diff options
Diffstat (limited to 'camlp4/Camlp4Parsers/Camlp4OCamlRevisedParserParser.ml')
| -rw-r--r-- | camlp4/Camlp4Parsers/Camlp4OCamlRevisedParserParser.ml | 394 |
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; |