source: trunk/source/lib/defstruct-macros.lisp @ 14423

Last change on this file since 14423 was 14345, checked in by rme, 9 years ago

In define-compile-time-structure, don't add refinfo for inherited
slots. This addresses ticket:750.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 4.3 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2009 Clozure Associates
4;;;   Copyright (C) 1994-2001 Digitool, Inc
5;;;   This file is part of Clozure CL. 
6;;;
7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18; This file is needed to compile DEFSTRUCT and anything accessing defstruct
19; data structures.
20
21(in-package "CCL")
22
23(eval-when (:execute :compile-toplevel)
24  (require "LISPEQU"))
25
26(defconstant $struct-r/o 24)             ; Read-only bit in refinfo fixnum
27(defconstant $struct-inherited 25)              ; Struct slot is  inherited.
28
29
30(defconstant $defstruct-nth 0)   ; Anything that won't conflict with array types...
31(defconstant $defstruct-struct 8)
32(defconstant $defstruct-simple-vector 16)
33
34
35(defmacro ssd-name (ssd) `(car ,ssd))
36;(defmacro ssd-type (ssd) (declare (ignore ssd)) t)
37(defmacro ssd-initform (ssd) `(cadr ,ssd))
38;(defmacro ssd-refinfo (ssd) `(cddr ,ssd))
39
40(defmacro ssd-update-refinfo ((ssd refinfo-var) new-refinfo-form)
41  (check-type refinfo-var symbol)
42  (let ((refinfo-cons (gensym)))
43    `(let* ((,refinfo-cons (cdr ,ssd))
44            (,refinfo-var (cdr ,refinfo-cons)))
45       (when (consp ,refinfo-var)
46         (setq ,refinfo-cons ,refinfo-var)
47         (setq ,refinfo-var (%cdr ,refinfo-cons)))
48       (%rplacd ,refinfo-cons ,new-refinfo-form))))
49
50(defmacro refinfo-offset (refinfo) `(%ilogand2 #xFFFF ,refinfo))
51(defmacro refinfo-r/o (refinfo) `(%ilogbitp $struct-r/o ,refinfo))
52(defmacro refinfo-reftype (refinfo) `(%ilogand2 #xFF (%ilsr 16 ,refinfo)))
53(defmacro refinfo-inherited (refinfo) `(%ilogbitp $struct-inherited ,refinfo))
54
55(defmacro ssd-offset (ssd) `(refinfo-offset (ssd-refinfo ,ssd)))
56(defmacro ssd-r/o (ssd) `(refinfo-r/o (ssd-refinfo ,ssd)))
57(defmacro ssd-reftype (ssd) `(refinfo-reftype (ssd-refinfo ,ssd)))
58(defmacro ssd-inherited (ssd) `(refinfo-inherited (ssd-refinfo ,ssd)))
59
60(defmacro ssd-set-initform (ssd value) `(rplaca (cdr ,ssd) ,value))
61
62#| these are fns now
63(defmacro ssd-set-reftype (ssd reftype)      ;-> ssd multiply evaluated
64  `(rplacd (cdr ,ssd) (%ilogior2 (%ilogand2 #x100FFFF (cdr (%cdr ,ssd)))
65                                 (%ilsl 16 ,reftype))))
66
67(defmacro ssd-set-r/o (ssd)                  ;-> ssd multiply evaluated
68  `(rplacd (cdr ,ssd) (%ilogior2 #x1000000 (cdr (%cdr ,ssd)))))
69
70(defmacro copy-ssd (ssd)                     ;-> ssd multiply evaluated
71  `(list* (car ,ssd) (car (%cdr ,ssd)) (%cddr ,ssd)))
72|#
73
74(defmacro named-ssd (name slot-list) `(assq ,name ,slot-list))
75
76(defmacro sd-name (sd) `(car (svref ,sd 2)))
77(defmacro sd-type (sd) `(svref ,sd 0))
78(defmacro sd-slots (sd) `(svref ,sd 1))
79(defmacro sd-superclasses (sd) `(svref ,sd 2))
80(defmacro sd-size (sd) `(svref ,sd 3))
81(defmacro sd-constructor (sd) `(svref ,sd 4))
82(defmacro sd-print-function (sd) `(svref ,sd 5))
83(defmacro sd-set-print-function (sd value) `(svset ,sd 5 ,value))
84(defmacro sd-refnames (sd) `(svref ,sd 6))
85
86(defmacro struct-name (struct) `(class-cell-name (car (uvref ,struct 0))))
87(defmacro struct-def (struct) `(gethash (struct-name ,struct) %defstructs%))
88
89;Can use this to let the printer print with print-function, reader read with
90;constructor and slot-names, inspector inspect with slot-names.
91;Everything else you have to arrange yourself.
92#+ignore
93(defmacro pretend-i-am-a-structure (name constructor print-function &rest slot-names)
94  (let ((slots slot-names) (offset 1) (supers (list name)))
95    (while slots
96      (%rplaca slots (make-ssd (%car slots) () offset t))
97      (ssd-set-reftype (%car slots) $v_struct)
98      (setq slots (%cdr slots) offset (1+ offset)))
99    (push (make-ssd 0 `',supers 0 t) slot-names)
100    (ssd-set-reftype (%car slot-names) $v_struct)
101    `(puthash ',name %defstructs%
102          '#(internal-structure  ;Make structure-class-p false.
103             ,slot-names
104             ,supers
105             ,offset
106             ,constructor
107             ,print-function
108             nil))))
109
110(provide 'defstruct-macros)
111
112; End of defstruct-macros.lisp
Note: See TracBrowser for help on using the repository browser.