/[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.4 by ram, Wed Feb 14 12:46:09 1990 UTC revision 1.5 by ram, Thu Feb 22 11:46:14 1990 UTC
# Line 31  Line 31 
31    (declare (ignore depth))    (declare (ignore depth))
32    (format stream "#<Defstruct-Description for ~S>" (dd-name structure)))    (format stream "#<Defstruct-Description for ~S>" (dd-name structure)))
33    
   
34  ;;; DSD-Name  --  Internal  ;;; DSD-Name  --  Internal
35  ;;;  ;;;
36  ;;;    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 43  Line 42 
42  (defun print-defstruct-slot-description (structure stream depth)  (defun print-defstruct-slot-description (structure stream depth)
43    (declare (ignore depth))    (declare (ignore depth))
44    (format stream "#<Defstruct-Slot-Description for ~S>" (dsd-name structure)))    (format stream "#<Defstruct-Slot-Description for ~S>" (dsd-name structure)))
45    
46    
47    
48  ;;; The legendary macro itself.  ;;; The legendary macro itself.
49    
# Line 97  Line 98 
98        (setq name-and-options (list name-and-options)))        (setq name-and-options (list name-and-options)))
99    (do* ((options (cdr name-and-options) (cdr options))    (do* ((options (cdr name-and-options) (cdr options))
100          (name (car name-and-options))          (name (car name-and-options))
101          (print-function 'default-structure-print)          (print-function #'default-structure-print)
102            (pf-supplied-p)
103          (conc-name (concat-pnames name '-))          (conc-name (concat-pnames name '-))
104          (constructor (concat-pnames 'make- name))          (constructor (concat-pnames 'make- name))
105          (saw-constructor)          (saw-constructor)
# Line 147  Line 149 
149                                   (push args boa-constructors))                                   (push args boa-constructors))
150                                  (t                                  (t
151                                   (setq saw-constructor t)                                   (setq saw-constructor t)
152                                   (setq constructor (car args)))))                                   (setq constructor
153                                           (or (car args)
154                                               (concat-pnames 'make- name))))))
155              (:copier (setq copier (car args)))              (:copier (setq copier (car args)))
156              (:predicate (setq predicate (car args)))              (:predicate (setq predicate (car args)))
157              (:include (setq include args))              (:include
158              (:print-function (setq print-function (car args)))               (setf include args)
159              (:type (setq saw-type t type (car args)))               (let* ((name (car include))
160                        (included-structure
161                         (or (get name '%structure-definition-in-compiler)
162                             (get name '%structure-definition)))
163                        (included-print-function
164                         (if included-structure
165                             (dd-print-function included-structure))))
166                   (unless included-structure
167                     (error "Cannot find description of structure ~S to use for ~
168                             inclusion."
169                            name))
170                   (unless pf-supplied-p
171                     (setf print-function included-print-function))))
172                (:print-function
173                 (setf print-function (or (car args) #'default-structure-print))
174                 (setf pf-supplied-p t))
175                (:type (setf saw-type t type (car args)))
176              (:named (error "The Defstruct option :NAMED takes no arguments."))              (:named (error "The Defstruct option :NAMED takes no arguments."))
177              (:initial-offset (setq offset (car args)))              (:initial-offset (setf offset (car args)))
178              (t (error "~S is an unknown Defstruct option." option)))))))              (t (error "~S is an unknown Defstruct option." option)))))))
179    
180    
181    
182  ;;; Parse-Slot-Descriptions parses the slot descriptions (surprise) and does  ;;;; Stuff to parse slot descriptions.
 ;;; any structure inclusion that needs to be done.  
183    
184    ;;; PARSE-SLOT-DESCRIPTIONS parses the slot descriptions (surprise) and does
185    ;;; any structure inclusion that needs to be done.
186    ;;;
187  (defun parse-slot-descriptions (defstruct slots)  (defun parse-slot-descriptions (defstruct slots)
188    ;; First strip off any doc string and stash it in the Defstruct.    ;; First strip off any doc string and stash it in the Defstruct.
189    (when (stringp (car slots))    (when (stringp (car slots))
# Line 208  Line 232 
232                                   (car options)))))))))))))                                   (car options)))))))))))))
233    ;; Finally parse the slots into Slot-Description objects.    ;; Finally parse the slots into Slot-Description objects.
234    (do ((slots slots (cdr slots))    (do ((slots slots (cdr slots))
235         (index (+ (dd-offset defstruct) (if (dd-named defstruct) 1 0)) (1+ index))         (index (+ (dd-offset defstruct) (if (dd-named defstruct) 1 0))
236         (descriptions '()))                (1+ index))
237           (descriptions ()))
238        ((null slots)        ((null slots)
239         (setf (dd-length defstruct) index)         (setf (dd-length defstruct) index)
240         (setf (dd-slots defstruct) (nreverse descriptions)))         (setf (dd-slots defstruct) (nreverse descriptions)))
241      (let ((slot (car slots)))      (let* ((slot (car slots))
242               (name (if (atom slot) slot (car slot))))
243          (when (keywordp name)
244            (warn "Keyword slot name indicates possible syntax error in DEFSTRUCT ~
245                   -- ~S."
246                  name))
247        (push        (push
248         (if (atom slot)         (if (atom slot)
249             (let ((name slot))             (make-defstruct-slot-description
250               (make-defstruct-slot-description              :%name (string name)
251                :%name (string name)              :index index
252                :index index              :accessor (concat-pnames (dd-conc-name defstruct) name)
253                :accessor (concat-pnames (dd-conc-name defstruct) name)              :type t)
               :type t))  
254             (do ((options (cddr slot) (cddr options))             (do ((options (cddr slot) (cddr options))
                 (name (car slot))  
255                  (default (cadr slot))                  (default (cadr slot))
256                  (type t)                  (type t)
257                  (read-only nil))                  (read-only nil))
# Line 410  Line 438 
438                      (push `(setf (aref ,temp ,(dsd-index slot))                      (push `(setf (aref ,temp ,(dsd-index slot))
439                                   ,(dsd-name slot))                                   ,(dsd-name slot))
440                            sets)))))))))))                            sets)))))))))))
441    
442    
443    
444  ;;; Find-Legal-Slot   --  Internal  ;;;; Support for By-Order-Argument Constructors.
445    
446    ;;; FIND-LEGAL-SLOT   --  Internal
447  ;;;  ;;;
448  ;;;    Given a defstruct description and a slot name, return the corresponding  ;;;    Given a defstruct description and a slot name, return the corresponding
449  ;;; slot if it exists, or signal an error if not.  ;;; slot if it exists, or signal an error if not.
# Line 421  Line 453 
453        (error "~S is not a defined slot name in the ~S structure."        (error "~S is not a defined slot name in the ~S structure."
454               name (dd-name defstruct))))               name (dd-name defstruct))))
455    
 ;;; 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.  
 ;;;  
 ;;; If we are defining safe accessors, we check the types of the arguments  
 ;;; supplied.  We don't bother checking the defaulted arguments since we would  
 ;;; have to figure out how to eval the defaults only once, and it probably  
 ;;; isn't worth the effort anyway.  
456    
457    ;;; Define-Boa-Constructors defines positional constructor functions.  We
458    ;;; generate code to set each variable not specified in the arglist to the
459    ;;; default given in the Defstruct.  We just slap required args in, as with
460    ;;; rest args and aux args.  Optionals are treated a little differently.  Those
461    ;;; that aren't supplied with a default in the arg list are mashed so that
462    ;;; their default in the arglist is the corresponding default from the
463    ;;; Defstruct.
464    ;;;
465  (defun define-boa-constructors (defstruct)  (defun define-boa-constructors (defstruct)
466    (do* ((boas (dd-boa-constructors defstruct) (cdr boas))    (do* ((boas (dd-boa-constructors defstruct) (cdr boas))
467          (name (car (car boas)) (car (car boas)))          (name (car (car boas)) (car (car boas)))
# Line 446  Line 475 
475           (arg-kind 'required))           (arg-kind 'required))
476          ((null args))          ((null args))
477        (let ((arg (car args)))        (let ((arg (car args)))
478          (if (atom arg)          (cond ((not (atom arg))
479              (if (memq arg '(&optional &rest &aux))                 (push (find-legal-slot defstruct (car arg)) slots-in-arglist))
480                  (setq arg-kind arg)                ((memq arg '(&optional &rest &aux &key))
481                  (case arg-kind                 (setq arg-kind arg))
482                    ((required &rest &aux)                (t
483                     (push (find-legal-slot defstruct arg) slots-in-arglist))                 (case arg-kind
484                    (&optional                   ((required &rest &aux)
485                     (let ((dsd (find-legal-slot defstruct arg)))                    (push (find-legal-slot defstruct arg) slots-in-arglist))
486                       (push dsd slots-in-arglist)                   ((&optional &key)
487                       (rplaca args (list arg (dsd-default dsd)))))))                    (let ((dsd (find-legal-slot defstruct arg)))
488              (push (find-legal-slot defstruct (car arg)) slots-in-arglist))))                      (push dsd slots-in-arglist)
489                        (rplaca args (list arg (dsd-default dsd))))))))))
490    
491      ;; 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...).
492      (let ((initial-cruft      (let ((initial-cruft
493             (if (dd-named defstruct)             (if (dd-named defstruct)
494                 (make-list (1+ (dd-offset defstruct))                 (make-list (1+ (dd-offset defstruct))
# Line 516  Line 546 
546  ;;; desired.  This is only called for typed structures, since the default  ;;; desired.  This is only called for typed structures, since the default
547  ;;; structure predicate is implemented as a closure.  ;;; structure predicate is implemented as a closure.
548    
549  (defun define-predicate (defstruct)  
550                         **** END OF MERGE LOSSAGE ****(defun define-predicate (defstruct)
551    (let ((name (dd-name defstruct))    (let ((name (dd-name defstruct))
552          (pred (dd-predicate defstruct)))          (pred (dd-predicate defstruct)))
553      (when (and pred (dd-named defstruct))      (when (and pred (dd-named defstruct))

Legend:
Removed from v.1.4  
changed lines
  Added in v.1.5

  ViewVC Help
Powered by ViewVC 1.1.5