source: release/1.9/source/library/lispequ.lisp @ 15706

Last change on this file since 15706 was 15606, checked in by gb, 6 years ago

This is a work-in-progress; there will need to be new binaries
and similar changes for other architectures.

compiler/nx2.lisp: do late constant-folding on comparisons. (This depends

on being able to use operators for T and NIL in the backend; since backends
don't necessarily support that, check first.)

compiler/optimizers.lisp: bind temporaries for 3-arg numeric comparisons.

compiler/vinsn.lisp: do dead-code elimination at the vinsn level. Because

of the way that "aligned labels" work on x86, introduce an :align vinsn
attribute. Add/change some utilities for finding next/previous vinsn, etc.

compiler/X86/x862.lisp: Handle operators for T/NIL. Peephole optimize

things like (if (let ...)) where the LET returns a constant value and
we need to discard some words from the stack.

compiler/X86/X8632/x8632-arch.lisp:
compiler/X86/X8664/x8664-arch.lisp: Bump image version

compiler/X86/X8632/x8632-vinsns.lisp:
compiler/X86/X8664/x8664-vinsns.lisp: EMIT-ALIGNED-LABEL has :align

attribute

level-0/l0-hash.lisp: Don't assume that GC maintains weak-deletions; do

assume that it maintains count/deleted-count, so lock-based code adjusts
those slots atomically.

level-0/l0-misc.lisp: We don't want to use futexes (at least not instead

of spinlocks.)

level-0/X86/x86-misc.lisp: %ATOMIC-INCF-NODE needs to pause while spinning.

(Note that a locked ADD may be faster on x86, but wouldn't return a
meaningful value and some callers expect it to.)

level-1/l1-clos-boot.lisp: no more DESTRUCTURE-STATE.
level-1/l1-files.lisp: indentation change
level-1/l1-utils.lisp: no more DESTRUCTURE-STATE.
level-1/linux-files.lisp: UNSETENV

lib/hash.lisp: no need to %NORMALIZE-HASH-TABLE-COUNT.
lib/macros.lisp: no more DESTRUCTURE-STATE.

library/lispequ.lisp: no more DESTRUCTURE-STATE.

lisp-kernel/gc-common.c: decrement count when removing weak key from

hash vector; increment deleted-count if not lock-free.

lisp-kernel/x86-constants32.h:
lisp-kernel/x86-constants64.h: bump current, max image versions

lisp-kernel/linuxx8632/Makefile:
lisp-kernel/linuxx8664/Makefile: don't define USE_FUTEX.

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