diff options
| -rw-r--r-- | sucl/basic.icl | 6 | ||||
| -rw-r--r-- | sucl/canon.icl | 4 | ||||
| -rw-r--r-- | sucl/law.icl | 3 | ||||
| -rw-r--r-- | sucl/loop.icl | 2 | ||||
| -rw-r--r-- | sucl/newtest.icl | 5 | ||||
| -rw-r--r-- | sucl/trd.icl | 3 |
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) |