Menu
▾
▴
mlton-commit — [MLton-commit] Code commits
You can subscribe to this list here.
| 2005 |
Jan
|
Feb
|
Mar
|
Apr
|
May
|
Jun
|
Jul
|
Aug
(56) |
Sep
(40) |
Oct
(30) |
Nov
(144) |
Dec
(23) |
|---|---|---|---|---|---|---|---|---|---|---|---|---|
| 2006 |
Jan
(41) |
Feb
(29) |
Mar
(31) |
Apr
(39) |
May
(193) |
Jun
(45) |
Jul
(19) |
Aug
(3) |
Sep
(23) |
Oct
(83) |
Nov
(92) |
Dec
(123) |
| 2007 |
Jan
(90) |
Feb
(267) |
Mar
(120) |
Apr
(51) |
May
(40) |
Jun
(121) |
Jul
(109) |
Aug
(173) |
Sep
(77) |
Oct
(52) |
Nov
(121) |
Dec
(62) |
| 2008 |
Jan
(76) |
Feb
(53) |
Mar
(98) |
Apr
(87) |
May
(26) |
Jun
(27) |
Jul
(23) |
Aug
(136) |
Sep
(79) |
Oct
(68) |
Nov
(29) |
Dec
(14) |
| 2009 |
Jan
(7) |
Feb
(2) |
Mar
(11) |
Apr
(75) |
May
(1) |
Jun
(95) |
Jul
(19) |
Aug
(4) |
Sep
(8) |
Oct
(93) |
Nov
(43) |
Dec
(21) |
| 2010 |
Jan
(20) |
Feb
(23) |
Mar
(18) |
Apr
(6) |
May
(20) |
Jun
(23) |
Jul
(1) |
Aug
|
Sep
|
Oct
|
Nov
|
Dec
|
| 2011 |
Jan
(2) |
Feb
(6) |
Mar
(15) |
Apr
(5) |
May
(9) |
Jun
(14) |
Jul
(9) |
Aug
|
Sep
|
Oct
|
Nov
|
Dec
|
| 2012 |
Jan
|
Feb
(3) |
Mar
|
Apr
|
May
(2) |
Jun
(17) |
Jul
(37) |
Aug
|
Sep
(1) |
Oct
(6) |
Nov
|
Dec
|
| 2013 |
Jan
|
Feb
|
Mar
(5) |
Apr
(2) |
May
(7) |
Jun
(11) |
Jul
(8) |
Aug
|
Sep
(1) |
Oct
(2) |
Nov
|
Dec
|
| 2014 |
Jan
|
Feb
(2) |
Mar
(1) |
Apr
|
May
(1) |
Jun
(1) |
Jul
(7) |
Aug
(2) |
Sep
|
Oct
(5) |
Nov
(2) |
Dec
(4) |
| 2015 |
Jan
|
Feb
(2) |
Mar
(2) |
Apr
|
May
|
Jun
(9) |
Jul
(1) |
Aug
|
Sep
|
Oct
(4) |
Nov
(1) |
Dec
|
| 2016 |
Jan
(2) |
Feb
(1) |
Mar
(1) |
Apr
(1) |
May
(1) |
Jun
(2) |
Jul
(1) |
Aug
|
Sep
(5) |
Oct
|
Nov
|
Dec
|
| 2017 |
Jan
(1) |
Feb
(3) |
Mar
(3) |
Apr
(7) |
May
(2) |
Jun
(2) |
Jul
(5) |
Aug
(1) |
Sep
(2) |
Oct
(17) |
Nov
(4) |
Dec
(7) |
| 2018 |
Jan
(5) |
Feb
(14) |
Mar
(2) |
Apr
(5) |
May
(2) |
Jun
(5) |
Jul
|
Aug
(2) |
Sep
|
Oct
(3) |
Nov
(5) |
Dec
|
| 2019 |
Jan
(4) |
Feb
(2) |
Mar
(3) |
Apr
(1) |
May
(8) |
Jun
(14) |
Jul
(2) |
Aug
|
Sep
(2) |
Oct
(2) |
Nov
(15) |
Dec
(2) |
| 2020 |
Jan
(10) |
Feb
(3) |
Mar
(1) |
Apr
|
May
(9) |
Jun
(4) |
Jul
(16) |
Aug
(10) |
Sep
(4) |
Oct
(3) |
Nov
|
Dec
|
| 2021 |
Jan
(11) |
Feb
(2) |
Mar
(2) |
Apr
|
May
|
Jun
(1) |
Jul
|
Aug
(5) |
Sep
|
Oct
(6) |
Nov
(4) |
Dec
(4) |
| 2022 |
Jan
(4) |
Feb
(2) |
Mar
(2) |
Apr
|
May
(6) |
Jun
(3) |
Jul
|
Aug
(1) |
Sep
|
Oct
|
Nov
(1) |
Dec
|
| 2023 |
Jan
|
Feb
|
Mar
|
Apr
(2) |
May
(5) |
Jun
(1) |
Jul
(4) |
Aug
(1) |
Sep
|
Oct
(1) |
Nov
(13) |
Dec
|
| 2024 |
Jan
(1) |
Feb
|
Mar
(5) |
Apr
|
May
(10) |
Jun
|
Jul
|
Aug
(3) |
Sep
|
Oct
|
Nov
(1) |
Dec
(14) |
| 2025 |
Jan
(3) |
Feb
|
Mar
(1) |
Apr
|
May
(2) |
Jun
(3) |
Jul
|
Aug
|
Sep
|
Oct
|
Nov
|
Dec
|
|
From: Matthew F. <fl...@ml...> - 2006-04-24 19:41:23
|
Mostly refactored real; some work left on C-side
----------------------------------------------------------------------
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/Makefile
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/build/sources.mlb
A mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/int-inf-prim.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/int-inf-top.sml
D mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/intinf-prim.sml
D mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/intinf-top.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/c/sys-word.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/default/default-int-inf.sml
D mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/default/default-intinf.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/word.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/maps/default-int-inf.map
D mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/maps/default-intinf.map
D mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/misc/
A mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-int-inf.sml
D mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-intinf.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-mlton.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-nullstring.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/primitive.mlb
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/primitive.sml
D mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real.fun
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real.sig
A mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real.sml
D mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real0.sml
D mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real32.sml
D mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real64.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/test/Makefile
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/test/test.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/util/CUtil.sig
A mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/util/CUtil.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/util/dynamic-wind.sig
----------------------------------------------------------------------
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/Makefile
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/Makefile 2006-04-24 21:45:47 UTC (rev 4407)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/Makefile 2006-04-25 02:41:19 UTC (rev 4408)
@@ -25,7 +25,7 @@
SEQ_INDEX_MAPS = seqindex-int32.map seqindex-int64.map
CTYPES_MAPS = c-types.m32.map c-types.m64.map c-types.weird.map
DEFAULT_CHAR_MAPS = default-char8.map
-DEFAULT_INT_MAPS = default-int32.map default-int64.map default-intinf.map
+DEFAULT_INT_MAPS = default-int32.map default-int64.map default-int-inf.map
DEFAULT_REAL_MAPS = default-real32.map default-real64.map
DEFAULT_WORD_MAPS = default-word32.map default-word64.map
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/build/sources.mlb
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/build/sources.mlb 2006-04-24 21:45:47 UTC (rev 4407)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/build/sources.mlb 2006-04-25 02:41:19 UTC (rev 4408)
@@ -34,7 +34,7 @@
local
local
../config/bind/int-prim.sml
- ../config/bind/intinf-prim.sml
+ ../config/bind/int-inf-prim.sml
../config/bind/word-prim.sml
in ann "forceUsed" in
../config/default/$(DEFAULT_INT)
@@ -50,7 +50,7 @@
local
../config/bind/char-prim.sml
../config/bind/int-prim.sml
- ../config/bind/intinf-prim.sml
+ ../config/bind/int-inf-prim.sml
../config/bind/real-prim.sml
../config/bind/string-prim.sml
../config/bind/word-prim.sml
@@ -122,7 +122,7 @@
../integer/int-inf.sml
local
../config/bind/int-top.sml
- ../config/bind/intinf-top.sml
+ ../config/bind/int-inf-top.sml
../config/bind/word-top.sml
in ann "forceUsed" in
../config/default/$(DEFAULT_INT)
@@ -139,6 +139,14 @@
../integer/embed-word.sml
../integer/pack-word.sig
(* ../integer/pack-word32.sml *)
+ local
+ ../config/bind/int-top.sml
+ ../config/bind/pointer-prim.sml
+ ../config/bind/real-prim.sml
+ ../config/bind/word-top.sml
+ in ann "forceUsed" in
+ ../config/c/misc/$(CTYPES)
+ end end
../text/char.sig
../text/char.sml
@@ -154,25 +162,24 @@
../text/text.sig
../text/text.sml
+ ../text/nullstring.sml
+ ../util/CUtil.sig
+ ../util/CUtil.sml
+
../real/IEEE-real.sig
../real/IEEE-real.sml
- (* ../../misc/C.sig *)
- (* ../../misc/C.sml *)
../real/math.sig
../real/real.sig
- ../real/real.fun
+ ../real/real.sml
../real/pack-real.sig
(* ../real/pack-real.sml *)
- (* ../real/real32.sml *)
- (* ../real/real64.sml *)
local
../config/bind/real-top.sml
in ann "forceUsed" in
../config/default/$(DEFAULT_REAL)
../config/default/large-real.sml
end end
-
-(*
+ ../real/real-global.sml
local
../config/bind/int-top.sml
../config/bind/pointer-prim.sml
@@ -183,7 +190,6 @@
../config/c/position.sml
../config/c/sys-word.sml
end end
-*)
../util/unique-id.sig
../util/unique-id.fun
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/int-inf-prim.sml (from rev 4407, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/intinf-prim.sml)
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/int-inf-top.sml (from rev 4407, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/intinf-top.sml)
Deleted: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/intinf-prim.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/intinf-prim.sml 2006-04-24 21:45:47 UTC (rev 4407)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/intinf-prim.sml 2006-04-25 02:41:19 UTC (rev 4408)
@@ -1,8 +0,0 @@
-(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
- * Jagannathan, and Stephen Weeks.
- *
- * MLton is released under a BSD-style license.
- * See the file MLton-LICENSE for details.
- *)
-
-structure IntInf = Primitive.IntInf
Deleted: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/intinf-top.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/intinf-top.sml 2006-04-24 21:45:47 UTC (rev 4407)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/bind/intinf-top.sml 2006-04-25 02:41:19 UTC (rev 4408)
@@ -1,8 +0,0 @@
-(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
- * Jagannathan, and Stephen Weeks.
- *
- * MLton is released under a BSD-style license.
- * See the file MLton-LICENSE for details.
- *)
-
-structure IntInf = IntInf
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/c/sys-word.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/c/sys-word.sml 2006-04-24 21:45:47 UTC (rev 4407)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/c/sys-word.sml 2006-04-25 02:41:19 UTC (rev 4408)
@@ -7,6 +7,6 @@
structure SysWord = C_UIntmax
-functor SysWord_ChooseWordN (A: CHOOSE_WORD_ARG) :
+functor SysWord_ChooseWordN (A: CHOOSE_WORDN_ARG) :
sig val f : SysWord.word A.t end =
C_UIntmax_ChooseWordN (A)
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/default/default-int-inf.sml (from rev 4407, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/default/default-intinf.sml)
Deleted: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/default/default-intinf.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/default/default-intinf.sml 2006-04-24 21:45:47 UTC (rev 4407)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/default/default-intinf.sml 2006-04-25 02:41:19 UTC (rev 4408)
@@ -1,13 +0,0 @@
-(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
- * Jagannathan, and Stephen Weeks.
- *
- * MLton is released under a BSD-style license.
- * See the file MLton-LICENSE for details.
- *)
-
-structure Int = IntInf
-type int = Int.int
-
-functor Int_ChooseInt (A: CHOOSE_INT_ARG) :
- sig val f : Int.int A.t end =
- ChooseInt_IntInf (A)
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/word.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/word.sml 2006-04-24 21:45:47 UTC (rev 4407)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/word.sml 2006-04-25 02:41:19 UTC (rev 4408)
@@ -29,6 +29,35 @@
fun rol (w, n) = W.rol (w, Primitive.Word32.fromWord n)
fun ror (w, n) = W.ror (w, Primitive.Word32.fromWord n)
+local
+ (* Allocate a buffer large enough to hold any formatted word in any radix.
+ * The most that will be required is for maxWord in binary.
+ *)
+ val maxNumDigits = wordSize
+ val oneBuf = One.make (fn () => CharArray.array (maxNumDigits, #"\000"))
+in
+ fun fmt radix (w: word): string =
+ One.use
+ (oneBuf, fn buf =>
+ let
+ val radix = fromInt (StringCvt.radixToInt radix)
+ fun loop (q, i: Int.int) =
+ let
+ val _ =
+ CharArray.update
+ (buf, i, StringCvt.digitToChar (toInt (q mod radix)))
+ val q = q div radix
+ in
+ if q = zero
+ then CharArraySlice.vector
+ (CharArraySlice.slice (buf, i, NONE))
+ else loop (q, Int.- (i, 1))
+ end
+ in
+ loop (w, Int.- (maxNumDigits, 1))
+ end)
+end
+
fun fmt radix (w: word): string =
let val radix = fromInt (StringCvt.radixToInt radix)
fun loop (q, chars) =
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/maps/default-int-inf.map (from rev 4407, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/maps/default-intinf.map)
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/maps/default-intinf.map 2006-04-24 21:45:47 UTC (rev 4407)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/maps/default-int-inf.map 2006-04-25 02:41:19 UTC (rev 4408)
@@ -0,0 +1 @@
+DEFAULT_INT default-int-inf.sml
Deleted: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/maps/default-intinf.map
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/maps/default-intinf.map 2006-04-24 21:45:47 UTC (rev 4407)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/maps/default-intinf.map 2006-04-25 02:41:19 UTC (rev 4408)
@@ -1 +0,0 @@
-DEFAULT_INT default-intinf.sml
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-int-inf.sml (from rev 4407, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-intinf.sml)
Deleted: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-intinf.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-intinf.sml 2006-04-24 21:45:47 UTC (rev 4407)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-intinf.sml 2006-04-25 02:41:19 UTC (rev 4408)
@@ -1,41 +0,0 @@
-(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
- * Jagannathan, and Stephen Weeks.
- * Copyright (C) 1997-2000 NEC Research Institute.
- *
- * MLton is released under a BSD-style license.
- * See the file MLton-LICENSE for details.
- *)
-
-(* Primitive names are special -- see atoms/prim.fun. *)
-
-structure Primitive = struct
-
-open Primitive
-
-structure IntInf =
- struct
- open IntInf
-
- val + = _prim "IntInf_add": int * int * C_Size.t -> int;
- val andb = _prim "IntInf_andb": int * int * C_Size.t -> int;
- val ~>> = _prim "IntInf_arshift": int * Word32.word * C_Size.t -> int;
- val compare = _prim "IntInf_compare": int * int -> Int32.int;
- val fromVector = _prim "WordVector_toIntInf": C_MPLimb.t vector -> int;
- val fromWord = _prim "Word_toIntInf": ObjptrWord.word -> int;
- val gcd = _prim "IntInf_gcd": int * int * C_Size.t -> int;
- val << = _prim "IntInf_lshift": int * Word32.word * C_Size.t -> int;
- val * = _prim "IntInf_mul": int * int * C_Size.t -> int;
- val ~ = _prim "IntInf_neg": int * C_Size.t -> int;
- val notb = _prim "IntInf_notb": int * C_Size.t -> int;
- val orb = _prim "IntInf_orb": int * int * C_Size.t -> int;
- val quot = _prim "IntInf_quot": int * int * C_Size.t -> int;
- val rem = _prim "IntInf_rem": int * int * C_Size.t -> int;
- val - = _prim "IntInf_sub": int * int * C_Size.t -> int;
- val toString =
- _prim "IntInf_toString": int * Int32.int * C_Size.t -> String8.string;
- val toVector = _prim "IntInf_toVector": int -> C_MPLimb.t vector;
- val toWord = _prim "IntInf_toWord": int -> ObjptrWord.word;
- val xorb = _prim "IntInf_xorb": int * int * C_Size.t -> int;
- end
-
-end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-mlton.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-mlton.sml 2006-04-24 21:45:47 UTC (rev 4407)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-mlton.sml 2006-04-25 02:41:19 UTC (rev 4408)
@@ -190,6 +190,12 @@
struct
open Pointer
+ local
+ exception IsNull
+ in
+ val isNull : t -> bool = fn _ => raise IsNull
+ end
+
val getInt8 = _prim "Pointer_getWord8": t * C_Ptrdiff.t -> Int8.int;
val getInt16 = _prim "Pointer_getWord16": t * C_Ptrdiff.t -> Int16.int;
val getInt32 = _prim "Pointer_getWord32": t * C_Ptrdiff.t -> Int32.int;
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-nullstring.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-nullstring.sml 2006-04-24 21:45:47 UTC (rev 4407)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-nullstring.sml 2006-04-25 02:41:19 UTC (rev 4408)
@@ -13,15 +13,13 @@
open Primitive
(* NullString is used for strings that must be passed to C and hence must be
- * null terminated. After the Primitive structure is defined,
- * NullString.fromString is replaced by a version that checks that the string
- * is indeed null terminated. See the bottom of this file.
+ * null terminated.
*)
structure NullString8 :>
sig
type t
- val empty: String8.string
+ val empty: t
val fromString: String8.string -> t
end =
struct
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/primitive.mlb
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/primitive.mlb 2006-04-24 21:45:47 UTC (rev 4407)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/primitive.mlb 2006-04-25 02:41:19 UTC (rev 4408)
@@ -25,7 +25,7 @@
local
../config/bind/char-prim.sml
../config/bind/int-prim.sml
- ../config/bind/intinf-prim.sml
+ ../config/bind/int-inf-prim.sml
../config/bind/real-prim.sml
../config/bind/string-prim.sml
../config/bind/word-prim.sml
@@ -50,7 +50,7 @@
prim-seq.sml
prim-nullstring.sml
- prim-intinf.sml
+ prim-int-inf.sml
prim-char.sml
prim-string.sml
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/primitive.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/primitive.sml 2006-04-24 21:45:47 UTC (rev 4407)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/primitive.sml 2006-04-25 02:41:19 UTC (rev 4408)
@@ -51,166 +51,6 @@
_import "PackReal64_updateRev": Word8.word array * int * real -> unit;
end
- structure Real64 =
- struct
- open Real64
-
- structure Class =
- struct
- type t = int
-
- val inf = _const "FP_INFINITE": t;
- val nan = _const "FP_NAN": t;
- val normal = _const "FP_NORMAL": t;
- val subnormal = _const "FP_SUBNORMAL": t;
- val zero = _const "FP_ZERO": t;
- end
-
- structure Math =
- struct
- type real = real
-
- val acos = _prim "Real64_Math_acos": real -> real;
- val asin = _prim "Real64_Math_asin": real -> real;
- val atan = _prim "Real64_Math_atan": real -> real;
- val atan2 = _prim "Real64_Math_atan2": real * real -> real;
- val cos = _prim "Real64_Math_cos": real -> real;
- val cosh = _import "cosh": real -> real;
- val e = #1 _symbol "Real64_Math_e": real GetSet.t; ()
- val exp = _prim "Real64_Math_exp": real -> real;
- val ln = _prim "Real64_Math_ln": real -> real;
- val log10 = _prim "Real64_Math_log10": real -> real;
- val pi = #1 _symbol "Real64_Math_pi": real GetSet.t; ()
- val pow = _import "pow": real * real -> real;
- val sin = _prim "Real64_Math_sin": real -> real;
- val sinh = _import "sinh": real -> real;
- val sqrt = _prim "Real64_Math_sqrt": real -> real;
- val tan = _prim "Real64_Math_tan": real -> real;
- val tanh = _import "tanh": real -> real;
- end
-
- val * = _prim "Real64_mul": real * real -> real;
- val *+ = _prim "Real64_muladd": real * real * real -> real;
- val *- = _prim "Real64_mulsub": real * real * real -> real;
- val + = _prim "Real64_add": real * real -> real;
- val - = _prim "Real64_sub": real * real -> real;
- val / = _prim "Real64_div": real * real -> real;
- val op < = _prim "Real64_lt": real * real -> bool;
- val op <= = _prim "Real64_le": real * real -> bool;
- val == = _prim "Real64_equal": real * real -> bool;
- val ?= = _prim "Real64_qequal": real * real -> bool;
- val abs = _prim "Real64_abs": real -> real;
- val class = _import "Real64_class": real -> int;
- val frexp = _import "Real64_frexp": real * int ref -> real;
- val gdtoa =
- _import "Real64_gdtoa": real * int * int * int ref -> CString.t;
- val fromInt = _prim "WordS32_toReal64": int -> real;
- val ldexp = _prim "Real64_ldexp": real * int -> real;
- val maxFinite = #1 _symbol "Real64_maxFinite": real GetSet.t; ()
- val minNormalPos = #1 _symbol "Real64_minNormalPos": real GetSet.t; ()
- val minPos = #1 _symbol "Real64_minPos": real GetSet.t; ()
- val modf = _import "Real64_modf": real * real ref -> real;
- val nextAfter = _import "Real64_nextAfter": real * real -> real;
- val round = _prim "Real64_round": real -> real;
- val signBit = _import "Real64_signBit": real -> int;
- val strto = _import "Real64_strto": NullString.t -> real;
- val toInt = _prim "Real64_toWordS32": real -> int;
- val ~ = _prim "Real64_neg": real -> real;
-
- val fromLarge : real -> real = fn x => x
- val toLarge : real -> real = fn x => x
- val precision : int = 53
- val radix : int = 2
- end
-
- structure Real32 =
- struct
- open Real32
-
- val precision : int = 24
- val radix : int = 2
-
- val fromLarge = _prim "Real64_toReal32": Real64.real -> real;
- val toLarge = _prim "Real32_toReal64": real -> Real64.real;
-
- fun unary (f: Real64.real -> Real64.real) (r: real): real =
- fromLarge (f (toLarge r))
-
- fun binary (f: Real64.real * Real64.real -> Real64.real)
- (r: real, r': real): real =
- fromLarge (f (toLarge r, toLarge r'))
-
- structure Math =
- struct
- type real = real
-
- val acos = _prim "Real32_Math_acos": real -> real;
- val asin = _prim "Real32_Math_asin": real -> real;
- val atan = _prim "Real32_Math_atan": real -> real;
- val atan2 = _prim "Real32_Math_atan2": real * real -> real;
- val cos = _prim "Real32_Math_cos": real -> real;
- val cosh = unary Real64.Math.cosh
- val e = #1 _symbol "Real32_Math_e": real GetSet.t; ()
- val exp = _prim "Real32_Math_exp": real -> real;
- val ln = _prim "Real32_Math_ln": real -> real;
- val log10 = _prim "Real32_Math_log10": real -> real;
- val pi = #1 _symbol "Real32_Math_pi": real GetSet.t; ()
- val pow = binary Real64.Math.pow
- val sin = _prim "Real32_Math_sin": real -> real;
- val sinh = unary Real64.Math.sinh
- val sqrt = _prim "Real32_Math_sqrt": real -> real;
- val tan = _prim "Real32_Math_tan": real -> real;
- val tanh = unary Real64.Math.tanh
- end
-
- val * = _prim "Real32_mul": real * real -> real;
- val *+ = _prim "Real32_muladd": real * real * real -> real;
- val *- = _prim "Real32_mulsub": real * real * real -> real;
- val + = _prim "Real32_add": real * real -> real;
- val - = _prim "Real32_sub": real * real -> real;
- val / = _prim "Real32_div": real * real -> real;
- val op < = _prim "Real32_lt": real * real -> bool;
- val op <= = _prim "Real32_le": real * real -> bool;
- val == = _prim "Real32_equal": real * real -> bool;
- val ?= = _prim "Real32_qequal": real * real -> bool;
- val abs = _prim "Real32_abs": real -> real;
- val class = _import "Real32_class": real -> int;
- fun frexp (r: real, ir: int ref): real =
- fromLarge (Real64.frexp (toLarge r, ir))
- val gdtoa =
- _import "Real32_gdtoa": real * int * int * int ref -> CString.t;
- val fromInt = _prim "WordS32_toReal32": int -> real;
- val ldexp = _prim "Real32_ldexp": real * int -> real;
- val maxFinite = #1 _symbol "Real32_maxFinite": real GetSet.t; ()
- val minNormalPos = #1 _symbol "Real32_minNormalPos": real GetSet.t; ()
- val minPos = #1 _symbol "Real32_minPos": real GetSet.t; ()
- val modf = _import "Real32_modf": real * real ref -> real;
- val signBit = _import "Real32_signBit": real -> int;
- val strto = _import "Real32_strto": NullString.t -> real;
- val toInt = _prim "Real32_toWordS32": real -> int;
- val ~ = _prim "Real32_neg": real -> real;
- end
-
- structure Real32 =
- struct
- open Real32
- local
- structure S = RealComparisons (Real32)
- in
- open S
- end
- end
-
- structure Real64 =
- struct
- open Real64
- local
- structure S = RealComparisons (Real64)
- in
- open S
- end
- end
-
structure TextIO =
struct
val bufSize = _command_line_const "TextIO.bufSize": int = 4096;
Deleted: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real.fun 2006-04-24 21:45:47 UTC (rev 4407)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real.fun 2006-04-25 02:41:19 UTC (rev 4408)
@@ -1,859 +0,0 @@
-(* Copyright (C) 2003-2005 Henry Cejtin, Matthew Fluet, Suresh
- * Jagannathan, and Stephen Weeks.
- *
- * MLton is released under a BSD-style license.
- * See the file MLton-LICENSE for details.
- *)
-
-functor Real (R: PRE_REAL)(*: REAL*) =
- struct
- structure MLton = Primitive.MLton
- structure Prim = R
- local
- open IEEEReal
- in
- datatype float_class = datatype float_class
- datatype rounding_mode = datatype rounding_mode
- end
- infix 4 == != ?=
- type real = R.real
-
- local
- open Prim
- val isBytecode = MLton.Codegen.isBytecode
- in
- val *+ =
- if isBytecode
- then fn (r1, r2, r3) => r1 * r2 + r3
- else *+
- val *- =
- if isBytecode
- then fn (r1, r2, r3) => r1 * r2 - r3
- else *-
- val op * = op *
- val op + = op +
- val op - = op -
- val op / = op /
- val op / = op /
- val op < = op <
- val op <= = op <=
- val op > = op >
- val op >= = op >=
- val ~ = ~
- val abs = abs
-
- val maxFinite = maxFinite
- val minNormalPos = minNormalPos
- val minPos = minPos
-
- val precision = Primitive.Int32.toInt precision
- val radix = Primitive.Int32.toInt radix
-
- val signBit = fn r => signBit r <> 0
- end
-
- val zero = R.fromInt32Unsafe 0
- val one = R.fromInt32Unsafe 1
- val two = R.fromInt32Unsafe 2
-
- val negOne = ~ one
- val half = one / two
-
- val posInf = one / zero
- val negInf = ~one / zero
-
- val nan = posInf + negInf
-
- local
- val classes =
- let
- open R.Class
- in
- (* order here is chosen based on putting the more
- * commonly used classes at the front.
- *)
- [(normal, NORMAL),
- (zero, ZERO),
- (inf, INF),
- (nan, NAN),
- (subnormal, SUBNORMAL)]
- end
- in
- fun class x =
- let
- val i = R.class x
- in
- case List.find (fn (i', _) => i = i') classes of
- NONE => raise Fail "Real_class returned bogus integer"
- | SOME (_, c) => c
- end
- end
-
- val abs =
- if MLton.Codegen.isNative
- then abs
- else
- fn x =>
- case class x of
- INF => posInf
- | NAN => x
- | _ => if signBit x then ~x else x
-
- fun isFinite r =
- case class r of
- INF => false
- | NAN => false
- | _ => true
-
- fun isNan r = class r = NAN
-
- fun isNormal r = class r = NORMAL
-
- val op == =
- fn (x, y) =>
- case (class x, class y) of
- (NAN, _) => false
- | (_, NAN) => false
- | (ZERO, ZERO) => true
- | _ => R.== (x, y)
-
- val op != = not o op ==
-
- val op ?= =
- if MLton.Codegen.isNative
- then R.?=
- else
- fn (x, y) =>
- case (class x, class y) of
- (NAN, _) => true
- | (_, NAN) => true
- | (ZERO, ZERO) => true
- | _ => R.== (x, y)
-
- fun min (x, y) =
- if isNan x
- then y
- else if isNan y
- then x
- else if x < y then x else y
-
- fun max (x, y) =
- if isNan x
- then y
- else if isNan y
- then x
- else if x > y then x else y
-
- fun sign (x: real): int =
- case class x of
- NAN => raise Domain
- | ZERO => 0
- | _ => if x > zero then 1 else ~1
-
- fun sameSign (x, y) = signBit x = signBit y
-
- fun copySign (x, y) =
- if sameSign (x, y)
- then x
- else ~ x
-
- local
- datatype z = datatype IEEEReal.real_order
- in
- fun compareReal (x, y) =
- case (class x, class y) of
- (NAN, _) => UNORDERED
- | (_, NAN) => UNORDERED
- | (ZERO, ZERO) => EQUAL
- | _ => if x < y then LESS
- else if x > y then GREATER
- else EQUAL
- end
-
- local
- structure I = IEEEReal
- structure G = General
- in
- fun compare (x, y) =
- case compareReal (x, y) of
- I.EQUAL => G.EQUAL
- | I.GREATER => G.GREATER
- | I.LESS => G.LESS
- | I.UNORDERED => raise IEEEReal.Unordered
- end
-
- fun unordered (x, y) = isNan x orelse isNan y
-
- val nextAfter: real * real -> real =
- fn (r, t) =>
- case (class r, class t) of
- (NAN, _) => nan
- | (_, NAN) => nan
- | (INF, _) => r
- | (ZERO, ZERO) => r
- | (ZERO, _) => if t > zero then minPos else ~minPos
- | _ =>
- if r == t
- then r
- else
- let
- fun doit (r, t) =
- if r == maxFinite andalso t == posInf
- then posInf
- else if r > t
- then R.nextAfter (r, negInf)
- else R.nextAfter (r, posInf)
- in
- if r > zero
- then doit (r, t)
- else ~ (doit (~r, ~t))
- end
-
- fun toManExp x =
- case class x of
- INF => {exp = 0, man = x}
- | NAN => {exp = 0, man = nan}
- | ZERO => {exp = 0, man = x}
- | _ =>
- let
- val r: C_Int.t ref = ref 0
- val man = R.frexp (x, r)
- in
- {exp = C_Int.toInt (!r), man = man}
- end
-
- fun fromManExp {exp, man} =
- (R.ldexp (man, C_Int.fromInt exp))
- handle Overflow =>
- man * (if Int.< (exp, 0) then zero else posInf)
-
- val fromManExp =
- if MLton.Codegen.isNative
- then fromManExp
- else
- fn {exp, man} =>
- case class man of
- INF => man
- | NAN => man
- | ZERO => man
- | _ => fromManExp {exp = exp, man = man}
-
- fun split x =
- case class x of
- INF => {frac = if x > zero then zero else ~zero,
- whole = x}
- | NAN => {frac = nan, whole = nan}
- | _ =>
- let
- val int = ref zero
- val frac = R.modf (x, int)
- val whole = !int
- (* Some platforms' C libraries don't get sign of
- * zero right.
- *)
- fun fix y =
- if class y = ZERO andalso not (sameSign (x, y))
- then ~ y
- else y
- in
- {frac = fix frac,
- whole = fix whole}
- end
-
- val realMod = #frac o split
-
- fun checkFloat x =
- case class x of
- INF => raise Overflow
- | NAN => raise Div
- | _ => x
-
- local
- fun 'a make {fromRealUnsafe: 'a -> real,
- toRealUnsafe: real -> 'a,
- other : {precision: Primitive.Int32.int}} =
- if R.precision = #precision other
- then (fromRealUnsafe,
- fn (m: rounding_mode) => fromRealUnsafe,
- toRealUnsafe,
- fn (m: rounding_mode) => toRealUnsafe)
- else (fromRealUnsafe,
- fn (m: rounding_mode) => fn r =>
- IEEEReal.withRoundingMode (m, fn () => fromRealUnsafe r),
- toRealUnsafe,
- fn (m: rounding_mode) => fn r =>
- IEEEReal.withRoundingMode (m, fn () => toRealUnsafe r))
- in
- val (fromReal32,fromReal32M,toReal32,toReal32M) =
- make {fromRealUnsafe = R.fromReal32Unsafe,
- toRealUnsafe = R.toReal32Unsafe,
- other = {precision = Primitive.Real32.precision}}
- val (fromReal64,fromReal64M,toReal64,toReal64M) =
- make {fromRealUnsafe = R.fromReal64Unsafe,
- toRealUnsafe = R.toReal64Unsafe,
- other = {precision = Primitive.Real64.precision}}
- end
- local
- structure S =
- LargeReal_ChooseRealN
- (type 'a t = real -> 'a
- val fReal32 = toReal32
- val fReal64 = toReal64)
- in
- val toLarge = S.f
- end
- local
- structure S =
- LargeReal_ChooseRealN
- (type 'a t = rounding_mode -> 'a -> real
- val fReal32 = fromReal32M
- val fReal64 = fromReal64M)
- in
- val fromLarge = S.f
- end
-
- fun roundReal (x: real, m: rounding_mode): real =
- IEEEReal.withRoundingMode (m, fn () => R.round x)
-
- local
- fun 'a make {fromIntUnsafe: 'a -> real,
- toIntUnsafe: real -> 'a,
- other : {maxInt': 'a,
- minInt': 'a}} =
- let
- val maxInt' = #maxInt' other
- val minInt' = #minInt' other
- val maxInt = fromIntUnsafe maxInt'
- val minInt = fromIntUnsafe minInt'
- in
- (fromIntUnsafe,
- fn (m: rounding_mode) => fn i =>
- IEEEReal.withRoundingMode (m, fn () => fromIntUnsafe i),
- toIntUnsafe,
- fn (m: rounding_mode) => fn x =>
- case class x of
- INF => raise Overflow
- | NAN => raise Domain
- | _ => if minInt <= x
- then if x <= maxInt
- then toIntUnsafe (roundReal (x, m))
- else if x < maxInt + one
- then (case m of
- TO_NEGINF => maxInt'
- | TO_POSINF => raise Overflow
- | TO_ZERO => maxInt'
- | TO_NEAREST =>
- (* Depends on maxInt being odd. *)
- if x - maxInt >= half
- then raise Overflow
- else maxInt')
- else raise Overflow
- else if x > minInt - one
- then (case m of
- TO_NEGINF => raise Overflow
- | TO_POSINF => minInt'
- | TO_ZERO => minInt'
- | TO_NEAREST =>
- (* Depends on minInt being even. *)
- if x - minInt < ~half
- then raise Overflow
- else minInt')
- else raise Overflow)
- end
- in
- val (fromInt8,fromInt8M,toInt8,toInt8M) =
- make {fromIntUnsafe = R.fromInt8Unsafe,
- toIntUnsafe = R.toInt8Unsafe,
- other = {maxInt' = Int8.maxInt',
- minInt' = Int8.minInt'}}
- val (fromInt16,fromInt16M,toInt16,toInt16M) =
- make {fromIntUnsafe = R.fromInt16Unsafe,
- toIntUnsafe = R.toInt16Unsafe,
- other = {maxInt' = Int16.maxInt',
- minInt' = Int16.minInt'}}
- val (fromInt32,fromInt32M,toInt32,toInt32M) =
- make {fromIntUnsafe = R.fromInt32Unsafe,
- toIntUnsafe = R.toInt32Unsafe,
- other = {maxInt' = Int32.maxInt',
- minInt' = Int32.minInt'}}
- val (fromInt64,fromInt64M,toInt64,toInt64M) =
- make {fromIntUnsafe = R.fromInt64Unsafe,
- toIntUnsafe = R.toInt64Unsafe,
- other = {maxInt' = Int64.maxInt',
- minInt' = Int64.minInt'}}
- end
-
-(*
- val floor = toInt TO_NEGINF
- val ceil = toInt TO_POSINF
- val trunc = toInt TO_ZERO
- val round = toInt TO_NEAREST
-
- local
- fun round mode x =
- case class x of
- INF => x
- | NAN => x
- | _ => roundReal (x, mode)
- in
- val realCeil = round TO_POSINF
- val realFloor = round TO_NEGINF
- val realRound = round TO_NEAREST
- val realTrunc = round TO_ZERO
- end
-
- fun rem (x, y) =
- case class x of
- INF => nan
- | NAN => nan
- | ZERO => zero
- | _ =>
- case class y of
- INF => x
- | NAN => nan
- | ZERO => nan
- | _ => x - realTrunc (x/y) * y
-
- (* fromDecimal, scan, fromString: decimal -> binary conversions *)
- exception Bad
- fun fromDecimal ({class, digits, exp, sign}: IEEEReal.decimal_approx) =
- let
- fun doit () =
- let
- val exp =
- if Int.< (exp, 0)
- then concat ["-", Int.toString (Int.~ exp)]
- else Int.toString exp
-(* val x = concat ["0.", digits, "E", exp, "\000"] *)
- val n =
- Int.+ (4, Int.+ (List.length digits, String.size exp))
- val a = Array.rawArray n
- fun up (i, c) = (Array.update (a, i, c); Int.+ (i, 1))
- val i = 0
- val i = up (i, #"0")
- val i = up (i, #".")
- val i =
- List.foldl
- (fn (d, i) =>
- if Int.< (d, 0) orelse Int.> (d, 9)
- then raise Bad
- else up (i, Char.chr (Int.+ (d, Char.ord #"0"))))
- i digits
- val i = up (i, #"E")
- val i = CharVector.foldl (fn (c, i) => up (i, c)) i exp
- val _ = up (i, #"\000")
- val x = Vector.fromArray a
- val x = Prim.strto (NullString.fromString x)
- in
- if sign
- then ~ x
- else x
- end
- in
- SOME (case class of
- INF => if sign then negInf else posInf
- | NAN => nan
- | NORMAL => doit ()
- | SUBNORMAL => doit ()
- | ZERO => if sign then ~ zero else zero)
- handle Bad => NONE
- end
-
- fun scan reader state =
- case IEEEReal.scan reader state of
- NONE => NONE
- | SOME (da, state) => SOME (valOf (fromDecimal da), state)
-
- val fromString = StringCvt.scanString scan
-
- (* toDecimal, fmt, toString: binary -> decimal conversions. *)
- datatype mode = Fix | Gen | Sci
- local
- val decpt: int ref = ref 0
- in
- fun gdtoa (x: real, mode: mode, ndig: int) =
- let
- val mode =
- case mode of
- Fix => 3
- | Gen => 0
- | Sci => 2
- val cs = Prim.gdtoa (x, mode, ndig, decpt)
- in
- (cs, !decpt)
- end
- end
-
- fun toDecimal (x: real): IEEEReal.decimal_approx =
- case class x of
- INF => {class = INF,
- digits = [],
- exp = 0,
- sign = x < zero}
- | NAN => {class = NAN,
- digits = [],
- exp = 0,
- sign = false}
- | ZERO => {class = ZERO,
- digits = [],
- exp = 0,
- sign = signBit x}
- | c =>
- let
- val (cs, exp) = gdtoa (x, Gen, 0)
- fun loop (i, ac) =
- if Int.< (i, 0)
- then ac
- else loop (Int.- (i, 1),
- (Int.- (Char.ord (COld.CS.sub (cs, i)),
- Char.ord #"0"))
- :: ac)
- val digits = loop (Int.- (COld.CS.length cs, 1), [])
- in
- {class = c,
- digits = digits,
- exp = exp,
- sign = x < zero}
- end
-
- datatype realfmt = datatype StringCvt.realfmt
-
- fun add1 n = Int.+ (n, 1)
-
- local
- fun fix (sign: string, cs: COld.CS.t, decpt: int, ndig: int): string =
- let
- val length = COld.CS.length cs
- in
- if Int.< (decpt, 0)
- then
- concat [sign,
- "0.",
- String.new (Int.~ decpt, #"0"),
- COld.CS.toString cs,
- String.new (Int.+ (Int.- (ndig, length),
- decpt),
- #"0")]
- else
- let
- val whole =
- if decpt = 0
- then "0"
- else
- String.tabulate (decpt, fn i =>
- if Int.< (i, length)
- then COld.CS.sub (cs, i)
- else #"0")
- in
- if 0 = ndig
- then concat [sign, whole]
- else
- let
- val frac =
- String.tabulate
- (ndig, fn i =>
- let
- val j = Int.+ (i, decpt)
- in
- if Int.< (j, length)
- then COld.CS.sub (cs, j)
- else #"0"
- end)
- in
- concat [sign, whole, ".", frac]
- end
- end
- end
- fun sci (x: real, ndig: int): string =
- let
- val sign = if x < zero then "~" else ""
- val (cs, decpt) = gdtoa (x, Sci, add1 ndig)
- val length = COld.CS.length cs
- val whole = String.tabulate (1, fn _ => COld.CS.sub (cs, 0))
- val frac =
- if 0 = ndig
- then ""
- else concat [".",
- String.tabulate
- (ndig, fn i =>
- let
- val j = Int.+ (i, 1)
- in
- if Int.< (j, length)
- then COld.CS.sub (cs, j)
- else #"0"
- end)]
- val exp = Int.- (decpt, 1)
- val exp =
- let
- val (exp, sign) =
- if Int.< (exp, 0)
- then (Int.~ exp, "~")
- else (exp, "")
- in
- concat [sign, Int.toString exp]
- end
- in
- concat [sign, whole, frac, "E", exp]
- end
- fun gen (x: real, n: int): string =
- case class x of
- INF => if x > zero then "inf" else "~inf"
- | NAN => "nan"
- | _ =>
- let
- val (prefix, x) =
- if x < zero
- then ("~", ~ x)
- else ("", x)
- val ss = Substring.full (sci (x, Int.- (n, 1)))
- fun isE c = c = #"E"
- fun isZero c = c = #"0"
- val expS =
- Substring.string (Substring.taker (not o isE) ss)
- val exp = valOf (Int.fromString expS)
- val man =
- String.translate
- (fn #"." => "" | c => str c)
- (Substring.string (Substring.dropr isZero
- (Substring.takel (not o isE) ss)))
- val manSize = String.size man
- fun zeros i = CharVector.tabulate (i, fn _ => #"0")
- fun dotAt i =
- concat [String.substring (man, 0, i),
- ".", String.extract (man, i, NONE)]
- fun sci () = concat [prefix,
- if manSize = 1 then man else dotAt 1,
- "E", expS]
- val op - = Int.-
- val op + = Int.+
- val ~ = Int.~
- val op >= = Int.>=
- in
- if exp >= (if manSize = 1 then 3 else manSize + 3)
- then sci ()
- else if exp >= manSize - 1
- then concat [prefix, man, zeros (exp - (manSize - 1))]
- else if exp >= 0
- then concat [prefix, dotAt (exp + 1)]
- else if exp >= (if manSize = 1 then ~2 else ~3)
- then concat [prefix, "0.", zeros (~exp - 1), man]
- else sci ()
- end
- in
- fun fmt spec =
- let
- val doit =
- case spec of
- EXACT => IEEEReal.toString o toDecimal
- | FIX opt =>
- let
- val n =
- case opt of
- NONE => 6
- | SOME n =>
- if Primitive.safe andalso Int.< (n, 0)
- then raise Size
- else n
- in
- fn x =>
- let
- val sign = if x < zero then "~" else ""
- val (cs, decpt) = gdtoa (x, Fix, n)
- in
- fix (sign, cs, decpt, n)
- end
- end
- | GEN opt =>
- let
- val n =
- case opt of
- NONE => 12
- | SOME n =>
- if Primitive.safe andalso Int.< (n, 1)
- then raise Size
- else n
- in
- fn x => gen (x, n)
- end
- | SCI opt =>
- let
- val n =
- case opt of
- NONE => 6
- | SOME n =>
- if Primitive.safe andalso Int.< (n, 0)
- then raise Size
- else n
- in
- fn x => sci (x, n)
- end
- in
- fn x =>
- case class x of
- NAN => "nan"
- | INF => if x > zero then "inf" else "~inf"
- | _ => doit x
- end
- end
-
- val toString = fmt (StringCvt.GEN NONE)
-
- val fromLargeInt: LargeInt.int -> real =
- fn i =>
- fromInt (IntInf.toInt i)
- handle Overflow =>
- let
- val (i, sign) =
- if LargeInt.< (i, 0)
- then (LargeInt.~ i, true)
- else (i, false)
- val x = Prim.strto (NullString.fromString
- (concat [LargeInt.toString i, "\000"]))
- in
- if sign then ~ x else x
- end
-
- val toLargeInt: IEEEReal.rounding_mode -> real -> LargeInt.int =
- fn mode => fn x =>
- case class x of
- INF => raise Overflow
- | NAN => raise Domain
- | ZERO => 0
- | _ =>
- let
- (* This round may turn x into an INF, so we need to check the
- * class again.
- *)
- val x = roundReal (x, mode)
- in
- case class x of
- INF => raise Overflow
- | _ =>
- if minInt <= x andalso x <= maxInt
- then LargeInt.fromInt (Prim.toInt x)
- else
- valOf
- (LargeInt.fromString (fmt (StringCvt.FIX (SOME 0)) x))
- end
-
- structure Math =
- struct
- open Prim.Math
-
- (* Patch functions to handle out-of-range args. Many C math
- * libraries do not do what the SML Basis Spec requires.
- *)
-
- local
- fun patch f x =
- if x < ~one orelse x > one
- then nan
- else f x
- in
- val acos = patch acos
- val asin = patch asin
- end
-
- local
- fun patch f x = if x < zero then nan else f x
- in
- val ln = patch ln
- val log10 = patch log10
- end
-
- (* The x86 doesn't get exp right on infs. *)
- val exp =
- if MLton.Codegen.isNative
- andalso let open MLton.Platform.Arch in host = X86 end
- then (fn x =>
- case class x of
- INF => if x > zero then posInf else zero
- | _ => exp x)
- else exp
-
- (* The Cygwin math library doesn't get pow right on some exceptional
- * cases.
- *
- * The Linux math library doesn't get pow (x, y) right when x < 0
- * and y is large (but finite).
- *
- * So, we define a pow function that gives the correct result on
- * exceptional cases, and only calls the C pow with x > 0.
- *)
- fun isInt (x: real): bool = x == realFloor x
-
- (* isEven x assumes isInt x. *)
- fun isEven (x: real): bool = isInt (x / two)
-
- fun isOddInt x = isInt x andalso not (isEven x)
-
- fun isNeg x = x < zero
-
- fun pow (x, y) =
- case class y of
- INF =>
- if class x = NAN
- then nan
- else if x < negOne orelse x > one
- then if isNeg y then zero else posInf
- else if negOne < x andalso x < one
- then if isNeg y then posInf else zero
- else (* x = 1 orelse x = ~1 *)
- nan
- | NAN => nan
- | ZERO => one
- | _ =>
- (case class x of
- INF =>
- if isNeg x
- then if isNeg y
- then if isOddInt y
- then ~ zero
- else zero
- else if isOddInt y
- then negInf
- else posInf
- else (* x = posInf *)
- if isNeg y then zero else posInf
- | NAN => nan
- | ZERO =>
- if isNeg y
- then if isOddInt y
- then copySign (posInf, x)
- else posInf
- else if isOddInt y
- then x
- else zero
- | _ =>
- if isNeg x
- then if isInt y
- then if isEven y
- then Prim.Math.pow (~ x, y)
- else negOne * Prim.Math.pow (~ x, y)
- else nan
- else Prim.Math.pow (x, y))
-
- fun cosh x =
- case class x of
- INF => x
- | ZERO => one
- | _ => R.Math.cosh x
-
- fun sinh x =
- case class x of
- INF => x
- | ZERO => x
- | _ => R.Math.sinh x
-
- fun tanh x =
- case class x of
- INF => if x > zero then one else negOne
- | ZERO => x
- | _ => R.Math.tanh x
- end
-*)
- end
-
-structure Real32 = Real (Primitive.Real32)
-structure Real64 = Real (Primitive.Real64)
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real.sig 2006-04-24 21:45:47 UTC (rev 4407)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real.sig 2006-04-25 02:41:19 UTC (rev 4408)
@@ -51,12 +51,8 @@
val modf: real * real ref -> real
val round: real -> real
-(*
- val gdtoa: real * int * int * int ref -> C_String.t
- val nextAfterDown: real -> real
- val nextAfterUp: real -> real
- val strto: NullString.t -> real
-*)
+ val gdtoa: real * C_Int.t * C_Int.t * C_Int.t ref -> C_String.t
+ val strto: Primitive.NullString8.t -> real
val fromInt8Unsafe: Primitive.Int8.int -> real
val fromInt16Unsafe: Primitive.Int16.int -> real
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real.sml (from rev 4407, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real.fun)
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real.fun 2006-04-24 21:45:47 UTC (rev 4407)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real.sml 2006-04-25 02:41:19 UTC (rev 4408)
@@ -0,0 +1,905 @@
+(* Copyright (C) 2003-2005 Henry Cejtin, Matthew Fluet, Suresh
+ * Jagannathan, and Stephen Weeks.
+ *
+ * MLton is released under a BSD-style license.
+ * See the file MLton-LICENSE for details.
+ *)
+
+functor Real (R: PRE_REAL): REAL =
+ struct
+ structure MLton = Primitive.MLton
+ structure Prim = R
+ local
+ open IEEEReal
+ in
+ datatype float_class = datatype float_class
+ datatype rounding_mode = datatype rounding_mode
+ end
+ infix 4 == != ?=
+ type real = R.real
+
+ local
+ open Prim
+ val isBytecode = MLton.Codegen.isBytecode
+ in
+ val *+ =
+ if isBytecode
+ then fn (r1, r2, r3) => r1 * r2 + r3
+ else *+
+ val *- =
+ if isBytecode
+ then fn (r1, r2, r3) => r1 * r2 - r3
+ else *-
+ val op * = op *
+ val op + = op +
+ val op - = op -
+ val op / = op /
+ val op / = op /
+ val op < = op <
+ val op <= = op <=
+ val op > = op >
+ val op >= = op >=
+ val ~ = ~
+ val abs = abs
+
+ val maxFinite = maxFinite
+ val minNormalPos = minNormalPos
+ val minPos = minPos
+
+ val precision = Primitive.Int32.toInt precision
+ val radix = Primitive.Int32.toInt radix
+
+ val signBit = fn r => signBit r <> 0
+ end
+
+ local
+ fun 'a make {fromRealUnsafe: 'a -> real,
+ toRealUnsafe: real -> 'a,
+ other : {precision: Primitive.Int32.int}} =
+ if R.precision = #precision other
+ then (fromRealUnsafe,
+ fn (m: rounding_mode) => fromRealUnsafe,
+ toRealUnsafe,
+ fn (m: rounding_mode) => toRealUnsafe)
+ else (fromRealUnsafe,
+ fn (m: rounding_mode) => fn r =>
+ IEEEReal.withRoundingMode (m, fn () => fromRealUnsafe r),
+ toRealUnsafe,
+ fn (m: rounding_mode) => fn r =>
+ IEEEReal.withRoundingMode (m, fn () => toRealUnsafe r))
+ in
+ val (fro...
[truncated message content] |
|
From: Stephen W. <sw...@ml...> - 2006-04-24 14:45:51
|
Ville Laurikari's patch for HP-UX.
----------------------------------------------------------------------
U mlton/trunk/basis-library/misc/primitive.sml
U mlton/trunk/basis-library/mlton/platform.sig
U mlton/trunk/basis-library/mlton/platform.sml
U mlton/trunk/basis-library/sml-nj/sml-nj.sml
U mlton/trunk/bin/platform
U mlton/trunk/bin/upgrade-basis
U mlton/trunk/lib/mlton-stubs/mlton.sml
U mlton/trunk/lib/mlton-stubs/platform.sig
U mlton/trunk/mlton/main/main.fun
U mlton/trunk/runtime/Makefile
U mlton/trunk/runtime/Posix/ProcEnv/Uname.c
U mlton/trunk/runtime/basis/Int/Word.c
U mlton/trunk/runtime/gc.c
A mlton/trunk/runtime/platform/hpux.c
A mlton/trunk/runtime/platform/hpux.h
A mlton/trunk/runtime/platform/setenv.putenv.c
U mlton/trunk/runtime/platform/solaris.c
U mlton/trunk/runtime/platform.h
U mlton/trunk/runtime/types.h
----------------------------------------------------------------------
Modified: mlton/trunk/basis-library/misc/primitive.sml
===================================================================
--- mlton/trunk/basis-library/misc/primitive.sml 2006-04-24 21:21:40 UTC (rev 4406)
+++ mlton/trunk/basis-library/misc/primitive.sml 2006-04-24 21:45:47 UTC (rev 4407)
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-2000 NEC Research Institute.
*
@@ -967,6 +967,7 @@
Cygwin
| Darwin
| FreeBSD
+ | HPUX
| Linux
| MinGW
| NetBSD
@@ -978,6 +979,7 @@
"cygwin" => Cygwin
| "darwin" => Darwin
| "freebsd" => FreeBSD
+ | "hpux" => HPUX
| "linux" => Linux
| "mingw" => MinGW
| "netbsd" => NetBSD
Modified: mlton/trunk/basis-library/mlton/platform.sig
===================================================================
--- mlton/trunk/basis-library/mlton/platform.sig 2006-04-24 21:21:40 UTC (rev 4406)
+++ mlton/trunk/basis-library/mlton/platform.sig 2006-04-24 21:45:47 UTC (rev 4407)
@@ -1,4 +1,4 @@
-(* Copyright (C) 2003-2005 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 2003-2006 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
*
* MLton is released under a BSD-style license.
@@ -23,6 +23,7 @@
Cygwin
| Darwin
| FreeBSD
+ | HPUX
| Linux
| MinGW
| NetBSD
Modified: mlton/trunk/basis-library/mlton/platform.sml
===================================================================
--- mlton/trunk/basis-library/mlton/platform.sml 2006-04-24 21:21:40 UTC (rev 4406)
+++ mlton/trunk/basis-library/mlton/platform.sml 2006-04-24 21:45:47 UTC (rev 4407)
@@ -1,4 +1,4 @@
-(* Copyright (C) 2003-2005 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 2003-2006 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
*
* MLton is released under a BSD-style license.
@@ -46,6 +46,7 @@
val all = [(Cygwin, "Cygwin"),
(Darwin, "Darwin"),
(FreeBSD, "FreeBSD"),
+ (HPUX, "HPUX"),
(Linux, "Linux"),
(MinGW, "MinGW"),
(NetBSD, "NetBSD"),
Modified: mlton/trunk/basis-library/sml-nj/sml-nj.sml
===================================================================
--- mlton/trunk/basis-library/sml-nj/sml-nj.sml 2006-04-24 21:21:40 UTC (rev 4406)
+++ mlton/trunk/basis-library/sml-nj/sml-nj.sml 2006-04-24 21:45:47 UTC (rev 4407)
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-2000 NEC Research Institute.
*
@@ -33,6 +33,7 @@
Cygwin => UNIX
| Darwin => MACOS
| FreeBSD => UNIX
+ | HPUX => UNIX
| Linux => UNIX
| MinGW => WIN32
| NetBSD => UNIX
@@ -68,4 +69,3 @@
| Original => false
end
end
-
Modified: mlton/trunk/bin/platform
===================================================================
--- mlton/trunk/bin/platform 2006-04-24 21:21:40 UTC (rev 4406)
+++ mlton/trunk/bin/platform 2006-04-24 21:45:47 UTC (rev 4407)
@@ -35,6 +35,9 @@
FreeBSD*)
HOST_OS='freebsd'
;;
+HP-UX)
+ HOST_OS='hpux'
+;;
Linux)
HOST_OS='linux'
;;
@@ -74,6 +77,9 @@
parisc*)
HOST_ARCH=hppa
;;
+9000/*)
+ HOST_ARCH=hppa
+;;
ia64*)
HOST_ARCH=ia64
;;
Modified: mlton/trunk/bin/upgrade-basis
===================================================================
--- mlton/trunk/bin/upgrade-basis 2006-04-24 21:21:40 UTC (rev 4406)
+++ mlton/trunk/bin/upgrade-basis 2006-04-24 21:45:47 UTC (rev 4407)
@@ -144,6 +144,9 @@
freebsd)
os='FreeBSD'
;;
+hpux)
+ os="HPUX"
+;;
linux)
os='Linux'
;;
@@ -206,12 +209,13 @@
structure OS =
struct
- datatype t = Cygwin | Darwin | FreeBSD | Linux | MinGW | NetBSD
- | OpenBSD | Solaris
+ datatype t = Cygwin | Darwin | FreeBSD | HPUX | Linux | MinGW
+ | NetBSD | OpenBSD | Solaris
val all = [(Cygwin, "Cygwin"),
(Darwin, "Darwin"),
(FreeBSD, "FreeBSD"),
+ (HPUX, "HPUX"),
(Linux, "Linux"),
(MinGW, "MinGW"),
(NetBSD, "NetBSD"),
Modified: mlton/trunk/lib/mlton-stubs/mlton.sml
===================================================================
--- mlton/trunk/lib/mlton-stubs/mlton.sml 2006-04-24 21:21:40 UTC (rev 4406)
+++ mlton/trunk/lib/mlton-stubs/mlton.sml 2006-04-24 21:45:47 UTC (rev 4407)
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-2000 NEC Research Institute.
*
@@ -213,6 +213,7 @@
Cygwin
| Darwin
| FreeBSD
+ | HPUX
| Linux
| MinGW
| NetBSD
@@ -224,6 +225,7 @@
val all = [(Cygwin, "Cygwin"),
(Darwin, "Darwin"),
(FreeBSD, "FreeBSD"),
+ (HPUX, "HPUX"),
(Linux, "Linux"),
(MinGW, "MinGW"),
(NetBSD, "NetBSD"),
Modified: mlton/trunk/lib/mlton-stubs/platform.sig
===================================================================
--- mlton/trunk/lib/mlton-stubs/platform.sig 2006-04-24 21:21:40 UTC (rev 4406)
+++ mlton/trunk/lib/mlton-stubs/platform.sig 2006-04-24 21:45:47 UTC (rev 4407)
@@ -1,4 +1,4 @@
-(* Copyright (C) 2003-2005 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 2003-2006 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
*
* MLton is released under a BSD-style license.
@@ -23,6 +23,7 @@
Cygwin
| Darwin
| FreeBSD
+ | HPUX
| Linux
| MinGW
| NetBSD
Modified: mlton/trunk/mlton/main/main.fun
===================================================================
--- mlton/trunk/mlton/main/main.fun 2006-04-24 21:21:40 UTC (rev 4406)
+++ mlton/trunk/mlton/main/main.fun 2006-04-24 21:45:47 UTC (rev 4407)
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-2000 NEC Research Institute.
*
@@ -645,6 +645,7 @@
case targetOS of
Darwin => ()
| FreeBSD => ()
+ | HPUX => ()
| Linux => ()
| NetBSD => ()
| OpenBSD => ()
Modified: mlton/trunk/runtime/Makefile
===================================================================
--- mlton/trunk/runtime/Makefile 2006-04-24 21:21:40 UTC (rev 4406)
+++ mlton/trunk/runtime/Makefile 2006-04-24 21:45:47 UTC (rev 4407)
@@ -1,4 +1,4 @@
-## Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
+## Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
# Jagannathan, and Stephen Weeks.
# Copyright (C) 1997-2000 NEC Research Institute.
#
Modified: mlton/trunk/runtime/Posix/ProcEnv/Uname.c
===================================================================
--- mlton/trunk/runtime/Posix/ProcEnv/Uname.c 2006-04-24 21:21:40 UTC (rev 4406)
+++ mlton/trunk/runtime/Posix/ProcEnv/Uname.c 2006-04-24 21:45:47 UTC (rev 4407)
@@ -4,12 +4,12 @@
#define DEBUG FALSE
#endif
-static struct utsname utsname;
+static struct utsname mlton_utsname;
Int Posix_ProcEnv_Uname_uname () {
Int res;
- res = uname (&utsname);
+ res = uname (&mlton_utsname);
if (DEBUG)
fprintf (stderr, "%d = Posix_ProcEnv_Uname_uname ()\n",
(int)res);
@@ -17,21 +17,21 @@
}
Cstring Posix_ProcEnv_Uname_sysname () {
- return (Cstring)utsname.sysname;
+ return (Cstring)mlton_utsname.sysname;
}
Cstring Posix_ProcEnv_Uname_nodename () {
- return (Cstring)utsname.nodename;
+ return (Cstring)mlton_utsname.nodename;
}
Cstring Posix_ProcEnv_Uname_release () {
- return (Cstring)utsname.release;
+ return (Cstring)mlton_utsname.release;
}
Cstring Posix_ProcEnv_Uname_version () {
- return (Cstring)utsname.version;
+ return (Cstring)mlton_utsname.version;
}
Cstring Posix_ProcEnv_Uname_machine () {
- return (Cstring)utsname.machine;
+ return (Cstring)mlton_utsname.machine;
}
Modified: mlton/trunk/runtime/basis/Int/Word.c
===================================================================
--- mlton/trunk/runtime/basis/Int/Word.c 2006-04-24 21:21:40 UTC (rev 4406)
+++ mlton/trunk/runtime/basis/Int/Word.c 2006-04-24 21:45:47 UTC (rev 4407)
@@ -28,7 +28,7 @@
#define DEBUG FALSE
#endif
-#if ! (defined (__hppa__) || defined (__i386__) || defined (__ppc__) || defined (__powerpc__) || defined (__sparc__))
+#if ! (defined (__hppa__) || defined (__i386__) || defined(__ia64__) || defined (__ppc__) || defined (__powerpc__) || defined (__sparc__))
#error check that C {/,%} correctly implement {quot,rem} from the basis library
#endif
Modified: mlton/trunk/runtime/gc.c
===================================================================
--- mlton/trunk/runtime/gc.c 2006-04-24 21:21:40 UTC (rev 4406)
+++ mlton/trunk/runtime/gc.c 2006-04-24 21:45:47 UTC (rev 4407)
@@ -1,4 +1,4 @@
-/* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
+/* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-2000 NEC Research Institute.
*
@@ -332,7 +332,15 @@
/* ---------------------------------------------------------------- */
void GC_display (GC_state s, FILE *stream) {
- fprintf (stream, "GC state\n\tcardMap = 0x%08x\n\toldGen = 0x%08x\n\toldGenSize = %s\n\toldGen + oldGenSize = 0x%08x\n\tnursery = 0x%08x\n\tfrontier = 0x%08x\n\tfrontier - nursery = %u\n\tlimitPlusSlop - frontier = %d\n",
+ fprintf (stream, "GC state\n"
+ "\tcardMap = 0x%08x\n"
+ "\toldGen = 0x%08x\n"
+ "\toldGenSize = %s\n"
+ "\toldGen + oldGenSize = 0x%08x\n"
+ "\tnursery = 0x%08x\n"
+ "\tfrontier = 0x%08x\n"
+ "\tfrontier - nursery = %td\n"
+ "\tlimitPlusSlop - frontier = %td\n",
(uint) s->cardMap,
(uint) s->heap.start,
uintToCommaString (s->oldGenSize),
@@ -343,7 +351,9 @@
s->limitPlusSlop - s->frontier);
fprintf (stream, "\tcanHandle = %d\n\tsignalsIsPending = %d\n", s->canHandle, s->signalIsPending);
fprintf (stderr, "\tcurrentThread = 0x%08x\n", (uint) s->currentThread);
- fprintf (stream, "\tstackBottom = 0x%08x\n\tstackTop - stackBottom = %u\n\tstackLimit - stackTop = %u\n",
+ fprintf (stream, "\tstackBottom = 0x%08x\n"
+ "\tstackTop - stackBottom = %td\n"
+ "\tstackLimit - stackTop = %td\n",
(uint)s->stackBottom,
s->stackTop - s->stackBottom,
(s->stackLimit - s->stackTop));
@@ -764,7 +774,7 @@
/* Invariant: top points just past a "return address". */
returnAddress = *(word*) (top - WORD_SIZE);
if (DEBUG) {
- fprintf (stderr, " top = %d return address = ",
+ fprintf (stderr, " top = %td return address = ",
top - bottom);
fprintf (stderr, "0x%08x.\n", returnAddress);
}
@@ -2323,7 +2333,7 @@
*/
assert (stackBottom (s, (GC_stack)cur) <= top);
if (DEBUG_MARK_COMPACT)
- fprintf (stderr, "markInStack top = %d\n",
+ fprintf (stderr, "markInStack top = %td\n",
top - stackBottom (s, (GC_stack)cur));
if (top == stackBottom (s, (GC_stack)(cur)))
@@ -2554,7 +2564,8 @@
* busted.
*/
if (DEBUG_MARK_COMPACT)
- fprintf (stderr, "compressing from 0x%08x to 0x%08x (length = %u)\n",
+ fprintf (stderr, "compressing from 0x%08x to 0x%08x "
+ "(length = %td)\n",
(uint)endOfLastMarked,
(uint)front,
front - endOfLastMarked);
@@ -3378,7 +3389,7 @@
from = s->savedThread;
s->savedThread = BOGUS_THREAD;
if (DEBUG_THREADS) {
- fprintf (stderr, "free space = %u\n",
+ fprintf (stderr, "free space = %td\n",
s->limitPlusSlop - s->frontier);
fprintf (stderr, "0x%08x = copyThread (0x%08x)\n",
(uint)to, (uint)from);
Added: mlton/trunk/runtime/platform/hpux.c
===================================================================
--- mlton/trunk/runtime/platform/hpux.c 2006-04-24 21:21:40 UTC (rev 4406)
+++ mlton/trunk/runtime/platform/hpux.c 2006-04-24 21:45:47 UTC (rev 4407)
@@ -0,0 +1,110 @@
+#include "platform.h"
+
+#include <sys/mman.h>
+#define MAP_ANON MAP_ANONYMOUS
+
+#include <sys/param.h>
+#include <sys/pstat.h>
+#include <sys/newsig.h>
+
+#include "ssmmap.c"
+#include "getrusage.c"
+#include "use-mmap.c"
+#include "mkdir2.c"
+#include "setenv.putenv.c"
+
+W32 totalRam (GC_state s) {
+ struct pst_static buf;
+
+ if (pstat_getstatic (&buf, sizeof(buf), 1, 0) < 0)
+ diee ("failed to get physical memory size");
+ return buf.physical_memory * buf.page_size;
+}
+
+
+struct pstnames {
+ int type;
+ char *name;
+};
+
+static struct pstnames pst_type_names[] =
+ {{ PS_NOTUSED, "unused" },
+ { PS_USER_AREA, "user" },
+ { PS_TEXT, "text" },
+ { PS_DATA, "data" },
+ { PS_STACK, "stack" },
+ { PS_SHARED, "shared" },
+ { PS_NULLDEREF, "null" },
+ { PS_IO, "io" },
+ { PS_MMF, "mmap" },
+ { PS_GRAPHICS, "gfx" },
+ { PS_GRAPHICS_DMA, "gfxdma" },
+#ifdef PS_RSESTACK
+ { PS_RSESTACK, "rsestack" },
+#endif
+ { 0, NULL }};
+
+static const char *
+pst_type_name(int type)
+{
+ int i;
+
+ for (i = 0; pst_type_names[i].name; i++)
+ if (pst_type_names[i].type == type)
+ return pst_type_names[i].name;
+ return "unknown";
+}
+
+static const char*
+pst_filename(struct pst_vm_status vm)
+{
+ static char fname[256];
+#ifdef PSTAT_FILEDETAILS
+ if (pstat_getpathname(fname, sizeof(fname), &vm.pst_fid) < 0)
+#endif
+ strcpy(fname, "unknown");
+ return fname;
+}
+
+void showMem () {
+ int i;
+ struct pst_vm_status buf;
+ size_t page_size = sysconf(_SC_PAGE_SIZE);
+
+ printf("va_start va_end perms type phys filename\n");
+ printf("--------+--------+-----+-------+------+-----------\n");
+ for (i = 0;; i++) {
+ if (pstat_getprocvm (&buf, sizeof(buf), 0, i) < 0)
+ break;
+ printf("%p %p %s%s%s %-8s %4d %s\n",
+ (void*)buf.pst_vaddr,
+ (void*)buf.pst_vaddr + buf.pst_length * page_size - 1,
+ (buf.pst_flags & PS_PROT_READ) ? "-" : "r",
+ (buf.pst_flags & PS_PROT_WRITE) ? "-" : "w",
+ (buf.pst_flags & PS_PROT_EXECUTE) ? "-" : "x",
+ pst_type_name(buf.pst_type),
+ buf.pst_phys_pages,
+ pst_filename(buf));
+ }
+}
+
+
+static void catcher (int sig, siginfo_t* sip, void* mystery) {
+ ucontext_t* ucp = (ucontext_t*)mystery;
+ GC_handleSigProf ((pointer) (ucp->uc_link));
+}
+
+void setSigProfHandler (struct sigaction *sa) {
+ sa->sa_flags = SA_ONSTACK | SA_RESTART | SA_SIGINFO;
+ sa->sa_sigaction = (void (*)(int, siginfo_t*, void*))catcher;
+}
+
+extern void *__text_start;
+extern void *etext;
+
+void *getTextStart () {
+ return &__text_start;
+}
+void *getTextEnd () {
+ return &etext;
+}
Added: mlton/trunk/runtime/platform/hpux.h
===================================================================
--- mlton/trunk/runtime/platform/hpux.h 2006-04-24 21:21:40 UTC (rev 4406)
+++ mlton/trunk/runtime/platform/hpux.h 2006-04-24 21:45:47 UTC (rev 4407)
@@ -0,0 +1,43 @@
+#ifndef _XOPEN_SOURCE_EXTENDED
+#define _XOPEN_SOURCE_EXTENDED
+#endif
+
+#include <math.h>
+#include <signal.h>
+#include <sys/ptrace.h>
+#include <sys/poll.h>
+#include <sys/socket.h>
+#include <sys/un.h>
+#include <sys/times.h>
+#include <sys/utsname.h>
+#include <termios.h>
+#include <netinet/in.h>
+#include <netinet/tcp.h>
+#include <netdb.h>
+#include <grp.h>
+#include <fenv.h>
+#include <syslog.h>
+
+#include "setenv.h"
+
+#define HAS_FEROUND TRUE
+#define HAS_FPCLASSIFY TRUE
+#define HAS_PTRACE FALSE
+#define HAS_REMAP FALSE
+#define HAS_SIGALTSTACK TRUE
+#define HAS_SIGNBIT TRUE
+#define HAS_SPAWN FALSE
+#define HAS_TIME_PROFILING TRUE
+
+#define MLton_Platform_OS_host "hpux"
+
+#define LOG_PERROR 0
+#define LOG_AUTHPRIV LOG_AUTH
+
+#define MSG_DONTWAIT 0
+
+#ifndef PF_INET6
+/* Old versions of HP-UX don't have IPv6 support. */
+struct sockaddr_in6 {};
+#define PF_INET6 0
+#endif
Added: mlton/trunk/runtime/platform/setenv.putenv.c
===================================================================
--- mlton/trunk/runtime/platform/setenv.putenv.c 2006-04-24 21:21:40 UTC (rev 4406)
+++ mlton/trunk/runtime/platform/setenv.putenv.c 2006-04-24 21:45:47 UTC (rev 4407)
@@ -0,0 +1,13 @@
+/* This implementation of setenv has a space leak, but I don't see how to avoid
+ * it, since the specification of putenv is that it uses the memory for its arg.
+ */
+int setenv (const char *name, const char *value, int overwrite) {
+ char *b;
+
+ if (!overwrite && getenv (name))
+ return 0;
+
+ b = malloc (strlen (name) + strlen (value) + 2 /* = and \000 */);
+ sprintf (b, "%s=%s", name, value);
+ return putenv (b);
+}
Modified: mlton/trunk/runtime/platform/solaris.c
===================================================================
--- mlton/trunk/runtime/platform/solaris.c 2006-04-24 21:21:40 UTC (rev 4406)
+++ mlton/trunk/runtime/platform/solaris.c 2006-04-24 21:45:47 UTC (rev 4407)
@@ -9,6 +9,7 @@
#include "signbit.c"
#include "ssmmap.c"
#include "totalRam.sysconf.c"
+#include "setenv.putenv.c"
static void catcher (int sig, siginfo_t *sip, ucontext_t *ucp) {
GC_handleSigProf ((pointer) ucp->uc_mcontext.gregs[REG_PC]);
@@ -85,17 +86,6 @@
smunmap (base, length);
}
-/* This implementation of setenv has a space leak, but I don't see how to avoid
- * it, since the specification of putenv is that it uses the memory for its arg.
- */
-int setenv (const char *name, const char *value, int overwrite) {
- char *b;
-
- b = malloc (strlen (name) + strlen (value) + 2 /* = and \000 */);
- sprintf (b, "%s=%s", name, value);
- return putenv (b);
-}
-
void showMem () {
static char buffer[256];
sprintf (buffer, "pmap %d\n", (int)(getpid ()));
Modified: mlton/trunk/runtime/platform.h
===================================================================
--- mlton/trunk/runtime/platform.h 2006-04-24 21:21:40 UTC (rev 4406)
+++ mlton/trunk/runtime/platform.h 2006-04-24 21:45:47 UTC (rev 4407)
@@ -1,4 +1,4 @@
-/* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
+/* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-2000 NEC Research Institute.
*
@@ -64,6 +64,8 @@
#include "platform/darwin.h"
#elif (defined (__FreeBSD__))
#include "platform/freebsd.h"
+#elif (defined (__hpux__))
+#include "platform/hpux.h"
#elif (defined (__linux__))
#include "platform/linux.h"
#elif (defined (__MINGW32__))
@@ -271,8 +273,8 @@
void swrite (int fd, const void *buf, size_t count);
void swriteUint (int fd, uint n);
/*
- * totalRam returns the amount of physical memory on the machine.
- */
+ * totalRam returns the amount of physical memory on the machine (in
+ * bytes). */
Word32 totalRam (GC_state s);
string uintToCommaString (uint n);
string ullongToCommaString (ullong n);
Modified: mlton/trunk/runtime/types.h
===================================================================
--- mlton/trunk/runtime/types.h 2006-04-24 21:21:40 UTC (rev 4406)
+++ mlton/trunk/runtime/types.h 2006-04-24 21:45:47 UTC (rev 4407)
@@ -1,4 +1,4 @@
-/* Copyright (C) 2004-2005 Henry Cejtin, Matthew Fluet, Suresh
+/* Copyright (C) 2004-2006 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
*
* MLton is released under a BSD-style license.
@@ -16,7 +16,7 @@
#ifndef _ISOC99_SOURCE
#define _ISOC99_SOURCE
#endif
-#if (defined (__OpenBSD__))
+#if (defined(__hpux__) || defined (__OpenBSD__))
#include <inttypes.h>
#elif (defined (__sun__))
#include <sys/int_types.h>
|
|
From: Stephen W. <sw...@ml...> - 2006-04-24 14:21:40
|
Removed. ---------------------------------------------------------------------- D mlton/tags/on-20051109-release/ ---------------------------------------------------------------------- |
|
From: Stephen W. <sw...@ml...> - 2006-04-24 14:19:59
|
Tagged release. ---------------------------------------------------------------------- A mlton/tags/on-20051202-release/ ---------------------------------------------------------------------- Copied: mlton/tags/on-20051202-release (from rev 4285, mlton/trunk) |
|
From: Stephen W. <sw...@ml...> - 2006-04-24 13:49:21
|
Clean up before untarring, otherwise one gets errors of the following form when applying the patch. The next patch would create the file MLRISC/cm/proxyLib.cm, which already exists! Assume -R? [n] ---------------------------------------------------------------------- U mlton/trunk/lib/mlrisc-lib/Makefile ---------------------------------------------------------------------- Modified: mlton/trunk/lib/mlrisc-lib/Makefile =================================================================== --- mlton/trunk/lib/mlrisc-lib/Makefile 2006-04-24 11:47:41 UTC (rev 4403) +++ mlton/trunk/lib/mlrisc-lib/Makefile 2006-04-24 20:49:20 UTC (rev 4404) @@ -9,6 +9,7 @@ all: MLRISC/README.mlton MLRISC/README.mlton: MLRISC.tgz MLRISC.patch + rm -rf MLRISC gzip -dc MLRISC.tgz | tar xf - chmod -R a+r MLRISC chmod -R g-s MLRISC |
|
From: Matthew F. <fl...@ml...> - 2006-04-24 04:47:42
|
Removed debugging ---------------------------------------------------------------------- U mlton/branches/on-20050822-x86_64-branch/runtime/gc/debug.h ---------------------------------------------------------------------- Modified: mlton/branches/on-20050822-x86_64-branch/runtime/gc/debug.h =================================================================== --- mlton/branches/on-20050822-x86_64-branch/runtime/gc/debug.h 2006-04-24 03:37:43 UTC (rev 4402) +++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/debug.h 2006-04-24 11:47:41 UTC (rev 4403) @@ -32,6 +32,6 @@ DEBUG_THREADS = FALSE, DEBUG_WEAK = FALSE, DEBUG_WORLD = FALSE, - FORCE_GENERATIONAL = TRUE, + FORCE_GENERATIONAL = FALSE, FORCE_MARK_COMPACT = FALSE, }; |
|
From: Matthew F. <fl...@ml...> - 2006-04-23 20:37:46
|
Merge trunk revisions r4397:4400 into x86_64 branch
----------------------------------------------------------------------
U mlton/branches/on-20050822-x86_64-branch/doc/changelog
U mlton/branches/on-20050822-x86_64-branch/runtime/gc/debug.h
U mlton/branches/on-20050822-x86_64-branch/runtime/gc/dfs-mark.c
U mlton/branches/on-20050822-x86_64-branch/runtime/gc/generational.c
U mlton/branches/on-20050822-x86_64-branch/runtime/gc/generational.h
U mlton/branches/on-20050822-x86_64-branch/runtime/gc/hash-cons.c
----------------------------------------------------------------------
Modified: mlton/branches/on-20050822-x86_64-branch/doc/changelog
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/doc/changelog 2006-04-24 03:15:53 UTC (rev 4401)
+++ mlton/branches/on-20050822-x86_64-branch/doc/changelog 2006-04-24 03:37:43 UTC (rev 4402)
@@ -1,3 +1,10 @@
+Here are the changes since version 20051202.
+
+* 2006-04-19
+ - Fixed a bug in MLton.share that could cause a segfault.
+
+--------------------------------------------------------------------------------
+
Here are the changes from version 20041109 to version 20051202.
Summary:
Modified: mlton/branches/on-20050822-x86_64-branch/runtime/gc/debug.h
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/debug.h 2006-04-24 03:15:53 UTC (rev 4401)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/debug.h 2006-04-24 03:37:43 UTC (rev 4402)
@@ -32,6 +32,6 @@
DEBUG_THREADS = FALSE,
DEBUG_WEAK = FALSE,
DEBUG_WORLD = FALSE,
- FORCE_GENERATIONAL = FALSE,
+ FORCE_GENERATIONAL = TRUE,
FORCE_MARK_COMPACT = FALSE,
};
Modified: mlton/branches/on-20050822-x86_64-branch/runtime/gc/dfs-mark.c
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/dfs-mark.c 2006-04-24 03:15:53 UTC (rev 4401)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/dfs-mark.c 2006-04-24 03:37:43 UTC (rev 4402)
@@ -301,6 +301,8 @@
prev = fetchObjptrToPointer (todo, s->heap.start);
// *(pointer*)todo = next;
storeObjptrFromPointer (todo, next, s->heap.start);
+ if (shouldHashCons)
+ markIntergenerationalPointer (s, (pointer*)todo);
goto markNextInNormal;
} else if (ARRAY_TAG == tag) {
arrayIndex = getArrayCounter (cur);
@@ -311,6 +313,8 @@
prev = fetchObjptrToPointer (todo, s->heap.start);
// *(pointer*)todo = next;
storeObjptrFromPointer (todo, next, s->heap.start);
+ if (shouldHashCons)
+ markIntergenerationalPointer (s, (pointer*)todo);
goto markNextInArray;
} else {
assert (STACK_TAG == tag);
@@ -325,6 +329,8 @@
prev = fetchObjptrToPointer (todo, s->heap.start);
// *(pointer*)todo = next;
storeObjptrFromPointer (todo, next, s->heap.start);
+ if (shouldHashCons)
+ markIntergenerationalPointer (s, (pointer*)todo);
index++;
goto markInFrame;
}
Modified: mlton/branches/on-20050822-x86_64-branch/runtime/gc/generational.c
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/generational.c 2006-04-24 03:15:53 UTC (rev 4401)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/generational.c 2006-04-24 03:37:43 UTC (rev 4402)
@@ -65,6 +65,20 @@
*(pointerToCardMapAddr (s, p)) = 0x1;
}
+void markIntergenerationalPointer (GC_state s, pointer *pp) {
+ if (s->mutatorMarksCards
+ and isPointerInOldGen (s, (pointer)pp)
+ and isPointerInNursery (s, *pp))
+ markCard (s, (pointer)pp);
+}
+
+void markIntergenerationalObjptr (GC_state s, objptr *opp) {
+ if (s->mutatorMarksCards
+ and isPointerInOldGen (s, (pointer)opp)
+ and isObjptrInNursery (s, *opp))
+ markCard (s, (pointer)opp);
+}
+
void setCardMapAbsolute (GC_state s) {
unless (s->mutatorMarksCards)
return;
Modified: mlton/branches/on-20050822-x86_64-branch/runtime/gc/generational.h
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/generational.h 2006-04-24 03:15:53 UTC (rev 4401)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/generational.h 2006-04-24 03:37:43 UTC (rev 4402)
@@ -63,6 +63,8 @@
static inline bool isCardMarked (GC_state s, pointer p);
static inline void markCard (GC_state s, pointer p);
+static inline void markIntergenerationalPointer (GC_state s, pointer *pp);
+static inline void markIntergenerationalObjptr (GC_state s, objptr *opp);
static inline void setCardMapAbsolute (GC_state s);
static inline pointer getCrossMapCardStart (GC_state s, pointer p);
Modified: mlton/branches/on-20050822-x86_64-branch/runtime/gc/hash-cons.c
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/hash-cons.c 2006-04-24 03:15:53 UTC (rev 4401)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/hash-cons.c 2006-04-24 03:37:43 UTC (rev 4402)
@@ -236,7 +236,7 @@
pointer res;
if (DEBUG_SHARE)
- fprintf (stderr, "hashCons ("FMTPTR")\n", (uintptr_t)object);
+ fprintf (stderr, "hashConsPointer ("FMTPTR")\n", (uintptr_t)object);
t = s->objectHashTable;
header = getHeader (object);
splitHeader(s, header, &tag, &hasIdentity, &bytesNonObjptrs, &numObjptrs);
@@ -281,10 +281,11 @@
p = objptrToPointer (*opp, s->heap.start);
if (DEBUG_SHARE)
- fprintf (stderr, "shareObjptrMaybe opp = "FMTPTR" *opp = "FMTOBJPTR"\n",
+ fprintf (stderr, "shareObjptr opp = "FMTPTR" *opp = "FMTOBJPTR"\n",
(uintptr_t)opp, *opp);
p = hashConsPointer (s, p, FALSE);
*opp = pointerToObjptr (p, s->heap.start);
+ markIntergenerationalObjptr (s, opp);
}
void printBytesHashConsedMessage (GC_state s, uintmax_t total) {
|
|
From: Matthew F. <fl...@ml...> - 2006-04-23 20:15:53
|
Missed change when merging trunk revisions r4363:4396 into x86_64 branch
----------------------------------------------------------------------
U mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/primitive.sml
----------------------------------------------------------------------
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/primitive.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/primitive.sml 2006-04-19 20:09:54 UTC (rev 4400)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/primitive.sml 2006-04-24 03:15:53 UTC (rev 4401)
@@ -1691,3 +1691,5 @@
"unhandled exception in Basis Library\000")))
in
end
+
+val op + = Primitive.Int.+
|
|
From: Stephen W. <sw...@ml...> - 2006-04-19 13:09:56
|
Fixed a bug in GC_share that could cause a segfault. The problem was
that GC_share could introduce intergenerational pointers, but didn't
update the card map. Now, it marks the appropriate card whenever it
creates an intergenerational pointer.
----------------------------------------------------------------------
U mlton/trunk/doc/changelog
U mlton/trunk/runtime/gc.c
----------------------------------------------------------------------
Modified: mlton/trunk/doc/changelog
===================================================================
--- mlton/trunk/doc/changelog 2006-04-19 02:46:47 UTC (rev 4399)
+++ mlton/trunk/doc/changelog 2006-04-19 20:09:54 UTC (rev 4400)
@@ -1,3 +1,10 @@
+Here are the changes since version 20051202.
+
+* 2006-04-19
+ - Fixed a bug in MLton.share that could cause a segfault.
+
+--------------------------------------------------------------------------------
+
Here are the changes from version 20041109 to version 20051202.
Summary:
Modified: mlton/trunk/runtime/gc.c
===================================================================
--- mlton/trunk/runtime/gc.c 2006-04-19 02:46:47 UTC (rev 4399)
+++ mlton/trunk/runtime/gc.c 2006-04-19 20:09:54 UTC (rev 4400)
@@ -880,12 +880,12 @@
return s->nursery <= p and p < s->frontier;
}
-#if ASSERT
-
static inline bool isInOldGen (GC_state s, pointer p) {
return s->heap.start <= p and p < s->heap.start + s->oldGenSize;
}
+#if ASSERT
+
static inline bool isInFromSpace (GC_state s, pointer p) {
return (isInOldGen (s, p) or isInNursery (s, p));
}
@@ -2094,6 +2094,13 @@
return res;
}
+static inline void markIntergenerational (GC_state s, Pointer *pp) {
+ if (s->mutatorMarksCards
+ and isInOldGen (s, (pointer)pp)
+ and isInNursery (s, *pp))
+ markCard (s, (pointer)pp);
+}
+
static inline void maybeSharePointer (GC_state s,
Pointer *pp,
Bool shouldHashCons) {
@@ -2103,6 +2110,7 @@
fprintf (stderr, "maybeSharePointer pp = 0x%08x *pp = 0x%08x\n",
(uint)pp, (uint)*pp);
*pp = hashCons (s, *pp, FALSE);
+ markIntergenerational (s, pp);
}
/* ---------------------------------------------------------------- */
@@ -2377,6 +2385,8 @@
todo += index * POINTER_SIZE;
prev = *(pointer*)todo;
*(pointer*)todo = next;
+ if (shouldHashCons)
+ markIntergenerational (s, (pointer*)todo);
goto markNextInNormal;
} else if (ARRAY_TAG == tag) {
arrayIndex = arrayCounter (cur);
@@ -2386,6 +2396,8 @@
todo += numNonPointers + index * POINTER_SIZE;
prev = *(pointer*)todo;
*(pointer*)todo = next;
+ if (shouldHashCons)
+ markIntergenerational (s, (pointer*)todo);
goto markNextInArray;
} else {
assert (STACK_TAG == tag);
@@ -2396,6 +2408,8 @@
todo = top - layout->numBytes + frameOffsets [index + 1];
prev = *(pointer*)todo;
*(pointer*)todo = next;
+ if (shouldHashCons)
+ markIntergenerational (s, (pointer*)todo);
index++;
goto markInFrame;
}
|
|
From: Matthew F. <fl...@ml...> - 2006-04-18 19:46:51
|
Manually ported basis Library implementation changes to basis refactoring
----------------------------------------------------------------------
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/arrays-and-vectors/array.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/arrays-and-vectors/array2.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/arrays-and-vectors/mono-array.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/arrays-and-vectors/mono-vector.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/arrays-and-vectors/sequence.fun
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/arrays-and-vectors/sequence.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/arrays-and-vectors/vector.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/arrays-and-vectors/vector.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/build/sources.mlb
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/int.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/array.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/cont.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/vector.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-mlton.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/util/one.sml
----------------------------------------------------------------------
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/arrays-and-vectors/array.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/arrays-and-vectors/array.sig 2006-04-19 02:37:13 UTC (rev 4398)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/arrays-and-vectors/array.sig 2006-04-19 02:46:47 UTC (rev 4399)
@@ -51,5 +51,5 @@
val concat: 'a array list -> 'a array
val duplicate: 'a array -> 'a array
val toList: 'a array -> 'a list
- val unfoldi: int * 'a * (int * 'a -> 'b * 'a) -> 'b array
+ val unfoldi: int * 'b * (int * 'b -> 'a * 'b) -> 'a array * 'b
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/arrays-and-vectors/array2.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/arrays-and-vectors/array2.sml 2006-04-19 02:37:13 UTC (rev 4398)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/arrays-and-vectors/array2.sml 2006-04-19 02:46:47 UTC (rev 4399)
@@ -298,74 +298,12 @@
fun modify trv f a = modifyi trv (f o #3) (wholeRegion a)
fun tabulate trv (rows, cols, f) =
-(*
- if !Primitive.usesCallcc
- then
- (* All this mess is careful to construct a list representing
- * the array and then convert the list to the array after all
- * the calls to f have been made, in case f uses callcc.
- *)
- let
- val size =
- if Primitive.safe andalso (rows < 0 orelse cols < 0)
- then raise Size
- else rows * cols handle Overflow => raise Size
- val (rows', cols', f) =
- case trv of
- RowMajor => (rows, cols, f)
- | ColMajor => (cols, rows, fn (c, r) => f (r, c))
- fun loopr (r, l) =
- if r >= rows'
- then l
- else
- let
- fun loopc (c, l) =
- if c >= cols'
- then l
- else loopc (c + 1, f (r, c) :: l)
- in loopr (r + 1, loopc (0, l))
- end
- val l = loopr (0, [])
- val a = Primitive.Array.array size
- in case trv of
- RowMajor =>
- (* The list holds the elements in row major order,
- * but reversed.
- *)
- let
- val _ =
- List.foldl (fn (x, i) =>
- (Primitive.Array.update (a, i, x)
- ; i -? 1))
- (size -? 1) l
- in
- ()
- end
- | ColMajor =>
- (* The list holds the elements in column major order,
- * but reversed.
- *)
- let
- val _ =
- List.foldl (fn (x, (spot, r)) =>
- (Primitive.Array.update (a, spot, x)
- ; if r = 0
- then (spot -? 1 +? size -? cols,
- rows -? 1)
- else (spot -? cols, r -? 1)))
- (size -? 1, rows -? 1)
- l
- in
- ()
- end
- ; {rows = rows, cols = cols, array = a}
- end
- else
-*)
- let val a = arrayUninit (rows, cols)
- in modifyi trv (fn (r, c, _) => f (r, c)) (wholeRegion a)
- ; a
- end
+ let
+ val a = arrayUninit (rows, cols)
+ val () = modifyi trv (fn (r, c, _) => f (r, c)) (wholeRegion a)
+ in
+ a
+ end
fun copy {src = src as {base, ...}: 'a region,
dst, dst_row, dst_col} =
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/arrays-and-vectors/mono-array.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/arrays-and-vectors/mono-array.sig 2006-04-19 02:37:13 UTC (rev 4398)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/arrays-and-vectors/mono-array.sig 2006-04-19 02:46:47 UTC (rev 4399)
@@ -44,7 +44,7 @@
val fromPoly: elem Array.array -> array
val toList: array -> elem list
val toPoly: array -> elem Array.array
- val unfoldi: int * 'a * (int * 'a -> elem * 'a) -> array
+ val unfoldi: int * 'a * (int * 'a -> elem * 'a) -> array * 'a
val unsafeSub: array * int -> elem
val unsafeUpdate: array * int * elem -> unit
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/arrays-and-vectors/mono-vector.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/arrays-and-vectors/mono-vector.sig 2006-04-19 02:37:13 UTC (rev 4398)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/arrays-and-vectors/mono-vector.sig 2006-04-19 02:46:47 UTC (rev 4399)
@@ -41,7 +41,7 @@
val toList: vector -> elem list
val tokens: (elem -> bool) -> vector -> vector list
val translate: (elem -> vector) -> vector -> vector
- val unfoldi: int * 'a * (int * 'a -> elem * 'a) -> vector
+ val unfoldi: int * 'a * (int * 'a -> elem * 'a) -> vector * 'a
val unsafeSub: vector * int -> elem
val vector: int * elem -> vector
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/arrays-and-vectors/sequence.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/arrays-and-vectors/sequence.fun 2006-04-19 02:37:13 UTC (rev 4398)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/arrays-and-vectors/sequence.fun 2006-04-19 02:46:47 UTC (rev 4399)
@@ -35,6 +35,8 @@
fun wrap1 f = fn (i) => f (SeqIndex.toIntUnsafe i)
fun wrap2 f = fn (i, x) => f (SeqIndex.toIntUnsafe i, x)
fun wrap3 f = fn (i, x, y) => f (SeqIndex.toIntUnsafe i, x, y)
+ fun unwrap1 f = fn (i) => f (SeqIndex.fromIntUnsafe i)
+ fun unwrap2 f = fn (i, x) => f (SeqIndex.fromIntUnsafe i, x)
type 'a sequence = 'a S.sequence
type 'a elt = 'a S.elt
@@ -90,30 +92,70 @@
fun seq0 () = S.fromArray (arrayUninit' 0)
+ fun generate' (n, f) =
+ let
+ val a = arrayUninit' n
+ val subLim = ref 0
+ fun sub i =
+ if Primitive.Controls.safe andalso geu (i, !subLim)
+ then raise Subscript
+ else Array.subUnsafe (a, i)
+ val updateLim = ref 0
+ fun update (i, x) =
+ if Primitive.Controls.safe andalso geu (i, !updateLim)
+ then raise Subscript
+ else Array.updateUnsafe (a, i, x)
+ val (tab, finish) = f {sub = sub, update = update}
+ fun loop i =
+ if i >= n
+ then ()
+ else let
+ val () = Array.updateUnsafe (a, i, tab i)
+ val () = subLim := i +? 1
+ val () = updateLim := i +? 1
+ in
+ loop (i +? 1)
+ end
+ val () = loop 0
+ val () = finish ()
+ val () = updateLim := 0
+ in
+ S.fromArray a
+ end
+ fun generate (n, f) =
+ generate' (fromIntForLength n,
+ fn {sub, update} =>
+ let
+ val (tab, finish) =
+ f {sub = unwrap1 sub, update = unwrap2 update}
+ in
+ (wrap1 tab, finish)
+ end)
+
fun unfoldi' (n, b, f) =
let
val a = arrayUninit' n
fun loop (i, b) =
if i >= n
- then ()
+ then b
else
let
val (x, b') = f (i, b)
- val _ = Array.updateUnsafe (a, i, x)
+ val () = Array.updateUnsafe (a, i, x)
in
loop (i +? 1, b')
end
- val _ = loop (0, b)
+ val b = loop (0, b)
in
- S.fromArray a
+ (S.fromArray a, b)
end
fun unfoldi (n, b, f) = unfoldi' (fromIntForLength n, b, wrap2 f)
fun unfold (n, b, f) = unfoldi (n, b, f o #2)
fun tabulate' (n, f) =
- unfoldi' (n, (), fn (i, ()) => (f i, ()))
+ #1 (unfoldi' (n, (), fn (i, ()) => (f i, ())))
fun tabulate (n, f) =
- unfoldi (n, (), fn (i, ()) => (f i, ()))
+ #1 (unfoldi (n, (), fn (i, ()) => (f i, ())))
fun new' (n, x) = tabulate' (n, fn _ => x)
fun new (n, x) = tabulate (n, fn _ => x)
@@ -328,13 +370,13 @@
val l2 = length' sl2
val n = (l1 + l2) handle Overflow => raise Size
in
- unfoldi' (n, (0, sl1),
- fn (_, (i, sl)) =>
- if SeqIndex.< (i, length' sl)
- then (unsafeSub' (sl, i),
- (i +? 1, sl))
- else (unsafeSub' (sl2, 0),
- (1, sl2)))
+ #1 (unfoldi'
+ (n, (0, sl1), fn (_, (i, sl)) =>
+ if SeqIndex.< (i, length' sl)
+ then (unsafeSub' (sl, i),
+ (i +? 1, sl))
+ else (unsafeSub' (sl2, 0),
+ (1, sl2))))
end
fun concat (sls: 'a slice list): 'a sequence =
case sls of
@@ -346,18 +388,18 @@
(List.foldl (fn (sl, s) => s +? length' sl) 0 sls')
handle Overflow => raise Size
in
- unfoldi' (n, (0, sl, sls),
- fn (_, ac) =>
- let
- fun loop (i, sl, sls) =
- if SeqIndex.< (i, length' sl)
- then (unsafeSub' (sl, i),
- (i +? 1, sl, sls))
- else case sls of
- [] => raise Fail "Sequence.Slice.concat"
- | sl :: sls => loop (0, sl, sls)
- in loop ac
- end)
+ #1 (unfoldi'
+ (n, (0, sl, sls), fn (_, ac) =>
+ let
+ fun loop (i, sl, sls) =
+ if SeqIndex.< (i, length' sl)
+ then (unsafeSub' (sl, i),
+ (i +? 1, sl, sls))
+ else case sls of
+ [] => raise Fail "Sequence.Slice.concat"
+ | sl :: sls => loop (0, sl, sls)
+ in loop ac
+ end))
end
fun concatWith (sep: 'a sequence) (sls: 'a slice list): 'a sequence =
let val sep = full sep
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/arrays-and-vectors/sequence.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/arrays-and-vectors/sequence.sig 2006-04-19 02:37:13 UTC (rev 4398)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/arrays-and-vectors/sequence.sig 2006-04-19 02:46:47 UTC (rev 4399)
@@ -80,12 +80,22 @@
val create: (SeqIndex.int * (SeqIndex.int -> 'b elt) -> 'c) ->
('a elt -> 'b elt) -> 'a sequence -> 'c
val duplicate: 'a sequence -> 'a sequence
+ val generate':
+ SeqIndex.int * ({sub: SeqIndex.int -> 'a elt,
+ update: SeqIndex.int * 'a elt -> unit}
+ -> (SeqIndex.int -> 'a elt) * (unit -> unit))
+ -> 'a sequence
+ val generate:
+ int * ({sub: int -> 'a elt,
+ update: int * 'a elt -> unit}
+ -> (int -> 'a elt) * (unit -> unit))
+ -> 'a sequence
val newUninit': SeqIndex.int -> 'a sequence
val newUninit: int -> 'a sequence
val new': SeqIndex.int * 'a elt -> 'a sequence
val new: int * 'a elt -> 'a sequence
val toList: 'a sequence -> 'a elt list
- val unfoldi': SeqIndex.int * 'a * (SeqIndex.int * 'a -> 'b elt * 'a) -> 'b sequence
- val unfoldi: int * 'a * (int * 'a -> 'b elt * 'a) -> 'b sequence
- val unfold: int * 'a * ('a -> 'b elt * 'a) -> 'b sequence
+ val unfoldi': SeqIndex.int * 'b * (SeqIndex.int * 'b -> 'a elt * 'b) -> 'a sequence * 'b
+ val unfoldi: int * 'b * (int * 'b -> 'a elt * 'b) -> 'a sequence * 'b
+ val unfold: int * 'b * ('b -> 'a elt * 'b) -> 'a sequence * 'b
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/arrays-and-vectors/vector.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/arrays-and-vectors/vector.sig 2006-04-19 02:37:13 UTC (rev 4398)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/arrays-and-vectors/vector.sig 2006-04-19 02:46:47 UTC (rev 4399)
@@ -47,9 +47,13 @@
val fields: ('a -> bool) -> 'a vector -> 'a vector list
val append: 'a vector * 'a vector -> 'a vector
+ val create:
+ int * ({sub: int -> 'a, update: int * 'a -> unit}
+ -> (int -> 'a) * (unit -> unit))
+ -> 'a vector
val duplicate: 'a vector -> 'a vector
val tabulate': SeqIndex.int * (SeqIndex.int -> 'a) -> 'a vector
val toList: 'a vector -> 'a list
- val unfoldi: int * 'a * (int * 'a -> 'b * 'a) -> 'b vector
+ val unfoldi: int * 'b * (int * 'b -> 'a * 'b) -> 'a vector * 'b
val vector: int * 'a -> 'a vector
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/arrays-and-vectors/vector.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/arrays-and-vectors/vector.sml 2006-04-19 02:37:13 UTC (rev 4398)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/arrays-and-vectors/vector.sml 2006-04-19 02:46:47 UTC (rev 4399)
@@ -60,6 +60,8 @@
val fromArray = Primitive.Vector.fromArray
val vector = new
+
+ fun create (n, f) = generate (n, f)
end
structure VectorSlice: VECTOR_SLICE_EXTRA = Vector.VectorSlice
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/build/sources.mlb
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/build/sources.mlb 2006-04-19 02:37:13 UTC (rev 4398)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/build/sources.mlb 2006-04-19 02:46:47 UTC (rev 4399)
@@ -65,6 +65,7 @@
end end
../general/general.sig
../general/general.sml
+ ../util/one.sml
../general/option.sig
../general/option.sml
../list/list.sig
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/int.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/int.sml 2006-04-19 02:37:13 UTC (rev 4398)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/int.sml 2006-04-19 02:46:47 UTC (rev 4399)
@@ -60,9 +60,11 @@
* The most that will be required is for minInt in binary.
*)
val maxNumDigits = Int.+ (precision', 1)
- val buf = CharArray.array (maxNumDigits, #"\000")
+ val oneBuf = One.make (fn () => CharArray.array (maxNumDigits, #"\000"))
in
fun fmt radix (n: int): string =
+ One.use
+ (oneBuf, fn buf =>
let
val radix = fromInt (StringCvt.radixToInt radix)
fun loop (q, i: Int.int) =
@@ -93,7 +95,7 @@
end
in
loop (if n < zero then n else ~? n, Int.- (maxNumDigits, 1))
- end
+ end)
end
val toString = fmt StringCvt.DEC
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/array.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/array.sig 2006-04-19 02:37:13 UTC (rev 4398)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/array.sig 2006-04-19 02:46:47 UTC (rev 4399)
@@ -10,5 +10,5 @@
signature MLTON_ARRAY =
sig
- val unfoldi: int * 'b * (int * 'b -> 'a * 'b) -> 'a array
+ val unfoldi: int * 'b * (int * 'b -> 'a * 'b) -> 'a array * 'b
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/cont.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/cont.sml 2006-04-19 02:37:13 UTC (rev 4398)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/cont.sml 2006-04-19 02:46:47 UTC (rev 4399)
@@ -24,42 +24,41 @@
type 'a t = (unit -> 'a) -> unit
fun callcc (f: 'a t -> 'a): 'a =
- (dummy ()
- ; if MLtonThread.amInSignalHandler ()
- then die "callcc can not be used in a signal handler\n"
- else
- let
- datatype 'a state =
- Original of 'a t -> 'a
- | Copy of unit -> 'a
- | Clear
- val r: 'a state ref = ref (Original f)
- val _ = Thread.atomicBegin () (* Match 1 *)
- val _ = Thread.copyCurrent ()
- in
- case (!r before r := Clear) of
- Clear => raise Fail "callcc saw Clear"
- | Copy v => (Thread.atomicEnd () (* Match 2 *)
- ; v ())
- | Original f =>
- let
- val t = Thread.savedPre gcState
- in
- Thread.atomicEnd () (* Match 1 *)
- ; f (fn v =>
- let
- val _ = Thread.atomicBegin () (* Match 2 *)
- val _ = r := Copy v
- val new = Thread.copy t
- (* The following Thread.atomicBegin ()
- * is matched by Thread.switchTo.
- *)
- val _ = Thread.atomicBegin ()
- in
- Thread.switchTo new
- end)
- end
- end)
+ if MLtonThread.amInSignalHandler ()
+ then die "callcc can not be used in a signal handler\n"
+ else
+ let
+ datatype 'a state =
+ Original of 'a t -> 'a
+ | Copy of unit -> 'a
+ | Clear
+ val r: 'a state ref = ref (Original f)
+ val _ = Thread.atomicBegin () (* Match 1 *)
+ val _ = Thread.copyCurrent ()
+ in
+ case (!r before r := Clear) of
+ Clear => raise Fail "callcc saw Clear"
+ | Copy v => (Thread.atomicEnd () (* Match 2 *)
+ ; v ())
+ | Original f =>
+ let
+ val t = Thread.savedPre gcState
+ in
+ Thread.atomicEnd () (* Match 1 *)
+ ; f (fn v =>
+ let
+ val _ = Thread.atomicBegin () (* Match 2 *)
+ val _ = r := Copy v
+ val new = Thread.copy t
+ (* The following Thread.atomicBegin ()
+ * is matched by Thread.switchTo.
+ *)
+ val _ = Thread.atomicBegin ()
+ in
+ Thread.switchTo new
+ end)
+ end
+ end)
fun ('a, 'b) throw' (k: 'a t, v: unit -> 'a): 'b =
(k v; raise Fail "throw bug")
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/vector.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/vector.sig 2006-04-19 02:37:13 UTC (rev 4398)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/vector.sig 2006-04-19 02:46:47 UTC (rev 4399)
@@ -10,6 +10,10 @@
signature MLTON_VECTOR =
sig
- val unfoldi: int * 'b * (int * 'b -> 'a * 'b) -> 'a vector
+ val create:
+ int * ({sub: int -> 'a, update: int * 'a -> unit}
+ -> (int -> 'a) * (unit -> unit))
+ -> 'a vector
+ val unfoldi: int * 'b * (int * 'b -> 'a * 'b) -> 'a vector * 'b
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-mlton.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-mlton.sml 2006-04-19 02:37:13 UTC (rev 4398)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-mlton.sml 2006-04-19 02:46:47 UTC (rev 4399)
@@ -31,11 +31,6 @@
val gcState = #1 _symbol "gcStateAddress": t GetSet.t; ()
end
-
-structure Callcc =
- struct
- val usesCallcc: bool ref = ref false
- end
structure CallStack =
struct
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/util/one.sml (from rev 4397, mlton/branches/on-20050822-x86_64-branch/basis-library/misc/one.sml)
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/misc/one.sml 2006-04-19 01:19:31 UTC (rev 4397)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/util/one.sml 2006-04-19 02:46:47 UTC (rev 4399)
@@ -0,0 +1,40 @@
+(* Copyright (C) 2006-2006 Henry Cejtin, Matthew Fluet, Suresh
+ * Jagannathan, and Stephen Weeks.
+ *
+ * MLton is released under a BSD-style license.
+ * See the file MLton-LICENSE for details.
+ *)
+
+structure One:
+ sig
+ type 'a t
+
+ val make: (unit -> 'a) -> 'a t
+ val use: 'a t * ('a -> 'b) -> 'b
+ end =
+ struct
+ datatype 'a t = T of {more: unit -> 'a,
+ static: 'a,
+ staticIsInUse: bool ref}
+
+ fun make f = T {more = f,
+ static = f (),
+ staticIsInUse = ref false}
+
+ fun use (T {more, static, staticIsInUse}, f) =
+ let
+ val () = Primitive.MLton.Thread.atomicBegin ()
+ val b = ! staticIsInUse
+ val d =
+ if b then
+ (Primitive.MLton.Thread.atomicEnd ();
+ more ())
+ else
+ (staticIsInUse := true;
+ Primitive.MLton.Thread.atomicEnd ();
+ static)
+ in
+ DynamicWind.wind (fn () => f d,
+ fn () => if b then () else staticIsInUse := false)
+ end
+ end
|
|
From: Matthew F. <fl...@ml...> - 2006-04-18 19:37:14
|
Configuration with Real = Real32
----------------------------------------------------------------------
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/default/large-real.sml
A mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/maps/default-real32.map
----------------------------------------------------------------------
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/default/large-real.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/default/large-real.sml 2006-04-19 01:19:31 UTC (rev 4397)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/default/large-real.sml 2006-04-19 02:37:13 UTC (rev 4398)
@@ -8,5 +8,5 @@
structure LargeReal = Real64
functor LargeReal_ChooseRealN (A: CHOOSE_REALN_ARG) :
- sig val f : Real.real A.t end =
+ sig val f : LargeReal.real A.t end =
ChooseRealN_Real64 (A)
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/maps/default-real32.map (from rev 4396, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/maps/default-real64.map)
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/maps/default-real64.map 2006-04-19 00:53:39 UTC (rev 4396)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/maps/default-real32.map 2006-04-19 02:37:13 UTC (rev 4398)
@@ -0,0 +1 @@
+DEFAULT_REAL default-real32.sml
|
|
From: Matthew F. <fl...@ml...> - 2006-04-18 18:19:38
|
Merge trunk revisions r4363:4396 into x86_64 branch
----------------------------------------------------------------------
U mlton/branches/on-20050822-x86_64-branch/Makefile
U mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/array.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/array2.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/mono-array.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/mono-vector.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/sequence.fun
U mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/sequence.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/vector.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/vector.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/integer/int.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/libs/basis-extra/basis-extra.mlb
A mlton/branches/on-20050822-x86_64-branch/basis-library/misc/one.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/array.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/cont.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/pointer.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/vector.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library/real/pack-real.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library/real/real.fun
U mlton/branches/on-20050822-x86_64-branch/basis-library/real/real.sig
U mlton/branches/on-20050822-x86_64-branch/doc/license/README
U mlton/branches/on-20050822-x86_64-branch/lib/cml/core-cml/event.sml
A mlton/branches/on-20050822-x86_64-branch/lib/mlrisc-lib/
A mlton/branches/on-20050822-x86_64-branch/lib/mlton/basic/inet-sock.sml
A mlton/branches/on-20050822-x86_64-branch/lib/mlton/basic/socket.sml
U mlton/branches/on-20050822-x86_64-branch/lib/mlton/basic/sources.cm
U mlton/branches/on-20050822-x86_64-branch/lib/mlton/basic/sources.mlb
U mlton/branches/on-20050822-x86_64-branch/lib/mlton/basic/string.sig
U mlton/branches/on-20050822-x86_64-branch/lib/mlton/basic/string.sml
U mlton/branches/on-20050822-x86_64-branch/lib/mlton/basic/vector.fun
U mlton/branches/on-20050822-x86_64-branch/lib/mlton/basic/vector.sig
U mlton/branches/on-20050822-x86_64-branch/lib/mlton/basic/word.sml
A mlton/branches/on-20050822-x86_64-branch/lib/mlton/basic/word16.sml
A mlton/branches/on-20050822-x86_64-branch/lib/mlton/basic/word8-array-slice.sml
U mlton/branches/on-20050822-x86_64-branch/lib/mlton/pervasive/pervasive.sml
U mlton/branches/on-20050822-x86_64-branch/lib/mlton/sources.cm
U mlton/branches/on-20050822-x86_64-branch/lib/mlton/sources.mlb
U mlton/branches/on-20050822-x86_64-branch/lib/mlton-stubs/array.sig
U mlton/branches/on-20050822-x86_64-branch/lib/mlton-stubs/bin-io.sig
U mlton/branches/on-20050822-x86_64-branch/lib/mlton-stubs/mlton.sml
U mlton/branches/on-20050822-x86_64-branch/lib/mlton-stubs/pointer.sig
U mlton/branches/on-20050822-x86_64-branch/lib/mlton-stubs/proc-env.sig
U mlton/branches/on-20050822-x86_64-branch/lib/mlton-stubs/sources.cm
U mlton/branches/on-20050822-x86_64-branch/lib/mlton-stubs/text-io.sig
U mlton/branches/on-20050822-x86_64-branch/lib/mlton-stubs/vector.sig
U mlton/branches/on-20050822-x86_64-branch/lib/mlton-stubs-in-smlnj/array.sml
U mlton/branches/on-20050822-x86_64-branch/lib/mlton-stubs-in-smlnj/open-int32.sml
A mlton/branches/on-20050822-x86_64-branch/lib/mlton-stubs-in-smlnj/socket.sml
U mlton/branches/on-20050822-x86_64-branch/lib/mlton-stubs-in-smlnj/sources.cm
U mlton/branches/on-20050822-x86_64-branch/mlton/atoms/prim.fun
U mlton/branches/on-20050822-x86_64-branch/mlton/ssa/redundant-tests.fun
U mlton/branches/on-20050822-x86_64-branch/util/cm2mlb/cm2mlb-map
U mlton/branches/on-20050822-x86_64-branch/util/cm2mlb/cm2mlb.sml
----------------------------------------------------------------------
Modified: mlton/branches/on-20050822-x86_64-branch/Makefile
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/Makefile 2006-04-19 00:53:39 UTC (rev 4396)
+++ mlton/branches/on-20050822-x86_64-branch/Makefile 2006-04-19 01:19:31 UTC (rev 4397)
@@ -168,17 +168,19 @@
# do not change "make" to "$(MAKE)" in the following line
cd $(BSDSRC)/package/freebsd && MAINTAINER_MODE=yes make build-package
-LIBRARIES = ckit-lib cml mlnlffi-lib mlyacc-lib smlnj-lib
+LIBRARIES = ckit-lib cml mlnlffi-lib mlrisc-lib mlyacc-lib smlnj-lib
.PHONY: libraries-no-check
libraries-no-check:
mkdir -p $(LIB)/sml
cd $(LIB)/sml && rm -rf $(LIBRARIES)
$(MAKE) -C $(SRC)/lib/ckit-lib
+ $(MAKE) -C $(SRC)/lib/mlrisc-lib
$(MAKE) -C $(SRC)/lib/smlnj-lib
$(CP) $(SRC)/lib/cml/. $(LIB)/sml/cml
$(CP) $(SRC)/lib/ckit-lib/ckit/. $(LIB)/sml/ckit-lib
$(CP) $(SRC)/lib/mlnlffi/. $(LIB)/sml/mlnlffi-lib
+ $(CP) $(SRC)/lib/mlrisc-lib/MLRISC/. $(LIB)/sml/mlrisc-lib
$(CP) $(SRC)/lib/mlyacc/. $(LIB)/sml/mlyacc-lib
$(CP) $(SRC)/lib/smlnj-lib/smlnj-lib/. $(LIB)/sml/smlnj-lib
find $(LIB)/sml -type d -name .svn | xargs rm -rf
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/array.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/array.sig 2006-04-19 00:53:39 UTC (rev 4396)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/array.sig 2006-04-19 01:19:31 UTC (rev 4397)
@@ -40,17 +40,11 @@
structure ArraySlice: ARRAY_SLICE_EXTRA
- val rawArray: int -> 'a array
- val unsafeSub: 'a array * int -> 'a
- val unsafeUpdate: 'a array * int * 'a -> unit
-
val concat: 'a array list -> 'a array
val duplicate: 'a array -> 'a array
+ val rawArray: int -> 'a array
val toList: 'a array -> 'a list
- val unfoldi: int * 'a * (int * 'a -> 'b * 'a) -> 'b array
-
- (* Deprecated *)
- val checkSlice: 'a array * int * int option -> int
- (* Deprecated *)
- val checkSliceMax: int * int option * int -> int
+ val unfoldi: int * 'b * (int * 'b -> 'a * 'b) -> 'a array * 'b
+ val unsafeSub: 'a array * int -> 'a
+ val unsafeUpdate: 'a array * int * 'a -> unit
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/array2.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/array2.sml 2006-04-19 00:53:39 UTC (rev 4396)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/array2.sml 2006-04-19 01:19:31 UTC (rev 4397)
@@ -28,10 +28,28 @@
nrows: int option,
ncols: int option}
+ fun checkSliceMax (start: int, num: int option, max: int): int =
+ case num of
+ NONE =>
+ if Primitive.safe andalso (start < 0 orelse start > max) then
+ raise Subscript
+ else
+ max
+ | SOME num =>
+ if Primitive.safe
+ andalso (start < 0
+ orelse num < 0
+ orelse start > max -? num) then
+ raise Subscript
+ else
+ start +? num
+
fun checkRegion {base, row, col, nrows, ncols} =
- let val (rows, cols) = dimensions base
- in {stopRow = Array.checkSliceMax (row, nrows, rows),
- stopCol = Array.checkSliceMax (col, ncols, cols)}
+ let
+ val (rows, cols) = dimensions base
+ in
+ {stopRow = checkSliceMax (row, nrows, rows),
+ stopCol = checkSliceMax (col, ncols, cols)}
end
fun wholeRegion (a: 'a array): 'a region =
@@ -142,72 +160,12 @@
fun modify trv f a = modifyi trv (f o #3) (wholeRegion a)
fun tabulate trv (rows, cols, f) =
- if !Primitive.usesCallcc
- then
- (* All this mess is careful to construct a list representing
- * the array and then convert the list to the array after all
- * the calls to f have been made, in case f uses callcc.
- *)
- let
- val size =
- if Primitive.safe andalso (rows < 0 orelse cols < 0)
- then raise Size
- else rows * cols handle Overflow => raise Size
- val (rows', cols', f) =
- case trv of
- RowMajor => (rows, cols, f)
- | ColMajor => (cols, rows, fn (c, r) => f (r, c))
- fun loopr (r, l) =
- if r >= rows'
- then l
- else
- let
- fun loopc (c, l) =
- if c >= cols'
- then l
- else loopc (c + 1, f (r, c) :: l)
- in loopr (r + 1, loopc (0, l))
- end
- val l = loopr (0, [])
- val a = Primitive.Array.array size
- in case trv of
- RowMajor =>
- (* The list holds the elements in row major order,
- * but reversed.
- *)
- let
- val _ =
- List.foldl (fn (x, i) =>
- (Primitive.Array.update (a, i, x)
- ; i -? 1))
- (size -? 1) l
- in
- ()
- end
- | ColMajor =>
- (* The list holds the elements in column major order,
- * but reversed.
- *)
- let
- val _ =
- List.foldl (fn (x, (spot, r)) =>
- (Primitive.Array.update (a, spot, x)
- ; if r = 0
- then (spot -? 1 +? size -? cols,
- rows -? 1)
- else (spot -? cols, r -? 1)))
- (size -? 1, rows -? 1)
- l
- in
- ()
- end
- ; {rows = rows, cols = cols, array = a}
- end
- else
- let val a = arrayUninit (rows, cols)
- in modifyi trv (fn (r, c, _) => f (r, c)) (wholeRegion a)
- ; a
- end
+ let
+ val a = arrayUninit (rows, cols)
+ val () = modifyi trv (fn (r, c, _) => f (r, c)) (wholeRegion a)
+ in
+ a
+ end
fun copy {src = src as {base, row, col, ...}: 'a region,
dst, dst_row, dst_col} =
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/mono-array.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/mono-array.sig 2006-04-19 00:53:39 UTC (rev 4396)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/mono-array.sig 2006-04-19 01:19:31 UTC (rev 4397)
@@ -45,7 +45,7 @@
val rawArray: int -> array
val toList: array -> elem list
val toPoly: array -> elem Array.array
- val unfoldi: int * 'a * (int * 'a -> elem * 'a) -> array
+ val unfoldi: int * 'a * (int * 'a -> elem * 'a) -> array * 'a
val unsafeSub: array * int -> elem
val unsafeUpdate: array * int * elem -> unit
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/mono-vector.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/mono-vector.sig 2006-04-19 00:53:39 UTC (rev 4396)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/mono-vector.sig 2006-04-19 01:19:31 UTC (rev 4397)
@@ -41,7 +41,7 @@
val toList: vector -> elem list
val tokens: (elem -> bool) -> vector -> vector list
val translate: (elem -> vector) -> vector -> vector
- val unfoldi: int * 'a * (int * 'a -> elem * 'a) -> vector
+ val unfoldi: int * 'a * (int * 'a -> elem * 'a) -> vector * 'a
val unsafeSub: vector * int -> elem
val vector: int * elem -> vector
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/sequence.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/sequence.fun 2006-04-19 00:53:39 UTC (rev 4396)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/sequence.fun 2006-04-19 01:19:31 UTC (rev 4397)
@@ -32,55 +32,28 @@
fun seq0 () = fromArray (array 0)
+ (* unfoldi depends on the fact that the runtime system fills in the array
+ * with reasonable bogus values.
+ *)
fun unfoldi (n, b, f) =
let
val a = array n
fun loop (i, b) =
- if i >= n
- then ()
+ if i >= n then
+ b
else
let
val (x, b') = f (i, b)
- val _ = Array.update (a, i, x)
+ val () = Array.update (a, i, x)
in
loop (i +? 1, b')
end
- val _ = loop (0, b)
+ val b = loop (0, b)
in
- fromArray a
+ (fromArray a, b)
end
- (* Tabulate depends on the fact that the runtime system fills in the array
- * with reasonable bogus values.
- *)
- fun tabulate (n, f) =
-(*
- if !Primitive.usesCallcc
- then
- (* This code is careful to use a list to accumulate the
- * components of the array in case f uses callcc.
- *)
- let
- fun loop (i, l) =
- if i >= n
- then l
- else loop (i + 1, f i :: l)
- val l = loop (0, [])
- val a = array n
- fun loop (l, i) =
- case l of
- [] => ()
- | x :: l =>
- let val i = i -? 1
- in Array.update (a, i, x)
- ; loop (l, i)
- end
- in loop (l, n)
- ; fromArray a
- end
- else
-*)
- unfoldi (n, (), fn (i, ()) => (f i, ()))
+ fun tabulate (n, f) = #1 (unfoldi (n, (), fn (i, ()) => (f i, ())))
fun new (n, x) = tabulate (n, fn _ => x)
@@ -218,25 +191,26 @@
in loop (min1, min2)
end
fun sequence (sl as T {seq, start, len}): 'a sequence =
- if isMutable orelse (start <> 0 orelse len <> S.length seq)
- then map (fn x => x) sl
- else seq
+ if isMutable orelse (start <> 0 orelse len <> S.length seq) then
+ map (fn x => x) sl
+ else
+ seq
fun append (sl1: 'a slice, sl2: 'a slice): 'a sequence =
- if length sl1 = 0
- then sequence sl2
- else if length sl2 = 0
- then sequence sl1
+ if length sl1 = 0 then
+ sequence sl2
+ else if length sl2 = 0 then
+ sequence sl1
else
let
val l1 = length sl1
val l2 = length sl2
val n = l1 + l2 handle Overflow => raise Size
in
- unfoldi (n, (0, sl1),
- fn (_, (i, sl)) =>
- if i < length sl
- then (unsafeSub (sl, i), (i +? 1, sl))
- else (unsafeSub (sl2, 0), (1, sl2)))
+ #1 (unfoldi (n, (0, sl1),
+ fn (_, (i, sl)) =>
+ if i < length sl then
+ (unsafeSub (sl, i), (i +? 1, sl))
+ else (unsafeSub (sl2, 0), (1, sl2))))
end
fun concat (sls: 'a slice list): 'a sequence =
case sls of
@@ -247,17 +221,19 @@
val n = List.foldl (fn (sl, s) => s + length sl) 0 sls'
handle Overflow => raise Size
in
- unfoldi (n, (0, sl, sls),
- fn (_, ac) =>
- let
- fun loop (i, sl, sls) =
- if i < length sl
- then (unsafeSub (sl, i), (i +? 1, sl, sls))
- else case sls of
- [] => raise Fail "concat bug"
- | sl :: sls => loop (0, sl, sls)
- in loop ac
- end)
+ #1 (unfoldi (n, (0, sl, sls),
+ fn (_, ac) =>
+ let
+ fun loop (i, sl, sls) =
+ if i < length sl then
+ (unsafeSub (sl, i),
+ (i +? 1, sl, sls))
+ else case sls of
+ [] => raise Fail "concat bug"
+ | sl :: sls => loop (0, sl, sls)
+ in
+ loop ac
+ end))
end
fun concatWith (sep: 'a sequence) (sls: 'a slice list): 'a sequence =
let val sep = full sep
@@ -480,18 +456,4 @@
fun duplicate seq = make Slice.sequence seq
fun toList seq = make Slice.toList seq
end
-
- (* Deprecated *)
- fun checkSliceMax (start: int, num: int option, max: int): int =
- case num of
- NONE => if Primitive.safe andalso (start < 0 orelse start > max)
- then raise Subscript
- else max
- | SOME num =>
- if Primitive.safe
- andalso (start < 0 orelse num < 0 orelse start > max -? num)
- then raise Subscript
- else start +? num
- (* Deprecated *)
- fun checkSlice (s, i, opt) = checkSliceMax (i, opt, length s)
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/sequence.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/sequence.sig 2006-04-19 00:53:39 UTC (rev 4396)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/sequence.sig 2006-04-19 01:19:31 UTC (rev 4397)
@@ -62,10 +62,5 @@
val duplicate: 'a sequence -> 'a sequence
val new: int * 'a elt -> 'a sequence
val toList: 'a sequence -> 'a elt list
- val unfoldi: int * 'a * (int * 'a -> 'b elt * 'a) -> 'b sequence
-
- (* Deprecated *)
- val checkSlice: 'a sequence * int * int option -> int
- (* Deprecated *)
- val checkSliceMax: int * int option * int -> int
+ val unfoldi: int * 'a * (int * 'a -> 'b elt * 'a) -> 'b sequence * 'a
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/vector.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/vector.sig 2006-04-19 00:53:39 UTC (rev 4396)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/vector.sig 2006-04-19 01:19:31 UTC (rev 4397)
@@ -34,24 +34,24 @@
include VECTOR
structure VectorSlice: VECTOR_SLICE_EXTRA
- val unsafeSub: 'a vector * int -> 'a
-
- (* Used to implement Substring/String functions *)
+ val append: 'a vector * 'a vector -> 'a vector
+ (* concatWith is used to implement Substring/String functions *)
val concatWith: 'a vector -> 'a vector list -> 'a vector
+ val create:
+ int
+ * ({sub: int -> 'a, update: int * 'a -> unit}
+ -> (int -> 'a) * (unit -> unit))
+ -> 'a vector
+ val duplicate: 'a vector -> 'a vector
+ val fields: ('a -> bool) -> 'a vector -> 'a vector list
+ val fromArray: 'a array -> 'a vector
val isPrefix: ('a * 'a -> bool) -> 'a vector -> 'a vector -> bool
val isSubvector: ('a * 'a -> bool) -> 'a vector -> 'a vector -> bool
val isSuffix: ('a * 'a -> bool) -> 'a vector -> 'a vector -> bool
+ val toList: 'a vector -> 'a list
+ val tokens: ('a -> bool) -> 'a vector -> 'a vector list
val translate: ('a -> 'a vector) -> 'a vector -> 'a vector
- val tokens: ('a -> bool) -> 'a vector -> 'a vector list
- val fields: ('a -> bool) -> 'a vector -> 'a vector list
-
- val append: 'a vector * 'a vector -> 'a vector
- val duplicate: 'a vector -> 'a vector
- val fromArray: 'a array -> 'a vector
- val toList: 'a vector -> 'a list
- val unfoldi: int * 'a * (int * 'a -> 'b * 'a) -> 'b vector
+ val unfoldi: int * 'b * (int * 'b -> 'a * 'b) -> 'a vector * 'b
+ val unsafeSub: 'a vector * int -> 'a
val vector: int * 'a -> 'a vector
-
- (* Deprecated *)
- val checkSlice: 'a vector * int * int option -> int
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/vector.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/vector.sml 2006-04-19 00:53:39 UTC (rev 4396)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/arrays-and-vectors/vector.sml 2006-04-19 01:19:31 UTC (rev 4397)
@@ -42,9 +42,37 @@
val fromArray = Primitive.Vector.fromArray
val vector = new
+
+ fun create (n, f) =
+ let
+ val a = Primitive.Array.array n
+ val subLim = ref 0
+ fun sub i =
+ if Primitive.safe andalso Primitive.Int.geu (i, !subLim) then
+ raise Subscript
+ else
+ Primitive.Array.sub (a, i)
+ val updateLim = ref 0
+ fun update (i, x) =
+ if Primitive.safe andalso Primitive.Int.geu (i, !updateLim) then
+ raise Subscript
+ else
+ Primitive.Array.update (a, i, x)
+ val (tab, finish) = f {sub = sub, update = update}
+ val () =
+ Util.naturalForeach
+ (n, fn i =>
+ (Primitive.Array.update (a, i, tab i);
+ subLim := i + 1;
+ updateLim := i + 1))
+ val () = finish ()
+ val () = updateLim := 0
+ in
+ fromArray a
+ end
end
structure VectorSlice: VECTOR_SLICE_EXTRA = Vector.VectorSlice
-
+
structure VectorGlobal: VECTOR_GLOBAL = Vector
open VectorGlobal
val vector = Vector.fromList
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/integer/int.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/integer/int.sml 2006-04-19 00:53:39 UTC (rev 4396)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/integer/int.sml 2006-04-19 01:19:31 UTC (rev 4397)
@@ -119,40 +119,42 @@
* The most that will be required is for minInt in binary.
*)
val maxNumDigits = PI.+ (precision', 1)
- val buf = CharArray.array (maxNumDigits, #"\000")
+ val one = One.make (fn () => CharArray.array (maxNumDigits, #"\000"))
in
fun fmt radix (n: int): string =
- let
- val radix = fromInt (StringCvt.radixToInt radix)
- fun loop (q, i: Int.int) =
- let
- val _ =
- CharArray.update
- (buf, i, StringCvt.digitToChar (toInt (~? (rem (q, radix)))))
- val q = quot (q, radix)
- in
- if q = zero
- then
- let
- val start =
- if n < zero
- then
- let
- val i = PI.- (i, 1)
- val () = CharArray.update (buf, i, #"~")
- in
- i
- end
- else i
- in
- CharArraySlice.vector
- (CharArraySlice.slice (buf, start, NONE))
- end
- else loop (q, PI.- (i, 1))
- end
- in
- loop (if n < zero then n else ~? n, PI.- (maxNumDigits, 1))
- end
+ One.use
+ (one, fn buf =>
+ let
+ val radix = fromInt (StringCvt.radixToInt radix)
+ fun loop (q, i: Int.int) =
+ let
+ val _ =
+ CharArray.update
+ (buf, i, StringCvt.digitToChar (toInt (~? (rem (q, radix)))))
+ val q = quot (q, radix)
+ in
+ if q = zero
+ then
+ let
+ val start =
+ if n < zero
+ then
+ let
+ val i = PI.- (i, 1)
+ val () = CharArray.update (buf, i, #"~")
+ in
+ i
+ end
+ else i
+ in
+ CharArraySlice.vector
+ (CharArraySlice.slice (buf, start, NONE))
+ end
+ else loop (q, PI.- (i, 1))
+ end
+ in
+ loop (if n < zero then n else ~? n, PI.- (maxNumDigits, 1))
+ end)
end
val toString = fmt StringCvt.DEC
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/libs/basis-extra/basis-extra.mlb
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/libs/basis-extra/basis-extra.mlb 2006-04-19 00:53:39 UTC (rev 4396)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/libs/basis-extra/basis-extra.mlb 2006-04-19 01:19:31 UTC (rev 4397)
@@ -20,6 +20,7 @@
../../misc/dynamic-wind.sml
../../general/general.sig
../../general/general.sml
+ ../../misc/one.sml
../../misc/util.sml
../../general/option.sig
../../general/option.sml
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library/misc/one.sml (from rev 4396, mlton/trunk/basis-library/misc/one.sml)
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/array.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/array.sig 2006-04-19 00:53:39 UTC (rev 4396)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/array.sig 2006-04-19 01:19:31 UTC (rev 4397)
@@ -10,5 +10,5 @@
signature MLTON_ARRAY =
sig
- val unfoldi: int * 'b * (int * 'b -> 'a * 'b) -> 'a array
+ val unfoldi: int * 'b * (int * 'b -> 'a * 'b) -> 'a array * 'b
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/cont.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/cont.sml 2006-04-19 00:53:39 UTC (rev 4396)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/cont.sml 2006-04-19 01:19:31 UTC (rev 4397)
@@ -12,54 +12,44 @@
structure Thread = Primitive.Thread
val gcState = Primitive.GCState.gcState
-(* This mess with dummy is so that if callcc is ever used anywhere in the
- * program, then Primitive.usesCallcc is set to true during basis library
- * evaluation. This relies on the dead code elimination algorithm
- * (core-ml/dead-code.fun), which will keep dummy around only if callcc is used.
- *)
-val dummy =
- (Primitive.usesCallcc := true
- ; fn () => ())
-
type 'a t = (unit -> 'a) -> unit
fun callcc (f: 'a t -> 'a): 'a =
- (dummy ()
- ; if MLtonThread.amInSignalHandler ()
- then die "callcc can not be used in a signal handler\n"
- else
- let
- datatype 'a state =
- Original of 'a t -> 'a
- | Copy of unit -> 'a
- | Clear
- val r: 'a state ref = ref (Original f)
- val _ = Thread.atomicBegin () (* Match 1 *)
- val _ = Thread.copyCurrent ()
- in
- case (!r before r := Clear) of
- Clear => raise Fail "callcc saw Clear"
- | Copy v => (Thread.atomicEnd () (* Match 2 *)
- ; v ())
- | Original f =>
- let
- val t = Thread.savedPre gcState
- in
- Thread.atomicEnd () (* Match 1 *)
- ; f (fn v =>
- let
- val _ = Thread.atomicBegin () (* Match 2 *)
- val _ = r := Copy v
- val new = Thread.copy t
- (* The following Thread.atomicBegin ()
- * is matched by Thread.switchTo.
- *)
- val _ = Thread.atomicBegin ()
- in
- Thread.switchTo new
- end)
- end
- end)
+ if MLtonThread.amInSignalHandler () then
+ die "callcc can not be used in a signal handler\n"
+ else
+ let
+ datatype 'a state =
+ Original of 'a t -> 'a
+ | Copy of unit -> 'a
+ | Clear
+ val r: 'a state ref = ref (Original f)
+ val _ = Thread.atomicBegin () (* Match 1 *)
+ val _ = Thread.copyCurrent ()
+ in
+ case (!r before r := Clear) of
+ Clear => raise Fail "callcc saw Clear"
+ | Copy v => (Thread.atomicEnd () (* Match 2 *)
+ ; v ())
+ | Original f =>
+ let
+ val t = Thread.savedPre gcState
+ in
+ Thread.atomicEnd () (* Match 1 *)
+ ; f (fn v =>
+ let
+ val _ = Thread.atomicBegin () (* Match 2 *)
+ val _ = r := Copy v
+ val new = Thread.copy t
+ (* The following Thread.atomicBegin ()
+ * is matched by Thread.switchTo.
+ *)
+ val _ = Thread.atomicBegin ()
+ in
+ Thread.switchTo new
+ end)
+ end
+ end
fun ('a, 'b) throw' (k: 'a t, v: unit -> 'a): 'b =
(k v; raise Fail "throw bug")
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/pointer.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/pointer.sig 2006-04-19 00:53:39 UTC (rev 4396)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/pointer.sig 2006-04-19 01:19:31 UTC (rev 4397)
@@ -5,6 +5,9 @@
* See the file MLton-LICENSE for details.
*)
+type int = Int.int
+type word = Word.word
+
signature MLTON_POINTER =
sig
eqtype t
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/vector.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/vector.sig 2006-04-19 00:53:39 UTC (rev 4396)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/mlton/vector.sig 2006-04-19 01:19:31 UTC (rev 4397)
@@ -10,6 +10,10 @@
signature MLTON_VECTOR =
sig
- val unfoldi: int * 'b * (int * 'b -> 'a * 'b) -> 'a vector
+ val create:
+ int * ({sub: int -> 'a, update: int * 'a -> unit}
+ -> (int -> 'a) * (unit -> unit))
+ -> 'a vector
+ val unfoldi: int * 'b * (int * 'b -> 'a * 'b) -> 'a vector * 'b
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/real/pack-real.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/real/pack-real.sml 2006-04-19 00:53:39 UTC (rev 4396)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/real/pack-real.sml 2006-04-19 01:19:31 UTC (rev 4397)
@@ -24,10 +24,16 @@
then (subVec, update)
else (subVecRev, updateRev)
+fun check (size, i) =
+ if Int.< (i, 0) orelse Int.> (i, size -? bytesPerElem) then
+ raise Subscript
+ else
+ ()
+
fun update (a, i, r) =
let
+ val () = check (Word8Array.length a, i)
val a = Word8Array.toPoly a
- val _ = Array.checkSlice (a, i, SOME bytesPerElem)
in
up (a, i, r)
end
@@ -42,8 +48,8 @@
fun subVec (v, i) =
let
+ val () = check (Word8Vector.length v, i)
val v = Word8Vector.toPoly v
- val _ = Vector.checkSlice (v, i, SOME bytesPerElem)
in
sub (v, i)
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/real/real.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/real/real.fun 2006-04-19 00:53:39 UTC (rev 4396)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/real/real.fun 2006-04-19 01:19:31 UTC (rev 4397)
@@ -63,10 +63,11 @@
val nan = posInf + negInf
+ structure Class = Primitive.Real64.Class
local
val classes =
let
- open Primitive.Real64.Class
+ open Class
in
(* order here is chosen based on putting the more commonly used
* classes at the front.
@@ -103,21 +104,15 @@
INF => false
| NAN => false
| _ => true
-
- fun isNan r = class r = NAN
- fun isNormal r = class r = NORMAL
+ val op == = Prim.==
- val op == =
- fn (x, y) =>
- case (class x, class y) of
- (NAN, _) => false
- | (_, NAN) => false
- | (ZERO, ZERO) => true
- | _ => Prim.== (x, y)
-
val op != = not o op ==
+ fun isNan r = r != r
+
+ fun isNormal r = class r = NORMAL
+
val op ?= =
if MLton.Codegen.isNative
then Prim.?=
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/real/real.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/real/real.sig 2006-04-19 00:53:39 UTC (rev 4396)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/real/real.sig 2006-04-19 01:19:31 UTC (rev 4397)
@@ -27,7 +27,7 @@
val ?= : real * real -> bool
val ~ : real -> real
val abs: real -> real
- val class: real -> int
+ val class: real -> Primitive.Real64.Class.t
val frexp: real * int ref -> real
val gdtoa: real * int * int * int ref -> Primitive.CString.t
val fromInt: int -> real
Modified: mlton/branches/on-20050822-x86_64-branch/doc/license/README
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/doc/license/README 2006-04-19 00:53:39 UTC (rev 4396)
+++ mlton/branches/on-20050822-x86_64-branch/doc/license/README 2006-04-19 01:19:31 UTC (rev 4397)
@@ -12,6 +12,7 @@
Concurrent ML Library
CKit Library
mlnlffigen and MLNLFFI Library
+ MLRISC Library
SML/NJ Lib SMLNJ-LIB-LICENSE (BSD-style) SML/NJ Library
Modified: mlton/branches/on-20050822-x86_64-branch/lib/cml/core-cml/event.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/lib/cml/core-cml/event.sml 2006-04-19 00:53:39 UTC (rev 4396)
+++ mlton/branches/on-20050822-x86_64-branch/lib/cml/core-cml/event.sml 2006-04-19 01:19:31 UTC (rev 4397)
@@ -421,7 +421,7 @@
(* walk the event group tree, collecting the base events (with associated
* ack flags), and a list of flag sets. A flag set is a (cvar * ack flag list)
- * pairs, where the flags are those associated with the events covered by the
+ * pair, where the flags are those associated with the events covered by the
* nack cvar.
*)
type ack_flg = bool ref
@@ -590,10 +590,7 @@
extRdy (backs, {prio = prio, doitFn = (doitFn, ackFlg)}::doitFns)
| _ => extRdy (backs, doitFns))
end
- val x =
- case backs of
- [(bevt, _)] => syncOnBEvt bevt
- | _ => (S.atomicBegin (); ext (backs, []))
+ val x = (S.atomicBegin (); ext (backs, []))
val () = debug' "syncOnGrp(4)" (* NonAtomic *)
val () = Assert.assertNonAtomic' "Event.syncOnGrp(4)"
in
Copied: mlton/branches/on-20050822-x86_64-branch/lib/mlrisc-lib (from rev 4396, mlton/trunk/lib/mlrisc-lib)
Property changes on: mlton/branches/on-20050822-x86_64-branch/lib/mlrisc-lib
___________________________________________________________________
Name: svn:ignore
+ MLRISC
Copied: mlton/branches/on-20050822-x86_64-branch/lib/mlton/basic/inet-sock.sml (from rev 4396, mlton/trunk/lib/mlton/basic/inet-sock.sml)
Copied: mlton/branches/on-20050822-x86_64-branch/lib/mlton/basic/socket.sml (from rev 4396, mlton/trunk/lib/mlton/basic/socket.sml)
Modified: mlton/branches/on-20050822-x86_64-branch/lib/mlton/basic/sources.cm
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/lib/mlton/basic/sources.cm 2006-04-19 00:53:39 UTC (rev 4396)
+++ mlton/branches/on-20050822-x86_64-branch/lib/mlton/basic/sources.cm 2006-04-19 01:19:31 UTC (rev 4397)
@@ -27,6 +27,7 @@
signature SUM
signature T
signature UNIQUE_ID
+signature VECTOR
structure AppendList
structure Array
@@ -36,6 +37,7 @@
structure BinarySearch
structure Bool
structure Buffer
+structure Byte
structure Char
structure CharArray
structure CharBuffer
@@ -70,6 +72,7 @@
structure Int32
structure IntInf
structure InsertionSort
+structure INetSock
structure Iterate
structure Itimer
structure Justify
@@ -117,6 +120,7 @@
structure SMLofNJ
structure Sexp
structure Signal
+structure Socket
structure Stream
structure String
structure StringCvt
@@ -124,18 +128,22 @@
structure SysWord
structure Thread
structure Time
+structure Timer
structure Trace
structure Tree
structure TwoListQueue
structure Unimplemented
structure Unit
structure Unsafe
+structure Url
structure Vector
structure Word
structure Word32
structure Word8
structure Word8Array
+structure Word8ArraySlice
structure Word8Vector
+structure Word16
functor AlphaBeta
functor Control
@@ -326,6 +334,10 @@
escape.sml
buffer.sig
buffer.sml
+socket.sml
+word16.sml
+inet-sock.sml
+word8-array-slice.sml
# if ( defined(SMLNJ_VERSION) )
Modified: mlton/branches/on-20050822-x86_64-branch/lib/mlton/basic/sources.mlb
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/lib/mlton/basic/sources.mlb 2006-04-19 00:53:39 UTC (rev 4396)
+++ mlton/branches/on-20050822-x86_64-branch/lib/mlton/basic/sources.mlb 2006-04-19 01:19:31 UTC (rev 4397)
@@ -198,6 +198,7 @@
signature STRING
signature T
signature UNIQUE_ID
+ signature VECTOR
structure AppendList
structure Array
Modified: mlton/branches/on-20050822-x86_64-branch/lib/mlton/basic/string.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/lib/mlton/basic/string.sig 2006-04-19 00:53:39 UTC (rev 4396)
+++ mlton/branches/on-20050822-x86_64-branch/lib/mlton/basic/string.sig 2006-04-19 01:19:31 UTC (rev 4397)
@@ -26,6 +26,7 @@
val baseName: t * t -> t
val compare: t * t -> Relation.t
val concat: t list -> t
+ val concatV: t vector -> t
val concatWith: t list * t -> t
val contains: t * char -> bool
val deleteSurroundingWhitespace: t -> t
@@ -41,6 +42,7 @@
val escapeC: t -> t
val escapeSML: t -> t
val existsi: t * (int * char -> bool) -> bool
+ val exists: t * (char -> bool) -> bool
val explode: t -> char list
(* extract (s, i, SOME j)
* returns the substring of s of length j starting at i.
@@ -103,6 +105,7 @@
val toUpper: t -> t
val tokens: t * (char -> bool) -> t list
val translate: t * (char -> t) -> t
+ val unfold: int * 'a * ('a -> char * 'a) -> t
end
Modified: mlton/branches/on-20050822-x86_64-branch/lib/mlton/basic/string.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/lib/mlton/basic/string.sml 2006-04-19 00:53:39 UTC (rev 4396)
+++ mlton/branches/on-20050822-x86_64-branch/lib/mlton/basic/string.sml 2006-04-19 01:19:31 UTC (rev 4397)
@@ -11,8 +11,42 @@
struct
open String1
+ fun unfold (n, a, f) =
+ let
+ val r = ref a
+ in
+ tabulate (n, fn _ =>
+ let
+ val (b, a) = f (!r)
+ val () = r := a
+ in
+ b
+ end)
+ end
+
+ fun concatV ss =
+ case Vector.length ss of
+ 0 => ""
+ | 1 => Vector.sub (ss, 0)
+ | _ =>
+ let
+ val n =
+ Vector.fold (ss, 0, fn (s, n) => n + size s)
+ val a = Array.new (n, #"a")
+ val _ =
+ Vector.fold
+ (ss, 0, fn (s, i) =>
+ fold (s, i, fn (c, i) =>
+ (Array.update (a, i, c);
+ i + 1)))
+ in
+ tabulate (n, fn i => Array.sub (a, i))
+ end
+
fun existsi (s, f) = Int.exists (0, size s, fn i => f (i, sub (s, i)))
+ fun exists (s, f) = existsi (s, f o #2)
+
fun keepAll (s: t, f: char -> bool): t =
implode (List.rev
(fold (s, [], fn (c, ac) => if f c then c :: ac else ac)))
Modified: mlton/branches/on-20050822-x86_64-branch/lib/mlton/basic/vector.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/lib/mlton/basic/vector.fun 2006-04-19 00:53:39 UTC (rev 4396)
+++ mlton/branches/on-20050822-x86_64-branch/lib/mlton/basic/vector.fun 2006-04-19 01:19:31 UTC (rev 4397)
@@ -13,9 +13,11 @@
open S
+val size = length
+
fun unfold (n, a, f) = unfoldi (n, a, f o #2)
-fun tabulate (n, f) = unfoldi (n, (), fn (i, ()) => (f i, ()))
+fun tabulate (n, f) = #1 (unfoldi (n, (), fn (i, ()) => (f i, ())))
fun fromArray a =
tabulate (Pervasive.Array.length a, fn i => Pervasive.Array.sub (a, i))
@@ -455,36 +457,37 @@
let
val n = List.fold (vs, 0, fn (v, s) => s + length v)
in
- unfold (n, (0, v, vs'),
- let
- fun loop (i, v, vs) =
- if i < length v
- then (sub (v, i), (i + 1, v, vs))
- else
- case vs of
- [] => Error.bug "Vector.concat"
- | v :: vs => loop (0, v, vs)
- in loop
- end)
+ #1 (unfold (n, (0, v, vs'),
+ let
+ fun loop (i, v, vs) =
+ if i < length v
+ then (sub (v, i), (i + 1, v, vs))
+ else
+ case vs of
+ [] => Error.bug "Vector.concat"
+ | v :: vs => loop (0, v, vs)
+ in loop
+ end))
end
fun concatV vs =
- if 0 = length vs
- then new0 ()
+ if 0 = length vs then
+ new0 ()
else
let
val n = fold (vs, 0, fn (v, s) => s + length v)
fun state i = (i, sub (vs, i), 0)
in
- unfold (n, state 0,
- let
- fun loop (i, v, j) =
- if j < length v
- then (sub (v, j), (i, v, j + 1))
- else loop (state (i + 1))
- in loop
- end)
- end
+ #1 (unfold (n, state 0,
+ let
+ fun loop (i, v, j) =
+ if j < length v then
+ (sub (v, j), (i, v, j + 1))
+ else
+ loop (state (i + 1))
+ in loop
+ end))
+ end
fun splitLast v =
let
Modified: mlton/branches/on-20050822-x86_64-branch/lib/mlton/basic/vector.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/lib/mlton/basic/vector.sig 2006-04-19 00:53:39 UTC (rev 4396)
+++ mlton/branches/on-20050822-x86_64-branch/lib/mlton/basic/vector.sig 2006-04-19 01:19:31 UTC (rev 4397)
@@ -14,7 +14,7 @@
val length: 'a t -> int
val sub: 'a t * int -> 'a
- val unfoldi: int * 'a * (int * 'a -> 'b * 'a) -> 'b t
+ val unfoldi: int * 'b * (int * 'b -> 'a * 'b) -> 'a t * 'b
end
signature VECTOR =
@@ -111,6 +111,7 @@
val removeDuplicates: 'a t * ('a * 'a -> bool) -> 'a t
val removeFirst: 'a t * ('a -> bool) -> 'a t
val rev: 'a t -> 'a t
+ val size: 'a t -> int
val splitLast: 'a t -> 'a t * 'a
val tabulate: int * (int -> 'a) -> 'a t
val tabulator: int * (('a -> unit) -> unit) -> 'a t
Modified: mlton/branches/on-20050822-x86_64-branch/lib/mlton/basic/word.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/lib/mlton/basic/word.sml 2006-04-19 00:53:39 UTC (rev 4396)
+++ mlton/branches/on-20050822-x86_64-branch/lib/mlton/basic/word.sml 2006-04-19 01:19:31 UTC (rev 4397)
@@ -23,15 +23,7 @@
orb (w (2, 0w16), w (3, 0w24)))
end
- local
- val wordSize = fromInt wordSize
- in
- fun rotateLeft (w: t, n: t) =
- let val l = n mod wordSize
- val r = wordSize - l
- in orb (<< (w, l), >> (w, r))
- end
- end
+ val rotateLeft = MLton.Word.rol
val fromWord = fn x => x
val toWord = fn x => x
Copied: mlton/branches/on-20050822-x86_64-branch/lib/mlton/basic/word16.sml (from rev 4396, mlton/trunk/lib/mlton/basic/word16.sml)
Copied: mlton/branches/on-20050822-x86_64-branch/lib/mlton/basic/word8-array-slice.sml (from rev 4396, mlton/trunk/lib/mlton/basic/word8-array-slice.sml)
Modified: mlton/branches/on-20050822-x86_64-branch/lib/mlton/pervasive/pervasive.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/lib/mlton/pervasive/pervasive.sml 2006-04-19 00:53:39 UTC (rev 4396)
+++ mlton/branches/on-20050822-x86_64-branch/lib/mlton/pervasive/pervasive.sml 2006-04-19 01:19:31 UTC (rev 4397)
@@ -36,6 +36,7 @@
structure Real = Real
structure Real32 = Real32
structure Real64 = Real64
+ structure Socket = Socket
structure String = String
structure StringCvt = StringCvt
structure Substring = Substring
@@ -47,6 +48,7 @@
structure Word = Word
structure Word32 = Word32
structure Word8 = Word8
+ structure Word16 = Word16
structure Word8Array = Word8Array
type unit = General.unit
Modified: mlton/branches/on-20050822-x86_64-branch/lib/mlton/sources.cm
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/lib/mlton/sources.cm 2006-04-19 00:53:39 UTC (rev 4396)
+++ mlton/branches/on-20050822-x86_64-branch/lib/mlton/sources.cm 2006-04-19 01:19:31 UTC (rev 4397)
@@ -46,6 +46,7 @@
signature SUM
signature T
signature UNIQUE_ID
+signature VECTOR
structure AppendList
structure Array
@@ -55,6 +56,7 @@
structure BinarySearch
structure Bool
structure Buffer
+structure Byte
structure Char
structure CharArray
structure CharBuffer
@@ -90,6 +92,7 @@
structure Int32
structure IntInf
structure InsertionSort
+structure INetSock
structure Iterate
structure Itimer
structure Justify
@@ -138,6 +141,7 @@
structure Sexp
structure Signal
structure SMLofNJ
+structure Socket
structure Stream
structure String
structure StringCvt
@@ -145,17 +149,21 @@
structure SysWord
structure Thread
structure Time
+structure Timer
structure Trace
structure Tree
structure TwoListQueue
structure Unimplemented
structure Unit
structure Unsafe
+structure Url
structure Vector
structure Word
structure Word8
structure Word8Array
+structure Word8ArraySlice
structure Word8Vector
+structure Word16
structure Word32
functor AlphaBeta
Modified: mlton/branches/on-20050822-x86_64-branch/lib/mlton/sources.mlb
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/lib/mlton/sources.mlb 2006-04-19 00:53:39 UTC (rev 4396)
+++ mlton/branches/on-20050822-x86_64-branch/lib/mlton/sources.mlb 2006-04-19 01:19:31 UTC (rev 4397)
@@ -32,6 +32,7 @@
signature STRING
signature T
signature UNIQUE_ID
+ signature VECTOR
structure AppendList
structure Array
Modified: mlton/branches/on-20050822-x86_64-branch/lib/mlton-stubs/array.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/lib/mlton-stubs/array.sig 2006-04-19 00:53:39 UTC (rev 4396)
+++ mlton/branches/on-20050822-x86_64-branch/lib/mlton-stubs/array.sig 2006-04-19 01:19:31 UTC (rev 4397)
@@ -1,5 +1,6 @@
-(* Copyright (C) 2002-2005 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
+ * Copyright (C) 1997-2000 NEC Research Institute.
*
* MLton is released under a BSD-style license.
* See the file MLton-LICENSE for details.
@@ -9,5 +10,5 @@
signature MLTON_ARRAY =
sig
- val unfoldi: int * 'b * (int * 'b -> 'a * 'b) -> 'a array
+ val unfoldi: int * 'b * (int * 'b -> 'a * 'b) -> 'a array * 'b
end
Modified: mlton/branches/on-20050822-x86_64-branch/lib/mlton-stubs/bin-io.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/lib/mlton-stubs/bin-io.sig 2006-04-19 00:53:39 UTC (rev 4396)
+++ mlton/branches/on-20050822-x86_64-branch/lib/mlton-stubs/bin-io.sig 2006-04-19 01:19:31 UTC (rev 4397)
@@ -5,7 +5,5 @@
* See the file MLton-LICENSE for details.
*)
-signature MLTON_BIN_IO =
- MLTON_IO
- where type instream = BinIO.instream
- where type outstream = BinIO.outstream
+signature MLTON_BIN_IO = MLTON_IO
+
Modified: mlton/branches/on-20050822-x86_64-branch/lib/mlton-stubs/mlton.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/lib/mlton-stubs/mlton.sml 2006-04-19 00:53:39 UTC (rev 4396)
+++ mlton/branches/on-20050822-x86_64-branch/lib/mlton-stubs/mlton.sml 2006-04-19 01:19:31 UTC (rev 4397)
@@ -59,14 +59,16 @@
fun unfoldi (n, a, f) =
let
val r = ref a
+ val a =
+ tabulate (n, fn i =>
+ let
+ val (b, a') = f (i, !r)
+ val _ = r := a'
+ in
+ b
+ end)
in
- tabulate (n, fn i =>
- let
- val (b, a') = f (i, !r)
- val _ = r := a'
- in
- b
- end)
+ (a, !r)
end
end
@@ -277,6 +279,8 @@
structure ProcEnv =
struct
+ type gid = Posix.ProcEnv.gid
+
fun setenv _ = raise Fail "setenv"
fun setgroups _ = raise Fail "setgroups"
end
@@ -568,17 +572,55 @@
struct
open Vector
+ fun create (n, f) =
+ let
+ val r = ref (Array.fromList [])
+ val lim = ref 0
+ fun check i =
+ if 0 <= i andalso i < !lim then () else raise Subscript
+ val sub = fn i => (check i; Array.sub (!r, i))
+ val update = fn (i, x) => (check i; Array.update (!r, i, x))
+ val (tab, finish) = f {sub = sub, update = update}
+ in
+ if 0 = n then
+ (finish (); Vector.fromList [])
+ else
+ let
+ val init = tab 0
+ val a = Array.array (n, init)
+ val () = r := a
+ val () =
+ Array.modifyi (fn (i, _) =>
+ let
+ val res =
+ if i = 0 then
+ init
+ else
+ tab i
+ val () = lim := i + 1
+ in
+ res
+ end)
+ a
+ val () = finish ()
+ in
+ Array.vector a
+ end
+ end
+
fun unfoldi (n, a, f) =
let
val r = ref a
+ val v =
+ tabulate (n, fn i =>
+ let
+ val (b, a') = f (i, !r)
+ val _ = r := a'
+ in
+ b
+ end)
in
- tabulate (n, fn i =>
- let
- val (b, a') = f (i, !r)
- val _ = r := a'
- in
- b
- end)
+ (v, !r)
end
end
Modified: mlton/branches/on-20050822-x86_64-branch/lib/mlton-stubs/pointer.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/lib/mlton-stubs/pointer.sig 2006-04-19 00:53:39 UTC (rev 4396)
+++ mlton/branches/on-20050822-x86_64-branch/lib/mlton-stubs/pointer.sig 2006-04-19 01:19:31 UTC (rev 4397)
@@ -5,6 +5,9 @@
* See the file MLton-LICENSE for details.
*)
+type int = Int.int
+type word = Word.word
+
signature MLTON_POINTER =
sig
eqtype t
@@ -12,7 +15,7 @@
val add: t * word -> t
val compare: t * t -> order
val diff: t * t -> word
- val free: t -> unit
+(* val free: t -> unit *)
val getInt8: t * int -> Int8.int
val getInt16: t * int -> Int16.int
val getInt32: t * int -> Int32.int
Modified: mlton/branches/on-20050822-x86_64-branch/lib/mlton-stubs/proc-env.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/lib/mlton-stubs/proc-env.sig 2006-04-19 00:53:39 UTC (rev 4396)
+++ mlton/branches/on-20050822-x86_64-branch/lib/mlton-stubs/proc-env.sig 2006-04-19 01:19:31 UTC (rev 4397)
@@ -1,5 +1,6 @@
-(* Copyright (C) 2002-2005 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
+ * Copyright (C) 1997-2000 NEC Research Institute.
*
* MLton is released under a BSD-style license.
* See the file MLton-LICENSE for details.
@@ -7,5 +8,8 @@
signature MLTON_PROC_ENV =
sig
+ type gid
+
val setenv: {name: string, value: string} -> unit
+ val setgroups: gid list -> unit
end
Modified: mlton/branches/on-20050822-x86_64-branch/lib/mlton-stubs/sources.cm
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/lib/mlton-stubs/sources.cm 2006-04-19 00:53:39 UTC (rev 4396)
+++ mlton/branches/on-20050822-x86_64-branch/lib/mlton-stubs/sources.cm 2006-04-19 01:19:31 UTC (rev 4397)
@@ -29,6 +29,7 @@
structure Int32
structure Int64
structure IntInf
+structure INetSock
structure IO
structure LargeInt
structure LargeReal
@@ -49,19 +50,23 @@
structure RealVector
structure SML90
structure SMLofNJ
+structure Socket
structure String
structure StringCvt
structure Substring
structure SysWord
structure TextIO
structure Time
+structure Timer
structure Unix
structure Unsafe
structure Vector
structure Word
structure Word8
structure Word8Array
+structure Word8ArraySlice
structure Word8Vector
+structure Word16
structure Word32
structure Word64
Modified: mlton/branches/on-20050822-x86_64-branch/lib/mlton-stubs/text-io.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/lib/mlton-stubs/text-io.sig 2006-04-19 00:53:39 UTC (rev 4396)
+++ mlton/branches/on-20050822-x86_64-branch/lib/mlton-stubs/text-io.sig 2006-04-19 01:19:31 UTC (rev 4397)
@@ -1,11 +1,9 @@
-(* Copyright (C) 2002-2005 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
+ * Copyright (C) 1997-2000 NEC Research Institute.
*
* MLton is released under a BSD-style license.
* See the file MLton-LICENSE for details.
*)
-signature MLTON_TEXT_IO =
- MLTON_IO
- where type instream = TextIO.instream
- where type outstream = TextIO.outstream
+signature MLTON_TEXT_IO = MLTON_IO
Modified: mlt...
[truncated message content] |
|
From: Matthew F. <fl...@ml...> - 2006-04-18 17:53:39
|
Formatting
----------------------------------------------------------------------
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/int-inf0.sml
----------------------------------------------------------------------
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/int-inf0.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/int-inf0.sml 2006-04-19 00:53:20 UTC (rev 4395)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/integer/int-inf0.sml 2006-04-19 00:53:39 UTC (rev 4396)
@@ -328,7 +328,6 @@
val fromWord8Unsafe = fromWord8
val fromWord8XUnsafe = fromWord8X
-
val fromWordAux16 =
make {toMPLimb = MPLimb.fromWord16,
toObjptrWord = ObjptrWord.fromWord16,
|
|
From: Matthew F. <fl...@ml...> - 2006-04-18 17:53:22
|
Real{32,64} primitive semantics
----------------------------------------------------------------------
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/Makefile
A mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/default/default-real32.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-real.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/IEEE-real.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real.fun
A mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real0.sml
U mlton/branches/on-20050822-x86_64-branch/runtime/TODO
----------------------------------------------------------------------
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/Makefile
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/Makefile 2006-04-19 00:02:11 UTC (rev 4394)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/Makefile 2006-04-19 00:53:20 UTC (rev 4395)
@@ -26,7 +26,7 @@
CTYPES_MAPS = c-types.m32.map c-types.m64.map c-types.weird.map
DEFAULT_CHAR_MAPS = default-char8.map
DEFAULT_INT_MAPS = default-int32.map default-int64.map default-intinf.map
-DEFAULT_REAL_MAPS = default-real64.map
+DEFAULT_REAL_MAPS = default-real32.map default-real64.map
DEFAULT_WORD_MAPS = default-word32.map default-word64.map
.PHONY: type-check
Copied: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/default/default-real32.sml (from rev 4376, mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/default/default-real64.sml)
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/default/default-real64.sml 2006-03-04 19:37:37 UTC (rev 4376)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/config/default/default-real32.sml 2006-04-19 00:53:20 UTC (rev 4395)
@@ -0,0 +1,13 @@
+(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
+ * Jagannathan, and Stephen Weeks.
+ *
+ * MLton is released under a BSD-style license.
+ * See the file MLton-LICENSE for details.
+ *)
+
+structure Real = Real32
+type real = Real.real
+
+functor Real_ChooseRealN (A: CHOOSE_REALN_ARG) :
+ sig val f : Real.real A.t end =
+ ChooseRealN_Real32 (A)
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-real.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-real.sml 2006-04-19 00:02:11 UTC (rev 4394)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/primitive/prim-real.sml 2006-04-19 00:53:20 UTC (rev 4395)
@@ -74,19 +74,23 @@
val strto: Primitive.NullString8.t -> real
val ~ : real -> real
+ (* Integer to float; depends on rounding mode. *)
val fromInt8Unsafe: Primitive.Int8.int -> real
val fromInt16Unsafe: Primitive.Int16.int -> real
val fromInt32Unsafe: Primitive.Int32.int -> real
val fromInt64Unsafe: Primitive.Int64.int -> real
+ (* Float to float; depends on rounding mode. *)
val fromReal32Unsafe: Primitive.Real32.real -> real
val fromReal64Unsafe: Primitive.Real64.real -> real
+ (* Float to integer, taking lowbits. *)
val toInt8Unsafe: real -> Primitive.Int8.int
val toInt16Unsafe: real -> Primitive.Int16.int
val toInt32Unsafe: real -> Primitive.Int32.int
val toInt64Unsafe: real -> Primitive.Int64.int
+ (* Float to float; depends on rounding mode. *)
val toReal32Unsafe: real -> Primitive.Real32.real
val toReal64Unsafe: real -> Primitive.Real64.real
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/IEEE-real.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/IEEE-real.sml 2006-04-19 00:02:11 UTC (rev 4394)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/IEEE-real.sml 2006-04-19 00:53:20 UTC (rev 4395)
@@ -151,8 +151,7 @@
type exp = {digits: int list, negate: bool}
fun 'b afterE (state: 'a,
failure: unit -> 'b,
- success: exp * 'a -> 'b)
- : 'b =
+ success: exp * 'a -> 'b) : 'b =
case reader state of
NONE => failure ()
| SOME (c, state) =>
@@ -373,4 +372,3 @@
else num
end
end
-
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real.fun 2006-04-19 00:02:11 UTC (rev 4394)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real.fun 2006-04-19 00:53:20 UTC (rev 4395)
@@ -12,7 +12,7 @@
local
open IEEEReal
in
- datatype z = datatype float_class
+ datatype float_class = datatype float_class
datatype rounding_mode = datatype rounding_mode
end
infix 4 == != ?=
Added: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real0.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real0.sml 2006-04-19 00:02:11 UTC (rev 4394)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/real/real0.sml 2006-04-19 00:53:20 UTC (rev 4395)
@@ -0,0 +1,16 @@
+(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
+ * Jagannathan, and Stephen Weeks.
+ * Copyright (C) 1997-2000 NEC Research Institute.
+ *
+ * MLton is released under a BSD-style license.
+ * See the file MLton-LICENSE for details.
+ *)
+
+signature REAL0 =
+ sig
+ include PRIM_REAL
+
+ val zero: real
+ val one: real
+
+ end
\ No newline at end of file
Modified: mlton/branches/on-20050822-x86_64-branch/runtime/TODO
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/TODO 2006-04-19 00:02:11 UTC (rev 4394)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/TODO 2006-04-19 00:53:20 UTC (rev 4395)
@@ -7,6 +7,14 @@
Fix PackWord{16,32,64}_{sub,upadate}{,Rev} to use byte offset; This
requires fixing the semantics of the primitives as well.
+Rename primitives to indicate that these are not bit-wise identities
+ Real_toWord
+ Real_toReal
+ Word_toReal
+and add primitives
+ Real_toWord, Word_toReal
+that correspond to bit-wise identities.
+
basis/Int/Word.c
basis/IntInf.c
basis/MLton/allocTooLarge.c
|
|
From: Stephen W. <sw...@ml...> - 2006-04-18 17:02:13
|
Fixed typo.
----------------------------------------------------------------------
U mlton/trunk/runtime/gc.c
----------------------------------------------------------------------
Modified: mlton/trunk/runtime/gc.c
===================================================================
--- mlton/trunk/runtime/gc.c 2006-04-01 00:14:07 UTC (rev 4393)
+++ mlton/trunk/runtime/gc.c 2006-04-19 00:02:11 UTC (rev 4394)
@@ -893,7 +893,7 @@
static inline void assertIsInFromSpace (GC_state s, pointer *p) {
#if ASSERT
unless (isInFromSpace (s, *p))
- die ("gc.c: assertIsInFromSpace p = 0x%08x *p = 0x%08x);\n",
+ die ("gc.c: assertIsInFromSpace p = 0x%08x *p = 0x%08x;\n",
(uint)p, *(uint*)p);
/* The following checks that intergenerational pointers have the
* appropriate card marked. Unfortunately, it doesn't work because
|
|
From: Stephen W. <sw...@ml...> - 2006-03-31 16:14:08
|
Exported Url structure. ---------------------------------------------------------------------- U mlton/trunk/lib/mlton/basic/sources.cm U mlton/trunk/lib/mlton/sources.cm ---------------------------------------------------------------------- Modified: mlton/trunk/lib/mlton/basic/sources.cm =================================================================== --- mlton/trunk/lib/mlton/basic/sources.cm 2006-03-31 18:18:22 UTC (rev 4392) +++ mlton/trunk/lib/mlton/basic/sources.cm 2006-04-01 00:14:07 UTC (rev 4393) @@ -135,6 +135,7 @@ structure Unimplemented structure Unit structure Unsafe +structure Url structure Vector structure Word structure Word32 Modified: mlton/trunk/lib/mlton/sources.cm =================================================================== --- mlton/trunk/lib/mlton/sources.cm 2006-03-31 18:18:22 UTC (rev 4392) +++ mlton/trunk/lib/mlton/sources.cm 2006-04-01 00:14:07 UTC (rev 4393) @@ -156,6 +156,7 @@ structure Unimplemented structure Unit structure Unsafe +structure Url structure Vector structure Word structure Word8 |
|
From: Stephen W. <sw...@ml...> - 2006-03-31 10:18:23
|
Caught up with basis changes.
----------------------------------------------------------------------
U mlton/trunk/lib/mlton/basic/vector.fun
U mlton/trunk/lib/mlton/basic/vector.sig
U mlton/trunk/lib/mlton-stubs/array.sig
U mlton/trunk/lib/mlton-stubs/bin-io.sig
U mlton/trunk/lib/mlton-stubs/mlton.sml
U mlton/trunk/lib/mlton-stubs/pointer.sig
U mlton/trunk/lib/mlton-stubs/proc-env.sig
U mlton/trunk/lib/mlton-stubs/text-io.sig
U mlton/trunk/lib/mlton-stubs/vector.sig
----------------------------------------------------------------------
Modified: mlton/trunk/lib/mlton/basic/vector.fun
===================================================================
--- mlton/trunk/lib/mlton/basic/vector.fun 2006-03-31 18:17:59 UTC (rev 4391)
+++ mlton/trunk/lib/mlton/basic/vector.fun 2006-03-31 18:18:22 UTC (rev 4392)
@@ -17,7 +17,7 @@
fun unfold (n, a, f) = unfoldi (n, a, f o #2)
-fun tabulate (n, f) = unfoldi (n, (), fn (i, ()) => (f i, ()))
+fun tabulate (n, f) = #1 (unfoldi (n, (), fn (i, ()) => (f i, ())))
fun fromArray a =
tabulate (Pervasive.Array.length a, fn i => Pervasive.Array.sub (a, i))
@@ -457,36 +457,37 @@
let
val n = List.fold (vs, 0, fn (v, s) => s + length v)
in
- unfold (n, (0, v, vs'),
- let
- fun loop (i, v, vs) =
- if i < length v
- then (sub (v, i), (i + 1, v, vs))
- else
- case vs of
- [] => Error.bug "Vector.concat"
- | v :: vs => loop (0, v, vs)
- in loop
- end)
+ #1 (unfold (n, (0, v, vs'),
+ let
+ fun loop (i, v, vs) =
+ if i < length v
+ then (sub (v, i), (i + 1, v, vs))
+ else
+ case vs of
+ [] => Error.bug "Vector.concat"
+ | v :: vs => loop (0, v, vs)
+ in loop
+ end))
end
fun concatV vs =
- if 0 = length vs
- then new0 ()
+ if 0 = length vs then
+ new0 ()
else
let
val n = fold (vs, 0, fn (v, s) => s + length v)
fun state i = (i, sub (vs, i), 0)
in
- unfold (n, state 0,
- let
- fun loop (i, v, j) =
- if j < length v
- then (sub (v, j), (i, v, j + 1))
- else loop (state (i + 1))
- in loop
- end)
- end
+ #1 (unfold (n, state 0,
+ let
+ fun loop (i, v, j) =
+ if j < length v then
+ (sub (v, j), (i, v, j + 1))
+ else
+ loop (state (i + 1))
+ in loop
+ end))
+ end
fun splitLast v =
let
Modified: mlton/trunk/lib/mlton/basic/vector.sig
===================================================================
--- mlton/trunk/lib/mlton/basic/vector.sig 2006-03-31 18:17:59 UTC (rev 4391)
+++ mlton/trunk/lib/mlton/basic/vector.sig 2006-03-31 18:18:22 UTC (rev 4392)
@@ -14,7 +14,7 @@
val length: 'a t -> int
val sub: 'a t * int -> 'a
- val unfoldi: int * 'a * (int * 'a -> 'b * 'a) -> 'b t
+ val unfoldi: int * 'b * (int * 'b -> 'a * 'b) -> 'a t * 'b
end
signature VECTOR =
Modified: mlton/trunk/lib/mlton-stubs/array.sig
===================================================================
--- mlton/trunk/lib/mlton-stubs/array.sig 2006-03-31 18:17:59 UTC (rev 4391)
+++ mlton/trunk/lib/mlton-stubs/array.sig 2006-03-31 18:18:22 UTC (rev 4392)
@@ -1,5 +1,6 @@
-(* Copyright (C) 2002-2005 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
+ * Copyright (C) 1997-2000 NEC Research Institute.
*
* MLton is released under a BSD-style license.
* See the file MLton-LICENSE for details.
@@ -9,5 +10,5 @@
signature MLTON_ARRAY =
sig
- val unfoldi: int * 'b * (int * 'b -> 'a * 'b) -> 'a array
+ val unfoldi: int * 'b * (int * 'b -> 'a * 'b) -> 'a array * 'b
end
Modified: mlton/trunk/lib/mlton-stubs/bin-io.sig
===================================================================
--- mlton/trunk/lib/mlton-stubs/bin-io.sig 2006-03-31 18:17:59 UTC (rev 4391)
+++ mlton/trunk/lib/mlton-stubs/bin-io.sig 2006-03-31 18:18:22 UTC (rev 4392)
@@ -5,7 +5,5 @@
* See the file MLton-LICENSE for details.
*)
-signature MLTON_BIN_IO =
- MLTON_IO
- where type instream = BinIO.instream
- where type outstream = BinIO.outstream
+signature MLTON_BIN_IO = MLTON_IO
+
Modified: mlton/trunk/lib/mlton-stubs/mlton.sml
===================================================================
--- mlton/trunk/lib/mlton-stubs/mlton.sml 2006-03-31 18:17:59 UTC (rev 4391)
+++ mlton/trunk/lib/mlton-stubs/mlton.sml 2006-03-31 18:18:22 UTC (rev 4392)
@@ -59,14 +59,16 @@
fun unfoldi (n, a, f) =
let
val r = ref a
+ val a =
+ tabulate (n, fn i =>
+ let
+ val (b, a') = f (i, !r)
+ val _ = r := a'
+ in
+ b
+ end)
in
- tabulate (n, fn i =>
- let
- val (b, a') = f (i, !r)
- val _ = r := a'
- in
- b
- end)
+ (a, !r)
end
end
@@ -277,6 +279,8 @@
structure ProcEnv =
struct
+ type gid = Posix.ProcEnv.gid
+
fun setenv _ = raise Fail "setenv"
fun setgroups _ = raise Fail "setgroups"
end
@@ -568,17 +572,55 @@
struct
open Vector
+ fun create (n, f) =
+ let
+ val r = ref (Array.fromList [])
+ val lim = ref 0
+ fun check i =
+ if 0 <= i andalso i < !lim then () else raise Subscript
+ val sub = fn i => (check i; Array.sub (!r, i))
+ val update = fn (i, x) => (check i; Array.update (!r, i, x))
+ val (tab, finish) = f {sub = sub, update = update}
+ in
+ if 0 = n then
+ (finish (); Vector.fromList [])
+ else
+ let
+ val init = tab 0
+ val a = Array.array (n, init)
+ val () = r := a
+ val () =
+ Array.modifyi (fn (i, _) =>
+ let
+ val res =
+ if i = 0 then
+ init
+ else
+ tab i
+ val () = lim := i + 1
+ in
+ res
+ end)
+ a
+ val () = finish ()
+ in
+ Array.vector a
+ end
+ end
+
fun unfoldi (n, a, f) =
let
val r = ref a
+ val v =
+ tabulate (n, fn i =>
+ let
+ val (b, a') = f (i, !r)
+ val _ = r := a'
+ in
+ b
+ end)
in
- tabulate (n, fn i =>
- let
- val (b, a') = f (i, !r)
- val _ = r := a'
- in
- b
- end)
+ (v, !r)
end
end
Modified: mlton/trunk/lib/mlton-stubs/pointer.sig
===================================================================
--- mlton/trunk/lib/mlton-stubs/pointer.sig 2006-03-31 18:17:59 UTC (rev 4391)
+++ mlton/trunk/lib/mlton-stubs/pointer.sig 2006-03-31 18:18:22 UTC (rev 4392)
@@ -5,8 +5,8 @@
* See the file MLton-LICENSE for details.
*)
+type int = Int.int
type word = Word.word
-type int = Int.int
signature MLTON_POINTER =
sig
@@ -15,7 +15,7 @@
val add: t * word -> t
val compare: t * t -> order
val diff: t * t -> word
- val free: t -> unit
+(* val free: t -> unit *)
val getInt8: t * int -> Int8.int
val getInt16: t * int -> Int16.int
val getInt32: t * int -> Int32.int
Modified: mlton/trunk/lib/mlton-stubs/proc-env.sig
===================================================================
--- mlton/trunk/lib/mlton-stubs/proc-env.sig 2006-03-31 18:17:59 UTC (rev 4391)
+++ mlton/trunk/lib/mlton-stubs/proc-env.sig 2006-03-31 18:18:22 UTC (rev 4392)
@@ -1,5 +1,6 @@
-(* Copyright (C) 2002-2005 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
+ * Copyright (C) 1997-2000 NEC Research Institute.
*
* MLton is released under a BSD-style license.
* See the file MLton-LICENSE for details.
@@ -7,5 +8,8 @@
signature MLTON_PROC_ENV =
sig
+ type gid
+
val setenv: {name: string, value: string} -> unit
+ val setgroups: gid list -> unit
end
Modified: mlton/trunk/lib/mlton-stubs/text-io.sig
===================================================================
--- mlton/trunk/lib/mlton-stubs/text-io.sig 2006-03-31 18:17:59 UTC (rev 4391)
+++ mlton/trunk/lib/mlton-stubs/text-io.sig 2006-03-31 18:18:22 UTC (rev 4392)
@@ -1,11 +1,9 @@
-(* Copyright (C) 2002-2005 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
+ * Copyright (C) 1997-2000 NEC Research Institute.
*
* MLton is released under a BSD-style license.
* See the file MLton-LICENSE for details.
*)
-signature MLTON_TEXT_IO =
- MLTON_IO
- where type instream = TextIO.instream
- where type outstream = TextIO.outstream
+signature MLTON_TEXT_IO = MLTON_IO
Modified: mlton/trunk/lib/mlton-stubs/vector.sig
===================================================================
--- mlton/trunk/lib/mlton-stubs/vector.sig 2006-03-31 18:17:59 UTC (rev 4391)
+++ mlton/trunk/lib/mlton-stubs/vector.sig 2006-03-31 18:18:22 UTC (rev 4392)
@@ -1,5 +1,6 @@
-(* Copyright (C) 2002-2005 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
+ * Copyright (C) 1997-2000 NEC Research Institute.
*
* MLton is released under a BSD-style license.
* See the file MLton-LICENSE for details.
@@ -9,6 +10,10 @@
signature MLTON_VECTOR =
sig
- val unfoldi: int * 'b * (int * 'b -> 'a * 'b) -> 'a vector
+ val create:
+ int * ({sub: int -> 'a, update: int * 'a -> unit}
+ -> (int -> 'a) * (unit -> unit))
+ -> 'a vector
+ val unfoldi: int * 'b * (int * 'b -> 'a * 'b) -> 'a vector * 'b
end
|
|
From: Stephen W. <sw...@ml...> - 2006-03-31 10:18:00
|
Added toplevel type definitions of int and word to please SML/NJ.
These need to be here because this file is copied to lib/mlton-stubs/
----------------------------------------------------------------------
U mlton/trunk/basis-library/mlton/pointer.sig
----------------------------------------------------------------------
Modified: mlton/trunk/basis-library/mlton/pointer.sig
===================================================================
--- mlton/trunk/basis-library/mlton/pointer.sig 2006-03-31 02:17:42 UTC (rev 4390)
+++ mlton/trunk/basis-library/mlton/pointer.sig 2006-03-31 18:17:59 UTC (rev 4391)
@@ -5,6 +5,9 @@
* See the file MLton-LICENSE for details.
*)
+type int = Int.int
+type word = Word.word
+
signature MLTON_POINTER =
sig
eqtype t
|
|
From: Matthew F. <fl...@ml...> - 2006-03-30 18:18:03
|
Updated auto-generated .mlb files
----------------------------------------------------------------------
U mlton/trunk/lib/mlrisc-lib/MLRISC.patch
U mlton/trunk/lib/mlrisc-lib/MLRISC.tgz
----------------------------------------------------------------------
Modified: mlton/trunk/lib/mlrisc-lib/MLRISC.patch
===================================================================
--- mlton/trunk/lib/mlrisc-lib/MLRISC.patch 2006-03-30 23:49:53 UTC (rev 4389)
+++ mlton/trunk/lib/mlrisc-lib/MLRISC.patch 2006-03-31 02:17:42 UTC (rev 4390)
@@ -2524,7 +2524,7 @@
val clear : 'a array -> unit
diff -Naur MLRISC/mlb/ALPHA.mlb MLRISC-mlton/mlb/ALPHA.mlb
--- MLRISC/mlb/ALPHA.mlb 1969-12-31 19:00:00.000000000 -0500
-+++ MLRISC-mlton/mlb/ALPHA.mlb 2006-03-04 12:08:27.000000000 -0500
++++ MLRISC-mlton/mlb/ALPHA.mlb 2006-03-30 21:16:50.000000000 -0500
@@ -0,0 +1,476 @@
+
+ann
@@ -3004,7 +3004,7 @@
+end
diff -Naur MLRISC/mlb/Control.mlb MLRISC-mlton/mlb/Control.mlb
--- MLRISC/mlb/Control.mlb 1969-12-31 19:00:00.000000000 -0500
-+++ MLRISC-mlton/mlb/Control.mlb 2006-03-04 12:08:27.000000000 -0500
++++ MLRISC-mlton/mlb/Control.mlb 2006-03-30 21:16:50.000000000 -0500
@@ -0,0 +1,104 @@
+
+ann
@@ -3112,7 +3112,7 @@
+end
diff -Naur MLRISC/mlb/Graphs.mlb MLRISC-mlton/mlb/Graphs.mlb
--- MLRISC/mlb/Graphs.mlb 1969-12-31 19:00:00.000000000 -0500
-+++ MLRISC-mlton/mlb/Graphs.mlb 2006-03-04 12:08:27.000000000 -0500
++++ MLRISC-mlton/mlb/Graphs.mlb 2006-03-30 21:16:51.000000000 -0500
@@ -0,0 +1,708 @@
+
+ann
@@ -3824,7 +3824,7 @@
+end
diff -Naur MLRISC/mlb/HPPA.mlb MLRISC-mlton/mlb/HPPA.mlb
--- MLRISC/mlb/HPPA.mlb 1969-12-31 19:00:00.000000000 -0500
-+++ MLRISC-mlton/mlb/HPPA.mlb 2006-03-04 12:08:28.000000000 -0500
++++ MLRISC-mlton/mlb/HPPA.mlb 2006-03-30 21:16:52.000000000 -0500
@@ -0,0 +1,494 @@
+
+ann
@@ -4322,7 +4322,7 @@
+end
diff -Naur MLRISC/mlb/IA32.mlb MLRISC-mlton/mlb/IA32.mlb
--- MLRISC/mlb/IA32.mlb 1969-12-31 19:00:00.000000000 -0500
-+++ MLRISC-mlton/mlb/IA32.mlb 2006-03-04 12:08:29.000000000 -0500
++++ MLRISC-mlton/mlb/IA32.mlb 2006-03-30 21:16:53.000000000 -0500
@@ -0,0 +1,781 @@
+
+ann
@@ -5107,7 +5107,7 @@
+end
diff -Naur MLRISC/mlb/IA32-Peephole.mlb MLRISC-mlton/mlb/IA32-Peephole.mlb
--- MLRISC/mlb/IA32-Peephole.mlb 1969-12-31 19:00:00.000000000 -0500
-+++ MLRISC-mlton/mlb/IA32-Peephole.mlb 2006-03-04 12:08:29.000000000 -0500
++++ MLRISC-mlton/mlb/IA32-Peephole.mlb 2006-03-30 21:16:53.000000000 -0500
@@ -0,0 +1,60 @@
+
+ann
@@ -5171,7 +5171,7 @@
+end
diff -Naur MLRISC/mlb/Lib.mlb MLRISC-mlton/mlb/Lib.mlb
--- MLRISC/mlb/Lib.mlb 1969-12-31 19:00:00.000000000 -0500
-+++ MLRISC-mlton/mlb/Lib.mlb 2006-03-04 12:08:29.000000000 -0500
++++ MLRISC-mlton/mlb/Lib.mlb 2006-03-30 21:16:54.000000000 -0500
@@ -0,0 +1,267 @@
+
+ann
@@ -5442,7 +5442,7 @@
+end
diff -Naur MLRISC/mlb/MLRISC.mlb MLRISC-mlton/mlb/MLRISC.mlb
--- MLRISC/mlb/MLRISC.mlb 1969-12-31 19:00:00.000000000 -0500
-+++ MLRISC-mlton/mlb/MLRISC.mlb 2006-03-04 12:08:30.000000000 -0500
++++ MLRISC-mlton/mlb/MLRISC.mlb 2006-03-30 21:16:56.000000000 -0500
@@ -0,0 +1,1705 @@
+
+ann
@@ -7151,7 +7151,7 @@
+end
diff -Naur MLRISC/mlb/MLTREE.mlb MLRISC-mlton/mlb/MLTREE.mlb
--- MLRISC/mlb/MLTREE.mlb 1969-12-31 19:00:00.000000000 -0500
-+++ MLRISC-mlton/mlb/MLTREE.mlb 2006-03-04 12:08:30.000000000 -0500
++++ MLRISC-mlton/mlb/MLTREE.mlb 2006-03-30 21:16:57.000000000 -0500
@@ -0,0 +1,213 @@
+
+ann
@@ -7368,7 +7368,7 @@
+end
diff -Naur MLRISC/mlb/Peephole.mlb MLRISC-mlton/mlb/Peephole.mlb
--- MLRISC/mlb/Peephole.mlb 1969-12-31 19:00:00.000000000 -0500
-+++ MLRISC-mlton/mlb/Peephole.mlb 2006-03-04 12:08:30.000000000 -0500
++++ MLRISC-mlton/mlb/Peephole.mlb 2006-03-30 21:16:57.000000000 -0500
@@ -0,0 +1,61 @@
+
+ann
@@ -7433,7 +7433,7 @@
+end
diff -Naur MLRISC/mlb/PPC.mlb MLRISC-mlton/mlb/PPC.mlb
--- MLRISC/mlb/PPC.mlb 1969-12-31 19:00:00.000000000 -0500
-+++ MLRISC-mlton/mlb/PPC.mlb 2006-03-04 12:08:31.000000000 -0500
++++ MLRISC-mlton/mlb/PPC.mlb 2006-03-30 21:16:57.000000000 -0500
@@ -0,0 +1,575 @@
+
+ann
@@ -8012,7 +8012,7 @@
+end
diff -Naur MLRISC/mlb/RA.mlb MLRISC-mlton/mlb/RA.mlb
--- MLRISC/mlb/RA.mlb 1969-12-31 19:00:00.000000000 -0500
-+++ MLRISC-mlton/mlb/RA.mlb 2006-03-04 12:08:31.000000000 -0500
++++ MLRISC-mlton/mlb/RA.mlb 2006-03-30 21:16:58.000000000 -0500
@@ -0,0 +1,152 @@
+
+ann
@@ -8168,7 +8168,7 @@
+end
diff -Naur MLRISC/mlb/SPARC.mlb MLRISC-mlton/mlb/SPARC.mlb
--- MLRISC/mlb/SPARC.mlb 1969-12-31 19:00:00.000000000 -0500
-+++ MLRISC-mlton/mlb/SPARC.mlb 2006-03-04 12:08:31.000000000 -0500
++++ MLRISC-mlton/mlb/SPARC.mlb 2006-03-30 21:16:58.000000000 -0500
@@ -0,0 +1,540 @@
+
+ann
@@ -8712,7 +8712,7 @@
+end
diff -Naur MLRISC/mlb/Visual.mlb MLRISC-mlton/mlb/Visual.mlb
--- MLRISC/mlb/Visual.mlb 1969-12-31 19:00:00.000000000 -0500
-+++ MLRISC-mlton/mlb/Visual.mlb 2006-03-04 12:08:31.000000000 -0500
++++ MLRISC-mlton/mlb/Visual.mlb 2006-03-30 21:16:59.000000000 -0500
@@ -0,0 +1,252 @@
+
+ann
@@ -8968,7 +8968,7 @@
+end
diff -Naur MLRISC/mlrisc-lib.mlb MLRISC-mlton/mlrisc-lib.mlb
--- MLRISC/mlrisc-lib.mlb 1969-12-31 19:00:00.000000000 -0500
-+++ MLRISC-mlton/mlrisc-lib.mlb 2006-03-04 12:08:31.000000000 -0500
++++ MLRISC-mlton/mlrisc-lib.mlb 2006-03-30 21:16:59.000000000 -0500
@@ -0,0 +1,17 @@
+(* DO NOT USE. Only suitable for type-checking purposes. *)
+local
Modified: mlton/trunk/lib/mlrisc-lib/MLRISC.tgz
===================================================================
(Binary files differ)
|
|
From: Stephen W. <sw...@ml...> - 2006-03-30 15:49:53
|
Added toplevel type definitions of int and word to please SML/NJ.
----------------------------------------------------------------------
U mlton/trunk/lib/mlton-stubs/pointer.sig
----------------------------------------------------------------------
Modified: mlton/trunk/lib/mlton-stubs/pointer.sig
===================================================================
--- mlton/trunk/lib/mlton-stubs/pointer.sig 2006-03-30 20:37:36 UTC (rev 4388)
+++ mlton/trunk/lib/mlton-stubs/pointer.sig 2006-03-30 23:49:53 UTC (rev 4389)
@@ -5,6 +5,9 @@
* See the file MLton-LICENSE for details.
*)
+type word = Word.word
+type int = Int.int
+
signature MLTON_POINTER =
sig
eqtype t
|
|
From: Stephen W. <sw...@ml...> - 2006-03-30 12:37:39
|
Eliminated deprecated checkSlice{,Max}.
----------------------------------------------------------------------
U mlton/trunk/basis-library/arrays-and-vectors/array.sig
U mlton/trunk/basis-library/arrays-and-vectors/array2.sml
U mlton/trunk/basis-library/arrays-and-vectors/sequence.fun
U mlton/trunk/basis-library/arrays-and-vectors/sequence.sig
U mlton/trunk/basis-library/arrays-and-vectors/vector.sig
U mlton/trunk/basis-library/real/pack-real.sml
----------------------------------------------------------------------
Modified: mlton/trunk/basis-library/arrays-and-vectors/array.sig
===================================================================
--- mlton/trunk/basis-library/arrays-and-vectors/array.sig 2006-03-30 20:09:58 UTC (rev 4387)
+++ mlton/trunk/basis-library/arrays-and-vectors/array.sig 2006-03-30 20:37:36 UTC (rev 4388)
@@ -40,8 +40,6 @@
structure ArraySlice: ARRAY_SLICE_EXTRA
- val checkSlice: 'a array * int * int option -> int (* Deprecated *)
- val checkSliceMax: int * int option * int -> int (* Deprecated *)
val concat: 'a array list -> 'a array
val duplicate: 'a array -> 'a array
val rawArray: int -> 'a array
Modified: mlton/trunk/basis-library/arrays-and-vectors/array2.sml
===================================================================
--- mlton/trunk/basis-library/arrays-and-vectors/array2.sml 2006-03-30 20:09:58 UTC (rev 4387)
+++ mlton/trunk/basis-library/arrays-and-vectors/array2.sml 2006-03-30 20:37:36 UTC (rev 4388)
@@ -28,10 +28,28 @@
nrows: int option,
ncols: int option}
+ fun checkSliceMax (start: int, num: int option, max: int): int =
+ case num of
+ NONE =>
+ if Primitive.safe andalso (start < 0 orelse start > max) then
+ raise Subscript
+ else
+ max
+ | SOME num =>
+ if Primitive.safe
+ andalso (start < 0
+ orelse num < 0
+ orelse start > max -? num) then
+ raise Subscript
+ else
+ start +? num
+
fun checkRegion {base, row, col, nrows, ncols} =
- let val (rows, cols) = dimensions base
- in {stopRow = Array.checkSliceMax (row, nrows, rows),
- stopCol = Array.checkSliceMax (col, ncols, cols)}
+ let
+ val (rows, cols) = dimensions base
+ in
+ {stopRow = checkSliceMax (row, nrows, rows),
+ stopCol = checkSliceMax (col, ncols, cols)}
end
fun wholeRegion (a: 'a array): 'a region =
Modified: mlton/trunk/basis-library/arrays-and-vectors/sequence.fun
===================================================================
--- mlton/trunk/basis-library/arrays-and-vectors/sequence.fun 2006-03-30 20:09:58 UTC (rev 4387)
+++ mlton/trunk/basis-library/arrays-and-vectors/sequence.fun 2006-03-30 20:37:36 UTC (rev 4388)
@@ -456,18 +456,4 @@
fun duplicate seq = make Slice.sequence seq
fun toList seq = make Slice.toList seq
end
-
- (* Deprecated *)
- fun checkSliceMax (start: int, num: int option, max: int): int =
- case num of
- NONE => if Primitive.safe andalso (start < 0 orelse start > max)
- then raise Subscript
- else max
- | SOME num =>
- if Primitive.safe
- andalso (start < 0 orelse num < 0 orelse start > max -? num)
- then raise Subscript
- else start +? num
- (* Deprecated *)
- fun checkSlice (s, i, opt) = checkSliceMax (i, opt, length s)
end
Modified: mlton/trunk/basis-library/arrays-and-vectors/sequence.sig
===================================================================
--- mlton/trunk/basis-library/arrays-and-vectors/sequence.sig 2006-03-30 20:09:58 UTC (rev 4387)
+++ mlton/trunk/basis-library/arrays-and-vectors/sequence.sig 2006-03-30 20:37:36 UTC (rev 4388)
@@ -63,9 +63,4 @@
val new: int * 'a elt -> 'a sequence
val toList: 'a sequence -> 'a elt list
val unfoldi: int * 'a * (int * 'a -> 'b elt * 'a) -> 'b sequence * 'a
-
- (* Deprecated *)
- val checkSlice: 'a sequence * int * int option -> int
- (* Deprecated *)
- val checkSliceMax: int * int option * int -> int
end
Modified: mlton/trunk/basis-library/arrays-and-vectors/vector.sig
===================================================================
--- mlton/trunk/basis-library/arrays-and-vectors/vector.sig 2006-03-30 20:09:58 UTC (rev 4387)
+++ mlton/trunk/basis-library/arrays-and-vectors/vector.sig 2006-03-30 20:37:36 UTC (rev 4388)
@@ -34,28 +34,24 @@
include VECTOR
structure VectorSlice: VECTOR_SLICE_EXTRA
- val unsafeSub: 'a vector * int -> 'a
-
- (* Used to implement Substring/String functions *)
- val concatWith: 'a vector -> 'a vector list -> 'a vector
- val isPrefix: ('a * 'a -> bool) -> 'a vector -> 'a vector -> bool
- val isSubvector: ('a * 'a -> bool) -> 'a vector -> 'a vector -> bool
- val isSuffix: ('a * 'a -> bool) -> 'a vector -> 'a vector -> bool
- val translate: ('a -> 'a vector) -> 'a vector -> 'a vector
- val tokens: ('a -> bool) -> 'a vector -> 'a vector list
- val fields: ('a -> bool) -> 'a vector -> 'a vector list
-
val append: 'a vector * 'a vector -> 'a vector
+ (* concatWith is used to implement Substring/String functions *)
+ val concatWith: 'a vector -> 'a vector list -> 'a vector
val create:
- int * ({sub: int -> 'a, update: int * 'a -> unit}
- -> (int -> 'a) * (unit -> unit))
+ int
+ * ({sub: int -> 'a, update: int * 'a -> unit}
+ -> (int -> 'a) * (unit -> unit))
-> 'a vector
val duplicate: 'a vector -> 'a vector
+ val fields: ('a -> bool) -> 'a vector -> 'a vector list
val fromArray: 'a array -> 'a vector
+ val isPrefix: ('a * 'a -> bool) -> 'a vector -> 'a vector -> bool
+ val isSubvector: ('a * 'a -> bool) -> 'a vector -> 'a vector -> bool
+ val isSuffix: ('a * 'a -> bool) -> 'a vector -> 'a vector -> bool
val toList: 'a vector -> 'a list
+ val tokens: ('a -> bool) -> 'a vector -> 'a vector list
+ val translate: ('a -> 'a vector) -> 'a vector -> 'a vector
val unfoldi: int * 'b * (int * 'b -> 'a * 'b) -> 'a vector * 'b
+ val unsafeSub: 'a vector * int -> 'a
val vector: int * 'a -> 'a vector
-
- (* Deprecated *)
- val checkSlice: 'a vector * int * int option -> int
end
Modified: mlton/trunk/basis-library/real/pack-real.sml
===================================================================
--- mlton/trunk/basis-library/real/pack-real.sml 2006-03-30 20:09:58 UTC (rev 4387)
+++ mlton/trunk/basis-library/real/pack-real.sml 2006-03-30 20:37:36 UTC (rev 4388)
@@ -24,10 +24,16 @@
then (subVec, update)
else (subVecRev, updateRev)
+fun check (size, i) =
+ if Int.< (i, 0) orelse Int.> (i, size -? bytesPerElem) then
+ raise Subscript
+ else
+ ()
+
fun update (a, i, r) =
let
+ val () = check (Word8Array.length a, i)
val a = Word8Array.toPoly a
- val _ = Array.checkSlice (a, i, SOME bytesPerElem)
in
up (a, i, r)
end
@@ -42,8 +48,8 @@
fun subVec (v, i) =
let
+ val () = check (Word8Vector.length v, i)
val v = Word8Vector.toPoly v
- val _ = Vector.checkSlice (v, i, SOME bytesPerElem)
in
sub (v, i)
end
|
|
From: Stephen W. <sw...@ml...> - 2006-03-30 12:10:00
|
Changed unfoldi to return the state in addition to the created
object.
----------------------------------------------------------------------
U mlton/trunk/basis-library/arrays-and-vectors/array.sig
U mlton/trunk/basis-library/arrays-and-vectors/mono-array.sig
U mlton/trunk/basis-library/arrays-and-vectors/mono-vector.sig
U mlton/trunk/basis-library/arrays-and-vectors/sequence.fun
U mlton/trunk/basis-library/arrays-and-vectors/sequence.sig
U mlton/trunk/basis-library/arrays-and-vectors/vector.sig
U mlton/trunk/basis-library/mlton/array.sig
U mlton/trunk/basis-library/mlton/vector.sig
----------------------------------------------------------------------
Modified: mlton/trunk/basis-library/arrays-and-vectors/array.sig
===================================================================
--- mlton/trunk/basis-library/arrays-and-vectors/array.sig 2006-03-30 11:07:48 UTC (rev 4386)
+++ mlton/trunk/basis-library/arrays-and-vectors/array.sig 2006-03-30 20:09:58 UTC (rev 4387)
@@ -40,17 +40,13 @@
structure ArraySlice: ARRAY_SLICE_EXTRA
- val rawArray: int -> 'a array
- val unsafeSub: 'a array * int -> 'a
- val unsafeUpdate: 'a array * int * 'a -> unit
-
+ val checkSlice: 'a array * int * int option -> int (* Deprecated *)
+ val checkSliceMax: int * int option * int -> int (* Deprecated *)
val concat: 'a array list -> 'a array
val duplicate: 'a array -> 'a array
+ val rawArray: int -> 'a array
val toList: 'a array -> 'a list
- val unfoldi: int * 'a * (int * 'a -> 'b * 'a) -> 'b array
-
- (* Deprecated *)
- val checkSlice: 'a array * int * int option -> int
- (* Deprecated *)
- val checkSliceMax: int * int option * int -> int
+ val unfoldi: int * 'b * (int * 'b -> 'a * 'b) -> 'a array * 'b
+ val unsafeSub: 'a array * int -> 'a
+ val unsafeUpdate: 'a array * int * 'a -> unit
end
Modified: mlton/trunk/basis-library/arrays-and-vectors/mono-array.sig
===================================================================
--- mlton/trunk/basis-library/arrays-and-vectors/mono-array.sig 2006-03-30 11:07:48 UTC (rev 4386)
+++ mlton/trunk/basis-library/arrays-and-vectors/mono-array.sig 2006-03-30 20:09:58 UTC (rev 4387)
@@ -45,7 +45,7 @@
val rawArray: int -> array
val toList: array -> elem list
val toPoly: array -> elem Array.array
- val unfoldi: int * 'a * (int * 'a -> elem * 'a) -> array
+ val unfoldi: int * 'a * (int * 'a -> elem * 'a) -> array * 'a
val unsafeSub: array * int -> elem
val unsafeUpdate: array * int * elem -> unit
end
Modified: mlton/trunk/basis-library/arrays-and-vectors/mono-vector.sig
===================================================================
--- mlton/trunk/basis-library/arrays-and-vectors/mono-vector.sig 2006-03-30 11:07:48 UTC (rev 4386)
+++ mlton/trunk/basis-library/arrays-and-vectors/mono-vector.sig 2006-03-30 20:09:58 UTC (rev 4387)
@@ -41,7 +41,7 @@
val toList: vector -> elem list
val tokens: (elem -> bool) -> vector -> vector list
val translate: (elem -> vector) -> vector -> vector
- val unfoldi: int * 'a * (int * 'a -> elem * 'a) -> vector
+ val unfoldi: int * 'a * (int * 'a -> elem * 'a) -> vector * 'a
val unsafeSub: vector * int -> elem
val vector: int * elem -> vector
end
Modified: mlton/trunk/basis-library/arrays-and-vectors/sequence.fun
===================================================================
--- mlton/trunk/basis-library/arrays-and-vectors/sequence.fun 2006-03-30 11:07:48 UTC (rev 4386)
+++ mlton/trunk/basis-library/arrays-and-vectors/sequence.fun 2006-03-30 20:09:58 UTC (rev 4387)
@@ -39,21 +39,21 @@
let
val a = array n
fun loop (i, b) =
- if i >= n
- then ()
+ if i >= n then
+ b
else
let
val (x, b') = f (i, b)
- val _ = Array.update (a, i, x)
+ val () = Array.update (a, i, x)
in
loop (i +? 1, b')
end
- val () = loop (0, b)
+ val b = loop (0, b)
in
- fromArray a
+ (fromArray a, b)
end
- fun tabulate (n, f) = unfoldi (n, (), fn (i, ()) => (f i, ()))
+ fun tabulate (n, f) = #1 (unfoldi (n, (), fn (i, ()) => (f i, ())))
fun new (n, x) = tabulate (n, fn _ => x)
@@ -191,25 +191,26 @@
in loop (min1, min2)
end
fun sequence (sl as T {seq, start, len}): 'a sequence =
- if isMutable orelse (start <> 0 orelse len <> S.length seq)
- then map (fn x => x) sl
- else seq
+ if isMutable orelse (start <> 0 orelse len <> S.length seq) then
+ map (fn x => x) sl
+ else
+ seq
fun append (sl1: 'a slice, sl2: 'a slice): 'a sequence =
- if length sl1 = 0
- then sequence sl2
- else if length sl2 = 0
- then sequence sl1
+ if length sl1 = 0 then
+ sequence sl2
+ else if length sl2 = 0 then
+ sequence sl1
else
let
val l1 = length sl1
val l2 = length sl2
val n = l1 + l2 handle Overflow => raise Size
in
- unfoldi (n, (0, sl1),
- fn (_, (i, sl)) =>
- if i < length sl
- then (unsafeSub (sl, i), (i +? 1, sl))
- else (unsafeSub (sl2, 0), (1, sl2)))
+ #1 (unfoldi (n, (0, sl1),
+ fn (_, (i, sl)) =>
+ if i < length sl then
+ (unsafeSub (sl, i), (i +? 1, sl))
+ else (unsafeSub (sl2, 0), (1, sl2))))
end
fun concat (sls: 'a slice list): 'a sequence =
case sls of
@@ -220,17 +221,19 @@
val n = List.foldl (fn (sl, s) => s + length sl) 0 sls'
handle Overflow => raise Size
in
- unfoldi (n, (0, sl, sls),
- fn (_, ac) =>
- let
- fun loop (i, sl, sls) =
- if i < length sl
- then (unsafeSub (sl, i), (i +? 1, sl, sls))
- else case sls of
- [] => raise Fail "concat bug"
- | sl :: sls => loop (0, sl, sls)
- in loop ac
- end)
+ #1 (unfoldi (n, (0, sl, sls),
+ fn (_, ac) =>
+ let
+ fun loop (i, sl, sls) =
+ if i < length sl then
+ (unsafeSub (sl, i),
+ (i +? 1, sl, sls))
+ else case sls of
+ [] => raise Fail "concat bug"
+ | sl :: sls => loop (0, sl, sls)
+ in
+ loop ac
+ end))
end
fun concatWith (sep: 'a sequence) (sls: 'a slice list): 'a sequence =
let val sep = full sep
Modified: mlton/trunk/basis-library/arrays-and-vectors/sequence.sig
===================================================================
--- mlton/trunk/basis-library/arrays-and-vectors/sequence.sig 2006-03-30 11:07:48 UTC (rev 4386)
+++ mlton/trunk/basis-library/arrays-and-vectors/sequence.sig 2006-03-30 20:09:58 UTC (rev 4387)
@@ -62,7 +62,7 @@
val duplicate: 'a sequence -> 'a sequence
val new: int * 'a elt -> 'a sequence
val toList: 'a sequence -> 'a elt list
- val unfoldi: int * 'a * (int * 'a -> 'b elt * 'a) -> 'b sequence
+ val unfoldi: int * 'a * (int * 'a -> 'b elt * 'a) -> 'b sequence * 'a
(* Deprecated *)
val checkSlice: 'a sequence * int * int option -> int
Modified: mlton/trunk/basis-library/arrays-and-vectors/vector.sig
===================================================================
--- mlton/trunk/basis-library/arrays-and-vectors/vector.sig 2006-03-30 11:07:48 UTC (rev 4386)
+++ mlton/trunk/basis-library/arrays-and-vectors/vector.sig 2006-03-30 20:09:58 UTC (rev 4387)
@@ -53,7 +53,7 @@
val duplicate: 'a vector -> 'a vector
val fromArray: 'a array -> 'a vector
val toList: 'a vector -> 'a list
- val unfoldi: int * 'a * (int * 'a -> 'b * 'a) -> 'b vector
+ val unfoldi: int * 'b * (int * 'b -> 'a * 'b) -> 'a vector * 'b
val vector: int * 'a -> 'a vector
(* Deprecated *)
Modified: mlton/trunk/basis-library/mlton/array.sig
===================================================================
--- mlton/trunk/basis-library/mlton/array.sig 2006-03-30 11:07:48 UTC (rev 4386)
+++ mlton/trunk/basis-library/mlton/array.sig 2006-03-30 20:09:58 UTC (rev 4387)
@@ -10,5 +10,5 @@
signature MLTON_ARRAY =
sig
- val unfoldi: int * 'b * (int * 'b -> 'a * 'b) -> 'a array
+ val unfoldi: int * 'b * (int * 'b -> 'a * 'b) -> 'a array * 'b
end
Modified: mlton/trunk/basis-library/mlton/vector.sig
===================================================================
--- mlton/trunk/basis-library/mlton/vector.sig 2006-03-30 11:07:48 UTC (rev 4386)
+++ mlton/trunk/basis-library/mlton/vector.sig 2006-03-30 20:09:58 UTC (rev 4387)
@@ -14,6 +14,6 @@
int * ({sub: int -> 'a, update: int * 'a -> unit}
-> (int -> 'a) * (unit -> unit))
-> 'a vector
- val unfoldi: int * 'b * (int * 'b -> 'a * 'b) -> 'a vector
+ val unfoldi: int * 'b * (int * 'b -> 'a * 'b) -> 'a vector * 'b
end
|
|
From: Matthew F. <fl...@ml...> - 2006-03-30 03:07:50
|
Removed absolute paths ---------------------------------------------------------------------- U mlton/trunk/lib/mlrisc-lib/MLRISC.patch ---------------------------------------------------------------------- Modified: mlton/trunk/lib/mlrisc-lib/MLRISC.patch =================================================================== --- mlton/trunk/lib/mlrisc-lib/MLRISC.patch 2006-03-29 22:04:27 UTC (rev 4385) +++ mlton/trunk/lib/mlrisc-lib/MLRISC.patch 2006-03-30 11:07:48 UTC (rev 4386) @@ -2544,15 +2544,15 @@ + end + basis l4 = + bas -+ (* $MLRISC.cm(=$SMLNJ-MLRISC)/MLRISC.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/MLRISC.mlb ++ (* $MLRISC.cm(=$SMLNJ-MLRISC)/MLRISC.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/MLRISC.mlb + end + basis l50 = + bas -+ (* $Control.cm(=$SMLNJ-MLRISC)/Control.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Control.mlb ++ (* $Control.cm(=$SMLNJ-MLRISC)/Control.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Control.mlb + end + basis l9 = + bas -+ (* $Lib.cm(=$SMLNJ-MLRISC)/Lib.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Lib.mlb ++ (* $Lib.cm(=$SMLNJ-MLRISC)/Lib.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Lib.mlb + end +in +local @@ -3132,7 +3132,7 @@ + end + basis l29 = + bas -+ (* $Lib.cm(=$SMLNJ-MLRISC)/Lib.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Lib.mlb ++ (* $Lib.cm(=$SMLNJ-MLRISC)/Lib.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Lib.mlb + end +in +local @@ -3844,15 +3844,15 @@ + end + basis l4 = + bas -+ (* $MLRISC.cm(=$SMLNJ-MLRISC)/MLRISC.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/MLRISC.mlb ++ (* $MLRISC.cm(=$SMLNJ-MLRISC)/MLRISC.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/MLRISC.mlb + end + basis l16 = + bas -+ (* $Control.cm(=$SMLNJ-MLRISC)/Control.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Control.mlb ++ (* $Control.cm(=$SMLNJ-MLRISC)/Control.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Control.mlb + end + basis l37 = + bas -+ (* $Lib.cm(=$SMLNJ-MLRISC)/Lib.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Lib.mlb ++ (* $Lib.cm(=$SMLNJ-MLRISC)/Lib.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Lib.mlb + end +in +local @@ -4342,23 +4342,23 @@ + end + basis l4 = + bas -+ (* $MLRISC.cm(=$SMLNJ-MLRISC)/MLRISC.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/MLRISC.mlb ++ (* $MLRISC.cm(=$SMLNJ-MLRISC)/MLRISC.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/MLRISC.mlb + end + basis l12 = + bas -+ (* $Control.cm(=$SMLNJ-MLRISC)/Control.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Control.mlb ++ (* $Control.cm(=$SMLNJ-MLRISC)/Control.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Control.mlb + end + basis l230 = + bas -+ (* $Graphs.cm(=$SMLNJ-MLRISC)/Graphs.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Graphs.mlb ++ (* $Graphs.cm(=$SMLNJ-MLRISC)/Graphs.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Graphs.mlb + end + basis l39 = + bas -+ (* $Lib.cm(=$SMLNJ-MLRISC)/Lib.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Lib.mlb ++ (* $Lib.cm(=$SMLNJ-MLRISC)/Lib.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Lib.mlb + end + basis l311 = + bas -+ (* $MLTREE.cm(=$SMLNJ-MLRISC)/MLTREE.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/MLTREE.mlb ++ (* $MLTREE.cm(=$SMLNJ-MLRISC)/MLTREE.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/MLTREE.mlb + end +in +local @@ -5119,15 +5119,15 @@ +local + basis l8 = + bas -+ (* $MLRISC.cm(=$SMLNJ-MLRISC)/MLRISC.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/MLRISC.mlb ++ (* $MLRISC.cm(=$SMLNJ-MLRISC)/MLRISC.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/MLRISC.mlb + end + basis l16 = + bas -+ (* $IA32.cm(=$SMLNJ-MLRISC)/IA32.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/IA32.mlb ++ (* $IA32.cm(=$SMLNJ-MLRISC)/IA32.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/IA32.mlb + end + basis l4 = + bas -+ (* $Peephole.cm(=$SMLNJ-MLRISC)/Peephole.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Peephole.mlb ++ (* $Peephole.cm(=$SMLNJ-MLRISC)/Peephole.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Peephole.mlb + end +in +local @@ -5462,15 +5462,15 @@ + end + basis l44 = + bas -+ (* $Control.cm(=$SMLNJ-MLRISC)/Control.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Control.mlb ++ (* $Control.cm(=$SMLNJ-MLRISC)/Control.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Control.mlb + end + basis l5 = + bas -+ (* $Graphs.cm(=$SMLNJ-MLRISC)/Graphs.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Graphs.mlb ++ (* $Graphs.cm(=$SMLNJ-MLRISC)/Graphs.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Graphs.mlb + end + basis l9 = + bas -+ (* $Lib.cm(=$SMLNJ-MLRISC)/Lib.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Lib.mlb ++ (* $Lib.cm(=$SMLNJ-MLRISC)/Lib.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Lib.mlb + end +in +local @@ -7171,15 +7171,15 @@ + end + basis l4 = + bas -+ (* $MLRISC.cm(=$SMLNJ-MLRISC)/MLRISC.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/MLRISC.mlb ++ (* $MLRISC.cm(=$SMLNJ-MLRISC)/MLRISC.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/MLRISC.mlb + end + basis l42 = + bas -+ (* $Control.cm(=$SMLNJ-MLRISC)/Control.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Control.mlb ++ (* $Control.cm(=$SMLNJ-MLRISC)/Control.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Control.mlb + end + basis l68 = + bas -+ (* $Lib.cm(=$SMLNJ-MLRISC)/Lib.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Lib.mlb ++ (* $Lib.cm(=$SMLNJ-MLRISC)/Lib.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Lib.mlb + end +in +local @@ -7380,11 +7380,11 @@ +local + basis l4 = + bas -+ (* $MLRISC.cm(=$SMLNJ-MLRISC)/MLRISC.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/MLRISC.mlb ++ (* $MLRISC.cm(=$SMLNJ-MLRISC)/MLRISC.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/MLRISC.mlb + end + basis l14 = + bas -+ (* $Graphs.cm(=$SMLNJ-MLRISC)/Graphs.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Graphs.mlb ++ (* $Graphs.cm(=$SMLNJ-MLRISC)/Graphs.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Graphs.mlb + end +in +local @@ -7453,15 +7453,15 @@ + end + basis l4 = + bas -+ (* $MLRISC.cm(=$SMLNJ-MLRISC)/MLRISC.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/MLRISC.mlb ++ (* $MLRISC.cm(=$SMLNJ-MLRISC)/MLRISC.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/MLRISC.mlb + end + basis l50 = + bas -+ (* $Control.cm(=$SMLNJ-MLRISC)/Control.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Control.mlb ++ (* $Control.cm(=$SMLNJ-MLRISC)/Control.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Control.mlb + end + basis l9 = + bas -+ (* $Lib.cm(=$SMLNJ-MLRISC)/Lib.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Lib.mlb ++ (* $Lib.cm(=$SMLNJ-MLRISC)/Lib.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Lib.mlb + end +in +local @@ -8032,15 +8032,15 @@ + end + basis l4 = + bas -+ (* $MLRISC.cm(=$SMLNJ-MLRISC)/MLRISC.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/MLRISC.mlb ++ (* $MLRISC.cm(=$SMLNJ-MLRISC)/MLRISC.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/MLRISC.mlb + end + basis l53 = + bas -+ (* $Control.cm(=$SMLNJ-MLRISC)/Control.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Control.mlb ++ (* $Control.cm(=$SMLNJ-MLRISC)/Control.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Control.mlb + end + basis l29 = + bas -+ (* $Lib.cm(=$SMLNJ-MLRISC)/Lib.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Lib.mlb ++ (* $Lib.cm(=$SMLNJ-MLRISC)/Lib.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Lib.mlb + end +in +local @@ -8188,15 +8188,15 @@ + end + basis l4 = + bas -+ (* $MLRISC.cm(=$SMLNJ-MLRISC)/MLRISC.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/MLRISC.mlb ++ (* $MLRISC.cm(=$SMLNJ-MLRISC)/MLRISC.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/MLRISC.mlb + end + basis l46 = + bas -+ (* $Control.cm(=$SMLNJ-MLRISC)/Control.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Control.mlb ++ (* $Control.cm(=$SMLNJ-MLRISC)/Control.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Control.mlb + end + basis l30 = + bas -+ (* $Lib.cm(=$SMLNJ-MLRISC)/Lib.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Lib.mlb ++ (* $Lib.cm(=$SMLNJ-MLRISC)/Lib.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Lib.mlb + end +in +local @@ -8728,19 +8728,19 @@ + end + basis l66 = + bas -+ (* $MLRISC.cm(=$SMLNJ-MLRISC)/MLRISC.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/MLRISC.mlb ++ (* $MLRISC.cm(=$SMLNJ-MLRISC)/MLRISC.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/MLRISC.mlb + end + basis l5 = + bas -+ (* $Control.cm(=$SMLNJ-MLRISC)/Control.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Control.mlb ++ (* $Control.cm(=$SMLNJ-MLRISC)/Control.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Control.mlb + end + basis l12 = + bas -+ (* $Graphs.cm(=$SMLNJ-MLRISC)/Graphs.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Graphs.mlb ++ (* $Graphs.cm(=$SMLNJ-MLRISC)/Graphs.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Graphs.mlb + end + basis l19 = + bas -+ (* $Lib.cm(=$SMLNJ-MLRISC)/Lib.cm ====> *) /home/fluet/mlton/smlnj-libs/MLRISC/MLRISC.cvs.HEAD-mlton/mlb/Lib.mlb ++ (* $Lib.cm(=$SMLNJ-MLRISC)/Lib.cm ====> *) $(SML_LIB)/mlrisc-lib/mlb/Lib.mlb + end +in +local |
|
From: Stephen W. <sw...@ml...> - 2006-03-29 14:04:29
|
Sped up the implementation of Real.{==,!=,isNan}.
Real.== no longer calls Real.class to ensure basis spec compliance.
Instead, it assumes that the primitive == does the right thing.
Real.isNan is now implemented with
fun isNan r = r != r
This was about 4 times faster on my machine than the old version that
used Real.class.
Changed the primitive simplifier so that it doesn't simplify
Real_equal(x, x) to true, since this is incorrect for nans.
----------------------------------------------------------------------
U mlton/trunk/basis-library/real/real.fun
U mlton/trunk/mlton/atoms/prim.fun
----------------------------------------------------------------------
Modified: mlton/trunk/basis-library/real/real.fun
===================================================================
--- mlton/trunk/basis-library/real/real.fun 2006-03-29 00:21:10 UTC (rev 4384)
+++ mlton/trunk/basis-library/real/real.fun 2006-03-29 22:04:27 UTC (rev 4385)
@@ -105,19 +105,13 @@
| NAN => false
| _ => true
- fun isNan r = class r = NAN
+ val op == = Prim.==
- fun isNormal r = class r = NORMAL
+ val op != = not o op ==
- val op == =
- fn (x, y) =>
- case (class x, class y) of
- (NAN, _) => false
- | (_, NAN) => false
- | (ZERO, ZERO) => true
- | _ => Prim.== (x, y)
+ fun isNan r = r != r
- val op != = not o op ==
+ fun isNormal r = class r = NORMAL
val op ?= =
if MLton.Codegen.isNative
Modified: mlton/trunk/mlton/atoms/prim.fun
===================================================================
--- mlton/trunk/mlton/atoms/prim.fun 2006-03-29 00:21:10 UTC (rev 4384)
+++ mlton/trunk/mlton/atoms/prim.fun 2006-03-29 22:04:27 UTC (rev 4385)
@@ -1507,7 +1507,6 @@
| MLton_equal => t
| Real_lt _ => f
| Real_le _ => t
- | Real_equal _ => t
| Real_qequal _ => t
| Word_andb _ => Var x
| Word_equal _ => t
|
|
From: Stephen W. <sw...@ml...> - 2006-03-28 16:21:11
|
Made Primitive.Real.class return an abstract type.
----------------------------------------------------------------------
U mlton/trunk/basis-library/real/real.fun
U mlton/trunk/basis-library/real/real.sig
----------------------------------------------------------------------
Modified: mlton/trunk/basis-library/real/real.fun
===================================================================
--- mlton/trunk/basis-library/real/real.fun 2006-03-28 22:58:06 UTC (rev 4383)
+++ mlton/trunk/basis-library/real/real.fun 2006-03-29 00:21:10 UTC (rev 4384)
@@ -63,10 +63,11 @@
val nan = posInf + negInf
+ structure Class = Primitive.Real64.Class
local
val classes =
let
- open Primitive.Real64.Class
+ open Class
in
(* order here is chosen based on putting the more commonly used
* classes at the front.
@@ -103,7 +104,7 @@
INF => false
| NAN => false
| _ => true
-
+
fun isNan r = class r = NAN
fun isNormal r = class r = NORMAL
Modified: mlton/trunk/basis-library/real/real.sig
===================================================================
--- mlton/trunk/basis-library/real/real.sig 2006-03-28 22:58:06 UTC (rev 4383)
+++ mlton/trunk/basis-library/real/real.sig 2006-03-29 00:21:10 UTC (rev 4384)
@@ -27,7 +27,7 @@
val ?= : real * real -> bool
val ~ : real -> real
val abs: real -> real
- val class: real -> int
+ val class: real -> Primitive.Real64.Class.t
val frexp: real * int ref -> real
val gdtoa: real * int * int * int ref -> Primitive.CString.t
val fromInt: int -> real
|
