summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/c/urweb.c38
-rw-r--r--src/cjr_env.sml4
-rw-r--r--src/cjr_print.sml11
-rw-r--r--src/cjrize.sml3
-rw-r--r--src/compiler.sml16
-rw-r--r--src/elaborate.sml27
-rw-r--r--src/mono_reduce.sml6
-rw-r--r--src/tag.sml4
8 files changed, 83 insertions, 26 deletions
diff --git a/src/c/urweb.c b/src/c/urweb.c
index f0e93e46..57caa03d 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -589,3 +589,41 @@ lw_Basis_string lw_Basis_strdup(lw_context ctx, lw_Basis_string s1) {
return s;
}
+
+
+lw_Basis_string lw_Basis_sqlifyString(lw_context ctx, lw_Basis_string s) {
+ char *r, *s2;
+
+ lw_check_heap(ctx, strlen(s) * 2 + 4);
+
+ r = s2 = ctx->heap_front;
+ *s2++ = 'E';
+ *s2++ = '\'';
+
+ for (; *s; s++) {
+ char c = *s;
+
+ switch (c) {
+ case '\'':
+ strcpy(s2, "\\'");
+ s2 += 2;
+ break;
+ case '\\':
+ strcpy(s2, "\\\\");
+ s2 += 2;
+ break;
+ default:
+ if (isprint(c))
+ *s2++ = c;
+ else {
+ sprintf(s2, "\\%3o", c);
+ s2 += 4;
+ }
+ }
+ }
+
+ *s2++ = '\'';
+ *s2++ = 0;
+ ctx->heap_front = s2;
+ return r;
+}
diff --git a/src/cjr_env.sml b/src/cjr_env.sml
index 482b93f6..0859abe5 100644
--- a/src/cjr_env.sml
+++ b/src/cjr_env.sml
@@ -48,7 +48,7 @@ type env = {
structs : (string * typ) list IM.map
}
-val empty = {
+val empty : env = {
datatypes = IM.empty,
constructors = IM.empty,
@@ -56,7 +56,7 @@ val empty = {
relE = [],
namedE = IM.empty,
- structs = IM.empty
+ structs = IM.insert (IM.empty, 0, [])
}
fun pushDatatype (env : env) x n xncs =
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 938821be..50098a99 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -881,7 +881,7 @@ fun p_file env (ds, ps) =
case ek of
Core.Link => fields
| Core.Action =>
- case List.last ts of
+ case List.nth (ts, length ts - 2) of
(TRecord i, _) =>
let
val xts = E.lookupStruct env i
@@ -1222,12 +1222,12 @@ fun p_file env (ds, ps) =
case ek of
Core.Link => (ts, string "", string "")
| Core.Action =>
- case List.last ts of
+ case List.nth (ts, length ts - 2) of
(TRecord i, _) =>
let
val xts = E.lookupStruct env i
in
- (List.drop (ts, 1),
+ (List.take (ts, length ts - 2),
box [box (map (fn (x, t) => box [p_typ env t,
space,
string "lw_input_",
@@ -1324,10 +1324,9 @@ fun p_file env (ds, ps) =
p_list_sep (box [string ",", space])
(fn x => x)
(string "ctx"
- :: ListUtil.mapi (fn (i, _) => string ("arg" ^ Int.toString i)) ts
- @ [string "lw_unit_v"]),
+ :: ListUtil.mapi (fn (i, _) => string ("arg" ^ Int.toString i)) ts),
inputsVar,
- string ");",
+ string ", lw_unit_v);",
newline,
string "return;",
newline,
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 88fae6f0..ed8182c2 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -171,7 +171,7 @@ fun cifyPat ((p, loc), sm) =
((L'.PRecord xps, loc), sm)
end
-fun cifyExp ((e, loc), sm) =
+fun cifyExp (eAll as (e, loc), sm) =
case e of
L.EPrim p => ((L'.EPrim p, loc), sm)
| L.ERel n => ((L'.ERel n, loc), sm)
@@ -206,6 +206,7 @@ fun cifyExp ((e, loc), sm) =
((L'.EApp (e1, e2), loc), sm)
end
| L.EAbs _ => (ErrorMsg.errorAt loc "Anonymous function remains at code generation";
+ Print.prefaces' [("Function", MonoPrint.p_exp MonoEnv.empty eAll)];
(dummye, sm))
| L.ERecord xes =>
diff --git a/src/compiler.sml b/src/compiler.sml
index f9fe0da8..263aaf9a 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -93,15 +93,17 @@ fun op o (tr2 : ('b, 'c) transform, tr1 : ('a, 'b) transform) = {
end
}
-fun run (tr : ('src, 'dst) transform) = #func tr
+fun run (tr : ('src, 'dst) transform) x = (ErrorMsg.resetErrors ();
+ #func tr x)
fun runPrint (tr : ('src, 'dst) transform) input =
- case #func tr input of
- NONE => print "Failure\n"
- | SOME v =>
- (print "Success\n";
- Print.print (#print tr v);
- print "\n")
+ (ErrorMsg.resetErrors ();
+ case #func tr input of
+ NONE => print "Failure\n"
+ | SOME v =>
+ (print "Success\n";
+ Print.print (#print tr v);
+ print "\n"))
fun time (tr : ('src, 'dst) transform) input =
let
diff --git a/src/elaborate.sml b/src/elaborate.sml
index d4b71b80..5770fe5b 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -1482,11 +1482,9 @@ fun normClassConstraint envs (c, loc) =
fun elabExp (env, denv) (eAll as (e, loc)) =
let
-
- in
- (*eprefaces "elabExp" [("eAll", SourcePrint.p_exp eAll)];*)
+ (*val () = eprefaces "elabExp" [("eAll", SourcePrint.p_exp eAll)];*)
- case e of
+ val r = case e of
L.EAnnot (e, t) =>
let
val (e', et, gs1) = elabExp (env, denv) e
@@ -1756,6 +1754,12 @@ fun elabExp (env, denv) (eAll as (e, loc)) =
((L'.ECase (e', pes', {disc = et, result = result}), loc), result, enD gs' @ gs)
end
+
+ (*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 r)*)
+ in
+ (*prefaces "elabExp" [("e", SourcePrint.p_exp eAll),
+ ("|tcs|", PD.string (Int.toString (length tcs)))];*)
+ r
end
@@ -2731,7 +2735,7 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) =
| _ => sgnError env (SgnWrongForm (sgn1, sgn2))
-fun elabDecl ((d, loc), (env, denv, gs : constraint list)) =
+fun elabDecl (dAll as (d, loc), (env, denv, gs : constraint list)) =
let
(*val () = preface ("elabDecl", SourcePrint.p_decl (d, loc))*)
@@ -2873,7 +2877,7 @@ fun elabDecl ((d, loc), (env, denv, gs : constraint list)) =
| SOME c => elabCon (env, denv) c
in
((x, c', e), enD gs1 @ gs)
- end) [] vis
+ end) gs vis
val (vis, env) = ListUtil.foldlMap (fn ((x, c', e), env) =>
let
@@ -3103,16 +3107,21 @@ fun elabDecl ((d, loc), (env, denv, gs : constraint list)) =
| L.DClass (x, c) =>
let
val k = (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc)
- val (c', ck, gs) = elabCon (env, denv) c
+ val (c', ck, gs') = elabCon (env, denv) c
val (env, n) = E.pushCNamed env x k (SOME c')
val env = E.pushClass env n
in
checkKind env c' ck k;
- ([(L'.DClass (x, n, c'), loc)], (env, denv, []))
+ ([(L'.DClass (x, n, c'), loc)], (env, denv, enD gs' @ gs))
end
- | L.DDatabase s => ([(L'.DDatabase s, loc)], (env, denv, []))
+ | L.DDatabase s => ([(L'.DDatabase s, loc)], (env, denv, gs))
+
+ (*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 (#2 r))*)
in
+ (*prefaces "elabDecl" [("e", SourcePrint.p_decl dAll),
+ ("|tcs|", PD.string (Int.toString (length tcs)))];*)
+
r
end
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 5367be60..cc44869a 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -97,6 +97,12 @@ fun match (env, p : pat, e : exp) =
(PWild, _) => Yes env
| (PVar (x, t), _) => Yes (E.pushERel env x t (SOME e))
+ | (PPrim (Prim.String s), EStrcat ((EPrim (Prim.String s'), _), _)) =>
+ if String.isPrefix s' s then
+ Maybe
+ else
+ No
+
| (PPrim p, EPrim p') =>
if Prim.equal (p, p') then
Yes env
diff --git a/src/tag.sml b/src/tag.sml
index a8b59c5a..34595732 100644
--- a/src/tag.sml
+++ b/src/tag.sml
@@ -216,7 +216,9 @@ fun tag file =
((EApp (app, (ERel n, loc)), loc),
n - 1))
((ENamed f, loc), length args - 1) args
+ val app = (EApp (app, (ERecord [], loc)), loc)
val body = (EWrite app, loc)
+ val t = (TFun (unit, unit), loc)
val (abs, _, t) = foldr (fn (t, (abs, n, rest)) =>
((EAbs ("x" ^ Int.toString n,
t,
@@ -224,7 +226,7 @@ fun tag file =
abs), loc),
n + 1,
(TFun (t, rest), loc)))
- (body, 0, unit) args
+ (body, 0, t) args
in
(abs, t)
end
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-28 22:02:09 +0000