/[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.2 by wlott, Thu Mar 15 18:09:12 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 285  Line 287 
287  ;;; 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
288  ;;; Defstruct-Description.  ;;; Defstruct-Description.
289  ;;;  ;;;
290    #+new-compiler
291  (proclaim '(inline typep-to-structure))  (proclaim '(inline typep-to-structure))
292    #+new-compiler
293  (defun typep-to-structure (obj info)  (defun typep-to-structure (obj info)
294    (declare (type defstruct-description info) (inline member))    (declare (type defstruct-description info) (inline member))
295    (and (structurep obj)    (and (structurep obj)
296         (let ((name (%primitive header-ref obj 0)))         (let ((name (%primitive structure-ref obj 0)))
297           (or (eq name (dd-name info))           (or (eq name (dd-name info))
298               (member name (dd-included-by info) :test #'eq)))))               (member name (dd-included-by info) :test #'eq)))))
299    
# Line 312  Line 316 
316                  (unless (typep-to-structure structure info)                  (unless (typep-to-structure structure info)
317                    (error "Structure for accessor ~S is not a ~S:~% ~S"                    (error "Structure for accessor ~S is not a ~S:~% ~S"
318                           (dsd-accessor dsd) (dd-name info) structure))                           (dsd-accessor dsd) (dd-name info) structure))
319                  (%primitive header-ref structure (dsd-index dsd))))                  (%primitive structure-index-ref structure (dsd-index dsd))))
320    
321        (unless (dsd-read-only slot)        (unless (dsd-read-only slot)
322          (setf (fdefinition `(setf ,(dsd-accessor slot)))          (setf (fdefinition `(setf ,(dsd-accessor slot)))
# Line 326  Line 330 
330                      (error "New-Value for setter ~S is not a ~S:~% ~S."                      (error "New-Value for setter ~S is not a ~S:~% ~S."
331                             `(setf ,(dsd-accessor dsd)) (dsd-type dsd)                             `(setf ,(dsd-accessor dsd)) (dsd-type dsd)
332                             new-value))                             new-value))
333                    (%primitive header-set structure (dsd-index dsd)                    (%primitive structure-index-set structure (dsd-index dsd)
334                                new-value))))))                                new-value))))))
335    
336    (when (dd-predicate info)    (when (dd-predicate info)
# Line 348  Line 352 
352                  (do ((i 1 (1+ i))                  (do ((i 1 (1+ i))
353                       (res (%primitive alloc-g-vector len nil)))                       (res (%primitive alloc-g-vector len nil)))
354                      ((= i len)                      ((= i len)
355                       (%primitive header-set res 0 (dd-name info))                       (%primitive structure-set res (dd-name info) 0)
356                       (structurify res))                       (structurify res))
357                    (declare (fixnum i))                    (declare (fixnum i))
358                    (%primitive header-set res i                    (%primitive structure-index-set res i
359                                (%primitive header-ref structure i)))))))                                (%primitive structure-index-ref structure i)))))))
360    (when (dd-doc info)    (when (dd-doc info)
361      (setf (documentation (dd-name info) 'type) (dd-doc info))))      (setf (documentation (dd-name info) 'type) (dd-doc info))))
362    
# Line 476  Line 480 
480        (let ((arg (car args)))        (let ((arg (car args)))
481          (cond ((not (atom arg))          (cond ((not (atom arg))
482                 (push (find-legal-slot defstruct (car arg)) slots-in-arglist))                 (push (find-legal-slot defstruct (car arg)) slots-in-arglist))
483                ((memq arg '(&optional &rest &aux &key))                ((member arg '(&optional &rest &aux &key) :test #'eq)
484                 (setq arg-kind arg))                 (setq arg-kind arg))
485                (t                (t
486                 (case arg-kind                 (case arg-kind
# Line 494  Line 498 
498                            :initial-element `',(dd-name defstruct))                            :initial-element `',(dd-name defstruct))
499                 (make-list (dd-offset defstruct))))                 (make-list (dd-offset defstruct))))
500            (thing (mapcar #'(lambda (slot)            (thing (mapcar #'(lambda (slot)
501                               (if (memq slot slots-in-arglist)                               (if (member slot slots-in-arglist
502                                             :test #'eq)
503                                   (dsd-name slot)                                   (dsd-name slot)
504                                   (dsd-default slot)))                                   (dsd-default slot)))
505                           slots)))                           slots)))
# Line 567  Line 572 
572    (let ((def (info type structure-info type)))    (let ((def (info type structure-info type)))
573      (if (and def (eq (dd-type def) 'structure) (dd-predicate def))      (if (and def (eq (dd-type def) 'structure) (dd-predicate def))
574          `(and (structurep ,object)          `(and (structurep ,object)
575                (or (eq (%primitive header-ref ,object 0) ',type)                (or (eq (%primitive structure-ref ,object 0) ',type)
576                    (,(dd-predicate def) ,object)))                    (,(dd-predicate def) ,object)))
577          `(lisp::structure-typep ,object ',type))))          `(lisp::structure-typep ,object ',type))))
578    

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

  ViewVC Help
Powered by ViewVC 1.1.5