evaluator.ml

   1 (*
   2
   3   This attempt will not work as it is now. The evaluator should be
   4   CPS, what we can try is to add some "instruction" objects to the
   5   cont list (not scheme objects, but control stuff) that can be used
   6   to ask the evaluator to perform pending instructions.
   7
   8   I think this would be enough:
   9
  10   Rewind (application and call/cc) re-evaluates the last result, applying the last rib and popping a result frame.
  11   RestoreEnv (Env) Restore an environment (return from a closure)
  12   Cond of schemeobj * schemeobj If the last result is true, pile up the true case...
  13
  14   Bind(var)  per  a define
  15   Set(var) per a set!
  16
  17   This is a bit ugly... looks like mixing a compiler and an interpreter...
  18 *)
  19
  20 open Environment;;
  21 open Printer ;;                         (* Just for debugging *)
  22 open Types;;
  23
  24 module Evaluator = struct
  25 (*********************************************************************
  26                                  AUX
  27 **********************************************************************)
  28
  29 let (|>) (p : 'a) (f : 'a -> 'b) = f p;;
  30
  31 let rec prefix0 n l acum =
  32   match n with
  33       0 -> List.rev acum
  34     | i -> prefix0 (n - 1) (List.tl l) ((List.hd l)::acum);;
  35 let prefix n l = prefix0 n l [];;
  36
  37 let rec split_at0 n (seen, unseen) =
  38   match n with
  39       0 -> ((List.rev seen), unseen)
  40     | i -> split_at0 (n - 1) (((List.hd unseen)::seen), (List.tl unseen));;
  41 let split_at n l = split_at0 n ([], l);;
  42
  43 let rec loop_acum n f initial =
  44   match n with
  45       0 -> initial
  46     | i -> loop_acum (i - 1) f (f initial);;
  47
  48 let is_some = function
  49     Some x -> true
  50   | None -> false
  51
  52 let is_none x = not (is_some x);;
  53
  54 let get_some = function
  55     Some x -> x
  56   | None -> raise Not_found
  57
  58 let eval_error s = raise (Scheme_eval_error s);;
  59
  60 let get_int = function
  61     Int i -> i
  62   | _ -> raise Scheme_cast_error;;
  63
  64 let get_bool = function
  65     True -> true
  66   | False -> false
  67   | _ -> raise Scheme_cast_error;;
  68
  69 let scheme_obj_of_bool b =
  70   match b with
  71       true -> True
  72     | false -> False;;
  73
  74 (**********************************************************************
  75                                BUILTINS
  76  **********************************************************************)
  77 let make_arith_op_builtin_func (base:int) (f:int -> int -> int) params =
  78         Some (List.fold_left (fun x -> fun y -> Int (f (get_int x) (get_int y))) (Int base) params) ;;
  79
  80 let builtin_begin params =
  81   match (List.rev params) with
  82       hd::tl -> Some hd
  83     | [] -> None;;
  84
  85 let builtin_equal (params:scheme_object list) : (scheme_object option) =
  86   Some (scheme_obj_of_bool (List.for_all (( = ) (List.hd params)) (List.tl params)));;
  87
  88 let builtin_option (o:string) : ((scheme_object list) -> (scheme_object option) ) option =
  89   match o with
  90     "+" -> Some (make_arith_op_builtin_func 0 ( + ))
  91   | "-" -> Some (make_arith_op_builtin_func 0 ( - ))
  92   | "*" -> Some (make_arith_op_builtin_func 1 ( * ))
  93   | "/" -> Some (make_arith_op_builtin_func 1 ( / ))
  94   | "=" -> Some (builtin_equal)
  95   | "begin" -> Some (builtin_begin)
  96   | "list" -> Some (fun params -> (Some (ProperList params)))
  97   | _ -> None
  98 ;;
  99
 100 (**********************************************************************
 101                                  CPS
 102  **********************************************************************)
 103
 104 (*
 105
 106 In a continuation, maybe we also need to save the rib...
 107 if so, The Continuation object might need to save almost a whole state...
 108
 109 Then the state could be a stack of frames, instead of a record of stacks...
 110
 111 *)
 112
 113 type eval_state = { cont : scheme_object list;
 114                     pending_results : scheme_object list list;
 115                     env : scheme_environment };;
 116
 117 let rec eval (state:eval_state) : eval_state =
 118   let (current_res_frame, older_res_frames) = (List.hd state.pending_results, List.tl state.pending_results) in
 119   let push_result results res = (res::(List.hd results))::(List.tl results) in
 120   let rewind s =
 121     { s with pending_results = ((s.pending_results |> List.hd |> List.tl)::(List.tl s.pending_results));
 122       cont = (s.pending_results |> List.hd |> List.hd)::s.cont }
 123   in
 124   match state.cont with
 125       exp::rest ->
 126         let return obj =
 127           eval { state with pending_results = (push_result state.pending_results obj); cont=rest }
 128         in
 129         (match exp with
 130           | ProperList (Symbol "quote"::[obj]) ->
 131             return obj
 132           | ProperList (Symbol "error"::whatever) ->
 133             raise (Scheme_user_error whatever)
 134           | ProperList (Symbol "define"::Symbol var::[expression])  ->
 135             eval { state with cont = expression::Bind(var)::rest;
 136               pending_results = []::state.pending_results }
 137           | Bind (var) ->
 138             let f = Environment.current_env_frame state.env in
 139             Hashtbl.add f var (List.hd current_res_frame);
 140             eval { state with cont=rest;
 141               pending_results= older_res_frames }
 142           | ProperList (Symbol "set!"::Symbol var::[expression])  ->
 143             eval { state with cont = expression::Set(var)::rest;
 144               pending_results = []::state.pending_results }
 145           | Set (var) ->
 146             Environment.update state.env var (List.hd current_res_frame);
 147             eval { state with cont=rest;
 148               pending_results= older_res_frames }
 149           | ProperList (Symbol "lambda"::formals::body) ->
 150             let proper_body = ProperList (Symbol "begin"::body) in
 151             let syms = match formals with
 152                 ProperList l -> (List.map (function
 153                 (Symbol s) -> s
 154                   | _ -> eval_error "Invalid formal parameter list") l)
 155               | _ -> eval_error "Bad lambda syntax"
 156             in
 157             return (Closure (proper_body, state.env, syms))
 158           | ProperList (Symbol "call/cc"::[callee]) ->
 159             let continuation = Continuation (state.env, rest, state.pending_results) in
 160             eval { state with cont = callee::Rewind::rest; (* (EvalSeq 1):: *)
 161               pending_results = [continuation]::state.pending_results }
 162           | ProperList (Symbol "if"::test::true_case::[false_case]) ->
 163             eval { state with cont = test::Cond(true_case, false_case)::rest;
 164               pending_results = []::state.pending_results }
 165           | Cond (true_case, false_case) ->
 166             (match (List.hd current_res_frame) with
 167                 False ->
 168                   eval { state with cont = false_case::rest;
 169                     pending_results = older_res_frames }
 170               | _ -> eval { state with cont = true_case::rest;
 171                           pending_results = older_res_frames })
 172           | ProperList (f::params) ->
 173             eval { state with cont= params @ (f::Rewind::rest); (* (EvalSeq len):: *)
 174               pending_results = []::state.pending_results }
 175           | Rewind ->
 176             eval (rewind { state with cont = rest })
 177           | Closure (body, closure_env, formals) ->
 178             let env = (Environment.push_env_frame closure_env formals current_res_frame) in
 179             eval { env; cont=body::(RestoreEnv state.env)::rest; pending_results = older_res_frames }
 180           | RestoreEnv (env) ->
 181             eval { state with env; cont = rest }
 182           | Continuation (saved_env, saved_cont, saved_res) ->
 183             eval { env=saved_env;
 184                    cont= saved_cont;
 185                    pending_results = push_result saved_res (List.hd current_res_frame) }
 186           | Symbol op when is_some (builtin_option op) ->
 187             let fbuiltin = op |> builtin_option |> get_some in
 188             return (Builtin fbuiltin)
 189           | Builtin (fbuiltin) ->
 190             (match fbuiltin current_res_frame with
 191                 Some (result) ->
 192                   eval { state with pending_results = push_result older_res_frames result;
 193                     cont = rest }
 194               | None ->
 195                 eval { state with cont = rest;
 196                   pending_results = older_res_frames })
 197           | Symbol s ->
 198             return (Environment.lookup state.env s)
 199           | whatever ->
 200             return whatever) (* Int, String, Quotation, Null *)
 201     | [] -> state
 202 ;;
 203
 204
 205
 206 end
 207
 208
 209