summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--.hgignore1
-rw-r--r--Makefile14
-rw-r--r--include/lacweb.h8
-rw-r--r--include/types.h8
-rw-r--r--src/c/driver.c8
-rw-r--r--src/c/lacweb.c9
-rw-r--r--src/cjr.sml2
-rw-r--r--src/cjr_print.sml10
-rw-r--r--src/cjrize.sml11
-rw-r--r--src/cloconv.sml15
-rw-r--r--src/compiler.sml18
-rw-r--r--src/core.sml2
-rw-r--r--src/core_print.sml4
-rw-r--r--src/core_util.sml5
-rw-r--r--src/corify.sml14
-rw-r--r--src/flat.sml4
-rw-r--r--src/flat_print.sml10
-rw-r--r--src/flat_util.sml12
-rw-r--r--src/mono.sml2
-rw-r--r--src/mono_print.sml6
-rw-r--r--src/mono_util.sml5
-rw-r--r--src/monoize.sml1
22 files changed, 153 insertions, 16 deletions
diff --git a/.hgignore b/.hgignore
index deca79d3..e4fdd97e 100644
--- a/.hgignore
+++ b/.hgignore
@@ -11,3 +11,4 @@ src/lacweb.mlb
*.lex.*
*.grm.*
+*.o
diff --git a/Makefile b/Makefile
index 9bfcd95c..ac64b3a4 100644
--- a/Makefile
+++ b/Makefile
@@ -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 --git a/include/lacweb.h b/include/lacweb.h
index 26f85402..14431df1 100644
--- a/include/lacweb.h
+++ b/include/lacweb.h
@@ -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 --git a/include/types.h b/include/types.h
new file mode 100644
index 00000000..28a8ea80
--- /dev/null
+++ b/include/types.h
@@ -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 --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("<html>");
+ lw_handle();
+ puts("</html>");
+ 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 <stdio.h>
+
+#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)) =
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-07 11:41:37 +0000