|
@@ -111,17 +111,17 @@ and parse_type_decls pack acc s =
|
|
| [< v = parse_type_decl; l = parse_type_decls pack (v :: acc) >] -> l
|
|
| [< v = parse_type_decl; l = parse_type_decls pack (v :: acc) >] -> l
|
|
| [< >] -> List.rev acc
|
|
| [< >] -> List.rev acc
|
|
with
|
|
with
|
|
- | TypePath ([],Some (name,false),b) ->
|
|
|
|
|
|
+ | TypePath ([],Some (name,false),b,p) ->
|
|
(* resolve imports *)
|
|
(* resolve imports *)
|
|
List.iter (fun d ->
|
|
List.iter (fun d ->
|
|
match fst d with
|
|
match fst d with
|
|
| EImport (t,_) ->
|
|
| EImport (t,_) ->
|
|
(match List.rev t with
|
|
(match List.rev t with
|
|
- | (n,_) :: path when n = name && List.for_all (fun (i,_) -> is_lower_ident i) path -> raise (TypePath (List.map fst (List.rev path),Some (name,false),b))
|
|
|
|
|
|
+ | (n,_) :: path when n = name && List.for_all (fun (i,_) -> is_lower_ident i) path -> raise (TypePath (List.map fst (List.rev path),Some (name,false),b,p))
|
|
| _ -> ())
|
|
| _ -> ())
|
|
| _ -> ()
|
|
| _ -> ()
|
|
) acc;
|
|
) acc;
|
|
- raise (TypePath (pack,Some(name,true),b))
|
|
|
|
|
|
+ raise (TypePath (pack,Some(name,true),b,p))
|
|
| Stream.Error _ when do_resume() ->
|
|
| Stream.Error _ when do_resume() ->
|
|
ignore(resume false false s);
|
|
ignore(resume false false s);
|
|
parse_type_decls pack acc s
|
|
parse_type_decls pack acc s
|
|
@@ -220,20 +220,20 @@ and parse_class doc meta cflags need_name s =
|
|
}, punion p1 p2)
|
|
}, punion p1 p2)
|
|
|
|
|
|
and parse_import s p1 =
|
|
and parse_import s p1 =
|
|
- let rec loop acc =
|
|
|
|
|
|
+ let rec loop pn acc =
|
|
match s with parser
|
|
match s with parser
|
|
| [< '(Dot,p) >] ->
|
|
| [< '(Dot,p) >] ->
|
|
let resume() =
|
|
let resume() =
|
|
- type_path (List.map fst acc) true
|
|
|
|
|
|
+ type_path (List.map fst acc) true (punion pn p)
|
|
in
|
|
in
|
|
check_resume p resume (fun () -> ());
|
|
check_resume p resume (fun () -> ());
|
|
(match s with parser
|
|
(match s with parser
|
|
| [< '(Const (Ident k),p) >] ->
|
|
| [< '(Const (Ident k),p) >] ->
|
|
- loop ((k,p) :: acc)
|
|
|
|
|
|
+ loop pn ((k,p) :: acc)
|
|
| [< '(Kwd Macro,p) >] ->
|
|
| [< '(Kwd Macro,p) >] ->
|
|
- loop (("macro",p) :: acc)
|
|
|
|
|
|
+ loop pn (("macro",p) :: acc)
|
|
| [< '(Kwd Extern,p) >] ->
|
|
| [< '(Kwd Extern,p) >] ->
|
|
- loop (("extern",p) :: acc)
|
|
|
|
|
|
+ loop pn (("extern",p) :: acc)
|
|
| [< '(Binop OpMult,_); '(Semicolon,p2) >] ->
|
|
| [< '(Binop OpMult,_); '(Semicolon,p2) >] ->
|
|
p2, List.rev acc, IAll
|
|
p2, List.rev acc, IAll
|
|
| [< >] ->
|
|
| [< >] ->
|
|
@@ -248,29 +248,29 @@ and parse_import s p1 =
|
|
serror()
|
|
serror()
|
|
in
|
|
in
|
|
let p2, path, mode = (match s with parser
|
|
let p2, path, mode = (match s with parser
|
|
- | [< '(Const (Ident name),p) >] -> loop [name,p]
|
|
|
|
|
|
+ | [< '(Const (Ident name),p) >] -> loop p [name,p]
|
|
| [< >] -> if would_skip_resume p1 s then p1, [], INormal else serror()
|
|
| [< >] -> if would_skip_resume p1 s then p1, [], INormal else serror()
|
|
) in
|
|
) in
|
|
(EImport (path,mode),punion p1 p2)
|
|
(EImport (path,mode),punion p1 p2)
|
|
|
|
|
|
and parse_using s p1 =
|
|
and parse_using s p1 =
|
|
- let rec loop acc =
|
|
|
|
|
|
+ let rec loop pn acc =
|
|
match s with parser
|
|
match s with parser
|
|
| [< '(Dot,p) >] ->
|
|
| [< '(Dot,p) >] ->
|
|
- check_resume p (fun () -> type_path (List.map fst acc) false) (fun () -> ());
|
|
|
|
|
|
+ check_resume p (fun () -> type_path (List.map fst acc) false (punion pn p)) (fun () -> ());
|
|
begin match s with parser
|
|
begin match s with parser
|
|
| [< '(Const (Ident k),p) >] ->
|
|
| [< '(Const (Ident k),p) >] ->
|
|
- loop ((k,p) :: acc)
|
|
|
|
|
|
+ loop pn ((k,p) :: acc)
|
|
| [< '(Kwd Macro,p) >] ->
|
|
| [< '(Kwd Macro,p) >] ->
|
|
- loop (("macro",p) :: acc)
|
|
|
|
|
|
+ loop pn (("macro",p) :: acc)
|
|
| [< '(Kwd Extern,p) >] ->
|
|
| [< '(Kwd Extern,p) >] ->
|
|
- loop (("extern",p) :: acc)
|
|
|
|
|
|
+ loop pn (("extern",p) :: acc)
|
|
end
|
|
end
|
|
| [< '(Semicolon,p2) >] ->
|
|
| [< '(Semicolon,p2) >] ->
|
|
p2,List.rev acc
|
|
p2,List.rev acc
|
|
in
|
|
in
|
|
let p2, path = (match s with parser
|
|
let p2, path = (match s with parser
|
|
- | [< '(Const (Ident name),p) >] -> loop [name,p]
|
|
|
|
|
|
+ | [< '(Const (Ident name),p) >] -> loop p [name,p]
|
|
| [< >] -> if would_skip_resume p1 s then p1, [] else serror()
|
|
| [< >] -> if would_skip_resume p1 s then p1, [] else serror()
|
|
) in
|
|
) in
|
|
(EUsing path,punion p1 p2)
|
|
(EUsing path,punion p1 p2)
|
|
@@ -377,7 +377,7 @@ and parse_meta_argument_expr s =
|
|
with Display e -> match fst e with
|
|
with Display e -> match fst e with
|
|
| EDisplay(e,_) ->
|
|
| EDisplay(e,_) ->
|
|
begin try
|
|
begin try
|
|
- type_path (string_list_of_expr_path_raise e) false
|
|
|
|
|
|
+ type_path (string_list_of_expr_path_raise e) false (pos e)
|
|
with Exit ->
|
|
with Exit ->
|
|
e
|
|
e
|
|
end
|
|
end
|
|
@@ -520,7 +520,7 @@ and parse_type_path2 p0 pack name p1 s =
|
|
(match s with parser
|
|
(match s with parser
|
|
| [< '(Dot,p) >] ->
|
|
| [< '(Dot,p) >] ->
|
|
check_resume p
|
|
check_resume p
|
|
- (fun () -> raise (TypePath (List.rev (name :: pack),None,false)))
|
|
|
|
|
|
+ (fun () -> raise (TypePath (List.rev (name :: pack),None,false,punion (match p0 with None -> p1 | Some p0 -> p0) p)))
|
|
(fun () -> parse_type_path1 (match p0 with None -> Some p1 | Some _ -> p0) (name :: pack) s)
|
|
(fun () -> parse_type_path1 (match p0 with None -> Some p1 | Some _ -> p0) (name :: pack) s)
|
|
| [< '(Semicolon,_) >] ->
|
|
| [< '(Semicolon,_) >] ->
|
|
error (Custom "Type name should start with an uppercase letter") p1
|
|
error (Custom "Type name should start with an uppercase letter") p1
|
|
@@ -529,7 +529,7 @@ and parse_type_path2 p0 pack name p1 s =
|
|
let sub,p2 = (match s with parser
|
|
let sub,p2 = (match s with parser
|
|
| [< '(Dot,p); s >] ->
|
|
| [< '(Dot,p); s >] ->
|
|
(check_resume p
|
|
(check_resume p
|
|
- (fun () -> raise (TypePath (List.rev pack,Some (name,false),false)))
|
|
|
|
|
|
+ (fun () -> raise (TypePath (List.rev pack,Some (name,false),false,punion (match p0 with None -> p1 | Some p0 -> p0) p)))
|
|
(fun () -> match s with parser
|
|
(fun () -> match s with parser
|
|
| [< '(Const (Ident name),p2) when not (is_lower_ident name) >] -> Some name,p2
|
|
| [< '(Const (Ident name),p2) when not (is_lower_ident name) >] -> Some name,p2
|
|
| [< >] -> serror()))
|
|
| [< >] -> serror()))
|
|
@@ -1122,13 +1122,8 @@ and expr = parser
|
|
| [< '(Const (Int i),p); e = expr_next (EConst (Int i),p) >] -> e
|
|
| [< '(Const (Int i),p); e = expr_next (EConst (Int i),p) >] -> e
|
|
| [< '(Const (Float f),p); e = expr_next (EConst (Float f),p) >] -> e
|
|
| [< '(Const (Float f),p); e = expr_next (EConst (Float f),p) >] -> e
|
|
| [< >] -> serror()) */*)
|
|
| [< >] -> serror()) */*)
|
|
- | [< '(Kwd For,p); '(POpen,_); it = expr; '(PClose,_); s >] ->
|
|
|
|
- (try
|
|
|
|
- let e = secure_expr s in
|
|
|
|
- (EFor (it,e),punion p (pos e))
|
|
|
|
- with
|
|
|
|
- Display e -> display (EFor (it,e),punion p (pos e)))
|
|
|
|
- | [< '(Kwd If,p); '(POpen,_); cond = expr; '(PClose,_); e1 = expr; s >] ->
|
|
|
|
|
|
+ | [< '(Kwd For,p); '(POpen,_); it = secure_expr; '(PClose,_); e = secure_expr >] -> (EFor (it,e),punion p (pos e))
|
|
|
|
+ | [< '(Kwd If,p); '(POpen,_); cond = secure_expr; '(PClose,_); e1 = secure_expr; s >] ->
|
|
let e2 = (match s with parser
|
|
let e2 = (match s with parser
|
|
| [< '(Kwd Else,_); e2 = expr; s >] -> Some e2
|
|
| [< '(Kwd Else,_); e2 = expr; s >] -> Some e2
|
|
| [< >] ->
|
|
| [< >] ->
|
|
@@ -1144,17 +1139,12 @@ and expr = parser
|
|
| [< '(Kwd Return,p); e = popt toplevel_expr >] -> (EReturn e, match e with None -> p | Some e -> punion p (pos e))
|
|
| [< '(Kwd Return,p); e = popt toplevel_expr >] -> (EReturn e, match e with None -> p | Some e -> punion p (pos e))
|
|
| [< '(Kwd Break,p) >] -> (EBreak,p)
|
|
| [< '(Kwd Break,p) >] -> (EBreak,p)
|
|
| [< '(Kwd Continue,p) >] -> (EContinue,p)
|
|
| [< '(Kwd Continue,p) >] -> (EContinue,p)
|
|
- | [< '(Kwd While,p1); '(POpen,_); cond = expr; '(PClose,_); s >] ->
|
|
|
|
- (try
|
|
|
|
- let e = secure_expr s in
|
|
|
|
- (EWhile (cond,e,NormalWhile),punion p1 (pos e))
|
|
|
|
- with
|
|
|
|
- Display e -> display (EWhile (cond,e,NormalWhile),punion p1 (pos e)))
|
|
|
|
- | [< '(Kwd Do,p1); e = expr; '(Kwd While,_); '(POpen,_); cond = expr; '(PClose,_); s >] -> (EWhile (cond,e,DoWhile),punion p1 (pos e))
|
|
|
|
- | [< '(Kwd Switch,p1); e = expr; '(BrOpen,_); cases , def = parse_switch_cases e []; '(BrClose,p2); s >] -> (ESwitch (e,cases,def),punion p1 p2)
|
|
|
|
- | [< '(Kwd Try,p1); e = expr; cl,p2 = parse_catches e [] (pos e) >] -> (ETry (e,cl),punion p1 p2)
|
|
|
|
|
|
+ | [< '(Kwd While,p1); '(POpen,_); cond = secure_expr; '(PClose,_); e = secure_expr >] -> (EWhile (cond,e,NormalWhile),punion p1 (pos e))
|
|
|
|
+ | [< '(Kwd Do,p1); e = secure_expr; '(Kwd While,_); '(POpen,_); cond = secure_expr; '(PClose,_); s >] -> (EWhile (cond,e,DoWhile),punion p1 (pos e))
|
|
|
|
+ | [< '(Kwd Switch,p1); e = secure_expr; '(BrOpen,_); cases , def = parse_switch_cases e []; '(BrClose,p2); s >] -> (ESwitch (e,cases,def),punion p1 p2)
|
|
|
|
+ | [< '(Kwd Try,p1); e = secure_expr; cl,p2 = parse_catches e [] (pos e) >] -> (ETry (e,cl),punion p1 p2)
|
|
| [< '(IntInterval i,p1); e2 = expr >] -> make_binop OpInterval (EConst (Int i),p1) e2
|
|
| [< '(IntInterval i,p1); e2 = expr >] -> make_binop OpInterval (EConst (Int i),p1) e2
|
|
- | [< '(Kwd Untyped,p1); e = expr >] -> (EUntyped e,punion p1 (pos e))
|
|
|
|
|
|
+ | [< '(Kwd Untyped,p1); e = secure_expr >] -> (EUntyped e,punion p1 (pos e))
|
|
| [< '(Dollar v,p); s >] -> expr_next (EConst (Ident ("$"^v)),p) s
|
|
| [< '(Dollar v,p); s >] -> expr_next (EConst (Ident ("$"^v)),p) s
|
|
|
|
|
|
and expr_next e1 s =
|
|
and expr_next e1 s =
|
|
@@ -1201,12 +1191,7 @@ and expr_next' e1 = parser
|
|
make_binop OpGte e1 (secure_expr s)
|
|
make_binop OpGte e1 (secure_expr s)
|
|
| [< e2 = secure_expr >] ->
|
|
| [< e2 = secure_expr >] ->
|
|
make_binop OpGt e1 e2)
|
|
make_binop OpGt e1 e2)
|
|
- | [< '(Binop op,_); s >] ->
|
|
|
|
- (try
|
|
|
|
- let e2 = secure_expr s in
|
|
|
|
- make_binop op e1 e2
|
|
|
|
- with Display e2 ->
|
|
|
|
- raise (Display (make_binop op e1 e2)))
|
|
|
|
|
|
+ | [< '(Binop op,_); e2 = secure_expr >] -> make_binop op e1 e2
|
|
| [< '(Unop op,p) when is_postfix e1 op; s >] ->
|
|
| [< '(Unop op,p) when is_postfix e1 op; s >] ->
|
|
expr_next (EUnop (op,Postfix,e1), punion (pos e1) p) s
|
|
expr_next (EUnop (op,Postfix,e1), punion (pos e1) p) s
|
|
| [< '(Question,_); e2 = expr; '(DblDot,_); e3 = expr >] ->
|
|
| [< '(Question,_); e2 = expr; '(DblDot,_); e3 = expr >] ->
|
|
@@ -1254,12 +1239,7 @@ and parse_switch_cases eswitch cases = parser
|
|
and parse_catch etry = parser
|
|
and parse_catch etry = parser
|
|
| [< '(Kwd Catch,p); '(POpen,_); name, pn = dollar_ident; s >] ->
|
|
| [< '(Kwd Catch,p); '(POpen,_); name, pn = dollar_ident; s >] ->
|
|
match s with parser
|
|
match s with parser
|
|
- | [< t,pt = parse_type_hint; '(PClose,_); s >] ->
|
|
|
|
- (try
|
|
|
|
- let e = secure_expr s in
|
|
|
|
- ((name,pn),(t,pt),e,punion p (pos e)),(pos e)
|
|
|
|
- with
|
|
|
|
- Display e -> display (ETry (etry,[(name,pn),(t,pt),e,(pos e)]),punion (pos etry) (pos e)))
|
|
|
|
|
|
+ | [< t,pt = parse_type_hint; '(PClose,_); e = secure_expr >] -> ((name,pn),(t,pt),e,punion p (pos e)),(pos e)
|
|
| [< '(_,p) >] -> error Missing_type p
|
|
| [< '(_,p) >] -> error Missing_type p
|
|
|
|
|
|
and parse_catches etry catches pmax = parser
|
|
and parse_catches etry catches pmax = parser
|
|
@@ -1307,17 +1287,22 @@ and parse_call_params f p1 s =
|
|
| [< >] -> parse_next_param [] p1
|
|
| [< >] -> parse_next_param [] p1
|
|
end
|
|
end
|
|
|
|
|
|
|
|
+(* Parses an expression and catches Display exceptions. *)
|
|
and toplevel_expr s =
|
|
and toplevel_expr s =
|
|
try
|
|
try
|
|
expr s
|
|
expr s
|
|
with
|
|
with
|
|
Display e -> e
|
|
Display e -> e
|
|
|
|
|
|
|
|
+(* Tries to parse a toplevel expression and defaults to a null expression when in display mode.
|
|
|
|
+ This function always accepts in display mode and should only be used for expected expressions,
|
|
|
|
+ not accepted ones! *)
|
|
and secure_expr s =
|
|
and secure_expr s =
|
|
match s with parser
|
|
match s with parser
|
|
| [< e = toplevel_expr >] -> e
|
|
| [< e = toplevel_expr >] -> e
|
|
| [< >] -> if do_resume() then mk_null_expr (punion_next (pos (last_token s)) s) else serror()
|
|
| [< >] -> if do_resume() then mk_null_expr (punion_next (pos (last_token s)) s) else serror()
|
|
|
|
|
|
|
|
+(* Like secure_expr, but with a custom fail function *)
|
|
and expr_or_fail fail s =
|
|
and expr_or_fail fail s =
|
|
match s with parser
|
|
match s with parser
|
|
| [< e = expr >] -> e
|
|
| [< e = expr >] -> e
|