From 4d54809acb6b11bd4acd71a1b3ac2176e90ea458 Mon Sep 17 00:00:00 2001 From: danyaberezun Date: Mon, 12 Nov 2018 16:33:44 +0300 Subject: [PATCH] merge --- regression/Makefile | 6 +-- regression/orig/test046.log | 6 +++ regression/test046.expr | 10 ++++- src/Language.ml | 21 +++++++--- src/SM.ml | 76 ++++++++++++++++++++++++++----------- src/X86.ml | 19 +++++++++- 6 files changed, 106 insertions(+), 32 deletions(-) diff --git a/regression/Makefile b/regression/Makefile index 7d1cce545..0fc4b3f96 100644 --- a/regression/Makefile +++ b/regression/Makefile @@ -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) diff --git a/regression/orig/test046.log b/regression/orig/test046.log index dae76f132..f33ba2d92 100644 --- a/regression/orig/test046.log +++ b/regression/orig/test046.log @@ -5,3 +5,9 @@ 2 3 5 +5 +1 +2 +3 +4 +5 diff --git a/regression/test046.expr b/regression/test046.expr index b8fad763b..9a0a8d106 100644 --- a/regression/test046.expr +++ b/regression/test046.expr @@ -27,4 +27,12 @@ case `a (1, 2, 3, 4, 5) of | `a (_, _, _) -> write (3) | `a (_, _, _, _) -> write (4) | `a (_, _, _, _, _) -> write (5) -esac \ No newline at end of file +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]) diff --git a/src/Language.ml b/src/Language.ml index 10a7a366a..33a0fd4ed 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -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 diff --git a/src/SM.ml b/src/SM.ml index 32e1fca7e..118548281 100644 --- a/src/SM.ml +++ b/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 diff --git a/src/X86.ml b/src/X86.ml index 176ab218c..dd69089f7 100644 --- a/src/X86.ml +++ b/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