shithub: martian9

ref: 4853f4341f2d0fa254630faf24e8a0eed55d8b63
dir: /m9.ml/

(*
  Martian Scheme
  Copyright 2020, McKay Marston

  This is a project for me to
    1) Get more familiar with OCaml.
    2) Try to provide a natively supported scheme for Plan9.

  It is heavily inspired by s9fes (http://www.t3x.org/s9fes), and the
  make a lisp project (https://github.com/kanaka/mal)
 *)

module T = Types.Types

let repl_env = Env.make (Some Core.base)

let rec quasiquote ast =
  match ast with
  | T.List { T.value = [ T.Symbol { T.value = "unquote" }; ast ] } -> ast
  | T.Vector { T.value = [ T.Symbol { T.value = "unquote" }; ast ] } -> ast
  | T.List
      { T.value =
          T.List { T.value = [ T.Symbol { T.value = "unquote-splicing" }; head ] } :: tail
      }
  | T.Vector
      { T.value =
          T.List { T.value = [ T.Symbol { T.value = "unquote-splicing" }; head ] } :: tail
      } -> Types.list [ Types.symbol "concat"; head; quasiquote (Types.list tail) ]
  | T.List { T.value = head :: tail } | T.Vector { T.value = head :: tail } ->
    Types.list [ Types.symbol "cons"; quasiquote head; quasiquote (Types.list tail) ]
  | ast -> Types.list [ Types.symbol "quote"; ast ]
;;

let is_macro_call ast env =
  match ast with
  | T.List { T.value = s :: args } ->
    (match
       try Env.get env s with
       | _ -> T.Nil
     with
    | T.Proc { T.meta = T.Map { T.value = meta } } ->
      Types.M9map.mem Core.kw_macro meta
      && Types.to_bool (Types.M9map.find Core.kw_macro meta)
    | _ -> false)
  | _ -> false
;;

let rec macroexpand ast env =
  if is_macro_call ast env
  then (
    match ast with
    | T.List { T.value = s :: args } ->
      (match
         try Env.get env s with
         | _ -> T.Nil
       with
      | T.Proc { T.value = f } -> macroexpand (f args) env
      | _ -> ast)
    | _ -> ast)
  else ast
;;

let rec eval_ast ast env =
  match ast with
  | T.Symbol s -> Env.get env ast
  | T.List { T.value = xs; T.meta } ->
    T.List { T.value = List.map (fun x -> eval x env) xs; T.meta }
  | T.Vector { T.value = xs; T.meta } ->
    T.Vector { T.value = List.map (fun x -> eval x env) xs; T.meta }
  | _ -> ast

and eval ast env =
  match ast with
  | T.List { T.value = [] } -> ast
  | T.List { T.value = [ T.Symbol { T.value = "define" }; key; expr ] } ->
    let value = eval expr env in
    Env.set env key value;
    value
  | T.List
      { T.value = [ T.Symbol { T.value = "let" }; T.Vector { T.value = bindings }; body ]
      }
  | T.List
      { T.value = [ T.Symbol { T.value = "let" }; T.List { T.value = bindings }; body ] }
    ->
    let sub_env = Env.make (Some env) in
    let rec bind_pairs = function
      | T.List { T.value = [ T.Symbol { T.value = sym }; expr ] } :: more ->
        let value = eval expr env in
        Env.set env (Types.symbol sym) value;
        bind_pairs more
      | _ -> ()
    in
    bind_pairs bindings;
    eval body sub_env
  | T.List
      { T.value =
          [ T.Symbol { T.value = "lambda" }; T.Vector { T.value = arg_names }; expr ]
      }
  | T.List
      { T.value =
          [ T.Symbol { T.value = "lambda" }; T.List { T.value = arg_names }; expr ]
      } ->
    Types.proc (function args ->
        let sub_env = Env.make (Some env) in
        let rec bind_args a b =
          match a, b with
          | [ T.Symbol { T.value = "&" }; name ], args ->
            Env.set sub_env name (Types.list args)
          | name :: names, arg :: args ->
            Env.set sub_env name arg;
            bind_args names args
          | [], [] -> ()
          | _ -> raise (Reader.Syntax_error "wrong parameter count for lambda")
        in
        bind_args arg_names args;
        eval expr sub_env)
  | T.List { T.value = T.Symbol { T.value = "begin" } :: body } ->
    List.fold_left (fun x expr -> eval expr env) T.Nil body
  | T.List { T.value = [ T.Symbol { T.value = "if" }; cond; then_expr; else_expr ] } ->
    if Types.to_bool (eval cond env) then eval then_expr env else eval else_expr env
  | T.List { T.value = [ T.Symbol { T.value = "if" }; cond; then_expr ] } ->
    if Types.to_bool (eval cond env) then eval then_expr env else T.Nil
  | T.List { T.value = [ T.Symbol { T.value = "quote" }; ast ] } -> ast
  | T.List { T.value = [ T.Symbol { T.value = "quasiquote" }; ast ] } ->
    eval (quasiquote ast) env
  | T.List _ ->
    (match eval_ast ast env with
    | T.List { T.value = T.Proc { T.value = f } :: args } -> f args
    | _ as x ->
      raise (Reader.Syntax_error ("\"" ^ Printer.print x true ^ "\" not a function")))
  | _ -> eval_ast ast env
;;

let nameplate = "Martian9 Scheme v0.1"
let read str = Reader.read str
let print exp = Printer.print exp true
let rep str env = print (eval (read str) env)

let rec main =
  try
    Core.init Core.base;
    Env.set
      repl_env
      (Types.symbol "eval")
      (Types.proc (function
          | [ ast ] -> eval ast repl_env
          | _ -> T.Nil));
    ignore
      (rep
         "(define load-file (lambda (f) (eval (read-string (string \"(begin \" (slurp f) \
          \")\")))))"
         repl_env);
    if Array.length Sys.argv > 1
    then print_endline (rep ("(load-file \"" ^ Sys.argv.(1) ^ "\")") repl_env)
    else (
      print_endline nameplate;
      while true do
        print_string "m9> ";
        let line = read_line () in
        try print_endline (rep line repl_env) with
        | End_of_file -> ()
        | Invalid_argument x ->
          output_string stderr ("Invalid argument: " ^ x ^ "\n");
          flush stderr
      done)
  with
  | End_of_file -> ()
;;