toplevel/expunge.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
   6 (*                                                                     *)
   7 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
   8 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   9 (*  under the terms of the Q Public License version 1.0.               *)
  10 (*                                                                     *)
  11 (***********************************************************************)
  12
  13 (* $Id$ *)
  14
  15 (* "Expunge" a toplevel by removing compiler modules from the global List.map.
  16    Usage: expunge <source file> <dest file> <names of modules to keep> *)
  17
  18 open Sys
  19 open Misc
  20
  21 module StringSet =
  22   Set.Make(struct
  23     type t = string
  24     let compare = compare
  25   end)
  26
  27 let to_keep = ref StringSet.empty
  28
  29 let expunge_map tbl =
  30   Symtable.filter_global_map
  31     (fun id -> StringSet.mem (Ident.name id) !to_keep)
  32     tbl
  33
  34 let expunge_crcs tbl =
  35   List.filter (fun (unit, crc) -> StringSet.mem unit !to_keep) tbl
  36
  37 let main () =
  38   let input_name = Sys.argv.(1) in
  39   let output_name = Sys.argv.(2) in
  40   Array.iter
  41     (fun exn -> to_keep := StringSet.add exn !to_keep)
  42     Runtimedef.builtin_exceptions;
  43   for i = 3 to Array.length Sys.argv - 1 do
  44     to_keep := StringSet.add (String.capitalize Sys.argv.(i)) !to_keep
  45   done;
  46   let ic = open_in_bin input_name in
  47   Bytesections.read_toc ic;
  48   let toc = Bytesections.toc() in
  49   let pos_first_section = Bytesections.pos_first_section ic in
  50   let oc =
  51     open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] 0o777
  52                  output_name in
  53   (* Copy the file up to the symbol section as is *)
  54   seek_in ic 0;
  55   copy_file_chunk ic oc pos_first_section;
  56   (* Copy each section, modifying the symbol section in passing *)
  57   Bytesections.init_record oc;
  58   List.iter
  59     (fun (name, len) ->
  60       begin match name with
  61         "SYMB" ->
  62           let global_map = (input_value ic : Symtable.global_map) in
  63           output_value oc (expunge_map global_map)
  64       | "CRCS" ->
  65           let crcs = (input_value ic : (string * Digest.t) list) in
  66           output_value oc (expunge_crcs crcs)
  67       | _ ->
  68           copy_file_chunk ic oc len
  69       end;
  70       Bytesections.record oc name)
  71     toc;
  72   (* Rewrite the toc and trailer *)
  73   Bytesections.write_toc_and_trailer oc;
  74   (* Done *)
  75   close_in ic;
  76   close_out oc
  77
  78 let _ = Printexc.catch main (); exit 0