[fpc-pascal]Real bpw and fpc

[adeli@adeli.fr]

Date sent:      	Mon, 8 Oct 2001 23:57:00 +0200 (W. Europe Daylight 
Time)
From:           	Michael Van Canneyt <michael.vancanneyt at wisa.be>
To:             	<fpc-pascal at deadlock.et.tudelft.nl>
Subject:        	Re: [fpc-pascal]Real bpw and fpc
Send reply to:  	fpc-pascal at deadlock.et.tudelft.nl

the correction is only for convert the double into borland real when egal 0

i just try some convert but not trying all !

> 
> 
> On Mon, 8 Oct 2001, adeli at adeli.fr wrote:
> 
> > Date sent:      	Wed, 3 Oct 2001 00:02:49 +0200 (W. Europe Daylight Time)
> > From:           	Michael Van Canneyt <michael.vancanneyt at wisa.be>
> > To:             	<fpc-pascal at deadlock.et.tudelft.nl>
> > Subject:        	Re: [fpc-pascal]Real bpw and fpc
> > Send reply to:  	fpc-pascal at deadlock.et.tudelft.nl
> >
> >
> > TANKS a lot
> >
> > i found one bug on it..
> > how put correction on it  (the original sender is unknow!) ?
> 
> Send it to me; I'll implement it in the RTL, I think we should have had
> that a long time ago.
> 
> Michael.
> 
> 
> _______________________________________________
> fpc-pascal maillist  -  fpc-pascal at lists.freepascal.org
> http://lists.freepascal.org/mailman/listinfo/fpc-pascal


Lionel Drevon			ldrevon at adeli.fr
Adeli				http://www.adeli.fr
618 Av. Gal de Gaulle		Tel 04 78 66 11 85
69760 Limonest			Fax 04 78 66 04 33

-------------- next part --------------
unit borreal;

{**************************************************************************
  Title   : Quick and dirty borland-style reals
  Author  : Ren‚ van der Zee
  Compiler: Freepascal
  Platform: developed on Win32
  E-mail  : r.van.der.zee!nospam-remove this!@gmx.net
  Version : 0.3
  Why?    : because I want to read files with borland-style reals in them!

  TODO    :
    - more functions
    - make it more 'transparent' (how?)
    - maybe build it IN the freepascal compiler

 ---------------CORRECTION------------------
in the setvalue
 if (d=0) then
  	begin
  	e:=0;
  	f:=0;
  	sf:=0;
.....

  USAGE:
    <borlandreal>:=<double>;
    <double>:=<borlandreal>;
    double(<borlandreal>)

  EXAMPLES:
    var
      r:borlandreal;
      d:double;
    begin
      r:=-1.25e10;
      writeln(double(r):1:11)
      r:=d;
      d:=r;
    end;
    
 --------------------------------------------------------------------------
    !! if you make usefull changes to the unit or implement a TODO above
    or if you fixed a bug, PLEASE send me a copy !!
 **************************************************************************}

interface

{7654321076543210765432107654321076543210765432107654321076543210
 sxxxxxxxxxxxFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFfffffffffffff IEEE float64
 sfffffffffffffffffffffffffffffffffffffffeeeeeeee                 borland real
 siiiiiiiiiiifffffffffffffffffffffffffffffffffffffff0000000000000 real>float64
 where i=e-129+1023
 sFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFjjjjjjjj                 float64>real
 where J=x-1023+129
}

type
  borlandreal=packed object
    e  : byte;
    f  : longint;
    sf : byte;
    function  value:double;
    procedure setvalue(d:double);
  end; {Because no virtual functions are used, the size is 6 bytes}

operator := (b:borlandreal) d:double;
operator := (d:double) b:borlandreal;
var res:borlandreal;

implementation

operator := (b:borlandreal) d:double;
begin
  d:=b.value();
end;

operator := (d:double) b:borlandreal;
begin
  b.setvalue(d);
end;

function borlandreal.value:double;
var
  af:packed record
    case integer of
    1: (f2:word; f:longint; sxf:word);
    2: (r:double);
  end;
  ie:word;
begin
  if e=0 then
    fillchar(af,sizeof(af),#0)
  else begin
    ie:=e-129+1023;
    af.sxf:=((sf and 128) shl 8) or (ie shl 4) or ((sf and $7f) shr 3);
    af.f:=((sf and $7) shl 29) or (f shr 3);
    af.f2:=(f and $7) shl 13
  end;
  value:=af.r;
end;

procedure borlandreal.setvalue(d:double);
var
  af:packed record
    case integer of
    1: (f2:word; f:longint; sxf:word);
    2: (r:double);
  end;
  w:word;
  ie:integer;
  raf:^borlandreal;
begin
  {TODO}
  if (d=0) then
  	begin
  	e:=0;
  	f:=0;
  	sf:=0;
  	end else
  	begin
  	af.r:=d;
  	w:=(af.sxf shr 4) and $7ff;
  	ie:=w-1023+129;
  	if (ie>255) or (ie<0) then {overflow};
  	
  	e:=ie;
  	f:=((af.f and $1FFFFFFF) shl 3) or (af.f2 shr 13);
  	sf:=((af.sxf and $8000) shr 8) or ((af.sxf and $f) shl 3) or (af.f shr 29);
	
    end;

end;

end.