diff -ur ocaml-3.00/bytecomp/translcore.ml ocaml-option/bytecomp/translcore.ml --- ocaml-3.00/bytecomp/translcore.ml Thu Jan 4 12:01:12 2001 +++ ocaml-option/bytecomp/translcore.ml Thu Jan 4 11:57:57 2001 @@ -438,7 +438,7 @@ transl_primitive p | Texp_ident(path, {val_kind = Val_anc _}) -> raise(Error(e.exp_loc, Free_super_var)) - | Texp_ident(path, {val_kind = Val_reg | Val_self _}) -> + | Texp_ident(path, {val_kind = Val_reg | Val_optional | Val_self _}) -> transl_path path | Texp_constant cst -> Lconst(Const_base cst) diff -ur ocaml-3.00/bytecomp/translmod.ml ocaml-option/bytecomp/translmod.ml --- ocaml-3.00/bytecomp/translmod.ml Thu Jan 4 12:01:12 2001 +++ ocaml-option/bytecomp/translmod.ml Thu Jan 4 11:57:57 2001 @@ -41,11 +41,18 @@ Lfunction(Curried, [param], apply_coercion cc_res (Lapply(Lvar id, [apply_coercion cc_arg (Lvar param)])))) - | Tcoerce_primitive p -> - transl_primitive p - -and apply_coercion_field id (pos, cc) = - apply_coercion cc (Lprim(Pfield pos, [Lvar id])) + | Tcoerce_lift -> + Lprim(Pmakeblock(0,Immutable), [arg]) + | Tcoerce_seq(c1,c2) -> + apply_coercion c1 (apply_coercion c2 arg) + +and apply_coercion_field id (loc, cc) = + apply_coercion cc ( + match loc with + Loc_at pos -> Lprim(Pfield pos, [Lvar id]) + | Loc_primitive p -> transl_primitive p + | Loc_absent -> Lconst(Const_base(Const_int 0)) + ) (* Compose two coercions apply_coercion c1 (apply_coercion c2 e) behaves like @@ -59,16 +66,18 @@ let v2 = Array.of_list pc2 in Tcoerce_structure (List.map - (function (p1, Tcoerce_primitive p) -> - (p1, Tcoerce_primitive p) - | (p1, c1) -> - let (p2, c2) = v2.(p1) in (p2, compose_coercions c1 c2)) - pc1) + (function + (Loc_at i,c1) -> + let (p2,c2) = v2.(i) in + (p2, compose_coercions c1 c2) + | p1 -> p1 + ) + pc1) | (Tcoerce_functor(arg1, res1), Tcoerce_functor(arg2, res2)) -> Tcoerce_functor(compose_coercions arg2 arg1, compose_coercions res1 res2) | (_, _) -> - fatal_error "Translmod.compose_coercions" + Tcoerce_seq (c1,c2) (* Record the primitive declarations occuring in the module compiled *) @@ -123,13 +132,14 @@ List.map (fun id -> Lvar id) (List.rev fields)) | Tcoerce_structure pos_cc_list -> let v = Array.of_list (List.rev fields) in - Lprim(Pmakeblock(0, Immutable), - List.map - (fun (pos, cc) -> - match cc with - Tcoerce_primitive p -> transl_primitive p - | _ -> apply_coercion cc (Lvar v.(pos))) - pos_cc_list) + let transl (loc,cc) = + apply_coercion cc ( + match loc with + Loc_at pos -> Lvar v.(pos) + | Loc_primitive p -> transl_primitive p + | Loc_absent -> Lconst(Const_base(Const_int 0)) + ) in + Lprim(Pmakeblock(0, Immutable), List.map transl pos_cc_list) | _ -> fatal_error "Translmod.transl_structure" end @@ -193,9 +203,12 @@ refer to earlier fields of the structure through the fields of the global, not by their names. "map" is a table from defined idents to (pos in global block, coercion). - "prim" is a list of (pos in global block, primitive declaration). *) + "prim" is a list of (pos in global block, primitive declaration, coercion). + "abs" is a list of (pos in global block, coercion). + ( for the moment coercion = Tcoerce_none for abs ) + *) -let transl_store_structure glob map prims str = +let transl_store_structure glob map prims abs str = let rec transl_store subst = function [] -> lambda_unit @@ -206,7 +219,7 @@ 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 ids subst) rem) + transl_store (add_idents true ids subst) rem) | Tstr_primitive(id, descr) :: rem -> begin match descr.val_kind with Val_prim p -> primitive_declarations := @@ -248,7 +261,7 @@ cl_list, store_idents ids) in Lsequence(subst_lambda subst lam, - transl_store (add_idents ids subst) rem) + transl_store (add_idents false ids subst) rem) | Tstr_cltype cl_list :: rem -> transl_store subst rem @@ -274,15 +287,20 @@ with Not_found -> assert false - and add_idents idlist subst = - List.fold_right (add_ident false) idlist subst + and add_idents may_coerce idlist subst = + List.fold_right (add_ident may_coerce) idlist subst - and store_primitive (pos, prim) cont = - Lsequence(Lprim(Psetfield(pos, false), - [Lprim(Pgetglobal glob, []); transl_primitive prim]), + and store_primitive (pos, prim, cc) cont = + let p = apply_coercion cc (transl_primitive prim) in + Lsequence(Lprim(Psetfield(pos, false), [Lprim(Pgetglobal glob, []); p]), cont) - in List.fold_right store_primitive prims (transl_store Ident.empty str) + and store_absent (pos, cc) cont = + let p = apply_coercion cc (Lconst(Const_base(Const_int 0))) in + Lsequence(Lprim(Psetfield(pos, false), [Lprim(Pgetglobal glob, []); p]), + cont) + in List.fold_right store_primitive prims ( + List.fold_right store_absent abs (transl_store Ident.empty str)) (* Build the list of value identifiers defined by a toplevel structure (excluding primitive declarations). *) @@ -313,29 +331,33 @@ Identifiers that are not exported are assigned positions at the end of the block (beyond the positions of all exported idents). Also compute the total size of the global block, - and the list of all primitives exported as values. *) + the list of all primitives exported as values, + and the list of absent field to replace with None. *) let build_ident_map restr idlist = - let rec natural_map pos map prims = function + let rec natural_map pos map prims abs = function [] -> - (map, prims, pos) + (map, prims, abs, pos) | id :: rem -> - natural_map (pos+1) (Ident.add id (pos, Tcoerce_none) map) prims rem in + natural_map (pos+1) (Ident.add id (pos, Tcoerce_none) map) prims abs rem in match restr with Tcoerce_none -> - natural_map 0 Ident.empty [] idlist + natural_map 0 Ident.empty [] [] idlist | Tcoerce_structure pos_cc_list -> let idarray = Array.of_list idlist in - let rec export_map pos map prims undef = function + let rec export_map pos map prims abs undef = function [] -> - natural_map pos map prims undef - | (source_pos, Tcoerce_primitive p) :: rem -> - export_map (pos + 1) map ((pos, p) :: prims) undef rem - | (source_pos, cc) :: rem -> + natural_map pos map prims abs undef + | (Loc_primitive p, cc) :: rem -> + export_map (pos + 1) map ((pos, p, cc) :: prims) abs undef rem + | (Loc_at source_pos, cc) :: rem -> let id = idarray.(source_pos) in export_map (pos + 1) (Ident.add id (pos, cc) map) - prims (list_remove id undef) rem - in export_map 0 Ident.empty [] idlist pos_cc_list + prims abs (list_remove id undef) rem + | (Loc_absent, cc) :: rem -> + export_map (pos + 1) map prims ((pos,cc) :: abs) undef rem + + in export_map 0 Ident.empty [] [] idlist pos_cc_list | _ -> fatal_error "Translmod.build_ident_map" @@ -346,8 +368,8 @@ 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 - (size, transl_label_init (transl_store_structure module_id map prims str)) + let (map, prims, abs, size) = build_ident_map restr (defined_idents str) in + (size, transl_label_init (transl_store_structure module_id map prims abs str)) (* Compile a toplevel phrase *) diff -ur ocaml-3.00/parsing/parser.mly ocaml-option/parsing/parser.mly --- ocaml-3.00/parsing/parser.mly Thu Jan 4 12:01:05 2001 +++ ocaml-option/parsing/parser.mly Thu Jan 4 11:57:59 2001 @@ -413,7 +413,7 @@ [{ppat_desc = Ppat_any}, exp] -> mkstr(Pstr_eval exp) | _ -> mkstr(Pstr_value($2, List.rev $3)) } | EXTERNAL val_ident_colon core_type EQUAL primitive_declaration - { mkstr(Pstr_primitive($2, {pval_type = $3; pval_prim = $5})) } + { mkstr(Pstr_primitive($2, {pval_type = $3; pval_option = false; pval_prim = $5})) } | TYPE type_declarations { mkstr(Pstr_type(List.rev $2)) } | EXCEPTION UIDENT constructor_arguments @@ -465,10 +465,12 @@ | signature signature_item SEMISEMI { $2 :: $1 } ; signature_item: - VAL val_ident_colon core_type - { mksig(Psig_value($2, {pval_type = $3; pval_prim = []})) } + VIRTUAL VAL val_ident_colon core_type + { mksig(Psig_value($3, {pval_type = $4; pval_option = true; pval_prim = []})) } + | VAL val_ident_colon core_type + { mksig(Psig_value($2, {pval_type = $3; pval_option = false; pval_prim = []})) } | EXTERNAL val_ident_colon core_type EQUAL primitive_declaration - { mksig(Psig_value($2, {pval_type = $3; pval_prim = $5})) } + { mksig(Psig_value($2, {pval_type = $3; pval_option = false; pval_prim = $5})) } | TYPE type_declarations { mksig(Psig_type(List.rev $2)) } | EXCEPTION UIDENT constructor_arguments diff -ur ocaml-3.00/parsing/parsetree.mli ocaml-option/parsing/parsetree.mli --- ocaml-3.00/parsing/parsetree.mli Thu Jan 4 12:01:05 2001 +++ ocaml-option/parsing/parsetree.mli Thu Jan 4 11:57:59 2001 @@ -105,6 +105,7 @@ and value_description = { pval_type: core_type; + pval_option: bool; pval_prim: string list } (* Type declarations *) diff -ur ocaml-3.00/typing/includecore.ml ocaml-option/typing/includecore.ml --- ocaml-3.00/typing/includecore.ml Thu Jan 4 12:01:09 2001 +++ ocaml-option/typing/includecore.ml Thu Jan 4 11:58:02 2001 @@ -21,18 +21,18 @@ (* Inclusion between value descriptions *) -exception Dont_match - let value_descriptions env vd1 vd2 = - if Ctype.moregeneral env true vd1.val_type vd2.val_type then begin - match (vd1.val_kind, vd2.val_kind) with - (Val_prim p1, Val_prim p2) -> - if p1 = p2 then Tcoerce_none else raise Dont_match - | (Val_prim p, _) -> Tcoerce_primitive p - | (_, Val_prim p) -> raise Dont_match - | (_, _) -> Tcoerce_none - end else - raise Dont_match + match (vd1.val_kind, vd2.val_kind) with + ((Val_reg | Val_prim _ ), Val_optional) -> + Ctype.moregeneral env true + (Predef.type_option vd1.val_type) vd2.val_type + | (Val_optional, Val_optional) + | (Val_reg, Val_reg) + | (Val_prim _, Val_reg) -> + Ctype.moregeneral env true vd1.val_type vd2.val_type + | (Val_prim p1, Val_prim p2) when p1 = p2 -> + Ctype.moregeneral env true vd1.val_type vd2.val_type + | _ -> false (* Inclusion between type declarations *) diff -ur ocaml-3.00/typing/includecore.mli ocaml-option/typing/includecore.mli --- ocaml-3.00/typing/includecore.mli Thu Jan 4 12:01:09 2001 +++ ocaml-option/typing/includecore.mli Thu Jan 4 11:58:02 2001 @@ -17,10 +17,8 @@ open Types open Typedtree -exception Dont_match - val value_descriptions: - Env.t -> value_description -> value_description -> module_coercion + Env.t -> value_description -> value_description -> bool val type_declarations: Env.t -> Ident.t -> type_declaration -> type_declaration -> bool val exception_declarations: diff -ur ocaml-3.00/typing/includemod.ml ocaml-option/typing/includemod.ml --- ocaml-3.00/typing/includemod.ml Thu Jan 4 12:01:09 2001 +++ ocaml-option/typing/includemod.ml Thu Jan 4 11:58:02 2001 @@ -44,13 +44,21 @@ (* Inclusion between value descriptions *) -let value_descriptions env subst id vd1 vd2 = +let value_descriptions env subst id pos vd1 vd2 = let vd2 = Subst.value_description subst vd2 in try - Includecore.value_descriptions env vd1 vd2 - with Includecore.Dont_match -> + if not (Includecore.value_descriptions env vd1 vd2) + then raise Exit + else + match (vd1.val_kind, vd2.val_kind) with + (Val_prim p1, Val_prim p2) -> None + | (Val_prim p, Val_reg) -> Some (Loc_primitive p, Tcoerce_none) + | (Val_reg, Val_optional) -> Some (Loc_at pos, Tcoerce_lift) + | (Val_prim p, Val_optional) -> Some (Loc_primitive p, Tcoerce_lift) + | (_, _) -> Some (Loc_at pos, Tcoerce_none) + with Exit -> raise(Error[Value_descriptions(id, vd1, vd2)]) - + (* Inclusion between type declarations *) let type_declarations env subst id decl1 decl2 = @@ -117,9 +125,8 @@ let pos = ref 0 in try List.iter - (fun (n, c) -> - if n <> !pos or c <> Tcoerce_none then raise Exit; - incr pos) + (function (Loc_at n, Tcoerce_none) when n = !pos -> incr pos + | _ -> raise Exit) cc; Tcoerce_none with Exit -> @@ -226,7 +233,11 @@ pair_components new_subst ((item1, item2, pos1) :: paired) unpaired rem with Not_found -> - pair_components subst paired (Missing_field id2 :: unpaired) rem + match item2 with + Tsig_value (_,{val_kind = Val_optional}) -> + pair_components subst ((item2, item2, -1) :: paired) unpaired rem + | _ -> + pair_components subst paired (Missing_field id2 :: unpaired) rem end in (* Do the pairing and checking, and return the final coercion *) simplify_structure_coercion(pair_components subst [] [] sig2) @@ -235,11 +246,15 @@ and signature_components env subst = function [] -> [] + | ( _, Tsig_value(id2, valdecl2), -1) :: rem -> + (* Special case for absent virtual field; should + redesign this and avoid -1 and the meaningless first field *) + (Loc_absent, Tcoerce_none) :: signature_components env subst rem | (Tsig_value(id1, valdecl1), Tsig_value(id2, valdecl2), pos) :: rem -> - let cc = value_descriptions env subst id1 valdecl1 valdecl2 in - begin match valdecl2.val_kind with - Val_prim p -> signature_components env subst rem - | _ -> (pos, cc) :: signature_components env subst rem + begin + match value_descriptions env subst id1 pos valdecl1 valdecl2 with + None -> signature_components env subst rem + | Some p -> p :: signature_components env subst rem end | (Tsig_type(id1, tydecl1), Tsig_type(id2, tydecl2), pos) :: rem -> type_declarations env subst id1 tydecl1 tydecl2; @@ -247,17 +262,17 @@ | (Tsig_exception(id1, excdecl1), Tsig_exception(id2, excdecl2), pos) :: rem -> exception_declarations env subst id1 excdecl1 excdecl2; - (pos, Tcoerce_none) :: signature_components env subst rem + (Loc_at pos, Tcoerce_none) :: signature_components env subst rem | (Tsig_module(id1, mty1), Tsig_module(id2, mty2), pos) :: rem -> let cc = modtypes env subst (Mtype.strengthen env mty1 (Pident id1)) mty2 in - (pos, cc) :: signature_components env subst rem + (Loc_at pos, cc) :: signature_components env subst rem | (Tsig_modtype(id1, info1), Tsig_modtype(id2, info2), pos) :: rem -> modtype_infos env subst id1 info1 info2; signature_components env subst rem | (Tsig_class(id1, decl1), Tsig_class(id2, decl2), pos) :: rem -> class_declarations env subst id1 decl1 decl2; - (pos, Tcoerce_none) :: signature_components env subst rem + (Loc_at pos, Tcoerce_none) :: signature_components env subst rem | (Tsig_cltype(id1, info1), Tsig_cltype(id2, info2), pos) :: rem -> class_type_declarations env subst id1 info1 info2; signature_components env subst rem diff -ur ocaml-3.00/typing/printtyp.ml ocaml-option/typing/printtyp.ml --- ocaml-3.00/typing/printtyp.ml Thu Jan 4 12:01:09 2001 +++ ocaml-option/typing/printtyp.ml Thu Jan 4 11:58:02 2001 @@ -455,14 +455,23 @@ | _ -> fprintf ppf "( %s )" name let value_description id ppf decl = - let kwd = if decl.val_kind = Val_reg then "val " else "external " in - let pr_val ppf = - match decl.val_kind with - | Val_prim p -> - fprintf ppf "@ = %a" Primitive.print_description p - | _ -> () in - fprintf ppf "@[<2>%s%a :@ %a%t@]" - kwd value_ident id type_scheme decl.val_type pr_val + match decl.val_kind with + Val_reg -> + fprintf ppf "@[<2>val %a :@ %a@]" + value_ident id type_scheme decl.val_type + | Val_optional -> + let ty = decl.val_type in + (match (repr ty).desc with + | Tconstr(path, [ty], _) when path = Predef.path_option -> + fprintf ppf "@[<2>virtual val %a :@ %a@]" + value_ident id type_scheme ty + | _ -> assert false) + | Val_prim p -> + fprintf ppf "@[<2>external %a :@ %a@ = %a@]" + value_ident id type_scheme decl.val_type + Primitive.print_description p + | _ -> assert false + (* Print a class type *) diff -ur ocaml-3.00/typing/typedecl.ml ocaml-option/typing/typedecl.ml --- ocaml-3.00/typing/typedecl.ml Thu Jan 4 12:01:09 2001 +++ ocaml-option/typing/typedecl.ml Thu Jan 4 11:58:02 2001 @@ -305,7 +305,10 @@ let ty = Typetexp.transl_type_scheme env valdecl.pval_type in match valdecl.pval_prim with [] -> - { val_type = ty; val_kind = Val_reg } + if valdecl.pval_option then + { val_type = Predef.type_option ty; val_kind = Val_optional } + else + { val_type = ty; val_kind = Val_reg } | decl -> let arity = Ctype.arity ty in if arity = 0 then diff -ur ocaml-3.00/typing/typedtree.ml ocaml-option/typing/typedtree.ml --- ocaml-3.00/typing/typedtree.ml Thu Jan 4 12:01:09 2001 +++ ocaml-option/typing/typedtree.ml Thu Jan 4 11:58:02 2001 @@ -136,11 +136,18 @@ | Tstr_class of (Ident.t * int * string list * class_expr) list | Tstr_cltype of (Ident.t * cltype_declaration) list -and module_coercion = +and module_coercion = Tcoerce_none - | Tcoerce_structure of (int * module_coercion) list + | Tcoerce_structure of (field_location * module_coercion) list | Tcoerce_functor of module_coercion * module_coercion - | Tcoerce_primitive of Primitive.description + | Tcoerce_lift (* lift from 'a to 'a option *) + | Tcoerce_seq of module_coercion * module_coercion + +and field_location = + Loc_at of int (* at position n *) + | Loc_primitive of Primitive.description (* defined as a primitive *) + | Loc_absent (* absent *) + (* Auxiliary functions over the a.s.t. *) diff -ur ocaml-3.00/typing/typedtree.mli ocaml-option/typing/typedtree.mli --- ocaml-3.00/typing/typedtree.mli Thu Jan 4 12:01:09 2001 +++ ocaml-option/typing/typedtree.mli Thu Jan 4 11:58:02 2001 @@ -137,11 +137,17 @@ | Tstr_class of (Ident.t * int * string list * class_expr) list | Tstr_cltype of (Ident.t * cltype_declaration) list -and module_coercion = +and module_coercion = Tcoerce_none - | Tcoerce_structure of (int * module_coercion) list + | Tcoerce_structure of (field_location * module_coercion) list | Tcoerce_functor of module_coercion * module_coercion - | Tcoerce_primitive of Primitive.description + | Tcoerce_lift (* lift from 'a to 'a option *) + | Tcoerce_seq of module_coercion * module_coercion + +and field_location = + Loc_at of int (* at position n *) + | Loc_primitive of Primitive.description (* defined as a primitive *) + | Loc_absent (* absent *) (* Auxiliary functions over the a.s.t. *) diff -ur ocaml-3.00/typing/types.ml ocaml-option/typing/types.ml --- ocaml-3.00/typing/types.ml Thu Jan 4 12:01:09 2001 +++ ocaml-option/typing/types.ml Thu Jan 4 11:58:02 2001 @@ -72,6 +72,7 @@ and value_kind = Val_reg (* Regular value *) + | Val_optional (* Virtual field of a structure *) | Val_prim of Primitive.description (* Primitive *) | Val_ivar of mutable_flag * string (* Instance variable (mutable ?) *) | Val_self of (Ident.t * type_expr) Meths.t ref * diff -ur ocaml-3.00/typing/types.mli ocaml-option/typing/types.mli --- ocaml-3.00/typing/types.mli Thu Jan 4 12:01:09 2001 +++ ocaml-option/typing/types.mli Thu Jan 4 11:58:02 2001 @@ -71,6 +71,7 @@ and value_kind = Val_reg (* Regular value *) + | Val_optional (* Virtual field of a structure *) | Val_prim of Primitive.description (* Primitive *) | Val_ivar of mutable_flag * string (* Instance variable (mutable ?) *) | Val_self of (Ident.t * type_expr) Meths.t ref *