diff --git a/src/Driver.ml b/src/Driver.ml index f0f6451d6..9e96848e9 100644 --- a/src/Driver.ml +++ b/src/Driver.ml @@ -6,7 +6,7 @@ let parse infile = (object inherit Matcher.t s inherit Util.Lexers.decimal s - inherit Util.Lexers.ident ["read"; "write"; "skip"; "if"; "then"; "else"; "elif"; "fi"; "while"; "do"; "od"; "repeat"; "until"; "for"; (* add new keywords *)] s + inherit Util.Lexers.ident ["read"; "write"; "skip"; "if"; "then"; "else"; "elif"; "fi"; "while"; "do"; "od"; "repeat"; "until"; "for"; "fun"; "local"] s inherit Util.Lexers.skip [ Matcher.Skip.whitespaces " \t\n"; Matcher.Skip.lineComment "--"; diff --git a/src/Language.ml b/src/Language.ml index cb41eda4b..a84102540 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -15,21 +15,25 @@ module State = type t = {g : string -> int; l : string -> int; scope : string list} (* Empty state *) - let empty = failwith "Not implemented" + let empty = + let e x = failwith (Printf.sprintf "Undefined variable: %s" x) in + {g = e; l = e; scope = []} (* Update: non-destructively "modifies" the state s by binding the variable x to value v and returns the new state w.r.t. a scope *) - let update x v s = failwith "Not implemented" - + let update x v s = + let u x v s = fun y -> if x = y then v else s y in + if List.mem x s.scope then {s with l = u x v s.l} else {s with g = u x v s.g} + (* Evals a variable in a state w.r.t. a scope *) - let eval s x = failwith "Not implemented" + let eval s x = (if List.mem x s.scope then s.l else s.g) x (* Creates a new scope, based on a given state *) - let enter st xs = failwith "Not implemented" + let push_scope st xs = {empty with g = st.g; scope = xs} (* Drops a scope *) - let leave st st' = failwith "Not implemented" + let drop_scope st st' = {st' with g = st.g} end @@ -60,7 +64,31 @@ module Expr = Takes a state and an expression, and returns the value of the expression in the given state. *) - let eval st expr = failwith "Not implemented" + let to_func op = + let bti = function true -> 1 | _ -> 0 in + let itb b = b <> 0 in + let (|>) f g = fun x y -> f (g x y) in + match op with + | "+" -> (+) + | "-" -> (-) + | "*" -> ( * ) + | "/" -> (/) + | "%" -> (mod) + | "<" -> bti |> (< ) + | "<=" -> bti |> (<=) + | ">" -> bti |> (> ) + | ">=" -> bti |> (>=) + | "==" -> bti |> (= ) + | "!=" -> bti |> (<>) + | "&&" -> fun x y -> bti (itb x && itb y) + | "!!" -> fun x y -> bti (itb x || itb y) + | _ -> failwith (Printf.sprintf "Unknown binary operator %s" op) + + let rec eval st expr = + match expr with + | Const n -> n + | Var x -> State.eval st x + | Binop (op, x, y) -> to_func op (eval st x) (eval st y) (* Expression parser. You can use the following terminals: @@ -69,7 +97,26 @@ module Expr = *) ostap ( - parse: empty {failwith "Not implemented"} + parse: + !(Ostap.Util.expr + (fun x -> x) + (Array.map (fun (a, s) -> a, + List.map (fun s -> ostap(- $(s)), (fun x y -> Binop (s, x, y))) s + ) + [| + `Lefta, ["!!"]; + `Lefta, ["&&"]; + `Nona , ["=="; "!="; "<="; "<"; ">="; ">"]; + `Lefta, ["+" ; "-"]; + `Lefta, ["*" ; "/"; "%"]; + |] + ) + primary); + + primary: + n:DECIMAL {Const n} + | x:IDENT {Var x} + | -"(" parse -")" ) end @@ -100,15 +147,56 @@ module Stmt = Takes an environment, a configuration and a statement, and returns another configuration. The environment supplies the following method - method definition : string -> (string list, string list, t) + method definition : string -> (string list, t) - which returns a list of formal parameters, local variables, and a body for given definition + which returns a list of formal parameters and a body for given definition *) - let eval env ((st, i, o) as conf) stmt = failwith "Not implemented" + let rec eval env ((st, i, o) as conf) stmt = + match stmt with + | Read x -> (match i with z::i' -> (State.update x z st, i', o) | _ -> failwith "Unexpected end of input") + | Write e -> (st, i, o @ [Expr.eval st e]) + | Assign (x, e) -> (State.update x (Expr.eval st e) st, i, o) + | Seq (s1, s2) -> eval env (eval env conf s1) s2 + | Skip -> conf + | If (e, s1, s2) -> eval env conf (if Expr.eval st e <> 0 then s1 else s2) + | While (e, s) -> if Expr.eval st e = 0 then conf else eval env (eval env conf s) stmt + | Repeat (s, e) -> let (st, _, _) as conf' = eval env conf s in if Expr.eval st e = 0 then eval env conf' stmt else conf' + | Call (f, args) -> let args = List.map (Expr.eval st) args in + let xs, locs, s = env#definition f in + let st' = List.fold_left (fun st (x, a) -> State.update x a st) (State.push_scope st (xs @ locs)) (List.combine xs args) in + let st'', i', o' = eval env (st', i, o) s in + (State.drop_scope st'' st, i', o') (* Statement parser *) ostap ( - parse: empty {failwith "Not implemented"} + parse: + s:stmt ";" ss:parse {Seq (s, ss)} + | stmt; + stmt: + %"read" "(" x:IDENT ")" {Read x} + | %"write" "(" e:!(Expr.parse) ")" {Write e} + | %"skip" {Skip} + | %"if" e:!(Expr.parse) + %"then" the:parse + elif:(%"elif" !(Expr.parse) %"then" parse)* + els:(%"else" parse)? + %"fi" { + If (e, the, + List.fold_right + (fun (e, t) elif -> If (e, t, elif)) + elif + (match els with None -> Skip | Some s -> s) + ) + } + | %"while" e:!(Expr.parse) %"do" s:parse %"od"{While (e, s)} + | %"for" i:parse "," c:!(Expr.parse) "," s:parse %"do" b:parse %"od" { + Seq (i, While (c, Seq (b, s))) + } + | %"repeat" s:parse %"until" e:!(Expr.parse) {Repeat (s, e)} + | x:IDENT + s:(":=" e :!(Expr.parse) {Assign (x, e)} | + "(" args:!(Util.list0)[Expr.parse] ")" {Call (x, args)} + ) {s} ) end @@ -121,7 +209,12 @@ module Definition = type t = string * (string list * string list * Stmt.t) ostap ( - parse: empty {failwith "Not implemented"} + arg : IDENT; + parse: %"fun" name:IDENT "(" args:!(Util.list0 arg) ")" + locs:(%"local" !(Util.list arg))? + "{" body:!(Stmt.parse) "}" { + (name, (args, (match locs with None -> [] | Some l -> l), body)) + } ) end @@ -137,7 +230,10 @@ type t = Definition.t list * Stmt.t Takes a program and its input stream, and returns the output stream *) -let eval (defs, body) i = failwith "Not implemented" - +let eval (defs, body) i = + let module M = Map.Make (String) in + let m = List.fold_left (fun m ((name, _) as def) -> M.add name def m) M.empty defs in + let _, _, o = Stmt.eval (object method definition f = snd @@ M.find f m end) (State.empty, i, []) body in o + (* Top-level parser *) -let parse = failwith "Not implemented" +let parse = ostap (!(Definition.parse)* !(Stmt.parse)) diff --git a/src/SM.ml b/src/SM.ml index 057298228..cee1e79b4 100644 --- a/src/SM.ml +++ b/src/SM.ml @@ -31,7 +31,32 @@ type config = (prg * State.t) list * int list * Stmt.config Takes an environment, a configuration and a program, and returns a configuration as a result. The environment is used to locate a label to jump to (via method env#labeled ) *) -let eval env ((cstack, stack, ((st, i, o) as c)) as conf) = failwith "Not implemented" +let rec eval env ((cstack, stack, ((st, i, o) as c)) as conf) = function +| [] -> conf +| insn :: prg' -> + (match insn with + | BINOP op -> let y::x::stack' = stack in eval env (cstack, Expr.to_func op x y :: stack', c) prg' + | READ -> let z::i' = i in eval env (cstack, z::stack, (st, i', o)) prg' + | WRITE -> let z::stack' = stack in eval env (cstack, stack', (st, i, o @ [z])) prg' + | CONST i -> eval env (cstack, i::stack, c) prg' + | LD x -> eval env (cstack, State.eval st x :: stack, c) prg' + | ST x -> let z::stack' = stack in eval env (cstack, stack', (State.update x z st, 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 conf (if (c = "z" && x = 0) || (c = "nz" && x <> 0) then env#labeled l else prg') + | CALL f -> eval env ((prg', st)::cstack, stack, c) (env#labeled f) + | BEGIN (args, locals) -> let rec combine acc args stack = + match args, stack with + | [], _ -> List.rev acc, stack + | a::args', s::stack' -> combine ((a, s)::acc) args' stack' + in + let state', stack' = combine [] args stack in + eval env (cstack, stack', (List.fold_left (fun s (x, v) -> State.update x v s) (State.push_scope st (args @ locals)) state', i, o)) prg' + | END -> (match cstack with + | (prg', st')::cstack' -> eval env (cstack', stack, (State.drop_scope st st', i, o)) prg' + | [] -> conf + ) + ) (* Top-level evaluation @@ -56,4 +81,64 @@ let run p i = Takes a program in the source language and returns an equivalent program for the stack machine *) -let compile (defs, p) = failwith "Not implemented" +let compile (defs, p) = + let label s = "L" ^ s in + let rec expr = function + | Expr.Var x -> [LD x] + | Expr.Const n -> [CONST n] + | Expr.Binop (op, x, y) -> expr x @ expr y @ [BINOP op] + in + let rec compile_stmt l env = function + | Stmt.Read x -> env, false, [READ; ST x] + | Stmt.Write e -> env, false, expr e @ [WRITE] + | Stmt.Assign (x, e) -> env, false, expr e @ [ST x] + | Stmt.Skip -> env, false, [] + + | Stmt.Seq (s1, s2) -> let l2, env = env#get_label in + let env, flag1, s1 = compile_stmt l2 env s1 in + let env, flag2, s2 = compile_stmt l env s2 in + env, flag2, s1 @ (if flag1 then [LABEL l2] else []) @ s2 + + | Stmt.If (c, s1, s2) -> let l2, env = env#get_label in + let env, flag1, s1 = compile_stmt l env s1 in + let env, flag2, s2 = compile_stmt l env s2 in + env, true, expr c @ [CJMP ("z", l2)] @ s1 @ (if flag1 then [] else [JMP l]) @ [LABEL l2] @ s2 @ (if flag2 then [] else [JMP l]) + + | Stmt.While (c, s) -> let loop, env = env#get_label in + let cond, env = env#get_label in + let env, _, s = compile_stmt cond env s in + env, false, [JMP cond; LABEL loop] @ s @ [LABEL cond] @ expr c @ [CJMP ("nz", loop)] + + | Stmt.Repeat (s, c) -> let loop , env = env#get_label in + let check, env = env#get_label in + let env , flag, body = compile_stmt check env s in + env, false, [LABEL loop] @ body @ (if flag then [LABEL check] else []) @ (expr c) @ [CJMP ("z", loop)] + + | Stmt.Call (f, args) -> let args_code = List.concat @@ List.map expr (List.rev args) in + env, false, args_code @ [CALL (label f)] + in + let compile_def env (name, (args, locals, stmt)) = + let lend, env = env#get_label in + let env, flag, code = compile_stmt lend env stmt in + env, + [LABEL name; BEGIN (args, locals)] @ + code @ + (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 lend, env = env#get_label in + let _, flag, code = compile_stmt lend env p in + (LABEL "main" :: if flag then code @ [LABEL lend] else code) @ [END] @ (List.concat def_code) +