diff --git a/regression/test013.expr b/regression/test013.expr index 3802f1937..560ef085d 100644 --- a/regression/test013.expr +++ b/regression/test013.expr @@ -13,4 +13,4 @@ elif n == 4 then write (3) n := n - 1 -until n == 0 \ No newline at end of file +until (n == 0) \ No newline at end of file diff --git a/regression/test016.expr b/regression/test016.expr index fac4314fc..1cd2b9ed1 100644 --- a/regression/test016.expr +++ b/regression/test016.expr @@ -7,6 +7,6 @@ repeat s := s * n; n := n - 1 -until n == 0; +until (n == 0); write (s) \ No newline at end of file diff --git a/regression/test023.expr b/regression/test023.expr index 87efc01ff..a616f2b4b 100644 --- a/regression/test023.expr +++ b/regression/test023.expr @@ -3,6 +3,6 @@ s := 0; repeat n := read (); s := s + n -until n == 0; +until (n == 0); write (s) diff --git a/regression/test030.expr b/regression/test030.expr index d0d764743..5c4b90314 100644 --- a/regression/test030.expr +++ b/regression/test030.expr @@ -2,7 +2,7 @@ fun fib (n) { if n <= 1 then return 1 else - return fib (n-1) + fib (n-2) + return (fib (n-1) + fib (n-2)) fi } diff --git a/regression/test031.expr b/regression/test031.expr index a5bd16218..14d166a16 100644 --- a/regression/test031.expr +++ b/regression/test031.expr @@ -2,7 +2,7 @@ fun fact (n) { if n <= 1 then return 1 else - return n * fact (n-1) + return (n * fact (n-1)) fi } diff --git a/regression/test032.expr b/regression/test032.expr index 809d7f182..cb19d72d7 100644 --- a/regression/test032.expr +++ b/regression/test032.expr @@ -1,5 +1,5 @@ fun ack (m, n) { - if m == 0 then return n+1 + if m == 0 then return (n+1) elif m > 0 && n == 0 then return ack (m-1, 1) else return ack (m-1, ack (m, n-1)) fi diff --git a/regression/test043.expr b/regression/test043.expr index fa1031048..996cb062a 100644 --- a/regression/test043.expr +++ b/regression/test043.expr @@ -1,7 +1,7 @@ fun sum (x) { case x of Nil -> return 0 - | Cons (x, tl) -> return x + sum (tl) + | Cons (x, tl) -> return (x + sum (tl)) esac } diff --git a/regression/test047.expr b/regression/test047.expr index 5a1f15c23..46b2a39d7 100644 --- a/regression/test047.expr +++ b/regression/test047.expr @@ -69,4 +69,4 @@ case [1, 2, 3] of | [a, b, c] -> write (a); write (b); write (c) esac; -print_list (collect_ints ([1, 2, 3, [4, 5, 6, Cons (1, 2, 3)]])) +print_list (collect_ints ([1, 2, 3, [4, 5, 6, Cons (1, 2, 3)]])) diff --git a/regression/test049.expr b/regression/test049.expr index f3e6d32a6..5d326d547 100644 --- a/regression/test049.expr +++ b/regression/test049.expr @@ -11,9 +11,10 @@ fun test (n, m) local i, s { n := read (); y := ((((((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))))) + (((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))))) + ((((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))))) + (((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))))))) + (((((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))))) + (((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))))) + ((((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))))) + (((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + test(10, 100))))))))); -t := test(10, 100); +t := test (10, 100); y2 := ((((((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))))) + (((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))))) + ((((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))))) + (((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))))))) + (((((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))))) + (((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))))) + ((((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))))) + (((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + t)))))))); write (t); write (y2); -write (y) \ No newline at end of file +write (y) + diff --git a/regression/test053.expr b/regression/test053.expr index bddc09507..2a9439106 100644 --- a/regression/test053.expr +++ b/regression/test053.expr @@ -16,14 +16,14 @@ infix "===" at "==" (v1, v2) local s1, s2, i { infix "?" before "+" (v, l) { case l of {} -> return 0 - | h : tl -> if h === v then return 1 else return v ? tl fi + | h : tl -> if h === v then return 1 else return (v ? tl) fi esac } infix "+++" at "+" (l1, l2) { case l1 of {} -> return l2 - | h : tl -> return h : tl +++ l2 + | h : tl -> return (h : tl +++ l2) esac } @@ -35,5 +35,3 @@ write (1+2 ? {1, 2, 3}); write (1*3+2 ? {1, 2, 3}); write (1*3+2 ? {1, 2, 5}); write (8*4 ? {1, 2, 3} +++ {5, 7, 32, 6}) - - diff --git a/runtime/runtime.c b/runtime/runtime.c index f69a043c1..51225c4c4 100644 --- a/runtime/runtime.c +++ b/runtime/runtime.c @@ -339,7 +339,7 @@ extern int Bsexp_tag_patt (void *x) { return BOX(TAG(TO_DATA(x)->tag) == SEXP_TAG); } - +/* extern void Bsta (int n, int v, void *s, ...) { va_list args = (va_list) BOX (NULL); int i = 0, k = 0; @@ -358,6 +358,11 @@ extern void Bsta (int n, int v, void *s, ...) { if (TAG(a->tag) == STRING_TAG)((char*) s)[k] = (char) UNBOX(v); else ((int*) s)[k] = v; } +*/ +extern void Bsta (void *v, int i, void *x) { + if (TAG(TO_DATA(x)->tag) == STRING_TAG)((char*) x)[UNBOX(i)] = (char) UNBOX(v); + else ((int*) x)[UNBOX(i)] = v; +} extern int Lraw (int x) { return UNBOX(x); diff --git a/src/Language.ml b/src/Language.ml index 676a922fc..ab9f54873 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -153,7 +153,7 @@ module Builtin = let eval (st, i, o, vs) args = function | "read" -> (match i with z::i' -> (st, i', o, (Value.of_int z)::vs) | _ -> failwith "Unexpected end of input") - | "write" -> (st, i, o @ [Value.to_int @@ List.hd args], (*Value.Empty ::*) vs) + | "write" -> (st, i, o @ [Value.to_int @@ List.hd args], Value.Empty :: vs) | ".elem" -> let [b; j] = args in (st, i, o, let i = Value.to_int j in (match b with @@ -254,6 +254,8 @@ module Expr = (* loop with a post-condition *) | Repeat of t * t (* pattern-matching *) | Case of t * (Pattern.t * t) list (* return statement *) | Return of t option + (* ignore a value *) | Ignore of t + (* unit value *) | Unit (* leave a scope *) | Leave (* intrinsic (for evaluation) *) | Intrinsic of (config -> config) (* control (for control flow) *) | Control of (config -> t * config) @@ -316,6 +318,8 @@ module Expr = let rec eval env ((st, i, o, vs) as conf) k expr = match expr with + | Unit -> eval env (st, i, o, Value.Empty :: vs) Skip k + | Ignore s -> eval env conf k (schedule_list [s; Intrinsic (fun (st, i, o, vs) -> (st, i, o, List.tl vs))]) | Control f -> let s, conf' = f conf in eval env conf' k s @@ -348,7 +352,7 @@ module Expr = env#definition env f (List.rev es) (st, i, o, vs'))])) | Leave -> eval env (State.drop st, i, o, vs) Skip k | Assign (x, e) -> - eval env conf k (schedule_list [x; e; Intrinsic (fun (st, i, o, v::x::vs) -> (update st x v, i, o, vs))]) + eval env conf k (schedule_list [x; e; Intrinsic (fun (st, i, o, v::x::vs) -> (update st x v, i, o, v::vs))]) | Seq (s1, s2) -> eval env conf (seq s2 k) s1 | Skip -> @@ -411,7 +415,39 @@ module Expr = | If (e, t1, t2) -> If (e, propagate_ref t1, propagate_ref t2) | Case (e, bs) -> Case (e, List.map (fun (p, e) -> p, propagate_ref e) bs) | _ -> raise (Semantic_error "not a destination") - + + (* Balance values *) + let rec balance_value = function + | Array es -> Array (List.map balance_value es) + | Sexp (s, es) -> Sexp (s, List.map balance_value es) + | Binop (o, l, r) -> Binop (o, balance_value l, balance_value r) + | Elem (b, i) -> Elem (balance_value b, balance_value i) + | ElemRef (b, i) -> ElemRef (balance_value b, balance_value i) + | Length x -> Length (balance_value x) + | StringVal x -> StringVal (balance_value x) + | Call (f, es) -> Call (balance_value f, List.map balance_value es) + | Assign (d, s) -> Assign (balance_value d, balance_value s) + | Seq (l, r) -> Seq (balance_void l, balance_value r) + | If (c, t, e) -> If (balance_value c, balance_value t, balance_value e) + | Case (e, ps) -> Case (balance_value e, List.map (fun (p, e) -> p, balance_value e) ps) + + | Return _ + | While _ + | Repeat _ + | Skip -> raise (Semantic_error "missing value") + + | e -> e + and balance_void = function + | If (c, t, e) -> If (balance_value c, balance_void t, balance_void e) + | Seq (l, r) -> Seq (balance_void l, balance_void r) + | Case (e, ps) -> Case (balance_value e, List.map (fun (p, e) -> p, balance_void e) ps) + | While (e, s) -> While (balance_value e, balance_void s) + | Repeat (s, e) -> Repeat (balance_void s, balance_value e) + | Return (Some e) -> Return (Some (balance_value e)) + | Return None -> Return None + | Skip -> Skip + | e -> Ignore (balance_value e) + ostap ( parse[infix]: h:basic[infix] t:(-";" parse[infix])? {match t with None -> h | Some t -> Seq (h, t)}; basic[infix]: @@ -588,7 +624,7 @@ module Definition = <(name, infix')> : head[infix] "(" args:!(Util.list0 arg) ")" locs:(%"local" !(Util.list arg))? "{" body:!(Expr.parse infix') "}" { - (name, (args, (match locs with None -> [] | Some l -> l), body)), infix' + (name, (args, (match locs with None -> [] | Some l -> l), Expr.balance_void body)), infix' } ) @@ -616,7 +652,7 @@ let eval (defs, body) i = let xs, locs, s = snd @@ M.find f m in let st' = List.fold_left (fun st (x, a) -> State.update x a st) (State.enter st (xs @ locs)) (List.combine xs args) in let st'', i', o', vs' = Expr.eval env (st', i, o, []) Skip s in - (State.leave st'' st, i', o', match vs' with [v] -> v::vs | _ -> vs) + (State.leave st'' st, i', o', match vs' with [v] -> v::vs | _ -> Value.Empty :: vs) with Not_found -> Builtin.eval conf args f end) (State.empty, i, [], []) @@ -627,7 +663,7 @@ let eval (defs, body) i = (* Top-level parser *) ostap ( - parse[infix]: <(defs, infix')> : definitions[infix] body:!(Expr.parse infix') {defs, body}; + parse[infix]: <(defs, infix')> : definitions[infix] body:!(Expr.parse infix') {defs, Expr.balance_void body}; definitions[infix]: <(def, infix')> : !(Definition.parse infix) <(defs, infix'')> : definitions[infix'] {def::defs, infix''} | empty {[], infix} diff --git a/src/SM.ml b/src/SM.ml index b5f189480..4e9a68b3c 100644 --- a/src/SM.ml +++ b/src/SM.ml @@ -11,16 +11,16 @@ open Language (* 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 -(* load a variable address to the stack *) | LDA of string +(* load a variable address to the stack *) | LDA of string (* store a value into a reference *) | ST -(* store a value into array/sexp/string *) | STA +(* store a value into array/sexp/string *) | STA (* 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 -(* returns from a function *) | RET of bool +(* returns from a function *) | RET (* drops the top element off *) | DROP (* duplicates the top element *) | DUP (* swaps two top elements *) | SWAP @@ -67,8 +67,8 @@ let rec eval env ((cstack, stack, ((st, i, o) as c)) as conf) = function eval env (cstack, (Value.sexp s @@ List.rev vs)::stack', c) prg' | LD x -> eval env (cstack, State.eval st x :: stack, c) prg' | LDA x -> eval env (cstack, (Value.Var x) :: stack, c) prg' - | ST -> let z::r::stack' = stack in eval env (cstack, stack', (Expr.update st r z, i, o)) prg' - | STA -> let v::j::x::stack' = stack in eval env (cstack, stack', (Expr.update st (Value.Elem (x, Value.to_int j)) v, i, o)) prg' + | ST -> let z::r::stack' = stack in eval env (cstack, z::stack', (Expr.update st r z, i, o)) prg' + | STA -> let v::j::x::stack' = stack in eval env (cstack, v::stack', (Expr.update st (Value.Elem (x, Value.to_int j)) v, i, o)) prg' | LABEL _ -> eval env conf prg' | JMP l -> eval env conf (env#labeled l) | CJMP (c, l) -> let x::stack' = stack in eval env (cstack, stack', (st, i, o)) (if (c = "z" && Value.to_int x = 0) || (c = "nz" && Value.to_int x <> 0) then env#labeled l else prg') @@ -78,10 +78,16 @@ let rec eval env ((cstack, stack, ((st, i, o) as c)) as conf) = function | BEGIN (_, args, locals) -> let vs, stack' = split (List.length args) stack in let state = List.combine args @@ List.rev vs in eval env (cstack, stack', (List.fold_left (fun s (x, v) -> State.update x v s) (State.enter st (args @ locals)) state, i, o)) prg' - | END | RET _ -> (match cstack with + | END -> (match cstack with + | (prg', st')::cstack' -> eval env (cstack', Value.Empty :: stack, (State.leave st st', i, o)) prg' + | [] -> conf + ) + + | RET -> (match cstack with | (prg', st')::cstack' -> eval env (cstack', stack, (State.leave st st', i, o)) prg' | [] -> conf ) + | DROP -> eval env (cstack, List.tl stack, c) prg' | DUP -> eval env (cstack, List.hd stack :: stack, c) prg' | SWAP -> let x::y::stack' = stack in @@ -132,7 +138,7 @@ let run p i = let args, stack' = split n stack in let (st, i, o, r) = Language.Builtin.eval (st, i, o, []) (List.rev args) f in (*Printf.printf "Builtin:\n";*) - (cstack, (match r with [r] -> r::stack' | _ -> stack'), (st, i, o)) + (cstack, (match r with [r] -> r::stack' | _ -> Value.Empty :: stack'), (st, i, o)) end ) ([], [], (State.empty, i, [])) @@ -222,6 +228,11 @@ let compile (defs, p) = let env, flag2, s2 = compile_list l env es in add_code (env, flag1, s1) les flag2 s2 and compile_expr l env = function + | Expr.Unit -> env, false, [CONST 0] + + | Expr.Ignore s -> let ls, env = env#get_label in + add_code (compile_expr ls env s) ls false [DROP] + | Expr.ElemRef (x, i) -> compile_list l env [x; i] | Expr.Var x -> env, false, [LD x] | Expr.Ref x -> env, false, [LDA x] @@ -278,9 +289,9 @@ let compile (defs, p) = env, false, [LABEL loop] @ body @ (if flag then [LABEL check] else []) @ se @ (if fe then [LABEL lexp] else []) @ [CJMP ("z", loop)] | Expr.Return (Some e) -> let lret, env = env#get_label in - add_code (compile_expr lret env e) lret false [RET true] + add_code (compile_expr lret env e) lret false [RET] - | Expr.Return None -> env, false, [RET false] + | Expr.Return None -> env, false, [CONST 0; RET] | Expr.Leave -> env, false, [LEAVE] diff --git a/src/X86.ml b/src/X86.ml index 42697fa2c..f4e0ff802 100644 --- a/src/X86.ml +++ b/src/X86.ml @@ -13,10 +13,11 @@ let word_size = 4;; (* We need to distinguish the following operand types: *) @type opnd = -| R of int (* hard register *) -| S of int (* a position on the hardware stack *) -| M of string (* a named memory location *) -| L of int (* an immediate operand *) +| R of int (* hard register *) +| S of int (* a position on the hardware stack *) +| M of string (* a named memory location *) +| L of int (* an immediate operand *) +| I of opnd (* an indirect operand *) with show let show_opnd = show(opnd) @@ -33,29 +34,29 @@ let esp = R 7 (* Now x86 instruction (we do not need all of them): *) type instr = -(* copies a value from the first to the second operand *) | Mov of opnd * opnd -(* makes a binary operation; note, the first operand *) | Binop of string * opnd * opnd -(* designates x86 operator, not the source language one *) -(* x86 integer division, see instruction set reference *) | IDiv of opnd -(* see instruction set reference *) | Cltd -(* sets a value from flags; the first operand is the *) | Set of string * string -(* suffix, which determines the value being set, the *) -(* the second --- (sub)register name *) -(* pushes the operand on the hardware stack *) | Push of opnd -(* pops from the hardware stack to the operand *) | Pop of opnd -(* call a function by a name *) | Call of string -(* returns from a function *) | Ret -(* a label in the code *) | Label of string -(* a conditional jump *) | CJmp of string * string -(* a non-conditional jump *) | Jmp of string -(* directive *) | Meta of string +(* copies a value from the first to the second operand *) | Mov of opnd * opnd +(* loads an address of the first operand into the second *) | Lea of opnd * opnd +(* makes a binary operation; note, the first operand *) | Binop of string * opnd * opnd +(* designates x86 operator, not the source language one *) +(* x86 integer division, see instruction set reference *) | IDiv of opnd +(* see instruction set reference *) | Cltd +(* sets a value from flags; the first operand is the *) | Set of string * string +(* suffix, which determines the value being set, the *) +(* the second --- (sub)register name *) +(* pushes the operand on the hardware stack *) | Push of opnd +(* pops from the hardware stack to the operand *) | Pop of opnd +(* call a function by a name *) | Call of string +(* returns from a function *) | Ret +(* a label in the code *) | Label of string +(* a conditional jump *) | CJmp of string * string +(* a non-conditional jump *) | Jmp of string +(* directive *) | Meta of string -(* arithmetic correction: decrement *) | Dec of opnd -(* arithmetic correction: or 0x0001 *) | Or1 of opnd -(* arithmetic correction: shl 1 *) | Sal1 of opnd -(* arithmetic correction: shr 1 *) | Sar1 of opnd - | Repmovsl - +(* arithmetic correction: decrement *) | Dec of opnd +(* arithmetic correction: or 0x0001 *) | Or1 of opnd +(* arithmetic correction: shl 1 *) | Sal1 of opnd +(* arithmetic correction: shr 1 *) | Sar1 of opnd + | Repmovsl (* Instruction printer *) let show instr = let binop = function @@ -68,13 +69,14 @@ let show instr = | "cmp" -> "cmpl" | _ -> failwith "unknown binary operator" in - let opnd = function + let rec opnd = function | R i -> regs.(i) | S i -> if i >= 0 then Printf.sprintf "-%d(%%ebp)" ((i+1) * word_size) else Printf.sprintf "%d(%%ebp)" (8+(-i-1) * word_size) | M x -> x | L i -> Printf.sprintf "$%d" i + | I x -> Printf.sprintf "(%s)" (opnd x) in match instr with | Cltd -> "\tcltd" @@ -82,6 +84,7 @@ let show instr = | IDiv s1 -> Printf.sprintf "\tidivl\t%s" (opnd s1) | Binop (op, s1, s2) -> Printf.sprintf "\t%s\t%s,\t%s" (binop op) (opnd s1) (opnd s2) | Mov (s1, s2) -> Printf.sprintf "\tmovl\t%s,\t%s" (opnd s1) (opnd s2) + | Lea (x, y) -> Printf.sprintf "\tleal\t%s,\t%s" (opnd x) (opnd y) | Push s -> Printf.sprintf "\tpushl\t%s" (opnd s) | Pop s -> Printf.sprintf "\tpopl\t%s" (opnd s) | Ret -> "\tret" @@ -107,7 +110,7 @@ open SM of x86 instructions *) let compile env code = - (*SM.print_prg code;*) + SM.print_prg code; flush stdout; let suffix = function | "<" -> "l" @@ -129,25 +132,20 @@ let compile env code = List.split @@ List.map (fun r -> (Push r, Pop r)) (env#live_registers n) in let env, code = - if n = 0 - then env, pushr @ [Call f] @ (List.rev popr) - else - let rec push_args env acc = function - | 0 -> env, acc - | n -> let x, env = env#pop in - push_args env ((Push x)::acc) (n-1) - in - let env, pushs = push_args env [] n in - let pushs = - match f with - | "Barray" -> List.rev @@ (Push (L n)) :: pushs - | "Bsexp" -> List.rev @@ (Push (L n)) :: pushs - | "Bsta" -> - let x::v::is = List.rev pushs in - is @ [x; v] @ [Push (L (n-2))] - | _ -> List.rev pushs - in - env, pushr @ pushs @ [Call f; Binop ("+", L (4 * List.length pushs), esp)] @ (List.rev popr) + let rec push_args env acc = function + | 0 -> env, acc + | n -> let x, env = env#pop in + push_args env ((Push x)::acc) (n-1) + in + let env, pushs = push_args env [] n in + let pushs = + match f with + | "Barray" -> List.rev @@ (Push (L n)) :: pushs + | "Bsexp" -> List.rev @@ (Push (L n)) :: pushs + | "Bsta" -> pushs + | _ -> List.rev pushs + in + env, pushr @ pushs @ [Call f; Binop ("+", L (4 * List.length pushs), esp)] @ (List.rev popr) in (if p then env, code else let y, env = env#allocate in env, code @ [Mov (eax, y)]) in @@ -166,6 +164,14 @@ let compile env code = let l, env = env#allocate in let env, call = call env ".string" 1 false in (env, Mov (M ("$" ^ s), l) :: call) + + | LDA x -> + let s, env' = (env#variable x)#allocate in + env', + (match s with + | S _ | M _ -> [Lea (env'#loc x, eax); Mov (eax, s)] + | _ -> [Lea (env'#loc x, s)] + ) | LD x -> let s, env' = (env#variable x)#allocate in @@ -174,26 +180,17 @@ let compile env code = | S _ | M _ -> [Mov (env'#loc x, eax); Mov (eax, s)] | _ -> [Mov (env'#loc x, s)] ) - - (* TODO - | STA (x, n) -> - let s, env = (env#variable x)#allocate in - let push = - match s with - | S _ | M _ -> [Mov (env#loc x, eax); Mov (eax, s)] - | _ -> [Mov (env#loc x, s)] - in - let env, code = call env ".sta" (n+2) true in - env, push @ code + + | STA -> + call env ".sta" 3 true - | ST x -> - let s, env' = (env#variable x)#pop in + | ST -> + let v, x, env' = env#pop2 in env', - (match s with - | S _ | M _ -> [Mov (s, eax); Mov (eax, env'#loc x)] - | _ -> [Mov (s, env'#loc x)] - ) - *) + (match x with + | S _ | M _ -> [Mov (v, edx); Mov (x, eax); Mov (edx, I eax)] + | _ -> [Mov (v, eax); Mov (eax, I x)] + ) | BINOP op -> let x, y, env' = env#pop2 in @@ -310,12 +307,11 @@ let compile env code = Meta (Printf.sprintf "\t.set\t%s,\t%d" env#allocated_size env#allocated) ] - | RET b -> - if b - then let x, env = env#pop in env, [Mov (x, eax); Jmp env#epilogue] - else env, [Jmp env#epilogue] + | RET -> + let x, env = env#pop in + env, [Mov (x, eax); Jmp env#epilogue] - | CALL (f, n) -> call env f n (* p *) false (* TODO!!! *) + | CALL (f, n) -> call env f n (f <> "Lraw" && f <> "Lcollect_ints" && f <> "Lcollect_ints_acc" && f <> "Lread" && f <> ".elem" && f <> ".array" && f <> ".length") | SEXP (t, n) -> let s, env = env#allocate in