source: branches/new-random/library/lispequ.lisp @ 13318

Last change on this file since 13318 was 13318, checked in by rme, 10 years ago

Updated accessors for new random state object.

(temporarily x86-only)

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