ref: 60993540fa2f1383724705faf0796202250c63f6
parent: dd3012ec25538fc83f12e81520f0470fcc9020fa
author: McKay Marston <mckay.marston@greymanlabs.com>
date: Thu Nov 26 17:48:44 EST 2020
macros kind of working
--- a/core.ml
+++ b/core.ml
@@ -4,55 +4,45 @@
let number_compare t f =
Types.proc (function
- | [ T.Number a; T.Number b ] -> t (f a.value b.value)
- | _ -> raise (Invalid_argument "not a number"))
-;;
+ | [T.Number a; T.Number b] ->
+ t (f a.value b.value)
+ | _ ->
+ raise (Invalid_argument "not a number") )
let simple_compare t f =
- Types.proc (function
- | [ T.Number a; T.Number b ] -> t (f a b)
- | _ -> raise (Invalid_argument "incomparable"))
-;;
+ Types.proc (function [T.Number a; T.Number b] -> t (f a b) | _ -> raise (Invalid_argument "incomparable"))
let mk_num x = Types.number x
+
let mk_bool x = T.Bool x
-let seq = function
- | T.List { T.value = xs; meta = _ } -> xs- | T.Vector { T.value = xs; meta = _ } -> xs- | _ -> []
-;;
+let seq = function T.List {T.value= xs; meta= _} -> xs | T.Vector {T.value= xs; meta= _} -> xs | _ -> [](* this is 'assoc' from mal, but it's not what assoc is in scheme *)
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.Nil
-;;
+ | 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.Nil
let init env =
- Env.set
- env
- (Types.symbol "raise")
- (Types.proc (function
- | [ ast ] -> raise (Types.M9exn ast)
- | _ -> T.Nil));
- Env.set
- env
- (Types.symbol "*arguments*")
+ Env.set env (Types.symbol "raise") (Types.proc (function [ast] -> raise (Types.M9exn ast) | _ -> T.Nil)) ;
+ Env.set env (Types.symbol "*arguments*")
(Types.list
- (if Array.length Sys.argv > 1
- then List.map (fun x -> T.String x) (List.tl (List.tl (Array.to_list Sys.argv)))
- else []));
- Env.set env (Types.symbol "+") (number_compare mk_num ( +. ));
- Env.set env (Types.symbol "-") (number_compare mk_num ( -. ));
- Env.set env (Types.symbol "*") (number_compare mk_num ( *. ));
- Env.set env (Types.symbol "/") (number_compare mk_num ( /. ));
- Env.set env (Types.symbol "<") (simple_compare mk_bool ( < ));
- Env.set env (Types.symbol "<=") (simple_compare mk_bool ( <= ));
- Env.set env (Types.symbol ">") (simple_compare mk_bool ( > ));
- Env.set env (Types.symbol ">=") (simple_compare mk_bool ( >= ));
+ ( if Array.length Sys.argv > 1 then List.map (fun x -> T.String x) (List.tl (List.tl (Array.to_list Sys.argv)))
+ else [] ) ) ;
+ Env.set env (Types.symbol "+") (number_compare mk_num ( +. )) ;
+ Env.set env (Types.symbol "-") (number_compare mk_num ( -. )) ;
+ Env.set env (Types.symbol "*") (number_compare mk_num ( *. )) ;
+ Env.set env (Types.symbol "/") (number_compare mk_num ( /. )) ;
+ Env.set env (Types.symbol "<") (simple_compare mk_bool ( < )) ;
+ Env.set env (Types.symbol "<=") (simple_compare mk_bool ( <= )) ;
+ Env.set env (Types.symbol ">") (simple_compare mk_bool ( > )) ;
+ Env.set env (Types.symbol ">=") (simple_compare mk_bool ( >= )) ;
(* Env.set
* env
* (Types.symbol "proc?")
@@ -64,77 +54,44 @@
* && Types.to_bool (Types.M9map.find kw_macro meta)))
* | [ T.Proc _ ] -> T.Bool true
* | _ -> T.Bool false)); *)
- Env.set
- env
- (Types.symbol "number?")
+ Env.set env (Types.symbol "number?") (Types.proc (function [T.Number _] -> T.Bool true | _ -> T.Bool false)) ;
+ Env.set env (Types.symbol "list") (Types.proc (function xs -> Types.list xs)) ;
+ Env.set env (Types.symbol "list?") (Types.proc (function [T.List _] -> T.Bool true | _ -> T.Bool false)) ;
+ Env.set env (Types.symbol "vector") (Types.proc (function xs -> Types.vector xs)) ;
+ Env.set env (Types.symbol "vector?") (Types.proc (function [T.Vector _] -> T.Bool true | _ -> T.Bool false)) ;
+ Env.set env (Types.symbol "empty?")
(Types.proc (function
- | [ T.Number _ ] -> T.Bool true
- | _ -> T.Bool false));
- Env.set env (Types.symbol "list") (Types.proc (function xs -> Types.list xs));
- Env.set
- env
- (Types.symbol "list?")
+ | [T.List {T.value= []; meta= _}] ->+ T.Bool true
+ | [T.Vector {T.value= []; meta= _}] ->+ T.Bool true
+ | _ ->
+ T.Bool false ) ) ;
+ Env.set env (Types.symbol "count")
(Types.proc (function
- | [ T.List _ ] -> T.Bool true
- | _ -> T.Bool false));
- Env.set env (Types.symbol "vector") (Types.proc (function xs -> Types.vector xs));
- Env.set
- env
- (Types.symbol "vector?")
- (Types.proc (function
- | [ T.Vector _ ] -> T.Bool true
- | _ -> T.Bool false));
- Env.set
- env
- (Types.symbol "empty?")
- (Types.proc (function
- | [ T.List { T.value = []; meta = _ } ] -> T.Bool true- | [ T.Vector { T.value = []; meta = _ } ] -> T.Bool true- | _ -> T.Bool false));
- Env.set
- env
- (Types.symbol "count")
- (Types.proc (function
- | [ T.List { T.value = xs; meta = _ } ] | [ T.Vector { T.value = xs; meta = _ } ] ->+ | [T.List {T.value= xs; meta= _}] | [T.Vector {T.value= xs; meta= _}] ->Types.number (float_of_int (List.length xs))
- | _ -> Types.number 0.));
- Env.set
- env
- (Types.symbol "display")
+ | _ ->
+ Types.number 0. ) ) ;
+ Env.set env (Types.symbol "display")
(Types.proc (function xs ->
- print_string (Printer.stringify xs false);
- T.Unspecified));
- Env.set
- env
- (Types.symbol "string")
- (Types.proc (function xs -> T.String (String.concat "" (List.map (fun s -> Printer.print s false) xs))));
- Env.set
- env
- (Types.symbol "read-string")
- (Types.proc (function
- | [ T.String x ] -> Reader.read x
- | _ -> T.Nil));
- Env.set
- env
- (Types.symbol "slurp")
- (Types.proc (function
- | [ T.String x ] -> T.String (Reader.slurp x)
- | _ -> T.Nil));
- Env.set
- env
- (Types.symbol "cons")
- (Types.proc (function
- | [ x; xs ] -> Types.list [ x; xs ]
- | _ -> T.Nil));
- Env.set
- env
- (Types.symbol "concat")
+ print_string (Printer.stringify xs false) ;
+ T.Unspecified ) ) ;
+ Env.set env (Types.symbol "string")
+ (Types.proc (function xs -> T.String (String.concat "" (List.map (fun s -> Printer.print s false) xs)))) ;
+ Env.set env (Types.symbol "read-string") (Types.proc (function [T.String x] -> Reader.read x | _ -> T.Nil)) ;
+ Env.set env (Types.symbol "slurp") (Types.proc (function [T.String x] -> T.String (Reader.slurp x) | _ -> T.Nil)) ;
+ Env.set env (Types.symbol "cons") (Types.proc (function [x; xs] -> Types.list [x; xs] | _ -> T.Nil)) ;
+ Env.set env (Types.symbol "concat")
(Types.proc
(let rec concat = function
- | x :: y :: more -> concat (Types.list (seq x @ seq y) :: more)
- | [ (T.List _ as x) ] -> x
- | [ x ] -> Types.list (seq x)
- | [] -> Types.list []
+ | x :: y :: more ->
+ concat (Types.list (seq x @ seq y) :: more)
+ | [(T.List _ as x)] ->
+ x
+ | [x] ->
+ Types.list (seq x)
+ | [] ->
+ Types.list []
in
- concat))
-;;
+ concat ) )
--- a/env.ml
+++ b/env.ml
@@ -3,40 +3,34 @@
exception Runtime_error of string
-type env =
- { outer : env option- ; data : Types.m9type Data.t ref
- }
+type env = {outer: env option; data: Types.m9type Data.t ref}-let make outer = { outer; data = ref Data.empty }+let make outer = {outer; data= ref Data.empty}let set env sym value =
match sym with
- | 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")
-;;
+ | 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.meta = _ } ->- if Data.mem key !(env.data)
- then Some env
- else (
- match env.outer with
- | Some outer -> find outer sym
- | None -> None)
- | _ -> raise (Invalid_argument "find: not a symbol")
-;;
+ | T.Symbol {T.value= key; T.meta= _} -> (+ if Data.mem key !(env.data) then Some env else match env.outer with Some outer -> find outer sym | None -> None )
+ | _ ->
+ raise (Invalid_argument "find: not a symbol")
let get env sym =
match sym with
- | 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")
-;;
+ | 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
--- a/eval.ml
+++ b/eval.ml
@@ -2,124 +2,103 @@
let rec quasiquote ast =
match ast with
- | T.List { T.value = [ T.Symbol { T.value = "unquote"; meta = _ }; ast ]; meta = _ } -> ast- | T.Vector { T.value = [ T.Symbol { T.value = "unquote"; meta = _ }; ast ]; meta = _ } -> ast- | T.List
- { T.value = T.List { T.value = [ T.Symbol { T.value = "unquote-splicing"; meta = _ }; head ]; meta = _ } :: tail- ; meta = _
- }
+ | T.List {T.value= [T.Symbol {T.value= "unquote"; meta= _}; ast]; meta= _} ->+ ast
+ | T.Vector {T.value= [T.Symbol {T.value= "unquote"; meta= _}; ast]; meta= _} ->+ ast
+ | T.List {T.value= T.List {T.value= [T.Symbol {T.value= "unquote-splicing"; meta= _}; head]; meta= _} :: tail; meta= _}| T.Vector
- { T.value = T.List { T.value = [ T.Symbol { T.value = "unquote-splicing"; meta = _ }; head ]; meta = _ } :: tail- ; meta = _
- } -> Types.list [ Types.symbol "concat"; head; quasiquote (Types.list tail) ]
- | T.List { T.value = head :: tail; meta = _ } | T.Vector { T.value = head :: tail; meta = _ } ->- Types.list [ Types.symbol "cons"; quasiquote head; quasiquote (Types.list tail) ]
- | ast -> Types.list [ Types.symbol "quote"; ast ]
-;;
+ {T.value= T.List {T.value= [T.Symbol {T.value= "unquote-splicing"; meta= _}; head]; meta= _} :: tail; meta= _} ->+ Types.list [Types.symbol "concat"; head; quasiquote (Types.list tail)]
+ | T.List {T.value= head :: tail; meta= _} | T.Vector {T.value= head :: tail; meta= _} ->+ Types.list [Types.symbol "cons"; quasiquote head; quasiquote (Types.list tail)]
+ | ast ->
+ Types.list [Types.symbol "quote"; ast]
let rec eval_ast ast env =
(* print_endline ("EVAL_AST: " ^ Printer.print ast true); *)match ast with
- | T.Symbol _ -> Env.get env ast
- | T.List { T.value = xs; T.meta } ->- (match
- try Env.get env (List.hd xs) with
- | _ -> T.Nil
- with
- | _ -> 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
+ | T.Symbol _ ->
+ Env.get env ast
+ | T.List {T.value= xs; T.meta} -> (+ match try Env.get env (List.hd xs) with _ -> T.Nil with
+ | _ ->
+ 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 =
- print_endline ("AST: " ^ Printer.print ast true);+ print_endline ("AST: " ^ Printer.print ast true) ;match ast with
- | T.List { T.value = []; meta = _ } -> ast+ | T.List {T.value= []; meta= _} ->+ ast
(* Can this be replaced with a define-syntax thing? *)
- | T.List
- { T.value = [ T.Symbol { T.value = "define"; meta = _ }; T.List { T.value = arg_list; meta = _ }; body ]- ; meta = _
- } ->
- 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- in
- print_endline ("DEFINE: " ^ Printer.print sym true);- print_endline
- (" => "- ^ "(define "
- ^ Printer.print sym true
- ^ " (lambda ("- ^ Printer.stringify rest false
- ^ ") "
- ^ Printer.print body true
- ^ "))");
- Env.set env sym func;
- func
- | T.List { T.value = [ T.Symbol { T.value = "define"; meta = _ }; key; expr ]; meta = _ } ->- let value = eval expr env in
- Env.set env key value;
- value
- | T.List
- { T.value = [ T.Symbol { T.value = "lambda"; meta = _ }; T.Vector { T.value = arg_names; meta = _ }; expr ]- ; meta = _
- }
- | T.List
- { T.value = [ T.Symbol { T.value = "lambda"; meta = _ }; T.List { T.value = arg_names; meta = _ }; expr ]- ; meta = _
- } ->
- 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 = "."; meta = _ }; 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
- (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)
+ | T.List {T.value= [T.Symbol {T.value= "define"; meta= _}; T.List {T.value= arg_list; meta= _}; body]; meta= _} ->+ 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+ in
+ print_endline ("DEFINE: " ^ Printer.print sym true) ;+ print_endline
+ ( " => " ^ "(define " ^ Printer.print sym true ^ " (lambda (" ^ Printer.stringify rest false ^ ") "+ ^ Printer.print body true ^ "))" ) ;
+ Env.set env sym func ;
+ func
+ | T.List {T.value= [T.Symbol {T.value= "define"; meta= _}; key; expr]; meta= _} ->+ let value = eval expr env in
+ Env.set env key value ; value
+ | T.List {T.value= [T.Symbol {T.value= "lambda"; meta= _}; T.Vector {T.value= arg_names; meta= _}; expr]; meta= _}+ | T.List {T.value= [T.Symbol {T.value= "lambda"; meta= _}; T.List {T.value= arg_names; meta= _}; expr]; meta= _} ->+ 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= "."; meta= _}; 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
+ (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 )
(* Can these be replace with define-syntax stuff? *)
- | T.List
- { T.value = [ T.Symbol { T.value = "let"; meta = _ }; T.Vector { T.value = bindings; meta = _ }; body ]- ; meta = _
- }
- | T.List
- { T.value = [ T.Symbol { T.value = "let"; meta = _ }; T.List { T.value = bindings; meta = _ }; body ]; meta = _ }- ->
- let sub_env = Env.make (Some env) in
- let rec bind_pairs = function
- | T.List { T.value = [ T.Symbol { T.value = sym; meta = _ }; expr ]; meta = _ } :: 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"; meta = _ } :: body; meta = _ } ->- List.fold_left (fun _ expr -> eval expr env) T.Nil body
- | T.List { T.value = [ T.Symbol { T.value = "if"; meta = _ }; cond; then_expr; else_expr ]; meta = _ } ->- 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"; meta = _ }; cond; then_expr ]; meta = _ } ->- if Types.to_bool (eval cond env) then eval then_expr env else T.Nil
- | T.List { T.value = [ T.Symbol { T.value = "quote"; meta = _ }; ast ]; meta = _ } -> ast- | T.List { T.value = [ T.Symbol { T.value = "quasiquote"; meta = _ }; ast ]; meta = _ } -> eval (quasiquote ast) env- | T.List _ ->
- (match eval_ast ast env with
- | T.List { T.value = T.Proc { T.value = f; meta = _ } :: args; meta = _ } -> f args- | T.List { T.value = T.Macro { T.value = _; meta = _ } :: macro :: _; meta = _ } ->- print_endline "MACRO EVALUATION";
- eval macro env
- | _ as x -> raise (Utils.Syntax_error ("'" ^ Printer.print x true ^ "' not a function")))- | _ -> eval_ast ast env
-;;
+ | T.List {T.value= [T.Symbol {T.value= "let"; meta= _}; T.Vector {T.value= bindings; meta= _}; body]; meta= _}+ | T.List {T.value= [T.Symbol {T.value= "let"; meta= _}; T.List {T.value= bindings; meta= _}; body]; meta= _} ->+ let sub_env = Env.make (Some env) in
+ let rec bind_pairs = function
+ | T.List {T.value= [T.Symbol {T.value= sym; meta= _}; expr]; meta= _} :: 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"; meta= _} :: body; meta= _} ->+ List.fold_left (fun _ expr -> eval expr env) T.Nil body
+ | T.List {T.value= [T.Symbol {T.value= "if"; meta= _}; cond; then_expr; else_expr]; meta= _} ->+ 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"; meta= _}; cond; then_expr]; meta= _} ->+ if Types.to_bool (eval cond env) then eval then_expr env else T.Nil
+ | T.List {T.value= [T.Symbol {T.value= "quote"; meta= _}; ast]; meta= _} ->+ ast
+ | T.List {T.value= [T.Symbol {T.value= "quasiquote"; meta= _}; ast]; meta= _} ->+ eval (quasiquote ast) env
+ | T.List _ -> (
+ match eval_ast ast env with
+ | T.List {T.value= T.Proc {T.value= f; meta= _} :: args; meta= _} ->+ f args
+ | T.List {T.value= T.Macro {T.value= _; meta= _} :: macro :: _; meta= _} ->+ print_endline "MACRO EVALUATION" ; eval macro env
+ | _ as x ->
+ raise (Utils.Syntax_error ("'" ^ Printer.print x true ^ "' not a function")) )+ | _ ->
+ eval_ast ast env
--- a/m9.ml
+++ b/m9.ml
@@ -13,35 +13,32 @@
module T = Types.Types
let repl_env = Env.make (Some Core.base)
+
let nameplate = "Martian9 Scheme v0.2"
+
let read str = Reader.read str
+
let print exp = Printer.print exp true
+
let rep str env = print (Eval.eval (read str) env)
let main =
- print_endline nameplate;
+ print_endline nameplate ;
try
- Core.init Core.base;
- Env.set
- repl_env
- (Types.symbol "eval")
- (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);
- if Array.length Sys.argv > 1
- then print_endline (rep ("(load-file \"" ^ Sys.argv.(1) ^ "\")") repl_env)+ Core.init Core.base ;
+ Env.set repl_env (Types.symbol "eval") (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) ;
+ if Array.length Sys.argv > 1 then print_endline (rep ("(load-file \"" ^ Sys.argv.(1) ^ "\")") repl_env)else (
- print_endline nameplate;
+ print_endline nameplate ;
while true do
- print_string "m9> ";
+ print_string "m9> " ;
let line = read_line () in
try print_endline (rep line repl_env) with
- | End_of_file -> ()
+ | End_of_file ->
+ ()
| Invalid_argument x ->
- output_string stderr ("Invalid argument: " ^ x ^ "\n");- flush stderr
- done)
- with
- | End_of_file -> ()
-;;
+ output_string stderr ("Invalid argument: " ^ x ^ "\n") ;+ flush stderr
+ done )
+ with End_of_file -> ()
--- a/macro.ml
+++ b/macro.ml
@@ -13,71 +13,68 @@
let gen_sym root =
let gen () =
match Random.int (26 + 26 + 10) with
- | n when n < 26 -> int_of_char 'a' + n
- | n when n < 26 + 26 -> int_of_char 'A' + n - 26
- | n -> int_of_char '0' + n - 26 - 26
+ | n when n < 26 ->
+ int_of_char 'a' + n
+ | n when n < 26 + 26 ->
+ int_of_char 'A' + n - 26
+ | n ->
+ int_of_char '0' + n - 26 - 26
in
let gen _ = String.make 1 (char_of_int (gen ())) in
Types.symbol (root ^ String.concat "" (Array.to_list (Array.init 5 gen)))
-;;
let rec is_matching_pattern sym pattern args matched =
- match pattern, args with
+ match (pattern, args) with
(* literals and ellipses not handled, yet *)
| ph :: pt, ah :: at ->
- (* 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); *)- is_matching_pattern sym pt at matched
+ (* 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); *)+ is_matching_pattern sym pt at matched
| ph :: pt, [] ->
- (* print_endline " LIST <-> []";
- * print_endline (" ph: " ^ ph);- * print_endline (" pt: " ^ String.concat "|" pt); *)- if ph = "_" || ph = Printer.print sym true
- then is_matching_pattern sym pt [] matched && true
- else ph = "..." || List.hd pt = "..."
+ (* print_endline " LIST <-> []";
+ * print_endline (" ph: " ^ ph);+ * print_endline (" pt: " ^ String.concat "|" pt); *)+ if ph = "_" || ph = Printer.print sym true then is_matching_pattern sym pt [] matched && true
+ else ph = "..." || List.hd pt = "..."
| [], _ :: _ ->
- (* print_endline " [] <-> LIST"; *)
- false
- | _, _ -> matched
-;;
+ (* print_endline " [] <-> LIST"; *)
+ false
+ | _, _ ->
+ matched
let ellipsis pattern template args =
let has_ellipsis =
try
- ignore (Str.search_forward (Str.regexp "...") (Printer.stringify pattern true) 0);
+ ignore (Str.search_forward (Str.regexp "...") (Printer.stringify pattern true) 0) ;
true
- with
- | Not_found -> false
+ with Not_found -> false
in
let ellipsis_substitutions = ref [] in
let missing = List.length args - List.length pattern + if has_ellipsis then 1 else 0 in
- print_endline ("args: " ^ String.concat " " (List.map (fun x -> Printer.print x true) args));- print_endline ("missing: " ^ string_of_int missing);+ print_endline ("args: " ^ String.concat " " (List.map (fun x -> Printer.print x true) args)) ;+ 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 ->
- (* add arguments *)
- print_endline ("ADD " ^ string_of_int missing ^ " arguments");- for _ = 1 to missing do
- ellipsis_substitutions := !ellipsis_substitutions @ [ Printer.print (gen_sym "x") true ]
- done;
- let pattern_str =
- Str.global_replace
- (Str.regexp "\\.\\.\\.")
- (String.concat " " !ellipsis_substitutions)
- (Printer.stringify pattern true)
- in
- let template_str =
- Str.global_replace
- (Str.regexp "\\.\\.\\.")
- (String.concat " " !ellipsis_substitutions)
- (Printer.stringify template true)
- in
- (* let args_str = Printer.stringify args true in *)
- (* print_endline ("ellipsis: template: " ^ template_str ^ " args: " ^ args_str); *)- "(" ^ pattern_str ^ ") " ^ template_str ^ ")"+ (* add arguments *)
+ print_endline ("ADD " ^ string_of_int missing ^ " arguments") ;+ for _ = 1 to missing do
+ ellipsis_substitutions := !ellipsis_substitutions @ [Printer.print (gen_sym "x") true]
+ done ;
+ let pattern_str =
+ Str.global_replace (Str.regexp "\\.\\.\\.")
+ (String.concat " " !ellipsis_substitutions)
+ (Printer.stringify pattern true)
+ in
+ let template_str =
+ Str.global_replace (Str.regexp "\\.\\.\\.")
+ (String.concat " " !ellipsis_substitutions)
+ (Printer.stringify template true)
+ in
+ (* let args_str = Printer.stringify args true in *)
+ (* print_endline ("ellipsis: template: " ^ template_str ^ " args: " ^ args_str); *)+ "(" ^ pattern_str ^ ") " ^ template_str ^ ")"(* | _ when missing < 0 ->
* (\* remove ellipsis and arg *\)
* print_endline "REMOVE arguments";
@@ -91,56 +88,44 @@
* print_endline (" template_str: " ^ template_str); * print_endline ("(" ^ pattern_str ^ ") " ^ template_str ^ ")"); * "(" ^ pattern_str ^ ") " ^ template_str ^ ")" *)- | _ -> "(" ^ Printer.dump pattern ^ ") " ^ Printer.dump template ^ ")"-;;
+ | _ ->
+ "(" ^ Printer.dump pattern ^ ") " ^ Printer.dump template ^ ")"let sanitize_macro pattern template =
let sanitized =
try
- ignore (Str.search_forward (Str.regexp "...") (Printer.stringify pattern true) 0);
+ ignore (Str.search_forward (Str.regexp "...") (Printer.stringify pattern true) 0) ;
let substitution = Printer.print (gen_sym "x") true in
- let pattern_str =
- Str.global_replace
- (Str.regexp "\\.\\.\\.")
- substitution
- (Printer.stringify pattern true)
- in
- let template_str =
- Str.global_replace
- (Str.regexp "\\.\\.\\.")
- substitution
- (Printer.stringify template true)
- in
+ let pattern_str = Str.global_replace (Str.regexp "\\.\\.\\.") substitution (Printer.stringify pattern true) in
+ let template_str = Str.global_replace (Str.regexp "\\.\\.\\.") substitution (Printer.stringify template true) in
"(" ^ pattern_str ^ ") (" ^ template_str ^ ")"- with
- | Not_found -> "(" ^ Printer.dump pattern ^ ") (" ^ Printer.dump template ^ ")"+ with Not_found -> "((" ^ Printer.dump pattern ^ ") (" ^ Printer.dump template ^ "))"in
- print_endline ("SANITIZED: " ^ sanitized); sanitized-;;
+ print_endline (" SANITIZED: " ^ sanitized) ;+ sanitized
let parse ast _ =
- print_endline ("\n\nREADING MACRO: " ^ String.concat " " ast);- match ast with
- | [] -> raise End_of_file
- | macro :: _ -> print_endline (" macro: " ^ macro)-;;
+ print_endline ("\n\nREADING MACRO: " ^ String.concat " " ast) ;+ match ast with [] -> raise End_of_file | macro :: _ -> print_endline (" macro: " ^ macro)-let hack_ellipsis prefix clause =
+let hack_ellipsis _ clause =
let clauses = ref [] in
- (match clause with
+ ( match clause with
(* ((_ test1 test2 ...) (if test1 (_ test2 ...) #f)) *)
- (* | T.List { T.value = [ T.List { T.value = pattern; meta = _ }; T.List {T.value = [ transform ]; meta = _ } ]; meta = _ } -> *)- | T.List { T.value = [ T.List { T.value = pattern; meta = _ }; T.List { T.value = transform; meta = _ } ]; meta = _ }- ->
- print_endline ("HAXXOR: " ^ prefix ^ ":: " ^ Printer.dump pattern ^ " :: " ^ Printer.dump transform);- clauses := !clauses @ [ sanitize_macro pattern transform ]
+ | T.List {T.value= [T.List {T.value= pattern; meta= _}; T.List {T.value= transform; meta= _}]; meta= _} ->+ (* print_endline ("HAXXOR: " ^ prefix ^ ":: " ^ Printer.dump pattern ^ " :: " ^ Printer.dump transform); *)+ clauses := !clauses @ ["(" ^ sanitize_macro pattern transform ^ ")"](* needs to match ((_) #t) : LIST(LIST() ATOM) *)
- | T.List { T.value = [ T.List { T.value = pattern; meta = _ }; atom ]; meta = _ } ->- print_endline ("FOUND CLAUSE WITH ATOM: " ^ Printer.print atom true ^ " pattern: " ^ Printer.dump pattern);- clauses := !clauses @ [ sanitize_macro pattern [ atom ] ]
- | _ as x -> print_endline ("nope: " ^ Printer.print x true));+ | T.List {T.value= [T.List {T.value= pattern; meta= _}; atom]; meta= _} ->+ (* print_endline ("FOUND CLAUSE WITH ATOM: " ^ Printer.print atom true ^ " pattern: " ^ Printer.dump pattern); *)+ clauses :=
+ !clauses
+ @ [ "(("+ ^ String.concat " " (List.map (fun x -> Printer.to_string x) pattern)
+ ^ ") " ^ Printer.to_string atom ^ ")" ]
+ | _ as x ->
+ print_endline ("nope: " ^ Printer.print x true) ) ;!clauses
-;;
(* print_endline (" head: " ^ Printer.print (List.hd clause) true); * print_endline (" tail: " ^ Printer.dump (List.tl clause)); *)@@ -149,22 +134,26 @@
(* clause *)
(* this is a dirty hack *)
-let generate_patterns sym clauses =
+let sanitize_clauses sym clauses =
+ (* ((_) #t) ((_ test) test) ((_ test1 test2 ...) (if test1 (_ test2 ...) #f)) *)
let prefix = Printer.print sym true in
let sanitized = ref [] in
let rec sanitize_clauses unsanitized =
match unsanitized with
- | [ clause ] ->
- print_endline ("CLAUSE: " ^ Printer.print clause true);- sanitized := !sanitized @ [ hack_ellipsis prefix clause ];
- !sanitized
+ | [clause] ->
+ print_endline
+ (" CLAUSE: " ^ Printer.print clause true ^ " <|> " ^ String.concat " " (hack_ellipsis prefix clause)) ;+ sanitized := !sanitized @ [hack_ellipsis prefix clause] ;
+ !sanitized
| clause :: rest ->
- sanitized := !sanitized @ [ hack_ellipsis prefix clause ];
- sanitize_clauses rest
- | [] -> !sanitized
+ print_endline
+ (" CLAUSE: " ^ Printer.print clause true ^ " <|> " ^ String.concat " " (hack_ellipsis prefix clause)) ;+ sanitized := !sanitized @ [hack_ellipsis prefix clause] ;
+ sanitize_clauses rest
+ | [] ->
+ !sanitized
in
sanitize_clauses clauses
-;;
let generate_variants sym _ clauses =
let symbol = Printer.print sym true in
@@ -172,41 +161,40 @@
let rec register_variants clauses =
let new_sym = gen_sym symbol in
match clauses with
- | [ clause ] ->
- variants := Types.M9map.add new_sym clause !variants;
- !variants
+ | [clause] ->
+ variants := Types.M9map.add new_sym clause !variants ;
+ !variants
| clause :: rest ->
- variants := Types.M9map.add new_sym clause !variants;
- register_variants rest
- | _ -> raise (Utils.Syntax_error "macro clause registration botch")
+ variants := Types.M9map.add new_sym clause !variants ;
+ register_variants rest
+ | _ ->
+ raise (Utils.Syntax_error "macro clause registration botch")
in
register_variants clauses
-;;
let match_variant macro args =
let vmatch = ref "" in
- (match macro with
- | T.Map { T.value = meta; meta = _ } ->- (match Types.M9map.find Types.macro_variants meta with
- | T.Map { T.value = variant_list; meta = _ } ->- 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; meta = _ } :: z; meta = _ } ->- 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
- | _ -> ())
- | _ -> ());
+ ( match macro with
+ | T.Map {T.value= meta; meta= _} -> (+ match Types.M9map.find Types.macro_variants meta with
+ | T.Map {T.value= variant_list; meta= _} ->+ 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; meta= _} :: z; meta= _} ->+ 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
-;;
--- a/printer.ml
+++ b/printer.ml
@@ -2,57 +2,63 @@
let meta obj =
match obj with
- | 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
-;;
+ | 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
let rec print obj readable =
let r = readable in
match obj with
- | T.Bool true -> "#t"
- | T.Bool false -> "#f"
- | T.Char c -> "#\\" ^ Char.escaped c
- | T.Nil -> "nil"
- | 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.Bool true ->
+ "#t"
+ | T.Bool false ->
+ "#f"
+ | T.Char c ->
+ "#\\" ^ Char.escaped c
+ | T.Nil ->
+ "nil"
+ | 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 _ -> "#<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 _ -> "<port 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 _ ->
+ "<port unsupported>"
| T.String s ->
- if r
- then
- "\""
- ^ Utils.gsub
- (Str.regexp "\\([\"\\\n]\\)")
- (function
- | "\n" -> "\\n"
- | x -> "\\" ^ x)
- s
- ^ "\""
- else s
- | T.List { T.value = xs; T.meta = _ } -> "(" ^ stringify xs r ^ ")"- | T.Vector { T.value = v; T.meta = _ } -> "#(" ^ stringify v r ^ ")"- | T.Record _ -> "<record unsupported>"
+ if r then "\"" ^ Utils.gsub (Str.regexp "\\([\"\\\n]\\)") (function "\n" -> "\\n" | x -> "\\" ^ x) s ^ "\""
+ else s
+ | 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
- " "
- (List.filter
- (function
- | T.Unspecified | T.Eof_object -> human
- | _ -> true)
- obj
- |> List.map (fun s -> print s human))
-;;
+ String.concat " "
+ (List.filter (function T.Unspecified | T.Eof_object -> human | _ -> true) obj |> List.map (fun s -> print s human))
let dump obj = String.concat " " (List.map (fun s -> print s true) obj)
+
+let to_string obj = print obj true
--- a/reader.ml
+++ b/reader.ml
@@ -1,193 +1,240 @@
module T = Types.Types
let token_re = Str.regexp "~@\\|[][{}()'`~^@]\\|\"\\(\\\\.\\|[^\"]\\)*\"?\\|;.*\\$\\|[^][ \n{}('\"`,;)]*"+
let string_re = Str.regexp "\"\\(\\\\.\\|[^\\\\\"]\\)*\""
+
let registered_macros = Env.make None
-type reader =
- { form : Types.m9type- ; tokens : string list
- }
+type reader = {form: Types.m9type; tokens: string list}-type list_reader =
- { list_form : Types.m9type list- ; tokens : string list
- }
+type list_reader = {list_form: Types.m9type list; tokens: string list}let tokenize str =
List.map
- (function
- | Str.Delim x -> String.trim x (* move trim to regex for speed? *)
- | Str.Text _ -> "tokenize botch")
- (List.filter
- (function
- | Str.Delim _ -> true
- | Str.Text _ -> false)
- (Str.full_split token_re str))
-;;
+ (function Str.Delim x -> String.trim x (* move trim to regex for speed? *) | Str.Text _ -> "tokenize botch")
+ (List.filter (function Str.Delim _ -> true | Str.Text _ -> false) (Str.full_split token_re str))
let unescape_string token =
- if Str.string_match string_re token 0
- then (
+ if Str.string_match string_re token 0 then
let without_quotes = String.sub token 1 (String.length token - 2) in
- Utils.gsub
- (Str.regexp "\\\\.")
- (function
- | "\\n" -> "\n"
- | x -> String.sub x 1 1)
- without_quotes)
+ Utils.gsub (Str.regexp "\\\\.") (function "\\n" -> "\n" | x -> String.sub x 1 1) without_quotes
else raise (Utils.Syntax_error "unterminated string")
-;;
-let fix_pattern sym pattern =
- print_endline(" fix_pattern: " ^ pattern ^ " sym: " ^ Printer.print sym true);- let tokenized_pattern = tokenize pattern in
- let new_pattern = ref [] in
- let rec replace_token tokens =
- match tokens with
- | [ token ] ->
- let t = if token = "_" then Printer.print sym true else token in
- new_pattern := !new_pattern @ [ t ];
- !new_pattern
- | token :: rest ->
- let t = if token = "_" then Printer.print sym true else token in
- new_pattern := !new_pattern @ [ t ];
- replace_token rest
- | _ -> raise (Utils.Syntax_error "unable to fix pattern")
- in
- let trimmed = List.tl tokenized_pattern in
- replace_token (["("; "define"; List.hd trimmed; "("; "lambda"; "("] @ List.tl trimmed @ [ ")"; ")" ])-;;
+let rec replace_token tokens replacement block =
+ match tokens with
+ | [token] ->
+ let t = if token = "_" then replacement else token in
+ block := !block @ [t] ;
+ String.concat " " !block
+ | token :: rest ->
+ let t = if token = "_" then replacement else token in
+ block := !block @ [t] ;
+ replace_token rest replacement block
+ | _ ->
+ String.concat " " !block
+(* raise (Utils.Syntax_error ("clause is unfixable: " ^ String.concat " " x)) *)+and fix_clause original sym clause =
+ print_endline (" fix_clause: incoming: " ^ Printer.print clause true) ;+ match clause with
+ | T.List {T.value= [T.List {T.value= pattern; meta= _}; T.List {T.value= transform; meta= _}]; meta= _} ->+ (* print_endline(" fix_clause: pattern: " ^ Printer.dump pattern ^ " sym: " ^ Printer.to_string sym);+ * print_endline( " fix_clause: transform: " ^ Printer.dump transform ^ " original: " ^ Printer.to_string original ^ " ???? " ^ String.concat "?" (tokenize (Printer.dump transform))); *)
+ let pattern = tokenize (Printer.dump pattern) in
+ let fixed_pattern = replace_token (List.tl pattern) (Printer.to_string sym) (ref []) in
+ let fixed_transform = replace_token (tokenize (Printer.dump transform)) (Printer.to_string original) (ref []) in
+ (* print_endline ("FIXED PATTERN: " ^ fixed_pattern);+ * print_endline ("FIXED TRANSFORM: " ^ fixed_transform); *)+ [ "("+ ; "define"
+ ; Printer.print sym true
+ ; "("+ ; "lambda"
+ ; "("+ ; fixed_pattern
+ ; ")"
+ ; "("+ ; fixed_transform
+ ; ")"
+ ; ")"
+ ; ")" ]
+ | T.List {T.value= [T.List {T.value= pattern; meta= _}; atom]; meta= _} ->+ (* print_endline(" fix_clause (atom): pattern: " ^ Printer.dump pattern ^ " sym: " ^ Printer.print sym true);+ * print_endline( "fix_clause: atom: " ^ Printer.to_string atom ^ " original: " ^ Printer.print original true); *)
+ let pattern = tokenize (Printer.dump pattern) in
+ let fixed_pattern = replace_token (List.tl pattern) (Printer.to_string sym) (ref []) in
+ ["("; "define"; Printer.to_string sym; "("; "lambda"; "("; fixed_pattern; ")"; Printer.to_string atom; ")"; ")"]+ | _ as e ->
+ raise (Utils.Syntax_error ("fix_clause botch: " ^ Printer.to_string e))+
let read_atom token =
match token with
- | "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 token.[1], token.[2] with
- | '\\', '0' .. '9' | '\\', 'a' .. 'z' | '\\', 'A' .. 'Z' -> T.Char token.[2]
- | _ -> Types.symbol token)
- | '-' ->
- (match String.length token with
- | 1 -> 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 (token.[1], token.[2]) with
+ | '\\', '0' .. '9' | '\\', 'a' .. 'z' | '\\', 'A' .. 'Z' ->
+ T.Char token.[2]
| _ ->
- (match token.[1] with
- | '0' .. '9' -> Types.number (float_of_string token)
- | _ -> Types.symbol token))
- | '"' -> T.String (unescape_string token)
- | _ -> Types.symbol token)
-;;
+ Types.symbol 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 (unescape_string token)
+ | _ ->
+ Types.symbol token )
let rec read_list eol list_reader =
- if List.length list_reader.tokens > 1 && List.hd list_reader.tokens = "("- then (
- match
- try Env.get registered_macros (Types.symbol (List.nth list_reader.tokens 1)) with
- | _ -> T.Nil
- with
- | T.List { T.value = _; 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)- | _ -> ());
+ ( if List.length list_reader.tokens > 1 && List.hd list_reader.tokens = "(" then+ match try Env.get registered_macros (Types.symbol (List.nth list_reader.tokens 1)) with _ -> T.Nil with
+ | T.List {T.value= _; 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 ^ "'"))- | [ _ ] -> { list_form = list_reader.list_form; tokens = [ ")" ] }+ print_endline ("ERROR: " ^ Printer.dump list_reader.list_form) ;+ raise (Utils.Syntax_error ("unterminated '" ^ eol ^ "'"))+ | [_] ->
+ {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 }- 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_quote sym tokens =
let reader = read_form tokens in
- { form = Types.list [ Types.symbol sym; reader.form ]; tokens = reader.tokens }+ {form= Types.list [Types.symbol sym; reader.form]; tokens= reader.tokens}and read_vector all_tokens =
match all_tokens with
- | [] -> raise End_of_file
- | token :: tokens ->
- (match token with
+ | [] ->
+ raise End_of_file
+ | token :: tokens -> (
+ match token with
| "(" ->- let list_reader = read_list ")" { list_form = []; tokens } in- { form = Types.vector list_reader.list_form; tokens = list_reader.tokens }- | _ -> read_form tokens)
+ let list_reader = read_list ")" {list_form= []; tokens} in+ {form= Types.vector list_reader.list_form; tokens= list_reader.tokens}+ | _ ->
+ read_form tokens )
and read_macro tokens =
let macro = ref [] in
- let list_reader = read_list ")" { list_form = []; tokens } in- print_endline ("MACRO: " ^ Printer.dump list_reader.list_form);- (match list_reader.list_form with
- | sym :: rest ->
- print_endline (" sym: " ^ Printer.print sym true);- print_endline (" rest: " ^ Printer.dump rest);- (match rest with
- | [ T.List { T.value = T.Symbol { T.value = "syntax-rules"; meta = _ } :: literals :: clauses; meta = _ } ] ->- List.iter (fun x -> print_endline("<<<<< " ^ String.concat "." x)) (Macro.generate_patterns sym clauses);- let sanitized_clauses = List.map (fun x -> (read_form x).form) (Macro.generate_patterns sym clauses) in
- (* print_endline ("sanitized: " ^ String.concat " " (List.map (fun x -> String.concat " " x) sanitized_clauses)); *)- print_endline ("sanitized: " ^ Printer.dump sanitized_clauses);- let variants = Macro.generate_variants sym literals sanitized_clauses in
- let macro_entry = Types.macro sym literals (Types.list sanitized_clauses) variants in
- 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);
- 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));+ let list_reader = read_list ")" {list_form= []; tokens} in+ print_endline ("MACRO: " ^ Printer.dump list_reader.list_form) ;+ ( match list_reader.list_form with
+ | sym :: rest -> (
+ print_endline (" sym: " ^ Printer.print sym true) ;+ print_endline (" rest: " ^ Printer.dump rest) ;+ match rest with
+ | [T.List {T.value= T.Symbol {T.value= "syntax-rules"; meta= _} :: literals :: clauses; meta= _}] ->+ let sanitized_clauses = List.flatten (Macro.sanitize_clauses sym clauses) in
+ print_endline (" sanitized_clauses: " ^ String.concat "!" sanitized_clauses) ;+ let variants = Macro.generate_variants sym literals sanitized_clauses in
+ Types.M9map.iter
+ (fun k v ->
+ print_endline (" >>> " ^ Printer.print k true ^ ": " ^ v) ;+ print_endline (" VARIANT ==> " ^ String.concat " " (fix_clause sym k (read_form (tokenize v)).form)) )+ variants ;
+ let variant_map = ref Types.M9map.empty in
+ Types.M9map.iter
+ (fun k v -> variant_map := Types.M9map.add k (read_form (tokenize v)).form !variant_map)
+ variants ;
+ let macro_entry =
+ Types.macro sym literals
+ (Types.list (List.map (fun x -> (read_form (tokenize x)).form) sanitized_clauses))
+ !variant_map
+ in
+ Env.set registered_macros sym macro_entry ;
+ Types.M9map.iter
+ (fun k v ->
+ let fixed_clause = fix_clause sym k (read_form (tokenize v)).form in
+ print_endline (" >>> " ^ Printer.print k true ^ ": " ^ String.concat " " fixed_clause) ;+ macro := !macro @ fixed_clause ;
+ Env.set registered_macros k (read_form fixed_clause).form )
+ variants
+ (* List.iter (fun x -> print_endline("<<<<< " ^ String.concat "." x)) (Macro.generate_patterns sym clauses);+ * let sanitized_clauses = List.map (fun x -> (read_form x).form) (Macro.generate_patterns sym clauses) in
+ * (\* print_endline ("sanitized: " ^ String.concat " " (List.map (fun x -> String.concat " " x) sanitized_clauses)); *\)+ * print_endline ("sanitized: " ^ Printer.dump sanitized_clauses);+ * let variants = Macro.generate_variants sym literals sanitized_clauses in
+ * let macro_entry = Types.macro sym literals (Types.list sanitized_clauses) variants in
+ * Env.set registered_macros sym macro_entry;
+ * Types.M9map.iter
+ * (fun k v ->
+ * print_endline
+ * (" >>> " ^ Printer.print k true ^ ": " ^ String.concat " " (fix_clause sym k v));+ * macro := !macro @ fix_clause sym k v;
+ * Env.set registered_macros k (read_form (fix_clause sym k v)).form)
+ * variants *)
+ | _ ->
+ raise (Utils.Syntax_error "read_macro botch") )
+ | _ as x ->
+ print_endline (" last rest: " ^ Printer.dump x) ) ;read_form !macro
and read_form all_tokens =
(* print_endline ("READ_FORM: " ^ String.concat " " all_tokens); *)match all_tokens with
- | [] -> raise End_of_file
- | token :: tokens ->
- (match token with
- | "'" -> read_quote "quote" tokens
- | "`" -> read_quote "quasiquote" tokens
- | "#" -> read_vector tokens
+ | [] ->
+ raise End_of_file
+ | token :: tokens -> (
+ match token with
+ | "'" ->
+ read_quote "quote" tokens
+ | "`" ->
+ read_quote "quasiquote" tokens
+ | "#" ->
+ read_vector tokens
| "#|" ->
- let list_reader = read_list "|#" { list_form = []; tokens } in- print_endline ("block comment: " ^ Printer.dump list_reader.list_form);- { form = T.Unspecified; tokens = list_reader.tokens }+ let list_reader = read_list "|#" {list_form= []; tokens} in+ print_endline ("block comment: " ^ Printer.dump list_reader.list_form) ;+ {form= T.Unspecified; tokens= list_reader.tokens} | "(" ->- 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
- | "define-syntax" -> read_macro tokens
+ 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
+ | "define-syntax" ->
+ read_macro tokens
| _ ->
- if token.[0] = ';'
- then (
- let list_reader = read_list "\\n" { list_form = []; tokens } in- print_endline ("line comment: " ^ String.concat " " list_reader.tokens);- { form = T.Unspecified; tokens = list_reader.tokens })- else { form = read_atom token; tokens })-;;
+ if token.[0] = ';' then (
+ let list_reader = read_list "\\n" {list_form= []; tokens} in+ print_endline ("line comment: " ^ String.concat " " list_reader.tokens) ;+ {form= T.Unspecified; tokens= list_reader.tokens} )+ else {form= read_atom token; tokens} )let slurp filename =
let chan = open_in filename in
let b = Buffer.create 27 in
- Buffer.add_channel b chan (in_channel_length chan);
- close_in chan;
+ Buffer.add_channel b chan (in_channel_length chan) ;
+ close_in chan ;
Buffer.contents b
-;;
let read str = (read_form (tokenize str)).form
--- a/types.ml
+++ b/types.ml
@@ -1,8 +1,5 @@
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
@@ -45,37 +42,38 @@
type m9type = Value.t
let macro_literals = Types.String "literals"
+
let macro_transformers = Types.String "transformers"
+
let macro_variants = Types.String "variants"
exception M9exn of Types.t
-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
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 map x = Types.Map { Types.value = x; meta = Types.Nil }+let list x = Types.List {Types.value= x; meta= Types.Nil}+let map x = Types.Map {Types.value= x; meta= Types.Nil}+
(* let pair x xs = Types.Pair ({ Types.value = x; meta = Types.Nil }, Types.List { Types.value = xs; 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) }+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)}+
let macro sym literals transformers variants =
let meta = ref M9map.empty in
- meta
- := M9map.add macro_literals literals !meta
- |> M9map.add macro_transformers transformers
- |> M9map.add macro_variants (map variants);
- Types.Macro { Types.value = sym; meta = map !meta }-;;
+ meta :=
+ M9map.add macro_literals literals !meta
+ |> M9map.add macro_transformers transformers
+ |> M9map.add macro_variants (map variants) ;
+ Types.Macro {Types.value= sym; meta= map !meta}--- a/utils.ml
+++ b/utils.ml
@@ -1,13 +1,7 @@
exception Syntax_error of string
+
exception Runtime_error of string
(* copied verbatim - must needs grok *)
let gsub re f str =
- String.concat
- ""
- (List.map
- (function
- | Str.Delim x -> f x
- | Str.Text x -> x)
- (Str.full_split re str))
-;;
+ String.concat "" (List.map (function Str.Delim x -> f x | Str.Text x -> x) (Str.full_split re str))