From 710ea0edf0f15fc7d9f4d12381a0cb8688d69029 Mon Sep 17 00:00:00 2001 From: peter Date: Fri, 23 Dec 2005 14:11:29 +0000 Subject: [PATCH] * fix enum support in vecn in symlists git-svn-id: trunk@2035 - --- .gitattributes | 3 + compiler/pdecvar.pas | 2 +- compiler/pexpr.pas | 6 +- compiler/symtype.pas | 21 +++--- tests/webtbs/tw4632.pp | 60 +++++++++++++++++ tests/webtbs/tw4633.pp | 146 +++++++++++++++++++++++++++++++++++++++++ tests/webtbs/tw4635.pp | 33 ++++++++++ 7 files changed, 258 insertions(+), 13 deletions(-) create mode 100755 tests/webtbs/tw4632.pp create mode 100755 tests/webtbs/tw4633.pp create mode 100755 tests/webtbs/tw4635.pp diff --git a/.gitattributes b/.gitattributes index 4b532aa562..c1568fa2bf 100644 --- a/.gitattributes +++ b/.gitattributes @@ -6642,6 +6642,9 @@ tests/webtbs/tw4566.pp -text svneol=unset#text/plain tests/webtbs/tw4599.pp svneol=native#text/plain tests/webtbs/tw4613.pp -text svneol=unset#text/plain tests/webtbs/tw4616.pp svneol=native#text/plain +tests/webtbs/tw4632.pp svneol=native#text/plain +tests/webtbs/tw4633.pp svneol=native#text/plain +tests/webtbs/tw4635.pp svneol=native#text/plain tests/webtbs/ub1873.pp svneol=native#text/plain tests/webtbs/ub1883.pp svneol=native#text/plain tests/webtbs/uw0555.pp svneol=native#text/plain diff --git a/compiler/pdecvar.pas b/compiler/pdecvar.pas index df345167e8..7c5cca25ee 100644 --- a/compiler/pdecvar.pas +++ b/compiler/pdecvar.pas @@ -175,7 +175,7 @@ implementation Message(type_e_ordinal_expr_expected) end; p.free; - pl.addconst(sl_vec,idx); + pl.addconst(sl_vec,idx,p.resulttype); def:=tarraydef(def).elementtype.def; end else diff --git a/compiler/pexpr.pas b/compiler/pexpr.pas index 41544ec7d3..5976de998e 100644 --- a/compiler/pexpr.pas +++ b/compiler/pexpr.pas @@ -186,7 +186,7 @@ implementation include(p1.flags,nf_absolute); end; sl_vec : - p1:=cvecnode.create(p1,cordconstnode.create(plist^.value,s32inttype,true)); + p1:=cvecnode.create(p1,cordconstnode.create(plist^.value,plist^.valuett,true)); else internalerror(200110205); end; @@ -219,12 +219,12 @@ implementation begin addnode(tvecnode(p).left); if tvecnode(p).right.nodetype=ordconstn then - sl.addconst(sl_vec,tordconstnode(tvecnode(p).right).value) + sl.addconst(sl_vec,tordconstnode(tvecnode(p).right).value,tvecnode(p).right.resulttype) else begin Message(parser_e_illegal_expression); { recovery } - sl.addconst(sl_vec,0); + sl.addconst(sl_vec,0,tvecnode(p).right.resulttype); end; end; loadn : diff --git a/compiler/symtype.pas b/compiler/symtype.pas index a23b374324..19c7292d69 100644 --- a/compiler/symtype.pas +++ b/compiler/symtype.pas @@ -164,7 +164,7 @@ interface next : psymlistitem; case byte of 0 : (sym : tsym; symderef : tderef); - 1 : (value : TConstExprInt); + 1 : (value : TConstExprInt; valuett: ttype); 2 : (tt : ttype); end; @@ -178,7 +178,7 @@ interface function empty:boolean; procedure addsym(slt:tsltype;p:tsym); procedure addsymderef(slt:tsltype;const d:tderef); - procedure addconst(slt:tsltype;v:TConstExprInt); + procedure addconst(slt:tsltype;v:TConstExprInt;const tt:ttype); procedure addtype(slt:tsltype;const tt:ttype); procedure clear; function getcopy:tsymlist; @@ -670,7 +670,7 @@ implementation end; - procedure tsymlist.addconst(slt:tsltype;v:TConstExprInt); + procedure tsymlist.addconst(slt:tsltype;v:TConstExprInt;const tt:ttype); var hp : psymlistitem; begin @@ -678,6 +678,7 @@ implementation fillchar(hp^,sizeof(tsymlistitem),0); hp^.sltype:=slt; hp^.value:=v; + hp^.valuett:=tt; if assigned(lastsym) then lastsym^.next:=hp else @@ -740,11 +741,10 @@ implementation sl_load, sl_subscript : hp^.sym:=tsym(hp^.symderef.resolve); + sl_vec, sl_absolutetype, sl_typeconv : hp^.tt.resolve; - sl_vec : - ; else internalerror(200110205); end; @@ -766,11 +766,10 @@ implementation sl_load, sl_subscript : hp^.symderef.build(hp^.sym); + sl_vec, sl_absolutetype, sl_typeconv : hp^.tt.buildderef; - sl_vec : - ; else internalerror(200110205); end; @@ -1226,7 +1225,8 @@ implementation sl_vec : begin idx:=getlongint; - p.addconst(slt,idx); + gettype(tt); + p.addconst(slt,idx,tt); end; else internalerror(200110204); @@ -1386,7 +1386,10 @@ implementation sl_typeconv : puttype(hp^.tt); sl_vec : - putlongint(hp^.value); + begin + putlongint(hp^.value); + puttype(hp^.valuett); + end; else internalerror(200110205); end; diff --git a/tests/webtbs/tw4632.pp b/tests/webtbs/tw4632.pp new file mode 100755 index 0000000000..783f8cb386 --- /dev/null +++ b/tests/webtbs/tw4632.pp @@ -0,0 +1,60 @@ +{ Source provided for Free Pascal Bug Report 4632 } +{ Submitted by "Graeme Geldenhuys" on 2005-12-23 } +{ e-mail: graemeg@gmail.com } +program Project1; + +{$mode objfpc}{$H+} + +uses + Classes, SysUtils; + +var + err : boolean; + +procedure Error(const s:string); +begin + writeln(s); + err:=true; +end; + +{ Fixed version of ExtractFileName function } +function lExtractFileName(const FileName: string): string; +var + i: longint; +begin + I := LastDelimiter(PathDelim + DriveDelim, FileName); + Result := Copy(FileName, I + 1, MaxInt); +end; + +var + name, s: string; + i: integer; + +const + ext = '.txt'; + +begin + name := ''; + for i := 1 to 251 do + name := name + 'a'; // complete name of 255 chars + + s := ExtractFileName(name + ext); + if Length(s) <> 255 then + Error('Failed on 1'); + + s := lExtractFileName(name + ext); + if Length(s) <> 255 then + Error('Failed on 2'); + + name := name + 'a'; // complete name on 256 chars + s := ExtractFileName(name + ext); + if Length(s) <> 256 then + Error('Failed on 3'); + + s := lExtractFileName(name + ext); + if Length(s) <> 256 then + Error('Failed on 4'); + + if err then + halt(1); +end. \ No newline at end of file diff --git a/tests/webtbs/tw4633.pp b/tests/webtbs/tw4633.pp new file mode 100755 index 0000000000..9d10e4a208 --- /dev/null +++ b/tests/webtbs/tw4633.pp @@ -0,0 +1,146 @@ +{$mode objfpc}{$H+} + +uses + Classes, SysUtils, Variants; + +var + err : boolean; + +function IsVariantOfType( pVariant : Variant ; pVarType : TVarType ) : +boolean ; +var + xVT : TVarType; + xVTHigh : TVarType; +// xVTLow : TVarType; +begin +// result := ( varType( pVariant ) and pVarType ) = pVarType ; +// Contr: VarType is varDate = 0007, pVarType is varInteger=0003. +// 0007 and 0003 = 0003. WRONG! + + xVT := VarType(pVariant); +// xVTLow:=xVT and varTypeMask; + xVTHigh := xVT and (not varTypeMask); + + // in true pVarType can be and OR of two types: varArray and varString (or others) + // we have to recognize it. + // there shouldn't be xVTLow because when we have array of string (normal) then + // xVT=$2008 = $2000 (var Array) or $0008 (var String) + // then when we asked: + // is $2000 (varArray)? we should receive TRUE (xVTHigh=pVarType) + // is $2008 (varArray of varString)? we should receive TRUE (xVT=pVarType) + // is $0008 (varString)? we should receive FALSE + Result := (xVT=pVarType) or ((xVTHigh=pVarType) and (xVTHigh<>varEmpty)); +end ; + +procedure TestIsVariantOfType ; + + procedure _tiIsVariantOfType(xVar : variant; xExpected : TVarType; xMsg : string); + + procedure __tiIsVariantOfType(xxCheck : TVarType; xxMsg : string); + begin + if xxCheck=xExpected then + begin + If not IsVariantOfType( xVar, xxCheck ) then + begin + Writeln(xMsg); + err:=true; + end; + end + else + begin + If IsVariantOfType( xVar, xxCheck ) then + begin + Writeln(xMsg + ' - ' + xxMsg); + err:=true; + end; + end; + end; + + begin + __tiIsVariantOfType(varEmpty,'varEmpty'); + __tiIsVariantOfType(varNull,'varNull'); + __tiIsVariantOfType(varSmallint,'varSmallInt'); + __tiIsVariantOfType(varInteger,'varInteger'); + __tiIsVariantOfType(varSingle,'varSingle'); + __tiIsVariantOfType(varDouble,'varDouble'); + __tiIsVariantOfType(varDate,'varDate'); + __tiIsVariantOfType(varBoolean,'varBoolean'); + __tiIsVariantOfType(varOleStr,'varOleStr'); + end; +var + lVar : Variant ; + lSmallInt : Smallint; + lInteger : Integer; + lDouble : Double; + lDateTimeNow : TDateTime; + lDateTimeDate : TDateTime; + lOleString : WideString; + lString : string; + lBoolean : boolean; + lCurrency : Currency; +begin + lSmallInt := 123; + lInteger := High(Integer); + lDouble := 123.45678901234567890; + lDateTimeNow := Now; + lDateTimeDate := Date; + lOleString := 'OLE STRING TEST'; + lString := 'STRING TEST'; + lBoolean := true; + lCurrency := 12345678.9876; + + lVar := Unassigned; + _tiIsVariantOfType(lVar,varEmpty,'Failed with varEmpty'); + + lVar := Null ; + _tiIsVariantOfType(lVar,varNull,'Failed with varNull'); + + // There is no other way to receive variant of type small int... + lVar:=VarAsType(lSmallInt,varSmallint); + _tiIsVariantOfType(lVar,varSmallInt,'Failed with VarSmallint'); + + lVar:=lInteger; + _tiIsVariantOfType(lVar,varInteger,'Failed with Integer'); + +// Can't make this one work + lVar:=VarAsType(123.456,varSingle); + _tiIsVariantOfType(lVar,varSingle,'Failed with VarSingle'); + + lVar:=lDouble; + _tiIsVariantOfType(lVar,varDouble,'Failed with VarDouble'); + + lVar:=lDateTimeDate; + _tiIsVariantOfType(lVar,varDate,'Failed with varDate - DATE'); + + lVar:=lDateTimeNow; + _tiIsVariantOfType(lVar,varDate,'Failed with varDate - NOW'); + + lVar:=lBoolean; + _tiIsVariantOfType(lVar,varBoolean,'Failed with varBoolean'); + + lVar:=lOleString; + _tiIsVariantOfType(lVar,varOLEStr,'Failed with varOLEStr'); + + lVar := lString; + _tiIsVariantOfType(lVar, varString, 'Failed with varString'); + + lVar:=lCurrency; + _tiIsVariantOfType(lVar,varCurrency,'Failed with varCurrency'); + +// These ones have not been tested +// varCurrency Currency floating-point value (type Currency). +// varDispatch Reference to an Automation object (an IDispatch interface pointer). +// varError Operating system error code. +// varUnknown Reference to an unknown COM object (an IUnknown interface pointer). +// varByte 8-bit unsigned integer (type Byte). +// varTypeMask Bit mask for extracting type code. +// varArray Bit indicating variant array. +// varByRef Bit indicating variant contains a reference (rather than a value). +end; + + +begin + TestIsVariantOfType; + if err then + halt(1); +end. diff --git a/tests/webtbs/tw4635.pp b/tests/webtbs/tw4635.pp new file mode 100755 index 0000000000..56f41df593 --- /dev/null +++ b/tests/webtbs/tw4635.pp @@ -0,0 +1,33 @@ +{ Source provided for Free Pascal Bug Report 4635 } +{ Submitted by "Ales Katona" on 2005-12-23 } +{ e-mail: almindor@gmail.com } +program p1; + +{$mode objfpc}{$H+} + +type + TTestEnum = (Enum1, Enum2); + + TTest = class + protected + FArray: array[TTestEnum] of Boolean; + procedure SetTestB(const Value: Boolean); + public + property TestB: Boolean read FArray[Enum1] write SetTestB; + end; + +procedure TTest.SetTestB(const Value: Boolean); +begin + FArray[Enum1]:=Value; +end; + +var + t1: TTest; +begin + t1:=TTest.Create; + t1.TestB:=true; + Writeln(t1.TestB); // it doesn't compile here, but if you comment this line it works + if not t1.TestB then + halt; + t1.Free; +end.