haftmann@38970: (* Title: Tools/Code/code_namespace.ML haftmann@38970: Author: Florian Haftmann, TU Muenchen haftmann@38970: haftmann@38970: Mastering target language namespaces. haftmann@38970: *) haftmann@38970: haftmann@38970: signature CODE_NAMESPACE = haftmann@38970: sig haftmann@39017: datatype ('a, 'b) node = haftmann@38970: Dummy haftmann@39017: | Stmt of 'a haftmann@39017: | Module of ('b * (string * ('a, 'b) node) Graph.T); haftmann@38970: val hierarchical_program: (string -> string) -> { module_alias: string -> string option, haftmann@39022: reserved: Name.context, empty_nsp: 'c, namify_module: string -> 'c -> string * 'c, haftmann@39022: namify_stmt: Code_Thingol.stmt -> string -> 'c -> string * 'c, haftmann@39022: cyclic_modules: bool, empty_data: 'b, memorize_data: string -> 'b -> 'b, haftmann@39022: modify_stmt: Code_Thingol.stmt -> Code_Thingol.stmt option } haftmann@38970: -> Code_Thingol.program haftmann@38970: -> { deresolver: string list -> string -> string, haftmann@39017: hierarchical_program: (string * (Code_Thingol.stmt, 'b) node) Graph.T } haftmann@38970: end; haftmann@38970: haftmann@38970: structure Code_Namespace : CODE_NAMESPACE = haftmann@38970: struct haftmann@38970: haftmann@38970: (* hierarchical program structure *) haftmann@38970: haftmann@39017: datatype ('a, 'b) node = haftmann@38970: Dummy haftmann@39017: | Stmt of 'a haftmann@39017: | Module of ('b * (string * ('a, 'b) node) Graph.T); haftmann@38970: haftmann@39018: fun map_module_content f (Module content) = Module (f content); haftmann@39018: haftmann@39018: fun map_module [] = I haftmann@39018: | map_module (name_fragment :: name_fragments) = haftmann@39018: apsnd o Graph.map_node name_fragment o apsnd o map_module_content haftmann@39018: o map_module name_fragments; haftmann@39018: haftmann@38970: fun hierarchical_program labelled_name { module_alias, reserved, empty_nsp, haftmann@39022: namify_module, namify_stmt, cyclic_modules, empty_data, memorize_data, modify_stmt } program = haftmann@38970: let haftmann@38970: haftmann@38970: (* building module name hierarchy *) haftmann@38970: fun alias_fragments name = case module_alias name haftmann@38970: of SOME name' => Long_Name.explode name' haftmann@38970: | NONE => map (fn name => fst (yield_singleton Name.variants name reserved)) haftmann@38970: (Long_Name.explode name); haftmann@38970: val module_names = Graph.fold (insert (op =) o fst o Code_Printer.dest_name o fst) program []; haftmann@38970: val fragments_tab = fold (fn name => Symtab.update haftmann@38970: (name, alias_fragments name)) module_names Symtab.empty; haftmann@38970: val dest_name = Code_Printer.dest_name #>> (the o Symtab.lookup fragments_tab); haftmann@38970: haftmann@38970: (* building empty module hierarchy *) haftmann@38970: val empty_module = (empty_data, Graph.empty); haftmann@38970: fun ensure_module name_fragment (data, nodes) = haftmann@38970: if can (Graph.get_node nodes) name_fragment then (data, nodes) haftmann@38970: else (data, haftmann@38970: nodes |> Graph.new_node (name_fragment, (name_fragment, Module empty_module))); haftmann@38970: fun allocate_module [] = I haftmann@38970: | allocate_module (name_fragment :: name_fragments) = haftmann@38970: ensure_module name_fragment haftmann@39018: #> (apsnd o Graph.map_node name_fragment o apsnd o map_module_content o allocate_module) name_fragments; haftmann@38970: val empty_program = Symtab.fold (fn (_, fragments) => allocate_module fragments) haftmann@38970: fragments_tab empty_module; haftmann@38970: haftmann@38970: (* distribute statements over hierarchy *) haftmann@38970: fun add_stmt name stmt = haftmann@38970: let haftmann@38970: val (name_fragments, base) = dest_name name; haftmann@38970: in haftmann@39018: (map_module name_fragments o apsnd) (Graph.new_node (name, (base, Stmt stmt))) haftmann@38970: end; haftmann@38970: fun add_dependency name name' = haftmann@38970: let haftmann@38970: val (name_fragments, base) = dest_name name; haftmann@38970: val (name_fragments', base') = dest_name name'; haftmann@38970: val (name_fragments_common, (diff, diff')) = haftmann@38970: chop_prefix (op =) (name_fragments, name_fragments'); haftmann@38970: val (is_module, dep) = if null diff then (false, (name, name')) haftmann@38970: else (true, (hd diff, hd diff')) haftmann@38970: val add_edge = if is_module andalso not cyclic_modules haftmann@38970: then (fn node => Graph.add_edge_acyclic dep node haftmann@38970: handle Graph.CYCLES _ => error ("Dependency " haftmann@38970: ^ quote name ^ " -> " ^ quote name' haftmann@38970: ^ " would result in module dependency cycle")) haftmann@38970: else Graph.add_edge dep haftmann@39018: in (map_module name_fragments_common o apsnd) add_edge end; haftmann@38970: val proto_program = empty_program haftmann@38970: |> Graph.fold (fn (name, (stmt, _)) => add_stmt name stmt) program haftmann@38970: |> Graph.fold (fn (name, (_, (_, names))) => fold (add_dependency name) names) program; haftmann@38970: haftmann@39022: (* name declarations, data and statement modifications *) haftmann@38970: fun make_declarations nsps (data, nodes) = haftmann@38970: let haftmann@38970: val (module_fragments, stmt_names) = List.partition haftmann@38970: (fn name_fragment => case Graph.get_node nodes name_fragment haftmann@38970: of (_, Module _) => true | _ => false) (Graph.keys nodes); haftmann@39022: fun declare namify name (nsps, nodes) = haftmann@38970: let haftmann@38970: val (base, node) = Graph.get_node nodes name; haftmann@38970: val (base', nsps') = namify node base nsps; haftmann@39022: val nodes' = Graph.map_node name (K (base', node)) nodes; haftmann@38970: in (nsps', nodes') end; haftmann@38970: val (nsps', nodes') = (nsps, nodes) haftmann@39022: |> fold (declare (K namify_module)) module_fragments haftmann@39022: |> fold (declare (namify_stmt o (fn Stmt stmt => stmt))) stmt_names; haftmann@38970: val nodes'' = nodes' haftmann@38970: |> fold (fn name_fragment => (Graph.map_node name_fragment haftmann@39022: o apsnd o map_module_content) (make_declarations nsps')) module_fragments haftmann@39022: |> fold (fn name => (Graph.map_node name o apsnd) (fn Stmt stmt => haftmann@39022: case modify_stmt stmt of NONE => Dummy | SOME stmt => Stmt stmt)) stmt_names; haftmann@39018: val data' = fold memorize_data stmt_names data; haftmann@39018: in (data', nodes'') end; haftmann@38970: val (_, hierarchical_program) = make_declarations empty_nsp proto_program; haftmann@38970: haftmann@38970: (* deresolving *) haftmann@38970: fun deresolver prefix_fragments name = haftmann@38970: let haftmann@38970: val (name_fragments, _) = dest_name name; haftmann@38970: val (_, (_, remainder)) = chop_prefix (op =) (prefix_fragments, name_fragments); haftmann@38970: val nodes = fold (fn name_fragment => fn nodes => case Graph.get_node nodes name_fragment haftmann@38970: of (_, Module (_, nodes)) => nodes) name_fragments hierarchical_program; haftmann@38970: val (base', _) = Graph.get_node nodes name; haftmann@38970: in Long_Name.implode (remainder @ [base']) end haftmann@38970: handle Graph.UNDEF _ => error ("Unknown statement name: " ^ labelled_name name); haftmann@38970: haftmann@38970: in { deresolver = deresolver, hierarchical_program = hierarchical_program } end; haftmann@38970: haftmann@38970: end;