Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Printf.sprintf et String.concat dans stdlib 

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@5 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Xavier Leroy 1995-05-05 10:05:18 +00:00
parent 623e2fbc00
commit 997fb206a7
36 changed files with 348 additions and 267 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
bytecomp/codegen.ml
View File

@ -103,7 +103,7 @@ let functions_to_compile =
(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
@ -325,7 +325,7 @@ let rec comp_expr env exp sz cont =
(* 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

28
bytecomp/linker.ml
View File

@ -149,7 +149,8 @@ let link_bytecode objfiles exec_name copy_header =
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
@ -198,21 +199,22 @@ let link objfiles =
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;

2
bytecomp/symtable.ml
View File

@ -186,7 +186,7 @@ let init_toplevel () =
(* 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)

11
byterun/Makefile
View File

@ -15,7 +15,7 @@ PRIMS=array.c compare.c crc.c extern.c floats.c gc_ctrl.c hash.c \
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)
@ -23,15 +23,10 @@ camlrun: $(OBJS) prims.o
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' \

17
driver/compile.ml
View File

@ -89,11 +89,14 @@ let implementation sourcefile =
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

22
parsing/parser.mly
View File

@ -213,7 +213,7 @@ structure:
;
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
@ -260,7 +260,7 @@ signature:
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) }
@ -394,8 +394,8 @@ let_bindings:
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
@ -476,6 +476,20 @@ lbl_pattern_list:
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 */

2
stdlib/Makefile
View File

@ -4,7 +4,7 @@ COMPILER=../camlc
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

8
stdlib/array.mli
View File

@ -1,10 +1,10 @@
(* 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
@ -16,6 +16,6 @@ val map: ('a -> 'b) -> 'a array -> 'b 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"

2
stdlib/baltree.ml
View File

@ -16,7 +16,7 @@ let size = function
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. *)

4
stdlib/char.mli
View File

@ -1,6 +1,6 @@
(* 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"

14
stdlib/format.ml
View File

@ -33,7 +33,7 @@ type pp_queue_elem =
(* 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)
@ -46,23 +46,23 @@ let pp_format_stack = ref ([]:pp_format_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 *)
@ -390,8 +390,8 @@ let print_if_newline () =
(* 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

12
stdlib/gc.mli
View File

@ -67,15 +67,15 @@ type control = {
- [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:
[
@ -84,10 +84,10 @@ val set : control -> unit = "gc_set"
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. *)

2
stdlib/hashtbl.mli
View File

@ -52,7 +52,7 @@ val hash : 'a -> int
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

2
stdlib/lexing.mli
View File

@ -64,5 +64,5 @@ val lexeme_end : lexbuf -> int
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

18
stdlib/obj.mli
View File

@ -2,12 +2,12 @@
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"

144
stdlib/pervasives.mli
View File

@ -24,7 +24,7 @@ exception Division_by_zero
(* Exceptions *)
val raise : exn -> 'a = "%raise"
external raise : exn -> 'a = "%raise"
val failwith: string -> 'a
val invalid_arg: string -> 'a
@ -32,64 +32,64 @@ exception Exit
(* 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 *)
@ -97,16 +97,16 @@ val (^) : string -> string -> 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 *)
@ -155,43 +155,43 @@ type open_flag =
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 *)

200
stdlib/printf.ml
View File

@ -6,81 +6,147 @@ let fprintf outchan format =
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

3
stdlib/printf.mli
View File

@ -43,3 +43,6 @@ val printf: ('a, out_channel, unit) format -> 'a
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. *)

18
stdlib/string.ml
View File

@ -38,7 +38,6 @@ let sub s ofs len =
r
end
let fill s ofs len c =
if ofs < 0 or len < 0 or ofs + len > length s
then invalid_arg "String.fill"
@ -50,6 +49,23 @@ let blit s1 ofs1 s2 ofs2 len =
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"

16
stdlib/string.mli
View File

@ -1,11 +1,11 @@
(* 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
@ -13,12 +13,14 @@ 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"

12
stdlib/sys.mli
View File

@ -1,18 +1,18 @@
(* 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

2
toplevel/printval.ml
View File

@ -7,7 +7,7 @@ open Path
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... *)

8
toplevel/topdirs.ml
View File

@ -22,7 +22,7 @@ let protect r newval body =
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
@ -121,7 +121,7 @@ let find_printer_type lid =
(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;
@ -218,7 +218,7 @@ let dir_trace 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 =
@ -238,7 +238,7 @@ 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 () =

2
typing/includecore.ml
View File

@ -5,7 +5,7 @@ open Path
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 &

6
typing/includemod.ml
View File

@ -20,7 +20,7 @@ exception Error of error list
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
@ -81,8 +81,8 @@ let simplify_structure_coercion cc =
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

2
typing/parmatch.ml
View File

@ -166,7 +166,7 @@ let full_match env =
(*
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)
*)

2
typing/printtyp.ml
View File

@ -144,7 +144,7 @@ and label (name, mut, arg) =
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;

2
typing/typecore.ml
View File

@ -538,7 +538,7 @@ open Printtyp
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 ->

2
typing/typedtree.ml
View File

@ -18,7 +18,7 @@ and type_variable =
(* 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

2
typing/typemod.ml
View File

@ -142,7 +142,7 @@ and transl_modtype_info env sinfo =
| 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

2
utils/crc.mli
View File

@ -1,6 +1,6 @@
(* 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"

2
utils/cset.ml
View File

@ -10,7 +10,7 @@ let size = function
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. *)

14
utils/meta.mli
View File

@ -1,9 +1,9 @@
(* 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"

18
utils/misc.ml
View File

@ -69,24 +69,6 @@ let lowercase s =
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 =

2
utils/misc.mli
View File

@ -22,8 +22,6 @@ val create_hashtable: int -> ('a * 'b) list -> ('a, 'b) Hashtbl.t
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]. *)

8
utils/terminfo.mli
View File

@ -1,7 +1,7 @@
(* 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"