Commit 26f1b3df authored by Vincent Zweije's avatar Vincent Zweije
Browse files

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

which included commits to RCS files with non-trunk default branches.
parent 9510cff0
......@@ -27,17 +27,21 @@ $(SYS)/%.abc: %.icl
$(SYS)/supercompile.abc: supercompile.icl supercompile.dcl convert.dcl
$(SYS)/convert.abc: convert.icl convert.dcl coreclean.dcl rule.dcl graph.dcl basic.dcl
$(SYS)/cli.abc: cli.icl cli.dcl absmodule.dcl coreclean.dcl law.dcl strat.dcl rule.dcl basic.dcl
$(SYS)/coreclean.abc: coreclean.icl coreclean.dcl strat.dcl spine.dcl rule.dcl graph.dcl
$(SYS)/law.abc: law.icl law.dcl coreclean.dcl strat.dcl spine.dcl rule.dcl graph.dcl dnc.dcl basic.dcl
$(SYS)/loop.abc: loop.icl loop.dcl trace.dcl strat.dcl history.dcl rule.dcl graph.dcl basic.dcl
$(SYS)/strat.abc: strat.icl strat.dcl history.dcl spine.dcl dnc.dcl rule.dcl graph.dcl pfun.dcl basic.dcl
$(SYS)/history.abc: history.icl history.dcl spine.dcl rule.dcl graph.dcl basic.dcl
$(SYS)/spine.abc: spine.icl spine.dcl rule.dcl pfun.dcl basic.dcl
$(SYS)/newtest.abc: newtest.icl newtest.dcl newfold.dcl cli.dcl canon.dcl coreclean.dcl loop.dcl trace.dcl spine.dcl history.dcl complete.dcl trd.dcl rule.dcl graph.dcl basic.dcl
$(SYS)/newfold.abc: newfold.icl newfold.dcl trace.dcl spine.dcl history.dcl rule.dcl
$(SYS)/extract.abc: extract.icl extract.dcl
$(SYS)/cli.abc: cli.icl cli.dcl law.dcl coreclean.dcl strat.dcl absmodule.dcl rule.dcl dnc.dcl graph.dcl basic.dcl
$(SYS)/canon.abc: canon.icl canon.dcl rule.dcl graph.dcl basic.dcl
$(SYS)/law.abc: law.icl law.dcl coreclean.dcl strat.dcl spine.dcl rule.dcl dnc.dcl graph.dcl basic.dcl
$(SYS)/coreclean.abc: coreclean.icl coreclean.dcl strat.dcl spine.dcl rule.dcl graph.dcl basic.dcl
$(SYS)/loop.abc: loop.icl loop.dcl strat.dcl trace.dcl spine.dcl history.dcl rewr.dcl rule.dcl graph.dcl pfun.dcl basic.dcl
$(SYS)/strat.abc: strat.icl strat.dcl spine.dcl history.dcl rule.dcl dnc.dcl graph.dcl pfun.dcl basic.dcl
$(SYS)/absmodule.abc: absmodule.icl absmodule.dcl rule.dcl
$(SYS)/trace.abc: trace.icl trace.dcl rule.dcl
$(SYS)/trace.abc: trace.icl trace.dcl spine.dcl history.dcl rule.dcl basic.dcl
$(SYS)/spine.abc: spine.icl spine.dcl history.dcl rule.dcl graph.dcl pfun.dcl basic.dcl
$(SYS)/history.abc: history.icl history.dcl rule.dcl graph.dcl pfun.dcl basic.dcl
$(SYS)/complete.abc: complete.icl complete.dcl graph.dcl
$(SYS)/rewr.abc: rewr.icl rewr.dcl graph.dcl pfun.dcl basic.dcl
$(SYS)/rewr.abc: rewr.icl rewr.dcl rule.dcl graph.dcl pfun.dcl basic.dcl
$(SYS)/trd.abc: trd.icl trd.dcl rule.dcl graph.dcl basic.dcl
$(SYS)/rule.abc: rule.icl rule.dcl graph.dcl basic.dcl
$(SYS)/dnc.abc: dnc.icl dnc.dcl graph.dcl
......
......@@ -2,11 +2,12 @@ implementation module cli
// $Id$
import absmodule
import coreclean
import law
import coreclean
import strat
import absmodule
import rule
import dnc
import basic
import StdEnv
......@@ -117,12 +118,18 @@ Abstype implementation.
> stripexports main (tdefs,(es,as,ts,rs)) = (tdefs,([User m i|User m i<-es;m=main],as,ts,rs))
> exports (tdefs,(es,as,ts,rs)) = es
*/
exports :: Cli -> [SuclSymbol]
exports m = m.exportedsymbols
/*
> typerule (tdefs,(es,as,ts,rs)) = fst.maxtypeinfo ts
*/
typerule :: Cli SuclSymbol -> Rule SuclTypeSymbol SuclTypeVariable
typerule _ _ = undef
typerule m sym
= fst (maxtypeinfo m.typerules sym)
/*
> rules (tdefs,(es,as,ts,rs)) = foldmap Present Absent rs
......@@ -166,7 +173,12 @@ maxtypeinfo defs sym = extendfn defs coretypeinfo sym
> constrs ((tes,tas,tcs),defs) = tcs
> complete ((tes,tas,tcs),(es,as,ts,rs)) = mkclicomplete tcs (fst.maxtypeinfo ts)
*/
complete :: Cli -> [SuclSymbol] -> Bool
complete m = mkclicomplete m.typeconstructors (fst o maxtypeinfo m.typerules)
/*
> showcli = printcli
> mkclicomplete
......@@ -181,7 +193,24 @@ maxtypeinfo defs sym = extendfn defs coretypeinfo sym
> = foldmap superset (corecomplete tsym) tcs tsym syms, otherwise
> where trule = typerule (hd syms)
> (tdef,(tsym,targs)) = dnc (const "in mkclicomplete") (rulegraph trule) (rhs trule)
*/
mkclicomplete ::
[(SuclTypeSymbol,[SuclSymbol])]
(SuclSymbol->Rule SuclTypeSymbol tvar)
[SuclSymbol]
-> Bool
| == tvar
mkclicomplete tcs typerule [] = False
mkclicomplete tcs typerule syms
| not tdef
= False
= foldmap superset (corecomplete tsym) tcs tsym syms
where trule = typerule (hd syms)
(tdef,(tsym,_)) = dnc (const "in mkclicomplete") (rulegraph trule) (ruleroot trule)
/*
------------------------------------------------------------------------
> printcli :: module symbol node typesymbol typenode -> [char]
......
......@@ -2,7 +2,6 @@ implementation module history
// $Id$
import spine
import rule
import graph
import pfun
......
......@@ -6,8 +6,8 @@ import coreclean
import strat
import spine
import rule
import graph
import dnc
import graph
import basic
import StdEnv
......
......@@ -3,18 +3,18 @@ definition module loop
// $Id$
from strat import Strategy
from spine import Answer
from trace import Trace
from spine import Answer
from history import HistoryAssociation,HistoryPattern
from rule import Rgraph,Rule
from graph import Graph
from StdOverloaded import ==
from strat import Substrategy,Subspine // for Strategy
from trace import History,Transformation // for Trace
from spine import Spine // for Answer
from graph import Node // for Strategy
from basic import Optional // for Answer
from spine import Spine // for Answer
from trace import History,Transformation // for Trace
loop
:: (((Graph sym pvar) pvar var -> ub:Bool) -> Strategy sym var pvar (Answer sym var pvar))
......
......@@ -2,10 +2,10 @@ implementation module loop
// $Id$
import trace
import strat
import history
import trace
import spine
import history
import rewr
import rule
import graph
......@@ -245,7 +245,9 @@ loop strategy matchable (initheap,rule)
sargs = arguments rule; initsroot = ruleroot rule; initsubject = rulegraph rule
listselect :: [.Bool] [.elem] -> [.elem]
listselect _ _ = undef
listselect [True:bs] [x:xs] = [x:listselect bs xs]
listselect [False:bs] [x:xs] = listselect bs xs
listselect _ _ = []
initrule
:: ![var]
......
......@@ -2,6 +2,10 @@ implementation module newfold
// $Id$
import trace
import rule
import StdEnv
/*
newfold.lit - New folding function
......@@ -86,8 +90,25 @@ occurs within any subtrace.
>|| = mapfst3 only (extract trc foldarea trace ([],[],[])), otherwise
> = newextract trc foldarea trace, otherwise
> where (recursive,recurseresult) = recurse foldarea fnsymbol trace
*/
fullfold ::
(Etracer sym var pvar)
((Rgraph sym var)->(sym,[var]))
sym
(Trace sym var pvar)
-> ([Bool],[Rule sym var],[Rgraph sym var])
fullfold trc foldarea fnsymbol trace
| recursive
= recurseresult
= newextract trc foldarea trace
where (recursive,recurseresult) = recurse foldarea fnsymbol trace
recurse = undef
newextract = undef
/*
`Recurse foldarea fnsymbol trace' is a pair `(recursive,recurseresult)'.
`Recurseresult' is the derived function definition (strictness, rules,
and new areas), obtained by folding the trace. `Recurse' tries to fold
......@@ -193,7 +214,15 @@ in the supertrace.
> rgraph * ** ->
> bool ->
> bool
*/
:: Etracer sym var pvar :==
(Trace sym var pvar)
(Rgraph sym var)
Bool
-> Bool
/*
> extract
> :: etracer * ** *** ->
> (rgraph * **->(*,[**])) ->
......
......@@ -4,6 +4,13 @@ implementation module newtest
import cli
import coreclean
import newfold
import complete
import trd
import loop
import trace
import rule
import graph
import canon
import basic
import StdEnv
......@@ -138,7 +145,19 @@ these tuples.
> [rule * **], || Resulting rewrite rules
> [rgraph * **] || New areas for further symbolic reduction (not necessarily canonical)
> )
*/
:: Symredresult sym var tsym tvar
:== ( Rgraph sym var // The initial area in canonical form
, sym // The assigned symbol
, [Bool] // Strictness annotations
, Rule tsym tvar // Type rule
, Trace sym var var // Truncated and folded trace
, [Rule sym var] // Resulting rewrite rules
, [Rgraph sym var] // New areas for further symbolic reduction (not necessarily canonical)
)
/*
> listopt :: [char] -> [[char]] -> [char]
> listopt main = listnew main.loadclis
......@@ -253,7 +272,7 @@ these tuples.
fullsymred ::
[SuclSymbol] // Fresh function symbols
Cli // Module to optimise
-> [Symredresult symbol node typesymbol typenode]
-> [Symredresult SuclSymbol SuclVariable SuclTypeSymbol SuclTypeVariable]
fullsymred freshsymbols cli
= results
......@@ -265,11 +284,6 @@ fullsymred freshsymbols cli
labelarea` = labelarea (map getinit results) freshsymbols
canonise` = canonise (typerule cli) suclheap
initareas = undef
getareas = undef
symredarea = undef
getinit = undef
/*
`Initareas cli' is the list of initial rooted graphs that must be
symbolically reduced. An initial rooted graph is formed by applying an
......@@ -290,7 +304,23 @@ its type rule.
> getareas :: symredresult * ** **** ***** -> [rgraph * **]
> getareas (area,symbol,stricts,trule,trace,rules,areas) = areas
*/
initareas :: Cli -> [Rgraph SuclSymbol SuclVariable]
initareas cli
= map (initialise suclheap) (exports cli)
where initialise [root:nodes] symbol
= mkrgraph root (updategraph root (symbol,args) emptygraph)
where args = map2 const nodes targs
targs = arguments (typerule cli symbol)
getinit :: (Symredresult sym var tsym tvar) -> Rgraph sym var
getinit (area,symbol,stricts,trule,trace,rules,areas) = area
getareas :: (Symredresult sym var tsym tvar) -> [Rgraph sym var]
getareas (area,symbol,stricts,trule,trace,rules,areas) = areas
/*
`Symredarea' is the function that does symbolic reduction of a single
area.
......@@ -311,13 +341,38 @@ area.
> complete' = (~).converse matchable' (mkrgraph () emptygraph)
> matchable' = matchable (complete cli)
> strategy' = clistrategy cli
*/
:: Unit = Unit
symredarea ::
((Rgraph SuclSymbol SuclVariable)->(SuclSymbol,[SuclVariable]))
Cli
(Rgraph SuclSymbol SuclVariable)
-> Symredresult SuclSymbol SuclVariable SuclTypeSymbol SuclTypeVariable
symredarea foldarea cli area
= (area,symbol,stricts,trule,trace,rules,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
trace = loop strategy` matchable` (removeMembers suclheap (varlist agraph [aroot]),arule)
(stricts,rules,areas) = fullfold (trc symbol) foldarea symbol trace
matchable` = matchable (complete cli)
strategy` = clistrategy cli
/*
> trc :: symbol -> trace symbol node node -> rgraph symbol node -> bool -> bool
> trc symbol trace area recursive
> = error (lay ("Trace is recursive in area":printrgraph showsymbol shownode area:printtrace symbol showsymbol shownode shownode trace)), if esymbol symbol & recursive
> = recursive, otherwise
*/
trc symbol trace area recursive = recursive
/*
> esymbol (User m "E") = True
> esymbol symbol = False
......@@ -403,7 +458,20 @@ area.
> matchable complete patterns rgraph
> = ~coveredby complete (rgraphgraph rgraph) [(rgraphgraph pattern,[rgraphroot pattern])|pattern<-patterns] [rgraphroot rgraph]
*/
matchable ::
([sym]->Bool)
[Rgraph sym pvar]
(Rgraph sym var)
-> Bool
| == sym
& == var
& == pvar
matchable complete patterns rgraph
= not (coveredby complete (rgraphgraph rgraph) [(rgraphgraph pattern,[rgraphroot pattern]) \\ pattern<-patterns] [rgraphroot rgraph])
/*
------------------------------------------------------------------------
`Ctyperule' cli (sym,args)' is the typerule of an occurrence of symbol
......@@ -424,7 +492,25 @@ sym with the given arguments, curried if there are too few.
> (troot',tgraph',theap') = foldr build (troot,tgraph,typeheap--nodelist tgraph (troot:targs)) targs''
> build targ (troot,tgraph,tnode:tnodes)
> = (tnode,updategraph tnode (fn,[targ,troot]) tgraph,tnodes)
*/
> newsymbols main = map (User main.("New_"++)) identifiers
ctyperule ::
(Int -> tsym) // The arrow type symbol for functions of given arity
[tvar] // Fresh type variables
(sym->Rule tsym tvar) // Type rule of a symbol
(sym,[var]) // Node to abstract
-> Rule tsym tvar
| == tvar
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
(troot`,tgraph`,_) = foldr build (troot,tgraph,removeMembers typeheap (varlist tgraph [troot:targs])) targs``
build targ (troot,tgraph,[tnode:tnodes])
= (tnode,updategraph tnode (fn 1,[targ,troot]) tgraph,tnodes)
/*
> newsymbols main = map (User main.("New_"++)) identifiers
*/
......@@ -2,8 +2,8 @@ definition module strat
// $Id$
from history import History
from spine import Answer
from history import History
from rule import Rule
from graph import Graph,Node
from StdOverloaded import ==
......
......@@ -2,10 +2,10 @@ implementation module strat
// $Id$
import history
import spine
import dnc
import history
import rule
import dnc
import graph
import pfun
import basic
......
......@@ -2,9 +2,12 @@ definition module trace
// $Id$
from history import History,HistoryAssociation,HistoryPattern
from spine import Answer
from history import History,HistoryAssociation,HistoryPattern
from rule import Rule
// Transitive necessities
from spine import Spine,Subspine // for Answer
from rule import Rgraph // for History
from basic import Optional // for Answer
......
......@@ -2,8 +2,8 @@ implementation module trace
// $Id$
import history
import spine
import history
import rule
import StdEnv
......
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