Skip to content
Permalink
Browse files

restored Delphi compilation after #249 merge

  • Loading branch information...
Arnaud Bouchez
Arnaud Bouchez committed Oct 30, 2019
1 parent dff34b9 commit 7c4117074d7700f56a1d94045603a80fe49240c1
Showing with 43 additions and 45 deletions.
  1. +12 −12 SQLite3/mORMot.pas
  2. +3 −6 SQLite3/mORMotSelfTests.pas
  3. +14 −20 SynCommons.pas
  4. +13 −6 SynMongoDB.pas
  5. +1 −1 SynopseCommit.inc
@@ -2843,9 +2843,6 @@ {$ifdef UNICODE}TTypeInfo = record{$else}TTypeInfo = object{$endif}
function AttributeTable: PFPCAttributeTable; inline;
{$endif FPC_PROVIDE_ATTR_TABLE}
end;
{$ifdef FPC}
{$pop}
{$endif}

/// how a RTTI property definition access its value
// - as returned by TPropInfo.Getter/Setter methods
@@ -2854,7 +2851,7 @@ {$ifdef UNICODE}TTypeInfo = record{$else}TTypeInfo = object{$endif}

/// a wrapper containing a RTTI property definition
// - used for direct Delphi / UTF-8 SQL type mapping/conversion
{$ifdef UNICODE}TPropInfo = packed record{$else}TPropInfo = packed object{$endif}
{$ifdef UNICODE}TPropInfo = record{$else}TPropInfo = object{$endif}
public
/// raw retrieval of the property read access definition
// - note: 'var Call' generated incorrect code on Delphi XE4 -> use PMethod
@@ -3150,6 +3147,10 @@ {$ifdef UNICODE}TTypeInfo = record{$else}TTypeInfo = object{$endif}
Options: TJSONToObjectOptions=[]): PUTF8Char;
end;

{$ifdef FPC}
{$pop}
{$endif}

/// the available methods calling conventions
// - this is by design only relevant to the x86 model
// - Win64 has one unique calling convention
@@ -21035,6 +21036,7 @@ function Deref(Info: PPTypeInfo): PTypeInfo;
type
AlignToPtr = pointer;
AlignTypeData = pointer;
AlignTypeDataClean = pointer;
UnalignToDouble = Double;
{$endif FPC}

@@ -21043,13 +21045,13 @@ function Deref(Info: PPTypeInfo): PTypeInfo;
function GetTypeData(const info: TTypeInfo): pointer;
{$ifdef HASINLINE}inline;{$endif}
begin
result := AlignTypeData(pointer(@info)+2+PByte(pointer(@info)+1)^);
result := AlignTypeData(PAnsiChar(@info)+2+PByte(PAnsiChar(@info)+1)^);
end;

function GetTypeDataClean(const info: TTypeInfo): pointer;
{$ifdef HASINLINE}inline;{$endif}
begin
result := AlignTypeDataClean(pointer(@info)+2+PByte(pointer(@info)+1)^);
result := AlignTypeDataClean(PAnsiChar(@info)+2+PByte(PAnsiChar(@info)+1)^);
end;

function TTypeInfo.ClassType: PClassType;
@@ -21233,8 +21235,7 @@ function TPropInfo.GetFieldAddr(Instance: TObject): pointer;
{$ifdef HASINLINENOTX86}
function TPropInfo.Next: PPropInfo;
begin
//result := AlignToPtr(PAnsiChar(@Name[1])+ord(Name[0]));
result := AlignToPtr(PByte(@Name[0]) + SizeOf(Name[0]) + Length(Name));
result := AlignToPtr(PAnsiChar(@Name[0]) + SizeOf(Name[0]) + Length(Name));
end;
{$else}
function TPropInfo.Next: PPropInfo;
@@ -55941,10 +55942,9 @@ function StubCallAllocMem(const Size, flProtect: DWORD): pointer;
while start<stop do begin // try whole -STUB_INTERV..+STUB_INTERV range
inc(start,STUB_SIZE);
result := fpmmap(pointer(start),STUB_SIZE,flProtect,MAP_PRIVATE or MAP_ANONYMOUS,-1,0);
if result<>MAP_FAILED then // close enough for a 24/32-bit relative jump?
begin
dist:= abs(stub-PtrUInt(result));
if (dist<STUB_RELJMP) then begin
if result<>MAP_FAILED then begin // close enough for a 24/32-bit relative jump?
dist := abs(stub-PtrUInt(result));
if dist<STUB_RELJMP then begin
StubCallAllocMemLastStart := start;
exit;
end else
@@ -129,8 +129,7 @@ function TTestSynopsemORMotFramework.Run: boolean;
procedure TTestSynopsemORMotFramework.SynopseLibraries;
begin
//AddCase(TTestCompression);
//
exit;
//exit;
AddCase([TTestLowLevelCommon,
TTestLowLevelTypes,
{$ifdef MSWINDOWS}
@@ -156,10 +155,8 @@ procedure TTestSynopsemORMotFramework.SynopseLibraries;
{$else}
procedure TTestSynopsemORMotFramework._mORMot;
begin
//
AddCase(TTestDDDSharedUnits);
//
exit; // (*
//AddCase(TTestDDDSharedUnits);
//exit; // (*
AddCase([TTestFileBased,TTestFileBasedMemoryMap,TTestFileBasedWAL]);
AddCase(TTestMemoryBased);
AddCase(TTestBasicClasses);
@@ -2024,6 +2024,11 @@ function TrimControlChars(const text: RawUTF8; const controls: TSynAnsicharSet=[
{$endif}
/// the non-number values potentially stored in an IEEE floating point
TSynExtendedNan = (seNumber, seNan, seInf, seNegInf);
{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
/// will actually change anything only on FPC ARM/Aarch64 plaforms
unaligned = Double;
{$endif}


const
/// the JavaScript-like values of non-number IEEE constants
type
{$ifdef FPC}
{$packrecords c} // as expected by FPC's RTTI record definitions

TStrRec =
{packed}
record // see TAnsiRec/TUnicodeRec in astrings/ustrings.inc
TStrRec = record // see TAnsiRec/TUnicodeRec in astrings/ustrings.inc
{$ifdef ISFPC27}
codePage: TSystemCodePage; // =Word
elemSize: Word;
tkEnumeration: (
EnumType: TOrdType;
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
EnumDummy: DWORD; // needed on ARM for correct alignment !!??
EnumDummy: DWORD; // needed on ARM for correct alignment
{$endif}
{$ifdef FPC_ENUMHASINNER} inner:
{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT} packed {$endif} record
tkSet: (
SetType: TOrdType;
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
SetDummy: DWORD; // needed on ARM for correct alignment !!??
SetDummy: DWORD; // needed on ARM for correct alignment
{$endif}
{$ifdef FPC}
{$ifndef VER3_0}
begin
if len<=0 then
r := nil else begin
GetMem(r,len+(STRRECSIZE+2));
GetMem(r,len+(STRRECSIZE+4));
sr := pointer(r);
sr^.codePage := CP_UTF8;
sr^.elemSize := 1;
sr^.refCnt := 1;
sr^.length := len;
inc(PByte(sr),STRRECSIZE);
PWord(PAnsiChar(sr)+len)^ := 0; // ensure ends with two #0
PCardinal(PAnsiChar(sr)+len)^ := 0; // ensure ends with four #0
r := pointer(sr);
if p<>nil then
{$ifdef FPC}Move{$else}MoveFast{$endif}(p^,sr^,len);
result := false;
end;

{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
type
unaligned = Double;
{$endif}

function Char2ToByte(P: PUTF8Char; out Value: Cardinal): Boolean;
var B: PtrUInt;
begin
recInitData: PFPCRecInitData; // low-level type redirected from SynFPCTypInfo
aPointer:pointer;
begin
if Assigned(info^.RecInitInfo) then
begin
if Assigned(info^.RecInitInfo) then begin
recInitData := PFPCRecInitData(AlignTypeDataClean(PTypeInfo(info^.RecInitInfo+2+PByte(info^.RecInitInfo+1)^)));
firstfield := PFieldInfo(PtrUInt(@recInitData^.ManagedFieldCount));
Inc(PByte(firstfield),SizeOf(integer));
inc(PByte(firstfield),SizeOf(integer));
firstfield := AlignToPtr(firstfield);
result := recInitData^.ManagedFieldCount;
end
else
begin
end else begin
aPointer:=@info^.RecInitInfo;
{$ifdef FPC_PROVIDE_ATTR_TABLE}
dec(PByte(aPointer),SizeOf(Pointer));
{$endif}
recInitData := PFPCRecInitData(aPointer);
firstfield := PFieldInfo(PtrUInt(@recInitData^.ManagedFieldCount));
Inc(PByte(firstfield),SizeOf(integer));
inc(PByte(firstfield),SizeOf(integer));
firstfield := AlignToPtr(firstfield);
result := recInitData^.ManagedFieldCount;
end;
@@ -256,10 +256,10 @@ EBSONException = class(ESynException);

/// element types for BSON internal representation
TBSONElementType = (
betMinKey=-1, betEOF=0, betFloat, betString, betDoc, betArray, betBinary,
betEOF, betFloat, betString, betDoc, betArray, betBinary,
betDeprecatedUndefined, betObjectID, betBoolean, betDateTime,
betNull, betRegEx, betDeprecatedDbptr, betJS, betDeprecatedSymbol,
betJSScope, betInt32, betTimestamp, betInt64, betDecimal128, betMaxKey);
betJSScope, betInt32, betTimestamp, betInt64, betDecimal128);

/// points to an element type for BSON internal representation
PBSONElementType = ^TBSONElementType;
@@ -822,6 +822,13 @@ TBSONWriter = class(TFileBufferWriter)


const
/// fake BSON element type which compares lower than all other possible values
// - element type sounds to be stored as shortint, so here $ff=-1<0=betEOF
betMinKey = TBSONElementType($ff);
/// fake BSON element type which compares higher than all other possible values
// - element type sounds to be stored as shortint, so here betInt64=$12<$7f
betMaxKey = TBSONElementType($7f);

/// kind of elements which will store a RawByteString/RawUTF8 content
// within its TBSONVariant kind
// - i.e. TBSONVariantData.VBlob/VText field is to be managed
@@ -2682,26 +2689,26 @@ procedure BSONItemsToDocVariant(Kind: TBSONElementType; BSON: PByte;
// - equals -1 for varying elements
BSON_ELEMENTSIZE: array[TBSONElementType] of integer = (
//betEOF, betFloat, betString, betDoc, betArray, betBinary,
0, 0, sizeof(Double), -1, -1, -1, -1,
0, sizeof(Double), -1, -1, -1, -1,
//betDeprecatedUndefined, betObjectID, betBoolean, betDateTime,
0, sizeof(TBSONObjectID), 1, sizeof(Int64),
//betNull, betRegEx, betDeprecatedDbptr, betJS, betDeprecatedSymbol,
0, -1, -1, -1, -1,
//betJSScope, betInt32, betTimestamp, betInt64, betDecimal128
-1, sizeof(Integer), sizeof(Int64), SizeOf(Int64), Sizeof(TDecimal128), 0);
-1, sizeof(Integer), sizeof(Int64), SizeOf(Int64), Sizeof(TDecimal128));

/// types which do not have an exact equivalency to a standard variant
// type will be mapped as varUnknown - and will be changed into
// BSONVariantType.VarType
BSON_ELEMENTTYPES: array[TBSONElementType] of word = (
//betEOF, betFloat, betString, betDoc, betArray, betBinary,
varEmpty, varEmpty, varDouble, varString, varUnknown, varUnknown, varUnknown,
varEmpty, varDouble, varString, varUnknown, varUnknown, varUnknown,
//betDeprecatedUndefined, betObjectID, betBoolean, betDateTime,
varEmpty, varUnknown, varBoolean, varDate,
//betNull, betRegEx, betDeprecatedDbptr, betJS, betDeprecatedSymbol,
varNull, varUnknown, varUnknown, varUnknown, varUnknown,
//betJSScope, betInt32, betTimestamp, betInt64, betDecimal128
varUnknown, varInteger, varUnknown, varInt64, varUnknown, varEmpty);
varUnknown, varInteger, varUnknown, varInt64, varUnknown);

function TBSONElement.ToVariant(DocArrayConversion: TBSONDocArrayConversion): variant;
begin
@@ -1 +1 @@
'1.18.5435'
'1.18.5436'

0 comments on commit 7c41170

Please sign in to comment.
You can’t perform that action at this time.