utils/terminfo.cmx : utils/terminfo.cmi

utils/warnings.cmo : utils/warnings.cmi

utils/warnings.cmx : utils/warnings.cmi

parsing/lexer.cmi : parsing/parser.cmi parsing/location.cmi

parsing/location.cmi : utils/warnings.cmi

parsing/longident.cmi :

parsing/parse.cmi : parsing/parsetree.cmi

parsing/parsetree.cmi : parsing/longident.cmi parsing/location.cmi \

parsing/asttypes.cmi

parsing/printast.cmi : parsing/parsetree.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 parsing/longident.cmi \

typing/ident.cmi typing/env.cmi parsing/asttypes.cmi

typing/ident.cmi :

typing/includecore.cmi : typing/types.cmi typing/typedtree.cmi \

typing/ident.cmi typing/env.cmi

typing/includemod.cmi : typing/types.cmi typing/typedtree.cmi \

typing/env.cmi

typing/oprint.cmi : typing/outcometree.cmi

typing/outcometree.cmi : parsing/asttypes.cmi

typing/path.cmi : typing/ident.cmi

typing/predef.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi

typing/primitive.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/annot.cmi

typing/subst.cmi : typing/types.cmi typing/path.cmi typing/ident.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/annot.cmi

typing/typedtree.cmi : typing/types.cmi typing/primitive.cmi typing/path.cmi \

typing/typemod.cmi : typing/types.cmi typing/typedtree.cmi \

parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \

typing/includemod.cmi typing/ident.cmi typing/env.cmi

typing/types.cmi : typing/primitive.cmi typing/path.cmi \

parsing/longident.cmi parsing/location.cmi typing/ident.cmi \

parsing/asttypes.cmi

typing/btype.cmo : typing/types.cmi typing/path.cmi utils/misc.cmi \

typing/btype.cmi

typing/btype.cmx : typing/types.cmx typing/path.cmx utils/misc.cmx \

typing/btype.cmi

typing/ctype.cmo : typing/types.cmi typing/subst.cmi typing/path.cmi \

utils/misc.cmi parsing/longident.cmi parsing/location.cmi \

typing/ident.cmi typing/env.cmi utils/clflags.cmi typing/btype.cmi \

typing/ident.cmx typing/env.cmx utils/clflags.cmx typing/btype.cmx \

parsing/asttypes.cmi typing/ctype.cmi

typing/datarepr.cmo : typing/types.cmi typing/predef.cmi utils/misc.cmi \

typing/datarepr.cmx : typing/types.cmx typing/predef.cmx utils/misc.cmx \

typing/env.cmo : utils/warnings.cmi typing/types.cmi utils/tbl.cmi \

typing/subst.cmi typing/predef.cmi typing/path.cmi utils/misc.cmi \

parsing/longident.cmi parsing/location.cmi typing/ident.cmi \

typing/datarepr.cmi utils/consistbl.cmi utils/config.cmi \

typing/env.cmx : utils/warnings.cmx typing/types.cmx utils/tbl.cmx \

typing/subst.cmx typing/predef.cmx typing/path.cmx utils/misc.cmx \

parsing/longident.cmx parsing/location.cmx typing/ident.cmx \

typing/datarepr.cmx utils/consistbl.cmx utils/config.cmx \

typing/ident.cmo : typing/ident.cmi

typing/ident.cmx : typing/ident.cmi

typing/includeclass.cmo : typing/types.cmi typing/printtyp.cmi \

typing/oprint.cmx utils/misc.cmx parsing/longident.cmx typing/ident.cmx \

typing/env.cmx typing/ctype.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/annot.cmi typing/stypes.cmi

typing/stypes.cmx : typing/typedtree.cmx typing/printtyp.cmx \

typing/printtyp.cmi typing/predef.cmi typing/path.cmi \

parsing/parsetree.cmi typing/parmatch.cmi utils/misc.cmi \

parsing/longident.cmi parsing/location.cmi typing/includeclass.cmi \

typing/typeclass.cmx : utils/warnings.cmx typing/typetexp.cmx \

typing/types.cmx typing/typedtree.cmx typing/typedecl.cmx \

typing/typecore.cmx typing/subst.cmx typing/stypes.cmx \

typing/printtyp.cmx typing/predef.cmx typing/path.cmx \

parsing/parsetree.cmi typing/parmatch.cmx utils/misc.cmx \

parsing/longident.cmx parsing/location.cmx typing/includeclass.cmx \

typing/typecore.cmo : utils/warnings.cmi typing/typetexp.cmi \

typing/types.cmi typing/typedtree.cmi typing/subst.cmi typing/stypes.cmi \

typing/printtyp.cmi typing/primitive.cmi typing/predef.cmi \

typing/path.cmi parsing/parsetree.cmi typing/parmatch.cmi \

typing/oprint.cmi utils/misc.cmi parsing/longident.cmi \

parsing/location.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \

typing/typecore.cmx : utils/warnings.cmx typing/typetexp.cmx \

typing/types.cmx typing/typedtree.cmx typing/subst.cmx typing/stypes.cmx \

typing/printtyp.cmx typing/primitive.cmx typing/predef.cmx \

typing/path.cmx parsing/parsetree.cmi typing/parmatch.cmx \

typing/oprint.cmx utils/misc.cmx parsing/longident.cmx \

parsing/location.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \

typing/typedecl.cmo : utils/warnings.cmi typing/typetexp.cmi \

typing/types.cmi typing/typedtree.cmi typing/subst.cmi \

typing/printtyp.cmi typing/primitive.cmi typing/predef.cmi \

utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \

typing/typedecl.cmi

typing/typedtree.cmo : typing/types.cmi typing/primitive.cmi typing/path.cmi \

typing/typedtree.cmx : typing/types.cmx typing/primitive.cmx typing/path.cmx \

typing/typemod.cmo : utils/warnings.cmi typing/typetexp.cmi typing/types.cmi \

typing/typedtree.cmi typing/typedecl.cmi typing/typecore.cmi \

typing/typeclass.cmi typing/subst.cmi typing/stypes.cmi \

typing/printtyp.cmi typing/path.cmi parsing/parsetree.cmi \

typing/mtype.cmi utils/misc.cmi parsing/longident.cmi \

parsing/location.cmi typing/includemod.cmi typing/ident.cmi \

typing/typemod.cmx : utils/warnings.cmx typing/typetexp.cmx typing/types.cmx \

typing/typedtree.cmx typing/typedecl.cmx typing/typecore.cmx \

typing/typeclass.cmx typing/subst.cmx typing/stypes.cmx \

typing/printtyp.cmx typing/path.cmx parsing/parsetree.cmi \

typing/mtype.cmx utils/misc.cmx parsing/longident.cmx \

parsing/location.cmx typing/includemod.cmx typing/ident.cmx \

typing/types.cmo : typing/primitive.cmi typing/path.cmi utils/misc.cmi \

parsing/longident.cmi parsing/location.cmi typing/ident.cmi \

parsing/asttypes.cmi typing/types.cmi

typing/types.cmx : typing/primitive.cmx typing/path.cmx utils/misc.cmx \

parsing/longident.cmx parsing/location.cmx typing/ident.cmx \

parsing/asttypes.cmi typing/types.cmi

bytecomp/bytegen.cmi : bytecomp/lambda.cmi bytecomp/instruct.cmi

bytecomp/bytelibrarian.cmi :

bytecomp/bytelink.cmi : bytecomp/symtable.cmi bytecomp/cmo_format.cmi

bytecomp/translcore.cmo : typing/types.cmi bytecomp/typeopt.cmi \

typing/typedtree.cmi bytecomp/translobj.cmi typing/primitive.cmi \

typing/predef.cmi typing/path.cmi typing/parmatch.cmi utils/misc.cmi \

bytecomp/translcore.cmx : typing/types.cmx bytecomp/typeopt.cmx \

typing/typedtree.cmx bytecomp/translobj.cmx typing/primitive.cmx \

typing/predef.cmx typing/path.cmx typing/parmatch.cmx utils/misc.cmx \

bytecomp/translmod.cmo : typing/types.cmi typing/typedtree.cmi \

bytecomp/translobj.cmi bytecomp/translcore.cmi bytecomp/translclass.cmi \

typing/printtyp.cmi typing/primitive.cmi typing/predef.cmi \

bytecomp/translclass.cmi parsing/syntaxerr.cmi bytecomp/symtable.cmi \

driver/pparse.cmi parsing/location.cmi parsing/lexer.cmi \

typing/includemod.cmi typing/env.cmi typing/ctype.cmi \

bytecomp/bytelibrarian.cmi driver/errors.cmi

driver/errors.cmx : utils/warnings.cmx typing/typetexp.cmx \

typing/typemod.cmx typing/typedecl.cmx typing/typecore.cmx \

bytecomp/translclass.cmx parsing/syntaxerr.cmx bytecomp/symtable.cmx \

driver/pparse.cmx parsing/location.cmx parsing/lexer.cmx \

typing/includemod.cmx typing/env.cmx typing/ctype.cmx \

bytecomp/bytelibrarian.cmx driver/errors.cmi

driver/main.cmo : utils/warnings.cmi utils/misc.cmi driver/main_args.cmi \

parsing/location.cmi driver/errors.cmi utils/config.cmi \

bytecomp/translclass.cmi parsing/syntaxerr.cmi driver/pparse.cmi \

parsing/location.cmi parsing/lexer.cmi typing/includemod.cmi \

typing/env.cmi typing/ctype.cmi asmcomp/compilenv.cmi \

driver/opterrors.cmx : utils/warnings.cmx typing/typetexp.cmx \

typing/typemod.cmx typing/typedecl.cmx typing/typecore.cmx \

typing/typeclass.cmx bytecomp/translmod.cmx bytecomp/translcore.cmx \

bytecomp/translclass.cmx parsing/syntaxerr.cmx driver/pparse.cmx \

parsing/location.cmx parsing/lexer.cmx typing/includemod.cmx \

typing/env.cmx typing/ctype.cmx asmcomp/compilenv.cmx \

driver/optmain.cmo : utils/warnings.cmi asmcomp/printmach.cmi \

driver/opterrors.cmi driver/optcompile.cmi utils/misc.cmi \

driver/main_args.cmi parsing/location.cmi utils/config.cmi \

typing/primitive.cmo typing/types.cmo \

typing/btype.cmo typing/oprint.cmo \

typing/subst.cmo typing/predef.cmo \

typing/printtyp.cmo typing/includeclass.cmo \

typing/mtype.cmo typing/includecore.cmo \

typing/includemod.cmo typing/typetexp.cmo typing/parmatch.cmo \

typing/typedecl.cmo typing/typeclass.cmo \

typing/typemod.cmo

typing/primitive.cmo typing/types.cmo \

typing/btype.cmo typing/oprint.cmo \

typing/subst.cmo typing/predef.cmo \

typing/typedtree.cmo typing/ctype.cmo \

typing/printtyp.cmo typing/includeclass.cmo \

typing/mtype.cmo typing/includecore.cmo \

typing/includemod.cmo typing/parmatch.cmo \

typing/typedecl.cmo typing/typeclass.cmo \

typing/typemod.cmo

# Recompile the system using the bootstrap compiler

all: runtime ocamlc ocamllex ocamlyacc ocamltools library ocaml \

# The compilation of ocaml will fail if the runtime has changed.

# Never mind, just do make bootstrap to reach fixpoint again.

# The version string is the first line of this file.

# It must be in the format described in stdlib/sys.mli

make clean

./build/distclean.sh

./configure -prefix `pwd`/_install

./build/fastworld.sh

# Go to "Bootstrap camlp4"

In Camlp4/Printers/OCaml.ml:

| <:expr< let open $i$ in $e$ >> ->

o#ident i o#reset_semi#expr e

And at the end of #simple_expr:

<:expr< let open $_$ in $_$ >>

let rec filter_rec = function

| (p::ps)::rem ->

begin match p.pat_desc with

filter_rec ((p::ps)::rem)

| Tpat_var _ ->

filter_rec ((omega::ps)::rem)

let ctx_matcher p =

let p = normalize_pat p in

match p.pat_desc with

(fun q rem -> match q.pat_desc with

p,args @ rem

| Tpat_any -> p,omegas @ rem

| _ -> raise NoMatch)

(fun q rem -> match q.pat_desc with

| Tpat_tuple args -> p,args @ rem

| _ -> p, omegas @ rem)

(fun q rem -> match q.pat_desc with

let l' = all_record_args l' in

| Tpat_lazy omega ->

(fun q rem -> match q.pat_desc with

| Tpat_lazy arg -> p, (arg::rem)

begin match p.pat_desc with

| Tpat_or (p1,p2,_) ->

filter_rec ({l with right=p1::ps}::{l with right=p2::ps}::rem)

filter_rec ({l with right=p::ps}::rem)

| Tpat_var _ ->

filter_rec ({l with right=omega::ps}::rem)

let simplify_or p =

let rec simpl_rec p = match p with

| {pat_desc = Tpat_any|Tpat_var _} -> raise (Var p)

begin try

with

end

| {pat_desc = Tpat_or (p1,p2,o)} ->

let q1 = simpl_rec p1 in

with

| Var q2 -> raise (Var {p with pat_desc = Tpat_or (q1, q2, o)})

end

let all_lbls = all_record_args lbls in

| _ -> p in

try

simpl_rec p

| [] -> []

| ((pat :: patl, action) as cl) :: rem ->

begin match pat.pat_desc with

(omega :: patl, bind Alias id arg action) ::

simplify rem

| Tpat_any ->

cl :: simplify rem

simplify ((p :: patl, bind Alias id arg action) :: rem)

(omega :: patl, action)::

simplify rem

let all_lbls = all_record_args lbls in

(full_pat::patl,action)::

simplify rem

| Tpat_or _ ->

let rec what_is_cases cases = match cases with

| ({pat_desc=Tpat_any} :: _, _) :: rem -> what_is_cases rem

-> assert false (* applies to simplified matchings only *)

| (p::_,_)::_ -> p

| [] -> omega

(* Or-pattern expansion, variables are a complication w.r.t. the article *)

let rec extract_vars r p = match p.pat_desc with

extract_vars (IdentSet.add id r) p

| Tpat_tuple pats ->

List.fold_left extract_vars r pats

List.fold_left

r lpats

List.fold_left extract_vars r pats

| Tpat_array pats ->

List.fold_left extract_vars r pats

arg patl mk_action

(explode_or_pat arg patl mk_action rem vars aliases p2)

vars aliases p1

explode_or_pat arg patl mk_action rem vars (id::aliases) p

let env = mk_alpha_env arg (x::aliases) vars in

(omega::patl,mk_action (List.map snd env))::rem

| p ->

| _ -> false

and group_constructor = function

| _ -> false

and group_variant = function

let get_group p = match p.pat_desc with

| Tpat_any -> group_var

| Tpat_constant _ -> group_constant

| Tpat_tuple _ -> group_tuple

| Tpat_record _ -> group_record

| Tpat_array _ -> group_array

in make_args first_pos

let get_key_constr = function

| _ -> assert false

let get_args_constr p rem = match p with

| _ -> assert false

let pat_as_constr = function

| _ -> fatal_error "Matching.pat_as_constr"

with

| NoMatch -> matcher_rec p2 rem

end

rem

| Tpat_any -> rem

| _ -> raise NoMatch in

rem

| _, _ -> assert false

end

arg::rem

| Tpat_any -> omega::rem

| _ -> raise NoMatch in

| _ ->

fun q rem -> match q.pat_desc with

| Tpat_or (_,_,_) -> raise OrPat

when cstr.cstr_tag = cstr1.cstr_tag -> args @ rem

| Tpat_any -> Parmatch.omegas cstr.cstr_arity @ rem

| _ -> raise NoMatch

let record_matching_line num_fields lbl_pat_list =

let patv = Array.create num_fields omega in

Array.to_list patv

let get_args_record num_fields p rem = match p with

| {pat_desc=Tpat_any} ->

record_matching_line num_fields [] @ rem

record_matching_line num_fields lbl_pat_list @ rem

| _ -> assert false

| Tpat_or (p1,p2,_) ->

let k1,seen1 = extract_pat seen k p1 in

extract_pat seen1 k1 p2

extract_pat seen k p

| Tpat_var _|Tpat_any ->

raise All

let rec name_pattern default = function

(pat :: patl, action) :: rem ->

begin match pat.pat_desc with

| _ -> name_pattern default rem

end

| _ -> Ident.create default

compile_no_test

(divide_tuple (List.length patl) (normalize_pat pat)) ctx_combine

repr partial ctx pm

compile_no_test

(divide_record lbl.lbl_all (normalize_pat pat))

ctx_combine repr partial ctx pm

divide_constant

(combine_constant arg cst partial)

ctx pm

compile_test

(compile_match repr partial) partial

divide_constructor (combine_constructor arg pat cstr partial)

| Tpat_any -> omegas size::k

| Tpat_tuple args -> args::k

| Tpat_or (p1,p2,_) -> flatten_pat_line size p1 (flatten_pat_line size p2 k)

binding, solves PR #3780 *)

flatten_pat_line size p k

| _ -> fatal_error "Matching.flatten_pat_line"

let rec build_object_init cl_table obj params inh_init obj_init cl =

match cl.cl_desc with

let obj_init = Ident.create "obj_init" in

let envs, inh_init = inh_init in

let env =

in

((envs, (obj_init, path)::inh_init),

mkappl(Lvar obj_init, env @ [obj]))

create_object cl_table obj (fun obj ->

let (inh_init, obj_init, has_init) =

List.fold_right

(fun field (inh_init, obj_init, has_init) ->

let (inh_init, obj_init') =

build_object_init cl_table (Lvar obj) [] inh_init

(fun _ -> lambda_unit) cl

in

(inh_init, lsequence obj_init' obj_init, true)

(inh_init, lsequence (set_inst_var obj id exp) obj_init,

has_init)

(inh_init, obj_init, has_init)

(inh_init, obj_init, true)

)

(inh_init, obj_init obj, false)

in

(inh_init,

lsequence (Lifused (id, set_inst_var obj id expr)) rem)

params obj_init,

has_init))

let (inh_init, obj_init) =

build_object_init cl_table obj (vals @ params) inh_init obj_init cl

in

Lfunction (Curried, params, rem) -> build params rem

| rem -> build [] rem

end)

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 Location.none)

let (inh_init, obj_init) =

build_object_init cl_table obj (vals @ params) inh_init obj_init cl

in

(inh_init, Translcore.transl_let rec_flag defs obj_init)

build_object_init cl_table obj params inh_init obj_init cl

let rec build_object_init_0 cl_table params cl copy_env subst_env top ids =

match cl.cl_desc with

build_object_init_0 cl_table (vals@params) cl copy_env subst_env top ids

| _ ->

let self = Ident.create "self" in

let rec ignore_cstrs cl =

match cl.cl_desc with

| _ -> cl

let rec index a = function

| b :: l ->

if b = a then 0 else 1 + index a l

let rec build_class_init cla cstr super inh_init cl_init msubst top cl =

match cl.cl_desc with

begin match inh_init with

(obj_init, path')::inh_init ->

let lpath = transl_path path in

| _ ->

assert false

end

let cl_init = bind_super cla super cl_init in

let (inh_init, cl_init, methods, values) =

List.fold_right

(fun field (inh_init, cl_init, methods, values) ->

let cl_init = output_methods cla methods cl_init in

let inh_init, cl_init =

build_class_init cla false

inh_init cl_init msubst top cl in

(inh_init, cl_init, [], values)

let values = if over then values else (name, id) :: values in

(inh_init, cl_init, methods, values)

let met_code = msubst true (transl_exp exp) in

let met_code =

if !Clflags.native_code && List.length met_code = 1 then

else met_code

in

(inh_init, cl_init,

values)

(inh_init,

Lsequence(mkappl (oo_prim "add_initializer",

Lvar cla :: msubst false (transl_exp exp)),

cl_init),

methods, values))

(inh_init, cl_init, [], [])

in

let cl_init = output_methods cla methods cl_init in

let (inh_init, cl_init) =

build_class_init cla cstr super inh_init cl_init msubst top cl

in

let vals = List.map bind_id_as_val vals in

(inh_init, transl_vals cla true StrictOpt vals cl_init)

build_class_init cla cstr super inh_init cl_init msubst top cl

let (inh_init, cl_init) =

build_class_init cla cstr super inh_init cl_init msubst top cl

in

let vals = List.map bind_id_as_val vals in

(inh_init, transl_vals cla true StrictOpt vals cl_init)

let virt_meths =

List.filter (fun lab -> not (Concr.mem lab concr_meths)) meths in

let concr_meths = Concr.elements concr_meths in

transl_meth_list concr_meths] in

let cl = ignore_cstrs cl in

begin match cl.cl_desc, inh_init with

assert (Path.same path path');

let lpath = transl_path path in

let inh = Ident.create "inh"

let rec build_class_lets cl =

match cl.cl_desc with

let env, wrap = build_class_lets cl in

(env, fun x -> Translcore.transl_let rec_flag defs (wrap x))

| _ ->

let rec get_class_meths cl =

match cl.cl_desc with

(*

XXX Il devrait etre peu couteux d'ecrire des classes :

*)

let rec transl_class_rebind obj_init cl vf =

match cl.cl_desc with

if vf = Concrete then begin

try if (Env.find_class path cl.cl_env).cty_new = None then raise Exit

with Not_found -> raise Exit

end;

(path, obj_init)

let path, obj_init = transl_class_rebind obj_init cl vf in

let build params rem =

let param = name_pattern "param" [pat, ()] in

match obj_init with

Lfunction (Curried, params, rem) -> build params rem

| rem -> build [] rem)

let path, obj_init = transl_class_rebind obj_init cl vf in

(path, transl_apply obj_init oexprs Location.none)

let path, obj_init = transl_class_rebind obj_init cl vf in

(path, Translcore.transl_let rec_flag defs obj_init)

let path, obj_init = transl_class_rebind obj_init cl' vf in

let rec check_constraint = function

| _ -> raise Exit

in

check_constraint cl.cl_type;

let rec transl_class_rebind_0 self obj_init cl vf =

match cl.cl_desc with

let path, obj_init = transl_class_rebind_0 self obj_init cl vf in

(path, Translcore.transl_let rec_flag defs obj_init)

| _ ->

let names = List.map Ident.unique_toplevel_name ids in

prerr_endline (String.concat " " (msg :: names))

(* First check if it is not only a rebind *)

let rebind = transl_class_rebind ids cl vflag in

if rebind <> lambda_unit then rebind else

)))))

(* Wrapper for class compilation *)

let () =

(* Error report *)

val transl_class :

Ident.t list -> Ident.t ->

type error = Illegal_class_expr | Tags of string * string

simplify_constant_constructor) =

Hashtbl.find comparisons_table prim_name in

begin match args with

when simplify_constant_constructor ->

intcomp

when simplify_constant_constructor ->

intcomp

| [arg1; {exp_desc = Texp_variant(_, None)}]

[] -> Ident.create default

| (p, e) :: rem ->

match p.pat_desc with

| _ -> name_pattern default rem

(* Push the default values under the functional abstractions *)

let rec push_defaults loc bindings pat_expr_list partial =

match pat_expr_list with

let pl = push_defaults exp.exp_loc bindings pl partial in

| [pat, {exp_desc = Texp_let

(Default, cases, ({exp_desc = Texp_function _} as e2))}] ->

push_defaults loc (cases :: bindings) [pat, e2] partial

{ exp with exp_loc = loc; exp_desc =

Texp_match

({exp with exp_type = pat.pat_type; exp_desc =

{val_type = pat.pat_type; val_kind = Val_reg;

})},

pat_expr_list, partial) }

in

push_defaults loc bindings

| _ ->

pat_expr_list

and transl_exp0 e =

match e.exp_desc with

let public_send = p.prim_name = "%send" in

if public_send || p.prim_name = "%sendself" then

let kind = if public_send then Public else Self in

Lsend(Cached, Lvar meth, Lvar obj, [Lvar cache; Lvar pos], e.exp_loc))

else

transl_primitive p

raise(Error(e.exp_loc, Free_super_var))

transl_path path

| Texp_ident _ -> fatal_error "Translcore.transl_exp: bad Texp_ident"

| Texp_constant cst ->

Lconst(Const_base cst)

| Texp_let(rec_flag, pat_expr_list, body) ->

transl_let rec_flag pat_expr_list (event_before body (transl_exp body))

let ((kind, params), body) =

event_function e

(function repr ->

transl_function e.exp_loc !Clflags.native_code repr partial pl)

in

Lfunction(kind, params, body)

when List.length oargs >= p.prim_arity

let args, args' = cut p.prim_arity oargs in

let wrap f =

if args' = []

in

let wrap0 f =

if args' = [] then f else wrap f in

let argl = transl_list args in

let public_send = p.prim_name = "%send"

|| not !Clflags.native_code && p.prim_name = "%sendcache"in

with Not_constant ->

Lprim(Pmakeblock(0, Immutable), ll)

end

let ll = transl_list args in

begin match cstr.cstr_tag with

Cstr_constant n ->

Lprim(Pmakeblock(0, Immutable),

[Lconst(Const_base(Const_int tag)); lam])

end

transl_record lbl1.lbl_all lbl1.lbl_repres lbl_expr_list opt_init_expr

| Texp_record ([], _) ->

fatal_error "Translcore.transl_exp: bad Texp_record"

let access =

match lbl.lbl_repres with

Record_regular -> Pfield lbl.lbl_pos

| Record_float -> Pfloatfield lbl.lbl_pos in

Lprim(access, [transl_exp arg])

let access =

match lbl.lbl_repres with

Record_regular -> Psetfield(lbl.lbl_pos, maybe_pointer newval)

Lsequence(transl_exp expr1, event_before expr2 (transl_exp expr2))

| Texp_while(cond, body) ->

Lwhile(transl_exp cond, event_before body (transl_exp body))

Lfor(param, transl_exp low, transl_exp high, dir,

event_before body (transl_exp body))

| Texp_when(cond, body) ->

event_before cond

(Lifthenelse(transl_exp cond, event_before body (transl_exp body),

staticfail))

let obj = transl_exp expr in

let lam =

match met with

Lsend (kind, tag, obj, cache, e.exp_loc)

in

event_after e lam

Lapply(Lprim(Pfield 0, [transl_path cl]), [lambda_unit], Location.none)

Lprim(Parrayrefu Paddrarray, [transl_path path_self; transl_path path])

transl_setinstvar (transl_path path_self) path expr

| Texp_override(path_self, modifs) ->

let cpy = Ident.create "copy" in

Lapply(Translobj.oo_prim "copy", [transl_path path_self],

Location.none),

List.fold_right

Lsequence(transl_setinstvar (Lvar cpy) path expr, rem))

modifs

(Lvar cpy))

Llet(Strict, id, !transl_module Tcoerce_none None modl, transl_exp body)

| Texp_pack modl ->

!transl_module Tcoerce_none None modl

| Texp_constant

( Const_int _ | Const_char _ | Const_string _

| Const_int32 _ | Const_int64 _ | Const_nativeint _ )

-> transl_exp e

| Texp_constant(Const_float _) ->

Lprim(Pmakeblock(Obj.forward_tag, Immutable), [transl_exp e])

begin match e.exp_type.desc with

(* the following may represent a float/forward/lazy: need a

forward_tag *)

let fn = Lfunction (Curried, [Ident.create "param"], transl_exp e) in

Lprim(Pmakeblock(Config.lazy_tag, Immutable), [fn])

end

let cl = Ident.create "class" in

!transl_object cl meths

cl_loc = e.exp_loc;

cl_env = e.exp_env }

and transl_list expr_list =

List.map transl_exp expr_list

| [] ->

lapply lam (List.rev_map fst args)

in

and transl_function loc untuplify_fn repr partial pat_expr_list =

match pat_expr_list with

when Parmatch.fluid pat ->

let param = name_pattern "param" pat_expr_list in

let ((_, params), body) =

| Recursive ->

let idlist =

List.map

| _ -> raise(Error(pat.pat_loc, Illegal_letrec_pat)))

pat_expr_list in

let transl_case (pat, expr) id =

done

end;

List.iter

lbl_expr_list;

let ll = Array.to_list lv in

let mut =

then Mutable

else Immutable in

let lam =

(* If you change anything here, you will likely have to change

[check_recursive_recordwith] in this file. *)

let copy_id = Ident.create "newrecord" in

let upd =

match lbl.lbl_repres with

Record_regular -> Psetfield(lbl.lbl_pos, maybe_pointer expr)

for the core language *)

open Asttypes

open Typedtree

open Lambda

val name_pattern: string -> (pattern * 'a) list -> Ident.t

val transl_exp: expression -> lambda

-> Location.t -> lambda

val transl_let:

rec_flag -> (pattern * expression) list -> lambda -> lambda

let init_shape modl =

let rec init_shape_mod env mty =

match Mtype.scrape env mty with

raise Not_found

Const_block(0, [Const_block(0, init_shape_struct env sg)])

raise Not_found (* can we do better? *)

and init_shape_struct env sg =

match sg with

[] -> []

let init_v =

match Ctype.expand_head env vdesc.val_type with

{desc = Tarrow(_,_,_,_)} ->

Const_pointer 1 (* camlinternalMod.Lazy *)

| _ -> raise Not_found in

init_v :: init_shape_struct env rem

init_shape_struct (Env.add_type id tdecl env) rem

raise Not_found

init_shape_mod env mty ::

init_shape_struct (Env.add_module id mty env) rem

init_shape_struct (Env.add_modtype id minfo env) rem

Const_pointer 2 (* camlinternalMod.Class *)

:: init_shape_struct env rem

init_shape_struct env rem

in

try

eval_rec_bindings

(reorder_rec_bindings

(List.map

(id, modl.mod_loc, init_shape modl, compile_rhs id modl))

bindings))

cont

(* Compile a module expression *)

let rec transl_module cc rootpath mexp =

match mexp.mod_desc with

apply_coercion cc (transl_path path)

| Tmod_structure str ->

let bodypath = functor_path rootpath param in

oo_wrap mexp.mod_env true

(function

(apply_coercion cc)

(Lapply(transl_module Tcoerce_none None funct,

[transl_module ccarg None arg], mexp.mod_loc))

transl_module (compose_coercions cc ccarg) rootpath arg

| Tmod_unpack(arg, _) ->

apply_coercion cc (Translcore.transl_exp arg)

and transl_structure fields cc rootpath = function

[] ->

begin match cc with

| _ ->

fatal_error "Translmod.transl_structure"

end

Lsequence(transl_exp expr, transl_structure fields cc rootpath rem)

let ext_fields = rev_let_bound_idents pat_expr_list @ fields in

transl_let rec_flag pat_expr_list

(transl_structure ext_fields cc rootpath rem)

transl_structure fields cc rootpath rem

transl_structure fields cc rootpath rem

Llet(Strict, id, transl_exception id (field_path rootpath id) decl,

transl_structure (id :: fields) cc rootpath rem)

Llet(Strict, id, transl_path path,

transl_structure (id :: fields) cc rootpath rem)

Llet(Strict, id,

transl_module Tcoerce_none (field_path rootpath id) modl,

transl_structure (id :: fields) cc rootpath rem)

compile_recmodule

(fun id modl ->

transl_module Tcoerce_none (field_path rootpath id) modl)

bindings

(transl_structure ext_fields cc rootpath rem)

transl_structure fields cc rootpath rem

transl_structure fields cc rootpath rem

Lletrec(List.map

cl_list,

transl_structure (List.rev ids @ fields) cc rootpath rem)

transl_structure fields cc rootpath rem

let mid = Ident.create "include" in

let rec rebind_idents pos newfields = function

[] ->

let module_id = Ident.create_persistent module_name in

Lprim(Psetglobal module_id,

[transl_label_init

(* A variant of transl_structure used to compile toplevel structure definitions

for the native-code compiler. Store the defined values in the fields

let rec transl_store subst = function

[] ->

transl_store_subst := subst;

Lsequence(subst_lambda subst (transl_exp expr),

transl_store subst rem)

let ids = let_bound_idents pat_expr_list in

let lam = transl_let rec_flag pat_expr_list (store_idents ids) in

Lsequence(subst_lambda subst lam,

transl_store (add_idents false ids subst) rem)

transl_store subst rem

transl_store subst rem

let lam = transl_exception id (field_path (global_path glob) id) decl in

Lsequence(Llet(Strict, id, lam, store_ident id),

transl_store (add_ident false id subst) rem)

let lam = subst_lambda subst (transl_path path) in

Lsequence(Llet(Strict, id, lam, store_ident id),

transl_store (add_ident false id subst) rem)

let lam =

transl_module Tcoerce_none (field_path (global_path glob) id) modl in

(* Careful: the module value stored in the global may be different

(add_ident true adds id -> Pgetglobal... to subst). *)

Llet(Strict, id, subst_lambda subst lam,

Lsequence(store_ident id, transl_store(add_ident true id subst) rem))

compile_recmodule

(fun id modl ->

subst_lambda subst

bindings

(Lsequence(store_idents ids,

transl_store (add_idents true ids subst) rem))

transl_store subst rem

transl_store subst rem

let lam =

Lletrec(List.map

cl_list,

store_idents ids) in

Lsequence(subst_lambda subst lam,

transl_store (add_idents false ids subst) rem)

transl_store subst rem

let mid = Ident.create "include" in

let rec store_idents pos = function

[] -> transl_store (add_idents true ids subst) rem

(* Build the list of value identifiers defined by a toplevel structure

(excluding primitive declarations). *)

[] -> []

let_bound_idents pat_expr_list @ defined_idents rem

(* Transform a coercion and the list of value identifiers defined by

a toplevel structure into a table [id -> (pos, coercion)],

(* Compile an implementation using transl_store_structure

(for the native-code compiler). *)

reset_labels ();

primitive_declarations := [];

let module_id = Ident.create_persistent module_name in

let (map, prims, size) = build_ident_map restr (defined_idents str) in

let f = function

assert (size = 0);

subst_lambda !transl_store_subst (transl_exp expr)

| str -> transl_store_structure module_id map prims str in

IdentSet.fold (fun id l -> Llet(Strict, id, toploop_getvalue id, l))

(free_variables lam) lam

Tstr_eval expr ->

transl_exp expr

| Tstr_value(rec_flag, pat_expr_list) ->

let idents = let_bound_idents pat_expr_list in

transl_let rec_flag pat_expr_list

(make_sequence toploop_setvalue_id idents)

lambda_unit

| Tstr_type(decls) ->

lambda_unit

toploop_setvalue id (transl_exception id None decl)

toploop_setvalue id (transl_path path)

(* we need to use the unique name for the module because of issues

with "open" (PR#1672) *)

set_toplevel_unique_name id;

toploop_setvalue id

(transl_module Tcoerce_none (Some(Pident id)) modl)

| Tstr_recmodule bindings ->

compile_recmodule

(fun id modl -> transl_module Tcoerce_none (Some(Pident id)) modl)

bindings

(make_sequence toploop_setvalue_id idents)

lambda_unit

lambda_unit

| Tstr_class cl_list ->

(* we need to use unique names for the classes because there might

be a value named identically *)

List.iter set_toplevel_unique_name ids;

Lletrec(List.map

cl_list,

make_sequence

cl_list)

lambda_unit

| Tstr_include(modl, ids) ->

let mid = Ident.create "include" in

let transl_toplevel_definition str =

reset_labels ();

(* Compile the initialization code for a packed library *)

"Cannot print %S this identifier does not respect OCaml lexing rules (%s)"

str (Lexer.Error.to_string exn)) ];

value rec get_expr_args a al =

match a with

| <:expr< $int64:s$ >> -> o#numeric f s "L"

| <:expr< $int32:s$ >> -> o#numeric f s "l"

| <:expr< $flo:s$ >> -> o#numeric f s ""

| <:expr< $id:i$ >> -> o#var_ident f i

| <:expr< { $b$ } >> ->

pp f "@[<hv0>@[<hv2>{%a@]@ }@]" o#record_binding b

| <:patt< $int32:s$ >> -> o#numeric f s "l"

| <:patt< $int:s$ >> -> o#numeric f s ""

| <:patt< $flo:s$ >> -> o#numeric f s ""

| <:patt< ~ $s$ >> -> pp f "~%s" s

| <:patt< ` $uid:s$ >> -> pp f "`%a" o#var s

| <:patt< # $i$ >> -> pp f "@[<2>#%a@]" o#ident i

value mkloc = Loc.to_ocaml_location;

value mkghloc loc = Loc.to_ocaml_location (Loc.ghostify loc);

value mktyp loc d = {ptyp_desc = d; ptyp_loc = mkloc loc};

value mkpat loc d = {ppat_desc = d; ppat_loc = mkloc loc};

value mkghpat loc d = {ppat_desc = d; ppat_loc = mkghloc loc};

value mkstr loc d = {pstr_desc = d; pstr_loc = mkloc loc};

value mkfield loc d = {pfield_desc = d; pfield_loc = mkloc loc};

value mkcty loc d = {pcty_desc = d; pcty_loc = mkloc loc};

value mkpolytype t =

match t.ptyp_desc with

[ Ptyp_poly _ _ -> t

| _ -> assert False ];

value lident s = Lident s;

value ldot l s = Ldot l s;

value lapply l s = Lapply l s;

}

;

ldot (lident str) (if Camlp4_config.unsafe.val then "unsafe_" ^ name else name)

;

value mkrf =

fun

[ <:rec_flag< rec >> -> Recursive

| <:rec_flag<>> -> Nonrecursive

| _ -> assert False ];

where rec loop f =

fun

[ [i :: il] -> loop (ldot (f i)) il

| _ -> error (loc_of_ident i) "invalid long identifier" ]

in self i None;

;

value long_type_ident = long_lident "invalid long identifier type";

value long_class_ident = long_lident "invalid class name";

match ident_tag i with

[ (Ldot i s, `uident) -> ldot i (conv_con s)

| (Lident s, `uident) -> lident (conv_con s)

| _ -> error (loc_of_ident i) "uppercase identifier expected" ]

;

value rec ctyp_long_id_prefix t =

match t with

| <:ctyp< $m1$ $m2$ >> ->

let li1 = ctyp_long_id_prefix m1 in

let li2 = ctyp_long_id_prefix m2 in

| _ -> assert False ];

value mktrecord =

fun

| _ -> assert False (*FIXME*) ];

value mkvariant =

fun

| _ -> assert False (*FIXME*) ];

value rec type_decl tl cl loc m pflag =

value type_decl tl cl t loc = type_decl tl cl loc None False t;

value rec list_of_meta_list =

fun

value rec optional_type_parameters t acc =

match t with

[ <:ctyp< $t1$ $t2$ >> -> optional_type_parameters t1 (optional_type_parameters t2 acc)

| Ast.TyAnP _loc -> [(None, (True, False)) :: acc]

| Ast.TyAnM _loc -> [(None, (False, True)) :: acc]

| Ast.TyAny _loc -> [(None, (False, False)) :: acc]

| _ -> assert False ];

value rec class_parameters t acc =

match t with

[ <:ctyp< $t1$, $t2$ >> -> class_parameters t1 (class_parameters t2 acc)

| _ -> assert False ];

value rec type_parameters_and_type_name t acc =

value rec patt =

fun

| <:patt@loc< $id:i$ >> ->

let p = Ppat_construct (long_uident ~conv_con i)

None (constructors_arity ())

| PaAli loc p1 p2 ->

let (p, i) =

match (p1, p2) with

| _ -> error loc "invalid alias pattern" ]

in

mkpat loc (Ppat_alias (patt p) i)

| PaAnt loc _ -> error loc "antiquotation not allowed here"

| PaAny loc -> mkpat loc Ppat_any

(Some (mkpat loc_any Ppat_any)) False)

| PaApp loc _ _ as f ->

let (f, al) = patt_fa [] f in

| PaTyp loc i -> mkpat loc (Ppat_type (long_type_ident i))

| PaVrn loc s -> mkpat loc (Ppat_variant (conv_con s) None)

| PaLaz loc p -> mkpat loc (Ppat_lazy (patt p))

| PaEq _ _ _ | PaSem _ _ _ | PaCom _ _ _ | PaNil _ as p ->

error (loc_of_patt p) "invalid pattern" ]

and mklabpat =

[ <:ctyp<>> -> acc

| t -> list_of_ctyp t acc ];

match t.ptyp_desc with

[

Ptyp_any -> Ptyp_any

| Ptyp_arrow label core_type core_type' ->

Ptyp_arrow label (loop core_type) (loop core_type')

| Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst)

Ptyp_var ("&" ^ s)

| Ptyp_constr longident lst ->

| Ptyp_object lst ->

| Ptyp_class longident lst lbl_list ->

| Ptyp_alias core_type string ->

| Ptyp_poly string_lst core_type ->

| Ptyp_package longident lst ->

Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst)

]

in

{(t) with ptyp_desc = desc}

match t.pfield_desc with

[ Pfield(n,typ) ->

Pfield(n,loop typ)

Pfield_var]

in

{ (t) with pfield_desc=desc}

match x with

[ Rtag(label,flag,lst) ->

| Rinherit t ->

Rinherit (loop t) ]

in

fun

[ <:expr@loc< $x$.val >> ->

mkexp loc

| ExAcc loc _ _ | <:expr@loc< $id:<:ident< $_$ . $_$ >>$ >> as e ->

let (e, l) =

match sep_expr_acc [] e with

let ca = constructors_arity () in

| [(_, [], e) :: l] -> (expr e, l)

| _ -> error loc "bad ast in expression" ]

in

List.fold_left

(fun (loc_bp, e1) (loc_ep, ml, e2) ->

match e2 with

let loc = Loc.merge loc_bp loc_ep

| _ -> error (loc_of_expr e2) "lowercase identifier expected" ])

(loc, e) l

in

| _ -> mkexp loc (Pexp_apply (expr f) al) ]

| ExAre loc e1 e2 ->

mkexp loc

[("", expr e1); ("", expr e2)])

| ExArr loc e -> mkexp loc (Pexp_array (List.map expr (list_of_expr e [])))

| ExAsf loc -> mkexp loc Pexp_assertfalse

let e =

match e with

[ <:expr@loc< $x$.val >> ->

[("", expr x); ("", expr v)]

| ExAcc loc _ _ ->

match (expr e).pexp_desc with

[ Pexp_field e lab -> Pexp_setfield e lab (expr v)

| _ -> error loc "bad record access" ]

[("", expr e1); ("", expr e2); ("", expr v)]

Pexp_apply

[("", expr e1); ("", expr e2); ("", expr v)]

| _ -> error loc "bad left part of assignment" ]

in

| ExFlo loc s -> mkexp loc (Pexp_constant (Const_float (remove_underscores s)))

| ExFor loc i e1 e2 df el ->

let e3 = ExSeq loc el in

| <:expr@loc< fun [ $PaLab _ lab po$ when $w$ -> $e$ ] >> ->

mkexp loc

(Pexp_function lab None

| ExLaz loc e -> mkexp loc (Pexp_lazy (expr e))

| ExLet loc rf bi e ->

mkexp loc (Pexp_let (mkrf rf) (binding bi []) (expr e))

| ExMat loc e a -> mkexp loc (Pexp_match (expr e) (match_case a []))

| ExNew loc id -> mkexp loc (Pexp_new (long_type_ident id))

| ExObj loc po cfl ->

| p -> p ]

in

let cil = class_str_item cfl [] in

| ExOlb loc _ _ -> error loc "labeled expression not allowed here"

| ExOvr loc iel -> mkexp loc (Pexp_override (mkideexp iel []))

| ExRec loc lel eo ->

| ExSnd loc e s -> mkexp loc (Pexp_send (expr e) s)

| ExSte loc e1 e2 ->

mkexp loc

[("", expr e1); ("", expr e2)])

| ExStr loc s ->

mkexp loc (Pexp_constant (Const_string (string_of_string_token loc s)))

| <:expr@loc< ($tup:_$) >> -> error loc "singleton tuple"

| ExTyc loc e t -> mkexp loc (Pexp_constraint (expr e) (Some (ctyp t)) None)

| <:expr@loc< () >> ->

| <:expr@loc< $lid:s$ >> ->

| <:expr@loc< $uid:s$ >> ->

(* let ca = constructors_arity () in *)

| ExVrn loc s -> mkexp loc (Pexp_variant (conv_con s) None)

| ExWhi loc e1 el ->

let e2 = ExSeq loc el in

match x with

[ <:binding< $x$ and $y$ >> ->

binding x (binding y acc)

(* this code is not pretty because it is temporary *)

[ <:ctyp< $lid:x$ >> -> [x]

| <:ctyp< $x$ $y$ >> -> (id_to_string x) @ (id_to_string y)

| _ -> assert False]

let mkexp = mkexp _loc in

let mkpat = mkpat _loc in

let e = mkexp (Pexp_constraint (expr e) (Some (ctyp ty)) None) in

match x with

[ [newtype :: []] -> mkexp (Pexp_newtype(newtype, e))

| [newtype :: newtypes] ->

mkexp(Pexp_newtype (newtype,mk_newtypes newtypes))

| [] -> assert False]

in

in

let e = mk_newtypes vars in

[( pat, e) :: acc]

[ <:rec_binding<>> -> acc

| <:rec_binding< $x$; $y$ >> ->

mkideexp x (mkideexp y acc)

| _ -> assert False ]

and mktype_decl x acc =

match x with

[ <:ctyp< $x$ and $y$ >> ->

mktype_decl x (mktype_decl y acc)

let cl =

List.map

(fun (t1, t2) ->

(ctyp t1, ctyp t2, mkloc loc))

cl

in

| _ -> assert False ]

and module_type =

fun

[ <:module_type@loc<>> -> error loc "abstract/nil module type not allowed here"

| <:module_type@loc< $id:i$ >> -> mkmty loc (Pmty_ident (long_uident i))

| <:module_type@loc< functor ($n$ : $nt$) -> $mt$ >> ->

| <:module_type@loc< '$_$ >> -> error loc "module type variable not allowed here"

| <:module_type@loc< sig $sl$ end >> ->

mkmty loc (Pmty_signature (sig_item sl []))

| <:sig_item< $sg1$; $sg2$ >> -> sig_item sg1 (sig_item sg2 l)

| SgDir _ _ _ -> l

| <:sig_item@loc< exception $uid:s$ >> ->

| <:sig_item@loc< exception $uid:s$ of $t$ >> ->

(List.map ctyp (list_of_ctyp t []))) :: l]

| SgExc _ _ -> assert False (*FIXME*)

| SgInc loc mt -> [mksig loc (Psig_include (module_type mt)) :: l]

| SgRecMod loc mb ->

[mksig loc (Psig_recmodule (module_sig_binding mb [])) :: l]

| SgMty loc n mt ->

[ MtQuo _ _ -> Pmodtype_abstract

| _ -> Pmodtype_manifest (module_type mt) ]

in

| SgOpn loc id ->

[mksig loc (Psig_open (long_uident id)) :: l]

| SgTyp loc tdl -> [mksig loc (Psig_type (mktype_decl tdl [])) :: l]

| <:sig_item@loc< $anti:_$ >> -> error loc "antiquotation in sig_item" ]

and module_sig_binding x acc =

match x with

[ <:module_binding< $x$ and $y$ >> ->

module_sig_binding x (module_sig_binding y acc)

| _ -> assert False ]

and module_str_binding x acc =

match x with

[ <:module_binding< $x$ and $y$ >> ->

module_str_binding x (module_str_binding y acc)

| _ -> assert False ]

and module_expr =

fun

| <:module_expr@loc< $me1$ $me2$ >> ->

mkmod loc (Pmod_apply (module_expr me1) (module_expr me2))

| <:module_expr@loc< functor ($n$ : $mt$) -> $me$ >> ->

| <:module_expr@loc< struct $sl$ end >> ->

mkmod loc (Pmod_structure (str_item sl []))

| <:module_expr@loc< ($me$ : $mt$) >> ->

| <:str_item< $st1$; $st2$ >> -> str_item st1 (str_item st2 l)

| StDir _ _ _ -> l

| <:str_item@loc< exception $uid:s$ >> ->

| <:str_item@loc< exception $uid:s$ of $t$ >> ->

(List.map ctyp (list_of_ctyp t []))) :: l ]

| <:str_item@loc< exception $uid:s$ = $i$ >> ->

| <:str_item@loc< exception $uid:_$ of $_$ = $_$ >> ->

error loc "type in exception alias"

| StExc _ _ _ -> assert False (*FIXME*)

| StExp loc e -> [mkstr loc (Pstr_eval (expr e)) :: l]

| StInc loc me -> [mkstr loc (Pstr_include (module_expr me)) :: l]

| StRecMod loc mb ->

[mkstr loc (Pstr_recmodule (module_str_binding mb [])) :: l]

| StOpn loc id ->

[mkstr loc (Pstr_open (long_uident id)) :: l]

| StTyp loc tdl -> [mkstr loc (Pstr_type (mktype_decl tdl [])) :: l]

| t -> t ]

in

let cil = class_sig_item ctfl [] in

| CtCon loc _ _ _ ->

error loc "invalid virtual class inside a class type"

| CtAnt _ _ | CtEq _ _ _ | CtCol _ _ _ | CtAnd _ _ _ | CtNil _ ->

and class_info_class_expr ci =

match ci with

let (loc_params, (params, variance)) =

match params with

[ <:ctyp<>> -> (loc, ([], []))

in

{pci_virt = mkvirtual vir;

pci_params = (params, mkloc loc_params);

pci_expr = class_expr ce;

pci_loc = mkloc loc;

pci_variance = variance}

| ce -> error (loc_of_class_expr ce) "bad class definition" ]

and class_info_class_type ci =

match ci with

let (loc_params, (params, variance)) =

match params with

[ <:ctyp<>> -> (loc, ([], []))

in

{pci_virt = mkvirtual vir;

pci_params = (params, mkloc loc_params);

pci_expr = class_type ct;

pci_loc = mkloc loc;

pci_variance = variance}

and class_sig_item c l =

match c with

[ <:class_sig_item<>> -> l

| <:class_sig_item< $csg1$; $csg2$ >> ->

class_sig_item csg1 (class_sig_item csg2 l)

| CgMth loc s pf t ->

| CgVal loc s b v t ->

| CgVir loc s b t ->

| CgAnt _ _ -> assert False ]

and class_expr =

fun

[ CeApp loc _ _ as c ->

let (ce, el) = class_expr_fa [] c in

let el = List.map label_expr el in

| CeCon loc ViNil id tl ->

(Pcl_constr (long_class_ident id) (List.map ctyp (list_of_opt_ctyp tl [])))

| CeFun loc (PaLab _ lab po) ce ->

(Pcl_fun lab None (patt_of_lab loc lab po) (class_expr ce))

| CeFun loc (PaOlbi _ lab p e) ce ->

let lab = paolab lab p in

| CeFun loc (PaOlb _ lab p) ce ->

let lab = paolab lab p in

(Pcl_fun ("?" ^ lab) None (patt_of_lab loc lab p) (class_expr ce))

| CeLet loc rf bi ce ->

| CeStr loc po cfl ->

let p =

match po with

| p -> p ]

in

let cil = class_str_item cfl [] in

| CeTyc loc ce ct ->

| CeCon loc _ _ _ ->

error loc "invalid virtual class inside a class expression"

| CeAnt _ _ | CeEq _ _ _ | CeAnd _ _ _ | CeNil _ -> assert False ]

and class_str_item c l =

match c with

[ CrNil _ -> l

| <:class_str_item< $cst1$; $cst2$ >> ->

class_str_item cst1 (class_str_item cst2 l)

| CrInh loc ov ce pb ->

let opb = if pb = "" then None else Some pb in

| CrMth loc s ov pf e t ->

let t =

match t with

[ <:ctyp<>> -> None

| t -> Some (mkpolytype (ctyp t)) ] in

let e = mkexp loc (Pexp_poly (expr e) t) in

| CrVal loc s ov mf e ->

| CrVir loc s pf t ->

| CrVvr loc s mf t ->

| CrAnt _ _ -> assert False ];

value sig_item ast = sig_item ast [];

| ExInt _ i -> Pdir_int (int_of_string i)

| <:expr< True >> -> Pdir_bool True

| <:expr< False >> -> Pdir_bool False

;

value phrase =

| [: `'b' :] -> '\b'

| [: `'\\' :] -> '\\'

| [: `'"' :] -> '"'

| [: `' ' :] -> ' '

| [: `('0'..'9' as c1); `('0'..'9' as c2); `('0'..'9' as c3) :] ->

chr (100 * (valch c1) + 10 * (valch c2) + (valch c3))

let formatter =

let header = "camlp4-debug: " in

in

make_formatter

(fun buf pos len ->

(fun () -> flush out_channel)

let printf section fmt = fprintf formatter ("%s: " ^^ fmt) section

(** A signature for locations. *)

module type Loc =

sig

type t

(** Return a start location for the given file name.

val to_tuple :

t -> (string * int * int * int * int * int * int * bool)

val merge : t -> t -> t

(** The stop pos becomes equal to the start pos. *)

(** Return the line number of the ending of this location. *)

val stop_line : t -> int

to the begining of the line of location's begining. *)

val start_bol : t -> int

to the begining of the line of location's ending. *)

val stop_bol : t -> int

of the begining of this location. *)

val start_off : t -> int

of the ending of this location. *)

val stop_off : t -> int

(* source tree. *)

(* *)

(****************************************************************************)

type loc =

Loc.

t

let mkghloc loc = Loc.to_ocaml_location (Loc.ghostify loc)

let mktyp loc d = { ptyp_desc = d; ptyp_loc = mkloc loc; }

let mkpat loc d = { ppat_desc = d; ppat_loc = mkloc loc; }

let mkcty loc d = { pcty_desc = d; pcty_loc = mkloc loc; }

let mkpolytype t =

match t.ptyp_desc with

let lident s = Lident s

let ldot l s = Ldot (l, s)

let lapply l s = Lapply (l, s)

[ ("val", "contents") ];

fun s -> try Hashtbl.find t s with | Not_found -> s)

ldot (lident str)

(if !Camlp4_config.unsafe then "unsafe_" ^ name else name)

let mkrf =

function

| Ast.ReRecursive -> Recursive

| Ast.ReNil -> Nonrecursive

| _ -> assert false

let rec loop f =

function | i :: il -> loop (ldot (f i)) il | [] -> f s

let rec ctyp_fa al =

function

let ident_tag ?(conv_lid = fun x -> x) i =

let rec self i acc =

match i with

| Ast.IdAcc (_, i1, i2) -> self i2 (Some (self i1 acc))

| Ast.IdApp (_, i1, i2) ->

let i' =

| _ -> error (loc_of_ident i) "invalid long identifier"

in self i None

let long_type_ident = long_lident "invalid long identifier type"

let long_class_ident = long_lident "invalid class name"

match ident_tag i with

| (Ldot (i, s), `uident) -> ldot i (conv_con s)

| (Lident s, `uident) -> lident (conv_con s)

| (i, `app) -> i

| _ -> error (loc_of_ident i) "uppercase identifier expected"

let rec ctyp_long_id_prefix t =

match t with

| Ast.TyApp (_, m1, m2) ->

let li1 = ctyp_long_id_prefix m1 in

let li2 = ctyp_long_id_prefix m2 in Lapply (li1, li2)

| Ast.TyQuo (_, s) -> [ s ]

| _ -> assert false

let rec ctyp =

function

| TyId (loc, i) ->

| TyArr (loc, (TyLab (_, lab, t1)), t2) ->

mktyp loc (Ptyp_arrow (lab, (ctyp t1), (ctyp t2)))

| TyArr (loc, (TyOlb (loc1, lab, t1)), t2) ->

in

mktyp loc

(Ptyp_arrow (("?" ^ lab), (ctyp t1), (ctyp t2)))

and package_type_constraints wc acc =

match wc with

| Ast.WcNil _ -> acc

| Ast.WcAnd (_, wc1, wc2) ->

package_type_constraints wc1

(package_type_constraints wc2 acc)

let mktrecord =

function

(Ast.TyMut (_, t))) ->

| _ -> assert false

let mkvariant =

function

(Ast.TyArr (_, t, u))) ->

| _ -> assert false

let rec type_decl tl cl loc m pflag =

| _ -> Some (ctyp t)

in mktype loc tl cl Ptype_abstract (mkprivate' pflag) m)

let rec list_of_meta_list =

function

| Ast.TyApp (_, t1, t2) ->

optional_type_parameters t1

(optional_type_parameters t2 acc)

| Ast.TyAnP _loc -> (None, (true, false)) :: acc

| Ast.TyAnM _loc -> (None, (false, true)) :: acc

| Ast.TyAny _loc -> (None, (false, false)) :: acc

| _ -> assert false

match t with

| Ast.TyCom (_, t1, t2) ->

class_parameters t1 (class_parameters t2 acc)

| _ -> assert false

let rec type_parameters_and_type_name t acc =

let rec patt =

function

| Ast.PaId (loc, i) ->

let p =

Ppat_construct ((long_uident ~conv_con i), None,

| PaAli (loc, p1, p2) ->

let (p, i) =

(match (p1, p2) with

| _ -> error loc "invalid alias pattern")

in mkpat loc (Ppat_alias ((patt p), i))

| PaAnt (loc, _) -> error loc "antiquotation not allowed here"

| PaAny loc -> mkpat loc Ppat_any

(Ast.PaTup (_, (Ast.PaAny loc_any)))) ->

mkpat loc

(Some (mkpat loc_any Ppat_any)), false))

| (PaApp (loc, _, _) as f) ->

let (f, al) = patt_fa [] f in

| PaTyc (loc, p, t) ->

mkpat loc (Ppat_constraint ((patt p), (ctyp t)))

| PaTyp (loc, i) -> mkpat loc (Ppat_type (long_type_ident i))

| PaLaz (loc, p) -> mkpat loc (Ppat_lazy (patt p))

| (PaEq (_, _, _) | PaSem (_, _, _) | PaCom (_, _, _) | PaNil _

as p) -> error (loc_of_patt p) "invalid pattern"

and mklabpat =

| Ptyp_arrow (label, core_type, core_type') ->

Ptyp_arrow (label, (loop core_type), (loop core_type'))

| Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst)

| Ptyp_constr (longident, lst) ->

Ptyp_constr (longident, (List.map loop lst))

| Ptyp_object lst ->

function

| Ast.ExAcc (loc, x, (Ast.ExId (_, (Ast.IdLid (_, "val"))))) ->

mkexp loc

[ ("", (expr x)) ]))

| (ExAcc (loc, _, _) | Ast.ExId (loc, (Ast.IdAcc (_, _, _))) as

e) ->

let (e, l) =

(match sep_expr_acc [] e with

let ca = constructors_arity ()

in

((mkexp loc

l)

| (_, [], e) :: l -> ((expr e), l)

| _ -> error loc "bad ast in expression") in

let (_, e) =

List.fold_left

(fun (loc_bp, e1) (loc_ep, ml, e2) ->

match e2 with

let loc = Loc.merge loc_bp loc_ep

in

(loc,

(mkexp loc

| _ ->

error (loc_of_expr e2)

"lowercase identifier expected")

mkexp loc

(Pexp_apply

((mkexp loc

[ ("", (expr e1)); ("", (expr e2)) ]))

| ExArr (loc, e) ->

mkexp loc (Pexp_array (List.map expr (list_of_expr e [])))

(match e with

| Ast.ExAcc (loc, x,

(Ast.ExId (_, (Ast.IdLid (_, "val"))))) ->

[ ("", (expr x)); ("", (expr v)) ])

| ExAcc (loc, _, _) ->

(match (expr e).pexp_desc with

| Pexp_field (e, lab) ->

Pexp_setfield (e, lab, (expr v))

| _ -> error loc "bad record access")

Pexp_apply

((mkexp loc

[ ("", (expr e1)); ("", (expr e2)); ("", (expr v)) ])

Pexp_apply

((mkexp loc

[ ("", (expr e1)); ("", (expr e2)); ("", (expr v)) ])

| _ -> error loc "bad left part of assignment")

in mkexp loc e

let e3 = ExSeq (loc, el)

in

mkexp loc

| Ast.ExFun (loc, (Ast.McArr (_, (PaLab (_, lab, po)), w, e)))

->

mkexp loc

| ExLet (loc, rf, bi, e) ->

mkexp loc (Pexp_let ((mkrf rf), (binding bi []), (expr e)))

| ExLmd (loc, i, me, e) ->

| ExMat (loc, e, a) ->

mkexp loc (Pexp_match ((expr e), (match_case a [])))

| ExNew (loc, id) -> mkexp loc (Pexp_new (long_type_ident id))

let p =

(match po with | Ast.PaNil _ -> Ast.PaAny loc | p -> p) in

let cil = class_str_item cfl []

| ExOlb (loc, _, _) ->

error loc "labeled expression not allowed here"

| ExOvr (loc, iel) ->

mkexp loc

(Pexp_apply

((mkexp loc

[ ("", (expr e1)); ("", (expr e2)) ]))

| ExStr (loc, s) ->

mkexp loc

mkexp loc

(Pexp_constraint ((expr e), (Some (ctyp t)), None))

| Ast.ExId (loc, (Ast.IdUid (_, "()"))) ->

| Ast.ExId (loc, (Ast.IdLid (_, s))) ->

| Ast.ExId (loc, (Ast.IdUid (_, s))) ->

mkexp loc

| ExWhi (loc, e1, el) ->

let e2 = ExSeq (loc, el)

in mkexp loc (Pexp_while ((expr e1), (expr e2)))

and binding x acc =

match x with

| Ast.BiAnd (_, x, y) -> binding x (binding y acc)

(Ast.ExTyc (_, e, (TyTypePol (_, vs, ty))))) ->

let rec id_to_string x =

(match x with

| _ -> assert false) in

let vars = id_to_string vs in

let ampersand_vars = List.map (fun x -> "&" ^ x) vars in

let ty' = varify_constructors vars (ctyp ty) in

let mkexp = mkexp _loc in

let mkpat = mkpat _loc in

let pat =

mkpat

(Ppat_constraint

(mktyp _loc (Ptyp_poly (ampersand_vars, ty')))))) in

let e = mk_newtypes vars in (pat, e) :: acc

| Ast.BiEq (_loc, p,

match x with

| Ast.RbNil _ -> acc

| Ast.RbSem (_, x, y) -> mkideexp x (mkideexp y acc)

| _ -> assert false

and mktype_decl x acc =

match x with

| Ast.TyAnd (_, x, y) -> mktype_decl x (mktype_decl y acc)

let cl =

List.map

(fun (t1, t2) ->

in ((ctyp t1), (ctyp t2), (mkloc loc)))

cl

in

(type_decl

(List.fold_right optional_type_parameters tl []) cl

acc

| _ -> assert false

and module_type =

| Ast.MtId (loc, i) -> mkmty loc (Pmty_ident (long_uident i))

| Ast.MtFun (loc, n, nt, mt) ->

mkmty loc

| Ast.MtQuo (loc, _) ->

error loc "module type variable not allowed here"

| Ast.MtSig (loc, sl) ->

| Ast.SgSem (_, sg1, sg2) -> sig_item sg1 (sig_item sg2 l)

| SgDir (_, _, _) -> l

| Ast.SgExc (loc, (Ast.TyId (_, (Ast.IdUid (_, s))))) ->

| Ast.SgExc (loc,

(Ast.TyOf (_, (Ast.TyId (_, (Ast.IdUid (_, s)))), t))) ->

(mksig loc

(List.map ctyp (list_of_ctyp t []))))) ::

l

| SgExc (_, _) -> assert false

| SgExt (loc, n, t, sl) ->

(mksig loc

l

| SgInc (loc, mt) ->

(mksig loc (Psig_include (module_type mt))) :: l

| SgMod (loc, n, mt) ->

| SgRecMod (loc, mb) ->

(mksig loc (Psig_recmodule (module_sig_binding mb []))) ::

l

(match mt with

| MtQuo (_, _) -> Pmodtype_abstract

| _ -> Pmodtype_manifest (module_type mt))

| SgOpn (loc, id) ->

(mksig loc (Psig_open (long_uident id))) :: l

| SgTyp (loc, tdl) ->

(mksig loc (Psig_type (mktype_decl tdl []))) :: l

| SgVal (loc, n, t) ->

| Ast.SgAnt (loc, _) -> error loc "antiquotation in sig_item"

and module_sig_binding x acc =

match x with

| Ast.MbAnd (_, x, y) ->

module_sig_binding x (module_sig_binding y acc)

| _ -> assert false

and module_str_binding x acc =

match x with

| Ast.MbAnd (_, x, y) ->

module_str_binding x (module_str_binding y acc)

| _ -> assert false

and module_expr =

function

(Pmod_apply ((module_expr me1), (module_expr me2)))

| Ast.MeFun (loc, n, mt, me) ->

mkmod loc

| Ast.MeStr (loc, sl) ->

mkmod loc (Pmod_structure (str_item sl []))

| Ast.MeTyc (loc, me, mt) ->

| StDir (_, _, _) -> l

| Ast.StExc (loc, (Ast.TyId (_, (Ast.IdUid (_, s)))), Ast.

ONone) ->

| Ast.StExc (loc,

(Ast.TyOf (_, (Ast.TyId (_, (Ast.IdUid (_, s)))), t)), Ast.

ONone) ->

(mkstr loc

(List.map ctyp (list_of_ctyp t []))))) ::

l

| Ast.StExc (loc, (Ast.TyId (_, (Ast.IdUid (_, s)))),

(Ast.OSome i)) ->

l

| Ast.StExc (loc,

(Ast.TyOf (_, (Ast.TyId (_, (Ast.IdUid (_, _)))), _)),

| StExp (loc, e) -> (mkstr loc (Pstr_eval (expr e))) :: l

| StExt (loc, n, t, sl) ->

(mkstr loc

l

| StInc (loc, me) ->

(mkstr loc (Pstr_include (module_expr me))) :: l

| StMod (loc, n, me) ->

| StRecMod (loc, mb) ->

(mkstr loc (Pstr_recmodule (module_str_binding mb []))) ::

l

| StMty (loc, n, mt) ->

| StOpn (loc, id) ->

(mkstr loc (Pstr_open (long_uident id))) :: l

| StTyp (loc, tdl) ->

| CtFun (loc, (TyLab (_, lab, t)), ct) ->

mkcty loc (Pcty_fun (lab, (ctyp t), (class_type ct)))

| CtFun (loc, (TyOlb (loc1, lab, t)), ct) ->

in

mkcty loc

(Pcty_fun (("?" ^ lab), (ctyp t), (class_type ct)))

let t =

(match t_o with | Ast.TyNil _ -> Ast.TyAny loc | t -> t) in

let cil = class_sig_item ctfl []

| CtCon (loc, _, _, _) ->

error loc "invalid virtual class inside a class type"

| CtAnt (_, _) | CtEq (_, _, _) | CtCol (_, _, _) |

CtAnd (_, _, _) | CtNil _ -> assert false

and class_info_class_expr ci =

match ci with

let (loc_params, (params, variance)) =

(match params with

| Ast.TyNil _ -> (loc, ([], []))

{

pci_virt = mkvirtual vir;

pci_params = (params, (mkloc loc_params));

pci_expr = class_expr ce;

pci_loc = mkloc loc;

pci_variance = variance;

| ce -> error (loc_of_class_expr ce) "bad class definition"

and class_info_class_type ci =

match ci with

ct)

->

let (loc_params, (params, variance)) =

{

pci_virt = mkvirtual vir;

pci_params = (params, (mkloc loc_params));

pci_expr = class_type ct;

pci_loc = mkloc loc;

pci_variance = variance;

match c with

| Ast.CgNil _ -> l

| CgCtr (loc, t1, t2) ->

| Ast.CgSem (_, csg1, csg2) ->

class_sig_item csg1 (class_sig_item csg2 l)

| CgMth (loc, s, pf, t) ->

l

| CgVal (loc, s, b, v, t) ->

l

| CgVir (loc, s, b, t) ->

l

| CgAnt (_, _) -> assert false

and class_expr =

| (CeApp (loc, _, _) as c) ->

let (ce, el) = class_expr_fa [] c in

let el = List.map label_expr el

| CeCon (loc, ViNil, id, tl) ->

(Pcl_constr ((long_class_ident id),

(List.map ctyp (list_of_opt_ctyp tl []))))

| CeFun (loc, (PaLab (_, lab, po)), ce) ->

(Pcl_fun (lab, None, (patt_of_lab loc lab po),

(class_expr ce)))

| CeFun (loc, (PaOlbi (_, lab, p, e)), ce) ->

let lab = paolab lab p

in

(Pcl_fun (("?" ^ lab), (Some (expr e)), (patt p),

(class_expr ce)))

| CeFun (loc, (PaOlb (_, lab, p)), ce) ->

let lab = paolab lab p

in

(Pcl_fun (("?" ^ lab), None, (patt_of_lab loc lab p),

(class_expr ce)))

| CeFun (loc, p, ce) ->

| CeLet (loc, rf, bi, ce) ->

(Pcl_let ((mkrf rf), (binding bi []), (class_expr ce)))

| CeStr (loc, po, cfl) ->

let p =

(match po with | Ast.PaNil _ -> Ast.PaAny loc | p -> p) in

let cil = class_str_item cfl []

| CeTyc (loc, ce, ct) ->

(Pcl_constraint ((class_expr ce), (class_type ct)))

| CeCon (loc, _, _, _) ->

error loc "invalid virtual class inside a class expression"

match c with

| CrNil _ -> l

| CrCtr (loc, t1, t2) ->

| Ast.CrSem (_, cst1, cst2) ->

class_str_item cst1 (class_str_item cst2 l)

| CrInh (loc, ov, ce, pb) ->

let opb = if pb = "" then None else Some pb

in

l

| CrMth (loc, s, ov, pf, e, t) ->

let t =

(match t with

| t -> Some (mkpolytype (ctyp t))) in

let e = mkexp loc (Pexp_poly ((expr e), t))

in

l

| CrVal (loc, s, ov, mf, e) ->

l

| CrVir (loc, s, pf, t) ->

l

| CrVvr (loc, s, mf, t) ->

l

| CrAnt (_, _) -> assert false

| ExInt (_, i) -> Pdir_int (int_of_string i)

| Ast.ExId (_, (Ast.IdUid (_, "True"))) -> Pdir_bool true

| Ast.ExId (_, (Ast.IdUid (_, "False"))) -> Pdir_bool false

let phrase =

function

let drop_prev_loc = Tools.drop_prev_loc

let add_loc bp parse_fun strm =

let x = parse_fun strm in

let stream_peek_nth strm n =

let rec loop i =

in Some t

| None -> None)

| LocAct (_, _) | DeadEnd -> None

in insert gsymbols tree

let insert_level entry e1 symbols action slev =

"Cannot print %S this identifier does not respect OCaml lexing rules (%s)"

str (Lexer.Error.to_string exn))

let rec get_expr_args a al =

match a with

fun f t ->

match Ast.list_of_ctyp t [] with

| [] -> ()

method string = fun f -> pp f "%s"

method quoted_string = fun f -> pp f "%S"

method numeric =

| Ast.ExInt64 (_, s) -> o#numeric f s "L"

| Ast.ExInt32 (_, s) -> o#numeric f s "l"

| Ast.ExFlo (_, s) -> o#numeric f s ""

| Ast.ExId (_, i) -> o#var_ident f i

| Ast.ExRec (_, b, (Ast.ExNil _)) ->

pp f "@[<hv0>@[<hv2>{%a@]@ }@]" o#record_binding b

| Ast.PaInt32 (_, s) -> o#numeric f s "l"

| Ast.PaInt (_, s) -> o#numeric f s ""

| Ast.PaFlo (_, s) -> o#numeric f s ""

| Ast.PaLab (_, s, (Ast.PaNil _)) -> pp f "~%s" s

| Ast.PaVrn (_, s) -> pp f "`%a" o#var s

| Ast.PaTyp (_, i) -> pp f "@[<2>#%a@]" o#ident i

in

match ce with

| Ast.CeApp (_, ce, e) ->

| Ast.CeCon (_, Ast.ViNil, i, (Ast.TyNil _)) ->

pp f "@[<2>%a@]" o#ident i

| Ast.CeCon (_, Ast.ViNil, i, t) ->

value meta_loc = meta_loc_expr;

module Expr =

struct

value meta_int _loc s = Ast.ExInt _loc s;

value meta_float _loc s = Ast.ExFlo _loc s;

value meta_bool _loc =

fun

[ False -> Ast.ExId _loc (Ast.IdUid _loc "False")

(* source tree. *)

(* *)

(****************************************************************************)

'a 'a_out.

('self_type -> 'a -> 'a_out) ->

meta_option 'a -> meta_option 'a_out =

let stopped_at _loc = Some (Loc.move_line 1 _loc)

(* FIXME be more precise *)

let symbolchar =

let list =

[ '$'; '!'; '%'; '&'; '*'; '+'; '-'; '.'; '/'; ':'; '<'; '=';

(match Stream.peek __strm with

| Some

((KEYWORD

as i)),

_loc))

->

[ (None, (Some Camlp4.Sig.Grammar.RightA),

[ ([ Gram.Snterm

(Gram.Entry.obj

Gram.Sself ],

(Gram.Action.mk

(fun (e : 'fun_binding) (p : 'labeled_ipatt)

(Ast.McArr (_loc, p, (Ast.ExNil _loc), e))) :

'fun_binding))));

([ Gram.Stry

(Gram.srules fun_binding

[ ([ Gram.Skeyword "("; Gram.Skeyword "type" ],

(Gram.Action.mk

([ Gram.Snterm

(Gram.Entry.obj

(label_ipatt : 'label_ipatt Gram.Entry.t));

Gram.Skeyword ";"; Gram.Sself ],

(Gram.Action.mk

(fun (p2 : 'label_ipatt_list) _

(a_UIDENT : 'a_UIDENT Gram.Entry.t));

Gram.Skeyword ":";

Gram.Snterm

(Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ],

(Gram.Action.mk

'constructor_declarations))));

([ Gram.Snterm

(Gram.Entry.obj

(Gram.Action.mk

(fun (st2 : 'str_item_quot) _ (st1 : 'str_item)

(_loc : Gram.Loc.t) ->

([ Gram.Skeyword "#";

Gram.Snterm

(Gram.Entry.obj

(Gram.Action.mk

(fun (sg2 : 'sig_item_quot) _ (sg1 : 'sig_item)

(_loc : Gram.Loc.t) ->

([ Gram.Skeyword "#";

Gram.Snterm

(Gram.Entry.obj

(Gram.Action.mk

(fun (x2 : 'class_str_item_quot) _

(x1 : 'class_str_item) (_loc : Gram.Loc.t) ->

'class_str_item_quot)))) ]) ]))

());

Gram.extend

(Gram.Action.mk

(fun (x2 : 'class_sig_item_quot) _

(x1 : 'class_sig_item) (_loc : Gram.Loc.t) ->

'class_sig_item_quot)))) ]) ]))

());

Gram.extend (with_constr_quot : 'with_constr_quot Gram.Entry.t)

DEFINE <lident> = <expression> IN <expression>

__FILE__

__LOCATION__

In patterns:

The expression __FILE__ returns the current compiled file name.

The expression __LOCATION__ returns the current location of itself.

*)

open Camlp4

Ast.ExId (_, (Ast.IdUid (_, x)))

as e) ->

(try List.assoc x env with | Not_found -> super#expr e)

| e -> super#expr e

method patt =

function

(i : 'uident) _ (_loc : Gram.Loc.t) ->

(if is_defined i then e1 else e2 : 'expr)))) ]) ]))

());

Gram.extend (patt : 'patt Gram.Entry.t)

((fun () ->

(None,

open Ast

function

| Ast.ExApp (_, e, (Ast.ExId (_, (Ast.IdUid (_, "NOTHING"))))) |

Ast.ExFun (_,

(Ast.McArr (_, (Ast.PaId (_, (Ast.IdUid (_, "NOTHING")))),

(Ast.ExNil _), e)))

-> e

| e -> e

end

show_information.cmi question.cmi program_management.cmi primitives.cmi \

parameters.cmi ../utils/misc.cmi input_handling.cmi frames.cmi exec.cmi \

../typing/env.cmi debugger_config.cmi ../utils/config.cmi \

main.cmx: unix_tools.cmx $(UNIXDIR)/unix.cmx time_travel.cmx \

show_information.cmx question.cmx program_management.cmx primitives.cmx \

parameters.cmx ../utils/misc.cmx input_handling.cmx frames.cmx exec.cmx \

../typing/env.cmx debugger_config.cmx ../utils/config.cmx \

parameters.cmo: primitives.cmi envaux.cmi debugger_config.cmi \

../utils/config.cmi parameters.cmi

parameters.cmx: primitives.cmx envaux.cmx debugger_config.cmx \

include ../config/Makefile

CAMLC=../ocamlcomp.sh

CAMLYACC=../boot/ocamlyacc

YACCFLAGS=

CAMLLEX=../boot/ocamlrun ../boot/ocamllex

../typing/ident.cmo ../typing/path.cmo ../typing/types.cmo \

../typing/btype.cmo ../typing/primitive.cmo ../typing/typedtree.cmo \

../typing/subst.cmo ../typing/predef.cmo \

../typing/ctype.cmo ../typing/printtyp.cmo ../typing/mtype.cmo \

../bytecomp/runtimedef.cmo ../bytecomp/bytesections.cmo \

../bytecomp/dll.cmo ../bytecomp/meta.cmo ../bytecomp/symtable.cmo \

with

| Exit ->

stop_user_input ()

(** Instructions. **)

let instr_cd ppf lexbuf =

let extract_sig env mty =

match Mtype.scrape env mty with

| _ -> fatal_error "Envaux.extract_sig"

let rec env_from_summary sum subst =

[] ->

raise(Error(Wrong_label(ty, lbl)))

| (name, mut, ty_arg) :: rem ->

let ty_res =

Btype.newgenty(Tconstr(path, tydesc.type_params, ref Mnil))

in

Env.report_error err_formatter e;

eprintf "@]@.";

exit 2

let _ =

Printexc.catch (Unix.handle_unix_error main) ()

(*** Program loading and initializations. ***)

let initialize_loading () =

prerr_endline "Loading debugging information...";

begin try access !program_name [F_OK]

with Unix_error _ ->

prerr_endline "Program not found.";

try

(String.sub m 0 len') = m' && (String.get m len') = '.'

with

let path =

Hashtbl.fold

(fun mdl dirs acc ->

Debugger_config.load_path_for

!Config.load_path in

let fname = pos.Lexing.pos_fname in

find_in_path path fname

else

fname

(* Return the full path if found. *)

(* Raise `Not_found' otherwise. *)

let search_in_path name =

let check name =

try access name [X_OK]; name with Unix_error _ -> raise Not_found

in

open Misc

open Config

open Format

(* Initialize the search path.

The current directory is always searched first,

check_unit_name ppf sourcefile modulename;

Env.set_unit_name modulename;

let inputfile = Pparse.preprocess sourcefile in

try

let ast =

Pparse.file ppf inputfile Parse.interface ast_intf_magic_number in

if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast;

if !Clflags.print_types then

fprintf std_formatter "%a@." Printtyp.signature

(Typemod.simplify_signature sg);

Typecore.force_delayed_checks ();

Warnings.check_fatal ();

Pparse.remove_preprocessed inputfile

with e ->

Pparse.remove_preprocessed_if_ast inputfile;

++ Typemod.type_implementation sourcefile outputprefix modulename env);

Warnings.check_fatal ();

Pparse.remove_preprocessed inputfile;

with x ->

Pparse.remove_preprocessed_if_ast inputfile;

raise x

end else begin

let objfile = outputprefix ^ ".cmo" in

Warnings.check_fatal ();

close_out oc;

Pparse.remove_preprocessed inputfile;

with x ->

close_out oc;

remove_file objfile;

Pparse.remove_preprocessed_if_ast inputfile;

raise x

end

| Env.Error err ->

Location.print_error_cur_file ppf;

Env.report_error ppf err

| Ctype.Tags(l, l') ->

Location.print_error_cur_file ppf;

fprintf ppf

let _a = set make_archive

let _absname = set Location.absname

let _annot = set annotations

let _c = set compile_only

let _cc s = c_compiler := Some s

let _cclib s = ccobjs := Misc.rev_split_words s @ !ccobjs

"-annot", Arg.Unit f, " Save information in <filename>.annot"

;;

let mk_c f =

"-c", Arg.Unit f, " Compile only (do not link)"

;;

val _a : unit -> unit

val _absname : unit -> unit

val _annot : unit -> unit

val _c : unit -> unit

val _cc : string -> unit

val _cclib : string -> unit

val _a : unit -> unit

val _absname : unit -> unit

val _annot : unit -> unit

val _c : unit -> unit

val _cc : string -> unit

val _cclib : string -> unit

mk_a F._a;

mk_absname F._absname;

mk_annot F._annot;

mk_c F._c;

mk_cc F._cc;

mk_cclib F._cclib;

mk_a F._a;

mk_absname F._absname;

mk_annot F._annot;

mk_c F._c;

mk_cc F._cc;

mk_cclib F._cclib;

val _a : unit -> unit

val _absname : unit -> unit

val _annot : unit -> unit

val _c : unit -> unit

val _cc : string -> unit

val _cclib : string -> unit

val _a : unit -> unit

val _absname : unit -> unit

val _annot : unit -> unit

val _c : unit -> unit

val _cc : string -> unit

val _cclib : string -> unit

open Misc

open Config

open Format

(* Initialize the search path.

The current directory is always searched first,

check_unit_name ppf sourcefile modulename;

Env.set_unit_name modulename;

let inputfile = Pparse.preprocess sourcefile in

try

let ast =

Pparse.file ppf inputfile Parse.interface ast_intf_magic_number in

if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast;

if !Clflags.print_types then

fprintf std_formatter "%a@." Printtyp.signature

(Typemod.simplify_signature sg);

Typecore.force_delayed_checks ();

Warnings.check_fatal ();

Pparse.remove_preprocessed inputfile;

with e ->

Pparse.remove_preprocessed_if_ast inputfile;

raise e

(* Compile a .ml file *)

end;

Warnings.check_fatal ();

Pparse.remove_preprocessed inputfile;

with x ->

remove_file objfile;

remove_file cmxfile;

Pparse.remove_preprocessed_if_ast inputfile;

raise x

let c_file name =

| Env.Error err ->

Location.print_error_cur_file ppf;

Env.report_error ppf err

| Ctype.Tags(l, l') ->

Location.print_error_cur_file ppf;

fprintf ppf

let _a = set make_archive

let _absname = set Location.absname

let _annot = set annotations

let _c = set compile_only

let _cc s = c_compiler := Some s

let _cclib s = ccobjs := Misc.rev_split_words s @ !ccobjs

val ccomptype : string

val extralibs : string

val tk_defs : string

$(OCAMLSRCDIR)/typing/predef.cmo \

$(OCAMLSRCDIR)/typing/datarepr.cmo \

$(OCAMLSRCDIR)/typing/subst.cmo \

$(OCAMLSRCDIR)/typing/env.cmo \

$(OCAMLSRCDIR)/typing/ctype.cmo \

$(OCAMLSRCDIR)/typing/primitive.cmo \

$(OCAMLSRCDIR)/typing/typedtree.cmo \

$(OCAMLSRCDIR)/typing/parmatch.cmo \

$(OCAMLSRCDIR)/typing/stypes.cmo \

$(OCAMLSRCDIR)/typing/typecore.cmo \

$(OCAMLSRCDIR)/typing/includeclass.cmo \

$(OCAMLSRCDIR)/typing/typedecl.cmo \

$(OCAMLSRCDIR)/typing/predef.cmo \

$(OCAMLSRCDIR)/typing/datarepr.cmo \

$(OCAMLSRCDIR)/typing/subst.cmo \

$(OCAMLSRCDIR)/typing/env.cmo \

$(OCAMLSRCDIR)/typing/ctype.cmo \

$(OCAMLSRCDIR)/typing/primitive.cmo \

let env = initial_env () in

try

let parsetree = parse_file inputfile Parse.implementation ast_impl_magic_number in

(Some (parsetree, typedtree), inputfile)

with

e ->

| Env.Error err ->

Location.print_error_cur_file ppf;

Env.report_error ppf err

| Ctype.Tags(l, l') ->

Location.print_error_cur_file ppf;

fprintf ppf

try

let (ast, signat, input_file) = process_interface_file ppf file in

let file_module = Sig_analyser.analyse_signature file

in

file_module.Odoc_module.m_top_deps <- Odoc_dep.intf_dependencies ast ;

let m =

{

Odoc_module.m_name = mod_name ;

Odoc_module.m_info = None ;

Odoc_module.m_is_interface = true ;

Odoc_module.m_file = file ;

| P of string

| IM of string

type tab_values = (Odoc_module.Name.t, Typedtree.pattern * Typedtree.expression) Hashtbl.t

let iter_val_pattern = function

| Typedtree.Tpat_any -> None

| Typedtree.Tpat_tuple _ -> None (* A VOIR quand on traitera les tuples *)

| _ -> None

let add_to_hashes table table_values tt =

match tt with

Hashtbl.add table (M (Name.from_ident ident)) tt

| Typedtree.Tstr_recmodule mods ->

List.iter

Hashtbl.add table (M (Name.from_ident ident))

)

mods

Hashtbl.add table (MT (Name.from_ident ident)) tt

Hashtbl.add table (E (Name.from_ident ident)) tt

Hashtbl.add table (ER (Name.from_ident ident)) tt

| Typedtree.Tstr_type ident_type_decl_list ->

List.iter

Hashtbl.add table (T (Name.from_ident id))

ident_type_decl_list

| Typedtree.Tstr_class info_list ->

List.iter

info_list

List.iter

Hashtbl.add table

(CT (Name.from_ident id))

info_list

| Typedtree.Tstr_value (_, pat_exp_list) ->

List.iter

| Some n -> Hashtbl.add table_values n (pat,exp)

)

pat_exp_list

Hashtbl.add table (P (Name.from_ident ident)) tt

| Typedtree.Tstr_open _ -> ()

| Typedtree.Tstr_include _ -> ()

let tables typedtree =

let t = Hashtbl.create 13 in

let t_values = Hashtbl.create 13 in

(t, t_values)

let search_module table name =

match Hashtbl.find table (M name) with

| _ -> assert false

let search_module_type table name =

match Hashtbl.find table (MT name) with

| _ -> assert false

let search_exception table name =

match Hashtbl.find table (E name) with

| _ -> assert false

let search_exception_rebind table name =

match Hashtbl.find table (ER name) with

| _ -> assert false

let search_type_declaration table name =

match Hashtbl.find table (T name) with

| _ -> assert false

let search_class_exp table name =

match Hashtbl.find table (C name) with

(

try

let type_decl = search_type_declaration table name in

with

Not_found ->

(ce, [])

let search_class_type_declaration table name =

match Hashtbl.find table (CT name) with

| _ -> assert false

let search_value table name = Hashtbl.find table name

let search_primitive table name =

match Hashtbl.find table (P name) with

| _ -> assert false

let get_nth_inherit_class_expr cls n =

let rec iter cpt = function

| [] ->

raise Not_found

if n = cpt then clexp else iter (cpt+1) q

| _ :: q ->

iter cpt q

in

let search_attribute_type cls name =

let rec iter = function

| [] ->

raise Not_found

when Name.from_ident ident = name ->

exp.Typedtree.exp_type

| _ :: q ->

iter q

in

let class_sig_of_cltype_decl =

let rec iter = function

in

fun ct_decl -> iter ct_decl.Types.clty_type

let search_virtual_attribute_type table ctname name =

let ct_decl = search_class_type_declaration table ctname in

let (_,_,texp) = Types.Vars.find name cls_sig.cty_vars in

texp

let rec iter = function

| [] ->

raise Not_found

exp

| _ :: q ->

iter q

in

end

module Analyser =

let tt_param_info_from_pattern env f_desc pat =

let rec iter_pattern pat =

match pat.pat_desc with

let name = Name.from_ident ident in

Simple_name { sn_name = name ;

sn_text = f_desc name ;

sn_type = Odoc_env.subst_type env pat.pat_type

}

iter_pattern pat

| Typedtree.Tpat_tuple patlist ->

(List.map iter_pattern patlist,

Odoc_env.subst_type env pat.pat_type)

(* we give a name to the parameter only if it unit *)

(match cons_desc.cstr_res.desc with

Tconstr (p, _, _) ->

(

(

match func_body.exp_desc with

let name = Name.from_ident id in

let new_param = Simple_name

{ sn_name = name ;

in

(* continue if the body is still a function *)

match next_exp.exp_desc with

p :: (tt_analyse_function_parameters env current_comment_opt pat_exp_list)

| _ ->

(* something else ; no more parameter *)

let tt_analyse_value env current_module_name comment_opt loc pat_exp rec_flag =

let (pat, exp) = pat_exp in

match (pat.pat_desc, exp.exp_desc) with

(* a new function is defined *)

let name_pre = Name.from_ident ident in

let name = Name.parens_if_infix name_pre in

in

[ new_value ]

(* a new value is defined *)

let name_pre = Name.from_ident ident in

let name = Name.parens_if_infix name_pre in

);

*)

match clexp.Typedtree.cl_desc with

(*

| Typedtree.Tclass_fun (_, _, class_expr, _) -> tt_name_of_class_expr class_expr

| Typedtree.Tclass_let (_,_,_, class_expr) -> tt_name_of_class_expr class_expr

*)

let rec tt_analyse_method_expression env current_method_name comment_opt ?(first=true) exp =

match exp.Typedtree.exp_desc with

(

match pat_exp_list with

[] ->

(

(

match body.exp_desc with

let name = Name.from_ident id in

let new_param = Simple_name

{ sn_name = name ;

ele_coms

in

(acc_inher, acc_fields @ ele_comments)

let tt_clexp =

let n = List.length acc_inher in

try Typedtree_search.get_nth_inherit_class_expr tt_cls n

p_clexp.Parsetree.pcl_loc.Location.loc_end.Lexing.pos_cnum

q

let virt = match x with Parsetree.Pcf_val _ -> false | _ -> true in

let complete_name = Name.concat current_class_name label in

let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in

in

iter acc_inher (acc_fields @ ele_comments @ [ Class_attribute att ]) loc.Location.loc_end.Lexing.pos_cnum q

let complete_name = Name.concat current_class_name label in

let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in

let met_type =

iter acc_inher (acc_fields @ ele_comments @ [ Class_method met ]) loc.Location.loc_end.Lexing.pos_cnum q

let complete_name = Name.concat current_class_name label in

let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in

let exp =

iter acc_inher (acc_fields @ ele_comments @ [ Class_method met ]) loc.Location.loc_end.Lexing.pos_cnum q

(* don't give a $*%@ ! *)

iter acc_inher acc_fields loc.Location.loc_end.Lexing.pos_cnum q

iter acc_inher acc_fields exp.Parsetree.pexp_loc.Location.loc_end.Lexing.pos_cnum q

in

(** Analysis of a [Parsetree.class_expr] and a [Typedtree.class_expr] to get a a couple (class parameters, class kind). *)

let rec analyse_class_kind env current_class_name comment_opt last_pos p_class_expr tt_class_exp table =

(Parsetree.Pcl_constr (lid, _), tt_class_exp_desc ) ->

let name =

match tt_class_exp_desc with

| _ ->

(* we try to get the name from the environment. *)

(* A VOIR : dommage qu'on n'ait pas un Tclass_ident :-( m�me quand on a class tutu = toto *)

in

(* On n'a pas ici les param�tres de type sous forme de Types.type_expr,

par contre on peut les trouver dans le class_type *)

let params =

match tt_class_exp.Typedtree.cl_type with

(* cltyp is the class type for [type_exp_list] p *)

type_exp_list

| _ ->

cco_type_parameters = List.map (Odoc_env.subst_type env) params ;

} )

(* we need the class signature to get the type of methods in analyse_class_structure *)

let tt_class_sig =

match tt_class_exp.Typedtree.cl_type with

| _ -> raise (Failure "analyse_class_kind: no class signature for a class structure.")

in

let (inherited_classes, class_elements) = analyse_class_structure

Class_structure (inherited_classes, class_elements) )

| (Parsetree.Pcl_fun (label, expression_opt, pattern, p_class_expr2),

(* we check that this is not an optional parameter with

a default value. In this case, we look for the good parameter pattern *)

let (parameter, next_tt_class_exp) =

match pat.Typedtree.pat_desc with

(

match tt_class_expr2.Typedtree.cl_desc with

let name = Name.from_ident id in

let new_param = Simple_name

{ sn_name = name ;

in

(parameter :: params, k)

let applied_name =

(* we want an ident, or else the class applied will appear in the form object ... end,

because if the class applied has no name, the code is kinda ugly, isn't it ? *)

match tt_class_expr2.Typedtree.cl_desc with

| _ ->

(* A VOIR : dommage qu'on n'ait pas un Tclass_ident :-( m�me quand on a class tutu = toto *)

match p_class_expr2.Parsetree.pcl_desc with

Parsetree.Pcl_constr (lid, _) ->

(* we try to get the name from the environment. *)

| _ ->

Odoc_messages.object_end

in

let param_exps = List.fold_left

match exp_opt with

None -> acc

| Some e -> acc @ [e])

capp_params_code = params_code ;

} )

(* we don't care about these lets *)

analyse_class_kind

env current_class_name comment_opt last_pos p_class_expr2

tt_class_expr2 table

| (Parsetree.Pcl_constraint (p_class_expr2, p_class_type2),

let (l, class_kind) = analyse_class_kind

env current_class_name comment_opt last_pos p_class_expr2

tt_class_expr2 table

(** Analysis of a [Parsetree.class_declaration] and a [Typedtree.class_expr] to return a [t_class].*)

let analyse_class env current_module_name comment_opt p_class_decl tt_type_params tt_class_exp table =

let name = p_class_decl.Parsetree.pci_name in

let pos_start = p_class_decl.Parsetree.pci_expr.Parsetree.pcl_loc.Location.loc_start.Lexing.pos_cnum in

let type_parameters = tt_type_params in

let virt = p_class_decl.Parsetree.pci_virt = Asttypes.Virtual in

is not an ident of a constraint on an ident. *)

let rec tt_name_from_module_expr mod_expr =

match mod_expr.Typedtree.mod_desc with

| Typedtree.Tmod_structure _

| Typedtree.Tmod_functor _

| Typedtree.Tmod_apply _

(** Get the list of included modules in a module structure of a typed tree. *)

let tt_get_included_module_list tt_structure =

let f acc item =

Typedtree.Tstr_include (mod_expr, _) ->

acc @ [

{ (* A VOIR : chercher dans les modules et les module types, avec quel env ? *)

| _ ->

acc

in

(** This function takes a [module element list] of a module and replaces the "dummy" included modules with

the ones found in typed tree structure of the module. *)

and the module has a "structure" kind. *)

let rec filter_module_with_module_type_constraint m mt =

match m.m_kind, mt with

m.m_kind <- Module_struct (filter_module_elements_with_module_type_constraint l lsig);

m.m_type <- mt;

| _ -> ()

and the module type has a "structure" kind. *)

and filter_module_type_with_module_type_constraint mtyp mt =

match mtyp.mt_kind, mt with

mtyp.mt_kind <- Some (Module_type_struct (filter_module_elements_with_module_type_constraint l lsig));

mtyp.mt_type <- Some mt;

| _ -> ()

let f = match ele with

Element_module m ->

(function

let n1 = Name.simple m.m_name

and n2 = Ident.name ident in

(

| _ -> false)

| Element_module_type mt ->

(function

let n1 = Name.simple mt.mt_name

and n2 = Ident.name ident in

(

| _ -> false)

| Element_value v ->

(function

let n1 = Name.simple v.val_name

and n2 = Ident.name ident in

n1 = n2

| _ -> false)

| Element_type t ->

(function

(* A VOIR: il est possible que le d�tail du type soit cach� *)

let n1 = Name.simple t.ty_name

and n2 = Ident.name ident in

| _ -> false)

| Element_exception e ->

(function

let n1 = Name.simple e.ex_name

and n2 = Ident.name ident in

n1 = n2

| _ -> false)

| Element_class c ->

(function

let n1 = Name.simple c.cl_name

and n2 = Ident.name ident in

n1 = n2

| _ -> false)

| Element_class_type ct ->

(function

let n1 = Name.simple ct.clt_name

and n2 = Ident.name ident in

n1 = n2

(** Analysis of a parse tree structure with a typed tree, to return module elements.*)

let rec analyse_structure env current_module_name last_pos pos_limit parsetree typedtree =

print_DEBUG "Odoc_ast:analyse_struture";

let rec iter env last_pos = function

[] ->

let s = get_string_of_file last_pos pos_limit in

iter new_last_pos acc_env acc q

| Some name ->

try

let (info_opt, ele_comments) =

(* we already have the optional comment for the first value. *)

if first then

let (new_env, l_ele) = iter ~first: true loc.Location.loc_start.Lexing.pos_cnum env [] pat_exp_list in

(0, new_env, l_ele)

(* of string * value_description *)

print_DEBUG ("Parsetree.Pstr_primitive ("^name_pre^", ["^(String.concat ", " val_desc.Parsetree.pval_prim)^"]");

let typ = Typedtree_search.search_primitive table name_pre in

(* we start by extending the environment *)

let new_env =

List.fold_left

let complete_name = Name.concat current_module_name name in

Odoc_env.add_type acc_env complete_name

)

let rec f ?(first=false) maybe_more_acc last_pos name_type_decl_list =

match name_type_decl_list with

[] -> (maybe_more_acc, [])

let complete_name = Name.concat current_module_name name in

let loc_start = type_decl.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum in

let loc_end = type_decl.Parsetree.ptype_loc.Location.loc_end.Lexing.pos_cnum in

in

let (maybe_more, name_comment_list) =

Sig.name_comment_from_type_kind

new_env name_comment_list

tt_type_decl.Types.type_kind

in

| Parsetree.Pstr_exception (name, excep_decl) ->

(* a new exception is defined *)

(* we get the exception declaration in the typed tree *)

let tt_excep_decl =

with Not_found ->

raise (Failure (Odoc_messages.exception_not_found_in_typedtree complete_name))

in

{

ex_name = complete_name ;

ex_info = comment_opt ;

ex_alias = None ;

ex_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ;

ex_code =

in

(0, new_env, [ Element_exception new_ex ])

(* a new exception is defined *)

(* we get the exception rebind in the typed tree *)

let tt_path =

with Not_found ->

raise (Failure (Odoc_messages.exception_not_found_in_typedtree complete_name))

in

(

(* of string * module_expr *)

try

let new_module_pre = analyse_module

env

current_module_name

comment_opt

module_expr

tt_module_expr

let new_env2 =

match new_module.m_type with

(* A VOIR : cela peut-il �tre Tmty_ident ? dans ce cas, on aurait pas la signature *)

Odoc_env.add_signature new_env new_module.m_name

~rel: (Name.simple new_module.m_name) s

| _ ->

(0, new_env2, [ Element_module new_module ])

with

Not_found ->

raise (Failure (Odoc_messages.module_not_found_in_typedtree complete_name))

)

let new_env =

List.fold_left

(fun acc_env (name, _, mod_exp) ->

let e = Odoc_env.add_module acc_env complete_name in

let tt_mod_exp =

with Not_found -> raise (Failure (Odoc_messages.module_not_found_in_typedtree complete_name))

in

let new_module = analyse_module

e

current_module_name

None

mod_exp

tt_mod_exp

in

match new_module.m_type with

Odoc_env.add_signature e new_module.m_name

~rel: (Name.simple new_module.m_name) s

| _ ->

match name_mod_exp_list with

[] -> []

| (name, _, mod_exp) :: q ->

let loc_start = mod_exp.Parsetree.pmod_loc.Location.loc_start.Lexing.pos_cnum in

let loc_end = mod_exp.Parsetree.pmod_loc.Location.loc_end.Lexing.pos_cnum in

let tt_mod_exp =

with Not_found -> raise (Failure (Odoc_messages.module_not_found_in_typedtree complete_name))

in

let (com_opt, ele_comments) = (* the comment for the first type was already retrieved *)

let new_module = analyse_module

new_env

current_module_name

com_opt

mod_exp

tt_mod_exp

(0, new_env, eles)

| Parsetree.Pstr_modtype (name, modtype) ->

let tt_module_type =

with Not_found ->

raise (Failure (Odoc_messages.module_type_not_found_in_typedtree complete_name))

in

let kind = Sig.analyse_module_type_kind env complete_name

in

let mt =

{

mt_name = complete_name ;

mt_info = comment_opt ;

mt_is_interface = false ;

mt_file = !file_name ;

mt_kind = Some kind ;

in

let new_env = Odoc_env.add_module_type env mt.mt_name in

let new_env2 =

(* A VOIR : cela peut-il �tre Tmty_ident ? dans ce cas, on n'aurait pas la signature *)

Odoc_env.add_signature new_env mt.mt_name ~rel: (Name.simple mt.mt_name) s

| _ ->

new_env

let new_env =

List.fold_left

(fun acc_env -> fun class_decl ->

Odoc_env.add_class acc_env complete_name

)

env

[]

| class_decl :: q ->

let (tt_class_exp, tt_type_params) =

with Not_found ->

raise (Failure (Odoc_messages.class_not_found_in_typedtree complete_name))

in

let (com_opt, ele_comments) =

let new_env =

List.fold_left

(fun acc_env -> fun class_type_decl ->

Odoc_env.add_class_type acc_env complete_name

)

env

[]

| class_type_decl :: q ->

let name = class_type_decl.Parsetree.pci_name in

let virt = class_type_decl.Parsetree.pci_virt = Asttypes.Virtual in

let tt_cltype_declaration =

with Not_found ->

raise (Failure (Odoc_messages.class_type_not_found_in_typedtree complete_name))

let type_params = tt_cltype_declaration.Types.clty_params in

let kind = Sig.analyse_class_type_kind

new_env

}

in

match (p_module_expr.Parsetree.pmod_desc, tt_module_expr.Typedtree.mod_desc) with

let alias_name = Odoc_env.full_module_name env (Name.from_path path) in

{ m_base with m_kind = Module_alias { ma_name = alias_name ;

ma_module = None ; } }

{ m_base with m_kind = Module_struct elements2 }

| (Parsetree.Pmod_functor (_, pmodule_type, p_module_expr2),

let loc_start = pmodule_type.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in

let loc_end = pmodule_type.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in

let mp_type_code = get_string_of_file loc_start loc_end in

print_DEBUG (Printf.sprintf "mp_type_code=%s" mp_type_code);

let mp_name = Name.from_ident ident in

let mp_kind = Sig.analyse_module_type_kind env

in

let param =

{

mp_name = mp_name ;

mp_type_code = mp_type_code ;

mp_kind = mp_kind ;

}

Typedtree.Tmod_apply (tt_module_expr1, tt_module_expr2, _))

| (Parsetree.Pmod_apply (p_module_expr1, p_module_expr2),

Typedtree.Tmod_constraint

_, _)

) ->

let m1 = analyse_module

{ m_base with m_kind = Module_apply (m1.m_kind, m2.m_kind) }

| (Parsetree.Pmod_constraint (p_module_expr2, p_modtype),

print_DEBUG ("Odoc_ast: case Parsetree.Pmod_constraint + Typedtree.Tmod_constraint "^module_name);

let m_base2 = analyse_module

env

| (Parsetree.Pmod_structure p_structure,

Typedtree.Tmod_constraint

({ Typedtree.mod_desc = Typedtree.Tmod_structure tt_structure},

) ->

(* needed for recursive modules *)

m_kind = Module_struct elements2 ;

}

Typedtree.Tmod_unpack (t_exp, tt_modtype)) ->

print_DEBUG ("Odoc_ast: case Parsetree.Pmod_unpack + Typedtree.Tmod_unpack "^module_name);

let code =

(* let name = Odoc_env.full_module_type_name env (Name.from_path (fst pkg_type)) in *)

let name =

match tt_modtype with

Odoc_env.full_module_type_name env (Name.from_path p)

| _ -> ""

in

let kind = Module_struct elements2 in

{

m_name = mod_name ;

m_info = info_opt ;

m_is_interface = false ;

m_file = !file_name ;

sig

type ele

type tab_values = (Odoc_name.t, Typedtree.pattern * Typedtree.expression) Hashtbl.t

(** Create hash tables used to search by some of the functions below. *)

(** This function returns the [Types.module_type] associated to the given module type name,

in the given table.

@raise Not_found if the module type was not found.*)

(** This function returns the [Types.exception_declaration] associated to the given exception name,

in the given table.

@raise Not_found if the exception was not found.*)

(** This function returns the [Path.t] associated to the given exception rebind name,

in the table.

(** This function returns the [Typedtree.type_declaration] associated to the given type name,

in the given table.

@raise Not_found if the type was not found. *)

(** This function returns the [Typedtree.class_expr] and type parameters

associated to the given class name, in the given table.

(** This function returns the [Types.cltype_declaration] associated to the given class type name,

in the given table.

@raise Not_found if the class type was not found. *)

(** This function returns the couple (pat, exp) for the given value name, in the

given table of values.

in

let f env item =

match item with

let env2 =

match modtype with (* A VOIR : le cas o� c'est un identificateur, dans ce cas on n'a pas de signature *)

| _ -> env

in

{ env2 with env_modules = (rel_name ident, qualify ident) :: env2.env_modules }

let env2 =

match modtype_decl with

env

match modtype with

(* A VOIR : le cas o� c'est un identificateur, dans ce cas on n'a pas de signature *)

| _ -> env

in

{ env2 with env_module_types = (rel_name ident, qualify ident) :: env2.env_module_types }

in

List.fold_left f env signat

let subst_module_type env t =

let rec iter t =

match t with

let new_p = Odoc_name.to_path (full_module_type_name env (Odoc_name.from_path p)) in

t

in

iter t

let subst_class_type env t =

let rec iter t =

match t with

let new_p = Odoc_name.to_path (full_type_name env (Odoc_name.from_path p)) in

let new_texp_list = List.map (subst_type env) texp_list in

let new_ct = iter ct in

(* on ne s'occupe pas des vals et methods *)

t

let new_texp = subst_type env texp in

let new_ct = iter ct in

in

iter t

module_elements ~trans: trans

{ m_name = "" ;

m_info = None ;

m_is_interface = false ; m_file = "" ; m_kind = k ;

m_loc = Odoc_types.dummy_loc ;

m_top_deps = [] ;

let simpl_module_type ?code t =

let rec iter t =

match t with

(

match code with

| Some s -> raise (Use_code s)

)

in

iter t

let simpl_class_type t =

let rec iter t =

match t with

(* on vire les vals et methods pour ne pas qu'elles soient imprim�es

quand on affichera le type *)

let tnil = { Types.desc = Types.Tnil ; Types.level = 0; Types.id = 0 } in

Types.desc = Types.Tobject (tnil, ref None) };

Types.cty_vars = Types.Vars.empty ;

Types.cty_concr = Types.Concr.empty ;

Types.cty_inher = []

}

let new_ct = iter ct in

in

iter t

let add_to_hash table signat =

match signat with

Hashtbl.add table (V (Name.from_ident ident)) signat

Hashtbl.add table (E (Name.from_ident ident)) signat

Hashtbl.add table (T (Name.from_ident ident)) signat

Hashtbl.add table (C (Name.from_ident ident)) signat

Hashtbl.add table (CT (Name.from_ident ident)) signat

Hashtbl.add table (M (Name.from_ident ident)) signat

Hashtbl.add table (MT (Name.from_ident ident)) signat

let table signat =

let search_value table name =

match Hashtbl.find table (V name) with

| _ -> assert false

let search_exception table name =

match Hashtbl.find table (E name) with

type_expr_list

| _ -> assert false

let search_type table name =

match Hashtbl.find table (T name) with

| _ -> assert false

let search_class table name =

match Hashtbl.find table (C name) with

| _ -> assert false

let search_class_type table name =

match Hashtbl.find table (CT name) with

| _ -> assert false

let search_module table name =

match Hashtbl.find table (M name) with

| _ -> assert false

let search_module_type table name =

match Hashtbl.find table (MT name) with

Some module_type

None

| _ -> assert false

pos_limit

in

let (len, comment_opt) = My_ir.just_after_special !file_name s in

| (name, _, _, loc) :: (name2, core_type_list2, ret_type2, loc2)

:: q ->

let pos_end_first = loc.Location.loc_end.Lexing.pos_cnum in

let pos_start_second = loc2.Location.loc_start.Lexing.pos_cnum in

let s = get_string_of_file pos_end_first pos_start_second in

let (_,comment_opt) = My_ir.just_after_special !file_name s in

((name2, core_type_list2, ret_type2, loc2) :: q)

in

f [] cons_core_type_list_list

let pos = ct.Parsetree.ptyp_loc.Location.loc_end.Lexing.pos_cnum in

let s = get_string_of_file pos pos_end in

let (_,comment_opt) = My_ir.just_after_special !file_name s in

| (name,_,ct,xxloc) :: ((name2,_,ct2,xxloc2) as ele2) :: q ->

let pos = ct.Parsetree.ptyp_loc.Location.loc_end.Lexing.pos_cnum in

let pos2 = ct2.Parsetree.ptyp_loc.Location.loc_start.Lexing.pos_cnum in

let s = get_string_of_file pos pos2 in

let (_,comment_opt) = My_ir.just_after_special !file_name s in

in

(0, f name_mutable_type_list)

Odoc_type.Type_abstract

| Types.Type_variant l ->

let f (constructor_name, type_expr_list, ret_type) =

let comment_opt =

try

match List.assoc constructor_name name_comment_list with

| Types.Type_record (l, _) ->

let f (field_name, mutable_flag, type_expr) =

let comment_opt =

try

match List.assoc field_name name_comment_list with

let get_pos_limit2 q =

match q with

[] -> pos_limit

| Parsetree.Pctf_inher class_type ->

class_type.Parsetree.pcty_loc.Location.loc_start.Lexing.pos_cnum

in

in

([], ele_comments)

(* of (string * mutable_flag * core_type option * Location.t)*)

let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in

let complete_name = Name.concat current_class_name name in

let (inher_l, eles) = f (pos_end + maybe_more) q in

(inher_l, eles_comments @ ((Class_attribute att) :: eles))

(* of (string * private_flag * core_type * Location.t) *)

let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in

let (met, maybe_more) = get_method name comment_opt private_flag loc q in

let (inher_l, eles) = f (loc.Location.loc_end.Lexing.pos_cnum + maybe_more) q in

(inher_l, eles_comments @ ((Class_method met2) :: eles))

(* of (string * private_flag * core_type * Location.t) *)

let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in

let (met, maybe_more) = get_method name comment_opt private_flag loc q in

let (inher_l, eles) = f (loc.Location.loc_end.Lexing.pos_cnum + maybe_more) q in

(inher_l, eles_comments @ ((Class_method met) :: eles))

(* of (core_type * core_type * Location.t) *)

(* A VOIR : cela correspond aux contraintes, non ? on ne les garde pas pour l'instant *)

let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in

let (inher_l, eles) = f loc.Location.loc_end.Lexing.pos_cnum q in

(inher_l, eles_comments @ eles)

let loc = class_type.Parsetree.pcty_loc in

let (comment_opt, eles_comments) =

get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum

match class_type.Parsetree.pcty_desc with

Parsetree.Pcty_constr (longident, _) ->

(*of Longident.t * core_type list*)

let ic =

{

ic_name = Odoc_env.full_class_or_class_type_name env name ;

| Parsetree.Pcty_signature _

| Parsetree.Pcty_fun _ ->

{

ic_name = Odoc_messages.object_end ;

ic_class = None ;

match sig_item_desc with

Parsetree.Psig_value (name_pre, value_desc) ->

let type_expr =

with Not_found ->

in

let subst_typ = Odoc_env.subst_type env type_expr in

let v =

{

| Parsetree.Psig_exception (name, exception_decl) ->

let types_excep_decl =

with Not_found ->

in

let e =

{

ex_info = comment_opt ;

ex_args = List.map (Odoc_env.subst_type env) types_excep_decl.exn_args ;

ex_alias = None ;

let new_env =

List.fold_left

(fun acc_env -> fun (name, _) ->

Odoc_env.add_type acc_env complete_name

)

env

let pos_limit2 =

match q with

[] -> pos_limit

in

let (maybe_more, name_comment_list) =

name_comment_from_type_kind

pos_limit2

type_decl.Parsetree.ptype_kind

in

let f_DEBUG (name, c_opt) = print_DEBUG ("constructor/field "^name^": "^(match c_opt with None -> "sans commentaire" | Some c -> Odoc_misc.string_of_info c)) in

List.iter f_DEBUG name_comment_list;

(* get the information for the type in the signature *)

let sig_type_decl =

with Not_found ->

in

(* get the type kind with the associated comments *)

let type_kind = get_type_kind new_env name_comment_list sig_type_decl.Types.type_kind in

(* associate the comments to each constructor and build the [Type.t_type] *)

let new_type =

{

ty_info = assoc_com ;

ty_parameters =

List.map2 (fun p (co,cn,_) ->

(0, env, ele_comments)

| Parsetree.Psig_module (name, module_type) ->

(* get the the module type in the signature by the module name *)

let sig_module_type =

with Not_found ->

in

let module_kind = analyse_module_kind env complete_name module_type sig_module_type in

let code_intf =

let new_env = Odoc_env.add_module env new_module.m_name in

let new_env2 =

match new_module.m_type with (* A VOIR : cela peut-il �tre Tmty_ident ? dans ce cas, on aurait pas la signature *)

| _ -> new_env

in

(maybe_more, new_env2, [ Element_module new_module ])

(* we start by extending the environment *)

let new_env =

List.fold_left

let complete_name = Name.concat current_module_name name in

let e = Odoc_env.add_module acc_env complete_name in

(* get the information for the module in the signature *)

in

match sig_module_type with

(* A VOIR : cela peut-il �tre Tmty_ident ? dans ce cas, on aurait pas la signature *)

Odoc_env.add_signature e complete_name ~rel: name s

| _ ->

print_DEBUG "not a Tmty_signature";

[] ->

(acc_maybe_more, [])

| (name, modtype) :: q ->

let loc_start = modtype.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in

let loc_end = modtype.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in

let (assoc_com, ele_comments) =

in

(* get the information for the module in the signature *)

let sig_module_type =

with Not_found ->

in

(* associate the comments to each constructor and build the [Type.t_type] *)

let module_kind = analyse_module_kind new_env complete_name modtype sig_module_type in

(maybe_more, new_env, mods)

| Parsetree.Psig_modtype (name, pmodtype_decl) ->

let sig_mtype =

with Not_found ->

in

let module_type_kind =

match pmodtype_decl with

let new_env = Odoc_env.add_module_type env mt.mt_name in

let new_env2 =

match sig_mtype with (* A VOIR : cela peut-il �tre Tmty_ident ? dans ce cas, on aurait pas la signature *)

| _ -> new_env

in

(maybe_more, new_env2, [ Element_module_type mt ])

| Parsetree.Psig_include module_type ->

let rec f = function

Parsetree.Pmty_ident longident ->

| Parsetree.Pmty_signature _ ->

"??"

| Parsetree.Pmty_functor _ ->

f mt.Parsetree.pmty_desc

| Parsetree.Pmty_typeof mexpr ->

match mexpr.Parsetree.pmod_desc with

| _ -> "??"

in

let name = f module_type.Parsetree.pmty_desc in

let new_env =

List.fold_left

(fun acc_env -> fun class_desc ->

Odoc_env.add_class acc_env complete_name

)

env

| cd :: _ -> cd.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum

in

let name = class_desc.Parsetree.pci_name in

let sig_class_decl =

with Not_found ->

in

let sig_class_type = sig_class_decl.Types.cty_type in

let (parameters, class_kind) =

let new_env =

List.fold_left

(fun acc_env -> fun class_type_decl ->

Odoc_env.add_class_type acc_env complete_name

)

env

| ct_decl2 :: _ -> ct_decl2.Parsetree.pci_loc.Location.loc_start.Lexing.pos_cnum

in

let name = ct_decl.Parsetree.pci_name in

let sig_cltype_decl =

with Not_found ->

in

let sig_class_type = sig_cltype_decl.Types.clty_type in

let kind = analyse_class_type_kind

Parsetree.Pmty_ident longident ->

let name =

match sig_module_type with

(* A VOIR cela arrive quand on fait module type F : functor ... -> Toto, Toto n'est pas un ident mais une structure *)

in

Module_type_alias { mta_name = Odoc_env.full_module_type_name env name ;

(

(* we must have a signature in the module type *)

match sig_module_type with

let pos_start = module_type.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in

let pos_end = module_type.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in

let elements = analyse_parsetree env signat current_module_name pos_start pos_end ast in

Module_type_struct elements

| _ ->

)

(

let loc_start = pmodule_type2.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in

let loc_end = pmodule_type2.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in

let mp_type_code = get_string_of_file loc_start loc_end in

print_DEBUG (Printf.sprintf "mp_type_code=%s" mp_type_code);

match sig_module_type with

let mp_kind = analyse_module_type_kind env

current_module_name pmodule_type2 param_module_type

in

| _ ->

(* if we're here something's wrong *)

)

| Parsetree.Pmty_with (module_type2, _) ->

| Parsetree.Pmty_signature signature ->

(

match sig_module_type with

Module_struct

(analyse_parsetree

env

)

| _ ->

(* if we're here something's wrong *)

)

(

match sig_module_type with

let loc_start = pmodule_type2.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in

let loc_end = pmodule_type2.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in

let mp_type_code = get_string_of_file loc_start loc_end in

| _ ->

(* if we're here something's wrong *)

)

| Parsetree.Pmty_with (module_type2, _) ->

(*of module_type * (Longident.t * with_constraint) list*)

and analyse_class_kind env current_class_name last_pos parse_class_type sig_class_type =

match parse_class_type.Parsetree.pcty_desc, sig_class_type with

(Parsetree.Pcty_constr (_, _) (*of Longident.t * core_type list *),

let path_name = Name.from_path p in

let name = Odoc_env.full_class_or_class_type_name env path_name in

let k =

in

([], k)

(* we get the elements of the class in class_type_field_list *)

let (inher_l, ele) = analyse_class_elements env current_class_name

last_pos

in

([], Class_structure (inher_l, ele))

(* label = string. Dans les signatures, pas de nom de param�tres � l'int�rieur des tuples *)

(* si label = "", pas de label. ici on a l'information pour savoir si on a un label explicite. *)

if parse_label = label then

and analyse_class_type_kind env current_class_name last_pos parse_class_type sig_class_type =

match parse_class_type.Parsetree.pcty_desc, sig_class_type with

(Parsetree.Pcty_constr (_, _) (*of Longident.t * core_type list *),

let k =

Class_type

{

in

k

(* we get the elements of the class in class_type_field_list *)

let (inher_l, ele) = analyse_class_elements env current_class_name

last_pos

in

Class_signature (inher_l, ele)

(*

| (Parsetree.Pcty_constr (longident, _) (*of Longident.t * core_type list *),

(* A VOIR : c'est pour le cas des contraintes de classes :

class type cons = object

method m : int

in

{

m_name = mod_name ;

m_info = info_opt ;

m_is_interface = true ;

m_file = !file_name ;

(** This function returns the Types.cltype_declaration for the class type whose name is given,

in the given table.

@raise Not_found if error.*)

(** This function returns the Types.module_type for the module whose name is given,

in the given table.

let string_of_class_params c =

let b = Buffer.create 256 in

let rec iter = function

let parent = is_arrow_type t in

Printf.bprintf b "%s%s%s%s -> "

(

)

(if parent then ")" else "");

iter ctype

in

iter c.Odoc_class.cl_type;

Buffer.contents b

%token <string> Char

/* Start Symbols */

%type <Odoc_types.text> main

%%

main:

| text_element text_element_list { $1 :: $2 }

;

ele_ref_kind:

ELE_REF { None }

| VAL_REF { Some RK_value }