diff options
Diffstat (limited to 'avx512-0037785/tests')
30 files changed, 952 insertions, 200 deletions
diff --git a/avx512-0037785/tests/Makefile b/avx512-0037785/tests/Makefile index b9676a929a..e908b07b74 100644 --- a/avx512-0037785/tests/Makefile +++ b/avx512-0037785/tests/Makefile @@ -2423,9 +2423,9 @@ LOGEXT=.testlog .tbslog .tbflog .webtbslog .webtbflog TESTUNITDIRS=system dos crt objects strings sysutils math sharemem strutils matrix lineinfo ucomplex fpwidestring cpu fmtbcd windows classes character dateutil fpcunit softfpu variants sortbase sortalgs linux unixutil types nullable TESTDIRECTDIRS= TESTSUBDIRS=cg cg/variants cg/cdecl cpu16 cpu16/i8086 library opt $(addprefix units/,$(TESTUNITDIRS)) -TESTPACKAGESDIRS=win-base webtbs hash fcl-registry fcl-process zlib fcl-db fcl-xml cocoaint bzip2 +TESTPACKAGESDIRS=win-base webtbs hash fcl-registry fcl-process zlib fcl-db fcl-xml cocoaint bzip2 fcl-net TESTPACKAGESUBDIRS=$(addprefix packages/,$(TESTPACKAGESDIRS)) -TESTPACKAGESDIRECTDIRS=rtl-objpas rtl-generics hash regexpr +TESTPACKAGESDIRECTDIRS=rtl-objpas rtl-generics hash regexpr fcl-registry TESTPACKAGESDIRECTSUBDIRS=$(addprefix ../packages/,$(addsuffix /tests,$(TESTPACKAGESDIRECTDIRS))) ifdef QUICKTEST export QUICKTEST diff --git a/avx512-0037785/tests/Makefile.fpc b/avx512-0037785/tests/Makefile.fpc index 5e6dd2bd2f..15e765d5c4 100644 --- a/avx512-0037785/tests/Makefile.fpc +++ b/avx512-0037785/tests/Makefile.fpc @@ -162,9 +162,9 @@ LOGEXT=.testlog .tbslog .tbflog .webtbslog .webtbflog TESTUNITDIRS=system dos crt objects strings sysutils math sharemem strutils matrix lineinfo ucomplex fpwidestring cpu fmtbcd windows classes character dateutil fpcunit softfpu variants sortbase sortalgs linux unixutil types nullable TESTDIRECTDIRS= TESTSUBDIRS=cg cg/variants cg/cdecl cpu16 cpu16/i8086 library opt $(addprefix units/,$(TESTUNITDIRS)) -TESTPACKAGESDIRS=win-base webtbs hash fcl-registry fcl-process zlib fcl-db fcl-xml cocoaint bzip2 +TESTPACKAGESDIRS=win-base webtbs hash fcl-registry fcl-process zlib fcl-db fcl-xml cocoaint bzip2 fcl-net TESTPACKAGESUBDIRS=$(addprefix packages/,$(TESTPACKAGESDIRS)) -TESTPACKAGESDIRECTDIRS=rtl-objpas rtl-generics hash regexpr +TESTPACKAGESDIRECTDIRS=rtl-objpas rtl-generics hash regexpr fcl-registry TESTPACKAGESDIRECTSUBDIRS=$(addprefix ../packages/,$(addsuffix /tests,$(TESTPACKAGESDIRECTDIRS))) ifdef QUICKTEST diff --git a/avx512-0037785/tests/test/cg/tpara4.pp b/avx512-0037785/tests/test/cg/tpara4.pp new file mode 100644 index 0000000000..f175a553eb --- /dev/null +++ b/avx512-0037785/tests/test/cg/tpara4.pp @@ -0,0 +1,22 @@ +{ This test ensures that a "const TVarData" parameter is passed as a reference. + This is required for Delphi compatibility as implementers of IVarInvokable or + inheritors of TInvokableVariantType need to modify the variant data by using + a pointer to the TVarData because it's passed as const and thus not modifyable + by itself. + This behavior is documented in so far as the C++ builder documentation shows + that the same parameter is implemented as "const&". } + +program tpara4; + +var + d: TVarData; + +procedure Test(const v: TVarData); +begin + if @d <> @v then + Halt(1); +end; + +begin + Test(d); +end. diff --git a/avx512-0037785/tests/test/theapthread.pp b/avx512-0037785/tests/test/theapthread.pp index 44f51bf000..36689148ab 100644 --- a/avx512-0037785/tests/test/theapthread.pp +++ b/avx512-0037785/tests/test/theapthread.pp @@ -15,12 +15,14 @@ type tpair = class; tproducethread = class(tthread) + running: boolean; pair: tpair; constructor create(apair: tpair); procedure execute; override; end; tconsumethread = class(tthread) + running: boolean; pair: tpair; constructor create(apair: tpair); procedure execute; override; @@ -197,11 +199,13 @@ end; procedure tproducethread.execute; begin + running:=true; producer(pair); end; procedure tconsumethread.execute; begin + running:=true; consumer(pair); end; @@ -221,7 +225,12 @@ begin pairs[i] := tpair.create; for i := low(pairs) to high(pairs) do pairs[i].resume; - sleep(1500); + + { wait till all threads are really resumed } + for i := low(pairs) to high(pairs) do + while not(pairs[i].produce_thread.running) or not(pairs[i].consume_thread.running) do + sleep(100); + done := true; for i := low(pairs) to high(pairs) do begin diff --git a/avx512-0037785/tests/test/units/linux/tfutimesen.pp b/avx512-0037785/tests/test/units/linux/tfutimesen.pp new file mode 100644 index 0000000000..797f51fba3 --- /dev/null +++ b/avx512-0037785/tests/test/units/linux/tfutimesen.pp @@ -0,0 +1,84 @@ +{ %target=linux } +uses + ctypes,baseunix,linux; + +var + un : utsname; + res : cint; + f1,f2 : text; + err : word; + mystatx1,mystatx2 : tstatx; + times : tkernel_timespecs; + st,major,minor : string; + i,p,e : longint; + major_release, minor_release : longint; +begin + fpuname(un); + st:=un.release; + for i:=1 to UTSNAME_LENGTH do + if st[i]='.' then + begin + p:=i; + major:=system.copy(st,1,p-1); + system.val(major,major_release,err); + if err<>0 then + begin + writeln('Unable to parse first part of linux version ',st,'(',major,') correctly'); + halt(2); + end; + break; + end; + + for i:=p+1 to UTSNAME_LENGTH do + if st[i]='.' then + begin + e:=i; + minor:=system.copy(st,p+1,e-p-1); + system.val(minor,minor_release,err); + if err<>0 then + begin + writeln('Unable to second part of parse linux version ',st,'i(',minor,') correctly'); + halt(2); + end; + break; + end; + if (major_release<4) or ((major_release=4) and (minor_release<11)) then + begin + writeln('This version of Linux: ',st,' does not have fstatx syscall'); + halt(0); + end + else + writeln('This linux version ',st,' should support statx syscall'); + + assign(f1,'tutimensat1.txt'); + rewrite(f1); + write(f1,'ccccc'); + assign(f2,'tutimensat2.txt'); + rewrite(f2); + write(f2,'ccccc'); + + res:=statx(AT_FDCWD,'tutimensat1.txt',AT_SYMLINK_NOFOLLOW,STATX_ALL,mystatx1); + if res<>0 then + halt(1); + times[0].tv_sec:=mystatx1.stx_atime.tv_sec; + times[0].tv_nsec:=mystatx1.stx_atime.tv_nsec; + times[1].tv_sec:=mystatx1.stx_mtime.tv_sec; + times[1].tv_nsec:=mystatx1.stx_mtime.tv_nsec; + res:=futimens(textrec(f2).handle,times); + if res<>0 then + halt(1); + res:=statx(AT_FDCWD,'tutimensat2.txt',AT_SYMLINK_NOFOLLOW,STATX_ALL,mystatx2); + if res<>0 then + halt(1); + + close(f1); + close(f2); + + erase(f1); + erase(f2); + + if (mystatx1.stx_atime.tv_sec<>mystatx2.stx_atime.tv_sec) or (mystatx1.stx_atime.tv_nsec<>mystatx2.stx_atime.tv_nsec) or + (mystatx1.stx_mtime.tv_sec<>mystatx2.stx_mtime.tv_sec) or (mystatx1.stx_mtime.tv_nsec<>mystatx2.stx_mtime.tv_nsec) then + halt(1); + writeln('ok'); +end. diff --git a/avx512-0037785/tests/test/units/linux/tstatx.pp b/avx512-0037785/tests/test/units/linux/tstatx.pp index 360b11a356..78798f08c3 100644 --- a/avx512-0037785/tests/test/units/linux/tstatx.pp +++ b/avx512-0037785/tests/test/units/linux/tstatx.pp @@ -1,10 +1,10 @@ { %target=linux } uses ctypes,baseunix,linux; - + var un : utsname; - mystatx : statx; + mystatx : tstatx; res : cint; f : text; st,major,minor : string; @@ -21,13 +21,13 @@ begin major:=system.copy(st,1,p-1); system.val(major,major_release,err); if err<>0 then - begin + begin writeln('Unable to parse first part of linux version ',st,'(',major,') correctly'); halt(2); end; break; end; - + for i:=p+1 to UTSNAME_LENGTH do if st[i]='.' then begin @@ -35,25 +35,25 @@ begin minor:=system.copy(st,p+1,e-p-1); system.val(minor,minor_release,err); if err<>0 then - begin + begin writeln('Unable to second part of parse linux version ',st,'i(',minor,') correctly'); halt(2); end; break; end; - if (major_release<4) or (minor_release<11) then + if (major_release<4) or ((major_release=4) and (minor_release<11)) then begin writeln('This version of Linux: ',st,' does not have fstatx syscall'); halt(0); end else writeln('This linux version ',st,' should support statx syscall'); - + assign(f,'test.txt'); rewrite(f); write(f,'ccccc'); close(f); - res:=fpstatx(AT_FDCWD,'test.txt',AT_SYMLINK_NOFOLLOW,STATX_ALL,mystatx); + res:=statx(AT_FDCWD,'test.txt',AT_SYMLINK_NOFOLLOW,STATX_ALL,mystatx); erase(f); if res<>0 then begin diff --git a/avx512-0037785/tests/test/units/linux/tutimensat.pp b/avx512-0037785/tests/test/units/linux/tutimensat.pp new file mode 100644 index 0000000000..e7fc443bcb --- /dev/null +++ b/avx512-0037785/tests/test/units/linux/tutimensat.pp @@ -0,0 +1,83 @@ +{ %target=linux } +uses + ctypes,baseunix,linux; + +var + un : utsname; + res : cint; + f1,f2 : text; + err : word; + mystatx1,mystatx2 : tstatx; + times : tkernel_timespecs; + st,major,minor : string; + i,p,e : longint; + major_release, minor_release : longint; +begin + fpuname(un); + st:=un.release; + for i:=1 to UTSNAME_LENGTH do + if st[i]='.' then + begin + p:=i; + major:=system.copy(st,1,p-1); + system.val(major,major_release,err); + if err<>0 then + begin + writeln('Unable to parse first part of linux version ',st,'(',major,') correctly'); + halt(2); + end; + break; + end; + + for i:=p+1 to UTSNAME_LENGTH do + if st[i]='.' then + begin + e:=i; + minor:=system.copy(st,p+1,e-p-1); + system.val(minor,minor_release,err); + if err<>0 then + begin + writeln('Unable to second part of parse linux version ',st,'i(',minor,') correctly'); + halt(2); + end; + break; + end; + if (major_release<4) or ((major_release=4) and (minor_release<11)) then + begin + writeln('This version of Linux: ',st,' does not have fstatx syscall'); + halt(0); + end + else + writeln('This linux version ',st,' should support statx syscall'); + + assign(f1,'tutimensat1.txt'); + rewrite(f1); + write(f1,'ccccc'); + close(f1); + assign(f2,'tutimensat2.txt'); + rewrite(f2); + write(f2,'ccccc'); + close(f2); + + res:=statx(AT_FDCWD,'tutimensat1.txt',AT_SYMLINK_NOFOLLOW,STATX_ALL,mystatx1); + if res<>0 then + halt(1); + times[0].tv_sec:=mystatx1.stx_atime.tv_sec; + times[0].tv_nsec:=mystatx1.stx_atime.tv_nsec; + times[1].tv_sec:=mystatx1.stx_mtime.tv_sec; + times[1].tv_nsec:=mystatx1.stx_mtime.tv_nsec; + res:=utimensat(AT_FDCWD,'tutimensat2.txt',times,0); + if res<>0 then + halt(1); + res:=statx(AT_FDCWD,'tutimensat2.txt',AT_SYMLINK_NOFOLLOW,STATX_ALL,mystatx2); + if res<>0 then + halt(1); + + erase(f1); + erase(f2); + + if (mystatx1.stx_atime.tv_sec<>mystatx2.stx_atime.tv_sec) or (mystatx1.stx_atime.tv_nsec<>mystatx2.stx_atime.tv_nsec) or + (mystatx1.stx_mtime.tv_sec<>mystatx2.stx_mtime.tv_sec) or (mystatx1.stx_mtime.tv_nsec<>mystatx2.stx_mtime.tv_nsec) then + halt(1); + writeln('ok'); +end. diff --git a/avx512-0037785/tests/test/units/sysutils/tfile1.pp b/avx512-0037785/tests/test/units/sysutils/tfile1.pp index 578976f2c5..ddca3956e6 100644 --- a/avx512-0037785/tests/test/units/sysutils/tfile1.pp +++ b/avx512-0037785/tests/test/units/sysutils/tfile1.pp @@ -32,6 +32,19 @@ BEGIN if FileSetDate('datetest.dat', DateTimeToFileDate(dateTime))<>0 then do_error(1002); + dateTime := IncMonth(Now, -1); + Assign(f,'datetest.dat'); + Rewrite(f); + if FileSetDate(filerec(f).handle, DateTimeToFileDate(dateTime))<>0 then + do_error(1003); + Close(f); + + Assign(f,'datetest.dat'); + Reset(f); + if FileGetDate(filerec(f).handle)<>DateTimeToFileDate(dateTime) then + do_error(1004); + Close(f); + if FileExists('datetest.dat') then begin Assign(f,'datetest.dat'); diff --git a/avx512-0037785/tests/test/units/sysutils/tfileage.pp b/avx512-0037785/tests/test/units/sysutils/tfileage.pp new file mode 100644 index 0000000000..7710082ea6 --- /dev/null +++ b/avx512-0037785/tests/test/units/sysutils/tfileage.pp @@ -0,0 +1,18 @@ +uses + sysutils; +begin + if 3600*24*(now()-FileDateToDateTime(FileAge(paramstr(0))))>7200 then + begin + writeln('FileAge returns: ',FileDateToDateTime(FileAge(paramstr(0)))); + writeln('Compilation time and run time differ too much, SysUtils.FileAge buggy?'); + halt(1); + end; + + { test with relative path } + if 3600*24*(now()-FileDateToDateTime(FileAge(ExtractRelativePath(GetCurrentDir+DirectorySeparator,paramstr(0)))))>7200 then + begin + writeln('FileAge returns: ',FileDateToDateTime(FileAge(paramstr(0)))); + writeln('Compilation time and run time differ too much, SysUtils.FileAge buggy?'); + halt(1); + end; +end. diff --git a/avx512-0037785/tests/utils/testsuite/utests.pp b/avx512-0037785/tests/utils/testsuite/utests.pp index e40f57922c..cca795028b 100644 --- a/avx512-0037785/tests/utils/testsuite/utests.pp +++ b/avx512-0037785/tests/utils/testsuite/utests.pp @@ -153,13 +153,16 @@ const faction_compare_with_next = 6; faction_compare2_with_previous = 7; faction_compare2_with_next = 8; + faction_compare_both_with_previous = 9; + faction_compare_both_with_next = 10; + Function TestResultsTableName(const RunId : String) : string; var RunIDVal : qword; Error : word; begin - system.val (RunId,RunIdVal,error); + system.val (Trim(RunId),RunIdVal,error); if (error<>0) then result:='ErrorTable' else if (RunIdVal <= LastOldTestRun) then @@ -347,6 +350,18 @@ begin FCompareRunID:=FNext2RunID; ShowRunComparison; end; + faction_compare_both_with_previous : + begin + FRunID:=FPreviousRunID; + FCompareRunID:=FPrevious2RunID; + ShowRunComparison; + end; + faction_compare_both_with_next : + begin + FRunID:=FNextRunID; + FCompareRunID:=FNext2RunID; + ShowRunComparison; + end; {$ifdef TEST} 98 : begin @@ -402,6 +417,10 @@ begin FAction:=faction_compare2_with_previous else if S='Compare_right_to_next' then FAction:=faction_compare2_with_next + else if S='Compare_both_to_previous' then + FAction:=faction_compare_both_with_previous + else if S='Compare_both_to_next' then + FAction:=faction_compare_both_with_next else FAction:=StrToIntDef(S,0); S:=RequestVariables['limit']; @@ -1134,7 +1153,7 @@ Const SGetRunData = 'SELECT TU_ID,TU_DATE,TC_NAME,TO_NAME,' + 'TU_SUBMITTER,TU_MACHINE,TU_COMMENT,TV_VERSION,'+ 'TU_CATEGORY_FK,TU_SVNCOMPILERREVISION,TU_SVNRTLREVISION,'+ - 'TU_COMPILERDATE,'+ + 'TU_COMPILERDATE,TU_COMPILERFULLVERSION,'+ 'TU_SVNPACKAGESREVISION,TU_SVNTESTSREVISION,'+ '(TU_SUCCESSFULLYFAILED+TU_SUCCESFULLYCOMPILED+TU_SUCCESSFULLYRUN) AS OK,'+ '(TU_FAILEDTOCOMPILE+TU_FAILEDTORUN+TU_FAILEDTOFAIL) as Failed,'+ @@ -1150,12 +1169,70 @@ Const Var - Q1,Q2 : TSQLQuery; + Q1, Q2 : TSQLQuery; F : TField; - SC : string; - Date1, Date2: TDateTime; - AddNewPar : boolean; - CompilerDate1, CompilerDate2: TDateTime; + SC, FRight : string; + Date1, Date2 : TDateTime; + AddNewPar, same_date : boolean; + CompilerDate1, CompilerDate2 : TDateTime; + + procedure EmitOneRow(RowTitle,FieldLeft,FieldRight : String; is_same : boolean); + var + FieldColor : string; + begin + if (FieldRight='') then + FieldColor:='' + else if is_same then + FieldColor:='style="color:green;"' + else + FieldColor:='style="color:red;"'; + With FHTMLWriter do + begin + RowNext; + if FieldColor<>'' then + begin + TagStart('TD',FieldColor); + end + else + CellStart; + LDumpLn(RowTitle); + if FieldColor<>'' then + begin + CellEnd; + TagStart('TD',FieldColor); + end + else + CellNext; + LDumpLn(FieldLeft); + if FieldColor<>'' then + begin + CellEnd; + TagStart('TD',FieldColor); + end + else + CellNext; + LDumpLn(FieldRight); + CellEnd; + end; + end; + procedure EmitOneRow(RowTitle,FieldLeft,FieldRight : String); + var + is_same : boolean; + begin + is_same:=(FieldLeft=FieldRight); + EmitOneRow(RowTitle,FieldLeft,FieldRight,is_same); + end; + procedure EmitRow(RowTitle,FieldName : String); + var + FieldLeft, FieldRight : String; + begin + FieldLeft:=Q1.FieldByName(FieldName).AsString; + if Q2=nil then + FieldRight:='' + else + FieldRight:=Q2.FieldByName(FieldName).AsString; + EmitOneRow(RowTitle,FieldLeft,FieldRight); + end; begin Result:=(FRunID<>''); If Result then @@ -1191,172 +1268,99 @@ begin CellNext; EmitInput('run2id',FCompareRunID); CellEnd; - RowNext; - CellStart; - DumpLn('Operating system:'); - CellNext; - DumpLn(Q1.FieldByName('TO_NAME').AsString); - CellNext; - if Q2 <> nil then - DumpLn(Q2.FieldByName('TO_NAME').AsString); - CellEnd; - RowNext; - CellStart; - DumpLn('Processor:'); - CellNext; - DumpLn(Q1.FieldByName('TC_NAME').AsString); - CellNext; - if Q2 <> nil then - DumpLn(Q2.FieldByName('TC_NAME').AsString); - CellEnd; - RowNext; - CellStart; - DumpLn('Version:'); - CellNext; - DumpLn(Q1.FieldByNAme('TV_VERSION').AsString); - CellNext; - if Q2 <> nil then - DumpLn(Q2.FieldByNAme('TV_VERSION').AsString); - CellEnd; - RowNext; - CellStart; - DumpLn('Fails/OK/Total:'); - CellNext; - Dump(Q1.FieldByName('Failed').AsString); - Dump('/'+Q1.FieldByName('OK').AsString); - DumpLn('/'+Q1.FieldByName('Total').AsString); - CellNext; - if Q2 <> nil then - begin - Dump(Q2.FieldByName('Failed').AsString); - Dump('/'+Q2.FieldByName('Ok').AsString); - DumpLn('/'+Q2.FieldByName('Total').AsString); - end; - CellEnd; - RowNext; - CellStart; - DumpLn('Comment:'); - CellNext; - DumpLn(Q1.FieldByName('TU_COMMENT').AsString); - CellNext; - if Q2 <> nil then - DumpLn(Q2.FieldByName('TU_COMMENT').AsString); - CellEnd; - RowNext; - CellStart; - DumpLn('Machine:'); - CellNext; - DumpLn(Q1.FieldByName('TU_MACHINE').AsString); - CellNext; - if Q2 <> nil then - DumpLn(Q2.FieldByName('TU_MACHINE').AsString); - CellEnd; - if GetCategoryName(FCategory)<>'All' then + EmitRow('Operating system:','TO_NAME'); + EmitRow('Processor:','TC_NAME'); + EmitRow('Version:','TV_VERSION'); + if Q2 = nil then + FRight:='' + else begin - RowNext; - CellStart; - DumpLn('Category:'); - CellNext; - DumpLn(GetCategoryName(Q1.FieldByName('TU_CATEGORY_FK').AsString)); - CellNext; - if Q2 <> nil then - DumpLn(GetCategoryName(Q2.FieldByName('TU_CATEGORY_FK').AsString)); - CellEnd; + FRight:=Q2.FieldByName('Failed').AsString+ + '/'+Q2.FieldByName('Ok').AsString+ + '/'+Q2.FieldByName('Total').AsString; end; + EmitOneRow('Fails/OK/Total:', + Q1.FieldByName('Failed').AsString+ + '/'+Q1.FieldByName('OK').AsString+ + '/'+Q1.FieldByName('Total').AsString, + FRight); + EmitRow('Version:','TV_VERSION'); + EmitRow('Full version:','TU_COMPILERFULLVERSION'); + EmitRow('Comment:','TU_COMMENT'); + EmitRow('Machine:','TU_MACHINE'); + if GetCategoryName(FCategory)<>'All' then + EmitRow('Category:','TU_CATEGORY_FK'); If GetCategoryName(FCategory)<>'DB' then begin - RowNext; - CellStart; - DumpLn('SVN Revisions:'); - CellNext; - SC:=Q1.FieldByName('svnrev').AsString; - if (SC<>'') then - FormatSVNData(SC); - LDumpLn(SC); - CellNext; - if Q2 <> nil then - begin - SC:=Q2.FieldByName('svnrev').AsString; - FormatSVNData(SC); - LDumpLn(SC); - end; - CellEnd; - end; - RowNext; - CellStart; - DumpLn('Submitter:'); - CellNext; - DumpLn(Q1.FieldByName('TU_SUBMITTER').AsString); - CellNext; + SC:=Q1.FieldByName('svnrev').AsString; + if (SC<>'') then + FormatSVNData(SC); if Q2 <> nil then - DumpLn(Q2.FieldByName('TU_SUBMITTER').AsString); - CellEnd; - RowNext; - CellStart; - DumpLn('Date:'); - CellNext; - F := Q1.FieldByName('TU_DATE'); - Date1 := F.AsDateTime; - DumpLn(F.AsString); - F := Q1.FieldByName('TU_COMPILERDATE'); + begin + FRight:=Q2.FieldByName('svnrev').AsString; + FormatSVNData(FRight); + end + else + FRight:=''; + EmitOneRow('SVN revisions:',SC,FRight); + end; + EmitRow('Submitter:','TU_SUBMITTER'); + F := Q1.FieldByName('TU_DATE'); + Date1 := F.AsDateTime; + SC:=F.AsString; + F := Q1.FieldByName('TU_COMPILERDATE'); + Try + CompilerDate1 := F.AsDateTime; + if not SameDate(Date1,CompilerDate1) then + SC:=SC+' <> '+F.AsString; + Except + { Not a valid date, do nothing } + end; + if Q2 = nil then + FRight:='' + else + begin + F := Q2.FieldByName('TU_DATE'); + Date2 := F.AsDateTime; + FRight:= F.AsString; + F := Q2.FieldByName('TU_COMPILERDATE'); Try - CompilerDate1 := F.AsDateTime; - if not SameDate(Date1,CompilerDate1) then - DumpLn(' <> '+F.AsString); + CompilerDate2 := F.AsDateTime; + if not SameDate(Date2,CompilerDate2) then + FRight:=FRight+' <> '+F.AsString; Except { Not a valid date, do nothing } end; - CellNext; - if Q2 <> nil then - begin - F := Q2.FieldByName('TU_DATE'); - Date2 := F.AsDateTime; - DumpLn(F.AsString); - F := Q2.FieldByName('TU_COMPILERDATE'); - Try - CompilerDate2 := F.AsDateTime; - if not SameDate(Date2,CompilerDate2) then - DumpLn(' <> '+F.AsString); - Except - { Not a valid date, do nothing } - end; - end; - CellEnd; - RowNext; - CellStart; - DumpLn('Previous run:'); - CellNext; - FPreviousRunID:=GetPreviousRunID(FRunID); - if FPreviousRunID<>'' then - EmitHiddenVar('previousrunid',FPreviousRunID); - DumpLn(FPreviousRunID); - CellNext; - if (FCompareRunID<>'') then - begin - FPrevious2RunID:=GetPreviousRunID(FCompareRunID); - DumpLn(FPrevious2RunID); - if FPrevious2RunID <> '' then - EmitHiddenVar('previous2runid',FPrevious2RunID); - end; - CellEnd; - RowNext; - CellStart; - DumpLn('Next run:'); - CellNext; - FNextRunID:=GetNextRunID(FRunID); - if FNextRunID<>'' then - EmitHiddenVar('nextrunid',FNextRunID); - DumpLn(FNextRunID); - CellNext; - if (FCompareRunID<>'') then - begin - FNext2RunID:=GetNextRunID(FCompareRunID); - DumpLn(FNext2RunID); - if FNext2RunID <> '' then - EmitHiddenVar('next2runid',FNext2RunID); - end; - CellEnd; + end; + same_date:=(Copy(SC,1,10)=Copy(FRight,1,10)); + EmitOneRow('Date:',SC,FRight,same_date); + FPreviousRunID:=GetPreviousRunID(FRunID); + if FPreviousRunID<>'' then + EmitHiddenVar('previousrunid',FPreviousRunID); + SC:=FPreviousRunID; + if (FCompareRunID<>'') then + begin + FPrevious2RunID:=GetPreviousRunID(FCompareRunID); + FRight:=FPrevious2RunID; + if FPrevious2RunID <> '' then + EmitHiddenVar('previous2runid',FPrevious2RunID); + end + else + FRight:=''; + EmitOneRow('Previous run:',SC,FRight); + FNextRunID:=GetNextRunID(FRunID); + if FNextRunID<>'' then + EmitHiddenVar('nextrunid',FNextRunID); + SC:=FNextRunID; + if (FCompareRunID<>'') then + begin + FNext2RunID:=GetNextRunID(FCompareRunID); + FRight:=FNext2RunID; + if FNext2RunID <> '' then + EmitHiddenVar('next2runid',FNext2RunID); + end; + EmitOneRow('Next run:',SC,FRight); RowEnd; TableEnd; ParagraphStart; @@ -1397,7 +1401,22 @@ begin ParaGraphStart; end; - EmitSubmitButton('action','Show/Compare'); + if (FPrevious2RunID<>'') and (FPreviousRunId<>'') then + begin + EmitSubmitButton('action','Compare_both_to_previous'); + AddNewPar:=true; + end; + if (FNext2RunID<>'') and (FNextRunId<>'') then + begin + EmitSubmitButton('action','Compare_both_to_next'); + AddNewPar:=true; + end; + if AddNewPar then + begin + ParagraphEnd; + ParaGraphStart; + end; + EmitSubmitButton('action','Show/Compare'); if FTestFileID<>'' then EmitSubmitButton('action','View_history'); EmitResetButton('','Reset form'); @@ -1524,7 +1543,7 @@ begin finally Free; end; - If Not (FRunCount=0) and not (FNoSkipped or FOnlyFailed) then + If Not (FRunCount=0) and not (FNoSkipped and FOnlyFailed) then begin ParaGraphStart; TagStart('IMG',Format('Src="'+TestsuiteCGIURL+ @@ -2916,10 +2935,6 @@ Procedure TTestSuite.DoDrawPie(Img : TFPCustomImage; Skipped,Failed,Total : Inte Var Cnv : TFPImageCanvas; - W,H,FH,CR,ra : Integer; - A1,A2,FR,SR,PR : Double; - R : TRect; - F : TFreeTypeFont; Procedure AddPie(X,Y,R : Integer; AStart,AStop : Double; Col : TFPColor); @@ -2927,14 +2942,14 @@ Var DX,Dy : Integer; begin - DX:=Round(R*Cos(A1)); - DY:=Round(R*Sin(A1)); + DX:=Round(R*Cos(AStart)); + DY:=Round(R*Sin(AStart)); Cnv.Line(X,Y,X+DX,Y-DY); - DX:=Round(Ra*Cos(A2)); - DY:=Round(Ra*Sin(A2)); + DX:=Round(R*Cos(AStop)); + DY:=Round(R*Sin(AStop)); Cnv.Line(X,Y,X+DX,Y-Dy); - DX:=Round(R/2*Cos((A1+A2)/2)); - DY:=Round(R/2*Sin((A1+A2)/2)); + DX:=Round(R/2*Cos((AStart+AStop)/2)); + DY:=Round(R/2*Sin((AStart+AStop)/2)); Cnv.Brush.FpColor:=Col; Cnv.FloodFill(X+DX,Y-DY); end; @@ -2945,7 +2960,11 @@ Var Result:=(2*Pi*(F/T)) end; - +Var + W,H,FH,CR,RA : Integer; + A1,A2,FR,SR,PR : Double; + R : TRect; + F : TFreeTypeFont; begin F:=TFreeTypeFont.Create; @@ -3010,7 +3029,12 @@ begin Writeln(stdout,'Setting brush style'); system.flush(stdout); end; - cnv.brush.FPColor:=colRed; + cnv.brush.FPColor:=colDkGray; + SR:=Skipped/Total; + FR:=Failed/Total; + PR:=1-SR-FR; + cnv.font.FPColor:=colDkGray; + Cnv.Textout(1,FH*2,Format('%d Skipped (%3.1f%%)',[Skipped,SR*100])); // cnv.pen.width:=1; // Writeln('Drawing ellipse'); Cnv.Ellipse(R); @@ -3019,15 +3043,16 @@ begin Writeln(stdout,'Setting text'); system.flush(stdout); end; - Cnv.Textout(1,FH*2,Format('%d Skipped (%3.1f%%)',[Skipped,SR*100])); - A1:=(Pi*2*(failed/total)); - A2:=A1+(Pi*2*(Skipped/Total)); - AddPie(Ra,R.Top+Ra,Ra,A1,A2,ColYellow); + A1:=0; + A2:=A1+FractionAngle(Failed,Total); + cnv.font.FPColor:=colRed; + Cnv.Textout(1,FH*3,Format('%d Failed (%3.1f%%)',[Failed,FR*100])); + AddPie(Ra,R.Top+Ra,Ra,A1,A2,ColRed); cnv.font.FPColor:=colGreen; + Cnv.Textout(1,FH,Format('%d Passed (%3.1f%%)',[Total-Skipped-Failed,PR*100])); // Writeln('Palette size : ',Img.Palette.Count); A1:=A2; - A2:=A1+(Pi*2*((Total-(Skipped+Failed))/Total)); - Cnv.Textout(1,FH*3,Format('%d Passed (%3.1f%%',[Total-Skipped-Failed,PR*100])); + A2:=A1+FractionAngle(Total-(Skipped+Failed),Total); AddPie(Ra,R.Top+Ra,Ra,A1,A2,ColGreen); // Writeln('Palette size : ',Img.Palette.Count); // Writeln('All done'); diff --git a/avx512-0037785/tests/webtbf/tw24434.pp b/avx512-0037785/tests/webtbf/tw24434.pp new file mode 100644 index 0000000000..666655b0f8 --- /dev/null +++ b/avx512-0037785/tests/webtbf/tw24434.pp @@ -0,0 +1,13 @@ +{ %fail } +function f(s: string): string; +begin + f := '''' + s + ''''; +end; + +function f(s: string): integer; +begin + Val(s,f); +end; + +begin +end. diff --git a/avx512-0037785/tests/webtbf/tw37217.pp b/avx512-0037785/tests/webtbf/tw37217.pp new file mode 100644 index 0000000000..b2969f3353 --- /dev/null +++ b/avx512-0037785/tests/webtbf/tw37217.pp @@ -0,0 +1,12 @@ +{ %fail } +{$mode delphi} +type + TEagle = class + constructor Create<Y>(); + end; + +constructor TEagle.Create<Y>(); +begin +end; +begin +end. diff --git a/avx512-0037785/tests/webtbf/tw38287.pp b/avx512-0037785/tests/webtbf/tw38287.pp new file mode 100644 index 0000000000..6971257653 --- /dev/null +++ b/avx512-0037785/tests/webtbf/tw38287.pp @@ -0,0 +1,11 @@ +{$macro on} +var + a,b,s : real; + +begin + a:=1; + b:=2; +{$define sum:=a+b } +{$define b:=sum} { DON’T do this !!!} + s:=sum; { Will be infinitely recursively expanded... } +end. diff --git a/avx512-0037785/tests/webtbs/tw32139.pp b/avx512-0037785/tests/webtbs/tw32139.pp new file mode 100644 index 0000000000..ced0f60db1 --- /dev/null +++ b/avx512-0037785/tests/webtbs/tw32139.pp @@ -0,0 +1,11 @@ +{ %OPT=-Seh }
+program Test;
+
+{$HINTS ON}
+
+var
+ cur: Currency;
+begin
+ cur := 3.5;
+ cur := cur / 1.5;
+end.
diff --git a/avx512-0037785/tests/webtbs/tw34027.pp b/avx512-0037785/tests/webtbs/tw34027.pp new file mode 100644 index 0000000000..feacc2e199 --- /dev/null +++ b/avx512-0037785/tests/webtbs/tw34027.pp @@ -0,0 +1,27 @@ +uses + strings; + +type tz = record + name : pchar; + end; +const aa :array[0..2] of char = 'aa'#0; + +const testArrZ : array [0..4] of tz = ( + (name: @aa), { Ok } + (name: pchar(@aa)), { Ok } + (name: pchar(@aa)+1), + (name: pchar(@aa)+1+1), + (name: pchar(@aa)+1+1-1) + ); + +var b : pchar; + +begin + b:=pchar(@aa)+1; {Ok} + if strlen(testArrZ[2].name)<>1 then + halt(1); + if strlen(testArrZ[3].name)<>0 then + halt(2); + if strlen(testArrZ[4].name)<>1 then + halt(2); +end. diff --git a/avx512-0037785/tests/webtbs/tw37060.pp b/avx512-0037785/tests/webtbs/tw37060.pp index c167a50887..847c5ede4f 100644 --- a/avx512-0037785/tests/webtbs/tw37060.pp +++ b/avx512-0037785/tests/webtbs/tw37060.pp @@ -4,7 +4,7 @@ program fp37060; uses sockets, Classes, SysUtils; -procedure BuildBadAddrs4(out bad_addrs: TStringList); +procedure BuildBadAddrs4(var bad_addrs: TStringList); begin bad_addrs.Add('1.1.1.1.1'); // too many octets bad_addrs.Add('0xa.3.4.5'); //hex in octets @@ -32,7 +32,7 @@ begin bad_addrs.Add('&7.&5.30.4'); // octal end; -procedure BuildGoodAddrs4(out good_addrs: TStringList); +procedure BuildGoodAddrs4(var good_addrs: TStringList); begin good_addrs.Add('127.0.0.1|127.0.0.1'); good_addrs.Add('0.0.0.0|0.0.0.0'); @@ -40,7 +40,7 @@ begin good_addrs.Add('255.255.255.255|255.255.255.255'); end; -procedure BuildBadAddrs6(out bad_addrs: TStringList); +procedure BuildBadAddrs6(var bad_addrs: TStringList); begin // start with some obviously bad formats. bad_addrs.Add(''); @@ -193,7 +193,7 @@ begin bad_addrs.Add('127.0.0.2'); end; -procedure BuildGoodAddrs6(out addrlist: TStringList); +procedure BuildGoodAddrs6(var addrlist: TStringList); begin // Each str is two parts, separated by a pipe. The left part is the input // address to be parsed, and the right is the expected result of taking the diff --git a/avx512-0037785/tests/webtbs/tw38306.pp b/avx512-0037785/tests/webtbs/tw38306.pp new file mode 100644 index 0000000000..1fbcea7a38 --- /dev/null +++ b/avx512-0037785/tests/webtbs/tw38306.pp @@ -0,0 +1,39 @@ +{ %OPT=-gh }
+{$mode objfpc}
+program gqueue_test;
+
+uses
+ gqueue;
+
+type
+ TIntQueue = specialize TQueue<Integer>;
+
+var
+ IntQueue: TIntQueue;
+ PushCnt: Integer;
+
+procedure Push2Pop1;
+var
+ i: Integer;
+begin
+ for i:= 0 to 1000000 do begin
+ IntQueue.Push(PushCnt);
+ inc(PushCnt);
+ IntQueue.Push(PushCnt);
+ inc(PushCnt);
+ IntQueue.Pop();
+ end;
+end;
+
+var
+ i: Integer;
+begin
+ try
+ IntQueue:= TIntQueue.Create;
+ Push2Pop1;
+ WriteLn('Ready');
+ finally
+ IntQueue.Free;
+ end;
+end.
+
diff --git a/avx512-0037785/tests/webtbs/tw38316.pp b/avx512-0037785/tests/webtbs/tw38316.pp new file mode 100644 index 0000000000..29cd58b0e7 --- /dev/null +++ b/avx512-0037785/tests/webtbs/tw38316.pp @@ -0,0 +1,21 @@ +{ %opt=-gh } + +program project1; + +procedure P1(A: array of Integer); +begin +end; + +procedure P2(A: array of Integer); +begin + P1(A); +end; + +var + A: array [0..2] of Integer; + i: Integer; +begin + HaltOnNotReleased := true; + for i := 0 to 10 do + P2(A); +end. diff --git a/avx512-0037785/tests/webtbs/tw38337.pp b/avx512-0037785/tests/webtbs/tw38337.pp new file mode 100644 index 0000000000..7d461ddfa9 --- /dev/null +++ b/avx512-0037785/tests/webtbs/tw38337.pp @@ -0,0 +1,20 @@ +program fs; + +{$mode objfpc}{$H+} + +function UTF8Length(const s: string): PtrInt; inline; +begin + Result:=9; +end; + + +var + v1: string; + s: shortstring; + i: Integer; +begin + v1 := '123456789'; + s := v1; + for i := 1 to UTF8Length(s)-8 do begin + end; +end. diff --git a/avx512-0037785/tests/webtbs/tw38339.pp b/avx512-0037785/tests/webtbs/tw38339.pp new file mode 100644 index 0000000000..e81db9c9da --- /dev/null +++ b/avx512-0037785/tests/webtbs/tw38339.pp @@ -0,0 +1,23 @@ +{%OPT=-O3 } +program test48086; +{$mode objfpc}{$H+} +function IsFontNameXLogicalFontDesc(const LongFontName: string): boolean; +var MinusCnt, p: integer; +begin + MinusCnt:=0; + for p:=1 to length(LongFontName) do + if LongFontName[p]='-' then inc(MinusCnt); + Result:=(MinusCnt=14); +end; +var +myfont:string; +begin + myfont:='Myfont--------------'; + if IsFontNameXLogicalFontDesc(myfont) then + writeln('NO ERROR') + else + begin + writeln('Error in count'); + halt(1); + end; +end. diff --git a/avx512-0037785/tests/webtbs/tw38351.pp b/avx512-0037785/tests/webtbs/tw38351.pp new file mode 100644 index 0000000000..d76d639b4c --- /dev/null +++ b/avx512-0037785/tests/webtbs/tw38351.pp @@ -0,0 +1,33 @@ +{$MODE OBJFPC}
+{$APPTYPE CONSOLE}
+
+uses Classes, BufStream, Sysutils;
+
+procedure TestBufferedFileStream;
+var
+ F: TStream;
+ pf: File;
+begin
+ Assign(pf,'tw38351.tmp');
+ Rewrite(pf,1);
+ Seek(pf,100);
+ Close(pf);
+ F := TBufferedFileStream.Create('tw38351.tmp', fmOpenRead);
+ try
+ Writeln(F.Position);
+ if F.Position<>0 then
+ halt(1);
+ Writeln(F.Seek(0, soBeginning)); // TFileStream = 0, TBufferedFileStream = -1
+ Writeln(F.Position);
+ if F.Position<>0 then
+ halt(1);
+ finally
+ F.Free;
+ DeleteFile('tw38351.tmp');
+ end;
+end;
+
+begin
+ TestBufferedFileStream;
+ writeln('ok');
+end.
diff --git a/avx512-0037785/tests/webtbs/tw38385.pp b/avx512-0037785/tests/webtbs/tw38385.pp new file mode 100644 index 0000000000..30a66965a2 --- /dev/null +++ b/avx512-0037785/tests/webtbs/tw38385.pp @@ -0,0 +1,41 @@ +{ %norun } +Unit tw38385; + +{$mode objfpc}{$H+} + +Interface + +Uses + uw38385a, uw38385b, uw38385c; + +Type + + { TFoo } + + TFoo = Class(TInterfacedObject, uw38385a.IInterface1, uw38385b.IInterface1, uw38385c.IInterface1) + Procedure p1(); + Procedure p2(); + Procedure p3(); + End; + +Implementation + +{ TFoo } + +Procedure TFoo.p1(); +Begin + WriteLn('p1'); +End; + +Procedure TFoo.p2(); +Begin + WriteLn('p2'); +End; + +Procedure TFoo.p3(); +Begin + WriteLn('p3'); +End; + +End. + diff --git a/avx512-0037785/tests/webtbs/tw38390.pp b/avx512-0037785/tests/webtbs/tw38390.pp new file mode 100644 index 0000000000..11a2c523b0 --- /dev/null +++ b/avx512-0037785/tests/webtbs/tw38390.pp @@ -0,0 +1,23 @@ +program tw38390; +{$MODE Delphi} +uses SysUtils; + +var + s: String; + x: UInt64; + +begin + s := '20000000000'; + x := UInt64.Parse(s); + WriteLn(x); + if x <> 20000000000 then + Halt(1); + UInt64.TryParse(s, x); + WriteLn(x); + if x <> 20000000000 then + Halt(2); + x := StrToQWord(s); + WriteLn(x); + if x <> 20000000000 then + Halt(3); +end. diff --git a/avx512-0037785/tests/webtbs/tw38412.pp b/avx512-0037785/tests/webtbs/tw38412.pp new file mode 100644 index 0000000000..dcfe911a99 --- /dev/null +++ b/avx512-0037785/tests/webtbs/tw38412.pp @@ -0,0 +1,10 @@ +{ %norun } +type + measure = (short := 1, long := 2); + generic bar<const x: measure> = object + public + const + myMeasure = ord(x); + end; +begin +end. diff --git a/avx512-0037785/tests/webtbs/tw38413.pp b/avx512-0037785/tests/webtbs/tw38413.pp new file mode 100644 index 0000000000..ccd5930eac --- /dev/null +++ b/avx512-0037785/tests/webtbs/tw38413.pp @@ -0,0 +1,12 @@ +var + arr : array[-1..140] of byte=(4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4, + 4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4, + 4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4); + index , value : byte; // unsigned byte - important +begin + index:=133; // positive value, which is treated as negative + value:=arr[index]; // wrong value! Memory access outside array + if value<>4 then + halt(1); + writeln('ok'); +end. diff --git a/avx512-0037785/tests/webtbs/tw38429.pp b/avx512-0037785/tests/webtbs/tw38429.pp new file mode 100644 index 0000000000..87e9c9913e --- /dev/null +++ b/avx512-0037785/tests/webtbs/tw38429.pp @@ -0,0 +1,61 @@ +program tw38429; + +{$mode objfpc}{$h+} + +uses + SysUtils, Variants, uw38429; + +var + v, d: Variant; + I: Integer = 42; +begin + Writeln('Test VarAsType'); + d := I; + try + v := VarAsType(d, varMyVar); + except + on e: exception do begin + WriteLn('cast ', VarTypeAsText(VarType(d)), ' to ',VarTypeAsText(varMyVar), + ' raises ', e.ClassName, ' with message: ', e.Message); + Halt(1); + end; + end; + WriteLn('now v is ', VarTypeAsText(VarType(v))); + VarClear(d); + try + d := VarAsType(v, varInteger); + except + on e: exception do begin + WriteLn('cast ', VarTypeAsText(VarType(v)), ' to ',VarTypeAsText(varInteger), + ' raises ', e.ClassName, ' with message: ', e.Message); + Halt(2); + end; + end; + WriteLn('now d is ', VarTypeAsText(VarType(d))); + + { also test VarCast from #20849 } + Writeln('Test VarCast'); + d := I; + try + VarCast(v, d, varMyVar); + except + on e: exception do begin + WriteLn('cast ', VarTypeAsText(VarType(d)), ' to ',VarTypeAsText(varMyVar), + ' raises ', e.ClassName, ' with message: ', e.Message); + Halt(3); + end; + end; + WriteLn('now v is ', VarTypeAsText(VarType(v))); + VarClear(d); + try + VarCast(d, v, varInteger); + except + on e: exception do begin + WriteLn('cast ', VarTypeAsText(VarType(v)), ' to ',VarTypeAsText(varInteger), + ' raises ', e.ClassName, ' with message: ', e.Message); + Halt(4); + end; + end; + WriteLn('now d is ', VarTypeAsText(VarType(d))); +end. + diff --git a/avx512-0037785/tests/webtbs/uw38385a.pp b/avx512-0037785/tests/webtbs/uw38385a.pp new file mode 100644 index 0000000000..41110fc8a8 --- /dev/null +++ b/avx512-0037785/tests/webtbs/uw38385a.pp @@ -0,0 +1,17 @@ +Unit uw38385a; + +{$mode objfpc}{$H+} + +Interface + +Type + IInterface1 = Interface(IInterface) + Procedure p1(); + End; + +Implementation + + + +End. + diff --git a/avx512-0037785/tests/webtbs/uw38385b.pp b/avx512-0037785/tests/webtbs/uw38385b.pp new file mode 100644 index 0000000000..a4b5d9eca7 --- /dev/null +++ b/avx512-0037785/tests/webtbs/uw38385b.pp @@ -0,0 +1,18 @@ +unit uw38385b; + +{$mode objfpc}{$H+} + +interface + +uses + uw38385a; + +type + IInterface1 = Interface(uw38385a.IInterface1) + Procedure p2(); + End; + +implementation + +end. + diff --git a/avx512-0037785/tests/webtbs/uw38385c.pp b/avx512-0037785/tests/webtbs/uw38385c.pp new file mode 100644 index 0000000000..069d50f7f4 --- /dev/null +++ b/avx512-0037785/tests/webtbs/uw38385c.pp @@ -0,0 +1,18 @@ +Unit uw38385c; + +{$mode objfpc}{$H+} + +Interface + +Uses + uw38385a; + +Type + IInterface1 = Interface(uw38385a.IInterface1) + Procedure p3(); + End; + +Implementation + +End. + diff --git a/avx512-0037785/tests/webtbs/uw38429.pp b/avx512-0037785/tests/webtbs/uw38429.pp new file mode 100644 index 0000000000..0ec87fb766 --- /dev/null +++ b/avx512-0037785/tests/webtbs/uw38429.pp @@ -0,0 +1,88 @@ +unit uw38429; + +{$mode objfpc}{$H+} +{$modeswitch advancedrecords} + +interface + +uses + SysUtils, Variants; + +type + TMyVar = packed record + VType: TVarType; + Dummy1: array[0..2] of Word; + Dummy2, + Dummy3: Pointer; + procedure Init; + end; + + { TMyVariant } + + TMyVariant = class(TInvokeableVariantType) + procedure Copy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean); override; + procedure Clear(var V: TVarData); override; + procedure Cast(var Dest: TVarData; const Source: TVarData); override; + procedure CastTo(var Dest: TVarData; const Source: TVarData; const aVarType: TVarType); override; + end; + + function MyVarCreate: Variant; + + function varMyVar: TVarType; + +implementation + +var + MyVariant: TMyVariant; + +function MyVarCreate: Variant; +begin + VarClear(Result); + TMyVar(Result).Init; +end; + +function VarMyVar: TVarType; +begin + Result := MyVariant.VarType; +end; + +{ TMyVar } + +procedure TMyVar.Init; +begin + VType := VarMyVar; +end; + +{ TMyVariant } + +procedure TMyVariant.Copy(var Dest: TVarData; const Source: TVarData; + const Indirect: Boolean); +begin + Dest := Source; +end; + +procedure TMyVariant.Clear(var V: TVarData); +begin + TMyVar(v).VType := varEmpty; +end; + +procedure TMyVariant.Cast(var Dest: TVarData; const Source: TVarData); +begin + WriteLn('TMyVariant.Cast'); + VarClear(Variant(Dest)); + TMyVar(Dest).Init; +end; + +procedure TMyVariant.CastTo(var Dest: TVarData; const Source: TVarData; const aVarType: TVarType); +begin + WriteLn('TMyVariant.CastTo'); + VarClear(Variant(Dest)); + TVarData(Dest).VType := aVarType; +end; + +initialization + MyVariant := TMyVariant.Create; +finalization + MyVariant.Free; +end. + |