(FILECREATED " 8-Dec-84 12:01:32" {ERIS}<LISPCORE>LIBRARY>LAMBDATRAN.;2 7143
changes to: (VARS LAMBDATRANCOMS)
previous date: "18-NOV-79 22:45:22" {ERIS}<LISPCORE>LIBRARY>LAMBDATRAN.;1)
(* Copyright (c) 1984 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT LAMBDATRANCOMS)
(RPAQQ LAMBDATRANCOMS [(* Translation machinery for new LAMBDA words)
(LOCALVARS . T)
[DECLARE: FIRST (P (VIRGINFN (QUOTE ARGLIST)
T)
(MOVD? (QUOTE ARGLIST)
(QUOTE OLDARGLIST))
(VIRGINFN (QUOTE NARGS)
T)
(MOVD? (QUOTE NARGS)
(QUOTE OLDNARGS))
(VIRGINFN (QUOTE ARGTYPE)
T)
(MOVD? (QUOTE ARGTYPE)
(QUOTE OLDARGTYPE))
(MOVD? (QUOTE NILL)
(QUOTE LTDWIMUSERFN]
(FNS ARGLIST ARGTYPE FNTYP1 LTDWIMUSERFN LTSTKNAME NARGS)
(ADDVARS (DWIMUSERFORMS (LTDWIMUSERFN)))
(PROP VARTYPE LAMBDATRANFNS)
(ALISTS (LAMBDATRANFNS))
(PROP MACRO LTSTKNAME)
(P (PUTHASH (QUOTE LTSTKNAME)
(QUOTE (NIL))
MSTEMPLATES))
(P (RELINK (QUOTE WORLD)))
(DECLARE: EVAL@COMPILE DONTCOPY (P (RESETSAVE DWIMIFYCOMPFLG T))
(GLOBALVARS CLISPARRAY COMMENTFLG LAMBDASPLST LAMBDATRANFNS
BOUNDPDUMMY))
(DECLARE: DONTCOPY (RECORDS LAMBDAWORD))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML LTSTKNAME)
(LAMA])
(* Translation machinery for new LAMBDA words)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS)
)
(DECLARE: FIRST
(VIRGINFN (QUOTE ARGLIST)
T)
(MOVD? (QUOTE ARGLIST)
(QUOTE OLDARGLIST))
(VIRGINFN (QUOTE NARGS)
T)
(MOVD? (QUOTE NARGS)
(QUOTE OLDNARGS))
(VIRGINFN (QUOTE ARGTYPE)
T)
(MOVD? (QUOTE ARGTYPE)
(QUOTE OLDARGTYPE))
(MOVD? (QUOTE NILL)
(QUOTE LTDWIMUSERFN))
)
(DEFINEQ
(ARGLIST
[LAMBDA (FN) (* rmk: " 6-AUG-79 22:41")
(PROG (TEMP (DEF (CGETD FN)))
(DECLARE (LOCALVARS . T))
(RETURN (if (OR (SUBRP DEF)
(NLISTP DEF)
(SELECTQ DEF:1
([LAMBDA NLAMBDA FUNARG]
T)
NIL))
then (OLDARGLIST FN)
elseif (AND CLISPARRAY TEMP←(GETHASH DEF CLISPARRAY))
then (ARGLIST TEMP)
elseif (AND TEMP←(fetch ARGLIST of (CDR (ASSOC DEF:1 LAMBDATRANFNS)))
T~=TEMP←(APPLY* TEMP DEF))
then TEMP
else (OLDARGLIST FN])
(ARGTYPE
[LAMBDA (FN) (* rmk: " 9-APR-78 12:55")
(* Note: We don't have to worry about SUBR's or CCODE here)
(OR (OLDARGTYPE FN)
(SELECTQ (FNTYP FN)
(EXPR 0)
(FEXPR 1)
(EXPR* 2)
(FEXPR* 3)
NIL])
(FNTYP1
[LAMBDA (X) (* rmk: " 6-AUG-79 22:43")
(* Called by FNTYP when it can't interpret the CAR of a list definition. Doesn't call dwimify, because it might not know what FAULTN
really is. Therefore, examines the FNTYP field of the LAMBDATRAN entry)
(PROG (TEMP)
(RETURN (if (AND CLISPARRAY TEMP←(GETHASH X CLISPARRAY))
then (FNTYP TEMP)
elseif TEMP←(CDR (ASSOC X:1 LAMBDATRANFNS))
then (SELECTQ TEMP←TEMP:FNTYP
((EXPR EXPR* FEXPR FEXPR*)
TEMP)
(NIL 'EXPR)
(APPLY* TEMP X])
(LTDWIMUSERFN
[LAMBDA NIL (* rmk: " 6-AUG-79 22:49")
(* NOTE: dwimuserfn HAS to be compiled for proper action!!)
(* LAMBDA-words can be added by making entries on LAMBDATRANFNS, e.g.
(FOOLAMBDA FOOTRAN EXPR FOOARGLIST))
(DECLARE (USEDFREE EXPR FAULTFN FAULTAPPLYFLG FAULTX FAULTARGS LAMBDASPLST LAMBDATRANFNS
COMMENTFLG CLISPCHANGE))
(PROG (FORM TRAN TRANFN (EXPR EXPR)
(FAULTFN FAULTFN))
(DECLARE (SPECVARS FAULTFN EXPR)) (* Rebind FAULTFN to guarantee function name instead of TYPE-IN)
(FORM←(if (LISTP FAULTX)
then (if (FMEMB FAULTX:1 LAMBDASPLST)
then FAULTX
elseif (LITATOM FAULTX:1)
then EXPR←(GETD FAULTFN←FAULTX:1)
else (LISTP FAULTX:1))
elseif (AND FAULTAPPLYFLG (LITATOM FAULTX))
then EXPR←(GETD FAULTFN←FAULTX)))
(RETURN (if TRANFN←(fetch TRANFN of (CDR (ASSOC FORM:1 LAMBDATRANFNS)))
then (CLISPCHANGE←T) (* Tell dwim not to try again if the translation doesn't make it)
(if (LISTP TRAN←(APPLY* TRANFN FORM))
then (if (OR FORM=(GETD FAULTFN)
FORM=(GETP FAULTFN 'EXPR))
then (* Insert the form that will establish the right function name on the
stack)
(for X TEMP on (LISTP TRAN::1)::1
unless (SELECTQ (TEMP←(LISTP X:1):1)
((DECLARE CLISP:)
T)
TEMP=COMMENTFLG)
do (ATTACH <'LTSTKNAME FAULTFN> X)
(RETURN)))
(CLISPTRAN FORM TRAN)
(if FAULTAPPLYFLG
then (RETAPPLY 'FAULTAPPLY TRAN FAULTARGS)
else (SELECTQ TRAN:1
([LAMBDA NLAMBDA]
(if FORM=FAULTX:1
then (DWIMIFY0? FAULTX::1 FAULTX NIL NIL
NIL FAULTFN))
(* Dwimify the arguments of an open LAMBDA)
FAULTX)
TRAN])
(LTSTKNAME
[NLAMBDA (NAME) (* rmk: " 6-JUN-79 10:54")
(* Smashes the correct stack-name on the frame for the LAMBDA-translation. The call goes away at compile. If BOUNDPDUMMY is bound to a
stackframe, avoids allocation on each call.)
(DECLARE (USEDFREE BOUNDPDUMMY))
(PROG (POS)
(SETSTKNAME POS←(REALSTKNTH -1 'LTSTKNAME T BOUNDPDUMMY)
NAME)
(RELSTK POS])
(NARGS
[LAMBDA (X) (* rmk: "29-APR-78 14:10")
(OR (OLDNARGS X)
(AND (NLSETQ X←(ARGLIST X))
(if X=NIL
then 0
elseif (LISTP X)
then (LENGTH X)
else 1])
)
(ADDTOVAR DWIMUSERFORMS (LTDWIMUSERFN))
(PUTPROPS LAMBDATRANFNS VARTYPE ALIST)
(ADDTOVAR LAMBDATRANFNS )
(PUTPROPS LTSTKNAME MACRO (X (CONS COMMENTFLG X)))
(PUTHASH (QUOTE LTSTKNAME)
(QUOTE (NIL))
MSTEMPLATES)
(RELINK (QUOTE WORLD))
(DECLARE: EVAL@COMPILE DONTCOPY
(RESETSAVE DWIMIFYCOMPFLG T)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS CLISPARRAY COMMENTFLG LAMBDASPLST LAMBDATRANFNS BOUNDPDUMMY)
)
)
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(RECORD LAMBDAWORD (TRANFN FNTYP ARGLIST))
]
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML LTSTKNAME)
(ADDTOVAR LAMA )
)
(PUTPROPS LAMBDATRAN COPYRIGHT ("Xerox Corporation" 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1886 6389 (ARGLIST 1896 . 2509) (ARGTYPE 2511 . 2832) (FNTYP1 2834 . 3469) (
LTDWIMUSERFN 3471 . 5663) (LTSTKNAME 5665 . 6130) (NARGS 6132 . 6387)))))
STOP