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/trunk/src/system/Init/pervasive.sml
ViewVC logotype

Annotation of /sml/trunk/src/system/Init/pervasive.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 416 - (view) (download)

1 : monnier 416 (* (C) 1999 Lucent Technologies, Bell Laboratories *)
2 :    
3 :    
4 :     infix 7 * / mod div
5 :     infix 6 ^ + -
6 :     infix 3 := o
7 :     infix 4 > < >= <= = <>
8 :     infixr 5 :: @
9 :     infix 0 before
10 :    
11 :     local
12 :     structure I31 = InlineT.Int31
13 :     structure I32 = InlineT.Int32
14 :     structure W8 = InlineT.Word8
15 :     structure W31 = InlineT.Word31
16 :     structure W32 = InlineT.Word32
17 :     structure R64 = InlineT.Real64
18 :     structure CV = InlineT.CharVector
19 :     structure PV = InlineT.PolyVector
20 :     structure DI = InlineT.DfltInt
21 :    
22 :     fun w8adapt oper args = W8.andb (oper args, 0wxFF)
23 :     val w8plus = w8adapt W8.+
24 :     val w8minus = w8adapt W8.-
25 :     val w8times = w8adapt W8.*
26 :    
27 :     fun i32div (a, b) =
28 :     if I32.>= (b, 0) then
29 :     if I32.>= (a, 0) then I32.quot (a, b)
30 :     else I32.- (I32.quot (I32.+ (a, 1), b), 1)
31 :     else if I32.>(a,0) then
32 :     I32.- (I32.quot (I32.- (a, 1), b), 1)
33 :     else I32.quot(a, b)
34 :    
35 :     fun i32mod (a, b) =
36 :     if I32.>= (b, 0) then
37 :     if I32.>= (a, 0) then
38 :     I32.- (a, I32.* (I32.quot (a, b), b))
39 :     else I32.+ (I32.- (a, I32.* (I32.quot (I32.+ (a,1), b), b)), b)
40 :     else if I32.> (a, 0) then
41 :     I32.+ (I32.- (a, I32.* (I32.quot (I32.- (a, 1), b), b)), b)
42 :     else if I32.= (a, ~2147483648) andalso I32.=(b, ~1) then 0
43 :     else I32.- (a, I32.* (I32.quot (a, b), b))
44 :    
45 :     fun w8mod (a, b) = w8minus (a, w8times (W8.div (a, b), b))
46 :     fun w31mod (a, b) = W31.- (a, W31.* (W31.div (a, b), b))
47 :     fun w32mod (a, b) = W32.- (a, W32.* (W32.div (a, b), b))
48 :    
49 :     fun stringlt (a, b) = let
50 :     val al = CV.length a
51 :     val bl = CV.length b
52 :     val ashort = DI.< (al, bl)
53 :     val n = if ashort then al else bl
54 :     fun cmp i =
55 :     if InlineT.= (i, n) then ashort
56 :     else let
57 :     val ai = CV.sub (a, i)
58 :     val bi = CV.sub (b, i)
59 :     in
60 :     InlineT.Char.< (ai, bi) orelse
61 :     (InlineT.= (ai, bi) andalso cmp (DI.+ (i, 1)))
62 :     end
63 :     in
64 :     cmp 0
65 :     end
66 :     fun stringle (a, b) = if stringlt (b, a) then false else true
67 :     fun stringgt (a, b) = stringlt (b, a)
68 :     fun stringge (a, b) = stringle (b, a)
69 :    
70 :     fun i32abs a = if I32.< (a, 0) then I32.~ a else a
71 :     in
72 :     overload ~ : ('a -> 'a)
73 :     as I31.~ and I32.~ and R64.~
74 :     overload + : ('a * 'a -> 'a)
75 :     as I31.+ and I32.+ and w8plus and W31.+ and W32.+ and R64.+
76 :     overload - : ('a * 'a -> 'a)
77 :     as I31.- and I32.- and w8minus and W31.- and W32.- and R64.-
78 :     overload * : ('a * 'a -> 'a)
79 :     as I31.* and I32.* and w8times and W31.* and W32.* and R64.*
80 :     overload / : ('a * 'a -> 'a)
81 :     as R64./
82 :     overload div : ('a * 'a -> 'a)
83 :     as I31.div and i32div and W8.div and W31.div and W32.div
84 :     overload mod : ('a * 'a -> 'a)
85 :     as I31.mod and i32mod and w8mod and w31mod and w32mod
86 :     overload < : ('a * 'a -> bool)
87 :     as I31.< and I32.< and W8.< and W31.< and W32.< and R64.<
88 :     and InlineT.Char.<
89 :     and stringlt
90 :     overload <= : ('a * 'a -> bool)
91 :     as I31.<= and I32.<= and W8.<= and W31.<= and W32.<= and R64.<=
92 :     and InlineT.Char.<=
93 :     and stringle
94 :     overload > : ('a * 'a -> bool)
95 :     as I31.> and I32.> and W8.> and W31.> and W32.> and R64.>
96 :     and InlineT.Char.>
97 :     and stringgt
98 :     overload >= : ('a * 'a -> bool)
99 :     as I31.>= and I32.>= and W8.>= and W31.>= and W32.>= and R64.>=
100 :     and InlineT.Char.>=
101 :     and stringge
102 :     overload abs : ('a -> 'a)
103 :     as I31.abs and i32abs and R64.abs
104 :    
105 :     type unit = PrimTypes.unit
106 :     type exn = PrimTypes.exn
107 :    
108 :     exception Bind = Core.Bind
109 :     exception Match = Core.Match
110 :     exception Subscript = Core.Subscript
111 :     exception Size = Core.Size
112 :     exception Overflow = Assembly.Overflow
113 :     exception Chr = InlineT.Char.Chr
114 :     exception Div = Assembly.Div
115 :     exception Domain
116 :    
117 :     exception Fail of string
118 :    
119 :     (* exception Span
120 :     * datatype order
121 :     * datatype option
122 :     * exception Option
123 :     * val getOpt
124 :     * val isSome
125 :     * val valOf
126 :     * val op =
127 :     * val op <> *)
128 :     open PrePervasive
129 :    
130 :     val ! = InlineT.!
131 :     val op := = InlineT.:=
132 :    
133 :     val op o : ('b -> 'c) * ('a -> 'b) -> ('a -> 'c) = InlineT.compose
134 :     val op before : ('a * unit) -> 'a = InlineT.before
135 :     fun ignore _ = ()
136 :    
137 :     (* top-level types *)
138 :    
139 :     datatype bool = datatype PrimTypes.bool
140 :     datatype list = datatype PrimTypes.list
141 :     datatype ref = datatype PrimTypes.ref
142 :    
143 :     (* top-level value identifiers *)
144 :    
145 :     fun vector l = let
146 :     fun len ([], n) = n
147 :     | len ([_], n) = n+1
148 :     | len (_::_::r, n) = len(r, n+2)
149 :     val n = len (l, 0)
150 :     in
151 :     if DI.ltu (Core.max_length, n) then raise Size
152 :     else if (n = 0) then
153 :     Assembly.vector0
154 :     else
155 :     Assembly.A.create_v(n, l)
156 :     end
157 :    
158 :    
159 :     (* Bool *)
160 :     val not = InlineT.inlnot
161 :    
162 :     (* Int *)
163 :     type int = PrimTypes.int
164 :    
165 :     (* Word *)
166 :     type word = PrimTypes.word
167 :    
168 :     (* Real *)
169 :     type real = PrimTypes.real
170 :    
171 :     val real = InlineT.real
172 :     fun floor x =
173 :     if R64.< (x, 1073741824.0) andalso R64.>= (x, ~1073741824.0) then
174 :     Assembly.A.floor x
175 :     else if R64.== (x, x) then raise Overflow (* not a NaN *)
176 :     else raise Domain (* NaN *)
177 :     fun ceil x = DI.- (~1, floor (R64.~ (x + 1.0)))
178 :     fun trunc x = if R64.< (x, 0.0) then ceil x else floor x
179 :     fun round x = floor (x + 0.5) (* bug: does not round-to-nearest *)
180 :    
181 :     (* List *)
182 :     exception Empty
183 :     fun null [] = true
184 :     | null _ = false
185 :     fun hd (h :: _) = h
186 :     | hd [] = raise Empty
187 :     fun tl (_ :: t) = t
188 :     | tl [] = raise Empty
189 :     fun foldl f b l = let
190 :     fun f2 ([], b) = b
191 :     | f2 (a :: r, b) = f2 (r, f (a, b))
192 :     in
193 :     f2 (l, b)
194 :     end
195 :     fun length l = let
196 :     fun loop (n, []) = n
197 :     | loop (n, _ :: l) = loop (n + 1, l)
198 :     in
199 :     loop (0, l)
200 :     end
201 :     fun rev l = foldl (op ::) [] l
202 :     fun foldr f b = let
203 :     fun f2 [] = b
204 :     | f2 (a :: r) = f (a, f2 r)
205 :     in
206 :     f2
207 :     end
208 :     fun l1 @ l2 = foldr (op ::) l2 l1
209 :     fun app f = let
210 :     fun a2 [] = ()
211 :     | a2 (h :: t) = (f h; a2 t)
212 :     in
213 :     a2
214 :     end
215 :     fun map f = let
216 :     fun m [] = []
217 :     | m [a] = [f a]
218 :     | m [a, b] = [f a, f b]
219 :     | m [a, b, c] = [f a, f b, f c]
220 :     | m (a :: b :: c :: d :: r) = f a :: f b :: f c :: f d :: m r
221 :     in
222 :     m
223 :     end
224 :    
225 :     (* Array *)
226 :     type 'a array = 'a PrimTypes.array
227 :    
228 :     (* Vector *)
229 :     type 'a vector = 'a PrimTypes.vector
230 :    
231 :     (* Char *)
232 :     type char = PrimTypes.char
233 :     val ord = InlineT.Char.ord
234 :     val chr = InlineT.Char.chr
235 :    
236 :     (* String *)
237 :     local
238 :     (* allocate an uninitialized string of given length *)
239 :     fun create n =
240 :     if (DI.ltu (Core.max_length, n)) then raise Size
241 :     else Assembly.A.create_s n
242 :    
243 :     val unsafeSub = CV.sub
244 :     val unsafeUpdate = CV.update
245 :     in
246 :    
247 :     type string = PrimTypes.string
248 :    
249 :     val size = CV.length : string -> int
250 :    
251 :     fun str (c: char) : string = PV.sub (PreString.chars, InlineT.cast c)
252 :    
253 :     (* concatenate a list of strings together *)
254 :     fun concat [s] = s
255 :     | concat (sl : string list) = let
256 :     fun length (i, []) = i
257 :     | length (i, s::rest) = length(i+size s, rest)
258 :     in
259 :     case length (0, sl) of
260 :     0 => ""
261 :     | 1 => let
262 :     fun find ("" :: r) = find r
263 :     | find (s :: _) = s
264 :     | find _ = "" (** impossible **)
265 :     in
266 :     find sl
267 :     end
268 :     | totLen => let
269 :     val ss = create totLen
270 :     fun copy ([], _) = ()
271 :     | copy (s::r, i) = let
272 :     val len = size s
273 :     fun copy' j =
274 :     if (j = len) then ()
275 :     else (unsafeUpdate(ss, i+j, unsafeSub(s, j));
276 :     copy'(j+1))
277 :     in
278 :     copy' 0;
279 :     copy (r, i+len)
280 :     end
281 :     in
282 :     copy (sl, 0);
283 :     ss
284 :     end
285 :     end (* concat *)
286 :    
287 :    
288 :     (* implode a list of characters into a string *)
289 :     fun implode [] = ""
290 :     | implode cl = let
291 :     fun length ([], n) = n
292 :     | length (_::r, n) = length (r, n+1)
293 :     in
294 :     PreString.implode (length (cl, 0), cl)
295 :     end
296 :    
297 :     (* explode a string into a list of characters *)
298 :     fun explode s = let
299 :     fun f(l, ~1) = l
300 :     | f(l, i) = f (unsafeSub(s, i) :: l, i-1)
301 :     in
302 :     f (nil, size s - 1)
303 :     end
304 :    
305 :     (* Return the n-character substring of s starting at position i.
306 :     * NOTE: we use words to check the right bound so as to avoid
307 :     * raising overflow.
308 :     *)
309 :     local
310 :     structure W = InlineT.DfltWord
311 :     in
312 :     fun substring (s, i, n) =
313 :     if ((i < 0) orelse (n < 0)
314 :     orelse W.<(W.fromInt(size s), W.+(W.fromInt i, W.fromInt n)))
315 :     then raise Core.Subscript
316 :     else PreString.unsafeSubstring (s, i, n)
317 :     end (* local *)
318 :    
319 :     fun "" ^ s = s
320 :     | s ^ "" = s
321 :     | x ^ y = PreString.concat2 (x, y)
322 :    
323 :     end (* local *)
324 :    
325 :     (* Substring *)
326 :     type substring = Substring.substring
327 :    
328 :     (* I/O *)
329 :     val print = PrintHook.print
330 :    
331 :     (* simple interface to compiler *)
332 :     val use = UseHook.use
333 :    
334 :     (* getting info about exceptions *)
335 :     val exnName = ExnInfoHook.exnName
336 :     val exnMessage = ExnInfoHook.exnMessage
337 :    
338 :     end (* local *)

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