From d4d058795c122df75a29831f5559ef722291bd70 Mon Sep 17 00:00:00 2001 From: Joan Arnaldich Bernal Date: Mon, 12 Dec 2011 23:12:23 +0100 Subject: [PATCH] Added some words in the evaluator --- evaluator.ml | 60 +++++++++++++++++++++++++++++++----------------------- interactive.ml | 25 +++++------------------ tests/closures.scm | 6 +++--- types.ml | 4 +++- types.mli | 4 +++- 5 files changed, 48 insertions(+), 51 deletions(-) diff --git a/evaluator.ml b/evaluator.ml index 67048a6..1e7744b 100644 --- a/evaluator.ml +++ b/evaluator.ml @@ -8,17 +8,15 @@ I think this would be enough: Rewind (application and call/cc) re-evaluates the last result, applying the last rib and popping a frame. - PopEnv (closure) Pop an environment frame. - Cond of schemeobj * schemeobj If the last result is true, pile up the true case... - - EvalSeq of int + + Bind(var) per a define + Set(var) per a set! This is a bit ugly... looks like mixing a compiler and an interpreter... *) - open Environment;; open Printer ;; (* Just for debugging *) open Types;; @@ -117,7 +115,6 @@ type eval_state = { cont : scheme_object list; env : scheme_environment };; let rec eval (state:eval_state) : eval_state = - let exp_eval obj = List.hd (List.hd (eval {state with cont = obj::state.cont }).pending_results) in let (current_res_frame, older_res_frames) = (List.hd state.pending_results, List.tl state.pending_results) in let push_result results res = (res::(List.hd results))::(List.tl results) in let rewind s = @@ -126,20 +123,29 @@ let rec eval (state:eval_state) : eval_state = in match state.cont with exp::rest -> - let return obj = { state with pending_results = (push_result state.pending_results obj); cont=rest } in - let return_void = { state with cont=rest } in + let return obj = + eval { state with pending_results = (push_result state.pending_results obj); cont=rest } + in (match exp with | ProperList (Symbol "quote"::[obj]) -> return obj | ProperList (Symbol "error"::whatever) -> raise (Scheme_user_error whatever) | ProperList (Symbol "define"::Symbol var::[expression]) -> + eval { state with cont = expression::Bind(var)::rest; + pending_results = []::state.pending_results } + | Bind (var) -> let f = Environment.current_env_frame state.env in - Hashtbl.add f var (exp_eval expression); - return_void + Hashtbl.add f var (List.hd current_res_frame); + eval { state with cont=rest; + pending_results= older_res_frames } | ProperList (Symbol "set!"::Symbol var::[expression]) -> - Environment.update state.env var (exp_eval expression); - return_void + eval { state with cont = expression::Set(var)::rest; + pending_results = []::state.pending_results } + | Set (var) -> + Environment.update state.env var (List.hd current_res_frame); + eval { state with cont=rest; + pending_results= older_res_frames } | ProperList (Symbol "lambda"::formals::body) -> let proper_body = ProperList (Symbol "begin"::body) in let syms = match formals with @@ -151,27 +157,28 @@ let rec eval (state:eval_state) : eval_state = return (Closure (proper_body, state.env, syms)) | ProperList (Symbol "call/cc"::[callee]) -> let continuation = Continuation (state.env, rest, state.pending_results) in - eval { state with cont = (EvalSeq 1)::callee::Rewind::rest; + eval { state with cont = callee::Rewind::rest; (* (EvalSeq 1):: *) pending_results = [continuation]::state.pending_results } | ProperList (Symbol "if"::test::true_case::[false_case]) -> - (match (exp_eval test) with - False -> return (exp_eval false_case) - | _ -> return (exp_eval true_case)) (* *) + eval { state with cont = test::Cond(true_case, false_case)::rest; + pending_results = []::state.pending_results } + | Cond (true_case, false_case) -> + (match (List.hd current_res_frame) with + False -> + eval { state with cont = false_case::rest; + pending_results = older_res_frames } + | _ -> eval { state with cont = true_case::rest; + pending_results = older_res_frames }) | ProperList (f::params) -> - let len = List.length (f::params) in - eval { state with cont=((EvalSeq len)::params)@(f::Rewind::rest); + eval { state with cont= params @ (f::Rewind::rest); (* (EvalSeq len):: *) pending_results = []::state.pending_results } | Rewind -> eval (rewind { state with cont = rest }) - | EvalSeq 0 -> - eval { state with cont = rest } - | EvalSeq (n) -> - eval (eval { state with cont = (List.hd rest)::(EvalSeq (n-1))::(List.tl rest)}) | Closure (body, closure_env, formals) -> let env = (Environment.push_env_frame closure_env formals current_res_frame) in eval { env; cont=body::PopEnv::rest; pending_results = older_res_frames } | PopEnv -> - { state with env = (List.tl state.env); cont = rest } + eval { state with env = (List.tl state.env); cont = rest } | Continuation (saved_env, saved_cont, saved_res) -> eval { env=saved_env; cont= saved_cont; @@ -182,10 +189,11 @@ let rec eval (state:eval_state) : eval_state = | Builtin (fbuiltin) -> (match fbuiltin current_res_frame with Some (result) -> - { state with pending_results = push_result older_res_frames result; + eval { state with pending_results = push_result older_res_frames result; cont = rest } - | None -> { state with cont = rest; - pending_results = older_res_frames }) + | None -> + eval { state with cont = rest; + pending_results = older_res_frames }) | Symbol s -> return (Environment.lookup state.env s) | whatever -> diff --git a/interactive.ml b/interactive.ml index a387875..eb64969 100644 --- a/interactive.ml +++ b/interactive.ml @@ -11,10 +11,6 @@ open Parser;; let (|>) (p : 'a) (f : 'a -> 'b) = f p;; -let t2 = - ProperList - [ProperList [Symbol "lambda"; ProperList [Symbol "x"]; Symbol "x"]; Int 1];; - #untrace Evaluator.eval;; #load "evaluator.cmo";; @@ -27,24 +23,13 @@ let go exp = Evaluator.pending_results = [[]] }; state;; #trace Evaluator.eval;; -go t2;; let read s = Parser.main Lexer.token (Lexing.from_string s);; -let test_exp = - ProperList - [Symbol "+"; Int 1; - ProperList - [Symbol "call/cc"; - ProperList - [Symbol "lambda"; ProperList [Symbol "k"]; - ProperList [Symbol "k"; Int 2]]]; - Int 2];; - -let closure_exp = read "(define x 1) ((lambda () (set! x 2))) x";; - let rev x = go (read x);; -"(+ 1 1)" |> rev;; - -"(+ 1 (+ 1 (call/cc (lambda (k) (k 3))) 5) 3)" |> rev;; +"(+ 1 (+ 1 (call/cc (lambda (k) (k 3))) 5) 3)" |> rev;; +"(+ 1 1)" |> rev;; +(* "(define x 1)" |> rev;; *) +(* "(define add-x (lambda (y) (+ x y)))" |> rev;; *) +(* "(add-x 1)" |> rev;; *) diff --git a/tests/closures.scm b/tests/closures.scm index 7e5ff6b..f4dd99b 100644 --- a/tests/closures.scm +++ b/tests/closures.scm @@ -7,8 +7,7 @@ (define x 1) ;;; Closes over x -(define add-x - (lambda (y) (+ x y))) +(define add-x (lambda (y) (+ x y))) (set! x 3) (assert-equal (add-x 2) 5) @@ -32,4 +31,5 @@ (lambda () (set-free-x))) (call-set-free-x) -(assert-equal x 5) +(assert-equal x 5) + diff --git a/types.ml b/types.ml index f9ea83a..915253f 100644 --- a/types.ml +++ b/types.ml @@ -15,7 +15,9 @@ type scheme_object = | Continuation of scheme_environment * (scheme_object list) * (scheme_object list list) | PopEnv | Rewind - | EvalSeq of int + | Cond of (scheme_object * scheme_object) + | Set of string + | Bind of string and environment_frame = (string, scheme_object) Hashtbl.t and diff --git a/types.mli b/types.mli index c6bb530..b31180e 100644 --- a/types.mli +++ b/types.mli @@ -22,7 +22,9 @@ type scheme_object = | Continuation of scheme_environment * (scheme_object list) * (scheme_object list list) | PopEnv | Rewind - | EvalSeq of int + | Cond of (scheme_object * scheme_object) + | Set of string + | Bind of string and environment_frame = (string, scheme_object) Hashtbl.t and -- 2.11.4.GIT