ref: 264e6b67b3caa3be6c4a23fca1a81adddc9d2bac
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 r7rs-small 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 - thanks
https://github.com/chouser for the fantastic implementation!)
*)
module T = Types.Types
let repl_env = Env.make (Some Core.base)
let synext_literals = T.String "syntax literals"
let synext_transformers = T.String "syntax transformers"
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.Macro m ->
print_endline "is_macro_call: true";
true
| 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)
| T.List { T.value = macro } ->
(match macro with
| kw :: _ -> kw = Types.symbol "syntax-rules"
| _ -> false)
| _ -> false)
| _ -> false
;;
let eval_macro sym args macro env =
(match macro with
| _ :: literals :: groups ->
let sgroups =
Str.global_replace
(Str.regexp "(_")
("(" ^ Printer.print sym true)
(Printer.dump groups)
in
print_endline ("BLARGH: " ^ sgroups);
print_endline
("TOKENIZED: " ^ String.concat " " (Reader.tokenize ("(" ^ sgroups ^ ")")));
let rec handle_groups groups =
match groups with
| hd :: tl ->
print_endline (" HD: " ^ Printer.print hd true ^ " tl: " ^ Printer.dump tl);
handle_groups tl
| _ -> print_endline "<list end>"
in
handle_groups groups;
let list_reader =
Reader.read_list ")" { list_form = []; tokens = Reader.tokenize (sgroups ^ ")") }
in
let slist = Types.list list_reader.list_form in
print_endline ("BLAAAARGH: " ^ Printer.print slist true)
| _ -> ());
let smacro =
Str.global_replace
(Str.regexp "(_")
("(" ^ Printer.print sym true)
(Printer.dump macro)
in
print_endline
("eval_macro: sym:"
^ Printer.print sym true
^ " args:"
^ Printer.dump args
^ " straight macro: "
^ Printer.dump macro);
print_endline (" subbed macro:" ^ smacro);
(* let sub_env = Env.make (Some env) in *)
match Reader.read smacro with
| T.List { T.value = transformer } ->
print_endline (" TRANSFORMER: " ^ Printer.dump transformer)
| _ -> ()
;;
let rec macroexpand ast env =
if is_macro_call ast env
then (
print_endline (" YES!: " ^ Printer.print ast true);
match ast with
| T.List { T.value = s :: args } ->
(match
try Env.get env s with
| _ -> T.Nil
with
| T.Macro { T.value = s; meta = m } ->
print_endline (" THIS IS A MACRO: " ^ Printer.print s true);
print_endline (" META: " ^ Printer.print m true);
print_endline (" ARGS: " ^ Printer.dump args);
ast
| T.Proc { T.value = f } -> macroexpand (f args) env
| T.List { T.value = macro } ->
eval_macro s args macro env;
ast
| _ -> 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 }
| T.Macro { T.value = m } ->
print_endline ("wait, what? " ^ Printer.print m true);
T.Nil
| _ -> ast
and eval ast env =
match macroexpand ast env with
| T.List { T.value = [] } -> ast
(* Can this be replaced with a define-syntax thing? *)
| T.List
{ T.value = [ T.Symbol { T.value = "define" }; T.List { T.value = arg_list }; body ]
} ->
let sym = List.hd arg_list in
let rest = List.tl arg_list in
let func =
eval
(Reader.read
("(lambda ("
^ String.concat " " (List.map (fun x -> Printer.print x false) rest)
^ ") "
^ Printer.print body true
^ ")"))
env
in
Env.set env sym func;
func
| 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 = "define-syntax" }; keyword; T.List { T.value = macro } ]
} ->
print_endline ("define-syntax: " ^ Printer.print keyword true);
(match macro with
| _ :: literals :: groups ->
let macro_entry =
Types.macro (Printer.print keyword true) literals (Types.list groups)
in
print_endline (" macro_entry: " ^ Printer.print macro_entry true);
print_endline (" literals: " ^ Printer.print literals true);
print_endline (" groups: " ^ Printer.dump groups);
Env.set env keyword macro_entry;
macro_entry
| _ -> T.Nil)
| 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)
(* Can these be replace with define-syntax stuff? *)
| 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 = "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 -> ()
;;