![[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] / 42BSD / ucb / lisp / lisplib|
Return to macros.l CVS log | Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / lisplib |
1.1 root 1: (setq rcs-macros-
2: "$Header: macros.l,v 1.4 83/09/12 15:24:08 layer Exp $")
3:
4: ;; macros.l -[Mon Aug 15 10:41:25 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: (or (symbolp (car expr))
298: (error '|-- setf can't handle this.| expr))
299: (and (setq y (get (car expr) 'setf-expand))
300: (return (apply y `(,expr ,val ,@rest))))
301: (or (setf-check-cad+r (car expr))
302: (and
303: (or (setq y (get (car expr) 'cmacro))
304: (setq y (getd (car expr))))
305: (or (and (dtpr y)
306: (eq (car y) 'macro))
307: (and (bcdp y)
308: (eq (getdisc y) 'macro)))
309: (setq expr (apply y expr)))
310: (error '|-- setf can't handle this.| expr))))))
311:
312: (defun setf-check-cad+r (name)
313: (if (eq (getcharn name 1) #/c)
314: then (let ((letters (nreverse (cdr (exploden name)))))
315: (if (eq (car letters) #/r)
316: then (do ((xx (cdr letters) (cdr xx)))
317: ((null xx)
318: ;; form is c{ad}+r, setf form is
319: ;; (rplac<first a or d> (c<rest of a's + d's>r x))
320: (setq letters (nreverse letters))
321: (eval
322: `(defsetf ,name (e v)
323: (list
324: ',(concat "rplac" (ascii (car letters)))
325: (list
326: ',(implode `(#/c ,@(cdr letters)))
327: (cadr e))
328: v)))
329: t)
330: (if (not (memq (car xx) '(#/a #/d)))
331: then (return nil)))))))
332:
333: (defmacro defsetf (name vars &rest body)
334: `(eval-when
335: (compile load eval)
336: (defun (,name setf-expand) ,vars . ,body)))
337:
338: ;--- other setf's for car's and cdr's are generated automatically
339: ;
340: (defsetf car (e v) `(rplaca ,(cadr e) ,v))
341: (defsetf caar (e v) `(rplaca (car ,(cadr e)) ,v))
342: (defsetf cadr (e v) `(rplaca (cdr ,(cadr e)) ,v))
343: (defsetf cdr (e v) `(rplacd ,(cadr e) ,v))
344: (defsetf cdar (e v) `(rplacd (car ,(cadr e)) ,v))
345: (defsetf cddr (e v) `(rplacd (cdr ,(cadr e)) ,v))
346: (defsetf cxr (e v) `(rplacx ,(cadr e) ,(caddr e) ,v))
347:
348: (defsetf vref (e v) `(vset ,(cadr e) ,(caddr e) ,v))
349: (defsetf vrefi-byte (e v) `(vseti-byte ,(cadr e) ,(caddr e) ,v))
350: (defsetf vrefi-word (e v) `(vseti-word ,(cadr e) ,(caddr e) ,v))
351: (defsetf vrefi-long (e v) `(vseti-long ,(cadr e) ,(caddr e) ,v))
352:
353: (defsetf nth (e v) `(rplaca (nthcdr ,(cadr e) ,(caddr e)) ,v))
354: (defsetf nthelem (e v) `(rplaca (nthcdr (1- ,(cadr e)) ,(caddr e)) ,v))
355: (defsetf nthcdr (e v) `(rplacd (nthcdr (1- ,(cadr e)) ,(caddr e)) ,v))
356:
357: (defsetf arraycall (e v) `(store ,e ,v))
358: (defsetf get (e v) `(putprop ,(cadr e) ,v ,(caddr e)))
359:
360: (defsetf plist (e v) `(setplist ,(cadr e) ,v))
361:
362: (defsetf symeval (e v) `(set ,(cadr e) ,v))
363:
364: (defsetf arg (e v) `(setarg ,(cadr e) ,v))
365:
366: (defsetf args (e v) `(args ,(cadr e) ,v))
367:
368:
369: (defmacro push (object list) `(setf ,list (cons ,object ,list)))
370:
371: ; this relies on the fact that setf returns the value stored.
372: (defmacro pop (list &optional (into nil into-p))
373: (cond (into-p `(prog1 (setf ,into (car ,list))
374: (setf ,list (cdr ,list))))
375: (t `(prog1 (car ,list)
376: (setf ,list (cdr ,list))))))
377:
378: ; let for franz (with destructuring)
379: ;--- let
380: ; - binds - binding forms
381: ; - . body - forms to execute
382: ; the binding forms may have these forms
383: ; a local variable a, initially nil
384: ; (a x) local variable a, x is evaled and a gets its value initially
385: ; ((a . (b . c)) x) three local variables, a,b and c which are given
386: ; values corresponding to the location in the value
387: ; of x. Any structure is allowed here.
388: ;
389: (defmacro let (binds &rest body &aux vrbls vals destrs newgen)
390: (mapc '(lambda (form)
391: (cond ((atom form)
392: (setq vrbls (cons form vrbls)
393: vals (cons nil vals)))
394: ((atom (car form))
395: (setq vrbls (cons (car form) vrbls)
396: vals (cons (cadr form) vals)))
397: (t (setq newgen (gensym)
398: destrs `((,newgen ,@(de-compose (car form) '(r)))
399: ,@destrs)
400: vrbls (cons newgen vrbls)
401: vals (cons (cadr form) vals)))))
402: binds)
403:
404: (mapc '(lambda (frm)
405: (do ((ll (cdr frm) (cdr ll)))
406: ((null ll))
407: (setq vrbls (cons (cdar ll) vrbls)
408: vals (cons nil vals))))
409: destrs)
410:
411: (setq vals (nreverse vals)
412: vrbls (nreverse vrbls)
413: destrs (nreverse destrs))
414: `((lambda ,vrbls
415: ,@(mapcan '(lambda (frm)
416: (mapcar '(lambda (vrb)
417: `(setq ,(cdr vrb) (,(car vrb)
418: ,(car frm))))
419: (cdr frm)))
420: destrs)
421: ,@body)
422: ,@vals))
423:
424: ;--- de-compose
425: ; form - pattern to de-compose
426: ; sofar - the sequence of cxxr's needed to get to this part
427: ; of the pattern
428: ; de-compose returns a list of this form
429: ;
430: ; ((cxxr . a) (cyyr . b) ... )
431: ; which tells how to get to the value for a and b ..etc..
432: ;
433: (def de-compose
434: (lambda (form sofar)
435: (cond ((null form ) nil)
436: ((atom form) (ncons (cons (apply 'concat (cons 'c sofar))
437: form)))
438: (t (nconc (de-compose (car form) (cons 'a sofar))
439: (de-compose (cdr form) (cons 'd sofar)))))))
440:
441: ;--- caseq
442: ; use is
443: ; (caseq expr
444: ; (match1 do1)
445: ; (match2 do2)
446: ; (t doifallelsefails))
447: ; the matchi can be atoms in which case an 'eq' test is done, or they
448: ; can be lists in which case a 'memq' test is done.
449: ;
450:
451: (defmacro caseq (switch &body clauses &aux var code)
452: (setq var (cond ((symbolp switch) switch) ((gensym 'Z))))
453: (setq code
454: `(cond . ,(mapcar '(lambda (clause)
455: (cons
456: (let ((test (car clause)))
457: (cond ((eq test t) t)
458: ((dtpr test)
459: `(memq ,var ',test))
460: (t `(eq ,var ',test))))
461: (cdr clause)))
462: clauses)))
463: (cond ((symbolp switch) code)
464: (`((lambda (,var) ,code) ,switch))))
465:
466: ;--- selectq :: just like caseq
467: ; except 'otherwise' is recogized as equivalent to 't' as a key
468: ;
469: (defmacro selectq (key . forms)
470: (setq forms
471: (mapcar '(lambda (form) (if (eq (car form) 'otherwise)
472: (cons t (cdr form)) form))
473: forms))
474: `(caseq ,key . ,forms))
475:
476: ;--- let*
477: ; - binds - binding forms (like let)
478: ; - body - forms to eval (like let)
479: ; this is the same as let, except forms are done in a left to right manner
480: ; in fact, all we do is generate nested lets
481: ;
482: (defmacro let* (binds &rest body)
483: (do ((ll (reverse binds) (cdr ll)))
484: ((null ll) (car body))
485: (setq body `((let (,(car ll)) ,@body)))))
486:
487:
488:
489: ;--- listify : n - integer
490: ; returns a list of the first n args to the enclosing lexpr if
491: ; n is positive, else returns the last -n args to the lexpr if n is
492: ; negative.
493: ; returns nil if n is 0
494: ;
495: (def listify
496: (macro (lis)
497: `(let ((n ,(cadr lis)))
498: (cond ((eq n 0) nil)
499: ((minusp n)
500: (do ((i (arg nil) (1- i))
501: (result nil (cons (arg i) result)))
502: ((<& i (+ (arg nil) n 1)) result) ))
503: (t (do ((i n (1- i))
504: (result nil (cons (arg i) result)))
505: ((<& i 1) result) ))))))
506:
507: ;--- include-if
508: ; form: (include-if <predicate> <filename>)
509: ; will return (include <filename>) if <predicate> is non-nil
510: ; This is useful at the beginning of a file to conditionally
511: ; include a file based on whether it has already been included.
512: ;
513: (defmacro include-if (pred filename)
514: (cond ((eval pred) `(include ,filename))))
515:
516: ;--- includef-if
517: ; form: (includef-if <predicate> '<filename>)
518: ; like the above except it includef's the file.
519: ;
520: (defmacro includef-if (pred filenameexpr)
521: (cond ((eval pred) `(includef ,filenameexpr))))
522:
523: ;--- if :: macro for doing conditionalization
524: ;
525: ; This macro is compatible with both the crufty mit-version and
526: ; the keyword version at ucb.
527: ;
528: ; simple summary:
529: ; non-keyword use:
530: ; (if a b) ==> (cond (a b))
531: ; (if a b c d e ...) ==> (cond (a b) (t c d e ...))
532: ; with keywords:
533: ; (if a then b) ==> (cond (a b))
534: ; (if a thenret) ==> (cond (a))
535: ; (if a then b c d e) ==> (cond (a b c d e))
536: ; (if a then b c else d) ==> (cond (a b c) (t d))
537: ; (if a then b c elseif d thenret else g)
538: ; ==> (cond (a b c) (d) (t g))
539: ;
540: ;
541: ;
542: ;
543: ; In the syntax description below,
544: ; optional parts are surrounded by [ and ],
545: ; + means one or more instances.
546: ; | means 'or'
547: ; <expr> is an lisp expression which isn't a keyword
548: ; The keywords are: then, thenret, else, elseif.
549: ; <pred> is also a lisp expression which isn't a keyword.
550: ;
551: ; <if-stmt> ::= <simple-if-stmt>
552: ; | <keyword-if-stmt>
553: ;
554: ; <simple-if-stmt> ::= (if <pred> <expr>)
555: ; | (if <pred> <expr> <expr>)
556: ;
557: ; <keyword-if-stmt> ::= (if <pred> <then-clause> [ <else-clause> ] )
558: ;
559: ; <then-clause> ::= then <expr>+
560: ; | thenret
561: ;
562: ; <else-clause> ::= else <expr>+
563: ; | elseif <pred> <then-clause> [ <else-clause> ]
564: ;
565:
566: (declare (special if-keyword-list))
567:
568: (eval-when (compile load eval)
569: (setq if-keyword-list '(then thenret elseif else)))
570:
571: ;--- if
572: ;
573: ; the keyword if expression is parsed using a simple four state
574: ; automaton. The expression is parsed in reverse.
575: ; States:
576: ; init - have parsed a complete predicate, then clause
577: ; col - have collected at least one non keyword in col
578: ; then - have just seen a then, looking for a predicate
579: ; compl - have just seen a predicate after an then, looking
580: ; for elseif or if (i.e. end of forms).
581: ;
582: (defmacro if (&rest args)
583: (let ((len (length args)))
584: ;; first eliminate the non-keyword if macro cases
585: (cond ((<& len 2)
586: (error "if: not enough arguments " args))
587: ((and (=& len 2)
588: (not (memq (cadr args) if-keyword-list)))
589: `(cond (,(car args) ,(cadr args))))
590: ; clause if there are not keywords (and len > 2)
591: ((do ((xx args (cdr xx)))
592: ((null xx) t)
593: (cond ((memq (car xx) if-keyword-list)
594: (return nil))))
595: `(cond (,(car args) ,(cadr args))
596: (t ,@(cddr args))))
597:
598: ;; must be an instance of a keyword if macro
599:
600: (t (do ((xx (reverse args) (cdr xx))
601: (state 'init)
602: (elseseen nil)
603: (totalcol nil)
604: (col nil))
605: ((null xx)
606: (cond ((eq state 'compl)
607: `(cond ,@totalcol))
608: (t (error "if: illegal form " args))))
609: (cond ((eq state 'init)
610: (cond ((memq (car xx) if-keyword-list)
611: (cond ((eq (car xx) 'thenret)
612: (setq col nil
613: state 'then))
614: (t (error "if: bad keyword "
615: (car xx) args))))
616: (t (setq state 'col
617: col nil)
618: (push (car xx) col))))
619: ((eq state 'col)
620: (cond ((memq (car xx) if-keyword-list)
621: (cond ((eq (car xx) 'else)
622: (cond (elseseen
623: (error
624: "if: multiples elses "
625: args)))
626: (setq elseseen t)
627: (setq state 'init)
628: (push `(t ,@col) totalcol))
629: ((eq (car xx) 'then)
630: (setq state 'then))
631: (t (error "if: bad keyword "
632: (car xx) args))))
633: (t (push (car xx) col))))
634: ((eq state 'then)
635: (cond ((memq (car xx) if-keyword-list)
636: (error "if: keyword at the wrong place "
637: (car xx) args))
638: (t (setq state 'compl)
639: (push `(,(car xx) ,@col) totalcol))))
640: ((eq state 'compl)
641: (cond ((not (eq (car xx) 'elseif))
642: (error "if: missing elseif clause " args)))
643: (setq state 'init))))))))
644:
645: ;--- If :: the same as 'if' but defined for those programs that still
646: ; use it.
647: ;
648: (putd 'If (getd 'if))
649:
650: ;--- defvar :: a macro for declaring a variable special
651: ; a variable declared special with defvar will be special when the
652: ; file containing the variable is compiled and also when the file
653: ; containing the defvar is loaded in. Furthermore, you can specify
654: ; an default value for the variable. It will be set to that value
655: ; iff it is unbound
656: ;
657: (defmacro defvar (variable &optional (initial-value nil iv-p) documentation)
658: (if iv-p
659: then `(progn 'compile
660: (eval-when (eval compile load)
661: (eval '(liszt-declare (special ,variable))))
662: (or (boundp ',variable) (setq ,variable ,initial-value)))
663: else `(eval-when (eval compile load)
664: (eval '(liszt-declare (special ,variable))))))
665:
666:
667:
668:
669: (defmacro list* (&rest forms)
670: (cond ((null forms) nil)
671: ((null (cdr forms)) (car forms))
672: (t (construct-list* forms))))
673:
674: (eval-when (load compile eval)
675: (defun construct-list* (forms)
676: (setq forms (reverse forms))
677: (do ((forms (cddr forms) (cdr forms))
678: (return-form `(cons ,(cadr forms) ,(car forms))
679: `(cons ,(car forms) ,return-form)))
680: ((null forms) return-form))))
681:
682: ;; (<= a b) --> (not (> a b))
683: ;; (<= a b c) --> (not (or (> a b) (> b c)))
684: ;; funny arglist to check for correct number of arguments.
685:
686:
687: (defmacro <= (arg1 arg2 &rest rest &aux result)
688: (setq rest (list* arg1 arg2 rest))
689: (do l rest (cdr l) (null (cdr l))
690: (push `(> ,(car l) ,(cadr l)) result))
691: (cond ((null (cdr result)) `(not ,(car result)))
692: (t `(not (or . ,(nreverse result))))))
693:
694: (defmacro <=& (x y)
695: `(not (>& ,x ,y)))
696:
697: ;; (>= a b) --> (not (< a b))
698: ;; (>= a b c) --> (not (or (< a b) (< b c)))
699: ;; funny arglist to check for correct number of arguments.
700:
701: (defmacro >= (arg1 arg2 &rest rest &aux result)
702: (setq rest (list* arg1 arg2 rest))
703: (do l rest (cdr l) (null (cdr l))
704: (push `(< ,(car l) ,(cadr l)) result))
705: (cond ((null (cdr result)) `(not ,(car result)))
706: (t `(not (or . ,(nreverse result))))))
707:
708:
709: (defmacro >=& (x y)
710: `(not (<& ,x ,y)))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.