ViewVC logotype

Diff of /src/code/defstruct.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.12 by wlott, Fri Oct 5 15:51:19 1990 UTC revision 1.13 by wlott, Tue Oct 9 23:03:53 1990 UTC
# Line 15  Line 15 
15  (in-package 'c)  (in-package 'c)
16  (export '(lisp::defstruct) "LISP")  (export '(lisp::defstruct) "LISP")
19    ;;;; Structure frobbing primitives.
21  ;;; Note: STRUCTURIFY is defined in struct.lisp.  It converts a simple-vector  ;;; Note: STRUCTURIFY is defined in struct.lisp.  It converts a simple-vector
22  ;;; into a structure.  ;;; into a structure.  It should go away when we have a real structure
23    ;;; allocation primitive.
25    (defun structure-length (x)
26      "Return the number of slots used by the structure object X, including the
27      type slot."
28      (declare (type structure x))
29      (structure-length x))
31    (defun structure-ref (struct index)
32      "Return the value from the INDEXth slot of STRUCT.  0 corresponds to the
33      type.  This is SETFable."
34      (structure-ref struct index)
36    (defun structure-set (struct index new-value)
37      "Set the INDEXth slot of STRUCT to NEW-VALUE."
38      (setf (structure-ref struct index) new-value))
40    (defsetf structure-ref structure-set)
44  ;;; 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 286  Line 308 
308  (defun typep-to-structure (obj info)  (defun typep-to-structure (obj info)
309    (declare (type defstruct-description info) (inline member))    (declare (type defstruct-description info) (inline member))
310    (and (structurep obj)    (and (structurep obj)
311         (let ((name (%primitive structure-ref obj 0)))         (let ((name (structure-ref obj 0)))
312           (or (eq name (dd-name info))           (or (eq name (dd-name info))
313               (member name (dd-included-by info) :test #'eq)))))               (member name (dd-included-by info) :test #'eq)))))
# Line 309  Line 331 
331                  (unless (typep-to-structure structure info)                  (unless (typep-to-structure structure info)
332                    (error "Structure for accessor ~S is not a ~S:~% ~S"                    (error "Structure for accessor ~S is not a ~S:~% ~S"
333                           (dsd-accessor dsd) (dd-name info) structure))                           (dsd-accessor dsd) (dd-name info) structure))
334                  (%primitive structure-index-ref structure (dsd-index dsd))))                  (structure-ref structure (dsd-index dsd))))
336        (unless (dsd-read-only slot)        (unless (dsd-read-only slot)
337          (setf (fdefinition `(setf ,(dsd-accessor slot)))          (setf (fdefinition `(setf ,(dsd-accessor slot)))
# Line 323  Line 345 
345                      (error "New-Value for setter ~S is not a ~S:~% ~S."                      (error "New-Value for setter ~S is not a ~S:~% ~S."
346                             `(setf ,(dsd-accessor dsd)) (dsd-type dsd)                             `(setf ,(dsd-accessor dsd)) (dsd-type dsd)
347                             new-value))                             new-value))
348                    (%primitive structure-index-set structure (dsd-index dsd)                    (setf (structure-ref structure (dsd-index dsd))
349                                new-value))))))                          new-value))))))
351    (when (dd-predicate info)    (when (dd-predicate info)
352      (setf (symbol-function (dd-predicate info))      (setf (symbol-function (dd-predicate info))
# Line 343  Line 365 
365                (let ((len (dd-length info)))                (let ((len (dd-length info)))
366                  (declare (fixnum len))                  (declare (fixnum len))
367                  (do ((i 1 (1+ i))                  (do ((i 1 (1+ i))
368                       (res (%primitive alloc-g-vector len nil)))                       (res (structurify (%primitive alloc-g-vector len nil))))
369                      ((= i len)                      ((= i len)
370                       (%primitive structure-set res (dd-name info) 0)                       (setf (structure-ref res 0) (dd-name info))
371                       (structurify res))                       res)
372                    (declare (fixnum i))                    (declare (fixnum i))
373                    (%primitive structure-index-set res i                    (setf (structure-ref res i)
374                                (%primitive structure-index-ref structure i)))))))                          (structure-ref structure i)))))))
375    (when (dd-doc info)    (when (dd-doc info)
376      (setf (documentation (dd-name info) 'type) (dd-doc info))))      (setf (documentation (dd-name info) 'type) (dd-doc info))))
# Line 565  Line 587 
587    (let ((def (info type structure-info type)))    (let ((def (info type structure-info type)))
588      (if (and def (eq (dd-type def) 'structure) (dd-predicate def))      (if (and def (eq (dd-type def) 'structure) (dd-predicate def))
589          `(and (structurep ,object)          `(and (structurep ,object)
590                (if (eq (%primitive structure-ref ,object 0) ',type)                (if (eq (structure-ref ,object 0) ',type)
591                    t                    t
592                    (,(dd-predicate def) ,object)))                    (,(dd-predicate def) ,object)))
593          `(lisp::structure-typep ,object ',type))))          `(lisp::structure-typep ,object ',type))))
# Line 575  Line 597 
598  (defun default-structure-print (structure stream depth)  (defun default-structure-print (structure stream depth)
599    (declare (ignore depth))    (declare (ignore depth))
600    (let* ((type (%primitive structure-ref structure 0))    (let* ((type (structure-ref structure 0))
601           (dd (info type defined-structure-info type)))           (dd (info type defined-structure-info type)))
602      (cond (*print-pretty*      (cond (*print-pretty*
603             (let ((index 0))             (let ((index 0))
# Line 591  Line 613 
613                   (prin1 (dsd-name (xp:pprint-pop)) stream)                   (prin1 (dsd-name (xp:pprint-pop)) stream)
614                   (write-char #\space stream)                   (write-char #\space stream)
615                   (xp:pprint-newline :miser stream)                   (xp:pprint-newline :miser stream)
616                   (prin1 (%primitive structure-index-ref structure (incf index))                   (prin1 (structure-ref structure (incf index)) stream)
617                   (xp:pprint-exit-if-list-exhausted)                   (xp:pprint-exit-if-list-exhausted)
618                   (write-char #\space stream)                   (write-char #\space stream)
619                   (xp:pprint-newline :linear stream)))))                   (xp:pprint-newline :linear stream)))))
# Line 600  Line 621 
621             (write-string "#S(" stream)             (write-string "#S(" stream)
622             (prin1 type stream)             (prin1 type stream)
623             (do ((index 1 (1+ index))             (do ((index 1 (1+ index))
624                  (length (truly-the index                  (length (structure-length structure))
                                    (%primitive structure-ref structure -1)))  
625                  (slots (dd-slots dd) (cdr slots)))                  (slots (dd-slots dd) (cdr slots)))
626                 ((or (= index length)                 ((or (= index length)
627                      (and *print-length*                      (and *print-length*
# Line 613  Line 633 
633               (write-char #\space stream)               (write-char #\space stream)
634               (prin1 (dsd-name (car slots)) stream)               (prin1 (dsd-name (car slots)) stream)
635               (write-char #\space stream)               (write-char #\space stream)
636               (prin1 (%primitive structure-index-ref structure index)               (prin1 (structure-ref structure index) stream))))))

Removed from v.1.12  
changed lines
  Added in v.1.13

  ViewVC Help
Powered by ViewVC 1.1.5