aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--sucl/Makefile22
-rw-r--r--sucl/cli.icl35
-rw-r--r--sucl/history.icl1
-rw-r--r--sucl/law.icl2
-rw-r--r--sucl/loop.dcl6
-rw-r--r--sucl/loop.icl8
-rw-r--r--sucl/newfold.icl29
-rw-r--r--sucl/newtest.icl100
-rw-r--r--sucl/strat.dcl2
-rw-r--r--sucl/strat.icl4
-rw-r--r--sucl/trace.dcl5
-rw-r--r--sucl/trace.icl2
12 files changed, 184 insertions, 32 deletions
diff --git a/sucl/Makefile b/sucl/Makefile
index 7732f75..79dd004 100644
--- a/sucl/Makefile
+++ b/sucl/Makefile
@@ -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
diff --git a/sucl/cli.icl b/sucl/cli.icl
index 5ce09a6..0f2d2c9 100644
--- a/sucl/cli.icl
+++ b/sucl/cli.icl
@@ -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]
diff --git a/sucl/history.icl b/sucl/history.icl
index 4ece980..a8d7c66 100644
--- a/sucl/history.icl
+++ b/sucl/history.icl
@@ -2,7 +2,6 @@ implementation module history
// $Id$
-import spine
import rule
import graph
import pfun
diff --git a/sucl/law.icl b/sucl/law.icl
index 1f14ee4..8ec781a 100644
--- a/sucl/law.icl
+++ b/sucl/law.icl
@@ -6,8 +6,8 @@ import coreclean
import strat
import spine
import rule
-import graph
import dnc
+import graph
import basic
import StdEnv
diff --git a/sucl/loop.dcl b/sucl/loop.dcl
index 2fcbe3f..d49c0d4 100644
--- a/sucl/loop.dcl
+++ b/sucl/loop.dcl
@@ -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))
diff --git a/sucl/loop.icl b/sucl/loop.icl
index 85d1233..ef750e5 100644
--- a/sucl/loop.icl
+++ b/sucl/loop.icl
@@ -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]
diff --git a/sucl/newfold.icl b/sucl/newfold.icl
index 6958f4b..31d5a79 100644
--- a/sucl/newfold.icl
+++ b/sucl/newfold.icl
@@ -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 * **->(*,[**])) ->
diff --git a/sucl/newtest.icl b/sucl/newtest.icl
index 9b65610..7c9e4bb 100644
--- a/sucl/newtest.icl
+++ b/sucl/newtest.icl
@@ -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
*/
diff --git a/sucl/strat.dcl b/sucl/strat.dcl
index 01589e0..1123a78 100644
--- a/sucl/strat.dcl
+++ b/sucl/strat.dcl
@@ -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 ==
diff --git a/sucl/strat.icl b/sucl/strat.icl
index 0f938b8..04ea9f9 100644
--- a/sucl/strat.icl
+++ b/sucl/strat.icl
@@ -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
diff --git a/sucl/trace.dcl b/sucl/trace.dcl
index f8e884d..6aafc88 100644
--- a/sucl/trace.dcl
+++ b/sucl/trace.dcl
@@ -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
diff --git a/sucl/trace.icl b/sucl/trace.icl
index 7429566..f2ff7b3 100644
--- a/sucl/trace.icl
+++ b/sucl/trace.icl
@@ -2,8 +2,8 @@ implementation module trace
// $Id$
-import history
import spine
+import history
import rule
import StdEnv