Commit 80efb6aa authored by POTTIER Francois's avatar POTTIER Francois

Introduce and use the auxiliary function [CodeBits.annotate].

parent e21c419c
Pipeline #147054 passed with stages
in 25 seconds
......@@ -1239,7 +1239,7 @@ let reducebody prod =
Production.action prod
in
let act =
EAnnot (Action.to_il_expr action, type2scheme (semvtypent nt))
annotate (Action.to_il_expr action) (semvtypent nt)
in
tracecomment
......@@ -1586,10 +1586,9 @@ let discarddef = {
valpublic = false;
valpat = PVar discard;
valval =
EAnnot (
discardbody,
type2scheme (arrow tenv tenv)
)
annotate
discardbody
(arrow tenv tenv)
}
(* This is [initenv], used to allocate a fresh parser environment.
......@@ -1605,7 +1604,7 @@ let initenvdef =
valpublic = false;
valpat = PVar initenv;
valval =
EAnnot (
annotate (
EFun ( [ PVar lexer; PVar lexbuf ],
blet (
(* We do not have a dummy token at hand, so we forge one. *)
......@@ -1619,9 +1618,9 @@ let initenvdef =
]
)
)
),
type2scheme (marrow [ tlexer; tlexbuf ] tenv)
)
)
)
(marrow [ tlexer; tlexbuf ] tenv)
}
(* ------------------------------------------------------------------------ *)
......
......@@ -124,6 +124,11 @@ let scheme qs t =
let type2scheme t =
scheme [] t
(* Constraining an expression to have a (monomorphic) type. *)
let annotate e t =
EAnnot (e, type2scheme t)
let pat2var = function
| PVar x ->
x
......
......@@ -53,6 +53,10 @@ val tvar: string -> typ
val scheme: string list -> typ -> typescheme
val type2scheme: typ -> typescheme
(* Constraining an expression to have a (monomorphic) type. *)
val annotate: expr -> typ -> expr
(* Projecting out of a [PVar] pattern. *)
val pat2var: pattern -> string
......
......@@ -174,7 +174,7 @@ let inline_valdefs (defs : valdef list) : valdef list =
let rec annotate formals body typ =
match formals, typ with
| [], _ ->
[], EAnnot (body, type2scheme typ)
[], CodeBits.annotate body typ
| formal :: formals, TypArrow (targ, tres) ->
let formals, body = annotate formals body tres in
PAnnot (formal, targ) :: formals, body
......
......@@ -190,7 +190,7 @@ let destructuretokendef name codomain bindsemv branch = {
valpublic = false;
valpat = PVar name;
valval =
EAnnot (
annotate (
EFun ([ PVar token ],
EMatch (EVar token,
Terminal.fold (fun tok branches ->
......@@ -201,9 +201,9 @@ let destructuretokendef name codomain bindsemv branch = {
branchbody = branch tok } :: branches
) []
)
),
type2scheme (arrow TokenType.ttoken codomain)
)
)
(arrow TokenType.ttoken codomain)
}
(* ------------------------------------------------------------------------ *)
......
......@@ -144,10 +144,9 @@ let actiondef grammar symbol branch =
semantic action. *)
let body =
EAnnot (
Action.to_il_expr branch.action,
type2scheme (nttype grammar symbol)
)
annotate
(Action.to_il_expr branch.action)
(nttype grammar symbol)
in
match formals with
......@@ -188,7 +187,7 @@ let program grammar =
let def = {
valpublic = true;
valpat = PTuple ps;
valval = ELet (bindings1 @ bindings2, EAnnot (bottom, type2scheme (TypTuple ts)))
valval = ELet (bindings1 @ bindings2, annotate bottom (TypTuple ts))
}
in
......
......@@ -191,7 +191,7 @@ let reducecellcasts prod i symbol casts =
(* Cast: [let id = ((Obj.magic id) : t) in ...]. *)
(
PVar id,
EAnnot (EMagic (EVar id), type2scheme t)
annotate (EMagic (EVar id)) t
) :: casts
(* 2015/11/04. The start and end positions of an epsilon production are obtained
......@@ -260,7 +260,7 @@ let reducebody prod =
Production.action prod
in
let act =
EAnnot (Action.to_il_expr action, type2scheme (semvtypent nt))
annotate (Action.to_il_expr action) (semvtypent nt)
in
EComment (
......@@ -697,7 +697,7 @@ let monolithic_entry_point state nt t =
and lexbuf = "lexbuf" in
EFun (
[ PVar lexer; PVar lexbuf ],
EAnnot (
annotate (
EMagic (
EApp (
EVar entry, [
......@@ -706,9 +706,9 @@ let monolithic_entry_point state nt t =
EVar lexbuf
]
)
),
type2scheme (TypTextual t)
)
)
(TypTextual t)
)
)
......@@ -732,7 +732,7 @@ let incremental_entry_point state nt t =
to the standard error channel. *)
EFun (
[ PVar initial ],
EAnnot (
annotate (
EMagic (
EApp (
EVar start, [
......@@ -740,9 +740,9 @@ let incremental_entry_point state nt t =
EVar initial;
]
)
),
type2scheme (checkpoint (TypTextual t))
)
)
(checkpoint (TypTextual t))
)
)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment