ref: 8493d9a4b6c4ce926637287bbc437d8bb2ca2baa
parent: db23aa72a4d43083867fc28c5ec1664a3442645b
author: McKay Marston <mckay.marston@greymanlabs.com>
date: Wed Sep 16 18:06:15 EDT 2020
further macroing
--- a/core.ml
+++ b/core.ml
@@ -27,8 +27,7 @@
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.Map { T.value = m; T.meta }; k; v ] -> T.Map { T.value = Types.M9map.add k v m; T.meta }| _ -> T.Nil
;;
@@ -96,8 +95,7 @@
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))
+ | [ T.List { T.value = xs } ] | [ T.Vector { T.value = xs } ] -> Types.number (float_of_int (List.length xs))| _ -> Types.number 0.));
Env.set
env
@@ -108,8 +106,7 @@
Env.set
env
(Types.symbol "string")
- (Types.proc (function xs ->
- T.String (String.concat "" (List.map (fun s -> Printer.print s false) xs))));
+ (Types.proc (function xs -> T.String (String.concat "" (List.map (fun s -> Printer.print s false) xs))));
Env.set
env
(Types.symbol "read-string")
--- a/env.ml
+++ b/env.ml
@@ -12,8 +12,7 @@
let set env sym value =
match sym with
- | T.Symbol { T.value = key } ->- (* print_endline ("Env.set: " ^ key); *) env.data := Data.add key value !(env.data)+ | T.Symbol { T.value = key } -> (* print_endline ("Env.set: " ^ key); *) env.data := Data.add key value !(env.data)| _ -> raise (Invalid_argument "set: not a symbol")
;;
--- a/eval.ml
+++ b/eval.ml
@@ -4,14 +4,9 @@
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 = 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 ]
@@ -20,10 +15,8 @@
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.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 preparse ast env =
@@ -40,26 +33,15 @@
* eval foo env
* | _ -> ast)
* | _ -> ast *)
-
and eval ast env =
- (* match preparse ast env with *)
match ast 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 ]- } ->
+ | 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 ("- ^ Printer.stringify rest false
- ^ ") "
- ^ Printer.print body true
- ^ ")"))
- env
+ eval (Reader.read ("(lambda (" ^ Printer.stringify rest false ^ ") " ^ Printer.print body true ^ ")")) envin
Env.set env sym func;
func
@@ -67,32 +49,20 @@
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 } ]- } ->
+ | T.List { T.value = [ T.Symbol { T.value = "define-syntax" }; keyword; T.List { T.value = macro } ] } ->(match macro with
- | _ :: literals :: groups ->
- let macro_entry =
- Types.macro (Printer.print keyword true) literals (Types.list groups)
- in
+ | _ :: literals :: groups ->
+ let macro_entry = Types.macro (Printer.print keyword true) literals (Types.list groups) in
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 ]- } ->
+ | 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)
+ | [ 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
@@ -102,12 +72,8 @@
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 ] }- ->
+ | 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 ->@@ -125,8 +91,7 @@
| 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 { 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@@ -135,7 +100,6 @@
let foo = Macro.expand ast env args sym meta in
print_endline (":::: " ^ Printer.print foo true);eval foo env
- | _ as x ->
- raise (Reader.Syntax_error ("'" ^ Printer.print x true ^ "' not a function")))+ | _ as x -> raise (Reader.Syntax_error ("'" ^ Printer.print x true ^ "' not a function")))| _ -> eval_ast ast env
;;
--- a/m9.ml
+++ b/m9.ml
@@ -27,11 +27,7 @@
(Types.proc (function
| [ ast ] -> Eval.eval ast repl_env
| _ -> T.Nil));
- ignore
- (rep
- "(define load-file (lambda (f) (eval (read-string (string \"(begin \" (slurp f) \
- \")\")))))"
- repl_env);
+ 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 (
--- a/macro.ml
+++ b/macro.ml
@@ -18,8 +18,7 @@
(* print_endline " LIST <-> LIST"; *)
if ph = "_" || (ph = Printer.print sym true && sym = ah)
then is_matching_pattern sym pt at matched && true
- else
- (* print_endline (" ------> " ^ ph ^ " vs " ^ Printer.print ah true); *)+ else (* print_endline (" ------> " ^ ph ^ " vs " ^ Printer.print ah true); *)is_matching_pattern sym pt at matched
| ph :: pt, [] ->
(* print_endline " LIST <-> []";
@@ -47,7 +46,7 @@
print_endline ("missing: " ^ string_of_int missing); (* print_endline (" NEED TO ADD " ^ string_of_int missing ^ " PLACEHOLDERS"); *)match missing with
- | _ when (missing = 0 || missing > 0) ->
+ | _ when missing = 0 || missing > 0 ->
(* add arguments *)
print_endline ("ADD " ^ string_of_int missing ^ " arguments");for i = 1 to missing do
@@ -81,8 +80,7 @@
print_endline (" template_str: " ^ template_str); print_endline ("(" ^ pattern_str ^ ") " ^ template_str ^ ")"); "(" ^ pattern_str ^ ") " ^ template_str ^ ")"- | _ ->
- "(" ^ Printer.dump pattern ^ ") " ^ Printer.print template true ^ ")"+ | _ -> "(" ^ Printer.dump pattern ^ ") " ^ Printer.print template true ^ ")";;
let lambdaize pattern template args =
@@ -89,8 +87,7 @@
match pattern, args with
| ph :: pt, ah :: at :: rest ->
print_endline ("lambdaize: list list: args: " ^ Printer.stringify args true);- Reader.read
- ("((lambda " ^ ellipsis pt template args ^ Printer.stringify args false ^ ")")+ Reader.read ("((lambda " ^ ellipsis pt template args ^ Printer.stringify args false ^ ")")| ph :: pt, ah :: at ->
print_endline "lambdaize: list short";
Reader.read
@@ -103,12 +100,7 @@
^ ")")
| ph :: pt, [] ->
print_endline "lambdaize: list empty";
- Reader.read
- ("((lambda ("- ^ Printer.stringify pt false
- ^ ") "
- ^ Printer.print template true
- ^ "))")
+ Reader.read ("((lambda (" ^ Printer.stringify pt false ^ ") " ^ Printer.print template true ^ "))")| _ ->
print_endline "lambdaize: empty";
Reader.read ("((lambda () " ^ Printer.print template true ^ "))")@@ -118,7 +110,7 @@
print_endline ("\n\nTHIS IS A MACRO: " ^ Printer.print sym true); print_endline (" META: " ^ Printer.print meta true); print_endline (" ARGS: " ^ Printer.dump args);- print_endline (" AST: " ^ Printer.print ast true);+ print_endline (" AST: " ^ Printer.print ast true);match meta with
| T.Map { T.value = m } ->((* let literals = Types.M9map.find Types.macro_literals m in *)
@@ -135,27 +127,17 @@
| hd :: tl ->
(* print_endline (" transform: " ^ Printer.print hd true); *)(match hd with
- | T.List
- { T.value = [ T.List { T.value = pattern }; T.List { T.value = template } ]- } ->
+ | T.List { T.value = [ T.List { T.value = pattern }; T.List { T.value = template } ] } ->(* print_endline " MULTI";
* print_endline (" - template: " ^ Printer.dump template); *)print_endline
(" matched (m)?: "- ^ (if is_matching_pattern
- sym
- (List.map (fun x -> Printer.print x true) pattern)
- (Core.seq ast)
- true
+ ^ (if is_matching_pattern sym (List.map (fun x -> Printer.print x true) pattern) (Core.seq ast) true
then "yes"
else "no")
^ " ::> "
^ Printer.dump pattern);
- if is_matching_pattern
- sym
- (List.map (fun x -> Printer.print x true) pattern)
- (Core.seq ast)
- true
+ if is_matching_pattern sym (List.map (fun x -> Printer.print x true) pattern) (Core.seq ast) true
then lambdaize pattern (Types.list template) args
else match_transform tl
| T.List { T.value = [ T.List { T.value = pattern }; atom ] } ->@@ -162,33 +144,20 @@
(* print_endline " SINGLE"; *)
print_endline
(" matched (s)?: "- ^ (if is_matching_pattern
- sym
- (List.map (fun x -> Printer.print x true) pattern)
- (Core.seq ast)
- true
+ ^ (if is_matching_pattern sym (List.map (fun x -> Printer.print x true) pattern) (Core.seq ast) true
then "yes"
else "no")
^ " ::> "
^ Printer.dump pattern);
- if is_matching_pattern
- sym
- (List.map (fun x -> Printer.print x true) pattern)
- (Core.seq ast)
- true
+ if is_matching_pattern sym (List.map (fun x -> Printer.print x true) pattern) (Core.seq ast) true
then lambdaize pattern atom args
else match_transform tl
| _ -> raise (Reader.Syntax_error "Unknown"))
(* errors? *)
- | [] ->
- raise
- (Reader.Syntax_error
- ("No matching transform for macro: '" ^ Printer.print sym true))+ | [] -> raise (Reader.Syntax_error ("No matching transform for macro: '" ^ Printer.print sym true))in
match_transform (Core.seq transformers)
with
- | Not_found ->
- raise
- (Reader.Syntax_error ("'" ^ Printer.print sym true ^ "' is not a known macro")))+ | Not_found -> raise (Reader.Syntax_error ("'" ^ Printer.print sym true ^ "' is not a known macro")))| _ -> raise (Reader.Syntax_error "syntax error with defined macro")
;;
--- a/printer.ml
+++ b/printer.ml
@@ -19,12 +19,7 @@
| T.Nil -> "nil"
| T.Macro { T.value = xs } -> "#<macro>" ^ print xs r | T.Map { T.value = xs } ->- "{"- ^ Types.M9map.fold
- (fun k v s -> s ^ (if s = "" then "" else " ") ^ print k r ^ " " ^ print v r)
- xs
- ""
- ^ "}"
+ "{" ^ Types.M9map.fold (fun k v s -> s ^ (if s = "" then "" else " ") ^ print k r ^ " " ^ print v r) xs "" ^ "}"| T.Unspecified -> "#unspecified"
| T.Eof_object -> "#eof"
(* | T.Pair ({ T.value = one }, { T.value = two }) -> "(" ^ (print one readable) ^ " . " ^ (print two readable) ^ ")" *)@@ -31,10 +26,7 @@
| T.Proc p -> "#<proc>"
| T.Symbol { T.value = s } -> s| T.Bytevector bv -> "<bytevector unsupported>"
- | 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.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 ->
if r
--- a/reader.ml
+++ b/reader.ml
@@ -2,10 +2,7 @@
exception Syntax_error of string
-let token_re =
- Str.regexp "~@\\|[][{}()'`~^@]\\|\"\\(\\\\.\\|[^\"]\\)*\"?\\|;.*\\|[^][ \n{}('\"`,;)]*"-;;
-
+let token_re = Str.regexp "~@\\|[][{}()'`~^@]\\|\"\\(\\\\.\\|[^\"]\\)*\"?\\|;.*\\|[^][ \n{}('\"`,;)]*"let string_re = Str.regexp "\"\\(\\\\.\\|[^\\\\\"]\\)*\""
type reader =
@@ -88,9 +85,7 @@
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 })+ read_list eol { list_form = list_reader.list_form @ [ reader.form ]; tokens = reader.tokens })and read_quote sym tokens =
let reader = read_form tokens in
@@ -121,8 +116,7 @@
let list_reader = read_list ")" { list_form = []; tokens } in { form = Types.list list_reader.list_form; tokens = list_reader.tokens }| "" | "\t" | "\n" -> read_form tokens
- | _ ->
- if token.[0] = ';' then read_form tokens else { form = read_atom token; tokens })+ | _ -> if token.[0] = ';' then read_form tokens else { form = read_atom token; tokens });;
let slurp filename =
--- a/types.ml
+++ b/types.ml
@@ -73,8 +73,6 @@
let macro sym literals transformers =
let meta = ref M9map.empty in
- meta
- := M9map.add macro_literals literals !meta
- |> M9map.add macro_transformers transformers;
+ meta := M9map.add macro_literals literals !meta |> M9map.add macro_transformers transformers;
Types.Macro { Types.value = symbol sym; meta = map !meta };;