(FILECREATED "27-Jan-85 00:49:07" {ERIS}<LISPCORE>LIBRARY>CMLSPECIALFORMS.;22 15550
changes to: (VARS CMLSPECIALFORMSCOMS)
previous date: "19-Dec-84 18:46:09" {ERIS}<LISPCORE>LIBRARY>CMLSPECIALFORMS.;20)
(* Copyright (c) 1983, 1984, 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CMLSPECIALFORMSCOMS)
(RPAQQ CMLSPECIALFORMSCOMS [(COMS (*
"CommonLisp style DEFUN, LET LET* PROG* LIST* macros and CATCH and THROW")
(MACROS PSETQ PROGV DEFUN)
(FNS \DEFUNexpander \Process&Specs))
(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))
(DECLARE: (*
"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]
(GLOBALVARS \THROW.STRBUFFER])
(* "CommonLisp style DEFUN, LET LET* PROG* LIST* macros and CATCH and THROW")
(DECLARE: EVAL@COMPILE
(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
(\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))))))))
)
(* "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))
)
)
(DECLARE:
(RPAQ \THROW.STRBUFFER (PROG ((X (ALLOCSTRING 256)))
(RPLSTRING X 1 (QUOTE \CATCH.TAG.))
(RETURN X)))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \THROW.STRBUFFER)
)
)
(PUTPROPS CMLSPECIALFORMS COPYRIGHT ("Xerox Corporation" 1983 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2219 8546 (\DEFUNexpander 2229 . 5368) (\Process&Specs 5370 . 8544)) (8594 12427 (CATCH
8604 . 9130) (\CATCH.AUX 9132 . 10048) (\CATCH.FINDFRAME 10050 . 10281) (\CATCH.TAG.INTERN 10283 .
11354) (THROW 11356 . 11527) (\THROW.AUX 11529 . 12425)))))
STOP