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

;; file of common cmu functions which should be macros 
;; I hope that by just loading in the file an environment will be
;; created which will permit the cmu files to be compiled.

(setq rcs-cmumacs-
   "$Header: /usr/lib/lisp/cmumacs.l,v 1.1 83/01/29 18:34:31 jkf Exp $")

(declare (macros t))

(eval-when (compile eval load)
   (or (boundp 'CMU-fcn-def) (setq CMU-fcn-def (getd 'def))))

;-- contents
;	dv	mark!changed 	***	list* [construct-list* lambda]
;	neq	push	pop	mukname (equivlance)
;	prin1 (equiv to print)	selectq	lineread
;

;--- dv :: set variable to value and remember it was changed
; (dv name value)   name is setq'ed to value (no evaluation) and
;		 the fact that it was done is remembered
;
(defmacro dv (name value)
  `(progn 'compile
	  (setq ,name ',value)
	  (mark!changed ',name)))

(defmacro mark!changed (name)
  `(let ((atomname ,name))
        (and (boundp '%changes) (setq %changes (cons atomname %changes)))
	atomname))

;--- *** :: comment macro
;
(defmacro *** (&rest x) nil)

;; this must be rewritten as a macro		****
;(def quote! (nlambda (a) (quote!-expr a)))

; this will be thrown away if the code below it works
(def quote!-expr
     (lambda 
      (x)
      (cond ((atom x) x)
            ((eq (car x) '!)
             (cons (eval (cadr x)) (quote!-expr (cddr x))))
            ((eq (car x) '!!)
             (cond ((cddr x)
                    (append (eval (cadr x)) (quote!-expr (cddr x))))
                   (t (eval (cadr x)))))
            (t
             (prog (u v)
                   (setq u (quote!-expr (car x)))
                   (setq v (quote!-expr (cdr x)))
                   (cond ((and (eq u (car x)) (eq v (cdr x))) (return x)))
                   (return (cons u v)))))))
;; this is probably what the above forms do. (jkf)
(defmacro quote! (&rest a) (quote!-expr-mac a))
(eval-when (compile eval load)
   
(defun quote!-expr-mac (form)
   (cond ((null form) nil)
	 ((atom form) `',form)
	 ((eq (car form) '!)
	  `(cons ,(cadr form) ,(quote!-expr-mac (cddr form))))
	 ((eq (car form) '!!)
	  (cond ((cddr form) `(append ,(cadr form)
				       ,(quote!-expr-mac (cddr form))))
		(t (cadr form))))
	 (t `(cons ,(quote!-expr-mac (car form))
		    ,(quote!-expr-mac (cdr form))))))

); end eval-when
		 
	 
;--- the following are macroizations from cmu3.l

;(jkf)- ucb list* macro.
;
(defmacro list* (&rest forms)
	  (cond ((null forms) nil)
		((null (cdr forms)) (car forms))
		(t (construct-list* forms))))

(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))) 

(defmacro neq (a b) `(not (eq ,a ,b)))


(defmacro push (value stack) `(setq ,stack (cons ,value ,stack)))


;(jkf) this is actually maknum is the maclisp terminology
(putd 'munknam (getd 'maknum))

; added for CMULisp compatibilty (used by editor etc)
(putd 'prin1 (getd 'print))

;--- selectq :: case statement type construct
;
;   (selectq <form>
;	     (<tag1> <expr1> ...)
;	     (<tag2> <expr2> ...)
;		 ...
;	     (<tagn> <exprn> ...)
;	      (<exprfinal> ...))
; <form> is evaluated and then compared with the tagi, if it matches
; the expri are evaluated.  If it doesn't match, then <exprfinal> are
; evaluated.
;
(def selectq
   (macro (form)
	  ((lambda (x)
		   `((lambda (,x)
			     (cond
				  ,@(maplist
					 '(lambda (ff)
						  (cond ((null (cdr ff))
							 `(t  ,(car ff)))
							((atom (caar ff))
							 `((eq ,x ',(caar ff))
							   . ,(cdar ff)))
							(t
							     `((memq ,x ',(caar ff))
							       . ,(cdar ff)))))
					  (cddr form))))
		     ,(cadr form)))
	  (gensym 'Z))))

(defmacro lineread (&optional (x nil)) 
  `(%lineread ,x))


(defmacro de (name &rest body)
   (cond ((status feature complr) `(def ,name (lambda ,@body)))
	 (t `(progn (putd ,name '(lambda ,@body))
		    (mark!changed ',name)))))
(defmacro dn (name &rest body)
   (cond ((status feature complr) `(def ,name (nlambda ,@body)))
	 (t `(progn (putd ,name '(nlambda ,@body))
		    (mark!changed ',name)))))
(defmacro dm (name &rest body)
   (cond ((status feature complr) `(def ,name (macro ,@body)))
	 (t `(progn (putd ,name '(macro ,@body))
		    (mark!changed ',name)))))

(eval-when (compile eval load)
   (or (boundp 'OLD-fcn-def) (setq OLD-fcn-def (getd 'def))))

(defmacro def (&rest form)
    (cond ((status feature complr)
	   `(progn 'compile
		    (eval-when (compile) (putd 'def OLD-fcn-def))
		    (def ,@form)
		    (eval-when (compile) (putd 'def CMU-fcn-def))))
	  (t `(progn (putd ',(car form) ',(cadr form))
		    (mark!changed ',(car form))))))

(eval-when (compile eval load)
   (or (boundp 'CMU-fcn-def) (setq CMU-fcn-def (getd 'def))))

;--iteration macros

(def Cdo (macro (l) (expand-do l)))

(def exists (macro (l) (expand-ex 'some l)))

(declare (special var))

(eval-when (compile eval load)
   
(def expand-ex
     (lambda 
      (fn form)
      (quote! !
              fn
              !
              (caddr form)
              (function
               (lambda 
                !
                (cond ((atom (cadr form)) (ncons (cadr form)))
                      (t (cadr form)))
                !
                (car (setq form (cdddr form)))))
              !
              (cond ((cdr form) (list 'function (cadr form)))))))
) ; end eval-when

(def expand-do
     (lambda 
      (l)
      (prog (label var init incr limit part)
            (cond
             ((setq part (memq 'for l))
              (setq var (cadr part))
              (setq l (append (ldiff l part) (cddr part)))))
            (cond
             ((setq part (exists w l (memq w '(gets = _ :=))))
              (setq init (cadr part))
              (setq l (append (ldiff l part) (cddr part)))))
            (cond
             ((setq part (exists w l (memq w '(step by))))
              (setq incr (cadr part))
              (setq l (append (ldiff l part) (cddr part)))))
            (cond
             ((setq part (memq 'to l))
              (setq limit (cadr part))
              (setq l (append (ldiff l part) (cddr part)))))
            (return
             (quote! prog
                     !
                     (cond (var (ncons var)))
                     !!
                     (cond
                      (var
                       (ncons
                        (list 'setq var (cond (init) (t 1))))))
                     !
                     (setq label (gensym))
                     !!
                     (mapcan (function
                              (lambda 
                               (exp)
                               (cond ((eq part 'while)
                                      (setq part nil)
                                      (quote!
                                       (cond
                                        ((not ! exp) (return nil)))))
                                     ((eq part 'until)
                                      (setq part nil)
                                      (quote!
                                       (cond (! exp (return nil)))))
                                     ((memq (setq part exp)
                                            '(while until do Cdo))
                                      nil)
                                     (t (ncons exp)))))
                             l)
                     !!
                     (cond
                      (var
                       (quote!
                        (setq ! var (+ ! var ! (cond (incr) (t 1)))))))
                     !!
                     (cond
                      ((and var limit)
                       (quote! (cond ((> ! var ! limit) (return nil))))))
                     (go ! label))))))


(def expand-fe
     (lambda 
      (form)
      (prog (vars body)
            (return
             (cons (cond ((memq (cadr form)
                                (quote
                                 (map mapc
                                      mapcan
                                      mapcar
                                      mapcon
                                      mapconc
                                      maplist)))
                          (setq form (cdr form))
                          (car form))
                         (t 'mapc))
                   (progn (setq vars (cadr form))
                          (cond ((atom vars) (setq vars (list vars))))
                          (cons (cons 'function
                                      (ncons
                                       (cons 'lambda
                                             (cons vars
                                                   (setq body
                                                         (Cnth (cdddr
                                                                form)
                                                               (length
                                                                vars)))))))
                                (ldiff (cddr form) body))))))))
(def expand-set-of
     (lambda 
      (form)
      (prog (vars body)
            (setq vars (cadr form))
            (cond ((atom vars) (setq vars (list vars))))
            (setq form (cddr form))
            (return
             (quote! mapcan
                     (function
                      (lambda 
                       !
                       vars
                       (cond
                        (! (car
                            (setq body (Cnth (cdr form) (length vars))))
                           (list ! (car vars))))))
                     !!
                     (ldiff form body))))))

(dv filelst nil)

(def for (macro (l) (expand-do l)))

(def for-each (macro (l) (expand-fe l)))

(def forall (macro (l) (expand-ex 'every l)))

(def set-of (macro (l) (expand-set-of l)))

(def ty (macro (f) (append '(exec cat) (cdr f))))

(def until (macro (l) (expand-do l)))

(def while (macro (l) (expand-do l)))

(putprop 'cmumacs t 'version)
Commit	Line	Data
5f34e841 C	1	;; file of common cmu functions which should be macros
	2	;; I hope that by just loading in the file an environment will be
	3	;; created which will permit the cmu files to be compiled.
	4
	5	(setq rcs-cmumacs-
	6	"$Header: /usr/lib/lisp/cmumacs.l,v 1.1 83/01/29 18:34:31 jkf Exp $")
	7
	8	(declare (macros t))
	9
	10	(eval-when (compile eval load)
	11	(or (boundp 'CMU-fcn-def) (setq CMU-fcn-def (getd 'def))))
	12
	13	;-- contents
	14	; dv mark!changed *** list* [construct-list* lambda]
	15	; neq push pop mukname (equivlance)
	16	; prin1 (equiv to print) selectq lineread
	17	;
	18
	19	;--- dv :: set variable to value and remember it was changed
	20	; (dv name value) name is setq'ed to value (no evaluation) and
	21	; the fact that it was done is remembered
	22	;
	23	(defmacro dv (name value)
	24	`(progn 'compile
	25	(setq ,name ',value)
	26	(mark!changed ',name)))
	27
	28	(defmacro mark!changed (name)
	29	`(let ((atomname ,name))
	30	(and (boundp '%changes) (setq %changes (cons atomname %changes)))
	31	atomname))
	32
	33	;--- *** :: comment macro
	34	;
	35	(defmacro *** (&rest x) nil)
	36
	37	;; this must be rewritten as a macro ****
	38	;(def quote! (nlambda (a) (quote!-expr a)))
	39
	40	; this will be thrown away if the code below it works
	41	(def quote!-expr
	42	(lambda
	43	(x)
	44	(cond ((atom x) x)
	45	((eq (car x) '!)
	46	(cons (eval (cadr x)) (quote!-expr (cddr x))))
	47	((eq (car x) '!!)
	48	(cond ((cddr x)
	49	(append (eval (cadr x)) (quote!-expr (cddr x))))
	50	(t (eval (cadr x)))))
	51	(t
	52	(prog (u v)
	53	(setq u (quote!-expr (car x)))
	54	(setq v (quote!-expr (cdr x)))
	55	(cond ((and (eq u (car x)) (eq v (cdr x))) (return x)))
	56	(return (cons u v)))))))
	57	;; this is probably what the above forms do. (jkf)
	58	(defmacro quote! (&rest a) (quote!-expr-mac a))
	59	(eval-when (compile eval load)
	60
	61	(defun quote!-expr-mac (form)
	62	(cond ((null form) nil)
	63	((atom form) `',form)
	64	((eq (car form) '!)
65	`(cons ,(cadr form) ,(quote!-expr-mac (cddr form))))
66	((eq (car form) '!!)
67	(cond ((cddr form) `(append ,(cadr form)
68	,(quote!-expr-mac (cddr form))))
69	(t (cadr form))))
70	(t `(cons ,(quote!-expr-mac (car form))
71	,(quote!-expr-mac (cdr form))))))
72
73	); end eval-when
74
75
76	;--- the following are macroizations from cmu3.l
77
78	;(jkf)- ucb list* macro.
79	;
80	(defmacro list* (&rest forms)
81	(cond ((null forms) nil)
82	((null (cdr forms)) (car forms))
83	(t (construct-list* forms))))
84
85	(defun construct-list* (forms)
86	(setq forms (reverse forms))
87	(do ((forms (cddr forms) (cdr forms))
88	(return-form `(cons ,(cadr forms) ,(car forms))
89	`(cons ,(car forms) ,return-form)))
90	((null forms) return-form)))
91
92	(defmacro neq (a b) `(not (eq ,a ,b)))
93
94
95	(defmacro push (value stack) `(setq ,stack (cons ,value ,stack)))
96
97
98
99
100
101	;(jkf) this is actually maknum is the maclisp terminology
102	(putd 'munknam (getd 'maknum))
103
104	; added for CMULisp compatibilty (used by editor etc)
105	(putd 'prin1 (getd 'print))
106
107	;--- selectq :: case statement type construct
108	;
109	; (selectq <form>
110	; (<tag1> <expr1> ...)
111	; (<tag2> <expr2> ...)
112	; ...
113	; (<tagn> <exprn> ...)
114	; (<exprfinal> ...))
115	; <form> is evaluated and then compared with the tagi, if it matches
116	; the expri are evaluated. If it doesn't match, then <exprfinal> are
117	; evaluated.
118	;
119	(def selectq
120	(macro (form)
121	((lambda (x)
122	`((lambda (,x)
123	(cond
124	,@(maplist
125	'(lambda (ff)
126	(cond ((null (cdr ff))
127	`(t ,(car ff)))
128	((atom (caar ff))
129	`((eq ,x ',(caar ff))
130	. ,(cdar ff)))
131	(t
132	`((memq ,x ',(caar ff))
133	. ,(cdar ff)))))
134	(cddr form))))
135	,(cadr form)))
136	(gensym 'Z))))
137
138	(defmacro lineread (&optional (x nil))
139	`(%lineread ,x))
140
141
142
143	(defmacro de (name &rest body)
144	(cond ((status feature complr) `(def ,name (lambda ,@body)))
145	(t `(progn (putd ,name '(lambda ,@body))
146	(mark!changed ',name)))))
147	(defmacro dn (name &rest body)
148	(cond ((status feature complr) `(def ,name (nlambda ,@body)))
149	(t `(progn (putd ,name '(nlambda ,@body))
150	(mark!changed ',name)))))
151	(defmacro dm (name &rest body)
152	(cond ((status feature complr) `(def ,name (macro ,@body)))
153	(t `(progn (putd ,name '(macro ,@body))
154	(mark!changed ',name)))))
155
156	(eval-when (compile eval load)
157	(or (boundp 'OLD-fcn-def) (setq OLD-fcn-def (getd 'def))))
158
159	(defmacro def (&rest form)
160	(cond ((status feature complr)
161	`(progn 'compile
162	(eval-when (compile) (putd 'def OLD-fcn-def))
163	(def ,@form)
164	(eval-when (compile) (putd 'def CMU-fcn-def))))
165	(t `(progn (putd ',(car form) ',(cadr form))
166	(mark!changed ',(car form))))))
167
168	(eval-when (compile eval load)
169	(or (boundp 'CMU-fcn-def) (setq CMU-fcn-def (getd 'def))))
170
171	;--iteration macros
172
173	(def Cdo (macro (l) (expand-do l)))
174
175	(def exists (macro (l) (expand-ex 'some l)))
176
177	(declare (special var))
178
179	(eval-when (compile eval load)
180
181	(def expand-ex
182	(lambda
183	(fn form)
184	(quote! !
185	fn
186	!
187	(caddr form)
188	(function
189	(lambda
190	!
191	(cond ((atom (cadr form)) (ncons (cadr form)))
192	(t (cadr form)))
193	!
194	(car (setq form (cdddr form)))))
195	!
196	(cond ((cdr form) (list 'function (cadr form)))))))
197	) ; end eval-when
198
199	(def expand-do
200	(lambda
201	(l)
202	(prog (label var init incr limit part)
203	(cond
204	((setq part (memq 'for l))
205	(setq var (cadr part))
206	(setq l (append (ldiff l part) (cddr part)))))
207	(cond
208	((setq part (exists w l (memq w '(gets = _ :=))))
209	(setq init (cadr part))
210	(setq l (append (ldiff l part) (cddr part)))))
211	(cond
212	((setq part (exists w l (memq w '(step by))))
213	(setq incr (cadr part))
214	(setq l (append (ldiff l part) (cddr part)))))
215	(cond
216	((setq part (memq 'to l))
217	(setq limit (cadr part))
218	(setq l (append (ldiff l part) (cddr part)))))
219	(return
220	(quote! prog
221	!
222	(cond (var (ncons var)))
223	!!
224	(cond
225	(var
226	(ncons
227	(list 'setq var (cond (init) (t 1))))))
228	!
229	(setq label (gensym))
230	!!
231	(mapcan (function
232	(lambda
233	(exp)
234	(cond ((eq part 'while)
235	(setq part nil)
236	(quote!
237	(cond
238	((not ! exp) (return nil)))))
239	((eq part 'until)
240	(setq part nil)
241	(quote!
242	(cond (! exp (return nil)))))
243	((memq (setq part exp)
244	'(while until do Cdo))
245	nil)
246	(t (ncons exp)))))
247	l)
248	!!
249	(cond
250	(var
251	(quote!
252	(setq ! var (+ ! var ! (cond (incr) (t 1)))))))
253	!!
254	(cond
255	((and var limit)
256	(quote! (cond ((> ! var ! limit) (return nil))))))
257	(go ! label))))))
258
259
260	(def expand-fe
261	(lambda
262	(form)
263	(prog (vars body)
264	(return
265	(cons (cond ((memq (cadr form)
266	(quote
267	(map mapc
268	mapcan
269	mapcar
270	mapcon
271	mapconc
272	maplist)))
273	(setq form (cdr form))
274	(car form))
275	(t 'mapc))
276	(progn (setq vars (cadr form))
277	(cond ((atom vars) (setq vars (list vars))))
278	(cons (cons 'function
279	(ncons
280	(cons 'lambda
281	(cons vars
282	(setq body
283	(Cnth (cdddr
284	form)
285	(length
286	vars)))))))
287	(ldiff (cddr form) body))))))))
288	(def expand-set-of
289	(lambda
290	(form)
291	(prog (vars body)
292	(setq vars (cadr form))
293	(cond ((atom vars) (setq vars (list vars))))
294	(setq form (cddr form))
295	(return
296	(quote! mapcan
297	(function
298	(lambda
299	!
300	vars
301	(cond
302	(! (car
303	(setq body (Cnth (cdr form) (length vars))))
304	(list ! (car vars))))))
305	!!
306	(ldiff form body))))))
307
308	(dv filelst nil)
309
310	(def for (macro (l) (expand-do l)))
311
312	(def for-each (macro (l) (expand-fe l)))
313
314	(def forall (macro (l) (expand-ex 'every l)))
315
316	(def set-of (macro (l) (expand-set-of l)))
317
318	(def ty (macro (f) (append '(exec cat) (cdr f))))
319
320	(def until (macro (l) (expand-do l)))
321
322	(def while (macro (l) (expand-do l)))
323
324	(putprop 'cmumacs t 'version)