* m68k updates merged

rtl/inc/generic.inc

@@ -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;
-begin
-   objectsize:=pvmt(vmt)^.size;
-   getmem(_self,objectsize);
-   fillchar(_self,objectsize,#0);
-   ppointer(_self+vmt_pos)^:=vmt;
+      vmtcopy : pointer;
+begin
+   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
 

rtl/inc/real2str.inc

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

rtl/inc/system.inc

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

rtl/inc/systemh.inc

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