/[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.37.1.2 by ram, Mon Feb 8 22:20:58 1993 UTC revision 1.37.1.3 by ram, Wed Feb 10 23:39:22 1993 UTC
# Line 305  Line 305 
305               (eval-when (compile)               (eval-when (compile)
306                 (%compiler-only-defstruct ',defstruct ',inherits))                 (%compiler-only-defstruct ',defstruct ',inherits))
307               (%compiler-defstruct ',defstruct)               (%compiler-defstruct ',defstruct)
              ,@(define-constructors defstruct)  
308               ,@(define-raw-accessors defstruct)               ,@(define-raw-accessors defstruct)
309                 ,@(define-constructors defstruct)
310               ,@(define-class-methods defstruct)               ,@(define-class-methods defstruct)
311             ',name))             ',name))
312          `(progn          `(progn
# Line 644  Line 644 
644         (let ((,temp (truly-the ,(dd-name defstruct)         (let ((,temp (truly-the ,(dd-name defstruct)
645                                 (%make-instance ,(dd-length defstruct)))))                                 (%make-instance ,(dd-length defstruct)))))
646           (setf (%instance-layout ,temp)           (setf (%instance-layout ,temp)
647                 (load-time-value                 (truly-the layout
648                  (class-layout                            (load-time-value
649                   (find-class ',(dd-name defstruct)))))                             (class-layout
650                                (find-class ',(dd-name defstruct))))))
651           ,@(when (dd-raw-index defstruct)           ,@(when (dd-raw-index defstruct)
652               `((setf (%instance-ref ,temp ,(dd-raw-index defstruct))               `((setf (%instance-ref ,temp ,(dd-raw-index defstruct))
653                       (make-array ,(dd-raw-length defstruct)                       (make-array ,(dd-raw-length defstruct)
# Line 657  Line 658 
658                                 ,temp)                                 ,temp)
659                                ,value))                                ,value))
660                     (dd-slots defstruct)                     (dd-slots defstruct)
661                     values)))))                     values)
662             ,temp))))
663    
664    
665  ;;; CREATE-KEYWORD-CONSTRUCTOR   --  Internal  ;;; CREATE-KEYWORD-CONSTRUCTOR   --  Internal
# Line 687  Line 689 
689  ;;;  ;;;
690  (defun create-boa-constructor (defstruct boa creator)  (defun create-boa-constructor (defstruct boa creator)
691    (multiple-value-bind (req opt restp rest keyp keys allowp aux)    (multiple-value-bind (req opt restp rest keyp keys allowp aux)
692                         (kernel:parse-lambda-list boa)                         (kernel:parse-lambda-list (second boa))
693      (collect ((arglist)      (collect ((arglist)
694                (vars)                (vars)
695                (types))                (types))
# Line 842  Line 844 
844                                      (setf ,aname))))                                      (setf ,aname))))
845                (res                (res
846                 `(defun (setf ,aname) (new-value object)                 `(defun (setf ,aname) (new-value object)
847                    (setf (,accessor ,data ,offset) new-value))))))))                    (setf (,accessor ,data ,offset) new-value)
848                      new-value)))))))
849      (res)))      (res)))
850    
851    
# Line 917  Line 920 
920  ;;; general-case code.  Since the compiler will normally open-code accesors,  ;;; general-case code.  Since the compiler will normally open-code accesors,
921  ;;; the (minor) efficiency penalty is not a concern.  ;;; the (minor) efficiency penalty is not a concern.
922    
923    #+ns-boot
924    (defun %defstruct (&rest ignore)
925      (declare (ignore ignore)))
926    
927  #-ns-boot(progn  #-ns-boot(progn
928  ;;; Typep-To-Layout  --  Internal  ;;; Typep-To-Layout  --  Internal
929  ;;;  ;;;

Legend:
Removed from v.1.37.1.2  
changed lines
  Added in v.1.37.1.3

  ViewVC Help
Powered by ViewVC 1.1.5