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

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