summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/c/urweb.c6
-rw-r--r--src/cjr.sml2
-rw-r--r--src/cjr_print.sml14
-rw-r--r--src/cjrize.sml8
-rw-r--r--src/mono.sml2
-rw-r--r--src/mono_print.sml9
-rw-r--r--src/mono_reduce.sml2
-rw-r--r--src/mono_util.sml7
-rw-r--r--src/monoize.sml9
-rw-r--r--src/prepare.sml7
10 files changed, 65 insertions, 1 deletions
diff --git a/src/c/urweb.c b/src/c/urweb.c
index 6f54e1a7..c5f3a716 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -96,7 +96,7 @@ failure_kind lw_begin(lw_context ctx, char *path) {
return r;
}
-void lw_error(lw_context ctx, failure_kind fk, const char *fmt, ...) {
+__attribute__((noreturn)) void lw_error(lw_context ctx, failure_kind fk, const char *fmt, ...) {
va_list ap;
va_start(ap, fmt);
@@ -105,6 +105,10 @@ void lw_error(lw_context ctx, failure_kind fk, const char *fmt, ...) {
longjmp(ctx->jmp_buf, fk);
}
+__attribute__((noreturn)) void lw_Basis_error(lw_context ctx, const char *s) {
+ lw_error(ctx, FATAL, s);
+}
+
char *lw_error_message(lw_context ctx) {
return ctx->error_message;
}
diff --git a/src/cjr.sml b/src/cjr.sml
index 0f261de6..398f94c6 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -66,6 +66,8 @@ datatype exp' =
| ECase of exp * (pat * exp) list * { disc : typ, result : typ }
+ | EError of exp * typ
+
| EWrite of exp
| ESeq of exp * exp
| ELet of string * typ * exp * exp
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index c813a260..25a84b9c 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -455,6 +455,20 @@ fun p_exp' par env (e, loc) =
end
| EFfi (m, x) => box [string "lw_", string m, string "_", string x]
+ | EError (e, t) =>
+ box [string "({",
+ newline,
+ p_typ env t,
+ space,
+ string "tmp;",
+ newline,
+ string "lw_Basis_error(ctx, ",
+ p_exp env e,
+ string ");",
+ newline,
+ string "tmp;",
+ newline,
+ string "})"]
| EFfiApp (m, x, es) => box [string "lw_",
string m,
string "_",
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 71bb2a0d..f3e24710 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -253,6 +253,14 @@ fun cifyExp (eAll as (e, loc), sm) =
((L'.ECase (e, pes, {disc = disc, result = result}), loc), sm)
end
+ | L.EError (e, t) =>
+ let
+ val (e, sm) = cifyExp (e, sm)
+ val (t, sm) = cifyTyp (t, sm)
+ in
+ ((L'.EError (e, t), loc), sm)
+ end
+
| L.EStrcat (e1, e2) =>
let
val (e1, sm) = cifyExp (e1, sm)
diff --git a/src/mono.sml b/src/mono.sml
index cbe935c0..4ac21330 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -69,6 +69,8 @@ datatype exp' =
| EStrcat of exp * exp
+ | EError of exp * typ
+
| EWrite of exp
| ESeq of exp * exp
| ELet of string * typ * exp * exp
diff --git a/src/mono_print.sml b/src/mono_print.sml
index 3c090124..7ae28cf7 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -173,6 +173,15 @@ fun p_exp' par env (e, _) =
space,
p_exp (E.patBinds env p) e]) pes])
+ | EError (e, t) => box [string "(error",
+ space,
+ p_exp env e,
+ space,
+ string ":",
+ space,
+ p_typ env t,
+ string ")"]
+
| EStrcat (e1, e2) => box [p_exp' true env e1,
space,
string "^",
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index cc44869a..c1972729 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -55,6 +55,8 @@ fun impure (e, _) =
| ECase (e, pes, _) => impure e orelse List.exists (fn (_, e) => impure e) pes
+ | EError (e, _) => impure e
+
| EStrcat (e1, e2) => impure e1 orelse impure e2
| ESeq (e1, e2) => impure e1 orelse impure e2
diff --git a/src/mono_util.sml b/src/mono_util.sml
index 2b257641..f3604cf3 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -197,6 +197,13 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
fn result' =>
(ECase (e', pes', {disc = disc', result = result'}), loc)))))
+ | EError (e, t) =>
+ S.bind2 (mfe ctx e,
+ fn e' =>
+ S.map2 (mft t,
+ fn t' =>
+ (EError (e', t'), loc)))
+
| EStrcat (e1, e2) =>
S.bind2 (mfe ctx e1,
fn e1' =>
diff --git a/src/monoize.sml b/src/monoize.sml
index c79bea67..5fd344d4 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -1279,6 +1279,15 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
_), _),
xml) => monoExp (env, st, fm) xml
+ | L.ECApp ((L.EFfi ("Basis", "error"), _), t) =>
+ let
+ val t = monoType env t
+ in
+ ((L'.EAbs ("s", (L'.TFfi ("Basis", "string"), loc), t,
+ (L'.EError ((L'.ERel 0, loc), t), loc)), loc),
+ fm)
+ end
+
| L.EApp (e1, e2) =>
let
val (e1, fm) = monoExp (env, st, fm) e1
diff --git a/src/prepare.sml b/src/prepare.sml
index 67f6e0b6..64ccb465 100644
--- a/src/prepare.sml
+++ b/src/prepare.sml
@@ -106,6 +106,13 @@ fun prepExp (e as (_, loc), sns) =
((ECase (e, pes, ts), loc), sns)
end
+ | EError (e, t) =>
+ let
+ val (e, sns) = prepExp (e, sns)
+ in
+ ((EError (e, t), loc), sns)
+ end
+
| EWrite e =>
let
val (e, sns) = prepExp (e, sns)