Commit | Line | Data |
---|---|---|
5ffa1c4c C |
1 | (setq rcs-macros- |
2 | "$Header: macros.l,v 1.6 83/11/09 07:09:42 jkf Exp $") | |
3 | ||
4 | ;; macros.l -[Wed Nov 9 07:09:26 1983 by jkf]- | |
5 | ;; | |
6 | ;; The file contains the common macros for Franz lisp. | |
7 | ;; contents: | |
8 | ;; defmacro | |
9 | ;; setf | |
10 | ;; defsetf | |
11 | ;; push | |
12 | ;; pop | |
13 | ;; let | |
14 | ;; let* | |
15 | ;; caseq | |
16 | ;; listify | |
17 | ;; include-if | |
18 | ;; includef-if | |
19 | ;; defvar | |
20 | ||
21 | ||
22 | (declare (macros t)) | |
23 | ||
24 | ;; defmacro | |
25 | (declare (special defmacrooptlist protect-list protect-evform)) | |
26 | ||
27 | ;--- defmacro - name - name of macro being defined | |
28 | ; - pattrn - formal arguments plus other fun stuff | |
29 | ; - body - body of the macro | |
30 | ; This is an intellegent macro creator. The pattern may contain | |
31 | ; symbols which are formal paramters, lists which show how the | |
32 | ; actual paramters will appear in the args, and these key words | |
33 | ; &rest name - the rest of the args (or nil if there are no other args) | |
34 | ; is bound to name | |
35 | ; &optional name - bind the next arg to name if it exists, otherwise | |
36 | ; bind it to nil | |
37 | ; &optional (name init) - bind the next arg to name if it exists, otherwise | |
38 | ; bind it to init evaluted. (the evaluation is done left | |
39 | ; to right for optional forms) | |
40 | ; &optional (name init given) - bind the next arg to name and given to t | |
41 | ; if the arg exists, else bind name to the value of | |
42 | ; init and given to nil. | |
43 | ; &aux name | |
44 | ; &aux (name init) | |
45 | ; | |
46 | ; Method of operation: | |
47 | ; the list returned from defmcrosrc has the form ((cxxr name) ...) | |
48 | ; where cxxr is the loc of the macro arg and name is it formal name | |
49 | ; defmcrooptlist has the form ((initv cxxr name) ...) | |
50 | ; which is use for &optional args with an initial value. | |
51 | ; here cxxr looks like cdd..dr which will test of the arg exists. | |
52 | ; | |
53 | ; the variable defmacro-for-compiling determines if the defmacro forms | |
54 | ; will be compiled. If it is t, then we return (progn 'compile (def xx..)) | |
55 | ; to insure that it is compiled | |
56 | ; | |
57 | (declare (special defmacro-for-compiling)) | |
58 | (cond ((null (boundp 'defmacro-for-compiling)) ; insure it has a value | |
59 | (setq defmacro-for-compiling nil))) | |
60 | ||
61 | (def defmacro | |
62 | (macro (args) | |
63 | ((lambda | |
64 | (tmp tmp2 defmacrooptlist body protect-evform protect-list gutz) | |
65 | (setq tmp (defmcrosrch (caddr args) '(d r) nil) | |
66 | body | |
67 | `(def ,(cadr args) | |
68 | (macro (defmacroarg) | |
69 | ((lambda ,(mapcar 'cdr tmp) | |
70 | ,@(mapcar | |
71 | '(lambda (arg) | |
72 | `(cond ((setq ,(caddr arg) | |
73 | (,(cadr arg) | |
74 | defmacroarg)) | |
75 | ,@(cond ((setq tmp2 (cadddr arg)) | |
76 | `((setq ,tmp2 t)))) | |
77 | (setq ,(caddr arg) | |
78 | (car ,(caddr arg)))) | |
79 | (t (setq ,(caddr arg) | |
80 | ,(car arg))))) | |
81 | defmacrooptlist) | |
82 | ,@(cond (protect-evform | |
83 | (setq gutz | |
84 | (eval `((lambda ,(mapcar 'cdr tmp) | |
85 | ,@(cdddr args)) | |
86 | ,@(mapcar | |
87 | '(lambda (x) `',(cdr x)) | |
88 | tmp)))) | |
89 | (ncons | |
90 | `(cond (,protect-evform | |
91 | (copy | |
92 | `((lambda ,',(mapcar 'cdr tmp) | |
93 | ,',gutz) | |
94 | ,,@(mapcar 'cdr tmp)))) | |
95 | (t ,@(cdddr args))))) | |
96 | (t (cdddr args)))) | |
97 | ,@(mapcar '(lambda (arg) | |
98 | (cond ((dtpr (car arg)) | |
99 | (caar arg)) | |
100 | ((car arg) | |
101 | `(,(car arg) defmacroarg)))) | |
102 | tmp))))) | |
103 | (cond (defmacro-for-compiling `(progn 'compile ,body)) | |
104 | (t body))) | |
105 | ||
106 | nil nil nil nil nil nil nil))) | |
107 | ||
108 | (def defmcrosrch | |
109 | (lambda (pat form sofar) | |
110 | (cond ((null pat) sofar) | |
111 | ((atom pat) (cons (cons (concatl `(c ,@form)) pat) | |
112 | sofar)) | |
113 | ((memq (car pat) '(&rest &body)) | |
114 | (append (defmcrosrch (cadr pat) form nil) | |
115 | (defmcrosrch (cddr pat) form sofar))) | |
116 | ((eq (car pat) '&optional) | |
117 | (defmcrooption (cdr pat) form sofar)) | |
118 | ((eq (car pat) '&protect) | |
119 | (setq protect-list (cond ((atom (cadr pat)) | |
120 | (ncons (cadr pat))) | |
121 | (t (cadr pat))) | |
122 | protect-evform (cons 'or (mapcar '(lambda (x) | |
123 | `(dtpr ,x)) | |
124 | protect-list))) | |
125 | (defmcrosrch (cddr pat) form sofar)) | |
126 | ((eq (car pat) '&aux) | |
127 | (mapcar '(lambda (frm) | |
128 | (cond ((atom frm) `((nil) . ,frm)) | |
129 | (t `((,(cadr frm)) . ,(car frm))))) | |
130 | (cdr pat))) | |
131 | (t (append (defmcrosrch (car pat) (cons 'a form) nil) | |
132 | (defmcrosrch (cdr pat) (cons 'd form) sofar)))))) | |
133 | ||
134 | (def defmcrooption | |
135 | (lambda (pat form sofar) | |
136 | ((lambda (tmp tmp2) | |
137 | (cond ((null pat) sofar) | |
138 | ((memq (car pat) '(&rest &body)) | |
139 | (defmcrosrch (cadr pat) form sofar)) | |
140 | (t (cond ((atom (car pat)) | |
141 | (setq tmp (car pat))) | |
142 | (t (setq tmp (caar pat)) | |
143 | (setq defmacrooptlist | |
144 | `((,(cadar pat) | |
145 | ,(concatl `(c ,@form)) | |
146 | ,tmp | |
147 | ,(setq tmp2 (caddar pat))) | |
148 | . ,defmacrooptlist)))) | |
149 | (defmcrooption | |
150 | (cdr pat) | |
151 | (cons 'd form) | |
152 | `( (,(concatl `(ca ,@form)) . ,tmp) | |
153 | ,@(cond (tmp2 `((nil . ,tmp2)))) | |
154 | . ,sofar))))) | |
155 | nil nil))) | |
156 | ||
157 | ||
158 | ;--- lambdacvt :: new lambda converter. | |
159 | ; | |
160 | ; - input is a lambda body beginning with the argument list. | |
161 | ; | |
162 | ; vrbls :: list of (name n) where n is the arg number for name | |
163 | ; optlist :: list of (name n defval pred) where optional variable name is | |
164 | ; (arg n) [if it exists], initval is the value if it doesn't | |
165 | ; exist, pred is set to non nil if the arg exists | |
166 | ; auxlist :: list of (name initial-value) for auxillary variables. (&aux) | |
167 | ; restform :: (name n) where args n to #args should be consed and assigned | |
168 | ; to name. | |
169 | ; | |
170 | ;; strategy: | |
171 | ; Until the compiler can compiler lexprs better, we try to avoid creating | |
172 | ; a lexpr. A lexpr is only required if &optional or &rest forms | |
173 | ; appear. | |
174 | ; Formal parameters which come after &aux are bound and evaluated in a let* | |
175 | ; surrounding the body. The parameter after a &rest is put in the let* | |
176 | ; too, with an init form which is a complex do loop. The parameters | |
177 | ; after &optional are put in the lambda expression just below the lexpr. | |
178 | ; | |
179 | (defun lambdacvt (exp) | |
180 | (prog (vrbls optlist auxlist restform vbl fl-type optcode mainvar | |
181 | minargs maxargs) | |
182 | (do ((reallist (car exp) (cdr reallist)) | |
183 | (count 1 (1+ count))) | |
184 | ((null reallist)) | |
185 | (setq vbl (car reallist)) | |
186 | (cond ((memq vbl '(&rest &body)) | |
187 | (setq fl-type '&rest count (1- count))) | |
188 | ((eq '&aux vbl) | |
189 | (setq fl-type '&aux count (1- count))) | |
190 | ((eq '&optional vbl) | |
191 | (setq fl-type '&optional count (1- count))) | |
192 | ((null fl-type) ; just a variable | |
193 | (setq vrbls (cons (list vbl count) vrbls))) | |
194 | ((eq fl-type '&rest) | |
195 | (cond (restform (error "Too many &rest parameters " vbl))) | |
196 | (setq restform (list vbl count))) | |
197 | ((eq fl-type '&aux) | |
198 | (cond ((atom vbl) | |
199 | (setq auxlist (cons (list vbl nil) auxlist))) | |
200 | (t (setq auxlist (cons (list (car vbl) (cadr vbl)) | |
201 | auxlist))))) | |
202 | ((eq fl-type '&optional) | |
203 | (cond ((atom vbl) | |
204 | (setq optlist | |
205 | (cons (list vbl count) optlist))) | |
206 | (t (setq optlist | |
207 | (cons (cons (car vbl) | |
208 | (cons count | |
209 | (cdr vbl))) | |
210 | optlist))))))) | |
211 | ||
212 | ;; arguments are collected in reverse order, but set them straight | |
213 | (setq vrbls (nreverse vrbls) | |
214 | optlist (nreverse optlist) | |
215 | auxlist (nreverse auxlist) | |
216 | minargs (length vrbls) | |
217 | maxargs (cond (restform nil) | |
218 | (t (+ (length optlist) minargs)))) | |
219 | ||
220 | ;; we must covert to a lexpr if there are &optional or &rest forms | |
221 | (cond ((or optlist restform) (setq mainvar (gensym)))) | |
222 | ||
223 | ; generate optionals code | |
224 | (cond (optlist | |
225 | (setq optcode | |
226 | (mapcar '(lambda (x) | |
227 | `(cond ((> ,(cadr x) ,mainvar) | |
228 | (setq ,(car x) ,(caddr x))) | |
229 | (t (setq ,(car x) | |
230 | (arg ,(cadr x))) | |
231 | ,(cond ((cdddr x) | |
232 | `(setq ,(cadddr x) t)))))) | |
233 | optlist)))) | |
234 | ||
235 | ;; do the rest forms | |
236 | (cond (restform | |
237 | (let ((dumind (gensym)) | |
238 | (dumcol (gensym))) | |
239 | (setq restform | |
240 | `((,(car restform) | |
241 | (do ((,dumind ,mainvar (1- ,dumind)) | |
242 | (,dumcol nil (cons (arg ,dumind) ,dumcol))) | |
243 | ((< ,dumind ,(cadr restform)) ,dumcol)))))))) | |
244 | ||
245 | ;; calculate body | |
246 | (let (body) | |
247 | (setq body (cond ((or auxlist restform) | |
248 | `((let* ,(append restform auxlist) | |
249 | ,@(cdr exp)))) | |
250 | (t (cdr exp)))) | |
251 | (cond ((null mainvar) ; no &optional or &rest | |
252 | (return `(lambda ,(mapcar 'car vrbls) | |
253 | (declare (*args ,minargs ,maxargs)) | |
254 | ,@body))) | |
255 | (t (return | |
256 | `(lexpr (,mainvar) | |
257 | (declare (*args ,minargs ,maxargs)) | |
258 | ((lambda | |
259 | ,(nconc | |
260 | (mapcar 'car vrbls) | |
261 | (mapcan '(lambda (x) ; may be two vrbls | |
262 | (cons (car x) | |
263 | (cond ((cdddr x) ;pred? | |
264 | (ncons | |
265 | (cadddr x)))))) | |
266 | optlist)) | |
267 | ,@optcode ,@body) | |
268 | ,@(nconc (mapcar '(lambda (x) `(arg ,(cadr x))) | |
269 | vrbls) | |
270 | (mapcan '(lambda (x) | |
271 | (cond ((cdddr x) | |
272 | (list nil nil)) | |
273 | (t (list nil)))) | |
274 | optlist)))))))))) | |
275 | ||
276 | ;--- defcmacro :: like defmacro but result ends up under cmacro ind | |
277 | ; | |
278 | (def defcmacro | |
279 | (macro (args) | |
280 | (let ((name (concat (cadr args) "::cmacro:" (gensym)))) | |
281 | `(eval-when (compile load eval) | |
282 | (defmacro ,name ,@(cddr args)) | |
283 | (putprop ',(cadr args) (getd ',name) 'cmacro) | |
284 | (remob ',name))))) | |
285 | ||
286 | ;;; --- setf macro | |
287 | ; | |
288 | ;(setf (cadr x) 3) --> (rplaca (cdr x) 3) | |
289 | ||
290 | (defmacro setf (expr val &rest rest) | |
291 | (cond ((atom expr) | |
292 | (or (symbolp expr) | |
293 | (error '|-- setf can't handle this.| expr)) | |
294 | `(setq ,expr ,val)) | |
295 | (t | |
296 | (do ((y) | |
297 | (tmp)) | |
298 | (nil) | |
299 | (and (dtpr (car expr)) | |
300 | (setq tmp | |
301 | (setf-record-package-access-check expr val)) | |
302 | (return tmp)) | |
303 | (or (symbolp (car expr)) | |
304 | (error '|-- setf can't handle this.| expr)) | |
305 | (and (setq y (get (car expr) 'setf-expand)) | |
306 | (return (apply y `(,expr ,val ,@rest)))) | |
307 | (or (setf-check-cad+r (car expr)) | |
308 | (and | |
309 | (or (setq y (get (car expr) 'cmacro)) | |
310 | (setq y (getd (car expr)))) | |
311 | (or (and (dtpr y) | |
312 | (eq (car y) 'macro)) | |
313 | (and (bcdp y) | |
314 | (eq (getdisc y) 'macro))) | |
315 | (setq expr (apply y expr))) | |
316 | (error '|-- setf can't handle this.| expr)))))) | |
317 | ||
318 | (defun setf-check-cad+r (name) | |
319 | ;; invert all c{ad}+r combinations | |
320 | (if (eq (getcharn name 1) #/c) | |
321 | then (let ((letters (nreverse (cdr (exploden name))))) | |
322 | (if (eq (car letters) #/r) | |
323 | then (do ((xx (cdr letters) (cdr xx))) | |
324 | ((null xx) | |
325 | ;; form is c{ad}+r, setf form is | |
326 | ;; (rplac<first a or d> (c<rest of a's + d's>r x)) | |
327 | (setq letters (nreverse letters)) | |
328 | (eval | |
329 | `(defsetf ,name (e v) | |
330 | (list | |
331 | ',(concat "rplac" (ascii (car letters))) | |
332 | (list | |
333 | ',(implode `(#/c ,@(cdr letters))) | |
334 | (cadr e)) | |
335 | v))) | |
336 | t) | |
337 | (if (not (memq (car xx) '(#/a #/d))) | |
338 | then (return nil))))))) | |
339 | ||
340 | (defun setf-record-package-access-check (form val) | |
341 | ;; When the record package is given the 'access-check' flag, | |
342 | ;; the access macros it generates have this form: | |
343 | ;; ((lambda (defrecord-acma) | |
344 | ;; (cond (...) | |
345 | ;; (t (access-form)))) | |
346 | ;; res) | |
347 | ;; To invert this, we make a copy of the form and replace the | |
348 | ;; access-form with (setf (access-form) val) | |
349 | ;; | |
350 | ;; we return nil if the form passed isn't a recognized form | |
351 | ;; | |
352 | (cond ((and (dtpr form) | |
353 | (dtpr (car form)) | |
354 | (eq 'lambda (car (car form))) | |
355 | (dtpr (cadr (car form))) | |
356 | (eq (car (cadr (car form))) | |
357 | 'defrecord-acma)) | |
358 | ((lambda (newform acc) | |
359 | ; newform is a copy of the given form, so we can | |
360 | ; clobber it | |
361 | ; locate the second clause of the cond | |
362 | (setq acc (cadr ;; right the 't' | |
363 | (caddr ;; second cond clause | |
364 | (caddr ;; cond is third thing in lambda | |
365 | (car newform))))) | |
366 | (rplaca (cdaddaddar newform) (list 'setf acc val)) | |
367 | newform) | |
368 | (copy form) nil)) | |
369 | (t nil))) | |
370 | ||
371 | (defmacro defsetf (name vars &rest body) | |
372 | `(eval-when | |
373 | (compile load eval) | |
374 | (defun (,name setf-expand) ,vars . ,body))) | |
375 | ||
376 | ;--- other setf's for car's and cdr's are generated automatically | |
377 | ; | |
378 | (defsetf car (e v) `(rplaca ,(cadr e) ,v)) | |
379 | (defsetf caar (e v) `(rplaca (car ,(cadr e)) ,v)) | |
380 | (defsetf cadr (e v) `(rplaca (cdr ,(cadr e)) ,v)) | |
381 | (defsetf cdr (e v) `(rplacd ,(cadr e) ,v)) | |
382 | (defsetf cdar (e v) `(rplacd (car ,(cadr e)) ,v)) | |
383 | (defsetf cddr (e v) `(rplacd (cdr ,(cadr e)) ,v)) | |
384 | (defsetf cxr (e v) `(rplacx ,(cadr e) ,(caddr e) ,v)) | |
385 | ||
386 | (defsetf vref (e v) `(vset ,(cadr e) ,(caddr e) ,v)) | |
387 | (defsetf vrefi-byte (e v) `(vseti-byte ,(cadr e) ,(caddr e) ,v)) | |
388 | (defsetf vrefi-word (e v) `(vseti-word ,(cadr e) ,(caddr e) ,v)) | |
389 | (defsetf vrefi-long (e v) `(vseti-long ,(cadr e) ,(caddr e) ,v)) | |
390 | ||
391 | (defsetf nth (e v) `(rplaca (nthcdr ,(cadr e) ,(caddr e)) ,v)) | |
392 | (defsetf nthelem (e v) `(rplaca (nthcdr (1- ,(cadr e)) ,(caddr e)) ,v)) | |
393 | (defsetf nthcdr (e v) `(rplacd (nthcdr (1- ,(cadr e)) ,(caddr e)) ,v)) | |
394 | ||
395 | (defsetf arraycall (e v) `(store ,e ,v)) | |
396 | (defsetf get (e v) `(putprop ,(cadr e) ,v ,(caddr e))) | |
397 | ||
398 | (defsetf plist (e v) `(setplist ,(cadr e) ,v)) | |
399 | ||
400 | (defsetf symeval (e v) `(set ,(cadr e) ,v)) | |
401 | ||
402 | (defsetf arg (e v) `(setarg ,(cadr e) ,v)) | |
403 | ||
404 | (defsetf args (e v) `(args ,(cadr e) ,v)) | |
405 | ||
406 | ||
407 | (defmacro push (object list) `(setf ,list (cons ,object ,list))) | |
408 | ||
409 | ; this relies on the fact that setf returns the value stored. | |
410 | (defmacro pop (list &optional (into nil into-p)) | |
411 | (cond (into-p `(prog1 (setf ,into (car ,list)) | |
412 | (setf ,list (cdr ,list)))) | |
413 | (t `(prog1 (car ,list) | |
414 | (setf ,list (cdr ,list)))))) | |
415 | ||
416 | ; let for franz (with destructuring) | |
417 | ;--- let | |
418 | ; - binds - binding forms | |
419 | ; - . body - forms to execute | |
420 | ; the binding forms may have these forms | |
421 | ; a local variable a, initially nil | |
422 | ; (a x) local variable a, x is evaled and a gets its value initially | |
423 | ; ((a . (b . c)) x) three local variables, a,b and c which are given | |
424 | ; values corresponding to the location in the value | |
425 | ; of x. Any structure is allowed here. | |
426 | ; | |
427 | (defmacro let (binds &rest body &aux vrbls vals destrs newgen) | |
428 | (mapc '(lambda (form) | |
429 | (cond ((atom form) | |
430 | (setq vrbls (cons form vrbls) | |
431 | vals (cons nil vals))) | |
432 | ((atom (car form)) | |
433 | (setq vrbls (cons (car form) vrbls) | |
434 | vals (cons (cadr form) vals))) | |
435 | (t (setq newgen (gensym) | |
436 | destrs `((,newgen ,@(de-compose (car form) '(r))) | |
437 | ,@destrs) | |
438 | vrbls (cons newgen vrbls) | |
439 | vals (cons (cadr form) vals))))) | |
440 | binds) | |
441 | ||
442 | (mapc '(lambda (frm) | |
443 | (do ((ll (cdr frm) (cdr ll))) | |
444 | ((null ll)) | |
445 | (setq vrbls (cons (cdar ll) vrbls) | |
446 | vals (cons nil vals)))) | |
447 | destrs) | |
448 | ||
449 | (setq vals (nreverse vals) | |
450 | vrbls (nreverse vrbls) | |
451 | destrs (nreverse destrs)) | |
452 | `((lambda ,vrbls | |
453 | ,@(mapcan '(lambda (frm) | |
454 | (mapcar '(lambda (vrb) | |
455 | `(setq ,(cdr vrb) (,(car vrb) | |
456 | ,(car frm)))) | |
457 | (cdr frm))) | |
458 | destrs) | |
459 | ,@body) | |
460 | ,@vals)) | |
461 | ||
462 | ;--- de-compose | |
463 | ; form - pattern to de-compose | |
464 | ; sofar - the sequence of cxxr's needed to get to this part | |
465 | ; of the pattern | |
466 | ; de-compose returns a list of this form | |
467 | ; | |
468 | ; ((cxxr . a) (cyyr . b) ... ) | |
469 | ; which tells how to get to the value for a and b ..etc.. | |
470 | ; | |
471 | (def de-compose | |
472 | (lambda (form sofar) | |
473 | (cond ((null form ) nil) | |
474 | ((atom form) (ncons (cons (apply 'concat (cons 'c sofar)) | |
475 | form))) | |
476 | (t (nconc (de-compose (car form) (cons 'a sofar)) | |
477 | (de-compose (cdr form) (cons 'd sofar))))))) | |
478 | ||
479 | ;--- caseq | |
480 | ; use is | |
481 | ; (caseq expr | |
482 | ; (match1 do1) | |
483 | ; (match2 do2) | |
484 | ; (t doifallelsefails)) | |
485 | ; the matchi can be atoms in which case an 'eq' test is done, or they | |
486 | ; can be lists in which case a 'memq' test is done. | |
487 | ; | |
488 | ||
489 | (defmacro caseq (switch &body clauses &aux var code) | |
490 | (setq var (cond ((symbolp switch) switch) ((gensym 'Z)))) | |
491 | (setq code | |
492 | `(cond . ,(mapcar '(lambda (clause) | |
493 | (cons | |
494 | (let ((test (car clause))) | |
495 | (cond ((eq test t) t) | |
496 | ((dtpr test) | |
497 | `(memq ,var ',test)) | |
498 | (t `(eq ,var ',test)))) | |
499 | (cdr clause))) | |
500 | clauses))) | |
501 | (cond ((symbolp switch) code) | |
502 | (`((lambda (,var) ,code) ,switch)))) | |
503 | ||
504 | ;--- selectq :: just like caseq | |
505 | ; except 'otherwise' is recogized as equivalent to 't' as a key | |
506 | ; | |
507 | (defmacro selectq (key . forms) | |
508 | (setq forms | |
509 | (mapcar '(lambda (form) (if (eq (car form) 'otherwise) | |
510 | (cons t (cdr form)) form)) | |
511 | forms)) | |
512 | `(caseq ,key . ,forms)) | |
513 | ||
514 | ;--- let* | |
515 | ; - binds - binding forms (like let) | |
516 | ; - body - forms to eval (like let) | |
517 | ; this is the same as let, except forms are done in a left to right manner | |
518 | ; in fact, all we do is generate nested lets | |
519 | ; | |
520 | (defmacro let* (binds &rest body) | |
521 | (do ((ll (reverse binds) (cdr ll))) | |
522 | ((null ll) (car body)) | |
523 | (setq body `((let (,(car ll)) ,@body))))) | |
524 | ||
525 | ||
526 | ||
527 | ;--- listify : n - integer | |
528 | ; returns a list of the first n args to the enclosing lexpr if | |
529 | ; n is positive, else returns the last -n args to the lexpr if n is | |
530 | ; negative. | |
531 | ; returns nil if n is 0 | |
532 | ; | |
533 | (def listify | |
534 | (macro (lis) | |
535 | `(let ((n ,(cadr lis))) | |
536 | (cond ((eq n 0) nil) | |
537 | ((minusp n) | |
538 | (do ((i (arg nil) (1- i)) | |
539 | (result nil (cons (arg i) result))) | |
540 | ((<& i (+ (arg nil) n 1)) result) )) | |
541 | (t (do ((i n (1- i)) | |
542 | (result nil (cons (arg i) result))) | |
543 | ((<& i 1) result) )))))) | |
544 | ||
545 | ;--- include-if | |
546 | ; form: (include-if <predicate> <filename>) | |
547 | ; will return (include <filename>) if <predicate> is non-nil | |
548 | ; This is useful at the beginning of a file to conditionally | |
549 | ; include a file based on whether it has already been included. | |
550 | ; | |
551 | (defmacro include-if (pred filename) | |
552 | (cond ((eval pred) `(include ,filename)))) | |
553 | ||
554 | ;--- includef-if | |
555 | ; form: (includef-if <predicate> '<filename>) | |
556 | ; like the above except it includef's the file. | |
557 | ; | |
558 | (defmacro includef-if (pred filenameexpr) | |
559 | (cond ((eval pred) `(includef ,filenameexpr)))) | |
560 | ||
561 | ;--- if :: macro for doing conditionalization | |
562 | ; | |
563 | ; This macro is compatible with both the crufty mit-version and | |
564 | ; the keyword version at ucb. | |
565 | ; | |
566 | ; simple summary: | |
567 | ; non-keyword use: | |
568 | ; (if a b) ==> (cond (a b)) | |
569 | ; (if a b c d e ...) ==> (cond (a b) (t c d e ...)) | |
570 | ; with keywords: | |
571 | ; (if a then b) ==> (cond (a b)) | |
572 | ; (if a thenret) ==> (cond (a)) | |
573 | ; (if a then b c d e) ==> (cond (a b c d e)) | |
574 | ; (if a then b c else d) ==> (cond (a b c) (t d)) | |
575 | ; (if a then b c elseif d thenret else g) | |
576 | ; ==> (cond (a b c) (d) (t g)) | |
577 | ; | |
578 | ; | |
579 | ; | |
580 | ; | |
581 | ; In the syntax description below, | |
582 | ; optional parts are surrounded by [ and ], | |
583 | ; + means one or more instances. | |
584 | ; | means 'or' | |
585 | ; <expr> is an lisp expression which isn't a keyword | |
586 | ; The keywords are: then, thenret, else, elseif. | |
587 | ; <pred> is also a lisp expression which isn't a keyword. | |
588 | ; | |
589 | ; <if-stmt> ::= <simple-if-stmt> | |
590 | ; | <keyword-if-stmt> | |
591 | ; | |
592 | ; <simple-if-stmt> ::= (if <pred> <expr>) | |
593 | ; | (if <pred> <expr> <expr>) | |
594 | ; | |
595 | ; <keyword-if-stmt> ::= (if <pred> <then-clause> [ <else-clause> ] ) | |
596 | ; | |
597 | ; <then-clause> ::= then <expr>+ | |
598 | ; | thenret | |
599 | ; | |
600 | ; <else-clause> ::= else <expr>+ | |
601 | ; | elseif <pred> <then-clause> [ <else-clause> ] | |
602 | ; | |
603 | ||
604 | (declare (special if-keyword-list)) | |
605 | ||
606 | (eval-when (compile load eval) | |
607 | (setq if-keyword-list '(then thenret elseif else))) | |
608 | ||
609 | ;--- if | |
610 | ; | |
611 | ; the keyword if expression is parsed using a simple four state | |
612 | ; automaton. The expression is parsed in reverse. | |
613 | ; States: | |
614 | ; init - have parsed a complete predicate, then clause | |
615 | ; col - have collected at least one non keyword in col | |
616 | ; then - have just seen a then, looking for a predicate | |
617 | ; compl - have just seen a predicate after an then, looking | |
618 | ; for elseif or if (i.e. end of forms). | |
619 | ; | |
620 | (defmacro if (&rest args) | |
621 | (let ((len (length args))) | |
622 | ;; first eliminate the non-keyword if macro cases | |
623 | (cond ((<& len 2) | |
624 | (error "if: not enough arguments " args)) | |
625 | ((and (=& len 2) | |
626 | (not (memq (cadr args) if-keyword-list))) | |
627 | `(cond (,(car args) ,(cadr args)))) | |
628 | ; clause if there are not keywords (and len > 2) | |
629 | ((do ((xx args (cdr xx))) | |
630 | ((null xx) t) | |
631 | (cond ((memq (car xx) if-keyword-list) | |
632 | (return nil)))) | |
633 | `(cond (,(car args) ,(cadr args)) | |
634 | (t ,@(cddr args)))) | |
635 | ||
636 | ;; must be an instance of a keyword if macro | |
637 | ||
638 | (t (do ((xx (reverse args) (cdr xx)) | |
639 | (state 'init) | |
640 | (elseseen nil) | |
641 | (totalcol nil) | |
642 | (col nil)) | |
643 | ((null xx) | |
644 | (cond ((eq state 'compl) | |
645 | `(cond ,@totalcol)) | |
646 | (t (error "if: illegal form " args)))) | |
647 | (cond ((eq state 'init) | |
648 | (cond ((memq (car xx) if-keyword-list) | |
649 | (cond ((eq (car xx) 'thenret) | |
650 | (setq col nil | |
651 | state 'then)) | |
652 | (t (error "if: bad keyword " | |
653 | (car xx) args)))) | |
654 | (t (setq state 'col | |
655 | col nil) | |
656 | (push (car xx) col)))) | |
657 | ((eq state 'col) | |
658 | (cond ((memq (car xx) if-keyword-list) | |
659 | (cond ((eq (car xx) 'else) | |
660 | (cond (elseseen | |
661 | (error | |
662 | "if: multiples elses " | |
663 | args))) | |
664 | (setq elseseen t) | |
665 | (setq state 'init) | |
666 | (push `(t ,@col) totalcol)) | |
667 | ((eq (car xx) 'then) | |
668 | (setq state 'then)) | |
669 | (t (error "if: bad keyword " | |
670 | (car xx) args)))) | |
671 | (t (push (car xx) col)))) | |
672 | ((eq state 'then) | |
673 | (cond ((memq (car xx) if-keyword-list) | |
674 | (error "if: keyword at the wrong place " | |
675 | (car xx) args)) | |
676 | (t (setq state 'compl) | |
677 | (push `(,(car xx) ,@col) totalcol)))) | |
678 | ((eq state 'compl) | |
679 | (cond ((not (eq (car xx) 'elseif)) | |
680 | (error "if: missing elseif clause " args))) | |
681 | (setq state 'init)))))))) | |
682 | ||
683 | ;--- If :: the same as 'if' but defined for those programs that still | |
684 | ; use it. | |
685 | ; | |
686 | (putd 'If (getd 'if)) | |
687 | ||
688 | ;--- defvar :: a macro for declaring a variable special | |
689 | ; a variable declared special with defvar will be special when the | |
690 | ; file containing the variable is compiled and also when the file | |
691 | ; containing the defvar is loaded in. Furthermore, you can specify | |
692 | ; an default value for the variable. It will be set to that value | |
693 | ; iff it is unbound | |
694 | ; | |
695 | (defmacro defvar (variable &optional (initial-value nil iv-p) documentation) | |
696 | (if iv-p | |
697 | then `(progn 'compile | |
698 | (eval-when (eval compile load) | |
699 | (eval '(liszt-declare (special ,variable)))) | |
700 | (or (boundp ',variable) (setq ,variable ,initial-value))) | |
701 | else `(eval-when (eval compile load) | |
702 | (eval '(liszt-declare (special ,variable)))))) | |
703 | ||
704 | ||
705 | ||
706 | ||
707 | (defmacro list* (&rest forms) | |
708 | (cond ((null forms) nil) | |
709 | ((null (cdr forms)) (car forms)) | |
710 | (t (construct-list* forms)))) | |
711 | ||
712 | (eval-when (load compile eval) | |
713 | (defun construct-list* (forms) | |
714 | (setq forms (reverse forms)) | |
715 | (do ((forms (cddr forms) (cdr forms)) | |
716 | (return-form `(cons ,(cadr forms) ,(car forms)) | |
717 | `(cons ,(car forms) ,return-form))) | |
718 | ((null forms) return-form)))) | |
719 | ||
720 | ;; (<= a b) --> (not (> a b)) | |
721 | ;; (<= a b c) --> (not (or (> a b) (> b c))) | |
722 | ;; funny arglist to check for correct number of arguments. | |
723 | ||
724 | ||
725 | (defmacro <= (arg1 arg2 &rest rest &aux result) | |
726 | (setq rest (list* arg1 arg2 rest)) | |
727 | (do l rest (cdr l) (null (cdr l)) | |
728 | (push `(> ,(car l) ,(cadr l)) result)) | |
729 | (cond ((null (cdr result)) `(not ,(car result))) | |
730 | (t `(not (or . ,(nreverse result)))))) | |
731 | ||
732 | (defmacro <=& (x y) | |
733 | `(not (>& ,x ,y))) | |
734 | ||
735 | ;; (>= a b) --> (not (< a b)) | |
736 | ;; (>= a b c) --> (not (or (< a b) (< b c))) | |
737 | ;; funny arglist to check for correct number of arguments. | |
738 | ||
739 | (defmacro >= (arg1 arg2 &rest rest &aux result) | |
740 | (setq rest (list* arg1 arg2 rest)) | |
741 | (do l rest (cdr l) (null (cdr l)) | |
742 | (push `(< ,(car l) ,(cadr l)) result)) | |
743 | (cond ((null (cdr result)) `(not ,(car result))) | |
744 | (t `(not (or . ,(nreverse result)))))) | |
745 | ||
746 | ||
747 | (defmacro >=& (x y) | |
748 | `(not (<& ,x ,y))) |