(* pa_r.cmo pa_rp.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo *)
(* ********************************************************************** *)
(* *)
(* Camlp4 *)
(* *)
(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 2002 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 file *)
(* ../../../LICENSE. *)
(* *)
(* ********************************************************************** *)
(* File generated by pretty print; do not edit! *)
open Pcaml;
open Stdpp;
type choice 'a 'b =
[ Left of 'a
| Right of 'b ]
;
(* Buffer *)
module Buff =
struct
value buff = ref (String.create 80);
value store len x =
do {
if len >= String.length buff.val then
buff.val := buff.val ^ String.create (String.length buff.val)
else ();
buff.val.[len] := x;
succ len
}
;
value get len = String.sub buff.val 0 len;
end
;
(* Lexer *)
value rec skip_to_eol =
parser
[ [: `'\n' | '\r' :] -> ()
| [: `_; s :] -> skip_to_eol s ]
;
value no_ident = ['('; ')'; '['; ']'; '{'; '}'; ' '; '\t'; '\n'; '\r'; ';'];
value rec ident len =
parser
[ [: `'.' :] -> (Buff.get len, True)
| [: `x when not (List.mem x no_ident); s :] -> ident (Buff.store len x) s
| [: :] -> (Buff.get len, False) ]
;
value identifier kwt (s, dot) =
let con =
try do { (Hashtbl.find kwt s : unit); "" } with
[ Not_found ->
match s.[0] with
[ 'A'..'Z' -> if dot then "UIDENTDOT" else "UIDENT"
| _ -> if dot then "LIDENTDOT" else "LIDENT" ] ]
in
(con, s)
;
value rec string len =
parser
[ [: `'"' :] -> Buff.get len
| [: `'\\'; `c; s :] -> string (Buff.store (Buff.store len '\\') c) s
| [: `x; s :] -> string (Buff.store len x) s ]
;
value rec end_exponent_part_under len =
parser
[ [: `('0'..'9' as c); s :] -> end_exponent_part_under (Buff.store len c) s
| [: :] -> ("FLOAT", Buff.get len) ]
;
value end_exponent_part len =
parser
[ [: `('0'..'9' as c); s :] -> end_exponent_part_under (Buff.store len c) s
| [: :] -> raise (Stream.Error "ill-formed floating-point constant") ]
;
value exponent_part len =
parser
[ [: `('+' | '-' as c); s :] -> end_exponent_part (Buff.store len c) s
| [: a = end_exponent_part len :] -> a ]
;
value rec decimal_part len =
parser
[ [: `('0'..'9' as c); s :] -> decimal_part (Buff.store len c) s
| [: `'e' | 'E'; s :] -> exponent_part (Buff.store len 'E') s
| [: :] -> ("FLOAT", Buff.get len) ]
;
value rec number len =
parser
[ [: `('0'..'9' as c); s :] -> number (Buff.store len c) s
| [: `'.'; s :] -> decimal_part (Buff.store len '.') s
| [: `'e' | 'E'; s :] -> exponent_part (Buff.store len 'E') s
| [: :] -> ("INT", Buff.get len) ]
;
value binary = parser [: `('0'..'1' as c) :] -> c;
value octal = parser [: `('0'..'7' as c) :] -> c;
value hexa = parser [: `('0'..'9' | 'a'..'f' | 'A'..'F' as c) :] -> c;
value rec digits_under kind len =
parser
[ [: d = kind; s :] -> digits_under kind (Buff.store len d) s
| [: :] -> Buff.get len ]
;
value digits kind bp len =
parser
[ [: d = kind; s :] -> ("INT", digits_under kind (Buff.store len d) s)
| [: s :] ep ->
raise_with_loc
(Reloc.shift_pos bp Reloc.zero_loc, Reloc.shift_pos ep Reloc.zero_loc)
(Failure "ill-formed integer constant") ]
;
value base_number kwt bp len =
parser
[ [: `'b' | 'B'; s :] -> digits binary bp (Buff.store len 'b') s
| [: `'o' | 'O'; s :] -> digits octal bp (Buff.store len 'o') s
| [: `'x' | 'X'; s :] -> digits hexa bp (Buff.store len 'x') s
| [: id = ident (Buff.store 0 '#') :] -> identifier kwt id ]
;
value rec operator len =
parser
[ [: `'.' :] -> Buff.get (Buff.store len '.')
| [: :] -> Buff.get len ]
;
value char_or_quote_id x =
parser
[ [: `''' :] -> ("CHAR", String.make 1 x)
| [: s :] ep ->
if List.mem x no_ident then
Stdpp.raise_with_loc
(Reloc.shift_pos (ep - 2) Reloc.zero_loc,
Reloc.shift_pos (ep - 1) Reloc.zero_loc)
(Stream.Error "bad quote")
else
let len = Buff.store (Buff.store 0 ''') x in
let (s, dot) = ident len s in
(if dot then "LIDENTDOT" else "LIDENT", s) ]
;
value rec char len =
parser
[ [: `''' :] -> len
| [: `x; s :] -> char (Buff.store len x) s ]
;
value quote =
parser
[ [: `'\\'; len = char (Buff.store 0 '\\') :] -> ("CHAR", Buff.get len)
| [: `x; s :] -> char_or_quote_id x s ]
;
(* The system with LIDENTDOT and UIDENTDOT is not great (it would be *)
(* better to have a token DOT (actually SPACEDOT and DOT)) but it is *)
(* the only way (that I have found) to have a good behaviour in the *)
(* toplevel (not expecting tokens after a phrase). Drawbacks: 1/ to be *)
(* complete, we should have STRINGDOT, RIGHTPARENDOT, and so on 2/ the *)
(* parser rule with dot is right associative and we have to reverse *)
(* the resulting tree (using the function leftify). *)
(* This is a complicated issue: the behaviour of the OCaml toplevel *)
(* is strange, anyway. For example, even without Camlp4, The OCaml *)
(* toplevel accepts that: *)
(* # let x = 32;; foo bar match let ) *)
value rec lexer kwt = parser [: t = lexer0 kwt; _ = no_dot :] -> t
and no_dot =
parser
[ [: `'.' :] ep ->
Stdpp.raise_with_loc
(Reloc.shift_pos (ep - 1) Reloc.zero_loc,
Reloc.shift_pos ep Reloc.zero_loc)
(Stream.Error "bad dot")
| [: :] -> () ]
and lexer0 kwt =
parser bp
[ [: `'\t' | '\n' | '\r'; s :] -> lexer0 kwt s
| [: `' '; s :] -> after_space kwt s
| [: `';'; _ = skip_to_eol; s :] -> lexer kwt s
| [: `'(' :] -> (("", "("), (bp, bp + 1))
| [: `')'; s :] ep -> (("", rparen s), (bp, ep))
| [: `'[' :] -> (("", "["), (bp, bp + 1))
| [: `']' :] -> (("", "]"), (bp, bp + 1))
| [: `'{' :] -> (("", "{"), (bp, bp + 1))
| [: `'}' :] -> (("", "}"), (bp, bp + 1))
| [: `'"'; s = string 0 :] ep -> (("STRING", s), (bp, ep))
| [: `'''; tok = quote :] ep -> (tok, (bp, ep))
| [: `'<'; tok = less kwt :] ep -> (tok, (bp, ep))
| [: `'-'; tok = minus kwt :] ep -> (tok, (bp, ep))
| [: `'~'; tok = tilde :] ep -> (tok, (bp, ep))
| [: `'?'; tok = question :] ep -> (tok, (bp, ep))
| [: `'#'; tok = base_number kwt bp (Buff.store 0 '0') :] ep ->
(tok, (bp, ep))
| [: `('0'..'9' as c); tok = number (Buff.store 0 c) :] ep ->
(tok, (bp, ep))
| [: `('+' | '*' | '/' as c); id = operator (Buff.store 0 c) :] ep ->
(identifier kwt (id, False), (bp, ep))
| [: `x; id = ident (Buff.store 0 x) :] ep -> (identifier kwt id, (bp, ep))
| [: :] -> (("EOI", ""), (bp, bp + 1)) ]
and rparen =
parser
[ [: `'.' :] -> ")."
| [: ___ :] -> ")" ]
and after_space kwt =
parser
[ [: `'.' :] ep -> (("", "."), (ep - 1, ep))
| [: x = lexer0 kwt :] -> x ]
and tilde =
parser
[ [: `('a'..'z' as c); (s, dot) = ident (Buff.store 0 c) :] ->
("TILDEIDENT", s)
| [: :] -> ("LIDENT", "~") ]
and question =
parser
[ [: `('a'..'z' as c); (s, dot) = ident (Buff.store 0 c) :] ->
("QUESTIONIDENT", s)
| [: :] -> ("LIDENT", "?") ]
and minus kwt =
parser
[ [: `'.' :] -> identifier kwt ("-.", False)
| [: `('0'..'9' as c); n = number (Buff.store (Buff.store 0 '-') c) :] ->
n
| [: id = ident (Buff.store 0 '-') :] -> identifier kwt id ]
and less kwt =
parser
[ [: `':'; lab = label 0; `'<' ? "'<' expected"; q = quotation 0 :] ->
("QUOT", lab ^ ":" ^ q)
| [: id = ident (Buff.store 0 '<') :] -> identifier kwt id ]
and label len =
parser
[ [: `('a'..'z' | 'A'..'Z' | '_' as c); s :] -> label (Buff.store len c) s
| [: :] -> Buff.get len ]
and quotation len =
parser
[ [: `'>'; s :] -> quotation_greater len s
| [: `x; s :] -> quotation (Buff.store len x) s
| [: :] -> failwith "quotation not terminated" ]
and quotation_greater len =
parser
[ [: `'>' :] -> Buff.get len
| [: a = quotation (Buff.store len '>') :] -> a ]
;
value lexer_using kwt (con, prm) =
match con with
[ "CHAR" | "EOI" | "INT" | "FLOAT" | "LIDENT" | "LIDENTDOT" |
"QUESTIONIDENT" | "QUOT" | "STRING" | "TILDEIDENT" | "UIDENT" |
"UIDENTDOT" ->
()
| "ANTIQUOT" -> ()
| "" ->
try Hashtbl.find kwt prm with [ Not_found -> Hashtbl.add kwt prm () ]
| _ ->
raise
(Token.Error
("the constructor \"" ^ con ^ "\" is not recognized by Plexer")) ]
;
value lexer_text (con, prm) =
if con = "" then "'" ^ prm ^ "'"
else if prm = "" then con
else con ^ " \"" ^ prm ^ "\""
;
value lexer_gmake () =
let kwt = Hashtbl.create 89 in
{Token.tok_func =
Token.lexer_func_of_parser
(fun s ->
let (r, (bp, ep)) = lexer kwt s in
(r,
(Reloc.shift_pos bp Reloc.zero_loc,
Reloc.shift_pos ep Reloc.zero_loc)));
Token.tok_using = lexer_using kwt; Token.tok_removing = fun [];
Token.tok_match = Token.default_match; Token.tok_text = lexer_text;
Token.tok_comm = None}
;
(* Building AST *)
type sexpr =
[ Sacc of Loc.t and sexpr and sexpr
| Schar of Loc.t and string
| Sexpr of Loc.t and list sexpr
| Sint of Loc.t and string
| Sfloat of Loc.t and string
| Slid of Loc.t and string
| Slist of Loc.t and list sexpr
| Sqid of Loc.t and string
| Squot of Loc.t and string and string
| Srec of Loc.t and list sexpr
| Sstring of Loc.t and string
| Stid of Loc.t and string
| Suid of Loc.t and string ]
;
value loc_of_sexpr =
fun [
Sacc loc _ _ | Schar loc _ | Sexpr loc _ | Sint loc _ | Sfloat loc _ |
Slid loc _ | Slist loc _ | Sqid loc _ | Squot loc _ _ | Srec loc _ |
Sstring loc _ | Stid loc _ | Suid loc _ ->
loc ]
;
value error_loc loc err =
raise_with_loc loc (Stream.Error (err ^ " expected"))
;
value error se err = error_loc (loc_of_sexpr se) err;
value strm_n = "__strm";
value peek_fun loc = <:expr< Stream.peek >>;
value junk_fun loc = <:expr< Stream.junk >>;
value assoc_left_parsed_op_list =
["+"; "*"; "+."; "*."; "land"; "lor"; "lxor"]
;
value assoc_right_parsed_op_list = ["and"; "or"; "^"; "@"];
value and_by_couple_op_list = ["="; "<>"; "<"; ">"; "<="; ">="; "=="; "!="];
value op_apply loc e1 e2 =
fun
[ "and" -> <:expr< $e1$ && $e2$ >>
| "or" -> <:expr< $e1$ || $e2$ >>
| x -> <:expr< $lid:x$ $e1$ $e2$ >> ]
;
value string_se =
fun
[ Sstring loc s -> s
| se -> error se "string" ]
;
value mod_ident_se =
fun
[ Suid _ s -> [Pcaml.rename_id.val s]
| Slid _ s -> [Pcaml.rename_id.val s]
| se -> error se "mod_ident" ]
;
value lident_expr loc s =
if String.length s > 1 && s.[0] = '`' then
let s = String.sub s 1 (String.length s - 1) in
<:expr< ` $s$ >>
else <:expr< $lid:(Pcaml.rename_id.val s)$ >>
;
value rec module_expr_se =
fun
[ Sexpr loc [Slid _ "functor"; Suid _ s; se1; se2] ->
let s = Pcaml.rename_id.val s in
let mt = module_type_se se1 in
let me = module_expr_se se2 in
<:module_expr< functor ($s$ : $mt$) -> $me$ >>
| Sexpr loc [Slid _ "struct" :: sl] ->
let mel = List.map str_item_se sl in
<:module_expr< struct $list:mel$ end >>
| Sexpr loc [se1; se2] ->
let me1 = module_expr_se se1 in
let me2 = module_expr_se se2 in
<:module_expr< $me1$ $me2$ >>
| Suid loc s -> <:module_expr< $uid:(Pcaml.rename_id.val s)$ >>
| se -> error se "module expr" ]
and module_type_se =
fun
[ Sexpr loc [Slid _ "functor"; Suid _ s; se1; se2] ->
let s = Pcaml.rename_id.val s in
let mt1 = module_type_se se1 in
let mt2 = module_type_se se2 in
<:module_type< functor ($s$ : $mt1$) -> $mt2$ >>
| Sexpr loc [Slid _ "sig" :: sel] ->
let sil = List.map sig_item_se sel in
<:module_type< sig $list:sil$ end >>
| Sexpr loc [Slid _ "with"; se; Sexpr _ sel] ->
let mt = module_type_se se in
let wcl = List.map with_constr_se sel in
<:module_type< $mt$ with $list:wcl$ >>
| Suid loc s -> <:module_type< $uid:(Pcaml.rename_id.val s)$ >>
| se -> error se "module type" ]
and with_constr_se =
fun
[ Sexpr loc [Slid _ "type"; se1; se2] ->
let tn = mod_ident_se se1 in
let te = ctyp_se se2 in
MLast.WcTyp loc tn [] te
| se -> error se "with constr" ]
and sig_item_se =
fun
[ Sexpr loc [Slid _ "type" :: sel] ->
let tdl = type_declaration_list_se sel in
<:sig_item< type $list:tdl$ >>
| Sexpr loc [Slid _ "exception"; Suid _ c :: sel] ->
let c = Pcaml.rename_id.val c in
let tl = List.map ctyp_se sel in
<:sig_item< exception $c$ of $list:tl$ >>
| Sexpr loc [Slid _ "value"; Slid _ s; se] ->
let s = Pcaml.rename_id.val s in
let t = ctyp_se se in
<:sig_item< value $s$ : $t$ >>
| Sexpr loc [Slid _ "external"; Slid _ i; se :: sel] ->
let i = Pcaml.rename_id.val i in
let pd = List.map string_se sel in
let t = ctyp_se se in
<:sig_item< external $i$ : $t$ = $list:pd$ >>
| Sexpr loc [Slid _ "module"; Suid _ s; se] ->
let s = Pcaml.rename_id.val s in
let mb = module_type_se se in
<:sig_item< module $s$ : $mb$ >>
| Sexpr loc [Slid _ "moduletype"; Suid _ s; se] ->
let s = Pcaml.rename_id.val s in
let mt = module_type_se se in
<:sig_item< module type $s$ = $mt$ >>
| se -> error se "sig item" ]
and str_item_se se =
match se with
[ Sexpr loc [Slid _ "open"; se] ->
let s = mod_ident_se se in
<:str_item< open $s$ >>
| Sexpr loc [Slid _ "type" :: sel] ->
let tdl = type_declaration_list_se sel in
<:str_item< type $list:tdl$ >>
| Sexpr loc [Slid _ "exception"; Suid _ c :: sel] ->
let c = Pcaml.rename_id.val c in
let tl = List.map ctyp_se sel in
<:str_item< exception $c$ of $list:tl$ >>
| Sexpr loc [Slid _ ("define" | "definerec" as r); se :: sel] ->
let r = r = "definerec" in
let (p, e) = fun_binding_se se (begin_se loc sel) in
<:str_item< value $opt:r$ $p$ = $e$ >>
| Sexpr loc [Slid _ ("define*" | "definerec*" as r) :: sel] ->
let r = r = "definerec*" in
let lbs = List.map let_binding_se sel in
<:str_item< value $opt:r$ $list:lbs$ >>
| Sexpr loc [Slid _ "external"; Slid _ i; se :: sel] ->
let i = Pcaml.rename_id.val i in
let pd = List.map string_se sel in
let t = ctyp_se se in
<:str_item< external $i$ : $t$ = $list:pd$ >>
| Sexpr loc [Slid _ "module"; Suid _ i; se] ->
let i = Pcaml.rename_id.val i in
let mb = module_binding_se se in
<:str_item< module $i$ = $mb$ >>
| Sexpr loc [Slid _ "moduletype"; Suid _ s; se] ->
let s = Pcaml.rename_id.val s in
let mt = module_type_se se in
<:str_item< module type $s$ = $mt$ >>
| _ ->
let loc = loc_of_sexpr se in
let e = expr_se se in
<:str_item< $exp:e$ >> ]
and module_binding_se se = module_expr_se se
and expr_se =
fun
[ Sacc loc se1 se2 ->
let e1 = expr_se se1 in
match se2 with
[ Slist loc [se2] ->
let e2 = expr_se se2 in
<:expr< $e1$ .[ $e2$ ] >>
| Sexpr loc [se2] ->
let e2 = expr_se se2 in
<:expr< $e1$ .( $e2$ ) >>
| _ ->
let e2 = expr_se se2 in
<:expr< $e1$ . $e2$ >> ]
| Slid loc s -> lident_expr loc s
| Suid loc s -> <:expr< $uid:(Pcaml.rename_id.val s)$ >>
| Sint loc s -> <:expr< $int:s$ >>
| Sfloat loc s -> <:expr< $flo:s$ >>
| Schar loc s -> <:expr< $chr:s$ >>
| Sstring loc s -> <:expr< $str:s$ >>
| Stid loc s -> <:expr< ~ $(Pcaml.rename_id.val s)$ >>
| Sqid loc s -> <:expr< ? $(Pcaml.rename_id.val s)$ >>
| Sexpr loc [] -> <:expr< () >>
| Sexpr loc [Slid _ s; e1 :: ([_ :: _] as sel)]
when List.mem s assoc_left_parsed_op_list ->
let rec loop e1 =
fun
[ [] -> e1
| [e2 :: el] -> loop (op_apply loc e1 e2 s) el ]
in
loop (expr_se e1) (List.map expr_se sel)
| Sexpr loc [Slid _ s :: ([_; _ :: _] as sel)]
when List.mem s assoc_right_parsed_op_list ->
let rec loop =
fun
[ [] -> assert False
| [e1] -> e1
| [e1 :: el] ->
let e2 = loop el in
op_apply loc e1 e2 s ]
in
loop (List.map expr_se sel)
| Sexpr loc [Slid _ s :: ([_; _ :: _] as sel)]
when List.mem s and_by_couple_op_list ->
let rec loop =
fun
[ [] | [_] -> assert False
| [e1; e2] -> <:expr< $lid:s$ $e1$ $e2$ >>
| [e1 :: ([e2; _ :: _] as el)] ->
let a1 = op_apply loc e1 e2 s in
let a2 = loop el in
<:expr< $a1$ && $a2$ >> ]
in
loop (List.map expr_se sel)
| Sexpr loc [Stid _ s; se] ->
let e = expr_se se in
<:expr< ~ $s$ : $e$ >>
| Sexpr loc [Slid _ "-"; se] ->
let e = expr_se se in
<:expr< - $e$ >>
| Sexpr loc [Slid _ "if"; se; se1] ->
let e = expr_se se in
let e1 = expr_se se1 in
<:expr< if $e$ then $e1$ else () >>
| Sexpr loc [Slid _ "if"; se; se1; se2] ->
let e = expr_se se in
let e1 = expr_se se1 in
let e2 = expr_se se2 in
<:expr< if $e$ then $e1$ else $e2$ >>
| Sexpr loc [Slid _ "cond" :: sel] ->
let rec loop =
fun
[ [Sexpr loc [Slid _ "else" :: sel]] -> begin_se loc sel
| [Sexpr loc [se1 :: sel1] :: sel] ->
let e1 = expr_se se1 in
let e2 = begin_se loc sel1 in
let e3 = loop sel in
<:expr< if $e1$ then $e2$ else $e3$ >>
| [] -> <:expr< () >>
| [se :: _] -> error se "cond clause" ]
in
loop sel
| Sexpr loc [Slid _ "while"; se :: sel] ->
let e = expr_se se in
let el = List.map expr_se sel in
<:expr< while $e$ do { $list:el$ } >>
| Sexpr loc [Slid _ "for"; Slid _ i; se1; se2 :: sel] ->
let i = Pcaml.rename_id.val i in
let e1 = expr_se se1 in
let e2 = expr_se se2 in
let el = List.map expr_se sel in
<:expr< for $i$ = $e1$ to $e2$ do { $list:el$ } >>
| Sexpr loc [Slid loc1 "lambda"] -> <:expr< fun [] >>
| Sexpr loc [Slid loc1 "lambda"; sep :: sel] ->
let e = begin_se loc1 sel in
match ipatt_opt_se sep with
[ Left p -> <:expr< fun $p$ -> $e$ >>
| Right (se, sel) ->
List.fold_right
(fun se e ->
let p = ipatt_se se in
<:expr< fun $p$ -> $e$ >>)
[se :: sel] e ]
| Sexpr loc [Slid _ "lambda_match" :: sel] ->
let pel = List.map (match_case loc) sel in
<:expr< fun [ $list:pel$ ] >>
| Sexpr loc [Slid _ ("let" | "letrec" as r) :: sel] ->
match sel with
[ [Sexpr _ sel1 :: sel2] ->
let r = r = "letrec" in
let lbs = List.map let_binding_se sel1 in
let e = begin_se loc sel2 in
<:expr< let $opt:r$ $list:lbs$ in $e$ >>
| [Slid _ n; Sexpr _ sl :: sel] ->
let n = Pcaml.rename_id.val n in
let (pl, el) =
List.fold_right
(fun se (pl, el) ->
match se with
[ Sexpr _ [se1; se2] ->
([patt_se se1 :: pl], [expr_se se2 :: el])
| se -> error se "named let" ])
sl ([], [])
in
let e1 =
List.fold_right (fun p e -> <:expr< fun $p$ -> $e$ >>) pl
(begin_se loc sel)
in
let e2 =
List.fold_left (fun e1 e2 -> <:expr< $e1$ $e2$ >>)
<:expr< $lid:n$ >> el
in
<:expr< let rec $lid:n$ = $e1$ in $e2$ >>
| [se :: _] -> error se "let_binding"
| _ -> error_loc loc "let_binding" ]
| Sexpr loc [Slid _ "let*" :: sel] ->
match sel with
[ [Sexpr _ sel1 :: sel2] ->
List.fold_right
(fun se ek ->
let (p, e) = let_binding_se se in
<:expr< let $p$ = $e$ in $ek$ >>)
sel1 (begin_se loc sel2)
| [se :: _] -> error se "let_binding"
| _ -> error_loc loc "let_binding" ]
| Sexpr loc [Slid _ "match"; se :: sel] ->
let e = expr_se se in
let pel = List.map (match_case loc) sel in
<:expr< match $e$ with [ $list:pel$ ] >>
| Sexpr loc [Slid _ "parser" :: sel] ->
let e =
match sel with
[ [(Slid _ _ as se) :: sel] ->
let p = patt_se se in
let pc = parser_cases_se loc sel in
<:expr< let $p$ = Stream.count $lid:strm_n$ in $pc$ >>
| _ -> parser_cases_se loc sel ]
in
<:expr< fun ($lid:strm_n$ : Stream.t _) -> $e$ >>
| Sexpr loc [Slid _ "match_with_parser"; se :: sel] ->
let me = expr_se se in
let (bpo, sel) =
match sel with
[ [(Slid _ _ as se) :: sel] -> (Some (patt_se se), sel)
| _ -> (None, sel) ]
in
let pc = parser_cases_se loc sel in
let e =
match bpo with
[ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >>
| None -> pc ]
in
match me with
[ <:expr< $lid:x$ >> when x = strm_n -> e
| _ -> <:expr< let ($lid:strm_n$ : Stream.t _) = $me$ in $e$ >> ]
| Sexpr loc [Slid _ "try"; se :: sel] ->
let e = expr_se se in
let pel = List.map (match_case loc) sel in
<:expr< try $e$ with [ $list:pel$ ] >>
| Sexpr loc [Slid _ "begin" :: sel] ->
let el = List.map expr_se sel in
<:expr< do { $list:el$ } >>
| Sexpr loc [Slid _ ":="; se1; se2] ->
let e1 = expr_se se1 in
let e2 = expr_se se2 in
<:expr< $e1$ := $e2$ >>
| Sexpr loc [Slid _ "values" :: sel] ->
let el = List.map expr_se sel in
<:expr< ( $list:el$ ) >>
| Srec loc [Slid _ "with"; se :: sel] ->
let e = expr_se se in
let lel = List.map (label_expr_se loc) sel in
<:expr< { ($e$) with $list:lel$ } >>
| Srec loc sel ->
let lel = List.map (label_expr_se loc) sel in
<:expr< { $list:lel$ } >>
| Sexpr loc [Slid _ ":"; se1; se2] ->
let e = expr_se se1 in
let t = ctyp_se se2 in
<:expr< ( $e$ : $t$ ) >>
| Sexpr loc [se] ->
let e = expr_se se in
<:expr< $e$ () >>
| Sexpr loc [Slid _ "assert"; Suid _ "False"] -> <:expr< assert False >>
| Sexpr loc [Slid _ "assert"; se] ->
let e = expr_se se in
<:expr< assert $e$ >>
| Sexpr loc [Slid _ "lazy"; se] ->
let e = expr_se se in
<:expr< lazy $e$ >>
| Sexpr loc [se :: sel] ->
List.fold_left
(fun e se ->
let e1 = expr_se se in
<:expr< $e$ $e1$ >>)
(expr_se se) sel
| Slist loc sel ->
let rec loop =
fun
[ [] -> <:expr< [] >>
| [se1; Slid _ "."; se2] ->
let e = expr_se se1 in
let el = expr_se se2 in
<:expr< [$e$ :: $el$] >>
| [se :: sel] ->
let e = expr_se se in
let el = loop sel in
<:expr< [$e$ :: $el$] >> ]
in
loop sel
| Squot loc typ txt -> Pcaml.handle_expr_quotation loc (typ, txt) ]
and begin_se loc =
fun
[ [] -> <:expr< () >>
| [se] -> expr_se se
| sel ->
let el = List.map expr_se sel in
let loc = (fst (loc_of_sexpr (List.hd sel)), snd loc) in
<:expr< do { $list:el$ } >> ]
and let_binding_se =
fun
[ Sexpr loc [se :: sel] ->
let e = begin_se loc sel in
match ipatt_opt_se se with
[ Left p -> (p, e)
| Right _ -> fun_binding_se se e ]
| se -> error se "let_binding" ]
and fun_binding_se se e =
match se with
[ Sexpr _ [Slid _ "values" :: _] -> (ipatt_se se, e)
| Sexpr _ [Slid loc s :: sel] ->
let s = Pcaml.rename_id.val s in
let e =
List.fold_right
(fun se e ->
let loc = (fst (loc_of_sexpr se), snd (MLast.loc_of_expr e)) in
let p = ipatt_se se in
<:expr< fun $p$ -> $e$ >>)
sel e
in
let p = <:patt< $lid:s$ >> in
(p, e)
| _ -> (ipatt_se se, e) ]
and match_case loc =
fun
[ Sexpr loc [Sexpr _ [Slid _ "when"; se; sew] :: sel] ->
(patt_se se, Some (expr_se sew), begin_se loc sel)
| Sexpr loc [se :: sel] -> (patt_se se, None, begin_se loc sel)
| se -> error se "match_case" ]
and label_expr_se loc =
fun
[ Sexpr _ [se1; se2] -> (patt_se se1, expr_se se2)
| se -> error se "label_expr" ]
and label_patt_se loc =
fun
[ Sexpr _ [se1; se2] -> (patt_se se1, patt_se se2)
| se -> error se "label_patt" ]
and parser_cases_se loc =
fun
[ [] -> <:expr< raise Stream.Failure >>
| [Sexpr loc [Sexpr _ spsel :: act] :: sel] ->
let ekont _ = parser_cases_se loc sel in
let act =
match act with
[ [se] -> expr_se se
| [sep; se] ->
let p = patt_se sep in
let e = expr_se se in
<:expr< let $p$ = Stream.count $lid:strm_n$ in $e$ >>
| _ -> error_loc loc "parser_case" ]
in
stream_pattern_se loc act ekont spsel
| [se :: _] -> error se "parser_case" ]
and stream_pattern_se loc act ekont =
fun
[ [] -> act
| [se :: sel] ->
let ckont err = <:expr< raise (Stream.Error $err$) >> in
let skont = stream_pattern_se loc act ckont sel in
stream_pattern_component skont ekont <:expr< "" >> se ]
and stream_pattern_component skont ekont err =
fun
[ Sexpr loc [Slid _ "`"; se :: wol] ->
let wo =
match wol with
[ [se] -> Some (expr_se se)
| [] -> None
| _ -> error_loc loc "stream_pattern_component" ]
in
let e = peek_fun loc in
let p = patt_se se in
let j = junk_fun loc in
let k = ekont err in
<:expr< match $e$ $lid:strm_n$ with
[ Some $p$ $when:wo$ -> do { $j$ $lid:strm_n$ ; $skont$ }
| _ -> $k$ ] >>
| Sexpr loc [se1; se2] ->
let p = patt_se se1 in
let e =
let e = expr_se se2 in
<:expr< try Some ($e$ $lid:strm_n$) with [ Stream.Failure -> None ] >>
in
let k = ekont err in
<:expr< match $e$ with [ Some $p$ -> $skont$ | _ -> $k$ ] >>
| Sexpr loc [Slid _ "?"; se1; se2] ->
stream_pattern_component skont ekont (expr_se se2) se1
| Slid loc s ->
let s = Pcaml.rename_id.val s in
<:expr< let $lid:s$ = $lid:strm_n$ in $skont$ >>
| se -> error se "stream_pattern_component" ]
and patt_se =
fun
[ Sacc loc se1 se2 ->
let p1 = patt_se se1 in
let p2 = patt_se se2 in
<:patt< $p1$ . $p2$ >>
| Slid loc "_" -> <:patt< _ >>
| Slid loc s -> <:patt< $lid:(Pcaml.rename_id.val s)$ >>
| Suid loc s -> <:patt< $uid:(Pcaml.rename_id.val s)$ >>
| Sint loc s -> <:patt< $int:s$ >>
| Sfloat loc s -> <:patt< $flo:s$ >>
| Schar loc s -> <:patt< $chr:s$ >>
| Sstring loc s -> <:patt< $str:s$ >>
| Stid loc _ -> error_loc loc "patt"
| Sqid loc _ -> error_loc loc "patt"
| Srec loc sel ->
let lpl = List.map (label_patt_se loc) sel in
<:patt< { $list:lpl$ } >>
| Sexpr loc [Slid _ ":"; se1; se2] ->
let p = patt_se se1 in
let t = ctyp_se se2 in
<:patt< ($p$ : $t$) >>
| Sexpr loc [Slid _ "or"; se :: sel] ->
List.fold_left
(fun p se ->
let p1 = patt_se se in
<:patt< $p$ | $p1$ >>)
(patt_se se) sel
| Sexpr loc [Slid _ "range"; se1; se2] ->
let p1 = patt_se se1 in
let p2 = patt_se se2 in
<:patt< $p1$ .. $p2$ >>
| Sexpr loc [Slid _ "values" :: sel] ->
let pl = List.map patt_se sel in
<:patt< ( $list:pl$ ) >>
| Sexpr loc [Slid _ "as"; se1; se2] ->
let p1 = patt_se se1 in
let p2 = patt_se se2 in
<:patt< ($p1$ as $p2$) >>
| Sexpr loc [se :: sel] ->
List.fold_left
(fun p se ->
let p1 = patt_se se in
<:patt< $p$ $p1$ >>)
(patt_se se) sel
| Sexpr loc [] -> <:patt< () >>
| Slist loc sel ->
let rec loop =
fun
[ [] -> <:patt< [] >>
| [se1; Slid _ "."; se2] ->
let p = patt_se se1 in
let pl = patt_se se2 in
<:patt< [$p$ :: $pl$] >>
| [se :: sel] ->
let p = patt_se se in
let pl = loop sel in
<:patt< [$p$ :: $pl$] >> ]
in
loop sel
| Squot loc typ txt -> Pcaml.handle_patt_quotation loc (typ, txt) ]
and ipatt_se se =
match ipatt_opt_se se with
[ Left p -> p
| Right (se, _) -> error se "ipatt" ]
and ipatt_opt_se =
fun
[ Slid loc "_" -> Left <:patt< _ >>
| Slid loc s -> Left <:patt< $lid:(Pcaml.rename_id.val s)$ >>
| Stid loc s -> Left <:patt< ~ $(Pcaml.rename_id.val s)$ >>
| Sqid loc s -> Left <:patt< ? $(Pcaml.rename_id.val s)$ >>
| Sexpr loc [Sqid _ s; se] ->
let s = Pcaml.rename_id.val s in
let e = expr_se se in
Left <:patt< ? ( $lid:s$ = $e$ ) >>
| Sexpr loc [Slid _ ":"; se1; se2] ->
let p = ipatt_se se1 in
let t = ctyp_se se2 in
Left <:patt< ($p$ : $t$) >>
| Sexpr loc [Slid _ "values" :: sel] ->
let pl = List.map ipatt_se sel in
Left <:patt< ( $list:pl$ ) >>
| Sexpr loc [] -> Left <:patt< () >>
| Sexpr loc [se :: sel] -> Right (se, sel)
| se -> error se "ipatt" ]
and type_declaration_list_se =
fun
[ [se1; se2 :: sel] ->
let (n1, loc1, tpl) =
match se1 with
[ Sexpr _ [Slid loc n :: sel] ->
(n, loc, List.map type_parameter_se sel)
| Slid loc n -> (n, loc, [])
| se -> error se "type declaration" ]
in
[((loc1, Pcaml.rename_id.val n1), tpl, ctyp_se se2, []) ::
type_declaration_list_se sel]
| [] -> []
| [se :: _] -> error se "type_declaration" ]
and type_parameter_se =
fun
[ Slid _ s when String.length s >= 2 && s.[0] = ''' ->
(String.sub s 1 (String.length s - 1), (False, False))
| se -> error se "type_parameter" ]
and ctyp_se =
fun
[ Sexpr loc [Slid _ "sum" :: sel] ->
let cdl = List.map constructor_declaration_se sel in
<:ctyp< [ $list:cdl$ ] >>
| Srec loc sel ->
let ldl = List.map label_declaration_se sel in
<:ctyp< { $list:ldl$ } >>
| Sexpr loc [Slid _ "->" :: ([_; _ :: _] as sel)] ->
let rec loop =
fun
[ [] -> assert False
| [se] -> ctyp_se se
| [se :: sel] ->
let t1 = ctyp_se se in
let loc = (fst (loc_of_sexpr se), snd loc) in
let t2 = loop sel in
<:ctyp< $t1$ -> $t2$ >> ]
in
loop sel
| Sexpr loc [Slid _ "*" :: sel] ->
let tl = List.map ctyp_se sel in
<:ctyp< ($list:tl$) >>
| Sexpr loc [se :: sel] ->
List.fold_left
(fun t se ->
let t2 = ctyp_se se in
<:ctyp< $t$ $t2$ >>)
(ctyp_se se) sel
| Sacc loc se1 se2 ->
let t1 = ctyp_se se1 in
let t2 = ctyp_se se2 in
<:ctyp< $t1$ . $t2$ >>
| Slid loc "_" -> <:ctyp< _ >>
| Slid loc s ->
if s.[0] = ''' then
let s = String.sub s 1 (String.length s - 1) in
<:ctyp< '$s$ >>
else <:ctyp< $lid:(Pcaml.rename_id.val s)$ >>
| Suid loc s -> <:ctyp< $uid:(Pcaml.rename_id.val s)$ >>
| se -> error se "ctyp" ]
and constructor_declaration_se =
fun
[ Sexpr loc [Suid _ ci :: sel] ->
(loc, Pcaml.rename_id.val ci, List.map ctyp_se sel)
| se -> error se "constructor_declaration" ]
and label_declaration_se =
fun
[ Sexpr loc [Slid _ lab; Slid _ "mutable"; se] ->
(loc, Pcaml.rename_id.val lab, True, ctyp_se se)
| Sexpr loc [Slid _ lab; se] ->
(loc, Pcaml.rename_id.val lab, False, ctyp_se se)
| se -> error se "label_declaration" ]
;
value directive_se =
fun
[ Sexpr _ [Slid _ s] -> (s, None)
| Sexpr _ [Slid _ s; se] ->
let e = expr_se se in
(s, Some e)
| se -> error se "directive" ]
;
(* Parser *)
Pcaml.syntax_name.val := "Scheme";
Pcaml.no_constructors_arity.val := False;
do {
Grammar.Unsafe.gram_reinit gram (lexer_gmake ());
Grammar.Unsafe.clear_entry interf;
Grammar.Unsafe.clear_entry implem;
Grammar.Unsafe.clear_entry top_phrase;
Grammar.Unsafe.clear_entry use_file;
Grammar.Unsafe.clear_entry module_type;
Grammar.Unsafe.clear_entry module_expr;
Grammar.Unsafe.clear_entry sig_item;
Grammar.Unsafe.clear_entry str_item;
Grammar.Unsafe.clear_entry expr;
Grammar.Unsafe.clear_entry patt;
Grammar.Unsafe.clear_entry ctyp;
Grammar.Unsafe.clear_entry let_binding;
Grammar.Unsafe.clear_entry type_declaration;
Grammar.Unsafe.clear_entry class_type;
Grammar.Unsafe.clear_entry class_expr;
Grammar.Unsafe.clear_entry class_sig_item;
Grammar.Unsafe.clear_entry class_str_item
};
Pcaml.parse_interf.val := Grammar.Entry.parse interf;
Pcaml.parse_implem.val := Grammar.Entry.parse implem;
value sexpr = Grammar.Entry.create gram "sexpr";
value rec leftify =
fun
[ Sacc loc1 se1 se2 ->
match leftify se2 with
[ Sacc loc2 se2 se3 -> Sacc loc1 (Sacc loc2 se1 se2) se3
| se2 -> Sacc loc1 se1 se2 ]
| x -> x ]
;
EXTEND
GLOBAL: implem interf top_phrase use_file str_item sig_item expr patt sexpr;
implem:
[ [ "#"; se = sexpr ->
let (n, dp) = directive_se se in
([(<:str_item< # $n$ $opt:dp$ >>, loc)], True)
| si = str_item; x = SELF ->
let (sil, stopped) = x in
let loc = MLast.loc_of_str_item si in
([(si, loc) :: sil], stopped)
| EOI -> ([], False) ] ]
;
interf:
[ [ "#"; se = sexpr ->
let (n, dp) = directive_se se in
([(<:sig_item< # $n$ $opt:dp$ >>, loc)], True)
| si = sig_item; x = SELF ->
let (sil, stopped) = x in
let loc = MLast.loc_of_sig_item si in
([(si, loc) :: sil], stopped)
| EOI -> ([], False) ] ]
;
top_phrase:
[ [ "#"; se = sexpr ->
let (n, dp) = directive_se se in
Some <:str_item< # $n$ $opt:dp$ >>
| se = sexpr -> Some (str_item_se se)
| EOI -> None ] ]
;
use_file:
[ [ "#"; se = sexpr ->
let (n, dp) = directive_se se in
([<:str_item< # $n$ $opt:dp$ >>], True)
| si = str_item; x = SELF ->
let (sil, stopped) = x in
([si :: sil], stopped)
| EOI -> ([], False) ] ]
;
str_item:
[ [ se = sexpr -> str_item_se se
| e = expr -> <:str_item< $exp:e$ >> ] ]
;
sig_item:
[ [ se = sexpr -> sig_item_se se ] ]
;
expr:
[ "top"
[ se = sexpr -> expr_se se ] ]
;
patt:
[ [ se = sexpr -> patt_se se ] ]
;
sexpr:
[ [ se1 = sexpr_dot; se2 = SELF -> leftify (Sacc loc se1 se2) ]
| [ "("; sl = LIST0 sexpr; ")" -> Sexpr loc sl
| "("; sl = LIST0 sexpr; ")."; se = SELF ->
leftify (Sacc loc (Sexpr loc sl) se)
| "["; sl = LIST0 sexpr; "]" -> Slist loc sl
| "{"; sl = LIST0 sexpr; "}" -> Srec loc sl
| a = pa_extend_keyword -> Slid loc a
| s = LIDENT -> Slid loc s
| s = UIDENT -> Suid loc s
| s = TILDEIDENT -> Stid loc s
| s = QUESTIONIDENT -> Sqid loc s
| s = INT -> Sint loc s
| s = FLOAT -> Sfloat loc s
| s = CHAR -> Schar loc s
| s = STRING -> Sstring loc s
| s = QUOT ->
let i = String.index s ':' in
let typ = String.sub s 0 i in
let txt = String.sub s (i + 1) (String.length s - i - 1) in
Squot loc typ txt ] ]
;
sexpr_dot:
[ [ s = LIDENTDOT -> Slid loc s
| s = UIDENTDOT -> Suid loc s ] ]
;
pa_extend_keyword:
[ [ "_" -> "_"
| "," -> ","
| "=" -> "="
| ":" -> ":"
| "." -> "."
| "/" -> "/" ] ]
;
END;