ref: 24cf0e8cd6799c80652dd2f7ecf41e0209dfe159
parent: 60993540fa2f1383724705faf0796202250c63f6
author: McKay Marston <[email protected]>
date: Wed Dec 2 14:10:56 EST 2020
about to mess up read_macro
--- a/core.ml
+++ b/core.ml
@@ -4,30 +4,22 @@
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"))
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 | _ -> [](* 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)) ;
@@ -61,18 +53,14 @@
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 ) ) ;
+ | [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= _}] ->Types.number (float_of_int (List.length xs))
- | _ ->
- Types.number 0. ) ) ;
+ | _ -> Types.number 0. ) ) ;
Env.set env (Types.symbol "display")
(Types.proc (function xs ->
print_string (Printer.stringify xs false) ;
@@ -85,13 +73,8 @@
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 []
- in
+ | 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 ) )
--- a/env.ml
+++ b/env.ml
@@ -10,27 +10,22 @@
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")
+ 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")
+ | _ -> 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")
+ | 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,49 +2,40 @@
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.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.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]
+ | 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.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.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) ;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
+ 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 ^ "))" ) ;
+ ^ Printer.print body true ^ ")" ) ;
Env.set env sym func ;
func
| T.List {T.value= [T.Symbol {T.value= "define"; meta= _}; key; expr]; meta= _} ->@@ -51,27 +42,23 @@
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= _} ->+ |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
- | [], [] ->
- ()
+ | [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
+ ^ 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= _} ->+ |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 ->@@ -78,9 +65,7 @@
let value = eval expr env in
Env.set env (Types.symbol sym) value ;
bind_pairs more
- | _ ->
- ()
- in
+ | _ -> () 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
@@ -88,17 +73,12 @@
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 {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.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
+ | _ as x -> raise (Utils.Syntax_error ("'" ^ Printer.print x true ^ "' not a function")) )+ | _ -> eval_ast ast env
--- a/m9.ml
+++ b/m9.ml
@@ -13,13 +13,9 @@
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 =
@@ -27,7 +23,7 @@
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) ;
+ 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 ;
@@ -35,8 +31,7 @@
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
--- a/macro.ml
+++ b/macro.ml
@@ -13,13 +13,9 @@
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
- in
+ | 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)))
@@ -40,8 +36,7 @@
| [], _ :: _ ->
(* print_endline " [] <-> LIST"; *)
false
- | _, _ ->
- matched
+ | _, _ -> matched
let ellipsis pattern template args =
let has_ellipsis =
@@ -48,8 +43,7 @@
try
ignore (Str.search_forward (Str.regexp "...") (Printer.stringify pattern true) 0) ;
true
- with Not_found -> false
- in
+ 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)) ;@@ -65,13 +59,11 @@
let pattern_str =
Str.global_replace (Str.regexp "\\.\\.\\.")
(String.concat " " !ellipsis_substitutions)
- (Printer.stringify pattern true)
- in
+ (Printer.stringify pattern true) in
let template_str =
Str.global_replace (Str.regexp "\\.\\.\\.")
(String.concat " " !ellipsis_substitutions)
- (Printer.stringify template true)
- in
+ (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 ^ ")"@@ -88,8 +80,7 @@
* 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 =
@@ -99,9 +90,8 @@
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 ^ "))"- in
- print_endline (" SANITIZED: " ^ sanitized) ;+ with Not_found -> "((" ^ Printer.dump pattern ^ ") (" ^ Printer.dump template ^ "))" in+ (* print_endline (" SANITIZED: " ^ sanitized) ; *)sanitized
let parse ast _ =
@@ -123,8 +113,7 @@
@ [ "(("^ String.concat " " (List.map (fun x -> Printer.to_string x) pattern)
^ ") " ^ Printer.to_string atom ^ ")" ]
- | _ as x ->
- print_endline ("nope: " ^ Printer.print x true) ) ;+ | _ as x -> print_endline ("nope: " ^ Printer.print x true) ) ;!clauses
(* print_endline (" head: " ^ Printer.print (List.hd clause) true);@@ -138,22 +127,20 @@
(* ((_) #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 =
+ let rec sanitize unsanitized =
match unsanitized with
| [clause] ->
- print_endline
- (" CLAUSE: " ^ Printer.print clause true ^ " <|> " ^ String.concat " " (hack_ellipsis prefix clause)) ;+ (* print_endline
+ * (" CLAUSE: " ^ Printer.print clause true ^ " <|> " ^ String.concat " " (hack_ellipsis prefix clause)) ; *)sanitized := !sanitized @ [hack_ellipsis prefix clause] ;
!sanitized
| clause :: rest ->
- print_endline
- (" CLAUSE: " ^ Printer.print clause true ^ " <|> " ^ String.concat " " (hack_ellipsis prefix clause)) ;+ (* 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
+ sanitize rest
+ | [] -> !sanitized in
+ sanitize clauses
let generate_variants sym _ clauses =
let symbol = Printer.print sym true in
@@ -167,13 +154,18 @@
| clause :: rest ->
variants := Types.M9map.add new_sym clause !variants ;
register_variants rest
- | _ ->
- raise (Utils.Syntax_error "macro clause registration botch")
- in
+ | _ -> raise (Utils.Syntax_error "macro clause registration botch") in
register_variants clauses
+let rec collect_args tokens args =
+ match tokens with
+ | [t] -> args @ [t]
+ | t :: ts -> if t = ")" then args else collect_args ts args @ [t]
+ | _ -> []
+
let match_variant macro args =
let vmatch = ref "" in
+ print_endline ("match_variant: " ^ Printer.to_string macro);( match macro with
| T.Map {T.value= meta; meta= _} -> (match Types.M9map.find Types.macro_variants meta with
@@ -180,21 +172,23 @@
| 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
- | _ ->
- () )
+ print_endline (" >>> " ^ Printer.to_string k ^ ": " ^ Printer.to_string v) ;+ let wrong = Utils.tokenize (Printer.to_string v) in
+ print_endline ("->->-> " ^ String.concat "*" wrong);+ (match wrong with
+ | "(" :: "define" :: sym :: "(":: "lambda" :: rest ->+ print_endline ("SYM: " ^ sym ^ " REST: " ^ String.concat " " rest);+ let new_args = collect_args (List.tl rest) [] in
+ print_endline (" ARGS: " ^ String.concat " " new_args ^ " [" ^ string_of_int (List.length new_args) ^ "] args:[" ^ string_of_int (List.length args - 1) ^ "]");+ if List.length new_args = List.length args - 1 then vmatch := sym
+ | _ -> print_endline "no rest");
+ (* match v with
+ * | T.List { T.value = [T.Symbol { T.value = "define"; meta = _ }; T.Symbol { T.value = sym; meta = _ } ]; meta = _ } -> *)+ print_endline ( " >>>> sym: " ^ Printer.to_string k);
+ print_endline ( " >>>> args: " ^ String.concat " " args);
+ print_endline ( " >>>> v: " ^ Printer.to_string v))
+ (* | _ -> () ) *)
variant_list
- | _ ->
- () )
- | _ ->
- () ) ;
+ | _ -> () )
+ | _ -> () ) ;
!vmatch
--- a/printer.ml
+++ b/printer.ml
@@ -2,58 +2,37 @@
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.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.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>"
+ | 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 " "
@@ -60,5 +39,4 @@
(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,20 +1,11 @@
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 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))
-
let unescape_string token =
if Str.string_match string_re token 0 then
let without_quotes = String.sub token 1 (String.length token - 2) in
@@ -21,6 +12,8 @@
Utils.gsub (Str.regexp "\\\\.") (function "\\n" -> "\n" | x -> String.sub x 1 1) without_quotes
else raise (Utils.Syntax_error "unterminated string")
+let trim_end list = List.rev (List.tl (List.rev list))
+
let rec replace_token tokens replacement block =
match tokens with
| [token] ->
@@ -31,102 +24,71 @@
let t = if token = "_" then replacement else token in
block := !block @ [t] ;
replace_token rest replacement block
- | _ ->
- String.concat " " !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) ;+ 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 pattern = Utils.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
- ; ")"
- ; ")"
- ; ")" ]
+ let fixed_transform = replace_token (Utils.tokenize (Printer.dump transform)) (Printer.to_string original) (ref []) in
+ [ "("; "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 pattern = Utils.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))+ | _ 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
+ | "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)
+ | '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 )
+ | '\\', '0' .. '9' | '\\', 'a' .. 'z' | '\\', 'A' .. 'Z' -> T.Char token.[2]
+ | _ -> 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 )
+ | 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)- | _ ->
- () ) ;
- match list_reader.tokens with
+ (* we need to replace macro calls with their variant symbols *)
+ let tweaked_tokens =
+ if List.length list_reader.tokens > 1 && List.hd list_reader.tokens = "(" then+ let symbol = Types.symbol (List.nth list_reader.tokens 1) in
+ match try Env.get registered_macros symbol with _ -> T.Nil with
+ | T.Macro {T.value= m; meta} ->+ print_endline "XXXX MACRO FOUND" ;
+ print_endline ("XXXX MACRO: " ^ Printer.to_string m) ;+ print_endline ("XXXX META: " ^ Printer.to_string meta);+ print_endline ("XXXX TOKENS: " ^ String.concat " " list_reader.tokens);+ let args = Macro.collect_args (List.tl list_reader.tokens) [] in
+ print_endline ("<><><> args: " ^ String.concat " " args) ;+ let variant = Macro.match_variant meta args in
+ print_endline ("<><><><>: " ^ variant) ;+ List.map (fun s -> if s = Printer.to_string symbol then variant else s) list_reader.tokens
+ | _ -> list_reader.tokens
+ else list_reader.tokens in
+ (* print_endline ("TWEAKED_TOKENS: [" ^ String.concat " " tweaked_tokens ^ "]"); *)+ match tweaked_tokens with
| [] ->
- print_endline ("ERROR: " ^ Printer.dump list_reader.list_form) ;- raise (Utils.Syntax_error ("unterminated '" ^ eol ^ "'"))- | [_] ->
- {list_form= list_reader.list_form; tokens= [")"]}+ raise (Utils.Syntax_error ("read_list botch: '" ^ Printer.dump list_reader.list_form ^ "' eol: '" ^ 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 tweaked_tokens in
+ print_endline ("token: " ^ token ^ " tokens: " ^ String.concat " " 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
@@ -134,84 +96,73 @@
and read_vector all_tokens =
match all_tokens with
- | [] ->
- raise End_of_file
+ | [] -> 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 )
+ | _ -> 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) ;+ print_endline ("READ_MACRO: " ^ Printer.dump list_reader.list_form) ;+ print_endline ("READ_MACRO tokens: " ^ String.concat " " list_reader.tokens) ;( match list_reader.list_form with
| sym :: rest -> (
- print_endline (" sym: " ^ Printer.print sym true) ;- print_endline (" rest: " ^ Printer.dump rest) ;+ print_endline ("> sym: " ^ Printer.to_string sym) ;+ 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
+ let fixed_variants = ref Types.M9map.empty in
+ let transforms = ref Types.M9map.empty 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)) )+ (fun k v -> transforms := Types.M9map.add k (Utils.tokenize v) !transforms)
variants ;
- let variant_map = ref Types.M9map.empty in
+
+ let fixed_clauses = ref [] in
Types.M9map.iter
- (fun k v -> variant_map := Types.M9map.add k (read_form (tokenize v)).form !variant_map)
- variants ;
+ (fun k v ->
+ let fixed_clause = fix_clause sym k (read_form (Utils.tokenize v)).form in
+ print_endline
+ (">>>> registering variant: " ^ Printer.print k true ^ ": " ^ String.concat " " fixed_clause) ;+ macro := !macro @ fixed_clause;
+ let parsed = (read_form fixed_clause).form in
+ fixed_clauses := !fixed_clauses @ [ parsed ];
+ fixed_variants := Types.M9map.add k parsed !fixed_variants;
+ Env.set registered_macros k parsed)
+ variants;
+ print_endline ("trying to parse macro: " ^ String.concat " " !macro);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
+ T.Nil
+ !fixed_variants in
+ Env.set registered_macros sym macro_entry;
+ print_endline ("finished")+ | _ -> raise (Utils.Syntax_error "read_macro botch") )
+ | _ -> raise (Utils.Syntax_error "read_macro last rest botch") ) ;
+ print_endline ("SO HERE ARE THE MACRO VARIANTS: " ^ String.concat " " !macro) ;+ (* the first and last () because the parser makes the whole thing a bogus list *)
+ let trimmed_macro = List.tl !macro in
+ let trimmed_tokens = trim_end list_reader.tokens in
+ print_endline ("TRIMMED_MACRO: " ^ String.concat " " trimmed_macro) ;+ print_endline ("TRIMMED_TOKENS: " ^ String.concat " " trimmed_tokens) ;+ print_endline ("TRIMMED_MACRO: " ^ String.concat " " (trimmed_macro @ trimmed_tokens));+ trimmed_macro @ trimmed_tokens
+
and read_form all_tokens =
(* print_endline ("READ_FORM: " ^ String.concat " " all_tokens); *)match all_tokens with
- | [] ->
- raise End_of_file
+ | [] -> raise End_of_file
| token :: tokens -> (
match token with
- | "'" ->
- read_quote "quote" tokens
- | "`" ->
- read_quote "quasiquote" tokens
- | "#" ->
- read_vector tokens
+ | "'" -> 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) ;@@ -219,10 +170,12 @@
| "(" -> 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
+ | "" | "\t" | "\n" -> read_form tokens
+ (* | "define-syntax" -> read_form (read_macro tokens) *)
| "define-syntax" ->
- read_macro tokens
+ let list_reader = read_list ")" {list_form= []; tokens= read_macro tokens} in+ print_endline ("macro: " ^ Printer.dump list_reader.list_form) ;+ {form= T.Unspecified; tokens= list_reader.tokens}| _ ->
if token.[0] = ';' then (
let list_reader = read_list "\\n" {list_form= []; tokens} in@@ -237,4 +190,10 @@
close_in chan ;
Buffer.contents b
-let read str = (read_form (tokenize str)).form
+(* let read str = (read_form (tokenize str)).form *)
+let read str =
+ let tokenized = Utils.tokenize str in
+ print_endline ("TOKENIZED: " ^ String.concat " " tokenized) ;+ let form = (read_form tokenized).form in
+ print_endline ("FORM: " ^ Printer.to_string form) ;+ form
--- a/types.ml
+++ b/types.ml
@@ -42,9 +42,7 @@
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
@@ -56,18 +54,13 @@
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 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 macro sym literals transformers variants =
--- a/utils.ml
+++ b/utils.ml
@@ -1,7 +1,14 @@
exception Syntax_error of string
-
exception Runtime_error of string
+let token_re = Str.regexp "~@\\|[][{}()'`~^@]\\|\"\\(\\\\.\\|[^\"]\\)*\"?\\|;.*\\$\\|[^][ \n{}('\"`,;)]*"+
(* 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))
+
+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))
+