paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-05 10:46:19 +02:00
Code Issues Packages Projects Releases Wiki Activity

* generic write_float str_float

Browse Source
This commit is contained in:
peter 1999-05-06 09:05:11 +00:00
parent 1c96916943
commit 458a7be587
5 changed files with 134 additions and 81 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
rtl/inc/astrings.inc
View File

@ -624,20 +624,27 @@ end;
{$EndIf ValInternCompiled} {$EndIf ValInternCompiled}
{!!!!!!!!!!!!
We need ansistring str routines for the following types: {$ifdef INTERNDOUBLE}
FIXED16
QWORD procedure AnsiStr_Float(d : ValReal;len,fr,rt : longint;var s : ansistring);[public,alias:'FPC_ANSISTR_FLOAT'];
INT64 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); 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; Var SS : ShortString;
begin begin
int_Str_comp (Co,Len,fr,SS); ShortStr_comp (Co,Len,fr,SS);
S:=SS; S:=SS;
end; end;
@ -648,7 +655,7 @@ Procedure ASiStr (Si : Single;Len,fr: Longint; Var S : AnsiString);
Var SS : ShortString; Var SS : ShortString;
begin begin
int_Str_Single (Si,Len,fr,SS); ShortStr_Single (Si,Len,fr,SS);
S:=SS; S:=SS;
end; end;
@ -659,18 +666,19 @@ Procedure AFiStr (fi : Comp;Len,fr: Longint; Var S : AnsiString);
Var SS : ShortString; Var SS : ShortString;
begin begin
int_Str_Fixed (fi,Len,fr,SS); ShortStr_Fixed (fi,Len,fr,SS);
S:=SS; S:=SS;
end; end;
{$EndIf Support_Fixed} {$EndIf Support_Fixed}
Procedure ARStr (D : Real;Len,fr: Longint; Var S : AnsiString); Procedure ARStr (D : Real;Len,fr: Longint; Var S : AnsiString);
[Public,Alias : 'FPC_'+{$ifdef NOSTRANSI}'ANSISTR'{$else}'STRANSI'{$endif}+'_REAL']; [Public,Alias : 'FPC_'+{$ifdef NOSTRANSI}'ANSISTR'{$else}'STRANSI'{$endif}+'_REAL'];
Var SS : ShortString; Var SS : ShortString;
begin begin
int_Str_real (D,Len,fr,SS); ShortStr_real (D,Len,fr,SS);
S:=SS; S:=SS;
end; end;
@ -681,11 +689,13 @@ Procedure AEStr (E : Extended;Len,Fr: Longint; Var S : AnsiString);
Var SS : ShortString; Var SS : ShortString;
begin begin
int_Str_Extended (E,Len,fr,SS); ShortStr_Extended (E,Len,fr,SS);
S:=SS; S:=SS;
end; end;
{$endif INTERNDOUBLE}
Procedure ACStr (C : Cardinal;Len : Longint; Var S : AnsiString); Procedure ACStr (C : Cardinal;Len : Longint; Var S : AnsiString);
[Public,Alias : 'FPC_'+{$ifdef NOSTRANSI}'ANSISTR'{$else}'STRANSI'{$endif}+'_CARDINAL']; [Public,Alias : 'FPC_'+{$ifdef NOSTRANSI}'ANSISTR'{$else}'STRANSI'{$endif}+'_CARDINAL'];
@ -761,7 +771,10 @@ end;
{ {
$Log$ $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 * fixed pchar 2 ansi
Revision 1.21 1999/04/13 09:02:06 michael Revision 1.21 1999/04/13 09:02:06 michael

59
rtl/inc/real2str.inc
View File

@ -14,25 +14,17 @@
**********************************************************************} **********************************************************************}
type 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 const
{ do not use real constants else you get rouding errors } { do not use real constants else you get rouding errors }
i10 = 10; i10 = 10;
i2 = 2; i2 = 2;
i1 = 1; 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... These numbers are for the double type...
At the moment these are mapped onto a double but this may change At the moment these are mapped onto a double but this may change
@ -49,7 +41,7 @@ const
var correct : longint; { Power correction } var correct : longint; { Power correction }
currprec : longint; currprec : longint;
roundcorr : bestreal; roundcorr : Valreal;
temp : string; temp : string;
power : string[10]; power : string[10];
sign : boolean; sign : boolean;
@ -58,13 +50,32 @@ var correct : longint; { Power correction }
begin begin
case real_type of case real_type of
rt_s32real :
begin
maxlen:=16;
minlen:=8;
explen:=4;
end;
rt_s64real : rt_s64real :
begin begin
maxlen:=23; maxlen:=23;
minlen:=9; minlen:=9;
explen:=5; explen:=5;
end; 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 begin
maxlen:=16; maxlen:=16;
minlen:=8; minlen:=8;
@ -76,19 +87,6 @@ begin
minlen:=8; minlen:=8;
explen:=4; explen:=4;
end; 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; end;
{ check parameters } { check parameters }
{ default value for length is -32767 } { default value for length is -32767 }
@ -216,7 +214,10 @@ end;
{ {
$Log$ $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 * str and val for extended use now int constants to minimize
rounding error rounding error

45
rtl/inc/sstrings.inc
View File

@ -282,46 +282,56 @@ end;
Str() Helpers 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 begin
{$ifdef i386} str_real(len,fr,d,treal_type(rt),s);
str_real(len,fr,d,rt_s64real,s);
{$else}
str_real(len,fr,d,rt_s32real,s);
{$endif}
end; end;
{$else}
{$ifdef SUPPORT_SINGLE} {$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 begin
str_real(len,fr,d,rt_s32real,s); str_real(len,fr,d,rt_s32real,s);
end; 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} {$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 begin
str_real(len,fr,d,rt_s80real,s); str_real(len,fr,d,rt_s80real,s);
end; end;
{$endif SUPPORT_EXTENDED} {$endif SUPPORT_S80REAL}
{$ifdef SUPPORT_COMP} {$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 begin
str_real(len,fr,d,rt_s64bit,s); str_real(len,fr,d,rt_c64bit,s);
end; end;
{$endif SUPPORT_COMP} {$endif SUPPORT_C64BIT}
{$ifdef SUPPORT_FIXED} {$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 begin
str_real(len,fr,d,rt_f32bit,s); str_real(len,fr,d,rt_f32bit,s);
end; 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']; 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$ $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() + subrange checking for readln()
Revision 1.26 1999/04/05 12:28:27 michael Revision 1.26 1999/04/05 12:28:27 michael

19
rtl/inc/systemh.inc
View File

@ -47,15 +47,19 @@ Type
{ at least declare Turbo Pascal real types } { at least declare Turbo Pascal real types }
{$ifdef i386} {$ifdef i386}
Double = real;
StrLenInt = LongInt; StrLenInt = LongInt;
{$ifndef INTERNDOUBLE}
Double = real;
{$endif}
{$define DEFAULT_EXTENDED} {$define DEFAULT_EXTENDED}
{$define SUPPORT_SINGLE}
{$define SUPPORT_DOUBLE}
{$define SUPPORT_EXTENDED} {$define SUPPORT_EXTENDED}
{$define SUPPORT_COMP} {$define SUPPORT_COMP}
{$define SUPPORT_SINGLE}
{causes internalerror(17) with internal val handling, and is not yet fully
supported anyway (JM)}
{ define SUPPORT_FIXED} { define SUPPORT_FIXED}
ValSInt = Longint; ValSInt = Longint;
@ -69,6 +73,8 @@ Type
ValSInt = Longint; ValSInt = Longint;
ValUInt = Cardinal; ValUInt = Cardinal;
ValReal = Real; ValReal = Real;
{$define SUPPORT_SINGLE}
{$endif} {$endif}
{ some type aliases } { some type aliases }
@ -454,7 +460,10 @@ const
{ {
$Log$ $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 * addr() internal
Revision 1.54 1999/04/08 15:57:56 peter Revision 1.54 1999/04/08 15:57:56 peter

53
rtl/inc/text.inc
View File

@ -525,24 +525,23 @@ Begin
End; 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 var
s : String; s : String;
Begin Begin
If (InOutRes<>0) then If (InOutRes<>0) then
exit; exit;
{$ifdef i386} Str_real(Len,fixkomma,r,treal_type(rt),s);
Str_real(Len,fixkomma,r,rt_s64real,s); Write_Str(Len,t,s);
{$else}
Str_real(Len,fixkomma,r,rt_s32real,s);
{$endif}
Write_Str(Len,t,s);
End; End;
{$else INTERNDOUBLE}
{$ifdef SUPPORT_SINGLE} {$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 var
s : String; s : String;
Begin Begin
@ -551,11 +550,24 @@ Begin
Str_real(Len,fixkomma,r,rt_s32real,s); Str_real(Len,fixkomma,r,rt_s32real,s);
Write_Str(Len,t,s); Write_Str(Len,t,s);
End; 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} {$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 var
s : String; s : String;
Begin Begin
@ -564,24 +576,24 @@ Begin
Str_real(Len,fixkomma,r,rt_s80real,s); Str_real(Len,fixkomma,r,rt_s80real,s);
Write_Str(Len,t,s); Write_Str(Len,t,s);
End; End;
{$endif SUPPORT_EXTENDED} {$endif SUPPORT_S80REAL}
{$ifdef SUPPORT_COMP} {$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 var
s : String; s : String;
Begin Begin
If (InOutRes<>0) then If (InOutRes<>0) then
exit; exit;
Str_real(Len,fixkomma,r,rt_s64bit,s); Str_real(Len,fixkomma,r,rt_c64bit,s);
Write_Str(Len,t,s); Write_Str(Len,t,s);
End; End;
{$endif SUPPORT_COMP} {$endif SUPPORT_C64BIT}
{$ifdef SUPPORT_FIXED} {$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 var
s : String; s : String;
Begin Begin
@ -590,7 +602,9 @@ Begin
Str_real(Len,fixkomma,r,rt_f32bit,s); Str_real(Len,fixkomma,r,rt_f32bit,s);
Write_Str(Len,t,s); Write_Str(Len,t,s);
End; 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']; Procedure Write_Boolean(Len : Longint;var t : TextRec;b : Boolean);[Public,Alias:'FPC_WRITE_TEXT_BOOLEAN'];
@ -1211,7 +1225,10 @@ end;
{ {
$Log$ $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 * fixed write array
* read array with maxlen * read array with maxlen