diff options
author | jonas <jonas@3ad0048d-3df7-0310-abae-a5850022a9f2> | 2018-12-24 22:12:19 +0000 |
---|---|---|
committer | jonas <jonas@3ad0048d-3df7-0310-abae-a5850022a9f2> | 2018-12-24 22:12:19 +0000 |
commit | a142ff06bcd482d496aa8c96d3294c651d31965a (patch) | |
tree | fdb916e044a395791a45a28d197d2e6c1764d6b8 | |
parent | 636ae0b1f820d20b64ccfc2146aa6e99783547cf (diff) | |
parent | 5654f1a2ebf9871ac052d7825076e468d01b52b9 (diff) | |
download | fpc-a142ff06bcd482d496aa8c96d3294c651d31965a.tar.gz |
* synchronised with trunk till r40635
git-svn-id: https://svn.freepascal.org/svn/fpc/branches/debug_eh@40636 3ad0048d-3df7-0310-abae-a5850022a9f2
38 files changed, 776 insertions, 181 deletions
diff --git a/compiler/arm/symcpu.pas b/compiler/arm/symcpu.pas index 926ef4f581..54a9f2a563 100644 --- a/compiler/arm/symcpu.pas +++ b/compiler/arm/symcpu.pas @@ -101,7 +101,7 @@ type { library symbol for AROS } libsym : tsym; 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 deref; override; end; @@ -208,7 +208,7 @@ implementation end; - function tcpuprocdef.getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp): tstoreddef; + function tcpuprocdef.getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp; const paraprefix: string): tstoreddef; begin result:=inherited; if newtyp=procdef then diff --git a/compiler/blockutl.pas b/compiler/blockutl.pas index f4e2bfb91c..a5d5ae889f 100644 --- a/compiler/blockutl.pas +++ b/compiler/blockutl.pas @@ -207,7 +207,7 @@ implementation exit; end; { 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 } result.proccalloption:=pocall_cdecl; { add po_is_block so that a block "self" pointer gets added (of the type diff --git a/compiler/hlcg2ll.pas b/compiler/hlcg2ll.pas index 58ce04a03d..fb82a6c89f 100644 --- a/compiler/hlcg2ll.pas +++ b/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_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 maketojumpboollabels(list: TAsmList; p: tnode; truelabel, falselabel: tasmlabel); override; @@ -1250,7 +1250,7 @@ implementation 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 reg : tregister; href : treference; diff --git a/compiler/hlcgobj.pas b/compiler/hlcgobj.pas index 6107966cb1..78bb6a643e 100644 --- a/compiler/hlcgobj.pas +++ b/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_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_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; { Retrieve the location of the data pointed to in location l, when the location is @@ -4100,7 +4100,7 @@ implementation 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 reg : tregister; href : treference; @@ -4145,6 +4145,7 @@ implementation l.size:=def_cgsize(newsize); location_freetemp(list,l); location_reset(l,LOC_MMREGISTER,l.size); + size:=newsize; l.register:=reg; end; end; diff --git a/compiler/i386/symcpu.pas b/compiler/i386/symcpu.pas index 1246fa8178..fef67511e8 100644 --- a/compiler/i386/symcpu.pas +++ b/compiler/i386/symcpu.pas @@ -97,7 +97,7 @@ type { library symbol for AROS } libsym : tsym; 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 deref; override; end; @@ -203,7 +203,7 @@ implementation end; - function tcpuprocdef.getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp): tstoreddef; + function tcpuprocdef.getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp; const paraprefix: string): tstoreddef; begin result:=inherited; if newtyp=procdef then diff --git a/compiler/i8086/symcpu.pas b/compiler/i8086/symcpu.pas index ff83bf0bc2..6f7c9b8cbb 100644 --- a/compiler/i8086/symcpu.pas +++ b/compiler/i8086/symcpu.pas @@ -110,7 +110,7 @@ type tcpuprocvardef = class(ti86procvardef) 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 ofs_address_type:tdef;override; function size:asizeint;override; @@ -133,7 +133,7 @@ type procedure Setinterfacedef(AValue: boolean);override; public 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 ofs_address_type:tdef;override; function size:asizeint;override; @@ -334,7 +334,7 @@ implementation end; - function tcpuprocdef.getcopyas(newtyp:tdeftyp;copytyp:tproccopytyp):tstoreddef; + function tcpuprocdef.getcopyas(newtyp:tdeftyp;copytyp:tproccopytyp;const paraprefix:string):tstoreddef; begin result:=inherited; if is_far then @@ -428,7 +428,7 @@ implementation end; - function tcpuprocvardef.getcopyas(newtyp:tdeftyp;copytyp:tproccopytyp):tstoreddef; + function tcpuprocvardef.getcopyas(newtyp:tdeftyp;copytyp:tproccopytyp;const paraprefix:string):tstoreddef; begin result:=inherited; if is_far then diff --git a/compiler/jvm/pjvm.pas b/compiler/jvm/pjvm.pas index 698b4feac4..75b73d6c3d 100644 --- a/compiler/jvm/pjvm.pas +++ b/compiler/jvm/pjvm.pas @@ -505,7 +505,7 @@ implementation { add a method to call the procvar using unwrapped arguments, which 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); insert_self_and_vmt_para(methoddef); insert_funcret_para(methoddef); @@ -540,7 +540,7 @@ implementation { add a method prototype matching the procvar (like the invoke in the procvarclass itself) } 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); insert_self_and_vmt_para(methoddef); insert_funcret_para(methoddef); @@ -639,7 +639,7 @@ implementation wrapperpd.synthetickind:=tsk_jvm_virtual_clmethod; wrapperpd.skpara:=pd; { 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; { no use in creating a callback wrapper here, this procvar type isn't for public consumption } @@ -667,7 +667,7 @@ implementation { wrapper is part of the same symtable as the original procdef } symtablestack.push(pd.owner); { 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 } include(wrapperpd.procoptions,po_classmethod); wrapperpd.proctypeoption:=potype_function; diff --git a/compiler/llvm/nllvmcal.pas b/compiler/llvm/nllvmcal.pas index 4d35cf8063..6f13103e43 100644 --- a/compiler/llvm/nllvmcal.pas +++ b/compiler/llvm/nllvmcal.pas @@ -27,7 +27,7 @@ interface uses parabase, - ncgcal, + ncal,ncgcal, cgutils; type @@ -38,6 +38,7 @@ interface tllvmcallnode = class(tcgcallnode) protected + function paraneedsinlinetemp(para: tcallparanode; const pushconstaddr, complexpara: boolean): boolean; override; function can_call_ref(var ref: treference): boolean; override; procedure pushparas; override; end; @@ -47,7 +48,7 @@ implementation uses verbose, - ncal; + symconst,symdef; {***************************************************************************** TLLVMCALLPARANODE @@ -64,6 +65,25 @@ implementation 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; begin result:=false; diff --git a/compiler/llvm/nllvmcnv.pas b/compiler/llvm/nllvmcnv.pas index 27e815de8c..53e1014761 100644 --- a/compiler/llvm/nllvmcnv.pas +++ b/compiler/llvm/nllvmcnv.pas @@ -80,7 +80,7 @@ class function tllvmtypeconvnode.target_specific_need_equal_typeconv(fromdef, to result:= (fromdef<>todef) and { two procdefs that are structurally the same but semantically different - still need a convertion } + still need a conversion } ( ((fromdef.typ=procvardef) and (todef.typ=procvardef)) @@ -180,7 +180,7 @@ procedure tllvmtypeconvnode.second_proc_to_procvar; if location.loc<>LOC_REFERENCE then internalerror(2015111902); 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), location.reference); end; @@ -283,7 +283,7 @@ procedure tllvmtypeconvnode.second_nothing; hlcg.location_force_mem(current_asmdata.CurrAsmList,left.location,left.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); - 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); end else diff --git a/compiler/llvm/nllvmld.pas b/compiler/llvm/nllvmld.pas index 6f7455301c..d5d0aa22ed 100644 --- a/compiler/llvm/nllvmld.pas +++ b/compiler/llvm/nllvmld.pas @@ -90,7 +90,7 @@ procedure tllvmloadnode.pass_generate_code; (resultdef.typ in [symconst.procdef,procvardef]) and not tabstractprocdef(resultdef).is_addressonly then begin - pvdef:=tprocvardef(procdef.getcopyas(procvardef,pc_normal)); + pvdef:=tprocvardef(procdef.getcopyas(procvardef,pc_normal,'')); { on little endian, location.register contains proc and location.registerhi contains self; on big endian, it's the other way around } diff --git a/compiler/m68k/symcpu.pas b/compiler/m68k/symcpu.pas index 73f1bd04ee..8920d27629 100644 --- a/compiler/m68k/symcpu.pas +++ b/compiler/m68k/symcpu.pas @@ -97,7 +97,7 @@ type { library symbol for AmigaOS/MorphOS } libsym : tsym; 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 deref; override; end; @@ -203,7 +203,7 @@ implementation end; - function tcpuprocdef.getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp): tstoreddef; + function tcpuprocdef.getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp; const paraprefix: string): tstoreddef; begin result:=inherited; if newtyp=procdef then diff --git a/compiler/ncal.pas b/compiler/ncal.pas index a7cbe3b7ad..2eb6fc33f0 100644 --- a/compiler/ncal.pas +++ b/compiler/ncal.pas @@ -108,6 +108,7 @@ interface it's not strictly necessary) for speed and code size reasons. 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; procedure createinlineparas; procedure wrapcomplexinlinepara(para: tcallparanode); virtual; @@ -4624,98 +4625,98 @@ implementation 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; var tempnode: ttempcreatenode; realtarget: tnode; paracomplexity: longint; 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 result:=false; { 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 contents to that temp and then substitute the parameter with the temp everywhere in the function } - if needtemp then + if paraneedsinlinetemp(para,pushconstaddr,complexpara) then begin tempnode:=ctempcreatenode.create(para.parasym.vardef,para.parasym.vardef.size, tt_persistent,tparavarsym(para.parasym).is_regvar(false)); diff --git a/compiler/ncgcnv.pas b/compiler/ncgcnv.pas index 217dd4c850..54ffefbd38 100644 --- a/compiler/ncgcnv.pas +++ b/compiler/ncgcnv.pas @@ -423,10 +423,10 @@ interface case tstringdef(resultdef).stringtype of st_shortstring : 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; hlcg.g_ptrtypecast_ref(current_asmdata.CurrAsmList, - cpointerdef.getreusable(cshortstringtype), + cpointerdef.getreusable(resultdef), cpointerdef.getreusable(left.resultdef),tmpref); hlcg.a_load_loc_ref(current_asmdata.CurrAsmList,left.resultdef,left.resultdef,left.location, tmpref); @@ -574,7 +574,7 @@ interface begin location.register:=hlcg.getaddressregister(current_asmdata.CurrAsmList,resultdef); { 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); end; LOC_REGISTER,LOC_CREGISTER: diff --git a/compiler/ncgnstld.pas b/compiler/ncgnstld.pas index 85283aaa8f..4e016f7f5b 100644 --- a/compiler/ncgnstld.pas +++ b/compiler/ncgnstld.pas @@ -106,8 +106,8 @@ implementation the parentfpstruct inside the routine in which they were originally declared, except in the initialisation code for 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 { get struct holding all locals accessed by nested routines } nestedvars:=tprocdef(symtable.defowner).parentfpstruct; @@ -142,7 +142,6 @@ implementation var thissym, nestedvars: tsym; - nestedvarsdef: tdef; begin result:=inherited; if assigned(result) then @@ -153,11 +152,8 @@ implementation begin { Nested variable? Then we have to move it to a structure that 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 { get struct holding all locals accessed by nested routines } nestedvars:=tprocdef(symtable.defowner).parentfpstruct; @@ -167,7 +163,6 @@ implementation build_parentfpstruct(tprocdef(symtable.defowner)); nestedvars:=tprocdef(symtable.defowner).parentfpstruct; end; - nestedvarsdef:=tlocalvarsym(nestedvars).vardef; if nestedvars<>symtableentry then thissym:=nestsym else @@ -185,7 +180,7 @@ implementation left:=csubscriptnode.create(thissym,cderefnode.create(left)); firstpass(left); include(flags,nf_internal); - end; + end; end; end; end; diff --git a/compiler/ncgutil.pas b/compiler/ncgutil.pas index 5cca991e99..990d0924a2 100644 --- a/compiler/ncgutil.pas +++ b/compiler/ncgutil.pas @@ -1814,9 +1814,11 @@ implementation begin { can't free the result, because we load it after 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 - (([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); end; end; diff --git a/compiler/ncnv.pas b/compiler/ncnv.pas index 0156f31224..6cb539133a 100644 --- a/compiler/ncnv.pas +++ b/compiler/ncnv.pas @@ -350,7 +350,8 @@ implementation if equal_defs(p.resultdef,def) and (p.resultdef.typ=def.typ) 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 { don't replace encoded string constants to rawbytestring encoding. preserve the codepage } @@ -2268,7 +2269,7 @@ implementation copytype:=pc_address_only else copytype:=pc_normal; - resultdef:=pd.getcopyas(procvardef,copytype); + resultdef:=pd.getcopyas(procvardef,copytype,''); end; end; @@ -2434,7 +2435,8 @@ implementation {$ifdef llvm} { we still may have to insert a type conversion at the 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 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 diff --git a/compiler/ninl.pas b/compiler/ninl.pas index 4de11c3c73..60e51efe2e 100644 --- a/compiler/ninl.pas +++ b/compiler/ninl.pas @@ -4378,7 +4378,7 @@ implementation 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 } node_reset_flags(newstatement.statement,[nf_pass1_done]); { firstpass it } diff --git a/compiler/powerpc/symcpu.pas b/compiler/powerpc/symcpu.pas index cd06ccd0b3..55284fe42f 100644 --- a/compiler/powerpc/symcpu.pas +++ b/compiler/powerpc/symcpu.pas @@ -97,7 +97,7 @@ type { library symbol for AmigaOS/MorphOS } libsym : tsym; 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 deref; override; end; @@ -203,7 +203,7 @@ implementation end; - function tcpuprocdef.getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp): tstoreddef; + function tcpuprocdef.getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp; const paraprefix: string): tstoreddef; begin result:=inherited; if newtyp=procdef then diff --git a/compiler/symcreat.pas b/compiler/symcreat.pas index 502abc9614..bea2d0d21c 100644 --- a/compiler/symcreat.pas +++ b/compiler/symcreat.pas @@ -515,7 +515,7 @@ implementation end; - procedure addvisibibleparameters(var str: ansistring; pd: tprocdef); + procedure addvisibleparameters(var str: ansistring; pd: tprocdef); var currpara: tparavarsym; i: longint; @@ -530,7 +530,7 @@ implementation if not firstpara then str:=str+','; firstpara:=false; - str:=str+currpara.realname; + str:=str+'&'+currpara.realname; end; end; end; @@ -554,7 +554,7 @@ implementation mnetion this program/unit name to avoid accidentally calling other same-named routines that may be in scope } str:=str+def_unit_name_prefix_if_toplevel(callpd)+callpd.procsym.realname+'('; - addvisibibleparameters(str,pd); + addvisibleparameters(str,pd); str:=str+') end;'; str_parse_method_impl(str,pd,isclassmethod); end; @@ -862,7 +862,7 @@ implementation not is_void(pd.returndef) then str:=str+'result:='; str:=str+'pv('; - addvisibibleparameters(str,pd); + addvisibleparameters(str,pd); str:=str+') end;'; str_parse_method_impl(str,pd,true) end; @@ -964,7 +964,7 @@ implementation if pd.returndef<>voidtype then str:=str+'result:='; 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_parse_method_impl(str,pd,false); end; @@ -988,8 +988,8 @@ implementation { now call through to the actual method } if pd.returndef<>voidtype then str:=str+'result:='; - str:=str+callthroughpd.procsym.realname+'('; - addvisibibleparameters(str,callthroughpd); + str:=str+'&'+callthroughpd.procsym.realname+'('; + addvisibleparameters(str,pd); str:=str+') end;'; { add dummy file info so we can step in/through it } 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; sk: tsynthetickind; skpara: pointer): tprocdef; 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 } result.setmangledname(newmangledname); { finish creating the copy } @@ -1481,7 +1484,10 @@ implementation because there may already be references to the mangled name for the 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); newpd.procoptions:=newpd.procoptions+orgpd.procoptions*[po_external,po_has_importname,po_has_importdll]; newpd.import_name:=orgpd.import_name; @@ -1493,6 +1499,9 @@ implementation newpd.setmangledname(newname); finish_copied_procdef(newpd,'__FPC_IMPL_EXTERNAL_REDIRECT_'+newname,current_module.localsymtable,nil); 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.synthetickind:=tsk_callthrough; orgpd.procoptions:=orgpd.procoptions-[po_external,po_has_importname,po_has_importdll]; diff --git a/compiler/symdef.pas b/compiler/symdef.pas index 2a60ab2f5f..f7baf3b16c 100644 --- a/compiler/symdef.pas +++ b/compiler/symdef.pas @@ -630,7 +630,7 @@ interface function is_addressonly:boolean;virtual; function no_self_node:boolean; { 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; procedure check_mark_as_nested; procedure init_paraloc_info(side: tcallercallee); @@ -668,7 +668,7 @@ interface function is_methodpointer:boolean;override; function is_addressonly:boolean;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; tprocvardefclass = class of tprocvardef; @@ -813,7 +813,7 @@ interface needs to be finalised afterwards by calling 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 GetTypeName : string;override; function mangledname : TSymStr; virtual; @@ -5154,7 +5154,7 @@ implementation end; - function tabstractprocdef.getcopyas(newtyp:tdeftyp;copytyp:tproccopytyp): tstoreddef; + function tabstractprocdef.getcopyas(newtyp:tdeftyp;copytyp:tproccopytyp; const paraprefix: string): tstoreddef; var j, nestinglevel: longint; pvs, npvs: tparavarsym; @@ -5187,8 +5187,15 @@ implementation if (copytyp=pc_bareproc) and (([vo_is_self,vo_is_vmt,vo_is_parentfp,vo_is_result,vo_is_funcret]*pvs.varoptions)<>[]) then 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; tabstractprocdef(result).parast.insert(npvs); end; @@ -6070,11 +6077,11 @@ implementation end; - function tprocdef.getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp): tstoreddef; + function tprocdef.getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp; const paraprefix: string): tstoreddef; var j : longint; begin - result:=inherited getcopyas(newtyp,copytyp); + result:=inherited; if newtyp=procvardef then begin { create new paralist } @@ -6141,7 +6148,7 @@ implementation function tprocdef.getcopy: tstoreddef; begin - result:=getcopyas(procdef,pc_normal); + result:=getcopyas(procdef,pc_normal,''); end; @@ -6504,7 +6511,7 @@ implementation { do not simply push/pop current_module.localsymtable, because that can have side-effects (e.g., it removes helpers) } 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); { res^.Data may still be nil -> don't overwrite result } exit; @@ -6643,7 +6650,7 @@ implementation end; - function tprocvardef.getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp): tstoreddef; + function tprocvardef.getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp; const paraprefix: string): tstoreddef; begin result:=inherited; tabstractprocdef(result).calcparas; diff --git a/compiler/x86_64/symcpu.pas b/compiler/x86_64/symcpu.pas index e6d15ba87e..a2c9ddd79e 100644 --- a/compiler/x86_64/symcpu.pas +++ b/compiler/x86_64/symcpu.pas @@ -97,7 +97,7 @@ type { library symbol for AROS } libsym : tsym; 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 deref; override; end; @@ -203,7 +203,7 @@ implementation end; - function tcpuprocdef.getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp): tstoreddef; + function tcpuprocdef.getcopyas(newtyp: tdeftyp; copytyp: tproccopytyp; const paraprefix: string): tstoreddef; begin result:=inherited; if newtyp=procdef then diff --git a/packages/chm/src/chmcmd.lpr b/packages/chm/src/chmcmd.lpr index f6259e1c50..be56490dee 100644 --- a/packages/chm/src/chmcmd.lpr +++ b/packages/chm/src/chmcmd.lpr @@ -26,7 +26,7 @@ uses {$ifdef Unix}cthreads,{$endif} Classes, Sysutils, chmfilewriter, GetOpts; Const - CHMCMDVersion = '3.1.1'; + CHMCMDVersion = {$I %FPCVERSION%}; Procedure Usage; diff --git a/packages/fcl-db/examples/myext.pp b/packages/fcl-db/examples/myext.pp new file mode 100644 index 0000000000..7a5bc97e5e --- /dev/null +++ b/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. diff --git a/packages/fcl-db/examples/sqlite3extdemo.pp b/packages/fcl-db/examples/sqlite3extdemo.pp new file mode 100644 index 0000000000..93869fd14f --- /dev/null +++ b/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. diff --git a/packages/fcl-db/src/sqldb/sqlite/sqlite3conn.pp b/packages/fcl-db/src/sqldb/sqlite/sqlite3conn.pp index 7b599de878..83cb07d43c 100644 --- a/packages/fcl-db/src/sqldb/sqlite/sqlite3conn.pp +++ b/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: CollationName has to be a UTF-8 string procedure CreateCollation(const CollationName: string; eTextRep: integer; Arg: Pointer=nil; Compare: xCompare=nil); - procedure LoadExtension(LibraryFile: string); + procedure LoadExtension(const LibraryFile: string); Published Property OpenFlags : TSQLiteOpenFlags Read FOpenFlags Write SetOpenFlags default DefaultOpenFlags; end; @@ -1107,7 +1107,7 @@ begin CheckError(sqlite3_create_collation(fhandle, PChar(CollationName), eTextRep, Arg, Compare)); end; -procedure TSQLite3Connection.LoadExtension(LibraryFile: string); +procedure TSQLite3Connection.LoadExtension(const LibraryFile: string); var LoadResult: integer; begin diff --git a/packages/fpmkunit/src/fpmkunit.pp b/packages/fpmkunit/src/fpmkunit.pp index 878bea8d62..1bd3541d5b 100644 --- a/packages/fpmkunit/src/fpmkunit.pp +++ b/packages/fpmkunit/src/fpmkunit.pp @@ -1683,7 +1683,7 @@ ResourceString SWarngcclibpath = 'Warning: Unable to determine the libgcc path.'; SWarnNoFCLProcessSupport= 'No FCL-Process support'; 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'; SWarnRemovedNonEmptyDirectory = 'Warning: Removed non empty directory "%s"'; diff --git a/packages/pastojs/src/fppas2js.pp b/packages/pastojs/src/fppas2js.pp index daf31556a0..b4f2ad8c32 100644 --- a/packages/pastojs/src/fppas2js.pp +++ b/packages/pastojs/src/fppas2js.pp @@ -374,6 +374,9 @@ ToDos: - functions - rtti - 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 - 'new', 'Function' -> class var use .prototype - static arrays diff --git a/packages/pastojs/src/pas2jsfilecache.pp b/packages/pastojs/src/pas2jsfilecache.pp index a591079e99..86bac7ea13 100644 --- a/packages/pastojs/src/pas2jsfilecache.pp +++ b/packages/pastojs/src/pas2jsfilecache.pp @@ -1896,7 +1896,7 @@ var // search in Dir for pp, pas, p times given case, lower case, upper case begin Dir:=IncludeTrailingPathDelimiter(Dir); - if IndexOfFile(SearchedDirs,Dir)>=0 then exit; + if IndexOfFile(SearchedDirs,Dir)>=0 then exit(false); SearchedDirs.Add(Dir); Filename:=Dir+aUnitname+'.pp'; if SearchLowUpCase(Filename) then exit(true); diff --git a/packages/rtl-console/src/unix/keyboard.pp b/packages/rtl-console/src/unix/keyboard.pp index 111f5a604a..625b35b6cf 100644 --- a/packages/rtl-console/src/unix/keyboard.pp +++ b/packages/rtl-console/src/unix/keyboard.pp @@ -96,6 +96,12 @@ const KbShiftUp = $f0; KbShiftDown = $f3; KbShiftHome = $f4; KbShiftEnd = $f5; + KbCtrlShiftUp = $f6; + KbCtrlShiftDown = $f7; + KbCtrlShiftRight = $f8; + KbCtrlShiftLeft = $f9; + KbCtrlShiftHome = $fa; + KbCtrlShiftEnd = $fb; double_esc_hack_enabled : boolean = false; @@ -494,7 +500,7 @@ const MouseEvent.buttons := 0; PutMouseEvent(MouseEvent); end; - + procedure GenMouseEvent; var MouseEvent: TMouseEvent; ch : char; @@ -869,7 +875,7 @@ type key_sequence=packed record st:string[7]; 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: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'[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:kbCtrlDown;st:#27'[1;5B'), {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 explanation.} 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 begin if intail=0 then @@ -1361,11 +1376,11 @@ begin end else RestoreArray; - end + end; {$ifdef logging} writeln(f); {$endif logging} - ; + ReadKey:=PopKey; End; @@ -1541,6 +1556,8 @@ const kbAltDown,kbAltPgDn,kbAltIns,kbAltDel); ShiftArrow : array [kbShiftUp..kbShiftEnd] of byte = (kbUp,kbLeft,kbRight,kbDown,kbHome,kbEnd); + CtrlShiftArrow : array [kbCtrlShiftUp..kbCtrlShiftEnd] of byte = + (kbCtrlUp,kbCtrlDown,kbCtrlRight,kbCtrlLeft,kbCtrlHome,kbCtrlEnd); var MyScan:byte; @@ -1601,10 +1618,17 @@ begin {main} kbF11..KbF12 : { sF11-sF12 } MyScan:=MyScan+kbShiftF11-kbF11; end; - if myscan in [kbShiftUp..kbShiftEnd] then + if myscan in [kbShiftUp..kbCtrlShiftEnd] then 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; if myscan=kbAltBack then sstate:=sstate or kbalt; diff --git a/packages/sqlite/examples/myext.lpi b/packages/sqlite/examples/myext.lpi new file mode 100644 index 0000000000..77b1c453d5 --- /dev/null +++ b/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> diff --git a/packages/sqlite/examples/myext.pp b/packages/sqlite/examples/myext.pp new file mode 100644 index 0000000000..7a5bc97e5e --- /dev/null +++ b/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. diff --git a/packages/sqlite/fpmake.pp b/packages/sqlite/fpmake.pp index 5aa2c439a3..e81ef2a56a 100644 --- a/packages/sqlite/fpmake.pp +++ b/packages/sqlite/fpmake.pp @@ -47,7 +47,9 @@ begin AddUnit('sqlite'); end; T:=P.Targets.AddUnit('sqlite.pp'); - + T:=P.Targets.AddUnit('sqlite3ext.pp'); + T.Dependencies.AddUnit('sqlite'); + P.ExamplePath.Add('tests/'); P.Targets.AddExampleProgram('testapiv3x.pp'); P.Targets.AddExampleProgram('test.pas'); diff --git a/packages/sqlite/src/sqlite3ext.pp b/packages/sqlite/src/sqlite3ext.pp new file mode 100644 index 0000000000..623539c189 --- /dev/null +++ b/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. diff --git a/utils/tply/lexbase.pas b/utils/tply/lexbase.pas index f6b329203c..719df5f2ee 100644 --- a/utils/tply/lexbase.pas +++ b/utils/tply/lexbase.pas @@ -969,7 +969,7 @@ function path(filename : String) : String; var i : Integer; begin 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); path := copy(filename, 1, i); end(*path*); @@ -985,10 +985,10 @@ function root(filename : String) : String; root := copy(filename, 1, i-1); exit end; - '\': exit; + DirectorySeparator : exit; else end; - end(*addExt*); + end(*root*); function addExt(filename, ext : String) : String; (* implemented with goto for maximum efficiency *) label x; @@ -999,7 +999,7 @@ function addExt(filename, ext : String) : String; for i := length(filename) downto 1 do case filename[i] of '.' : exit; - '\': goto x; + DirectorySeparator: goto x; else end; x : addExt := filename+'.'+ext diff --git a/utils/tply/plex.pas b/utils/tply/plex.pas index df2aefd1d3..9ea37b962f 100644 --- a/utils/tply/plex.pas +++ b/utils/tply/plex.pas @@ -597,7 +597,11 @@ var i : Integer; begin {$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/'; {$else} codfilepath1:=path(paramstr(0)); diff --git a/utils/tply/pyacc.pas b/utils/tply/pyacc.pas index 7964476f6e..530ff7842e 100644 --- a/utils/tply/pyacc.pas +++ b/utils/tply/pyacc.pas @@ -2375,7 +2375,11 @@ var i : Integer; begin {$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/'; {$else} codfilepath1:=path(paramstr(0)); diff --git a/utils/tply/pyacc.y b/utils/tply/pyacc.y index ddf614e1ce..5817810d8f 100644 --- a/utils/tply/pyacc.y +++ b/utils/tply/pyacc.y @@ -711,7 +711,11 @@ var i : Integer; begin {$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/'; {$else} codfilepath1:=path(paramstr(0)); diff --git a/utils/tply/yaccbase.pas b/utils/tply/yaccbase.pas index d48188d016..d161ed8be9 100644 --- a/utils/tply/yaccbase.pas +++ b/utils/tply/yaccbase.pas @@ -640,7 +640,7 @@ function path(filename : String) : String; var i : Integer; begin 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); path := copy(filename, 1, i); end(*path*); @@ -656,10 +656,10 @@ function root(filename : String) : String; root := copy(filename, 1, i-1); exit end; - '\': exit; + DirectorySeparator: exit; else end; - end(*addExt*); + end(*root*); function addExt(filename, ext : String) : String; (* implemented with goto for maximum efficiency *) label x; @@ -670,7 +670,7 @@ function addExt(filename, ext : String) : String; for i := length(filename) downto 1 do case filename[i] of '.' : exit; - '\': goto x; + DirectorySeparator : goto x; else end; x : addExt := filename+'.'+ext |