rops.ml

   1 (*********************************************************************
   2                                  AUX
   3 **********************************************************************)
   4
   5 let (|>) (p : 'a) (f : 'a -> 'b) = f p;;
   6
   7 let is_some = function
   8     Some x -> true
   9   | None -> false
  10
  11 let is_none x = not (is_some x);;
  12
  13 let get_some = function
  14     Some x -> x
  15   | None -> raise Not_found
  16
  17 exception Scheme_cast_error;;
  18
  19 exception Scheme_eval_error of string;;
  20 let eval_error s = raise (Scheme_eval_error s);;
  21
  22 type symbol = string ;;
  23
  24 (*
  25    A scheme object is anything that can be considered a value in Scheme. Notice that:
  26
  27    - Any symbolic expression can be an object (through the use of quote).
  28    - Some objects have a literal representation in the program (can be read), but others don't: Closures and Continuations are created through evaluation of some other expressions.
  29
  30  *)
  31 type scheme_object =
  32     Int of int
  33   | String of string
  34   | Symbol of symbol
  35   | Null
  36   | True
  37   | False
  38   | Quotation of scheme_object
  39   | ProperList of scheme_object list
  40   | ImproperList of (scheme_object list) * scheme_object
  41   | Closure of scheme_object * scheme_environment * (symbol list)
  42   | Continuation of scheme_environment * (scheme_object -> scheme_object)
  43 and
  44   environment_frame = (string, scheme_object) Hashtbl.t
  45 and
  46   scheme_environment = environment_frame list
  47 ;;
  48
  49 let get_int = function
  50     Int i -> i
  51   | _ -> raise Scheme_cast_error;;
  52
  53 (**********************************************************************
  54                              ENVIRONMENT
  55 **********************************************************************)
  56 let env_from_alist alist =
  57   let h = Hashtbl.create 1 in
  58   List.iter (fun (k, v) -> Hashtbl.add h k v) alist;
  59   h
  60 ;;
  61
  62 let push_env_frame env formals actuals =
  63   let h = Hashtbl.create (List.length formals) in
  64     List.iter
  65       (function (name, obj) -> Hashtbl.add h name obj )
  66       (List.combine formals actuals);
  67     h::env
  68 ;;
  69
  70 let lookup env k =
  71     Hashtbl.find (List.find (fun x -> Hashtbl.mem x k) env) k ;;
  72
  73 let current_env_frame  = function
  74     (e::rest) -> e
  75   | [] -> assert false
  76 ;;
  77
  78 (**********************************************************************
  79                                BUILTINS
  80  **********************************************************************)
  81 let make_arith_op_builtin_func (base:int) (f:int -> int -> int) =
  82         List.fold_left (fun x -> fun y -> Int (f (get_int x) (get_int y))) (Int base) ;;
  83
  84 let builtin_begin params = List.hd (List.rev params)
  85
  86 let builtin_option = function
  87     "+" -> Some (make_arith_op_builtin_func 0 ( + ))
  88   | "-" -> Some (make_arith_op_builtin_func 0 ( - ))
  89   | "*" -> Some (make_arith_op_builtin_func 1 ( * ))
  90   | "/" -> Some (make_arith_op_builtin_func 1 ( / ))
  91   | "begin" -> Some builtin_begin
  92   | _ -> None
  93 ;;
  94
  95 (**********************************************************************
  96                            EVALUATION
  97  **********************************************************************)
  98 let rec eval (e:scheme_environment) (exp:scheme_object) =
  99   let exp_eval = (eval e) in
 100     match exp with
 101       | ProperList (Symbol "define"::Symbol var::cdr)  ->
 102           let f = current_env_frame e in
 103             Hashtbl.add f var (exp_eval (ProperList ((Symbol "begin")::cdr)));
 104             Null
 105       | ProperList (Symbol "lambda"::formals::body) ->
 106           let proper_body = ProperList (Symbol "begin"::body) in
 107           let syms = match formals with
 108               ProperList l -> (List.map (function
 109                                              (Symbol s) -> s
 110                                          | _ -> eval_error "Invalid formal parameter list") l)
 111           | _ -> eval_error "Bad lambda syntax"
 112         in
 113           Closure (proper_body, e, syms)
 114     | ProperList (Symbol "if"::test::true_case::[false_case]) ->
 115         (match (exp_eval test) with
 116              False -> exp_eval false_case
 117            | _ -> exp_eval true_case)
 118     | ProperList (f::params) ->
 119         let evaluated_params = (List.map exp_eval params) in
 120           (match f with
 121                Symbol op when is_some (builtin_option op) ->
 122                  let fbuiltin = op |> builtin_option |> get_some in
 123                    (fbuiltin evaluated_params)
 124              | Closure (body, closure_env, formals) ->
 125                  eval (push_env_frame closure_env formals evaluated_params) body
 126              | _ -> eval_error "Cannot apply non-object" )
 127     | Symbol s ->
 128         lookup e s
 129     | whatever -> whatever (* Int, String, Quotation, Null *)
 130 ;;
 131
 132 (**********************************************************************
 133                                  CPS
 134  **********************************************************************)
 135 let rec eval_cps (e:scheme_environment) (exp:scheme_object) (return:scheme_object -> scheme_object) =
 136   let exp_eval = eval_cps e in
 137     match exp with
 138       | ProperList (Symbol "define"::Symbol var::[expression])  ->
 139           exp_eval expression (fun expression_value ->
 140                                  let f = current_env_frame e in
 141                                    Hashtbl.add f var expression_value;
 142                                    return Null)
 143       | ProperList (Symbol "lambda"::formals::body) ->
 144           let proper_body = ProperList (Symbol "begin"::body) in
 145           let syms = match formals with
 146               ProperList l -> (List.map (function
 147                                              (Symbol s) -> s
 148                                            | _ -> eval_error "Invalid formal parameter list") l)
 149             | _ -> eval_error "Bad lambda syntax"
 150           in
 151             return (Closure (proper_body, e, syms))
 152       | ProperList (Symbol "call/cc"::[callee]) ->
 153           let continuation = Continuation (e, return) in
 154             eval_application e callee [continuation] return
 155       | ProperList (Symbol "if"::test::true_case::[false_case]) ->
 156           exp_eval test (function
 157                              False -> exp_eval false_case return
 158                            | _ -> exp_eval true_case return)
 159       | ProperList (f::params) ->
 160           eval_list_cps e (ProperList params)
 161             (function
 162                  ProperList evaluated_params ->
 163                    (eval_application e f evaluated_params return)
 164                | _ -> invalid_arg "eval_list_cps did not return a proper list object")
 165     | Symbol s ->
 166         return (lookup e s)
 167     | whatever ->
 168         return whatever (* Int, String, Quotation, Null *)
 169 and eval_list_cps (env:scheme_environment) (exp:scheme_object) (return: scheme_object -> scheme_object) =
 170   match exp with
 171       ProperList [] as base -> return base
 172     | ProperList (car::cdr) ->
 173         eval_cps env car
 174           (fun (car_result:scheme_object) ->
 175              (eval_list_cps env (ProperList cdr)
 176                 (function
 177                      ProperList (cdr_result) -> return (ProperList (car_result::cdr_result))
 178                    |_ -> assert false)))
 179     | _ -> invalid_arg "eval_list_cps called with a non-list scheme object"
 180
 181 and eval_application e f evaluated_params return =
 182   match f with
 183       Symbol op when is_some (builtin_option op) ->
 184         let fbuiltin = op |> builtin_option |> get_some in
 185           return (fbuiltin evaluated_params)
 186     | _ -> eval_cps e f (function
 187                            | Closure (body, closure_env, formals) ->
 188                                eval_cps (push_env_frame closure_env formals evaluated_params) body return
 189                            | Continuation (e, escape_proc) ->
 190                                (escape_proc (List.hd evaluated_params))
 191                            | _ -> eval_error "Trying to apply something that is not a closure")
 192 ;;
 193
 194
 195 (**********************************************************************)
 196 let e = env_from_alist [("a", (Int 1));
 197                         ("b", (Int 2));
 198                         ("true-val", True);
 199                        ];;
 200
 201
 202 let print_res = function
 203     Int i -> (Printf.printf "Res: %d\n" i); Int i
 204   | _ -> assert false ;;
 205
 206 let eval0 = eval [e];;
 207 let eval1 obj = eval_cps [e] obj print_res;;
 208
 209 assert ((eval1 (ProperList [Symbol "+";Int 2; Symbol "a"])) = Int 3);;
 210 assert ((eval1 (ProperList [Symbol "begin"; Int 1; Int 2])) = Int 2);;
 211
 212 (***********************************************************************)
 213 eval1 (Int 1);;
 214
 215 (eval1 (ProperList [ Symbol "if";
 216                      Quotation (Symbol "true-val");
 217                      Int 1;
 218                      Int 0; ]));;
 219
 220 ((eval1 (ProperList [Symbol "+";Int 2; Symbol "a"])) = Int 3);;
 221 (eval1 (ProperList [ Symbol "begin";
 222                      ProperList [Symbol "define"; Symbol "x"; Int 3];
 223                      Symbol "x"]))