diff --git a/runtime/Std.i b/runtime/Std.i index 299a2f39a..f8e6aceeb 100644 --- a/runtime/Std.i +++ b/runtime/Std.i @@ -1,3 +1,7 @@ +F,fst; +F,snd; +F,hd; +F,tl; F,readLine; F,stringcat; F,sprintf; diff --git a/runtime/runtime.c b/runtime/runtime.c index 5d564c19f..78b992287 100644 --- a/runtime/runtime.c +++ b/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); diff --git a/src/Language.ml b/src/Language.ml index ebea9791d..439ab8125 100644 --- a/src/Language.ml +++ b/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 _ -> "") (fun _ -> "") v)) | (patt, body)::tl -> @@ -544,23 +551,23 @@ 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 *) let rec balance_value = function - | Array es -> Array (List.map balance_value es) - | Sexp (s, es) -> Sexp (s, List.map balance_value es) - | Binop (o, l, r) -> Binop (o, balance_value l, balance_value r) - | Elem (b, i) -> Elem (balance_value b, balance_value i) - | ElemRef (b, i) -> ElemRef (balance_value b, balance_value i) - | Length x -> Length (balance_value x) - | StringVal x -> StringVal (balance_value x) - | Call (f, es) -> Call (balance_value f, List.map balance_value es) - | 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) + | Array es -> Array (List.map balance_value es) + | Sexp (s, es) -> Sexp (s, List.map balance_value es) + | Binop (o, l, r) -> Binop (o, balance_value l, balance_value r) + | Elem (b, i) -> Elem (balance_value b, balance_value i) + | ElemRef (b, i) -> ElemRef (balance_value b, balance_value i) + | Length x -> Length (balance_value x) + | StringVal x -> StringVal (balance_value x) + | Call (f, es) -> Call (balance_value f, List.map balance_value es) + | 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, l) -> Case (balance_value e, List.map (fun (p, e) -> p, balance_value e) ps, l) | Return _ | While _ @@ -569,15 +576,15 @@ module Expr = | e -> e 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) - | 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)) - | Return None -> Return None - | Skip -> Skip - | e -> Ignore (balance_value e) + | 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, 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)) + | Return None -> Return None + | Skip -> Skip + | e -> Ignore (balance_value e) (* places ignore if expression should be void *) let ignore atr expr = if isVoid atr then Ignore expr else expr @@ -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 (e, bs)} - | %"case" e:parse[def][infix][Val] %"of" bs:(!(Pattern.parse) -"->" scope[def][infix][Void][parse def]) => {isVoid atr} => %"esac" - {Case (e, [bs])} + | %"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, l#coord)} + | %"case" l:$ e:parse[def][infix][Val] %"of" bs:(!(Pattern.parse) -"->" scope[def][infix][Void][parse def]) => {isVoid atr} => %"esac" + {Case (e, [bs], l#coord)} | -"(" parse[def][infix][atr] -")" ) diff --git a/src/SM.ml b/src/SM.ml index 11c9e6ea4..5b5aeb8b6 100644 --- a/src/SM.ml +++ b/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) -> - let n = List.length brs - 1 in - let lexp, env = env#get_label in - let env , fe , se = compile_expr lexp env e in - let env , _, _, code, _ = + | Expr.Case (e, brs, loc) -> + let n = List.length brs - 1 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, 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); *) diff --git a/src/X86.ml b/src/X86.ml index 06ca2f4eb..c6a478bac 100644 --- a/src/X86.ml +++ b/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 @@ -460,7 +462,12 @@ let compile env code = | Sexp -> ".sexp_tag_patt" | 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)