diff options
| -rw-r--r-- | byterun/main.c | 4 | ||||
| -rw-r--r-- | driver/compile.ml | 3 | ||||
| -rw-r--r-- | driver/main.ml | 3 | ||||
| -rw-r--r-- | driver/optcompile.ml | 3 | ||||
| -rw-r--r-- | driver/optmain.ml | 3 | ||||
| -rw-r--r-- | toplevel/topdirs.ml | 12 | ||||
| -rw-r--r-- | toplevel/toploop.ml | 22 | ||||
| -rw-r--r-- | toplevel/toploop.mli | 5 | ||||
| -rw-r--r-- | toplevel/topmain.ml | 2 | ||||
| -rw-r--r-- | typing/includemod.ml | 20 | ||||
| -rw-r--r-- | typing/includemod.mli | 2 | ||||
| -rw-r--r-- | typing/printtyp.ml | 2 | ||||
| -rw-r--r-- | typing/typecore.ml | 15 | ||||
| -rw-r--r-- | typing/typecore.mli | 1 | ||||
| -rw-r--r-- | typing/typemod.ml | 21 | ||||
| -rw-r--r-- | typing/typemod.mli | 3 |
16 files changed, 78 insertions, 43 deletions
diff --git a/byterun/main.c b/byterun/main.c index 1f8b830d69..610e327e03 100644 --- a/byterun/main.c +++ b/byterun/main.c @@ -162,10 +162,6 @@ int main(argc, argv) case 'v': verbose_init = 1; break; - case 'V': - fprintf(stderr, "The Caml 1999 runtime system, version %s\n", - "1"); - exit(0); default: fatal_error_arg("Unknown option %s.\n", argv[i]); } diff --git a/driver/compile.ml b/driver/compile.ml index 0cf5b3ef40..541a024285 100644 --- a/driver/compile.ml +++ b/driver/compile.ml @@ -81,9 +81,10 @@ let implementation sourcefile = try find_in_path !load_path (prefixname ^ ".cmi") with Not_found -> prefixname ^ ".cmi" in let (dclsig, crc) = Env.read_signature modulename intf_file in - (Includemod.signatures Env.initial sg dclsig, crc) + (Includemod.compunit sourcefile sg intf_file dclsig, crc) end else begin let crc = Env.save_signature sg modulename (prefixname ^ ".cmi") in + Typemod.check_nongen_schemes str; (Tcoerce_none, crc) end in Emitcode.to_file oc modulename crc diff --git a/driver/main.ml b/driver/main.ml index fd2858ab67..3561afa2b6 100644 --- a/driver/main.ml +++ b/driver/main.ml @@ -47,12 +47,11 @@ let main () = "-o", Arg.String(fun s -> exec_name := s; archive_name := s); "-i", Arg.Unit(fun () -> print_types := true); "-a", Arg.Unit(fun () -> make_archive := true); - "-fast", Arg.Unit(fun () -> fast := true); + "-unsafe", Arg.Unit(fun () -> fast := true); "-nopervasives", Arg.Unit(fun () -> nopervasives := true); "-custom", Arg.Unit(fun () -> custom_runtime := true); "-ccopt", Arg.String(fun s -> ccopts := s :: !ccopts); "-cclib", Arg.String(fun s -> ccobjs := ("-l" ^ s) :: !ccobjs); - "-l", Arg.String(fun s -> ccobjs := s :: !ccobjs); "-linkall", Arg.Unit(fun s -> link_everything := true); "-dlambda", Arg.Unit(fun () -> dump_lambda := true); "-dinstr", Arg.Unit(fun () -> dump_instr := true); diff --git a/driver/optcompile.ml b/driver/optcompile.ml index 69788b372b..940ce5d97b 100644 --- a/driver/optcompile.ml +++ b/driver/optcompile.ml @@ -79,9 +79,10 @@ let implementation sourcefile = try find_in_path !load_path (prefixname ^ ".cmi") with Not_found -> prefixname ^ ".cmi" in let (dclsig, crc) = Env.read_signature modulename intf_file in - (Includemod.signatures Env.initial sg dclsig, crc) + (Includemod.compunit sourcefile sg intf_file dclsig, crc) end else begin let crc = Env.save_signature sg modulename (prefixname ^ ".cmi") in + Typemod.check_nongen_schemes str; (Tcoerce_none, crc) end in Compilenv.reset modulename crc; diff --git a/driver/optmain.ml b/driver/optmain.ml index 0e9b453c5e..380fd84bbb 100644 --- a/driver/optmain.ml +++ b/driver/optmain.ml @@ -48,12 +48,11 @@ let main () = "-o", Arg.String(fun s -> exec_name := s; archive_name := s); "-i", Arg.Unit(fun () -> print_types := true); "-a", Arg.Unit(fun () -> make_archive := true); - "-fast", Arg.Unit(fun () -> fast := true); + "-unsafe", Arg.Unit(fun () -> fast := true); "-compact", Arg.Unit(fun () -> optimize_for_speed := false); "-nopervasives", Arg.Unit(fun () -> nopervasives := true); "-ccopt", Arg.String(fun s -> ccopts := s :: !ccopts); "-cclib", Arg.String(fun s -> ccobjs := ("-l" ^ s) :: !ccobjs); - "-l", Arg.String(fun s -> ccobjs := s :: !ccobjs); "-dlambda", Arg.Unit(fun () -> dump_lambda := true); "-dcmm", Arg.Unit(fun () -> dump_cmm := true); "-dsel", Arg.Unit(fun () -> dump_selection := true); diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml index bfdefecd1a..7b34aa5474 100644 --- a/toplevel/topdirs.ml +++ b/toplevel/topdirs.ml @@ -111,10 +111,14 @@ let dir_use name = let lb = Lexing.from_channel ic in protect Location.input_name filename (fun () -> try - while true do - execute_phrase (Parse.toplevel_phrase lb) - done - with End_of_file -> ()); + while execute_phrase (Parse.toplevel_phrase lb) + do () done + with + End_of_file -> () + | Sys.Break -> + print_string "Interrupted."; print_newline() + | x -> + Errors.report_error x); close_in ic with Not_found -> print_string "Cannot find file "; print_string name; print_newline() diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml index 610e6b420e..c4cf14bc87 100644 --- a/toplevel/toploop.ml +++ b/toplevel/toploop.ml @@ -130,23 +130,27 @@ let execute_phrase phr = close_box(); print_flush() end; - toplevel_env := newenv + toplevel_env := newenv; + true | Exception exn -> - print_exception_outcome exn + print_exception_outcome exn; + false end | Ptop_dir(dir_name, dir_arg) -> try match (Hashtbl.find directive_table dir_name, dir_arg) with - (Directive_none f, Pdir_none) -> f () - | (Directive_string f, Pdir_string s) -> f s - | (Directive_int f, Pdir_int n) -> f n - | (Directive_ident f, Pdir_ident lid) -> f lid + (Directive_none f, Pdir_none) -> f (); true + | (Directive_string f, Pdir_string s) -> f s; true + | (Directive_int f, Pdir_int n) -> f n; true + | (Directive_ident f, Pdir_ident lid) -> f lid; true | (_, _) -> print_string "Wrong type of argument for directive `"; - print_string dir_name; print_string "'"; print_newline() + print_string dir_name; print_string "'"; print_newline(); + false with Not_found -> print_string "Unknown directive `"; print_string dir_name; - print_string "'"; print_newline() + print_string "'"; print_newline(); + false (* Reading function -- should use input_scan_line directly... *) @@ -185,7 +189,7 @@ let loop() = while true do try empty_lexbuf lb; - execute_phrase (Parse.toplevel_phrase lb) + execute_phrase (Parse.toplevel_phrase lb); () with End_of_file -> print_newline(); exit 0 diff --git a/toplevel/toploop.mli b/toplevel/toploop.mli index a3b32cad49..554591493c 100644 --- a/toplevel/toploop.mli +++ b/toplevel/toploop.mli @@ -25,8 +25,9 @@ type directive_fun = val directive_table: (string, directive_fun) Hashtbl.t (* Table of known directives, with their execution function *) -val execute_phrase: Parsetree.toplevel_phrase -> unit - (* Execute the given toplevel phrase *) +val execute_phrase: Parsetree.toplevel_phrase -> bool + (* Execute the given toplevel phrase. Return [true] if the + phrase executed with no errors and [false] otherwise. *) val print_exception_outcome: exn -> unit (* Print an exception resulting from the evaluation of user code. *) val toplevel_env: Env.t ref diff --git a/toplevel/topmain.ml b/toplevel/topmain.ml index be09f498be..80311169fd 100644 --- a/toplevel/topmain.ml +++ b/toplevel/topmain.ml @@ -16,7 +16,7 @@ open Clflags let main () = Arg.parse ["-I", Arg.String(fun dir -> include_dirs := dir :: !include_dirs); - "-fast", Arg.Unit(fun () -> fast := true); + "-unsafe", Arg.Unit(fun () -> fast := true); "-dlambda", Arg.Unit(fun () -> dump_lambda := true); "-dinstr", Arg.Unit(fun () -> dump_instr := true)] (fun name -> raise(Arg.Bad("don't know what to do with " ^ name))); diff --git a/typing/includemod.ml b/typing/includemod.ml index 61c7597b4b..dcec80c608 100644 --- a/typing/includemod.ml +++ b/typing/includemod.ml @@ -26,6 +26,7 @@ type error = Ident.t * exception_declaration * exception_declaration | Module_types of module_type * module_type | Modtype_infos of Ident.t * modtype_declaration * modtype_declaration + | Interface_mismatch of string * string exception Error of error list @@ -221,6 +222,15 @@ let check_modtype_inclusion env mty1 mty2 = let _ = Env.check_modtype_inclusion := check_modtype_inclusion +(* Check that an implementation of a compilation unit meets its + interface. *) + +let compunit impl_name impl_sig intf_name intf_sig = + try + signatures Env.initial impl_sig intf_sig + with Error reasons -> + raise(Error(Interface_mismatch(impl_name, intf_name) :: reasons)) + (* Error report *) open Format @@ -228,7 +238,8 @@ open Printtyp let include_err = function Missing_field id -> - print_string "Missing field "; ident id + print_string "The field `"; ident id; + print_string "' is required but not provided" | Value_descriptions(id, d1, d2) -> open_hvbox 2; print_string "Values do not match:"; print_space(); @@ -269,6 +280,13 @@ let include_err = function print_string "is not included in"; print_space(); modtype_declaration id d2; close_box() + | Interface_mismatch(impl_name, intf_name) -> + open_hovbox 0; + print_string "The implementation "; print_string impl_name; + print_space(); print_string "does not match the interface "; + print_string intf_name; + print_string ":"; + close_box() let report_error errlist = match List.rev errlist with diff --git a/typing/includemod.mli b/typing/includemod.mli index b5589ca5db..52b97ff0ac 100644 --- a/typing/includemod.mli +++ b/typing/includemod.mli @@ -17,6 +17,7 @@ open Typedtree val modtypes: Env.t -> module_type -> module_type -> module_coercion val signatures: Env.t -> signature -> signature -> module_coercion +val compunit: string -> signature -> string -> signature -> module_coercion type error = Missing_field of Ident.t @@ -26,6 +27,7 @@ type error = Ident.t * exception_declaration * exception_declaration | Module_types of module_type * module_type | Modtype_infos of Ident.t * modtype_declaration * modtype_declaration + | Interface_mismatch of string * string exception Error of error list diff --git a/typing/printtyp.ml b/typing/printtyp.ml index 2fc842f352..93ead52ea2 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -71,7 +71,7 @@ let rec typexp sch prio = function Tvar {tvar_link = Some ty} -> typexp sch prio ty | Tvar {tvar_link = None; tvar_level = lvl} as v -> - if not sch or lvl = -1 (* generic *) + if (not sch) or lvl = -1 (* generic *) then print_string "'" else print_string "'_"; print_string(name_of_var v) diff --git a/typing/typecore.ml b/typing/typecore.ml index e403c54dfa..ac5d41fc82 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -33,7 +33,6 @@ type error = | Label_multiply_defined of Longident.t | Label_missing | Label_not_mutable of Longident.t - | Non_generalizable of type_expr | Bad_format_letter of char exception Error of Location.t * error @@ -525,14 +524,7 @@ and type_let env rec_flag spat_sexp_list = let type_binding env rec_flag spat_sexp_list = Typetexp.reset_type_variables(); - let (pat_exp_list, new_env as result) = - type_let env rec_flag spat_sexp_list in - List.iter - (fun (pat, exp) -> - if not (closed_schema exp.exp_type) then - raise(Error(exp.exp_loc, Non_generalizable exp.exp_type))) - pat_exp_list; - result + type_let env rec_flag spat_sexp_list (* Typing of toplevel expressions *) @@ -605,10 +597,5 @@ let report_error = function | Label_not_mutable lid -> print_string "The label "; longident lid; print_string " is not mutable" - | Non_generalizable typ -> - open_hovbox 0; - print_string "The type of this expression,"; print_space(); - type_scheme typ; print_string ","; print_space(); - print_string "contains type variables that cannot be generalized" | Bad_format_letter c -> print_string "Bad format letter `%"; print_char c; print_string "'" diff --git a/typing/typecore.mli b/typing/typecore.mli index 2b495a028d..cd00679b82 100644 --- a/typing/typecore.mli +++ b/typing/typecore.mli @@ -37,7 +37,6 @@ type error = | Label_multiply_defined of Longident.t | Label_missing | Label_not_mutable of Longident.t - | Non_generalizable of type_expr | Bad_format_letter of char exception Error of Location.t * error diff --git a/typing/typemod.ml b/typing/typemod.ml index f743bee3a2..3b6a5b1e64 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -30,6 +30,7 @@ type error = | With_not_abstract of string | With_arity_mismatch of string | Repeated_name of string * string + | Non_generalizable of type_expr exception Error of Location.t * error @@ -189,6 +190,20 @@ let check_unique_names sg = | Pstr_open(lid, loc) -> () in List.iter check_item sg +(* Check that all core type schemes in a structure are closed *) + +let check_nongen_schemes str = + List.iter + (function + Tstr_value(rec_flag, pat_exp_list) -> + List.iter + (fun (pat, exp) -> + if not (Ctype.closed_schema exp.exp_type) then + raise(Error(exp.exp_loc, Non_generalizable exp.exp_type))) + pat_exp_list + | _ -> ()) (* Sub-structures have been checked before *) + str + (* Type a module value expression *) let rec type_module env smod = @@ -200,6 +215,7 @@ let rec type_module env smod = mod_loc = smod.pmod_loc } | Pmod_structure sstr -> let (str, sg, _) = type_structure env sstr in + check_nongen_schemes str; { mod_desc = Tmod_structure str; mod_type = Tmty_signature sg; mod_loc = smod.pmod_loc } @@ -357,3 +373,8 @@ let report_error = function print_space(); print_string "Names must be unique in a given structure."; close_box() + | Non_generalizable typ -> + open_hovbox 0; + print_string "The type of this expression,"; print_space(); + type_scheme typ; print_string ","; print_space(); + print_string "contains type variables that cannot be generalized" diff --git a/typing/typemod.mli b/typing/typemod.mli index 1e925546da..30c60930ea 100644 --- a/typing/typemod.mli +++ b/typing/typemod.mli @@ -19,6 +19,8 @@ val type_structure: Env.t -> Parsetree.structure -> structure * signature * Env.t val transl_signature: Env.t -> Parsetree.signature -> signature +val check_nongen_schemes: + structure -> unit type error = Unbound_module of Longident.t @@ -31,6 +33,7 @@ type error = | With_not_abstract of string | With_arity_mismatch of string | Repeated_name of string * string + | Non_generalizable of type_expr exception Error of Location.t * error |