120 lines
3.8 KiB
OCaml
120 lines
3.8 KiB
OCaml
(***********************************************************************)
|
|
(* *)
|
|
(* 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))
|
|
let pcon c x = mkpat (Ppat_construct (Ldot (Lident "Stream", c), x))
|
|
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))
|
|
|
|
|
|
(* parsers *)
|
|
|
|
let stream_pattern_component skont =
|
|
function
|
|
Spat_term (p, None) ->
|
|
(afun "peek" [mkexp sexp],
|
|
p, mkexp (Pexp_sequence (afun "junk" [mkexp sexp], skont)))
|
|
| Spat_term (p, Some e) ->
|
|
(afun "peek" [mkexp sexp],
|
|
p,
|
|
mkexp
|
|
(Pexp_when
|
|
(e, mkexp(Pexp_sequence (afun "junk" [mkexp sexp], skont)))))
|
|
| Spat_nterm (p, e) ->
|
|
(mkexp
|
|
(Pexp_try
|
|
(esome (mkexp (Pexp_apply (e, [mkexp sexp]))),
|
|
[(pcon "Parse_failure" None,
|
|
mkexp (Pexp_construct (Lident "None", None)))])),
|
|
p, skont)
|
|
| Spat_sterm p ->
|
|
(esome (mkexp sexp), p, skont)
|
|
|
|
let rec stream_pattern epo e ekont =
|
|
function
|
|
[] ->
|
|
begin match epo with
|
|
Some ep ->
|
|
mkexp (Pexp_let (Nonrecursive, [(ep, afun "count" [mkexp sexp])], e))
|
|
| _ -> e
|
|
end
|
|
| (spc, err) :: spcl ->
|
|
let skont =
|
|
let ekont err =
|
|
let str =
|
|
match err with
|
|
Some estr -> estr
|
|
| _ -> mkexp (Pexp_constant (Const_string ""))
|
|
in
|
|
araise "Parse_error" (Some str)
|
|
in
|
|
stream_pattern epo e ekont spcl
|
|
in
|
|
let (tst, p, e) = stream_pattern_component skont spc in
|
|
let ckont = ekont err in
|
|
mkexp
|
|
(Pexp_match
|
|
(tst,
|
|
[(ploc p.ppat_loc (Ppat_construct (Lident "Some", Some p)), e);
|
|
(mkpat Ppat_any, ckont)]))
|
|
|
|
let rec parser_cases =
|
|
function
|
|
[] -> araise "Parse_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_let (Nonrecursive, [(bp, afun "count" [mkexp sexp])], 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 "scons" [lazy e; cstream secl]
|
|
| Sexp_nterm e :: secl -> afun "sapp" [lazy e; cstream secl]
|