calc.ml 3.31 KB
Newer Older
1 2 3 4 5
(* Introduce a short name for the incremental parser API. *)

module I =
  Parser.MenhirInterpreter

6 7 8 9 10 11 12 13 14
(* The length of a stream. *)

let rec length xs =
  match Lazy.force xs with
  | I.Nil ->
      0
  | I.Cons (_, xs) ->
      1 + length xs

15 16 17 18 19 20 21 22 23
(* Folding over a stream. *)

let rec foldr f xs accu =
  match Lazy.force xs with
  | I.Nil ->
      accu
  | I.Cons (x, xs) ->
      f x (foldr f xs accu)

24 25 26 27 28 29
(* A measure of the stack height. Used as a primitive way of
   testing the [view] function. *)

let height env =
  length (I.view env)

30 31 32 33 34
(* Printing an element. *)

let print_element e : string =
  match e with
  | I.Element (s, v, _, _) ->
35 36
      let open Parser.Inspection in
      match symbol s with
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
      | T T_TIMES ->
          "*"
      | T T_RPAREN ->
          ")"
      | T T_PLUS ->
          "+"
      | T T_MINUS ->
          "-"
      | T T_LPAREN ->
          "("
      | T T_INT ->
          string_of_int v
      | N N_expr ->
          string_of_int v
      | N N_main ->
          string_of_int v
      | T T_EOL ->
          ""
      | T T_DIV ->
          "/"

(* Printing a stack. *)

let print env : string =
  let b = Buffer.create 80 in
  foldr (fun e () ->
    Buffer.add_string b (print_element e);
    Buffer.add_char b ' ';
  ) (I.view env) ();
  Buffer.contents b

68 69 70 71 72 73 74
(* Define the loop which drives the parser. At each iteration,
   we analyze a result produced by the parser, and act in an
   appropriate manner. *)

let rec loop linebuf (result : int I.result) =
  match result with
  | I.InputNeeded env ->
75
      (* TEMPORARY *)
76 77 78 79
      if true then begin
        Printf.fprintf stderr "Stack height: %d\n%!" (height env);
        Printf.fprintf stderr "Stack view:\n%s\n%!" (print env)
      end;
80 81 82 83 84 85
      (* The parser needs a token. Request one from the lexer,
         and offer it to the parser, which will produce a new
         result. Then, repeat. *)
      let token = Lexer.token linebuf in
      let startp = linebuf.Lexing.lex_start_p
      and endp = linebuf.Lexing.lex_curr_p in
86 87 88 89
      let result = I.offer result (token, startp, endp) in
      loop linebuf result
  | I.AboutToReduce _ ->
      let result = I.resume result in
90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108
      loop linebuf result
  | I.HandlingError env ->
      (* The parser has suspended itself because of a syntax error. Stop. *)
      Printf.fprintf stderr
        "At offset %d: syntax error.\n%!"
        (Lexing.lexeme_start linebuf)
  | I.Accepted v ->
      (* The parser has succeeded and produced a semantic value. Print it. *)
      Printf.printf "%d\n%!" v
  | I.Rejected ->
      (* The parser rejects this input. This cannot happen, here, because
         we stop as soon as the parser reports [HandlingError]. *)
      assert false

(* Initialize the lexer, and catch any exception raised by the lexer. *)

let process (line : string) =
  let linebuf = Lexing.from_string line in
  try
109
    loop linebuf (Parser.Incremental.main())
110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132
  with
  | Lexer.Error msg ->
      Printf.fprintf stderr "%s%!" msg

(* The rest of the code is as in the [calc] demo. *)

let process (optional_line : string option) =
  match optional_line with
  | None ->
      ()
  | Some line ->
      process line

let rec repeat channel =
  (* Attempt to read one line. *)
  let optional_line, continue = Lexer.line channel in
  process optional_line;
  if continue then
    repeat channel
  
let () =
  repeat (Lexing.from_channel stdin)