From 0e95aa2c802d0a4fa54ebf985133eb2584a1d9ba Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 10 Jul 2008 15:49:14 -0400 Subject: More with attributes and efficient serialization --- include/lacweb.h | 4 ++++ lib/basis.lig | 4 ---- src/c/lacweb.c | 42 ++++++++++++++++++++++++++++++++++++++++++ src/cjr.sml | 1 + src/cjr_print.sml | 11 ++++++++++- src/cjrize.sml | 8 ++++++++ src/cloconv.sml | 8 ++++++++ src/flat.sml | 1 + src/flat_print.sml | 5 +++++ src/flat_util.sml | 7 +++++++ src/mono.sml | 1 + src/mono_opt.sml | 11 +++++++++++ src/mono_print.sml | 5 +++++ src/mono_util.sml | 7 +++++++ src/monoize.sml | 2 +- tests/attrs_escape.lac | 6 ++++++ 16 files changed, 117 insertions(+), 6 deletions(-) create mode 100644 tests/attrs_escape.lac diff --git a/include/lacweb.h b/include/lacweb.h index 14431df1..983f979a 100644 --- a/include/lacweb.h +++ b/include/lacweb.h @@ -3,3 +3,7 @@ extern lw_unit lw_unit_v; void lw_write(const char*); + +char *lw_Basis_attrifyInt(lw_Basis_int); +char *lw_Basis_attrifyFloat(lw_Basis_float); +char *lw_Basis_attrifyString(lw_Basis_string); diff --git a/lib/basis.lig b/lib/basis.lig index c0f39e65..cd106950 100644 --- a/lib/basis.lig +++ b/lib/basis.lig @@ -28,7 +28,3 @@ val p : tag [] [Body] [Body] val b : tag [] [Body] [Body] val i : tag [] [Body] [Body] val font : tag [Size = int, Face = string] [Body] [Body] - - -val attrifyInt : int -> string -val attrifyFloat : float -> string diff --git a/src/c/lacweb.c b/src/c/lacweb.c index 5054d8d5..10ccd6a0 100644 --- a/src/c/lacweb.c +++ b/src/c/lacweb.c @@ -1,9 +1,51 @@ #include +#include #include "types.h" lw_unit lw_unit_v = {}; +void lw_writec(char c) { + fputc(c, stdout); +} + void lw_write(const char* s) { fputs(s, stdout); } + +char *lw_Basis_attrifyInt(lw_Basis_int n) { + return "0"; +} + +char *lw_Basis_attrifyFloat(lw_Basis_float n) { + return "0.0"; +} + +char *lw_Basis_attrifyString(lw_Basis_string s) { + return ""; +} + +char *lw_Basis_attrifyInt_w(lw_Basis_int n) { + printf("%d", n); +} + +char *lw_Basis_attrifyFloat_w(lw_Basis_float n) { + printf("%g", n); +} + +char *lw_Basis_attrifyString_w(lw_Basis_string s) { + for (; *s; s++) { + char c = *s; + + if (c == '"') + lw_write("""); + else if (isprint(c)) + lw_writec(c); + else { + lw_write("&#"); + lw_Basis_attrifyInt_w(c); + lw_writec(';'); + } + } + lw_write(s); +} diff --git a/src/cjr.sml b/src/cjr.sml index f357c351..d22b38f4 100644 --- a/src/cjr.sml +++ b/src/cjr.sml @@ -54,6 +54,7 @@ datatype exp' = | ELet of (string * typ * exp) list * exp | EWrite of exp + | ESeq of exp * exp withtype exp = exp' located diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 91e5060c..44e9f847 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -146,6 +146,13 @@ fun p_exp' par env (e, _) = p_exp env e, string "), lw_unit_v)"] + | ESeq (e1, e2) => box [string "(", + p_exp env e1, + string ",", + space, + p_exp env e2, + string ")"] + and p_exp env = p_exp' false env fun p_decl env ((d, _) : decl) = @@ -177,7 +184,9 @@ fun p_decl env ((d, _) : decl) = let val env' = E.pushERel env x dom in - box [p_typ env ran, + box [string "static", + space, + p_typ env ran, space, string ("__lwc_" ^ Int.toString n), string "(", diff --git a/src/cjrize.sml b/src/cjrize.sml index 3ae68a0a..da436720 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -167,6 +167,14 @@ fun cifyExp ((e, loc), sm) = ((L'.EWrite e, loc), sm) end + | L.ESeq (e1, e2) => + let + val (e1, sm) = cifyExp (e1, sm) + val (e2, sm) = cifyExp (e2, sm) + in + ((L'.ESeq (e1, e2), loc), sm) + end + fun cifyDecl ((d, loc), sm) = case d of L.DVal (x, n, t, e) => diff --git a/src/cloconv.sml b/src/cloconv.sml index 89d64fdf..b5ea56ca 100644 --- a/src/cloconv.sml +++ b/src/cloconv.sml @@ -204,6 +204,14 @@ fun ccExp env ((e, loc), D) = ((L'.EWrite e, loc), D) end + | L.ESeq (e1, e2) => + let + val (e1, D) = ccExp env (e1, D) + val (e2, D) = ccExp env (e2, D) + in + ((L'.ESeq (e1, e2), loc), D) + end + fun ccDecl ((d, loc), D) = case d of L.DVal (x, n, t, e) => diff --git a/src/flat.sml b/src/flat.sml index d31a2420..2b63bc24 100644 --- a/src/flat.sml +++ b/src/flat.sml @@ -56,6 +56,7 @@ datatype exp' = | EStrcat of exp * exp | EWrite of exp + | ESeq of exp * exp withtype exp = exp' located diff --git a/src/flat_print.sml b/src/flat_print.sml index b6c467e1..f94614b4 100644 --- a/src/flat_print.sml +++ b/src/flat_print.sml @@ -146,6 +146,11 @@ fun p_exp' par env (e, _) = p_exp env e, string ")"] + | ESeq (e1, e2) => box [p_exp env e1, + string ";", + space, + p_exp env e2] + and p_exp env = p_exp' false env fun p_decl env ((d, _) : decl) = diff --git a/src/flat_util.sml b/src/flat_util.sml index 0ed2a33a..7e52381d 100644 --- a/src/flat_util.sml +++ b/src/flat_util.sml @@ -209,6 +209,13 @@ fun mapfoldB {typ = fc, exp = fe, bind} = S.map2 (mfe ctx e, fn e' => (EWrite e', loc)) + + | ESeq (e1, e2) => + S.bind2 (mfe ctx e1, + fn e1' => + S.map2 (mfe ctx e2, + fn e2' => + (ESeq (e1', e2'), loc))) in mfe end diff --git a/src/mono.sml b/src/mono.sml index 1099be72..3e9e2638 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -52,6 +52,7 @@ datatype exp' = | EStrcat of exp * exp | EWrite of exp + | ESeq of exp * exp withtype exp = exp' located diff --git a/src/mono_opt.sml b/src/mono_opt.sml index c9cd5f84..30b462bf 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -81,6 +81,17 @@ fun exp e = | EStrcat ((EStrcat (e1, e2), loc), e3) => optExp (EStrcat (e1, (EStrcat (e2, e3), loc)), loc) + | EWrite (EStrcat (e1, e2), loc) => + ESeq ((optExp (EWrite e1, loc), loc), + (optExp (EWrite e2, loc), loc)) + + | EWrite (EFfiApp ("Basis", "attrifyInt", [e]), _) => + EFfiApp ("Basis", "attrifyInt_w", [e]) + | EWrite (EFfiApp ("Basis", "attrifyFloat", [e]), _) => + EFfiApp ("Basis", "attrifyFloat_w", [e]) + | EWrite (EFfiApp ("Basis", "attrifyString", [e]), _) => + EFfiApp ("Basis", "attrifyString_w", [e]) + | _ => e and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e) diff --git a/src/mono_print.sml b/src/mono_print.sml index 317744ed..3797aefa 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -122,6 +122,11 @@ fun p_exp' par env (e, _) = p_exp env e, string ")"] + | ESeq (e1, e2) => box [p_exp env e1, + string ";", + space, + p_exp env e2] + and p_exp env = p_exp' false env fun p_decl env ((d, _) : decl) = diff --git a/src/mono_util.sml b/src/mono_util.sml index d095a69d..d5c047a7 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -145,6 +145,13 @@ fun mapfoldB {typ = fc, exp = fe, bind} = S.map2 (mfe ctx e, fn e' => (EWrite e', loc)) + + | ESeq (e1, e2) => + S.bind2 (mfe ctx e1, + fn e1' => + S.map2 (mfe ctx e2, + fn e2' => + (ESeq (e1', e2'), loc))) in mfe end diff --git a/src/monoize.sml b/src/monoize.sml index 0b868d59..1d95a303 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -81,7 +81,7 @@ val dummyExp = (L'.EPrim (Prim.Int 0), E.dummySpan) fun attrifyExp (e, tAll as (t, loc)) = case t of - L'.TFfi ("Basis", "string") => e + L'.TFfi ("Basis", "string") => (L'.EFfiApp ("Basis", "attrifyString", [e]), loc) | L'.TFfi ("Basis", "int") => (L'.EFfiApp ("Basis", "attrifyInt", [e]), loc) | L'.TFfi ("Basis", "float") => (L'.EFfiApp ("Basis", "attrifyFloat", [e]), loc) | _ => (E.errorAt loc "Don't know how to encode attribute type"; diff --git a/tests/attrs_escape.lac b/tests/attrs_escape.lac new file mode 100644 index 00000000..2194ce09 --- /dev/null +++ b/tests/attrs_escape.lac @@ -0,0 +1,6 @@ +val main = fn () => + Welcome + + +page main -- cgit v1.2.3