Commit 75ac5fce authored by Vincent Zweije's avatar Vincent Zweije
Browse files

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

which included commits to RCS files with non-trunk default branches.
parent 2c53ade2
......@@ -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) <--- "basic.claim ends (with empty result)"
claim [] heap = ([],heap)
claim [pnode:pnodes] [snode:heap]
= ([snode:snodes],heap`) <--- "basic.claim ends (with nonempty result)"
where (snodes,heap`) = (claim--->"basic.claim begins from basic.claim") pnodes heap
= ([snode:snodes],heap`)
where (snodes,heap`) = 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
......
......@@ -117,9 +117,9 @@ fullfold ::
& <<< pvar
fullfold trc foldarea fnsymbol trace
| recursive ---> "newfold.fullfold begins"
= addlhs recurseresult <--- "newfold.fullfold ends (recursive=True)"
= addlhs (newextract trc foldarea trace) <--- "newfold.fullfold ends (recursive=False)"
| recursive
= addlhs recurseresult
= addlhs (newextract trc foldarea trace)
where (recursive,recurseresult) = recurse foldarea fnsymbol trace
addlhs = mapsnd3 (pair (arguments rule))
(Trace _ rule _ _ _) = trace
......@@ -149,31 +149,31 @@ recurse ::
& <<< pvar
recurse foldarea fnsymbol
= ((f--->"newfold.recurse.f begins from newfold.recurse") ([],[]) <--- "newfold.recurse ends") ---> "newfold.recurse begins"
= f ([],[])
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"
| isEmpty pclosed && superset popen ropen
= f (newhist`,newhist`) trace
where rargs = arguments rule; rroot = ruleroot rule; rgraph = rulegraph rule
(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)"
(pclosed,popen) = graphvars rgraph rargs
(_,ropen) = graphvars rgraph [rroot]
newhist` = [(rroot,rgraph):newhist]
(newhist,hist) = newhisthist
f newhisthist (Trace stricts rule answer history (Annotate trace))
| isEmpty pclosed && superset popen ropen
= ((f--->"newfold.recurse.f begins (from Annotate)") (newhist`,hist) trace <--- "newfold.recurse.f ends (valid Annotate)") ---> "f: Annotate"
= f (newhist`,hist) trace
where rargs = arguments rule; rroot = ruleroot rule; rgraph = rulegraph rule
(pclosed,popen) = graphvars rgraph rargs ---> "get (pclosed,popen)"
(_,ropen) = graphvars rgraph [rroot] ---> "get ropen"
(pclosed,popen) = graphvars rgraph rargs
(_,ropen) = graphvars rgraph [rroot]
newhist` = [(rroot,rgraph):newhist]
(newhist,hist) = newhisthist ---> "get (newhist,hist)"
(newhist,hist) = newhisthist
f newhisthist (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"
= foldtips foldarea (fnsymbol,arguments rule) (removeDup newhist`,removeDup hist) (Trace stricts rule answer history transf)
where rroot = ruleroot rule; rgraph = rulegraph rule
newhist` = [(rroot,rgraph):newhist]
(newhist,hist) = newhisthist ---> "get (newhist,hist)"
(newhist,hist) = newhisthist
/*
......@@ -195,26 +195,26 @@ foldtips ::
& == pvar
foldtips foldarea foldcont
= (ft--->"newfold.foldtips.ft begins from foldtips")<---"newfold.foldtips ends"
= ft
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) <--- "newfold.foldtips.ft ends (Stop)") ---> "newfold.foldtips.ft case = Stop"
-> foldoptional exres (pair True o addstrict stricts o mapfst rule2body) (actualfold deltanodes rnfnodes foldarea (==) foldcont (snd hist) rule)
where deltanodes = foldoptional [] getdeltanodes answer
rnfnodes = foldoptional [ruleroot rule] (const []) answer
Instantiate ipattern yestrace notrace
-> 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)") ---> "newfold.foldtips.ft case Instantiate/no"
-> ft` (ft hist yestrace) (ft hist notrace)
where ft` (False,yessra) (False,nosra) = exres
ft` (yesfound,(yesstricts,yesbody,yesareas)) (nofound,(nostricts,nobody,noareas))
= ((True,(stricts,MatchPattern ipattern yesbody nobody,yesareas++noareas)) <--- "newfold.foldtips.ft ends (Instantiate/yes)") ---> "newfold.foldtips.ft case Instantiate/yes"
= (True,(stricts,MatchPattern ipattern yesbody nobody,yesareas++noareas))
Reduce reductroot trace
-> 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)") ---> "newfold.foldtips.ft case Reduce/no"
ft` (found,sra) = ((True,sra) <--- "newfold.foldtips.ft ends (Reduce/yes)") ---> "newfold.foldtips.ft case Reduce/no"
-> ft` (ft (fst hist,fst hist) trace)
where ft` (False,sra) = exres
ft` (found,sra) = (True,sra)
Annotate trace
-> ft` ((ft--->"newfold.foldtips.ft begins from newfold.foldtips.ft.Annotate") hist trace)
where ft` (False,sra) = (exres <--- "newfold.foldtips.ft ends (Annotate/no)") ---> "newfold.foldtips.ft case Annotate/no"
ft` (found,sra) = ((True,sra) <--- "newfold.foldtips.ft ends (Annotate/yes)") ---> "newfold.foldtips.ft case Annotate/no"
-> ft` (ft hist trace)
where ft` (False,sra) = exres
ft` (found,sra) = (True,sra)
where (Trace stricts rule answer _ transf) = trace
exres = (False,newextract noetrc foldarea trace)
......@@ -262,19 +262,19 @@ newextract ::
& == pvar
newextract trc newname (Trace stricts rule answer history transf)
| recursive ---> "newfold.newextract begins"
= (stricts,rule2body recrule,recareas) <--- "newfold.newextract ends (recursive=True)"
| recursive
= (stricts,rule2body recrule,recareas)
= case transf
of Reduce reductroot trace
-> newextract trc newname trace <--- "newfold.newextract ends (at Reduce transformation)"
-> newextract trc newname trace
Annotate trace
-> newextract trc newname trace <--- "newfold.newextract ends (at Annotate transformation)"
-> newextract trc newname trace
Instantiate ipattern yestrace notrace
-> (stricts,MatchPattern ipattern yesbody nobody,yesareas++noareas) <--- "newfold.newextract ends (at Instantiate transformation)"
-> (stricts,MatchPattern ipattern yesbody nobody,yesareas++noareas)
where (_,yesbody,yesareas) = newextract trc newname yestrace
(_,nobody,noareas) = newextract trc newname notrace
Stop
-> (stricts,buildgraph rargs rroot stoprgraph,stopareas) <--- "newfold.newextract ends (at Stop transformation)"
-> (stricts,buildgraph rargs rroot stoprgraph,stopareas)
where (recursive,unsafearea)
= if (isreduce transf)
......@@ -296,7 +296,7 @@ buildgraph ::
(Graph sym var)
-> FuncBody sym var | == var
buildgraph args root graph
= (BuildGraph (mkrgraph root (compilegraph (map (pairwith (snd o varcontents graph)) newnodes))) <--- "newfold.buildgraph ends") ---> "newfold.buildgraph begins"
= BuildGraph (mkrgraph root (compilegraph (map (pairwith (snd o varcontents graph)) newnodes)))
where newnodes = closedreplnodes--patnodes
closedreplnodes = fst (graphvars graph [root])
patnodes = varlist graph args
......@@ -359,7 +359,7 @@ findpattern pattern thespinenodes residuroot transf
findpattern pattern thespinenodes residuroot (Reduce reductroot trace)
= fp (redirect residuroot) trace
where fp residuroot (Trace stricts rule answer history transf)
| or [(isinstance--->"graph.isinstance begins from newfold.findpattern.fp") pattern (graph,node) \\ node<-varlist graph [residuroot]]
| or [isinstance pattern (graph,node) \\ node<-varlist graph [residuroot]]
= True
where graph = rulegraph rule
fp residuroot trace = findpattern` pattern residuroot trace
......
......@@ -173,7 +173,7 @@ where toString srr
instance <<< (Symredresult sym var tsym tvar) | toString sym & <<<,==,toString var
where (<<<) file srr
= file <<< "==[BEGIN]==" <<< nl
<<< "Task expression: " <<< ((srr.srr_task_expression <--- "newtest.<<<(Symredresult).srr_task_expression ends") ---> "newtest.<<<(Symredresult).srr_task_expression begins") <<< nl
<<< "Task expression: " <<< srr.srr_task_expression <<< nl
<<< "Assigned symbol: " <<< toString (srr.srr_assigned_symbol) <<< nl
<<< "Strictness: " <<< srr.srr_strictness <<< nl
//<<< "Type rule: ..." <<< nl
......@@ -306,13 +306,13 @@ fullsymred ::
fullsymred freshsymbols cli
= results
where results = (depthfirst generate process (initareas cli) <--- "newtest.fullsymred.results ends") ---> "newtest.fullsymred.results begins"
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"
where results = depthfirst generate process (initareas cli)
generate result = map canonise` (getareas result)
process area = symredarea foldarea` cli area
foldarea` = ((foldarea (labelarea` o canonise`)) <--- "newtest.fullsymred.foldarea` ends") ---> "newtest.fullsymred.foldarea` begins"
labelarea` = (labelarea isSuclUserSym (map getinit results) freshsymbols <--- "newtest.fullsymred.labelarea` ends") ---> "newtest.fullsymred.labelarea` begins"
canonise` = (canonise (arity cli) suclheap <--- "newtest.fullsymred.canonise` ends") ---> "newtest.fullsymred.canonise` begins"
foldarea` = foldarea (labelarea` o canonise`)
labelarea` = labelarea isSuclUserSym (map getinit results) freshsymbols
canonise` = canonise (arity cli) suclheap
isSuclUserSym (SuclUser _) = True
isSuclUserSym _ = False
......@@ -349,11 +349,11 @@ initareas cli
getinit :: (Symredresult sym var tsym tvar) -> Rgraph sym var
getinit srr
= (srr.srr_task_expression <--- "newtest.getinit ends") ---> "newtest.getinit begins"
= srr.srr_task_expression
getareas :: (Symredresult sym var tsym tvar) -> [Rgraph sym var]
getareas srr
= (srr.srr_areas <--- "newtest.getareas ends") ---> "newtest.getareas begins"
= srr.srr_areas
/*
`Symredarea' is the function that does symbolic reduction of a single
......@@ -387,21 +387,21 @@ symredarea ::
-> Symredresult SuclSymbol SuclVariable SuclTypeSymbol SuclTypeVariable
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_task_expression = area
, srr_assigned_symbol = symbol
, srr_strictness = stricts
, 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"
, srr_areas = (areas <--- "newtest.symredarea.srr_areas ends") ---> "newtest.symredarea.srr_areas begins"
, srr_trace = trace
, srr_function_def = rules
, srr_areas = 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 <--- "newtest.symredarea.trule.ruletype ends") ---> "newtest.symredarea.trule.ruletype begins"
trace = (loop strategy` matchable` (suclheap--varlist agraph [aroot],arule) <--- "newtest.symredarea.trace.loop ends") ---> "newtest.symredarea.trace.loop begins"
(stricts,rules,areas) = (fullfold (trc symbol) foldarea symbol trace <--- "newtest.symredarea.(,,).fullfold ends") ---> "newtest.symredarea.(,,).fullfold begins"
trule = ruletype sucltypeheap (ctyperule SuclFN sucltypeheap (typerule cli)) arule
trace = loop strategy` matchable` (suclheap--varlist agraph [aroot],arule)
(stricts,rules,areas) = fullfold (trc symbol) foldarea symbol trace
matchable` = matchable (complete cli)
strategy` = clistrategy cli
......@@ -549,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--->"basic.claim begins from newtest.ctyperule") args targs
(targs`,targs``) = claim 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)
......
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