shithub: martian9

ref: 5fa933a00fd0a280221439c54a246600d454ecc7
dir: /core.ml/

module T = Types.Types

let base = Env.make None

let number_compare t f =
  Types.proc (function
      | [ T.Number a; T.Number b ] -> t (f a.value b.value)
      | _ -> raise (Invalid_argument "not a number"))
;;

let simple_compare t f =
  Types.proc (function
      | [ T.Number a; T.Number b ] -> t (f a b)
      | _ -> raise (Invalid_argument "incomparable"))
;;

let mk_num x = Types.number x
let mk_bool x = T.Bool x

let init env =
  Env.set env (Types.symbol "+") (number_compare mk_num ( +. ));
  Env.set env (Types.symbol "-") (number_compare mk_num ( -. ));
  Env.set env (Types.symbol "*") (number_compare mk_num ( *. ));
  Env.set env (Types.symbol "/") (number_compare mk_num ( /. ));
  Env.set env (Types.symbol "<") (simple_compare mk_bool ( < ));
  Env.set env (Types.symbol "<=") (simple_compare mk_bool ( <= ));
  Env.set env (Types.symbol ">") (simple_compare mk_bool ( > ));
  Env.set env (Types.symbol ">=") (simple_compare mk_bool ( >= ));
  Env.set
    env
    (Types.symbol "number?")
    (Types.proc (function
        | [ T.Number _ ] -> T.Bool true
        | _ -> T.Bool false));
  Env.set env (Types.symbol "list") (Types.proc (function xs -> Types.list xs));
  Env.set
    env
    (Types.symbol "list?")
    (Types.proc (function
        | [ T.List _ ] -> T.Bool true
        | _ -> T.Bool false));
  Env.set env (Types.symbol "vector") (Types.proc (function xs -> Types.vector xs));
  Env.set
    env
    (Types.symbol "vector?")
    (Types.proc (function
        | [ T.Vector _ ] -> T.Bool true
        | _ -> T.Bool false));
  Env.set
    env
    (Types.symbol "empty?")
    (Types.proc (function
        | [ T.List { T.value = [] } ] -> T.Bool true
        | [ T.Vector { T.value = [] } ] -> T.Bool true
        | _ -> T.Bool false));
  Env.set
    env
    (Types.symbol "count")
    (Types.proc (function
        | [ T.List { T.value = xs } ] | [ T.Vector { T.value = xs } ] ->
          Types.number (float_of_int (List.length xs))
        | _ -> Types.number 0.))
;;