From 0168071775d98602c427b4b915fb6489cc2f10ff Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Sat, 28 Mar 2009 11:13:36 -0400
Subject: Marshalcheck

---
 src/marshalcheck.sml | 136 +++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 136 insertions(+)
 create mode 100644 src/marshalcheck.sml

(limited to 'src/marshalcheck.sml')

diff --git a/src/marshalcheck.sml b/src/marshalcheck.sml
new file mode 100644
index 00000000..2cce607b
--- /dev/null
+++ b/src/marshalcheck.sml
@@ -0,0 +1,136 @@
+(* Copyright (c) 2009, Adam Chlipala
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * - Redistributions of source code must retain the above copyright notice,
+ *   this list of conditions and the following disclaimer.
+ * - Redistributions in binary form must reproduce the above copyright notice,
+ *   this list of conditions and the following disclaimer in the documentation
+ *   and/or other materials provided with the distribution.
+ * - The names of contributors may not be used to endorse or promote products
+ *   derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ *)
+
+structure MarshalCheck :> MARSHAL_CHECK = struct
+
+open Core
+
+structure U = CoreUtil
+structure E = ErrorMsg
+
+structure PK = struct
+open Order
+type ord_key = string * string
+fun compare ((m1, x1), (m2, x2)) =
+    join (String.compare (m1, m2),
+          fn () => String.compare (x1, x2))
+end
+
+structure PS = BinarySetFn(PK)
+structure PS = struct
+open PS
+fun toString' (m, x) = m ^ "." ^ x
+fun toString set =
+    case PS.listItems set of
+        [] => "{}"
+      | [x] => toString' x
+      | x :: xs => List.foldl (fn (x, s) => s ^ ", " ^ toString' x) (toString' x) xs
+end
+
+structure IM = IntBinaryMap
+
+val clientToServer = [("Basis", "int"),
+                      ("Basis", "float"),
+                      ("Basis", "string"),
+                      ("Basis", "time"),
+                      ("Basis", "unit"),
+                      ("Basis", "option")]
+
+val clientToServer = PS.addList (PS.empty, clientToServer)
+
+fun check file =
+    let
+        fun kind (_, st) = st
+
+        fun con cmap (c, st) =
+            case c of
+                CFfi mx =>
+                if PS.member (clientToServer, mx) then
+                    st
+                else
+                    PS.add (st, mx)
+              | CNamed n =>
+                (case IM.find (cmap, n) of
+                     NONE => st
+                   | SOME st' => PS.union (st, st'))
+              | _ => st
+
+        fun sins cmap = U.Con.fold {kind = kind, con = con cmap} PS.empty
+    in
+        ignore (foldl (fn ((d, _), (cmap, emap)) =>
+                          case d of
+                              DCon (_, n, _, c) => (IM.insert (cmap, n, sins cmap c), emap)
+                            | DDatatype (_, n, _, xncs) =>
+                              (IM.insert (cmap, n, foldl (fn ((_, _, co), s) =>
+                                                             case co of
+                                                                 NONE => s
+                                                               | SOME c => PS.union (s, sins cmap c))
+                                                         PS.empty xncs),
+                               emap)
+
+                            | DVal (_, n, t, _, tag) => (cmap, IM.insert (emap, n, (t, tag)))
+                            | DValRec vis => (cmap,
+                                              foldl (fn ((_, n, t, _, tag), emap) => IM.insert (emap, n, (t, tag)))
+                                                    emap vis)
+
+                            | DExport (_, n) =>
+                              (case IM.find (emap, n) of
+                                   NONE => raise Fail "MarshalCheck: Unknown export"
+                                 | SOME (t, tag) =>
+                                   let
+                                       fun makeS (t, _) =
+                                           case t of
+                                               TFun (dom, ran) => PS.union (sins cmap dom, makeS ran)
+                                             | _ => PS.empty
+                                       val s = makeS t
+                                   in
+                                       if PS.isEmpty s then
+                                           ()
+                                       else
+                                           E.error ("Input to exported function '"
+                                                    ^ tag ^ "' involves one or more disallowed types: "
+                                                    ^ PS.toString s);
+                                       (cmap, emap)
+                                   end)
+
+                            | DCookie (_, _, t, tag) =>
+                              let
+                                  val s = sins cmap t
+                              in
+                                  if PS.isEmpty s then
+                                      ()
+                                  else
+                                      E.error ("Cookie '" ^ tag ^ "' includes one or more disallowed types: "
+                                               ^ PS.toString s);
+                                  (cmap, emap)
+                              end
+
+                            | _ => (cmap, emap))
+                      (IM.empty, IM.empty) file)
+    end
+
+end
-- 
cgit v1.2.3