diff --git a/src/Driver.ml b/src/Driver.ml index 44501f5d5..ca790354b 100644 --- a/src/Driver.ml +++ b/src/Driver.ml @@ -56,7 +56,7 @@ let main = let output = if interpret then Language.eval prog input - else [] (* SM.run (SM.compile prog) input *) (* TODO! *) + else SM.run (SM.compile prog) input in List.iter (fun i -> Printf.printf "%d\n" i) output | `Fail er -> Printf.eprintf "Error: %s\n" er diff --git a/src/Language.ml b/src/Language.ml index eba210f50..ba4233d3e 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -134,12 +134,6 @@ module State = (* empty state *) let empty = I - (* initialize empty state *) - let init st vars list = - match st with - | I -> G (vars @ Builtin.names, List.fold_left (fun s (name, value) -> bind name value s) (from_list list) (Builtin.bindings ())) - | _ -> invalid_arg "state already initialzied" - (* Scope operation: checks if a name is in a scope *) let in_scope x s = List.exists (fun (y, _) -> y = x) s @@ -195,10 +189,13 @@ module State = | L (_, _, e) -> enter e xs (* Push a new local scope *) - let push st s xs = L (xs, s, st) + let push st s xs = + match st with + | I -> G (xs @ Builtin.names, List.fold_left (fun s (name, value) -> bind name value s) s (Builtin.bindings ())) + | _ -> L (xs, s, st) (* Drop a local scope *) - let drop (L (_, _, e)) = e + let drop = function L (_, _, e) -> e | G _ -> I (* Observe a variable in a state and print it to stderr *) let observe st x = @@ -296,7 +293,7 @@ module Expr = (* return statement *) | Return of t option (* ignore a value *) | Ignore of t (* unit value *) | Unit - (* entering the scope *) | Scope of [`Global | `Local] * (string * [`Fun of string list * t | `Variable of t option]) list * t + (* entering the scope *) | Scope of (string * [`Fun of string list * t | `Variable of t option]) list * t (* lambda expression *) | Lambda of string list * t (* leave a scope *) | Leave (* intrinsic (for evaluation) *) | Intrinsic of (t config -> t config) @@ -383,7 +380,7 @@ module Expr = match expr with | Lambda (args, body) -> eval (st, i, o, Value.Closure (args, body, st) ::vs) Skip k - | Scope (kind, defs, body) -> + | Scope (defs, body) -> let vars, body, bnds = List.fold_left (fun (vs, bd, bnd) -> function @@ -393,13 +390,7 @@ module Expr = ([], body, []) (List.rev defs) in - eval - ((match kind with - | `Local -> State.push st (State.from_list bnds) vars - | `Global -> State.init st vars bnds - ), i, o, vs) - k - (match kind with `Global -> body | `Local -> Seq (body, Leave)) + eval (State.push st (State.from_list bnds) vars, i, o, vs) k (Seq (body, Leave)) | Unit -> eval (st, i, o, Value.Empty :: vs) Skip k | Ignore s -> @@ -595,7 +586,7 @@ module Expr = ostap ( parse[def][infix][atr]: h:basic[def][infix][Void] -";" t:parse[def][infix][atr] {Seq (h, t)} | basic[def][infix][atr]; - scope[kind][def][infix][atr][e]: <(d, infix')> : def[infix] expr:e[infix'][atr] {Scope (kind, d, expr)}; + scope[def][infix][atr][e]: <(d, infix')> : def[infix] expr:e[infix'][atr] {Scope (d, expr)}; basic[def][infix][atr]: !(expr (fun x -> x) (Array.map (fun (a, (atr, l)) -> a, (atr, List.map (fun (s, f) -> ostap (- $(s)), f) l)) infix) (primary def infix) atr); @@ -642,7 +633,7 @@ module Expr = | %"infix" s:STRING => {notRef atr} => {ignore atr (Var (infix_name @@ unquote s))} | %"fun" "(" args:!(Util.list0)[ostap (STRING)] ")" body:parse[def][infix][Void] => {notRef atr} => {ignore atr (Lambda (args, body))} | "[" es:!(Util.list0)[parse def infix Val] "]" => {notRef atr} => {ignore atr (Array es)} - | -"{" scope[`Local][def][infix][atr][parse def] -"}" + | -"{" scope[def][infix][atr][parse def] -"}" | "{" es:!(Util.list0)[parse def infix Val] "}" => {notRef atr} => {ignore atr (match es with | [] -> Const 0 | _ -> List.fold_right (fun x acc -> Sexp ("cons", [x; acc])) es (Const 0)) @@ -655,22 +646,22 @@ module Expr = | {isVoid atr} => %"skip" {Skip} - | %"if" e:parse[def][infix][Val] %"then" the:scope[`Local][def][infix][atr][parse def] - elif:(%"elif" parse[def][infix][Val] %"then" scope[`Local][def][infix][atr][parse def])* - %"else" els:scope[`Local][def][infix][atr][parse def] %"fi" + | %"if" e:parse[def][infix][Val] %"then" the:scope[def][infix][atr][parse def] + elif:(%"elif" parse[def][infix][Val] %"then" scope[def][infix][atr][parse def])* + %"else" els:scope[def][infix][atr][parse def] %"fi" {If (e, the, List.fold_right (fun (e, t) elif -> If (e, t, elif)) elif els)} - | %"if" e:parse[def][infix][Val] %"then" the:scope[`Local][def][infix][Void][parse def] - elif:(%"elif" parse[def][infix][Val] %"then" scope[`Local][def][infix][atr][parse def])* + | %"if" e:parse[def][infix][Val] %"then" the:scope[def][infix][Void][parse def] + elif:(%"elif" parse[def][infix][Val] %"then" scope[def][infix][atr][parse def])* => {isVoid atr} => %"fi" {If (e, the, List.fold_right (fun (e, t) elif -> If (e, t, elif)) elif Skip)} - | %"while" e:parse[def][infix][Val] %"do" s:scope[`Local][def][infix][Void][parse def] + | %"while" e:parse[def][infix][Val] %"do" s:scope[def][infix][Void][parse def] => {isVoid atr} => %"od" {While (e, s)} - | %"for" i:parse[def][infix][Void] "," c:parse[def][infix][Val] "," s:parse[def][infix][Void] %"do" b:scope[`Local][def][infix][Void][parse def] => {isVoid atr} => %"od" + | %"for" i:parse[def][infix][Void] "," c:parse[def][infix][Val] "," s:parse[def][infix][Void] %"do" b:scope[def][infix][Void][parse def] => {isVoid atr} => %"od" {Seq (i, While (c, Seq (b, s)))} - | %"repeat" s:scope[`Local][def][infix][Void][parse def] %"until" e:basic[def][infix][Val] + | %"repeat" s:scope[def][infix][Void][parse def] %"until" e:basic[def][infix][Val] => {isVoid atr} => {Repeat (s, e)} | %"return" e:basic[def][infix][Val]? => {isVoid atr} => {Return e} @@ -806,7 +797,7 @@ let eval expr i = (* Top-level parser *) ostap ( - parse[infix]: !(Expr.scope `Global (definitions global) infix Expr.Void (Expr.parse (definitions local))); + parse[infix]: !(Expr.scope (definitions global) infix Expr.Void (Expr.parse (definitions local))); local: %"local" {`Local}; global: %"global" {`Global}; definitions[kind][infix]: diff --git a/src/SM.ml b/src/SM.ml index 322244b8b..cfef08d0f 100644 --- a/src/SM.ml +++ b/src/SM.ml @@ -155,8 +155,26 @@ let run p i = Takes a program in the source language and returns an equivalent program for the stack machine *) -let compile (defs, p) = - let label s = "L" ^ s in + +let label s = "L" ^ s + +class env = +object (self : 'self) + val label_index = 0 + val scope_index = 0 + val globals = ([] : string list) + + method get_label = (label @@ string_of_int label_index), {< label_index = label_index + 1 >} + + method push_scope (k : [`Global | `Local]) = self + + method pop_scope (k : [`Global | `Local]) = self + + method add_var (k : [`Global | `Local]) (name : string) = match k with `Global -> self | `Local -> self + method add_fun (k : [`Global | `Local]) (name : string) = match k with `Global -> self | `Local -> self +end + +let compile p = let rec pattern env lfalse = function | Pattern.Wildcard -> env, false, [DROP] | Pattern.Named (_, p) -> pattern env lfalse p @@ -231,6 +249,23 @@ 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.Scope (ds, e) -> + let k = `Global in + let env = env#push_scope k in + let env, e = + List.fold_left + (fun (env, e) -> + function + | name, `Fun _ -> env#add_fun k name, e + | name, `Variable None -> env#add_var k name, e + | name, `Variable (Some v) -> env#add_var k name, Expr.Seq (Expr.Assign (Expr.Ref name, v), e) + ) + (env, e) + ds + in + let env, flag, code = compile_expr l env e in + env#pop_scope k, flag, code + | Expr.Unit -> env, false, [CONST 0] | Expr.Ignore s -> let ls, env = env#get_label in @@ -264,10 +299,7 @@ let compile (defs, p) = add_code (compile_expr lsv env e) lsv false [CALL (".stringval", 1)] | Expr.Assign (x, e) -> let lassn, env = env#get_label in - add_code (compile_list lassn env [x; e]) lassn false [match x with Expr.ElemRef _ -> STA | _ -> STI] - (* (match x with - * | Expr.Ref x -> add_code (compile_expr lassn env e) lassn false [ST x] - * | _ -> add_code (compile_list lassn env [x; e]) lassn false [match x with Expr.ElemRef _ -> STA | _ -> STI]) *) + add_code (compile_list lassn env [x; e]) lassn false [match x with Expr.ElemRef _ -> STA | _ -> STI] | Expr.Skip -> env, false, [] @@ -334,12 +366,7 @@ let compile (defs, p) = in env, true, se @ (if fe then [LABEL lexp] else []) @ [DUP] @ (List.flatten @@ List.rev code) @ [JMP l] in - let compile_def env (name, def) = - let args, stmt = - match def with - | `Fun (args, stmt) -> args, stmt - | _ -> invalid_arg "local definition" - in + let compile_fundef env (name, args, stmt) = let lend, env = env#get_label in let env, flag, code = compile_expr lend env stmt in env, @@ -348,18 +375,7 @@ let compile (defs, p) = (if flag then [LABEL lend] else []) @ [END] in - let env = - object - val ls = 0 - method get_label = (label @@ string_of_int ls), {< ls = ls + 1 >} - end - in - let env, def_code = - List.fold_left - (fun (env, code) (name, others) -> let env, code' = compile_def env (label name, others) in env, code'::code) - (env, []) - defs - in + let env = new env in let lend, env = env#get_label in let _, flag, code = compile_expr lend env p in - (if flag then code @ [LABEL lend] else code) @ [END] @ (List.concat def_code) + (if flag then code @ [LABEL lend] else code) @ [END] diff --git a/src/X86.ml b/src/X86.ml index 87c9d9873..d56321e65 100644 --- a/src/X86.ml +++ b/src/X86.ml @@ -558,7 +558,7 @@ let genasm (ds, stmt) = let env, code = compile (new env) - ((LABEL "main") :: (BEGIN ("main", [], [])) :: SM.compile (ds, stmt)) + ((LABEL "main") :: (BEGIN ("main", [], [])) :: [] (* TODO! SM.compile (ds, stmt) *)) in let gc_start, gc_end = "__gc_data_start", "__gc_data_end" in let data = [Meta "\t.data";