(FILECREATED "22-Jul-85 19:03:22" {ERIS}<LISPCORE>SOURCES>MACROS.;31 29391
changes to: (FILEPKGCOMS MACROS)
previous date: "18-Jul-85 21:36:44" {ERIS}<LISPCORE>SOURCES>MACROS.;30)
(* Copyright (c) 1984, 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT MACROSCOMS)
(RPAQQ MACROSCOMS [(PROP MACRO NEQ NLISTP ZEROP ADD1 SUB1 SETQQ ERSETQ NLSETQ RPTQ NCONC1 XNLSETQ
UNDONLSETQ RESETVAR RESETFORM RESETLST RESETSAVE RESETTOPVALS RESETBUFS
SELECT SELECTC IGEQ ILEQ GEQ LEQ FLESSP IMIN IMAX PROG2 EVENP ODDP SIGNED
UNSIGNED BQUOTE LIST* LET LET* PROG* PSETQ)
(ALISTS (PRETTYEQUIVLST LET LET* PROG*))
[COMS (* MACRO translations)
(FNS EXPANDMACRO DEFMACRO DEFMACRO.EXPAND DESTRUCTURE.ALIST MACROEXPANSION
MACROS.GETDEF GETMACROPROP MUSTCOMPILEMACROP EXPANDOPENLAMBDA \LETtran
\MAKE.KEYWORD \KEYWORDP)
(BLOCKS (NIL GETMACROPROP MACROEXPANSION EXPANDMACRO MUSTCOMPILEMACROP EXPANDOPENLAMBDA
\LETtran (LOCALVARS . T)
(SPECVARS FAULTX FAULTAPPLYFLG EXP VCF PCF NCF FAULTFN EXPR DWIMIFYFLG)
(GLOBALVARS NOFIXFNSLST BYTECOMPFLG CLISPARRAY BYTEMACROPROP)
(LINKFNS . T]
(FILEPKGCOMS MACROS)
(PROP MACRO CONSTANT LOADTIMECONSTANT DEFERREDCONSTANT)
(FNS CSELECT)
(COMS (FNS PRINTCOMSTRAN)
(GLOBALVARS COMMENTFLG LCASEFLG PRINTOUTMACROS)
(ADDVARS (PRINTOUTMACROS))
(VARS PRINTOUTTOKENS)
(MACROS PRINTOUT printout))
(ADDVARS * (LIST (CONS (QUOTE SYSPROPS)
MACROPROPS)))
(PROP PROPTYPE * (PROGN MACROPROPS))
(PROP SETFN GETTOPVAL)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA DEFMACRO)
(NLAML)
(LAMA])
(PUTPROPS NEQ MACRO ((X Y)
(NULL (EQ X Y))))
(PUTPROPS NLISTP MACRO ((X)
(NULL (LISTP X))))
(PUTPROPS ZEROP MACRO [OPENLAMBDA (X)
(COND
((EQ X 0))
((FLOATP X)
(FEQP X 0.0])
(PUTPROPS ADD1 MACRO ((X)
(IPLUS X 1)))
(PUTPROPS SUB1 MACRO ((X)
(IDIFFERENCE X 1)))
(PUTPROPS SETQQ MACRO ((X V)
(SETQ X (QUOTE V))))
(PUTPROPS ERSETQ MACRO ((X)
(.ERRSETQ. X T)))
(PUTPROPS NLSETQ MACRO ((X . Y)
(.ERRSETQ. (PROGN X . Y)
NIL)))
(PUTPROPS RPTQ MACRO ((N . FORMS)
(PROG ((RPTN N)
RPTV)
(DECLARE (LOCALVARS RPTN RPTV))
RPTQLAB
(COND
((IGREATERP RPTN 0)
(SETQ RPTV (PROGN . FORMS))
(SETQ RPTN (SUB1 RPTN))
(GO RPTQLAB)))
(RETURN RPTV))))
(PUTPROPS NCONC1 MACRO ((LST X)
(NCONC LST (CONS X))))
(PUTPROPS XNLSETQ MACRO ((X FLG FN)
(.ERRSETQ. X FLG FN)))
(PUTPROPS UNDONLSETQ MACRO ((UNDOFORM UNDOFN)
(PROG ((LISPXHIST LISPXHIST)
UNDOSIDE0 UNDOSIDE UNDOTEM)
(DECLARE (SPECVARS LISPXHIST))
[COND
([LISTP (SETQ UNDOSIDE (LISTGET1 LISPXHIST (QUOTE SIDE]
(SETQ UNDOSIDE0 (CDR UNDOSIDE)))
(T (SETQ UNDOSIDE0 UNDOSIDE)
(SETQ UNDOSIDE (LIST 0))
(COND
(LISPXHIST (LISTPUT1 LISPXHIST (QUOTE SIDE)
UNDOSIDE))
(T (SETQ LISPXHIST (LIST (QUOTE SIDE)
UNDOSIDE]
(RESETVARS (#UNDOSAVES)
(SETQ UNDOTEM (XNLSETQ UNDOFORM NIL UNDOFN)))
(COND
((EQ UNDOSIDE0 (QUOTE NOSAVE))
(LISTPUT1 LISPXHIST (QUOTE SIDE)
(QUOTE NOSAVE)))
(T (UNDOSAVE)))
(COND
(UNDOTEM (RETURN UNDOTEM)))
(UNDONLSETQ1 (CDR UNDOSIDE)
(LISTP UNDOSIDE0))
(RETURN))))
(PUTPROPS RESETVAR MACRO ((VAR VAL FORM)
(PROG (MACROX MACROY)
(SETQ MACROX (SETQ RESETVARSLST
(CONS [CONS (QUOTE VAR)
(CONS (STKSCAN (QUOTE VAR))
(GETATOMVAL (QUOTE VAR]
RESETVARSLST)))
(SETQ MACROY (XNLSETQ (PROGN (SETATOMVAL (QUOTE VAR)
VAL)
FORM)
(QUOTE INTERNAL)))
(SETATOMVAL (QUOTE VAR)
(CDDAR MACROX))
(SETQ RESETVARSLST (CDR MACROX))
[COND
(MACROY (RETURN (CAR MACROY]
(ERROR!))))
(PUTPROPS RESETFORM MACRO [OPENX (SUBPAIR (QUOTE (FN FORM . EXPRESSIONS))
(CONS (CAAR OPENX)
OPENX)
(QUOTE (PROG ((OLDVALUE FORM)
MACROX MACROY RESETSTATE)
(DECLARE (LOCALVARS MACROX MACROY))
(SETQ MACROX
(SETQ RESETVARSLST
(CONS (LIST (LIST (QUOTE FN)
OLDVALUE))
RESETVARSLST)))
[COND
((NOT (XNLSETQ (SETQ MACROY (PROGN .
EXPRESSIONS))
INTERNAL))
(SETQ RESETSTATE (QUOTE ERROR]
(SETQ RESETVARSLST (CDR MACROX))
(APPLY (QUOTE FN)
(CDAAR MACROX))
(RETURN (COND
(RESETSTATE (ERROR!))
(T MACROY])
(PUTPROPS RESETLST MACRO [(X . Y)
(PROG (RESETY RESETZ (LISPXHIST LISPXHIST))
[RESETRESTORE RESETVARSLST (SETQ RESETZ (COND
((XNLSETQ (SETQ RESETY (PROGN X . Y))
INTERNAL)
NIL)
(T (QUOTE ERROR]
(RETURN (COND
(RESETZ (ERROR!))
(T RESETY])
(PUTPROPS RESETSAVE MACRO [X
(LIST (QUOTE SETQ)
(QUOTE RESETVARSLST)
(LIST (QUOTE CONS)
[COND
[(AND (ATOM (CAR X))
(CAR X))
(SUBPAIR (QUOTE (VAR VAL))
X
(QUOTE (PROG1 [CONS (QUOTE VAR)
(CONS (STKSCAN (QUOTE VAR))
(GETATOMVAL (QUOTE VAR]
(SETATOMVAL (QUOTE VAR)
VAL]
((CDR X)
(LIST (QUOTE LIST)
(CADR X)
(CAR X)))
(T (LIST (QUOTE LIST)
(LIST (QUOTE LIST)
[LIST (QUOTE QUOTE)
(COND
((EQ (CAAR X)
(QUOTE SETQ))
(CAR (CADDAR X)))
(T (CAAR X]
(CAR X]
(QUOTE RESETVARSLST])
(PUTPROPS RESETTOPVALS MACRO [ARGS (CONS (QUOTE RESETLST)
(NCONC [MAPCAR (CAR ARGS)
(FUNCTION (LAMBDA (V)
(CONS (QUOTE RESETSAVE)
V]
(CDR ARGS])
(PUTPROPS RESETBUFS MACRO [(A . B)
([LAMBDA ($$BUFS)
(DECLARE (LOCALVARS $$BUFS))
(PROG1 (PROGN A . B)
(AND $$BUFS (BKBUFS $$BUFS]
(PROGN (LINBUF)
(SYSBUF)
(CLBUFS NIL T READBUF])
(PUTPROPS SELECT MACRO (X (CSELECT X)))
(PUTPROPS SELECTC MACRO [F (CONS (QUOTE SELECTQ)
(CONS (CAR F)
(MAPLIST (CDR F)
(FUNCTION (LAMBDA (I)
(COND
((CDR I)
(CONS (CONSTANT (EVAL (CAAR I)))
(CDAR I)))
(T (CAR I])
(PUTPROPS IGEQ MACRO ((X Y)
(NOT (ILESSP X Y))))
(PUTPROPS ILEQ MACRO ((X Y)
(NOT (IGREATERP X Y))))
(PUTPROPS GEQ MACRO ((X Y)
(NOT (LESSP X Y))))
(PUTPROPS LEQ MACRO ((X Y)
(NOT (GREATERP X Y))))
(PUTPROPS FLESSP MACRO [LAMBDA (X Y)
(FGREATERP Y X])
(PUTPROPS IMIN MACRO [DEFMACRO (&WHOLE ORIGINAL &OPTIONAL (ARG1 NIL ARG1GIVEN)
(ARG2 NIL ARG2GIVEN)
&REST RESTARGS)
(COND
((NOT ARG1GIVEN)
(QUOTE MAX.INTEGER))
((NOT ARG2GIVEN)
(BQUOTE (FIX , ARG1)))
(RESTARGS (BQUOTE (IMIN (IMIN2 , ARG1 , ARG2)
., RESTARGS)))
(T (LIST (QUOTE IMIN2)
ARG1 ARG2])
(PUTPROPS IMAX MACRO [DEFMACRO (&OPTIONAL (ARG1 NIL ARG1GIVEN)
(ARG2 NIL ARG2GIVEN)
&REST RESTARGS)
(COND
((NOT ARG1GIVEN)
(QUOTE MIN.INTEGER))
((NOT ARG2GIVEN)
(BQUOTE (FIX , ARG1)))
(RESTARGS (BQUOTE (IMAX (IMAX2 , ARG1 , ARG2)
., RESTARGS)))
(T (BQUOTE (IMAX2 , ARG1 , ARG2])
(PUTPROPS PROG2 MACRO ((X . Y)
(PROGN X (PROG1 . Y))))
(PUTPROPS EVENP MACRO [DEFMACRO (N &OPTIONAL (MODULUS 2))
(BQUOTE (EQ 0 (IMOD , N , MODULUS])
(PUTPROPS ODDP MACRO ((X . TAIL)
(NOT (EVENP X . TAIL))))
(PUTPROPS SIGNED MACRO [ARGS (COND
((EQ COMPILE.CONTEXT (QUOTE EFFECT))
(CAR ARGS))
(T (CONS [QUOTE (OPENLAMBDA (N WIDTH)
(COND
[[IGREATERP N
(SUB1 (LLSH 1 (SUB1 WIDTH]
(* done this way just so that
(SIGNED X 2↑16) doesn't box)
(SUB1 (IDIFFERENCE
N
(SUB1 (LLSH 1 WIDTH]
(T N]
ARGS])
(PUTPROPS UNSIGNED MACRO [(X WIDTH)
(LOGAND X (SUB1 (LLSH 1 WIDTH])
(PUTPROPS BQUOTE MACRO (FORM (\BQUOTE.EXPAND (\UNCOMMA (CAR FORM))
1)))
(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 LET MACRO (X (\LETtran X)))
(PUTPROPS LET* MACRO (X (\LETtran X T)))
(PUTPROPS PROG* MACRO (X (\LETtran X (QUOTE PROG*))))
(PUTPROPS PSETQ MACRO (DEFMACRO (VAR VAL &REST TAIL)
(BQUOTE (PROGN (SETQ , VAR , (if TAIL
then (BQUOTE (PROG1 , VAL
(PSETQ ,. TAIL)))
else VAL))
NIL))))
(ADDTOVAR PRETTYEQUIVLST (LET . PROG)
(LET* . PROG)
(PROG* . PROG))
(* MACRO translations)
(DEFINEQ
(EXPANDMACRO
[LAMBDA (EXP QUIETFLG OPTIONS COMPILE.CONTEXT) (* lmm "26-Jul-84 04:22")
(DECLARE (SPECVARS NCF PCF VCF EFF EXP COMPILE.CONTEXT))
(PROG [ALLFLG MACRODEF NCF PCF (VCF (NEQ COMPILE.CONTEXT (QUOTE EFFECT)))
(EFF (EQ COMPILE.CONTEXT (QUOTE EFFECT]
LP (COND
((NLISTP EXP)
(GO OUT))
((AND (EQ ALLFLG (QUOTE CLISP))
(GETHASH EXP CLISPARRAY))
(SETQ EXP (GETHASH EXP CLISPARRAY))
(GO LP)))
MLP (SETQ MACRODEF (GETMACROPROP (CAR EXP)
COMPILERMACROPROPS))
[COND
((NEQ EXP (SETQ EXP (MACROEXPANSION EXP MACRODEF)))
(COND
(ALLFLG (GO LP]
OUT (COND
(QUIETFLG (RETURN EXP))
(T (RESETFORM (OUTPUT T)
(PRINTDEF EXP NIL T)
(TERPRI T])
(DEFMACRO
[NLAMBDA L (* hdj "21-Apr-85 13:23")
(SAVEPUT (CAR L)
(QUOTE MACRO)
(CONS (QUOTE DEFMACRO)
(CDR L)))
(CAR L])
(DEFMACRO.EXPAND
[LAMBDA (MACRO.VARS MACRO.EXPRESSION MACRO.BODY DEFAULT.VALUE)
(* lmm "18-Jul-85 20:08")
(DECLARE (SPECVARS MACRO.BODY MACRO.EXPRESSION DEFAULT.VALUE))
(LET [(EXP (EVALA MACRO.BODY (DESTRUCTURE.ALIST MACRO.VARS (CDR MACRO.EXPRESSION)
NIL NIL]
(if (EQ EXP (QUOTE IGNOREMACRO))
then MACRO.EXPRESSION
else EXP])
(DESTRUCTURE.ALIST
[LAMBDA (VARS FORM TAIL INOPTIONAL) (* lmm "18-Jul-85 20:07")
(if (NULL VARS)
then TAIL
elseif (NLISTP VARS)
then (CONS (CONS VARS FORM)
TAIL)
else
(SELECTQ
(CAR VARS)
((&REST &BODY)
(DESTRUCTURE.ALIST (CDDR VARS)
FORM
(CONS (CONS (CADR VARS)
FORM)
TAIL)
INOPTIONAL))
(&WHOLE (DESTRUCTURE.ALIST (CDDR VARS)
FORM
(CONS (CONS (CADR VARS)
MACRO.EXPRESSION)
TAIL)
INOPTIONAL))
(&OPTIONAL (DESTRUCTURE.ALIST (CDR VARS)
FORM TAIL T))
(&AUX (DESTRUCTURE.ALIST (CDR VARS)
(if FORM
then (ERROR FORM "too many expressions supplied to macro"))
TAIL
(QUOTE AUX)))
(&KEY (SETQ VARS (CDR VARS))
(while VARS
do (SELECTQ (CAR VARS)
((&REST &ALLOW-OTHER-KEYS)
(RETURN (DESTRUCTURE.ALIST VARS FORM TAIL)))
(PROGN [LET* [(BINDING (CAR VARS))
SVAR
[INIT (if (LISTP BINDING)
then (PROG1 (CADR BINDING)
(SETQ SVAR (CADDR BINDING))
(SETQ BINDING (CAR BINDING]
(KEY (if (LISTP BINDING)
then (PROG1 (CAR BINDING)
(SETQ BINDING (CADR BINDING)))
else (\MAKE.KEYWORD BINDING)))
(FMV (for FM on FORM by (CDDR FM)
do (LET [(FMV (COND
((\KEYWORDP (CAR FM))
FM)
((CONSTANTEXPRESSIONP
(CAR FM]
(if (NOT FMV)
then (RETFROM (QUOTE DEFMACRO.EXPAND)
MACRO.EXPRESSION))
(if (EQ (CAR FMV)
KEY)
then (RETURN (CDR FM]
[if SVAR
then (push TAIL
(CONS SVAR (if FMV
then T
else NIL]
(push TAIL (CONS BINDING (if FMV
then (CAR FMV)
else (EVAL INIT]
(pop VARS)))
finally (RETURN TAIL)))
(DESTRUCTURE.ALIST (CDR VARS)
(CDR FORM)
(if INOPTIONAL
then [COND
((NLISTP FORM) (* optional omitted)
(if (LISTP (CAR VARS))
then (DESTRUCTURE.ALIST
(CAAR VARS)
(EVAL (CADAR VARS))
(if (CDDAR VARS)
then (CONS (CONS (CADDAR VARS)
NIL)
TAIL)
else TAIL)
NIL)
else (DESTRUCTURE.ALIST (CAR VARS)
DEFAULT.VALUE TAIL NIL)))
(T (* optional present)
(if (LISTP (CAR VARS))
then (DESTRUCTURE.ALIST
(CAAR VARS)
(CAR FORM)
(if (CDDAR VARS)
then (CONS (CONS (CADDAR VARS)
T)
TAIL)
else TAIL)
NIL)
else (DESTRUCTURE.ALIST (CAR VARS)
(CAR FORM)
TAIL NIL]
else (if (NLISTP FORM)
then (ERROR "macro body missing value for" VARS)
else (DESTRUCTURE.ALIST (CAR VARS)
(CAR FORM)
TAIL NIL)))
INOPTIONAL])
(MACROEXPANSION
(LAMBDA (EXPR MACRODEF COMPFLG COMPILE.CONTEXT) (* lmm "29-Mar-85 22:58") (DECLARE (SPECVARS
COMPILE.CONTEXT)) (COND ((NLISTP MACRODEF) EXPR) (T (SELECTQ (CAR MACRODEF) (NIL (COND ((CDDR MACRODEF
) (CONS (QUOTE PROGN) (CDR MACRODEF))) (T (CADR MACRODEF)))) ((LAMBDA NLAMBDA) (CONS MACRODEF (CDR
EXPR))) (= (* bytemacro abbreviation) (CONS (CDR MACRODEF) (CDR EXPR))) (OPENLAMBDA (EXPANDOPENLAMBDA
MACRODEF (CDR EXPR))) ((APPLY APPLY*) EXPR) (DEFMACRO (DEFMACRO.EXPAND (CADR MACRODEF) EXPR (MKPROGN (
CDDR MACRODEF)))) (COND ((LISTP (CAR MACRODEF)) (SUBPAIR (CAR MACRODEF) (CDR EXPR) (COND ((CDDR
MACRODEF) (CONS (QUOTE PROGN) (CDR MACRODEF))) (T (CADR MACRODEF))))) ((LITATOM (CAR MACRODEF)) (COND
((FMEMB (CAR MACRODEF) LAMBDASPLST) (CONS MACRODEF (CDR EXPR))) ((AND (NOT COMPFLG) (MUSTCOMPILEMACROP
MACRODEF)) EXPR) ((NEQ (SETQ MACRODEF (COND (COMPFLG (APPLY (CONS (QUOTE NLAMBDA) MACRODEF) (CDR EXPR
))) (T (PROG ((EXP EXPR) (EFF (EQ COMPILE.CONTEXT (QUOTE EFFECT))) (VCF (NEQ COMPILE.CONTEXT (QUOTE
EFFECT))) NCF PCF PREDF) (DECLARE (SPECVARS NCF PCF VCF EFF EXPR EXP RETF PREDF)) (* various variables
bound in the Interlisp-D and Interlisp-10 compiler) (RETURN (APPLY (CONS (QUOTE NLAMBDA) MACRODEF) (
CDR EXPR))))))) (QUOTE IGNOREMACRO)) MACRODEF) (T EXPR))) (T EXPR)))))))
(MACROS.GETDEF
(LAMBDA (NAME TYPE OPTIONS) (* lmm " 2-Apr-85 17:26") (MKPROGN (for X on (GETPROPLIST NAME) by (CDDR X
) when (FMEMB (CAR X) MACROPROPS) collect (if (AND (EQ (CAR X) (QUOTE MACRO)) (EQ (CAADR X) (QUOTE
DEFMACRO))) then (BQUOTE (DEFMACRO , NAME ,@ (CDR (CADR X)))) else (BQUOTE (PUTPROPS , NAME , (CAR X)
, (CADR X))))))))
(GETMACROPROP
[LAMBDA (FN PROPS) (* lmm "18-APR-82 13:23")
(for X in PROPS bind VAL do (COND
((SETQ VAL (GETPROP FN X))
(RETURN VAL])
(MUSTCOMPILEMACROP
[LAMBDA (X SAFEFLG) (* lmm "14-DEC-77 22:37")
(COND
[(LISTP X)
(SELECTQ (CAR X)
(QUOTE (AND SAFEFLG (MUSTCOMPILEMACROP (CADR X)
T)))
(SOME X (FUNCTION (LAMBDA (Y)
(MUSTCOMPILEMACROP Y SAFEFLG]
(T (OR (FMEMB X UNSAFEMACROATOMS)
(AND SAFEFLG (FMEMB X SHOULDCOMPILEMACROATOMS])
(EXPANDOPENLAMBDA
[LAMBDA (OPENLAM ACTUALS) (* lmm "27-FEB-83 23:26")
(PROG ((FORMALS (CADR OPENLAM))
A ARGS VALS SUBSTPAIRS VAL GENARGS TMP)
LP (COND
((NLISTP FORMALS)
(GO OUT)))
(SETQ A (CAR FORMALS))
(COND
((NLISTP ACTUALS) (* Here if ran out of actuals before formals)
(for A in FORMALS do (push SUBSTPAIRS (LIST A)))
(GO OUT)))
(SETQ VAL (CAR ACTUALS))
(COND
[(SETQ TMP (CONSTANTEXPRESSIONP VAL))
(push SUBSTPAIRS (CONS A (KWOTE (CAR TMP]
(T (push ARGS A)
(push VALS VAL)))
(SETQ FORMALS (CDR FORMALS))
(SETQ ACTUALS (CDR ACTUALS))
(GO LP)
OUT [while (AND VALS (ATOM (CAR VALS))) do (push SUBSTPAIRS (CONS (pop ARGS)
(pop VALS]
(SETQ OPENLAM (CDDR OPENLAM))
[COND
(SUBSTPAIRS [COND
(ARGS (SETQ OPENLAM (SUBPAIR ARGS [SETQ ARGS (MAPCAR
ARGS
(FUNCTION (LAMBDA (A)
(PACK* A (GENSYM]
OPENLAM]
(* Replace variables to avoid conflict with names in substituted values)
(SETQ OPENLAM (SUBLIS SUBSTPAIRS OPENLAM]
(* Any ACTUALS left are extra but still need to be evaluated)
(RETURN (COND
(ARGS (BQUOTE ([LAMBDA ,
(SETQ ARGS (REVERSE ARGS))
(DECLARE (LOCALVARS ., ARGS))
., OPENLAM]
.,
(REVERSE VALS)
., ACTUALS)))
(T (MKPROGN (NCONC ACTUALS OPENLAM])
(\LETtran
[LAMBDA (LETTAIL SEQUENTIALP) (* lmm "16-Jul-85 12:52")
(PROG ([VARS (MAPCAR (CAR LETTAIL)
(FUNCTION (LAMBDA (BINDENTRY)
(if (LISTP BINDENTRY)
then (SETQ BINDENTRY (CAR BINDENTRY)))
(if (OR (NULL BINDENTRY)
(EQ BINDENTRY T)
(NOT (LITATOM BINDENTRY)))
then (if (LITATOM BINDENTRY)
then (LISPERROR "ATTEMPT TO BIND NIL OR T" BINDENTRY)
else (LISPERROR "ARG NOT LITATOM" BINDENTRY)))
BINDENTRY]
[VALS (MAPCAR (CAR LETTAIL)
(FUNCTION (LAMBDA (BINDENTRY)
(if (LISTP BINDENTRY)
then (if (CDDR BINDENTRY)
then (CONS (QUOTE PROG1)
(CDR BINDENTRY))
else (CADR BINDENTRY))
else NIL]
(BODY (CDR LETTAIL))
(DECLS NIL)
(COMNTS NIL))
(RETURN (if (NOT SEQUENTIALP)
then (LIST* (LIST* (QUOTE LAMBDA)
VARS BODY)
VALS)
elseif (NULL (CDR VARS))
then (SELECTQ SEQUENTIALP
(PROG* (CONS (QUOTE PROG)
LETTAIL))
(BQUOTE ([LAMBDA , VARS ,@ BODY]
,@ VALS)))
else (* 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])
(\MAKE.KEYWORD
[LAMBDA (X)
(if (NEQ (NTHCHARCODE X 1)
(CHARCODE ":"))
then (SETQ X (PACK* ":" X)))
(SET X X])
(\KEYWORDP
[LAMBDA (X)
(EQ (NTHCHARCODE X 1)
(CHARCODE ":"])
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: NIL GETMACROPROP MACROEXPANSION EXPANDMACRO MUSTCOMPILEMACROP EXPANDOPENLAMBDA \LETtran
(LOCALVARS . T)
(SPECVARS FAULTX FAULTAPPLYFLG EXP VCF PCF NCF FAULTFN EXPR DWIMIFYFLG)
(GLOBALVARS NOFIXFNSLST BYTECOMPFLG CLISPARRAY BYTEMACROPROP)
(LINKFNS . T))
]
(PUTDEF (QUOTE MACROS) (QUOTE FILEPKGCOMS) (QUOTE
((COM
MACRO
[X
(DECLARE:
EVAL@COMPILE
(P
*
(MAPCAR
(QUOTE X)
(FUNCTION
(LAMBDA
(Y)
(OR
(GETDEF Y (QUOTE MACROS)
(QUOTE CURRENT)
(QUOTE (NOCOPY NOERROR)))
(KWOTE
(PRINT (CONS Y
(QUOTE (-- no MACRO
definition)))
T]
CONTENTS NILL)
(TYPE DESCRIPTION "macros" GETDEF MACROS.GETDEF
WHENCHANGED (CLEARCLISPARRAY)
EDITDEF NILL))))
(PUTPROPS CONSTANT MACRO [MACROX (PROG ((VAL (APPLY (QUOTE PROG1)
MACROX)))
(RETURN (COND
((CONSTANTOK VAL)
(KWOTE VAL))
(T (CONS (QUOTE LOADTIMECONSTANT)
MACROX])
(PUTPROPS LOADTIMECONSTANT MACRO ((X)
(DEFERREDCONSTANT X)))
(PUTPROPS DEFERREDCONSTANT MACRO [X (LIST [SUBST (CAR X)
(QUOTE FORM)
(QUOTE (LAMBDA (MACROX)
(DECLARE (LOCALVARS MACROX))
(OR (CDR MACROX)
(FRPLACD (FRPLACA MACROX
(EVQ FORM))
T))
(CAR MACROX]
(KWOTE (CONS])
(DEFINEQ
(CSELECT
[LAMBDA (L)
(DECLARE (LOCALVARS . T)) (* edited: 8 Dec 78 13:50)
(PROG (K C)
(OR (CDR L)
(RETURN (CAR L)))
(OR (SMALLP (CAR L))
(LITATOM (CAR L))
(SETQQ K .SELEC.))
[SETQ C (CONS (QUOTE COND)
(PROG ($$VAL X TMP $$TEM1 $$TEM2)
(SETQ X (CDR L))
$$LP(COND
((NLISTP X)
(GO $$OUT)))
[SETQ $$TEM1 (COND
((NULL (CDR X))
(LIST T (CAR X)))
(T [SETQ TMP (MAPCAR (OR (LISTP (CAAR X))
(LIST (CAAR X)))
(FUNCTION (LAMBDA (Y)
(LIST (QUOTE EQ)
Y
(OR K (CAR L]
[SETQ TMP (COND
((CDR TMP)
(CONS (QUOTE OR)
TMP))
(T (CAR TMP]
(CONS TMP (CDAR X]
[COND
[$$TEM2 (FRPLACD $$TEM2 (SETQ $$TEM2 (LIST $$TEM1]
(T (SETQ $$VAL (SETQ $$TEM2 (LIST $$TEM1]
$$ITERATE
(SETQ X (CDR X))
(GO $$LP)
$$OUT
(RETURN $$VAL]
(RETURN (COND
(K (LIST (LIST (QUOTE LAMBDA)
(QUOTE (.SELEC.))
(QUOTE (DECLARE (LOCALVARS .SELEC.)))
C)
(CAR L)))
(T C])
)
(DEFINEQ
(PRINTCOMSTRAN
(LAMBDA (FORM TAIL MACROS FILEFORM FROMDWIM) (* lmm "29-Mar-85 23:53") (* This function computes the
translations for PRINTOUT type CLISP forms. FORM is the form beginning with the CLISPWORD. After it is
dwimified, TAIL is applied to obtain the TAIL of printing commands. If FILEFORM~=NIL, it is applied
to FORM after dwimification to produce the output file specification.) (PROG (FORMATLIST (VARS (AND
FROMDWIM (APPEND (MAPCAR MACROS (FUNCTION CAR)) PRINTOUTTOKENS VARS)))) (DECLARE (SPECVARS VARS)) (for
ARG in (CDR FORM) bind (TYPE POINT WIDTH) when (AND (LITATOM ARG) (NOT (FASSOC ARG FORMATLIST)) (EQ (
CHCON1 ARG) (CHARCODE %.)) (SELCHARQ (SETQ TYPE (NTHCHARCODE ARG 2)) ((I F) T) NIL) (FIXP (SETQ WIDTH
(SUBATOM ARG 3 (AND (SETQ POINT (STRPOS (QUOTE %.) ARG 3)) (SUB1 POINT)))))) do (SETQ VARS (CONS ARG
VARS)) (* Suppress spelling-correction of formatcode atoms) (SETQ FORMATLIST (CONS (CONS ARG (KWOTE (
CONS (COND ((EQ TYPE (CHARCODE I)) (QUOTE FIX)) (T (QUOTE FLOAT))) (CONS WIDTH (while POINT collect (
SUBATOM ARG (ADD1 POINT) (AND (SETQ POINT (STRPOS (QUOTE %.) ARG (ADD1 POINT))) (SUB1 POINT))))))))
FORMATLIST))) (* Since we did all the work to decode the format, save it for later.) (AND FROMDWIM (
DWIMIFY0? (CDR FORM) FORM NIL NIL NIL FAULTFN)) (COND (FILEFORM (SETQ FILEFORM (LIST (COND ((EQ
FILEFORM T) T) (T (APPLY* FILEFORM FORM))))))) (SETQ TAIL (APPLY* TAIL FORM)) (RETURN (while TAIL bind
(ARG TEMP RESETOUT) collect (COND ((SETQ TEMP (ASSOC (CAR TAIL) MACROS)) (SETQ RESETOUT T) (*
Probably should pass FILEFORM to macrofn, but then would have to explain interface, smashing etc.) (
SETQ TAIL (APPLY* (CADR TEMP) TAIL)) (pop TAIL)) (T (SELECTQ (SETQ ARG (pop TAIL)) (.TAB0 (BQUOTE (TAB
, (pop TAIL) 0 ,@ FILEFORM))) (.TAB (BQUOTE (TAB , (pop TAIL) NIL ,@ FILEFORM))) ((0 T) (BQUOTE (
TERPRI ,@ FILEFORM))) (.RESET (BQUOTE (PRIN1 (CONSTANT (CHARACTER (CHARCODE CR))) ,@ FILEFORM))) (# (
SETQ RESETOUT T) (pop TAIL)) (.P2 (BQUOTE (PRIN2 , (pop TAIL) ,@ FILEFORM))) ((.PPF .PPV .PPFTL .PPVTL
) (BQUOTE (PRINTDEF , (pop TAIL) (POSITION ,@ FILEFORM) , (OR (EQ ARG (QUOTE .PPF)) (EQ ARG (QUOTE
.PPFTL))) , (OR (EQ ARG (QUOTE .PPVTL)) (EQ ARG (QUOTE .PPFTL))) NIL ,@ FILEFORM))) (.FONT (SETQ ARG (
pop TAIL)) (BQUOTE (CHANGEFONT , (COND ((FIXP ARG) (PACK* (QUOTE FONT) ARG)) (T ARG)) ,@ FILEFORM))) (
(.SUB .SUP .BASE) (BQUOTE (AND FONTCHANGEFLG (PROGN (CHANGEFONT SUPERSCRIPTFONT ,@ FILEFORM) (PRIN3 ,
(KWOTE (SELECTQ ARG (.SUB (CONSTANT (CHARACTER 20))) (.SUP (CONSTANT (CHARACTER 8))) (.BASE (CONSTANT
(CHARACTER 14))) NIL)) ,@ FILEFORM))))) (, (BQUOTE (SPACES 1 ,@ FILEFORM))) (,, (BQUOTE (SPACES 2 ,@
FILEFORM))) (,,, (BQUOTE (SPACES 3 ,@ FILEFORM))) (.SP (BQUOTE (SPACES , (pop TAIL) ,@ FILEFORM))) (
.SKIP (BQUOTE (FRPTQ , (pop TAIL) (TERPRI ,@ FILEFORM)))) (.N (BQUOTE (PRINTNUM , (pop TAIL) , (pop
TAIL) ,@ FILEFORM))) ((.FR .FR2 .CENTER .CENTER2) (BQUOTE (FLUSHRIGHT , (pop TAIL) , (pop TAIL) 0 , (
SELECTQ ARG ((.FR2 .CENTER2) T) NIL) , (SELECTQ ARG ((.CENTER .CENTER2) T) NIL) ,@ FILEFORM))) ((.PARA
.PARA2) (BQUOTE (PRINTPARA , (pop TAIL) , (pop TAIL) , (pop TAIL) , (EQ ARG (QUOTE .PARA2)) NIL ,@
FILEFORM))) (.PAGE (BQUOTE (PROGN (PRIN3 , (KWOTE (CHARACTER (CHARCODE FORM))) ,@ FILEFORM) (POSITION
(PROGN ,@ FILEFORM) 0)))) (COND ((SETQ TEMP (CDR (FASSOC ARG FORMATLIST))) (BQUOTE (PRINTNUM , TEMP ,
(pop TAIL) ,@ FILEFORM))) ((NOT (FIXP ARG)) (BQUOTE (PRIN1 , ARG ,@ FILEFORM))) ((MINUSP ARG) (BQUOTE
(SPACES , (IMINUS ARG) ,@ FILEFORM))) (T (BQUOTE (TAB , ARG NIL ,@ FILEFORM))))))) finally (RETURN (
COND ((AND (CAR FILEFORM) RESETOUT) (BQUOTE (RESETFORM (OUTPUT , (PROG1 (CAR FILEFORM) (RPLACA
FILEFORM NIL))) ,@ $$VAL))) ((LISTP (CAR FILEFORM)) (BQUOTE ((LAMBDA ($$OUTPUT) (DECLARE (LOCALVARS
$$OUTPUT)) ,@ $$VAL) , (PROG1 (CAR FILEFORM) (RPLACA FILEFORM (QUOTE $$OUTPUT)))))) (T (CONS (QUOTE
PROGN) $$VAL)))))))))
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS COMMENTFLG LCASEFLG PRINTOUTMACROS)
)
(ADDTOVAR PRINTOUTMACROS )
(RPAQQ PRINTOUTTOKENS (.RESET .TAB # , ,, ,,, .P2 .PPF .PPV .PPFTL .PPVTL .TAB0 .FR .FR2 .CENTER
.CENTER2 .PARA .PARA2 .PAGE .FONT .SUP .SUB .BASE .SP .SKIP .N))
(DECLARE: EVAL@COMPILE
(DEFMACRO PRINTOUT (&WHOLE X)
(PRINTCOMSTRAN X (FUNCTION CDDR)
PRINTOUTMACROS
(FUNCTION CADR)))
(PUTPROPS printout MACRO (= . PRINTOUT))
)
(ADDTOVAR SYSPROPS ALTOMACRO MACRO BYTEMACRO DMACRO)
(PUTPROPS ALTOMACRO PROPTYPE MACROS)
(PUTPROPS MACRO PROPTYPE MACROS)
(PUTPROPS BYTEMACRO PROPTYPE MACROS)
(PUTPROPS DMACRO PROPTYPE MACROS)
(PUTPROPS GETTOPVAL SETFN SETTOPVAL)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA DEFMACRO)
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(PUTPROPS MACROS COPYRIGHT ("Xerox Corporation" 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (10378 21715 (EXPANDMACRO 10388 . 11172) (DEFMACRO 11174 . 11404) (DEFMACRO.EXPAND 11406
. 11879) (DESTRUCTURE.ALIST 11881 . 15467) (MACROEXPANSION 15469 . 16776) (MACROS.GETDEF 16778 .
17120) (GETMACROPROP 17122 . 17313) (MUSTCOMPILEMACROP 17315 . 17681) (EXPANDOPENLAMBDA 17683 . 19298)
(\LETtran 19300 . 21464) (\MAKE.KEYWORD 21466 . 21628) (\KEYWORDP 21630 . 21713)) (23365 24528 (
CSELECT 23375 . 24526)) (24529 28440 (PRINTCOMSTRAN 24539 . 28438)))))
STOP