Context Navigation

source: branches/working-0711/ccl/library/lispequ.lisp @ 11836

Visit:

Last change on this file since 11836 was 11836, checked in by gz, 12 years ago
Typecheck new bindings in nx1-env-body, if nx-declarations-typecheck is true. Remove the typechecking from nx1-typed-var-initform since no longer needed. Remove some bogus declarations found by compiling the system with typechecking declarations.
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 55.1 KB

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

Note: See TracBrowser for help on using the repository browser.

Download in other formats: