This commit was generated by cvs2svn to compensate for changes in r616,

which included commits to RCS files with non-trunk default branches.

git-svn-id: https://svn.cs.ru.nl/repos/clean-compiler/trunk@617 1f8540f1-abd5-4d5b-9d24-4c5ce8603e2d

12 files changed, 184 insertions, 32 deletions

diff --git a/sucl/Makefile b/sucl/Makefile
index 7732f75..79dd004 100644
--- a/sucl/Makefile
+++ b/sucl/Makefile
@@ -27,17 +27,21 @@ $(SYS)/%.abc: %.icl
 
 $(SYS)/supercompile.abc: supercompile.icl supercompile.dcl convert.dcl
 $(SYS)/convert.abc: convert.icl convert.dcl coreclean.dcl rule.dcl graph.dcl basic.dcl
-$(SYS)/cli.abc: cli.icl cli.dcl absmodule.dcl coreclean.dcl law.dcl strat.dcl rule.dcl basic.dcl
-$(SYS)/coreclean.abc: coreclean.icl coreclean.dcl strat.dcl spine.dcl rule.dcl graph.dcl
-$(SYS)/law.abc: law.icl law.dcl coreclean.dcl strat.dcl spine.dcl rule.dcl graph.dcl dnc.dcl basic.dcl
-$(SYS)/loop.abc: loop.icl loop.dcl trace.dcl strat.dcl history.dcl rule.dcl graph.dcl basic.dcl
-$(SYS)/strat.abc: strat.icl strat.dcl history.dcl spine.dcl dnc.dcl rule.dcl graph.dcl pfun.dcl basic.dcl
-$(SYS)/history.abc: history.icl history.dcl spine.dcl rule.dcl graph.dcl basic.dcl
-$(SYS)/spine.abc: spine.icl spine.dcl rule.dcl pfun.dcl basic.dcl
+$(SYS)/newtest.abc: newtest.icl newtest.dcl newfold.dcl cli.dcl canon.dcl coreclean.dcl loop.dcl trace.dcl spine.dcl history.dcl complete.dcl trd.dcl rule.dcl graph.dcl basic.dcl
+$(SYS)/newfold.abc: newfold.icl newfold.dcl trace.dcl spine.dcl history.dcl rule.dcl
+$(SYS)/extract.abc: extract.icl extract.dcl 
+$(SYS)/cli.abc: cli.icl cli.dcl law.dcl coreclean.dcl strat.dcl absmodule.dcl rule.dcl dnc.dcl graph.dcl basic.dcl
+$(SYS)/canon.abc: canon.icl canon.dcl rule.dcl graph.dcl basic.dcl
+$(SYS)/law.abc: law.icl law.dcl coreclean.dcl strat.dcl spine.dcl rule.dcl dnc.dcl graph.dcl basic.dcl
+$(SYS)/coreclean.abc: coreclean.icl coreclean.dcl strat.dcl spine.dcl rule.dcl graph.dcl basic.dcl
+$(SYS)/loop.abc: loop.icl loop.dcl strat.dcl trace.dcl spine.dcl history.dcl rewr.dcl rule.dcl graph.dcl pfun.dcl basic.dcl
+$(SYS)/strat.abc: strat.icl strat.dcl spine.dcl history.dcl rule.dcl dnc.dcl graph.dcl pfun.dcl basic.dcl
 $(SYS)/absmodule.abc: absmodule.icl absmodule.dcl rule.dcl
-$(SYS)/trace.abc: trace.icl trace.dcl rule.dcl
+$(SYS)/trace.abc: trace.icl trace.dcl spine.dcl history.dcl rule.dcl basic.dcl
+$(SYS)/spine.abc: spine.icl spine.dcl history.dcl rule.dcl graph.dcl pfun.dcl basic.dcl
+$(SYS)/history.abc: history.icl history.dcl rule.dcl graph.dcl pfun.dcl basic.dcl
 $(SYS)/complete.abc: complete.icl complete.dcl graph.dcl
-$(SYS)/rewr.abc: rewr.icl rewr.dcl graph.dcl pfun.dcl basic.dcl
+$(SYS)/rewr.abc: rewr.icl rewr.dcl rule.dcl graph.dcl pfun.dcl basic.dcl
 $(SYS)/trd.abc: trd.icl trd.dcl rule.dcl graph.dcl basic.dcl
 $(SYS)/rule.abc: rule.icl rule.dcl graph.dcl basic.dcl
 $(SYS)/dnc.abc: dnc.icl dnc.dcl graph.dcl
diff --git a/sucl/cli.icl b/sucl/cli.icl
index 5ce09a6..0f2d2c9 100644
--- a/sucl/cli.icl
+++ b/sucl/cli.icl
@@ -2,11 +2,12 @@ implementation module cli
 
 // $Id$
 
-import absmodule
-import coreclean
 import law
+import coreclean
 import strat
+import absmodule
 import rule
+import dnc
 import basic
 import StdEnv
 
@@ -117,12 +118,18 @@ Abstype implementation.
 >   stripexports main (tdefs,(es,as,ts,rs)) = (tdefs,([User m i|User m i<-es;m=main],as,ts,rs))
 
 >   exports (tdefs,(es,as,ts,rs)) = es
+*/
+
+exports :: Cli -> [SuclSymbol]
+exports m = m.exportedsymbols
 
+/*
 >   typerule (tdefs,(es,as,ts,rs)) = fst.maxtypeinfo ts
 */
 
 typerule :: Cli SuclSymbol -> Rule SuclTypeSymbol SuclTypeVariable
-typerule _ _ = undef
+typerule m sym
+= fst (maxtypeinfo m.typerules sym)
 
 /*
 >   rules (tdefs,(es,as,ts,rs)) = foldmap Present Absent rs
@@ -166,7 +173,12 @@ maxtypeinfo defs sym = extendfn defs coretypeinfo sym
 >   constrs ((tes,tas,tcs),defs) = tcs
 
 >   complete ((tes,tas,tcs),(es,as,ts,rs)) = mkclicomplete tcs (fst.maxtypeinfo ts)
+*/
+
+complete :: Cli -> [SuclSymbol] -> Bool
+complete m = mkclicomplete m.typeconstructors (fst o maxtypeinfo m.typerules)
 
+/*
 >   showcli = printcli
 
 >   mkclicomplete
@@ -181,7 +193,24 @@ maxtypeinfo defs sym = extendfn defs coretypeinfo sym
 >   =   foldmap superset (corecomplete tsym) tcs tsym syms, otherwise
 >       where trule = typerule (hd syms)
 >             (tdef,(tsym,targs)) = dnc (const "in mkclicomplete") (rulegraph trule) (rhs trule)
+*/
+
+mkclicomplete ::
+    [(SuclTypeSymbol,[SuclSymbol])]
+    (SuclSymbol->Rule SuclTypeSymbol tvar)
+    [SuclSymbol]
+ -> Bool
+ |  == tvar
+
+mkclicomplete tcs typerule [] = False
+mkclicomplete tcs typerule syms
+| not tdef
+  = False
+= foldmap superset (corecomplete tsym) tcs tsym syms
+  where trule = typerule (hd syms)
+        (tdef,(tsym,_)) = dnc (const "in mkclicomplete") (rulegraph trule) (ruleroot trule)
 
+/*
 ------------------------------------------------------------------------
 
 >   printcli :: module symbol node typesymbol typenode -> [char]
diff --git a/sucl/history.icl b/sucl/history.icl
index 4ece980..a8d7c66 100644
--- a/sucl/history.icl
+++ b/sucl/history.icl
@@ -2,7 +2,6 @@ implementation module history
 
 // $Id$
 
-import spine
 import rule
 import graph
 import pfun
diff --git a/sucl/law.icl b/sucl/law.icl
index 1f14ee4..8ec781a 100644
--- a/sucl/law.icl
+++ b/sucl/law.icl
@@ -6,8 +6,8 @@ import coreclean
 import strat
 import spine
 import rule
-import graph
 import dnc
+import graph
 import basic
 import StdEnv
 
diff --git a/sucl/loop.dcl b/sucl/loop.dcl
index 2fcbe3f..d49c0d4 100644
--- a/sucl/loop.dcl
+++ b/sucl/loop.dcl
@@ -3,18 +3,18 @@ definition module loop
 // $Id$
 
 from strat import Strategy
-from spine import Answer
 from trace import Trace
+from spine import Answer
 from history import HistoryAssociation,HistoryPattern
 from rule import Rgraph,Rule
 from graph import Graph
 from StdOverloaded import ==
 
 from strat import Substrategy,Subspine   // for Strategy
+from trace import History,Transformation // for Trace
+from spine import Spine                  // for Answer
 from graph import Node                   // for Strategy
 from basic import Optional               // for Answer
-from spine import Spine                  // for Answer
-from trace import History,Transformation // for Trace
 
 loop
  :: (((Graph sym pvar) pvar var -> ub:Bool) -> Strategy sym var pvar (Answer sym var pvar))
diff --git a/sucl/loop.icl b/sucl/loop.icl
index 85d1233..ef750e5 100644
--- a/sucl/loop.icl
+++ b/sucl/loop.icl
@@ -2,10 +2,10 @@ implementation module loop
 
 // $Id$
 
-import trace
 import strat
-import history
+import trace
 import spine
+import history
 import rewr
 import rule
 import graph
@@ -245,7 +245,9 @@ loop strategy matchable (initheap,rule)
         sargs = arguments rule; initsroot = ruleroot rule; initsubject = rulegraph rule
 
 listselect :: [.Bool] [.elem] -> [.elem]
-listselect _ _ = undef
+listselect [True:bs] [x:xs] = [x:listselect bs xs]
+listselect [False:bs] [x:xs] = listselect bs xs
+listselect _ _ = []
 
 initrule
  :: ![var]
diff --git a/sucl/newfold.icl b/sucl/newfold.icl
index 6958f4b..31d5a79 100644
--- a/sucl/newfold.icl
+++ b/sucl/newfold.icl
@@ -2,6 +2,10 @@ implementation module newfold
 
 // $Id$
 
+import trace
+import rule
+import StdEnv
+
 /*
 
 newfold.lit - New folding function
@@ -86,8 +90,25 @@ occurs within any subtrace.
 >|| =   mapfst3 only (extract trc foldarea trace ([],[],[])), otherwise
 >   =   newextract trc foldarea trace, otherwise
 >       where (recursive,recurseresult) = recurse foldarea fnsymbol trace
+*/
+
+fullfold ::
+    (Etracer sym var pvar)
+    ((Rgraph sym var)->(sym,[var]))
+    sym
+    (Trace sym var pvar)
+ -> ([Bool],[Rule sym var],[Rgraph sym var])
+
+fullfold trc foldarea fnsymbol trace
+| recursive
+  = recurseresult
+= newextract trc foldarea trace
+  where (recursive,recurseresult) = recurse foldarea fnsymbol trace
 
+recurse = undef
+newextract = undef
 
+/*
 `Recurse foldarea fnsymbol trace' is a pair `(recursive,recurseresult)'.
 `Recurseresult'  is  the derived function definition (strictness, rules,
 and new areas), obtained by folding the trace.  `Recurse' tries to  fold
@@ -193,7 +214,15 @@ in the supertrace.
 >       rgraph * ** ->
 >       bool ->
 >       bool
+*/
 
+:: Etracer sym var pvar :==
+       (Trace sym var pvar)
+       (Rgraph sym var)
+       Bool
+    -> Bool
+
+/*
 >   extract
 >   ::  etracer * ** *** ->
 >       (rgraph * **->(*,[**])) ->
diff --git a/sucl/newtest.icl b/sucl/newtest.icl
index 9b65610..7c9e4bb 100644
--- a/sucl/newtest.icl
+++ b/sucl/newtest.icl
@@ -4,6 +4,13 @@ implementation module newtest
 
 import cli
 import coreclean
+import newfold
+import complete
+import trd
+import loop
+import trace
+import rule
+import graph
 import canon
 import basic
 import StdEnv
@@ -138,7 +145,19 @@ these tuples.
 >           [rule * **],      ||  Resulting rewrite rules
 >           [rgraph * **]     ||  New areas for further symbolic reduction (not necessarily canonical)
 >       )
+*/
+
+:: Symredresult sym var tsym tvar
+   :== ( Rgraph sym var    // The initial area in canonical form
+       , sym               // The assigned symbol
+       , [Bool]            // Strictness annotations
+       , Rule tsym tvar    // Type rule
+       , Trace sym var var // Truncated and folded trace
+       , [Rule sym var]    // Resulting rewrite rules
+       , [Rgraph sym var]  // New areas for further symbolic reduction (not necessarily canonical)
+       )
 
+/*
 >   listopt :: [char] -> [[char]] -> [char]
 
 >   listopt main = listnew main.loadclis
@@ -253,7 +272,7 @@ these tuples.
 fullsymred ::
     [SuclSymbol]    // Fresh function symbols
     Cli             // Module to optimise
- -> [Symredresult symbol node typesymbol typenode]
+ -> [Symredresult SuclSymbol SuclVariable SuclTypeSymbol SuclTypeVariable]
 
 fullsymred freshsymbols cli
  = results
@@ -265,11 +284,6 @@ fullsymred freshsymbols cli
          labelarea` = labelarea (map getinit results) freshsymbols
          canonise` = canonise (typerule cli) suclheap
 
-initareas = undef
-getareas = undef
-symredarea = undef
-getinit = undef
-
 /*
 `Initareas cli' is the list  of  initial  rooted  graphs  that  must  be
 symbolically  reduced.  An initial rooted graph is formed by applying an
@@ -290,7 +304,23 @@ its type rule.
 
 >   getareas :: symredresult * ** **** ***** -> [rgraph * **]
 >   getareas (area,symbol,stricts,trule,trace,rules,areas) = areas
+*/
+
+initareas :: Cli -> [Rgraph SuclSymbol SuclVariable]
+initareas cli
+= map (initialise suclheap) (exports cli)
+  where initialise [root:nodes] symbol
+        = mkrgraph root (updategraph root (symbol,args) emptygraph)
+          where args = map2 const nodes targs
+                targs = arguments (typerule cli symbol)
 
+getinit :: (Symredresult sym var tsym tvar) -> Rgraph sym var
+getinit (area,symbol,stricts,trule,trace,rules,areas) = area
+
+getareas :: (Symredresult sym var tsym tvar) -> [Rgraph sym var]
+getareas (area,symbol,stricts,trule,trace,rules,areas) = areas
+
+/*
 `Symredarea' is the function that does symbolic reduction  of  a  single
 area.
 
@@ -311,13 +341,38 @@ area.
 >             complete' = (~).converse matchable' (mkrgraph () emptygraph)
 >             matchable' = matchable (complete cli)
 >             strategy' = clistrategy cli
+*/
+
+:: Unit = Unit
+
+symredarea ::
+    ((Rgraph SuclSymbol SuclVariable)->(SuclSymbol,[SuclVariable]))
+    Cli
+    (Rgraph SuclSymbol SuclVariable)
+ -> Symredresult SuclSymbol SuclVariable SuclTypeSymbol SuclTypeVariable
+
+symredarea foldarea cli area
+= (area,symbol,stricts,trule,trace,rules,areas)
+  where agraph = rgraphgraph area; aroot = rgraphroot area
+        (symbol,aargs) = foldarea area
+        arule = mkrule aargs aroot agraph
+        trule = ruletype sucltypeheap (ctyperule SuclFN sucltypeheap (typerule cli)) arule
+        trace = loop strategy` matchable` (removeMembers suclheap (varlist agraph [aroot]),arule)
+        (stricts,rules,areas) = fullfold (trc symbol) foldarea symbol trace
+        matchable` = matchable (complete cli)
+        strategy` = clistrategy cli
 
+/*
 >   trc :: symbol -> trace symbol node node -> rgraph symbol node -> bool -> bool
 
 >   trc symbol trace area recursive
 >   =   error (lay ("Trace is recursive in area":printrgraph showsymbol shownode area:printtrace symbol showsymbol shownode shownode trace)), if esymbol symbol & recursive
 >   =   recursive, otherwise
+*/
+
+trc symbol trace area recursive = recursive
 
+/*
 >   esymbol (User m "E") = True
 >   esymbol symbol = False
 
@@ -403,7 +458,20 @@ area.
 
 >   matchable complete patterns rgraph
 >   =   ~coveredby complete (rgraphgraph rgraph) [(rgraphgraph pattern,[rgraphroot pattern])|pattern<-patterns] [rgraphroot rgraph]
+*/
+
+matchable ::
+    ([sym]->Bool)
+    [Rgraph sym pvar]
+    (Rgraph sym var)
+ -> Bool
+ |  == sym
+ &  == var
+ &  == pvar
+matchable complete patterns rgraph
+= not (coveredby complete (rgraphgraph rgraph) [(rgraphgraph pattern,[rgraphroot pattern]) \\ pattern<-patterns] [rgraphroot rgraph])
 
+/*
 ------------------------------------------------------------------------
 
 `Ctyperule' cli (sym,args)' is the typerule of an occurrence  of  symbol
@@ -424,7 +492,25 @@ sym with the given arguments, curried if there are too few.
 >             (troot',tgraph',theap') = foldr build (troot,tgraph,typeheap--nodelist tgraph (troot:targs)) targs''
 >             build targ (troot,tgraph,tnode:tnodes)
 >             =   (tnode,updategraph tnode (fn,[targ,troot]) tgraph,tnodes)
+*/
 
->   newsymbols main = map (User main.("New_"++)) identifiers
+ctyperule ::
+    (Int -> tsym)           // The arrow type symbol for functions of given arity
+    [tvar]                  // Fresh type variables
+    (sym->Rule tsym tvar)   // Type rule of a symbol
+    (sym,[var])             // Node to abstract
+ -> Rule tsym tvar
+ |  == tvar
+
+ctyperule fn typeheap typerule (sym,args)
+= mkrule targs` troot` tgraph`
+  where targs = arguments trule; troot = ruleroot trule; tgraph = rulegraph trule
+        trule = typerule sym
+        (targs`,targs``) = claim args targs
+        (troot`,tgraph`,_) = foldr build (troot,tgraph,removeMembers typeheap (varlist tgraph [troot:targs])) targs``
+        build targ (troot,tgraph,[tnode:tnodes])
+        = (tnode,updategraph tnode (fn 1,[targ,troot]) tgraph,tnodes)
 
+/*
+>   newsymbols main = map (User main.("New_"++)) identifiers
 */
diff --git a/sucl/strat.dcl b/sucl/strat.dcl
index 01589e0..1123a78 100644
--- a/sucl/strat.dcl
+++ b/sucl/strat.dcl
@@ -2,8 +2,8 @@ definition module strat
 
 // $Id$
 
-from history import History
 from spine import Answer
+from history import History
 from rule import Rule
 from graph import Graph,Node
 from StdOverloaded import ==
diff --git a/sucl/strat.icl b/sucl/strat.icl
index 0f938b8..04ea9f9 100644
--- a/sucl/strat.icl
+++ b/sucl/strat.icl
@@ -2,10 +2,10 @@ implementation module strat
 
 // $Id$
 
-import history
 import spine
-import dnc
+import history
 import rule
+import dnc
 import graph
 import pfun
 import basic
diff --git a/sucl/trace.dcl b/sucl/trace.dcl
index f8e884d..6aafc88 100644
--- a/sucl/trace.dcl
+++ b/sucl/trace.dcl
@@ -2,9 +2,12 @@ definition module trace
 
 // $Id$
 
-from history import History,HistoryAssociation,HistoryPattern
 from spine import Answer
+from history import History,HistoryAssociation,HistoryPattern
 from rule import Rule
+
+// Transitive necessities
+
 from spine import Spine,Subspine // for Answer
 from rule import Rgraph          // for History
 from basic import Optional       // for Answer
diff --git a/sucl/trace.icl b/sucl/trace.icl
index 7429566..f2ff7b3 100644
--- a/sucl/trace.icl
+++ b/sucl/trace.icl
@@ -2,8 +2,8 @@ implementation module trace
 
 // $Id$
 
-import history
 import spine
+import history
 import rule
 import StdEnv