Context Navigation

fasd.lisp @ 226

Revision 226, 16.6 KB (checked in by rjs, 22 months ago)
Initial versions.

Line
1	;FAST DUMPER (MACLISP MODEL) --LISP--
2
3	; (c) Copyright 1980 Massachusetts Institute of Technology
4
5	;READ LISPM;MACROS > IN BEFORE TRYING TO RUN THIS INTERPRETIVELY
6
7	(DECLARE (COND ((STATUS FEATURE LISPM))
8	((NULL (MEMQ 'NEWIO (STATUS FEATURES)))
9	(BREAK 'YOU-HAVE-TO-COMPILE-THIS-WITH-QCOMPL T))
10	((NULL (GET 'IF-FOR-MACLISP 'MACRO))
11	(LOAD '(MACROS > DSK LISPM))
12	(LOAD '(DEFMAC FASL DSK LISPM2))
13	(LOAD '(LMMAC > DSK LISPM2))
14	(MACROS T)))) ;SEND OVER THE REST OF THE MACROS IN THIS FILE
15
16	(DECLARE (FIXNUM (Q-CHAR-LENGTH NOTYPE)
17	(Q-CHAR-CHOMP NOTYPE)))
18
19	(DECLARE (SPECIAL ARRAY-ELEMENTS-PER-Q ARRAY-DIM-MULT ARRAY-TYPES
20	ARRAY-TYPE-SHIFT ARRAY-DISPLACED-BIT ARRAY-LEADER-BIT ARRAY-LONG-LENGTH-FLAG
21	%ARRAY-MAX-SHORT-INDEX-LENGTH))
22
23	(DECLARE (SPECIAL FASD-BUFFER-ARRAY FASD-FILE))
24
25	(DECLARE (SPECIAL FASD-TABLE FASD-GROUP-LENGTH FASL-TABLE-PARAMETERS))
26
27	(DECLARE (SPECIAL %FASL-GROUP-CHECK
28	%FASL-GROUP-FLAG %FASL-GROUP-LENGTH
29	FASL-GROUP-LENGTH-SHIFT %FASL-GROUP-TYPE
30	FASL-OP-ERR FASL-OP-INDEX FASL-OP-SYMBOL FASL-OP-PACKAGE-SYMBOL FASL-OP-LIST
31	FASL-OP-TEMP-LIST FASL-OP-FIXED FASL-OP-FLOAT
32	FASL-OP-ARRAY FASL-OP-EVAL FASL-OP-MOVE
33	FASL-OP-FRAME FASL-OP-ARRAY-PUSH FASL-OP-STOREIN-SYMBOL-VALUE
34	FASL-OP-STOREIN-FUNCTION-CELL FASL-OP-STOREIN-PROPERTY-CELL
35	FASL-OP-STOREIN-ARRAY-LEADER
36	FASL-OP-FETCH-SYMBOL-VALUE FASL-OP-FETCH-FUNCTION-CELL
37	FASL-OP-FETCH-PROPERTY-CELL FASL-OP-APPLY FASL-OP-END-OF-WHACK
38	FASL-OP-END-OF-FILE FASL-OP-SOAK FASL-OP-FUNCTION-HEADER FASL-OP-FUNCTION-END
39	FASL-OP-MAKE-MICRO-CODE-ENTRY FASL-OP-SAVE-ENTRY-POINT FASL-OP-MICRO-CODE-SYMBOL
40	FASL-OP-MICRO-TO-MICRO-LINK FASL-OP-MISC-ENTRY FASL-OP-QUOTE-POINTER FASL-OP-S-V-CELL
41	FASL-OP-FUNCELL FASL-OP-CONST-PAGE FASL-OP-SET-PARAMETER
42	FASL-OP-INITIALIZE-ARRAY FASL-OP-UNUSED FASL-OP-UNUSED1
43	FASL-OP-UNUSED2 FASL-OP-UNUSED3 FASL-OP-UNUSED4
44	FASL-OP-UNUSED5 FASL-OP-UNUSED6
45	FASL-OP-STRING FASL-OP-EVAL1
46	FASL-NIL FASL-EVALED-VALUE FASL-TEM1 FASL-TEM2 FASL-TEM3
47	FASL-SYMBOL-HEAD-AREA
48	FASL-SYMBOL-STRING-AREA FASL-OBARRAY-POINTER FASL-ARRAY-AREA
49	FASL-FRAME-AREA FASL-LIST-AREA FASL-TEMP-LIST-AREA
50	FASL-MICRO-CODE-EXIT-AREA
51	FASL-TABLE-WORKING-OFFSET ))
52
53	(DECLARE (FIXNUM (FASD-TABLE-ENTER NOTYPE NOTYPE))
54	(NOTYPE (FASD-START-GROUP NOTYPE FIXNUM FIXNUM)
55	(FASD-FIXED FIXNUM)
56	(FASD-INITIALIZE-ARRAY FIXNUM NOTYPE)
57	(FASD-INDEX FIXNUM)
58	(FASD-EVAL FIXNUM)
59	(FASD-NIBBLE FIXNUM)))
60
61	(DEFUN FASD-START-GROUP (FLAG LENGTH TYPE)
62	(PROG (OUT-LEN)
63	(SETQ FASD-GROUP-LENGTH LENGTH)
64	(SETQ OUT-LEN (LSH (COND ((>= LENGTH 377) 377)
65	(T LENGTH))
66	(- FASL-GROUP-LENGTH-SHIFT)))
67	(FASD-NIBBLE (+ %FASL-GROUP-CHECK
68	(+ (COND (FLAG %FASL-GROUP-FLAG) (T 0))
69	(+ OUT-LEN
70	TYPE))))
71	(AND (>= LENGTH 377)
72	(FASD-NIBBLE LENGTH))
73	(RETURN NIL)))
74
75	(DEFUN FASD-SYMBOL (SYM)
76	(COND ((GET SYM 'MAGIC-PACKAGE-FLAG)
77	(FASD-PACKAGE-SYMBOL (GET SYM 'MAGIC-PACKAGE-FLAG)))
78	(T (FASD-WRITE-SYMBOL SYM FASL-OP-SYMBOL))))
79
80	(DEFUN FASD-STRING (STRING) (FASD-WRITE-SYMBOL STRING FASL-OP-STRING))
81
82	(DEFUN FASD-WRITE-SYMBOL (SYM GROUP-TYPE)
83	(PROG (FASD-GROUP-LENGTH CHLIST C0 C1)
84	(DECLARE (FIXNUM C0 C1))
85	(SETQ CHLIST (EXPLODEN SYM))
86	(FASD-START-GROUP NIL (// (1+ (Q-CHAR-LENGTH CHLIST)) 2) GROUP-TYPE)
87	L (COND ((NULL CHLIST)
88	(RETURN NIL)))
89	; (SETQ C0 (CAR CHLIST))
90	; (SETQ C1 (COND ((CDR CHLIST) (CADR CHLIST))
91	; (T 200)))
92	; (COND ((AND (> C0 7)
93	; (< C0 16))
94	; (SETQ C0 (+ 200 C0))))
95	; (COND ((AND (> C1 7)
96	; (< C1 16))
97	; (SETQ C1 (+ 200 C1))))
98	(SETQ C0 (Q-CHAR-CHOMP CHLIST))
99	(SETQ C1 (COND ((NULL (SETQ CHLIST (Q-CHAR-ADVANCE CHLIST)))
100	200)
101	(T (Q-CHAR-CHOMP CHLIST))))
102	(FASD-NIBBLE (+ C0 (LSH C1 8)))
103	(SETQ CHLIST (Q-CHAR-ADVANCE CHLIST))
104	(GO L)))
105
106	;; For A:B:C, we are given the list (A B C).
107	(DEFUN FASD-PACKAGE-SYMBOL (LIST)
108	(FASD-START-GROUP NIL 1 FASL-OP-PACKAGE-SYMBOL)
109	(FASD-NIBBLE (LENGTH LIST))
110	(DO L LIST (CDR L) (NULL L)
111	(FASD-STRING (CAR L))
112	(FASD-TABLE-ENTER 'LIST (CAR L))))
113
114	(DEFUN FASD-CONSTANT (S-EXP)
115	(PROG (FASD-GROUP-LENGTH TEM BSIZE DOTP)
116	(COND ((SETQ TEM (FASD-TABLE-SEARCH 'LIST S-EXP))
117	(FASD-START-GROUP NIL 1 FASL-OP-INDEX)
118	(FASD-NIBBLE TEM)
119	(RETURN TEM))
120	((FIXP S-EXP) (FASD-FIXED S-EXP) (GO X))
121	((FLOATP S-EXP) (FASD-FLOAT S-EXP) (GO X))
122	((ATOM S-EXP) (FASD-SYMBOL S-EXP) (GO X))
123	((EQ (CAR S-EXP) 'PACKAGE)
124	(FASD-PACKAGE-SYMBOL (CDR S-EXP)) (GO X))
125	((EQ (CAR S-EXP) 'STRING)
126	(FASD-STRING (CADR S-EXP)) (GO X))
127	((EQ (CAR S-EXP) 'EXECUTION-CONTEXT-EVAL)
128	(FASD-EVAL1 (CDR S-EXP))))
129	(SETQ BSIZE (LENGTH-TERM-BY-ATOM S-EXP))
130	(SETQ TEM S-EXP)
131	(COND ((CDR (LAST-TERM-BY-ATOM S-EXP))
132	(SETQ BSIZE (1+ BSIZE))
133	(SETQ DOTP T)
134	(SETQ TEM (UNDOTIFY S-EXP))))
135	(FASD-START-GROUP DOTP 1 FASL-OP-LIST)
136	(FASD-NIBBLE BSIZE)
137	L (COND ((NULL TEM) (GO X)))
138	(FASD-CONSTANT (CAR TEM))
139	(SETQ TEM (CDR TEM))
140	(GO L)
141	X (RETURN (FASD-TABLE-ENTER 'LIST S-EXP))
142	))
143
144	(DEFUN FASD-FIXED (N)
145	(PROG (FASD-GROUP-LENGTH NMAG NLENGTH)
146	(SETQ NMAG (ABS N)
147	NLENGTH (// (+ (HAULONG NMAG) 15.) 16.))
148	(COND ((> (HAULONG NMAG) 64.)
149	(BARF N 'BIGNUM-TOO-LONG-FOR-FASD-FIXED 'WARN))) ;UNTIL NEW BYTE SPEC.
150	(FASD-START-GROUP (< N 0) NLENGTH FASL-OP-FIXED)
151	(DO ((POS (* 20 (1- NLENGTH)) (- POS 20))
152	(C NLENGTH (1- C)))
153	((ZEROP C))
154	(FASD-NIBBLE (LOGLDB (+ (LSH POS 6) 20) NMAG)))))
155
156	(DEFUN FASD-FLOAT (N)
157	(DECLARE (FLONUM N))
158	(PROG (FASD-GROUP-LENGTH EXP MANTISSA)
159	(SETQ MANTISSA (LOGAND (LSH N 0) 777777777)
160	EXP (LSH N -27.))
161	(COND ((MINUSP N)
162	(SETQ EXP (LOGAND (1- (- EXP)) 377)
163	MANTISSA (+ 1_28. MANTISSA))
164	;; THIS IS TO TAKE CARE OF THE -1/2 CASE WHICH IS DIFFERENT IN 10
165	(COND ((= MANTISSA 3_28.)
166	(SETQ EXP (1- EXP) MANTISSA 1_28.)))))
167	(COND ((NOT (ZEROP N))
168	(SETQ EXP (+ EXP 1600)))) ;CONVERSION FROM EXCESS 200 TO 2000
169	(FASD-START-GROUP NIL 3 FASL-OP-FLOAT)
170	(FASD-NIBBLE EXP)
171	(FASD-NIBBLE (LSH MANTISSA -12.))
172	(FASD-NIBBLE (LOGAND (LSH MANTISSA 3) 177777))))
173
174	(DEFUN FASD-MICRO-CODE-SYMBOL (SYM)
175	(PROG (FASD-GROUP-LENGTH TEM)
176	(FASD-START-GROUP NIL 1 FASL-OP-MICRO-CODE-SYMBOL)
177	(BREAK OBSOLETE T)))
178
179	(DEFUN FASD-MISC-ENTRY (SYM)
180	(PROG (FASD-GROUP-LENGTH TEM)
181	(FASD-START-GROUP NIL 1 FASL-OP-MICRO-CODE-SYMBOL)
182	(COND ((NULL (SETQ TEM (GET SYM 'QLVAL)))
183	(BARF SYM 'UNDEFINED-MISC-ENTRY 'BARF)))
184	(FASD-NIBBLE (- TEM 200)))) ;AREA STARTS WITH MISC-ENTRY 200
185
186	(DEFUN FASD-QUOTE-POINTER (S-EXP)
187	(PROG (FASD-GROUP-LENGTH)
188	(FASD-START-GROUP NIL 0 FASL-OP-QUOTE-POINTER)
189	(FASD-CONSTANT S-EXP)))
190
191	(DEFUN FASD-S-V-CELL (SYM)
192	(PROG (FASD-GROUP-LENGTH)
193	(FASD-START-GROUP NIL 0 FASL-OP-S-V-CELL)
194	(FASD-CONSTANT SYM)))
195
196	(DEFUN FASD-FUNCELL (SYM)
197	(PROG (FASD-GROUP-LENGTH)
198	(FASD-START-GROUP NIL 0 FASL-OP-FUNCELL)
199	(FASD-CONSTANT SYM)))
200
201	(DEFUN FASD-CONST-PAGE (CONST-PAGE-INDEX)
202	(PROG (FASD-GROUP-LENGTH)
203	(FASD-START-GROUP NIL 1 FASL-OP-CONST-PAGE)
204	(FASD-NIBBLE CONST-PAGE-INDEX)))
205
206	(DEFUN FASD-MICRO-TO-MICRO-LINK (SYM)
207	(PROG (FASD-GROUP-LENGTH)
208	(FASD-START-GROUP NIL 0 FASL-OP-MICRO-TO-MICRO-LINK)
209	(FASD-CONSTANT SYM)))
210
211	(DEFUN FASD-FUNCTION-HEADER (FCTN-NAME)
212	(PROG (FASD-GROUP-LENGTH)
213	(FASD-START-GROUP NIL 0 FASL-OP-FUNCTION-HEADER)
214	(FASD-CONSTANT FCTN-NAME)
215	(FASD-CONSTANT '0)))
216
217	(DEFUN FASD-SAVE-ENTRY-POINT (FCTN-NAME)
218	(PROG (FASD-GROUP-LENGTH)
219	(FASD-START-GROUP NIL 0 FASL-OP-SAVE-ENTRY-POINT)
220	(RETURN (FASD-TABLE-ENTER 'ENTRY-POINT FCTN-NAME))))
221
222	(DEFUN FASD-MAKE-MICRO-CODE-ENTRY (FCTN-NAME ARGDESC-ATOM ENTRY-FASL-INDEX)
223	(PROG (FASD-GROUP-LENGTH)
224	(FASD-START-GROUP NIL 1 FASL-OP-MAKE-MICRO-CODE-ENTRY)
225	(FASD-CONSTANT FCTN-NAME)
226	(FASD-CONSTANT ARGDESC-ATOM)
227	(FASD-NIBBLE ENTRY-FASL-INDEX)
228	(RETURN (FASD-TABLE-ENTER 'UENTRY-INDEX FCTN-NAME)) ))
229
230	(DEFUN FASD-FUNCTION-END NIL
231	(PROG (FASD-GROUP-LENGTH)
232	(FASD-START-GROUP NIL 0 FASL-OP-FUNCTION-END)))
233
234	(DEFUN FASD-END-WHACK NIL
235	(PROG () ;STARTING NEW WHACK SO LET FASD-GROUP-LENGTH GET
236	;SET TO 0
237	(FASD-START-GROUP NIL 0 FASL-OP-END-OF-WHACK)
238	(FASD-TABLE-INITIALIZE)))
239
240	(DEFUN FASD-END-OF-FILE NIL
241	(PROG (FASD-GROUP-LENGTH)
242	(FASD-START-GROUP NIL 0 FASL-OP-END-OF-FILE)))
243
244	(DEFUN FASD-END-FILE NIL
245	(PROG (FASD-GROUP-LENGTH)
246	(FASD-START-GROUP NIL 0 FASL-OP-END-OF-FILE)))
247
248	(DEFUN FASD-SET-PARAMETER (PARAM VAL)
249	(PROG (FASD-GROUP-LENGTH C-VAL)
250	(COND ((NULL (SETQ C-VAL (ASSQ PARAM FASD-TABLE)))
251	(BARF PARAM 'UNKNOWN-FASL-PARAMETER 'BARF)))
252	(COND ((EQUAL VAL (CDR C-VAL))(RETURN NIL)))
253	(FASD-START-GROUP NIL 0 FASL-OP-SET-PARAMETER)
254	(FASD-CONSTANT PARAM)
255	(FASD-CONSTANT VAL)
256	))
257
258	(DEFUN FASD-STOREIN-ARRAY-LEADER (ARRAY SUBSCR VALUE)
259	(PROG (FASD-GROUP-LENGTH)
260	(FASD-START-GROUP NIL 3 FASL-OP-STOREIN-ARRAY-LEADER)
261	(FASD-NIBBLE ARRAY)
262	(FASD-NIBBLE SUBSCR)
263	(FASD-NIBBLE VALUE)
264	(RETURN 0)))
265
266	(DEFUN FASD-STOREIN-FUNCTION-CELL (SYM IDX) ;IDX AN FASD-TABLE INDEX THAT HAS
267	(PROG (FASD-GROUP-LENGTH) ;STUFF DESIRED TO STORE.
268	(FASD-START-GROUP NIL 1 FASL-OP-STOREIN-FUNCTION-CELL)
269	(FASD-NIBBLE IDX)
270	(FASD-CONSTANT SYM)
271	(RETURN 0)))
272
273	(DEFUN FASD-STOREIN-SYMBOL-VALUE (SYM IDX)
274	(PROG (FASD-GROUP-LENGTH)
275	(FASD-START-GROUP NIL 1 FASL-OP-STOREIN-SYMBOL-VALUE)
276	(FASD-NIBBLE IDX)
277	(FASD-CONSTANT SYM)
278	(RETURN 0)))
279
280	(DEFUN FASD-STOREIN-PROPERTY-CELL (SYM IDX)
281	(PROG (FASD-GROUP-LENGTH)
282	(FASD-START-GROUP NIL 1 FASL-OP-STOREIN-PROPERTY-CELL)
283	(FASD-NIBBLE IDX)
284	(FASD-CONSTANT SYM)
285	(RETURN 0)))
286
287	(DEFUN FASD-INITIALIZE-ARRAY (IDX INIT)
288	(PROG (FASD-GROUP-LENGTH)
289	(FASD-START-GROUP NIL 0 FASL-OP-INITIALIZE-ARRAY)
290	(FASD-INDEX IDX)
291	(FASD-CONSTANT (LENGTH INIT))
292	L (COND ((NULL INIT) (RETURN 0)))
293	(FASD-CONSTANT (CAR INIT))
294	(SETQ INIT (CDR INIT))
295	(GO L)))
296
297	(DEFUN FASD-INDEX (IDX)
298	(FASD-START-GROUP NIL 1 FASL-OP-INDEX)
299	(FASD-NIBBLE IDX))
300
301	;(DEFUN FASD-MESA-FEF (STORAGE-LENGTH MAX-EXIT-VECTOR-USAGE MAX-IP-PDL-USAGE
302	; FCTN-NAME FAST-OPTION-Q)
303	; (PROG (FASD-GROUP-LENGTH)
304	; (FASD-START-GROUP NIL 3 FASL-OP-MESA-FEF)
305	; (FASD-NIBBLE STORAGE-LENGTH)
306	; (FASD-NIBBLE MAX-EXIT-VECTOR-USAGE)
307	; (FASD-NIBBLE MAX-IP-PDL-USAGE)
308	; (FASD-CONSTANT FCTN-NAME)
309	; (FASD-CONSTANT FAST-OPTION-Q)))
310	;
311	;(DEFUN FASD-MESA-INSTRUCTION (WD)
312	; (PROG (FASD-GROUP-LENGTH)
313	; (FASD-START-GROUP NIL 1 FASL-OP-MESA-INSTRUCTION)
314	; (FASD-NIBBLE WD)))
315	;
316	;(DEFUN FASD-MESA-FUNCELL-PLUGIN (SYM ARG-Q)
317	; (PROG (FASD-GROUP-LENGTH)
318	; (FASD-START-GROUP ARG-Q 0 FASL-OP-MESA-FUNCELL-PLUGIN)
319	; (FASD-CONSTANT SYM)
320	; (COND (ARG-Q (FASD-CONSTANT ARG-Q))) ))
321	;
322	;(DEFUN FASD-MESA-S-V-CELL-PLUGIN (SYM)
323	; (PROG (FASD-GROUP-LENGTH)
324	; (FASD-START-GROUP NIL 0 FASL-OP-MESA-S-V-CELL-PLUGIN)
325	; (FASD-CONSTANT SYM)))
326	;
327	;(DEFUN FASD-MESA-QUOTE-PLUGIN (S-EXP)
328	; (PROG (FASD-GROUP-LENGTH)
329	; (FASD-START-GROUP NIL 0 FASL-OP-MESA-QUOTE-PLUGIN)
330	; (FASD-CONSTANT S-EXP)))
331	;
332	;(DEFUN FASD-MESA-CONST-PAGE-PLUGIN (CONST-PAGE-INDEX)
333	; (PROG (FASD-GROUP-LENGTH)
334	; (FASD-START-GROUP NIL 1 FASL-OP-MESA-CONST-PAGE-PLUGIN)
335	; (FASD-NIBBLE CONST-PAGE-INDEX)))
336	;
337	;(DEFUN FASD-MESA-FUNCTION-END NIL
338	; (PROG (FASD-GROUP-LENGTH)
339	; (FASD-START-GROUP NIL 0 FASL-OP-MESA-FUNCTION-END)))
340
341	(DEFUN FASD-EVAL (IDX)
342	(PROG (FASD-GROUP-LENGTH)
343	(FASD-START-GROUP NIL 1 FASL-OP-EVAL)
344	(FASD-NIBBLE IDX)
345	(RETURN FASL-EVALED-VALUE)))
346
347	(DEFUN FASD-EVAL1 (SEXP)
348	(PROG (FASD-GROUP-LENGTH)
349	(FASD-START-GROUP NIL 0 FASL-OP-EVAL1)
350	(FASD-CONSTANT SEXP)
351	(RETURN (FASD-TABLE-ENTER 'EVALED-VALUE SEXP))))
352	;--
353
354	(DEFUN FASD-STORE-VALUE-IN-FUNCTION-CELL (SYM VAL)
355	(FASD-STOREIN-FUNCTION-CELL SYM (FASD-CONSTANT VAL)))
356
357	(DEFUN FASD-MAKE-ARRAY N
358	(COND ((OR (< N 5) (> N 6))
359	(ERROR '\|Wrong number of arguments to FASD-MAKE-ARRAY\| N)))
360	(LET ((FASD-GROUP-LENGTH 0))
361	(FASD-START-GROUP (> N 5) 0 FASL-OP-ARRAY)
362	(FASD-CONSTANT (ARG 1))
363	(FASD-CONSTANT (ARG 2))
364	(FASD-CONSTANT (ARG 3))
365	(FASD-CONSTANT (ARG 4))
366	(FASD-CONSTANT (ARG 5))
367	(FASD-CONSTANT NIL) ;INDEX OFFSET
368	(AND (> N 5) (FASD-CONSTANT (ARG 6)))
369	(FASD-TABLE-ENTER 'ARRAY-POINTER (GENSYM))))
370
371	(DEFUN UNDOTIFY (X)
372	(COND ((OR (ATOM X) (NULL (CDR X))) X)
373	((ATOM (CDR X)) (LIST (CAR X) (CDR X)))
374	(T (CONS (CAR X) (UNDOTIFY (CDR X))))))
375
376	(DEFUN FASD-TABLE-ENTER (TYPE DATA)
377	(PROG NIL
378	(NCONC FASD-TABLE (LIST (CONS TYPE DATA)))
379	(RETURN (1- (LENGTH FASD-TABLE)))))
380
381	(DEFUN FASD-TABLE-LENGTH () (LENGTH FASD-TABLE))
382
383	(DEFUN FASD-TABLE-SET (TYPE DATA)
384	(PROG (TEM)
385	(SETQ TEM FASD-TABLE)
386	L (COND ((NULL TEM) (BARF TYPE 'BAD-FASD-PARAMETER 'BARF))
387	((EQ (CAAR TEM) TYPE)
388	(RPLACD (CAR TEM) DATA)
389	(RETURN NIL)))
390	(SETQ TEM (CDR TEM))
391	(GO L)))
392
393	(DEFUN FASD-TABLE-LOOKUP (DATA) (FASD-TABLE-SEARCH 'LIST DATA))
394
395	(DEFUN FASD-TABLE-SEARCH (TYPE DATA)
396	(PROG (C TEM)
397	(AND (EQ TYPE 'LIST)
398	(NUMBERP DATA)
399	(RETURN NIL))
400	(SETQ C 0)
401	(SETQ TEM FASD-TABLE)
402	L (COND ((NULL TEM) (RETURN NIL))
403	((AND (EQ (CAAR TEM) TYPE)
404	(EQ (CDAR TEM) DATA))
405	(RETURN C)))
406	(SETQ C (1+ C))
407	(SETQ TEM (CDR TEM))
408	(GO L)))
409
410	(DEFUN FASD-INITIALIZE NIL
411	(FASD-TABLE-INITIALIZE))
412
413	(DEFUN FASD-TABLE-INITIALIZE NIL
414	(PROG (TEM)
415	(SETQ FASD-GROUP-LENGTH 0)
416	(SETQ FASD-TABLE NIL)
417	(SETQ TEM (REVERSE FASL-TABLE-PARAMETERS))
418	L1 (COND ((NOT (= (LENGTH TEM) FASL-TABLE-WORKING-OFFSET))
419	(SETQ TEM (CONS 'UNUSED TEM))
420	(GO L1)))
421	L (COND ((NULL TEM) (GO X)))
422	(SETQ FASD-TABLE (CONS (LIST (CAR TEM))
423	FASD-TABLE))
424	(SETQ TEM (CDR TEM))
425	(GO L)
426	X (FASD-TABLE-SET 'FASL-SYMBOL-HEAD-AREA 'NRSYM) ;SET THINGS UP LIKE
427	;INITIALIZE-FASL-TABLE DOES AT FASL TIME
428	(FASD-TABLE-SET 'FASL-SYMBOL-STRING-AREA 'P-N-STRING)
429	(FASD-TABLE-SET 'FASL-ARRAY-AREA 'USER-ARRAY-AREA)
430	(FASD-TABLE-SET 'FASL-FRAME-AREA 'MACRO-COMPILED-PROGRAM)
431	(FASD-TABLE-SET 'FASL-LIST-AREA 'USER-INITIAL-LIST-AREA)
432	(FASD-TABLE-SET 'FASL-TEMP-LIST-AREA 'FASL-TEMP-AREA)
433	(FASD-TABLE-SET 'FASL-MICRO-CODE-EXIT-AREA 'MICRO-CODE-EXIT-AREA)
434	(RETURN T)))
435
436	;DUMP A GROUP TO EVALUATE A GIVEN FORM AND RETURN ITS VALUE.
437	;IF OPTIMIZE IS SET, SETQ AND DEFUN ARE HANDLED SPECIALLY,
438	;IN A WAY APPROPRIATE FOR THE TOP LEVEL OF FASDUMP OR QC-FILE.
439	(DEFUN FASD-FORM (FORM OPTIMIZE)
440	(COND ((OR (MEMQ FORM '(T NIL))
441	(AND (NOT (ATOM FORM))
442	(MEMQ (CAR FORM) '(PACKAGE STRING)))
443	(NUMBERP FORM))
444	(FASD-CONSTANT FORM))
445	((ATOM FORM) (FASD-RANDOM-FORM FORM))
446	((EQ (CAR FORM) 'QUOTE)
447	(FASD-CONSTANT (CADR FORM)))
448	((NOT OPTIMIZE)
449	(FASD-RANDOM-FORM FORM))
450	((EQ (CAR FORM) 'SETQ)
451	(FASD-SETQ FORM))
452	((EQ (CAR FORM) 'DECLARE)
453	(MAPC (FUNCTION FASD-DECLARATION) (CDR FORM)))
454	(T (FASD-RANDOM-FORM FORM))))
455
456	(DEFUN FASD-DECLARATION (DCL)
457	(AND (MEMQ (CAR DCL) '(SPECIAL UNSPECIAL))
458	(FASD-FORM DCL NIL)))
459
460	;DUMP SOMETHING TO EVAL SOME RANDOM FORM (WHICH IS THE ARGUMENT).
461	(DEFUN FASD-RANDOM-FORM (FRM)
462	(FASD-EVAL (FASD-CONSTANT FRM)))
463
464	;This is an old name for the same thing as FASD-RANDOM-FORM.
465	(DEFUN FASDUMP-EVAL (LST)
466	(PROG (IDX)
467	(SETQ IDX (FASD-CONSTANT LST))
468	(RETURN (FASD-EVAL IDX))))
469
470	(DEFUN FASD-SETQ (FORM) (FASDUMP-SETQ (CDR FORM)))
471
472	(DEFUN FASDUMP-SETQ (PAIR-LIST)
473	(PROG (IDX)
474	L (COND ((NULL PAIR-LIST) (RETURN NIL))
475	((NOT (ATOM (CAR PAIR-LIST)))
476	(BARF (CAR PAIR-LIST) 'FASDUMP-SETQ 'DATA)
477	(GO E))
478	(T (SETQ IDX (FASD-FORM (CADR PAIR-LIST) NIL))))
479	(FASD-STOREIN-SYMBOL-VALUE (CAR PAIR-LIST) IDX)
480	E (SETQ PAIR-LIST (CDDR PAIR-LIST))
481	(GO L)))
482
483	;(DEFUN FASD-NIBBLE (X) (PRINT X))
484
485	(DEFUN FASD-NIBBLE (X)
486	(SETQ X (LOGAND 177777 X))
487	(LET ((TEM 0))
488	(DECLARE (FIXNUM TEM))
489	(STORE (ARRAYCALL FIXNUM FASD-BUFFER-ARRAY 0)
490	(COND ((MINUSP (SETQ TEM (ARRAYCALL FIXNUM FASD-BUFFER-ARRAY 0))) ;FIRST HALFWORD
491	X)
492	(T (OUT FASD-FILE ;SECOND HALFWORD
493	(LSH (+ (LSH TEM 16.) X) 4))
494	-1))))
495	NIL)
496
497	(DEFUN FASD-CLOSE (FINAL-NAME)
498	(AND (PLUSP (ARRAYCALL FIXNUM FASD-BUFFER-ARRAY 0))
499	(FASD-NIBBLE 0)) ;FORCE
500	(AND FINAL-NAME (RENAMEF FASD-FILE FINAL-NAME))
501	(CLOSE FASD-FILE))
502
503	(DEFUN FASD-OPEN (FILE)
504	(SETQ FILE (MERGEF '((* *) _QCMP_ OUTPUT) FILE))
505	(SETQ FASD-FILE (OPEN FILE '(OUT FIXNUM BLOCK)))
506	(OR (BOUNDP 'FASD-BUFFER-ARRAY)
507	(SETQ FASD-BUFFER-ARRAY (*ARRAY NIL 'FIXNUM 1))) ;TO AVOID NUMBER CONSING
508	(STORE (ARRAYCALL FIXNUM FASD-BUFFER-ARRAY 0) -1) ;RESET BUFFERED BACK HALFWORD
509	(FASD-NIBBLE 143150) ;MAGIC
510	(FASD-NIBBLE 71660) ;MORE MAGIC - SIXBIT/QFASL/
511	T)
512
513	(DEFUN FASDUMP-ARRAY (NAME AREA ARRAY-TYPE DIMLIST DISPLACED-P LEADER INITIALIZATION)
514	(PROG (IDX)
515	(COND ((EQUAL DIMLIST '(**)) (SETQ DIMLIST (LIST (LENGTH INITIALIZATION)))))
516	(SETQ IDX (FASD-MAKE-ARRAY AREA ARRAY-TYPE DIMLIST DISPLACED-P LEADER))
517	(COND ((ATOM NAME) (FASD-STOREIN-FUNCTION-CELL NAME IDX))
518	((AND (EQ (CAR NAME) 'VALUE-CELL)
519	(ATOM (CADR NAME)))
520	(FASD-STOREIN-SYMBOL-VALUE (CADR NAME) IDX))
521	(T (BARF NAME 'BAD-ARRAY-NAME 'WARN)))
522	(COND (INITIALIZATION (FASD-INITIALIZE-ARRAY IDX INITIALIZATION)))
523	))

Note: See TracBrowser for help on using the browser.

Download in other formats:

Original Format