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

Translate module newtest (main module)

Cutoff points (undefs): fullfold from module newfold
                        continuations for strategy answers in module loop
parent f766d6f1
...@@ -27,17 +27,21 @@ $(SYS)/%.abc: %.icl ...@@ -27,17 +27,21 @@ $(SYS)/%.abc: %.icl
$(SYS)/supercompile.abc: supercompile.icl supercompile.dcl convert.dcl $(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)/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)/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)/coreclean.abc: coreclean.icl coreclean.dcl strat.dcl spine.dcl rule.dcl graph.dcl $(SYS)/newfold.abc: newfold.icl newfold.dcl trace.dcl spine.dcl history.dcl rule.dcl
$(SYS)/law.abc: law.icl law.dcl coreclean.dcl strat.dcl spine.dcl rule.dcl graph.dcl dnc.dcl basic.dcl $(SYS)/extract.abc: extract.icl extract.dcl
$(SYS)/loop.abc: loop.icl loop.dcl trace.dcl strat.dcl history.dcl rule.dcl graph.dcl basic.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)/strat.abc: strat.icl strat.dcl history.dcl spine.dcl dnc.dcl rule.dcl graph.dcl pfun.dcl basic.dcl $(SYS)/canon.abc: canon.icl canon.dcl rule.dcl graph.dcl basic.dcl
$(SYS)/history.abc: history.icl history.dcl spine.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)/spine.abc: spine.icl spine.dcl rule.dcl pfun.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)/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)/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)/trd.abc: trd.icl trd.dcl rule.dcl graph.dcl basic.dcl
$(SYS)/rule.abc: rule.icl 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 $(SYS)/dnc.abc: dnc.icl dnc.dcl graph.dcl
......
...@@ -3,8 +3,20 @@ definition module cli ...@@ -3,8 +3,20 @@ definition module cli
// $Id$ // $Id$
from coreclean import SuclSymbol,SuclVariable,SuclTypeSymbol,SuclTypeVariable from coreclean import SuclSymbol,SuclVariable,SuclTypeSymbol,SuclTypeVariable
from strat import Strategy
from rule import Rule from rule import Rule
from graph import Graph
from StdOverloaded import ==
// Transitive necessities
from strat import Substrategy
from spine import Spine,Subspine
from graph import Node
:: Cli :: Cli
typerule :: Cli SuclSymbol -> Rule SuclTypeSymbol SuclTypeVariable typerule :: Cli SuclSymbol -> Rule SuclTypeSymbol SuclTypeVariable
exports :: Cli -> [SuclSymbol]
complete :: Cli -> [SuclSymbol] -> Bool
clistrategy :: Cli ((Graph SuclSymbol SuclVariable) SuclVariable var -> Bool) -> Strategy SuclSymbol var SuclVariable answer | == var
...@@ -2,11 +2,12 @@ implementation module cli ...@@ -2,11 +2,12 @@ implementation module cli
// $Id$ // $Id$
import absmodule
import coreclean
import law import law
import coreclean
import strat import strat
import absmodule
import rule import rule
import dnc
import basic import basic
import StdEnv import StdEnv
...@@ -117,12 +118,18 @@ Abstype implementation. ...@@ -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)) > 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 (tdefs,(es,as,ts,rs)) = es
*/
exports :: Cli -> [SuclSymbol]
exports m = m.exportedsymbols
/*
> typerule (tdefs,(es,as,ts,rs)) = fst.maxtypeinfo ts > typerule (tdefs,(es,as,ts,rs)) = fst.maxtypeinfo ts
*/ */
typerule :: Cli SuclSymbol -> Rule SuclTypeSymbol SuclTypeVariable 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 > rules (tdefs,(es,as,ts,rs)) = foldmap Present Absent rs
...@@ -166,7 +173,12 @@ maxtypeinfo defs sym = extendfn defs coretypeinfo sym ...@@ -166,7 +173,12 @@ maxtypeinfo defs sym = extendfn defs coretypeinfo sym
> constrs ((tes,tas,tcs),defs) = tcs > constrs ((tes,tas,tcs),defs) = tcs
> complete ((tes,tas,tcs),(es,as,ts,rs)) = mkclicomplete tcs (fst.maxtypeinfo ts) > 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 > showcli = printcli
> mkclicomplete > mkclicomplete
...@@ -181,7 +193,24 @@ maxtypeinfo defs sym = extendfn defs coretypeinfo sym ...@@ -181,7 +193,24 @@ maxtypeinfo defs sym = extendfn defs coretypeinfo sym
> = foldmap superset (corecomplete tsym) tcs tsym syms, otherwise > = foldmap superset (corecomplete tsym) tcs tsym syms, otherwise
> where trule = typerule (hd syms) > where trule = typerule (hd syms)
> (tdef,(tsym,targs)) = dnc (const "in mkclicomplete") (rulegraph trule) (rhs trule) > (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] > printcli :: module symbol node typesymbol typenode -> [char]
......
...@@ -41,7 +41,7 @@ convert_fundef fundef (typerulemap,strictsmap,fundefs0,kindmap) ...@@ -41,7 +41,7 @@ convert_fundef fundef (typerulemap,strictsmap,fundefs0,kindmap)
, [(funsym,kind):kindmap] , [(funsym,kind):kindmap]
) )
where {fun_symb,fun_body,fun_type,fun_kind} = fundef where {fun_symb,fun_body,fun_type,fun_kind} = fundef
funsym = SuclUser fun_symb.id_info funsym = SuclUser fun_symb
(typerule,stricts) = foldoptional notyperule convert_symboltype fun_type (typerule,stricts) = foldoptional notyperule convert_symboltype fun_type
notyperule = abort "convert: convert_fundef: fun_type is absent" notyperule = abort "convert: convert_fundef: fun_type is absent"
fundefs1 = convert_functionbody funsym fun_body fundefs0 fundefs1 = convert_functionbody funsym fun_body fundefs0
...@@ -188,7 +188,7 @@ convert_expression bounds (App appinfo) ((heap0,seen0),(nodes0,fundefs0,globals0 ...@@ -188,7 +188,7 @@ convert_expression bounds (App appinfo) ((heap0,seen0),(nodes0,fundefs0,globals0
where [root:heap1] = heap0 where [root:heap1] = heap0
((heap2,seen1),(nodes1,fundefs1,globals1,args0)) ((heap2,seen1),(nodes1,fundefs1,globals1,args0))
= convert_expressions bounds appinfo.app_args ((heap1,seen0),(nodes0,fundefs0,globals0)) = convert_expressions bounds appinfo.app_args ((heap1,seen0),(nodes0,fundefs0,globals0))
nodes2 = [(root,(SuclUser appinfo.app_symb.symb_name.id_info,args0)):nodes1] nodes2 = [(root,(SuclUser appinfo.app_symb.symb_name,args0)):nodes1]
convert_expression bounds (expr @ exprs) ((heap0,seen0),(nodes0,fundefs0,globals0,rest)) convert_expression bounds (expr @ exprs) ((heap0,seen0),(nodes0,fundefs0,globals0,rest))
= ((heap2,seen1),(nodes2,fundefs1,globals1,[root:rest])) = ((heap2,seen1),(nodes2,fundefs1,globals1,[root:rest]))
...@@ -270,7 +270,7 @@ convert_algebraic_pattern ap ((heap0,seen0),(nodes0,rest)) ...@@ -270,7 +270,7 @@ convert_algebraic_pattern ap ((heap0,seen0),(nodes0,rest))
argmap = [(fv.fv_info_ptr,SuclNamed fv.fv_info_ptr) \\ fv <- ap.ap_vars] argmap = [(fv.fv_info_ptr,SuclNamed fv.fv_info_ptr) \\ fv <- ap.ap_vars]
seen1 = argmap++seen0 seen1 = argmap++seen0
args0 = map snd argmap args0 = map snd argmap
nodes1 = [(root,(SuclUser ap.ap_symbol.glob_object.ds_ident.id_info,args0)):nodes0] nodes1 = [(root,(SuclUser ap.ap_symbol.glob_object.ds_ident,args0)):nodes0]
convert_basic_branch branch ((heap0,seen0),(globals0,fundefs0,alternatives0)) convert_basic_branch branch ((heap0,seen0),(globals0,fundefs0,alternatives0))
= ((heap2,seen2),(globals1,fundefs1,alternatives1)) = ((heap2,seen2),(globals1,fundefs1,alternatives1))
...@@ -313,4 +313,4 @@ cts_exports :: {#FunType} -> [SuclSymbol] ...@@ -313,4 +313,4 @@ cts_exports :: {#FunType} -> [SuclSymbol]
cts_exports funtypes = [convert_funtype funtype\\funtype<-:funtypes] cts_exports funtypes = [convert_funtype funtype\\funtype<-:funtypes]
convert_funtype :: FunType -> SuclSymbol convert_funtype :: FunType -> SuclSymbol
convert_funtype funtype = SuclUser funtype.ft_symb.id_info convert_funtype funtype = SuclUser funtype.ft_symb
...@@ -34,10 +34,11 @@ from StdString import String ...@@ -34,10 +34,11 @@ from StdString import String
sucltypeheap :: [SuclTypeVariable] sucltypeheap :: [SuclTypeVariable]
:: SuclSymbol :: SuclSymbol
= SuclUser SymbolPtr = SuclUser Ident
| SuclCase ExprInfoPtr | SuclCase ExprInfoPtr
| SuclApply Int | SuclApply Int
| SuclInt Int | SuclInt Int
| SuclChar Char
| SuclReal Real | SuclReal Real
| SuclBool Bool | SuclBool Bool
...@@ -52,8 +53,13 @@ sucltypeheap :: [SuclTypeVariable] ...@@ -52,8 +53,13 @@ sucltypeheap :: [SuclTypeVariable]
suclheap :: [SuclVariable] suclheap :: [SuclVariable]
instance == SuclTypeSymbol
instance == SuclTypeVariable
instance == SuclSymbol instance == SuclSymbol
instance == SuclVariable instance == SuclVariable
// Get the type rule and strictness of a built in core clean symbol // Get the type rule and strictness of a built in core clean symbol
coretypeinfo :: SuclSymbol -> (Rule SuclTypeSymbol SuclTypeVariable,[Bool]) coretypeinfo :: SuclSymbol -> (Rule SuclTypeSymbol SuclTypeVariable,[Bool])
// Determine if a list of constructors completely covers a given type
corecomplete :: SuclTypeSymbol -> [SuclSymbol] -> Bool
...@@ -6,7 +6,10 @@ import strat ...@@ -6,7 +6,10 @@ import strat
import spine import spine
import rule import rule
import graph import graph
import basic
import StdCompare
import syntax import syntax
//import StdEnv
:: SuclTypeSymbol :: SuclTypeSymbol
= SuclUSER TypeSymbIdent = SuclUSER TypeSymbIdent
...@@ -27,10 +30,11 @@ sucltypeheap :: [SuclTypeVariable] ...@@ -27,10 +30,11 @@ sucltypeheap :: [SuclTypeVariable]
sucltypeheap =: map SuclANONYMOUS [0..] sucltypeheap =: map SuclANONYMOUS [0..]
:: SuclSymbol :: SuclSymbol
= SuclUser SymbolPtr = SuclUser Ident
| SuclCase ExprInfoPtr | SuclCase ExprInfoPtr
| SuclApply Int | SuclApply Int
| SuclInt Int | SuclInt Int
| SuclChar Char
| SuclReal Real | SuclReal Real
| SuclBool Bool | SuclBool Bool
...@@ -46,8 +50,25 @@ sucltypeheap =: map SuclANONYMOUS [0..] ...@@ -46,8 +50,25 @@ sucltypeheap =: map SuclANONYMOUS [0..]
suclheap :: [SuclVariable] suclheap :: [SuclVariable]
suclheap =: map SuclAnonymous [0..] suclheap =: map SuclAnonymous [0..]
instance == SuclTypeSymbol
where (==) (SuclUSER tsid1 ) (SuclUSER tsid2 ) = tsid1==tsid2
(==) (SuclFN arity1) (SuclFN arity2) = arity1==arity2
(==) SuclINT SuclINT = True
(==) SuclCHAR SuclCHAR = True
(==) SuclREAL SuclREAL = True
(==) SuclBOOL SuclBOOL = True
(==) SuclDYNAMIC SuclDYNAMIC = True
(==) SuclFILE SuclFILE = True
(==) SuclWORLD SuclWORLD = True
(==) _ _ = False
instance == SuclTypeVariable
where (==) (SuclANONYMOUS i1) (SuclANONYMOUS i2) = i1 == i2
(==) (SuclNAMED p1) (SuclNAMED p2) = p1 == p2
(==) _ _ = False
instance == SuclSymbol instance == SuclSymbol
where (==) (SuclUser sptr1) (SuclUser sptr2) = sptr1 == sptr2 where (==) (SuclUser id1 ) (SuclUser id2 ) = id1 == id2
(==) (SuclCase eptr1) (SuclCase eptr2) = eptr1 == eptr2 (==) (SuclCase eptr1) (SuclCase eptr2) = eptr1 == eptr2
(==) (SuclApply int1 ) (SuclApply int2 ) = int1 == int2 (==) (SuclApply int1 ) (SuclApply int2 ) = int1 == int2
(==) (SuclInt int1 ) (SuclInt int2 ) = int1 == int2 (==) (SuclInt int1 ) (SuclInt int2 ) = int1 == int2
...@@ -78,6 +99,7 @@ coretyperule (SuclApply argc) ...@@ -78,6 +99,7 @@ coretyperule (SuclApply argc)
(restype,emptygraph) (restype,emptygraph)
(outfunctype,updategraph outfunctype (SuclFN (argc-1),argtypes++[restype]) emptygraph) (outfunctype,updategraph outfunctype (SuclFN (argc-1),argtypes++[restype]) emptygraph)
coretyperule (SuclInt _) = consttyperule SuclINT coretyperule (SuclInt _) = consttyperule SuclINT
coretyperule (SuclChar _) = consttyperule SuclCHAR
coretyperule (SuclReal _) = consttyperule SuclREAL coretyperule (SuclReal _) = consttyperule SuclREAL
coretyperule (SuclBool _) = consttyperule SuclBOOL coretyperule (SuclBool _) = consttyperule SuclBOOL
coretyperule (SuclUser _) = abort "coreclean: coretyperule: untyped user symbol" coretyperule (SuclUser _) = abort "coreclean: coretyperule: untyped user symbol"
...@@ -86,3 +108,15 @@ coretyperule (SuclCase _) = abort "coreclean: coretyperule: untyped case symbol" ...@@ -86,3 +108,15 @@ coretyperule (SuclCase _) = abort "coreclean: coretyperule: untyped case symbol"
consttyperule tsym consttyperule tsym
= mkrule [] root (updategraph root (tsym,[]) emptygraph) = mkrule [] root (updategraph root (tsym,[]) emptygraph)
where root = SuclANONYMOUS 0 where root = SuclANONYMOUS 0
corecomplete :: SuclTypeSymbol -> [SuclSymbol] -> Bool
corecomplete (SuclUSER tsid) = const False // Must be an abstype...
corecomplete (SuclFN arity) = const False
corecomplete SuclINT = const False
corecomplete SuclCHAR = superset (map (SuclChar o toChar) [0..255]) // 256 alternatives... doubtful is this is useful, but hey...
corecomplete SuclREAL = const False
corecomplete SuclBOOL = superset (map SuclBool [False,True])
corecomplete SuclDYNAMIC = const False
corecomplete SuclFILE = const False
corecomplete SuclWORLD = const False
...@@ -2,7 +2,6 @@ implementation module history ...@@ -2,7 +2,6 @@ implementation module history
// $Id$ // $Id$
import spine
import rule import rule
import graph import graph
import pfun import pfun
......
...@@ -6,8 +6,8 @@ import coreclean ...@@ -6,8 +6,8 @@ import coreclean
import strat import strat
import spine import spine
import rule import rule
import graph
import dnc import dnc
import graph
import basic import basic
import StdEnv import StdEnv
......
...@@ -3,18 +3,18 @@ definition module loop ...@@ -3,18 +3,18 @@ definition module loop
// $Id$ // $Id$
from strat import Strategy from strat import Strategy
from spine import Answer
from trace import Trace from trace import Trace
from spine import Answer
from history import HistoryAssociation,HistoryPattern from history import HistoryAssociation,HistoryPattern
from rule import Rgraph,Rule from rule import Rgraph,Rule
from graph import Graph from graph import Graph
from StdOverloaded import == from StdOverloaded import ==
from strat import Substrategy,Subspine // for Strategy 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 graph import Node // for Strategy
from basic import Optional // for Answer from basic import Optional // for Answer
from spine import Spine // for Answer
from trace import History,Transformation // for Trace
loop loop
:: (((Graph sym pvar) pvar var -> ub:Bool) -> Strategy sym var pvar (Answer sym var pvar)) :: (((Graph sym pvar) pvar var -> ub:Bool) -> Strategy sym var pvar (Answer sym var pvar))
......
...@@ -2,10 +2,10 @@ implementation module loop ...@@ -2,10 +2,10 @@ implementation module loop
// $Id$ // $Id$
import trace
import strat import strat
import history import trace
import spine import spine
import history
import rewr import rewr
import rule import rule
import graph import graph
...@@ -245,7 +245,9 @@ loop strategy matchable (initheap,rule) ...@@ -245,7 +245,9 @@ loop strategy matchable (initheap,rule)
sargs = arguments rule; initsroot = ruleroot rule; initsubject = rulegraph rule sargs = arguments rule; initsroot = ruleroot rule; initsubject = rulegraph rule
listselect :: [.Bool] [.elem] -> [.elem] 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 initrule
:: ![var] :: ![var]
......
definition module newfold definition module newfold
// $Id$
from trace import Trace,Transformation
from spine import Answer,Spine,Subspine
from history import History,HistoryAssociation,HistoryPattern
from rule import Rgraph,Rule
from general import Optional
:: Etracer sym var pvar :==
(Trace sym var pvar)
(Rgraph sym var)
Bool
-> Bool
fullfold ::
(Etracer sym var pvar)
((Rgraph sym var)->(sym,[var]))
sym
(Trace sym var pvar)
-> ([Bool],[Rule sym var],[Rgraph sym var])
...@@ -2,6 +2,10 @@ implementation module newfold ...@@ -2,6 +2,10 @@ implementation module newfold
// $Id$ // $Id$
import trace
import rule
import StdEnv
/* /*
newfold.lit - New folding function newfold.lit - New folding function
...@@ -86,8 +90,25 @@ occurs within any subtrace. ...@@ -86,8 +90,25 @@ occurs within any subtrace.
>|| = mapfst3 only (extract trc foldarea trace ([],[],[])), otherwise >|| = mapfst3 only (extract trc foldarea trace ([],[],[])), otherwise
> = newextract trc foldarea trace, otherwise > = newextract trc foldarea trace, otherwise
> where (recursive,recurseresult) = recurse foldarea fnsymbol trace > 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)'. `Recurse foldarea fnsymbol trace' is a pair `(recursive,recurseresult)'.
`Recurseresult' is the derived function definition (strictness, rules, `Recurseresult' is the derived function definition (strictness, rules,
and new areas), obtained by folding the trace. `Recurse' tries to fold and new areas), obtained by folding the trace. `Recurse' tries to fold
...@@ -193,7 +214,15 @@ in the supertrace. ...@@ -193,7 +214,15 @@ in the supertrace.
> rgraph * ** -> > rgraph * ** ->
> bool -> > bool ->
> bool > bool
*/
:: Etracer sym var pvar :==
(Trace sym var pvar)
(Rgraph sym var)
Bool
-> Bool
/*
> extract > extract
> :: etracer * ** *** -> > :: etracer * ** *** ->
> (rgraph * **->(*,[**])) -> > (rgraph * **->(*,[**])) ->
......
definition module newtest definition module newtest
// $Id$
from cli import Cli
from coreclean import SuclTypeSymbol,SuclTypeVariable,SuclSymbol,SuclVariable
from trace import Trace,Transformation
from spine import Answer,Spine,Subspine
from history import History,HistoryAssociation,HistoryPattern
from rule import Rgraph,Rule
from general import Optional
:: 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)
)
fullsymred ::
[SuclSymbol] // Fresh function symbols
Cli // Module to optimise
-> [Symredresult SuclSymbol SuclVariable SuclTypeSymbol SuclTypeVariable]
...@@ -4,6 +4,13 @@ implementation module newtest ...@@ -4,6 +4,13 @@ implementation module newtest
import cli import cli
import coreclean import coreclean
import newfold
import complete
import trd
import loop
import trace
import rule
import graph
import canon import canon
import basic import basic
import StdEnv import StdEnv
...@@ -138,7 +145,19 @@ these tuples. ...@@ -138,7 +145,19 @@ these tuples.
> [rule * **], || Resulting rewrite rules > [rule * **], || Resulting rewrite rules
> [rgraph * **] || New areas for further symbolic reduction (not necessarily canonical) > [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