From 700a48cc6e78f75166b6e322207a29981782c4e3 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 7 Sep 2008 10:02:27 -0400 Subject: 'error' function --- include/urweb.h | 3 ++- lib/basis.urs | 10 ++++++++++ src/c/urweb.c | 6 +++++- src/cjr.sml | 2 ++ src/cjr_print.sml | 14 ++++++++++++++ src/cjrize.sml | 8 ++++++++ src/mono.sml | 2 ++ src/mono_print.sml | 9 +++++++++ src/mono_reduce.sml | 2 ++ src/mono_util.sml | 7 +++++++ src/monoize.sml | 9 +++++++++ src/prepare.sml | 7 +++++++ tests/error.ur | 3 +++ tests/error.urp | 5 +++++ 14 files changed, 85 insertions(+), 2 deletions(-) create mode 100644 tests/error.ur create mode 100644 tests/error.urp diff --git a/include/urweb.h b/include/urweb.h index 2c7576d9..8b74a21b 100644 --- a/include/urweb.h +++ b/include/urweb.h @@ -17,7 +17,8 @@ void lw_reset_keep_error_message(lw_context); 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); diff --git a/lib/basis.urs b/lib/basis.urs index 38049f13..b9f773c2 100644 --- a/lib/basis.urs +++ b/lib/basis.urs @@ -17,6 +17,11 @@ val eq_string : eq string val eq_bool : eq bool +(** String operations *) + +val strcat : string -> string -> string + + (** SQL *) con sql_table :: {Type} -> Type @@ -256,3 +261,8 @@ val loption : unit -> tag [Value = string] select [] [] [] 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 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) diff --git a/tests/error.ur b/tests/error.ur new file mode 100644 index 00000000..e5586d8d --- /dev/null +++ b/tests/error.ur @@ -0,0 +1,3 @@ +fun main () : transaction page = return + I couldn't make up my mind!}>Hello! + diff --git a/tests/error.urp b/tests/error.urp new file mode 100644 index 00000000..d6579653 --- /dev/null +++ b/tests/error.urp @@ -0,0 +1,5 @@ +debug +database dbname=test +exe /tmp/webapp + +error -- cgit v1.2.3