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 1686 - (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 : mblume 1683 structure CW64 = CoreWord64
24 : mblume 1686 structure CI64 = CoreInt64
25 : blume 573 structure R64 = InlineT.Real64
26 :     structure CV = InlineT.CharVector
27 :     structure PV = InlineT.PolyVector
28 :     structure DI = InlineT.DfltInt
29 :    
30 : mblume 1347 structure CII = CoreIntInf
31 :    
32 : blume 573 fun w8adapt oper args = W8.andb (oper args, 0wxFF)
33 :     val w8plus = w8adapt W8.+
34 :     val w8minus = w8adapt W8.-
35 :     val w8times = w8adapt W8.*
36 : mblume 1683 val w8neg = w8adapt W8.~
37 : blume 573
38 :     fun stringlt (a, b) = let
39 :     val al = CV.length a
40 :     val bl = CV.length b
41 :     val ashort = DI.< (al, bl)
42 :     val n = if ashort then al else bl
43 :     fun cmp i =
44 :     if InlineT.= (i, n) then ashort
45 :     else let
46 :     val ai = CV.sub (a, i)
47 :     val bi = CV.sub (b, i)
48 :     in
49 :     InlineT.Char.< (ai, bi) orelse
50 :     (InlineT.= (ai, bi) andalso cmp (DI.+ (i, 1)))
51 :     end
52 :     in
53 :     cmp 0
54 :     end
55 :     fun stringle (a, b) = if stringlt (b, a) then false else true
56 :     fun stringgt (a, b) = stringlt (b, a)
57 :     fun stringge (a, b) = stringle (b, a)
58 :     in
59 :     overload ~ : ('a -> 'a)
60 : mblume 1686 as I31.~ and I32.~ and CI64.~ and CII.~
61 : mblume 1683 and w8neg and W31.~ and W32.~ and CW64.~
62 :     and R64.~
63 : blume 573 overload + : ('a * 'a -> 'a)
64 : mblume 1686 as I31.+ and I32.+ and CI64.+ and CII.+
65 : mblume 1683 and w8plus and W31.+ and W32.+ and CW64.+
66 :     and R64.+
67 : blume 573 overload - : ('a * 'a -> 'a)
68 : mblume 1686 as I31.- and I32.- and CI64.- and CII.-
69 : mblume 1683 and w8minus and W31.- and W32.- and CW64.-
70 :     and R64.-
71 : blume 573 overload * : ('a * 'a -> 'a)
72 : mblume 1686 as I31.* and I32.* and CI64.* and CII.*
73 : mblume 1683 and w8times and W31.* and W32.* and CW64.*
74 :     and R64.*
75 : blume 573 overload / : ('a * 'a -> 'a)
76 :     as R64./
77 :     overload div : ('a * 'a -> 'a)
78 : mblume 1686 as I31.div and I32.div and CI64.div and CII.div
79 : mblume 1683 and W8.div and W31.div and W32.div and CW64.div
80 : blume 573 overload mod : ('a * 'a -> 'a)
81 : mblume 1686 as I31.mod and I32.mod and CI64.mod and CII.mod
82 : mblume 1683 and W8.mod and W31.mod and W32.mod and CW64.mod
83 : blume 573 overload < : ('a * 'a -> bool)
84 : mblume 1686 as I31.< and I32.< and CI64.< and CII.<
85 : mblume 1683 and W8.< and W31.< and W32.< and CW64.<
86 :     and R64.<
87 : blume 573 and InlineT.Char.<
88 :     and stringlt
89 :     overload <= : ('a * 'a -> bool)
90 : mblume 1686 as I31.<= and I32.<= and CI64.<= and CII.<=
91 : mblume 1683 and W8.<= and W31.<= and W32.<= and CW64.<=
92 :     and R64.<=
93 : blume 573 and InlineT.Char.<=
94 :     and stringle
95 :     overload > : ('a * 'a -> bool)
96 : mblume 1686 as I31.> and I32.> and CI64.> and CII.>
97 : mblume 1683 and W8.> and W31.> and W32.> and CW64.>
98 :     and R64.>
99 : blume 573 and InlineT.Char.>
100 :     and stringgt
101 :     overload >= : ('a * 'a -> bool)
102 : mblume 1686 as I31.>= and I32.>= and CI64.>= and CII.>=
103 : mblume 1683 and W8.>= and W31.>= and W32.>= and CW64.>=
104 :     and R64.>=
105 : blume 573 and InlineT.Char.>=
106 :     and stringge
107 :     overload abs : ('a -> 'a)
108 : mblume 1686 as I31.abs and I32.abs and CI64.abs and CII.abs and R64.abs
109 : blume 573
110 :     type unit = PrimTypes.unit
111 :     type exn = PrimTypes.exn
112 :    
113 :     exception Bind = Core.Bind
114 :     exception Match = Core.Match
115 :     exception Subscript = Core.Subscript
116 :     exception Size = Core.Size
117 :     exception Overflow = Assembly.Overflow
118 :     exception Chr = InlineT.Char.Chr
119 :     exception Div = Assembly.Div
120 :     exception Domain
121 :    
122 :     type string = PrimTypes.string
123 :    
124 :     exception Fail of string
125 :    
126 :     (* exception Span
127 :     * datatype order
128 :     * datatype option
129 :     * exception Option
130 :     * val getOpt
131 :     * val isSome
132 :     * val valOf
133 :     * val op =
134 :     * val op <> *)
135 :     open PrePervasive
136 :    
137 :     val ! = InlineT.!
138 :     val op := = InlineT.:=
139 :    
140 :     val op before : ('a * unit) -> 'a = InlineT.before
141 : blume 1183 val ignore : 'a -> unit = InlineT.ignore
142 : blume 573
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 : mblume 1381 val real = InlineT.Real64.from_int31
177 : blume 573 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 : mblume 1446 | a2 (h :: t) = (f h : unit; a2 t)
217 : blume 573 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 *)
342 : blume 592
343 :     (* Bind structure _Core. We use the symbol "xCore", but after parsing
344 :     * is done this will be re-written to "_Core" by the bootstrap compilation
345 :     * machinery. See file init.cmi for more details. *)
346 :     structure xCore = Core

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