* fix enum support in vecn in symlists

git-svn-id: trunk@2035 -

.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

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

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 :

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;

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: [email protected] }
+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.

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.

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: [email protected] }
+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.