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

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

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

6 files changed, 14 insertions, 9 deletions

diff --git a/sucl/basic.icl b/sucl/basic.icl
index aa78e19..1322f04 100644
--- a/sucl/basic.icl
+++ b/sucl/basic.icl
@@ -44,10 +44,10 @@ adjust a r f x
 // Claim a list of nodes from a heap
 claim :: ![.param] u:[.cell] -> ([.cell],v:[.cell]), [u<=v]
 
-claim [] heap = ([],heap)
+claim [] heap = ([],heap) <--- "basic.claim ends (with empty result)"
 claim [pnode:pnodes] [snode:heap]
-=   ([snode:snodes],heap`)
-    where (snodes,heap`) = claim pnodes heap
+=   ([snode:snodes],heap`) <--- "basic.claim ends (with nonempty result)"
+    where (snodes,heap`) = (claim--->"basic.claim begins from basic.claim") pnodes heap
 claim pnodes emptyheap = abort "claim: out of heap" // Just in case. Should be used with an infinite heap.
 
 /* Depthfirst collects results of a function (called process), applied to a
diff --git a/sucl/canon.icl b/sucl/canon.icl
index ea491f1..b2d0f98 100644
--- a/sucl/canon.icl
+++ b/sucl/canon.icl
@@ -75,14 +75,14 @@ canonise arity heap rg
 splitrg :: (Rgraph sym Int) -> Rgraph sym Int
 splitrg rgraph
  = foldsingleton single rgraph rgraph
-   where single root sym args = mkrgraph root (updategraph root (sym,fst (claim args (localheap--[root]))) emptygraph)
+   where single root sym args = mkrgraph root (updategraph root (sym,fst ((claim--->"basic.claim begins from canon.splitrg") args (localheap--[root]))) emptygraph)
 
 /*
 >   uncurry :: (*->rule **** *****) -> rgraph * num -> rgraph * num
 >   uncurry typerule rgraph
 >   =   f (nc root)
 >       where f (True,(sym,args))
->             =   mkrgraph root (updategraph root (sym,fst (claim targs (args++localheap--nodelist graph [root]))) graph)
+>             =   mkrgraph root (updategraph root (sym,fst ((claim--->"basic.claim begins from canon.uncurry") targs (args++localheap--nodelist graph [root]))) graph)
 >                 where targs = lhs (typerule sym)
 >             f cont = rgraph
 >             nc = nodecontents graph
diff --git a/sucl/law.icl b/sucl/law.icl
index 8ec781a..ef33b2e 100644
--- a/sucl/law.icl
+++ b/sucl/law.icl
@@ -9,6 +9,7 @@ import rule
 import dnc
 import graph
 import basic
+from general import --->
 import StdEnv
 
 /*
@@ -179,7 +180,7 @@ corestrategy matchable =(\ substrat subject found rnf snode
 applyrule :: (Bool,Node sym var) -> Rule sym SuclVariable
 applyrule (sdef,scont)
  = aprule (anode,(sym,aargs)) [enode] aroot
-   where (aargs,[anode,aroot,enode:_]) = claim sargs suclheap
+   where (aargs,[anode,aroot,enode:_]) = (claim--->"basic.claim begins from law.applyrule") sargs suclheap
          (sym,sargs)
           = if sdef scont (nosym,[])
          nosym = abort "applyrule: no function symbol available"
diff --git a/sucl/loop.icl b/sucl/loop.icl
index 7c13d57..1090a88 100644
--- a/sucl/loop.icl
+++ b/sucl/loop.icl
@@ -267,7 +267,7 @@ initrule
 
 initrule [root:heap] template sym
 = (heap`,mkrule args root (updategraph root (sym,args) emptygraph))
-  where (args,heap`) = claim (template sym) heap
+  where (args,heap`) = (claim--->"basic.claim begins from loop.initrule") (template sym) heap
 initrule _ _ _
 = abort "initrule: out of heap space"
 
diff --git a/sucl/newtest.icl b/sucl/newtest.icl
index 6a0cdc9..ebe0f47 100644
--- a/sucl/newtest.icl
+++ b/sucl/newtest.icl
@@ -152,6 +152,7 @@ these tuples.
    = { srr_task_expression :: Rgraph sym var    // The initial area in canonical form
      , srr_assigned_symbol :: sym               // The assigned symbol
      , srr_strictness      :: [Bool]            // Strictness annotations
+     , srr_arity           :: Int               // Arity
      , srr_typerule        :: Rule tsym tvar    // Type rule
      , srr_trace           :: Trace sym var var // Truncated and folded trace
      , srr_function_def    :: FuncDef sym var   // Resulting rewrite rules
@@ -163,6 +164,7 @@ where toString srr
       = "Task: "+++toString srr.srr_task_expression+++
         "\nSymbol: "+++toString srr.srr_assigned_symbol+++
         "\nStrictness: "+++listToString srr.srr_strictness+++
+        "\nArity: "+++toString srr.srr_arity+++
         "\nTyperule: "+++"<typerule>"+++
         "\nTrace: "+++"<trace>"+++
         "\nFunction definition: "+++"<funcdef>"+++
@@ -388,6 +390,7 @@ symredarea foldarea cli area
 = { srr_task_expression = (area <--- "newtest.symredarea.srr_task_expression ends") ---> "newtest.symredarea.srr_task_expression begins"
   , srr_assigned_symbol = (symbol <--- "newtest.symredarea.srr_assigned_symbol ends") ---> "newtest.symredarea.srr_assigned_symbol begins"
   , srr_strictness      = (stricts <--- "newtest.symredarea.srr_strictness ends") ---> "newtest.symredarea.srr_strictness begins"
+  , srr_arity           = length aargs
   , srr_typerule        = trule
   , srr_trace           = (trace <--- "newtest.symredarea.srr_trace ends") ---> "newtest.symredarea.srr_trace begins"
   , srr_function_def    = (rules <--- "newtest.symredarea.srr_function_def ends") ---> "newtest.symredarea.srr_function_def begins"
@@ -546,7 +549,7 @@ 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
+        (targs`,targs``) = (claim--->"basic.claim begins from newtest.ctyperule") args targs
         (troot`,tgraph`,_) = foldr build (troot,tgraph,typeheap--varlist tgraph [troot:targs]) targs``
         build targ (troot,tgraph,[tnode:tnodes])
         = (tnode,updategraph tnode (fn 1,[targ,troot]) tgraph,tnodes)
diff --git a/sucl/trd.icl b/sucl/trd.icl
index 45861d8..2a7d151 100644
--- a/sucl/trd.icl
+++ b/sucl/trd.icl
@@ -5,6 +5,7 @@ implementation module trd
 import rule
 import graph
 import basic
+from general import --->
 import StdEnv
 
 /*
@@ -133,7 +134,7 @@ buildtype typerule graph node bcont theap tgraph assignment
         trule = typerule cont
         trargs = arguments trule; trroot = ruleroot trule; trgraph = rulegraph trule
         trnodes = varlist trgraph [trroot:trargs]
-        (tnodes,theap`) = claim trnodes theap
+        (tnodes,theap`) = (claim--->"basic.claim begins from trd.buildtype") trnodes theap
         matching = zip2 trnodes tnodes
         tgraph` = foldr addnode tgraph matching
         addnode (trnode,tnode)