* a lot small fixes to the extended data type work

rtl/i386/math.inc

@@ -15,7 +15,7 @@
  **********************************************************************}
 
 {$ASMMODE DIRECT}
-
+{$ifdef dummy}
     function abs(d : real) : real;
 
       begin
@@ -218,7 +218,41 @@
          end [];
       end;
 
-    function pi : real;
+    function sin(d : real) : real;
+
+      begin
+         asm
+            fldl 8(%ebp)
+            fsin
+            fstsw
+            sahf
+            jnp .LSIN1
+            fstp %st(0)
+            fldl .LSIN0
+         .LSIN1:
+            leave
+            ret $8
+         .LSIN0:
+            .quad       0xffffffffffffffff
+         end ['EAX'];
+      end;
+
+   function power(bas,expo : real) : real;
+     begin
+        power:=exp(ln(bas)*expo);
+     end;
+{$endif dummy
+
+   function power(bas,expo : longint) : longint;
+     begin
+        power:=round(exp(ln(bas)*expo));
+     end;
+
+{****************************************************************************
+                       EXTENDED data type routines
+ ****************************************************************************}
+
+    function pi : extended;
 
       begin
          asm
@@ -228,26 +262,234 @@
          end [];
       end;
 
-    function sin(d : real) : real;
+    function abs(d : extended) : extended;
 
       begin
          asm
-            fldl 8(%ebp)
+            fldt 8(%ebp)
+            fabs
+            leave
+            ret $10
+         end [];
+      end;
+
+    function sqr(d : extended) : extended;
+
+      begin
+         asm
+            fldt 8(%ebp)
+            fldt 8(%ebp)
+            fmulp
+            leave
+            ret $10
+         end [];
+      end;
+
+    function sqrt(d : extended) : extended;
+
+      begin
+         asm
+            fldt 8(%ebp)
+            fsqrtl
+            leave
+            ret $10
+         end [];
+      end;
+
+    function arctan(d : extended) : extended;
+
+      begin
+         asm
+            fldt 8(%ebp)
+            fld1
+            fpatan
+            leave
+            ret $10
+         end [];
+      end;
+
+    function cos(d : extended) : extended;
+
+      begin
+         asm
+            fldt 8(%ebp)
+            fcos
+            fstsw
+            sahf
+            jnp .LCOS1
+            fstp %st(0)
+            fldt .LCOS0
+         .LCOS1:
+            leave
+            ret $10
+         .LCOS0:
+            .long       0xffffffff
+            .long       0xffffffff
+            .word       0xffff
+         end ['EAX'];
+      end;
+
+    function exp(d : extended) : extended;
+
+      begin
+         asm
+            // comes from DJ GPP
+            fldt        8(%ebp)
+            fldl2e
+            fmulp
+            fstcww      .LCW1
+            fstcww      .LCW2
+            fwait
+            andw        $0xf3ff,.LCW2
+            orw $0x0400,.LCW2
+            fldcww      .LCW2
+            fld         %st(0)
+            frndint
+            fldcww      .LCW1
+            fxch        %st(1)
+            fsub        %st(1),%st
+            f2xm1
+            fld1
+            fadd
+            fscale
+            fstp        %st(1)
+            leave
+            ret $10
+
+            // store some help data in the data segment
+            .data
+    .LCW1:
+            .word       0
+    .LCW2:
+            .word       0
+    .LC0:
+            .double     0d1.0e+00
+
+            // do not forget to switch back to text
+            .text
+         end;
+      end;
+
+    function frac(d : extended) : extended;
+
+      begin
+         asm
+            subl $16,%esp
+            fnstcw -4(%ebp)
+            fwait
+            movw -4(%ebp),%cx
+            orw $0x0c3f,%cx
+            movw %cx,-8(%ebp)
+            fldcw -8(%ebp)
+            fwait
+            fldt 8(%ebp)
+            frndint
+            fldt 8(%ebp)
+            fsub %st(1)
+            fstp %st(1)
+            fclex
+            fldcw -4(%ebp)
+            leave
+            ret $10
+         end ['ECX'];
+      end;
+
+    function int(d : extended) : extended;
+
+      begin
+         asm
+            subl $16,%esp
+            fnstcw -4(%ebp)
+            fwait
+            movw -4(%ebp),%cx
+            orw $0x0c3f,%cx
+            movw %cx,-8(%ebp)
+            fldcw -8(%ebp)
+            fwait
+            fldt 8(%ebp)
+            frndint
+            fclex
+            fldcw -4(%ebp)
+            leave
+            ret $10
+         end ['ECX'];
+      end;
+
+    function trunc(d : extended) : longint;
+
+      begin
+         asm
+            subl $16,%esp
+            fnstcw -4(%ebp)
+            fwait
+            movw -4(%ebp),%cx
+            orw $0x0c3f,%cx
+            movw %cx,-8(%ebp)
+            fldcw -8(%ebp)
+            fwait
+            fldt 8(%ebp)
+            fistpl -8(%ebp)
+            movl -8(%ebp),%eax
+            fldcw -4(%ebp)
+            leave
+            ret $10
+         end ['EAX','ECX'];
+      end;
+
+    function round(d : extended) : longint;
+
+      begin
+         asm
+            subl $8,%esp
+            fnstcw -4(%ebp)
+            fwait
+            movw $0x1372,-8(%ebp)
+            fldcw -8(%ebp)
+            fwait
+            fldt 8(%ebp)
+            fistpl -8(%ebp)
+            movl -8(%ebp),%eax
+            fldcw -4(%ebp)
+            leave
+            ret $10
+         end ['EAX','ECX'];
+      end;
+
+    function ln(d : extended) : extended;
+
+      begin
+         asm
+            fldln2
+            fldt 8(%ebp)
+            fyl2x
+            leave
+            ret $10
+         end [];
+      end;
+
+    function sin(d : extended) : extended;
+
+      begin
+         asm
+            fldt 8(%ebp)
             fsin
             fstsw
             sahf
             jnp .LSIN1
             fstp %st(0)
-            fldl .LSIN0
+            fldt .LSIN0
          .LSIN1:
             leave
-            ret $8
+            ret $10
          .LSIN0:
-            .quad       0xffffffffffffffff
+            .long       0xffffffff
+            .long       0xffffffff
+            .word       0xffff
          end ['EAX'];
       end;
 
-   function power(bas,expo : real) : real;
+   function power(bas,expo : extended) : extended;
+
      begin
         power:=exp(ln(bas)*expo);
      end;
@@ -373,7 +615,10 @@
 
 {
   $Log$
-  Revision 1.2  1998-05-31 14:15:49  peter
+  Revision 1.3  1998-08-08 12:28:09  florian
+    * a lot small fixes to the extended data type work
+
+  Revision 1.2  1998/05/31 14:15:49  peter
     * force to use ATT or direct parsing
 
 }

rtl/inc/astrings.pp

@@ -251,17 +251,15 @@ end;
 
 
 
-Procedure Ansi_To_ShortString (Var S1 : ShortString; Var S2 : AnsiString; Maxlen : Longint);
+Procedure Ansi_To_ShortString (Var S1 : ShortString;const S2 : AnsiString; Maxlen : Longint);
+  [Public, alias: 'FPC_TO_ANSISTRING_SHORT'];
 {
  Converts a AnsiString to a ShortString;
- if maxlen<>-1, the resulting string has maximal length maxlen
- else a default length of 255 is taken. 
 }
 Var Size : Longint;
 
 begin
   Size:=PAnsiRec(Pointer(S2)-FirstOff)^.Len;
-  if maxlen=-1 then maxlen:=255;
   If Size>maxlen then Size:=maxlen;
   Move (Pointer(S2)^,S1[1],Size);
   byte(S1[0]):=Size;
@@ -269,7 +267,8 @@ end;
 
 
 
-Procedure Short_To_AnsiString (Var S1 : AnsiString; Var S2 : ShortString);
+Procedure Short_To_AnsiString (Const S1 : AnsiString; Var S2 : ShortString);
+  [Public, alias: 'FPC_SHORT_TO_ANSISTRING'];
 {
  Converts a ShortString to a AnsiString;
 }
@@ -280,7 +279,8 @@ begin
   Size:=Byte(S2[0]);
   Setlength (S1,Size);
   Move (S2[1],Pointer(S1)^,Size);
-  PByte(Pointer(S1)+Size)^:=0; { Terminating Zero }
+  { Terminating Zero }
+  PByte(Pointer(S1)+Size)^:=0;
 end;
 
 
@@ -676,7 +676,10 @@ end;
 
 {
   $Log$
-  Revision 1.10  1998-07-29 21:44:34  michael
+  Revision 1.11  1998-08-08 12:28:10  florian
+    * a lot small fixes to the extended data type work
+
+  Revision 1.10  1998/07/29 21:44:34  michael
   + Implemented reading/writing of ansistrings
 
   Revision 1.9  1998/07/20 23:36:56  michael

rtl/inc/mathh.inc

@@ -15,6 +15,23 @@
 
    { declarations of the math routines }
 
+{$ifdef i386}
+    function abs(d : extended) : extended;
+    function arctan(d : extended) : extended;
+    function cos(d : extended) : extended;
+    function exp(d : extended) : extended;
+    function frac(d : extended) : extended;
+    function int(d : extended) : extended;
+    function ln(d : extended) : extended;
+    function pi : extended;
+    function round(d : extended) : longint;
+    function sin(d : extended) : extended;
+    function sqr(d : extended) : extended;
+    function sqrt(d : extended) : extended;
+    function trunc(d : extended) : longint;
+    function power(bas,expo : extended) : extended;
+    function power(bas,expo : longint) : longint;
+{$else i386}
     function abs(d : real) : real;
     function arctan(d : real) : real;
     function cos(d : real) : real;
@@ -22,14 +39,16 @@
     function frac(d : real) : real;
     function int(d : real) : real;
     function ln(d : real) : real;
-    function pi : real;
     function round(d : real) : longint;
     function sin(d : real) : real;
     function sqr(d : real) : real;
     function sqrt(d : real) : real;
     function trunc(d : real) : longint;
-    function power(bas,expo : real) : real;
     function power(bas,expo : longint) : longint;
+    function power(bas,expo : real) : real;
+    function pi : real;
+{$endif i386}
+
 {$ifdef FIXED}
     function sqrt(d : fixed) : fixed;
     function Round(x: fixed): longint;
@@ -42,10 +61,12 @@
 
 {
   $Log$
-  Revision 1.2  1998-05-12 10:42:45  peter
+  Revision 1.3  1998-08-08 12:28:11  florian
+    * a lot small fixes to the extended data type work
+
+  Revision 1.2  1998/05/12 10:42:45  peter
     * moved getopts to inc/, all supported OS's need argc,argv exported
     + strpas, strlen are now exported in the systemunit
     * removed logs
     * removed $ifdef ver_above
-
 }

rtl/inc/real2str.inc

@@ -19,8 +19,11 @@ type
   { corresponding to real    single     fixed   extended and comp for i386 }
 
 {$ifdef i386}
-{  bestreal  = extended;  still gives problems }
+{$ifdef VER0_9_5}
   bestreal = double;
+{$else VER0_9_5}
+  bestreal = extended; 
+{$endif VER0_9_5}
 {$else i386}
   bestreal = single;
 {$endif i386}
@@ -198,7 +201,10 @@ end;
 
 {
   $Log$
-  Revision 1.6  1998-07-18 17:14:22  florian
+  Revision 1.7  1998-08-08 12:28:12  florian
+    * a lot small fixes to the extended data type work
+
+  Revision 1.6  1998/07/18 17:14:22  florian
     * strlenint type implemented
 
   Revision 1.5  1998/07/13 21:19:10  florian

rtl/inc/sstrings.inc

@@ -467,11 +467,10 @@ begin
   val(s,b,word(code));
 end;
 
-
-procedure val(const s : string;var d : real;var code : word);
+procedure val(const s : string;var d : valreal;var code : word);
 var
   hd,
-  esign,sign : real;
+  esign,sign : valreal;
   exponent,i : longint;
   flags      : byte;
 begin
@@ -567,14 +566,13 @@ begin
   code:=0;
 end;
 
-
-procedure val(const s : string;var d : real;var code : integer);
+procedure val(const s : string;var d : valreal;var code : integer);
 begin
   val(s,d,word(code));
 end;
 
 
-procedure val(const s : string;var d : real);
+procedure val(const s : string;var d : valreal);
 var
   code : word;
 begin
@@ -585,7 +583,7 @@ end;
 {$ifdef SUPPORT_SINGLE}
 procedure val(const s : string;var d : single;var code : word);
 var
-  e : double;
+  e : valreal;
 begin
   val(s,e,code);
   d:=e;
@@ -594,7 +592,7 @@ end;
 
 procedure val(const s : string;var d : single;var code : integer);
 var
-  e : double;
+  e : valreal;
 begin
   val(s,e,word(code));
   d:=e;
@@ -612,28 +610,31 @@ end;
 {$endif SUPPORT_SINGLE}
 
 {$ifdef SUPPORT_EXTENDED}
-procedure val(const s : string;var d : extended;var code : word);
+
+{ we have to define val for reals, if extended is supported }
+
+procedure val(const s : string;var d : real;var code : word);
 var
-  e : double;
+  e : valreal;
 begin
   val(s,e,code);
   d:=e;
 end;
 
 
-procedure val(const s : string;var d : extended;var code : integer);
+procedure val(const s : string;var d : real;var code : integer);
 var
-  e : double;
+   e : valreal;
 begin
   val(s,e,word(code));
   d:=e;
 end;
 
 
-procedure val(const s : string;var d : extended);
+procedure val(const s : string;var d : real);
 var
   code : word;
-  e    : double;
+  e    : valreal;
 begin
   val(s,e,code);
   d:=e;
@@ -644,7 +645,7 @@ end;
 {$ifdef SUPPORT_COMP}
 procedure val(const s : string;var d : comp;var code : word);
 var
-  e : double;
+  e : valreal;
 begin
   val(s,e,code);
   d:=comp(e);
@@ -653,7 +654,7 @@ end;
 
 procedure val(const s : string;var d : comp;var code : integer);
 var
-  e : double;
+  e : valreal;
 begin
   val(s,e,word(code));
   d:=comp(e);
@@ -663,7 +664,7 @@ end;
 procedure val(const s : string;var d : comp);
 var
   code : word;
-  e    : double;
+  e    : valreal;
 begin
   val(s,e,code);
   d:=comp(e);
@@ -717,7 +718,10 @@ end;
 
 {
   $Log$
-  Revision 1.9  1998-07-18 17:14:23  florian
+  Revision 1.10  1998-08-08 12:28:13  florian
+    * a lot small fixes to the extended data type work
+
+  Revision 1.9  1998/07/18 17:14:23  florian
     * strlenint type implemented
 
   Revision 1.8  1998/07/10 11:02:38  peter

rtl/inc/systemh.inc

@@ -36,6 +36,7 @@ Type
 { at least declare Turbo Pascal real types }
 {$ifdef i386}
   Double = real;
+  ValReal = Extended;
   {$define SUPPORT_EXTENDED}
   {$define SUPPORT_COMP}
   {$define SUPPORT_SINGLE}
@@ -44,6 +45,7 @@ Type
 
 {$ifdef m68k}
    StrLenInt = Integer;
+   ValReal = Real;
    {$ifdef USEANSISTRINGS}
       {$error StrLenInt must be a longint if ansi strings are used}
    {$endif}
@@ -242,18 +244,21 @@ Procedure Val(const s:string;Var b:Word);
 Procedure Val(const s:string;Var b:Integer;Var code:Word);
 Procedure Val(const s:string;Var b:Integer;Var code:Integer);
 Procedure Val(const s:string;Var b:Integer);
-Procedure Val(const s:string;Var d:Real;Var code:Word);
-Procedure Val(const s:string;Var d:Real;Var code:Integer);
-Procedure Val(const s:string;Var d:Real);
+Procedure Val(const s:string;Var d:ValReal;Var code:Word);
+Procedure Val(const s:string;Var d:ValReal;Var code:Integer);
+Procedure Val(const s:string;Var d:ValReal);
 {$ifdef SUPPORT_SINGLE}
 Procedure Val(const s:string;Var d:single;Var code:Word);
 Procedure Val(const s:string;Var d:single;Var code:Integer);
 Procedure Val(const s:string;Var d:single);
 {$endif SUPPORT_SINGLE}
 {$ifdef SUPPORT_EXTENDED}
-Procedure Val(const s:string;Var d:Extended;Var code:Word);
-Procedure Val(const s:string;Var d:Extended;Var code:Integer);
-Procedure Val(const s:string;Var d:Extended);
+{ if extended is supported, valreal is an extended, so we
+  have to define the real routines
+}
+Procedure Val(const s:string;Var d:Real;Var code:Word);
+Procedure Val(const s:string;Var d:Real;Var code:Integer);
+Procedure Val(const s:string;Var d:Real);
 {$endif SUPPORT_EXTENDED}
 {$ifdef SUPPORT_COMP}
 Procedure Val(const s:string;Var d:comp;Var code:Word);
@@ -410,7 +415,10 @@ Procedure halt;
 
 {
   $Log$
-  Revision 1.21  1998-07-30 13:26:17  michael
+  Revision 1.22  1998-08-08 12:28:14  florian
+    * a lot small fixes to the extended data type work
+
+  Revision 1.21  1998/07/30 13:26:17  michael
   + Added support for ErrorProc variable. All internal functions are required
     to call HandleError instead of runerror from now on.
     This is necessary for exception support.