Match failure implemented

runtime/Std.i

@@ -1,3 +1,7 @@
+F,fst;
+F,snd;
+F,hd;
+F,tl;
 F,readLine;
 F,stringcat;
 F,sprintf;

runtime/runtime.c

@@ -617,6 +617,12 @@ extern void Lfailure (char *s, ...) {
   vfailure    (s, args);
 }
 
+extern void Bmatch_failure (void *v, char *fname, int line, int col) {
+  createStringBuf ();
+  printValue (v);
+  failure ("match failure at %s:%d:%d, value '%s'\n", fname, line, col, stringBuf.contents);
+}
+
 extern void* /*Lstrcat*/ i__Infix_4343 (void *a, void *b) {
   data *da = (data*) BOX (NULL);
   data *db = (data*) BOX (NULL);
@@ -747,6 +753,22 @@ extern void Lfwrite (char *fname, char *contents) {
   failure ("fwrite (\"%s\"): %s\n", fname, strerror (errno));
 }
 
+extern void* Lfst (void *v) {
+  return Belem (v, BOX(0));  
+}
+
+extern void* Lsnd (void *v) {
+  return Belem (v, BOX(1));  
+}
+
+extern void* Lhd (void *v) {
+  return Belem (v, BOX(0));  
+}
+
+extern void* Ltl (void *v) {
+  return Belem (v, BOX(1));  
+}
+
 /* Lread is an implementation of the "read" construct */
 extern int Lread () {
   int result = BOX(0);

src/Language.ml

@@ -13,6 +13,11 @@ exception Semantic_error of string
 
 let unquote s = String.sub s 1 (String.length s - 2)
 
+module Loc =
+  struct
+    @type t = int * int with show, html
+  end
+  
 (* Values *)
 module Value =
   struct
@@ -276,6 +281,8 @@ module Pattern =
       | c:DECIMAL                                    {Const c}
       | s:STRING                                     {String (unquote s)}
       | c:CHAR                                       {Const  (Char.code c)}
+      | %"true"                                      {Const 1}
+      | %"false"                                     {Const 0}
       | "#" %"boxed"                                 {Boxed}
       | "#" %"unboxed"                               {UnBoxed}
       | "#" %"string"                                {StringTag}
@@ -319,7 +326,7 @@ module Expr =
     (* conditional                *) | If        of t * t * t
     (* loop with a pre-condition  *) | While     of t * t
     (* loop with a post-condition *) | Repeat    of t * t
-    (* pattern-matching           *) | Case      of t * (Pattern.t * t) list
+    (* pattern-matching           *) | Case      of t * (Pattern.t * t) list * Loc.t
     (* return statement           *) | Return    of t option
     (* ignore a value             *) | Ignore    of t
     (* unit value                 *) | Unit
@@ -494,7 +501,7 @@ module Expr =
       | Repeat (s, e) ->
          eval conf (seq (While (Binop ("==", e, Const 0), s)) k) s
       | Return e -> (match e with None -> (st, i, o, []) | Some e -> eval (st, i, o, []) Skip e)
-      | Case (e, bs)->
+      | Case (e, bs, _)->
          let rec branch ((st, i, o, v::vs) as conf) = function
          | [] -> failwith (Printf.sprintf "Pattern matching failed: no branch is selected while matching %s\n" (show(Value.t) (fun _ -> "<expr>") (fun _ -> "<state>") v))
          | (patt, body)::tl ->
@@ -544,7 +551,7 @@ module Expr =
     | Elem (e, i)      -> ElemRef (e, i)
     | Seq  (s1, s2)    -> Seq (s1, propagate_ref s2)
     | If   (e, t1, t2) -> If (e, propagate_ref t1, propagate_ref t2)
-    | Case (e, bs)     -> Case (e, List.map (fun (p, e) -> p, propagate_ref e) bs)
+    | Case (e, bs, l)  -> Case (e, List.map (fun (p, e) -> p, propagate_ref e) bs, l)
     | _                -> raise (Semantic_error "not a destination")
 
     (* Balance values *)
@@ -560,7 +567,7 @@ module Expr =
     | Assign    (d, s)     -> Assign    (balance_value d, balance_value s)
     | Seq       (l, r)     -> Seq       (balance_void l, balance_value r)
     | If        (c, t, e)  -> If        (balance_value c, balance_value t, balance_value e)
-    | Case      (e, ps)   -> Case      (balance_value e, List.map (fun (p, e) -> p, balance_value e) ps)
+    | Case      (e, ps, l) -> Case      (balance_value e, List.map (fun (p, e) -> p, balance_value e) ps, l)
 
     | Return    _
     | While     _
@@ -571,7 +578,7 @@ module Expr =
     and balance_void = function
     | If     (c, t, e)  -> If     (balance_value c, balance_void t, balance_void e)
     | Seq    (l, r)     -> Seq    (balance_void l, balance_void r)
-    | Case   (e, ps)   -> Case   (balance_value e, List.map (fun (p, e) -> p, balance_void e) ps)
+    | Case   (e, ps, l) -> Case   (balance_value e, List.map (fun (p, e) -> p, balance_void e) ps, l)
     | While  (e, s)     -> While  (balance_value e, balance_void s)
     | Repeat (s, e)     -> Repeat (balance_void s, balance_value e)
     | Return (Some e)   -> Return (Some (balance_value e))
@@ -710,10 +717,10 @@ module Expr =
       | %"repeat" s:scope[def][infix][Void][parse def] %"until" e:basic[def][infix][Val] => {isVoid atr} => {Repeat (s, e)}
       | %"return" e:basic[def][infix][Val]? => {isVoid atr} => {Return e}
 
-      | %"case" e:parse[def][infix][Val] %"of" bs:!(Util.listBy1)[ostap ("|")][ostap (!(Pattern.parse) -"->" scope[def][infix][atr][parse def])] %"esac"
+      | %"case" l:$ e:parse[def][infix][Val] %"of" bs:!(Util.listBy1)[ostap ("|")][ostap (!(Pattern.parse) -"->" scope[def][infix][atr][parse def])] %"esac"
-                                                                     {Case (e, bs)}
+                                                                     {Case (e, bs, l#coord)}
-      | %"case" e:parse[def][infix][Val] %"of" bs:(!(Pattern.parse) -"->" scope[def][infix][Void][parse def]) => {isVoid atr} => %"esac"
+      | %"case" l:$ e:parse[def][infix][Val] %"of" bs:(!(Pattern.parse) -"->" scope[def][infix][Void][parse def]) => {isVoid atr} => %"esac"
-                                                                     {Case (e, [bs])}
+                                                                     {Case (e, [bs], l#coord)}
 
       | -"(" parse[def][infix][atr] -")"
     )

src/SM.ml

@@ -30,6 +30,7 @@ open Language
 (* checks the tag and arity of S-expression  *) | TAG     of string * int
 (* checks the tag and size of array          *) | ARRAY   of int
 (* checks various patterns                   *) | PATT    of patt
+(* match failure                             *) | FAIL    of Loc.t
 (* external definition                       *) | EXTERN  of string
 (* public   definition                       *) | PUBLIC  of string
 with show
@@ -206,6 +207,8 @@ let rec eval env (((cstack, stack, glob, loc, i, o) as conf) : config) = functio
                                  eval env (cstack, (Value.of_int @@ match x with Value.Int _ -> 1 | _ -> 0) :: stack', glob, loc, i, o) prg'
     | PATT Closure            -> let x::stack' = stack in
                                  eval env (cstack, (Value.of_int @@ match x with Value.Closure _ -> 1 | _ -> 0) :: stack', glob, loc, i, o) prg'
+    | FAIL l                  -> let x::_ = stack in
+                                 raise (Failure (Printf.sprintf "matching value %s failure at %s" (show(value) x) (show(Loc.t) l)))
    )
 
 (* Top-level evaluation
@@ -712,18 +715,19 @@ let compile cmd ((imports, infixes), p) =
 
   | Expr.Leave              -> env, false, []
                                  
-  | Expr.Case (e, brs) ->
+  | Expr.Case (e, brs, loc) ->
      let n          = List.length brs - 1 in
-     let lexp, env = env#get_label in
+     let lfail, env = env#get_label in
+     let lexp , env = env#get_label in
      let env  , fe  , se      = compile_expr lexp env e in
-     let env , _, _, code, _ =
+     let env  , _, _, code, fail =
        List.fold_left
          (fun ((env, lab, i, code, continue) as acc) (p, s) ->
              if continue
              then
                let (lfalse, env), jmp =
                  if i = n
-                 then (l, env), []
+                 then (lfail, env), []
                  else env#get_label, [JMP l]
                in
                let env, lfalse', pcode = pattern env lfalse p in
@@ -736,7 +740,7 @@ let compile cmd ((imports, infixes), p) =
          )
          (env, None, 0, [], true) brs
      in
-     env, true, se @ (if fe then [LABEL lexp] else []) @ [DUP] @ (List.flatten @@ List.rev code) @ [JMP l] 
+     env, true, se @ (if fe then [LABEL lexp] else []) @ [DUP] @ (List.flatten @@ List.rev code) @ [JMP l] @ if fail then [LABEL lfail; FAIL loc] else []
   in
   let rec compile_fundef env ((name, args, stmt, st) as fd) =
     (* Printf.eprintf "Compile fundef: %s, state=%s\n" name (show(State.t) (show(Value.designation)) st);                *)

src/X86.ml

@@ -114,7 +114,7 @@ open SM
    Take an environment, a stack machine program, and returns a pair --- the updated environment and the list
    of x86 instructions
 *)
-let compile env code =
+let compile cmd env code =
   (* SM.print_prg code; *)
   flush stdout;
   let suffix = function
@@ -399,6 +399,7 @@ let compile env code =
                   (if f = "main" then [Call "L__gc_init"] else [])   
 
           | END ->
+             env#assert_empty_stack;
              let name = env#fname in
              env#leave, [
                  Label env#epilogue;
@@ -414,6 +415,7 @@ let compile env code =
 
           | RET ->
              let x, env = env#pop in
+             env#assert_empty_stack;
              env, [Mov (x, eax); Jmp env#epilogue]
             
           | CALL (f, n) -> call env f n
@@ -461,6 +463,11 @@ let compile env code =
                 | Closure -> ".closure_tag_patt"
                ) 1
 
+          | FAIL (line, col) ->                       
+             let v, env = env#pop in
+             let s, env = env#string cmd#get_infile in
+             env, [Push (L col); Push (L line); Push (M ("$" ^ s)); Push v; Call "Bmatch_failure"; Binop  ("+", L (3 * word_size), esp)]
+             
           | i ->
              invalid_arg (Printf.sprintf "invalid SM insn: %s\n" (GT.show(insn) i))
         in
@@ -651,7 +658,7 @@ class env prg =
 *)
 let genasm cmd prog =
   let sm        = SM.compile cmd prog in
-  let env, code = compile (new env sm) sm in
+  let env, code = compile cmd (new env sm) sm in
   let gc_start, gc_end = "__gc_data_start", "__gc_data_end" in
   let globals =
     List.map (fun s -> Meta (Printf.sprintf "\t.globl\t%s" s)) ([gc_start; gc_end] @ env#publics)