-- NAN_PAYLOAD provides access to the payload bits from Long_Float IEEE754 NaN values -- Copyright (c) 2014 Alexandru Dan Corlan M.D. PhD -- -- Home page: http://dan.corlan.net/software/nan_payload -- -- nan_payload is free software; you can redistribute it and/or modify it -- under terms of the GNU General Public License as published by the -- Free Software Foundation; either version 3, or (at your option) -- any later version. CORLPACK is distributed in the hope that it -- will be useful, but WITHOUT ANY WARRANTY; without even the -- implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR -- PURPOSE. As a special exception under Section 7 of GPL version 3, -- you are granted additional permissions described in the GCC -- Runtime Library Exception, version 3.1, as published by the Free -- Software Foundation, only for the packages (not for the tests -- and utilities) included in this distribution. -- -- You should have received a copy of the GNU General Public License -- and a copy of the GCC Runtime Library Exception along with this -- program; see the files COPYING3 and COPYING.RUNTIME respectively. -- If not, see . -- -- Storing 'non-available', error as well as other symbolic values instead of any of the -- numbers in numeric arrays is necessary in many statistical applications. -- -- This package allows you to read and write the part of NaN IEEE754-64 bit values -- known as `the payload' that is 51 bits long, and also to treat the long_float -- type as an implicit tagged type by storing tags and values in the payload. -- Calendar dates with ms resolution as well as 9-letter symbols and some -- not available/error codes are provided as subtypes. Formatted output with -- Fortran-like descriptors as well as reading values from strings -- for these types is also provided. -- -- History: this is version 0.1, released june 5, 2014 -- tested only with gnat 4.6 on linux, x86_64, and the Atom-D2550 processor with Ada.Calendar; use Ada.Calendar; with Gnat.Calendar.Time_Io; use Gnat.Calendar.Time_Io; package Nan_Payload_64 is pragma Elaborate_Body(Nan_Payload_64); -- first level package: simply provide access to the 51 bits (the 'payload') -- of IEEE754 64 bit floats subtype Num is Long_Float; type Payload is mod 2**51; type Uint64 is mod 2**64; -- predicates for NaN, infinity and normal long_float values function Is_Nan(X: Num) return Boolean; function Is_Num(X: Num) return Boolean; -- neither nan, nor +/- inf, otherwise valid function Is_Plus_Inf(X: Num) return Boolean; function Is_Minus_Inf(X: Num) return Boolean; function Is_Inf(X: Num) return Boolean; -- either plus or minus infinity function Nanval(X: Num) return Payload; -- raises constranit_error if X is not a NaN function To_Nan(J: Payload) return Num; function Eq(X,Y: Num) return Boolean; -- = does not properly work; use Eq to test for identical NaN values -- EXAMPLE SCHEMA -- frequently used values -- this are supposed to also fit into the 22 bits of 32-bit floats, -- that will be developed some other time Nan_Zero: Num; -- this is the NaN with a 0 payload, as produced by 0.0/0.0 Nan_True: Num; -- some randomly choosen values (starting with mostly 1's) Nan_False: Num; Nan_Ok: Num; Nan_Na: Num; Nan_Err: Num; Nan_Err_1: Num; Nan_Err_2: Num; -- for the rest of the types, each payload is divided into a 'cls' (class or tag) -- and a value; some later types have a cls of 3 bits and a value of 48 bits, -- but types that will have to also be coercible to 22 bits will have a cls of at least -- 29 bits, starting with 29 '1's and a value of 22 or less, like the above (see -- the initialisation code in the package body) function Make(Cls: Uint64; Mask: Integer; Value: Uint64) return Num; -- num is a NaN function Peek(N: Num; Mask: Integer) return Uint64; -- if mask is negative then return the type (that number of bits at the start) -- if mask is positive then return the value (that number of bits at the end) -- symbols: up to 9 case-less letters, 0-9, ".", "_", ":" or "@" except -- that the last character cannot be a "@" function Is_Sym_Nan(X: Num) return Boolean; function To_Sym_Nan(S: String) return Num; function To_Str(X: Num) return String; -- calendar time: milliseconds since the start of the Gregorian calendar function Is_Time_Nan(X: Num) return Boolean; function To_time(X: Num) return Time; function To_Time_Nan(X: Time) return Num; -- 'input' and 'output' functions: convert NaNs into -- readable ascii strings (Img) and back (Val) -- only formats "s" and "" supported for NaNs -- "s" displays symbols and time when known; -- "" and unknown values to "s" result in a generic format -- that is nan:.. is the three bit class while -- the 12 hex digits represent the 48bit value -- If the value is not a NaN then F10.3 writes it in 10 space-padded -- characters with 3 decimals function Img(X: Num; Format: String:= "s") return String; function Val(S: String) return Num; -- the following are visible just for testing Wrong_Nan_Type: exception; Wrong_Format: exception; Sym_Type_Id: constant Uint64:= 5; Time_Type_Id: constant Uint64:= 4; function B40_To_String(B: Payload) return String; function String_To_B40(S: String) return Payload; end Nan_Payload_64; with Ada.Unchecked_Conversion; with Ada.Text_Io; package body Nan_Payload_64 is Nan0: Uint64:= 16#fff8_0000_0000_0000#; Zero: Num:= 0.0; function Lf_To_Li is new Ada.Unchecked_Conversion(Source => Num, Target => Uint64); function Li_To_Lf is new Ada.Unchecked_Conversion(Source => Uint64, Target => Num); Minus_Inf: Uint64:= Lf_To_Li(-1.0/Zero); Plus_Inf: Uint64:= Lf_To_Li(1.0/Zero); function Eq(X,Y: Num) return Boolean is begin return Lf_To_Li(X)=Lf_To_Li(Y); end Eq; function Is_Nan(X: Num) return Boolean is L: Uint64:= Lf_To_Li(X); begin return (L and Nan0) = Nan0; end Is_Nan; function Is_Plus_Inf(X: Num) return Boolean is begin return Lf_To_Li(X) = Plus_Inf; end Is_Plus_Inf; function Is_Minus_Inf(X: Num) return Boolean is begin return Lf_To_Li(X) = Minus_Inf; end Is_Minus_Inf; function Is_Inf(X: Num) return Boolean is begin return Is_Plus_Inf(X) or else Is_Minus_Inf(X); end Is_Inf; function Is_Num(X: Num) return Boolean is begin return not Is_Nan(X) and then not Is_Inf(X); end Is_Num; function Nanval(X: Num) return Payload is L: Uint64:= Lf_To_Li(X); begin if (L and Nan0) = Nan0 then return Payload(L and not Nan0); else raise Constraint_Error; -- not a nan number end if; end Nanval; function To_Nan(J: Payload) return Num is begin return Li_To_Lf(Nan0 or (Uint64(J) and not Nan0)); end To_Nan; function Make(Cls: Uint64; Mask: Integer; Value: Uint64) return Num is begin return To_Nan(Payload(((Cls and Uint64(2**Mask - 1)) * 2**(51-Mask)) + Value)); end Make; function Peek(N: Num; Mask: Integer) return Uint64 is begin if Mask>0 then return Uint64(Lf_To_Li(N)) and Uint64(2**(51-Mask)-1); else return Uint64(Lf_To_Li(N))/2**(51+Mask) and Uint64(2**(-Mask)-1); end if; end Peek; subtype Base40char is Short_Short_Integer range -1..39; Badchar: Short_Short_Integer:= -1; Char_To_Base40: array(Character) of Base40char := (others => Badchar); Base40_To_Char: constant array(Base40char) of Character := ( ' ', '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z', '.', '_', ':', '@'); procedure Init_B40 is begin for K in Character'('0')..Character'('9') loop Char_To_Base40(K) := Base40char(Character'Pos(K) - Character'Pos('0')); end loop; for K in Character'('A')..Character'('Z') loop Char_To_Base40(K) := Base40char(Character'Pos(K) - Character'Pos('A') + 10); end loop; for K in Character'('a')..Character'('z') loop Char_To_Base40(K) := Base40char(Character'Pos(K) - Character'Pos('a') + 10); end loop; Char_To_Base40('.') := 36; Char_To_Base40('_') := 37; Char_To_Base40(':') := 38; Char_To_Base40('@') := 39; end Init_B40; Impossible_Exception: exception; function String_To_B40(S: String) return Payload is R: Payload:= 0; U: String:= S & "@@@@@@@@@"; K: Integer:= U'First; Nc: Integer:= 0; B: Base40char; begin while K=1 loop Re := Re-1; end loop; return R(1..Re); end B40_To_String; function Is_Sym_Nan(X: Num) return Boolean is begin return Peek(X,-3)=Sym_Type_Id; end Is_Sym_Nan; function To_Sym_Nan(S: String) return Num is begin return Make(Sym_Type_Id,3,Uint64(String_To_B40(S))); end To_Sym_Nan; function To_Str(X: Num) return String is begin if Is_Sym_Nan(X) then return B40_To_String(Payload(Peek(X,3))); else raise Wrong_Nan_Type; end if; end To_Str; function Is_Time_Nan(X: Num) return Boolean is begin return Peek(X,-3)=4; end Is_Time_Nan; Gregorian_Epoch: constant Time:= Time_Of(1982,10,15); Days_In_400_Years: constant Uint64:= 146097; -- gregorian years of 365.2425 days each; fits exactly after 400 years Seconds_In_400_Years: constant Uint64:= Days_In_400_Years * 24 * 3600; function To_time(X: Num) return Time is begin return Gregorian_Epoch + Duration((Long_Float(Peek(X,3)) - Long_Float(Seconds_In_400_Years*1000))/1000.0); end To_time; function To_Time_Nan(X: Time) return Num is begin return Make(Time_Type_Id,3,Uint64((Long_Float(X - Time_Of(1982,10,15)) + Long_Float(Seconds_In_400_Years))*1000.0)); end To_Time_Nan; -- that is, format Pltime_Format: Picture_String:= "%Y-%m-%d/%H;%M:%S.%i"; function Read_Pltime(S: String) return Time is U: String(1..S'Length):= S; R: Time; Ms: Duration; begin U(11) := ' '; R := Value(U(1..19)); Ms := Duration'Value(U(21..23))/1000.0; return R+Ms; end Read_Pltime; function Img(X: Num; Format: String:= "s") return String is package Numio is new Ada.Text_Io.Float_Io(Num); function Gen_Nan_Form(X: Num) return String is Genan: String(1..17):= "nan0:000000000000"; function Hexdig(N: Integer) return Character is begin if N>0 and then N<10 then return Character'Val(Character'Pos('0') + N); elsif N<16 then return Character'Val(Character'Pos('a') + N - 10); else raise Constraint_Error; end if; end Hexdig; Y: Uint64; begin Genan(4) := Hexdig(Integer(Peek(X,-3))); -- first 3 bits Y := Peek(X,3); for K in 0..11 loop Genan(17-K) := Hexdig(Integer(Y mod 16)); Y := Y / 16; end loop; return Genan; end Gen_Nan_Form; W,Di,K: Integer; begin if Is_Nan(X) then if Format="S" or else Format="s" then if Is_Time_Nan(X) then return "nant:" & Image(To_time(X),Pltime_Format); elsif Is_Sym_Nan(X) then return "nans:" & To_Str(X); elsif Eq(X,Nan_True) then return "nan:true"; elsif Eq(X,Nan_False) then return "nan:false"; elsif Eq(X,Nan_Na) then return "nan:na"; elsif Eq(X,Nan_Ok) then return "nan:ok"; elsif Eq(X,Nan_Err) then return "nan:err"; elsif Eq(X,Nan_Zero) then return "nan:zero"; else return Gen_Nan_Form(X); end if; else return Gen_Nan_Form(X); end if; else if Format(Format'First)='F' or else Format(Format'First)='f' then -- this is something like F10.2 W := 0; K := 1; while (Format'First + K <= Format'Last) and then Format(K+Format'First)<='9' and then Format(K+Format'First)>='0' loop W := 10 * W + Character'Pos(Format(K+Format'First)) - Character'Pos('0'); K := K+1; end loop; if (K+Format'First > Format'Last) or else Format(K+Format'First)/='.' then raise Wrong_Format; end if; K := K+1; Di := 0; while (Format'First + K <= Format'Last) and then Format(K+Format'First)<='9' and then Format(K+Format'First)>='0' loop Di := 10 * Di + Character'Pos(Format(K+Format'First)) - Character'Pos('0'); K := K+1; end loop; if K+Format'First <= Format'Last or else Di>=W-1 then raise Wrong_Format; end if; declare R: String(1..W); begin Numio.Put(R,X, Aft => Di, Exp => 0); return R; end; else return Num'Image(X); end if; end if; end Img; function Val(S: String) return Num is begin if S(S'First..S'First+2)="nan" then case S(S'First+3) is when ':' => if S="nan:true" then return Nan_True; elsif S="nan:false" then return Nan_False; elsif S="nan:na" then return Nan_Na; elsif S="nan:ok" then return Nan_Ok; elsif S="nan:err" then return Nan_Err; elsif S="nan:zero" then return Nan_Zero; else raise Wrong_Nan_Type; end if; when 's' => return To_Sym_Nan(S(S'First+5..S'Last)); when 't' => return To_Time_Nan(Read_Pltime(S(S'First+5..S'Last))); when others => raise Wrong_Nan_Type; end case; else return Num'Value(S); end if; end Val; begin Init_B40; Nan_True := To_Nan(16#7_ffff_fff_ff_fff#); -- must be reorganised Nan_False := To_Nan(16#7_ffff_fff_ff_ffe#); Nan_OK := To_Nan(16#7_ffff_fff_ff_000#); Nan_Zero := To_Nan(16#0_0000_000_00_000#); Nan_NA := To_Nan(16#7_ffff_fff_ff_001#); Nan_Err := To_Nan(16#7_ffff_fff_ff_800#); Nan_Err_2 := To_Nan(16#7_ffff_fff_ff_801#); Nan_Err_2 := To_Nan(16#7_ffff_fff_ff_802#); end Nan_Payload_64; with Ada.Text_Io; use Ada.Text_Io; with Nan_Payload_64; use Nan_Payload_64; with Ada.Calendar; use Ada.Calendar; with Gnat.Calendar.Time_Io; use Gnat.Calendar.Time_Io; procedure Nanpl64test is R: Long_Float; procedure Test_Mask_Val(T: Uint64; Tl: Integer; V: Uint64) is begin R := Make(T,Tl,V); if Is_Nan(R) then Put("made is nan: " & Uint64'Image(T) & "/" & Integer'Image(Tl) & "=" & Uint64'Image(V) & " ### "); end if; Put(Uint64'Image(Peek(R,-Tl))); Put(Uint64'Image(Peek(R,Tl))); New_Line; end Test_Mask_Val; procedure Test_B40(S: String) is begin Put(S); Put(" => "); Put(B40_To_String(String_To_B40(S))); New_Line; end Test_B40; procedure Test_Sym(S: String) is begin Put(S); Put(" =S=> "); Put(To_Str(To_Sym_Nan(S))); New_Line; end Test_Sym; procedure Test_Time(T: Time) is R: Num; begin Put(Image(T,Iso_Date)); Put(" =T=> "); R := To_Time_Nan(T); Put(">"); Put(Image(To_time(R),Iso_Date)); New_Line; end Test_Time; procedure Test_Imgval(S: String) is begin Put(S); Put(" =IV=> "); Put(Img(Val(S),"s")); New_Line; end Test_Imgval; U: Duration:= -2.0; begin R := To_Nan(714); Put(Payload'Image(Nanval(R))); if Is_Nan(R) then Put_Line(" is nan"); end if; Test_Mask_Val(7,3,712); Test_Mask_Val(7,5,712); Test_Mask_Val(7,19,712); Test_Mask_Val(2#111_1111_1111_1111_1111_1111_1111_11#, 29, 104); Test_B40("alphalpha"); Test_B40("@123@@"); Test_B40("12 34 44"); Test_B40("000000000"); Test_B40("alabalaportocala"); Test_Sym("alpha"); Test_Time(Clock); Test_Time(Time_Of(2066,09,02)); Test_Time(Time_Of(1966,09,02)); if To_Time_Nan(Time_Of(2066,09,02)) = To_Time_Nan(Time_Of(2066,09,02)) then Put_Line("they times are equal"); else Put_Line("they times are not equal"); end if; if To_Sym_Nan("ala") = To_Sym_Nan("ala") then Put_Line("they syms are equal"); else Put_Line("they syms are not equal"); end if; if Eq(To_Time_Nan(Time_Of(2066,09,02)), To_Time_Nan(Time_Of(2066,09,02))) then Put_Line("they times are eq"); else Put_Line("they times are not eq"); end if; if Eq(To_Sym_Nan("ala"), To_Sym_Nan("ala")) then Put_Line("they syms are eq"); else Put_Line("they syms are not eq"); end if; Put_Line(Img(To_Sym_Nan("jolly"))); Put_Line(Img(To_Sym_Nan("jolly"),"s")); Put_Line(Img(To_Time_Nan(Time_Of(2066,09,02)),"s")); Put_Line(Img(2.33,"F10.3")); Put_Line(Img(-12.33,"F10.0")); Put_Line(Img(-2.33,"F10.3")); Test_Imgval("nans:alpha"); Test_Imgval("nant:2016-09-02/03:10:10.227"); Test_Imgval("nant:2016-09-02/00:05:00.000"); Test_Imgval("nan:ok"); Put_Line(Img(To_Sym_Nan("alph")+To_Sym_Nan("bet"))); -- does it say nans:BET? it is a quiet NaN end Nanpl64test;