Commit 1b246a8c authored by John van Groningen's avatar John van Groningen
Browse files

delete sucl, the same files can be found in the branch sucl

parent 1e943b4e
#! /usr/bin/make -f
# $Id$
COCL = cocl
#COCLFLAGS = -lat
SYS = Clean\ System\ Files
#SYS = .
MODULES = cleanversion basic pfun graph dnc rule trd rewr complete history spine trace absmodule strat loop coreclean law canon cli extract newfold newtest expand convert supercompile
ABC = $(patsubst %,$(SYS)/%.abc,$(MODULES))
#default: $(SYS)/history.abc $(SYS)/spine.abc $(SYS)/absmodule.abc $(SYS)/trace.abc $(SYS)/complete.abc $(SYS)/rewr.abc $(SYS)/trd.abc $(SYS)/rule.abc $(SYS)/dnc.abc $(SYS)/graph.abc $(SYS)/pfun.abc $(SYS)/pretty.abc $(SYS)/basic.abc
default: $(ABC)
clean:
rm -Rf errors.err $(SYS)
tags: *.dcl *.icl ../compiler/*.dcl ../compiler/*.icl
sh cleantags $^ >$@
%: $(SYS)/%.abc
@:
$(SYS)/%.abc: %.icl
$(COCL) $(COCLFLAGS) $*
$(SYS)/supercompile.abc: supercompile.icl supercompile.dcl convert.dcl expand.dcl newtest.dcl cli.dcl coreclean.dcl basic.dcl
$(SYS)/convert.abc: convert.icl convert.dcl coreclean.dcl rule.dcl graph.dcl basic.dcl
$(SYS)/expand.abc: expand.icl expand.dcl newtest.dcl newfold.dcl rule.dcl rewr.dcl graph.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 extract.dcl trace.dcl spine.dcl history.dcl rule.dcl dnc.dcl graph.dcl basic.dcl
$(SYS)/extract.abc: extract.icl extract.dcl rule.dcl dnc.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)/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 spine.dcl history.dcl rule.dcl graph.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 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
$(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)/basic.abc: basic.icl basic.dcl
$(SYS)/cleanversion.abc: cleanversion.icl cleanversion.dcl
definition module absmodule
// $Id$
from rule import Rule
:: Module sym pvar tsym tvar
= { arities :: [(sym,Int)] // Arity of each symbol
, typeconstructors :: [(tsym,[sym])] // All constructor symbols of each declared algebraic type
, exportedsymbols :: [sym] // Exported function/constructor symbols
, typerules :: [(sym,Rule tsym tvar)] // Principal types of symbols
, stricts :: [(sym,[Bool])] // Strict arguments of functions
, rules :: [(sym,[Rule sym pvar])] // Rewrite rules of each symbol, absent if imported
}
implementation module absmodule
// $Id$
import rule
/*
------------------------------------------------------------------------
Exports.
> %export
> module
> addtalias
> addtsymdef
> addalias
> addsymdef
> newmodule
------------------------------------------------------------------------
Includes.
> %include "basic.lit"
> %include "graph.lit" -extgraph
> %include "rule.lit"
------------------------------------------------------------------------
Module implementation.
*/
:: Module sym pvar tsym tvar
= { arities :: [(sym,Int)] // Arity of each symbol
, typeconstructors :: [(tsym,[sym])] // All constructor symbols of each declared algebraic type
, exportedsymbols :: [sym] // Exported function/constructor symbols
, typerules :: [(sym,Rule tsym tvar)] // Principal types of symbols
, stricts :: [(sym,[Bool])] // Strict arguments of functions
, rules :: [(sym,[Rule sym pvar])] // Rewrite rules of each symbol, absent if imported
}
definition module basic
// $Id$
/*
Basic definitions
=================
Description
-----------
Basic types and functions.
*/
from general import Optional
from StdFile import <<<
import StdOverloaded
import StdString
/*
Implementation
--------------
*/
// The optional type of type t is a type like t
// where the actual t value may be present or absent.
//:: Optional t = Absent | Present t
//Now using Optional from cocl's general module
instance == (Optional a) | == a
// Adjust a function for a single argument
adjust :: !arg res (arg->res) !arg -> res | == arg
// Claim a list of nodes from a heap
claim :: ![.param] u:[.cell] -> ([.cell],v:[.cell]), [u<=v]
// Cons prepends an element to a list
cons :: .elem u:[.elem] -> v:[.elem], [u <= v]
// Depthfirst does depth first enumeration of a search process
/* Depthfirst collects results of a function (called process), applied to a
given list of inputs and other inputs which are generated from the
results recursively, and so on. Duplicates are removed.
*/
depthfirst :: (res->.[elem]) (elem->res) !.[elem] -> .[res] | == elem
// `Disjoint xs ys' checks whether xs and ys are disjoint.
disjoint :: .[elem] !.[elem] -> Bool | == elem
// `Eqlen xs ys' determines whether `xs' and `ys' are equally long.
eqlen :: ![.elem1] ![.elem2] -> .Bool
// Extend a function using the elements of a mapping
extendfn :: [(src,dst)] (src->dst) src -> dst | == src
// `Foldlm' is a combination of foldl and map.
foldlm :: ((.collect,.elem) -> (.collect,.elem`)) !(.collect,![.elem]) -> (.collect,[.elem`])
// Foldlr combines foldl and foldr:
// Information flows both forward and backward through the list.
foldlr :: (.elem -> .((.lrinfo,.rlinfo) -> (.lrinfo,.rlinfo))) !(.lrinfo,.rlinfo) ![.elem] -> (.lrinfo,.rlinfo)
// Foldmap is the fold function for a map type (from arg to res) given by a list,
// deriving a total function from it giving res`.
foldmap :: (x:res -> w:res`) w:res` -> u:(![(arg,x:res)] -> v:(arg -> w:res`)) | == arg, [v u <= w, v <= x]
// Foldoptional is the standard fold for the optional type.
foldoptional :: .res .(.t -> .res) !(Optional .t) -> .res
// Force evaluation of first argument to root normal form before returning second
force :: !.a .b -> .b
// Forget drops a mapped value from a map given by a list.
forget :: val -> .(![.(val,res)] -> .[(val,res)]) | == val
// Indent a list of strings with spaces,
// except the first which is indented with a specific string.
indent :: .String -> .([.String] -> .[String])
// `Identifiers' is the list of all identifiers
identifiers :: [String]
// `Inccounter m f' increments counting function f by one at point m.
inccounter :: a (a->b) a -> b | == a & +,one b
// `Intersect xs ys' is the intersection of list `ys' with list `xs'.
intersect :: ![elem] [elem] -> .[elem] | == elem
// `Join x xss' is the join of the list of lists `xss', separated by `x'.
join :: a ![.[a]] -> .[a]
/* `Kleene xs' determines the kleene closure of the list `xs' of symbols,
i.e. all strings over that list in standard order. The implementation
is designed for maximum sharing.
*/
kleene :: !.[symbol] -> .[[symbol]]
// Lazy variant of the predefined abort function
error :: .String -> .a
// Determine the string representation of a list
listToString :: [a] -> String | toString a
// Lookup finds a value mapped in a list mapping.
lookup :: u:([(arg,w:res)] -> v:(arg -> w:res)) | == arg, [v u <= w]
// Map a function onto the zip of two lists.
map2 :: (.a -> .(.b -> .c)) ![.a] [.b] -> [.c]
// Map a function on the first element of a 2-tuple.
mapfst :: v:(.a -> .b) -> u:((.a,.c) -> (.b,.c)), [u <= v]
// Map a function on the first element of a triple.
mapfst3 :: v:(.a -> .b) -> u:((.a,.c,.d) -> (.b,.c,.d)), [u <= v]
// Map a function onto the head of a list.
maphd :: .(.a -> .a) !u:[.a] -> v:[.a], [u <= v]
// Map a function onto an optional value.
mapoptional :: .(.a -> .b) !(Optional .a) -> Optional .b
// Map two functions onto a pair.
mappair :: .(.a -> .b) .(.c -> .d) !(.a,.c) -> (.b,.d)
// Map a function onto the second element of a 2-tuple.
mapsnd :: v:(.a -> .b) -> u:((.c,.a) -> (.c,.b)), [u <= v]
// Map a function on the second element of a triple.
mapsnd3 :: v:(.a -> .b) -> u:((.c,.a,.d) -> (.c,.b,.d)), [u <= v]
// Map a function onto the tail of a list.
maptl :: .(x:[.a] -> u:[.a]) !w:[.a] -> v:[.a], [u <= v, w <= x]
// Map three functions onto a triple.
maptriple :: x:(.a -> .b) w:(.c -> .d) v:(.e -> .f) -> u:((.a,.c,.e) -> (.b,.d,.f)), [u <= v, u <= w, u <= x]
// String representation of line terminator
nl :: String
// Pairwith pairs a value with its result under a given function
pairwith :: .(arg -> .res) arg -> (arg,.res)
// Partition a list.
// The first argument is a representer function that defines partition blocks.
// The second argument is a selector function that is applied to each element of each block.
partition :: (a -> b) (a -> .c) -> .(!.[a] -> [(b,[.c])]) | == b
// Plookup is a printable lookup with a more readable error message for the not found case.
plookup :: .(arg -> String) ![(arg,.res)] arg -> .res | == arg
// Power applies a function a number of times to a value.
power :: !Int (.t -> .t) -> .(.t -> .t)
// Printoptional produces a printable representation of an optional type.
printoptional :: .(.t -> String) !(Optional .t) -> String
// Proc is an argument-permuted variant of foldr
proc :: .((w:elem -> .(.res -> .res)) -> v:(![w:elem] -> u:(.res -> .res))), [u <= v, u <= w]
// `Relimg rel x' is the relational image of `x' in relation `rel' (represented by a table).
relimg :: ![(a,.b)] a -> [.b] | == a
// `Remap x y mapping' alters the mapping by associating y with x, removing the old values.
remap :: a b [.(a,b)] -> .[(a,b)] | == a
// A variant of foldl that is strict in its accumulator
sfoldl :: (.a -> .(.b -> .a)) !.a [.b] -> .a
// `Shorter xs' determines whether a list is shorter than list `xs'.
shorter :: ![.a] [.b] -> .Bool
// `Showbool b' is the string representation of boolean `b'.
showbool :: .(!.Bool -> a) | fromBool a
// Determine a string representation of a list
showlist :: (.elem -> .String) ![.elem] -> String
// `Showoptional showa opt' is the string representation of optional value `opt',
// where `showa' determines the string representation of the inner value.
showoptional :: .(.a -> .String) !(Optional .a) -> String
// `Showpair showa showb pair' is the string representation of a pair,
// where showa and showb represent the internal types.
showpair :: !.(.a -> .String) !.(.b -> .String) !(.a,.b) -> String
// `Showstring s' represents a string as a string.
showstring :: .(!.String -> a) | fromString a
// `Showtriple' determines the string representation of a triple.
showtriple :: !.(.a -> .String) !.(.b -> .String) !.(.c -> .String) !(.a,.b,.c) -> String
// `Split sep' splits a list into a list of sublists which are separated by `sep'.
split :: a -> .(.[a] -> [.[a]]) | == a
// `Stub modulename functionname message' aborts with a explanatory message
stub :: .String .String .String -> .a
// `Superset xs ys' determines whether ys is a superset (actually, super-multi-set or super-list) of xs.
superset :: .[a] -> .(.[a] -> Bool) | == a
// zipwith zips up two lists with a joining function
zipwith :: (.a .b->.c) ![.a] [.b] -> [.c]
// Strict version of --->, which evaluates its lhs first
(<---) infix :: !.a !b -> .a | <<< b
// 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
// Prettyprint a list to a file with indent
printlist :: (elem->String) String [elem] *File -> .File
implementation module basic
// $Id$
/*
Basic definitions
=================
Description
-----------
Basic types and functions.
*/
import StdEnv
/*
Implementation
--------------
*/
//:: Optional t = Absent | Present t
// Now using Optional type from cocl's general module
from general import Optional,No,Yes,--->
instance == (Optional a) | == a
where (==) No No = True
(==) (Yes x1) (Yes x2) = x1==x2
(==) _ _ = False
// Adjust a function for a single argument
adjust :: !arg res (arg->res) !arg -> res | == arg
adjust a r f x
| x==a = r
= f x
// Claim a list of nodes from a heap
claim :: ![.param] u:[.cell] -> ([.cell],v:[.cell]), [u<=v]
claim [] heap = ([],heap)
claim [pnode:pnodes] [snode:heap]
= ([snode:snodes],heap`)
where (snodes,heap`) = claim pnodes heap
claim pnodes emptyheap = abort "claim: out of heap" // Just in case. Should be used with an infinite heap.
/* Depthfirst collects results of a function (called process), applied to a
given list of inputs and other inputs which are generated from the
results recursively, and so on. Duplicates are removed. */
depthfirst :: (res->.[elem]) (elem->res) !.[elem] -> .[res] | == elem
depthfirst generate process xs
= snd (collect xs ([],[]))
where collect [] seenrest = seenrest
collect [x:xs] seenrest
| isMember x seen
= collect xs seenrest
= (seen``,[y:rest``])
where (seen`,rest``) = collect (generate y) ([x:seen],rest`)
(seen``,rest`) = collect xs ( seen`,rest)
y = process x
(seen,rest) = seenrest
// `Disjoint xs ys' checks whether xs and ys are disjoint.
disjoint :: .[elem] !.[elem] -> Bool | == elem
disjoint xs ys = not (or (map (flip isMember xs) ys))
eqlen :: ![.elem1] ![.elem2] -> .Bool
eqlen [x:xs] [y:ys] = eqlen xs ys
eqlen [] [] = True
eqlen xs ys = False
// Extend a function using the elements of a mapping
extendfn :: [(src,dst)] (src->dst) src -> dst | == src
extendfn mapping f x = foldmap id (f x) mapping x
// `Foldlm' is a combination of foldl and map.
foldlm :: ((.collect,.elem) -> (.collect,.elem`)) !(.collect,![.elem]) -> (.collect,[.elem`])
foldlm f (l,[]) = (l,[])
foldlm f (l,[m:ms])
= (l``,[m`:ms`])
where (l`,m`) = f (l,m)
(l``,ms`) = foldlm f (l`,ms)
foldlr :: (.elem -> .((.lrinfo,.rlinfo) -> (.lrinfo,.rlinfo))) !(.lrinfo,.rlinfo) ![.elem] -> (.lrinfo,.rlinfo)
foldlr f lr []
= lr
foldlr f lr [x:xs]
= (l``,r``)
where (l``,r`) = foldlr f (l`,r) xs
(l`,r``) = f x (l,r`)
(l,r) = lr
foldmap :: (x:res -> w:res`) w:res` -> u:(![(arg,x:res)] -> v:(arg -> w:res`)) | == arg, [v u <= w, v <= x]
foldmap f d
= foldr foldmap` (const d)
where foldmap` xy g v
= if (x==v) (f y) (g v)
where (x,y) = xy
foldoptional :: .res .(.t -> .res) !(Optional .t) -> .res
foldoptional no yes No = no
foldoptional no yes (Yes x) = yes x
force :: !.a .b -> .b
force x y = y
forget :: val -> .(![.(val,res)] -> .[(val,res)]) | == val
forget x = filter (neq x o fst)
neq x y = x <> y
inccounter :: a (a->b) a -> b | == a & +,one b
inccounter m f n = if (n==m) (f n+one) (f n)
indent :: .String -> .([.String] -> .[String])
indent first = map2 (+++) [first:repeat (createArray (size first) ' ')]
map2 :: (.a -> .(.b -> .c)) ![.a] [.b] -> [.c]
map2 f [x:xs] [y:ys] = [f x y:map2 f xs ys]
map2 f _ _ = []
// `Identifiers' is the list of all identifiers
identifiers :: [String]
identifiers =: map toString (tl (kleene ['abcdefghijklmnopqrstuvwxyz']))
// `Intersect xs ys' is the intersection of list `ys' with list `xs'.
intersect :: ![elem] [elem] -> .[elem] | == elem
intersect [] _ = []
intersect [y:ys] xs = elim (cons y o intersect ys) (intersect ys xs) y xs
// Elim removes a given element from a list.
// There are two continuations, one for failure and one for success.
elim :: .(v:[elem] -> .res) .res elem u:[elem] -> .res | == elem, [u <= v]
elim found notfound y []
= notfound
elim found notfound y [x:xs]
| x==y
= found xs
= elim (found o cons x) notfound y xs
// Cons prepends an element to a list
cons :: .elem u:[.elem] -> v:[.elem], [u <= v]
cons x xs = [x:xs]
// `Join x xss' is the join of the list of lists `xss', separated by `x'.
join :: a ![.[a]] -> .[a]
join sep [] = []
join sep [x:xs] = x++flatten (map (cons sep) xs)
/* `Kleene xs' determines the kleene closure of the list `xs' of symbols,
i.e. all strings over that list in standard order. The implementation
is designed for maximum sharing.
*/
kleene :: !.[symbol] -> .[[symbol]]
kleene [] = [[]]
kleene symbols
= flatten (iterate prefix [[]])
where prefix strings
= flatten (map appendstrings symbols)
where appendstrings symbol = map (cons symbol) strings
// Lazy variant of the predefined abort function
error :: .String -> .a
error message = abort message
// Determine the string representation of a list
listToString :: [a] -> String | toString a
listToString xs = showlist toString xs
lookup :: u:([(arg,w:res)] -> v:(arg -> w:res)) | == arg, [v u <= w]
lookup = foldmap id (abort "lookup: not found")
pairwith :: .(arg -> .res) arg -> (arg,.res)
pairwith f x = (x,f x)
plookup :: .(arg -> String) ![(arg,.res)] arg -> .res | == arg
plookup showa tbl a = foldmap id (abort (showa a+++": not found")) tbl a
power :: !Int (.t -> .t) -> .(.t -> .t)
power n f
| n <= 0
= id
= f o power (n-1) f
printoptional :: .(.t -> String) !(Optional .t) -> String
printoptional printa No = ""
printoptional printa (Yes a) = printa a
proc :: .((w:elem -> .(.res -> .res)) -> v:(![w:elem] -> u:(.res -> .res))), [u <= v, u <= w]
proc = flip o foldr
mapfst :: v:(.a -> .b) -> u:((.a,.c) -> (.b,.c)), [u <= v]
mapfst f = app2 (f,id)
mapfst3 :: v:(.a -> .b) -> u:((.a,.c,.d) -> (.b,.c,.d)), [u <= v]
mapfst3 f = app3 (f,id,id)
maphd :: .(.a -> .a) !u:[.a] -> v:[.a], [u <= v]
maphd f [] = []
maphd f [x:xs] = [f x:xs]
mapoptional :: .(.a -> .b) !(Optional .a) -> Optional .b
mapoptional f No = No
mapoptional f (Yes x) = Yes (f x)
mappair :: .(.a -> .b) .(.c -> .d) !(.a,.c) -> (.b,.d)
mappair f g (x,y) = (f x,g y)
mapsnd :: v:(.a -> .b) -> u:((.c,.a) -> (.c,.b)), [u <= v]
mapsnd f = app2 (id,f)
mapsnd3 :: v:(.a -> .b) -> u:((.c,.a,.d) -> (.c,.b,.d)), [u <= v]
mapsnd3 f = app3 (id,f,id)
maptl :: .(x:[.a] -> u:[.a]) !w:[.a] -> v:[.a], [u <= v, w <= x]
maptl f [] = []
maptl f [x:xs] = [x:f xs]
maptriple :: x:(.a -> .b) w:(.c -> .d) v:(.e -> .f) -> u:((.a,.c,.e) -> (.b,.d,.f)), [u <= v, u <= w, u <= x]
maptriple f g h = app3 (f,g,h)
// String representation of line terminator
nl :: String
nl =: "\n"
partition :: (a -> b) (a -> .c) -> .(!.[a] -> [(b,[.c])]) | == b
partition f g
= h
where h [] = []
h [x:xs]
= [((r,[g x:ins])):h outs]
where ins = [g x\\x<-xs|f x==r]
outs = [x\\x<-xs|f x<>r]
r = f x
relimg :: ![(a,.b)] a -> [.b] | == a
relimg rel x` = [y\\(x,y)<-rel|x==x`]
remap :: a b [.(a,b)] -> .[(a,b)] | == a
remap x y xys = [(x,y):forget x xys]
// A variant of foldl that is strict in its accumulator