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 ecb6b3328..a44eea4e3 100644 --- a/runtime/runtime.c +++ b/runtime/runtime.c @@ -218,9 +218,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 =