Mercurial > urweb

annotate src/mono_shake.sml @ 709:0406e9cccb72

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
FOREIGN KEY, without ability to link NULL to NOT NULL (and with some lingering problems in row inference)
author Adam Chlipala <adamc@hcoop.net>
date Tue, 07 Apr 2009 18:47:47 -0400
parents a3ddf05fb3e3
children f152f215a02c
rev   line source
adamc@134 1 (* Copyright (c) 2008, Adam Chlipala
adamc@134 2 * All rights reserved.
adamc@134 3 *
adamc@134 4 * Redistribution and use in source and binary forms, with or without
adamc@134 5 * modification, are permitted provided that the following conditions are met:
adamc@134 6 *
adamc@134 7 * - Redistributions of source code must retain the above copyright notice,
adamc@134 8 * this list of conditions and the following disclaimer.
adamc@134 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@134 10 * this list of conditions and the following disclaimer in the documentation
adamc@134 11 * and/or other materials provided with the distribution.
adamc@134 12 * - The names of contributors may not be used to endorse or promote products
adamc@134 13 * derived from this software without specific prior written permission.
adamc@134 14 *
adamc@134 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@134 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@134 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@134 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@134 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@134 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@134 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@134 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@134 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@134 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@134 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@134 26 *)
adamc@134 27
adamc@134 28 (* Remove unused definitions from a file *)
adamc@134 29
adamc@134 30 structure MonoShake :> MONO_SHAKE = struct
adamc@134 31
adamc@134 32 open Mono
adamc@134 33
adamc@134 34 structure U = MonoUtil
adamc@134 35
adamc@134 36 structure IS = IntBinarySet
adamc@134 37 structure IM = IntBinaryMap
adamc@134 38
adamc@134 39 type free = {
adamc@134 40 con : IS.set,
adamc@134 41 exp : IS.set
adamc@134 42 }
adamc@134 43
adamc@134 44 fun shake file =
adamc@134 45 let
adamc@134 46 val page_es = List.foldl
adamc@609 47 (fn ((DExport (_, _, n, _, _), _), page_es) => n :: page_es
adamc@687 48 | ((DDatabase {expunge = n1, initialize = n2, ...}, _), page_es) => n1 :: n2 :: page_es
adamc@134 49 | (_, page_es) => page_es) [] file
adamc@134 50
adamc@178 51 val (cdef, edef) = foldl (fn ((DDatatype (_, n, xncs), _), (cdef, edef)) =>
adamc@178 52 (IM.insert (cdef, n, xncs), edef)
adamc@178 53 | ((DVal (_, n, t, e, _), _), (cdef, edef)) =>
adamc@178 54 (cdef, IM.insert (edef, n, (t, e)))
adamc@134 55 | ((DValRec vis, _), (cdef, edef)) =>
adamc@134 56 (cdef, foldl (fn ((_, n, t, e, _), edef) => IM.insert (edef, n, (t, e))) edef vis)
adamc@271 57 | ((DExport _, _), acc) => acc
adamc@273 58 | ((DTable _, _), acc) => acc
adamc@338 59 | ((DSequence _, _), acc) => acc
adamc@569 60 | ((DDatabase _, _), acc) => acc
adamc@569 61 | ((DJavaScript _, _), acc) => acc)
adamc@134 62 (IM.empty, IM.empty) file
adamc@134 63
adamc@164 64 fun typ (c, s) =
adamc@164 65 case c of
adamc@196 66 TDatatype (n, _) =>
adamc@164 67 if IS.member (#con s, n) then
adamc@164 68 s
adamc@164 69 else
adamc@178 70 let
adamc@178 71 val s' = {exp = #exp s,
adamc@178 72 con = IS.add (#con s, n)}
adamc@178 73 in
adamc@178 74 case IM.find (cdef, n) of
adamc@178 75 NONE => s'
adamc@178 76 | SOME xncs => foldl (fn ((_, _, to), s) =>
adamc@178 77 case to of
adamc@178 78 NONE => s
adamc@178 79 | SOME t => shakeTyp s t)
adamc@178 80 s' xncs
adamc@178 81 end
adamc@164 82 | _ => s
adamc@134 83
adamc@178 84 and shakeTyp s = U.Typ.fold typ s
adamc@178 85
adamc@134 86 fun exp (e, s) =
adamc@134 87 case e of
adamc@134 88 ENamed n =>
adamc@134 89 if IS.member (#exp s, n) then
adamc@134 90 s
adamc@134 91 else
adamc@134 92 let
adamc@134 93 val s' = {exp = IS.add (#exp s, n),
adamc@134 94 con = #con s}
adamc@134 95 in
adamc@134 96 case IM.find (edef, n) of
adamc@134 97 NONE => s'
adamc@134 98 | SOME (t, e) => shakeExp s' e
adamc@134 99 end
adamc@134 100 | _ => s
adamc@134 101
adamc@134 102 and shakeExp s = U.Exp.fold {typ = typ, exp = exp} s
adamc@134 103
adamc@134 104 val s = {con = IS.empty, exp = IS.addList (IS.empty, page_es)}
adamc@134 105
adamc@134 106 val s = foldl (fn (n, s) =>
adamc@134 107 case IM.find (edef, n) of
adamc@134 108 NONE => raise Fail "Shake: Couldn't find 'val'"
adamc@134 109 | SOME (t, e) => shakeExp s e) s page_es
adamc@134 110 in
adamc@164 111 List.filter (fn (DDatatype (_, n, _), _) => IS.member (#con s, n)
adamc@164 112 | (DVal (_, n, _, _, _), _) => IS.member (#exp s, n)
adamc@134 113 | (DValRec vis, _) => List.exists (fn (_, n, _, _, _) => IS.member (#exp s, n)) vis
adamc@271 114 | (DExport _, _) => true
adamc@273 115 | (DTable _, _) => true
adamc@338 116 | (DSequence _, _) => true
adamc@569 117 | (DDatabase _, _) => true
adamc@569 118 | (DJavaScript _, _) => true) file
adamc@134 119 end
adamc@134 120
adamc@134 121 end