Skip to content
Newer
Older
100644 224 lines (205 sloc) 10.5 KB
cb1af35 Establish Cells II (aka Cells 2.0, aka Cells) as Cells module in Cell…
ktilton authored May 6, 2005
1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
8faef55 A slow tedious transition to LLGPL
ktilton authored May 20, 2006
2 #|
3
4 Cells -- Automatic Dataflow Managememnt
5
6 Copyright (C) 1995, 2006 by Kenneth Tilton
7
8 This library is free software; you can redistribute it and/or
9 modify it under the terms of the Lisp Lesser GNU Public License
10 (http://opensource.franz.com/preamble.html), known as the LLGPL.
11
12 This library is distributed WITHOUT ANY WARRANTY; without even
13 the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
14
15 See the Lisp Lesser GNU Public License for more details.
16
17 |#
cb1af35 Establish Cells II (aka Cells 2.0, aka Cells) as Cells module in Cell…
ktilton authored May 6, 2005
18
19 (in-package :cells)
20 (defmacro defmodel (class directsupers slotspecs &rest options)
21 ;;(print `(defmodel sees directsupers ,directsupers using ,(or directsupers :model-object)))
236a354 Hope I have not broken things, but consider this a warning: I may have.
ktilton authored Oct 2, 2006
22 (assert (not (find class directsupers))() "~a cannot be its own superclass" class)
cb1af35 Establish Cells II (aka Cells 2.0, aka Cells) as Cells module in Cell…
ktilton authored May 6, 2005
23 `(progn
8e89a4c Just trying to get a patch in for record-caller
ktilton authored Oct 12, 2008
24 (setf (get ',class :cell-types) nil)
25 (setf (get ',class 'slots-excluded-from-persistence)
b5cf857 @Ramarren Add ensure-generic-function to get rid of sbcl style warnings
authored Feb 3, 2009
26 (loop for slotspec in ',slotspecs
27 unless (and (getf (cdr slotspec) :ps t)
28 (getf (cdr slotspec) :persistable t))
29 collect (car slotspec)))
8e89a4c Just trying to get a patch in for record-caller
ktilton authored Oct 12, 2008
30 (loop for slotspec in ',slotspecs
b5cf857 @Ramarren Add ensure-generic-function to get rid of sbcl style warnings
authored Feb 3, 2009
31 do (destructuring-bind
32 (slotname &rest slotargs
33 &key (cell t)
34 &allow-other-keys)
35 slotspec
36 (declare (ignorable slotargs))
37 (when cell
38 (setf (md-slot-cell-type ',class slotname) cell))))
24d3207 @Ramarren Ensure generic functions even earlier to shut up CCL warnings, remove…
authored Jun 30, 2009
39 ;; ensure accessors generic functions
40 ,@(mapcan (lambda (slotspec)
41 (destructuring-bind
42 (slotname &rest slotargs
43 &key (cell t) unchanged-if (accessor slotname) reader writer type
44 &allow-other-keys)
45 slotspec
46 (declare (ignorable slotargs unchanged-if type))
47 (when cell
48 (let ((reader-fn (or reader accessor))
49 (writer-fn (or writer accessor)))
50 (remove nil
51 (list
52 (when reader-fn
beb09a0 @Ramarren Ensure generic functions during compilation time as well.
authored Jan 20, 2010
53 `(eval-when (:compile-toplevel :load-toplevel :execute)
54 (ensure-generic-function ',reader-fn :lambda-list '(self))))
24d3207 @Ramarren Ensure generic functions even earlier to shut up CCL warnings, remove…
authored Jun 30, 2009
55 (when writer-fn
beb09a0 @Ramarren Ensure generic functions during compilation time as well.
authored Jan 20, 2010
56 `(eval-when (:compile-toplevel :load-toplevel :execute)
57 (ensure-generic-function '(setf ,writer-fn) :lambda-list '(new-value self))))))))))
24d3207 @Ramarren Ensure generic functions even earlier to shut up CCL warnings, remove…
authored Jun 30, 2009
58 slotspecs)
e5e5c65 *** empty log message ***
ktilton authored Dec 12, 2006
59 ;; define slot macros before class so they can appear in
8e89a4c Just trying to get a patch in for record-caller
ktilton authored Oct 12, 2008
60 ;; initforms and default-initargs
61 ,@(loop for slotspec in slotspecs
b5cf857 @Ramarren Add ensure-generic-function to get rid of sbcl style warnings
authored Feb 3, 2009
62 nconcing (destructuring-bind
63 (slotname &rest slotargs
64 &key (cell t) (accessor slotname) reader
65 &allow-other-keys)
66 slotspec
67 (declare (ignorable slotargs ))
68 (when cell
69 (list (let* ((reader-fn (or reader accessor))
70 (deriver-fn (intern$ "^" (symbol-name reader-fn))))
71 `(eval-when (:compile-toplevel :execute :load-toplevel)
72 (unless (macro-function ',deriver-fn)
73 (defmacro ,deriver-fn ()
24d3207 @Ramarren Ensure generic functions even earlier to shut up CCL warnings, remove…
authored Jun 30, 2009
74 `(,',reader-fn self)))))))))
b5cf857 @Ramarren Add ensure-generic-function to get rid of sbcl style warnings
authored Feb 3, 2009
75 ;
76 ; ------- defclass --------------- (^slot-value ,model ',',slotname)
77 ;
ea3503f @Ramarren Shut up "can't find type for specializer" warnings.
authored Dec 30, 2008
78 (defclass ,class ,(or directsupers '(model-object)) ;; now we can def the class
79 ,(mapcar (lambda (s)
80 (list* (car s)
81 (let ((ias (cdr s)))
82 (remf ias :persistable)
83 (remf ias :ps)
84 ;; We handle accessor below
85 (when (getf ias :cell t)
86 (remf ias :reader)
87 (remf ias :writer)
88 (remf ias :accessor))
89 (remf ias :cell)
90 (remf ias :owning)
91 (remf ias :unchanged-if)
92 ias))) (mapcar #'copy-list slotspecs))
93 (:documentation
94 ,@(or (cdr (find :documentation options :key #'car))
95 '("chya")))
96 (:default-initargs ;; nil ok and needed: acl oddity in re not clearing d-i's sans this
97 ,@(cdr (find :default-initargs options :key #'car)))
98 (:metaclass ,(or (cadr (find :metaclass options :key #'car))
99 'standard-class)))
24d3207 @Ramarren Ensure generic functions even earlier to shut up CCL warnings, remove…
authored Jun 30, 2009
100 (defmethod shared-initialize :after ((self ,class) slot-names &rest iargs &key)
101 (declare (ignore slot-names iargs))
102 ,(when (and directsupers (not (member 'model-object directsupers)))
103 `(unless (typep self 'model-object)
104 (error "If no superclass of ~a inherits directly
cb1af35 Establish Cells II (aka Cells 2.0, aka Cells) as Cells module in Cell…
ktilton authored May 6, 2005
105 or indirectly from model-object, model-object must be included as a direct super-class in
106 the defmodel form for ~a" ',class ',class))))
8e89a4c Just trying to get a patch in for record-caller
ktilton authored Oct 12, 2008
107
b5cf857 @Ramarren Add ensure-generic-function to get rid of sbcl style warnings
authored Feb 3, 2009
108 ;
109 ; slot accessors once class is defined...
110 ;
24d3207 @Ramarren Ensure generic functions even earlier to shut up CCL warnings, remove…
authored Jun 30, 2009
111 ,@(mapcan (lambda (slotspec)
112 (destructuring-bind
113 (slotname &rest slotargs
114 &key (cell t) unchanged-if (accessor slotname) reader writer type
115 &allow-other-keys)
116 slotspec
236a354 Hope I have not broken things, but consider this a warning: I may have.
ktilton authored Oct 2, 2006
117
24d3207 @Ramarren Ensure generic functions even earlier to shut up CCL warnings, remove…
authored Jun 30, 2009
118 (declare (ignorable slotargs))
119 (when cell
120 (let* ((reader-fn (or reader accessor))
121 (writer-fn (or writer accessor)))
122 (remove nil
123 (list
124 (when writer-fn
125 `(defmethod (setf ,writer-fn) (new-value (self ,class))
126 (setf (md-slot-value self ',slotname)
127 ,(if type
128 `(coerce new-value ',type)
129 'new-value))))
130 (when reader-fn
131 `(defmethod ,reader-fn ((self ,class))
132 (md-slot-value self ',slotname)))
133 (when unchanged-if
134 `(def-c-unchanged-test (,class ,slotname) ,unchanged-if))))))))
135 slotspecs)
136 (loop for slotspec in ',slotspecs
137 do (destructuring-bind
138 (slotname &rest slotargs &key (cell t) owning &allow-other-keys)
139 slotspec
140 (declare (ignorable slotargs))
141 (when (and cell owning)
142 (setf (md-slot-owning-direct? ',class slotname) owning))))
143 (find-class ',class)))
5f84137 *** empty log message ***
ktilton authored Jun 20, 2006
144
145 (defun defmd-canonicalize-slot (slotname
c631b54 *** empty log message ***
ktilton authored Nov 13, 2006
146 &key
147 (cell nil cell-p)
e5e5c65 *** empty log message ***
ktilton authored Dec 12, 2006
148 (ps t ps-p)
149 (persistable t persistable-p)
6649040 New :owning slot parameter automates NOT-TO-BE of slot contents as va…
ktilton authored Sep 5, 2006
150 (owning nil owning-p)
4b24693 New abbreviated defmodel: defmd
ktilton authored Jun 23, 2006
151 (type nil type-p)
c631b54 *** empty log message ***
ktilton authored Nov 13, 2006
152 (initform nil initform-p)
153 (initarg (intern (symbol-name slotname) :keyword))
154 (documentation nil documentation-p)
155 (unchanged-if nil unchanged-if-p)
156 (reader slotname reader-p)
157 (writer `(setf ,slotname) writer-p)
158 (accessor slotname accessor-p)
159 (allocation nil allocation-p))
5f84137 *** empty log message ***
ktilton authored Jun 20, 2006
160 (list* slotname :initarg initarg
161 (append
162 (when cell-p (list :cell cell))
e5e5c65 *** empty log message ***
ktilton authored Dec 12, 2006
163 (when ps-p (list :ps ps))
164 (when persistable-p (list :persistable persistable))
6649040 New :owning slot parameter automates NOT-TO-BE of slot contents as va…
ktilton authored Sep 5, 2006
165 (when owning-p (list :owning owning))
4b24693 New abbreviated defmodel: defmd
ktilton authored Jun 23, 2006
166 (when type-p (list :type type))
5f84137 *** empty log message ***
ktilton authored Jun 20, 2006
167 (when initform-p (list :initform initform))
168 (when unchanged-if-p (list :unchanged-if unchanged-if))
169 (when reader-p (list :reader reader))
170 (when writer-p (list :writer writer))
171 (when (or accessor-p
172 (not (and reader-p writer-p)))
173 (list :accessor accessor))
174 (when allocation-p (list :allocation allocation))
175 (when documentation-p (list :documentation documentation)))))
176
177 (defmacro defmd (class superclasses &rest mdspec)
852b833 CVS sucks
ktilton authored Aug 21, 2006
178 `(defmodel ,class (,@superclasses model)
5f84137 *** empty log message ***
ktilton authored Jun 20, 2006
179 ,@(let (definitargs class-options slots)
180 (loop with skip
181 for (spec next) on mdspec
182 if skip
183 do (setf skip nil)
184 else do (etypecase spec
185 (cons
186 (cond
187 ((keywordp (car spec))
188 (assert (find (car spec) '(:documentation :metaclass)))
189 (push spec class-options))
e5e5c65 *** empty log message ***
ktilton authored Dec 12, 2006
190 ((find (cadr spec) '(:initarg :type :ps :persistable :cell :initform :allocation :reader :writer :accessor :documentation))
5f84137 *** empty log message ***
ktilton authored Jun 20, 2006
191 (push (apply 'defmd-canonicalize-slot spec) slots))
192 (t ;; shortform (slotname initform &rest slotdef-key-values)
193 (push (apply 'defmd-canonicalize-slot
194 (list* (car spec) :initform (cadr spec) (cddr spec))) slots))))
195 (keyword
196 (setf definitargs (append definitargs (list spec next)))
197 (setf skip t))
198 (symbol (push (list spec :initform nil
199 :initarg (intern (symbol-name spec) :keyword)
200 :accessor spec) slots)))
201 finally
202 (return (list* (nreverse slots)
a87b9a4 *** empty log message ***
ktilton authored Jul 3, 2006
203 (delete nil
5f84137 *** empty log message ***
ktilton authored Jun 20, 2006
204 (list* `(:default-initargs ,@definitargs)
205 (nreverse class-options)))))))))
206
d565d12 nothing special
ktilton authored Jun 16, 2008
207
208
5f84137 *** empty log message ***
ktilton authored Jun 20, 2006
209 #+test
210 (progn
211 (defclass md-test-super ()())
cb1af35 Establish Cells II (aka Cells 2.0, aka Cells) as Cells module in Cell…
ktilton authored May 6, 2005
212
5f84137 *** empty log message ***
ktilton authored Jun 20, 2006
213 (defmd defmd-test (md-test-super)
214 (aaa :cell nil :initform nil :initarg :aaa :accessor aaa) ;; defmd would have written the same
215 (aa2 :documentation "hi mom")
216 bbb
217 (ccc 42 :allocation :class)
218 (ddd (c-in nil) :cell :ephemeral)
219 :superx 42 ;; default-initarg
e5e5c65 *** empty log message ***
ktilton authored Dec 12, 2006
220 (:documentation "as if!")))
7a387a1 *** empty log message ***
ktilton authored Nov 30, 2007
221
222
223
Something went wrong with that request. Please try again.