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

merge

Browse source
This commit is contained in:
danyaberezun 2018-11-12 16:32:24 +03:00
parent 5bfc0a08ec
commit c9bfede950
4 changed files with 25 additions and 52 deletions
Download patch file Download diff file Expand all files Collapse all files

3
regression/orig/test046.log
View file

@ -3,4 +3,5 @@
3 3
1 1
2 2
3 3
5

13
regression/test046.expr
View file

@ -14,8 +14,17 @@ case 3 of
esac; esac;
case `a (1, 2, 3) of case `a (1, 2, 3) of
`b -> write (1) `a -> write (1)
| a@`a (_, _, _) -> case a of | a@`a (_, _, _) -> case a of
`a (x, y, z) -> write (x); write (y); write (z) `a (x, y, z) -> write (x); write (y); write (z)
esac esac
esac esac;
case `a (1, 2, 3, 4, 5) of
`a -> write (0)
| `a (_) -> write (1)
| `a (_, _) -> write (2)
| `a (_, _, _) -> write (3)
| `a (_, _, _, _) -> write (4)
| `a (_, _, _, _, _) -> write (5)
esac

41
src/SM.ml
View file

@ -24,8 +24,6 @@ open Language
(* duplicates the top element *) | DUP (* duplicates the top element *) | DUP
(* swaps two top elements *) | SWAP (* swaps two top elements *) | SWAP
(* checks the tag and arity of S-expression *) | TAG of string * int (* 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
(* enters a scope *) | ENTER of string list (* enters a scope *) | ENTER of string list
(* leaves a scope *) | LEAVE (* leaves a scope *) | LEAVE
with show with show
@ -86,20 +84,6 @@ let rec eval env ((cstack, stack, ((st, i, o) as c)) as conf) = function
eval env (cstack, y::x::stack', c) prg' eval env (cstack, y::x::stack', c) prg'
| TAG (t, n) -> let x::stack' = stack in | TAG (t, n) -> let x::stack' = stack in
eval env (cstack, (Value.of_int @@ match x with Value.Sexp (t', a) when t' = t && List.length a = n -> 1 | _ -> 0) :: stack', c) prg' eval env (cstack, (Value.of_int @@ match x with Value.Sexp (t', a) when t' = t && List.length a = n -> 1 | _ -> 0) :: stack', c) prg'
| ARRAY n -> let x::stack' = stack in
eval env (cstack, (Value.of_int @@ match x with Value.Array a when List.length a = n -> 1 | _ -> 0) :: stack', c) prg'
| PATT StrCmp -> let x::y::stack' = stack in
eval env (cstack, (Value.of_int @@ match x, y with (Value.String xs, Value.String ys) when xs = ys -> 1 | _ -> 0) :: stack', c) prg'
| PATT Array -> let x::stack' = stack in
eval env (cstack, (Value.of_int @@ match x with Value.Array _ -> 1 | _ -> 0) :: stack', c) prg'
| PATT String -> let x::stack' = stack in
eval env (cstack, (Value.of_int @@ match x with Value.String _ -> 1 | _ -> 0) :: stack', c) prg'
| PATT Sexp -> let x::stack' = stack in
eval env (cstack, (Value.of_int @@ match x with Value.Sexp _ -> 1 | _ -> 0) :: stack', c) prg'
| PATT Boxed -> let x::stack' = stack in
eval env (cstack, (Value.of_int @@ match x with Value.Int _ -> 0 | _ -> 1) :: stack', c) prg'
| PATT UnBoxed -> let x::stack' = stack in
eval env (cstack, (Value.of_int @@ match x with Value.Int _ -> 1 | _ -> 0) :: stack', c) prg'
| ENTER xs -> let vs, stack' = split (List.length xs) stack in | ENTER xs -> let vs, stack' = split (List.length xs) stack in
eval env (cstack, stack', (State.push st (List.fold_left (fun s (x, v) -> State.bind x v s) State.undefined (List.combine xs vs)) xs, i, o)) prg' eval env (cstack, stack', (State.push st (List.fold_left (fun s (x, v) -> State.bind x v s) State.undefined (List.combine xs vs)) xs, i, o)) prg'
| LEAVE -> eval env (cstack, stack, (State.drop st, i, o)) prg' | LEAVE -> eval env (cstack, stack, (State.drop st, i, o)) prg'
@ -157,20 +141,17 @@ let compile (defs, p) =
| Stmt.Pattern.Sexp (t, ps) -> | Stmt.Pattern.Sexp (t, ps) ->
let lhead, env = env#get_label in let lhead, env = env#get_label in
let ldrop, env = env#get_label in let ldrop, env = env#get_label in
let tag = [DUP; TAG (t, List.length ps); CJMP ("nz", lhead); LABEL ldrop; DROP; JMP lfalse; LABEL lhead] in let tag = [DUP; TAG (t, List.length ps); CJMP ("nz", ltag); LABEL ldrop; DROP; JMP lfalse; LABEL ltag] in
let code, env = pattern_list lhead ldrop env ps in let _, env, code =
env, true, tag @ code @ [DROP] List.fold_left
and pattern_list lhead ldrop env ps = (fun (i, env, code) p ->
let _, env, code = let env, _, pcode = pattern env ldrop p in
List.fold_left i+1, env, ([DUP; CONST i; CALL (".elem", 2, false)] @ pcode) :: code
(fun (i, env, code) p -> )
let env, _, pcode = pattern env ldrop p in (0, env, [])
i+1, env, ([DUP; CONST i; CALL (".elem", 2, false)] @ pcode) :: code ps
) in
(0, env, []) env, true, tag @ List.flatten (List.rev code) @ [DROP]
ps
in
List.flatten (List.rev code), env
and bindings p = and bindings p =
let bindings = let bindings =
fix0 (fun fself -> fix0 (fun fself ->

20
src/X86.ml
View file

@ -326,25 +326,7 @@ let compile env code =
let s1, env = env#allocate in let s1, env = env#allocate in
let s2, env = env#allocate in let s2, env = env#allocate in
let env, code = call env ".tag" 3 false in let env, code = call env ".tag" 3 false in
env, [Mov (L env#hash t, s1); Mov (L n, s2)] @ code env, [Mov (L env#hash t, s1); Mov (L n, s2)] @ code
| ARRAY n ->
let s, env = env#allocate in
let env, code = call env ".array_patt" 2 false in
env, [Mov (L n, s)] @ code
| PATT StrCmp -> call env ".string_patt" 2 false
| PATT patt ->
call env
(match patt with
| Boxed -> ".boxed_patt"
| UnBoxed -> ".unboxed_patt"
| Array -> ".array_tag_patt"
| String -> ".string_tag_patt"
| Sexp -> ".sexp_tag_patt"
) 1 false
| ENTER xs -> | ENTER xs ->
let env, code = let env, code =
List.fold_left List.fold_left