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

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

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

8 files changed, 78 insertions, 50 deletions

diff --git a/sucl/basic.icl b/sucl/basic.icl
index bd01b2a..aa90104 100644
--- a/sucl/basic.icl
+++ b/sucl/basic.icl
@@ -314,4 +314,4 @@ zipwith f xs ys = [f x y \\ x<-xs & y<-ys]
 (writeList) infixl :: !*File [a] -> .File | <<< a
 (writeList) file [] = file
 (writeList) file [x:xs]
-= file <<< x writeList xs
+= file <<< x <<< nl writeList xs
diff --git a/sucl/canon.icl b/sucl/canon.icl
index 95b57a3..cf87b70 100644
--- a/sucl/canon.icl
+++ b/sucl/canon.icl
@@ -114,9 +114,9 @@ localheap =: [0..]
 
 foldarea :: ((Rgraph sym var) -> sym) (Rgraph sym var) -> Node sym var | == var
 foldarea label rgraph
- = ((id (labelrgraph,foldsingleton single nosingle rgraph)) <--- "canon.foldarea ends") ---> "canon.foldarea begins"
-   where single root sym args = args
-         nosingle = snd (graphvars (rgraphgraph rgraph) [rgraphroot rgraph])
+ = (((labelrgraph<---"canon.foldarea.labelrgraph begins")--->"canon.foldarea.labelrgraph ends",(foldsingleton single nosingle rgraph<---"canon.foldarea.foldsingleton ends")--->"canon.foldarea.foldsingleton begins") <--- "canon.foldarea ends") ---> "canon.foldarea begins"
+   where single root sym args = map (\arg->(arg<---"newfold.foldarea.single.arg begins")--->"newfold.foldarea.single.arg ends") args
+         nosingle = map (\arg->(arg<---"newfold.foldarea.nosingle.arg begins")--->"newfold.foldarea.nosingle.arg ends") (snd (graphvars (rgraphgraph rgraph) [rgraphroot rgraph]))
          labelrgraph = (label rgraph <--- "canon.foldarea.labelrgraph ends") ---> "canon.foldarea.labelrgraph begins"
 
 /*
diff --git a/sucl/cli.icl b/sucl/cli.icl
index a992b00..faa1a4b 100644
--- a/sucl/cli.icl
+++ b/sucl/cli.icl
@@ -105,7 +105,7 @@ Abstype implementation.
 >        stripexports :: [char] -> cli -> cli
 */
 
-:: Cli :== Module SuclSymbol SuclVariable SuclTypeSymbol SuclTypeVariable
+:: Cli = CliAlias (Module SuclSymbol SuclVariable SuclTypeSymbol SuclTypeVariable)
 
 /*
 >   cli == module symbol node typesymbol typenode
@@ -121,14 +121,14 @@ Abstype implementation.
 */
 
 exports :: Cli -> [SuclSymbol]
-exports m = m.exportedsymbols
+exports (CliAlias m) = m.exportedsymbols
 
 /*
 >   typerule (tdefs,(es,as,ts,rs)) = maxtyperule ts
 */
 
 typerule :: Cli SuclSymbol -> Rule SuclTypeSymbol SuclTypeVariable
-typerule m sym
+typerule (CliAlias m) sym
 = maxtyperule m.typerules sym
 
 /*
@@ -153,7 +153,7 @@ typerule m sym
 */
 
 clistrategy :: Cli ((Graph SuclSymbol SuclVariable) SuclVariable var -> Bool) -> Strategy SuclSymbol var SuclVariable answer | == var
-clistrategy {arities=as,typeconstructors=tcs,typerules=ts,rules=rs} matchable
+clistrategy (CliAlias {arities=as,typeconstructors=tcs,typerules=ts,rules=rs}) matchable
  = ( checkarity (extendfn as (typearity o maxtyperule ts))        // Checks curried occurrences and strict arguments
    o checklaws cleanlaws                            // Checks for special (hard coded) rules (+x0=x /y1=y ...)
    o checkrules matchable (foldmap id [] rs)        // Checks normal rewrite rules
@@ -182,7 +182,7 @@ maxstricts defs sym = extendfn defs corestricts sym
 */
 
 complete :: Cli -> [SuclSymbol] -> Bool
-complete m = mkclicomplete m.typeconstructors (maxtyperule m.typerules)
+complete (CliAlias m) = mkclicomplete m.typeconstructors (maxtyperule m.typerules)
 
 /*
 >   showcli = printcli
@@ -326,10 +326,20 @@ mkcli ::
  -> Cli
 
 mkcli typerules stricts exports constrs bodies
-= { arities          = map (mapsnd fst) bodies
+= CliAlias
+  { arities          = map (mapsnd fst) bodies
   , typeconstructors = constrs
   , exportedsymbols  = exports
   , typerules        = typerules
   , stricts          = stricts
   , rules            = map (mapsnd snd) bodies
   }
+
+instance <<< Cli
+where (<<<) file (CliAlias m)
+      = file <<< "=== Arities ===" <<< nl
+             writeList m.arities
+             <<< "=== Type Rules ===" <<< nl
+             writeList m.typerules
+             <<< "=== Rules ===" <<< nl
+             writeList m.rules
diff --git a/sucl/graph.icl b/sucl/graph.icl
index 02362f1..2021826 100644
--- a/sucl/graph.icl
+++ b/sucl/graph.icl
@@ -97,20 +97,20 @@ varcontents (GraphAlias pfun) v
 
 graphvars :: .(Graph sym var) !.[var] -> (.[var],.[var]) | == var
 graphvars graph roots
-= graphvars` [] graph roots
+= (graphvars` [] graph roots<---"graph.graphvars ends")--->"graph.graphvars begins"
 
 // Finds bound and free variables in a graph
 // Excludes the variables only reachable through "prune"
 graphvars` :: .[var] .(Graph sym var) .[var] -> (.[var],.[var]) | == var
 graphvars` prune graph roots
-= snd (foldlr ns (prune,([],[])) roots)
-  where ns var (seen,boundfree=:(bound,free))
-        | isMember var seen = (seen,boundfree)
-        | not def           = ([var:seen],(bound,[var:free]))
-                            = (seen`,([var:bound`],free`))
-          where (seen`,(bound`,free`)) = foldlr ns ([var:seen],boundfree) args
+= (snd (foldlr (ns--->"graph.graphvars`.ns begins from graph.graphvars`") (prune,([],[])) roots)<---"graph.graphvars` ends")--->"graph.graphvars` begins"
+  where ns var seenboundfree
+        | isMember var seen = seenboundfree<---"graph.graphvars`.ns ends (already seen)"
+        | not def           = ([var:seen],(bound,[var:free]))<---"graph.graphvars`.ns ends (open variable)"
+                            = (seen`,([var:bound`],free`))<---"graph.graphvars`.ns ends (closed variable)"
+          where (seen`,(bound`,free`)) = foldlr (ns--->"graph.graphvars`.ns begins from graph.graphvars`.ns") ([var:seen],boundfree) args
                 (def,(_,args)) = varcontents graph var
-
+                (seen,boundfree=:(bound,free)) = seenboundfree
 varlist :: .(Graph sym var) !.[var] -> .[var] | == var
 varlist graph roots
 = depthfirst arguments id roots
diff --git a/sucl/loop.dcl b/sucl/loop.dcl
index d49c0d4..cdc6fc1 100644
--- a/sucl/loop.dcl
+++ b/sucl/loop.dcl
@@ -9,6 +9,8 @@ from history import HistoryAssociation,HistoryPattern
 from rule import Rgraph,Rule
 from graph import Graph
 from StdOverloaded import ==
+from StdFile import <<<
+from StdString import toString
 
 from strat import Substrategy,Subspine   // for Strategy
 from trace import History,Transformation // for Trace
@@ -24,6 +26,9 @@ loop
  |  == sym
  &  == var
  &  == pvar
+ &  toString sym    // Debugging
+ &  toString var    // Debugging
+ &  <<< var         // Debugging
 
 initrule
  :: ![var]
diff --git a/sucl/loop.icl b/sucl/loop.icl
index f8674c3..50b6021 100644
--- a/sucl/loop.icl
+++ b/sucl/loop.icl
@@ -11,7 +11,7 @@ import rule
 import graph
 import pfun
 import basic
-from general import Yes,No,--->
+from general import Yes,No
 import StdEnv
 
 /*
@@ -224,11 +224,14 @@ loop
  |  == sym
  &  == var
  &  == pvar
+ &  toString sym    // Debugging
+ &  toString var    // Debugging
+ &  <<< var         // Debugging
 
 loop strategy matchable (initheap,rule)
-= maketrace inithistory initfailinfo initinstdone initstricts initsroot initsubject initheap
-
-  where maketrace history failinfo instdone stricts sroot subject heap
+= result
+  where result = maketrace inithistory initfailinfo initinstdone initstricts initsroot initsubject initheap
+        maketrace history failinfo instdone stricts sroot subject heap
         = Trace stricts (mkrule sargs sroot subject) answer history transf
           where answer = makernfstrategy history (strategy matchable`) rnfnodes sroot subject
                 transf = transform sroot sargs answer maketrace history failinfo instdone stricts sroot subject heap
diff --git a/sucl/newfold.icl b/sucl/newfold.icl
index a654f5a..a9b9f48 100644
--- a/sucl/newfold.icl
+++ b/sucl/newfold.icl
@@ -110,6 +110,9 @@ fullfold ::
  |  == sym
  &  == var
  &  == pvar
+ &  toString var
+ &  <<< var
+ &  toString sym
 
 fullfold trc foldarea fnsymbol trace
 | recursive ---> "newfold.fullfold begins"
@@ -137,30 +140,36 @@ recurse ::
  |  == sym
  &  == var
  &  == pvar
+ &  toString var
+ &  <<< var
+ &  toString sym
 
 recurse foldarea fnsymbol
-= (f ([],[]) <--- "newfold.recurse ends") ---> "newfold.recurse begins"
-  where f newhisthist (Trace stricts rule answer history (Reduce reductroot trace))
-        | isEmpty pclosed && superset popen ropen
-          = f (newhist`,newhist`) trace
+= ((f--->"newfold.recurse.f begins from newfold.recurse") ([],[]) <--- "newfold.recurse ends") ---> "newfold.recurse begins"
+  where f newhisthist trace
+        | (trace--->trace) $ False
+          = error "shouldn't happen"
+        f newhisthist (Trace stricts rule answer history (Reduce reductroot trace))
+        | (isEmpty (pclosed--->"pclosed for isEmpty")--->"f: Reduce: isEmpty?") && (superset (popen--->"popen for superset") (ropen--->"ropen for superset")--->"f: Reduce: superset?")
+          = ((f--->"newfold.recurse.f begins (from Reduce)") (newhist`,newhist`) trace <--- "newfold.recurse.f ends (valid Reduce)") ---> "f: Reduce"
             where rargs = arguments rule; rroot = ruleroot rule; rgraph = rulegraph rule
-                  (pclosed,popen) = graphvars rgraph rargs
-                  (_,ropen) = graphvars rgraph [rroot]
-                  newhist` = [(rroot,rgraph):newhist]
-                  (newhist,hist) = newhisthist
+                  (pclosed,popen) = graphvars (rgraph--->"rgraph for (pclosed,popen)") (rargs--->"rargs for (pclosed,popen)") ---> "get (pclosed,popen)"
+                  (_,ropen) = graphvars (rgraph--->"rgraph for ropen") [rroot--->"rroot for ropen"] ---> "get ropen"
+                  newhist` = [(rroot,rgraph):newhist--->"newhist"]
+                  (newhist,hist) = newhisthist ---> "get (newhist,hist)"
         f newhisthist (Trace stricts rule answer history (Annotate trace))
         | isEmpty pclosed && superset popen ropen
-          = f (newhist`,hist) trace
+          = ((f--->"newfold.recurse.f begins (from Annotate)") (newhist`,hist) trace <--- "newfold.recurse.f ends (valid Annotate)") ---> "f: Annotate"
             where rargs = arguments rule; rroot = ruleroot rule; rgraph = rulegraph rule
-                  (pclosed,popen) = graphvars rgraph rargs
-                  (_,ropen) = graphvars rgraph [rroot]
+                  (pclosed,popen) = graphvars rgraph rargs ---> "get (pclosed,popen)"
+                  (_,ropen) = graphvars rgraph [rroot] ---> "get ropen"
                   newhist` = [(rroot,rgraph):newhist]
-                  (newhist,hist) = newhisthist
+                  (newhist,hist) = newhisthist ---> "get (newhist,hist)"
         f newhisthist (Trace stricts rule answer history transf)
-        = foldtips foldarea (fnsymbol,arguments rule) (removeDup newhist`,removeDup hist) (Trace stricts rule answer history transf)
+        = ((foldtips--->"newfold.foldtips begins from newfold.recurse") foldarea (fnsymbol,arguments rule) (removeDup newhist`,removeDup hist) (Trace stricts rule answer history transf) <--- "newfold.recurse.f ends (other transformation)") ---> "f: default"
           where rroot = ruleroot rule; rgraph = rulegraph rule
                 newhist` = [(rroot,rgraph):newhist]
-                (newhist,hist) = newhisthist
+                (newhist,hist) = newhisthist ---> "get (newhist,hist)"
 
 
 /*
@@ -182,26 +191,26 @@ foldtips ::
  &  == pvar
 
 foldtips foldarea foldcont
-= ft
+= (ft--->"newfold.foldtips.ft begins from foldtips")<---"newfold.foldtips ends"
   where ft hist trace
         = case transf
           of Stop
-              -> foldoptional exres (pair True o addstrict stricts o mapfst rule2body) (actualfold deltanodes rnfnodes foldarea (==) foldcont (snd hist) rule)
+              -> foldoptional exres (pair True o addstrict stricts o mapfst rule2body) (actualfold deltanodes rnfnodes foldarea (==) foldcont (snd hist) rule) <--- "newfold.foldtips.ft ends (Stop)"
                  where deltanodes = foldoptional [] getdeltanodes answer
                        rnfnodes = foldoptional [ruleroot rule] (const []) answer
              Instantiate yestrace notrace
-              -> ft` (ft hist yestrace) (ft hist notrace)
-                 where ft` (False,yessra) (False,nosra) = exres
+              -> ft` ((ft--->"newfold.foldtips.ft begins from newfold.foldtips.ft.Instantiate.match") hist yestrace) ((ft--->"newfold.foldtips.ft begins from newfold.foldtips.ft.Instantiate.fail") hist notrace)
+                 where ft` (False,yessra) (False,nosra) = exres <--- "newfold.foldtips.ft ends (Instantiate/no)"
                        ft` (yesfound,(yesstricts,yesbody,yesareas)) (nofound,(nostricts,nobody,noareas))
-                       = (True,(stricts,matchpattern answer yesbody nobody,yesareas++noareas))
+                       = (True,(stricts,matchpattern answer yesbody nobody,yesareas++noareas)) <--- "newfold.foldtips.ft ends (Instantiate/yes)"
              Reduce reductroot trace
-              -> ft` (ft (fst hist,fst hist) trace)
-                 where ft` (False,sra) = exres
-                       ft` (found,sra) = (True,sra)
+              -> ft` ((ft--->"newfold.foldtips.ft begins from newfold.foldtips.ft.Reduce") (fst hist,fst hist) trace)
+                 where ft` (False,sra) = exres <--- "newfold.foldtips.ft ends (Reduce/no)"
+                       ft` (found,sra) = (True,sra) <--- "newfold.foldtips.ft ends (Reduce/yes)"
              Annotate trace
-              -> ft` (ft hist trace)
-                 where ft` (False,sra) = exres
-                       ft` (found,sra) = (True,sra)
+              -> ft` ((ft--->"newfold.foldtips.ft begins from newfold.foldtips.ft.Annotate") hist trace)
+                 where ft` (False,sra) = exres <--- "newfold.foldtips.ft ends (Annotate/no)"
+                       ft` (found,sra) = (True,sra) <--- "newfold.foldtips.ft ends (Annotate/yes)"
           where (Trace stricts rule answer _ transf) = trace
                 exres = (False,newextract noetrc foldarea trace)
 
diff --git a/sucl/newtest.icl b/sucl/newtest.icl
index d9a7087..13fe716 100644
--- a/sucl/newtest.icl
+++ b/sucl/newtest.icl
@@ -174,9 +174,10 @@ where (<<<) file srr
              <<< "Task expression: " <<< ((srr.srr_task_expression <--- "newtest.<<<(Symredresult).srr_task_expression ends") ---> "newtest.<<<(Symredresult).srr_task_expression begins") <<< nl
              <<< "Assigned symbol: " <<< toString (srr.srr_assigned_symbol) <<< nl
              <<< "Strictness: " <<< srr.srr_strictness <<< nl
-             <<< "Type rule: ..." <<< nl
+             //<<< "Type rule: ..." <<< nl
              <<< srr.srr_trace <<< nl
-             //<<< "Function definition: ..." <<< nl
+             //<<< "Function definition:" <<< nl
+             //<<< srr.srr_function_def
              <<< "Areas:" <<< nl
              writeareas srr.srr_areas
              <<< "==[END]==" <<< nl
@@ -307,7 +308,7 @@ fullsymred freshsymbols cli
          generate result = (map canonise` (getareas result) <--- "newtest.fullsymred.generate begins") ---> "newtest.fullsymred.generate begins"
          process area = (symredarea foldarea` cli area <--- "newtest.fullsymred.process ends") ---> "newtest.fullsymred.process begins"
 
-         foldarea` = ((id (foldarea (labelarea` o canonise`))) <--- "newtest.fullsymred.foldarea` ends") ---> "newtest.fullsymred.foldarea` begins"
+         foldarea` = ((foldarea (labelarea` o canonise`)) <--- "newtest.fullsymred.foldarea` ends") ---> "newtest.fullsymred.foldarea` begins"
          labelarea` = (labelarea (map getinit results) freshsymbols <--- "newtest.fullsymred.labelarea` ends") ---> "newtest.fullsymred.labelarea` begins"
          canonise` = (canonise (typerule cli) suclheap <--- "newtest.fullsymred.canonise` ends") ---> "newtest.fullsymred.canonise` begins"