source: branches/qres/ccl/lib/defstruct-lds.lisp @ 14057

Last change on this file since 14057 was 14057, checked in by gz, 9 years ago

Couple defstruct fixes from trunk (r13590, r13788)

  • 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-check (value slot &aux (slot-type (ssd-type slot)))
289  (if (eq t slot-type)
290    value
291    `(require-type ,value ',slot-type)))
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-check (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-check 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-check (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.