"$Header: macros.l.l 1.2 83/06/09 01:42:51 jkf Exp $")
;; macros.l -[Wed May 25 12:07:00 1983 by jkf]-
;; The file contains the common macros for Franz lisp.
(declare (special defmacrooptlist protect-list protect-evform))
;--- defmacro - name - name of macro being defined
; - pattrn - formal arguments plus other fun stuff
; - body - body of the macro
; This is an intellegent macro creator. The pattern may contain
; symbols which are formal paramters, lists which show how the
; actual paramters will appear in the args, and these key words
; &rest name - the rest of the args (or nil if there are no other args)
; &optional name - bind the next arg to name if it exists, otherwise
; &optional (name init) - bind the next arg to name if it exists, otherwise
; bind it to init evaluted. (the evaluation is done left
; to right for optional forms)
; &optional (name init given) - bind the next arg to name and given to t
; if the arg exists, else bind name to the value of
; the list returned from defmcrosrc has the form ((cxxr name) ...)
; where cxxr is the loc of the macro arg and name is it formal name
; defmcrooptlist has the form ((initv cxxr name) ...)
; which is use for &optional args with an initial value.
; here cxxr looks like cdd..dr which will test of the arg exists.
; the variable defmacro-for-compiling determines if the defmacro forms
; will be compiled. If it is t, then we return (progn 'compile (def xx..))
; to insure that it is compiled
(declare (special defmacro-for-compiling))
(cond ((null (boundp 'defmacro-for-compiling)) ; insure it has a value
(setq defmacro-for-compiling nil)))
(tmp tmp2 defmacrooptlist body protect-evform protect-list gutz)
(setq tmp (defmcrosrch (caddr args) '(d r) nil)
((lambda ,(mapcar 'cdr tmp)
`(cond ((setq ,(caddr arg)
,@(cond ((setq tmp2 (cadddr arg))
(eval `((lambda ,(mapcar 'cdr tmp)
`((lambda ,',(mapcar 'cdr tmp)
`(,(car arg) defmacroarg))))
(cond (defmacro-for-compiling `(progn 'compile ,body))
nil nil nil nil nil nil nil)))
((atom pat) (cons (cons (concatl `(c ,@form)) pat)
((memq (car pat) '(&rest &body))
(append (defmcrosrch (cadr pat) form nil)
(defmcrosrch (cddr pat) form sofar)))
((eq (car pat) '&optional)
(defmcrooption (cdr pat) form sofar))
((eq (car pat) '&protect)
(setq protect-list (cond ((atom (cadr pat))
protect-evform (cons 'or (mapcar '(lambda (x)
(defmcrosrch (cddr pat) form sofar))
(cond ((atom frm) `((nil) . ,frm))
(t `((,(cadr frm)) . ,(car frm)))))
(t (append (defmcrosrch (car pat) (cons 'a form) nil)
(defmcrosrch (cdr pat) (cons 'd form) sofar))))))
((memq (car pat) '(&rest &body))
(defmcrosrch (cadr pat) form sofar))
(t (cond ((atom (car pat))
,(setq tmp2 (caddar pat)))
`( (,(concatl `(ca ,@form)) . ,tmp)
,@(cond (tmp2 `((nil . ,tmp2))))
;--- lambdacvt :: new lambda converter.
; - input is a lambda body beginning with the argument list.
; vrbls :: list of (name n) where n is the arg number for name
; optlist :: list of (name n defval pred) where optional variable name is
; (arg n) [if it exists], initval is the value if it doesn't
; exist, pred is set to non nil if the arg exists
; auxlist :: list of (name initial-value) for auxillary variables. (&aux)
; restform :: (name n) where args n to #args should be consed and assigned
; Until the compiler can compiler lexprs better, we try to avoid creating
; a lexpr. A lexpr is only required if &optional or &rest forms
; Formal parameters which come after &aux are bound and evaluated in a let*
; surrounding the body. The parameter after a &rest is put in the let*
; too, with an init form which is a complex do loop. The parameters
; after &optional are put in the lambda expression just below the lexpr.
(prog (vrbls optlist auxlist restform vbl fl-type optcode mainvar
(do ((reallist (car exp) (cdr reallist))
(setq vbl (car reallist))
(cond ((memq vbl '(&rest &body))
(setq fl-type '&rest count (1- count)))
(setq fl-type '&aux count (1- count)))
(setq fl-type '&optional count (1- count)))
((null fl-type) ; just a variable
(setq vrbls (cons (list vbl count) vrbls)))
(cond (restform (error "Too many &rest parameters " vbl)))
(setq restform (list vbl count)))
(setq auxlist (cons (list vbl nil) auxlist)))
(t (setq auxlist (cons (list (car vbl) (cadr vbl))
(cons (list vbl count) optlist)))
;; arguments are collected in reverse order, but set them straight
(setq vrbls (nreverse vrbls)
optlist (nreverse optlist)
auxlist (nreverse auxlist)
maxargs (cond (restform nil)
(t (+ (length optlist) minargs))))
;; we must covert to a lexpr if there are &optional or &rest forms
(cond ((or optlist restform) (setq mainvar (gensym))))
; generate optionals code
`(cond ((> ,(cadr x) ,mainvar)
(setq ,(car x) ,(caddr x)))
`(setq ,(cadddr x) t))))))
(do ((,dumind ,mainvar (1- ,dumind))
(,dumcol nil (cons (arg ,dumind) ,dumcol)))
((< ,dumind ,(cadr restform)) ,dumcol))))))))
(setq body (cond ((or auxlist restform)
`((let* ,(append restform auxlist)
(cond ((null mainvar) ; no &optional or &rest
(return `(lambda ,(mapcar 'car vrbls)
(declare (*args ,minargs ,maxargs))
(declare (*args ,minargs ,maxargs))
(mapcan '(lambda (x) ; may be two vrbls
,@(nconc (mapcar '(lambda (x) `(arg ,(cadr x)))
;--- defcmacro :: like defmacro but result ends up under cmacro ind
(let ((name (concat (cadr args) "::cmacro:" (gensym))))
`(eval-when (compile load eval)
(defmacro ,name ,@(cddr args))
(putprop ',(cadr args) (getd ',name) 'cmacro)
; let for franz (with destructuring)
; - binds - binding forms
; - . body - forms to execute
; the binding forms may have these forms
; a local variable a, initially nil
; (a x) local variable a, x is evaled and a gets its value initially
; ((a . (b . c)) x) three local variables, a,b and c which are given
; values corresponding to the location in the value
; of x. Any structure is allowed here.
(defmacro let (binds &rest body &aux vrbls vals destrs newgen)
(setq vrbls (cons form vrbls)
(setq vrbls (cons (car form) vrbls)
vals (cons (cadr form) vals)))
destrs `((,newgen ,@(de-compose (car form) '(r)))
vrbls (cons newgen vrbls)
vals (cons (cadr form) vals)))))
(do ((ll (cdr frm) (cdr ll)))
(setq vrbls (cons (cdar ll) vrbls)
(setq vals (nreverse vals)
destrs (nreverse destrs))
`(setq ,(cdr vrb) (,(car vrb)
; form - pattern to de-compose
; sofar - the sequence of cxxr's needed to get to this part
; de-compose returns a list of this form
; ((cxxr . a) (cyyr . b) ... )
; which tells how to get to the value for a and b ..etc..
((atom form) (ncons (cons (apply 'concat (cons 'c sofar))
(t (nconc (de-compose (car form) (cons 'a sofar))
(de-compose (cdr form) (cons 'd sofar)))))))
; the matchi can be atoms in which case an 'eq' test is done, or they
; can be lists in which case a 'memq' test is done.
(defmacro caseq (switch &body clauses &aux var code)
(setq var (cond ((symbolp switch) switch) ((gensym 'Z))))
`(cond . ,(mapcar '(lambda (clause)
(let ((test (car clause)))
(cond ((symbolp switch) code)
(`((lambda (,var) ,code) ,switch))))
;--- selectq :: just like caseq
; except 'otherwise' is recogized as equivalent to 't' as a key
(defmacro selectq (key . forms)
(mapcar '(lambda (form) (if (eq (car form) 'otherwise)
(cons t (cdr form)) form))
; - binds - binding forms (like let)
; - body - forms to eval (like let)
; this is the same as let, except forms are done in a left to right manner
; in fact, all we do is generate nested lets
(defmacro let* (binds &rest body)
(do ((ll (reverse binds) (cdr ll)))
(setq body `((let (,(car ll)) ,@body)))))
;--- listify : n - integer
; returns a list of the first n args to the enclosing lexpr if
; n is positive, else returns the last -n args to the lexpr if n is
(do ((i (arg nil) (1- i))
(result nil (cons (arg i) result)))
((<& i (+ (arg nil) n 1)) result) ))
(result nil (cons (arg i) result)))
; form: (include-if <predicate> <filename>)
; will return (include <filename>) if <predicate> is non-nil
; This is useful at the beginning of a file to conditionally
; include a file based on whether it has already been included.
(defmacro include-if (pred filename)
(cond ((eval pred) `(include ,filename))))
; form: (includef-if <predicate> '<filename>)
; like the above except it includef's the file.
(defmacro includef-if (pred filenameexpr)
(cond ((eval pred) `(includef ,filenameexpr))))
;--- if :: macro for doing conditionalization
; This macro is compatible with both the crufty mit-version and
; the keyword version at ucb.
; (if a b) ==> (cond (a b))
; (if a b c d e ...) ==> (cond (a b) (t c d e ...))
; (if a then b) ==> (cond (a b))
; (if a thenret) ==> (cond (a))
; (if a then b c d e) ==> (cond (a b c d e))
; (if a then b c else d) ==> (cond (a b c) (t d))
; (if a then b c elseif d thenret else g)
; ==> (cond (a b c) (d) (t g))
; In the syntax description below,
; optional parts are surrounded by [ and ],
; + means one or more instances.
; <expr> is an lisp expression which isn't a keyword
; The keywords are: then, thenret, else, elseif.
; <pred> is also a lisp expression which isn't a keyword.
; <if-stmt> ::= <simple-if-stmt>
; <simple-if-stmt> ::= (if <pred> <expr>)
; | (if <pred> <expr> <expr>)
; <keyword-if-stmt> ::= (if <pred> <then-clause> [ <else-clause> ] )
; <then-clause> ::= then <expr>+
; <else-clause> ::= else <expr>+
; | elseif <pred> <then-clause> [ <else-clause> ]
(declare (special if-keyword-list))
(eval-when (compile load eval)
(setq if-keyword-list '(then thenret elseif else)))
; the keyword if expression is parsed using a simple four state
; automaton. The expression is parsed in reverse.
; init - have parsed a complete predicate, then clause
; col - have collected at least one non keyword in col
; then - have just seen a then, looking for a predicate
; compl - have just seen a predicate after an then, looking
; for elseif or if (i.e. end of forms).
(defmacro if (&rest args)
(let ((len (length args)))
;; first eliminate the non-keyword if macro cases
(error "if: not enough arguments " args))
(not (memq (cadr args) if-keyword-list)))
`(cond (,(car args) ,(cadr args))))
; clause if there are not keywords (and len > 2)
((do ((xx args (cdr xx)))
(cond ((memq (car xx) if-keyword-list)
`(cond (,(car args) ,(cadr args))
;; must be an instance of a keyword if macro
(t (do ((xx (reverse args) (cdr xx))
(t (error "if: illegal form " args))))
(cond ((memq (car xx) if-keyword-list)
(cond ((eq (car xx) 'thenret)
(t (error "if: bad keyword "
(cond ((memq (car xx) if-keyword-list)
(cond ((eq (car xx) 'else)
(push `(t ,@col) totalcol))
(t (error "if: bad keyword "
(t (push (car xx) col))))
(cond ((memq (car xx) if-keyword-list)
(error "if: keyword at the wrong place "
(push `(,(car xx) ,@col) totalcol))))
(cond ((not (eq (car xx) 'elseif))
(error "if: missing elseif clause " args)))
(setq state 'init))))))))
;--- If :: the same as 'if' but defined for those programs that still
;--- defvar :: a macro for declaring a variable special
; a variable declared special with defvar will be special when the
; file containing the variable is compiled and also when the file
; containing the defvar is loaded in. Furthermore, you can specify
; an default value for the variable. It will be set to that value
(defmacro defvar (variable &optional (initial-value nil iv-p) documentation)
(eval-when (eval compile load)
(eval '(liszt-declare (special ,variable))))
(or (boundp ',variable) (setq ,variable ,initial-value)))
else `(eval-when (eval compile load)
(eval '(liszt-declare (special ,variable))))))