瀏覽代碼

* synchronised with trunk till r40635

git-svn-id: branches/debug_eh@40636 -
Jonas Maebe 6 年之前
父節點
當前提交
882d676bc9

+ 5 - 0
.gitattributes

@@ -2099,8 +2099,10 @@ packages/fcl-db/examples/loadlibdemo.lpi svneol=native#text/plain
 packages/fcl-db/examples/loadlibdemo.pp svneol=native#text/plain
 packages/fcl-db/examples/loadlibdemo.pp svneol=native#text/plain
 packages/fcl-db/examples/logsqldemo.lpi svneol=native#text/plain
 packages/fcl-db/examples/logsqldemo.lpi svneol=native#text/plain
 packages/fcl-db/examples/logsqldemo.pas svneol=native#text/plain
 packages/fcl-db/examples/logsqldemo.pas svneol=native#text/plain
+packages/fcl-db/examples/myext.pp svneol=native#text/plain
 packages/fcl-db/examples/pqeventstest.pp svneol=native#text/plain
 packages/fcl-db/examples/pqeventstest.pp svneol=native#text/plain
 packages/fcl-db/examples/showcsv.pp svneol=native#text/plain
 packages/fcl-db/examples/showcsv.pp svneol=native#text/plain
+packages/fcl-db/examples/sqlite3extdemo.pp svneol=native#text/plain
 packages/fcl-db/examples/sqlite3loadlib.lpr svneol=native#text/plain
 packages/fcl-db/examples/sqlite3loadlib.lpr svneol=native#text/plain
 packages/fcl-db/examples/sqlparser.pp svneol=native#text/plain
 packages/fcl-db/examples/sqlparser.pp svneol=native#text/plain
 packages/fcl-db/examples/tsamytable.pp svneol=native#text/plain
 packages/fcl-db/examples/tsamytable.pp svneol=native#text/plain
@@ -7662,12 +7664,15 @@ packages/sndfile/src/sndfile.pp svneol=native#text/plain
 packages/sqlite/Makefile svneol=native#text/plain
 packages/sqlite/Makefile svneol=native#text/plain
 packages/sqlite/Makefile.fpc svneol=native#text/plain
 packages/sqlite/Makefile.fpc svneol=native#text/plain
 packages/sqlite/Makefile.fpc.fpcmake svneol=native#text/plain
 packages/sqlite/Makefile.fpc.fpcmake svneol=native#text/plain
+packages/sqlite/examples/myext.lpi svneol=native#text/plain
+packages/sqlite/examples/myext.pp svneol=native#text/plain
 packages/sqlite/fpmake.pp svneol=native#text/plain
 packages/sqlite/fpmake.pp svneol=native#text/plain
 packages/sqlite/src/sqlite.pp svneol=native#text/plain
 packages/sqlite/src/sqlite.pp svneol=native#text/plain
 packages/sqlite/src/sqlite3.inc svneol=native#text/plain
 packages/sqlite/src/sqlite3.inc svneol=native#text/plain
 packages/sqlite/src/sqlite3.pp svneol=native#text/plain
 packages/sqlite/src/sqlite3.pp svneol=native#text/plain
 packages/sqlite/src/sqlite3db.pas svneol=native#text/x-pascal
 packages/sqlite/src/sqlite3db.pas svneol=native#text/x-pascal
 packages/sqlite/src/sqlite3dyn.pp svneol=native#text/plain
 packages/sqlite/src/sqlite3dyn.pp svneol=native#text/plain
+packages/sqlite/src/sqlite3ext.pp svneol=native#text/plain
 packages/sqlite/src/sqlitedb.pas svneol=native#text/plain
 packages/sqlite/src/sqlitedb.pas svneol=native#text/plain
 packages/sqlite/tests/test.pas svneol=native#text/plain
 packages/sqlite/tests/test.pas svneol=native#text/plain
 packages/sqlite/tests/testapiv3x.README svneol=native#text/plain
 packages/sqlite/tests/testapiv3x.README svneol=native#text/plain

+ 2 - 2
compiler/arm/symcpu.pas

@@ -101,7 +101,7 @@ type
     { library symbol for AROS }
     { library symbol for AROS }
     libsym : tsym;
     libsym : tsym;
     libsymderef : tderef;
     libsymderef : tderef;
-    function getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp): tstoreddef; override;
+    function getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp; const paraprefix: string): tstoreddef; override;
     procedure buildderef; override;
     procedure buildderef; override;
     procedure deref; override;
     procedure deref; override;
   end;
   end;
@@ -208,7 +208,7 @@ implementation
     end;
     end;
 
 
 
 
-  function tcpuprocdef.getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp): tstoreddef;
+  function tcpuprocdef.getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp; const paraprefix: string): tstoreddef;
     begin
     begin
       result:=inherited;
       result:=inherited;
       if newtyp=procdef then
       if newtyp=procdef then

+ 1 - 1
compiler/blockutl.pas

@@ -207,7 +207,7 @@ implementation
           exit;
           exit;
         end;
         end;
       { bare copy, so that self etc are not inserted }
       { bare copy, so that self etc are not inserted }
-      result:=tprocdef(orgpd.getcopyas(procdef,pc_bareproc));
+      result:=tprocdef(orgpd.getcopyas(procdef,pc_bareproc,''));
       { will be called accoding to the ABI conventions }
       { will be called accoding to the ABI conventions }
       result.proccalloption:=pocall_cdecl;
       result.proccalloption:=pocall_cdecl;
       { add po_is_block so that a block "self" pointer gets added (of the type
       { add po_is_block so that a block "self" pointer gets added (of the type

+ 2 - 2
compiler/hlcg2ll.pas

@@ -304,7 +304,7 @@ unit hlcg2ll;
 
 
           procedure location_force_reg(list:TAsmList;var l:tlocation;src_size,dst_size:tdef;maybeconst:boolean);override;
           procedure location_force_reg(list:TAsmList;var l:tlocation;src_size,dst_size:tdef;maybeconst:boolean);override;
           procedure location_force_mem(list:TAsmList;var l:tlocation;size:tdef);override;
           procedure location_force_mem(list:TAsmList;var l:tlocation;size:tdef);override;
-          procedure location_force_mmregscalar(list:TAsmList;var l: tlocation;size:tdef;maybeconst:boolean);override;
+          procedure location_force_mmregscalar(list:TAsmList;var l: tlocation;var size:tdef;maybeconst:boolean);override;
 //          procedure location_force_mmreg(list:TAsmList;var l: tlocation;size:tdef;maybeconst:boolean);override;
 //          procedure location_force_mmreg(list:TAsmList;var l: tlocation;size:tdef;maybeconst:boolean);override;
 
 
           procedure maketojumpboollabels(list: TAsmList; p: tnode; truelabel, falselabel: tasmlabel); override;
           procedure maketojumpboollabels(list: TAsmList; p: tnode; truelabel, falselabel: tasmlabel); override;
@@ -1250,7 +1250,7 @@ implementation
       end;
       end;
     end;
     end;
 
 
-  procedure thlcg2ll.location_force_mmregscalar(list: TAsmList; var l: tlocation; size: tdef; maybeconst: boolean);
+  procedure thlcg2ll.location_force_mmregscalar(list: TAsmList; var l: tlocation; var size: tdef; maybeconst: boolean);
     var
     var
       reg : tregister;
       reg : tregister;
       href : treference;
       href : treference;

+ 3 - 2
compiler/hlcgobj.pas

@@ -575,7 +575,7 @@ unit hlcgobj;
           procedure location_force_reg(list:TAsmList;var l:tlocation;src_size,dst_size:tdef;maybeconst:boolean);virtual;
           procedure location_force_reg(list:TAsmList;var l:tlocation;src_size,dst_size:tdef;maybeconst:boolean);virtual;
           procedure location_force_fpureg(list:TAsmList;var l: tlocation;size: tdef;maybeconst:boolean);virtual;
           procedure location_force_fpureg(list:TAsmList;var l: tlocation;size: tdef;maybeconst:boolean);virtual;
           procedure location_force_mem(list:TAsmList;var l:tlocation;size:tdef);virtual;
           procedure location_force_mem(list:TAsmList;var l:tlocation;size:tdef);virtual;
-          procedure location_force_mmregscalar(list:TAsmList;var l: tlocation;size:tdef;maybeconst:boolean);virtual;
+          procedure location_force_mmregscalar(list:TAsmList;var l: tlocation;var size:tdef;maybeconst:boolean);virtual;
 //          procedure location_force_mmreg(list:TAsmList;var l: tlocation;size:tdef;maybeconst:boolean);virtual;abstract;
 //          procedure location_force_mmreg(list:TAsmList;var l: tlocation;size:tdef;maybeconst:boolean);virtual;abstract;
 
 
           { Retrieve the location of the data pointed to in location l, when the location is
           { Retrieve the location of the data pointed to in location l, when the location is
@@ -4100,7 +4100,7 @@ implementation
       end;
       end;
     end;
     end;
 
 
-  procedure thlcgobj.location_force_mmregscalar(list: TAsmList; var l: tlocation; size: tdef; maybeconst: boolean);
+  procedure thlcgobj.location_force_mmregscalar(list: TAsmList; var l: tlocation; var size: tdef; maybeconst: boolean);
     var
     var
       reg : tregister;
       reg : tregister;
       href : treference;
       href : treference;
@@ -4145,6 +4145,7 @@ implementation
           l.size:=def_cgsize(newsize);
           l.size:=def_cgsize(newsize);
           location_freetemp(list,l);
           location_freetemp(list,l);
           location_reset(l,LOC_MMREGISTER,l.size);
           location_reset(l,LOC_MMREGISTER,l.size);
+          size:=newsize;
           l.register:=reg;
           l.register:=reg;
         end;
         end;
     end;
     end;

+ 2 - 2
compiler/i386/symcpu.pas

@@ -97,7 +97,7 @@ type
     { library symbol for AROS }
     { library symbol for AROS }
     libsym : tsym;
     libsym : tsym;
     libsymderef : tderef;
     libsymderef : tderef;
-    function getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp): tstoreddef; override;
+    function getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp; const paraprefix: string): tstoreddef; override;
     procedure buildderef; override;
     procedure buildderef; override;
     procedure deref; override;
     procedure deref; override;
   end;
   end;
@@ -203,7 +203,7 @@ implementation
     end;
     end;
 
 
 
 
-  function tcpuprocdef.getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp): tstoreddef;
+  function tcpuprocdef.getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp; const paraprefix: string): tstoreddef;
     begin
     begin
       result:=inherited;
       result:=inherited;
       if newtyp=procdef then
       if newtyp=procdef then

+ 4 - 4
compiler/i8086/symcpu.pas

@@ -110,7 +110,7 @@ type
 
 
   tcpuprocvardef = class(ti86procvardef)
   tcpuprocvardef = class(ti86procvardef)
     constructor create(level:byte);override;
     constructor create(level:byte);override;
-    function getcopyas(newtyp:tdeftyp;copytyp:tproccopytyp):tstoreddef;override;
+    function getcopyas(newtyp:tdeftyp;copytyp:tproccopytyp;const paraprefix:string):tstoreddef;override;
     function address_type:tdef;override;
     function address_type:tdef;override;
     function ofs_address_type:tdef;override;
     function ofs_address_type:tdef;override;
     function size:asizeint;override;
     function size:asizeint;override;
@@ -133,7 +133,7 @@ type
     procedure Setinterfacedef(AValue: boolean);override;
     procedure Setinterfacedef(AValue: boolean);override;
    public
    public
     constructor create(level:byte;doregister:boolean);override;
     constructor create(level:byte;doregister:boolean);override;
-    function getcopyas(newtyp:tdeftyp;copytyp:tproccopytyp):tstoreddef;override;
+    function getcopyas(newtyp:tdeftyp;copytyp:tproccopytyp;const paraprefix:string):tstoreddef;override;
     function address_type:tdef;override;
     function address_type:tdef;override;
     function ofs_address_type:tdef;override;
     function ofs_address_type:tdef;override;
     function size:asizeint;override;
     function size:asizeint;override;
@@ -334,7 +334,7 @@ implementation
     end;
     end;
 
 
 
 
-  function tcpuprocdef.getcopyas(newtyp:tdeftyp;copytyp:tproccopytyp):tstoreddef;
+  function tcpuprocdef.getcopyas(newtyp:tdeftyp;copytyp:tproccopytyp;const paraprefix:string):tstoreddef;
     begin
     begin
       result:=inherited;
       result:=inherited;
       if is_far then
       if is_far then
@@ -428,7 +428,7 @@ implementation
     end;
     end;
 
 
 
 
-  function tcpuprocvardef.getcopyas(newtyp:tdeftyp;copytyp:tproccopytyp):tstoreddef;
+  function tcpuprocvardef.getcopyas(newtyp:tdeftyp;copytyp:tproccopytyp;const paraprefix:string):tstoreddef;
     begin
     begin
       result:=inherited;
       result:=inherited;
       if is_far then
       if is_far then

+ 4 - 4
compiler/jvm/pjvm.pas

@@ -505,7 +505,7 @@ implementation
 
 
         { add a method to call the procvar using unwrapped arguments, which
         { add a method to call the procvar using unwrapped arguments, which
           then wraps them and calls through to JLRMethod.invoke }
           then wraps them and calls through to JLRMethod.invoke }
-        methoddef:=tprocdef(tprocvardef(def).getcopyas(procdef,pc_bareproc));
+        methoddef:=tprocdef(tprocvardef(def).getcopyas(procdef,pc_bareproc,''));
         finish_copied_procdef(methoddef,'invoke',pvclass.symtable,pvclass);
         finish_copied_procdef(methoddef,'invoke',pvclass.symtable,pvclass);
         insert_self_and_vmt_para(methoddef);
         insert_self_and_vmt_para(methoddef);
         insert_funcret_para(methoddef);
         insert_funcret_para(methoddef);
@@ -540,7 +540,7 @@ implementation
             { add a method prototype matching the procvar (like the invoke
             { add a method prototype matching the procvar (like the invoke
               in the procvarclass itself) }
               in the procvarclass itself) }
             symtablestack.push(pvintf.symtable);
             symtablestack.push(pvintf.symtable);
-            methoddef:=tprocdef(tprocvardef(def).getcopyas(procdef,pc_bareproc));
+            methoddef:=tprocdef(tprocvardef(def).getcopyas(procdef,pc_bareproc,''));
             finish_copied_procdef(methoddef,name+'Callback',pvintf.symtable,pvintf);
             finish_copied_procdef(methoddef,name+'Callback',pvintf.symtable,pvintf);
             insert_self_and_vmt_para(methoddef);
             insert_self_and_vmt_para(methoddef);
             insert_funcret_para(methoddef);
             insert_funcret_para(methoddef);
@@ -639,7 +639,7 @@ implementation
         wrapperpd.synthetickind:=tsk_jvm_virtual_clmethod;
         wrapperpd.synthetickind:=tsk_jvm_virtual_clmethod;
         wrapperpd.skpara:=pd;
         wrapperpd.skpara:=pd;
         { also create procvar type that we can use in the implementation }
         { also create procvar type that we can use in the implementation }
-        wrapperpv:=tcpuprocvardef(pd.getcopyas(procvardef,pc_normal));
+        wrapperpv:=tcpuprocvardef(pd.getcopyas(procvardef,pc_normal,''));
         wrapperpv.calcparas;
         wrapperpv.calcparas;
         { no use in creating a callback wrapper here, this procvar type isn't
         { no use in creating a callback wrapper here, this procvar type isn't
           for public consumption }
           for public consumption }
@@ -667,7 +667,7 @@ implementation
         { wrapper is part of the same symtable as the original procdef }
         { wrapper is part of the same symtable as the original procdef }
         symtablestack.push(pd.owner);
         symtablestack.push(pd.owner);
         { get a copy of the constructor }
         { get a copy of the constructor }
-        wrapperpd:=tprocdef(pd.getcopyas(procdef,pc_bareproc));
+        wrapperpd:=tprocdef(pd.getcopyas(procdef,pc_bareproc,''));
         { this one is a class method rather than a constructor }
         { this one is a class method rather than a constructor }
         include(wrapperpd.procoptions,po_classmethod);
         include(wrapperpd.procoptions,po_classmethod);
         wrapperpd.proctypeoption:=potype_function;
         wrapperpd.proctypeoption:=potype_function;

+ 22 - 2
compiler/llvm/nllvmcal.pas

@@ -27,7 +27,7 @@ interface
 
 
     uses
     uses
       parabase,
       parabase,
-      ncgcal,
+      ncal,ncgcal,
       cgutils;
       cgutils;
 
 
     type
     type
@@ -38,6 +38,7 @@ interface
 
 
       tllvmcallnode = class(tcgcallnode)
       tllvmcallnode = class(tcgcallnode)
        protected
        protected
+        function paraneedsinlinetemp(para: tcallparanode; const pushconstaddr, complexpara: boolean): boolean; override;
         function can_call_ref(var ref: treference): boolean; override;
         function can_call_ref(var ref: treference): boolean; override;
         procedure pushparas; override;
         procedure pushparas; override;
       end;
       end;
@@ -47,7 +48,7 @@ implementation
 
 
      uses
      uses
        verbose,
        verbose,
-       ncal;
+       symconst,symdef;
 
 
 {*****************************************************************************
 {*****************************************************************************
                           TLLVMCALLPARANODE
                           TLLVMCALLPARANODE
@@ -64,6 +65,25 @@ implementation
                            TLLVMCALLNODE
                            TLLVMCALLNODE
  *****************************************************************************}
  *****************************************************************************}
 
 
+    function tllvmcallnode.paraneedsinlinetemp(para: tcallparanode; const pushconstaddr, complexpara: boolean): boolean;
+      begin
+        { We don't insert type conversions for self node trees to the type of
+          the self parameter (and doing so is quite hard due to all kinds of
+          ugly hacks with this parameter). This means that if we pass on a
+          self parameter through multiple levels of inlining, it may no
+          longer match the actual type of the parameter it has been passed to
+          -> always store in a temp which by definition will have the right
+          type (if it's a pointer-like type) }
+        if (vo_is_self in para.parasym.varoptions) and
+           (is_class_or_interface_or_dispinterface(para.parasym.vardef) or
+            is_classhelper(para.parasym.vardef) or
+            ((para.parasym.vardef.typ=classrefdef) and
+             is_class(tclassrefdef(para.parasym.vardef).pointeddef))) then
+          result:=true
+        else
+          result:=inherited;
+      end;
+
     function tllvmcallnode.can_call_ref(var ref: treference): boolean;
     function tllvmcallnode.can_call_ref(var ref: treference): boolean;
       begin
       begin
         result:=false;
         result:=false;

+ 3 - 3
compiler/llvm/nllvmcnv.pas

@@ -80,7 +80,7 @@ class function tllvmtypeconvnode.target_specific_need_equal_typeconv(fromdef, to
     result:=
     result:=
       (fromdef<>todef) and
       (fromdef<>todef) and
       { two procdefs that are structurally the same but semantically different
       { two procdefs that are structurally the same but semantically different
-        still need a convertion }
+        still need a conversion }
       (
       (
        ((fromdef.typ=procvardef) and
        ((fromdef.typ=procvardef) and
         (todef.typ=procvardef))
         (todef.typ=procvardef))
@@ -180,7 +180,7 @@ procedure tllvmtypeconvnode.second_proc_to_procvar;
         if location.loc<>LOC_REFERENCE then
         if location.loc<>LOC_REFERENCE then
           internalerror(2015111902);
           internalerror(2015111902);
         hlcg.g_ptrtypecast_ref(current_asmdata.CurrAsmList,
         hlcg.g_ptrtypecast_ref(current_asmdata.CurrAsmList,
-          cpointerdef.getreusable(tprocdef(left.resultdef).getcopyas(procvardef,pc_normal)),
+          cpointerdef.getreusable(tprocdef(left.resultdef).getcopyas(procvardef,pc_normal,'')),
           cpointerdef.getreusable(resultdef),
           cpointerdef.getreusable(resultdef),
           location.reference);
           location.reference);
       end;
       end;
@@ -283,7 +283,7 @@ procedure tllvmtypeconvnode.second_nothing;
         hlcg.location_force_mem(current_asmdata.CurrAsmList,left.location,left.resultdef);
         hlcg.location_force_mem(current_asmdata.CurrAsmList,left.location,left.resultdef);
         hreg:=hlcg.getaddressregister(current_asmdata.CurrAsmList,cpointerdef.getreusable(resultdef));
         hreg:=hlcg.getaddressregister(current_asmdata.CurrAsmList,cpointerdef.getreusable(resultdef));
         hlcg.a_loadaddr_ref_reg(current_asmdata.CurrAsmList,left.resultdef,cpointerdef.getreusable(resultdef),left.location.reference,hreg);
         hlcg.a_loadaddr_ref_reg(current_asmdata.CurrAsmList,left.resultdef,cpointerdef.getreusable(resultdef),left.location.reference,hreg);
-        location_reset_ref(location,left.location.loc,left.location.size,left.location.reference.alignment,left.location.reference.volatility);
+        location_reset_ref(location,left.location.loc,def_cgsize(resultdef),left.location.reference.alignment,left.location.reference.volatility);
         reference_reset_base(location.reference,hreg,0,location.reference.temppos,location.reference.alignment,location.reference.volatility);
         reference_reset_base(location.reference,hreg,0,location.reference.temppos,location.reference.alignment,location.reference.volatility);
       end
       end
     else
     else

+ 1 - 1
compiler/llvm/nllvmld.pas

@@ -90,7 +90,7 @@ procedure tllvmloadnode.pass_generate_code;
             (resultdef.typ in [symconst.procdef,procvardef]) and
             (resultdef.typ in [symconst.procdef,procvardef]) and
              not tabstractprocdef(resultdef).is_addressonly then
              not tabstractprocdef(resultdef).is_addressonly then
             begin
             begin
-              pvdef:=tprocvardef(procdef.getcopyas(procvardef,pc_normal));
+              pvdef:=tprocvardef(procdef.getcopyas(procvardef,pc_normal,''));
               { on little endian, location.register contains proc and
               { on little endian, location.register contains proc and
                 location.registerhi contains self; on big endian, it's the
                 location.registerhi contains self; on big endian, it's the
                 other way around }
                 other way around }

+ 2 - 2
compiler/m68k/symcpu.pas

@@ -97,7 +97,7 @@ type
     { library symbol for AmigaOS/MorphOS }
     { library symbol for AmigaOS/MorphOS }
     libsym : tsym;
     libsym : tsym;
     libsymderef : tderef;
     libsymderef : tderef;
-    function getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp): tstoreddef; override;
+    function getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp; const paraprefix: string): tstoreddef; override;
     procedure buildderef; override;
     procedure buildderef; override;
     procedure deref; override;
     procedure deref; override;
   end;
   end;
@@ -203,7 +203,7 @@ implementation
     end;
     end;
 
 
 
 
-  function tcpuprocdef.getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp): tstoreddef;
+  function tcpuprocdef.getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp; const paraprefix: string): tstoreddef;
     begin
     begin
       result:=inherited;
       result:=inherited;
       if newtyp=procdef then
       if newtyp=procdef then

+ 88 - 87
compiler/ncal.pas

@@ -108,6 +108,7 @@ interface
             it's not strictly necessary) for speed and code size reasons.
             it's not strictly necessary) for speed and code size reasons.
             Returns true if the temp creation has been handled, false otherwise
             Returns true if the temp creation has been handled, false otherwise
           }
           }
+          function paraneedsinlinetemp(para: tcallparanode; const pushconstaddr, complexpara: boolean): boolean; virtual;
           function maybecreateinlineparatemp(para: tcallparanode; out complexpara: boolean): boolean;
           function maybecreateinlineparatemp(para: tcallparanode; out complexpara: boolean): boolean;
           procedure createinlineparas;
           procedure createinlineparas;
           procedure wrapcomplexinlinepara(para: tcallparanode); virtual;
           procedure wrapcomplexinlinepara(para: tcallparanode); virtual;
@@ -4624,98 +4625,98 @@ implementation
       end;
       end;
 
 
 
 
+    function tcallnode.paraneedsinlinetemp(para: tcallparanode; const pushconstaddr, complexpara: boolean): boolean;
+      begin
+        { We need a temp if the passed value will not be in memory, while
+          the parameter inside the routine must be in memory }
+        if (tparavarsym(para.parasym).varregable in [vr_none,vr_addr]) and
+           not(para.left.expectloc in [LOC_REFERENCE,LOC_CREFERENCE]) then
+          exit(true);
+
+        { We cannot create a formaldef temp and assign something to it }
+        if para.parasym.vardef.typ=formaldef then
+          exit(false);
+
+        { We try to handle complex expressions later by taking their address
+          and storing this address in a temp (which is then dereferenced when
+          the value is used; that doesn't work if we cannot take the address
+          of the expression though, in which case we store the result of the
+          expression in a temp }
+        if (complexpara and not(para.left.expectloc in [LOC_REFERENCE,LOC_CREFERENCE]) or
+           (complexpara and
+            (not valid_for_addr(para.left,false) or
+             (para.left.nodetype=calln) or
+             is_constnode(para.left)))) then
+          exit(true);
+
+        { Normally, we do not need to create a temp for value parameters that
+          are not modified in the inlined function, and neither for const
+          parameters that are passed by value.
+
+          However, if we pass a global variable, an object field, a variable
+          whose address has been taken, or an expression containing a pointer
+          dereference as parameter, this value could be modified in other ways
+          as well (even inside the callee) and in such cases we still create a
+          temp to be on the safe side.
+
+          We *must not* create a temp for global variables passed by
+          reference to a const parameter, because if not inlined then any
+          changes to the original value will also be visible in the callee
+          (although this is technically undefined behaviour, since with
+           "const" the programmer tells the compiler this argument will not
+           change). }
+        if (((para.parasym.varspez=vs_value) and
+             (para.parasym.varstate in [vs_initialised,vs_declared,vs_read])) or
+            ((para.parasym.varspez=vs_const) and
+             not pushconstaddr)) and
+           foreachnodestatic(para.left,@nonlocalvars,pointer(symtableproc)) then
+          exit(true);
+
+        { Value parameters of which we know they are modified by definition
+          have to be copied to a temp }
+        if (para.parasym.varspez=vs_value) and
+           not(para.parasym.varstate in [vs_initialised,vs_declared,vs_read]) then
+          exit(true);
+
+        { the compiler expects that it can take the address of parameters passed by reference in
+          the case of const so we can't replace the node simply by a constant node
+          When playing with this code, ensure that
+          function f(const a,b  : longint) : longint;inline;
+            begin
+              result:=a*b;
+            end;
+
+          [...]
+          ...:=f(10,20));
+          [...]
+
+          is still folded. (FK)
+          }
+        if (para.parasym.varspez=vs_const) and
+           { const para's can get vs_readwritten if their address is taken ->
+             in case they are not passed by reference, to keep the same
+             behaviour as without inlining we have to make a copy in case the
+             originally passed parameter value gets changed inside the callee
+           }
+           (not pushconstaddr and
+            (para.parasym.varstate=vs_readwritten)
+           ) or
+           { call-by-reference const's may need to be passed by reference to
+             function called in the inlined code }
+           (pushconstaddr and
+            not valid_for_addr(para.left,false)) then
+          exit(true);
+
+        result:=false;
+      end;
+
+
     function tcallnode.maybecreateinlineparatemp(para: tcallparanode; out complexpara: boolean): boolean;
     function tcallnode.maybecreateinlineparatemp(para: tcallparanode; out complexpara: boolean): boolean;
       var
       var
         tempnode: ttempcreatenode;
         tempnode: ttempcreatenode;
         realtarget: tnode;
         realtarget: tnode;
         paracomplexity: longint;
         paracomplexity: longint;
         pushconstaddr: boolean;
         pushconstaddr: boolean;
-
-      function needtemp: boolean;
-        begin
-          { We need a temp if the passed value will not be in memory, while
-            the parameter inside the routine must be in memory }
-          if (tparavarsym(para.parasym).varregable in [vr_none,vr_addr]) and
-             not(para.left.expectloc in [LOC_REFERENCE,LOC_CREFERENCE]) then
-            exit(true);
-
-          { We cannot create a formaldef temp and assign something to it }
-          if para.parasym.vardef.typ=formaldef then
-            exit(false);
-
-          { We try to handle complex expressions later by taking their address
-            and storing this address in a temp (which is then dereferenced when
-            the value is used; that doesn't work if we cannot take the address
-            of the expression though, in which case we store the result of the
-            expression in a temp }
-          if (complexpara and not(para.left.expectloc in [LOC_REFERENCE,LOC_CREFERENCE]) or
-             (complexpara and
-              (not valid_for_addr(para.left,false) or
-               (para.left.nodetype=calln) or
-               is_constnode(para.left)))) then
-            exit(true);
-
-          { Normally, we do not need to create a temp for value parameters that
-            are not modified in the inlined function, and neither for const
-            parameters that are passed by value.
-
-            However, if we pass a global variable, an object field, a variable
-            whose address has been taken, or an expression containing a pointer
-            dereference as parameter, this value could be modified in other ways
-            as well (even inside the callee) and in such cases we still create a
-            temp to be on the safe side.
-
-            We *must not* create a temp for global variables passed by
-            reference to a const parameter, because if not inlined then any
-            changes to the original value will also be visible in the callee
-            (although this is technically undefined behaviour, since with
-             "const" the programmer tells the compiler this argument will not
-             change). }
-          if (((para.parasym.varspez=vs_value) and
-               (para.parasym.varstate in [vs_initialised,vs_declared,vs_read])) or
-              ((para.parasym.varspez=vs_const) and
-               not pushconstaddr)) and
-             foreachnodestatic(para.left,@nonlocalvars,pointer(symtableproc)) then
-            exit(true);
-
-          { Value parameters of which we know they are modified by definition
-            have to be copied to a temp }
-          if (para.parasym.varspez=vs_value) and
-             not(para.parasym.varstate in [vs_initialised,vs_declared,vs_read]) then
-            exit(true);
-
-          { the compiler expects that it can take the address of parameters passed by reference in
-            the case of const so we can't replace the node simply by a constant node
-            When playing with this code, ensure that
-            function f(const a,b  : longint) : longint;inline;
-              begin
-                result:=a*b;
-              end;
-
-            [...]
-            ...:=f(10,20));
-            [...]
-
-            is still folded. (FK)
-            }
-          if (para.parasym.varspez=vs_const) and
-             { const para's can get vs_readwritten if their address is taken ->
-               in case they are not passed by reference, to keep the same
-               behaviour as without inlining we have to make a copy in case the
-               originally passed parameter value gets changed inside the callee
-             }
-             (not pushconstaddr and
-              (para.parasym.varstate=vs_readwritten)
-             ) or
-             { call-by-reference const's may need to be passed by reference to
-               function called in the inlined code }
-             (pushconstaddr and
-              not valid_for_addr(para.left,false)) then
-            exit(true);
-
-          result:=false;
-        end;
-
       begin
       begin
         result:=false;
         result:=false;
         { determine how a parameter is passed to the inlined body
         { determine how a parameter is passed to the inlined body
@@ -4773,7 +4774,7 @@ implementation
         { check if we have to create a temp, assign the parameter's
         { check if we have to create a temp, assign the parameter's
           contents to that temp and then substitute the parameter
           contents to that temp and then substitute the parameter
           with the temp everywhere in the function                  }
           with the temp everywhere in the function                  }
-        if needtemp then
+        if paraneedsinlinetemp(para,pushconstaddr,complexpara) then
           begin
           begin
             tempnode:=ctempcreatenode.create(para.parasym.vardef,para.parasym.vardef.size,
             tempnode:=ctempcreatenode.create(para.parasym.vardef,para.parasym.vardef.size,
               tt_persistent,tparavarsym(para.parasym).is_regvar(false));
               tt_persistent,tparavarsym(para.parasym).is_regvar(false));

+ 3 - 3
compiler/ncgcnv.pas

@@ -423,10 +423,10 @@ interface
          case tstringdef(resultdef).stringtype of
          case tstringdef(resultdef).stringtype of
            st_shortstring :
            st_shortstring :
              begin
              begin
-               tg.gethltemp(current_asmdata.CurrAsmList,cshortstringtype,256,tt_normal,location.reference);
+               tg.gethltemp(current_asmdata.CurrAsmList,resultdef,resultdef.size,tt_normal,location.reference);
                tmpref:=location.reference;
                tmpref:=location.reference;
                hlcg.g_ptrtypecast_ref(current_asmdata.CurrAsmList,
                hlcg.g_ptrtypecast_ref(current_asmdata.CurrAsmList,
-                 cpointerdef.getreusable(cshortstringtype),
+                 cpointerdef.getreusable(resultdef),
                  cpointerdef.getreusable(left.resultdef),tmpref);
                  cpointerdef.getreusable(left.resultdef),tmpref);
                hlcg.a_load_loc_ref(current_asmdata.CurrAsmList,left.resultdef,left.resultdef,left.location,
                hlcg.a_load_loc_ref(current_asmdata.CurrAsmList,left.resultdef,left.resultdef,left.location,
                  tmpref);
                  tmpref);
@@ -574,7 +574,7 @@ interface
                     begin
                     begin
                       location.register:=hlcg.getaddressregister(current_asmdata.CurrAsmList,resultdef);
                       location.register:=hlcg.getaddressregister(current_asmdata.CurrAsmList,resultdef);
                       { code field is the first one }
                       { code field is the first one }
-                      hlcg.g_ptrtypecast_ref(current_asmdata.CurrAsmList,cpointerdef.getreusable(tprocvardef(tprocdef(left.resultdef).getcopyas(procvardef,pc_normal))),cpointerdef.getreusable(resultdef),left.location.reference);
+                      hlcg.g_ptrtypecast_ref(current_asmdata.CurrAsmList,cpointerdef.getreusable(tprocvardef(tprocdef(left.resultdef).getcopyas(procvardef,pc_normal,''))),cpointerdef.getreusable(resultdef),left.location.reference);
                       hlcg.a_load_ref_reg(current_asmdata.CurrAsmList,resultdef,resultdef,left.location.reference,location.register);
                       hlcg.a_load_ref_reg(current_asmdata.CurrAsmList,resultdef,resultdef,left.location.reference,location.register);
                     end;
                     end;
                   LOC_REGISTER,LOC_CREGISTER:
                   LOC_REGISTER,LOC_CREGISTER:

+ 5 - 10
compiler/ncgnstld.pas

@@ -106,8 +106,8 @@ implementation
                      the parentfpstruct inside the routine in which they were
                      the parentfpstruct inside the routine in which they were
                      originally declared, except in the initialisation code for
                      originally declared, except in the initialisation code for
                      the parentfpstruct (nf_internal flag) }
                      the parentfpstruct (nf_internal flag) }
-                  (tabstractnormalvarsym(symtableentry).inparentfpstruct and
-                   not(nf_internal in flags))) then
+                  tabstractnormalvarsym(symtableentry).inparentfpstruct) and
+                   not(nf_internal in flags) then
                 begin
                 begin
                   { get struct holding all locals accessed by nested routines }
                   { get struct holding all locals accessed by nested routines }
                   nestedvars:=tprocdef(symtable.defowner).parentfpstruct;
                   nestedvars:=tprocdef(symtable.defowner).parentfpstruct;
@@ -142,7 +142,6 @@ implementation
       var
       var
         thissym,
         thissym,
         nestedvars: tsym;
         nestedvars: tsym;
-        nestedvarsdef: tdef;
       begin
       begin
         result:=inherited;
         result:=inherited;
         if assigned(result) then
         if assigned(result) then
@@ -153,11 +152,8 @@ implementation
             begin
             begin
               { Nested variable? Then we have to move it to a structure that
               { Nested variable? Then we have to move it to a structure that
                 can be passed by reference to nested routines }
                 can be passed by reference to nested routines }
-              if assigned(current_procinfo) and
-                 (symtable.symtabletype in [localsymtable,parasymtable]) and
-                 ((symtable.symtablelevel<>current_procinfo.procdef.parast.symtablelevel) or
-                  (tabstractnormalvarsym(symtableentry).inparentfpstruct and
-                   not(nf_internal in flags))) then
+              if assigned(left) and
+                 not(nf_internal in flags) then
                 begin
                 begin
                   { get struct holding all locals accessed by nested routines }
                   { get struct holding all locals accessed by nested routines }
                   nestedvars:=tprocdef(symtable.defowner).parentfpstruct;
                   nestedvars:=tprocdef(symtable.defowner).parentfpstruct;
@@ -167,7 +163,6 @@ implementation
                       build_parentfpstruct(tprocdef(symtable.defowner));
                       build_parentfpstruct(tprocdef(symtable.defowner));
                       nestedvars:=tprocdef(symtable.defowner).parentfpstruct;
                       nestedvars:=tprocdef(symtable.defowner).parentfpstruct;
                     end;
                     end;
-                  nestedvarsdef:=tlocalvarsym(nestedvars).vardef;
                   if nestedvars<>symtableentry then
                   if nestedvars<>symtableentry then
                     thissym:=nestsym
                     thissym:=nestsym
                   else
                   else
@@ -185,7 +180,7 @@ implementation
                   left:=csubscriptnode.create(thissym,cderefnode.create(left));
                   left:=csubscriptnode.create(thissym,cderefnode.create(left));
                   firstpass(left);
                   firstpass(left);
                   include(flags,nf_internal);
                   include(flags,nf_internal);
-                 end;
+                end;
             end;
             end;
         end;
         end;
       end;
       end;

+ 4 - 2
compiler/ncgutil.pas

@@ -1814,9 +1814,11 @@ implementation
                         begin
                         begin
                           { can't free the result, because we load it after
                           { can't free the result, because we load it after
                             this call into the function result location
                             this call into the function result location
-                            (gets freed in thlcgobj.gen_load_return_value() }
+                            (gets freed in thlcgobj.gen_load_return_value();) }
                           if (typ in [localvarsym,paravarsym]) and
                           if (typ in [localvarsym,paravarsym]) and
-                             (([vo_is_funcret,vo_is_result]*varoptions)=[]) then
+                             (([vo_is_funcret,vo_is_result]*varoptions)=[]) and
+                             ((current_procinfo.procdef.proctypeoption<>potype_constructor) or
+                              not(vo_is_self in varoptions)) then
                             tg.Ungetlocal(list,localloc.reference);
                             tg.Ungetlocal(list,localloc.reference);
                         end;
                         end;
                     end;
                     end;

+ 5 - 3
compiler/ncnv.pas

@@ -350,7 +350,8 @@ implementation
         if equal_defs(p.resultdef,def) and
         if equal_defs(p.resultdef,def) and
            (p.resultdef.typ=def.typ) and
            (p.resultdef.typ=def.typ) and
            not is_bitpacked_access(p) and
            not is_bitpacked_access(p) and
-           not ctypeconvnode.target_specific_need_equal_typeconv(p.resultdef,def) then
+           ((p.blocktype=bt_const) or
+            not ctypeconvnode.target_specific_need_equal_typeconv(p.resultdef,def)) then
           begin
           begin
             { don't replace encoded string constants to rawbytestring encoding.
             { don't replace encoded string constants to rawbytestring encoding.
               preserve the codepage }
               preserve the codepage }
@@ -2268,7 +2269,7 @@ implementation
              copytype:=pc_address_only
              copytype:=pc_address_only
            else
            else
              copytype:=pc_normal;
              copytype:=pc_normal;
-           resultdef:=pd.getcopyas(procvardef,copytype);
+           resultdef:=pd.getcopyas(procvardef,copytype,'');
          end;
          end;
       end;
       end;
 
 
@@ -2434,7 +2435,8 @@ implementation
 {$ifdef llvm}
 {$ifdef llvm}
                      { we still may have to insert a type conversion at the
                      { we still may have to insert a type conversion at the
                        llvm level }
                        llvm level }
-                     if (left.resultdef<>resultdef) and
+                     if (blocktype<>bt_const) and
+                        (left.resultdef<>resultdef) and
                         { if unspecialised generic -> we won't generate any code
                         { if unspecialised generic -> we won't generate any code
                           for this, and keeping the type conversion node will
                           for this, and keeping the type conversion node will
                           cause valid_for_assign to fail because the typecast will be from/to something of 0
                           cause valid_for_assign to fail because the typecast will be from/to something of 0

+ 1 - 1
compiler/ninl.pas

@@ -4378,7 +4378,7 @@ implementation
 
 
          addstatement(newstatement,cassignmentnode.create(resultnode,hpp));
          addstatement(newstatement,cassignmentnode.create(resultnode,hpp));
 
 
-         { force pass 1, so copied tries get first pass'ed as well and flags like nf_write, nf_call_unique
+         { force pass 1, so copied trees get first pass'ed as well and flags like nf_write, nf_call_unique
            get set right }
            get set right }
          node_reset_flags(newstatement.statement,[nf_pass1_done]);
          node_reset_flags(newstatement.statement,[nf_pass1_done]);
          { firstpass it }
          { firstpass it }

+ 2 - 2
compiler/powerpc/symcpu.pas

@@ -97,7 +97,7 @@ type
     { library symbol for AmigaOS/MorphOS }
     { library symbol for AmigaOS/MorphOS }
     libsym : tsym;
     libsym : tsym;
     libsymderef : tderef;
     libsymderef : tderef;
-    function getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp): tstoreddef; override;
+    function getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp; const paraprefix: string): tstoreddef; override;
     procedure buildderef; override;
     procedure buildderef; override;
     procedure deref; override;
     procedure deref; override;
   end;
   end;
@@ -203,7 +203,7 @@ implementation
     end;
     end;
 
 
 
 
-  function tcpuprocdef.getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp): tstoreddef;
+  function tcpuprocdef.getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp; const paraprefix: string): tstoreddef;
     begin
     begin
       result:=inherited;
       result:=inherited;
       if newtyp=procdef then
       if newtyp=procdef then

+ 19 - 10
compiler/symcreat.pas

@@ -515,7 +515,7 @@ implementation
     end;
     end;
 
 
 
 
-  procedure addvisibibleparameters(var str: ansistring; pd: tprocdef);
+  procedure addvisibleparameters(var str: ansistring; pd: tprocdef);
     var
     var
       currpara: tparavarsym;
       currpara: tparavarsym;
       i: longint;
       i: longint;
@@ -530,7 +530,7 @@ implementation
               if not firstpara then
               if not firstpara then
                 str:=str+',';
                 str:=str+',';
               firstpara:=false;
               firstpara:=false;
-              str:=str+currpara.realname;
+              str:=str+'&'+currpara.realname;
             end;
             end;
         end;
         end;
     end;
     end;
@@ -554,7 +554,7 @@ implementation
         mnetion this program/unit name to avoid accidentally calling other
         mnetion this program/unit name to avoid accidentally calling other
         same-named routines that may be in scope }
         same-named routines that may be in scope }
       str:=str+def_unit_name_prefix_if_toplevel(callpd)+callpd.procsym.realname+'(';
       str:=str+def_unit_name_prefix_if_toplevel(callpd)+callpd.procsym.realname+'(';
-      addvisibibleparameters(str,pd);
+      addvisibleparameters(str,pd);
       str:=str+') end;';
       str:=str+') end;';
       str_parse_method_impl(str,pd,isclassmethod);
       str_parse_method_impl(str,pd,isclassmethod);
     end;
     end;
@@ -862,7 +862,7 @@ implementation
          not is_void(pd.returndef) then
          not is_void(pd.returndef) then
         str:=str+'result:=';
         str:=str+'result:=';
       str:=str+'pv(';
       str:=str+'pv(';
-      addvisibibleparameters(str,pd);
+      addvisibleparameters(str,pd);
       str:=str+') end;';
       str:=str+') end;';
       str_parse_method_impl(str,pd,true)
       str_parse_method_impl(str,pd,true)
     end;
     end;
@@ -964,7 +964,7 @@ implementation
       if pd.returndef<>voidtype then
       if pd.returndef<>voidtype then
         str:=str+'result:=';
         str:=str+'result:=';
       str:=str+'__FPC_BLOCK_INVOKE_PV_TYPE(PFPC_Block_literal_complex_procvar(FPC_Block_Self)^.pv)(';
       str:=str+'__FPC_BLOCK_INVOKE_PV_TYPE(PFPC_Block_literal_complex_procvar(FPC_Block_Self)^.pv)(';
-      addvisibibleparameters(str,pd);
+      addvisibleparameters(str,pd);
       str:=str+') end;';
       str:=str+') end;';
       str_parse_method_impl(str,pd,false);
       str_parse_method_impl(str,pd,false);
     end;
     end;
@@ -988,8 +988,8 @@ implementation
       { now call through to the actual method }
       { now call through to the actual method }
       if pd.returndef<>voidtype then
       if pd.returndef<>voidtype then
         str:=str+'result:=';
         str:=str+'result:=';
-      str:=str+callthroughpd.procsym.realname+'(';
-      addvisibibleparameters(str,callthroughpd);
+      str:=str+'&'+callthroughpd.procsym.realname+'(';
+      addvisibleparameters(str,pd);
       str:=str+') end;';
       str:=str+') end;';
       { add dummy file info so we can step in/through it }
       { add dummy file info so we can step in/through it }
       if pd.owner.iscurrentunit then
       if pd.owner.iscurrentunit then
@@ -1147,8 +1147,11 @@ implementation
   function create_procdef_alias(pd: tprocdef; const newrealname: string; const newmangledname: TSymStr; newparentst: tsymtable; newstruct: tabstractrecorddef;
   function create_procdef_alias(pd: tprocdef; const newrealname: string; const newmangledname: TSymStr; newparentst: tsymtable; newstruct: tabstractrecorddef;
       sk: tsynthetickind; skpara: pointer): tprocdef;
       sk: tsynthetickind; skpara: pointer): tprocdef;
     begin
     begin
-      { bare copy so we don't copy the aliasnames }
-      result:=tprocdef(pd.getcopyas(procdef,pc_bareproc));
+      { bare copy so we don't copy the aliasnames (specify prefix for
+        parameter names so we don't get issues in the body in case
+        we e.g. reference system.initialize and one of the parameters
+        is called "system") }
+      result:=tprocdef(pd.getcopyas(procdef,pc_bareproc,'__FPCW_'));
       { set the mangled name to the wrapper name }
       { set the mangled name to the wrapper name }
       result.setmangledname(newmangledname);
       result.setmangledname(newmangledname);
       { finish creating the copy }
       { finish creating the copy }
@@ -1481,7 +1484,10 @@ implementation
         because there may already be references to the mangled name for the
         because there may already be references to the mangled name for the
         non-external "test".
         non-external "test".
       }
       }
-      newpd:=tprocdef(orgpd.getcopyas(procdef,pc_bareproc));
+
+      { prefixing the parameters here is useless, because the new procdef will
+        just be an external declaration without a body }
+      newpd:=tprocdef(orgpd.getcopyas(procdef,pc_bareproc,''));
       insert_funcret_para(newpd);
       insert_funcret_para(newpd);
       newpd.procoptions:=newpd.procoptions+orgpd.procoptions*[po_external,po_has_importname,po_has_importdll];
       newpd.procoptions:=newpd.procoptions+orgpd.procoptions*[po_external,po_has_importname,po_has_importdll];
       newpd.import_name:=orgpd.import_name;
       newpd.import_name:=orgpd.import_name;
@@ -1493,6 +1499,9 @@ implementation
       newpd.setmangledname(newname);
       newpd.setmangledname(newname);
       finish_copied_procdef(newpd,'__FPC_IMPL_EXTERNAL_REDIRECT_'+newname,current_module.localsymtable,nil);
       finish_copied_procdef(newpd,'__FPC_IMPL_EXTERNAL_REDIRECT_'+newname,current_module.localsymtable,nil);
       newpd.forwarddef:=false;
       newpd.forwarddef:=false;
+      { ideally we would prefix the parameters of the original routine here, but since it
+        can be an interface definition, we cannot do that without risking to change the
+        interface crc }
       orgpd.skpara:=newpd;
       orgpd.skpara:=newpd;
       orgpd.synthetickind:=tsk_callthrough;
       orgpd.synthetickind:=tsk_callthrough;
       orgpd.procoptions:=orgpd.procoptions-[po_external,po_has_importname,po_has_importdll];
       orgpd.procoptions:=orgpd.procoptions-[po_external,po_has_importname,po_has_importdll];

+ 18 - 11
compiler/symdef.pas

@@ -630,7 +630,7 @@ interface
           function  is_addressonly:boolean;virtual;
           function  is_addressonly:boolean;virtual;
           function  no_self_node:boolean;
           function  no_self_node:boolean;
           { get either a copy as a procdef or procvardef }
           { get either a copy as a procdef or procvardef }
-          function  getcopyas(newtyp:tdeftyp;copytyp:tproccopytyp): tstoreddef; virtual;
+          function  getcopyas(newtyp:tdeftyp;copytyp:tproccopytyp; const paraprefix: string): tstoreddef; virtual;
           function  compatible_with_pointerdef_size(ptr: tpointerdef): boolean; virtual;
           function  compatible_with_pointerdef_size(ptr: tpointerdef): boolean; virtual;
           procedure check_mark_as_nested;
           procedure check_mark_as_nested;
           procedure init_paraloc_info(side: tcallercallee);
           procedure init_paraloc_info(side: tcallercallee);
@@ -668,7 +668,7 @@ interface
           function  is_methodpointer:boolean;override;
           function  is_methodpointer:boolean;override;
           function  is_addressonly:boolean;override;
           function  is_addressonly:boolean;override;
           function  getmangledparaname:TSymStr;override;
           function  getmangledparaname:TSymStr;override;
-          function getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp): tstoreddef; override;
+          function getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp; const paraprefix: string): tstoreddef; override;
        end;
        end;
        tprocvardefclass = class of tprocvardef;
        tprocvardefclass = class of tprocvardef;
 
 
@@ -813,7 +813,7 @@ interface
                 needs to be finalised afterwards by calling
                 needs to be finalised afterwards by calling
                 symcreat.finish_copied_procdef() afterwards
                 symcreat.finish_copied_procdef() afterwards
           }
           }
-          function  getcopyas(newtyp:tdeftyp;copytyp:tproccopytyp): tstoreddef; override;
+          function  getcopyas(newtyp:tdeftyp;copytyp:tproccopytyp; const paraprefix: string): tstoreddef; override;
           function  getcopy: tstoreddef; override;
           function  getcopy: tstoreddef; override;
           function  GetTypeName : string;override;
           function  GetTypeName : string;override;
           function  mangledname : TSymStr; virtual;
           function  mangledname : TSymStr; virtual;
@@ -5154,7 +5154,7 @@ implementation
       end;
       end;
 
 
 
 
-    function tabstractprocdef.getcopyas(newtyp:tdeftyp;copytyp:tproccopytyp): tstoreddef;
+    function tabstractprocdef.getcopyas(newtyp:tdeftyp;copytyp:tproccopytyp; const paraprefix: string): tstoreddef;
       var
       var
         j, nestinglevel: longint;
         j, nestinglevel: longint;
         pvs, npvs: tparavarsym;
         pvs, npvs: tparavarsym;
@@ -5187,8 +5187,15 @@ implementation
                   if (copytyp=pc_bareproc) and
                   if (copytyp=pc_bareproc) and
                      (([vo_is_self,vo_is_vmt,vo_is_parentfp,vo_is_result,vo_is_funcret]*pvs.varoptions)<>[]) then
                      (([vo_is_self,vo_is_vmt,vo_is_parentfp,vo_is_result,vo_is_funcret]*pvs.varoptions)<>[]) then
                     continue;
                     continue;
-                  npvs:=cparavarsym.create(pvs.realname,pvs.paranr,pvs.varspez,
-                    pvs.vardef,pvs.varoptions);
+                  if paraprefix='' then
+                    npvs:=cparavarsym.create(pvs.realname,pvs.paranr,pvs.varspez,
+                      pvs.vardef,pvs.varoptions)
+                  else if not(vo_is_high_para in pvs.varoptions) then
+                    npvs:=cparavarsym.create(paraprefix+pvs.realname,pvs.paranr,pvs.varspez,
+                      pvs.vardef,pvs.varoptions)
+                  else
+                    npvs:=cparavarsym.create('$high'+paraprefix+copy(pvs.name,5,length(pvs.name)),pvs.paranr,pvs.varspez,
+                      pvs.vardef,pvs.varoptions);
                   npvs.defaultconstsym:=pvs.defaultconstsym;
                   npvs.defaultconstsym:=pvs.defaultconstsym;
                   tabstractprocdef(result).parast.insert(npvs);
                   tabstractprocdef(result).parast.insert(npvs);
                 end;
                 end;
@@ -6070,11 +6077,11 @@ implementation
       end;
       end;
 
 
 
 
-    function tprocdef.getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp): tstoreddef;
+    function tprocdef.getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp; const paraprefix: string): tstoreddef;
       var
       var
         j : longint;
         j : longint;
       begin
       begin
-        result:=inherited getcopyas(newtyp,copytyp);
+        result:=inherited;
         if newtyp=procvardef then
         if newtyp=procvardef then
           begin
           begin
             { create new paralist }
             { create new paralist }
@@ -6141,7 +6148,7 @@ implementation
 
 
     function tprocdef.getcopy: tstoreddef;
     function tprocdef.getcopy: tstoreddef;
       begin
       begin
-        result:=getcopyas(procdef,pc_normal);
+        result:=getcopyas(procdef,pc_normal,'');
       end;
       end;
 
 
 
 
@@ -6504,7 +6511,7 @@ implementation
             { do not simply push/pop current_module.localsymtable, because
             { do not simply push/pop current_module.localsymtable, because
               that can have side-effects (e.g., it removes helpers) }
               that can have side-effects (e.g., it removes helpers) }
             symtablestack:=nil;
             symtablestack:=nil;
-            result:=tprocvardef(def.getcopyas(procvardef,pc_address_only));
+            result:=tprocvardef(def.getcopyas(procvardef,pc_address_only,''));
             setup_reusable_def(def,result,res,oldsymtablestack);
             setup_reusable_def(def,result,res,oldsymtablestack);
             { res^.Data may still be nil -> don't overwrite result }
             { res^.Data may still be nil -> don't overwrite result }
             exit;
             exit;
@@ -6643,7 +6650,7 @@ implementation
       end;
       end;
 
 
 
 
-    function tprocvardef.getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp): tstoreddef;
+    function tprocvardef.getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp; const paraprefix: string): tstoreddef;
       begin
       begin
         result:=inherited;
         result:=inherited;
         tabstractprocdef(result).calcparas;
         tabstractprocdef(result).calcparas;

+ 2 - 2
compiler/x86_64/symcpu.pas

@@ -97,7 +97,7 @@ type
     { library symbol for AROS }
     { library symbol for AROS }
     libsym : tsym;
     libsym : tsym;
     libsymderef : tderef;
     libsymderef : tderef;
-    function getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp): tstoreddef; override;
+    function getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp; const paraprefix: string): tstoreddef; override;
     procedure buildderef; override;
     procedure buildderef; override;
     procedure deref; override;
     procedure deref; override;
   end;
   end;
@@ -203,7 +203,7 @@ implementation
     end;
     end;
 
 
 
 
-  function tcpuprocdef.getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp): tstoreddef;
+  function tcpuprocdef.getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp; const paraprefix: string): tstoreddef;
     begin
     begin
       result:=inherited;
       result:=inherited;
       if newtyp=procdef then
       if newtyp=procdef then

+ 1 - 1
packages/chm/src/chmcmd.lpr

@@ -26,7 +26,7 @@ uses
   {$ifdef Unix}cthreads,{$endif} Classes, Sysutils, chmfilewriter, GetOpts;
   {$ifdef Unix}cthreads,{$endif} Classes, Sysutils, chmfilewriter, GetOpts;
 
 
 Const
 Const
-  CHMCMDVersion = '3.1.1';
+  CHMCMDVersion = {$I %FPCVERSION%};
 
 
 Procedure Usage;
 Procedure Usage;
 
 

+ 49 - 0
packages/fcl-db/examples/myext.pp

@@ -0,0 +1,49 @@
+library myext;
+
+{$mode objfpc}{$h+}
+
+uses
+  sysutils,
+  ctypes,
+  sqlite3,
+  sqlite3ext;
+
+procedure mysum(ctx: psqlite3_context; n: cint; v: ppsqlite3_value); cdecl;
+var
+  a, b, r: cint;
+begin
+  a := sqlite3_value_int(v[0]);
+  b := sqlite3_value_int(v[1]);
+  r := a + b;
+  sqlite3_result_int(ctx, r);
+end;
+
+procedure myconcat(ctx: psqlite3_context; n: cint; v: ppsqlite3_value); cdecl;
+var
+  a, b, r: ansistring;
+begin
+  a := sqlite3_value_text(v[0]);
+  b := sqlite3_value_text(v[1]);
+  r := a + b;
+  sqlite3_result_text(ctx, @r[1], length(r), nil);
+end;
+
+function sqlite3_extension_init(db: Psqlite3; pzErrMsg: Ppcchar;
+  const pApi: Psqlite3_api_routines): cint; cdecl; export;
+var
+  rc: cint;
+begin
+  SQLITE_EXTENSION_INIT2(pApi);
+  rc := sqlite3_create_function(db, 'mysum', 2, SQLITE_UTF8, nil,
+    @mysum, nil, nil);
+  if rc = SQLITE_OK then
+    Result := sqlite3_create_function(db, 'myconcat', 2, SQLITE_UTF8, nil,
+      @myconcat, nil, nil);
+  Result := rc;
+end;
+
+exports
+  sqlite3_extension_init;
+
+begin
+end.

+ 40 - 0
packages/fcl-db/examples/sqlite3extdemo.pp

@@ -0,0 +1,40 @@
+program test;
+
+{$mode objfpc}{$H+}
+
+uses
+  sysutils,
+  sqlite3conn,
+  sqlite3ext,
+  sqldb;
+
+const
+  SharedPrefix = {$ifdef mswindows}''{$else}'lib'{$endif};
+
+var
+  con: TSQLite3Connection;
+  trans: TSQLTransaction;
+  q: TSQLQuery;
+begin
+  con := TSQLite3Connection.Create(nil);
+  trans := TSQLTransaction.Create(con);
+  q := TSQLQuery.Create(con);
+  try
+    trans.DataBase := con;
+    q.DataBase := con;
+    q.Transaction := trans;
+    con.DatabaseName := 'test.sqlite3';
+    con.Open;
+    con.LoadExtension(ExtractFilePath(ParamStr(0)) +
+      SharedPrefix + 'myext.' + SharedSuffix);
+    q.SQL.Text := 'SELECT mysum(2, 3);';
+    q.Open;
+    WriteLn('MYSUM: ', q.Fields[0].AsInteger); // prints "MYSUM: 5"
+    q.Close;
+    q.SQL.Text := 'SELECT myconcat(''abc'', ''123'');';
+    q.Open;
+    WriteLn('MYCONCAT: ', q.Fields[0].AsString); // prints "MYCONCAT: abc123"
+  finally
+    con.Free;
+  end;
+end.

+ 2 - 2
packages/fcl-db/src/sqldb/sqlite/sqlite3conn.pp

@@ -119,7 +119,7 @@ Type
     // Warning: UTF8CompareCallback needs a wide string manager on Linux such as cwstring
     // Warning: UTF8CompareCallback needs a wide string manager on Linux such as cwstring
     // Warning: CollationName has to be a UTF-8 string
     // Warning: CollationName has to be a UTF-8 string
     procedure CreateCollation(const CollationName: string; eTextRep: integer; Arg: Pointer=nil; Compare: xCompare=nil);
     procedure CreateCollation(const CollationName: string; eTextRep: integer; Arg: Pointer=nil; Compare: xCompare=nil);
-    procedure LoadExtension(LibraryFile: string);
+    procedure LoadExtension(const LibraryFile: string);
   Published
   Published
     Property OpenFlags : TSQLiteOpenFlags Read FOpenFlags Write SetOpenFlags default DefaultOpenFlags;
     Property OpenFlags : TSQLiteOpenFlags Read FOpenFlags Write SetOpenFlags default DefaultOpenFlags;
   end;
   end;
@@ -1107,7 +1107,7 @@ begin
   CheckError(sqlite3_create_collation(fhandle, PChar(CollationName), eTextRep, Arg, Compare));
   CheckError(sqlite3_create_collation(fhandle, PChar(CollationName), eTextRep, Arg, Compare));
 end;
 end;
 
 
-procedure TSQLite3Connection.LoadExtension(LibraryFile: string);
+procedure TSQLite3Connection.LoadExtension(const LibraryFile: string);
 var
 var
   LoadResult: integer;
   LoadResult: integer;
 begin
 begin

+ 1 - 1
packages/fpmkunit/src/fpmkunit.pp

@@ -1683,7 +1683,7 @@ ResourceString
   SWarngcclibpath         = 'Warning: Unable to determine the libgcc path.';
   SWarngcclibpath         = 'Warning: Unable to determine the libgcc path.';
   SWarnNoFCLProcessSupport= 'No FCL-Process support';
   SWarnNoFCLProcessSupport= 'No FCL-Process support';
   SWarnRetryRemDirectory     = 'Failed to remove directory "%s". Retry after a short delay';
   SWarnRetryRemDirectory     = 'Failed to remove directory "%s". Retry after a short delay';
-  SWarnRetryDeleteFile       = 'Failed to remove file "%f". Retry after a short delay';
+  SWarnRetryDeleteFile       = 'Failed to remove file "%s". Retry after a short delay';
   SWarnCombinedPathAndUDir= 'Warning: Better do not combine the SearchPath and Global/Local-UnitDir parameters';
   SWarnCombinedPathAndUDir= 'Warning: Better do not combine the SearchPath and Global/Local-UnitDir parameters';
   SWarnRemovedNonEmptyDirectory = 'Warning: Removed non empty directory "%s"';
   SWarnRemovedNonEmptyDirectory = 'Warning: Removed non empty directory "%s"';
 
 

+ 3 - 0
packages/pastojs/src/fppas2js.pp

@@ -374,6 +374,9 @@ ToDos:
     - functions
     - functions
     - rtti
     - rtti
 - bug: DoIt(typeinfo(i))  where DoIt is in another unit and has TTypeInfo
 - bug: DoIt(typeinfo(i))  where DoIt is in another unit and has TTypeInfo
+- $OPTIMIZATION ON|OFF
+- $optimization REMOVEEMPTYPROCS
+- $optimization REMOVEEMPTYPROCS,RemoveNotUsedDeclarations-
 - setlength(dynarray)  modeswitch to not create a copy
 - setlength(dynarray)  modeswitch to not create a copy
 - 'new', 'Function' -> class var use .prototype
 - 'new', 'Function' -> class var use .prototype
 - static arrays
 - static arrays

+ 1 - 1
packages/pastojs/src/pas2jsfilecache.pp

@@ -1896,7 +1896,7 @@ var
   // search in Dir for pp, pas, p times given case, lower case, upper case
   // search in Dir for pp, pas, p times given case, lower case, upper case
   begin
   begin
     Dir:=IncludeTrailingPathDelimiter(Dir);
     Dir:=IncludeTrailingPathDelimiter(Dir);
-    if IndexOfFile(SearchedDirs,Dir)>=0 then exit;
+    if IndexOfFile(SearchedDirs,Dir)>=0 then exit(false);
     SearchedDirs.Add(Dir);
     SearchedDirs.Add(Dir);
     Filename:=Dir+aUnitname+'.pp';
     Filename:=Dir+aUnitname+'.pp';
     if SearchLowUpCase(Filename) then exit(true);
     if SearchLowUpCase(Filename) then exit(true);

+ 32 - 8
packages/rtl-console/src/unix/keyboard.pp

@@ -96,6 +96,12 @@ const KbShiftUp    = $f0;
       KbShiftDown  = $f3;
       KbShiftDown  = $f3;
       KbShiftHome  = $f4;
       KbShiftHome  = $f4;
       KbShiftEnd   = $f5;
       KbShiftEnd   = $f5;
+      KbCtrlShiftUp    = $f6;
+      KbCtrlShiftDown  = $f7;
+      KbCtrlShiftRight = $f8;
+      KbCtrlShiftLeft  = $f9;
+      KbCtrlShiftHome  = $fa;
+      KbCtrlShiftEnd   = $fb;
 
 
       double_esc_hack_enabled : boolean = false;
       double_esc_hack_enabled : boolean = false;
 
 
@@ -494,7 +500,7 @@ const
     MouseEvent.buttons := 0;
     MouseEvent.buttons := 0;
     PutMouseEvent(MouseEvent);
     PutMouseEvent(MouseEvent);
   end;
   end;
-  
+
   procedure GenMouseEvent;
   procedure GenMouseEvent;
   var MouseEvent: TMouseEvent;
   var MouseEvent: TMouseEvent;
       ch : char;
       ch : char;
@@ -869,7 +875,7 @@ type  key_sequence=packed record
         st:string[7];
         st:string[7];
       end;
       end;
 
 
-const key_sequences:array[0..289] of key_sequence=(
+const key_sequences:array[0..297] of key_sequence=(
        (char:0;scan:kbAltA;st:#27'A'),
        (char:0;scan:kbAltA;st:#27'A'),
        (char:0;scan:kbAltA;st:#27'a'),
        (char:0;scan:kbAltA;st:#27'a'),
        (char:0;scan:kbAltB;st:#27'B'),
        (char:0;scan:kbAltB;st:#27'B'),
@@ -1136,6 +1142,15 @@ const key_sequences:array[0..289] of key_sequence=(
        (char:0;scan:kbShiftHome;st:#27'[1;2H'),  {xterm}
        (char:0;scan:kbShiftHome;st:#27'[1;2H'),  {xterm}
        (char:0;scan:kbShiftHome;st:#27'[7$'),    {rxvt}
        (char:0;scan:kbShiftHome;st:#27'[7$'),    {rxvt}
 
 
+       (char:0;scan:KbCtrlShiftUp;st:#27'[1;6A'),    {xterm}
+       (char:0;scan:KbCtrlShiftDown;st:#27'[1;6B'),  {xterm}
+       (char:0;scan:KbCtrlShiftRight;st:#27'[1;6C'), {xterm, xfce4}
+       (char:0;scan:KbCtrlShiftLeft;st:#27'[1;6D'),  {xterm, xfce4}
+       (char:0;scan:KbCtrlShiftHome;st:#27'[1;6H'),  {xterm}
+       (char:0;scan:KbCtrlShiftEnd;st:#27'[1;6F'),   {xterm}
+
+       (char:0;scan:kbCtrlPgDn;st:#27'[6;5~'),   {xterm}
+       (char:0;scan:kbCtrlPgUp;st:#27'[5;5~'),   {xterm}
        (char:0;scan:kbCtrlUp;st:#27'[1;5A'),     {xterm}
        (char:0;scan:kbCtrlUp;st:#27'[1;5A'),     {xterm}
        (char:0;scan:kbCtrlDown;st:#27'[1;5B'),   {xterm}
        (char:0;scan:kbCtrlDown;st:#27'[1;5B'),   {xterm}
        (char:0;scan:kbCtrlRight;st:#27'[1;5C'),  {xterm}
        (char:0;scan:kbCtrlRight;st:#27'[1;5C'),  {xterm}
@@ -1304,7 +1319,7 @@ begin
               {This is the same hack as in findsequence; see findsequence for
               {This is the same hack as in findsequence; see findsequence for
                explanation.}
                explanation.}
               ch:=ttyrecvchar;
               ch:=ttyrecvchar;
-              {Alt+O cannot be used in this situation, it can be a function key.} 
+              {Alt+O cannot be used in this situation, it can be a function key.}
               if not(ch in ['a'..'z','A'..'N','P'..'Z','0'..'9','-','+','_','=']) then
               if not(ch in ['a'..'z','A'..'N','P'..'Z','0'..'9','-','+','_','=']) then
                 begin
                 begin
                   if intail=0 then
                   if intail=0 then
@@ -1361,11 +1376,11 @@ begin
         end
         end
       else
       else
         RestoreArray;
         RestoreArray;
-   end
+   end;
 {$ifdef logging}
 {$ifdef logging}
        writeln(f);
        writeln(f);
 {$endif logging}
 {$endif logging}
-    ;
+
   ReadKey:=PopKey;
   ReadKey:=PopKey;
 End;
 End;
 
 
@@ -1541,6 +1556,8 @@ const
     kbAltDown,kbAltPgDn,kbAltIns,kbAltDel);
     kbAltDown,kbAltPgDn,kbAltIns,kbAltDel);
   ShiftArrow : array [kbShiftUp..kbShiftEnd] of byte =
   ShiftArrow : array [kbShiftUp..kbShiftEnd] of byte =
    (kbUp,kbLeft,kbRight,kbDown,kbHome,kbEnd);
    (kbUp,kbLeft,kbRight,kbDown,kbHome,kbEnd);
+  CtrlShiftArrow : array [kbCtrlShiftUp..kbCtrlShiftEnd] of byte =
+   (kbCtrlUp,kbCtrlDown,kbCtrlRight,kbCtrlLeft,kbCtrlHome,kbCtrlEnd);
 
 
 var
 var
   MyScan:byte;
   MyScan:byte;
@@ -1601,10 +1618,17 @@ begin {main}
             kbF11..KbF12 : { sF11-sF12 }
             kbF11..KbF12 : { sF11-sF12 }
               MyScan:=MyScan+kbShiftF11-kbF11;
               MyScan:=MyScan+kbShiftF11-kbF11;
           end;
           end;
-        if myscan in [kbShiftUp..kbShiftEnd] then
+        if myscan in [kbShiftUp..kbCtrlShiftEnd] then
           begin
           begin
-            myscan:=ShiftArrow[myscan];
-            sstate:=sstate or kbshift;
+            if myscan <= kbShiftEnd then
+            begin
+               myscan:=ShiftArrow[myscan];
+               sstate:=sstate or kbshift;
+            end else
+            begin
+               myscan:=CtrlShiftArrow[myscan];
+               sstate:=sstate or kbshift or kbCtrl;
+            end;
           end;
           end;
         if myscan=kbAltBack then
         if myscan=kbAltBack then
           sstate:=sstate or kbalt;
           sstate:=sstate or kbalt;

+ 66 - 0
packages/sqlite/examples/myext.lpi

@@ -0,0 +1,66 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<CONFIG>
+  <ProjectOptions>
+    <Version Value="11"/>
+    <General>
+      <Flags>
+        <SaveOnlyProjectUnits Value="True"/>
+        <MainUnitHasCreateFormStatements Value="False"/>
+        <MainUnitHasTitleStatement Value="False"/>
+        <MainUnitHasScaledStatement Value="False"/>
+      </Flags>
+      <MainUnit Value="0"/>
+      <Title Value="myext"/>
+      <UseAppBundle Value="False"/>
+      <ResourceType Value="res"/>
+    </General>
+    <BuildModes Count="1" Active="Default">
+      <Item1 Name="Default" Default="True"/>
+    </BuildModes>
+    <PublishOptions>
+      <Version Value="2"/>
+      <UseFileFilters Value="True"/>
+    </PublishOptions>
+    <RunParams>
+      <FormatVersion Value="2"/>
+      <Modes Count="0"/>
+    </RunParams>
+    <Units Count="1">
+      <Unit0>
+        <Filename Value="myext.pp"/>
+        <IsPartOfProject Value="True"/>
+      </Unit0>
+    </Units>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="11"/>
+    <Target>
+      <Filename Value="myext"/>
+    </Target>
+    <SearchPaths>
+      <IncludeFiles Value="$(ProjOutDir)"/>
+      <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
+    </SearchPaths>
+    <CodeGeneration>
+      <RelocatableUnit Value="True"/>
+    </CodeGeneration>
+    <Linking>
+      <Options>
+        <ExecutableType Value="Library"/>
+      </Options>
+    </Linking>
+  </CompilerOptions>
+  <Debugging>
+    <Exceptions Count="3">
+      <Item1>
+        <Name Value="EAbort"/>
+      </Item1>
+      <Item2>
+        <Name Value="ECodetoolError"/>
+      </Item2>
+      <Item3>
+        <Name Value="EFOpenError"/>
+      </Item3>
+    </Exceptions>
+  </Debugging>
+</CONFIG>

+ 49 - 0
packages/sqlite/examples/myext.pp

@@ -0,0 +1,49 @@
+library myext;
+
+{$mode objfpc}{$h+}
+
+uses
+  sysutils,
+  ctypes,
+  sqlite3,
+  sqlite3ext;
+
+procedure mysum(ctx: psqlite3_context; n: cint; v: ppsqlite3_value); cdecl;
+var
+  a, b, r: cint;
+begin
+  a := sqlite3_value_int(v[0]);
+  b := sqlite3_value_int(v[1]);
+  r := a + b;
+  sqlite3_result_int(ctx, r);
+end;
+
+procedure myconcat(ctx: psqlite3_context; n: cint; v: ppsqlite3_value); cdecl;
+var
+  a, b, r: ansistring;
+begin
+  a := sqlite3_value_text(v[0]);
+  b := sqlite3_value_text(v[1]);
+  r := a + b;
+  sqlite3_result_text(ctx, @r[1], length(r), nil);
+end;
+
+function sqlite3_extension_init(db: Psqlite3; pzErrMsg: Ppcchar;
+  const pApi: Psqlite3_api_routines): cint; cdecl; export;
+var
+  rc: cint;
+begin
+  SQLITE_EXTENSION_INIT2(pApi);
+  rc := sqlite3_create_function(db, 'mysum', 2, SQLITE_UTF8, nil,
+    @mysum, nil, nil);
+  if rc = SQLITE_OK then
+    Result := sqlite3_create_function(db, 'myconcat', 2, SQLITE_UTF8, nil,
+      @myconcat, nil, nil);
+  Result := rc;
+end;
+
+exports
+  sqlite3_extension_init;
+
+begin
+end.

+ 3 - 1
packages/sqlite/fpmake.pp

@@ -47,7 +47,9 @@ begin
           AddUnit('sqlite');
           AddUnit('sqlite');
         end;
         end;
     T:=P.Targets.AddUnit('sqlite.pp');
     T:=P.Targets.AddUnit('sqlite.pp');
-
+    T:=P.Targets.AddUnit('sqlite3ext.pp');
+      T.Dependencies.AddUnit('sqlite');
+ 
     P.ExamplePath.Add('tests/');
     P.ExamplePath.Add('tests/');
     P.Targets.AddExampleProgram('testapiv3x.pp');
     P.Targets.AddExampleProgram('testapiv3x.pp');
     P.Targets.AddExampleProgram('test.pas');
     P.Targets.AddExampleProgram('test.pas');

+ 313 - 0
packages/sqlite/src/sqlite3ext.pp

@@ -0,0 +1,313 @@
+{
+  This file is part of the Free Pascal Classes Library (FCL).
+  Copyright (C) 2018 Silvio Clecio (silvioprog) member of
+  the Free Pascal development team.
+
+  This unit file defines the SQLite interface for use by
+  shared libraries that want to be imported as extensions
+  into a SQLite instance.
+
+  See the file COPYING.FPC, included in this distribution,
+  for details about the copyright.
+
+  This program is distributed in the hope that it will be useful,
+  but WITHOUT ANY WARRANTY; without even the implied warranty of
+  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+}
+
+unit SQLite3Ext;
+
+{$mode objfpc}{$h+}
+
+interface
+
+uses
+  ctypes,
+  sqlite3;
+
+{$packrecords c}
+
+type
+  Ppcchar = ^pcchar;
+  PPpcchar = ^Ppcchar;
+  va_list = type Pointer;
+
+  xCallback = function (_para1:cunsigned; _para2:pointer; _para3:pointer; _para4:pointer):cint;cdecl;
+
+  Psqlite3_api_routines = ^sqlite3_api_routines;
+  (*
+  ** The following structure holds pointers to all of the SQLite API
+  ** routines.
+  **
+  ** WARNING:  In order to maintain backwards compatibility, add new
+  ** interfaces to the end of this structure only.  If you insert new
+  ** interfaces in the middle of this structure, then older different
+  ** versions of SQLite will not be able to load each other's shared
+  ** libraries!
+  *)
+  sqlite3_api_routines = record
+      aggregate_context : function (_para1:Psqlite3_context; nBytes:cint):pointer;cdecl;
+      aggregate_count : function (_para1:Psqlite3_context):cint;cdecl;
+      bind_blob : function (_para1:Psqlite3_stmt; _para2:cint; _para3:pointer; n:cint; _para5:sqlite3_destructor_type):cint;cdecl;
+      bind_double : function (_para1:Psqlite3_stmt; _para2:cint; _para3:double):cint;cdecl;
+      bind_int : function (_para1:Psqlite3_stmt; _para2:cint; _para3:cint):cint;cdecl;
+      bind_int64 : function (_para1:Psqlite3_stmt; _para2:cint; _para3:sqlite_int64):cint;cdecl;
+      bind_null : function (_para1:Psqlite3_stmt; _para2:cint):cint;cdecl;
+      bind_parameter_count : function (_para1:Psqlite3_stmt):cint;cdecl;
+      bind_parameter_index : function (_para1:Psqlite3_stmt; zName:pcchar):cint;cdecl;
+      bind_parameter_name : function (_para1:Psqlite3_stmt; _para2:cint):pcchar;cdecl;
+      bind_text : function (_para1:Psqlite3_stmt; _para2:cint; _para3:pcchar; n:cint; _para5:sqlite3_destructor_type):cint;cdecl;
+      bind_text16 : function (_para1:Psqlite3_stmt; _para2:cint; _para3:pointer; _para4:cint; _para5:sqlite3_destructor_type):cint;cdecl;
+      bind_value : function (_para1:Psqlite3_stmt; _para2:cint; _para3:Psqlite3_value):cint;cdecl;
+      busy_handler : function (_para1:Psqlite3; _para2:busyhandler_callback; _para3:pointer):cint;cdecl;
+      busy_timeout : function (_para1:Psqlite3; ms:cint):cint;cdecl;
+      changes : function (_para1:Psqlite3):cint;cdecl;
+      close : function (_para1:Psqlite3):cint;cdecl;
+      collation_needed : function (_para1:Psqlite3; _para2:pointer; _para3:collation_needed_cb):cint;cdecl;
+      collation_needed16 : function (_para1:Psqlite3; _para2:pointer; _para3:collation_needed_cb):cint;cdecl;
+      column_blob : function (_para1:Psqlite3_stmt; iCol:cint):pointer;cdecl;
+      column_bytes : function (_para1:Psqlite3_stmt; iCol:cint):cint;cdecl;
+      column_bytes16 : function (_para1:Psqlite3_stmt; iCol:cint):cint;cdecl;
+      column_count : function (pStmt:Psqlite3_stmt):cint;cdecl;
+      column_database_name : function (_para1:Psqlite3_stmt; _para2:cint):pcchar;cdecl;
+      column_database_name16 : function (_para1:Psqlite3_stmt; _para2:cint):pointer;cdecl;
+      column_decltype : function (_para1:Psqlite3_stmt; i:cint):pcchar;cdecl;
+      column_decltype16 : function (_para1:Psqlite3_stmt; _para2:cint):pointer;cdecl;
+      column_double : function (_para1:Psqlite3_stmt; iCol:cint):double;cdecl;
+      column_int : function (_para1:Psqlite3_stmt; iCol:cint):cint;cdecl;
+      column_int64 : function (_para1:Psqlite3_stmt; iCol:cint):sqlite_int64;cdecl;
+      column_name : function (_para1:Psqlite3_stmt; _para2:cint):pcchar;cdecl;
+      column_name16 : function (_para1:Psqlite3_stmt; _para2:cint):pointer;cdecl;
+      column_origin_name : function (_para1:Psqlite3_stmt; _para2:cint):pcchar;cdecl;
+      column_origin_name16 : function (_para1:Psqlite3_stmt; _para2:cint):pointer;cdecl;
+      column_table_name : function (_para1:Psqlite3_stmt; _para2:cint):pcchar;cdecl;
+      column_table_name16 : function (_para1:Psqlite3_stmt; _para2:cint):pointer;cdecl;
+      column_text : function (_para1:Psqlite3_stmt; iCol:cint):pcuchar;cdecl;
+      column_text16 : function (_para1:Psqlite3_stmt; iCol:cint):pointer;cdecl;
+      column_type : function (_para1:Psqlite3_stmt; iCol:cint):cint;cdecl;
+      column_value : function (_para1:Psqlite3_stmt; iCol:cint):Psqlite3_value;cdecl;
+      commit_hook : function (_para1:Psqlite3; _para2:commit_callback; _para3:pointer):pointer;cdecl;
+      complete : function (sql:pcchar):cint;cdecl;
+      complete16 : function (sql:pointer):cint;cdecl;
+      create_collation : function (_para1:Psqlite3; _para2:pcchar; _para3:cint; _para4:pointer; _para5:xCompare):cint;cdecl;
+      create_collation16 : function (_para1:Psqlite3; _para2:pointer; _para3:cint; _para4:pointer; _para5:xCompare):cint;cdecl;
+      create_function : function (_para1:Psqlite3; _para2:pcchar; _para3:cint; _para4:cint; _para5:pointer; 
+                   xFunc:xFunc; xStep:xStep; xFinal:xFinal):cint;cdecl;
+      create_function16 : function (_para1:Psqlite3; _para2:pointer; _para3:cint; _para4:cint; _para5:pointer; 
+                   xFunc:xFunc; xStep:xStep; xFinal:xFinal):cint;cdecl;
+      create_module : function (_para1:Psqlite3; _para2:pcchar; _para3:Psqlite3_module; _para4:pointer):cint;cdecl;
+      data_count : function (pStmt:Psqlite3_stmt):cint;cdecl;
+      db_handle : function (_para1:Psqlite3_stmt):Psqlite3;cdecl;
+      declare_vtab : function (_para1:Psqlite3; _para2:pcchar):cint;cdecl;
+      enable_shared_cache : function (_para1:cint):cint;cdecl;
+      errcode : function (db:Psqlite3):cint;cdecl;
+      errmsg : function (_para1:Psqlite3):pcchar;cdecl;
+      errmsg16 : function (_para1:Psqlite3):pointer;cdecl;
+      exec : function (_para1:Psqlite3; _para2:pcchar; _para3:sqlite3_callback; _para4:pointer; _para5:Ppcchar):cint;cdecl;
+      expired : function (_para1:Psqlite3_stmt):cint;cdecl;
+      finalize : function (pStmt:Psqlite3_stmt):cint;cdecl;
+      free : procedure;cdecl;
+      free_table : procedure (result:Ppcchar);cdecl;
+      get_autocommit : function (_para1:Psqlite3):cint;cdecl;
+      get_auxdata : function (_para1:Psqlite3_context; _para2:cint):pointer;cdecl;
+      get_table : function (_para1:Psqlite3; _para2:pcchar; _para3:PPpcchar; _para4:pcint; _para5:pcint; 
+                   _para6:Ppcchar):cint;cdecl;
+      global_recover : function :cint;cdecl;
+      interruptx : procedure (_para1:Psqlite3);cdecl;
+      last_insert_rowid : function (_para1:Psqlite3):sqlite_int64;cdecl;
+      libversion : function :pcchar;cdecl;
+      libversion_number : function :cint;cdecl;
+      malloc : function (_para1:cint):pointer;cdecl;
+      mprintf : function (_para1:pcchar; args:array of const):pcchar;cdecl;
+      open : function (_para1:pcchar; _para2:PPsqlite3):cint;cdecl;
+      open16 : function (_para1:pointer; _para2:PPsqlite3):cint;cdecl;
+      prepare : function (_para1:Psqlite3; _para2:pcchar; _para3:cint; _para4:PPsqlite3_stmt; _para5:Ppcchar):cint;cdecl;
+      prepare16 : function (_para1:Psqlite3; _para2:pointer; _para3:cint; _para4:PPsqlite3_stmt; _para5:Ppointer):cint;cdecl;
+      profile : function (_para1:Psqlite3; _para2:xProfile; _para3:pointer):pointer;cdecl;
+      progress_handler : procedure (_para1:Psqlite3; _para2:cint; _para3:commit_callback; _para4:pointer);cdecl;
+      realloc : function:pointer;cdecl;
+      reset : function (pStmt:Psqlite3_stmt):cint;cdecl;
+      result_blob : procedure (_para1:Psqlite3_context; _para2:pointer; _para3:cint; _para4:sqlite3_destructor_type);cdecl;
+      result_double : procedure (_para1:Psqlite3_context; _para2:double);cdecl;
+      result_error : procedure (_para1:Psqlite3_context; _para2:pcchar; _para3:cint);cdecl;
+      result_error16 : procedure (_para1:Psqlite3_context; _para2:pointer; _para3:cint);cdecl;
+      result_int : procedure (_para1:Psqlite3_context; _para2:cint);cdecl;
+      result_int64 : procedure (_para1:Psqlite3_context; _para2:sqlite_int64);cdecl;
+      result_null : procedure (_para1:Psqlite3_context);cdecl;
+      result_text : procedure (_para1:Psqlite3_context; _para2:pcchar; _para3:cint; _para4:sqlite3_destructor_type);cdecl;
+      result_text16 : procedure (_para1:Psqlite3_context; _para2:pointer; _para3:cint; _para4:sqlite3_destructor_type);cdecl;
+      result_text16be : procedure (_para1:Psqlite3_context; _para2:pointer; _para3:cint; _para4:sqlite3_destructor_type);cdecl;
+      result_text16le : procedure (_para1:Psqlite3_context; _para2:pointer; _para3:cint; _para4:sqlite3_destructor_type);cdecl;
+      result_value : procedure (_para1:Psqlite3_context; _para2:Psqlite3_value);cdecl;
+      rollback_hook : function (_para1:Psqlite3; _para2:sqlite3_destructor_type; _para3:pointer):pointer;cdecl;
+      set_authorizer : function (_para1:Psqlite3; _para2:xAuth; _para3:pointer):cint;cdecl;
+      set_auxdata : procedure (_para1:Psqlite3_context; _para2:cint; _para3:pointer; _para4:sqlite3_destructor_type);cdecl;
+      xsnprintf : function (_para1:cint; _para2:pcchar; _para3:pcchar; args:array of const):pcchar;cdecl;
+      step : function (_para1:Psqlite3_stmt):cint;cdecl;
+      table_column_metadata : function (_para1:Psqlite3; _para2:pcchar; _para3:pcchar; _para4:pcchar; _para5:Ppcchar; 
+                   _para6:Ppcchar; _para7:pcint; _para8:pcint; _para9:pcint):cint;cdecl;
+      thread_cleanup : procedure ;cdecl;
+      total_changes : function (_para1:Psqlite3):cint;cdecl;
+      trace : function (_para1:Psqlite3; xTrace:xTrace; _para3:pointer):pointer;cdecl;
+      transfer_bindings : function (_para1:Psqlite3_stmt; _para2:Psqlite3_stmt):cint;cdecl;
+      update_hook : function (_para1:Psqlite3; _para2:update_callback; _para3:pointer):pointer;cdecl;
+      user_data : function (_para1:Psqlite3_context):pointer;cdecl;
+      value_blob : function (_para1:Psqlite3_value):pointer;cdecl;
+      value_bytes : function (_para1:Psqlite3_value):cint;cdecl;
+      value_bytes16 : function (_para1:Psqlite3_value):cint;cdecl;
+      value_double : function (_para1:Psqlite3_value):double;cdecl;
+      value_int : function (_para1:Psqlite3_value):cint;cdecl;
+      value_int64 : function (_para1:Psqlite3_value):sqlite_int64;cdecl;
+      value_numeric_type : function (_para1:Psqlite3_value):cint;cdecl;
+      value_text : function (_para1:Psqlite3_value):pcuchar;cdecl;
+      value_text16 : function (_para1:Psqlite3_value):pointer;cdecl;
+      value_text16be : function (_para1:Psqlite3_value):pointer;cdecl;
+      value_text16le : function (_para1:Psqlite3_value):pointer;cdecl;
+      value_type : function (_para1:Psqlite3_value):cint;cdecl;
+      vmprintf : function (_para1:pcchar; _para2:va_list):pcchar;cdecl;
+      overload_function : function (_para1:Psqlite3; zFuncName:pcchar; nArg:cint):cint;cdecl;
+      prepare_v2 : function (_para1:Psqlite3; _para2:pcchar; _para3:cint; _para4:PPsqlite3_stmt; _para5:Ppcchar):cint;cdecl;
+      prepare16_v2 : function (_para1:Psqlite3; _para2:pointer; _para3:cint; _para4:PPsqlite3_stmt; _para5:Ppointer):cint;cdecl;
+      clear_bindings : function (_para1:Psqlite3_stmt):cint;cdecl;
+      create_module_v2 : function (_para1:Psqlite3; _para2:pcchar; _para3:Psqlite3_module; _para4:pointer; xDestroy:sqlite3_destructor_type):cint;cdecl;
+      bind_zeroblob : function (_para1:Psqlite3_stmt; _para2:cint; _para3:cint):cint;cdecl;
+      blob_bytes : function (_para1:Psqlite3_blob):cint;cdecl;
+      blob_close : function (_para1:Psqlite3_blob):cint;cdecl;
+      blob_open : function (_para1:Psqlite3; _para2:pcchar; _para3:pcchar; _para4:pcchar; _para5:sqlite3_int64; 
+                   _para6:cint; _para7:PPsqlite3_blob):cint;cdecl;
+      blob_read : function (_para1:Psqlite3_blob; _para2:pointer; _para3:cint; _para4:cint):cint;cdecl;
+      blob_write : function (_para1:Psqlite3_blob; _para2:pointer; _para3:cint; _para4:cint):cint;cdecl;
+      create_collation_v2 : function (_para1:Psqlite3; _para2:pcchar; _para3:cint; _para4:pointer; _para5:xCompare; 
+                   _para6:sqlite3_destructor_type):cint;cdecl;
+      file_control : function (_para1:Psqlite3; _para2:pcchar; _para3:cint; _para4:pointer):cint;cdecl;
+      memory_highwater : function (_para1:cint):sqlite3_int64;cdecl;
+      memory_used : function :sqlite3_int64;cdecl;
+      mutex_alloc : function (_para1:cint):Psqlite3_mutex;cdecl;
+      mutex_enter : procedure (_para1:Psqlite3_mutex);cdecl;
+      mutex_free : procedure (_para1:Psqlite3_mutex);cdecl;
+      mutex_leave : procedure (_para1:Psqlite3_mutex);cdecl;
+      mutex_try : function (_para1:Psqlite3_mutex):cint;cdecl;
+      open_v2 : function (_para1:pcchar; _para2:PPsqlite3; _para3:cint; _para4:pcchar):cint;cdecl;
+      release_memory : function (_para1:cint):cint;cdecl;
+      result_error_nomem : procedure (_para1:Psqlite3_context);cdecl;
+      result_error_toobig : procedure (_para1:Psqlite3_context);cdecl;
+      sleep : function (_para1:cint):cint;cdecl;
+      soft_heap_limit : procedure (_para1:cint);cdecl;
+      vfs_find : function (_para1:pcchar):Psqlite3_vfs;cdecl;
+      vfs_register : function (_para1:Psqlite3_vfs; _para2:cint):cint;cdecl;
+      vfs_unregister : function (_para1:Psqlite3_vfs):cint;cdecl;
+      xthreadsafe : function :cint;cdecl;
+      result_zeroblob : procedure (_para1:Psqlite3_context; _para2:cint);cdecl;
+      result_error_code : procedure (_para1:Psqlite3_context; _para2:cint);cdecl;
+      test_control : function (_para1:cint; args:array of const):cint;cdecl;
+      randomness : procedure (_para1:cint; _para2:pointer);cdecl;
+      context_db_handle : function (_para1:Psqlite3_context):Psqlite3;cdecl;
+      extended_result_codes : function (_para1:Psqlite3; _para2:cint):cint;cdecl;
+      limit : function (_para1:Psqlite3; _para2:cint; _para3:cint):cint;cdecl;
+      next_stmt : function (_para1:Psqlite3; _para2:Psqlite3_stmt):Psqlite3_stmt;cdecl;
+      sql : function (_para1:Psqlite3_stmt):pcchar;cdecl;
+      status : function (_para1:cint; _para2:pcint; _para3:pcint; _para4:cint):cint;cdecl;
+      backup_finish : function (_para1:Psqlite3backup):cint;cdecl;
+      backup_init : function (_para1:Psqlite3; _para2:pcchar; _para3:Psqlite3; _para4:pcchar):Psqlite3backup;cdecl;
+      backup_pagecount : function (_para1:Psqlite3backup):cint;cdecl;
+      backup_remaining : function (_para1:Psqlite3backup):cint;cdecl;
+      backup_step : function (_para1:Psqlite3backup; _para2:cint):cint;cdecl;
+      compileoption_get : function (_para1:cint):pcchar;cdecl;
+      compileoption_used : function (_para1:pcchar):cint;cdecl;
+      create_function_v2 : function (_para1:Psqlite3; _para2:pcchar; _para3:cint; _para4:cint; _para5:pointer; 
+                   xFunc:xFunc; xStep:xStep; xFinal:xFinal; xDestroy:sqlite3_destructor_type):cint;cdecl;
+      db_config : function (_para1:Psqlite3; _para2:cint; args:array of const):cint;cdecl;
+      db_mutex : function (_para1:Psqlite3):Psqlite3_mutex;cdecl;
+      db_status : function (_para1:Psqlite3; _para2:cint; _para3:pcint; _para4:pcint; _para5:cint):cint;cdecl;
+      extended_errcode : function (_para1:Psqlite3):cint;cdecl;
+      log : procedure (_para1:cint; _para2:pcchar; args:array of const);cdecl;
+      soft_heap_limit64 : function (_para1:sqlite3_int64):sqlite3_int64;cdecl;
+      sourceid : function :pcchar;cdecl;
+      stmt_status : function (_para1:Psqlite3_stmt; _para2:cint; _para3:cint):cint;cdecl;
+      strnicmp : function (_para1:pcchar; _para2:pcchar; _para3:cint):cint;cdecl;
+      unlock_notify : function (_para1:Psqlite3; _para2:xNotifycb; _para3:pointer):cint;cdecl;
+      wal_autocheckpoint : function (_para1:Psqlite3; _para2:cint):cint;cdecl;
+      wal_checkpoint : function (_para1:Psqlite3; _para2:pcchar):cint;cdecl;
+      wal_hook : function (_para1:Psqlite3; _para2:wal_hook_cb; _para3:pointer):pointer;cdecl;
+      blob_reopen : function (_para1:Psqlite3_blob; _para2:sqlite3_int64):cint;cdecl;
+      vtab_config : function (_para1:Psqlite3; op:cint; args:array of const):cint;cdecl;
+      vtab_on_conflict : function (_para1:Psqlite3):cint;cdecl;
+      close_v2 : function (_para1:Psqlite3):cint;cdecl;
+      db_filename : function (_para1:Psqlite3; _para2:pcchar):pcchar;cdecl;
+      db_readonly : function (_para1:Psqlite3; _para2:pcchar):cint;cdecl;
+      db_release_memory : function (_para1:Psqlite3):cint;cdecl;
+      errstr : function (_para1:cint):pcchar;cdecl;
+      stmt_busy : function (_para1:Psqlite3_stmt):cint;cdecl;
+      stmt_readonly : function (_para1:Psqlite3_stmt):cint;cdecl;
+      stricmp : function (_para1:pcchar; _para2:pcchar):cint;cdecl;
+      uri_boolean : function (_para1:pcchar; _para2:pcchar; _para3:cint):cint;cdecl;
+      uri_int64 : function (_para1:pcchar; _para2:pcchar; _para3:sqlite3_int64):sqlite3_int64;cdecl;
+      uri_parameter : function (_para1:pcchar; _para2:pcchar):pcchar;cdecl;
+      xvsnprintf : function (_para1:cint; _para2:pcchar; _para3:pcchar; _para4:va_list):pcchar;cdecl;
+      wal_checkpoint_v2 : function (_para1:Psqlite3; _para2:pcchar; _para3:cint; _para4:pcint; _para5:pcint):cint;cdecl;
+      auto_extension : function (_para1:pointer ):cint;cdecl;
+      bind_blob64 : function (_para1:Psqlite3_stmt; _para2:cint; _para3:pointer; _para4:sqlite3_uint64; _para5:sqlite3_destructor_type):cint;cdecl;
+      bind_text64 : function (_para1:Psqlite3_stmt; _para2:cint; _para3:pcchar; _para4:sqlite3_uint64; _para5:sqlite3_destructor_type; 
+                   _para6:cuchar):cint;cdecl;
+      cancel_auto_extension : function (_para1:pointer ):cint;cdecl;
+      load_extension : function (_para1:Psqlite3; _para2:pcchar; _para3:pcchar; _para4:Ppcchar):cint;cdecl;
+      malloc64 : function (_para1:sqlite3_uint64):pointer;cdecl;
+      msize : function (_para1:pointer):sqlite3_uint64;cdecl;
+      realloc64 : function (_para1:pointer; _para2:sqlite3_uint64):pointer;cdecl;
+      reset_auto_extension : procedure ;cdecl;
+      result_blob64 : procedure (_para1:Psqlite3_context; _para2:pointer; _para3:sqlite3_uint64; _para4:sqlite3_destructor_type);cdecl;
+      result_text64 : procedure (_para1:Psqlite3_context; _para2:pcchar; _para3:sqlite3_uint64; _para4:sqlite3_destructor_type; _para5:cuchar);cdecl;
+      strglob : function (_para1:pcchar; _para2:pcchar):cint;cdecl;
+      value_dup : function (_para1:Psqlite3_value):Psqlite3_value;cdecl;
+      value_free : procedure (_para1:Psqlite3_value);cdecl;
+      result_zeroblob64 : function (_para1:Psqlite3_context; _para2:sqlite3_uint64):cint;cdecl;
+      bind_zeroblob64 : function (_para1:Psqlite3_stmt; _para2:cint; _para3:sqlite3_uint64):cint;cdecl;
+      value_subtype : function (_para1:Psqlite3_value):cuint;cdecl;
+      result_subtype : procedure (_para1:Psqlite3_context; _para2:cuint);cdecl;
+      status64 : function (_para1:cint; _para2:Psqlite3_int64; _para3:Psqlite3_int64; _para4:cint):cint;cdecl;
+      strlike : function (_para1:pcchar; _para2:pcchar; _para3:cuint):cint;cdecl;
+      db_cacheflush : function (_para1:Psqlite3):cint;cdecl;
+      system_errno : function (_para1:Psqlite3):cint;cdecl;
+      trace_v2 : function (_para1:Psqlite3; _para2:cunsigned; _para3:xCallback; _para4:pointer):cint;cdecl;
+      expanded_sql : function (_para1:Psqlite3_stmt):pcchar;cdecl;
+      set_last_insert_rowid : procedure (_para1:Psqlite3; _para2:sqlite3_int64);cdecl;
+      prepare_v3 : function (_para1:Psqlite3; _para2:pcchar; _para3:cint; _para4:cuint; _para5:PPsqlite3_stmt; 
+                   _para6:Ppcchar):cint;cdecl;
+      prepare16_v3 : function (_para1:Psqlite3; _para2:pointer; _para3:cint; _para4:cuint; _para5:PPsqlite3_stmt; 
+                   _para6:Ppointer):cint;cdecl;
+      bind_pointer : function (_para1:Psqlite3_stmt; _para2:cint; _para3:pointer; _para4:pcchar; _para5:sqlite3_destructor_type):cint;cdecl;
+      result_pointer : procedure (_para1:Psqlite3_context; _para2:pointer; _para3:pcchar; _para4:sqlite3_destructor_type);cdecl;
+      value_pointer : function (_para1:Psqlite3_value; _para2:pcchar):pointer;cdecl;
+      vtab_nochange : function (_para1:Psqlite3_context):cint;cdecl;
+      value_nochange : function (_para1:Psqlite3_value):cint;cdecl;
+      vtab_collation : function (_para1:Psqlite3_index_info; _para2:cint):pcchar;cdecl;
+    end;
+
+// These are no-ops.
+procedure SQLITE_EXTENSION_INIT1;
+procedure SQLITE_EXTENSION_INIT3;
+
+// This is actually unnecessary, but is provided for compatibility with sqlite3ext tutorial.
+
+Var
+  sqlite3_api : Psqlite3_api_routines;
+  
+procedure SQLITE_EXTENSION_INIT2(v: Psqlite3_api_routines);
+
+implementation
+
+procedure SQLITE_EXTENSION_INIT1;
+begin
+end;
+
+procedure SQLITE_EXTENSION_INIT2(v: Psqlite3_api_routines);
+begin
+  sqlite3_api:=v;
+end;
+
+procedure SQLITE_EXTENSION_INIT3;
+begin
+
+end;
+
+end.

+ 4 - 4
utils/tply/lexbase.pas

@@ -969,7 +969,7 @@ function path(filename : String) : String;
   var i : Integer;
   var i : Integer;
   begin
   begin
     i := length(filename);
     i := length(filename);
-    while (i>0) and (filename[i]<>'\') and (filename[i]<>':') do
+    while (i>0) and (filename[i]<>DirectorySeparator) and (filename[i]<>':') do
       dec(i);
       dec(i);
     path := copy(filename, 1, i);
     path := copy(filename, 1, i);
   end(*path*);
   end(*path*);
@@ -985,10 +985,10 @@ function root(filename : String) : String;
             root := copy(filename, 1, i-1);
             root := copy(filename, 1, i-1);
             exit
             exit
           end;
           end;
-        '\': exit;
+        DirectorySeparator : exit;
         else
         else
       end;
       end;
-  end(*addExt*);
+  end(*root*);
 function addExt(filename, ext : String) : String;
 function addExt(filename, ext : String) : String;
   (* implemented with goto for maximum efficiency *)
   (* implemented with goto for maximum efficiency *)
   label x;
   label x;
@@ -999,7 +999,7 @@ function addExt(filename, ext : String) : String;
     for i := length(filename) downto 1 do
     for i := length(filename) downto 1 do
       case filename[i] of
       case filename[i] of
         '.' : exit;
         '.' : exit;
-        '\': goto x;
+        DirectorySeparator: goto x;
         else
         else
       end;
       end;
     x : addExt := filename+'.'+ext
     x : addExt := filename+'.'+ext

+ 5 - 1
utils/tply/plex.pas

@@ -597,7 +597,11 @@ var i : Integer;
 
 
 begin
 begin
 {$ifdef Unix}
 {$ifdef Unix}
-  codfilepath1:='/usr/local/lib/fpc/lexyacc/';
+  codfilepath1:=path(paramstr(0));
+  if (codfilepath1<>'') then
+    codfilepath1:=codfilepath1+'../lib/fpc/lexyacc/'
+  else
+    codfilepath1:='/usr/local/lib/fpc/lexyacc/';
   codfilepath2:='/usr/lib/fpc/lexyacc/';
   codfilepath2:='/usr/lib/fpc/lexyacc/';
 {$else}
 {$else}
   codfilepath1:=path(paramstr(0));
   codfilepath1:=path(paramstr(0));

+ 5 - 1
utils/tply/pyacc.pas

@@ -2375,7 +2375,11 @@ var i : Integer;
 
 
 begin
 begin
 {$ifdef Unix}
 {$ifdef Unix}
-  codfilepath1:='/usr/local/lib/fpc/lexyacc/';
+  codfilepath1:=path(paramstr(0));
+  if (codfilepath1<>'') then
+    codfilepath1:=codfilepath1+'../lib/fpc/lexyacc/'
+  else
+    codfilepath1:='/usr/local/lib/fpc/lexyacc/';
   codfilepath2:='/usr/lib/fpc/lexyacc/';
   codfilepath2:='/usr/lib/fpc/lexyacc/';
 {$else}
 {$else}
   codfilepath1:=path(paramstr(0));
   codfilepath1:=path(paramstr(0));

+ 5 - 1
utils/tply/pyacc.y

@@ -711,7 +711,11 @@ var i : Integer;
 
 
 begin
 begin
 {$ifdef Unix}
 {$ifdef Unix}
-  codfilepath1:='/usr/local/lib/fpc/lexyacc/';
+  codfilepath1:=path(paramstr(0));
+  if (codfilepath1<>'') then
+    codfilepath1:=codfilepath1+'../lib/fpc/lexyacc/'
+  else
+    codfilepath1:='/usr/local/lib/fpc/lexyacc/';
   codfilepath2:='/usr/lib/fpc/lexyacc/';
   codfilepath2:='/usr/lib/fpc/lexyacc/';
 {$else}
 {$else}
   codfilepath1:=path(paramstr(0));
   codfilepath1:=path(paramstr(0));

+ 4 - 4
utils/tply/yaccbase.pas

@@ -640,7 +640,7 @@ function path(filename : String) : String;
   var i : Integer;
   var i : Integer;
   begin
   begin
     i := length(filename);
     i := length(filename);
-    while (i>0) and (filename[i]<>'\') and (filename[i]<>':') do
+    while (i>0) and (filename[i]<>DirectorySeparator) and (filename[i]<>':') do
       dec(i);
       dec(i);
     path := copy(filename, 1, i);
     path := copy(filename, 1, i);
   end(*path*);
   end(*path*);
@@ -656,10 +656,10 @@ function root(filename : String) : String;
             root := copy(filename, 1, i-1);
             root := copy(filename, 1, i-1);
             exit
             exit
           end;
           end;
-        '\': exit;
+        DirectorySeparator: exit;
         else
         else
       end;
       end;
-  end(*addExt*);
+  end(*root*);
 function addExt(filename, ext : String) : String;
 function addExt(filename, ext : String) : String;
   (* implemented with goto for maximum efficiency *)
   (* implemented with goto for maximum efficiency *)
   label x;
   label x;
@@ -670,7 +670,7 @@ function addExt(filename, ext : String) : String;
     for i := length(filename) downto 1 do
     for i := length(filename) downto 1 do
       case filename[i] of
       case filename[i] of
         '.' : exit;
         '.' : exit;
-        '\': goto x;
+        DirectorySeparator : goto x;
         else
         else
       end;
       end;
     x : addExt := filename+'.'+ext
     x : addExt := filename+'.'+ext