[unix-history] / usr / lib / lisp / machacks.l

(setq |SCCS-machacks| "@(#)machacks.l	1.2	11/7/80")

;; machacks - maclisp compatibility package.
;; When this file is fasl'ed into a lisp, it will change the syntax to
;; maclisp's syntax and will define functions know to the standard maclisp.
;
; this file will be fasled whenever the -m switch is set for compilation.
;

(declare (macros t))

;-- macsyma-env 
; This really isn't part of the maclisp compatibility package but we put
; it here to allow us to bootstrap the macsyma macro packages.
;
(def macsyma-env		; put at the beginning of each macsyma file
  (macro (l) `(include |libmax//prelud.l|)))

(def coutput
  (lambda (msg)
	  (print msg)	; should go to unfasl port
	  (terpr)))

;--- displace 
; This is useful after a macro has been expanded and you want to save the
; interpreter the trouble of expanding the macro again.  
; [This is really only useful for interpretation]
(defun displace (old-form new-form)
       (cond ((atom old-form)
	      (error '|Not able to displace this form| old-form))
	     ((atom new-form)
	      (rplaca old-form 'progn)
	      (rplacd old-form (list new-form)))
	     (t (rplaca old-form (car new-form))
		(rplacd old-form (cdr new-form)))))

;--- caseq
; use is 
;    (caseq expr
;	    (match1 do1)
;	    (match2 do2)
;	    (t  doifallelsefails))
(def caseq
  (macro (form)
	   ((lambda (x)
		    `((lambda (,x)
			      (cond 
			       ,@(mapcar '(lambda (ff)
						  (cond ((eq (car ff) 't)
							 `(t ,(cadr ff)))
							(t `((eq ,x ',(car ff))
							     ,(cadr ff)))))
					 (cddr form))))
		      ,(cadr form)))
	    (gensym 'Z))))


;A winning macro to store things anywhere:  (stolen from AI:ALAN;LSPENV)
;(SETF (CADR X) 3) --> (RPLACA (CDR X) 3)

(DEFMACRO SETF (EXPR VAL)
	  (COND ((ATOM EXPR)
		 (OR (SYMBOLP EXPR) (ERROR '|-- SETF can't handle this.| EXPR))
		 `(SETQ ,EXPR ,VAL))
		(T
		 (DO ((Y)) (())
		     (OR (SYMBOLP (CAR EXPR))
			 (ERROR '|-- SETF can't handle this.| EXPR))
		     (AND (SETQ Y (GET (CAR EXPR) 'SETF-EXPAND))
			  (RETURN (FUNCALL Y EXPR VAL)))
		     (OR (SETQ Y (GET (CAR EXPR) 'MACRO))
			 (ERROR '|-- SETF can't handle this.| EXPR))
		     (SETQ EXPR (FUNCALL Y EXPR))))))

(DEFMACRO DEFSETF (NAME VARS &REST BODY)
	  `(DEFPROP ,NAME (LAMBDA ,VARS . ,BODY) SETF-EXPAND))

(DEFSETF CAR (E V) `(RPLACA ,(CADR E) ,V))
(DEFSETF CAAR (E V) `(RPLACA (CAR ,(CADR E)) ,V))
(DEFSETF CADR (E V) `(RPLACA (CDR ,(CADR E)) ,V))
(DEFSETF CAAAR (E V) `(RPLACA (CAAR ,(CADR E)) ,V))
(DEFSETF CADAR (E V) `(RPLACA (CDAR ,(CADR E)) ,V))
(DEFSETF CAADR (E V) `(RPLACA (CADR ,(CADR E)) ,V))
(DEFSETF CADDR (E V) `(RPLACA (CDDR ,(CADR E)) ,V))
(DEFSETF CAAAAR (E V) `(RPLACA (CAAAR ,(CADR E)) ,V))
(DEFSETF CADAAR (E V) `(RPLACA (CDAAR ,(CADR E)) ,V))
(DEFSETF CAADAR (E V) `(RPLACA (CADAR ,(CADR E)) ,V))
(DEFSETF CADDAR (E V) `(RPLACA (CDDAR ,(CADR E)) ,V))
(DEFSETF CAAADR (E V) `(RPLACA (CAADR ,(CADR E)) ,V))
(DEFSETF CADADR (E V) `(RPLACA (CDADR ,(CADR E)) ,V))
(DEFSETF CAADDR (E V) `(RPLACA (CADDR ,(CADR E)) ,V))
(DEFSETF CADDDR (E V) `(RPLACA (CDDDR ,(CADR E)) ,V))
(DEFSETF CDR (E V) `(RPLACD ,(CADR E) ,V))
(DEFSETF CDAR (E V) `(RPLACD (CAR ,(CADR E)) ,V))
(DEFSETF CDDR (E V) `(RPLACD (CDR ,(CADR E)) ,V))
(DEFSETF CDAAR (E V) `(RPLACD (CAAR ,(CADR E)) ,V))
(DEFSETF CDDAR (E V) `(RPLACD (CDAR ,(CADR E)) ,V))
(DEFSETF CDADR (E V) `(RPLACD (CADR ,(CADR E)) ,V))
(DEFSETF CDDDR (E V) `(RPLACD (CDDR ,(CADR E)) ,V))
(DEFSETF CDAAAR (E V) `(RPLACD (CAAAR ,(CADR E)) ,V))
(DEFSETF CDDAAR (E V) `(RPLACD (CDAAR ,(CADR E)) ,V))
(DEFSETF CDADAR (E V) `(RPLACD (CADAR ,(CADR E)) ,V))
(DEFSETF CDDDAR (E V) `(RPLACD (CDDAR ,(CADR E)) ,V))
(DEFSETF CDAADR (E V) `(RPLACD (CAADR ,(CADR E)) ,V))
(DEFSETF CDDADR (E V) `(RPLACD (CDADR ,(CADR E)) ,V))
(DEFSETF CDADDR (E V) `(RPLACD (CADDR ,(CADR E)) ,V))
(DEFSETF CDDDDR (E V) `(RPLACD (CDDDR ,(CADR E)) ,V))

(DEFSETF CXR (E V) `(RPLACX ,(CADR E) ,(CADDR E) ,V))

(DEFSETF NTH (E V) `(RPLACA (NTHCDR ,(CADR E) ,(CADDR E)) ,V))

(DEFSETF ARRAYCALL (E V) `(STORE ,E ,V))

(DEFSETF GET (E V) `(PUTPROP ,(CADR E) ,V ,(CADDR E)))

(DEFSETF PLIST (E V) `(SETPLIST ,(CADR E) ,V))

(DEFSETF SYMEVAL (E V) `(SET ,(CADR E) ,V))

(DEFSETF ARG (E V) `(SETARG ,(CADR E) ,V))

(DEFSETF ARGS (E V) `(ARGS ,(CADR E) ,V))

(DEFSETF SFA-GET (E V) `(SFA-STORE ,(CADR E) ,(CADDR E) ,V))

(DEFSETF EXAMINE (E V) `(DEPOSIT ,(CADR E) ,V))


(defmacro list* (&rest forms)
	  (cond ((null forms) nil)
		((null (cdr forms)) (car forms))
		(t (construct-list* forms))))
(defmacro ttf (&rest l) `(list* . , l))


(defun construct-list* (forms)
       (setq forms (reverse forms))
       (do ((forms (cddr forms) (cdr forms))
	    (return-form `(cons ,(cadr forms) ,(car forms))
			 `(cons ,(car forms) ,return-form)))
	   ((null forms) return-form))) 

;; lexpr-funcall is a cross between apply and funcall.  The last arguments
;; is a list of the rest of the arguments
(defmacro lexpr-funcall (func &rest args)
  `(apply ,func (list* ,@args)))

; contents of the file libmax;macros  all of these functions are
; (by default) in maclisp
;; (IF X P Q1 Q2 ...) --> (COND (X P) (T Q1 Q2 ...))
;; It is important that (IF NIL <FORM>) returns NIL as Macsyma code depends
;; upon this in places.  See also IFN in LIBMAX;MAXMAC.

(DEFMACRO IF (PREDICATE THEN &REST ELSE)
	  (COND ((NULL ELSE) `(COND (,PREDICATE ,THEN)))
		(T `(COND (,PREDICATE ,THEN) (T . ,ELSE)))))

;; LET, LET*, LIST* are now a part of Multics Lisp.  Nobody should miss
;; the code commented out below.
;; (LET ((A 3) (B) C) STUFF) --> ((LAMBDA (A B C) STUFF) 3 NIL NIL)
;; (LET* ((A 3) (B 4)) STUFF) --> ((LAMBDA (A) ((LAMBDA (B) STUFF) 4)) 3)

;; (PUSH X S) --> (SETQ S (CONS X S))

(DEFMACRO PUSH (OBJECT LIST) `(SETF ,LIST (CONS ,OBJECT ,LIST)))

;; (POP S) -->   (PROG1 (CAR S) (SETF S (CDR S)))
;; (POP S V) --> (PROG1 (SETF V (CAR S)) (SETF S (CDR S)))
;; This relies on the fact that SETF returns the value stored.

(DEFMACRO POP (LIST &OPTIONAL (INTO NIL INTO-P))
  (COND (INTO-P `(PROG1 (SETF ,INTO (CAR ,LIST))
                        (SETF ,LIST (CDR ,LIST))))
        (T `(PROG1 (CAR ,LIST)
                   (SETF ,LIST (CDR ,LIST))))))

;; (FOR I m n . BODY) will evaluate BODY with I bound to m,m+1,...,n-1
;; sequentially.  (FOR I 0 n . BODY) --> (DOTIMES (I n) . BODY)

(DEFMACRO FOR (VAR START STOP . BODY)
          `(DO ,VAR ,START (1+ ,VAR) (= ,VAR ,STOP) ,@BODY))

(DEFMACRO EVENP (X) `(NOT (ODDP ,X)))

; these were grabbed from lspsrc;umlmac.5
(DEFMACRO WHEN (P . C) `(COND (,P . ,C)))
(DEFMACRO UNLESS (P . C) `(COND ((NOT ,P) . ,C)))
(defmacro DOLIST ((var form index) &rest body &aux (dummy (gensym)) decls)
   (setq decls (cond ((and body 
			   (not (atom (car body)))
			   (eq (caar body) 'DECLARE))
		      (prog2 () (cdar body) (pop body)))))
   (cond (index (setq index (ncons `(,INDEX 0 (1+ ,INDEX)) ))
		(push `(FIXNUM ,INDEX) decls)))
   (and decls (setq decls  (ncons `(DECLARE ,.decls))))
   `(DO ((,DUMMY ,FORM (CDR ,DUMMY)) (,VAR) ,.index )
	((NULL ,DUMMY))
      ,@decls
      (SETQ ,VAR (CAR ,DUMMY))  ,.BODY))

;Repeat a number of times.  <count> evaluates to the number of times,
;and <body> is executed with <var> bound to 0, 1, ...
;Don't generate dummy variable if <count> is an integer.  We could also do this
;if <count> were a symbol, but the symbol may get clobbered inside the body,
;so the behavior of the macro would change.

(DEFMACRO DOTIMES (SPEC &REST BODY)
  (LET (VAR COUNT DUMMY DECLS)
       (SETQ DECLS `(DECLARE 
		     (FIXNUM ,var )	;LOOP VARIABLE TO BE FILLED IN HERE
		     ,.(cond ((and body 
				   (not (atom (car body)))
				   (eq (caar body) 'DECLARE))
			      (prog2 () (cdar body) (pop body))))))
       (COND ((ATOM SPEC) (SETQ VAR (GENSYM) COUNT SPEC)) 
	     ('T (DESETQ (VAR COUNT) SPEC)
		 (COND ((NULL VAR) (SETQ VAR (GENSYM))))
		 (COND ((NOT (FIXP COUNT))
			(SETQ DUMMY `((,(gensym) ,count))
			      COUNT (CAAR DUMMY))))))
       (SETF (CADADR DECLS) VAR)
       `(DO ((,var 0 (1+ ,var)) ,.dummy)
	    ((NOT (< ,var ,count)))
	  ,decls
	  ,.body)))


;; The following is NOT courtesy AI: LISPM2; LMMAC 118
;; Theirs is buggy!
;; PSETQ looks like SETQ but does its work in parallel.
(DEFMACRO PSETQ (&REST REST)
     (COND ((CDDR REST)
	    `(SETQ ,(CAR REST)
		   (PROG1 ,(CADR REST) (PSETQ . ,(CDDR REST)))))
           ;; The last pair.  Keep it simple;  no superfluous
	   ;; (PROG1 (SETQ...) (PSETQ)).
	   ((CDR REST) `(SETQ . ,REST))
	   (T (error '|Odd number of args to PSETQ| rest 'wrng-no-args))))


(defmacro if-for-maclisp-else-lispm (&rest ll) (car ll))

(PROGN 'COMPILE
	       (DEFMACRO LOGAND (&REST FORMS) `(BOOLE 1 . ,FORMS))
	       (DEFMACRO LOGIOR (&REST FORMS) `(BOOLE 7 . ,FORMS))
	       (DEFMACRO LOGXOR (&REST FORMS) `(BOOLE 6 . ,FORMS))
	       )

(DEFMACRO DEFVAR (VARIABLE &OPTIONAL (INITIAL-VALUE NIL IV-P) DOCUMENTATION)
  DOCUMENTATION ;; Ignored for now.
  (IF IV-P `(PROGN 'COMPILE
		   (DECLARE (SPECIAL ,VARIABLE))
		   (OR (BOUNDP ',VARIABLE) (SETQ ,VARIABLE ,INITIAL-VALUE)))
      `(DECLARE (SPECIAL ,VARIABLE))))

(DEFMACRO PSETQ (VAR VALUE . REST)
	  (COND (REST `(SETQ ,VAR (PROG1 ,VALUE (PSETQ . ,REST))))
		(T `(SETQ ,VAR ,VALUE))))

 
;; (DOTIMES (I N) BODY) evaluates BODY N times, with I bound to 0, 1, ..., N-1.
;; (DOLIST (X L) BODY) successively binds X to the elements of L, and evaluates
;; BODY each time.

;; Things to beware of:
;; [1] This won't work for COUNT being a bignum.
;; [2] If COUNT is a symbol, somebody could clobber its value inside the body.
;; [3] Somebody inside of BODY could reference **COUNT**.

(DEFMACRO DOTIMES ((VAR COUNT) . BODY)
  (IF (OR (FIXP COUNT) (SYMBOLP COUNT))
      `(DO ((,VAR 0 (1+ ,VAR)))
	   ((>= ,VAR ,COUNT))
	   (DECLARE (FIXNUM ,VAR))
	   . ,BODY)
      `(DO ((,VAR 0 (1+ ,VAR))
	    (**COUNT** ,COUNT))
	   ((>= ,VAR **COUNT**))
	   (DECLARE (FIXNUM ,VAR **COUNT**))
	   . ,BODY)))

(DEFMACRO DOLIST ((VAR LIST) . BODY)
  `(DO ((**LIST** ,LIST (CDR **LIST**))
	(,VAR))
       ((NULL **LIST**))
       (SETQ ,VAR (CAR **LIST**))
       . ,BODY))

;; CASE is apparently missing from ITS MacLisp.
;; (DEFMACRO SELECT (KEY . FORMS)
;; 	  (SETQ FORMS
;; 		(MAPCAR #'(LAMBDA (FORM) (IF (EQ (CAR FORM) 'OTHERWISE)
;; 					     (CONS T (CDR FORM)) FORM))
;; 			FORMS))
;; 	  `(CASE ,KEY . ,FORMS))

(DEFMACRO SELECTQ (KEY . FORMS)
	  (SETQ FORMS
		(MAPCAR '(LAMBDA (FORM) (IF (EQ (CAR FORM) 'OTHERWISE)
					     (CONS T (CDR FORM)) FORM))
			FORMS))
	  `(CASEQ ,KEY . ,FORMS))
Commit	Line	Data
31cef89c BJ	1	(setq \|SCCS-machacks\| "@(#)machacks.l 1.2 11/7/80")
	2
	3	;; machacks - maclisp compatibility package.
	4	;; When this file is fasl'ed into a lisp, it will change the syntax to
	5	;; maclisp's syntax and will define functions know to the standard maclisp.
	6	;
	7	; this file will be fasled whenever the -m switch is set for compilation.
	8	;
	9
	10	(declare (macros t))
	11
	12	;-- macsyma-env
	13	; This really isn't part of the maclisp compatibility package but we put
	14	; it here to allow us to bootstrap the macsyma macro packages.
	15	;
	16	(def macsyma-env ; put at the beginning of each macsyma file
	17	(macro (l) `(include \|libmax//prelud.l\|)))
	18
	19	(def coutput
	20	(lambda (msg)
	21	(print msg) ; should go to unfasl port
	22	(terpr)))
	23
	24	;--- displace
	25	; This is useful after a macro has been expanded and you want to save the
	26	; interpreter the trouble of expanding the macro again.
	27	; [This is really only useful for interpretation]
	28	(defun displace (old-form new-form)
	29	(cond ((atom old-form)
	30	(error '\|Not able to displace this form\| old-form))
	31	((atom new-form)
	32	(rplaca old-form 'progn)
	33	(rplacd old-form (list new-form)))
	34	(t (rplaca old-form (car new-form))
	35	(rplacd old-form (cdr new-form)))))
	36
	37	;--- caseq
	38	; use is
	39	; (caseq expr
	40	; (match1 do1)
	41	; (match2 do2)
	42	; (t doifallelsefails))
	43	(def caseq
	44	(macro (form)
	45	((lambda (x)
	46	`((lambda (,x)
	47	(cond
	48	,@(mapcar '(lambda (ff)
	49	(cond ((eq (car ff) 't)
	50	`(t ,(cadr ff)))
	51	(t `((eq ,x ',(car ff))
	52	,(cadr ff)))))
	53	(cddr form))))
	54	,(cadr form)))
	55	(gensym 'Z))))
	56
	57
	58
	59	;A winning macro to store things anywhere: (stolen from AI:ALAN;LSPENV)
	60	;(SETF (CADR X) 3) --> (RPLACA (CDR X) 3)
	61
	62	(DEFMACRO SETF (EXPR VAL)
	63	(COND ((ATOM EXPR)
	64	(OR (SYMBOLP EXPR) (ERROR '\|-- SETF can't handle this.\| EXPR))
65	`(SETQ ,EXPR ,VAL))
66	(T
67	(DO ((Y)) (())
68	(OR (SYMBOLP (CAR EXPR))
69	(ERROR '\|-- SETF can't handle this.\| EXPR))
70	(AND (SETQ Y (GET (CAR EXPR) 'SETF-EXPAND))
71	(RETURN (FUNCALL Y EXPR VAL)))
72	(OR (SETQ Y (GET (CAR EXPR) 'MACRO))
73	(ERROR '\|-- SETF can't handle this.\| EXPR))
74	(SETQ EXPR (FUNCALL Y EXPR))))))
75
76	(DEFMACRO DEFSETF (NAME VARS &REST BODY)
77	`(DEFPROP ,NAME (LAMBDA ,VARS . ,BODY) SETF-EXPAND))
78
79	(DEFSETF CAR (E V) `(RPLACA ,(CADR E) ,V))
80	(DEFSETF CAAR (E V) `(RPLACA (CAR ,(CADR E)) ,V))
81	(DEFSETF CADR (E V) `(RPLACA (CDR ,(CADR E)) ,V))
82	(DEFSETF CAAAR (E V) `(RPLACA (CAAR ,(CADR E)) ,V))
83	(DEFSETF CADAR (E V) `(RPLACA (CDAR ,(CADR E)) ,V))
84	(DEFSETF CAADR (E V) `(RPLACA (CADR ,(CADR E)) ,V))
85	(DEFSETF CADDR (E V) `(RPLACA (CDDR ,(CADR E)) ,V))
86	(DEFSETF CAAAAR (E V) `(RPLACA (CAAAR ,(CADR E)) ,V))
87	(DEFSETF CADAAR (E V) `(RPLACA (CDAAR ,(CADR E)) ,V))
88	(DEFSETF CAADAR (E V) `(RPLACA (CADAR ,(CADR E)) ,V))
89	(DEFSETF CADDAR (E V) `(RPLACA (CDDAR ,(CADR E)) ,V))
90	(DEFSETF CAAADR (E V) `(RPLACA (CAADR ,(CADR E)) ,V))
91	(DEFSETF CADADR (E V) `(RPLACA (CDADR ,(CADR E)) ,V))
92	(DEFSETF CAADDR (E V) `(RPLACA (CADDR ,(CADR E)) ,V))
93	(DEFSETF CADDDR (E V) `(RPLACA (CDDDR ,(CADR E)) ,V))
94	(DEFSETF CDR (E V) `(RPLACD ,(CADR E) ,V))
95	(DEFSETF CDAR (E V) `(RPLACD (CAR ,(CADR E)) ,V))
96	(DEFSETF CDDR (E V) `(RPLACD (CDR ,(CADR E)) ,V))
97	(DEFSETF CDAAR (E V) `(RPLACD (CAAR ,(CADR E)) ,V))
98	(DEFSETF CDDAR (E V) `(RPLACD (CDAR ,(CADR E)) ,V))
99	(DEFSETF CDADR (E V) `(RPLACD (CADR ,(CADR E)) ,V))
100	(DEFSETF CDDDR (E V) `(RPLACD (CDDR ,(CADR E)) ,V))
101	(DEFSETF CDAAAR (E V) `(RPLACD (CAAAR ,(CADR E)) ,V))
102	(DEFSETF CDDAAR (E V) `(RPLACD (CDAAR ,(CADR E)) ,V))
103	(DEFSETF CDADAR (E V) `(RPLACD (CADAR ,(CADR E)) ,V))
104	(DEFSETF CDDDAR (E V) `(RPLACD (CDDAR ,(CADR E)) ,V))
105	(DEFSETF CDAADR (E V) `(RPLACD (CAADR ,(CADR E)) ,V))
106	(DEFSETF CDDADR (E V) `(RPLACD (CDADR ,(CADR E)) ,V))
107	(DEFSETF CDADDR (E V) `(RPLACD (CADDR ,(CADR E)) ,V))
108	(DEFSETF CDDDDR (E V) `(RPLACD (CDDDR ,(CADR E)) ,V))
109
110	(DEFSETF CXR (E V) `(RPLACX ,(CADR E) ,(CADDR E) ,V))
111
112	(DEFSETF NTH (E V) `(RPLACA (NTHCDR ,(CADR E) ,(CADDR E)) ,V))
113
114	(DEFSETF ARRAYCALL (E V) `(STORE ,E ,V))
115
116	(DEFSETF GET (E V) `(PUTPROP ,(CADR E) ,V ,(CADDR E)))
117
118	(DEFSETF PLIST (E V) `(SETPLIST ,(CADR E) ,V))
119
120	(DEFSETF SYMEVAL (E V) `(SET ,(CADR E) ,V))
121
122	(DEFSETF ARG (E V) `(SETARG ,(CADR E) ,V))
123
124	(DEFSETF ARGS (E V) `(ARGS ,(CADR E) ,V))
125
126	(DEFSETF SFA-GET (E V) `(SFA-STORE ,(CADR E) ,(CADDR E) ,V))
127
128	(DEFSETF EXAMINE (E V) `(DEPOSIT ,(CADR E) ,V))
129
130
131	(defmacro list* (&rest forms)
132	(cond ((null forms) nil)
133	((null (cdr forms)) (car forms))
134	(t (construct-list* forms))))
135	(defmacro ttf (&rest l) `(list* . , l))
136
137
138	(defun construct-list* (forms)
139	(setq forms (reverse forms))
140	(do ((forms (cddr forms) (cdr forms))
141	(return-form `(cons ,(cadr forms) ,(car forms))
142	`(cons ,(car forms) ,return-form)))
143	((null forms) return-form)))
144
145	;; lexpr-funcall is a cross between apply and funcall. The last arguments
146	;; is a list of the rest of the arguments
147	(defmacro lexpr-funcall (func &rest args)
148	`(apply ,func (list* ,@args)))
149
150	; contents of the file libmax;macros all of these functions are
151	; (by default) in maclisp
152	;; (IF X P Q1 Q2 ...) --> (COND (X P) (T Q1 Q2 ...))
153	;; It is important that (IF NIL <FORM>) returns NIL as Macsyma code depends
154	;; upon this in places. See also IFN in LIBMAX;MAXMAC.
155
156	(DEFMACRO IF (PREDICATE THEN &REST ELSE)
157	(COND ((NULL ELSE) `(COND (,PREDICATE ,THEN)))
158	(T `(COND (,PREDICATE ,THEN) (T . ,ELSE)))))
159
160	;; LET, LET, LIST are now a part of Multics Lisp. Nobody should miss
161	;; the code commented out below.
162	;; (LET ((A 3) (B) C) STUFF) --> ((LAMBDA (A B C) STUFF) 3 NIL NIL)
163	;; (LET* ((A 3) (B 4)) STUFF) --> ((LAMBDA (A) ((LAMBDA (B) STUFF) 4)) 3)
164
165	;; (PUSH X S) --> (SETQ S (CONS X S))
166
167	(DEFMACRO PUSH (OBJECT LIST) `(SETF ,LIST (CONS ,OBJECT ,LIST)))
168
169	;; (POP S) --> (PROG1 (CAR S) (SETF S (CDR S)))
170	;; (POP S V) --> (PROG1 (SETF V (CAR S)) (SETF S (CDR S)))
171	;; This relies on the fact that SETF returns the value stored.
172
173	(DEFMACRO POP (LIST &OPTIONAL (INTO NIL INTO-P))
174	(COND (INTO-P `(PROG1 (SETF ,INTO (CAR ,LIST))
175	(SETF ,LIST (CDR ,LIST))))
176	(T `(PROG1 (CAR ,LIST)
177	(SETF ,LIST (CDR ,LIST))))))
178
179	;; (FOR I m n . BODY) will evaluate BODY with I bound to m,m+1,...,n-1
180	;; sequentially. (FOR I 0 n . BODY) --> (DOTIMES (I n) . BODY)
181
182	(DEFMACRO FOR (VAR START STOP . BODY)
183	`(DO ,VAR ,START (1+ ,VAR) (= ,VAR ,STOP) ,@BODY))
184
185	(DEFMACRO EVENP (X) `(NOT (ODDP ,X)))
186
187	; these were grabbed from lspsrc;umlmac.5
188	(DEFMACRO WHEN (P . C) `(COND (,P . ,C)))
189	(DEFMACRO UNLESS (P . C) `(COND ((NOT ,P) . ,C)))
190	(defmacro DOLIST ((var form index) &rest body &aux (dummy (gensym)) decls)
191	(setq decls (cond ((and body
192	(not (atom (car body)))
193	(eq (caar body) 'DECLARE))
194	(prog2 () (cdar body) (pop body)))))
195	(cond (index (setq index (ncons `(,INDEX 0 (1+ ,INDEX)) ))
196	(push `(FIXNUM ,INDEX) decls)))
197	(and decls (setq decls (ncons `(DECLARE ,.decls))))
198	`(DO ((,DUMMY ,FORM (CDR ,DUMMY)) (,VAR) ,.index )
199	((NULL ,DUMMY))
200	,@decls
201	(SETQ ,VAR (CAR ,DUMMY)) ,.BODY))
202
203	;Repeat a number of times. <count> evaluates to the number of times,
204	;and <body> is executed with <var> bound to 0, 1, ...
205	;Don't generate dummy variable if <count> is an integer. We could also do this
206	;if <count> were a symbol, but the symbol may get clobbered inside the body,
207	;so the behavior of the macro would change.
208
209	(DEFMACRO DOTIMES (SPEC &REST BODY)
210	(LET (VAR COUNT DUMMY DECLS)
211	(SETQ DECLS `(DECLARE
212	(FIXNUM ,var ) ;LOOP VARIABLE TO BE FILLED IN HERE
213	,.(cond ((and body
214	(not (atom (car body)))
215	(eq (caar body) 'DECLARE))
216	(prog2 () (cdar body) (pop body))))))
217	(COND ((ATOM SPEC) (SETQ VAR (GENSYM) COUNT SPEC))
218	('T (DESETQ (VAR COUNT) SPEC)
219	(COND ((NULL VAR) (SETQ VAR (GENSYM))))
220	(COND ((NOT (FIXP COUNT))
221	(SETQ DUMMY `((,(gensym) ,count))
222	COUNT (CAAR DUMMY))))))
223	(SETF (CADADR DECLS) VAR)
224	`(DO ((,var 0 (1+ ,var)) ,.dummy)
225	((NOT (< ,var ,count)))
226	,decls
227	,.body)))
228
229
230	;; The following is NOT courtesy AI: LISPM2; LMMAC 118
231	;; Theirs is buggy!
232	;; PSETQ looks like SETQ but does its work in parallel.
233	(DEFMACRO PSETQ (&REST REST)
234	(COND ((CDDR REST)
235	`(SETQ ,(CAR REST)
236	(PROG1 ,(CADR REST) (PSETQ . ,(CDDR REST)))))
237	;; The last pair. Keep it simple; no superfluous
238	;; (PROG1 (SETQ...) (PSETQ)).
239	((CDR REST) `(SETQ . ,REST))
240	(T (error '\|Odd number of args to PSETQ\| rest 'wrng-no-args))))
241
242
243	(defmacro if-for-maclisp-else-lispm (&rest ll) (car ll))
244
245	(PROGN 'COMPILE
246	(DEFMACRO LOGAND (&REST FORMS) `(BOOLE 1 . ,FORMS))
247	(DEFMACRO LOGIOR (&REST FORMS) `(BOOLE 7 . ,FORMS))
248	(DEFMACRO LOGXOR (&REST FORMS) `(BOOLE 6 . ,FORMS))
249	)
250
251	(DEFMACRO DEFVAR (VARIABLE &OPTIONAL (INITIAL-VALUE NIL IV-P) DOCUMENTATION)
252	DOCUMENTATION ;; Ignored for now.
253	(IF IV-P `(PROGN 'COMPILE
254	(DECLARE (SPECIAL ,VARIABLE))
255	(OR (BOUNDP ',VARIABLE) (SETQ ,VARIABLE ,INITIAL-VALUE)))
256	`(DECLARE (SPECIAL ,VARIABLE))))
257
258	(DEFMACRO PSETQ (VAR VALUE . REST)
259	(COND (REST `(SETQ ,VAR (PROG1 ,VALUE (PSETQ . ,REST))))
260	(T `(SETQ ,VAR ,VALUE))))
261
262
263	;; (DOTIMES (I N) BODY) evaluates BODY N times, with I bound to 0, 1, ..., N-1.
264	;; (DOLIST (X L) BODY) successively binds X to the elements of L, and evaluates
265	;; BODY each time.
266
267	;; Things to beware of:
268	;; [1] This won't work for COUNT being a bignum.
269	;; [2] If COUNT is a symbol, somebody could clobber its value inside the body.
270	;; [3] Somebody inside of BODY could reference COUNT.
271
272	(DEFMACRO DOTIMES ((VAR COUNT) . BODY)
273	(IF (OR (FIXP COUNT) (SYMBOLP COUNT))
274	`(DO ((,VAR 0 (1+ ,VAR)))
275	((>= ,VAR ,COUNT))
276	(DECLARE (FIXNUM ,VAR))
277	. ,BODY)
278	`(DO ((,VAR 0 (1+ ,VAR))
279	(COUNT ,COUNT))
280	((>= ,VAR COUNT))
281	(DECLARE (FIXNUM ,VAR COUNT))
282	. ,BODY)))
283
284	(DEFMACRO DOLIST ((VAR LIST) . BODY)
285	`(DO ((LIST ,LIST (CDR LIST))
286	(,VAR))
287	((NULL LIST))
288	(SETQ ,VAR (CAR LIST))
289	. ,BODY))
290
291	;; CASE is apparently missing from ITS MacLisp.
292	;; (DEFMACRO SELECT (KEY . FORMS)
293	;; (SETQ FORMS
294	;; (MAPCAR #'(LAMBDA (FORM) (IF (EQ (CAR FORM) 'OTHERWISE)
295	;; (CONS T (CDR FORM)) FORM))
296	;; FORMS))
297	;; `(CASE ,KEY . ,FORMS))
298
299	(DEFMACRO SELECTQ (KEY . FORMS)
300	(SETQ FORMS
301	(MAPCAR '(LAMBDA (FORM) (IF (EQ (CAR FORM) 'OTHERWISE)
302	(CONS T (CDR FORM)) FORM))
303	FORMS))
304	`(CASEQ ,KEY . ,FORMS))
305