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

Last change on this file since 13788 was 13788, checked in by rme, 10 years ago

In the DEFSTRUCT macro, define constructors later so that
something like

(defstruct foo

(a nil :type (or null foo)))

works without warning about "unknown or invalid type FOO".

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