From 931d4dcfeea91a734cbbbb4ff28beabf8b9bda34 Mon Sep 17 00:00:00 2001 From: florian Date: Mon, 13 Jan 2020 21:20:03 +0000 Subject: [PATCH] * ensure the rtl and the packages for embedded compile with features exceptions and classes disabled git-svn-id: trunk@43931 - --- compiler/psub.pas | 5 +- packages/rtl-extra/src/inc/sortalgs.pp | 12 +++++ rtl/inc/objpash.inc | 68 ++++++++++++++------------ rtl/inc/rtti.inc | 6 +++ rtl/inc/sortbase.pp | 5 ++ rtl/inc/systemh.inc | 2 - 6 files changed, 62 insertions(+), 36 deletions(-) diff --git a/compiler/psub.pas b/compiler/psub.pas index ad2ec35b11..5330a38479 100644 --- a/compiler/psub.pas +++ b/compiler/psub.pas @@ -932,7 +932,8 @@ implementation (pi_needs_implicit_finally in flags) and { but it's useless in init/final code of units } not(procdef.proctypeoption in [potype_unitfinalize,potype_unitinit]) and - not(target_info.system in systems_garbage_collected_managed_types) then + not(target_info.system in systems_garbage_collected_managed_types) and + (f_exceptions in features) then begin { Any result of managed type must be returned in parameter } if is_managed_type(procdef.returndef) and @@ -969,7 +970,7 @@ implementation { constructors need destroy-on-exception code even if they don't have managed variables/temps } maybe_add_constructor_wrapper(code, - cs_implicit_exceptions in current_settings.moduleswitches); + (cs_implicit_exceptions in current_settings.moduleswitches) and (f_exceptions in features)); current_filepos:=entrypos; addstatement(newstatement,code); current_filepos:=exitpos; diff --git a/packages/rtl-extra/src/inc/sortalgs.pp b/packages/rtl-extra/src/inc/sortalgs.pp index 23c384494f..30fbb54416 100644 --- a/packages/rtl-extra/src/inc/sortalgs.pp +++ b/packages/rtl-extra/src/inc/sortalgs.pp @@ -349,7 +349,10 @@ begin exit; GetMem(TempBuf, ItemSize); + +{$ifdef FPC_HAS_FEATURE_EXCEPTIONS} try +{$endif FPC_HAS_FEATURE_EXCEPTIONS} HeapSize := ItemCount; for I := HeapSort_Parent(ItemCount - 1) downto 0 do Heapify(I); @@ -361,9 +364,13 @@ begin Dec(HeapSize); Heapify(0); end; +{$ifdef FPC_HAS_FEATURE_EXCEPTIONS} finally +{$endif FPC_HAS_FEATURE_EXCEPTIONS} FreeMem(TempBuf, ItemSize); +{$ifdef FPC_HAS_FEATURE_EXCEPTIONS} end; +{$endif FPC_HAS_FEATURE_EXCEPTIONS} end; procedure HeapSort_ItemList_CustomItemExchanger_Context( @@ -959,11 +966,16 @@ begin if not Assigned(Items) or (ItemCount < 2) or (ItemSize < 1) then exit; GetMem(TempBuf, ItemSize); +{$ifdef FPC_HAS_FEATURE_EXCEPTIONS} try IntroSort(0, ItemCount - 1, 2*IntLog2(ItemCount)); finally FreeMem(TempBuf, ItemSize); end; +{$else FPC_HAS_FEATURE_EXCEPTIONS} + IntroSort(0, ItemCount - 1, 2*IntLog2(ItemCount)); + FreeMem(TempBuf, ItemSize); +{$endif FPC_HAS_FEATURE_EXCEPTIONS} end; procedure IntroSort_ItemList_CustomItemExchanger_Context( diff --git a/rtl/inc/objpash.inc b/rtl/inc/objpash.inc index b7670c7c28..1a7257bcdc 100644 --- a/rtl/inc/objpash.inc +++ b/rtl/inc/objpash.inc @@ -29,6 +29,35 @@ Basic Types/constants *****************************************************************************} + type + TextFile = Text; + + PGuid = ^TGuid; + TGuid = packed record + case integer of + 1 : ( + Data1 : DWord; + Data2 : word; + Data3 : word; + Data4 : array[0..7] of byte; + ); + 2 : ( + D1 : DWord; + D2 : word; + D3 : word; + D4 : array[0..7] of byte; + ); + 3 : ( { uuid fields according to RFC4122 } + time_low : dword; // The low field of the timestamp + time_mid : word; // The middle field of the timestamp + time_hi_and_version : word; // The high field of the timestamp multiplexed with the version number + clock_seq_hi_and_reserved : byte; // The high field of the clock sequence multiplexed with the variant + clock_seq_low : byte; // The low field of the clock sequence + node : array[0..5] of byte; // The spatially unique node identifier + ); + end; + +{$ifdef FPC_HAS_FEATURE_CLASSES} const vmtInstanceSize = 0; vmtParent = sizeof(SizeInt)*2; @@ -68,8 +97,6 @@ E_NOTIMPL = hresult($80004001); type - TextFile = Text; - { now the let's declare the base classes for the class object model. The compiler expects TObject and IUnknown to be defined first as forward classes } @@ -130,31 +157,6 @@ property vParent: PVmt read GetvParent; end; - PGuid = ^TGuid; - TGuid = packed record - case integer of - 1 : ( - Data1 : DWord; - Data2 : word; - Data3 : word; - Data4 : array[0..7] of byte; - ); - 2 : ( - D1 : DWord; - D2 : word; - D3 : word; - D4 : array[0..7] of byte; - ); - 3 : ( { uuid fields according to RFC4122 } - time_low : dword; // The low field of the timestamp - time_mid : word; // The middle field of the timestamp - time_hi_and_version : word; // The high field of the timestamp multiplexed with the version number - clock_seq_hi_and_reserved : byte; // The high field of the clock sequence multiplexed with the variant - clock_seq_low : byte; // The low field of the clock sequence - node : array[0..5] of byte; // The spatially unique node identifier - ); - end; - // This enumerate is found both in the rtl and compiler. Do not change the order of the fields. tinterfaceentrytype = (etStandard, etVirtualMethodResult, @@ -467,6 +469,11 @@ Calling this method is only valid within an except block. } procedure ReleaseExceptionObject; + const + { for safe as operator support } + IObjectInstance: TGuid = '{D91C9AF4-3C93-420F-A303-BF5BA82BFD23}'; +{$endif FPC_HAS_FEATURE_CLASSES} + {***************************************************************************** Array of const support *****************************************************************************} @@ -515,8 +522,10 @@ vtString : (VString: PShortString); vtPointer : (VPointer: Pointer); vtPChar : (VPChar: PAnsiChar); +{$ifdef FPC_HAS_FEATURE_CLASSES} vtObject : (VObject: TObject); vtClass : (VClass: TClass); +{$endif FPC_HAS_FEATURE_CLASSES} vtPWideChar : (VPWideChar: PWideChar); vtAnsiString : (VAnsiString: Pointer); vtCurrency : (VCurrency: PCurrency); @@ -533,11 +542,6 @@ var DispCallByIDProc : codepointer; - const - { for safe as operator support } - IObjectInstance: TGuid = '{D91C9AF4-3C93-420F-A303-BF5BA82BFD23}'; - - {***************************************************************************** Resourcestring support *****************************************************************************} diff --git a/rtl/inc/rtti.inc b/rtl/inc/rtti.inc index c39f199625..80feccb15e 100644 --- a/rtl/inc/rtti.inc +++ b/rtl/inc/rtti.inc @@ -262,8 +262,10 @@ begin recordrtti(data,typeinfo,@int_finalize); end; {$endif VER3_0} +{$ifdef FPC_HAS_FEATURE_CLASSES} tkInterface: Intf_Decr_Ref(PPointer(Data)^); +{$endif FPC_HAS_FEATURE_CLASSES} {$ifdef FPC_HAS_FEATURE_DYNARRAYS} tkDynArray: fpc_dynarray_clear(PPointer(Data)^,TypeInfo); @@ -315,8 +317,10 @@ begin tkDynArray: fpc_dynarray_incr_ref(PPointer(Data)^); {$endif FPC_HAS_FEATURE_DYNARRAYS} +{$ifdef FPC_HAS_FEATURE_CLASSES} tkInterface: Intf_Incr_Ref(PPointer(Data)^); +{$endif FPC_HAS_FEATURE_CLASSES} {$ifdef FPC_HAS_FEATURE_VARIANTS} tkVariant: variant_addref(pvardata(Data)^); @@ -434,8 +438,10 @@ begin tkDynArray: fpc_dynarray_assign(PPointer(Dest)^,PPointer(Src)^,typeinfo); {$endif FPC_HAS_FEATURE_DYNARRAYS} +{$ifdef FPC_HAS_FEATURE_CLASSES} tkInterface: fpc_intf_assign(PPointer(Dest)^,PPointer(Src)^); +{$endif FPC_HAS_FEATURE_CLASSES} {$ifdef FPC_HAS_FEATURE_VARIANTS} tkVariant: begin diff --git a/rtl/inc/sortbase.pp b/rtl/inc/sortbase.pp index 11ee9915a3..99b2cbc96e 100644 --- a/rtl/inc/sortbase.pp +++ b/rtl/inc/sortbase.pp @@ -297,11 +297,16 @@ begin if not Assigned(Items) or (ItemCount < 2) or (ItemSize < 1) then exit; GetMem(TempBuf, ItemSize); +{$ifdef FPC_HAS_FEATURE_EXCEPTIONS} try QuickSort(0, ItemCount - 1); finally FreeMem(TempBuf, ItemSize); end; +{$else FPC_HAS_FEATURE_EXCEPTIONS} + QuickSort(0, ItemCount - 1); + FreeMem(TempBuf, ItemSize); +{$endif FPC_HAS_FEATURE_EXCEPTIONS} end; procedure QuickSort_ItemList_CustomItemExchanger_Context( diff --git a/rtl/inc/systemh.inc b/rtl/inc/systemh.inc index 2f7cfbb091..ced0de756d 100644 --- a/rtl/inc/systemh.inc +++ b/rtl/inc/systemh.inc @@ -1639,9 +1639,7 @@ const Object Pascal support *****************************************************************************} -{$ifdef FPC_HAS_FEATURE_CLASSES} {$i objpash.inc} -{$endif FPC_HAS_FEATURE_CLASSES} {***************************************************************************** Variant support