* synchronize with trunk

git-svn-id: branches/unicodekvm@41595 -

packages/fcl-passrc/src/pasresolver.pp

@@ -1234,7 +1234,7 @@ type
     SubType: TResolverBaseType; // for btSet, btArrayLit, btArrayOrSet, btRange
     IdentEl: TPasElement; // if set then this specific identifier is the value, can be a type
     LoTypeEl: TPasType; // can be nil for const expression, all alias resolved
-    HiTypeEl: TPasType; // same as BaseTypeEl, except alias types are not resolved
+    HiTypeEl: TPasType; // same as LoTypeEl, except alias types are not resolved
     ExprEl: TPasExpr;
     Flags: TPasResolverResultFlags;
   end;
@@ -1438,7 +1438,7 @@ type
     procedure OnFindFirst(El: TPasElement; ElScope, StartScope: TPasScope;
       FindFirstElementData: Pointer; var Abort: boolean); virtual;
     procedure OnFindCallElements(El: TPasElement; ElScope, StartScope: TPasScope;
-      FindProcsData: Pointer; var Abort: boolean); virtual; // find candidates for Name(params)
+      FindCallElData: Pointer; var Abort: boolean); virtual; // find candidates for Name(params)
     procedure OnFindProc(El: TPasElement; ElScope, StartScope: TPasScope;
       FindProcData: Pointer; var Abort: boolean); virtual;
     function IsSameProcContext(ProcParentA, ProcParentB: TPasElement): boolean;
@@ -4373,9 +4373,9 @@ begin
 end;
 
 procedure TPasResolver.OnFindCallElements(El: TPasElement; ElScope,
-  StartScope: TPasScope; FindProcsData: Pointer; var Abort: boolean);
+  StartScope: TPasScope; FindCallElData: Pointer; var Abort: boolean);
 var
-  Data: PFindCallElData absolute FindProcsData;
+  Data: PFindCallElData absolute FindCallElData;
   Proc, PrevProc: TPasProcedure;
   Distance: integer;
   BuiltInProc: TResElDataBuiltInProc;
@@ -4680,7 +4680,7 @@ var
   end;
 
 begin
-  //writeln('TPasResolver.OnFindProcSameSignature START ',El.Name,':',GetElementTypeName(El),' itself=',El=Data^.Proc);
+  //writeln('TPasResolver.OnFindProc START ',El.Name,':',GetElementTypeName(El),' itself=',El=Data^.Proc);
   if not (El is TPasProcedure) then
     begin
     // identifier is not a proc
@@ -4732,7 +4732,7 @@ begin
     end;
 
   {$IFDEF VerbosePasResolver}
-  writeln('TPasResolver.OnFindProcSameSignature ',GetTreeDbg(El,2));
+  writeln('TPasResolver.OnFindProc ',GetTreeDbg(El,2));
   {$ENDIF}
   Store:=CheckOverloadProcCompatibility(Data^.Proc,Proc);
   if Data^.Kind=fpkSameSignature then
@@ -20198,18 +20198,25 @@ begin
         end;
       exit;
       end;
+    if (Param.ArgType=nil) then
+      exit(cExact); // untyped argument
     if (ParamResolved.BaseType=ExprResolved.BaseType) then
       begin
       if msDelphi in CurrentParser.CurrentModeswitches then
         begin
+        // Delphi allows passing alias, but not type alias to a var arg
         if IsSameType(ParamResolved.HiTypeEl,ExprResolved.HiTypeEl,prraSimple) then
           exit(cExact);
         end
       else if IsSameType(ParamResolved.LoTypeEl,ExprResolved.LoTypeEl,prraNone) then
-        exit(cExact);
+        begin
+        // ObjFPC allows passing type alias to a var arg, but simple alias wins
+        if IsSameType(ParamResolved.HiTypeEl,ExprResolved.HiTypeEl,prraSimple) then
+          exit(cExact)
+        else
+          exit(cAliasExact);
+        end;
       end;
-    if (Param.ArgType=nil) then
-      exit(cExact); // untyped argument
     if RaiseOnError then
       RaiseIncompatibleTypeRes(20170216152452,nIncompatibleTypeArgNoVarParamMustMatchExactly,
         [IntToStr(ParamNo+1)],ExprResolved,ParamResolved,
@@ -22137,6 +22144,8 @@ begin
     exit(TPasArgument(IdentEl).ArgType<>nil)
   else if IdentEl.ClassType=TPasResultElement then
     exit(TPasResultElement(IdentEl).ResultType<>nil)
+  else if IdentEl is TPasType then
+    Result:=true
   else
     Result:=false;
 end;

packages/fcl-passrc/tests/tcresolver.pas

@@ -6421,14 +6421,26 @@ begin
   '  TAliasValue = TValue;',
   '  TColor = type TAliasValue;',
   '  TAliasColor = TColor;',
-  'procedure DoIt(i: TAliasValue); external;',
-  'procedure DoIt(i: TAliasColor); external;',
+  'procedure {#a}DoIt(i: TAliasValue); external;',
+  'procedure {#b}DoIt(i: TAliasColor); external;',
+  'procedure {#c}Fly(var i: TAliasValue); external;',
+  'procedure {#d}Fly(var i: TAliasColor); external;',
   'var',
   '  v: TAliasValue;',
   '  c: TAliasColor;',
   'begin',
-  '  DoIt(v);',
-  '  DoIt(c);',
+  '  {@a}DoIt(v);',
+  '  {@a}DoIt(TAliasValue(c));',
+  '  {@a}DoIt(TValue(c));',
+  '  {@b}DoIt(c);',
+  '  {@b}DoIt(TAliasColor(v));',
+  '  {@b}DoIt(TColor(v));',
+  '  {@c}Fly(v);',
+  '  {@c}Fly(TAliasValue(c));',
+  '  {@c}Fly(TValue(c));',
+  '  {@d}Fly(c);',
+  '  {@d}Fly(TAliasColor(v));',
+  '  {@d}Fly(TColor(v));',
   '']);
   ParseProgram;
 end;

packages/fcl-pdf/src/fppdf.pp

@@ -2857,13 +2857,11 @@ begin
   if Length(FStreamed)=0 then
     begin
     if Collection.Owner is TPDFDocument then
-      begin
-      Opts:=TPDFDocument(Collection.Owner).ImageStreamOptions;
-      end
+      Opts:=TPDFDocument(Collection.Owner).ImageStreamOptions
     else
       Opts:=[isoCompressed,isoTransparent];
+    CreateStreamedData(Opts);
     end;
-  CreateStreamedData(Opts);
   Result:=FStreamed;
 end;
 

packages/fcl-pdf/src/fpttf.pp

@@ -149,7 +149,7 @@ resourcestring
   rsNoSearchPathDefined = 'No search path was defined';
   rsNoFontFileName = 'The FileName property is empty, so we can''t load font data.';
   rsMissingFontFile = 'The font file <%s> can''t be found.';
-  SErrFontNotFound = 'The font <%s> can can''t be found';
+  SErrFontNotFound = 'The font <%s> can''t be found';
 
 var
   uFontCacheList: TFPFontCacheList;

packages/pastojs/src/fppas2js.pp

@@ -573,6 +573,8 @@ type
     pbifnAsExt,
     pbifnBitwiseNativeIntAnd,
     pbifnBitwiseNativeIntOr,
+    pbifnBitwiseNativeIntShl,
+    pbifnBitwiseNativeIntShr,
     pbifnBitwiseNativeIntXor,
     pbifnCheckMethodCall,
     pbifnCheckVersion,
@@ -739,6 +741,8 @@ const
     'asExt', // rtl.asExt
     'and', // pbifnBitwiseNativeIntAnd,
     'or', // pbifnBitwiseNativeIntOr,
+    'shl', // pbifnBitwiseNativeIntShl,
+    'shr', // pbifnBitwiseNativeIntShr,
     'xor', // pbifnBitwiseNativeIntXor,
     'checkMethodCall',
     'checkVersion',
@@ -7010,10 +7014,6 @@ begin
         // convert "a div b" to "Math.floor(a/b)"
         Result:=CreateMathFloor(El,Result);
         end;
-      eopShl,eopShr:
-        if (aResolver<>nil) and (LeftResolved.BaseType in [btIntDouble,btUIntDouble]) then
-          aResolver.LogMsg(20190228220225,mtWarning,nBitWiseOperationIs32Bit,
-            sBitWiseOperationIs32Bit,[],El);
       end;
 
       if (bsOverflowChecks in AContext.ScannerBoolSwitches) and (aResolver<>nil) then
@@ -7095,6 +7095,7 @@ var
   SNE: TJSEqualityExpressionSNE;
   JSBinClass: TJSBinaryClass;
   ResolvedEl: TPasResolverResult;
+  AInt, BInt: TMaxPrecInt;
 begin
   {$IFDEF VerbosePas2JS}
   writeln('TPasToJSConverter.ConvertBinaryExpressionRes OpCode="',OpcodeStrings[El.OpCode],'" Left=',GetResolverResultDbg(LeftResolved),' Right=',GetResolverResultDbg(RightResolved));
@@ -7166,6 +7167,68 @@ begin
     Call.AddArg(B); B:=nil;
     exit;
     end
+  else if El.OpCode in [eopShl,eopShr] then
+    begin
+    if LeftResolved.BaseType in [btIntDouble,btUIntDouble] then
+      begin
+      // BigInt shl/shr   JavaScript bitwise operators only supports 32bit
+      if IsLiteralInteger(B,BInt) then
+        begin
+        // BigInt shl/shr const
+        if BInt>=54 then
+          begin
+          // A shl 54 -> 0
+          // A shr 54 -> 0
+          Result:=CreateLiteralNumber(El,0);
+          FreeAndNil(A);
+          FreeAndNil(B);
+          exit;
+          end
+        else if BInt<=0 then
+          begin
+          // A shl 0 -> A
+          // A shr 0 -> A
+          Result:=A;
+          A:=nil;
+          FreeAndNil(B);
+          exit;
+          end
+        else if IsLiteralInteger(A,AInt) then
+          begin
+          // const shl const  ->  const
+          if El.OpCode=eopShl then
+            AInt:=AInt shl BInt
+          else
+            AInt:=AInt shr BInt;
+          if (AInt>=0) and (AInt<=MaxSafeIntDouble) then
+            begin
+            TJSLiteral(A).Value.AsNumber:=AInt;
+            Result:=A;
+            FreeAndNil(B);
+            exit;
+            end;
+          end
+        else if El.OpCode=eopShr then
+          begin
+          // BigInt shr const -> Math.floor(A/otherconst)
+          Result:=CreateMathFloor(El,CreateDivideNumber(El,A,TMaxPrecInt(1) shl BInt));
+          A:=nil;
+          FreeAndNil(B);
+          exit;
+          end;
+        end;
+      // use rtl.shl(a,b)
+      Call:=CreateCallExpression(El);
+      Result:=Call;
+      if El.OpCode=eopShl then
+        Call.Expr:=CreateMemberExpression([GetBIName(pbivnRTL),GetBIName(pbifnBitwiseNativeIntShl)])
+      else
+        Call.Expr:=CreateMemberExpression([GetBIName(pbivnRTL),GetBIName(pbifnBitwiseNativeIntShr)]);
+      Call.AddArg(A); A:=nil;
+      Call.AddArg(B); B:=nil;
+      exit;
+      end;
+    end
   else if (LeftResolved.BaseType=btCurrency) or (RightResolved.BaseType=btCurrency) then
     begin
     case El.OpCode of

packages/pastojs/tests/tcmodules.pas

@@ -263,7 +263,8 @@ type
     Procedure TestInteger;
     Procedure TestIntegerRange;
     Procedure TestIntegerTypecasts;
-    Procedure TestBitwiseShlNativeIntWarn;
+    Procedure TestInteger_BitwiseShrNativeInt;
+    Procedure TestInteger_BitwiseShlNativeInt;
     Procedure TestCurrency;
     Procedure TestForBoolDo;
     Procedure TestForIntDo;
@@ -6436,24 +6437,59 @@ begin
     '']));
 end;
 
-procedure TTestModule.TestBitwiseShlNativeIntWarn;
+procedure TTestModule.TestInteger_BitwiseShrNativeInt;
+begin
+  StartProgram(false);
+  Add([
+  'var',
+  '  i,j: nativeint;',
+  'begin',
+  '  i:=i shr 0;',
+  '  i:=i shr 1;',
+  '  i:=i shr 3;',
+  '  i:=i shr 54;',
+  '  i:=j shr i;',
+  '']);
+  ConvertProgram;
+  CheckResolverUnexpectedHints;
+  CheckSource('TestInteger_BitwiseShrNativeInt',
+    LinesToStr([
+    'this.i = 0;',
+    'this.j = 0;',
+    '']),
+    LinesToStr([
+    '$mod.i = $mod.i;',
+    '$mod.i = Math.floor($mod.i / 2);',
+    '$mod.i = Math.floor($mod.i / 8);',
+    '$mod.i = 0;',
+    '$mod.i = rtl.shr($mod.j, $mod.i);',
+    '']));
+end;
+
+procedure TTestModule.TestInteger_BitwiseShlNativeInt;
 begin
   StartProgram(false);
   Add([
   'var',
   '  i: nativeint;',
   'begin',
-  '  i:=i shl 3;',
+  '  i:=i shl 0;',
+  '  i:=i shl 54;',
+  '  i:=123456789012 shl 1;',
+  '  i:=i shl 1;',
   '']);
   ConvertProgram;
-  CheckSource('TestBitwiseShlNativeIntWarn',
+  CheckResolverUnexpectedHints;
+  CheckSource('TestInteger_BitwiseShrNativeInt',
     LinesToStr([
     'this.i = 0;',
     '']),
     LinesToStr([
-    '$mod.i = $mod.i << 3;',
+    '$mod.i = $mod.i;',
+    '$mod.i = 0;',
+    '$mod.i = 246913578024;',
+    '$mod.i = rtl.shl($mod.i, 1);',
     '']));
-  CheckHint(mtWarning,nBitWiseOperationIs32Bit,sBitWiseOperationIs32Bit);
 end;
 
 procedure TTestModule.TestCurrency;

tests/test/cg/tmoddiv4.pp

@@ -3,6 +3,9 @@ program tmoddiv4;
 const
   TestValues: array[0..10] of QWord = (500, 1, 0, 995, $100000000, $100000001, $7FFFFFFFFFFFFFFF, QWord($8000000000000000), QWord($8000000000000001), QWord($8000000000000002), 1000000);
 
+  { Divisors are only for the error reporting }
+  Divisors: array[0..8] of QWord = (1000, 1, 3, $1000, $7FFFFFFF, $80000000, $7FFFFFFFFFFFFFFF, QWord($8000000000000000), QWord($8000000000000001));
+
 const
   ExpectedResults: array[0..10,1..18] of QWord = (
     (0,500,500,0,166,2,0,500,0,500,0,500,0,500,0,500,0,500),
@@ -11,10 +14,10 @@ const
     (0,995,995,0,331,2,0,995,0,995,0,995,0,995,0,995,0,995),
     (4294967,296,4294967296,0,1431655765,1,1048576,0,2,2,2,0,0,4294967296,0,4294967296,0,4294967296),
     (4294967,297,4294967297,0,1431655765,2,1048576,1,2,3,2,1,0,4294967297,0,4294967297,0,4294967297),
-    (9223372036854775,807,9223372036854775807,0,3074457345618258602,1,2251799813685247,4095,4294967298,1,4294967295,2147483647,1,0,0,9223372036854775807,18446744073709551615,0),
-    (9223372036854775,808,9223372036854775808,0,3074457345618258602,2,2251799813685248,0,4294967298,2,4294967296,0,1,1,1,0,1,18446744073709551615),
-    (9223372036854775,809,9223372036854775809,0,3074457345618258603,0,2251799813685248,1,4294967298,3,4294967296,1,1,2,0,9223372036854775809,1,0),
-    (9223372036854775,810,9223372036854775810,0,3074457345618258603,1,2251799813685248,2,4294967298,4,4294967296,2,1,3,0,9223372036854775810,0,9223372036854775810),
+    (9223372036854775,807,9223372036854775807,0,3074457345618258602,1,2251799813685247,4095,4294967298,1,4294967295,2147483647,1,0,0,$7FFFFFFFFFFFFFFF,0,$7FFFFFFFFFFFFFFF),
+    (9223372036854775,808,9223372036854775808,0,3074457345618258602,2,2251799813685248,0,4294967298,2,4294967296,0,1,1,1,0,0,QWord($8000000000000000)),
+    (9223372036854775,809,9223372036854775809,0,3074457345618258603,0,2251799813685248,1,4294967298,3,4294967296,1,1,2,1,1,1,0),
+    (9223372036854775,810,9223372036854775810,0,3074457345618258603,1,2251799813685248,2,4294967298,4,4294967296,2,1,3,1,2,1,1),
     (1000,0,1000000,0,333333,1,244,576,0,1000000,0,1000000,0,1000000,0,1000000,0,1000000));
 
 var
@@ -25,7 +28,12 @@ procedure DoCheck;
   begin
     if Y<>ExpectedResults[C,Col] then
       begin
-        writeln('Error at ',C,' ',Col);
+        Write(#10'Error at ', C, ',', Col, ' - ', TestValues[C]);
+        if (Col and $1) = 0 then
+          Write(' mod ')
+        else
+          Write(' div ');
+        WriteLn(Divisors[(Col - 1) shr 1], ' - expected ', ExpectedResults[C,Col], ' got ', Y);
         halt(1);
       end;
     Inc(Col);
@@ -92,19 +100,20 @@ begin
     Write(Y,',');
     DoCheck;
 
-    Y := QWord(X) div $8000000000000000;
+    { Constants this large default to being made into Int64's, so typecast them }
+    Y := QWord(X) div QWord($8000000000000000);
     Write(Y,',');
     DoCheck;
 
-    Y := QWord(X) mod $8000000000000000;
+    Y := QWord(X) mod QWord($8000000000000000);
     Write(Y,',');
     DoCheck;
 
-    Y := QWord(X) div $8000000000000001;
+    Y := QWord(X) div QWord($8000000000000001);
     Write(Y,',');
     DoCheck;
 
-    Y := QWord(X) mod $8000000000000001;
+    Y := QWord(X) mod QWord($8000000000000001);
     Writeln(Y);
     DoCheck;
   end;

utils/pas2js/dist/rtl.js

@@ -26,6 +26,8 @@ var rtl = {
     if (rtl.version != v) throw "expected rtl version "+v+", but found "+rtl.version;
   },
 
+  hiInt: Math.pow(2,53),
+
   hasString: function(s){
     return rtl.isString(s) && (s.length>0);
   },
@@ -1089,6 +1091,23 @@ var rtl = {
     return h*hi + l;
   },
 
+  shr: function(a,b){
+    if (a<0) a += rtl.hiInt;
+    if (a<0x80000000) return a >> b;
+    if (b<=0) return a;
+    if (b>54) return 0;
+    return Math.floor(a / Math.pow(2,b));
+  },
+
+  shl: function(a,b){
+    if (a<0) a += rtl.hiInt;
+    if (b<=0) return a;
+    if (b>54) return 0;
+    var r = a * (2**b);
+    if (r <= rtl.hiInt) return r;
+    return r % rtl.hiInt;
+  },
+
   initRTTI: function(){
     if (rtl.debug_rtti) rtl.debug('initRTTI');