st/lama_byterun
1
0
Fork 0
mirror of https://github.com/ProgramSnail/Lama.git synced 2025-12-24 15:48:47 +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 • committed by danyabeerzun
parent dc38319a13
commit 99fdd176f4
6 changed files with 42 additions and 31 deletions
Download patch file Download diff file Expand all files Collapse all files

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