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 *)