summaryrefslogtreecommitdiffstats
path: root/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParserParser.ml
diff options
context:
space:
mode:
Diffstat (limited to 'camlp4/Camlp4Parsers/Camlp4OCamlRevisedParserParser.ml')
-rw-r--r--camlp4/Camlp4Parsers/Camlp4OCamlRevisedParserParser.ml394
1 files changed, 0 insertions, 394 deletions
diff --git a/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParserParser.ml b/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParserParser.ml
deleted file mode 100644
index 2bdab6bf9..000000000
--- a/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParserParser.ml
+++ /dev/null
@@ -1,394 +0,0 @@
-open Camlp4; (* -*- camlp4r -*- *)
-(****************************************************************************)
-(* *)
-(* OCaml *)
-(* *)
-(* INRIA Rocquencourt *)
-(* *)
-(* Copyright 1998-2006 Institut National de Recherche en Informatique et *)
-(* en Automatique. All rights reserved. This file is distributed under *)
-(* the terms of the GNU Library General Public License, with the special *)
-(* exception on linking described in LICENSE at the top of the OCaml *)
-(* source tree. *)
-(* *)
-(****************************************************************************)
-
-(* Authors:
- * - Daniel de Rauglaudre: initial version
- * - Nicolas Pouillard: refactoring
- *)
-
-
-module Id : Sig.Id = struct
- value name = "Camlp4OCamlRevisedParserParser";
- value version = Sys.ocaml_version;
-end;
-
-module Make (Syntax : Sig.Camlp4Syntax) = struct
- open Sig;
- include Syntax;
-
- type spat_comp =
- [ SpTrm of Loc.t and Ast.patt and option Ast.expr
- | SpNtr of Loc.t and Ast.patt and Ast.expr
- | SpStr of Loc.t and Ast.patt ]
- ;
- type sexp_comp =
- [ SeTrm of Loc.t and Ast.expr | SeNtr of Loc.t and Ast.expr ]
- ;
-
- value stream_expr = Gram.Entry.mk "stream_expr";
- value stream_begin = Gram.Entry.mk "stream_begin";
- value stream_end = Gram.Entry.mk "stream_end";
- value stream_quot = Gram.Entry.mk "stream_quot";
- value parser_case = Gram.Entry.mk "parser_case";
- value parser_case_list = Gram.Entry.mk "parser_case_list";
-
- value strm_n = "__strm";
- value peek_fun _loc = <:expr< Stream.peek >>;
- value junk_fun _loc = <:expr< Stream.junk >>;
-
- (* Parsers. *)
- (* In syntax generated, many cases are optimisations. *)
-
- value rec pattern_eq_expression p e =
- match (p, e) with
- [ (<:patt< $lid:a$ >>, <:expr< $lid:b$ >>) -> a = b
- | (<:patt< $uid:a$ >>, <:expr< $uid:b$ >>) -> a = b
- | (<:patt< $p1$ $p2$ >>, <:expr< $e1$ $e2$ >>) ->
- pattern_eq_expression p1 e1 && pattern_eq_expression p2 e2
- | _ -> False ]
- ;
-
- value is_raise e =
- match e with
- [ <:expr< raise $_$ >> -> True
- | _ -> False ]
- ;
-
- value is_raise_failure e =
- match e with
- [ <:expr< raise Stream.Failure >> -> True
- | _ -> False ]
- ;
-
- value rec handle_failure e =
- match e with
- [ <:expr< try $_$ with [ Stream.Failure -> $e$] >> ->
- handle_failure e
- | <:expr< match $me$ with [ $a$ ] >> ->
- let rec match_case_handle_failure =
- fun
- [ <:match_case< $a1$ | $a2$ >> ->
- match_case_handle_failure a1 && match_case_handle_failure a2
- | <:match_case< $pat:_$ -> $e$ >> -> handle_failure e
- | _ -> False ]
- in handle_failure me && match_case_handle_failure a
- | <:expr< let $bi$ in $e$ >> ->
- let rec binding_handle_failure =
- fun
- [ <:binding< $b1$ and $b2$ >> ->
- binding_handle_failure b1 && binding_handle_failure b2
- | <:binding< $_$ = $e$ >> -> handle_failure e
- | _ -> False ]
- in binding_handle_failure bi && handle_failure e
- | <:expr< $lid:_$ >> | <:expr< $int:_$ >> | <:expr< $str:_$ >> |
- <:expr< $chr:_$ >> | <:expr< fun [ $_$ ] >> | <:expr< $uid:_$ >> ->
- True
- | <:expr< raise $e$ >> ->
- match e with
- [ <:expr< Stream.Failure >> -> False
- | _ -> True ]
- | <:expr< $f$ $x$ >> ->
- is_constr_apply f && handle_failure f && handle_failure x
- | _ -> False ]
- and is_constr_apply =
- fun
- [ <:expr< $uid:_$ >> -> True
- | <:expr< $lid:_$ >> -> False
- | <:expr< $x$ $_$ >> -> is_constr_apply x
- | _ -> False ]
- ;
-
- value rec subst v e =
- let _loc = Ast.loc_of_expr e in
- match e with
- [ <:expr< $lid:x$ >> ->
- let x = if x = v then strm_n else x in
- <:expr< $lid:x$ >>
- | <:expr< $uid:_$ >> -> e
- | <:expr< $int:_$ >> -> e
- | <:expr< $chr:_$ >> -> e
- | <:expr< $str:_$ >> -> e
- | <:expr< $_$ . $_$ >> -> e
- | <:expr< let $rec:rf$ $bi$ in $e$ >> ->
- <:expr< let $rec:rf$ $subst_binding v bi$ in $subst v e$ >>
- | <:expr< $e1$ $e2$ >> -> <:expr< $subst v e1$ $subst v e2$ >>
- | <:expr< ( $tup:e$ ) >> -> <:expr< ( $tup:subst v e$ ) >>
- | <:expr< $e1$, $e2$ >> -> <:expr< $subst v e1$, $subst v e2$ >>
- | _ -> raise Not_found ]
- and subst_binding v =
- fun
- [ <:binding@_loc< $b1$ and $b2$ >> ->
- <:binding< $subst_binding v b1$ and $subst_binding v b2$ >>
- | <:binding@_loc< $lid:v'$ = $e$ >> ->
- <:binding< $lid:v'$ = $if v = v' then e else subst v e$ >>
- | _ -> raise Not_found ];
-
- value stream_pattern_component skont ckont =
- fun
- [ SpTrm _loc p None ->
- <:expr< match $peek_fun _loc$ $lid:strm_n$ with
- [ Some $p$ ->
- do { $junk_fun _loc$ $lid:strm_n$; $skont$ }
- | _ -> $ckont$ ] >>
- | SpTrm _loc p (Some w) ->
- <:expr< match $peek_fun _loc$ $lid:strm_n$ with
- [ Some $p$ when $w$ ->
- do { $junk_fun _loc$ $lid:strm_n$; $skont$ }
- | _ -> $ckont$ ] >>
- | SpNtr _loc p e ->
- let e =
- match e with
- [ <:expr< fun [ ($lid:v$ : Stream.t _) -> $e$ ] >> when v = strm_n -> e
- | _ -> <:expr< $e$ $lid:strm_n$ >> ]
- in
- if pattern_eq_expression p skont then
- if is_raise_failure ckont then e
- else if handle_failure e then e
- else <:expr< try $e$ with [ Stream.Failure -> $ckont$ ] >>
- else if is_raise_failure ckont then
- <:expr< let $p$ = $e$ in $skont$ >>
- else if pattern_eq_expression <:patt< Some $p$ >> skont then
- <:expr< try Some $e$ with [ Stream.Failure -> $ckont$ ] >>
- else if is_raise ckont then
- let tst =
- if handle_failure e then e
- else <:expr< try $e$ with [ Stream.Failure -> $ckont$ ] >>
- in
- <:expr< let $p$ = $tst$ in $skont$ >>
- else
- <:expr< match try Some $e$ with [ Stream.Failure -> None ] with
- [ Some $p$ -> $skont$
- | _ -> $ckont$ ] >>
- | SpStr _loc p ->
- try
- match p with
- [ <:patt< $lid:v$ >> -> subst v skont
- | _ -> raise Not_found ]
- with
- [ Not_found -> <:expr< let $p$ = $lid:strm_n$ in $skont$ >> ] ]
- ;
-
- value rec stream_pattern _loc epo e ekont =
- fun
- [ [] ->
- match epo with
- [ Some ep -> <:expr< let $ep$ = Stream.count $lid:strm_n$ in $e$ >>
- | _ -> e ]
- | [(spc, err) :: spcl] ->
- let skont =
- let ekont err =
- let str =
- match err with
- [ Some estr -> estr
- | _ -> <:expr< "" >> ]
- in
- <:expr< raise (Stream.Error $str$) >>
- in
- stream_pattern _loc epo e ekont spcl
- in
- let ckont = ekont err in stream_pattern_component skont ckont spc ]
- ;
-
- value stream_patterns_term _loc ekont tspel =
- let pel =
- List.fold_right
- (fun (p, w, _loc, spcl, epo, e) acc ->
- let p = <:patt< Some $p$ >> in
- let e =
- let ekont err =
- let str =
- match err with
- [ Some estr -> estr
- | _ -> <:expr< "" >> ]
- in
- <:expr< raise (Stream.Error $str$) >>
- in
- let skont = stream_pattern _loc epo e ekont spcl in
- <:expr< do { $junk_fun _loc$ $lid:strm_n$; $skont$ } >>
- in
- match w with
- [ Some w -> <:match_case< $pat:p$ when $w$ -> $e$ | $acc$ >>
- | None -> <:match_case< $pat:p$ -> $e$ | $acc$ >> ])
- tspel <:match_case<>>
- in
- <:expr< match $peek_fun _loc$ $lid:strm_n$ with [ $pel$ | _ -> $ekont ()$ ] >>
- ;
-
- value rec group_terms =
- fun
- [ [([(SpTrm _loc p w, None) :: spcl], epo, e) :: spel] ->
- let (tspel, spel) = group_terms spel in
- ([(p, w, _loc, spcl, epo, e) :: tspel], spel)
- | spel -> ([], spel) ]
- ;
-
- value rec parser_cases _loc =
- fun
- [ [] -> <:expr< raise Stream.Failure >>
- | spel ->
- match group_terms spel with
- [ ([], [(spcl, epo, e) :: spel]) ->
- stream_pattern _loc epo e (fun _ -> parser_cases _loc spel) spcl
- | (tspel, spel) ->
- stream_patterns_term _loc (fun _ -> parser_cases _loc spel) tspel ] ]
- ;
-
- value cparser _loc bpo pc =
- let e = parser_cases _loc pc in
- let e =
- match bpo with
- [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $e$ >>
- | None -> e ]
- in
- let p = <:patt< ($lid:strm_n$ : Stream.t _) >> in
- <:expr< fun $p$ -> $e$ >>
- ;
-
- value cparser_match _loc me bpo pc =
- let pc = parser_cases _loc pc in
- let e =
- match bpo with
- [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >>
- | None -> pc ]
- in
- let me =
- match me with
- [ <:expr@_loc< $_$; $_$ >> as e -> <:expr< do { $e$ } >>
- | e -> e ]
- in
- match me with
- [ <:expr< $lid:x$ >> when x = strm_n -> e
- | _ -> <:expr< let ($lid:strm_n$ : Stream.t _) = $me$ in $e$ >> ]
- ;
-
- (* streams *)
-
- value rec not_computing =
- fun
- [ <:expr< $lid:_$ >> | <:expr< $uid:_$ >> | <:expr< $int:_$ >> |
- <:expr< $flo:_$ >> | <:expr< $chr:_$ >> | <:expr< $str:_$ >> -> True
- | <:expr< $x$ $y$ >> -> is_cons_apply_not_computing x && not_computing y
- | _ -> False ]
- and is_cons_apply_not_computing =
- fun
- [ <:expr< $uid:_$ >> -> True
- | <:expr< $lid:_$ >> -> False
- | <:expr< $x$ $y$ >> -> is_cons_apply_not_computing x && not_computing y
- | _ -> False ]
- ;
-
- value slazy _loc e =
- match e with
- [ <:expr< $f$ () >> ->
- match f with
- [ <:expr< $lid:_$ >> -> f
- | _ -> <:expr< fun _ -> $e$ >> ]
- | _ -> <:expr< fun _ -> $e$ >> ]
- ;
-
- value rec cstream gloc =
- fun
- [ [] -> let _loc = gloc in <:expr< Stream.sempty >>
- | [SeTrm _loc e] ->
- if not_computing e then <:expr< Stream.ising $e$ >>
- else <:expr< Stream.lsing $slazy _loc e$ >>
- | [SeTrm _loc e :: secl] ->
- if not_computing e then <:expr< Stream.icons $e$ $cstream gloc secl$ >>
- else <:expr< Stream.lcons $slazy _loc e$ $cstream gloc secl$ >>
- | [SeNtr _loc e] ->
- if not_computing e then e else <:expr< Stream.slazy $slazy _loc e$ >>
- | [SeNtr _loc e :: secl] ->
- if not_computing e then <:expr< Stream.iapp $e$ $cstream gloc secl$ >>
- else <:expr< Stream.lapp $slazy _loc e$ $cstream gloc secl$ >> ]
- ;
- (* Syntax extensions in Revised Syntax grammar *)
-
- EXTEND Gram
- GLOBAL: expr stream_expr stream_begin stream_end stream_quot
- parser_case parser_case_list;
- expr: LEVEL "top"
- [ [ "parser"; po = OPT parser_ipatt; pcl = parser_case_list ->
- cparser _loc po pcl
- | "match"; e = sequence; "with"; "parser"; po = OPT parser_ipatt;
- pcl = parser_case_list ->
- cparser_match _loc e po pcl
- ] ]
- ;
- parser_case_list:
- [ [ "["; pcl = LIST0 parser_case SEP "|"; "]" -> pcl
- | pc = parser_case -> [pc]
- ] ]
- ;
- parser_case:
- [ [ stream_begin; sp = stream_patt; stream_end; po = OPT parser_ipatt; "->"; e = expr ->
- (sp, po, e) ] ]
- ;
- stream_begin:
- [ [ "[:" -> () ] ]
- ;
- stream_end:
- [ [ ":]" -> () ] ]
- ;
- stream_quot:
- [ [ "`" -> () ] ]
- ;
- stream_expr:
- [ [ e = expr -> e ] ]
- ;
- stream_patt:
- [ [ spc = stream_patt_comp -> [(spc, None)]
- | spc = stream_patt_comp; ";"; sp = stream_patt_comp_err_list ->
- [(spc, None) :: sp]
- | -> [] ] ]
- ;
- stream_patt_comp_err:
- [ [ spc = stream_patt_comp; eo = OPT [ "??"; e = stream_expr -> e ] ->
- (spc, eo) ] ]
- ;
- stream_patt_comp_err_list:
- [ [ spc = stream_patt_comp_err -> [spc]
- | spc = stream_patt_comp_err; ";" -> [spc]
- | spc = stream_patt_comp_err; ";"; sp = stream_patt_comp_err_list ->
- [spc :: sp] ] ]
- ;
- stream_patt_comp:
- [ [ stream_quot; p = patt; eo = OPT [ "when"; e = stream_expr -> e ] -> SpTrm _loc p eo
- | p = patt; "="; e = stream_expr -> SpNtr _loc p e
- | p = patt -> SpStr _loc p ] ]
- ;
- parser_ipatt:
- [ [ i = a_LIDENT -> <:patt< $lid:i$ >>
- | "_" -> <:patt< _ >>
- ] ]
- ;
- expr: LEVEL "simple"
- [ [ stream_begin; stream_end -> <:expr< $cstream _loc []$ >>
- | stream_begin; sel = stream_expr_comp_list; stream_end ->
- <:expr< $cstream _loc sel$ >> ] ]
- ;
- stream_expr_comp_list:
- [ [ se = stream_expr_comp; ";"; sel = stream_expr_comp_list -> [se :: sel]
- | se = stream_expr_comp; ";" -> [se]
- | se = stream_expr_comp -> [se] ] ]
- ;
- stream_expr_comp:
- [ [ stream_quot; e = stream_expr -> SeTrm _loc e
- | e = stream_expr -> SeNtr _loc e ] ]
- ;
- END;
-
-end;
-
-module M = Register.OCamlSyntaxExtension Id Make;