ref: cc10399b3b05fc3fcda7f04afe9b34fffa7f743a
parent: b34fba0e5b9e39fc5120f06b6c335033472f81ca
author: smazga <smazga@greymanlabs.com>
date: Thu Aug 6 09:33:45 EDT 2020
format and switch building to ocamlc for plan9
--- a/m9.ml
+++ b/m9.ml
@@ -12,37 +12,11 @@
module T = Types.Types
-module Env = Map.Make (String
-(*(struct
- type t = Types.Symbol
- let compare (Types.Symbol a) (Types.Symbol b) = compare a b
- end)*))
+let repl_env = Env.make (Some Core.base)
-(* replace me *)
-let num_fun f =
- Types.proc (function
- | [ T.Number a; T.Number b ] -> T.Number (f a b)
- | _ -> raise (Invalid_argument "Expected numeric argument"))
-;;
-
-(* replace me *)
-let repl_env =
- ref
- (List.fold_left
- (fun a b -> b a)
- Env.empty
- [ Env.add "+" (num_fun ( + ))
- ; Env.add "-" (num_fun ( - ))
- ; Env.add "*" (num_fun ( * ))
- ; Env.add "/" (num_fun ( / ))
- ])
-;;
-
let rec eval_ast ast env =
match ast with
- | T.Symbol { T.value = s } ->- (try Env.find s !env with
- | Not_found -> raise (Invalid_argument ("Symbol '" ^ s ^ "' not found")))+ | 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 } ->@@ -50,10 +24,61 @@
| _ -> ast
and eval ast env =
- let result = eval_ast ast env in
- match result with
- | T.List { T.value = T.Proc { T.value = f } :: args } -> f args- | _ -> result
+ 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
+ | sym :: expr :: more ->
+ Env.set sub_env sym (eval expr sub_env);
+ bind_pairs more
+ | [ _ ] -> raise (Invalid_argument "let missing body")
+ | [] -> ()
+ 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 (Invalid_argument "wrong parameter count")
+ 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 _ ->
+ (match eval_ast ast env with
+ | T.List { T.value = T.Proc { T.value = f } :: args } -> f args+ | _ -> raise (Invalid_argument "not a function"))
+ | _ -> eval_ast ast env
;;
let nameplate = "Martian9 Scheme v0.1"
@@ -63,6 +88,7 @@
let rec main =
try
+ Core.init Core.base;
print_endline nameplate;
while true do
print_string "m9> ";
--- a/mkfile
+++ b/mkfile
@@ -1,13 +1,19 @@
BIN=m9
-$BIN: types.cmx printer.cmx reader.cmx $BIN.cmx
- ocamlopt -o $target str.cmxa $prereq
+# $BIN: types.cmx env.cmx core.cmx printer.cmx reader.cmx $BIN.cmx
+# ocamlopt -o $target str.cmxa $prereq
+$BIN: types.cmo env.cmo core.cmo printer.cmo reader.cmo $BIN.cmo
+ ocamlc -o $target str.cma $prereq
+
%.cmx : %.ml
ocamlopt -c $stem.ml
+%.cmo : %.ml
+ ocamlc -c $stem.ml
+
install:V: $BIN
cp $prereq ~/bin/$BIN
clean:V:
- rm -f $BIN *.cmx *.cmi *.o
+ rm -f $BIN *.cmx *.cmi *.cmo
--- a/printer.ml
+++ b/printer.ml
@@ -8,6 +8,7 @@
| T.Vector { T.meta } -> meta | T.Record { T.meta } -> meta| _ -> T.Nil
+;;
let rec print obj readable =
let r = readable in
@@ -20,14 +21,18 @@
(* | T.Pair { T.value = one, two } -> "(" ^ one ^ " . " ^ two ^ ")" *)| T.Pair (p, q) -> "<pair unsupported>"
| T.Proc p -> "#<proc>"
- | T.Symbol {T.value = s} -> s+ | T.Symbol { T.value = s } -> s| T.Bytevector bv -> "<bytevector unsupported>"
| T.Eof_object -> "<eof>"
- | T.Number n -> string_of_int n
+ | T.Number n ->
+ if Types.is_float n.value
+ then string_of_float n.value
+ else string_of_int (int_of_float n.value)
| T.Port p -> "<port unsupported>"
| T.String s -> s (* need to handle escaping and stuff *)
| T.List { T.value = xs } ->- "(" ^ (String.concat " " (List.map (fun s -> print s r) xs)) ^ ")"- | T.Vector {T.value = v} -> "#(" ^ (String.concat " " (List.map (fun s -> print s r) v)) ^ ")"+ "(" ^ String.concat " " (List.map (fun s -> print s r) xs) ^ ")"+ | T.Vector { T.value = v } ->+ "#(" ^ String.concat " " (List.map (fun s -> print s r) v) ^ ")"| T.Record r -> "<record supported>"
-
+;;
--- a/reader.ml
+++ b/reader.ml
@@ -1,54 +1,79 @@
module T = Types.Types
-let token_re = Str.regexp "~@\\|[][{}()'`~^@]\\|\"\\(\\\\.\\|[^\"]\\)*\"?\\|;.*\\|[^][ \n{}('\"`,;)]*"+let token_re =
+ Str.regexp "~@\\|[][{}()'`~^@]\\|\"\\(\\\\.\\|[^\"]\\)*\"?\\|;.*\\|[^][ \n{}('\"`,;)]*"+;;
+
let string_re = Str.regexp "\"\\(\\\\.\\|[^\\\\\"]\\)*\""
-type reader = { form : Types.m9type; tokens : string list }-type list_reader = { list_form : Types.m9type list; tokens : string list }+type reader =
+ { form : Types.m9type+ ; tokens : string list
+ }
+type list_reader =
+ { list_form : Types.m9type list+ ; tokens : string list
+ }
+
let tokenize str =
List.map
- (function Str.Delim x -> x | Str.Text x -> "botch")
- (List.filter (function Str.Delim x -> true | Str.Text x -> false) (Str.full_split token_re str))
+ (function
+ | Str.Delim x -> x
+ | Str.Text x -> "tokenize botch")
+ (List.filter
+ (function
+ | Str.Delim x -> true
+ | Str.Text x -> false)
+ (Str.full_split token_re str))
+;;
let read_atom token =
match token with
- | "null" -> T.Nil
- | "true" -> T.Bool true
- | "false" -> T.Bool false
- | _ -> (
- match token.[0] with
- | '0' .. '9' -> T.Number (int_of_string token)
- | '-' -> (
- match String.length token with
- | 1 -> Types.symbol token
- | _ -> ( match token.[1] with '0' .. '9' -> T.Number (int_of_string token) | _ -> Types.symbol token ) )
- | '"' -> T.String token (* TODO: unescape *)
- | _ -> Types.symbol token )
+ | "null" -> T.Nil
+ | "#t" | "#true" -> T.Bool true
+ | "#f" | "#false" -> T.Bool false
+ | _ ->
+ (match token.[0] with
+ | '0' .. '9' -> Types.number (float_of_string token)
+ | '-' ->
+ (match String.length token with
+ | 1 -> Types.symbol token
+ | _ ->
+ (match token.[1] with
+ | '0' .. '9' -> Types.number (float_of_string token)
+ | _ -> Types.symbol token))
+ | '"' -> T.String token (* TODO: unescape *)
+ | _ -> Types.symbol token)
+;;
let rec read_list eol list_reader =
match list_reader.tokens with
- | [] ->
- print_endline "unexpected EOF";
- raise End_of_file
+ | [] ->
+ print_endline "unexpected EOF";
+ raise End_of_file
| token :: tokens ->
- if Str.string_match (Str.regexp eol) token 0 then
- { list_form = list_reader.list_form; tokens }- else
- let reader = read_form list_reader.tokens in
- read_list eol { list_form = list_reader.list_form @ [ reader.form ]; tokens = reader.tokens }+ if Str.string_match (Str.regexp eol) token 0
+ then { list_form = list_reader.list_form; tokens }+ else (
+ let reader = read_form list_reader.tokens in
+ read_list
+ eol
+ { list_form = list_reader.list_form @ [ reader.form ]; tokens = reader.tokens })and read_form all_tokens =
match all_tokens with
- | [] -> raise End_of_file
- | token :: tokens -> (
- match token with
- | "(" ->- let list_reader = read_list ")" { list_form = []; tokens } in- { form = Types.list list_reader.list_form; tokens = list_reader.tokens }- | "#|" ->
- let list_reader = read_list "|#" { list_form = []; tokens } in- { form = T.Comment; tokens = list_reader.tokens }- | _ -> if token.[0] = ';' then read_form tokens else { form = read_atom token; tokens } )+ | [] -> raise End_of_file
+ | token :: tokens ->
+ (match token with
+ | "(" ->+ let list_reader = read_list ")" { list_form = []; tokens } in+ { form = Types.list list_reader.list_form; tokens = list_reader.tokens }+ | "#|" ->
+ let list_reader = read_list "|#" { list_form = []; tokens } in+ { form = T.Comment; tokens = list_reader.tokens }+ | _ ->
+ if token.[0] = ';' then read_form tokens else { form = read_atom token; tokens })+;;
let read_str str = (read_form (tokenize str)).form
--- a/types.ml
+++ b/types.ml
@@ -1,5 +1,8 @@
module rec Types : sig
- type 'a with_meta = { value : 'a; meta : t }+ type 'a with_meta =
+ { value : 'a+ ; meta : t
+ }
and t =
| List of t list with_meta
@@ -12,7 +15,7 @@
| Symbol of string with_meta
| Bytevector of t list
| Eof_object
- | Number of int (* needs to handle more than one type *)
+ | Number of float with_meta
| Port of bool (* not sure how to represent this *)
| String of string
| Vector of t list with_meta
@@ -32,12 +35,20 @@
type m9type = Value.t
-let list x = Types.List { Types.value = x; meta = Types.Nil }+let to_bool x =
+ match x with
+ | Types.Nil | Types.Bool false -> false
+ | _ -> true
+;;
-let proc x = Types.Proc { Types.value = x; meta = Types.Nil }+let is_float v =
+ let c = classify_float (fst (Float.modf v)) in
+ c != FP_zero
+;;
+let list x = Types.List { Types.value = x; meta = Types.Nil }+let proc x = Types.Proc { Types.value = x; meta = Types.Nil } let symbol x = Types.Symbol { Types.value = x; meta = Types.Nil }-
let vector x = Types.Vector { Types.value = x; meta = Types.Nil }-
let record x = Types.Record { Types.value = x; meta = Types.Nil }+let number x = Types.Number { Types.value = x; meta = Types.Bool (is_float x) }