source: trunk/source/lib/defstruct-lds.lisp @ 9240

Last change on this file since 9240 was 9240, checked in by gz, 13 years ago

Propagate r9237 to trunk: Stop ignoring defstruct slot type
specifiers. Types are checked unconditionally (i.e. regardless of
safety settings) by constructors and slot setters.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 16.4 KB
1;;;-*-Mode: LISP; Package: CCL -*-
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
14;;;   The LLGPL is also available online at
17; defstruct-lds.lisp
19(in-package "CCL")
21(eval-when (eval compile)
22  (require 'defstruct-macros)
28(defun uvector-subtype-p (thing subtype-number)
29  (= (the fixnum (typecode thing)) subtype-number))
31(defun uvector (subtype &rest p)
32  (declare (dynamic-extent p))
33  (let ((n (length p)) (uv))
34    (setq uv  (%alloc-misc n subtype))
35    (dotimes (i (the fixnum n)) (declare (fixnum i)) (uvset uv i (pop p)))
36    uv))
38;(defmacro test (&rest args) `(macroexpand-1 (defstruct ,@args)))
40;--> To do: compiler transform for copier, possibly constructor.
41(defmacro defstruct (options &rest slots &environment env)
42  "DEFSTRUCT {Name | (Name Option*)} {Slot | (Slot [Default] {Key Value}*)}
43   Define the structure type Name. Instances are created by MAKE-<name>,
44   which takes &KEY arguments allowing initial slot values to the specified.
45   A SETF'able function <name>-<slot> is defined for each slot to read and
46   write slot values. <name>-p is a type predicate.
48   Popular DEFSTRUCT options (see manual for others):
50   (:CONSTRUCTOR Name)
51   (:PREDICATE Name)
52       Specify the name for the constructor or predicate.
54   (:CONSTRUCTOR Name Lambda-List)
55       Specify the name and arguments for a BOA constructor
56       (which is more efficient when keyword syntax isn't necessary.)
58   (:INCLUDE Supertype Slot-Spec*)
59       Make this type a subtype of the structure type Supertype. The optional
60       Slot-Specs override inherited slot options.
62   Slot options:
64   :TYPE Type-Spec
65       Asserts that the value of this slot is always of the specified type.
67   :READ-ONLY {T | NIL}
68       If true, no setter function is defined for this slot."
69  ;There's too much state to keep around here to break it up into little
70  ;functions, so what the hell, let's do it all inline...
71  (prog (struct-name type conc-name constructor copier predicate include
72         print-function print-object  named initial-offset boa-constructors print-p
73         documentation (slot-list ()) (offset 0) superclasses sd
74         refnames)
75    ;Parse options
76    (if (atom options)
77      (setq struct-name options options ())
78      (setq struct-name (pop options)))
79    (unless (symbolp struct-name) (signal-program-error $XNotSym struct-name))
80    (let (name args constructor-p predicate-p)
81      (while options
82        (if (atom (car options))
83          (setq name (%car options) args ())
84          (setq name (%caar options) args (%cdar options)))
85        (case name
86          (:conc-name
87           (when conc-name (go dup-options))
88           (when (cdr args) (go bad-options))
89           (setq conc-name (or args (list nil))))
90          (:constructor
91           (when (cddr args) (go bad-options))
92           (cond ((cdr args) (push args boa-constructors))
93                 (t (when constructor (go dup-options))
94                    (unless (symbolp (%car args)) (go bad-options))
95                    (setq constructor-p t constructor args))))
96          (:copier
97           (when copier (go dup-options))
98           (when (or (cdr args) (not (symbolp (%car args)))) (go bad-options))
99           (setq copier args))
100          (:predicate
101           (when predicate (go dup-options))
102           (when (or (cdr args) (not (symbolp (%car args)))) (go bad-options))
103           (setq predicate-p t predicate args))
104          (:include
105           (when include (go dup-options))
106           (when (or (null args) (not (symbolp (car args)))) (go bad-options))
107           (setq include args))
108          ((:print-function :print-object)
109           (when print-function (go dup-options))
110           (when (or (cdr args)
111                     (not (or (symbolp (%car args))
112                              (and (consp (%car args)) (eq (%caar args) 'lambda)))))
113             (go bad-options))
114           (setq print-p t
115                 print-function (%car args)
116                 print-object (eq name :print-object)))
117          (:type
118           (when type (go dup-options))
119           (when (cdr args) (go bad-options))
120           (unless (eq (setq type (%car args)) 'list)
121             (when (eq type 'vector) (setq type '(vector t)))
122             (when (or (atom type) (neq (%car type) 'vector) (cdr (%cdr type)))
123               (go bad-options))))
124          (:named
125           (when args (go bad-options))
126           (setq named t))
127          (:initial-offset
128           (when initial-offset (go dup-options))
129           (when (or (cdr args) (not (fixnump (%car args))) (%i< (%car args) 0))
130             (go bad-options))
131           (setq initial-offset (%car args)))
132          (t (go bad-options)))
133        (setq options (%cdr options)))
134      ;Options parsed!  Do defaulting and some consistency checking.
135      (cond (type
136             (when (null (defstruct-reftype type)) ;e.g. (vector NIL)
137               (bad-named-arg :type type))
138             (when print-p
139               (error "Cannot specify ~S with ~S" :print-function :type))
140             (if (and named (consp type) (eq (car type) 'vector)
141                      (cadr type) (not (subtypep 'symbol (cadr type))))
142               (error "Cannot specify ~S with type: ~S" :named type))
143             )
144            ((built-in-type-p struct-name)
145             (error "Cannot redefine built-in type ~S" struct-name))
146            (initial-offset
147             (error "Cannot use ~S without ~S" :initial-offset :type))
148            (t (setq named t)))
149      (if (not named)
150        (when predicate-p
151          (unless (null (setq predicate (%car predicate)))
152            (error "Cannot specify :PREDICATE for an unnamed structure")))
153        (setq predicate (if (null predicate)
154                          (concat-pnames struct-name "-P")
155                          (%car predicate))))
156      (setq conc-name
157            (if (null conc-name) (%str-cat (symbol-name struct-name) "-")
158                (if (%car conc-name) (string (%car conc-name)))))
159      (unless (and boa-constructors (not constructor-p))
160        (setq constructor
161              (if (null constructor)
162                (concat-pnames "MAKE-" struct-name) (%car constructor))))
163      (setq copier
164            (if (null copier) (concat-pnames "COPY-" struct-name) (%car copier))))
165    ;Process included slots
166    (when include
167      (let* ((included-name (%car include))
168             (sub-sd (or (let* ((defenv (definition-environment env)))
169                          (when defenv (%cdr (assq included-name (defenv.structures defenv)))))
170                         (gethash included-name %defstructs%)))
171            (slots (%cdr include))
172            name args ssd)
173        (unless sub-sd (error "No such structure: ~S" (cons :include include)))
174        (unless (eq (defstruct-reftype type)
175                    (defstruct-reftype (sd-type sub-sd)))
176          (error "Incompatible structure type ~S for ~S"
177                 (sd-type sub-sd) (cons :include include)))
178        (dolist (ssd (sd-slots sub-sd)) (push
179                                         (let* ((new-ssd (copy-ssd ssd)))
180                                           (ssd-set-inherited new-ssd)
181                                           new-ssd)
182                                           slot-list))
183        (while slots
184          (if (atom (car slots))
185            (setq name (%car slots) args ())
186            (setq name (%caar slots) args (%cdar slots)))
187          (unless (symbolp name) (signal-program-error $XNotSym name))
188          (unless (setq ssd (named-ssd name slot-list))
189            (error "~S has no ~S slot, in ~S"
190                   (sd-name sub-sd) name (cons :include include)))
191          (ssd-set-initform ssd (pop args))
192          (while args
193            (when (atom (cdr args)) (signal-program-error "~S is not a proper list" (cdr args)))
194            (cond ((eq (%car args) :type) )
195                  ((eq (%car args) :read-only)
196                   (when (and (not (%cadr args)) (ssd-r/o ssd))
197                     (signal-program-error "Slot ~S in ~S must be read-only" name (sd-name sub-sd)))
198                   (when (%cadr args) (ssd-set-r/o ssd)))
199                  (t (signal-program-error "~S must be  (member :type :read-only)." (%car args))))
200            (setq args (%cddr args)))
201          (setq slots (%cdr slots)))
202        (setq offset (sd-size sub-sd))
203        (setq superclasses (sd-superclasses sub-sd))))
204    (push struct-name superclasses)
205    ;Now add own slots
206    (setq offset (%i+ offset (or initial-offset 0)))
207    (when (and named (or type (not include)))
208      (push (make-ssd 0 (if type `',struct-name `',superclasses) offset t) slot-list)
209      (setq named offset offset (%i+ offset 1)))
210    (when (stringp (%car slots))
211      (setq documentation (%car slots) slots (%cdr slots)))
212    (let (name args read-only initform slot-type)
213      (while slots
214         (if (atom (%car slots))
215           (setq name (%car slots) args ())
216           (setq name (%caar slots) args (%cdar slots)))
217         (unless (symbolp name) (go bad-slot))
218         (setq read-only nil initform (pop args) slot-type t)
219         (while args
220            (when (atom (cdr args)) (go bad-slot))
221            ;; To do: check for multiple/incompatible options.
222            (cond ((eq (%car args) :type)
223                   (setq slot-type (%cadr args)))
224                  ((eq (%car args) :read-only)
225                   (setq read-only (%cadr args)))
226                  (t (go bad-slot)))
227            (setq args (%cddr args)))
228         (push (make-ssd name initform offset read-only slot-type) slot-list)
229         (setq slots (%cdr slots) offset (%i+ offset 1))))
231    (setq slot-list (nreverse slot-list))
232    (when (and (null type) include)
233      (ssd-set-initform (car slot-list) `',superclasses))
234    (progn ;when conc-name
235      (dolist (slot slot-list)
236        (unless (fixnump (ssd-name slot))
237          (push (if conc-name
238                  (concat-pnames conc-name (ssd-name slot))
239                  (ssd-name slot))
240                refnames)))
241      (setq refnames (nreverse refnames)))
242    (setq sd (vector type slot-list superclasses offset constructor () refnames))
243    (return
244     `(progn
245       (remove-structure-defs  ',struct-name) ; lose any previous defs
246        ,(defstruct-slot-defs sd refnames env)
247        ,.(if constructor (list (defstruct-constructor sd constructor)))
248        ,.(defstruct-boa-constructors sd boa-constructors)
249        ,.(if copier (list (defstruct-copier sd copier env)))
250        ,.(if predicate (defstruct-predicate sd named predicate))
251        (eval-when (:compile-toplevel)
252          (define-compile-time-structure 
253            ',sd 
254            ',refnames 
255            ,(if (and predicate (null (sd-type sd))) `',predicate)
256            ,env))       
257        (%defstruct-do-load-time
258         ',sd
259         ,(if (and predicate (null (sd-type sd))) `',predicate)
260         ,.(if documentation (list documentation)))
261        ,(%defstruct-compile sd refnames)
262       ;; Wait until slot accessors are defined, to avoid
263       ;; undefined function warnings in the print function/method.
264       (%defstruct-set-print-function
265        ',sd
266        ,(if print-function
267          (if (symbolp print-function)
268            `',print-function
269            `#',print-function)
270          (unless print-p (if include 0)))
271        ,print-object)
272        ',struct-name))
274    dup-options
275     (error "Duplicate ~S options not allowed" (%car options))
276    bad-options
277     (signal-program-error "Bad defstruct option ~S." (%car options))
278    bad-slot
279    (signal-program-error "Bad defstruct slot spec ~S." (%car slots))))
281(defun concat-pnames (name1 name2)
282  (intern (%str-cat (string name1) (string name2))))
284(defun wrap-with-type-check (value slot &aux (slot-type (ssd-type slot)))
285  (if (eq t slot-type)
286    value
287    `(require-type ,value ',slot-type)))
289(defun defstruct-constructor (sd constructor &aux (offset 0)
290                                                  (args ())
291                                                  (values ())
292                                                  slot-offset
293                                                  name)
294  (dolist (slot (sd-slots sd))
295    (setq slot-offset (ssd-offset slot))
296    #-bccl (when (%i< slot-offset offset)
297             (error "slots out of order! ~S" (sd-slots sd)))
298    (while (%i< offset slot-offset)
299      (push nil values)
300      (setq offset (%i+ offset 1)))
301    (if (fixnump (setq name (ssd-name slot)))
302      (push (wrap-with-type-check (ssd-initform slot) slot) values)
303      (let* ((temp (make-symbol (symbol-name name))))
304        (push (list (list (make-keyword name) temp) (ssd-initform slot)) args)
305        (push (wrap-with-type-check temp slot) values)))
306    (setq offset (%i+ offset 1)))
307  (setq values (nreverse values))
308  `(defun ,constructor (&key ,@(nreverse args))
309     ,(case (setq name (defstruct-reftype (sd-type sd)))
310          (#.$defstruct-nth `(list ,@values))
311          ( `(vector ,@values))
312          (( #.$defstruct-struct)
313           `(gvector :struct ,@values))
314          (t `(uvector ,name ,@values)))))
316(defun defstruct-boa-constructors (sd boas &aux (list ()))
317  (dolist (boa boas list)
318    (push (defstruct-boa-constructor sd boa) list)))
320(defun defstruct-boa-constructor (sd boa &aux (args ())
321                                              (used-slots ())
322                                              (values ())
323                                              (offset 0)
324                                              arg-kind slot slot-offset)
325  (unless (verify-lambda-list (cadr boa))
326    (error "Invalid lambda-list in ~S ." (cons :constructor boa)))
327  (dolist (arg (cadr boa))
328    (cond ((memq arg lambda-list-keywords)
329           (setq arg-kind arg))
330          ((setq slot (named-ssd arg (sd-slots sd)))
331           (when (or (eq arg-kind '&optional) (eq arg-kind '&key)
332                     ;; for &aux variables, init value is implementation-defined, however it's not supposed
333                     ;; to signal a type error until slot is assigned, so might as well just use the initform.
334                     (eq arg-kind '&aux))
335             (setq arg (list arg (ssd-initform slot))))
336           (push slot used-slots))
337          ((and (consp arg) (setq slot (named-ssd (if (consp (%car arg)) (%cadar arg) (%car arg)) (sd-slots sd))))
338           (push slot used-slots))
339          (t nil))
340    (push arg args))
341  (dolist (slot (sd-slots sd))
342    (setq slot-offset (ssd-offset slot))
343    #-bccl (when (%i< slot-offset offset) (error "slots out of order! ~S" sd))
344    (while (%i< offset slot-offset)
345      (push nil values)
346      (setq offset (%i+ offset 1)))
347    (push (if (memq slot used-slots) (ssd-name slot)
348              (if (constantp (ssd-initform slot)) (ssd-initform slot)
349                  (progn
350                    (unless (eq arg-kind '&aux)
351                      (push (setq arg-kind '&aux) args))
352                    (push (list (ssd-name slot) (ssd-initform slot)) args)
353                    (ssd-name slot))))
354          values)
355    (setq offset (%i+ offset 1)))
356  (setq values (mapcar #'wrap-with-type-check (nreverse values) (sd-slots sd)))
357  `(defun ,(car boa) ,(nreverse args)
358     ,(case (setq slot (defstruct-reftype (sd-type sd)))
359          (#.$defstruct-nth `(list ,@values))
360          ( `(vector ,@values))
361          (( #.$defstruct-struct)
362           `(gvector :struct ,@values))
363          (t `(uvector ,slot ,@values)))))
365(defun defstruct-copier (sd copier env)
366  `(progn
367     (eval-when (:compile-toplevel)
368       (record-function-info ',copier (list (list (encode-lambda-list '(x)))) ,env))
369     (fset ',copier
370           ,(if (eq (sd-type sd) 'list) '#'copy-list '#'copy-uvector))
371     (record-source-file ',copier 'function)))
372;;; (put 'COPY-SHIP 'nx-alias 'copy-list)
374(defun defstruct-predicate (sd named predicate &aux (arg (gensym)))
375  (let* ((sd-name (sd-name sd))
376         (body
377          (case (sd-type sd)
378            ((nil) `(structure-typep ,arg ',sd-name))
379            ((list) `(and (consp ,arg) (eq (nth ,named ,arg) ',sd-name)))
380            (t `(and (uvector-subtype-p ,arg ,(defstruct-reftype (sd-type sd)))
381               (< ,named (uvsize ,arg))
382               (eq (uvref ,arg ,named) ',sd-name))))))
383    `((setf (symbol-function ',predicate) #'(lambda (,arg) ,body)))))
385; End of defstruct-lds.lisp
Note: See TracBrowser for help on using the repository browser.