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

ajout des annotations pour variables et appels terminaux 

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@8232 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Damien Doligez 2007-05-16 08:21:41 +00:00
parent 5dbc715029
commit 1dd68ccf50
40 changed files with 608 additions and 283 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

75
.depend
View File

@ -52,12 +52,13 @@ parsing/printast.cmx: parsing/parsetree.cmi parsing/longident.cmx \
parsing/location.cmx parsing/asttypes.cmi parsing/printast.cmi
parsing/syntaxerr.cmo: parsing/location.cmi parsing/syntaxerr.cmi
parsing/syntaxerr.cmx: parsing/location.cmx parsing/syntaxerr.cmi
typing/annot.cmi: parsing/location.cmi
typing/btype.cmi: typing/types.cmi typing/path.cmi parsing/asttypes.cmi
typing/ctype.cmi: typing/types.cmi typing/path.cmi typing/ident.cmi \
typing/env.cmi parsing/asttypes.cmi
typing/datarepr.cmi: typing/types.cmi typing/path.cmi parsing/asttypes.cmi
typing/env.cmi: typing/types.cmi typing/path.cmi parsing/longident.cmi \
typing/ident.cmi utils/consistbl.cmi
typing/ident.cmi utils/consistbl.cmi typing/annot.cmi
typing/includeclass.cmi: typing/types.cmi typing/typedtree.cmi typing/env.cmi \
typing/ctype.cmi
typing/includecore.cmi: typing/types.cmi typing/typedtree.cmi \
@ -74,14 +75,14 @@ typing/path.cmi: typing/ident.cmi
typing/predef.cmi: typing/types.cmi typing/path.cmi typing/ident.cmi
typing/printtyp.cmi: typing/types.cmi typing/path.cmi typing/outcometree.cmi \
parsing/longident.cmi typing/ident.cmi
typing/stypes.cmi: typing/typedtree.cmi parsing/location.cmi
typing/stypes.cmi: typing/typedtree.cmi parsing/location.cmi typing/annot.cmi
typing/subst.cmi: typing/types.cmi typing/path.cmi typing/ident.cmi
typing/typeclass.cmi: typing/types.cmi typing/typedtree.cmi \
parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
typing/ident.cmi typing/env.cmi typing/ctype.cmi parsing/asttypes.cmi
typing/typecore.cmi: typing/types.cmi typing/typedtree.cmi typing/path.cmi \
parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
typing/ident.cmi typing/env.cmi parsing/asttypes.cmi
typing/ident.cmi typing/env.cmi parsing/asttypes.cmi typing/annot.cmi
typing/typedecl.cmi: typing/types.cmi typing/path.cmi parsing/parsetree.cmi \
parsing/longident.cmi parsing/location.cmi typing/ident.cmi \
typing/env.cmi
@ -112,11 +113,13 @@ typing/datarepr.cmx: typing/types.cmx typing/predef.cmx utils/misc.cmx \
typing/env.cmo: typing/types.cmi utils/tbl.cmi typing/subst.cmi \
typing/predef.cmi typing/path.cmi utils/misc.cmi parsing/longident.cmi \
typing/ident.cmi typing/datarepr.cmi utils/consistbl.cmi utils/config.cmi \
utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi typing/env.cmi
utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi typing/annot.cmi \
typing/env.cmi
typing/env.cmx: typing/types.cmx utils/tbl.cmx typing/subst.cmx \
typing/predef.cmx typing/path.cmx utils/misc.cmx parsing/longident.cmx \
typing/ident.cmx typing/datarepr.cmx utils/consistbl.cmx utils/config.cmx \
utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi typing/env.cmi
utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi typing/annot.cmi \
typing/env.cmi
typing/ident.cmo: typing/ident.cmi
typing/ident.cmx: typing/ident.cmi
typing/includeclass.cmo: typing/types.cmi typing/printtyp.cmi \
@ -174,9 +177,9 @@ typing/printtyp.cmx: typing/types.cmx typing/primitive.cmx typing/predef.cmx \
utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \
typing/printtyp.cmi
typing/stypes.cmo: typing/typedtree.cmi typing/printtyp.cmi \
parsing/location.cmi utils/clflags.cmi typing/stypes.cmi
parsing/location.cmi utils/clflags.cmi typing/annot.cmi typing/stypes.cmi
typing/stypes.cmx: typing/typedtree.cmx typing/printtyp.cmx \
parsing/location.cmx utils/clflags.cmx typing/stypes.cmi
parsing/location.cmx utils/clflags.cmx typing/annot.cmi typing/stypes.cmi
typing/subst.cmo: typing/types.cmi utils/tbl.cmi typing/path.cmi \
utils/misc.cmi typing/ident.cmi typing/btype.cmi typing/subst.cmi
typing/subst.cmx: typing/types.cmx utils/tbl.cmx typing/path.cmx \
@ -203,14 +206,14 @@ typing/typecore.cmo: utils/warnings.cmi typing/typetexp.cmi typing/types.cmi \
parsing/parsetree.cmi typing/parmatch.cmi utils/misc.cmi \
parsing/longident.cmi parsing/location.cmi typing/ident.cmi \
typing/env.cmi typing/ctype.cmi utils/clflags.cmi typing/btype.cmi \
parsing/asttypes.cmi typing/typecore.cmi
parsing/asttypes.cmi typing/annot.cmi typing/typecore.cmi
typing/typecore.cmx: utils/warnings.cmx typing/typetexp.cmx typing/types.cmx \
typing/typedtree.cmx typing/stypes.cmx typing/printtyp.cmx \
typing/primitive.cmx typing/predef.cmx typing/path.cmx \
parsing/parsetree.cmi typing/parmatch.cmx utils/misc.cmx \
parsing/longident.cmx parsing/location.cmx typing/ident.cmx \
typing/env.cmx typing/ctype.cmx utils/clflags.cmx typing/btype.cmx \
parsing/asttypes.cmi typing/typecore.cmi
parsing/asttypes.cmi typing/annot.cmi typing/typecore.cmi
typing/typedecl.cmo: typing/typetexp.cmi typing/types.cmi \
typing/typedtree.cmi typing/subst.cmi typing/printtyp.cmi \
typing/primitive.cmi typing/predef.cmi typing/path.cmi \
@ -237,7 +240,7 @@ typing/typemod.cmo: typing/types.cmi typing/typedtree.cmi typing/typedecl.cmi \
parsing/parsetree.cmi typing/mtype.cmi utils/misc.cmi \
parsing/longident.cmi parsing/location.cmi typing/includemod.cmi \
typing/ident.cmi typing/env.cmi typing/ctype.cmi utils/config.cmi \
utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \
utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi typing/annot.cmi \
typing/typemod.cmi
typing/typemod.cmx: typing/types.cmx typing/typedtree.cmx typing/typedecl.cmx \
typing/typecore.cmx typing/typeclass.cmx typing/subst.cmx \
@ -245,7 +248,7 @@ typing/typemod.cmx: typing/types.cmx typing/typedtree.cmx typing/typedecl.cmx \
parsing/parsetree.cmi typing/mtype.cmx utils/misc.cmx \
parsing/longident.cmx parsing/location.cmx typing/includemod.cmx \
typing/ident.cmx typing/env.cmx typing/ctype.cmx utils/config.cmx \
utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \
utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi typing/annot.cmi \
typing/typemod.cmi
typing/types.cmo: typing/primitive.cmi typing/path.cmi utils/misc.cmi \
typing/ident.cmi parsing/asttypes.cmi typing/types.cmi
@ -290,14 +293,14 @@ bytecomp/translmod.cmi: typing/typedtree.cmi parsing/location.cmi \
bytecomp/translobj.cmi: bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi
bytecomp/typeopt.cmi: typing/typedtree.cmi typing/path.cmi \
bytecomp/lambda.cmi
bytecomp/bytegen.cmo: typing/types.cmi bytecomp/switch.cmi \
bytecomp/bytegen.cmo: typing/types.cmi bytecomp/switch.cmi typing/stypes.cmi \
typing/primitive.cmi utils/misc.cmi bytecomp/lambda.cmi \
bytecomp/instruct.cmi typing/ident.cmi utils/config.cmi \
parsing/asttypes.cmi bytecomp/bytegen.cmi
bytecomp/bytegen.cmx: typing/types.cmx bytecomp/switch.cmx \
parsing/asttypes.cmi typing/annot.cmi bytecomp/bytegen.cmi
bytecomp/bytegen.cmx: typing/types.cmx bytecomp/switch.cmx typing/stypes.cmx \
typing/primitive.cmx utils/misc.cmx bytecomp/lambda.cmx \
bytecomp/instruct.cmx typing/ident.cmx utils/config.cmx \
parsing/asttypes.cmi bytecomp/bytegen.cmi
parsing/asttypes.cmi typing/annot.cmi bytecomp/bytegen.cmi
bytecomp/bytelibrarian.cmo: utils/misc.cmi utils/config.cmi \
bytecomp/cmo_format.cmi utils/clflags.cmi bytecomp/bytelink.cmi \
bytecomp/bytelibrarian.cmi
@ -622,10 +625,8 @@ asmcomp/proc.cmx: asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \
asmcomp/arch.cmx asmcomp/proc.cmi
asmcomp/reg.cmo: asmcomp/cmm.cmi asmcomp/reg.cmi
asmcomp/reg.cmx: asmcomp/cmm.cmx asmcomp/reg.cmi
asmcomp/reload.cmo: asmcomp/reloadgen.cmi asmcomp/reg.cmi asmcomp/mach.cmi \
asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/reload.cmi
asmcomp/reload.cmx: asmcomp/reloadgen.cmx asmcomp/reg.cmx asmcomp/mach.cmx \
asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/reload.cmi
asmcomp/reload.cmo: asmcomp/reloadgen.cmi asmcomp/reload.cmi
asmcomp/reload.cmx: asmcomp/reloadgen.cmx asmcomp/reload.cmi
asmcomp/reloadgen.cmo: asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \
asmcomp/reloadgen.cmi
asmcomp/reloadgen.cmx: asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \
@ -636,20 +637,20 @@ asmcomp/schedgen.cmo: asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \
asmcomp/schedgen.cmx: asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \
asmcomp/linearize.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \
asmcomp/schedgen.cmi
asmcomp/scheduling.cmo: asmcomp/schedgen.cmi asmcomp/scheduling.cmi
asmcomp/scheduling.cmx: asmcomp/schedgen.cmx asmcomp/scheduling.cmi
asmcomp/scheduling.cmo: asmcomp/schedgen.cmi asmcomp/mach.cmi \
asmcomp/arch.cmo asmcomp/scheduling.cmi
asmcomp/scheduling.cmx: asmcomp/schedgen.cmx asmcomp/mach.cmx \
asmcomp/arch.cmx asmcomp/scheduling.cmi
asmcomp/selectgen.cmo: utils/tbl.cmi asmcomp/reg.cmi asmcomp/proc.cmi \
utils/misc.cmi asmcomp/mach.cmi typing/ident.cmi asmcomp/debuginfo.cmi \
asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/selectgen.cmi
asmcomp/selectgen.cmx: utils/tbl.cmx asmcomp/reg.cmx asmcomp/proc.cmx \
utils/misc.cmx asmcomp/mach.cmx typing/ident.cmx asmcomp/debuginfo.cmx \
asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/selectgen.cmi
asmcomp/selection.cmo: asmcomp/selectgen.cmi asmcomp/reg.cmi asmcomp/proc.cmi \
utils/misc.cmi asmcomp/mach.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \
asmcomp/arch.cmo asmcomp/selection.cmi
asmcomp/selection.cmx: asmcomp/selectgen.cmx asmcomp/reg.cmx asmcomp/proc.cmx \
utils/misc.cmx asmcomp/mach.cmx asmcomp/debuginfo.cmx asmcomp/cmm.cmx \
asmcomp/arch.cmx asmcomp/selection.cmi
asmcomp/selection.cmo: asmcomp/selectgen.cmi asmcomp/reg.cmi utils/misc.cmi \
asmcomp/mach.cmi asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/selection.cmi
asmcomp/selection.cmx: asmcomp/selectgen.cmx asmcomp/reg.cmx utils/misc.cmx \
asmcomp/mach.cmx asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/selection.cmi
asmcomp/spill.cmo: asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \
asmcomp/mach.cmi asmcomp/spill.cmi
asmcomp/spill.cmx: asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \
@ -662,18 +663,18 @@ driver/compile.cmi: typing/env.cmi
driver/optcompile.cmi: typing/env.cmi
driver/compile.cmo: utils/warnings.cmi typing/unused_var.cmi \
typing/typemod.cmi typing/typedtree.cmi bytecomp/translmod.cmi \
bytecomp/simplif.cmi typing/printtyp.cmi bytecomp/printlambda.cmi \
bytecomp/printinstr.cmi parsing/printast.cmi driver/pparse.cmi \
parsing/parse.cmi utils/misc.cmi typing/ident.cmi typing/env.cmi \
bytecomp/emitcode.cmi utils/config.cmi utils/clflags.cmi utils/ccomp.cmi \
bytecomp/bytegen.cmi driver/compile.cmi
typing/stypes.cmi bytecomp/simplif.cmi typing/printtyp.cmi \
bytecomp/printlambda.cmi bytecomp/printinstr.cmi parsing/printast.cmi \
driver/pparse.cmi parsing/parse.cmi utils/misc.cmi typing/ident.cmi \
typing/env.cmi bytecomp/emitcode.cmi utils/config.cmi utils/clflags.cmi \
utils/ccomp.cmi bytecomp/bytegen.cmi driver/compile.cmi
driver/compile.cmx: utils/warnings.cmx typing/unused_var.cmx \
typing/typemod.cmx typing/typedtree.cmx bytecomp/translmod.cmx \
bytecomp/simplif.cmx typing/printtyp.cmx bytecomp/printlambda.cmx \
bytecomp/printinstr.cmx parsing/printast.cmx driver/pparse.cmx \
parsing/parse.cmx utils/misc.cmx typing/ident.cmx typing/env.cmx \
bytecomp/emitcode.cmx utils/config.cmx utils/clflags.cmx utils/ccomp.cmx \
bytecomp/bytegen.cmx driver/compile.cmi
typing/stypes.cmx bytecomp/simplif.cmx typing/printtyp.cmx \
bytecomp/printlambda.cmx bytecomp/printinstr.cmx parsing/printast.cmx \
driver/pparse.cmx parsing/parse.cmx utils/misc.cmx typing/ident.cmx \
typing/env.cmx bytecomp/emitcode.cmx utils/config.cmx utils/clflags.cmx \
utils/ccomp.cmx bytecomp/bytegen.cmx driver/compile.cmi
driver/errors.cmo: utils/warnings.cmi typing/typetexp.cmi typing/typemod.cmi \
typing/typedecl.cmi typing/typecore.cmi typing/typeclass.cmi \
bytecomp/translmod.cmi bytecomp/translcore.cmi bytecomp/translclass.cmi \

2
asmcomp/closure.ml
View File

@ -492,7 +492,7 @@ let rec close fenv cenv = function
end
| Lfunction(kind, params, body) as funct ->
close_one_function fenv cenv (Ident.create "fun") funct
| Lapply(funct, args) ->
| Lapply(funct, args, loc) ->
let nargs = List.length args in
begin match (close fenv cenv funct, close_list fenv cenv args) with
((ufunct, Value_closure(fundesc, approx_res)),

BIN
boot/ocamlc
View File

Binary file not shown.

BIN
boot/ocamllex
View File

Binary file not shown.

11
bytecomp/bytegen.ml
View File

@ -414,13 +414,15 @@ let rec comp_expr env exp sz cont =
end
| Lconst cst ->
Kconst cst :: cont
| Lapply(func, args) ->
| Lapply(func, args, loc) ->
let nargs = List.length args in
if is_tailcall cont then
if is_tailcall cont then begin
Stypes.record (Stypes.An_call (loc, Annot.Tail));
comp_args env args sz
(Kpush :: comp_expr env func (sz + nargs)
(Kappterm(nargs, sz + nargs) :: discard_dead_code cont))
else
end else begin
Stypes.record (Stypes.An_call (loc, Annot.Stack));
if nargs < 4 then
comp_args env args sz
(Kpush :: comp_expr env func (sz + nargs) (Kapply nargs :: cont))
@ -431,6 +433,7 @@ let rec comp_expr env exp sz cont =
(Kpush :: comp_expr env func (sz + 3 + nargs)
(Kapply nargs :: cont1))
end
end
| Lsend(kind, met, obj, args) ->
let args = if kind = Cached then List.tl args else args in
let nargs = List.length args + 1 in
@ -746,7 +749,7 @@ let rec comp_expr env exp sz cont =
| Lev_after ty ->
let info =
match lam with
Lapply(_, args) -> Event_return (List.length args)
Lapply(_, args, _) -> Event_return (List.length args)
| Lsend(_, _, _, args) -> Event_return (List.length args + 1)
| _ -> Event_other
in

8
bytecomp/lambda.ml
View File

@ -124,7 +124,7 @@ type shared_code = (int * int) list
type lambda =
Lvar of Ident.t
| Lconst of structured_constant
| Lapply of lambda * lambda list
| Lapply of lambda * lambda list * Location.t
| Lfunction of function_kind * Ident.t list * lambda
| Llet of let_kind * Ident.t * lambda * lambda
| Lletrec of (Ident.t * lambda) list * lambda
@ -170,7 +170,7 @@ let rec same l1 l2 =
Ident.same v1 v2
| Lconst c1, Lconst c2 ->
c1 = c2
| Lapply(a1, bl1), Lapply(a2, bl2) ->
| Lapply(a1, bl1, _), Lapply(a2, bl2, _) ->
same a1 a2 && samelist same bl1 bl2
| Lfunction(k1, idl1, a1), Lfunction(k2, idl2, a2) ->
k1 = k2 && samelist Ident.same idl1 idl2 && same a1 a2
@ -240,7 +240,7 @@ let name_lambda_list args fn =
let rec iter f = function
Lvar _
| Lconst _ -> ()
| Lapply(fn, args) ->
| Lapply(fn, args, _) ->
f fn; List.iter f args
| Lfunction(kind, params, body) ->
f body
@ -374,7 +374,7 @@ let subst_lambda s lam =
Lvar id as l ->
begin try Ident.find_same id s with Not_found -> l end
| Lconst sc as l -> l
| Lapply(fn, args) -> Lapply(subst fn, List.map subst args)
| Lapply(fn, args, loc) -> Lapply(subst fn, List.map subst args, loc)
| Lfunction(kind, params, body) -> Lfunction(kind, params, subst body)
| Llet(str, id, arg, body) -> Llet(str, id, subst arg, subst body)
| Lletrec(decl, body) -> Lletrec(List.map subst_decl decl, subst body)

2
bytecomp/lambda.mli
View File

@ -133,7 +133,7 @@ type shared_code = (int * int) list (* stack size -> code label *)
type lambda =
Lvar of Ident.t
| Lconst of structured_constant
| Lapply of lambda * lambda list
| Lapply of lambda * lambda list * Location.t
| Lfunction of function_kind * Ident.t list * lambda
| Llet of let_kind * Ident.t * lambda * lambda
| Lletrec of (Ident.t * lambda) list * lambda

2
bytecomp/printlambda.ml
View File

@ -185,7 +185,7 @@ let rec lam ppf = function
Ident.print ppf id
| Lconst cst ->
struct_const ppf cst
| Lapply(lfun, largs) ->
| Lapply(lfun, largs, _) ->
let lams ppf largs =
List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
fprintf ppf "@[<2>(apply@ %a%a)@]" lam lfun lams largs

12
bytecomp/simplif.ml
View File

@ -26,8 +26,8 @@ let rec eliminate_ref id = function
Lvar v as lam ->
if Ident.same v id then raise Real_reference else lam
| Lconst cst as lam -> lam
| Lapply(e1, el) ->
Lapply(eliminate_ref id e1, List.map (eliminate_ref id) el)
| Lapply(e1, el, loc) ->
Lapply(eliminate_ref id e1, List.map (eliminate_ref id) el, loc)
| Lfunction(kind, params, body) as lam ->
if IdentSet.mem id (free_variables lam)
then raise Real_reference
@ -104,7 +104,7 @@ let simplify_exits lam =
let rec count = function
| (Lvar _| Lconst _) -> ()
| Lapply(l1, ll) -> count l1; List.iter count ll
| Lapply(l1, ll, _) -> count l1; List.iter count ll
| Lfunction(kind, params, l) -> count l
| Llet(str, v, l1, l2) ->
count l2; count l1
@ -185,7 +185,7 @@ let simplify_exits lam =
let rec simplif = function
| (Lvar _|Lconst _) as l -> l
| Lapply(l1, ll) -> Lapply(simplif l1, List.map simplif ll)
| Lapply(l1, ll, loc) -> Lapply(simplif l1, List.map simplif ll, loc)
| Lfunction(kind, params, l) -> Lfunction(kind, params, simplif l)
| Llet(kind, v, l1, l2) -> Llet(kind, v, simplif l1, simplif l2)
| Lletrec(bindings, body) ->
@ -276,7 +276,7 @@ let simplify_lets lam =
let rec count = function
| Lvar v -> incr_var v
| Lconst cst -> ()
| Lapply(l1, ll) -> count l1; List.iter count ll
| Lapply(l1, ll, _) -> count l1; List.iter count ll
| Lfunction(kind, params, l) -> count l
| Llet(str, v, Lvar w, l2) when not !Clflags.debug ->
(* v will be replaced by w in l2, so each occurrence of v in l2
@ -346,7 +346,7 @@ let simplify_lets lam =
l
end
| Lconst cst as l -> l
| Lapply(l1, ll) -> Lapply(simplif l1, List.map simplif ll)
| Lapply(l1, ll, loc) -> Lapply(simplif l1, List.map simplif ll, loc)
| Lfunction(kind, params, l) -> Lfunction(kind, params, simplif l)
| Llet(str, v, Lvar w, l2) when not !Clflags.debug ->
Hashtbl.add subst v (simplif (Lvar w));

89
bytecomp/translclass.ml
View File

@ -34,12 +34,14 @@ let lfunction params body =
| _ ->
Lfunction (Curried, params, body)
let lapply func args =
let lapply func args loc =
match func with
Lapply(func', args') ->
Lapply(func', args' @ args)
Lapply(func', args', _) ->
Lapply(func', args' @ args, loc)
| _ ->
Lapply(func, args)
Lapply(func, args, loc)
let mkappl (func, args) = Lapply (func, args, Location.none);;
let lsequence l1 l2 =
if l2 = lambda_unit then l1 else Lsequence(l1, l2)
@ -68,7 +70,7 @@ let copy_inst_var obj id expr templ offset =
Lvar offset])])]))
let transl_val tbl create name =
Lapply (oo_prim (if create then "new_variable" else "get_variable"),
mkappl (oo_prim (if create then "new_variable" else "get_variable"),
[Lvar tbl; transl_label name])
let transl_vals tbl create vals rem =
@ -82,7 +84,7 @@ let meths_super tbl meths inh_meths =
(fun (nm, id) rem ->
try
(nm, id,
Lapply(oo_prim "get_method", [Lvar tbl; Lvar (Meths.find nm meths)]))
mkappl(oo_prim "get_method", [Lvar tbl; Lvar (Meths.find nm meths)]))
:: rem
with Not_found -> rem)
inh_meths []
@ -97,16 +99,16 @@ let create_object cl obj init =
let (inh_init, obj_init, has_init) = init obj' in
if obj_init = lambda_unit then
(inh_init,
Lapply (oo_prim (if has_init then "create_object_and_run_initializers"
mkappl (oo_prim (if has_init then "create_object_and_run_initializers"
else"create_object_opt"),
[obj; Lvar cl]))
else begin
(inh_init,
Llet(Strict, obj',
Lapply (oo_prim "create_object_opt", [obj; Lvar cl]),
mkappl (oo_prim "create_object_opt", [obj; Lvar cl]),
Lsequence(obj_init,
if not has_init then Lvar obj' else
Lapply (oo_prim "run_initializers_opt",
mkappl (oo_prim "run_initializers_opt",
[obj; Lvar obj'; Lvar cl]))))
end
@ -120,7 +122,7 @@ let rec build_object_init cl_table obj params inh_init obj_init cl =
| Some envs -> [Lprim(Pfield (List.length inh_init + 1), [Lvar envs])]
in
((envs, (obj_init, path)::inh_init),
Lapply(Lvar obj_init, env @ [obj]))
mkappl(Lvar obj_init, env @ [obj]))
| Tclass_structure str ->
create_object cl_table obj (fun obj ->
let (inh_init, obj_init, has_init) =
@ -177,7 +179,7 @@ let rec build_object_init cl_table obj params inh_init obj_init cl =
let (inh_init, obj_init) =
build_object_init cl_table obj params inh_init obj_init cl
in
(inh_init, transl_apply obj_init oexprs)
(inh_init, transl_apply obj_init oexprs Location.none)
| Tclass_let (rec_flag, defs, vals, cl) ->
let (inh_init, obj_init) =
build_object_init cl_table obj (vals @ params) inh_init obj_init cl
@ -203,7 +205,7 @@ let rec build_object_init_0 cl_table params cl copy_env subst_env top ids =
let bind_method tbl lab id cl_init =
Llet(StrictOpt, id, Lapply (oo_prim "get_method_label",
Llet(StrictOpt, id, mkappl (oo_prim "get_method_label",
[Lvar tbl; transl_label lab]),
cl_init)
@ -219,7 +221,7 @@ let bind_methods tbl meths vals cl_init =
"new_methods_variables", [transl_meth_list (List.map fst vals)]
in
Llet(StrictOpt, ids,
Lapply (oo_prim getter,
mkappl (oo_prim getter,
[Lvar tbl; transl_meth_list (List.map fst methl)] @ names),
List.fold_right
(fun (lab,id) lam -> decr i; Llet(StrictOpt, id, lfield ids !i, lam))
@ -229,9 +231,9 @@ let output_methods tbl methods lam =
match methods with
[] -> lam
| [lab; code] ->
lsequence (Lapply(oo_prim "set_method", [Lvar tbl; lab; code])) lam
lsequence (mkappl(oo_prim "set_method", [Lvar tbl; lab; code])) lam
| _ ->
lsequence (Lapply(oo_prim "set_methods",
lsequence (mkappl(oo_prim "set_methods",
[Lvar tbl; Lprim(Pmakeblock(0,Immutable), methods)]))
lam
@ -254,7 +256,7 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
let lpath = transl_path path in
(inh_init,
Llet (Strict, obj_init,
Lapply(Lprim(Pfield 1, [lpath]), Lvar cla ::
mkappl(Lprim(Pfield 1, [lpath]), Lvar cla ::
if top then [Lprim(Pfield 3, [lpath])] else []),
bind_super cla super cl_init))
| _ ->
@ -295,7 +297,7 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
(inh_init, cl_init, methods, vals @ values)
| Cf_init exp ->
(inh_init,
Lsequence(Lapply (oo_prim "add_initializer",
Lsequence(mkappl (oo_prim "add_initializer",
Lvar cla :: msubst false (transl_exp exp)),
cl_init),
methods, values))
@ -348,7 +350,7 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
cl_init valids in
(inh_init,
Llet (Strict, inh,
Lapply(oo_prim "inherits", narrow_args @
mkappl(oo_prim "inherits", narrow_args @
[lpath; Lconst(Const_pointer(if top then 1 else 0))]),
Llet(StrictOpt, obj_init, lfield inh 0, cl_init)))
| _ ->
@ -357,10 +359,11 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
in
if cstr then core cl_init else
let (inh_init, cl_init) =
core (Lsequence (Lapply (oo_prim "widen", [Lvar cla]), cl_init))
core (Lsequence (mkappl (oo_prim "widen", [Lvar cla]), cl_init))
in
(inh_init,
Lsequence(Lapply (oo_prim "narrow", narrow_args), cl_init))
Lsequence(mkappl (oo_prim "narrow", narrow_args),
cl_init))
end
let rec build_class_lets cl =
@ -407,7 +410,7 @@ let rec transl_class_rebind obj_init cl vf =
| rem -> build [] rem)
| Tclass_apply (cl, oexprs) ->
let path, obj_init = transl_class_rebind obj_init cl vf in
(path, transl_apply obj_init oexprs)
(path, transl_apply obj_init oexprs Location.none)
| Tclass_let (rec_flag, defs, vals, cl) ->
let path, obj_init = transl_class_rebind obj_init cl vf in
(path, Translcore.transl_let rec_flag defs obj_init)
@ -435,7 +438,7 @@ let transl_class_rebind ids cl vf =
try
let obj_init = Ident.create "obj_init"
and self = Ident.create "self" in
let obj_init0 = lapply (Lvar obj_init) [Lvar self] in
let obj_init0 = lapply (Lvar obj_init) [Lvar self] Location.none in
let path, obj_init' = transl_class_rebind_0 self obj_init0 cl vf in
if not (Translcore.check_recursive_lambda ids obj_init') then
raise(Error(cl.cl_loc, Illegal_class_expr));
@ -452,13 +455,13 @@ let transl_class_rebind ids cl vf =
Llet(
Alias, cla, transl_path path,
Lprim(Pmakeblock(0, Immutable),
[Lapply(Lvar new_init, [lfield cla 0]);
[mkappl(Lvar new_init, [lfield cla 0]);
lfunction [table]
(Llet(Strict, env_init,
Lapply(lfield cla 1, [Lvar table]),
mkappl(lfield cla 1, [Lvar table]),
lfunction [envs]
(Lapply(Lvar new_init,
[Lapply(Lvar env_init, [Lvar envs])]))));
(mkappl(Lvar new_init,
[mkappl(Lvar env_init, [Lvar envs])]))));
lfield cla 2;
lfield cla 3])))
with Exit ->
@ -497,12 +500,12 @@ let rec builtin_meths self env env2 body =
match body with
| Llet(_, s', Lvar s, body) when List.mem s self ->
builtin_meths (s'::self) env env2 body
| Lapply(f, [arg]) when const_path f ->
| Lapply(f, [arg], _) when const_path f ->
let s, args = conv arg in ("app_"^s, f :: args)
| Lapply(f, [arg; p]) when const_path f && const_path p ->
| Lapply(f, [arg; p], _) when const_path f && const_path p ->
let s, args = conv arg in
("app_"^s^"_const", f :: args @ [p])
| Lapply(f, [p; arg]) when const_path f && const_path p ->
| Lapply(f, [p; arg], _) when const_path f && const_path p ->
let s, args = conv arg in
("app_const_"^s, f :: p :: args)
| Lsend(Self, Lvar n, Lvar s, [arg]) when List.mem s self ->
@ -533,7 +536,7 @@ module M = struct
open CamlinternalOO
let builtin_meths self env env2 body =
let builtin, args = builtin_meths self env env2 body in
(* if not arr then [Lapply(oo_prim builtin, args)] else *)
(* if not arr then [mkappl(oo_prim builtin, args)] else *)
let tag = match builtin with
"get_const" -> GetConst
| "get_var" -> GetVar
@ -680,11 +683,11 @@ let transl_class ids cl_id arity pub_meths cl vflag =
tags pub_meths;
let ltable table lam =
Llet(Strict, table,
Lapply (oo_prim "create_table", [transl_meth_list pub_meths]), lam)
mkappl (oo_prim "create_table", [transl_meth_list pub_meths]), lam)
and ldirect obj_init =
Llet(Strict, obj_init, cl_init,
Lsequence(Lapply (oo_prim "init_class", [Lvar cla]),
Lapply(Lvar obj_init, [lambda_unit])))
Lsequence(mkappl (oo_prim "init_class", [Lvar cla]),
mkappl (Lvar obj_init, [lambda_unit])))
in
(* Simplest case: an object defined at toplevel (ids=[]) *)
if top && ids = [] then llets (ltable cla (ldirect obj_init)) else
@ -695,16 +698,16 @@ let transl_class ids cl_id arity pub_meths cl vflag =
Llet(Strict, class_init, cl_init, lam (free_variables cl_init))
and lbody fv =
if List.for_all (fun id -> not (IdentSet.mem id fv)) ids then
Lapply (oo_prim "make_class",[transl_meth_list pub_meths;
mkappl (oo_prim "make_class",[transl_meth_list pub_meths;
Lvar class_init])
else
ltable table (
Llet(
Strict, env_init, Lapply(Lvar class_init, [Lvar table]),
Strict, env_init, mkappl (Lvar class_init, [Lvar table]),
Lsequence(
Lapply (oo_prim "init_class", [Lvar table]),
mkappl (oo_prim "init_class", [Lvar table]),
Lprim(Pmakeblock(0, Immutable),
[Lapply(Lvar env_init, [lambda_unit]);
[mkappl (Lvar env_init, [lambda_unit]);
Lvar class_init; Lvar env_init; lambda_unit]))))
and lbody_virt lenvs =
Lprim(Pmakeblock(0, Immutable),
@ -740,7 +743,7 @@ let transl_class ids cl_id arity pub_meths cl vflag =
lam)
and def_ids cla lam =
Llet(StrictOpt, env2,
Lapply (oo_prim "new_variable", [Lvar cla; transl_label ""]),
mkappl (oo_prim "new_variable", [Lvar cla; transl_label ""]),
lam)
in
let inh_paths =
@ -754,7 +757,7 @@ let transl_class ids cl_id arity pub_meths cl vflag =
and lcache lam =
if inh_keys = [] then Llet(Alias, cached, Lvar tables, lam) else
Llet(Strict, cached,
Lapply(oo_prim "lookup_tables",
mkappl (oo_prim "lookup_tables",
[Lvar tables; Lprim(Pmakeblock(0, Immutable), inh_keys)]),
lam)
and lset cached i lam =
@ -763,7 +766,7 @@ let transl_class ids cl_id arity pub_meths cl vflag =
let ldirect () =
ltable cla
(Llet(Strict, env_init, def_ids cla cl_init,
Lsequence(Lapply (oo_prim "init_class", [Lvar cla]),
Lsequence(mkappl (oo_prim "init_class", [Lvar cla]),
lset cached 0 (Lvar env_init))))
and lclass_virt () =
lset cached 0 (Lfunction(Curried, [cla], def_ids cla cl_init))
@ -775,14 +778,14 @@ let transl_class ids cl_id arity pub_meths cl vflag =
if ids = [] then ldirect () else
if not concrete then lclass_virt () else
lclass (
Lapply (oo_prim "make_class_store",
mkappl (oo_prim "make_class_store",
[transl_meth_list pub_meths;
Lvar class_init; Lvar cached]))),
make_envs (
if ids = [] then Lapply(lfield cached 0, [lenvs]) else
if ids = [] then mkappl (lfield cached 0, [lenvs]) else
Lprim(Pmakeblock(0, Immutable),
if concrete then
[Lapply(lfield cached 0, [lenvs]);
[mkappl (lfield cached 0, [lenvs]);
lfield cached 1;
lfield cached 0;
lenvs]

20
bytecomp/translcore.ml
View File

@ -569,7 +569,10 @@ and transl_exp0 e =
&& List.for_all (fun (arg,_) -> arg <> None) args ->
let args, args' = cut p.prim_arity args in
let wrap f =
event_after e (if args' = [] then f else transl_apply f args') in
if args' = []
then event_after e f
else event_after e (transl_apply f args' e.exp_loc)
in
let wrap0 f =
if args' = [] then f else wrap f in
let args = List.map (function Some x, _ -> x | _ -> assert false) args in
@ -594,7 +597,7 @@ and transl_exp0 e =
if primitive_is_ccall prim then wrap p else wrap0 p
end
| Texp_apply(funct, oargs) ->
event_after e (transl_apply (transl_exp funct) oargs)
event_after e (transl_apply (transl_exp funct) oargs e.exp_loc)
| Texp_match({exp_desc = Texp_tuple argl}, pat_expr_list, partial) ->
Matching.for_multiple_match e.exp_loc
(transl_list argl) (transl_cases pat_expr_list) partial
@ -705,7 +708,7 @@ and transl_exp0 e =
in
event_after e lam
| Texp_new (cl, _) ->
Lapply(Lprim(Pfield 0, [transl_path cl]), [lambda_unit])
Lapply(Lprim(Pfield 0, [transl_path cl]), [lambda_unit], Location.none)
| Texp_instvar(path_self, path) ->
Lprim(Parrayrefu Paddrarray, [transl_path path_self; transl_path path])
| Texp_setinstvar(path_self, path, expr) ->
@ -713,7 +716,8 @@ and transl_exp0 e =
| Texp_override(path_self, modifs) ->
let cpy = Ident.create "copy" in
Llet(Strict, cpy,
Lapply(Translobj.oo_prim "copy", [transl_path path_self]),
Lapply(Translobj.oo_prim "copy", [transl_path path_self],
Location.none),
List.fold_right
(fun (path, expr) rem ->
Lsequence(transl_setinstvar (Lvar cpy) path expr, rem))
@ -748,17 +752,17 @@ and transl_cases pat_expr_list =
and transl_tupled_cases patl_expr_list =
List.map (fun (patl, expr) -> (patl, transl_exp expr)) patl_expr_list
and transl_apply lam sargs =
and transl_apply lam sargs loc =
let lapply funct args =
match funct with
Lsend(k, lmet, lobj, largs) ->
Lsend(k, lmet, lobj, largs @ args)
| Levent(Lsend(k, lmet, lobj, largs), _) ->
Lsend(k, lmet, lobj, largs @ args)
| Lapply(lexp, largs) ->
Lapply(lexp, largs @ args)
| Lapply(lexp, largs, _) ->
Lapply(lexp, largs @ args, loc)
| lexp ->
Lapply(lexp, args)
Lapply(lexp, args, loc)
in
let rec build_apply lam args = function
(None, optional) :: l ->

3
bytecomp/translcore.mli
View File

@ -23,7 +23,8 @@ open Lambda
val name_pattern: string -> (pattern * 'a) list -> Ident.t
val transl_exp: expression -> lambda
val transl_apply: lambda -> (expression option * optional) list -> lambda
val transl_apply: lambda -> (expression option * optional) list
-> Location.t -> lambda
val transl_let:
rec_flag -> (pattern * expression) list -> lambda -> lambda
val transl_primitive: Primitive.description -> lambda

16
bytecomp/translmod.ml
View File

@ -47,7 +47,8 @@ let rec apply_coercion restr arg =
name_lambda arg (fun id ->
Lfunction(Curried, [param],
apply_coercion cc_res
(Lapply(Lvar id, [apply_coercion cc_arg (Lvar param)]))))
(Lapply(Lvar id, [apply_coercion cc_arg (Lvar param)],
Location.none))))
| Tcoerce_primitive p ->
transl_primitive p
@ -202,7 +203,7 @@ let eval_rec_bindings bindings cont =
| (id, None, rhs) :: rem ->
bind_inits rem
| (id, Some(loc, shape), rhs) :: rem ->
Llet(Strict, id, Lapply(mod_prim "init_mod", [loc; shape]),
Llet(Strict, id, Lapply(mod_prim "init_mod", [loc; shape], Location.none),
bind_inits rem)
and bind_strict = function
[] ->
@ -217,7 +218,8 @@ let eval_rec_bindings bindings cont =
| (id, None, rhs) :: rem ->
patch_forwards rem
| (id, Some(loc, shape), rhs) :: rem ->
Lsequence(Lapply(mod_prim "update_mod", [shape; Lvar id; rhs]),
Lsequence(Lapply(mod_prim "update_mod", [shape; Lvar id; rhs],
Location.none),
patch_forwards rem)
in
bind_inits bindings
@ -258,7 +260,7 @@ let rec transl_module cc rootpath mexp =
oo_wrap mexp.mod_env true
(apply_coercion cc)
(Lapply(transl_module Tcoerce_none None funct,
[transl_module ccarg None arg]))
[transl_module ccarg None arg], mexp.mod_loc))
| Tmod_constraint(arg, mty, ccarg) ->
transl_module (compose_coercions cc ccarg) rootpath arg
@ -556,12 +558,14 @@ let toplevel_name id =
let toploop_getvalue id =
Lapply(Lprim(Pfield toploop_getvalue_pos,
[Lprim(Pgetglobal toploop_ident, [])]),
[Lconst(Const_base(Const_string (toplevel_name id)))])
[Lconst(Const_base(Const_string (toplevel_name id)))],
Location.none)
let toploop_setvalue id lam =
Lapply(Lprim(Pfield toploop_setvalue_pos,
[Lprim(Pgetglobal toploop_ident, [])]),
[Lconst(Const_base(Const_string (toplevel_name id))); lam])
[Lconst(Const_base(Const_string (toplevel_name id))); lam],
Location.none)
let toploop_setvalue_id id = toploop_setvalue id (Lvar id)

4
driver/compile.ml
View File

@ -111,12 +111,14 @@ let implementation ppf sourcefile outputprefix =
++ print_if ppf Clflags.dump_instr Printinstr.instrlist
++ Emitcode.to_file oc modulename;
Warnings.check_fatal ();
Pparse.remove_preprocessed inputfile;
close_out oc;
Pparse.remove_preprocessed inputfile;
Stypes.dump (outputprefix ^ ".annot");
with x ->
close_out oc;
remove_file objfile;
Pparse.remove_preprocessed_if_ast inputfile;
Stypes.dump (outputprefix ^ ".annot");
raise x
end

2
driver/main.ml
View File

@ -89,6 +89,7 @@ module Options = Main_args.Make_options (struct
let set r () = r := true
let unset r () = r := false
let _a = set make_archive
let _annot = set annotations
let _c = set compile_only
let _cc s = c_compiler := s; c_linker := s
let _cclib s = ccobjs := Misc.rev_split_words s @ !ccobjs
@ -97,7 +98,6 @@ module Options = Main_args.Make_options (struct
let _custom = set custom_runtime
let _dllib s = dllibs := Misc.rev_split_words s @ !dllibs
let _dllpath s = dllpaths := !dllpaths @ [s]
let _dtypes = set save_types
let _g = set debug
let _i () = print_types := true; compile_only := true
let _I s = include_dirs := s :: !include_dirs

5
driver/main_args.ml
View File

@ -15,6 +15,7 @@
module Make_options (F :
sig
val _a : unit -> unit
val _annot : unit -> unit
val _c : unit -> unit
val _cc : string -> unit
val _cclib : string -> unit
@ -23,7 +24,6 @@ module Make_options (F :
val _custom : unit -> unit
val _dllib : string -> unit
val _dllpath : string -> unit
val _dtypes : unit -> unit
val _g : unit -> unit
val _i : unit -> unit
val _I : string -> unit
@ -65,6 +65,7 @@ module Make_options (F :
struct
let list = [
"-a", Arg.Unit F._a, " Build a library";
"-annot", Arg.Unit F._annot, " Save information in <filename>.annot";
"-c", Arg.Unit F._c, " Compile only (do not link)";
"-cc", Arg.String F._cc,
"<command> Use <command> as the C compiler and linker";
@ -78,7 +79,7 @@ struct
"<lib> Use the dynamically-loaded library <lib>";
"-dllpath", Arg.String F._dllpath,
"<dir> Add <dir> to the run-time search path for shared libraries";
"-dtypes", Arg.Unit F._dtypes, " Save type information in <filename>.annot";
"-dtypes", Arg.Unit F._annot, " (deprecated) same as -annot";
"-for-pack", Arg.String (fun s -> ()),
"<ident> Ignored (for compatibility with ocamlopt)";
"-g", Arg.Unit F._g, " Save debugging information";

2
driver/main_args.mli
View File

@ -15,6 +15,7 @@
module Make_options (F :
sig
val _a : unit -> unit
val _annot : unit -> unit
val _c : unit -> unit
val _cc : string -> unit
val _cclib : string -> unit
@ -23,7 +24,6 @@ module Make_options (F :
val _custom : unit -> unit
val _dllib : string -> unit
val _dllpath : string -> unit
val _dtypes : unit -> unit
val _g : unit -> unit
val _i : unit -> unit
val _I : string -> unit

9
driver/optmain.ml
View File

@ -97,6 +97,8 @@ let main () =
try
Arg.parse (Arch.command_line_options @ [
"-a", Arg.Set make_archive, " Build a library";
"-annot", Arg.Set annotations,
" Save information in <filename>.annot";
"-c", Arg.Set compile_only, " Compile only (do not link)";
"-cc", Arg.String(fun s -> c_compiler := s; c_linker := s),
"<comp> Use <comp> as the C compiler and linker";
@ -109,12 +111,13 @@ let main () =
" Optimize code size rather than speed";
"-config", Arg.Unit show_config,
" print configuration values and exit";
"-dtypes", Arg.Set save_types,
" Save type information in <filename>.annot";
"-dtypes", Arg.Set annotations,
" (deprecated) same as -annot";
"-for-pack", Arg.String (fun s -> for_package := Some s),
"<ident> Generate code that can later be `packed' with\n\
\ ocamlopt -pack -o <ident>.cmx";
"-g", Arg.Set debug, " Record debugging information for exception backtrace";
"-g", Arg.Set debug,
" Record debugging information for exception backtrace";
"-i", Arg.Unit (fun () -> print_types := true; compile_only := true),
" Print inferred interface";
"-I", Arg.String(fun dir -> include_dirs := dir :: !include_dirs),

258
emacs/caml-types.el
View File

@ -12,7 +12,7 @@
;(* $Id$ *)
; An emacs-lisp complement to the "-dtypes" option of ocamlc and ocamlopt.
; An emacs-lisp complement to the "-annot" option of ocamlc and ocamlopt.
;; XEmacs compatibility
@ -25,15 +25,15 @@
(defvar caml-types-location-re nil "Regexp to parse *.annot files.
Annotation files *.annot may be generated with the \"-dtypes\" option
of ocamlc and ocamlopt.
Annotation files *.annot may be generated with the \"-annot\" option
of ocamlc and ocamlopt.
Their format is:
file ::= block *
block ::= position <SP> position <LF> annotation *
position ::= filename <SP> num <SP> num <SP> num
annotation ::= keyword open-paren <LF> <SP> <SP> data <LF> close-paren
annotation ::= keyword open-paren <LF> <SP> <SP> data <LF> close-paren <LF>
<SP> is a space character (ASCII 0x20)
<LF> is a line-feed character (ASCII 0x0A)
@ -52,38 +52,60 @@ Their format is:
- the char number within the line is the difference between the third
and second nums.
For the moment, the only possible keyword is \"type\"."
The current list of keywords is:
type call ident"
)
(let* ((caml-types-filename-re "\"\\(\\([^\\\"]\\|\\\\.\\)*\\)\"")
(caml-types-number-re "\\([0-9]*\\)")
(caml-types-position-re
(caml-types-number-re "\\([0-9]*\\)"))
(setq caml-types-position-re
(concat caml-types-filename-re " "
caml-types-number-re " "
caml-types-number-re " "
caml-types-number-re)))
caml-types-number-re))
(setq caml-types-location-re
(concat "^" caml-types-position-re " " caml-types-position-re)))
(defvar caml-types-expr-ovl (make-overlay 1 1))
(make-face 'caml-types-face)
(set-face-doc-string 'caml-types-face
(make-face 'caml-types-expr-face)
(set-face-doc-string 'caml-types-expr-face
"face for hilighting expressions and types")
(if (not (face-differs-from-default-p 'caml-types-face))
(set-face-background 'caml-types-face "#88FF44"))
(if (not (face-differs-from-default-p 'caml-types-expr-face))
(set-face-background 'caml-types-expr-face "#88FF44"))
(overlay-put caml-types-expr-ovl 'face 'caml-types-expr-face)
(defvar caml-types-typed-ovl (make-overlay 1 1))
(make-face 'caml-types-typed-face)
(set-face-doc-string 'caml-types-typed-face
"face for hilighting typed expressions")
(if (not (face-differs-from-default-p 'caml-types-typed-face))
(set-face-background 'caml-types-typed-face "#FF8844"))
(overlay-put caml-types-expr-ovl 'face 'caml-types-face)
(overlay-put caml-types-typed-ovl 'face 'caml-types-typed-face)
(defvar caml-types-scope-ovl (make-overlay 1 1))
(make-face 'caml-types-scope-face)
(set-face-doc-string 'caml-types-scope-face
"face for hilighting variable scopes")
(if (not (face-differs-from-default-p 'caml-types-scope-face))
(set-face-background 'caml-types-scope-face "#BBFFFF"))
(overlay-put caml-types-scope-ovl 'face 'caml-types-scope-face)
(defvar caml-types-def-ovl (make-overlay 1 1))
(make-face 'caml-types-def-face)
(set-face-doc-string 'caml-types-def-face
"face for hilighting binding occurrences")
(if (not (face-differs-from-default-p 'caml-types-def-face))
(set-face-background 'caml-types-def-face "#FF4444"))
(overlay-put caml-types-def-ovl 'face 'caml-types-def-face)
(defvar caml-types-occ-ovl (make-overlay 1 1))
(make-face 'caml-types-occ-face)
(set-face-doc-string 'caml-types-occ-face
"face for hilighting variable occurrences")
(if (not (face-differs-from-default-p 'caml-types-occ-face))
(set-face-background 'caml-types-occ-face "#44FF44"))
(overlay-put caml-types-occ-ovl 'face 'caml-types-occ-face)
(defvar caml-types-annotation-tree nil)
(defvar caml-types-annotation-date nil)
@ -130,7 +152,7 @@ See `caml-types-location-re' for annotation file format.
(caml-types-preprocess type-file)
(setq caml-types-buffer (get-buffer-create caml-types-buffer-name))
(let* ((targ-loc (vector target-file target-line target-bol target-cnum))
(node (caml-types-find-location targ-loc ()
(node (caml-types-find-location targ-loc "type" ()
caml-types-annotation-tree)))
(cond
((null node)
@ -139,7 +161,7 @@ See `caml-types-location-re' for annotation file format.
(t
(let ((left (caml-types-get-pos target-buf (elt node 0)))
(right (caml-types-get-pos target-buf (elt node 1)))
(type (elt node 2)))
(type (cdr (assoc "type" (elt node 2)))))
(move-overlay caml-types-expr-ovl left right target-buf)
(with-current-buffer caml-types-buffer
(erase-buffer)
@ -154,6 +176,153 @@ See `caml-types-location-re' for annotation file format.
(delete-overlay caml-types-expr-ovl)
)))
(defun caml-types-show-call (arg)
"Show the kind of call at point.
The smallest function call that contains point is
temporarily highlighted. Its kind is highlighted in the .annot
file and the mark is set to the beginning of the kind.
The kind is also displayed in the mini-buffer.
The kind is also displayed in the buffer *caml-types*, which is
displayed when the command is called with Prefix argument 4.
See `caml-types-location-re' for annotation file format.
"
(interactive "p")
(let* ((target-buf (current-buffer))
(target-file (file-name-nondirectory (buffer-file-name)))
(target-line (1+ (count-lines (point-min)
(caml-line-beginning-position))))
(target-bol (caml-line-beginning-position))
(target-cnum (point))
(type-file (concat (file-name-sans-extension (buffer-file-name))
".annot")))
(caml-types-preprocess type-file)
(setq caml-types-buffer (get-buffer-create caml-types-buffer-name))
(let* ((targ-loc (vector target-file target-line target-bol target-cnum))
(node (caml-types-find-location targ-loc "call" ()
caml-types-annotation-tree)))
(cond
((null node)
(delete-overlay caml-types-expr-ovl)
(message "Point is not within a function call."))
(t
(let ((left (caml-types-get-pos target-buf (elt node 0)))
(right (caml-types-get-pos target-buf (elt node 1)))
(kind (cdr (assoc "call" (elt node 2)))))
(move-overlay caml-types-expr-ovl left right target-buf)
(with-current-buffer caml-types-buffer
(erase-buffer)
(insert kind)
(message (format "%s call" kind)))
))))
(if (and (= arg 4)
(not (window-live-p (get-buffer-window caml-types-buffer))))
(display-buffer caml-types-buffer))
(unwind-protect
(caml-sit-for 60)
(delete-overlay caml-types-expr-ovl)
)))
(defun caml-types-show-ident (arg)
"Show the kind of call at point.
The smallest function call that contains point is
temporarily highlighted. Its kind is highlighted in the .annot
file and the mark is set to the beginning of the kind.
The kind is also displayed in the mini-buffer.
The kind is also displayed in the buffer *caml-types*, which is
displayed when the command is called with Prefix argument 4.
See `caml-types-location-re' for annotation file format.
"
(interactive "p")
(let* ((target-buf (current-buffer))
(target-file (file-name-nondirectory (buffer-file-name)))
(target-line (1+ (count-lines (point-min)
(caml-line-beginning-position))))
(target-bol (caml-line-beginning-position))
(target-cnum (point))
(type-file (concat (file-name-sans-extension (buffer-file-name))
".annot")))
(caml-types-preprocess type-file)
(setq caml-types-buffer (get-buffer-create caml-types-buffer-name))
(let* ((targ-loc (vector target-file target-line target-bol target-cnum))
(node (caml-types-find-location targ-loc "ident" ()
caml-types-annotation-tree)))
(cond
((null node)
(delete-overlay caml-types-expr-ovl)
(message "Point is not within an identifier."))
(t
(let ((left (caml-types-get-pos target-buf (elt node 0)))
(right (caml-types-get-pos target-buf (elt node 1)))
(kind (cdr (assoc "ident" (elt node 2)))))
(move-overlay caml-types-expr-ovl left right target-buf)
(let* ((loc-re (concat caml-types-position-re " "
caml-types-position-re))
(end-re (concat caml-types-position-re " --"))
(def-re (concat "def " loc-re))
(def-end-re (concat "def " end-re))
(internal-re (concat "internal_ref " loc-re))
(external-re "external_ref \\(.*\\)"))
(cond
((string-match def-re kind)
(let ((l-file (file-name-nondirectory (match-string 1 kind)))
(l-line (string-to-int (match-string 3 kind)))
(l-bol (string-to-int (match-string 4 kind)))
(l-cnum (string-to-int (match-string 5 kind)))
(r-file (file-name-nondirectory (match-string 6 kind)))
(r-line (string-to-int (match-string 8 kind)))
(r-bol (string-to-int (match-string 9 kind)))
(r-cnum (string-to-int (match-string 10 kind))))
(let* ((lpos (vector l-file l-line l-bol l-cnum))
(rpos (vector r-file r-line r-bol r-cnum))
(left (caml-types-get-pos target-buf lpos))
(right (caml-types-get-pos target-buf rpos)))
(move-overlay caml-types-scope-ovl left right target-buf))))
((string-match def-end-re kind)
(let ((l-file (file-name-nondirectory (match-string 1 kind)))
(l-line (string-to-int (match-string 3 kind)))
(l-bol (string-to-int (match-string 4 kind)))
(l-cnum (string-to-int (match-string 5 kind))))
(let* ((lpos (vector l-file l-line l-bol l-cnum))
(left (caml-types-get-pos target-buf lpos))
(right (buffer-size target-buf)))
(move-overlay caml-types-scope-ovl left right target-buf))))
((string-match internal-re kind)
(let ((l-file (file-name-nondirectory (match-string 1 kind)))
(l-line (string-to-int (match-string 3 kind)))
(l-bol (string-to-int (match-string 4 kind)))
(l-cnum (string-to-int (match-string 5 kind)))
(r-file (file-name-nondirectory (match-string 6 kind)))
(r-line (string-to-int (match-string 8 kind)))
(r-bol (string-to-int (match-string 9 kind)))
(r-cnum (string-to-int (match-string 10 kind))))
(let* ((lpos (vector l-file l-line l-bol l-cnum))
(rpos (vector r-file r-line r-bol r-cnum))
(left (caml-types-get-pos target-buf lpos))
(right (caml-types-get-pos target-buf rpos)))
(move-overlay caml-types-def-ovl left right target-buf)
(message (format "this variable is bound at line %d char %d"
l-line (- l-cnum l-bol))))))
((string-match external-re kind)
(let ((fullname (match-string 1 kind)))
(with-current-buffer caml-types-buffer
(erase-buffer)
(insert fullname)
(message (format "external ident: %s" fullname)))))))
))))
(if (and (= arg 4)
(not (window-live-p (get-buffer-window caml-types-buffer))))
(display-buffer caml-types-buffer))
(unwind-protect
(caml-sit-for 60)
(delete-overlay caml-types-expr-ovl)
(delete-overlay caml-types-def-ovl)
(delete-overlay caml-types-scope-ovl)
)))
(defun caml-types-preprocess (type-file)
(let* ((type-date (nth 5 (file-attributes type-file)))
(target-file (file-name-nondirectory (buffer-file-name)))
@ -173,7 +342,7 @@ See `caml-types-location-re' for annotation file format.
(setq caml-types-annotation-tree tree
caml-types-annotation-date type-date)
(kill-buffer type-buf)
(message ""))
(message "done"))
)))
(defun caml-types-date< (date1 date2)
@ -191,18 +360,26 @@ See `caml-types-location-re' for annotation file format.
(symbol-name (intern elem table)))
(defun next-annotation ()
(forward-char 1)
(if (re-search-forward "^[a-z\"]" () t)
(forward-char -1)
(goto-char (point-max)))
(looking-at "[a-z]")
)
; tree of intervals
; each node is a vector
; [ pos-left pos-right type-info child child child... ]
; type-info =
; () if this node does not correspond to an annotated interval
; (type-start . type-end) address of the annotation in the .annot file
; [ pos-left pos-right annotation child child child... ]
; annotation is a list of:
; (kind . info) where kind = "type" "call" etc.
; and info = the contents of the annotation
(defun caml-types-build-tree (target-file)
(let ((stack ())
(accu ())
(table (caml-types-make-hash-table))
(type-info ()))
(annotation ()))
(while (re-search-forward caml-types-location-re () t)
(let ((l-file (file-name-nondirectory (match-string 1)))
(l-line (string-to-int (match-string 3)))
@ -213,14 +390,13 @@ See `caml-types-location-re' for annotation file format.
(r-bol (string-to-int (match-string 9)))
(r-cnum (string-to-int (match-string 10))))
(unless (caml-types-not-in-file l-file r-file target-file)
(while (and (re-search-forward "^" () t)
(not (looking-at "type"))
(not (looking-at "\\\"")))
(forward-char 1))
(setq type-info
(if (looking-at
"^type(\n\\( \\([^\n)]\\|.)\\|\n[^)]\\)*\\)\n)")
(caml-types-hcons (match-string 1) table)))
(setq annotation ())
(while (next-annotation)
(cond ((looking-at
"^\\([a-z]+\\)(\n \\(\\([^\n)]\\|.)\\|\n[^)]\\)*\\)\n)")
(let ((kind (caml-types-hcons (match-string 1) table))
(info (caml-types-hcons (match-string 2) table)))
(setq annotation (cons (cons kind info) annotation))))))
(setq accu ())
(while (and stack
(caml-types-pos-contains l-cnum r-cnum (car stack)))
@ -228,7 +404,7 @@ See `caml-types-location-re' for annotation file format.
(setq stack (cdr stack)))
(let* ((left-pos (vector l-file l-line l-bol l-cnum))
(right-pos (vector r-file r-line r-bol r-cnum))
(node (caml-types-make-node left-pos right-pos type-info
(node (caml-types-make-node left-pos right-pos annotation
accu)))
(setq stack (cons node stack))))))
(if (null stack)
@ -245,12 +421,12 @@ See `caml-types-location-re' for annotation file format.
(and (not (string= r-file target-file))
(not (string= r-file "")))))
(defun caml-types-make-node (left-pos right-pos type-info children)
(defun caml-types-make-node (left-pos right-pos annotation children)
(let ((result (make-vector (+ 3 (length children)) ()))
(i 3))
(aset result 0 left-pos)
(aset result 1 right-pos)
(aset result 2 type-info)
(aset result 2 annotation)
(while children
(aset result i (car children))
(setq children (cdr children))
@ -261,15 +437,15 @@ See `caml-types-location-re' for annotation file format.
(and (<= l-cnum (elt (elt node 0) 3))
(>= r-cnum (elt (elt node 1) 3))))
(defun caml-types-find-location (targ-pos curr node)
(defun caml-types-find-location (targ-pos kind curr node)
(if (not (caml-types-pos-inside targ-pos node))
curr
(if (elt node 2)
(if (and (elt node 2) (assoc kind (elt node 2)))
(setq curr node))
(let ((i (caml-types-search node targ-pos)))
(if (and (> i 3)
(caml-types-pos-inside targ-pos (elt node (1- i))))
(caml-types-find-location targ-pos curr (elt node (1- i)))
(caml-types-find-location targ-pos kind curr (elt node (1- i)))
curr))))
; trouve le premier fils qui commence apres la position
@ -377,7 +553,7 @@ See `caml-types-location-re' for annotation file format.
(with-current-buffer buf (toggle-read-only 1))
)
(t
(error "No annotation file. You should compile with option \"-dtypes\"."))
(error "No annotation file. You should compile with option \"-annot\"."))
)
buf))
@ -494,7 +670,7 @@ The function uses two overlays.
target-pos
(vector target-file target-line target-bol cnum))
(save-excursion
(setq node (caml-types-find-location
(setq node (caml-types-find-location "type"
target-pos () target-tree))
(set-buffer caml-types-buffer)
(erase-buffer)
@ -567,7 +743,7 @@ The function uses two overlays.
(defun caml-types-version ()
"internal version number of caml-types.el"
(interactive)
(message "2")
(message "3")
)
(provide 'caml-types)

2
emacs/caml.el
View File

@ -297,6 +297,8 @@ have caml-electric-indent on, which see.")
;; caml-types
(define-key caml-mode-map [?\C-c?\C-t] 'caml-types-show-type)
(define-key caml-mode-map [?\C-c?\C-s] 'caml-types-show-call)
(define-key caml-mode-map [?\C-c?\C-i] 'caml-types-show-ident)
;; must be a mouse-down event. Can be any button and any prefix
(define-key caml-mode-map [?\C-c down-mouse-1] 'caml-types-explore)
;; caml-help

92
otherlibs/labltk/browser/.depend
View File

@ -1,19 +1,19 @@
editor.cmo: fileselect.cmi jg_bind.cmi jg_button.cmo jg_menu.cmo \
jg_message.cmi jg_text.cmi jg_tk.cmo jg_toplevel.cmo lexical.cmi \
mytypes.cmi searchid.cmi searchpos.cmi setpath.cmi shell.cmi \
typecheck.cmi viewer.cmi editor.cmi
editor.cmx: fileselect.cmx jg_bind.cmx jg_button.cmx jg_menu.cmx \
jg_message.cmx jg_text.cmx jg_tk.cmx jg_toplevel.cmx lexical.cmx \
mytypes.cmi searchid.cmx searchpos.cmx setpath.cmx shell.cmx \
typecheck.cmx viewer.cmx editor.cmi
fileselect.cmo: jg_box.cmo jg_entry.cmo jg_memo.cmi jg_toplevel.cmo list2.cmo \
setpath.cmi useunix.cmi fileselect.cmi
fileselect.cmx: jg_box.cmx jg_entry.cmx jg_memo.cmx jg_toplevel.cmx list2.cmx \
setpath.cmx useunix.cmx fileselect.cmi
editor.cmo: viewer.cmi typecheck.cmi shell.cmi setpath.cmi searchpos.cmi \
searchid.cmi mytypes.cmi lexical.cmi jg_toplevel.cmo jg_tk.cmo \
jg_text.cmi jg_message.cmi jg_menu.cmo jg_button.cmo jg_bind.cmi \
fileselect.cmi editor.cmi
editor.cmx: viewer.cmx typecheck.cmx shell.cmx setpath.cmx searchpos.cmx \
searchid.cmx mytypes.cmi lexical.cmx jg_toplevel.cmx jg_tk.cmx \
jg_text.cmx jg_message.cmx jg_menu.cmx jg_button.cmx jg_bind.cmx \
fileselect.cmx editor.cmi
fileselect.cmo: useunix.cmi setpath.cmi list2.cmo jg_toplevel.cmo jg_memo.cmi \
jg_entry.cmo jg_box.cmo fileselect.cmi
fileselect.cmx: useunix.cmx setpath.cmx list2.cmx jg_toplevel.cmx jg_memo.cmx \
jg_entry.cmx jg_box.cmx fileselect.cmi
jg_bind.cmo: jg_bind.cmi
jg_bind.cmx: jg_bind.cmi
jg_box.cmo: jg_bind.cmi jg_completion.cmi
jg_box.cmx: jg_bind.cmx jg_completion.cmx
jg_box.cmo: jg_completion.cmi jg_bind.cmi
jg_box.cmx: jg_completion.cmx jg_bind.cmx
jg_completion.cmo: jg_completion.cmi
jg_completion.cmx: jg_completion.cmi
jg_config.cmo: jg_tk.cmo jg_config.cmi
@ -22,45 +22,45 @@ jg_entry.cmo: jg_bind.cmi
jg_entry.cmx: jg_bind.cmx
jg_memo.cmo: jg_memo.cmi
jg_memo.cmx: jg_memo.cmi
jg_message.cmo: jg_bind.cmi jg_text.cmi jg_tk.cmo jg_toplevel.cmo \
jg_message.cmo: jg_toplevel.cmo jg_tk.cmo jg_text.cmi jg_bind.cmi \
jg_message.cmi
jg_message.cmx: jg_bind.cmx jg_text.cmx jg_tk.cmx jg_toplevel.cmx \
jg_message.cmx: jg_toplevel.cmx jg_tk.cmx jg_text.cmx jg_bind.cmx \
jg_message.cmi
jg_multibox.cmo: jg_bind.cmi jg_completion.cmi jg_multibox.cmi
jg_multibox.cmx: jg_bind.cmx jg_completion.cmx jg_multibox.cmi
jg_text.cmo: jg_bind.cmi jg_button.cmo jg_tk.cmo jg_toplevel.cmo jg_text.cmi
jg_text.cmx: jg_bind.cmx jg_button.cmx jg_tk.cmx jg_toplevel.cmx jg_text.cmi
jg_multibox.cmo: jg_completion.cmi jg_bind.cmi jg_multibox.cmi
jg_multibox.cmx: jg_completion.cmx jg_bind.cmx jg_multibox.cmi
jg_text.cmo: jg_toplevel.cmo jg_tk.cmo jg_button.cmo jg_bind.cmi jg_text.cmi
jg_text.cmx: jg_toplevel.cmx jg_tk.cmx jg_button.cmx jg_bind.cmx jg_text.cmi
lexical.cmo: jg_tk.cmo lexical.cmi
lexical.cmx: jg_tk.cmx lexical.cmi
main.cmo: editor.cmi jg_config.cmi searchid.cmi searchpos.cmi shell.cmi \
viewer.cmi
main.cmx: editor.cmx jg_config.cmx searchid.cmx searchpos.cmx shell.cmx \
viewer.cmx
main.cmo: viewer.cmi shell.cmi searchpos.cmi searchid.cmi jg_config.cmi \
editor.cmi
main.cmx: viewer.cmx shell.cmx searchpos.cmx searchid.cmx jg_config.cmx \
editor.cmx
searchid.cmo: list2.cmo searchid.cmi
searchid.cmx: list2.cmx searchid.cmi
searchpos.cmo: jg_bind.cmi jg_memo.cmi jg_message.cmi jg_text.cmi jg_tk.cmo \
lexical.cmi searchid.cmi searchpos.cmi
searchpos.cmx: jg_bind.cmx jg_memo.cmx jg_message.cmx jg_text.cmx jg_tk.cmx \
lexical.cmx searchid.cmx searchpos.cmi
setpath.cmo: jg_bind.cmi jg_box.cmo jg_button.cmo jg_toplevel.cmo list2.cmo \
useunix.cmi setpath.cmi
setpath.cmx: jg_bind.cmx jg_box.cmx jg_button.cmx jg_toplevel.cmx list2.cmx \
useunix.cmx setpath.cmi
shell.cmo: dummy.cmi fileselect.cmi jg_memo.cmi jg_menu.cmo jg_message.cmi \
jg_text.cmi jg_tk.cmo jg_toplevel.cmo lexical.cmi list2.cmo shell.cmi
shell.cmx: dummy.cmi fileselect.cmx jg_memo.cmx jg_menu.cmx jg_message.cmx \
jg_text.cmx jg_tk.cmx jg_toplevel.cmx lexical.cmx list2.cmx shell.cmi
typecheck.cmo: jg_message.cmi jg_text.cmi jg_tk.cmo mytypes.cmi typecheck.cmi
typecheck.cmx: jg_message.cmx jg_text.cmx jg_tk.cmx mytypes.cmi typecheck.cmi
searchpos.cmo: searchid.cmi lexical.cmi jg_tk.cmo jg_text.cmi jg_message.cmi \
jg_memo.cmi jg_bind.cmi searchpos.cmi
searchpos.cmx: searchid.cmx lexical.cmx jg_tk.cmx jg_text.cmx jg_message.cmx \
jg_memo.cmx jg_bind.cmx searchpos.cmi
setpath.cmo: useunix.cmi list2.cmo jg_toplevel.cmo jg_button.cmo jg_box.cmo \
jg_bind.cmi setpath.cmi
setpath.cmx: useunix.cmx list2.cmx jg_toplevel.cmx jg_button.cmx jg_box.cmx \
jg_bind.cmx setpath.cmi
shell.cmo: list2.cmo lexical.cmi jg_toplevel.cmo jg_tk.cmo jg_text.cmi \
jg_message.cmi jg_menu.cmo jg_memo.cmi fileselect.cmi dummy.cmi shell.cmi
shell.cmx: list2.cmx lexical.cmx jg_toplevel.cmx jg_tk.cmx jg_text.cmx \
jg_message.cmx jg_menu.cmx jg_memo.cmx fileselect.cmx dummy.cmi shell.cmi
typecheck.cmo: mytypes.cmi jg_tk.cmo jg_text.cmi jg_message.cmi typecheck.cmi
typecheck.cmx: mytypes.cmi jg_tk.cmx jg_text.cmx jg_message.cmx typecheck.cmi
useunix.cmo: useunix.cmi
useunix.cmx: useunix.cmi
viewer.cmo: help.cmo jg_bind.cmi jg_box.cmo jg_button.cmo jg_completion.cmi \
jg_entry.cmo jg_menu.cmo jg_message.cmi jg_multibox.cmi jg_text.cmi \
jg_tk.cmo jg_toplevel.cmo mytypes.cmi searchid.cmi searchpos.cmi \
setpath.cmi shell.cmi useunix.cmi viewer.cmi
viewer.cmx: help.cmx jg_bind.cmx jg_box.cmx jg_button.cmx jg_completion.cmx \
jg_entry.cmx jg_menu.cmx jg_message.cmx jg_multibox.cmx jg_text.cmx \
jg_tk.cmx jg_toplevel.cmx mytypes.cmi searchid.cmx searchpos.cmx \
setpath.cmx shell.cmx useunix.cmx viewer.cmi
viewer.cmo: useunix.cmi shell.cmi setpath.cmi searchpos.cmi searchid.cmi \
mytypes.cmi jg_toplevel.cmo jg_tk.cmo jg_text.cmi jg_multibox.cmi \
jg_message.cmi jg_menu.cmo jg_entry.cmo jg_completion.cmi jg_button.cmo \
jg_box.cmo jg_bind.cmi help.cmo viewer.cmi
viewer.cmx: useunix.cmx shell.cmx setpath.cmx searchpos.cmx searchid.cmx \
mytypes.cmi jg_toplevel.cmx jg_tk.cmx jg_text.cmx jg_multibox.cmx \
jg_message.cmx jg_menu.cmx jg_entry.cmx jg_completion.cmx jg_button.cmx \
jg_box.cmx jg_bind.cmx help.cmx viewer.cmi
mytypes.cmi: shell.cmi
typecheck.cmi: mytypes.cmi

1
otherlibs/labltk/browser/Makefile
View File

@ -60,5 +60,6 @@ dummy.mli:
ln -s dummyUnix.mli $@
shell.cmo: dummy.cmi
setpath.cmo fileselect.cmo lexical.cmi searchid.cmi typecheck.cmi: $(TOPDIR)/toplevel/toplevellib.cma
mytypes.cmi searchpos.cmi searchpos.cmo typecheck.cmo: $(TOPDIR)/typing/stypes.cmi
include .depend

2
otherlibs/labltk/browser/mytypes.mli
View File

@ -23,7 +23,7 @@ type edit_window =
modified: Textvariable.textVariable;
mutable shell: (string * Shell.shell) option;
mutable structure: Typedtree.structure;
mutable type_info: Stypes.type_info list;
mutable type_info: Stypes.annotation list;
mutable signature: Types.signature;
mutable psignature: Parsetree.signature;
number: string }

1
otherlibs/labltk/browser/searchpos.ml
View File

@ -871,6 +871,7 @@ let search_pos_ti ~pos = function
| Ti_expr e -> search_pos_expr ~pos e
| Ti_class c -> search_pos_class_expr ~pos c
| Ti_mod m -> search_pos_module_expr ~pos m
| _ -> ()
let rec search_pos_info ~pos = function
[] -> []

2
otherlibs/labltk/browser/searchpos.mli
View File

@ -67,7 +67,7 @@ val search_pos_structure :
pos:int -> Typedtree.structure_item list ->
(fkind * Env.t * Location.t) list
val search_pos_info :
pos:int -> Stypes.type_info list -> (fkind * Env.t * Location.t) list
pos:int -> Stypes.annotation list -> (fkind * Env.t * Location.t) list
val view_type : fkind -> env:Env.t -> unit
val view_type_menu : fkind -> env:Env.t -> parent:'a widget -> menu widget

4
otherlibs/labltk/browser/typecheck.ml
View File

@ -92,7 +92,7 @@ let f txt =
txt.signature <- [];
txt.psignature <- [];
ignore (Stypes.get_info ());
Clflags.save_types := true;
Clflags.annotations := true;
begin try
@ -109,7 +109,7 @@ let f txt =
List.iter psl ~f:
begin function
Ptop_def pstr ->
let str, sign, env' = Typemod.type_structure !env pstr in
let str, sign, env' = Typemod.type_structure !env pstr Location.none in
txt.structure <- txt.structure @ str;
txt.signature <- txt.signature @ sign;
env := env'

1
tools/ocamlcp.ml
View File

@ -43,6 +43,7 @@ let incompatible o =
module Options = Main_args.Make_options (struct
let _a () = make_archive := true; option "-a" ()
let _annot = option "-annot"
let _c = option "-c"
let _cc s = option_with_arg "-cc" s
let _cclib s = option_with_arg "-cclib" s

3
toplevel/toploop.ml
View File

@ -218,7 +218,8 @@ let execute_phrase print_outcome ppf phr =
let oldenv = !toplevel_env in
let _ = Unused_var.warn ppf sstr in
Typecore.reset_delayed_checks ();
let (str, sg, newenv) = Typemod.type_structure oldenv sstr in
let (str, sg, newenv) = Typemod.type_structure oldenv sstr Location.none
in
Typecore.force_delayed_checks ();
let lam = Translmod.transl_toplevel_definition str in
Warnings.check_fatal ();

23
typing/annot.mli Normal file
View File

@ -0,0 +1,23 @@
(***********************************************************************)
(* *)
(* Objective Caml *)
(* *)
(* Damien Doligez, projet Gallium, INRIA Rocquencourt *)
(* *)
(* Copyright 2007 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$ *)
(* Data types for annotations (Stypes.ml) *)
type call = Tail | Stack | Inline;;
type ident =
| Iref_internal of Location.t (* defining occurrence *)
| Iref_external of string (* fully qualified name *)
| Idef of Location.t (* scope *)
;;

34
typing/env.ml
View File

@ -44,6 +44,7 @@ type summary =
type t = {
values: (Path.t * value_description) Ident.tbl;
annotations: (Path.t * Annot.ident) Ident.tbl;
constrs: constructor_description Ident.tbl;
labels: label_description Ident.tbl;
types: (Path.t * type_declaration) Ident.tbl;
@ -63,6 +64,7 @@ and module_components_repr =
and structure_components = {
mutable comp_values: (string, (value_description * int)) Tbl.t;
mutable comp_annotations: (string, (Annot.ident * int)) Tbl.t;
mutable comp_constrs: (string, (constructor_description * int)) Tbl.t;
mutable comp_labels: (string, (label_description * int)) Tbl.t;
mutable comp_types: (string, (type_declaration * int)) Tbl.t;
@ -83,7 +85,7 @@ and functor_components = {
}
let empty = {
values = Ident.empty; constrs = Ident.empty;
values = Ident.empty; annotations = Ident.empty; constrs = Ident.empty;
labels = Ident.empty; types = Ident.empty;
modules = Ident.empty; modtypes = Ident.empty;
components = Ident.empty; classes = Ident.empty;
@ -388,6 +390,13 @@ let lookup_simple proj1 proj2 lid env =
let lookup_value =
lookup (fun env -> env.values) (fun sc -> sc.comp_values)
let lookup_annot id e =
let (path, annot) =
lookup (fun env -> env.annotations) (fun sc -> sc.comp_annotations) id e
in
match annot with
| Annot.Iref_external "" -> (path, Annot.Iref_external (Path.name path))
| _ -> (path, annot)
and lookup_constructor =
lookup_simple (fun env -> env.constrs) (fun sc -> sc.comp_constrs)
and lookup_label =
@ -478,7 +487,8 @@ let rec components_of_module env sub path mty =
lazy(match scrape_modtype mty env with
Tmty_signature sg ->
let c =
{ comp_values = Tbl.empty; comp_constrs = Tbl.empty;
{ comp_values = Tbl.empty; comp_annotations = Tbl.empty;
comp_constrs = Tbl.empty;
comp_labels = Tbl.empty; comp_types = Tbl.empty;
comp_modules = Tbl.empty; comp_modtypes = Tbl.empty;
comp_components = Tbl.empty; comp_classes = Tbl.empty;
@ -492,6 +502,11 @@ let rec components_of_module env sub path mty =
let decl' = Subst.value_description sub decl in
c.comp_values <-
Tbl.add (Ident.name id) (decl', !pos) c.comp_values;
if !Clflags.annotations then begin
c.comp_annotations <-
Tbl.add (Ident.name id) (Annot.Iref_external "", !pos)
c.comp_annotations;
end;
begin match decl.val_kind with
Val_prim _ -> () | _ -> incr pos
end
@ -552,7 +567,8 @@ let rec components_of_module env sub path mty =
fcomp_cache = Hashtbl.create 17 }
| Tmty_ident p ->
Structure_comps {
comp_values = Tbl.empty; comp_constrs = Tbl.empty;
comp_values = Tbl.empty; comp_annotations = Tbl.empty;
comp_constrs = Tbl.empty;
comp_labels = Tbl.empty; comp_types = Tbl.empty;
comp_modules = Tbl.empty; comp_modtypes = Tbl.empty;
comp_components = Tbl.empty; comp_classes = Tbl.empty;
@ -565,6 +581,12 @@ and store_value id path decl env =
values = Ident.add id (path, decl) env.values;
summary = Env_value(env.summary, id, decl) }
and store_annot id path annot env =
if !Clflags.annotations then
{ env with
annotations = Ident.add id (path, annot) env.annotations }
else env
and store_type id path info env =
{ env with
constrs =
@ -645,6 +667,9 @@ let _ =
let add_value id desc env =
store_value id (Pident id) desc env
let add_annot id annot env =
store_annot id (Pident id) annot env
and add_type id info env =
store_type id (Pident id) info env
@ -704,8 +729,9 @@ let open_signature root sg env =
(fun env item p ->
match item with
Tsig_value(id, decl) ->
store_value (Ident.hide id) p
let e1 = store_value (Ident.hide id) p
(Subst.value_description sub decl) env
in store_annot (Ident.hide id) p (Annot.Iref_external "") e1
| Tsig_type(id, decl, _) ->
store_type (Ident.hide id) p
(Subst.type_declaration sub decl) env

2
typing/env.mli
View File

@ -37,6 +37,7 @@ val find_modtype_expansion: Path.t -> t -> Types.module_type
(* Lookup by long identifiers *)
val lookup_value: Longident.t -> t -> Path.t * value_description
val lookup_annot: Longident.t -> t -> Path.t * Annot.ident
val lookup_constructor: Longident.t -> t -> constructor_description
val lookup_label: Longident.t -> t -> label_description
val lookup_type: Longident.t -> t -> Path.t * type_declaration
@ -48,6 +49,7 @@ val lookup_cltype: Longident.t -> t -> Path.t * cltype_declaration
(* Insertion by identifier *)
val add_value: Ident.t -> value_description -> t -> t
val add_annot: Ident.t -> Annot.ident -> t -> t
val add_type: Ident.t -> type_declaration -> t -> t
val add_exception: Ident.t -> exception_declaration -> t -> t
val add_module: Ident.t -> module_type -> t -> t

73
typing/stypes.ml
View File

@ -21,16 +21,19 @@
interesting in case of errors.
*)
open Annot;;
open Format;;
open Lexing;;
open Location;;
open Typedtree;;
type type_info =
Ti_pat of pattern
type annotation =
| Ti_pat of pattern
| Ti_expr of expression
| Ti_class of class_expr
| Ti_mod of module_expr
| An_call of Location.t * Annot.call
| An_ident of Location.t * Annot.ident
;;
let get_location ti =
@ -39,18 +42,20 @@ let get_location ti =
| Ti_expr e -> e.exp_loc
| Ti_class c -> c.cl_loc
| Ti_mod m -> m.mod_loc
| An_call (l, k) -> l
| An_ident (l, k) -> l
;;
let type_info = ref ([] : type_info list);;
let annotations = ref ([] : annotation list);;
let phrases = ref ([] : Location.t list);;
let record ti =
if !Clflags.save_types && not (get_location ti).Location.loc_ghost then
type_info := ti :: !type_info
if !Clflags.annotations && not (get_location ti).Location.loc_ghost then
annotations := ti :: !annotations
;;
let record_phrase loc =
if !Clflags.save_types then phrases := loc :: !phrases;
if !Clflags.annotations then phrases := loc :: !phrases;
;;
(* comparison order:
@ -67,7 +72,17 @@ let cmp_ti_inner_first ti1 ti2 =
;;
let print_position pp pos =
fprintf pp "%S %d %d %d" pos.pos_fname pos.pos_lnum pos.pos_bol pos.pos_cnum;
if pos = dummy_pos then
fprintf pp "--"
else
fprintf pp "%S %d %d %d" pos.pos_fname pos.pos_lnum pos.pos_bol
pos.pos_cnum;
;;
let print_location pp loc =
print_position pp loc.loc_start;
fprintf pp " ";
print_position pp loc.loc_end;
;;
let sort_filter_phrases () =
@ -93,38 +108,60 @@ let rec printtyp_reset_maybe loc =
| _ -> ()
;;
let call_kind_string k =
match k with
| Tail -> "tail"
| Stack -> "stack"
| Inline -> "inline"
;;
let print_ident_annot pp k =
match k with
| Idef l -> fprintf pp "def %a@." print_location l;
| Iref_internal l -> fprintf pp "internal_ref %a@." print_location l;
| Iref_external s -> fprintf pp "external_ref %s@." s;
;;
(* The format of the annotation file is documented in emacs/caml-types.el. *)
let print_info pp ti =
let print_info pp prev_loc ti =
match ti with
| Ti_class _ | Ti_mod _ -> ()
| Ti_class _ | Ti_mod _ -> prev_loc
| Ti_pat {pat_loc = loc; pat_type = typ}
| Ti_expr {exp_loc = loc; exp_type = typ} ->
print_position pp loc.loc_start;
fprintf pp " ";
print_position pp loc.loc_end;
fprintf pp "@.type(@. ";
if loc <> prev_loc then fprintf pp "%a@." print_location loc;
fprintf pp "type(@. ";
printtyp_reset_maybe loc;
Printtyp.mark_loops typ;
Printtyp.type_sch pp typ;
fprintf pp "@.)@.";
loc
| An_call (loc, k) ->
if loc <> prev_loc then fprintf pp "%a@." print_location loc;
fprintf pp "call(@. %s@.)@." (call_kind_string k);
loc
| An_ident (loc, k) ->
if loc <> prev_loc then fprintf pp "%a@." print_location loc;
fprintf pp "ident(@. ";
print_ident_annot pp k;
fprintf pp ")@.";
loc
;;
let get_info () =
let info = List.fast_sort cmp_ti_inner_first !type_info in
type_info := [];
let info = List.fast_sort cmp_ti_inner_first !annotations in
annotations := [];
info
;;
let dump filename =
if !Clflags.save_types then begin
if !Clflags.annotations then begin
let info = get_info () in
let pp = formatter_of_out_channel (open_out filename) in
sort_filter_phrases ();
List.iter (print_info pp) info;
ignore (List.fold_left (print_info pp) Location.none info);
phrases := [];
end else begin
type_info := [];
annotations := [];
end;
;;

12
typing/stypes.mli
View File

@ -18,16 +18,18 @@
open Typedtree;;
type type_info =
Ti_pat of pattern
type annotation =
| Ti_pat of pattern
| Ti_expr of expression
| Ti_class of class_expr
| Ti_mod of module_expr
| An_call of Location.t * Annot.call
| An_ident of Location.t * Annot.ident
;;
val record : type_info -> unit;;
val record : annotation -> unit;;
val record_phrase : Location.t -> unit;;
val dump : string -> unit;;
val get_location : type_info -> Location.t;;
val get_info : unit -> type_info list;;
val get_location : annotation -> Location.t;;
val get_info : unit -> annotation list;;

4
typing/typeclass.ml
View File

@ -561,7 +561,7 @@ let rec class_field cl_num self_type meths vars
| Pcf_let (rec_flag, sdefs, loc) ->
let (defs, val_env) =
try
Typecore.type_let val_env rec_flag sdefs
Typecore.type_let val_env rec_flag sdefs None
with Ctype.Unify [(ty, _)] ->
raise(Error(loc, Make_nongen_seltype ty))
in
@ -910,7 +910,7 @@ and class_expr cl_num val_env met_env scl =
| Pcl_let (rec_flag, sdefs, scl') ->
let (defs, val_env) =
try
Typecore.type_let val_env rec_flag sdefs
Typecore.type_let val_env rec_flag sdefs None
with Ctype.Unify [(ty, _)] ->
raise(Error(scl.pcl_loc, Make_nongen_seltype ty))
in

78
typing/typecore.ml
View File

@ -188,22 +188,29 @@ let has_variants p =
(* pattern environment *)
let pattern_variables = ref ([]: (Ident.t * type_expr) list)
let pattern_variables = ref ([]: (Ident.t * type_expr * Location.t) list)
let pattern_force = ref ([] : (unit -> unit) list)
let reset_pattern () =
let pattern_scope = ref (None : Annot.ident option);;
let reset_pattern scope =
pattern_variables := [];
pattern_force := []
pattern_force := [];
pattern_scope := scope;
;;
let enter_variable loc name ty =
if List.exists (fun (id, _) -> Ident.name id = name) !pattern_variables
if List.exists (fun (id, _, _) -> Ident.name id = name) !pattern_variables
then raise(Error(loc, Multiply_bound_variable));
let id = Ident.create name in
pattern_variables := (id, ty) :: !pattern_variables;
pattern_variables := (id, ty, loc) :: !pattern_variables;
begin match !pattern_scope with
| None -> ()
| Some s -> Stypes.record (Stypes.An_ident (loc, s));
end;
id
let sort_pattern_variables vs =
List.sort
(fun (x,_) (y,_) -> Pervasives.compare (Ident.name x) (Ident.name y))
(fun (x,_,_) (y,_,_) -> Pervasives.compare (Ident.name x) (Ident.name y))
vs
let enter_orpat_variables loc env p1_vs p2_vs =
@ -213,7 +220,7 @@ let enter_orpat_variables loc env p1_vs p2_vs =
and p2_vs = sort_pattern_variables p2_vs in
let rec unify_vars p1_vs p2_vs = match p1_vs, p2_vs with
| (x1,t1)::rem1, (x2,t2)::rem2 when Ident.equal x1 x2 ->
| (x1,t1,l1)::rem1, (x2,t2,l2)::rem2 when Ident.equal x1 x2 ->
if x1==x2 then
unify_vars rem1 rem2
else begin
@ -226,9 +233,9 @@ let enter_orpat_variables loc env p1_vs p2_vs =
(x2,x1)::unify_vars rem1 rem2
end
| [],[] -> []
| (x,_)::_, [] -> raise (Error (loc, Orpat_vars x))
| [],(x,_)::_ -> raise (Error (loc, Orpat_vars x))
| (x,_)::_, (y,_)::_ ->
| (x,_,_)::_, [] -> raise (Error (loc, Orpat_vars x))
| [],(x,_,_)::_ -> raise (Error (loc, Orpat_vars x))
| (x,_,_)::_, (y,_,_)::_ ->
let min_var =
if Ident.name x < Ident.name y then x
else y in
@ -517,24 +524,26 @@ let get_ref r =
let add_pattern_variables env =
let pv = get_ref pattern_variables in
List.fold_right
(fun (id, ty) env ->
Env.add_value id {val_type = ty; val_kind = Val_reg} env)
(fun (id, ty, loc) env ->
let e1 = Env.add_value id {val_type = ty; val_kind = Val_reg} env in
Env.add_annot id (Annot.Iref_internal loc) e1;
)
pv env
let type_pattern env spat =
reset_pattern ();
let type_pattern env spat scope =
reset_pattern scope;
let pat = type_pat env spat in
let new_env = add_pattern_variables env in
(pat, new_env, get_ref pattern_force)
let type_pattern_list env spatl =
reset_pattern ();
let type_pattern_list env spatl scope =
reset_pattern scope;
let patl = List.map (type_pat env) spatl in
let new_env = add_pattern_variables env in
(patl, new_env, get_ref pattern_force)
let type_class_arg_pattern cl_num val_env met_env l spat =
reset_pattern ();
reset_pattern None;
let pat = type_pat val_env spat in
if has_variants pat then begin
Parmatch.pressure_variants val_env [pat];
@ -544,7 +553,7 @@ let type_class_arg_pattern cl_num val_env met_env l spat =
if is_optional l then unify_pat val_env pat (type_option (newvar ()));
let (pv, met_env) =
List.fold_right
(fun (id, ty) (pv, env) ->
(fun (id, ty, loc) (pv, env) ->
let id' = Ident.create (Ident.name id) in
((id', id, ty)::pv,
Env.add_value id' {val_type = ty;
@ -562,7 +571,7 @@ let type_self_pattern cl_num privty val_env met_env par_env spat =
mkpat (Ppat_alias (mkpat(Ppat_alias (spat, "selfpat-*")),
"selfpat-" ^ cl_num))
in
reset_pattern ();
reset_pattern None;
let pat = type_pat val_env spat in
List.iter (fun f -> f()) (get_ref pattern_force);
let meths = ref Meths.empty in
@ -571,7 +580,7 @@ let type_self_pattern cl_num privty val_env met_env par_env spat =
pattern_variables := [];
let (val_env, met_env, par_env) =
List.fold_right
(fun (id, ty) (val_env, met_env, par_env) ->
(fun (id, ty, loc) (val_env, met_env, par_env) ->
(Env.add_value id {val_type = ty; val_kind = Val_unbound} val_env,
Env.add_value id {val_type = ty;
val_kind = Val_self (meths, vars, cl_num, privty)}
@ -900,6 +909,11 @@ let rec type_exp env sexp =
match sexp.pexp_desc with
Pexp_ident lid ->
begin try
if !Clflags.annotations then begin
try let (path, annot) = Env.lookup_annot lid env in
Stypes.record (Stypes.An_ident (sexp.pexp_loc, annot));
with _ -> ()
end;
let (path, desc) = Env.lookup_value lid env in
re {
exp_desc =
@ -932,7 +946,13 @@ let rec type_exp env sexp =
exp_type = type_constant cst;
exp_env = env }
| Pexp_let(rec_flag, spat_sexp_list, sbody) ->
let (pat_exp_list, new_env) = type_let env rec_flag spat_sexp_list in
let scp =
match rec_flag with
| Recursive -> Some (Annot.Idef sexp.pexp_loc)
| Nonrecursive -> Some (Annot.Idef sbody.pexp_loc)
| Default -> None
in
let (pat_exp_list, new_env) = type_let env rec_flag spat_sexp_list scp in
let body = type_exp new_env sbody in
re {
exp_desc = Texp_let(rec_flag, pat_exp_list, body);
@ -1759,7 +1779,7 @@ and type_expect ?in_function env sexp ty_expected =
| Pexp_construct(lid, sarg, explicit_arity) ->
type_construct env sexp.pexp_loc lid sarg explicit_arity ty_expected
| Pexp_let(rec_flag, spat_sexp_list, sbody) ->
let (pat_exp_list, new_env) = type_let env rec_flag spat_sexp_list in
let (pat_exp_list, new_env) = type_let env rec_flag spat_sexp_list None in
let body = type_expect new_env sbody ty_expected in
re {
exp_desc = Texp_let(rec_flag, pat_exp_list, body);
@ -1902,7 +1922,8 @@ and type_cases ?in_function env ty_arg ty_res partial_loc caselist =
List.map
(fun (spat, sexp) ->
if !Clflags.principal then begin_def ();
let (pat, ext_env, force) = type_pattern env spat in
let scope = Some (Annot.Idef sexp.pexp_loc) in
let (pat, ext_env, force) = type_pattern env spat scope in
pattern_force := force @ !pattern_force;
let pat =
if !Clflags.principal then begin
@ -1942,12 +1963,11 @@ and type_cases ?in_function env ty_arg ty_res partial_loc caselist =
(* Typing of let bindings *)
and type_let env rec_flag spat_sexp_list =
and type_let env rec_flag spat_sexp_list scope =
begin_def();
if !Clflags.principal then begin_def ();
let (pat_list, new_env, force) =
type_pattern_list env (List.map (fun (spat, sexp) -> spat) spat_sexp_list)
in
let spatl = List.map (fun (spat, sexp) -> spat) spat_sexp_list in
let (pat_list, new_env, force) = type_pattern_list env spatl scope in
if rec_flag = Recursive then
List.iter2
(fun pat (_, sexp) -> unify_pat env pat (type_approx env sexp))
@ -1993,9 +2013,9 @@ and type_let env rec_flag spat_sexp_list =
(* Typing of toplevel bindings *)
let type_binding env rec_flag spat_sexp_list =
let type_binding env rec_flag spat_sexp_list scope =
Typetexp.reset_type_variables();
type_let env rec_flag spat_sexp_list
type_let env rec_flag spat_sexp_list scope
(* Typing of toplevel expressions *)

4
typing/typecore.mli
View File

@ -23,10 +23,12 @@ val is_nonexpansive: Typedtree.expression -> bool
val type_binding:
Env.t -> rec_flag ->
(Parsetree.pattern * Parsetree.expression) list ->
Annot.ident option ->
(Typedtree.pattern * Typedtree.expression) list * Env.t
val type_let:
Env.t -> rec_flag ->
(Parsetree.pattern * Parsetree.expression) list ->
(Parsetree.pattern * Parsetree.expression) list ->
Annot.ident option ->
(Typedtree.pattern * Typedtree.expression) list * Env.t
val type_expression:
Env.t -> Parsetree.expression -> Typedtree.expression

26
typing/typemod.ml
View File

@ -503,7 +503,7 @@ let rec type_module anchor env smod =
mod_env = env;
mod_loc = smod.pmod_loc }
| Pmod_structure sstr ->
let (str, sg, finalenv) = type_structure anchor env sstr in
let (str, sg, finalenv) = type_structure anchor env sstr smod.pmod_loc in
rm { mod_desc = Tmod_structure str;
mod_type = Tmty_signature sg;
mod_env = env;
@ -558,7 +558,7 @@ let rec type_module anchor env smod =
mod_env = env;
mod_loc = smod.pmod_loc }
and type_structure anchor env sstr =
and type_structure anchor env sstr scope =
let type_names = ref StringSet.empty
and module_names = ref StringSet.empty
and modtype_names = ref StringSet.empty in
@ -571,9 +571,20 @@ and type_structure anchor env sstr =
let expr = Typecore.type_expression env sexpr in
let (str_rem, sig_rem, final_env) = type_struct env srem in
(Tstr_eval expr :: str_rem, sig_rem, final_env)
| {pstr_desc = Pstr_value(rec_flag, sdefs)} :: srem ->
| {pstr_desc = Pstr_value(rec_flag, sdefs); pstr_loc = loc} :: srem ->
let scope =
match rec_flag with
| Recursive -> Some (Annot.Idef {scope with
Location.loc_start = loc.Location.loc_start})
| Nonrecursive ->
let start = match srem with
| [] -> scope.Location.loc_end
| {pstr_loc = loc2} :: _ -> loc2.Location.loc_start
in Some (Annot.Idef {scope with Location.loc_start = start})
| Default -> None
in
let (defs, newenv) =
Typecore.type_binding env rec_flag sdefs in
Typecore.type_binding env rec_flag sdefs scope in
let (str_rem, sig_rem, final_env) = type_struct newenv srem in
let bound_idents = let_bound_idents defs in
let make_sig_value id =
@ -723,7 +734,7 @@ and type_structure anchor env sstr =
sg @ sig_rem,
final_env)
in
if !Clflags.save_types
if !Clflags.annotations
then List.iter (function {pstr_loc = l} -> Stypes.record_phrase l) sstr;
type_struct env sstr
@ -784,10 +795,7 @@ and simplify_signature sg =
let type_implementation sourcefile outputprefix modulename initial_env ast =
Typecore.reset_delayed_checks ();
let (str, sg, finalenv) =
Misc.try_finally (fun () -> type_structure initial_env ast)
(fun () -> Stypes.dump (outputprefix ^ ".annot"))
in
let (str, sg, finalenv) = type_structure initial_env ast Location.none in
Typecore.force_delayed_checks ();
if !Clflags.print_types then begin
fprintf std_formatter "%a@." Printtyp.signature (simplify_signature sg);

3
typing/typemod.mli
View File

@ -20,7 +20,8 @@ open Format
val type_module:
Env.t -> Parsetree.module_expr -> Typedtree.module_expr
val type_structure:
Env.t -> Parsetree.structure -> Typedtree.structure * signature * Env.t
Env.t -> Parsetree.structure -> Location.t ->
Typedtree.structure * signature * Env.t
val type_implementation:
string -> string -> string -> Env.t -> Parsetree.structure ->
Typedtree.structure * Typedtree.module_coercion

2
utils/clflags.ml
View File

@ -33,7 +33,7 @@ and ccopts = ref ([] : string list) (* -ccopt *)
and classic = ref false (* -nolabels *)
and nopervasives = ref false (* -nopervasives *)
and preprocessor = ref(None : string option) (* -pp *)
let save_types = ref false (* -stypes *)
let annotations = ref false (* -annot *)
and use_threads = ref false (* -thread *)
and use_vmthreads = ref false (* -vmthread *)
and noassert = ref false (* -noassert *)

2
utils/clflags.mli
View File

@ -30,7 +30,7 @@ val ccopts : string list ref
val classic : bool ref
val nopervasives : bool ref
val preprocessor : string option ref
val save_types : bool ref
val annotations : bool ref
val use_threads : bool ref
val use_vmthreads : bool ref
val noassert : bool ref