(FILECREATED " 9-Oct-86 18:00:08" {ERIS}<LISPCORE>SOURCES>CMLSPECIALFORMS.;3 27179
changes to: (FUNCTIONS CASE)
previous date: " 4-Sep-86 16:56:16" {ERIS}<LISPCORE>SOURCES>CMLSPECIALFORMS.;2)
(* "
Copyright (c) 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT CMLSPECIALFORMSCOMS)
(RPAQQ CMLSPECIALFORMSCOMS ((COMS (* "hacks for Interlisp NLAMBDAs that should look like functions")
(PROP MACRO FRPTQ SETN SUB1VAR *))
(COMS (VARS *COMMON-LISP-SPECIAL-FORMS*)
(FUNCTIONS LOOP)
(COMS (FNS IDENTITY)
(PROP DMACRO IDENTITY))
(FUNCTIONS CL:UNLESS CL:WHEN))
(FUNCTIONS FLET LABELS SELECTQ)
(COMS (* * "DO DO* and support.")
(FUNCTIONS CL:DO CL:DO*)
(FNS \DO.TRANSLATE))
(COMS (* "somewhat bogus definitions")
(FUNCTIONS DOLIST DOTIMES)
(FNS EXPAND-LOOP LOOP-EXPAND LOOP-EXPAND-BODY LOOP-EXPAND-FOR)
(FUNCTIONS CASE)
(FNS CASE-1))
(PROP FILETYPE CMLSPECIALFORMS)
(COMS (* hacks)
(COMS (FNS BQUOTIFY)
(USERMACROS BQUOTE UNCOMMA)
(VARS *BQUOTE-COMMA* *BQUOTE-COMMA-ATSIGN* *BQUOTE-COMMA-DOT*
)
(GLOBALVARS *BQUOTE-COMMA* *BQUOTE-COMMA-ATSIGN*
*BQUOTE-COMMA-DOT*))
(COMS (FNS CLEAR-CLISPARRAY)
(DECLARE: DONTEVAL@LOAD DOCOPY (ADDVARS (MARKASCHANGEDFNS
CLEAR-CLISPARRAY))))
(P (PROCLAIM (QUOTE (SPECIAL FILEPKGFLG DFNFLG *READTABLE*)))
(PROCLAIM (CONS (QUOTE SPECIAL)
SYSSPECVARS))))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA IDENTITY)))))
(* "hacks for Interlisp NLAMBDAs that should look like functions")
(PUTPROPS FRPTQ MACRO (= . RPTQ))
(PUTPROPS SETN MACRO (= . SETQ))
(PUTPROPS SUB1VAR MACRO ((X)
(SETQ X (SUB1 X))))
(PUTPROPS * MACRO ((X . Y)
(QUOTE X)))
(RPAQQ *COMMON-LISP-SPECIAL-FORMS*
(CL:BLOCK CATCH COMPILER-LET DECLARE EVAL-WHEN FLET FUNCTION GO COND LABELS LET LET* MACROLET
MULTIPLE-VALUE-CALL MULTIPLE-VALUE-PROG1 PROGN PROGV QUOTE RETURN-FROM CL:SETQ TAGBODY
THE THROW UNWIND-PROTECT))
(DEFMACRO LOOP (&REST FORMS) (LET ((TAG (GENSYM "LOOPTAG")))
(BQUOTE (PROG NIL
(\, TAG)
(\,@ FORMS)
(GO (\, TAG))))))
(DEFINEQ
(IDENTITY
(CL:LAMBDA (THING)
"Returns what was passed to it. Default for :key options." THING))
)
(PUTPROPS IDENTITY DMACRO ((X)
X))
(DEFMACRO CL:UNLESS (TEST &BODY BODY) (BQUOTE (COND
((\, (NEGATE TEST))
(\,@ BODY)))))
(DEFMACRO CL:WHEN (TEST &BODY BODY) (BQUOTE (COND
((\, TEST)
(\,@ BODY)))))
(DEFMACRO FLET (FUNCTION-BINDINGS &BODY BODY &ENVIRONMENT ENV)
(LET
((FUNCTIONS (MAPCAR FUNCTION-BINDINGS (FUNCTION (LAMBDA (X)
(CONS (GENSYM)
X))))))
(BQUOTE
(LET
(\, (for X in FUNCTIONS collect (BQUOTE ((\, (CAR X))
(FUNCTION (CL:LAMBDA (\,@ (CDDR X))))))))
(\, (WALK-FORM
(BQUOTE (PROGN (\,@ BODY)))
:ENVIROMENT ENV :WALK-FUNCTION
(CL:FUNCTION (CL:LAMBDA
(FORM CONTEXT)
(CL:IF (NLISTP FORM)
FORM
(COND
((FMEMB (CAR FORM)
(QUOTE (FUNCTION CL:FUNCTION)))
(for Z in FUNCTIONS when (EQ (CADR FORM)
(CADR Z))
do (RETURN (CAR Z)) finally (RETURN FORM)))
(T (for Z in FUNCTIONS when (EQ (CAR FORM)
(CADR Z))
do (RETURN (BQUOTE (FUNCALL (\, (CAR Z))
(\,@ (CDR FORM)))))
finally (RETURN FORM)))))))))))))
(DEFMACRO LABELS (FUNCTION-BINDINGS &BODY BODY &ENVIRONMENT ENV)
(LET
((FUNCTIONS (MAPCAR FUNCTION-BINDINGS (FUNCTION (LAMBDA (X)
(CONS (GENSYM)
X))))))
(LIST (QUOTE LET)
(MAPCAR FUNCTIONS (FUNCTION CAR))
(WALK-FORM
(BQUOTE (PROGN (\,@ (for X in FUNCTIONS collect (BQUOTE (SETQ (\, (CAR X))
(FUNCTION (CL:LAMBDA
(\,@ (CDDR X))))))))
(\,@ BODY)))
:ENVIROMENT ENV :WALK-FUNCTION
(CL:FUNCTION (CL:LAMBDA
(FORM CONTEXT)
(CL:IF (NLISTP FORM)
FORM
(COND
((FMEMB (CAR FORM)
(QUOTE (FUNCTION CL:FUNCTION)))
(for Z in FUNCTIONS when (EQ (CADR FORM)
(CADR Z))
do (RETURN (CAR Z)) finally (RETURN FORM)))
(T (for Z in FUNCTIONS when (EQ (CAR FORM)
(CADR Z))
do (RETURN (BQUOTE (FUNCALL (\, (CAR Z))
(\,@ (CDR FORM)))))
finally (RETURN FORM)))))))))))
(DEFMACRO SELECTQ (SELECTOR &REST FORMS)
(LET*
((KV (CL:IF (SYMBOLP SELECTOR)
SELECTOR
(GENSYM)))
(CLAUSES
(for C on FORMS
collect
(COND
((NULL (CDR C))
(BQUOTE (T (\, (CAR C)))))
((NOT (CONSP (CAAR C)))
(BQUOTE ((EQ (\, KV)
(QUOTE (\, (CAAR C))))
(\,@ (CDAR C)))))
(T (BQUOTE ((OR (\,@ (CL:DO ((X (CAAR C)
(CDR X))
(Y NIL))
((CL:ATOM X)
(REVERSE Y))
(CL:PUSH (BQUOTE (EQ (\, KV)
(QUOTE (\, (CAR X)))))
Y))))
(\,@ (CDAR C)))))))))
(CL:IF (EQ KV SELECTOR)
(BQUOTE (COND
(\,@ CLAUSES)))
(BQUOTE (LET (((\, KV)
(\, SELECTOR)))
(COND
(\,@ CLAUSES)))))))
(* * "DO DO* and support.")
(DEFMACRO CL:DO (VARS END-TEST &BODY BODY &ENVIRONMENT ENV) (\DO.TRANSLATE VARS END-TEST BODY NIL ENV
))
(DEFMACRO CL:DO* (BINDS END-TEST &REST BODY &ENVIRONMENT ENV) (\DO.TRANSLATE BINDS END-TEST BODY T
ENV))
(DEFINEQ
(\DO.TRANSLATE
[LAMBDA (VARS END-TEST BODY SEQUENTIALP ENV) (* lmm " 3-Jun-86 00:12")
(LET ([VARS-AND-INITIAL-VALUES (MAPCAR VARS (FUNCTION (LAMBDA (X)
(COND
((NLISTP X)
(LIST X NIL))
(T (LIST (CAR X)
(CADR X]
[SUBSEQUENT-VALUES (MAPCAR VARS (FUNCTION (LAMBDA (X)
(AND (LISTP X)
(CDDR X)
(LIST (CAR X)
(CADDR X]
(TAG (GENSYM)))
[AND (SETQ SUBSEQUENT-VALUES (REMOVE NIL SUBSEQUENT-VALUES))
(SETQ SUBSEQUENT-VALUES (CONS (COND
(SEQUENTIALP (QUOTE CL:SETQ))
(T (QUOTE PSETQ)))
(APPLY (FUNCTION APPEND)
SUBSEQUENT-VALUES]
(MULTIPLE-VALUE-BIND (BODY DECLS)
(PARSE-BODY BODY ENV)
(BQUOTE ([\, (COND
(SEQUENTIALP (QUOTE PROG*))
(T (QUOTE PROG]
(\, VARS-AND-INITIAL-VALUES)
(\,@ DECLS)
(\, TAG)
[COND
((\, (CAR END-TEST))
(RETURN (PROGN (\,@ (CDR END-TEST]
(PROGN (\,@ BODY))
(\, SUBSEQUENT-VALUES)
(GO (\, TAG])
)
(* "somewhat bogus definitions")
(DEFMACRO DOLIST ((VAR LISTFORM &OPTIONAL RESULTFORM)
&BODY BODY &ENVIRONMENT ENV)
(LET ((TAIL (GENSYM)))
(MULTIPLE-VALUE-BIND (BODY DECL)
(PARSE-BODY BODY ENV)
(BQUOTE (LET (((\, TAIL)
(\, LISTFORM))
(\, VAR))
(\,@ DECL)
(LOOP (SETQ (\, VAR)
(CAR (OR (\, TAIL)
(PROGN (SETQ (\, VAR)
NIL)
(RETURN (\, RESULTFORM))))))
(\,@ BODY)
(SETQ (\, TAIL)
(CDR (\, TAIL)))))))))
(DEFMACRO DOTIMES ((VAR COUNTFORM &OPTIONAL RESULTFORM)
&BODY BODY &ENVIRONMENT ENV)
(LET ((MAX (GENTEMP)))
(MULTIPLE-VALUE-BIND (BODY DECLS)
(PARSE-BODY BODY ENV)
(BQUOTE (LET (((\, MAX)
(\, COUNTFORM))
((\, VAR)
0))
(LOOP (COND
((>= (\, VAR)
(\, MAX))
(RETURN (\, (OR RESULTFORM NIL)))))
(\,@ BODY)
(INCF (\, VAR))))))))
(DEFINEQ
(EXPAND-LOOP
[LAMBDA (LOOP-ARGS) (* Gregor: " 1-Jul-85 20:08")
(LET ((TAG (GENSYM))
(RESULT-VAR (GENSYM))
(PROLOGUE NIL)
(BODY NIL)
(EPILOGUE NIL))
[CL:DO ((REMAINING LOOP-ARGS))
((NULL REMAINING))
(COND
((SYMBOLP (CAR REMAINING))
(SETQ REMAINING (LOOP-EXPAND-BODY REMAINING]
(LIST (QUOTE PROG)
NIL TAG (CONS (QUOTE PROGN)
(REVERSE BODY))
(LIST (QUOTE GO)
TAG)
(CONS (QUOTE PROGN)
(REVERSE EPILOGUE))
(LIST (QUOTE RETURN)
RESULT-VAR])
(LOOP-EXPAND
[LAMBDA (LOOP-ARGS) (* Gregor: " 1-Jul-85 20:08")
(LET ((TAG (GENSYM))
(RESULT-VAR (GENSYM))
(PROLOGUE NIL)
(BODY NIL)
(EPILOGUE NIL))
[CL:DO ((REMAINING LOOP-ARGS))
((NULL REMAINING))
(COND
((SYMBOLP (CAR REMAINING))
(SETQ REMAINING (LOOP-EXPAND-BODY REMAINING]
(LIST (QUOTE PROG)
NIL TAG (CONS (QUOTE PROGN)
(REVERSE BODY))
(LIST (QUOTE GO)
TAG)
(CONS (QUOTE PROGN)
(REVERSE EPILOGUE))
(LIST (QUOTE RETURN)
RESULT-VAR])
(LOOP-EXPAND-BODY
[LAMBDA (REMAINING) (* kmk: " 3-Jul-85 19:57")
(LET ((KEYWORD (CAR REMAINING))
(ARG (CADR REMAINING))
(OPTION? (CADDR REMAINING))
(OPTION-ARG? (CADDDR REMAINING)))
(COND
((EQ KEYWORD (QUOTE DO))
(CL:PUSH ARG BODY)
(SETQ REMAINING (CDDR REMAINING)))
[(MEMBER KEYWORD (QUOTE (COLLECT APPEND NCONC SUM MAXIMIZE MINIMIZE)))
[COND
((EQ OPTION? (QUOTE INTO))
(SETQ RESULT-VAR OPTION-ARG?)
(SETQ REMAINING (CDDDDR REMAINING)))
(T (SETQ REMAINING (CDDR REMAINING]
(COND
((EQ KEYWORD (QUOTE COLLECT))
(CL:PUSH (LIST (QUOTE CL:PUSH)
ARG RESULT-VAR)
BODY)
(CL:PUSH (LIST (QUOTE SETQ)
RESULT-VAR
(LIST (QUOTE REVERSE)
RESULT-VAR))
EPILOGUE))
((MEMBER KEYWORD (QUOTE (APPEND NCONC)))
(CL:PUSH (LIST (QUOTE SETQ)
RESULT-VAR
(LIST KEYWORD RESULT-VAR ARG))
BODY))
((EQ KEYWORD (QUOTE SUM))
(CL:PUSH (LIST (QUOTE SETQ)
RESULT-VAR
(LIST (QUOTE PLUS)
RESULT-VAR ARG))
BODY))
((MEMBER KEYWORD (QUOTE (MAXIMIZE MINIMIZE)))
(CL:PUSH (LIST (QUOTE SETQ)
RESULT-VAR
(LIST [CADR (MEMBER KEYWORD (QUOTE (MAXIMIZE MAX MINIMIZE MIN]
RESULT-VAR ARG))
BODY]
(T (ERROR "Unrecognized LOOP keyword or implicit PROGN.")))
REMAINING])
(LOOP-EXPAND-FOR
[LAMBDA (REMAINING) (* Gregor: " 1-Jul-85 20:16")
(LET ((VAR (CADR REMAINING))
(PATH (CADDR REMAINING)))
(CL])
)
(DEFMACRO CASE (SELECTOR &REST CASES)
(LET*
((KV (CL:IF (SYMBOLP SELECTOR)
SELECTOR
(GENSYM)))
(CLAUSES
(FOR CASE IN CASES
COLLECT
(LET ((KEY-LIST (CAR CASE))
(CONSEQUENTS (OR (CDR CASE)
(LIST NIL))))
(COND
((FMEMB KEY-LIST (QUOTE (T OTHERWISE)))
(BQUOTE (T (\,@ CONSEQUENTS))))
((CL:ATOM KEY-LIST)
(BQUOTE ((EQL (\, KV)
(QUOTE (\, KEY-LIST)))
(\,@ CONSEQUENTS))))
(T (BQUOTE ((OR (\,@ (FOR X IN KEY-LIST
COLLECT (BQUOTE (EQL (\, KV)
(QUOTE (\, X)))))))
(\,@ CONSEQUENTS)))))))))
(CL:IF (EQ KV SELECTOR)
(BQUOTE (COND
(\,@ CLAUSES)))
(BQUOTE (LET (((\, KV)
(\, SELECTOR)))
(COND
(\,@ CLAUSES)))))))
(DEFINEQ
(CASE-1
[LAMBDA (FOR-WHO CLAUSES KEY-VARIABLE TEST-FN DEFAULT-T-CLAUSE-FORM ALLOW-NIL-P ALLOW-REPEATS-P
ALLOW-OTHERWISE-OR-T-P) (* amd "19-May-86 14:35")
(* * Note that the fact that we only take one TEST argument which looks for a
key in a keylist means that the compiler should have an optimizer for fmemb
when the second argument is a constant list of length one
(or maybe even two))
(LET
((SAW-OTHERWISE-OR-T NIL)
(ALL-KEYS NIL)
(COND-CLAUSES NIL))
[for CLAUSE-LOC on CLAUSES
do (LET* [(KEYLIST (CAAR CLAUSE-LOC))
(BODY (CDAR CLAUSE-LOC))
(TEST (COND
((NULL KEYLIST)
(OR (NOT (NULL ALLOW-NIL-P))
(ERROR FOR-WHO "Can't have NIL as a keylist."))
NIL)
((MEMB KEYLIST (QUOTE (T OTHERWISE)))
(OR (NOT (NULL ALLOW-OTHERWISE-OR-T-P))
(ERROR "Can't have an otherwise (or T) keylist." FOR-WHO))
(SETQ SAW-OTHERWISE-OR-T T)
(AND (CDR CLAUSE-LOC) (* When Compiling warn about clauses
being ignored.)
)
T)
(T [COND
((NOT (LISTP KEYLIST))
(SETQ KEYLIST (LIST KEYLIST]
[for X on KEYLIST
do (COND
([AND (NOT (NULL (CDR X)))
(NOT (LISTP (CDR X]
(ERROR FOR-WHO (CONCAT "The Keylist " KEYLIST
" has a non-list cdr.")))
((NOT (SYMBOLP (CAR X)))
(ERROR FOR-WHO (CONCAT "Not all the elements of the keylist "
KEYLIST " are symbols.")))
(T (AND (MEMB (CAR X)
ALL-KEYS)
(NOT (NULL ALLOW-REPEATS-P))
(ERROR FOR-WHO (CONCAT "The same key (" (CAR X)
") can't appear in more that one keylist."
)))
(CL:PUSH (CAR X)
ALL-KEYS]
(LIST TEST-FN KEY-VARIABLE (LIST (QUOTE QUOTE)
KEYLIST]
(AND TEST (SETQ COND-CLAUSES (NCONC COND-CLAUSES (LIST (CONS TEST BODY]
[OR SAW-OTHERWISE-OR-T (SETQ COND-CLAUSES (NCONC COND-CLAUSES (LIST (LIST T
DEFAULT-T-CLAUSE-FORM]
(LIST COND-CLAUSES ALL-KEYS])
)
(PUTPROPS CMLSPECIALFORMS FILETYPE COMPILE-FILE)
(* hacks)
(DEFINEQ
(BQUOTIFY
[LAMBDA (FORM) (* bvm: "10-Jun-86 17:07")
(* turn FORM into a BQUOTE if it can.
If so, return it as a list, otherwise,
return NIL)
(COND
[(LISTP FORM)
(LET
((FN (CAR FORM))
(TAIL (CDR FORM)))
(AND (LISTP TAIL)
[OR (NULL (CDR TAIL))
(AND (LISTP (CDR TAIL))
(OR (NULL (CDDR TAIL))
(SELECTQ FN
((CONS NCONC1) (*
"These take exactly two args, so if there are more, it's an error")
NIL)
T]
(SELECTQ FN
((QUOTE BQUOTE)
(AND (NULL (CDR TAIL))
(LIST (CAR TAIL))))
(LIST [LIST (for X in TAIL join (OR (BQUOTIFY X)
(LIST (LIST *BQUOTE-COMMA* X])
((CONS LIST*)
[LIST (APPEND [OR (BQUOTIFY (CAR TAIL))
(LIST (LIST *BQUOTE-COMMA* (CAR TAIL]
(OR [CAR (BQUOTIFY (SETQ TAIL (COND
((AND (EQ FN (QUOTE LIST*))
(CDDR TAIL))
(CONS (QUOTE LIST*)
(CDR TAIL)))
(T (CADR TAIL]
(LIST (LIST *BQUOTE-COMMA-ATSIGN* TAIL])
((APPEND NCONC NCONC1)
[LET [(DEFAULT (COND
((EQ FN (QUOTE APPEND))
*BQUOTE-COMMA-ATSIGN*)
(T *BQUOTE-COMMA-DOT*)))
(BQCAR (BQUOTIFY (CAR TAIL]
(LIST (APPEND [COND
((AND BQCAR (for (TL ← (SETQ BQCAR (CAR BQCAR)))
by (CDR TL) while TL
never (NLISTP TL)))
(* "Second condition catches (APPEND (CONS A 0) --), where the (CONS A 0) turns into (,A . 0) and then the APPEND would lose it. It will lose it at runtime, too, of course, but let's not remove mistakes from the source.")
BQCAR)
(T (LIST (LIST DEFAULT (CAR TAIL]
(COND
[(EQ FN (QUOTE NCONC1))
(*
"Second arg is an element, not a segment")
(OR (BQUOTIFY (SETQ TAIL (CADR TAIL)))
(LIST (LIST *BQUOTE-COMMA* TAIL]
(T (OR [CAR (BQUOTIFY (SETQ TAIL (COND
((CDDR TAIL)
(CONS FN
(CDR TAIL)))
(T (CADR TAIL]
(LIST (LIST DEFAULT TAIL])
NIL]
((OR (NUMBERP FORM)
(STRINGP FORM)
(EQ FORM T)
(NULL FORM))
(LIST FORM))
(T NIL])
)
(ADDTOVAR USERMACROS (UNCOMMA NIL (IF (EQ (## 1)
(QUOTE BQUOTE))
NIL
((IF (EQ (## !0 1)
(QUOTE BQUOTE))
(!0))))
(I 2 (\UNCOMMA (## 2)))))
(ADDTOVAR EDITMACROS (BQUOTE NIL UP (ORR ((I 1 (OR (CONS (QUOTE BQUOTE)
(OR (BQUOTIFY (## 1))
(ERROR!)))
(ERROR!))))
((E (QUOTE BQUOTE?))))
1))
(ADDTOVAR EDITCOMSA BQUOTE UNCOMMA)
(RPAQQ *BQUOTE-COMMA* \,)
(RPAQQ *BQUOTE-COMMA-ATSIGN* \,@)
(RPAQQ *BQUOTE-COMMA-DOT* \,.)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS *BQUOTE-COMMA* *BQUOTE-COMMA-ATSIGN* *BQUOTE-COMMA-DOT*)
)
(DEFINEQ
(CLEAR-CLISPARRAY
[LAMBDA (NAME TYPE REASON) (* bvm: "25-Jun-86 12:59")
(SELECTQ REASON
((T CLISP) (*
"New definition or changed only by CLISP translation")
NIL)
(CLRHASH CLISPARRAY])
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(ADDTOVAR MARKASCHANGEDFNS CLEAR-CLISPARRAY)
)
(PROCLAIM (QUOTE (SPECIAL FILEPKGFLG DFNFLG *READTABLE*)))
(PROCLAIM (CONS (QUOTE SPECIAL)
SYSSPECVARS))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA IDENTITY)
)
(PUTPROPS CMLSPECIALFORMS COPYRIGHT ("Xerox Corporation" 1983 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (3549 3672 (IDENTITY 3559 . 3670)) (8998 10974 (\DO.TRANSLATE 9008 . 10972)) (12538
16357 (EXPAND-LOOP 12548 . 13324) (LOOP-EXPAND 13326 . 14102) (LOOP-EXPAND-BODY 14104 . 16150) (
LOOP-EXPAND-FOR 16152 . 16355)) (17518 20965 (CASE-1 17528 . 20963)) (21038 25340 (BQUOTIFY 21048 .
25338)) (26360 26733 (CLEAR-CLISPARRAY 26370 . 26731)))))
STOP