l4/pkg/ocaml/contrib/bytecomp/bytelibrarian.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: bytelibrarian.ml 7422 2006-05-11 15:50:53Z xleroy $ *)
  14
  15 (* Build libraries of .cmo files *)
  16
  17 open Misc
  18 open Config
  19 open Cmo_format
  20
  21 type error =
  22     File_not_found of string
  23   | Not_an_object_file of string
  24
  25 exception Error of error
  26
  27 (* Copy a compilation unit from a .cmo or .cma into the archive *)
  28 let copy_compunit ic oc compunit =
  29   seek_in ic compunit.cu_pos;
  30   compunit.cu_pos <- pos_out oc;
  31   compunit.cu_force_link <- !Clflags.link_everything;
  32   copy_file_chunk ic oc compunit.cu_codesize;
  33   if compunit.cu_debug > 0 then begin
  34     seek_in ic compunit.cu_debug;
  35     compunit.cu_debug <- pos_out oc;
  36     copy_file_chunk ic oc compunit.cu_debugsize
  37   end
  38
  39 (* Add C objects and options and "custom" info from a library descriptor *)
  40
  41 let lib_sharedobjs = ref []
  42 let lib_ccobjs = ref []
  43 let lib_ccopts = ref []
  44 let lib_dllibs = ref []
  45
  46 (* See Bytelink.add_ccobjs for explanations on how options are ordered.
  47    Notice that here we scan .cma files given on the command line from
  48    left to right, hence options must be added after. *)
  49
  50 let add_ccobjs l =
  51   if not !Clflags.no_auto_link then begin
  52     if l.lib_custom then Clflags.custom_runtime := true;
  53     lib_ccobjs := !lib_ccobjs @ l.lib_ccobjs;
  54     lib_ccopts := !lib_ccopts @ l.lib_ccopts;
  55     lib_dllibs := !lib_dllibs @ l.lib_dllibs
  56   end
  57
  58 let copy_object_file oc name =
  59   let file_name =
  60     try
  61       find_in_path !load_path name
  62     with Not_found ->
  63       raise(Error(File_not_found name)) in
  64   let ic = open_in_bin file_name in
  65   try
  66     let buffer = String.create (String.length cmo_magic_number) in
  67     really_input ic buffer 0 (String.length cmo_magic_number);
  68     if buffer = cmo_magic_number then begin
  69       let compunit_pos = input_binary_int ic in
  70       seek_in ic compunit_pos;
  71       let compunit = (input_value ic : compilation_unit) in
  72       Bytelink.check_consistency file_name compunit;
  73       copy_compunit ic oc compunit;
  74       close_in ic;
  75       [compunit]
  76     end else
  77     if buffer = cma_magic_number then begin
  78       let toc_pos = input_binary_int ic in
  79       seek_in ic toc_pos;
  80       let toc = (input_value ic : library) in
  81       List.iter (Bytelink.check_consistency file_name) toc.lib_units;
  82       add_ccobjs toc;
  83       List.iter (copy_compunit ic oc) toc.lib_units;
  84       close_in ic;
  85       toc.lib_units
  86     end else
  87       raise(Error(Not_an_object_file file_name))
  88   with
  89     End_of_file -> close_in ic; raise(Error(Not_an_object_file file_name))
  90   | x -> close_in ic; raise x
  91
  92 let create_archive file_list lib_name =
  93   let outchan = open_out_bin lib_name in
  94   try
  95     output_string outchan cma_magic_number;
  96     let ofs_pos_toc = pos_out outchan in
  97     output_binary_int outchan 0;
  98     let units = List.flatten(List.map (copy_object_file outchan) file_list) in
  99     let toc =
 100       { lib_units = units;
 101         lib_custom = !Clflags.custom_runtime;
 102         lib_ccobjs = !Clflags.ccobjs @ !lib_ccobjs;
 103         lib_ccopts = !Clflags.ccopts @ !lib_ccopts;
 104         lib_dllibs = !Clflags.dllibs @ !lib_dllibs } in
 105     let pos_toc = pos_out outchan in
 106     output_value outchan toc;
 107     seek_out outchan ofs_pos_toc;
 108     output_binary_int outchan pos_toc;
 109     close_out outchan
 110   with x ->
 111     close_out outchan;
 112     remove_file lib_name;
 113     raise x
 114
 115 open Format
 116
 117 let report_error ppf = function
 118   | File_not_found name ->
 119       fprintf ppf "Cannot find file %s" name
 120   | Not_an_object_file name ->
 121       fprintf ppf "The file %s is not a bytecode object file" name
 122