(FILECREATED "29-Sep-86 18:50:56" {ERIS}<LISPCORE>SOURCES>CMLPARSE.;7 39770
changes to: (FUNCTIONS ANALYZE ANALYZE-REST ANALYZE-AUX ANALYZE-KEY ANALYZE-PARAMETER
CHECK-PARAMETER-NAME PUSH-KEYWORD-BINDING KEYWORD-TEST FIND-KEYWORD)
(VARS CMLPARSECOMS)
previous date: "26-Sep-86 14:55:20" {ERIS}<LISPCORE>SOURCES>CMLPARSE.;4)
(* "
Copyright (c) 1986 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT CMLPARSECOMS)
(RPAQQ CMLPARSECOMS ((* ;; "Parsing bodies and argument lists")
(VARIABLES %%ARG-COUNT %%MIN-ARGS %%UNBOUNDED-ARG-COUNT %%LET-LIST
%%KEYWORD-TESTS %%ENV-ARG-USED %%CTX-ARG-USED %%ENV-ARG-NAME
%%CTX-ARG-NAME)
(VARIABLES *DEFAULT-DEFAULT* *KEY-FINDER*)
(FUNCTIONS PARSE-BODY)
(FUNCTIONS PARSE-DEFMACRO ANALYZE ANALYZE-AUX ANALYZE-KEY ANALYZE-PARAMETER
CHECK-PARAMETER-NAME PUSH-KEYWORD-BINDING ANALYZE-REST
RECURSIVELY-ANALYZE DEFMACRO-ARG-TEST)
(* ;; "Testing the argument-list parsing")
(VARIABLES ANALYZE-TESTS)
(* ;; "Runtime support functions")
(FUNCTIONS KEYWORD-TEST FIND-KEYWORD)
(* ;; "Arrange to use the correct compiler")
(PROP FILETYPE CMLPARSE)))
(* ;; "Parsing bodies and argument lists")
(DEFVAR %%ARG-COUNT NIL)
(DEFVAR %%MIN-ARGS NIL)
(DEFVAR %%UNBOUNDED-ARG-COUNT 0)
(DEFVAR %%LET-LIST NIL)
(DEFVAR %%KEYWORD-TESTS NIL)
(DEFVAR %%ENV-ARG-USED NIL)
(DEFVAR %%CTX-ARG-USED NIL)
(DEFVAR %%ENV-ARG-NAME NIL)
(DEFVAR %%CTX-ARG-NAME NIL)
(DEFVAR *DEFAULT-DEFAULT* NIL)
(DEFVAR *KEY-FINDER* NIL)
(DEFUN PARSE-BODY (BODY ENVIRONMENT &OPTIONAL (DOC-STRING-ALLOWED T))
(* ;; "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 ((RESULT (PROCEED-CASE (MACROEXPAND FORM ENVIRONMENT)
(PROCEED (IGNORE)
:REPORT
(LET ((*PRINT-LEVEL* 3)
(*PRINT-LENGTH* 3))
(FORMAT T
"Assume that ~S does not expand into a declaration."
FORM))
FORM))))
(CL:IF (AND (CONSP RESULT)
(EQ (CAR RESULT)
(QUOTE DECLARE)))
(CL:PUSH RESULT DECLS)
(RETURN))))))
(CL:POP TAIL))
(VALUES TAIL (REVERSE DECLS)
DOC)))
(DEFUN PARSE-DEFMACRO (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 NIL)
(DOC-STRING-ALLOWED T)
((:DEFAULT-DEFAULT *DEFAULT-DEFAULT*)
NIL)
((:KEY-FINDER *KEY-FINDER*)
(QUOTE FIND-KEYWORD))
(REMOVE-COMMENTS (AND (EQ (CAR ARGUMENT-LIST)
(QUOTE &WHOLE))
(EQ (CADR ARGUMENT-LIST)
(QUOTE %%ORIGINAL-DEFINITION)))))
(DECLARE (SPECIAL %%CTX-ARG-NAME %%ENV-ARG-NAME *KEY-FINDER* *DEFAULT-DEFAULT*))
(* ;; "%"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.")
(* ;; "")
(* ;;
"-- ARGUMENT-LIST is the argument-list to be used for parsing.")
(* ;; "-- WHOLE-EXPRESSION is the variable which is bound to the entire macro-call, or NIL if &whole is illegal.")
(* ;;
"-- MACRO-BODY is the code that will be executed in the scope of the argument-list.")
(* ;;
"-- ERROR-LOCATION is the name of the function being worked on, for use in error messages.")
(* ;; "-- ENVIRONMENT is an environment in which PARSE-DEFMACRO may macroexpand the WHOLE-EXPRESSION, 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.")
(* ;; "-- :CONTEXT is the place where the macroexpansion compiler context may be found. If not supplied, then no &context arg is allowed.")
(* ;; "-- :ERROR-STRING is used as the first argument to ERROR if an incorrect number of arguments are supplied. The additional arguments to ERROR 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.")
(* ;; "-- :REMOVE-COMMENTS should be non-NIL iff comments should be stripped from the macro-call before processing. The default is set up as a horrible hack to allow macros created by DEFDEFINER to get this feature.")
(* ;; "")
(* ;;
"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))
(ANALYZE ARGUMENT-LIST (CL:IF REMOVE-COMMENTS (BQUOTE (REMOVE-COMMENTS (\, PATH)))
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))))))
(DEFUN ANALYZE (ARGLIST PATH ERRLOC WHOLE) (* ;; "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)))
(ANALYZE-PARAMETER (CADR ARGS)
WHOLE ERRLOC)
(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)))
(CHECK-PARAMETER-NAME (CADR ARGS)
ERRLOC)
(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)))
(CHECK-PARAMETER-NAME (CADR ARGS)
ERRLOC)
(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 (CAR ARGS)
(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)))
(* ;; "It's actually a parameter!")
(OTHERWISE (COND (* ;; "It's an optional argument.")
(OPTIONALP (CL:SETQ %%ARG-COUNT (1+ %%ARG-COUNT))
(COND (* ;; "The normal case, a simple variable.")
((SYMBOLP A)
(CHECK-PARAMETER-NAME A ERRLOC)
(CL:PUSH (BQUOTE ((\, A)
(COND
((\, PATH)
(CAR (\, PATH)))
(T (\, *DEFAULT-DEFAULT*)))))
%%LET-LIST)) (* ;; "A buggy case.")
((CL:ATOM A)
(CERROR "Ignore this item." "Non-symbol variable name in ~S."
ERRLOC))
(* ;;
"The defaulting case: (var [default [svar]])")
(T (ANALYZE-PARAMETER (CAR A)
(BQUOTE (COND
((\, PATH)
(CAR (\, PATH)))
(T (\, (COND
((CDR A)
(* ; "Was a default value specified?")
(CADR A))
(T *DEFAULT-DEFAULT*))))))
ERRLOC)
(CL:WHEN (NOT (NULL (CDDR A)))
(CHECK-PARAMETER-NAME (CADDR A)
ERRLOC)
(CL:PUSH (BQUOTE ((\, (CADDR A))
(NOT (NULL (\, PATH)))))
%%LET-LIST)))))
(* ;; "It's a required argument.")
(T (CL:SETQ %%MIN-ARGS (1+ %%MIN-ARGS))
(CL:SETQ %%ARG-COUNT (1+ %%ARG-COUNT))
(ANALYZE-PARAMETER A (BQUOTE (CAR (\, PATH)))
ERRLOC))) (* ;; "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)))))))
(DEFUN ANALYZE-AUX (ARGLIST ERRLOC) (* ;; "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))
((SYMBOLP (CAR ARGS))
(CHECK-PARAMETER-NAME (CAR ARGS)
ERRLOC)
(CL:PUSH (BQUOTE ((\, (CAR ARGS))
NIL))
%%LET-LIST))
((CL:ATOM (CAR ARGS))
(CL:ERROR "Non-symbolic &AUX parameter %"~S%" in arglist of ~S." (CAR ARGS)
ERRLOC))
((SYMBOLP (CAAR ARGS))
(CHECK-PARAMETER-NAME (CAAR ARGS)
ERRLOC)
(CL:PUSH (BQUOTE ((\, (CAAR ARGS))
(\, (CADAR ARGS))))
%%LET-LIST))
(T (CL:ERROR "Non-symbolic &AUX parameter %"~S%" in arglist of ~S." (CAAR ARGS)
ERRLOC)))))
(DEFUN ANALYZE-KEY (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))))
(DEFUN ANALYZE-PARAMETER (PARAM PATH ERRLOC) (* ;;; "We are given a single parameter and the path for getting to its value. The parameter may ask us to destructure the value. Arrange for the parameter to get its value.")
(COND
((SYMBOLP PARAM) (* ; "The simple, normal case.")
(CHECK-PARAMETER-NAME PARAM ERRLOC)
(CL:PUSH (BQUOTE ((\, PARAM)
(\, PATH)))
%%LET-LIST))
((CL:ATOM PARAM) (* ; "Not so good.")
(CERROR "Ignore this item." "Non-symbol variable name %"~S%" in ~S." PARAM ERRLOC))
(T (* ; "The destructuring case.")
(LET ((NEW-WHOLE (GENSYM)))
(CL:PUSH (BQUOTE ((\, NEW-WHOLE)
(\, PATH)))
%%LET-LIST)
(RECURSIVELY-ANALYZE PARAM NEW-WHOLE ERRLOC NEW-WHOLE)))))
(DEFUN CHECK-PARAMETER-NAME (NAME ERRLOC) (CL:ASSERT (SYMBOLP NAME)
NIL
"CHECK-PARAMETER-NAME should only be called with a symbol!"
)
(COND
((NULL NAME)
(CERROR "Try to continue. Good luck!"
"NIL used as a parameter name in ~S" ERRLOC))
((KEYWORDP NAME)
(CERROR "Use it anyway. This is UGLY..."
"The keyword ~S was used as a parameter name in ~S"
NAME ERRLOC))
((MEMBER NAME LAMBDA-LIST-KEYWORDS :TEST (QUOTE EQ))
(CERROR "Use it anyway. This is UGLY..."
"The lambda-list keyword ~S was used as a parameter name in ~S"
NAME ERRLOC))))
(DEFUN PUSH-KEYWORD-BINDING (VARIABLE KEYWORD DEFAULT SUPPLIED-P-VAR REST-VAR TEMP-VAR ERRLOC)
(CHECK-PARAMETER-NAME VARIABLE ERRLOC)
(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 (NOT (NULL SUPPLIED-P-VAR))
(CHECK-PARAMETER-NAME SUPPLIED-P-VAR ERRLOC)
(CL:PUSH (BQUOTE ((\, SUPPLIED-P-VAR)
(NOT (NULL (\, TEMP-VAR)))))
%%LET-LIST)))
(DEFUN ANALYZE-REST (KEYWORD ARGLIST PATH ERRLOC WHOLE)
(* ;;; "This is complicated by the ``implicit PARSE-BODY'' convention. If a &body keyword is followed by a symbol, then it's just a normal &rest. If it's followed by a list of length one, then it's just like &rest using the CAR of that list. Otherwise, it's a list of length either 2 or 3: (body decls [doc]). The tail of the macro-call arguments is passed to PARSE-BODY along with the current lexical environment (as from &environment) and a doc-string-allowed-p argument of T iff the ``doc'' was specified (that is, the list after &body was of length three). PARSE-BODY returns three values that are then matched against ``body'', ``decls'', and ``doc'' respectively. Those three values can, in turn, be destructured, but it's not likely to be useful in any but the ``body'' case.")
(CL:WHEN (CL:ATOM ARGLIST)
(CL:ERROR "Bad ~S arg in ~S." KEYWORD ERRLOC))
(SETQ %%UNBOUNDED-ARG-COUNT T)
(LET ((REST-ARG (CAR ARGLIST)))
(COND
((OR (CL:ATOM REST-ARG)
(EQ KEYWORD (QUOTE &REST))
(AND (EQ KEYWORD (QUOTE &BODY))
(CONSP REST-ARG)
(NULL (CDR REST-ARG))
(PROGN (SETQ REST-ARG (CAR REST-ARG))
T))) (* ; "The non-parsing case of &rest or &body.")
(ANALYZE-PARAMETER REST-ARG PATH ERRLOC))
((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
"The parsing version of &body is not allowed when no lexical environment is available."
))
(LET ((BODY (CL:FIRST REST-ARG))
(DECLS (SECOND REST-ARG))
(DOC (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)))))))
%%LET-LIST)
(ANALYZE-PARAMETER BODY (BQUOTE (CL:FIRST (\, PARSE-BODY-RESULT)))
ERRLOC)
(ANALYZE-PARAMETER DECLS (BQUOTE (SECOND (\, PARSE-BODY-RESULT)))
ERRLOC)
(CL:WHEN DOC (ANALYZE-PARAMETER DOC (BQUOTE (THIRD (\, PARSE-BODY-RESULT)))
ERRLOC))))
(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-ARG)
(CERROR "Ignore the keywords."
"The parsing version of &body 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))))))
(DEFUN RECURSIVELY-ANALYZE (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)))
(DEFUN DEFMACRO-ARG-TEST (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)))))))
(* ;; "Testing the argument-list parsing")
(DEFVAR ANALYZE-TESTS (QUOTE ((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)))) )
(* ;; "Runtime support functions")
(DEFUN KEYWORD-TEST (ARGS KEYS) (* ;; "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)
(ALLOW-OTHER-KEYS-P NIL))
(FOR TAIL ON ARGS BY (CDDR TAIL) DO (CL:WHEN (EQ (CAR TAIL)
:ALLOW-OTHER-KEYS)
(SETQ ALLOW-OTHER-KEYS-P (CADR TAIL)))
(CL:UNLESS (CL:MEMBER (CAR TAIL)
KEYS :TEST (CL:FUNCTION EQ))
(CL:SETQ EXTRA-KEY-FOUND (CAR TAIL))))
(CL:WHEN (AND EXTRA-KEY-FOUND (NOT ALLOW-OTHER-KEYS-P))
(CL:ERROR "Extraneous keyword %"~S%" given." EXTRA-KEY-FOUND))))
(DEFUN FIND-KEYWORD (KEYWORD KEYLIST) (* ;; "If keyword is present in the keylist, return a list of its argument. Else, return NIL. Be sure to get the value associated with the LAST use of the keyword in the list.")
(CL:DO ((L KEYLIST (CDDR L))
(RESULT NIL))
((CL:ATOM L)
RESULT)
(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)
(SETQ RESULT (LIST (CADR L)))))))
(* ;; "Arrange to use the correct compiler")
(PUTPROPS CMLPARSE FILETYPE COMPILE-FILE)
(PUTPROPS CMLPARSE COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL)))
STOP