mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-06-04 13:18:39 +02:00
* generic write_float str_float
This commit is contained in:
peter
parent
1c96916943
commit
458a7be587
@ -624,20 +624,27 @@ end;
|
||||
{$EndIf ValInternCompiled}
|
||||
|
||||
|
||||
{!!!!!!!!!!!!
|
||||
We need ansistring str routines for the following types:
|
||||
FIXED16
|
||||
QWORD
|
||||
INT64
|
||||
}
|
||||
|
||||
{$ifdef INTERNDOUBLE}
|
||||
|
||||
procedure AnsiStr_Float(d : ValReal;len,fr,rt : longint;var s : ansistring);[public,alias:'FPC_ANSISTR_FLOAT'];
|
||||
var
|
||||
ss : shortstring;
|
||||
begin
|
||||
str_real(len,fr,d,treal_type(rt),ss);
|
||||
s:=ss;
|
||||
end;
|
||||
|
||||
{$else INTERNDOUBLE}
|
||||
|
||||
|
||||
Procedure ACoStr (Co : Comp;Len,fr: Longint; Var S : AnsiString);
|
||||
[Public,Alias : 'FPC_'+{$ifdef NOSTRANSI}'ANSISTR'{$else}'STRANSI'{$endif}+'_COMP'];
|
||||
[Public,Alias : 'FPC_'+{$ifdef NOSTRANSI}'ANSISTR'{$else}'STRANSI_'{$endif}+'COMP'];
|
||||
|
||||
Var SS : ShortString;
|
||||
|
||||
begin
|
||||
int_Str_comp (Co,Len,fr,SS);
|
||||
ShortStr_comp (Co,Len,fr,SS);
|
||||
S:=SS;
|
||||
end;
|
||||
|
||||
@ -648,7 +655,7 @@ Procedure ASiStr (Si : Single;Len,fr: Longint; Var S : AnsiString);
|
||||
Var SS : ShortString;
|
||||
|
||||
begin
|
||||
int_Str_Single (Si,Len,fr,SS);
|
||||
ShortStr_Single (Si,Len,fr,SS);
|
||||
S:=SS;
|
||||
end;
|
||||
|
||||
@ -659,18 +666,19 @@ Procedure AFiStr (fi : Comp;Len,fr: Longint; Var S : AnsiString);
|
||||
Var SS : ShortString;
|
||||
|
||||
begin
|
||||
int_Str_Fixed (fi,Len,fr,SS);
|
||||
ShortStr_Fixed (fi,Len,fr,SS);
|
||||
S:=SS;
|
||||
end;
|
||||
{$EndIf Support_Fixed}
|
||||
|
||||
|
||||
Procedure ARStr (D : Real;Len,fr: Longint; Var S : AnsiString);
|
||||
[Public,Alias : 'FPC_'+{$ifdef NOSTRANSI}'ANSISTR'{$else}'STRANSI'{$endif}+'_REAL'];
|
||||
|
||||
Var SS : ShortString;
|
||||
|
||||
begin
|
||||
int_Str_real (D,Len,fr,SS);
|
||||
ShortStr_real (D,Len,fr,SS);
|
||||
S:=SS;
|
||||
end;
|
||||
|
||||
@ -681,11 +689,13 @@ Procedure AEStr (E : Extended;Len,Fr: Longint; Var S : AnsiString);
|
||||
Var SS : ShortString;
|
||||
|
||||
begin
|
||||
int_Str_Extended (E,Len,fr,SS);
|
||||
ShortStr_Extended (E,Len,fr,SS);
|
||||
S:=SS;
|
||||
end;
|
||||
|
||||
|
||||
{$endif INTERNDOUBLE}
|
||||
|
||||
|
||||
Procedure ACStr (C : Cardinal;Len : Longint; Var S : AnsiString);
|
||||
[Public,Alias : 'FPC_'+{$ifdef NOSTRANSI}'ANSISTR'{$else}'STRANSI'{$endif}+'_CARDINAL'];
|
||||
@ -761,7 +771,10 @@ end;
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.22 1999-04-22 10:51:17 peter
|
||||
Revision 1.23 1999-05-06 09:05:11 peter
|
||||
* generic write_float str_float
|
||||
|
||||
Revision 1.22 1999/04/22 10:51:17 peter
|
||||
* fixed pchar 2 ansi
|
||||
|
||||
Revision 1.21 1999/04/13 09:02:06 michael
|
||||
|
||||
@ -14,25 +14,17 @@
|
||||
**********************************************************************}
|
||||
|
||||
type
|
||||
{ See symdefh.inc tfloattyp }
|
||||
treal_type = (rt_s32real,rt_s64real,rt_s80real,rt_c64bit,rt_f16bit,rt_f32bit);
|
||||
{ corresponding to single double extended fixed comp for i386 }
|
||||
|
||||
treal_type = (rt_s64real,rt_s32real,rt_f32bit,rt_s80real,rt_s64bit);
|
||||
{ corresponding to real single fixed extended and comp for i386 }
|
||||
|
||||
{$ifdef i386}
|
||||
{$ifdef DEFAULT_EXTENDED}
|
||||
bestreal = extended;
|
||||
{$else}
|
||||
bestreal = double;
|
||||
{$endif DEFAULT_EXTENDED}
|
||||
{$else i386}
|
||||
bestreal = single;
|
||||
{$endif i386}
|
||||
const
|
||||
{ do not use real constants else you get rouding errors }
|
||||
i10 = 10;
|
||||
i2 = 2;
|
||||
i1 = 1;
|
||||
Procedure str_real (len,f : longint; d : bestreal; real_type :treal_type; var s : string);
|
||||
|
||||
Procedure str_real (len,f : longint; d : ValReal; real_type :treal_type; var s : string);
|
||||
{
|
||||
These numbers are for the double type...
|
||||
At the moment these are mapped onto a double but this may change
|
||||
@ -49,7 +41,7 @@ const
|
||||
|
||||
var correct : longint; { Power correction }
|
||||
currprec : longint;
|
||||
roundcorr : bestreal;
|
||||
roundcorr : Valreal;
|
||||
temp : string;
|
||||
power : string[10];
|
||||
sign : boolean;
|
||||
@ -58,13 +50,32 @@ var correct : longint; { Power correction }
|
||||
|
||||
begin
|
||||
case real_type of
|
||||
rt_s32real :
|
||||
begin
|
||||
maxlen:=16;
|
||||
minlen:=8;
|
||||
explen:=4;
|
||||
end;
|
||||
rt_s64real :
|
||||
begin
|
||||
maxlen:=23;
|
||||
minlen:=9;
|
||||
explen:=5;
|
||||
end;
|
||||
rt_s32real :
|
||||
rt_s80real :
|
||||
begin
|
||||
maxlen:=26;
|
||||
minlen:=10;
|
||||
explen:=6;
|
||||
end;
|
||||
rt_c64bit :
|
||||
begin
|
||||
maxlen:=22;
|
||||
minlen:=9;
|
||||
{ according to TP (was 5) (FK) }
|
||||
explen:=6;
|
||||
end;
|
||||
rt_f16bit :
|
||||
begin
|
||||
maxlen:=16;
|
||||
minlen:=8;
|
||||
@ -76,19 +87,6 @@ begin
|
||||
minlen:=8;
|
||||
explen:=4;
|
||||
end;
|
||||
rt_s80real :
|
||||
begin
|
||||
maxlen:=26;
|
||||
minlen:=10;
|
||||
explen:=6;
|
||||
end;
|
||||
rt_s64bit :
|
||||
begin
|
||||
maxlen:=22;
|
||||
minlen:=9;
|
||||
{ according to TP (was 5) (FK) }
|
||||
explen:=6;
|
||||
end;
|
||||
end;
|
||||
{ check parameters }
|
||||
{ default value for length is -32767 }
|
||||
@ -216,7 +214,10 @@ end;
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.12 1999-03-10 21:49:02 florian
|
||||
Revision 1.13 1999-05-06 09:05:12 peter
|
||||
* generic write_float str_float
|
||||
|
||||
Revision 1.12 1999/03/10 21:49:02 florian
|
||||
* str and val for extended use now int constants to minimize
|
||||
rounding error
|
||||
|
||||
|
||||
@ -282,46 +282,56 @@ end;
|
||||
Str() Helpers
|
||||
*****************************************************************************}
|
||||
|
||||
procedure int_str_real(d : real;len,fr : longint;var s : shortstring);[public,alias:'FPC_'+{$ifdef NOSTRANSI}'SHORT'+{$endif}'STR_REAL'];
|
||||
{$ifdef INTERNDOUBLE}
|
||||
|
||||
procedure ShortStr_Float(d : ValReal;len,fr,rt : longint;var s : shortstring);[public,alias:'FPC_SHORTSTR_FLOAT'];
|
||||
begin
|
||||
{$ifdef i386}
|
||||
str_real(len,fr,d,rt_s64real,s);
|
||||
{$else}
|
||||
str_real(len,fr,d,rt_s32real,s);
|
||||
{$endif}
|
||||
str_real(len,fr,d,treal_type(rt),s);
|
||||
end;
|
||||
|
||||
{$else}
|
||||
|
||||
|
||||
{$ifdef SUPPORT_SINGLE}
|
||||
procedure int_str_single(d : single;len,fr : longint;var s : shortstring);[public,alias:'FPC_'+{$ifdef NOSTRANSI}'SHORT'+{$endif}'STR_SINGLE'];
|
||||
procedure ShortStr_Single(d : single;len,fr : longint;var s : shortstring);[public,alias:'FPC_'+{$ifdef NOSTRANSI}'SHORT'+{$endif}'STR_'+{$ifdef INTERNDOUBLE}'S32REAL'{$else}'SINGLE'{$endif}];
|
||||
begin
|
||||
str_real(len,fr,d,rt_s32real,s);
|
||||
end;
|
||||
{$endif SUPPORT_SINGLE}
|
||||
{$endif}
|
||||
|
||||
|
||||
{$ifdef SUPPORT_DOUBLE}
|
||||
procedure ShortStr_Real(d : real;len,fr : longint;var s : shortstring);[public,alias:'FPC_'+{$ifdef NOSTRANSI}'SHORT'+{$endif}'STR_'+{$ifdef INTERNDOUBLE}'S64'+{$endif}'REAL'];
|
||||
begin
|
||||
str_real(len,fr,d,rt_s64real,s);
|
||||
end;
|
||||
{$endif SUPPORT_S64REAL}
|
||||
|
||||
|
||||
{$ifdef SUPPORT_EXTENDED}
|
||||
procedure int_str_extended(d : extended;len,fr : longint;var s : shortstring);[public,alias:'FPC_'+{$ifdef NOSTRANSI}'SHORT'+{$endif}'STR_EXTENDED'];
|
||||
procedure ShortStr_Extended(d : extended;len,fr : longint;var s : shortstring);[public,alias:'FPC_'+{$ifdef NOSTRANSI}'SHORT'+{$endif}'STR_'+{$ifdef INTERNDOUBLE}'S80REAL'{$else}'EXTENDED'{$endif}];
|
||||
begin
|
||||
str_real(len,fr,d,rt_s80real,s);
|
||||
end;
|
||||
{$endif SUPPORT_EXTENDED}
|
||||
{$endif SUPPORT_S80REAL}
|
||||
|
||||
|
||||
{$ifdef SUPPORT_COMP}
|
||||
procedure int_str_comp(d : comp;len,fr : longint;var s : shortstring);[public,alias:'FPC_'+{$ifdef NOSTRANSI}'SHORT'+{$endif}'STR_COMP'];
|
||||
procedure ShortStr_Comp(d : comp;len,fr : longint;var s : shortstring);[public,alias:'FPC_'+{$ifdef NOSTRANSI}'SHORT'+{$endif}'STR_'+{$ifdef INTERNDOUBLE}'C64BIT'{$else}'COMP'{$endif}];
|
||||
begin
|
||||
str_real(len,fr,d,rt_s64bit,s);
|
||||
str_real(len,fr,d,rt_c64bit,s);
|
||||
end;
|
||||
{$endif SUPPORT_COMP}
|
||||
{$endif SUPPORT_C64BIT}
|
||||
|
||||
|
||||
{$ifdef SUPPORT_FIXED}
|
||||
procedure int_str_fixed(d : fixed;len,fr : longint;var s : shortstring);[public,alias:'FPC_'+{$ifdef NOSTRANSI}'SHORT'+{$endif}'STR_FIXED'];
|
||||
procedure ShortStr_Fixed(d : fixed;len,fr : longint;var s : shortstring);[public,alias:'FPC_'+{$ifdef NOSTRANSI}'SHORT'+{$endif}'STR_'+{$ifdef INTERNDOUBLE}'F16BIT'{$else}'FIXED'{$endif}];
|
||||
begin
|
||||
str_real(len,fr,d,rt_f32bit,s);
|
||||
end;
|
||||
{$endif SUPPORT_FIXED}
|
||||
{$endif SUPPORT_F16BIT}
|
||||
|
||||
{$endif}
|
||||
|
||||
|
||||
procedure int_str_longint(v : longint;len : longint;var s : shortstring);[public,alias:'FPC_'+{$ifdef NOSTRANSI}'SHORT'+{$endif}'STR_LONGINT'];
|
||||
@ -1190,7 +1200,10 @@ end;
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.27 1999-04-08 15:57:54 peter
|
||||
Revision 1.28 1999-05-06 09:05:13 peter
|
||||
* generic write_float str_float
|
||||
|
||||
Revision 1.27 1999/04/08 15:57:54 peter
|
||||
+ subrange checking for readln()
|
||||
|
||||
Revision 1.26 1999/04/05 12:28:27 michael
|
||||
|
||||
@ -47,15 +47,19 @@ Type
|
||||
|
||||
{ at least declare Turbo Pascal real types }
|
||||
{$ifdef i386}
|
||||
Double = real;
|
||||
StrLenInt = LongInt;
|
||||
|
||||
{$ifndef INTERNDOUBLE}
|
||||
Double = real;
|
||||
{$endif}
|
||||
|
||||
{$define DEFAULT_EXTENDED}
|
||||
|
||||
{$define SUPPORT_SINGLE}
|
||||
{$define SUPPORT_DOUBLE}
|
||||
{$define SUPPORT_EXTENDED}
|
||||
{$define SUPPORT_COMP}
|
||||
{$define SUPPORT_SINGLE}
|
||||
{causes internalerror(17) with internal val handling, and is not yet fully
|
||||
supported anyway (JM)}
|
||||
|
||||
{ define SUPPORT_FIXED}
|
||||
|
||||
ValSInt = Longint;
|
||||
@ -69,6 +73,8 @@ Type
|
||||
ValSInt = Longint;
|
||||
ValUInt = Cardinal;
|
||||
ValReal = Real;
|
||||
|
||||
{$define SUPPORT_SINGLE}
|
||||
{$endif}
|
||||
|
||||
{ some type aliases }
|
||||
@ -454,7 +460,10 @@ const
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.55 1999-04-17 13:10:26 peter
|
||||
Revision 1.56 1999-05-06 09:05:14 peter
|
||||
* generic write_float str_float
|
||||
|
||||
Revision 1.55 1999/04/17 13:10:26 peter
|
||||
* addr() internal
|
||||
|
||||
Revision 1.54 1999/04/08 15:57:56 peter
|
||||
|
||||
@ -525,24 +525,23 @@ Begin
|
||||
End;
|
||||
|
||||
|
||||
{$ifdef INTERNDOUBLE}
|
||||
|
||||
Procedure Write_Real(fixkomma,Len : Longint;var t : TextRec;r : real);[Public,Alias:'FPC_WRITE_TEXT_REAL'];
|
||||
Procedure Write_Float(rt,fixkomma,Len : Longint;var t : TextRec;r : ValReal);[Public,Alias:'FPC_WRITE_TEXT_FLOAT'];
|
||||
var
|
||||
s : String;
|
||||
s : String;
|
||||
Begin
|
||||
If (InOutRes<>0) then
|
||||
exit;
|
||||
{$ifdef i386}
|
||||
Str_real(Len,fixkomma,r,rt_s64real,s);
|
||||
{$else}
|
||||
Str_real(Len,fixkomma,r,rt_s32real,s);
|
||||
{$endif}
|
||||
Write_Str(Len,t,s);
|
||||
Str_real(Len,fixkomma,r,treal_type(rt),s);
|
||||
Write_Str(Len,t,s);
|
||||
End;
|
||||
|
||||
{$else INTERNDOUBLE}
|
||||
|
||||
|
||||
{$ifdef SUPPORT_SINGLE}
|
||||
Procedure Write_Single(fixkomma,Len : Longint;var t : TextRec;r : single);[Public,Alias:'FPC_WRITE_TEXT_SINGLE'];
|
||||
Procedure Write_S32Real(fixkomma,Len : Longint;var t : TextRec;r : single);[Public,Alias:'FPC_WRITE_TEXT_'+{$ifdef INTERNDOUBLE}'S32REAL'{$else}'SINGLE'{$endif}];
|
||||
var
|
||||
s : String;
|
||||
Begin
|
||||
@ -551,11 +550,24 @@ Begin
|
||||
Str_real(Len,fixkomma,r,rt_s32real,s);
|
||||
Write_Str(Len,t,s);
|
||||
End;
|
||||
{$endif SUPPORT_SINGLE}
|
||||
{$endif SUPPORT_S32REAL}
|
||||
|
||||
|
||||
{$ifdef SUPPORT_DOUBLE}
|
||||
Procedure Write_s64Real(fixkomma,Len : Longint;var t : TextRec;r : double);[Public,Alias:'FPC_WRITE_TEXT_'+{$ifdef INTERNDOUBLE}'S64'{$endif}+'REAL'];
|
||||
var
|
||||
s : String;
|
||||
Begin
|
||||
If (InOutRes<>0) then
|
||||
exit;
|
||||
Str_real(Len,fixkomma,r,rt_s64real,s);
|
||||
Write_Str(Len,t,s);
|
||||
End;
|
||||
{$endif SUPPORT_S64REAL}
|
||||
|
||||
|
||||
{$ifdef SUPPORT_EXTENDED}
|
||||
Procedure Write_Extended(fixkomma,Len : Longint;var t : TextRec;r : extended);[Public,Alias:'FPC_WRITE_TEXT_EXTENDED'];
|
||||
Procedure Write_S80Real(fixkomma,Len : Longint;var t : TextRec;r : extended);[Public,Alias:'FPC_WRITE_TEXT_'+{$ifdef INTERNDOUBLE}'S80REAL'{$else}'EXTENDED'{$endif}];
|
||||
var
|
||||
s : String;
|
||||
Begin
|
||||
@ -564,24 +576,24 @@ Begin
|
||||
Str_real(Len,fixkomma,r,rt_s80real,s);
|
||||
Write_Str(Len,t,s);
|
||||
End;
|
||||
{$endif SUPPORT_EXTENDED}
|
||||
{$endif SUPPORT_S80REAL}
|
||||
|
||||
|
||||
{$ifdef SUPPORT_COMP}
|
||||
Procedure Write_Comp(fixkomma,Len : Longint;var t : TextRec;r : comp);[Public,Alias:'FPC_WRITE_TEXT_COMP'];
|
||||
Procedure Write_C64Bit(fixkomma,Len : Longint;var t : TextRec;r : comp);[Public,Alias:'FPC_WRITE_TEXT_'+{$ifdef INTERNDOUBLE}'C64BIT'{$else}'COMP'{$endif}];
|
||||
var
|
||||
s : String;
|
||||
Begin
|
||||
If (InOutRes<>0) then
|
||||
exit;
|
||||
Str_real(Len,fixkomma,r,rt_s64bit,s);
|
||||
Str_real(Len,fixkomma,r,rt_c64bit,s);
|
||||
Write_Str(Len,t,s);
|
||||
End;
|
||||
{$endif SUPPORT_COMP}
|
||||
{$endif SUPPORT_C64BIT}
|
||||
|
||||
|
||||
{$ifdef SUPPORT_FIXED}
|
||||
Procedure Write_Fixed(fixkomma,Len : Longint;var t : TextRec;r : fixed);[Public,Alias:'FPC_WRITE_TEXT_FIXED'];
|
||||
Procedure Write_Fixed(fixkomma,Len : Longint;var t : TextRec;r : fixed16);[Public,Alias:'FPC_WRITE_TEXT_'+{$ifdef INTERNDOUBLE}'F16BIT'{$else}'FIXED'{$endif}];
|
||||
var
|
||||
s : String;
|
||||
Begin
|
||||
@ -590,7 +602,9 @@ Begin
|
||||
Str_real(Len,fixkomma,r,rt_f32bit,s);
|
||||
Write_Str(Len,t,s);
|
||||
End;
|
||||
{$endif SUPPORT_FIXED}
|
||||
{$endif SUPPORT_F16BIT}
|
||||
|
||||
{$endif INTERNDOUBLE}
|
||||
|
||||
|
||||
Procedure Write_Boolean(Len : Longint;var t : TextRec;b : Boolean);[Public,Alias:'FPC_WRITE_TEXT_BOOLEAN'];
|
||||
@ -1211,7 +1225,10 @@ end;
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.45 1999-04-26 18:27:26 peter
|
||||
Revision 1.46 1999-05-06 09:05:16 peter
|
||||
* generic write_float str_float
|
||||
|
||||
Revision 1.45 1999/04/26 18:27:26 peter
|
||||
* fixed write array
|
||||
* read array with maxlen
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user