macro constraints

sexpr.ml

@@ -672,6 +672,7 @@ end
 module SExprMacroExp = struct
   exception Misformated_Macro of SExpr.t
   exception Macro_Doesnt_App
+  exception Not_Valid_Macro_Arg_Syntax
   exception FIXME of SExpr.t
 
   let assoc_all k li =
@@ -707,7 +708,7 @@ module SExprMacroExp = struct
   and check_expands ctx s =
     let open SExpr in
     match s with
-      Cons(Id(":macro"), r) -> begin
+      Cons(Id ":macro", r) -> begin
         let a = match r with
           Cons(Id(l), Cons(a,b)) -> l, (a,b)
         | _ -> raise @@ Misformated_Macro s
@@ -717,7 +718,13 @@ module SExprMacroExp = struct
         in
         Nil, false, ctx
       end
-    | Cons(Id(i), r) when String.starts_with ~prefix:":" i ->
+    | Cons(Id ":c-eq", Cons(l, Cons(r, Nil))) -> begin
+        if l = r then
+          Nil, true, ctx
+        else
+          Cons(Nil, Nil), true, 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(_) ->
@@ -730,26 +737,33 @@ module SExprMacroExp = struct
         [] -> li1 s, false, ctx
       | hd :: tl ->
           try
-            expand_macro r hd, true, ctx
+            expand_macro r hd ctx, true, ctx
           with Macro_Doesnt_App ->
             test tl ctx
       end
     in
     test (assoc_all i ctx) ctx
-  and match_macro_arg args margs =
+  and match_macro_arg args margs ctx =
     let open SExpr in
     match args, margs with
-      Nil,        Nil                               -> []
-    | Cons(_),    Cons(Id(".."), Cons(Id(rem),Nil)) -> [rem, args]
-    | Cons(v,rl), Cons(Id(k), rr)                   -> [k,li1 v] @ match_macro_arg rl rr
-    | _                                             -> raise Macro_Doesnt_App
+      Nil,        Nil                                  -> []
+    | Cons(_),    Cons(Id(".."), Cons(Id(rem),Nil))    -> [rem, args]
+    | Cons(v,rl), Cons(Id(k), rr)                      -> [k,li1 v] @ match_macro_arg rl rr ctx
+    | Cons(v,rl), Cons(Cons(Id k, Cons(cst, Nil)), rr) ->
+        let cst_exp = expand_macro_eval cst ["_", li1 v] in
+        let cst_exp, _ = eval_while ctx cst_exp in
+        if cst_exp <> Nil then
+          raise Macro_Doesnt_App;
+        [k, li1 v] @ match_macro_arg rl rr ctx
+    | _                                                -> raise Macro_Doesnt_App
   and macro_req_score args =
     let open SExpr in
     match args with
       Nil                               -> 0
     | Cons(Id(".."), Cons(Id(rem),Nil)) -> 1
     | Cons(Id _, rr)                    -> 100 + macro_req_score rr
-    | _                                 -> raise Not_SExpr_List
+    | Cons(Cons(Id _, Cons(_,Nil)), rr) -> 110 + macro_req_score rr
+    | _                                 -> raise Not_Valid_Macro_Arg_Syntax
   and expand_macro_eval expr defs =
     let open SExpr in
     let perfm expr =
@@ -768,23 +782,21 @@ module SExprMacroExp = struct
       flat_map perfm expr
     else
       perfm expr
-  and expand_macro args macro =
+  and expand_macro args macro ctx =
     let margs, mbody = macro in
-    let defs = match_macro_arg args margs in
+    let defs = match_macro_arg args margs ctx in
     expand_macro_eval mbody defs
-
-  let do_eval s = begin
-    let rec inner ctx s = begin
-      let s, ch, ctx = eval ctx s in
-      if ch then
-        SExpr.aggr_flat_map inner ctx s
-      else
-        s, ctx
-    end in
-    inner [] s
-      |> fst
+  and eval_while ctx s = begin
+    let s, ch, ctx = eval ctx s in
+    if ch then
+      SExpr.aggr_flat_map eval_while ctx s
+    else
+      s, ctx
   end
 
+  let do_eval s =
+    eval_while [] s |> fst
+
   (* only use this for testing! *)
   let sparse src =
     PC.doparse