Commit bb0d225f authored by Vincent Zweije's avatar Vincent Zweije
Browse files

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

which included commits to RCS files with non-trunk default branches.
parent f03c3210
......@@ -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
......
......@@ -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
......
......@@ -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"
......
......@@ -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"
......
......@@ -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)
......
......@@ -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)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment