diff options
| -rwxr-xr-x | boot/ocamlc | bin | 1527509 -> 1526840 bytes | |||
| -rwxr-xr-x | boot/ocamldep | bin | 420745 -> 420492 bytes | |||
| -rwxr-xr-x | boot/ocamllex | bin | 184025 -> 183922 bytes | |||
| -rw-r--r-- | bytecomp/lambda.ml | 41 | ||||
| -rw-r--r-- | bytecomp/lambda.mli | 9 | ||||
| -rw-r--r-- | bytecomp/printlambda.ml | 8 | ||||
| -rw-r--r-- | bytecomp/translcore.ml | 23 | ||||
| -rw-r--r-- | otherlibs/threads/pervasives.ml | 14 | ||||
| -rw-r--r-- | stdlib/pervasives.ml | 14 | ||||
| -rw-r--r-- | stdlib/pervasives.mli | 13 | ||||
| -rw-r--r-- | typing/typedecl.ml | 4 |
11 files changed, 118 insertions, 8 deletions
diff --git a/boot/ocamlc b/boot/ocamlc Binary files differindex f118c0c0b..6939a4772 100755 --- a/boot/ocamlc +++ b/boot/ocamlc diff --git a/boot/ocamldep b/boot/ocamldep Binary files differindex e0948caf0..01070f0a3 100755 --- a/boot/ocamldep +++ b/boot/ocamldep diff --git a/boot/ocamllex b/boot/ocamllex Binary files differindex 06909bd65..deee0c50a 100755 --- a/boot/ocamllex +++ b/boot/ocamllex diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml index a5cb79475..f68588090 100644 --- a/bytecomp/lambda.ml +++ b/bytecomp/lambda.ml @@ -21,11 +21,19 @@ type compile_time_constant = | Ostype_win32 | Ostype_cygwin +type loc_kind = + | Loc_FILE + | Loc_LINE + | Loc_MODULE + | Loc_LOC + | Loc_POS + type primitive = Pidentity | Pignore | Prevapply of Location.t | Pdirapply of Location.t + | Ploc of loc_kind (* Globals *) | Pgetglobal of Ident.t | Psetglobal of Ident.t @@ -203,7 +211,7 @@ let lambda_unit = Lconst const_unit exception Not_simple -let max_raw = 32 +let max_raw = 32 let make_key e = let count = ref 0 @@ -247,7 +255,7 @@ let make_key e = | Ltrywith (e1,x,e2) -> Ltrywith (tr_rec env e1,x,tr_rec env e2) | Lifthenelse (cond,ifso,ifnot) -> - Lifthenelse (tr_rec env cond,tr_rec env ifso,tr_rec env ifnot) + Lifthenelse (tr_rec env cond,tr_rec env ifso,tr_rec env ifnot) | Lsequence (e1,e2) -> Lsequence (tr_rec env e1,tr_rec env e2) | Lassign (x,e) -> @@ -258,7 +266,7 @@ let make_key e = Levent (tr_rec env e,evt) | Lifused (id,e) -> Lifused (id,tr_rec env e) | Lletrec _|Lfunction _ - | Lfor _ | Lwhile _ -> + | Lfor _ | Lwhile _ -> raise Not_simple and tr_recs env es = List.map (tr_rec env) es @@ -317,7 +325,7 @@ let iter f = function f arg; List.iter (fun (key, case) -> f case) sw.sw_consts; List.iter (fun (key, case) -> f case) sw.sw_blocks; - iter_opt f sw.sw_failaction + iter_opt f sw.sw_failaction | Lstringswitch (arg,cases,default) -> f arg ; List.iter (fun (_,act) -> f act) cases ; @@ -422,7 +430,7 @@ let rec transl_normal_path = function (* Translation of value identifiers *) let transl_path ?(loc=Location.none) env path = - transl_normal_path (Env.normalize_path (Some loc) env path) + transl_normal_path (Env.normalize_path (Some loc) env path) (* Compile a sequence of expressions *) @@ -498,3 +506,26 @@ let raise_kind = function | Raise_regular -> "raise" | Raise_reraise -> "reraise" | Raise_notrace -> "raise_notrace" + +let lam_of_loc kind loc = + let loc_start = loc.Location.loc_start in + let (file, lnum, cnum) = Location.get_pos_info loc_start in + let enum = loc.Location.loc_end.Lexing.pos_cnum - + loc_start.Lexing.pos_cnum + cnum in + match kind with + | Loc_POS -> + Lconst (Const_block (0, [ + Const_immstring file; + Const_base (Const_int lnum); + Const_base (Const_int cnum); + Const_base (Const_int enum); + ])) + | Loc_FILE -> Lconst (Const_immstring file) + | Loc_MODULE -> Lconst (Const_immstring + (String.capitalize + (Filename.chop_extension (Filename.basename file)))) + | Loc_LOC -> + let loc = Printf.sprintf "File %S, line %d, characters %d-%d" + file lnum cnum enum in + Lconst (Const_immstring loc) + | Loc_LINE -> Lconst (Const_base (Const_int lnum)) diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli index fddace659..8acb4cd03 100644 --- a/bytecomp/lambda.mli +++ b/bytecomp/lambda.mli @@ -21,11 +21,19 @@ type compile_time_constant = | Ostype_win32 | Ostype_cygwin +type loc_kind = + | Loc_FILE + | Loc_LINE + | Loc_MODULE + | Loc_LOC + | Loc_POS + type primitive = Pidentity | Pignore | Prevapply of Location.t | Pdirapply of Location.t + | Ploc of loc_kind (* Globals *) | Pgetglobal of Ident.t | Psetglobal of Ident.t @@ -245,3 +253,4 @@ val is_guarded: lambda -> bool val patch_guarded : lambda -> lambda -> lambda val raise_kind: raise_kind -> string +val lam_of_loc : loc_kind -> Location.t -> lambda diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml index a2b2d5c5a..fd90caf59 100644 --- a/bytecomp/printlambda.ml +++ b/bytecomp/printlambda.ml @@ -87,11 +87,19 @@ let record_rep ppf r = | Record_float -> fprintf ppf "float" ;; +let string_of_loc_kind = function + | Loc_FILE -> "loc_FILE" + | Loc_LINE -> "loc_LINE" + | Loc_MODULE -> "loc_MODULE" + | Loc_POS -> "loc_POS" + | Loc_LOC -> "loc_LOC" + let primitive ppf = function | Pidentity -> fprintf ppf "id" | Pignore -> fprintf ppf "ignore" | Prevapply _ -> fprintf ppf "revapply" | Pdirapply _ -> fprintf ppf "dirapply" + | Ploc kind -> fprintf ppf "%s" (string_of_loc_kind kind) | Pgetglobal id -> fprintf ppf "global %a" Ident.print id | Psetglobal id -> fprintf ppf "setglobal %a" Ident.print id | Pmakeblock(tag, Immutable) -> fprintf ppf "makeblock %i" tag diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index 526c0f576..904ef1a71 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -325,6 +325,11 @@ let find_primitive loc prim_name = match prim_name with "%revapply" -> Prevapply loc | "%apply" -> Pdirapply loc + | "%loc_LOC" -> Ploc Loc_LOC + | "%loc_FILE" -> Ploc Loc_FILE + | "%loc_LINE" -> Ploc Loc_LINE + | "%loc_POS" -> Ploc Loc_POS + | "%loc_MODULE" -> Ploc Loc_MODULE | name -> Hashtbl.find primitives_table name let transl_prim loc prim args = @@ -404,10 +409,20 @@ let transl_primitive loc p = with Not_found -> Pccall p in match prim with - Plazyforce -> + | Plazyforce -> let parm = Ident.create "prim" in Lfunction(Curried, [parm], Matching.inline_lazy_force (Lvar parm) Location.none) + | Ploc kind -> + let lam = lam_of_loc kind loc in + begin match p.prim_arity with + | 0 -> lam + | 1 -> (* TODO: we should issue a warning ? *) + let param = Ident.create "prim" in + Lfunction(Curried, [param], + Lprim(Pmakeblock(0, Immutable), [lam; Lvar param])) + | _ -> assert false + end | _ -> let rec make_params n = if n <= 0 then [] else Ident.create "prim" :: make_params (n-1) in @@ -694,6 +709,12 @@ and transl_exp0 e = k in wrap0 (Lprim(Praise k, [event_after arg1 targ])) + | (Ploc kind, []) -> + lam_of_loc kind e.exp_loc + | (Ploc kind, [arg1]) -> + let lam = lam_of_loc kind arg1.exp_loc in + Lprim(Pmakeblock(0, Immutable), lam :: argl) + | (Ploc _, _) -> assert false | (_, _) -> begin match (prim, argl) with | (Plazyforce, [a]) -> diff --git a/otherlibs/threads/pervasives.ml b/otherlibs/threads/pervasives.ml index 402e01b87..7992c68d2 100644 --- a/otherlibs/threads/pervasives.ml +++ b/otherlibs/threads/pervasives.ml @@ -40,6 +40,20 @@ exception Exit external (|>) : 'a -> ('a -> 'b) -> 'b = "%revapply" external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply" +(* Debugging *) + +external __LOC__ : string = "%loc_LOC" +external __FILE__ : string = "%loc_FILE" +external __LINE__ : int = "%loc_LINE" +external __MODULE__ : string = "%loc_MODULE" +external __POS__ : string * int * int * int = "%loc_POS" + +external __LOC_OF__ : 'a -> string * 'a = "%loc_LOC" +external __FILE_OF__ : 'a -> string * 'a = "%loc_FILE" +external __LINE_OF__ : 'a -> int * 'a = "%loc_LINE" +external __MODULE_OF__ : 'a -> string * 'a = "%loc_MODULE" +external __POS_OF__ : 'a -> (string * int * int * int) * 'a = "%loc_POS" + (* Comparisons *) external (=) : 'a -> 'a -> bool = "%equal" diff --git a/stdlib/pervasives.ml b/stdlib/pervasives.ml index e4a07c3de..7c0f14298 100644 --- a/stdlib/pervasives.ml +++ b/stdlib/pervasives.ml @@ -37,6 +37,20 @@ exception Exit external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply" external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply" +(* Debugging *) + +external __LOC__ : string = "%loc_LOC" +external __FILE__ : string = "%loc_FILE" +external __LINE__ : int = "%loc_LINE" +external __MODULE__ : string = "%loc_MODULE" +external __POS__ : string * int * int * int = "%loc_POS" + +external __LOC_OF__ : 'a -> string * 'a = "%loc_LOC" +external __FILE_OF__ : 'a -> string * 'a = "%loc_FILE" +external __LINE_OF__ : 'a -> int * 'a = "%loc_LINE" +external __MODULE_OF__ : 'a -> string * 'a = "%loc_MODULE" +external __POS_OF__ : 'a -> (string * int * int * int) * 'a = "%loc_POS" + (* Comparisons *) external ( = ) : 'a -> 'a -> bool = "%equal" diff --git a/stdlib/pervasives.mli b/stdlib/pervasives.mli index 0a2e4af6a..1ee09984c 100644 --- a/stdlib/pervasives.mli +++ b/stdlib/pervasives.mli @@ -140,6 +140,19 @@ external ( || ) : bool -> bool -> bool = "%sequor" external ( or ) : bool -> bool -> bool = "%sequor" (** @deprecated {!Pervasives.( || )} should be used instead.*) +(** {6 Debugging} *) + +external __LOC__ : string = "%loc_LOC" +external __FILE__ : string = "%loc_FILE" +external __LINE__ : int = "%loc_LINE" +external __MODULE__ : string = "%loc_MODULE" +external __POS__ : string * int * int * int = "%loc_POS" + +external __LOC_OF__ : 'a -> string * 'a = "%loc_LOC" +external __FILE_OF__ : 'a -> string * 'a = "%loc_FILE" +external __LINE_OF__ : 'a -> int * 'a = "%loc_LINE" +external __MODULE_OF__ : 'a -> string * 'a = "%loc_MODULE" +external __POS_OF__ : 'a -> (string * int * int * int) * 'a = "%loc_POS" (** {6 Composition operators} *) diff --git a/typing/typedecl.ml b/typing/typedecl.ml index 41625af08..3f02d310c 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -1074,9 +1074,9 @@ let transl_value_decl env loc valdecl = val_attributes = valdecl.pval_attributes } | decl -> let arity = Ctype.arity ty in - if arity = 0 then - raise(Error(valdecl.pval_type.ptyp_loc, Null_arity_external)); let prim = Primitive.parse_declaration arity decl in + if arity = 0 && prim.prim_name.[0] <> '%' then + raise(Error(valdecl.pval_type.ptyp_loc, Null_arity_external)); if !Clflags.native_code && prim.prim_arity > 5 && prim.prim_native_name = "" |