shithub: martian9

ref: 0560b9b189c123d48e91231a3adf15016c0a49d9
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 seq = function
  | T.List {T.value= xs; meta= _} -> xs
  | T.Vector {T.value= xs; meta= _} -> 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= []; meta= _}] -> T.Bool true
      | [T.Vector {T.value= []; meta= _}] -> T.Bool true
      | _ -> T.Bool false ) ) ;
  Env.set env (Types.symbol "count")
    (Types.proc (function
      | [T.List {T.value= xs; meta= _}]
       |[T.Vector {T.value= xs; meta= _}] ->
          Types.number (float_of_int (List.length xs))
      | _ -> Types.number 0. ) ) ;
  Env.set env (Types.symbol "display")
    (Types.proc (function xs ->
         print_string (Printer.stringify xs false) ;
         T.Unspecified ) ) ;
  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 ) )