(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP")

(FILECREATED "19-Feb-87 10:40:43" {QV}<LFG>PARSER>NEXT>LAMBDATRAN.;2
 9556   

      changes to%:  (FNS FNTYP1 LTDWIMUSERFN LTSTKNAME NARGS)

      previous date%: "19-Feb-87 09:56:18" {QV}<LFG>PARSER>NEXT>LAMBDATRAN.;1)


(* "
Copyright (c) 1984, 1987 by Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT LAMBDATRANCOMS)

(RPAQQ LAMBDATRANCOMS
 [(* Translation machinery for new LAMBDA words)
                       (LOCALVARS . T)
                       [DECLARE%: FIRST (P (VIRGINFN 'ARGLIST T)
                                           (MOVD? 'ARGLIST 'OLDARGLIST)
                                           (VIRGINFN 'NARGS T)
                                           (MOVD? 'NARGS 'OLDNARGS)
                                           (VIRGINFN 'ARGTYPE T)
                                           (MOVD? 'ARGTYPE 'OLDARGTYPE)
                                           (MOVD? 'NILL 'LTDWIMUSERFN]
                       (FNS ARGLIST ARGTYPE FNTYP1 LTDWIMUSERFN LTSTKNAME NARGS)
                       (ADDVARS (DWIMUSERFORMS (LTDWIMUSERFN)))
                       (PROP VARTYPE LAMBDATRANFNS)
                       (ALISTS (LAMBDATRANFNS))
                       (PROP MACRO LTSTKNAME)
                       (P (PUTHASH 'LTSTKNAME '(NIL) MSTEMPLATES))
                       (P (RELINK '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 . T)
)
(DECLARE%: FIRST 
(VIRGINFN 'ARGLIST T)
(MOVD? 'ARGLIST 'OLDARGLIST)
(VIRGINFN 'NARGS T)
(MOVD? 'NARGS 'OLDNARGS)
(VIRGINFN 'ARGTYPE T)
(MOVD? 'ARGTYPE 'OLDARGTYPE)
(MOVD? 'NILL '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 (CAR DEF)
                              ([LAMBDA NLAMBDA FUNARG] 
                                   T)
                              NIL))
                      then
 (OLDARGLIST FN)
                    elseif
 (AND CLISPARRAY (SETQ TEMP (GETHASH DEF CLISPARRAY)))
                      then
 (ARGLIST
 TEMP)
                    elseif
 [AND [SETQ TEMP (fetch
 ARGLIST of
 (CDR (ASSOC (CAR DEF)
                                                                         LAMBDATRANFNS]
                                (NEQ T (SETQ 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 (SETQ TEMP (GETHASH X CLISPARRAY)))
                      then
 (FNTYP TEMP)
                    elseif
 (SETQ TEMP (CDR (ASSOC (CAR X)
                                                  LAMBDATRANFNS)))
                      then
 (SELECTQ (SETQ TEMP (fetch
 FNTYP of
 TEMP))
                               ((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)

          [SETQ FORM (if
 (LISTP FAULTX)
                         then
 (if
 (FMEMB (CAR FAULTX)
                                         LAMBDASPLST)
                                  then
 FAULTX
                                elseif
 (LITATOM (CAR FAULTX))
                                  then
 [SETQ EXPR (GETD (SETQ FAULTFN (CAR FAULTX]
                                else
 (LISTP (CAR FAULTX)))
                       elseif
 (AND FAULTAPPLYFLG (LITATOM FAULTX))
                         then
 (SETQ EXPR (GETD (SETQ FAULTFN FAULTX]
          (RETURN
           (if
 [SETQ TRANFN (fetch
 TRANFN of
 (CDR (ASSOC (CAR FORM)
                                                         LAMBDATRANFNS]
               then
 (SETQ CLISPCHANGE T) 
          
          (* Tell dwim not to try again if the translation doesn't make it)


                    (if
 (LISTP (SETQ TRAN (APPLY* TRANFN FORM)))
                        then
 (if
 [OR (EQ FORM (GETD FAULTFN))
                                     (EQ FORM (GETP FAULTFN 'EXPR]
                                 then
 
          
          (* Insert the form that will establish the right function name on the stack)


                                      (for
 X TEMP on
 (CDR (LISTP (CDR TRAN)))
                                         unless
 (SELECTQ [SETQ TEMP (CAR (LISTP (CAR X]
                                                    ((DECLARE CLISP%:) 
                                                         T)
                                                    (EQ TEMP COMMENTFLG))
                                         do
 (ATTACH (LIST 'LTSTKNAME FAULTFN)
                                                   X)
                                            (RETURN)))
                             (CLISPTRAN FORM TRAN)
                             (if
 FAULTAPPLYFLG
                                 then
 (RETAPPLY 'FAULTAPPLY TRAN FAULTARGS)
                               else
 (SELECTQ (CAR TRAN)
                                        ([LAMBDA NLAMBDA] 
                                             (if
 (EQ FORM (CAR FAULTX))
                                                 then
 (DWIMIFY0? (CDR FAULTX)
                                                             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 (SETQ POS (REALSTKNTH -1 'LTSTKNAME T BOUNDPDUMMY))
                 NAME)
          (RELSTK POS])

(NARGS

  [LAMBDA (X)
                                                (* rmk%: "29-APR-78 14:10")

    (OR (OLDNARGS X)
        (AND (NLSETQ (SETQ X (ARGLIST
 X)))
             (if
 (NULL X)
                 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 'LTSTKNAME '(NIL) MSTEMPLATES)
(RELINK '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 1987))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (2224 8821 (ARGLIST 2234 . 3188) (ARGTYPE 3190 . 3544) (FNTYP1 3546 . 4455) (
LTDWIMUSERFN 4457 . 7957) (LTSTKNAME 7959 . 8483) (NARGS 8485 . 8819)))))
STOP