* synchronized with trunk

git-svn-id: branches/wasm@47525 -

.gitattributes

@@ -14471,6 +14471,7 @@ tests/test/packages/webtbs/tw14265.pp svneol=native#text/plain
 tests/test/packages/webtbs/tw1808.pp svneol=native#text/plain
 tests/test/packages/webtbs/tw3820.pp svneol=native#text/plain
 tests/test/packages/win-base/tdispvar1.pp svneol=native#text/plain
+tests/test/packages/win-base/tdispvar2.pp svneol=native#text/pascal
 tests/test/packages/zlib/tzlib1.pp svneol=native#text/plain
 tests/test/t4cc1.pp svneol=native#text/plain
 tests/test/t4cc2.pp svneol=native#text/plain

compiler/defutil.pas

@@ -1358,7 +1358,10 @@ implementation
                    (tarraydef(p).elementdef.typ=floatdef) and
                    (
                     (tarraydef(p).lowrange=0) and
-                    (tarraydef(p).highrange=3) and
+                    ((tarraydef(p).highrange=3) or
+                     (UseAVX and (tarraydef(p).highrange=7)) or
+                     (UseAVX512 and (tarraydef(p).highrange=15))
+                    ) and
                     (tfloatdef(tarraydef(p).elementdef).floattype=s32real)
                    )
                   ) or
@@ -1367,7 +1370,10 @@ implementation
                    (tarraydef(p).elementdef.typ=floatdef) and
                    (
                     (tarraydef(p).lowrange=0) and
-                    (tarraydef(p).highrange=1) and
+                    ((tarraydef(p).highrange=1) or
+                     (UseAVX and (tarraydef(p).highrange=3)) or
+                     (UseAVX512 and (tarraydef(p).highrange=7))
+                    )and
                     (tfloatdef(tarraydef(p).elementdef).floattype=s64real)
                    )
                   ) {or

compiler/ncnv.pas

@@ -322,7 +322,7 @@ implementation
       globtype,systems,constexp,compinnr,
       cutils,verbose,globals,widestr,ppu,
       symconst,symdef,symsym,symcpu,symtable,
-      ncon,ncal,nset,nadd,nmem,nmat,nbas,nutils,ninl,
+      ncon,ncal,nset,nadd,nmem,nmat,nbas,nutils,ninl,nflw,
       cgbase,procinfo,
       htypechk,blockutl,pass_1,cpuinfo;
 
@@ -2872,6 +2872,9 @@ implementation
 
     function checkremovebiginttypeconvs(n: tnode; out gotsint: boolean;validints : tordtypeset;const l,h : Tconstexprint): boolean;
       var
+        gotminus1,
+        gotsigned,
+        gotunsigned,
         gotdivmod: boolean;
 
       { checks whether a node has an accepted resultdef, or originally
@@ -2880,6 +2883,13 @@ implementation
         begin
           if (n.resultdef.typ<>orddef) then
             exit(false);
+          gotsigned:=gotsigned or is_signed(n.resultdef);
+          gotunsigned:=gotunsigned or not(is_signed(n.resultdef));
+          { actually, we should only check right (denominator) nodes here, but
+            setting it always is a safe approximation }
+          if ((n.nodetype=ordconstn) and
+            (tordconstnode(n).value=-1)) then
+            gotminus1:=true;
           if (torddef(n.resultdef).ordtype in validints) then
             begin
               if is_signed(n.resultdef) then
@@ -2904,7 +2914,12 @@ implementation
                   is_signed(ttypeconvnode(n).left.resultdef)) or
                  ((n.nodetype=ordconstn) and
                   (tordconstnode(n).value<0)) then
-                gotsint:=true;
+                begin
+                  gotsint:=true;
+                  gotsigned:=true;
+                end
+              else
+                gotunsigned:=true;
               exit(true);
             end;
           result:=false;
@@ -2938,11 +2953,11 @@ implementation
                   gotdivmod:=true;
                 result:=
                   (docheckremoveinttypeconvs(tbinarynode(n).left) and
-                   docheckremoveinttypeconvs(tbinarynode(n).right)) or
-                  { in case of div/mod, the result of that division/modulo can
-                    usually be different in 32 and 64 bit }
-                  (not gotdivmod and
-                   (((n.nodetype=andn) and wasoriginallysmallerint(tbinarynode(n).left)) or
+                   docheckremoveinttypeconvs(tbinarynode(n).right) and
+
+                   (not(n.nodetype in [modn,divn]) or (not(gotminus1)))
+                  ) or
+                  ((((n.nodetype=andn) and wasoriginallysmallerint(tbinarynode(n).left)) or
                     ((n.nodetype=andn) and wasoriginallysmallerint(tbinarynode(n).right))));
               end;
             else
@@ -2953,14 +2968,22 @@ implementation
       begin { checkremove64bittypeconvs }
         gotdivmod:=false;
         gotsint:=false;
+        gotminus1:=false;
+        gotsigned:=false;
+        gotunsigned:=false;
         result:=
           docheckremoveinttypeconvs(n) and
-          not(gotdivmod and gotsint);
+          (not(gotdivmod) or (gotsigned xor gotunsigned));
       end;
 
 
     { remove int type conversions and set the result to the given type }
     procedure doremoveinttypeconvs(var n: tnode; todef: tdef; forceunsigned: boolean; signedtype,unsignedtype : tdef);
+      var
+        newblock: tblocknode;
+        newstatements: tstatementnode;
+        originaldivtree: tnode;
+        tempnode: ttempcreatenode;
       begin
         case n.nodetype of
           subn,addn,muln,divn,modn,xorn,andn,orn:
@@ -2969,9 +2992,34 @@ implementation
               if not forceunsigned and
                  is_signed(n.resultdef) then
                 begin
+                  originaldivtree:=nil;
+                  if n.nodetype in [divn,modn] then
+                    originaldivtree:=n.getcopy;
                   doremoveinttypeconvs(tbinarynode(n).left,signedtype,false,signedtype,unsignedtype);
                   doremoveinttypeconvs(tbinarynode(n).right,signedtype,false,signedtype,unsignedtype);
                   n.resultdef:=signedtype;
+                  if n.nodetype in [divn,modn] then
+                    begin
+                      newblock:=internalstatements(newstatements);
+                      tempnode:=ctempcreatenode.create(n.resultdef,n.resultdef.size,tt_persistent,true);
+                      addstatement(newstatements,tempnode);
+                      addstatement(newstatements,cifnode.create_internal(
+                        caddnode.create_internal(equaln,tbinarynode(n).right.getcopy,cordconstnode.create(-1,n.resultdef,false)),
+                          cassignmentnode.create_internal(
+                            ctemprefnode.create(tempnode),
+                            cmoddivnode.create(n.nodetype,tbinarynode(originaldivtree).left.getcopy,cordconstnode.create(-1,tbinarynode(originaldivtree).right.resultdef,false))
+                          ),
+                          cassignmentnode.create_internal(
+                            ctemprefnode.create(tempnode),n
+                          )
+                        )
+                      );
+                      addstatement(newstatements,ctempdeletenode.create_normal_temp(tempnode));
+                      addstatement(newstatements,ctemprefnode.create(tempnode));
+                      n:=newblock;
+                      do_typecheckpass(n);
+                      originaldivtree.free;
+                    end;
                 end
               else
                 begin

compiler/options.pas

@@ -3417,6 +3417,11 @@ begin
       not LinkerSetExplicitly then
      include(init_settings.globalswitches,cs_link_vlink);
 {$endif}
+{$ifdef m68k}
+   if (target_info.system in [system_m68k_sinclairql]) and
+      not LinkerSetExplicitly then
+     include(init_settings.globalswitches,cs_link_vlink);
+{$endif m68k}
 end;
 
 procedure TOption.checkoptionscompatibility;

compiler/x86/aasmcpu.pas

@@ -4784,6 +4784,16 @@ implementation
                 R_SUBQ,
                 R_SUBMMWHOLE:
                   result:=taicpu.op_ref_reg(A_VMOVQ,S_NO,tmpref,r);
+                R_SUBMMY:
+                   if ref.alignment>=32 then
+                     result:=taicpu.op_ref_reg(A_VMOVDQA,S_NO,tmpref,r)
+                   else
+                     result:=taicpu.op_ref_reg(A_VMOVDQU,S_NO,tmpref,r);
+                R_SUBMMZ:
+                   if ref.alignment>=64 then
+                     result:=taicpu.op_ref_reg(A_VMOVDQA64,S_NO,tmpref,r)
+                   else
+                     result:=taicpu.op_ref_reg(A_VMOVDQU64,S_NO,tmpref,r);
                 R_SUBMMX:
                   result:=taicpu.op_ref_reg(A_VMOVDQU,S_NO,tmpref,r);
                 else
@@ -4843,6 +4853,16 @@ implementation
                   result:=taicpu.op_reg_ref(A_VMOVSD,S_NO,r,tmpref);
                 R_SUBMMS:
                   result:=taicpu.op_reg_ref(A_VMOVSS,S_NO,r,tmpref);
+                R_SUBMMY:
+                   if ref.alignment>=32 then
+                     result:=taicpu.op_reg_ref(A_VMOVDQA,S_NO,r,tmpref)
+                   else
+                     result:=taicpu.op_reg_ref(A_VMOVDQU,S_NO,r,tmpref);
+                R_SUBMMZ:
+                   if ref.alignment>=64 then
+                     result:=taicpu.op_reg_ref(A_VMOVDQA64,S_NO,r,tmpref)
+                   else
+                     result:=taicpu.op_reg_ref(A_VMOVDQU64,S_NO,r,tmpref);
                 R_SUBQ,
                 R_SUBMMWHOLE:
                   result:=taicpu.op_reg_ref(A_VMOVQ,S_NO,r,tmpref);

compiler/x86/cgx86.pas

@@ -1399,7 +1399,12 @@ unit cgx86;
               OS_M512:
                 { 256-bit aligned vector }
                 if UseAVX then
-                  result:=A_VMOVAPS
+                  begin
+                    if aligned then
+                      result:=A_VMOVAPS
+                    else
+                      result:=A_VMOVUPS;
+                  end
                 else
                   { SSE does not support 256-bit or 512-bit vectors }
                   InternalError(2018012930);

packages/fcl-passrc/src/pastree.pp

@@ -534,6 +534,7 @@ type
     procedure ClearTypeReferences(aType: TPasElement); override;
   public
     DestType: TPasType;
+    SubType: TPasType;
     Expr: TPasExpr;
   end;
 
@@ -1168,7 +1169,8 @@ type
     otBitwiseAnd, otbitwiseXor,
     otLogicalAnd, otLogicalNot, otLogicalXor,
     otRightShift,
-    otEnumerator, otIn
+    otEnumerator, otIn,
+    otInitialize // Management operator
     );
   TOperatorTypes = set of TOperatorType;
 
@@ -1750,13 +1752,13 @@ const
            '>',':=','<>','<=','>=','**',
            '><','Inc','Dec','mod','-','+','Or','div',
            'shl','or','and','xor','and','not','xor',
-           'shr','enumerator','in');
+           'shr','enumerator','in','');
   OperatorNames : Array[TOperatorType] of string
        =  ('','implicit','explicit','multiply','add','subtract','divide','lessthan','equal',
            'greaterthan','assign','notequal','lessthanorequal','greaterthanorequal','power',
            'symmetricaldifference','inc','dec','modulus','negative','positive','bitwiseor','intdivide',
            'leftshift','logicalor','bitwiseand','bitwisexor','logicaland','logicalnot','logicalxor',
-           'rightshift','enumerator','in');
+           'rightshift','enumerator','in','initialize');
 
   AssignKindNames : Array[TAssignKind] of string = (':=','+=','-=','*=','/=' );
 
@@ -2835,7 +2837,9 @@ begin
         Result := Result + ', ';
       Result := Result + TPasArgument(ProcType.Args[i]).ArgType.Name;
       end;
-    Result := Result + '): ' + TPasFunctionType(ProcType).ResultEl.ResultType.Name;
+    Result := Result + ')';
+    if (OperatorType<>otInitialize) and Assigned(TPasFunctionType(ProcType).ResultEl.ResultType) then
+       Result:=Result+': ' + TPasFunctionType(ProcType).ResultEl.ResultType.Name;
     If WithPath then
       begin
       S:=Self.ParentPath;
@@ -3303,6 +3307,7 @@ end;
 
 destructor TPasAliasType.Destroy;
 begin
+  ReleaseAndNil(TPasElement(SubType){$IFDEF CheckPasTreeRefCount},'TPasAliasType.SubType'{$ENDIF});
   ReleaseAndNil(TPasElement(DestType){$IFDEF CheckPasTreeRefCount},'TPasAliasType.DestType'{$ENDIF});
   ReleaseAndNil(TPasElement(Expr){$IFDEF CheckPasTreeRefCount},'TPasAliasType.Expr'{$ENDIF});
   inherited Destroy;

packages/fcl-passrc/src/paswrite.pp

@@ -1408,11 +1408,11 @@ end;
 
 procedure TPasWriter.WriteImplRaise(aRaise: TPasImplRaise);
 begin
-  if  assigned(aRaise.ExceptObject) then
+  if assigned(aRaise.ExceptObject) then
     begin
-      Add('raise %s',[GetExpr(aRaise.ExceptObject)]);
-      if aRaise.ExceptAddr<>Nil then
-        Add(' at %s',[GetExpr(aRaise.ExceptAddr)]);
+    Add('raise %s',[GetExpr(aRaise.ExceptObject)]);
+    if aRaise.ExceptAddr<>Nil then
+      Add(' at %s',[GetExpr(aRaise.ExceptAddr)]);
     end
   else
     Add('raise');

packages/fcl-passrc/src/pparser.pp

@@ -1759,12 +1759,20 @@ begin
       end;
     // read nested specialize arguments
     ReadSpecializeArguments(ST,ST.Params);
-    // Important: resolve type reference AFTER args, because arg count is needed
-    ST.DestType:=ResolveTypeReference(GenName,ST,ST.Params.Count);
-
     if CurToken<>tkGreaterThan then
       ParseExcTokenError('[20190801113005]');
-    // ToDo: cascaded specialize A<B>.C<D>
+
+    // Check for cascaded specialize A<B>.C or A<B>.C<D>
+    NextToken;
+    if CurToken<>tkDot then
+      UnGetToken
+    else
+      begin
+      NextToken;
+      ST.SubType:=ParseSimpleType(ST,CurSourcePos,GenName,False);
+      end;
+    // Important: resolve type reference AFTER args, because arg count is needed
+    ST.DestType:=ResolveTypeReference(GenName,ST,ST.Params.Count);
 
     Engine.FinishScope(stTypeDef,ST);
     Result:=ST;
@@ -5348,13 +5356,17 @@ begin
         begin
         ResultEl.Name := CurTokenName;
         ExpectToken(tkColon);
-        end
-      else
-        if (CurToken=tkColon) then
-          ResultEl.Name := 'Result'
-        else
-          ParseExc(nParserExpectedColonID,SParserExpectedColonID);
         ResultEl.ResultType := ParseType(ResultEl,CurSourcePos);
+        end
+      else if not ((Parent is TPasOperator) and (TPasOperator(Parent).OperatorType=otInitialize)) then
+        // Initialize operator has no result
+        begin
+         if (CurToken=tkColon) then
+            ResultEl.Name := 'Result'
+          else
+            ParseExc(nParserExpectedColonID,SParserExpectedColonID);
+         ResultEl.ResultType := ParseType(ResultEl,CurSourcePos);
+         end;
       end;
   else
     ResultEl:=Nil;
@@ -6846,6 +6858,24 @@ var
     Scanner.UnSetTokenOption(toOperatorToken);
   end;
 
+  Function CheckSection : Boolean;
+
+  begin
+    // Advanced records can have empty sections.
+    { Use Case:
+      Record
+      type
+      const
+      var
+      Case Integer of
+      end;
+    }
+    NextToken;
+    Result:=CurToken in [tkvar,tktype,tkConst,tkCase];
+    if Not Result then
+      UngetToken;
+  end;
+
 Var
   VariantName : String;
   v : TPasMemberVisibility;
@@ -6857,7 +6887,10 @@ Var
   CurEl: TPasElement;
   LastToken: TToken;
   AllowVisibility: Boolean;
+  IsGeneric : Boolean;
+
 begin
+  IsGeneric:=False;
   AllowVisibility:=msAdvancedRecords in CurrentModeswitches;
   if AllowVisibility then
     v:=visPublic
@@ -6874,6 +6907,8 @@ begin
         DisableIsClass;
         if Not AllowMethods then
           ParseExc(nErrRecordTypesNotAllowed,SErrRecordTypesNotAllowed);
+        if CheckSection then
+          continue;
         ExpectToken(tkIdentifier);
         ParseMembersLocalTypes(ARec,v);
         end;
@@ -6882,6 +6917,8 @@ begin
         DisableIsClass;
         if Not AllowMethods then
           ParseExc(nErrRecordConstantsNotAllowed,SErrRecordConstantsNotAllowed);
+        if CheckSection then
+          continue;
         ExpectToken(tkIdentifier);
         ParseMembersLocalConsts(ARec,v);
         end;
@@ -6889,6 +6926,8 @@ begin
         begin
         if Not AllowMethods then
           ParseExc(nErrRecordVariablesNotAllowed,SErrRecordVariablesNotAllowed);
+        if CheckSection then
+          continue;
         ExpectToken(tkIdentifier);
         OldCount:=ARec.Members.Count;
         ParseInlineVarDecl(ARec, ARec.Members, v, AEndToken=tkBraceClose);
@@ -6937,7 +6976,7 @@ begin
         if Not AllowMethods then
           ParseExc(nErrRecordMethodsNotAllowed,SErrRecordMethodsNotAllowed);
         ProcType:=GetProcTypeFromToken(CurToken,LastToken=tkclass);
-        Proc:=ParseProcedureOrFunctionDecl(ARec,ProcType,false,v);
+        Proc:=ParseProcedureOrFunctionDecl(ARec,ProcType,IsGeneric,v);
         if Proc.Parent is TPasOverloadedProc then
           TPasOverloadedProc(Proc.Parent).Overloads.Add(Proc)
         else
@@ -6946,9 +6985,21 @@ begin
         end;
       tkDestructor:
         ParseExc(nParserNoConstructorAllowed,SParserNoConstructorAllowed);
-      tkabsolute,tkGeneric,tkSelf, // Counts as field name
+      tkGeneric, // Can count as field name
+      tkabsolute,
+      tkSelf, // Count as field name
       tkIdentifier :
         begin
+        if (Curtoken=tkGeneric) and AllowVisibility then
+          begin
+          NextToken;
+          if CurToken in [tkClass,tkOperator,tkFunction,tkProcedure] then
+            begin
+            IsGeneric:=True;
+            Continue;
+            end;
+          UnGetToken;
+          end;
         If AllowVisibility and CheckVisibility(CurTokenString,v) then
           begin
           if not (v in [visPrivate,visPublic,visStrictPrivate]) then
@@ -7002,6 +7053,8 @@ begin
       break;
     LastToken:=CurToken;
     NextToken;
+    if not IsClass then
+      IsGeneric:=False;
     end;
 end;
 

packages/fcl-passrc/tests/tcprocfunc.pas

@@ -178,6 +178,7 @@ type
     Procedure TestProcedureCdeclExternalName;
     Procedure TestFunctionCdeclExternalName;
     Procedure TestFunctionAlias;
+    Procedure TestOperatorNamedResult;
     Procedure TestOperatorTokens;
     procedure TestOperatorNames;
     Procedure TestAssignOperatorAfterObject;
@@ -1312,6 +1313,13 @@ begin
   AssertEquals('Alias name','''myalias''',Func.AliasName);
 end;
 
+procedure TTestProcedureFunction.TestOperatorNamedResult;
+begin
+  AddDeclaration('operator = (a,b : T) z : Integer;');
+  ParseOperator;
+  AssertEquals('Correct operator type',otEqual,FOperator.OperatorType);
+end;
+
 procedure TTestProcedureFunction.TestProcedureAlias;
 begin
   AddDeclaration('Procedure A; Alias : ''myalias''');
@@ -1328,23 +1336,25 @@ Var
 
 begin
   For t:=otMul to High(TOperatorType) do
+    begin
+    if OperatorTokens[t]='' then continue;
     // No way to distinguish between logical/bitwise or/and/Xor
-    if not (t in [otBitwiseOr,otBitwiseAnd,otBitwiseXor]) then
-      begin
-      S:=GetEnumName(TypeInfo(TOperatorType),Ord(T));
-      ResetParser;
-      if t in UnaryOperators then
-        AddDeclaration(Format('operator %s (a: Integer) : te',[OperatorTokens[t]]))
-      else
-        AddDeclaration(Format('operator %s (a: Integer; b: integer) : te',[OperatorTokens[t]]));
-      ParseOperator;
-      AssertEquals(S+': Token based ',Not (T in [otInc,otDec,otEnumerator]),FOperator.TokenBased);
-      AssertEquals(S+': Correct operator type',T,FOperator.OperatorType);
-      if t in UnaryOperators then
-        AssertEquals(S+': Correct operator name',format('%s(Integer):te',[OperatorNames[t]]),FOperator.Name)
-      else
-        AssertEquals(S+': Correct operator name',format('%s(Integer,Integer):te',[OperatorNames[t]]),FOperator.Name);
-      end;
+    if t in [otBitWiseOr,otBitwiseAnd,otbitwiseXor] then continue;
+
+    S:=GetEnumName(TypeInfo(TOperatorType),Ord(T));
+    ResetParser;
+    if t in UnaryOperators then
+      AddDeclaration(Format('operator %s (a: Integer) : te',[OperatorTokens[t]]))
+    else
+      AddDeclaration(Format('operator %s (a: Integer; b: integer) : te',[OperatorTokens[t]]));
+    ParseOperator;
+    AssertEquals(S+': Token based ',Not (T in [otInc,otDec,otEnumerator]),FOperator.TokenBased);
+    AssertEquals(S+': Correct operator type',T,FOperator.OperatorType);
+    if t in UnaryOperators then
+      AssertEquals(S+': Correct operator name',format('%s(Integer):te',[OperatorNames[t]]),FOperator.Name)
+    else
+      AssertEquals(S+': Correct operator name',format('%s(Integer,Integer):te',[OperatorNames[t]]),FOperator.Name);
+    end;
 end;
 
 procedure TTestProcedureFunction.TestOperatorNames;
@@ -1355,21 +1365,25 @@ Var
 
 begin
   For t:=Succ(otUnknown) to High(TOperatorType) do
-      begin
-      S:=GetEnumName(TypeInfo(TOperatorType),Ord(T));
-      ResetParser;
-      if t in UnaryOperators then
-        AddDeclaration(Format('operator %s (a: Integer) : te',[OperatorNames[t]]))
-      else
-        AddDeclaration(Format('operator %s (a: Integer; b: integer) : te',[OperatorNames[t]]));
-      ParseOperator;
-      AssertEquals(S+': Token based',t in [otIn],FOperator.TokenBased);
-      AssertEquals(S+': Correct operator type',T,FOperator.OperatorType);
-      if t in UnaryOperators then
-        AssertEquals('Correct operator name',format('%s(Integer):te',[OperatorNames[t]]),FOperator.Name)
-      else
-        AssertEquals('Correct operator name',format('%s(Integer,Integer):te',[OperatorNames[t]]),FOperator.Name);
-      end;
+    begin
+    if OperatorNames[t]='' then continue;
+    // otInitialize has no result
+    if t=otInitialize then continue;
+    writeln('TTestProcedureFunction.TestOperatorTokens ',t);
+    S:=GetEnumName(TypeInfo(TOperatorType),Ord(T));
+    ResetParser;
+    if t in UnaryOperators then
+      AddDeclaration(Format('operator %s (a: Integer) : te',[OperatorNames[t]]))
+    else
+      AddDeclaration(Format('operator %s (a: Integer; b: integer) : te',[OperatorNames[t]]));
+    ParseOperator;
+    AssertEquals(S+': Token based',t in [otIn],FOperator.TokenBased);
+    AssertEquals(S+': Correct operator type',T,FOperator.OperatorType);
+    if t in UnaryOperators then
+      AssertEquals('Correct operator name',format('%s(Integer):te',[OperatorNames[t]]),FOperator.Name)
+    else
+      AssertEquals('Correct operator name',format('%s(Integer,Integer):te',[OperatorNames[t]]),FOperator.Name);
+    end;
 end;
 
 procedure TTestProcedureFunction.TestAssignOperatorAfterObject;

packages/fcl-passrc/tests/tcresolvegenerics.pas

@@ -1932,7 +1932,7 @@ begin
   '  PRec = ^specialize TRec<word>;',
   'begin',
   '']);
-  CheckParserException('Expected "Identifier" at token "specialize" in file afile.pp at line 4 column 11',nParserExpectTokenError);
+  CheckParserException('Expected "Identifier or file"',nParserExpectTokenError);
 end;
 
 procedure TTestResolveGenerics.TestGen_HelperForArray;

packages/fcl-passrc/tests/tcresolver.pas

@@ -16489,7 +16489,7 @@ begin
   Add([
   'type p = ^(red, green);',
   'begin']);
-  CheckParserException('Expected "Identifier" at token "(" in file afile.pp at line 2 column 11',
+  CheckParserException('Expected "Identifier or file"',
     nParserExpectTokenError);
 end;
 

packages/fcl-passrc/tests/tctypeparser.pas

@@ -363,9 +363,13 @@ type
     Procedure TestAdvRec_ProcOverrideFail;
     Procedure TestAdvRec_ProcMessageFail;
     Procedure TestAdvRec_DestructorFail;
+    Procedure TestAdvRec_CaseInVar;
+    Procedure TestAdvRec_EmptySections;
     Procedure TestAdvRecordInFunction;
     Procedure TestAdvRecordInAnonFunction;
     Procedure TestAdvRecordClassOperator;
+    Procedure TestAdvRecordInitOperator;
+    Procedure TestAdvRecordGenericFunction;
   end;
 
   { TTestProcedureTypeParser }
@@ -2612,6 +2616,29 @@ begin
   ParseRecordFail(SParserNoConstructorAllowed,nParserNoConstructorAllowed);
 end;
 
+procedure TTestRecordTypeParser.TestAdvRec_CaseInVar;
+
+// Found in System.UITypes.pas
+
+begin
+  StartRecord(true);
+  AddMember('var');
+  AddMember('Case Integer of');
+  AddMember('  1 : (x: integer);');
+  AddMember('  2 : (y,z: integer)');
+  ParseRecord;
+end;
+
+procedure TTestRecordTypeParser.TestAdvRec_EmptySections;
+begin
+  StartRecord(true);
+  AddMember('const');
+  AddMember('type');
+  AddMember('var');
+  AddMember('  x: integer;');
+  ParseRecord;
+end;
+
 procedure TTestRecordTypeParser.TestAdvRecordInFunction;
 
 // Src from bug report 36179
@@ -2690,6 +2717,51 @@ begin
   ParseModule;   // We're just interested in that it parses.
 end;
 
+procedure TTestRecordTypeParser.TestAdvRecordInitOperator;
+// Source from bug id 36180
+
+Const
+   SRC =
+    '{$mode objfpc}'+sLineBreak+
+    '{$modeswitch advancedrecords}'+sLineBreak+
+    'program afile;'+sLineBreak+
+    'type'+sLineBreak+
+    '  TMyRecord = record'+sLineBreak+
+    '    class operator initialize (var self: TMyRecord);'+sLineBreak+
+    '  end;'+sLineBreak+
+    'class operator TMyRecord.initialize (a, b: TMyRecord);'+sLineBreak+
+    'begin'+sLineBreak+
+    '  result := (@a = @b);'+sLineBreak+
+    'end;'+sLineBreak+
+    'begin'+sLineBreak+
+    'end.';
+
+begin
+  Source.Text:=Src;
+  ParseModule;   // We're just interested in that it parses.
+end;
+
+procedure TTestRecordTypeParser.TestAdvRecordGenericFunction;
+
+Const
+   SRC =
+    '{$mode objfpc}'+sLineBreak+
+    '{$modeswitch advancedrecords}'+sLineBreak+
+    'program afile;'+sLineBreak+
+    'type'+sLineBreak+
+    '  TMyRecord = record'+sLineBreak+
+    '    generic class procedure doit<T> (a: T);'+sLineBreak+
+    '  end;'+sLineBreak+
+    'generic class procedure TMyRecord.DoIt<T>(a: T);'+sLineBreak+
+    'begin'+sLineBreak+
+    'end;'+sLineBreak+
+    'begin'+sLineBreak+
+    'end.';
+begin
+  Source.Text:=Src;
+  ParseModule;   // We're just interested in that it parses.
+end;
+
 { TBaseTestTypeParser }
 
 Function TBaseTestTypeParser.ParseType(ASource: String; ATypeClass: TClass;

packages/pastojs/src/pas2jsfiler.pp

@@ -485,7 +485,8 @@ const
     'LogicalXor',
     'RightShift',
     'Enumerator',
-    'In'
+    'In',
+    'Initialize'
     );
 
   PCUProcedureModifierNames: array[TProcedureModifier] of string = (

packages/winunits-base/src/comobj.pp

@@ -1184,7 +1184,7 @@ HKCR
         { we can't pass pascal ansistrings to COM routines so we've to convert them
           to/from widestring. This array contains the mapping to do so
         }
-        StringMap : array[0..255] of record passtr : pansistring; comstr : pwidechar; end;
+        StringMap : array[0..255] of record passtr : pansistring; paswstr : punicodestring; comstr : pwidechar; end;
         invokekind,
         i : longint;
         invokeresult : HResult;
@@ -1210,7 +1210,7 @@ HKCR
               writeln('DispatchInvoke: Params = ',hexstr(Params));
 {$endif DEBUG_COMDISPATCH}
               { get plain type }
-              CurrType:=CallDesc^.ArgTypes[i] and $3f;
+              CurrType:=CallDesc^.ArgTypes[i] and $7f;
               { a skipped parameter? Don't increment Params pointer if so. }
               if CurrType=varError then
                 begin
@@ -1230,8 +1230,23 @@ HKCR
 {$endif DEBUG_COMDISPATCH}
                         StringMap[NextString].ComStr:=StringToOleStr(PString(Params^)^);
                         StringMap[NextString].PasStr:=PString(Params^);
+                        StringMap[NextString].PasWStr:=Nil;
                         Arguments[i].VType:=varOleStr or varByRef;
-                        Arguments[i].VPointer:=StringMap[NextString].ComStr;
+                        Arguments[i].VPointer:=@StringMap[NextString].ComStr;
+                        inc(NextString);
+                        inc(PPointer(Params));
+                      end;
+                    varUStrArg:
+                      begin
+{$ifdef DEBUG_COMDISPATCH}
+                        if printcom then
+                        writeln('Translating var unicodestring argument ',PUnicodeString(Params^)^);
+{$endif DEBUG_COMDISPATCH}
+                        StringMap[NextString].ComStr:=StringToOleStr(PUnicodeString(Params^)^);
+                        StringMap[NextString].PasStr:=Nil;
+                        StringMap[NextString].PasWStr:=PUnicodeString(Params^);
+                        Arguments[i].VType:=varOleStr or varByRef;
+                        Arguments[i].VPointer:=@StringMap[NextString].ComStr;
                         inc(NextString);
                         inc(PPointer(Params));
                       end;
@@ -1282,6 +1297,22 @@ HKCR
 {$endif DEBUG_COMDISPATCH}
                       StringMap[NextString].ComStr:=StringToOleStr(PString(Params)^);
                       StringMap[NextString].PasStr:=nil;
+                      StringMap[NextString].PasWStr:=nil;
+                      Arguments[i].VType:=varOleStr;
+                      Arguments[i].VPointer:=StringMap[NextString].ComStr;
+                      inc(NextString);
+                      inc(PPointer(Params));
+                    end;
+
+                  varUStrArg:
+                    begin
+{$ifdef DEBUG_COMDISPATCH}
+                    if printcom then
+                      writeln('Translating unicodestring argument ',PUnicodeString(Params)^);
+{$endif DEBUG_COMDISPATCH}
+                      StringMap[NextString].ComStr:=StringToOleStr(PUnicodeString(Params)^);
+                      StringMap[NextString].PasStr:=nil;
+                      StringMap[NextString].PasWStr:=nil;
                       Arguments[i].VType:=varOleStr;
                       Arguments[i].VPointer:=StringMap[NextString].ComStr;
                       inc(NextString);
@@ -1373,9 +1404,12 @@ HKCR
             DispatchInvokeError(invokeresult,exceptioninfo);
 
           { translate strings back }
-          for i:=0 to NextString-1 do
+          for i:=0 to NextString-1 do begin
             if assigned(StringMap[i].passtr) then
-              OleStrToStrVar(StringMap[i].comstr,StringMap[i].passtr^);
+              OleStrToStrVar(StringMap[i].comstr,StringMap[i].passtr^)
+            else if assigned(StringMap[i].paswstr) then
+              OleStrToStrVar(StringMap[i].comstr,StringMap[i].paswstr^);
+          end;
         finally
           for i:=0 to NextString-1 do
             SysFreeString(StringMap[i].ComStr);

tests/test/packages/win-base/tdispvar2.pp

@@ -0,0 +1,151 @@
+{ %TARGET = win32,win64,wince }
+{ tests that the different string types are converted correctly when dispatching }
+
+program tdispvar2;
+
+{$mode objfpc}{$H+}
+
+uses
+  SysUtils, Variants, ComObj, ActiveX, Windows;
+
+type
+  { TTest }
+
+  TTest = class(TInterfacedObject, IDispatch)
+    function GetTypeInfoCount(out count : longint) : HResult;stdcall;
+    function GetTypeInfo(Index,LocaleID : longint;
+      out TypeInfo): HResult;stdcall;
+    function GetIDsOfNames(const iid: TGUID; names: Pointer;
+      NameCount, LocaleID: LongInt; DispIDs: Pointer) : HResult;stdcall;
+    function Invoke(DispID: LongInt;const iid : TGUID;
+      LocaleID : longint; Flags: Word;var params;
+      VarResult,ExcepInfo,ArgErr : pointer) : HResult;stdcall;
+  end;
+
+var
+  TestStr: WideString;
+
+{ TTest }
+
+function TTest.GetTypeInfoCount(out count: longint): HResult; stdcall;
+begin
+  Count := 0;
+  Result := S_OK;
+end;
+
+function TTest.GetTypeInfo(Index, LocaleID: longint; out TypeInfo): HResult;
+  stdcall;
+begin
+  Result := E_NOTIMPL;
+end;
+
+function TTest.GetIDsOfNames(const iid: TGUID; names: Pointer; NameCount,
+  LocaleID: LongInt; DispIDs: Pointer): HResult; stdcall;
+var
+  n: ^PWideChar absolute names;
+  d: PDispIDList absolute DispIDs;
+begin
+  if (WideString(n^) = 'SomeFunction') then begin
+    d^[0] := 1;
+    Result := S_OK;
+  end else
+    Result := DISP_E_UNKNOWNNAME;
+end;
+
+function TTest.Invoke(DispID: LongInt; const iid: TGUID; LocaleID: longint;
+  Flags: Word; var params; VarResult, ExcepInfo, ArgErr: pointer): HResult;
+  stdcall;
+var
+  args: TDispParams absolute params;
+  i: UINT;
+begin
+  //Writeln('Call to Invoke');
+  if (DispID = 1) then begin
+    //Writeln(HexStr(Flags, 4));
+    //Writeln(args.cArgs, ' ', args.cNamedArgs);
+    for i := 0 to args.cArgs - 1 do begin
+      //Writeln(HexStr(args.rgvarg^[i].vt, 4));
+      if args.rgvarg^[i].vt = VT_BSTR then begin
+        //Writeln(WideString(args.rgvarg^[i].bstrVal));
+        TestStr := WideString(args.rgvarg^[i].bstrVal);
+      end else if args.rgvarg^[i].vt = VT_BSTR or VT_BYREF then begin
+        //Writeln(args.rgvarg^[i].pbstrVal^);
+        TestStr := args.rgvarg^[i].pbstrVal^;
+      end;
+    end;
+    Result := S_OK;
+  end else
+    Result := E_NOTIMPL;
+end;
+
+procedure Test;
+{$push}
+{$J-}
+const
+  cs: AnsiString = 'Constant AnsiString';
+  cus: UnicodeString = 'Constant UnicodeString';
+  cws: WideString = 'Constant WideString';
+{$pop}
+var
+  i: IDispatch;
+  w: OleVariant;
+  s: AnsiString;
+  us: UnicodeString;
+  ws: WideString;
+begin
+  w := Null;
+  i := TTest.Create;
+  try
+    s := 'AnsiString';
+    us := 'UnicodeString';
+    ws := 'WideString';
+    w := i;
+
+    TestStr := '';
+    w.SomeFunction('Constant');
+    if TestStr <> 'Constant' then
+      Halt(1);
+
+    TestStr := '';
+    w.SomeFunction(s);
+    if TestStr <> 'AnsiString' then
+      Halt(2);
+
+    TestStr := '';
+    w.SomeFunction(us);
+    if TestStr <> 'UnicodeString' then
+      Halt(3);
+
+    TestStr := '';
+    w.SomeFunction(ws);
+    if TestStr <> 'WideString' then
+      Halt(4);
+
+    TestStr := '';
+    w.SomeFunction(cs);
+    if TestStr <> 'Constant AnsiString' then
+      Halt(5);
+
+    TestStr := '';
+    w.SomeFunction(cus);
+    if TestStr <> 'Constant UnicodeString' then
+      Halt(6);
+
+    TestStr := '';
+    w.SomeFunction(cws);
+    if TestStr <> 'Constant WideString' then
+      Halt(7);
+  finally
+    w := Null;
+    i := Nil;
+  end;
+end;
+
+begin
+  CoInitializeEx(Nil, COINIT_MULTITHREADED);
+  try
+    Test;
+  finally
+    CoUninitialize;
+  end;
+end.

utils/fpdoc/dglobals.pp

@@ -1056,7 +1056,8 @@ var
   i, j, k: Integer;
   Module: TPasModule;
   Alias : TPasAliasType;
-  ClassDecl: TPasClassType;
+  MemberDecl: TPasMembersType;
+  ClassLikeDecl : TPasClassType;
   Member: TPasElement;
   s: String;
   Buf : TBufType;
@@ -1089,41 +1090,48 @@ begin
       if not assigned(Module.InterfaceSection) then
         continue;
       for j := 0 to Module.InterfaceSection.Classes.Count - 1 do
-      begin
-        ClassDecl := TPasClassType(Module.InterfaceSection.Classes[j]);
-        Write(ContentFile, CheckImplicitInterfaceLink(ClassDecl.PathName), ' ');
-        if Assigned(ClassDecl.AncestorType) then 
+        begin
+        MemberDecl := TPasClassType(Module.InterfaceSection.Classes[j]);
+        if MemberDecl is TPasClassType then
+          ClassLikeDecl:=MemberDecl as TPasClassType
+        else
+          ClassLikeDecl:=nil;
+        Write(ContentFile, CheckImplicitInterfaceLink(MemberDecl.PathName), ' ');
+        if Assigned(ClassLikeDecl) then
           begin
-             // simple aliases to class types are coded as "alias(classtype)"
-             Write(ContentFile, CheckImplicitInterfaceLink(ClassDecl.AncestorType.PathName));
-             if ClassDecl.AncestorType is TPasAliasType then
+          if Assigned(ClassLikeDecl.AncestorType) then
+            begin
+            // simple aliases to class types are coded as "alias(classtype)"
+            Write(ContentFile, CheckImplicitInterfaceLink(ClassLikeDecl.AncestorType.PathName));
+            if ClassLikeDecl.AncestorType is TPasAliasType then
                begin
-                 alias:= TPasAliasType(ClassDecl.AncestorType);
-                 if assigned(alias.desttype) and (alias.desttype is TPasClassType) then
-                   write(ContentFile,'(',alias.desttype.PathName,')');   
+               alias:= TPasAliasType(ClassLikeDecl.AncestorType);
+               if assigned(alias.desttype) and (alias.desttype is TPasClassType) then
+                  write(ContentFile,'(',alias.desttype.PathName,')');
                end;
-          end
-        else if ClassDecl.ObjKind = okClass then
-          Write(ContentFile, '#rtl.System.TObject')
-        else if ClassDecl.ObjKind = okInterface then
-          Write(ContentFile, '#rtl.System.IUnknown');
-        if ClassDecl.Interfaces.Count>0 then
-          begin
-            for k:=0 to ClassDecl.Interfaces.count-1 do
+            end
+          else if ClassLikeDecl.ObjKind = okClass then
+            Write(ContentFile, '#rtl.System.TObject')
+          else if ClassLikeDecl.ObjKind = okInterface then
+           Write(ContentFile, '#rtl.System.IUnknown');
+          if ClassLikeDecl.Interfaces.Count>0 then
+            begin
+            for k:=0 to ClassLikeDecl.Interfaces.count-1 do
               begin
-                write(contentfile,',',CheckImplicitInterfaceLink(TPasClassType(ClassDecl.Interfaces[k]).PathName));
-                if TPasElement(ClassDecl.Interfaces[k]) is TPasAliasType then
+                write(contentfile,',',CheckImplicitInterfaceLink(TPasClassType(ClassLikeDecl.Interfaces[k]).PathName));
+                if TPasElement(ClassLikeDecl.Interfaces[k]) is TPasAliasType then
                   begin
-                    alias:= TPasAliasType(ClassDecl.Interfaces[k]);
+                    alias:= TPasAliasType(ClassLikeDecl.Interfaces[k]);
                     if assigned(alias.desttype) and (alias.desttype is TPasClassType) then
                       write(ContentFile,'(',CheckImplicitInterfaceLink(alias.desttype.PathName),')');   
                   end;
               end;
+            end;
           end;
         writeln(contentfile);
-        for k := 0 to ClassDecl.Members.Count - 1 do
+        for k := 0 to MemberDecl.Members.Count - 1 do
         begin
-          Member := TPasElement(ClassDecl.Members[k]);
+          Member := TPasElement(MemberDecl.Members[k]);
           Write(ContentFile, Chr(Ord(Member.Visibility) + Ord('0')));
           S:='';
           if Member.ClassType = TPasVariable then

utils/fpdoc/fpdocclasstree.pp

@@ -52,6 +52,7 @@ begin
   FreeAndNil(FClassTree);
   Inherited;
 end;
+
 Function TClassTreeBuilder.BuildTree(AObjects : TStringList) : Integer;
 
 Var
@@ -62,11 +63,13 @@ begin
   Result:=0;
   AObjects.Sorted:=True;
   For I:=0 to AObjects.Count-1 do
-    begin
-    PC:=AObjects.Objects[i] as TPasClassType;
-    If (PC.ObjKind=FObjectKind) and Not PC.IsForward then
-      AddToClassTree(PC,Result);
-    end;
+    // Advanced records
+    if AObjects.Objects[i] is TPasClassType then
+      begin
+      PC:=AObjects.Objects[i] as TPasClassType;
+      If (PC.ObjKind=FObjectKind) and Not PC.IsForward then
+        AddToClassTree(PC,Result);
+      end;
 end;
 
 Function TClassTreeBuilder.NodeMatch(N : TDomNode; AElement : TPasElement; NoPath : Boolean) : Boolean;