/
custom.lisp
119 lines (97 loc) · 3.74 KB
/
custom.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;; See the file LICENCE for licence information.
(in-package :cl-store)
; special floats
(defun create-float-values (value &rest codes)
"Returns a alist of special float to float code mappings."
(ext:with-float-traps-masked (:overflow :invalid)
(let ((neg-inf (expt value 3)))
(mapcar 'cons
(list (expt (abs value) 2)
neg-inf
(/ neg-inf neg-inf))
codes))))
;; Custom Structures
(defstore-cl-store (obj structure-object stream)
(output-type-code +structure-object-code+ stream)
(store-type-object obj stream))
(defrestore-cl-store (structure-object stream)
(restore-type-object stream))
;; Structure definitions
(defun get-layout (obj)
(slot-value obj 'pcl::wrapper))
(defun get-info (obj)
(declare (type kernel:layout obj))
(slot-value obj 'ext:info))
(defun dd-name (dd)
(slot-value dd 'kernel::name))
(defvar *cmucl-struct-inherits*
(list (get-layout (find-class t))
(get-layout (find-class 'kernel:instance))
(get-layout (find-class 'cl:structure-object))))
(defstruct (struct-def (:conc-name sdef-))
(supers (required-arg :supers) :type list)
(info (required-arg :info) :type kernel:defstruct-description))
(defun info-or-die (obj)
(let ((wrapper (get-layout obj)))
(if wrapper
(or (get-info wrapper)
(store-error "No defstruct-definition for ~A." obj))
(store-error "No wrapper for ~A." obj))))
(defun save-able-supers (obj)
(set-difference (coerce (slot-value (get-layout obj) 'kernel::inherits)
'list)
*cmucl-struct-inherits*))
(defun get-supers (obj)
(loop for x in (save-able-supers obj)
collect (let ((name (dd-name (get-info x))))
(if *store-class-superclasses*
(find-class name)
name))))
(defstore-cl-store (obj structure-class stream)
(output-type-code +structure-class-code+ stream)
(store-object (make-struct-def :info (info-or-die obj)
:supers (get-supers obj))
stream))
(defstore-cl-store (obj struct-def stream)
(output-type-code +struct-def-code+ stream)
(store-object (sdef-supers obj) stream)
(store-object (sdef-info obj) stream))
;; Restoring
(defun cmu-struct-defs (dd)
(append (kernel::define-constructors dd)
(kernel::define-raw-accessors dd)
(kernel::define-class-methods dd)))
(defun create-make-foo (dd)
(let ((*compile-print* nil))
(funcall (compile nil `(lambda () ,@(cmu-struct-defs dd))))
(find-class (dd-name dd))))
(defun cmu-define-structure (dd supers)
(cond ((or *nuke-existing-classes*
(not (find-class (dd-name dd) nil)))
;; create-struct
(kernel::%defstruct dd supers)
;; compiler stuff
;;(kernel::%compiler-defstruct dd)
;; create make-?
(create-make-foo dd))
(t (find-class (dd-name dd)))))
(defun super-layout (super)
(etypecase super
(symbol (get-layout (find-class super)))
(structure-class
(super-layout (dd-name (info-or-die super))))))
(defun super-layouts (supers)
(loop for super in supers
collect (super-layout super)))
(defrestore-cl-store (structure-class stream)
(restore-object stream))
(defrestore-cl-store (struct-def stream)
(let* ((supers (super-layouts (restore-object stream)))
(dd (restore-object stream)))
(cmu-define-structure dd (if supers
(coerce (append *cmucl-struct-inherits*
supers)
'vector)
(coerce *cmucl-struct-inherits* 'vector)))))
;; EOF