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/smlnj/init/pervasive.sml
ViewVC logotype

Annotation of /sml/trunk/src/system/smlnj/init/pervasive.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1446 - (view) (download)

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

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