(FILECREATED " 5-Jun-86 23:31:11" {ERIS}<LISPCORE>LIBRARY>CMLPARSE.;22 36542
changes to: (FNS PARSE-BODY)
previous date: "27-May-86 17:56:12" {ERIS}<LISPCORE>LIBRARY>CMLPARSE.;21)
(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLPARSECOMS)
(RPAQQ CMLPARSECOMS
[[DECLARE: EVAL@COMPILE
(P (PROCLAIM (QUOTE (SPECIAL %%ARG-COUNT %%MIN-ARGS %%UNBOUNDED-ARG-COUNT %%LET-LIST
%%KEYWORD-TESTS %%ENV-ARG-USED %%CTX-ARG-USED
%%ENV-ARG-USED %%ENV-ARG-NAME %%CTX-ARG-USED %%CTX-ARG-NAME
*DEFAULT-DEFAULT* *KEY-FINDER*]
(FNS PARSE-BODY)
(FNS PARSE-DEFMACRO ANALYZE ANALYZE-REST ANALYZE-AUX ANALYZE-KEY DEFMACRO-ARG-TEST
RECURSIVELY-ANALYZE PUSH-KEYWORD-BINDING)
(VARS ANALYZE-TESTS)
(COMS (* * "These two are needed at runtime.")
(FNS KEYWORD-TEST FIND-KEYWORD))
(PROP FILETYPE CMLPARSE)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA FIND-KEYWORD KEYWORD-TEST PUSH-KEYWORD-BINDING RECURSIVELY-ANALYZE
DEFMACRO-ARG-TEST ANALYZE-KEY ANALYZE-AUX ANALYZE-REST PARSE-DEFMACRO
PARSE-BODY])
(DECLARE: EVAL@COMPILE
(PROCLAIM (QUOTE (SPECIAL %%ARG-COUNT %%MIN-ARGS %%UNBOUNDED-ARG-COUNT %%LET-LIST %%KEYWORD-TESTS
%%ENV-ARG-USED %%CTX-ARG-USED %%ENV-ARG-USED %%ENV-ARG-NAME %%CTX-ARG-USED
%%CTX-ARG-NAME *DEFAULT-DEFAULT* *KEY-FINDER*)))
)
(DEFINEQ
(PARSE-BODY
(CL:LAMBDA (BODY ENVIRONMENT &OPTIONAL (DOC-STRING-ALLOWED T))
(* lmm " 5-Jun-86 23:26")
"CDR down the list of forms in BODY, looking for declarations and documentation strings, until we hit either the end of the BODY or a form that is neither of these. We expand macros in our search for declarations and doc-strings, but only until we find a form we don't understand.
Return three values:
1) The remainder of the BODY, after declarations and doc-strings,
2) A list of the declarations found,
3) The first documentation string found, or NIL if none are present."
(LET ((TAIL BODY)
(DECLS NIL)
(DOC NIL))
(LOOP (CL:WHEN (NULL TAIL)
(RETURN))
[LET ((FORM (CAR TAIL)))
(COND
((AND (STRINGP FORM)
(CDR TAIL)) (*
"Be careful about strings at the end of BODY..."
"They aren't doc-strings!")
(CL:IF (AND (NOT DOC)
DOC-STRING-ALLOWED)
(CL:SETQ DOC FORM)))
([OR (CL:ATOM FORM)
(NOT (SYMBOLP (CAR FORM]
(RETURN))
((EQ (CAR FORM)
(QUOTE DECLARE))
(CL:PUSH FORM DECLS))
((SPECIAL-FORM-P (CAR FORM))
(RETURN))
(T (LET ((MF (MACRO-FUNCTION (CAR FORM)
ENVIRONMENT)))
(CL:IF MF (MULTIPLE-VALUE-BIND (RES WIN)
(MACROEXPAND FORM ENVIRONMENT)
(CL:IF (AND WIN (CONSP RES)
(EQ (CAR RES)
(QUOTE DECLARE)))
(CL:PUSH RES DECLS)
(RETURN)))
(RETURN]
(pop TAIL))
(VALUES TAIL (REVERSE DECLS)
DOC))))
)
(DEFINEQ
(PARSE-DEFMACRO
[CL:LAMBDA (ARGUMENT-LIST WHOLE-EXPRESSION MACRO-BODY ERROR-LOCATION ENVIRONMENT &KEY
[PATH (BQUOTE (CDR (\, WHOLE-EXPRESSION]
((:ENVIRONMENT %%ENV-ARG-NAME))
((:CONTEXT %%CTX-ARG-NAME))
ERROR-STRING
(DOC-STRING-ALLOWED T)
((:DEFAULT-DEFAULT *DEFAULT-DEFAULT*)
NIL)
((:KEY-FINDER *KEY-FINDER*)
(QUOTE FIND-KEYWORD))) (* lmm "27-May-86 17:54")
(DECLARE (SPECIAL %%CTX-ARG-NAME %%ENV-ARG-NAME *KEY-FINDER* *DEFAULT-DEFAULT*))
(* lmm "24-May-86 22:29")
(* "Pavel" "16-May-86 19:17")
(* *
"Parse-Defmacro provides a clean interface to ANALYZE for use by macros and macro-like forms that must parse some form according to a defmacro-like argument list."
"
ARGLIST is the argument-list to be used for parsing.
CODE is the code that will be executed in the scope of the argument-list.
WHOLE is the variable which is bound to the entire arglist, or NIL if &whole is illegal.
ERRLOC is the name of the function being worked on, for use in error messages.
ENV is an environment in which PARSE-DEFMACRO may macroexpand the CODE, looking for declarations.
PATH is an access expression for getting to the object to be parsed, which defaults to the CDR of WHOLE.
ENVIRONMENT is the place where the macroexpansion environment may be found. If not supplied, then no &environment arg is allowed.
ERROR-STRING is used as the argument to ERROR if an incorrect number of arguments are supplied. The additional error arguments are ERRLOC and the number of arguments supplied. If ERROR-STRING is not supplied, then no argument count error checking is done.
DOC-STRING-ALLOWED indicates whether a doc-string should be parsed out of the body.
DEFAULT-DEFAULT is the default value for unsupplied arguments, which defaults to NIL.
KEY-FINDER the function used to do keyword lookup. It defaults to a function that does the right thing. If you supply your own, it should take two arguments, the keyword to be found and a list in which to find it, and return either a list of one element, the value of the given keyword, or NIL, if the keyword is not present.
"
" The first value returned is a LET* form which binds things and then evaluates the specified CODE.
The second value is a list of ignore declarations for the WHOLE and ENVIRONMENT vars, if appropriate.
The third value is the documentation string, if DOC-STRING-ALLOWED and one is present, and NIL otherwise.
The fourth and fifth values are the minimum and maximum number of arguments allowed, in case you care about that kind of thing. The fifth value is NIL if there is no upper limit.
")
(MULTIPLE-VALUE-BIND
(BODY LOCAL-DECS DOC)
(PARSE-BODY MACRO-BODY ENVIRONMENT DOC-STRING-ALLOWED)
(LET ((%%ARG-COUNT 0)
(%%MIN-ARGS 0)
(%%UNBOUNDED-ARG-COUNT NIL)
(%%LET-LIST NIL)
(%%KEYWORD-TESTS NIL)
(%%ENV-ARG-USED NIL)
(%%CTX-ARG-USED NIL))
(DECLARE (SPECIAL %%ARG-COUNT %%MIN-ARGS %%UNBOUNDED-ARG-COUNT %%LET-LIST %%KEYWORD-TESTS
%%ENV-ARG-USED %%CTX-ARG-USED))
(ANALYZE ARGUMENT-LIST PATH ERROR-LOCATION WHOLE-EXPRESSION)
(LET [(ARG-TEST (CL:IF ERROR-STRING (DEFMACRO-ARG-TEST PATH)))
(BODY (BQUOTE (LET* (\, (REVERSE %%LET-LIST))
(\,@ LOCAL-DECS)
(\,@ %%KEYWORD-TESTS)
(\,@ BODY]
(VALUES (CL:IF ARG-TEST (BQUOTE (CL:IF (\, ARG-TEST)
(CL:ERROR (\, ERROR-STRING)
(QUOTE (\, ERROR-LOCATION))
(CL:LENGTH (\, PATH)))
(\, BODY)))
BODY)
[BQUOTE ([\,@ (CL:UNLESS (OR ARG-TEST ARGUMENT-LIST)
(BQUOTE ((DECLARE (IGNORE (\, WHOLE-EXPRESSION]
[\,@ (CL:WHEN (AND %%ENV-ARG-NAME (NOT %%ENV-ARG-USED))
(BQUOTE ((DECLARE (IGNORE (\, %%ENV-ARG-NAME]
(\,@ (CL:WHEN (AND %%CTX-ARG-NAME (NOT %%CTX-ARG-USED))
(BQUOTE ((DECLARE (IGNORE (\, %%CTX-ARG-NAME]
DOC %%MIN-ARGS (CL:IF %%UNBOUNDED-ARG-COUNT NIL %%ARG-COUNT])
(ANALYZE
[LAMBDA (ARGLIST PATH ERRLOC WHOLE) (* lmm "27-May-86 17:51")
(* * "ANALYZE 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, %%unbounded-arg-count, %%keyword-tests, %%ctx-arg-used and %%env-arg-used."
"It reads the special variables %%env-arg-name and %%ctx-arg-name.")
(CL:UNLESS (CL:ATOM PATH) (* "Eliminate a common subexpression.")
(LET ((NEW-PATH (GENSYM)))
(CL:PUSH (BQUOTE ((\, NEW-PATH)
(\, PATH)))
%%LET-LIST)
(CL:SETQ PATH NEW-PATH)))
(CL:DO
((ARGS ARGLIST (CDR ARGS))
(OPTIONALP NIL)
A)
((CL:ATOM ARGS)
(CL:UNLESS (NULL ARGS) (* "If the variable-list is dotted,"
"treat it as a &rest argument"
"and return.")
(CL:SETQ %%UNBOUNDED-ARG-COUNT T)
(CL:PUSH (BQUOTE ((\, ARGS)
(\, PATH)))
%%LET-LIST)))
(CL:SETQ A (CAR ARGS))
(CASE A [(&WHOLE)
(COND
((AND WHOLE (CONSP (CDR ARGS))
(SYMBOLP (CADR ARGS)))
(push %%LET-LIST (LIST (CADR ARGS)
WHOLE))
(SETQ %%UNBOUNDED-ARG-COUNT T)
(SETQ ARGS (CDR ARGS)) (* "Only one CDR here; the other one"
"is done by the DO loop, above.")
)
(T (CL:ERROR "Illegal or ill-formed &whole arg in ~S." ERRLOC]
[(&ENVIRONMENT)
(COND
((AND %%ENV-ARG-NAME (CONSP (CDR ARGS))
(SYMBOLP (CADR ARGS)))
(CL:PUSH (BQUOTE ((\, (CADR ARGS))
(\, %%ENV-ARG-NAME)))
%%LET-LIST)
(CL:SETQ %%ENV-ARG-USED T)
(CL:SETQ ARGS (CDR ARGS)))
(T (CL:ERROR "Illegal or ill-formed &environment arg in ~S." ERRLOC]
[(&CONTEXT)
(COND
((AND %%CTX-ARG-NAME (CONSP (CDR ARGS))
(SYMBOLP (CADR ARGS)))
(CL:PUSH (BQUOTE ((\, (CADR ARGS))
(\, %%CTX-ARG-NAME)))
%%LET-LIST)
(CL:SETQ %%CTX-ARG-USED T)
(CL:SETQ ARGS (CDR ARGS)))
(T (CL:ERROR "Illegal or ill-formed &context arg in ~S." ERRLOC]
((&OPTIONAL)
(AND OPTIONALP (CERROR "Ignore it." "Redundant &optional flag in varlist of ~S." ERRLOC))
(CL:SETQ OPTIONALP T))
((&REST &BODY)
(RETURN (ANALYZE-REST (CDR ARGS)
PATH ERRLOC WHOLE)))
[(&KEY)
(LET ((KEYWORD-ARGS-VAR (GENSYM)))
(CL:SETQ %%UNBOUNDED-ARG-COUNT T)
(CL:PUSH (BQUOTE ((\, KEYWORD-ARGS-VAR)
(\, PATH)))
%%LET-LIST)
(RETURN (ANALYZE-KEY (CDR ARGS)
KEYWORD-ARGS-VAR ERRLOC]
((&ALLOW-OTHER-KEYS)
(CERROR "Ignore it." "Stray &ALLOW-OTHER-KEYS in arglist of ~S." ERRLOC))
((&AUX)
(RETURN (ANALYZE-AUX (CDR ARGS)
ERRLOC)))
(OTHERWISE (* "It's actually a parameter!")
[COND
[OPTIONALP (* "It's an optional argument.")
(CL:SETQ %%ARG-COUNT (1+ %%ARG-COUNT))
(COND
((SYMBOLP A) (*
"The normal case, a simple variable.")
(CL:PUSH [BQUOTE ((\, A)
(COND
((\, PATH)
(CAR (\, PATH)))
(T (\, *DEFAULT-DEFAULT*]
%%LET-LIST))
((CL:ATOM A)
(CERROR "Ignore this item." "Non-symbol variable name in ~S." ERRLOC))
((SYMBOLP (CAR A)) (* "Another common case:"
"(var [default [svar]])")
(CL:PUSH [BQUOTE ((\, (CAR A))
(COND
((\, PATH)
(CAR (\, PATH)))
(T (\, (COND
((> (CL:LENGTH A)
1)
(CADR A))
(T *DEFAULT-DEFAULT*]
%%LET-LIST)
(AND (> (CL:LENGTH A)
2)
(CL:PUSH [BQUOTE ((\, (CADDR A))
(NOT (NULL (\, PATH]
%%LET-LIST)))
(T (*
"Just like the previous case, but we"
"must destructure the 'var'.")
(LET ((NEW-WHOLE (GENSYM)))
(CL:PUSH [BQUOTE ((\, NEW-WHOLE)
(COND
((\, PATH)
(CAR (\, PATH)))
(T (\, (COND
((> (CL:LENGTH A)
1)
(CADR A))
(T *DEFAULT-DEFAULT*]
%%LET-LIST)
(RECURSIVELY-ANALYZE (CAR A)
NEW-WHOLE ERRLOC NIL))
(AND (> (CL:LENGTH A)
2)
(CL:PUSH [BQUOTE ((\, (CADDR A))
(NOT (NULL (\, PATH]
%%LET-LIST]
(T (* "It's a required argument.")
(CL:SETQ %%MIN-ARGS (1+ %%MIN-ARGS))
(CL:SETQ %%ARG-COUNT (1+ %%ARG-COUNT))
(COND
((SYMBOLP A) (*
"The normal case, a simple variable.")
(CL:PUSH [BQUOTE ((\, A)
(CAR (\, PATH]
%%LET-LIST))
((CL:ATOM A)
(CERROR "Ignore this item." "Non-symbol variable name %"~S%" in ~S." A ERRLOC))
(T (* "The normal destructuring case.")
(LET ((NEW-WHOLE (GENSYM)))
(CL:PUSH [BQUOTE ((\, NEW-WHOLE)
(CAR (\, PATH]
%%LET-LIST)
(RECURSIVELY-ANALYZE A NEW-WHOLE ERRLOC NEW-WHOLE]
(* * "After each real parameter, we need to advance PATH by CDRing."
"In many cases, though, we can eliminate a common subexpression.")
(CL:IF (OR (CL:ATOM (CDR ARGS))
(CL:ATOM (CDDR ARGS)))
[CL:SETQ PATH (BQUOTE (CDR (\, PATH]
(LET ((NEW-PATH (GENSYM)))
(CL:PUSH [BQUOTE ((\, NEW-PATH)
(CDR (\, PATH]
%%LET-LIST)
(CL:SETQ PATH NEW-PATH])
(ANALYZE-REST
[CL:LAMBDA (ARGLIST PATH ERRLOC WHOLE) (* "Pavel" "16-May-86 16:30")
(CL:WHEN (CL:ATOM ARGLIST)
(CL:ERROR "Bad &rest or &body arg in ~S." ERRLOC))
(SETQ %%UNBOUNDED-ARG-COUNT T)
(LET ((REST-ARG (CAR ARGLIST)))
(COND
((SYMBOLP REST-ARG) (* "Normal case, a single variable.")
(CL:PUSH (BQUOTE ((\, REST-ARG)
(\, PATH)))
%%LET-LIST))
[(AND (CONSP REST-ARG)
(> (CL:LENGTH REST-ARG)
1)) (* "Fancy case:"
"(body-var [decls-var [doc-var]])"
"an implicit call to PARSE-BODY.")
(CL:UNLESS %%ENV-ARG-NAME (CL:ERROR
"A non-atomic &body is not allowed when no environment is available."
))
(LET ((BODY-VAR (CL:FIRST REST-ARG))
(DECLS-VAR (SECOND REST-ARG))
(DOC-VAR (THIRD REST-ARG))
(PARSE-BODY-RESULT (GENSYM)))
(SETQ REST-ARG NIL) (* "This makes &key illegal.")
(CL:PUSH [BQUOTE ((\, PARSE-BODY-RESULT)
(MULTIPLE-VALUE-LIST (PARSE-BODY (\, PATH)
(\, %%ENV-ARG-NAME)
(\, (NOT (NULL DOC-VAR]
%%LET-LIST)
(CL:PUSH [BQUOTE ((\, BODY-VAR)
(CL:FIRST (\, PARSE-BODY-RESULT]
%%LET-LIST)
(CL:WHEN DECLS-VAR (CL:PUSH [BQUOTE ((\, DECLS-VAR)
(SECOND (\, PARSE-BODY-RESULT]
%%LET-LIST))
(CL:WHEN DOC-VAR (CL:PUSH [BQUOTE ((\, DOC-VAR)
(THIRD (\, PARSE-BODY-RESULT]
%%LET-LIST]
(T (CL:ERROR "Bad &rest or &body arg in ~S." ERRLOC)))
(* * "Handle any arguments after &rest or &body.")
(CL:DO ((MORE (CDR ARGLIST)
(CDR MORE)))
((CL:ATOM MORE)
(CL:IF (NULL MORE)
NIL
(CERROR "Ignore the illegal terminator."
"Dotted arglist terminator after &rest arg in ~S." ERRLOC)))
(CASE (CAR MORE)
[(&KEY)
(CL:IF (NULL REST-VAR)
(CL:ERROR
"A non-atomic &body argument was mixed with &key in arglist of ~S."
ERRLOC)
(RETURN (ANALYZE-KEY (CDR MORE)
REST-ARG ERRLOC]
((&AUX)
(RETURN (ANALYZE-AUX (CDR MORE)
ERRLOC)))
((&ALLOW-OTHER-KEYS)
(CERROR "Ignore it." "Stray &ALLOW-OTHER-KEYS in arglist of ~S." ERRLOC))
[(&WHOLE)
(COND
((AND WHOLE (CONSP (CDR MORE))
(SYMBOLP (CADR MORE)))
(CL:PUSH (BQUOTE ((\, (CADR MORE))
(\, WHOLE)))
%%LET-LIST)
(SETQ MORE (CDR MORE)))
(T (CL:ERROR "Ill-formed or illegal &whole arg in ~S." ERRLOC]
[(&ENVIRONMENT)
(COND
((AND %%ENV-ARG-NAME (CONSP (CDR MORE))
(SYMBOLP (CADR MORE)))
(CL:PUSH (BQUOTE ((\, (CADR MORE))
(\, %%ENV-ARG-NAME)))
%%LET-LIST)
(SETQ %%ENV-ARG-USED T)
(SETQ MORE (CDR MORE)))
(T (CL:ERROR "Ill-formed or illegal &environment arg in ~S." ERRLOC]
[(&CONTEXT)
(COND
((AND %%CTX-ARG-NAME (CONSP (CDR MORE))
(SYMBOLP (CADR MORE)))
(CL:PUSH (BQUOTE ((\, (CADR MORE))
(\, %%CTX-ARG-NAME)))
%%LET-LIST)
(SETQ %%CTX-ARG-USED T)
(SETQ MORE (CDR MORE)))
(T (CL:ERROR "Ill-formed or illegal &context arg in ~S." ERRLOC]
(OTHERWISE (CERROR "Ignore it."
"Stray parameter %"~S%" found in arglist of ~S." (CAR MORE)
ERRLOC])
(ANALYZE-AUX
[CL:LAMBDA (ARGLIST ERRLOC) (* "Pavel" "16-May-86 16:32")
(* "Pavel" "12-May-86 22:30")
(* * "Analyze stuff following &aux.")
(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))
(CL:UNLESS (SYMBOLP (CAR ARGS))
(CL:ERROR "Non-symbolic &AUX parameter %"~S%" in arglist of ~S." (CAR ARGS)
ERRLOC))
(CL:WHEN (CL:MEMBER (CAR ARGS)
LAMBDA-LIST-KEYWORDS)
(WARN "WARNING: The lambda-list keyword %"~S%" was found where an &aux variable should be in the arglist of ~S.~%%It will be treated as an &aux variable and bound to NIL.~%%You will almost certainly lose.~%%"
(CAR ARGS)
ERRLOC))
(CL:PUSH (BQUOTE ((\, (CAR ARGS))
NIL))
%%LET-LIST))
(T (CL:UNLESS (SYMBOLP (CAAR ARGS))
(CL:ERROR "Non-symbolic &AUX parameter %"~S%" in arglist of ~S." (CAAR ARGS)
ERRLOC))
(CL:PUSH [BQUOTE ((\, (CAAR ARGS))
(\, (CADAR ARGS]
%%LET-LIST])
(ANALYZE-KEY
[CL:LAMBDA (ARGLIST RESTVAR ERRLOC)
"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."
(LET ((TEMP (GENSYM))
(CHECK-KEYWORDS T)
(KEYWORDS-SEEN NIL))
(CL:PUSH TEMP %%LET-LIST) (*
"TEMP will be used for each keyword"
"as a temporary piece of storage;"
"see PUSH-KEYWORD-BINDING.")
[CL:DO ((ARGS ARGLIST (CDR ARGS))
A K SP-VAR TEMP1)
((CL:ATOM ARGS)
(CL:IF (NULL ARGS)
NIL
(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)))
((SYMBOLP A) (* "Just a top-level variable."
"Make matching keyword.")
(SETQ K (MAKE-KEYWORD A))
(PUSH-KEYWORD-BINDING A K NIL NIL RESTVAR TEMP ERRLOC)
(CL:PUSH K KEYWORDS-SEEN))
((CL:ATOM A) (* "Filter out error that might"
"choke defmacro.")
(CERROR "Ignore this item." "~S -- non-symbol variable name in arglist of ~S." A
ERRLOC))
((SYMBOLP (CAR A)) (* "Deal with the common case:"
"(var [init [svar]])")
(SETQ K (MAKE-KEYWORD (CAR A)))
(SETQ SP-VAR (CADDR A))
(PUSH-KEYWORD-BINDING (CAR A)
K
(CADR A)
SP-VAR RESTVAR TEMP ERRLOC)
(CL:PUSH K KEYWORDS-SEEN))
((OR (CL:ATOM (CAR A))
(NOT (KEYWORDP (CAAR A)))
(CL:ATOM (CDAR A))) (* "Filter out more error cases that"
"might kill defmacro.")
(CERROR "Ignore this item." "~S -- ill-formed keyword arg in ~S." (CAR A)
ERRLOC))
((SYMBOLP (CADR (CAR A))) (* "Next case is"
"((:key var) [init [supplied-p]]).")
(SETQ K (CAAR A))
(CL:UNLESS (KEYWORDP K)
(CL:ERROR "%"~S%" should be a keyword, in arglist of ~S." K ERRLOC))
(SETQ SP-VAR (CADDR A))
(PUSH-KEYWORD-BINDING (CADR (CAR A))
K
(CADR A)
SP-VAR RESTVAR TEMP ERRLOC)
(CL:PUSH K KEYWORDS-SEEN))
(T (* "Same case, but must destructure"
"the 'variable'.")
(SETQ K (CAAR A))
(CL:UNLESS (KEYWORDP K)
(CL:ERROR "%"~S%" should be a keyword, in arglist of ~S." K ERRLOC))
(SETQ TEMP1 (GENSYM))
(SETQ SP-VAR (CADDR A))
(PUSH-KEYWORD-BINDING TEMP1 K (CADR A)
SP-VAR RESTVAR TEMP ERRLOC)
(CL:PUSH K KEYWORDS-SEEN)
(RECURSIVELY-ANALYZE (CADAR A)
TEMP1 ERRLOC NIL]
(CL:WHEN CHECK-KEYWORDS (CL:PUSH [BQUOTE (KEYWORD-TEST (\, RESTVAR)
(QUOTE (\, KEYWORDS-SEEN]
%%KEYWORD-TESTS])
(DEFMACRO-ARG-TEST
[CL:LAMBDA (ARGS)
"Return a form which tests whether an illegal number of arguments have been supplied. Args is a form which evaluates to the list of arguments."
(COND
((AND (ZEROP %%MIN-ARGS)
%%UNBOUNDED-ARG-COUNT)
NIL)
[(ZEROP %%MIN-ARGS)
(BQUOTE (> (CL:LENGTH (\, ARGS))
(\, %%ARG-COUNT]
[%%UNBOUNDED-ARG-COUNT (BQUOTE (< (CL:LENGTH (\, ARGS))
(\, %%MIN-ARGS]
[(= %%MIN-ARGS %%ARG-COUNT)
(BQUOTE (/= (CL:LENGTH (\, ARGS))
(\, %%MIN-ARGS]
(T (BQUOTE (OR (> (CL:LENGTH (\, ARGS))
(\, %%ARG-COUNT))
(< (CL:LENGTH (\, ARGS))
(\, %%MIN-ARGS])
(RECURSIVELY-ANALYZE
(CL:LAMBDA (ARGLIST PATH ERRLOC WHOLE)
"Make a recursive call on ANALYZE, being careful to shield the data-structures of outer calls and to make certain constructs illegal. The bindings of MIN-ARGS, ARG-COUNT, and UNBOUNDED-ARG-COUNT are for shielding and those of ENV-ARG-NAME and CTX-ARG-NAME are to disallow &environment and &context respectively."
(LET ((%%MIN-ARGS 0)
(%%ARG-COUNT 0)
(%%UNBOUNDED-ARG-COUNT NIL)
(%%ENV-ARG-NAME NIL)
(%%CTX-ARG-NAME NIL))
(ANALYZE ARGLIST PATH ERRLOC WHOLE))))
(PUSH-KEYWORD-BINDING
[CL:LAMBDA (VARIABLE KEYWORD DEFAULT SUPPLIED-P-VAR REST-VAR TEMP-VAR ERRLOC)
(CL:BLOCK PUSH-KEYWORD-BINDING (* "Pavel" "19-May-86 15:30")
(CL:UNLESS (SYMBOLP SUPPLIED-P-VAR)
(CL:ERROR "Non-symbolic supplied-p parameter %"~S%" found in arglist of ~S."
SUPPLIED-P-VAR ERRLOC))
(CL:PUSH [BQUOTE ((\, VARIABLE)
(COND
((CL:SETQ (\, TEMP-VAR)
((\, *KEY-FINDER*)
(QUOTE (\, KEYWORD))
(\, REST-VAR)))
(CAR (\, TEMP-VAR)))
(T (\, (OR DEFAULT *DEFAULT-DEFAULT*]
%%LET-LIST)
(CL:WHEN SUPPLIED-P-VAR (CL:PUSH [BQUOTE ((\, SUPPLIED-P-VAR)
(NOT (NULL (\, TEMP-VAR]
%%LET-LIST])
)
(RPAQQ ANALYZE-TESTS ((MULTIPLE-VALUE-LIST (PARSE-DEFMACRO (QUOTE ((&WHOLE HEAD MOUTH &OPTIONAL EYE1
(EYE2 7 EYE2-P))
([FIN1 LENGTH1 &KEY ONE
(TWO 8)
((:THREE TROIS)
3 TRES-P)
((:FOUR (QUATRE QUATRO))
(QUOTE (4 4]
&OPTIONAL
((FIN2 LENGTH2)
9 FL2-P))
TAIL &REST (FOO BAR BAZ)
&ENVIRONMENT ENV))
(QUOTE WHOLE-ARG)
(QUOTE ((CODE)))
(QUOTE ERRLOC)
:ENVIRONMENT
(QUOTE *ENV*)
:ERROR-STRING "Ack!"))
(QUOTE ((&WHOLE HEAD MOUTH EYE1 EYE2)
((FIN1 LENGTH1)
(FIN2 LENGTH2))
TAIL))
(QUOTE ((&WHOLE HEAD MOUTH &OPTIONAL EYE1 (EYE2 7 EYE2-P))
([FIN1 LENGTH1 &KEY ONE (TWO 8)
((:THREE TROIS)
3 TRES-P)
((:FOUR (QUATRE QUATRO))
(QUOTE (4 4]
&OPTIONAL
((FIN2 LENGTH2)
9 FL2-P))
TAIL &REST (FOO BAR BAZ)
&ENVIRONMENT ENV))))
(* * "These two are needed at runtime.")
(DEFINEQ
(KEYWORD-TEST
[CL:LAMBDA (ARGS KEYS) (* "Pavel" "16-May-86 17:01")
"Signal an error unless
-- one of the keywords on ARGS is :ALLOW-OTHER-KEYS and
it has a non-NIL value, or
-- all of the keywords on ARGS are also on KEYS.
Note that we should search ARGS by CDDR and KEYS by CDR.
"
(LET ((EXTRA-KEY-FOUND NIL))
[for TAIL on ARGS by (CDDR TAIL)
do
(CL:WHEN [AND (EQ (CAR TAIL)
:ALLOW-OTHER-KEYS)
(NOT (NULL (CADR TAIL]
(RETURN (VALUES)))
(CL:UNLESS (CL:MEMBER (CAR TAIL)
KEYS :TEST (CL:FUNCTION EQ))
(CL:SETQ EXTRA-KEY-FOUND (CAR TAIL]
(CL:IF EXTRA-KEY-FOUND (CL:ERROR "Extraneous keyword %"~S%" given." EXTRA-KEY-FOUND)
(VALUES])
(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])
)
(PUTPROPS CMLPARSE FILETYPE COMPILE-FILE)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA FIND-KEYWORD KEYWORD-TEST PUSH-KEYWORD-BINDING RECURSIVELY-ANALYZE DEFMACRO-ARG-TEST
ANALYZE-KEY ANALYZE-AUX ANALYZE-REST PARSE-DEFMACRO PARSE-BODY)
)
(PUTPROPS CMLPARSE COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1727 4360 (PARSE-BODY 1737 . 4358)) (4361 32025 (PARSE-DEFMACRO 4371 . 9240) (ANALYZE
9242 . 18211) (ANALYZE-REST 18213 . 23472) (ANALYZE-AUX 23474 . 25063) (ANALYZE-KEY 25065 . 29572) (
DEFMACRO-ARG-TEST 29574 . 30368) (RECURSIVELY-ANALYZE 30370 . 30957) (PUSH-KEYWORD-BINDING 30959 .
32023)) (34407 36115 (KEYWORD-TEST 34417 . 35321) (FIND-KEYWORD 35323 . 36113)))))
STOP