Mercurial > urweb

annotate src/checknest.sml @ 2191:849404a3af27

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Change behavior of SQL equality to do the intuitive thing for nullable types
author Adam Chlipala <adam@chlipala.net>
date Sun, 01 Nov 2015 17:02:16 -0500
parents 98895243b5b6
children
rev   line source
adamc@879 1 (* Copyright (c) 2009, Adam Chlipala
adamc@879 2 * All rights reserved.
adamc@879 3 *
adamc@879 4 * Redistribution and use in source and binary forms, with or without
adamc@879 5 * modification, are permitted provided that the following conditions are met:
adamc@879 6 *
adamc@879 7 * - Redistributions of source code must retain the above copyright notice,
adamc@879 8 * this list of conditions and the following disclaimer.
adamc@879 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@879 10 * this list of conditions and the following disclaimer in the documentation
adamc@879 11 * and/or other materials provided with the distribution.
adamc@879 12 * - The names of contributors may not be used to endorse or promote products
adamc@879 13 * derived from this software without specific prior written permission.
adamc@879 14 *
adamc@879 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@879 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@879 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@879 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@879 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@879 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@879 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@879 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@879 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@879 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@879 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@879 26 *)
adamc@879 27
adamc@879 28 structure Checknest :> CHECKNEST = struct
adamc@879 29
adamc@879 30 open Cjr
adamc@879 31
adamc@879 32 structure IS = IntBinarySet
adamc@879 33 structure IM = IntBinaryMap
adamc@879 34
adamc@879 35 fun expUses globals =
adamc@879 36 let
adamc@879 37 fun eu (e, _) =
adamc@879 38 case e of
adamc@879 39 EPrim _ => IS.empty
adamc@879 40 | ERel _ => IS.empty
adamc@879 41 | ENamed n => Option.getOpt (IM.find (globals, n), IS.empty)
adamc@879 42 | ECon (_, _, NONE) => IS.empty
adamc@879 43 | ECon (_, _, SOME e) => eu e
adamc@879 44 | ENone _ => IS.empty
adamc@879 45 | ESome (_, e) => eu e
adamc@879 46 | EFfi _ => IS.empty
adam@1663 47 | EFfiApp (_, _, es) => foldl IS.union IS.empty (map (eu o #1) es)
adamc@879 48 | EApp (e, es) => foldl IS.union (eu e) (map eu es)
adamc@879 49
adamc@879 50 | EUnop (_, e) => eu e
adamc@879 51 | EBinop (_, e1, e2) => IS.union (eu e1, eu e2)
adamc@879 52
adamc@879 53 | ERecord (_, xes) => foldl (fn ((_, e), s) => IS.union (eu e, s)) IS.empty xes
adamc@879 54 | EField (e, _) => eu e
adamc@879 55
adamc@879 56 | ECase (e, pes, _) => foldl (fn ((_, e), s) => IS.union (eu e, s)) (eu e) pes
adamc@879 57
adamc@879 58 | EError (e, _) => eu e
adam@1932 59 | EReturnBlob {blob = NONE, mimeType, ...} => eu mimeType
adam@1932 60 | EReturnBlob {blob = SOME blob, mimeType, ...} => IS.union (eu blob, eu mimeType)
adamc@1065 61 | ERedirect (e, _) => eu e
adamc@879 62
adamc@879 63 | EWrite e => eu e
adamc@879 64 | ESeq (e1, e2) => IS.union (eu e1, eu e2)
adamc@879 65 | ELet (_, _, e1, e2) => IS.union (eu e1, eu e2)
adamc@879 66
adamc@879 67 | EQuery {query, body, initial, prepared, ...} =>
adamc@879 68 let
adamc@879 69 val s = IS.union (eu query, IS.union (eu body, eu initial))
adamc@879 70 in
adamc@879 71 case prepared of
adamc@879 72 SOME {id, ...} => IS.add (s, id)
adamc@879 73 | _ => s
adamc@879 74 end
adamc@879 75 | EDml {dml, prepared, ...} =>
adamc@879 76 let
adamc@879 77 val s = eu dml
adamc@879 78 in
adamc@879 79 case prepared of
adamc@879 80 SOME {id, ...} => IS.add (s, id)
adamc@879 81 | _ => s
adamc@879 82 end
adamc@879 83 | ENextval {seq, prepared, ...} =>
adamc@879 84 let
adamc@879 85 val s = eu seq
adamc@879 86 in
adamc@879 87 case prepared of
adamc@879 88 SOME {id, ...} => IS.add (s, id)
adamc@879 89 | _ => s
adamc@879 90 end
adamc@1073 91 | ESetval {seq, count} => IS.union (eu seq, eu count)
adamc@879 92
adamc@1112 93 | EUnurlify (e, _, _) => eu e
adamc@879 94 in
adamc@879 95 eu
adamc@879 96 end
adamc@879 97
adamc@879 98 fun annotateExp globals =
adamc@879 99 let
adamc@879 100 fun ae (e as (_, loc)) =
adamc@879 101 case #1 e of
adamc@879 102 EPrim _ => e
adamc@879 103 | ERel _ => e
adamc@879 104 | ENamed n => e
adamc@879 105 | ECon (_, _, NONE) => e
adamc@879 106 | ECon (dk, pc, SOME e) => (ECon (dk, pc, SOME (ae e)), loc)
adamc@879 107 | ENone _ => e
adamc@879 108 | ESome (t, e) => (ESome (t, ae e), loc)
adamc@879 109 | EFfi _ => e
adam@1663 110 | EFfiApp (m, f, es) => (EFfiApp (m, f, map (fn (e, t) => (ae e, t)) es), loc)
adamc@879 111 | EApp (e, es) => (EApp (ae e, map ae es), loc)
adamc@879 112
adamc@879 113 | EUnop (uo, e) => (EUnop (uo, ae e), loc)
adamc@879 114 | EBinop (bo, e1, e2) => (EBinop (bo, ae e1, ae e2), loc)
adamc@879 115
adamc@879 116 | ERecord (n, xes) => (ERecord (n, map (fn (x, e) => (x, ae e)) xes), loc)
adamc@879 117 | EField (e, f) => (EField (ae e, f), loc)
adamc@879 118
adamc@879 119 | ECase (e, pes, ts) => (ECase (ae e, map (fn (p, e) => (p, ae e)) pes, ts), loc)
adamc@879 120
adamc@879 121 | EError (e, t) => (EError (ae e, t), loc)
adam@1932 122 | EReturnBlob {blob = NONE, mimeType, t} => (EReturnBlob {blob = NONE, mimeType = ae mimeType, t = t}, loc)
adam@1932 123 | EReturnBlob {blob = SOME blob, mimeType, t} => (EReturnBlob {blob = SOME (ae blob), mimeType = ae mimeType, t = t}, loc)
adamc@1065 124 | ERedirect (e, t) => (ERedirect (ae e, t), loc)
adamc@879 125
adamc@879 126 | EWrite e => (EWrite (ae e), loc)
adamc@879 127 | ESeq (e1, e2) => (ESeq (ae e1, ae e2), loc)
adamc@879 128 | ELet (x, t, e1, e2) => (ELet (x, t, ae e1, ae e2), loc)
adamc@879 129
adamc@879 130 | EQuery {exps, tables, rnum, state, query, body, initial, prepared} =>
adamc@879 131 (EQuery {exps = exps,
adamc@879 132 tables = tables,
adamc@879 133 rnum = rnum,
adamc@879 134 state = state,
adamc@879 135 query = ae query,
adamc@879 136 body = ae body,
adamc@879 137 initial = ae initial,
adamc@879 138 prepared = case prepared of
adamc@879 139 NONE => NONE
adamc@879 140 | SOME {id, query, ...} => SOME {id = id, query = query,
adamc@879 141 nested = IS.member (expUses globals body, id)}},
adamc@879 142 loc)
adam@1293 143 | EDml {dml, prepared, mode} =>
adamc@879 144 (EDml {dml = ae dml,
adam@1293 145 prepared = prepared,
adam@1293 146 mode = mode}, loc)
adamc@879 147
adamc@879 148 | ENextval {seq, prepared} =>
adamc@879 149 (ENextval {seq = ae seq,
adamc@879 150 prepared = prepared}, loc)
adamc@1073 151 | ESetval {seq, count} =>
adamc@1073 152 (ESetval {seq = ae seq,
adamc@1073 153 count = ae count}, loc)
adamc@879 154
adamc@1112 155 | EUnurlify (e, t, b) => (EUnurlify (ae e, t, b), loc)
adamc@879 156 in
adamc@879 157 ae
adamc@879 158 end
adamc@879 159
adamc@879 160 fun annotate (ds, syms) =
adamc@879 161 let
adamc@879 162 val globals =
adamc@879 163 foldl (fn ((d, _), globals) =>
adamc@879 164 case d of
adamc@879 165 DVal (_, n, _, e) => IM.insert (globals, n, expUses globals e)
adamc@879 166 | DFun (_, n, _, _, e) => IM.insert (globals, n, expUses globals e)
adamc@879 167 | DFunRec fs =>
adamc@879 168 let
adamc@879 169 val s = foldl (fn ((_, _, _, _, e), s) => IS.union (expUses globals e, s)) IS.empty fs
adamc@879 170 in
adamc@879 171 foldl (fn ((_, n, _, _, _), globals) => IM.insert (globals, n, s)) globals fs
adamc@879 172 end
adamc@879 173 | _ => globals) IM.empty ds
adamc@879 174
adamc@879 175 val ds =
adamc@879 176 map (fn d as (_, loc) =>
adamc@879 177 case #1 d of
adamc@879 178 DVal (x, n, t, e) => (DVal (x, n, t, annotateExp globals e), loc)
adamc@879 179 | DFun (x, n, ts, t, e) => (DFun (x, n, ts, t, annotateExp globals e), loc)
adamc@879 180 | DFunRec fs => (DFunRec
adamc@879 181 (map (fn (x, n, ts, t, e) => (x, n, ts, t, annotateExp globals e)) fs), loc)
adamc@879 182 | _ => d) ds
adamc@879 183 in
adamc@879 184 (ds, syms)
adamc@879 185 end
adamc@879 186
adamc@879 187 end