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)
|
check: $(TESTS)
|
||||||
|
|
||||||
$(TESTS): %: %.expr
|
$(TESTS): %: %.expr
|
||||||
$(RC) $< && cat $@.input | ./$@ > $@.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) -i $< > $@.log && diff $@.log orig/$@.log
|
||||||
cat $@.input | $(RC) -s $< > $@.log && diff $@.log orig/$@.log
|
@cat $@.input | $(RC) -s $< > $@.log && diff $@.log orig/$@.log
|
||||||
|
|
||||||
clean:
|
clean:
|
||||||
rm -f test*.log *.s *~ $(TESTS)
|
rm -f test*.log *.s *~ $(TESTS)
|
||||||
|
|
|
||||||
|
|
@ -5,3 +5,9 @@
|
||||||
2
|
2
|
||||||
3
|
3
|
||||||
5
|
5
|
||||||
|
5
|
||||||
|
1
|
||||||
|
2
|
||||||
|
3
|
||||||
|
4
|
||||||
|
5
|
||||||
|
|
|
||||||
|
|
@ -27,4 +27,12 @@ case `a (1, 2, 3, 4, 5) of
|
||||||
| `a (_, _, _) -> write (3)
|
| `a (_, _, _) -> write (3)
|
||||||
| `a (_, _, _, _) -> write (4)
|
| `a (_, _, _, _) -> write (4)
|
||||||
| `a (_, _, _, _, _) -> write (5)
|
| `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}
|
| "[" ps:(!(Util.list0)[parse]) "]" {Array ps}
|
||||||
| x:IDENT y:(-"@" parse)? {match y with None -> Named (x, Wildcard) | Some y -> Named (x, y)}
|
| x:IDENT y:(-"@" parse)? {match y with None -> Named (x, Wildcard) | Some y -> Named (x, y)}
|
||||||
| c:DECIMAL {Const c}
|
| 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}
|
| "#" %"boxed" {Boxed}
|
||||||
| "#" %"unboxed" {UnBoxed}
|
| "#" %"unboxed" {UnBoxed}
|
||||||
| "#" %"string" {StringTag}
|
| "#" %"string" {StringTag}
|
||||||
|
|
@ -385,10 +386,20 @@ module Stmt =
|
||||||
| Some s -> Some (State.bind x v s)
|
| Some s -> Some (State.bind x v s)
|
||||||
in
|
in
|
||||||
match patt, v with
|
match patt, v with
|
||||||
| Pattern.Named (x, p), v -> update x v (match_patt p v st )
|
| Pattern.Named (x, p), v -> update x v (match_patt p v st )
|
||||||
| Pattern.Wildcard , _ -> st
|
| Pattern.Wildcard , _ -> st
|
||||||
| Pattern.Sexp (t, ps), Value.Sexp (t', vs) when t = t' -> match_list ps vs st
|
| Pattern.Sexp (t, ps), Value.Sexp (t', vs) when t = t' && List.length ps = List.length vs -> match_list ps vs st
|
||||||
| _ -> None
|
| 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 =
|
and match_list ps vs s =
|
||||||
match ps, vs with
|
match ps, vs with
|
||||||
| [], [] -> s
|
| [], [] -> s
|
||||||
|
|
|
||||||
76
src/SM.ml
76
src/SM.ml
|
|
@ -24,6 +24,8 @@ 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
|
||||||
|
|
@ -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'
|
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'
|
||||||
|
|
@ -138,36 +154,52 @@ let compile (defs, p) =
|
||||||
and pattern env lfalse = function
|
and pattern env lfalse = function
|
||||||
| Stmt.Pattern.Wildcard -> env, false, [DROP]
|
| Stmt.Pattern.Wildcard -> env, false, [DROP]
|
||||||
| Stmt.Pattern.Named (_, p) -> pattern env lfalse p
|
| 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) ->
|
| 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", ltag); LABEL ldrop; DROP; JMP lfalse; LABEL ltag] in
|
let tag = [DUP; TAG (t, List.length ps); CJMP ("nz", lhead); LABEL ldrop; DROP; JMP lfalse; LABEL lhead] in
|
||||||
let _, env, code =
|
let code, env = pattern_list lhead ldrop env ps in
|
||||||
List.fold_left
|
env, true, tag @ code @ [DROP]
|
||||||
(fun (i, env, code) p ->
|
and pattern_list lhead ldrop env ps =
|
||||||
let env, _, pcode = pattern env ldrop p in
|
let _, env, code =
|
||||||
i+1, env, ([DUP; CONST i; CALL (".elem", 2, false)] @ pcode) :: code
|
List.fold_left
|
||||||
)
|
(fun (i, env, code) p ->
|
||||||
(0, env, [])
|
let env, _, pcode = pattern env ldrop p in
|
||||||
ps
|
i+1, env, ([DUP; CONST i; CALL (".elem", 2, false)] @ pcode) :: code
|
||||||
in
|
)
|
||||||
env, true, tag @ List.flatten (List.rev code) @ [DROP]
|
(0, env, [])
|
||||||
|
ps
|
||||||
|
in
|
||||||
|
List.flatten (List.rev code), env
|
||||||
and bindings p =
|
and bindings p =
|
||||||
let bindings =
|
let bindings =
|
||||||
fix0 (fun fself ->
|
fix0 (fun fself ->
|
||||||
transform(Stmt.Pattern.t)
|
transform(Stmt.Pattern.t)
|
||||||
(object inherit [int list, (string * int list) list, _] @Stmt.Pattern.t
|
(object inherit [int list, (string * int list) list, _] @Stmt.Pattern.t
|
||||||
method c_Wildcard path = []
|
method c_Wildcard path = []
|
||||||
method c_Named path s p = [s, path] @ fself path p
|
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_Sexp path x ps = List.concat @@ List.mapi (fun i p -> fself (path @ [i]) p) ps
|
||||||
method c_UnBoxed = invalid_arg ""
|
method c_UnBoxed _ = []
|
||||||
method c_StringTag = invalid_arg ""
|
method c_StringTag _ = []
|
||||||
method c_String = invalid_arg ""
|
method c_String _ _ = []
|
||||||
method c_SexpTag = invalid_arg ""
|
method c_SexpTag _ = []
|
||||||
method c_Const = invalid_arg ""
|
method c_Const _ _ = []
|
||||||
method c_Boxed = invalid_arg ""
|
method c_Boxed _ = []
|
||||||
method c_ArrayTag = invalid_arg ""
|
method c_ArrayTag _ = []
|
||||||
method c_Array = invalid_arg ""
|
method c_Array path ps = List.concat @@ List.mapi (fun i p -> fself (path @ [i]) p) ps
|
||||||
end))
|
end))
|
||||||
[]
|
[]
|
||||||
p
|
p
|
||||||
|
|
|
||||||
19
src/X86.ml
19
src/X86.ml
|
|
@ -326,7 +326,24 @@ 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
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue