diff options
48 files changed, 886 insertions, 98 deletions
@@ -1,6 +1,8 @@ -OCaml 3.13.0: +OCaml 4.00.0: ------------- +(Changes that can break existing programs are marked with a "*") + - The official name of the language is now OCaml. Language features: @@ -52,34 +54,57 @@ Standard library: - String: new function "map" (PR#3888) Bug Fixes: +- PR#1643: functions of the Lazy module whose named started with 'lazy_' have + been deprecated, and new ones without the prefix added - PR#4549: Filename.dirname is not handling multiple / on Unix -- PR#4688: (Windows) special floating-point values aren't converted to strings correctly +- PR#4688: (Windows) special floating-point values aren't converted to strings + correctly +- PR#4697: Unix.putenv leaks memory on failure +- PR#4705: camlp4 does not allow to define types with `True or `False +- PR#4746: wrong detection of stack overflows in native code under Linux - PR#4869: rare collisions between assembly labels for code and data - PR#4880: "assert" constructs now show up in the exception stack backtrace +- PR#4937: camlp4 incorrectly handles optional arguments if 'option' is + redefined +- PR#5024: camlp4r now handles underscores in irrefutable patern matching of + records - PR#5064, PR#5485: try to ensure that 4K words of stack are available before calling into C functions, raising a Stack_overflow exception otherwise. This reduces (but does not eliminate) the risk of segmentation faults due to stack overflow in C code +- PR#5211: updated Genlex documentation to state that camlp4 is mandatory for + 'parser' keyword and associated notation +- PR#5238, PR#5277: Sys_error when getting error location +- PR#5301: camlp4r and exception equal to another one with parameters +- PR#5309: Queue.add is not thread/signal safe - PR#5313: ocamlopt -g misses optimizations +- PR#5316: objinfo now shows ccopts/ccobjs/force_link when applicable - PR#5322: type abbreviations expanding to a universal type variable - PR#5325: (Windows) blocked Unix.recv in one thread blocks Unix.send in another thread -- PR#5309: Queue.add is not thread/signal safe - PR#5327: (Windows) Unix.select blocks if same socket listed in first and third arguments +- PR#5328: under Windows, Unix.select leaves sockets in non-blocking mode - PR#5330: thread tag with '.top' and '.inferred.mli' targets +- PR#5331: ocamlmktop is not always a shell script +- PR#5335: Unix.environment segfaults after a call to clearenv - PR#5343: ocaml -rectypes is unsound wrt module subtyping +- PR#5344: some predifined exceptions need special printing +- PR#5356: ocamlbuild handling of 'predicates' for ocamlfind +- PR#5364: wrong compilation of "((val m : SIG1) : SIG2)" +- PR#5370: ocamldep omits filename in syntax error message +- PR#5380: strange sscanf input segfault - PR#5394: Documentation for -dtypes is missing in manpage - PR#5416: (Windows) Unix.(set|clear)_close_on_exec now preserves blocking mode - PR#5436: update object ids on unmarshaling - PR#5453: configure doesn't find X11 under Ubuntu/MultiarchSpec +- PR#5461: Double linking of bytecode modules - PR#5469: private record type generated by functor loses abbreviation +- PR#5475: Wrapper script for interpreted LablTk wrongly handles command line + parameters - PR#5476: bug in native code compilation of let rec on float arrays -- emacs mode: colorization of comments and strings now works correctly -- PR5475: Wrapper script for interpreted LablTk wrongly handles command line parameters -- PR5461: Double linking of bytecode modules - PR#5498: Unification with an empty object only checks the absence of - the first method + the first method - PR#5503: error when ocamlbuild is passed an absolute path as build directory - PR#5509: misclassification of statically-allocated empty array that falls exactly at beginning of an otherwise unused data page. @@ -87,14 +112,18 @@ Bug Fixes: - PR#5511: in Bigarray.reshape, unwarranted limitation on new array dimensions. - PR#5513: Int64.div causes floating point exception (ocamlopt, x86) - PR#5516: in Bigarray C stubs, use C99 / GCC flexible array types if possible +- problem with printing of string literals in camlp4 (reported on caml-list) +- emacs mode: colorization of comments and strings now works correctly Feature wishes: - PR#352: new option "-stdin" to make ocaml read stdin as a script +- PR#4444: new String.trim function, removing leading and trailing whistespace +- PR#4898: new Sys.big_endian boolean for machine endianness - PR#5199: tests are run only for bytecode if either native support is missing, or a non-empty value is set to "BYTECODE_ONLY" Makefile variable -- PR#5297: compiler now checks existence of builtin primitives - PR#5236: new '%revapply' primitive with the semantics 'revapply x f = f x', and '%apply' with semantics 'apply f x = f x'. +- PR#5297: compiler now checks existence of builtin primitives - PR#5329: (Windows) more efficient Unix.select if all fd's are sockets - PR#5358: first class modules don't allow "with type" declarations for types in sub-modules @@ -105,7 +134,11 @@ Feature wishes: - PR#5454: Digest.compare is missing and md5 doc update - PR#5467: no extern "C" into ocaml C-stub headers - PR#5478: ocamlopt assumes ar command exists -- PR#5479: Num.num_of_string may raise an exception, not reflected in the documentation. +- PR#5479: Num.num_of_string may raise an exception, not reflected in the + documentation. +- ocamldebug: ability to inspect values that contain code pointers +- ocamldebug: new 'environment' directive to set environment variables + for debugee Shedding weight: * Removed the obsolete native-code generators for Alpha, HPPA, IA64 and MIPS. @@ -113,6 +146,9 @@ Shedding weight: longer part of this distribution. It now lives its own life at https://forge.ocamlcore.org/projects/camldbm/ +Other changes: +- Copy VERSION file to library directory when installing. + OCaml 3.12.1: ------------- @@ -282,6 +282,7 @@ install: if test -d $(STUBLIBDIR); then : ; else $(MKDIR) $(STUBLIBDIR); fi if test -d $(MANDIR)/man$(MANEXT); then : ; \ else $(MKDIR) $(MANDIR)/man$(MANEXT); fi + cp VERSION $(LIBDIR)/ cd $(LIBDIR); rm -f dllbigarray.so dlllabltk.so dllnums.so \ dllthreads.so dllunix.so dllgraphics.so dllstr.so \ dlltkanim.so @@ -1,4 +1,4 @@ -3.13.0+dev11 (2012-01-26) +3.13.0+dev12 (2012-03-08) # The version string is the first line of this file. # It must be in the format described in stdlib/sys.mli diff --git a/asmcomp/arm/emit.mlp b/asmcomp/arm/emit.mlp index 5aa83aa13..846ee4ae3 100644 --- a/asmcomp/arm/emit.mlp +++ b/asmcomp/arm/emit.mlp @@ -829,6 +829,7 @@ let fundecl fundecl = ` .thumb\n` else ` .arm\n`; + ` .type {emit_symbol fundecl.fun_name}, %function\n`; `{emit_symbol fundecl.fun_name}:\n`; if !Clflags.gprofile then emit_profile(); let n = frame_size() in diff --git a/asmcomp/cmx_format.mli b/asmcomp/cmx_format.mli index ffbe3b701..69cd38234 100644 --- a/asmcomp/cmx_format.mli +++ b/asmcomp/cmx_format.mli @@ -16,12 +16,12 @@ (* Each .o file has a matching .cmx file that provides the following infos on the compilation unit: - - list of other units imported, with CRCs of their .cmx files + - list of other units imported, with MD5s of their .cmx files - approximation of the structure implemented (includes descriptions of known functions: arity and direct entry points) - list of currying functions and application functions needed - The .cmx file contains these infos (as an externed record) plus a CRC + The .cmx file contains these infos (as an externed record) plus a MD5 of these infos *) type unit_infos = @@ -40,7 +40,7 @@ type unit_infos = infos on the library: *) type library_infos = - { lib_units: (unit_infos * Digest.t) list; (* List of unit infos w/ CRCs *) + { lib_units: (unit_infos * Digest.t) list; (* List of unit infos w/ MD5s *) lib_ccobjs: string list; (* C object files needed *) lib_ccopts: string list } (* Extra opts to C compiler *) diff --git a/asmcomp/compilenv.mli b/asmcomp/compilenv.mli index ca03724ef..3e4d83e20 100644 --- a/asmcomp/compilenv.mli +++ b/asmcomp/compilenv.mli @@ -57,7 +57,7 @@ val new_structured_constant : Lambda.structured_constant -> bool -> string val structured_constants : unit -> (string * bool * Lambda.structured_constant) list val read_unit_info: string -> unit_infos * Digest.t - (* Read infos and CRC from a [.cmx] file. *) + (* Read infos and MD5 from a [.cmx] file. *) val write_unit_info: unit_infos -> string -> unit (* Save the given infos in the given file *) val save_unit_info: string -> unit diff --git a/asmrun/arm.S b/asmrun/arm.S index 6fa7eb16d..64829566e 100644 --- a/asmrun/arm.S +++ b/asmrun/arm.S @@ -63,6 +63,7 @@ caml_system__code_begin: .align 2 .globl caml_call_gc + .type caml_call_gc, %function caml_call_gc: PROFILE /* Record return address */ @@ -103,6 +104,7 @@ caml_call_gc: .align 2 .globl caml_alloc1 + .type caml_alloc1, %function caml_alloc1: PROFILE .Lcaml_alloc1: @@ -124,6 +126,7 @@ caml_alloc1: .align 2 .globl caml_alloc2 + .type caml_alloc2, %function caml_alloc2: PROFILE .Lcaml_alloc2: @@ -145,6 +148,7 @@ caml_alloc2: .align 2 .globl caml_alloc3 + .type caml_alloc3, %function caml_alloc3: PROFILE .Lcaml_alloc3: @@ -166,6 +170,7 @@ caml_alloc3: .align 2 .globl caml_allocN + .type caml_allocN, %function caml_allocN: PROFILE .Lcaml_allocN: @@ -191,6 +196,7 @@ caml_allocN: .align 2 .globl caml_c_call + .type caml_c_call, %function caml_c_call: PROFILE /* Record lowest stack address and return address */ @@ -220,6 +226,7 @@ caml_c_call: .align 2 .globl caml_start_program + .type caml_start_program, %function caml_start_program: PROFILE ldr r12, =caml_program @@ -332,6 +339,7 @@ caml_raise_exn: .align 2 .globl caml_raise_exception + .type caml_raise_exception, %function caml_raise_exception: PROFILE /* Reload trap ptr, alloc ptr and alloc limit */ @@ -366,6 +374,7 @@ caml_raise_exception: .align 2 .globl caml_callback_exn + .type caml_callback_exn, %function caml_callback_exn: PROFILE /* Initial shuffling of arguments (r0 = closure, r1 = first arg) */ @@ -379,6 +388,7 @@ caml_callback_exn: .align 2 .globl caml_callback2_exn + .type caml_callback2_exn, %function caml_callback2_exn: PROFILE /* Initial shuffling of arguments (r0 = closure, r1 = arg1, r2 = arg2) */ @@ -393,6 +403,7 @@ caml_callback2_exn: .align 2 .globl caml_callback3_exn + .type caml_callback3_exn, %function caml_callback3_exn: PROFILE /* Initial shuffling of arguments */ @@ -409,6 +420,7 @@ caml_callback3_exn: .align 2 .globl caml_ml_array_bound_error + .type caml_ml_array_bound_error, %function caml_ml_array_bound_error: PROFILE /* Load address of [caml_array_bound_error] in r7 */ diff --git a/boot/ocamlc b/boot/ocamlc Binary files differindex 85aef73f3..17998d3aa 100755 --- a/boot/ocamlc +++ b/boot/ocamlc diff --git a/boot/ocamldep b/boot/ocamldep Binary files differindex fb7a64301..ba9a71666 100755 --- a/boot/ocamldep +++ b/boot/ocamldep diff --git a/boot/ocamllex b/boot/ocamllex Binary files differindex 089762cb0..c0adcd904 100755 --- a/boot/ocamllex +++ b/boot/ocamllex diff --git a/byterun/debugger.c b/byterun/debugger.c index c69b1edd1..a114b46cb 100644 --- a/byterun/debugger.c +++ b/byterun/debugger.c @@ -21,6 +21,7 @@ #include <string.h> +#include "alloc.h" #include "config.h" #include "debugger.h" #include "misc.h" @@ -28,6 +29,7 @@ int caml_debugger_in_use = 0; uintnat caml_event_count; int caml_debugger_fork_mode = 1; /* parent by default */ +value marshal_flags = Val_emptylist; #if !defined(HAS_SOCKETS) || defined(NATIVE_CODE) @@ -162,6 +164,11 @@ void caml_debugger_init(void) struct hostent * host; int n; + caml_register_global_root(&marshal_flags); + marshal_flags = caml_alloc(2, Tag_cons); + Store_field(marshal_flags, 0, Val_int(1)); /* Marshal.Closures */ + Store_field(marshal_flags, 1, Val_emptylist); + address = getenv("CAML_DEBUG_SOCKET"); if (address == NULL) return; dbg_addr = address; @@ -230,7 +237,7 @@ static void safe_output_value(struct channel *chan, value val) saved_external_raise = caml_external_raise; if (sigsetjmp(raise_buf.buf, 0) == 0) { caml_external_raise = &raise_buf; - caml_output_val(chan, val, Val_unit); + caml_output_val(chan, val, marshal_flags); } else { /* Send wrong magic number, will cause [caml_input_value] to fail */ caml_really_putblock(chan, "\000\000\000\000", 4); diff --git a/byterun/intern.c b/byterun/intern.c index 35d293b60..713f1feaa 100644 --- a/byterun/intern.c +++ b/byterun/intern.c @@ -126,7 +126,10 @@ static void intern_rec(value *dest) header_t header; char cksum[16]; struct custom_operations * ops; + value * function_placeholder; + int get_function_placeholder; + get_function_placeholder = 1; tailcall: code = read8u(); if (code >= PREFIX_SMALL_INT) { @@ -311,6 +314,15 @@ static void intern_rec(value *dest) ofs = read32u(); readblock(cksum, 16); if (memcmp(cksum, caml_code_checksum(), 16) != 0) { + if (get_function_placeholder) { + function_placeholder = + caml_named_value ("Debugger.function_placeholder"); + get_function_placeholder = 0; + } + if (function_placeholder != NULL) { + v = *function_placeholder; + break; + } intern_cleanup(); caml_failwith("input_value: code mismatch"); } diff --git a/byterun/memory.h b/byterun/memory.h index dddf9a36b..69f5ff91c 100644 --- a/byterun/memory.h +++ b/byterun/memory.h @@ -173,8 +173,8 @@ CAMLextern struct caml__roots_block *caml_local_roots; /* defined in roots.c */ If you need local variables of type [value], declare them with one or more calls to the [CAMLlocal] macros at the beginning of the - function. Use [CAMLlocalN] (at the beginning of the function) to - declare an array of [value]s. + function, after the call to CAMLparam. Use [CAMLlocalN] (at the + beginning of the function) to declare an array of [value]s. Your function may raise an exception or return a [value] with the [CAMLreturn] macro. Its argument is simply the [value] returned by diff --git a/byterun/sys.c b/byterun/sys.c index 0b18cc0c0..dcc290756 100644 --- a/byterun/sys.c +++ b/byterun/sys.c @@ -320,9 +320,14 @@ CAMLprim value caml_sys_get_config(value unit) CAMLlocal2 (result, ostype); ostype = caml_copy_string(OCAML_OS_TYPE); - result = caml_alloc_small (2, 0); + result = caml_alloc_small (3, 0); Field(result, 0) = ostype; Field(result, 1) = Val_long (8 * sizeof(value)); +#ifdef ARCH_BIG_ENDIAN + Field(result, 2) = Val_true; +#else + Field(result, 2) = Val_false; +#endif CAMLreturn (result); } diff --git a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml index 0200d1896..e73e875ff 100644 --- a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml +++ b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml @@ -133,7 +133,9 @@ module Make (Ast : Sig.Camlp4Ast) = struct let rec self i acc = match i with - [ <:ident< $i1$.$i2$ >> -> + [ <:ident< $lid:"*predef*"$.$lid:"option"$ >> -> + (ldot (lident "*predef*") "option", `lident) + | <:ident< $i1$.$i2$ >> -> self i2 (Some (self i1 acc)) | <:ident< $i1$ $i2$ >> -> let i' = Lapply (fst (self i1 None)) (fst (self i2 None)) in @@ -204,6 +206,9 @@ module Make (Ast : Sig.Camlp4Ast) = struct | <:ctyp< '$s$ >> -> [s] | _ -> assert False ]; + value predef_option loc = + TyId (loc, IdAcc (loc, IdLid (loc, "*predef*"), IdLid (loc, "option"))); + value rec ctyp = fun [ TyId loc i -> @@ -226,7 +231,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct | TyArr loc (TyLab _ lab t1) t2 -> mktyp loc (Ptyp_arrow lab (ctyp t1) (ctyp t2)) | TyArr loc (TyOlb loc1 lab t1) t2 -> - let t1 = TyApp loc1 <:ctyp@loc1< option >> t1 in + let t1 = TyApp loc1 (predef_option loc1) t1 in mktyp loc (Ptyp_arrow ("?" ^ lab) (ctyp t1) (ctyp t2)) | TyArr loc t1 t2 -> mktyp loc (Ptyp_arrow "" (ctyp t1) (ctyp t2)) | <:ctyp@loc< < $fl$ > >> -> mktyp loc (Ptyp_object (meth_list fl [])) @@ -553,7 +558,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct | <:patt@loc< ($tup:_$) >> -> error loc "singleton tuple pattern" | PaTyc loc p t -> mkpat loc (Ppat_constraint (patt p) (ctyp t)) | PaTyp loc i -> mkpat loc (Ppat_type (long_type_ident i)) - | PaVrn loc s -> mkpat loc (Ppat_variant s None) + | PaVrn loc s -> mkpat loc (Ppat_variant (conv_con s) None) | PaLaz loc p -> mkpat loc (Ppat_lazy (patt p)) | PaMod loc m -> mkpat loc (Ppat_unpack m) | PaEq _ _ _ | PaSem _ _ _ | PaCom _ _ _ | PaNil _ as p -> @@ -836,7 +841,7 @@ value varify_constructors var_names = | <:expr@loc< $uid:s$ >> -> (* let ca = constructors_arity () in *) mkexp loc (Pexp_construct (lident (conv_con s)) None True) - | ExVrn loc s -> mkexp loc (Pexp_variant s None) + | ExVrn loc s -> mkexp loc (Pexp_variant (conv_con s) None) | ExWhi loc e1 el -> let e2 = ExSeq loc el in mkexp loc (Pexp_while (expr e1) (expr e2)) @@ -1063,7 +1068,7 @@ value varify_constructors var_names = | CtFun loc (TyLab _ lab t) ct -> mkcty loc (Pcty_fun lab (ctyp t) (class_type ct)) | CtFun loc (TyOlb loc1 lab t) ct -> - let t = TyApp loc1 <:ctyp@loc1< option >> t in + let t = TyApp loc1 (predef_option loc1) t in mkcty loc (Pcty_fun ("?" ^ lab) (ctyp t) (class_type ct)) | CtFun loc t ct -> mkcty loc (Pcty_fun "" (ctyp t) (class_type ct)) | CtSig loc t_o ctfl -> diff --git a/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml b/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml index cf75f0e17..c9744140d 100644 --- a/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml +++ b/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml @@ -783,9 +783,9 @@ New syntax:\ [ RIGHTA [ TRY ["("; "type"]; i = a_LIDENT; ")"; e = SELF -> <:expr< fun (type $i$) -> $e$ >> - | p = TRY labeled_ipatt; e = SELF -> + | bi = TRY cvalue_binding -> bi + | p = labeled_ipatt; e = SELF -> <:expr< fun $p$ -> $e$ >> - | bi = cvalue_binding -> bi ] ] ; match_case: @@ -984,6 +984,8 @@ New syntax:\ ; label_ipatt_list: [ [ p1 = label_ipatt; ";"; p2 = SELF -> <:patt< $p1$ ; $p2$ >> + | p1 = label_ipatt; ";"; "_" -> <:patt< $p1$ ; _ >> + | p1 = label_ipatt; ";"; "_"; ";" -> <:patt< $p1$ ; _ >> | p1 = label_ipatt; ";" -> p1 | p1 = label_ipatt -> p1 ] ]; diff --git a/camlp4/boot/Camlp4Ast.ml b/camlp4/boot/Camlp4Ast.ml index da35700cd..acb8afd3c 100644 --- a/camlp4/boot/Camlp4Ast.ml +++ b/camlp4/boot/Camlp4Ast.ml @@ -471,7 +471,8 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc = value meta_loc = meta_loc_expr; module Expr = struct - value meta_string _loc s = Ast.ExStr _loc (safe_string_escaped s); + value meta_string _loc s = + Ast.ExStr _loc (safe_string_escaped s); value meta_int _loc s = Ast.ExInt _loc s; value meta_float _loc s = Ast.ExFlo _loc s; value meta_char _loc s = Ast.ExChr _loc (String.escaped s); @@ -1346,7 +1346,10 @@ if test "$x11_include" = "not found"; then /lib/usr/lib/X11 \ \ /usr/openwin/lib \ - /usr/openwin/share/lib \ + /usr/openwin/share/lib \ + \ + /usr/lib/i386-linux-gnu \ + /usr/lib/x86_64-linux-gnu \ ; \ do if test -f $dir/libX11.a || \ diff --git a/debugger/command_line.ml b/debugger/command_line.ml index 3f84ea7b2..9b0084daf 100644 --- a/debugger/command_line.ml +++ b/debugger/command_line.ml @@ -230,6 +230,22 @@ let instr_shell ppf lexbuf = if (err != 0) then eprintf "Shell command %S failed with exit code %d\n%!" cmd err +let instr_env ppf lexbuf = + let cmdarg = argument_list_eol argument lexbuf in + let cmdarg = string_trim (String.concat " " cmdarg) in + if cmdarg <> "" then + try + if (String.index cmdarg '=') > 0 then + Debugger_config.environment := cmdarg :: !Debugger_config.environment + else + eprintf "Environment variables should not have an empty name\n%!" + with Not_found -> + eprintf "Environment variables should have the \"name=value\" format\n%!" + else + List.iter + (printf "%s\n%!") + (List.rev !Debugger_config.environment) + let instr_pwd ppf lexbuf = eol lexbuf; fprintf ppf "%s@." (Sys.getcwd ()) @@ -454,7 +470,7 @@ let instr_help ppf lexbuf = fprintf ppf "Ambiguous command \"%s\" : %a@." x pr_instrs l end | None -> - fprintf ppf "List of commands :%a@." pr_instrs !instruction_list + fprintf ppf "List of commands : %a@." pr_instrs !instruction_list (* Printing values *) @@ -962,6 +978,9 @@ With no argument, reset the search path." }; { instr_name = "shell"; instr_prio = false; instr_action = instr_shell; instr_repeat = true; instr_help = "Execute a given COMMAND thru the system shell." }; + { instr_name = "environment"; instr_prio = false; + instr_action = instr_env; instr_repeat = false; instr_help = +"environment variable to give to program being debugged when it is started." }; (* Displacements *) { instr_name = "run"; instr_prio = true; instr_action = instr_run; instr_repeat = true; instr_help = diff --git a/debugger/debugger_config.ml b/debugger/debugger_config.ml index 007a3e973..292875936 100644 --- a/debugger/debugger_config.ml +++ b/debugger/debugger_config.ml @@ -80,3 +80,7 @@ let make_checkpoints = ref (match Sys.os_type with "Win32" -> false | _ -> true) + +(*** Environment variables for debugee. ***) + +let environment = ref [] diff --git a/debugger/debugger_config.mli b/debugger/debugger_config.mli index 64411f96a..d3f1a2a7d 100644 --- a/debugger/debugger_config.mli +++ b/debugger/debugger_config.mli @@ -33,3 +33,7 @@ val checkpoint_big_step : int64 ref val checkpoint_small_step : int64 ref val checkpoint_max_count : int ref val make_checkpoints : bool ref + +(*** Environment variables for debugee. ***) + +val environment : string list ref diff --git a/debugger/main.ml b/debugger/main.ml index 5e80081f0..9dbb41ee6 100644 --- a/debugger/main.ml +++ b/debugger/main.ml @@ -183,7 +183,11 @@ let speclist = [ " Print version number and exit"; ] +let function_placeholder () = + raise Not_found + let main () = + Callback.register "Debugger.function_placeholder" function_placeholder; try socket_name := (match Sys.os_type with diff --git a/debugger/parser.mly b/debugger/parser.mly index ae1b0d153..5bba611b9 100644 --- a/debugger/parser.mly +++ b/debugger/parser.mly @@ -170,6 +170,8 @@ longident : LIDENT { Lident $1 } | module_path DOT LIDENT { Ldot($1, $3) } | OPERATOR { Lident $1 } + | module_path DOT OPERATOR { Ldot($1, $3) } + | module_path DOT LPAREN OPERATOR RPAREN { Ldot($1, $4) } ; module_path : diff --git a/debugger/program_loading.ml b/debugger/program_loading.ml index 3f32cb245..6ef9d03e7 100644 --- a/debugger/program_loading.ml +++ b/debugger/program_loading.ml @@ -35,6 +35,39 @@ let load_program () = (*** Launching functions. ***) +(* Returns the environment to be passed to debugee *) +let get_environment () = + let env = Unix.environment () in + let have_same_name x y = + let split = Primitives.split_string '=' in + match split x, split y with + (hd1 :: _), (hd2 :: _) -> hd1 = hd2 + | _ -> false in + let have_name_in_config_env x = + List.exists + (have_same_name x) + !Debugger_config.environment in + let env = + Array.fold_right + (fun elem acc -> + if have_name_in_config_env elem then + acc + else + elem :: acc) + env + [] in + Array.of_list (env @ !Debugger_config.environment) + +(* Returns the environment to be passed to debugee *) +let get_win32_environment () = + let res = Buffer.create 256 in + let env = get_environment () in + let len = Array.length env in + for i = 0 to pred len do + Buffer.add_string res (Printf.sprintf "set %s && " env.(i)) + done; + Buffer.contents res + (* A generic function for launching the program *) let generic_exec_unix cmdline = function () -> if !debug_loading then @@ -52,7 +85,7 @@ let generic_exec_unix cmdline = function () -> 0 -> (* Try to detach the process from the controlling terminal, so that it does not receive SIGINT on ctrl-C. *) begin try ignore(setsid()) with Invalid_argument _ -> () end; - execv shell [| shell; "-c"; cmdline() |] + execve shell [| shell; "-c"; cmdline() |] (get_environment ()) | _ -> exit 0 with x -> Unix_tools.report_error x; @@ -86,7 +119,8 @@ let exec_with_runtime = but quoting is even worse because Unix.create_process thinks each command line parameter is a file. So no good solution so far *) - Printf.sprintf "set CAML_DEBUG_SOCKET=%s && %s %s %s" + Printf.sprintf "%sset CAML_DEBUG_SOCKET=%s && %s %s %s" + (get_win32_environment ()) !socket_name runtime_program !program_name @@ -105,7 +139,8 @@ let exec_direct = match Sys.os_type with "Win32" -> (* See the comment above *) - Printf.sprintf "set CAML_DEBUG_SOCKET=%s && %s %s" + Printf.sprintf "%sset CAML_DEBUG_SOCKET=%s && %s %s" + (get_win32_environment ()) !socket_name !program_name !arguments diff --git a/man/ocamlc.m b/man/ocamlc.m index e53a994f4..c26d29ca5 100644 --- a/man/ocamlc.m +++ b/man/ocamlc.m @@ -407,9 +407,8 @@ specify the name of the output file produced. .B \-output\-obj Cause the linker to produce a C object file instead of a bytecode executable file. This is useful to wrap OCaml code as a C library, -callable from any C program. The name of the output object file is -.B camlprog.o -by default; it can be set with the +callable from any C program. The name of the output object file +must be set with the .B \-o option. This option can also be used to produce a C source file (.c extension) or diff --git a/man/ocamlopt.m b/man/ocamlopt.m index db6ac0098..0dfb196bd 100644 --- a/man/ocamlopt.m +++ b/man/ocamlopt.m @@ -336,8 +336,8 @@ option is given, specify the name of plugin file produced. .B \-output\-obj Cause the linker to produce a C object file instead of an executable file. This is useful to wrap OCaml code as a C library, -callable from any C program. The name of the output object file is -camlprog.o by default; it can be set with the +callable from any C program. The name of the output object file +must be set with the .B \-o option. This option can also be used to produce a compiled shared/dynamic diff --git a/ocamlbuild/ocaml_specific.ml b/ocamlbuild/ocaml_specific.ml index 454daaed4..79c149371 100644 --- a/ocamlbuild/ocaml_specific.ml +++ b/ocamlbuild/ocaml_specific.ml @@ -434,7 +434,7 @@ let () = (* tags package(X), predicate(X) and syntax(X) *) List.iter begin fun tags -> pflag tags "package" (fun pkg -> S [A "-package"; A pkg]); - pflag tags "predicate" (fun pkg -> S [A "-predicate"; A pkg]); + pflag tags "predicate" (fun pkg -> S [A "-predicates"; A pkg]); pflag tags "syntax" (fun pkg -> S [A "-syntax"; A pkg]) end all_tags end else begin diff --git a/otherlibs/unix/putenv.c b/otherlibs/unix/putenv.c index 0fc5534f5..1238ee2b6 100644 --- a/otherlibs/unix/putenv.c +++ b/otherlibs/unix/putenv.c @@ -28,13 +28,16 @@ CAMLprim value unix_putenv(value name, value val) { mlsize_t namelen = string_length(name); mlsize_t vallen = string_length(val); - char * s = (char *) stat_alloc(namelen + 1 + vallen + 1); + char * s = (char *) caml_stat_alloc(namelen + 1 + vallen + 1); memmove (s, String_val(name), namelen); s[namelen] = '='; memmove (s + namelen + 1, String_val(val), vallen); s[namelen + 1 + vallen] = 0; - if (putenv(s) == -1) uerror("putenv", name); + if (putenv(s) == -1) { + caml_stat_free(s); + uerror("putenv", name); + } return Val_unit; } diff --git a/parsing/location.ml b/parsing/location.ml index ad13e70e3..02b135fae 100644 --- a/parsing/location.ml +++ b/parsing/location.ml @@ -15,8 +15,8 @@ open Lexing let absname = ref false - (* This reference should be in Clflags, but it would create an additional dependency - and make bootstrapping Camlp4 more difficult. *) + (* This reference should be in Clflags, but it would create an additional + dependency and make bootstrapping Camlp4 more difficult. *) type t = { loc_start: position; loc_end: position; loc_ghost: bool };; diff --git a/stdlib/format.mli b/stdlib/format.mli index c8146d747..f660b1f24 100644 --- a/stdlib/format.mli +++ b/stdlib/format.mli @@ -631,13 +631,19 @@ val fprintf : formatter -> ('a, formatter, unit) format -> 'a;; For more details about tags, see the functions [open_tag] and [close_tag]. - [@\}]: close the most recently opened tag. - - [@@]: print a plain [@] character. - [@%]: print a plain [%] character. Example: [printf "@[%s@ %d@]@." "x =" 1] is equivalent to [open_box (); print_string "x ="; print_space (); print_int 1; close_box (); print_newline ()]. It prints [x = 1] within a pretty-printing box. + + Note: the old [@@] ``pretty-printing indication'' is now deprecated, since + it had no pretty-printing indication semantics. If you need to prevent + the pretty-printing indication interpretation of a [@] character, simply + use the regular way to escape a character in format string: write [%@]. + @since 3.12.2. + *) val printf : ('a, formatter, unit) format -> 'a;; diff --git a/stdlib/genlex.mli b/stdlib/genlex.mli index 41ce68d0f..b1098f097 100644 --- a/stdlib/genlex.mli +++ b/stdlib/genlex.mli @@ -37,6 +37,11 @@ [< 'Kwd "+"; n2 = parse_expr >] -> n1+n2 | ... ]} + + One should notice that the use of the [parser] keyword and associated + notation for streams are only available through camlp4 extensions. This + means that one has to preprocess its sources {i e. g.} by using the + ["-pp"] command-line switch of the compilers. *) (** The type of tokens. The lexical classes are: [Int] and [Float] diff --git a/stdlib/lazy.ml b/stdlib/lazy.ml index 359fcaa63..6a114245e 100644 --- a/stdlib/lazy.ml +++ b/stdlib/lazy.ml @@ -57,13 +57,13 @@ external force : 'a t -> 'a = "%lazy_force";; let force_val = CamlinternalLazy.force_val;; -let lazy_from_fun (f : unit -> 'arg) = +let from_fun (f : unit -> 'arg) = let x = Obj.new_block Obj.lazy_tag 1 in Obj.set_field x 0 (Obj.repr f); (Obj.obj x : 'arg t) ;; -let lazy_from_val (v : 'arg) = +let from_val (v : 'arg) = let t = Obj.tag (Obj.repr v) in if t = Obj.forward_tag || t = Obj.lazy_tag || t = Obj.double_tag then begin make_forward v @@ -72,4 +72,10 @@ let lazy_from_val (v : 'arg) = end ;; -let lazy_is_val (l : 'arg t) = Obj.tag (Obj.repr l) <> Obj.lazy_tag;; +let is_val (l : 'arg t) = Obj.tag (Obj.repr l) <> Obj.lazy_tag;; + +let lazy_from_fun = from_fun;; + +let lazy_from_val = from_val;; + +let lazy_is_val = is_val;; diff --git a/stdlib/lazy.mli b/stdlib/lazy.mli index 4a3b5df0f..4a4419c22 100644 --- a/stdlib/lazy.mli +++ b/stdlib/lazy.mli @@ -62,15 +62,23 @@ val force_val : 'a t -> 'a;; whether [force_val x] raises the same exception or [Undefined]. *) -val lazy_from_fun : (unit -> 'a) -> 'a t;; -(** [lazy_from_fun f] is the same as [lazy (f ())] but slightly more - efficient. *) +val from_fun : (unit -> 'a) -> 'a t;; +(** [from_fun f] is the same as [lazy (f ())] but slightly more efficient. *) -val lazy_from_val : 'a -> 'a t;; -(** [lazy_from_val v] returns an already-forced suspension of [v] +val from_val : 'a -> 'a t;; +(** [from_val v] returns an already-forced suspension of [v]. This is for special purposes only and should not be confused with [lazy (v)]. *) -val lazy_is_val : 'a t -> bool;; -(** [lazy_is_val x] returns [true] if [x] has already been forced and +val is_val : 'a t -> bool;; +(** [is_val x] returns [true] if [x] has already been forced and did not raise an exception. *) + +val lazy_from_fun : (unit -> 'a) -> 'a t;; +(** @deprecated synonym for [from_fun]. *) + +val lazy_from_val : 'a -> 'a t;; +(** @deprecated synonym for [from_val]. *) + +val lazy_is_val : 'a t -> bool;; +(** @deprecated synonym for [is_val]. *) diff --git a/stdlib/marshal.ml b/stdlib/marshal.ml index c42851504..638f05434 100644 --- a/stdlib/marshal.ml +++ b/stdlib/marshal.ml @@ -16,6 +16,7 @@ type extern_flags = No_sharing | Closures +(* note: this type definition is used in 'byterun/debugger.c' *) external to_channel: out_channel -> 'a -> extern_flags list -> unit = "caml_output_value" diff --git a/stdlib/scanf.ml b/stdlib/scanf.ml index 9c6ecef62..37740765d 100644 --- a/stdlib/scanf.ml +++ b/stdlib/scanf.ml @@ -1111,7 +1111,7 @@ let make_char_bit_vect bit set = ;; (* Compute the predicate on chars corresponding to a char set. *) -let make_pred bit set stp = +let make_predicate bit set stp = let r = make_char_bit_vect bit set in List.iter (fun c -> set_bit_of_range r (int_of_char c) (bit_not bit)) stp; @@ -1131,9 +1131,9 @@ let make_setp stp char_set = (fun c -> if c == p1 || c == p2 then 1 else 0) | 3 -> let p1 = set.[0] and p2 = set.[1] and p3 = set.[2] in - if p2 = '-' then make_pred 1 set stp else + if p2 = '-' then make_predicate 1 set stp else (fun c -> if c == p1 || c == p2 || c == p3 then 1 else 0) - | _ -> make_pred 1 set stp + | _ -> make_predicate 1 set stp end | Neg_set set -> begin match String.length set with @@ -1146,9 +1146,9 @@ let make_setp stp char_set = (fun c -> if c != p1 && c != p2 then 1 else 0) | 3 -> let p1 = set.[0] and p2 = set.[1] and p3 = set.[2] in - if p2 = '-' then make_pred 0 set stp else + if p2 = '-' then make_predicate 0 set stp else (fun c -> if c != p1 && c != p2 && c != p3 then 1 else 0) - | _ -> make_pred 0 set stp + | _ -> make_predicate 0 set stp end ;; @@ -1335,18 +1335,10 @@ let scan_format ib ef fmt rv f = let rec scan_fmt ir f i = if i > lim then ir, f else match Sformat.unsafe_get fmt i with - | ' ' -> skip_whites ib; scan_fmt ir f (succ i) | '%' -> scan_skip ir f (succ i) - | '@' -> skip_indication ir f (succ i) + | ' ' -> skip_whites ib; scan_fmt ir f (succ i) | c -> check_char ib c; scan_fmt ir f (succ i) - and skip_indication ir f i = - if i < lim then - match Sformat.unsafe_get fmt i with - | '@' | '%' as c -> check_char ib c; scan_fmt ir f (succ i) - | c -> check_char ib c; scan_fmt ir f i - else incomplete_format fmt - and scan_skip ir f i = if i > lim then ir, f else match Sformat.get fmt i with @@ -1393,6 +1385,12 @@ let scan_format ib ef fmt rv f = | '%' | '@' as c -> check_char ib c; scan_fmt ir f (succ i) + | '!' -> + if not (Scanning.end_of_input ib) + then bad_input "end of input not found" else + scan_fmt ir f (succ i) + | ',' -> + scan_fmt ir f (succ i) | 's' -> let i, stp = scan_indication (succ i) in let _x = scan_string stp width ib in @@ -1451,11 +1449,6 @@ let scan_format ib ef fmt rv f = | _ -> scan_fmt ir (stack f (token_int64 conv1 ib)) (succ i) end (* This is not an integer conversion, but a regular %l, %n or %L. *) | _ -> scan_fmt ir (stack f (get_count conv0 ib)) i end - | '!' -> - if Scanning.end_of_input ib then scan_fmt ir f (succ i) - else bad_input "end of input not found" - | ',' -> - scan_fmt ir f (succ i) | '(' | '{' as conv (* ')' '}' *) -> let i = succ i in (* Find the static specification for the format to read. *) diff --git a/stdlib/stdLabels.mli b/stdlib/stdLabels.mli index cb1ba01a4..1360081a2 100644 --- a/stdlib/stdLabels.mli +++ b/stdlib/stdLabels.mli @@ -117,6 +117,7 @@ module String : unit val concat : sep:string -> string list -> string val iter : f:(char -> unit) -> string -> unit + val trim : string -> string val escaped : string -> string val index : string -> char -> int val rindex : string -> char -> int diff --git a/stdlib/string.ml b/stdlib/string.ml index 7eafec02f..f3906f353 100644 --- a/stdlib/string.ml +++ b/stdlib/string.ml @@ -85,6 +85,27 @@ external is_printable: char -> bool = "caml_is_printable" external char_code: char -> int = "%identity" external char_chr: int -> char = "%identity" +let is_space = function + | ' ' | '\012' | '\n' | '\r' | '\t' -> true + | _ -> false + +let trim s = + let len = length s in + let i = ref 0 in + while !i < len && is_space (unsafe_get s !i) do + incr i + done; + let j = ref (len - 1) in + while !j >= !i && is_space (unsafe_get s !j) do + decr j + done; + if !i = 0 && !j = len - 1 then + s + else if !j >= !i then + sub s !i (!j - !i + 1) + else + "" + let escaped s = let n = ref 0 in for i = 0 to length s - 1 do diff --git a/stdlib/string.mli b/stdlib/string.mli index d1ae9356b..2405ac6ad 100644 --- a/stdlib/string.mli +++ b/stdlib/string.mli @@ -132,6 +132,12 @@ val map : (char -> char) -> string -> string the characters of [s] and stores the results in a new string that is returned. *) +val trim : string -> string +(** Return a copy of the argument, without leading and trailing whitespace. + The characters regarded as whitespace are: [' '], ['\012'], ['\n'], + ['\r'], and ['\t']. If there is no whitespace character in the argument, + return the original string itself, not a copy. *) + val escaped : string -> string (** Return a copy of the argument, with special characters represented by escape sequences, following the lexical diff --git a/stdlib/stringLabels.mli b/stdlib/stringLabels.mli index 5a17c67da..84f618be2 100644 --- a/stdlib/stringLabels.mli +++ b/stdlib/stringLabels.mli @@ -86,11 +86,22 @@ val iter : f:(char -> unit) -> string -> unit val iteri : f:(int -> char -> unit) -> string -> unit (** Same as {!String.iter}, but the - function is applied to the index of the element as first argument (counting from 0), - and the character itself as second argument. + function is applied to the index of the element as first argument + (counting from 0), and the character itself as second argument. @since 3.13.0 *) +val map : f:(char -> char) -> string -> string +(** [String.map f s] applies function [f] in turn to all + the characters of [s] and stores the results in a new string that + is returned. *) + +val trim : string -> string +(** Return a copy of the argument, without leading and trailing whitespace. + The characters regarded as whitespace are: [' '], ['\012'], ['\n'], + ['\r'], and ['\t']. If there is no whitespace character in the argument, + return the original string itself, not a copy. *) + val escaped : string -> string (** Return a copy of the argument, with special characters represented by escape sequences, following the lexical diff --git a/stdlib/sys.mli b/stdlib/sys.mli index 4913bef8e..b127bc00b 100644 --- a/stdlib/sys.mli +++ b/stdlib/sys.mli @@ -84,6 +84,9 @@ val word_size : int (** Size of one word on the machine currently executing the OCaml program, in bits: 32 or 64. *) +val big_endian : bool +(** Whether the machine currently executing the Caml program is big-endian. *) + val max_string_length : int (** Maximum length of a string. *) diff --git a/stdlib/sys.mlp b/stdlib/sys.mlp index b83cbb287..c7271794d 100644 --- a/stdlib/sys.mlp +++ b/stdlib/sys.mlp @@ -19,11 +19,11 @@ (* System interface *) -external get_config: unit -> string * int = "caml_sys_get_config" +external get_config: unit -> string * int * bool = "caml_sys_get_config" external get_argv: unit -> string * string array = "caml_sys_get_argv" let (executable_name, argv) = get_argv() -let (os_type, word_size) = get_config() +let (os_type, word_size, big_endian) = get_config() let max_array_length = (1 lsl (word_size - 10)) - 1;; let max_string_length = word_size / 8 * max_array_length - 1;; diff --git a/testsuite/tests/lib-printf/Makefile b/testsuite/tests/lib-printf/Makefile new file mode 100644 index 000000000..94c404726 --- /dev/null +++ b/testsuite/tests/lib-printf/Makefile @@ -0,0 +1,7 @@ +#MODULES= +MAIN_MODULE=tprintf +ADD_COMPFLAGS=-I $(BASEDIR)/lib +ADD_MODULES=testing + +include ../../makefiles/Makefile.one +include ../../makefiles/Makefile.common diff --git a/testsuite/tests/lib-printf/tprintf.ml b/testsuite/tests/lib-printf/tprintf.ml new file mode 100644 index 000000000..16046a7c0 --- /dev/null +++ b/testsuite/tests/lib-printf/tprintf.ml @@ -0,0 +1,468 @@ +(*************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Damien Doligez, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2011 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(*************************************************************************) + +(* $Id: tscanf.ml 10713 2010-10-08 11:53:19Z doligez $ *) + +(* + +A test file for the Printf module. + +*) + +open Testing;; +open Printf;; + +try + + printf "d/i positive\n%!"; + test (sprintf "%d/%i" 42 43 = "42/43"); + test (sprintf "%-4d/%-5i" 42 43 = "42 /43 "); + test (sprintf "%04d/%05i" 42 43 = "0042/00043"); + test (sprintf "%+d/%+i" 42 43 = "+42/+43"); + test (sprintf "% d/% i" 42 43 = " 42/ 43"); + test (sprintf "%#d/%#i" 42 43 = "42/43"); + test (sprintf "%4d/%5i" 42 43 = " 42/ 43"); + test (sprintf "%*d/%*i" 4 42 5 43 = " 42/ 43"); + test (sprintf "%-0+#4d/%-0 #5i" 42 43 = "+42 / 43 "); + + printf "\nd/i negative\n%!"; + test (sprintf "%d/%i" (-42) (-43) = "-42/-43"); + test (sprintf "%-4d/%-5i" (-42) (-43) = "-42 /-43 "); + test (sprintf "%04d/%05i" (-42) (-43) = "-042/-0043"); + test (sprintf "%+d/%+i" (-42) (-43) = "-42/-43"); + test (sprintf "% d/% i" (-42) (-43) = "-42/-43"); + test (sprintf "%#d/%#i" (-42) (-43) = "-42/-43"); + test (sprintf "%4d/%5i" (-42) (-43) = " -42/ -43"); + test (sprintf "%*d/%*i" 4 (-42) 5 (-43) = " -42/ -43"); + test (sprintf "%-0+ #4d/%-0+ #5i" (-42) (-43) = "-42 /-43 "); + + printf "\nu positive\n%!"; + test (sprintf "%u" 42 = "42"); + test (sprintf "%-4u" 42 = "42 "); + test (sprintf "%04u" 42 = "0042"); + test (sprintf "%+u" 42 = "42"); + test (sprintf "% u" 42 = "42"); + test (sprintf "%#u" 42 = "42"); + test (sprintf "%4u" 42 = " 42"); + test (sprintf "%*u" 4 42 = " 42"); + test (sprintf "%-0+ #6d" 42 = "+42 "); + + printf "\nu negative\n%!"; + begin match Sys.word_size with + | 32 -> + test (sprintf "%u" (-1) = "2147483647"); + | 64 -> + test (sprintf "%u" (-1) = "9223372036854775807"); + | _ -> test false + end; + + printf "\nx positive\n%!"; + test (sprintf "%x" 42 = "2a"); + test (sprintf "%-4x" 42 = "2a "); + test (sprintf "%04x" 42 = "002a"); + test (sprintf "%+x" 42 = "2a"); + test (sprintf "% x" 42 = "2a"); + test (sprintf "%#x" 42 = "0x2a"); + test (sprintf "%4x" 42 = " 2a"); + test (sprintf "%*x" 5 42 = " 2a"); + test (sprintf "%-0+ #*x" 5 42 = "0x2a "); + + printf "\nx negative\n%!"; + begin match Sys.word_size with + | 32 -> + test (sprintf "%x" (-42) = "7fffffd6"); + | 64 -> + test (sprintf "%x" (-42) = "7fffffffffffffd6"); + | _ -> test false + end; + + printf "\nX positive\n%!"; + test (sprintf "%X" 42 = "2A"); + test (sprintf "%-4X" 42 = "2A "); + test (sprintf "%04X" 42 = "002A"); + test (sprintf "%+X" 42 = "2A"); + test (sprintf "% X" 42 = "2A"); + test (sprintf "%#X" 42 = "0X2A"); + test (sprintf "%4X" 42 = " 2A"); + test (sprintf "%*X" 5 42 = " 2A"); + test (sprintf "%-0+ #*X" 5 42 = "0X2A "); + + printf "\nx negative\n%!"; + begin match Sys.word_size with + | 32 -> + test (sprintf "%X" (-42) = "7FFFFFD6"); + | 64 -> + test (sprintf "%X" (-42) = "7FFFFFFFFFFFFFD6"); + | _ -> test false + end; + + printf "\no positive\n%!"; + test (sprintf "%o" 42 = "52"); + test (sprintf "%-4o" 42 = "52 "); + test (sprintf "%04o" 42 = "0052"); + test (sprintf "%+o" 42 = "52"); + test (sprintf "% o" 42 = "52"); + test (sprintf "%#o" 42 = "052"); + test (sprintf "%4o" 42 = " 52"); + test (sprintf "%*o" 5 42 = " 52"); + test (sprintf "%-0+ #*o" 5 42 = "052 "); + + printf "\no negative\n%!"; + begin match Sys.word_size with + | 32 -> + test (sprintf "%o" (-42) = "17777777726"); + | 64 -> + test (sprintf "%o" (-42) = "777777777777777777726"); + | _ -> test false + end; + + printf "\ns\n%!"; + test (sprintf "%s" "foo" = "foo"); + test (sprintf "%-5s" "foo" = "foo "); + test (sprintf "%05s" "foo" = " foo"); + test (sprintf "%+s" "foo" = "foo"); + test (sprintf "% s" "foo" = "foo"); + test (sprintf "%#s" "foo" = "foo"); + test (sprintf "%5s" "foo" = " foo"); + test (sprintf "%1s" "foo" = "foo"); + test (sprintf "%*s" 6 "foo" = " foo"); + test (sprintf "%*s" 2 "foo" = "foo"); + test (sprintf "%-0+ #5s" "foo" = "foo "); + test (sprintf "%s@" "foo" = "foo@"); + test (sprintf "%s@inria.fr" "foo" = "foo@inria.fr"); + test (sprintf "%s@%s" "foo" "inria.fr" = "foo@inria.fr"); + + printf "\nS\n%!"; + test (sprintf "%S" "fo\"o" = "\"fo\\\"o\""); +(* test (sprintf "%-5S" "foo" = "\"foo\" "); padding not done *) +(* test (sprintf "%05S" "foo" = " \"foo\""); padding not done *) + test (sprintf "%+S" "foo" = "\"foo\""); + test (sprintf "% S" "foo" = "\"foo\""); + test (sprintf "%#S" "foo" = "\"foo\""); +(* test (sprintf "%5S" "foo" = " \"foo\""); padding not done *) + test (sprintf "%1S" "foo" = "\"foo\""); +(* test (sprintf "%*S" 6 "foo" = " \"foo\""); padding not done *) + test (sprintf "%*S" 2 "foo" = "\"foo\""); +(* test (sprintf "%-0+ #5S" "foo" = "\"foo\" "); padding not done *) + test (sprintf "%S@" "foo" = "\"foo\"@"); + test (sprintf "%S@inria.fr" "foo" = "\"foo\"@inria.fr"); + test (sprintf "%S@%S" "foo" "inria.fr" = "\"foo\"@\"inria.fr\""); + + printf "\nc\n%!"; + test (sprintf "%c" 'c' = "c"); +(* test (sprintf "%-4c" 'c' = "c "); padding not done *) +(* test (sprintf "%04c" 'c' = " c"); padding not done *) + test (sprintf "%+c" 'c' = "c"); + test (sprintf "% c" 'c' = "c"); + test (sprintf "%#c" 'c' = "c"); +(* test (sprintf "%4c" 'c' = " c"); padding not done *) +(* test (sprintf "%*c" 2 'c' = " c"); padding not done *) +(* test (sprintf "%-0+ #4c" 'c' = "c "); padding not done *) + + printf "\nC\n%!"; + test (sprintf "%C" 'c' = "'c'"); + test (sprintf "%C" '\'' = "'\\''"); +(* test (sprintf "%-4C" 'c' = "c "); padding not done *) +(* test (sprintf "%04C" 'c' = " c"); padding not done *) + test (sprintf "%+C" 'c' = "'c'"); + test (sprintf "% C" 'c' = "'c'"); + test (sprintf "%#C" 'c' = "'c'"); +(* test (sprintf "%4C" 'c' = " c"); padding not done *) +(* test (sprintf "%*C" 2 'c' = " c"); padding not done *) +(* test (sprintf "%-0+ #4C" 'c' = "c "); padding not done *) + + printf "\nf\n%!"; + test (sprintf "%f" (-42.42) = "-42.420000"); + test (sprintf "%-13f" (-42.42) = "-42.420000 "); + test (sprintf "%013f" (-42.42) = "-00042.420000"); + test (sprintf "%+f" 42.42 = "+42.420000"); + test (sprintf "% f" 42.42 = " 42.420000"); + test (sprintf "%#f" 42.42 = "42.420000"); + test (sprintf "%13f" 42.42 = " 42.420000"); + test (sprintf "%*f" 12 42.42 = " 42.420000"); + test (sprintf "%-0+ #12f" 42.42 = "+42.420000 "); + test (sprintf "%.3f" (-42.42) = "-42.420"); + test (sprintf "%-13.3f" (-42.42) = "-42.420 "); + test (sprintf "%013.3f" (-42.42) = "-00000042.420"); + test (sprintf "%+.3f" 42.42 = "+42.420"); + test (sprintf "% .3f" 42.42 = " 42.420"); + test (sprintf "%#.3f" 42.42 = "42.420"); + test (sprintf "%13.3f" 42.42 = " 42.420"); + test (sprintf "%*.*f" 12 3 42.42 = " 42.420"); + test (sprintf "%-0+ #12.3f" 42.42 = "+42.420 "); + + printf "\nF\n%!"; + test (sprintf "%F" 42.42 = "42.42"); + test (sprintf "%F" 42.42e42 = "4.242e+43"); + test (sprintf "%F" 42.00 = "42."); + test (sprintf "%F" 0.042 = "0.042"); +(* no padding, no precision + test (sprintf "%.3F" 42.42 = "42.420"); + test (sprintf "%12.3F" 42.42e42 = " 4.242e+43"); + test (sprintf "%.3F" 42.00 = "42.000"); + test (sprintf "%.3F" 0.0042 = "0.004"); +*) + + printf "\ne\n%!"; + test (sprintf "%e" (-42.42) = "-4.242000e+01"); + test (sprintf "%-15e" (-42.42) = "-4.242000e+01 "); + test (sprintf "%015e" (-42.42) = "-004.242000e+01"); + test (sprintf "%+e" 42.42 = "+4.242000e+01"); + test (sprintf "% e" 42.42 = " 4.242000e+01"); + test (sprintf "%#e" 42.42 = "4.242000e+01"); + test (sprintf "%15e" 42.42 = " 4.242000e+01"); + test (sprintf "%*e" 14 42.42 = " 4.242000e+01"); + test (sprintf "%-0+ #14e" 42.42 = "+4.242000e+01 "); + test (sprintf "%.3e" (-42.42) = "-4.242e+01"); + test (sprintf "%-15.3e" (-42.42) = "-4.242e+01 "); + test (sprintf "%015.3e" (-42.42) = "-000004.242e+01"); + test (sprintf "%+.3e" 42.42 = "+4.242e+01"); + test (sprintf "% .3e" 42.42 = " 4.242e+01"); + test (sprintf "%#.3e" 42.42 = "4.242e+01"); + test (sprintf "%15.3e" 42.42 = " 4.242e+01"); + test (sprintf "%*.*e" 11 3 42.42 = " 4.242e+01"); + test (sprintf "%-0+ #14.3e" 42.42 = "+4.242e+01 "); + + printf "\nE\n%!"; + test (sprintf "%E" (-42.42) = "-4.242000E+01"); + test (sprintf "%-15E" (-42.42) = "-4.242000E+01 "); + test (sprintf "%015E" (-42.42) = "-004.242000E+01"); + test (sprintf "%+E" 42.42 = "+4.242000E+01"); + test (sprintf "% E" 42.42 = " 4.242000E+01"); + test (sprintf "%#E" 42.42 = "4.242000E+01"); + test (sprintf "%15E" 42.42 = " 4.242000E+01"); + test (sprintf "%*E" 14 42.42 = " 4.242000E+01"); + test (sprintf "%-0+ #14E" 42.42 = "+4.242000E+01 "); + test (sprintf "%.3E" (-42.42) = "-4.242E+01"); + test (sprintf "%-15.3E" (-42.42) = "-4.242E+01 "); + test (sprintf "%015.3E" (-42.42) = "-000004.242E+01"); + test (sprintf "%+.3E" 42.42 = "+4.242E+01"); + test (sprintf "% .3E" 42.42 = " 4.242E+01"); + test (sprintf "%#.3E" 42.42 = "4.242E+01"); + test (sprintf "%15.3E" 42.42 = " 4.242E+01"); + test (sprintf "%*.*E" 11 3 42.42 = " 4.242E+01"); + test (sprintf "%-0+ #14.3E" 42.42 = "+4.242E+01 "); + +(* %g gives strange results that correspond to neither %f nor %e + printf "\ng\n%!"; + test (sprintf "%g" (-42.42) = "-42.42000"); + test (sprintf "%-15g" (-42.42) = "-42.42000 "); + test (sprintf "%015g" (-42.42) = "-00000042.42000"); + test (sprintf "%+g" 42.42 = "+42.42000"); + test (sprintf "% g" 42.42 = " 42.42000"); + test (sprintf "%#g" 42.42 = "42.42000"); + test (sprintf "%15g" 42.42 = " 42.42000"); + test (sprintf "%*g" 14 42.42 = " 42.42000"); + test (sprintf "%-0+ #14g" 42.42 = "+42.42000 "); + test (sprintf "%.3g" (-42.42) = "-42.420"); +*) + +(* Same for %G + printf "\nG\n%!"; +*) + + printf "\nB\n%!"; + test (sprintf "%B" true = "true"); + test (sprintf "%B" false = "false"); + + printf "ld/li positive\n%!"; + test (sprintf "%ld/%li" 42l 43l = "42/43"); + test (sprintf "%-4ld/%-5li" 42l 43l = "42 /43 "); + test (sprintf "%04ld/%05li" 42l 43l = "0042/00043"); + test (sprintf "%+ld/%+li" 42l 43l = "+42/+43"); + test (sprintf "% ld/% li" 42l 43l = " 42/ 43"); + test (sprintf "%#ld/%#li" 42l 43l = "42/43"); + test (sprintf "%4ld/%5li" 42l 43l = " 42/ 43"); + test (sprintf "%*ld/%*li" 4 42l 5 43l = " 42/ 43"); + test (sprintf "%-0+#4ld/%-0 #5li" 42l 43l = "+42 / 43 "); + + printf "\nld/li negative\n%!"; + test (sprintf "%ld/%li" (-42l) (-43l) = "-42/-43"); + test (sprintf "%-4ld/%-5li" (-42l) (-43l) = "-42 /-43 "); + test (sprintf "%04ld/%05li" (-42l) (-43l) = "-042/-0043"); + test (sprintf "%+ld/%+li" (-42l) (-43l) = "-42/-43"); + test (sprintf "% ld/% li" (-42l) (-43l) = "-42/-43"); + test (sprintf "%#ld/%#li" (-42l) (-43l) = "-42/-43"); + test (sprintf "%4ld/%5li" (-42l) (-43l) = " -42/ -43"); + test (sprintf "%*ld/%*li" 4 (-42l) 5 (-43l) = " -42/ -43"); + test (sprintf "%-0+ #4ld/%-0+ #5li" (-42l) (-43l) = "-42 /-43 "); + + printf "\nlu positive\n%!"; + test (sprintf "%lu" 42l = "42"); + test (sprintf "%-4lu" 42l = "42 "); + test (sprintf "%04lu" 42l = "0042"); + test (sprintf "%+lu" 42l = "42"); + test (sprintf "% lu" 42l = "42"); + test (sprintf "%#lu" 42l = "42"); + test (sprintf "%4lu" 42l = " 42"); + test (sprintf "%*lu" 4 42l = " 42"); + test (sprintf "%-0+ #6ld" 42l = "+42 "); + + printf "\nlu negative\n%!"; + test (sprintf "%lu" (-1l) = "4294967295"); + + printf "\nlx positive\n%!"; + test (sprintf "%lx" 42l = "2a"); + test (sprintf "%-4lx" 42l = "2a "); + test (sprintf "%04lx" 42l = "002a"); + test (sprintf "%+lx" 42l = "2a"); + test (sprintf "% lx" 42l = "2a"); + test (sprintf "%#lx" 42l = "0x2a"); + test (sprintf "%4lx" 42l = " 2a"); + test (sprintf "%*lx" 5 42l = " 2a"); + test (sprintf "%-0+ #*lx" 5 42l = "0x2a "); + + printf "\nlx negative\n%!"; + test (sprintf "%lx" (-42l) = "ffffffd6"); + + printf "\nlX positive\n%!"; + test (sprintf "%lX" 42l = "2A"); + test (sprintf "%-4lX" 42l = "2A "); + test (sprintf "%04lX" 42l = "002A"); + test (sprintf "%+lX" 42l = "2A"); + test (sprintf "% lX" 42l = "2A"); + test (sprintf "%#lX" 42l = "0X2A"); + test (sprintf "%4lX" 42l = " 2A"); + test (sprintf "%*lX" 5 42l = " 2A"); + test (sprintf "%-0+ #*lX" 5 42l = "0X2A "); + + printf "\nlx negative\n%!"; + test (sprintf "%lX" (-42l) = "FFFFFFD6"); + + printf "\nlo positive\n%!"; + test (sprintf "%lo" 42l = "52"); + test (sprintf "%-4lo" 42l = "52 "); + test (sprintf "%04lo" 42l = "0052"); + test (sprintf "%+lo" 42l = "52"); + test (sprintf "% lo" 42l = "52"); + test (sprintf "%#lo" 42l = "052"); + test (sprintf "%4lo" 42l = " 52"); + test (sprintf "%*lo" 5 42l = " 52"); + test (sprintf "%-0+ #*lo" 5 42l = "052 "); + + printf "\nlo negative\n%!"; + test (sprintf "%lo" (-42l) = "37777777726"); + + (* Nativeint not tested: looks like too much work, and anyway it should + work like Int32 or Int64. *) + + printf "Ld/Li positive\n%!"; + test (sprintf "%Ld/%Li" 42L 43L = "42/43"); + test (sprintf "%-4Ld/%-5Li" 42L 43L = "42 /43 "); + test (sprintf "%04Ld/%05Li" 42L 43L = "0042/00043"); + test (sprintf "%+Ld/%+Li" 42L 43L = "+42/+43"); + test (sprintf "% Ld/% Li" 42L 43L = " 42/ 43"); + test (sprintf "%#Ld/%#Li" 42L 43L = "42/43"); + test (sprintf "%4Ld/%5Li" 42L 43L = " 42/ 43"); + test (sprintf "%*Ld/%*Li" 4 42L 5 43L = " 42/ 43"); + test (sprintf "%-0+#4Ld/%-0 #5Li" 42L 43L = "+42 / 43 "); + + printf "\nLd/Li negative\n%!"; + test (sprintf "%Ld/%Li" (-42L) (-43L) = "-42/-43"); + test (sprintf "%-4Ld/%-5Li" (-42L) (-43L) = "-42 /-43 "); + test (sprintf "%04Ld/%05Li" (-42L) (-43L) = "-042/-0043"); + test (sprintf "%+Ld/%+Li" (-42L) (-43L) = "-42/-43"); + test (sprintf "% Ld/% Li" (-42L) (-43L) = "-42/-43"); + test (sprintf "%#Ld/%#Li" (-42L) (-43L) = "-42/-43"); + test (sprintf "%4Ld/%5Li" (-42L) (-43L) = " -42/ -43"); + test (sprintf "%*Ld/%*Li" 4 (-42L) 5 (-43L) = " -42/ -43"); + test (sprintf "%-0+ #4Ld/%-0+ #5Li" (-42L) (-43L) = "-42 /-43 "); + + printf "\nLu positive\n%!"; + test (sprintf "%Lu" 42L = "42"); + test (sprintf "%-4Lu" 42L = "42 "); + test (sprintf "%04Lu" 42L = "0042"); + test (sprintf "%+Lu" 42L = "42"); + test (sprintf "% Lu" 42L = "42"); + test (sprintf "%#Lu" 42L = "42"); + test (sprintf "%4Lu" 42L = " 42"); + test (sprintf "%*Lu" 4 42L = " 42"); + test (sprintf "%-0+ #6Ld" 42L = "+42 "); + + printf "\nLu negative\n%!"; + test (sprintf "%Lu" (-1L) = "18446744073709551615"); + + printf "\nLx positive\n%!"; + test (sprintf "%Lx" 42L = "2a"); + test (sprintf "%-4Lx" 42L = "2a "); + test (sprintf "%04Lx" 42L = "002a"); + test (sprintf "%+Lx" 42L = "2a"); + test (sprintf "% Lx" 42L = "2a"); + test (sprintf "%#Lx" 42L = "0x2a"); + test (sprintf "%4Lx" 42L = " 2a"); + test (sprintf "%*Lx" 5 42L = " 2a"); + test (sprintf "%-0+ #*Lx" 5 42L = "0x2a "); + + printf "\nLx negative\n%!"; + test (sprintf "%Lx" (-42L) = "ffffffffffffffd6"); + + printf "\nLX positive\n%!"; + test (sprintf "%LX" 42L = "2A"); + test (sprintf "%-4LX" 42L = "2A "); + test (sprintf "%04LX" 42L = "002A"); + test (sprintf "%+LX" 42L = "2A"); + test (sprintf "% LX" 42L = "2A"); + test (sprintf "%#LX" 42L = "0X2A"); + test (sprintf "%4LX" 42L = " 2A"); + test (sprintf "%*LX" 5 42L = " 2A"); + test (sprintf "%-0+ #*LX" 5 42L = "0X2A "); + + printf "\nLx negative\n%!"; + test (sprintf "%LX" (-42L) = "FFFFFFFFFFFFFFD6"); + + printf "\nLo positive\n%!"; + test (sprintf "%Lo" 42L = "52"); + test (sprintf "%-4Lo" 42L = "52 "); + test (sprintf "%04Lo" 42L = "0052"); + test (sprintf "%+Lo" 42L = "52"); + test (sprintf "% Lo" 42L = "52"); + test (sprintf "%#Lo" 42L = "052"); + test (sprintf "%4Lo" 42L = " 52"); + test (sprintf "%*Lo" 5 42L = " 52"); + test (sprintf "%-0+ #*Lo" 5 42L = "052 "); + + printf "\nLo negative\n%!"; + test (sprintf "%Lo" (-42L) = "1777777777777777777726"); + + printf "\na\n%!"; + let x = ref () in + let f () y = if y == x then "ok" else "wrong" in + test (sprintf "%a" f x = "ok"); + + printf "\nt\n%!"; + let f () = "ok" in + test (sprintf "%t" f = "ok"); + +(* Does not work as expected. Should be fixed to work like %s. + printf "\n{...%%}\n%!"; + let f = format_of_string "%f/%s" in + test (sprintf "%{%f%s%}" f = "%f/%s"); +*) + + printf "\n(...%%)\n%!"; + let f = format_of_string "%d/foo/%s" in + test (sprintf "%(%d%s%)" f 42 "bar" = "42/foo/bar"); + + printf "\n! %% @ , and constants\n%!"; + test (sprintf "%!" = ""); + test (sprintf "%%" = "%"); + test (sprintf "%@" = "@"); + test (sprintf "%," = ""); + test (sprintf "@" = "@"); + test (sprintf "@@" = "@@"); + test (sprintf "@%%" = "@%"); + + printf "\nend of tests\n%!"; +with e -> + printf "unexpected exception: %s\n%!" (Printexc.to_string e); + test false; +;; diff --git a/testsuite/tests/lib-printf/tprintf.reference b/testsuite/tests/lib-printf/tprintf.reference new file mode 100644 index 000000000..693db2496 --- /dev/null +++ b/testsuite/tests/lib-printf/tprintf.reference @@ -0,0 +1,87 @@ +d/i positive +0 1 2 3 4 5 6 7 8 +d/i negative +9 10 11 12 13 14 15 16 17 +u positive +18 19 20 21 22 23 24 25 26 +u negative +27 +x positive +28 29 30 31 32 33 34 35 36 +x negative +37 +X positive +38 39 40 41 42 43 44 45 46 +x negative +47 +o positive +48 49 50 51 52 53 54 55 56 +o negative +57 +s +58 59 60 61 62 63 64 65 66 67 68 69 70 71 +S +72 73 74 75 76 77 78 79 80 +c +81 82 83 84 +C +85 86 87 88 89 +f +90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 +F +108 109 110 111 +e +112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 +E +130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 +B +148 149 ld/li positive +150 151 152 153 154 155 156 157 158 +ld/li negative +159 160 161 162 163 164 165 166 167 +lu positive +168 169 170 171 172 173 174 175 176 +lu negative +177 +lx positive +178 179 180 181 182 183 184 185 186 +lx negative +187 +lX positive +188 189 190 191 192 193 194 195 196 +lx negative +197 +lo positive +198 199 200 201 202 203 204 205 206 +lo negative +207 Ld/Li positive +208 209 210 211 212 213 214 215 216 +Ld/Li negative +217 218 219 220 221 222 223 224 225 +Lu positive +226 227 228 229 230 231 232 233 234 +Lu negative +235 +Lx positive +236 237 238 239 240 241 242 243 244 +Lx negative +245 +LX positive +246 247 248 249 250 251 252 253 254 +Lx negative +255 +Lo positive +256 257 258 259 260 261 262 263 264 +Lo negative +265 +a +266 +t +267 +(...%) +268 +! % @ , and constants +269 270 271 272 273 274 275 +end of tests + +All tests succeeded. diff --git a/testsuite/tests/lib-scanf/tscanf.ml b/testsuite/tests/lib-scanf/tscanf.ml index 49afdb320..64e144264 100644 --- a/testsuite/tests/lib-scanf/tscanf.ml +++ b/testsuite/tests/lib-scanf/tscanf.ml @@ -1444,12 +1444,22 @@ let test57 () = test (test57 ()) ;; -(* let test58 () = + sscanf "string1%string2" "%s@%%s" id = "string1" + && sscanf "string1%string2" "%s@%%%s" (^) = "string1string2" + && sscanf "string1@string2" "%[a-z0-9]@%s" (^) = "string1string2" + && sscanf "string1@%string2" "%[a-z0-9]%@%%%s" (^) = "string1string2" ;; test (test58 ()) ;; + +(* +let test59 () = +;; + +test (test59 ()) +;; *) (* To be continued ... diff --git a/testsuite/tests/lib-scanf/tscanf.reference b/testsuite/tests/lib-scanf/tscanf.reference index edeff6725..3c9fa4420 100644 --- a/testsuite/tests/lib-scanf/tscanf.reference +++ b/testsuite/tests/lib-scanf/tscanf.reference @@ -1,2 +1,2 @@ -0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 +0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 All tests succeeded. diff --git a/tools/ocamldep.ml b/tools/ocamldep.ml index 8839d68f1..36cb2cfef 100644 --- a/tools/ocamldep.ml +++ b/tools/ocamldep.ml @@ -12,8 +12,6 @@ (* $Id$ *) -open Format -open Location open Longident open Parsetree @@ -52,14 +50,14 @@ let add_to_load_path dir = let contents = Sys.readdir dir in load_path := !load_path @ [dir, contents] with Sys_error msg -> - fprintf Format.err_formatter "@[Bad -I option: %s@]@." msg; + Format.fprintf Format.err_formatter "@[Bad -I option: %s@]@." msg; error_occurred := true let add_to_synonym_list synonyms suffix = if (String.length suffix) > 1 && suffix.[0] = '.' then synonyms := suffix :: !synonyms else begin - fprintf Format.err_formatter "@[Bad suffix: '%s'@]@." suffix; + Format.fprintf Format.err_formatter "@[Bad suffix: '%s'@]@." suffix; error_occurred := true end @@ -229,6 +227,7 @@ let parse_use_file ic = else begin seek_in ic 0; let lb = Lexing.from_channel ic in + Location.init lb !Location.input_name; Parse.use_file lb end @@ -239,6 +238,7 @@ let parse_interface ic = else begin seek_in ic 0; let lb = Lexing.from_channel ic in + Location.init lb !Location.input_name; Parse.interface lb end @@ -314,15 +314,15 @@ let file_dependencies_as kind source_file = with x -> let report_err = function | Lexer.Error(err, range) -> - fprintf Format.err_formatter "@[%a%a@]@." + Format.fprintf Format.err_formatter "@[%a%a@]@." Location.print_error range Lexer.report_error err | Syntaxerr.Error err -> - fprintf Format.err_formatter "@[%a@]@." + Format.fprintf Format.err_formatter "@[%a@]@." Syntaxerr.report_error err | Sys_error msg -> - fprintf Format.err_formatter "@[I/O error:@ %s@]@." msg + Format.fprintf Format.err_formatter "@[I/O error:@ %s@]@." msg | Preprocessing_error -> - fprintf Format.err_formatter "@[Preprocessing error on file %s@]@." + Format.fprintf Format.err_formatter "@[Preprocessing error on file %s@]@." source_file | x -> raise x in error_occurred := true; @@ -393,16 +393,16 @@ let sort_files_by_dependencies files = done; if !worklist <> [] then begin - fprintf Format.err_formatter + Format.fprintf Format.err_formatter "@[Warning: cycle in dependencies. End of list is not sorted.@]@."; Hashtbl.iter (fun _ (file, deps) -> - fprintf Format.err_formatter "\t@[%s: " file; + Format.fprintf Format.err_formatter "\t@[%s: " file; List.iter (fun (modname, kind) -> - fprintf Format.err_formatter "%s.%s " modname + Format.fprintf Format.err_formatter "%s.%s " modname (if kind=ML then "ml" else "mli"); ) !deps; - fprintf Format.err_formatter "@]@."; - Printf.printf "%s@ " file) h; + Format.fprintf Format.err_formatter "@]@."; + Printf.printf "%s " file) h; end; Printf.printf "\n%!"; () @@ -413,12 +413,12 @@ let sort_files_by_dependencies files = let usage = "Usage: ocamldep [options] <source files>\nOptions are:" let print_version () = - printf "ocamldep, version %s@." Sys.ocaml_version; + Format.printf "ocamldep, version %s@." Sys.ocaml_version; exit 0; ;; let print_version_num () = - printf "%s@." Sys.ocaml_version; + Format.printf "%s@." Sys.ocaml_version; exit 0; ;; diff --git a/typing/ctype.ml b/typing/ctype.ml index f5371d387..478143c85 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -2134,7 +2134,7 @@ and unify3 env t1 t1' t2 t2' = | (Tvar _, _) -> occur !env t1 t2'; occur_univar !env t2; - link_type t1' t2; + link_type t1' t2; | (_, Tvar _) -> occur !env t2 t1'; occur_univar !env t1; @@ -2171,19 +2171,19 @@ and unify3 env t1 t1' t2 t2' = | (Tconstr ((Path.Pident p) as path,[],_), Tconstr ((Path.Pident p') as path',[],_)) when is_abstract_newtype !env path && is_abstract_newtype !env path' - && !generate_equations -> - let source,destination = + && !generate_equations -> + let source,destination = if find_newtype_level !env path > find_newtype_level !env path' then p,t2' else p',t1' in add_gadt_equation env source destination | (Tconstr ((Path.Pident p) as path,[],_), _) - when is_abstract_newtype !env path && !generate_equations -> + when is_abstract_newtype !env path && !generate_equations -> reify env t2'; local_non_recursive_abbrev !env (Path.Pident p) t2'; add_gadt_equation env p t2' | (_, Tconstr ((Path.Pident p) as path,[],_)) - when is_abstract_newtype !env path && !generate_equations -> + when is_abstract_newtype !env path && !generate_equations -> reify env t1' ; local_non_recursive_abbrev !env (Path.Pident p) t1'; add_gadt_equation env p t1' @@ -2197,7 +2197,7 @@ and unify3 env t1 t1' t2 t2' = (* XXX One should do some kind of unification... *) begin match (repr t2').desc with Tobject (_, {contents = Some (_, va::_)}) when - (match (repr va).desc with + (match (repr va).desc with Tvar _|Tunivar _|Tnil -> true | _ -> false) -> () | Tobject (_, nm2) -> set_name nm2 !nm1 | _ -> () |