st/lama_byterun
1
0
Fork 0
mirror of https://github.com/ProgramSnail/Lama.git synced 2025-12-06 06:48:48 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

Match failure implemented

Browse source
This commit is contained in:
Dmitry Boulytchev 2019-12-24 03:59:05 +03:00
parent de2955cbc9
commit 711c8d2f12
5 changed files with 82 additions and 38 deletions
Download patch file Download diff file Expand all files Collapse all files

4
runtime/Std.i
View file

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

22
runtime/runtime.c
View file

@ -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);

63
src/Language.ml
View file

@ -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,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] -")"
)

18
src/SM.ml
View file

@ -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); *)

13
src/X86.ml
View file

@ -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)