diff options
Diffstat (limited to 'camlp4/etc/pa_schemer.ml')
| -rw-r--r-- | camlp4/etc/pa_schemer.ml | 1067 |
1 files changed, 0 insertions, 1067 deletions
diff --git a/camlp4/etc/pa_schemer.ml b/camlp4/etc/pa_schemer.ml deleted file mode 100644 index a7d64ce4a5..0000000000 --- a/camlp4/etc/pa_schemer.ml +++ /dev/null @@ -1,1067 +0,0 @@ -(* camlp4 pa_r.cmo pa_rp.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo *) -(* 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 (bp, ep) (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 (ep - 2, ep - 1) (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 (ep - 1, ep) (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) :] ep -> - 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 (lexer kwt); - 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 MLast.loc and sexpr and sexpr - | Schar of MLast.loc and string - | Sexpr of MLast.loc and list sexpr - | Sint of MLast.loc and string - | Sfloat of MLast.loc and string - | Slid of MLast.loc and string - | Slist of MLast.loc and list sexpr - | Sqid of MLast.loc and string - | Squot of MLast.loc and string and string - | Srec of MLast.loc and list sexpr - | Sstring of MLast.loc and string - | Stid of MLast.loc and string - | Suid of MLast.loc 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; |