Mercurial > urweb

changeset 102:5f04adf47f48

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Writing HTML
author Adam Chlipala <adamc@hcoop.net>
date Thu, 10 Jul 2008 14:02:54 -0400
parents 717b6f8d8505
children 8921f0344193
files .hgignore Makefile include/lacweb.h include/types.h src/c/driver.c src/c/lacweb.c src/cjr.sml src/cjr_print.sml src/cjrize.sml src/cloconv.sml src/compiler.sml src/core.sml src/core_print.sml src/core_util.sml src/corify.sml src/flat.sml src/flat_print.sml src/flat_util.sml src/mono.sml src/mono_print.sml src/mono_util.sml src/monoize.sml
diffstat 22 files changed, 153 insertions(+), 16 deletions(-) [+]
line wrap: on
line diff
--- a/.hgignore	Thu Jul 10 11:13:49 2008 -0400
+++ b/.hgignore	Thu Jul 10 14:02:54 2008 -0400
@@ -11,3 +11,4 @@
 
 *.lex.*
 *.grm.*
+*.o
--- a/Makefile	Thu Jul 10 11:13:49 2008 -0400
+++ b/Makefile	Thu Jul 10 14:02:54 2008 -0400
@@ -1,15 +1,23 @@
-all: smlnj mlton
+all: smlnj mlton c
 
-.PHONY: all smlnj mlton clean
+.PHONY: all smlnj mlton c clean
 
 smlnj: src/lacweb.cm
 mlton: bin/lacweb
+c: clib/lacweb.o clib/driver.o
 
 clean:
 	rm -f src/*.mlton.grm.* src/*.mlton.lex.* \
-		src/lacweb.cm src/lacweb.mlb
+		src/lacweb.cm src/lacweb.mlb \
+		clib/*.o
 	rm -rf .cm src/.cm
 
+clib/lacweb.o: src/c/lacweb.c
+	gcc -I include -c src/c/lacweb.c -o clib/lacweb.o
+
+clib/driver.o: src/c/driver.c
+	gcc -c src/c/driver.c -o clib/driver.o
+
 src/lacweb.cm: src/prefix.cm src/sources
 	cat src/prefix.cm src/sources \
 	>src/lacweb.cm
--- a/include/lacweb.h	Thu Jul 10 11:13:49 2008 -0400
+++ b/include/lacweb.h	Thu Jul 10 14:02:54 2008 -0400
@@ -1,3 +1,5 @@
-typedef int lw_Basis_int;
-typedef float lw_Basis_float;
-typedef char* lw_Basis_string;
+#include "types.h"
+
+extern lw_unit lw_unit_v;
+
+void lw_write(const char*);
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/include/types.h	Thu Jul 10 14:02:54 2008 -0400
@@ -0,0 +1,8 @@
+typedef int lw_Basis_int;
+typedef float lw_Basis_float;
+typedef char* lw_Basis_string;
+
+struct __lws_0 {
+};
+
+typedef struct __lws_0 lw_unit;
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/c/driver.c	Thu Jul 10 14:02:54 2008 -0400
@@ -0,0 +1,8 @@
+void lw_handle(void);
+
+int main() {
+  puts("<html>");
+  lw_handle();
+  puts("</html>");
+  return 0;
+}
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/c/lacweb.c	Thu Jul 10 14:02:54 2008 -0400
@@ -0,0 +1,9 @@
+#include <stdio.h>
+
+#include "types.h"
+
+lw_unit lw_unit_v = {};
+
+void lw_write(const char* s) {
+  fputs(s, stdout);
+}
--- a/src/cjr.sml	Thu Jul 10 11:13:49 2008 -0400
+++ b/src/cjr.sml	Thu Jul 10 14:02:54 2008 -0400
@@ -53,6 +53,8 @@
 
        | ELet of (string * typ * exp) list * exp
 
+       | EWrite of exp
+
 withtype exp = exp' located
 
 datatype decl' =
--- a/src/cjr_print.sml	Thu Jul 10 11:13:49 2008 -0400
+++ b/src/cjr_print.sml	Thu Jul 10 14:02:54 2008 -0400
@@ -142,6 +142,10 @@
                  string "})"]
         end
 
+      | EWrite e => box [string "(lw_write(",
+                         p_exp env e,
+                         string "), lw_unit_v)"]
+
 and p_exp env = p_exp' false env
 
 fun p_decl env ((d, _) : decl) =
@@ -219,9 +223,7 @@
                                              val r = (ERecord (ri, [("env", envx),
                                                                     ("arg", (ERecord (ari, []), loc))]), loc)
                                          in
-                                             box [string "return",
-                                                  space,
-                                                  p_exp env (EApp (code, r), loc),
+                                             box [p_exp env (EApp (code, r), loc),
                                                   string ";"]
                                          end
                                        | _ => string "Page handler is too complicated! [6]"
@@ -247,7 +249,7 @@
              newline,
              p_list_sep newline (fn x => x) pds,
              newline,
-             string "char *lw_handle(void) {",
+             string "void lw_handle(void) {",
              newline,
              p_list_sep newline (fn x => x) pds',
              newline,
--- a/src/cjrize.sml	Thu Jul 10 11:13:49 2008 -0400
+++ b/src/cjrize.sml	Thu Jul 10 14:02:54 2008 -0400
@@ -46,7 +46,7 @@
 
 type t = int * int FM.map * (int * (string * L'.typ) list) list
 
-val empty = (0, FM.empty, [])
+val empty : t = (1, FM.insert (FM.empty, (L.TRecord [], ErrorMsg.dummySpan), 0), [])
 
 fun find ((n, m, ds), xts, xts') =
     let
@@ -158,6 +158,15 @@
             ((L'.ELet (xes, e), loc), sm)
         end
 
+      | L.EStrcat _ => raise Fail "Cjrize EStrcat"
+
+      | L.EWrite e =>
+        let
+            val (e, sm) = cifyExp (e, sm)
+        in
+            ((L'.EWrite e, loc), sm)
+        end
+
 fun cifyDecl ((d, loc), sm) =
     case d of
         L.DVal (x, n, t, e) =>
--- a/src/cloconv.sml	Thu Jul 10 11:13:49 2008 -0400
+++ b/src/cloconv.sml	Thu Jul 10 14:02:54 2008 -0400
@@ -189,7 +189,20 @@
             ((L'.EField (e1, x), loc), D)
         end
 
-      | L.EStrcat _ => raise Fail "Cloconv EStrcat"
+      | L.EStrcat (e1, e2) =>
+        let
+            val (e1, D) = ccExp env (e1, D)
+            val (e2, D) = ccExp env (e2, D)
+        in
+            ((L'.EStrcat (e1, e2), loc), D)
+        end
+
+      | L.EWrite e =>
+        let
+            val (e, D) = ccExp env (e, D)
+        in
+            ((L'.EWrite e, loc), D)
+        end
 
 fun ccDecl ((d, loc), D) =
     case d of
--- a/src/compiler.sml	Thu Jul 10 11:13:49 2008 -0400
+++ b/src/compiler.sml	Thu Jul 10 14:02:54 2008 -0400
@@ -345,11 +345,25 @@
         NONE => ()
       | SOME file =>
         let
-            val outf = TextIO.openOut "/tmp/lacweb.c"
+            val cname = "/tmp/lacweb.c"
+            val oname = "/tmp/lacweb.o"
+            val ename = "/tmp/webapp"
+
+            val compile = "gcc -I include -c " ^ cname ^ " -o " ^ oname
+            val link = "gcc clib/lacweb.o " ^ oname ^ " clib/driver.o -o " ^ ename
+
+            val outf = TextIO.openOut cname
             val s = TextIOPP.openOut {dst = outf, wid = 80}
         in
             Print.fprint s (CjrPrint.p_file CjrEnv.empty file);
-            TextIO.closeOut outf
+            TextIO.closeOut outf;
+
+            if not (OS.Process.isSuccess (OS.Process.system compile)) then
+                print "C compilation failed\n"
+            else if not (OS.Process.isSuccess (OS.Process.system link)) then
+                print "C linking failed\n"
+            else
+                print "Success\n"
         end
 
 end
--- a/src/core.sml	Thu Jul 10 11:13:49 2008 -0400
+++ b/src/core.sml	Thu Jul 10 14:02:54 2008 -0400
@@ -74,6 +74,8 @@
        | EField of exp * con * { field : con, rest : con }
        | EFold of kind
 
+       | EWrite of exp
+
 withtype exp = exp' located
 
 datatype decl' =
--- a/src/core_print.sml	Thu Jul 10 11:13:49 2008 -0400
+++ b/src/core_print.sml	Thu Jul 10 14:02:54 2008 -0400
@@ -226,6 +226,10 @@
                  p_con' true env c]
       | EFold _ => string "fold"
 
+      | EWrite e => box [string "write(",
+                         p_exp env e,
+                         string ")"]
+
 and p_exp env = p_exp' false env
 
 fun p_decl env ((d, _) : decl) =
--- a/src/core_util.sml	Thu Jul 10 11:13:49 2008 -0400
+++ b/src/core_util.sml	Thu Jul 10 14:02:54 2008 -0400
@@ -286,6 +286,11 @@
                 S.map2 (mfk k,
                          fn k' =>
                             (EFold k', loc))
+
+              | EWrite e =>
+                S.map2 (mfe ctx e,
+                     fn e' =>
+                        (EWrite e', loc))
     in
         mfe
     end
--- a/src/corify.sml	Thu Jul 10 11:13:49 2008 -0400
+++ b/src/corify.sml	Thu Jul 10 14:02:54 2008 -0400
@@ -427,7 +427,19 @@
              end
            | _ => raise Fail "Non-const signature for FFI structure")
 
-      | L.DPage (c, e) => ([(L'.DPage (corifyCon st c, corifyExp st e), loc)], st)
+      | L.DPage (c, e) =>
+        let
+            val c = corifyCon st c
+            val e = corifyExp st e
+
+            val dom = (L'.TRecord c, loc)
+            val ran = (L'.TRecord (L'.CRecord ((L'.KType, loc), []), loc), loc)
+            val e = (L'.EAbs ("vs", dom, ran,
+                              (L'.EWrite (L'.EApp (e, (L'.ERel 0, loc)), loc), loc)), loc)
+                                                                
+        in
+            ([(L'.DPage (c, e), loc)], st)
+        end
 
 and corifyStr ((str, _), st) =
     case str of
--- a/src/flat.sml	Thu Jul 10 11:13:49 2008 -0400
+++ b/src/flat.sml	Thu Jul 10 14:02:54 2008 -0400
@@ -53,6 +53,10 @@
 
        | ELet of (string * typ * exp) list * exp
 
+       | EStrcat of exp * exp
+
+       | EWrite of exp
+
 withtype exp = exp' located
 
 datatype decl' =
--- a/src/flat_print.sml	Thu Jul 10 11:13:49 2008 -0400
+++ b/src/flat_print.sml	Thu Jul 10 14:02:54 2008 -0400
@@ -136,6 +136,16 @@
                  string "end"]
         end
 
+      | EStrcat (e1, e2) => box [p_exp' true env e1,
+                                 space,
+                                 string "^",
+                                 space,
+                                 p_exp' true env e2]
+
+      | EWrite e => box [string "write(",
+                         p_exp env e,
+                         string ")"]
+
 and p_exp env = p_exp' false env
 
 fun p_decl env ((d, _) : decl) =
--- a/src/flat_util.sml	Thu Jul 10 11:13:49 2008 -0400
+++ b/src/flat_util.sml	Thu Jul 10 14:02:54 2008 -0400
@@ -197,6 +197,18 @@
                          S.map2 (mfe ctx e,
                                  fn e' =>
                                     (ELet (xes', e'), loc)))
+
+              | EStrcat (e1, e2) =>
+                S.bind2 (mfe ctx e1,
+                      fn e1' =>
+                         S.map2 (mfe ctx e2,
+                              fn e2' =>
+                                 (EStrcat (e1', e2'), loc)))
+
+              | EWrite e =>
+                S.map2 (mfe ctx e,
+                     fn e' =>
+                        (EWrite e', loc))
     in
         mfe
     end
--- a/src/mono.sml	Thu Jul 10 11:13:49 2008 -0400
+++ b/src/mono.sml	Thu Jul 10 14:02:54 2008 -0400
@@ -51,6 +51,8 @@
 
        | EStrcat of exp * exp
 
+       | EWrite of exp
+
 
 withtype exp = exp' located
 
--- a/src/mono_print.sml	Thu Jul 10 11:13:49 2008 -0400
+++ b/src/mono_print.sml	Thu Jul 10 14:02:54 2008 -0400
@@ -114,10 +114,14 @@
 
       | EStrcat (e1, e2) => box [p_exp' true env e1,
                                  space,
-                                 string ".",
+                                 string "^",
                                  space,
                                  p_exp' true env e2]
 
+      | EWrite e => box [string "write(",
+                         p_exp env e,
+                         string ")"]
+
 and p_exp env = p_exp' false env
 
 fun p_decl env ((d, _) : decl) =
--- a/src/mono_util.sml	Thu Jul 10 11:13:49 2008 -0400
+++ b/src/mono_util.sml	Thu Jul 10 14:02:54 2008 -0400
@@ -140,6 +140,11 @@
                          S.map2 (mfe ctx e2,
                               fn e2' =>
                                  (EStrcat (e1', e2'), loc)))
+
+              | EWrite e =>
+                S.map2 (mfe ctx e,
+                     fn e' =>
+                        (EWrite e', loc))
     in
         mfe
     end
--- a/src/monoize.sml	Thu Jul 10 11:13:49 2008 -0400
+++ b/src/monoize.sml	Thu Jul 10 14:02:54 2008 -0400
@@ -151,6 +151,7 @@
           | L.ERecord xes => (L'.ERecord (map (fn (x, e, t) => (monoName env x, monoExp env e, monoType env t)) xes), loc)
           | L.EField (e, x, _) => (L'.EField (monoExp env e, monoName env x), loc)
           | L.EFold _ => poly ()
+          | L.EWrite e => (L'.EWrite (monoExp env e), loc)
     end
 
 fun monoDecl env (all as (d, loc)) =