* synchronized with trunk

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

.gitattributes

@@ -18533,7 +18533,9 @@ tests/webtbs/tw37806.pp svneol=native#text/pascal
 tests/webtbs/tw3782.pp svneol=native#text/plain
 tests/webtbs/tw37823.pp svneol=native#text/pascal
 tests/webtbs/tw37844.pp svneol=native#text/pascal
+tests/webtbs/tw37878.pp svneol=native#text/plain
 tests/webtbs/tw37926.pp svneol=native#text/pascal
+tests/webtbs/tw37949.pp svneol=native#text/pascal
 tests/webtbs/tw3796.pp svneol=native#text/plain
 tests/webtbs/tw3805.pp svneol=native#text/plain
 tests/webtbs/tw3814.pp svneol=native#text/plain

compiler/aarch64/cpubase.pas

@@ -48,9 +48,6 @@ unit cpubase;
     type
       TAsmOp= {$i a64op.inc}
 
-      { See comment for this type in arm/cpubase.pas }
-      TCommonAsmOps = Set of A_NONE..A_MOV;
-
       { This should define the array of instructions as string }
       op2strtable=array[tasmop] of string[11];
 
@@ -59,6 +56,13 @@ unit cpubase;
       firstop = low(tasmop);
       { Last value of opcode enumeration  }
       lastop  = high(tasmop);
+      { Last value of opcode for TCommonAsmOps set below  }
+      LastCommonAsmOp = A_MOV;
+
+    type
+      { See comment for this type in arm/cpubase.pas }
+      TCommonAsmOps = Set of A_None .. LastCommonAsmOp;
+
 
 {*****************************************************************************
                                   Registers

compiler/aopt.pas

@@ -273,28 +273,16 @@ Unit aopt;
     Procedure TAsmOptimizer.Optimize;
       Var
         HP: tai;
-        pass: longint;
       Begin
-        pass:=0;
         BlockStart := tai(AsmL.First);
         pass_1;
         While Assigned(BlockStart) Do
           Begin
             if (cs_opt_peephole in current_settings.optimizerswitches) then
               begin
-                if pass = 0 then
-                  PrePeepHoleOpts;
-                { Peephole optimizations }
+                PrePeepHoleOpts;
                 PeepHoleOptPass1;
-                { Only perform them twice in the first pass }
-                if pass = 0 then
-                  PeepHoleOptPass1;
-              end;
-            { more peephole optimizations }
-            if (cs_opt_peephole in current_settings.optimizerswitches) then
-              begin
                 PeepHoleOptPass2;
-                { if pass = last_pass then }
                 PostPeepHoleOpts;
               end;
             { free memory }

compiler/aoptobj.pas

@@ -2464,13 +2464,28 @@ Unit AoptObj;
 
 
     procedure TAOptObj.PeepHoleOptPass1;
+      const
+        MaxPasses: array[1..4] of Cardinal = (1, 2, 8, 8);
       var
         p : tai;
         stoploop, FirstInstruction, JumpOptsAvailable: boolean;
+        PassCount, MaxCount: Cardinal;
       begin
         JumpOptsAvailable := CanDoJumpOpts();
 
         StartPoint := BlockStart;
+        PassCount := 0;
+
+        { Determine the maximum number of passes allowed based on the compiler switches }
+        if (cs_opt_level4 in current_settings.optimizerswitches) then
+          { it should never take more than 8 passes, but the limit is finite to protect against faulty optimisations }
+          MaxCount := MaxPasses[4]
+        else if (cs_opt_level3 in current_settings.optimizerswitches) then
+          MaxCount := MaxPasses[3]
+        else if (cs_opt_level2 in current_settings.optimizerswitches) then
+          MaxCount := MaxPasses[2] { The original double run of Pass 1 }
+        else
+          MaxCount := MaxPasses[1];
 
         repeat
           stoploop:=true;
@@ -2523,7 +2538,10 @@ Unit AoptObj;
                 p := tai(UpdateUsedRegsAndOptimize(p).Next);
 
             end;
-        until stoploop or not(cs_opt_level3 in current_settings.optimizerswitches);
+
+          Inc(PassCount);
+
+        until stoploop or (PassCount >= MaxCount);
       end;
 
 

compiler/arm/cpubase.pas

@@ -44,10 +44,6 @@ unit cpubase;
 
     type
       TAsmOp= {$i armop.inc}
-      {This is a bit of a hack, because there are more than 256 ARM Assembly Ops
-       But FPC currently can't handle more than 256 elements in a set.}
-      TCommonAsmOps = Set of A_None .. A_UADD16;
-
       { This should define the array of instructions as string }
       op2strtable=array[tasmop] of string[11];
 
@@ -56,6 +52,14 @@ unit cpubase;
       firstop = low(tasmop);
       { Last value of opcode enumeration  }
       lastop  = high(tasmop);
+      { Last value of opcode for TCommonAsmOps set below  }
+      LastCommonAsmOp = A_UADD16;
+
+
+    type
+      {This is a bit of a hack, because there are more than 256 ARM Assembly Ops
+       But FPC currently can't handle more than 256 elements in a set.}
+      TCommonAsmOps = Set of A_None .. LastCommonAsmOp;
 
 {*****************************************************************************
                                   Registers

compiler/armgen/aoptarm.pas

@@ -87,7 +87,7 @@ Implementation
     begin
       result :=
         (instr.typ = ait_instruction) and
-        ((op = []) or ((ord(taicpu(instr).opcode)<256) and (taicpu(instr).opcode in op))) and
+        ((op = []) or ((taicpu(instr).opcode<=LastCommonAsmOp) and (taicpu(instr).opcode in op))) and
         ((cond = []) or (taicpu(instr).condition in cond)) and
         ((postfix = []) or (taicpu(instr).oppostfix in postfix));
     end;

compiler/nadd.pas

@@ -3572,6 +3572,9 @@ implementation
         canbesignedconst, canbeunsignedconst: boolean;
       begin
         result := false;
+        { make sure that if there is a constant, that it's on the right }
+        if left.nodetype = ordconstn then
+          swapleftright;
         if is_32to64typeconv(left) then
           begin
             leftoriginallysigned:=is_signed(ttypeconvnode(left).left.resultdef);
@@ -3747,11 +3750,7 @@ implementation
 
         { make sure that if there is a constant, that it's on the right }
         if left.nodetype = ordconstn then
-          begin
-            temp := right;
-            right := left;
-            left := temp;
-          end;
+          swapleftright;
 
         { can we use a shift instead of a mul? }
         if not (cs_check_overflow in current_settings.localswitches) and

compiler/ncgmat.pas

@@ -292,29 +292,18 @@ implementation
     procedure tcgunaryminusnode.second_integer;
       var
         hl: tasmlabel;
-        opsize: tdef;
       begin
         secondpass(left);
-
-{$ifdef cpunodefaultint}
-        opsize:=left.resultdef;
-{$else cpunodefaultint}
-        { in case of a 32 bit system that can natively execute 64 bit operations }
-        if (left.resultdef.size<=sinttype.size) then
-          opsize:=sinttype
-        else
-          opsize:={$ifdef cpu16bitalu}s32inttype{$else}s64inttype{$endif};
-{$endif cpunodefaultint}
         if not(left.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
-          hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,left.resultdef,opsize,false);
-        location_reset(location,LOC_REGISTER,def_cgsize(opsize));
+          hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,left.resultdef,resultdef,false);
+        location_reset(location,LOC_REGISTER,def_cgsize(resultdef));
         location.register:=cg.getintregister(current_asmdata.CurrAsmList,location.size);
-        hlcg.a_op_reg_reg(current_asmdata.CurrAsmList,OP_NEG,opsize,left.location.register,location.register);
+        hlcg.a_op_reg_reg(current_asmdata.CurrAsmList,OP_NEG,resultdef,left.location.register,location.register);
 
         if (cs_check_overflow in current_settings.localswitches) then
           begin
             current_asmdata.getjumplabel(hl);
-            hlcg.a_cmp_const_reg_label(current_asmdata.CurrAsmList,opsize,OC_NE,torddef(opsize).low.svalue,location.register,hl);
+            hlcg.a_cmp_const_reg_label(current_asmdata.CurrAsmList,resultdef,OC_NE,torddef(resultdef).low.svalue,location.register,hl);
             hlcg.g_call_system_proc(current_asmdata.CurrAsmList,'fpc_overflow',[],nil).resetiftemp;
             hlcg.a_label(current_asmdata.CurrAsmList,hl);
           end;

compiler/ncnv.pas

@@ -2925,6 +2925,13 @@ implementation
                   docheckremoveinttypeconvs(tbinarynode(n).left) and
                   docheckremoveinttypeconvs(tbinarynode(n).right);
               end;
+            unaryminusn:
+              begin
+                gotsint:=true;
+                result:=docheckremoveinttypeconvs(tunarynode(n).left);
+              end;
+            notn:
+              result:=docheckremoveinttypeconvs(tunarynode(n).left);
             addn,muln,divn,modn,andn:
               begin
                 if n.nodetype in [divn,modn] then
@@ -2980,6 +2987,21 @@ implementation
               //  ((tordconstnode(tbinarynode(n).right).value and $7fffffff)=tordconstnode(tbinarynode(n).right).value) then
               //  inserttypeconv_internal(tbinarynode(n).left,n.resultdef);
             end;
+          unaryminusn,notn:
+            begin
+              exclude(n.flags,nf_internal);
+              if not forceunsigned and
+                 is_signed(n.resultdef) then
+                begin
+                  doremoveinttypeconvs(tunarynode(n).left,signedtype,false,signedtype,unsignedtype);
+                  n.resultdef:=signedtype;
+                end
+              else
+                begin
+                  doremoveinttypeconvs(tunarynode(n).left,unsignedtype,forceunsigned,signedtype,unsignedtype);
+                  n.resultdef:=unsignedtype;
+                end;
+            end;
           typeconvn:
             begin
               ttypeconvnode(n).totypedef:=todef;
@@ -3271,7 +3293,7 @@ implementation
                     to 64 bit                                               }
                   if (resultdef.size <= 4) and
                     is_64bitint(left.resultdef) and
-                    (left.nodetype in [subn,addn,muln,divn,modn,xorn,andn,orn]) and
+                    (left.nodetype in [subn,addn,muln,divn,modn,xorn,andn,orn,notn,unaryminusn]) and
                     checkremovebiginttypeconvs(left,foundsint,[s8bit,u8bit,s16bit,u16bit,s32bit,u32bit],int64(low(longint)),high(cardinal)) then
                     doremoveinttypeconvs(left,generrordef,not foundsint,s32inttype,u32inttype);
 {$if defined(cpu16bitalu)}

compiler/nmem.pas

@@ -1052,10 +1052,15 @@ implementation
                                                          int64(Tarraydef(left.resultdef).lowrange),
                                                          int64(Tarraydef(left.resultdef).highrange),
                                                          true
-                                                        ))
+                                                        ));
                    end
                  else
-                   inserttypeconv(right,htype)
+                   begin
+                     inserttypeconv(right,htype);
+                     { insert type conversion so cse can pick it up }
+                     if (htype.size<ptrsinttype.size) and is_integer(htype) and not(cs_check_range in current_settings.localswitches) then
+                       inserttypeconv_internal(right,ptrsinttype);
+                   end;
                end;
              stringdef:
                if is_open_string(left.resultdef) then

compiler/nutils.pas

@@ -872,7 +872,17 @@ implementation
                     exit;
                   p := tunarynode(p).left;
                 end;
-              vecn,
+              vecn:
+                begin
+                  inc(result,node_complexity(tbinarynode(p).left));
+                  inc(result);
+                  if (result >= NODE_COMPLEXITY_INF) then
+                    begin
+                      result := NODE_COMPLEXITY_INF;
+                      exit;
+                    end;
+                  p := tbinarynode(p).right;
+                end;
               statementn:
                 begin
                   inc(result,node_complexity(tbinarynode(p).left));

compiler/x86/aoptx86.pas

@@ -3156,6 +3156,8 @@ unit aoptx86;
         l : ASizeInt;
         ref: Integer;
         saveref: treference;
+        TempReg: TRegister;
+        Multiple: TCGInt;
       begin
         Result:=false;
         { removes seg register prefixes from LEA operations, as they
@@ -3202,158 +3204,257 @@ unit aoptx86;
                 exit;
               end;
           end;
+
         if GetNextInstruction(p,hp1) and
-          MatchInstruction(hp1,A_MOV,[taicpu(p).opsize]) and
-          MatchOperand(taicpu(p).oper[1]^,taicpu(hp1).oper[0]^) and
-          MatchOpType(Taicpu(hp1),top_reg,top_reg) and
-          (taicpu(p).oper[1]^.reg<>NR_STACK_POINTER_REG) then
+          (hp1.typ=ait_instruction) then
           begin
-            TransferUsedRegs(TmpUsedRegs);
-            UpdateUsedRegs(TmpUsedRegs, tai(p.next));
-            if not(RegUsedAfterInstruction(taicpu(p).oper[1]^.reg,hp1,TmpUsedRegs)) then
+            if MatchInstruction(hp1,A_MOV,[taicpu(p).opsize]) and
+              MatchOperand(taicpu(p).oper[1]^,taicpu(hp1).oper[0]^) and
+              MatchOpType(Taicpu(hp1),top_reg,top_reg) and
+              (taicpu(p).oper[1]^.reg<>NR_STACK_POINTER_REG) then
               begin
-                taicpu(p).loadoper(1,taicpu(hp1).oper[1]^);
-                DebugMsg(SPeepholeOptimization + 'LeaMov2Lea done',p);
-                RemoveInstruction(hp1);
-                result:=true;
+                TransferUsedRegs(TmpUsedRegs);
+                UpdateUsedRegs(TmpUsedRegs, tai(p.next));
+                if not(RegUsedAfterInstruction(taicpu(p).oper[1]^.reg,hp1,TmpUsedRegs)) then
+                  begin
+                    taicpu(p).loadoper(1,taicpu(hp1).oper[1]^);
+                    DebugMsg(SPeepholeOptimization + 'LeaMov2Lea done',p);
+                    RemoveInstruction(hp1);
+                    result:=true;
+                    exit;
+                  end;
               end;
+
+            { changes
+                lea <ref1>, reg1
+                <op> ...,<ref. with reg1>,...
+                to
+                <op> ...,<ref1>,... }
+            if (taicpu(p).oper[1]^.reg<>current_procinfo.framepointer) and
+              (taicpu(p).oper[1]^.reg<>NR_STACK_POINTER_REG) and
+              not(MatchInstruction(hp1,A_LEA,[])) then
+              begin
+                { find a reference which uses reg1 }
+                if (taicpu(hp1).ops>=1) and (taicpu(hp1).oper[0]^.typ=top_ref) and RegInOp(taicpu(p).oper[1]^.reg,taicpu(hp1).oper[0]^) then
+                  ref:=0
+                else if (taicpu(hp1).ops>=2) and (taicpu(hp1).oper[1]^.typ=top_ref) and RegInOp(taicpu(p).oper[1]^.reg,taicpu(hp1).oper[1]^) then
+                  ref:=1
+                else
+                  ref:=-1;
+                if (ref<>-1) and
+                  { reg1 must be either the base or the index }
+                  ((taicpu(hp1).oper[ref]^.ref^.base=taicpu(p).oper[1]^.reg) xor (taicpu(hp1).oper[ref]^.ref^.index=taicpu(p).oper[1]^.reg)) then
+                  begin
+                    { reg1 can be removed from the reference }
+                    saveref:=taicpu(hp1).oper[ref]^.ref^;
+                    if taicpu(hp1).oper[ref]^.ref^.base=taicpu(p).oper[1]^.reg then
+                      taicpu(hp1).oper[ref]^.ref^.base:=NR_NO
+                    else if taicpu(hp1).oper[ref]^.ref^.index=taicpu(p).oper[1]^.reg then
+                      taicpu(hp1).oper[ref]^.ref^.index:=NR_NO
+                    else
+                      Internalerror(2019111201);
+                    { check if the can insert all data of the lea into the second instruction }
+                    if ((taicpu(hp1).oper[ref]^.ref^.base=taicpu(p).oper[1]^.reg) or (taicpu(hp1).oper[ref]^.ref^.scalefactor <= 1)) and
+                      ((taicpu(p).oper[0]^.ref^.base=NR_NO) or (taicpu(hp1).oper[ref]^.ref^.base=NR_NO)) and
+                      ((taicpu(p).oper[0]^.ref^.index=NR_NO) or (taicpu(hp1).oper[ref]^.ref^.index=NR_NO)) and
+                      ((taicpu(p).oper[0]^.ref^.symbol=nil) or (taicpu(hp1).oper[ref]^.ref^.symbol=nil)) and
+                      ((taicpu(p).oper[0]^.ref^.relsymbol=nil) or (taicpu(hp1).oper[ref]^.ref^.relsymbol=nil)) and
+                      ((taicpu(p).oper[0]^.ref^.scalefactor <= 1) or (taicpu(hp1).oper[ref]^.ref^.scalefactor <= 1)) and
+                      (taicpu(p).oper[0]^.ref^.segment=NR_NO) and (taicpu(hp1).oper[ref]^.ref^.segment=NR_NO)
+{$ifdef x86_64}
+                      and (abs(taicpu(hp1).oper[ref]^.ref^.offset+taicpu(p).oper[0]^.ref^.offset)<=$7fffffff)
+                      and (((taicpu(p).oper[0]^.ref^.base<>NR_RIP) and (taicpu(p).oper[0]^.ref^.index<>NR_RIP)) or
+                           ((taicpu(hp1).oper[ref]^.ref^.base=NR_NO) and (taicpu(hp1).oper[ref]^.ref^.index=NR_NO))
+                          )
+{$endif x86_64}
+                      then
+                      begin
+                        { reg1 might not used by the second instruction after it is remove from the reference }
+                        if not(RegInInstruction(taicpu(p).oper[1]^.reg,taicpu(hp1))) then
+                          begin
+                            TransferUsedRegs(TmpUsedRegs);
+                            UpdateUsedRegs(TmpUsedRegs, tai(p.next));
+                            { reg1 is not updated so it might not be used afterwards }
+                            if not(RegUsedAfterInstruction(taicpu(p).oper[1]^.reg,hp1,TmpUsedRegs)) then
+                              begin
+                                DebugMsg(SPeepholeOptimization + 'LeaOp2Op done',p);
+                                if taicpu(p).oper[0]^.ref^.base<>NR_NO then
+                                  taicpu(hp1).oper[ref]^.ref^.base:=taicpu(p).oper[0]^.ref^.base;
+                                if taicpu(p).oper[0]^.ref^.index<>NR_NO then
+                                  taicpu(hp1).oper[ref]^.ref^.index:=taicpu(p).oper[0]^.ref^.index;
+                                if taicpu(p).oper[0]^.ref^.symbol<>nil then
+                                  taicpu(hp1).oper[ref]^.ref^.symbol:=taicpu(p).oper[0]^.ref^.symbol;
+                                if taicpu(p).oper[0]^.ref^.relsymbol<>nil then
+                                  taicpu(hp1).oper[ref]^.ref^.relsymbol:=taicpu(p).oper[0]^.ref^.relsymbol;
+                                if taicpu(p).oper[0]^.ref^.scalefactor > 1 then
+                                  taicpu(hp1).oper[ref]^.ref^.scalefactor:=taicpu(p).oper[0]^.ref^.scalefactor;
+                                inc(taicpu(hp1).oper[ref]^.ref^.offset,taicpu(p).oper[0]^.ref^.offset);
+                                RemoveCurrentP(p, hp1);
+                                result:=true;
+                                exit;
+                              end
+                          end;
+                      end;
+                    { recover }
+                    taicpu(hp1).oper[ref]^.ref^:=saveref;
+                  end;
+              end;
+
           end;
-        { changes
-            lea offset1(regX), reg1
-            lea offset2(reg1), reg1
-            to
-            lea offset1+offset2(regX), reg1 }
 
         { for now, we do not mess with the stack pointer, thought it might be usefull to remove
           unneeded lea sequences on the stack pointer, it needs to be tested in detail }
         if (taicpu(p).oper[1]^.reg <> NR_STACK_POINTER_REG) and
-          GetNextInstructionUsingReg(p,hp1,taicpu(p).oper[1]^.reg) and
-          MatchInstruction(hp1,A_LEA,[taicpu(p).opsize]) and
-          MatchOperand(taicpu(p).oper[1]^,taicpu(hp1).oper[1]^) and
-          (taicpu(p).oper[0]^.ref^.relsymbol=nil) and
-          (taicpu(p).oper[0]^.ref^.segment=NR_NO) and
-          (taicpu(p).oper[0]^.ref^.symbol=nil) and
-          (((taicpu(hp1).oper[0]^.ref^.base=taicpu(p).oper[1]^.reg) and
-            (taicpu(p).oper[0]^.ref^.scalefactor in [0,1]) and
-            (taicpu(p).oper[0]^.ref^.index=NR_NO) and
-            (taicpu(p).oper[0]^.ref^.index=taicpu(hp1).oper[0]^.ref^.index) and
-            (taicpu(p).oper[0]^.ref^.scalefactor=taicpu(hp1).oper[0]^.ref^.scalefactor)
-           ) or
-           ((taicpu(hp1).oper[0]^.ref^.index=taicpu(p).oper[1]^.reg) and
-            (taicpu(p).oper[0]^.ref^.index=NR_NO)
-           ) or
-           ((taicpu(hp1).oper[0]^.ref^.base=taicpu(p).oper[1]^.reg) and
-            (taicpu(hp1).oper[0]^.ref^.scalefactor in [0,1]) and
-            (taicpu(p).oper[0]^.ref^.base=NR_NO) and
-            not(RegUsedBetween(taicpu(p).oper[0]^.ref^.index,p,hp1)))
-          ) and
-          not(RegUsedBetween(taicpu(p).oper[0]^.ref^.base,p,hp1)) and
-          (taicpu(p).oper[0]^.ref^.relsymbol=taicpu(hp1).oper[0]^.ref^.relsymbol) and
-          (taicpu(p).oper[0]^.ref^.segment=taicpu(hp1).oper[0]^.ref^.segment) and
-          (taicpu(p).oper[0]^.ref^.symbol=taicpu(hp1).oper[0]^.ref^.symbol) then
+          GetNextInstructionUsingReg(p,hp1,taicpu(p).oper[1]^.reg) then
           begin
-            DebugMsg(SPeepholeOptimization + 'LeaLea2Lea done',p);
-            if taicpu(hp1).oper[0]^.ref^.index=taicpu(p).oper[1]^.reg then
+            { changes
+                lea offset1(regX), reg1
+                lea offset2(reg1), reg1
+                to
+                lea offset1+offset2(regX), reg1 }
+
+            if MatchInstruction(hp1,A_LEA,[taicpu(p).opsize]) and
+              MatchOperand(taicpu(p).oper[1]^,taicpu(hp1).oper[1]^) and
+              (taicpu(p).oper[0]^.ref^.relsymbol=nil) and
+              (taicpu(p).oper[0]^.ref^.segment=NR_NO) and
+              (taicpu(p).oper[0]^.ref^.symbol=nil) and
+              (((taicpu(hp1).oper[0]^.ref^.base=taicpu(p).oper[1]^.reg) and
+                (taicpu(p).oper[0]^.ref^.scalefactor <= 1) and
+                (taicpu(p).oper[0]^.ref^.index=NR_NO) and
+                (taicpu(p).oper[0]^.ref^.index=taicpu(hp1).oper[0]^.ref^.index) and
+                (taicpu(p).oper[0]^.ref^.scalefactor=taicpu(hp1).oper[0]^.ref^.scalefactor)
+               ) or
+               ((taicpu(hp1).oper[0]^.ref^.index=taicpu(p).oper[1]^.reg) and
+                (taicpu(p).oper[0]^.ref^.index=NR_NO)
+               ) or
+               ((taicpu(hp1).oper[0]^.ref^.base=taicpu(p).oper[1]^.reg) and
+                (taicpu(hp1).oper[0]^.ref^.scalefactor <= 1) and
+                (taicpu(p).oper[0]^.ref^.base=NR_NO) and
+                not(RegUsedBetween(taicpu(p).oper[0]^.ref^.index,p,hp1)))
+              ) and
+              not(RegUsedBetween(taicpu(p).oper[0]^.ref^.base,p,hp1)) and
+              (taicpu(p).oper[0]^.ref^.relsymbol=taicpu(hp1).oper[0]^.ref^.relsymbol) and
+              (taicpu(p).oper[0]^.ref^.segment=taicpu(hp1).oper[0]^.ref^.segment) and
+              (taicpu(p).oper[0]^.ref^.symbol=taicpu(hp1).oper[0]^.ref^.symbol) then
               begin
-                taicpu(hp1).oper[0]^.ref^.index:=taicpu(p).oper[0]^.ref^.base;
-                inc(taicpu(hp1).oper[0]^.ref^.offset,taicpu(p).oper[0]^.ref^.offset*max(taicpu(hp1).oper[0]^.ref^.scalefactor,1));
-                { if the register is used as index and base, we have to increase for base as well
-                  and adapt base }
-                if taicpu(hp1).oper[0]^.ref^.base=taicpu(p).oper[1]^.reg then
+                DebugMsg(SPeepholeOptimization + 'LeaLea2Lea done',p);
+                if taicpu(hp1).oper[0]^.ref^.index=taicpu(p).oper[1]^.reg then
+                  begin
+                    taicpu(hp1).oper[0]^.ref^.index:=taicpu(p).oper[0]^.ref^.base;
+                    inc(taicpu(hp1).oper[0]^.ref^.offset,taicpu(p).oper[0]^.ref^.offset*max(taicpu(hp1).oper[0]^.ref^.scalefactor,1));
+                    { if the register is used as index and base, we have to increase for base as well
+                      and adapt base }
+                    if taicpu(hp1).oper[0]^.ref^.base=taicpu(p).oper[1]^.reg then
+                      begin
+                        taicpu(hp1).oper[0]^.ref^.base:=taicpu(p).oper[0]^.ref^.base;
+                        inc(taicpu(hp1).oper[0]^.ref^.offset,taicpu(p).oper[0]^.ref^.offset);
+                      end;
+                  end
+                else
                   begin
-                    taicpu(hp1).oper[0]^.ref^.base:=taicpu(p).oper[0]^.ref^.base;
                     inc(taicpu(hp1).oper[0]^.ref^.offset,taicpu(p).oper[0]^.ref^.offset);
+                    taicpu(hp1).oper[0]^.ref^.base:=taicpu(p).oper[0]^.ref^.base;
                   end;
-              end
-            else
-              begin
-                inc(taicpu(hp1).oper[0]^.ref^.offset,taicpu(p).oper[0]^.ref^.offset);
-                taicpu(hp1).oper[0]^.ref^.base:=taicpu(p).oper[0]^.ref^.base;
-              end;
-            if taicpu(p).oper[0]^.ref^.index<>NR_NO then
-              begin
-                taicpu(hp1).oper[0]^.ref^.base:=taicpu(hp1).oper[0]^.ref^.index;
-                taicpu(hp1).oper[0]^.ref^.index:=taicpu(p).oper[0]^.ref^.index;
-                taicpu(hp1).oper[0]^.ref^.scalefactor:=taicpu(p).oper[0]^.ref^.scalefactor;
+                if taicpu(p).oper[0]^.ref^.index<>NR_NO then
+                  begin
+                    taicpu(hp1).oper[0]^.ref^.base:=taicpu(hp1).oper[0]^.ref^.index;
+                    taicpu(hp1).oper[0]^.ref^.index:=taicpu(p).oper[0]^.ref^.index;
+                    taicpu(hp1).oper[0]^.ref^.scalefactor:=taicpu(p).oper[0]^.ref^.scalefactor;
+                  end;
+                RemoveCurrentP(p);
+                result:=true;
+                exit;
               end;
-            RemoveCurrentP(p);
-            result:=true;
-            exit;
-          end;
-        { changes
-            lea <ref1>, reg1
-            <op> ...,<ref. with reg1>,...
-            to
-            <op> ...,<ref1>,... }
-        if (taicpu(p).oper[1]^.reg<>current_procinfo.framepointer) and
-          (taicpu(p).oper[1]^.reg<>NR_STACK_POINTER_REG) and
-          GetNextInstruction(p,hp1) and
-          (hp1.typ=ait_instruction) and
-          not(MatchInstruction(hp1,A_LEA,[])) then
-          begin
-            { find a reference which uses reg1 }
-            if (taicpu(hp1).ops>=1) and (taicpu(hp1).oper[0]^.typ=top_ref) and RegInOp(taicpu(p).oper[1]^.reg,taicpu(hp1).oper[0]^) then
-              ref:=0
-            else if (taicpu(hp1).ops>=2) and (taicpu(hp1).oper[1]^.typ=top_ref) and RegInOp(taicpu(p).oper[1]^.reg,taicpu(hp1).oper[1]^) then
-              ref:=1
-            else
-              ref:=-1;
-            if (ref<>-1) and
-              { reg1 must be either the base or the index }
-              ((taicpu(hp1).oper[ref]^.ref^.base=taicpu(p).oper[1]^.reg) xor (taicpu(hp1).oper[ref]^.ref^.index=taicpu(p).oper[1]^.reg)) then
+
+            { Change:
+                leal/q $x(%reg1),%reg2
+                ...
+                shll/q $y,%reg2
+              To:
+                leal/q $(x+2^y)(%reg1,2^y),%reg2 (if y <= 3)
+            }
+            if MatchInstruction(hp1, A_SHL, [taicpu(p).opsize]) and
+              MatchOpType(taicpu(hp1), top_const, top_reg) and
+              (taicpu(hp1).oper[0]^.val <= 3) then
               begin
-                { reg1 can be removed from the reference }
-                saveref:=taicpu(hp1).oper[ref]^.ref^;
-                if taicpu(hp1).oper[ref]^.ref^.base=taicpu(p).oper[1]^.reg then
-                  taicpu(hp1).oper[ref]^.ref^.base:=NR_NO
-                else if taicpu(hp1).oper[ref]^.ref^.index=taicpu(p).oper[1]^.reg then
-                  taicpu(hp1).oper[ref]^.ref^.index:=NR_NO
-                else
-                  Internalerror(2019111201);
-                { check if the can insert all data of the lea into the second instruction }
-                if ((taicpu(hp1).oper[ref]^.ref^.base=taicpu(p).oper[1]^.reg) or (taicpu(hp1).oper[ref]^.ref^.scalefactor in [0,1])) and
-                  ((taicpu(p).oper[0]^.ref^.base=NR_NO) or (taicpu(hp1).oper[ref]^.ref^.base=NR_NO)) and
-                  ((taicpu(p).oper[0]^.ref^.index=NR_NO) or (taicpu(hp1).oper[ref]^.ref^.index=NR_NO)) and
-                  ((taicpu(p).oper[0]^.ref^.symbol=nil) or (taicpu(hp1).oper[ref]^.ref^.symbol=nil)) and
-                  ((taicpu(p).oper[0]^.ref^.relsymbol=nil) or (taicpu(hp1).oper[ref]^.ref^.relsymbol=nil)) and
-                  ((taicpu(p).oper[0]^.ref^.scalefactor in [0,1]) or (taicpu(hp1).oper[ref]^.ref^.scalefactor in [0,1])) and
-                  (taicpu(p).oper[0]^.ref^.segment=NR_NO) and (taicpu(hp1).oper[ref]^.ref^.segment=NR_NO)
-{$ifdef x86_64}
-                  and (abs(taicpu(hp1).oper[ref]^.ref^.offset+taicpu(p).oper[0]^.ref^.offset)<=$7fffffff)
-                  and (((taicpu(p).oper[0]^.ref^.base<>NR_RIP) and (taicpu(p).oper[0]^.ref^.index<>NR_RIP)) or
-                       ((taicpu(hp1).oper[ref]^.ref^.base=NR_NO) and (taicpu(hp1).oper[ref]^.ref^.index=NR_NO))
+                Multiple := 1 shl taicpu(hp1).oper[0]^.val;
+                TransferUsedRegs(TmpUsedRegs);
+                UpdateUsedRegs(TmpUsedRegs, tai(hp1.Next));
+
+                TempReg := taicpu(hp1).oper[1]^.reg; { Store locally to reduce the number of dereferences }
+                if
+                  { This allows the optimisation in some circumstances even if the lea instruction already has a scale factor
+                    (this works even if scalefactor is zero) }
+                  ((Multiple * taicpu(p).oper[0]^.ref^.scalefactor) <= 8) and
+
+                  { Ensure offset doesn't go out of bounds }
+                  (abs(taicpu(p).oper[0]^.ref^.offset * Multiple) <= $7FFFFFFF) and
+
+                  not (RegInUsedRegs(NR_DEFAULTFLAGS,TmpUsedRegs)) and
+                  MatchOperand(taicpu(p).oper[1]^, TempReg) and
+                  (
+                    (
+                      not SuperRegistersEqual(taicpu(p).oper[0]^.ref^.base, TempReg) and
+                      (
+                        (taicpu(p).oper[0]^.ref^.index = NR_NO) or
+                        (taicpu(p).oper[0]^.ref^.index = NR_INVALID) or
+                        (
+                          { Check for lea $x(%reg1,%reg1),%reg2 and treat as it it were lea $x(%reg1,2),%reg2 }
+                          (taicpu(p).oper[0]^.ref^.index = taicpu(p).oper[0]^.ref^.base) and
+                          (taicpu(p).oper[0]^.ref^.scalefactor <= 1)
+                        )
                       )
-{$endif x86_64}
-                  then
+                    ) or (
+                      (
+                        (taicpu(p).oper[0]^.ref^.base = NR_NO) or
+                        (taicpu(p).oper[0]^.ref^.base = NR_INVALID)
+                      ) and
+                      not SuperRegistersEqual(taicpu(p).oper[0]^.ref^.index, TempReg)
+                    )
+                  ) then
                   begin
-                    { reg1 might not used by the second instruction after it is remove from the reference }
-                    if not(RegInInstruction(taicpu(p).oper[1]^.reg,taicpu(hp1))) then
-                      begin
-                        TransferUsedRegs(TmpUsedRegs);
-                        UpdateUsedRegs(TmpUsedRegs, tai(p.next));
-                        { reg1 is not updated so it might not be used afterwards }
-                        if not(RegUsedAfterInstruction(taicpu(p).oper[1]^.reg,hp1,TmpUsedRegs)) then
-                          begin
-                            DebugMsg(SPeepholeOptimization + 'LeaOp2Op done',p);
-                            if taicpu(p).oper[0]^.ref^.base<>NR_NO then
-                              taicpu(hp1).oper[ref]^.ref^.base:=taicpu(p).oper[0]^.ref^.base;
-                            if taicpu(p).oper[0]^.ref^.index<>NR_NO then
-                              taicpu(hp1).oper[ref]^.ref^.index:=taicpu(p).oper[0]^.ref^.index;
-                            if taicpu(p).oper[0]^.ref^.symbol<>nil then
-                              taicpu(hp1).oper[ref]^.ref^.symbol:=taicpu(p).oper[0]^.ref^.symbol;
-                            if taicpu(p).oper[0]^.ref^.relsymbol<>nil then
-                              taicpu(hp1).oper[ref]^.ref^.relsymbol:=taicpu(p).oper[0]^.ref^.relsymbol;
-                            if not(taicpu(p).oper[0]^.ref^.scalefactor in [0,1]) then
-                              taicpu(hp1).oper[ref]^.ref^.scalefactor:=taicpu(p).oper[0]^.ref^.scalefactor;
-                            inc(taicpu(hp1).oper[ref]^.ref^.offset,taicpu(p).oper[0]^.ref^.offset);
-                            RemoveCurrentP(p, hp1);
-                            result:=true;
-                            exit;
-                          end
-                      end;
+                    repeat
+                      with taicpu(p).oper[0]^.ref^ do
+                        begin
+                          { Convert lea $x(%reg1,%reg1),%reg2 to lea $x(%reg1,2),%reg2 }
+                          if index = base then
+                            begin
+                              if Multiple > 4 then
+                                { Optimisation will no longer work because resultant
+                                  scale factor will exceed 8 }
+                                Break;
+
+                              base := NR_NO;
+                              scalefactor := 2;
+                              DebugMsg(SPeepholeOptimization + 'lea $x(%reg1,%reg1),%reg2 -> lea $x(%reg1,2),%reg2 for following optimisation', p);
+                            end
+                          else if (base <> NR_NO) and (base <> NR_INVALID) then
+                            begin
+                              { Scale factor only works on the index register }
+                              index := base;
+                              base := NR_NO;
+                            end;
+
+                          { For safety }
+                          if scalefactor <= 1 then
+                            begin
+                              DebugMsg(SPeepholeOptimization + 'LeaShl2Lea 1', p);
+                              scalefactor := Multiple;
+                            end
+                          else
+                            begin
+                              DebugMsg(SPeepholeOptimization + 'LeaShl2Lea 2', p);
+                              scalefactor := scalefactor * Multiple;
+                            end;
+
+                          offset := offset * Multiple;
+                        end;
+                      RemoveInstruction(hp1);
+                      Result := True;
+                      Exit;
+                    { This repeat..until loop exists for the benefit of Break }
+                    until True;
                   end;
-                { recover }
-                taicpu(hp1).oper[ref]^.ref^:=saveref;
               end;
           end;
       end;
@@ -5970,26 +6071,27 @@ unit aoptx86;
     function TX86AsmOptimizer.OptPass2Lea(var p : tai) : Boolean;
       begin
         Result:=false;
-        if not (RegInUsedRegs(NR_DEFAULTFLAGS,UsedRegs)) and
-          MatchReference(taicpu(p).oper[0]^.ref^,taicpu(p).oper[1]^.reg,NR_INVALID) and
-          (taicpu(p).oper[0]^.ref^.index<>NR_NO) then
+        if not (RegInUsedRegs(NR_DEFAULTFLAGS,UsedRegs)) then
           begin
-            taicpu(p).loadreg(1,taicpu(p).oper[0]^.ref^.base);
-            taicpu(p).loadreg(0,taicpu(p).oper[0]^.ref^.index);
-            taicpu(p).opcode:=A_ADD;
-            DebugMsg(SPeepholeOptimization + 'Lea2AddBase done',p);
-            result:=true;
-          end
+            if MatchReference(taicpu(p).oper[0]^.ref^,taicpu(p).oper[1]^.reg,NR_INVALID) and
+              (taicpu(p).oper[0]^.ref^.index<>NR_NO) then
+              begin
+                taicpu(p).loadreg(1,taicpu(p).oper[0]^.ref^.base);
+                taicpu(p).loadreg(0,taicpu(p).oper[0]^.ref^.index);
+                taicpu(p).opcode:=A_ADD;
+                DebugMsg(SPeepholeOptimization + 'Lea2AddBase done',p);
+                result:=true;
+              end
 
-        else if not (RegInUsedRegs(NR_DEFAULTFLAGS,UsedRegs)) and
-          MatchReference(taicpu(p).oper[0]^.ref^,NR_INVALID,taicpu(p).oper[1]^.reg) and
-          (taicpu(p).oper[0]^.ref^.base<>NR_NO) then
-          begin
-            taicpu(p).loadreg(1,taicpu(p).oper[0]^.ref^.index);
-            taicpu(p).loadreg(0,taicpu(p).oper[0]^.ref^.base);
-            taicpu(p).opcode:=A_ADD;
-            DebugMsg(SPeepholeOptimization + 'Lea2AddIndex done',p);
-            result:=true;
+            else if MatchReference(taicpu(p).oper[0]^.ref^,NR_INVALID,taicpu(p).oper[1]^.reg) and
+              (taicpu(p).oper[0]^.ref^.base<>NR_NO) then
+              begin
+                taicpu(p).loadreg(1,taicpu(p).oper[0]^.ref^.index);
+                taicpu(p).loadreg(0,taicpu(p).oper[0]^.ref^.base);
+                taicpu(p).opcode:=A_ADD;
+                DebugMsg(SPeepholeOptimization + 'Lea2AddIndex done',p);
+                result:=true;
+              end;
           end;
       end;
 

packages/odbc/src/odbcsql.inc

@@ -90,6 +90,7 @@ type
   PSQLREAL      = ^SQLREAL;
   PSQLDOUBLE    = ^SQLDOUBLE;
   PSQLFLOAT     = ^SQLFLOAT;
+  PSQLPOINTER   = ^SQLPOINTER;
   PSQLHANDLE    = ^SQLHANDLE;
 
 const
@@ -304,6 +305,7 @@ const
 
   SQL_OV_ODBC3          = 3;
   SQL_OV_ODBC2          = 2;
+  SQL_OV_ODBC3_80       = 380;
   SQL_ATTR_ODBC_VERSION = 200;
 
   { Options for SQLDriverConnect }
@@ -528,17 +530,20 @@ const
   SQL_GET_BOOKMARK            =13;      //      GetStmtOption Only */
   SQL_ROW_NUMBER              =14 ;     //      GetStmtOption Only */
 
-  SQL_ATTR_CURSOR_TYPE        = SQL_CURSOR_TYPE;
+  { statement attributes for ODBC 3.0 }
+  SQL_ATTR_ASYNC_ENABLE       = 4;
   SQL_ATTR_CONCURRENCY        = SQL_CONCURRENCY;
+  SQL_ATTR_CURSOR_TYPE        = SQL_CURSOR_TYPE;
   SQL_ATTR_FETCH_BOOKMARK_PTR = 16;
+  SQL_ATTR_MAX_ROWS           = SQL_MAX_ROWS;
+  SQL_ATTR_PARAMSET_SIZE      = 22;
+  SQL_ATTR_QUERY_TIMEOUT      = SQL_QUERY_TIMEOUT;
+  SQL_ATTR_ROW_NUMBER         = SQL_ROW_NUMBER;
   SQL_ATTR_ROW_STATUS_PTR     = 25;
   SQL_ATTR_ROWS_FETCHED_PTR   = 26;
-
-  SQL_ATTR_ROW_NUMBER         = SQL_ROW_NUMBER;
-  SQL_ATTR_MAX_ROWS           = SQL_MAX_ROWS;
   SQL_ATTR_USE_BOOKMARKS      = SQL_USE_BOOKMARKS;
 
-//* connection attributes */
+  { connection attributes }
   SQL_ACCESS_MODE             =101;
   SQL_AUTOCOMMIT              =102;
   SQL_LOGIN_TIMEOUT           =103;
@@ -553,7 +558,7 @@ const
   SQL_PACKET_SIZE             =112;
 
 
-//* connection attributes with new names */
+  { connection attributes with new names }
   SQL_ATTR_ACCESS_MODE        =SQL_ACCESS_MODE;
   SQL_ATTR_AUTOCOMMIT         =SQL_AUTOCOMMIT;
   SQL_ATTR_CONNECTION_DEAD    =1209;        //* GetConnectAttr only */
@@ -703,13 +708,15 @@ const
 #define SQL_PRED_CHAR     1
 #define SQL_PRED_BASIC    2
 #endif
+}
 
-/* values of UNNAMED field in descriptor */
-#if (ODBCVER >= 0x0300)
-#define SQL_NAMED           0
-#define SQL_UNNAMED         1
-#endif
+  { values of UNNAMED field in descriptor }
+{$ifdef ODBCVER3}
+  SQL_NAMED   = 0;
+  SQL_UNNAMED = 1;
+{$endif}
 
+{
 /* values of ALLOC_TYPE field in descriptor */
 #if (ODBCVER >= 0x0300)
 #define SQL_DESC_ALLOC_AUTO 1
@@ -761,13 +768,11 @@ const
   SQL_BEST_ROWID        = 1;
   SQL_ROWVER            = 2;
 
-{
-#define SQL_PC_UNKNOWN      0
-#if (ODBCVER >= 0x0300)
-#define SQL_PC_NON_PSEUDO   1
-#endif
-#define SQL_PC_PSEUDO       2
-}
+  SQL_PC_UNKNOWN    = 0;
+{$ifdef ODBCVER3}
+  SQL_PC_NON_PSEUDO = 1;
+{$endif}
+  SQL_PC_PSEUDO     = 2;
 
 //* Reserved value for the IdentifierType argument of SQLSpecialColumns() */
 {$ifdef ODBCVER3}
@@ -790,6 +795,66 @@ const
 //  SQL_INDEX_BTREE     = ???;
 //  SQL_INDEX_CONTENT   = ???;
 
+(* SQLGetFunctions() values to identify ODBC APIs *)
+  SQL_API_SQLALLOCCONNECT     = 1;
+  SQL_API_SQLALLOCENV         = 2;
+  SQL_API_SQLALLOCHANDLE      = 1001;
+  SQL_API_SQLALLOCSTMT        = 3;
+  SQL_API_SQLBINDCOL          = 4;
+  SQL_API_SQLBINDPARAM        = 1002;
+  SQL_API_SQLCANCEL           = 5;
+  SQL_API_SQLCLOSECURSOR      = 1003;
+  SQL_API_SQLCOLATTRIBUTE     = 6;
+  SQL_API_SQLCOLUMNS          = 40;
+  SQL_API_SQLCONNECT          = 7;
+  SQL_API_SQLCOPYDESC         = 1004;
+  SQL_API_SQLDATASOURCES      = 57;
+  SQL_API_SQLDESCRIBECOL      = 8;
+  SQL_API_SQLDISCONNECT       = 9;
+  SQL_API_SQLENDTRAN          = 1005;
+  SQL_API_SQLERROR            = 10;
+  SQL_API_SQLEXECDIRECT       = 11;
+  SQL_API_SQLEXECUTE          = 12;
+  SQL_API_SQLFETCH            = 13;
+  SQL_API_SQLFETCHSCROLL      = 1021;
+  SQL_API_SQLFREECONNECT      = 14;
+  SQL_API_SQLFREEENV          = 15;
+  SQL_API_SQLFREEHANDLE       = 1006;
+  SQL_API_SQLFREESTMT         = 16;
+  SQL_API_SQLGETCONNECTATTR   = 1007;
+  SQL_API_SQLGETCONNECTOPTION = 42;
+  SQL_API_SQLGETCURSORNAME    = 17;
+  SQL_API_SQLGETDATA          = 43;
+  SQL_API_SQLGETDESCFIELD     = 1008;
+  SQL_API_SQLGETDESCREC       = 1009;
+  SQL_API_SQLGETDIAGFIELD     = 1010;
+  SQL_API_SQLGETDIAGREC       = 1011;
+  SQL_API_SQLGETENVATTR       = 1012;
+  SQL_API_SQLGETFUNCTIONS     = 44;
+  SQL_API_SQLGETINFO          = 45;
+  SQL_API_SQLGETSTMTATTR      = 1014;
+  SQL_API_SQLGETSTMTOPTION    = 46;
+  SQL_API_SQLGETTYPEINFO      = 47;
+  SQL_API_SQLNUMRESULTCOLS    = 18;
+  SQL_API_SQLPARAMDATA        = 48;
+  SQL_API_SQLPREPARE          = 19;
+  SQL_API_SQLPUTDATA          = 49;
+  SQL_API_SQLROWCOUNT         = 20;
+  SQL_API_SQLSETCONNECTATTR   = 1016;
+  SQL_API_SQLSETCONNECTOPTION = 50;
+  SQL_API_SQLSETCURSORNAME    = 21;
+  SQL_API_SQLSETDESCFIELD     = 1017;
+  SQL_API_SQLSETDESCREC       = 1018;
+  SQL_API_SQLSETENVATTR       = 1019;
+  SQL_API_SQLSETPARAM         = 22;
+  SQL_API_SQLSETSTMTATTR      = 1020;
+  SQL_API_SQLSETSTMTOPTION    = 51;
+  SQL_API_SQLSPECIALCOLUMNS   = 52;
+  SQL_API_SQLSTATISTICS       = 53;
+  SQL_API_SQLTABLES           = 54;
+  SQL_API_SQLTRANSACT         = 23;
+  SQL_API_SQLCANCELHANDLE     = 1022;
+
 {
 /* Information requested by SQLGetInfo() */
 #if (ODBCVER >= 0x0300)
@@ -870,6 +935,9 @@ const
   SQL_MAXIMUM_IDENTIFIER_LENGTH = SQL_MAX_IDENTIFIER_LEN;
 {$endif} { ODBCVER >= 0x0300 }
 
+  { Extended definitions for SQLGetInfo }
+  SQL_NEED_LONG_DATA_LEN        = 111;
+
 {/* SQL_ALTER_TABLE bitmasks */
 #if (ODBCVER >= 0x0200)
 #define SQL_AT_ADD_COLUMN                       0x00000001L
@@ -897,8 +965,12 @@ const
 *#define SQL_AT_CONSTRAINT_NON_DEFERRABLE                       0x00080000L
 
 #endif  /* ODBCVER >= 0x0300 */
+}
 
+  SQL_API_ALL_FUNCTIONS = 0;
+  SQL_API_ODBC3_ALL_FUNCTIONS = 999;
 
+{
 /* SQL_ASYNC_MODE values */
 #if (ODBCVER >= 0x0300)
 #define SQL_AM_NONE                         0
@@ -978,6 +1050,10 @@ const
   SQL_SS_DELETIONS = 2;
   SQL_SS_UPDATES   = 4;
 
+{ SQLBindParameter extensions }
+  SQL_DEFAULT_PARAM = -5;
+  SQL_IGNORE = -6;
+
 { SQLColAttributes defines }
   SQL_COLUMN_COUNT               = 0;
   SQL_COLUMN_NAME                = 1;
@@ -1038,6 +1114,11 @@ const
   SQL_DESC_UPDATABLE         = SQL_COLUMN_UPDATABLE;
 {$endif}
 
+  { defines for diagnostics fields }
+  SQL_DIAG_CURSOR_ROW_COUNT  = -1249;
+  SQL_DIAG_ROW_NUMBER        = -1248;
+  SQL_DIAG_COLUMN_NUMBER     = -1247;
+
 { SQLColAttributes subdefines for SQL_COLUMN_UPDATABLE }
   SQL_ATTR_READONLY          = 0;
   SQL_ATTR_WRITE             = 1;
@@ -1057,6 +1138,14 @@ const
   ODBC_CONFIG_SYS_DSN = 5;
   ODBC_REMOVE_SYS_DSN = 6;
 
+
+  { Defines for SQLTables }
+{$ifdef ODBCVER3}
+  SQL_ALL_CATALOGS    = '%';
+  SQL_ALL_SCHEMAS     = '%';
+  SQL_ALL_TABLE_TYPES = '%';
+{$endif}
+
 {$ifdef DYNLOADINGODBC}
 
 type   TSQLAllocHandle =function(HandleType: SQLSMALLINT;
@@ -1113,6 +1202,8 @@ type   TSQLExecDirect=function (StatementHandle:SQLHSTMT;
        TSQLExecDirectW=function (StatementHandle:SQLHSTMT;
            StatementText:PSQLWCHAR;TextLength:SQLINTEGER):SQLRETURN;{$ifdef fpc} extdecl {$else} stdcall {$endif};
 
+type   TSQLParamData=function(StatementHandle:SQLHSTMT; ValuePtrPtr: PSQLPOINTER):SQLRETURN;{$ifdef fpc} extdecl {$else} stdcall {$endif};
+
 type   TSQLPrepare=function (StatementHandle:SQLHSTMT;
            StatementText:PSQLCHAR;TextLength:SQLINTEGER):SQLRETURN;{$ifdef fpc} extdecl {$else} stdcall {$endif};
        TSQLPrepareW=function (StatementHandle:SQLHSTMT;
@@ -1167,6 +1258,10 @@ type   TSQLSetDescRec=function (DescriptorHandle:SQLHDESC;
            Length:SQLLEN; Precision, Scale: SQLSMALLINT;
            DataPtr:SQLPOINTER; StringLengthPtr,IndicatorPtr:PSQLLEN):SQLRETURN;{$ifdef fpc} extdecl {$else} stdcall {$endif};
 
+type   TSQLGetFunctions=function(ConnectionHandle: SQLHDBC;
+           FunctionId: SQLUSMALLINT;
+           Supported: PSQLUSMALLINT):SQLRETURN;{$ifdef fpc} extdecl {$else} stdcall {$endif};
+
 type   TSQLGetInfo=function (ConnectionHandle:SQLHDBC;
            InfoType:SQLUSMALLINT;InfoValue:SQLPOINTER;
            BufferLength:SQLSMALLINT;StringLength:PSQLSMALLINT):SQLRETURN;{$ifdef fpc} extdecl {$else} stdcall {$endif};
@@ -1198,7 +1293,11 @@ type   TSQLDrivers=function (EnvironmentHandle:SQLHENV;
            DriverAttributes:PSQLCHAR;BufferLength2:SQLSMALLINT;
            AttributesLength2:PSQLSMALLINT):SQLRETURN;{$ifdef fpc} extdecl {$else} stdcall {$endif};
 
-type   TSQLSetConnectAttr=function (ConnectionHandle:SQLHDBC;
+type   TSQLGetConnectAttr=function (ConnectionHandle:SQLHDBC;
+           Attribute: SQLINTEGER; Value: SQLPOINTER;
+           BufferLength: SQLINTEGER; StringLengthPtr: PSQLINTEGER):SQLRETURN;{$ifdef fpc} extdecl {$else} stdcall {$endif};
+
+       TSQLSetConnectAttr=function (ConnectionHandle:SQLHDBC;
            Attribute:SQLINTEGER; Value:SQLPOINTER;
            StringLength:SQLINTEGER):SQLRETURN;{$ifdef fpc} extdecl {$else} stdcall {$endif};
 
@@ -1206,7 +1305,7 @@ type   TSQLGetCursorName=function (StatementHandle:SQLHSTMT;
            CursorName:PSQLCHAR; BufferLength:SQLSMALLINT;
            NameLength:PSQLSMALLINT):SQLRETURN;{$ifdef fpc} extdecl {$else} stdcall {$endif};
 
-type   TSQLSetCursorName=function (StatementHandle:SQLHSTMT;
+       TSQLSetCursorName=function (StatementHandle:SQLHSTMT;
            CursorName:PSQLCHAR; NameLength:SQLSMALLINT):SQLRETURN;{$ifdef fpc} extdecl {$else} stdcall {$endif};
 
 type   TSQLRowCount=function (StatementHandle:SQLHSTMT;
@@ -1219,6 +1318,13 @@ type   TSQLBindParameter=function (hstmt:SQLHSTMT;
            rgbValue:SQLPOINTER;cbValueMax:SQLLEN;
            pcbValue:PSQLLEN):SQLRETURN;{$ifdef fpc} extdecl {$else} stdcall {$endif};
 
+type   TSQLDescribeParam=function (StatementHandle: SQLHSTMT;
+           ParameterNumber: SQLUSMALLINT;
+           DataTypePtr: PSQLSMALLINT;
+           ParameterSizePtr: PSQLULEN;
+           DecimalDigitsPtr: PSQLSMALLINT;
+           NullablePtr: PSQLSMALLINT): SQLRETURN;{$ifdef fpc} extdecl {$else} stdcall {$endif};
+
 type   TSQLFreeStmt=function (StatementHandle:SQLHSTMT;
            Option:SQLUSMALLINT):SQLRETURN;{$ifdef fpc} extdecl {$else} stdcall {$endif};
 
@@ -1246,7 +1352,7 @@ type   TSQLColumns=function ( hstmt : SQLHSTMT;
            szTableOwner : PSQLCHAR;cbTableOwner : SQLSMALLINT;
            szTableName : PSQLCHAR;cbTableName : SQLSMALLINT;
            szColumnName : PSQLCHAR;cbColumnName : SQLSMALLINT ) : SQLRETURN; {$ifdef fpc} extdecl {$else} stdcall {$endif};
-      TSQLColumnsW=function ( hstmt : SQLHSTMT;
+       TSQLColumnsW=function ( hstmt : SQLHSTMT;
            szTableQualifier : PSQLWCHAR;cbTableQualifier : SQLSMALLINT;
            szTableOwner : PSQLWCHAR;cbTableOwner : SQLSMALLINT;
            szTableName : PSQLWCHAR;cbTableName : SQLSMALLINT;
@@ -1259,6 +1365,21 @@ type   TSQLSpecialColumns=function (StatementHandle:SQLHSTMT;
            NameLength3:SQLSMALLINT;Scope:SQLUSMALLINT;
            Nullable:SQLUSMALLINT) : SQLRETURN; {$ifdef fpc} extdecl {$else} stdcall {$endif};
 
+type   TSQLForeignKeysA=function(StatementHandle: SQLHSTMT;
+           PKCatalogName: PSQLCHAR; NameLength1: SQLSMALLINT;
+           PKSchemaName: PSQLCHAR; NameLength2: SQLSMALLINT;
+           PKTableName: PSQLCHAR; NameLength3: SQLSMALLINT;
+           FKCatalogName: PSQLCHAR; NameLength4: SQLSMALLINT;
+           FKSchemaName: PSQLCHAR; NameLength5: SQLSMALLINT;
+           FKTableName: PSQLCHAR; NameLength6: SQLSMALLINT) : SQLRETURN; {$ifdef fpc} extdecl {$else} stdcall {$endif};
+       TSQLForeignKeysW=function(StatementHandle: SQLHSTMT;
+           PKCatalogName: PSQLWCHAR; NameLength1: SQLSMALLINT;
+           PKSchemaName: PSQLWCHAR; NameLength2: SQLSMALLINT;
+           PKTableName: PSQLWCHAR; NameLength3: SQLSMALLINT;
+           FKCatalogName: PSQLWCHAR; NameLength4: SQLSMALLINT;
+           FKSchemaName: PSQLWCHAR; NameLength5: SQLSMALLINT;
+           FKTableName: PSQLWCHAR; NameLength6: SQLSMALLINT) : SQLRETURN; {$ifdef fpc} extdecl {$else} stdcall {$endif};
+
 type   TSQLProcedures=function ( hstmt : SQLHSTMT;
            szTableQualifier : PSQLCHAR;cbTableQualifier : SQLSMALLINT;
            szTableOwner : PSQLCHAR;cbTableOwner : SQLSMALLINT;
@@ -1304,6 +1425,7 @@ type   TSQLStatistics = function (hstmt: SQLHSTMT;
 var    SQLAllocHandle:tSQLAllocHandle;
 var    SQLSetEnvAttr:tSQLSetEnvAttr;
 var    SQLFreeHandle:tSQLFreeHandle;
+var    SQLGetFunctions:TSQLGetFunctions;
 var    SQLGetInfo:tSQLGetInfo;
 var    SQLGetDiagRecA:TSQLGetDiagRec;
        SQLGetDiagRecW:TSQLGetDiagRecW;
@@ -1315,6 +1437,7 @@ var    SQLDriverConnectA:TSQLDriverConnect;
        SQLDriverConnectW:TSQLDriverConnectW;
 var    SQLExecDirectA:TSQLExecDirect;
        SQLExecDirectW:TSQLExecDirectW;
+var    SQLParamData:TSQLParamData;
 var    SQLPrepareA:TSQLPrepare;
        SQLPrepareW:TSQLPrepareW;
 var    SQLCloseCursor:TSQLCloseCursor;
@@ -1328,7 +1451,7 @@ var    SQLExtendedFetch:TSQLExtendedFetch;
 var    SQLGetData:TSQLGetData;
 var    SQLSetStmtAttr:TSQLSetStmtAttr;
 var    SQLGetStmtAttr:TSQLGetStmtAttr;
-//var    SQLSetDescField:TSQLSetDescField;
+var    SQLSetDescField:TSQLSetDescField;
 var    SQLSetDescRec:TSQLSetDescRec;
 var    SQLBulkOperations:TSQLBulkOperations;
 var    SQLPutData:TSQLPutData;
@@ -1336,11 +1459,13 @@ var    SQLBindCol:TSQLBindCol;
 var    SQLSetPos:TSQLSetPos;
 var    SQLDataSources:TSQLDataSources;
 var    SQLDrivers:TSQLDrivers;
+var    SQLGetConnectAttr:TSQLGetConnectAttr;
 var    SQLSetConnectAttr:TSQLSetConnectAttr;
 var    SQLGetCursorName:TSQLGetCursorName;
 var    SQLSetCursorName:TSQLSetCursorName;
 var    SQLRowCount:TSQLRowCount;
 var    SQLBindParameter:TSQLBindParameter;
+var    SQLDescribeParam:TSQLDescribeParam;
 var    SQLFreeStmt:TSQLFreeStmt;
 var    SQLColAttribute:TSQLColAttribute;
 var    SQLEndTran:TSQLEndTran;
@@ -1349,6 +1474,8 @@ var    SQLTablesA:TSQLTables;
 var    SQLColumnsA:TSQLColumns;
        SQLColumnsW:TSQLColumnsW;
 var    SQLSpecialColumns:TSQLSpecialColumns;
+var    SQLForeignKeysA:TSQLForeignKeysA;
+       SQLForeignKeysW:TSQLForeignKeysW;
 var    SQLPrimaryKeysA:TSQLPrimaryKeys;
        SQLPrimaryKeysW:TSQLPrimaryKeysW;
 var    SQLProceduresA:TSQLProcedures;
@@ -1461,6 +1588,9 @@ var
                StatementHandle:SQLHSTMT;
                StatementText:  PSQLWCHAR;
                TextLength:     SQLINTEGER):SQLRETURN;{$ifdef fpc} extdecl {$else} stdcall {$endif};external odbclib;
+   function SQLParamData(
+               StatementHandle:SQLHSTMT;
+               ValuePtrPtr: PSQLPOINTER):SQLRETURN;{$ifdef fpc} extdecl {$else} stdcall {$endif};external odbclib;
    function SQLPrepare(
                StatementHandle:SQLHSTMT;
                StatementText:PSQLCHAR;
@@ -1531,6 +1661,10 @@ var
                RecNumber:SQLSMALLINT; DescType, SubType:SQLSMALLINT;
                Length:SQLLEN; Precision, Scale: SQLSMALLINT;
                DataPtr:SQLPOINTER; StringLengthPtr,IndicatorPtr:PSQLLEN):SQLRETURN;{$ifdef fpc} extdecl {$else} stdcall {$endif};external odbclib;
+   function SQLGetFunctions(
+               ConnectionHandle: SQLHDBC;
+               FunctionId: SQLUSMALLINT;
+               Supported: PSQLUSMALLINT):SQLRETURN;{$ifdef fpc} extdecl {$else} stdcall {$endif};external odbclib;
    function SQLGetInfo(
                ConnectionHandle:SQLHDBC;
                InfoType:SQLUSMALLINT;
@@ -1574,6 +1708,9 @@ var
                DriverAttributes:PSQLCHAR;
                BufferLength2:SQLSMALLINT;
                AttributesLength2:PSQLSMALLINT):SQLRETURN;{$ifdef fpc} extdecl {$else} stdcall {$endif};external odbclib;
+   function SQLGetConnectAttr(ConnectionHandle: SQLHDBC;
+               Attribute: SQLINTEGER; Value: SQLPOINTER;
+               BufferLength: SQLINTEGER; StringLengthPtr: PSQLINTEGER):SQLRETURN;{$ifdef fpc} extdecl {$else} stdcall {$endif};external odbclib;
    function SQLSetConnectAttr(
                ConnectionHandle:SQLHDBC;
                Attribute:SQLINTEGER; Value:SQLPOINTER;
@@ -1600,6 +1737,13 @@ var
                rgbValue:SQLPOINTER;
                cbValueMax:SQLLEN;
                pcbValue:PSQLLEN):SQLRETURN;{$ifdef fpc} extdecl {$else} stdcall {$endif};external odbclib;
+   function SQLDescribeParam(
+               StatementHandle: SQLHSTMT;
+               ParameterNumber: SQLUSMALLINT;
+               DataTypePtr: PSQLSMALLINT;
+               ParameterSizePtr: PSQLULEN;
+               DecimalDigitsPtr: PSQLSMALLINT;
+               NullablePtr: PSQLSMALLINT): SQLRETURN;{$ifdef fpc} extdecl {$else} stdcall {$endif};external odbclib;
    function SQLFreeStmt(
                StatementHandle:SQLHSTMT;
                Option:SQLUSMALLINT):SQLRETURN;{$ifdef fpc} extdecl {$else} stdcall {$endif};external odbclib;
@@ -1663,6 +1807,20 @@ var
                 NameLength3:SQLSMALLINT;
                 Scope:SQLUSMALLINT;
                 Nullable:SQLUSMALLINT) : SQLRETURN; {$ifdef fpc} extdecl {$else} stdcall {$endif}; external odbclib;
+   function SQLForeignKeys(StatementHandle: SQLHSTMT;
+                PKCatalogName: PSQLCHAR; NameLength1: SQLSMALLINT;
+                PKSchemaName: PSQLCHAR; NameLength2: SQLSMALLINT;
+                PKTableName: PSQLCHAR; NameLength3: SQLSMALLINT;
+                FKCatalogName: PSQLCHAR; NameLength4: SQLSMALLINT;
+                FKSchemaName: PSQLCHAR; NameLength5: SQLSMALLINT;
+                FKTableName: PSQLCHAR; NameLength6: SQLSMALLINT) : SQLRETURN; {$ifdef fpc} extdecl {$else} stdcall {$endif}; external odbclib;
+   function SQLForeignKeysW(StatementHandle: SQLHSTMT;
+                PKCatalogName: PSQLWCHAR; NameLength1: SQLSMALLINT;
+                PKSchemaName: PSQLWCHAR; NameLength2: SQLSMALLINT;
+                PKTableName: PSQLWCHAR; NameLength3: SQLSMALLINT;
+                FKCatalogName: PSQLWCHAR; NameLength4: SQLSMALLINT;
+                FKSchemaName: PSQLWCHAR; NameLength5: SQLSMALLINT;
+                FKTableName: PSQLWCHAR; NameLength6: SQLSMALLINT) : SQLRETURN; {$ifdef fpc} extdecl {$else} stdcall {$endif}; external odbclib;
    function SQLProcedures( hstmt : SQLHSTMT;
                 szTableQualifier : PSQLCHAR;
                 cbTableQualifier : SQLSMALLINT;
@@ -1751,6 +1909,7 @@ begin
     pointer(SQLAllocHandle) := GetProcedureAddress(ODBCLibraryHandle,'SQLAllocHandle');
     pointer(SQLSetEnvAttr) := GetProcedureAddress(ODBCLibraryHandle,'SQLSetEnvAttr');
     pointer(SQLFreeHandle) := GetProcedureAddress(ODBCLibraryHandle,'SQLFreeHandle');
+    pointer(SQLGetFunctions) := GetProcedureAddress(ODBCLibraryHandle,'SQLGetFunctions');
     pointer(SQLGetInfo) := GetProcedureAddress(ODBCLibraryHandle,'SQLGetInfo');
     pointer(SQLSpecialColumns) := GetProcedureAddress(ODBCLibraryHandle,'SQLSpecialColumns');
     pointer(SQLGetDiagField) := GetProcedureAddress(ODBCLibraryHandle,'SQLGetDiagField');
@@ -1764,7 +1923,7 @@ begin
     pointer(SQLGetData) := GetProcedureAddress(ODBCLibraryHandle,'SQLGetData');
     pointer(SQLSetStmtAttr) := GetProcedureAddress(ODBCLibraryHandle,'SQLSetStmtAttr');
     pointer(SQLGetStmtAttr) := GetProcedureAddress(ODBCLibraryHandle,'SQLGetStmtAttr');
-    //pointer(SQLSetDescField) := GetProcedureAddress(ODBCLibraryHandle,'SQLSetDescField');
+    pointer(SQLSetDescField) := GetProcedureAddress(ODBCLibraryHandle,'SQLSetDescField');
     pointer(SQLSetDescRec) := GetProcedureAddress(ODBCLibraryHandle,'SQLSetDescRec');
     pointer(SQLBulkOperations) := GetProcedureAddress(ODBCLibraryHandle,'SQLBulkOperations');
     pointer(SQLPutData) := GetProcedureAddress(ODBCLibraryHandle,'SQLPutData');
@@ -1772,11 +1931,14 @@ begin
     pointer(SQLSetPos) := GetProcedureAddress(ODBCLibraryHandle,'SQLSetPos');
     pointer(SQLDataSources) := GetProcedureAddress(ODBCLibraryHandle,'SQLDataSources');
     pointer(SQLDrivers) := GetProcedureAddress(ODBCLibraryHandle,'SQLDrivers');
+    pointer(SQLGetConnectAttr) := GetProcedureAddress(ODBCLibraryHandle,'SQLGetConnectAttr');
     pointer(SQLSetConnectAttr) := GetProcedureAddress(ODBCLibraryHandle,'SQLSetConnectAttr');
     pointer(SQLGetCursorName) := GetProcedureAddress(ODBCLibraryHandle,'SQLGetCursorName');
     pointer(SQLSetCursorName) := GetProcedureAddress(ODBCLibraryHandle,'SQLSetCursorName');
     pointer(SQLRowCount) := GetProcedureAddress(ODBCLibraryHandle,'SQLRowCount');
     pointer(SQLBindParameter) := GetProcedureAddress(ODBCLibraryHandle,'SQLBindParameter');
+    pointer(SQLDescribeParam) :=GetProcedureAddress(ODBCLibraryHandle,'SQLDescribeParam');
+    pointer(SQLParamData) :=GetProcedureAddress(ODBCLibraryHandle,'SQLParamData');
     pointer(SQLFreeStmt) := GetProcedureAddress(ODBCLibraryHandle,'SQLFreeStmt');
     pointer(SQLColAttribute) := GetProcedureAddress(ODBCLibraryHandle,'SQLColAttribute');
     pointer(SQLEndTran) := GetProcedureAddress(ODBCLibraryHandle,'SQLEndTran');
@@ -1789,6 +1951,7 @@ begin
     pointer(SQLDescribeColA) := GetProcedureAddress(ODBCLibraryHandle,'SQLDescribeCol');
     pointer(SQLTablesA) := GetProcedureAddress(ODBCLibraryHandle,'SQLTables');
     pointer(SQLColumnsA) := GetProcedureAddress(ODBCLibraryHandle,'SQLColumns');
+    pointer(SQLForeignKeysA) := GetProcedureAddress(ODBCLibraryHandle,'SQLForeignKeys');
     pointer(SQLPrimaryKeysA) := GetProcedureAddress(ODBCLibraryHandle,'SQLPrimaryKeys');
     pointer(SQLProceduresA) := GetProcedureAddress(ODBCLibraryHandle,'SQLProcedures');
     pointer(SQLProcedureColumnsA) := GetProcedureAddress(ODBCLibraryHandle,'SQLProcedureColumns');
@@ -1816,6 +1979,7 @@ begin
     pointer(SQLDescribeColW) := GetProcedureAddress(ODBCLibraryHandle,'SQLDescribeColW');
     pointer(SQLTablesW) := GetProcedureAddress(ODBCLibraryHandle,'SQLTablesW');
     pointer(SQLColumnsW) := GetProcedureAddress(ODBCLibraryHandle,'SQLColumnsW');
+    pointer(SQLForeignKeysW) := GetProcedureAddress(ODBCLibraryHandle,'SQLForeignKeysW');
     pointer(SQLPrimaryKeysW) := GetProcedureAddress(ODBCLibraryHandle,'SQLPrimaryKeysW');
     pointer(SQLProceduresW) := GetProcedureAddress(ODBCLibraryHandle,'SQLProceduresW');
     pointer(SQLProcedureColumnsW) := GetProcedureAddress(ODBCLibraryHandle,'SQLProcedureColumnsW');
@@ -1824,6 +1988,7 @@ begin
     SQLAllocHandle := GetProcedureAddress(ODBCLibraryHandle,'SQLAllocHandle');
     SQLSetEnvAttr := GetProcedureAddress(ODBCLibraryHandle,'SQLSetEnvAttr');
     SQLFreeHandle := GetProcedureAddress(ODBCLibraryHandle,'SQLFreeHandle');
+    SQLGetFunctions := GetProcedureAddress(ODBCLibraryHandle,'SQLGetFunctions');
     SQLGetInfo := GetProcedureAddress(ODBCLibraryHandle,'SQLGetInfo');
     SQLProcedures := GetProcedureAddress(ODBCLibraryHandle,'SQLProcedures');
     SQLColumns := GetProcedureAddress(ODBCLibraryHandle,'SQLColumns');
@@ -1834,6 +1999,7 @@ begin
     SQLDisconnect := GetProcedureAddress(ODBCLibraryHandle,'SQLDisconnect');
     SQLDriverConnect := GetProcedureAddress(ODBCLibraryHandle,'SQLDriverConnect');
     SQLExecDirect := GetProcedureAddress(ODBCLibraryHandle,'SQLExecDirect');
+    SQLParamData := GetProcedureAddress(ODBCLibraryHandle,'SQLParamData');
     SQLPrepare := GetProcedureAddress(ODBCLibraryHandle,'SQLPrepare');
     SQLCloseCursor := GetProcedureAddress(ODBCLibraryHandle,'SQLCloseCursor');
     SQLExecute := GetProcedureAddress(ODBCLibraryHandle,'SQLExecute');
@@ -1845,7 +2011,7 @@ begin
     SQLGetData := GetProcedureAddress(ODBCLibraryHandle,'SQLGetData');
     SQLSetStmtAttr := GetProcedureAddress(ODBCLibraryHandle,'SQLSetStmtAttr');
     SQLGetStmtAttr := GetProcedureAddress(ODBCLibraryHandle,'SQLGetStmtAttr');
-    //SQLSetDescField := GetProcedureAddress(ODBCLibraryHandle,'SQLSetDescField');
+    SQLSetDescField := GetProcedureAddress(ODBCLibraryHandle,'SQLSetDescField');
     SQLSetDescRec := GetProcedureAddress(ODBCLibraryHandle,'SQLSetDescRec');
     SQLBulkOperations := GetProcedureAddress(ODBCLibraryHandle,'SQLBulkOperations');
     SQLPutData := GetProcedureAddress(ODBCLibraryHandle,'SQLPutData');
@@ -1853,6 +2019,7 @@ begin
     SQLSetPos := GetProcedureAddress(ODBCLibraryHandle,'SQLSetPos');
     SQLDataSources := GetProcedureAddress(ODBCLibraryHandle,'SQLDataSources');
     SQLDrivers := GetProcedureAddress(ODBCLibraryHandle,'SQLDrivers');
+    SQLGetConnectAttr := GetProcedureAddress(ODBCLibraryHandle,'SQLGetConnectAttr');
     SQLSetConnectAttr := GetProcedureAddress(ODBCLibraryHandle,'SQLSetConnectAttr');
     SQLGetCursorName := GetProcedureAddress(ODBCLibraryHandle,'SQLGetCursorName');
     SQLSetCursorName := GetProcedureAddress(ODBCLibraryHandle,'SQLSetCursorName');

packages/pastojs/src/fppas2js.pp

@@ -18465,7 +18465,7 @@ begin
   aResolver:=AContext.Resolver;
 
   Proc:=TPasProcedure(ResolvedEl.IdentEl);
-  if not (Proc.Parent is TPasMembersType)
+  if (not (Proc.Parent is TPasMembersType))
       or (ptmStatic in Proc.ProcType.Modifiers) then
     begin
     // not an "of object" method -> simply use the function

packages/pastojs/src/pas2jsfiler.pp

@@ -1028,10 +1028,11 @@ type
   protected
     // specialize
     FPendingSpecialize: TPCUReaderPendingSpecialized; // chain of TPCUReaderPendingSpecialized
+    function FindPendingSpecialize(Id: integer): TPCUReaderPendingSpecialized;
     function AddPendingSpecialize(Id: integer; const SpecName: string): TPCUReaderPendingSpecialized;
-    function CreateSpecializedElement(PendSpec: TPCUReaderPendingSpecialized): boolean; // false=param missing
+    function CreateSpecializedElement(PendSpec: TPCUReaderPendingSpecialized): boolean; // false=param missing, Note: needs ResolvePendingIdentifierScopes
     procedure DeletePendingSpecialize(PendSpec: TPCUReaderPendingSpecialized);
-    procedure PromiseSpecialize(SpecId: integer; El: TPasElement; const SpecName: string); virtual;
+    function PromiseSpecialize(SpecId: integer; const SpecName: string; RefEl, ErrorEl: TPasElement): TPCUReaderPendingSpecialized; virtual;
     procedure ResolveSpecializedElements(Complete: boolean);
   protected
     // json
@@ -5418,9 +5419,20 @@ begin
     RaiseMsg(20200514130809,SpecData.Element,GetObjPath(RefEl));
 end;
 
+function TPCUReader.FindPendingSpecialize(Id: integer
+  ): TPCUReaderPendingSpecialized;
+begin
+  Result:=FPendingSpecialize;
+  while (Result<>nil) and (Result.Id<>Id) do
+    Result:=Result.Next;
+end;
+
 function TPCUReader.AddPendingSpecialize(Id: integer; const SpecName: string
   ): TPCUReaderPendingSpecialized;
 begin
+  if FindPendingSpecialize(Id)<>nil then
+    RaiseMsg(20201022214051,SpecName+'='+IntToStr(Id));
+
   Result:=TPCUReaderPendingSpecialized.Create;
   if FPendingSpecialize<>nil then
     begin
@@ -5444,21 +5456,26 @@ var
   GenericEl: TPasGenericType;
 begin
   Result:=false;
+  {$IFDEF VerbosePCUFiler}
+  writeln('TPCUReader.CreateSpecializedElement Gen=',GetObjPath(PendSpec.GenericEl));
+  {$ENDIF}
   if PendSpec.RefEl=nil then
     begin
     if PendSpec.GenericEl=nil then
       RaiseMsg(20200531101241,PendSpec.SpecName)
     else
-      RaiseMsg(20200531101105,PendSpec.GenericEl);// nothing uses this specialize
+      RaiseMsg(20200531101105,PendSpec.GenericEl,PendSpec.SpecName);// nothing uses this specialize
     end;
   if PendSpec.GenericEl=nil then
-    RaiseMsg(20200531101333,PendSpec.RefEl);
+    RaiseMsg(20200531101333,PendSpec.RefEl,PendSpec.SpecName);
   Obj:=PendSpec.Obj;
   if Obj=nil then
-    RaiseMsg(20200531101128,PendSpec.GenericEl); // specialize missing in JSON
+    RaiseMsg(20200531101128,PendSpec.GenericEl,PendSpec.SpecName); // specialize missing in JSON
 
   // resolve params
   RefParams:=PendSpec.Params;
+  if RefParams=nil then
+    RaiseMsg(20201022215141,PendSpec.GenericEl,PendSpec.SpecName);
   for i:=0 to RefParams.Count-1 do
     begin
     Param:=TPCUReaderPendingSpecializedParam(RefParams[i]);
@@ -5501,25 +5518,18 @@ begin
   PendSpec.Free;
 end;
 
-procedure TPCUReader.PromiseSpecialize(SpecId: integer; El: TPasElement;
-  const SpecName: string);
-var
-  PendSpec: TPCUReaderPendingSpecialized;
+function TPCUReader.PromiseSpecialize(SpecId: integer; const SpecName: string;
+  RefEl, ErrorEl: TPasElement): TPCUReaderPendingSpecialized;
 begin
-  PendSpec:=FPendingSpecialize;
-  while PendSpec<>nil do
-    begin
-    if PendSpec.Id=SpecId then
-      break;
-    PendSpec:=PendSpec.Next;
-    end;
+  Result:=FindPendingSpecialize(SpecId);
+  if Result=nil then
+    Result:=AddPendingSpecialize(SpecId,SpecName)
+  else if Result.SpecName<>SpecName then
+    RaiseMsg(20200531093342,ErrorEl,'Id='+IntToStr(SpecId)+' Expected SpecName "'+SpecName+'", but was "'+Result.SpecName+'"');
 
-  if PendSpec=nil then
-    PendSpec:=AddPendingSpecialize(SpecId,SpecName)
-  else if PendSpec.SpecName<>SpecName then
-    RaiseMsg(20200531093342,El,'Id='+IntToStr(SpecId)+' Expected SpecName "'+SpecName+'", but was "'+PendSpec.SpecName+'"');
-  if PendSpec.RefEl=nil then
-    PendSpec.RefEl:=El;
+  if Result.RefEl=nil then
+    Result.RefEl:=RefEl;
+  // Note: cannot specialize before ResolvePendingIdentifierScopes;
 end;
 
 procedure TPCUReader.ResolveSpecializedElements(Complete: boolean);
@@ -5541,7 +5551,7 @@ begin
         if Ref<>nil then
           PendSpec.RefEl:=GetReferrerEl(Ref.Pending);
         end;
-      if PendSpec.RefEl<>nil then
+      if (PendSpec.RefEl<>nil) and (PendSpec.GenericEl<>nil) then
         begin
         if CreateSpecializedElement(PendSpec) then
           Changed:=true
@@ -5554,8 +5564,20 @@ begin
   if Complete then
     UnresolvedSpec:=FPendingSpecialize;
   if UnresolvedSpec<>nil then
+    begin
+    {$IF defined(VerbosePJUFiler) or defined(VerbosePas2JS)}
+    PendSpec:=FPendingSpecialize;
+    while PendSpec<>nil do
+      begin
+      {AllowWriteln}
+      writeln('TPCUReader.ResolveSpecializedElements PENDING: ',PendSpec.SpecName+' Id='+IntToStr(PendSpec.Id)+' RefEl='+GetObjPath(PendSpec.RefEl)+' GenericEl='+GetObjPath(PendSpec.GenericEl));;
+      {AllowWriteln-}
+      PendSpec:=PendSpec.Next;
+      end;
+    {$ENDIF}
     // a pending specialize cannot resolve its params
-    RaiseMsg(20200531101924,UnresolvedSpec.GenericEl,UnresolvedSpec.SpecName+' Id='+IntToStr(UnresolvedSpec.Id)+' RefEl='+GetObjPath(UnresolvedSpec.RefEl));
+    RaiseMsg(20200531101924,UnresolvedSpec.GenericEl,UnresolvedSpec.SpecName+' Id='+IntToStr(UnresolvedSpec.Id)+' RefEl='+GetObjPath(UnresolvedSpec.RefEl)+' GenericEl='+GetObjPath(UnresolvedSpec.GenericEl));
+    end;
 end;
 
 procedure TPCUReader.RaiseMsg(Id: int64; const Msg: string);
@@ -5738,15 +5760,15 @@ end;
 function TPCUReader.AddElReference(Id: integer; ErrorEl: TPasElement;
   El: TPasElement): TPCUFilerElementRef;
 var
+  {$IF defined(VerbosePCUFiler) or defined(memcheck)}
+  Node: TAVLTreeNode;
+  {$ENDIF}
   Ref: TPCUFilerElementRef;
   RefItem: TPCUFilerPendingElRef;
   PendingElRef: TPCUReaderPendingElRef;
   PendingElListRef: TPCUReaderPendingElListRef;
   PendingElArrRef: TPCUReaderPendingElArrRef;
-  {$IF defined(VerbosePCUFiler) or defined(memcheck)}
-  Node: TAVLTreeNode;
   PendingElScopeRef: TPCUReaderPendingElScopeRef;
-  {$ENDIF}
 begin
   if Id<=0 then
     RaiseMsg(20180207151233,ErrorEl);
@@ -6575,7 +6597,7 @@ begin
   if not ReadString(Obj,'SpecName',SpecName,GenEl) then
     RaiseMsg(20200531085133,GenEl);
 
-  PendSpec:=AddPendingSpecialize(Id,SpecName);
+  PendSpec:=PromiseSpecialize(Id,SpecName,nil,GenEl);
   PendSpec.Obj:=Obj;
   PendSpec.GenericEl:=GenEl;
 
@@ -6596,6 +6618,11 @@ begin
     PendParam.Index:=i;
     PendParam.Id:=Id;
     end;
+
+  {$IFDEF VerbosePCUFiler}
+  writeln('TPCUReader.ReadSpecialization Id=',PendSpec.Id,' GenEl=',GetObjPath(PendSpec.GenericEl),' SpecName=',PendSpec.SpecName,' ElRef=',GetObjPath(PendSpec.RefEl));
+  {$ENDIF}
+  // Note: cannot specialize before ResolvePendingIdentifierScopes;
 end;
 
 procedure TPCUReader.ReadExternalReferences(Obj: TJSONObject; El: TPasElement);
@@ -8121,7 +8148,7 @@ procedure TPCUReader.ReadSpecializeType(Obj: TJSONObject;
 var
   GenType: TPasGenericType;
   GenericTemplateTypes: TFPList;
-  ExpName: string;
+  SpecName: string;
   i, SpecId: Integer;
   Data: TPasSpecializeTypeData;
 begin
@@ -8153,12 +8180,12 @@ begin
   PromiseSetElReference(SpecId,@Set_SpecializeTypeData,Data,El);
 
   // check old specialized name
-  if not ReadString(Obj,'SpecName',ExpName,El) then
+  if not ReadString(Obj,'SpecName',SpecName,El) then
     RaiseMsg(20200219122919,El);
-  if ExpName='' then
+  if SpecName='' then
     RaiseMsg(20200530134152,El);
 
-  PromiseSpecialize(SpecId,El,ExpName);
+  PromiseSpecialize(SpecId,SpecName,El,El);
 end;
 
 procedure TPCUReader.ReadInlineSpecializeExpr(Obj: TJSONObject;

packages/pastojs/tests/tcfiler.pas

@@ -84,6 +84,8 @@ type
     procedure CheckRestoredRecordScope(const Path: string; Orig, Rest: TPas2jsRecordScope; Flags: TPCCheckFlags); virtual;
     procedure CheckRestoredClassScope(const Path: string; Orig, Rest: TPas2JSClassScope; Flags: TPCCheckFlags); virtual;
     procedure CheckRestoredProcScope(const Path: string; Orig, Rest: TPas2JSProcedureScope; Flags: TPCCheckFlags); virtual;
+    procedure CheckRestoredProcTypeScope(const Path: string; Orig, Rest: TPas2JSProcTypeScope; Flags: TPCCheckFlags); virtual;
+    procedure CheckRestoredArrayScope(const Path: string; Orig, Rest: TPas2JSArrayScope; Flags: TPCCheckFlags); virtual;
     procedure CheckRestoredPrecompiledJS(const Path: string; OrigEl: TPasElement; Orig: TPas2JSPrecompiledJS; RestEl: TPasElement; Rest: TPas2JSPrecompiledJS; Flags: TPCCheckFlags); virtual;
     procedure CheckRestoredScopeRefs(const Path: string; Orig, Rest: TPasScopeReferences; Flags: TPCCheckFlags); virtual;
     procedure CheckRestoredPropertyScope(const Path: string; Orig, Rest: TPasPropertyScope; Flags: TPCCheckFlags); virtual;
@@ -218,13 +220,11 @@ type
     procedure TestPC_GenericFunction_AnonymousProc;
     procedure TestPC_GenericClass;
     procedure TestPC_GenericMethod;
+    // ToDo: GenericMethod Calls, ProcTypes
     procedure TestPC_SpecializeClassSameUnit;
     procedure TestPC_Specialize_LocalTypeInUnit;
-    // ToDo: specialize local generic type via class forward
-    // ToDo: inline specialize local generic type in unit interface
-    // ToDo: inline specialize local generic type in unit implementation
-    // ToDo: inline specialize local generic type in proc decl
-    // ToDo: inline specialize local generic type in proc body
+    procedure TestPC_Specialize_ClassForward;
+    procedure TestPC_InlineSpecialize_LocalTypeInUnit;
     // ToDo: specialize extern generic type in unit interface
     // ToDo: specialize extern generic type in unit implementation
     // ToDo: specialize extern generic type in proc decl
@@ -253,7 +253,7 @@ var
   Ref1: TPasScopeReference absolute Item1;
   Ref2: TPasScopeReference absolute Item2;
 begin
-  Result:=CompareText(Ref1.Element.Name,Ref2.Element.Name);
+  Result:=CompareText(GetObjPath(Ref1.Element),GetObjPath(Ref2.Element));
   if Result<>0 then exit;
   Result:=ComparePointer(Ref1.Element,Ref2.Element);
 end;
@@ -644,11 +644,31 @@ procedure TCustomTestPrecompile.CheckRestoredDeclarations(const Path: string;
         and (TPasGenericScope(El.CustomData).SpecializedFromItem<>nil);
   end;
 
+  function GetSubPath(const Path: string; OrigIndex: integer; OrigDecl: TPasElement): string;
+  begin
+    Result:=Path+'['+IntToStr(OrigIndex)+']';
+    if OrigDecl.Name<>'' then
+      Result:=Result+'"'+OrigDecl.Name+'"'
+    else
+      Result:=Result+'?noname?';
+  end;
+
+{  procedure WriteList;
+  var
+    i: Integer;
+  begin
+    writeln('CheckRestoredDeclarations.WriteList');
+    for i:=0 to Orig.Declarations.Count-1 do
+      if i<Rest.Declarations.Count then
+        writeln('  ',i,' Orig=',TPasElement(Orig.Declarations[i]).Name,' Rest=',TPasElement(Rest.Declarations[i]).Name);
+  end;}
+
 var
   OrigIndex, RestIndex: Integer;
   OrigDecl, RestDecl: TPasElement;
   SubPath: String;
 begin
+  //WriteList;
   // check non specializations
   RestIndex:=0;
   for OrigIndex:=0 to Orig.Declarations.Count-1 do
@@ -656,12 +676,8 @@ begin
     OrigDecl:=TPasElement(Orig.Declarations[OrigIndex]);
     if IsSpecialization(OrigDecl) then
       continue;
-    SubPath:=Path+'['+IntToStr(OrigIndex)+']';
-    if OrigDecl.Name<>'' then
-      SubPath:=SubPath+'"'+OrigDecl.Name+'"'
-    else
-      SubPath:=SubPath+'?noname?';
-    // skip to next non specializations in restored declarations
+    SubPath:=GetSubPath(Path,OrigIndex,OrigDecl);
+    // skip to next non specialization in restored declarations
     while RestIndex<Rest.Declarations.Count do
       begin
       RestDecl:=TPasElement(Rest.Declarations[RestIndex]);
@@ -682,11 +698,7 @@ begin
     OrigDecl:=TPasElement(Orig.Declarations[OrigIndex]);
     if not IsSpecialization(OrigDecl) then
       continue;
-    SubPath:=Path+'['+IntToStr(OrigIndex)+']';
-    if OrigDecl.Name<>'' then
-      SubPath:=SubPath+'"'+OrigDecl.Name+'"'
-    else
-      SubPath:=SubPath+'?noname?';
+    SubPath:=GetSubPath(Path,OrigIndex,OrigDecl);
     // search specialization with same name
     RestIndex:=0;
     repeat
@@ -699,14 +711,33 @@ begin
     until false;
 
     if (OrigIndex<Rest.Declarations.Count) and (OrigIndex<>RestIndex) then
+      begin
       // move restored element to original place to generate the same JS
-      Rest.Declarations.Move(RestIndex,OrigIndex);
+      //writeln('TCustomTestPrecompile.CheckRestoredDeclarations Orig[',OrigIndex,']=',GetObjName(OrigDecl),' Rest[',RestIndex,']=',GetObjName(RestDecl));
+      if RestIndex>OrigIndex then
+        Rest.Declarations.Move(RestIndex,OrigIndex)
+      else
+        Rest.Declarations.Exchange(RestIndex,OrigIndex);
+      //writeln('TCustomTestPrecompile.CheckRestoredDeclarations RestIndex=',RestIndex,' ->',OrigIndex);
+      //WriteList;
+      end;
 
     // check
     CheckRestoredElement(SubPath,OrigDecl,RestDecl,Flags);
     end;
-
   AssertEquals(Path+'.Declarations.Count',Orig.Declarations.Count,Rest.Declarations.Count);
+
+  //WriteList;
+  for OrigIndex:=0 to Orig.Declarations.Count-1 do
+    begin
+    OrigDecl:=TPasElement(Orig.Declarations[OrigIndex]);
+    RestDecl:=TPasElement(Rest.Declarations[OrigIndex]);
+    if OrigDecl.Name<>RestDecl.Name then
+      begin
+      SubPath:=GetSubPath(Path,OrigIndex,OrigDecl);
+      AssertEquals(SubPath+'.Name',GetObjPath(OrigDecl),GetObjPath(RestDecl));
+      end;
+    end;
 end;
 
 procedure TCustomTestPrecompile.CheckRestoredSection(const Path: string; Orig,
@@ -889,6 +920,8 @@ procedure TCustomTestPrecompile.CheckRestoredRecordScope(const Path: string;
 begin
   CheckRestoredReference(Path+'.DefaultProperty',Orig.DefaultProperty,Rest.DefaultProperty);
   CheckRestoredIdentifierScope(Path,Orig,Rest,Flags);
+  // ok -> use same JSName
+  Rest.JSName:=Orig.JSName;
 end;
 
 procedure TCustomTestPrecompile.CheckRestoredClassScope(const Path: string;
@@ -962,6 +995,9 @@ begin
     end;
 
   CheckRestoredIdentifierScope(Path,Orig,Rest,Flags);
+
+  // ok -> use same JSName
+  Rest.JSName:=Orig.JSName;
 end;
 
 procedure TCustomTestPrecompile.CheckRestoredProcScope(const Path: string;
@@ -998,6 +1034,29 @@ begin
     begin
     // ImplProc
     end;
+
+  // ok -> use same JSName
+  Rest.JSName:=Orig.JSName;
+end;
+
+procedure TCustomTestPrecompile.CheckRestoredProcTypeScope(const Path: string;
+  Orig, Rest: TPas2JSProcTypeScope; Flags: TPCCheckFlags);
+begin
+  if Path='' then ;
+  if Flags=[] then ;
+
+  // ok -> use same JSName
+  Rest.JSName:=Orig.JSName;
+end;
+
+procedure TCustomTestPrecompile.CheckRestoredArrayScope(const Path: string;
+  Orig, Rest: TPas2JSArrayScope; Flags: TPCCheckFlags);
+begin
+  if Path='' then ;
+  if Flags=[] then ;
+
+  // ok -> use same JSName
+  Rest.JSName:=Orig.JSName;
 end;
 
 procedure TCustomTestPrecompile.CheckRestoredPrecompiledJS(const Path: string;
@@ -1224,6 +1283,10 @@ begin
     CheckRestoredClassScope(Path+'[TPas2JSClassScope]',TPas2JSClassScope(Orig),TPas2JSClassScope(Rest),Flags)
   else if C=TPas2JSProcedureScope then
     CheckRestoredProcScope(Path+'[TPas2JSProcedureScope]',TPas2JSProcedureScope(Orig),TPas2JSProcedureScope(Rest),Flags)
+  else if C=TPas2JSArrayScope then
+    CheckRestoredArrayScope(Path+'[TPas2JSArrayScope]',TPas2JSArrayScope(Orig),TPas2JSArrayScope(Rest),Flags)
+  else if C=TPas2JSProcTypeScope then
+    CheckRestoredProcTypeScope(Path+'[TPas2JSProcTypeScope]',TPas2JSProcTypeScope(Orig),TPas2JSProcTypeScope(Rest),Flags)
   else if C=TPasPropertyScope then
     CheckRestoredPropertyScope(Path+'[TPasPropertyScope]',TPasPropertyScope(Orig),TPasPropertyScope(Rest),Flags)
   else if C=TPasGenericParamsScope then
@@ -3241,27 +3304,97 @@ begin
   '  TBird<T> = class',
   '    a: T;',
   '  end;',
-  //'  TDoubleBird = TBIrd<double>;',
-  //'var',
-  //'  db: TDoubleBird;',
+  '  TDoubleBird = TBIrd<double>;',
+  'var',
+  '  db: TDoubleBird;',
   'procedure Fly;',
   'implementation',
   'type',
   '  TWordBird = TBird<word>;',
   'procedure Run;',
-  //'type TShortIntBird = TBird<shortint>;',
+  'type TShortIntBird = TBird<shortint>;',
   'var',
-  //'  shb: TShortIntBird;',
+  '  shb: TShortIntBird;',
   '  wb: TWordBird;',
   'begin',
-  //'  shb.a:=3;',
+  '  shb.a:=3;',
+  '  wb.a:=4;',
+  'end;',
+  'procedure Fly;',
+  'type TByteBird = TBird<byte>;',
+  'var bb: TByteBird;',
+  'begin',
+  '  bb.a:=5;',
+  '  Run;',
+  'end;',
+  'begin',
+  '']);
+  WriteReadUnit;
+end;
+
+procedure TTestPrecompile.TestPC_Specialize_ClassForward;
+begin
+  StartUnit(false);
+  Add([
+  '{$mode delphi}',
+  'interface',
+  'type',
+  '  TObject = class',
+  '  end;',
+  '  TBird<T> = class;',
+  '  TAnt = class',
+  '    b: TBird<word>;',
+  '  end;',
+  '  TBird<T> = class',
+  '    a: TAnt;',
+  '  end;',
+  'procedure Fly;',
+  'implementation',
+  'procedure Fly;',
+  'var b: TBird<Double>;',
+  'begin',
+  '  b.a:=nil;',
+  'end;',
+  'begin',
+  '']);
+  WriteReadUnit;
+end;
+
+procedure TTestPrecompile.TestPC_InlineSpecialize_LocalTypeInUnit;
+begin
+  StartUnit(false);
+  Add([
+  '{$mode delphi}',
+  'interface',
+  'type',
+  '  TObject = class',
+  '    constructor Create;',
+  '  end;',
+  '  TBird<T> = class',
+  '    a: T;',
+  '  end;',
+  'var',
+  '  db: TBIrd<double>;',
+  'procedure Fly;',
+  'implementation',
+  'constructor TObject.Create;',
+  'begin',
+  'end;',
+  'var wb: TBird<word>;',
+  'procedure Run;',
+  'var',
+  '  shb: TBird<shortint>;',
+  '  bb: TBird<boolean>;',
+  'begin',
+  '  shb.a:=3;',
   '  wb.a:=4;',
+  '  bb.a:=true;',
+  '  TBird<string>.Create;',
   'end;',
   'procedure Fly;',
-  //'type TByteBird = TBird<byte>;',
-  //'var bb: TByteBird;',
+  'var lb: TBird<longint>;',
   'begin',
-  //'  bb.a:=5;',
+  '  lb.a:=5;',
   '  Run;',
   'end;',
   'begin',

rtl/inc/iso7185.pp

@@ -44,6 +44,8 @@ unit iso7185;
 
     Procedure Get(Var t: Text);
     Procedure Put(Var t: Text);
+    procedure Get;
+    Procedure Put;
 
     Procedure Get(Var f: TypedFile);
     Procedure Put(Var f: TypedFile);
@@ -204,6 +206,24 @@ unit iso7185;
       end;
 
 
+    procedure Get;[IOCheck];
+      var
+        c : char;
+      Begin
+        Read(input,c);
+      End;
+
+
+    Procedure Put;[IOCheck];
+      type
+        FileFunc = Procedure(var t : TextRec);
+      begin
+        inc(TextRec(Output).BufPos);
+        If TextRec(Output).BufPos>=TextRec(Output).BufSize Then
+          FileFunc(TextRec(Output).InOutFunc)(TextRec(Output));
+      end;
+
+
     procedure Get(var f:TypedFile);[IOCheck];
       Begin
         if not(system.eof(f)) then

tests/webtbs/tw37878.pp

@@ -0,0 +1,8 @@
+{$mode objfpc}
+ var i64: int64; w: word;
+begin
+{$Q+}
+w := 4096;
+i64 := 8191;
+i64 := i64 - 2*int64(w);
+end.

tests/webtbs/tw37949.pp

@@ -0,0 +1,6 @@
+{$MODE ISO}
+program p(input, output);
+begin
+  get;
+  put
+end.