Trailing-Edge
-
PDP-10 Archives
-
clisp
-
clisp/upsala/defmacro.clisp
There are no other files named defmacro.clisp in the archive.
;;; This is a -*-Lisp-*- file.
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;; This file contains the DEFMACRO function that is part of the
;;; standard Spice Lisp environment.
;;; Written by Scott Fahlman.
;;; Ugly code, since I can't create macros here and need to stay close to
;;; Maclisp, so that it will be easy to create a derivitive version to use
;;; in the cross compiler. Even without this, there's so much going on
;;; in the arglist that the code has to be hairy.
;;; *******************************************************************
(in-package 'lisp)
(export '(defmacro deftype))
;;; The following specials are used for communication during argument-list
;;; parsing for a macro or macro-like form.
(proclaim '(special %arg-count %min-args %restp %let-list
%keyword-tests *keyword-package*))
;;; The following is an ugly way of getting an optional arg passed in to
;;; Analyze1.
(defvar *default-default* nil)
(defvar *key-finder* 'find-keyword)
;;; ANALYZE-ARGLIST is implemented as a finite-state machine that steps
;;; through the legal parts of an arglist in order: required, optional,
;;; rest, key, and aux. The results are accumulated in a set of special
;;; variables: %let-list, %arg-count, %min-args, %restp, and %keyword-tests.
(defun analyze-arglist (arglist path errloc whole)
"For use by macros and macro-like forms that must parse some form
according to a lambda-like argument list, ARGLIST. The result is
a list of variable-value pairs suitable for inclusion in a LET* form.
PATH is an access expression for getting to the object to be parsed.
ERRLOC is the name of the function being worked on, for use in error
messages. WHOLE is the form to supply if there is an &whole in the
arglist, or NIL if &whole is illegal."
(let ((%arg-count 0) (%min-args 0)
(%restp nil) (%let-list nil)
(%keyword-tests nil))
(analyze1 arglist path errloc whole)
(nreverse %let-list)))
;;; ANALYZE1 is called by ANALYZE-ARGLIST to do the work for required and
;;; optional args. It calls other functions if &rest, &key, or &aux are
;;; encountered. Uses %arg-count, %min-args, %restp, and %let-list.
(defun analyze1 (arglist path errloc whole)
(do ((args arglist (cdr args))
(optionalp nil)
a temp)
((atom args)
(cond ((null args) nil)
;; Varlist is dotted, treat as &rest arg and exit.
(t (push (list args path) %let-list)
(setq %restp t))))
(setq a (car args))
(cond ((eq a '&whole)
(cond ((and whole (cdr args) (symbolp (cadr args)))
(push (list (cadr args) whole) %let-list)
(setq %restp t)
(setq args (cdr args)))
(t (error "Illegal or ill-formed &whole arg in ~S." errloc))))
((eq a '&optional)
(and optionalp
(cerror "Ignore it."
"Redundant &optional flag in varlist of ~S." errloc))
(setq optionalp t))
((or (eq a '&rest) (eq a '&body))
(return (analyze-rest (cdr args) path errloc whole)))
((eq a '&key)
;; Create a rest-arg, then do keyword analysis.
(setq temp (gensym))
(setq %restp t)
(push (list temp path) %let-list)
(return (analyze-key (cdr args) temp errloc)))
((eq a '&allow-other-keys)
(cerror "Ignore it."
"Stray &ALLOW-OTHER-KEYS in arglist of ~S." errloc))
((eq a '&aux)
(return (analyze-aux (cdr args) errloc)))
((not optionalp)
(setq %min-args (1+ %min-args))
(setq %arg-count (1+ %arg-count))
(cond ((symbolp a)
(push `(,a (car ,path)) %let-list))
((atom a)
(cerror "Ignore this item."
"Non-symbol variable name in ~S." errloc))
(t (let ((%min-args 0) (%arg-count 0) (%restp nil))
(analyze1 a `(car ,path) errloc nil))))
(setq path `(cdr ,path)))
;; It's an optional arg.
(t (setq %arg-count (1+ %arg-count))
(cond ((symbolp a)
;; Just a symbol. Bind to car of path or NIL.
(push `(,a (cond (,path (car ,path))
(t ,*default-default*)))
%let-list))
((atom a)
(cerror "Ignore this item."
"Non-symbol variable name in ~S." errloc))
((symbolp (car a))
;; Car of list is a symbol. Bind to car of path or
;; to default value.
(push `(,(car a)
(cond (,path (car ,path))
(t ,(cond ((> (length a) 1) (cadr a))
(t *default-default*)))))
%let-list)
;; Handle supplied-p variable, if any.
(and (> (length a) 2)
(push `(,(caddr a) (not (null ,path))) %let-list)))
;; Then destructure arg against contents of this gensym.
(t (setq temp (gensym))
(push `(,temp
(cond (,path (car ,path))
(t ,(cond ((cddr a) (cadr a))
(t *default-default*)))))
%let-list)
(let ((%min-args 0) (%arg-count 0) (%restp nil))
(analyze1 (car a) temp errloc nil))
;; Handle supplied-p variable if any.
(and (> (length a) 2)
(push `(,(caddr a) (not (null ,path))) %let-list))))
(setq path `(cdr ,path))))))
;;; This deals with the portion of the arglist following any &rest flag.
(defun analyze-rest (arglist path errloc whole)
(cond ((or (atom arglist)
(not (symbolp (car arglist))))
(error "Bad &rest or &body arg in ~S." errloc)))
(push (list (car arglist) path) %let-list)
(setq %restp t)
(prog ((rest-arg (car arglist))
(more (cdr arglist)))
TRY-AGAIN
(cond ((null more) nil)
((atom more)
(cerror "Ignore the illegal terminator."
"Dotted arglist terminator after &rest arg in ~S." errloc))
((eq (car more) '&key)
(analyze-key (cdr more) rest-arg errloc))
((eq (car more) '&aux)
(analyze-aux (cdr more) errloc))
((eq (car more) '&allow-other-keys)
(cerror "Ignore it."
"Stray &ALLOW-OTHER-KEYS in arglist of ~S." errloc))
((eq (cadr arglist) '&whole)
(cond ((and whole (cdr more) (symbolp (cadr more)))
(push (list (cadr more) whole) %let-list)
(setq more (cddr more))
(go try-again))
(t (error "Ill-formed or illegal &whole arg in ~S."
errloc)))))))
;;; Analyze stuff following &aux.
(defun analyze-aux (arglist errloc)
(do ((args arglist (cdr args)))
((null args))
(cond ((atom args)
(cerror "Ignore the illegal terminator."
"Dotted arglist after &AUX in ~S." errloc)
(return nil))
((atom (car args))
(push (list (car args) nil) %let-list))
(t (push (list (caar args) (cadar args)) %let-list)))))
;;; Handle analysis of keywords, perhaps with destructuring over the keyword
;;; variable. Assumes the remainder of the calling form has already been
;;; bound to the variable passed in as RESTVAR.
(defun analyze-key (arglist restvar errloc)
(let ((temp (gensym))
(check-keywords t)
(keywords-seen nil))
(push temp %let-list)
(do ((args arglist (cdr args))
a k sp-var temp1)
((atom args)
(cond ((null args) nil)
(t (cerror "Ignore the illegal terminator."
"Dotted arglist after &key in ~S." errloc))))
(setq a (car args))
(cond ((eq a '&allow-other-keys)
(setq check-keywords nil))
((eq a '&aux)
(return (analyze-aux (cdr args) errloc)))
;; Just a top-level variable. Make matching keyword.
((symbolp a)
(setq k (make-keyword a))
(push `(,a (cond ((setq ,temp (,*key-finder* ',k ,restvar))
(car ,temp))
(t nil)))
%let-list)
(push k keywords-seen))
;; Filter out error that might choke defmacro.
((atom a)
(cerror "Ignore this item."
"~S -- non-symbol variable name in arglist of ~S."
a errloc))
;; Deal with the common case: (var [init [svar]])
((symbolp (car a))
(setq k (make-keyword (car a)))
;; Deal with supplied-p variable, if any.
(cond ((and (cddr a) (symbolp (caddr a)))
(setq sp-var (caddr a))
(push (list sp-var nil) %let-list))
(t (setq sp-var nil)))
(push `(,(car a)
(cond ((setq ,temp (,*key-finder* ',k ,restvar))
,@(and sp-var `((setq ,sp-var t)))
(car ,temp))
(t ,(cadr a))))
%let-list)
(push k keywords-seen))
;; Filter out more error cases that might kill defmacro.
((or (atom (car a)) (not (keywordp (caar a))) (atom (cdar a)))
(cerror "Ignore this item."
"~S -- ill-formed keyword arg in ~S." (car a) errloc))
;; Next case is ((:key var) [init [supplied-p]]).
((symbolp (cadar a))
(setq k (caar a))
;; Deal with supplied-p variable, if any.
(cond ((and (cddr a) (symbolp (caddr a)))
(setq sp-var (caddr a))
(push (list sp-var nil) %let-list))
(t (setq sp-var nil)))
(push `(,(cadar a)
(cond ((setq ,temp (,*key-finder* ',k ,restvar))
,@(and sp-var `((setq ,sp-var t)))
(car ,temp))
(t ,(cadr a))))
%let-list)
(push k keywords-seen))
;; Same case, but must destructure the "variable".
(t (setq k (caar a))
(setq temp1 (gensym))
(cond ((and (cddr a) (symbolp (caddr a)))
(setq sp-var (caddr a))
(push (list sp-var nil) %let-list))
(t (setq sp-var nil)))
(push `(,temp1
(cond ((setq ,temp (,*key-finder* ',k ,restvar))
,@(and sp-var `((setq ,sp-var t)))
(car ,temp))
(t ,(cadr a))))
%let-list)
(push k keywords-seen)
(let ((%min-args 0) (%arg-count 0) (%restp nil))
(analyze1 (cadar a) temp1 errloc nil)))))
(and check-keywords
(push `(keyword-test ,restvar ',keywords-seen) %keyword-tests))))
;;; Functions that must be around when the macros produced by DEFMACRO are
;;; expanded.
(defun make-keyword (s)
"Takes a non-keyword symbol S and returns the corresponding keyword."
(intern (symbol-name s) *keyword-package*))
(defun find-keyword (keyword keylist)
"If keyword is present in the keylist, return a list of its argument.
Else, return NIL."
(do ((l keylist (cddr l)))
((atom l) nil)
(cond ((atom (cdr l))
(cerror "Stick a NIL on the end and go on."
"Unpaired item in keyword portion of macro call.")
(rplacd l (list nil))
(return nil))
((eq (car l) keyword) (return (list (cadr l)))))))
(defun keyword-test (keylist legal)
"Check whether all keywords in a form are legal. KEYLIST is the portion
of the calling form containing keywords. LEGAL is the list of legal
keywords. If the keyword :allow-other-keyws is present in KEYLIST,
just return without complaining about anything."
(cond ((memq ':allow-other-keys keylist) nil)
(t (do ((kl keylist (cddr kl)))
((atom kl) nil)
(cond ((memq (car kl) legal))
(t (cerror "Ignore it."
"~S illegal or unknown keyword." (car kl))))))))
;;; The DEFMACRO definition itself.
(macro defmacro (form)
"Syntax like a DEFUN, but creates a macro. See manual for details."
(cond ((< (length form) 4)
(error "~S -- Macro too short to be legal." form)))
(prog ((name (cadr form))
(arglist (caddr form))
(body (cdddr form))
(local-decs nil)
(doc nil)
(arg-test nil)
(%arg-count 0)
(%min-args 0)
(%restp nil)
(%let-list nil)
(%keyword-tests nil))
(cond ((not (symbolp name))
(error "~S -- Macro-name not a symbol." name)))
;; Check for local declarations and documentation string.
LOOP
(cond ((atom body)
(setq body '(nil)))
((and (not (atom (car body))) (eq (caar body) 'declare))
(setq local-decs (append local-decs (cdar body)))
(setq body (cdr body))
(go loop))
((and (stringp (car body)) (not (null (cdr body))))
(setq doc (list (car body)))
(setq body (cdr body))
(go loop)))
;; Analyze the defmacro argument list.
(analyze1 arglist '(cdr **macroarg**) name '**macroarg**)
(setq arg-test
(cond ((and (zerop %min-args) %restp) nil)
((zerop %min-args)
`(> (length **macroarg**) ,(1+ %arg-count)))
(%restp
`(< (length **macroarg**) ,(1+ %min-args)))
((= %min-args %arg-count)
`(not (= (length **macroarg**) ,(1+ %min-args))))
(t
`(or (> (length **macroarg**) ,(1+ %arg-count))
(< (length **macroarg**) ,(1+ %min-args))))))
;; Now build the body of the macro.
(cond ((null arglist)
(push '(ignore **macroarg**) local-decs)))
(setq body `(let* ,(nreverse %let-list)
,@ (and local-decs (list (cons 'declare local-decs)))
,@ %keyword-tests
,@ body))
(and arg-test
(setq body
`(cond (,arg-test
(error "Macro ~S cannot be called with ~S args."
',name (1- (length **macroarg**))))
(t ,body))))
(return `(macro ,name (**macroarg**) ,@doc ,body))))
;;; DEFTYPE is a lot like DEFMACRO.
(macro deftype (form)
"Syntax like DEFMACRO, but defines a new type."
(cond ((< (length form) 4)
(error "~S -- Deftype form too short to be legal." form)))
(prog ((name (cadr form))
(arglist (caddr form))
(body (cdddr form))
(local-decs nil)
(doc nil)
(arg-test nil)
(%arg-count 0)
(%min-args 0)
(%restp nil)
(%let-list nil)
(%keyword-tests nil))
(cond ((not (symbolp name))
(error "~S -- Type-name not a symbol." name)))
;; Check for local declarations and documentation string.
LOOP
(cond ((atom body)
(setq body '(nil)))
((and (not (atom (car body))) (eq (caar body) 'declare))
(setq local-decs (append local-decs (cdar body)))
(setq body (cdr body))
(go loop))
((and (stringp (car body)) (not (null (cdr body))))
(setq doc (list (car body)))
(setq body (cdr body))
(go loop)))
;; Analyze the defmacro argument list.
(let ((*default-default* '(quote *)))
(analyze1 arglist '(cdr **macroarg**) name '**macroarg**))
(setq arg-test
(cond ((and (zerop %min-args) %restp) nil)
((zerop %min-args)
`(> (length **macroarg**) ,(1+ %arg-count)))
(%restp
`(< (length **macroarg**) ,(1+ %min-args)))
((= %min-args %arg-count)
`(not (= (length **macroarg**) ,(1+ %min-args))))
(t
`(or (> (length **macroarg**) ,(1+ %arg-count))
(< (length **macroarg**) ,(1+ %min-args))))))
;; Now build the body of the macro.
(cond ((null arglist)
(push '(ignore **macroarg**) local-decs)))
(setq body `(let* ,(nreverse %let-list)
,@ (and local-decs (list (cons 'declare local-decs)))
,@ %keyword-tests
,@ body))
(and arg-test
(setq body
`(cond (,arg-test
(error "Deftype ~S cannot be called with ~S args."
',name (1- (length **macroarg**))))
(t ,body))))
(return `(progn
(%put ',name
'deftype-expander
'(lambda (**macroarg**) ,body))
,@(if doc `((%put ',name '%type-documentation ',doc)))
',name))))