source: trunk/woodequ.lisp @ 3

Revision 3, 12.0 KB checked in by gz, 9 years ago (diff)

Recovered version 0.961 from Sheldon Ball <s.ball@…>

  • Property svn:eol-style set to native
Line 
1;;;-*- Mode: Lisp; Package: WOOD -*-
2
3;;;;;;;;;;;;;;;;;;;;;;;;;;
4;;
5;; woodequ.lisp
6;; Data representation constants
7;; Largely copied from "ccl:library;lispequ.lisp"
8;;
9;; Copyright © 1996 Digitool, Inc.
10;; Copyright © 1992-1995 Apple Computer, Inc.
11;; All rights reserved.
12;; Permission is given to use, copy, and modify this software provided
13;; that Digitool is given credit in all derivative works.
14;; This software is provided "as is". Digitool makes no warranty or
15;; representation, either express or implied, with respect to this software,
16;; its quality, accuracy, merchantability, or fitness for a particular
17;; purpose.
18;;
19
20;;;;;;;;;;;;;;;;;;;;;;;;;;
21;;
22;; Modification History
23;;
24;; -------------- 0.96
25;; -------------- 0.95
26;; 05/09/96 bill  use addr+ in dc-%arrayh-xxx
27;; -------------- 0.94 = MCL-PPC 3.9
28;; 03/21/96 bill  add $v_xstr
29;; -------------- 0.93
30;; -------------- 0.9
31;; 01/18/95 bill  $btree.max-key-size
32;; -------------- 0.8
33;; 03/27/93 bill  $forwarding-pointer-header
34;; -------------- 0.6
35;; 08/27/92 bill  $v_load-function
36;; 08/24/92 bill  $btree-type_string-equal-bit, $btree-type_string-equal
37;;                (these are not yet supported by the btree code)
38;; -------------- 0.5
39;; 06/23/92 bill  persistent-clos equates, btree type bits
40;; -------------- 0.1
41;;
42
43
44(in-package :wood)
45
46; low 3 bits of an address are the tag.
47
48(defmacro pointer-tag (pointer)
49  `(the fixnum (logand ,pointer 7)))
50
51(defmacro pointer-tagp (pointer tag)
52  `(eql (pointer-tag ,pointer) ,tag))
53           
54(defmacro pointer-address (pointer)
55  `(logand ,pointer -8))
56
57(defconstant $t_fixnum 0)
58(defconstant $t_vector 1)
59(defconstant $t_symbol 2)
60(defconstant $t_dfloat 3)
61(defconstant $t_cons 4)
62(defconstant $t_sfloat 5)
63(defconstant $t_lfun 6)
64(defconstant $t_imm 7)
65
66; Non-cons cells have a header long-word for the garbage collector.
67(defconstant $vector-header #x1ff)
68(defconstant $symbol-header #x8ff)
69; Need to find a value that can't be the first word of a float
70(defconstant $forwarding-pointer-header #xfff)
71
72; Vectors are a longword of block header, 1 byte of subtype, 3 bytes of length (in bytes)
73; then the contents.
74;
75;  -------------------
76; | 00 | 00 | 01 | FF |
77; |-------------------|
78; | ST |    Length    |
79; |-------------------|
80; |     Contents      |
81; |         .         |
82; |         .         |
83; |         .         |
84;  -------------------
85
86; Array subtypes. Multiply by two to get the MCL subtype
87;(defconstant $v_packed_sstr 0)          ; used in image loader/dumper
88(defconstant $v_bignum 1)
89(defconstant $v_macptr 2)
90(defconstant $v_badptr 3)
91(defconstant $v_nlfunv 4)               ; Lisp FUNction vector
92;subtype 5 unused
93(defconstant $v_xstr 6)      ;16-bit character vector
94(defconstant $v_min_arr 7)
95(defconstant $v_ubytev 7)    ;unsigned byte vector
96(defconstant $v_uwordv 8)    ;unsigned word vector
97(defconstant $v_floatv 9)    ;float vector
98(defconstant $v_slongv 10)   ;Signed long vector
99(defconstant $v_ulongv 11)   ;Unsigned long vector
100(defconstant $v_bitv 12)     ;Bit vector
101(defconstant $v_sbytev 13)   ;Signed byte vector
102(defconstant $v_swordv 14)   ;Signed word vector
103(defconstant $v_sstr 15)     ;simple string
104(defconstant $v_genv 16)     ;simple general vector
105(defconstant $v_arrayh 17)   ;complex array header
106(defconstant $v_struct 18)   ;structure
107(defconstant $v_mark 19)     ;buffer mark
108(defconstant $v_pkg 20)
109;subtype 21 unused
110(defconstant $v_istruct 22)
111(defconstant $v_ratio 23)
112(defconstant $v_complex 24)
113(defconstant $v_instance 25) ;clos instance
114; subtypes 26, 27, 28 unused.
115(defconstant $v_weakh 29)
116(defconstant $v_poolfreelist 30)
117(defconstant $v_nhash 31)
118
119; Types that exist only in the database
120(defconstant $v_area 32)                ; area descriptor
121(defconstant $v_segment 33)             ; area segment
122(defconstant $v_random-bits 34)         ; used for vectors of random bits, e.g. resources
123(defconstant $v_dbheader 35)            ; database header
124(defconstant $v_segment-headers 36)     ; Segment headers page.
125(defconstant $v_btree 37)               ; a BTREE
126(defconstant $v_btree-node 38)          ; one node of a BTREE's tree.
127(defconstant $v_class 39)               ; class
128(defconstant $v_load-function 40)       ; result of P-MAKE-LOAD-FUNCTION-OBJECT
129(defconstant $v_pload-barrier 41)       ; result of P-MAKE-PLOAD-BARRIER
130
131(defconstant $v_link (- $t_vector))
132(defconstant $V_SUBTYPE 3)
133(defconstant $V_DATA 7)
134(defconstant $V_LOG 3)
135(defconstant $vector-header-size 8)
136
137(defconstant $vnodebit 5)               ; set for arrays containing pointers
138(defconstant $vnode (lsh 1 $vnodebit))
139
140; NIL is tagged as a cons with and address of 0
141(defconstant $pheap-nil $t_cons)
142
143(defmacro def-indices (&body indices)
144  (let ((index 0)
145        res)
146    (dolist (spec indices)
147      (labels ((f (spec)
148                 (etypecase spec
149                   (symbol (push `(defconstant ,spec ,index) res))
150                   (list (dolist (sub-spec spec)
151                           (f sub-spec))))))
152        (declare (dynamic-extent f))
153        (f spec)
154        (incf index)))
155    `(progn ,@(nreverse res))))
156
157; Symbols are not regular vectors.
158(defconstant $sym_header -2)            ; $symbol-header
159(defconstant $sym_pname 2)
160(defconstant $sym_package 6)
161(defconstant $sym_values 10)            ; place for (value function . plist)
162(defconstant $symbol-size 16)
163
164; Packages do not support inheritance.
165; maybe they should.
166(def-indices
167  $pkg.names
168  $pkg.btree
169  $pkg-length)
170
171; Weak lists. Subtype $v_weakh
172(def-indices
173  $population.gclink
174  $population.type
175  $population.data
176  $population-size)
177
178;;;;;;;;;;;;;;;;;;;;;;;;;;
179;;
180;; A PHEAP file starts with a single vector containing
181;; the root objects and the file-wide information.
182;;
183(defconstant $block-overhead 8)         ; commit-lsn + segment-ptr
184(defconstant $block-commit-lsn 0)
185(defconstant $block-segment-ptr 4)
186
187(defconstant $root-vector (+ $block-overhead $t_vector))
188
189(def-indices
190  $pheap.version                        ; version number
191  $pheap.free-page                      ; free pointer in pages
192  $pheap.root                           ; root object
193  $pheap.default-consing-area           ; a pointer to an area descriptor
194  $pheap.class-hash                     ; class hash table
195  $pheap.page-size                      ; size of a page in bytes
196  $pheap.btree-free-list                ; head of linked list of btree nodes
197  $pheap.package-btree                  ; string->package table
198  $pheap.page-write-count               ; pages written since open
199  $pheap-free9
200  $pheap-free10
201  $pheap-free11
202  $pheap-free12
203  $pheap-free13
204  $pheap-free14
205  $pheap-free15
206  $pheap-header-size
207  )
208
209; A segment headers page header. Subtype is $v_segment-headers
210; The header in the first page of headers for an area
211; contains the $area.xxx information as well.
212(def-indices
213  $segment-headers.area                 ; my area
214  $segment-headers.link                 ; next segment headers page
215  $area.flags                           ; fixnum
216  $area.segment-size                    ; default size for segments
217  $area.last-headers                    ; last segment headers page
218  $area.free-count                      ; number of headers left in $area.last-headers
219  $area.free-ptr                        ; cons pointing at current header
220  $area-descriptor-size
221  )
222
223(defconstant $segment-headers-size $area.flags)
224
225; A segment header page entry
226; Pointers to these are typed as conses
227(defconstant $segment-header_free -4)   ; pointer to free space. Tagged as a cons
228(defconstant $segment-header_freebytes 0)       ; number of bytes left
229(defconstant $segment-header_free-link 4)       ; header entry with free space
230(defconstant $segment-header_segment 8)         ; beginning of the segment
231(defconstant $segment-header-entry-bytes (* 4 4))       ; must be a multiple of 8
232
233; The header of a segment. Subtype is $v_segment
234; This vector contains all other types of objects
235(def-indices
236  $segment.area                         ; my area
237  $segment.header                       ; my header entry
238  $segment-header-size
239  )
240
241; Complex array headers
242; Copied from lispequ.
243(def-indices
244  $arh.fixnum
245  $arh.offs
246  $arh.vect
247  ($arh.vlen $arh.dims)
248  $arh.fill)
249
250;byte offsets in arh.fixnum slot.
251(defconstant $arh_rank4 0)              ;4*rank
252(defconstant $arh_type 2)               ;vector subtype
253(defconstant $arh_bits 3)               ;Flags
254
255(defconstant $arh_one_dim 4)            ;arh.rank4 value of one-dim arrays
256
257;Bits in $arh_bits.
258(defconstant $arh_adjp_bit 7)           ;adjustable-p
259(defconstant $arh_fill_bit 6)           ;fill-pointer-p
260(defconstant $arh_disp_bit 5)           ;displaced to another array header -p
261(defconstant $arh_simple_bit 4)         ;not adjustable, no fill-pointer and
262                                        ; not user-visibly displaced -p
263
264(defmacro dc-%arrayh-bits (disk-cache pointer)
265  (setq disk-cache (require-type disk-cache 'symbol))
266  `(the fixnum
267        (read-8-bits ,disk-cache
268                     (addr+ ,disk-cache
269                            ,pointer
270                            (+ $v_data (* 4 $arh.fixnum) $arh_bits)))))
271
272(defmacro dc-%arrayh-type (disk-cache pointer)
273  (setq disk-cache (require-type disk-cache 'symbol))
274  `(the fixnum
275        (read-8-bits ,disk-cache
276                     (addr+ ,disk-cache
277                            ,pointer
278                            (+ $v_data (* 4 $arh.fixnum) $arh_type)))))
279
280(defmacro dc-%arrayh-rank4 (disk-cache pointer)
281  (setq disk-cache (require-type disk-cache 'symbol))
282  `(the fixnum
283        (read-unsigned-word
284         ,disk-cache
285         (addr+ ,disk-cache
286                ,pointer
287                (+ $v_data (* 4 $arh.fixnum) $arh_rank4)))))
288
289(defmacro arh.fixnum_type-bytespec ()
290  (byte 8 5))
291
292(defmacro arh.fixnum_type (fixnum)
293  `(ldb (arh.fixnum_type-bytespec) ,fixnum))
294
295;;;;;;;;;;;;;;;;;;;;;;;;;;
296;;;
297;;; btree vector - subtype $v_btree
298;;;
299(def-indices
300  $btree.root                           ; the root node
301  $btree.count                          ; number of leaf entries
302  $btree.depth                          ; 0 means only the root exists
303  $btree.nodes                          ; total number of nodes
304  $btree.first-leaf                     ; first leaf node. A constant
305  $btree.type                           ; type bits
306  $btree.max-key-size                   ; maximum size of a key
307  $btree-size                           ; length of a $v_btree vector
308  )
309
310;; Btree type bits
311(defconstant $btree-type_eqhash-bit 0)          ; EQ hash table
312(defconstant $btree-type_weak-bit 1)    ; weak hash table
313(defconstant $btree-type_weak-value-bit 2)      ; weak on value, not key
314(defconstant $btree-type_string-equal-bit 3)    ; use string-equal, not string=
315
316; Btree type values
317(defconstant $btree-type_normal 0)      ; normal string->value btree
318(defconstant $btree-type_string-equal (ash 1 $btree-type_string-equal-bit))
319(defconstant $btree-type_eqhash (ash 1 $btree-type_eqhash-bit))
320(defconstant $btree-type_eqhash-weak-key
321  (+ $btree-type_eqhash (ash 1 $btree-type_weak-bit)))
322(defconstant $btree-type_eqhash-weak-value
323  (+ $btree-type_eqhash-weak-key (ash 1 $btree-type_weak-value-bit)))
324
325;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
326;;;
327;;; Persistent CLOS equates
328;;;
329
330; subtype $v_instance
331(def-indices
332  $instance.wrapper                     ; class wrapper
333  $instance.slots                       ; slots vector
334  $instance-size)
335
336; A wrapper is a regular general vector
337(def-indices
338  $wrapper.class
339  $wrapper.slots                        ; vector of slot names
340  $wrapper-size)
341
342; subtype $v_class
343(def-indices
344  $class.name
345  $class.own-wrapper
346  $class-size)
347
348(defmacro %unbound-marker ()
349  (ccl::%unbound-marker-8))
350
351;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
352;;;
353;;; $v_load-function subtype
354;;;
355(def-indices
356  $load-function.load-list              ; load-function.args
357  $load-function.init-list              ; init-function.args
358  $load-function-size)
359
360;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
361;;;
362;;; $v_pload-barrier subtype
363;;;
364
365(def-indices
366  $pload-barrier.object
367  $pload-barrier-size)
368
369
370(provide :woodequ)
371;;;    1   3/10/94  bill         1.8d247
372;;;    2   7/26/94  Derek        1.9d027
373;;;    2   2/18/95  RŽti         1.10d019
374;;;    3   3/23/95  bill         1.11d010
Note: See TracBrowser for help on using the repository browser.