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