Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/branches/arith64/system/smlnj/init/pervasive.sml
ViewVC logotype

Annotation of /sml/branches/arith64/system/smlnj/init/pervasive.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 4874 - (view) (download)

1 : jhr 3417 (* pervasive.sml
2 :     *
3 : jhr 4874 * COPYRIGHT (c) 2018 The Fellowship of SML/NJ (http://www.smlnj.org)
4 : jhr 3417 * All rights reserved.
5 :     *
6 :     * These are the pervasive bindings as defined by the SML'97
7 :     * Basis Library specification (Chapter 3 of Gansner and
8 :     * Reppy, 2004). Note that this file must be processed before
9 :     * the code in base/system/Basis/Implementation, so we have to
10 :     * reverse the order of the bindings (e.g., Real.round is bound
11 :     * to the top-level round, instead of the other way around).
12 :     *)
13 : blume 573
14 :     infix 7 * / mod div
15 :     infix 6 ^ + -
16 :     infix 3 := o
17 :     infix 4 > < >= <= = <>
18 :     infixr 5 :: @
19 :     infix 0 before
20 :    
21 :     (* top-level type (we need this one early) *)
22 :    
23 :     datatype bool = datatype PrimTypes.bool
24 :    
25 : mblume 1381 val op o : ('b -> 'c) * ('a -> 'b) -> ('a -> 'c) = InlineT.compose
26 :    
27 : blume 573 local
28 :     structure I31 = InlineT.Int31
29 :     structure I32 = InlineT.Int32
30 :     structure W8 = InlineT.Word8
31 :     structure W31 = InlineT.Word31
32 :     structure W32 = InlineT.Word32
33 : jhr 4874 structure CW64 = CoreWord64 (* 64BIT: CoreWord64 will not be present on 64-bit targets *)
34 :     structure CI64 = CoreInt64 (* 64BIT: CoreInt64 will not be present on 64-bit targets *)
35 :     (* REAL32: add R32 *)
36 : blume 573 structure R64 = InlineT.Real64
37 :     structure CV = InlineT.CharVector
38 :     structure PV = InlineT.PolyVector
39 :     structure DI = InlineT.DfltInt
40 :    
41 : mblume 1347 structure CII = CoreIntInf
42 :    
43 : jhr 4455 (* FIXME: this wrapper breaks inlining of Word8 arithmetic!!!! *)
44 : blume 573 fun w8adapt oper args = W8.andb (oper args, 0wxFF)
45 :     val w8plus = w8adapt W8.+
46 :     val w8minus = w8adapt W8.-
47 :     val w8times = w8adapt W8.*
48 : mblume 1683 val w8neg = w8adapt W8.~
49 : blume 573
50 :     fun stringlt (a, b) = let
51 :     val al = CV.length a
52 :     val bl = CV.length b
53 :     val ashort = DI.< (al, bl)
54 :     val n = if ashort then al else bl
55 :     fun cmp i =
56 :     if InlineT.= (i, n) then ashort
57 :     else let
58 :     val ai = CV.sub (a, i)
59 :     val bi = CV.sub (b, i)
60 : jhr 3417 in
61 :     InlineT.Char.< (ai, bi) orelse
62 :     (InlineT.= (ai, bi) andalso cmp (DI.+ (i, 1)))
63 :     end
64 :     in
65 :     cmp 0
66 :     end
67 : blume 573 fun stringle (a, b) = if stringlt (b, a) then false else true
68 :     fun stringgt (a, b) = stringlt (b, a)
69 :     fun stringge (a, b) = stringle (b, a)
70 :     in
71 :     overload ~ : ('a -> 'a)
72 : mblume 1686 as I31.~ and I32.~ and CI64.~ and CII.~
73 : dbm 4000 and W31.~ and w8neg and W32.~ and CW64.~
74 : mblume 1683 and R64.~
75 : blume 573 overload + : ('a * 'a -> 'a)
76 : mblume 1686 as I31.+ and I32.+ and CI64.+ and CII.+
77 : dbm 4000 and W31.+ and w8plus and W32.+ and CW64.+
78 : mblume 1683 and R64.+
79 : blume 573 overload - : ('a * 'a -> 'a)
80 : mblume 1686 as I31.- and I32.- and CI64.- and CII.-
81 : dbm 4000 and W31.- and w8minus and W32.- and CW64.-
82 : mblume 1683 and R64.-
83 : blume 573 overload * : ('a * 'a -> 'a)
84 : mblume 1686 as I31.* and I32.* and CI64.* and CII.*
85 : dbm 4000 and W31.* and w8times and W32.* and CW64.*
86 : mblume 1683 and R64.*
87 : mblume 1793 (*
88 : blume 573 overload / : ('a * 'a -> 'a)
89 :     as R64./
90 : mblume 1793 *)
91 :     val op / = R64./ (* temporary hack around overloading bug *)
92 : blume 573 overload div : ('a * 'a -> 'a)
93 : mblume 1686 as I31.div and I32.div and CI64.div and CII.div
94 : dbm 4000 and W31.div and W8.div and W32.div and CW64.div
95 : blume 573 overload mod : ('a * 'a -> 'a)
96 : mblume 1686 as I31.mod and I32.mod and CI64.mod and CII.mod
97 : dbm 4000 and W31.mod and W8.mod and W32.mod and CW64.mod
98 : blume 573 overload < : ('a * 'a -> bool)
99 : mblume 1686 as I31.< and I32.< and CI64.< and CII.<
100 : dbm 4000 and W31.< and W8.< and W32.< and CW64.<
101 : mblume 1683 and R64.<
102 : blume 573 and InlineT.Char.<
103 :     and stringlt
104 :     overload <= : ('a * 'a -> bool)
105 : mblume 1686 as I31.<= and I32.<= and CI64.<= and CII.<=
106 : dbm 4000 and W31.<= and W8.<= and W32.<= and CW64.<=
107 : mblume 1683 and R64.<=
108 : blume 573 and InlineT.Char.<=
109 :     and stringle
110 :     overload > : ('a * 'a -> bool)
111 : mblume 1686 as I31.> and I32.> and CI64.> and CII.>
112 : dbm 4000 and W31.> and W8.> and W32.> and CW64.>
113 : mblume 1683 and R64.>
114 : blume 573 and InlineT.Char.>
115 :     and stringgt
116 :     overload >= : ('a * 'a -> bool)
117 : mblume 1686 as I31.>= and I32.>= and CI64.>= and CII.>=
118 : dbm 4000 and W31.>= and W8.>= and W32.>= and CW64.>=
119 : mblume 1683 and R64.>=
120 : blume 573 and InlineT.Char.>=
121 :     and stringge
122 :     overload abs : ('a -> 'a)
123 : mblume 1686 as I31.abs and I32.abs and CI64.abs and CII.abs and R64.abs
124 : blume 573
125 :     type unit = PrimTypes.unit
126 :     type exn = PrimTypes.exn
127 :    
128 :     exception Bind = Core.Bind
129 :     exception Match = Core.Match
130 :     exception Subscript = Core.Subscript
131 :     exception Size = Core.Size
132 :     exception Overflow = Assembly.Overflow
133 :     exception Chr = InlineT.Char.Chr
134 :     exception Div = Assembly.Div
135 :     exception Domain
136 :    
137 :     type string = PrimTypes.string
138 :    
139 :     exception Fail of string
140 :    
141 :     (* exception Span
142 :     * datatype order
143 :     * datatype option
144 :     * exception Option
145 :     * val getOpt
146 :     * val isSome
147 :     * val valOf
148 :     * val op =
149 : jhr 3417 * val op <>
150 :     *)
151 : blume 573 open PrePervasive
152 :    
153 :     val ! = InlineT.!
154 :     val op := = InlineT.:=
155 :    
156 :     val op before : ('a * unit) -> 'a = InlineT.before
157 : blume 1183 val ignore : 'a -> unit = InlineT.ignore
158 : blume 573
159 :     (* top-level types *)
160 :    
161 :     datatype list = datatype PrimTypes.list
162 :     datatype ref = datatype PrimTypes.ref
163 :    
164 :     (* top-level value identifiers *)
165 :    
166 :     (* Bool *)
167 :     val not = InlineT.inlnot
168 :    
169 :     (* Int *)
170 :     type int = PrimTypes.int
171 :    
172 :     (* Word *)
173 :     type word = PrimTypes.word
174 :    
175 :     (* Real *)
176 : jhr 3417 local
177 :     val w31_r = R64.from_int32 o I32.copy_word31
178 :     val intbound = w31_r 0wx40000000 (* not necessarily the same as rbase *)
179 :     val negintbound = R64.~ intbound
180 :     in
181 : blume 573 type real = PrimTypes.real
182 :    
183 : jhr 3417 val real = R64.from_int31
184 :    
185 : blume 573 fun floor x =
186 : jhr 3417 if x < intbound andalso x >= negintbound then Assembly.A.floor x
187 :     else if R64.==(x, x) then raise Overflow (* not a NaN *)
188 :     else raise Domain
189 :    
190 : blume 573 fun ceil x = DI.- (~1, floor (R64.~ (x + 1.0)))
191 : jhr 3417
192 : blume 573 fun trunc x = if R64.< (x, 0.0) then ceil x else floor x
193 :    
194 : jhr 3417 fun round x = let
195 :     (* ties go to the nearest even number *)
196 :     val fl = floor(x+0.5)
197 :     val cl = ceil(x-0.5)
198 :     in
199 :     if fl=cl then fl
200 :     else if W31.andb(W31.fromInt fl,0w1) = 0w1 then cl
201 :     else fl
202 :     end
203 :    
204 :     end (* local *)
205 :    
206 : blume 573 (* List *)
207 :     exception Empty
208 :     fun null [] = true
209 :     | null _ = false
210 :     fun hd (h :: _) = h
211 :     | hd [] = raise Empty
212 :     fun tl (_ :: t) = t
213 :     | tl [] = raise Empty
214 :     fun foldl f b l = let
215 : jhr 3417 fun f2 ([], b) = b
216 :     | f2 (a :: r, b) = f2 (r, f (a, b))
217 :     in
218 :     f2 (l, b)
219 :     end
220 : blume 573 fun length l = let
221 : jhr 3417 (* fast add that avoids the overflow test *)
222 :     fun a + b = W31.copyt_int31 (W31.+(W31.copyf_int31 a, W31.copyf_int31 b))
223 :     fun loop (n, []) = n
224 :     | loop (n, [_]) = n + 1
225 :     | loop (n, _ :: _ :: l) = loop (n + 2, l)
226 :     in
227 :     loop (0, l)
228 :     end
229 : jhr 3470 fun revAppend ([], l) = l
230 :     | revAppend (x::r, l) = revAppend(r, x::l)
231 :     fun rev l = revAppend(l, [])
232 :     fun foldr f b l = foldl f b (rev l)
233 :     fun l1 @ l2 = revAppend(rev l1, l2)
234 : blume 573 fun app f = let
235 : jhr 3417 fun a2 [] = ()
236 :     | a2 (h :: t) = (f h : unit; a2 t)
237 :     in
238 :     a2
239 :     end
240 : blume 573 fun map f = let
241 : jhr 3417 fun m [] = []
242 :     | m [a] = [f a]
243 :     | m [a, b] = [f a, f b]
244 :     | m [a, b, c] = [f a, f b, f c]
245 :     | m (a :: b :: c :: d :: r) = f a :: f b :: f c :: f d :: m r
246 :     in
247 :     m
248 :     end
249 : blume 573
250 :     (* Array *)
251 :     type 'a array = 'a PrimTypes.array
252 :    
253 :     (* Vector *)
254 :     type 'a vector = 'a PrimTypes.vector
255 :    
256 : jhr 3417 fun vector l = let
257 :     val n = length l
258 :     in
259 :     if DI.ltu (Core.max_length, n) then raise Size
260 :     else if (n = 0) then Assembly.vector0
261 :     else Assembly.A.create_v(n, l)
262 :     end
263 :    
264 : blume 573 (* Char *)
265 :     type char = PrimTypes.char
266 :     val ord = InlineT.Char.ord
267 :     val chr = InlineT.Char.chr
268 :    
269 :     (* String *)
270 :     local
271 :     (* allocate an uninitialized string of given length *)
272 :     fun create n =
273 :     if (DI.ltu (Core.max_length, n)) then raise Size
274 :     else Assembly.A.create_s n
275 :    
276 :     val unsafeSub = CV.sub
277 :     val unsafeUpdate = CV.update
278 :     in
279 :    
280 :     val size = CV.length : string -> int
281 :    
282 :     fun str (c: char) : string = PV.sub (PreString.chars, InlineT.cast c)
283 :    
284 :     (* concatenate a list of strings together *)
285 : jhr 3417 fun concat [] = ""
286 :     | concat [s] = s
287 : blume 573 | concat (sl : string list) = let
288 : jhr 3417 (* compute total length of result string *)
289 :     fun length (i, []) = i
290 :     | length (i, s::rest) = length(i+size s, rest)
291 :     in
292 :     case length (0, sl)
293 :     of 0 => ""
294 : blume 573 | 1 => let
295 : jhr 3417 fun find ("" :: r) = find r
296 :     | find (s :: _) = s
297 :     | find _ = "" (** impossible **)
298 :     in
299 : blume 573 find sl
300 : jhr 3417 end
301 : blume 573 | totLen => let
302 : jhr 3417 val ss = create totLen
303 :     fun copy ([], _) = ()
304 :     | copy (s::r, i) = let
305 :     val len = size s
306 :     fun copy' j =
307 :     if (j = len) then ()
308 :     else (unsafeUpdate(ss, i+j, unsafeSub(s, j));
309 :     copy'(j+1))
310 : blume 573 in
311 : jhr 3417 copy' 0;
312 :     copy (r, i+len)
313 : blume 573 end
314 : jhr 3417 in
315 : blume 573 copy (sl, 0);
316 :     ss
317 : jhr 3417 end
318 :     (* end case *)
319 :     end (* concat *)
320 : blume 573
321 :    
322 :     (* implode a list of characters into a string *)
323 :     fun implode [] = ""
324 : jhr 3417 | implode cl = PreString.implode (length cl, cl)
325 : blume 573
326 :     (* explode a string into a list of characters *)
327 :     fun explode s = let
328 : jhr 3417 fun f(l, ~1) = l
329 :     | f(l, i) = f (unsafeSub(s, i) :: l, i-1)
330 :     in
331 :     f ([], size s - 1)
332 :     end
333 : blume 573
334 :     (* Return the n-character substring of s starting at position i.
335 :     * NOTE: we use words to check the right bound so as to avoid
336 :     * raising overflow.
337 :     *)
338 :     local
339 :     structure W = InlineT.DfltWord
340 :     in
341 :     fun substring (s, i, n) =
342 :     if ((i < 0) orelse (n < 0)
343 : jhr 3417 orelse W.<(W.fromInt(size s), W.+(W.fromInt i, W.fromInt n)))
344 : blume 573 then raise Core.Subscript
345 :     else PreString.unsafeSubstring (s, i, n)
346 :     end (* local *)
347 :    
348 :     fun "" ^ s = s
349 :     | s ^ "" = s
350 :     | x ^ y = PreString.concat2 (x, y)
351 :    
352 :     end (* local *)
353 :    
354 :     (* Substring *)
355 :     type substring = Substring.substring
356 :    
357 :     (* I/O *)
358 :     val print = PrintHook.print
359 :    
360 :     (* simple interface to compiler *)
361 :     val use = UseHook.use
362 :    
363 :     (* getting info about exceptions *)
364 :     val exnName = ExnInfoHook.exnName
365 :     val exnMessage = ExnInfoHook.exnMessage
366 :    
367 :     end (* local *)
368 : blume 592
369 :     (* Bind structure _Core. We use the symbol "xCore", but after parsing
370 :     * is done this will be re-written to "_Core" by the bootstrap compilation
371 :     * machinery. See file init.cmi for more details. *)
372 :     structure xCore = Core

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0