program HEXFLOAT { (c) www.merlyn.demon.co.uk >= 2003-09-15 Borland Pascal 7 & Delphi Console Mode - DCC32 -cc HEXFLOAT Converts Extended to/from Legible Hex Float, using NO float operations; the conversion is exact and reversible. Here, ñ or ± is the +- sign. Legible Hex is as ñd.dddd dddd dddd dddd Hñddd where d is a hex digit and the Hexponent and mantissa are base 16 ; can be without spaces. Input string format is not as yet checked. Inf, NaN are coded differently, as ñInf or ñNaN then plain Hex. Program is liable to change. Because of Denormal problems, a digit parameter selects policy. 0 or none - Preserve all bits, using plain Hex for improper numbers. 1 - Best denorm presentation - can lose low bits. 2 - I wish it worked } ; { msb ; s 1 ; e 15 ; i 1 ; f 63 ; lsb if 0 <= e < 32767 then v = (-1)^s * 2^(e-16383) * i.f if e = 32767 and f = 0 then v = (-1)^s * Inf if e = 32767 and f <> 0 then v is a NaN } const Para : byte = 0 { Global control; 0 = safest } ; type St02 = string [02] ; St20 = string [20] ; St28 = string [28] ; {$IFDEF VER70} smallint = integer ; {$ENDIF} Extd = record Mt : set of 0..63 ; XP : smallint end ; TenBytes = array [0..9] of byte ; const HexA : array [0..15] of char = '0123456789ABCDEF' ; const Spaces : boolean = true ; function ExtendedToPlainHex(Z : extended) : St20 ; var St : St20 ; B, K : byte ; begin St[0] := #20 ; for K := 9 downto 0 do begin B := TenBytes(Z)[K] ; St[19-2*K] := HexA[B shr 4] ; St[20-2*K] := HexA[B and $0F] end ; ExtendedToPlainHex := St end {ExtendedToPlainHex} ; function PlainHexToExtended(S : St20) : extended ; var Arr : array [0..9] of byte ; Ch : char ; B, J, K : byte ; begin for K := 1 to 20 do begin Ch := S[K] ; B := (byte(Ch) and $0F) ; if Ch>'9' then Inc(B, 9) ; J := 9 - ((K-1) div 2) ; if Odd(K) then Arr[J] := B shl 4 else Inc(Arr[J], B) ; end ; PlainHexToExtended := extended(Arr) end {PlainHexToExtended} ; { Adj is the bit-shift needed for conversion of the exponent between giving a power of 2 and a power of 16 } function ExtendedToLegibleHex(Arg : extended) : St28 ; type Set144 = set of 0..18*8-1 { 18 chars - to access mantissa string bitwise } ; LILI = record X, Y : longint end ; const Naf : array [boolean] of string [3] = ('NaN', 'Inf') ; Pad : array [boolean] of string [4] = ('', ' ') ; SgnA : array [boolean] of char = '+-' ; var Expo : smallint ; Adj, B, J, Jext, K, MtEl : byte ; Sign : char ; Mt21 : string [22] ; Mt17 : string [17] absolute Mt21 ; SignExpo : string [4] ; ExpZ, Not0 : boolean ; begin Sign := SgnA[Extd(Arg).XP<0] ; Mt17 := '00000000000000000' {17} ; SignExpo := '+000' ; Not0 := false ; for K := 0 to 9 do if TenBytes(Arg)[K]<>0 then Not0 := true ; if Not0 then begin Expo := (Extd(Arg).XP and $7FFF) ; if Word(Expo)=32767 then begin with LILI(Extd(Arg).Mt) do ExtendedToLegibleHex := Sign + Naf[(X=0) and (Y=0)] + Pad[Spaces] + ExtendedtoPlainHex(Arg) ; EXIT end ; if not (63 in Extd(Arg).Mt) then begin ExtendedToLegibleHex := Sign + 'TB0' + Pad[Spaces] + ExtendedtoPlainHex(Arg) ; EXIT end ; ExpZ := word(Expo)=0 ; if (word(Expo)<2) and (Para=0) then begin ExtendedToLegibleHex := Sign + 'Den' + Pad[Spaces] + ExtendedtoPlainHex(Arg) ; EXIT end ; Expo := Expo - 16383 ; Adj := Expo and $3 ; SignExpo[1] := SgnA[Expo<0] ; If Expo<0 then Expo := (not Expo) + 4 ; Expo := Expo shr 2 ; K := 0 ; while Expo>$FFF do begin Dec(Expo) ; Inc(K, 4) end ; for J := 4 downto 2 do begin SignExpo[J] := HexA[Expo mod $10] ; Expo := Expo div $10 end ; for JExt := 63 downto 0 do if JExt in Extd(Arg).Mt then begin B := JExt + Adj + 1 + 4 - K ; if Para=1 then Inc(B, Ord(ExpZ)) { Why? } ; MtEl := 8 + 8 + 16*8 + (B and $03) - (B and $FC)*2 ; if MtEl in [8..143] then Include(Set144(Mt17), MtEl) ; end ; if (Mt17[1]='0') and (Para=0) then begin ExtendedToLegibleHex := Sign + 'DEN' + Pad[Spaces] + ExtendedtoPlainHex(Arg) ; EXIT end ; for J := 1 to 17 do if Mt17[J]>'9' then Inc(Mt17[J], 7) ; end ; for J := 4*Ord(Spaces) downto 0 do Insert(#32, Mt21, 4*J+2) ; Mt21[2] := '.' ; ExtendedToLegibleHex := Sign + Mt21 + 'H' + SignExpo ; end {ExtendedToLegibleHex} ; function LegibleHexToExtended(Arg : St28) : extended ; type Set136 = set of 0..17*8-1 { 17 bytes - to access mantissa string bitwise } ; Set16 = set of 0..15 ; var Ansr : Extd ; Expo, LI : longint ; Adj, B, J, Jext, MSD, Csh, MtEl : byte ; BQ : boolean ; Argt : record Len, Sgn : char ; Bits136 : Set136 end absolute Arg ; begin FillChar(Ansr, SizeOf(Ansr), 0) ; if Arg[3]<>'.' then begin LegibleHextoExtended := PlainHexToExtended(Copy(Arg, Length(Arg)-19, 20)) ; EXIT end ; for J := 4*Ord(Spaces) downto 0 do Delete(Arg, 5*J+3, 1) ; MSD := 0 { Position of first non-zero digit } ; for J := 2 to 18 do if Arg[J]>'0' then begin MSD := J ; BREAK end ; if MSD>0 then begin Csh := 4*(MSD-2) ; for J := 2 to Length(Arg) do if Arg[J]>'9' then Dec(Arg[J], 7) ; BQ := Arg[2]='0' ; Adj := 0 { Position of most significant bit in MSD } ; J := Ord(Arg[MSD]) and $F ; while true do begin J := J shr 1 ; if J=0 then BREAK ; Inc(Adj) end ; Expo := 0 ; for J := Length(Arg)-2 to Length(Arg) do Expo := 16*Expo + (Ord(Arg[J]) and $F) ; if Arg[Length(Arg)-3] = '-' then Expo := -Expo ; LI := Expo*4 + Adj + 16383 - Csh ; if LI<0 then begin Adj := Adj - LI ; LI := 0 end ; Ansr.XP := LI ; if Para=1 then if BQ and (LI<>0) then Include(Ansr.mt, 63) ; for JExt := 0 to 63 do begin B := JExt + Adj + 1 ; if Para=1 then Inc(B, Ord(BQ)) ; MtEl := 16*8 + Csh*2 + (B and $03) - (B and $FC)*2 ; if MtEl in [0..135] then if MtEl in Argt.Bits136 then Include(Ansr.Mt, JExt) ; end ; end ; if Arg[1]='-' then Include(Set16(Ansr.XP), 15) { set sign bit } ; LegibleHexToExtended := extended(Ansr) end {LegibleHexToExtended} ; procedure TryThatOut(N : longint ; Inp : extended ; var AllOK : boolean) ; var Get : extended ; K : integer ; var Leg : St28 ; OK : boolean ; begin Write(N:7) ; Write('':2, Inp:15, '':2, ExtendedToPlainHex(Inp)) ; Leg := ExtendedToLegibleHex(Inp) ; Write('':2, Leg) ; Writeln ; Get := LegibleHexToExtended(Leg) ; Write('':9, Get:15) ; Leg := ExtendedToPlainHex(Get) ; Write('':2, Leg) ; OK := true ; for K := 0 to 9 do if TenBytes(Inp)[K]<>TenBytes(Get)[K] then OK := false { bitwise compare } ; if not OK then AllOK := false ; Write('OK =':7, OK:5, ', AllOK =', AllOK:5) ; Writeln ; Writeln ; end {TryThatOut} ; function TrySomeOut(const Start, Mul : extended ; Skip, Show : longint) : boolean ; var Inp : extended ; N : integer ; AllOK : boolean ; begin Writeln(^M^J^M^J) ; AllOK := true ; Inp := Start ; for N := 0 to Skip do Inp := Inp*Mul ; for N := 0 to Show do begin Inp := Inp*Mul ; TryThatOut(N, Inp, AllOK) ; end ; Writeln('AllOK = ', AllOK) ; TrySomeOut := AllOK end {TrySomeOut} ; function TryRanBin(const Show : longint) : boolean ; var Inp : extended ; TenB : TenBytes absolute Inp ; K : byte ; N : longint ; AllOK : boolean ; begin Writeln(^M^J^M^J) ; AllOK := true ; for N := 0 to Show do begin repeat for K := 0 to 9 do TenB[K] := Random(256) ; until (TenB[7]>127) or (Random(32768)=0) ; TryThatOut(N, Inp, AllOK) ; if not AllOK then HALT ; end ; Writeln('AllOK = ', AllOK) ; TryRanBin := AllOK end {TryRanBin} ; function TryRanNum(const Start : extended ; const Show : longint) : boolean ; var Inp : extended ; N : integer ; AllOK : boolean ; begin Writeln(^M^J^M^J) ; AllOK := true ; Inp := Start ; for N := 0 to Show do begin Inp := 2*Inp*Random ; TryThatOut(N, Inp, AllOK) ; end ; Writeln('AllOK = ', AllOK) ; TryRanNum := AllOK end {TryRanNum} ; procedure GetParameter ; var T : string [1] ; begin Para := 0 ; if ParamCount>0 then begin T := ParamStr(1) ; Para := byte(T[1]) - 48 end ; Writeln('Para = ', Para) ; end {GetParameter} ; procedure TryThemOut ; begin Writeln ; Write( 'Count : Extended -> PlainHex &-> LegibleHex -> '^M^J, ' LH -> Extended &-> PlainHex, agrees , all agree.') ; if not TryRanNum(1.0, 27) then HALT ; if not TrySomeOut(1.0, 2.0, 0, 7) then HALT ; if not TrySomeOut(0.0, 0.0, 0, 0) then HALT ; if not TrySomeOut(1.0, 1.234567, 0, 13) then HALT ; if not TrySomeOut(1.0, 1/1.234567, 0, 99) then HALT ; if not TrySomeOut(1.0-1/512, 2.0, 16376, 06) then HALT ; if not TrySomeOut(1.0-1/256-1/4096, 0.5, 16371, 9) then HALT ; if not TryRanBin(999999) then HALT ; end {TryThemOut} ; BEGIN GetParameter ; TryThemOut END.