Commits

xleroy  committed d696190

Printf.sprintf et String.concat dans stdlib

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@5f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

  • Participants
  • Parent commits f8a6983

Comments (0)

Files changed (36)

File bytecomp/codegen.ml

   (Stack.new () : (Ident.t * lambda * label * Ident.t list) Stack.t)
 
 (* Compile an expression.
-   The val of the expression is left in the accumulator.
+   The value of the expression is left in the accumulator.
    env = compilation environment
    exp = the lambda expression to compile
    sz = current size of the stack frame
 
 (* Compile a list of arguments [e1; ...; eN] to a primitive operation.
    The values of eN ... e2 are pushed on the stack, e2 at top of stack,
-   then e3, then ... The val of e1 is left in the accumulator. *)
+   then e3, then ... The value of e1 is left in the accumulator. *)
 
 and comp_args env argl sz cont =
   comp_expr_list env (List.rev argl) sz cont

File bytecomp/linker.ml

   let tolink =
     List.fold_left scan_file [] (List.rev objfiles) in
   let outchan =
-    open_out_gen [Open_wronly; Open_trunc; Open_creat; Open_binary] 0o777 exec_name in
+    open_out_gen [Open_wronly; Open_trunc; Open_creat; Open_binary] 0o777
+                 exec_name in
   try
     (* Copy the header *)
     if copy_header then begin
       link_bytecode objfiles bytecode_name false;
       Symtable.output_primitives prim_name;
       if Sys.command
-          (concat_strings " " (
-            Config.c_compiler ::
-            ("-I" ^ Config.standard_library) ::
-            "-o" :: !Clflags.exec_name ::
-            List.rev !Clflags.ccopts @
-            prim_name ::
-            ("-L" ^ Config.standard_library) ::
-            List.rev !Clflags.ccobjs @
-            "-lcamlrun" ::
-            Config.c_libraries ::
-            [])) <> 0 
+          (Printf.sprintf
+           "%s -I%s -o %s %s %s -L%s %s -lcamlrun %s"
+           Config.c_compiler
+           Config.standard_library
+           !Clflags.exec_name
+           (String.concat " " (List.rev !Clflags.ccopts))
+           prim_name
+           Config.standard_library
+           (String.concat " " (List.rev !Clflags.ccobjs))
+           Config.c_libraries)
+         <> 0
       or Sys.command ("strip " ^ !Clflags.exec_name) <> 0
       then raise(Error Custom_runtime);
       let oc =
-        open_out_gen [Open_wronly; Open_append; Open_binary] 0 !Clflags.exec_name in
+        open_out_gen [Open_wronly; Open_append; Open_binary] 0
+                     !Clflags.exec_name in
       let ic = open_in_bin bytecode_name in
       copy_file ic oc;
       close_in ic;

File bytecomp/symtable.ml

   (* Enter the known C primitives *)
   Array.iter (enter_numtable c_prim_table) (Meta.available_primitives())
 
-(* Find the val of a global identifier *)
+(* Find the value of a global identifier *)
 
 let get_global_value id =
   (Meta.global_data()).(slot_for_getglobal id)

File byterun/Makefile

   intern.c interp.c ints.c io.c lexing.c meta.c parsing.c \
   signals.c str.c sys.c terminfo.c
 
-all: camlrun camlrund libcaml.a
+all: camlrun camlrund
 
 camlrun: $(OBJS) prims.o
 	$(CC) $(CCCOMPOPTS) $(CCLINKOPTS) $(LOWADDRESSES) -o camlrun prims.o $(OBJS) $(CCLIBS)
 camlrund: $(DOBJS) prims.o
 	$(CC) -g $(CCCOMPOPTS) $(CCLINKOPTS) $(LOWADDRESSES) -o camlrund prims.o $(DOBJS) $(CCLIBS)
 
-libcaml.a: $(OBJS)
-	rm -f libcaml.a
-	ar rc libcaml.a $(OBJS)
-	$(RANLIB) libcaml.a
-
 install:
 	cp camlrun $(BINDIR)/cslrun
-	cp libcaml.a $(LIBDIR)
-	$(RANLIB) $(LIBDIR)/libcaml.a
+	ar rc $(LIBDIR)/libcamlrun.a $(OBJS)
+	$(RANLIB) $(LIBDIR)/libcamlrun.a
 	test -d $(LIBDIR)/caml || mkdir $(LIBDIR)/caml
 	cp mlvalues.h alloc.h misc.h $(LIBDIR)/caml
 	sed -e '/#include ".*\/m.h/r ../config/m.h' \

File driver/compile.ml

     raise x
 
 let c_file name =
-  if Sys.command (concat_strings " " (
-    Config.c_compiler ::
-    "-c" ::
-    List.map (fun dir -> "-I" ^ dir) (List.rev !Clflags.include_dirs) @
-    ("-I" ^ Config.standard_library) ::
-    name ::
-    [])) <> 0
+  if Sys.command
+     (Printf.sprintf
+       "%s -c %s -I%s %s"
+       Config.c_compiler
+       (String.concat " "
+         (List.map (fun dir -> "-I" ^ dir) 
+                   (List.rev !Clflags.include_dirs)))
+       Config.standard_library
+       name)
+     <> 0
   then exit 2

File parsing/parser.mly

 ;
 structure_item:
     LET UNDERSCORE EQUAL expr
-      { Pstr_eval($4) }
+      { Pstr_eval $4 }
   | LET rec_flag let_bindings
       { Pstr_value($2, List.rev $3) }
   | EXTERNAL val_ident COLON core_type EQUAL STRING
 signature_item:
     VAL val_ident COLON core_type
       { Psig_value($2, {pval_type = $4; pval_prim = None}) }
-  | VAL val_ident COLON core_type EQUAL STRING
+  | EXTERNAL val_ident COLON core_type EQUAL STRING
       { Psig_value($2, {pval_type = $4; pval_prim = Some $6}) }
   | TYPE type_declarations
       { Psig_type(List.rev $2) }
 let_binding:
     val_ident fun_binding
       { ({ppat_desc = Ppat_var $1; ppat_loc = rhs_loc 1}, $2) }
-  | LPAREN pattern RPAREN EQUAL expr
-      { ($2, $5) }
+  | let_pattern EQUAL expr
+      { ($1, $3) }
 ;
 fun_binding:
     EQUAL expr %prec prec_let
     label_longident EQUAL pattern               { [($1, $3)] }
   | lbl_pattern_list SEMI label_longident EQUAL pattern { ($3, $5) :: $1 }
 ;
+let_pattern:
+    constr_longident
+      { mkpat(Ppat_construct($1, None)) }
+  | constr_longident pattern %prec prec_constr_appl
+      { mkpat(Ppat_construct($1, Some $2)) }
+  | LBRACE lbl_pattern_list RBRACE
+      { mkpat(Ppat_record(List.rev $2)) }
+  | LBRACKET pattern_semi_list RBRACKET
+      { mklistpat(List.rev $2) }
+  | LPAREN pattern RPAREN
+      { $2 }
+  | LPAREN pattern COLON core_type RPAREN
+      { mkpat(Ppat_constraint($2, $4)) }
+;
 
 /* Type declarations */
 

File stdlib/Makefile

 CAMLC=../boot/camlrun $(COMPILER)
 CAMLDEP=../tools/camldep
 
-OBJS=pervasives.cmo string.cmo char.cmo list.cmo array.cmo sys.cmo \
+OBJS=pervasives.cmo list.cmo string.cmo char.cmo array.cmo sys.cmo \
   hashtbl.cmo sort.cmo filename.cmo obj.cmo lexing.cmo parsing.cmo \
   baltree.cmo set.cmo stack.cmo queue.cmo \
   printf.cmo format.cmo arg.cmo printexc.cmo gc.cmo

File stdlib/array.mli

 (* Array operations *)
 
-val length : 'a array -> int = "%array_length"
+external length : 'a array -> int = "%array_length"
 
 val get: 'a array -> int -> 'a
 val set: 'a array -> int -> 'a -> unit
-val new: int -> 'a -> 'a array = "make_vect"
+external new: int -> 'a -> 'a array = "make_vect"
 val new_matrix: int -> int -> 'a -> 'a array array
 val concat: 'a array -> 'a array -> 'a array
 val sub: 'a array -> int -> int -> 'a array
 val to_list: 'a array -> 'a list
 val of_list: 'a list -> 'a array
 
-val unsafe_get: 'a array -> int -> 'a = "%array_get"
-val unsafe_set: 'a array -> int -> 'a -> unit = "%array_set"
+external unsafe_get: 'a array -> int -> 'a = "%array_get"
+external unsafe_set: 'a array -> int -> 'a -> unit = "%array_set"
 

File stdlib/baltree.ml

     Empty -> 1
   | Node(_, _, _, s) -> s
 
-(* Creates a new node with left son l, val x and right son r.
+(* Creates a new node with left son l, value x and right son r.
    l and r must be balanced and size l / size r must be between 1/N and N.
    Inline expansion of size for better speed. *)
 

File stdlib/char.mli

 (* Character operations *)
 
-val code: char -> int = "%identity"
+external code: char -> int = "%identity"
 val chr: int -> char
 val escaped : char -> string
-val unsafe_chr: int -> char = "%identity"
+external unsafe_chr: int -> char = "%identity"

File stdlib/format.ml

 
 (* Scan stack
    each element is (left_total, queue element) where left_total
-   is the val of pp_left_total when the element has been enqueued *)
+   is the value of pp_left_total when the element has been enqueued *)
 type pp_scan_elem = Scan_elem of int * pp_queue_elem
 let pp_scan_stack = ref ([] : pp_scan_elem list)
 
 
 let pp_tbox_stack = ref ([]:tblock list)
 
-(* Large val for default tokens size *)
+(* Large value for default tokens size *)
 let pp_infinity = 9999
 
 (* Global variables: default initialization is
    set_margin 78
    set_min_space_left 0 *)
-(* val of right margin *)
+(* value of right margin *)
 let pp_margin = ref 78
 
 (* Minimal space left before margin, when opening a block *)
 let pp_min_space_left = ref 10
-(* maximum val of indentation:
+(* maximum value of indentation:
    no blocks can be opened further *)
 let pp_max_indent = ref (!pp_margin - !pp_min_space_left)
 
 let pp_space_left = ref !pp_margin(* space remaining on the current line *)
-and pp_current_indent = ref 0	  (* current val of indentation *)
+and pp_current_indent = ref 0	  (* current value of indentation *)
 and pp_left_total = ref 1	  (* total width of tokens already printed *)
 and pp_right_total = ref 1	  (* total width of tokens ever put in queue *)
 and pp_curr_depth = ref 0	  (* current number of opened blocks *)
 
 (* Breaks: indicate where a block may be broken.
    If line is broken then offset is added to the indentation of the current
-    block else (the val of) width blanks are printed.
-   To do (?) : add a maximum width and offset val *)
+    block else (the value of) width blanks are printed.
+   To do (?) : add a maximum width and offset value *)
 let print_break (width, offset) =
     if !pp_curr_depth < !pp_max_boxes then 
       scan_push true

File stdlib/gc.mli

 -     [verbose]  This flag controls the GC messages on standard error output.
   *)
 
-val stat : unit -> stat = "gc_stat"
+external stat : unit -> stat = "gc_stat"
   (* Return the current values of the memory management counters in a
      [stat] record. *)
 val print_stat : out_channel -> unit
   (* Print the current values of the memory management counters (in
      human-readable form) into the channel argument. *)
-val get : unit -> control = "gc_get"
+external get : unit -> control = "gc_get"
   (* Return the current values of the GC parameters in a [control] record. *)
-val set : control -> unit = "gc_set"
+external set : control -> unit = "gc_set"
   (* [set r] changes the GC parameters according to the [control] record [r].
      The normal usage is:
      [
          Gc.set r              (* Set the new values. *)
      ]
   *)
-val minor : unit -> unit = "gc_minor"
+external minor : unit -> unit = "gc_minor"
   (* Trigger a minor collection. *)
-val major : unit -> unit = "gc_major"
+external major : unit -> unit = "gc_major"
   (* Finish the current major collection cycle. *)
-val full_major : unit -> unit = "gc_full_major"
+external full_major : unit -> unit = "gc_full_major"
   (* Finish the current major collection cycle and perform a complete
      new cycle.  This will collect all currently unreachable objects. *)

File stdlib/hashtbl.mli

            Moreover, [hash] always terminates, even on cyclic
            structures. *)
 
-val hash_param : int -> int -> 'a -> int = "hash_univ_param"
+external hash_param : int -> int -> 'a -> int = "hash_univ_param"
         (* [hash_param n m x] computes a hash val for [x], with the
            same properties as for [hash]. The two extra parameters [n] and
            [m] give more precise control over hashing. Hashing performs a

File stdlib/lexing.mli

    They are not intended to be used by user programs. *)
 
 val start_lexing : lexbuf -> unit
-val get_next_char : lexbuf -> char = "get_next_char"
+external get_next_char : lexbuf -> char = "get_next_char"
 val backtrack : lexbuf -> 'a

File stdlib/obj.mli

 
 type t
 
-val repr : 'a -> t = "%identity"
-val magic : 'a -> 'b = "%identity"
-val is_block : t -> bool = "obj_is_block"
-val tag : t -> int = "%tagof"
-val size : t -> int = "%array_length"
-val field : t -> int -> t = "%array_get"
-val set_field : t -> int -> t -> unit = "%array_set"
-val new_block : int -> int -> t = "obj_block"
-val update : t -> t -> unit = "%update"
+external repr : 'a -> t = "%identity"
+external magic : 'a -> 'b = "%identity"
+external is_block : t -> bool = "obj_is_block"
+external tag : t -> int = "%tagof"
+external size : t -> int = "%array_length"
+external field : t -> int -> t = "%array_get"
+external set_field : t -> int -> t -> unit = "%array_set"
+external new_block : int -> int -> t = "obj_block"
+external update : t -> t -> unit = "%update"

File stdlib/pervasives.mli

 
 (* Exceptions *)
 
-val raise : exn -> 'a = "%raise"
+external raise : exn -> 'a = "%raise"
 val failwith: string -> 'a
 val invalid_arg: string -> 'a
 
 
 (* Comparisons *)
 
-val (=) : 'a -> 'a -> bool = "%equal"
-val (<>) : 'a -> 'a -> bool = "%notequal"
-val (<) : 'a -> 'a -> bool = "%lessthan"
-val (>) : 'a -> 'a -> bool = "%greaterthan"
-val (<=) : 'a -> 'a -> bool = "%lessequal"
-val (>=) : 'a -> 'a -> bool = "%greaterequal"
-val compare: 'a -> 'a -> int = "compare"
+external (=) : 'a -> 'a -> bool = "%equal"
+external (<>) : 'a -> 'a -> bool = "%notequal"
+external (<) : 'a -> 'a -> bool = "%lessthan"
+external (>) : 'a -> 'a -> bool = "%greaterthan"
+external (<=) : 'a -> 'a -> bool = "%lessequal"
+external (>=) : 'a -> 'a -> bool = "%greaterequal"
+external compare: 'a -> 'a -> int = "compare"
 val min: 'a -> 'a -> 'a
 val max: 'a -> 'a -> 'a
-val (==) : 'a -> 'a -> bool = "%eq"
-val (!=) : 'a -> 'a -> bool = "%noteq"
+external (==) : 'a -> 'a -> bool = "%eq"
+external (!=) : 'a -> 'a -> bool = "%noteq"
 
 (* Boolean operations *)
 
-val not : bool -> bool = "%boolnot"
-val (&) : bool -> bool -> bool = "%sequand"
-val (or) : bool -> bool -> bool = "%sequor"
+external not : bool -> bool = "%boolnot"
+external (&) : bool -> bool -> bool = "%sequand"
+external (or) : bool -> bool -> bool = "%sequor"
 
 (* Integer operations *)
 
-val (~-) : int -> int = "%negint"
-val succ : int -> int = "%succint"
-val pred : int -> int = "%predint"
-val (+) : int -> int -> int = "%addint"
-val (-) : int -> int -> int = "%subint"
-val ( * ) : int -> int -> int = "%mulint"
-val (/) : int -> int -> int = "%divint"
-val (mod) : int -> int -> int = "%modint"
+external (~-) : int -> int = "%negint"
+external succ : int -> int = "%succint"
+external pred : int -> int = "%predint"
+external (+) : int -> int -> int = "%addint"
+external (-) : int -> int -> int = "%subint"
+external ( * ) : int -> int -> int = "%mulint"
+external (/) : int -> int -> int = "%divint"
+external (mod) : int -> int -> int = "%modint"
 val abs : int -> int
-val (land) : int -> int -> int = "%andint"
-val (lor) : int -> int -> int = "%orint"
-val (lxor) : int -> int -> int = "%xorint"
+external (land) : int -> int -> int = "%andint"
+external (lor) : int -> int -> int = "%orint"
+external (lxor) : int -> int -> int = "%xorint"
 val lnot: int -> int
-val (lsl) : int -> int -> int = "%lslint"
-val (lsr) : int -> int -> int = "%lsrint"
-val (asr) : int -> int -> int = "%asrint"
+external (lsl) : int -> int -> int = "%lslint"
+external (lsr) : int -> int -> int = "%lsrint"
+external (asr) : int -> int -> int = "%asrint"
 
 (* Floating-point operations *)
 
-val (~-.) : float -> float = "neg_float"
-val (+.) : float -> float -> float = "add_float"
-val (-.) : float -> float -> float = "sub_float"
-val ( *. ) : float -> float -> float = "mul_float"
-val (/.) : float -> float -> float = "div_float"
-val ( ** ) : float -> float -> float = "power_float"
-val exp : float -> float = "exp_float"
-val log : float -> float = "log_float"
-val sqrt : float -> float = "sqrt_float"
-val sin : float -> float = "sin_float"
-val cos : float -> float = "cos_float"
-val tan : float -> float = "tan_float"
-val asin : float -> float = "asin_float"
-val acos : float -> float = "acos_float"
-val atan : float -> float = "atan_float"
-val atan2 : float -> float -> float = "atan2_float"
+external (~-.) : float -> float = "neg_float"
+external (+.) : float -> float -> float = "add_float"
+external (-.) : float -> float -> float = "sub_float"
+external ( *. ) : float -> float -> float = "mul_float"
+external (/.) : float -> float -> float = "div_float"
+external ( ** ) : float -> float -> float = "power_float"
+external exp : float -> float = "exp_float"
+external log : float -> float = "log_float"
+external sqrt : float -> float = "sqrt_float"
+external sin : float -> float = "sin_float"
+external cos : float -> float = "cos_float"
+external tan : float -> float = "tan_float"
+external asin : float -> float = "asin_float"
+external acos : float -> float = "acos_float"
+external atan : float -> float = "atan_float"
+external atan2 : float -> float -> float = "atan2_float"
 val abs_float : float -> float
-val float : int -> float = "float_of_int"
-val truncate : float -> int = "int_of_float"
+external float : int -> float = "float_of_int"
+external truncate : float -> int = "int_of_float"
 
 (* String operations -- more in module String *)
 
 
 (* Pair operations *)
 
-val fst : 'a * 'b -> 'a = "%field0"
-val snd : 'a * 'b -> 'b = "%field1"
+external fst : 'a * 'b -> 'a = "%field0"
+external snd : 'a * 'b -> 'b = "%field1"
 
 (* String conversion functions *)
 
 val string_of_bool : bool -> string
 val string_of_int : int -> string
-val int_of_string : string -> int = "int_of_string"
+external int_of_string : string -> int = "int_of_string"
 val string_of_float : float -> string
-val float_of_string : string -> float = "float_of_string"
+external float_of_string : string -> float = "float_of_string"
 
 (* List operations -- more in module List *)
 
 val open_out : string -> out_channel
 val open_out_bin : string -> out_channel
 val open_out_gen : open_flag list -> int -> string -> out_channel
-val flush : out_channel -> unit = "flush"
-val output_char : out_channel -> char -> unit = "output_char"
+external flush : out_channel -> unit = "flush"
+external output_char : out_channel -> char -> unit = "output_char"
 val output_string : out_channel -> string -> unit
 val output : out_channel -> string -> int -> int -> unit
-val output_byte : out_channel -> int -> unit = "output_char"
-val output_binary_int : out_channel -> int -> unit = "output_int"
-val output_value : out_channel -> 'a -> unit = "output_value"
-val output_compact_value : out_channel -> 'a -> unit = "output_value"
-val seek_out : out_channel -> int -> unit = "seek_out"
-val pos_out : out_channel -> int = "pos_out"
-val size_out : out_channel -> int = "channel_size"
-val close_out : out_channel -> unit = "close_out"
+external output_byte : out_channel -> int -> unit = "output_char"
+external output_binary_int : out_channel -> int -> unit = "output_int"
+external output_value : out_channel -> 'a -> unit = "output_value"
+external output_compact_value : out_channel -> 'a -> unit = "output_value"
+external seek_out : out_channel -> int -> unit = "seek_out"
+external pos_out : out_channel -> int = "pos_out"
+external size_out : out_channel -> int = "channel_size"
+external close_out : out_channel -> unit = "close_out"
 
 (* General input functions *)
 val open_in : string -> in_channel
 val open_in_bin : string -> in_channel
 val open_in_gen : open_flag list -> int -> string -> in_channel
-val input_char : in_channel -> char = "input_char"
+external input_char : in_channel -> char = "input_char"
 val input_line : in_channel -> string
 val input : in_channel -> string -> int -> int -> int
 val really_input : in_channel -> string -> int -> int -> unit
-val input_byte : in_channel -> int = "input_char"
-val input_binary_int : in_channel -> int = "input_int"
-val input_value : in_channel -> 'a = "input_value"
-val seek_in : in_channel -> int -> unit = "seek_in"
-val pos_in : in_channel -> int = "pos_in"
-val in_channel_length : in_channel -> int = "channel_size"
-val close_in : in_channel -> unit = "close_in"
+external input_byte : in_channel -> int = "input_char"
+external input_binary_int : in_channel -> int = "input_int"
+external input_value : in_channel -> 'a = "input_value"
+external seek_in : in_channel -> int -> unit = "seek_in"
+external pos_in : in_channel -> int = "pos_in"
+external in_channel_length : in_channel -> int = "channel_size"
+external close_in : in_channel -> unit = "close_in"
 
 (* References *)
 
 type 'a ref = { mutable contents: 'a }
-val ref: 'a -> 'a ref = "%makeblock"
-val (!): 'a ref -> 'a = "%field0"
-val (:=): 'a ref -> 'a -> unit = "%setfield0"
-val incr: int ref -> unit = "%incr"
-val decr: int ref -> unit = "%decr"
+external ref: 'a -> 'a ref = "%makeblock"
+external (!): 'a ref -> 'a = "%field0"
+external (:=): 'a ref -> 'a -> unit = "%setfield0"
+external incr: int ref -> unit = "%incr"
+external decr: int ref -> unit = "%decr"
 
 (* Miscellaneous *)
 

File stdlib/printf.ml

   let rec doprn i =
     if i >= String.length format then
       Obj.magic ()
-    else
-      match String.get format i with
-        '%' ->
-          let j = skip_args (succ i) in
-          begin match String.get format j with
-            '%' ->
-              output_char outchan '%';
-              doprn (succ j)
-          | 's' ->
-              Obj.magic(fun s ->
-                if j <= i+1 then
+    else begin
+      let c = String.unsafe_get format i in
+      if c <> '%' then begin
+        output_char outchan c;
+        doprn (succ i)
+      end else begin
+        let j = skip_args (succ i) in
+        match String.unsafe_get format j with
+          '%' ->
+            output_char outchan '%';
+            doprn (succ j)
+        | 's' ->
+            Obj.magic(fun s ->
+              if j <= i+1 then
+                output_string outchan s
+              else begin
+                let p =
+                  try
+                    int_of_string (String.sub format (i+1) (j-i-1))
+                  with _ ->
+                    invalid_arg "fprintf: bad %s format" in
+                if p > 0 & String.length s < p then begin
+                  output_string outchan
+                                (String.make (p - String.length s) ' ');
                   output_string outchan s
-                else begin
-                  let p =
-                    try
-                      int_of_string (String.sub format (i+1) (j-i-1))
-                    with _ ->
-                      invalid_arg "fprintf: bad %s format" in
-                  if p > 0 & String.length s < p then begin
-                    output_string outchan
-                                  (String.make (p - String.length s) ' ');
-                    output_string outchan s
-                  end else if p < 0 & String.length s < -p then begin
-                    output_string outchan s;
-                    output_string outchan
-                                  (String.make (-p - String.length s) ' ')
-                  end else
-                    output_string outchan s
-                end;
-                doprn (succ j))
-          | 'c' ->
-              Obj.magic(fun c ->
-                output_char outchan c;
-                doprn (succ j))
-          | 'd' | 'o' | 'x' | 'X' | 'u' ->
-              Obj.magic(doint i j)
-          | 'f' | 'e' | 'E' | 'g' | 'G' ->
-              Obj.magic(dofloat i j)
-          | 'b' ->
-              Obj.magic(fun b ->
-                output_string outchan (string_of_bool b);
-                doprn (succ j))
-          | 'a' ->
-              Obj.magic(fun printer arg ->
-                printer outchan arg;
-                doprn(succ j))
-          | 't' ->
-              Obj.magic(fun printer ->
-                printer outchan;
-                doprn(succ j))
-          | c ->
-              invalid_arg ("fprintf: unknown format")
-          end
-      |  c  -> output_char outchan c; doprn (succ i)
+                end else if p < 0 & String.length s < -p then begin
+                  output_string outchan s;
+                  output_string outchan
+                                (String.make (-p - String.length s) ' ')
+                end else
+                  output_string outchan s
+              end;
+              doprn (succ j))
+        | 'c' ->
+            Obj.magic(fun c ->
+              output_char outchan c;
+              doprn (succ j))
+        | 'd' | 'o' | 'x' | 'X' | 'u' ->
+            Obj.magic(fun n ->
+              output_string outchan
+                            (format_int (String.sub format i (j-i+1)) n);
+              doprn (succ j))
+        | 'f' | 'e' | 'E' | 'g' | 'G' ->
+            Obj.magic(fun f ->
+              output_string outchan
+                            (format_float (String.sub format i (j-i+1)) f);
+              doprn (succ j))
+        | 'b' ->
+            Obj.magic(fun b ->
+              output_string outchan (string_of_bool b);
+              doprn (succ j))
+        | 'a' ->
+            Obj.magic(fun printer arg ->
+              printer outchan arg;
+              doprn(succ j))
+        | 't' ->
+            Obj.magic(fun printer ->
+              printer outchan;
+              doprn(succ j))
+        | c ->
+            invalid_arg ("fprintf: unknown format")
+      end
+    end
 
   and skip_args j =
-    match String.get format j with
+    match String.unsafe_get format j with
       '0' .. '9' | ' ' | '.' | '-' -> skip_args (succ j)
     | c -> j
-    
-  and doint i j n =
-    let len = j-i in
-    let fmt = String.create (len+2) in
-    String.blit format i fmt 0 len;
-    String.set fmt len 'l';
-    String.set fmt (len+1) (String.get format j);
-    output_string outchan (format_int fmt n);
-    doprn (succ j)
-
-  and dofloat i j f =
-    output_string outchan (format_float (String.sub format i (j-i+1)) f);
-    doprn (succ j)
 
   in doprn 0
 
 let printf fmt = fprintf stdout fmt
 and eprintf fmt = fprintf stderr fmt
 
+let sprintf format =
+  let format = (Obj.magic format : string) in
+  let res = ref [] in
+  let rec doprn start i =
+    if i >= String.length format then begin
+      if i > start then res := String.sub format start (i-start) :: !res;
+      Obj.magic(String.concat "" (List.rev !res))
+    end else
+      if String.unsafe_get format i <> '%' then
+        doprn start (i+1)
+      else begin
+        if i > start then res := String.sub format start (i-start) :: !res;
+        let j = skip_args (succ i) in
+        match String.unsafe_get format j with
+          '%' ->
+            doprn j (succ j)
+        | 's' ->
+            Obj.magic(fun s ->
+              if j <= i+1 then
+                res := s :: !res
+              else begin
+                let p =
+                  try
+                    int_of_string (String.sub format (i+1) (j-i-1))
+                  with _ ->
+                    invalid_arg "fprintf: bad %s format" in
+                if p > 0 & String.length s < p then begin
+                  res := String.make (p - String.length s) ' ' :: !res;
+                  res := s :: !res
+                end else if p < 0 & String.length s < -p then begin
+                  res := s :: !res;
+                  res := String.make (-p - String.length s) ' ' :: !res
+                end else
+                  res := s :: !res
+              end;
+              doprn (succ j) (succ j))
+        | 'c' ->
+            Obj.magic(fun c ->
+              res := String.make 1 c :: !res;
+              doprn (succ j) (succ j))
+        | 'd' | 'o' | 'x' | 'X' | 'u' ->
+            Obj.magic(fun n ->
+              res := format_int (String.sub format i (j-i+1)) n :: !res;
+              doprn (succ j) (succ j))
+        | 'f' | 'e' | 'E' | 'g' | 'G' ->
+            Obj.magic(fun f ->
+              res := format_float (String.sub format i (j-i+1)) f :: !res;
+              doprn (succ j) (succ j))
+        | 'b' ->
+            Obj.magic(fun b ->
+              res := string_of_bool b :: !res;
+              doprn (succ j) (succ j))
+        | 'a' ->
+            Obj.magic(fun printer arg ->
+              res := printer () arg :: !res;
+              doprn (succ j) (succ j))
+        | 't' ->
+            Obj.magic(fun printer ->
+              res := printer () :: !res;
+              doprn (succ j) (succ j))
+        | c ->
+            invalid_arg ("sprintf: unknown format")
+      end
+
+  and skip_args j =
+    match String.unsafe_get format j with
+      '0' .. '9' | ' ' | '.' | '-' -> skip_args (succ j)
+    | c -> j
+
+  in doprn 0 0

File stdlib/printf.mli

 val eprintf: ('a, out_channel, unit) format -> 'a
         (* Same as [fprintf], but output on [std_err]. *)
 
+val sprintf: ('a, unit, string) format -> 'a
+        (* Same as [printf], but return the result of formatting in a
+           string. *)

File stdlib/string.ml

     r
   end
 
-
 let fill s ofs len c =
   if ofs < 0 or len < 0 or ofs + len > length s
   then invalid_arg "String.fill"
   then invalid_arg "String.blit"
   else unsafe_blit s1 ofs1 s2 ofs2 len
 
+let concat sep l =
+  match l with
+    [] -> ""
+  | hd :: tl ->
+      let num = ref 0 and len = ref 0 in
+      List.iter (fun s -> incr num; len := !len + length s) l;
+      let r = create (!len + length sep * (!num - 1)) in
+      unsafe_blit hd 0 r 0 (length hd);
+      let pos = ref(length hd) in
+      List.iter
+        (fun s ->
+          unsafe_blit sep 0 r !pos (length sep);
+          pos := !pos + length sep;
+          unsafe_blit s 0 r !pos (length s);
+          pos := !pos + length s)
+        tl;
+      r
 
 external is_printable: char -> bool = "is_printable"
 

File stdlib/string.mli

 (* String operations *)
 
-val length : string -> int = "ml_string_length"
+external length : string -> int = "ml_string_length"
 
 val get : string -> int -> char
 val set : string -> int -> char -> unit
 
-val create : int -> string = "create_string"
+external create : int -> string = "create_string"
 val make : int -> char -> string
 val copy : string -> string
 val sub : string -> int -> int -> string
 val fill : string -> int -> int -> char -> unit
 val blit : string -> int -> string -> int -> int -> unit
 
+val concat : string -> string list -> string
+
 val escaped: string -> string
 
-val unsafe_get : string -> int -> char = "%string_get"
-val unsafe_set : string -> int -> char -> unit = "%string_set"
-val unsafe_blit : string -> int -> string -> int -> int -> unit
-                = "blit_string"
-val unsafe_fill : string -> int -> int -> char -> unit = "fill_string"
+external unsafe_get : string -> int -> char = "%string_get"
+external unsafe_set : string -> int -> char -> unit = "%string_set"
+external unsafe_blit : string -> int -> string -> int -> int -> unit
+                     = "blit_string"
+external unsafe_fill : string -> int -> int -> char -> unit = "fill_string"
 
 

File stdlib/sys.mli

 (* System interface *)
 
 val argv: string array
-val file_exists: string -> bool = "sys_file_exists"
-val remove: string -> unit = "sys_remove"
-val getenv: string -> string = "sys_getenv"
-val command: string -> int = "sys_system_command"
-val chdir: string -> unit = "sys_chdir"
+external file_exists: string -> bool = "sys_file_exists"
+external remove: string -> unit = "sys_remove"
+external getenv: string -> string = "sys_getenv"
+external command: string -> int = "sys_system_command"
+external chdir: string -> unit = "sys_chdir"
 
 type signal_behavior =
     Signal_default
   | Signal_ignore
   | Signal_handle of (int -> unit)
 
-val signal: int -> signal_behavior -> unit = "install_signal_handler"
+external signal: int -> signal_behavior -> unit = "install_signal_handler"
 
 val sigabrt: int
 val sigalrm: int

File toplevel/printval.ml

 open Typedtree
 
 
-(* Given an exception val, we cannot recover its type,
+(* Given an exception value, we cannot recover its type,
    hence we cannot print its arguments in general.
    Here, we do a feeble attempt to print
    integer, string and float arguments... *)

File toplevel/topdirs.ml

     r := oldval;
     raise x
 
-(* Return the val referred to by a path *)
+(* Return the value referred to by a path *)
 
 let rec eval_path = function
     Pident id -> Symtable.get_global_value id
     (ty_arg, path)
   with 
     Not_found ->
-      print_string "Unbound val "; Printtyp.longident lid;
+      print_string "Unbound value "; Printtyp.longident lid;
       print_newline(); raise Exit
   | Ctype.Unify ->
       Printtyp.longident lid;
       print_newline()
     end      
   with Not_found ->
-    print_string "Unbound val "; Printtyp.longident lid;
+    print_string "Unbound value "; Printtyp.longident lid;
     print_newline()
 
 let dir_untrace lid =
         end else remove rem in
     trace_env := remove !trace_env
   with Not_found ->
-    print_string "Unbound val "; Printtyp.longident lid;
+    print_string "Unbound value "; Printtyp.longident lid;
     print_newline()
 
 let dir_untrace_all () =

File typing/includecore.ml

 open Typedtree
 
 
-(* Inclusion between val descriptions *)
+(* Inclusion between value descriptions *)
 
 let value_descriptions env vd1 vd2 =
   Ctype.moregeneral env vd1.val_type vd2.val_type &

File typing/includemod.ml

    i.e. that x1 is the type of an implementation that fulfills the
    specification x2. If not, Error is raised with a backtrace of the error. *)
 
-(* Inclusion between val descriptions *)
+(* Inclusion between value descriptions *)
 
 let value_descriptions env id vd1 vd2 =
   if Includecore.value_descriptions env vd1 vd2
     Tcoerce_structure cc
 
 (* Inclusion between module types. 
-   Return the restriction that transforms a val of the smaller type
-   into a val of the bigger type. *)
+   Return the restriction that transforms a value of the smaller type
+   into a value of the bigger type. *)
 
 let rec modtypes env mty1 mty2 =
   try

File typing/parmatch.ml

 (*
   Is the last row of pattern matrix pss + qs satisfiable ?
         That is :
-  Does there List.exists at least one val vector, es such that :
+  Does there List.exists at least one value vector, es such that :
    1/ for all ps in pss ps # es (ps and es are not compatible)
    2/ qs <= es                  (es matches qs)
 *)

File typing/printtyp.ml

 let exception_declaration id decl =
   print_string "exception "; constructor (Ident.name id, decl)
 
-(* Print a val declaration *)
+(* Print a value declaration *)
 
 let value_description id decl =
   open_hovbox 2;

File typing/typecore.ml

 
 let report_error = function
     Unbound_value lid ->
-      print_string "Unbound val "; longident lid
+      print_string "Unbound value "; longident lid
   | Unbound_constructor lid ->
       print_string "Unbound constructor "; longident lid
   | Unbound_label lid ->

File typing/typedtree.ml

 (* Value descriptions *)
 
 type value_description =
-  { val_type: type_expr;                (* Type of the val *)
+  { val_type: type_expr;                (* Type of the value *)
     val_prim: primitive_description }   (* Is this a primitive? *)
 and primitive_description =
     Not_prim

File typing/typemod.ml

   | Pmodtype_manifest smty ->
       Tmodtype_manifest(transl_modtype env smty)
 
-(* Type a module val expression *)
+(* Type a module value expression *)
 
 let rec type_module env smod =
   match smod.pmod_desc with

File utils/crc.mli

 (* CRC computation *)
 
 val for_string: string -> int -> int -> int
-val for_channel: in_channel -> int -> int = "crc_chan"
+external for_channel: in_channel -> int -> int = "crc_chan"
 
 

File utils/cset.ml

     Empty -> 1
   | Node(_, _, _, s) -> s
 
-(* Creates a new node with left son l, val x and right son r.
+(* Creates a new node with left son l, value x and right son r.
    l and r must be balanced and size l / size r must be between 1/N and N.
    Inline expansion of size for better speed. *)
 

File utils/meta.mli

 (* To control the runtime system and bytecode interpreter *)
 
-val global_data : unit -> Obj.t array = "get_global_data"
-val realloc_global_data : int -> unit = "realloc_global"
-val static_alloc : int -> string = "static_alloc"
-val static_free : string -> unit = "static_free"
-val static_resize : string -> int -> string = "static_resize"
-val execute_bytecode : string -> int -> Obj.t = "execute_bytecode"
-val available_primitives : unit -> string array = "available_primitives"
+external global_data : unit -> Obj.t array = "get_global_data"
+external realloc_global_data : int -> unit = "realloc_global"
+external static_alloc : int -> string = "static_alloc"
+external static_free : string -> unit = "static_free"
+external static_resize : string -> int -> string = "static_resize"
+external execute_bytecode : string -> int -> Obj.t = "execute_bytecode"
+external available_primitives : unit -> string array = "available_primitives"

File utils/misc.ml

   if c >= 'A' & c <= 'Z' then r.[0] <- Char.chr(Char.code c + 32);
   r
 
-let concat_strings sep l =
-  match l with
-    [] -> ""
-  | hd :: tl ->
-      let num = ref 0 and len = ref 0 in
-      List.iter (fun s -> incr num; len := !len + String.length s) l;
-      let r = String.create (!len + String.length sep * (!num - 1)) in
-      String.blit hd 0 r 0 (String.length hd);
-      let pos = ref(String.length hd) in
-      List.iter
-        (fun s ->
-          String.blit sep 0 r !pos (String.length sep);
-          pos := !pos + String.length sep;
-          String.blit s 0 r !pos (String.length s);
-          pos := !pos + String.length s)
-        tl;
-      r
-
 (* File copy *)
 
 let copy_file ic oc =

File utils/misc.mli

 val capitalize: string -> string
 val lowercase: string -> string
 
-val concat_strings: string -> string list -> string
-
 val copy_file: in_channel -> out_channel -> unit
         (* [copy_file ic oc] reads the contents of file [ic] and copies
            them to [oc]. It stops when encountering EOF on [ic]. *)

File utils/terminfo.mli

 (* Basic interface to the terminfo database *)
 
-val setupterm: unit -> unit = "terminfo_setup"
-val getstr: string -> string = "terminfo_getstr"
-val getnum: string -> int = "terminfo_getnum"
-val puts: out_channel -> string -> int -> unit = "terminfo_puts"
+external setupterm: unit -> unit = "terminfo_setup"
+external getstr: string -> string = "terminfo_getstr"
+external getnum: string -> int = "terminfo_getnum"
+external puts: out_channel -> string -> int -> unit = "terminfo_puts"