Mercurial > urweb
changeset 283:c0e4ac23522d
'error' function
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sun, 07 Sep 2008 10:02:27 -0400 |
| parents | 0236d9412ad2 |
| children | 77a28e7430bf |
| files | include/urweb.h lib/basis.urs src/c/urweb.c src/cjr.sml src/cjr_print.sml src/cjrize.sml src/mono.sml src/mono_print.sml src/mono_reduce.sml src/mono_util.sml src/monoize.sml src/prepare.sml tests/error.ur tests/error.urp |
| diffstat | 14 files changed, 85 insertions(+), 2 deletions(-) [+] |
line wrap: on
line diff
--- a/include/urweb.h Sun Sep 07 09:28:13 2008 -0400 +++ b/include/urweb.h Sun Sep 07 10:02:27 2008 -0400 @@ -17,7 +17,8 @@ failure_kind lw_begin_init(lw_context); failure_kind lw_begin(lw_context, char *path); -void lw_error(lw_context, failure_kind, const char *fmt, ...); +__attribute__((noreturn)) void lw_error(lw_context, failure_kind, const char *fmt, ...); +__attribute__((noreturn)) void lw_Basis_error(lw_context, lw_Basis_string); char *lw_error_message(lw_context); void *lw_malloc(lw_context, size_t);
--- a/lib/basis.urs Sun Sep 07 09:28:13 2008 -0400 +++ b/lib/basis.urs Sun Sep 07 10:02:27 2008 -0400 @@ -17,6 +17,11 @@ val eq_bool : eq bool +(** String operations *) + +val strcat : string -> string -> string + + (** SQL *) con sql_table :: {Type} -> Type @@ -256,3 +261,8 @@ val submit : ctx ::: {Unit} -> [LForm] ~ ctx -> use ::: {Type} -> unit -> tag [Action = $use -> transaction page] ([LForm] ++ ctx) ([LForm] ++ ctx) use [] + + +(** Aborting *) + +val error : t ::: Type -> xml [Body] [] [] -> t
--- a/src/c/urweb.c Sun Sep 07 09:28:13 2008 -0400 +++ b/src/c/urweb.c Sun Sep 07 10:02:27 2008 -0400 @@ -96,7 +96,7 @@ 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 @@ 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; }
--- a/src/cjr.sml Sun Sep 07 09:28:13 2008 -0400 +++ b/src/cjr.sml Sun Sep 07 10:02:27 2008 -0400 @@ -66,6 +66,8 @@ | 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
--- a/src/cjr_print.sml Sun Sep 07 09:28:13 2008 -0400 +++ b/src/cjr_print.sml Sun Sep 07 10:02:27 2008 -0400 @@ -455,6 +455,20 @@ 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 "_",
--- a/src/cjrize.sml Sun Sep 07 09:28:13 2008 -0400 +++ b/src/cjrize.sml Sun Sep 07 10:02:27 2008 -0400 @@ -253,6 +253,14 @@ ((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)
--- a/src/mono.sml Sun Sep 07 09:28:13 2008 -0400 +++ b/src/mono.sml Sun Sep 07 10:02:27 2008 -0400 @@ -69,6 +69,8 @@ | EStrcat of exp * exp + | EError of exp * typ + | EWrite of exp | ESeq of exp * exp | ELet of string * typ * exp * exp
--- a/src/mono_print.sml Sun Sep 07 09:28:13 2008 -0400 +++ b/src/mono_print.sml Sun Sep 07 10:02:27 2008 -0400 @@ -173,6 +173,15 @@ 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 "^",
--- a/src/mono_reduce.sml Sun Sep 07 09:28:13 2008 -0400 +++ b/src/mono_reduce.sml Sun Sep 07 10:02:27 2008 -0400 @@ -55,6 +55,8 @@ | 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
--- a/src/mono_util.sml Sun Sep 07 09:28:13 2008 -0400 +++ b/src/mono_util.sml Sun Sep 07 10:02:27 2008 -0400 @@ -197,6 +197,13 @@ 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' =>
--- a/src/monoize.sml Sun Sep 07 09:28:13 2008 -0400 +++ b/src/monoize.sml Sun Sep 07 10:02:27 2008 -0400 @@ -1279,6 +1279,15 @@ _), _), 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
--- a/src/prepare.sml Sun Sep 07 09:28:13 2008 -0400 +++ b/src/prepare.sml Sun Sep 07 10:02:27 2008 -0400 @@ -106,6 +106,13 @@ ((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)