Trailing-Edge
-
PDP-10 Archives
-
clisp
-
clisp/upsala/analyze.clisp
There are no other files named analyze.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.
;;; Spice Lisp is currently incomplete and under active development.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;; This are the functions from DEFMACRO.CLISP that the compiler uses,
;;; ie., ANALYZE1, ANALYZE-REST, ANALYZE-KEY, ANALYZE-AUX, MAKE-KEYWORD,
;;; FIND-KEYWORD, and KEYWORD-TEST.
;;; They are all prefixed with CLC- for the compiler.
;;; DKS 9:00pm Thursday, 24 May 1984
;;; 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.
;;; *******************************************************************
;;; 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*))
;;; CLC-ANALYZE1 is called 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 clc-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 (clc-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 (clc-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 (clc-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))
(clc-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 nil)))
%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 nil)))))
%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 nil)))))
%let-list)
(let ((%min-args 0) (%arg-count 0) (%restp nil))
(clc-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 clc-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)
(clc-analyze-key (cdr more) rest-arg errloc))
((eq (car more) '&aux)
(clc-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 clc-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 clc-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 (clc-analyze-aux (cdr args) errloc)))
;; Just a top-level variable. Make matching keyword.
((symbolp a)
(setq k (clc-make-keyword a))
(push `(,a (cond ((setq ,temp (clc-find-keyword ',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 (clc-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 (clc-find-keyword ',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 (clc-find-keyword ',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 (clc-find-keyword ',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))
(clc-analyze1 (cadar a) temp1 errloc nil)))))
(and check-keywords
(push `(clc-keyword-test ,restvar ',keywords-seen) %keyword-tests))))
;;; Functions that must be around when the macros produced by DEFMACRO are
;;; expanded.
(defun clc-make-keyword (s)
"Takes a non-keyword symbol S and returns the corresponding keyword."
(intern (symbol-name s) *keyword-package*))
(defun clc-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 clc-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))))))))