diff options
Diffstat (limited to 'sucl/clean.icl')
| -rw-r--r-- | sucl/clean.icl | 449 |
1 files changed, 0 insertions, 449 deletions
diff --git a/sucl/clean.icl b/sucl/clean.icl deleted file mode 100644 index 6f4964f..0000000 --- a/sucl/clean.icl +++ /dev/null @@ -1,449 +0,0 @@ -implementation module clean - -// $Id$ - -/* - -clean.lit - Clean core language -=============================== - -Description ------------ - -This script contains the implementation of the core of the Clean -language. - ------------------------------------------------------------- - -Interface ---------- - -Exported identifiers: - -> %export || law.lit cli.lit test.lit - -> cleanpart || + + - -> node || + + + -> symbol || + + + -> typenode || + + + -> typesymbol || + + + - -> cleantyperule || - + - -> corecomplete || + + - -> coretypeinfo -> coretyperule || - + - -> readcleanparts || - + - -> showcleanpart -> shownode || - - + -> showsymbol || + + + -> showtypenode || - + - -> showtypesymbol || - + - -> symbolmodule -> typesymbolmodule -> usersym - -> cleanalias -> cleanmacro -> cleantype -> cleanrule - -> heap || Infinite list of anonymous nodes -> typeheap || Infinite list of anonymous type nodes - ------------------------------------------------------------- - -Includes --------- - -> %include "basic.lit" -> %include "hunt.lit" -> %include "graph.lit" -extgraph -> %include "rule.lit" - ------------------------------------------------------------- - -Implementation --------------- - -Implementation of identifier - -> typesymbol -> ::= INT | || Integer -> BOOL | || Boolean -> CHAR | || Character -> STRING | || String -> REAL | || Real -> FILE | || File -> FN | || Function -> LIST | || List -> TUPLE num | || Tuple of specific arity -> USER [char] [char] || User-defined type <module.ident> - -> typenode -> ::= NAMED [char] | || A type node with an explicit nodeid -> ANONYMOUS num || A type node without an explicit nodeid - -> symbol -> ::= Int num | || A specific integer -> Bool bool | || A specific boolean -> Char char | || A specific character -> String [char] | || A specific string -> Real num | || A specific real -> Tuple num | || The tuple constructor of specific arity -> Cons | || The list constructor -> Nil | || The empty list -> Apply | || The curried function application symbol -> If | || The predefined if symbol -> Select num num | || The tuple element selector for tuple arity and element number -> User [char] [char] || A user-defined symbol <module.ident> - -> node -> ::= Named [char] | || A node with an explicit nodeid -> Anonymous num || A node without an explicit nodeid - -> cleanpart -> ::= Typeexport typesymbol | -> Alias typesymbol [typenode] typenode [(typenode,(typesymbol,[typenode]))] | -> Algebra typesymbol [symbol] | -> Export symbol | -> Macro symbol [node] node [(node,(symbol,[node]))] | -> Type symbol [typenode] typenode [(typenode,(typesymbol,[typenode]))] [char] | -> Rules symbol | -> Rule symbol [node] node [(node,(symbol,[node]))] | -> Constructor symbol - -> showcleanpart :: cleanpart -> [char] -> showcleanpart = show - -> ct = printrule show show.coretyperule - -> coreconstructor :: symbol -> bool - -> coreconstructor (Int i) = True -> coreconstructor (Bool b) = True -> coreconstructor (Char c) = True -> coreconstructor (String s) = True -> coreconstructor (Real r) = True -> coreconstructor (Tuple a) = True -> coreconstructor (Cons ) = True -> coreconstructor (Nil ) = True -> coreconstructor (Apply ) = True -> coreconstructor (If ) = False -> coreconstructor (Select a i) = False -> coreconstructor (User m n) = False - -> coreexports :: [symbol] - -> coreexports = [] - -> coreimported :: symbol -> bool - -> coreimported (Int i) = False -> coreimported (Bool b) = False -> coreimported (Char c) = False -> coreimported (String s) = False -> coreimported (Real r) = False -> coreimported (Tuple a) = False -> coreimported (Cons ) = False -> coreimported (Nil ) = False -> coreimported (Apply ) = True -> coreimported (If ) = False -> coreimported (Select a i) = False -> coreimported (User m n) = False - -> corerules :: symbol -> [rule symbol node] - -> corerules (Int i) = [] -> corerules (Bool b) = [] -> corerules (Char c) = [] -> corerules (String s) = [] -> corerules (Real r) = [] -> corerules (Tuple a) = [] -> corerules (Cons ) = [] -> corerules (Nil ) = [] -> corerules (Apply ) = [] -> corerules (If ) -> = [ mkrule [Named "cond",Named "then",Named "else"] (Named "else") (updategraph (Named "cond") (Bool False,[]) emptygraph) -> , mkrule [Named "cond",Named "then",Named "else"] (Named "then") (updategraph (Named "cond") (Bool True ,[]) emptygraph) -> ] -> corerules (Select a i) = [mkrule [Named "tuple"] (Anonymous i) (updategraph (Named "tuple") (Tuple a,map Anonymous [1..a]) emptygraph)] -> corerules (User m n) = [] - - coresymbols :: [symbol] - - coresymbols = [If,Select a i] - -> coretyperule (Int i) = mkrule [] (NAMED "int" ) (updategraph (NAMED "int" ) (INT ,[]) emptygraph) -> coretyperule (Bool b) = mkrule [] (NAMED "bool" ) (updategraph (NAMED "bool" ) (BOOL ,[]) emptygraph) -> coretyperule (Char c) = mkrule [] (NAMED "char" ) (updategraph (NAMED "char" ) (CHAR ,[]) emptygraph) -> coretyperule (String s) = mkrule [] (NAMED "string") (updategraph (NAMED "string") (STRING,[]) emptygraph) -> coretyperule (Real r) = mkrule [] (NAMED "real" ) (updategraph (NAMED "real" ) (REAL ,[]) emptygraph) -> coretyperule (Tuple a) -> = mkrule args (NAMED "tuple") (updategraph (NAMED "tuple") (TUPLE a,args) emptygraph) -> where args = take a (map ANONYMOUS [1..]) -> coretyperule Cons = mkrule [NAMED "element",NAMED "list"] (NAMED "list") (updategraph (NAMED "list") (LIST,[NAMED "element"]) emptygraph) -> coretyperule Nil = mkrule [] (NAMED "list") (updategraph (NAMED "list") (LIST,[NAMED "element"]) emptygraph) -> coretyperule Apply = mkrule [NAMED "fn",NAMED "arg"] (NAMED "res") (updategraph (NAMED "fn") (FN,[NAMED "arg",NAMED "res"]) emptygraph) -> coretyperule If = mkrule [NAMED "bool",NAMED "res",NAMED "res"] (NAMED "res") (updategraph (NAMED "bool") (BOOL,[]) emptygraph) -> coretyperule (Select a i) = mkrule [NAMED "tuple"] (ANONYMOUS i) (updategraph (NAMED "tuple") (TUPLE a,map ANONYMOUS [1..a]) emptygraph) -> coretyperule (User m n) = error ("coretyperule: untyped user symbol "++m++'.':n) - -> coretypeinfo :: symbol -> (rule typesymbol typenode,[bool]) -> coretypeinfo sym -> = (trule,corestricts sym) -> where corestricts Apply = [True,False] -> corestricts If = [True,False,False] -> corestricts (Select a i) = [True] -> corestricts sym = map (const False) (lhs trule) -> trule = coretyperule sym - -> readcleanparts :: [char] -> [cleanpart] -> readcleanparts = readvals.findclean - -> findclean :: [char] -> [char] -> findclean base -> = foldr const (error ("findclean: "++show base++" not found.")) files -> where files = findfiles readable ["",".cli"] (getpath ["."] "CLIPATH") base - -> corecomplete :: typesymbol -> [symbol] -> bool - -> corecomplete INT = const False -> corecomplete BOOL = superset (map Bool [False,True]) -> corecomplete CHAR = superset (map (Char.decode) [0..255]) -> corecomplete STRING = const False -> corecomplete REAL = const False -> corecomplete FILE = const False -> corecomplete FN = const False -> corecomplete LIST = superset [Nil,Cons] -> corecomplete (TUPLE arity) = superset [Tuple arity] -> corecomplete (USER module identifier) = const False - -> showtypesymbol INT = "INT" -> showtypesymbol BOOL = "BOOL" -> showtypesymbol CHAR = "CHAR" -> showtypesymbol STRING = "STRING" -> showtypesymbol REAL = "REAL" -> showtypesymbol FILE = "FILE" -> showtypesymbol FN = "=>" -> showtypesymbol LIST = "_LIST" -> showtypesymbol (TUPLE a) = "_TUPLE"++shownum a -> showtypesymbol (USER module ident) = ident - -> showtypenode (NAMED ident) = ident -> showtypenode (ANONYMOUS n) = "type"++shownum n - -> showtypenodedef :: typesymbol -> [([char],[char])] -> ([char],[char]) -> showtypenodedef (TUPLE a) [] = issafe "()" -> showtypenodedef (TUPLE a) [arg] = arg -> showtypenodedef (TUPLE a) ((safearg,unsafearg):args) -> = issafe ('(':unsafearg++f args) -> where f [] = ")" -> f ((safearg,unsafearg):args) = ',':unsafearg++f args -> showtypenodedef LIST [(safearg,unsafearg)] = issafe ('[':unsafearg++"]") -> showtypenodedef symbol [] = issafe (showtypesymbol symbol) -> showtypenodedef symbol args = showappl (showtypesymbol symbol) args - -> showsymbol :: symbol -> [char] -> showsymbol (Int i) = shownum i -> showsymbol (Bool False) = "FALSE" -> showsymbol (Bool True) = "TRUE" -> showsymbol (Char c) = show c -> showsymbol (String s) = show s -> showsymbol (Real r) = show (r+0.0) -> showsymbol (Tuple a) = "_Tuple"++show a -> showsymbol Cons = "_CONS" -> showsymbol Nil = "[]" -> showsymbol Apply = "_AP" -> showsymbol If = "IF" -> showsymbol (Select a i) = "_Select"++show a++'.':show i -> showsymbol (User module ident) = ident - -> shownode (Named ident) = ident -> shownode (Anonymous n) = "node"++shownum n - -> shownodedef :: symbol -> [([char],[char])] -> ([char],[char]) -> shownodedef (Tuple a) [] = issafe "()" -> shownodedef (Tuple a) [arg] = arg -> shownodedef (Tuple a) ((safearg,unsafearg):args) -> = issafe ('(':unsafearg++f args) -> where f [] = ")" -> f ((safearg,unsafearg):args) = ',':unsafearg++f args -> shownodedef Cons [(safehead,unsafehead),(safetail,unsafetail)] -> = issafe ('[':unsafehead++f unsafetail) -> where f "[]" = "]" -> f ('[':ttail) = ',':ttail -> f unsafetail = '|':unsafetail++"]" -> shownodedef Apply [fn] = fn -> shownodedef Apply ((safefn,unsafefn):args) = showappl unsafefn args -> shownodedef symbol [] = issafe (showsymbol symbol) -> shownodedef symbol args = showappl (showsymbol symbol) args - -> showappl sym args = mksafe (sym++concat (map ((' ':).fst) args)) -> mksafe unsafe = ('(':unsafe++")",unsafe) -> issafe safe = (safe,safe) - -> cleantyperule :: symbol -> (rule typesymbol typenode,[bool]) -> [char] - -> cleantyperule sym (trule,tstricts) -> = ":: "++showsymbol sym++concat (map2 printarg tstricts targs)++" -> "++snd (lookup' troot)++";" -> where targs = lhs trule; troot = rhs trule; tgraph = rulegraph trule -> lookup' = lookup table -> table = map (pairwith printunraveled) (nodelist tgraph (troot:targs)) -> printunraveled tnode -> = showtypenodedef tsym (map lookup' targs), if tdef -> = issafe (showtypenode tnode), otherwise -> where (tdef,(tsym,targs)) = nodecontents tgraph tnode -> printarg tstrict targ = ' ':cond tstrict ('!':) id (fst (lookup' targ)) - -> prettyrule :: (**->[char]) -> (*->[([char],[char])]->([char],[char])) -> rule * ** -> [char] -> prettyrule shownode shownodedef rule -> = concat (map ((++" ").fst) (init shownnodes))++"-> "++snd (last shownnodes) -> where shownnodes = foldgraph prettydef (issafe.shownode) shownodedef graph (args++[root]) -> prettydef node (saferef,unsaferef) = issafe (shownode node++':':saferef) -> graph = rulegraph rule -> args = lhs rule -> root = rhs rule - -> usersym :: symbol -> bool -> usersym (User module name) = True -> usersym sym = False - -> symbolmodule :: symbol -> optional [char] -> symbolmodule (User module ident) = Present module -> symbolmodule symbol = Absent - -> typesymbolmodule :: typesymbol -> optional [char] -> typesymbolmodule (USER module ident) = Present module -> typesymbolmodule symbol = Absent - -======================================================================== - -Get the Select nodes from a graph. - -> getselectnodes :: graph symbol ** -> ** -> [((**,num),(num,**))] - -> getselectnodes graph root -> = foldr (withmeta (nodecontents graph) addselectnode) [] (nodelist graph [root]) -> where addselectnode (True,(Select arity index,[tuplenode])) selectnode -> = (((tuplenode,arity),(index,selectnode)):) -> addselectnode contents node = id - -Distribute the Select nodes over their indexes. - -> splitselectnodes :: ((**,num),[(num,**)]) -> (**,[[**]]) - -> splitselectnodes ((tuplenode,arity),selects) -> = (tuplenode,foldr dist (rep arity []) selects) -> where dist (1,selectnode) (ns:nss) = (selectnode:ns):nss -> dist (index,selectnode) (ns:nss) = ns:dist (index-1,selectnode) nss - -Make left hand sides. - -> makelhss :: [**] -> [[**]] -> ([**],[[**]]) - -> makelhss heap nss -> = (heap,[]), if empty -> = (heap'',ns':nss''), otherwise -> where (heap'',nss'') = makelhss heap' nss' -> (empty,ns',heap',nss') = heads heap nss -> heads heap [] = (True,[],heap,[]) -> heads (node:heap) ([]:nss) -> = (empty,node:ns',heap',[]:nss') -> where (empty,ns',heap',nss') = heads heap nss -> heads heap ((n:ns):nss) -> = (False,n:ns',heap',ns:nss') -> where (empty,ns',heap',nss') = heads heap nss - -> maketuplenodedefs :: [**] -> [(**,[[**]])] -> [([**],**)] - -> maketuplenodedefs heap [] -> = [] -> maketuplenodedefs heap ((tuplenode,nss):rest) -> = map (converse pair tuplenode) lhss++tuplenodedefs -> where (heap',lhss) = makelhss heap nss -> tuplenodedefs = maketuplenodedefs heap' rest - -> printtree :: graph symbol node -> node -> ([char],[char]) -> printtree = unravelwith (issafe.shownode) shownodedef - -> cleanalias sym = indent ":: ".totalpretty typeheap (const (const [])) showtypesymbol showtypenodedef showtypenode sym -> cleanmacro sym = indent " ".totalpretty heap (const (const [])) showsymbol shownodedef shownode sym -> cleantype sym = indent ":: ".totalpretty typeheap (const (const [])) showsymbol showtypenodedef showtypenode sym -> cleanrule sym = indent " ".totalpretty heap getselectnodes showsymbol shownodedef shownode sym - -> heap = map Anonymous [0..] -> typeheap = map ANONYMOUS [0..] - -> totalpretty -> :: [***] -> -> (graph ** ***->***->[((***,num),(num,***))]) -> -> (*->[char]) -> -> (**->[([char],[char])]->([char],[char])) -> -> (***->[char]) -> -> * -> -> rule ** *** -> -> [[char]] - -> totalpretty heap getselectnodes showlhssymbol shownodedef shownode lhssymbol rule -> = punctuate "" "," " " "" lhsheader lhsbody++ -> punctuate "-> " "," " " ";" rhsheader rhsbody - -> where - -> args = lhs rule; root = rhs rule; graph = rulegraph rule -> selectnodes = getselectnodes graph root -> prunedgraph = foldr prunegraph graph (map (snd.snd) selectnodes) -> tuplenodedefs -> = ( maketuplenodedefs (heap--nodelist graph (root:args)). -> map splitselectnodes. -> partition fst snd -> ) selectnodes -> tuplenodes = map snd tuplenodedefs -> count = refcount prunedgraph (args++root:tuplenodes) -> sharednodes = [node|node<-nodelist prunedgraph (args++root:tuplenodes);count node>1;fst (nodecontents prunedgraph node)] -> reprunedgraph = foldr prunegraph prunedgraph sharednodes -> (argreprs:[rootrepr]:tuplereprs:sharedargreprs) -> = map (map (unravelwith (issafe.shownode) shownodedef reprunedgraph)) (args:[root]:tuplenodes:map (snd.snd.nodecontents prunedgraph) sharednodes) - -> showtupledef (selectnodes,tuplenode) tuplerepr -> = '(':join ',' (map shownode selectnodes)++"): "++snd tuplerepr -> showshareddef (node,argreprs) -> = mapfst addline, if patnode node -> = mapsnd addline, otherwise -> where addline = ((shownode node++": "++snd (shownodedef (fst cont) argreprs)):) -> (True,cont) = nodecontents prunedgraph node - -> patnode = member (nodelist graph args) - -> lhsheader = showlhssymbol lhssymbol++concat (map ((' ':).fst) argreprs) -> rhsheader = snd rootrepr -> (lhslines,rhslines) = foldr showshareddef ([],[]) (zip2 sharednodes sharedargreprs) -> lhsbody = lhslines -> rhsbody = map2 showtupledef tuplenodedefs tuplereprs++rhslines - -> punctuate :: [char] -> [char] -> [char] -> [char] -> [char] -> [[char]] -> [[char]] - -> punctuate open endline beginline close l ls -> = (open++l++end):ls' -> where (end,ls') = f ls -> f [] = (close,[]) -> f (l:ls) = (endline,punctuate beginline endline beginline close l ls) - ------------------------------------------------------------------------- -Useful (higher order) functions. - -> withmeta :: (*->**) -> (**->*->***) -> * -> *** -> withmeta meta f x = f (meta x) x - -> pair :: * -> ** -> (*,**) -> pair x y = (x,y) - -> unravelwith :: (**->***) -> (*->[***]->***) -> graph * ** -> ** -> *** -> unravelwith foldopen foldclosed graph -> = unravel -> where unravel node -> = foldclosed sym (map unravel args), if def -> = foldopen node, otherwise -> where (def,(sym,args)) = nodecontents graph node - -*/ |