shithub: martian9

ref: 120a0cb0fd9df6a5da5d0ba480d6eb9b8b6d66a8
dir: /core.ml/

module T = Types.Types

let base = Env.make None
let kw_macro = T.String "macro"

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 seq = function
  | T.List { T.value = xs } -> xs
  | T.Vector { T.value = xs } -> xs
  | _ -> []
;;

(* this is 'assoc' from mal, but it's not what assoc is in scheme *)
let rec link = function
  | c :: k :: v :: (_ :: _ as xs) -> link (link [ c; k; v ] :: xs)
  | [ T.Nil; k; v ] -> Types.map (Types.M9map.add k v Types.M9map.empty)
  | [ T.Map { T.value = m; T.meta }; k; v ] ->
    T.Map { T.value = Types.M9map.add k v m; T.meta }
  | _ -> T.Nil
;;

let init env =
  Env.set
    env
    (Types.symbol "raise")
    (Types.proc (function
        | [ ast ] -> raise (Types.M9exn ast)
        | _ -> T.Nil));
  Env.set
    env
    (Types.symbol "*arguments*")
    (Types.list
       (if Array.length Sys.argv > 1
       then List.map (fun x -> T.String x) (List.tl (List.tl (Array.to_list Sys.argv)))
       else []));
  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 "proc?")
    (Types.proc (function
        | [ T.Proc { T.meta = T.Map { T.value = meta } } ] ->
          mk_bool
            (not
               (Types.M9map.mem kw_macro meta
               && Types.to_bool (Types.M9map.find kw_macro meta)))
        | [ T.Proc _ ] -> T.Bool true
        | _ -> T.Bool false));
  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.));
  Env.set
    env
    (Types.symbol "display")
    (Types.proc (function xs ->
         print_string (String.concat " " (List.map (fun s -> Printer.print s false) xs));
         T.Eof_object));
  Env.set
    env
    (Types.symbol "string")
    (Types.proc (function xs ->
         T.String (String.concat "" (List.map (fun s -> Printer.print s false) xs))));
  Env.set
    env
    (Types.symbol "read-string")
    (Types.proc (function
        | [ T.String x ] -> Reader.read x
        | _ -> T.Nil));
  Env.set
    env
    (Types.symbol "slurp")
    (Types.proc (function
        | [ T.String x ] -> T.String (Reader.slurp x)
        | _ -> T.Nil));
  Env.set
    env
    (Types.symbol "cons")
    (Types.proc (function
        | [ x; xs ] -> Types.list [ x; xs ]
        | _ -> T.Nil));
  Env.set
    env
    (Types.symbol "concat")
    (Types.proc
       (let rec concat = function
          | x :: y :: more -> concat (Types.list (seq x @ seq y) :: more)
          | [ (T.List _ as x) ] -> x
          | [ x ] -> Types.list (seq x)
          | [] -> Types.list []
        in
        concat))
;;