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

git-svn-id: https://svn.cs.ru.nl/repos/clean-compiler/trunk@1940 1f8540f1-abd5-4d5b-9d24-4c5ce8603e2d

1 files changed, 0 insertions, 568 deletions

diff --git a/sucl/newtest.icl b/sucl/newtest.icl
deleted file mode 100644
index f7e2787..0000000
--- a/sucl/newtest.icl
+++ /dev/null
@@ -1,568 +0,0 @@
-implementation module newtest
-
-// $Id$
-
-import cli
-import coreclean
-import newfold
-import complete
-import trd
-import loop
-import trace
-import rule
-import graph
-import canon
-import basic
-import general
-import StdEnv
-
-/*
-
-newtest.lit - Testing the new trace implementation
-==================================================
-
-Description
------------
-
-Describe in a few paragraphs what this module defines.
-
-------------------------------------------------------------
-
-Interface
----------
-
-Exported identifiers:
-
->   %export
->       all       ||  List of all clasp modules
->       list      ||  List a clean module
->       listopt   ||  List rules with introduction
->       listfull  ||  List full processing of optimization
->||     listtrace ||  List the trace for a clean module
->       optfiles  ||  Optimize files obeying a pattern
->       optimize  ||  Optimize a clean module
-
-Required types:
-
-    identifier - type@source.lit type@source.lit
-    ...
-
-------------------------------------------------------------
-
-Includes
---------
-
->   %include "dnc.lit"
-
->   %include "../src/basic.lit"
->   %include "../src/hunt.lit"
->   %include "../src/pfun.lit"
->   %include "../src/graph.lit"
->   %include "../src/rule.lit"
->   %include "../src/trd.lit"
->   %include "../src/spine.lit"
->   %include "strat.lit"
->   %include "trace.lit"
->   %include "loop.lit"
->   %include "../src/clean.lit"
->   %include "../src/module.lit"
->   %include "cli.lit"
->   %include "../src/complete.lit"
->|| %include "fold.lit"
->   %include "newfold.lit"
->   %include "../src/canon.lit"
-
-------------------------------------------------------------
-
-Implementation
---------------
-
-------------------------------------------------------------------------
-
->   optfiles :: [char] -> [sys_message]
->   optfiles
->   =   optimize.foldr addmodule [].glob.join ' '.expand [".cli"] (getpath ["."] "CLIPATH")
-
->   addmodule filename modules
->   =   subcli scont filename
->       where subcli success ".cli" = success ""
->             subcli success ('/':cs) = subcli scont cs
->             subcli success (c:cs) = subcli (success.(c:)) cs
->             subcli success cs = modules
->             scont = (:modules)
-
->   all = (foldr addmodule [].glob.join ' '.expand [".cli"] (getpath ["."] "CLIPATH")) "*"
-
->   optimize :: [[char]] -> [sys_message]
-
->   optimize modules
->   =   complaints++loads++concat (map optone goodnames)++[Stdout "Done.\n",Exit (#complaints)]
->       where allnames = [(module,findfiles readable [".cli"] (getpath ["."] "CLIPATH") module)|module<-modules]
->             badnames = [module|(module,[])<-allnames]
->             goodnames = [(module,cliname,init cliname++"o")|(module,cliname:clinames)<-allnames]
->             complaints
->             =   [], if badnames=[]
->             =   [Stderr ("Warning: cannot find module"++showmodules badnames++" (ignored).\n")], otherwise
->                 where showmodules [module]
->                       =   ": "++showstring module
->                       showmodules modules
->                       =   "s: "++join ',' (map showstring modules)
->             loads
->             =   [], if goodnames=[]
->             =   [Stdout ("Loaded modules: "++join ',' [module|(module,cli,clo)<-goodnames]++".\n")], otherwise
->             cli = loadclis (map snd3 goodnames)
->             optone (module,cliname,cloname)
->             =   [   Stdout ("Optimizing "++module++" ("++showstring cliname++") to "++show cloname++"..."),
->                     Tofile cloname (listnew module cli),
->                     Stdout "\n"
->                 ]
-
-------------------------------------------------------------------------
-
-`Newfunction' is the  type  of  a  new  function  produced  by  symbolic
-reduction  applied  to a cli module.  Symbolic reduction on a cli module
-actually produces a list of new functions.
-
->   newfunction * ** **** *****
->   ==  (   *,                ||  Assigned symbol of the new function
->           rule * **,        ||  Initial rule of the new function
->           [bool],           ||  Strictness annotations
->           rule **** *****,  ||  Type rule
->           bool,             ||  Export annotation
->           [rule * **],      ||  Rewrite rules
->           bool              ||  Import annotation
->       )
-
-`Symredresult' is the output produced by symbolic reduction  applied  to
-an  area.   Symbolic  reduction  on  an area actually produces a list of
-these tuples.
-
->   symredresult * ** **** *****
->   ==  (   rgraph * **,      ||  The initial area in canonical form
->           *,                ||  The assigned symbol
->           [bool],           ||  Strictness annotations
->           rule **** *****,  ||  Type rule
->           trace * ** **,    ||  Truncated and folded trace
->           [rule * **],      ||  Resulting rewrite rules
->           [rgraph * **]     ||  New areas for further symbolic reduction (not necessarily canonical)
->       )
-*/
-
-:: Symredresult sym var tsym tvar
-   = { srr_task_expression :: Rgraph sym var    // The initial area in canonical form
-     , srr_assigned_symbol :: sym               // The assigned symbol
-     , srr_strictness      :: [Bool]            // Strictness annotations
-     , srr_arity           :: Int               // Arity
-     , srr_typerule        :: Rule tsym tvar    // Type rule
-     , srr_trace           :: Trace sym var var // Truncated and folded trace
-     , srr_function_def    :: FuncDef sym var   // Resulting rewrite rules
-     , srr_areas           :: [Rgraph sym var]  // New areas for further symbolic reduction (not necessarily canonical)
-     }
-
-instance toString (Symredresult sym var tsym tvar) | toString sym & toString var & Eq var
-where toString srr
-      = "Task: "+++toString srr.srr_task_expression+++
-        "\nSymbol: "+++toString srr.srr_assigned_symbol+++
-        "\nStrictness: "+++listToString srr.srr_strictness+++
-        "\nArity: "+++toString srr.srr_arity+++
-        "\nTyperule: "+++"<typerule>"+++
-        "\nTrace: "+++"<trace>"+++
-        "\nFunction definition: "+++"<funcdef>"+++
-        "\nAreas: "+++listToString srr.srr_areas+++"\n"
-
-instance <<< (Symredresult sym var tsym tvar) | toString sym & <<<,==,toString var
-where (<<<) file0 srr
-      = file7
-        where file1
-              = file0 <<< "==[BEGIN]==" <<< nl
-                      <<< "Task expression: " <<< srr.srr_task_expression <<< nl
-                      <<< "Assigned symbol: " <<< toString (srr.srr_assigned_symbol) <<< nl
-                      <<< "Strictness: " <<< srr.srr_strictness <<< nl
-                      //<<< "Type rule: ..." <<< nl
-              file2 = printtrace srr.srr_assigned_symbol toString toString toString "" srr.srr_trace file1
-              file3 = file2 <<< "Function definition:" <<< nl
-              file4 = printfuncdef toString toString srr.srr_function_def file3
-              file5 = file4 <<< "Areas:" <<< nl
-              file6 = printareas toString toString "    " srr.srr_areas file5
-              file7 = file6 <<< "==[END]==" <<< nl
-
-printareas :: (sym->String) (var->String) String [Rgraph sym var] *File -> .File | == var
-printareas showsym showvar indent areas file
-= foldl (flip (printarea showsym showvar indent)) file areas
-
-printarea showsym showvar indent area file
-= file <<< indent <<< hd (printgraphBy showsym showvar (rgraphgraph area) [rgraphroot area]) <<< nl
-
-(writeareas) infixl :: *File [Rgraph sym var] -> .File | toString sym & toString,== var
-(writeareas) file xs = sfoldl (<<<) file xs
-
-/*
->   listopt :: [char] -> [[char]] -> [char]
-
->   listopt main = listnew main.loadclis
-
->   listnew :: [char] -> cli -> [char]
-
->   listnew main cli = (lay.printnew cli.map (makenew cli).filter hasusersym.fullsymred main.stripexports main) cli
-
->   printnew
->   ::  cli ->
->       [newfunction symbol node typesymbol typenode] ->
->       [[char]]
-
->   printnew cli results
->   =   (implementation exports++"MODULE "++modulename++";"):
->       prefix [""] (showimports [symbol|(symbol,initialrule,stricts,trule,exported,rules,True)<-results])++
->       showtypes ((map (uncurry cleanalias).aliases) cli) (map (printalgebra (typerule cli)) (constrs cli))++
->       prefix ["","MACRO"] ((concat.map (uncurry cleanmacro).macros) cli)++
->       concat (map (shownewrules cli) [(symbol,initialrule,(trule,stricts),rules)|(symbol,initialrule,stricts,trule,exported,rules,imported)<-results;rules~=[]])
->       where exports = [symbol|(symbol,initialrule,stricts,trule,True,rules,imported)<-results]
->             implementation [User module "Start"] = ""
->             implementation exports = "IMPLEMENTATION "
->             getmodule (User module ident) = module
->             modulename = hd (map getmodule exports++["empty"])
-
->   showimports symbols
->   =   map showblock (partition getmodule getident symbols)
->       where getmodule (User module ident) = module
->             getident (User module ident) = ident
->             showblock (module,idents)
->             =   "FROM "++module++" IMPORT "++join ',' idents++";"
-
->   showtypes aliastexts algebralines
->   =   prefix ["","TYPE"] (prefix [""] (concat aliastexts)++prefix [""] algebralines)
-
->   prefix xs [] = []
->   prefix xs ys = xs++ys
-
->   shownewrules cli (symbol,initialrule,tinfo,rules)
->   =   prefix ("":"<<":cleanrule symbol initialrule++[">>","RULE"]) (cleantyperule symbol tinfo:concat (map (cleanrule symbol) rules))
-
->   makenew
->   ::  cli ->
->       symredresult symbol node typesymbol typenode ->
->       newfunction symbol node typesymbol typenode
-
->   makenew cli (area,symbol,stricts,trule,Trace initialstricts initialrule answer history results,rules,areas)
->   =   (symbol,initialrule,stricts,trule,exported,rules',imported)
->       where exported = member (exports cli) symbol
->             imported = member (imports cli) symbol
->             rules' = filter ((~).unchanged) rules
->             unchanged rule
->             =   def & root=initialroot & sym=symbol
->                 where root = rhs rule; graph = rulegraph rule
->                       (def,(sym,args')) = dnc (const "in makenew") graph root
->             initialroot = rhs initialrule
-
->   hasusersym
->   ::  symredresult symbol node typesymbol typenode ->
->       bool
-
->   hasusersym (area,symbol,stricts,trule,trace,rules,areas) = usersym symbol
-
-------------------------------------------------------------------------
-
->   listfull :: [char] -> [[char]] -> [char]
->   listfull main filenames
->   =   (lay.map (showfull cli).fullsymred main) cli
->       where cli = stripexports main (loadclis (main:filenames))
-
->   showfull
->   ::  cli ->
->       symredresult symbol node typesymbol typenode ->
->       [char]
-
->   showfull cli (area,symbol,stricts,trule,trace,rules,areas)
->   =   hline++
->       "::: AREA :::\n"++
->       printrgraph showsymbol shownode area++
->       "\n\n::: ASSIGNED SYMBOL :::\n"++
->       showsymbol symbol++
->       "\n\n::: DERIVED TYPE RULE :::\n"++
->       printrule showtypesymbol showtypenode trule++
->       "\n\n::: TRACE :::\n"++
->       lay (printtrace symbol showsymbol shownode shownode trace)++
->       "\n\n::: DERIVED STRICTNESS :::\n"++
->       map strictchar stricts++
->       "\n::: RULES :::\n"++
->       lay (map (((showsymbol symbol++" ")++).printrule showsymbol shownode) rules)++
->       "\n::: NEW AREAS :::\n"++
->       lay (map (printrgraph showsymbol shownode) areas)++
->       hline
-
->   hline = rep 72 '='++"\n"
-
->   fullsymred
->   ::  [char] ->
->       cli ->
->       [symredresult symbol node typesymbol typenode]
-
->   fullsymred main cli
->   =   results
->       where results = depthfirst generate process (initareas cli)
->             generate result = map canonise' (getareas result)
->             process area = symredarea foldarea' cli area
-
->             foldarea' = foldarea (labelarea'.canonise')
->             labelarea' = labelarea (map getinit results) (newsymbols main)
->             canonise' = canonise (typerule cli) heap
-*/
-
-fullsymred ::
-    [SuclSymbol]    // Fresh function symbols
-    Cli             // Module to optimise
- -> [Symredresult SuclSymbol SuclVariable SuclTypeSymbol SuclTypeVariable]
-
-fullsymred freshsymbols cli
- = results
-   where results = depthfirst generate process (initareas cli)
-         generate result = map canonise` (getareas result)
-         process area = symredarea foldarea` cli area
-
-         foldarea` = foldarea (labelarea` o canonise`)
-         labelarea` = labelarea isSuclUserSym (map getinit results) freshsymbols
-         canonise` = canonise (arity cli) suclheap
-
-isSuclUserSym (SuclUser _) = True
-isSuclUserSym _ = False
-
-/*
-`Initareas cli' is the list  of  initial  rooted  graphs  that  must  be
-symbolically  reduced.  An initial rooted graph is formed by applying an
-exported symbol to its full complement of open  arguments  according  to
-its type rule.
-
->   initareas :: cli -> [rgraph symbol node]
-
->   initareas cli
->   =   map (initialise heap) (exports cli)
->       where initialise (root:nodes) symbol
->             =   mkrgraph root (updategraph root (symbol,args) emptygraph)
->                 where args = map2 const nodes targs
->                       targs = lhs (typerule cli symbol)
-
->   getinit :: symredresult * ** **** ***** -> rgraph * **
->   getinit (area,symbol,stricts,trule,trace,rules,areas) = area
-
->   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 srr
-= srr.srr_task_expression
-
-getareas :: (Symredresult sym var tsym tvar) -> [Rgraph sym var]
-getareas srr
-= srr.srr_areas
-
-/*
-`Symredarea' is the function that does symbolic reduction  of  a  single
-area.
-
->   symredarea
->   ::  (rgraph symbol node->(symbol,[node])) ->
->       cli ->
->       rgraph symbol node ->
->       symredresult symbol node typesymbol typenode
-
->   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 typeheap (ctyperule FN typeheap (typerule cli)) arule
->             trace = loop strategy' complete' matchable' (heap--nodelist agraph [aroot],arule)
->             (stricts,rules,areas) = fullfold (trc symbol) foldarea symbol trace
->             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
-= { srr_task_expression = area
-  , srr_assigned_symbol = symbol
-  , srr_strictness      = stricts
-  , srr_arity           = length aargs
-  , srr_typerule        = trule
-  , srr_trace           = trace
-  , srr_function_def    = rules
-  , srr_areas           = 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` (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
-
-------------------------------------------------------------------------
-
->   printelem symbol (result,optsra)
->   =   (   indent "subtrace: " (printresult symbol showsymbol shownode shownode result)++
->           foldoptional [] printsra optsra
->       )
-
->   printsra (stricts,rules,areas)
->   =   (   ("stricts: "++map strictchar stricts):
->           indent "rules: " (map (showrule showsymbol shownode) rules)++
->           indent "areas: " (map (showrgraph showsymbol shownode) areas)
->       )
-
->   printsras (strictss,rules,areas)
->   =   (   showlist (showstring.map strictchar) strictss:
->           indent "rules: " (map (showrule showsymbol shownode) rules)++
->           indent "areas: " (map (showrgraph showsymbol shownode) areas)
->       )
-
->   trsym (User module "New_ab") = True
->   trsym = const False
-
->   looping :: * -> rule * ** -> bool
->   looping symbol rule
->   =   rdef & rsym=symbol & rargs=args
->       where args = lhs rule; root = rhs rule; graph = rulegraph rule
->             (rdef,(rsym,rargs)) = dnc (const "in looping") graph root
-
-------------------------------------------------------------------------
-
-    listtrace :: [char] -> [[char]] -> [char]
-    listtrace main = lay.map clitraces.mktraces.stripexports main.loadclis.(main:)
-
->   clitraces :: (symbol,(trace symbol node node,[rule symbol node])) -> [char]
->   clitraces (sym,(trace,rules)) = lay (printtrace sym showsymbol shownode shownode trace)
-
-    mktraces :: cli -> [(symbol,(trace symbol node node,[rule symbol node]))]
-    mktraces cli
-    =   depthfirst
-        (   foldr addsymbols [].
-            snd.
-            snd
-        )
-        (pairwith clisymred')
-        (exports cli)
-        where clisymred' symbol
-              =   clisymred ((~=hd heap).rhs) cli symbol (initrule heap (lhs.typerule cli) symbol)
-
->   addsymbols :: rule * *** -> [*] -> [*]
->   addsymbols rule rest
->   =   foldr (addsymbol.dnc (const "in addsymbols") rgraph) rest nodes
->       where nodes = nodelist rgraph (rroot:lroots)
->             rgraph = rulegraph rule
->             rroot = rhs rule
->             lroots = lhs rule
->             addsymbol (def,(sym,args)) = cond def (sym:) id
-
-------------------------------------------------------------------------
-
->   list :: [char] -> [[char]] -> [char]
-
->   list main = showcli.stripexports main.loadclis.(main:)
-
-------------------------------------------------------------------------
-
-    clisymred :: (rule symbol **->bool) -> cli -> symbol -> ([**],rule symbol **) -> (trace symbol ** node,[rule symbol **])
-
-    clisymred unchanged cli symbol rule
-    =   (   mapsnd (filter unchanged)
-        .   pairwith tips
-        .   onresults (foldtrace symbol)
-        .   loop strategy' complete' matchable'
-        ) rule
-        where complete'
-              =   (~).converse matchable' (mkrgraph () emptygraph)
-              matchable' = matchable (complete cli)
-              strategy' = clistrategy cli
-
->   matchable :: ([*]->bool)->[rgraph * ***]->rgraph * **->bool
-
->   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
-sym with the given arguments, curried if there are too few.
-
->   ctyperule
->   ::  **** ->
->       [*****] ->
->       (*->rule **** *****) ->
->       (*,[**]) ->
->       rule **** *****
-
->   ctyperule fn typeheap typerule (sym,args)
->   =   mkrule targs' troot' tgraph'
->       where targs = lhs trule; troot = rhs trule; tgraph = rulegraph trule
->             trule = typerule sym
->             (targs',targs'') = claim args targs
->             (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)
-*/
-
-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,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
-*/