ref: dc596842d658ab664a025d4e98c89b50cac465c4
parent: b6f4824d97a68ecfa763e1edcbef629ff3ba1cfc
author: McKay Marston <mckay.marston@greymanlabs.com>
date: Fri Nov 20 14:56:03 EST 2020
macro update
--- a/env.ml
+++ b/env.ml
@@ -12,13 +12,14 @@
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; T.meta = _ } ->+ (* print_endline ("Env.set: " ^ key); *) env.data := Data.add key value !(env.data)| _ -> raise (Invalid_argument "set: not a symbol")
;;
let rec find env sym =
match sym with
- | T.Symbol { T.value = key } ->+ | T.Symbol { T.value = key; T.meta = _ } ->if Data.mem key !(env.data)
then Some env
else (
@@ -30,9 +31,17 @@
let get env sym =
match sym with
- | T.Symbol { T.value = key } ->+ | T.Symbol { T.value = key; T.meta = _ } ->(match find env sym with
| Some found_env -> Data.find key !(found_env.data)
| None -> raise (Runtime_error ("unknown symbol '" ^ key ^ "'")))| _ -> raise (Invalid_argument "get: not a symbol")
;;
+
+(* let string_of_env env =
+ * let string = ref "" in
+ * (match env with
+ * | { outer; data = data } ->+ * Data.iter (fun k v -> string := !string ^ "[" ^ k ^ "|" ^ v ^ "]") !data;
+ * | _ -> ());
+ * !string *)
--- a/eval.ml
+++ b/eval.ml
@@ -16,51 +16,15 @@
(* print_endline ("EVAL_AST: " ^ Printer.print ast true); *)match ast with
| T.Symbol s -> Env.get env ast
- (* | T.Symbol s -> let foo = Env.get env ast in(\* (match Env.get env ast with *\)
- * print_endline ("EVAL_AST: " ^ Printer.print foo true);- * (match foo with
- * | T.Macro { T.value = sym; meta } -> raise (Utils.Syntax_error ("EVAL_AST MACRO: ast: " ^ Printer.print ast true))- * | T.List { T.value = xs; meta } -> raise (Utils.Syntax_error "EVAL_AST LIST")- * | _ as x -> print_endline ("EVAL_AST UNKNOWN: " ^ Printer.print ast true ^ ":" ^ Printer.print x true); foo)- *)
| T.List { T.value = xs; T.meta } ->(match
try Env.get env (List.hd xs) with
| _ -> T.Nil
with
- (* disabled for macro_read development *)
-
- (* | T.Macro { T.value = sym; meta } as om ->- * print_endline (" EVAL_AST: the rest: " ^ Printer.dump (List.tl xs));- * print_endline (" EVAL_AST: AST: " ^ Printer.print ast true);- * let foo = Macro.expand ast env (List.tl xs) sym meta in
- * print_endline (" expanded: " ^ Printer.print foo true);- * T.List { T.value = [ om; foo ]; T.meta } *)-
- (* T.List { T.value = [foo]; T.meta } *)- (* T.List { T.value = [ Types.symbol (Printer.print sym true); foo; T.List { T.value = (List.tl xs); T.meta } ]; T.meta } *)- (* T.List { T.value = [eval foo env]; T.meta } *)- (* eval foo env *)
- (* raise (Utils.Syntax_error ("EVAL_AST MACRO: ast: " ^ Printer.print ast true)) *) | _ -> T.List { 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 =
- * print_endline ("preparse: " ^ 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 = sym; meta } ->- * let foo = Macro.expand ast env args sym meta in
- * print_endline (" expanded: " ^ Printer.print foo true);- * eval foo env
- * | _ -> ast)
- * | _ -> ast *)
and eval ast env =
print_endline ("AST: " ^ Printer.print ast true);match ast with
@@ -72,6 +36,8 @@
let func =
eval (Reader.read ("(lambda (" ^ Printer.stringify rest false ^ ") " ^ Printer.print body true ^ ")")) envin
+ print_endline ("DEFINE: " ^ Printer.print sym true);+ print_endline (" => " ^ "(lambda (" ^ Printer.stringify rest false ^ ") " ^ Printer.print body true ^ ")");Env.set env sym func;
func
| T.List { T.value = [ T.Symbol { T.value = "define" }; key; expr ] } ->@@ -78,13 +44,6 @@
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 } ] } ->- * (match macro with
- * | _ :: 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 ] } ->Types.proc (function args ->
@@ -96,7 +55,14 @@
Env.set sub_env name arg;
bind_args names args
| [], [] -> ()
- | _ -> raise (Utils.Syntax_error ("wrong parameter count for lambda: " ^ Printer.dump arg_names))+ | _ ->
+ raise
+ (Utils.Syntax_error
+ ("wrong parameter count for lambda: arg_names:["+ ^ Printer.dump arg_names
+ ^ "] args:["
+ ^ Printer.dump args
+ ^ "]"))
in
bind_args arg_names args;
eval expr sub_env)
@@ -127,11 +93,6 @@
| T.List { T.value = T.Macro { T.value = _ } :: macro :: _ } ->print_endline "MACRO EVALUATION";
eval macro env
- (* | T.List { T.value = T.Macro { T.value = sym; meta } :: args } ->- * (\* eval (Macro.expand ast env args sym meta) env *\)
- * let foo = Macro.expand ast env args sym meta in
- * print_endline (":::: " ^ Printer.print foo true);- * eval foo env *)
| _ as x -> raise (Utils.Syntax_error ("'" ^ Printer.print x true ^ "' not a function")))| _ -> eval_ast ast env
;;
--- a/macro.ml
+++ b/macro.ml
@@ -83,115 +83,6 @@
| _ -> "(" ^ Printer.dump pattern ^ ") " ^ Printer.print template true ^ ")";;
-(* let lambdaize pattern template args =
- * match pattern, args with
- * | ph :: pt, ah :: at :: rest ->
- * let expr = "((lambda " ^ ellipsis pt template args ^ Printer.stringify args false ^ ")" in
- * print_endline (" lambdaize list list: " ^ expr);- * Reader.read expr
- * | ph :: pt, ah :: at ->
- * let expr =
- * "((lambda ("- * ^ Printer.stringify pt true
- * ^ ")"
- * ^ Printer.print template true
- * ^ ")"
- * ^ Printer.stringify args true
- * ^ ")"
- * in
- * print_endline (" lambdaize short list: " ^ expr);- * Reader.read expr
- * | ph :: pt, [] ->
- * let expr = "((lambda (" ^ Printer.stringify pt false ^ ") " ^ Printer.print template false ^ "))" in- * print_endline (" lambdaize empty list: " ^ expr);- * Reader.read expr
- * | _ ->
- * print_endline "lambdaize: empty";
- * Reader.read ("((lambda () " ^ Printer.print template true ^ "))")- * ;; *)
-
-(* let rec expand ast env args sym meta =
- * 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);- * match meta with
- * | T.Map { T.value = m } ->- * ((\* let literals = Types.M9map.find Types.macro_literals m in *\)
- * try
- * let transformers = Types.M9map.find Types.macro_transformers m in
- * print_endline
- * (" -- EVAL_MACRO: "- * (\* ^ " literals: "
- * * ^ Printer.print literals true *\)
- * ^ " transformers: "
- * ^ Printer.print transformers true);
- * let rec match_transform transforms =
- * match transforms with
- * | 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 } ] } ->- * (\* 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
- * 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
- * then lambdaize pattern (Types.list template) args
- * else match_transform tl
- * | T.List { T.value = [ T.List { T.value = pattern }; atom ] } ->- * (\* 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
- * 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
- * then lambdaize pattern atom args
- * else match_transform tl
- * | _ -> raise (Utils.Syntax_error "Unknown"))
- * (\* errors? *\)
- * | [] -> raise (Utils.Syntax_error ("No matching transform for macro: '" ^ Printer.print sym true))- * in
- * match_transform (Core.seq transformers)
- * with
- * | Not_found -> raise (Utils.Syntax_error ("'" ^ Printer.print sym true ^ "' is not a known macro")))- * | _ -> raise (Utils.Syntax_error "syntax error with defined macro")
- * ;; *)
-
-(* let rec parse ast env args sym meta =
- * print_endline("\n\nREADING MACRO: " ^ Printer.print sym true);- * match meta with
- * | T.Map { T.value = m } ->- * (try
- * let transformers = Types.M9map.find Types.macro_transformers m in
- * let rec match_transform transforms =
- * match transforms with
- * | hd :: tl ->
- * (match hd with
- * | T.List { T.value = [ T.List { T.value = pattern }; T.List {T.value = template } ] } ->- * 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 ] } ->- * 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 (Utils.Syntax_error "no transform match"))
- * | [] -> raise (Utils.Syntax_error ("No matching transform for macro: '" ^ Printer.print sym true))- * in
- * match_transform (Core.seq transformers)
- * with
- * | Not_found -> raise (Utils.Syntax_error ("'" ^ Printer.print sym true ^ "' is not a known macro")))- * | _ -> raise (Utils.Syntax_error "syntax error with defined macro") *)
-
let rec parse ast macros =
print_endline ("\n\nREADING MACRO: " ^ String.concat " " ast);match ast with
@@ -199,33 +90,6 @@
| macro :: tokens -> print_endline (" macro: " ^ macro);;
-(* let add_variant sym variant env =
- * let new_variant = gen_sym sym in
- * match
- * try Env.get env (Types.symbol sym) with
- * | _ -> T.Nil
- * with
- * | T.Macro { T.value = sym; meta } ->- * (match meta with
- * | T.Map { T.value = m } ->- * let variants = ref (Types.M9map.find Types.macro_variants m) in
- * Types.M9map.add new_variant variant !variants;
- * print_endline ("ADD_VARIANT: " ^ (Printer.print new_variant true) ^ ": " ^ Printer.print meta true);- * print_endline (" variants: " ^ Printer.print !variants true)- * | _ -> raise (Utils.Runtime_error ("macro " ^ (Printer.print sym true) ^ " is missing its variants")))- * | _ -> raise (Utils.Syntax_error "add_variant botch") *)
-
-(* let macro = Env.get env (Types.symbol sym) in
- * let variants = Types.M9map.find Types.macro_variants macro.meta *)
-(* match
- * try Env.get env (Types.symbol sym) with
- * | _ -> T.Nil
- * with
- * | T.Macro { T.value = sym; meta } ->- * let variants = Types.M9map.find Types.macro_variants meta in
- * Types.M9map.add Types.macro_variants (new_variant :: variants) meta
- * | _ -> raise (Utils.Runtime_error ("wayward variant of " ^ sym ^ ": " ^ variant)) *)-
let generate_variants sym literals patterns =
let symbol = Printer.print sym true in
let variants = ref Types.M9map.empty in
@@ -246,47 +110,27 @@
let match_variant macro args =
let vmatch = ref "" in
(match macro with
- | T.Map { T.value = meta } ->- (match Types.M9map.find Types.macro_variants meta with
- | T.Map { T.value = variant_list } ->- Types.M9map.iter
- (fun k v ->
- print_endline (Printer.print k true ^ ": " ^ Printer.print v true);
- match v with
- | T.List { T.value = T.List { T.value = x } :: z } ->- print_endline
- (" >>>> [" ^ string_of_int (List.length args) ^ "|"- ^ string_of_int (List.length x) ^ "] "
- ^ Printer.dump x ^ " :: " ^ Printer.dump z);
- if List.length args = List.length x
- then vmatch := (Printer.print (List.hd x) true)
- | _ -> ())
- variant_list
- | _ -> ())
- | _ -> ());
+ | T.Map { T.value = meta } ->+ (match Types.M9map.find Types.macro_variants meta with
+ | T.Map { T.value = variant_list } ->+ Types.M9map.iter
+ (fun k v ->
+ print_endline (Printer.print k true ^ ": " ^ Printer.print v true);
+ match v with
+ | T.List { T.value = T.List { T.value = x } :: z } ->+ print_endline
+ (" >>>> ["+ ^ string_of_int (List.length args)
+ ^ "|"
+ ^ string_of_int (List.length x)
+ ^ "] "
+ ^ Printer.dump x
+ ^ " :: "
+ ^ Printer.dump z);
+ if List.length args = List.length x then vmatch := Printer.print (List.hd x) true
+ | _ -> ())
+ variant_list
+ | _ -> ())
+ | _ -> ());
!vmatch
;;
-
-(* match meta with
- * | T.Map { T.value = m } ->- * (try
- * let transformers = Types.M9map.find Types.macro_transformers m in
- * let rec match_transform transforms =
- * match transforms with
- * | hd :: tl ->
- * (match hd with
- * | T.List { T.value = [ T.List { T.value = pattern }; T.List {T.value = template } ] } ->- * 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 ] } ->- * 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 (Utils.Syntax_error "no transform match"))
- * | [] -> raise (Utils.Syntax_error ("No matching transform for macro: '" ^ Printer.print sym true))- * in
- * match_transform (Core.seq transformers)
- * with
- * | Not_found -> raise (Utils.Syntax_error ("'" ^ Printer.print sym true ^ "' is not a known macro")))- * | _ -> raise (Utils.Syntax_error "syntax error with defined macro") *)
--- a/notes.org
+++ b/notes.org
@@ -44,6 +44,7 @@
* Macros
** and
(define-syntax and (syntax-rules ()
- ((and) #t)
- ((and test) test) ((and test1 test2 ...)
- (if test1 (and test2 ...) #f))))
+ ((_) #t)
+ ((_ test) test)
+ ((_ test1 test2 ...)
+ (if test1 (_ test2 ...) #f))))
--- a/printer.ml
+++ b/printer.ml
@@ -2,11 +2,11 @@
let meta obj =
match obj with
- | T.List { T.meta } -> meta- | T.Proc { T.meta } -> meta- | T.Symbol { T.meta } -> meta- | T.Vector { T.meta } -> meta- | T.Record { T.meta } -> meta+ | T.List { T.value = _; T.meta } -> meta+ | T.Proc { T.value = _; T.meta } -> meta+ | T.Symbol { T.value = _; T.meta } -> meta+ | T.Vector { T.value = _; T.meta } -> meta+ | T.Record { T.value = _; T.meta } -> meta| _ -> T.Nil
;;
@@ -17,17 +17,17 @@
| T.Bool false -> "#f"
| T.Char c -> "#\\" ^ Char.escaped c
| T.Nil -> "nil"
- | T.Macro { T.value = xs } -> "#<macro>" ^ print xs r- | T.Map { T.value = xs } ->+ | T.Macro { T.value = xs; T.meta = _ } -> "#<macro>" ^ print xs r+ | T.Map { T.value = xs; T.meta = _ } -> "{" ^ 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) ^ ")" *)- | T.Proc p -> "#<proc>"
- | T.Symbol { T.value = s } -> s- | T.Bytevector bv -> "<bytevector unsupported>"
+ | T.Proc _ -> "#<proc>"
+ | T.Symbol { T.value = s; T.meta = _ } -> s+ | T.Bytevector _ -> "<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.Port p -> "<port unsupported>"
+ | T.Port _ -> "<port unsupported>"
| T.String s ->
if r
then
@@ -40,9 +40,9 @@
s
^ "\""
else s
- | T.List { T.value = xs } -> "(" ^ stringify xs r ^ ")"- | T.Vector { T.value = v } -> "#(" ^ stringify v r ^ ")"- | T.Record r -> "<record unsupported>"
+ | T.List { T.value = xs; T.meta = _ } -> "(" ^ stringify xs r ^ ")"+ | T.Vector { T.value = v; T.meta = _ } -> "#(" ^ stringify v r ^ ")"+ | T.Record _ -> "<record unsupported>"
and stringify obj human =
String.concat
--- a/reader.ml
+++ b/reader.ml
@@ -87,21 +87,23 @@
try Env.get registered_macros (Types.symbol (List.nth list_reader.tokens 1)) with
| _ -> T.Nil
with
- | T.Macro { T.value = sym; meta } ->- print_endline ("XXXX MACRO FOUND");- let rec collect_args tokens args =
- match tokens with
- | [ t ] -> args @ [ t ]
- | t :: ts -> if t = eol then args else collect_args ts args @ [ t ]
- | _ -> []
- in
- let args = collect_args (List.tl list_reader.tokens) [] in
- print_endline ("<><><><>: " ^ Macro.match_variant meta args)+ | T.List { T.value = xs; T.meta } ->+ print_endline "XXXX MACRO FOUND";
+ let rec collect_args tokens args =
+ match tokens with
+ | [ t ] -> args @ [ t ]
+ | t :: ts -> if t = eol then args else collect_args ts args @ [ t ]
+ | _ -> []
+ in
+ let args = collect_args (List.tl list_reader.tokens) [] in
+ print_endline ("<><><> args: " ^ String.concat " " args);+ print_endline ("<><><><>: " ^ Macro.match_variant meta args)| _ -> ());
match list_reader.tokens with
- | [] -> print_endline ("ERROR: " ^ Printer.dump list_reader.list_form);- raise (Utils.Syntax_error ("unterminated '" ^ eol ^ "'"))- | token :: [] -> { list_form = list_reader.list_form; tokens = [")"] }+ | [] ->
+ print_endline ("ERROR: " ^ Printer.dump list_reader.list_form);+ raise (Utils.Syntax_error ("unterminated '" ^ eol ^ "'"))+ | [ token ] -> { list_form = list_reader.list_form; tokens = [ ")" ] }| token :: tokens ->
if Str.string_match (Str.regexp eol) token 0
then { list_form = list_reader.list_form; tokens }@@ -138,8 +140,10 @@
Env.set registered_macros sym macro_entry;
Types.M9map.iter
(fun k v ->
- print_endline (" >>> " ^ Printer.print k true ^ ": " ^ String.concat " " (fix_pattern k (Printer.print v true)));- macro := !macro @ (fix_pattern k (Printer.print v true)))
+ print_endline
+ (" >>> " ^ Printer.print k true ^ ": " ^ String.concat " " (fix_pattern k (Printer.print v true)));+ macro := !macro @ fix_pattern k (Printer.print v true);
+ Env.set registered_macros k (read_form (fix_pattern k (Printer.print v true))).form)
variants
| _ -> raise (Utils.Syntax_error "read_macro botch"))
| _ as x -> print_endline (" last rest: " ^ Printer.dump x));--- a/types.ml
+++ b/types.ml
@@ -37,11 +37,10 @@
and M9map : (Map.S with type key = Value.t) = Map.Make (Value)
-let to_bool x =
- match x with
- | Types.Nil | Types.Bool false -> false
- | _ -> true
-;;
+(* let to_bool x =
+ * match x with
+ * | Types.Nil | Types.Bool false -> false
+ * | _ -> true *)
type m9type = Value.t