(FILECREATED "19-Dec-84 18:46:09" {ERIS}<LISPCORE>LIBRARY>CMLSPECIALFORMS.;20 19694
changes to: (MACROS PSETQ CATCH THROW)
(FNS CATCH \DEFUNexpander \LETtran)
(VARS CMLSPECIALFORMSCOMS)
previous date: "14-Nov-84 22:39:08" {ERIS}<LISPCORE>LIBRARY>CMLSPECIALFORMS.;12)
(* Copyright (c) 1983, 1984 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLSPECIALFORMSCOMS)
(RPAQQ CMLSPECIALFORMSCOMS ((COMS (*
"CommonLisp style DEFUN, LET LET* PROG* LIST* macros and CATCH and THROW")
(MACROS LET LET* PROG* LIST* PSETQ PROGV DEFUN)
(FNS \LETtran \DEFUNexpander \Process&Specs)
(FNS LIST*)
(PROP INFO LET LET* PROG*)
(ALISTS (PRETTYEQUIVLST LET LET* PROG*)))
(COMS (* "CommonLisp style CATCH and THROW")
(FNS CATCH \CATCH.AUX \CATCH.FINDFRAME \CATCH.TAG.INTERN THROW
\THROW.AUX)
(MACROS CATCH *CATCH \CATCHRUNFUN THROW *THROW \CATCHRELSTKP
UNWINDPROTECT)
(VARS (\CATCH.1SHOT.OPOS (STKNTH 0 T))
(\THROW.1SHOT.OPOS (STKNTH 0 T)))
(DECLARE: EVAL@COMPILE (PROP SPECVAR \CATCH.1SHOT.OPOS
\THROW.1SHOT.OPOS))
(DECLARE: DONTCOPY EVAL@COMPILE (MACROS DATATYPE.TEST)
(P (OR (AND (GETMACROPROP (QUOTE UNINTERRUPTABLY)
COMPILERMACROPROPS)
(RECLOOK (QUOTE LITATOM))
(GETP (QUOTE inatom)
(QUOTE I.S.OPR)))
(HELP
"You need to have ABC loaded to EDIT/COMPILE this file"))))
(DECLARE: COPYWHEN (EQ COMPILEMODE (QUOTE D))
(*
"Crufty low-level stuff to help make \CATCH.TAG.INTERN more efficient")
(VARS (\THROW.STRBUFFER (PROG ((X (ALLOCSTRING 256)))
(RPLSTRING X 1
(QUOTE
\CATCH.TAG.))
(RETURN X))))
(PROP DMACRO \MYALINK)
(DECLARE: EVAL@COMPILEWHEN (EQ COMPILEMODE (QUOTE D))
(PROP GLOBALVAR \THROW.STRBUFFER))))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA CATCH)
(NLAML)
(LAMA LIST*)))))
(* "CommonLisp style DEFUN, LET LET* PROG* LIST* macros and CATCH and THROW")
(DECLARE: EVAL@COMPILE
(PUTPROPS LET MACRO (X (\LETtran X)))
(PUTPROPS LET* MACRO (X (\LETtran X T)))
(PUTPROPS PROG* MACRO (X
(\LETtran X (QUOTE PROG*))))
(PUTPROPS LIST* MACRO (X
(COND
((NULL X)
NIL)
((NULL (CDR X))
(CAR X))
((NULL (CDDR X))
(CONS (QUOTE CONS)
X))
(T (LIST (QUOTE CONS)
(CAR X)
(CONS (QUOTE LIST*)
(CDR X)))))))
(PUTPROPS PSETQ MACRO (X
(COND
((NLISTP X)
NIL)
((NLISTP (CDR X))
(HELP "Odd number args for PSETQ"))
(T (LIST (QUOTE SETQ)
(CAR X)
(COND
((CDDR X)
(LIST (QUOTE PROG1)
(CADR X)
(CONS (QUOTE PSETQ)
(CDDR X))))
(T (CADR X))))))))
(PUTPROPS PROGV MACRO ((SYMS VALS . BODY)
(EVALA (LIST (FUNCTION (LAMBDA NIL . BODY)))
((LAMBDA (\Vars \Vals)
(DECLARE (LOCALVARS \Vars \Vals))
(while \Vars collect (CONS (pop \Vars)
(OR (pop \Vals)
(QUOTE NOBIND)))))
SYMS VALS))))
(PUTPROPS DEFUN MACRO (X
(\DEFUNexpander X)))
)
(DEFINEQ
(\LETtran
(LAMBDA (X SEQUENTIALP) (* JonL "17-Dec-84 16:54")
(PROG ((VARS (MAPCAR (CAR X)
(FUNCTION (LAMBDA (X)
(if (LISTP X)
then (SETQ X (CAR X)))
(if (OR (NULL X)
(EQ X T)
(NOT (LITATOM X)))
then (ERRORX (LIST (if (LITATOM X)
then 35
else 14)
X)))
X))))
(VALS (MAPCAR (CAR X)
(FUNCTION (LAMBDA (X)
(if (LISTP X)
then (LIST* (QUOTE PROG1)
(CDR X))
else NIL)))))
(BODY (CDR X))
(DECLS NIL)
(COMNTS NIL))
(RETURN (if (NOT SEQUENTIALP)
then (LIST* (LIST* (QUOTE LAMBDA)
VARS BODY)
VALS)
else (PROGN (* foo, in the sequential case, all declarations must
be "pulled up" to the top)
(SETQ BODY (\DECL.COMNT.PROCESS BODY))
(SETQ DECLS (pop BODY))
(SETQ COMNTS (pop BODY)))
(if (EQ SEQUENTIALP (QUOTE PROG*))
then (SETQ BODY (LIST (LIST* (QUOTE PROG)
NIL BODY))))
(for VAR in (DREVERSE (CDR VARS)) as VAL in (DREVERSE (CDR VALS))
do (SETQ BODY (LIST (LIST (LIST* (QUOTE LAMBDA)
(LIST VAR)
BODY)
VAL))))
(LIST (LIST* (QUOTE LAMBDA)
(LIST (CAR VARS))
(NCONC (DREVERSE DECLS)
(DREVERSE COMNTS)
BODY))
(CAR VALS)))))))
(\DEFUNexpander
(LAMBDA (DEF) (* JonL "18-Dec-84 18:40")
(PROG ((TYPE (QUOTE LAMBDA))
(L DEF)
NAME ARGL BODY SPECIND SPECNAM SPECVAL LAMBDALIST)
(SETQ NAME (pop L))
(if (AND (EQ (CAR L)
(QUOTE MACRO))
(NLISTP NAME))
then (* Convert (DEFUN MUMBLE MACRO ...) into
(DEFUN (MUMBLE MACRO) ...))
(SETQ NAME (LIST NAME (QUOTE MACRO)))
(pop L))
(if (LISTP NAME)
then (SELECTQ (CADR NAME)
((EXPR FEXPR LEXPR)
(push L (CADR NAME))
(SETQ NAME (CAR NAME)))
(PROGN (* Note that the (DEFUN (FOO MACRO) ...) case also
comes thru here.)
(SETQ SPECIND (CADR NAME))
(SETQ SPECNAM (MKATOM (CONCAT (GENSYM)
"$$"
(SETQ NAME (CAR NAME)))))
(SETQ SPECVAL
(if (EQ SPECIND (QUOTE MACRO))
then (BQUOTE (QUOTE (MACROARGS (, SPECNAM
(CONS (QUOTE , NAME)
MACROARGS)))))
else (BQUOTE (GETD (QUOTE , SPECNAM))))))))
(SELECTQ (CAR L)
(FEXPR (SETQ TYPE (QUOTE NLAMBDA))
(pop L))
(EXPR (pop L))
NIL)
(SETQ ARGL (CAR L))
(if (AND (EQ (QUOTE LAMBDA)
TYPE)
(LISTP ARGL)
(OR (MEMB (QUOTE &AUX)
ARGL)
(MEMB (QUOTE &OPTIONAL)
ARGL)
(MEMB (QUOTE &REST)
ARGL)
(MEMB (QUOTE &BODY)
ARGL)))
then (SETQ L (\Process&Specs (OR SPECNAM NAME)
L))
(SETQ TYPE (pop L)))
(SETQ LAMBDALIST (pop L))
(for TAIL FORM Z on L until (if (LISTP (SETQ FORM (CAR TAIL)))
then (NEQ (QUOTE DECLARE)
(CAR FORM))
else (NOT (STRINGP FORM)))
do (if (STRINGP FORM)
then (* Aha, a MacLisp style comment that can be converted)
(SETQ L (NCONC (DREVERSE Z)
(CONS (LIST COMMENTFLG FORM)
(CDR TAIL))))
(RETURN)
else (* Just consing up the prefix of the list in case it's
needed for the previous clause.)
(push Z FORM)))
(SETQ BODY (BQUOTE (DEFINEQ (, (OR SPECNAM NAME)
(, TYPE , LAMBDALIST (PROGN (QUOTE DEFUN)
(, COMMENTFLG ARGLIST = , ARGL)
,. L))))))
(RETURN (if SPECNAM
then (LIST (QUOTE PROGN)
(QUOTE 'COMPILE)
BODY
(LIST (QUOTE /PUTPROP)
(KWOTE NAME)
(KWOTE SPECIND)
SPECVAL)
(KWOTE NAME))
else BODY)))))
(\Process&Specs
(LAMBDA (NAME EXP) (* JonL "25-Oct-84 17:47")
(PROG (VRBLS OPTVARS AUXLIST RESTFORM VARTYP OPTCODE ARGVAR BODY)
(for BINDING VAR in (CAR EXP) as CNT from 1
do (SELECTQ BINDING
((&REST &BODY)
(SETQ VARTYP (QUOTE &REST))
(add CNT -1))
((&AUX &OPTIONAL)
(SETQ VARTYP BINDING)
(add CNT -1))
(PROGN (SETQ VAR (if (LISTP BINDING)
then (CAR BINDING)
else BINDING))
(OR (AND VAR (LITATOM VAR)
(NEQ VAR T))
(ERROR "Non bindable atom" VAR))
(SELECTQ VARTYP
(NIL (* Regular default &REQUIRED variable)
(OR (EQ VAR BINDING)
(ERROR "Non-atomic &REQUIRED var?" BINDING))
(push VRBLS BINDING))
(&REST (OR ARGVAR (SETQ ARGVAR (MKATOM (CONCAT (QUOTE \)
NAME
".ARGCNT"))))
(OR (NULL RESTFORM)
(ERROR "Too many &REST keywords" BINDING))
(SETQ RESTFORM
(BQUOTE ((, VAR
(for \Index from , CNT
to , ARGVAR
collect (ARG , ARGVAR \Index)))))))
(&AUX (push AUXLIST (if (NLISTP BINDING)
then (LIST VAR NIL)
elseif (CDDR BINDING)
then (ERROR
"Extra cruft in &AUX form"
BINDING)
else (LIST VAR (CADR BINDING)))))
(&OPTIONAL
(OR ARGVAR (SETQ ARGVAR (MKATOM (CONCAT (QUOTE \)
NAME ".ARGCNT"))))
(OR (LISTP BINDING)
(SETQ BINDING (LIST BINDING)))
(push OPTVARS VAR)
(if (SETQ SUPPLIEDP (CADDR BINDING))
then (* Hmmmm, a supplied-p arg?)
(OR (AND SUPPLIEDP (LITATOM SUPPLIEDP)
(NEQ SUPPLIEDP T))
(ERROR "Non bindable atom" SUPPLIEDP))
(push OPTVARS SUPPLIEDP))
(push OPTCODE
(BQUOTE (SETQ , VAR
(if (IGREATERP , CNT , ARGVAR)
then , (CADR BINDING)
else ,@(if SUPPLIEDP
then (BQUOTE ((SETQ ,
SUPPLIEDP T)))
)
(ARG , ARGVAR , CNT))))))
(SHOULDNT)))))
(SETQ BODY (APPEND (CDR EXP)
NIL))
(if AUXLIST
then (SETQ BODY (BQUOTE ((LET* (,@
(DREVERSE AUXLIST))
,@ BODY)))))
(if (NULL ARGVAR)
then (RETURN (LIST* (QUOTE LAMBDA)
(DREVERSE VRBLS)
BODY))
else (RETURN (BQUOTE (LAMBDA , ARGVAR
(LET (,.
(for VAR)
,. OPTVARS ,. RESTFORM)
,. (DREVERSE OPTCODE)
,. BODY))))))))
)
(DEFINEQ
(LIST*
(LAMBDA NARGS (* JonL " 5-Oct-84 20:06")
(if (EQ 0 NARGS)
then NIL
elseif (EQ 1 NARGS)
then (ARG NARGS 1)
else (bind (VAL ←(ARG NARGS NARGS)) for I from (SUB1 NARGS) by -1 until (ILEQ I 0)
do (push VAL (ARG NARGS I)) finally (RETURN VAL)))))
)
(PUTPROPS LET INFO (BINDS EVAL))
(PUTPROPS LET* INFO (BINDS EVAL))
(PUTPROPS PROG* INFO (EVAL BINDS LABELS))
(ADDTOVAR PRETTYEQUIVLST (LET . LAMBDA)
(LET* . LAMBDA)
(PROG* . PROG))
(* "CommonLisp style CATCH and THROW")
(DEFINEQ
(CATCH
(NLAMBDA L (* JonL "18-Dec-84 21:53")
(PROG ((Y (LISPFORM.SIMPLIFY (CONS (QUOTE PROGN)
L)
T)))
(* * Stupid CLISP format my have things like (CATCH (QUOTE FOO) x ← y))
(OR (EQ 2 (LENGTH (SETQ Y (CDR Y))))
(ERROR L "WRONG FORMAT FOR CATCH"))
(RETURN (\CATCH.AUX (EVAL (CAR Y)
(QUOTE INTERNAL))
(CADR Y)
T)))))
(\CATCH.AUX
(LAMBDA (TAG FUN FORMP) (* JonL "25-SEP-83 23:08")
(DECLARE (USEDFREE \CATCH.1SHOT.OPOS)) (* WARNING! This function cannot be run interpretively,
due to the expectations for the STKNTH call below)
(PROG ((STKPOSVARNAME (\CATCH.TAG.INTERN TAG))
(STKPOS (\CATCH.FINDFRAME))
(\CATCH.1SHOT.OPOS NIL))
(DECLARE (LOCALVARS STKPOSVARNAME STKPOS)
(SPECVARS \CATCH.1SHOT.OPOS \CATCHBODY))
(* Now do you see why Interlisp needs a PROGV like
MacLisp has?)
(RETURN (EVALA (if FORMP
then FUN
else (if (LITATOM FUN)
then (OR (AND FUN (NEQ FUN T))
(SHOULDNT "unacceptable function")))
(LIST FUN))
(LIST (CONS STKPOSVARNAME STKPOS)))))))
(\CATCH.FINDFRAME
(LAMBDA (POS) (* JonL "25-SEP-83 23:18")
(STKNTH -1 (OR (STACKP (SETQ POS (STKPOS (QUOTE \CATCH.AUX)
NIL NIL POS)))
(SHOULDNT))
POS)))
(\CATCH.TAG.INTERN
(LAMBDA (TAG) (* JonL "21-SEP-83 15:00")
(OR (AND (SETQ TAG (DATATYPE.TEST TAG (QUOTE LITATOM)))
(NEQ TAG T))
(ERROR TAG "NIL and T not usable as CATCH tags"))
(OR (SELECTQ (SYSTEMTYPE)
(D (UNINTERRUPTABLY
(bind (BASE ←(fetch (DSTRINGP BASE) of \THROW.STRBUFFER)) for CHAR
inatom TAG as I from (IPLUS 11 (fetch (DSTRINGP OFFST) of \THROW.STRBUFFER)
)
do (* 11 is Compensation for initial characters
\CATCH.TAG.)
(if (IGEQ I 256)
then (RETURN))
(\PUTBASEBYTE BASE I CHAR)
finally (PROGN (replace (DSTRINGP LENGTH) of \THROW.STRBUFFER
with I)
(RETURN (MKATOM \THROW.STRBUFFER))))))
(if (ILESSP (NCHARS TAG)
(CONSTANT (IDIFFERENCE 128 11)))
then (MKATOM (CONCAT (QUOTE \CATCH.TAG.)
TAG))))
(ERROR TAG "name too long to be CATCH tag"))))
(THROW
(LAMBDA (TAG VAL) (* JonL "21-SEP-83 15:21")
(\THROW.AUX (EVALV (\CATCH.TAG.INTERN TAG))
TAG VAL)))
(\THROW.AUX
(LAMBDA (POS TAG VAL) (* JonL "25-SEP-83 23:57")
(DECLARE (LOCALVARS POS TAG VAL FORMP)
(USEDFREE \THROW.1SHOT.OPOS))
(* Note that both TAG and VAL have been "evaluated" before the call to this SUBR, and hence before any of the
validity checking below.)
(PROG NIL
A (SELECTQ (SYSTEMTYPE)
(D (if (SMALLP POS)
then (UNINTERRUPTABLY
(RETTO (\MAKESTACKP \THROW.1SHOT.OPOS POS)
VAL T))))
NIL)
(if (STACKP POS)
then (if (\CATCHRELSTKP POS)
then (SHOULDNT "THROW to a released frame"))
(RETTO POS VAL T))
(SETQ TAG (ERROR TAG (QUOTE Tag% to% THROW,% but% no% corresponding% tag% in% a% CATCH)))
(SETQ POS (EVALV (\CATCH.TAG.INTERN TAG)))
(GO A))))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS CATCH MACRO (X
(PROG ((Y (LISPFORM.SIMPLIFY (CONS (QUOTE PROGN)
X)
T))
TAGFORM)
(OR (EQ 2 (LENGTH (SETQ Y (CDR Y))))
(ERROR X "WRONG FORMAT FOR CATCH"))
(RETURN (COND
((SETQ TAGFORM (CONSTANTEXPRESSIONP (CAR Y)))
(SETQ TAGFORM (\CATCH.TAG.INTERN (CAR TAGFORM)))
(SUBPAIR (QUOTE (X FORM))
(LIST TAGFORM (CADR Y))
(SELECTQ COMPILEMODE
(D (QUOTE (\CATCHRUNFUN (FUNCTION (LAMBDA NIL
((LAMBDA (X)
(DECLARE (SPECVARS X))
FORM)
(\MYALINK)))))))
(QUOTE (\CATCHRUNFUN (FUNCTION (LAMBDA NIL
((LAMBDA (X \CATCH.1SHOT.OPOS)
(DECLARE (SPECVARS X
\CATCH.1SHOT.OPOS))
FORM)
(STKNTH -2 NIL \CATCH.1SHOT.OPOS)))))
))))
(T (LIST (QUOTE \CATCH.AUX)
(CAR Y)
(LIST (QUOTE FUNCTION)
(LIST (QUOTE LAMBDA)
NIL
(CADR Y))))))))))
(PUTPROPS *CATCH MACRO (= . CATCH))
(PUTPROPS \CATCHRUNFUN DMACRO (= . SPREADAPPLY*))
(PUTPROPS \CATCHRUNFUN MACRO ((FUN . REST)
((LAMBDA (\CatchBody)
(DECLARE (LOCALVARS \CatchBody))
(APPLY* \CatchBody . REST))
FUN)))
(PUTPROPS THROW MACRO (X
(PROG ((Y (LISPFORM.SIMPLIFY (CONS (QUOTE PROGN)
X)
T))
TAGFORM)
(OR (EQ 2 (LENGTH (SETQ Y (CDR Y))))
(ERROR X "WRONG FORMAT FOR THROW"))
(RETURN (COND
((SETQ TAGFORM (CONSTANTEXPRESSIONP (CAR Y)))
(LIST (QUOTE \THROW.AUX)
(\CATCH.TAG.INTERN (CAR TAGFORM))
(KWOTE (CAR TAGFORM))
(CADR Y)))
(T (QUOTE IGNOREMACRO)))))))
(PUTPROPS *THROW MACRO (= . THROW))
(PUTPROPS \CATCHRELSTKP DMACRO ((X)
(EQ 0 (fetch EDFXP of X))))
(PUTPROPS \CATCHRELSTKP MACRO (= . RELSTKP))
(PUTPROPS UNWINDPROTECT MACRO ((FORM . CLEANUPS)
(RESETLST (RESETSAVE NIL (LIST (FUNCTION (LAMBDA NIL . CLEANUPS))))
FORM)))
)
(RPAQ \CATCH.1SHOT.OPOS (STKNTH 0 T))
(RPAQ \THROW.1SHOT.OPOS (STKNTH 0 T))
(DECLARE: EVAL@COMPILE
(PUTPROPS \CATCH.1SHOT.OPOS SPECVAR T)
(PUTPROPS \THROW.1SHOT.OPOS SPECVAR T)
)
(DECLARE: DONTCOPY EVAL@COMPILE
(DECLARE: EVAL@COMPILE
(PUTPROPS DATATYPE.TEST MACRO (OPENLAMBDA (X TYPE)
(COND
((NOT (TYPENAMEP X TYPE))
(ERROR X (CONCAT (QUOTE Not% of% type% TYPE))))
(T X))))
(PUTPROPS DATATYPE.TEST DMACRO (= . \DTEST))
)
(OR (AND (GETMACROPROP (QUOTE UNINTERRUPTABLY)
COMPILERMACROPROPS)
(RECLOOK (QUOTE LITATOM))
(GETP (QUOTE inatom)
(QUOTE I.S.OPR)))
(HELP "You need to have ABC loaded to EDIT/COMPILE this file"))
)
(DECLARE: COPYWHEN (EQ COMPILEMODE (QUOTE D))
(RPAQ \THROW.STRBUFFER (PROG ((X (ALLOCSTRING 256)))
(RPLSTRING X 1 (QUOTE \CATCH.TAG.))
(RETURN X)))
(PUTPROPS \MYALINK DMACRO (NIL
((OPCODES MYALINK))))
(DECLARE: EVAL@COMPILEWHEN (EQ COMPILEMODE (QUOTE D))
(PUTPROPS \THROW.STRBUFFER GLOBALVAR T)
)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA CATCH)
(ADDTOVAR NLAML )
(ADDTOVAR LAMA LIST*)
)
(PUTPROPS CMLSPECIALFORMS COPYRIGHT ("Xerox Corporation" 1983 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (3455 11523 (\LETtran 3465 . 5204) (\DEFUNexpander 5206 . 8345) (\Process&Specs 8347 .
11521)) (11524 11948 (LIST* 11534 . 11946)) (12221 16054 (CATCH 12231 . 12757) (\CATCH.AUX 12759 .
13675) (\CATCH.FINDFRAME 13677 . 13908) (\CATCH.TAG.INTERN 13910 . 14981) (THROW 14983 . 15154) (
\THROW.AUX 15156 . 16052)))))
STOP