/[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.2.3 by wlott, Thu Apr 5 23:59:37 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 21  Line 23 
23  (proclaim '(inline structurify))  (proclaim '(inline structurify))
24  (defun structurify (structure)  (defun structurify (structure)
25    "Frobs a vector to turn it into a named structure.  Returns the vector."    "Frobs a vector to turn it into a named structure.  Returns the vector."
26    (%primitive set-vector-subtype structure %g-vector-structure-subtype))    (%primitive set-vector-subtype structure
27                  #+new-compiler vm:vector-structure-subtype
28                  #-new-compiler %g-vector-structure-subtype))
29    
30    
31  ;;; This version of Defstruct is implemented using Defstruct, and is free of  ;;; This version of Defstruct is implemented using Defstruct, and is free of
# Line 285  Line 289 
289  ;;; This is called by the accessor closures, which have a handle on the type's  ;;; This is called by the accessor closures, which have a handle on the type's
290  ;;; Defstruct-Description.  ;;; Defstruct-Description.
291  ;;;  ;;;
292    #+new-compiler
293  (proclaim '(inline typep-to-structure))  (proclaim '(inline typep-to-structure))
294    #+new-compiler
295  (defun typep-to-structure (obj info)  (defun typep-to-structure (obj info)
296    (declare (type defstruct-description info) (inline member))    (declare (type defstruct-description info) (inline member))
297    (and (structurep obj)    (and (structurep obj)
298         (let ((name (%primitive header-ref obj 0)))         (let ((name (%primitive structure-ref obj 0)))
299           (or (eq name (dd-name info))           (or (eq name (dd-name info))
300               (member name (dd-included-by info) :test #'eq)))))               (member name (dd-included-by info) :test #'eq)))))
301    
# Line 312  Line 318 
318                  (unless (typep-to-structure structure info)                  (unless (typep-to-structure structure info)
319                    (error "Structure for accessor ~S is not a ~S:~% ~S"                    (error "Structure for accessor ~S is not a ~S:~% ~S"
320                           (dsd-accessor dsd) (dd-name info) structure))                           (dsd-accessor dsd) (dd-name info) structure))
321                  (%primitive header-ref structure (dsd-index dsd))))                  (%primitive structure-index-ref structure (dsd-index dsd))))
322    
323        (unless (dsd-read-only slot)        (unless (dsd-read-only slot)
324          (setf (fdefinition `(setf ,(dsd-accessor slot)))          (setf (fdefinition `(setf ,(dsd-accessor slot)))
# Line 326  Line 332 
332                      (error "New-Value for setter ~S is not a ~S:~% ~S."                      (error "New-Value for setter ~S is not a ~S:~% ~S."
333                             `(setf ,(dsd-accessor dsd)) (dsd-type dsd)                             `(setf ,(dsd-accessor dsd)) (dsd-type dsd)
334                             new-value))                             new-value))
335                    (%primitive header-set structure (dsd-index dsd)                    (%primitive structure-index-set structure (dsd-index dsd)
336                                new-value))))))                                new-value))))))
337    
338    (when (dd-predicate info)    (when (dd-predicate info)
# Line 348  Line 354 
354                  (do ((i 1 (1+ i))                  (do ((i 1 (1+ i))
355                       (res (%primitive alloc-g-vector len nil)))                       (res (%primitive alloc-g-vector len nil)))
356                      ((= i len)                      ((= i len)
357                       (%primitive header-set res 0 (dd-name info))                       (%primitive structure-set res (dd-name info) 0)
358                       (structurify res))                       (structurify res))
359                    (declare (fixnum i))                    (declare (fixnum i))
360                    (%primitive header-set res i                    (%primitive structure-index-set res i
361                                (%primitive header-ref structure i)))))))                                (%primitive structure-index-ref structure i)))))))
362    (when (dd-doc info)    (when (dd-doc info)
363      (setf (documentation (dd-name info) 'type) (dd-doc info))))      (setf (documentation (dd-name info) 'type) (dd-doc info))))
364    
# Line 476  Line 482 
482        (let ((arg (car args)))        (let ((arg (car args)))
483          (cond ((not (atom arg))          (cond ((not (atom arg))
484                 (push (find-legal-slot defstruct (car arg)) slots-in-arglist))                 (push (find-legal-slot defstruct (car arg)) slots-in-arglist))
485                ((memq arg '(&optional &rest &aux &key))                ((member arg '(&optional &rest &aux &key) :test #'eq)
486                 (setq arg-kind arg))                 (setq arg-kind arg))
487                (t                (t
488                 (case arg-kind                 (case arg-kind
# Line 494  Line 500 
500                            :initial-element `',(dd-name defstruct))                            :initial-element `',(dd-name defstruct))
501                 (make-list (dd-offset defstruct))))                 (make-list (dd-offset defstruct))))
502            (thing (mapcar #'(lambda (slot)            (thing (mapcar #'(lambda (slot)
503                               (if (memq slot slots-in-arglist)                               (if (member slot slots-in-arglist
504                                             :test #'eq)
505                                   (dsd-name slot)                                   (dsd-name slot)
506                                   (dsd-default slot)))                                   (dsd-default slot)))
507                           slots)))                           slots)))
# Line 567  Line 574 
574    (let ((def (info type structure-info type)))    (let ((def (info type structure-info type)))
575      (if (and def (eq (dd-type def) 'structure) (dd-predicate def))      (if (and def (eq (dd-type def) 'structure) (dd-predicate def))
576          `(and (structurep ,object)          `(and (structurep ,object)
577                (or (eq (%primitive header-ref ,object 0) ',type)                (or (eq (%primitive structure-ref ,object 0) ',type)
578                    (,(dd-predicate def) ,object)))                    (,(dd-predicate def) ,object)))
579          `(lisp::structure-typep ,object ',type))))          `(lisp::structure-typep ,object ',type))))
580    

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

  ViewVC Help
Powered by ViewVC 1.1.5