Commit 003d581d authored by Vincent Zweije's avatar Vincent Zweije
Browse files

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

which included commits to RCS files with non-trunk default branches.
parent 3a2f3fe0
......@@ -314,4 +314,4 @@ zipwith f xs ys = [f x y \\ x<-xs & y<-ys]
(writeList) infixl :: !*File [a] -> .File | <<< a
(writeList) file [] = file
(writeList) file [x:xs]
= file <<< x writeList xs
= file <<< x <<< nl writeList xs
......@@ -114,9 +114,9 @@ localheap =: [0..]
foldarea :: ((Rgraph sym var) -> sym) (Rgraph sym var) -> Node sym var | == var
foldarea label rgraph
= ((id (labelrgraph,foldsingleton single nosingle rgraph)) <--- "canon.foldarea ends") ---> "canon.foldarea begins"
where single root sym args = args
nosingle = snd (graphvars (rgraphgraph rgraph) [rgraphroot 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]))
labelrgraph = (label rgraph <--- "canon.foldarea.labelrgraph ends") ---> "canon.foldarea.labelrgraph begins"
/*
......
......@@ -105,7 +105,7 @@ Abstype implementation.
> stripexports :: [char] -> cli -> cli
*/
:: Cli :== Module SuclSymbol SuclVariable SuclTypeSymbol SuclTypeVariable
:: Cli = CliAlias (Module SuclSymbol SuclVariable SuclTypeSymbol SuclTypeVariable)
/*
> cli == module symbol node typesymbol typenode
......@@ -121,14 +121,14 @@ Abstype implementation.
*/
exports :: Cli -> [SuclSymbol]
exports m = m.exportedsymbols
exports (CliAlias m) = m.exportedsymbols
/*
> typerule (tdefs,(es,as,ts,rs)) = maxtyperule ts
*/
typerule :: Cli SuclSymbol -> Rule SuclTypeSymbol SuclTypeVariable
typerule m sym
typerule (CliAlias m) sym
= maxtyperule m.typerules sym
/*
......@@ -153,7 +153,7 @@ typerule m sym
*/
clistrategy :: Cli ((Graph SuclSymbol SuclVariable) SuclVariable var -> Bool) -> Strategy SuclSymbol var SuclVariable answer | == var
clistrategy {arities=as,typeconstructors=tcs,typerules=ts,rules=rs} matchable
clistrategy (CliAlias {arities=as,typeconstructors=tcs,typerules=ts,rules=rs}) matchable
= ( checkarity (extendfn as (typearity o maxtyperule ts)) // Checks curried occurrences and strict arguments
o checklaws cleanlaws // Checks for special (hard coded) rules (+x0=x /y1=y ...)
o checkrules matchable (foldmap id [] rs) // Checks normal rewrite rules
......@@ -182,7 +182,7 @@ maxstricts defs sym = extendfn defs corestricts sym
*/
complete :: Cli -> [SuclSymbol] -> Bool
complete m = mkclicomplete m.typeconstructors (maxtyperule m.typerules)
complete (CliAlias m) = mkclicomplete m.typeconstructors (maxtyperule m.typerules)
/*
> showcli = printcli
......@@ -326,10 +326,20 @@ mkcli ::
-> Cli
mkcli typerules stricts exports constrs bodies
= { arities = map (mapsnd fst) bodies
= CliAlias
{ arities = map (mapsnd fst) bodies
, typeconstructors = constrs
, exportedsymbols = exports
, typerules = typerules
, stricts = stricts
, rules = map (mapsnd snd) bodies
}
instance <<< Cli
where (<<<) file (CliAlias m)
= file <<< "=== Arities ===" <<< nl
writeList m.arities
<<< "=== Type Rules ===" <<< nl
writeList m.typerules
<<< "=== Rules ===" <<< nl
writeList m.rules
......@@ -97,20 +97,20 @@ varcontents (GraphAlias pfun) v
graphvars :: .(Graph sym var) !.[var] -> (.[var],.[var]) | == var
graphvars graph roots
= graphvars` [] graph roots
= (graphvars` [] graph roots<---"graph.graphvars ends")--->"graph.graphvars begins"
// 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 (prune,([],[])) roots)
where ns var (seen,boundfree=:(bound,free))
| isMember var seen = (seen,boundfree)
| not def = ([var:seen],(bound,[var:free]))
= (seen`,([var:bound`],free`))
where (seen`,(bound`,free`)) = foldlr ns ([var:seen],boundfree) args
= (snd (foldlr (ns--->"graph.graphvars`.ns begins from graph.graphvars`") (prune,([],[])) roots)<---"graph.graphvars` ends")--->"graph.graphvars` begins"
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
(def,(_,args)) = varcontents graph var
(seen,boundfree=:(bound,free)) = seenboundfree
varlist :: .(Graph sym var) !.[var] -> .[var] | == var
varlist graph roots
= depthfirst arguments id roots
......
......@@ -9,6 +9,8 @@ from history import HistoryAssociation,HistoryPattern
from rule import Rgraph,Rule
from graph import Graph
from StdOverloaded import ==
from StdFile import <<<
from StdString import toString
from strat import Substrategy,Subspine // for Strategy
from trace import History,Transformation // for Trace
......@@ -24,6 +26,9 @@ loop
| == sym
& == var
& == pvar
& toString sym // Debugging
& toString var // Debugging
& <<< var // Debugging
initrule
:: ![var]
......
......@@ -11,7 +11,7 @@ import rule
import graph
import pfun
import basic
from general import Yes,No,--->
from general import Yes,No
import StdEnv
/*
......@@ -224,11 +224,14 @@ loop
| == sym
& == var
& == pvar
& toString sym // Debugging
& toString var // Debugging
& <<< var // Debugging
loop strategy matchable (initheap,rule)
= maketrace inithistory initfailinfo initinstdone initstricts initsroot initsubject initheap
where maketrace history failinfo instdone stricts sroot subject heap
= 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
where answer = makernfstrategy history (strategy matchable`) rnfnodes sroot subject
transf = transform sroot sargs answer maketrace history failinfo instdone stricts sroot subject heap
......
......@@ -110,6 +110,9 @@ fullfold ::
| == sym
& == var
& == pvar
& toString var
& <<< var
& toString sym
fullfold trc foldarea fnsymbol trace
| recursive ---> "newfold.fullfold begins"
......@@ -137,30 +140,36 @@ recurse ::
| == sym
& == var
& == pvar
& toString var
& <<< var
& toString sym
recurse foldarea fnsymbol
= (f ([],[]) <--- "newfold.recurse ends") ---> "newfold.recurse begins"
where f newhisthist (Trace stricts rule answer history (Reduce reductroot trace))
| isEmpty pclosed && superset popen ropen
= f (newhist`,newhist`) trace
= ((f--->"newfold.recurse.f begins from newfold.recurse") ([],[]) <--- "newfold.recurse ends") ---> "newfold.recurse begins"
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"
where rargs = arguments rule; rroot = ruleroot rule; rgraph = rulegraph rule
(pclosed,popen) = graphvars rgraph rargs
(_,ropen) = graphvars rgraph [rroot]
newhist` = [(rroot,rgraph):newhist]
(newhist,hist) = newhisthist
(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)"
f newhisthist (Trace stricts rule answer history (Annotate trace))
| isEmpty pclosed && superset popen ropen
= f (newhist`,hist) trace
= ((f--->"newfold.recurse.f begins (from Annotate)") (newhist`,hist) trace <--- "newfold.recurse.f ends (valid Annotate)") ---> "f: Annotate"
where rargs = arguments rule; rroot = ruleroot rule; rgraph = rulegraph rule
(pclosed,popen) = graphvars rgraph rargs
(_,ropen) = graphvars rgraph [rroot]
(pclosed,popen) = graphvars rgraph rargs ---> "get (pclosed,popen)"
(_,ropen) = graphvars rgraph [rroot] ---> "get ropen"
newhist` = [(rroot,rgraph):newhist]
(newhist,hist) = newhisthist
(newhist,hist) = newhisthist ---> "get (newhist,hist)"
f newhisthist (Trace stricts rule answer history transf)
= foldtips foldarea (fnsymbol,arguments rule) (removeDup newhist`,removeDup hist) (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"
where rroot = ruleroot rule; rgraph = rulegraph rule
newhist` = [(rroot,rgraph):newhist]
(newhist,hist) = newhisthist
(newhist,hist) = newhisthist ---> "get (newhist,hist)"
/*
......@@ -182,26 +191,26 @@ foldtips ::
& == pvar
foldtips foldarea foldcont
= ft
= (ft--->"newfold.foldtips.ft begins from foldtips")<---"newfold.foldtips ends"
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)
-> foldoptional exres (pair True o addstrict stricts o mapfst rule2body) (actualfold deltanodes rnfnodes foldarea (==) foldcont (snd hist) rule) <--- "newfold.foldtips.ft ends (Stop)"
where deltanodes = foldoptional [] getdeltanodes answer
rnfnodes = foldoptional [ruleroot rule] (const []) answer
Instantiate yestrace notrace
-> ft` (ft hist yestrace) (ft hist notrace)
where ft` (False,yessra) (False,nosra) = exres
-> 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)"
ft` (yesfound,(yesstricts,yesbody,yesareas)) (nofound,(nostricts,nobody,noareas))
= (True,(stricts,matchpattern answer yesbody nobody,yesareas++noareas))
= (True,(stricts,matchpattern answer yesbody nobody,yesareas++noareas)) <--- "newfold.foldtips.ft ends (Instantiate/yes)"
Reduce reductroot trace
-> ft` (ft (fst hist,fst hist) trace)
where ft` (False,sra) = exres
ft` (found,sra) = (True,sra)
-> 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)"
Annotate trace
-> ft` (ft hist trace)
where ft` (False,sra) = exres
ft` (found,sra) = (True,sra)
-> 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 (Trace stricts rule answer _ transf) = trace
exres = (False,newextract noetrc foldarea trace)
......
......@@ -174,9 +174,10 @@ where (<<<) file srr
<<< "Task expression: " <<< ((srr.srr_task_expression <--- "newtest.<<<(Symredresult).srr_task_expression ends") ---> "newtest.<<<(Symredresult).srr_task_expression begins") <<< nl
<<< "Assigned symbol: " <<< toString (srr.srr_assigned_symbol) <<< nl
<<< "Strictness: " <<< srr.srr_strictness <<< nl
<<< "Type rule: ..." <<< nl
//<<< "Type rule: ..." <<< nl
<<< srr.srr_trace <<< nl
//<<< "Function definition: ..." <<< nl
//<<< "Function definition:" <<< nl
//<<< srr.srr_function_def
<<< "Areas:" <<< nl
writeareas srr.srr_areas
<<< "==[END]==" <<< nl
......@@ -307,7 +308,7 @@ fullsymred freshsymbols cli
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"
foldarea` = ((id (foldarea (labelarea` o canonise`))) <--- "newtest.fullsymred.foldarea` ends") ---> "newtest.fullsymred.foldarea` begins"
foldarea` = ((foldarea (labelarea` o canonise`)) <--- "newtest.fullsymred.foldarea` ends") ---> "newtest.fullsymred.foldarea` begins"
labelarea` = (labelarea (map getinit results) freshsymbols <--- "newtest.fullsymred.labelarea` ends") ---> "newtest.fullsymred.labelarea` begins"
canonise` = (canonise (typerule cli) suclheap <--- "newtest.fullsymred.canonise` ends") ---> "newtest.fullsymred.canonise` begins"
......
Supports Markdown
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