(FILECREATED "31-Aug-85 17:50:21" {ERIS}<LISPCORE>LIBRARY>CMLDEFMACRO.;2 13092
changes to: (VARS CMLDEFMACROCOMS)
(FNS ANALYZE-ARGLIST ANALYZE1 ANALYZE-REST ANALYZE-AUX ANALYZE-KEY MAKE-KEYWORD
FIND-KEYWORD KEYWORD-TEST)
previous date: "30-Aug-85 00:17:26" {ERIS}<LISPCORE>LIBRARY>CMLDEFMACRO.;1)
(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLDEFMACROCOMS)
(RPAQQ CMLDEFMACROCOMS ((INITVARS (*DEFAULT-DEFAULT* NIL)
(*KEY-FINDER* (QUOTE FIND-KEYWORD)))
(FNS ANALYZE-ARGLIST ANALYZE1 ANALYZE-REST ANALYZE-AUX ANALYZE-KEY
MAKE-KEYWORD FIND-KEYWORD KEYWORD-TEST)))
(RPAQ? *DEFAULT-DEFAULT* NIL)
(RPAQ? *KEY-FINDER* (QUOTE FIND-KEYWORD))
(DEFINEQ
(ANALYZE-ARGLIST
(CL:LAMBDA (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)
(CL:NREVERSE \LET-LIST))))
(ANALYZE1
(CL:LAMBDA (ARGLIST PATH ERRLOC WHOLE) (* kbr: "30-Aug-85 00:11")
(CL:DO ((ARGS ARGLIST (CDR ARGS))
(OPTIONALP NIL)
A TEMP)
((CL:ATOM ARGS)
(COND
((NULL ARGS)
NIL)
(T (* Varlist is dotted, treat as &rest arg and exit.
*)
(push \LET-LIST (LIST ARGS PATH))
(SETQ \RESTP T))))
(SETQ A (CAR ARGS))
(COND
((EQ A (QUOTE &WHOLE))
(COND
((AND WHOLE (CDR ARGS)
(SYMBOLP (CADR ARGS)))
(push \LET-LIST (LIST (CADR ARGS)
WHOLE))
(SETQ \RESTP T)
(SETQ ARGS (CDR ARGS)))
(T (CL:ERROR "Illegal or ill-formed &whole arg in ~S." ERRLOC))))
((EQ A (QUOTE &OPTIONAL))
(AND OPTIONALP (CERROR "Ignore it." "Redundant &optional flag in varlist of ~S."
ERRLOC))
(SETQ OPTIONALP T))
((OR (EQ A (QUOTE &REST))
(EQ A (QUOTE &BODY)))
(RETURN (ANALYZE-REST (CDR ARGS)
PATH ERRLOC WHOLE)))
((EQ A (QUOTE &KEY)) (* Create a rest-arg, then do keyword analysis.
*)
(SETQ TEMP (GENSYM))
(SETQ \RESTP T)
(push \LET-LIST (LIST TEMP PATH))
(RETURN (ANALYZE-KEY (CDR ARGS)
TEMP ERRLOC)))
((EQ A (QUOTE &ALLOW-OTHER-KEYS))
(CERROR "Ignore it." "Stray &ALLOW-OTHER-KEYS in arglist of ~S." ERRLOC))
((EQ A (QUOTE &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 \LET-LIST (BQUOTE ((\, A)
(CAR (\, PATH))))))
((CL: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 (BQUOTE (CAR (\, PATH)))
ERRLOC NIL))))
(SETQ PATH (BQUOTE (CDR (\, PATH)))))
(T (* It's an optional arg. *)
(SETQ \ARG-COUNT (1+ \ARG-COUNT))
(COND
((SYMBOLP A) (* Just a symbol. Bind to car of path or default.
*)
(push \LET-LIST (BQUOTE ((\, A)
(COND
((\, PATH)
(CAR (\, PATH)))
(T (\, *DEFAULT-DEFAULT*)))))))
((CL: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 \LET-LIST (BQUOTE ((\, (CAR A))
(COND
((\, PATH)
(CAR (\, PATH)))
(T (\, (COND
((> (LENGTH A)
1)
(CADR A))
(T *DEFAULT-DEFAULT*))))))))
(* Handle supplied-p variable, if any.
*)
(AND (> (LENGTH A)
2)
(push \LET-LIST (BQUOTE ((\, (CADDR A))
(NOT (NULL (\, PATH))))))))
(T (* Then destructure arg against contents of this
gensym. *)
(SETQ TEMP (GENSYM))
(push \LET-LIST (BQUOTE ((\, TEMP)
(COND
((\, PATH)
(CAR (\, PATH)))
(T (\, (COND
((CDDR A)
(CADR A))
(T *DEFAULT-DEFAULT*))))))))
(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 \LET-LIST (BQUOTE ((\, (CADDR A))
(NOT (NULL (\, PATH)))))))))
(SETQ PATH (BQUOTE (CDR (\, PATH)))))))))
(ANALYZE-REST
(CL:LAMBDA (ARGLIST PATH ERRLOC WHOLE)
(COND
((OR (CL:ATOM ARGLIST)
(NOT (SYMBOLP (CAR ARGLIST))))
(CL:ERROR "Bad &rest or &body arg in ~S." ERRLOC)))
(PUSH \LET-LIST (LIST (CAR ARGLIST)
PATH))
(SETQ \RESTP T)
(PROG (REST-ARG MORE)
(SETQ REST-ARG (CAR ARGLIST))
(SETQ MORE (CDR ARGLIST))
TRY-AGAIN
(COND
((NULL MORE)
NIL)
((CL:ATOM MORE)
(CERROR "Ignore the illegal terminator."
"Dotted arglist terminator after &rest arg in ~S."
ERRLOC))
((EQ (CAR MORE)
(QUOTE &KEY))
(ANALYZE-KEY (CDR MORE)
REST-ARG ERRLOC))
((EQ (CAR MORE)
(QUOTE &AUX))
(ANALYZE-AUX (CDR MORE)
ERRLOC))
((EQ (CAR MORE)
(QUOTE &ALLOW-OTHER-KEYS))
(CERROR "Ignore it." "Stray &ALLOW-OTHER-KEYS in arglist of ~S." ERRLOC))
((EQ (CADR ARGLIST)
(QUOTE &WHOLE))
(COND
((AND WHOLE (CDR MORE)
(SYMBOLP (CADR MORE)))
(PUSH \LET-LIST (LIST (CADR MORE)
WHOLE))
(SETQ MORE (CDDR MORE))
(GO TRY-AGAIN))
(T (CL:ERROR "Ill-formed or illegal &whole arg in ~S." ERRLOC))))))))
(ANALYZE-AUX
(CL:LAMBDA (ARGLIST ERRLOC)
(CL:DO ((ARGS ARGLIST (CDR ARGS)))
((NULL ARGS))
(COND
((CL:ATOM ARGS)
(CERROR "Ignore the illegal terminator." "Dotted arglist after &AUX in ~S." ERRLOC)
(RETURN NIL))
((CL:ATOM (CAR ARGS))
(PUSH \LET-LIST (LIST (CAR ARGS)
NIL)))
(T (PUSH \LET-LIST (LIST (CAAR ARGS)
(CADAR ARGS))))))))
(ANALYZE-KEY
(CL:LAMBDA (ARGLIST RESTVAR ERRLOC)
(LET ((TEMP (GENSYM))
(CHECK-KEYWORDS T)
(KEYWORDS-SEEN NIL))
(PUSH \LET-LIST TEMP)
(CL:DO ((ARGS ARGLIST (CDR ARGS))
A K SP-VAR TEMP1)
((CL: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 (QUOTE &ALLOW-OTHER-KEYS))
(SETQ CHECK-KEYWORDS NIL))
((EQ A (QUOTE &AUX))
(RETURN (ANALYZE-AUX (CDR ARGS)
ERRLOC)))
(* " Just a top-level variable. Make matching keyword." *)
((SYMBOLP A)
(SETQ K (MAKE-KEYWORD A))
(PUSH \LET-LIST (BQUOTE ((\, A)
(COND
((SETQ (\, TEMP)
((\, *KEY-FINDER*)
(QUOTE (\, K))
(\, RESTVAR)))
(CAR (\, TEMP)))
(T NIL)))))
(PUSH KEYWORDS-SEEN K))
(* " Filter out error that might choke defmacro." *)
((CL: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 \LET-LIST (LIST SP-VAR NIL)))
(T (SETQ SP-VAR NIL)))
(PUSH \LET-LIST (BQUOTE ((\, (CAR A))
(COND
((SETQ (\, TEMP)
((\, *KEY-FINDER*)
(QUOTE (\, K))
(\, RESTVAR)))
(\,@ (AND SP-VAR (BQUOTE ((SETQ (\, SP-VAR)
T)))))
(CAR (\, TEMP)))
(T (\, (CADR A)))))))
(PUSH KEYWORDS-SEEN K))
(* " Filter out more error cases that might kill defmacro." *)
((OR (CL:ATOM (CAR A))
(NOT (KEYWORDP (CAAR A)))
(CL: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 \LET-LIST (LIST SP-VAR NIL)))
(T (SETQ SP-VAR NIL)))
(PUSH \LET-LIST (BQUOTE ((\, (CADAR A))
(COND
((SETQ (\, TEMP)
((\, *KEY-FINDER*)
(QUOTE (\, K))
(\, RESTVAR)))
(\,@ (AND SP-VAR (BQUOTE ((SETQ (\, SP-VAR)
T)))))
(CAR (\, TEMP)))
(T (\, (CADR A)))))))
(PUSH KEYWORDS-SEEN K))
(* " 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 \LET-LIST (LIST SP-VAR NIL)))
(T (SETQ SP-VAR NIL)))
(PUSH \LET-LIST (BQUOTE ((\, TEMP1)
(COND
((SETQ (\, TEMP)
((\, *KEY-FINDER*)
(QUOTE (\, K))
(\, RESTVAR)))
(\,@ (AND SP-VAR (BQUOTE ((SETQ (\, SP-VAR)
T)))))
(CAR (\, TEMP)))
(T (\, (CADR A)))))))
(PUSH KEYWORDS-SEEN K)
(LET ((\MIN-ARGS 0)
(\ARG-COUNT 0)
(\RESTP NIL))
(ANALYZE1 (CADAR A)
TEMP1 ERRLOC NIL)))))
(AND CHECK-KEYWORDS (PUSH \KEYWORD-TESTS (BQUOTE (KEYWORD-TEST (\, RESTVAR)
(QUOTE (\, KEYWORDS-SEEN))))))
)))
(MAKE-KEYWORD
(CL:LAMBDA (S)
"Takes a non-keyword symbol S and returns the corresponding keyword."
(INTERN (SYMBOL-NAME S)
*KEYWORD-PACKAGE*)))
(FIND-KEYWORD
(CL:LAMBDA (KEYWORD KEYLIST)
"If keyword is present in the keylist, return a list of its argument.
Else, return NIL."
(CL:DO ((L KEYLIST (CDDR L)))
((CL:ATOM L)
NIL)
(COND
((CL: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))))))))
(KEYWORD-TEST
(CL:LAMBDA (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 (QUOTE :ALLOW-OTHER-KEYS)
KEYLIST)
NIL)
(T (CL:DO ((KL KEYLIST (CDDR KL)))
((CL:ATOM KL)
NIL)
(COND
((MEMQ (CAR KL)
LEGAL))
(T (CERROR "Ignore it." "~S illegal or unknown keyword." (CAR KL)))))))))
)
(PUTPROPS CMLDEFMACRO COPYRIGHT ("Xerox Corporation" 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (740 13010 (ANALYZE-ARGLIST 750 . 1475) (ANALYZE1 1477 . 5757) (ANALYZE-REST 5759 . 7103
) (ANALYZE-AUX 7105 . 7576) (ANALYZE-KEY 7578 . 11697) (MAKE-KEYWORD 11699 . 11865) (FIND-KEYWORD
11867 . 12397) (KEYWORD-TEST 12399 . 13008)))))
STOP