Context Navigation

lmmac.lisp @ 247

Revision 247, 22.0 KB (checked in by rjs, 21 months ago)
Update.

Line
1	;; These are the macros in the Lisp Machine system. --LISP--
2	;; They used to be in LISPM;MACROS > but have been moved
3	;; for purposes of the cold load.
4
5	; (c) Copyright 1980 Massachusetts Institute of Technology
6
7	; Macros which do the equivalent of a displace MUST use DISPLACE
8	; to make sure that temporary area problems are worried about.
9
10	;The IF-IN-MACLISP/IF-IN-LISPM conditionals have to do with not breaking
11	;the Maclisp environment when compiling. The optimizers in COMPAT take
12	;over these functions when compiling in Maclisp.
13
14	(DECLARE (SETQ INHIBIT-STYLE-WARNINGS-SWITCH T)
15	(SPECIAL COMPILING-FOR-LISPM))
16
17	;THESE ARE CONDITIONAL ON WHICH SYSTEM IS EXECUTING THEM.
18	(DEFMACRO IF-IN-MACLISP (&REST FORMS)
19	(COND ((NOT (STATUS FEATURE LISPM))
20	`(PROGN 'COMPILE . ,FORMS))))
21
22	(DEFMACRO IF-IN-LISPM (&REST FORMS)
23	(COND ((STATUS FEATURE LISPM)
24	`(PROGN 'COMPILE . ,FORMS))))
25
26	;THESE ARE CONDITIONAL ON WHICH SYSTEM RESULT IS INTENDED "FOR ".
27	; THIS IS THE SAME AS WHICH SYSTEM IS "IN" EXCEPT IN THE CASE
28	; COMPILING IN MACLISP FOR LISPM (IE QCMP, AFTER COMPILER ITSELF HAS
29	; BEEN LOADED). THE COMPILING-FOR-LISPM SWITCH IS SET BY .LISP. (INIT)
30	; AFTER QCMP HAS BEEN LOADED.
31
32	(DEFMACRO IF-FOR-MACLISP (&REST FORMS)
33	(COND ((AND (NOT (STATUS FEATURE LISPM)) ;IN MACLISP
34	(OR (NOT (BOUNDP 'COMPILING-FOR-LISPM))
35	(NULL COMPILING-FOR-LISPM)))
36	`(PROGN 'COMPILE . ,FORMS))))
37
38	(DEFMACRO IF-FOR-LISPM (&REST FORMS)
39	(COND ((OR (STATUS FEATURE LISPM)
40	(AND (BOUNDP 'COMPILING-FOR-LISPM)
41	COMPILING-FOR-LISPM))
42	`(COMPILER-LET ((RUN-IN-MACLISP-SWITCH NIL))
43	(PROGN 'COMPILE . ,FORMS)))))
44
45	(DEFMACRO IF-FOR-MACLISP-ELSE-LISPM (MACLISP-FORM LISPM-FORM)
46	(COND ((NOT (STATUS FEATURE LISPM))
47	(COND ((OR (NOT (BOUNDP 'COMPILING-FOR-LISPM)) ;QCMP DEFINES THIS TO T
48	(NULL COMPILING-FOR-LISPM))
49	MACLISP-FORM)
50	(T `(COMPILER-LET ((RUN-IN-MACLISP-SWITCH NIL)) ,LISPM-FORM))))
51	;COMPLR DOESNT KNOW (OR CARE) ABOUT COMPILER-LET.
52	(T LISPM-FORM)))
53
54	;; Needed when conditionalizing something at top level with #Q or #M because
55	;; splicing readmacros flushed then. #Q and #M now work at top level, so this
56	;; is for compatibility only.
57	(DEFMACRO NULL-MACRO (FORM) FORM)
58
59	;These must appear before anything in this file that uses LET in order to win
60	; at cold-load readin time.
61	#Q (PROGN 'COMPILE ;Do not change this to IF-FOR-LISPM!! that would lose because it
62	; eventually expands into a LET.
63	;PUSH, POP, LET, LET* now exist in COMPLR and in ITS MacLisp. -cwh
64
65	(DEFMACRO-DISPLACE PUSH (ITEM LIST)
66	`(SETF ,LIST (CONS ,ITEM ,LIST)))
67
68	(DEFMACRO-DISPLACE POP (LIST &OPTIONAL DEST)
69	`(PROG1 ,(COND ((NULL DEST)
70	`(CAR ,LIST))
71	(T `(SETF ,DEST (CAR ,LIST))))
72	(SETF ,LIST (CDR ,LIST))))
73
74	; (LET ((VAR1 VAL1) (VAR2 VAL2) VAR3 ..) <BODY>)
75	; binds VAR1 to VAL1 and VAR2 to VAL2 and VAR3 to NIL.
76
77	(DEFMACRO-DISPLACE LET (VARLIST . BODY)
78	`((LAMBDA ,(MAPCAR '(LAMBDA (V) (COND ((ATOM V) V)
79	((CDDR V)
80	(FERROR NIL "~S extraneous in LET" V))
81	(T (CAR V))))
82	VARLIST)
83	. ,BODY)
84	. ,(MAPCAR '(LAMBDA (V) (COND ((ATOM V) NIL) (T (CADR V)))) VARLIST)))
85
86	; LET* is like LET except it binds sequentially instead of in parallel.
87
88	(DEFMACRO-DISPLACE LET* (VARLIST . BODY)
89	(DO ((L (REVERSE VARLIST) (CDR L))
90	(B BODY `(((LAMBDA (,(COND ((ATOM (CAR L)) (CAR L))
91	(T (CAAR L))))
92	. ,B)
93	,(COND ((ATOM (CAR L)) NIL)
94	(T (CADAR L)))))))
95	((NULL L)
96	(COND ((NULL (CDR B)) (CAR B))
97	(T `(PROGN . ,B))))))
98
99	)
100
101	(DEFMACRO-DISPLACE @DEFINE (&REST IGNORE) NIL)
102
103	(DEFSUBST FIRST (LIST) (CAR LIST))
104
105	(DEFSUBST SECOND (LIST) (CADR LIST))
106
107	(DEFSUBST THIRD (LIST) (CADDR LIST))
108
109	(DEFSUBST FOURTH (LIST) (CADDDR LIST))
110
111	(DEFSUBST FIFTH (LIST) (CAR (CDDDDR LIST)))
112
113	(DEFSUBST SIXTH (LIST) (CADR (CDDDDR LIST)))
114
115	(DEFSUBST SEVENTH (LIST) (CADDR (CDDDDR LIST)))
116
117	(DEFSUBST REST1 (LIST) (CDR LIST))
118
119	(DEFSUBST REST2 (LIST) (CDDR LIST))
120
121	(DEFSUBST REST3 (LIST) (CDDDR LIST))
122
123	(DEFSUBST REST4 (LIST) (CDDDDR LIST))
124
125	;; (<= A B) --> (NOT (> A B))
126	;; (<= A B C) --> (NOT (OR (> A B) (> B C)))
127	;; Funny arglist to check for correct number of arguments.
128
129	(DEFMACRO-DISPLACE <= (ARG1 ARG2 &REST REST &AUX RESULT)
130	(SETQ REST (LIST* ARG1 ARG2 REST))
131	(DO L REST (CDR L) (NULL (CDR L))
132	(PUSH `(> ,(CAR L) ,(CADR L)) RESULT))
133	(COND ((NULL (CDR RESULT)) `(NOT ,(CAR RESULT)))
134	(T `(NOT (OR . ,(NREVERSE RESULT))))))
135
136	;; (>= A B) --> (NOT (< A B))
137	;; (>= A B C) --> (NOT (OR (< A B) (< B C)))
138	;; Funny arglist to check for correct number of arguments.
139
140	(DEFMACRO-DISPLACE >= (ARG1 ARG2 &REST REST &AUX RESULT)
141	(SETQ REST (LIST* ARG1 ARG2 REST))
142	(DO L REST (CDR L) (NULL (CDR L))
143	(PUSH `(< ,(CAR L) ,(CADR L)) RESULT))
144	(COND ((NULL (CDR RESULT)) `(NOT ,(CAR RESULT)))
145	(T `(NOT (OR . ,(NREVERSE RESULT))))))
146
147	(DEFMACRO-DISPLACE / (ARG1 ARG2 &REST REST) `(<= ,ARG1 ,ARG2 . ,REST))
148
149	(DEFMACRO-DISPLACE / (ARG1 ARG2 &REST REST) `(>= ,ARG1 ,ARG2 . ,REST))
150
151	(DEFSUBST NEQ (X Y) (NOT (EQ X Y)))
152
153	(DEFSUBST / (X Y) (NOT (= X Y)))
154
155	(DEFSUBST BIT-TEST (BITS WORD)
156	(NOT (ZEROP (LOGAND BITS WORD))))
157
158	(DEFSUBST LDB-TEST (PPSS WORD)
159	(NOT (ZEROP (LDB PPSS WORD))))
160
161	(IF-IN-LISPM
162	(DEFMACRO-DISPLACE CATCH (BODY TAG)
163	`(*CATCH ',TAG ,BODY))
164	)
165
166	(IF-IN-LISPM
167	(DEFMACRO-DISPLACE THROW (BODY TAG)
168	`(*THROW ',TAG ,BODY))
169	)
170
171	(IF-IN-LISPM
172	(DEFMACRO-DISPLACE ERRSET (BODY &OPTIONAL (PRINTFLAG T))
173	`(LET ((EH:ERRSET-STATUS T)
174	(EH:ERRSET-PRINT-MSG ,PRINTFLAG))
175	(*CATCH 'EH:ERRSET-CATCH (LIST ,BODY))))
176	)
177	(IF-IN-LISPM
178	(DEFMACRO-DISPLACE ERR (&OPTIONAL VALUE-FORM FLAG)
179	(COND (FLAG (ERROR "ERR with two arguments is not implemented"))
180	((NULL VALUE-FORM) '(ERROR ""))
181	(T `(COND (EH:ERRSET-STATUS (*THROW 'EH:ERRSET-CATCH ,VALUE-FORM))
182	(T (ERROR ""))))))
183	)
184
185	(IF-IN-LISPM
186	(DEFMACRO-DISPLACE ARRAYCALL (IGNORE ARRAY &REST DIMS)
187	`(FUNCALL ,ARRAY . ,DIMS))
188	)
189
190	(DEFMACRO-DISPLACE SELECTQ (TEST-OBJECT . CLAUSES)
191	(LET (TEST-EXP COND-EXP)
192	(SETQ TEST-EXP
193	(COND ((OR (ATOM TEST-OBJECT)
194	(AND (MEMQ (CAR TEST-OBJECT) '(CAR CDR CAAR CADR CDAR CDDR))
195	(ATOM (CADR TEST-OBJECT))))
196	TEST-OBJECT)
197	(T 'SELECTQ-ITEM)))
198	(SETQ COND-EXP
199	(CONS 'COND
200	(MAPCAR (FUNCTION (LAMBDA (CLAUSE)
201	(COND ((OR (EQ (CAR CLAUSE) 'OTHERWISE)
202	(EQ (CAR CLAUSE) 'T)) ;Maclisp compatibility
203	(CONS T (CDR CLAUSE)))
204	((ATOM (CAR CLAUSE))
205	`((EQ ,TEST-EXP ',(CAR CLAUSE)) . ,(CDR CLAUSE)))
206	(T
207	`((MEMQ ,TEST-EXP ',(CAR CLAUSE)) . ,(CDR CLAUSE))))))
208	CLAUSES)))
209	(COND ((EQ TEST-EXP TEST-OBJECT) COND-EXP)
210	(T
211	`(LET ((SELECTQ-ITEM ,TEST-OBJECT))
212	,COND-EXP)))))
213
214	(DEFMACRO-DISPLACE SELECT (TEST-OBJECT . CLAUSES)
215	(LET (TEST-EXP COND-EXP)
216	(SETQ TEST-EXP
217	(COND ((OR (ATOM TEST-OBJECT)
218	(AND (MEMQ (CAR TEST-OBJECT) '(CAR CDR CAAR CADR CDAR CDDR))
219	(ATOM (CADR TEST-OBJECT))))
220	TEST-OBJECT)
221	(T 'SELECTQ-ITEM)))
222	(SETQ COND-EXP
223	(CONS 'COND
224	(MAPCAR (FUNCTION (LAMBDA (CLAUSE)
225	(COND ((OR (EQ (CAR CLAUSE) 'OTHERWISE)
226	(EQ (CAR CLAUSE) 'T)) ;Maclisp compatibility
227	(CONS T (CDR CLAUSE)))
228	((ATOM (CAR CLAUSE))
229	`((EQ ,TEST-EXP ,(CAR CLAUSE)) . ,(CDR CLAUSE)))
230	(T
231	`((OR . ,(MAPCAR (FUNCTION (LAMBDA (FORM)
232	`(EQ ,TEST-EXP ,FORM)))
233	(CAR CLAUSE)))
234	. ,(CDR CLAUSE))))))
235	CLAUSES)))
236	(COND ((EQ TEST-EXP TEST-OBJECT) COND-EXP)
237	(T
238	`(LET ((SELECTQ-ITEM ,TEST-OBJECT))
239	,COND-EXP)))))
240
241	(DEFMACRO-DISPLACE SELECTOR (TEST-OBJECT TEST-FUNCTION . CLAUSES)
242	(LET (TEST-EXP COND-EXP)
243	(SETQ TEST-EXP
244	(COND ((OR (ATOM TEST-OBJECT)
245	(AND (MEMQ (CAR TEST-OBJECT) '(CAR CDR CAAR CADR CDAR CDDR))
246	(ATOM (CADR TEST-OBJECT))))
247	TEST-OBJECT)
248	(T 'SELECTQ-ITEM)))
249	(SETQ COND-EXP
250	(CONS 'COND
251	(MAPCAR (FUNCTION (LAMBDA (CLAUSE)
252	(COND ((OR (EQ (CAR CLAUSE) 'OTHERWISE)
253	(EQ (CAR CLAUSE) 'T)) ;Maclisp compatibility
254	(CONS T (CDR CLAUSE)))
255	((ATOM (CAR CLAUSE))
256	`((,TEST-FUNCTION ,TEST-EXP ,(CAR CLAUSE)) . ,(CDR CLAUSE)))
257	(T
258	`((OR . ,(MAPCAR (FUNCTION (LAMBDA (FORM)
259	`(,TEST-FUNCTION ,TEST-EXP ,FORM)))
260	(CAR CLAUSE)))
261	. ,(CDR CLAUSE))))))
262	CLAUSES)))
263	(COND ((EQ TEST-EXP TEST-OBJECT) COND-EXP)
264	(T
265	`(LET ((SELECTQ-ITEM ,TEST-OBJECT))
266	,COND-EXP)))))
267
268	;EVENTUALLY THE MICRO COMPILER SHOULD BE AWARE OF THIS
269	(DEFMACRO-DISPLACE DISPATCH (PPSS WORD . BODY)
270	(LIST
271	(LIST
272	'LAMBDA
273	'(BYTE)
274	(CONS 'COND
275	(MAPCAR (FUNCTION (LAMBDA (CLAUSE)
276	(COND ((EQ (CAR CLAUSE) 'OTHERWISE)
277	(CONS T (CDR CLAUSE)))
278	((ATOM (CAR CLAUSE))
279	(CONS (LIST '= 'BYTE (CAR CLAUSE))
280	(CDR CLAUSE)))
281	(T
282	(CONS (CONS 'OR
283	(MAPCAR (FUNCTION (LAMBDA (ITEM)
284	(LIST '= 'BYTE ITEM)))
285	(CAR CLAUSE)))
286	(CDR CLAUSE))))))
287	BODY)))
288	(LIST 'LDB PPSS WORD)))
289
290	(DEFMACRO-DISPLACE EVERY (LIST PRED &OPTIONAL (STEP ''CDR))
291	`(DO ((L ,LIST (FUNCALL ,STEP L)))
292	((NULL L) T)
293	(OR (FUNCALL ,PRED (CAR L)) (RETURN NIL))))
294
295	(DEFMACRO-DISPLACE SOME (LIST PRED &OPTIONAL (STEP ''CDR))
296	`(DO ((L ,LIST (FUNCALL ,STEP L)))
297	((NULL L) NIL)
298	(AND (FUNCALL ,PRED (CAR L)) (RETURN L))))
299
300	;(BEGF FOO) and (ENDF FOO) delimit the definition of FOO, for EDFN.
301	(DEFMACRO-DISPLACE BEGF IGNORE '(DECLARE))
302
303	(DEFMACRO-DISPLACE ENDF IGNORE '(DECLARE))
304
305	; LET-GLOBALLY IS SIMILAR TO LET, EXCEPT THAT THE BINDING APPLIES
306	; TO THE WHOLE WORLD, NOT JUST THE CURRENTLY-EXECUTING STACK GROUP.
307	; FOR THE MOMENT, ANYWAY, IT IS IMPLEMENTED USING UNWIND-PROTECT.
308	(DEFMACRO-DISPLACE LET-GLOBALLY (VARLIST . BODY)
309	(LET ((VARS (MAPCAR '(LAMBDA (V) (COND ((ATOM V) V) (T (CAR V)))) VARLIST))
310	(VALS (MAPCAR '(LAMBDA (V) (COND ((ATOM V) NIL) (T (CADR V)))) VARLIST))
311	(GENVARS (MAPCAR '(LAMBDA (IGNORE) (GENSYM)) VARLIST)))
312	`(LET ,(MAPCAR 'LIST GENVARS VARS)
313	(UNWIND-PROTECT (PROGN (SETQ . ,(MAPCAN 'LIST VARS VALS))
314	. ,BODY)
315	(SETQ . ,(MAPCAN 'LIST VARS GENVARS))))))
316
317	;DEFUNP is like DEFUN but provides an implicit PROG.
318	;However, the value on falling off the end is the last thing in the body.
319
320	(DEFMACRO DEFUNP (FUNCTION ARGS &REST BODY
321	&AUX (DEFAULT-CONS-AREA WORKING-STORAGE-AREA)
322	(LAST NIL))
323	(SETQ BODY (APPEND BODY NIL))
324	(SETQ LAST (LAST BODY))
325	(COND ((OR (ATOM (CAR LAST)) (NOT (EQ 'RETURN (CAAR LAST))))
326	(RPLACA LAST (LIST 'RETURN (CAR LAST)))))
327	`(DEFUN ,FUNCTION ,ARGS
328	(PROG () . ,BODY)))
329
330	;This is a dummy DISPLACE for use in lisp-machine macros
331	;called in code being compiled on the PDP-10.
332	;If anyone starts wanting a real DISPLACE in QCMP
333	;(eg, for running interpretively part of QCMP
334	;which uses displacing macros)
335	;just flush this one and let the real one be used for this as well.
336	(IF-IN-MACLISP
337	(DEFUN DISPLACE (OLD NEW) NEW))
338
339	;(UNWIND-PROTECT risky-stuff forms-to-do-when-unwinding-this-frame)
340	;If risky-stuff returns, we return what it returns, doing forms-to-do
341	;(just as PROG1 would do). If risky-stuff does a throw, we let the throw
342	;function as specified, but make sure that forms-to-do get done as well.
343	;forms-to-do can refer to UNWIND-PROTECT-TAG, which is the tag if
344	;a throw is happening, or NIL if risky-stuff is just returning.
345	;UNWIND-PROTECT is an fsubr in Maclisp.
346	(PROGN 'COMPILE
347	#Q
348	(DEFMACRO-DISPLACE UNWIND-PROTECT (BODY . UNDO-FN)
349	`(MULTIPLE-VALUE-BIND (UNWIND-PROTECT-VALUE UNWIND-PROTECT-TAG
350	UNWIND-PROTECT-COUNT UNWIND-PROTECT-ACTION)
351	(*CATCH T ,BODY)
352	,@UNDO-FN
353	(AND UNWIND-PROTECT-TAG ;Continue whatever type of throw or unwind was happening
354	(*UNWIND-STACK UNWIND-PROTECT-TAG UNWIND-PROTECT-VALUE
355	UNWIND-PROTECT-COUNT UNWIND-PROTECT-ACTION))
356	UNWIND-PROTECT-VALUE))
357	)
358
359	(DEFMACRO-DISPLACE CATCH-ALL BODY
360	`(*CATCH NIL (PROGN . ,BODY)))
361
362	;(IF test then-action else-action)
363	(DEFMACRO-DISPLACE IF (TEST THEN &REST ELSES)
364	(COND ((NULL TEST) (AND ELSES `(PROGN . ,ELSES))) ;macros can generate this case...
365	((EQ TEST T) THEN) ;and this one (avoids compiler error msg)
366	(T `(COND (,TEST ,THEN) (T . ,(OR ELSES '(NIL)))))))
367
368	;;; (CHECK-ARG STRING STRINGP "a string") signals an error if STRING is not a string.
369	;;; The error signals condition :WRONG-TYPE-ARGUMENT with arguments
370	;;; which are STRINGP (the predicate), the value of STRING (the losing value),
371	;;; the name of the argument (STRING), and the string "a string".
372	;;; If you try to proceed and do not supply a valid string to replace it,
373	;;; the error happens again.
374	;;; The second form may be the name of a predicate function, or it may be a full
375	;;; predicate form, as in:
376	;;; (CHECK-ARG A (AND (NUMBERP A) (< A 10.) (> A 0.)) "a number from one to ten" ONE-TO-TEN)
377	;;; ONE-TO-TEN is a symbol for the "type" which the argument failed to be.
378	;;; It is used instead of the second argument (the predicate) when signalling the error,
379	;;; since the second argument is not a suitable symbol.
380	;;; The value returned by CHECK-ARG is the argument's (original or respecified) value.
381	;;; In general, the condition :WRONG-TYPE-ARGUMENT is signalled with arguments
382	;;; (1) A symbol for the desired type (NIL if not supplied)
383	;;; (2) The bad value
384	;;; (3) The name of the argument
385	;;; (4) A string for the desired type.
386	(DEFMACRO-DISPLACE CHECK-ARG (ARG-NAME PREDICATE TYPE-STRING &OPTIONAL ERROR-TYPE-NAME)
387	(AND (NULL ERROR-TYPE-NAME)
388	(SYMBOLP PREDICATE)
389	(SETQ ERROR-TYPE-NAME PREDICATE))
390	`(DO () (,(COND ((SYMBOLP PREDICATE)
391	`(,PREDICATE ,ARG-NAME))
392	(T PREDICATE))
393	,ARG-NAME)
394	(SETQ ,ARG-NAME
395	(CERROR T NIL ':WRONG-TYPE-ARGUMENT
396	"The argument ~2G~A was ~1G~S, which is not ~3G~A"
397	',ERROR-TYPE-NAME ,ARG-NAME ',ARG-NAME ',TYPE-STRING))))
398
399	;(KEYWORD-EXTRACT <keylist> KEY '(FOO (UGH BLETCH) BAR) '(FLAG FALG) <otherwise> ...)
400	;parses a TV-DEFINE-PC-PPR style list of alternating keywords and values, <keylist>.
401	;The symbol KEY is bound internally to the name of the next keyword to be tested.
402	;The keywords recognized are :FOO, :BAR and UGH; whatever follows
403	;the keyword UGH is put in the variable BLETCH, whatever follows the
404	;keyword :FOO is put in the variable FOO, and similar for BAR.
405	;The flags are :FLAG and :FALG; if :FLAG is seen, FLAG is set to T.
406	;<otherwise> is one or more SELECTQ clauses which can be used
407	;to recognize whatever else you like, in nonstandard format.
408	;To gobble the next thing from the <keylist>, say (CAR (SETQ KEY (CDR KEY))).
409	;Note that by default the actual keywords are in the user package and
410	;the variables are in the current package. Because of this, you
411	;cannot compile except on the real machine unless you restrict yourself
412	;to specifying the keywords and variables, both, as in (UGH BLETCH).
413	;That is ok, since code written any other way which put the keywords in
414	;the user package as it should would require colons and have the same problem.
415	(DEFMACRO-DISPLACE KEYWORD-EXTRACT (KEYLIST KEYVAR KEYWORDS &OPTIONAL FLAGS &REST OTHERWISE)
416	`(DO ((,KEYVAR ,KEYLIST (CDR ,KEYVAR)))
417	((NULL ,KEYVAR))
418	(SELECTQ (CAR ,KEYVAR)
419	,@(MAPCAR (FUNCTION (LAMBDA (KEYWORD)
420	(COND ((ATOM KEYWORD)
421	`(,(INTERN (STRING KEYWORD) "USER")
422	(SETQ ,KEYWORD (CAR (SETQ ,KEYVAR (CDR ,KEYVAR))))))
423	(T `(,(CAR KEYWORD)
424	(SETQ ,(CADR KEYWORD)
425	(CAR (SETQ ,KEYVAR (CDR ,KEYVAR)))))))))
426	KEYWORDS)
427	,@(MAPCAR (FUNCTION (LAMBDA (KEYWORD)
428	`(,(INTERN (STRING KEYWORD) "USER")
429	(SETQ ,KEYWORD T))))
430	FLAGS)
431	. ,OTHERWISE)))
432
433	;PSETQ looks like SETQ but does its work in parallel.
434	(DEFMACRO-DISPLACE PSETQ (&REST REST)
435	(COND ((CDDR REST)
436	;; Not the last pair.
437	;; Improve the efficiency of DO-stepping by detecting
438	;; that a variable is being set to its CDR or its 1+,
439	;; and doing all such variables last.
440	;; That makes it possible to do all of them with SETE-CDR.
441	(COND ((AND (LISTP (CADR REST))
442	(MEMQ (CAADR REST) '(1+ CDR))
443	(EQ (CADADR REST) (CAR REST)))
444	`(PROGN (PSETQ . ,(CDDR REST))
445	(SETQ ,(CAR REST) ,(CADR REST))))
446	;; Not set to its own 1+ or CDR; do it the general way.
447	(T
448	`(SETQ ,(CAR REST) (PROG1 ,(CADR REST) (PSETQ . ,(CDDR REST)))))))
449	;; The last pair. Keep it simple; no superfluous (PROG1 (SETQ...) (PSETQ)).
450	((CDR REST)
451	`(SETQ . ,REST))))
452
453	;For things which want to do a tail-recursive call, passing back multiple
454	;values. This does not work in the interpreter. This is a temporary measure
455	;and will go away when the calling protocol is changed to always pass back
456	;multiple values on "tail recursive" calls.
457	(DEFMACRO-DISPLACE MULTIPLE-VALUE-CALL ((FUNCTION . ARGS))
458	`(PROGN (%OPEN-CALL-BLOCK (FUNCTION ,FUNCTION) 0 4) ;No ADI, destination-return
459	(%ASSURE-PDL-ROOM ,(LENGTH ARGS))
460	,@(MAPCAR '(LAMBDA (A) `(%PUSH ,A)) ARGS)
461	(%ACTIVATE-OPEN-CALL-BLOCK)))
462
463	;(LOCAL-DECLARE ((SPECIAL FOO) (UNSPECIAL BAR)) code)
464	;declares FOO and BAR locally within <code>.
465	;LOCAL-DECLARE can also be used by macros to pass information down
466	;to other macros that expand inside the code they produce.
467	;The list of declarations (in this case, ((MUMBLE FOO BAR))) is appended
468	;onto the front of LOCAL-DECLARATIONS, which can be searched by
469	;macros expending inside of <code>.
470	(DEFMACRO-DISPLACE LOCAL-DECLARE (DECLARATIONS &REST BODY)
471	`(COMPILER-LET ((LOCAL-DECLARATIONS (APPEND ',DECLARATIONS LOCAL-DECLARATIONS)))
472	. ,BODY))
473
474	;INHIBIT-STYLE-WARNINGS inhibits compiler style checking of what is inside it.
475	;In the interpreter, it is a no-op.
476	(DEFMACRO-DISPLACE INHIBIT-STYLE-WARNINGS (BODY)
477	BODY)
478
479	;(ERROR-RESTART .... (CERROR ...) ...) causes a request by the user
480	;or error handler to "restart" after the error to re-execute all the
481	;code inside the ERROR-RESTART.
482	(DEFMACRO-DISPLACE ERROR-RESTART (&REST BODY)
483	`(PROG ()
484	LOOP
485	(*CATCH 'ERROR-RESTART (RETURN (PROGN . ,BODY)))
486	(GO LOOP)))
487
488	;(LET-CLOSED (variables as in LET) initializations ... (FUNCTION ..))
489	;binds the variables and executes the initialization,
490	;then returns the last thing in the body, closed over those variables.
491	(DEFMACRO-DISPLACE LET-CLOSED (VARS &REST BODY)
492	(LET ((VARNAMES (MAPCAR (FUNCTION (LAMBDA (V) (COND ((ATOM V) V) (T (CAR V))))) VARS)))
493	`(LOCAL-DECLARE ((SPECIAL . ,VARNAMES))
494	(LET ,VARS
495	(CLOSURE ',VARNAMES (PROGN . ,BODY))))))
496
497	;(DEF-OPEN-CODED FOO-COMPONENT (CURRY-AFTER AR-1 5))
498	;defines FOO-COMPONENT as an open-coded function with that definition.
499	(DEFMACRO DEF-OPEN-CODED (FUNCTION DEFINITION)
500	`(PROGN 'COMPILE
501	(EVAL-WHEN (COMPILE)
502	(PUSH '(OPEN-CODE ,FUNCTION ,DEFINITION) LOCAL-DECLARATIONS))
503	(FSET-CAREFULLY ',FUNCTION ',DEFINITION)
504	(DEFPROP ,FUNCTION T 'OPEN-CODE)))
505
506	;Say that FUNCTION should be open-coded by the compiler as DEFINITION
507	;without changing FUNCTION's real definition.
508	;A call to this OPEN-CODE can be used as a local declaration, too.
509	;Giving NIL as the definition turns off open-coding.
510	(DEFMACRO OPEN-CODE (FUNCTION DEFINITION)
511	`(PROGN 'COMPILE
512	(EVAL-WHEN (COMPILE)
513	(PUSH '(OPEN-CODE ,FUNCTION ,DEFINITION) LOCAL-DECLARATIONS))
514	(DEFPROP ,FUNCTION ,DEFINITION 'OPEN-CODE)))
515
516	;(DEFSUBST FOO (X) (AR-1 X 5)) is like a similar DEFUN
517	;except that the definition of FOO will be substituted in at compile time
518	;and FOO's argument variables eliminated by substitution.
519	;It is your responsibility to make sure that FOO's args
520	;are evaluated exactly once, in the right ordr, in FOO's body,
521	;and that the symbols used for the args do not appear except
522	;to represent the args.
523	(DEFMACRO DEFSUBST (FUNCTION LAMBDA-LIST . BODY)
524	(LET ((DEF1 `(SUBST ,LAMBDA-LIST . ,BODY)))
525	`(PROGN 'COMPILE
526	(EVAL-WHEN (COMPILE) (PUSH '(DEF ,FUNCTION . ,DEF1) LOCAL-DECLARATIONS))
527	(FSET-CAREFULLY ',FUNCTION ',DEF1))))
528
529	;Make a variable special and, optionally, initialize it.
530	;This is recorded as a definition by TAGS and ZWEI.
531	(DEFMACRO DEFVAR (VARIABLE &OPTIONAL (INITIAL-VALUE NIL INITIALIZE-P))
532	`(PROGN 'COMPILE
533	(SPECIAL ,VARIABLE)
534	(RECORD-SOURCE-FILE-NAME ',VARIABLE)
535	,(AND INITIALIZE-P
536	;Initialize in a way that works in the cold-load
537	;Don't evaluate INITIAL-VALUE unless used
538	`(SETQ-IF-UNBOUND ,VARIABLE ,INITIAL-VALUE))))
539
540	;Similar to DEFVAR, but if initialization given, always use it (not just if
541	;variable was previously unbound).
542	(DEFMACRO DEFCONST (VARIABLE &OPTIONAL (INITIAL-VALUE NIL INITIALIZE-P))
543	`(PROGN 'COMPILE
544	(SPECIAL ,VARIABLE)
545	(RECORD-SOURCE-FILE-NAME ',VARIABLE)
546	,(AND INITIALIZE-P
547	;Initialize in a way that works in the cold-load
548	;Don't evaluate INITIAL-VALUE unless used
549	`(SETQ ,VARIABLE ,INITIAL-VALUE))))
550
551	;Performs a sequence of operations while inhibiting scheduling
552	(DEFMACRO-DISPLACE WITHOUT-INTERRUPTS (&REST FORMS)
553	`(LET ((INHIBIT-SCHEDULING-FLAG T))
554	. ,FORMS))
555
556	;MAPC with a prog body instead of a function. <form> evaluates to a list,
557	;and <body> is executed with <var> bound to successive elements of the list.
558	(DEFMACRO-DISPLACE DOLIST ((VAR FORM) &REST BODY)
559	(LET ((DUMMY (GENSYM)))
560	`(DO ((,DUMMY ,FORM (CDR ,DUMMY))
561	(,VAR))
562	((NULL ,DUMMY))
563	(SETQ ,VAR (CAR ,DUMMY))
564	. ,BODY)))
565
566	;Repeat a number of times. <form> evaluates to the number of times,
567	;and <body> is executed with <var> bound to 0, 1, ...
568	;Don't generate dummy variable if <form> is an integer. We could also do this
569	;if <form> were a symbol, but the symbol may get clobbered inside the body,
570	;so the behavior of the macro would change.
571	(DEFMACRO-DISPLACE DOTIMES ((VAR FORM) &REST BODY &AUX DUMMY)
572	(COND ((FIXP FORM)
573	`(DO ((,VAR 0 (1+ ,VAR)))
574	(( ,VAR ,FORM))
575	. ,BODY))
576	(T (SETQ DUMMY (GENSYM))
577	`(DO ((,VAR 0 (1+ ,VAR))
578	(,DUMMY ,FORM))
579	(( ,VAR ,DUMMY))
580	. ,BODY))))
581
582	;Execute body with a file open. Abnormal exit aborts the file (if it's an output file).
583	(DEFMACRO-DISPLACE WITH-OPEN-FILE ((STREAM FILENAME OPTIONS) . BODY)
584	`(LET ((,STREAM NIL))
585	(UNWIND-PROTECT (PROGN (SETQ ,STREAM (OPEN ,FILENAME ,OPTIONS))
586	,@BODY
587	(FUNCALL ,STREAM ':CLOSE))
588	(AND ,STREAM (FUNCALL ,STREAM ':CLOSE ':ABORT)))))

Note: See TracBrowser for help on using the browser.

Download in other formats:

Original Format