Mercurial > urweb

annotate src/prim.sml @ 2276:c05f9a5e0f0f

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Progress on free paths, but consolidation seems to fail more with them.
author Ziv Scully <ziv@mit.edu>
date Mon, 09 Nov 2015 13:37:31 -0500
parents 4d64af730e35
children
rev   line source
adam@2048 1 (* Copyright (c) 2008, 2014, Adam Chlipala
adamc@14 2 * All rights reserved.
adamc@14 3 *
adamc@14 4 * Redistribution and use in source and binary forms, with or without
adamc@14 5 * modification, are permitted provided that the following conditions are met:
adamc@14 6 *
adamc@14 7 * - Redistributions of source code must retain the above copyright notice,
adamc@14 8 * this list of conditions and the following disclaimer.
adamc@14 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@14 10 * this list of conditions and the following disclaimer in the documentation
adamc@14 11 * and/or other materials provided with the distribution.
adamc@14 12 * - The names of contributors may not be used to endorse or promote products
adamc@14 13 * derived from this software without specific prior written permission.
adamc@14 14 *
adamc@14 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@14 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@14 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@14 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@14 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@14 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@14 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@14 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@14 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@14 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@14 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@14 26 *)
adamc@14 27
adamc@14 28 structure Prim :> PRIM = struct
adamc@14 29
adam@2048 30 datatype string_mode = Normal | Html
adam@2048 31
adamc@14 32 datatype t =
adamc@14 33 Int of Int64.int
adamc@14 34 | Float of Real64.real
adam@2048 35 | String of string_mode * string
adamc@821 36 | Char of char
adamc@14 37
adamc@14 38 open Print.PD
adamc@14 39 open Print
adamc@14 40
adamc@14 41 fun p_t t =
adamc@14 42 case t of
adamc@14 43 Int n => string (Int64.toString n)
adamc@14 44 | Float n => string (Real64.toString n)
adam@2048 45 | String (_, s) => box [string "\"", string (String.toString s), string "\""]
adamc@942 46 | Char ch => box [string "#\"", string (String.toString (String.str ch)), string "\""]
adamc@14 47
adamc@276 48 fun int2s n =
adamc@276 49 if Int64.compare (n, Int64.fromInt 0) = LESS then
adamc@276 50 "-" ^ Int64.toString (Int64.~ n) ^ "LL"
adamc@276 51 else
adamc@276 52 Int64.toString n ^ "LL"
adamc@276 53
adamc@582 54 fun int2s' n =
adamc@582 55 if Int64.compare (n, Int64.fromInt 0) = LESS then
adamc@582 56 "-" ^ Int64.toString (Int64.~ n)
adamc@582 57 else
adamc@582 58 Int64.toString n
adamc@582 59
adam@1468 60 val float2s = String.translate (fn #"~" => "-" | ch => str ch) o Real64.toString
adamc@276 61
adamc@567 62 fun toString t =
adamc@567 63 case t of
adamc@582 64 Int n => int2s' n
adamc@567 65 | Float n => float2s n
adam@2048 66 | String (_, s) => s
adamc@821 67 | Char ch => str ch
adamc@567 68
adamc@1053 69 fun pad (n, ch, s) =
adamc@1053 70 if size s >= n then
adamc@1053 71 s
adamc@1053 72 else
adamc@1053 73 str ch ^ pad (n-1, ch, s)
adamc@1053 74
adam@1656 75 fun quoteDouble ch =
adam@1656 76 case ch of
adam@1656 77 #"'" => str ch
adam@1656 78 | _ => Char.toCString ch
adam@1656 79
adam@1656 80 fun toCChar ch =
adam@1656 81 case ch of
adam@1656 82 #"\"" => str ch
adam@1656 83 | _ => Char.toCString ch
adam@1656 84
adam@1656 85 val toCString = String.translate quoteDouble
adam@1656 86
adamc@276 87 fun p_t_GCC t =
adamc@276 88 case t of
adamc@276 89 Int n => string (int2s n)
adamc@276 90 | Float n => string (float2s n)
adam@2048 91 | String (_, s) => box [string "\"", string (toCString s), string "\""]
adam@1656 92 | Char ch => box [string "'", string (toCChar ch), string "'"]
adamc@276 93
adamc@183 94 fun equal x =
adamc@183 95 case x of
adamc@183 96 (Int n1, Int n2) => n1 = n2
adamc@183 97 | (Float n1, Float n2) => Real64.== (n1, n2)
adam@2048 98 | (String (_, s1), String (_, s2)) => s1 = s2
adamc@821 99 | (Char ch1, Char ch2) => ch1 = ch2
adamc@183 100
adamc@183 101 | _ => false
adamc@183 102
adamc@479 103 fun compare (p1, p2) =
adamc@479 104 case (p1, p2) of
adamc@479 105 (Int n1, Int n2) => Int64.compare (n1, n2)
adamc@479 106 | (Int _, _) => LESS
adamc@479 107 | (_, Int _) => GREATER
adamc@479 108
adamc@479 109 | (Float n1, Float n2) => Real64.compare (n1, n2)
adamc@479 110 | (Float _, _) => LESS
adamc@821 111 | (_, Float _) => GREATER
adamc@479 112
adam@2048 113 | (String (_, n1), String (_, n2)) => String.compare (n1, n2)
adamc@821 114 | (String _, _) => LESS
adamc@821 115 | (_, String _) => GREATER
adamc@821 116
adamc@821 117 | (Char ch1, Char ch2) => Char.compare (ch1, ch2)
adamc@479 118
adamc@14 119 end