/[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.22 by ram, Fri Feb 8 13:32:03 1991 UTC revision 1.23 by ram, Mon Mar 4 16:52:36 1991 UTC
# Line 11  Line 11 
11  ;;;  ;;;
12  ;;; **********************************************************************  ;;; **********************************************************************
13  ;;;  ;;;
 ;;; $Header$  
 ;;;  
14  ;;; Defstruct structure definition package (Mark II).  ;;; Defstruct structure definition package (Mark II).
15  ;;; Written by Skef Wholey and Rob MacLachlan.  ;;; Written by Skef Wholey and Rob MacLachlan.
16  ;;;  ;;;
# Line 87  Line 85 
85          `(progn          `(progn
86             (%defstruct ',defstruct)             (%defstruct ',defstruct)
87             (%compiler-defstruct ',defstruct)             (%compiler-defstruct ',defstruct)
88             ,@(define-constructor defstruct)             ,@(define-constructors defstruct)
89             ,@(define-boa-constructors defstruct)             ,@(define-boa-constructors defstruct)
90             ;;             ;;
91             ;; So the print function is in the right lexical environment, and             ;; So the print function is in the right lexical environment, and
# Line 103  Line 101 
101             (eval-when (compile load eval)             (eval-when (compile load eval)
102               (setf (info type kind ',name) nil)               (setf (info type kind ',name) nil)
103               (setf (info type structure-info ',name) ',defstruct))               (setf (info type structure-info ',name) ',defstruct))
104             ,@(define-constructor defstruct)             ,@(define-constructors defstruct)
105             ,@(define-boa-constructors defstruct)             ,@(define-boa-constructors defstruct)
106             ,@(define-predicate defstruct)             ,@(define-predicate defstruct)
107             ,@(define-accessors defstruct)             ,@(define-accessors defstruct)
# Line 123  Line 121 
121          (print-function nil)          (print-function nil)
122          (pf-supplied-p)          (pf-supplied-p)
123          (conc-name (concat-pnames name '-))          (conc-name (concat-pnames name '-))
124          (constructor (concat-pnames 'make- name))          (constructors '())
125          (saw-constructor)          (constructor-opt-p nil)
126          (boa-constructors '())          (boa-constructors '())
127          (copier (concat-pnames 'copy- name))          (copier (concat-pnames 'copy- name))
128          (predicate (concat-pnames name '-p))          (predicate (concat-pnames name '-p))
# Line 137  Line 135 
135          (make-defstruct-description          (make-defstruct-description
136           :name name           :name name
137           :conc-name conc-name           :conc-name conc-name
138           :constructor constructor           :constructors
139             (if constructor-opt-p
140                 (nreverse constructors)
141                 (list (concat-pnames 'make- name)))
142           :boa-constructors boa-constructors           :boa-constructors boa-constructors
143           :copier copier           :copier copier
144           :predicate predicate           :predicate predicate
# Line 154  Line 155 
155           :offset offset))           :offset offset))
156      (if (atom (car options))      (if (atom (car options))
157          (case (car options)          (case (car options)
158            (:constructor (setq saw-constructor t            (:constructor
159                                constructor (concat-pnames 'make- name)))             (setf constructor-opt-p t)
160               (setf constructors (list (concat-pnames 'make- name))))
161            (:copier)            (:copier)
162            (:predicate)            (:predicate)
163            (:named (setq saw-named t))            (:named (setq saw-named t))
# Line 165  Line 167 
167                (args (cdar options)))                (args (cdar options)))
168            (case option            (case option
169              (:conc-name (setq conc-name (car args)))              (:conc-name (setq conc-name (car args)))
170              (:constructor (cond ((cdr args)              (:constructor
171                                   (unless saw-constructor               (setf constructor-opt-p t)
172                                     (setq constructor nil))               (let ((lambda-list (cdr args))
173                                   (push args boa-constructors))                     (constructor-name (car args))
174                                  (t                     (no-explicit-nil-name (not args)))
175                                   (setq saw-constructor t)                 ;; Constructor-name may be nil because args has one element, the
176                                   (setq constructor                 ;; explicit name of nil.  In this situation, don't make a
177                                         (or (car args)                 ;; default constructor.  If args itself is nil, then we make a
178                                             (concat-pnames 'make- name))))))                 ;; default constructor.
179                   (cond (lambda-list
180                          (push args boa-constructors))
181                         (constructor-name
182                          (push constructor-name constructors))
183                         (no-explicit-nil-name
184                          (push (concat-pnames 'make- name) constructors)))))
185              (:copier (setq copier (car args)))              (:copier (setq copier (car args)))
186              (:predicate (setq predicate (car args)))              (:predicate (setq predicate (car args)))
187              (:include              (:include
# Line 457  Line 465 
465         stuff))))         stuff))))
466    
467    
468  ;;; Define-Constructor returns a definition for the constructor function of the  ;;; Define-Constructors returns a definition for the constructor function of
469  ;;; given Defstruct.  If the structure is implemented as a vector and is named,  ;;; the given Defstruct.  If the structure is implemented as a vector and is
470  ;;; we structurify it.  If the structure is a vector of some specialized type,  ;;; named, we structurify it.  If the structure is a vector of some specialized
471  ;;; we can't use the Vector function.  ;;; type, we can't use the Vector function.
472  ;;;  ;;;
473  ;;; If we are defining safe accessors, we also check the types of the values to  (defun define-constructors (defstruct)
474  ;;; make sure that they are legal.    (let ((cons-names (dd-constructors defstruct)))
475  ;;;      (when cons-names
476  (defun define-constructor (defstruct)        (let* ((name (first cons-names))
477    (let ((name (dd-constructor defstruct)))               (initial-cruft
     (when name  
       (let* ((initial-cruft  
478                (if (dd-named defstruct)                (if (dd-named defstruct)
479                    (make-list (1+ (dd-offset defstruct))                    (make-list (1+ (dd-offset defstruct))
480                               :initial-element `',(dd-name defstruct))                               :initial-element `',(dd-name defstruct))
# Line 516  Line 522 
522                    (let ((slot (car sluts)))                    (let ((slot (car sluts)))
523                      (push `(setf (aref ,temp ,(dsd-index slot))                      (push `(setf (aref ,temp ,(dsd-index slot))
524                                   ,(dsd-name slot))                                   ,(dsd-name slot))
525                            sets)))))))))))                            sets))))))
526              ,@(mapcar #'(lambda (other-name)
527                            `(setf (fdefinition ',other-name) #',name))
528                        (rest cons-names)))))))
529    
530    
531  ;;;; Support for By-Order-Argument Constructors.  ;;;; Support for By-Order-Argument Constructors.

Legend:
Removed from v.1.22  
changed lines
  Added in v.1.23

  ViewVC Help
Powered by ViewVC 1.1.5