mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-19 20:19:25 +02:00
* m68k updates merged
This commit is contained in:
peter
parent
ce52d581b3
commit
bc74424ab1
@ -330,7 +330,7 @@ end;
|
||||
FPC_HELP_CONSTRUCTOR : generic allways means aa little less efficient (PM) }
|
||||
{ I don't think we really need to save any registers here }
|
||||
{ since this is called at the start of the constructor (CEC) }
|
||||
procedure int_help_constructor(var _self : pointer; vmt : pointer; vmt_pos : cardinal); [public,alias:'FPC_HELP_CONSTRUCTOR'];
|
||||
function int_help_constructor(var _self : pointer; var vmt : pointer; vmt_pos : cardinal) : pointer; [public,alias:'FPC_HELP_CONSTRUCTOR'];
|
||||
type
|
||||
ppointer = ^pointer;
|
||||
pvmt = ^tvmt;
|
||||
@ -340,11 +340,23 @@ procedure int_help_constructor(var _self : pointer; vmt : pointer; vmt_pos : car
|
||||
end;
|
||||
var
|
||||
objectsize : longint;
|
||||
vmtcopy : pointer;
|
||||
begin
|
||||
objectsize:=pvmt(vmt)^.size;
|
||||
getmem(_self,objectsize);
|
||||
fillchar(_self,objectsize,#0);
|
||||
ppointer(_self+vmt_pos)^:=vmt;
|
||||
if vmt=nil then
|
||||
begin
|
||||
int_help_constructor:=_self;
|
||||
exit;
|
||||
end;
|
||||
vmtcopy:=vmt;
|
||||
objectsize:=pvmt(vmtcopy)^.size;
|
||||
if _self=nil then
|
||||
begin
|
||||
getmem(_self,objectsize);
|
||||
longint(vmt):=-1; { needed for fail }
|
||||
end;
|
||||
fillchar(_self^,objectsize,#0);
|
||||
ppointer(_self+vmt_pos)^:=vmtcopy;
|
||||
int_help_constructor:=_self;
|
||||
end;
|
||||
|
||||
{$endif ndef FPC_SYSTEM_HAS_FPC_HELP_CONSTRUCTOR}
|
||||
@ -376,6 +388,38 @@ end;
|
||||
|
||||
{$endif ndef FPC_SYSTEM_HAS_FPC_HELP_DESTRUCTOR}
|
||||
|
||||
{$ifndef FPC_SYSTEM_HAS_FPC_HELP_FAIL}
|
||||
{$error No pascal version of Int_help_fail}
|
||||
procedure int_help_fail(var _self : pointer; var vmt : pointer; vmt_pos : cardinal); [public,alias:'FPC_HELP_FAIL'];
|
||||
type
|
||||
ppointer = ^pointer;
|
||||
pvmt = ^tvmt;
|
||||
tvmt = packed record
|
||||
size,msize : longint;
|
||||
parent : pointer;
|
||||
end;
|
||||
var
|
||||
objectsize : longint;
|
||||
begin
|
||||
if vmt=nil then
|
||||
exit;
|
||||
if longint(vmt)=-1 then
|
||||
begin
|
||||
if (_self=nil) or (ppointer(_self+vmt_pos)^=nil) then
|
||||
HandleError(210)
|
||||
else
|
||||
begin
|
||||
ppointer(_self+vmt_pos)^:=nil;
|
||||
freemem(_self);
|
||||
_self:=nil;
|
||||
vmt:=nil;
|
||||
end;
|
||||
end
|
||||
else
|
||||
ppointer(_self+vmt_pos)^:=nil;
|
||||
end;
|
||||
|
||||
{$endif ndef FPC_SYSTEM_HAS_FPC_HELP_FAIL}
|
||||
|
||||
{$ifndef FPC_SYSTEM_HAS_FPC_NEW_CLASS}
|
||||
{$error No pascal version of Int_new_class}
|
||||
@ -498,6 +542,8 @@ end;
|
||||
procedure int_strcopy(len:longint;sstr,dstr:pointer);[public,alias:'FPC_SHORTSTR_COPY'];
|
||||
var
|
||||
slen : byte;
|
||||
type
|
||||
pstring = ^string;
|
||||
begin
|
||||
if dstr=nil then
|
||||
exit;
|
||||
@ -523,6 +569,8 @@ end;
|
||||
procedure int_strconcat(s1,s2:pointer);[public,alias:'FPC_SHORTSTR_CONCAT'];
|
||||
var
|
||||
s1l, s2l : byte;
|
||||
type
|
||||
pstring = ^string;
|
||||
begin
|
||||
if (s1=nil) or (s2=nil) then
|
||||
exit;
|
||||
@ -538,20 +586,22 @@ end;
|
||||
|
||||
{$ifndef FPC_SYSTEM_HAS_FPC_SHORTSTR_COMPARE}
|
||||
|
||||
function int_strcmp(dstr,sstr:pointer) : longint;[public,alias:'FPC_SHORTSTR_COMPARE'];
|
||||
function int_strcmp(rightstr,leftstr:pointer) : longint;[public,alias:'FPC_SHORTSTR_COMPARE'];
|
||||
var
|
||||
s1,s2,max,i : byte;
|
||||
d : longint;
|
||||
type
|
||||
pstring = ^string;
|
||||
begin
|
||||
s1:=length(pstring(dstr)^);
|
||||
s2:=length(pstring(sstr)^);
|
||||
s1:=length(pstring(rightstr)^);
|
||||
s2:=length(pstring(leftstr)^);
|
||||
if s1<s2 then
|
||||
max:=s1
|
||||
else
|
||||
max:=s2;
|
||||
for i:=1 to max do
|
||||
begin
|
||||
d:=byte(pstring(dstr)^[i])-byte(pstring(sstr)^[i]);
|
||||
d:=byte(pstring(leftstr)^[i])-byte(pstring(rightstr)^[i]);
|
||||
if d>0 then
|
||||
exit(1)
|
||||
else if d<0 then
|
||||
@ -624,8 +674,10 @@ begin
|
||||
len := byte(src[0]);
|
||||
inc(src);
|
||||
end;
|
||||
{$ifdef SUPPORT_ANSISTRING}
|
||||
{ ansistring}
|
||||
1: len := length(ansistring(pointer(src)));
|
||||
{$endif SUPPORT_ANSISTRING}
|
||||
{ longstring }
|
||||
2:;
|
||||
{ widestring }
|
||||
@ -825,10 +877,16 @@ end;
|
||||
{$endif ndef FPC_SYSTEM_HAS_FPC_BOUNDCHECK}
|
||||
{$endif NOBOUNDCHECK}
|
||||
|
||||
{****************************************************************************
|
||||
IoCheck
|
||||
****************************************************************************}
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.14 2001-07-08 21:00:18 peter
|
||||
Revision 1.15 2001-07-29 13:49:15 peter
|
||||
* m68k updates merged
|
||||
|
||||
Revision 1.14 2001/07/08 21:00:18 peter
|
||||
* various widestring updates, it works now mostly without charset
|
||||
mapping supported
|
||||
|
||||
|
||||
@ -61,7 +61,7 @@ type
|
||||
|
||||
var
|
||||
roundCorr, corrVal: valReal;
|
||||
intPart, spos, endpos, fracCount: longint;
|
||||
spos, endpos, fracCount: longint;
|
||||
correct, currprec: longint;
|
||||
temp : string;
|
||||
power : string[10];
|
||||
@ -88,9 +88,12 @@ var
|
||||
procedure getIntPart(d: valreal);
|
||||
var
|
||||
intPartStack: TIntPartStack;
|
||||
stackPtr, endStackPtr, digits: longint;
|
||||
intPart, stackPtr, endStackPtr, digits: longint;
|
||||
overflow: boolean;
|
||||
begin
|
||||
{$ifdef DEBUG_NASM}
|
||||
writeln(stderr,'getintpart(d) entry');
|
||||
{$endif DEBUG_NASM}
|
||||
{ position in the stack (gets increased before first write) }
|
||||
stackPtr := 0;
|
||||
{ number of digits processed }
|
||||
@ -121,6 +124,9 @@ var
|
||||
{ the power of 10 with which the resulting string has to be "multiplied" }
|
||||
{ if the decimal point is placed after the first significant digit }
|
||||
correct := digits-1;
|
||||
{$ifdef DEBUG_NASM}
|
||||
writeln(stderr,'endStackPtr = ',endStackPtr);
|
||||
{$endif DEBUG_NASM}
|
||||
repeat
|
||||
if (currprec > 0) then
|
||||
begin
|
||||
@ -128,6 +134,9 @@ var
|
||||
dec(currPrec);
|
||||
inc(spos);
|
||||
temp[spos] := chr(intPart+ord('0'));
|
||||
{$ifdef DEBUG_NASM}
|
||||
writeln(stderr,'stackptr =',stackptr,' intpart = ',intpart);
|
||||
{$endif DEBUG_NASM}
|
||||
if temp[spos] > '9' then
|
||||
begin
|
||||
temp[spos] := chr(ord(temp[spos])-10);
|
||||
@ -135,6 +144,9 @@ var
|
||||
end;
|
||||
end;
|
||||
corrVal := int(intPartStack[stackPtr]) * 10.0;
|
||||
{$ifdef DEBUG_NASM}
|
||||
writeln(stderr,'trunc(corrval) = ',trunc(corrval));
|
||||
{$endif DEBUG_NASM}
|
||||
dec(stackPtr);
|
||||
if stackPtr = 0 then
|
||||
stackPtr := maxDigits+1;
|
||||
@ -145,6 +157,9 @@ var
|
||||
if overflow and
|
||||
(trunc(intPartStack[stackPtr]-corrVal) > 5.0 - roundCorr) then
|
||||
roundStr(temp,spos);
|
||||
{$ifdef DEBUG_NASM}
|
||||
writeln(stderr,'temp at getintpart exit is = ',temp);
|
||||
{$endif DEBUG_NASM}
|
||||
end;
|
||||
|
||||
var maxlen : longint; { Maximal length of string for float }
|
||||
@ -255,8 +270,12 @@ begin
|
||||
{$error sign/NaN/Inf not yet supported for big endian CPU's in str_real}
|
||||
{$else SUPPORT_EXTENDED}
|
||||
{$ifdef SUPPORT_DOUBLE}
|
||||
sign := ((TSplitDouble(d).cards[0] shr 20) and $800) <> 0;
|
||||
expMaximal := ((TSplitDouble(d).cards[0] shr 20) and $7ff) = 2047;
|
||||
mantZero := (TSplitDouble(d).cards[0] and $fffff = 0) and
|
||||
(TSplitDouble(d).cards[1] = 0);
|
||||
{ double, format (MSB): 1 Sign bit, 11 bit exponent, 52 bit mantissa }
|
||||
{$error sign/NaN/Inf not yet supported for big endian CPU's in str_real}
|
||||
{error sign/NaN/Inf not yet supported for big endian CPU's in str_real}
|
||||
{$else SUPPORT_DOUBLE}
|
||||
{$ifdef SUPPORT_SINGLE}
|
||||
{ single, format (MSB): 1 Sign bit, 8 bit exponent, 23 bit mantissa }
|
||||
@ -419,7 +438,10 @@ end;
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.4 2001-06-13 18:32:05 peter
|
||||
Revision 1.5 2001-07-29 13:49:15 peter
|
||||
* m68k updates merged
|
||||
|
||||
Revision 1.4 2001/06/13 18:32:05 peter
|
||||
* big endian updates (merged)
|
||||
|
||||
Revision 1.3 2001/04/23 18:25:45 peter
|
||||
|
||||
@ -34,6 +34,7 @@ type
|
||||
|
||||
|
||||
const
|
||||
STACK_MARGIN = 16384; { Stack size margin for stack checking }
|
||||
{ Random / Randomize constants }
|
||||
OldRandSeed : Cardinal = 0;
|
||||
InitialSeed : Boolean = TRUE;
|
||||
@ -658,7 +659,10 @@ end;
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.17 2001-07-09 21:15:41 peter
|
||||
Revision 1.18 2001-07-29 13:49:15 peter
|
||||
* m68k updates merged
|
||||
|
||||
Revision 1.17 2001/07/09 21:15:41 peter
|
||||
* Length made internal
|
||||
* Add array support for Length
|
||||
|
||||
|
||||
@ -69,6 +69,8 @@ Type
|
||||
{$ifdef m68k}
|
||||
StrLenInt = Longint;
|
||||
|
||||
{$define SUPPORT_ANSISTRING}
|
||||
|
||||
ValSInt = Longint;
|
||||
ValUInt = Cardinal;
|
||||
ValReal = Real;
|
||||
@ -517,7 +519,10 @@ const
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.28 2001-07-15 11:57:16 peter
|
||||
Revision 1.29 2001-07-29 13:49:15 peter
|
||||
* m68k updates merged
|
||||
|
||||
Revision 1.28 2001/07/15 11:57:16 peter
|
||||
* merged m68k updates
|
||||
|
||||
Revision 1.27 2001/07/10 18:04:37 peter
|
||||
|
||||
Loading…
Reference in New Issue
Block a user