From 8a4874797bf7401cf086c4025bf19b1baf0f34bb Mon Sep 17 00:00:00 2001 From: Dmitry Boulytchev Date: Mon, 5 Nov 2018 18:21:41 +0300 Subject: [PATCH 1/4] 'as' pattern --- regression/Makefile | 6 ++-- regression/orig/test046.log | 6 ++++ regression/test046.expr | 21 ++++++++++++++ regression/test046.input | 1 + src/Driver.ml | 3 +- src/Language.ml | 24 +++++++++++++--- src/SM.ml | 56 ++++++++++++++++++++++--------------- src/X86.ml | 3 +- 8 files changed, 89 insertions(+), 31 deletions(-) create mode 100644 regression/orig/test046.log create mode 100644 regression/test046.expr create mode 100644 regression/test046.input diff --git a/regression/Makefile b/regression/Makefile index 0fc4b3f96..7d1cce545 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 new file mode 100644 index 000000000..5c1aac067 --- /dev/null +++ b/regression/orig/test046.log @@ -0,0 +1,6 @@ +> 3 +3 +3 +1 +2 +3 diff --git a/regression/test046.expr b/regression/test046.expr new file mode 100644 index 000000000..a3922863f --- /dev/null +++ b/regression/test046.expr @@ -0,0 +1,21 @@ +n := read (); + +case 3 of + a -> write (a) +| _ -> write (0) +esac; + +case 3 of + a -> write (a) +esac; + +case 3 of + a@_ -> write (a) +esac; + +case `a (1, 2, 3) of + `b -> write (1) +| a@`a (_, _, _) -> case a of + `a (x, y, z) -> write (x); write (y); write (z) + esac +esac \ No newline at end of file diff --git a/regression/test046.input b/regression/test046.input new file mode 100644 index 000000000..573541ac9 --- /dev/null +++ b/regression/test046.input @@ -0,0 +1 @@ +0 diff --git a/src/Driver.ml b/src/Driver.ml index 773d96daa..2239a6693 100644 --- a/src/Driver.ml +++ b/src/Driver.ml @@ -16,7 +16,8 @@ let parse infile = "fun"; "local"; "return"; "length"; "string"; - "case"; "of"; "esac"; "when"] s + "case"; "of"; "esac"; "when"; + "boxed"; "unboxed"; "string"; "sexp"; "array"] s inherit Util.Lexers.skip [ Matcher.Skip.whitespaces " \t\n"; Matcher.Skip.lineComment "--"; diff --git a/src/Language.ml b/src/Language.ml index ef947a5aa..52bcc6d68 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -293,7 +293,15 @@ module Stmt = @type t = (* wildcard "-" *) | Wildcard (* S-expression *) | Sexp of string * t list - (* identifier *) | Ident of string + (* array *) | Array of t list + (* identifier *) | Named of string * t + (* ground integer *) | Const of int + (* ground string *) | String of string + (* boxed value *) | Boxed + (* unboxed value *) | UnBoxed + (* any string value *) | StringTag + (* any sexp value *) | SexpTag + (* any array value *) | ArrayTag with show, foldl (* Pattern parser *) @@ -301,11 +309,19 @@ module Stmt = parse: %"_" {Wildcard} | "`" t:IDENT ps:(-"(" !(Util.list)[parse] -")")? {Sexp (t, match ps with None -> [] | Some ps -> ps)} - | x:IDENT {Ident x} + | "[" 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} + | "#" %"boxed" {Boxed} + | "#" %"unboxed" {UnBoxed} + | "#" %"string" {StringTag} + | "#" %"sexp" {SexpTag} + | "#" %"array" {ArrayTag} ) let vars p = fix0 (fun f -> - transform(t) (object inherit [string list, _] @t[foldl] f method c_Ident s name = name::s end)) [] p + transform(t) (object inherit [string list, _] @t[foldl] f method c_Named s name p = name :: f s p end)) [] p end @@ -371,7 +387,7 @@ module Stmt = | Some s -> Some (State.bind x v s) in match patt, v with - | Pattern.Ident x , v -> update x v st + | 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 diff --git a/src/SM.ml b/src/SM.ml index 62c394a35..67bb418e7 100644 --- a/src/SM.ml +++ b/src/SM.ml @@ -136,7 +136,7 @@ let compile (defs, p) = args_code @ [CALL (label f, List.length args, p)] and pattern env lfalse = function | Stmt.Pattern.Wildcard -> env, false, [DROP] - | Stmt.Pattern.Ident n -> env, false, [DROP] + | Stmt.Pattern.Named (_, p) -> pattern env lfalse p | Stmt.Pattern.Sexp (t, ps) -> let ltag , env = env#get_label in let ldrop, env = env#get_label in @@ -157,8 +157,16 @@ let compile (defs, p) = transform(Stmt.Pattern.t) (object inherit [int list, (string * int list) list, _] @Stmt.Pattern.t method c_Wildcard path = [] - method c_Ident path s = [s, 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 "" end)) [] p @@ -216,30 +224,34 @@ let compile (defs, p) = | Stmt.Leave -> env, false, [LEAVE] - | Stmt.Case (e, [p, s]) -> - let ldrop, env = env#get_label in - let env, _, pcode = pattern env ldrop p in - let env, _, scode = compile_stmt ldrop env (Stmt.Seq (s, Stmt.Leave)) in - env, true, expr e @ [DUP] @ pcode @ bindings p @ scode @ [JMP l; LABEL ldrop; DROP] + | Stmt.Case (e, [p, s]) -> + let ldrop, env = env#get_label in + let env, ldrop' , pcode = pattern env ldrop p in + let env, ldrop'', scode = compile_stmt ldrop env (Stmt.Seq (s, Stmt.Leave)) in + if ldrop' || ldrop'' + then env, true , expr e @ [DUP] @ pcode @ bindings p @ scode @ [JMP l; LABEL ldrop; DROP] + else env, false, expr e @ [DUP] @ pcode @ bindings p @ scode - | Stmt.Case (e, brs) -> - let n = List.length brs - 1 in - (*let ldrop, env = env#get_label in*) - let env, _, _, code = + | Stmt.Case (e, brs) -> + let n = List.length brs - 1 in + let env, _, _, code, _ = List.fold_left - (fun (env, lab, i, code) (p, s) -> - let (lfalse, env), jmp = - if i = n - then (l, env), [] - else env#get_label, [JMP l] - in - let env, _, pcode = pattern env lfalse p in - let env, _, scode = compile_stmt l(*ldrop*) env (Stmt.Seq (s, Stmt.Leave)) in - (env, Some lfalse, i+1, ((match lab with None -> [] | Some l -> [LABEL l; DUP]) @ pcode @ bindings p @ scode @ jmp) :: code) + (fun ((env, lab, i, code, continue) as acc) (p, s) -> + if continue + then + let (lfalse, env), jmp = + if i = n + then (l, env), [] + else env#get_label, [JMP l] + in + let env, lfalse', pcode = pattern env lfalse p in + let env, l' , scode = compile_stmt l env (Stmt.Seq (s, Stmt.Leave)) in + (env, Some lfalse, i+1, ((match lab with None -> [] | Some l -> [LABEL l; DUP]) @ pcode @ bindings p @ scode @ jmp) :: code, lfalse') + else acc ) - (env, None, 0, []) brs + (env, None, 0, [], true) brs in - env, true, expr e @ [DUP] @ (List.flatten @@ List.rev code) @ [JMP l] (*; LABEL ldrop; DROP]*) + env, true, expr e @ [DUP] @ (List.flatten @@ List.rev code) @ [JMP l] in let compile_def env (name, (args, locals, stmt)) = let lend, env = env#get_label in diff --git a/src/X86.ml b/src/X86.ml index 24b019271..70b89c476 100644 --- a/src/X86.ml +++ b/src/X86.ml @@ -310,7 +310,8 @@ let compile env code = let env, code = call env ".sexp" (n+1) false in env, [Mov (L env#hash t, s)] @ code - | DROP -> snd env#pop, [] + | DROP -> + snd env#pop, [] | DUP -> let x = env#peek in From cf045e0be5680073d8631517c482be72a9587e6d Mon Sep 17 00:00:00 2001 From: Dmitry Boulytchev Date: Mon, 5 Nov 2018 20:17:11 +0300 Subject: [PATCH 2/4] Fixed bug in sexp arity --- regression/orig/test046.log | 1 + regression/test046.expr | 11 ++++++++- runtime/runtime.c | 4 ++-- src/Language.ml | 2 +- src/SM.ml | 46 ++++++++++++++++++------------------- src/X86.ml | 9 ++++---- 6 files changed, 42 insertions(+), 31 deletions(-) diff --git a/regression/orig/test046.log b/regression/orig/test046.log index 5c1aac067..dae76f132 100644 --- a/regression/orig/test046.log +++ b/regression/orig/test046.log @@ -4,3 +4,4 @@ 1 2 3 +5 diff --git a/regression/test046.expr b/regression/test046.expr index a3922863f..b8fad763b 100644 --- a/regression/test046.expr +++ b/regression/test046.expr @@ -14,8 +14,17 @@ case 3 of esac; case `a (1, 2, 3) of - `b -> write (1) + `a -> write (1) | a@`a (_, _, _) -> case a of `a (x, y, z) -> write (x); write (y); write (z) 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 \ No newline at end of file diff --git a/runtime/runtime.c b/runtime/runtime.c index c4677c97f..9ca15c8d4 100644 --- a/runtime/runtime.c +++ b/runtime/runtime.c @@ -217,9 +217,9 @@ extern void* Bsexp (int n, ...) { return d->contents; } -extern int Btag (void *d, int t) { +extern int Btag (void *d, int t, int n) { data *r = TO_DATA(d); - return BOX(TAG(r->tag) == SEXP_TAG && TO_SEXP(d)->tag == t); + return BOX(TAG(r->tag) == SEXP_TAG && TO_SEXP(d)->tag == t && LEN(r->tag) == n); } extern void Bsta (int n, int v, void *s, ...) { diff --git a/src/Language.ml b/src/Language.ml index 52bcc6d68..ce346c4c1 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -130,7 +130,7 @@ module Builtin = | Value.Sexp (_, a) -> List.nth a i ) ) - | ".length" -> (st, i, o, Some (Value.of_int (match List.hd args with Value.Array a -> List.length a | Value.String s -> String.length s))) + | ".length" -> (st, i, o, Some (Value.of_int (match List.hd args with Value.Sexp (_, a) | Value.Array a -> List.length a | Value.String s -> String.length s))) | ".array" -> (st, i, o, Some (Value.of_array args)) | ".stringval" -> let [a] = args in (st, i, o, Some (Value.of_string @@ Value.string_val a)) | "isArray" -> let [a] = args in (st, i, o, Some (Value.of_int @@ match a with Value.Array _ -> 1 | _ -> 0)) diff --git a/src/SM.ml b/src/SM.ml index 67bb418e7..39f701fac 100644 --- a/src/SM.ml +++ b/src/SM.ml @@ -3,26 +3,26 @@ open Language (* The type for the stack machine instructions *) @type insn = -(* binary operator *) | BINOP of string -(* put a constant on the stack *) | CONST of int -(* put a string on the stack *) | STRING of string -(* create an S-expression *) | SEXP of string * int -(* load a variable to the stack *) | LD of string -(* store a variable from the stack *) | ST of string -(* store in an array *) | STA of string * int -(* a label *) | LABEL of string -(* unconditional jump *) | JMP of string -(* conditional jump *) | CJMP of string * string -(* begins procedure definition *) | BEGIN of string * string list * string list -(* end procedure definition *) | END -(* calls a function/procedure *) | CALL of string * int * bool -(* returns from a function *) | RET of bool -(* drops the top element off *) | DROP -(* duplicates the top element *) | DUP -(* swaps two top elements *) | SWAP -(* checks the tag of S-expression *) | TAG of string -(* enters a scope *) | ENTER of string list -(* leaves a scope *) | LEAVE +(* binary operator *) | BINOP of string +(* put a constant on the stack *) | CONST of int +(* put a string on the stack *) | STRING of string +(* create an S-expression *) | SEXP of string * int +(* load a variable to the stack *) | LD of string +(* store a variable from the stack *) | ST of string +(* store in an array *) | STA of string * int +(* a label *) | LABEL of string +(* unconditional jump *) | JMP of string +(* conditional jump *) | CJMP of string * string +(* begins procedure definition *) | BEGIN of string * string list * string list +(* end procedure definition *) | END +(* calls a function/procedure *) | CALL of string * int * bool +(* returns from a function *) | RET of bool +(* drops the top element off *) | DROP +(* duplicates the top element *) | DUP +(* swaps two top elements *) | SWAP +(* checks the tag and arity of S-expression *) | TAG of string * int +(* enters a scope *) | ENTER of string list +(* leaves a scope *) | LEAVE with show (* The type for the stack machine program *) @@ -79,8 +79,8 @@ let rec eval env ((cstack, stack, ((st, i, o) as c)) as conf) = function | DUP -> eval env (cstack, List.hd stack :: stack, c) prg' | SWAP -> let x::y::stack' = stack in eval env (cstack, y::x::stack', c) prg' - | TAG t -> let x::stack' = stack in - eval env (cstack, (Value.of_int @@ match x with Value.Sexp (t', _) when t' = t -> 1 | _ -> 0) :: 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' | 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' @@ -140,7 +140,7 @@ let compile (defs, p) = | Stmt.Pattern.Sexp (t, ps) -> let ltag , env = env#get_label in let ldrop, env = env#get_label in - let tag = [DUP; TAG t; CJMP ("nz", ltag); LABEL ldrop; DROP; JMP lfalse; LABEL ltag] 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 -> diff --git a/src/X86.ml b/src/X86.ml index 70b89c476..b51ccad38 100644 --- a/src/X86.ml +++ b/src/X86.ml @@ -322,10 +322,11 @@ let compile env code = let x, y = env#peek2 in env, [Push x; Push y; Pop x; Pop y] - | TAG t -> - let s, env = env#allocate in - let env, code = call env ".tag" 2 false in - env, [Mov (L env#hash t, s)] @ code + | TAG (t, n) -> + 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 | ENTER xs -> let env, code = From d0a32802e3af4784d3b03de42add87fd85133e18 Mon Sep 17 00:00:00 2001 From: Dmitry Boulytchev Date: Tue, 6 Nov 2018 00:21:38 +0300 Subject: [PATCH 3/4] Extended pattern-matching --- regression/Makefile | 6 +-- regression/orig/test046.log | 6 +++ regression/orig/test047.log | 17 +++++++ regression/test046.expr | 10 +++- regression/test047.expr | 72 +++++++++++++++++++++++++++++ regression/test047.input | 1 + runtime/runtime.c | 47 ++++++++++++++++++- src/Language.ml | 27 +++++++---- src/SM.ml | 91 +++++++++++++++++++++++++------------ src/X86.ml | 21 ++++++++- 10 files changed, 253 insertions(+), 45 deletions(-) create mode 100644 regression/orig/test047.log create mode 100644 regression/test047.expr create mode 100644 regression/test047.input 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/orig/test047.log b/regression/orig/test047.log new file mode 100644 index 000000000..b98c3e4e7 --- /dev/null +++ b/regression/orig/test047.log @@ -0,0 +1,17 @@ +> 1 +1 +1 +1 +1 +2 +3 +100 +3 +2 +1 +6 +5 +4 +3 +2 +1 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/regression/test047.expr b/regression/test047.expr new file mode 100644 index 000000000..37516ac0b --- /dev/null +++ b/regression/test047.expr @@ -0,0 +1,72 @@ +fun collect_ints_acc (v, tail) local i { + case v of + a@#unboxed -> return `cons (a, tail) + | #string -> return tail + | _ -> + for i := 0, i < v.length, i := i + 1 do + tail := collect_ints_acc (v[i], tail) + od; + return tail + esac +} + +fun collect_ints (v) { + return collect_ints_acc (v, `nil) +} + +fun print_list (l) { + case l of + `nil -> skip + | `cons (n, t) -> write (n); print_list (t) + esac +} + +n := read (); + +case 1 of + 5 -> write (5) +| 4 -> write (4) +| 3 -> write (3) +| 2 -> write (2) +| 1 -> write (1) +| 0 -> write (0) +esac; + +case 1 of + a@5 -> write (a) +| a@4 -> write (a) +| a@3 -> write (a) +| a@2 -> write (a) +| a@1 -> write (a) +| a@0 -> write (a) +esac; + +case `a (1, 2, 3) of + `a (1, 3, 5) -> write (0) +| `a (3, 4, 5) -> write (0) +| `a (1, 2, 3) -> write (1) +| `a (6, 7, 8) -> write (0) +esac; + +case "abc" of + "def" -> write (0) +| "ab" -> write (0) +| "abc" -> write (1) +| "" -> write (0) +esac; + +case [1, 2, 3] of + [] -> write (0) +| [a, b] -> write (0) +| [a, b, c] -> write (a); write (b); write (c) +| [_, _, _] -> write (0) +esac; + +case [1, 2, 3] of + [] -> write (0) +| [a, b] -> write (0) +| [_, _, _] -> write (100) +| [a, b, c] -> write (a); write (b); write (c) +esac; + +print_list (collect_ints ([1, 2, 3, [4, 5, 6, `cons (1, 2, 3)]])) diff --git a/regression/test047.input b/regression/test047.input new file mode 100644 index 000000000..573541ac9 --- /dev/null +++ b/regression/test047.input @@ -0,0 +1 @@ +0 diff --git a/runtime/runtime.c b/runtime/runtime.c index 9ca15c8d4..8e2591ec3 100644 --- a/runtime/runtime.c +++ b/runtime/runtime.c @@ -221,7 +221,52 @@ extern int Btag (void *d, int t, int n) { data *r = TO_DATA(d); return BOX(TAG(r->tag) == SEXP_TAG && TO_SEXP(d)->tag == t && LEN(r->tag) == n); } - + +extern int Barray_patt (void *d, int n) { + if (UNBOXED(d)) return BOX(0); + else { + data *r = TO_DATA(d); + return BOX(TAG(r->tag) == ARRAY_TAG && LEN(r->tag) == n); + } +} + +extern int Bstring_patt (void *x, void *y) { + if (UNBOXED(x)) return BOX(0); + else { + data *rx = TO_DATA(x), *ry = TO_DATA(y); + + if (TAG(rx->tag) != STRING_TAG) return BOX(0); + + return BOX(strcmp (rx->contents, ry->contents) == 0 ? 1 : 0); + } +} + +extern int Bboxed_patt (void *x) { + return BOX(UNBOXED(x) ? 0 : 1); +} + +extern int Bunboxed_patt (void *x) { + return BOX(UNBOXED(x) ? 1 : 0); +} + +extern int Barray_tag_patt (void *x) { + if (UNBOXED(x)) return BOX(0); + + return BOX(TAG(TO_DATA(x)->tag) == ARRAY_TAG); +} + +extern int Bstring_tag_patt (void *x) { + if (UNBOXED(x)) return BOX(0); + + return BOX(TAG(TO_DATA(x)->tag) == STRING_TAG); +} + +extern int Bsexp_tag_patt (void *x) { + if (UNBOXED(x)) return BOX(0); + + return BOX(TAG(TO_DATA(x)->tag) == SEXP_TAG); +} + extern void Bsta (int n, int v, void *s, ...) { va_list args; int i, k; diff --git a/src/Language.ml b/src/Language.ml index ce346c4c1..33a0fd4ed 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -132,10 +132,8 @@ module Builtin = ) | ".length" -> (st, i, o, Some (Value.of_int (match List.hd args with Value.Sexp (_, a) | Value.Array a -> List.length a | Value.String s -> String.length s))) | ".array" -> (st, i, o, Some (Value.of_array args)) - | ".stringval" -> let [a] = args in (st, i, o, Some (Value.of_string @@ Value.string_val a)) - | "isArray" -> let [a] = args in (st, i, o, Some (Value.of_int @@ match a with Value.Array _ -> 1 | _ -> 0)) - | "isString" -> let [a] = args in (st, i, o, Some (Value.of_int @@ match a with Value.String _ -> 1 | _ -> 0)) - + | ".stringval" -> let [a] = args in (st, i, o, Some (Value.of_string @@ Value.string_val a)) + end (* Simple expressions: syntax and semantics *) @@ -312,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} @@ -387,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 39f701fac..118548281 100644 --- a/src/SM.ml +++ b/src/SM.ml @@ -1,6 +1,9 @@ open GT open Language - + +(* The type for patters *) +@type patt = StrCmp | String | Array | Sexp | Boxed | UnBoxed with show + (* The type for the stack machine instructions *) @type insn = (* binary operator *) | BINOP of string @@ -21,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 @@ -28,7 +33,7 @@ with show (* The type for the stack machine program *) type prg = insn list -let print_prg p = List.iter (fun i -> Printf.printf "%s\n" (show(insn) i)) p +let print_prg p = List.iter (fun i -> Printf.printf "%s\n\!" (show(insn) i)) p (* The type for the stack machine configuration: control stack, stack and configuration from statement interpreter @@ -81,10 +86,22 @@ 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' ) @@ -95,7 +112,7 @@ let rec eval env ((cstack, stack, ((st, i, o) as c)) as conf) = function Takes a program, an input stream, and returns an output stream this program calculates *) let run p i = - (*print_prg p;*) + (* print_prg p; *) let module M = Map.Make (String) in let rec make_map m = function | [] -> m @@ -137,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.Sexp (t, ps) -> - let ltag , env = env#get_label in + | 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; 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; 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", 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 b51ccad38..27f6833d4 100644 --- a/src/X86.ml +++ b/src/X86.ml @@ -326,8 +326,25 @@ 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 From 89f72bdcac5182ed601ab986751f06db1f81485b Mon Sep 17 00:00:00 2001 From: Dmitry Boulytchev Date: Tue, 6 Nov 2018 14:03:55 +0300 Subject: [PATCH 4/4] Added test to x86only --- regression/x86only/orig/test002.log | 9 +++++ regression/x86only/test002.expr | 63 +++++++++++++++++++++++++++++ regression/x86only/test002.input | 1 + 3 files changed, 73 insertions(+) create mode 100644 regression/x86only/orig/test002.log create mode 100644 regression/x86only/test002.expr create mode 100644 regression/x86only/test002.input diff --git a/regression/x86only/orig/test002.log b/regression/x86only/orig/test002.log new file mode 100644 index 000000000..047d48e6c --- /dev/null +++ b/regression/x86only/orig/test002.log @@ -0,0 +1,9 @@ +1 +1 +1 +1 +1 +2 +3 +100 +`cons (3, `cons (2, `cons (1, `cons (6, `cons (5, `cons (4, `cons (3, `cons (2, `cons (1, `nil))))))))) diff --git a/regression/x86only/test002.expr b/regression/x86only/test002.expr new file mode 100644 index 000000000..37616d334 --- /dev/null +++ b/regression/x86only/test002.expr @@ -0,0 +1,63 @@ +fun collect_ints_acc (v, tail) local i { + case v of + a@#unboxed -> return `cons (a, tail) + | #string -> return tail + | _ -> + for i := 0, i < v.length, i := i + 1 do + tail := collect_ints_acc (v[i], tail) + od; + return tail + esac +} + +fun collect_ints (v) { + return collect_ints_acc (v, `nil) +} + +case 1 of + 5 -> write (5) +| 4 -> write (4) +| 3 -> write (3) +| 2 -> write (2) +| 1 -> write (1) +| 0 -> write (0) +esac; + +case 1 of + a@5 -> write (a) +| a@4 -> write (a) +| a@3 -> write (a) +| a@2 -> write (a) +| a@1 -> write (a) +| a@0 -> write (a) +esac; + +case `a (1, 2, 3) of + `a (1, 3, 5) -> write (0) +| `a (3, 4, 5) -> write (0) +| `a (1, 2, 3) -> write (1) +| `a (6, 7, 8) -> write (0) +esac; + +case "abc" of + "def" -> write (0) +| "ab" -> write (0) +| "abc" -> write (1) +| "" -> write (0) +esac; + +case [1, 2, 3] of + [] -> write (0) +| [a, b] -> write (0) +| [a, b, c] -> write (a); write (b); write (c) +| [_, _, _] -> write (0) +esac; + +case [1, 2, 3] of + [] -> write (0) +| [a, b] -> write (0) +| [_, _, _] -> write (100) +| [a, b, c] -> write (a); write (b); write (c) +esac; + +printf ("%s\n", collect_ints ([1, 2, 3, [4, 5, 6, `cons (1, 2, 3)]]).string) diff --git a/regression/x86only/test002.input b/regression/x86only/test002.input new file mode 100644 index 000000000..573541ac9 --- /dev/null +++ b/regression/x86only/test002.input @@ -0,0 +1 @@ +0