summaryrefslogtreecommitdiff
path: root/rtl/inc
diff options
context:
space:
mode:
Diffstat (limited to 'rtl/inc')
-rw-r--r--rtl/inc/astrings.inc24
-rw-r--r--rtl/inc/charset.pp37
-rw-r--r--rtl/inc/compproc.inc6
-rw-r--r--rtl/inc/dynarr.inc84
-rw-r--r--rtl/inc/dynarrh.inc8
-rw-r--r--rtl/inc/exeinfo.pp2
-rw-r--r--rtl/inc/fexpand.inc9
-rw-r--r--rtl/inc/file.inc8
-rw-r--r--rtl/inc/generic.inc111
-rw-r--r--rtl/inc/genmath.inc321
-rw-r--r--rtl/inc/innr.inc2
-rw-r--r--rtl/inc/int64.inc13
-rw-r--r--rtl/inc/mathh.inc80
-rw-r--r--rtl/inc/objpash.inc20
-rw-r--r--rtl/inc/rtti.inc16
-rw-r--r--rtl/inc/rttih.inc18
-rw-r--r--rtl/inc/softfpu.pp219
-rw-r--r--rtl/inc/sstrings.inc2
-rw-r--r--rtl/inc/system.fpd2
-rw-r--r--rtl/inc/system.inc27
-rw-r--r--rtl/inc/systemh.inc21
-rw-r--r--rtl/inc/text.inc39
-rw-r--r--rtl/inc/tinyheap.inc544
-rw-r--r--rtl/inc/tnyheaph.inc32
-rw-r--r--rtl/inc/ustringh.inc4
-rw-r--r--rtl/inc/ustrings.inc46
-rw-r--r--rtl/inc/variant.inc5
-rw-r--r--rtl/inc/varianth.inc2
-rw-r--r--rtl/inc/wstringh.inc4
-rw-r--r--rtl/inc/wstrings.inc38
30 files changed, 1296 insertions, 448 deletions
diff --git a/rtl/inc/astrings.inc b/rtl/inc/astrings.inc
index e9fda39988..772d4d7e60 100644
--- a/rtl/inc/astrings.inc
+++ b/rtl/inc/astrings.inc
@@ -1404,20 +1404,36 @@ end;
{$endif FPC_HAS_ANSISTR_OF_CHAR}
-Procedure SetString(Out S : AnsiString; Buf : PAnsiChar; Len : SizeInt); inline;
+{$ifdef FPC_HAS_CPSTRING}
+Procedure fpc_setstring_ansistr_pansichar(out S : RawByteString; Buf : PAnsiChar; Len : SizeInt; cp: TSystemCodePage); rtlproc; compilerproc;
+{$else}
+Procedure SetString(out S : AnsiString; Buf : PAnsiChar; Len : SizeInt);
+{$endif}
begin
SetLength(S,Len);
+{$ifdef FPC_HAS_CPSTRING}
+ SetCodePage(S,cp,false);
+{$endif}
If (Buf<>Nil) then
fpc_pchar_ansistr_intern_charmove(Buf,0,S,0,Len);
end;
-Procedure SetString(Out S : AnsiString; Buf : PWideChar; Len : SizeInt);
+{$ifdef FPC_HAS_CPSTRING}
+Procedure fpc_setstring_ansistr_pwidechar(out S : RawByteString; Buf : PWideChar; Len : SizeInt; cp: TSystemCodePage); rtlproc; compilerproc;
+{$else}
+Procedure SetString(out S : AnsiString; Buf : PWideChar; Len : SizeInt);
+{$endif}
begin
if (Buf<>nil) and (Len>0) then
- widestringmanager.Wide2AnsiMoveProc(Buf,RawByteString(S),DefaultSystemCodePage,Len)
+ widestringmanager.Wide2AnsiMoveProc(Buf,S,{$ifdef FPC_HAS_CPSTRING}cp{$else}DefaultSystemCodePage{$endif},Len)
else
- SetLength(S, Len);
+ begin
+ SetLength(S, Len);
+{$ifdef FPC_HAS_CPSTRING}
+ SetCodePage(S,cp,false);
+{$endif}
+ end;
end;
diff --git a/rtl/inc/charset.pp b/rtl/inc/charset.pp
index b50b313cfc..b3bc902131 100644
--- a/rtl/inc/charset.pp
+++ b/rtl/inc/charset.pp
@@ -73,15 +73,15 @@ unit charset;
) : punicodemap;overload;
procedure registermapping(p : punicodemap);
function registerbinarymapping(const directory,cpname : string):Boolean;
- function getmap(const s : string) : punicodemap;
- function getmap(cp : word) : punicodemap;
+ function getmap(const s : string) : punicodemap;
+ function getmap(cp : word) : punicodemap;
function mappingavailable(const s : string) : boolean;inline;
function mappingavailable(cp :word) : boolean;inline;
function getunicode(c : char;p : punicodemap) : tunicodechar;inline;
function getunicode(
AAnsiStr : pansichar;
AAnsiLen : LongInt;
- AMap : punicodemap;
+ AMap : punicodemap;
ADest : tunicodestring
) : LongInt;
function getascii(c : tunicodechar;p : punicodemap) : string;
@@ -421,10 +421,7 @@ unit charset;
Assign(f,filename);
Reset(f);
if (IOResult<>0) then
- begin
- Close(f);
- exit;
- end;
+ exit;
locSize:=FileSize(f);
if (locSize<SizeOf(TSerializedMapHeader)) then
begin
@@ -624,7 +621,7 @@ unit charset;
function getunicode(
AAnsiStr : pansichar;
AAnsiLen : LongInt;
- AMap : punicodemap;
+ AMap : punicodemap;
ADest : tunicodestring
) : LongInt;
@@ -632,11 +629,11 @@ unit charset;
i, c, k, destLen : longint;
ps : pansichar;
pd : ^tunicodechar;
-
+
begin
if (AAnsiStr=nil) or (AAnsiLen<=0) then
exit(0);
- ps:=AAnsiStr;
+ ps:=AAnsiStr;
if (ADest=nil) then
begin
c:=AAnsiLen-1;
@@ -651,12 +648,12 @@ unit charset;
Inc(ps);
i:=i+1;
end;
- end;
- i:=i+1;
+ end;
+ i:=i+1;
Inc(ps);
destLen:=destLen+1;
- end;
- exit(destLen);
+ end;
+ exit(destLen);
end;
pd:=ADest;
@@ -668,7 +665,7 @@ unit charset;
begin
if (AMap^.map[ord(ps^)].flag=umf_leadbyte) then
begin
- if (i<c) then
+ if (i<c) then
begin
k:=(Ord(ps^)*256);
Inc(ps);
@@ -681,16 +678,16 @@ unit charset;
end
else
pd^:=UNKNOW_CHAR_W;
- end
- else
+ end
+ else
pd^:=AMap^.map[ord(ps^)].unicode
- end
+ end
else
pd^:=UNKNOW_CHAR_W;
- i:=i+1;
+ i:=i+1;
Inc(ps);
Inc(pd);
- end;
+ end;
result:=((PtrUInt(pd)-PtrUInt(ADest)) div SizeOf(tunicodechar));
end;
diff --git a/rtl/inc/compproc.inc b/rtl/inc/compproc.inc
index a2f8db1aa6..5c37f2079b 100644
--- a/rtl/inc/compproc.inc
+++ b/rtl/inc/compproc.inc
@@ -507,7 +507,7 @@ function fpc_variant_to_idispatch(const v : variant) : idispatch;compilerproc;
function fpc_idispatch_to_variant(const i : idispatch) : variant;compilerproc;
procedure fpc_vararray_get(var d : variant;const s : variant;indices : plongint;len : sizeint);compilerproc;
procedure fpc_vararray_put(var d : variant;const s : variant;indices : plongint;len : sizeint);compilerproc;
-procedure fpc_dispinvoke_variant(dest : pvardata;const source : tvardata; calldesc : pcalldesc;params : pointer);compilerproc;
+procedure fpc_dispinvoke_variant(dest : pvardata;var source : tvardata; calldesc : pcalldesc;params : pointer);compilerproc;
{$endif FPC_HAS_FEATURE_VARIANTS}
{$ifdef FPC_HAS_FEATURE_TEXTIO}
@@ -747,7 +747,7 @@ function fpc_longword_to_double(i: longword): double; compilerproc;
function fpc_setjmp(var s : jmp_buf) : {$ifdef CPU16}smallint{$else}longint{$endif}; compilerproc;
procedure fpc_longjmp(var s : jmp_buf; value : {$ifdef CPU16}smallint{$else}longint{$endif}); compilerproc;
-{$ifdef i8086}
+{$ifdef cpui8086}
{ i8086 huge pointer helpers }
function fpc_hugeptr_add_longint(p: HugePointer; n: LongInt): HugePointer; compilerproc;
function fpc_hugeptr_add_longint_normalized(p: HugePointer; n: LongInt): HugePointer; compilerproc;
@@ -765,4 +765,4 @@ function fpc_hugeptr_cmp_normalized_b(p1, p2: HugePointer): Boolean; compilerpro
function fpc_hugeptr_cmp_normalized_be(p1, p2: HugePointer): Boolean; compilerproc;
function fpc_hugeptr_cmp_normalized_a(p1, p2: HugePointer): Boolean; compilerproc;
function fpc_hugeptr_cmp_normalized_ae(p1, p2: HugePointer): Boolean; compilerproc;
-{$endif i8086}
+{$endif cpui8086}
diff --git a/rtl/inc/dynarr.inc b/rtl/inc/dynarr.inc
index 76771c15d1..214fd3b5b8 100644
--- a/rtl/inc/dynarr.inc
+++ b/rtl/inc/dynarr.inc
@@ -30,7 +30,7 @@ type
packed
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
record
- elSize : PtrUInt;
+ elSize : SizeUInt;
elType2 : Pointer;
varType : Longint;
end;
@@ -303,6 +303,88 @@ function fpc_dynarray_copy(psrc : pointer;ti : pointer;
procedure DynArraySetLength(var a: Pointer; typeInfo: Pointer; dimCnt: SizeInt; lengthVec: PSizeInt);
external name 'FPC_DYNARR_SETLENGTH';
+function DynArraySize(a : pointer): tdynarrayindex;
+ external name 'FPC_DYNARRAY_LENGTH';
+
+procedure DynArrayClear(var a: Pointer; typeInfo: Pointer);
+ external name 'FPC_DYNARRAY_CLEAR';
+
+function DynArrayDim(typeInfo: Pointer): Integer;
+ begin
+ result:=0;
+ while (typeInfo <> nil) and (pdynarraytypeinfo(typeInfo)^.kind = tkDynArray) do
+ begin
+ { skip kind and name }
+ typeInfo:=aligntoptr(typeInfo+2+PByte(typeInfo)[1]);
+
+ { element type info}
+ typeInfo:=pdynarraytypedata(typeInfo)^.elType2;
+
+ Inc(result);
+ end;
+ end;
+
+function DynArrayBounds(a: Pointer; typeInfo: Pointer): TBoundArray;
+ var
+ i,dim: sizeint;
+ begin
+ dim:=DynArrayDim(typeInfo);
+ SetLength(result, dim);
+
+ for i:=0 to pred(dim) do
+ if a = nil then
+ exit
+ else
+ begin
+ result[i]:=DynArraySize(a)-1;
+ a:=PPointerArray(a)^[0];
+ end;
+ end;
+
+function IsDynArrayRectangular(a: Pointer; typeInfo: Pointer): Boolean;
+ var
+ i,j: sizeint;
+ dim,count: sizeint;
+ begin
+ dim:=DynArrayDim(typeInfo);
+ for i:=1 to pred(dim) do
+ begin
+ count:=DynArraySize(PPointerArray(a)^[0]);
+
+ for j:=1 to Pred(DynArraySize(a)) do
+ if count<>DynArraySize(PPointerArray(a)^[j]) then
+ exit(false);
+
+ a:=PPointerArray(a)^[0];
+ end;
+ result:=true;
+ end;
+
+function DynArrayIndex(a: Pointer; const indices: array of SizeInt; typeInfo: Pointer): Pointer;
+ var
+ i,h: sizeint;
+ begin
+ h:=High(indices);
+ for i:=0 to h do
+ begin
+ if i<h then
+ a := PPointerArray(a)^[indices[i]];
+
+ { skip kind and name }
+ typeInfo:=(typeInfo+2+PByte(typeInfo)[1]);
+ { element type info}
+ typeInfo:=pdynarraytypedata(typeInfo)^.elType2;
+
+ if typeInfo=nil then
+ exit(nil);
+ end;
+
+ { skip kind and name }
+ typeInfo:=(typeInfo+2+PByte(typeInfo)[1]);
+
+ result:=@(PByte(a)[indices[h]*pdynarraytypedata(typeInfo)^.elSize]);
+ end;
+
{ obsolete but needed for bootstrapping }
procedure fpc_dynarray_decr_ref(var p : pointer;ti : pointer); [Public,Alias:'FPC_DYNARRAY_DECR_REF']; compilerproc;
begin
diff --git a/rtl/inc/dynarrh.inc b/rtl/inc/dynarrh.inc
index c355227d4c..515dd3c3fd 100644
--- a/rtl/inc/dynarrh.inc
+++ b/rtl/inc/dynarrh.inc
@@ -30,4 +30,12 @@ type
end;
procedure DynArraySetLength(var a: Pointer; typeInfo: Pointer; dimCnt: SizeInt; lengthVec: PSizeInt);
+function DynArraySize(a : pointer): tdynarrayindex;
+procedure DynArrayClear(var a: Pointer; typeInfo: Pointer);
+function DynArrayDim(typeInfo: Pointer): Integer;
+function DynArrayBounds(a: Pointer; typeInfo: Pointer): TBoundArray;
+
+function IsDynArrayRectangular(a: Pointer; typeInfo: Pointer): Boolean;
+function DynArrayIndex(a: Pointer; const indices: array of SizeInt; typeInfo: Pointer): Pointer;
+
procedure fpc_dynarray_rangecheck(p : pointer;i : tdynarrayindex); compilerproc;
diff --git a/rtl/inc/exeinfo.pp b/rtl/inc/exeinfo.pp
index 198f3265bf..1dc9b70108 100644
--- a/rtl/inc/exeinfo.pp
+++ b/rtl/inc/exeinfo.pp
@@ -109,7 +109,7 @@ uses
Executable Loaders
****************************************************************************}
-{$if defined(freebsd) or defined(netbsd) or defined (openbsd) or defined(linux) or defined(sunos) or defined(android)}
+{$if defined(freebsd) or defined(netbsd) or defined (openbsd) or defined(linux) or defined(sunos) or defined(android) or defined(dragonfly)}
{$ifdef cpu64}
{$define ELF64}
{$else}
diff --git a/rtl/inc/fexpand.inc b/rtl/inc/fexpand.inc
index 599e47536a..411283d160 100644
--- a/rtl/inc/fexpand.inc
+++ b/rtl/inc/fexpand.inc
@@ -79,6 +79,10 @@ begin
OldInOutRes := InOutRes;
InOutRes := 0;
GetDir (DriveNr, Dir);
+{$IF defined(FPC_FEXPAND_SYSUTILS) and not defined(SYSUTILSUNICODE)}
+ { set the same codepage as used for the strings in fexpand itself }
+ SetCodePage(Dir,DefaultFileSystemCodePage);
+{$ENDIF FPC_FEXPAND_SYSUTILS and not SYSUTILSUNICODE}
InOutRes := OldInOutRes;
end;
@@ -599,7 +603,10 @@ begin
then
Delete (PA,length(PA),1);
{$ENDIF FPC_FEXPAND_DIRSEP_IS_UPDIR}
-
+{$IF defined(FPC_FEXPAND_SYSUTILS) and not defined(SYSUTILSUNICODE)}
+ { return result in expected code page }
+ SetCodePage(Pa,DefaultRTLFileSystemCodePage);
+{$ENDIF FPC_FEXPAND_SYSUTILS and not SYSUTILSUNICODE}
FExpand := Pa;
end;
diff --git a/rtl/inc/file.inc b/rtl/inc/file.inc
index 8b986df03f..464fcd7f36 100644
--- a/rtl/inc/file.inc
+++ b/rtl/inc/file.inc
@@ -441,6 +441,7 @@ Begin
End;
+{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
Procedure Rename(var f : File; const S : UnicodeString);[IOCheck];
{$ifdef FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
var
@@ -471,8 +472,10 @@ Begin
{$endif FPC_ANSI_TEXTFILEREC}
{$endif FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
End;
+{$endif FPC_HAS_FEATURE_WIDESTRINGS}
+{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
Procedure Rename(var f : File;const s : RawByteString);[IOCheck];
var
{$ifdef FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
@@ -517,6 +520,7 @@ Begin
FileRec(f).Name:=fs
{$endif FPC_ANSI_TEXTFILEREC and not FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
End;
+{$endif FPC_HAS_FEATURE_ANSISTRINGS}
Procedure Rename(var f : File;const s : ShortString);[IOCheck];
@@ -542,7 +546,7 @@ Begin
End;
{$else FPC_HAS_FEATURE_ANSISTRINGS}
var
- len: SizeInt
+ len: SizeInt;
Begin
if InOutRes<>0 then
exit;
@@ -551,7 +555,7 @@ Begin
InOutRes:=102;
exit;
end;
- Do_Rename(PFileTextRecChar(@FileRec(f).Name),p,false);
+ Do_Rename(PFileTextRecChar(@FileRec(f).Name),p,false,false);
{ check error code of do_rename }
if InOutRes=0 then
begin
diff --git a/rtl/inc/generic.inc b/rtl/inc/generic.inc
index b146f57404..4774d639e4 100644
--- a/rtl/inc/generic.inc
+++ b/rtl/inc/generic.inc
@@ -1854,45 +1854,35 @@ function SwapEndian(const AValue: Word): Word;{$ifdef SYSTEMINLINE}inline;{$endi
function SwapEndian(const AValue: LongInt): LongInt;
begin
- Result := (AValue shl 24)
- or ((AValue and $0000FF00) shl 8)
- or ((AValue and $00FF0000) shr 8)
- or (AValue shr 24);
+ Result := ((AValue shl 8) and $FF00FF00) or ((AValue shr 8) and $00FF00FF);
+ Result := (Result shl 16) or (Result shr 16);
end;
{$ifndef cpujvm}
function SwapEndian(const AValue: DWord): DWord;
begin
- Result := (AValue shl 24)
- or ((AValue and $0000FF00) shl 8)
- or ((AValue and $00FF0000) shr 8)
- or (AValue shr 24);
+ Result := ((AValue shl 8) and $FF00FF00) or ((AValue shr 8) and $00FF00FF);
+ Result := (Result shl 16) or (Result shr 16);
end;
{$endif}
function SwapEndian(const AValue: Int64): Int64;
begin
- Result := (AValue shl 56)
- or ((AValue and $000000000000FF00) shl 40)
- or ((AValue and $0000000000FF0000) shl 24)
- or ((AValue and $00000000FF000000) shl 8)
- or ((AValue and $000000FF00000000) shr 8)
- or ((AValue and $0000FF0000000000) shr 24)
- or ((AValue and $00FF000000000000) shr 40)
- or (AValue shr 56);
+ Result := ((AValue shl 8) and $FF00FF00FF00FF00) or
+ ((AValue shr 8) and $00FF00FF00FF00FF);
+ Result := ((Result shl 16) and $FFFF0000FFFF0000) or
+ ((Result shr 16) and $0000FFFF0000FFFF);
+ Result := (Result shl 32) or ((Result shr 32));
end;
{$ifndef cpujvm}
function SwapEndian(const AValue: QWord): QWord;
begin
- Result := (AValue shl 56)
- or ((AValue and $000000000000FF00) shl 40)
- or ((AValue and $0000000000FF0000) shl 24)
- or ((AValue and $00000000FF000000) shl 8)
- or ((AValue and $000000FF00000000) shr 8)
- or ((AValue and $0000FF0000000000) shr 24)
- or ((AValue and $00FF000000000000) shr 40)
- or (AValue shr 56);
+ Result := ((AValue shl 8) and $FF00FF00FF00FF00) or
+ ((AValue shr 8) and $00FF00FF00FF00FF);
+ Result := ((Result shl 16) and $FFFF0000FFFF0000) or
+ ((Result shr 16) and $0000FFFF0000FFFF);
+ Result := (Result shl 32) or ((Result shr 32));
end;
{$endif}
{$endif FPC_SYSTEM_HAS_SWAPENDIAN}
@@ -2376,11 +2366,8 @@ function BsrByte(Const AValue: Byte): Byte;
{$ifndef FPC_HAS_INTERNAL_BSF_WORD}
function BsfWord(Const AValue: Word): {$ifdef CPU16}byte{$else}cardinal{$endif};
begin
- result:=$ff;
- if lo(AValue)<>0 then
- result:=BsfByte(lo(AValue))
- else if hi(AValue) <> 0 then
- result:=BsfByte(hi(AValue))+8
+ result:=ord(lo(AValue)=0)*8;
+ result:=result or BsfByte(byte(AValue shr result));
end;
{$endif}
{$endif}
@@ -2389,10 +2376,8 @@ function BsfWord(Const AValue: Word): {$ifdef CPU16}byte{$else}cardinal{$endif};
{$ifndef FPC_HAS_INTERNAL_BSR_WORD}
function BsrWord(Const AValue: Word): {$ifdef CPU16}byte{$else}cardinal{$endif};
begin
- if hi(AValue)<>0 then
- result:=BsrByte(hi(AValue))+8
- else
- result:=BsrByte(lo(AValue))
+ result:=ord(AValue>255)*8;
+ result:=result or BsrByte(byte(AValue shr result));
end;
{$endif}
{$endif}
@@ -2400,37 +2385,47 @@ function BsrWord(Const AValue: Word): {$ifdef CPU16}byte{$else}cardinal{$endif};
{$ifndef FPC_HAS_INTERNAL_BSF_DWORD}
{$ifndef FPC_SYSTEM_HAS_BSF_DWORD}
function BsfDWord(Const AValue : DWord): {$ifdef CPU16}byte{$else}cardinal{$endif};
-begin
- result:=$ff;
- if lo(AValue)<>0 then
- result:=BsfWord(lo(AValue))
- else if hi(AValue) <> 0 then
- result:=BsfWord(hi(AValue))+16
-end;
+ var
+ tmp: DWord;
+ begin
+ result:=ord(lo(AValue)=0)*16;
+ tmp:=AValue shr result;
+ result:=result or (ord((tmp and $FF)=0)*8);
+ tmp:=tmp shr (result and 8);
+ result:=result or BsfByte(byte(tmp));
+ end;
{$endif}
{$endif}
{$ifndef FPC_HAS_INTERNAL_BSR_DWORD}
{$ifndef FPC_SYSTEM_HAS_BSR_DWORD}
function BsrDWord(Const AValue : DWord): {$ifdef CPU16}byte{$else}cardinal{$endif};
-begin
- if hi(AValue)<>0 then
- result:=BsrWord(hi(AValue))+16
- else
- result:=BsrWord(lo(AValue))
-end;
+ var
+ tmp: DWord;
+ begin
+ result:=ord(AValue>$FFFF)*16;
+ tmp:=AValue shr result;
+ result:=result or (ord(tmp>$FF)*8);
+ tmp:=tmp shr (result and 8);
+ result:=result or BsrByte(byte(tmp));
+ end;
{$endif}
{$endif}
{$ifndef FPC_HAS_INTERNAL_BSF_QWORD}
{$ifndef FPC_SYSTEM_HAS_BSF_QWORD}
function BsfQWord(Const AValue : QWord): {$ifdef CPU16}byte{$else}cardinal{$endif};
+ var
+ tmp: DWord;
begin
- result:=$ff;
- if lo(AValue) <> 0 then
- result:=BsfDWord(lo(AValue))
- else if hi(AValue) <> 0 then
- result:=BsfDWord(hi(AValue)) + 32;
+ result:=0;
+ tmp:=lo(AValue);
+ if (tmp=0) then
+ begin
+ tmp:=hi(AValue);
+ result:=32;
+ end;
+ result:=result or BsfDword(tmp);
end;
{$endif}
{$endif}
@@ -2438,11 +2433,17 @@ function BsfQWord(Const AValue : QWord): {$ifdef CPU16}byte{$else}cardinal{$endi
{$ifndef FPC_HAS_INTERNAL_BSR_QWORD}
{$ifndef FPC_SYSTEM_HAS_BSR_QWORD}
function BsrQWord(Const AValue : QWord): {$ifdef CPU16}byte{$else}cardinal{$endif};
+ var
+ tmp: DWord;
begin
- if hi(AValue) <> 0 then
- result:=BsrDWord(hi(AValue)) + 32
- else
- result:=BsrDWord(lo(AValue))
+ result:=32;
+ tmp:=hi(AValue);
+ if (tmp=0) then
+ begin
+ tmp:=lo(AValue);
+ result:=0;
+ end;
+ result:=result or BsrDword(tmp);
end;
{$endif}
{$endif}
diff --git a/rtl/inc/genmath.inc b/rtl/inc/genmath.inc
index 6eac64fd77..88c86bf195 100644
--- a/rtl/inc/genmath.inc
+++ b/rtl/inc/genmath.inc
@@ -90,7 +90,9 @@ const
lossth = 1.073741824e9;
MAXLOG = 8.8029691931113054295988E1; { log(2**127) }
MINLOG = -8.872283911167299960540E1; { log(2**-128) }
-
+ H2_54: double = 18014398509481984.0; {2^54}
+ huge: double = 1e300;
+ one: double = 1.0;
zero: double = 0;
{$if not defined(FPC_SYSTEM_HAS_SIN) or not defined(FPC_SYSTEM_HAS_COS)}
@@ -397,9 +399,6 @@ type
{* ldexp() multiplies x by 2**n. *}
var
i: integer;
- const
- H2_54: double = 18014398509481984.0; {2^54}
- huge: double = 1e300;
begin
i := (float64high(x) and $7ff00000) shr 20;
{if +-INF, NaN, 0 or if e=0 return d}
@@ -1128,9 +1127,7 @@ type
}
function fpc_exp_real(d: ValReal):ValReal;compilerproc;
const
- one: double = 1.0;
halF : array[0..1] of double = (0.5,-0.5);
- huge: double = 1.0e+300;
twom1000: double = 9.33263618503218878990e-302; { 2**-1000=0x01700000,0}
o_threshold: double = 7.09782712893383973096e+02; { 0x40862E42, 0xFEFA39EF }
u_threshold: double = -7.45133219101941108420e+02; { 0xc0874910, 0xD52D3051 }
@@ -1466,7 +1463,7 @@ type
k := 0;
if (hx < $00100000) then { x < 2**-1022 }
begin
- if (((hx and $7fffffff) or lx)=0) then
+ if (((hx and $7fffffff) or longint(lx))=0) then
exit(-two54/zero); { log(+-0)=-inf }
if (hx<0) then
exit((d-d)/zero); { log(-#) = NaN }
@@ -1702,9 +1699,6 @@ type
1.62858201153657823623e-02 { 0x3F90AD3A, 0xE322DA11 }
);
- one: double = 1.0;
- huge: double = 1.0e300;
-
var
w,s1,s2,z: double;
ix,hx,id: longint;
@@ -1927,3 +1921,310 @@ function FPower10(val: Extended; Power: Longint): Extended;
end;
end;
{$endif SUPPORT_EXTENDED}
+
+{$ifdef SUPPORT_EXTENDED}
+function TExtended80Rec.Mantissa : QWord;
+ begin
+ Result:=Frac and $7fffffffffffffff;
+ end;
+
+
+function TExtended80Rec.Fraction : Extended;
+ begin
+ Result:=system.frac(Value);
+ end;
+
+
+function TExtended80Rec.Exponent : Longint;
+ begin
+ Result:=Exp-16383;
+ end;
+
+
+function TExtended80Rec.GetExp : QWord;
+ begin
+ Result:=_Exp and $7fff;
+ end;
+
+
+procedure TExtended80Rec.SetExp(e : QWord);
+ begin
+ _Exp:=(_Exp and $8000) or (e and $7fff);
+ end;
+
+
+function TExtended80Rec.GetSign : Boolean;
+ begin
+ Result:=(_Exp and $8000)<>0;
+ end;
+
+
+procedure TExtended80Rec.SetSign(s : Boolean);
+ begin
+ _Exp:=(_Exp and $7ffff) or (ord(s) shl 15);
+ end;
+
+{
+ Based on information taken from http://en.wikipedia.org/wiki/Extended_precision#x86_Extended_Precision_Format
+}
+function TExtended80Rec.SpecialType : TFloatSpecial;
+ const
+ Denormal : array[boolean] of TFloatSpecial = (fsDenormal,fsNDenormal);
+ begin
+ case Exp of
+ 0:
+ begin
+ if Mantissa=0 then
+ begin
+ if Sign then
+ Result:=fsNZero
+ else
+ Result:=fsZero
+ end
+ else
+ Result:=Denormal[Sign];
+ end;
+ $7fff:
+ case (Frac shr 62) and 3 of
+ 0,1:
+ Result:=fsInvalidOp;
+ 2:
+ begin
+ if (Frac and $3fffffffffffffff)=0 then
+ begin
+ if Sign then
+ Result:=fsNInf
+ else
+ Result:=fsInf;
+ end
+ else
+ Result:=fsNaN;
+ end;
+ 3:
+ Result:=fsNaN;
+ end
+ else
+ begin
+ if (Frac and $8000000000000000)=0 then
+ Result:=fsInvalidOp
+ else
+ begin
+ if Sign then
+ Result:=fsNegative
+ else
+ Result:=fsPositive;
+ end;
+ end;
+ end;
+ end;
+
+{
+procedure TExtended80Rec.BuildUp(const _Sign : Boolean; const _Mantissa : QWord; const Exponent : Longint);
+ begin
+ end;
+}
+{$endif SUPPORT_EXTENDED}
+
+
+{$ifdef SUPPORT_DOUBLE}
+function TDoubleRec.Mantissa : QWord;
+ begin
+ Result:=Data and $fffffffffffff;
+ end;
+
+
+function TDoubleRec.Fraction : ValReal;
+ begin
+ Result:=system.frac(Value);
+ end;
+
+
+function TDoubleRec.Exponent : Longint;
+ begin
+ Result:=Exp-1023;
+ end;
+
+
+function TDoubleRec.GetExp : QWord;
+ begin
+ Result:=(Data and $7ff0000000000000) shr 52;
+ end;
+
+
+procedure TDoubleRec.SetExp(e : QWord);
+ begin
+ Data:=(Data and $800fffffffffffff) or ((e and $7ff) shl 52);
+ end;
+
+
+function TDoubleRec.GetSign : Boolean;
+ begin
+ Result:=(Data and $8000000000000000)<>0;
+ end;
+
+
+procedure TDoubleRec.SetSign(s : Boolean);
+ begin
+ Data:=(Data and $7fffffffffffffff) or (QWord(ord(s)) shl 63);
+ end;
+
+
+function TDoubleRec.GetFrac : QWord;
+ begin
+ Result:=$10000000000000 or Mantissa;
+ end;
+
+
+procedure TDoubleRec.SetFrac(e : QWord);
+ begin
+ Data:=(Data and $7ff0000000000000) or (e and $fffffffffffff);
+ end;
+
+{
+ Based on information taken from http://en.wikipedia.org/wiki/Double_precision#x86_Extended_Precision_Format
+}
+function TDoubleRec.SpecialType : TFloatSpecial;
+ const
+ Denormal : array[boolean] of TFloatSpecial = (fsDenormal,fsNDenormal);
+ begin
+ case Exp of
+ 0:
+ begin
+ if Mantissa=0 then
+ begin
+ if Sign then
+ Result:=fsNZero
+ else
+ Result:=fsZero
+ end
+ else
+ Result:=Denormal[Sign];
+ end;
+ $7ff:
+ if Mantissa=0 then
+ begin
+ if Sign then
+ Result:=fsNInf
+ else
+ Result:=fsInf;
+ end
+ else
+ Result:=fsNaN;
+ else
+ begin
+ if Sign then
+ Result:=fsNegative
+ else
+ Result:=fsPositive;
+ end;
+ end;
+ end;
+
+{
+procedure TDoubleRec.BuildUp(const _Sign : Boolean; const _Mantissa : QWord; const Exponent : Longint);
+ begin
+ end;
+}
+{$endif SUPPORT_DOUBLE}
+
+
+{$ifdef SUPPORT_SINGLE}
+function TSingleRec.Mantissa : QWord;
+ begin
+ Result:=Data and $7fffff;
+ end;
+
+
+function TSingleRec.Fraction : ValReal;
+ begin
+ Result:=system.frac(Value);
+ end;
+
+
+function TSingleRec.Exponent : Longint;
+ begin
+ Result:=Exp-127;
+ end;
+
+
+function TSingleRec.GetExp : QWord;
+ begin
+ Result:=(Data and $7f800000) shr 23;
+ end;
+
+
+procedure TSingleRec.SetExp(e : QWord);
+ begin
+ Data:=(Data and $807fffff) or ((e and $ff) shl 23);
+ end;
+
+
+function TSingleRec.GetSign : Boolean;
+ begin
+ Result:=(Data and $80000000)<>0;
+ end;
+
+
+procedure TSingleRec.SetSign(s : Boolean);
+ begin
+ Data:=(Data and $7fffffff) or (DWord(ord(s)) shl 31);
+ end;
+
+
+function TSingleRec.GetFrac : QWord;
+ begin
+ Result:=$8000000 or Mantissa;
+ end;
+
+
+procedure TSingleRec.SetFrac(e : QWord);
+ begin
+ Data:=(Data and $ff800000) or (e and $7fffff);
+ end;
+
+{
+ Based on information taken from http://en.wikipedia.org/wiki/Single_precision#x86_Extended_Precision_Format
+}
+function TSingleRec.SpecialType : TFloatSpecial;
+ const
+ Denormal : array[boolean] of TFloatSpecial = (fsDenormal,fsNDenormal);
+ begin
+ case Exp of
+ 0:
+ begin
+ if Mantissa=0 then
+ begin
+ if Sign then
+ Result:=fsNZero
+ else
+ Result:=fsZero
+ end
+ else
+ Result:=Denormal[Sign];
+ end;
+ $ff:
+ if Mantissa=0 then
+ begin
+ if Sign then
+ Result:=fsNInf
+ else
+ Result:=fsInf;
+ end
+ else
+ Result:=fsNaN;
+ else
+ begin
+ if Sign then
+ Result:=fsNegative
+ else
+ Result:=fsPositive;
+ end;
+ end;
+ end;
+
+{
+procedure TSingleRec.BuildUp(const _Sign : Boolean; const _Mantissa : QWord; const Exponent : Longint);
+ begin
+ end;
+}
+{$endif SUPPORT_SINGLE}
diff --git a/rtl/inc/innr.inc b/rtl/inc/innr.inc
index aec400c1b3..83d6fbeffd 100644
--- a/rtl/inc/innr.inc
+++ b/rtl/inc/innr.inc
@@ -88,6 +88,8 @@ const
fpc_in_box_x = 77; { managed platforms: wrap in class instance }
fpc_in_unbox_x_y = 78; { manage platforms: extract from class instance }
fpc_in_popcnt_x = 79;
+ fpc_in_aligned_x = 80;
+ fpc_in_setstring_x_y_z = 81;
{ Internal constant functions }
fpc_in_const_sqr = 100;
diff --git a/rtl/inc/int64.inc b/rtl/inc/int64.inc
index 5abd5b4e04..70096ca9ab 100644
--- a/rtl/inc/int64.inc
+++ b/rtl/inc/int64.inc
@@ -122,6 +122,12 @@
shift,lzz,lzn : longint;
begin
+ { Use the usually faster 32-bit division if possible }
+ if (hi(z) = 0) and (hi(n) = 0) then
+ begin
+ fpc_div_qword := Dword(z) div Dword(n);
+ exit;
+ end;
fpc_div_qword:=0;
if n=0 then
HandleErrorAddrFrameInd(200,get_pc_addr,get_frame);
@@ -134,6 +140,7 @@
{ then d is greater than the n }
if lzn>lzz then
exit;
+
shift:=lzz-lzn;
n:=n shl shift;
for shift:=shift downto 0 do
@@ -156,6 +163,12 @@
shift,lzz,lzn : longint;
begin
+ { Use the usually faster 32-bit mod if possible }
+ if (hi(z) = 0) and (hi(n) = 0) then
+ begin
+ fpc_mod_qword := Dword(z) mod Dword(n);
+ exit;
+ end;
fpc_mod_qword:=0;
if n=0 then
HandleErrorAddrFrameInd(200,get_pc_addr,get_frame);
diff --git a/rtl/inc/mathh.inc b/rtl/inc/mathh.inc
index bb079d9982..88f9a20242 100644
--- a/rtl/inc/mathh.inc
+++ b/rtl/inc/mathh.inc
@@ -115,6 +115,86 @@ procedure float_raise(i: TFPUExceptionMask);
operator := (b:real48) e:extended;
{$endif SUPPORT_EXTENDED}
+ type
+ TFloatSpecial = (fsZero,fsNZero,fsDenormal,fsNDenormal,fsPositive,fsNegative,
+ fsInf,fsNInf,fsNaN,fsInvalidOp);
+
+{$ifdef SUPPORT_EXTENDED}
+ TExtended80Rec = packed record
+ private
+ function GetExp : QWord;
+ procedure SetExp(e : QWord);
+ function GetSign : Boolean;
+ procedure SetSign(s : Boolean);
+ public
+ function Mantissa : QWord;
+ function Fraction : Extended;
+ function Exponent : Longint;
+ property Sign : Boolean read GetSign write SetSign;
+ property Exp : QWord read GetExp write SetExp;
+ function SpecialType : TFloatSpecial;
+ // procedure BuildUp(const _Sign : Boolean; const _Mantissa : QWord; const Exponent : Longint);
+ case byte of
+ 0: (Bytes : array[0..9] of Byte);
+ 1: (Words : array[0..4] of Word);
+{$ifdef ENDIAN_LITTLE}
+ 2: (Frac : QWord; _Exp: Word);
+{$else ENDIAN_LITTLE}
+ 2: (_Exp: Word; Frac : QWord);
+{$endif ENDIAN_LITTLE}
+ 3: (Value: Extended);
+ end;
+{$endif SUPPORT_EXTENDED}
+
+{$ifdef SUPPORT_DOUBLE}
+ TDoubleRec = packed record
+ private
+ function GetExp : QWord;
+ procedure SetExp(e : QWord);
+ function GetSign : Boolean;
+ procedure SetSign(s : Boolean);
+ function GetFrac : QWord;
+ procedure SetFrac(e : QWord);
+ public
+ function Mantissa : QWord;
+ function Fraction : ValReal;
+ function Exponent : Longint;
+ property Sign : Boolean read GetSign write SetSign;
+ property Exp : QWord read GetExp write SetExp;
+ property Frac : QWord read Getfrac write SetFrac;
+ function SpecialType : TFloatSpecial;
+ case byte of
+ 0: (Bytes : array[0..7] of Byte);
+ 1: (Words : array[0..3] of Word);
+ 2: (Data : QWord);
+ 3: (Value: Double);
+ end;
+{$endif SUPPORT_DOUBLE}
+
+{$ifdef SUPPORT_SINGLE}
+ TSingleRec = packed record
+ private
+ function GetExp : QWord;
+ procedure SetExp(e : QWord);
+ function GetSign : Boolean;
+ procedure SetSign(s : Boolean);
+ function GetFrac : QWord;
+ procedure SetFrac(e : QWord);
+ public
+ function Mantissa : QWord;
+ function Fraction : ValReal;
+ function Exponent : Longint;
+ property Sign : Boolean read GetSign write SetSign;
+ property Exp : QWord read GetExp write SetExp;
+ property Frac : QWord read Getfrac write SetFrac;
+ function SpecialType : TFloatSpecial;
+ case byte of
+ 0: (Bytes : array[0..3] of Byte);
+ 1: (Words : array[0..1] of Word);
+ 2: (Data : DWord);
+ 3: (Value: Single);
+ end;
+{$endif SUPPORT_SINGLE}
function FMASingle(s1,s2,s3 : single) : single;[internproc:fpc_in_fma_single];
{$ifdef SUPPORT_DOUBLE}
diff --git a/rtl/inc/objpash.inc b/rtl/inc/objpash.inc
index 9eb394404e..4af69c8c49 100644
--- a/rtl/inc/objpash.inc
+++ b/rtl/inc/objpash.inc
@@ -154,10 +154,10 @@
tinterfaceentrytype = (etStandard,
etVirtualMethodResult,
etStaticMethodResult,
- etFieldValue,
+ etFieldValue,
etVirtualMethodClass,
etStaticMethodClass,
- etFieldValueClass
+ etFieldValueClass
);
pinterfaceentry = ^tinterfaceentry;
@@ -376,9 +376,9 @@
vtInteger = 0;
vtBoolean = 1;
vtChar = 2;
-{$ifndef FPUNONE}
+{$ifndef FPUNONE}
vtExtended = 3;
-{$endif}
+{$endif}
vtString = 4;
vtPointer = 5;
vtPChar = 6;
@@ -399,23 +399,23 @@
PVarRec = ^TVarRec;
TVarRec = record
case VType : sizeint of
-{$ifdef ENDIAN_BIG}
+{$ifdef ENDIAN_BIG}
vtInteger : ({$IFDEF CPU64}integerdummy1 : Longint;{$ENDIF CPU64}VInteger: Longint);
vtBoolean : ({$IFDEF CPU64}booldummy : Longint;{$ENDIF CPU64}booldummy1,booldummy2,booldummy3: byte; VBoolean: Boolean);
vtChar : ({$IFDEF CPU64}chardummy : Longint;{$ENDIF CPU64}chardummy1,chardummy2,chardummy3: byte; VChar: Char);
vtWideChar : ({$IFDEF CPU64}widechardummy : Longint;{$ENDIF CPU64}wchardummy1,VWideChar: WideChar);
-{$else ENDIAN_BIG}
+{$else ENDIAN_BIG}
vtInteger : (VInteger: Longint);
vtBoolean : (VBoolean: Boolean);
vtChar : (VChar: Char);
vtWideChar : (VWideChar: WideChar);
-{$endif ENDIAN_BIG}
-{$ifndef FPUNONE}
+{$endif ENDIAN_BIG}
+{$ifndef FPUNONE}
vtExtended : (VExtended: PExtended);
-{$endif}
+{$endif}
vtString : (VString: PShortString);
vtPointer : (VPointer: Pointer);
- vtPChar : (VPChar: PChar);
+ vtPChar : (VPChar: PAnsiChar);
vtObject : (VObject: TObject);
vtClass : (VClass: TClass);
vtPWideChar : (VPWideChar: PWideChar);
diff --git a/rtl/inc/rtti.inc b/rtl/inc/rtti.inc
index fdf3954759..6991b573f2 100644
--- a/rtl/inc/rtti.inc
+++ b/rtl/inc/rtti.inc
@@ -392,3 +392,19 @@ procedure fpc_decref_array(data,typeinfo: pointer; count: SizeInt); [public,alia
int_finalizeArray(data,typeinfo,count);
end;
+procedure InitializeArray(p, typeInfo: Pointer; count: SizeInt);
+ external name 'FPC_INITIALIZE_ARRAY';
+
+procedure FinalizeArray(p, typeInfo: Pointer; count: SizeInt);
+ external name 'FPC_FINALIZE_ARRAY';
+
+procedure CopyArray(dest, source, typeInfo: Pointer; count: SizeInt);
+ var
+ i, size: SizeInt;
+ begin
+ size:=RTTISize(typeInfo);
+ if size>0 then
+ for i:=0 to count-1 do
+ fpc_Copy_internal(source+size*i, dest+size*i, typeInfo);
+ end;
+
diff --git a/rtl/inc/rttih.inc b/rtl/inc/rttih.inc
new file mode 100644
index 0000000000..d092088fc6
--- /dev/null
+++ b/rtl/inc/rttih.inc
@@ -0,0 +1,18 @@
+{
+ This file is part of the Free Pascal run time library.
+ Copyright (c) 1999-2014 by Maciej Izak
+
+ See the file COPYING.FPC, included in this distribution,
+ for details about the copyright.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+procedure InitializeArray(p, typeInfo: Pointer; count: SizeInt);
+procedure FinalizeArray(p, typeInfo: Pointer; count: SizeInt);
+procedure CopyArray(dest, source, typeInfo: Pointer; count: SizeInt);
+
+
diff --git a/rtl/inc/softfpu.pp b/rtl/inc/softfpu.pp
index 3ad877dd9d..d9f23c16c5 100644
--- a/rtl/inc/softfpu.pp
+++ b/rtl/inc/softfpu.pp
@@ -132,15 +132,6 @@ TYPE
2: (dummy : double);
end;
- int64rec = record
- case byte of
- 1: (low,high : bits32);
- // force the record to be aligned like a double
- // else *_to_double will fail for cpus like sparc
- // and avoid expensive unpacking/packing operations
- 2: (dummy : int64);
- end;
-
floatx80 = record
case byte of
1: (low : qword;high : word);
@@ -167,15 +158,6 @@ TYPE
2: (dummy : double);
end;
- int64rec = record
- case byte of
- 1: (high,low : bits32);
- // force the record to be aligned like a double
- // else *_to_double will fail for cpus like sparc
- // and avoid expensive unpacking/packing operations
- 2: (dummy : int64);
-end;
-
floatx80 = record
case byte of
1: (high : word;low : qword);
@@ -604,14 +586,14 @@ end;
function roundAndPackInt32( zSign: flag; absZ : bits64): int32;
var
roundingMode: TFPURoundingMode;
- roundNearestEven: flag;
+ roundNearestEven: boolean;
roundIncrement, roundBits: int8;
z: int32;
begin
roundingMode := softfloat_rounding_mode;
- roundNearestEven := ord( roundingMode = float_round_nearest_even );
+ roundNearestEven := (roundingMode = float_round_nearest_even);
roundIncrement := $40;
- if ( roundNearestEven=0 ) then
+ if not roundNearestEven then
begin
if ( roundingMode = float_round_to_zero ) then
begin
@@ -630,13 +612,13 @@ begin
end;
end;
end;
- roundBits := absZ and $7F;
+ roundBits := lo(absZ) and $7F;
absZ := ( absZ + roundIncrement ) shr 7;
- absZ := absZ and not( ord( ( roundBits xor $40 ) = 0 ) and roundNearestEven );
+ absZ := absZ and not( bits64( ord( ( roundBits xor $40 ) = 0 ) and ord(roundNearestEven) ));
z := absZ;
if ( zSign<>0 ) then
z := - z;
- if ( ( absZ shr 32 ) or ( z and ( ord( z < 0 ) xor zSign ) ) )<>0 then
+ if ( longint(hi( absZ )) or ( z and ( ord( z < 0 ) xor zSign ) ) )<>0 then
begin
float_raise( float_flag_invalid );
if zSign<>0 then
@@ -1341,9 +1323,9 @@ Var
aHigh, aLow, bHigh, bLow: bits16;
z0, zMiddleA, zMiddleB, z1: bits32;
Begin
- aLow := a and $ffff;
+ aLow := bits16(a);
aHigh := a shr 16;
- bLow := b and $ffff;
+ bLow := bits16(b);
bHigh := b shr 16;
z1 := ( bits32( aLow) ) * bLow;
zMiddleA := ( bits32 (aLow) ) * bHigh;
@@ -1620,7 +1602,7 @@ Begin
z := ( z shl 15 );
if ( z <= a ) then
Begin
- estimateSqrt32 := bits32 ( ( sbits32 (a )) shr 1 );
+ estimateSqrt32 := bits32 ( SarLongint( sbits32 (a)) );
exit;
End;
End;
@@ -2335,7 +2317,7 @@ var
Returns the fraction bits of the single-precision floating-point value `a'.
-------------------------------------------------------------------------------
*}
-Function ExtractFloat32Frac(a : Float32) : Bits32;
+Function ExtractFloat32Frac(a : Float32) : Bits32; inline;
Begin
ExtractFloat32Frac := A AND $007FFFFF;
End;
@@ -2345,7 +2327,7 @@ Function ExtractFloat32Frac(a : Float32) : Bits32;
Returns the exponent bits of the single-precision floating-point value `a'.
-------------------------------------------------------------------------------
*}
-Function extractFloat32Exp( a: float32 ): Int16;
+Function extractFloat32Exp( a: float32 ): Int16; inline;
Begin
extractFloat32Exp := (a shr 23) AND $FF;
End;
@@ -2355,7 +2337,7 @@ Function extractFloat32Exp( a: float32 ): Int16;
Returns the sign bit of the single-precision floating-point value `a'.
-------------------------------------------------------------------------------
*}
-Function extractFloat32Sign( a: float32 ): Flag;
+Function extractFloat32Sign( a: float32 ): Flag; inline;
Begin
extractFloat32Sign := a shr 31;
End;
@@ -2390,7 +2372,7 @@ than the desired result exponent whenever `zSig' is a complete, normalized
significand.
-------------------------------------------------------------------------------
*}
-Function packFloat32( zSign: Flag; zExp : Int16; zSig: Bits32 ): Float32;
+Function packFloat32( zSign: Flag; zExp : Int16; zSig: Bits32 ): Float32; inline;
Begin
packFloat32 := ( ( bits32( zSign) ) shl 31 ) + ( ( bits32 (zExp) ) shl 23 )
@@ -2423,19 +2405,14 @@ Binary Floating-Point Arithmetic.
Function roundAndPackFloat32( zSign : Flag; zExp : Int16; zSig : Bits32 ) : float32;
Var
roundingMode : TFPURoundingMode;
- roundNearestEven : Flag;
+ roundNearestEven : boolean;
roundIncrement, roundBits : BYTE;
- IsTiny : Flag;
+ IsTiny : boolean;
Begin
roundingMode := softfloat_rounding_mode;
- if (roundingMode = float_round_nearest_even) then
- Begin
- roundNearestEven := Flag(TRUE);
- end
- else
- roundNearestEven := Flag(FALSE);
+ roundNearestEven := (roundingMode = float_round_nearest_even);
roundIncrement := $40;
- if ( Boolean(roundNearestEven) = FALSE) then
+ if not roundNearestEven then
Begin
if ( roundingMode = float_round_to_zero ) Then
Begin
@@ -2466,23 +2443,22 @@ Function roundAndPackFloat32( zSign : Flag; zExp : Int16; zSig : Bits32 ) : floa
if ( zExp < 0 ) then
Begin
isTiny :=
- flag(( softfloat_detect_tininess = float_tininess_before_rounding )
+ ( softfloat_detect_tininess = float_tininess_before_rounding )
OR ( zExp < -1 )
- OR ( (zSig + roundIncrement) < $80000000 ));
+ OR ( (zSig + roundIncrement) < $80000000 );
shift32RightJamming( zSig, - zExp, zSig );
zExp := 0;
roundBits := zSig AND $7F;
- if ( (isTiny = flag(TRUE)) and (roundBits<>0) ) then
+ if ( isTiny and (roundBits<>0) ) then
float_raise( float_flag_underflow );
End;
End;
if ( roundBits )<> 0 then
set_inexact_flag;
zSig := ( zSig + roundIncrement ) shr 7;
- zSig := zSig AND not bits32( bits32( ( roundBits XOR $40 ) = 0 ) and roundNearestEven );
+ zSig := zSig AND not bits32( bits32( ( roundBits XOR $40 ) = 0 ) and ord(roundNearestEven) );
if ( zSig = 0 ) then zExp := 0;
roundAndPackFloat32 := packFloat32( zSign, zExp, zSig );
- exit;
End;
{*
@@ -2509,7 +2485,7 @@ Returns the most-significant 20 fraction bits of the double-precision
floating-point value `a'.
-------------------------------------------------------------------------------
*}
-Function extractFloat64Frac0(a: float64): bits32;
+Function extractFloat64Frac0(a: float64): bits32; inline;
Begin
extractFloat64Frac0 := a.high and $000FFFFF;
End;
@@ -2520,14 +2496,14 @@ Returns the least-significant 32 fraction bits of the double-precision
floating-point value `a'.
-------------------------------------------------------------------------------
*}
-Function extractFloat64Frac1(a: float64): bits32;
+Function extractFloat64Frac1(a: float64): bits32; inline;
Begin
extractFloat64Frac1 := a.low;
End;
{$define FPC_SYSTEM_HAS_extractFloat64Frac}
-Function extractFloat64Frac(a: float64): bits64;
+Function extractFloat64Frac(a: float64): bits64; inline;
Begin
extractFloat64Frac := bits64(a) and $000FFFFFFFFFFFFF;
End;
@@ -2537,7 +2513,7 @@ Function extractFloat64Frac(a: float64): bits64;
Returns the exponent bits of the double-precision floating-point value `a'.
-------------------------------------------------------------------------------
*}
-Function extractFloat64Exp(a: float64): int16;
+Function extractFloat64Exp(a: float64): int16; inline;
Begin
extractFloat64Exp:= ( a.high shr 20 ) AND $7FF;
End;
@@ -2547,7 +2523,7 @@ Function extractFloat64Exp(a: float64): int16;
Returns the sign bit of the double-precision floating-point value `a'.
-------------------------------------------------------------------------------
*}
-Function extractFloat64Sign(a: float64) : flag;
+Function extractFloat64Sign(a: float64) : flag; inline;
Begin
extractFloat64Sign := a.high shr 31;
End;
@@ -2885,6 +2861,25 @@ Procedure
End;
{*
+----------------------------------------------------------------------------
+Takes an abstract floating-point value having sign `zSign', exponent `zExp',
+and significand `zSig', and returns the proper double-precision floating-
+point value corresponding to the abstract input. This routine is just like
+`roundAndPackFloat64' except that `zSig' does not have to be normalized.
+Bit 63 of `zSig' must be zero, and `zExp' must be 1 less than the ``true''
+floating-point exponent.
+----------------------------------------------------------------------------
+*}
+
+function normalizeRoundAndPackFloat64(zSign: flag; zExp: int16; zSig: bits64): float64;
+ var
+ shiftCount: int8;
+ begin
+ shiftCount := countLeadingZeros64( zSig ) - 1;
+ result := roundAndPackFloat64( zSign, zExp - shiftCount, zSig shl shiftCount);
+ end;
+
+{*
-------------------------------------------------------------------------------
Returns the result of converting the 32-bit two's complement integer `a' to
the single-precision floating-point format. The conversion is performed
@@ -3756,7 +3751,7 @@ Function float32_mul(a: float32rec; b: float32rec ) : float32rec; compilerproc;
float32_mul.float32 := propagateFloat32NaN( a.float32, b.float32 );
exit;
End;
- if ( ( bExp OR bSig ) = 0 ) then
+ if ( ( bits32(bExp) OR bSig ) = 0 ) then
Begin
float_raise( float_flag_invalid );
float32_mul.float32 := float32_default_nan;
@@ -3772,7 +3767,7 @@ Function float32_mul(a: float32rec; b: float32rec ) : float32rec; compilerproc;
float32_mul.float32 := propagateFloat32NaN( a.float32, b.float32 );
exit;
End;
- if ( ( aExp OR aSig ) = 0 ) then
+ if ( ( bits32(aExp) OR aSig ) = 0 ) then
Begin
float_raise( float_flag_invalid );
float32_mul.float32 := float32_default_nan;
@@ -3867,7 +3862,7 @@ Function float32_div(a: float32rec;b: float32rec ): float32rec; compilerproc;
Begin
if ( bSig = 0 ) Then
Begin
- if ( ( aExp OR aSig ) = 0 ) then
+ if ( ( bits32(aExp) OR aSig ) = 0 ) then
Begin
float_raise( float_flag_invalid );
float32_div.float32 := float32_default_nan;
@@ -4065,7 +4060,7 @@ Begin
End;
if ( aSign <> 0) then
Begin
- if ( ( aExp OR aSig ) = 0 ) then
+ if ( ( bits32(aExp) OR aSig ) = 0 ) then
Begin
float32_sqrt := a;
exit;
@@ -4423,7 +4418,7 @@ Var
Begin
if ( aExp < $3FF ) then
Begin
- if ( aExp OR aSig0 OR aSig1 )<>0 then
+ if ( bits32(aExp) OR aSig0 OR aSig1 )<>0 then
Begin
set_inexact_flag;
End;
@@ -5071,7 +5066,7 @@ Begin
propagateFloat64NaN( a, b, result );
exit;
End;
- if ( ( bExp OR bSig0 OR bSig1 ) = 0 ) then goto invalid;
+ if ( ( bits32(bExp) OR bSig0 OR bSig1 ) = 0 ) then goto invalid;
packFloat64( zSign, $7FF, 0, 0, result );
exit;
End;
@@ -5186,7 +5181,7 @@ Begin
Begin
if ( ( bSig0 OR bSig1 ) = 0 ) then
Begin
- if ( ( aExp OR aSig0 OR aSig1 ) = 0 ) then
+ if ( ( bits32(aExp) OR aSig0 OR aSig1 ) = 0 ) then
Begin
invalid:
float_raise( float_flag_invalid );
@@ -5418,7 +5413,7 @@ Begin
End;
if ( aSign <> 0 ) then
Begin
- if ( ( aExp OR aSig0 OR aSig1 ) = 0 ) then
+ if ( ( bits32(aExp) OR aSig0 OR aSig1 ) = 0 ) then
Begin
result := a;
exit;
@@ -5761,7 +5756,6 @@ var
zSign : flag;
absA : uint64;
shiftCount: int8;
- intval : int64rec;
Begin
if ( a = 0 ) then
begin
@@ -5785,14 +5779,7 @@ Begin
begin
shiftCount := shiftCount + 7;
if ( shiftCount < 0 ) then
- begin
- intval.low := int64rec(AbsA).low;
- intval.high := int64rec(AbsA).high;
- shift64RightJamming( intval.high, intval.low, - shiftCount,
- intval.high, intval.low);
- int64rec(absA).low := intval.low;
- int64rec(absA).high := intval.high;
- end
+ shift64RightJamming( absA, - shiftCount, absA )
else
absA := absA shl shiftCount;
int64_to_float32.float32:=roundAndPackFloat32( zSign, $9C - shiftCount, absA );
@@ -5807,38 +5794,28 @@ End;
*----------------------------------------------------------------------------*}
function qword_to_float32( a: qword ): float32rec; compilerproc;
var
- zSign : flag;
absA : uint64;
shiftCount: int8;
- intval : int64rec;
Begin
if ( a = 0 ) then
begin
qword_to_float32.float32 := 0;
exit;
end;
- zSign := flag(FALSE);
absA := a;
shiftCount := countLeadingZeros64( absA ) - 40;
if ( 0 <= shiftCount ) then
begin
- qword_to_float32.float32:= packFloat32( zSign, $95 - shiftCount, absA shl shiftCount );
+ qword_to_float32.float32:= packFloat32( 0, $95 - shiftCount, absA shl shiftCount );
end
else
begin
shiftCount := shiftCount + 7;
if ( shiftCount < 0 ) then
- begin
- intval.low := int64rec(AbsA).low;
- intval.high := int64rec(AbsA).high;
- shift64RightJamming( intval.high, intval.low, - shiftCount,
- intval.high, intval.low);
- int64rec(absA).low := intval.low;
- int64rec(absA).high := intval.high;
- end
+ shift64RightJamming( absA, - shiftCount, absA )
else
absA := absA shl shiftCount;
- qword_to_float32.float32:=roundAndPackFloat32( zSign, $9C - shiftCount, absA );
+ qword_to_float32.float32:=roundAndPackFloat32( 0, $9C - shiftCount, absA );
end;
End;
@@ -5851,33 +5828,25 @@ End;
function qword_to_float64( a: qword ): float64;
{$ifdef fpc}[public,Alias:'QWORD_TO_FLOAT64'];compilerproc;{$endif}
var
- zSign : flag;
- float_result : float64;
- AbsA : bits64;
- shiftcount : int8;
- zSig0, zSig1 : bits32;
+ shiftCount: int8;
Begin
- if ( a = 0 ) then
- Begin
- packFloat64( 0, 0, 0, 0, result );
- exit;
- end;
- zSign := flag(FALSE);
- AbsA := a;
- shiftCount := countLeadingZeros64( absA ) - 11;
- if ( 0 <= shiftCount ) then
- Begin
- absA := absA shl shiftcount;
- zSig0:=int64rec(absA).high;
- zSig1:=int64rec(absA).low;
- End
- else
- Begin
- shift64Right( int64rec(absA).high, int64rec(absA).low,
- - shiftCount, zSig0, zSig1 );
- End;
- packFloat64( zSign, $432 - shiftCount, zSig0, zSig1, float_result );
- qword_to_float64:= float_result;
+ if ( a = 0 ) then
+ result := packFloat64( 0, 0, 0 )
+ else
+ begin
+ shiftCount := countLeadingZeros64(a) - 1;
+ { numbers with <= 53 significant bits are converted exactly }
+ if (shiftCount > 9) then
+ result := packFloat64(0, $43c - shiftCount, a shl (shiftCount-10))
+ else if (shiftCount>=0) then
+ result := roundAndPackFloat64( 0, $43c - shiftCount, a shl shiftCount)
+ else
+ begin
+ { the only possible negative value is -1, in case bit 63 of 'a' is set }
+ shift64RightJamming(a, 1, a);
+ result := roundAndPackFloat64(0, $43d, a);
+ end;
+ end;
End;
@@ -5889,37 +5858,15 @@ End;
*----------------------------------------------------------------------------*}
function int64_to_float64( a: int64 ): float64;
{$ifdef fpc}[public,Alias:'INT64_TO_FLOAT64'];compilerproc;{$endif}
-var
- zSign : flag;
- float_result : float64;
- AbsA : bits64;
- shiftcount : int8;
- zSig0, zSig1 : bits32;
Begin
- if ( a = 0 ) then
- Begin
- packFloat64( 0, 0, 0, 0, result );
- exit;
- end;
- zSign := flag( a < 0 );
- if ZSign<>0 then
- AbsA := -a
- else
- AbsA := a;
- shiftCount := countLeadingZeros64( absA ) - 11;
- if ( 0 <= shiftCount ) then
- Begin
- absA := absA shl shiftcount;
- zSig0:=int64rec(absA).high;
- zSig1:=int64rec(absA).low;
- End
- else
- Begin
- shift64Right( int64rec(absA).high, int64rec(absA).low,
- - shiftCount, zSig0, zSig1 );
- End;
- packFloat64( zSign, $432 - shiftCount, zSig0, zSig1, float_result );
- int64_to_float64:= float_result;
+ if ( a = 0 ) then
+ result := packFloat64( 0, 0, 0 )
+ else if (a = int64($8000000000000000)) then
+ result := packFloat64( 1, $43e, 0 )
+ else if (a < 0) then
+ result := normalizeRoundAndPackFloat64( 1, $43c, -a )
+ else
+ result := normalizeRoundAndPackFloat64( 0, $43c, a );
End;
diff --git a/rtl/inc/sstrings.inc b/rtl/inc/sstrings.inc
index 23dad25481..f16f2c910f 100644
--- a/rtl/inc/sstrings.inc
+++ b/rtl/inc/sstrings.inc
@@ -2080,7 +2080,7 @@ end;
{$ifndef FPC_HAS_SETSTRING_SHORTSTR}
{$define FPC_HAS_SETSTRING_SHORTSTR}
-Procedure SetString (Out S : Shortstring; Buf : PChar; Len : SizeInt);
+Procedure {$ifdef FPC_HAS_CPSTRING}fpc_setstring_shortstr{$else}SetString{$endif}(Out S : Shortstring; Buf : PChar; Len : SizeInt); {$ifdef FPC_HAS_CPSTRING} compilerproc; {$endif FPC_HAS_CPSTRING}
begin
If Len > High(S) then
Len := High(S);
diff --git a/rtl/inc/system.fpd b/rtl/inc/system.fpd
index 7bd5fc3859..dfd8504aeb 100644
--- a/rtl/inc/system.fpd
+++ b/rtl/inc/system.fpd
@@ -19,6 +19,8 @@ Type
Char = #0..#255;
Longint = -2147483648..2147483647;
Longword= 0..4294967295;
+ Int64 = =-9223372036854775808.. 9223372036854775807;
+ QWord = 0..18446744073709551615;
Shortint= -128 .. 127;
Smallint= -32768 .. 32767;
Word = 0 .. 65535;
diff --git a/rtl/inc/system.inc b/rtl/inc/system.inc
index 8f64474bc3..ea7a80d7c0 100644
--- a/rtl/inc/system.inc
+++ b/rtl/inc/system.inc
@@ -352,22 +352,22 @@ End;
Function Swap (X : Longint) : Longint;{$ifdef SYSTEMINLINE}inline;{$endif}
Begin
- Swap:=(X and $ffff) shl 16 + (X shr 16)
+ Swap:=(X shl 16) + (X shr 16);
End;
Function Swap (X : Cardinal) : Cardinal;{$ifdef SYSTEMINLINE}inline;{$endif}
Begin
- Swap:=(X and $ffff) shl 16 + (X shr 16)
+ Swap:=(X shl 16) + (X shr 16);
End;
Function Swap (X : QWord) : QWord;{$ifdef SYSTEMINLINE}inline;{$endif}
Begin
- Swap:=(X and $ffffffff) shl 32 + (X shr 32);
+ Swap:=(X shl 32) + (X shr 32);
End;
-Function swap (X : Int64) : Int64;{$ifdef SYSTEMINLINE}inline;{$endif}
+Function Swap (X : Int64) : Int64;{$ifdef SYSTEMINLINE}inline;{$endif}
Begin
- Swap:=(X and $ffffffff) shl 32 + (X shr 32);
+ Swap:=(X shl 32) + (X shr 32);
End;
{$ifdef SUPPORT_DOUBLE}
@@ -1519,6 +1519,7 @@ begin
end;
+{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
procedure DoDirSeparators(var ps:RawByteString);
var
i : longint;
@@ -1538,7 +1539,10 @@ begin
p[i-1]:=DirectorySeparator;
end;
end;
+{$endif FPC_HAS_FEATURE_ANSISTRINGS}
+
+{$ifdef FPC_HAS_FEATURE_UNICODESTRINGS}
procedure DoDirSeparators(var ps:UnicodeString);
var
i : longint;
@@ -1558,6 +1562,7 @@ begin
p[i-1]:=DirectorySeparator;
end;
end;
+{$endif FPC_HAS_FEATURE_UNICODESTRINGS}
{$endif FPC_HAS_FEATURE_FILEIO}
@@ -1642,8 +1647,20 @@ end;
{$endif FPC_HAS_FEATURE_FILEIO}
+{ helper for targets supporting no ansistrings, it is used
+ by non-ansistring code }
+function min(v1,v2 : SizeInt) : SizeInt;
+ begin
+ if v1<v2 then
+ result:=v1
+ else
+ result:=v2;
+ end;
+
+{$ifdef FPC_HAS_FEATURE_TEXTIO}
{ Text file }
{$i text.inc}
+{$endif FPC_HAS_FEATURE_TEXTIO}
{$ifdef FPC_HAS_FEATURE_FILEIO}
{ Untyped file }
diff --git a/rtl/inc/systemh.inc b/rtl/inc/systemh.inc
index 9cd447fa8c..69b489ad9f 100644
--- a/rtl/inc/systemh.inc
+++ b/rtl/inc/systemh.inc
@@ -20,6 +20,7 @@
{$I-,Q-,H-,R-,V-}
{$mode objfpc}
+{$modeswitch advancedrecords}
{ At least 2.4.0 is required }
{$if defined(VER1) or defined(VER2_0) or defined(VER2_2) }
@@ -412,6 +413,7 @@ Type
AnsiChar = Char;
PAnsiChar = PChar;
PPAnsiChar = PPChar;
+ PPPAnsiChar = PPPChar;
UCS4Char = type 0..$10ffff;
PUCS4Char = ^UCS4Char;
@@ -524,7 +526,8 @@ Type
{ the size of textrec/filerec is hardcoded in the 2.6 compiler binary }
{$define FPC_ANSI_TEXTFILEREC}
{$endif}
- TFileTextRecChar = {$ifdef FPC_ANSI_TEXTFILEREC}AnsiChar{$else}UnicodeChar{$endif};
+
+ TFileTextRecChar = {$if defined(FPC_ANSI_TEXTFILEREC) or not(defined(FPC_HAS_FEATURE_WIDESTRINGS))}AnsiChar{$else}UnicodeChar{$endif};
PFileTextRecChar = ^TFileTextRecChar;
TTextLineBreakStyle = (tlbsLF,tlbsCRLF,tlbsCR);
@@ -1070,10 +1073,16 @@ Function Pos(const substr:shortstring;const s:shortstring):SizeInt;
Function Pos(C:Char;const s:shortstring):SizeInt;
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
Function Pos(const Substr : ShortString; const Source : RawByteString) : SizeInt;
+
+{$ifdef FPC_HAS_CPSTRING}
+Procedure fpc_setstring_ansistr_pansichar(out S : RawByteString; Buf : PAnsiChar; Len : SizeInt; cp: TSystemCodePage); rtlproc; compilerproc;
+Procedure fpc_setstring_ansistr_pwidechar(out S : RawByteString; Buf : PWideChar; Len : SizeInt; cp: TSystemCodePage); rtlproc; compilerproc;
+{$else}
Procedure SetString(out S : AnsiString; Buf : PAnsiChar; Len : SizeInt);
Procedure SetString(out S : AnsiString; Buf : PWideChar; Len : SizeInt);
+{$endif}
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
-Procedure SetString (out S : Shortstring; Buf : PChar; Len : SizeInt);
+Procedure {$ifdef FPC_HAS_CPSTRING}fpc_setstring_shortstr{$else}SetString{$endif}(out S : Shortstring; Buf : PChar; Len : SizeInt); {$ifdef FPC_HAS_CPSTRING} compilerproc; {$endif FPC_HAS_CPSTRING}
function ShortCompareText(const S1, S2: shortstring): SizeInt;
Function upCase(const s:shortstring):shortstring;
Function lowerCase(const s:shortstring):shortstring; overload;
@@ -1469,6 +1478,14 @@ const
{$endif FPC_HAS_FEATURE_VARIANTS}
{*****************************************************************************
+ RTTI support
+*****************************************************************************}
+
+{$ifdef FPC_HAS_FEATURE_RTTI}
+{$i rttih.inc}
+{$endif FPC_HAS_FEATURE_RTTI}
+
+{*****************************************************************************
Internal helper routines support
*****************************************************************************}
diff --git a/rtl/inc/text.inc b/rtl/inc/text.inc
index 75379c70da..fa89f8672c 100644
--- a/rtl/inc/text.inc
+++ b/rtl/inc/text.inc
@@ -200,10 +200,15 @@ Begin
TextRec(t).mode:=mode;
TextRec(t).bufpos:=0;
TextRec(t).bufend:=0;
- {$ifdef FPC_HAS_CPSTRING}
+
+{$ifdef FPC_HAS_CPSTRING}
+{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
{ if no codepage is yet assigned then assign default ansi codepage }
TextRec(t).CodePage:=TranslatePlaceholderCP(TextRec(t).CodePage);
- {$endif}
+{$else FPC_HAS_FEATURE_ANSISTRINGS}
+ TextRec(t).CodePage:=0;
+{$endif FPC_HAS_FEATURE_ANSISTRINGS}
+{$endif FPC_HAS_CPSTRING}
FileFunc(TextRec(t).OpenFunc)(TextRec(t));
{ reset the mode to closed when an error has occured }
if InOutRes<>0 then
@@ -266,6 +271,7 @@ Begin
End;
+{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
Procedure Rename(var t : Text;const s : unicodestring);[IOCheck];
{$ifdef FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
var
@@ -296,8 +302,11 @@ Begin
{$endif FPC_ANSI_TEXTFILEREC}
{$endif FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
End;
+{$endif FPC_HAS_FEATURE_WIDESTRINGS}
+
+{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
Procedure Rename(var t : Text;const s : rawbytestring);[IOCheck];
var
{$ifdef FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
@@ -342,6 +351,7 @@ Begin
TextRec(t).Name:=fs
{$endif FPC_ANSI_TEXTTextRec and not FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
End;
+{$endif FPC_HAS_FEATURE_ANSISTRINGS}
Procedure Rename(var t : Text;const s : ShortString);[IOCheck];
@@ -366,16 +376,16 @@ Begin
End;
{$else FPC_HAS_FEATURE_ANSISTRINGS}
var
- len: SizeInt
+ len: SizeInt;
Begin
if InOutRes<>0 then
exit;
- if TextRec(f).mode<>fmClosed then
+ if TextRec(t).mode<>fmClosed then
begin
InOutRes:=102;
exit;
end;
- Do_Rename(PFileTextRecChar(@TextRec(t).Name),p,false);
+ Do_Rename(PFileTextRecChar(@TextRec(t).Name),p,false,false);
{ check error code of do_rename }
if InOutRes=0 then
begin
@@ -602,16 +612,17 @@ End;
function GetTextCodePage(var T: Text): TSystemCodePage;
begin
-{$ifdef FPC_HAS_CPSTRING}
+{$if defined(FPC_HAS_CPSTRING) and defined(FPC_HAS_FEATURE_ANSISTRINGS)}
GetTextCodePage:=TextRec(T).CodePage;
{$else}
GetTextCodePage:=0;
{$endif}
end;
+
procedure SetTextCodePage(var T: Text; CodePage: TSystemCodePage);
begin
-{$ifdef FPC_HAS_CPSTRING}
+{$if defined(FPC_HAS_CPSTRING) and defined(FPC_HAS_FEATURE_ANSISTRINGS)}
TextRec(T).CodePage:=TranslatePlaceholderCP(CodePage);
{$endif}
end;
@@ -631,7 +642,15 @@ end;
Procedure fpc_textinit_iso(var t : Text;nr : DWord);compilerproc;
begin
+{$ifdef FPC_HAS_FEATURE_COMMANDARGS}
assign(t,paramstr(nr));
+{$else FPC_HAS_FEATURE_COMMANDARGS}
+ { primitive workaround for targets supporting no command line arguments,
+ invent some file name, this will be fixed later on anways because
+ the current way of handling iso program parameters is apparently
+ wrong }
+ assign(t,chr((nr mod 16)+65));
+{$endif FPC_HAS_FEATURE_COMMANDARGS}
reset(t);
end;
@@ -2450,9 +2469,9 @@ begin
t.mode:=fmOutput;
t.OpenFunc:=nil;
t.CloseFunc:=nil;
- {$ifdef FPC_HAS_CPSTRING}
+{$if defined(FPC_HAS_CPSTRING) and defined(FPC_HAS_FEATURE_ANSISTRINGS)}
t.CodePage:=TranslatePlaceholderCP(cp);
- {$endif}
+{$endif}
end;
@@ -2561,7 +2580,7 @@ begin
t.mode:=fmInput;
t.OpenFunc:=nil;
t.CloseFunc:=nil;
- {$ifdef FPC_HAS_CPSTRING}
+{$if defined(FPC_HAS_CPSTRING) and defined(FPC_HAS_FEATURE_ANSISTRINGS)}
t.CodePage:=TranslatePlaceholderCP(cp);
{$endif}
PSizeInt(@t.userdata[BytesReadIndex])^:=0;
diff --git a/rtl/inc/tinyheap.inc b/rtl/inc/tinyheap.inc
index 38fa5421b2..155417b67c 100644
--- a/rtl/inc/tinyheap.inc
+++ b/rtl/inc/tinyheap.inc
@@ -13,74 +13,149 @@
**********************************************************************}
- const
- TinyHeapMinBlock = 4*sizeof(pointer);
+{ The heap, implemented here is TP7-compatible in the i8086 far data memory
+ models. It's basically a linked list of free blocks, which are kept ordered by
+ start address. The FreeList variable points to the start of the list. Each
+ free block, except the last one, contains a TTinyHeapBlock structure, which
+ holds the block size and a pointer to the next free block. The HeapPtr
+ variable points to the last free block, indicating the end of the list. The
+ last block is special in that it doesn't contain a TTinyHeapBlock structure.
+ Instead its size is determined by the pointer difference (HeapEnd-HeapPtr).
+ It *can* become zero sized, when all the memory inside of it is allocated, in
+ which case, HeapPtr will become equal to HeapEnd. }
+
+{$ifdef FPC_TINYHEAP_HUGE}
+ {$HugePointerArithmeticNormalization On}
+ {$HugePointerComparisonNormalization On}
+{$endif FPC_TINYHEAP_HUGE}
type
+ { TTinyHeapMemBlockSize holds the size of an *allocated* memory block,
+ and is written at position:
+ memblockstart-sizeof(TTinyHeapMemBlockSize) }
+ PTinyHeapMemBlockSize = ^TTinyHeapMemBlockSize; {$ifdef FPC_TINYHEAP_HUGE}huge;{$endif}
+ TTinyHeapMemBlockSize = PtrUInt;
+
+ { TTinyHeapFreeBlockSize holds the size of a *free* memory block, as a
+ part of the TTinyHeapBlock structure }
+{$ifdef FPC_TINYHEAP_HUGE}
+ TTinyHeapFreeBlockSize = record
+ OfsSize: Word;
+ SegSize: Word;
+ end;
+{$else FPC_TINYHEAP_HUGE}
+ TTinyHeapFreeBlockSize = PtrUInt;
+{$endif FPC_TINYHEAP_HUGE}
+
+ TTinyHeapPointerArithmeticType = ^Byte; {$ifdef FPC_TINYHEAP_HUGE}huge;{$endif}
+
PTinyHeapBlock = ^TTinyHeapBlock;
TTinyHeapBlock = record
- Size: ptruint;
Next: PTinyHeapBlock;
- EndAddr: pointer;
+ Size: TTinyHeapFreeBlockSize;
end;
- var
- TinyHeapBlocks: PTinyHeapBlock = nil;
+ const
+ TinyHeapMinBlock = sizeof(TTinyHeapBlock);
- procedure InternalTinyFreeMem(Addr: Pointer; Size: ptruint); forward;
+ TinyHeapAllocGranularity = sizeof(TTinyHeapBlock);
- function FindSize(p: pointer): ptruint;
+ function EncodeTinyHeapFreeBlockSize(Size: PtrUInt): TTinyHeapFreeBlockSize; inline;
begin
- FindSize := PPtrUInt(p)[-1];
+{$ifdef FPC_TINYHEAP_HUGE}
+ EncodeTinyHeapFreeBlockSize.OfsSize := Size and 15;
+ EncodeTinyHeapFreeBlockSize.SegSize := Size shr 4;
+{$else FPC_TINYHEAP_HUGE}
+ EncodeTinyHeapFreeBlockSize := Size;
+{$endif FPC_TINYHEAP_HUGE}
+ end;
+
+ function DecodeTinyHeapFreeBlockSize(Size: TTinyHeapFreeBlockSize): PtrUInt; inline;
+ begin
+{$ifdef FPC_TINYHEAP_HUGE}
+ DecodeTinyHeapFreeBlockSize := (PtrUInt(Size.SegSize) shl 4) + Size.OfsSize;
+{$else FPC_TINYHEAP_HUGE}
+ DecodeTinyHeapFreeBlockSize := Size;
+{$endif FPC_TINYHEAP_HUGE}
+ end;
+
+ procedure InternalTinyFreeMem(Addr: Pointer; Size: PtrUInt); forward;
+
+ function FindSize(p: pointer): TTinyHeapMemBlockSize;
+ begin
+ FindSize := PTinyHeapMemBlockSize(p)[-1];
end;
function SysTinyGetMem(Size: ptruint): pointer;
var
- p, prev: PTinyHeapBlock;
+ p, prev, p2: PTinyHeapBlock;
AllocSize, RestSize: ptruint;
begin
{$ifdef DEBUG_TINY_HEAP}
Write('SysTinyGetMem(', Size, ')=');
{$endif DEBUG_TINY_HEAP}
- AllocSize := align(size+sizeof(ptruint), sizeof(pointer));
+ AllocSize := align(size+sizeof(TTinyHeapMemBlockSize), TinyHeapAllocGranularity);
- p := TinyHeapBlocks;
+ p := FreeList;
prev := nil;
- while assigned(p) and (p^.Size < AllocSize) do
+ while (p<>HeapPtr) and (DecodeTinyHeapFreeBlockSize(p^.Size) < AllocSize) do
begin
prev := p;
p := p^.Next;
end;
- if assigned(p) then
+ if p<>HeapPtr then
begin
- result := @pptruint(p)[1];
+ result := @PTinyHeapMemBlockSize(p)[1];
- if p^.Size-AllocSize >= TinyHeapMinBlock then
- RestSize := p^.Size-AllocSize
+ if DecodeTinyHeapFreeBlockSize(p^.Size)-AllocSize >= TinyHeapMinBlock then
+ RestSize := DecodeTinyHeapFreeBlockSize(p^.Size)-AllocSize
else
begin
- AllocSize := p^.Size;
+ AllocSize := DecodeTinyHeapFreeBlockSize(p^.Size);
RestSize := 0;
end;
- if prev = nil then
- TinyHeapBlocks := p^.Next
+ if RestSize > 0 then
+ begin
+ p2 := pointer(TTinyHeapPointerArithmeticType(p)+AllocSize);
+ p2^.Next := p^.Next;
+ p2^.Size := EncodeTinyHeapFreeBlockSize(RestSize);
+ if prev = nil then
+ FreeList := p2
+ else
+ prev^.next := p2;
+ end
else
- prev^.next := p^.next;
-
- pptruint(p)^ := size;
+ begin
+ if prev = nil then
+ FreeList := p^.Next
+ else
+ prev^.next := p^.next;
+ end;
- if RestSize > 0 then
- InternalTinyFreeMem(pointer(ptruint(p)+AllocSize), RestSize);
+ PTinyHeapMemBlockSize(p)^ := size;
end
else
- if ReturnNilIfGrowHeapFails then
- Result := nil
- else
- HandleError(203);
+ begin
+ { p=HeapPtr }
+ if PtrUInt(TTinyHeapPointerArithmeticType(HeapEnd)-TTinyHeapPointerArithmeticType(HeapPtr))<AllocSize then
+ if ReturnNilIfGrowHeapFails then
+ Result := nil
+ else
+ HandleError(203);
+
+ result := @PTinyHeapMemBlockSize(HeapPtr)[1];
+ PTinyHeapMemBlockSize(HeapPtr)^ := size;
+
+ HeapPtr := pointer(TTinyHeapPointerArithmeticType(HeapPtr)+AllocSize);
+ if prev = nil then
+ FreeList := HeapPtr
+ else
+ prev^.next := HeapPtr;
+ end;
{$ifdef DEBUG_TINY_HEAP}
- Writeln(ptruint(Result));
+ Writeln(HexStr(Result));
{$endif DEBUG_TINY_HEAP}
end;
@@ -95,80 +170,52 @@
begin
mem := GetMem(Size+Alignment-1);
memp := align(ptruint(mem), Alignment);
- InternalTinyFreeMem(mem, ptruint(memp)-ptruint(mem));
+ InternalTinyFreeMem(mem, TTinyHeapPointerArithmeticType(memp)-TTinyHeapPointerArithmeticType(mem));
result := pointer(memp);
end;
end;
- procedure InternalTinyFreeMem(Addr: Pointer; Size: ptruint);
- var
- b, p, prev: PTinyHeapBlock;
- concatenated: boolean;
+ procedure InternalTinyFreeMem(Addr: Pointer; Size: PtrUInt);
+ var
+ p, prev: PTinyHeapBlock;
begin
- repeat
- concatenated := false;
- b := addr;
+ p := FreeList;
+ prev := nil;
- b^.Next := TinyHeapBlocks;
- b^.Size := Size;
- b^.EndAddr := pointer(ptruint(addr)+size);
+ while (p<>HeapPtr) and (TTinyHeapPointerArithmeticType(p) < TTinyHeapPointerArithmeticType(Addr)) do
+ begin
+ prev := p;
+ p := p^.Next;
+ end;
- if TinyHeapBlocks = nil then
- TinyHeapBlocks := b
+ { join with previous block? }
+ if assigned(prev) and ((TTinyHeapPointerArithmeticType(prev)+DecodeTinyHeapFreeBlockSize(prev^.Size)) = TTinyHeapPointerArithmeticType(Addr)) then
+ begin
+ Addr:=prev;
+ Size:=DecodeTinyHeapFreeBlockSize(prev^.size)+Size;
+ end
+ else
+ if assigned(prev) then
+ prev^.Next := Addr
else
- begin
- p := TinyHeapBlocks;
- prev := nil;
-
- while assigned(p) do
- begin
- if p^.EndAddr = addr then
- begin
- addr:=p;
- size:=p^.size+size;
- if prev = nil then
- TinyHeapBlocks:=p^.next
- else
- prev^.next:=p^.next;
- concatenated:=true;
- break;
- end
- else if p = b^.EndAddr then
- begin
- size:=p^.size+size;
- if prev = nil then
- TinyHeapBlocks:=p^.next
- else
- prev^.next:=p^.next;
- concatenated:=true;
- break;
- end;
-
- prev := p;
- p := p^.next;
- end;
-
- if not concatenated then
- begin
- p := TinyHeapBlocks;
- prev := nil;
-
- while assigned(p) and (p^.Size < size) do
- begin
- prev := p;
- p := p^.Next;
- end;
-
- if assigned(prev) then
- begin
- b^.Next := p;
- prev^.Next := b;
- end
- else
- TinyHeapBlocks := b;
- end;
- end;
- until not concatenated;
+ FreeList := Addr;
+
+ { join with next block? }
+ if TTinyHeapPointerArithmeticType(p)=(TTinyHeapPointerArithmeticType(Addr)+Size) then
+ begin
+ if p=HeapPtr then
+ HeapPtr:=Addr
+ else
+ begin
+ PTinyHeapBlock(Addr)^.Next:=p^.Next;
+ PTinyHeapBlock(Addr)^.Size:=EncodeTinyHeapFreeBlockSize(Size+DecodeTinyHeapFreeBlockSize(p^.Size));
+ end;
+ end
+ else
+ begin
+ PTinyHeapBlock(Addr)^.Next:=p;
+ PTinyHeapBlock(Addr)^.Size:=EncodeTinyHeapFreeBlockSize(Size);
+ end;
end;
function SysTinyFreeMem(Addr: Pointer): ptruint;
@@ -176,16 +223,19 @@
sz: ptruint;
begin
{$ifdef DEBUG_TINY_HEAP}
- Writeln('SysTinyFreeMem(', ptruint(Addr), ')');
+ Writeln('SysTinyFreeMem(', HexStr(Addr), ')');
{$endif DEBUG_TINY_HEAP}
if addr=nil then
begin
result:=0;
exit;
end;
- sz := Align(FindSize(addr)+SizeOf(ptruint), sizeof(pointer));
+ if (TTinyHeapPointerArithmeticType(addr) < TTinyHeapPointerArithmeticType(HeapOrg)) or
+ (TTinyHeapPointerArithmeticType(addr) >= TTinyHeapPointerArithmeticType(HeapPtr)) then
+ HandleError(204);
+ sz := Align(FindSize(addr)+SizeOf(TTinyHeapMemBlockSize), TinyHeapAllocGranularity);
- InternalTinyFreeMem(@pptruint(addr)[-1], sz);
+ InternalTinyFreeMem(@PTinyHeapMemBlockSize(addr)[-1], sz);
result := sz;
end;
@@ -209,46 +259,300 @@
function SysTinyReAllocMem(var p: pointer; size: ptruint):pointer;
var
- sz: ptruint;
+ oldsize, OldAllocSize, NewAllocSize: ptruint;
+ after_block, before_block, before_before_block: PTinyHeapBlock;
+ after_block_size, before_block_size: PtrUInt;
+ new_after_block: PTinyHeapBlock;
begin
{$ifdef DEBUG_TINY_HEAP}
- Write('SysTinyReAllocMem(', ptruint(p), ',', size, ')=');
+ Write('SysTinyReAllocMem(', HexStr(p), ',', size, ')=');
{$endif DEBUG_TINY_HEAP}
if size=0 then
- result := nil
+ begin
+ SysTinyFreeMem(p);
+ result := nil;
+ p := nil;
+ end
+ else if p=nil then
+ begin
+ result := AllocMem(size);
+ p := result;
+ end
else
- result := AllocMem(size);
- if result <> nil then
begin
- if p <> nil then
+ if (TTinyHeapPointerArithmeticType(p) < TTinyHeapPointerArithmeticType(HeapOrg)) or
+ (TTinyHeapPointerArithmeticType(p) >= TTinyHeapPointerArithmeticType(HeapPtr)) then
+ HandleError(204);
+ oldsize := FindSize(p);
+ OldAllocSize := align(oldsize+sizeof(TTinyHeapMemBlockSize), TinyHeapAllocGranularity);
+ NewAllocSize := align(size+sizeof(TTinyHeapMemBlockSize), TinyHeapAllocGranularity);
+ if OldAllocSize = NewAllocSize then
+ begin
+ { old and new size are the same after alignment, so the memory block is already allocated }
+ { we just need to update the size }
+ PTinyHeapMemBlockSize(p)[-1] := size;
+ if size > oldsize then
+ FillChar((TTinyHeapPointerArithmeticType(p)+oldsize)^, size-oldsize, 0);
+ end
+ else if OldAllocSize > NewAllocSize then
begin
- sz := FindSize(p);
- if sz > size then
- sz := size;
- move(pbyte(p)^, pbyte(result)^, sz);
+ { we're decreasing the memory block size, so we can just free the remaining memory at the end }
+ PTinyHeapMemBlockSize(p)[-1] := size;
+ InternalTinyFreeMem(Pointer(TTinyHeapPointerArithmeticType(p)+(NewAllocSize-PtrUInt(SizeOf(TTinyHeapMemBlockSize)))), OldAllocSize-NewAllocSize);
+ end
+ else
+ begin
+ { we're increasing the memory block size. First, find if there are free memory blocks immediately
+ before and after our memory block. }
+ after_block := FreeList;
+ before_block := nil;
+ before_before_block := nil;
+ while (after_block<>HeapPtr) and (TTinyHeapPointerArithmeticType(after_block) < TTinyHeapPointerArithmeticType(p)) do
+ begin
+ before_before_block := before_block;
+ before_block := after_block;
+ after_block := after_block^.Next;
+ end;
+ { is after_block immediately after our block? }
+ if after_block=Pointer(TTinyHeapPointerArithmeticType(p)+(OldAllocSize-PtrUInt(SizeOf(TTinyHeapMemBlockSize)))) then
+ begin
+ if after_block = HeapPtr then
+ after_block_size := PtrUInt(TTinyHeapPointerArithmeticType(HeapEnd)-TTinyHeapPointerArithmeticType(HeapPtr))
+ else
+ after_block_size := DecodeTinyHeapFreeBlockSize(after_block^.size);
+ end
+ else
+ after_block_size := 0;
+ { is there enough room after the block? }
+ if (OldAllocSize+after_block_size)>=NewAllocSize then
+ begin
+ if after_block = HeapPtr then
+ begin
+ HeapPtr:=Pointer(TTinyHeapPointerArithmeticType(HeapPtr)+(NewAllocSize-OldAllocSize));
+ if assigned(before_block) then
+ before_block^.Next := HeapPtr
+ else
+ FreeList := HeapPtr;
+ end
+ else
+ begin
+ if (NewAllocSize-OldAllocSize)=after_block_size then
+ begin
+ if assigned(before_block) then
+ before_block^.Next := after_block^.Next
+ else
+ FreeList := after_block^.Next;
+ end
+ else
+ begin
+ new_after_block := PTinyHeapBlock(TTinyHeapPointerArithmeticType(after_block)+(NewAllocSize-OldAllocSize));
+ new_after_block^.Next:=after_block^.Next;
+ new_after_block^.Size:=EncodeTinyHeapFreeBlockSize(after_block_size-(NewAllocSize-OldAllocSize));
+ if assigned(before_block) then
+ before_block^.Next := new_after_block
+ else
+ FreeList := new_after_block;
+ end;
+ end;
+ PTinyHeapMemBlockSize(p)[-1] := size;
+ FillChar((TTinyHeapPointerArithmeticType(p)+oldsize)^, size-oldsize, 0);
+ end
+ else
+ begin
+ { is before_block immediately before our block? }
+ if assigned(before_block) and (Pointer(TTinyHeapPointerArithmeticType(before_block)+DecodeTinyHeapFreeBlockSize(before_block^.Size))=Pointer(TTinyHeapPointerArithmeticType(p)-SizeOf(TTinyHeapMemBlockSize))) then
+ before_block_size := DecodeTinyHeapFreeBlockSize(before_block^.Size)
+ else
+ before_block_size := 0;
+
+ { if there's enough space, we can slide our current block back and reclaim before_block }
+ if (before_block_size<NewAllocSize) and ((before_block_size+OldAllocSize+after_block_size)>=NewAllocSize) and
+ { todo: implement this also for after_block_size>0 }
+ (after_block_size>0) then
+ begin
+ if (before_block_size+OldAllocSize+after_block_size)=NewAllocSize then
+ begin
+ if after_block=HeapPtr then
+ begin
+ HeapPtr := HeapEnd;
+ if assigned(before_before_block) then
+ before_before_block^.Next := HeapPtr
+ else
+ FreeList := HeapPtr;
+ end
+ else
+ if assigned(before_before_block) then
+ before_before_block^.Next := after_block^.Next
+ else
+ FreeList := after_block^.Next;
+ end;
+ Result := Pointer(TTinyHeapPointerArithmeticType(before_block)+SizeOf(TTinyHeapMemBlockSize));
+ Move(p^, Result^, oldsize);
+ PTinyHeapMemBlockSize(before_block)^ := size;
+ if (before_block_size+OldAllocSize+after_block_size)>NewAllocSize then
+ begin
+ new_after_block := PTinyHeapBlock(TTinyHeapPointerArithmeticType(before_block)+NewAllocSize);
+ new_after_block^.Next:=after_block^.Next;
+ new_after_block^.Size:=EncodeTinyHeapFreeBlockSize(before_block_size+after_block_size-(NewAllocSize-OldAllocSize));
+ if assigned(before_before_block) then
+ before_before_block^.Next := new_after_block
+ else
+ FreeList := new_after_block;
+ end;
+ FillChar((TTinyHeapPointerArithmeticType(Result)+oldsize)^, size-oldsize, 0);
+ p := Result;
+ end
+ else
+ begin
+ result := AllocMem(size);
+ if result <> nil then
+ begin
+ if oldsize > size then
+ oldsize := size;
+ move(pbyte(p)^, pbyte(result)^, oldsize);
+ end;
+ SysTinyFreeMem(p);
+ p := result;
+ end;
+ end;
end;
end;
- SysTinyFreeMem(p);
- p := result;
{$ifdef DEBUG_TINY_HEAP}
- Writeln(ptruint(result));
+ Writeln(HexStr(result));
+{$endif DEBUG_TINY_HEAP}
+ end;
+
+ function MemAvail: {$ifdef FPC_TINYHEAP_HUGE}LongInt{$else}PtrUInt{$endif};
+ var
+ p: PTinyHeapBlock;
+ begin
+ MemAvail := PtrUInt(TTinyHeapPointerArithmeticType(HeapEnd)-TTinyHeapPointerArithmeticType(HeapPtr));
+ if MemAvail > 0 then
+ Dec(MemAvail, SizeOf(TTinyHeapMemBlockSize));
+
+ p := FreeList;
+ while p <> HeapPtr do
+ begin
+ Inc(MemAvail, DecodeTinyHeapFreeBlockSize(p^.Size)-SizeOf(TTinyHeapMemBlockSize));
+ p := p^.Next;
+ end;
+ end;
+
+ function MaxAvail: {$ifdef FPC_TINYHEAP_HUGE}LongInt{$else}PtrUInt{$endif};
+ var
+ p: PTinyHeapBlock;
+ begin
+ MaxAvail := PtrUInt(TTinyHeapPointerArithmeticType(HeapEnd)-TTinyHeapPointerArithmeticType(HeapPtr));
+
+ p := FreeList;
+ while p <> HeapPtr do
+ begin
+ if DecodeTinyHeapFreeBlockSize(p^.Size) > MaxAvail then
+ MaxAvail := DecodeTinyHeapFreeBlockSize(p^.Size);
+ p := p^.Next;
+ end;
+
+ if MaxAvail > 0 then
+ Dec(MaxAvail, SizeOf(TTinyHeapMemBlockSize));
+ end;
+
+ procedure Mark(var p: Pointer);
+ begin
+ p := HeapPtr;
+ end;
+
+ procedure Release(var p: Pointer);
+ begin
+ HeapPtr := p;
+ FreeList := p;
+ end;
+
+ procedure InternalTinyAlign(var AAddress: Pointer; ASize: PtrUInt);
+ var
+ alignment_inc: smallint;
+ begin
+ alignment_inc := TTinyHeapPointerArithmeticType(align(AAddress,TinyHeapAllocGranularity))-TTinyHeapPointerArithmeticType(AAddress);
+ Inc(AAddress,alignment_inc);
+ Dec(ASize,alignment_inc);
+ Dec(ASize,ASize mod TinyHeapAllocGranularity);
+ end;
+
+ { Strongly simplified version of RegisterTinyHeapBlock, which can be used when
+ the heap is only a single contiguous memory block. If you want to add
+ multiple blocks to the heap, you should use RegisterTinyHeapBlock instead. }
+ procedure RegisterTinyHeapBlock_Simple(AAddress: Pointer; ASize: PtrUInt);
+ begin
+{$ifdef DEBUG_TINY_HEAP}
+ Writeln('RegisterTinyHeapBlock_Simple(', HexStr(AAddress), ',', ASize, ')');
+{$endif DEBUG_TINY_HEAP}
+ InternalTinyAlign(AAddress, ASize);
+ HeapOrg:=AAddress;
+ HeapPtr:=AAddress;
+ FreeList:=AAddress;
+ HeapEnd:=Pointer(TTinyHeapPointerArithmeticType(AAddress)+ASize);
+ end;
+
+ { Strongly simplified version of RegisterTinyHeapBlock, which can be used when
+ the heap is only a single contiguous memory block and the address and size
+ are already aligned on a TinyHeapAllocGranularity boundary. }
+ procedure RegisterTinyHeapBlock_Simple_Prealigned(AAddress: Pointer; ASize: PtrUInt);
+ begin
+{$ifdef DEBUG_TINY_HEAP}
+ Writeln('RegisterTinyHeapBlock_Simple_Prealigned(', HexStr(AAddress), ',', ASize, ')');
{$endif DEBUG_TINY_HEAP}
+ HeapOrg:=AAddress;
+ HeapPtr:=AAddress;
+ FreeList:=AAddress;
+ HeapEnd:=Pointer(TTinyHeapPointerArithmeticType(AAddress)+ASize);
end;
procedure RegisterTinyHeapBlock(AAddress: pointer; ASize: ptruint);
+ var
+ alignment_inc: smallint;
+ p: PTinyHeapBlock;
begin
{$ifdef DEBUG_TINY_HEAP}
- Writeln('RegisterTinyHeapBlock(', ptruint(AAddress), ',', ASize, ')');
+ Writeln('RegisterTinyHeapBlock(', HexStr(AAddress), ',', ASize, ')');
{$endif DEBUG_TINY_HEAP}
- if (ptruint(AAddress) and 1) <> 0 then
+ InternalTinyAlign(AAddress, ASize);
+ if HeapOrg=nil then
+ begin
+ HeapOrg:=AAddress;
+ HeapPtr:=AAddress;
+ FreeList:=AAddress;
+ HeapEnd:=Pointer(TTinyHeapPointerArithmeticType(AAddress)+ASize);
+ end
+ else
begin
- Inc(AAddress);
- Dec(ASize);
+ if (TTinyHeapPointerArithmeticType(HeapOrg) > TTinyHeapPointerArithmeticType(AAddress)) then
+ HeapOrg:=AAddress;
+ if TTinyHeapPointerArithmeticType(AAddress) > TTinyHeapPointerArithmeticType(HeapEnd) then
+ begin
+ if TTinyHeapPointerArithmeticType(HeapPtr) = TTinyHeapPointerArithmeticType(HeapEnd) then
+ begin
+ if FreeList=HeapPtr then
+ FreeList:=AAddress
+ else
+ begin
+ p:=FreeList;
+ while p^.Next<>HeapPtr do
+ p:=p^.Next;
+ PTinyHeapBlock(HeapPtr)^.Next:=AAddress;
+ end;
+ end
+ else
+ begin
+ PTinyHeapBlock(HeapPtr)^.Size:=EncodeTinyHeapFreeBlockSize(TTinyHeapPointerArithmeticType(HeapEnd)-TTinyHeapPointerArithmeticType(HeapPtr));
+ PTinyHeapBlock(HeapPtr)^.Next:=AAddress;
+ end;
+ HeapPtr:=AAddress;
+ HeapEnd:=Pointer(TTinyHeapPointerArithmeticType(AAddress)+ASize);
+ end
+ else if TTinyHeapPointerArithmeticType(AAddress) = TTinyHeapPointerArithmeticType(HeapEnd) then
+ HeapEnd:=Pointer(TTinyHeapPointerArithmeticType(AAddress)+ASize)
+ else
+ InternalTinyFreeMem(AAddress, ASize);
end;
- if (ASize and 1) <> 0 then
- Dec(ASize);
- pptruint(AAddress)^ := ASize - SizeOf(ptruint);
- FreeMem(pptruint(AAddress) + 1, ASize - SizeOf(ptruint));
end;
const
diff --git a/rtl/inc/tnyheaph.inc b/rtl/inc/tnyheaph.inc
new file mode 100644
index 0000000000..a7f1a37f8a
--- /dev/null
+++ b/rtl/inc/tnyheaph.inc
@@ -0,0 +1,32 @@
+{
+ This file is part of the Free Pascal run time library.
+ Copyright (c) 2014 by the Free Pascal development team.
+
+ Tiny heap manager for the i8086 near heap, embedded targets, etc.
+
+ See the file COPYING.FPC, included in this distribution,
+ for details about the copyright.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+{$ifdef cpui8086}
+ {$if defined(FPC_X86_DATA_FAR) or defined(FPC_X86_DATA_HUGE)}
+ {$define FPC_TINYHEAP_HUGE}
+ {$endif}
+{$endif cpui8086}
+
+ var
+ { these vars are TP7-compatible }
+ HeapOrg: Pointer = nil; { start of heap }
+ HeapEnd: Pointer = nil; { end of heap }
+ FreeList: Pointer = nil; { pointer to the first free block }
+ HeapPtr: Pointer = nil; { pointer to the last free block }
+
+ function MemAvail: {$ifdef FPC_TINYHEAP_HUGE}LongInt{$else}PtrUInt{$endif};
+ function MaxAvail: {$ifdef FPC_TINYHEAP_HUGE}LongInt{$else}PtrUInt{$endif};
+ procedure Mark(var p: Pointer);
+ procedure Release(var p: Pointer);
diff --git a/rtl/inc/ustringh.inc b/rtl/inc/ustringh.inc
index 5fdf8a4380..c856cd0078 100644
--- a/rtl/inc/ustringh.inc
+++ b/rtl/inc/ustringh.inc
@@ -30,8 +30,8 @@ Function LowerCase(c:UnicodeChar):UnicodeChar;
Procedure Insert (Const Source : UnicodeString; Var S : UnicodeString; Index : SizeInt);
Procedure Delete (Var S : UnicodeString; Index,Size: SizeInt);
-Procedure SetString (Out S : UnicodeString; Buf : PUnicodeChar; Len : SizeInt);
-Procedure SetString (Out S : UnicodeString; Buf : PChar; Len : SizeInt);
+Procedure {$ifdef FPC_HAS_CPSTRING}fpc_setstring_unicodestr_pwidechar{$else}SetString{$endif}(Out S : UnicodeString; Buf : PUnicodeChar; Len : SizeInt); {$ifdef FPC_HAS_CPSTRING} compilerproc; {$endif FPC_HAS_CPSTRING}
+Procedure {$ifdef FPC_HAS_CPSTRING}fpc_setstring_unicodestr_pansichar{$else}SetString{$endif}(Out S : UnicodeString; Buf : PChar; Len : SizeInt); {$ifdef FPC_HAS_CPSTRING} compilerproc; {$endif FPC_HAS_CPSTRING}
function WideCharToString(S : PWideChar) : UnicodeString;
function StringToWideChar(const Src : RawByteString;Dest : PWideChar;DestSize : SizeInt) : PWideChar;
diff --git a/rtl/inc/ustrings.inc b/rtl/inc/ustrings.inc
index c5c52b2f4d..09ea7dd0df 100644
--- a/rtl/inc/ustrings.inc
+++ b/rtl/inc/ustrings.inc
@@ -817,7 +817,7 @@ begin
len := length(src);
{ make sure we don't dereference src if it can be nil (JM) }
if len > 0 then
- widestringmanager.ansi2widemoveproc(pchar(@src[1]),StringCodePage(src),temp,len);
+ widestringmanager.ansi2widemoveproc(pchar(@src[1]),TranslatePlaceholderCP(StringCodePage(src)),temp,len);
len := length(temp);
if len > length(res) then
len := length(res);
@@ -1351,7 +1351,7 @@ end;
{$ifndef FPC_HAS_SETSTRING_UNICODESTR_PUNICODECHAR}
{$define FPC_HAS_SETSTRING_UNICODESTR_PUNICODECHAR}
-Procedure SetString (Out S : UnicodeString; Buf : PUnicodeChar; Len : SizeInt);
+Procedure {$ifdef FPC_HAS_CPSTRING}fpc_setstring_unicodestr_pwidechar{$else}SetString{$endif}(Out S : UnicodeString; Buf : PUnicodeChar; Len : SizeInt); {$ifdef FPC_HAS_CPSTRING} compilerproc; {$endif FPC_HAS_CPSTRING}
begin
SetLength(S,Len);
If (Buf<>Nil) and (Len>0) then
@@ -1362,7 +1362,7 @@ end;
{$ifndef FPC_HAS_SETSTRING_UNICODESTR_PCHAR}
{$define FPC_HAS_SETSTRING_UNICODESTR_PCHAR}
-Procedure SetString (Out S : UnicodeString; Buf : PChar; Len : SizeInt);
+Procedure {$ifdef FPC_HAS_CPSTRING}fpc_setstring_unicodestr_pansichar{$else}SetString{$endif}(Out S : UnicodeString; Buf : PChar; Len : SizeInt); {$ifdef FPC_HAS_CPSTRING} compilerproc; {$endif FPC_HAS_CPSTRING}
begin
If (Buf<>Nil) and (Len>0) then
widestringmanager.Ansi2UnicodeMoveProc(Buf,DefaultSystemCodePage,S,Len)
@@ -2286,19 +2286,22 @@ function StringCodePage(const S: UnicodeString): TSystemCodePage; overload;
{$warnings off}
-function GenericUnicodeCase(const s : UnicodeString) : UnicodeString;
+function StubUnicodeCase(const s : UnicodeString) : UnicodeString;
begin
unimplementedunicodestring;
end;
-
-function CompareUnicodeString(const s1, s2 : UnicodeString) : PtrInt;
+function StubCompareUnicodeString(const s1, s2 : UnicodeString) : PtrInt;
begin
unimplementedunicodestring;
end;
+function StubWideCase(const s: WideString): WideString;
+ begin
+ unimplementedunicodestring;
+ end;
-function CompareTextUnicodeString(const s1, s2 : UnicodeString): PtrInt;
+function StubCompareWideString(const s1, s2 : WideString) : PtrInt;
begin
unimplementedunicodestring;
end;
@@ -2307,24 +2310,23 @@ function CompareTextUnicodeString(const s1, s2 : UnicodeString): PtrInt;
procedure initunicodestringmanager;
begin
{$ifndef HAS_WIDESTRINGMANAGER}
- widestringmanager.Unicode2AnsiMoveProc:=@DefaultUnicode2AnsiMove;
- widestringmanager.Ansi2UnicodeMoveProc:=@DefaultAnsi2UnicodeMove;
- widestringmanager.UpperUnicodeStringProc:=@GenericUnicodeCase;
- widestringmanager.LowerUnicodeStringProc:=@GenericUnicodeCase;
-{$endif HAS_WIDESTRINGMANAGER}
- widestringmanager.CompareUnicodeStringProc:=@CompareUnicodeString;
- widestringmanager.CompareTextUnicodeStringProc:=@CompareTextUnicodeString;
-
{$ifdef FPC_WIDESTRING_EQUAL_UNICODESTRING}
-{$ifndef HAS_WIDESTRINGMANAGER}
- widestringmanager.Wide2AnsiMoveProc:=@defaultUnicode2AnsiMove;
widestringmanager.Ansi2WideMoveProc:=@defaultAnsi2UnicodeMove;
- widestringmanager.UpperWideStringProc:=@GenericUnicodeCase;
- widestringmanager.LowerWideStringProc:=@GenericUnicodeCase;
-{$endif HAS_WIDESTRINGMANAGER}
- widestringmanager.CompareWideStringProc:=@CompareUnicodeString;
- widestringmanager.CompareTextWideStringProc:=@CompareTextUnicodeString;
+{$else FPC_WIDESTRING_EQUAL_UNICODESTRING}
+ widestringmanager.Ansi2WideMoveProc:=@DefaultAnsi2WideMove;
{$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
+ widestringmanager.Wide2AnsiMoveProc:=@DefaultUnicode2AnsiMove;
+ widestringmanager.UpperWideStringProc:=@StubWideCase;
+ widestringmanager.LowerWideStringProc:=@StubWideCase;
+ widestringmanager.Unicode2AnsiMoveProc:=@DefaultUnicode2AnsiMove;
+ widestringmanager.Ansi2UnicodeMoveProc:=@DefaultAnsi2UnicodeMove;
+ widestringmanager.UpperUnicodeStringProc:=@StubUnicodeCase;
+ widestringmanager.LowerUnicodeStringProc:=@StubUnicodeCase;
+{$endif HAS_WIDESTRINGMANAGER}
+ widestringmanager.CompareWideStringProc:=@StubCompareWideString;
+ widestringmanager.CompareTextWideStringProc:=@StubCompareWideString;
+ widestringmanager.CompareUnicodeStringProc:=@StubCompareUnicodeString;
+ widestringmanager.CompareTextUnicodeStringProc:=@StubCompareUnicodeString;
widestringmanager.CharLengthPCharProc:=@DefaultCharLengthPChar;
widestringmanager.CodePointLengthProc:=@DefaultCodePointLength;
widestringmanager.GetStandardCodePageProc:=@DefaultGetStandardCodePage;
diff --git a/rtl/inc/variant.inc b/rtl/inc/variant.inc
index 440fe80bc5..d39eaf1437 100644
--- a/rtl/inc/variant.inc
+++ b/rtl/inc/variant.inc
@@ -142,7 +142,7 @@ function fpc_idispatch_to_variant(const i : idispatch) : variant;compilerproc;
end;
-procedure fpc_dispinvoke_variant(dest : pvardata;const source : tvardata;
+procedure fpc_dispinvoke_variant(dest : pvardata;var source : tvardata;
calldesc : pcalldesc;params : pointer); compilerproc;
begin
variantmanager.dispinvoke(dest,source,calldesc,params);
@@ -1093,9 +1093,6 @@ begin
VariantManager:=VarMgr;
end;
-procedure initvariantmanager;
- begin
- end;
Function Pos (c : Char; Const v : Variant) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
diff --git a/rtl/inc/varianth.inc b/rtl/inc/varianth.inc
index 4eda494522..336a6ee149 100644
--- a/rtl/inc/varianth.inc
+++ b/rtl/inc/varianth.inc
@@ -204,7 +204,7 @@ type
varcast : procedure(var dest : variant;const source : variant;vartype : longint);
varcastole : procedure(var dest : variant; const source : variant;vartype : longint);
- dispinvoke: procedure(dest : pvardata;const source : tvardata;
+ dispinvoke: procedure(dest : pvardata;var source : tvardata;
calldesc : pcalldesc;params : pointer);cdecl;
vararrayredim : procedure(var a : variant;highbound : SizeInt);
diff --git a/rtl/inc/wstringh.inc b/rtl/inc/wstringh.inc
index 57ca32a987..fde3bf756a 100644
--- a/rtl/inc/wstringh.inc
+++ b/rtl/inc/wstringh.inc
@@ -28,8 +28,8 @@ Function UpCase(const s : WideString) : WideString;
Procedure Insert (Const Source : WideString; Var S : WideString; Index : SizeInt);
Procedure Delete (Var S : WideString; Index,Size: SizeInt);
-Procedure SetString (Out S : WideString; Buf : PWideChar; Len : SizeInt);
-Procedure SetString (Out S : WideString; Buf : PChar; Len : SizeInt);
+Procedure {$ifdef FPC_HAS_CPSTRING}fpc_setstring_widestr_pwidechar{$else}SetString{$endif}(Out S : WideString; Buf : PWideChar; Len : SizeInt); {$ifdef FPC_HAS_CPSTRING} compilerproc; {$endif FPC_HAS_CPSTRING}
+Procedure {$ifdef FPC_HAS_CPSTRING}fpc_setstring_widestr_pansichar{$else}SetString{$endif}(Out S : WideString; Buf : PChar; Len : SizeInt); {$ifdef FPC_HAS_CPSTRING} compilerproc; {$endif FPC_HAS_CPSTRING}
procedure DefaultAnsi2WideMove(source:pchar;cp : TSystemCodePage;var dest:widestring;len:SizeInt);
diff --git a/rtl/inc/wstrings.inc b/rtl/inc/wstrings.inc
index 403b8c9552..1a366db4cd 100644
--- a/rtl/inc/wstrings.inc
+++ b/rtl/inc/wstrings.inc
@@ -723,7 +723,7 @@ begin
end;
-Procedure SetString (Out S : WideString; Buf : PWideChar; Len : SizeInt);
+Procedure {$ifdef FPC_HAS_CPSTRING}fpc_setstring_widestr_pwidechar{$else}SetString{$endif}(Out S : WideString; Buf : PWideChar; Len : SizeInt); {$ifdef FPC_HAS_CPSTRING} compilerproc; {$endif FPC_HAS_CPSTRING}
begin
SetLength(S,Len);
If (Buf<>Nil) and (Len>0) then
@@ -731,7 +731,7 @@ begin
end;
-Procedure SetString (Out S : WideString; Buf : PChar; Len : SizeInt);
+Procedure {$ifdef FPC_HAS_CPSTRING}fpc_setstring_widestr_pansichar{$else}SetString{$endif}(Out S : WideString; Buf : PChar; Len : SizeInt); {$ifdef FPC_HAS_CPSTRING} compilerproc; {$endif FPC_HAS_CPSTRING}
begin
If (Buf<>Nil) and (Len>0) then
widestringmanager.Ansi2WideMoveProc(Buf,DefaultSystemCodePage,S,Len)
@@ -942,38 +942,4 @@ function UTF8Encode(const s : WideString) : RawByteString;
end;
end;
-procedure unimplementedunicodestring; forward;
-{$warnings off}
-function GenericWideCase(const s : WideString) : WideString;
- begin
- unimplementedunicodestring;
- end;
-
-
-function CompareWideString(const s1, s2 : WideString) : PtrInt;
- begin
- unimplementedunicodestring;
- end;
-
-
-function CompareTextWideString(const s1, s2 : WideString): PtrInt;
- begin
- unimplementedunicodestring;
- end;
-
-{$warnings on}
-
-
-procedure initwidestringmanager;
- begin
- fillchar(widestringmanager,sizeof(widestringmanager),0);
-{$ifndef HAS_WIDESTRINGMANAGER}
- widestringmanager.Wide2AnsiMoveProc:=@DefaultUnicode2AnsiMove;
- widestringmanager.Ansi2WideMoveProc:=@DefaultAnsi2WideMove;
- widestringmanager.UpperWideStringProc:=@GenericWideCase;
- widestringmanager.LowerWideStringProc:=@GenericWideCase;
-{$endif HAS_WIDESTRINGMANAGER}
- widestringmanager.CompareWideStringProc:=@CompareWideString;
- widestringmanager.CompareTextWideStringProc:=@CompareTextWideString;
- end;
View Lorry Controller Status