From 0e3397fb0611ff6240f48c0d0b7a685aef917eb0 Mon Sep 17 00:00:00 2001 From: Martin Elsman Date: Thu, 5 Oct 2023 16:54:16 +0200 Subject: [PATCH] Real improvements (#135) * IEEEReal support * Improved real support * Removed Random structure from basis * Basis library signature and structure availability tests * Some basis restructuring to ensure availability of e.g BIN_IO --- NEWS.md | 7 + basis/POSIX.sig | 2 +- .../{POSIX_PROCENV.sml => POSIX_PROC_ENV.sig} | 2 +- basis/PackRealBig.sml | 3 + basis/PackRealLittle.sml | 3 + basis/Posix.sml | 2 +- basis/basis.mlb | 13 +- basis/io/io-close.sml | 5 + test/all.tst | 5 +- test/natset.sml | 100 +++++++----- test/sigs-avail.sml | 71 +++++++++ test/sigs-avail.sml.out.ok | 1 + test/structs-avail.sml | 142 ++++++++++++++++++ test/structs-avail.sml.out.ok | 1 + 14 files changed, 309 insertions(+), 48 deletions(-) rename basis/{POSIX_PROCENV.sml => POSIX_PROC_ENV.sig} (99%) create mode 100644 test/sigs-avail.sml create mode 100644 test/sigs-avail.sml.out.ok create mode 100644 test/structs-avail.sml create mode 100644 test/structs-avail.sml.out.ok diff --git a/NEWS.md b/NEWS.md index 2e6050fd9..5ca354615 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,12 @@ ## MLKit NEWS +* mael 2023-10-04: Improved documentation of basis library, which is + now documented with [sigdoc](http://github.com/diku-dk/sigdoc) at + https://elsman.com/mlkit/docs/pkg_idx.html. + +* mael 2023-10-04: Addition of IEEE_REAL signature and IEEEReal + structure. Improved Real support. + ### MLKit version 4.7.4 is released * mael 2023-10-01: Improved basis library documentation. diff --git a/basis/POSIX.sig b/basis/POSIX.sig index 79cff4908..146f7ec41 100644 --- a/basis/POSIX.sig +++ b/basis/POSIX.sig @@ -6,7 +6,7 @@ signature POSIX = structure Signal : POSIX_SIGNAL structure Process : POSIX_PROCESS where type signal = Signal.signal - structure ProcEnv : POSIX_PROCENV + structure ProcEnv : POSIX_PROC_ENV where type pid = Process.pid structure FileSys : POSIX_FILE_SYS where type file_desc = ProcEnv.file_desc diff --git a/basis/POSIX_PROCENV.sml b/basis/POSIX_PROC_ENV.sig similarity index 99% rename from basis/POSIX_PROCENV.sml rename to basis/POSIX_PROC_ENV.sig index edd3b766c..c3bdf4011 100644 --- a/basis/POSIX_PROCENV.sml +++ b/basis/POSIX_PROC_ENV.sig @@ -6,7 +6,7 @@ primitive POSIX access to the process environment. *) -signature POSIX_PROCENV = +signature POSIX_PROC_ENV = sig eqtype pid eqtype uid diff --git a/basis/PackRealBig.sml b/basis/PackRealBig.sml index 1c272900a..767774351 100644 --- a/basis/PackRealBig.sml +++ b/basis/PackRealBig.sml @@ -28,3 +28,6 @@ structure PackRealBig : PACK_REAL = Word8Array.copyVec {src=toBytes r, dst=arr, di=i*bytesPerElem} end + +(** SigDoc *) +structure PackReal64Big : PACK_REAL = PackRealBig diff --git a/basis/PackRealLittle.sml b/basis/PackRealLittle.sml index d9e2ce880..3359326c1 100644 --- a/basis/PackRealLittle.sml +++ b/basis/PackRealLittle.sml @@ -29,3 +29,6 @@ structure PackRealLittle : PACK_REAL = fun update (a,i,r) = Word8Array.copyVec {src=toBytes r, dst=a, di=i*bytesPerElem} end + +(** SigDoc *) +structure PackReal64Little : PACK_REAL = PackRealLittle diff --git a/basis/Posix.sml b/basis/Posix.sml index 3598b9b27..5b4b93b5f 100644 --- a/basis/Posix.sml +++ b/basis/Posix.sml @@ -390,7 +390,7 @@ struct end - structure ProcEnv : POSIX_PROCENV + structure ProcEnv : POSIX_PROC_ENV where type pid = Process.pid = struct type uid = int diff --git a/basis/basis.mlb b/basis/basis.mlb index e3203cba5..9c90188b6 100644 --- a/basis/basis.mlb +++ b/basis/basis.mlb @@ -140,7 +140,7 @@ local basis CommandLine = bas COMMAND_LINE.sml CommandLine.sml end basis Date = let open Int Real Time IntInf in bas DATE.sig Date.sml end end basis Timer = let open Int Time IntInf in bas TIMER.sig Timer.sml end end - in bas open Time Random Path FileSys + in bas open Time Path FileSys Process Os CommandLine Date Timer end end @@ -177,7 +177,7 @@ local basis Posix = let open General Word System List Int Real PrimIO Byte ArrayVector IntInf OSError BitFlags - in bas BIT_FLAGS.sml POSIX_IO.sml POSIX_PROCESS.sml POSIX_PROCENV.sml + in bas BIT_FLAGS.sml POSIX_IO.sml POSIX_PROCESS.sml POSIX_PROC_ENV.sig POSIX_FILE_SYS.sml POSIX_SIGNAL.sml POSIX_ERROR.sml POSIX_SYS_DB.sml POSIX_TTY.sml POSIX.sig Posix.sml end @@ -215,14 +215,7 @@ local end in bas open Stream IOClose Imperative Unix end end -(* - basis Sml90 = - let open General List String Real IO - in bas SML90.sml end - end -*) - in open General List ArrayVector String Bool Word Byte - Int Real IntInf IntInfRep Io System Text Posix IO Socket (* Sml90 *) + Int Real IntInf IntInfRep Io System Text Posix IO Socket PrimIO end diff --git a/basis/io/io-close.sml b/basis/io/io-close.sml index 2cadb8426..027044bb8 100644 --- a/basis/io/io-close.sml +++ b/basis/io/io-close.sml @@ -1,3 +1,8 @@ + +signature BIN_IO = BIN_IO +signature TEXT_IO = TEXT_IO +signature TEXT_STREAM_IO = TEXT_STREAM_IO + (** SigDoc *) structure BinIO : BIN_IO = BinIO diff --git a/test/all.tst b/test/all.tst index c5ebab0c6..8e98b5206 100644 --- a/test/all.tst +++ b/test/all.tst @@ -169,4 +169,7 @@ export3.sml atExit0.sml stringsz.sml -with-escape.sml \ No newline at end of file +with-escape.sml + +sigs-avail.sml (* basis library available signatures *) +structs-avail.sml (* basis library available structures *) \ No newline at end of file diff --git a/test/natset.sml b/test/natset.sml index 99900792c..085f5829d 100644 --- a/test/natset.sml +++ b/test/natset.sml @@ -1,3 +1,35 @@ +structure Random = + struct (* Generating random numbers. Paulson, page 96 *) + + type generator = {seedref : real ref} + val a = 16807.0 + val m = 2147483647.0 + fun nextrand seed = let val t = a*seed + in t - m * real(floor(t/m)) + end + fun newgenseed seed = {seedref = ref (nextrand seed)} + fun random {seedref as ref seed} = (seedref := nextrand seed; seed / m) + fun randomlist (n, {seedref as ref seed0}) = + let fun h 0 seed res = (seedref := seed; res) + | h i seed res = h (i-1) (nextrand seed) (seed / m :: res) + in h n seed0 [] + end + exception Random_range + fun range (min, max) = + if min >= max then raise Random_range + else fn {seedref as ref seed} => + (seedref := nextrand seed; min + (floor(real(max-min) * seed / m))) + fun rangelist (min, max) = + if min >= max then raise Random_range + else fn (n, {seedref as ref seed0}) => + let fun h 0 seed res = (seedref := seed; res) + | h i seed res = h (i-1) (nextrand seed) + (min + floor(real(max-min) * seed / m) :: res) + in h n seed0 [] + end + end + + signature MONO_SET = sig type elt @@ -12,7 +44,7 @@ signature MONO_SET = val eq : Set -> Set -> bool val list : Set -> elt list - val fromList : elt list -> Set + val fromList : elt list -> Set val addList : elt list -> Set -> Set (* addList l s : Add elements in list l to s. *) @@ -37,7 +69,7 @@ signature MONO_SET = end structure NatSet : MONO_SET = - struct + struct structure Bits = struct val xorb : word * word -> word = Word.xorb @@ -53,9 +85,9 @@ structure NatSet : MONO_SET = fun setb(w,n) = Bits.orb(w,bit n) fun isb(w,n) = Bits.andb(Bits.rshift(w,n),0w1) <> 0w0 fun unsetb(w,n) = Bits.andb(w, Bits.notb (bit n)) - - datatype natset = - empty + + datatype natset = + empty | some of word * natset * natset type Set = natset @@ -67,7 +99,7 @@ structure NatSet : MONO_SET = else if Bits.andb(n,0w1) <> 0w0 then member (Bits.rshift(n-bits_word,0w1), t1) else member(Bits.rshift(n-bits_word-0w1,0w1), t2) - fun add0(empty,n) = + fun add0(empty,n) = if n < bits_word then some(setb(0w0,n),empty,empty) else if Bits.andb(n,0w1) <> 0w0 then some(0w0,add0(empty, Bits.rshift(n-bits_word,0w1)), empty) else some(0w0, empty, add0(empty, Bits.rshift(n-bits_word-0w1,0w1))) @@ -77,10 +109,10 @@ structure NatSet : MONO_SET = else some(w, t1, add0(t2, Bits.rshift(n-bits_word-0w1,0w1))) fun singleton i = add0(empty,i) - + fun add(is,n) = if member(n,is) then is else add0(is,n) - - fun count(w,n) = if n < bits_word then + + fun count(w,n) = if n < bits_word then if isb(w,n) then 1 + count(w,n+0w1) else count(w,n+0w1) else 0 @@ -93,20 +125,20 @@ structure NatSet : MONO_SET = | c (some(w,t1,t2),a) = c(t2,c(t1,count(w,0w0,a))) in c (is,0) end - + fun mksome (0w0, empty, empty) = empty | mksome t = some t - + fun union (empty, ns2) = ns2 | union (ns1, empty) = ns1 | union (some(w1, t11, t12), some(w2, t21, t22)) = some(Bits.orb(w1,w2), union(t11, t21), union(t12, t22)) - + fun intersection (empty, ns2) = empty | intersection (ns1, empty) = empty | intersection (some(w1, t11, t12), some(w2, t21, t22)) = mksome(Bits.andb(w1,w2), intersection(t11, t21), intersection(t12, t22)) - + fun difference (empty, ns2) = empty | difference (ns1, empty) = ns1 | difference (some(w1, t11, t12), some(w2, t21, t22)) = @@ -117,15 +149,15 @@ structure NatSet : MONO_SET = if n < bits_word then mksome(unsetb(w,n),t1,t2) else if Bits.andb(n,0w1) <> 0w0 then mksome(w,delete0(t1, Bits.rshift(n-bits_word,0w1)), t2) else mksome(w, t1, delete0(t2, Bits.rshift(n-bits_word-0w1,0w1))) - + fun delete(is,n) = if member(n,is) then delete0(is,n) else is fun disjoint (empty, ns2) = true | disjoint (ns1, empty) = true | disjoint (some(w1, t11, t12), some(w2, t21, t22)) = - (Bits.andb(w1,w2) = 0w0) - andalso disjoint(t11, t21) - andalso disjoint(t12, t22) + (Bits.andb(w1,w2) = 0w0) + andalso disjoint(t11, t21) + andalso disjoint(t12, t22) fun foldset f (e, t) = let fun slb (n, d, w, a) = @@ -133,15 +165,15 @@ structure NatSet : MONO_SET = | slb' (w,i,a) = if isb(w,i) then slb'(unsetb(w,i),i+0w1,f(a,n+d*i)) else slb'(w,i+0w1,a) in slb' (w,0w0,a) - end + end fun sl (n, d, empty, a) = a | sl (n, d, some(w, t1, t2), a) = let val temp = n+d*bits_word val d' = 0w2*d - in sl(temp, d', t1, + in sl(temp, d', t1, sl(temp+d, d', t2, slb(n, d, w, a))) end - in sl(0w0, 0w1, t, e) + in sl(0w0, 0w1, t, e) end fun mapset f t = foldset (fn (a,i) => f i :: a) ([], t) @@ -164,9 +196,9 @@ structure NatSet : MONO_SET = in h'' (0w0,0w0) end fun h (n, d, empty) = empty - | h (n, d, some(w, t1, t2)) = + | h (n, d, some(w, t1, t2)) = mksome(h' (n, d, w), h(n+d*bits_word, 0w2*d, t1), h(n+d*(bits_word+0w1), 0w2*d, t2)) - in h(0w0, 0w1, t) + in h(0w0, 0w1, t) end val size = cardinality @@ -221,7 +253,7 @@ local fun check b = if b then "OK" else "WRONG"; fun check' f = (if f () then "OK" else "WRONG") handle _ => "EXN"; -fun range (from, to) p = +fun range (from, to) p = let open Word in (from > to) orelse (p from) andalso (range (from+0w1, to) p) @@ -236,13 +268,13 @@ fun tst0 s s' = print (s ^ " \t" ^ s' ^ "\n"); fun tst s b = tst0 s (check b); fun tst' s f = tst0 s (check' f); -fun tstrange s bounds = (tst s) o range bounds +fun tstrange s bounds = (tst s) o range bounds fun tstlist s l = (tst s) o list0 l val _ = print "Testing implementation of sets using word structure...\n" open NatSet -in +in fun mem w s = member s w val s1 = fromList[0w100,0w101,0w102,0w103,0w104,0w105,0w106,0w107,0w108] val s2 = fromList[0w106,0w107,0w108,0w109,0w110,0w111] @@ -266,7 +298,7 @@ val _ = tstrange "test10" (0w104,0w107) (not o mem s5) val _ = tstrange "test11" (0w108,0w111) (mem s5) val _ = tstrange "test12" (0w112,0w200) (not o mem s5) -val _ = tst "test13" (size s1 = 9 andalso size s2 = 6 andalso size s3 = 12 +val _ = tst "test13" (size s1 = 9 andalso size s2 = 6 andalso size s3 = 12 andalso size s4 = 3 andalso size s5 = 8) val s6 = remove 0w101 s5 @@ -278,21 +310,21 @@ val _ = tstrange "test18" (0w108,0w111) (mem s6) val _ = tstrange "test19" (0w112,0w200) (not o mem s6) fun T N str = - let - fun mkN n = List.map Word.fromInt (Random.rangelist(0,N)(n,Random.newgen())) - + let + fun mkN n = List.map Word.fromInt (Random.rangelist(0,N)(n,Random.newgenseed 2.0)) + val l7 = mkN 1000 val l8 = mkN 1000 val s7 = fromList l7 val s8 = fromList l8 - + val _ = tstlist ("test20"^str) l7 (mem s7) val _ = tstlist ("test21"^str) l8 (mem s8) val _ = tstlist ("test22"^str) (l7@l8) (mem (union s7 s8)) - + val _ = tst ("test23"^str) (eq (union s7 s8) - (union(union(intersect s7 s8) - (difference s7 s8)) + (union(union(intersect s7 s8) + (difference s7 s8)) (difference s8 s7))) in () end @@ -309,4 +341,4 @@ val _ = tst "test25" (fromList[0w103,0w109,0w111] = s10) val _ = tst "test26" (fold (fn w1 => fn w2 => Word.+(w1,w2)) 0w0 s9 = 0w420) val _ = tst "test27" (fold (fn w1 => fn w2 => Word.+(w1,w2)) 0w0 s10 = 0w323) -end \ No newline at end of file +end diff --git a/test/sigs-avail.sml b/test/sigs-avail.sml new file mode 100644 index 000000000..91bf2a57a --- /dev/null +++ b/test/sigs-avail.sml @@ -0,0 +1,71 @@ +(* Required signatures - see https://smlfamily.github.io/Basis/overview.html *) + +signature X = ARRAY +signature X = ARRAY_SLICE +signature X = BIN_IO +signature X = BOOL +signature X = BYTE +signature X = CHAR +signature X = COMMAND_LINE +signature X = DATE +signature X = GENERAL +signature X = IEEE_REAL +signature X = IMPERATIVE_IO +signature X = INTEGER +signature X = IO +signature X = LIST +signature X = LIST_PAIR +signature X = MATH +signature X = MONO_ARRAY +signature X = MONO_ARRAY_SLICE +signature X = MONO_VECTOR +signature X = MONO_VECTOR_SLICE +signature X = OPTION +signature X = OS +signature X = OS_FILE_SYS +signature X = OS_IO +signature X = OS_PATH +signature X = OS_PROCESS +signature X = PRIM_IO +signature X = REAL +signature X = STREAM_IO +signature X = STRING +signature X = STRING_CVT +signature X = SUBSTRING +signature X = TEXT +signature X = TEXT_IO +signature X = TEXT_STREAM_IO +signature X = TIME +signature X = TIMER +signature X = VECTOR +signature X = VECTOR_SLICE +signature X = WORD + +(* Optional signatures - see https://smlfamily.github.io/Basis/overview.html *) + +signature X = ARRAY2 +signature X = BIT_FLAGS +(*signature X = GENERIC_SOCK*) +signature X = INET_SOCK +signature X = INT_INF +signature X = MONO_ARRAY2 +signature X = NET_HOST_DB +(*signature X = NET_PROT_DB*) +(*signature X = NET_SERV_DB*) +signature X = PACK_REAL +signature X = PACK_WORD +signature X = POSIX +signature X = POSIX_ERROR +signature X = POSIX_FILE_SYS +signature X = POSIX_IO +signature X = POSIX_PROC_ENV +signature X = POSIX_PROCESS +signature X = POSIX_SIGNAL +signature X = POSIX_SYS_DB +signature X = POSIX_TTY +signature X = SOCKET +signature X = UNIX +(*signature X = UNIX_SOCK*) +(*signature X = WINDOWS*) + +val () = print "All ok!\n" diff --git a/test/sigs-avail.sml.out.ok b/test/sigs-avail.sml.out.ok new file mode 100644 index 000000000..268246d4b --- /dev/null +++ b/test/sigs-avail.sml.out.ok @@ -0,0 +1 @@ +All ok! diff --git a/test/structs-avail.sml b/test/structs-avail.sml new file mode 100644 index 000000000..f64b9899c --- /dev/null +++ b/test/structs-avail.sml @@ -0,0 +1,142 @@ +(* Required structures - see https://smlfamily.github.io/Basis/overview.html *) + +structure X = Array : ARRAY +structure X = ArraySlice : ARRAY_SLICE +structure X = BinIO : BIN_IO +structure X = BinPrimIO : PRIM_IO +structure X = Bool : BOOL +structure X = Byte : BYTE +structure X = CharArray : MONO_ARRAY +structure X = CharArraySlice : MONO_ARRAY_SLICE +structure X = Char : CHAR +structure X = CharVector : MONO_VECTOR +structure X = CharVectorSlice : MONO_VECTOR_SLICE +structure X = CommandLine : COMMAND_LINE +structure X = Date : DATE +structure X = General : GENERAL +structure X = IEEEReal : IEEE_REAL +structure X = Int : INTEGER +structure X = IO : IO +structure X = LargeInt : INTEGER +structure X = LargeReal : REAL +structure X = LargeWord : WORD +structure X = List : LIST +structure X = ListPair : LIST_PAIR +structure X = Math : MATH +structure X = Option : OPTION +structure X = OS : OS +structure X = Position : INTEGER +structure X = Real : REAL +structure X = StringCvt : STRING_CVT +structure X = String : STRING +structure X = Substring : SUBSTRING +structure X = TextIO : TEXT_IO +structure X = TextPrimIO : PRIM_IO +structure X = Text : TEXT +structure X = Timer : TIMER +structure X = Time : TIME +structure X = VectorSlice : VECTOR_SLICE +structure X = Vector : VECTOR +structure X = Word8Array : MONO_ARRAY +structure X = Word8ArraySlice : MONO_ARRAY_SLICE +structure X = Word8Vector : MONO_VECTOR +structure X = Word8VectorSlice : MONO_VECTOR_SLICE +structure X = Word8 : WORD +structure X = Word : WORD + +(* Optional structures - see https://smlfamily.github.io/Basis/overview.html *) + +structure X = Array2 : ARRAY2 +(* +structure X = BoolArray : MONO_ARRAY +structure X = BoolArray2 : MONO_ARRAY2 +structure X = BoolArraySlice : MONO_ARRAY_SLICE +structure X = BoolVector : MONO_VECTOR +structure X = BoolVectorSlice : MONO_VECTOR_SLICE +structure X = CharArray2 : MONO_ARRAY2 +*) +structure X = FixedInt : INTEGER +(*structure X = GenericSock : GENERIC_SOCK*) +structure X = INetSock : INET_SOCK +(* +structure X = IntArray : MONO_ARRAY +structure X = IntArray2 : MONO_ARRAY2 +structure X = IntArraySlice : MONO_ARRAY_SLICE +structure X = IntVector : MONO_VECTOR +structure X = IntVectorSlice : MONO_VECTOR_SLICE +structure X = IntArray : MONO_ARRAY +structure X = IntArray2 : MONO_ARRAY2 +structure X = IntArraySlice : MONO_ARRAY_SLICE +structure X = Int : INTEGER +structure X = IntVector : MONO_VECTOR +structure X = IntVectorSlice : MONO_VECTOR_SLICE +*) +structure X = Int31 : INTEGER +structure X = Int32 : INTEGER +structure X = Int63 : INTEGER +structure X = Int64 : INTEGER + +structure X = IntInf : INT_INF +structure X = NetHostDB : NET_HOST_DB +(* +structure X = NetProtDB : NET_PROT_DB +structure X = NetServDB : NET_SERV_DB +structure X = PackWordBig : PACK_WORD +structure X = PackWordLittle : PACK_WORD +*) +structure X = PackWord32Big : PACK_WORD +structure X = PackWord32Little : PACK_WORD + +structure X = PackRealBig : PACK_REAL +structure X = PackRealLittle : PACK_REAL +(* +structure X = PackRealBig : PACK_REAL +structure X = PackRealLittle : PACK_REAL +*) +structure X = PackReal64Big : PACK_REAL +structure X = PackReal64Little : PACK_REAL +structure X = Posix : POSIX +structure X = RealArray2 : MONO_ARRAY2 +structure X = RealArray : MONO_ARRAY +(*structure X = RealArraySlice : MONO_ARRAY_SLICE*) +structure X = RealVector : MONO_VECTOR +(*structure X = RealVectorSlice : MONO_VECTOR_SLICE*) +(* +structure X = RealArray : MONO_ARRAY +structure X = RealArray2 : MONO_ARRAY2 +structure X = RealArraySlice : MONO_ARRAY_SLICE +structure X = Real : REAL +structure X = RealVector : MONO_VECTOR +structure X = RealVectorSlice : MONO_VECTOR_SLICE +*) +structure X = Socket : SOCKET +structure X = SysWord : WORD +(*structure X = UnixSock : UNIX_SOCK*) +structure X = Unix : UNIX + (* +structure X = WideCharArray : MONO_ARRAY +structure X = WideCharArray2 : MONO_ARRAY2 +structure X = WideCharArraySlice : MONO_ARRAY_SLICE +structure X = WideChar : CHAR +structure X = WideCharVector : MONO_VECTOR +structure X = WideCharVectorSlice : MONO_VECTOR_SLICE +structure X = WideString : STRING +structure X = WideSubstring : SUBSTRING +structure X = WideTextPrimIO : PRIM_IO +structure X = WideText : TEXT +structure X = Windows : WINDOWS +structure X = WordArray : MONO_ARRAY +structure X = WordArray2 : MONO_ARRAY2 +structure X = WordArraySlice : MONO_ARRAY_SLICE +structure X = WordVector : MONO_VECTOR +structure X = WordVectorSlice : MONO_VECTOR_SLICE +structure X = Word : WORD +*) + +structure X = Word8 : WORD +structure X = Word31 : WORD +structure X = Word32 : WORD +structure X = Word63 : WORD +structure X = Word64 : WORD + +val () = print "All ok\n" diff --git a/test/structs-avail.sml.out.ok b/test/structs-avail.sml.out.ok new file mode 100644 index 000000000..f178fe1d8 --- /dev/null +++ b/test/structs-avail.sml.out.ok @@ -0,0 +1 @@ +All ok