summaryrefslogtreecommitdiff
path: root/src/cjr_print.sml
diff options
context:
space:
mode:
Diffstat (limited to 'src/cjr_print.sml')
-rw-r--r--src/cjr_print.sml140
1 files changed, 98 insertions, 42 deletions
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 851fa02d..e69b87f1 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -490,23 +490,23 @@ fun p_sql_type t = string (Settings.p_sql_ctype t)
fun getPargs (e, _) =
case e of
EPrim (Prim.String _) => []
- | EFfiApp ("Basis", "strcat", [e1, e2]) => getPargs e1 @ getPargs e2
+ | EFfiApp ("Basis", "strcat", [(e1, _), (e2, _)]) => getPargs e1 @ getPargs e2
- | EFfiApp ("Basis", "sqlifyInt", [e]) => [(e, Int)]
- | EFfiApp ("Basis", "sqlifyFloat", [e]) => [(e, Float)]
- | EFfiApp ("Basis", "sqlifyString", [e]) => [(e, String)]
- | EFfiApp ("Basis", "sqlifyBool", [e]) => [(e, Bool)]
- | EFfiApp ("Basis", "sqlifyTime", [e]) => [(e, Time)]
- | EFfiApp ("Basis", "sqlifyBlob", [e]) => [(e, Blob)]
- | EFfiApp ("Basis", "sqlifyChannel", [e]) => [(e, Channel)]
- | EFfiApp ("Basis", "sqlifyClient", [e]) => [(e, Client)]
+ | EFfiApp ("Basis", "sqlifyInt", [(e, _)]) => [(e, Int)]
+ | EFfiApp ("Basis", "sqlifyFloat", [(e, _)]) => [(e, Float)]
+ | EFfiApp ("Basis", "sqlifyString", [(e, _)]) => [(e, String)]
+ | EFfiApp ("Basis", "sqlifyBool", [(e, _)]) => [(e, Bool)]
+ | EFfiApp ("Basis", "sqlifyTime", [(e, _)]) => [(e, Time)]
+ | EFfiApp ("Basis", "sqlifyBlob", [(e, _)]) => [(e, Blob)]
+ | EFfiApp ("Basis", "sqlifyChannel", [(e, _)]) => [(e, Channel)]
+ | EFfiApp ("Basis", "sqlifyClient", [(e, _)]) => [(e, Client)]
| ECase (e,
[((PNone _, _),
(EPrim (Prim.String "NULL"), _)),
((PSome (_, (PVar _, _)), _),
- (EFfiApp (m, x, [(ERel 0, _)]), _))],
- _) => map (fn (x, y) => (x, Nullable y)) (getPargs (EFfiApp (m, x, [e]), #2 e))
+ (EFfiApp (m, x, [((ERel 0, _), _)]), _))],
+ {disc = t, ...}) => map (fn (x, y) => (x, Nullable y)) (getPargs (EFfiApp (m, x, [(e, t)]), #2 e))
| ECase (e,
[((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, _), _),
@@ -1442,7 +1442,63 @@ fun potentiallyFancy (e, _) =
val self = ref (NONE : int option)
-fun p_exp' par tail env (e, loc) =
+(* The crucial thing to do here is assign arguments to local variables, to enforce order of evaluation.
+ * Otherwise, we are at the mercy of C's undefined order of function argument evaluation. *)
+fun pFuncall env (m, x, es, extra) =
+ case es of
+ [] => box [string "uw_",
+ p_ident m,
+ string "_",
+ p_ident x,
+ string "(ctx",
+ case extra of
+ NONE => box []
+ | SOME extra => box [string ",",
+ space,
+ string extra],
+ string ")"]
+ | [(e, _)] => box [string "uw_",
+ p_ident m,
+ string "_",
+ p_ident x,
+ string "(ctx,",
+ space,
+ p_exp' false false env e,
+ case extra of
+ NONE => box []
+ | SOME extra => box [string ",",
+ space,
+ string extra],
+ string ")"]
+ | _ => box [string "({",
+ newline,
+ p_list_sepi (box []) (fn i => fn (e, t) =>
+ box [p_typ env t,
+ space,
+ string "arg",
+ string (Int.toString i),
+ space,
+ string "=",
+ space,
+ p_exp' false false env e,
+ string ";",
+ newline]) es,
+ string "uw_",
+ p_ident m,
+ string "_",
+ p_ident x,
+ string "(ctx, ",
+ p_list_sepi (box [string ",", space]) (fn i => fn _ => box [string "arg", string (Int.toString i)]) es,
+ case extra of
+ NONE => box []
+ | SOME extra => box [string ",",
+ space,
+ string extra],
+ string ");",
+ newline,
+ string "})"]
+
+and p_exp' par tail env (e, loc) =
case e of
EPrim p => Prim.p_t_GCC p
| ERel n => p_rel env n
@@ -1572,15 +1628,29 @@ fun p_exp' par tail env (e, loc) =
| EReturnBlob {blob, mimeType, t} =>
box [string "({",
newline,
+ string "uw_Basis_blob",
+ space,
+ string "blob",
+ space,
+ string "=",
+ space,
+ p_exp' false false env blob,
+ string ";",
+ newline,
+ string "uw_Basis_string",
+ space,
+ string "mimeType",
+ space,
+ string "=",
+ space,
+ p_exp' false false env mimeType,
+ string ";",
+ newline,
p_typ env t,
space,
string "tmp;",
newline,
- string "uw_return_blob(ctx, ",
- p_exp' false false env blob,
- string ", ",
- p_exp' false false env mimeType,
- string ");",
+ string "uw_return_blob(ctx, blob, mimeType);",
newline,
string "tmp;",
newline,
@@ -1604,37 +1674,23 @@ fun p_exp' par tail env (e, loc) =
| EApp ((EReturnBlob {blob, mimeType, t = (TFun (_, ran), _)}, loc), _) =>
p_exp' false false env (EReturnBlob {blob = blob, mimeType = mimeType, t = ran}, loc)
- | EFfiApp ("Basis", "strcat", [e1, e2]) =>
+ | EFfiApp ("Basis", "strcat", [(e1, _), (e2, _)]) =>
let
fun flatten e =
case #1 e of
- EFfiApp ("Basis", "strcat", [e1, e2]) => flatten e1 @ flatten e2
+ EFfiApp ("Basis", "strcat", [(e1, _), (e2, _)]) => flatten e1 @ flatten e2
| _ => [e]
+
+ val es = flatten e1 @ flatten e2
+ val t = (TFfi ("Basis", "string"), loc)
+ val es = map (fn e => (e, t)) es
in
- case flatten e1 @ flatten e2 of
- [e1, e2] => box [string "uw_Basis_strcat(ctx, ",
- p_exp' false false env e1,
- string ",",
- p_exp' false false env e2,
- string ")"]
- | es => box [string "uw_Basis_mstrcat(ctx, ",
- p_list (p_exp' false false env) es,
- string ", NULL)"]
+ case es of
+ [_, _] => pFuncall env ("Basis", "strcat", es, NONE)
+ | _ => pFuncall env ("Basis", "mstrcat", es, SOME "NULL")
end
- | EFfiApp (m, x, []) => box [string "uw_",
- p_ident m,
- string "_",
- p_ident x,
- string "(ctx)"]
-
- | EFfiApp (m, x, es) => box [string "uw_",
- p_ident m,
- string "_",
- p_ident x,
- string "(ctx, ",
- p_list (p_exp' false false env) es,
- string ")"]
+ | EFfiApp (m, x, es) => pFuncall env (m, x, es, NONE)
| EApp (f, args) =>
let
fun default () = parenIf par (box [p_exp' true false env f,
@@ -3036,7 +3092,7 @@ fun p_file env (ds, ps) =
case e of
ECon (_, _, SOME e) => expDb e
| ESome (_, e) => expDb e
- | EFfiApp (_, _, es) => List.exists expDb es
+ | EFfiApp (_, _, es) => List.exists (expDb o #1) es
| EApp (e, es) => expDb e orelse List.exists expDb es
| EUnop (_, e) => expDb e
| EBinop (_, e1, e2) => expDb e1 orelse expDb e2