* generic write_float str_float

rtl/inc/astrings.inc

@@ -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

rtl/inc/real2str.inc

@@ -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,23 +50,17 @@ var correct : longint;  { Power correction }
 
 begin
   case real_type of
-    rt_s64real :
-      begin
-         maxlen:=23;
-         minlen:=9;
-         explen:=5;
-      end;
     rt_s32real :
       begin
          maxlen:=16;
          minlen:=8;
          explen:=4;
       end;
-    rt_f32bit  :
+    rt_s64real :
       begin
-         maxlen:=16;
-         minlen:=8;
-         explen:=4;
+         maxlen:=23;
+         minlen:=9;
+         explen:=5;
       end;
     rt_s80real :
       begin
@@ -82,13 +68,25 @@ begin
          minlen:=10;
          explen:=6;
       end;
-    rt_s64bit  :
+    rt_c64bit  :
       begin
          maxlen:=22;
          minlen:=9;
          { according to TP (was 5) (FK) }
          explen:=6;
       end;
+    rt_f16bit  :
+      begin
+         maxlen:=16;
+         minlen:=8;
+         explen:=4;
+      end;
+    rt_f32bit  :
+      begin
+         maxlen:=16;
+         minlen:=8;
+         explen:=4;
+      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
 

rtl/inc/sstrings.inc

@@ -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

rtl/inc/systemh.inc

@@ -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

rtl/inc/text.inc

@@ -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