Merge pull request #301 from alainfrisch/let_exception

Local exceptions (without the optimization)
master
Alain Frisch 2016-03-15 22:04:39 +01:00
commit b791a20b69
28 changed files with 209 additions and 53 deletions

34
.depend
View File

@ -347,23 +347,25 @@ typing/typeclass.cmi : typing/types.cmi typing/typedtree.cmi \
parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
typing/ident.cmi typing/env.cmi typing/ctype.cmi parsing/asttypes.cmi
typing/typecore.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/cmt_format.cmi utils/clflags.cmi parsing/builtin_attributes.cmi \
typing/btype.cmi parsing/asttypes.cmi parsing/ast_helper.cmi \
typing/annot.cmi typing/typecore.cmi
typing/types.cmi typing/typedtree.cmi typing/typedecl.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/cmt_format.cmi \
utils/clflags.cmi parsing/builtin_attributes.cmi typing/btype.cmi \
parsing/asttypes.cmi parsing/ast_helper.cmi typing/annot.cmi \
typing/typecore.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/cmt_format.cmx utils/clflags.cmx parsing/builtin_attributes.cmx \
typing/btype.cmx parsing/asttypes.cmi parsing/ast_helper.cmx \
typing/annot.cmi typing/typecore.cmi
typing/types.cmx typing/typedtree.cmx typing/typedecl.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/cmt_format.cmx \
utils/clflags.cmx parsing/builtin_attributes.cmx typing/btype.cmx \
parsing/asttypes.cmi parsing/ast_helper.cmx typing/annot.cmi \
typing/typecore.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

View File

@ -3,6 +3,10 @@ OCaml 4.04.0:
(Changes that can break existing programs are marked with a "*")
Language features:
- GPR#301: local exception declarations "let exception ... in"
(Alain Frisch)
Tools:
- GPR#452: Make the output of ocamldep is more stable (Alain Frisch)

View File

@ -66,8 +66,8 @@ TYPING=typing/ident.cmo typing/path.cmo \
typing/tast_mapper.cmo \
typing/cmt_format.cmo typing/untypeast.cmo \
typing/includemod.cmo typing/typetexp.cmo typing/parmatch.cmo \
typing/stypes.cmo typing/typecore.cmo \
typing/typedecl.cmo typing/typeclass.cmo \
typing/stypes.cmo typing/typedecl.cmo typing/typecore.cmo \
typing/typeclass.cmo \
typing/typemod.cmo
COMP=bytecomp/lambda.cmo bytecomp/printlambda.cmo \

View File

@ -44,6 +44,26 @@ let transl_object =
ref (fun id s cl -> assert false :
Ident.t -> string list -> class_expr -> lambda)
(* Compile an exception/extension definition *)
let prim_fresh_oo_id =
Pccall (Primitive.simple ~name:"caml_fresh_oo_id" ~arity:1 ~alloc:false)
let transl_extension_constructor env path ext =
let name =
match path, !Clflags.for_package with
None, _ -> Ident.name ext.ext_id
| Some p, None -> Path.name p
| Some p, Some pack -> Printf.sprintf "%s.%s" pack (Path.name p)
in
match ext.ext_kind with
Text_decl(args, ret) ->
Lprim (Pmakeblock (Obj.object_tag, Immutable),
[Lconst (Const_base (Const_string (name, None)));
Lprim (prim_fresh_oo_id, [Lconst (Const_base (Const_int 0))])])
| Text_rebind(path, lid) ->
transl_path ~loc:ext.ext_loc env path
(* Translation of primitives *)
let comparisons_table = create_hashtable 11 [
@ -957,6 +977,9 @@ and transl_exp0 e =
(Lvar cpy))
| Texp_letmodule(id, _, modl, body) ->
Llet(Strict, id, !transl_module Tcoerce_none None modl, transl_exp body)
| Texp_letexception(cd, body) ->
Llet(Strict, cd.ext_id, transl_extension_constructor e.exp_env None cd,
transl_exp body)
| Texp_pack modl ->
!transl_module Tcoerce_none None modl
| Texp_assert {exp_desc=Texp_construct(_, {cstr_name="false"}, _)} ->

View File

@ -30,6 +30,9 @@ val transl_let: rec_flag -> value_binding list -> lambda -> lambda
val transl_primitive: Location.t -> Primitive.description -> Env.t
-> Types.type_expr -> Path.t option -> lambda
val transl_extension_constructor: Env.t -> Path.t option ->
extension_constructor -> lambda
val check_recursive_lambda: Ident.t list -> lambda -> bool
val used_primitives: (Path.t, Location.t) Hashtbl.t

View File

@ -48,24 +48,6 @@ let field_path path field =
(* Compile type extensions *)
let prim_fresh_oo_id =
Pccall (Primitive.simple ~name:"caml_fresh_oo_id" ~arity:1 ~alloc:false)
let transl_extension_constructor env path ext =
let name =
match path, !Clflags.for_package with
None, _ -> Ident.name ext.ext_id
| Some p, None -> Path.name p
| Some p, Some pack -> Printf.sprintf "%s.%s" pack (Path.name p)
in
match ext.ext_kind with
Text_decl(args, ret) ->
Lprim (Pmakeblock (Obj.object_tag, Immutable),
[Lconst (Const_base (Const_string (name, None)));
Lprim (prim_fresh_oo_id, [Lconst (Const_base (Const_int 0))])])
| Text_rebind(path, lid) ->
transl_path ~loc:ext.ext_loc env path
let transl_type_extension env rootpath tyext body =
List.fold_right
(fun ext body ->

View File

@ -1503,7 +1503,7 @@ typedef: ...
| typedef item-attribute
;
exception-definition:
'exception' constr-name { attribute } [ 'of' typexpr { '*' typexpr } ]
'exception' constr-decl
| 'exception' constr-name '=' constr
;
module-items:
@ -2096,3 +2096,25 @@ let invalid = function
| Point p -> p (* INVALID *)
| ...
\end{verbatim}
\section{Local exceptions}
\ikwd{let\@\texttt{let}}
\ikwd{exception\@\texttt{exception}}
(Introduced in OCaml 4.04)
It is possible to define local exceptions in expressions:
\begin{syntax}
expr:
...
| "let" "exception" constr-decl "in" expr
\end{syntax}
The syntactic scope of the exception constructor is the inner
expression, but nothing prevents exception values created with this
constructor from escaping this scope. Two executions of the definition
above result in two incompatible exception constructors (as for any
exception definition).

View File

@ -201,7 +201,7 @@ appear in the type equation and the type declaration.
\begin{syntax}
exception-definition:
'exception' constr-name [ 'of' typexpr { '*' typexpr } ]
'exception' constr-decl
| 'exception' constr-name '=' constr
\end{syntax}
@ -209,7 +209,7 @@ Exception definitions add new constructors to the built-in variant
type \verb"exn" of exception values. The constructors are declared as
for a definition of a variant type.
The form @'exception' constr-name ['of' typexpr {'*' typexpr}]@
The form @'exception' constr-decl@
generates a new exception, distinct from all other exceptions in the system.
The form @'exception' constr-name '=' constr@
gives an alternate name to an existing exception.

View File

@ -122,6 +122,7 @@ module Exp = struct
let setinstvar ?loc ?attrs a b = mk ?loc ?attrs (Pexp_setinstvar (a, b))
let override ?loc ?attrs a = mk ?loc ?attrs (Pexp_override a)
let letmodule ?loc ?attrs a b c= mk ?loc ?attrs (Pexp_letmodule (a, b, c))
let letexception ?loc ?attrs a b = mk ?loc ?attrs (Pexp_letexception (a, b))
let assert_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_assert a)
let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_lazy a)
let poly ?loc ?attrs a b = mk ?loc ?attrs (Pexp_poly (a, b))

View File

@ -149,6 +149,8 @@ module Exp:
-> expression
val letmodule: ?loc:loc -> ?attrs:attrs -> str -> module_expr -> expression
-> expression
val letexception: ?loc:loc -> ?attrs:attrs -> extension_constructor -> expression
-> expression
val assert_: ?loc:loc -> ?attrs:attrs -> expression -> expression
val lazy_: ?loc:loc -> ?attrs:attrs -> expression -> expression
val poly: ?loc:loc -> ?attrs:attrs -> expression -> core_type option

View File

@ -355,6 +355,9 @@ module E = struct
| Pexp_letmodule (s, me, e) ->
iter_loc sub s; sub.module_expr sub me;
sub.expr sub e
| Pexp_letexception (cd, e) ->
sub.extension_constructor sub cd;
sub.expr sub e
| Pexp_assert e -> sub.expr sub e
| Pexp_lazy e -> sub.expr sub e
| Pexp_poly (e, t) ->

View File

@ -370,6 +370,10 @@ module E = struct
| Pexp_letmodule (s, me, e) ->
letmodule ~loc ~attrs (map_loc sub s) (sub.module_expr sub me)
(sub.expr sub e)
| Pexp_letexception (cd, e) ->
letexception ~loc ~attrs
(sub.extension_constructor sub cd)
(sub.expr sub e)
| Pexp_assert e -> assert_ ~loc ~attrs (sub.expr sub e)
| Pexp_lazy e -> lazy_ ~loc ~attrs (sub.expr sub e)
| Pexp_poly (e, t) ->

View File

@ -1354,6 +1354,15 @@ expr:
{ expr_of_let_bindings $1 $3 }
| LET MODULE ext_attributes UIDENT module_binding_body IN seq_expr
{ mkexp_attrs (Pexp_letmodule(mkrhs $4 4, $5, $7)) $3 }
| LET EXCEPTION ext_attributes constr_ident generalized_constructor_arguments
attributes IN seq_expr
{ let args, res = $5 in
let ex =
Te.decl (mkrhs $4 4) ~args ?res ~attrs:$6
~loc:(symbol_rloc())
in
mkexp_attrs (Pexp_letexception(ex, $8)) $3
}
| LET OPEN override_flag ext_attributes mod_longident IN seq_expr
{ mkexp_attrs (Pexp_open($3, mkrhs $5 5, $7)) $4 }
| FUNCTION ext_attributes opt_bar match_cases
@ -1616,7 +1625,7 @@ let_binding_body:
| val_ident COLON TYPE lident_list DOT core_type EQUAL seq_expr
{ let exp, poly = wrap_type_annotation $4 $6 $8 in
(ghpat(Ppat_constraint(mkpatvar $1 1, poly)), exp) }
| pattern EQUAL seq_expr
| pattern_no_exn EQUAL seq_expr
{ ($1, $3) }
| simple_pattern_not_ident COLON core_type EQUAL seq_expr
{ (ghpat(Ppat_constraint($1, $3)), $5) }
@ -1722,36 +1731,58 @@ opt_type_constraint:
/* Patterns */
pattern:
simple_pattern
{ $1 }
| pattern AS val_ident
{ mkpat(Ppat_alias($1, mkrhs $3 3)) }
| pattern AS error
{ expecting 3 "identifier" }
| pattern_comma_list %prec below_COMMA
{ mkpat(Ppat_tuple(List.rev $1)) }
| constr_longident pattern %prec prec_constr_appl
{ mkpat(Ppat_construct(mkrhs $1 1, Some $2)) }
| name_tag pattern %prec prec_constr_appl
{ mkpat(Ppat_variant($1, Some $2)) }
| pattern COLONCOLON pattern
{ mkpat_cons (rhs_loc 2) (ghpat(Ppat_tuple[$1;$3])) (symbol_rloc()) }
| pattern COLONCOLON error
{ expecting 3 "pattern" }
| LPAREN COLONCOLON RPAREN LPAREN pattern COMMA pattern RPAREN
{ mkpat_cons (rhs_loc 2) (ghpat(Ppat_tuple[$5;$7])) (symbol_rloc()) }
| LPAREN COLONCOLON RPAREN LPAREN pattern COMMA pattern error
{ unclosed "(" 4 ")" 8 }
| pattern BAR pattern
{ mkpat(Ppat_or($1, $3)) }
| pattern BAR error
{ expecting 3 "pattern" }
| LAZY ext_attributes simple_pattern
{ mkpat_attrs (Ppat_lazy $3) $2}
| EXCEPTION ext_attributes pattern %prec prec_constr_appl
{ mkpat_attrs (Ppat_exception $3) $2}
| pattern attribute
{ Pat.attr $1 $2 }
| pattern_gen { $1 }
;
pattern_no_exn:
| pattern_no_exn AS val_ident
{ mkpat(Ppat_alias($1, mkrhs $3 3)) }
| pattern_no_exn AS error
{ expecting 3 "identifier" }
| pattern_no_exn_comma_list %prec below_COMMA
{ mkpat(Ppat_tuple(List.rev $1)) }
| pattern_no_exn COLONCOLON pattern
{ mkpat_cons (rhs_loc 2) (ghpat(Ppat_tuple[$1;$3])) (symbol_rloc()) }
| pattern_no_exn COLONCOLON error
{ expecting 3 "pattern" }
| pattern_no_exn BAR pattern
{ mkpat(Ppat_or($1, $3)) }
| pattern_no_exn BAR error
{ expecting 3 "pattern" }
| pattern_no_exn attribute
{ Pat.attr $1 $2 }
| pattern_gen { $1 }
;
pattern_gen:
simple_pattern
{ $1 }
| constr_longident pattern %prec prec_constr_appl
{ mkpat(Ppat_construct(mkrhs $1 1, Some $2)) }
| name_tag pattern %prec prec_constr_appl
{ mkpat(Ppat_variant($1, Some $2)) }
| LPAREN COLONCOLON RPAREN LPAREN pattern COMMA pattern RPAREN
{ mkpat_cons (rhs_loc 2) (ghpat(Ppat_tuple[$5;$7])) (symbol_rloc()) }
| LPAREN COLONCOLON RPAREN LPAREN pattern COMMA pattern error
{ unclosed "(" 4 ")" 8 }
| LAZY ext_attributes simple_pattern
{ mkpat_attrs (Ppat_lazy $3) $2}
;
simple_pattern:
val_ident %prec below_EQUAL
@ -1813,6 +1844,11 @@ pattern_comma_list:
| pattern COMMA pattern { [$3; $1] }
| pattern COMMA error { expecting 3 "pattern" }
;
pattern_no_exn_comma_list:
pattern_no_exn_comma_list COMMA pattern { $3 :: $1 }
| pattern_no_exn COMMA pattern { [$3; $1] }
| pattern_no_exn COMMA error { expecting 3 "pattern" }
;
pattern_semi_list:
pattern { [$1] }
| pattern_semi_list SEMI pattern { $3 :: $1 }

View File

@ -318,6 +318,8 @@ and expression_desc =
(* {< x1 = E1; ...; Xn = En >} *)
| Pexp_letmodule of string loc * module_expr * expression
(* let module M = ME in E *)
| Pexp_letexception of extension_constructor * expression
(* let exception C in E *)
| Pexp_assert of expression
(* assert E
Note: "assert false" is treated in a special way by the

View File

@ -475,7 +475,7 @@ class printer ()= object(self:'self)
self#paren true self#reset#expression f x
| Pexp_ifthenelse _ | Pexp_sequence _ when ifthenelse ->
self#paren true self#reset#expression f x
| Pexp_let _ | Pexp_letmodule _ when semi ->
| Pexp_let _ | Pexp_letmodule _ | Pexp_letexception _ when semi ->
self#paren true self#reset#expression f x
| Pexp_fun (l, e0, p, e) ->
pp f "@[<2>fun@;%a@;->@;%a@]"
@ -571,6 +571,10 @@ class printer ()= object(self:'self)
| Pexp_letmodule (s, me, e) ->
pp f "@[<hov2>let@ module@ %s@ =@ %a@ in@ %a@]" s.txt
self#reset#module_expr me self#expression e
| Pexp_letexception (cd, e) ->
pp f "@[<hov2>let@ exception@ %a@ in@ %a@]"
self#extension_constructor cd
self#expression e
| Pexp_assert e ->
pp f "@[<hov2>assert@ %a@]" self#simple_expr e
| Pexp_lazy (e) ->

View File

@ -341,6 +341,10 @@ and expression i ppf x =
line i ppf "Pexp_letmodule %a\n" fmt_string_loc s;
module_expr i ppf me;
expression i ppf e;
| Pexp_letexception (cd, e) ->
line i ppf "Pexp_letexception\n";
extension_constructor i ppf cd;
expression i ppf e;
| Pexp_assert (e) ->
line i ppf "Pexp_assert\n";
expression i ppf e;

View File

@ -0,0 +1,25 @@
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Alain Frisch, LexiFi *)
(* *)
(* Copyright 1995 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
let f (type t) () =
let exception E of t in
(fun x -> E x), (function E _ -> print_endline "OK" | _ -> print_endline "KO")
let inj1, proj1 = f ()
let inj2, proj2 = f ()
let () = proj1 (inj1 42)
let () = proj1 (inj2 42)

View File

@ -0,0 +1,2 @@
OK
KO

View File

@ -251,6 +251,7 @@ let rec add_expr bv exp =
| Pexp_letmodule(id, m, e) ->
let b = add_module_binding bv m in
add_expr (StringMap.add id.txt b bv) e
| Pexp_letexception(_, e) -> add_expr bv e
| Pexp_assert (e) -> add_expr bv e
| Pexp_lazy (e) -> add_expr bv e
| Pexp_poly (e, t) -> add_expr bv e; add_opt add_type bv t

View File

@ -284,6 +284,9 @@ and rw_exp iflag sexp =
rewrite_mod iflag smod;
rewrite_exp iflag sexp
| Pexp_letexception (_cd, exp) ->
rewrite_exp iflag exp
| Pexp_assert (cond) -> rewrite_exp iflag cond
| Pexp_lazy (expr) -> rewrite_exp iflag expr

View File

@ -362,6 +362,10 @@ and expression i ppf x =
line i ppf "Texp_letmodule \"%a\"\n" fmt_ident s;
module_expr i ppf me;
expression i ppf e;
| Texp_letexception (cd, e) ->
line i ppf "Pexp_letexception\n";
extension_constructor i ppf cd;
expression i ppf e;
| Texp_assert (e) ->
line i ppf "Texp_assert";
expression i ppf e;

View File

@ -323,6 +323,11 @@ let expr sub x =
sub.module_expr sub mexpr,
sub.expr sub exp
)
| Texp_letexception (cd, exp) ->
Texp_letexception (
sub.extension_constructor sub cd,
sub.expr sub exp
)
| Texp_assert exp ->
Texp_assert (sub.expr sub exp)
| Texp_lazy exp ->

View File

@ -166,6 +166,7 @@ let iter_expression f e =
| Pexp_send (e, _)
| Pexp_constraint (e, _)
| Pexp_coerce (e, _, _)
| Pexp_letexception (_, e)
| Pexp_field (e, _) -> expr e
| Pexp_while (e1, e2)
| Pexp_sequence (e1, e2)
@ -2729,6 +2730,16 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
exp_type = ty;
exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Pexp_letexception(cd, sbody) ->
let (cd, newenv) = Typedecl.transl_exception env cd in
let body = type_expect newenv sbody ty_expected in
re {
exp_desc = Texp_letexception(cd, body);
exp_loc = loc; exp_extra = [];
exp_type = body.exp_type;
exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Pexp_assert (e) ->
let cond = type_expect env e Predef.type_bool in
let exp_type =

View File

@ -103,6 +103,7 @@ and expression_desc =
| Texp_setinstvar of Path.t * Path.t * string loc * expression
| Texp_override of Path.t * (Path.t * string loc * expression) list
| Texp_letmodule of Ident.t * string loc * module_expr * expression
| Texp_letexception of extension_constructor * expression
| Texp_assert of expression
| Texp_lazy of expression
| Texp_object of class_structure * string list

View File

@ -204,6 +204,7 @@ and expression_desc =
| Texp_setinstvar of Path.t * Path.t * string loc * expression
| Texp_override of Path.t * (Path.t * string loc * expression) list
| Texp_letmodule of Ident.t * string loc * module_expr * expression
| Texp_letexception of extension_constructor * expression
| Texp_assert of expression
| Texp_lazy of expression
| Texp_object of class_structure * string list

View File

@ -342,6 +342,9 @@ module MakeIterator(Iter : IteratorArgument) : sig
| Texp_letmodule (id, _, mexpr, exp) ->
iter_module_expr mexpr;
iter_expression exp
| Texp_letexception (cd, exp) ->
iter_extension_constructor cd;
iter_expression exp
| Texp_assert exp -> iter_expression exp
| Texp_lazy exp -> iter_expression exp
| Texp_object (cl, _) ->

View File

@ -371,6 +371,11 @@ module MakeMap(Map : MapArgument) = struct
map_module_expr mexpr,
map_expression exp
)
| Texp_letexception (cd, exp) ->
Texp_letexception (
map_extension_constructor cd,
map_expression exp
)
| Texp_assert exp -> Texp_assert (map_expression exp)
| Texp_lazy exp -> Texp_lazy (map_expression exp)
| Texp_object (cl, string_list) ->

View File

@ -450,6 +450,9 @@ let expression sub exp =
| Texp_letmodule (_id, name, mexpr, exp) ->
Pexp_letmodule (name, sub.module_expr sub mexpr,
sub.expr sub exp)
| Texp_letexception (ext, exp) ->
Pexp_letexception (sub.extension_constructor sub ext,
sub.expr sub exp)
| Texp_assert exp -> Pexp_assert (sub.expr sub exp)
| Texp_lazy exp -> Pexp_lazy (sub.expr sub exp)
| Texp_object (cl, _) ->