* interp/c-util.boot (backendCompileNEWNAM): New.

	(pushLocalVariable): Likewise.
	(mutateToBackendCode): Likewise.
	(transformToBackendCode): Likewise
	* interp/comp.lisp (FLUIDVARS): Remove.
	(LOCVARS): Likewise.
	(SPECIALVARS): Likewise.
	($CLOSEDFNS): Likewise.
	(COMP-NAM): Likewise.
	(COMP-TRAN): Likewise.
	(COMP-TRAN-1): Likewise.
	* interp/compiler.boot (compWithMappingMode): Use
	transformToBackendCode. 
	(COMP-1): Use backendCompileNEWNAM.
	* interp/i-analy.boot (bottomUpCompile): Use mutateToBackendCode.

5 files changed, 107 insertions, 108 deletions

diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot
index d2bd035a..c18d6b52 100644
--- a/src/interp/c-util.boot
+++ b/src/interp/c-util.boot
@@ -1049,6 +1049,24 @@ backendCompileILAM(name,args,body) ==
   setDynamicBinding(name,["LAMBDA",args',:body'])
   name
 
+$CLOSEDFNS := nil
+
+MAKE_-CLOSEDFN_-NAME() ==
+  INTERNL($FUNNAME,'"!", STRINGIMAGE # $CLOSEDFNS)
+
+backendCompileNEWNAM: %Form -> %Void
+backendCompileNEWNAM x ==
+  isAtomicForm x => nil
+  atom(y := first x) =>
+    backendCompileNEWNAM rest x
+    if y = "CLOSEDFN" then
+      u := MAKE_-CLOSEDFN_-NAME()
+      PUSH([u,second x], $CLOSEDFNS)
+      RPLACA(x,"FUNCTION")
+      RPLACA(rest x,u)
+  backendCompileNEWNAM first x
+  backendCompileNEWNAM rest x
+
 
 ++ Lisp back end compiler for SLAM forms [namd,args,:body].
 ++ A SLAM form is one that is `functional' in the sense that
@@ -1136,7 +1154,6 @@ backendCompile2 code ==
   else COMP370 [body]
   name
 
-
 ++ returns all fuild variables contained in `x'.  Fuild variables are
 ++ identifiers starting with '$', except domain variable names.
 backendFluidize x ==
@@ -1149,3 +1166,88 @@ backendFluidize x ==
   a = nil => b
   [a,:b]
 
+
+$FluidVars := []
+$LocalVars := []
+$SpecialVars := []
+
+
+++ push `x' into the list of local variables.
+pushLocalVariable: %Symbol -> %List
+pushLocalVariable x ==
+  x ^= "$" and (p := PNAME x).0 = char "$" and
+    p.1 ^= char "," and not DIGITP p.1 => nil
+  PUSH(x,$LocalVars)
+
+
+
+++ Replace every middle end sub-forms in `x' with Lisp code.
+mutateToBackendCode: %Form -> %Void
+mutateToBackendCode x ==
+  isAtomicForm x => nil
+  -- temporarily have TRACELET report MAKEPROPs.
+  if (u := first x) = "MAKEPROP" and $TRACELETFLAG then
+    RPLACA(x,"MAKEPROP-SAY")
+  u in '(DCQ RELET PRELET SPADLET SETQ %LET) =>
+    if u ^= "DCQ" then
+      $NEWSPAD or $FUNAME in $traceletFunctions =>
+        nconc(x,$FUNNAME__TAIL)
+        RPLACA(x,"LETT")
+      $TRACELETFLAG => RPLACA(x,"/TRACE-LET")
+      u = "%LET" => RPLACA(x,"SPADLET")
+    mutateToBackendCode CDDR x
+    if not (u in '(SETQ RELET)) then
+      IDENTP second x => pushLocalVariable second x
+      second x is ["FLUID",:.] =>
+        PUSH(CADADR x, $FluidVars)
+        rplac(second x, CADADR x)
+      MAPC(function pushLocalVariable, LISTOFATOMS second x)
+  IDENTP u and GET(u,"ILAM") ^= nil =>
+    RPLACA(x, eval u)
+    mutateToBackendCode x
+  u in '(PROG LAMBDA) =>
+    newBindings := []
+    for y in second x repeat
+      not (y in $LocalVars) =>
+        $LocalVars := [y,:$LocalVars]
+        newBindings := [y,:newBindings]
+    res := mutateToBackendCode CDDR x
+    $LocalVars := REMOVE_-IF(function LAMBDA(y(), y in newBindings), 
+                     $LocalVars)
+    [u,second x,:res]
+  mutateToBackendCode u
+  mutateToBackendCode rest x
+
+
+++ Generate Lisp code by lowering middle end form `x'.
+transformToBackendCode: %Form -> %Code
+transformToBackendCode x ==
+  $FluidVars: fluid := nil
+  $LocalVars: fluid := nil
+  $SpecialVars: fluid := nil
+  x := middleEndExpand x
+  mutateToBackendCode CDDR x
+  body := 
+    null CDDDR x and 
+      (atom third x or first third x = "SEQ"
+        or not CONTAINED("EXIT",third x)) =>
+          third x
+    ["SEQ",:CDDR x]
+  x := [first x, second x, body]
+  $FluidVars := REMDUP nreverse $FluidVars
+  $LocalVars := S_-(S_-(REMDUP nreverse $LocalVars,$FluidVars),
+                  LISTOFATOMS second x)
+  lvars := [:$FluidVars,:$LocalVars]
+  fluids := S_+($FluidVars,$SpecialVars)
+  x := 
+    fluids ^= nil =>
+      [first x, second x, ["PROG",lvars,["DECLARE","SPECIAL",:fluids],
+                            ["RETURN",third x]]]
+    [first x, second x, 
+      (lvars ^= nil or CONTAINED("RETURN",third x) =>
+        ["PROG",lvars,["RETURN",third x]]; third x)]
+  -- add reference parameters to the list of special variables.
+  fluids := S_+(backendFluidize second x, $SpecialVars)
+  null fluids => x
+  [first x, second x, ["DECLARE","SPECIAL",:fluids],:CDDR x]
+
diff --git a/src/interp/comp.lisp b/src/interp/comp.lisp
index 46499b85..ad6b6520 100644
--- a/src/interp/comp.lisp
+++ b/src/interp/comp.lisp
@@ -58,13 +58,6 @@
 
 ;;; Common Block section
 
-(defparameter FluidVars nil)
-(defparameter LocVars nil)
-; (defparameter OptionList nil) defined in nlib.lisp
-(defparameter SpecialVars nil)
-
-(defvar $closedfns nil)
-
 ;; The following are used mainly in setvars.boot
 (defun notEqualLibs (u v)
   (if (string= u (library-name v)) (seq (close-library v) t) nil))
@@ -86,52 +79,6 @@
 ;; used to be called POSN - but that interfered with a CCL function
 (DEFUN POSN1 (X L) (position x l :test #'equal))
 
-(DEFUN COMP-NEWNAM (X)
-  (let (y u)
-    (cond ((ATOM X) NIL)
-          ((ATOM (setq Y (CAR X)))
-          ;; (AND (IDENTP Y) (setq U (GET Y 'NEWNAM)) (RPLACA X U))
-           (AND (NOT (eq Y 'QUOTE)) (COMP-NEWNAM (CDR X)))
-           (WHEN (and (EQ Y 'CLOSEDFN) (boundp '$closedfns))
-                 (SETQ U (MAKE-CLOSEDFN-NAME))
-                 (PUSH (list U (CADR X)) $closedfns)
-                 (rplaca x 'FUNCTION)
-                 (rplaca (cdr x) u)))
-          (t (COMP-NEWNAM (CAR X)) (COMP-NEWNAM (CDR X))))))
-
-(defun make-closedfn-name ()
-  (internl $FUNNAME "!" (STRINGIMAGE (LENGTH $CLOSEDFNS))))
-
-(DEFUN COMP-TRAN (X)
-  "SEXPR<FN. BODY> -> SEXPR"
-  (let ((X (|middleEndExpand| X)) FluidVars LocVars SpecialVars)
-    (COMP-TRAN-1 (CDDR X))
-    (setq X (list (first x) (second x)
-                  (if (and (null (cdddr x))
-                           (or (atom (third x))
-                               (eq (car (third x)) 'SEQ)
-                               (not (contained 'EXIT (third x)))))
-                      (caddr x)
-                      (cons 'SEQ (cddr x))))) ;catch naked EXITs
-    (let* ((FluidVars (REMDUP (NREVERSE FLUIDVARS)))
-           (LOCVARS (S- (S- (REMDUP (NREVERSE LOCVARS)) FLUIDVARS)
-                        (LISTOFATOMS (CADR X))))
-           (LVARS (append fluidvars LOCVARS)))
-      (let ((fluids (S+ fluidvars SpecialVars)))
-        (setq x
-              (if fluids
-                  `(,(first x) ,(second x)
-                    (prog ,lvars (declare (special . ,fluids))
-                      (return ,(third x))))
-                  (list (first x) (second x)
-                     (if (or lvars (contained 'RETURN (third x)))
-                         `(prog ,lvars (return ,(third x)))
-                         (third x)) )))))
-    (let ((fluids (S+ (|backendFluidize| (second x)) SpecialVars)))
-      (if fluids
-          `(,(first x) ,(second x) (declare (special . ,fluids)) . ,(cddr x))
-          `(,(first x) ,(second x) . ,(cddr x))))))
-
 ; Fluidize: Returns a list of fluid variables in X
 
 (DEFUN COMP\,FLUIDIZE  (X) (COND
@@ -149,55 +96,6 @@
               (RETURN X))
             ('T (RETURN (CONS A B)) )) )    )))
 
-(DEFUN COMP-TRAN-1 (X)
-  (let (u)
-    (cond ((ATOM X) NIL)
-          ((eq (setq U (CAR X)) 'QUOTE) NIL)
-          ((AND (eq U 'MAKEPROP) $TRACELETFLAG (RPLAC (CAR X) 'MAKEPROP-SAY) NIL)
-           NIL)
-           ; temporarily make TRACELET cause MAKEPROPs to be reported
-          ((MEMQ U '(DCQ RELET PRELET SPADLET SETQ %LET) )
-           (COND ((NOT (eq U 'DCQ))
-                  (COND ((OR (AND (eq $NEWSPAD T))
-                             (MEMQ $FUNNAME |$traceletFunctions|))
-                         (NCONC X $FUNNAME_TAIL)
-                         (RPLACA X 'LETT))
-                        ; this devious trick (due to RDJ) is needed since the compile
-                        ; looks only at global variables in top-level environment;
-                        ; thus SPADLET cannot itself test for such flags (7/83).
-                        ($TRACELETFLAG (RPLACA X '/TRACE-LET))
-                        ((eq U '%LET) (RPLACA X 'SPADLET)))))
-           (COMP-TRAN-1 (CDDR X))
-           (AND (NOT (MEMQ U '(setq RELET)))
-                (COND ((IDENTP (CADR X)) (PUSHLOCVAR (CADR X)))
-                      ((EQCAR (CADR X) 'FLUID)
-                       (PUSH (CADADR X) FLUIDVARS)
-                       (RPLAC (CADR X) (CADADR X)))
-                      ((mapc #'pushlocvar (listofatoms (cadr x))) nil))))
-          ((and (symbolp u) (GET U 'ILAM))
-           (RPLACA X (EVAL U)) (COMP-TRAN-1 X))
-          ((MEMQ U '(PROG LAMBDA))
-           (PROG (NEWBINDINGS RES)
-                 (setq NEWBINDINGS NIL)
-                 (mapcar #'(lambda (Y)
-                             (COND ((NOT (MEMQ Y LOCVARS))
-                                    (setq LOCVARS (CONS Y LOCVARS))
-                                    (setq NEWBINDINGS (CONS Y NEWBINDINGS)))))
-                         (second x))
-                 (setq RES (COMP-TRAN-1 (CDDR X)))
-                 (setq locvars (remove-if #'(lambda (y) (memq y newbindings))
-                                          locvars))
-                 (RETURN (CONS U (CONS (CADR X) RES)) )) )
-          ((PROGN (COMP-TRAN-1 U) (COMP-TRAN-1 (CDR X)))))))
-
-(DEFUN PUSHLOCVAR (X)
-  (let (p)
-    (cond ((AND (NE X '$)
-                (char= #\$ (ELT (setq P (PNAME X)) 0))
-                (NOT (char= #\, (ELT P 1)))
-                (NOT (DIGITP (ELT P 1)))) NIL)
-          ((PUSH X LOCVARS)))))
-
 (defmacro PRELET (L) `(spadlet . ,L))
 (defmacro RELET (L) `(spadlet . ,L))
 (defmacro PRESET (L) `(spadlet . ,L))
diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot
index dc5f1211..99d44744 100644
--- a/src/interp/compiler.boot
+++ b/src/interp/compiler.boot
@@ -277,7 +277,7 @@ compWithMappingMode(x,m is ["Mapping",m',:sl],oldE) ==
   --  pass this as the environment to our inner function.
   $FUNNAME :local := nil
   $FUNNAME__TAIL :local := [nil]
-  expandedFunction:=COMP_-TRAN CADR uu
+  expandedFunction:= transformToBackendCode second uu
   frees:=FreeList(expandedFunction,vl,nil,e)
     where FreeList(u,bound,free,e) ==
       atom u =>
@@ -1928,8 +1928,8 @@ COMP_-1 x ==
   $FUNNAME__TAIL := [fname]
   lamex := second x
   $CLOSEDFNS := []
-  lamex := COMP_-TRAN lamex
-  COMP_-NEWNAM lamex
+  lamex := transformToBackendCode lamex
+  backendCompileNEWNAM lamex
   -- Note that category constructors are evaluated before they
   -- their compiled, so this noise is not very helpful.
   if $verbose and FBOUNDP fname then
diff --git a/src/interp/i-analy.boot b/src/interp/i-analy.boot
index 45623e50..cbf3e34a 100644
--- a/src/interp/i-analy.boot
+++ b/src/interp/i-analy.boot
@@ -290,7 +290,7 @@ computeTypeWithVariablesTarget(p, q) ==
 bottomUpCompile t ==
   $genValue:local := false
   ms := bottomUp t
-  COMP_-TRAN_-1 objVal getValue t
+  mutateToBackendCode objVal getValue t
   ms
 
 bottomUpUseSubdomain t ==
diff --git a/src/interp/wi1.boot b/src/interp/wi1.boot
index 8693f7d4..a936733b 100644
--- a/src/interp/wi1.boot
+++ b/src/interp/wi1.boot
@@ -324,7 +324,6 @@ compWithMappingMode(x,m,oldE) ==
   originalFun := u
   if originalFun is ['WI,a,b] then u := b
   uu := ['LAMBDA,vl,u]
-  --------------------------> 11/28 drop COMP-TRAN, optimizations
   T := [uu,m,oldE]
   originalFun is ['WI,a,b] => markLambda(vl,a,m,T)
   markLambda(vl,originalFun,m,T)