source: branches/qres/ccl/lib/defstruct-macros.lisp @ 14308

Last change on this file since 14308 was 13070, checked in by gz, 10 years ago

r13066, r13067 from trunk: copyrights etc

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 4.2 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
54(defmacro ssd-offset (ssd) `(refinfo-offset (ssd-refinfo ,ssd)))
55(defmacro ssd-r/o (ssd) `(refinfo-r/o (ssd-refinfo ,ssd)))
56(defmacro ssd-reftype (ssd) `(refinfo-reftype (ssd-refinfo ,ssd)))
57
58(defmacro ssd-set-initform (ssd value) `(rplaca (cdr ,ssd) ,value))
59
60#| these are fns now
61(defmacro ssd-set-reftype (ssd reftype)      ;-> ssd multiply evaluated
62  `(rplacd (cdr ,ssd) (%ilogior2 (%ilogand2 #x100FFFF (cdr (%cdr ,ssd)))
63                                 (%ilsl 16 ,reftype))))
64
65(defmacro ssd-set-r/o (ssd)                  ;-> ssd multiply evaluated
66  `(rplacd (cdr ,ssd) (%ilogior2 #x1000000 (cdr (%cdr ,ssd)))))
67
68(defmacro copy-ssd (ssd)                     ;-> ssd multiply evaluated
69  `(list* (car ,ssd) (car (%cdr ,ssd)) (%cddr ,ssd)))
70|#
71
72(defmacro named-ssd (name slot-list) `(assq ,name ,slot-list))
73
74(defmacro sd-name (sd) `(car (svref ,sd 2)))
75(defmacro sd-type (sd) `(svref ,sd 0))
76(defmacro sd-slots (sd) `(svref ,sd 1))
77(defmacro sd-superclasses (sd) `(svref ,sd 2))
78(defmacro sd-size (sd) `(svref ,sd 3))
79(defmacro sd-constructor (sd) `(svref ,sd 4))
80(defmacro sd-print-function (sd) `(svref ,sd 5))
81(defmacro sd-set-print-function (sd value) `(svset ,sd 5 ,value))
82(defmacro sd-refnames (sd) `(svref ,sd 6))
83
84(defmacro struct-name (struct) `(class-cell-name (car (uvref ,struct 0))))
85(defmacro struct-def (struct) `(gethash (struct-name ,struct) %defstructs%))
86
87;Can use this to let the printer print with print-function, reader read with
88;constructor and slot-names, inspector inspect with slot-names.
89;Everything else you have to arrange yourself.
90#+ignore
91(defmacro pretend-i-am-a-structure (name constructor print-function &rest slot-names)
92  (let ((slots slot-names) (offset 1) (supers (list name)))
93    (while slots
94      (%rplaca slots (make-ssd (%car slots) () offset t))
95      (ssd-set-reftype (%car slots) $v_struct)
96      (setq slots (%cdr slots) offset (1+ offset)))
97    (push (make-ssd 0 `',supers 0 t) slot-names)
98    (ssd-set-reftype (%car slot-names) $v_struct)
99    `(puthash ',name %defstructs%
100          '#(internal-structure  ;Make structure-class-p false.
101             ,slot-names
102             ,supers
103             ,offset
104             ,constructor
105             ,print-function
106             nil))))
107
108(provide 'defstruct-macros)
109
110; End of defstruct-macros.lisp
Note: See TracBrowser for help on using the repository browser.