1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
|
(***********************************************************************)
(* *)
(* Objective Caml *)
(* *)
(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
(***********************************************************************)
(* $Id$ *)
open Asttypes
open Parsetree
open Longident
open Location
type stream_pattern_component =
Spat_term of pattern * expression option
| Spat_nterm of pattern * expression
| Spat_sterm of pattern
type stream_expr_component =
Sexp_term of expression
| Sexp_nterm of expression
let mkpat d = { ppat_desc = d; ppat_loc = symbol_loc() }
let mkexp d = { pexp_desc = d; pexp_loc = symbol_loc() }
let eloc loc e = { pexp_desc = e; pexp_loc = loc }
let ploc loc p = { ppat_desc = p; ppat_loc = loc }
let spat = Ppat_var "%strm"
let sexp = Pexp_ident (Lident "%strm")
let eval x = mkexp (Pexp_ident (Ldot (Lident "Stream", x)))
let econ c x = mkexp (Pexp_construct (Ldot (Lident "Stream", c), x, false))
let pcon c x = mkpat (Ppat_construct (Ldot (Lident "Stream", c), x, false))
let afun f x =
mkexp (Pexp_apply (mkexp (Pexp_ident (Ldot (Lident "Stream", f))), x))
let araise c x =
mkexp (Pexp_apply (mkexp (Pexp_ident (Lident "raise")), [econ c x]))
let esome x = mkexp (Pexp_construct (Lident "Some", Some x, false))
(* parsers *)
let stream_pattern_component skont =
let elock = eloc skont.pexp_loc in
function
Spat_term (p, None) ->
(afun "peek" [mkexp sexp],
p, elock (Pexp_sequence (afun "junk" [mkexp sexp], skont)))
| Spat_term (p, Some e) ->
(afun "peek" [mkexp sexp],
p,
elock
(Pexp_when
(e, elock(Pexp_sequence (afun "junk" [mkexp sexp], skont)))))
| Spat_nterm (p, e) ->
let eloce = eloc e.pexp_loc in
(eloce
(Pexp_try
(esome (eloce (Pexp_apply (e, [mkexp sexp]))),
[(pcon "Failure" None,
mkexp (Pexp_construct (Lident "None", None, false)))])),
p, skont)
| Spat_sterm p ->
(esome (mkexp sexp), p, skont)
(* error continuation for 2nd to last component of a stream pattern *)
let ekont1 = function
| Some _ as estr -> araise "Error" estr
| None -> araise "Error" (Some (mkexp (Pexp_constant (Const_string ""))))
;;
let rec stream_pattern epo e ekont =
function
[] ->
begin match epo with
Some ep ->
let countexpr = afun "count" [mkexp sexp] in
eloc e.pexp_loc (Pexp_match (countexpr, [(ep, e)]))
| _ -> e
end
| (spc, err) :: spcl ->
(* success continuation *)
let skont = stream_pattern epo e ekont1 spcl in
let (tst, p, e) = stream_pattern_component skont spc in
let ckont = ekont err in
eloc e.pexp_loc
(Pexp_match
(tst,
[(ploc p.ppat_loc (Ppat_construct (Lident "Some", Some p, false)),
e);
(mkpat Ppat_any, ckont)]))
let rec parser_cases =
function
[] -> araise "Failure" None
| (spcl, epo, e)::cl -> stream_pattern epo e (fun _ -> parser_cases cl) spcl
let cparser (bpo, pc) =
let pc = parser_cases pc in
let e =
match bpo with
Some bp -> mkexp (Pexp_match (afun "count" [mkexp sexp], [(bp, pc)]))
| None -> pc
in
mkexp (Pexp_function [(mkpat spat, e)])
(* streams *)
let lazy e = mkexp (Pexp_function [(mkpat Ppat_any, e)])
let rec cstream =
function
[] -> eval "sempty"
| Sexp_term e :: secl -> afun "lcons" [lazy e; cstream secl]
| Sexp_nterm e :: secl -> afun "lapp" [lazy e; cstream secl]
|
