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