Mercurial > urweb

annotate src/cjr_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 b4480a56cab7
children
rev   line source
adamc@29 1 (* Copyright (c) 2008, Adam Chlipala
adamc@29 2 * All rights reserved.
adamc@29 3 *
adamc@29 4 * Redistribution and use in source and binary forms, with or without
adamc@29 5 * modification, are permitted provided that the following conditions are met:
adamc@29 6 *
adamc@29 7 * - Redistributions of source code must retain the above copyright notice,
adamc@29 8 * this list of conditions and the following disclaimer.
adamc@29 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@29 10 * this list of conditions and the following disclaimer in the documentation
adamc@29 11 * and/or other materials provided with the distribution.
adamc@29 12 * - The names of contributors may not be used to endorse or promote products
adamc@29 13 * derived from this software without specific prior written permission.
adamc@29 14 *
adamc@29 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@29 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@29 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@29 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@29 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@29 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@29 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@29 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@29 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@29 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@29 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@29 26 *)
adamc@29 27
adamc@29 28 structure CjrEnv :> CJR_ENV = struct
adamc@29 29
adamc@29 30 open Cjr
adamc@29 31
adamc@29 32 structure IM = IntBinaryMap
adamc@29 33
adamc@29 34
adamc@29 35 exception UnboundRel of int
adamc@29 36 exception UnboundNamed of int
adamc@29 37 exception UnboundF of int
adamc@101 38 exception UnboundStruct of int
adamc@29 39
adamc@29 40 type env = {
adamc@166 41 datatypes : (string * (string * int * typ option) list) IM.map,
adamc@181 42 constructors : (string * typ option * int) IM.map,
adamc@29 43
adamc@29 44 numRelE : int,
adamc@29 45 relE : (string * typ) list,
adamc@29 46 namedE : (string * typ) IM.map,
adamc@29 47
adamc@101 48 structs : (string * typ) list IM.map
adamc@29 49 }
adamc@29 50
adamc@280 51 val empty : env = {
adamc@166 52 datatypes = IM.empty,
adamc@181 53 constructors = IM.empty,
adamc@29 54
adamc@29 55 numRelE = 0,
adamc@29 56 relE = [],
adamc@29 57 namedE = IM.empty,
adamc@29 58
adamc@280 59 structs = IM.insert (IM.empty, 0, [])
adamc@29 60 }
adamc@29 61
adamc@166 62 fun pushDatatype (env : env) x n xncs =
adamc@166 63 {datatypes = IM.insert (#datatypes env, n, (x, xncs)),
adamc@182 64 constructors = foldl (fn ((x, n', to), constructors) =>
adamc@182 65 IM.insert (constructors, n', (x, to, n)))
adamc@181 66 (#constructors env) xncs,
adamc@29 67
adamc@29 68 numRelE = #numRelE env,
adamc@29 69 relE = #relE env,
adamc@29 70 namedE = #namedE env,
adamc@29 71
adamc@101 72 structs = #structs env}
adamc@29 73
adamc@166 74 fun lookupDatatype (env : env) n =
adamc@166 75 case IM.find (#datatypes env, n) of
adamc@29 76 NONE => raise UnboundNamed n
adamc@29 77 | SOME x => x
adamc@29 78
adamc@181 79 fun lookupConstructor (env : env) n =
adamc@181 80 case IM.find (#constructors env, n) of
adamc@181 81 NONE => raise UnboundNamed n
adamc@181 82 | SOME x => x
adamc@181 83
adamc@29 84 fun pushERel (env : env) x t =
adamc@166 85 {datatypes = #datatypes env,
adamc@181 86 constructors = #constructors env,
adamc@29 87
adamc@29 88 numRelE = #numRelE env + 1,
adamc@29 89 relE = (x, t) :: #relE env,
adamc@29 90 namedE = #namedE env,
adamc@29 91
adamc@101 92 structs = #structs env}
adamc@29 93
adamc@29 94 fun lookupERel (env : env) n =
adamc@29 95 (List.nth (#relE env, n))
adamc@29 96 handle Subscript => raise UnboundRel n
adamc@29 97
adamc@29 98 fun countERels (env : env) = #numRelE env
adamc@29 99
adamc@29 100 fun listERels (env : env) = #relE env
adamc@29 101
adamc@29 102 fun pushENamed (env : env) x n t =
adamc@166 103 {datatypes = #datatypes env,
adamc@181 104 constructors = #constructors env,
adamc@29 105
adamc@29 106 numRelE = #numRelE env,
adamc@29 107 relE = #relE env,
adamc@29 108 namedE = IM.insert (#namedE env, n, (x, t)),
adamc@29 109
adamc@101 110 structs = #structs env}
adamc@29 111
adamc@29 112 fun lookupENamed (env : env) n =
adamc@29 113 case IM.find (#namedE env, n) of
adamc@29 114 NONE => raise UnboundNamed n
adamc@29 115 | SOME x => x
adamc@29 116
adamc@101 117 fun pushStruct (env : env) n xts =
adamc@166 118 {datatypes = #datatypes env,
adamc@181 119 constructors = #constructors env,
adamc@101 120
adamc@101 121 numRelE = #numRelE env,
adamc@101 122 relE = #relE env,
adamc@101 123 namedE = #namedE env,
adamc@101 124
adamc@101 125 structs = IM.insert (#structs env, n, xts)}
adamc@101 126
adamc@101 127 fun lookupStruct (env : env) n =
adamc@101 128 case IM.find (#structs env, n) of
adamc@101 129 NONE => raise UnboundStruct n
adamc@101 130 | SOME x => x
adamc@101 131
adamc@188 132 fun classifyDatatype xncs =
adamc@188 133 if List.all (fn (_, _, NONE) => true | _ => false) xncs then
adamc@188 134 Enum
adamc@188 135 else
adamc@188 136 Default
adamc@188 137
adamc@109 138 fun declBinds env (d, loc) =
adamc@29 139 case d of
adamc@809 140 DDatatype dts =>
adamc@809 141 foldl (fn ((_, x, n, xncs), env) =>
adamc@809 142 let
adamc@809 143 val env = pushDatatype env x n xncs
adamc@809 144 val dt = (TDatatype (classifyDatatype xncs, n, ref xncs), loc)
adamc@809 145 in
adamc@809 146 foldl (fn ((x', n', NONE), env) => pushENamed env x' n' dt
adamc@809 147 | ((x', n', SOME t), env) => pushENamed env x' n' (TFun (t, dt), loc))
adamc@809 148 env xncs
adamc@809 149 end) env dts
adamc@196 150 | DDatatypeForward (_, x, n) => pushDatatype env x n []
adamc@165 151 | DStruct (n, xts) => pushStruct env n xts
adamc@165 152 | DVal (x, n, t, _) => pushENamed env x n t
adamc@121 153 | DFun (fx, n, args, ran, _) =>
adamc@121 154 let
adamc@121 155 val t = foldl (fn ((_, arg), t) => (TFun (arg, t), loc)) ran args
adamc@121 156 in
adamc@121 157 pushENamed env fx n t
adamc@121 158 end
adamc@129 159 | DFunRec vis =>
adamc@129 160 foldl (fn ((fx, n, args, ran, _), env) =>
adamc@129 161 let
adamc@129 162 val t = foldl (fn ((_, arg), t) => (TFun (arg, t), loc)) ran args
adamc@129 163 in
adamc@129 164 pushENamed env fx n t
adamc@129 165 end) env vis
adamc@273 166 | DTable _ => env
adamc@338 167 | DSequence _ => env
adamc@754 168 | DView _ => env
adamc@271 169 | DDatabase _ => env
adamc@282 170 | DPreparedStatements _ => env
adamc@569 171 | DJavaScript _ => env
adamc@725 172 | DCookie _ => env
adamc@718 173 | DStyle _ => env
adamc@1075 174 | DTask _ => env
adam@1294 175 | DOnError _ => env
adamc@29 176
adamc@29 177 end