(FILECREATED "18-NOV-79 22:45:22" <LISPUSERS>LAMBDATRAN.;24
    7065

     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 (1773 6288 (ARGLIST 1785 . 2398) (ARGTYPE 2402 . 2723) (FNTYP1 2727 . 3362) (
LTDWIMUSERFN 3366 . 5558) (LTSTKNAME 5562 . 6027) (NARGS 6031 . 6286)))))
STOP