diff options
Diffstat (limited to 'camlp4/ocaml_src/meta/pa_rp.ml')
| -rw-r--r-- | camlp4/ocaml_src/meta/pa_rp.ml | 641 |
1 files changed, 0 insertions, 641 deletions
diff --git a/camlp4/ocaml_src/meta/pa_rp.ml b/camlp4/ocaml_src/meta/pa_rp.ml deleted file mode 100644 index ad743e8708..0000000000 --- a/camlp4/ocaml_src/meta/pa_rp.ml +++ /dev/null @@ -1,641 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -open Pcaml;; - -type spat_comp = - SpTrm of MLast.loc * MLast.patt * MLast.expr option - | SpNtr of MLast.loc * MLast.patt * MLast.expr - | SpStr of MLast.loc * MLast.patt -;; -type sexp_comp = - SeTrm of MLast.loc * MLast.expr - | SeNtr of MLast.loc * MLast.expr -;; - -let strm_n = "strm__";; -let peek_fun loc = - MLast.ExAcc (loc, MLast.ExUid (loc, "Stream"), MLast.ExLid (loc, "peek")) -;; -let junk_fun loc = - MLast.ExAcc (loc, MLast.ExUid (loc, "Stream"), MLast.ExLid (loc, "junk")) -;; - -(* Parsers. *) -(* In syntax generated, many cases are optimisations. *) - -let rec pattern_eq_expression p e = - match p, e with - MLast.PaLid (_, a), MLast.ExLid (_, b) -> a = b - | MLast.PaUid (_, a), MLast.ExUid (_, b) -> a = b - | MLast.PaApp (_, p1, p2), MLast.ExApp (_, e1, e2) -> - pattern_eq_expression p1 e1 && pattern_eq_expression p2 e2 - | _ -> false -;; - -let is_raise e = - match e with - MLast.ExApp (_, MLast.ExLid (_, "raise"), _) -> true - | _ -> false -;; - -let is_raise_failure e = - match e with - MLast.ExApp - (_, MLast.ExLid (_, "raise"), - MLast.ExAcc - (_, MLast.ExUid (_, "Stream"), MLast.ExUid (_, "Failure"))) -> - true - | _ -> false -;; - -let rec handle_failure e = - match e with - MLast.ExTry - (_, te, - [MLast.PaAcc - (_, MLast.PaUid (_, "Stream"), MLast.PaUid (_, "Failure")), None, - e]) -> - handle_failure e - | MLast.ExMat (_, me, pel) -> - handle_failure me && - List.for_all - (function - _, None, e -> handle_failure e - | _ -> false) - pel - | MLast.ExLet (_, false, pel, e) -> - List.for_all (fun (p, e) -> handle_failure e) pel && handle_failure e - | MLast.ExLid (_, _) | MLast.ExInt (_, _) | MLast.ExStr (_, _) | - MLast.ExChr (_, _) | MLast.ExFun (_, _) | MLast.ExUid (_, _) -> - true - | MLast.ExApp (_, MLast.ExLid (_, "raise"), e) -> - begin match e with - MLast.ExAcc - (_, MLast.ExUid (_, "Stream"), MLast.ExUid (_, "Failure")) -> - false - | _ -> true - end - | MLast.ExApp (_, f, x) -> - is_constr_apply f && handle_failure f && handle_failure x - | _ -> false -and is_constr_apply = - function - MLast.ExUid (_, _) -> true - | MLast.ExLid (_, _) -> false - | MLast.ExApp (_, x, _) -> is_constr_apply x - | _ -> false -;; - -let rec subst v e = - let loc = MLast.loc_of_expr e in - match e with - MLast.ExLid (_, x) -> - let x = if x = v then strm_n else x in MLast.ExLid (loc, x) - | MLast.ExUid (_, _) -> e - | MLast.ExInt (_, _) -> e - | MLast.ExChr (_, _) -> e - | MLast.ExStr (_, _) -> e - | MLast.ExAcc (_, _, _) -> e - | MLast.ExLet (_, rf, pel, e) -> - MLast.ExLet (loc, rf, List.map (subst_pe v) pel, subst v e) - | MLast.ExApp (_, e1, e2) -> MLast.ExApp (loc, subst v e1, subst v e2) - | MLast.ExTup (_, el) -> MLast.ExTup (loc, List.map (subst v) el) - | _ -> raise Not_found -and subst_pe v (p, e) = - match p with - MLast.PaLid (_, v') when v <> v' -> p, subst v e - | _ -> raise Not_found -;; - -let stream_pattern_component skont ckont = - function - SpTrm (loc, p, wo) -> - MLast.ExMat - (loc, MLast.ExApp (loc, peek_fun loc, MLast.ExLid (loc, strm_n)), - [MLast.PaApp (loc, MLast.PaUid (loc, "Some"), p), wo, - MLast.ExSeq - (loc, - [MLast.ExApp (loc, junk_fun loc, MLast.ExLid (loc, strm_n)); - skont]); - MLast.PaAny loc, None, ckont]) - | SpNtr (loc, p, e) -> - let e = - match e with - MLast.ExFun - (_, - [MLast.PaTyc - (_, MLast.PaLid (_, v), - MLast.TyApp - (_, - MLast.TyAcc - (_, MLast.TyUid (_, "Stream"), MLast.TyLid (_, "t")), - MLast.TyAny _)), None, e]) - when v = strm_n -> - e - | _ -> MLast.ExApp (loc, e, MLast.ExLid (loc, strm_n)) - in - if pattern_eq_expression p skont then - if is_raise_failure ckont then e - else if handle_failure e then e - else - MLast.ExTry - (loc, e, - [MLast.PaAcc - (loc, MLast.PaUid (loc, "Stream"), - MLast.PaUid (loc, "Failure")), - None, ckont]) - else if is_raise_failure ckont then - MLast.ExLet (loc, false, [p, e], skont) - else if - pattern_eq_expression - (MLast.PaApp (loc, MLast.PaUid (loc, "Some"), p)) skont - then - MLast.ExTry - (loc, MLast.ExApp (loc, MLast.ExUid (loc, "Some"), e), - [MLast.PaAcc - (loc, MLast.PaUid (loc, "Stream"), - MLast.PaUid (loc, "Failure")), - None, ckont]) - else if is_raise ckont then - let tst = - if handle_failure e then e - else - MLast.ExTry - (loc, e, - [MLast.PaAcc - (loc, MLast.PaUid (loc, "Stream"), - MLast.PaUid (loc, "Failure")), - None, ckont]) - in - MLast.ExLet (loc, false, [p, tst], skont) - else - MLast.ExMat - (loc, - MLast.ExTry - (loc, MLast.ExApp (loc, MLast.ExUid (loc, "Some"), e), - [MLast.PaAcc - (loc, MLast.PaUid (loc, "Stream"), - MLast.PaUid (loc, "Failure")), - None, MLast.ExUid (loc, "None")]), - [MLast.PaApp (loc, MLast.PaUid (loc, "Some"), p), None, skont; - MLast.PaAny loc, None, ckont]) - | SpStr (loc, p) -> - try - match p with - MLast.PaLid (_, v) -> subst v skont - | _ -> raise Not_found - with - Not_found -> - MLast.ExLet (loc, false, [p, MLast.ExLid (loc, strm_n)], skont) -;; - -let rec stream_pattern loc epo e ekont = - function - [] -> - begin match epo with - Some ep -> - MLast.ExLet - (loc, false, - [ep, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Stream"), - MLast.ExLid (loc, "count")), - MLast.ExLid (loc, strm_n))], - e) - | _ -> e - end - | (spc, err) :: spcl -> - let skont = - let ekont err = - let str = - match err with - Some estr -> estr - | _ -> MLast.ExStr (loc, "") - in - MLast.ExApp - (loc, MLast.ExLid (loc, "raise"), - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Stream"), - MLast.ExUid (loc, "Error")), - str)) - in - stream_pattern loc epo e ekont spcl - in - let ckont = ekont err in stream_pattern_component skont ckont spc -;; - -let stream_patterns_term loc ekont tspel = - let pel = - List.map - (fun (p, w, loc, spcl, epo, e) -> - let p = MLast.PaApp (loc, MLast.PaUid (loc, "Some"), p) in - let e = - let ekont err = - let str = - match err with - Some estr -> estr - | _ -> MLast.ExStr (loc, "") - in - MLast.ExApp - (loc, MLast.ExLid (loc, "raise"), - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Stream"), - MLast.ExUid (loc, "Error")), - str)) - in - let skont = stream_pattern loc epo e ekont spcl in - MLast.ExSeq - (loc, - [MLast.ExApp (loc, junk_fun loc, MLast.ExLid (loc, strm_n)); - skont]) - in - p, w, e) - tspel - in - let pel = pel @ [MLast.PaAny loc, None, ekont ()] in - MLast.ExMat - (loc, MLast.ExApp (loc, peek_fun loc, MLast.ExLid (loc, strm_n)), pel) -;; - -let rec group_terms = - function - ((SpTrm (loc, p, w), None) :: spcl, epo, e) :: spel -> - let (tspel, spel) = group_terms spel in - (p, w, loc, spcl, epo, e) :: tspel, spel - | spel -> [], spel -;; - -let rec parser_cases loc = - function - [] -> - MLast.ExApp - (loc, MLast.ExLid (loc, "raise"), - MLast.ExAcc - (loc, MLast.ExUid (loc, "Stream"), MLast.ExUid (loc, "Failure"))) - | spel -> - match group_terms spel with - [], (spcl, epo, e) :: spel -> - stream_pattern loc epo e (fun _ -> parser_cases loc spel) spcl - | tspel, spel -> - stream_patterns_term loc (fun _ -> parser_cases loc spel) tspel -;; - -let cparser loc bpo pc = - let e = parser_cases loc pc in - let e = - match bpo with - Some bp -> - MLast.ExLet - (loc, false, - [bp, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Stream"), - MLast.ExLid (loc, "count")), - MLast.ExLid (loc, strm_n))], - e) - | None -> e - in - let p = - MLast.PaTyc - (loc, MLast.PaLid (loc, strm_n), - MLast.TyApp - (loc, - MLast.TyAcc - (loc, MLast.TyUid (loc, "Stream"), MLast.TyLid (loc, "t")), - MLast.TyAny loc)) - in - MLast.ExFun (loc, [p, None, e]) -;; - -let cparser_match loc me bpo pc = - let pc = parser_cases loc pc in - let e = - match bpo with - Some bp -> - MLast.ExLet - (loc, false, - [bp, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Stream"), - MLast.ExLid (loc, "count")), - MLast.ExLid (loc, strm_n))], - pc) - | None -> pc - in - match me with - MLast.ExLid (_, x) when x = strm_n -> e - | _ -> - MLast.ExLet - (loc, false, - [MLast.PaTyc - (loc, MLast.PaLid (loc, strm_n), - MLast.TyApp - (loc, - MLast.TyAcc - (loc, MLast.TyUid (loc, "Stream"), MLast.TyLid (loc, "t")), - MLast.TyAny loc)), - me], - e) -;; - -(* streams *) - -let rec not_computing = - function - MLast.ExLid (_, _) | MLast.ExUid (_, _) | MLast.ExInt (_, _) | - MLast.ExFlo (_, _) | MLast.ExChr (_, _) | MLast.ExStr (_, _) -> - true - | MLast.ExApp (_, x, y) -> is_cons_apply_not_computing x && not_computing y - | _ -> false -and is_cons_apply_not_computing = - function - MLast.ExUid (_, _) -> true - | MLast.ExLid (_, _) -> false - | MLast.ExApp (_, x, y) -> is_cons_apply_not_computing x && not_computing y - | _ -> false -;; - -let slazy loc e = - match e with - MLast.ExApp (_, f, MLast.ExUid (_, "()")) -> - begin match f with - MLast.ExLid (_, _) -> f - | _ -> MLast.ExFun (loc, [MLast.PaAny loc, None, e]) - end - | _ -> MLast.ExFun (loc, [MLast.PaAny loc, None, e]) -;; - -let rec cstream gloc = - function - [] -> - let loc = gloc in - MLast.ExAcc - (loc, MLast.ExUid (loc, "Stream"), MLast.ExLid (loc, "sempty")) - | [SeTrm (loc, e)] -> - if not_computing e then - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Stream"), MLast.ExLid (loc, "ising")), - e) - else - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Stream"), MLast.ExLid (loc, "lsing")), - slazy loc e) - | SeTrm (loc, e) :: secl -> - if not_computing e then - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Stream"), - MLast.ExLid (loc, "icons")), - e), - cstream gloc secl) - else - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Stream"), - MLast.ExLid (loc, "lcons")), - slazy loc e), - cstream gloc secl) - | [SeNtr (loc, e)] -> - if not_computing e then e - else - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Stream"), MLast.ExLid (loc, "slazy")), - slazy loc e) - | SeNtr (loc, e) :: secl -> - if not_computing e then - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Stream"), MLast.ExLid (loc, "iapp")), - e), - cstream gloc secl) - else - MLast.ExApp - (loc, - MLast.ExApp - (loc, - MLast.ExAcc - (loc, MLast.ExUid (loc, "Stream"), MLast.ExLid (loc, "lapp")), - slazy loc e), - cstream gloc secl) -;; - -(* Syntax extensions in Revised Syntax grammar *) - -Grammar.extend - (let _ = (expr : 'expr Grammar.Entry.e) in - let grammar_entry_create s = - Grammar.Entry.create (Grammar.of_entry expr) s - in - let parser_case : 'parser_case Grammar.Entry.e = - grammar_entry_create "parser_case" - and stream_patt : 'stream_patt Grammar.Entry.e = - grammar_entry_create "stream_patt" - and stream_patt_comp_err : 'stream_patt_comp_err Grammar.Entry.e = - grammar_entry_create "stream_patt_comp_err" - and stream_patt_comp : 'stream_patt_comp Grammar.Entry.e = - grammar_entry_create "stream_patt_comp" - and ipatt : 'ipatt Grammar.Entry.e = grammar_entry_create "ipatt" - and stream_expr_comp : 'stream_expr_comp Grammar.Entry.e = - grammar_entry_create "stream_expr_comp" - in - [Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "top"), - [None, None, - [[Gramext.Stoken ("", "match"); Gramext.Sself; - Gramext.Stoken ("", "with"); Gramext.Stoken ("", "parser"); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e))); - Gramext.Snterm - (Grammar.Entry.obj (parser_case : 'parser_case Grammar.Entry.e))], - Gramext.action - (fun (pc : 'parser_case) (po : 'ipatt option) _ _ (e : 'expr) _ - (loc : int * int) -> - (cparser_match loc e po [pc] : 'expr)); - [Gramext.Stoken ("", "match"); Gramext.Sself; - Gramext.Stoken ("", "with"); Gramext.Stoken ("", "parser"); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e))); - Gramext.Stoken ("", "["); - Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj (parser_case : 'parser_case Grammar.Entry.e)), - Gramext.Stoken ("", "|")); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (pcl : 'parser_case list) _ (po : 'ipatt option) _ _ - (e : 'expr) _ (loc : int * int) -> - (cparser_match loc e po pcl : 'expr)); - [Gramext.Stoken ("", "parser"); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e))); - Gramext.Snterm - (Grammar.Entry.obj (parser_case : 'parser_case Grammar.Entry.e))], - Gramext.action - (fun (pc : 'parser_case) (po : 'ipatt option) _ (loc : int * int) -> - (cparser loc po [pc] : 'expr)); - [Gramext.Stoken ("", "parser"); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e))); - Gramext.Stoken ("", "["); - Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj (parser_case : 'parser_case Grammar.Entry.e)), - Gramext.Stoken ("", "|")); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (pcl : 'parser_case list) _ (po : 'ipatt option) _ - (loc : int * int) -> - (cparser loc po pcl : 'expr))]]; - Grammar.Entry.obj (parser_case : 'parser_case Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "[:"); - Gramext.Snterm - (Grammar.Entry.obj (stream_patt : 'stream_patt Grammar.Entry.e)); - Gramext.Stoken ("", ":]"); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e))); - Gramext.Stoken ("", "->"); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (po : 'ipatt option) _ (sp : 'stream_patt) _ - (loc : int * int) -> - (sp, po, e : 'parser_case))]]; - Grammar.Entry.obj (stream_patt : 'stream_patt Grammar.Entry.e), None, - [None, None, - [[], Gramext.action (fun (loc : int * int) -> ([] : 'stream_patt)); - [Gramext.Snterm - (Grammar.Entry.obj - (stream_patt_comp : 'stream_patt_comp Grammar.Entry.e)); - Gramext.Stoken ("", ";"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (stream_patt_comp_err : - 'stream_patt_comp_err Grammar.Entry.e)), - Gramext.Stoken ("", ";"))], - Gramext.action - (fun (sp : 'stream_patt_comp_err list) _ (spc : 'stream_patt_comp) - (loc : int * int) -> - ((spc, None) :: sp : 'stream_patt)); - [Gramext.Snterm - (Grammar.Entry.obj - (stream_patt_comp : 'stream_patt_comp Grammar.Entry.e))], - Gramext.action - (fun (spc : 'stream_patt_comp) (loc : int * int) -> - ([spc, None] : 'stream_patt))]]; - Grammar.Entry.obj - (stream_patt_comp_err : 'stream_patt_comp_err Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj - (stream_patt_comp : 'stream_patt_comp Grammar.Entry.e)); - Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "?"); - Gramext.Snterm - (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> (e : 'e__1))])], - Gramext.action - (fun (eo : 'e__1 option) (spc : 'stream_patt_comp) - (loc : int * int) -> - (spc, eo : 'stream_patt_comp_err))]]; - Grammar.Entry.obj (stream_patt_comp : 'stream_patt_comp Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))], - Gramext.action - (fun (p : 'patt) (loc : int * int) -> - (SpStr (loc, p) : 'stream_patt_comp)); - [Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (p : 'patt) (loc : int * int) -> - (SpNtr (loc, p, e) : 'stream_patt_comp)); - [Gramext.Stoken ("", "`"); - Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)); - Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "when"); - Gramext.Snterm - (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> (e : 'e__2))])], - Gramext.action - (fun (eo : 'e__2 option) (p : 'patt) _ (loc : int * int) -> - (SpTrm (loc, p, eo) : 'stream_patt_comp))]]; - Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (i : string) (loc : int * int) -> - (MLast.PaLid (loc, i) : 'ipatt))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "[:"); - Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj - (stream_expr_comp : 'stream_expr_comp Grammar.Entry.e)), - Gramext.Stoken ("", ";")); - Gramext.Stoken ("", ":]")], - Gramext.action - (fun _ (se : 'stream_expr_comp list) _ (loc : int * int) -> - (cstream loc se : 'expr))]]; - Grammar.Entry.obj (stream_expr_comp : 'stream_expr_comp Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) (loc : int * int) -> - (SeNtr (loc, e) : 'stream_expr_comp)); - [Gramext.Stoken ("", "`"); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (loc : int * int) -> - (SeTrm (loc, e) : 'stream_expr_comp))]]]);; |