First executable generated

10 files changed, 164 insertions, 26 deletions

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' =>