Mercurial > urweb

annotate src/mono_env.sml @ 1739:c414850f206f

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Add support for -boot flag, which allows in-tree execution of Ur/Web The boot flag rewrites most hardcoded paths to point to the build directory, and also forces static compilation. This is convenient for developing Ur/Web, or if you cannot 'sudo make install' Ur/Web. The following changes were made: * Header files were moved to include/urweb instead of include; this lets FFI users point their C_INCLUDE_PATH at this directory at write <urweb/urweb.h>. For internal Ur/Web executables, we simply pass -I$PATH/include/urweb as normal. * Differentiate between LIB and SRCLIB; SRCLIB is Ur and JavaScript source files, while LIB is compiled products from libtool. For in-tree compilation these live in different places. * No longer reference Config for paths; instead use Settings; these settings can be changed dynamically by Compiler.enableBoot () (TODO: add a disableBoot function.) * config.h is now generated directly in include/urweb/config.h, for consistency's sake (especially since it gets installed along with the rest of the headers!) * All of the autotools build products got updated. * The linkStatic field in protocols now only contains the name of the build product, and not the absolute path. Future users have to be careful not to reference the Settings files to early, lest they get an old version (this was the source of two bugs during development of this patch.)
author Edward Z. Yang <ezyang@mit.edu>
date Wed, 02 May 2012 17:17:57 -0400
parents d328983dc5a6
children 6f2ea4ed573a
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@168 39 datatypes : (string * (string * int * typ option) list) IM.map,
adamc@178 40 constructors : (string * typ option * int) IM.map,
adamc@25 41
adamc@183 42 relE : (string * typ * exp option) list,
adamc@109 43 namedE : (string * typ * exp option * string) IM.map
adamc@25 44 }
adamc@25 45
adamc@25 46 val empty = {
adamc@168 47 datatypes = IM.empty,
adamc@178 48 constructors = IM.empty,
adamc@25 49
adamc@25 50 relE = [],
adamc@25 51 namedE = IM.empty
adamc@25 52 }
adamc@25 53
adamc@168 54 fun pushDatatype (env : env) x n xncs =
adamc@168 55 {datatypes = IM.insert (#datatypes env, n, (x, xncs)),
adamc@182 56 constructors = foldl (fn ((x, n', to), constructors) =>
adamc@182 57 IM.insert (constructors, n', (x, to, n)))
adamc@178 58 (#constructors env) xncs,
adamc@25 59
adamc@25 60 relE = #relE env,
adamc@25 61 namedE = #namedE env}
adamc@25 62
adamc@168 63 fun lookupDatatype (env : env) n =
adamc@168 64 case IM.find (#datatypes env, n) of
adamc@25 65 NONE => raise UnboundNamed n
adamc@25 66 | SOME x => x
adamc@25 67
adamc@178 68 fun lookupConstructor (env : env) n =
adamc@178 69 case IM.find (#constructors env, n) of
adamc@178 70 NONE => raise UnboundNamed n
adamc@178 71 | SOME x => x
adamc@178 72
adamc@800 73 structure U = MonoUtil
adamc@800 74
adamc@800 75 val liftExpInExp =
adamc@800 76 U.Exp.mapB {typ = fn t => t,
adamc@800 77 exp = fn bound => fn e =>
adamc@800 78 case e of
adamc@800 79 ERel xn =>
adamc@800 80 if xn < bound then
adamc@800 81 e
adamc@800 82 else
adamc@800 83 ERel (xn + 1)
adamc@800 84 | _ => e,
adamc@800 85 bind = fn (bound, U.Exp.RelE _) => bound + 1
adamc@800 86 | (bound, _) => bound}
adamc@800 87
adam@1394 88 val subExpInExp =
adam@1394 89 U.Exp.mapB {typ = fn t => t,
adam@1394 90 exp = fn (xn, rep) => fn e =>
adam@1394 91 case e of
adam@1394 92 ERel xn' =>
adam@1394 93 (case Int.compare (xn', xn) of
adam@1394 94 EQUAL => #1 rep
adam@1394 95 | GREATER=> ERel (xn' - 1)
adam@1394 96 | LESS => e)
adam@1394 97 | _ => e,
adam@1394 98 bind = fn ((xn, rep), U.Exp.RelE _) => (xn+1, liftExpInExp 0 rep)
adam@1394 99 | (ctx, _) => ctx}
adam@1394 100
adamc@183 101 fun pushERel (env : env) x t eo =
adamc@168 102 {datatypes = #datatypes env,
adamc@178 103 constructors = #constructors env,
adamc@800 104 relE = (x, t, eo) :: map (fn (x, t, eo) => (x, t, Option.map (liftExpInExp 0) eo)) (#relE env),
adamc@25 105 namedE = #namedE env}
adamc@25 106
adamc@25 107 fun lookupERel (env : env) n =
adamc@25 108 (List.nth (#relE env, n))
adamc@25 109 handle Subscript => raise UnboundRel n
adamc@25 110
adamc@109 111 fun pushENamed (env : env) x n t eo s =
adamc@168 112 {datatypes = #datatypes env,
adamc@178 113 constructors = #constructors env,
adamc@25 114
adamc@25 115 relE = #relE env,
adamc@109 116 namedE = IM.insert (#namedE env, n, (x, t, eo, s))}
adamc@25 117
adamc@25 118 fun lookupENamed (env : env) n =
adamc@25 119 case IM.find (#namedE env, n) of
adamc@25 120 NONE => raise UnboundNamed n
adamc@25 121 | SOME x => x
adamc@25 122
adamc@164 123 fun declBinds env (d, loc) =
adamc@25 124 case d of
adamc@808 125 DDatatype dts =>
adamc@808 126 foldl (fn ((x, n, xncs), env) =>
adamc@808 127 let
adamc@808 128 val env = pushDatatype env x n xncs
adamc@808 129 val dt = (TDatatype (n, ref (ElabUtil.classifyDatatype xncs, xncs)), loc)
adamc@808 130 in
adamc@808 131 foldl (fn ((x', n', NONE), env) => pushENamed env x' n' dt NONE ""
adamc@808 132 | ((x', n', SOME t), env) => pushENamed env x' n' (TFun (t, dt), loc) NONE "")
adamc@808 133 env xncs
adamc@808 134 end) env dts
adamc@164 135 | DVal (x, n, t, e, s) => pushENamed env x n t (SOME e) s
adamc@126 136 | DValRec vis => foldl (fn ((x, n, t, e, s), env) => pushENamed env x n t NONE s) env vis
adamc@109 137 | DExport _ => env
adamc@273 138 | DTable _ => env
adamc@338 139 | DSequence _ => env
adamc@754 140 | DView _ => env
adamc@271 141 | DDatabase _ => env
adamc@569 142 | DJavaScript _ => env
adamc@725 143 | DCookie _ => env
adamc@718 144 | DStyle _ => env
adamc@1075 145 | DTask _ => env
adamc@1199 146 | DPolicy _ => env
adam@1294 147 | DOnError _ => env
adamc@25 148
adamc@179 149 fun patBinds env (p, loc) =
adamc@179 150 case p of
adamc@179 151 PWild => env
adamc@183 152 | PVar (x, t) => pushERel env x t NONE
adamc@179 153 | PPrim _ => env
adamc@188 154 | PCon (_, _, NONE) => env
adamc@188 155 | PCon (_, _, SOME p) => patBinds env p
adamc@182 156 | PRecord xps => foldl (fn ((_, p, _), env) => patBinds env p) env xps
adamc@288 157 | PNone _ => env
adamc@288 158 | PSome (_, p) => patBinds env p
adamc@179 159
adamc@567 160 fun patBindsN (p, loc) =
adamc@567 161 case p of
adamc@567 162 PWild => 0
adamc@567 163 | PVar _ => 1
adamc@567 164 | PPrim _ => 0
adamc@567 165 | PCon (_, _, NONE) => 0
adamc@567 166 | PCon (_, _, SOME p) => patBindsN p
adamc@567 167 | PRecord xps => foldl (fn ((_, p, _), count) => count + patBindsN p) 0 xps
adamc@567 168 | PNone _ => 0
adamc@567 169 | PSome (_, p) => patBindsN p
adamc@567 170
adamc@25 171 end