source: branches/working-0711/ccl/library/lispequ.lisp @ 7958

Last change on this file since 7958 was 7958, checked in by gb, 13 years ago

CLASS-WRAPER caches CPL.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 44.6 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17;; LispEqu.lisp
18
19(in-package "CCL")
20
21(defconstant $flags_Normal 0)
22(defconstant $flags_DisposeRecursiveLock 1)
23(defconstant $flags_DisposPtr 2)
24(defconstant $flags_DisposeRwlock 3)
25(defconstant $flags_DisposeSemaphore 4)
26
27(defconstant $system-lock-type-recursive 0)
28(defconstant $system-lock-type-rwlock 1)
29
30;;; this stuff is really ppc specific at the moment
31(defconstant $population_weak-list 0)
32(defconstant $population_weak-alist 1)
33(defconstant $population_termination-bit 16)
34
35;;; type of 0 is a weak-list
36;;; Note that this evals its args in the wrong order.
37(defmacro %cons-population (data &optional (type 0) (termination? nil))
38  (if termination?
39    `(gvector :population 0 (logior (ash 1 $population_termination-bit) ,type) ,data nil)
40    `(gvector :population 0 ,type ,data)))
41
42(defmacro %cons-terminatable-alist (&optional data)
43  `(%cons-population ,data $population_weak-alist t))
44
45;;; The GC assumes that this structure is laid out exactly as below.
46;;; It also assumes that if the $population_termination-bit is set in the
47;;; population.type slot, the vector is of length 4, otherwise 3.
48(def-accessors (population) %svref
49  population.gclink
50  population.type
51  population.data
52  population.termination-list)
53
54(def-accessors () uvref
55  nil
56  nil
57  population-data                      ; type-checked
58  population-termination-list)
59
60(defmacro %cons-pool (&optional data)
61  `(gvector :pool ,data))
62
63(def-accessors (pool) %svref
64  pool.data)
65
66(def-accessors (resource) %svref
67  nil                                   ; 'resource
68  resource.constructor
69  resource.destructor
70  resource.initializer
71  resource.pool
72  resource.lock)
73
74(defmacro gvector (type-keyword &rest initial-values)
75  `(%gvector ,(type-keyword-code type-keyword) ,@initial-values))
76
77
78(defmacro allocate-typed-vector (type-keyword elements &optional (init nil init-p))
79  `(%alloc-misc ,elements ,(type-keyword-code type-keyword)
80    ,@(if init-p `(,init))))
81   
82
83(def-accessors (semaphore) %svref
84  nil                                   ;'semaphore
85  semaphore.value)
86
87
88(defmacro %istruct (istruct-name &rest initial-values)
89  `(gvector :ISTRUCT ,istruct-name ,@initial-values))
90
91
92(defmacro %cons-resource (constructor &optional destructor initializer)
93  `(%istruct 'resource ,constructor ,destructor ,initializer (%cons-pool) (make-lock)))
94
95
96
97;;; Symbol [f,v]bits.
98
99(defconstant $sym_bit_bound 0)          ;Proclaimed bound.
100(defconstant $sym_bit_const 1)
101(defconstant $sym_bit_global 2)         ;Should never be lambda-bound.
102(defconstant $sym_bit_special 4)
103(defconstant $sym_vbit_typeppred 5)
104(defconstant $sym_bit_indirect 6)
105(defconstant $sym_bit_defunct 7)
106
107(defconstant $sym_vbit_bound $sym_bit_bound)
108(defconstant $sym_vbit_const $sym_bit_const)
109(defconstant $sym_vbit_global $sym_bit_global)
110(defconstant $sym_vbit_special $sym_bit_special)
111(defconstant $sym_vbit_indirect $sym_bit_indirect)
112(defconstant $sym_vbit_defunct $sym_bit_defunct)
113
114(defconstant $sym_fbit_frozen (+ 8 $sym_bit_bound))
115(defconstant $sym_fbit_special (+ 8 $sym_bit_special))
116(defconstant $sym_fbit_indirect (+ 8 $sym_bit_indirect))
117(defconstant $sym_fbit_defunct (+ 8 $sym_bit_defunct))
118
119(defconstant $sym_fbit_constant_fold (+ 8 $sym_bit_const))
120(defconstant $sym_fbit_fold_subforms (+ 8 $sym_bit_global))
121
122(def-accessors () %svref
123  nil                                   ;'destructure-state
124  destructure-state.current
125  destructure-state.whole
126  destructure-state.lambda
127  )
128
129;Lfun bits.
130;Assumed to be a fixnum, so if you ever assign a bit number > 28,
131;change lfun-bits and its callers.
132(defconstant $lfbits-nonnullenv-bit 0)
133(defconstant $lfbits-keys-bit 1)
134(defconstant $lfbits-numopt (byte 5 2))
135(defconstant $lfbits-restv-bit 7)
136(defconstant $lfbits-numreq (byte 6 8))
137(defconstant $lfbits-optinit-bit 14)
138(defconstant $lfbits-rest-bit 15)
139(defconstant $lfbits-aok-bit 16)
140(defconstant $lfbits-numinh (byte 6 17))
141(defconstant $lfbits-symmap-bit 23)
142(defconstant $lfbits-trampoline-bit 24)
143(defconstant $lfbits-evaluated-bit 25)
144(defconstant $lfbits-cm-bit 26)         ; combined-method
145(defconstant $lfbits-nextmeth-bit 26)   ; or call-next-method with method-bit
146(defconstant $lfbits-gfn-bit 27)        ; generic-function
147(defconstant $lfbits-nextmeth-with-args-bit 27)   ; or call-next-method-with-args with method-bit
148(defconstant $lfbits-method-bit 28)     ; method function
149(defconstant $lfbits-noname-bit 29)
150
151
152(defconstant $lfbits-args-mask
153  (%ilogior (dpb -1 $lfbits-numreq 0)
154            (dpb -1 $lfbits-numopt 0)
155            (%ilsl $lfbits-rest-bit 1)
156            (%ilsl $lfbits-keys-bit 1)
157            (%ilsl $lfbits-aok-bit 1)))
158
159;Bits in $arh_bits.
160(defconstant $arh_adjp_bit 7)           ;adjustable-p
161(defconstant $arh_fill_bit 6)           ;fill-pointer-p
162(defconstant $arh_disp_bit 5)           ;displaced to another array header -p
163(defconstant $arh_simple_bit 4)         ;not adjustable, no fill-pointer and
164                                        ; not user-visibly displaced -p
165(defconstant $arh_exp_disp_bit 3)       ;explicitly-displaced -p
166
167(def-accessors (lexical-environment) %svref
168  ()                                    ; 'lexical-environment
169  lexenv.parent-env
170  lexenv.functions
171  lexenv.variables
172  lexenv.fdecls                         ; function-binding decls, e.g., [NOT]INLINE, FTYPE
173  lexenv.vdecls                         ; variable-binding decls, e.g., SPECIAL, TYPE
174  lexenv.mdecls                         ; misc decls, e.g., OPTIMIZE
175  lexenv.lambda                         ; unique id (e.g., afunc) of containing lambda expression.
176  )
177
178(def-accessors (definition-environment) %svref
179  ()                                    ; 'definition-environment
180  defenv.type                           ; must be LIST, match lexenv.parent-env
181  defenv.functions                      ; compile-time macros, same structure as lexenv.functions
182  defenv.constants                      ; definition-time constants, shadows lexenv.variables
183  defenv.fdecls                         ; shadows lexenv.fdecls
184  defenv.vdecls                         ; shadows lexenv.vdecls
185  defenv.mdecls                         ; shadows lexenv.mdecls
186;;; extended info
187  defenv.types                          ; compile-time deftype info, shadows lexenv.function
188  defenv.defined                        ; functions defined in compilation unit.
189  defenv.specials
190  defenv.classes                        ; classed defined in compilation unit
191  defenv.structrefs                     ; compile-time DEFSTRUCT accessor info
192  defenv.structures                     ; compile-time DEFSTRUCT info
193  defenv.symbol-macros                  ; compile-time SYMBOL-MACROS.
194)
195
196(def-accessors (var) %svref
197  nil                                   ; 'var
198  var-name                              ; symbol
199  (var-bits var-parent)                 ; fixnum or ptr to parent
200  (var-ea  var-expansion)               ; p2 address (or symbol-macro expansion)
201  var-decls                             ; list of applicable decls
202  var-inittype
203  var-binding-info
204  var-refs
205)
206
207(def-accessors (package) %svref
208  pkg.itab
209  pkg.etab
210  pkg.used
211  pkg.used-by
212  pkg.names
213  pkg.shadowed
214  pkg.lock
215  pkg.intern-hook
216  )
217
218(defmacro package-deleted-marker ()
219  (%unbound-marker))
220
221
222
223
224(defmacro %cons-fake-stack-frame (&optional sp next-sp fn lr vsp xp link)
225  `(%istruct 'fake-stack-frame ,sp ,next-sp ,fn ,lr ,vsp ,xp ,link))
226
227(def-accessors () svref
228  bt.dialog
229  bt.youngest
230  bt.oldest
231  bt.tcr
232  bt.restarts
233  bt.top-catch
234  bt.break-condition
235  bt.current
236  bt.fake-frames
237  bt.db-link
238  bt.break-level)
239
240(defconstant bt.sg bt.tcr)
241(setf (macro-function 'bt.sg) (macro-function 'bt.tcr))
242
243
244(def-accessors (lock) %svref
245  lock.value
246  lock.name)
247
248
249
250
251
252
253 
254;contents of pkg.itab/pkg.etab.
255(defmacro pkgtab-table (htab) `(car (the list ,htab)))
256#|
257(defmacro pkgtab-hcount (htab) `(car (the list (cdr (the list ,htab)))))                                            (mkint acc)))
258(defmacro pkgtab-hlimit (htab) `(cdr (the list (cdr (the list ,htab)))))
259|#
260
261
262
263(def-accessors (pathname) %svref
264  ()                                    ; 'pathname
265  %pathname-directory
266  %pathname-name
267  %pathname-type
268  %physical-pathname-version)
269
270(def-accessors (logical-pathname) %svref
271  ()                                    ; 'logical-pathname
272  %pathname-directory
273  %pathname-name
274  %pathname-type 
275  %logical-pathname-host
276  %logical-pathname-version)
277
278(defmacro %cons-pathname (directory name type &optional version)
279  `(%istruct 'pathname ,directory ,name ,type ,version))
280
281(defmacro %cons-logical-pathname (directory name type host version)
282  `(%istruct 'logical-pathname ,directory ,name ,type ,host ,version))
283
284(def-accessors (restart) %svref
285  ()                                    ; 'restart
286  %restart-name
287  %restart-action
288  %restart-report
289  %restart-interactive
290  %restart-test)
291
292;;; %cons-restart now in level-2.lisp
293
294
295(def-accessors %svref
296  nil                                   ; 'periodic-task
297  ptask.state
298  ptask.name
299  ptask.function
300)
301
302;;;;;; CMU type system.
303
304
305
306(def-accessors (type-class) %svref
307  nil                                   ; 'type-class
308  type-class-name                       ; name
309
310  ;; Dyadic type methods.  If the classes of the two types are EQ, then we call
311  ;; the SIMPLE-xxx method.  If the classes are not EQ, and either type's class
312  ;; has a COMPLEX-xxx method, then we call it.
313  ;;
314  ;; Although it is undefined which method will get precedence when both types
315  ;; have a complex method, the complex method can assume that the second arg
316  ;; always is in its class, and the first always is not.  The arguments to
317  ;; commutative operations will be swapped if the first argument has a complex
318  ;; method.
319  ;;
320  ;; Since SUBTYPEP is not commutative, we have two complex methods.  the ARG1
321  ;; method is only called when the first argument is in its class, and the
322  ;; ARG2 method is only called when called when the second type is.  If either
323  ;; is specified, both must be.
324  type-class-simple-subtypep
325  type-class-complex-subtypep-arg1
326  type-class-complex-subtypep-arg2
327  ;;
328  ;; SIMPLE-UNION combines two types of the same class into a single type of
329  ;; that class.  If the result is a two-type union, then return NIL.
330  ;; VANILLA-UNION returns whichever argument is a supertype of the other, or
331  ;; NIL.
332  type-class-simple-union
333  type-class-complex-union
334  ;; The default intersection methods assume that if one type is a subtype of
335  ;; the other, then that type is the intersection.
336  type-class-simple-intersection
337  type-class-complex-intersection
338  ;;
339  type-class-simple-=
340  type-class-complex-=
341  type-class-unparse
342) 
343
344;; This istruct (and its subtypes) are used to define types.
345(def-accessors (ctype) %svref
346  nil                                   ; 'ctype or a subtype
347  ctype-class-info                       ; a type-class
348  ;; True if this type has a fixed number of members, and as such could
349  ;; possibly be completely specified in a MEMBER type.  This is used by the
350  ;; MEMBER type methods.
351  ctype-enumerable
352)
353
354;; args-ctype is a subtype of ctype
355(def-accessors (args-ctype) %svref
356  nil                                   ; 'args-ctype
357  nil                                   ; ctype-class-info             
358  nil                                   ; ctype-enumerable
359  ;; Lists of the type for each required and optional argument.
360  args-ctype-required
361  args-ctype-optional
362  ;;
363  ;; The type for the rest arg.  NIL if there is no rest arg.
364  args-ctype-rest
365  ;; True if keyword arguments are specified.
366  args-ctype-keyp
367  ;; List of key-info structures describing the keyword arguments.
368  args-ctype-keywords
369  ;; True if other keywords are allowed.
370  args-ctype-allowp
371)
372
373(def-accessors (key-info) %svref
374  nil                                   ; 'key-info
375  key-info-name                         ; Name of &key arg
376  key-info-type                         ; type (ctype) of this &key arg
377)
378
379;;; VALUES-ctype is a subtype of ARGS-ctype.
380(def-accessors (values-ctype) %svref
381  nil                                   ; 'values-ctype
382  nil                                   ; ctype-class-info           
383  nil                                   ; ctype-enumerable
384  ;; Lists of the type for each required and optional argument.
385  values-ctype-required
386  values-ctype-optional
387  ;;
388  ;; The type for the rest arg.  NIL if there is no rest arg.
389  values-ctype-rest
390  ;; True if keyword arguments are specified.
391  values-ctype-keyp
392  ;; List of key-info structures describing the keyword arguments.
393  values-ctype-keywords
394  ;; True if other keywords are allowed.
395  values-ctype-allowp
396)
397
398;;; FUNCTION-ctype is a subtype of ARGS-ctype.
399(def-accessors (args-ctype) %svref
400  nil                                   ; 'function-ctype
401  nil                                   ; ctype-class-info           
402  nil                                   ; ctype-enumerable
403  function-ctype-required               ; args-ctype-required
404  function-ctype-optional               ; args-ctype-optional
405  function-ctype-rest                   ; args-ctype-rest
406  function-ctype-keyp                   ; args-ctype-keyp
407  function-ctype-keywords               ; args-ctype-keywords
408  function-ctype-allowp                 ; args-ctype-allowp
409;; True if the arguments are unrestrictive, i.e. *.
410  function-ctype-wild-args
411  ;;
412  ;; Type describing the return values.  This is a values type
413  ;; when multiple values were specified for the return.
414  function-ctype-returns
415)
416
417;;; The CONSTANT-ctype structure represents a use of the CONSTANT-ARGUMENT "type
418;;; specifier", which is only meaningful in function argument type specifiers
419;;; used within the compiler.
420;;;
421
422
423(def-accessors (constant-ctype) %svref
424  nil                                   ; 'constant-ctype
425  nil                                   ; ctype-class-info           
426  nil                                   ; ctype-enumerable
427  ;; The type which the argument must be a constant instance of for this type
428  ;; specifier to win.
429  constant-ctype-type
430)
431
432;;; The NAMED-ctype is used to represent *, T and NIL.  These types must be
433;;; super or sub types of all types, not just classes and * & NIL aren't
434;;; classes anyway, so it wouldn't make much sense to make them built-in
435;;; classes.
436;;;
437
438(def-accessors (named-ctype) %svref
439  nil                                   ; 'named-ctype
440  nil                                   ; ctype-class-info           
441  nil                                   ; ctype-enumerable
442  named-ctype-name
443)
444
445;;; The Hairy-ctype represents anything too wierd to be described
446;;; reasonably or to be useful, such as SATISFIES.  We just remember
447;;; the original type spec.
448;;;
449
450(def-accessors (hairy-ctype) %svref
451  nil                                   ; 'hairy-ctype
452  nil                                   ; ctype-class-info           
453  nil                                   ; ctype-enumerable
454  ;; The type which the argument must be a constant instance of for this type
455  ;; specifier to win.
456  hairy-ctype-specifier
457)
458
459;;; An UNKNOWN-ctype is a type not known to the type system (not yet defined).
460;;; We make this distinction since we don't want to complain about types that
461;;; are hairy but defined.
462;;;
463
464;;; This means that UNKNOWN-ctype is a HAIRY-ctype.
465(def-accessors (unknown-ctype) %svref
466  nil                                   ; 'unknown-ctype
467  nil                                   ; ctype-class-info           
468  nil                                   ; ctype-enumerable
469  unknown-ctype-specifier
470)
471
472;;; CONS-ctype is a subclass of CTYPE
473(def-accessors (cons-ctype) %svref
474  nil                                   ; 'cons-ctype
475  nil                                   ; ctype-class-info
476  nil                                   ; ctype-enumerable
477  cons-ctype-car-ctype                  ; ctype of the car
478  cons-ctype-cdr-ctype                  ; ctype of the cdr
479  )
480
481;;; NUMERIC-ctype is a subclass of CTYPE
482(def-accessors (numeric-ctype) %svref
483  nil                                   ; numeric-ctype
484  nil                                   ; ctype-class-info           
485  nil                                   ; ctype-enumerable
486  ;;
487  ;; The kind of numeric type we have.  NIL if not specified (just NUMBER or
488  ;; COMPLEX).
489  numeric-ctype-class
490  ;; Format for a float type.  NIL if not specified or not a float.  Formats
491  ;; which don't exist in a given implementation don't appear here.
492  numeric-ctype-format
493  ;; Is this a complex numeric type?  Null if unknown (only in NUMBER.)
494  numeric-ctype-complexp
495  ;; The upper and lower bounds on the value.  If null, there is no bound.  If
496  ;; a list of a number, the bound is exclusive.  Integer types never have
497  ;; exclusive bounds.
498  numeric-ctype-low
499  numeric-ctype-high
500  numeric-ctype-predicate
501)
502
503;;; ARRAY-ctype is a subclass of CTYPE.
504(def-accessors (array-ctype) %svref
505  nil                                   ; 'array-ctype
506  nil                                   ; ctype-class-info           
507  nil                                   ; ctype-enumerable
508  ;;
509  ;; The dimensions of the array.  * if unspecified.  If a dimension is
510  ;; unspecified, it is *.
511  array-ctype-dimensions
512  ;;
513  ;; Is this not a simple array type?
514  array-ctype-complexp
515  ;;
516  ;; The element type as originally specified.
517  array-ctype-element-type
518  ;;
519  ;; The element type as it is specialized in this implementation.
520  array-ctype-specialized-element-type
521  ;; The typecode of the specialize element type, or NIL.
522  array-ctype-typecode
523)
524
525;;; MEMBER-ctype is a direct subclass of CTYPE.
526(def-accessors (member-ctype) %svref
527  nil                                   ; 'member-ctype
528  nil                                   ; ctype-class-info           
529  nil                                   ; ctype-enumerable
530  ;;
531  ;; The things in the set, with no duplications.
532  member-ctype-members
533)
534
535;;; UNION-ctype is a direct subclass of CTYPE.
536(def-accessors (union-ctype) %svref
537  nil                                   ; 'union-ctype
538  nil                                   ; ctype-class-info           
539  nil                                   ; ctype-enumerable
540  ;;
541  ;; The types in the union.
542  union-ctype-types
543)
544
545;;; INTERSECTION-ctype is a direct subclass of CTYPE.
546(def-accessors (intersection-ctype) %svref
547  nil                                   ; 'intersection-ctype
548  nil                                   ; ctype-class-info           
549  nil                                   ; ctype-enumerable
550  ;;
551  ;; The types in the intersection
552  intersection-ctype-types
553)
554
555(def-accessors (negation-ctype) %svref
556  nil                                   ; 'negation-ctype
557  nil                                   ; ctype-class-info           
558  nil                                   ; ctype-enumerable
559  ;; The type of what we're not:
560  negation-ctype-type
561  )
562 
563
564
565
566;;; It'd be nice to integrate "foreign" types into the type system
567(def-accessors (foreign-ctype) %svref
568  nil                                   ; 'foreign-ctype
569  nil                                   ; ctype-class-info           
570  nil                                   ; ctype-enumerable
571  foreign-ctype-foreign-type
572)
573 
574;;; Most "real" CLOS objects have one of these in their %class.ctype slot
575
576(def-accessors (class-ctype) %svref
577  nil                                   ; 'class-ctype
578  nil                                   ; ctype-class-info           
579  nil                                   ; ctype-enumerable
580  class-ctype-class                     ; backptr to class.
581  class-ctype-translation               ; ctype for some built-in-classes.
582)
583
584
585
586;;;;;;;
587;;
588;; state for with-package-iterator
589;;
590(def-accessors %svref
591  pkg-iter-step.pkg                     ; package
592  pkg-iter-step.type                    ; keyword
593  pkg-iter-step.table
594  pkg-iter-step.shadowed
595  pkg-iter-step.vector
596  pkg-iter-step.index)
597
598(def-accessors %svref
599  pkg-iter.step                         ; current step
600  pkg-iter.remaining-steps              ; steps to be processed
601)
602
603
604;;;;;;;;;;;;;
605
606(defconstant $catch.tag 0)
607(defconstant $catch.mvflag (+ $catch.tag 4))
608(defconstant $catch.dblink (+ $catch.mvflag 4))
609(defconstant $catch.vsp (+ $catch.dblink 4))
610(defconstant $catch.regs (+ $catch.vsp 4))
611(defconstant $catch.link (+ $catch.regs (* 4 5)))
612(defconstant $catch.scgvll (+ $catch.link 4))
613(defconstant $catch.cs_area (+ $catch.scgvll 4))
614(defconstant $catch.pc (+ $catch.cs_area 4))
615(defconstant $catchfsize (+ $catch.pc 4))
616
617
618;;; Bits in *gc-event-status-bits*
619(defconstant $gc-retain-pages-bit 0)
620(defconstant $gc-integrity-check-bit 2)
621(defconstant $gc-allow-stack-overflows-bit 5)
622(defconstant $egc-verbose-bit 3)
623(defconstant $gc-verbose-bit 4)
624(defconstant $gc-postgc-pending-bit 26)
625
626
627
628;;; Values for the flags arg to %install-periodic-task
629(defconstant $ptask_draw-flag 1)       ; set for tasks that do drawing
630(defconstant $ptask_event-dispatch-flag 2)      ; set for tasks that do event processing
631
632
633
634
635
636(defconstant struct.type 0)
637(defconstant istruct.type 0)
638
639(def-accessors (readtable) %svref
640  ()                                        ; 'readtable
641  rdtab.ttab                                ; type table
642  rdtab.alist                               ; macro-char alist
643  rdtab.case)                               ; gratuitous braindeath
644
645;character types in readtables
646(defconstant $cht_ill 0)                ;Illegal char
647(defconstant $cht_wsp 1)                ;Whitespace
648(defconstant $cht_sesc 4)               ;Single escape (\)
649(defconstant $cht_mesc 5)               ;Multiple escape (|)
650(defconstant $cht_cnst 6)               ;Atom constituent
651(defconstant $cht_tmac 8)               ;Terminating macro
652(defconstant $cht_ntmac 9)              ;Non-terminating macro
653
654(defconstant $cht_macbit 3)             ;This bit on in CHT_TMAC and CHT_NTMAC
655
656;;; quantifiers
657
658(defconstant $some 0)
659(defconstant $notany 1)
660(defconstant $every 2)
661(defconstant $notevery 3)
662
663;;; Error string constants.  As accurate as constants.i ...
664
665(defconstant $XVUNBND 1)
666;(defconstant $XNOCDR 2)
667(defconstant $xbadvec 6)
668(defconstant $XTMINPS 3)
669(defconstant $XNEINPS 4)
670(defconstant $XWRNGINP 5)
671(defconstant $err-bad-input 5)
672(defconstant $XFUNBND 6)
673;;(defconstant $err-fundefined 6)
674;;(defconstant $XNOCAR 7)
675(defconstant $xsetbadvec 7)
676(defconstant $xcoerce 8)
677(defconstant $xnofinfunction 9)
678(defconstant $xnomem 10)
679(defconstant $xnotranslation 12)
680(defconstant $XNOTFUN 13)
681(defconstant $XNOTsymlam 14)
682(defconstant $Xdeclpos 15)
683(defconstant $Xsetconstant 16)
684(defconstant $Xoddsetq 17)
685(defconstant $Xbadsetq 18)
686(defconstant $Xnotsym 19)
687(defconstant $Xisconstant 20)
688(defconstant $Xbadinit 21)
689(defconstant $Xsmacspec 22)
690(defconstant $X2manyargs 23)
691(defconstant $XNolexvar 24)
692(defconstant $XNolexfunc 25)
693(defconstant $XNolextag 26)
694(defconstant $XNolexblock 27)
695(defconstant $XNotag 28)
696(defconstant $Xduplicatetag 29)
697(defconstant $XNoblock 30)
698(defconstant $XBadLambdaList 31)
699(defconstant $XBadLambda 32)
700(defconstant $XNOCTAG 33)
701(defconstant $XOBJBadType 34)
702(defconstant $XFuncLexMacro 35)
703(defconstant $xumrpr 41)
704(defconstant $xnotsamevol 42)
705(defconstant $xbadfilenamechar 43)
706(defconstant $xillwild 44)
707(defconstant $xnotfaslortext 45)
708(defconstant $xrenamedir 46)
709(defconstant $xdirnotfile 47)
710(defconstant $xnocopydir 48)
711(defconstant $XBADTOK 49)
712(defconstant $err-long-pstr 49)
713(defconstant $xnocreate 50)
714(defconstant $XFLOVFL 64)
715(defconstant $XDIVZRO 66)
716(defconstant $XFLDZRO 66)
717(defconstant $XSTKOVER 75)
718(defconstant $XMEMFULL 76)
719(defconstant $xarrlimit 77)
720(defconstant $err-printer 94)
721(defconstant $err-printer-load 95)
722(defconstant $err-printer-params 96)
723(defconstant $err-printer-start 97)
724(defconstant $XFLEXC 98)
725(defconstant $xfileof 111)
726(defconstant $XARROOB 112)
727(defconstant $err-arroob 112)
728(defconstant $xunread 113)
729(defconstant $xbadmac 114)
730(defconstant $XCONST 115)
731(defconstant $xillchr 116)
732(defconstant $xbadsym 117)
733(defconstant $xdoterr 118)
734(defconstant $xbadrdx 119)
735(defconstant $XNOSPREAD 120)
736(defconstant $XFASLVERS 121)
737(defconstant $XNOTFASL 122)
738(defconstant $xudfcall 123)
739
740(defconstant $xusecX 127)
741(defconstant $ximprtcx 128)
742(defconstant $xbadnum 129)       ;Bad arg to #b/#o/#x/#r...
743(defconstant $XNOPKG 130)
744(defconstant $xnoesym 131)
745(defconstant $XBADFASL 132)
746(defconstant $ximprtc 133)
747(defconstant $xunintc 134)
748(defconstant $XSYMACC 135)
749(defconstant $XEXPRTC 136)
750(defconstant $xusec 137)
751(defconstant $xduppkg 138)
752(defconstant $xrmactx 139)
753(defconstant $xnordisp 140)
754(defconstant $xrdnoarg 141)
755(defconstant $xrdndarg 142)
756(defconstant $xmacrdx 143)
757(defconstant $xduprdlbl 144)
758(defconstant $xnordlbl 145)
759(defconstant $xrdfont 146)
760(defconstant $xrdname 147)
761(defconstant $XNDIMS 148)
762(defconstant $err-disp-size 149)
763(defconstant $XNARGS 150)
764(defconstant $xdifdim 151)
765(defconstant $xkeyconflict 152)
766(defconstant $XBADKEYS 153)
767(defconstant $xtoofew 154)
768(defconstant $xtoomany 155)
769(defconstant $XWRONGTYPE 157)
770(defconstant $XBADSTRUCT 158)
771(defconstant $XSTRUCTBOUNDS 159)
772(defconstant $XCALLNOTLAMBDA 160)
773(defconstant $XTEMPFLT 161)
774(defconstant $xrdfeature 163)
775(defconstant $err-no-file 164)
776(defconstant $err-bad-named-arg 165)
777(defconstant $err-bad-named-arg-2 166)
778(defconstant $XCALLTOOMANY 167)
779(defconstant $XCALLTOOFEW 168)
780(defconstant $XCALLNOMATCH 169)
781(defconstant $XIMPROPERLIST 170)
782(defconstant $XNOFILLPTR 171)
783(defconstant $XMALADJUST 172)
784(defconstant $XACCESSNTH 173)
785(defconstant $XNOTELT 174)
786(defconstant $XSGEXHAUSTED 175)
787(defconstant $XSGNARGS 176)
788(defconstant $XTOOMANYVALUES 177)
789(defconstant $XFOREIGNEXCEPTION 200)
790
791(defconstant $cons-area.gspace-start 0)
792(defconstant $cons-area.gspace-end 4)
793(defconstant $cons-area.ispace-start 8)
794(defconstant $cons-area.ispace-end 12)
795(defconstant $cons-area.pgc-count 16)
796(defconstant $cons-area.pgc-time 20)
797(defconstant $cons-area.total 24)
798
799
800;; Values returned by %number-check.
801
802(defconstant $Num1Dfloat 0)
803(defconstant $Num1Int 2)
804(defconstant $Num1Sfloat 4)
805(defconstant $Num1Ratio 6)
806(defconstant $Num1CR 8)
807(defconstant $Num1CF 10)
808(defconstant $Num1CS 12)
809
810(defconstant %numeric-type-names-alist% 
811  `((double-float . ,$Num1Dfloat)
812    (integer . ,$Num1Int)
813    (short-float . ,$Num1Sfloat)
814    (ratio . ,$Num1Ratio)
815    ((complex rational) . ,$Num1CR)
816    ((complex double-float) . ,$Num1CF)
817    ((complex short-float) . ,$Num1CS)))
818 
819(defmacro numeric-dispatch (numform &body cases)
820  (flet ((numtype (name)
821           (if (memq name '(t otherwise))
822             name
823             (dolist (pair %numeric-type-names-alist% (error "Unknown numeric type name ~s" name))
824               (when (subtypep name (car pair)) (return (cdr pair)))))))
825    (flet ((numify (case)
826             (destructuring-bind (types &body body) case
827               (if (atom types)
828                 `(,(numtype types) ,@body)
829                 `(,(mapcar #'numtype types) ,@body)))))
830      `(case (%number-check ,numform)
831         ,@(mapcar #'numify cases)))))
832
833(def-accessors (random-state) %svref
834  ()
835  random.seed-1
836  random.seed-2)
837
838;;; IEEE-floating-point constants.
839
840(defconstant IEEE-single-float-bias 126)
841(defconstant IEEE-single-float-exponent-offset 23)
842(defconstant IEEE-single-float-exponent-width 8)
843(defconstant IEEE-single-float-mantissa-offset 0)
844(defconstant IEEE-single-float-mantissa-width 23)
845(defconstant IEEE-single-float-hidden-bit 23)
846(defconstant IEEE-single-float-signalling-NAN-bit 22)
847(defconstant IEEE-single-float-normal-exponent-min 1)
848(defconstant IEEE-single-float-normal-exponent-max 254)
849(defconstant IEEE-single-float-digits (1+ IEEE-single-float-mantissa-width))
850
851;;; Double-floats are IEEE DOUBLE-FLOATs in both MCL implementations.
852
853(defconstant IEEE-double-float-bias 1022)
854(defconstant IEEE-double-float-exponent-offset 52)
855(defconstant IEEE-double-float-exponent-width 11)
856(defconstant IEEE-double-float-mantissa-offset 0)
857(defconstant IEEE-double-float-mantissa-width 52)
858(defconstant IEEE-double-float-hidden-bit 52)
859(defconstant IEEE-double-float-signalling-NAN-bit 51)
860(defconstant IEEE-double-float-normal-exponent-min 1)
861(defconstant IEEE-double-float-normal-exponent-max 2046)
862(defconstant IEEE-double-float-digits (1+ IEEE-double-float-mantissa-width))
863
864
865
866
867(def-accessors (ptaskstate) %svref
868  nil                                   ;ptaskstate
869  ptaskstate.nexttick
870  ptaskstate.interval
871  ptaskstate.privatedata
872  ptaskstate.flags)
873
874
875
876
877 
878
879;;;;;; clos instance and class layout.
880
881;;; All standard-instances (classes, instances other than funcallable
882;;; instances) consist of a vector of slot values and a pointer to the
883;;; class wrapper.
884(def-accessors (instance) %svref
885  instance.hash                         ; a fixnum for EQ-based hashing
886  instance.class-wrapper
887  instance.slots                        ; a slot-vector
888)
889;;; Doing this via %SLOT-REF traps if the slot is unbound
890(defmacro standard-instance-instance-location-access (instance location)
891  `(%slot-ref (instance-slots ,instance) ,location))
892
893;;; Get the "raw" contents of the slot, even if it's %SLOT-UNBOUND-MARKER.
894(defmacro %standard-instance-instance-location-access (instance location)
895  `(%svref (instance-slots ,instance) ,location))
896
897(defmacro set-standard-instance-instance-location-access (instance location new)
898  `(setf (%svref (instance-slots ,instance) ,location) ,new))
899
900(defsetf standard-instance-instance-location-access
901    set-standard-instance-instance-location-access)
902
903(defmacro standard-generic-function-instance-location-access (sgf location)
904  `(%slot-ref (gf.slots ,sgf) ,location))
905
906(defmacro %standard-generic-function-instance-location-access (sgf location)
907  `(%svref (gf.slots ,sgf) ,location))
908
909(defmacro set-standard-generic-function-instance-location-access (sgf location new)
910  `(setf (%svref (gf.slots ,sgf) ,location) ,new))
911
912(defsetf standard-generic-function-instance-location-access
913    set-standard-generic-function-instance-location-access)
914
915;;; Slot vectors contain the instance they "belong" to (or NIL) in
916;;; their 0th element, and the instance's slots in elements 1 .. n.
917
918(def-accessors (slot-vector) %svref
919  slot-vector.instance
920  )
921
922(def-accessors (class-wrapper) %svref
923  nil                                   ; 'class-wrapper
924  %wrapper-hash-index                   ; for generic-function dispatch tables
925  %wrapper-class                        ; the class itself
926  %wrapper-instance-slots               ; vector of instance slot names
927  %wrapper-class-slots                  ; alist of (name . value-cell) pairs
928  %wrapper-slot-id->slotd               ; map slot-id to slotd, or NIL
929  %wrapper-slot-id-map                  ; (vector (mod nslots) next-slot-id-index)
930  %wrapper-slot-definition-table        ; vector of nil || slot-definitions
931  %wrapper-slot-id-value                ; "fast" SLOT-VALUE function
932  %wrapper-set-slot-id-value            ; "fast" (SETF SLOT-VALUE) function
933  %wrapper-cpl                          ; cached cpl of %wrapper-class or NIL
934)
935
936;; Use the wrapper-class-slots for info on obsolete & forwarded instances
937;; Note: none of this xx-forwarding-xx or xx-forwarded-xx is valid unless
938;; (%wrapper-instance-slots ...) is 0.
939(defmacro %wrapper-forwarding-info (instance)
940  `(%wrapper-class-slots ,instance))
941
942(defmacro %forwarding-instance-slots (info)
943  `(%car ,info))
944(defmacro %forwarding-class-slots (info)
945  `(%cdr ,info))
946
947
948(defmacro %wrapper-forwarded-instance-slots (instance)
949  `(%forwarding-instance-slots (%wrapper-forwarding-info ,instance)))
950(defmacro %wrapper-forwarded-class-slots (instance)
951  `(%forwarding-class-slots (%wrapper-forwarding-info ,instance)))
952
953
954(defmacro %cons-forwarding-info (instance-slots class-slots)
955  `(cons ,instance-slots ,class-slots))
956
957
958(defmacro %cons-wrapper (class &optional 
959                               (hash-index '(new-class-wrapper-hash-index)))
960  `(%istruct 'class-wrapper ,hash-index ,class nil nil #'slot-id-lookup-no-slots nil nil #'%slot-id-ref-missing #'%slot-id-set-missing nil))
961
962
963(defmacro %instance-class (instance)
964  `(%wrapper-class (instance.class-wrapper ,instance)))
965
966(def-accessors standard-instance-instance-location-access ;A specializer
967    nil                                 ; backptr
968  specializer.direct-methods
969)
970
971(def-accessors (class) standard-instance-instance-location-access ;Slots of any class
972  nil                                   ; backptr
973  %class.direct-methods                 ; aka specializer.direct-methods
974  %class.prototype                      ; prototype instance
975  %class.name
976  %class.cpl                            ; class-precedence-list
977  %class.own-wrapper                    ; own wrapper (or nil)
978  %class.local-supers                   ; class-direct-superclasses
979  %class.subclasses                     ; class-direct-subclasses
980  %class.dependents                     ; arbitrary dependents
981  %class.ctype
982)
983
984
985(def-accessors () standard-instance-instance-location-access ; any standard class
986  nil                                   ; slot-vector backptr
987  nil                                   ; usual class stuff: direct-methods,
988  nil                                   ;   prototype,
989  nil                                   ;   name,
990  nil                                   ;   cpl,
991  nil                                   ;   own-wrapper,
992  nil                                   ;   local-supers,
993  nil                                   ;   subclasses,
994  nil                                   ;   dependents,
995  nil                                   ;   ctype.
996  %class.direct-slots                   ; local slots
997  %class.slots                          ; all slots
998  %class.kernel-p                       ; true if a non-redefinable class
999  %class.local-default-initargs         ; local default initargs alist
1000  %class.default-initargs               ; all default initargs if initialized.
1001  %class.alist                          ; other stuff about the class.
1002  %class.make-instance-initargs         ; (vector of) valid initargs to make-instance
1003  %class.reinit-initargs                ; valid initargs to reinitialize-instance
1004  %class.redefined-initargs             ; valid initargs to update-instance-for-redefined-class
1005  %class.changed-initargs               ; valid initargs to update-instance-for-changed-class
1006  )
1007
1008
1009
1010
1011
1012(defmacro %instance-vector (wrapper &rest slots)
1013  (let ((instance (gensym))
1014        (slots-vector (gensym)))
1015    `(let* ((,instance (gvector :instance 0 ,wrapper nil))
1016            (,slots-vector (gvector :slot-vector ,instance ,@slots)))
1017       (setf (instance.slots ,instance) ,slots-vector
1018             (instance.hash ,instance) (strip-tag-to-fixnum ,instance))
1019       ,instance)))
1020 
1021(defmacro %cons-built-in-class (name)
1022  `(%instance-vector *built-in-class-wrapper* nil nil ,name nil nil nil nil nil nil))
1023
1024
1025(defmacro %cons-standard-class (name &optional
1026                                     (metaclass-wrapper '*standard-class-wrapper*))
1027  `(%instance-vector  ,metaclass-wrapper
1028                      nil nil ,name nil nil nil nil nil nil nil nil
1029                      nil nil nil nil nil nil nil nil)
1030
1031)
1032
1033(def-accessors () standard-instance-instance-location-access
1034  nil                                   ; backptr
1035  standard-slot-definition.name
1036  standard-slot-definition.type
1037  standard-slot-definition.initfunction
1038  standard-slot-definition.initform
1039  standard-slot-definition.initargs
1040  standard-slot-definition.allocation
1041  standard-slot-definition.documentation
1042  standard-slot-definition.class
1043  )
1044
1045(def-accessors () standard-instance-instance-location-access
1046  nil
1047  standard-effective-slot-definition.name
1048  standard-effective-slot-definition.type
1049  standard-effective-slot-definition.initfunction
1050  standard-effective-slot-definition.initform
1051  standard-effective-slot-definition.initargs
1052  standard-effective-slot-definition.allocation
1053  standard-effective-slot-definition.documentation
1054  standard-effective-slot-definition.class
1055  standard-effective-slot-definition.location
1056  standard-effective-slot-definition.slot-id
1057  standard-effective-slot-definition.type-predicate
1058  )
1059
1060
1061(def-accessors () standard-instance-instance-location-access
1062  nil
1063  standard-direct-slot-definition.name
1064  standard-direct-slot-definition.type
1065  standard-direct-slot-definition.initfunction
1066  standard-direct-slot-definition.initform
1067  standard-direct-slot-definition.initargs
1068  standard-direct-slot-definition.allocation
1069  standard-direct-slot-definition.documentation
1070  standard-direct-slot-definition.class
1071  standard-direct-slot-definition.readers
1072  standard-direct-slot-definition.writers 
1073  )
1074
1075;; Methods
1076(defmacro %cons-method (name qualifiers specializers function &optional 
1077                             (class '*standard-method-class*))
1078  `(%instance-vector 
1079    (%class.own-wrapper ,class)
1080    ,qualifiers
1081    ,specializers
1082    ,function
1083    nil
1084    ,name))
1085
1086
1087(def-accessors standard-instance-instance-location-access ; method
1088  nil                                   ; backptr
1089  %method.qualifiers
1090  %method.specializers
1091  %method.function
1092  %method.gf
1093  %method.name
1094  %method.lambda-list)
1095
1096;;; Painful, but seems to be necessary.
1097(def-accessors standard-instance-instance-location-access ; standard-accessor-method
1098  nil                                   ; backptr
1099  nil                                   ;%method.qualifiers
1100  nil                                   ;%method.specializers
1101  nil                                   ;%method.function
1102  nil                                   ;%method.gf
1103  nil                                   ;%method.name
1104  nil                                   ;%method.lambda-list
1105  %accessor-method.slot-definition)
1106
1107
1108
1109
1110
1111;; Generic Function Dispatch tables.
1112;; These accessors are at the beginning of the table.
1113;; rest of the table is alternating wrappers & combined-methods.
1114
1115(def-accessors %svref
1116    %gf-dispatch-table-methods          ; List of methods
1117    %gf-dispatch-table-precedence-list  ; List of argument numbers in precedence order
1118    %gf-dispatch-table-keyvect          ; keyword vector, set by E-G-F.
1119    %gf-dispatch-table-argnum           ; argument number
1120    %gf-dispatch-table-gf               ; back pointer to gf - NEW
1121    %gf-dispatch-table-mask             ; mask for rest of table
1122    %gf-dispatch-table-first-data)      ; offset to first data.  Must follow mask.
1123 
1124(defmacro %gf-dispatch-table-size (dt)
1125  `(%i- (uvsize ,dt) ,(+ 2 %gf-dispatch-table-first-data)))
1126
1127(defmacro %gf-dispatch-table-ref (table index)
1128  `(%svref ,table (%i+ ,index %gf-dispatch-table-first-data)))
1129
1130(defmacro %cons-gf-dispatch-table (size)
1131  `(make-array (%i+ ,size ,(%i+ 2 %gf-dispatch-table-first-data))
1132               :initial-element nil))
1133
1134
1135;;; method-combination info
1136(def-accessors svref
1137  mci.class                             ; short-method-combination or long-method-combination
1138  mci.options                           ; short-form-options or long-form function
1139  mci.instances                         ; a population of instances
1140  mci.gfs                               ; a population of generic-functions
1141  )
1142
1143(defmacro %cons-mci (&optional class options)
1144  `(vector ,class ,options (%cons-population nil) (%cons-population nil)))
1145
1146;;; slot accessor info for primary classes
1147(def-accessors %svref
1148  %slot-accessor-info.class
1149  (%slot-accessor-info.accessor %slot-accessor-info.slot-name)
1150  %slot-accessor-info.offset
1151  )
1152
1153(defmacro %cons-slot-accessor-info (class accessor-or-slot-name &optional offset)
1154  `(vector ,class ,accessor-or-slot-name ,offset))
1155
1156(def-accessors (combined-method) nth-immediate
1157  combined-method.code-vector           ; trampoline code vector
1158  combined-method.thing                 ; arbitrary arg to dcode
1159  combined-method.dcode                 ; discriminator function
1160  combined-method.gf                    ; gf
1161  combined-method.bits                  ; lfun-bits
1162  )
1163;;; The structure of a generic-function object (funcallable instance).
1164(def-accessors (generic-function) nth-immediate
1165  gf.code-vector                        ; trampoline code-vector
1166  gf.instance.class-wrapper             ; instance class-wrapper
1167  gf.slots                              ; slots vector
1168  gf.dispatch-table                     ; effective-method cache
1169  gf.dcode                              ; discriminating code
1170  gf.hash                               ; hashing identity
1171  gf.bits                               ;
1172  )
1173
1174;;; The slots of STANDARD-GENERIC-FUNCTION.
1175(def-accessors (standard-generic-function) standard-generic-function-instance-location-access
1176  nil                                   ; backptr
1177  sgf.name                              ; generic-function-name
1178  sgf.method-combination                ; generic-function-method-combination
1179  sgf.method-class                      ; generic-function-method-class
1180  sgf.methods                           ; generic-function-methods
1181  sgf.decls                             ; generic-function-declarations
1182  sgf.%lambda-list                      ; explicit lambda-list
1183  sgf.dependents                        ; dependents for MAP-DEPENDENTS et al.
1184  )
1185
1186(def-accessors (slot-id) %svref
1187  nil                                   ;'slot-id
1188  slot-id.name                          ; slot name (symbol)
1189  slot-id.index                         ; index (integer)
1190  )
1191
1192(def-accessors (foreign-object-domain) %svref
1193  nil                                   ; foreign-object-domain
1194  foreign-object-domain-index           ; 1..n
1195  foreign-object-domain-name            ;
1196  foreign-object-domain-recognize       ; function: is object one of ours ?
1197  foreign-object-domain-class-of        ; function: returns class of object
1198  foreign-object-domain-classp          ; function: true if object is a class
1199  foreign-object-domain-instance-class-wrapper ; function: returns wrapper of object's class
1200  foreign-object-domain-class-own-wrapper ; function: returns class own wrapper if class
1201  foreign-object-domain-slots-vector    ; returns slots vector of object or nil
1202  )
1203
1204;;; Hash table accessors.
1205(def-accessors (hash-table) %svref
1206    nil                                 ; 'HASH-TABLE
1207    nhash.rehashF                       ; function: rehashes if necessary
1208    nhash.keytransF                     ; transform key into (values primary addressp)
1209    nhash.compareF                      ; comparison function: 0 -> eq, -1 ->eql, else function
1210    nhash.rehash-bits                   ; bitset (array (unsigned-byte 32)) for rehash
1211    nhash.vector                        ; N <key,value> pairs; n relatively prime to & larger than all secondary keys
1212    nhash.lock                          ; fixnum: bits for grow and rehash
1213    nhash.count                         ; Number of entries
1214    nhash.owner                         ; tcr of "owning" thread, else NIL.
1215    nhash.fixnum                        ; fwdnum kernel-global
1216    nhash.gc-count                      ; gc-count kernel-global
1217    nhash.grow-threshold                ; Max # entries before grow
1218    nhash.rehash-ratio                  ; inverted rehash-threshold
1219    nhash.rehash-size                   ; rehash-size from user
1220    nhash.puthash-count                 ; number of times table has been rehashed or grown
1221    nhash.exclusion-lock                ; read-write lock for access
1222    nhash.rehash-lock                   ; exclusive lock for rehash
1223    nhash.iterator                      ; current hash-table iterator
1224    nhash.address-based                 ; hashes based on address
1225    nhash.find                          ; function: find vector-index
1226    nhash.find-new                      ; function: find vector-index on put
1227    nhash.read-only                     ; boolean: true when read-only
1228    )
1229
1230(def-accessors (lock-acquisition) %svref
1231  nil                                   ; 'lock-acquisition
1232  lock-acquisition.status
1233  )
1234
1235(defmacro make-lock-acquisition ()
1236  `(%istruct 'lock-acquisition nil))
1237
1238(def-accessors (semaphore-notification) %svref
1239  nil                                   ; 'semaphore-notification
1240  semaphore-notification.status
1241  )
1242
1243(defmacro make-semaphore-notification ()
1244  `(%istruct 'semaphore-notification nil))
1245
1246;;; Why were these ever in architecture-dependent packages ?
1247(defenum (:prefix "AREA-")
1248  void                                  ; list header
1249  cstack                                ; a control stack
1250  vstack                                ; a value stack
1251  tstack                                ; (dynamic-extent) temp stack
1252  readonly                              ; readonly section
1253  managed-static                        ; growable static area
1254  static                                ; static data in application
1255  dynamic                               ; dynmaic (heap) data in application
1256)
1257
1258;;; areas are sorted such that (in the "succ" direction) codes are >=.
1259;;; If you think that you're looking for a stack (instead of a heap), look
1260;;; in the "pred" direction from the all-areas header.
1261(defconstant max-stack-area-code area-tstack)
1262(defconstant min-heap-area-code area-readonly)
1263
1264
1265;;; Lisp threads, which barely need to exist and aren't worth burning
1266;;; a separate tag on ...
1267(def-accessors (lisp-thread) %svref
1268  nil                                   ;'lisp-thread
1269  lisp-thread.tcr
1270  lisp-thread.name
1271  lisp-thread.cs-size
1272  lisp-thread.vs-size
1273  lisp-thread.ts-size
1274  lisp-thread.initial-function.args
1275  lisp-thread.interrupt-functions
1276  lisp-thread.interrupt-lock
1277  lisp-thread.startup-function
1278  lisp-thread.state
1279  lisp-thread.state-change-lock
1280  )
1281
1282;;; "basic" (e.g., builtin, non-extensible) streams.
1283(def-accessors (basic-stream) %svref
1284  basic-stream.class                    ; a class object
1285  basic-stream.flags                    ; fixnum; bits.
1286  basic-stream.state                    ; typically an ioblock
1287  basic-stream.info                     ; a plist for less-often-used things.
1288)
1289
1290(def-accessors (basic-file-stream) %svref
1291  basic-file-stream.class               ; a class object
1292  basic-file-stream.flags               ; fixnum; bits.
1293  basic-file-stream.state               ; typically an ioblock
1294  basic-file-stream.info                ; a plist for less-often-used things.
1295  basic-file-stream.filename
1296  basic-file-stream.actual-filename
1297  basic-file-stream.external-format
1298  )
1299
1300;;; Bits in basic-stream.flags
1301(defenum (:prefix "BASIC-STREAM-FLAG.")
1302  open-input
1303  open-output
1304  open-character
1305  open-binary
1306  file-stream)
1307
1308
1309(def-accessors (class-cell) %svref
1310  nil                                   ; 'class-cell
1311  class-cell-name
1312  class-cell-class
1313  class-cell-instantiate
1314  class-cell-extra                      ; wrapper in some cases
1315  )
1316
1317(defmacro make-class-cell (name) `(%istruct 'class-cell ,name nil '%make-instance nil))
1318
1319
1320(provide "LISPEQU")
1321
1322;;; End of lispequ.lisp
Note: See TracBrowser for help on using the repository browser.