alexander.nutz/ocaml-sexpr
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

macro constraints

Browse Source
This commit is contained in:
Alexander Nutz
2025-08-31 00:48:17 +02:00
parent d01e77e0d2
commit 72e2696492
1 changed files with 34 additions and 22 deletions
Download Patch File Download Diff File Expand all files Collapse all files

56
sexpr.ml
View File

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