diff --git a/bytecomp/codegen.ml b/bytecomp/codegen.ml index f19ca9614..fd70bd71c 100644 --- a/bytecomp/codegen.ml +++ b/bytecomp/codegen.ml @@ -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 diff --git a/bytecomp/linker.ml b/bytecomp/linker.ml index 677dc4a37..3223c42dd 100644 --- a/bytecomp/linker.ml +++ b/bytecomp/linker.ml @@ -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; diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml index c3a0eaf0a..d4d14c297 100644 --- a/bytecomp/symtable.ml +++ b/bytecomp/symtable.ml @@ -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) diff --git a/byterun/Makefile b/byterun/Makefile index 2ac4f0ef3..ed17a3683 100644 --- a/byterun/Makefile +++ b/byterun/Makefile @@ -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' \ diff --git a/driver/compile.ml b/driver/compile.ml index 54c7591c5..7f6174a79 100644 --- a/driver/compile.ml +++ b/driver/compile.ml @@ -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 diff --git a/parsing/parser.mly b/parsing/parser.mly index c45f900ea..d54745530 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -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 */ diff --git a/stdlib/Makefile b/stdlib/Makefile index e450ab52e..2c88ffaa4 100644 --- a/stdlib/Makefile +++ b/stdlib/Makefile @@ -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 diff --git a/stdlib/array.mli b/stdlib/array.mli index add7a92ca..dc9a4156f 100644 --- a/stdlib/array.mli +++ b/stdlib/array.mli @@ -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" diff --git a/stdlib/baltree.ml b/stdlib/baltree.ml index 7c61a8f54..6ecf9cf62 100644 --- a/stdlib/baltree.ml +++ b/stdlib/baltree.ml @@ -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. *) diff --git a/stdlib/char.mli b/stdlib/char.mli index 40791c94b..7afa37bb4 100644 --- a/stdlib/char.mli +++ b/stdlib/char.mli @@ -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" diff --git a/stdlib/format.ml b/stdlib/format.ml index ca631fdd2..6ac6c247c 100644 --- a/stdlib/format.ml +++ b/stdlib/format.ml @@ -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 diff --git a/stdlib/gc.mli b/stdlib/gc.mli index b77b0e286..80ab5e4e9 100644 --- a/stdlib/gc.mli +++ b/stdlib/gc.mli @@ -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. *) diff --git a/stdlib/hashtbl.mli b/stdlib/hashtbl.mli index fd32f6a36..5054970f8 100644 --- a/stdlib/hashtbl.mli +++ b/stdlib/hashtbl.mli @@ -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 diff --git a/stdlib/lexing.mli b/stdlib/lexing.mli index 6e224c4fc..1585da1f1 100644 --- a/stdlib/lexing.mli +++ b/stdlib/lexing.mli @@ -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 diff --git a/stdlib/obj.mli b/stdlib/obj.mli index 9509c2b8a..b4c131ad4 100644 --- a/stdlib/obj.mli +++ b/stdlib/obj.mli @@ -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" diff --git a/stdlib/pervasives.mli b/stdlib/pervasives.mli index 02b01c118..3d5a1d6c7 100644 --- a/stdlib/pervasives.mli +++ b/stdlib/pervasives.mli @@ -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 *) diff --git a/stdlib/printf.ml b/stdlib/printf.ml index e13c2a600..34f0b5438 100644 --- a/stdlib/printf.ml +++ b/stdlib/printf.ml @@ -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 diff --git a/stdlib/printf.mli b/stdlib/printf.mli index 943f97209..a46718d7f 100644 --- a/stdlib/printf.mli +++ b/stdlib/printf.mli @@ -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. *) diff --git a/stdlib/string.ml b/stdlib/string.ml index eeb5676a7..9b88686a6 100644 --- a/stdlib/string.ml +++ b/stdlib/string.ml @@ -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" diff --git a/stdlib/string.mli b/stdlib/string.mli index 6dd586f86..0a5982db0 100644 --- a/stdlib/string.mli +++ b/stdlib/string.mli @@ -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" diff --git a/stdlib/sys.mli b/stdlib/sys.mli index 99c5e9375..0466ba591 100644 --- a/stdlib/sys.mli +++ b/stdlib/sys.mli @@ -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 diff --git a/toplevel/printval.ml b/toplevel/printval.ml index 6e2ebd796..5bc5c78d8 100644 --- a/toplevel/printval.ml +++ b/toplevel/printval.ml @@ -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... *) diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml index 9a0121265..ebbc712b2 100644 --- a/toplevel/topdirs.ml +++ b/toplevel/topdirs.ml @@ -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 () = diff --git a/typing/includecore.ml b/typing/includecore.ml index 45ca23736..781abf166 100644 --- a/typing/includecore.ml +++ b/typing/includecore.ml @@ -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 & diff --git a/typing/includemod.ml b/typing/includemod.ml index efc1e0c19..5a1d4f446 100644 --- a/typing/includemod.ml +++ b/typing/includemod.ml @@ -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 diff --git a/typing/parmatch.ml b/typing/parmatch.ml index 9b09624e6..8d3ee419b 100644 --- a/typing/parmatch.ml +++ b/typing/parmatch.ml @@ -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) *) diff --git a/typing/printtyp.ml b/typing/printtyp.ml index c1b82d7ac..cd6d48287 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -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; diff --git a/typing/typecore.ml b/typing/typecore.ml index 882748fab..bc3a909ef 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -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 -> diff --git a/typing/typedtree.ml b/typing/typedtree.ml index c79579984..ff44fd0fb 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -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 diff --git a/typing/typemod.ml b/typing/typemod.ml index f0e6fbf53..139a8806c 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -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 diff --git a/utils/crc.mli b/utils/crc.mli index 0663267cb..eae8ca6eb 100644 --- a/utils/crc.mli +++ b/utils/crc.mli @@ -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" diff --git a/utils/cset.ml b/utils/cset.ml index f9305e503..f2c8482b5 100644 --- a/utils/cset.ml +++ b/utils/cset.ml @@ -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. *) diff --git a/utils/meta.mli b/utils/meta.mli index 1c6392a41..9987ba7e8 100644 --- a/utils/meta.mli +++ b/utils/meta.mli @@ -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" diff --git a/utils/misc.ml b/utils/misc.ml index f2b507340..1cd623585 100644 --- a/utils/misc.ml +++ b/utils/misc.ml @@ -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 = diff --git a/utils/misc.mli b/utils/misc.mli index 44354914e..3515d162d 100644 --- a/utils/misc.mli +++ b/utils/misc.mli @@ -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]. *) diff --git a/utils/terminfo.mli b/utils/terminfo.mli index 1989b424d..682edaa81 100644 --- a/utils/terminfo.mli +++ b/utils/terminfo.mli @@ -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"