Re: [Caml-list] camlp4

[Christian Sternagel <christian.sternagel@uibk.ac.at>]

On Tue, Jan 22, 2008 at 07:20:55PM +0100, Nicolas Pouillard wrote:
> Excerpts from christian.sternagel's message of Tue Jan 22 17:43:20 +0100 2008:
> > I tried to implement the optimizations for list comprehensions
> > as stated in the book by simon peyton jones (1987). The problem
> > of using fresh variables I circumvented in an admittedly `ugly' way,
> > however (which is not fool proof since there could be programmers
> > that use variable names like __h__0, __h__1, ...).
> > 
> > The Starting point was the file Camlp4ListComprehension.ml from
> > camlp4.
> > 
> > Any comments are wellcome.
> 
> Nice  start,  however  can you make it more closer to the original code (as in
Yes. Here it is. The `fresh variable' problem, however,
is not really solved. Maybe, using some dedicated namespace
is indeed the easiest solution (hence I did that in my code).

cheers

christisn

@Ertai: sorry for the duplicate... the first time I forgot to
reply to the list.
--------------------------------------------------------------------------
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
 * - Christian Sternagel: optimization of Chapter 7 of
 *   [Simon Peyton Jones, 1987. The Implementation of
 *    Functional Programming Languages]
 *)


module Id = struct
  value name = "Camlp4ListComprenhsion";
  value version = "$Id: Camlp4ListComprehension.ml,v 1.1.2.1 2007/05/27 16:23:35 pouillar Exp $";
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 index = ref 0;
  value var base =
   Format.sprintf
    "__camlp4_list_comprehension__%s__%i"
    base
    (incr index; !index);

  value compr _loc e qs =
   let rec transform _loc e acc =
    fun
    [ [] -> <:expr< [ $e$ :: $acc$ ] >>
    | [`cond b :: qs] ->
     <:expr< if $b$ then $transform _loc e acc qs$ else $acc$ >>
    | [`gen (p, l) :: qs] ->
     let h = var "h" and u = var "u" and us = var "us" in
     <:expr<
      let rec $lid:h$ = fun
      [ [] -> $acc$
      | [ $lid:u$ :: $lid:us$ ] ->
       $if Ast.is_irrefut_patt p then
        <:expr< (fun
         [ $p$ -> $transform _loc e <:expr< ($lid:h$ $lid:us$) >> qs$ ]
        ) $lid:u$
        >>
       else
        <:expr< (fun
         [ $p$ -> $transform _loc e <:expr< ($lid:h$ $lid:us$) >> qs$
         | _ -> $lid:h$ $lid:us$ ]
        ) $lid:us$
        >>
        $
       ]
     in $lid:h$ $l$ 
     >>
    | _ -> <:expr< [] >> ]
   in
   transform _loc e <:expr< [] >> qs;

  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 ();
--------------------------------------------------------------------------
> 
> -- 
> Nicolas Pouillard aka Ertai