summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--include/lacweb.h3
-rw-r--r--src/cjr.sml2
-rw-r--r--src/cjr_env.sig4
-rw-r--r--src/cjr_env.sml36
-rw-r--r--src/cjr_print.sml68
-rw-r--r--src/cjrize.sml36
-rw-r--r--src/cloconv.sml11
-rw-r--r--src/flat.sml1
-rw-r--r--src/flat_env.sml1
-rw-r--r--src/flat_print.sml14
-rw-r--r--src/flat_util.sml17
11 files changed, 167 insertions, 26 deletions
diff --git a/include/lacweb.h b/include/lacweb.h
new file mode 100644
index 00000000..26f85402
--- /dev/null
+++ b/include/lacweb.h
@@ -0,0 +1,3 @@
+typedef int lw_Basis_int;
+typedef float lw_Basis_float;
+typedef char* lw_Basis_string;
diff --git a/src/cjr.sml b/src/cjr.sml
index 35dad087..03e286d0 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -62,6 +62,6 @@ datatype decl' =
withtype decl = decl' located
-type file = decl list
+type file = decl list * ((string * typ) list * exp) list
end
diff --git a/src/cjr_env.sig b/src/cjr_env.sig
index 6a9b0e71..2aa785d5 100644
--- a/src/cjr_env.sig
+++ b/src/cjr_env.sig
@@ -34,6 +34,7 @@ signature CJR_ENV = sig
exception UnboundRel of int
exception UnboundNamed of int
exception UnboundF of int
+ exception UnboundStruct of int
val pushTNamed : env -> string -> int -> Cjr.typ option -> env
val lookupTNamed : env -> int -> string * Cjr.typ option
@@ -49,6 +50,9 @@ signature CJR_ENV = sig
val pushF : env -> int -> string -> Cjr.typ -> Cjr.typ -> env
val lookupF : env -> int -> string * Cjr.typ * Cjr.typ
+ val pushStruct : env -> int -> (string * Cjr.typ) list -> env
+ val lookupStruct : env -> int -> (string * Cjr.typ) list
+
val declBinds : env -> Cjr.decl -> env
end
diff --git a/src/cjr_env.sml b/src/cjr_env.sml
index 9431b956..de1c31a1 100644
--- a/src/cjr_env.sml
+++ b/src/cjr_env.sml
@@ -35,6 +35,7 @@ structure IM = IntBinaryMap
exception UnboundRel of int
exception UnboundNamed of int
exception UnboundF of int
+exception UnboundStruct of int
type env = {
namedT : (string * typ option) IM.map,
@@ -43,7 +44,8 @@ type env = {
relE : (string * typ) list,
namedE : (string * typ) IM.map,
- F : (string * typ * typ) IM.map
+ F : (string * typ * typ) IM.map,
+ structs : (string * typ) list IM.map
}
val empty = {
@@ -53,7 +55,8 @@ val empty = {
relE = [],
namedE = IM.empty,
- F = IM.empty
+ F = IM.empty,
+ structs = IM.empty
}
fun pushTNamed (env : env) x n co =
@@ -63,7 +66,8 @@ fun pushTNamed (env : env) x n co =
relE = #relE env,
namedE = #namedE env,
- F = #F env}
+ F = #F env,
+ structs = #structs env}
fun lookupTNamed (env : env) n =
case IM.find (#namedT env, n) of
@@ -77,7 +81,8 @@ fun pushERel (env : env) x t =
relE = (x, t) :: #relE env,
namedE = #namedE env,
- F = #F env}
+ F = #F env,
+ structs = #structs env}
fun lookupERel (env : env) n =
(List.nth (#relE env, n))
@@ -94,7 +99,8 @@ fun pushENamed (env : env) x n t =
relE = #relE env,
namedE = IM.insert (#namedE env, n, (x, t)),
- F = #F env}
+ F = #F env,
+ structs = #structs env}
fun lookupENamed (env : env) n =
case IM.find (#namedE env, n) of
@@ -108,17 +114,33 @@ fun pushF (env : env) n x dom ran =
relE = #relE env,
namedE = #namedE env,
- F = IM.insert (#F env, n, (x, dom, ran))}
+ F = IM.insert (#F env, n, (x, dom, ran)),
+ structs = #structs env}
fun lookupF (env : env) n =
case IM.find (#F env, n) of
NONE => raise UnboundF n
| SOME x => x
+fun pushStruct (env : env) n xts =
+ {namedT = #namedT env,
+
+ numRelE = #numRelE env,
+ relE = #relE env,
+ namedE = #namedE env,
+
+ F = #F env,
+ structs = IM.insert (#structs env, n, xts)}
+
+fun lookupStruct (env : env) n =
+ case IM.find (#structs env, n) of
+ NONE => raise UnboundStruct n
+ | SOME x => x
+
fun declBinds env (d, _) =
case d of
DVal (x, n, t, _) => pushENamed env x n t
| DFun (n, x, dom, ran, _) => pushF env n x dom ran
- | DStruct _ => env
+ | DStruct (n, xts) => pushStruct env n xts
end
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 0f924a93..53cfee18 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -43,9 +43,7 @@ val dummyTyp = (TNamed 0, ErrorMsg.dummySpan)
fun p_typ' par env (t, loc) =
case t of
- TTop =>
- (EM.errorAt loc "Undetermined type";
- string "?")
+ TTop => string "void*"
| TFun =>
(EM.errorAt loc "Undetermined function type";
string "?->")
@@ -188,19 +186,73 @@ fun p_decl env ((d, _) : decl) =
newline,
box[string "return(",
p_exp env' e,
- string ")"],
+ string ");"],
newline,
string "}"]
end
-fun p_file env file =
+fun p_page env (xts, (e, loc)) =
+ case e of
+ ERecord (_, xes) =>
+ let
+ fun read x = ListUtil.search (fn (x', e) => if x' = x then SOME e else NONE) xes
+ in
+ case (read "code", read "env") of
+ (SOME code, SOME envx) =>
+ (case #1 code of
+ ECode i =>
+ let
+ val (_, (dom, _), _) = E.lookupF env i
+ in
+ case dom of
+ TRecord ri =>
+ let
+ val axts = E.lookupStruct env ri
+ fun read x = ListUtil.search (fn (x', t) => if x' = x then SOME t else NONE) axts
+ in
+ case read "arg" of
+ NONE => string "Page handler is too complicated! [5]"
+ | SOME (at, _) =>
+ case at of
+ TRecord ari =>
+ let
+ val r = (ERecord (ri, [("env", envx),
+ ("arg", (ERecord (ari, []), loc))]), loc)
+ in
+ box [string "return",
+ space,
+ p_exp env (EApp (code, r), loc),
+ string ";"]
+ end
+ | _ => string "Page handler is too complicated! [6]"
+ end
+ | _ => string "Page handler is too complicated! [4]"
+ end
+ | _ => string "Page handler is too complicated! [3]")
+
+ | _ => string "Page handler is too complicated! [1]"
+ end
+ | _ => string "Page handler is too complicated! [2]"
+
+fun p_file env (ds, ps) =
let
- val (pds, _) = ListUtil.foldlMap (fn (d, env) =>
+ val (pds, env) = ListUtil.foldlMap (fn (d, env) =>
(p_decl env d,
E.declBinds env d))
- env file
+ env ds
+ val pds' = map (p_page env) ps
in
- p_list_sep newline (fn x => x) pds
+ box [string "#include \"lacweb.h\"",
+ newline,
+ newline,
+ p_list_sep newline (fn x => x) pds,
+ newline,
+ string "char *lw_handle(void) {",
+ newline,
+ p_list_sep newline (fn x => x) pds',
+ newline,
+ string "}",
+ newline]
end
end
diff --git a/src/cjrize.sml b/src/cjrize.sml
index ef4abea2..546b11fc 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -165,7 +165,7 @@ fun cifyDecl ((d, loc), sm) =
val (t, sm) = cifyTyp (t, sm)
val (e, sm) = cifyExp (e, sm)
in
- ((L'.DVal (x, n, t, e), loc), sm)
+ (SOME (L'.DVal (x, n, t, e), loc), NONE, sm)
end
| L.DFun (n, x, dom, ran, e) =>
let
@@ -173,15 +173,41 @@ fun cifyDecl ((d, loc), sm) =
val (ran, sm) = cifyTyp (ran, sm)
val (e, sm) = cifyExp (e, sm)
in
- ((L'.DFun (n, x, dom, ran, e), loc), sm)
+ (SOME (L'.DFun (n, x, dom, ran, e), loc), NONE, sm)
+ end
+ | L.DPage (xts, e) =>
+ let
+ val (xts, sm) = ListUtil.foldlMap (fn ((x, t), sm) =>
+ let
+ val (t, sm) = cifyTyp (t, sm)
+ in
+ ((x, t), sm)
+ end)
+ sm xts
+ val (e, sm) = cifyExp (e, sm)
+ in
+ (NONE, SOME (xts, e), sm)
end
fun cjrize ds =
let
- val (ds, sm) = ListUtil.foldlMap cifyDecl Sm.empty ds
+ val (ds, ps, sm) = foldl (fn (d, (ds, ps, sm)) =>
+ let
+ val (dop, pop, sm) = cifyDecl (d, sm)
+ val ds = case dop of
+ NONE => ds
+ | SOME d => d :: ds
+ val ps = case pop of
+ NONE => ps
+ | SOME p => p :: ps
+ in
+ (ds, ps, sm)
+ end)
+ ([], [], Sm.empty) ds
in
- List.revAppend (map (fn v => (L'.DStruct v, ErrorMsg.dummySpan)) (Sm.declares sm),
- ds)
+ (List.revAppend (map (fn v => (L'.DStruct v, ErrorMsg.dummySpan)) (Sm.declares sm),
+ rev ds),
+ ps)
end
end
diff --git a/src/cloconv.sml b/src/cloconv.sml
index 9c1825cc..4421003b 100644
--- a/src/cloconv.sml
+++ b/src/cloconv.sml
@@ -78,6 +78,7 @@ structure Ds :> sig
val exp : t -> string * int * L'.typ * L'.exp -> t
val func : t -> string * L'.typ * L'.typ * L'.exp -> t * int
+ val page : t -> (string * L'.typ) list * L'.exp -> t
val decls : t -> L'.decl list
val enter : t -> t
@@ -95,6 +96,8 @@ fun exp (fc, ds, vm) (v as (_, _, _, (_, loc))) = (fc, (L'.DVal v, loc) :: ds, v
fun func (fc, ds, vm) (x, dom, ran, e as (_, loc)) =
((fc+1, (L'.DFun (fc, x, dom, ran, e), loc) :: ds, vm), fc)
+fun page (fc, ds, vm) (xts, e as (_, loc)) = (fc, (L'.DPage (xts, e), loc) :: ds, vm)
+
fun decls (_, ds, _) = rev ds
fun enter (fc, ds, vm) = (fc, ds, IS.map (fn n => n + 1) vm)
@@ -197,7 +200,13 @@ fun ccDecl ((d, loc), D) =
in
Ds.exp D (x, n, t, e)
end
- | L.DPage _ => raise Fail "Cloconv DPage"
+ | L.DPage (xts, e) =>
+ let
+ val xts = map (fn (x, t) => (x, ccTyp t)) xts
+ val (e, D) = ccExp E.empty (e, D)
+ in
+ Ds.page D (xts, e)
+ end
fun cloconv ds =
let
diff --git a/src/flat.sml b/src/flat.sml
index e635bd1c..40ef95f6 100644
--- a/src/flat.sml
+++ b/src/flat.sml
@@ -58,6 +58,7 @@ withtype exp = exp' located
datatype decl' =
DVal of string * int * typ * exp
| DFun of int * string * typ * typ * exp
+ | DPage of (string * typ) list * exp
withtype decl = decl' located
diff --git a/src/flat_env.sml b/src/flat_env.sml
index 9c88a233..d86b6c97 100644
--- a/src/flat_env.sml
+++ b/src/flat_env.sml
@@ -111,5 +111,6 @@ fun declBinds env (d, _) =
case d of
DVal (x, n, t, _) => pushENamed env x n t
| DFun (n, x, dom, ran, _) => pushF env n x dom ran
+ | DPage _ => env
end
diff --git a/src/flat_print.sml b/src/flat_print.sml
index ccfceb2f..e9697adf 100644
--- a/src/flat_print.sml
+++ b/src/flat_print.sml
@@ -194,6 +194,20 @@ fun p_decl env ((d, _) : decl) =
end
+ | DPage (xcs, e) => box [string "page",
+ string "[",
+ p_list (fn (x, t) =>
+ box [string x,
+ space,
+ string ":",
+ space,
+ p_typ env t]) xcs,
+ string "]",
+ space,
+ string "=",
+ space,
+ p_exp env e]
+
fun p_file env file =
let
val (pds, _) = ListUtil.foldlMap (fn (d, env) =>
diff --git a/src/flat_util.sml b/src/flat_util.sml
index c503cf18..f0a1e2e3 100644
--- a/src/flat_util.sml
+++ b/src/flat_util.sml
@@ -270,6 +270,15 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} =
S.map2 (mfe ctx e,
fn e' =>
(DFun (n, x, dom', ran', e'), loc))))
+ | DPage (xts, e) =>
+ S.bind2 (ListUtil.mapfold (fn (x, t) =>
+ S.map2 (mft t,
+ fn t' =>
+ (x, t'))) xts,
+ fn xts' =>
+ S.map2 (mfe ctx e,
+ fn e' =>
+ (DPage (xts', e'), loc)))
in
mfd
end
@@ -308,11 +317,11 @@ fun mapfoldB (all as {bind, ...}) =
S.bind2 (mfd ctx d,
fn d' =>
let
- val b =
+ val ctx' =
case #1 d' of
- DVal (x, n, t, e) => NamedE (x, n, t, SOME e)
- | DFun v => F v
- val ctx' = bind (ctx, b)
+ DVal (x, n, t, e) => bind (ctx, NamedE (x, n, t, SOME e))
+ | DFun v => bind (ctx, F v)
+ | DPage _ => ctx
in
S.map2 (mff ctx' ds',
fn ds' =>
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-02 17:44:32 +0000