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

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

which included commits to RCS files with non-trunk default branches.
parent c36bdc7f
......@@ -6,7 +6,7 @@ COCL = cocl
#COCLFLAGS = -lat
SYS = Clean\ System\ Files
MODULES = basic pretty pfun graph dnc rule trd rewr complete history spine trace absmodule strat loop coreclean law canon cli extract newfold newtest convert supercompile
MODULES = cleanversion basic pfun graph dnc rule trd rewr complete history spine trace absmodule strat loop coreclean law canon cli extract newfold newtest convert supercompile
ABC = $(patsubst %,$(SYS)/%.abc,$(MODULES))
......@@ -47,5 +47,6 @@ $(SYS)/rule.abc: rule.icl rule.dcl graph.dcl basic.dcl
$(SYS)/dnc.abc: dnc.icl dnc.dcl graph.dcl
$(SYS)/graph.abc: graph.icl graph.dcl pfun.dcl basic.dcl
$(SYS)/pfun.abc: pfun.icl pfun.dcl basic.dcl
$(SYS)/pretty.abc: pretty.icl pretty.dcl
#$(SYS)/pretty.abc: pretty.icl pretty.dcl
$(SYS)/basic.abc: basic.icl basic.dcl
$(SYS)/cleanversion.abc: cleanversion.icl cleanversion.dcl
......@@ -213,5 +213,8 @@ zipwith :: (.a .b->.c) ![.a] [.b] -> [.c]
// Sequential evaluation of left and right arguments
($) infixr :: !.a .b -> .b
// List subtraction (lazier than removeMembers)
(--) infixl :: !.[elem] .[elem] -> .[elem] | == elem
// Write a list of things, each one terminated by a newline
(writeList) infixl :: !*File [a] -> .File | <<< a
......@@ -299,7 +299,7 @@ stub modulename functionname message
= abort (modulename+++": "+++functionname+++": "+++message)
superset :: .[a] -> .(.[a] -> Bool) | == a
superset set = isEmpty o (removeMembers set)
superset set = isEmpty o ((--) set)
zipwith :: (.a .b->.c) ![.a] [.b] -> [.c]
zipwith f xs ys = [f x y \\ x<-xs & y<-ys]
......@@ -311,6 +311,14 @@ zipwith f xs ys = [f x y \\ x<-xs & y<-ys]
($) infixr :: !.a .b -> .b
($) x y = y
// List subtraction (lazier than removeMembers)
(--) infixl :: !.[elem] .[elem] -> .[elem] | == elem
(--) [] ys = []
(--) [x:xs] ys = f maybeeqs
where (noteqs,maybeeqs) = span ((<>)x) ys
f [] = [x:xs--noteqs] // x wasn't in ys
f [y:ys] = xs--(noteqs++ys) // x==y
(writeList) infixl :: !*File [a] -> .File | <<< a
(writeList) file [] = file
(writeList) file [x:xs]
......
......@@ -59,9 +59,9 @@ steps:
*/
canonise :: (sym -> Rule tsym tvar) [var2] (Rgraph sym var1) -> Rgraph sym var2 | == var1
canonise typerule heap rg
= ((relabel heap o etaexpand typerule o splitrg o relabel localheap) rg <--- "canon.canonise ends") ---> "canon.canonise begins"
canonise :: (sym -> Int) [var2] (Rgraph sym var1) -> Rgraph sym var2 | == var1
canonise arity heap rg
= ((relabel heap o etaexpand arity o splitrg o relabel localheap) rg <--- "canon.canonise ends") ---> "canon.canonise begins"
/*
......@@ -75,7 +75,7 @@ canonise typerule 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 (removeMembers localheap [root]))) emptygraph)
where single root sym args = mkrgraph root (updategraph root (sym,fst (claim args (localheap--[root]))) emptygraph)
/*
> uncurry :: (*->rule **** *****) -> rgraph * num -> rgraph * num
......@@ -89,12 +89,11 @@ splitrg rgraph
> root = rgraphroot rgraph; graph = rgraphgraph rgraph
*/
etaexpand :: (sym->Rule tsym tvar) (Rgraph sym Int) -> Rgraph sym Int
etaexpand typerule rgraph
etaexpand :: (sym->Int) (Rgraph sym Int) -> Rgraph sym Int
etaexpand arity rgraph
= f (nc root)
where f (True,(sym,args))
= mkrgraph root (updategraph root (sym,fst (claim targs (args++(removeMembers localheap (varlist graph [root]))))) graph)
where targs = arguments (typerule sym)
= mkrgraph root (updategraph root (sym,take (arity sym) (args++(localheap--(varlist graph [root])))) graph)
f cont = rgraph
nc = varcontents graph
root = rgraphroot rgraph; graph = rgraphgraph rgraph
......@@ -115,8 +114,8 @@ localheap =: [0..]
foldarea :: ((Rgraph sym var) -> sym) (Rgraph sym var) -> Node sym var | == var
foldarea label 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]))
where single root sym args = map (\arg->(arg<---"canon.foldarea.single.arg ends")--->"canon.foldarea.single.arg begins") args
nosingle = map (\arg->(arg<---"newfold.foldarea.nosingle.arg ends")--->"newfold.foldarea.nosingle.arg begins") (snd (graphvars (rgraphgraph rgraph) [rgraphroot rgraph]))
labelrgraph = (label rgraph <--- "canon.foldarea.labelrgraph ends") ---> "canon.foldarea.labelrgraph begins"
/*
......@@ -139,18 +138,18 @@ foldarea label rgraph
> aroot = rgraphroot area; agraph = rgraphgraph area
*/
labelarea :: [Rgraph sym var] [sym] (Rgraph sym var) -> sym | == sym & == var
labelarea areas labels rg
= ((foldmap--->"canon.labelarea uses foldmap") id nolabel ((maketable--->"canon.maketable begins from canon.labelarea") ((areas<---"canon.labelarea.areas ends")--->"canon.labelarea.areas begins") ((labels<---"canon.labelarea.labels ends")--->"canon.labelarea.labels begins")) ((rg<---"canon.labelarea.rg ends")--->"canon.labelarea.rg begins") <--- "canon.labelarea ends") ---> "canon.labelarea begins"
labelarea :: (sym->Bool) [Rgraph sym var] [sym] (Rgraph sym var) -> sym | == sym & == var
labelarea reusable areas labels rg
= ((foldmap--->"canon.labelarea uses foldmap") id nolabel ((maketable--->"canon.maketable begins from canon.labelarea") reusable ((areas<---"canon.labelarea.areas ends")--->"canon.labelarea.areas begins") ((labels<---"canon.labelarea.labels ends")--->"canon.labelarea.labels begins")) ((rg<---"canon.labelarea.rg ends")--->"canon.labelarea.rg begins") <--- "canon.labelarea ends") ---> "canon.labelarea begins"
where nolabel = abort "canon: labelarea: no label assigned to area"
maketable :: [Rgraph sym var] [sym] -> [(Rgraph sym var,sym)] | == var
maketable [] _ = [] <--- "canon.maketable ends empty"
maketable [area:areas] labels
= [(((area<---"canon.maketable.area ends")--->"canon.maketable.area begins",(label<---"canon.maketable.label ends")--->"canon.maketable.label begins") <--- "canon.maketable.head ends") ---> "canon.maketable.head begins":(maketable--->"canon.maketable begins from maketable") areas labels`] <--- "canon.maketable ends nonempty"
maketable :: (sym->Bool) [Rgraph sym var] [sym] -> [(Rgraph sym var,sym)] | == var
maketable _ [] _ = [] <--- "canon.maketable ends empty"
maketable reusable [area:areas] labels
= [(((area<---"canon.maketable.area ends")--->"canon.maketable.area begins",(label<---"canon.maketable.label ends")--->"canon.maketable.label begins") <--- "canon.maketable.head ends") ---> "canon.maketable.head begins":(maketable--->"canon.maketable begins from maketable") reusable areas labels`] <--- "canon.maketable ends nonempty"
where (label,labels`) = getlabel (nc aroot) labels
getlabel (True,(asym,aargs)) labels
| not (or (map (fst o nc) aargs))
| reusable asym && not (or (map (fst o nc) aargs))
= (asym,labels)
getlabel acont [label:labels]
= (label,labels)
......
......@@ -9,6 +9,7 @@ import absmodule
import rule
import dnc
import basic
import general
import StdEnv
/*
......@@ -123,6 +124,11 @@ Abstype implementation.
exports :: Cli -> [SuclSymbol]
exports (CliAlias m) = m.exportedsymbols
// Determine the arity of a core clean symbol
arity :: Cli SuclSymbol -> Int
arity (CliAlias m) sym
= extendfn m.arities (length o arguments o (extendfn m.typerules coretyperule)) sym
/*
> typerule (tdefs,(es,as,ts,rs)) = maxtyperule ts
*/
......@@ -160,8 +166,9 @@ clistrategy (CliAlias {arities=as,typeconstructors=tcs,typerules=ts,rules=rs}) m
o checkimport islocal // Checks for delta symbols
o checkconstr (flip isMember (flatten (map snd tcs))) // Checks for constructors
) (corestrategy matchable) // Checks rules for symbols in the language core (IF, _AP, ...)
where islocal rsym=:(SuclUser s) = isMember rsym (map fst rs)
islocal rsym = True // Symbols in the language core are always completely known
where islocal rsym=:(SuclUser s) = isMember rsym (map fst rs)// User-defined symbols can be imported, so they're known if we have a list of rules for them
islocal rsym = True // Symbols in the language core (the rest) are always completely known
// This includes lifted case symbols; we lifted them ourselves, after all
typearity :: (Rule SuclTypeSymbol SuclTypeVariable) -> Int
typearity ti = length (arguments ti)
......@@ -321,17 +328,17 @@ mkcli ::
[(SuclSymbol,Rule SuclTypeSymbol SuclTypeVariable)]
[(SuclSymbol,[Bool])]
[SuclSymbol]
[(SuclTypeSymbol,[SuclSymbol])]
[(SuclTypeSymbol,[(SuclSymbol,(Rule SuclTypeSymbol SuclTypeVariable,[Bool]))])]
[(SuclSymbol,(Int,[Rule SuclSymbol SuclVariable]))]
-> Cli
mkcli typerules stricts exports constrs bodies
= CliAlias
{ arities = map (mapsnd fst) bodies
, typeconstructors = constrs
, typeconstructors = map (mapsnd (map fst)) constrs
, exportedsymbols = exports
, typerules = typerules
, stricts = stricts
, typerules = typerules++flatten ((map (map (mapsnd fst) o snd)) constrs)
, stricts = stricts++flatten ((map (map (mapsnd snd) o snd)) constrs)
, rules = map (mapsnd snd) bodies
}
......
......@@ -3,7 +3,7 @@ definition module dnc
// $Id$
from graph import Graph,Node
from StdString import String
from cleanversion import String
from StdOverloaded import ==
// dnc is like varcontents, but can give a more reasonable error message
......
......@@ -80,7 +80,7 @@ actualfold deltanodes rnfnodes foldarea self foldcont hist rule
= Yes (mkrule rargs rroot rgraph``,areas`)
where rargs = arguments rule; rroot = ruleroot rule; rgraph = rulegraph rule
list2 = map (pairwith (findoccs hist rule)) (removeMembers (varlist rgraph [rroot]) (varlist rgraph rargs))
list2 = map (pairwith (findoccs hist rule)) (varlist rgraph [rroot]--varlist rgraph rargs)
// list2: list combining every node with list of every instantiable history graph
list3 = [(rnode,mapping) \\ (rnode,[mapping:_])<-list2]
......@@ -120,7 +120,7 @@ findoccs hist rule rnode
unshared rnode (hroot,hgraph) mapping
= disjoint inner outer
where inner = map (lookup mapping) (fst (graphvars hgraph [hroot]))
outer = removeMembers (varlist (prunegraph rnode rgraph) [rroot:rargs]) [rnode]
outer = varlist (prunegraph rnode rgraph) [rroot:rargs]--[rnode]
/*
------------------------------------------------------------------------
......@@ -148,8 +148,8 @@ splitrule fold rnfnodes deltanodes rule area
rgraph` = updategraph aroot (fold area`) rgraph
area` = mkrgraph aroot agraph`
agraph` = foldr addnode emptygraph ins
ins = removeMembers (varlist agraph [aroot]) outs
outs = removeMembers (varlist (prunegraph aroot rgraph) [rroot:rargs++snd (graphvars agraph [aroot])]) [aroot]
ins = varlist agraph [aroot]--outs
outs = varlist (prunegraph aroot rgraph) [rroot:rargs++snd (graphvars agraph [aroot])]--[aroot]
addnode node = updategraph node (snd (dnc (const "in splitrule") rgraph node))
......@@ -180,11 +180,11 @@ finishfold foldarea fixednodes singlenodes root graph
process aroot
= mkrgraph aroot (foldr addnode emptygraph ins)
where outs_and_aroot = varlist (prunegraph aroot graph) arearoots++fixednodes
ins = [aroot:removeMembers (varlist graph [aroot]) outs_and_aroot]
ins = [aroot:varlist graph [aroot]--outs_and_aroot]
generate area
= removeMembers (snd (graphvars agraph [aroot])) fixednodes
= snd (graphvars agraph [aroot])--fixednodes
where aroot = rgraphroot area; agraph = rgraphgraph area
arearoots = removeMembers (removeDup [root:singlenodes++singfixargs]) fixednodes
arearoots = removeDup [root:singlenodes++singfixargs]--fixednodes
singfixargs = flatten (map arguments (singlenodes++fixednodes))
arguments node
......
......@@ -4,7 +4,8 @@ definition module graph
from pfun import Pfun
from StdOverloaded import ==
from StdString import String,toString
from cleanversion import String
from StdString import toString
// A rule associating a replacement with a pattern
//:: Rule sym var
......@@ -98,7 +99,7 @@ Implementation
*/
// The empty graph.
emptygraph :: Graph .sym .var
emptygraph :: .Graph sym var
// Assign a node to a variable in a graph.
updategraph :: var .(Node sym var) !.(Graph sym var) -> .Graph sym var
......
......@@ -60,7 +60,7 @@ functions to manipulate them.
*/
// The empty set of bindings
emptygraph :: Graph .sym .var
emptygraph :: .Graph sym var
emptygraph = GraphAlias emptypfun
updategraph :: var .(Node sym var) !.(Graph sym var) -> .Graph sym var
......@@ -97,18 +97,18 @@ varcontents (GraphAlias pfun) v
graphvars :: .(Graph sym var) !.[var] -> (.[var],.[var]) | == var
graphvars graph roots
= (graphvars` [] graph roots<---"graph.graphvars ends")--->"graph.graphvars begins"
= graphvars` [] graph roots
// 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--->"graph.graphvars`.ns begins from graph.graphvars`") (prune,([],[])) roots)<---"graph.graphvars` ends")--->"graph.graphvars` begins"
= snd (foldlr ns (prune,([],[])) roots)
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
| isMember var seen = seenboundfree
| not def = ([var:seen],(bound,[var:free]))
= (seen`,([var:bound`],free`))
where (seen`,(bound`,free`)) = foldlr ns ([var:seen],boundfree) args
(def,(_,args)) = varcontents graph var
(seen,boundfree=:(bound,free)) = seenboundfree
varlist :: .(Graph sym var) !.[var] -> .[var] | == var
......@@ -235,7 +235,7 @@ isinstance
& == pvar
isinstance (pgraph,pvar) (sgraph,svar)
= isEmpty (thd3 (findmatching (pgraph,sgraph) (pvar,svar) ([],[],[])))
= isEmpty (thd3 (findmatching (pgraph,sgraph) (pvar,svar) ([],[],[]))) <--- "graph.isinstance ends"
/*
......@@ -413,12 +413,12 @@ extgraph sgraph pattern pnodes matching graph
mapgraph ::
!( (Pfun var1 (sym1,[var1]))
-> Pfun .var2 (.sym2,[.var2])
-> Pfun var2 (sym2,[var2])
)
!.(Graph sym1 var1)
-> Graph .sym2 .var2
-> .Graph sym2 var2
mapgraph f (GraphAlias pfun) = GraphAlias (f pfun)
instance == (Graph sym var) | == sym & == var
where (==) (GraphAlias pf1) (GraphAlias pf2)
= ((pf1 == pf2) <--- "graph.==(Graph) ends") ---> "graph.==(Graph) begins"
= pf1 == pf2
......@@ -7,6 +7,8 @@ from graph import Graph
from general import Optional
from StdOverloaded import ==
from StdString import toString
from StdClass import Eq
from cleanversion import String
// A history relates node-ids in the subject graph to patterns
:: History sym var
......@@ -34,8 +36,16 @@ matchhistory
(Graph sym var) // Current subject graph
var // Current application point of strategy
-> [HistoryPattern sym var] // Matching history patterns
| == sym
& == var
| Eq sym
& Eq var
// Convert a history to its string representation
historyToString ::
(History sym var)
-> String
| toString sym
& toString var
& Eq var
(writeHistory) infixl :: *File (History sym var) -> .File | toString sym & toString,== var
(writeHistoryAssociation) infixl :: *File (HistoryAssociation sym var) -> .File | toString sym & toString,== var
......@@ -6,7 +6,7 @@ import rule
import graph
import pfun
import basic
from general import Optional,Yes,No
from general import Optional,Yes,No,--->
import StdEnv
// A history relates node-ids in the subject graph to patterns
......@@ -39,17 +39,17 @@ matchhistory
(Graph sym var) // Current subject graph
var // Current application point of strategy
-> [HistoryPattern sym var] // Matching history patterns
| == sym
& == var
| Eq sym
& Eq var
matchhistory hist spinenodes sgraph snode
= foldr (checkassoc spinenodes sgraph snode) [] hist
= foldr ((checkassoc--->"history.checkassoc begins from history.matchhistory") spinenodes sgraph snode) [] hist <--- "history.matchhistory ends"
checkassoc spinenodes sgraph snode (var,pats) rest
= if (isMember var spinenodes) (foldr checkpat rest pats) rest
where checkpat pat rest
= if (isinstance (hgraph,hroot) (sgraph,snode)) [pat:rest] rest
where hgraph = rgraphgraph pat; hroot = rgraphroot pat
= ((if (isMember var spinenodes) (foldr (checkpat--->"history.checkassoc.checkpat begins from history.checkassoc") rest pats) (rest--->"history.checkassoc history attachment node is not part of the spine nodes")) <--- "history.checkassoc ends") ---> ("history.checkassoc number of history patterns for node is "+++toString (length pats))
where checkpat pat rest
= (if ((isinstance--->"graph.isinstance begins from history.checkassoc.checkpat") (hgraph,hroot) (sgraph,snode)) [pat:rest] rest) <--- "history.checkassoc.checkpat ends"
where hgraph = rgraphgraph pat; hroot = rgraphroot pat
/*
instantiate ::
......@@ -60,8 +60,18 @@ instantiate ::
-> ([(pvar,var)],[(pvar,var)],[(pvar,var)])
*/
historyToString ::
(History sym var)
-> String
| toString sym
& toString var
& Eq var
historyToString history
= showlist (showpair toString (showlist toString)) history
(writeHistory) infixl :: *File (History sym var) -> .File | toString sym & toString,== var
(writeHistory) file history = sfoldl (writeHistoryAssociation) file history
(writeHistory) file history = file <<< "<history>" // sfoldl (writeHistoryAssociation) file history
(writeHistoryAssociation) infixl :: *File (HistoryAssociation sym var) -> .File | toString sym & toString,== var
(writeHistoryAssociation) file ha = file <<< showpair toString (showlist toString) ha <<< nl
(writeHistoryAssociation) file ha = file <<< "<historyassociation>" // showpair toString (showlist toString) ha <<< nl
......@@ -11,9 +11,12 @@ import rule
import graph
import pfun
import basic
from general import Yes,No
from general import Yes,No,--->
import StdEnv
mstub = stub "loop"
block func = mstub func "blocked for debugging"
/*
loop.lit - Looping to produce a trace
......@@ -228,19 +231,22 @@ loop
& toString var // Debugging
& <<< var // Debugging
// loop _ _ _ = block "loop"
loop strategy matchable (initheap,rule)
= 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
= (Trace stricts currentrule answer history transf ---> ("loop.loop.maketrace rule "+++ruleToString toString currentrule)) ---> ("loop.loop.maketrace history "+++historyToString history)
where answer = makernfstrategy history (strategy matchable`) rnfnodes sroot subject
transf = transform sroot sargs answer maketrace history failinfo instdone stricts sroot subject heap
transf = (transform--->"loop.transform begins from loop.loop") sroot sargs answer maketrace history failinfo instdone stricts sroot subject heap
rnfnodes = removeDup (listselect stricts sargs++fst (graphvars subject sargs))
matchable` pgraph pnode snode
= matchable (failinfo snode) (mkrgraph pnode pgraph)
currentrule = mkrule sargs sroot subject
inithistory = []
initfailinfo = const []
initinstdone = False
......@@ -277,14 +283,20 @@ transform
& == pvar
transform anode sargs (Yes spine)
= selectfromtip (spinetip spine)
where selectfromtip (nid,Open rgraph) = tryinstantiate nid rgraph anode sargs
selectfromtip (nid,Redex rule matching) = tryunfold nid rule matching spine
selectfromtip (nid,Strict) = tryannotate nid sargs
selectfromtip spine = dostop
= (selectfromtip--->"loop.transform.selectfromtip begins from loop.transform") (spinetip spine) <--- "loop.transform ends for some spine"
where selectfromtip (nid,Open rgraph) = (tryinstantiate--->"loop.tryinstantiate begins from loop.transform.selectfromtip") nid rgraph anode sargs <--- "loop.transform.selectfromtip ends for Open spine"
selectfromtip (nid,Redex rule matching) = (tryunfold--->"loop.tryunfold begins from loop.transform.selectfromtip") nid rule matching spine <--- "loop.transform.selectfromtip ends for Redex spine"
selectfromtip (nid,Strict) = (tryannotate--->"loop.tryannotate begins from loop.transform.selectfromtip") nid sargs <--- "loop.transform.selectfromtip ends for Strict spine"
selectfromtip (nid,Cycle) = (dostop--->"loop.dostop begins from loop.transform.selectfromtip") <--- "loop.transform.selectfromtip ends for Cycle spine"
selectfromtip (nid,Delta) = (dostop--->"loop.dostop begins from loop.transform.selectfromtip") <--- "loop.transform.selectfromtip ends for Delta spine"
selectfromtip (nid,Force _ _) = (dostop--->"loop.dostop begins from loop.transform.selectfromtip") <--- "loop.transform.selectfromtip ends for Force spine"
selectfromtip (nid,MissingCase) = (dostop--->"loop.dostop begins from loop.transform.selectfromtip") <--- "loop.transform.selectfromtip ends for MissingCase spine"
selectfromtip (nid,Partial _ _ _ _) = (dostop--->"loop.dostop begins from loop.transform.selectfromtip") <--- "loop.transform.selectfromtip ends for Partial spine"
selectfromtip (nid,Unsafe _) = (dostop--->"loop.dostop begins from loop.transform.selectfromtip") <--- "loop.transform.selectfromtip ends for Unsafe spine"
//selectfromtip spine = (dostop--->"loop.dostop begins from loop.transform.selectfromtip") <--- "loop.transform.selectfromtip ends for other spine"
transform anode sargs No
= dostop
= (dostop--->"loop.dostop begins from loop.transform") <--- "loop.transform ends for no spine"
// ==== ATTEMPT TO INSTANTIATE A FREE VARIABLE WITH A PATTERN ====
......@@ -298,7 +310,7 @@ tryinstantiate
& == pvar
tryinstantiate onode rpattern anode sargs
= act
= act <--- "loop.tryinstantiate ends"
where act continue history failinfo instdone stricts sroot subject heap
| anode==sroot // Check if strategy applied at root
&& goodorder strictargs sargs subject subject` // Check if order of arguments of rule ok
......@@ -325,8 +337,8 @@ goodorder
goodorder stricts sargs subject subject`
= startswith match match`
where match = removeMembers (fst (graphvars subject sargs)) stricts
match` = removeMembers (fst (graphvars subject` sargs)) stricts
where match = fst (graphvars subject sargs)--stricts
match` = fst (graphvars subject` sargs)--stricts
// See if second argument list has the first one as its initial part
startswith
......@@ -355,7 +367,7 @@ tryunfold ::
& == pvar
tryunfold redexroot rule matching spine
= act
= act <--- "loop.tryunfold ends"
where act continue history failinfo instdone stricts sroot subject heap
= Reduce reductroot trace
where (heap`,sroot`,subject`,matching`)
......@@ -373,7 +385,7 @@ tryannotate
| == var
tryannotate strictnode sargs
= act
= act <--- "loop.tryannotate ends"
where act continue history failinfo instdone stricts sroot subject heap
| not instdone && isMember strictnode sargs
= Annotate trace
......@@ -388,5 +400,5 @@ dostop
:: Action sym var pvar
dostop
= ds
= ds <--- "loop.dostop ends"
where ds continue history failinfo instdone stricts sroot subject heap = Stop
......@@ -110,9 +110,11 @@ fullfold ::
| == sym
& == var
& == pvar
& toString sym
& toString var
& toString pvar
& <<< var
& toString sym
& <<< pvar
fullfold trc foldarea fnsymbol trace
| recursive ---> "newfold.fullfold begins"
......@@ -140,9 +142,11 @@ recurse ::
| == sym
& == var
& == pvar
& toString sym
& toString var
& toString pvar
& <<< var
& toString sym
& <<< pvar
recurse foldarea fnsymbol
= ((f--->"newfold.recurse.f begins from newfold.recurse") ([],[]) <--- "newfold.recurse ends") ---> "newfold.recurse begins"
......@@ -195,22 +199,22 @@ foldtips foldarea foldcont
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)"
-> (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"
where deltanodes = foldoptional [] getdeltanodes answer
rnfnodes = foldoptional [ruleroot rule] (const []) answer
Instantiate 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)"
where ft` (False,yessra) (False,nosra) = (exres <--- "newfold.foldtips.ft ends (Instantiate/no)") ---> "newfold.foldtips.ft case Instantiate/no"
ft` (yesfound,(yesstricts,yesbody,yesareas)) (nofound,(nostricts,nobody,noareas))
= (True,(stricts,matchpattern answer yesbody nobody,yesareas++noareas)) <--- "newfold.foldtips.ft ends (Instantiate/yes)"
= ((True,(stricts,matchpattern answer yesbody nobody,yesareas++noareas)) <--- "newfold.foldtips.ft ends (Instantiate/yes)") ---> "newfold.foldtips.ft case Instantiate/yes"
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)"
ft` (found,sra) = (True,sra) <--- "newfold.foldtips.ft ends (Reduce/yes)"
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"
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)"
ft` (found,sra) = (True,sra) <--- "newfold.foldtips.ft ends (Annotate/yes)"
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"
where (Trace stricts rule answer _ transf) = trace
exres = (False,newextract noetrc foldarea trace)
......@@ -301,7 +305,7 @@ buildgraph ::
-> FuncBody sym var | == var
buildgraph args root graph </