mirror of
https://github.com/ProgramSnail/Lama.git
synced 2025-12-06 06:48:48 +00:00
merge
This commit is contained in:
danyaberezun
parent
c9bfede950
commit
4d54809acb
6 changed files with 106 additions and 32 deletions
|
|
@ -7,9 +7,9 @@ RC=../src/rc.opt
|
|||
check: $(TESTS)
|
||||
|
||||
$(TESTS): %: %.expr
|
||||
$(RC) $< && cat $@.input | ./$@ > $@.log && diff $@.log orig/$@.log
|
||||
cat $@.input | $(RC) -i $< > $@.log && diff $@.log orig/$@.log
|
||||
cat $@.input | $(RC) -s $< > $@.log && diff $@.log orig/$@.log
|
||||
@$(RC) $< && cat $@.input | ./$@ > $@.log && diff $@.log orig/$@.log
|
||||
@cat $@.input | $(RC) -i $< > $@.log && diff $@.log orig/$@.log
|
||||
@cat $@.input | $(RC) -s $< > $@.log && diff $@.log orig/$@.log
|
||||
|
||||
clean:
|
||||
rm -f test*.log *.s *~ $(TESTS)
|
||||
|
|
|
|||
|
|
@ -5,3 +5,9 @@
|
|||
2
|
||||
3
|
||||
5
|
||||
5
|
||||
1
|
||||
2
|
||||
3
|
||||
4
|
||||
5
|
||||
|
|
|
|||
|
|
@ -27,4 +27,12 @@ case `a (1, 2, 3, 4, 5) of
|
|||
| `a (_, _, _) -> write (3)
|
||||
| `a (_, _, _, _) -> write (4)
|
||||
| `a (_, _, _, _, _) -> write (5)
|
||||
esac
|
||||
esac;
|
||||
|
||||
write (`a (1, 2, 3, 4, 5).length);
|
||||
|
||||
write (`a (1, 2, 3, 4, 5)[0]);
|
||||
write (`a (1, 2, 3, 4, 5)[1]);
|
||||
write (`a (1, 2, 3, 4, 5)[2]);
|
||||
write (`a (1, 2, 3, 4, 5)[3]);
|
||||
write (`a (1, 2, 3, 4, 5)[4])
|
||||
|
|
|
|||
|
|
@ -310,7 +310,8 @@ module Stmt =
|
|||
| "[" ps:(!(Util.list0)[parse]) "]" {Array ps}
|
||||
| x:IDENT y:(-"@" parse)? {match y with None -> Named (x, Wildcard) | Some y -> Named (x, y)}
|
||||
| c:DECIMAL {Const c}
|
||||
| s:STRING {String s}
|
||||
| s:STRING {String (String.sub s 1 (String.length s - 2))}
|
||||
| c:CHAR {Const (Char.code c)}
|
||||
| "#" %"boxed" {Boxed}
|
||||
| "#" %"unboxed" {UnBoxed}
|
||||
| "#" %"string" {StringTag}
|
||||
|
|
@ -385,10 +386,20 @@ module Stmt =
|
|||
| Some s -> Some (State.bind x v s)
|
||||
in
|
||||
match patt, v with
|
||||
| Pattern.Named (x, p), v -> update x v (match_patt p v st )
|
||||
| Pattern.Wildcard , _ -> st
|
||||
| Pattern.Sexp (t, ps), Value.Sexp (t', vs) when t = t' -> match_list ps vs st
|
||||
| _ -> None
|
||||
| Pattern.Named (x, p), v -> update x v (match_patt p v st )
|
||||
| Pattern.Wildcard , _ -> st
|
||||
| Pattern.Sexp (t, ps), Value.Sexp (t', vs) when t = t' && List.length ps = List.length vs -> match_list ps vs st
|
||||
| Pattern.Array ps , Value.Array vs when List.length ps = List.length vs -> match_list ps vs st
|
||||
| Pattern.Const n , Value.Int n' when n = n' -> st
|
||||
| Pattern.String s , Value.String s' when s = s' -> st
|
||||
| Pattern.Boxed , Value.String _
|
||||
| Pattern.Boxed , Value.Array _
|
||||
| Pattern.UnBoxed , Value.Int _
|
||||
| Pattern.Boxed , Value.Sexp (_, _)
|
||||
| Pattern.StringTag , Value.String _
|
||||
| Pattern.ArrayTag , Value.Array _
|
||||
| Pattern.SexpTag , Value.Sexp (_, _) -> st
|
||||
| _ -> None
|
||||
and match_list ps vs s =
|
||||
match ps, vs with
|
||||
| [], [] -> s
|
||||
|
|
|
|||
76
src/SM.ml
76
src/SM.ml
|
|
@ -24,6 +24,8 @@ open Language
|
|||
(* duplicates the top element *) | DUP
|
||||
(* swaps two top elements *) | SWAP
|
||||
(* 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
|
||||
(* leaves a scope *) | LEAVE
|
||||
with show
|
||||
|
|
@ -84,6 +86,20 @@ let rec eval env ((cstack, stack, ((st, i, o) as c)) as conf) = function
|
|||
eval env (cstack, y::x::stack', c) prg'
|
||||
| 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'
|
||||
| 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
|
||||
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'
|
||||
|
|
@ -138,36 +154,52 @@ let compile (defs, p) =
|
|||
and pattern env lfalse = function
|
||||
| Stmt.Pattern.Wildcard -> env, false, [DROP]
|
||||
| Stmt.Pattern.Named (_, p) -> pattern env lfalse p
|
||||
| Stmt.Pattern.Const c -> env, true, [CONST c; BINOP "=="; CJMP ("z", lfalse)]
|
||||
| Stmt.Pattern.String s -> env, true, [STRING s; PATT StrCmp; CJMP ("z", lfalse)]
|
||||
| Stmt.Pattern.ArrayTag -> env, true, [PATT Array; CJMP ("z", lfalse)]
|
||||
| Stmt.Pattern.StringTag -> env, true, [PATT String; CJMP ("z", lfalse)]
|
||||
| Stmt.Pattern.SexpTag -> env, true, [PATT Sexp; CJMP ("z", lfalse)]
|
||||
| Stmt.Pattern.UnBoxed -> env, true, [PATT UnBoxed; CJMP ("z", lfalse)]
|
||||
| Stmt.Pattern.Boxed -> env, true, [PATT Boxed; CJMP ("z", lfalse)]
|
||||
| Stmt.Pattern.Array ps ->
|
||||
let lhead, env = env#get_label in
|
||||
let ldrop, env = env#get_label in
|
||||
let tag = [DUP; ARRAY (List.length ps); CJMP ("nz", lhead); LABEL ldrop; DROP; JMP lfalse; LABEL lhead] in
|
||||
let code, env = pattern_list lhead ldrop env ps in
|
||||
env, true, tag @ code @ [DROP]
|
||||
| Stmt.Pattern.Sexp (t, ps) ->
|
||||
let lhead, env = env#get_label in
|
||||
let ldrop, env = env#get_label in
|
||||
let tag = [DUP; TAG (t, List.length ps); CJMP ("nz", ltag); LABEL ldrop; DROP; JMP lfalse; LABEL ltag] in
|
||||
let _, env, code =
|
||||
List.fold_left
|
||||
(fun (i, env, code) p ->
|
||||
let env, _, pcode = pattern env ldrop p in
|
||||
i+1, env, ([DUP; CONST i; CALL (".elem", 2, false)] @ pcode) :: code
|
||||
)
|
||||
(0, env, [])
|
||||
ps
|
||||
in
|
||||
env, true, tag @ List.flatten (List.rev code) @ [DROP]
|
||||
let tag = [DUP; TAG (t, List.length ps); CJMP ("nz", lhead); LABEL ldrop; DROP; JMP lfalse; LABEL lhead] in
|
||||
let code, env = pattern_list lhead ldrop env ps in
|
||||
env, true, tag @ code @ [DROP]
|
||||
and pattern_list lhead ldrop env ps =
|
||||
let _, env, code =
|
||||
List.fold_left
|
||||
(fun (i, env, code) p ->
|
||||
let env, _, pcode = pattern env ldrop p in
|
||||
i+1, env, ([DUP; CONST i; CALL (".elem", 2, false)] @ pcode) :: code
|
||||
)
|
||||
(0, env, [])
|
||||
ps
|
||||
in
|
||||
List.flatten (List.rev code), env
|
||||
and bindings p =
|
||||
let bindings =
|
||||
fix0 (fun fself ->
|
||||
transform(Stmt.Pattern.t)
|
||||
(object inherit [int list, (string * int list) list, _] @Stmt.Pattern.t
|
||||
method c_Wildcard path = []
|
||||
method c_Named path s p = [s, path] @ fself path p
|
||||
method c_Sexp path x ps = List.concat @@ List.mapi (fun i p -> fself (path @ [i]) p) ps
|
||||
method c_UnBoxed = invalid_arg ""
|
||||
method c_StringTag = invalid_arg ""
|
||||
method c_String = invalid_arg ""
|
||||
method c_SexpTag = invalid_arg ""
|
||||
method c_Const = invalid_arg ""
|
||||
method c_Boxed = invalid_arg ""
|
||||
method c_ArrayTag = invalid_arg ""
|
||||
method c_Array = invalid_arg ""
|
||||
method c_Wildcard path = []
|
||||
method c_Named path s p = [s, path] @ fself path p
|
||||
method c_Sexp path x ps = List.concat @@ List.mapi (fun i p -> fself (path @ [i]) p) ps
|
||||
method c_UnBoxed _ = []
|
||||
method c_StringTag _ = []
|
||||
method c_String _ _ = []
|
||||
method c_SexpTag _ = []
|
||||
method c_Const _ _ = []
|
||||
method c_Boxed _ = []
|
||||
method c_ArrayTag _ = []
|
||||
method c_Array path ps = List.concat @@ List.mapi (fun i p -> fself (path @ [i]) p) ps
|
||||
end))
|
||||
[]
|
||||
p
|
||||
|
|
|
|||
19
src/X86.ml
19
src/X86.ml
|
|
@ -326,7 +326,24 @@ let compile env code =
|
|||
let s1, env = env#allocate in
|
||||
let s2, env = env#allocate 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 ->
|
||||
let env, code =
|
||||
List.fold_left
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue