src/Tools/Code/code_namespace.ML
changeset 39208 fc1e02735438
parent 39203 b2f9a6f4b84b
child 40629 f276d46d4ec0
     1.1 --- a/src/Tools/Code/code_namespace.ML	Tue Sep 07 16:37:23 2010 +0200
     1.2 +++ b/src/Tools/Code/code_namespace.ML	Tue Sep 07 16:37:23 2010 +0200
     1.3 @@ -6,15 +6,20 @@
     1.4  
     1.5  signature CODE_NAMESPACE =
     1.6  sig
     1.7 -  val dest_name: string -> string * string
     1.8 -  val build_module_namespace: { module_alias: string -> string option,
     1.9 -    module_prefix: string option, reserved: Name.context } -> Code_Thingol.program
    1.10 -    -> string list Symtab.table
    1.11 +  type flat_program
    1.12 +  val flat_program: (string -> string) -> { module_alias: string -> string option,
    1.13 +    module_prefix: string, reserved: Name.context, empty_nsp: 'a,
    1.14 +    namify_stmt: Code_Thingol.stmt -> string -> 'a -> string * 'a,
    1.15 +    modify_stmt: Code_Thingol.stmt -> Code_Thingol.stmt option }
    1.16 +      -> Code_Thingol.program
    1.17 +      -> { deresolver: string -> string -> string,
    1.18 +           flat_program: flat_program }
    1.19 +
    1.20    datatype ('a, 'b) node =
    1.21        Dummy
    1.22      | Stmt of 'a
    1.23      | Module of ('b * (string * ('a, 'b) node) Graph.T)
    1.24 -  type ('a, 'b) hierarchical_program = (string * ('a, 'b) node) Graph.T
    1.25 +  type ('a, 'b) hierarchical_program
    1.26    val hierarchical_program: (string -> string) -> { module_alias: string -> string option,
    1.27      reserved: Name.context, empty_nsp: 'c, namify_module: string -> 'c -> string * 'c,
    1.28      namify_stmt: Code_Thingol.stmt -> string -> 'c -> string * 'c,
    1.29 @@ -45,11 +50,85 @@
    1.30            (Long_Name.explode name);
    1.31      val module_names = Graph.fold (insert (op =) o fst o dest_name o fst) program [];
    1.32    in
    1.33 -    fold (fn name => Symtab.update (name, alias_fragments name))
    1.34 +    fold (fn name => Symtab.update (name, Long_Name.explode module_prefix @ alias_fragments name))
    1.35        module_names Symtab.empty
    1.36    end;
    1.37  
    1.38  
    1.39 +(** flat program structure **)
    1.40 +
    1.41 +type flat_program = ((string * Code_Thingol.stmt option) Graph.T * (string * string list) list) Graph.T;
    1.42 +
    1.43 +fun flat_program labelled_name { module_alias, module_prefix, reserved,
    1.44 +      empty_nsp, namify_stmt, modify_stmt } program =
    1.45 +  let
    1.46 +
    1.47 +    (* building module name hierarchy *)
    1.48 +    val fragments_tab = build_module_namespace { module_alias = module_alias,
    1.49 +      module_prefix = module_prefix, reserved = reserved } program;
    1.50 +    val dest_name = dest_name
    1.51 +      #>> (Long_Name.implode o the o Symtab.lookup fragments_tab);
    1.52 +
    1.53 +    (* distribute statements over hierarchy *)
    1.54 +    fun add_stmt name stmt =
    1.55 +      let
    1.56 +        val (module_name, base) = dest_name name;
    1.57 +      in
    1.58 +        Graph.default_node (module_name, (Graph.empty, []))
    1.59 +        #> (Graph.map_node module_name o apfst) (Graph.new_node (name, (base, stmt)))
    1.60 +      end;
    1.61 +    fun add_dependency name name' =
    1.62 +      let
    1.63 +        val (module_name, base) = dest_name name;
    1.64 +        val (module_name', base') = dest_name name';
    1.65 +      in if module_name = module_name'
    1.66 +        then (Graph.map_node module_name o apfst) (Graph.add_edge (name, name'))
    1.67 +        else (Graph.map_node module_name o apsnd) (AList.map_default (op =) (module_name', []) (insert (op =) name'))
    1.68 +      end;
    1.69 +    val proto_program = Graph.empty
    1.70 +      |> Graph.fold (fn (name, (stmt, _)) => add_stmt name stmt) program
    1.71 +      |> Graph.fold (fn (name, (_, (_, names))) => fold (add_dependency name) names) program;
    1.72 +
    1.73 +    (* name declarations and statement modifications *)
    1.74 +    fun declare name (base, stmt) (gr, nsp) = 
    1.75 +      let
    1.76 +        val (base', nsp') = namify_stmt stmt base nsp;
    1.77 +        val gr' = (Graph.map_node name o apfst) (K base') gr;
    1.78 +      in (gr', nsp') end;
    1.79 +    fun declarations gr = (gr, empty_nsp)
    1.80 +      |> fold (fn name => declare name (Graph.get_node gr name)) (Graph.keys gr) 
    1.81 +      |> fst
    1.82 +      |> (Graph.map o K o apsnd) modify_stmt;
    1.83 +    val flat_program = proto_program
    1.84 +      |> (Graph.map o K o apfst) declarations;
    1.85 +
    1.86 +    (* qualified and unqualified imports, deresolving *)
    1.87 +    fun base_deresolver name = fst (Graph.get_node
    1.88 +      (fst (Graph.get_node flat_program (fst (dest_name name)))) name);
    1.89 +    fun classify_names gr imports =
    1.90 +      let
    1.91 +        val import_tab = maps
    1.92 +          (fn (module_name, names) => map (rpair module_name) names) imports;
    1.93 +        val imported_names = map fst import_tab;
    1.94 +        val here_names = Graph.keys gr;
    1.95 +      in
    1.96 +        Symtab.empty
    1.97 +        |> fold (fn name => Symtab.update (name, base_deresolver name)) here_names
    1.98 +        |> fold (fn name => Symtab.update (name,
    1.99 +            Long_Name.append (the (AList.lookup (op =) import_tab name))
   1.100 +              (base_deresolver name))) imported_names
   1.101 +      end;
   1.102 +    val name_tabs = AList.make (uncurry classify_names o Graph.get_node flat_program)
   1.103 +      (Graph.keys flat_program);
   1.104 +    val deresolver_tab = Symtab.empty
   1.105 +      |> fold (fn (module_name, name_tab) => Symtab.update (module_name, name_tab)) name_tabs;
   1.106 +    fun deresolver module_name name =
   1.107 +      the (Symtab.lookup (the (Symtab.lookup deresolver_tab module_name)) name)
   1.108 +      handle Option => error ("Unknown statement name: " ^ labelled_name name);
   1.109 +
   1.110 +  in { deresolver = deresolver, flat_program = flat_program } end;
   1.111 +
   1.112 +
   1.113  (** hierarchical program structure **)
   1.114  
   1.115  datatype ('a, 'b) node =
   1.116 @@ -72,7 +151,7 @@
   1.117  
   1.118      (* building module name hierarchy *)
   1.119      val fragments_tab = build_module_namespace { module_alias = module_alias,
   1.120 -      module_prefix = NONE, reserved = reserved } program;
   1.121 +      module_prefix = "", reserved = reserved } program;
   1.122      val dest_name = dest_name #>> (the o Symtab.lookup fragments_tab);
   1.123  
   1.124      (* building empty module hierarchy *)