diff --git a/camlp4/Camlp4Bin.ml b/camlp4/Camlp4Bin.ml index 09895020b..ac893b409 100644 --- a/camlp4/Camlp4Bin.ml +++ b/camlp4/Camlp4Bin.ml @@ -38,6 +38,7 @@ value pa_qb = "Camlp4QuotationCommon"; value pa_q = "Camlp4QuotationExpander"; value pa_rq = "Camlp4OCamlRevisedQuotationExpander"; value pa_oq = "Camlp4OCamlOriginalQuotationExpander"; +value pa_l = "Camlp4ListComprehension"; value dyn_loader = ref (fun []); value rcall_callback = ref (fun () -> ()); @@ -70,8 +71,9 @@ value rewrite_and_load n x = | ("Parsers"|"", "q" | "camlp4quotationexpander.cmo") -> load [pa_r; pa_qb; pa_q] | ("Parsers"|"", "q_MLast.cmo" | "rq" | "camlp4ocamlrevisedquotationexpander.cmo") -> load [pa_r; pa_qb; pa_rq] | ("Parsers"|"", "oq" | "camlp4ocamloriginalquotationexpander.cmo") -> load [pa_r; pa_o; pa_qb; pa_oq] - | ("Parsers"|"", "rf") -> load [pa_r; pa_rp; pa_qb; pa_q; pa_g; pa_m] - | ("Parsers"|"", "of") -> load [pa_r; pa_o; pa_rp; pa_op; pa_qb; pa_rq; pa_g; pa_m] + | ("Parsers"|"", "rf") -> load [pa_r; pa_rp; pa_qb; pa_q; pa_g; pa_l; pa_m] + | ("Parsers"|"", "of") -> load [pa_r; pa_o; pa_rp; pa_op; pa_qb; pa_rq; pa_g; pa_l; pa_m] + | ("Parsers"|"", "comp" | "camlp4listcomprehension.cmo") -> load [pa_l] | ("Filters"|"", "lift" | "camlp4astlifter.cmo") -> load ["Camlp4AstLifter"] | ("Filters"|"", "exn" | "camlp4exceptiontracer.cmo") -> load ["Camlp4ExceptionTracer"] | ("Filters"|"", "prof" | "camlp4profiler.cmo") -> load ["Camlp4Profiler"] diff --git a/camlp4/Camlp4Parsers/Camlp4ListComprehension.ml b/camlp4/Camlp4Parsers/Camlp4ListComprehension.ml new file mode 100644 index 000000000..e74e734fc --- /dev/null +++ b/camlp4/Camlp4Parsers/Camlp4ListComprehension.ml @@ -0,0 +1,148 @@ +open Camlp4; (* -*- camlp4r -*- *) +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2007 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 Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nao Hirokawa: initial version + * - Nicolas Pouillard: revised syntax version + *) + + +module Id = struct + value name = "Camlp4ListComprenhsion"; + value version = "$Id$"; +end; + +module Make (Syntax : Sig.Camlp4Syntax) = struct + open Sig; + include Syntax; + + value rec loop n = + fun + [ [] -> None + | [(x, _)] -> if n = 1 then Some x else None + | [_ :: l] -> loop (n - 1) l ]; + + value stream_peek_nth n strm = loop n (Stream.npeek n strm); + + (* usual trick *) + value test_patt_lessminus = + Gram.Entry.of_parser "test_patt_lessminus" + (fun strm -> + let rec skip_patt n = + match stream_peek_nth n strm with + [ Some (KEYWORD "<-") -> n + | Some (KEYWORD ("[" | "[<")) -> + skip_patt (ignore_upto "]" (n + 1) + 1) + | Some (KEYWORD "(") -> + skip_patt (ignore_upto ")" (n + 1) + 1) + | Some (KEYWORD "{") -> + skip_patt (ignore_upto "}" (n + 1) + 1) + | Some (KEYWORD ("as" | "::" | ";" | "," | "_")) + | Some (LIDENT _ | UIDENT _) -> skip_patt (n + 1) + | Some _ | None -> raise Stream.Failure ] + and ignore_upto end_kwd n = + match stream_peek_nth n strm with + [ Some (KEYWORD prm) when prm = end_kwd -> n + | Some (KEYWORD ("[" | "[<")) -> + ignore_upto end_kwd (ignore_upto "]" (n + 1) + 1) + | Some (KEYWORD "(") -> + ignore_upto end_kwd (ignore_upto ")" (n + 1) + 1) + | Some (KEYWORD "{") -> + ignore_upto end_kwd (ignore_upto "}" (n + 1) + 1) + | Some _ -> ignore_upto end_kwd (n + 1) + | None -> raise Stream.Failure ] + in + skip_patt 1); + + value map _loc p e l = + match (p, e) with + [ (<:patt< $lid:x$ >>, <:expr< $lid:y$ >>) when x = y -> l + | _ -> + if Ast.is_irrefut_patt p then + <:expr< List.map (fun $p$ -> $e$) $l$ >> + else + <:expr< List.fold_right + (fun + [ $pat:p$ when True -> (fun x xs -> [ x :: xs ]) $e$ + | _ -> (fun l -> l) ]) + $l$ [] >> ]; + + value filter _loc p b l = + if Ast.is_irrefut_patt p then + <:expr< List.filter (fun $p$ -> $b$) $l$ >> + else + <:expr< List.filter (fun [ $p$ when True -> $b$ | _ -> False ]) $l$ >>; + + value concat _loc l = <:expr< List.concat $l$ >>; + + value rec compr _loc e = + fun + [ [`gen (p, l)] -> map _loc p e l + | [`gen (p, l); `cond b :: items] -> + compr _loc e [`gen (p, filter _loc p b l) :: items] + | [`gen (p, l) :: ([ `gen (_, _) :: _ ] as is )] -> + concat _loc (map _loc p (compr _loc e is) l) + | _ -> raise Stream.Failure ]; + + DELETE_RULE Gram expr: "["; sem_expr_for_list; "]" END; + + value is_revised = + try do { + DELETE_RULE Gram expr: "["; sem_expr_for_list; "::"; expr; "]" END; + True + } with [ Not_found -> False ]; + + value comprehension_or_sem_expr_for_list = + Gram.Entry.mk "comprehension_or_sem_expr_for_list"; + + EXTEND Gram + GLOBAL: expr comprehension_or_sem_expr_for_list; + + expr: LEVEL "simple" + [ [ "["; e = comprehension_or_sem_expr_for_list; "]" -> e ] ] + ; + + comprehension_or_sem_expr_for_list: + [ [ e = expr LEVEL "top"; ";"; mk = sem_expr_for_list -> + <:expr< [ $e$ :: $mk <:expr< [] >>$ ] >> + | e = expr LEVEL "top"; ";" -> <:expr< [$e$] >> + | e = expr LEVEL "top"; "|"; l = LIST1 item SEP ";" -> compr _loc e l + | e = expr LEVEL "top" -> <:expr< [$e$] >> ] ] + ; + + item: + [ [ test_patt_lessminus; + p = patt; "<-" ; e = expr LEVEL "top" -> `gen (p, e) + | e = expr LEVEL "top" -> `cond e ] ] + ; + + END; + + if is_revised then + EXTEND Gram + GLOBAL: expr comprehension_or_sem_expr_for_list; + + comprehension_or_sem_expr_for_list: + [ [ e = expr LEVEL "top"; ";"; mk = sem_expr_for_list; "::"; last = expr -> + <:expr< [ $e$ :: $mk last$ ] >> + | e = expr LEVEL "top"; "::"; last = expr -> + <:expr< [ $e$ :: $last$ ] >> ] ] + ; + END + else (); + +end; + +let module M = Register.OCamlSyntaxExtension Id Make in (); diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 0d8435f3f..a9e14aa30 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -630,6 +630,7 @@ let pa_oq = pa "Camlp4OCamlOriginalQuotationExpander" let pa_rp = pa "Camlp4OCamlRevisedParserParser" let pa_op = pa "Camlp4OCamlParserParser" let pa_g = pa "Camlp4GrammarParser" +let pa_l = pa "Camlp4ListComprehension" let pa_macro = pa "Camlp4MacroParser" let pa_debug = pa "Camlp4DebugParser" @@ -770,15 +771,15 @@ mk_camlp4 "camlp4boot" ~unix:false mk_camlp4 "camlp4r" [pa_r; pa_rp] [pr_a] [top_rprint];; mk_camlp4 "camlp4rf" - [pa_r; pa_qc; pa_q; pa_rp; pa_g; pa_macro] [pr_a] [top_rprint];; + [pa_r; pa_qc; pa_q; pa_rp; pa_g; pa_macro; pa_l] [pr_a] [top_rprint];; mk_camlp4 "camlp4o" [pa_r; pa_o; pa_rp; pa_op] [pr_a] [];; mk_camlp4 "camlp4of" - [pa_r; pa_qc; pa_q; pa_o; pa_rp; pa_op; pa_g; pa_macro] [pr_a] [];; + [pa_r; pa_qc; pa_q; pa_o; pa_rp; pa_op; pa_g; pa_macro; pa_l] [pr_a] [];; mk_camlp4 "camlp4oof" - [pa_r; pa_o; pa_rp; pa_op; pa_qc; pa_oq; pa_g; pa_macro] [pr_a] [];; + [pa_r; pa_o; pa_rp; pa_op; pa_qc; pa_oq; pa_g; pa_macro; pa_l] [pr_a] [];; mk_camlp4 "camlp4orf" - [pa_r; pa_o; pa_rp; pa_op; pa_qc; pa_rq; pa_g; pa_macro] [pr_a] [];; + [pa_r; pa_o; pa_rp; pa_op; pa_qc; pa_rq; pa_g; pa_macro; pa_l] [pr_a] [];; (* Labltk *)