Mercurial > urweb

changeset 106:d101cb1efe55

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
More with attributes and efficient serialization
author Adam Chlipala <adamc@hcoop.net>
date Thu, 10 Jul 2008 15:49:14 -0400
parents da760c34f5ed
children bed5cf0b6b75
files include/lacweb.h lib/basis.lig src/c/lacweb.c src/cjr.sml src/cjr_print.sml src/cjrize.sml src/cloconv.sml src/flat.sml src/flat_print.sml src/flat_util.sml src/mono.sml src/mono_opt.sml src/mono_print.sml src/mono_util.sml src/monoize.sml tests/attrs_escape.lac
diffstat 16 files changed, 117 insertions(+), 6 deletions(-) [+]
line wrap: on
line diff
--- a/include/lacweb.h	Thu Jul 10 15:19:06 2008 -0400
+++ b/include/lacweb.h	Thu Jul 10 15:49:14 2008 -0400
@@ -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);
--- a/lib/basis.lig	Thu Jul 10 15:19:06 2008 -0400
+++ b/lib/basis.lig	Thu Jul 10 15:49:14 2008 -0400
@@ -28,7 +28,3 @@
 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
--- a/src/c/lacweb.c	Thu Jul 10 15:19:06 2008 -0400
+++ b/src/c/lacweb.c	Thu Jul 10 15:49:14 2008 -0400
@@ -1,9 +1,51 @@
 #include <stdio.h>
+#include <ctype.h>
 
 #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("&quot;");
+    else if (isprint(c))
+      lw_writec(c);
+    else {
+      lw_write("&#");
+      lw_Basis_attrifyInt_w(c);
+      lw_writec(';');
+    }
+  }
+  lw_write(s);
+}
--- a/src/cjr.sml	Thu Jul 10 15:19:06 2008 -0400
+++ b/src/cjr.sml	Thu Jul 10 15:49:14 2008 -0400
@@ -54,6 +54,7 @@
        | ELet of (string * typ * exp) list * exp
 
        | EWrite of exp
+       | ESeq of exp * exp
 
 withtype exp = exp' located
 
--- a/src/cjr_print.sml	Thu Jul 10 15:19:06 2008 -0400
+++ b/src/cjr_print.sml	Thu Jul 10 15:49:14 2008 -0400
@@ -146,6 +146,13 @@
                          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 @@
         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 "(",
--- a/src/cjrize.sml	Thu Jul 10 15:19:06 2008 -0400
+++ b/src/cjrize.sml	Thu Jul 10 15:49:14 2008 -0400
@@ -167,6 +167,14 @@
             ((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) =>
--- a/src/cloconv.sml	Thu Jul 10 15:19:06 2008 -0400
+++ b/src/cloconv.sml	Thu Jul 10 15:49:14 2008 -0400
@@ -204,6 +204,14 @@
             ((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) =>
--- a/src/flat.sml	Thu Jul 10 15:19:06 2008 -0400
+++ b/src/flat.sml	Thu Jul 10 15:49:14 2008 -0400
@@ -56,6 +56,7 @@
        | EStrcat of exp * exp
 
        | EWrite of exp
+       | ESeq of exp * exp
 
 withtype exp = exp' located
 
--- a/src/flat_print.sml	Thu Jul 10 15:19:06 2008 -0400
+++ b/src/flat_print.sml	Thu Jul 10 15:49:14 2008 -0400
@@ -146,6 +146,11 @@
                          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) =
--- a/src/flat_util.sml	Thu Jul 10 15:19:06 2008 -0400
+++ b/src/flat_util.sml	Thu Jul 10 15:49:14 2008 -0400
@@ -209,6 +209,13 @@
                 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
--- a/src/mono.sml	Thu Jul 10 15:19:06 2008 -0400
+++ b/src/mono.sml	Thu Jul 10 15:49:14 2008 -0400
@@ -52,6 +52,7 @@
        | EStrcat of exp * exp
 
        | EWrite of exp
+       | ESeq of exp * exp
 
 
 withtype exp = exp' located
--- a/src/mono_opt.sml	Thu Jul 10 15:19:06 2008 -0400
+++ b/src/mono_opt.sml	Thu Jul 10 15:49:14 2008 -0400
@@ -81,6 +81,17 @@
       | 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)
--- a/src/mono_print.sml	Thu Jul 10 15:19:06 2008 -0400
+++ b/src/mono_print.sml	Thu Jul 10 15:49:14 2008 -0400
@@ -122,6 +122,11 @@
                          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) =
--- a/src/mono_util.sml	Thu Jul 10 15:19:06 2008 -0400
+++ b/src/mono_util.sml	Thu Jul 10 15:49:14 2008 -0400
@@ -145,6 +145,13 @@
                 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
--- a/src/monoize.sml	Thu Jul 10 15:19:06 2008 -0400
+++ b/src/monoize.sml	Thu Jul 10 15:49:14 2008 -0400
@@ -81,7 +81,7 @@
 
 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";
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/attrs_escape.lac	Thu Jul 10 15:49:14 2008 -0400
@@ -0,0 +1,6 @@
+val main = fn () => <html><body>
+        <font face="\"Well hey\"
+Wow">Welcome</font>
+</body></html>
+
+page main