Mercurial > urweb

annotate src/mono_opt.sml @ 122:f7c6ceb87bbd

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Three-argument web function test
author Adam Chlipala <adamc@hcoop.net>
date Sun, 13 Jul 2008 20:25:25 -0400
parents 6230bdd122e7
children b1cfe49ce692
rev   line source
adamc@96 1 (* Copyright (c) 2008, Adam Chlipala
adamc@96 2 * All rights reserved.
adamc@96 3 *
adamc@96 4 * Redistribution and use in source and binary forms, with or without
adamc@96 5 * modification, are permitted provided that the following conditions are met:
adamc@96 6 *
adamc@96 7 * - Redistributions of source code must retain the above copyright notice,
adamc@96 8 * this list of conditions and the following disclaimer.
adamc@96 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@96 10 * this list of conditions and the following disclaimer in the documentation
adamc@96 11 * and/or other materials provided with the distribution.
adamc@96 12 * - The names of contributors may not be used to endorse or promote products
adamc@96 13 * derived from this software without specific prior written permission.
adamc@96 14 *
adamc@96 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@96 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@96 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@96 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@96 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@96 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@96 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@96 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@96 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@96 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@96 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@96 26 *)
adamc@96 27
adamc@96 28 structure MonoOpt :> MONO_OPT = struct
adamc@96 29
adamc@96 30 open Mono
adamc@96 31 structure U = MonoUtil
adamc@96 32
adamc@96 33 fun typ t = t
adamc@96 34 fun decl d = d
adamc@96 35
adamc@107 36 fun attrifyInt n =
adamc@107 37 if n < 0 then
adamc@107 38 "-" ^ Int64.toString (Int64.~ n)
adamc@107 39 else
adamc@107 40 Int64.toString n
adamc@107 41
adamc@107 42 fun attrifyFloat n =
adamc@107 43 if n < 0.0 then
adamc@107 44 "-" ^ Real.toString (Real.~ n)
adamc@107 45 else
adamc@107 46 Real.toString n
adamc@107 47
adamc@107 48 val attrifyString = String.translate (fn #"\"" => "&quot;"
adamc@107 49 | ch => if Char.isPrint ch then
adamc@107 50 str ch
adamc@107 51 else
adamc@107 52 "&#" ^ Int.toString (ord ch) ^ ";")
adamc@107 53
adamc@120 54 val urlifyInt = attrifyInt
adamc@120 55 val urlifyFloat = attrifyFloat
adamc@120 56
adamc@120 57 fun hexIt ch =
adamc@120 58 let
adamc@120 59 val s = Int.fmt StringCvt.HEX (ord ch)
adamc@120 60 in
adamc@120 61 case size s of
adamc@120 62 0 => "00"
adamc@120 63 | 1 => "0" ^ s
adamc@120 64 | _ => s
adamc@120 65 end
adamc@120 66
adamc@120 67 val urlifyString = String.translate (fn #" " => "+"
adamc@120 68 | ch => if Char.isAlphaNum ch then
adamc@120 69 str ch
adamc@120 70 else
adamc@120 71 "%" ^ hexIt ch)
adamc@120 72
adamc@96 73 fun exp e =
adamc@96 74 case e of
adamc@96 75 EPrim (Prim.String s) =>
adamc@96 76 let
adamc@96 77 val (_, chs) =
adamc@96 78 CharVector.foldl (fn (ch, (lastSpace, chs)) =>
adamc@96 79 let
adamc@96 80 val isSpace = Char.isSpace ch
adamc@96 81 in
adamc@96 82 if isSpace andalso lastSpace then
adamc@96 83 (true, chs)
adamc@96 84 else
adamc@96 85 (isSpace, ch :: chs)
adamc@96 86 end)
adamc@96 87 (false, []) s
adamc@96 88 in
adamc@96 89 EPrim (Prim.String (String.implode (rev chs)))
adamc@96 90 end
adamc@96 91
adamc@96 92 | EStrcat ((EPrim (Prim.String s1), loc), (EPrim (Prim.String s2), _)) =>
adamc@96 93 let
adamc@96 94 val s =
adamc@96 95 if size s1 > 0 andalso size s2 > 0
adamc@96 96 andalso Char.isSpace (String.sub (s1, size s1 - 1))
adamc@96 97 andalso Char.isSpace (String.sub (s2, 0)) then
adamc@96 98 s1 ^ String.extract (s2, 1, NONE)
adamc@96 99 else
adamc@96 100 s1 ^ s2
adamc@96 101 in
adamc@96 102 EPrim (Prim.String s)
adamc@96 103 end
adamc@105 104
adamc@105 105 | EStrcat ((EPrim (Prim.String s1), loc), (EStrcat ((EPrim (Prim.String s2), _), rest), _)) =>
adamc@105 106 let
adamc@105 107 val s =
adamc@105 108 if size s1 > 0 andalso size s2 > 0
adamc@105 109 andalso Char.isSpace (String.sub (s1, size s1 - 1))
adamc@105 110 andalso Char.isSpace (String.sub (s2, 0)) then
adamc@105 111 s1 ^ String.extract (s2, 1, NONE)
adamc@105 112 else
adamc@105 113 s1 ^ s2
adamc@105 114 in
adamc@105 115 EStrcat ((EPrim (Prim.String s), loc), rest)
adamc@105 116 end
adamc@105 117
adamc@105 118 | EStrcat ((EStrcat (e1, e2), loc), e3) =>
adamc@105 119 optExp (EStrcat (e1, (EStrcat (e2, e3), loc)), loc)
adamc@105 120
adamc@106 121 | EWrite (EStrcat (e1, e2), loc) =>
adamc@106 122 ESeq ((optExp (EWrite e1, loc), loc),
adamc@106 123 (optExp (EWrite e2, loc), loc))
adamc@106 124
adamc@107 125 | EFfiApp ("Basis", "attrifyInt", [(EPrim (Prim.Int n), _)]) =>
adamc@107 126 EPrim (Prim.String (attrifyInt n))
adamc@107 127 | EWrite (EFfiApp ("Basis", "attrifyInt", [(EPrim (Prim.Int n), _)]), loc) =>
adamc@107 128 EWrite (EPrim (Prim.String (attrifyInt n)), loc)
adamc@106 129 | EWrite (EFfiApp ("Basis", "attrifyInt", [e]), _) =>
adamc@106 130 EFfiApp ("Basis", "attrifyInt_w", [e])
adamc@107 131
adamc@107 132 | EFfiApp ("Basis", "attrifyFloat", [(EPrim (Prim.Float n), _)]) =>
adamc@107 133 EPrim (Prim.String (attrifyFloat n))
adamc@107 134 | EWrite (EFfiApp ("Basis", "attrifyFloat", [(EPrim (Prim.Float n), _)]), loc) =>
adamc@107 135 EWrite (EPrim (Prim.String (attrifyFloat n)), loc)
adamc@106 136 | EWrite (EFfiApp ("Basis", "attrifyFloat", [e]), _) =>
adamc@106 137 EFfiApp ("Basis", "attrifyFloat_w", [e])
adamc@107 138
adamc@107 139 | EFfiApp ("Basis", "attrifyString", [(EPrim (Prim.String s), _)]) =>
adamc@107 140 EPrim (Prim.String (attrifyString s))
adamc@107 141 | EWrite (EFfiApp ("Basis", "attrifyString", [(EPrim (Prim.String s), _)]), loc) =>
adamc@107 142 EWrite (EPrim (Prim.String (attrifyString s)), loc)
adamc@106 143 | EWrite (EFfiApp ("Basis", "attrifyString", [e]), _) =>
adamc@106 144 EFfiApp ("Basis", "attrifyString_w", [e])
adamc@106 145
adamc@120 146 | EFfiApp ("Basis", "urlifyInt", [(EPrim (Prim.Int n), _)]) =>
adamc@120 147 EPrim (Prim.String (urlifyInt n))
adamc@120 148 | EWrite (EFfiApp ("Basis", "urlifyInt", [(EPrim (Prim.Int n), _)]), loc) =>
adamc@120 149 EWrite (EPrim (Prim.String (urlifyInt n)), loc)
adamc@120 150 | EWrite (EFfiApp ("Basis", "urlifyInt", [e]), _) =>
adamc@120 151 EFfiApp ("Basis", "urlifyInt_w", [e])
adamc@120 152
adamc@120 153 | EFfiApp ("Basis", "urlifyFloat", [(EPrim (Prim.Float n), _)]) =>
adamc@120 154 EPrim (Prim.String (urlifyFloat n))
adamc@120 155 | EWrite (EFfiApp ("Basis", "urlifyFloat", [(EPrim (Prim.Float n), _)]), loc) =>
adamc@120 156 EWrite (EPrim (Prim.String (urlifyFloat n)), loc)
adamc@120 157 | EWrite (EFfiApp ("Basis", "urlifyFloat", [e]), _) =>
adamc@120 158 EFfiApp ("Basis", "urlifyFloat_w", [e])
adamc@120 159
adamc@120 160 | EFfiApp ("Basis", "urlifyString", [(EPrim (Prim.String s), _)]) =>
adamc@120 161 EPrim (Prim.String (urlifyString s))
adamc@120 162 | EWrite (EFfiApp ("Basis", "urlifyString", [(EPrim (Prim.String s), _)]), loc) =>
adamc@120 163 EWrite (EPrim (Prim.String (urlifyString s)), loc)
adamc@120 164 | EWrite (EFfiApp ("Basis", "urlifyString", [e]), _) =>
adamc@120 165 EFfiApp ("Basis", "urlifyString_w", [e])
adamc@120 166
adamc@96 167 | _ => e
adamc@96 168
adamc@105 169 and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e)
adamc@105 170
adamc@96 171 val optimize = U.File.map {typ = typ, exp = exp, decl = decl}
adamc@96 172
adamc@96 173 end