diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/c/urweb.c | 6 | ||||
| -rw-r--r-- | src/cjr.sml | 2 | ||||
| -rw-r--r-- | src/cjr_print.sml | 14 | ||||
| -rw-r--r-- | src/cjrize.sml | 8 | ||||
| -rw-r--r-- | src/mono.sml | 2 | ||||
| -rw-r--r-- | src/mono_print.sml | 9 | ||||
| -rw-r--r-- | src/mono_reduce.sml | 2 | ||||
| -rw-r--r-- | src/mono_util.sml | 7 | ||||
| -rw-r--r-- | src/monoize.sml | 9 | ||||
| -rw-r--r-- | src/prepare.sml | 7 |
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) |