ocaml/camlp4/compile/compile.ml

577 lines
18 KiB
OCaml

(* camlp4r *)
(* $Id$ *)
#load "q_MLast.cmo";
open Gramext;
value strict_parsing = ref False;
value keywords = ref [];
value loc = (0, 0);
(* Watch the segmentation faults here! the compiled file must have been
loaded in camlp4 with the option pa_extend.cmo -meta_action. *)
value magic_act (act : Obj.t) : MLast.expr = Obj.magic act;
(* Names of symbols for error messages; code borrowed to grammar.ml *)
value rec name_of_symbol entry =
fun
[ Snterm e -> "[" ^ e.ename ^ "]"
| Snterml e l -> "[" ^ e.ename ^ " level " ^ l ^ "]"
| Sself | Snext -> "[" ^ entry.ename ^ "]"
| Stoken tok -> entry.egram.glexer.Token.text tok
| _ -> "???" ]
;
value rec name_of_symbol_failed entry =
fun
[ Slist0 s -> name_of_symbol_failed entry s
| Slist0sep s _ -> name_of_symbol_failed entry s
| Slist1 s -> name_of_symbol_failed entry s
| Slist1sep s _ -> name_of_symbol_failed entry s
| Sopt s -> name_of_symbol_failed entry s
| Stree t -> name_of_tree_failed entry t
| s -> name_of_symbol entry s ]
and name_of_tree_failed entry =
fun
[ Node {node = s; brother = bro; son = son} ->
let txt = name_of_symbol_failed entry s in
let txt =
match (s, son) with
[ (Sopt _, Node _) -> txt ^ " or " ^ name_of_tree_failed entry son
| _ -> txt ]
in
let txt =
match bro with
[ DeadEnd | LocAct _ _ -> txt
| _ -> txt ^ " or " ^ name_of_tree_failed entry bro ]
in
txt
| DeadEnd | LocAct _ _ -> "???" ]
;
value tree_failed entry prev_symb tree =
let (s2, s3) =
let txt = name_of_tree_failed entry tree in
match prev_symb with
[ Slist0 s ->
let txt1 = name_of_symbol_failed entry s in
("", txt1 ^ " or " ^ txt)
| Slist1 s ->
let txt1 = name_of_symbol_failed entry s in
("", txt1 ^ " or " ^ txt)
| Slist0sep s sep ->
let txt1 = name_of_symbol_failed entry s in
("", txt1 ^ " or " ^ txt)
| Slist1sep s sep ->
let txt1 = name_of_symbol_failed entry s in
("", txt1 ^ " or " ^ txt)
| Sopt _ | Stree _ -> ("", txt)
| _ -> (name_of_symbol entry prev_symb, txt) ]
in
<:expr<
P.error $str:entry.ename$ $str:String.escaped s2$ $str:String.escaped s3$
>>
;
(* Compilation *)
value rec find_act =
fun
[ DeadEnd -> failwith "find_act"
| LocAct act _ -> (magic_act act, 0)
| Node {son = son; brother = bro} ->
let (act, n) = try find_act son with [ Failure _ -> find_act bro ] in
(act, n + 1) ]
;
value level_number e l =
match e.edesc with
[ Dlevels elevs ->
loop 0 elevs where rec loop n =
fun
[ [lev :: levs] -> if lev.lname = Some l then n else loop (n + 1) levs
| [] -> failwith ("level " ^ l ^ " not found in entry " ^ e.ename) ]
| Dparser _ -> 0 ]
;
value nth_patt_of_act (e, n) =
let patt_list =
loop e where rec loop =
fun
[ <:expr< fun (loc : (int * int)) -> $_$ >> -> []
| <:expr< fun ($p$ : $_$) -> $e$ >> -> [p :: loop e]
| <:expr< fun $p$ -> $e$ >> -> [p :: loop e]
| _ -> failwith "nth_patt_of_act" ]
in
List.nth patt_list n
;
value rec last_patt_of_act =
fun
[ <:expr< fun ($p$ : $_$) (loc : (int * int)) -> $_$ >> -> p
| <:expr< fun $_$ -> $e$ >> -> last_patt_of_act e
| _ -> failwith "last_patt_of_act" ]
;
value rec final_action =
fun
[ <:expr< fun (loc : (int * int)) -> ($e$ : $_$) >> -> e
| <:expr< fun $_$ -> $e$ >> -> final_action e
| _ -> failwith "final_action" ]
;
value parse_standard_symbol e rkont fkont ending_act =
<:expr<
match try Some ($e$ strm__) with [ Stream.Failure -> None ] with
[ Some $nth_patt_of_act ending_act$ -> $rkont$
| _ -> $fkont$ ]
>>
;
value rec contain_loc =
fun
[ <:expr< $lid:s$ >> -> s = "loc"
| <:expr< $uid:_$ >> -> False
| <:expr< $str:_$ >> -> False
| <:expr< ($list:el$) >> -> List.exists contain_loc el
| <:expr< $e1$ $e2$ >> -> contain_loc e1 || contain_loc e2
| _ -> True ]
;
value gen_let_loc loc e =
if contain_loc e then <:expr< let loc = P.gloc bp strm__ in $e$ >> else e
;
value phony_entry = Grammar.Entry.obj Pcaml.implem;
value rec parse_tree entry nlevn alevn (tree, fst_symb) act_kont kont =
match tree with
[ DeadEnd -> kont
| LocAct act _ ->
let act = magic_act act in
act_kont False act
| Node {node = Sself; son = LocAct act _; brother = bro} ->
let act = magic_act act in
let n = entry.ename ^ "_" ^ string_of_int alevn in
let e =
if strict_parsing.val || alevn = 0 || fst_symb then <:expr< $lid:n$ >>
else <:expr< P.orzero $lid:n$ $lid:entry.ename ^ "_0"$ >>
in
let p2 =
match bro with
[ DeadEnd -> kont
| _ -> parse_tree entry nlevn alevn (bro, fst_symb) act_kont kont ]
in
let p1 = act_kont True act in
parse_standard_symbol e p1 p2 (act, 0)
| Node {node = s; son = LocAct act _; brother = bro} ->
let act = magic_act act in
let p2 = parse_tree entry nlevn alevn (bro, fst_symb) act_kont kont in
let p1 = act_kont False act in
parse_symbol entry nlevn s p1 p2 (act, 0)
| Node {node = s; son = son; brother = bro} ->
let p2 = parse_tree entry nlevn alevn (bro, fst_symb) act_kont kont in
let p1 =
let err =
let txt = tree_failed entry s son in
<:expr< raise (Stream.Error $txt$) >>
in
match son with
[ Node {brother = DeadEnd} ->
parse_tree entry nlevn alevn (son, False) act_kont err
| _ ->
let p1 =
parse_tree entry nlevn alevn (son, True) act_kont
<:expr< raise Stream.Failure >>
in
<:expr< try $p1$ with [ Stream.Failure -> $err$ ] >> ]
in
parse_symbol entry nlevn s p1 p2 (find_act son) ]
and parse_symbol entry nlevn s rkont fkont ending_act =
match s with
[ Slist0 s ->
let e = <:expr< P.list0 $symbol_parser entry nlevn s$ >> in
parse_standard_symbol e rkont fkont ending_act
| Slist1 s ->
let e = <:expr< P.list1 $symbol_parser entry nlevn s$ >> in
parse_standard_symbol e rkont fkont ending_act
| Slist0sep s sep ->
let e =
<:expr<
P.list0sep $symbol_parser entry nlevn s$
$symbol_parser entry nlevn sep$ >>
in
parse_standard_symbol e rkont fkont ending_act
| Slist1sep s sep ->
let e =
<:expr<
P.list1sep $symbol_parser entry nlevn s$
$symbol_parser entry nlevn sep$ >>
in
parse_standard_symbol e rkont fkont ending_act
| Sopt s ->
let e = <:expr< P.option $symbol_parser entry nlevn s$ >> in
parse_standard_symbol e rkont fkont ending_act
| Stree tree ->
let kont = <:expr< raise Stream.Failure >> in
let act_kont _ act = gen_let_loc loc (final_action act) in
let e = parse_tree phony_entry 0 0 (tree, True) act_kont kont in
parse_standard_symbol <:expr< fun strm__ -> $e$ >> rkont fkont ending_act
| Snterm e ->
let n =
match e.edesc with
[ Dparser _ -> e.ename
| Dlevels _ -> e.ename ^ "_0" ]
in
parse_standard_symbol <:expr< $lid:n$ >> rkont fkont ending_act
| Snterml e l ->
let n = e.ename ^ "_" ^ string_of_int (level_number e l) in
parse_standard_symbol <:expr< $lid:n$ >> rkont fkont ending_act
| Sself ->
let n = entry.ename ^ "_0" in
parse_standard_symbol <:expr< $lid:n$ >> rkont fkont ending_act
| Stoken tok ->
let _ =
do {
if fst tok = "" && not (List.mem (snd tok) keywords.val) then
keywords.val := [snd tok :: keywords.val]
else ()
}
in
let p =
let patt = nth_patt_of_act ending_act in
let p_con = String.escaped (fst tok) in
let p_prm = String.escaped (snd tok) in
if snd tok = "" then
if fst tok = "ANY" then <:patt< (_, $patt$) >>
else <:patt< ($str:p_con$, $patt$) >>
else
let p = <:patt< ($str:p_con$, $str:p_prm$) >> in
match patt with
[ <:patt< _ >> -> <:patt< ($str:p_con$, $str:p_prm$) >>
| _ -> <:patt< ($str:p_con$, ($str:p_prm$ as $patt$)) >> ]
in
<:expr<
match Stream.peek strm__ with
[ Some $p$ -> do { Stream.junk strm__; $rkont$ }
| _ -> $fkont$ ]
>>
| _ ->
parse_standard_symbol <:expr< ps >> rkont fkont ending_act ]
and symbol_parser entry nlevn =
fun
[ Snterm e ->
let n = e.ename ^ "_0" in
<:expr< $lid:n$ >>
| Snterml e l ->
let n = e.ename ^ "_" ^ string_of_int (level_number e l) in
<:expr< $lid:n$ >>
| Snext ->
let n = entry.ename ^ "_" ^ string_of_int nlevn in
if strict_parsing.val then <:expr< $lid:n$ >>
else
let n0 = entry.ename ^ "_0" in
<:expr< P.orzero $lid:n$ $lid:n0$ >>
| Stoken tok ->
let _ =
do {
if fst tok = "" && not (List.mem (snd tok) keywords.val) then
keywords.val := [snd tok :: keywords.val]
else ()
}
in
let p_con = String.escaped (fst tok) in
let p_prm = String.escaped (snd tok) in
<:expr< P.token ($str:p_con$, $str:p_prm$) >>
| Stree tree ->
let kont = <:expr< raise Stream.Failure >> in
let act_kont _ act = final_action act in
<:expr<
fun strm__ ->
$parse_tree phony_entry 0 0 (tree, True) act_kont kont$
>>
| _ ->
<:expr< aaa >> ]
;
value rec start_parser_of_levels entry clevn levs =
let n = entry.ename ^ "_" ^ string_of_int clevn in
let next = entry.ename ^ "_" ^ string_of_int (clevn + 1) in
let p = <:patt< $lid:n$ >> in
match levs with
[ [] -> [Some (p, <:expr< fun strm__ -> raise Stream.Failure >>)]
| [lev :: levs] ->
let pel = start_parser_of_levels entry (succ clevn) levs in
match lev.lprefix with
[ DeadEnd ->
let ncont =
if not strict_parsing.val && clevn = 0 then
entry.ename ^ "_gen_cont"
else entry.ename ^ "_" ^ string_of_int clevn ^ "_cont"
in
let curr =
<:expr< let a = $lid:next$ strm__ in $lid:ncont$ bp a strm__ >>
in
let curr = <:expr< let bp = Stream.count strm__ in $curr$ >> in
let e = <:expr< fun strm__ -> $curr$ >> in
let pel = if levs = [] then [] else pel in
[Some (p, e) :: pel]
| tree ->
let alevn = clevn in
let (kont, pel) =
match levs with
[ [] -> (<:expr< raise Stream.Failure >>, [])
| _ ->
let e =
match (lev.assoc, lev.lsuffix) with
[ (NonA, _) | (_, DeadEnd) -> <:expr< $lid:next$ strm__ >>
| _ ->
let ncont =
entry.ename ^ "_" ^ string_of_int clevn ^ "_cont"
in
<:expr<
let a = $lid:next$ strm__ in
$lid:ncont$ bp a strm__
>> ]
in
(e, pel) ]
in
let act_kont end_with_self act =
if lev.lsuffix = DeadEnd then gen_let_loc loc (final_action act)
else
let ncont = entry.ename ^ "_" ^ string_of_int clevn ^ "_cont" in
gen_let_loc loc
<:expr< $lid:ncont$ bp $final_action act$ strm__ >>
in
let curr =
parse_tree entry (succ clevn) alevn (tree, True) act_kont kont
in
let curr = <:expr< let bp = Stream.count strm__ in $curr$ >> in
let e = <:expr< fun strm__ -> $curr$ >> in
[Some (p, e) :: pel] ] ]
;
value rec continue_parser_of_levels entry clevn levs =
let n = entry.ename ^ "_" ^ string_of_int clevn ^ "_cont" in
let p = <:patt< $lid:n$ >> in
match levs with
[ [] -> [None]
| [lev :: levs] ->
let pel = continue_parser_of_levels entry (succ clevn) levs in
match lev.lsuffix with
[ DeadEnd ->
(*
let ncont = entry.ename ^ "_" ^ string_of_int clevn ^ "_cont" in
let e = <:expr< fun bp a__ strm__ -> a__ >> in
let pel = if levs = [] then [] else pel in
*)
[None :: pel]
| tree ->
let alevn =
match lev.assoc with
[ LeftA | NonA -> succ clevn
| RightA -> clevn ]
in
let (kont, pel) =
match levs with
[ [] -> (<:expr< a__ >>, [])
| _ -> (<:expr< a__ >>, pel) ]
in
let act_kont end_with_self act =
let p = last_patt_of_act act in
match lev.assoc with
[ RightA | NonA ->
<:expr<
let $p$ = a__ in
$gen_let_loc loc (final_action act)$
>>
| LeftA ->
let ncont =
entry.ename ^ "_" ^ string_of_int clevn ^ "_cont"
in
gen_let_loc loc
<:expr<
let $p$ = a__ in
$lid:ncont$ bp $final_action act$ strm__
>> ]
in
let curr =
parse_tree entry (succ clevn) alevn (tree, True) act_kont kont
in
let e = <:expr< fun bp a__ strm__ -> $curr$ >> in
[Some (p, e) :: pel] ] ]
;
value continue_parser_of_levels_again entry levs =
let n = entry.ename ^ "_gen_cont" in
let e =
loop <:expr< a__ >> 0 levs where rec loop var levn =
fun
[ [] -> <:expr< if x == a__ then x else $lid:n$ bp x strm__ >>
| [lev :: levs] ->
match lev.lsuffix with
[ DeadEnd -> loop var (levn + 1) levs
| _ ->
let n = entry.ename ^ "_" ^ string_of_int levn ^ "_cont" in
let rest = loop <:expr< x >> (levn + 1) levs in
<:expr< let x = $lid:n$ bp $var$ strm__ in $rest$ >> ] ]
in
(<:patt< $lid:n$ >>, <:expr< fun bp a__ strm__ -> $e$ >>)
;
value empty_entry ename =
let p = <:patt< $lid:ename$ >> in
let e =
<:expr<
fun strm__ ->
raise (Stream.Error $str:"entry [" ^ ename ^ "] is empty"$) >>
in
[Some (p, e)]
;
value start_parser_of_entry entry =
match entry.edesc with
[ Dlevels [] -> empty_entry entry.ename
| Dlevels elev -> start_parser_of_levels entry 0 elev
| Dparser p -> [] ]
;
value continue_parser_of_entry entry =
match entry.edesc with
[ Dlevels elev -> continue_parser_of_levels entry 0 elev
| Dparser p -> [] ]
;
value continue_parser_of_entry_again entry =
if strict_parsing.val then []
else
match entry.edesc with
[ Dlevels ([_; _ :: _] as levs) ->
[continue_parser_of_levels_again entry levs]
| _ -> [] ]
;
value rec list_alternate l1 l2 =
match (l1, l2) with
[ ([x1 :: l1], [x2 :: l2]) -> [x1; x2 :: list_alternate l1 l2]
| ([], l2) -> l2
| (l1, []) -> l1 ]
;
value compile_entry entry =
let pel1 = start_parser_of_entry entry in
let pel2 = continue_parser_of_entry entry in
let pel = list_alternate pel1 pel2 in
List.fold_right
(fun pe list ->
match pe with
[ Some pe -> [pe :: list]
| None -> list ])
pel (continue_parser_of_entry_again entry)
;
(* get all entries connected together *)
value rec scan_tree list =
fun
[ Node {node = n; son = son; brother = bro} ->
let list = scan_symbol list n in
let list = scan_tree list son in
let list = scan_tree list bro in
list
| LocAct _ _ | DeadEnd -> list ]
and scan_symbol list =
fun
[ Snterm e -> scan_entry list e
| Snterml e l -> scan_entry list e
| Slist0 s -> scan_symbol list s
| Slist0sep s sep -> scan_symbol (scan_symbol list s) sep
| Slist1 s -> scan_symbol list s
| Slist1sep s sep -> scan_symbol (scan_symbol list s) sep
| Sopt s -> scan_symbol list s
| Stree t -> scan_tree list t
| Sself | Snext | Stoken _ -> list ]
and scan_level list lev =
let list = scan_tree list lev.lsuffix in
let list = scan_tree list lev.lprefix in
list
and scan_levels list levs = List.fold_left scan_level list levs
and scan_entry list entry =
if List.memq entry list then list
else
match entry.edesc with
[ Dlevels levs -> scan_levels [entry :: list] levs
| Dparser _ -> list ]
;
value all_entries_in_graph list entry =
List.rev (scan_entry list entry)
;
(* main *)
value entries = ref [];
(*
[Grammar.Entry.obj Pcaml.interf;
Grammar.Entry.obj Pcaml.implem;
Grammar.Entry.obj Pcaml.top_phrase;
Grammar.Entry.obj Pcaml.use_file;
Grammar.Entry.obj Pcaml.str_item;
Grammar.Entry.obj Pcaml.sig_item;
Grammar.Entry.obj Pcaml.ctyp;
Grammar.Entry.obj Pcaml.expr;
Grammar.Entry.obj Pcaml.patt]
*)
value rec list_mem_right_assoc x =
fun
[ [] -> False
| [(a, b) :: l] -> x = b || list_mem_right_assoc x l ]
;
value rec expr_list =
fun
[ [] -> <:expr< [] >>
| [x :: l] -> <:expr< [$str:String.escaped x$ :: $expr_list l$] >> ]
;
value compile () =
let _ = do { keywords.val := []; } in
let list = List.fold_left all_entries_in_graph [] entries.val in
let list =
List.filter (fun e -> List.memq e list) entries.val @
List.filter (fun e -> not (List.memq e entries.val)) list
in
let list =
let set = ref [] in
List.fold_right
(fun entry list ->
if List.mem entry.ename set.val then
list
else do { set.val := [entry.ename :: set.val]; [entry :: list] })
list []
in
let pell = List.map compile_entry list in
let pel = List.flatten pell in
let si1 = <:str_item< value rec $list:pel$ >> in
let si2 =
let list = List.sort compare keywords.val in
<:str_item<
List.iter (fun kw -> P.lexer.Token.using ("", kw))
$expr_list list$
>>
in
let loc = (1, 1) in
([(si1, loc); (si2, loc)], False)
;
Pcaml.parse_implem.val := fun _ -> compile ();
Pcaml.add_option "-strict_parsing" (Arg.Set strict_parsing)
" don't generate error recovering by trying continuations or first levels"
;