src/Tools/Code/code_namespace.ML
changeset 39023 3f70c03e8282
parent 39022 ac7774a35bcf
child 39024 30d5dd2f30b6
     1.1 --- a/src/Tools/Code/code_namespace.ML	Wed Sep 01 16:08:31 2010 +0200
     1.2 +++ b/src/Tools/Code/code_namespace.ML	Wed Sep 01 17:14:42 2010 +0200
     1.3 @@ -14,10 +14,10 @@
     1.4      reserved: Name.context, empty_nsp: 'c, namify_module: string -> 'c -> string * 'c,
     1.5      namify_stmt: Code_Thingol.stmt -> string -> 'c -> string * 'c,
     1.6      cyclic_modules: bool, empty_data: 'b, memorize_data: string -> 'b -> 'b,
     1.7 -    modify_stmt: Code_Thingol.stmt -> Code_Thingol.stmt option }
     1.8 +    modify_stmts: Code_Thingol.stmt list -> 'a option list }
     1.9        -> Code_Thingol.program
    1.10        -> { deresolver: string list -> string -> string,
    1.11 -           hierarchical_program: (string * (Code_Thingol.stmt, 'b) node) Graph.T }
    1.12 +           hierarchical_program: (string * ('a, 'b) node) Graph.T }
    1.13  end;
    1.14  
    1.15  structure Code_Namespace : CODE_NAMESPACE =
    1.16 @@ -38,7 +38,7 @@
    1.17          o map_module name_fragments;
    1.18  
    1.19  fun hierarchical_program labelled_name { module_alias, reserved, empty_nsp,
    1.20 -      namify_module, namify_stmt, cyclic_modules, empty_data, memorize_data, modify_stmt } program =
    1.21 +      namify_module, namify_stmt, cyclic_modules, empty_data, memorize_data, modify_stmts } program =
    1.22    let
    1.23  
    1.24      (* building module name hierarchy *)
    1.25 @@ -77,8 +77,8 @@
    1.26          val (name_fragments', base') = dest_name name';
    1.27          val (name_fragments_common, (diff, diff')) =
    1.28            chop_prefix (op =) (name_fragments, name_fragments');
    1.29 -        val (is_module, dep) = if null diff then (false, (name, name'))
    1.30 -          else (true, (hd diff, hd diff'))
    1.31 +        val is_module = not (null diff andalso null diff');
    1.32 +        val dep = pairself hd (diff @ [name], diff' @ [name']);
    1.33          val add_edge = if is_module andalso not cyclic_modules
    1.34            then (fn node => Graph.add_edge_acyclic dep node
    1.35              handle Graph.CYCLES _ => error ("Dependency "
    1.36 @@ -105,11 +105,15 @@
    1.37          val (nsps', nodes') = (nsps, nodes)
    1.38            |> fold (declare (K namify_module)) module_fragments
    1.39            |> fold (declare (namify_stmt o (fn Stmt stmt => stmt))) stmt_names;
    1.40 -        val nodes'' = nodes'
    1.41 -          |> fold (fn name_fragment => (Graph.map_node name_fragment
    1.42 -              o apsnd o map_module_content) (make_declarations nsps')) module_fragments
    1.43 -          |> fold (fn name => (Graph.map_node name o apsnd) (fn Stmt stmt =>
    1.44 -               case modify_stmt stmt of NONE => Dummy | SOME stmt => Stmt stmt)) stmt_names;
    1.45 +        val modify_stmts' = filter (member (op =) stmt_names)
    1.46 +          #> AList.make (snd o Graph.get_node nodes)
    1.47 +          #> split_list
    1.48 +          ##> map (fn Stmt stmt => stmt)
    1.49 +          ##> modify_stmts
    1.50 +          #> op ~~;
    1.51 +        val stmtss' = maps modify_stmts' (Graph.strong_conn nodes);
    1.52 +        val nodes'' = Graph.map (fn name => apsnd (fn Module content => Module (make_declarations nsps' content)
    1.53 +            | _ => case AList.lookup (op =) stmtss' name of SOME (SOME stmt) => Stmt stmt | _ => Dummy)) nodes';
    1.54          val data' = fold memorize_data stmt_names data;
    1.55        in (data', nodes'') end;
    1.56      val (_, hierarchical_program) = make_declarations empty_nsp proto_program;