Mercurial > urweb

annotate src/mono_env.sml @ 109:813e5a52063d

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Remove closure conversion in favor of zany fun with modules, which also replaces 'page'
author Adam Chlipala <adamc@hcoop.net>
date Sun, 13 Jul 2008 10:17:06 -0400
parents f0f59e918cac
children 76a4d69719d8
rev   line source
adamc@25 1 (* Copyright (c) 2008, Adam Chlipala
adamc@25 2 * All rights reserved.
adamc@25 3 *
adamc@25 4 * Redistribution and use in source and binary forms, with or without
adamc@25 5 * modification, are permitted provided that the following conditions are met:
adamc@25 6 *
adamc@25 7 * - Redistributions of source code must retain the above copyright notice,
adamc@25 8 * this list of conditions and the following disclaimer.
adamc@25 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@25 10 * this list of conditions and the following disclaimer in the documentation
adamc@25 11 * and/or other materials provided with the distribution.
adamc@25 12 * - The names of contributors may not be used to endorse or promote products
adamc@25 13 * derived from this software without specific prior written permission.
adamc@25 14 *
adamc@25 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@25 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@25 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@25 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@25 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@25 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@25 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@25 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@25 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@25 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@25 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@25 26 *)
adamc@25 27
adamc@25 28 structure MonoEnv :> MONO_ENV = struct
adamc@25 29
adamc@25 30 open Mono
adamc@25 31
adamc@25 32 structure IM = IntBinaryMap
adamc@25 33
adamc@25 34
adamc@25 35 exception UnboundRel of int
adamc@25 36 exception UnboundNamed of int
adamc@25 37
adamc@25 38 type env = {
adamc@25 39 namedT : (string * typ option) IM.map,
adamc@25 40
adamc@25 41 relE : (string * typ) list,
adamc@109 42 namedE : (string * typ * exp option * string) IM.map
adamc@25 43 }
adamc@25 44
adamc@25 45 val empty = {
adamc@25 46 namedT = IM.empty,
adamc@25 47
adamc@25 48 relE = [],
adamc@25 49 namedE = IM.empty
adamc@25 50 }
adamc@25 51
adamc@25 52 fun pushTNamed (env : env) x n co =
adamc@25 53 {namedT = IM.insert (#namedT env, n, (x, co)),
adamc@25 54
adamc@25 55 relE = #relE env,
adamc@25 56 namedE = #namedE env}
adamc@25 57
adamc@25 58 fun lookupTNamed (env : env) n =
adamc@25 59 case IM.find (#namedT env, n) of
adamc@25 60 NONE => raise UnboundNamed n
adamc@25 61 | SOME x => x
adamc@25 62
adamc@25 63 fun pushERel (env : env) x t =
adamc@25 64 {namedT = #namedT env,
adamc@25 65
adamc@25 66 relE = (x, t) :: #relE env,
adamc@25 67 namedE = #namedE env}
adamc@25 68
adamc@25 69 fun lookupERel (env : env) n =
adamc@25 70 (List.nth (#relE env, n))
adamc@25 71 handle Subscript => raise UnboundRel n
adamc@25 72
adamc@109 73 fun pushENamed (env : env) x n t eo s =
adamc@25 74 {namedT = #namedT env,
adamc@25 75
adamc@25 76 relE = #relE env,
adamc@109 77 namedE = IM.insert (#namedE env, n, (x, t, eo, s))}
adamc@25 78
adamc@25 79 fun lookupENamed (env : env) n =
adamc@25 80 case IM.find (#namedE env, n) of
adamc@25 81 NONE => raise UnboundNamed n
adamc@25 82 | SOME x => x
adamc@25 83
adamc@25 84 fun declBinds env (d, _) =
adamc@25 85 case d of
adamc@109 86 DVal (x, n, t, e, s) => pushENamed env x n t (SOME e) s
adamc@109 87 | DExport _ => env
adamc@25 88
adamc@25 89 end