From 425bb7f90ffc8a6f8a1590ed76f305f3029a0beb Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 10 Jul 2008 14:02:54 -0400 Subject: Writing HTML --- src/c/driver.c | 8 ++++++++ src/c/lacweb.c | 9 +++++++++ src/cjr.sml | 2 ++ src/cjr_print.sml | 10 ++++++---- src/cjrize.sml | 11 ++++++++++- src/cloconv.sml | 15 ++++++++++++++- src/compiler.sml | 18 ++++++++++++++++-- src/core.sml | 2 ++ src/core_print.sml | 4 ++++ src/core_util.sml | 5 +++++ src/corify.sml | 14 +++++++++++++- src/flat.sml | 4 ++++ src/flat_print.sml | 10 ++++++++++ src/flat_util.sml | 12 ++++++++++++ src/mono.sml | 2 ++ src/mono_print.sml | 6 +++++- src/mono_util.sml | 5 +++++ src/monoize.sml | 1 + 18 files changed, 128 insertions(+), 10 deletions(-) create mode 100644 src/c/driver.c create mode 100644 src/c/lacweb.c (limited to 'src') diff --git a/src/c/driver.c b/src/c/driver.c new file mode 100644 index 00000000..51d8bab7 --- /dev/null +++ b/src/c/driver.c @@ -0,0 +1,8 @@ +void lw_handle(void); + +int main() { + puts(""); + lw_handle(); + puts(""); + return 0; +} diff --git a/src/c/lacweb.c b/src/c/lacweb.c new file mode 100644 index 00000000..5054d8d5 --- /dev/null +++ b/src/c/lacweb.c @@ -0,0 +1,9 @@ +#include + +#include "types.h" + +lw_unit lw_unit_v = {}; + +void lw_write(const char* s) { + fputs(s, stdout); +} diff --git a/src/cjr.sml b/src/cjr.sml index 03e286d0..f357c351 100644 --- a/src/cjr.sml +++ b/src/cjr.sml @@ -53,6 +53,8 @@ datatype exp' = | ELet of (string * typ * exp) list * exp + | EWrite of exp + withtype exp = exp' located datatype decl' = diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 53cfee18..91e5060c 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -142,6 +142,10 @@ fun p_exp' par env (e, _) = 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 @@ fun p_page env (xts, (e, loc)) = 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 @@ fun p_file env (ds, ps) = 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 --git a/src/cjrize.sml b/src/cjrize.sml index 546b11fc..3ae68a0a 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -46,7 +46,7 @@ structure FM = BinaryMapFn(struct 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 @@ fun cifyExp ((e, loc), sm) = ((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 --git a/src/cloconv.sml b/src/cloconv.sml index 4421003b..89d64fdf 100644 --- a/src/cloconv.sml +++ b/src/cloconv.sml @@ -189,7 +189,20 @@ fun ccExp env ((e, loc), D) = ((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 --git a/src/compiler.sml b/src/compiler.sml index 592191c8..1e40cb11 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -345,11 +345,25 @@ fun compile job = 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 --git a/src/core.sml b/src/core.sml index 62a5b700..4572a8d9 100644 --- a/src/core.sml +++ b/src/core.sml @@ -74,6 +74,8 @@ datatype exp' = | EField of exp * con * { field : con, rest : con } | EFold of kind + | EWrite of exp + withtype exp = exp' located datatype decl' = diff --git a/src/core_print.sml b/src/core_print.sml index 18d9a7f5..be2f7387 100644 --- a/src/core_print.sml +++ b/src/core_print.sml @@ -226,6 +226,10 @@ fun p_exp' par env (e, _) = 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 --git a/src/core_util.sml b/src/core_util.sml index d65f0b87..df20ef9a 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -286,6 +286,11 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = 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 --git a/src/corify.sml b/src/corify.sml index 118255b7..43acedfc 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -427,7 +427,19 @@ fun corifyDecl ((d, loc : EM.span), st) = 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 --git a/src/flat.sml b/src/flat.sml index 40ef95f6..d31a2420 100644 --- a/src/flat.sml +++ b/src/flat.sml @@ -53,6 +53,10 @@ datatype exp' = | ELet of (string * typ * exp) list * exp + | EStrcat of exp * exp + + | EWrite of exp + withtype exp = exp' located datatype decl' = diff --git a/src/flat_print.sml b/src/flat_print.sml index e9697adf..b6c467e1 100644 --- a/src/flat_print.sml +++ b/src/flat_print.sml @@ -136,6 +136,16 @@ fun p_exp' par env (e, _) = 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 --git a/src/flat_util.sml b/src/flat_util.sml index f0a1e2e3..0ed2a33a 100644 --- a/src/flat_util.sml +++ b/src/flat_util.sml @@ -197,6 +197,18 @@ fun mapfoldB {typ = fc, exp = fe, bind} = 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 --git a/src/mono.sml b/src/mono.sml index 21d1cbe3..1099be72 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -51,6 +51,8 @@ datatype exp' = | EStrcat of exp * exp + | EWrite of exp + withtype exp = exp' located diff --git a/src/mono_print.sml b/src/mono_print.sml index b3c5f3a5..317744ed 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -114,10 +114,14 @@ fun p_exp' par env (e, _) = | 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 --git a/src/mono_util.sml b/src/mono_util.sml index cde2d57a..d095a69d 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -140,6 +140,11 @@ fun mapfoldB {typ = fc, exp = fe, bind} = 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 --git a/src/monoize.sml b/src/monoize.sml index 29e94b3f..51044783 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -151,6 +151,7 @@ fun monoExp env (all as (e, loc)) = | 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)) = -- cgit v1.2.3