(FILECREATED "10-MAR-83 22:45:35" <NEWLISP>MACROS.;3 15189
previous date: " 9-MAR-83 21:56:25" <NEWLISP>MACROS.;2)
(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 IMOD)
[COMS (* MACRO translations)
(FNS MACROTRAN EXPANDMACRO MACROEXPANSION GETMACROPROP MUSTCOMPILEMACROP
EXPANDOPENLAMBDA)
(BLOCKS (NIL MACROTRAN GETMACROPROP MACROEXPANSION EXPANDMACRO MUSTCOMPILEMACROP
EXPANDOPENLAMBDA (LOCALVARS . T)
(SPECVARS FAULTX FAULTAPPLYFLG EXP VCF PCF NCF FAULTFN EXPR DWIMIFYFLG)
(GLOBALVARS NOFIXFNSLST BYTECOMPFLG CLISPARRAY BYTEMACROPROP)
(LINKFNS . T)))
(ADDVARS (DWIMUSERFORMS (MACROTRAN]
(PROP MACRO CONSTANT LOADTIMECONSTANT DEFERREDCONSTANT)
(FNS CSELECT)))
(PUTPROPS NEQ MACRO ((X Y)
(NULL (EQ X Y))))
(PUTPROPS NLISTP MACRO ((X)
(NULL (LISTP X))))
(PUTPROPS ZEROP MACRO ((X)
(EQ X 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 [ARGS (COND
((NOT ARGS)
MAX.INTEGER)
[(CDDR ARGS)
(CONS (QUOTE IMIN)
(CONS (LIST (QUOTE IMIN2)
(CAR ARGS)
(CADR ARGS))
(CDDR ARGS]
((CDR ARGS)
(LIST (QUOTE IMIN2)
(CAR ARGS)
(CADR ARGS)))
(T (LIST (QUOTE FIX)
(CAR ARGS])
(PUTPROPS IMAX MACRO [ARGS (COND
((NOT ARGS)
MIN.INTEGER)
[(CDDR ARGS)
(CONS (QUOTE IMAX)
(CONS (LIST (QUOTE IMAX2)
(CAR ARGS)
(CADR ARGS))
(CDDR ARGS]
((CDR ARGS)
(LIST (QUOTE IMAX2)
(CAR ARGS)
(CADR ARGS)))
(T (LIST (QUOTE FIX)
(CAR ARGS])
(PUTPROPS PROG2 MACRO ((X . Y)
(PROGN X (PROG1 . Y))))
(PUTPROPS EVENP MACRO [L (LIST (QUOTE ZEROP)
(LIST (QUOTE IMOD)
(CAR L)
(if (CDR L)
then (CADR L)
else 2])
(PUTPROPS ODDP MACRO ((X . TAIL)
(NOT (EVENP X . TAIL))))
(PUTPROPS IMOD MACRO [L (PROG [(N (CONSTANTEXPRESSIONP (CADR L]
(if (NULL N)
then (RETURN (QUOTE IGNOREMACRO)))
(SETQ N (if (EQ T (CONSTANTEXPRESSIONP 3))
then
(* Don't touch this code until all old Interlisp-10 sysouts go away -- there was
a backwards-incompatible change to CONSTANTEXPRESSIONP about Dec 1 1982)
(EVAL (CADR L))
else (CAR N)))
(RETURN (if (NOT (FIXP N))
then (HELP "Non-numeric modulus - IMOD" (CADR L))
elseif (NOT (POWEROFTWOP N))
then (QUOTE IGNOREMACRO)
else (LIST (QUOTE LOGAND)
(CAR L)
(SUB1 N])
(* MACRO translations)
(DEFINEQ
(MACROTRAN
[LAMBDA NIL (* lmm "15-DEC-82 00:02")
(PROG (TEM)
(COND
((AND (NOT FAULTAPPLYFLG)
(LISTP FAULTX)
(LITATOM (CAR FAULTX))
(NOT (FGETD (CAR FAULTX)))
(SETQ TEM (GETMACROPROP (CAR FAULTX)
COMPILERMACROPROPS)))
(RETURN (COND
[(MUSTCOMPILEMACROP TEM T)
(COND
([OR (EQ DWIMIFYFLG T)
(NOT (GETD (QUOTE ASSEMBLETRAN]
(/SETATOMVAL (QUOTE NOFIXFNSLST)
(CONS (CAR FAULTX)
NOFIXFNSLST))
(* Don't want to expand if it contains ASSEMBLE or explicit compiler directives -
However, can mark this function so that spelling correction is not attempted)
NIL)
(T (ASSEMBLETRAN FAULTX]
((NEQ FAULTX (SETQ TEM (MACROEXPANSION FAULTX TEM)))
(CLISPTRAN FAULTX (OR (LISTP TEM)
(LIST (QUOTE PROGN)
TEM)))
FAULTX])
(EXPANDMACRO
[LAMBDA (EXP QUIETFLG OPTIONS) (* lmm "22-NOV-82 00:34")
(DECLARE (SPECVARS NCF PCF VCF EFF EXP))
(PROG (ALLFLG MACRODEF NCF PCF (VCF T)
EFF)
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])
(MACROEXPANSION
[LAMBDA (EXPR MACRODEF COMPFLG) (* edited: "17-DEC-82 11:21")
(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)
(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
(VCF T)
NCF PCF)
(DECLARE (SPECVARS NCF PCF VCF EFF EXPR))
(RETURN (APPLY (CONS (QUOTE NLAMBDA)
MACRODEF)
(CDR EXPR]
(QUOTE IGNOREMACRO))
MACRODEF)
(T EXPR)))
(T EXPR])
(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])
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: NIL MACROTRAN GETMACROPROP MACROEXPANSION EXPANDMACRO MUSTCOMPILEMACROP EXPANDOPENLAMBDA
(LOCALVARS . T)
(SPECVARS FAULTX FAULTAPPLYFLG EXP VCF PCF NCF FAULTFN EXPR DWIMIFYFLG)
(GLOBALVARS NOFIXFNSLST BYTECOMPFLG CLISPARRAY BYTEMACROPROP)
(LINKFNS . T))
]
(ADDTOVAR DWIMUSERFORMS (MACROTRAN))
(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])
)
(PUTPROPS MACROS COPYRIGHT (NONE))
(DECLARE: DONTCOPY
(FILEMAP (NIL (7857 13011 (MACROTRAN 7867 . 8771) (EXPANDMACRO 8773 . 9445) (MACROEXPANSION 9447 .
10831) (GETMACROPROP 10833 . 11024) (MUSTCOMPILEMACROP 11026 . 11392) (EXPANDOPENLAMBDA 11394 . 13009)
) (13969 15132 (CSELECT 13979 . 15130)))))
STOP