- Merging r29456 into '.':

A    tests/webtbs/tw27256.pp
U    compiler/ncal.pas
U    compiler/nadd.pas
--- Merging r29495 into '.':
G    compiler/ncal.pas
--- Merging r29584 into '.':
U    compiler/utils/ppuutils/ppudump.pp
U    compiler/psub.pas
U    compiler/globtype.pas
G    compiler/ncal.pas
--- Merging r29585 into '.':
U    rtl/unix/oscdecl.inc
U    rtl/unix/oscdeclh.inc
U    rtl/linux/osmacro.inc
--- Merging r29586 into '.':
U    tests/utils/dotest.pp
--- Merging r29616 into '.':
A    tests/webtbs/tw26534a.pp
A    tests/webtbs/tw26534b.pp
A    tests/webtbs/tw24796.pp
G    compiler/ncal.pas
--- Merging r29641 into '.':
U    compiler/optdfa.pas
--- Merging r29686 into '.':
A    tests/test/tobjc42.pp
A    tests/test/uobjc42.pp
U    compiler/symdef.pas
--- Merging r29792 into '.':
U    compiler/finput.pas
--- Merging r29793 into '.':
A    tests/webtbs/tw14347.pp

git-svn-id: branches/fixes_3_0@32621 -

.gitattributes

@@ -11976,6 +11976,7 @@ tests/test/tobjc39.pp svneol=native#text/plain
 tests/test/tobjc4.pp svneol=native#text/plain
 tests/test/tobjc40.pp svneol=native#text/plain
 tests/test/tobjc41.pp svneol=native#text/plain
+tests/test/tobjc42.pp svneol=native#text/plain
 tests/test/tobjc4a.pp svneol=native#text/plain
 tests/test/tobjc5.pp svneol=native#text/plain
 tests/test/tobjc5a.pp svneol=native#text/plain
@@ -12660,6 +12661,7 @@ tests/test/uobjc35f.pp svneol=native#text/plain
 tests/test/uobjc35g.pp svneol=native#text/plain
 tests/test/uobjc39.pp svneol=native#text/plain
 tests/test/uobjc41.pp svneol=native#text/plain
+tests/test/uobjc42.pp svneol=native#text/plain
 tests/test/uobjc7.pp svneol=native#text/plain
 tests/test/uobjcl1.pp svneol=native#text/plain
 tests/test/uprec6.pp svneol=native#text/plain
@@ -13516,6 +13518,7 @@ tests/webtbs/tw1430.pp svneol=native#text/plain
 tests/webtbs/tw14307.pp svneol=native#text/plain
 tests/webtbs/tw14315.pp svneol=native#text/plain
 tests/webtbs/tw1433.pp svneol=native#text/plain
+tests/webtbs/tw14347.pp svneol=native#text/pascal
 tests/webtbs/tw14363.pp svneol=native#text/plain
 tests/webtbs/tw14388.pp svneol=native#text/pascal
 tests/webtbs/tw14403.pp svneol=native#text/plain
@@ -14091,6 +14094,7 @@ tests/webtbs/tw24651.pp svneol=native#text/pascal
 tests/webtbs/tw24690.pp svneol=native#text/pascal
 tests/webtbs/tw24705.pp svneol=native#text/pascal
 tests/webtbs/tw2473.pp svneol=native#text/plain
+tests/webtbs/tw24796.pp svneol=native#text/pascal
 tests/webtbs/tw2480.pp svneol=native#text/plain
 tests/webtbs/tw2481.pp svneol=native#text/plain
 tests/webtbs/tw2483.pp svneol=native#text/plain
@@ -14196,6 +14200,8 @@ tests/webtbs/tw26482.pp svneol=native#text/pascal
 tests/webtbs/tw26483.pp svneol=native#text/pascal
 tests/webtbs/tw2649.pp svneol=native#text/plain
 tests/webtbs/tw2651.pp svneol=native#text/plain
+tests/webtbs/tw26534a.pp svneol=native#text/pascal
+tests/webtbs/tw26534b.pp svneol=native#text/pascal
 tests/webtbs/tw26536.pp svneol=native#text/plain
 tests/webtbs/tw2656.pp svneol=native#text/plain
 tests/webtbs/tw2659.pp svneol=native#text/plain
@@ -14234,6 +14240,7 @@ tests/webtbs/tw27185.pp svneol=native#text/pascal
 tests/webtbs/tw2721.pp svneol=native#text/plain
 tests/webtbs/tw2723.pp svneol=native#text/plain
 tests/webtbs/tw2725.pp svneol=native#text/plain
+tests/webtbs/tw27256.pp svneol=native#text/pascal
 tests/webtbs/tw2727.pp svneol=native#text/plain
 tests/webtbs/tw2728.pp svneol=native#text/plain
 tests/webtbs/tw2729.pp svneol=native#text/plain

compiler/finput.pas

@@ -454,7 +454,7 @@ uses
         fileopen:=false;
         try
           f:=CFileStreamClass.Create(filename,fmOpenRead);
-          fileopen:=true;
+          fileopen:=CStreamError=0;
         except
         end;
       end;

compiler/globtype.pas

@@ -616,7 +616,9 @@ interface
          { allocates memory on stack, so stack is unbalanced on exit }
          pi_has_stack_allocs,
          { set if the stack frame of the procedure is estimated }
-         pi_estimatestacksize
+         pi_estimatestacksize,
+         { the routine calls a C-style varargs function }
+         pi_calls_c_varargs
        );
        tprocinfoflags=set of tprocinfoflag;
 

compiler/nadd.pas

@@ -409,8 +409,7 @@ implementation
           end;
 
         { both are int constants }
-        if (
-            (
+        if  (
              is_constintnode(left) and
              is_constintnode(right)
             ) or
@@ -422,7 +421,7 @@ implementation
             (
              is_constenumnode(left) and
              is_constenumnode(right) and
-             allowenumop(nodetype))
+             (allowenumop(nodetype) or (nf_internal in flags))
             ) or
             (
              (lt = pointerconstn) and
@@ -2140,7 +2139,7 @@ implementation
          { enums }
          else if (ld.typ=enumdef) and (rd.typ=enumdef) then
           begin
-            if allowenumop(nodetype) then
+            if allowenumop(nodetype) or (nf_internal in flags) then
               inserttypeconv(right,left.resultdef)
             else
               CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,rd.typename);

compiler/ncal.pas

@@ -268,6 +268,9 @@ interface
        between the callparanodes and the callnode they belong to }
       aktcallnode : tcallnode;
 
+    const
+      { track current inlining depth }
+      inlinelevel : longint = 0;
 
 implementation
 
@@ -1004,10 +1007,17 @@ implementation
                         { uninitialized warnings (tbs/tb0542)         }
                         set_varstate(left,vs_written,[]);
                         set_varstate(left,vs_readwritten,[]);
+                        make_not_regable(left,[ra_addr_regable,ra_addr_taken]);
                       end;
                     vs_var,
                     vs_constref:
-                      set_varstate(left,vs_readwritten,[vsf_must_be_valid,vsf_use_hints]);
+                      begin
+                        set_varstate(left,vs_readwritten,[vsf_must_be_valid,vsf_use_hints]);
+                        { constref takes also the address, but storing it is actually the compiler
+                          is not supposed to expect }
+                        if parasym.varspez=vs_var then
+                          make_not_regable(left,[ra_addr_regable,ra_addr_taken]);
+                      end;
                     else
                       set_varstate(left,vs_read,[vsf_must_be_valid]);
                   end;
@@ -1702,7 +1712,10 @@ implementation
                       typecheckpass(temp);
                       if (temp.nodetype <> ordconstn) or
                          (tordconstnode(temp).value <> 0) then
-                        hightree := caddnode.create(subn,hightree,temp)
+                        begin
+                          hightree:=caddnode.create(subn,hightree,temp);
+                          include(hightree.flags,nf_internal);
+                        end
                       else
                         temp.free;
                     end;
@@ -2821,6 +2834,7 @@ implementation
           end;
         if (i>0) then
           begin
+            include(current_procinfo.flags,pi_calls_c_varargs);
             varargsparas:=tvarargsparalist.create;
             pt:=tcallparanode(left);
             while assigned(pt) do
@@ -3489,9 +3503,25 @@ implementation
         { Can we inline the procedure? }
         if (po_inline in procdefinition.procoptions) and
            (procdefinition.typ=procdef) and
-           tprocdef(procdefinition).has_inlininginfo then
+           tprocdef(procdefinition).has_inlininginfo and
+           {  Prevent too deep inlining recursion and code bloat by inlining
+
+              The actual formuala is
+                                inlinelevel+1  /-------
+                  node count <  -------------\/  10000
+
+              This allows exponential grow of the code only to a certain limit.
+
+              Remarks
+               - The current approach calculates the inlining level top down, so outer call nodes (nodes closer to the leaf) might not be inlined
+                 if the max. complexity is reached. This is done because it makes the implementation easier and because
+                 there might be situations were it is more beneficial to inline inner nodes and do the calls to the outer nodes
+                 if the outer nodes are in a seldomly used code path
+               - The code avoids to use functions from the math unit
+           }
+           (node_count(tprocdef(procdefinition).inlininginfo^.code)<round(exp((1.0/(inlinelevel+1))*ln(10000)))) then
           begin
-             include(callnodeflags,cnf_do_inline);
+            include(callnodeflags,cnf_do_inline);
             { Check if we can inline the procedure when it references proc/var that
               are not in the globally available }
             st:=procdefinition.owner;
@@ -3883,7 +3913,10 @@ implementation
             ((tloadnode(n).symtable.symtabletype in [globalsymtable,ObjectSymtable]) or
             { statics can only be modified by functions in the same unit }
              ((tloadnode(n).symtable.symtabletype = staticsymtable) and
-              (tloadnode(n).symtable = TSymtable(arg))))) or
+              (tloadnode(n).symtable = TSymtable(arg))) or
+              { if the addr of the symbol is taken somewhere, it can be also non-local }
+              (tabstractvarsym(tloadnode(n).symtableentry).addr_taken)
+           )) or
            ((n.nodetype = subscriptn) and
             (tsubscriptnode(n).vs.owner.symtabletype = ObjectSymtable)) then
           result := fen_norecurse_true;
@@ -4159,6 +4192,7 @@ implementation
         inlineblock,
         inlinecleanupblock : tblocknode;
       begin
+        inc(inlinelevel);
         result:=nil;
         if not(assigned(tprocdef(procdefinition).inlininginfo) and
                assigned(tprocdef(procdefinition).inlininginfo^.code)) then
@@ -4256,6 +4290,7 @@ implementation
         writeln('**************************',tprocdef(procdefinition).mangledname);
         printnode(output,result);
 {$endif DEBUGINLINE}
+        dec(inlinelevel);
       end;
 
 end.

compiler/optdfa.pas

@@ -517,6 +517,10 @@ unit optdfa;
                   end;
               end;
 
+{$ifdef JVM}
+            { all other platforms except jvm translate raise nodes into call nodes during pass_1 }
+            raisen,
+{$endif JVM}
             asn,
             inlinen,
             calln:
@@ -918,6 +922,10 @@ unit optdfa;
                   end
               end;
             { could be the implicitly generated load node for the result }
+{$ifdef JVM}
+            { all other platforms except jvm translate raise nodes into call nodes during pass_1 }
+            raisen,
+{$endif JVM}
             loadn,
             assignn,
             calln,

compiler/psub.pas

@@ -155,6 +155,12 @@ implementation
             Message(parser_h_inlining_disabled);
             exit;
           end;
+        if pi_calls_c_varargs in current_procinfo.flags then
+          begin
+            Message1(parser_h_not_supported_for_inline,'called C-style varargs functions');
+            Message(parser_h_inlining_disabled);
+            exit;
+          end;
         { the compiler cannot handle inherited in inlined subroutines because
           it tries to search for self in the symtable, however, the symtable
           is not available }

compiler/symdef.pas

@@ -6311,7 +6311,7 @@ implementation
          inherited derefimpl;
          { the procdefs are not owned by the class helper procsyms, so they
            are not stored/restored either -> re-add them here }
-         if (objecttype=odt_objcclass) or
+         if (objecttype in [odt_objcclass,odt_objcprotocol]) or
             (oo_is_classhelper in objectoptions) then
            symtable.DefList.ForEachCall(@create_class_helper_for_procdef,nil);
       end;

compiler/utils/ppuutils/ppudump.pp

@@ -1200,7 +1200,9 @@ const
          (mask:pi_has_stack_allocs;
          str:' allocates memory on stack, so stack may be unbalanced on exit '),
          (mask:pi_estimatestacksize;
-         str:' stack size is estimated before subroutine is compiled ')
+         str:' stack size is estimated before subroutine is compiled '),
+         (mask:pi_calls_c_varargs;
+         str:' calls function with C-style varargs ')
   );
 var
   procinfooptions : tprocinfoflags;

rtl/linux/osmacro.inc

@@ -117,11 +117,4 @@ function  FpStat(path: pchar; var buf : stat): cint;inline;
     FpStat:=__xstat(_STAT_VER,path,buf);
   end;
 
-{$ifndef fs32bit}
-function  FpOpen    (path: pchar; flags : cint; mode: TMode):cint; inline;
-  begin
-    FpOpen:=__fpopen(path, flags or O_LARGEFILE, mode);
-  end;
-{$endif}
-
 {$endif FPC_USE_LIBC}

rtl/unix/oscdecl.inc

@@ -52,3 +52,20 @@ begin
   FpFcntl:=real_FpFcntl(fildes, cmd, @arg);
 end;
 
+
+{ ********************************************************************* }
+{ fpopen                                                                }
+{ ********************************************************************* }
+
+function  real_FpOpen(path: pchar; flags : cint):cint; varargs; cdecl; external clib name 'open'{$ifdef aix}+suffix64bit{$endif};
+
+function  FpOpen    (path: pchar; flags : cint; mode: TMode):cint;
+begin
+{$if defined(linux) and defined(fs32bit)}
+  flags:=flags or O_LARGEFILE;
+{$endif}
+  { emulate what the bunxovl(h).inc version of fpopen does. Required because
+    existing code depends on this (it doesn't always pass a valid mode when
+    using fmCreate) }
+  FpOpen:=real_FpOpen(path,flags,mode);
+end;

rtl/unix/oscdeclh.inc

@@ -91,13 +91,9 @@ const
     Function  FpReaddir (var dirp : Dir) : pDirent;cdecl; external clib name 'readdir'+suffix64bit;
     Function  FpClosedir (var dirp : Dir): cInt; cdecl; external clib name 'closedir'{$ifdef aix}+suffix64bit{$endif};
     function  FpChdir   (path : pchar): cint; cdecl; external clib name 'chdir';
-    function  FpOpen    (path: pchar; flags : cint; mode: TMode):cint;
-{$if defined(linux) and not defined(fs32bit)}
-    { we need a wrapper for linux to automatically pass O_LARGEFILE with flags }
-                                              {$ifdef FPC_IS_SYSTEM}forward;{$endif} inline;
-    function  __FpOpen  (path: pchar; flags : cint; mode: TMode):cint; 
-{$endif}
-                                                                        cdecl; external clib name 'open'{$ifdef aix}+suffix64bit{$endif};
+    { emulate the bunxovl version that automatically passes
+     638 as mode }
+    function  FpOpen    (path: pchar; flags : cint; mode: TMode):cint; {$ifdef FPC_IS_SYSTEM}forward;{$endif}
     function  FpMkdir   (path : pchar; mode: TMode):cint; cdecl; external clib name 'mkdir';
     function  FpUnlink  (path: pchar): cint; cdecl; external clib name 'unlink';
     function  FpRmdir   (path : pchar): cint; cdecl; external clib name 'rmdir';

tests/test/tobjc42.pp

@@ -0,0 +1,13 @@
+{ %target=darwin }
+{ %recompile }
+{ %norun }
+
+{$modeswitch objectivec2}
+
+uses uobjc42;
+
+var
+  i: id;
+begin
+  i.mytest;
+end.

tests/test/uobjc42.pp

@@ -0,0 +1,12 @@
+{$modeswitch objectivec2}
+unit uobjc42;
+
+interface
+type
+  tinf = objcprotocol
+    procedure mytest; message 'mytest';
+  end;
+
+implementation
+
+end.

tests/utils/dotest.pp

@@ -1405,9 +1405,15 @@ begin
       if Config.NeedLibrary then
         begin
           if RemoteShellNeedsExport then
-            execcmd:=execcmd+' LD_LIBRARY_PATH=.; export LD_LIBRARY_PATH;'
+            if CompilerTarget='darwin' then
+              execcmd:=execcmd+' DYLD_LIBRARY_PATH=.; export DYLD_LIBRARY_PATH;'
+            else
+              execcmd:=execcmd+' LD_LIBRARY_PATH=.; export LD_LIBRARY_PATH;'
           else
-            execcmd:=execcmd+' setenv LD_LIBRARY_PATH=.; ';
+            if CompilerTarget='darwin' then
+              execcmd:=execcmd+' setenv DYLD_LIBRARY_PATH=.; '
+            else
+              execcmd:=execcmd+' setenv LD_LIBRARY_PATH=.; '
         end;
 
 

tests/webtbs/tw14347.pp

@@ -0,0 +1,15 @@
+{ %OPT=-Sew -Oodfa }
+program Project1;
+
+{$mode objfpc}{$H+}
+
+type
+  TRec = record a : Integer; end;
+  PRec = ^TRec;
+
+var
+  p : PRec;
+
+begin
+  writeln( sizeof(p^.a)); // warning here!
+end.

tests/webtbs/tw24796.pp

@@ -0,0 +1,94 @@
+{$apptype console}
+{$mode objfpc}
+{$inline on}
+
+{$define debug_inline}
+
+var
+    fault_mask: integer = 0;
+
+/////////////////////////////////////////
+
+function dummy1( x: integer; var y: integer ): boolean; {$ifdef debug_inline}inline;{$endif}
+begin
+    y := x + 1;
+    result := ( y = x + 1 );
+end;
+
+function dummy2( x: integer; out y: integer ): boolean; {$ifdef debug_inline}inline;{$endif}
+begin
+    y := x + 1;
+    result := ( y = x + 1 );
+end;
+
+procedure test1;
+var
+    y: integer;
+begin
+
+    y := 0;
+
+    if not dummy1( y, y ) then
+    begin
+        writeln( 'fail 1' );
+        fault_mask := fault_mask or 1;
+    end;
+
+    if not dummy2( y, y ) then
+    begin
+        writeln( 'fail 2' );
+        fault_mask := fault_mask or 2;
+    end;
+
+end;
+
+/////////////////////////////////////////
+
+type
+    bits64 = qword;
+
+procedure add128( a0, a1, b0, b1 : bits64; var z0Ptr, z1Ptr : bits64); {$ifdef debug_inline}inline;{$endif}
+// routine from the SOFTFPU unit
+var
+    z1 : bits64;
+begin
+    z1 := a1 + b1;
+    z1Ptr := z1; // overrites "a1" when called as below and inlined
+    z0Ptr := a0 + b0 + ord( z1 < a1 ); // z1 compared with wrong value
+end;
+
+const
+    correct_zSig0 = bits64($0001A784379D99DB);
+    correct_zSig1 = bits64($4200000000000000);
+
+procedure test2;
+var
+    zSig0, zSig1, aSig0, aSig1: bits64;
+begin
+
+    zSig0 := bits64($000054B40B1F852B);
+    zSig1 := bits64($DA00000000000000);
+    aSig0 := bits64($000152D02C7E14AF);
+    aSig1 := bits64($6800000000000000);
+
+    // this usage pattern from routine SOFTFPU::float128_mul
+    add128( zSig0, zSig1, aSig0, aSig1, zSig0, zSig1 );
+
+    if zSig0 <> correct_zSig0 then
+    begin
+        writeln( 'fail 3' ); // fail if add128 is inlined
+        fault_mask := fault_mask or 4;
+    end;
+
+end;
+
+/////////////////////////////////////////
+
+begin
+    test1;
+    test2;
+    if fault_mask = 0 then
+        writeln( 'pass' )
+    else
+        halt( fault_mask );
+end.

tests/webtbs/tw26534a.pp

@@ -0,0 +1,26 @@
+{ %norun }
+{ %opt=-O2 }
+{Opt.level: -O2}
+{$inline on}
+unit tw26534a;
+interface
+
+implementation
+
+procedure redirect( p: pointer );
+begin
+end;
+
+procedure inlined( var R: byte ); inline;
+begin
+  redirect(@R);
+end;
+
+procedure comp_failed;
+var
+  a: byte;
+begin
+  inlined(a); // ie2006111510
+end;
+
+end.

tests/webtbs/tw26534b.pp

@@ -0,0 +1,19 @@
+{ %opt=-O2 }
+// Opt.level: -O2
+{$inline on}
+program test2;
+
+procedure redirect( p: pointer );
+begin
+end;
+
+procedure inlined( var R: byte ); inline;
+begin
+  redirect(@R);
+end;
+
+var
+  a: byte;
+begin
+  inlined(a); // ie2006111510
+end.

tests/webtbs/tw27256.pp

@@ -0,0 +1,25 @@
+program Test;
+
+type
+  FullType = (Unknown,Stiletto,Vanguard);
+  SubType = Stiletto..Vanguard;
+
+const
+  full_choices: array[FullType] of String = ('U','S','V');
+  sub_choices: array[SubType] of String = ('S', 'V');
+
+var
+  x : longint;
+
+procedure abc(choices: array of String);
+begin
+  inc(x,high(choices));
+end;
+
+begin
+  abc(full_choices);
+  abc(sub_choices);
+  if x<>3 then
+    halt(1);
+  writeln('ok');
+end.