source: branches/qres/ccl/library/lispequ.lisp @ 15278

Last change on this file since 15278 was 13339, checked in by gz, 10 years ago

New CL:RANDOM implementation from trunk

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 55.2 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2009 Clozure Associates
4;;;   Copyright (C) 1994-2001 Digitool, Inc
5;;;   This file is part of Clozure CL. 
6;;;
7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18;; 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(def-accessors (random-state) %svref
825  ()
826  random.mrg31k3p-state)
827
828;;; IEEE-floating-point constants.
829
830(defconstant IEEE-single-float-bias 126)
831(defconstant IEEE-single-float-exponent-offset 23)
832(defconstant IEEE-single-float-exponent-width 8)
833(defconstant IEEE-single-float-mantissa-offset 0)
834(defconstant IEEE-single-float-mantissa-width 23)
835(defconstant IEEE-single-float-hidden-bit 23)
836(defconstant IEEE-single-float-signalling-NAN-bit 22)
837(defconstant IEEE-single-float-normal-exponent-min 1)
838(defconstant IEEE-single-float-normal-exponent-max 254)
839(defconstant IEEE-single-float-digits (1+ IEEE-single-float-mantissa-width))
840
841;;; Double-floats are IEEE DOUBLE-FLOATs in both MCL implementations.
842
843(defconstant IEEE-double-float-bias 1022)
844(defconstant IEEE-double-float-exponent-offset 52)
845(defconstant IEEE-double-float-exponent-width 11)
846(defconstant IEEE-double-float-mantissa-offset 0)
847(defconstant IEEE-double-float-mantissa-width 52)
848(defconstant IEEE-double-float-hidden-bit 52)
849(defconstant IEEE-double-float-signalling-NAN-bit 51)
850(defconstant IEEE-double-float-normal-exponent-min 1)
851(defconstant IEEE-double-float-normal-exponent-max 2046)
852(defconstant IEEE-double-float-digits (1+ IEEE-double-float-mantissa-width))
853
854
855
856
857(def-accessors (ptaskstate) %svref
858  nil                                   ;ptaskstate
859  ptaskstate.nexttick
860  ptaskstate.interval
861  ptaskstate.privatedata
862  ptaskstate.flags)
863
864
865
866
867 
868
869;;;;;; clos instance and class layout.
870
871;;; All standard-instances (classes, instances other than funcallable
872;;; instances) consist of a vector of slot values and a pointer to the
873;;; class wrapper.
874(def-accessors (instance) %svref
875  instance.hash                         ; a fixnum for EQ-based hashing
876  instance.class-wrapper
877  instance.slots                        ; a slot-vector
878)
879;;; Doing this via %SLOT-REF traps if the slot is unbound
880(defmacro standard-instance-instance-location-access (instance location)
881  `(%slot-ref (instance-slots ,instance) ,location))
882
883;;; Get the "raw" contents of the slot, even if it's %SLOT-UNBOUND-MARKER.
884(defmacro %standard-instance-instance-location-access (instance location)
885  `(%svref (instance-slots ,instance) ,location))
886
887(defmacro set-standard-instance-instance-location-access (instance location new)
888  `(setf (%svref (instance-slots ,instance) ,location) ,new))
889
890(defsetf standard-instance-instance-location-access
891    set-standard-instance-instance-location-access)
892
893(defmacro standard-generic-function-instance-location-access (sgf location)
894  `(%slot-ref (gf.slots ,sgf) ,location))
895
896(defmacro %standard-generic-function-instance-location-access (sgf location)
897  `(%svref (gf.slots ,sgf) ,location))
898
899(defmacro set-standard-generic-function-instance-location-access (sgf location new)
900  `(setf (%svref (gf.slots ,sgf) ,location) ,new))
901
902(defsetf standard-generic-function-instance-location-access
903    set-standard-generic-function-instance-location-access)
904
905;;; Slot vectors contain the instance they "belong" to (or NIL) in
906;;; their 0th element, and the instance's slots in elements 1 .. n.
907
908(def-accessors (slot-vector) %svref
909  slot-vector.instance
910  )
911
912(def-accessors (class-wrapper) %svref
913  nil                                   ; 'class-wrapper
914  %wrapper-hash-index                   ; for generic-function dispatch tables
915  %wrapper-class                        ; the class itself
916  %wrapper-instance-slots               ; vector of instance slot names
917  %wrapper-class-slots                  ; alist of (name . value-cell) pairs
918  %wrapper-slot-id->slotd               ; map slot-id to slotd, or NIL
919  %wrapper-slot-id-map                  ; (vector (mod nslots) next-slot-id-index)
920  %wrapper-slot-definition-table        ; vector of nil || slot-definitions
921  %wrapper-slot-id-value                ; "fast" SLOT-VALUE function
922  %wrapper-set-slot-id-value            ; "fast" (SETF SLOT-VALUE) function
923  %wrapper-cpl                          ; cached cpl of %wrapper-class or NIL
924  %wrapper-class-ordinal                ; cached copy of class-ordinal
925  %wrapper-cpl-bits                     ; bitvector representation of cpl
926)
927
928;; Use the wrapper-class-slots for info on obsolete & forwarded instances
929;; Note: none of this xx-forwarding-xx or xx-forwarded-xx is valid unless
930;; (%wrapper-instance-slots ...) is 0.
931(defmacro %wrapper-forwarding-info (instance)
932  `(%wrapper-class-slots ,instance))
933
934(defmacro %forwarding-instance-slots (info)
935  `(%car ,info))
936(defmacro %forwarding-class-slots (info)
937  `(%cdr ,info))
938
939
940(defmacro %wrapper-forwarded-instance-slots (instance)
941  `(%forwarding-instance-slots (%wrapper-forwarding-info ,instance)))
942(defmacro %wrapper-forwarded-class-slots (instance)
943  `(%forwarding-class-slots (%wrapper-forwarding-info ,instance)))
944
945
946(defmacro %cons-forwarding-info (instance-slots class-slots)
947  `(cons ,instance-slots ,class-slots))
948
949
950(defmacro %cons-wrapper (class &optional 
951                               (hash-index '(new-class-wrapper-hash-index)))
952  (let* ((c (gensym)))
953  `(let* ((,c ,class))
954    (%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))))
955
956
957(defmacro %instance-class (instance)
958  `(%wrapper-class (instance.class-wrapper ,instance)))
959
960(def-accessors standard-instance-instance-location-access ;A specializer
961    nil                                 ; backptr
962  specializer.direct-methods
963)
964
965(def-accessors (class) standard-instance-instance-location-access ;Slots of any class
966  nil                                   ; backptr
967  %class.direct-methods                 ; aka specializer.direct-methods
968  %class.prototype                      ; prototype instance
969  %class.name
970  %class.cpl                            ; class-precedence-list
971  %class.own-wrapper                    ; own wrapper (or nil)
972  %class.local-supers                   ; class-direct-superclasses
973  %class.subclasses                     ; class-direct-subclasses
974  %class.dependents                     ; arbitrary dependents
975  %class.ctype
976  %class.direct-slots                   ; local slots
977  %class.slots                          ; all slots
978  %class.info                           ; cons of kernel-p, proper-name
979  %class.local-default-initargs         ; local default initargs alist
980  %class.default-initargs               ; all default initargs if initialized.
981)
982
983
984(def-accessors () standard-instance-instance-location-access ; any standard class
985  nil                                   ; slot-vector backptr
986  nil                                   ; usual class stuff: direct-methods,
987  nil                                   ;   prototype,
988  nil                                   ;   name,
989  nil                                   ;   cpl,
990  nil                                   ;   own-wrapper,
991  nil                                   ;   local-supers,
992  nil                                   ;   subclasses,
993  nil                                   ;   dependents,
994  nil                                   ;   ctype.
995  nil                                   ; local slots
996  nil                                   ; all slots
997  nil                                ; true if a non-redefinable class
998  nil                                   ; local default initargs alist
999  nil                           ; all default initargs if initialized.
1000  %class.alist                          ; other stuff about the class.
1001  %class.make-instance-initargs         ; (vector of) valid initargs to make-instance
1002  %class.reinit-initargs                ; valid initargs to reinitialize-instance
1003  %class.redefined-initargs             ; valid initargs to update-instance-for-redefined-class
1004  %class.changed-initargs               ; valid initargs to update-instance-for-changed-class
1005  )
1006
1007
1008
1009
1010
1011(defmacro %instance-vector (wrapper &rest slots)
1012  (let ((instance (gensym))
1013        (slots-vector (gensym)))
1014    `(let* ((,instance (gvector :instance 0 ,wrapper nil))
1015            (,slots-vector (gvector :slot-vector ,instance ,@slots)))
1016       (setf (instance.slots ,instance) ,slots-vector
1017             (instance.hash ,instance) (strip-tag-to-fixnum ,instance))
1018       ,instance)))
1019 
1020
1021
1022
1023(defmacro %cons-built-in-class (name)
1024  `(%instance-vector  *built-in-class-wrapper*
1025    nil                                 ;direct-methods
1026    nil                                 ;prototype
1027    ,name                               ;name
1028    nil                                 ;precedence-list
1029    nil                                 ;own-wrapper
1030    nil                                 ;direct-superclasses
1031    nil                                 ;direct-subclasses
1032    nil                                 ;dependents
1033    nil                                 ;class-ctype
1034    nil                                 ;direct-slots
1035    nil                                 ;slots
1036    (cons nil nil)                      ;info
1037    nil                                 ;direct-default-initargs
1038    nil                                 ;default-initargs
1039    ))
1040
1041(defmacro %cons-standard-class (name &optional
1042                                     (metaclass-wrapper '*standard-class-wrapper*))
1043  `(%instance-vector  ,metaclass-wrapper
1044    nil                                 ;direct-methods
1045    nil                                 ;prototype
1046    ,name                               ;name
1047    nil                                 ;precedence-list
1048    nil                                 ;own-wrapper
1049    nil                                 ;direct-superclasses
1050    nil                                 ;direct-subclasses
1051    nil                                 ;dependents
1052    nil                                 ;class-ctype
1053    nil                                 ;direct-slots
1054    nil                                 ;slots
1055    (cons nil nil)                      ;info
1056    nil                                 ;direct-default-initargs
1057    nil                                 ;default-initargs
1058    nil                                 ;alist
1059    nil                                 ;make-instance-initargs
1060    nil                                 ;reinit-initargs
1061    nil                                 ;redefined-initargs
1062    nil                                 ;changed-initargs
1063    )
1064)
1065
1066
1067
1068(defconstant max-class-ordinal (ash 1 20))
1069
1070
1071(def-accessors () standard-instance-instance-location-access
1072  nil                                   ; backptr
1073  standard-slot-definition.name
1074  standard-slot-definition.type
1075  standard-slot-definition.initfunction
1076  standard-slot-definition.initform
1077  standard-slot-definition.initargs
1078  standard-slot-definition.allocation
1079  standard-slot-definition.documentation
1080  standard-slot-definition.class
1081  )
1082
1083(def-accessors () standard-instance-instance-location-access
1084  nil
1085  standard-effective-slot-definition.name
1086  standard-effective-slot-definition.type
1087  standard-effective-slot-definition.initfunction
1088  standard-effective-slot-definition.initform
1089  standard-effective-slot-definition.initargs
1090  standard-effective-slot-definition.allocation
1091  standard-effective-slot-definition.documentation
1092  standard-effective-slot-definition.class
1093  standard-effective-slot-definition.location
1094  standard-effective-slot-definition.slot-id
1095  standard-effective-slot-definition.type-predicate
1096  )
1097
1098
1099(def-accessors () standard-instance-instance-location-access
1100  nil
1101  standard-direct-slot-definition.name
1102  standard-direct-slot-definition.type
1103  standard-direct-slot-definition.initfunction
1104  standard-direct-slot-definition.initform
1105  standard-direct-slot-definition.initargs
1106  standard-direct-slot-definition.allocation
1107  standard-direct-slot-definition.documentation
1108  standard-direct-slot-definition.class
1109  standard-direct-slot-definition.readers
1110  standard-direct-slot-definition.writers 
1111  )
1112
1113;; Methods
1114(defmacro %cons-method (name qualifiers specializers function &optional 
1115                             (class '*standard-method-class*))
1116  `(%instance-vector 
1117    (%class.own-wrapper ,class)
1118    ,qualifiers
1119    ,specializers
1120    ,function
1121    nil
1122    ,name))
1123
1124
1125(def-accessors standard-instance-instance-location-access ; method
1126  nil                                   ; backptr
1127  %method.qualifiers
1128  %method.specializers
1129  %method.function
1130  %method.gf
1131  %method.name
1132  %method.lambda-list)
1133
1134;;; Painful, but seems to be necessary.
1135(def-accessors standard-instance-instance-location-access ; standard-accessor-method
1136  nil                                   ; backptr
1137  nil                                   ;%method.qualifiers
1138  nil                                   ;%method.specializers
1139  nil                                   ;%method.function
1140  nil                                   ;%method.gf
1141  nil                                   ;%method.name
1142  nil                                   ;%method.lambda-list
1143  %accessor-method.slot-definition)
1144
1145
1146
1147
1148
1149;; Generic Function Dispatch tables.
1150;; These accessors are at the beginning of the table.
1151;; rest of the table is alternating wrappers & combined-methods.
1152
1153(def-accessors %svref
1154    %gf-dispatch-table-methods          ; List of methods
1155    %gf-dispatch-table-precedence-list  ; List of argument numbers in precedence order
1156    %gf-dispatch-table-keyvect          ; keyword vector, set by E-G-F.
1157    %gf-dispatch-table-argnum           ; argument number
1158    %gf-dispatch-table-gf               ; back pointer to gf - NEW
1159    %gf-dispatch-table-mask             ; mask for rest of table
1160    %gf-dispatch-table-first-data)      ; offset to first data.  Must follow mask.
1161 
1162(defmacro %gf-dispatch-table-size (dt)
1163  `(%i- (uvsize ,dt) ,(+ 2 %gf-dispatch-table-first-data)))
1164
1165(defmacro %gf-dispatch-table-ref (table index)
1166  `(%svref ,table (%i+ ,index %gf-dispatch-table-first-data)))
1167
1168(defmacro %cons-gf-dispatch-table (size)
1169  `(make-array (%i+ ,size ,(%i+ 2 %gf-dispatch-table-first-data))
1170               :initial-element nil))
1171
1172
1173;;; method-combination info
1174(def-accessors svref
1175  mci.class                             ; short-method-combination or long-method-combination
1176  mci.options                           ; short-form-options or long-form function
1177  mci.instances                         ; a population of instances
1178  mci.gfs                               ; a population of generic-functions
1179  )
1180
1181(defmacro %cons-mci (&optional class options)
1182  `(vector ,class ,options (%cons-population nil) (%cons-population nil)))
1183
1184;;; slot accessor info for primary classes
1185(def-accessors %svref
1186  %slot-accessor-info.class
1187  (%slot-accessor-info.accessor %slot-accessor-info.slot-name)
1188  %slot-accessor-info.offset
1189  )
1190
1191(defmacro %cons-slot-accessor-info (class accessor-or-slot-name &optional offset)
1192  `(vector ,class ,accessor-or-slot-name ,offset))
1193
1194(def-accessors (combined-method) nth-immediate
1195  combined-method.code-vector           ; trampoline code vector
1196  combined-method.thing                 ; arbitrary arg to dcode
1197  combined-method.dcode                 ; discriminator function
1198  combined-method.gf                    ; gf
1199  combined-method.bits                  ; lfun-bits
1200  )
1201;;; The structure of a generic-function object (funcallable instance).
1202(def-accessors (generic-function) nth-immediate
1203  gf.code-vector                        ; trampoline code-vector
1204  gf.instance.class-wrapper             ; instance class-wrapper
1205  gf.slots                              ; slots vector
1206  gf.dispatch-table                     ; effective-method cache
1207  gf.dcode                              ; discriminating code
1208  gf.hash                               ; hashing identity
1209  gf.bits                               ;
1210  )
1211
1212;;; The slots of STANDARD-GENERIC-FUNCTION.
1213(def-accessors (standard-generic-function) standard-generic-function-instance-location-access
1214  nil                                   ; backptr
1215  sgf.name                              ; generic-function-name
1216  sgf.method-combination                ; generic-function-method-combination
1217  sgf.method-class                      ; generic-function-method-class
1218  sgf.methods                           ; generic-function-methods
1219  sgf.decls                             ; generic-function-declarations
1220  sgf.%lambda-list                      ; explicit lambda-list
1221  sgf.dependents                        ; dependents for MAP-DEPENDENTS et al.
1222  )
1223
1224(def-accessors (slot-id) %svref
1225  nil                                   ;'slot-id
1226  slot-id.name                          ; slot name (symbol)
1227  slot-id.index                         ; index (integer)
1228  )
1229
1230(def-accessors (foreign-object-domain) %svref
1231  nil                                   ; foreign-object-domain
1232  foreign-object-domain-index           ; 1..n
1233  foreign-object-domain-name            ;
1234  foreign-object-domain-recognize       ; function: is object one of ours ?
1235  foreign-object-domain-class-of        ; function: returns class of object
1236  foreign-object-domain-classp          ; function: true if object is a class
1237  foreign-object-domain-instance-class-wrapper ; function: returns wrapper of object's class
1238  foreign-object-domain-class-own-wrapper ; function: returns class own wrapper if class
1239  foreign-object-domain-slots-vector    ; returns slots vector of object or nil
1240  foreign-object-domain-class-ordinal   ; returns class ordinal if class
1241  foreign-object-domain-set-class-ordinal  ; sets class ordinal if class
1242  )
1243
1244;;; Hash table accessors.
1245(def-accessors (hash-table) %svref
1246    nil                                 ; 'HASH-TABLE
1247    nhash.keytransF                     ; transform key into (values primary addressp)
1248    nhash.compareF                      ; comparison function: 0 -> eq, -1 ->eql, else function
1249    nhash.rehash-bits                   ; bitset (array (unsigned-byte 32)) for rehash
1250    nhash.vector                        ; N <key,value> pairs; n relatively prime to & larger than all secondary keys
1251    nhash.lock                          ; flag: non-zero if lock-free
1252    nhash.owner                         ; tcr of "owning" thread, else NIL.
1253    nhash.grow-threshold                ; Max # entries before grow
1254    nhash.rehash-ratio                  ; inverted rehash-threshold
1255    nhash.rehash-size                   ; rehash-size from user
1256    nhash.puthash-count                 ; number of times table has been rehashed or grown
1257    nhash.exclusion-lock                ; read-write lock for access
1258    nhash.find                          ; function: find vector-index
1259    nhash.find-new                      ; function: find vector-index on put
1260    nhash.read-only                     ; boolean: true when read-only
1261    )
1262
1263(def-accessors (lock-acquisition) %svref
1264  nil                                   ; 'lock-acquisition
1265  lock-acquisition.status
1266  )
1267
1268(defmacro make-lock-acquisition ()
1269  `(%istruct 'lock-acquisition nil))
1270
1271(def-accessors (semaphore-notification) %svref
1272  nil                                   ; 'semaphore-notification
1273  semaphore-notification.status
1274  )
1275
1276(defmacro make-semaphore-notification ()
1277  `(%istruct 'semaphore-notification nil))
1278
1279;;; Why were these ever in architecture-dependent packages ?
1280(defenum (:prefix "AREA-")
1281  void                                  ; list header
1282  cstack                                ; a control stack
1283  vstack                                ; a value stack
1284  tstack                                ; (dynamic-extent) temp stack
1285  readonly                              ; readonly section
1286  watched                               ; static area containing a single object
1287  managed-static                        ; growable static area
1288  static                                ; static data in application
1289  dynamic                               ; dynmaic (heap) data in application
1290)
1291
1292;;; areas are sorted such that (in the "succ" direction) codes are >=.
1293;;; If you think that you're looking for a stack (instead of a heap), look
1294;;; in the "pred" direction from the all-areas header.
1295(defconstant max-stack-area-code area-tstack)
1296(defconstant min-heap-area-code area-readonly)
1297
1298
1299;;; Lisp threads, which barely need to exist and aren't worth burning
1300;;; a separate tag on ...
1301(def-accessors (lisp-thread) %svref
1302  nil                                   ;'lisp-thread
1303  lisp-thread.tcr
1304  lisp-thread.name
1305  lisp-thread.cs-size
1306  lisp-thread.vs-size
1307  lisp-thread.ts-size
1308  lisp-thread.initial-function.args
1309  lisp-thread.interrupt-functions
1310  lisp-thread.interrupt-lock
1311  lisp-thread.startup-function
1312  lisp-thread.state
1313  lisp-thread.state-change-lock
1314  )
1315
1316;;; "basic" (e.g., builtin, non-extensible) streams.
1317(def-accessors (basic-stream) %svref
1318  basic-stream.wrapper                  ; a class wrapper object
1319  basic-stream.flags                    ; fixnum; bits.
1320  basic-stream.state                    ; typically an ioblock
1321  basic-stream.info                     ; a plist for less-often-used things.
1322)
1323
1324(def-accessors (basic-file-stream) %svref
1325  basic-file-stream.class               ; a class object
1326  basic-file-stream.flags               ; fixnum; bits.
1327  basic-file-stream.state               ; typically an ioblock
1328  basic-file-stream.info                ; a plist for less-often-used things.
1329  basic-file-stream.filename
1330  basic-file-stream.actual-filename
1331  basic-file-stream.external-format
1332  )
1333
1334;;; Bits in basic-stream.flags
1335(defenum (:prefix "BASIC-STREAM-FLAG.")
1336  open-input
1337  open-output
1338  open-character
1339  open-binary
1340  file-stream)
1341
1342
1343(def-accessors (class-cell) %svref
1344  nil                                   ; 'class-cell
1345  class-cell-name
1346  class-cell-class
1347  class-cell-instantiate
1348  class-cell-extra                      ; wrapper in some cases
1349  )
1350
1351(defmacro make-class-cell (name) `(%istruct 'class-cell ,name nil '%make-instance nil))
1352
1353;;; Map between TYPE-SPECIFIERS and CTYPEs
1354(def-accessors (type-cell) %svref
1355  nil
1356  type-cell-type-specifier
1357  type-cell-ctype)
1358
1359(defmacro make-type-cell (specifier) `(%istruct 'type-cell ,specifier nil))
1360
1361;;; Map between package names and packages, sometimes.
1362(def-accessors (package-ref) %svref
1363  nil
1364  package-ref.name                      ; a string
1365  package-ref.pkg                       ; a package or NIL
1366  )
1367
1368(defmacro make-package-ref (name) `(%istruct 'package-ref (string ,name) nil))
1369
1370
1371(def-accessor-macros %svref
1372  nil                                 ; 'external-entry-point
1373  eep.address
1374  eep.name
1375  eep.container)
1376
1377(defmacro %cons-external-entry-point (name &optional container)
1378  `(%istruct 'external-entry-point nil ,name ,container))
1379
1380(def-accessor-macros %svref
1381    nil                                 ;'foreign-variable
1382  fv.addr                               ; a MACPTR, or nil
1383  fv.name                               ; a string
1384  fv.type                               ; a foreign type
1385  fv.container                          ; containing library
1386  )
1387
1388
1389(def-accessor-macros %svref
1390    nil                                 ;'shlib
1391  shlib.soname
1392  shlib.pathname
1393  shlib.handle                          ; if explicitly opened
1394  shlib.map
1395  shlib.base
1396  shlib.opencount)
1397
1398(defmacro %cons-shlib (soname pathname map base)
1399  `(%istruct 'shlib ,soname ,pathname nil ,map ,base 0))
1400
1401(def-accessors uvref ; %svref
1402    ()                                  ;'entry
1403  entry-test                          ;predicate function or count of higher priority others.
1404  entry-fn                            ;pprint function
1405  entry-full-spec                     ;list of priority and type specifier
1406  )
1407
1408;;; MacOS toolbox routines were once written mostly in Pascal, so some
1409;;; code still refers to callbacks from foreign code as "pascal-callable
1410;;; functions".
1411
1412; %Pascal-Functions% Entry
1413(def-accessor-macros %svref
1414  pfe.routine-descriptor
1415  pfe.proc-info
1416  pfe.lisp-function
1417  pfe.sym
1418  pfe.without-interrupts
1419  pfe.trace-p)
1420
1421(defmacro %cons-pfe (routine-descriptor proc-info lisp-function sym without-interrupts)
1422  `(vector ,routine-descriptor ,proc-info ,lisp-function ,sym ,without-interrupts nil))
1423
1424
1425(def-accessors %svref
1426    ()                                  ; 'xp-structure
1427  xp-base-stream ;;The stream io eventually goes to.
1428  xp-linel ;;The line length to use for formatting.
1429  xp-line-limit ;;If non-NIL the max number of lines to print.
1430  xp-line-no ;;number of next line to be printed.
1431  xp-char-mode ;;NIL :UP :DOWN :CAP0 :CAP1 :CAPW
1432  xp-char-mode-counter                  ;depth of nesting of ~(...~)
1433  xp-depth-in-blocks ;;Number of logical blocks at QRIGHT that
1434  ;;are started but not ended.             
1435  xp-block-stack 
1436  xp-block-stack-ptr
1437  ;;This stack is pushed and popped in accordance with the way blocks are
1438  ;;nested at the moment they are entered into the queue.  It contains the
1439  ;;following block specific value.
1440  ;;SECTION-START total position where the section (see AIM-1102)
1441  ;;that is rightmost in the queue started.
1442  xp-buffer
1443  xp-charpos
1444  xp-buffer-ptr 
1445  xp-buffer-offset
1446  ;;This is a vector of characters (eg a string) that builds up the
1447  ;;line images that will be printed out.  BUFFER-PTR is the
1448  ;;buffer position where the next character should be inserted in
1449  ;;the string.  CHARPOS is the output character position of the
1450  ;;first character in the buffer (non-zero only if a partial line
1451  ;;has been output).  BUFFER-OFFSET is used in computing total lengths.
1452  ;;It is changed to reflect all shifting and insertion of prefixes so that
1453  ;;total length computes things as they would be if they were
1454  ;;all on one line.  Positions are kept three different ways
1455  ;; Buffer position (eg BUFFER-PTR)
1456  ;; Line position (eg (+ BUFFER-PTR CHARPOS)).  Indentations are stored in this form.
1457  ;; Total position if all on one line (eg (+ BUFFER-PTR BUFFER-OFFSET))
1458  ;;  Positions are stored in this form.
1459  xp-queue
1460  xp-qleft
1461  xp-qright
1462  ;;This holds a queue of action descriptors.  QLEFT and QRIGHT
1463  ;;point to the next entry to dequeue and the last entry enqueued
1464  ;;respectively.  The queue is empty when
1465  ;;(> QLEFT QRIGHT).  The queue entries have several parts:
1466  ;;QTYPE one of :NEWLINE/:IND/:START-BLOCK/:END-BLOCK
1467  ;;QKIND :LINEAR/:MISER/:FILL/:MANDATORY or :UNCONDITIONAL/:FRESH
1468  ;; or :BLOCK/:CURRENT
1469  ;;QPOS total position corresponding to this entry
1470  ;;QDEPTH depth in blocks of this entry.
1471  ;;QEND offset to entry marking end of section this entry starts. (NIL until known.)
1472  ;; Only :start-block and non-literal :newline entries can start sections.
1473  ;;QOFFSET offset to :END-BLOCK for :START-BLOCK (NIL until known).
1474  ;;QARG for :IND indentation delta
1475  ;;     for :START-BLOCK suffix in the block if any.
1476  ;;                      or if per-line-prefix then cons of suffix and
1477  ;;                      per-line-prefix.
1478  ;;     for :END-BLOCK suffix for the block if any.
1479  xp-prefix
1480  ;;this stores the prefix that should be used at the start of the line
1481  xp-prefix-stack
1482  xp-prefix-stack-ptr
1483  ;;This stack is pushed and popped in accordance with the way blocks
1484  ;;are nested at the moment things are taken off the queue and printed.
1485  ;;It contains the following block specific values.
1486  ;;PREFIX-PTR current length of PREFIX.
1487  ;;SUFFIX-PTR current length of pending suffix
1488  ;;NON-BLANK-PREFIX-PTR current length of non-blank prefix.
1489  ;;INITIAL-PREFIX-PTR prefix-ptr at the start of this block.
1490  ;;SECTION-START-LINE line-no value at last non-literal break at this level.
1491  xp-suffix
1492  ;;this stores the suffixes that have to be printed to close of the current
1493  ;;open blocks.  For convenient in popping, the whole suffix
1494  ;;is stored in reverse order.
1495  xp-stream  ;;; the xp-stream containing this structure
1496  xp-string-stream ;; string-stream for output until first circularity (in case none)
1497  )
1498
1499(def-accessors (afunc) %svref
1500  ()                                    ; 'afunc
1501  afunc-acode
1502  afunc-parent
1503  afunc-vars
1504  afunc-inherited-vars
1505  afunc-blocks
1506  afunc-tags
1507  afunc-inner-functions
1508  afunc-name
1509  afunc-bits
1510  afunc-lfun
1511  afunc-environment
1512  afunc-lambdaform
1513  afunc-argsword
1514  afunc-ref-form
1515  afunc-warnings
1516  afunc-fn-refcount
1517  afunc-fn-downward-refcount
1518  afunc-all-vars
1519  afunc-callers
1520  afunc-vcells
1521  afunc-fcells
1522  afunc-fwd-refs
1523  afunc-lfun-info
1524  afunc-linkmap)
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.declarations-typecheck
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.last-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.