(FILECREATED "23-Jul-86 23:40:59" {ERIS}<LISPCORE>SOURCES>MACROS.;46 41879
changes to: (VARS MACROSCOMS)
previous date: "20-Jul-86 21:04:09" {ERIS}<LISPCORE>SOURCES>MACROS.;45)
(* Copyright (c) 1984, 1985, 1986 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 LIST*)
(COMS (* "obsolete Interlisp macro functions")
(FNS EXPANDMACRO MACROEXPANSION EXPAND-DEFMACRO COMPUTE-MACRO-ARGS MACROS.GETDEF
GETMACROPROP EXPANDOPENLAMBDA)
(GLOBALVARS NOFIXFNSLST BYTECOMPFLG CLISPARRAY BYTEMACROPROP))
(PROP MACRO CONSTANT LOADTIMECONSTANT DEFERREDCONSTANT)
(FNS CSELECT)
(COMS (FNS PRINTCOMSTRAN)
(GLOBALVARS COMMENTFLG LCASEFLG PRINTOUTMACROS)
(ADDVARS (PRINTOUTMACROS))
(VARS PRINTOUTTOKENS)
(PROP INFO PRINTOUT printout)
(PROP MACRO PRINTOUT printout))
(ADDVARS * (LIST (CONS (QUOTE SYSPROPS)
MACROPROPS)))
(PROP PROPTYPE * (PROGN MACROPROPS))
(PROP SETFN GETTOPVAL)
(PROP FILETYPE MACROS)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA COMPUTE-MACRO-ARGS
EXPAND-DEFMACRO])
(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 (&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 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])
(* "obsolete Interlisp macro functions")
(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])
(MACROEXPANSION
[LAMBDA (EXPR MACRODEF COMPFLG COMPILE.CONTEXT) (* lmm "17-Apr-86 10:41")
(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 (EXPAND-DEFMACRO (CDR MACRODEF)
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)))
((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])
(EXPAND-DEFMACRO
[CL:LAMBDA (DEF FORM &OPTIONAL DEFAULT-VALUE) (* lmm "25-May-86 00:15")
(LET (*MACRO-VARS* *MACRO-VALS* (*MACRO-FORM* FORM)
(*MACRO-DEFAULT* DEFAULT-VALUE))
(DECLARE (SPECIAL *MACRO-VARS* *MACRO-VALS* *MACRO-FORM* *MACRO-DEFAULT*))
(COMPUTE-MACRO-ARGS (CAR DEF)
(CDR FORM)
NIL)
(LET [(VAL (PROGV *MACRO-VARS* *MACRO-VALS* (EVAL (CONS (QUOTE PROGN)
(CDR DEF]
(if (EQ VAL (QUOTE IGNOREMACRO))
then FORM else VAL])
(COMPUTE-MACRO-ARGS
[CL:LAMBDA (ARGUMENT-LIST MACRO-CALL-BODY CONTEXT) (* lmm "18-Apr-86 12:04")
(COND
((NULL ARGUMENT-LIST)
NIL)
((CL:ATOM ARGUMENT-LIST)
(SETQ *MACRO-VARS* (CONS ARGUMENT-LIST *MACRO-VARS*))
(SETQ *MACRO-VALS* (CONS MACRO-CALL-BODY *MACRO-VALS*)))
(T
(SELECTQ (CAR ARGUMENT-LIST)
((&REST &BODY)
(COMPUTE-MACRO-ARGS (CADR ARGUMENT-LIST)
MACRO-CALL-BODY NIL)
(COMPUTE-MACRO-ARGS (CDDR ARGUMENT-LIST)
MACRO-CALL-BODY
(QUOTE AUX-ONLY)))
(&WHOLE (COMPUTE-MACRO-ARGS (CADR ARGUMENT-LIST)
*MACRO-FORM*
(QUOTE ONE))
(COMPUTE-MACRO-ARGS (CDDR ARGUMENT-LIST)
MACRO-CALL-BODY
(QUOTE AUX-ONLY)))
(&ENVIRONMENT (* dunno exactly what to do about
this-- there no environments here
right now)
(COMPUTE-MACRO-ARGS (CADR ARGUMENT-LIST)
NIL
(QUOTE ONE))
(COMPUTE-MACRO-ARGS (CDDR ARGUMENT-LIST)
MACRO-CALL-BODY
(QUOTE AUX-ONLY)))
(&OPTIONAL (COMPUTE-MACRO-ARGS (CDR ARGUMENT-LIST)
MACRO-CALL-BODY
(QUOTE OPTIONAL)))
(&AUX (COMPUTE-MACRO-ARGS (CDR ARGUMENT-LIST)
MACRO-CALL-BODY
(QUOTE AUX)))
(&KEY (SETQ ARGUMENT-LIST (CDR ARGUMENT-LIST))
[while ARGUMENT-LIST
do (SELECTQ (CAR ARGUMENT-LIST)
((&REST &ALLOW-OTHER-KEYS &AUX)
(RETURN (COMPUTE-MACRO-ARGS ARGUMENT-LIST MACRO-CALL-BODY NIL)))
(PROGN (LET* [(KEYWORD-VARIABLE (CAR ARGUMENT-LIST))
SUPPLIED-P-VARIABLE
[DEFAULT-VALUE (COND
((CONSP KEYWORD-VARIABLE)
(PROG1 (CADR KEYWORD-VARIABLE)
(SETQ SUPPLIED-P-VARIABLE
(CADDR KEYWORD-VARIABLE))
(SETQ KEYWORD-VARIABLE
(CAR KEYWORD-VARIABLE]
[KEYWORD (COND
[(CONSP KEYWORD-VARIABLE)
(PROG1 (CAR KEYWORD-VARIABLE)
(SETQ KEYWORD-VARIABLE (CADR
KEYWORD-VARIABLE
]
(T (MAKE-KEYWORD KEYWORD-VARIABLE]
(FOUND-VALUE (for FM on MACRO-CALL-BODY
by (CDDR FM)
do (COND
((EQ (CAR FM)
KEYWORD)
(RETURN (CDR FM]
[COND
(SUPPLIED-P-VARIABLE (COMPUTE-MACRO-ARGS
SUPPLIED-P-VARIABLE
(COND
(FOUND-VALUE T)
(T NIL))
(QUOTE ONE]
(COMPUTE-MACRO-ARGS KEYWORD-VARIABLE (COND
(FOUND-VALUE
(CAR FOUND-VALUE))
(T (EVAL
DEFAULT-VALUE
)))
(QUOTE ONE)))
(pop ARGUMENT-LIST])
(PROGN [COND
[(EQ CONTEXT (QUOTE OPTIONAL))
(COND
[(CONSP (CAR ARGUMENT-LIST)) (* an optional of the form
(arg init val))
(DESTRUCTURING-BIND (ARG INIT SUPPLIEDP)
(CAR ARGUMENT-LIST)
(COND
((CL:ATOM MACRO-CALL-BODY)
(* optional omitted)
(AND SUPPLIEDP (COMPUTE-MACRO-ARGS SUPPLIEDP NIL (QUOTE ONE)))
(COMPUTE-MACRO-ARGS (CAAR ARGUMENT-LIST)
(EVAL INIT)
(QUOTE ONE)))
(T (* optional present)
[COND
(SUPPLIEDP (COMPUTE-MACRO-ARGS SUPPLIEDP T (QUOTE ONE]
(COMPUTE-MACRO-ARGS (CAAR ARGUMENT-LIST)
(CAR MACRO-CALL-BODY)
NIL]
(T (COND
((CL:ATOM MACRO-CALL-BODY) (* optional omitted)
(COMPUTE-MACRO-ARGS (CAR ARGUMENT-LIST)
*MACRO-DEFAULT*
(QUOTE ONE)))
(T (* optional present)
(COMPUTE-MACRO-ARGS (CAR ARGUMENT-LIST)
(CAR MACRO-CALL-BODY)
NIL]
[(EQ CONTEXT (QUOTE AUX))
(for BINDING in ARGUMENT-LIST do (COND
((CONSP BINDING)
(COMPUTE-MACRO-ARGS (CAR BINDING)
(EVAL (CADR BINDING))
(QUOTE ONE)))
(T (COMPUTE-MACRO-ARGS BINDING NIL
(QUOTE ONE]
(T (COND
((CL:ATOM MACRO-CALL-BODY)
(ERROR "macro body missing value for" ARGUMENT-LIST))
(T (COMPUTE-MACRO-ARGS (CAR ARGUMENT-LIST)
(CAR MACRO-CALL-BODY)
NIL]
(COMPUTE-MACRO-ARGS (CDR ARGUMENT-LIST)
(CDR MACRO-CALL-BODY)
CONTEXT])
(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])
(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: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS NOFIXFNSLST BYTECOMPFLG CLISPARRAY BYTEMACROPROP)
)
(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 "10-Jan-86 13:55")
(* 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 (push VARS ARG) (* Suppress spelling-correction of formatcode atoms)
(push FORMATLIST
(CONS ARG
(BQUOTE
(QUOTE (, (COND
((EQ TYPE (CHARCODE I))
(QUOTE FIX))
(T (QUOTE FLOAT)))
, WIDTH .,
(while POINT
collect (SUBATOM
ARG
(ADD1 POINT)
(AND (SETQ POINT
(STRPOS (QUOTE %.)
ARG
(ADD1 POINT)))
(SUB1 POINT]
(* 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
,
(LIST (QUOTE QUOTE)
(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 , (LIST (QUOTE QUOTE)
(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 (BQUOTE (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))
(PUTPROPS PRINTOUT INFO NOEVAL)
(PUTPROPS printout INFO NOEVAL)
(PUTPROPS PRINTOUT MACRO (DEFMACRO (&WHOLE X) (PRINTCOMSTRAN X (FUNCTION CDDR)
PRINTOUTMACROS
(FUNCTION CADR)) )
)
(PUTPROPS printout MACRO (DEFMACRO (&WHOLE X) (PRINTCOMSTRAN X (FUNCTION CDDR)
PRINTOUTMACROS
(FUNCTION CADR)) )
)
(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)
(PUTPROPS MACROS FILETYPE COMPILE-FILE)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA COMPUTE-MACRO-ARGS EXPAND-DEFMACRO)
)
(PUTPROPS MACROS COPYRIGHT ("Xerox Corporation" 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (16089 31294 (EXPANDMACRO 16099 . 16984) (MACROEXPANSION 16986 . 19659) (EXPAND-DEFMACRO
19661 . 20296) (COMPUTE-MACRO-ARGS 20298 . 28626) (MACROS.GETDEF 28628 . 29190) (GETMACROPROP 29192
. 29427) (EXPANDOPENLAMBDA 29429 . 31292)) (32731 34211 (CSELECT 32741 . 34209)) (34212 40476 (
PRINTCOMSTRAN 34222 . 40474)))))
STOP