/[cmucl]/src/code/defstruct.lisp
ViewVC logotype

Diff of /src/code/defstruct.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.7 by ram, Mon Mar 5 11:57:43 1990 UTC revision 1.7.1.1 by wlott, Tue Mar 6 21:10:21 1990 UTC
# Line 7  Line 7 
7  ;;; Scott Fahlman (FAHLMAN@CMUC).  ;;; Scott Fahlman (FAHLMAN@CMUC).
8  ;;; **********************************************************************  ;;; **********************************************************************
9  ;;;  ;;;
10    ;;; $Header$
11    ;;;
12  ;;; Defstruct structure definition package (Mark II).  ;;; Defstruct structure definition package (Mark II).
13  ;;; Written by Skef Wholey and Rob MacLachlan.  ;;; Written by Skef Wholey and Rob MacLachlan.
14  ;;;  ;;;
# Line 31  Line 33 
33    (declare (ignore depth))    (declare (ignore depth))
34    (format stream "#<Defstruct-Description for ~S>" (dd-name structure)))    (format stream "#<Defstruct-Description for ~S>" (dd-name structure)))
35    
36    
37  ;;; DSD-Name  --  Internal  ;;; DSD-Name  --  Internal
38  ;;;  ;;;
39  ;;;    Return the the name of a defstruct slot as a symbol.  We store it  ;;;    Return the the name of a defstruct slot as a symbol.  We store it
# Line 42  Line 45 
45  (defun print-defstruct-slot-description (structure stream depth)  (defun print-defstruct-slot-description (structure stream depth)
46    (declare (ignore depth))    (declare (ignore depth))
47    (format stream "#<Defstruct-Slot-Description for ~S>" (dsd-name structure)))    (format stream "#<Defstruct-Slot-Description for ~S>" (dsd-name structure)))
   
   
48    
49  ;;; The legendary macro itself.  ;;; The legendary macro itself.
50    
# Line 69  Line 70 
70             ;; So the print function is in the right lexical environment, and             ;; So the print function is in the right lexical environment, and
71             ;; can be compiled...             ;; can be compiled...
72             (let ((new ',defstruct))             (let ((new ',defstruct))
73               ,@(let ((pf (dd-print-function defstruct)))               ,@(when (consp (dd-print-function defstruct))
74                   (when pf                   `((setf (dd-print-function new)
75                     `((setf (info type printer ',name)                           #',(dd-print-function defstruct))))
                            ,(if (symbolp pf)  
                                 `',pf  
                                 `#',pf)))))  
76               (%defstruct new))               (%defstruct new))
77             ',name)             ',name)
78          `(progn          `(progn
# Line 98  Line 96 
96        (setq name-and-options (list name-and-options)))        (setq name-and-options (list name-and-options)))
97    (do* ((options (cdr name-and-options) (cdr options))    (do* ((options (cdr name-and-options) (cdr options))
98          (name (car name-and-options))          (name (car name-and-options))
99          (print-function nil)          (print-function 'default-structure-print)
         (pf-supplied-p)  
100          (conc-name (concat-pnames name '-))          (conc-name (concat-pnames name '-))
101          (constructor (concat-pnames 'make- name))          (constructor (concat-pnames 'make- name))
102          (saw-constructor)          (saw-constructor)
# Line 149  Line 146 
146                                   (push args boa-constructors))                                   (push args boa-constructors))
147                                  (t                                  (t
148                                   (setq saw-constructor t)                                   (setq saw-constructor t)
149                                   (setq constructor                                   (setq constructor (car args)))))
                                        (or (car args)  
                                            (concat-pnames 'make- name))))))  
150              (:copier (setq copier (car args)))              (:copier (setq copier (car args)))
151              (:predicate (setq predicate (car args)))              (:predicate (setq predicate (car args)))
152              (:include              (:include (setq include args))
153               (setf include args)              (:print-function (setq print-function (car args)))
154               (let* ((name (car include))              (:type (setq saw-type t type (car args)))
                     (included-structure  
                      (info type structure-info name))  
                     (included-print-function  
                      (if included-structure  
                          (dd-print-function included-structure))))  
                (unless included-structure  
                  (error "Cannot find description of structure ~S to use for ~  
                          inclusion."  
                         name))  
                (unless pf-supplied-p  
                  (setf print-function included-print-function))))  
             (:print-function  
              (setf print-function (car args))  
              (setf pf-supplied-p t))  
             (:type (setf saw-type t type (car args)))  
155              (:named (error "The Defstruct option :NAMED takes no arguments."))              (:named (error "The Defstruct option :NAMED takes no arguments."))
156              (:initial-offset (setf offset (car args)))              (:initial-offset (setq offset (car args)))
157              (t (error "~S is an unknown Defstruct option." option)))))))              (t (error "~S is an unknown Defstruct option." option)))))))
   
   
158    
159  ;;;; Stuff to parse slot descriptions.  ;;; Parse-Slot-Descriptions parses the slot descriptions (surprise) and does
   
 ;;; PARSE-SLOT-DESCRIPTIONS parses the slot descriptions (surprise) and does  
160  ;;; any structure inclusion that needs to be done.  ;;; any structure inclusion that needs to be done.
161  ;;;  
162  (defun parse-slot-descriptions (defstruct slots)  (defun parse-slot-descriptions (defstruct slots)
163    ;; First strip off any doc string and stash it in the Defstruct.    ;; First strip off any doc string and stash it in the Defstruct.
164    (when (stringp (car slots))    (when (stringp (car slots))
# Line 231  Line 207 
207                                   (car options)))))))))))))                                   (car options)))))))))))))
208    ;; Finally parse the slots into Slot-Description objects.    ;; Finally parse the slots into Slot-Description objects.
209    (do ((slots slots (cdr slots))    (do ((slots slots (cdr slots))
210         (index (+ (dd-offset defstruct) (if (dd-named defstruct) 1 0))         (index (+ (dd-offset defstruct) (if (dd-named defstruct) 1 0)) (1+ index))
211                (1+ index))         (descriptions '()))
        (descriptions ()))  
212        ((null slots)        ((null slots)
213         (setf (dd-length defstruct) index)         (setf (dd-length defstruct) index)
214         (setf (dd-slots defstruct) (nreverse descriptions)))         (setf (dd-slots defstruct) (nreverse descriptions)))
215      (let* ((slot (car slots))      (let ((slot (car slots)))
            (name (if (atom slot) slot (car slot))))  
       (when (keywordp name)  
         (warn "Keyword slot name indicates possible syntax error in DEFSTRUCT ~  
                -- ~S."  
               name))  
216        (push        (push
217         (if (atom slot)         (if (atom slot)
218             (make-defstruct-slot-description             (let ((name slot))
219              :%name (string name)               (make-defstruct-slot-description
220              :index index                :%name (string name)
221              :accessor (concat-pnames (dd-conc-name defstruct) name)                :index index
222              :type t)                :accessor (concat-pnames (dd-conc-name defstruct) name)
223                  :type t))
224             (do ((options (cddr slot) (cddr options))             (do ((options (cddr slot) (cddr options))
225                    (name (car slot))
226                  (default (cadr slot))                  (default (cadr slot))
227                  (type t)                  (type t)
228                  (read-only nil))                  (read-only nil))
# Line 289  Line 261 
261  (defun typep-to-structure (obj info)  (defun typep-to-structure (obj info)
262    (declare (type defstruct-description info) (inline member))    (declare (type defstruct-description info) (inline member))
263    (and (structurep obj)    (and (structurep obj)
264         (let ((name (%primitive header-ref obj 0)))         (let ((name (%primitive structure-ref obj 0)))
265           (or (eq name (dd-name info))           (or (eq name (dd-name info))
266               (member name (dd-included-by info) :test #'eq)))))               (member name (dd-included-by info) :test #'eq)))))
267    
# Line 302  Line 274 
274  ;;;  ;;;
275  (defun %defstruct (info)  (defun %defstruct (info)
276    (declare (type defstruct-description info))    (declare (type defstruct-description info))
   (setf (info type defined-structure-info (dd-name info)) info)  
   
277    (dolist (slot (dd-slots info))    (dolist (slot (dd-slots info))
278      (let ((dsd slot))      (let ((dsd slot))
279        (setf (symbol-function (dsd-accessor slot))        (setf (symbol-function (dsd-accessor slot))
# Line 312  Line 282 
282                  (unless (typep-to-structure structure info)                  (unless (typep-to-structure structure info)
283                    (error "Structure for accessor ~S is not a ~S:~% ~S"                    (error "Structure for accessor ~S is not a ~S:~% ~S"
284                           (dsd-accessor dsd) (dd-name info) structure))                           (dsd-accessor dsd) (dd-name info) structure))
285                  (%primitive header-ref structure (dsd-index dsd))))                  (%primitive structure-ref structure (dsd-index dsd))))
286    
287        (unless (dsd-read-only slot)        (unless (dsd-read-only slot)
288          (setf (fdefinition `(setf ,(dsd-accessor slot)))          (setf (fdefinition `(setf ,(dsd-accessor slot)))
# Line 326  Line 296 
296                      (error "New-Value for setter ~S is not a ~S:~% ~S."                      (error "New-Value for setter ~S is not a ~S:~% ~S."
297                             `(setf ,(dsd-accessor dsd)) (dsd-type dsd)                             `(setf ,(dsd-accessor dsd)) (dsd-type dsd)
298                             new-value))                             new-value))
299                    (%primitive header-set structure (dsd-index dsd)                    (%primitive structure-set structure (dsd-index dsd)
300                                new-value))))))                                new-value))))))
301    
302    (when (dd-predicate info)    (when (dd-predicate info)
# Line 348  Line 318 
318                  (do ((i 1 (1+ i))                  (do ((i 1 (1+ i))
319                       (res (%primitive alloc-g-vector len nil)))                       (res (%primitive alloc-g-vector len nil)))
320                      ((= i len)                      ((= i len)
321                       (%primitive header-set res 0 (dd-name info))                       (%primitive structure-set res 0 (dd-name info))
322                       (structurify res))                       (structurify res))
323                    (declare (fixnum i))                    (declare (fixnum i))
324                    (%primitive header-set res i                    (%primitive structure-set res i
325                                (%primitive header-ref structure i)))))))                                (%primitive structure-ref structure i)))))))
326    
327    (when (dd-doc info)    (when (dd-doc info)
328      (setf (documentation (dd-name info) 'type) (dd-doc info))))      (setf (documentation (dd-name info) 'type) (dd-doc info))))
329    
# Line 437  Line 408 
408                      (push `(setf (aref ,temp ,(dsd-index slot))                      (push `(setf (aref ,temp ,(dsd-index slot))
409                                   ,(dsd-name slot))                                   ,(dsd-name slot))
410                            sets)))))))))))                            sets)))))))))))
   
   
411    
412  ;;;; Support for By-Order-Argument Constructors.  ;;; Find-Legal-Slot   --  Internal
   
 ;;; FIND-LEGAL-SLOT   --  Internal  
413  ;;;  ;;;
414  ;;;    Given a defstruct description and a slot name, return the corresponding  ;;;    Given a defstruct description and a slot name, return the corresponding
415  ;;; slot if it exists, or signal an error if not.  ;;; slot if it exists, or signal an error if not.
# Line 452  Line 419 
419        (error "~S is not a defined slot name in the ~S structure."        (error "~S is not a defined slot name in the ~S structure."
420               name (dd-name defstruct))))               name (dd-name defstruct))))
421    
422    ;;; Define-Boa-Constructors defines positional constructor functions.  We generate
423    ;;; code to set each variable not specified in the arglist to the default given
424    ;;; in the Defstruct.  We just slap required args in, as with rest args and aux
425    ;;; args.  Optionals are treated a little differently.  Those that aren't
426    ;;; supplied with a default in the arg list are mashed so that their default in
427    ;;; the arglist is the corresponding default from the Defstruct.
428    ;;;
429    ;;; If we are defining safe accessors, we check the types of the arguments
430    ;;; supplied.  We don't bother checking the defaulted arguments since we would
431    ;;; have to figure out how to eval the defaults only once, and it probably
432    ;;; isn't worth the effort anyway.
433    
 ;;; Define-Boa-Constructors defines positional constructor functions.  We  
 ;;; generate code to set each variable not specified in the arglist to the  
 ;;; default given in the Defstruct.  We just slap required args in, as with  
 ;;; rest args and aux args.  Optionals are treated a little differently.  Those  
 ;;; that aren't supplied with a default in the arg list are mashed so that  
 ;;; their default in the arglist is the corresponding default from the  
 ;;; Defstruct.  
 ;;;  
434  (defun define-boa-constructors (defstruct)  (defun define-boa-constructors (defstruct)
435    (do* ((boas (dd-boa-constructors defstruct) (cdr boas))    (do* ((boas (dd-boa-constructors defstruct) (cdr boas))
436          (name (car (car boas)) (car (car boas)))          (name (car (car boas)) (car (car boas)))
# Line 474  Line 444 
444           (arg-kind 'required))           (arg-kind 'required))
445          ((null args))          ((null args))
446        (let ((arg (car args)))        (let ((arg (car args)))
447          (cond ((not (atom arg))          (if (atom arg)
448                 (push (find-legal-slot defstruct (car arg)) slots-in-arglist))              (if (memq arg '(&optional &rest &aux))
449                ((memq arg '(&optional &rest &aux &key))                  (setq arg-kind arg)
450                 (setq arg-kind arg))                  (case arg-kind
451                (t                    ((required &rest &aux)
452                 (case arg-kind                     (push (find-legal-slot defstruct arg) slots-in-arglist))
453                   ((required &rest &aux)                    (&optional
454                    (push (find-legal-slot defstruct arg) slots-in-arglist))                     (let ((dsd (find-legal-slot defstruct arg)))
455                   ((&optional &key)                       (push dsd slots-in-arglist)
456                    (let ((dsd (find-legal-slot defstruct arg)))                       (rplaca args (list arg (dsd-default dsd)))))))
457                      (push dsd slots-in-arglist)              (push (find-legal-slot defstruct (car arg)) slots-in-arglist))))
                     (rplaca args (list arg (dsd-default dsd))))))))))  
458    
459      ;; Then make a list that can be used with a (list ...) or (vector...).      ;; Then make a list that can be used with a (list ...) or (vector ...).
460      (let ((initial-cruft      (let ((initial-cruft
461             (if (dd-named defstruct)             (if (dd-named defstruct)
462                 (make-list (1+ (dd-offset defstruct))                 (make-list (1+ (dd-offset defstruct))
# Line 567  Line 536 
536    (let ((def (info type structure-info type)))    (let ((def (info type structure-info type)))
537      (if (and def (eq (dd-type def) 'structure) (dd-predicate def))      (if (and def (eq (dd-type def) 'structure) (dd-predicate def))
538          `(and (structurep ,object)          `(and (structurep ,object)
539                (or (eq (%primitive header-ref ,object 0) ',type)                (or (eq (%primitive structure-ref ,object 0) ',type)
540                    (,(dd-predicate def) ,object)))                    (,(dd-predicate def) ,object)))
541          `(lisp::structure-typep ,object ',type))))          `(lisp::structure-typep ,object ',type))))
542    
# Line 580  Line 549 
549    (prin1 (svref structure 0) stream)    (prin1 (svref structure 0) stream)
550    (do ((index 1 (1+ index))    (do ((index 1 (1+ index))
551         (length (length structure))         (length (length structure))
552         (slots (dd-slots (info type defined-structure-info (svref structure 0)))         (slots (dd-slots (info type structure-info (svref structure 0)))
553                (cdr slots)))                (cdr slots)))
554        ((or (= index length)        ((or (= index length)
555             (and *print-length*             (and *print-length*

Legend:
Removed from v.1.7  
changed lines
  Added in v.1.7.1.1

  ViewVC Help
Powered by ViewVC 1.1.5