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

SCM Repository

[smlnj] Diff of /sml/trunk/system/smlnj/init/pervasive.sml
ViewVC logotype

Diff of /sml/trunk/system/smlnj/init/pervasive.sml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 3416, Thu Jul 9 16:14:26 2009 UTC revision 3417, Thu Jul 9 16:19:33 2009 UTC
# Line 1  Line 1 
1  (* (C) 1999 Lucent Technologies, Bell Laboratories *)  (* pervasive.sml
2     *
3     * COPYRIGHT (c) 2009 The Fellowship of SML/NJ (http://www.smlnj.org)
4     * 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    
14  infix 7  * / mod div  infix 7  * / mod div
15  infix 6 ^ + -  infix 6 ^ + -
# Line 134  Line 144 
144   * val isSome   * val isSome
145   * val valOf   * val valOf
146   * val op =   * val op =
147   * val op <> *)   * val op <>
148     *)
149  open PrePervasive  open PrePervasive
150    
151  val ! = InlineT.!  val ! = InlineT.!
# Line 150  Line 161 
161    
162  (* top-level value identifiers *)  (* top-level value identifiers *)
163    
 fun vector l = let  
     fun len ([], n) = n  
       | len ([_], n) = n+1  
       | len (_::_::r, n) = len(r, n+2)  
     val n = len (l, 0)  
 in  
     if DI.ltu (Core.max_length, n) then raise Size  
     else if (n = 0) then  
         Assembly.vector0  
     else  
         Assembly.A.create_v(n, l)  
 end  
   
   
164  (* Bool *)  (* Bool *)
165  val not = InlineT.inlnot  val not = InlineT.inlnot
166    
# Line 174  Line 171 
171  type word = PrimTypes.word  type word = PrimTypes.word
172    
173  (* Real *)  (* Real *)
174    local
175      val w31_r = R64.from_int32 o I32.copy_word31
176      val intbound = w31_r 0wx40000000      (* not necessarily the same as rbase *)
177      val negintbound = R64.~ intbound
178    in
179  type real = PrimTypes.real  type real = PrimTypes.real
180    
181  val real = InlineT.Real64.from_int31  val real = R64.from_int31
182    
183  fun floor x =  fun floor x =
184      if R64.< (x, 1073741824.0) andalso R64.>= (x, ~1073741824.0) then        if x < intbound andalso x >= negintbound then Assembly.A.floor x
         Assembly.A.floor x  
185      else if R64.== (x, x) then raise Overflow (* not a NaN *)      else if R64.== (x, x) then raise Overflow (* not a NaN *)
186      else raise Domain                   (* NaN *)        else raise Domain
187    
188  fun ceil x = DI.- (~1, floor (R64.~ (x + 1.0)))  fun ceil x = DI.- (~1, floor (R64.~ (x + 1.0)))
189    
190  fun trunc x = if R64.< (x, 0.0) then ceil x else floor x  fun trunc x = if R64.< (x, 0.0) then ceil x else floor x
191  fun round x = floor (x + 0.5)           (* bug: does not round-to-nearest *)  
192    fun round x = let
193        (* ties go to the nearest even number *)
194          val fl = floor(x+0.5)
195          val cl = ceil(x-0.5)
196          in
197            if fl=cl then fl
198            else if W31.andb(W31.fromInt fl,0w1) = 0w1 then cl
199            else fl
200          end
201    
202    end (* local *)
203    
204  (* List *)  (* List *)
205  exception Empty  exception Empty
# Line 201  Line 216 
216      f2 (l, b)      f2 (l, b)
217  end  end
218  fun length l = let  fun length l = let
219        (* fast add that avoids the overflow test *)
220          fun a + b = W31.copyt_int31 (W31.+(W31.copyf_int31 a, W31.copyf_int31 b))
221      fun loop (n, []) = n      fun loop (n, []) = n
222        | loop (n, _ :: l) = loop (n + 1, l)          | loop (n, [_]) = n + 1
223            | loop (n, _ :: _ :: l) = loop (n + 2, l)
224  in  in
225      loop (0, l)      loop (0, l)
226  end  end
227  fun rev l = foldl (op ::) [] l  fun rev l = let
228          fun loop ([], l) = l
229            | loop (x::xs, l) = loop(xs, x::l)
230          in
231            loop (l, [])
232          end
233  fun foldr f b = let  fun foldr f b = let
234      fun f2 [] = b      fun f2 [] = b
235        | f2 (a :: r) = f (a, f2 r)        | f2 (a :: r) = f (a, f2 r)
# Line 236  Line 259 
259  (* Vector *)  (* Vector *)
260  type 'a vector = 'a PrimTypes.vector  type 'a vector = 'a PrimTypes.vector
261    
262    fun vector l = let
263          val n = length l
264          in
265            if DI.ltu (Core.max_length, n) then raise Size
266            else if (n = 0) then Assembly.vector0
267            else Assembly.A.create_v(n, l)
268          end
269    
270  (* Char *)  (* Char *)
271  type char = PrimTypes.char  type char = PrimTypes.char
272  val ord = InlineT.Char.ord  val ord = InlineT.Char.ord
# Line 257  Line 288 
288  fun str (c: char) : string = PV.sub (PreString.chars, InlineT.cast c)  fun str (c: char) : string = PV.sub (PreString.chars, InlineT.cast c)
289    
290  (* concatenate a list of strings together *)  (* concatenate a list of strings together *)
291  fun concat [s] = s  fun concat [] = ""
292      | concat [s] = s
293    | concat (sl : string list) = let    | concat (sl : string list) = let
294        (* compute total length of result string *)
295          fun length (i, []) = i          fun length (i, []) = i
296            | length (i, s::rest) = length(i+size s, rest)            | length (i, s::rest) = length(i+size s, rest)
297      in      in
298          case length (0, sl) of          case length (0, sl)
299              0 => ""           of 0 => ""
300            | 1 => let            | 1 => let
301                  fun find ("" :: r) = find r                  fun find ("" :: r) = find r
302                    | find (s :: _) = s                    | find (s :: _) = s
# Line 288  Line 321 
321                  copy (sl, 0);                  copy (sl, 0);
322                  ss                  ss
323              end              end
324            (* end case *)
325      end (* concat *)      end (* concat *)
326    
327    
328  (* implode a list of characters into a string *)  (* implode a list of characters into a string *)
329  fun implode [] = ""  fun implode [] = ""
330    | implode cl =  let    | implode cl = PreString.implode (length cl, cl)
         fun length ([], n) = n  
           | length (_::r, n) = length (r, n+1)  
     in  
         PreString.implode (length (cl, 0), cl)  
     end  
331    
332  (* explode a string into a list of characters *)  (* explode a string into a list of characters *)
333  fun explode s = let  fun explode s = let
334      fun f(l, ~1) = l      fun f(l, ~1) = l
335        | f(l,  i) = f (unsafeSub(s, i) :: l, i-1)        | f(l,  i) = f (unsafeSub(s, i) :: l, i-1)
336  in  in
337      f (nil, size s - 1)          f ([], size s - 1)
338  end  end
339    
340  (* Return the n-character substring of s starting at position i.  (* Return the n-character substring of s starting at position i.

Legend:
Removed from v.3416  
changed lines
  Added in v.3417

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