/[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 by dtc, Wed Apr 9 17:49:41 1997 UTC revision 1.58.2.1 by pw, Tue Jun 23 11:21:45 1998 UTC
# Line 1  Line 1 
1  ;;; -*- Package: KERNEL -*-  ;;; -*- Mode: Lisp; Package: KERNEL -*-
2  ;;;  ;;;
3  ;;; **********************************************************************  ;;; **********************************************************************
4  ;;; This code was written as part of the CMU Common Lisp project at  ;;; This code was written as part of the CMU Common Lisp project at
# Line 15  Line 15 
15  (in-package "LISP")  (in-package "LISP")
16  (export '(defstruct copy-structure structure-object))  (export '(defstruct copy-structure structure-object))
17  (in-package "KERNEL")  (in-package "KERNEL")
18  (export '(  (export '(default-structure-print make-structure-load-form
           default-structure-print make-structure-load-form  
19            %compiler-defstruct %%compiler-defstruct            %compiler-defstruct %%compiler-defstruct
20            %compiler-only-defstruct            %compiler-only-defstruct
21            %make-instance            %make-instance
# Line 62  Line 61 
61    (declare (type index index))    (declare (type index index))
62    (%raw-ref-double vec index))    (%raw-ref-double vec index))
63    
64    #+long-float
65    (defun %raw-ref-long (vec index)
66      (declare (type index index))
67      (%raw-ref-long vec index))
68    
69  (defun %raw-set-single (vec index val)  (defun %raw-set-single (vec index val)
70    (declare (type index index))    (declare (type index index))
71    (%raw-set-single vec index val))    (%raw-set-single vec index val))
# Line 70  Line 74 
74    (declare (type index index))    (declare (type index index))
75    (%raw-set-double vec index val))    (%raw-set-double vec index val))
76    
77    #+long-float
78    (defun %raw-set-long (vec index val)
79      (declare (type index index))
80      (%raw-set-long vec index val))
81    
82    #+complex-float
83    (progn
84    
85    (defun %raw-ref-complex-single (vec index)
86      (declare (type index index))
87      (%raw-ref-complex-single vec index))
88    
89    (defun %raw-ref-complex-double (vec index)
90      (declare (type index index))
91      (%raw-ref-complex-double vec index))
92    
93    #+long-float
94    (defun %raw-ref-complex-long (vec index)
95      (declare (type index index))
96      (%raw-ref-complex-long vec index))
97    
98    (defun %raw-set-complex-single (vec index val)
99      (declare (type index index))
100      (%raw-set-complex-single vec index val))
101    
102    (defun %raw-set-complex-double (vec index val)
103      (declare (type index index))
104      (%raw-set-complex-double vec index val))
105    
106    #+long-float
107    (defun %raw-set-complex-long (vec index val)
108      (declare (type index index))
109      (%raw-set-complex-long vec index val))
110    
111    ) ; end progn complex-float
112    
113  (defun %instance-layout (instance)  (defun %instance-layout (instance)
114    (%instance-layout instance))    (%instance-layout instance))
115    
# Line 125  Line 165 
165  (defsetf %instance-ref %instance-set)  (defsetf %instance-ref %instance-set)
166  (defsetf %raw-ref-single %raw-set-single)  (defsetf %raw-ref-single %raw-set-single)
167  (defsetf %raw-ref-double %raw-set-double)  (defsetf %raw-ref-double %raw-set-double)
168    #+long-float
169    (defsetf %raw-ref-long %raw-set-long)
170    #+complex-float
171    (defsetf %raw-ref-complex-single %raw-set-complex-single)
172    #+complex-float
173    (defsetf %raw-ref-complex-double %raw-set-complex-double)
174    #+(and complex-float long-float)
175    (defsetf %raw-ref-complex-long %raw-set-complex-long)
176  (defsetf %instance-layout %set-instance-layout)  (defsetf %instance-layout %set-instance-layout)
177  (defsetf %funcallable-instance-info %set-funcallable-instance-info)  (defsetf %funcallable-instance-info %set-funcallable-instance-info)
178    
# Line 238  Line 286 
286    (type t)                      ; declared type specifier    (type t)                      ; declared type specifier
287    ;;    ;;
288    ;; If a raw slot, what it holds.  T means not raw.    ;; If a raw slot, what it holds.  T means not raw.
289    (raw-type t :type (member t single-float double-float unsigned-byte))    (raw-type t :type (member t single-float double-float #+long-float long-float
290                                #+complex-float complex-single-float
291                                #+complex-float complex-double-float
292                                #+(and complex-float long-float) complex-long-float
293                                unsigned-byte))
294    (read-only nil :type (member t nil)))    (read-only nil :type (member t nil)))
295    
296  (defun print-defstruct-description (structure stream depth)  (defun print-defstruct-description (structure stream depth)
# Line 269  Line 321 
321    
322  ;;; DSD-Name  --  External  ;;; DSD-Name  --  External
323  ;;;  ;;;
324  ;;;    Return the the name of a defstruct slot as a symbol.  We store it  ;;;    Return the name of a defstruct slot as a symbol.  We store it
325  ;;; as a string to avoid creating lots of worthless symbols at load time.  ;;; as a string to avoid creating lots of worthless symbols at load time.
326  ;;;  ;;;
327  (defun dsd-name (dsd)  (defun dsd-name (dsd)
# Line 512  Line 564 
564                  spec))                  spec))
565          spec))          spec))
566      (when (find name (dd-slots defstruct) :test #'string= :key #'dsd-%name)      (when (find name (dd-slots defstruct) :test #'string= :key #'dsd-%name)
567        (error "Duplicate slot name ~S." name))        (error 'program-error
568                 :format-control "Duplicate slot name ~S."
569                 :format-arguments (list name)))
570      (setf (dsd-%name islot) (string name))      (setf (dsd-%name islot) (string name))
571      (setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list islot)))      (setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list islot)))
572    
# Line 565  Line 619 
619                 (values 'single-float 1))                 (values 'single-float 1))
620                ((subtypep type 'double-float)                ((subtypep type 'double-float)
621                 (values 'double-float 2))                 (values 'double-float 2))
622                  #+long-float
623                  ((subtypep type 'long-float)
624                   (values 'long-float #+x86 3 #+sparc 4))
625                  #+complex-float
626                  ((subtypep type '(complex single-float))
627                   (values 'complex-single-float 2))
628                  #+complex-float
629                  ((subtypep type '(complex double-float))
630                   (values 'complex-double-float 4))
631                  #+(and long-float complex-float)
632                  ((subtypep type '(complex long-float))
633                   (values 'complex-long-float #+x86 6 #+sparc 8))
634                (t (values nil nil)))                (t (values nil nil)))
635    
636        (cond ((not raw-type)        (cond ((not raw-type)
# Line 929  Line 995 
995       (ecase rtype       (ecase rtype
996         (single-float '%raw-ref-single)         (single-float '%raw-ref-single)
997         (double-float '%raw-ref-double)         (double-float '%raw-ref-double)
998           #+long-float
999           (long-float '%raw-ref-long)
1000           #+complex-float
1001           (complex-single-float '%raw-ref-complex-single)
1002           #+complex-float
1003           (complex-double-float '%raw-ref-complex-double)
1004           #+(and complex-float long-float)
1005           (complex-long-float '%raw-ref-complex-long)
1006         (unsigned-byte 'aref)         (unsigned-byte 'aref)
1007         ((t)         ((t)
1008          (if (eq (dd-type defstruct) 'funcallable-structure)          (if (eq (dd-type defstruct) 'funcallable-structure)
1009              '%funcallable-instance-info              '%funcallable-instance-info
1010              '%instance-ref)))              '%instance-ref)))
1011       (if (eq rtype 'double-float)       (case rtype
1012           (ash (dsd-index slot) -1)         #+(and complex-float long-float)
1013           (dsd-index slot))         (complex-long-float
1014            (truncate (dsd-index slot) #+x86 6 #+sparc 8))
1015           #+long-float
1016           (long-float
1017            (truncate (dsd-index slot) #+x86 3 #+sparc 4))
1018           (double-float
1019            (ash (dsd-index slot) -1))
1020           #+complex-float
1021           (complex-double-float
1022            (ash (dsd-index slot) -2))
1023           #+complex-float
1024           (complex-single-float
1025            (ash (dsd-index slot) -1))
1026           (t
1027            (dsd-index slot)))
1028       (cond       (cond
1029        ((eq rtype 't) object)        ((eq rtype 't) object)
1030        (data)        (data)
# Line 1216  Line 1304 
1304                                  #'(lambda (x) (typep x (find-class class))))                                  #'(lambda (x) (typep x (find-class class))))
1305                              (fdefinition constructor)))                              (fdefinition constructor)))
1306      (setf (class-direct-superclasses class)      (setf (class-direct-superclasses class)
1307            (list (layout-class (svref inherits (1- (length inherits))))))            (if (eq (dd-name info) 'lisp-stream)
1308                  ;; Hack to add stream as a superclass mixin to lisp-streams.
1309                  (list (layout-class (svref inherits (1- (length inherits))))
1310                        (layout-class (svref inherits (- (length inherits) 2))))
1311                  (list (layout-class (svref inherits (1- (length inherits)))))))
1312      (let ((new-layout (make-layout :class class      (let ((new-layout (make-layout :class class
1313                                     :inherits inherits                                     :inherits inherits
1314                                     :inheritance-depth (length inherits)                                     :inheritance-depth (length inherits)
# Line 1387  Line 1479 
1479                (compiler-layout-or-lose (first include))                (compiler-layout-or-lose (first include))
1480                (class-layout (find-class (or (first superclass-opt)                (class-layout (find-class (or (first superclass-opt)
1481                                              'structure-object))))))                                              'structure-object))))))
1482      (concatenate 'simple-vector (layout-inherits super) (vector super))))      (if (eq (dd-name info) 'lisp-stream)
1483            ;; Hack to added the stream class as a mixin for lisp-streams.
1484            (concatenate 'simple-vector (layout-inherits super)
1485                         (vector super (class-layout (find-class 'stream))))
1486            (concatenate 'simple-vector (layout-inherits super) (vector super)))))
1487    
1488  ;;; %COMPILER-ONLY-DEFSTRUCT  --  Internal  ;;; %COMPILER-ONLY-DEFSTRUCT  --  Internal
1489  ;;;  ;;;
# Line 1438  Line 1533 
1533  ;;; %%Compiler-Defstruct  --  External  ;;; %%Compiler-Defstruct  --  External
1534  ;;;  ;;;
1535  ;;;    This function does the (compile load eval) time actions for updating the  ;;;    This function does the (compile load eval) time actions for updating the
1536  ;;; compiler's global meta-information to represent the definition of the the  ;;; compiler's global meta-information to represent the definition of the
1537  ;;; structure described by Info.  This primarily amounts to setting up info  ;;; structure described by Info.  This primarily amounts to setting up info
1538  ;;; about the accessor and other implicitly defined functions.  The  ;;; about the accessor and other implicitly defined functions.  The
1539  ;;; constructors are explicitly defined by top-level code.  ;;; constructors are explicitly defined by top-level code.

Legend:
Removed from v.1.58  
changed lines
  Added in v.1.58.2.1

  ViewVC Help
Powered by ViewVC 1.1.5