st/lama_byterun
1
0
Fork 0
mirror of https://github.com/ProgramSnail/Lama.git synced 2025-12-06 06:48:48 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

Fixed bug in sexp arity

Browse source
This commit is contained in:
Dmitry Boulytchev 2018-11-05 20:17:11 +03:00
parent 8a4874797b
commit cf045e0be5
6 changed files with 42 additions and 31 deletions
Download patch file Download diff file Expand all files Collapse all files

1
regression/orig/test046.log
View file

@ -4,3 +4,4 @@
1
2
3
5

11
regression/test046.expr
View file

@ -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

4
runtime/runtime.c
View file

@ -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, ...) {

2
src/Language.ml
View file

@ -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))

46
src/SM.ml
View file

@ -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 ->

9
src/X86.ml
View file

@ -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 =