source: trunk/source/library/lispequ.lisp @ 9917

Last change on this file since 9917 was 9917, checked in by gz, 12 years ago

Move more definitions into lispequ. To bootstrap, (load "ccl:library;lispequ.lisp") before recompiling

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 55.4 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-info-bit 23)
142(defconstant $lfbits-symmap-bit 23) ;; bootstrapping
143(defconstant $lfbits-trampoline-bit 24)
144(defconstant $lfbits-code-coverage-bit 25)
145(defconstant $lfbits-cm-bit 26)         ; combined-method
146(defconstant $lfbits-nextmeth-bit 26)   ; or call-next-method with method-bit
147(defconstant $lfbits-gfn-bit 27)        ; generic-function
148(defconstant $lfbits-nextmeth-with-args-bit 27)   ; or call-next-method-with-args with method-bit
149(defconstant $lfbits-method-bit 28)     ; method function
150(defconstant $lfbits-noname-bit 29)
151
152
153(defconstant $lfbits-args-mask
154  (%ilogior (dpb -1 $lfbits-numreq 0)
155            (dpb -1 $lfbits-numopt 0)
156            (%ilsl $lfbits-rest-bit 1)
157            (%ilsl $lfbits-keys-bit 1)
158            (%ilsl $lfbits-aok-bit 1)))
159
160;Bits in $arh_bits.
161(defconstant $arh_adjp_bit 7)           ;adjustable-p
162(defconstant $arh_fill_bit 6)           ;fill-pointer-p
163(defconstant $arh_disp_bit 5)           ;displaced to another array header -p
164(defconstant $arh_simple_bit 4)         ;not adjustable, no fill-pointer and
165                                        ; not user-visibly displaced -p
166(defconstant $arh_exp_disp_bit 3)       ;explicitly-displaced -p
167
168(def-accessors (lexical-environment) %svref
169  ()                                    ; 'lexical-environment
170  lexenv.parent-env
171  lexenv.functions
172  lexenv.variables
173  lexenv.fdecls                         ; function-binding decls, e.g., [NOT]INLINE, FTYPE
174  lexenv.vdecls                         ; variable-binding decls, e.g., SPECIAL, TYPE
175  lexenv.mdecls                         ; misc decls, e.g., OPTIMIZE
176  lexenv.lambda                         ; unique id (e.g., afunc) of containing lambda expression.
177  )
178
179(def-accessors (definition-environment) %svref
180  ()                                    ; 'definition-environment
181  defenv.type                           ; must be LIST, match lexenv.parent-env
182  defenv.functions                      ; compile-time macros, same structure as lexenv.functions
183  defenv.constants                      ; definition-time constants, shadows lexenv.variables
184  defenv.fdecls                         ; shadows lexenv.fdecls
185  defenv.vdecls                         ; shadows lexenv.vdecls
186  defenv.mdecls                         ; shadows lexenv.mdecls
187;;; extended info
188  defenv.types                          ; compile-time deftype info, shadows lexenv.function
189  defenv.defined                        ; functions defined in compilation unit.
190  defenv.specials
191  defenv.classes                        ; classed defined in compilation unit
192  defenv.structrefs                     ; compile-time DEFSTRUCT accessor info
193  defenv.structures                     ; compile-time DEFSTRUCT info
194  defenv.symbol-macros                  ; compile-time SYMBOL-MACROS.
195)
196
197(def-accessors (var) %svref
198  nil                                   ; 'var
199  var-name                              ; symbol
200  (var-bits var-parent)                 ; fixnum or ptr to parent
201  (var-ea  var-expansion)               ; p2 address (or symbol-macro expansion)
202  var-decls                             ; list of applicable decls
203  var-inittype
204  var-binding-info
205  var-refs
206)
207
208(def-accessors (package) %svref
209  pkg.itab
210  pkg.etab
211  pkg.used
212  pkg.used-by
213  pkg.names
214  pkg.shadowed
215  pkg.lock
216  pkg.intern-hook
217  )
218
219(defmacro package-deleted-marker ()
220  (%unbound-marker))
221
222
223
224
225(defmacro %cons-fake-stack-frame (&optional sp next-sp fn lr vsp xp link)
226  `(%istruct 'fake-stack-frame ,sp ,next-sp ,fn ,lr ,vsp ,xp ,link))
227
228(def-accessors () svref
229  bt.dialog
230  bt.youngest
231  bt.oldest
232  bt.tcr
233  bt.restarts
234  bt.top-catch
235  bt.break-condition
236  bt.current
237  bt.fake-frames
238  bt.db-link
239  bt.break-level)
240
241(defconstant bt.sg bt.tcr)
242(setf (macro-function 'bt.sg) (macro-function 'bt.tcr))
243
244
245(def-accessors (lock) %svref
246  lock.value
247  lock.name)
248
249
250
251
252
253
254 
255;contents of pkg.itab/pkg.etab.
256(defmacro pkgtab-table (htab) `(car (the list ,htab)))
257#|
258(defmacro pkgtab-hcount (htab) `(car (the list (cdr (the list ,htab)))))                                            (mkint acc)))
259(defmacro pkgtab-hlimit (htab) `(cdr (the list (cdr (the list ,htab)))))
260|#
261
262
263
264(def-accessors (pathname) %svref
265  ()                                    ; 'pathname
266  %pathname-directory
267  %pathname-name
268  %pathname-type
269  %physical-pathname-version)
270
271(def-accessors (logical-pathname) %svref
272  ()                                    ; 'logical-pathname
273  %pathname-directory
274  %pathname-name
275  %pathname-type 
276  %logical-pathname-host
277  %logical-pathname-version)
278
279(defmacro %cons-pathname (directory name type &optional version)
280  `(%istruct 'pathname ,directory ,name ,type ,version))
281
282(defmacro %cons-logical-pathname (directory name type host version)
283  `(%istruct 'logical-pathname ,directory ,name ,type ,host ,version))
284
285(def-accessors (restart) %svref
286  ()                                    ; 'restart
287  %restart-name
288  %restart-action
289  %restart-report
290  %restart-interactive
291  %restart-test)
292
293;;; %cons-restart now in level-2.lisp
294
295
296(def-accessors %svref
297  nil                                   ; 'periodic-task
298  ptask.state
299  ptask.name
300  ptask.function
301)
302
303;;;;;; CMU type system.
304
305
306
307(def-accessors (type-class) %svref
308  nil                                   ; 'type-class
309  type-class-name                       ; name
310
311  ;; Dyadic type methods.  If the classes of the two types are EQ, then we call
312  ;; the SIMPLE-xxx method.  If the classes are not EQ, and either type's class
313  ;; has a COMPLEX-xxx method, then we call it.
314  ;;
315  ;; Although it is undefined which method will get precedence when both types
316  ;; have a complex method, the complex method can assume that the second arg
317  ;; always is in its class, and the first always is not.  The arguments to
318  ;; commutative operations will be swapped if the first argument has a complex
319  ;; method.
320  ;;
321  ;; Since SUBTYPEP is not commutative, we have two complex methods.  the ARG1
322  ;; method is only called when the first argument is in its class, and the
323  ;; ARG2 method is only called when called when the second type is.  If either
324  ;; is specified, both must be.
325  type-class-simple-subtypep
326  type-class-complex-subtypep-arg1
327  type-class-complex-subtypep-arg2
328  ;;
329  ;; SIMPLE-UNION combines two types of the same class into a single type of
330  ;; that class.  If the result is a two-type union, then return NIL.
331  ;; VANILLA-UNION returns whichever argument is a supertype of the other, or
332  ;; NIL.
333  type-class-simple-union
334  type-class-complex-union
335  ;; The default intersection methods assume that if one type is a subtype of
336  ;; the other, then that type is the intersection.
337  type-class-simple-intersection
338  type-class-complex-intersection
339  ;;
340  type-class-simple-=
341  type-class-complex-=
342  type-class-unparse
343) 
344
345;; This istruct (and its subtypes) are used to define types.
346(def-accessors (ctype) %svref
347  nil                                   ; 'ctype or a subtype
348  ctype-class-info                       ; a type-class
349  ;; True if this type has a fixed number of members, and as such could
350  ;; possibly be completely specified in a MEMBER type.  This is used by the
351  ;; MEMBER type methods.
352  ctype-enumerable
353)
354
355;; args-ctype is a subtype of ctype
356(def-accessors (args-ctype) %svref
357  nil                                   ; 'args-ctype
358  nil                                   ; ctype-class-info             
359  nil                                   ; ctype-enumerable
360  ;; Lists of the type for each required and optional argument.
361  args-ctype-required
362  args-ctype-optional
363  ;;
364  ;; The type for the rest arg.  NIL if there is no rest arg.
365  args-ctype-rest
366  ;; True if keyword arguments are specified.
367  args-ctype-keyp
368  ;; List of key-info structures describing the keyword arguments.
369  args-ctype-keywords
370  ;; True if other keywords are allowed.
371  args-ctype-allowp
372)
373
374(def-accessors (key-info) %svref
375  nil                                   ; 'key-info
376  key-info-name                         ; Name of &key arg
377  key-info-type                         ; type (ctype) of this &key arg
378)
379
380;;; VALUES-ctype is a subtype of ARGS-ctype.
381(def-accessors (values-ctype) %svref
382  nil                                   ; 'values-ctype
383  nil                                   ; ctype-class-info           
384  nil                                   ; ctype-enumerable
385  ;; Lists of the type for each required and optional argument.
386  values-ctype-required
387  values-ctype-optional
388  ;;
389  ;; The type for the rest arg.  NIL if there is no rest arg.
390  values-ctype-rest
391  ;; True if keyword arguments are specified.
392  values-ctype-keyp
393  ;; List of key-info structures describing the keyword arguments.
394  values-ctype-keywords
395  ;; True if other keywords are allowed.
396  values-ctype-allowp
397)
398
399;;; FUNCTION-ctype is a subtype of ARGS-ctype.
400(def-accessors (args-ctype) %svref
401  nil                                   ; 'function-ctype
402  nil                                   ; ctype-class-info           
403  nil                                   ; ctype-enumerable
404  function-ctype-required               ; args-ctype-required
405  function-ctype-optional               ; args-ctype-optional
406  function-ctype-rest                   ; args-ctype-rest
407  function-ctype-keyp                   ; args-ctype-keyp
408  function-ctype-keywords               ; args-ctype-keywords
409  function-ctype-allowp                 ; args-ctype-allowp
410;; True if the arguments are unrestrictive, i.e. *.
411  function-ctype-wild-args
412  ;;
413  ;; Type describing the return values.  This is a values type
414  ;; when multiple values were specified for the return.
415  function-ctype-returns
416)
417
418;;; The CONSTANT-ctype structure represents a use of the CONSTANT-ARGUMENT "type
419;;; specifier", which is only meaningful in function argument type specifiers
420;;; used within the compiler.
421;;;
422
423
424(def-accessors (constant-ctype) %svref
425  nil                                   ; 'constant-ctype
426  nil                                   ; ctype-class-info           
427  nil                                   ; ctype-enumerable
428  ;; The type which the argument must be a constant instance of for this type
429  ;; specifier to win.
430  constant-ctype-type
431)
432
433;;; The NAMED-ctype is used to represent *, T and NIL.  These types must be
434;;; super or sub types of all types, not just classes and * & NIL aren't
435;;; classes anyway, so it wouldn't make much sense to make them built-in
436;;; classes.
437;;;
438
439(def-accessors (named-ctype) %svref
440  nil                                   ; 'named-ctype
441  nil                                   ; ctype-class-info           
442  nil                                   ; ctype-enumerable
443  named-ctype-name
444)
445
446;;; The Hairy-ctype represents anything too wierd to be described
447;;; reasonably or to be useful, such as SATISFIES.  We just remember
448;;; the original type spec.
449;;;
450
451(def-accessors (hairy-ctype) %svref
452  nil                                   ; 'hairy-ctype
453  nil                                   ; ctype-class-info           
454  nil                                   ; ctype-enumerable
455  ;; The type which the argument must be a constant instance of for this type
456  ;; specifier to win.
457  hairy-ctype-specifier
458)
459
460;;; An UNKNOWN-ctype is a type not known to the type system (not yet defined).
461;;; We make this distinction since we don't want to complain about types that
462;;; are hairy but defined.
463;;;
464
465;;; This means that UNKNOWN-ctype is a HAIRY-ctype.
466(def-accessors (unknown-ctype) %svref
467  nil                                   ; 'unknown-ctype
468  nil                                   ; ctype-class-info           
469  nil                                   ; ctype-enumerable
470  unknown-ctype-specifier
471)
472
473;;; CONS-ctype is a subclass of CTYPE
474(def-accessors (cons-ctype) %svref
475  nil                                   ; 'cons-ctype
476  nil                                   ; ctype-class-info
477  nil                                   ; ctype-enumerable
478  cons-ctype-car-ctype                  ; ctype of the car
479  cons-ctype-cdr-ctype                  ; ctype of the cdr
480  )
481
482;;; NUMERIC-ctype is a subclass of CTYPE
483(def-accessors (numeric-ctype) %svref
484  nil                                   ; numeric-ctype
485  nil                                   ; ctype-class-info           
486  nil                                   ; ctype-enumerable
487  ;;
488  ;; The kind of numeric type we have.  NIL if not specified (just NUMBER or
489  ;; COMPLEX).
490  numeric-ctype-class
491  ;; Format for a float type.  NIL if not specified or not a float.  Formats
492  ;; which don't exist in a given implementation don't appear here.
493  numeric-ctype-format
494  ;; Is this a complex numeric type?  Null if unknown (only in NUMBER.)
495  numeric-ctype-complexp
496  ;; The upper and lower bounds on the value.  If null, there is no bound.  If
497  ;; a list of a number, the bound is exclusive.  Integer types never have
498  ;; exclusive bounds.
499  numeric-ctype-low
500  numeric-ctype-high
501  numeric-ctype-predicate
502)
503
504;;; ARRAY-ctype is a subclass of CTYPE.
505(def-accessors (array-ctype) %svref
506  nil                                   ; 'array-ctype
507  nil                                   ; ctype-class-info           
508  nil                                   ; ctype-enumerable
509  ;;
510  ;; The dimensions of the array.  * if unspecified.  If a dimension is
511  ;; unspecified, it is *.
512  array-ctype-dimensions
513  ;;
514  ;; Is this not a simple array type?
515  array-ctype-complexp
516  ;;
517  ;; The element type as originally specified.
518  array-ctype-element-type
519  ;;
520  ;; The element type as it is specialized in this implementation.
521  array-ctype-specialized-element-type
522  ;; The typecode of the specialize element type, or NIL.
523  array-ctype-typecode
524)
525
526;;; MEMBER-ctype is a direct subclass of CTYPE.
527(def-accessors (member-ctype) %svref
528  nil                                   ; 'member-ctype
529  nil                                   ; ctype-class-info           
530  nil                                   ; ctype-enumerable
531  ;;
532  ;; The things in the set, with no duplications.
533  member-ctype-members
534)
535
536;;; UNION-ctype is a direct subclass of CTYPE.
537(def-accessors (union-ctype) %svref
538  nil                                   ; 'union-ctype
539  nil                                   ; ctype-class-info           
540  nil                                   ; ctype-enumerable
541  ;;
542  ;; The types in the union.
543  union-ctype-types
544)
545
546;;; INTERSECTION-ctype is a direct subclass of CTYPE.
547(def-accessors (intersection-ctype) %svref
548  nil                                   ; 'intersection-ctype
549  nil                                   ; ctype-class-info           
550  nil                                   ; ctype-enumerable
551  ;;
552  ;; The types in the intersection
553  intersection-ctype-types
554)
555
556(def-accessors (negation-ctype) %svref
557  nil                                   ; 'negation-ctype
558  nil                                   ; ctype-class-info           
559  nil                                   ; ctype-enumerable
560  ;; The type of what we're not:
561  negation-ctype-type
562  )
563 
564
565
566
567;;; It'd be nice to integrate "foreign" types into the type system
568(def-accessors (foreign-ctype) %svref
569  nil                                   ; 'foreign-ctype
570  nil                                   ; ctype-class-info           
571  nil                                   ; ctype-enumerable
572  foreign-ctype-foreign-type
573)
574 
575;;; Most "real" CLOS objects have one of these in their %class.ctype slot
576
577(def-accessors (class-ctype) %svref
578  nil                                   ; 'class-ctype
579  nil                                   ; ctype-class-info           
580  nil                                   ; ctype-enumerable
581  class-ctype-class                     ; backptr to class.
582  class-ctype-translation               ; ctype for some built-in-classes.
583)
584
585
586
587;;;;;;;
588;;
589;; state for with-package-iterator
590;;
591(def-accessors %svref
592  pkg-iter-step.pkg                     ; package
593  pkg-iter-step.type                    ; keyword
594  pkg-iter-step.table
595  pkg-iter-step.shadowed
596  pkg-iter-step.vector
597  pkg-iter-step.index)
598
599(def-accessors %svref
600  pkg-iter.step                         ; current step
601  pkg-iter.remaining-steps              ; steps to be processed
602)
603
604
605;;;;;;;;;;;;;
606
607(defconstant $catch.tag 0)
608(defconstant $catch.mvflag (+ $catch.tag 4))
609(defconstant $catch.dblink (+ $catch.mvflag 4))
610(defconstant $catch.vsp (+ $catch.dblink 4))
611(defconstant $catch.regs (+ $catch.vsp 4))
612(defconstant $catch.link (+ $catch.regs (* 4 5)))
613(defconstant $catch.scgvll (+ $catch.link 4))
614(defconstant $catch.cs_area (+ $catch.scgvll 4))
615(defconstant $catch.pc (+ $catch.cs_area 4))
616(defconstant $catchfsize (+ $catch.pc 4))
617
618
619;;; Bits in *gc-event-status-bits*
620(defconstant $gc-retain-pages-bit 0)
621(defconstant $gc-integrity-check-bit 2)
622(defconstant $gc-allow-stack-overflows-bit 5)
623(defconstant $egc-verbose-bit 3)
624(defconstant $gc-verbose-bit 4)
625(defconstant $gc-postgc-pending-bit 26)
626
627
628
629;;; Values for the flags arg to %install-periodic-task
630(defconstant $ptask_draw-flag 1)       ; set for tasks that do drawing
631(defconstant $ptask_event-dispatch-flag 2)      ; set for tasks that do event processing
632
633
634
635
636
637(defconstant struct.type 0)
638(defconstant istruct.type 0)
639
640(def-accessors (readtable) %svref
641  ()                                        ; 'readtable
642  rdtab.ttab                                ; type table
643  rdtab.alist                               ; macro-char alist
644  rdtab.case)                               ; gratuitous braindeath
645
646;character types in readtables
647(defconstant $cht_ill 0)                ;Illegal char
648(defconstant $cht_wsp 1)                ;Whitespace
649(defconstant $cht_sesc 4)               ;Single escape (\)
650(defconstant $cht_mesc 5)               ;Multiple escape (|)
651(defconstant $cht_cnst 6)               ;Atom constituent
652(defconstant $cht_tmac 8)               ;Terminating macro
653(defconstant $cht_ntmac 9)              ;Non-terminating macro
654
655(defconstant $cht_macbit 3)             ;This bit on in CHT_TMAC and CHT_NTMAC
656
657;;; quantifiers
658
659(defconstant $some 0)
660(defconstant $notany 1)
661(defconstant $every 2)
662(defconstant $notevery 3)
663
664;;; Error string constants.  As accurate as constants.i ...
665
666(defconstant $XVUNBND 1)
667;(defconstant $XNOCDR 2)
668(defconstant $xbadvec 6)
669(defconstant $XTMINPS 3)
670(defconstant $XNEINPS 4)
671(defconstant $XWRNGINP 5)
672(defconstant $err-bad-input 5)
673(defconstant $XFUNBND 6)
674;;(defconstant $err-fundefined 6)
675;;(defconstant $XNOCAR 7)
676(defconstant $xsetbadvec 7)
677(defconstant $xcoerce 8)
678(defconstant $xnofinfunction 9)
679(defconstant $xnomem 10)
680(defconstant $xnotranslation 12)
681(defconstant $XNOTFUN 13)
682(defconstant $XNOTsymlam 14)
683(defconstant $Xdeclpos 15)
684(defconstant $Xsetconstant 16)
685(defconstant $Xoddsetq 17)
686(defconstant $Xbadsetq 18)
687(defconstant $Xnotsym 19)
688(defconstant $Xisconstant 20)
689(defconstant $Xbadinit 21)
690(defconstant $Xsmacspec 22)
691(defconstant $X2manyargs 23)
692(defconstant $XNolexvar 24)
693(defconstant $XNolexfunc 25)
694(defconstant $XNolextag 26)
695(defconstant $XNolexblock 27)
696(defconstant $XNotag 28)
697(defconstant $Xduplicatetag 29)
698(defconstant $XNoblock 30)
699(defconstant $XBadLambdaList 31)
700(defconstant $XBadLambda 32)
701(defconstant $XNOCTAG 33)
702(defconstant $XOBJBadType 34)
703(defconstant $XFuncLexMacro 35)
704(defconstant $xumrpr 41)
705(defconstant $xnotsamevol 42)
706(defconstant $xbadfilenamechar 43)
707(defconstant $xillwild 44)
708(defconstant $xnotfaslortext 45)
709(defconstant $xrenamedir 46)
710(defconstant $xdirnotfile 47)
711(defconstant $xnocopydir 48)
712(defconstant $XBADTOK 49)
713(defconstant $err-long-pstr 49)
714(defconstant $xnocreate 50)
715(defconstant $XFLOVFL 64)
716(defconstant $XDIVZRO 66)
717(defconstant $XFLDZRO 66)
718(defconstant $XSTKOVER 75)
719(defconstant $XMEMFULL 76)
720(defconstant $xarrlimit 77)
721(defconstant $err-printer 94)
722(defconstant $err-printer-load 95)
723(defconstant $err-printer-params 96)
724(defconstant $err-printer-start 97)
725(defconstant $XFLEXC 98)
726(defconstant $xfileof 111)
727(defconstant $XARROOB 112)
728(defconstant $err-arroob 112)
729(defconstant $xunread 113)
730(defconstant $xbadmac 114)
731(defconstant $XCONST 115)
732(defconstant $xillchr 116)
733(defconstant $xbadsym 117)
734(defconstant $xdoterr 118)
735(defconstant $xbadrdx 119)
736(defconstant $XNOSPREAD 120)
737(defconstant $XFASLVERS 121)
738(defconstant $XNOTFASL 122)
739(defconstant $xudfcall 123)
740
741(defconstant $xusecX 127)
742(defconstant $ximprtcx 128)
743(defconstant $xbadnum 129)       ;Bad arg to #b/#o/#x/#r...
744(defconstant $XNOPKG 130)
745(defconstant $xnoesym 131)
746(defconstant $XBADFASL 132)
747(defconstant $ximprtc 133)
748(defconstant $xunintc 134)
749(defconstant $XSYMACC 135)
750(defconstant $XEXPRTC 136)
751(defconstant $xusec 137)
752(defconstant $xduppkg 138)
753(defconstant $xrmactx 139)
754(defconstant $xnordisp 140)
755(defconstant $xrdnoarg 141)
756(defconstant $xrdndarg 142)
757(defconstant $xmacrdx 143)
758(defconstant $xduprdlbl 144)
759(defconstant $xnordlbl 145)
760(defconstant $xrdfont 146)
761(defconstant $xrdname 147)
762(defconstant $XNDIMS 148)
763(defconstant $err-disp-size 149)
764(defconstant $XNARGS 150)
765(defconstant $xdifdim 151)
766(defconstant $xkeyconflict 152)
767(defconstant $XBADKEYS 153)
768(defconstant $xtoofew 154)
769(defconstant $xtoomany 155)
770(defconstant $XWRONGTYPE 157)
771(defconstant $XBADSTRUCT 158)
772(defconstant $XSTRUCTBOUNDS 159)
773(defconstant $XCALLNOTLAMBDA 160)
774(defconstant $XTEMPFLT 161)
775(defconstant $xrdfeature 163)
776(defconstant $err-no-file 164)
777(defconstant $err-bad-named-arg 165)
778(defconstant $err-bad-named-arg-2 166)
779(defconstant $XCALLTOOMANY 167)
780(defconstant $XCALLTOOFEW 168)
781(defconstant $XCALLNOMATCH 169)
782(defconstant $XIMPROPERLIST 170)
783(defconstant $XNOFILLPTR 171)
784(defconstant $XMALADJUST 172)
785(defconstant $XACCESSNTH 173)
786(defconstant $XNOTELT 174)
787(defconstant $XSGEXHAUSTED 175)
788(defconstant $XSGNARGS 176)
789(defconstant $XTOOMANYVALUES 177)
790(defconstant $XFOREIGNEXCEPTION 200)
791
792(defconstant $cons-area.gspace-start 0)
793(defconstant $cons-area.gspace-end 4)
794(defconstant $cons-area.ispace-start 8)
795(defconstant $cons-area.ispace-end 12)
796(defconstant $cons-area.pgc-count 16)
797(defconstant $cons-area.pgc-time 20)
798(defconstant $cons-area.total 24)
799
800
801;; Values returned by %number-check.
802
803(defconstant $Num1Dfloat 0)
804(defconstant $Num1Int 2)
805(defconstant $Num1Sfloat 4)
806(defconstant $Num1Ratio 6)
807(defconstant $Num1CR 8)
808(defconstant $Num1CF 10)
809(defconstant $Num1CS 12)
810
811(defconstant %numeric-type-names-alist% 
812  `((double-float . ,$Num1Dfloat)
813    (integer . ,$Num1Int)
814    (short-float . ,$Num1Sfloat)
815    (ratio . ,$Num1Ratio)
816    ((complex rational) . ,$Num1CR)
817    ((complex double-float) . ,$Num1CF)
818    ((complex short-float) . ,$Num1CS)))
819 
820(defmacro numeric-dispatch (numform &body cases)
821  (flet ((numtype (name)
822           (if (memq name '(t otherwise))
823             name
824             (dolist (pair %numeric-type-names-alist% (error "Unknown numeric type name ~s" name))
825               (when (subtypep name (car pair)) (return (cdr pair)))))))
826    (flet ((numify (case)
827             (destructuring-bind (types &body body) case
828               (if (atom types)
829                 `(,(numtype types) ,@body)
830                 `(,(mapcar #'numtype types) ,@body)))))
831      `(case (%number-check ,numform)
832         ,@(mapcar #'numify cases)))))
833
834(def-accessors (random-state) %svref
835  ()
836  random.seed-1
837  random.seed-2)
838
839;;; IEEE-floating-point constants.
840
841(defconstant IEEE-single-float-bias 126)
842(defconstant IEEE-single-float-exponent-offset 23)
843(defconstant IEEE-single-float-exponent-width 8)
844(defconstant IEEE-single-float-mantissa-offset 0)
845(defconstant IEEE-single-float-mantissa-width 23)
846(defconstant IEEE-single-float-hidden-bit 23)
847(defconstant IEEE-single-float-signalling-NAN-bit 22)
848(defconstant IEEE-single-float-normal-exponent-min 1)
849(defconstant IEEE-single-float-normal-exponent-max 254)
850(defconstant IEEE-single-float-digits (1+ IEEE-single-float-mantissa-width))
851
852;;; Double-floats are IEEE DOUBLE-FLOATs in both MCL implementations.
853
854(defconstant IEEE-double-float-bias 1022)
855(defconstant IEEE-double-float-exponent-offset 52)
856(defconstant IEEE-double-float-exponent-width 11)
857(defconstant IEEE-double-float-mantissa-offset 0)
858(defconstant IEEE-double-float-mantissa-width 52)
859(defconstant IEEE-double-float-hidden-bit 52)
860(defconstant IEEE-double-float-signalling-NAN-bit 51)
861(defconstant IEEE-double-float-normal-exponent-min 1)
862(defconstant IEEE-double-float-normal-exponent-max 2046)
863(defconstant IEEE-double-float-digits (1+ IEEE-double-float-mantissa-width))
864
865
866
867
868(def-accessors (ptaskstate) %svref
869  nil                                   ;ptaskstate
870  ptaskstate.nexttick
871  ptaskstate.interval
872  ptaskstate.privatedata
873  ptaskstate.flags)
874
875
876
877
878 
879
880;;;;;; clos instance and class layout.
881
882;;; All standard-instances (classes, instances other than funcallable
883;;; instances) consist of a vector of slot values and a pointer to the
884;;; class wrapper.
885(def-accessors (instance) %svref
886  instance.hash                         ; a fixnum for EQ-based hashing
887  instance.class-wrapper
888  instance.slots                        ; a slot-vector
889)
890;;; Doing this via %SLOT-REF traps if the slot is unbound
891(defmacro standard-instance-instance-location-access (instance location)
892  `(%slot-ref (instance-slots ,instance) ,location))
893
894;;; Get the "raw" contents of the slot, even if it's %SLOT-UNBOUND-MARKER.
895(defmacro %standard-instance-instance-location-access (instance location)
896  `(%svref (instance-slots ,instance) ,location))
897
898(defmacro set-standard-instance-instance-location-access (instance location new)
899  `(setf (%svref (instance-slots ,instance) ,location) ,new))
900
901(defsetf standard-instance-instance-location-access
902    set-standard-instance-instance-location-access)
903
904(defmacro standard-generic-function-instance-location-access (sgf location)
905  `(%slot-ref (gf.slots ,sgf) ,location))
906
907(defmacro %standard-generic-function-instance-location-access (sgf location)
908  `(%svref (gf.slots ,sgf) ,location))
909
910(defmacro set-standard-generic-function-instance-location-access (sgf location new)
911  `(setf (%svref (gf.slots ,sgf) ,location) ,new))
912
913(defsetf standard-generic-function-instance-location-access
914    set-standard-generic-function-instance-location-access)
915
916;;; Slot vectors contain the instance they "belong" to (or NIL) in
917;;; their 0th element, and the instance's slots in elements 1 .. n.
918
919(def-accessors (slot-vector) %svref
920  slot-vector.instance
921  )
922
923(def-accessors (class-wrapper) %svref
924  nil                                   ; 'class-wrapper
925  %wrapper-hash-index                   ; for generic-function dispatch tables
926  %wrapper-class                        ; the class itself
927  %wrapper-instance-slots               ; vector of instance slot names
928  %wrapper-class-slots                  ; alist of (name . value-cell) pairs
929  %wrapper-slot-id->slotd               ; map slot-id to slotd, or NIL
930  %wrapper-slot-id-map                  ; (vector (mod nslots) next-slot-id-index)
931  %wrapper-slot-definition-table        ; vector of nil || slot-definitions
932  %wrapper-slot-id-value                ; "fast" SLOT-VALUE function
933  %wrapper-set-slot-id-value            ; "fast" (SETF SLOT-VALUE) function
934  %wrapper-cpl                          ; cached cpl of %wrapper-class or NIL
935  %wrapper-class-ordinal                ; cached copy of class-ordinal
936  %wrapper-cpl-bits                     ; bitvector representation of cpl
937)
938
939;; Use the wrapper-class-slots for info on obsolete & forwarded instances
940;; Note: none of this xx-forwarding-xx or xx-forwarded-xx is valid unless
941;; (%wrapper-instance-slots ...) is 0.
942(defmacro %wrapper-forwarding-info (instance)
943  `(%wrapper-class-slots ,instance))
944
945(defmacro %forwarding-instance-slots (info)
946  `(%car ,info))
947(defmacro %forwarding-class-slots (info)
948  `(%cdr ,info))
949
950
951(defmacro %wrapper-forwarded-instance-slots (instance)
952  `(%forwarding-instance-slots (%wrapper-forwarding-info ,instance)))
953(defmacro %wrapper-forwarded-class-slots (instance)
954  `(%forwarding-class-slots (%wrapper-forwarding-info ,instance)))
955
956
957(defmacro %cons-forwarding-info (instance-slots class-slots)
958  `(cons ,instance-slots ,class-slots))
959
960
961(defmacro %cons-wrapper (class &optional 
962                               (hash-index '(new-class-wrapper-hash-index)))
963  `(%istruct 'class-wrapper ,hash-index ,class nil nil #'slot-id-lookup-no-slots nil nil #'%slot-id-ref-missing #'%slot-id-set-missing nil))
964
965
966(defmacro %instance-class (instance)
967  `(%wrapper-class (instance.class-wrapper ,instance)))
968
969(def-accessors standard-instance-instance-location-access ;A specializer
970    nil                                 ; backptr
971  specializer.direct-methods
972)
973
974(def-accessors (class) standard-instance-instance-location-access ;Slots of any class
975  nil                                   ; backptr
976  %class.direct-methods                 ; aka specializer.direct-methods
977  %class.prototype                      ; prototype instance
978  %class.name
979  %class.cpl                            ; class-precedence-list
980  %class.own-wrapper                    ; own wrapper (or nil)
981  %class.local-supers                   ; class-direct-superclasses
982  %class.subclasses                     ; class-direct-subclasses
983  %class.dependents                     ; arbitrary dependents
984  %class.ctype
985  %class.direct-slots                   ; local slots
986  %class.slots                          ; all slots
987  %class.info                           ; cons of kernel-p, proper-name
988  %class.local-default-initargs         ; local default initargs alist
989  %class.default-initargs               ; all default initargs if initialized.
990)
991
992
993(def-accessors () standard-instance-instance-location-access ; any standard class
994  nil                                   ; slot-vector backptr
995  nil                                   ; usual class stuff: direct-methods,
996  nil                                   ;   prototype,
997  nil                                   ;   name,
998  nil                                   ;   cpl,
999  nil                                   ;   own-wrapper,
1000  nil                                   ;   local-supers,
1001  nil                                   ;   subclasses,
1002  nil                                   ;   dependents,
1003  nil                                   ;   ctype.
1004  nil                                   ; local slots
1005  nil                                   ; all slots
1006  nil                                ; true if a non-redefinable class
1007  nil                                   ; local default initargs alist
1008  nil                           ; all default initargs if initialized.
1009  %class.alist                          ; other stuff about the class.
1010  %class.make-instance-initargs         ; (vector of) valid initargs to make-instance
1011  %class.reinit-initargs                ; valid initargs to reinitialize-instance
1012  %class.redefined-initargs             ; valid initargs to update-instance-for-redefined-class
1013  %class.changed-initargs               ; valid initargs to update-instance-for-changed-class
1014  )
1015
1016
1017
1018
1019
1020(defmacro %instance-vector (wrapper &rest slots)
1021  (let ((instance (gensym))
1022        (slots-vector (gensym)))
1023    `(let* ((,instance (gvector :instance 0 ,wrapper nil))
1024            (,slots-vector (gvector :slot-vector ,instance ,@slots)))
1025       (setf (instance.slots ,instance) ,slots-vector
1026             (instance.hash ,instance) (strip-tag-to-fixnum ,instance))
1027       ,instance)))
1028 
1029
1030
1031
1032(defmacro %cons-built-in-class (name)
1033  `(%instance-vector  *built-in-class-wrapper*
1034    nil                                 ;direct-methods
1035    nil                                 ;prototype
1036    ,name                               ;name
1037    nil                                 ;precedence-list
1038    nil                                 ;own-wrapper
1039    nil                                 ;direct-superclasses
1040    nil                                 ;direct-subclasses
1041    nil                                 ;dependents
1042    nil                                 ;class-ctype
1043    nil                                 ;direct-slots
1044    nil                                 ;slots
1045    (cons nil nil)                      ;info
1046    nil                                 ;direct-default-initargs
1047    nil                                 ;default-initargs
1048    ))
1049
1050(defmacro %cons-standard-class (name &optional
1051                                     (metaclass-wrapper '*standard-class-wrapper*))
1052  `(%instance-vector  ,metaclass-wrapper
1053    nil                                 ;direct-methods
1054    nil                                 ;prototype
1055    ,name                               ;name
1056    nil                                 ;precedence-list
1057    nil                                 ;own-wrapper
1058    nil                                 ;direct-superclasses
1059    nil                                 ;direct-subclasses
1060    nil                                 ;dependents
1061    nil                                 ;class-ctype
1062    nil                                 ;direct-slots
1063    nil                                 ;slots
1064    (cons nil nil)                      ;info
1065    nil                                 ;direct-default-initargs
1066    nil                                 ;default-initargs
1067    nil                                 ;alist
1068    nil                                 ;make-instance-initargs
1069    nil                                 ;reinit-initargs
1070    nil                                 ;redefined-initargs
1071    nil                                 ;changed-initargs
1072    )
1073)
1074
1075
1076
1077(defconstant max-class-ordinal (ash 1 20))
1078
1079
1080(def-accessors () standard-instance-instance-location-access
1081  nil                                   ; backptr
1082  standard-slot-definition.name
1083  standard-slot-definition.type
1084  standard-slot-definition.initfunction
1085  standard-slot-definition.initform
1086  standard-slot-definition.initargs
1087  standard-slot-definition.allocation
1088  standard-slot-definition.documentation
1089  standard-slot-definition.class
1090  )
1091
1092(def-accessors () standard-instance-instance-location-access
1093  nil
1094  standard-effective-slot-definition.name
1095  standard-effective-slot-definition.type
1096  standard-effective-slot-definition.initfunction
1097  standard-effective-slot-definition.initform
1098  standard-effective-slot-definition.initargs
1099  standard-effective-slot-definition.allocation
1100  standard-effective-slot-definition.documentation
1101  standard-effective-slot-definition.class
1102  standard-effective-slot-definition.location
1103  standard-effective-slot-definition.slot-id
1104  standard-effective-slot-definition.type-predicate
1105  )
1106
1107
1108(def-accessors () standard-instance-instance-location-access
1109  nil
1110  standard-direct-slot-definition.name
1111  standard-direct-slot-definition.type
1112  standard-direct-slot-definition.initfunction
1113  standard-direct-slot-definition.initform
1114  standard-direct-slot-definition.initargs
1115  standard-direct-slot-definition.allocation
1116  standard-direct-slot-definition.documentation
1117  standard-direct-slot-definition.class
1118  standard-direct-slot-definition.readers
1119  standard-direct-slot-definition.writers 
1120  )
1121
1122;; Methods
1123(defmacro %cons-method (name qualifiers specializers function &optional 
1124                             (class '*standard-method-class*))
1125  `(%instance-vector 
1126    (%class.own-wrapper ,class)
1127    ,qualifiers
1128    ,specializers
1129    ,function
1130    nil
1131    ,name))
1132
1133
1134(def-accessors standard-instance-instance-location-access ; method
1135  nil                                   ; backptr
1136  %method.qualifiers
1137  %method.specializers
1138  %method.function
1139  %method.gf
1140  %method.name
1141  %method.lambda-list)
1142
1143;;; Painful, but seems to be necessary.
1144(def-accessors standard-instance-instance-location-access ; standard-accessor-method
1145  nil                                   ; backptr
1146  nil                                   ;%method.qualifiers
1147  nil                                   ;%method.specializers
1148  nil                                   ;%method.function
1149  nil                                   ;%method.gf
1150  nil                                   ;%method.name
1151  nil                                   ;%method.lambda-list
1152  %accessor-method.slot-definition)
1153
1154
1155
1156
1157
1158;; Generic Function Dispatch tables.
1159;; These accessors are at the beginning of the table.
1160;; rest of the table is alternating wrappers & combined-methods.
1161
1162(def-accessors %svref
1163    %gf-dispatch-table-methods          ; List of methods
1164    %gf-dispatch-table-precedence-list  ; List of argument numbers in precedence order
1165    %gf-dispatch-table-keyvect          ; keyword vector, set by E-G-F.
1166    %gf-dispatch-table-argnum           ; argument number
1167    %gf-dispatch-table-gf               ; back pointer to gf - NEW
1168    %gf-dispatch-table-mask             ; mask for rest of table
1169    %gf-dispatch-table-first-data)      ; offset to first data.  Must follow mask.
1170 
1171(defmacro %gf-dispatch-table-size (dt)
1172  `(%i- (uvsize ,dt) ,(+ 2 %gf-dispatch-table-first-data)))
1173
1174(defmacro %gf-dispatch-table-ref (table index)
1175  `(%svref ,table (%i+ ,index %gf-dispatch-table-first-data)))
1176
1177(defmacro %cons-gf-dispatch-table (size)
1178  `(make-array (%i+ ,size ,(%i+ 2 %gf-dispatch-table-first-data))
1179               :initial-element nil))
1180
1181
1182;;; method-combination info
1183(def-accessors svref
1184  mci.class                             ; short-method-combination or long-method-combination
1185  mci.options                           ; short-form-options or long-form function
1186  mci.instances                         ; a population of instances
1187  mci.gfs                               ; a population of generic-functions
1188  )
1189
1190(defmacro %cons-mci (&optional class options)
1191  `(vector ,class ,options (%cons-population nil) (%cons-population nil)))
1192
1193;;; slot accessor info for primary classes
1194(def-accessors %svref
1195  %slot-accessor-info.class
1196  (%slot-accessor-info.accessor %slot-accessor-info.slot-name)
1197  %slot-accessor-info.offset
1198  )
1199
1200(defmacro %cons-slot-accessor-info (class accessor-or-slot-name &optional offset)
1201  `(vector ,class ,accessor-or-slot-name ,offset))
1202
1203(def-accessors (combined-method) nth-immediate
1204  combined-method.code-vector           ; trampoline code vector
1205  combined-method.thing                 ; arbitrary arg to dcode
1206  combined-method.dcode                 ; discriminator function
1207  combined-method.gf                    ; gf
1208  combined-method.bits                  ; lfun-bits
1209  )
1210;;; The structure of a generic-function object (funcallable instance).
1211(def-accessors (generic-function) nth-immediate
1212  gf.code-vector                        ; trampoline code-vector
1213  gf.instance.class-wrapper             ; instance class-wrapper
1214  gf.slots                              ; slots vector
1215  gf.dispatch-table                     ; effective-method cache
1216  gf.dcode                              ; discriminating code
1217  gf.hash                               ; hashing identity
1218  gf.bits                               ;
1219  )
1220
1221;;; The slots of STANDARD-GENERIC-FUNCTION.
1222(def-accessors (standard-generic-function) standard-generic-function-instance-location-access
1223  nil                                   ; backptr
1224  sgf.name                              ; generic-function-name
1225  sgf.method-combination                ; generic-function-method-combination
1226  sgf.method-class                      ; generic-function-method-class
1227  sgf.methods                           ; generic-function-methods
1228  sgf.decls                             ; generic-function-declarations
1229  sgf.%lambda-list                      ; explicit lambda-list
1230  sgf.dependents                        ; dependents for MAP-DEPENDENTS et al.
1231  )
1232
1233(def-accessors (slot-id) %svref
1234  nil                                   ;'slot-id
1235  slot-id.name                          ; slot name (symbol)
1236  slot-id.index                         ; index (integer)
1237  )
1238
1239(def-accessors (foreign-object-domain) %svref
1240  nil                                   ; foreign-object-domain
1241  foreign-object-domain-index           ; 1..n
1242  foreign-object-domain-name            ;
1243  foreign-object-domain-recognize       ; function: is object one of ours ?
1244  foreign-object-domain-class-of        ; function: returns class of object
1245  foreign-object-domain-classp          ; function: true if object is a class
1246  foreign-object-domain-instance-class-wrapper ; function: returns wrapper of object's class
1247  foreign-object-domain-class-own-wrapper ; function: returns class own wrapper if class
1248  foreign-object-domain-slots-vector    ; returns slots vector of object or nil
1249  )
1250
1251;;; Hash table accessors.
1252(def-accessors (hash-table) %svref
1253    nil                                 ; 'HASH-TABLE
1254    nhash.rehashF                       ; function: rehashes if necessary
1255    nhash.keytransF                     ; transform key into (values primary addressp)
1256    nhash.compareF                      ; comparison function: 0 -> eq, -1 ->eql, else function
1257    nhash.rehash-bits                   ; bitset (array (unsigned-byte 32)) for rehash
1258    nhash.vector                        ; N <key,value> pairs; n relatively prime to & larger than all secondary keys
1259    nhash.lock                          ; fixnum: bits for grow and rehash
1260    nhash.count                         ; Number of entries
1261    nhash.owner                         ; tcr of "owning" thread, else NIL.
1262    nhash.fixnum                        ; fwdnum kernel-global
1263    nhash.gc-count                      ; gc-count kernel-global
1264    nhash.grow-threshold                ; Max # entries before grow
1265    nhash.rehash-ratio                  ; inverted rehash-threshold
1266    nhash.rehash-size                   ; rehash-size from user
1267    nhash.puthash-count                 ; number of times table has been rehashed or grown
1268    nhash.exclusion-lock                ; read-write lock for access
1269    nhash.rehash-lock                   ; exclusive lock for rehash
1270    nhash.iterator                      ; current hash-table iterator
1271    nhash.address-based                 ; hashes based on address
1272    nhash.find                          ; function: find vector-index
1273    nhash.find-new                      ; function: find vector-index on put
1274    nhash.read-only                     ; boolean: true when read-only
1275    )
1276
1277(def-accessors (lock-acquisition) %svref
1278  nil                                   ; 'lock-acquisition
1279  lock-acquisition.status
1280  )
1281
1282(defmacro make-lock-acquisition ()
1283  `(%istruct 'lock-acquisition nil))
1284
1285(def-accessors (semaphore-notification) %svref
1286  nil                                   ; 'semaphore-notification
1287  semaphore-notification.status
1288  )
1289
1290(defmacro make-semaphore-notification ()
1291  `(%istruct 'semaphore-notification nil))
1292
1293;;; Why were these ever in architecture-dependent packages ?
1294(defenum (:prefix "AREA-")
1295  void                                  ; list header
1296  cstack                                ; a control stack
1297  vstack                                ; a value stack
1298  tstack                                ; (dynamic-extent) temp stack
1299  readonly                              ; readonly section
1300  managed-static                        ; growable static area
1301  static                                ; static data in application
1302  dynamic                               ; dynmaic (heap) data in application
1303)
1304
1305;;; areas are sorted such that (in the "succ" direction) codes are >=.
1306;;; If you think that you're looking for a stack (instead of a heap), look
1307;;; in the "pred" direction from the all-areas header.
1308(defconstant max-stack-area-code area-tstack)
1309(defconstant min-heap-area-code area-readonly)
1310
1311
1312;;; Lisp threads, which barely need to exist and aren't worth burning
1313;;; a separate tag on ...
1314(def-accessors (lisp-thread) %svref
1315  nil                                   ;'lisp-thread
1316  lisp-thread.tcr
1317  lisp-thread.name
1318  lisp-thread.cs-size
1319  lisp-thread.vs-size
1320  lisp-thread.ts-size
1321  lisp-thread.initial-function.args
1322  lisp-thread.interrupt-functions
1323  lisp-thread.interrupt-lock
1324  lisp-thread.startup-function
1325  lisp-thread.state
1326  lisp-thread.state-change-lock
1327  )
1328
1329;;; "basic" (e.g., builtin, non-extensible) streams.
1330(def-accessors (basic-stream) %svref
1331  basic-stream.class                    ; a class object
1332  basic-stream.flags                    ; fixnum; bits.
1333  basic-stream.state                    ; typically an ioblock
1334  basic-stream.info                     ; a plist for less-often-used things.
1335)
1336
1337(def-accessors (basic-file-stream) %svref
1338  basic-file-stream.class               ; a class object
1339  basic-file-stream.flags               ; fixnum; bits.
1340  basic-file-stream.state               ; typically an ioblock
1341  basic-file-stream.info                ; a plist for less-often-used things.
1342  basic-file-stream.filename
1343  basic-file-stream.actual-filename
1344  basic-file-stream.external-format
1345  )
1346
1347;;; Bits in basic-stream.flags
1348(defenum (:prefix "BASIC-STREAM-FLAG.")
1349  open-input
1350  open-output
1351  open-character
1352  open-binary
1353  file-stream)
1354
1355
1356(def-accessors (class-cell) %svref
1357  nil                                   ; 'class-cell
1358  class-cell-name
1359  class-cell-class
1360  class-cell-instantiate
1361  class-cell-extra                      ; wrapper in some cases
1362  )
1363
1364(defmacro make-class-cell (name) `(%istruct 'class-cell ,name nil '%make-instance nil))
1365
1366;;; Map between TYPE-SPECIFIERS and CTYPEs
1367(def-accessors (type-cell) %svref
1368  nil
1369  type-cell-type-specifier
1370  type-cell-ctype)
1371
1372(defmacro make-type-cell (specifier) `(%istruct 'type-cell ,specifier nil))
1373
1374;;; Map between package names and packages, sometimes.
1375(def-accessors (package-ref) %svref
1376  nil
1377  package-ref.name                      ; a string
1378  package-ref.pkg                       ; a package or NIL
1379  )
1380
1381(defmacro make-package-ref (name) `(%istruct 'package-ref (string ,name) nil))
1382
1383
1384(def-accessor-macros %svref
1385  nil                                 ; 'external-entry-point
1386  eep.address
1387  eep.name
1388  eep.container)
1389
1390(defmacro %cons-external-entry-point (name &optional container)
1391  `(%istruct 'external-entry-point nil ,name ,container))
1392
1393(def-accessor-macros %svref
1394    nil                                 ;'foreign-variable
1395  fv.addr                               ; a MACPTR, or nil
1396  fv.name                               ; a string
1397  fv.type                               ; a foreign type
1398  fv.container                          ; containing library
1399  )
1400
1401(defun %cons-foreign-variable (name type &optional container)
1402  (%istruct 'foreign-variable nil name type container))
1403
1404(def-accessor-macros %svref
1405    nil                                 ;'shlib
1406  shlib.soname
1407  shlib.pathname
1408  shlib.handle                          ; if explicitly opened
1409  shlib.map
1410  shlib.base
1411  shlib.opencount)
1412
1413(defmacro %cons-shlib (soname pathname map base)
1414  `(%istruct 'shlib ,soname ,pathname nil ,map ,base 0))
1415
1416(def-accessors uvref ; %svref
1417    ()                                  ;'entry
1418  entry-test                          ;predicate function or count of higher priority others.
1419  entry-fn                            ;pprint function
1420  entry-full-spec                     ;list of priority and type specifier
1421  )
1422
1423(def-accessors %svref
1424    ()                                  ; 'xp-structure
1425  xp-base-stream ;;The stream io eventually goes to.
1426  xp-linel ;;The line length to use for formatting.
1427  xp-line-limit ;;If non-NIL the max number of lines to print.
1428  xp-line-no ;;number of next line to be printed.
1429  xp-char-mode ;;NIL :UP :DOWN :CAP0 :CAP1 :CAPW
1430  xp-char-mode-counter                  ;depth of nesting of ~(...~)
1431  xp-depth-in-blocks ;;Number of logical blocks at QRIGHT that
1432  ;;are started but not ended.             
1433  xp-block-stack 
1434  xp-block-stack-ptr
1435  ;;This stack is pushed and popped in accordance with the way blocks are
1436  ;;nested at the moment they are entered into the queue.  It contains the
1437  ;;following block specific value.
1438  ;;SECTION-START total position where the section (see AIM-1102)
1439  ;;that is rightmost in the queue started.
1440  xp-buffer
1441  xp-charpos
1442  xp-buffer-ptr 
1443  xp-buffer-offset
1444  ;;This is a vector of characters (eg a string) that builds up the
1445  ;;line images that will be printed out.  BUFFER-PTR is the
1446  ;;buffer position where the next character should be inserted in
1447  ;;the string.  CHARPOS is the output character position of the
1448  ;;first character in the buffer (non-zero only if a partial line
1449  ;;has been output).  BUFFER-OFFSET is used in computing total lengths.
1450  ;;It is changed to reflect all shifting and insertion of prefixes so that
1451  ;;total length computes things as they would be if they were
1452  ;;all on one line.  Positions are kept three different ways
1453  ;; Buffer position (eg BUFFER-PTR)
1454  ;; Line position (eg (+ BUFFER-PTR CHARPOS)).  Indentations are stored in this form.
1455  ;; Total position if all on one line (eg (+ BUFFER-PTR BUFFER-OFFSET))
1456  ;;  Positions are stored in this form.
1457  xp-queue
1458  xp-qleft
1459  xp-qright
1460  ;;This holds a queue of action descriptors.  QLEFT and QRIGHT
1461  ;;point to the next entry to dequeue and the last entry enqueued
1462  ;;respectively.  The queue is empty when
1463  ;;(> QLEFT QRIGHT).  The queue entries have several parts:
1464  ;;QTYPE one of :NEWLINE/:IND/:START-BLOCK/:END-BLOCK
1465  ;;QKIND :LINEAR/:MISER/:FILL/:MANDATORY or :UNCONDITIONAL/:FRESH
1466  ;; or :BLOCK/:CURRENT
1467  ;;QPOS total position corresponding to this entry
1468  ;;QDEPTH depth in blocks of this entry.
1469  ;;QEND offset to entry marking end of section this entry starts. (NIL until known.)
1470  ;; Only :start-block and non-literal :newline entries can start sections.
1471  ;;QOFFSET offset to :END-BLOCK for :START-BLOCK (NIL until known).
1472  ;;QARG for :IND indentation delta
1473  ;;     for :START-BLOCK suffix in the block if any.
1474  ;;                      or if per-line-prefix then cons of suffix and
1475  ;;                      per-line-prefix.
1476  ;;     for :END-BLOCK suffix for the block if any.
1477  xp-prefix
1478  ;;this stores the prefix that should be used at the start of the line
1479  xp-prefix-stack
1480  xp-prefix-stack-ptr
1481  ;;This stack is pushed and popped in accordance with the way blocks
1482  ;;are nested at the moment things are taken off the queue and printed.
1483  ;;It contains the following block specific values.
1484  ;;PREFIX-PTR current length of PREFIX.
1485  ;;SUFFIX-PTR current length of pending suffix
1486  ;;NON-BLANK-PREFIX-PTR current length of non-blank prefix.
1487  ;;INITIAL-PREFIX-PTR prefix-ptr at the start of this block.
1488  ;;SECTION-START-LINE line-no value at last non-literal break at this level.
1489  xp-suffix
1490  ;;this stores the suffixes that have to be printed to close of the current
1491  ;;open blocks.  For convenient in popping, the whole suffix
1492  ;;is stored in reverse order.
1493  xp-stream  ;;; the xp-stream containing this structure
1494  xp-string-stream ;; string-stream for output until first circularity (in case none)
1495  )
1496
1497  (def-accessors (afunc) %svref
1498    ()                                    ; 'afunc
1499    afunc-acode
1500    afunc-parent
1501    afunc-vars
1502    afunc-inherited-vars
1503    afunc-blocks
1504    afunc-tags
1505    afunc-inner-functions
1506    afunc-name
1507    afunc-bits
1508    afunc-lfun
1509    afunc-environment
1510    afunc-lambdaform
1511    afunc-argsword
1512    afunc-ref-form
1513    afunc-warnings
1514    afunc-fn-refcount
1515    afunc-fn-downward-refcount
1516    afunc-all-vars
1517    afunc-callers
1518    afunc-vcells
1519    afunc-fcells
1520    afunc-fwd-refs
1521    afunc-lfun-info
1522    afunc-linkmap)
1523
1524(declaim (inline %make-afunc))
1525
1526(defmacro %make-afunc ()
1527  `(%istruct 'afunc
1528    nil                                 ;afunc-acode
1529    nil                                 ;afunc-parent
1530    nil                                 ;afunc-vars
1531    nil                                 ;afunc-inherited-vars
1532    nil                                 ;afunc-blocks
1533    nil                                 ;afunc-tags
1534    nil                                 ;afunc-inner-functions
1535    nil                                 ;afunc-name
1536    nil                                 ;afunc-bits
1537    nil                                 ;afunc-lfun
1538    nil                                 ;afunc-environment
1539    nil                                 ;afunc-lambdaform
1540    nil                                 ;afunc-argsword
1541    nil                                 ;afunc-ref-form
1542    nil                                 ;afunc-warnings
1543    nil                                 ;afunc-fn-refcount
1544    nil                                 ;afunc-fn-downward-refcount
1545    nil                                 ;afunc-all-vars
1546    nil                                 ;afunc-callers
1547    nil                                 ;afunc-vcells
1548    nil                                 ;afunc-fcells
1549    nil                                 ;afunc-fwd-refs
1550    nil                                 ;afunc-lfun-info
1551    nil                                 ;afunc-linkmap
1552    ))
1553
1554
1555(def-accessors (compiler-policy) uvref
1556  nil                                   ; 'compiler-policy
1557  policy.allow-tail-recursion-elimination
1558  policy.inhibit-register-allocation
1559  policy.trust-declarations
1560  policy.open-code-inline
1561  policy.inhibit-safety-checking
1562  policy.the-typechecks
1563  policy.inline-self-calls
1564  policy.allow-transforms
1565  policy.force-boundp-checks
1566  policy.allow-constant-substitution
1567  policy.misc)
1568
1569
1570(def-accessors (deferred-warnings) %svref
1571  nil
1572  deferred-warnings.parent
1573  deferred-warnings.warnings
1574  deferred-warnings.defs
1575  deferred-warnings.flags ; might use to distinguish interactive case/compile-file
1576)
1577
1578;;; loader framework istruct
1579(def-accessors (faslapi) %svref
1580  ()
1581  ;; these represent all users of faslstate.iobuffer, .bufcount, and
1582  ;; .faslfd -- I think these are all the important file- and
1583  ;; buffer-IO-specific slots in faslstate; encapsulating these allows
1584  ;; sophisticated users to load fasl data from nonstandard sources
1585  ;; without too much trouble
1586  faslapi.fasl-open
1587  faslapi.fasl-close
1588  faslapi.fasl-init-buffer
1589  faslapi.fasl-set-file-pos
1590  faslapi.fasl-get-file-pos
1591  faslapi.fasl-read-buffer
1592  faslapi.fasl-read-byte
1593  faslapi.fasl-read-n-bytes)
1594
1595
1596(defmacro istruct-cell-name (cell)
1597  `(car ,cell))
1598
1599(defmacro istruct-cell-info (cell)
1600  `(cdr ,cell))
1601
1602(provide "LISPEQU")
1603
1604;;; End of lispequ.lisp
Note: See TracBrowser for help on using the repository browser.