C言語風のループ

OCamlの標準のforループは指定回数だけループする機能しかない。ループは再帰で書けということだと思うけど、そういう再帰関数の中には副作用を持つ操作をなるべく含めたくなし、breakするにも書きにくい。
そこで、C言語風のforループを書ける構文拡張を作ってみた。

構文は

for (変数名 = 初期値; 条件式; 次の値) do
  処理
done

となっている。ただし、再帰関数を使ったコードを作るので”次の値”はループ変数を更新するのではなくあくまで次の値なので注意。 また、ループのヘッダのところを省略すると、それぞれ　
for ( () = (); true; () )
と書いたことになる。( for ( ;; ) 　と書くと ";;"がひとつのトークンになるので間にスペースを入れる )

break動作は breakと書く。continueはない（末尾再帰にならなくなるので）けどなくても大丈夫だろう。
また、whileループや for .. (to/dowonto) do .. done のループでもbreakが使えるようにしてある。

例：

#load "pa_cloop.cmo";;
# for (l = [1;2;3]; l <> []; List.tl l) do
    Printf.printf "%d\n" (List.hd l)
  done;;
1
2
3
- : unit = ()
# for (i = 0; i < 3; i + 1) do
    Printf.printf "%d\n" i
  done;;
0
1
2
- : unit = ()
# let i = ref 0;;
val i : int ref = {contents = 0}
# for (; !i < 3; incr i) do
    Printf.printf "%d\n" !i
  done;;
0
1
2
- : unit = ()
# for (i = ref 0; !i < 10; i) do
    if !i mod 2 = 0 then i := !i + 1
    else i := !i + 3;
    Printf.printf "%d\n" !i
  done;;
1
4
5
8
9
12
- : unit = ()
# for (i = 0; ; i + 1) do
    if i = 3 then break
    else ();
    Printf.printf "%d\n" i
  done;;
0
1
2
- : unit = ()
#

ソース

(*pp camlp4o pa_extend.cmo q_MLast.cmo *)

open Pcaml

let gensym =
  let cnt = ref 0 in
  fun var ->
    let x = incr cnt; !cnt in
    var ^ "_thgensymth" ^ string_of_int x

(* 同じ例外を投げると恐ろしいバグになるのでかぶらない文字列にしておく *)
let break_str =  ",1%#'$]1!zvks='9|)o"


let gen_for _loc v iv  wh nx e =
  let loop_fun = gensym "iter" in
  <:expr<
    try
      let rec $lid:loop_fun$ $v$ =
        if $wh$
        then 
          do { $e$; $lid:loop_fun$ $nx$ }
        else ()
      in
        $lid:loop_fun$ $iv$ 
     with
       [Sys_error $str:break_str$ -> ()]
  >>

let gen_while _loc b e  =
  <:expr<
    try 
      while $b$ do { $e$ }
    with
        [Sys_error $str:break_str$ -> ()]
  >>

let gen_native_for _loc v iv df e1 e2 =
  <:expr<
    try
      for $v$ = $iv$ $to:df$ $e1$ do { $e2$ }
    with
        [Sys_error $str:break_str$ -> ()]
  >>

DELETE_RULE
  expr: "while"; SELF; "do"; SELF; "done"
END


EXTEND
 GLOBAL: expr;
  expr: LEVEL "expr1"
    [
      [ "for"; "("; init =  init; ";";
        wh =  cond ; ";";
        nx =  next; ")";
        "do"; e = expr; "done"
         ->
          gen_for 
            _loc 
            (fst init)
            (snd init)
            wh
            nx
            e
      | "while"; b = expr;
        "do"; e = expr; "done"
          -> gen_while _loc b e
      | "for"; v = LIDENT; "="; iv = expr; 
        df = direction_flag; e1 = expr;
        "do"; e2 = expr; "done"
          -> gen_native_for 
              _loc 
              v
              iv
              df
              e1
              e2
      | "break" -> <:expr<ignore(raise (Sys_error $str:break_str$))>>
      ]
    ];

  direction_flag:
    [ [ "to" -> true
      | "downto" -> false
      ]
    ];

  init:
    [ [ v = patt LEVEL "simple"; "="; iv = expr LEVEL "expr1"
          -> (v, iv)
      | -> (<:patt<()>>, <:expr<()>>)

      ] 
    ];

  cond:
    [ [ e = expr LEVEL "expr1" -> e
      | -> <:expr<True>>
      ]
    ];
   
  next:
    [ [ e = expr LEVEL "expr1" -> e
      | -> <:expr<()>>
      ]
    ];
  
END