(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