(FILECREATED "30-Sep-86 23:34:31" {ERIS}<LISPCORE>SOURCES>MACROS.;48 46469
changes to: (OPTIMIZERS SELECTC)
(VARS MACROSCOMS)
(FNS CSELECT)
previous date: "29-Sep-86 12:39:35" {ERIS}<LISPCORE>SOURCES>MACROS.;47)
(* "
Copyright (c) 1984, 1985, 1986 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT MACROSCOMS)
(RPAQQ MACROSCOMS
((OPTIMIZERS ADD1 CONSTANT DEFERREDCONSTANT EVENP GEQ IGEQ ILEQ IMAX IMIN LEQ LIST* NCONC1 NEQ
NLISTP ODDP RPTQ SELECT SELECTC SETQQ SUB1 ZEROP)
(PROP MACRO ERSETQ NLSETQ XNLSETQ UNDONLSETQ RESETVAR RESETFORM RESETLST RESETSAVE
RESETTOPVALS RESETBUFS FLESSP PROG2 SIGNED UNSIGNED)
(COMS (* "obsolete Interlisp macro functions")
(FNS EXPANDMACRO MACROEXPANSION EXPAND-DEFMACRO COMPUTE-MACRO-ARGS MACROS.GETDEF
GETMACROPROP EXPANDOPENLAMBDA)
(GLOBALVARS NOFIXFNSLST BYTECOMPFLG CLISPARRAY BYTEMACROPROP))
(PROP MACRO LOADTIMECONSTANT)
(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)))))
(DEFOPTIMIZER ADD1 (X) (BQUOTE (IPLUS (\, X)
1)))
(DEFOPTIMIZER CONSTANT (&REST MACROX) (PROG ((VAL (APPLY (QUOTE PROG1)
MACROX)))
(RETURN (COND
((CONSTANTOK VAL)
(KWOTE VAL))
(T (CONS (QUOTE LOADTIMECONSTANT)
MACROX))))))
(DEFOPTIMIZER DEFERREDCONSTANT (X) (LIST (BQUOTE (LAMBDA (MACROX)
(DECLARE (LOCALVARS MACROX))
(OR (CDR MACROX)
(FRPLACD (FRPLACA MACROX (EVQ (\, X)))
T))
(CAR MACROX)))
(KWOTE (CONS))))
(DEFOPTIMIZER EVENP (N &OPTIONAL (MODULUS 2)) (BQUOTE (EQ 0 (IMOD (\, N)
(\, MODULUS)))))
(DEFOPTIMIZER GEQ (X Y) (BQUOTE (NOT (LESSP (\, X)
(\, Y)))))
(DEFOPTIMIZER IGEQ (X Y) (BQUOTE (NOT (ILESSP (\, X)
(\, Y)))))
(DEFOPTIMIZER ILEQ (X Y) (BQUOTE (NOT (IGREATERP (\, X)
(\, Y)))))
(DEFOPTIMIZER IMAX (&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)))))
(DEFOPTIMIZER IMIN (&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))))
(DEFOPTIMIZER LEQ (X Y) (BQUOTE (NOT (GREATERP (\, X)
(\, Y)))))
(DEFOPTIMIZER LIST* (&REST 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))))))
(DEFOPTIMIZER NCONC1 (LST X) (BQUOTE (NCONC (\, LST)
(CONS (\, X)))))
(DEFOPTIMIZER NEQ (X Y) (BQUOTE (NULL (EQ (\, X)
(\, Y)))))
(DEFOPTIMIZER NLISTP (X) (BQUOTE (NULL (LISTP (\, X)))))
(DEFOPTIMIZER ODDP (X . TAIL) (BQUOTE (NOT (EVENP (\, X)
\, TAIL))))
(DEFOPTIMIZER RPTQ (N . FORMS) (BQUOTE (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))))
(DEFOPTIMIZER SELECT (&REST X) (CSELECT X))
(DEFOPTIMIZER SELECTC (EXPR &REST CLAUSES)
(BQUOTE (SELECTQ (\, EXPR)
(\,@ (FOR TAIL ON CLAUSES COLLECT (CL:IF (CDR TAIL)
(BQUOTE ((\, (EVAL (CAAR TAIL)))
(\,@ (CDAR TAIL))))
(CAR TAIL)))))))
(DEFOPTIMIZER SETQQ (X V) (BQUOTE (SETQ (\, X)
(QUOTE (\, V)))))
(DEFOPTIMIZER SUB1 (X) (BQUOTE (IDIFFERENCE (\, X)
1)))
(DEFOPTIMIZER ZEROP (&REST ARGS) (CONS (QUOTE (OPENLAMBDA (X)
(COND ((EQ X 0))
((FLOATP X)
(\FZEROP X)))))
ARGS))
(PUTPROPS ERSETQ MACRO ((X)
(.ERRSETQ. X T)))
(PUTPROPS NLSETQ MACRO ((X . Y)
(.ERRSETQ. (PROGN X . Y)
NIL)))
(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 FLESSP MACRO (LAMBDA (X Y)
(FGREATERP Y X)))
(PUTPROPS PROG2 MACRO ((X . Y)
(PROGN X (PROG1 . Y))))
(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)))))
(* "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 LOADTIMECONSTANT MACRO ((X)
(DEFERREDCONSTANT X)))
(DEFINEQ
(CSELECT
(LAMBDA (L)
(DECLARE (LOCALVARS . T)) (* Pavel "30-Sep-86 23:32")
(LET*
((SELECTOR (CAR L))
(CLAUSES (CDR L))
(COND-FORM
(BQUOTE
(COND
(\,@ (FOR TAIL ON CLAUSES
COLLECT (LET ((CASES (CAR (CAR TAIL)))
(ACTIONS (CDR (CAR TAIL))))
(CL:IF (NULL (CDR TAIL))
(BQUOTE (T (\, (CAR TAIL))))
(LET* ((EQ-FORMS (FOR CASE IN (OR (LISTP CASES)
(LIST CASES))
COLLECT (BQUOTE (EQ .SELEC. (\, CASE)))))
(TEST (CL:IF (NULL (CDR EQ-FORMS))
(CAR EQ-FORMS)
(BQUOTE (OR (\,@ EQ-FORMS))))))
(BQUOTE ((\, TEST)
(\, ACTIONS))))))))))))
(CL:IF (NULL CLAUSES)
SELECTOR
(BQUOTE ((LAMBDA (.SELEC.)
(DECLARE (LOCALVARS .SELEC.))
(\, COND-FORM))
(\, SELECTOR)))))))
)
(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 (16841 33166 (EXPANDMACRO 16851 . 17807) (MACROEXPANSION 17809 . 20486) (EXPAND-DEFMACRO
20488 . 21210) (COMPUTE-MACRO-ARGS 21212 . 29441) (MACROS.GETDEF 29443 . 30193) (GETMACROPROP 30195
. 30473) (EXPANDOPENLAMBDA 30475 . 33164)) (33366 34802 (CSELECT 33376 . 34800)) (34803 45069 (
PRINTCOMSTRAN 34813 . 45067)))))
STOP