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

	(middleEndExpand): New.
	(backendCompileILAM): Bootify COMP-ILAM.
	(backendCompileSLAM): Bootify COMP-SLAM.
	(backendCompileSPADSLAM): Bootify COMP-SPADSLAM.
	* interp/comp.lisp (COMP-2): Use them.
	(COMP-ILAM): Remove.
	(COMP-SLAM): Likewise.
	(COMP-SPADLSAM): Likewise.
	(COMP-TRAN): Use middleEndExpand.
	(COMP-EXPAND): Remove.
	($COMP-MACROLIS): Likewise.

3 files changed, 122 insertions, 99 deletions

diff --git a/src/ChangeLog b/src/ChangeLog
index 279725d7..5fb64461 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,3 +1,18 @@
+2008-10-10  Gabriel Dos Reis  <gdr@cs.tamu.edu>
+
+	* interp/c-util.boot ($middleEndMacroList): New.
+	(middleEndExpand): New.
+	(backendCompileILAM): Bootify COMP-ILAM.
+	(backendCompileSLAM): Bootify COMP-SLAM.
+	(backendCompileSPADSLAM): Bootify COMP-SPADSLAM.
+	* interp/comp.lisp (COMP-2): Use them.
+	(COMP-ILAM): Remove.
+	(COMP-SLAM): Likewise.
+	(COMP-SPADLSAM): Likewise.
+	(COMP-TRAN): Use middleEndExpand.
+	(COMP-EXPAND): Remove.
+	($COMP-MACROLIS): Likewise.
+
 2008-10-09  Gabriel Dos Reis  <gdr@cs.tamu.edu>
 
 	* boot/translator.boot (loadNativeModule): Don't save loaded
diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot
index 27abe533..c7c9443a 100644
--- a/src/interp/c-util.boot
+++ b/src/interp/c-util.boot
@@ -895,6 +895,26 @@ updateCapsuleDirectory(entry,pred) ==
 
 --% 
 
+++ List of macros used by the middle end to represent some
+++ high level control structures.
+-- NOTE: It is potentially dangerous to assume every occurrence of 
+-- element of $middleEndMacroList is actually a macro call
+$middleEndMacroList == 
+  '(COLLECT REPEAT SUCHTHATCLAUSE THETA COLLECTV 
+    COLLECTVEC THETA1 SPADREDUCE SPADDO)
+
+middleEndExpand: %Form -> %Form
+middleEndExpand x ==
+  isAtomicForm x => x
+  first x in $middleEndMacroList =>
+    middleEndExpand MACROEXPAND_-1 x
+  a := middleEndExpand first x
+  b := middleEndExpand rest x
+  EQ(a,first x) and EQ(b,rest x) => x
+  [a,:b]
+
+
+
 -- A function is simple if it looks like a super combinator, and it
 -- does not use its environment argument.  They can be safely replaced
 -- by more efficient (hopefully) functions.
@@ -993,7 +1013,7 @@ setCompilerOptimizations level ==
   coreError '"unknown optimization level request"
 
 
---%
+--% Lisp backend support.
 
 ++ Proclaim the type of the capsule function `op' with signature `sig'.
 ++ Note that all capsule functions take an additional argument 
@@ -1019,3 +1039,85 @@ proclaimCapsuleFunction(op,sig) ==
           getmode(d,$e) => "*"
           d
         [first d, :[normalize(first args,false) for args in tails rest d]]
+
+++ Lisp back end compiler for ILAM with `name', formal `args', and `body'.
+backendCompileILAM: (%Symbol,%List, %Code) -> %Symbol
+backendCompileILAM(name,args,body) ==
+  args' := NLIST(#args, ["GENSYM"])
+  body' := eqSubst(args',args,body)
+  MAKEPROP(name,"ILAM",true)
+  setDynamicBinding(name,["LAMBDA",args',:body'])
+  name
+
+
+++ Lisp back end compiler for SLAM forms [namd,args,:body].
+++ A SLAM form is one that is `functional' in the sense that
+++ its values are cached, so that equal lists of argument values
+++ yield equal values.  The arguments-value pairs are stored
+++ as alists.
+backendCompileSLAM: (%Symbol,%List,%Code) -> %Symbol
+backendCompileSLAM(name,args,body) ==
+  al := INTERNL(name,'";AL")    -- name of the cache alist.
+  auxfn := INTERNL(name,'";")   -- name of the worker function.
+  g1 := GENSYM()                -- name for the parameter.
+  g2 := GENSYM()                -- name for the cache value
+  u :=                          -- body of the stub function
+    null args => [nil,[auxfn]]
+    null rest args => [[g1],[auxfn,g1]]
+    [g1,["APPLX", ["FUNCTION",auxfn], g1]]
+  arg := first u
+  app := second u
+  codePart1 :=                  -- look up the value if it is already there
+    args ^= nil => [["SETQ", g2, ["assoc",g1,al]], ["CDR",g2]]
+    [al]
+  codePart2 :=                  -- otherwise, compute it.
+    args ^= nil => [true,["SETQ",g2,app],["SETQ",al,[[g1,:g2],:al]],g2]
+    [true,["SETQ",al,app]]
+  lamex := ["LAM",arg,["PROG",[g2],
+                        ["RETURN",["COND",codePart1,codePart2]]]]
+  setDynamicBinding(al,nil)     -- clear the cache
+  -- compile the worker function, first.
+  u := [auxfn,["LAMBDA",args,:body]]
+  COMP370 [u]
+  -- then compile the original function.
+  u := [name,lamex]
+  if $PrettyPrint then PRETTYPRINT u
+  COMP370 [u]
+  name
+
+++ Same as backendCompileSPADSLAM, except that the cache is a hash
+++ table.  This backend compiler is used to compile constructors.
+backendCompileSPADSLAM: (%Symbol,%List,%Code) -> %Symbol
+backendCompileSPADSLAM(name,args,body) ==
+  al := INTERNL(name,'";AL")   -- name of the cache hash table.
+  auxfn := INTERNL(name,'";")  -- name of the worker function.
+  g1 := GENSYM()               -- name of the worker function parameter
+  g2 := GENSYM()               -- name for the cache value.
+  u := 
+    null args => [nil,nil,[auxfn]]
+    null rest args => [[g1],["devaluate",g1],[auxfn,g1]]
+    [g1,["devaluateList",g1],["APPLY",["FUNCTION",auxfn],g1]]
+  arg := first u
+  argtran := second u          -- devaluate argument
+  app := third u
+  codePart1 :=                 -- if value already computed, grab it.
+    null args = nil => [al]
+    [["SETQ",g2,["assoc",argtran,al]], ["CDR",g2]]
+  codePart2 :=                 -- otherwise compute it, and cache it.
+                               -- Note: at most five values are cached.
+    null args = nil => [true,["SETQ",al,app]]
+    [true,["SETQ",al,["cons5",["CONS",argtran, ["SETQ",g2,app]],al]],g2]
+  decl :=                      -- declare the cache variable.
+    null args => nil
+    [g2]
+  lamex := ["LAM",arg,["LET",decl,["COND",codePart1,codePart2]]]
+  SETANDFILE(al,nil)           -- define the global cache.
+  -- compile the worker function first.
+  u := [auxfn,["LAMBDA",args,:body]]
+  if $PrettyPrint then PRETTYPRINT u
+  COMP370 [u]
+  -- then compiler the stub (which is the user-visible constructor).
+  u := [name,lamex]
+  if $PrettyPrint then PRETTYPRINT u
+  COMP370 [u]
+  name
diff --git a/src/interp/comp.lisp b/src/interp/comp.lisp
index 2a52d020..c8bdb9fb 100644
--- a/src/interp/comp.lisp
+++ b/src/interp/comp.lisp
@@ -86,10 +86,10 @@
 (defun Comp-2 (args &aux name type argl bodyl junk)
     (dsetq (NAME (TYPE ARGL . BODYL) . JUNK) args)
     (cond (JUNK (MOAN (format nil "******pren error in (~S (~S ...) ...)" NAME TYPE)))
-          ((eq TYPE 'SLAM) (COMP-SLAM NAME ARGL BODYL))
+          ((eq TYPE 'SLAM) (|backendCompileSLAM| NAME ARGL BODYL))
           ((LASSQ NAME |$clamList|) (|compClam| NAME ARGL BODYL |$clamList|))
-          ((eq TYPE 'SPADSLAM) (COMP-SPADSLAM NAME ARGL BODYL))
-          ((eq TYPE 'ILAM) (COMP-ILAM NAME ARGL BODYL))
+          ((eq TYPE 'SPADSLAM) (|backendCompileSPADSLAM| NAME ARGL BODYL))
+          ((eq TYPE 'ILAM) (|backendCompileILAM| NAME ARGL BODYL))
           ((setq BODYL (LIST NAME (CONS TYPE (CONS ARGL BODYL))))
            (if |$PrettyPrint| (pprint bodyl))
            (if (null $COMPILE) (SAY "No Compilation")
@@ -99,81 +99,6 @@
 ;; used to be called POSN - but that interfered with a CCL function
 (DEFUN POSN1 (X L) (position x l :test #'equal))
 
-(DEFUN COMP-ILAM (NAME ARGL BODYL)
-  (let* ((FARGL (NLIST (LENGTH ARGL) '(GENSYM)))
-         (BODYLP (SUBLISLIS FARGL ARGL BODYL)))
-        (MAKEPROP NAME 'ILAM T)
-        (SET NAME (CONS 'LAMBDA (CONS FARGL BODYLP)))
-        NAME))
-
-(DEFUN COMP-SPADSLAM (NAME ARGL BODYL)
-  (let* ((AL (INTERNL NAME ";AL"))
-         (AUXFN (INTERNL NAME ";"))
-         (G1 (GENSYM))
-         (G2 (GENSYM))
-         (U (COND ((NOT ARGL) (LIST NIL NIL (LIST AUXFN)))
-                  ((NOT (CDR ARGL))
-                   (LIST (LIST G1) (LIST '|devaluate| G1) (LIST AUXFN G1)))
-                  ((LIST G1
-                         (LIST '|devaluateList| G1)
-                         (LIST 'APPLY (LIST 'FUNCTION AUXFN) G1)))))
-         (ARG (first U))
-         (ARGTRAN (second U))
-         (APP (third U))
-         (LAMEX  `(lam ,ARG
-                       (let (,g2)
-                         (cond ,(COND (ARGL `((setq ,g2 (|assoc| ,argtran ,al))
-                                              (cdr ,g2)))
-                                      ((LIST AL)))
-                               ,(COND (ARGL
-                                       `(t(setq ,al(|cons5|(cons ,argtran
-                                                                 (setq ,g2 ,app))
-                                                           ,al))
-                                          ,g2))
-                                      (`(t (setq ,al ,app)))))))))
-    (setandfile AL NIL)
-    (setq U (LIST NAME LAMEX))
-    (if |$PrettyPrint| (PRETTYPRINT U))
-    (COMP370 (LIST U))
-    (setq U (LIST AUXFN (CONS 'LAMBDA (CONS ARGL BODYL))))
-    (COND (|$PrettyPrint| (PRETTYPRINT U)))
-    (COMP370 (LIST U))
-    NAME))
-
-(DEFUN COMP-SLAM (NAME ARGL BODYL)
-  (let* ((AL (INTERNL NAME ";AL"))
-         (AUXFN (INTERNL NAME ";"))
-         (G1 (GENSYM))
-         (G2 (GENSYM))
-         (U (COND ((NOT ARGL) `(nil (,auxfn)))
-                  ((NOT (CDR ARGL)) `((,g1)(,auxfn ,g1)))
-                  (`(,g1 (applx (function ,auxfn) ,g1)))))
-         (ARG (CAR U))
-         (APP (CADR U))
-         (LAMEX
-           (LIST 'LAM ARG
-                 (LIST 'PROG (LIST G2)
-                       (LIST 'RETURN
-                             (LIST 'COND
-                                   (COND (ARGL
-                                          `((setq ,G2 (|assoc| ,G1 ,AL))
-                                            (CDR ,G2)))
-                                         ((LIST AL)))
-                                   (COND (ARGL (LIST ''T `(setq ,G2 ,APP)
-                                                     (LIST 'SETQ AL
-                                                           `(CONS
-                                                              (CONS ,G1 ,G2) ,AL))
-                                                     G2))
-                                         ((LIST ''T `(setq ,AL ,APP))))))))))
-    (set AL NIL)
-    (setq U (LIST NAME LAMEX))
-    (if |$PrettyPrint| (PRETTYPRINT U))
-    (COMP370 (LIST U))
-    (setq U (LIST AUXFN (CONS 'LAMBDA (CONS ARGL BODYL))))
-    (if |$PrettyPrint| (PRETTYPRINT U))
-    (COMP370 (LIST U))
-    NAME))
-
 (DEFUN COMP-NEWNAM (X)
   (let (y u)
     (cond ((ATOM X) NIL)
@@ -192,7 +117,7 @@
 
 (DEFUN COMP-TRAN (X)
   "SEXPR<FN. BODY> -> SEXPR"
-  (let ((X (COMP-EXPAND X)) FluidVars LocVars SpecialVars)
+  (let ((X (|middleEndExpand| X)) FluidVars LocVars SpecialVars)
     (COMP-TRAN-1 (CDDR X))
     (setq X (list (first x) (second x)
                   (if (and (null (cdddr x))
@@ -250,25 +175,6 @@
               (RETURN X))
             ('T (RETURN (CONS A B)) )) )    )))
 
-; NOTE: It is potentially dangerous to assume every occurrence of element of
-; $COMP-MACROLIST is actually a macro call
-
-(defparameter $COMP-MACROLIST
-  '(COLLECT REPEAT SUCHTHATCLAUSE THETA COLLECTV COLLECTVEC
-            THETA1 SPADREDUCE SPADDO)
-  "???")
-
-(DEFUN COMP-EXPAND (X)
-  (COND ((atom x) x)
-        ((eq (CAR X) 'QUOTE) X)
-        ((memq (CAR X) $COMP-MACROLIST)
-         (comp-expand (macroexpand-1 x)))
-        ((let ((a (comp-expand (car x)))
-               (b (comp-expand (cdr x))))
-           (if (AND (eq A (CAR X)) (eq B (CDR X)))
-               x
-               (CONS A B))))))
-
 (DEFUN COMP-TRAN-1 (X)
   (let (u)
     (cond ((ATOM X) NIL)