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

SCM Repository

[smlnj] View of /sml/trunk/src/system/smlnj/init/core-int64.sml
ViewVC logotype

View of /sml/trunk/src/system/smlnj/init/core-int64.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1687 - (download) (annotate)
Fri Nov 12 06:31:53 2004 UTC (14 years, 8 months ago) by mblume
File size: 2947 byte(s)
added full implementation of Int64
(* core-int64.sml
 *
 *   Basic (simulated) 64-bit integer support.
 *
 * Copyright (c) 2004 by The Fellowship of SML/NJ
 *
 * Author: Matthias Blume (blume@tti-c.org)
 *)
structure CoreInt64 = struct

  local
      structure CII = CoreIntInf

      infix o val op o = InLine.compose
      val not = InLine.inlnot
      infix 7 * val op * = InLine.w32mul
      infix 6 + - val op + = InLine.w32add val op - = InLine.w32sub
      infix 5 << >> val op << = InLine.w32lshift val op >> = InLine.w32rshiftl
      infix 5 & val op & = InLine.w32andb
      infix 4 < val op < = InLine.w32lt
      infix 4 <> val op <> = InLine.w32ne
      infix 4 == val op == = InLine.w32eq
      val ~ = InLine.w32neg
      val ^ = InLine.w32notb

      fun lift1' f = f o InLine.i64p
      fun lift1 f = InLine.p64i o lift1' f
      fun lift2' f (x, y) = f (InLine.i64p x, InLine.i64p y)
      fun lift2 f = InLine.p64i o lift2' f

      fun neg64 (0wx80000000, 0w0) = raise Assembly.Overflow
	| neg64 (hi, 0w0) = (~hi, 0w0)
	| neg64 (hi, lo) = (^hi, ~lo)

      fun negbit hi = hi & 0wx80000000
      fun isneg hi = negbit hi <> 0w0

      fun add64 ((hi1, lo1), (hi2, lo2)) =
	  let val (hi, lo) = (hi1 + hi2, lo1 + lo2)
	      val hi = if lo < lo1 then hi + 0w1 else hi
	      val nb1 = negbit hi1
	  in if nb1 <> negbit hi2 orelse nb1 == negbit hi then (hi, lo)
	     else raise Assembly.Overflow
	  end

      fun sub64 ((hi1, lo1), (hi2, lo2)) =
	  let val (hi, lo) = (hi1 - hi2, lo1 - lo2)
	      val hi = if lo1 < lo then hi - 0w1 else hi
	      val nb1 = negbit hi1
	  in if nb1 == negbit hi2 orelse nb1 == negbit hi then (hi, lo)
	     else raise Assembly.Overflow
	  end

      (* I am definitely too lazy to do this the pedestrian way, so
       * here we go... *)
      fun mul64 (x, y) =
	  CII.testInf64 (CII.* (CII.extendInf64 x, CII.extendInf64 y))

      fun div64 (_, (0w0, 0w0)) = raise Assembly.Div
	| div64 (x, (0w0, 0w1)) = x
	| div64 (x, (0wxffffffff, 0wxffffffff)) = neg64 x
	| div64 (x, y) =
	    (* again, the easy way out... *)
	    CII.truncInf64 (CII.div (CII.extendInf64 x, CII.extendInf64 y))

      fun mod64 (x, y) = sub64 (x, mul64 (div64 (x, y), y))

      fun swap (x, y) = (y, x)

      fun lt64 ((hi1, lo1), (hi2, lo2)) =
	  let fun normal () = hi1 < hi2 orelse (hi1 == hi2 andalso lo1 < lo2)
	  in if isneg hi1 then
		 if isneg hi2 then normal () else true
	     else normal ()
	  end
      val gt64 = lt64 o swap
      val le64 = not o gt64
      val ge64 = not o lt64

      fun abs64 (hi, lo) = if isneg hi then neg64 (hi, lo) else (hi, lo)
  in
      val extern = InLine.i64p
      val intern = InLine.p64i

      val ~ = lift1 neg64
      val op + = lift2 add64
      val op - = lift2 sub64
      val op * = lift2 mul64
      val div = lift2 div64
      val mod = lift2 mod64
      val op < = lift2' lt64
      val <= = lift2' le64
      val > = lift2' gt64
      val >= = lift2' ge64
      val abs = lift1 abs64
  end
end

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