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

Last change on this file since 14258 was 14258, checked in by gz, 10 years ago

Defstruct changes: Get rid of *defstruct-share-accessor-functions*. Typecheck the structure object in copiers, accessors -- both the accessor functions and compiler transforms -- unless nx-inhibit-safety-checking is true. Try to be more consistent about when/how typecheck struct slot types. Generate setter as well as getter functions.

Added new macro, TYPECHECK, that, depending on the value of nx-inhibit-safety-checking, turns into either a declaration or a require-type with approppriately downgraded type.

I had to turn off the typechecking (with optimize declarations) in a handful of places because of a bootstrapping problem: there are some structure types in the ARCH package which are referenced before the package exists, causing bootstrap to fail.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 17.3 KB
1;;;-*-Mode: LISP; Package: CCL -*-
3;;;   Copyright (C) 2009 Clozure Associates
4;;;   Copyright (C) 1994-2001 Digitool, Inc
5;;;   This file is part of Clozure CL. 
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. 
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
15;;;   The LLGPL is also available online at
18; defstruct-lds.lisp
20(in-package "CCL")
22(eval-when (eval compile)
23  (require 'defstruct-macros)
29(defun uvector-subtype-p (thing subtype-number)
30  (= (the fixnum (typecode thing)) subtype-number))
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))
39;(defmacro test (&rest args) `(macroexpand-1 (defstruct ,@args)))
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.
49   Popular DEFSTRUCT options (see manual for others):
51   (:CONSTRUCTOR Name)
52   (:PREDICATE Name)
53       Specify the name for the constructor or predicate.
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.)
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.
63   Slot options:
65   :TYPE Type-Spec
66       Asserts that the value of this slot is always of the specified type.
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        (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        ,.(if copier (defstruct-copier sd copier env))
262        ,.(if predicate (defstruct-predicate sd named predicate env))
263        ,.(%defstruct-compile sd refnames env)
264        ,.(defstruct-boa-constructors sd boa-constructors env)
265        ,.(if constructor (list (defstruct-constructor sd constructor env)))
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))
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))))
285(defun concat-pnames (name1 name2)
286  (intern (%str-cat (string name1) (string name2))))
288(defun wrap-with-typecheck (value slot env)
289  (let ((slot-type (defstruct-type-for-typecheck (ssd-type slot) env)))
290    (if (eq t slot-type)
291      value
292      `(typecheck ,value ,slot-type))))
294(defun make-class-cells-list (class-names)
295  (if (and (consp class-names)
296           (eq (car class-names) 'quote)
297           (consp (cdr class-names))
298           (null (cddr class-names))
299           (listp (cadr class-names))
300           (every #'symbolp (cadr class-names)))
301    `',(mapcar (lambda (name) (find-class-cell name t)) (cadr class-names))
302    class-names))
304(defun defstruct-constructor (sd constructor env &aux (offset 0)
305                                                      (args ())
306                                                      (values ())
307                                                      slot-offset
308                                                      name)
309  (dolist (slot (sd-slots sd))
310    (setq slot-offset (ssd-offset slot))
311    #-bccl (when (%i< slot-offset offset)
312             (error "slots out of order! ~S" (sd-slots sd)))
313    (while (%i< offset slot-offset)
314      (push nil values)
315      (setq offset (%i+ offset 1)))
316    (if (fixnump (setq name (ssd-name slot)))
317      (if (eql 0 name)
318        (push (make-class-cells-list (ssd-initform slot)) values) 
319        (push (wrap-with-typecheck (ssd-initform slot) slot env) values))
320      (let* ((temp (make-symbol (symbol-name name))))
321        (push (list (list (make-keyword name) temp) (ssd-initform slot)) args)
322        (push (wrap-with-typecheck temp slot env) values)))
323    (setq offset (%i+ offset 1)))
324  (setq values (nreverse values))
325  `(defun ,constructor (&key ,@(nreverse args))
326     ,(case (setq name (defstruct-reftype (sd-type sd)))
327          (#.$defstruct-nth `(list ,@values))
328          ( `(vector ,@values))
329          (( #.$defstruct-struct)
330           `(gvector :struct ,@values))
331          (t `(uvector ,name ,@values)))))
333(defun defstruct-boa-constructors (sd boas env &aux (list ()))
334  (dolist (boa boas list)
335    (push (defstruct-boa-constructor sd boa env) list)))
337(defun defstruct-boa-constructor (sd boa env &aux (args ())
338                                     (used-slots ())
339                                     (values ())
340                                     (offset 0)
341                                     arg-kind slot slot-offset)
342  (unless (verify-lambda-list (cadr boa))
343    (error "Invalid lambda-list in ~S ." (cons :constructor boa)))
344  (dolist (arg (cadr boa))
345    (cond ((memq arg lambda-list-keywords)
346           (setq arg-kind arg))
347          ((setq slot (named-ssd arg (sd-slots sd)))
348           (when (or (eq arg-kind '&optional) (eq arg-kind '&key)
349                     ;; for &aux variables, init value is
350                     ;; implementation-defined, however it's not
351                     ;; supposed to signal a type error until slot is
352                     ;; assigned, so might as well just use the
353                     ;; initform.
354                     (eq arg-kind '&aux))
355             (setq arg (list arg (ssd-initform slot))))
356           (push slot used-slots))
357          ((and (consp arg) (setq slot (named-ssd (if (consp (%car arg)) (%cadar arg) (%car arg)) (sd-slots sd))))
358           (push slot used-slots))
359          (t nil))
360    (push arg args))
361  (dolist (slot (sd-slots sd))
362    (setq slot-offset (ssd-offset slot))
363    #-bccl (when (%i< slot-offset offset) (error "slots out of order! ~S" sd))
364    (while (%i< offset slot-offset)
365      (push nil values)
366      (setq offset (%i+ offset 1)))
367    (push (if (memq slot used-slots) (ssd-name slot)
368            (if (eql 0 (ssd-name slot))
369              (make-class-cells-list (ssd-initform slot))
370              (if (constantp (ssd-initform slot)) (ssd-initform slot)
371                (progn
372                  (unless (eq arg-kind '&aux)
373                    (push (setq arg-kind '&aux) args))
374                  (push (list (ssd-name slot) (ssd-initform slot)) args)
375                  (ssd-name slot)))))
376          values)
377    (setq offset (%i+ offset 1)))
378  (setq values (mapcar (lambda (v s) (wrap-with-typecheck v s env)) (nreverse values) (sd-slots sd)))
379  `(defun ,(car boa) ,(nreverse args)
380     ,(case (setq slot (defstruct-reftype (sd-type sd)))
381        (#.$defstruct-nth `(list ,@values))
382        ( `(vector ,@values))
383        (( #.$defstruct-struct)
384         `(gvector :struct ,@values))
385        (t `(uvector ,slot ,@values)))))
387(defun defstruct-copier (sd copier env)
388  (let* ((sd-name (sd-name sd))
389         (sd-type (sd-type sd))
390         (var (defstruct-var sd-name env))
391         (arg (if sd-type var `(typecheck ,var ,sd-name)))
392         (fn (if (eq sd-type 'list) 'copy-list 'copy-uvector)))
393    `((defun ,copier (,var) (,fn ,arg)))))
395(defun defstruct-predicate (sd named predicate env)
396  (declare (ignore env))
397  (let* ((arg (gensym))
398         (sd-name (sd-name sd))
399         (body
400          (case (sd-type sd)
401            ((nil) `(structure-typep ,arg ',(find-class-cell sd-name t)))
402            ((list) `(and (consp ,arg) (eq (nth ,named ,arg) ',sd-name)))
403            (t `(and (uvector-subtype-p ,arg ,(defstruct-reftype (sd-type sd)))
404               (< ,named (uvsize ,arg))
405               (eq (uvref ,arg ,named) ',sd-name))))))
406    `((defun ,predicate (,arg) ,body))))
408; End of defstruct-lds.lisp
Note: See TracBrowser for help on using the repository browser.