# HG changeset patch # User Adam Chlipala # Date 1215712974 14400 # Node ID 5f04adf47f48733e7461bfca40e86fc0a52708ca # Parent 717b6f8d850569797a0c96ecd75004321e1eddc4 Writing HTML diff -r 717b6f8d8505 -r 5f04adf47f48 .hgignore --- 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 diff -r 717b6f8d8505 -r 5f04adf47f48 Makefile --- 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 diff -r 717b6f8d8505 -r 5f04adf47f48 include/lacweb.h --- 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*); diff -r 717b6f8d8505 -r 5f04adf47f48 include/types.h --- /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; diff -r 717b6f8d8505 -r 5f04adf47f48 src/c/driver.c --- /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(""); + lw_handle(); + puts(""); + return 0; +} diff -r 717b6f8d8505 -r 5f04adf47f48 src/c/lacweb.c --- /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 + +#include "types.h" + +lw_unit lw_unit_v = {}; + +void lw_write(const char* s) { + fputs(s, stdout); +} diff -r 717b6f8d8505 -r 5f04adf47f48 src/cjr.sml --- 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' = diff -r 717b6f8d8505 -r 5f04adf47f48 src/cjr_print.sml --- 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, diff -r 717b6f8d8505 -r 5f04adf47f48 src/cjrize.sml --- 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) => diff -r 717b6f8d8505 -r 5f04adf47f48 src/cloconv.sml --- 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 diff -r 717b6f8d8505 -r 5f04adf47f48 src/compiler.sml --- 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 diff -r 717b6f8d8505 -r 5f04adf47f48 src/core.sml --- 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' = diff -r 717b6f8d8505 -r 5f04adf47f48 src/core_print.sml --- 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) = diff -r 717b6f8d8505 -r 5f04adf47f48 src/core_util.sml --- 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 diff -r 717b6f8d8505 -r 5f04adf47f48 src/corify.sml --- 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 diff -r 717b6f8d8505 -r 5f04adf47f48 src/flat.sml --- 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' = diff -r 717b6f8d8505 -r 5f04adf47f48 src/flat_print.sml --- 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) = diff -r 717b6f8d8505 -r 5f04adf47f48 src/flat_util.sml --- 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 diff -r 717b6f8d8505 -r 5f04adf47f48 src/mono.sml --- 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 diff -r 717b6f8d8505 -r 5f04adf47f48 src/mono_print.sml --- 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) = diff -r 717b6f8d8505 -r 5f04adf47f48 src/mono_util.sml --- 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 diff -r 717b6f8d8505 -r 5f04adf47f48 src/monoize.sml --- 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)) =