source: release/1.6/source/library/lispequ.lisp @ 14493

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

Improve CL:RANDOM.

The new generator is the MRG321k3p generator described in

  1. L'Ecuyer and R. Touzin, "Fast Combined Multiple Recursive

Generators with Multipliers of the form a = +/- 2d +/- 2e"",
Proceedings of the 2000 Winter Simulation Conference, Dec. 2000,
683--689.

It has a period of about 2185 and produces output of much higher
statistical quality than the previous generator.

Performance of the new generator should generally be comparable to that
of the old generator, despite the fact that the new generator does
a lot more work.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 55.3 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  static-cons                           ; static cons cells
1288  managed-static                        ; growable static area
1289  static                                ; static data in application
1290  dynamic                               ; dynmaic (heap) data in application
1291)
1292
1293;;; areas are sorted such that (in the "succ" direction) codes are >=.
1294;;; If you think that you're looking for a stack (instead of a heap), look
1295;;; in the "pred" direction from the all-areas header.
1296(defconstant max-stack-area-code area-tstack)
1297(defconstant min-heap-area-code area-readonly)
1298
1299
1300;;; Lisp threads, which barely need to exist and aren't worth burning
1301;;; a separate tag on ...
1302(def-accessors (lisp-thread) %svref
1303  nil                                   ;'lisp-thread
1304  lisp-thread.tcr
1305  lisp-thread.name
1306  lisp-thread.cs-size
1307  lisp-thread.vs-size
1308  lisp-thread.ts-size
1309  lisp-thread.initial-function.args
1310  lisp-thread.interrupt-functions
1311  lisp-thread.interrupt-lock
1312  lisp-thread.startup-function
1313  lisp-thread.state
1314  lisp-thread.state-change-lock
1315  )
1316
1317;;; "basic" (e.g., builtin, non-extensible) streams.
1318(def-accessors (basic-stream) %svref
1319  basic-stream.wrapper                  ; a class wrapper object
1320  basic-stream.flags                    ; fixnum; bits.
1321  basic-stream.state                    ; typically an ioblock
1322  basic-stream.info                     ; a plist for less-often-used things.
1323)
1324
1325(def-accessors (basic-file-stream) %svref
1326  basic-file-stream.class               ; a class object
1327  basic-file-stream.flags               ; fixnum; bits.
1328  basic-file-stream.state               ; typically an ioblock
1329  basic-file-stream.info                ; a plist for less-often-used things.
1330  basic-file-stream.filename
1331  basic-file-stream.actual-filename
1332  basic-file-stream.external-format
1333  )
1334
1335;;; Bits in basic-stream.flags
1336(defenum (:prefix "BASIC-STREAM-FLAG.")
1337  open-input
1338  open-output
1339  open-character
1340  open-binary
1341  file-stream)
1342
1343
1344(def-accessors (class-cell) %svref
1345  nil                                   ; 'class-cell
1346  class-cell-name
1347  class-cell-class
1348  class-cell-instantiate
1349  class-cell-extra                      ; wrapper in some cases
1350  )
1351
1352(defmacro make-class-cell (name) `(%istruct 'class-cell ,name nil '%make-instance nil))
1353
1354;;; Map between TYPE-SPECIFIERS and CTYPEs
1355(def-accessors (type-cell) %svref
1356  nil
1357  type-cell-type-specifier
1358  type-cell-ctype)
1359
1360(defmacro make-type-cell (specifier) `(%istruct 'type-cell ,specifier nil))
1361
1362;;; Map between package names and packages, sometimes.
1363(def-accessors (package-ref) %svref
1364  nil
1365  package-ref.name                      ; a string
1366  package-ref.pkg                       ; a package or NIL
1367  )
1368
1369(defmacro make-package-ref (name) `(%istruct 'package-ref (string ,name) nil))
1370
1371
1372(def-accessor-macros %svref
1373  nil                                 ; 'external-entry-point
1374  eep.address
1375  eep.name
1376  eep.container)
1377
1378(defmacro %cons-external-entry-point (name &optional container)
1379  `(%istruct 'external-entry-point nil ,name ,container))
1380
1381(def-accessor-macros %svref
1382    nil                                 ;'foreign-variable
1383  fv.addr                               ; a MACPTR, or nil
1384  fv.name                               ; a string
1385  fv.type                               ; a foreign type
1386  fv.container                          ; containing library
1387  )
1388
1389
1390(def-accessor-macros %svref
1391    nil                                 ;'shlib
1392  shlib.soname
1393  shlib.pathname
1394  shlib.handle                          ; if explicitly opened
1395  shlib.map
1396  shlib.base
1397  shlib.opencount)
1398
1399(defmacro %cons-shlib (soname pathname map base)
1400  `(%istruct 'shlib ,soname ,pathname nil ,map ,base 0))
1401
1402(def-accessors uvref ; %svref
1403    ()                                  ;'entry
1404  entry-test                          ;predicate function or count of higher priority others.
1405  entry-fn                            ;pprint function
1406  entry-full-spec                     ;list of priority and type specifier
1407  )
1408
1409;;; MacOS toolbox routines were once written mostly in Pascal, so some
1410;;; code still refers to callbacks from foreign code as "pascal-callable
1411;;; functions".
1412
1413; %Pascal-Functions% Entry
1414(def-accessor-macros %svref
1415  pfe.routine-descriptor
1416  pfe.proc-info
1417  pfe.lisp-function
1418  pfe.sym
1419  pfe.without-interrupts
1420  pfe.trace-p)
1421
1422(defmacro %cons-pfe (routine-descriptor proc-info lisp-function sym without-interrupts)
1423  `(vector ,routine-descriptor ,proc-info ,lisp-function ,sym ,without-interrupts nil))
1424
1425
1426(def-accessors %svref
1427    ()                                  ; 'xp-structure
1428  xp-base-stream ;;The stream io eventually goes to.
1429  xp-linel ;;The line length to use for formatting.
1430  xp-line-limit ;;If non-NIL the max number of lines to print.
1431  xp-line-no ;;number of next line to be printed.
1432  xp-char-mode ;;NIL :UP :DOWN :CAP0 :CAP1 :CAPW
1433  xp-char-mode-counter                  ;depth of nesting of ~(...~)
1434  xp-depth-in-blocks ;;Number of logical blocks at QRIGHT that
1435  ;;are started but not ended.             
1436  xp-block-stack 
1437  xp-block-stack-ptr
1438  ;;This stack is pushed and popped in accordance with the way blocks are
1439  ;;nested at the moment they are entered into the queue.  It contains the
1440  ;;following block specific value.
1441  ;;SECTION-START total position where the section (see AIM-1102)
1442  ;;that is rightmost in the queue started.
1443  xp-buffer
1444  xp-charpos
1445  xp-buffer-ptr 
1446  xp-buffer-offset
1447  ;;This is a vector of characters (eg a string) that builds up the
1448  ;;line images that will be printed out.  BUFFER-PTR is the
1449  ;;buffer position where the next character should be inserted in
1450  ;;the string.  CHARPOS is the output character position of the
1451  ;;first character in the buffer (non-zero only if a partial line
1452  ;;has been output).  BUFFER-OFFSET is used in computing total lengths.
1453  ;;It is changed to reflect all shifting and insertion of prefixes so that
1454  ;;total length computes things as they would be if they were
1455  ;;all on one line.  Positions are kept three different ways
1456  ;; Buffer position (eg BUFFER-PTR)
1457  ;; Line position (eg (+ BUFFER-PTR CHARPOS)).  Indentations are stored in this form.
1458  ;; Total position if all on one line (eg (+ BUFFER-PTR BUFFER-OFFSET))
1459  ;;  Positions are stored in this form.
1460  xp-queue
1461  xp-qleft
1462  xp-qright
1463  ;;This holds a queue of action descriptors.  QLEFT and QRIGHT
1464  ;;point to the next entry to dequeue and the last entry enqueued
1465  ;;respectively.  The queue is empty when
1466  ;;(> QLEFT QRIGHT).  The queue entries have several parts:
1467  ;;QTYPE one of :NEWLINE/:IND/:START-BLOCK/:END-BLOCK
1468  ;;QKIND :LINEAR/:MISER/:FILL/:MANDATORY or :UNCONDITIONAL/:FRESH
1469  ;; or :BLOCK/:CURRENT
1470  ;;QPOS total position corresponding to this entry
1471  ;;QDEPTH depth in blocks of this entry.
1472  ;;QEND offset to entry marking end of section this entry starts. (NIL until known.)
1473  ;; Only :start-block and non-literal :newline entries can start sections.
1474  ;;QOFFSET offset to :END-BLOCK for :START-BLOCK (NIL until known).
1475  ;;QARG for :IND indentation delta
1476  ;;     for :START-BLOCK suffix in the block if any.
1477  ;;                      or if per-line-prefix then cons of suffix and
1478  ;;                      per-line-prefix.
1479  ;;     for :END-BLOCK suffix for the block if any.
1480  xp-prefix
1481  ;;this stores the prefix that should be used at the start of the line
1482  xp-prefix-stack
1483  xp-prefix-stack-ptr
1484  ;;This stack is pushed and popped in accordance with the way blocks
1485  ;;are nested at the moment things are taken off the queue and printed.
1486  ;;It contains the following block specific values.
1487  ;;PREFIX-PTR current length of PREFIX.
1488  ;;SUFFIX-PTR current length of pending suffix
1489  ;;NON-BLANK-PREFIX-PTR current length of non-blank prefix.
1490  ;;INITIAL-PREFIX-PTR prefix-ptr at the start of this block.
1491  ;;SECTION-START-LINE line-no value at last non-literal break at this level.
1492  xp-suffix
1493  ;;this stores the suffixes that have to be printed to close of the current
1494  ;;open blocks.  For convenient in popping, the whole suffix
1495  ;;is stored in reverse order.
1496  xp-stream  ;;; the xp-stream containing this structure
1497  xp-string-stream ;; string-stream for output until first circularity (in case none)
1498  )
1499
1500(def-accessors (afunc) %svref
1501  ()                                    ; 'afunc
1502  afunc-acode
1503  afunc-parent
1504  afunc-vars
1505  afunc-inherited-vars
1506  afunc-blocks
1507  afunc-tags
1508  afunc-inner-functions
1509  afunc-name
1510  afunc-bits
1511  afunc-lfun
1512  afunc-environment
1513  afunc-lambdaform
1514  afunc-argsword
1515  afunc-ref-form
1516  afunc-warnings
1517  afunc-fn-refcount
1518  afunc-fn-downward-refcount
1519  afunc-all-vars
1520  afunc-callers
1521  afunc-vcells
1522  afunc-fcells
1523  afunc-fwd-refs
1524  afunc-lfun-info
1525  afunc-linkmap)
1526
1527(defmacro %make-afunc ()
1528  `(%istruct 'afunc
1529    nil                                 ;afunc-acode
1530    nil                                 ;afunc-parent
1531    nil                                 ;afunc-vars
1532    nil                                 ;afunc-inherited-vars
1533    nil                                 ;afunc-blocks
1534    nil                                 ;afunc-tags
1535    nil                                 ;afunc-inner-functions
1536    nil                                 ;afunc-name
1537    nil                                 ;afunc-bits
1538    nil                                 ;afunc-lfun
1539    nil                                 ;afunc-environment
1540    nil                                 ;afunc-lambdaform
1541    nil                                 ;afunc-argsword
1542    nil                                 ;afunc-ref-form
1543    nil                                 ;afunc-warnings
1544    nil                                 ;afunc-fn-refcount
1545    nil                                 ;afunc-fn-downward-refcount
1546    nil                                 ;afunc-all-vars
1547    nil                                 ;afunc-callers
1548    nil                                 ;afunc-vcells
1549    nil                                 ;afunc-fcells
1550    nil                                 ;afunc-fwd-refs
1551    nil                                 ;afunc-lfun-info
1552    nil                                 ;afunc-linkmap
1553    ))
1554
1555
1556(def-accessors (compiler-policy) uvref
1557  nil                                   ; 'compiler-policy
1558  policy.allow-tail-recursion-elimination
1559  policy.inhibit-register-allocation
1560  policy.trust-declarations
1561  policy.open-code-inline
1562  policy.inhibit-safety-checking
1563  policy.declarations-typecheck
1564  policy.inline-self-calls
1565  policy.allow-transforms
1566  policy.force-boundp-checks
1567  policy.allow-constant-substitution
1568  policy.misc)
1569
1570
1571(def-accessors (deferred-warnings) %svref
1572  nil
1573  deferred-warnings.parent
1574  deferred-warnings.warnings
1575  deferred-warnings.defs
1576  deferred-warnings.last-file
1577)
1578
1579;;; loader framework istruct
1580(def-accessors (faslapi) %svref
1581  ()
1582  ;; these represent all users of faslstate.iobuffer, .bufcount, and
1583  ;; .faslfd -- I think these are all the important file- and
1584  ;; buffer-IO-specific slots in faslstate; encapsulating these allows
1585  ;; sophisticated users to load fasl data from nonstandard sources
1586  ;; without too much trouble
1587  faslapi.fasl-open
1588  faslapi.fasl-close
1589  faslapi.fasl-init-buffer
1590  faslapi.fasl-set-file-pos
1591  faslapi.fasl-get-file-pos
1592  faslapi.fasl-read-buffer
1593  faslapi.fasl-read-byte
1594  faslapi.fasl-read-n-bytes)
1595
1596
1597(defmacro istruct-cell-name (cell)
1598  `(car ,cell))
1599
1600(defmacro istruct-cell-info (cell)
1601  `(cdr ,cell))
1602
1603(provide "LISPEQU")
1604
1605;;; End of lispequ.lisp
Note: See TracBrowser for help on using the repository browser.