almost

.gitignore

@@ -0,0 +1,7 @@
+core
+*.cmx
+*.cml
+*.cmi
+*.cmo
+*.o
+a.out

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))

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