Add fatal error on Parser

ast.ml

@@ -1,5 +1,6 @@
 (* simple, untyped AST. *)
 type t =
+  | Nothing
   | Nint of int
   | Nfloat of float
   | Nbool of bool
@@ -59,6 +60,7 @@ let print ast =
 
   let pr = Printf.printf in
   let rec aux = function
+    | Nothing -> pr ""
     | Nint n -> pr "%d" n
     | Nfloat n -> pr "%f" n
     | Nbool b -> pr "%b" b
@@ -75,7 +77,7 @@ let print ast =
     | Let (v, e) ->
       pr "(define %s " v; aux e; pr ")"
     | Letin (v, e, f) ->
-      pr "(let ((%s " v; aux e; pr "))"; aux f; pr ")"
+      pr "(let ((%s " v; aux e; pr ")) "; aux f; pr ")"
     | Unary (op, t) ->
       let op = op_to_string op in
       pr "(%s " op; aux t; pr ")"

eval.ml

@@ -249,6 +249,7 @@ exception Unbound of string
 
 let rec eval env ast =
   let rec aux = function
+    | Nothing -> Nop
     | Nint n -> Int n
     | Nfloat n -> Float n
     | Nbool b -> Bool b

main.ml

@@ -9,6 +9,8 @@ let error_to_string e =
   | Lex.Invalid_character (col, c) ->
     sprintf "invalid character %c at col %d" c col
   | Lex.Expected (col, c) -> sprintf "expected %c at col %d" c col
+  | Parser.Fatal e -> raise e
+  | Parser.End_of_tokens -> "expression ended abruptly"
   | Parser.Expected (col, t) -> sprintf "expected %s at col %d" t col
   | Parser.Unexpected_token (col, t) ->
     sprintf "unexpected token \"%s\" at col %d" t col

parser.ml

@@ -2,6 +2,8 @@ open Ast
 
 module S = Set.Make(String)
 
+(* fatal exception that parsing need to be stopped *)
+exception Fatal of exn
 exception Expected of int * string
 exception Unexpected_token of int * string
 exception End_of_tokens
@@ -84,7 +86,7 @@ let is_keyword = function
   | "if" | "then" | "else" | "let" | "in" -> true
   | _ -> false
 
-(* common parsers *)
+(* parser primitives *)
 
 let any seq =
   match seq () with
@@ -120,16 +122,25 @@ let operator seq =
 
 (* parser combinators *)
 
+let mustbe f seq =
+  try f seq with
+  | e -> raise @@ Fatal e
+
 let oneof fs seq =
   let rec aux = function
     | [] -> assert false
     | [f] -> f seq
-    | f::fs -> (try f seq with _ -> aux fs)
+    | f::fs ->
+      (try f seq with
+       | Fatal _ as e -> raise e
+       | _ -> aux fs)
   in
   aux fs
 
 let either f g = fun seq ->
-  try f seq with _ -> g seq
+  try f seq with
+  | Fatal _ as e -> raise e
+  | _ -> g seq
 
 let (@>) f g = fun seq ->
   let a, seq = f seq in
@@ -141,6 +152,7 @@ let more f seq =
       let x, seq = f seq in
       aux (x::xs) seq
     with
+    | Fatal _ as e -> raise e
     | _ -> xs, seq
   in
   let xs, seq = aux [] seq in
@@ -153,8 +165,14 @@ let rec decl seq =
   seq |> oneof [
     expr min_int;
     let_global;
+    nothing;
   ]
 
+and nothing seq =
+  match seq () with
+  | Seq.Nil -> Nothing, seq
+  | Seq.Cons ((col, x), _) -> unexpected_token col x
+
 (* let_global := "let" ident "=" expr *)
 and let_global seq =
   let _, seq = ident "let" seq in
@@ -178,16 +196,17 @@ and expr pre seq =
     assoc;
     lambda;
     extern_value;
+    (* TODO: place error routine here *)
   ]
 
 (* let_value := "let" id "=" expr "in" expr *)
 and let_value seq =
   let _, seq = ident "let" seq in
-  let id, seq = any_ident seq in
+  let id, seq = mustbe any_ident seq in
   let _, seq = token Equal seq in
-  let e, seq = expr min_int seq in
+  let e, seq = mustbe (expr min_int) seq in
   let _, seq = ident "in" seq in
-  let f, seq = expr min_int seq in
+  let f, seq = mustbe (expr min_int) seq in
   Letin (id, e, f), seq
 
 (* level := "level" {"get" | "set"} [op] *)
@@ -219,22 +238,24 @@ and assoc seq =
 (* lambda := "fun" [ident]+ "->" expr *)
 and lambda seq =
   let _, seq = ident "fun" seq in
-  let v0, seq = any_ident seq in
+  seq |> mustbe (fun seq ->
-  let vars, seq = more any_ident seq in
+      let v0, seq = any_ident seq in
-  let _, seq = token Right_arrow seq in
+      let vars, seq = more any_ident seq in
-  let e, seq = expr min_int seq in
+      let _, seq = token Right_arrow seq in
-  List.fold_right (fun v f -> Nfunction (v, f)) (v0::vars) e,
+      let e, seq = expr min_int seq in
-  seq
+      List.fold_right (fun v f -> Nfunction (v, f)) (v0::vars) e,
+      seq)
 
 (* ifexpr := "if" expr "then" expr "else" expr *)
 and ifexpr seq =
   let _, seq = ident "if" seq in
-  let co, seq = expr min_int seq in
+  seq |> mustbe (fun seq ->
-  let _, seq = ident "then" seq in
+      let co, seq = expr min_int seq in
-  let th, seq = expr min_int seq in
+      let _, seq = ident "then" seq in
-  let _, seq = ident "else" seq in
+      let th, seq = expr min_int seq in
-  let el, seq = expr min_int seq in
+      let _, seq = ident "else" seq in
-  If (co, th, el), seq
+      let el, seq = expr min_int seq in
+      If (co, th, el), seq)
 
 (* apply := value [value]+ *)
 and apply seq =
@@ -246,7 +267,7 @@ and apply seq =
 (* extern_value := external ident *)
 and extern_value seq =
   let _, seq = ident "external" seq in
-  let id, seq = any_ident seq in
+  let id, seq = mustbe any_ident seq in
   Nexternal id, seq
 
 (* unary := - value *)
@@ -257,7 +278,7 @@ and unary seq =
     then Negate, seq
     else expected col "minus (-)"
   in
-  let v, seq = value seq in
+  let v, seq = mustbe value seq in
   Ast.unary op v, seq
 
 (* value := int | float | ( expr ) *)
@@ -265,7 +286,7 @@ and value seq =
   match seq () with
   | Seq.Nil -> raise End_of_tokens
   | Seq.Cons ((col, x), seq) -> begin match x with
-      | Ident id when is_keyword id -> failwith "value"
+      | Ident id when is_keyword id -> expected col "value"
       | Ident "true" -> Nbool true, seq
       | Ident "false" -> Nbool false, seq
       | Ident id -> Var id, seq
@@ -276,8 +297,8 @@ and value seq =
         let _, t, seq = any seq in
         Nsymbol (Token.to_string t), seq
       | LParen ->
-        let e, seq = expr min_int seq in
+        let e, seq = mustbe (expr min_int) seq in
-        let _, seq = token RParen seq in
+        let _, seq = mustbe (token RParen) seq in
         e, seq
       | _ -> unexpected_token col x
     end
@@ -294,7 +315,7 @@ and binop pre left seq =
         if op_pre > pre
         || (op_is_right_to_left op && op_pre = pre)
         then
-          let right, seq = expr op_pre seq in
+          let right, seq = mustbe (expr op_pre) seq in
           binop pre (Ast.binop left op right) seq
         else
           left, Seq.cons (col, x) seq
@@ -306,6 +327,6 @@ and binop pre left seq =
 
 (* parse tokens *)
 let parse ts =
-  let ast, rest = decl ts in
+  let ast, rest = try decl ts with Fatal e -> raise e in
   if rest () <> Seq.Nil then failwith "Parser.parse";
   ast