Skip to content
Browse files

[enhance] compiler: Just introduce (non syntactic) typeval compiler d…

…irective
  • Loading branch information...
1 parent 5d6e63c commit c7cb78b5d95f92bf7be99bdd866630a49bca73f1 @BourgerieQuentin BourgerieQuentin committed Nov 13, 2012
View
1 compiler/libqmlcompil/qmlAst.ml
@@ -1156,6 +1156,7 @@ type qml_directive = [
| `assert_ (**As [assert]. : if --no-assert is enabled, all this directive without exception are ignored ('assert false' too) *)
| `fail (**As [assert false], with a message. : always fails, no matter if --no-assert is enabled or not. type : 'a *)
| `typeof (** -> WIP, don't use (yet) *)
+ | `typeval
| `expand of Big_int.big_int option (**Marker for macro (function) that are macro-expanded, the integer represents the number of unrolling the compiler is authorised to do, it must do at least one *)
| `restricted_bypass of string
View
5 compiler/libqmlcompil/qmlDirectives.ml
@@ -90,6 +90,9 @@ struct
let alpha = next () in
Q.TypeArrow ([alpha], opaty)
+ let typeval () =
+ Q.TypeArrow ([], opaty)
+
let callcc () =
let alpha = next () in
let f_cont =
@@ -238,6 +241,7 @@ let ty directive exprs tys =
(* === *)
(* Magic *)
| `typeof -> Ty.typeof ()
+ | `typeval -> Ty.typeval()
| `specialize _ ->
let n = List.length exprs in
assert (n >= 1);
@@ -452,6 +456,7 @@ let to_string d =
| `extendwith -> "extendwith"
| `assert_ -> "assert"
| `typeof -> "typeof"
+ | `typeval -> "typeval"
| `atomic -> "atomic"
| `immovable -> "immovable"
| `thread_context -> "thread_context"
View
7 compiler/opalang/classic_syntax/opa_parser.trx
@@ -656,6 +656,9 @@ directive1 <-
/ "unsafe_cast" {{ `unsafe_cast }}
/ "wait" {{ `wait }}
+directive1_typ <-
+ / "typeval" {{ `typeval }}
+
directive0pack <-
/ "from" {{ fun x -> `from x }}
@@ -698,6 +701,8 @@ directive <-
{{ Directive (v pck,[],[]) }}
/ "@" (=exact_ident(directive1)):v Opa_lexer.lpar_nosp expr:e rpar
{{ Directive (v,[e],[]) }}
+ / "@" (=exact_ident(directive1_typ)):v Opa_lexer.lpar_nosp typ:t rpar
+ {{ Directive (v,[],[t]) }}
/ "@" (=exact_ident(directive1str)):v Opa_lexer.lpar_nosp string:str rpar
{{ Directive (v str,[],[]) }}
/ "@" (=exact_ident(directive1rec)):v Opa_lexer.lpar_nosp (=deco(just_record)):e rpar
@@ -1213,7 +1218,7 @@ just_type_without_sum <- just_type_const:t {{ t }}
/ external {{ TypeExternal }}
/ lpar just_typ:t rpar {{ t }}
/ type_tuple
- / forall (lpar (=list1(just_flatvar,comma)):l rpar {{l}}):typevars (=exact_symbol(".")) typ:t
+ / forall (lpar (=list1(just_flatvar,comma)):l rpar {{l}}):typevars (=exact_symbol(".")) typ:t
{{ TypeForall(typevars, [], [], t) }}
/ just_type_module
View
16 compiler/opalang/js_syntax/opa_parser.trx
@@ -395,7 +395,7 @@ just_type_without_sum <- just_type_const:t {{ t }}
/ external {{ TypeExternal }}
/ lpar just_typ:t rpar {{ t }}
/ type_tuple
- / forall (lpar (=list1(just_flatvar,comma)):l rpar {{l}}):typevars (=exact_symbol(".")) typ:t
+ / forall (lpar (=list1(just_flatvar,comma)):l rpar {{l}}):typevars (=exact_symbol(".")) typ:t
{{ TypeForall(typevars, [], [], t) }}
/ type_module
@@ -1190,6 +1190,9 @@ directive1 <-
/ "unsafe_cast" {{ `unsafe_cast }}
/ "wait" {{ `wait }}
+directive1_typ <-
+ / "typeval" {{ `typeval }}
+
directive0pack <-
/ "from" {{ fun x -> `from x }}
@@ -1217,21 +1220,14 @@ directive <-
(* FIXME: could accept assert_message(,_e)(s)
* instead of just assert_message(s,e) *)
/ "@xml(" spacing Xml.xmlns:xmlns rpar {{ undecorate xmlns }}
- / "@typeval(" typ:t rpar {{
- (* For convenience, directive [@typeval] is handled as thin syntactic sugar.
- Therefore [@typeval(t)] is parsed as [@typeof(@unsafe_cast("dummy_for_typeval"):t)]
- *)
- let expr_cast = (directive1 `unsafe_cast (void (nlabel t)), nlabel t) in
- let expr_coerced = coerce_expr expr_cast t in
- let just_typeof = directive1 `typeof expr_coerced in
- just_typeof
- }}
/ "@" (=exact_ident(directive0)):v !"("
{{ Directive (v,[],[]) }}
/ "@" (=exact_ident(directive0pack)):v Opa_lexer.lpar_nosp package_identifier:pck rpar
{{ Directive (v pck,[],[]) }}
/ "@" (=exact_ident(directive1)):v Opa_lexer.lpar_nosp expr:e rpar
{{ Directive (v,[e],[]) }}
+ / "@" (=exact_ident(directive1_typ)):v Opa_lexer.lpar_nosp typ:t rpar
+ {{ Directive (v,[],[t]) }}
/ "@" (=exact_ident(directive1str)):v Opa_lexer.lpar_nosp string:str rpar
{{ Directive (v str,[],[]) }}
/ "@" (=exact_ident(directive1rec)):v Opa_lexer.lpar_nosp (=deco(record)):e rpar
View
2 compiler/opalang/opaPrint.ml
@@ -790,6 +790,7 @@ module Classic = struct
| `fun_action -> Format.pp_print_string f "fun_action"
| `magic_do -> Format.pp_print_string f "magic_do"
| `typeof -> Format.pp_print_string f "typeof"
+ | `typeval -> Format.pp_print_string f "typeval"
| `assert_ -> Format.pp_print_string f "assert_"
| `deprecated -> pp f "deprecated"
| `todo -> pp f "todo"
@@ -1372,6 +1373,7 @@ module Js = struct
| `fun_action -> Format.pp_print_string f "fun_action"
| `magic_do -> Format.pp_print_string f "magic_do"
| `typeof -> Format.pp_print_string f "typeof"
+ | `typeval -> Format.pp_print_string f "typeval"
| `assert_ -> Format.pp_print_string f "assert_"
| `deprecated -> pp f "deprecated"
| `todo -> pp f "todo"
View
2 compiler/opalang/opaToQml.ml
@@ -567,7 +567,7 @@ struct
and directive opa_annot ((c, e, t) as d) : QA.expr =
match c, e, t with
| (
- `typeof | `opensums | `openrecord | `extendwith | `unsafe_cast
+ `typeof | `typeval | `opensums | `openrecord | `extendwith | `unsafe_cast
| `nonexpansive | `doctype _ | `module_ | `module_field_lifting
| `spawn | `wait | `atomic | `callcc | `js_ident | `expand _
| `create_lazy_record | `assert_ | `fail
View
1 compiler/opalang/surfaceAst.ml
@@ -297,6 +297,7 @@ type magic_directive =
*)
| `typeof
+ | `typeval
| `specialize of [ `strict | `polymorphic ]
]
View
2 compiler/passes/surfaceAstRenaming.ml
@@ -1444,7 +1444,7 @@ and f_bindings ~rec_ all_env hierar iel =
and f_directive all_env hierar (variant, el, tl) =
let f_env, el = f_expr_list all_env hierar el in
let f_env, tl =
- let not_coerce = variant != `coerce in
+ let not_coerce = match variant with | `coerce | `typeval -> false | _ -> true in
let fold_map f_env ty =
let all_env, ty =
f_ty_ext

0 comments on commit c7cb78b

Please sign in to comment.
Something went wrong with that request. Please try again.