PreviousUpNext

15.4.99  src/app/makelib/portable-graph/gen-sml.pkg

## gen-sml.pkg

# Compiled by:
#     src/app/makelib/portable-graph/portable-graph-stuff.lib



# Generate SML source code for a given library.


stipulate
    package fil =  file__premicrothread;                                # file__premicrothread  is from   src/lib/std/src/posix/file--premicrothread.pkg
    package p= portable_graph;                                          # portable_graph        is from   src/app/makelib/portable-graph/portable-graph.pkg
herein
    package gen_sml: (weak)  api {
                            Type = String;
                            Varname = String;

                            exception TYPE_ERROR  (Type, Varname);
                            exception UNBOUND  Varname;
                            exception IMPORT_MISMATCH;

                             gen:  {   graph: p::Graph,
                                          nativesrc: String -> String,
                                          importstructs: List( String ),
                                          output_stream: fil::Output_Stream,
                                          exportprefix: String,
                                          use_toplocal: Bool
                                      }
                                   -> Void;
                        }
    {
        Type     = String;
        Varname = String;

        exception TYPE_ERROR  (Type, Varname);
        exception UNBOUND  Varname;
        exception IMPORT_MISMATCH;

        package m
            =
            red_black_map_g (                                           # red_black_map_g               is from   src/lib/src/red-black-map-g.pkg
                Key = String;
                compare = string::compare;
            );

        Namespace = String;
        Name      = String;

        Symbol = (Namespace, Name);

        fun symbol_compare ((ns, n), (ns', n'))
            =
            case (string::compare (n, n'))
              
                 EQUAL   => string::compare (ns, ns');
                 unequal => unequal;
            esac;

        package ss
            =
            red_black_set_g (
                Key = Symbol;
                compare = symbol_compare;
            );

        package sm
            =
            red_black_map_g (
                Key = Symbol;
                compare = symbol_compare;
            );

        Naming = SYM   Symbol
               | SYMS  ss::Set
               | DICTIONARY  sm::Map( Symbol );

        fun gen args
            =
            {   args
                    ->
                    { graph => p::GRAPH { imports, defs, export },
                      nativesrc,
                      importstructs,
                      output_stream => outs,
                      exportprefix,
                      use_toplocal
                    };

                my (xlocal, xin, xend)
                    =
                    if   use_toplocal      ("stipulate", "herein", "end");
                                        else   ("/* stipulate */", "/* herein */", "/* end */");  fi;

                fun out l
                    =
                    apply (fn s =  fil::write (outs, s)) l;

                im
                    =
                    if   (length imports == length importstructs)
                        
                          fun add (v, str, m)
                                 =
                                 m::set (m, v, str);

                             m = paired_lists::fold_forward add m::empty (imports, importstructs);
                         
                             fn v =  m::get (m, v);
                         
                    else
                         raise exception IMPORT_MISMATCH;
                    fi;

                gensym
                    =
                    {   next = REF 0;
                    
                        fn () => { i = *next;
                                 
                                     next := i + 1;
                                     "gs_" + int::to_string i;
                                 }; end ;
                    };

                fun genexport (ss, fmt)
                    =
                    {   sl = ss::vals_list ss;
                        sl' = map (fn (ns, n) = (ns, gensym ())) sl;

                        fun oneline (symbol, symbol', e)
                            =
                            {   fmt (symbol, symbol');
                                sm::set (e, symbol, symbol');
                            };
                    
                        paired_lists::fold_forward oneline sm::empty (sl, sl');
                    };

                fun an_import (lib, ss)
                    =
                    {   lstruct = case (im lib)
                                    
                                        NULL  =>  raise exception UNBOUND lib;
                                        THE n =>  n;
                                  esac;

                        fun fmt ((ns, n), (_, n'))
                            =
                            out [ns, " ", n', " = ", lstruct, n, "\n"];
                    
                        genexport (ss, fmt);
                    };

                fun genimport ((ns, n), (_, n'))
                    =
                    out ["    ", ns, " ", n, " = ", n', "\n"];

                fun compile (src, native, e, oss)
                    =
                    {   fun fmt ((ns, n), (_, n'))
                            =
                            out [ns, " ", n', " = ", n, "\n"];

                        fun copyfile src
                            =
                            copy ()
                            where
                                ins = fil::open_for_read (if native  src; else nativesrc src;fi);

                                fun copy ()
                                    =
                                    case (fil::read ins)
                                        #
                                        "" =>  fil::close_input ins;
                                        s  =>  { out [s]; copy (); };
                                    esac;
                            end;
                    
                        out [xlocal, "\n"];
                        sm::keyed_apply genimport e;
                        out [xin, "\n"];
                        copyfile src;

                        genexport (oss, fmt)
                        before
                            out [xend, "\n"];
                    };

                fun filter (e, ss)
                    =
                    sm::keyed_filter (fn (symbol, _) => ss::member (ss, symbol); end ) e;

                fun get dm v
                    =
                    case (m::get (dm, v))
                        #                     
                        NULL  =>  raise exception UNBOUND v;
                        THE d =>  d;
                    esac;

                fun get_dictionary dm v
                    =
                    case (get dm v)
                        #
                        DICTIONARY m =>  m;
                        _      =>  raise exception TYPE_ERROR ("dictionary", v);
                    esac;

                fun namespace p::SGN       => "api";
                    namespace p::PACKAGE   => "package";
                    namespace p::GENERIC   => "generic";
                end;

                fun onedef (p::DEF { lhs, rhs }, dm)
                    =
                    {   get      =  get dm;
                        get_dictionary =  get_dictionary dm;

                        fun get_sym v
                            =
                            case (get v)
                                #
                                SYM s =>  s;
                                _     =>  raise exception TYPE_ERROR ("symbol", v);
                            esac;

                        fun get_syms v
                            =
                            case (get v)
                                #
                                SYMS ss =>  ss;
                                _       =>  raise exception TYPE_ERROR ("syms", v);
                            esac;
                    
                        m::set (   dm,
                                   lhs,

                                   case rhs
                                       #                                             
                                       p::SYM (ns, n)
                                           =>
                                           SYM (namespace ns, n);

                                       p::SYMS vl
                                           =>
                                           {   fun one (v, ss) = ss::add (ss, get_sym v);

                                               SYMS (fold_forward one ss::empty vl);
                                           };

                                       p::IMPORT { lib, syms }
                                           =>
                                           DICTIONARY (an_import (lib, get_syms syms));

                                       p::COMPILE { src => (src, native), env=>dictionary, syms }
                                           =>
                                           DICTIONARY (compile (src, native, get_dictionary dictionary, get_syms syms));

                                       p::FILTER { env=>dictionary, syms }
                                           =>
                                           DICTIONARY (filter (get_dictionary dictionary, get_syms syms));

                                       p::MERGE el
                                           =>
                                           {   fun one (v, e)
                                                   =
                                                   sm::union_with #2 (get_dictionary v, e);

                                               DICTIONARY (fold_forward one sm::empty el);
                                           };
                                   esac
                              );
                    };

                out ["stipulate\n"];

                dm   =   fold_forward onedef m::empty defs;

                ee   =   get_dictionary dm export;

                fun libexport ((ns, n), (_, n'))
                    =
                    out [ns, " ", exportprefix, n, " = ", n', "\n"];

            
                out ["herein\n"];
                sm::keyed_apply libexport ee;
                out ["end\n"];
            };
    };
end;


## (C) 2001 Lucent Technologies, Bell Labs
## author: Matthias Blume (blume@research.bell-labs.com)


Comments and suggestions to: bugs@mythryl.org

PreviousUpNext