Mercurial > urweb

annotate src/scriptcheck.sml @ 2040:8ea382a57ce2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Fix index-matching bug in MonoReduce effect calculation
author Adam Chlipala <adam@chlipala.net>
date Mon, 21 Jul 2014 08:11:03 -0400
parents c1e3805e604e
children a9159911c3ba
rev   line source
adamc@643 1 (* Copyright (c) 2009, Adam Chlipala
adamc@643 2 * All rights reserved.
adamc@643 3 *
adamc@643 4 * Redistribution and use in source and binary forms, with or without
adamc@643 5 * modification, are permitted provided that the following conditions are met:
adamc@643 6 *
adamc@643 7 * - Redistributions of source code must retain the above copyright notice,
adamc@643 8 * this list of conditions and the following disclaimer.
adamc@643 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@643 10 * this list of conditions and the following disclaimer in the documentation
adamc@643 11 * and/or other materials provided with the distribution.
adamc@643 12 * - The names of contributors may not be used to endorse or promote products
adamc@643 13 * derived from this software without specific prior written permission.
adamc@643 14 *
adamc@643 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@643 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@643 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@643 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@643 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@643 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@643 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@643 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@643 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@643 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@643 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@643 26 *)
adamc@643 27
adamc@643 28 structure ScriptCheck :> SCRIPT_CHECK = struct
adamc@643 29
adam@1845 30 open Mono
adamc@643 31
adamc@643 32 structure SS = BinarySetFn(struct
adamc@643 33 type ord_key = string
adamc@643 34 val compare = String.compare
adamc@643 35 end)
adamc@643 36 structure IS = IntBinarySet
adamc@643 37
adamc@693 38 val pushBasis = SS.addList (SS.empty,
adamc@693 39 ["new_channel",
adamc@693 40 "self"])
adamc@799 41
adamc@643 42 fun classify (ds, ps) =
adamc@643 43 let
adamc@855 44 val proto = Settings.currentProtocol ()
adamc@855 45
adamc@970 46 fun inString {needle, haystack} = String.isSubstring needle haystack
adamc@643 47
adam@1845 48 fun hasClient {basis, funcs, push} =
adam@1845 49 MonoUtil.Exp.exists {typ = fn _ => false,
adam@1845 50 exp = fn ERecv _ => push
adam@1845 51 | EFfiApp ("Basis", x, _) => SS.member (basis, x)
adam@1845 52 | EJavaScript _ => not push
adam@1845 53 | ENamed n => IS.member (funcs, n)
adam@1845 54 | _ => false}
adamc@643 55
adamc@693 56 fun decl ((d, _), (pull_ids, push_ids)) =
adamc@643 57 let
adam@1845 58 val hasClientPull = hasClient {basis = SS.empty, funcs = pull_ids, push = false}
adam@1845 59 val hasClientPush = hasClient {basis = pushBasis, funcs = push_ids, push = true}
adamc@643 60 in
adamc@643 61 case d of
adam@1845 62 DVal (_, n, _, e, _) => (if hasClientPull e then
adamc@693 63 IS.add (pull_ids, n)
adamc@693 64 else
adamc@693 65 pull_ids,
adamc@693 66 if hasClientPush e then
adamc@693 67 IS.add (push_ids, n)
adamc@693 68 else
adamc@693 69 push_ids)
adam@1845 70 | DValRec xes => (if List.exists (fn (_, _, _, e, _) => hasClientPull e) xes then
adamc@693 71 foldl (fn ((_, n, _, _, _), pull_ids) => IS.add (pull_ids, n))
adamc@693 72 pull_ids xes
adamc@693 73 else
adamc@693 74 pull_ids,
adam@1845 75 if List.exists (fn (_, _, _, e, _) => hasClientPush e) xes then
adamc@693 76 foldl (fn ((_, n, _, _, _), push_ids) => IS.add (push_ids, n))
adamc@693 77 push_ids xes
adamc@693 78 else
adamc@693 79 push_ids)
adamc@693 80 | _ => (pull_ids, push_ids)
adamc@643 81 end
adamc@643 82
adamc@693 83 val (pull_ids, push_ids) = foldl decl (IS.empty, IS.empty) ds
adamc@643 84
adamc@855 85 val foundBad = ref false
adamc@855 86
adam@1845 87 val all_ids = IS.union (pull_ids, push_ids)
adam@1845 88
adam@1845 89 val ps = map (fn n =>
adam@1845 90 (n, if IS.member (push_ids, n) then
adam@1845 91 (if not (#persistent proto) andalso not (!foundBad) then
adam@1845 92 (foundBad := true;
adam@1845 93 ErrorMsg.error ("This program needs server push, but the current protocol ("
adam@1845 94 ^ #name proto ^ ") doesn't support that."))
adam@1845 95 else
adam@1845 96 ();
adam@1845 97 ServerAndPullAndPush)
adam@1845 98 else if IS.member (pull_ids, n) then
adam@1845 99 ServerAndPull
adam@1845 100 else
adam@1845 101 ServerOnly)) (IS.listItems all_ids)
adamc@643 102 in
adamc@643 103 (ds, ps)
adamc@643 104 end
adamc@643 105
adamc@643 106 end
adamc@643 107