diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..8ffd9c6 --- /dev/null +++ b/.gitignore @@ -0,0 +1,7 @@ +core +*.cmx +*.cml +*.cmi +*.cmo +*.o +a.out diff --git a/example.lsp b/example.lsp index 3313ea8..be8088e 100644 --- a/example.lsp +++ b/example.lsp @@ -6,8 +6,8 @@ (:macro seq (hd .. tl) (:seq hd) (:seq tl)) -(:macro @ ('k) - (:t 'k ":")) +(:macro @ (k) + (:t k ":")) (:macro @ (k v) (:t k ": " v)) diff --git a/sexpr.ml b/sexpr.ml index 774f9c3..59ae482 100644 --- a/sexpr.ml +++ b/sexpr.ml @@ -24,7 +24,7 @@ module Testing = struct Printf.printf "Pass\n%!"; Pass with e -> - Printf.printf "FAIL\n"; + Printf.printf "FAIL\n%!"; if test_only <> [] then begin let msg = Printexc.to_string e and stack = Printexc.get_backtrace () in @@ -440,13 +440,13 @@ module SExpr = struct let li1 s = Cons(s, Nil) - exception Not_Sexpr_List + exception Not_SExpr_List let rec append tl hd = match hd with Nil -> tl | Cons(x, rem) -> Cons(x, append tl rem) - | _ -> raise Not_Sexpr_List + | _ -> raise Not_SExpr_List let () = test "SExpr.append" @@ begin fun () -> let a = Cons(Int 1, Cons(Int 2, Cons(Int 3, Nil))) @@ -471,7 +471,7 @@ module SExpr = struct match li with Nil -> Nil | Cons(x, rem) -> append (flat_map fn rem) (fn x) - | _ -> raise Not_Sexpr_List + | _ -> raise Not_SExpr_List let () = test "SExpr.flat_map.0" @@ begin fun () -> let a = Cons(Int 1, Cons(Int 2, Cons(Int 3, Nil))) @@ -498,7 +498,7 @@ module SExpr = struct let x, acc = fn acc x in let vv, acc = aggr_flat_map fn acc rem in append vv x, acc - | _ -> raise Not_Sexpr_List + | _ -> raise Not_SExpr_List let () = test "SExpr.aggr_flat_map.0" @@ begin fun () -> let a = Cons(Int 1, Cons(Int 2, Nil)) @@ -660,13 +660,14 @@ module SExpr = struct |> until ex_end |> map (fun li -> List.fold_right (fun x acc -> Cons(x,acc)) li Nil) + + let parser_tests = [] end module SExprMacroExp = struct exception Misformated_Macro of SExpr.t exception Macro_Doesnt_App - exception Macro_App_TODO of ((string * SExpr.t) list) * SExpr.t exception FIXME of SExpr.t let assoc_all k li = @@ -691,8 +692,7 @@ module SExprMacroExp = struct else s, ctx in - let s, ctx = check_expands_while ctx s in - s, ctx + check_expands_while ctx s (* expr -> list(new exprs) * bool:changed * ctx *) and check_expands ctx s = let open SExpr in @@ -704,27 +704,29 @@ module SExprMacroExp = struct in Nil, false, (a :: ctx) end - | Cons(Id(i), r) -> begin - let i = if String.starts_with ~prefix:":" i then - String.sub i 1 ((String.length i) - 1) - else "@" in - let rec test opt ctx = - begin match opt with - [] -> li1 s, false, ctx - | hd :: tl -> - try - expand_macro r hd, true, ctx - with Macro_Doesnt_App -> - test tl ctx - end - in - test (assoc_all i ctx) ctx - end + | Cons(Id(i), r) when String.starts_with ~prefix:":" i -> + let i = String.sub i 1 ((String.length i) - 1) in + check_expands_macro i ctx r s + | Cons(_) -> + check_expands_macro "@" ctx s s | s -> li1 s, false, ctx + and check_expands_macro i ctx r s = + let open SExpr in + let rec test opt ctx = + begin match opt with + [] -> li1 s, false, ctx + | hd :: tl -> + try + expand_macro r hd, true, ctx + with Macro_Doesnt_App -> + test tl ctx + end + in + test (assoc_all i ctx) ctx and check_expands_while ctx s = let s', c, ctx' = check_expands ctx s in if c then - check_expands_while ctx' s' + SExpr.aggr_flat_map check_expands_while ctx' s' else s', ctx' and match_macro_arg args margs = @@ -732,17 +734,42 @@ module SExprMacroExp = struct match args, margs with Nil, Nil -> [] | Cons(_), Cons(Id(".."), Cons(Id(rem),Nil)) -> [rem, args] - | Cons(v,rl), Cons(Id(k), rr) -> [k,v] @ match_macro_arg rl rr + | Cons(v,rl), Cons(Id(k), rr) -> [k,li1 v] @ match_macro_arg rl rr | _ -> raise Macro_Doesnt_App + and expand_macro_eval expr defs = + let open SExpr in + let perfm expr = + begin match expr with + Id(i) when String.starts_with ~prefix:"'" i -> + li1 @@ Id(String.sub i 1 (String.length i - 1)) + | Id(i) -> begin match List.assoc_opt i defs with + Some x -> x + | None -> li1 expr + end + | x when is_list x -> expand_macro_eval x defs + | x -> li1 x + end + in + if is_list expr then + flat_map perfm expr + else + perfm expr and expand_macro args macro = let (margs, mbody) = macro in let defs = match_macro_arg args margs in - raise @@ Macro_App_TODO (defs, mbody); - args + expand_macro_eval mbody defs let do_eval s = eval [] s |> fst + (* only use this for testing! *) + let sparse src = + PC.doparse + Format.err_formatter + { source = src; path = "top" } + (SExpr.parse_top ()) + |> Option.get + let () = test "SExprMacroExp.do_eval.unchanged_num" @@ begin fun () -> let open SExpr in let a = Int 1 in @@ -760,6 +787,55 @@ module SExprMacroExp = struct let a = Cons(Int 1, Cons( Cons(Int 10, Cons(Int 20, Nil)), Cons(Int 3, Nil))) in assert (do_eval a = li1 a) end + + let () = test "SExprMacroExp.do_eval.macro_no_body" ~depends:SExpr.parser_tests @@ begin fun () -> + let open SExpr in + let a = "(:macro one()) (:one)" + and p = "()" in + assert (do_eval (sparse a) = sparse p) + end + + let () = test "SExprMacroExp.do_eval.macro_body" ~depends:SExpr.parser_tests @@ begin fun () -> + let open SExpr in + let a = "(:macro a() 1 2) (:a)" + and p = "(1 2)" in + assert (do_eval (sparse a) = sparse p) + end + + let () = test "SExprMacroExp.do_eval.macro_arg" ~depends:SExpr.parser_tests @@ begin fun () -> + let open SExpr in + let a = "(:macro a(arg) 1 arg) (:a 2)" + and p = "(1 2)" in + assert (do_eval (sparse a) = sparse p) + end + + let () = test "SExprMacroExp.do_eval.macro_args" ~depends:SExpr.parser_tests @@ begin fun () -> + let open SExpr in + let a = "(:macro a(arg arg2) arg2 1 arg) (:a 2 0)" + and p = "(0 1 2)" in + assert (do_eval (sparse a) = sparse p) + end + + let () = test "SExprMacroExp.do_eval.macro_varargs" ~depends:SExpr.parser_tests @@ begin fun () -> + let open SExpr in + let a = "(:macro a(arg .. rem) arg 1 rem) (:a 0 2 3)" + and p = "(0 1 2 3)" in + assert (do_eval (sparse a) = sparse p) + end + + let () = test "SExprMacroExp.do_eval.macro_varargs_notmatch_none" ~depends:SExpr.parser_tests @@ begin fun () -> + let open SExpr in + let a = "(:macro a(arg .. rem) arg 1 rem) (:a 0)" + and p = "((:a 0))" in + assert (do_eval (sparse a) = sparse p) + end + + let () = test "SExprMacroExp.do_eval.macro_body_paren" ~depends:SExpr.parser_tests @@ begin fun () -> + let open SExpr in + let a = "(:macro a() (1)) (:a)" + and p = "((1))" in + assert (do_eval (sparse a) = sparse p) + end end