![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to cmumacs.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / lisplib|
Return to cmumacs.l CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / lisplib |
1.1 root 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)
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.