diff --git a/.gitattributes b/.gitattributes index 8244a7b1a6..8d74edbb79 100644 --- a/.gitattributes +++ b/.gitattributes @@ -11715,6 +11715,8 @@ tests/tbs/tb0649.pp -text svneol=native#text/pascal tests/tbs/tb0650.pp svneol=native#text/pascal tests/tbs/tb0651.pp svneol=native#text/pascal tests/tbs/tb0654.pp svneol=native#text/plain +tests/tbs/tb0655.pp svneol=native#text/pascal +tests/tbs/tb0657.pp svneol=native#text/pascal tests/tbs/tb205.pp svneol=native#text/plain tests/tbs/tb610.pp svneol=native#text/pascal tests/tbs/tb613.pp svneol=native#text/plain @@ -16426,6 +16428,7 @@ tests/webtbs/tw3577.pp svneol=native#text/plain tests/webtbs/tw3578.pp svneol=native#text/plain tests/webtbs/tw3579.pp svneol=native#text/plain tests/webtbs/tw3583.pp svneol=native#text/plain +tests/webtbs/tw35862.pp svneol=native#text/pascal tests/webtbs/tw3589.pp svneol=native#text/plain tests/webtbs/tw3594.pp svneol=native#text/plain tests/webtbs/tw3595.pp svneol=native#text/plain diff --git a/packages/graph/src/inc/graph.inc b/packages/graph/src/inc/graph.inc index 38d282a3ed..cb2d32eba0 100644 --- a/packages/graph/src/inc/graph.inc +++ b/packages/graph/src/inc/graph.inc @@ -265,7 +265,7 @@ var { thick width } hline(x1,x2,y2-1); hline(x1,x2,y2); - hline(x2,x2,y2+1); + hline(x1,x2,y2+1); end; end else diff --git a/packages/rtl-generics/src/generics.collections.pas b/packages/rtl-generics/src/generics.collections.pas index 092398ee7e..930675a86a 100644 --- a/packages/rtl-generics/src/generics.collections.pas +++ b/packages/rtl-generics/src/generics.collections.pas @@ -679,7 +679,10 @@ type procedure ValueNotify(constref AValue: TValue; ACollectionNotification: TCollectionNotification); inline; procedure NodeNotify(ANode: PNode; ACollectionNotification: TCollectionNotification; ADispose: boolean); inline; procedure SetValue(var AValue: TValue; constref ANewValue: TValue); + function GetItem(const AKey: TKey): TValue; + procedure SetItem(const AKey: TKey; const AValue: TValue); + property Items[Index: TKey]: TValue read GetItem write SetItem; // for reporting procedure WriteStr(AStream: TStream; const AText: string); public type @@ -747,8 +750,8 @@ type function Remove(constref AKey: TKey; ADisposeNode: boolean = true): boolean; function ExtractPair(constref AKey: TKey; ADisposeNode: boolean = true): TTreePair; overload; function ExtractPair(constref ANode: PNode; ADispose: boolean = true): TTreePair; overload; - function ExtractNode(constref AKey: TKey; ADisposeNode: boolean): PNode; overload; - function ExtractNode(ANode: PNode; ADispose: boolean): PNode; overload; + function Extract(constref AKey: TKey; ADisposeNode: boolean): PNode; + function ExtractNode(ANode: PNode; ADispose: boolean): PNode; procedure Delete(ANode: PNode; ADispose: boolean = true); inline; function GetEnumerator: TPairEnumerator; @@ -782,6 +785,8 @@ type end; TAVLTreeMap = class(TCustomAVLTreeMap) + public + property Items; default; end; TIndexedAVLTreeMap = class(TCustomAVLTreeMap) @@ -808,6 +813,7 @@ type protected property OnKeyNotify; property OnValueNotify; + property Items; public type TItemEnumerator = TKeyEnumerator; public @@ -3319,6 +3325,21 @@ begin Result := TValueCollection(FValues); end; +function TCustomAVLTreeMap.GetItem(const AKey: TKey): TValue; +var + LNode: PNode; +begin + LNode := Find(AKey); + if not Assigned(LNode) then + raise EAVLTree.CreateRes(@SDictionaryKeyDoesNotExist); + result := LNode.Value; +end; + +procedure TCustomAVLTreeMap.SetItem(const AKey: TKey; const AValue: TValue); +begin + Find(AKey).Value := AValue; +end; + constructor TCustomAVLTreeMap.Create; begin FComparer := TComparer.Default; @@ -3430,7 +3451,7 @@ begin Result.Value := DoRemove(ANode, cnExtracted, ADispose); end; -function TCustomAVLTreeMap.ExtractNode(constref AKey: TKey; ADisposeNode: boolean): PNode; +function TCustomAVLTreeMap.Extract(constref AKey: TKey; ADisposeNode: boolean): PNode; begin Result:=Find(AKey); if Result<>nil then diff --git a/packages/rtl-generics/tests/tests.generics.trees.pas b/packages/rtl-generics/tests/tests.generics.trees.pas index 1152c91130..134753273e 100644 --- a/packages/rtl-generics/tests/tests.generics.trees.pas +++ b/packages/rtl-generics/tests/tests.generics.trees.pas @@ -42,6 +42,7 @@ type procedure Test_IndexedAVLTree_Add_General; procedure Test_IndexedAVLTree_Add; procedure Test_IndexedAVLTree_Delete; + procedure Test_IndexedAVLTree_Items; procedure Test_TAVLTreeMap_Notification; end; @@ -50,6 +51,7 @@ implementation type TStringsTree = TIndexedAVLTree; + TMapTree = TAVLTreeMap; { TTestTrees } @@ -138,6 +140,29 @@ begin end; end; +procedure TTestTrees.Test_IndexedAVLTree_Items; +var + LTree: TMapTree; +begin + LTree := TMapTree.Create; + try + Check(LTree.Add('A', 1)<>nil); + Check(LTree.Add('B', 2)<>nil); + Check(LTree.Add('C', 3)<>nil); + CheckEquals(LTree.Items['A'], 1); + CheckEquals(LTree.Items['B'], 2); + CheckEquals(LTree.Items['C'], 3); + LTree.Items['A'] := 4; + LTree.Items['B'] := 5; + LTree.Items['C'] := 6; + CheckEquals(LTree.Items['A'], 4); + CheckEquals(LTree.Items['B'], 5); + CheckEquals(LTree.Items['C'], 6); + finally + LTree.Free; + end; +end; + procedure TTestTrees.Test_TAVLTreeMap_Notification; var LTree: TAVLTreeMap; diff --git a/packages/rtl-objpas/src/inc/variants.pp b/packages/rtl-objpas/src/inc/variants.pp index 153453cb29..a03ccc476a 100644 --- a/packages/rtl-objpas/src/inc/variants.pp +++ b/packages/rtl-objpas/src/inc/variants.pp @@ -2488,12 +2488,25 @@ begin DoOleVarFromVar(TVarData(aDest), TVarData(aSource)); end; -procedure sysolevarfromint(var Dest : olevariant; const Source : LongInt; const range : ShortInt); +procedure sysolevarfromint(var Dest : olevariant; const Source : Int64; const range : ShortInt); begin DoVarClearIfComplex(TVarData(Dest)); + { 64-bit values have their own types, all smaller ones are stored as signed 32-bit value } with TVarData(Dest) do begin - vInteger := Source; - vType := varInteger; + case range of + -8: begin + vInt64 := Int64(Source); + vType := varInt64; + end; + 8: begin + vQWord := QWord(Source); + vType := varQWord; + end; + else begin + vInteger := LongInt(Source); + vType := varInteger; + end; + end; end; end; diff --git a/rtl/amicommon/sysutils.pp b/rtl/amicommon/sysutils.pp index 65c1a03b48..1fd34fe0a6 100644 --- a/rtl/amicommon/sysutils.pp +++ b/rtl/amicommon/sysutils.pp @@ -949,4 +949,5 @@ Initialization RefreshDeviceList; Finalization DoneExceptions; + FreeTerminateProcs; end. diff --git a/rtl/atari/sysutils.pp b/rtl/atari/sysutils.pp index 10200a9000..ef59c393ba 100644 --- a/rtl/atari/sysutils.pp +++ b/rtl/atari/sysutils.pp @@ -527,4 +527,5 @@ Initialization Finalization DoneExceptions; + FreeTerminateProcs; end. diff --git a/rtl/embedded/sysutils.pp b/rtl/embedded/sysutils.pp index e5e56b321c..ee66fe45f2 100644 --- a/rtl/embedded/sysutils.pp +++ b/rtl/embedded/sysutils.pp @@ -286,4 +286,5 @@ Initialization InitExceptions; Finalization DoneExceptions; + FreeTerminateProcs; end. diff --git a/rtl/emx/sysutils.pp b/rtl/emx/sysutils.pp index 58fa68bbd3..3e09eb0fed 100644 --- a/rtl/emx/sysutils.pp +++ b/rtl/emx/sysutils.pp @@ -1335,4 +1335,5 @@ Initialization InitInternational; { Initialize internationalization settings } Finalization DoneExceptions; + FreeTerminateProcs; end. diff --git a/rtl/gba/sysutils.pp b/rtl/gba/sysutils.pp index c7eeb472c6..74e51e8a74 100644 --- a/rtl/gba/sysutils.pp +++ b/rtl/gba/sysutils.pp @@ -320,4 +320,5 @@ Initialization InitExceptions; Finalization DoneExceptions; + FreeTerminateProcs; end. diff --git a/rtl/go32v2/sysutils.pp b/rtl/go32v2/sysutils.pp index 422728fb5e..8f92b4a7d6 100644 --- a/rtl/go32v2/sysutils.pp +++ b/rtl/go32v2/sysutils.pp @@ -915,4 +915,5 @@ Initialization OnBeep:=@SysBeep; Finalization DoneExceptions; + FreeTerminateProcs; end. diff --git a/rtl/inc/varianth.inc b/rtl/inc/varianth.inc index 91fa75cf8a..8417b54b71 100644 --- a/rtl/inc/varianth.inc +++ b/rtl/inc/varianth.inc @@ -186,7 +186,7 @@ type olevarfrompstr: procedure(var dest : olevariant; const source : shortstring); olevarfromlstr: procedure(var dest : olevariant; const source : ansistring); olevarfromvar: procedure(var dest : olevariant; const source : variant); - olevarfromint: procedure(var dest : olevariant; const source : longint;const range : shortint); + olevarfromint: procedure(var dest : olevariant; const source : int64;const range : shortint); { operators } varop : procedure(var left : variant;const right : variant;opcode : tvarop); diff --git a/rtl/macos/sysutils.pp b/rtl/macos/sysutils.pp index a045a7df16..6f2577c982 100644 --- a/rtl/macos/sysutils.pp +++ b/rtl/macos/sysutils.pp @@ -844,4 +844,5 @@ Initialization InitInternational; { Initialize internationalization settings } Finalization DoneExceptions; + FreeTerminateProcs; end. diff --git a/rtl/msdos/sysutils.pp b/rtl/msdos/sysutils.pp index 09444f72e2..a77fa362e9 100644 --- a/rtl/msdos/sysutils.pp +++ b/rtl/msdos/sysutils.pp @@ -924,4 +924,5 @@ Initialization OnBeep:=@SysBeep; Finalization DoneExceptions; + FreeTerminateProcs; end. diff --git a/rtl/nativent/sysutils.pp b/rtl/nativent/sysutils.pp index 8a7eafb97a..fedcdec162 100644 --- a/rtl/nativent/sysutils.pp +++ b/rtl/nativent/sysutils.pp @@ -1258,4 +1258,5 @@ initialization OnBeep := @SysBeep; finalization DoneExceptions; + FreeTerminateProcs; end. diff --git a/rtl/nds/sysutils.pp b/rtl/nds/sysutils.pp index 641c7112e5..34d31abe21 100644 --- a/rtl/nds/sysutils.pp +++ b/rtl/nds/sysutils.pp @@ -359,4 +359,5 @@ Initialization InitExceptions; Finalization DoneExceptions; + FreeTerminateProcs; end. diff --git a/rtl/netware/sysutils.pp b/rtl/netware/sysutils.pp index 1aca9745f0..7b032c41c1 100644 --- a/rtl/netware/sysutils.pp +++ b/rtl/netware/sysutils.pp @@ -656,4 +656,5 @@ Initialization OnBeep:=@SysBeep; Finalization DoneExceptions; + FreeTerminateProcs; end. diff --git a/rtl/netwlibc/sysutils.pp b/rtl/netwlibc/sysutils.pp index be20af62fe..96b2f2f398 100644 --- a/rtl/netwlibc/sysutils.pp +++ b/rtl/netwlibc/sysutils.pp @@ -723,4 +723,5 @@ Initialization InitInternational; { Initialize internationalization settings } Finalization DoneExceptions; + FreeTerminateProcs; end. diff --git a/rtl/objpas/fgl.pp b/rtl/objpas/fgl.pp index 4e5f7cf1d0..0aab16386e 100644 --- a/rtl/objpas/fgl.pp +++ b/rtl/objpas/fgl.pp @@ -900,7 +900,7 @@ end; function TFPGList.GetList: PTypeList; begin - Result := PTypeList(FList); + Result := PTypeList(@FList); end; function TFPGList.ItemPtrCompare(Item1, Item2: Pointer): Integer; @@ -1029,7 +1029,7 @@ end; function TFPGObjectList.GetList: PTypeList; begin - Result := PTypeList(FList); + Result := PTypeList(@FList); end; function TFPGObjectList.ItemPtrCompare(Item1, Item2: Pointer): Integer; @@ -1153,7 +1153,7 @@ end; function TFPGInterfacedObjectList.GetList: PTypeList; begin - Result := PTypeList(FList); + Result := PTypeList(@FList); end; function TFPGInterfacedObjectList.ItemPtrCompare(Item1, Item2: Pointer): Integer; diff --git a/rtl/objpas/sysutils/sysutils.inc b/rtl/objpas/sysutils/sysutils.inc index aa5b8f0a06..c97422b256 100644 --- a/rtl/objpas/sysutils/sysutils.inc +++ b/rtl/objpas/sysutils/sysutils.inc @@ -653,6 +653,19 @@ begin end; end; +procedure FreeTerminateProcs; +var + TPR1, TPR2: PPRecord; +begin + TPR1 := TPList; + TPList := Nil; + while Assigned(TPR1) do begin + TPR2 := TPR1^.NextFunc; + Dispose(TPR1); + TPR1 := TPR2; + end; +end; + { --------------------------------------------------------------------- Diskh functions, OS independent. ---------------------------------------------------------------------} diff --git a/rtl/os2/sysutils.pp b/rtl/os2/sysutils.pp index 694d555b47..16205a14ed 100644 --- a/rtl/os2/sysutils.pp +++ b/rtl/os2/sysutils.pp @@ -997,4 +997,5 @@ Initialization OrigOSErrorWatch := TOSErrorWatch (SetOSErrorTracking (@TrackLastOSError)); Finalization DoneExceptions; + FreeTerminateProcs; end. diff --git a/rtl/symbian/sysutils.pp b/rtl/symbian/sysutils.pp index a334860fbc..26fc7abbf0 100644 --- a/rtl/symbian/sysutils.pp +++ b/rtl/symbian/sysutils.pp @@ -286,4 +286,5 @@ Initialization InitExceptions; Finalization DoneExceptions; + FreeTerminateProcs; end. diff --git a/rtl/unix/sysutils.pp b/rtl/unix/sysutils.pp index f40632d314..cc0c67a300 100644 --- a/rtl/unix/sysutils.pp +++ b/rtl/unix/sysutils.pp @@ -1658,4 +1658,5 @@ Initialization Finalization FreeDriveStr; DoneExceptions; + FreeTerminateProcs; end. diff --git a/rtl/watcom/sysutils.pp b/rtl/watcom/sysutils.pp index 2def0e6979..9829685423 100644 --- a/rtl/watcom/sysutils.pp +++ b/rtl/watcom/sysutils.pp @@ -893,4 +893,5 @@ Initialization InitDelay; Finalization DoneExceptions; + FreeTerminateProcs; end. diff --git a/rtl/wii/sysutils.pp b/rtl/wii/sysutils.pp index dbc0e5b4b7..baf6b0c0b2 100644 --- a/rtl/wii/sysutils.pp +++ b/rtl/wii/sysutils.pp @@ -289,4 +289,5 @@ Initialization InitExceptions; Finalization DoneExceptions; + FreeTerminateProcs; end. diff --git a/rtl/win/sysutils.pp b/rtl/win/sysutils.pp index fdfc1bc6ef..3638b1b5ce 100644 --- a/rtl/win/sysutils.pp +++ b/rtl/win/sysutils.pp @@ -1528,4 +1528,5 @@ Initialization OnBeep:=@SysBeep; Finalization DoneExceptions; + FreeTerminateProcs; end. diff --git a/rtl/win16/sysutils.pp b/rtl/win16/sysutils.pp index 319f8ebdb2..e4e00454df 100644 --- a/rtl/win16/sysutils.pp +++ b/rtl/win16/sysutils.pp @@ -946,4 +946,5 @@ Initialization OnBeep:=@SysBeep; Finalization DoneExceptions; + FreeTerminateProcs; end. diff --git a/rtl/wince/sysutils.pp b/rtl/wince/sysutils.pp index afc43bf9e4..5bb59e2b56 100644 --- a/rtl/wince/sysutils.pp +++ b/rtl/wince/sysutils.pp @@ -977,5 +977,6 @@ Initialization Finalization DoneExceptions; + FreeTerminateProcs; end. diff --git a/tests/tbs/tb0655.pp b/tests/tbs/tb0655.pp new file mode 100644 index 0000000000..acfaa66c4d --- /dev/null +++ b/tests/tbs/tb0655.pp @@ -0,0 +1,115 @@ +program tb0655; + +uses + Variants; + +var + s8: Int8 = $12; + u8: UInt8 = $98; + s16: Int16 = $1234; + u16: UInt16 = $9876; + s32: Int32 = $12345768; + u32: UInt32 = $98765432; + s64: Int64 = $1234567812345678; + u64: UInt64 = UInt64($9876543298765432); + v: Variant; + ov: OleVariant; +begin + v := s8; + if VarType(v) <> varShortInt then + Halt(1); + if Int8(v) <> s8 then + Halt(2); + + v := u8; + if VarType(v) <> varByte then + Halt(3); + if UInt8(v) <> u8 then + Halt(4); + + v := s16; + if VarType(v) <> varSmallInt then + Halt(5); + if Int16(v) <> s16 then + Halt(6); + + v := u16; + if VarType(v) <> varWord then + Halt(7); + if UInt16(v) <> u16 then + Halt(8); + + v := s32; + if VarType(v) <> varInteger then + Halt(9); + if Int32(v) <> s32 then + Halt(10); + + v := u32; + if VarType(v) <> varLongWord then + Halt(11); + if UInt32(v) <> u32 then + Halt(12); + + v := s64; + if VarType(v) <> varInt64 then + Halt(13); + if Int64(v) <> s64 then + Halt(14); + + v := u64; + if VarType(v) <> varUInt64 then + Halt(15); + if UInt64(v) <> u64 then + Halt(16); + + { OleVariant has slightly different behaviour to Variant } + ov := s8; + if VarType(ov) <> varInteger then + Halt(17); + if Int8(ov) <> s8 then + Halt(18); + + ov := u8; + if VarType(ov) <> varInteger then + Halt(19); + if UInt8(ov) <> u8 then + Halt(20); + + ov := s16; + if VarType(ov) <> varInteger then + Halt(21); + if Int16(ov) <> s16 then + Halt(22); + + ov := u16; + if VarType(ov) <> varInteger then + Halt(23); + if UInt16(ov) <> u16 then + Halt(24); + + ov := s32; + if VarType(ov) <> varInteger then + Halt(25); + if Int32(ov) <> s32 then + Halt(26); + + ov := u32; + if VarType(ov) <> varInteger then + Halt(27); + { ! } + if UInt32(Int32(ov)) <> u32 then + Halt(28); + + ov := s64; + if VarType(ov) <> varInt64 then + Halt(29); + if Int64(ov) <> s64 then + Halt(30); + + ov := u64; + if VarType(ov) <> varUInt64 then + Halt(31); + if UInt64(ov) <> u64 then + Halt(32); +end. diff --git a/tests/tbs/tb0657.pp b/tests/tbs/tb0657.pp new file mode 100644 index 0000000000..e890ed9d0c --- /dev/null +++ b/tests/tbs/tb0657.pp @@ -0,0 +1,29 @@ +program tb0657; + +{$mode objfpc} + +uses + fgl; + +type + TIntList = specialize TFPGList; + +const + c = 3; + +var + l: TIntList; + i: LongInt; +begin + l := TIntList.Create; + try + for i := 0 to c do + l.Add(i); + + for i := 0 to l.Count - 1 do + if l.List^[i] <> i then + Halt(i + 1); + finally + l.Free; + end; +end. diff --git a/tests/webtbs/tw35862.pp b/tests/webtbs/tw35862.pp new file mode 100644 index 0000000000..8763349bb1 --- /dev/null +++ b/tests/webtbs/tw35862.pp @@ -0,0 +1,22 @@ +{ %OPT=-gh } + +program tw35862; + +{$modeswitch result} + +uses sysutils; + +function do_term:boolean; +begin + writeln('In terminate proc'); + Result:=true; +end; + +begin + HaltOnNotReleased:=True; + + writeln('Adding terminate proc'); + AddTerminateproc(@do_term); + writeln('terminating'); + CallterminateProcs; +end.