/[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.58.2.2 by pw, Tue May 23 16:36:20 2000 UTC revision 1.58.2.3 by pw, Sat Mar 23 18:49:55 2002 UTC
# Line 30  Line 30 
30            defstruct-description dd-name dd-default-constructor dd-copier            defstruct-description dd-name dd-default-constructor dd-copier
31            dd-predicate dd-slots dd-length dd-type dd-raw-index dd-raw-length            dd-predicate dd-slots dd-length dd-type dd-raw-index dd-raw-length
32            defstruct-slot-description dsd-name dsd-%name dsd-accessor dsd-type            defstruct-slot-description dsd-name dsd-%name dsd-accessor dsd-type
33            dsd-index dsd-raw-type dsd-read-only undefine-structure))            dsd-index dsd-raw-type dsd-read-only undefine-structure
34              *ansi-defstruct-options-p*))
35    
36    
37    (defparameter *ANSI-defstruct-options-p* nil
38      "Controls compiling DEFSTRUCT :print-function and :print-method
39       options according to ANSI spec. MUST be NIL to compile CMUCL & PCL")
40    
41  ;;;; Structure frobbing primitives.  ;;;; Structure frobbing primitives.
42    
# Line 323  Line 328 
328    (declare (ignore depth))    (declare (ignore depth))
329    (format stream "#<Defstruct-Slot-Description for ~S>" (dsd-name structure)))    (format stream "#<Defstruct-Slot-Description for ~S>" (dsd-name structure)))
330    
331    (defun dd-maybe-make-print-method (defstruct)
332      ;; Maybe generate CLOS DEFMETHOD forms for :print-function/:print-object.
333      (let ((print-function-value (dd-print-function defstruct)))
334        (when (consp print-function-value)
335          (let ((kind (car print-function-value))
336                (function (cdr print-function-value)))
337            (unless (eq kind 'lambda)
338              (setf (dd-print-function defstruct) nil)
339              (let* ((class (dd-name defstruct))
340                     (func (if (symbolp function) `',function `#',function)))
341                ;; We can only generate this code if CLOS is loaded. Maybe should
342                ;; signal an error instead of quietly ignoring the defmethod?
343                `((when (fboundp 'print-object)
344                    (defmethod print-object ((object ,class) stream)
345                      (funcall
346                       ,func object stream
347                       ,@(when (or (eq kind :print-function)
348                                   (eq function 'default-structure-print))
349                           '(*current-level*))))))))))))
350    
351    
352  ;;; The legendary macro itself.  ;;; The legendary macro itself.
353    
# Line 331  Line 356 
356  ;;; Return a list of forms to install print and make-load-form funs, mentioning  ;;; Return a list of forms to install print and make-load-form funs, mentioning
357  ;;; them in the expansion so that they can be compiled.  ;;; them in the expansion so that they can be compiled.
358  ;;;  ;;;
359    
360    (defun define-class-methods (defstruct)
361      (let* ((name (dd-name defstruct))
362             (pom (dd-maybe-make-print-method defstruct)))
363        `(,@(let ((pf (dd-print-function defstruct)))
364              (when pf
365                `((setf (basic-structure-class-print-function (find-class ',name))
366                        ,(if (symbolp pf)
367                             `',pf
368                             `#',pf)))))
369          ,@(let ((mlff (dd-make-load-form-fun defstruct)))
370              (when mlff
371                `((setf (structure-class-make-load-form-fun (find-class ',name))
372                        ,(if (symbolp mlff)
373                             `',mlff
374                             `#',mlff)))))
375          ,@(let ((pure (dd-pure defstruct)))
376              (cond ((eq pure 't)
377                     `((setf (layout-pure (class-layout (find-class ',name)))
378                        t)))
379                    ((eq pure :substructure)
380                     `((setf (layout-pure (class-layout (find-class ',name)))
381                        0)))))
382          ,@(let ((def-con (dd-default-constructor defstruct)))
383              (when (and def-con (not (dd-alternate-metaclass defstruct)))
384                `((setf (structure-class-constructor (find-class ',name))
385                        #',def-con))))
386          ,@pom)))
387    
388    #+ORIGINAL
389  (defun define-class-methods (defstruct)  (defun define-class-methods (defstruct)
390    (let ((name (dd-name defstruct)))    (let ((name (dd-name defstruct)))
391      `(,@(let ((pf (dd-print-function defstruct)))      `(,@(let ((pf (dd-print-function defstruct)))
# Line 454  Line 509 
509         (setf (dd-include defstruct) args))         (setf (dd-include defstruct) args))
510        (:alternate-metaclass        (:alternate-metaclass
511         (setf (dd-alternate-metaclass defstruct) args))         (setf (dd-alternate-metaclass defstruct) args))
512          ((:print-function :print-object)
513           (destructuring-bind (&optional (fun 'default-structure-print)) args
514             (setf (dd-print-function defstruct)
515                   (if *ANSI-defstruct-options-p*
516                       (cons (first option) fun)
517                       fun))))
518          (:type
519           (destructuring-bind (type) args
520             (cond ((eq type 'funcallable-structure)
521                    (setf (dd-type defstruct) type))
522                   ((member type '(list vector))
523                    (setf (dd-element-type defstruct) 't)
524                    (setf (dd-type defstruct) type))
525                   ((and (consp type) (eq (first type) 'vector))
526                    (destructuring-bind (vector vtype) type
527                      (declare (ignore vector))
528                      (setf (dd-element-type defstruct) vtype)
529                      (setf (dd-type defstruct) 'vector)))
530                   (t
531                    (error "~S is a bad :TYPE for Defstruct." type)))))
532          (:named
533           (error "The Defstruct option :NAMED takes no arguments."))
534          (:initial-offset
535           (destructuring-bind (offset) args
536             (setf (dd-offset defstruct) offset)))
537          (:make-load-form-fun
538           (destructuring-bind (fun) args
539             (setf (dd-make-load-form-fun defstruct) fun)))
540          (:pure
541           (destructuring-bind (fun) args
542             (setf (dd-pure defstruct) fun)))
543          (t (error "Unknown DEFSTRUCT option~%  ~S" option)))))
544    
545    #+ORIGINAL
546    (defun parse-1-option (option defstruct)
547      (let ((args (rest option))
548            (name (dd-name defstruct)))
549        (case (first option)
550          (:conc-name
551           (destructuring-bind (conc-name) args
552             (setf (dd-conc-name defstruct)
553                   (if (symbolp conc-name)
554                       conc-name
555                       (make-symbol (string conc-name))))))
556          (:constructor
557           (destructuring-bind (&optional (cname (concat-pnames 'make- name))
558                                          &rest stuff)
559                               args
560             (push (cons cname stuff) (dd-constructors defstruct))))
561          (:copier
562           (destructuring-bind (&optional (copier (concat-pnames 'copy- name)))
563                               args
564             (setf (dd-copier defstruct) copier)))
565          (:predicate
566           (destructuring-bind (&optional (pred (concat-pnames name '-p)))
567                               args
568             (setf (dd-predicate defstruct) pred)))
569          (:include
570           (when (dd-include defstruct)
571             (error "Can't have more than one :INCLUDE option."))
572           (setf (dd-include defstruct) args))
573          (:alternate-metaclass
574           (setf (dd-alternate-metaclass defstruct) args))
575        (:print-function        (:print-function
576         (destructuring-bind (&optional (fun 'default-structure-print)) args         (destructuring-bind (&optional (fun 'default-structure-print)) args
577           (setf (dd-print-function defstruct) fun)))           (setf (dd-print-function defstruct) fun)))
# Line 999  Line 1117 
1117        (data)        (data)
1118        (t        (t
1119         `(truly-the (simple-array (unsigned-byte 32) (*))         `(truly-the (simple-array (unsigned-byte 32) (*))
1120                     (%instance-ref object ,(dd-raw-index defstruct))))))))                     (%instance-ref ,object ,(dd-raw-index defstruct))))))))
1121    
1122    
1123  ;;; dsd-inherited-p  --  Internal  ;;; dsd-inherited-p  --  Internal
# Line 1084  Line 1202 
1202                (index (dsd-index slot))                (index (dsd-index slot))
1203                (slot-type `(and ,(dsd-type slot)                (slot-type `(and ,(dsd-type slot)
1204                                 ,(dd-element-type defstruct))))                                 ,(dd-element-type defstruct))))
1205            (stuff `(proclaim '(inline ,aname (setf ,aname))))            (stuff `(declaim (inline ,aname (setf ,aname))))
1206            (stuff `(defun ,aname (structure)            (stuff `(defun ,aname (structure)
1207                      (declare (type ,ltype structure))                      (declare (type ,ltype structure))
1208                      (the ,slot-type (elt structure ,index))))                      (the ,slot-type (elt structure ,index))))
# Line 1137  Line 1255 
1255  ;;; Layout.  This is called by the accessor closures, which have a handle on  ;;; Layout.  This is called by the accessor closures, which have a handle on
1256  ;;; the type's layout.  ;;; the type's layout.
1257  ;;;  ;;;
1258  (proclaim '(inline typep-to-layout))  (declaim (inline typep-to-layout))
1259  (defun typep-to-layout (obj layout)  (defun typep-to-layout (obj layout)
1260    (declare (type layout layout) (optimize (speed 3) (safety 0)))    (declare (type layout layout) (optimize (speed 3) (safety 0)))
1261    (when (layout-invalid layout)    (when (layout-invalid layout)

Legend:
Removed from v.1.58.2.2  
changed lines
  Added in v.1.58.2.3

  ViewVC Help
Powered by ViewVC 1.1.5