changeset 101:717b6f8d8505

First executable generated
author Adam Chlipala <adamc@hcoop.net>
date Thu, 10 Jul 2008 11:13:49 -0400
parents f0f59e918cac
children 5f04adf47f48
files include/lacweb.h src/cjr.sml src/cjr_env.sig src/cjr_env.sml src/cjr_print.sml src/cjrize.sml src/cloconv.sml src/flat.sml src/flat_env.sml src/flat_print.sml src/flat_util.sml
diffstat 11 files changed, 167 insertions(+), 26 deletions(-) [+]
line wrap: on
line diff
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/include/lacweb.h	Thu Jul 10 11:13:49 2008 -0400
@@ -0,0 +1,3 @@
+typedef int lw_Basis_int;
+typedef float lw_Basis_float;
+typedef char* lw_Basis_string;
--- a/src/cjr.sml	Thu Jul 10 10:11:35 2008 -0400
+++ b/src/cjr.sml	Thu Jul 10 11:13:49 2008 -0400
@@ -62,6 +62,6 @@
 
 withtype decl = decl' located
 
-type file = decl list
+type file = decl list * ((string * typ) list * exp) list
 
 end
--- a/src/cjr_env.sig	Thu Jul 10 10:11:35 2008 -0400
+++ b/src/cjr_env.sig	Thu Jul 10 11:13:49 2008 -0400
@@ -34,6 +34,7 @@
     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 @@
     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
--- a/src/cjr_env.sml	Thu Jul 10 10:11:35 2008 -0400
+++ b/src/cjr_env.sml	Thu Jul 10 11:13:49 2008 -0400
@@ -35,6 +35,7 @@
 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 @@
      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 @@
     relE = [],
     namedE = IM.empty,
 
-    F = IM.empty
+    F = IM.empty,
+    structs = IM.empty
 }
 
 fun pushTNamed (env : env) x n co =
@@ -63,7 +66,8 @@
      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 @@
      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 @@
      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 @@
      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
--- a/src/cjr_print.sml	Thu Jul 10 10:11:35 2008 -0400
+++ b/src/cjr_print.sml	Thu Jul 10 11:13:49 2008 -0400
@@ -43,9 +43,7 @@
 
 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 @@
                  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
--- a/src/cjrize.sml	Thu Jul 10 10:11:35 2008 -0400
+++ b/src/cjrize.sml	Thu Jul 10 11:13:49 2008 -0400
@@ -165,7 +165,7 @@
             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 @@
             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
--- a/src/cloconv.sml	Thu Jul 10 10:11:35 2008 -0400
+++ b/src/cloconv.sml	Thu Jul 10 11:13:49 2008 -0400
@@ -78,6 +78,7 @@
 
     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 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 @@
         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
--- a/src/flat.sml	Thu Jul 10 10:11:35 2008 -0400
+++ b/src/flat.sml	Thu Jul 10 11:13:49 2008 -0400
@@ -58,6 +58,7 @@
 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
 
--- a/src/flat_env.sml	Thu Jul 10 10:11:35 2008 -0400
+++ b/src/flat_env.sml	Thu Jul 10 11:13:49 2008 -0400
@@ -111,5 +111,6 @@
     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
--- a/src/flat_print.sml	Thu Jul 10 10:11:35 2008 -0400
+++ b/src/flat_print.sml	Thu Jul 10 11:13:49 2008 -0400
@@ -194,6 +194,20 @@
 
         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) =>
--- a/src/flat_util.sml	Thu Jul 10 10:11:35 2008 -0400
+++ b/src/flat_util.sml	Thu Jul 10 11:13:49 2008 -0400
@@ -270,6 +270,15 @@
                                   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 @@
                 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' =>