Trailing-Edge
-
PDP-10 Archives
-
-
There are no other files named in the archive.
(FILECREATED "18-NOV-79 22:45:22" <LISPUSERS>LAMBDATRAN.;24 7286
changes to: LAMBDATRANCOMS
previous date: " 6-AUG-79 22:50:04" <LISPUSERS>LAMBDATRAN.;23)
(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]
(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: DOCOPY (DECLARE: EVAL@LOADWHEN (NEQ (EVALV (QUOTE LDFLG))
(QUOTE SYSLOAD))
(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 . T)
)
(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))
)
(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
(ADDTOVAR GLOBALVARS CLISPARRAY COMMENTFLG LAMBDASPLST LAMBDATRANFNS BOUNDPDUMMY)
)
)
(DECLARE: DOCOPY
(DECLARE: EVAL@LOADWHEN (NEQ (EVALV (QUOTE LDFLG))
(QUOTE SYSLOAD))
[DECLARE: EVAL@COMPILE
(RECORD LAMBDAWORD (TRANFN FNTYP ARGLIST))
]
)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML LTSTKNAME)
(ADDTOVAR LAMA )
)
(DECLARE: DONTCOPY
(FILEMAP (NIL (1840 6470 (ARGLIST 1852 . 2483) (ARGTYPE 2487 . 2819) (FNTYP1 2823 . 3475) (
LTDWIMUSERFN 3479 . 5716) (LTSTKNAME 5720 . 6198) (NARGS 6202 . 6467)))))
STOP