diff options
| author | foxsen <foxsen@3ad0048d-3df7-0310-abae-a5850022a9f2> | 2012-07-11 05:58:33 +0000 |
|---|---|---|
| committer | foxsen <foxsen@3ad0048d-3df7-0310-abae-a5850022a9f2> | 2012-07-11 05:58:33 +0000 |
| commit | 0321f8d9bde18cc19bf642102f287ab6eade382f (patch) | |
| tree | ad6224bc825907ba6b8a03d849e4396298fb53e3 | |
| parent | a18fe56f5e2c634b35936e044f1e95573699e77d (diff) | |
| download | fpc-foxsen.tar.gz | |
merge to trunk 21856foxsen
git-svn-id: http://svn.freepascal.org/svn/fpc/branches/foxsen@21858 3ad0048d-3df7-0310-abae-a5850022a9f2
269 files changed, 9569 insertions, 3901 deletions
diff --git a/mips/compiler/Makefile b/mips/compiler/Makefile index 1beac0d0b4..0292a943f3 100644 --- a/mips/compiler/Makefile +++ b/mips/compiler/Makefile @@ -1,5 +1,5 @@ # -# Don't edit, this file is generated by FPCMake Version 2.0.0 [2012/04/25] +# Don't edit, this file is generated by FPCMake Version 2.0.0 [2012/06/13] # default: all MAKEFILETARGETS=i386-linux i386-go32v2 i386-win32 i386-os2 i386-freebsd i386-beos i386-haiku i386-netbsd i386-solaris i386-qnx i386-netware i386-openbsd i386-wdosx i386-darwin i386-emx i386-watcom i386-netwlibc i386-wince i386-embedded i386-symbian i386-nativent i386-iphonesim m68k-linux m68k-freebsd m68k-netbsd m68k-amiga m68k-atari m68k-openbsd m68k-palmos m68k-embedded powerpc-linux powerpc-netbsd powerpc-amiga powerpc-macos powerpc-darwin powerpc-morphos powerpc-embedded powerpc-wii powerpc-aix sparc-linux sparc-netbsd sparc-solaris sparc-embedded x86_64-linux x86_64-freebsd x86_64-netbsd x86_64-solaris x86_64-openbsd x86_64-darwin x86_64-win64 x86_64-embedded arm-linux arm-palmos arm-darwin arm-wince arm-gba arm-nds arm-embedded arm-symbian powerpc64-linux powerpc64-darwin powerpc64-embedded powerpc64-aix avr-embedded armeb-linux armeb-embedded mips-linux mipsel-linux jvm-java jvm-android @@ -362,6 +362,32 @@ endif ifndef RTLOPT RTLOPT:=$(OPT) endif +ifdef CYCLELEVEL +ifeq ($(CYCLELEVEL),1) +LOCALOOPT+=$(OPTLEVEL1) +RTLOPT+=$(OPTLEVEL1) +LOCALOPT+=$(LOCALOPTLEVEL1) +RTLOPT+=$(RTLOPTLEVEL1) +endif +ifeq ($(CYCLELEVEL),2) +LOCALOOPT+=$(OPTLEVEL2) +RTLOPT+=$(OPTLEVEL2) +LOCALOPT+=$(LOCALOPTLEVEL2) +RTLOPT+=$(RTLOPTLEVEL2) +endif +ifeq ($(CYCLELEVEL),3) +LOCALOOPT+=$(OPTLEVEL3) +RTLOPT+=$(OPTLEVEL3) +LOCALOPT+=$(LOCALOPTLEVEL3) +RTLOPT+=$(RTLOPTLEVEL3) +endif +ifeq ($(CYCLELEVEL),4) +LOCALOOPT+=$(OPTLEVEL4) +RTLOPT+=$(OPTLEVEL4) +LOCALOPT+=$(LOCALOPTLEVEL4) +RTLOPT+=$(RTLOPTLEVEL4) +endif +endif override OPT= MSGFILES=$(wildcard msg/error*.msg) ifeq ($(CPC_TARGET),i386) @@ -2702,17 +2728,12 @@ endif endif ifdef CREATESHARED override FPCOPT+=-Cg -ifeq ($(CPU_TARGET),i386) -override FPCOPT+=-Aas -endif endif -ifeq ($(findstring 2.0.,$(FPC_VERSION)),) ifneq ($(findstring $(OS_TARGET),freebsd openbsd netbsd linux solaris),) ifeq ($(CPU_TARGET),x86_64) override FPCOPT+=-Cg endif endif -endif ifdef LINKSHARED endif ifdef OPT @@ -3674,20 +3695,20 @@ next : $(MAKE) echotime endif $(TEMPNAME1) : - $(MAKE) 'OLDFPC=' next + $(MAKE) 'OLDFPC=' next CYCLELEVEL=1 -$(DEL) $(TEMPNAME1) $(MOVE) $(EXENAME) $(TEMPNAME1) $(TEMPNAME2) : $(TEMPNAME1) - $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME1)' 'OLDFPC=' next + $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME1)' 'OLDFPC=' next CYCLELEVEL=2 -$(DEL) $(TEMPNAME2) $(MOVE) $(EXENAME) $(TEMPNAME2) $(TEMPNAME3) : $(TEMPNAME2) - $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME2)' 'OLDFPC=$(BASEDIR)/$(TEMPNAME1)' next + $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME2)' 'OLDFPC=$(BASEDIR)/$(TEMPNAME1)' next CYCLELEVEL=3 -$(DEL) $(TEMPNAME3) $(MOVE) $(EXENAME) $(TEMPNAME3) cycle: $(MAKE) tempclean $(TEMPNAME3) - $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME3)' 'OLDFPC=$(BASEDIR)/$(TEMPNAME2)' next + $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME3)' 'OLDFPC=$(BASEDIR)/$(TEMPNAME2)' next CYCLELEVEL=4 $(DIFF) $(TEMPNAME3) $(EXENAME) $(MAKE) $(addsuffix _all,$(TARGET_DIRS)) 'FPC=$(BASEDIR)/$(EXENAME)' $(MAKE) wpocycle @@ -3695,14 +3716,14 @@ cycle: else cycle: $(MAKE) OS_TARGET=$(OS_SOURCE) CROSSBINDIR= BINUTILSPREFIX= CROSSCYCLEBOOTSTRAP=1 rtlclean rtl - $(MAKE) OS_TARGET=$(OS_SOURCE) EXENAME=$(TEMPNAME) CROSSBINDIR= BINUTILSPREFIX= CROSSCYCLEBOOTSTRAP=1 cycleclean compiler + $(MAKE) OS_TARGET=$(OS_SOURCE) EXENAME=$(TEMPNAME) CROSSBINDIR= BINUTILSPREFIX= CROSSCYCLEBOOTSTRAP=1 cycleclean compiler CYCLELEVEL=1 $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME)' OS_TARGET=$(OS_SOURCE) CROSSBINDIR= BINUTILSPREFIX= CROSSCYCLEBOOTSTRAP=1 rtlclean rtl - $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME)' OS_TARGET=$(OS_SOURCE) EXENAME=$(PPCROSSNAME) CROSSBINDIR= BINUTILSPREFIX= CROSSCYCLEBOOTSTRAP=1 cycleclean compiler + $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME)' OS_TARGET=$(OS_SOURCE) EXENAME=$(PPCROSSNAME) CROSSBINDIR= BINUTILSPREFIX= CROSSCYCLEBOOTSTRAP=1 cycleclean compiler CYCLELEVEL=2 ifndef CROSSINSTALL $(MAKE) 'FPC=$(BASEDIR)/$(PPCROSSNAME)' rtlclean rtl ifneq ($(OS_TARGET),embedded) ifneq ($(OS_TARGET),gba) - $(MAKE) 'FPC=$(BASEDIR)/$(PPCROSSNAME)' cycleclean compiler + $(MAKE) 'FPC=$(BASEDIR)/$(PPCROSSNAME)' cycleclean compiler CYCLELEVEL=3 endif endif endif @@ -3711,27 +3732,31 @@ else cycle: override FPC= cycle: $(MAKE) OS_TARGET=$(OS_SOURCE) CPU_TARGET=$(CPU_SOURCE) CROSSBINDIR= BINUTILSPREFIX= CROSSCYCLEBOOTSTRAP=1 rtlclean rtl - $(MAKE) OS_TARGET=$(OS_SOURCE) CPU_TARGET=$(CPU_SOURCE) EXENAME=$(TEMPNAME) CROSSBINDIR= BINUTILSPREFIX= CROSSCYCLEBOOTSTRAP=1 cycleclean compiler + $(MAKE) OS_TARGET=$(OS_SOURCE) CPU_TARGET=$(CPU_SOURCE) EXENAME=$(TEMPNAME) CROSSBINDIR= BINUTILSPREFIX= CROSSCYCLEBOOTSTRAP=1 cycleclean compiler CYCLELEVEL=1 $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME)' OS_TARGET=$(OS_SOURCE) CPU_TARGET=$(CPU_SOURCE) CROSSBINDIR= BINUTILSPREFIX= CROSSCYCLEBOOTSTRAP=1 rtlclean rtl - $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME)' OS_TARGET=$(OS_SOURCE) CPU_TARGET=$(CPU_SOURCE) PPC_TARGET=$(CPU_TARGET) EXENAME=$(PPCROSSNAME) CROSSBINDIR= BINUTILSPREFIX= CROSSCYCLEBOOTSTRAP=1 cycleclean compiler + $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME)' OS_TARGET=$(OS_SOURCE) CPU_TARGET=$(CPU_SOURCE) PPC_TARGET=$(CPU_TARGET) EXENAME=$(PPCROSSNAME) CROSSBINDIR= BINUTILSPREFIX= CROSSCYCLEBOOTSTRAP=1 cycleclean compiler CYCLELEVEL=2 ifndef CROSSINSTALL $(MAKE) 'FPC=$(BASEDIR)/$(PPCROSSNAME)' 'OPT=$(RTLOPT) $(CROSSOPT)' rtlclean rtl ifndef NoNativeBinaries - $(MAKE) 'FPC=$(BASEDIR)/$(PPCROSSNAME)' 'OPT=$(LOCALOPT) $(CROSSOPT)' cycleclean compiler + $(MAKE) 'FPC=$(BASEDIR)/$(PPCROSSNAME)' 'OPT=$(LOCALOPT) $(CROSSOPT)' cycleclean compiler CYCLELEVEL=3 endif endif endif cycledep: $(MAKE) cycle USEDEPEND=1 extcycle: - $(MAKE) cycle OPT='-n -OG2p3 -glttt -CRriot -dEXTDEBUG' + $(MAKE) cycle OPT="$(OPT) -n -OG2p3 -glttt -CRriot -dEXTDEBUG" cvstest: $(MAKE) cycle 'LOCALOPT=-n -Se' 'RTLOPT=-n -Se' full: fullcycle fullcycle: $(MAKE) cycle $(MAKE) ppuclean +ifneq ($(CPU_SOURCE),x86_64) $(MAKE) $(filter-out $(PPC_TARGET),$(CYCLETARGETS)) 'FPC=$(BASEDIR)/$(EXENAME)' +else + $(MAKE) $(filter-out i386,$(filter-out $(PPC_TARGET),$(CYCLETARGETS))) 'FPC=$(BASEDIR)/$(EXENAME)' +endif htmldocs: $(PASDOC) -p -h -o html$(PATHSEP)$(PPC_TARGET) -d fpc -d gdb -d $(PPC_TARGET) -u $(PPC_TARGET) $(PPC_TARGET)$(PATHSEP)*.pas systems$(PATHSEP)*.pas *.pas .PHONY: quickinstall exeinstall install installsym diff --git a/mips/compiler/Makefile.fpc b/mips/compiler/Makefile.fpc index 7b92695a05..8f24b83262 100644 --- a/mips/compiler/Makefile.fpc +++ b/mips/compiler/Makefile.fpc @@ -123,6 +123,33 @@ ifndef RTLOPT RTLOPT:=$(OPT) endif +ifdef CYCLELEVEL +ifeq ($(CYCLELEVEL),1) +LOCALOOPT+=$(OPTLEVEL1) +RTLOPT+=$(OPTLEVEL1) +LOCALOPT+=$(LOCALOPTLEVEL1) +RTLOPT+=$(RTLOPTLEVEL1) +endif +ifeq ($(CYCLELEVEL),2) +LOCALOOPT+=$(OPTLEVEL2) +RTLOPT+=$(OPTLEVEL2) +LOCALOPT+=$(LOCALOPTLEVEL2) +RTLOPT+=$(RTLOPTLEVEL2) +endif +ifeq ($(CYCLELEVEL),3) +LOCALOOPT+=$(OPTLEVEL3) +RTLOPT+=$(OPTLEVEL3) +LOCALOPT+=$(LOCALOPTLEVEL3) +RTLOPT+=$(RTLOPTLEVEL3) +endif +ifeq ($(CYCLELEVEL),4) +LOCALOOPT+=$(OPTLEVEL4) +RTLOPT+=$(OPTLEVEL4) +LOCALOPT+=$(LOCALOPTLEVEL4) +RTLOPT+=$(RTLOPTLEVEL4) +endif +endif + # Make OPT empty. It is copied to LOCALOPT and RTLOPT override OPT= @@ -582,23 +609,23 @@ next : endif $(TEMPNAME1) : - $(MAKE) 'OLDFPC=' next + $(MAKE) 'OLDFPC=' next CYCLELEVEL=1 -$(DEL) $(TEMPNAME1) $(MOVE) $(EXENAME) $(TEMPNAME1) $(TEMPNAME2) : $(TEMPNAME1) - $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME1)' 'OLDFPC=' next + $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME1)' 'OLDFPC=' next CYCLELEVEL=2 -$(DEL) $(TEMPNAME2) $(MOVE) $(EXENAME) $(TEMPNAME2) $(TEMPNAME3) : $(TEMPNAME2) - $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME2)' 'OLDFPC=$(BASEDIR)/$(TEMPNAME1)' next + $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME2)' 'OLDFPC=$(BASEDIR)/$(TEMPNAME1)' next CYCLELEVEL=3 -$(DEL) $(TEMPNAME3) $(MOVE) $(EXENAME) $(TEMPNAME3) cycle: $(MAKE) tempclean $(TEMPNAME3) - $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME3)' 'OLDFPC=$(BASEDIR)/$(TEMPNAME2)' next + $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME3)' 'OLDFPC=$(BASEDIR)/$(TEMPNAME2)' next CYCLELEVEL=4 $(DIFF) $(TEMPNAME3) $(EXENAME) $(MAKE) $(addsuffix _all,$(TARGET_DIRS)) 'FPC=$(BASEDIR)/$(EXENAME)' $(MAKE) wpocycle @@ -613,10 +640,10 @@ else cycle: # ppc (source native) $(MAKE) OS_TARGET=$(OS_SOURCE) CROSSBINDIR= BINUTILSPREFIX= CROSSCYCLEBOOTSTRAP=1 rtlclean rtl - $(MAKE) OS_TARGET=$(OS_SOURCE) EXENAME=$(TEMPNAME) CROSSBINDIR= BINUTILSPREFIX= CROSSCYCLEBOOTSTRAP=1 cycleclean compiler + $(MAKE) OS_TARGET=$(OS_SOURCE) EXENAME=$(TEMPNAME) CROSSBINDIR= BINUTILSPREFIX= CROSSCYCLEBOOTSTRAP=1 cycleclean compiler CYCLELEVEL=1 # ppcross<ARCH> (source native) $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME)' OS_TARGET=$(OS_SOURCE) CROSSBINDIR= BINUTILSPREFIX= CROSSCYCLEBOOTSTRAP=1 rtlclean rtl - $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME)' OS_TARGET=$(OS_SOURCE) EXENAME=$(PPCROSSNAME) CROSSBINDIR= BINUTILSPREFIX= CROSSCYCLEBOOTSTRAP=1 cycleclean compiler + $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME)' OS_TARGET=$(OS_SOURCE) EXENAME=$(PPCROSSNAME) CROSSBINDIR= BINUTILSPREFIX= CROSSCYCLEBOOTSTRAP=1 cycleclean compiler CYCLELEVEL=2 # ppc<ARCH> (target native) ifndef CROSSINSTALL $(MAKE) 'FPC=$(BASEDIR)/$(PPCROSSNAME)' rtlclean rtl @@ -624,7 +651,7 @@ ifndef CROSSINSTALL ifneq ($(OS_TARGET),embedded) # building a native compiler for the arm-gba target is not possible ifneq ($(OS_TARGET),gba) - $(MAKE) 'FPC=$(BASEDIR)/$(PPCROSSNAME)' cycleclean compiler + $(MAKE) 'FPC=$(BASEDIR)/$(PPCROSSNAME)' cycleclean compiler CYCLELEVEL=3 endif endif endif @@ -646,16 +673,16 @@ cycle: # ppc (source native) # Clear detected compiler binary, because it can be existing crosscompiler binary, but we need native compiler here $(MAKE) OS_TARGET=$(OS_SOURCE) CPU_TARGET=$(CPU_SOURCE) CROSSBINDIR= BINUTILSPREFIX= CROSSCYCLEBOOTSTRAP=1 rtlclean rtl - $(MAKE) OS_TARGET=$(OS_SOURCE) CPU_TARGET=$(CPU_SOURCE) EXENAME=$(TEMPNAME) CROSSBINDIR= BINUTILSPREFIX= CROSSCYCLEBOOTSTRAP=1 cycleclean compiler + $(MAKE) OS_TARGET=$(OS_SOURCE) CPU_TARGET=$(CPU_SOURCE) EXENAME=$(TEMPNAME) CROSSBINDIR= BINUTILSPREFIX= CROSSCYCLEBOOTSTRAP=1 cycleclean compiler CYCLELEVEL=1 # ppcross<ARCH> (source native) $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME)' OS_TARGET=$(OS_SOURCE) CPU_TARGET=$(CPU_SOURCE) CROSSBINDIR= BINUTILSPREFIX= CROSSCYCLEBOOTSTRAP=1 rtlclean rtl - $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME)' OS_TARGET=$(OS_SOURCE) CPU_TARGET=$(CPU_SOURCE) PPC_TARGET=$(CPU_TARGET) EXENAME=$(PPCROSSNAME) CROSSBINDIR= BINUTILSPREFIX= CROSSCYCLEBOOTSTRAP=1 cycleclean compiler + $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME)' OS_TARGET=$(OS_SOURCE) CPU_TARGET=$(CPU_SOURCE) PPC_TARGET=$(CPU_TARGET) EXENAME=$(PPCROSSNAME) CROSSBINDIR= BINUTILSPREFIX= CROSSCYCLEBOOTSTRAP=1 cycleclean compiler CYCLELEVEL=2 # ppc<ARCH> (target native) ifndef CROSSINSTALL $(MAKE) 'FPC=$(BASEDIR)/$(PPCROSSNAME)' 'OPT=$(RTLOPT) $(CROSSOPT)' rtlclean rtl # building a native compiler for JVM and embedded targets is not possible ifndef NoNativeBinaries - $(MAKE) 'FPC=$(BASEDIR)/$(PPCROSSNAME)' 'OPT=$(LOCALOPT) $(CROSSOPT)' cycleclean compiler + $(MAKE) 'FPC=$(BASEDIR)/$(PPCROSSNAME)' 'OPT=$(LOCALOPT) $(CROSSOPT)' cycleclean compiler CYCLELEVEL=3 endif endif @@ -665,7 +692,7 @@ cycledep: $(MAKE) cycle USEDEPEND=1 extcycle: - $(MAKE) cycle OPT='-n -OG2p3 -glttt -CRriot -dEXTDEBUG' + $(MAKE) cycle OPT="$(OPT) -n -OG2p3 -glttt -CRriot -dEXTDEBUG" cvstest: $(MAKE) cycle 'LOCALOPT=-n -Se' 'RTLOPT=-n -Se' @@ -685,7 +712,11 @@ full: fullcycle fullcycle: $(MAKE) cycle $(MAKE) ppuclean +ifneq ($(CPU_SOURCE),x86_64) $(MAKE) $(filter-out $(PPC_TARGET),$(CYCLETARGETS)) 'FPC=$(BASEDIR)/$(EXENAME)' +else + $(MAKE) $(filter-out i386,$(filter-out $(PPC_TARGET),$(CYCLETARGETS))) 'FPC=$(BASEDIR)/$(EXENAME)' +endif ##################################################################### # Docs diff --git a/mips/compiler/aasmbase.pas b/mips/compiler/aasmbase.pas index 04eb2d1260..9fe07535fb 100644 --- a/mips/compiler/aasmbase.pas +++ b/mips/compiler/aasmbase.pas @@ -191,6 +191,15 @@ interface function ReplaceForbiddenAsmSymbolChars(const s: string): string; + { dummy default noop callback } + procedure default_global_used; + type + TGlobalUsedProcedure = procedure; + { Procedure variable to allow for special handling of + the occurence of use of a global variable, + used by PIC code generation to request GOT loading } + const + global_used : TGlobalUsedProcedure = @default_global_used; implementation @@ -420,6 +429,7 @@ implementation is_set:=false; { write it always } increfs; + global_used; end; @@ -447,4 +457,8 @@ implementation increfs; end; + procedure default_global_used; + begin + end; + end. diff --git a/mips/compiler/aasmtai.pas b/mips/compiler/aasmtai.pas index 2b8e9ce15d..fee6ce2766 100644 --- a/mips/compiler/aasmtai.pas +++ b/mips/compiler/aasmtai.pas @@ -68,10 +68,13 @@ interface ait_stab, ait_force_line, ait_function_name, + { Used for .ent .end pair used for .dpr section in MIPS + and probably also for Alpha } + ait_ent, + ait_ent_end, {$ifdef alpha} { the follow is for the DEC Alpha } ait_frame, - ait_ent, {$endif alpha} {$ifdef ia64} ait_bundle, @@ -163,10 +166,11 @@ interface 'stab', 'force_line', 'function_name', + 'ent', + 'ent_end', {$ifdef alpha} { the follow is for the DEC Alpha } 'frame', - 'ent', {$endif alpha} {$ifdef ia64} 'bundle', @@ -261,7 +265,8 @@ interface a new ait type! } SkipInstr = [ait_comment, ait_symbol,ait_section ,ait_stab, ait_function_name, ait_force_line - ,ait_regalloc, ait_tempalloc, ait_symbol_end, ait_directive + ,ait_regalloc, ait_tempalloc, ait_symbol_end + ,ait_ent, ait_ent_end, ait_directive ,ait_varloc,ait_seh_directive ,ait_jvar, ait_jcatch]; @@ -272,6 +277,7 @@ interface ait_stab,ait_function_name, ait_cutobject,ait_marker,ait_varloc,ait_align,ait_section,ait_comment, ait_const,ait_directive, + ait_ent, ait_ent_end, {$ifdef arm} ait_thumb_func, {$endif arm} @@ -420,6 +426,16 @@ interface procedure derefimpl;override; end; + tai_ent = class(tai) + Name : string; + Constructor Create (const ProcName : String); + end; + + tai_ent_end = class(tai) + Name : string; + Constructor Create (const ProcName : String); + end; + tai_directive = class(tailineinfo) name : ansistring; directive : TAsmDirective; @@ -1246,6 +1262,26 @@ implementation ppufile.putbyte(byte(directive)); end; +{**************************************************************************** + TAI_ENT / TAI_ENT_END + ****************************************************************************} + + Constructor tai_ent.Create (const ProcName : String); + + begin + Inherited Create; + Name:=ProcName; + typ:=ait_ent; + end; + + Constructor tai_ent_end.Create (const ProcName : String); + + begin + Inherited Create; + Name:=ProcName; + typ:=ait_ent_end; + end; + {**************************************************************************** TAI_CONST diff --git a/mips/compiler/aggas.pas b/mips/compiler/aggas.pas index e64d96a1ba..d9dfb03db9 100644 --- a/mips/compiler/aggas.pas +++ b/mips/compiler/aggas.pas @@ -1177,14 +1177,6 @@ implementation else AsmWriteln(tai_symbol(hp).sym.name); end; - if target_info.system in [system_mipsel_linux,system_mipseb_linux] then - begin - AsmWrite(#9'.ent'#9); - if replaceforbidden then - AsmWriteln(ReplaceForbiddenAsmSymbolChars(tai_symbol(hp).sym.name)) - else - AsmWriteln(tai_symbol(hp).sym.name); - end; if (target_info.system = system_powerpc64_linux) and (tai_symbol(hp).sym.typ = AT_FUNCTION) then begin @@ -1255,13 +1247,23 @@ implementation AsmWriteLn(#9'.thumb_func'); end; {$endif arm} -{$if defined(alpha)} ait_ent: begin - AsmWriteLn(#9'.ent'#9+tai_ent(hp).Name); + AsmWrite(#9'.ent'#9); + if replaceforbidden then + AsmWriteLn(ReplaceForbiddenAsmSymbolChars(tai_ent(hp).Name)) + else + AsmWriteLn(tai_ent(hp).Name); + end; + ait_ent_end: + begin + AsmWrite(#9'.end'#9); + if replaceforbidden then + AsmWriteLn(ReplaceForbiddenAsmSymbolChars(tai_ent_end(hp).Name)) + else + AsmWriteLn(tai_ent_end(hp).Name); end; -{$endif alpha} - ait_symbol_end : + ait_symbol_end : begin if tf_needs_symbol_size in target_info.flags then begin @@ -1529,7 +1531,7 @@ implementation i: longint; begin {$ifdef EXTDEBUG} - if assigned(current_module.mainsource) then + if current_module.mainsource<>'' then Comment(V_Debug,'Start writing gas-styled assembler output for '+current_module.mainsource); {$endif} @@ -1573,7 +1575,7 @@ implementation AsmLn; {$ifdef EXTDEBUG} - if assigned(current_module.mainsource) then + if current_module.mainsource<>'' then Comment(V_Debug,'Done writing gas-styled assembler output for '+current_module.mainsource); {$endif EXTDEBUG} end; diff --git a/mips/compiler/alpha/aasmcpu.pas b/mips/compiler/alpha/aasmcpu.pas index 6e1ef8d02b..9a9d1b5ec4 100644 --- a/mips/compiler/alpha/aasmcpu.pas +++ b/mips/compiler/alpha/aasmcpu.pas @@ -39,11 +39,6 @@ unit aasmcpu; Constructor Create (GP : Tregister; Localsize : Longint; RA : TRegister; L : longint); end; - tai_ent = class(tai) - Name : string; - Constructor Create (const ProcName : String); - end; - taicpu = class(tai_cpu_abstract_sym) constructor op_none(op : tasmop); @@ -260,14 +255,6 @@ implementation LU:=L; end; - Constructor tai_ent.Create (const ProcName : String); - - begin - Inherited Create; - typ:=ait_ent; - Name:=ProcName; - end; - procedure InitAsm; begin end; diff --git a/mips/compiler/aopt.pas b/mips/compiler/aopt.pas index b763c9ddae..e0366d420d 100644 --- a/mips/compiler/aopt.pas +++ b/mips/compiler/aopt.pas @@ -298,7 +298,8 @@ Unit aopt; Begin if assigned(LabelInfo^.LabelTable) then Freemem(LabelInfo^.LabelTable); - Dispose(LabelInfo) + Dispose(LabelInfo); + inherited Destroy; End; diff --git a/mips/compiler/aoptbase.pas b/mips/compiler/aoptbase.pas index a60c163585..fa511bbdf3 100644 --- a/mips/compiler/aoptbase.pas +++ b/mips/compiler/aoptbase.pas @@ -129,7 +129,11 @@ unit aoptbase; Begin Case op.typ Of Top_Reg: RegInOp := Reg = op.reg; - Top_Ref: RegInOp := RegInRef(Reg, op.ref^) + Top_Ref: RegInOp := RegInRef(Reg, op.ref^); + {$ifdef arm} + Top_Shifterop: RegInOp := op.shifterop^.rs = Reg; + Top_RegSet: RegInOp := getsupreg(Reg) in op.regset^; + {$endif arm} Else RegInOp := False End End; diff --git a/mips/compiler/aoptobj.pas b/mips/compiler/aoptobj.pas index e27009d3d3..c279e2af10 100644 --- a/mips/compiler/aoptobj.pas +++ b/mips/compiler/aoptobj.pas @@ -61,7 +61,7 @@ Unit AoptObj; TRegArray = Array[byte] of tsuperregister; - TRegSet = Set of byte; + TRegSet = tcpuregisterset; { possible actions on an operand: read, write or modify (= read & write) } TOpAction = (OpAct_Read, OpAct_Write, OpAct_Modify, OpAct_Unknown); diff --git a/mips/compiler/arm/aasmcpu.pas b/mips/compiler/arm/aasmcpu.pas index 9db5726c2e..46309d56b0 100644 --- a/mips/compiler/arm/aasmcpu.pas +++ b/mips/compiler/arm/aasmcpu.pas @@ -567,10 +567,12 @@ implementation function taicpu.is_same_reg_move(regtype: Tregistertype):boolean; begin { allow the register allocator to remove unnecessary moves } - result:=(((opcode=A_MOV) and (regtype = R_INTREGISTER)) or - ((opcode=A_MVF) and (regtype = R_FPUREGISTER) and (oppostfix in [PF_None,PF_D])) or - (((opcode=A_FCPYS) or (opcode=A_FCPYD)) and (regtype = R_MMREGISTER)) + result:=( + ((opcode=A_MOV) and (regtype = R_INTREGISTER)) or + ((opcode=A_MVF) and (regtype = R_FPUREGISTER)) or + ((opcode in [A_FCPYS, A_FCPYD]) and (regtype = R_MMREGISTER)) ) and + (oppostfix in [PF_None,PF_D]) and (condition=C_None) and (ops=2) and (oper[0]^.typ=top_reg) and diff --git a/mips/compiler/arm/agarmgas.pas b/mips/compiler/arm/agarmgas.pas index 71a36f86bb..68d44706a6 100644 --- a/mips/compiler/arm/agarmgas.pas +++ b/mips/compiler/arm/agarmgas.pas @@ -153,7 +153,10 @@ unit agarmgas; s:=s+gas_regname(index); - if shiftmode<>SM_None then + {RRX always rotates by 1 bit and does not take an imm} + if shiftmode = SM_RRX then + s:=s+', rrx' + else if shiftmode <> SM_None then s:=s+', '+gas_shiftmode2str[shiftmode]+' #'+tostr(shiftimm); end else if offset<>0 then @@ -171,10 +174,6 @@ unit agarmgas; getreferencestring:=s; end; - - const - shiftmode2str: array[tshiftmode] of string[3] = ('','lsl','lsr','asr','ror','rrx'); - function getopstr(const o:toper) : string; var hs : string; @@ -186,10 +185,13 @@ unit agarmgas; getopstr:=gas_regname(o.reg); top_shifterop: begin - if (o.shifterop^.rs<>NR_NO) and (o.shifterop^.shiftimm=0) then - getopstr:=shiftmode2str[o.shifterop^.shiftmode]+' '+gas_regname(o.shifterop^.rs) + {RRX is special, it only rotates by 1 and does not take any shiftervalue} + if o.shifterop^.shiftmode=SM_RRX then + getopstr:='rrx' + else if (o.shifterop^.rs<>NR_NO) and (o.shifterop^.shiftimm=0) then + getopstr:=gas_shiftmode2str[o.shifterop^.shiftmode]+' '+gas_regname(o.shifterop^.rs) else if (o.shifterop^.rs=NR_NO) then - getopstr:=shiftmode2str[o.shifterop^.shiftmode]+' #'+tostr(o.shifterop^.shiftimm) + getopstr:=gas_shiftmode2str[o.shifterop^.shiftmode]+' #'+tostr(o.shifterop^.shiftimm) else internalerror(200308282); end; top_const: diff --git a/mips/compiler/arm/aoptcpu.pas b/mips/compiler/arm/aoptcpu.pas index ab7ee875b7..b1b76c57af 100644 --- a/mips/compiler/arm/aoptcpu.pas +++ b/mips/compiler/arm/aoptcpu.pas @@ -66,6 +66,7 @@ Implementation result:= (p.typ=ait_instruction) and (taicpu(p).condition=C_None) and + (taicpu(p).opcode<>A_PLD) and ((taicpu(p).opcode<>A_BLX) or (taicpu(p).oper[0]^.typ=top_reg)); end; @@ -96,12 +97,20 @@ Implementation function MatchOperand(const oper1: TOper; const oper2: TOper): boolean; inline; begin - result := (oper1.typ = oper2.typ) and - ( - ((oper1.typ = top_const) and (oper1.val = oper2.val)) or - ((oper1.typ = top_reg) and (oper1.reg = oper2.reg)) or - ((oper1.typ = top_conditioncode) and (oper1.cc = oper2.cc)) - ); + result := oper1.typ = oper2.typ; + + if result then + case oper1.typ of + top_const: + Result:=oper1.val = oper2.val; + top_reg: + Result:=oper1.reg = oper2.reg; + top_conditioncode: + Result:=oper1.cc = oper2.cc; + top_ref: + Result:=RefsEqual(oper1.ref^, oper2.ref^); + else Result:=false; + end end; function MatchOperand(const oper: TOper; const reg: TRegister): boolean; inline; @@ -130,24 +139,47 @@ Implementation if not ((assigned(hp)) and (hp.typ = ait_instruction)) then exit; - {These are not writing to their first oper} - if p.opcode in [A_STR, A_STRB, A_STRH, A_CMP, A_CMN, A_TST, A_TEQ, - A_B, A_BL, A_BX, A_BLX] then + case p.opcode of + { These operands do not write into a register at all } + A_CMP, A_CMN, A_TST, A_TEQ, A_B, A_BL, A_BX, A_BLX, A_SWI, A_MSR, A_PLD: + exit; + {Take care of post/preincremented store and loads, they will change their base register} + A_STR, A_LDR: + regLoadedWithNewValue := + (taicpu(p).oper[1]^.typ=top_ref) and + (taicpu(p).oper[1]^.ref^.addressmode in [AM_PREINDEXED,AM_POSTINDEXED]) and + (taicpu(p).oper[1]^.ref^.base = reg); + { These four are writing into the first 2 register, UMLAL and SMLAL will also read from them } + A_UMLAL, A_UMULL, A_SMLAL, A_SMULL: + regLoadedWithNewValue := + (p.oper[1]^.typ = top_reg) and + (p.oper[1]^.reg = reg); + {Loads to oper2 from coprocessor} + { + MCR/MRC is currently not supported in FPC + A_MRC: + regLoadedWithNewValue := + (p.oper[2]^.typ = top_reg) and + (p.oper[2]^.reg = reg); + } + {Loads to all register in the registerset} + A_LDM: + regLoadedWithNewValue := (getsupreg(reg) in p.oper[1]^.regset^); + end; + + if regLoadedWithNewValue then exit; - { These four are writing into the first 2 register, UMLAL and SMLAL will also read from them } - if (p.opcode in [A_UMLAL, A_UMULL, A_SMLAL, A_SMULL]) and - (p.oper[1]^.typ = top_reg) and - (p.oper[1]^.reg = reg) then - begin - regLoadedWithNewValue := true; - exit + case p.oper[0]^.typ of + {This is the case} + top_reg: + regLoadedWithNewValue := (p.oper[0]^.reg = reg); + {LDM/STM might write a new value to their index register} + top_ref: + regLoadedWithNewValue := + (taicpu(p).oper[0]^.ref^.addressmode in [AM_PREINDEXED,AM_POSTINDEXED]) and + (taicpu(p).oper[0]^.ref^.base = reg); end; - - {All other instructions use oper[0] as destination} - regLoadedWithNewValue := - (p.oper[0]^.typ = top_reg) and - (p.oper[0]^.reg = reg); end; function instructionLoadsFromReg(const reg: TRegister; const hp: tai): boolean; @@ -162,7 +194,8 @@ Implementation i:=1; {For these instructions we have to start on oper[0]} - if (p.opcode in [A_STR, A_STRB, A_STRH, A_CMP, A_CMN, A_TST, A_TEQ, + if (p.opcode in [A_STR, A_LDM, A_STM, A_PLD, + A_CMP, A_CMN, A_TST, A_TEQ, A_B, A_BL, A_BX, A_BLX, A_SMLAL, A_UMLAL]) then i:=0; @@ -231,6 +264,12 @@ Implementation i: longint; TmpUsedRegs: TAllUsedRegs; tempop: tasmop; + + function IsPowerOf2(const value: DWord): boolean; inline; + begin + Result:=(value and (value - 1)) = 0; + end; + begin result := false; case p.typ of @@ -432,6 +471,40 @@ Implementation result := true; end; end; + { Change the common + mov r0, r0, lsr #24 + and r0, r0, #255 + + and remove the superfluous and + + This could be extended to handle more cases. + } + if (taicpu(p).ops=3) and + (taicpu(p).oper[2]^.typ = top_shifterop) and + (taicpu(p).oper[2]^.shifterop^.rs = NR_NO) and + (taicpu(p).oper[2]^.shifterop^.shiftmode = SM_LSR) and + (taicpu(p).oper[2]^.shifterop^.shiftimm >= 24 ) and + getnextinstruction(p,hp1) and + MatchInstruction(hp1, A_AND, [taicpu(p).condition], [taicpu(p).oppostfix]) and + (taicpu(hp1).ops=3) and + MatchOperand(taicpu(p).oper[0]^, taicpu(hp1).oper[0]^) and + MatchOperand(taicpu(p).oper[0]^, taicpu(hp1).oper[1]^) and + (taicpu(hp1).oper[2]^.typ = top_const) and + { Check if the AND actually would only mask out bits beeing already zero because of the shift + For LSR #25 and an AndConst of 255 that whould go like this: + 255 and ((2 shl (32-25))-1) + which results in 127, which is one less a power-of-2, meaning all lower bits are set. + + LSR #25 and AndConst of 254: + 254 and ((2 shl (32-25))-1) = 126 -> lowest bit is clear, so we can't remove it. + } + ispowerof2((taicpu(hp1).oper[2]^.val and ((2 shl (32-taicpu(p).oper[2]^.shifterop^.shiftimm))-1))+1) then + begin + asml.insertbefore(tai_comment.Create(strpnew('Peephole LsrAnd2Lsr done')), hp1); + asml.remove(hp1); + hp1.free; + end; + { This changes the very common mov r0, #0 diff --git a/mips/compiler/arm/cgcpu.pas b/mips/compiler/arm/cgcpu.pas index 368cedf158..4822e00b97 100644 --- a/mips/compiler/arm/cgcpu.pas +++ b/mips/compiler/arm/cgcpu.pas @@ -211,9 +211,16 @@ unit cgcpu; inherited init_register_allocators; { currently, we always save R14, so we can use it } if (target_info.system<>system_arm_darwin) then - rg[R_INTREGISTER]:=trgintcpu.create(R_INTREGISTER,R_SUBWHOLE, - [RS_R0,RS_R1,RS_R2,RS_R3,RS_R12,RS_R4,RS_R5,RS_R6,RS_R7,RS_R8, - RS_R9,RS_R10,RS_R14],first_int_imreg,[]) + begin + if assigned(current_procinfo) and (current_procinfo.framepointer<>NR_R11) then + rg[R_INTREGISTER]:=trgintcpu.create(R_INTREGISTER,R_SUBWHOLE, + [RS_R0,RS_R1,RS_R2,RS_R3,RS_R12,RS_R4,RS_R5,RS_R6,RS_R7,RS_R8, + RS_R9,RS_R10,RS_R11,RS_R14],first_int_imreg,[]) + else + rg[R_INTREGISTER]:=trgintcpu.create(R_INTREGISTER,R_SUBWHOLE, + [RS_R0,RS_R1,RS_R2,RS_R3,RS_R12,RS_R4,RS_R5,RS_R6,RS_R7,RS_R8, + RS_R9,RS_R10,RS_R14],first_int_imreg,[]) + end else { r7 is not available on Darwin, it's used as frame pointer (always, for backtrace support -- also in gcc/clang -> R11 can be used). @@ -253,6 +260,7 @@ unit cgcpu; imm_shift : byte; l : tasmlabel; hr : treference; + imm1, imm2: DWord; begin if not(size in [OS_8,OS_S8,OS_16,OS_S16,OS_32,OS_S32]) then internalerror(2002090902); @@ -261,20 +269,16 @@ unit cgcpu; else if is_shifter_const(not(a),imm_shift) then list.concat(taicpu.op_reg_const(A_MVN,reg,not(a))) { loading of constants with mov and orr } - else if (is_shifter_const(a-byte(a),imm_shift)) then + else if (split_into_shifter_const(a,imm1, imm2)) then begin - list.concat(taicpu.op_reg_const(A_MOV,reg,a-byte(a))); - list.concat(taicpu.op_reg_reg_const(A_ORR,reg,reg,byte(a))); + list.concat(taicpu.op_reg_const(A_MOV,reg, imm1)); + list.concat(taicpu.op_reg_reg_const(A_ORR,reg,reg, imm2)); end - else if (is_shifter_const(a-word(a),imm_shift)) and (is_shifter_const(word(a),imm_shift)) then + { loading of constants with mvn and bic } + else if (split_into_shifter_const(not(a), imm1, imm2)) then begin - list.concat(taicpu.op_reg_const(A_MOV,reg,a-word(a))); - list.concat(taicpu.op_reg_reg_const(A_ORR,reg,reg,word(a))); - end - else if (is_shifter_const(a-(dword(a) shl 8) shr 8,imm_shift)) and (is_shifter_const((dword(a) shl 8) shr 8,imm_shift)) then - begin - list.concat(taicpu.op_reg_const(A_MOV,reg,a-(dword(a) shl 8) shr 8)); - list.concat(taicpu.op_reg_reg_const(A_ORR,reg,reg,(dword(a) shl 8) shr 8)); + list.concat(taicpu.op_reg_const(A_MVN,reg, imm1)); + list.concat(taicpu.op_reg_reg_const(A_BIC,reg,reg, imm2)); end else begin @@ -584,23 +588,34 @@ unit cgcpu; procedure tcgarm.a_op_reg_reg(list : TAsmList; Op: TOpCG; size: TCGSize; src, dst: TRegister); + var + so : tshifterop; begin - case op of - OP_NEG: - list.concat(taicpu.op_reg_reg_const(A_RSB,dst,src,0)); - OP_NOT: - begin + if op = OP_NEG then + list.concat(taicpu.op_reg_reg_const(A_RSB,dst,src,0)) + else if op = OP_NOT then + begin + if size in [OS_8, OS_16, OS_S8, OS_S16] then + begin + shifterop_reset(so); + so.shiftmode:=SM_LSL; + if size in [OS_8, OS_S8] then + so.shiftimm:=24 + else + so.shiftimm:=16; + list.concat(taicpu.op_reg_reg_shifterop(A_MVN,dst,src,so)); + {Using a shift here allows this to be folded into another instruction} + if size in [OS_S8, OS_S16] then + so.shiftmode:=SM_ASR + else + so.shiftmode:=SM_LSR; + list.concat(taicpu.op_reg_reg_shifterop(A_MOV,dst,dst,so)); + end + else list.concat(taicpu.op_reg_reg(A_MVN,dst,src)); - case size of - OS_8 : - a_op_const_reg_reg(list,OP_AND,OS_INT,$ff,dst,dst); - OS_16 : - a_op_const_reg_reg(list,OP_AND,OS_INT,$ffff,dst,dst); - end; - end - else + end + else a_op_reg_reg_reg(list,op,OS_32,src,dst,dst); - end; end; @@ -627,6 +642,17 @@ unit cgcpu; a_op_reg_reg_reg_checkoverflow(list,op,size,src1,src2,dst,false,ovloc); end; + function opshift2shiftmode(op: TOpCg): tshiftmode; + begin + case op of + OP_SHL: Result:=SM_LSL; + OP_SHR: Result:=SM_LSR; + OP_ROR: Result:=SM_ROR; + OP_ROL: Result:=SM_ROR; + OP_SAR: Result:=SM_ASR; + else internalerror(2012070501); + end + end; procedure tcgarm.a_op_const_reg_reg_checkoverflow(list: TAsmList; op: TOpCg; size: tcgsize; a: tcgint; src, dst: tregister;setflags : boolean;var ovloc : tlocation); var @@ -634,6 +660,9 @@ unit cgcpu; tmpreg : tregister; so : tshifterop; l1 : longint; + imm1, imm2: DWord; + + begin ovloc.loc:=LOC_VOID; if {$ifopt R+}(a<>-2147483648) and{$endif} is_shifter_const(-a,shift) then @@ -654,71 +683,22 @@ unit cgcpu; case op of OP_NEG,OP_NOT: internalerror(200308281); - OP_SHL: - begin - if a>32 then - internalerror(200308294); - if a<>0 then - begin - shifterop_reset(so); - so.shiftmode:=SM_LSL; - so.shiftimm:=a; - list.concat(taicpu.op_reg_reg_shifterop(A_MOV,dst,src,so)); - end - else - list.concat(taicpu.op_reg_reg(A_MOV,dst,src)); - end; - OP_ROL: - begin - if a>32 then - internalerror(200308294); - if a<>0 then - begin - shifterop_reset(so); - so.shiftmode:=SM_ROR; - so.shiftimm:=32-a; - list.concat(taicpu.op_reg_reg_shifterop(A_MOV,dst,src,so)); - end - else - list.concat(taicpu.op_reg_reg(A_MOV,dst,src)); - end; - OP_ROR: - begin - if a>32 then - internalerror(200308294); - if a<>0 then - begin - shifterop_reset(so); - so.shiftmode:=SM_ROR; - so.shiftimm:=a; - list.concat(taicpu.op_reg_reg_shifterop(A_MOV,dst,src,so)); - end - else - list.concat(taicpu.op_reg_reg(A_MOV,dst,src)); - end; - OP_SHR: - begin - if a>32 then - internalerror(200308292); - shifterop_reset(so); - if a<>0 then - begin - so.shiftmode:=SM_LSR; - so.shiftimm:=a; - list.concat(taicpu.op_reg_reg_shifterop(A_MOV,dst,src,so)); - end - else - list.concat(taicpu.op_reg_reg(A_MOV,dst,src)); - end; + OP_SHL, + OP_SHR, + OP_ROL, + OP_ROR, OP_SAR: begin if a>32 then - internalerror(200308298); + internalerror(200308294); if a<>0 then begin shifterop_reset(so); - so.shiftmode:=SM_ASR; - so.shiftimm:=a; + so.shiftmode:=opshift2shiftmode(op); + if op = OP_ROL then + so.shiftimm:=32-a + else + so.shiftimm:=a; list.concat(taicpu.op_reg_reg_shifterop(A_MOV,dst,src,so)); end else @@ -787,6 +767,18 @@ unit cgcpu; broader range of shifterconstants.} else if (op = OP_AND) and is_shifter_const(not(dword(a)),shift) then list.concat(taicpu.op_reg_reg_const(A_BIC,dst,src,not(dword(a)))) + else if (op = OP_AND) and split_into_shifter_const(not(dword(a)), imm1, imm2) then + begin + list.concat(taicpu.op_reg_reg_const(A_BIC,dst,src,imm1)); + list.concat(taicpu.op_reg_reg_const(A_BIC,dst,dst,imm2)); + end + else if (op in [OP_ADD, OP_SUB, OP_OR]) and + not(cgsetflags or setflags) and + split_into_shifter_const(a, imm1, imm2) then + begin + list.concat(taicpu.op_reg_reg_const(op_reg_reg_opcg2asmop[op],dst,src,imm1)); + list.concat(taicpu.op_reg_reg_const(op_reg_reg_opcg2asmop[op],dst,dst,imm2)); + end else begin tmpreg:=getintregister(list,size); @@ -809,25 +801,16 @@ unit cgcpu; OP_NEG,OP_NOT, OP_DIV,OP_IDIV: internalerror(200308281); - OP_SHL: - begin - shifterop_reset(so); - so.rs:=src1; - so.shiftmode:=SM_LSL; - list.concat(taicpu.op_reg_reg_shifterop(A_MOV,dst,src2,so)); - end; - OP_SHR: - begin - shifterop_reset(so); - so.rs:=src1; - so.shiftmode:=SM_LSR; - list.concat(taicpu.op_reg_reg_shifterop(A_MOV,dst,src2,so)); - end; - OP_SAR: + OP_SHL, + OP_SHR, + OP_SAR, + OP_ROR: begin + if (op = OP_ROR) and not(size in [OS_32,OS_S32]) then + internalerror(2008072801); shifterop_reset(so); so.rs:=src1; - so.shiftmode:=SM_ASR; + so.shiftmode:=opshift2shiftmode(op); list.concat(taicpu.op_reg_reg_shifterop(A_MOV,dst,src2,so)); end; OP_ROL: @@ -836,19 +819,9 @@ unit cgcpu; internalerror(2008072801); { simulate ROL by ror'ing 32-value } tmpreg:=getintregister(list,OS_32); - list.concat(taicpu.op_reg_const(A_MOV,tmpreg,32)); - list.concat(taicpu.op_reg_reg_reg(A_SUB,src1,tmpreg,src1)); - shifterop_reset(so); - so.rs:=src1; - so.shiftmode:=SM_ROR; - list.concat(taicpu.op_reg_reg_shifterop(A_MOV,dst,src2,so)); - end; - OP_ROR: - begin - if not(size in [OS_32,OS_S32]) then - internalerror(2008072802); + list.concat(taicpu.op_reg_reg_const(A_RSB,tmpreg,src1, 32)); shifterop_reset(so); - so.rs:=src1; + so.rs:=tmpreg; so.shiftmode:=SM_ROR; list.concat(taicpu.op_reg_reg_shifterop(A_MOV,dst,src2,so)); end; @@ -1942,10 +1915,10 @@ unit cgcpu; paraloc1.init; paraloc2.init; paraloc3.init; - paramanager.getintparaloc(pocall_default,1,paraloc1); - paramanager.getintparaloc(pocall_default,2,paraloc2); - paramanager.getintparaloc(pocall_default,3,paraloc3); - a_load_const_cgpara(list,OS_INT,len,paraloc3); + paramanager.getintparaloc(pocall_default,1,voidpointertype,paraloc1); + paramanager.getintparaloc(pocall_default,2,voidpointertype,paraloc2); + paramanager.getintparaloc(pocall_default,3,ptrsinttype,paraloc3); + a_load_const_cgpara(list,OS_SINT,len,paraloc3); a_loadaddr_ref_cgpara(list,dest,paraloc2); a_loadaddr_ref_cgpara(list,source,paraloc1); paramanager.freecgpara(list,paraloc3); @@ -2639,7 +2612,7 @@ unit cgcpu; procedure tcgarm.maybeadjustresult(list: TAsmList; op: TOpCg; size: tcgsize; dst: tregister); const - overflowops = [OP_MUL,OP_SHL,OP_ADD,OP_SUB,OP_NOT,OP_NEG]; + overflowops = [OP_MUL,OP_SHL,OP_ADD,OP_SUB,OP_NEG]; begin if (op in overflowops) and (size in [OS_8,OS_S8,OS_16,OS_S16]) then diff --git a/mips/compiler/arm/cpubase.pas b/mips/compiler/arm/cpubase.pas index 46ca1d2705..fe0fd5c19f 100644 --- a/mips/compiler/arm/cpubase.pas +++ b/mips/compiler/arm/cpubase.pas @@ -314,7 +314,7 @@ unit cpubase; (RS_R4,RS_R5,RS_R6,RS_R7,RS_R8,RS_R9,RS_R10); { this is only for the generic code which is not used for this architecture } - saved_mm_registers : array[0..0] of tsuperregister = (RS_NO); + saved_mm_registers : array[0..0] of tsuperregister = (RS_INVALID); { Required parameter alignment when calling a routine declared as stdcall and cdecl. The alignment value should be the one defined @@ -347,6 +347,7 @@ unit cpubase; function is_pc(const r : tregister) : boolean; {$ifdef USEINLINE}inline;{$endif USEINLINE} function is_shifter_const(d : aint;var imm_shift : byte) : boolean; + function split_into_shifter_const(value : aint;var imm1: dword; var imm2: dword):boolean; function dwarf_reg(r:tregister):shortint; implementation @@ -497,12 +498,6 @@ unit cpubase; end; - function rotl(d : dword;b : byte) : dword; {$ifdef USEINLINE}inline;{$endif USEINLINE} - begin - result:=(d shr (32-b)) or (d shl b); - end; - - function is_shifter_const(d : aint;var imm_shift : byte) : boolean; var i : longint; @@ -523,7 +518,7 @@ unit cpubase; begin for i:=0 to 15 do begin - if (dword(d) and not(rotl($ff,i*2)))=0 then + if (dword(d) and not(roldword($ff,i*2)))=0 then begin imm_shift:=i*2; result:=true; @@ -534,6 +529,30 @@ unit cpubase; result:=false; end; + function split_into_shifter_const(value : aint;var imm1: dword; var imm2: dword) : boolean; + var + d, i, i2: Dword; + begin + Result:=false; + {Thumb2 is not supported (YET?)} + if current_settings.cputype in cpu_thumb2 then exit; + d:=DWord(value); + for i:=0 to 15 do + begin + imm1:=d and rordword($FF, I*2); + imm2:=d and not (imm1); {remove already found bits} + {is the remainder a shifterconst? YAY! we've done it!} + {Could we start from i instead of 0?} + for i2:=0 to 15 do + begin + if (imm2 and not(rordword($FF,i2*2)))=0 then + begin + result:=true; + exit; + end; + end; + end; + end; function dwarf_reg(r:tregister):shortint; begin diff --git a/mips/compiler/arm/cpupara.pas b/mips/compiler/arm/cpupara.pas index 2ab9f9ec2f..2d6f2e5b9d 100644 --- a/mips/compiler/arm/cpupara.pas +++ b/mips/compiler/arm/cpupara.pas @@ -39,7 +39,7 @@ unit cpupara; function get_volatile_registers_mm(calloption : tproccalloption):tcpuregisterset;override; function push_addr_param(varspez:tvarspez;def : tdef;calloption : tproccalloption) : boolean;override; function ret_in_param(def : tdef;calloption : tproccalloption) : boolean;override; - procedure getintparaloc(calloption : tproccalloption; nr : longint;var cgpara:TCGPara);override; + procedure getintparaloc(calloption : tproccalloption; nr : longint; def : tdef; var cgpara : tcgpara);override; function create_paraloc_info(p : tabstractprocdef; side: tcallercallee):longint;override; function create_varargs_paraloc_info(p : tabstractprocdef; varargspara:tvarargsparalist):longint;override; function get_funcretloc(p : tabstractprocdef; side: tcallercallee; def: tdef): tcgpara;override; @@ -79,16 +79,17 @@ unit cpupara; end; - procedure tarmparamanager.getintparaloc(calloption : tproccalloption; nr : longint;var cgpara:TCGPara); + procedure tarmparamanager.getintparaloc(calloption : tproccalloption; nr : longint; def : tdef; var cgpara : tcgpara); var paraloc : pcgparalocation; begin if nr<1 then internalerror(2002070801); cgpara.reset; - cgpara.size:=OS_ADDR; - cgpara.intsize:=sizeof(pint); + cgpara.size:=def_cgsize(def); + cgpara.intsize:=tcgsize2size[cgpara.size]; cgpara.alignment:=std_param_align; + cgpara.def:=def; paraloc:=cgpara.add_location; with paraloc^ do begin @@ -356,12 +357,9 @@ unit cpupara; break; end; - if (hp.varspez in [vs_var,vs_out]) or - push_addr_param(hp.varspez,paradef,p.proccalloption) or - is_open_array(paradef) or - is_array_of_const(paradef) then + if push_addr_param(hp.varspez,paradef,p.proccalloption) then begin - paradef:=voidpointertype; + paradef:=getpointerdef(paradef); loc:=LOC_REGISTER; paracgsize := OS_ADDR; paralen := tcgsize2size[OS_ADDR]; @@ -384,7 +382,8 @@ unit cpupara; if (paracgsize=OS_NO) then begin paracgsize:=OS_ADDR; - paralen := tcgsize2size[OS_ADDR]; + paralen:=tcgsize2size[OS_ADDR]; + paradef:=voidpointertype; end; end end; @@ -392,6 +391,7 @@ unit cpupara; hp.paraloc[side].size:=paracgsize; hp.paraloc[side].Alignment:=std_param_align; hp.paraloc[side].intsize:=paralen; + hp.paraloc[side].def:=paradef; firstparaloc:=true; {$ifdef EXTDEBUG} @@ -587,38 +587,8 @@ unit cpupara; paraloc : pcgparalocation; retcgsize : tcgsize; begin - result.init; - result.alignment:=get_para_align(p.proccalloption); - { void has no location } - if is_void(def) then - begin - paraloc:=result.add_location; - result.size:=OS_NO; - result.intsize:=0; - paraloc^.size:=OS_NO; - paraloc^.loc:=LOC_VOID; - exit; - end; - { Constructors return self instead of a boolean } - if (p.proctypeoption=potype_constructor) then - begin - retcgsize:=OS_ADDR; - result.intsize:=sizeof(pint); - end - else - begin - retcgsize:=def_cgsize(def); - result.intsize:=def.size; - end; - result.size:=retcgsize; - { Return is passed as var parameter } - if ret_in_param(def,p.proccalloption) then - begin - paraloc:=result.add_location; - paraloc^.loc:=LOC_REFERENCE; - paraloc^.size:=retcgsize; - exit; - end; + if set_common_funcretloc_info(p,def,retcgsize,result) then + exit; paraloc:=result.add_location; { Return in FPU register? } diff --git a/mips/compiler/arm/cpupi.pas b/mips/compiler/arm/cpupi.pas index c5c6a92eed..2815b09c6b 100644 --- a/mips/compiler/arm/cpupi.pas +++ b/mips/compiler/arm/cpupi.pas @@ -50,7 +50,7 @@ unit cpupi; aasmtai,aasmdata, tgobj, symconst,symsym,paramgr, - cgbase, + cgbase,cgutils, cgobj; procedure tarmprocinfo.set_first_temp_offset; diff --git a/mips/compiler/arm/narminl.pas b/mips/compiler/arm/narminl.pas index e23b726232..951698165a 100644 --- a/mips/compiler/arm/narminl.pas +++ b/mips/compiler/arm/narminl.pas @@ -49,6 +49,7 @@ interface procedure second_sin_real; override; } procedure second_prefetch; override; + procedure second_abs_long; override; private procedure load_fpu_location(out singleprec: boolean); end; @@ -59,14 +60,14 @@ implementation uses globtype,systems, cutils,verbose,globals,fmodule, - cpuinfo, + cpuinfo, defutil, symconst,symdef, aasmbase,aasmtai,aasmdata,aasmcpu, cgbase,cgutils, pass_1,pass_2, cpubase,paramgr, nbas,ncon,ncal,ncnv,nld, - tgobj,ncgutil,cgobj,cg64f32,rgobj,rgcpu,cgcpu; + tgobj,ncgutil,cgobj,cg64f32,rgobj,rgcpu,cgcpu, hlcgobj; {***************************************************************************** tarminlinenode @@ -338,6 +339,21 @@ implementation end; end; + procedure tarminlinenode.second_abs_long; + var + hregister : tregister; + opsize : tcgsize; + hp : taicpu; + begin + secondpass(left); + opsize:=def_cgsize(left.resultdef); + hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,left.resultdef,left.resultdef,true); + hregister:=cg.getintregister(current_asmdata.CurrAsmList,opsize); + location:=left.location; + location.register:=cg.getintregister(current_asmdata.CurrAsmList,opsize); + current_asmdata.CurrAsmList.concat(setoppostfix(taicpu.op_reg_reg(A_MOV,location.register,left.location.register), PF_S)); + current_asmdata.CurrAsmList.concat(setcondition(taicpu.op_reg_reg_const(A_RSB,location.register,location.register, 0), C_MI)); + end; begin cinlinenode:=tarminlinenode; diff --git a/mips/compiler/arm/narmmat.pas b/mips/compiler/arm/narmmat.pas index a2e244fd47..b18b9c5509 100644 --- a/mips/compiler/arm/narmmat.pas +++ b/mips/compiler/arm/narmmat.pas @@ -42,6 +42,10 @@ interface procedure second_float;override; end; + tarmshlshrnode = class(tcgshlshrnode) + procedure second_64bit;override; + function first_shlshr64bitint: tnode; override; + end; implementation @@ -350,9 +354,142 @@ implementation end; end; + function tarmshlshrnode.first_shlshr64bitint: tnode; + begin + result := nil; + end; + + procedure tarmshlshrnode.second_64bit; + var + hreg64hi,hreg64lo,shiftreg:Tregister; + v : TConstExprInt; + l1,l2,l3:Tasmlabel; + so: tshifterop; + + procedure emit_instr(p: tai); + begin + current_asmdata.CurrAsmList.concat(p); + end; + + {Reg1 gets shifted and moved into reg2, and is set to zero afterwards} + procedure shift_more_than_32(reg1, reg2: TRegister; shiftval: Byte ; sm: TShiftMode); + begin + shifterop_reset(so); so.shiftimm:=shiftval - 32; so.shiftmode:=sm; + emit_instr(taicpu.op_reg_reg_shifterop(A_MOV, reg2, reg1, so)); + emit_instr(taicpu.op_reg_const(A_MOV, reg1, 0)); + end; + + procedure shift_less_than_32(reg1, reg2: TRegister; shiftval: Byte; shiftright: boolean); + begin + shifterop_reset(so); so.shiftimm:=shiftval; + if shiftright then so.shiftmode:=SM_LSR else so.shiftmode:=SM_LSL; + emit_instr(taicpu.op_reg_reg_shifterop(A_MOV, reg1, reg1, so)); + + if shiftright then so.shiftmode:=SM_LSL else so.shiftmode:=SM_LSR; + so.shiftimm:=32-shiftval; + emit_instr(taicpu.op_reg_reg_reg_shifterop(A_ORR, reg1, reg1, reg2, so)); + + if shiftright then so.shiftmode:=SM_LSR else so.shiftmode:=SM_LSL; + so.shiftimm:=shiftval; + emit_instr(taicpu.op_reg_reg_shifterop(A_MOV, reg2, reg2, so)); + end; + + procedure shift_by_variable(reg1, reg2, shiftval: TRegister; shiftright: boolean); + var + shiftval2:TRegister; + begin + shifterop_reset(so); + shiftval2:=cg.getintregister(current_asmdata.CurrAsmList,OS_INT); + {Do we shift more than 32 bits?} + emit_instr(setoppostfix(taicpu.op_reg_reg_const(A_RSB, shiftval2, shiftval, 32), PF_S)); + + {This part cares for 32 bits and more} + emit_instr(setcondition(taicpu.op_reg_reg_const(A_SUB, shiftval2, shiftval, 32), C_MI)); + if shiftright then so.shiftmode:=SM_LSR else so.shiftmode:=SM_LSL; + so.rs:=shiftval2; + emit_instr(setcondition(taicpu.op_reg_reg_shifterop(A_MOV, reg2, reg1, so), C_MI)); + + {Less than 32 bits} + so.rs:=shiftval; + emit_instr(setcondition(taicpu.op_reg_reg_shifterop(A_MOV, reg2, reg2, so), C_PL)); + if shiftright then so.shiftmode:=SM_LSL else so.shiftmode:=SM_LSR; + so.rs:=shiftval2; + emit_instr(setcondition(taicpu.op_reg_reg_reg_shifterop(A_ORR, reg2, reg2, reg1, so), C_PL)); + + {Final adjustments} + if shiftright then so.shiftmode:=SM_LSR else so.shiftmode:=SM_LSL; + so.rs:=shiftval; + emit_instr(taicpu.op_reg_reg_shifterop(A_MOV, reg1, reg1, so)); + end; + + begin + location_reset(location,LOC_REGISTER,def_cgsize(resultdef)); + + { load left operator in a register } + hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,left.resultdef,resultdef,false); + hreg64hi:=left.location.register64.reghi; + hreg64lo:=left.location.register64.reglo; + location.register64.reghi:=hreg64hi; + location.register64.reglo:=hreg64lo; + + { shifting by a constant directly coded: } + if (right.nodetype=ordconstn) then + begin + v:=Tordconstnode(right).value and 63; + {Single bit shift} + if v = 1 then + if nodetype=shln then + begin + {Shift left by one by 2 simple 32bit additions} + emit_instr(setoppostfix(taicpu.op_reg_reg_reg(A_ADD, hreg64lo, hreg64lo, hreg64lo), PF_S)); + emit_instr(taicpu.op_reg_reg_reg(A_ADC, hreg64hi, hreg64hi, hreg64hi)); + end + else + begin + {Shift right by first shifting hi by one and then using RRX (rotate right extended), which rotates through the carry} + shifterop_reset(so); so.shiftmode:=SM_LSR; so.shiftimm:=1; + emit_instr(setoppostfix(taicpu.op_reg_reg_shifterop(A_MOV, hreg64hi, hreg64hi, so), PF_S)); + so.shiftmode:=SM_RRX; so.shiftimm:=0; {RRX does NOT have a shift amount} + emit_instr(taicpu.op_reg_reg_shifterop(A_MOV, hreg64lo, hreg64lo, so)); + end + {A 32bit shift just replaces a register and clears the other} + else if v = 32 then + begin + if nodetype=shln then + emit_instr(taicpu.op_reg_const(A_MOV, hreg64hi, 0)) + else + emit_instr(taicpu.op_reg_const(A_MOV, hreg64lo, 0)); + location.register64.reghi:=hreg64lo; + location.register64.reglo:=hreg64hi; + end + {Shift LESS than 32} + else if (v < 32) and (v > 1) then + if nodetype=shln then + shift_less_than_32(hreg64hi, hreg64lo, v.uvalue, false) + else + shift_less_than_32(hreg64lo, hreg64hi, v.uvalue, true) + {More than 32} + else if v > 32 then + if nodetype=shln then + shift_more_than_32(hreg64lo, hreg64hi, v.uvalue, SM_LSL) + else + shift_more_than_32(hreg64hi, hreg64lo, v.uvalue, SM_LSR); + end + else + begin + { force right operators in a register } + hlcg.location_force_reg(current_asmdata.CurrAsmList,right.location,right.resultdef,resultdef,false); + if nodetype = shln then + shift_by_variable(hreg64lo,hreg64hi,right.location.register, false) + else + shift_by_variable(hreg64hi,hreg64lo,right.location.register, true); + end; + end; + begin cmoddivnode:=tarmmoddivnode; cnotnode:=tarmnotnode; cunaryminusnode:=tarmunaryminusnode; + cshlshrnode:=tarmshlshrnode; end. diff --git a/mips/compiler/arm/raarmgas.pas b/mips/compiler/arm/raarmgas.pas index 0ad94a2f20..91b8c816b7 100644 --- a/mips/compiler/arm/raarmgas.pas +++ b/mips/compiler/arm/raarmgas.pas @@ -62,7 +62,7 @@ Unit raarmgas; procinfo, itcpugas, rabase,rautils, - cgbase,cgobj + cgbase,cgutils,cgobj ; diff --git a/mips/compiler/assemble.pas b/mips/compiler/assemble.pas index 689f39f9c3..324fffd672 100644 --- a/mips/compiler/assemble.pas +++ b/mips/compiler/assemble.pas @@ -604,6 +604,14 @@ Implementation Replace(result,'$ASM',maybequoted(AsmFileName)); Replace(result,'$OBJ',maybequoted(ObjFileName)); end; + if (cs_create_pic in current_settings.moduleswitches) then + Replace(result,'$PIC','-KPIC') + else + Replace(result,'$PIC',''); + if (cs_asm_source in current_settings.globalswitches) then + Replace(result,'$NOWARN','') + else + Replace(result,'$NOWARN','-W'); end; diff --git a/mips/compiler/avr/cgcpu.pas b/mips/compiler/avr/cgcpu.pas index 21d0d8a5b5..a7ce99033f 100644 --- a/mips/compiler/avr/cgcpu.pas +++ b/mips/compiler/avr/cgcpu.pas @@ -470,9 +470,9 @@ unit cgcpu; paraloc1.init; paraloc2.init; paraloc3.init; - paramanager.getintparaloc(pocall_default,1,paraloc1); - paramanager.getintparaloc(pocall_default,2,paraloc2); - paramanager.getintparaloc(pocall_default,3,paraloc3); + paramanager.getintparaloc(pocall_default,1,u16inttype,paraloc1); + paramanager.getintparaloc(pocall_default,2,u16inttype,paraloc2); + paramanager.getintparaloc(pocall_default,3,pasbool8type,paraloc3); a_load_const_cgpara(list,OS_8,0,paraloc3); a_load_reg_cgpara(list,OS_16,src,paraloc2); a_load_reg_cgpara(list,OS_16,dst,paraloc1); @@ -1451,10 +1451,10 @@ unit cgcpu; paraloc1.init; paraloc2.init; paraloc3.init; - paramanager.getintparaloc(pocall_default,1,paraloc1); - paramanager.getintparaloc(pocall_default,2,paraloc2); - paramanager.getintparaloc(pocall_default,3,paraloc3); - a_load_const_cgpara(list,OS_INT,len,paraloc3); + paramanager.getintparaloc(pocall_default,1,voidpointertype,paraloc1); + paramanager.getintparaloc(pocall_default,2,voidpointertype,paraloc2); + paramanager.getintparaloc(pocall_default,3,ptrsinttype,paraloc3); + a_load_const_cgpara(list,OS_SINT,len,paraloc3); a_loadaddr_ref_cgpara(list,dest,paraloc2); a_loadaddr_ref_cgpara(list,source,paraloc1); paramanager.freecgpara(list,paraloc3); diff --git a/mips/compiler/avr/cpubase.pas b/mips/compiler/avr/cpubase.pas index 2b02b97751..b0a3ba014f 100644 --- a/mips/compiler/avr/cpubase.pas +++ b/mips/compiler/avr/cpubase.pas @@ -101,11 +101,11 @@ unit cpubase; { Float Super register first and last } first_fpu_supreg = RS_INVALID; - first_fpu_imreg = RS_INVALID; + first_fpu_imreg = 0; { MM Super register first and last } first_mm_supreg = RS_INVALID; - first_mm_imreg = RS_INVALID; + first_mm_imreg = 0; regnumber_count_bsstart = 32; diff --git a/mips/compiler/avr/cpupara.pas b/mips/compiler/avr/cpupara.pas index d313d24896..ae5c5a5996 100644 --- a/mips/compiler/avr/cpupara.pas +++ b/mips/compiler/avr/cpupara.pas @@ -38,7 +38,7 @@ unit cpupara; function get_volatile_registers_fpu(calloption : tproccalloption):tcpuregisterset;override; function push_addr_param(varspez:tvarspez;def : tdef;calloption : tproccalloption) : boolean;override; function ret_in_param(def : tdef;calloption : tproccalloption) : boolean;override; - procedure getintparaloc(calloption : tproccalloption; nr : longint;var cgpara:TCGPara);override; + procedure getintparaloc(calloption : tproccalloption; nr : longint; def : tdef; var cgpara : tcgpara);override; function create_paraloc_info(p : tabstractprocdef; side: tcallercallee):longint;override; function create_varargs_paraloc_info(p : tabstractprocdef; varargspara:tvarargsparalist):longint;override; function get_funcretloc(p : tabstractprocdef; side: tcallercallee; def: tdef): tcgpara;override; @@ -69,16 +69,17 @@ unit cpupara; end; - procedure tavrparamanager.getintparaloc(calloption : tproccalloption; nr : longint;var cgpara:TCGPara); + procedure tavrparamanager.getintparaloc(calloption : tproccalloption; nr : longint; def : tdef; var cgpara : tcgpara); var paraloc : pcgparalocation; begin if nr<1 then internalerror(2002070801); cgpara.reset; - cgpara.size:=OS_INT; - cgpara.intsize:=tcgsize2size[OS_INT]; + cgpara.size:=def_cgsize(def); + cgpara.intsize:=tcgsize2size[cgpara.size]; cgpara.alignment:=std_param_align; + cgpara.def:=def; paraloc:=cgpara.add_location; with paraloc^ do begin @@ -271,12 +272,9 @@ unit cpupara; break; end; - if (hp.varspez in [vs_var,vs_out]) or - push_addr_param(hp.varspez,paradef,p.proccalloption) or - is_open_array(paradef) or - is_array_of_const(paradef) then + if push_addr_param(hp.varspez,paradef,p.proccalloption) then begin - paradef:=voidpointertype; + paradef:=getpointerdef(paradef); loc:=LOC_REGISTER; paracgsize := OS_ADDR; paralen := tcgsize2size[OS_ADDR]; @@ -299,7 +297,8 @@ unit cpupara; if (paracgsize=OS_NO) then begin paracgsize:=OS_ADDR; - paralen := tcgsize2size[OS_ADDR]; + paralen:=tcgsize2size[OS_ADDR]; + paradef:=voidpointertype; end; end end; @@ -307,6 +306,7 @@ unit cpupara; hp.paraloc[side].size:=paracgsize; hp.paraloc[side].Alignment:=std_param_align; hp.paraloc[side].intsize:=paralen; + hp.paraloc[side].def:=paradef; {$ifdef EXTDEBUG} if paralen=0 then @@ -415,38 +415,8 @@ unit cpupara; retcgsize : tcgsize; paraloc : pcgparalocation; begin - result.init; - result.alignment:=get_para_align(p.proccalloption); - { void has no location } - if is_void(def) then - begin - paraloc:=result.add_location; - result.size:=OS_NO; - result.intsize:=0; - paraloc^.size:=OS_NO; - paraloc^.loc:=LOC_VOID; - exit; - end; - { Constructors return self instead of a boolean } - if (p.proctypeoption=potype_constructor) then - begin - retcgsize:=OS_ADDR; - result.intsize:=sizeof(pint); - end - else - begin - retcgsize:=def_cgsize(def); - result.intsize:=def.size; - end; - result.size:=retcgsize; - { Return is passed as var parameter } - if ret_in_param(def,p.proccalloption) then - begin - paraloc:=result.add_location; - paraloc^.loc:=LOC_REFERENCE; - paraloc^.size:=retcgsize; - exit; - end; + if set_common_funcretloc_info(p,def,retcgsize,result) then + exit; paraloc:=result.add_location; { Return in FPU register? } diff --git a/mips/compiler/avr/raavrgas.pas b/mips/compiler/avr/raavrgas.pas index 3cefacaedf..967f9e742b 100644 --- a/mips/compiler/avr/raavrgas.pas +++ b/mips/compiler/avr/raavrgas.pas @@ -59,7 +59,7 @@ Unit raavrgas; procinfo, itcpugas, rabase,rautils, - cgbase,cgobj + cgbase,cgutils,cgobj ; diff --git a/mips/compiler/cgbase.pas b/mips/compiler/cgbase.pas index 26a1ac6aee..abd47adf6d 100644 --- a/mips/compiler/cgbase.pas +++ b/mips/compiler/cgbase.pas @@ -220,7 +220,6 @@ interface end; { Set type definition for registers } - tcpuregisterset = set of byte; tsuperregisterset = array[byte] of set of byte; pmmshuffle = ^tmmshuffle; @@ -264,10 +263,6 @@ interface { Invalid register number } RS_INVALID = high(tsuperregister); - { Maximum number of cpu registers per register type, - this must fit in tcpuregisterset } - maxcpuregister = 32; - tcgsize2size : Array[tcgsize] of integer = { integer values } (0,1,2,4,8,16,1,2,4,8,16, diff --git a/mips/compiler/cgobj.pas b/mips/compiler/cgobj.pas index 674623deb5..ec1cc20bde 100644 --- a/mips/compiler/cgobj.pas +++ b/mips/compiler/cgobj.pas @@ -390,21 +390,6 @@ unit cgobj; } procedure g_concatcopy_unaligned(list : TAsmList;const source,dest : treference;len : tcgint);virtual; - {# This should emit the opcode to a shortrstring from the source - to destination. - - @param(source Source reference of copy) - @param(dest Destination reference of copy) - - } - procedure g_copyshortstring(list : TAsmList;const source,dest : treference;len:byte); - procedure g_copyvariant(list : TAsmList;const source,dest : treference); - - procedure g_incrrefcount(list : TAsmList;t: tdef; const ref: treference); - procedure g_array_rtti_helper(list: TAsmList; t: tdef; const ref: treference; const highloc: tlocation; - const name: string); - procedure g_initialize(list : TAsmList;t : tdef;const ref : treference); - procedure g_finalize(list : TAsmList;t : tdef;const ref : treference); {# Generates overflow checking code for a node } procedure g_overflowcheck(list: TAsmList; const Loc:tlocation; def:tdef); virtual;abstract; @@ -2066,239 +2051,6 @@ implementation end; - procedure tcg.g_copyshortstring(list : TAsmList;const source,dest : treference;len:byte); - var - cgpara1,cgpara2,cgpara3 : TCGPara; - begin - cgpara1.init; - cgpara2.init; - cgpara3.init; - paramanager.getintparaloc(pocall_default,1,cgpara1); - paramanager.getintparaloc(pocall_default,2,cgpara2); - paramanager.getintparaloc(pocall_default,3,cgpara3); - a_loadaddr_ref_cgpara(list,dest,cgpara3); - a_loadaddr_ref_cgpara(list,source,cgpara2); - a_load_const_cgpara(list,OS_INT,len,cgpara1); - paramanager.freecgpara(list,cgpara3); - paramanager.freecgpara(list,cgpara2); - paramanager.freecgpara(list,cgpara1); - allocallcpuregisters(list); - a_call_name(list,'FPC_SHORTSTR_ASSIGN',false); - deallocallcpuregisters(list); - cgpara3.done; - cgpara2.done; - cgpara1.done; - end; - - - procedure tcg.g_copyvariant(list : TAsmList;const source,dest : treference); - var - cgpara1,cgpara2 : TCGPara; - begin - cgpara1.init; - cgpara2.init; - paramanager.getintparaloc(pocall_default,1,cgpara1); - paramanager.getintparaloc(pocall_default,2,cgpara2); - a_loadaddr_ref_cgpara(list,dest,cgpara2); - a_loadaddr_ref_cgpara(list,source,cgpara1); - paramanager.freecgpara(list,cgpara2); - paramanager.freecgpara(list,cgpara1); - allocallcpuregisters(list); - a_call_name(list,'FPC_VARIANT_COPY_OVERWRITE',false); - deallocallcpuregisters(list); - cgpara2.done; - cgpara1.done; - end; - - - procedure tcg.g_incrrefcount(list : TAsmList;t: tdef; const ref: treference); - var - href : treference; - incrfunc : string; - cgpara1,cgpara2 : TCGPara; - begin - cgpara1.init; - cgpara2.init; - paramanager.getintparaloc(pocall_default,1,cgpara1); - paramanager.getintparaloc(pocall_default,2,cgpara2); - if is_interfacecom_or_dispinterface(t) then - incrfunc:='FPC_INTF_INCR_REF' - else if is_ansistring(t) then - incrfunc:='FPC_ANSISTR_INCR_REF' - else if is_widestring(t) then - incrfunc:='FPC_WIDESTR_INCR_REF' - else if is_unicodestring(t) then - incrfunc:='FPC_UNICODESTR_INCR_REF' - else if is_dynamic_array(t) then - incrfunc:='FPC_DYNARRAY_INCR_REF' - else - incrfunc:=''; - { call the special incr function or the generic addref } - if incrfunc<>'' then - begin - { widestrings aren't ref. counted on all platforms so we need the address - to create a real copy } - if is_widestring(t) then - a_loadaddr_ref_cgpara(list,ref,cgpara1) - else - { these functions get the pointer by value } - a_load_ref_cgpara(list,OS_ADDR,ref,cgpara1); - paramanager.freecgpara(list,cgpara1); - allocallcpuregisters(list); - a_call_name(list,incrfunc,false); - deallocallcpuregisters(list); - end - else - begin - if is_open_array(t) then - InternalError(201103054); - reference_reset_symbol(href,RTTIWriter.get_rtti_label(t,initrtti),0,sizeof(pint)); - a_loadaddr_ref_cgpara(list,href,cgpara2); - a_loadaddr_ref_cgpara(list,ref,cgpara1); - paramanager.freecgpara(list,cgpara1); - paramanager.freecgpara(list,cgpara2); - allocallcpuregisters(list); - a_call_name(list,'FPC_ADDREF',false); - deallocallcpuregisters(list); - end; - cgpara2.done; - cgpara1.done; - end; - - - procedure tcg.g_array_rtti_helper(list: TAsmList; t: tdef; const ref: treference; const highloc: tlocation; const name: string); - var - cgpara1,cgpara2,cgpara3: TCGPara; - href: TReference; - hreg, lenreg: TRegister; - begin - cgpara1.init; - cgpara2.init; - cgpara3.init; - paramanager.getintparaloc(pocall_default,1,cgpara1); - paramanager.getintparaloc(pocall_default,2,cgpara2); - paramanager.getintparaloc(pocall_default,3,cgpara3); - - reference_reset_symbol(href,RTTIWriter.get_rtti_label(t,initrtti),0,sizeof(pint)); - if highloc.loc=LOC_CONSTANT then - a_load_const_cgpara(list,OS_INT,highloc.value+1,cgpara3) - else - begin - if highloc.loc in [LOC_REGISTER,LOC_CREGISTER] then - hreg:=highloc.register - else - begin - hreg:=getintregister(list,OS_INT); - a_load_loc_reg(list,OS_INT,highloc,hreg); - end; - { increment, converts high(x) to length(x) } - lenreg:=getintregister(list,OS_INT); - a_op_const_reg_reg(list,OP_ADD,OS_INT,1,hreg,lenreg); - a_load_reg_cgpara(list,OS_INT,lenreg,cgpara3); - end; - - a_loadaddr_ref_cgpara(list,href,cgpara2); - a_loadaddr_ref_cgpara(list,ref,cgpara1); - paramanager.freecgpara(list,cgpara1); - paramanager.freecgpara(list,cgpara2); - paramanager.freecgpara(list,cgpara3); - allocallcpuregisters(list); - a_call_name(list,name,false); - deallocallcpuregisters(list); - - cgpara3.done; - cgpara2.done; - cgpara1.done; - end; - - procedure tcg.g_initialize(list : TAsmList;t : tdef;const ref : treference); - var - href : treference; - cgpara1,cgpara2 : TCGPara; - begin - cgpara1.init; - cgpara2.init; - if is_ansistring(t) or - is_widestring(t) or - is_unicodestring(t) or - is_interfacecom_or_dispinterface(t) or - is_dynamic_array(t) then - a_load_const_ref(list,OS_ADDR,0,ref) - else if t.typ=variantdef then - begin - paramanager.getintparaloc(pocall_default,1,cgpara1); - a_loadaddr_ref_cgpara(list,ref,cgpara1); - paramanager.freecgpara(list,cgpara1); - allocallcpuregisters(list); - a_call_name(list,'FPC_VARIANT_INIT',false); - deallocallcpuregisters(list); - end - else - begin - if is_open_array(t) then - InternalError(201103052); - paramanager.getintparaloc(pocall_default,1,cgpara1); - paramanager.getintparaloc(pocall_default,2,cgpara2); - reference_reset_symbol(href,RTTIWriter.get_rtti_label(t,initrtti),0,sizeof(pint)); - a_loadaddr_ref_cgpara(list,href,cgpara2); - a_loadaddr_ref_cgpara(list,ref,cgpara1); - paramanager.freecgpara(list,cgpara1); - paramanager.freecgpara(list,cgpara2); - allocallcpuregisters(list); - a_call_name(list,'FPC_INITIALIZE',false); - deallocallcpuregisters(list); - end; - cgpara1.done; - cgpara2.done; - end; - - - procedure tcg.g_finalize(list : TAsmList;t : tdef;const ref : treference); - var - href : treference; - cgpara1,cgpara2 : TCGPara; - decrfunc : string; - begin - if is_interfacecom_or_dispinterface(t) then - decrfunc:='FPC_INTF_DECR_REF' - else if is_ansistring(t) then - decrfunc:='FPC_ANSISTR_DECR_REF' - else if is_widestring(t) then - decrfunc:='FPC_WIDESTR_DECR_REF' - else if is_unicodestring(t) then - decrfunc:='FPC_UNICODESTR_DECR_REF' - else if t.typ=variantdef then - decrfunc:='FPC_VARIANT_CLEAR' - else - begin - cgpara1.init; - cgpara2.init; - if is_open_array(t) then - InternalError(201103051); - paramanager.getintparaloc(pocall_default,1,cgpara1); - paramanager.getintparaloc(pocall_default,2,cgpara2); - reference_reset_symbol(href,RTTIWriter.get_rtti_label(t,initrtti),0,sizeof(pint)); - a_loadaddr_ref_cgpara(list,href,cgpara2); - a_loadaddr_ref_cgpara(list,ref,cgpara1); - paramanager.freecgpara(list,cgpara1); - paramanager.freecgpara(list,cgpara2); - if is_dynamic_array(t) then - g_call(list,'FPC_DYNARRAY_CLEAR') - else - g_call(list,'FPC_FINALIZE'); - cgpara1.done; - cgpara2.done; - exit; - end; - cgpara1.init; - paramanager.getintparaloc(pocall_default,1,cgpara1); - a_loadaddr_ref_cgpara(list,ref,cgpara1); - paramanager.freecgpara(list,cgpara1); - g_call(list,decrfunc); - cgpara1.done; - end; - - procedure tcg.g_overflowCheck_loc(List:TAsmList;const Loc:TLocation;def:TDef;ovloc : tlocation); begin g_overflowCheck(list,loc,def); @@ -2329,8 +2081,8 @@ implementation current_asmdata.getjumplabel(oklabel); a_cmp_const_reg_label(list,OS_ADDR,OC_NE,0,reg,oklabel); cgpara1.init; - paramanager.getintparaloc(pocall_default,1,cgpara1); - a_load_const_cgpara(list,OS_INT,tcgint(210),cgpara1); + paramanager.getintparaloc(pocall_default,1,s32inttype,cgpara1); + a_load_const_cgpara(list,OS_S32,tcgint(210),cgpara1); paramanager.freecgpara(list,cgpara1); a_call_name(list,'FPC_HANDLEERROR',false); a_label(list,oklabel); @@ -2346,10 +2098,10 @@ implementation begin cgpara1.init; cgpara2.init; - paramanager.getintparaloc(pocall_default,1,cgpara1); - paramanager.getintparaloc(pocall_default,2,cgpara2); + paramanager.getintparaloc(pocall_default,1,voidpointertype,cgpara1); if (cs_check_object in current_settings.localswitches) then begin + paramanager.getintparaloc(pocall_default,2,voidpointertype,cgpara2); reference_reset_symbol(hrefvmt,current_asmdata.RefAsmSymbol(objdef.vmt_mangledname),0,sizeof(pint)); a_loadaddr_ref_cgpara(list,hrefvmt,cgpara2); a_load_reg_cgpara(list,OS_ADDR,reg,cgpara1); @@ -2406,7 +2158,7 @@ implementation { do getmem call } cgpara1.init; - paramanager.getintparaloc(pocall_default,1,cgpara1); + paramanager.getintparaloc(pocall_default,1,ptruinttype,cgpara1); a_load_reg_cgpara(list,OS_INT,sizereg,cgpara1); paramanager.freecgpara(list,cgpara1); allocallcpuregisters(list); @@ -2420,11 +2172,11 @@ implementation cgpara1.init; cgpara2.init; cgpara3.init; - paramanager.getintparaloc(pocall_default,1,cgpara1); - paramanager.getintparaloc(pocall_default,2,cgpara2); - paramanager.getintparaloc(pocall_default,3,cgpara3); + paramanager.getintparaloc(pocall_default,1,voidpointertype,cgpara1); + paramanager.getintparaloc(pocall_default,2,voidpointertype,cgpara2); + paramanager.getintparaloc(pocall_default,3,ptrsinttype,cgpara3); { load size } - a_load_reg_cgpara(list,OS_INT,sizereg,cgpara3); + a_load_reg_cgpara(list,OS_SINT,sizereg,cgpara3); { load destination } a_load_reg_cgpara(list,OS_ADDR,destreg,cgpara2); { load source } @@ -2447,7 +2199,7 @@ implementation begin { do move call } cgpara1.init; - paramanager.getintparaloc(pocall_default,1,cgpara1); + paramanager.getintparaloc(pocall_default,1,voidpointertype,cgpara1); { load source } a_load_loc_cgpara(list,l,cgpara1); paramanager.freecgpara(list,cgpara1); @@ -2507,12 +2259,19 @@ implementation for r:=low(saved_mm_registers) to high(saved_mm_registers) do begin - if saved_mm_registers[r] in rg[R_MMREGISTER].used_in_proc then + { the array has to be declared even if no MM registers are saved + (such as with SSE on i386), and since 0-element arrays don't + exist, they contain a single RS_INVALID element in that case + } + if saved_mm_registers[r]<>RS_INVALID then begin - a_loadmm_reg_ref(list,OS_VECTOR,OS_VECTOR,newreg(R_MMREGISTER,saved_mm_registers[r],R_SUBNONE),href,nil); - inc(href.offset,tcgsize2size[OS_VECTOR]); + if saved_mm_registers[r] in rg[R_MMREGISTER].used_in_proc then + begin + a_loadmm_reg_ref(list,OS_VECTOR,OS_VECTOR,newreg(R_MMREGISTER,saved_mm_registers[r],R_SUBNONE),href,nil); + inc(href.offset,tcgsize2size[OS_VECTOR]); + end; + include(rg[R_MMREGISTER].preserved_by_proc,saved_mm_registers[r]); end; - include(rg[R_MMREGISTER].preserved_by_proc,saved_mm_registers[r]); end; end; end; diff --git a/mips/compiler/cgutils.pas b/mips/compiler/cgutils.pas index 60a185c26f..76c60805fd 100644 --- a/mips/compiler/cgutils.pas +++ b/mips/compiler/cgutils.pas @@ -32,7 +32,17 @@ unit cgutils; aasmbase, cpubase,cgbase; + const + { implementation of max function using only functionality that can be + evaluated as a constant expression by the compiler -- this is + basically maxcpureg = max(max(first_int_imreg,first_fpu_imreg),first_mm_imreg)-1 } + tmpmaxcpufpuintreg = first_int_imreg + ((first_fpu_imreg - first_int_imreg) * ord(first_int_imreg < first_fpu_imreg)); + maxcpuregister = (tmpmaxcpufpuintreg + ((first_mm_imreg - tmpmaxcpufpuintreg) * ord(tmpmaxcpufpuintreg < first_mm_imreg)))-1; + type + { Set type definition for cpuregisters } + tcpuregisterset = set of 0..maxcpuregister; + {$ifdef jvm} tarrayreftype = (art_none,art_indexreg,art_indexref,art_indexconst); {$endif jvm} diff --git a/mips/compiler/cutils.pas b/mips/compiler/cutils.pas index dc41ac209a..177d064a65 100644 --- a/mips/compiler/cutils.pas +++ b/mips/compiler/cutils.pas @@ -813,27 +813,11 @@ implementation { return if value is a power of 2. And if correct return the power } - var - hl : int64; - i : longint; begin - if value and (value - 1) <> 0 then - begin - ispowerof2 := false; - exit - end; - hl:=1; - ispowerof2:=true; - for i:=0 to 63 do - begin - if hl=value then - begin - power:=i; - exit; - end; - hl:=hl shl 1; - end; - ispowerof2:=false; + if (value = 0) or (value and (value - 1) <> 0) then + exit(false); + power:=BsfQWord(value); + result:=true; end; diff --git a/mips/compiler/dbgstabs.pas b/mips/compiler/dbgstabs.pas index 103cba1c87..2057de8ceb 100644 --- a/mips/compiler/dbgstabs.pas +++ b/mips/compiler/dbgstabs.pas @@ -149,11 +149,38 @@ implementation uses SysUtils,cutils,cfileutl, globals,globtype,verbose,constexp, - defutil, - cpuinfo,cpubase,paramgr, + defutil, cgutils, parabase, + cpuinfo,cpubase,cpupi,paramgr, aasmbase,procinfo, finput,fmodule,ppu; + + const + current_procdef : tprocdef = nil; + + function GetOffsetStr(reference : TReference) : string; + begin +{$ifdef MIPS} + if (reference.index=NR_STACK_POINTER_REG) or + (reference.base=NR_STACK_POINTER_REG) then + GetOffsetStr:=tostr(reference.offset + - mips_extra_offset(current_procdef)) + else +{$endif MIPS} + GetOffsetStr:=tostr(reference.offset); + end; + + function GetParaOffsetStr(reference : TCGParaReference) : string; + begin +{$ifdef MIPS} + if reference.index=NR_STACK_POINTER_REG then + GetParaOffsetStr:=tostr(reference.offset + - mips_extra_offset(current_procdef)) + else +{$endif MIPS} + GetParaOffsetStr:=tostr(reference.offset); + end; + function GetSymName(Sym : TSymEntry) : string; begin if Not (cs_stabs_preservecase in current_settings.globalswitches) then @@ -734,15 +761,15 @@ implementation begin {$ifdef cpu64bitaddr} ss:=def_stabstr_evaluate(def,'s${savesize}HANDLE:$1,0,32;MODE:$1,32,32;RECSIZE:$2,64,64;'+ - '_PRIVATE:ar$1;1;64;$3,128,256;USERDATA:ar$1;1;16;$3,384,128;'+ - 'NAME:ar$1;0;255;$4,512,2048;;',[def_stab_number(s32inttype), + '_PRIVATE:ar$1;1;64;$3,128,256;USERDATA:ar$1;1;32;$3,384,256;'+ + 'NAME:ar$1;0;255;$4,640,2048;;',[def_stab_number(s32inttype), def_stab_number(s64inttype), def_stab_number(u8inttype), def_stab_number(cansichartype)]); {$else cpu64bitaddr} ss:=def_stabstr_evaluate(def,'s${savesize}HANDLE:$1,0,32;MODE:$1,32,32;RECSIZE:$1,64,32;'+ - '_PRIVATE:ar$1;1;32;$3,96,256;USERDATA:ar$1;1;16;$2,352,128;'+ - 'NAME:ar$1;0;255;$3,480,2048;;',[def_stab_number(s32inttype), + '_PRIVATE:ar$1;1;32;$3,96,256;USERDATA:ar$1;1;32;$2,352,256;'+ + 'NAME:ar$1;0;255;$3,608,2048;;',[def_stab_number(s32inttype), def_stab_number(u8inttype), def_stab_number(cansichartype)]); {$endif cpu64bitaddr} @@ -1052,6 +1079,7 @@ implementation var hs : ansistring; templist : TAsmList; + prev_procdef : tprocdef; begin if not(def.in_currentunit) or { happens for init procdef of units without init section } @@ -1060,6 +1088,8 @@ implementation { mark as used so the local type defs also be written } def.dbg_state:=dbg_state_used; + prev_procdef:=current_procdef; + current_procdef:=def; templist:=gen_procdef_endsym_stabs(def); current_asmdata.asmlists[al_procedures].insertlistafter(def.procendtai,templist); @@ -1090,11 +1120,11 @@ implementation hs:='X'; templist.concat(Tai_stab.create(stabsdir,strpnew( '"'+GetSymName(def.procsym)+':'+hs+def_stab_number(def.returndef)+'",'+ - base_stabs_str(localvarsymref_stab,'0','0',tostr(tabstractnormalvarsym(def.funcretsym).localloc.reference.offset))))); + base_stabs_str(localvarsymref_stab,'0','0',getoffsetstr(tabstractnormalvarsym(def.funcretsym).localloc.reference))))); if (m_result in current_settings.modeswitches) then templist.concat(Tai_stab.create(stabsdir,strpnew( '"RESULT:'+hs+def_stab_number(def.returndef)+'",'+ - base_stabs_str(localvarsymref_stab,'0','0',tostr(tabstractnormalvarsym(def.funcretsym).localloc.reference.offset))))); + base_stabs_str(localvarsymref_stab,'0','0',getoffsetstr(tabstractnormalvarsym(def.funcretsym).localloc.reference))))); end; end; @@ -1102,6 +1132,7 @@ implementation current_asmdata.asmlists[al_procedures].insertlistbefore(def.procstarttai,templist); templist.free; + current_procdef:=prev_procdef; end; @@ -1256,7 +1287,7 @@ implementation LOC_REFERENCE : { offset to ebp => will not work if the framepointer is esp so some optimizing will make things harder to debug } - ss:=sym_stabstr_evaluate(sym,'"${name}:$1",'+base_stabs_str(localvarsymref_stab,'0','${line}','$2'),[st,tostr(sym.localloc.reference.offset)]) + ss:=sym_stabstr_evaluate(sym,'"${name}:$1",'+base_stabs_str(localvarsymref_stab,'0','${line}','$2'),[st,getoffsetstr(sym.localloc.reference)]) else internalerror(2003091814); end; @@ -1411,7 +1442,7 @@ implementation begin if (sym.localloc.loc=LOC_REFERENCE) then ss:=sym_stabstr_evaluate(sym,'"pvmt:p$1",'+base_stabs_str(localvarsymref_stab,'0','0','$2'), - [def_stab_number(pvmttype),tostr(sym.localloc.reference.offset)]) + [def_stab_number(pvmttype),getoffsetstr(sym.localloc.reference)]) else begin regidx:=findreg_by_number(sym.localloc.register); @@ -1427,7 +1458,7 @@ implementation c:='p'; if (sym.localloc.loc=LOC_REFERENCE) then ss:=sym_stabstr_evaluate(sym,'"$$t:$1",'+base_stabs_str(localvarsymref_stab,'0','0','$2'), - [c+def_stab_number(tprocdef(sym.owner.defowner).struct),tostr(sym.localloc.reference.offset)]) + [c+def_stab_number(tprocdef(sym.owner.defowner).struct),getoffsetstr(sym.localloc.reference)]) else begin if (c='p') then @@ -1481,14 +1512,15 @@ implementation if not(sym.paraloc[calleeside].location^.loc in [LOC_REFERENCE,LOC_CREFERENCE]) then ss:=get_appendsym_paravar_reg(sym,c,st,sym.paraloc[calleeside].location^.register) else - ss:=sym_stabstr_evaluate(sym,'"${name}:$1",'+base_stabs_str(localvarsymref_stab,'0','${line}','$2'),[c+st,tostr(sym.paraloc[calleeside].location^.reference.offset)]); + ss:=sym_stabstr_evaluate(sym,'"${name}:$1",'+base_stabs_str(localvarsymref_stab,'0','${line}','$2'), + [c+st,getparaoffsetstr(sym.paraloc[calleeside].location^.reference)]); write_sym_stabstr(list,sym,ss); { second stab has no parameter specifier } c:=''; end; { offset to ebp => will not work if the framepointer is esp so some optimizing will make things harder to debug } - ss:=sym_stabstr_evaluate(sym,'"${name}:$1",'+base_stabs_str(paravarsymref_stab,'0','${line}','$2'),[c+st,tostr(sym.localloc.reference.offset)]) + ss:=sym_stabstr_evaluate(sym,'"${name}:$1",'+base_stabs_str(paravarsymref_stab,'0','${line}','$2'),[c+st,getoffsetstr(sym.localloc.reference)]) end; else internalerror(2003091814); diff --git a/mips/compiler/defcmp.pas b/mips/compiler/defcmp.pas index bc50dd2e29..b8267a01b5 100644 --- a/mips/compiler/defcmp.pas +++ b/mips/compiler/defcmp.pas @@ -1533,13 +1533,18 @@ implementation doconv:=tc_variant_2_interface; eq:=te_convert_l2; end - { ugly, but delphi allows it } + { ugly, but delphi allows it (enables typecasting ordinals/ + enums of any size to pointer-based object defs) } {Â in Java enums /are/ class instances, and hence such - typecasts must not be treated as integer-like conversions + typecasts must not be treated as integer-like conversions; + arbitrary constants cannot be converted into classes/ + pointer-based values either on the JVM -> always return + false and let it be handled by the regular explicit type + casting code } - else if ((not(target_info.system in systems_jvm) and - (def_from.typ=enumdef)) or - (def_from.typ=orddef)) and + else if (not(target_info.system in systems_jvm) and + ((def_from.typ=enumdef) or + (def_from.typ=orddef))) and (m_delphi in current_settings.modeswitches) and (cdo_explicit in cdoptions) then begin diff --git a/mips/compiler/fpcdefs.inc b/mips/compiler/fpcdefs.inc index 5374c4949b..d19cb94077 100644 --- a/mips/compiler/fpcdefs.inc +++ b/mips/compiler/fpcdefs.inc @@ -107,6 +107,7 @@ {$define cpumm} {$define cpurox} {$define cpurefshaveindexreg} + {$define fpc_compiler_has_fixup_jmps} {$endif powerpc} {$ifdef powerpc64} @@ -117,6 +118,7 @@ {$define cpumm} {$define cpurox} {$define cpurefshaveindexreg} + {$define fpc_compiler_has_fixup_jmps} {$endif powerpc64} {$ifdef arm} @@ -170,20 +172,32 @@ {$ifdef mipsel} {$define mips} +{$else not mipsel} + { Define both mips and mipseb if mipsel is not defined + but mips cpu is wanted. } + {$ifdef mipseb} + {$define mips} + {$endif mipseb} + {$ifdef mips} + {$define mipseb} + {$endif mips} {$endif mipsel} -{$ifdef mipseb} - {$define mips} -{$endif mipseb} + {$ifdef mips} - {$define cpu32bit} - {$define cpu32bitalu} - {$define cpu32bitaddr} + {$ifndef mips64} + {$define cpu32bit} + {$define cpu32bitalu} + {$define cpu32bitaddr} + {$else} + {$error mips64 not yet supported} + {$endif} { define cpuflags} {$define cputargethasfixedstack} {$define cpurequiresproperalignment} { define cpumm} {$define cpurefshaveindexreg} + {$define fpc_compiler_has_fixup_jmps} {$endif mips} {$ifdef jvm} diff --git a/mips/compiler/fppu.pas b/mips/compiler/fppu.pas index a01f646ee8..fb16cc2bfe 100644 --- a/mips/compiler/fppu.pas +++ b/mips/compiler/fppu.pas @@ -719,8 +719,6 @@ var hp : tinputfile; begin sources_avail:=(flags and uf_release) = 0; - if not sources_avail then - exit; is_main:=true; main_dir:=''; while not ppufile.endofentry do @@ -728,73 +726,78 @@ var hs:=ppufile.getstring; orgfiletime:=ppufile.getlongint; temp_dir:=''; - if (flags and uf_in_library)<>0 then - begin - sources_avail:=false; - temp:=' library'; - end - else if pos('Macro ',hs)=1 then - begin - { we don't want to find this file } - { but there is a problem with file indexing !! } - temp:=''; - end - else - begin - { check the date of the source files: - 1 path of ppu - 2 path of main source - 3 current dir - 4 include/unit path } - Source_Time:=GetNamedFileTime(path+hs); - found:=false; - if Source_Time<>-1 then - hs:=path+hs - else - if not(is_main) then + if sources_avail then + begin + if (flags and uf_in_library)<>0 then begin - Source_Time:=GetNamedFileTime(main_dir+hs); - if Source_Time<>-1 then - hs:=main_dir+hs; - end; - if Source_Time=-1 then - Source_Time:=GetNamedFileTime(hs); - if (Source_Time=-1) then + sources_avail:=false; + temp:=' library'; + end + else if pos('Macro ',hs)=1 then begin - if is_main then - found:=unitsearchpath.FindFile(hs,true,temp_dir) - else - found:=includesearchpath.FindFile(hs,true,temp_dir); - if found then - begin - Source_Time:=GetNamedFileTime(temp_dir); - if Source_Time<>-1 then - hs:=temp_dir; - end; - end; - if Source_Time<>-1 then + { we don't want to find this file } + { but there is a problem with file indexing !! } + temp:=''; + end + else begin - if is_main then - main_dir:=ExtractFilePath(hs); - temp:=' time '+filetimestring(source_time); - if (orgfiletime<>-1) and - (source_time<>orgfiletime) then + { check the date of the source files: + 1 path of ppu + 2 path of main source + 3 current dir + 4 include/unit path } + Source_Time:=GetNamedFileTime(path+hs); + found:=false; + if Source_Time<>-1 then + hs:=path+hs + else + if not(is_main) then begin - do_compile:=true; - recompile_reason:=rr_sourcenewer; - Message2(unit_u_source_modified,hs,ppufilename,@queuecomment); - temp:=temp+' *'; + Source_Time:=GetNamedFileTime(main_dir+hs); + if Source_Time<>-1 then + hs:=main_dir+hs; end; - end - else - begin - sources_avail:=false; - temp:=' not found'; + if Source_Time=-1 then + Source_Time:=GetNamedFileTime(hs); + if (Source_Time=-1) then + begin + if is_main then + found:=unitsearchpath.FindFile(hs,true,temp_dir) + else + found:=includesearchpath.FindFile(hs,true,temp_dir); + if found then + begin + Source_Time:=GetNamedFileTime(temp_dir); + if Source_Time<>-1 then + hs:=temp_dir; + end; + end; + if Source_Time<>-1 then + begin + if is_main then + main_dir:=ExtractFilePath(hs); + temp:=' time '+filetimestring(source_time); + if (orgfiletime<>-1) and + (source_time<>orgfiletime) then + begin + do_compile:=true; + recompile_reason:=rr_sourcenewer; + Message2(unit_u_source_modified,hs,ppufilename,@queuecomment); + temp:=temp+' *'; + end; + end + else + begin + sources_avail:=false; + temp:=' not found'; + end; + hp:=tdosinputfile.create(hs); + { the indexing is wrong here PM } + sourcefiles.register_file(hp); end; - hp:=tdosinputfile.create(hs); - { the indexing is wrong here PM } - sourcefiles.register_file(hp); - end; + end + else + temp:=' not available'; if is_main then begin mainsource:=hs; diff --git a/mips/compiler/globals.pas b/mips/compiler/globals.pas index 4c41b4c7d8..c0fffb3e73 100644 --- a/mips/compiler/globals.pas +++ b/mips/compiler/globals.pas @@ -117,8 +117,11 @@ interface type - { this is written to ppus during token recording for generics so it must be packed } - tsettings = packed record + { this is written to ppus during token recording for generics, + it used to required to be packed, + but this requirement is now obsolete, + as the fields are written one by one. PM 2012-06-13 } + tsettings = record alignment : talignmentinfo; globalswitches : tglobalswitches; targetswitches : ttargetswitches; diff --git a/mips/compiler/globtype.pas b/mips/compiler/globtype.pas index f00730c832..e562792b91 100644 --- a/mips/compiler/globtype.pas +++ b/mips/compiler/globtype.pas @@ -212,7 +212,16 @@ interface { for the JVM target: generate integer array initializations via string constants in order to reduce the generated code size (Java routines are limited to 64kb of bytecode) } - ts_compact_int_array_init + ts_compact_int_array_init, + { for the JVM target: intialize enum fields in constructors with the + enum class instance corresponding to ordinal value 0 (not done by + default because this initialization can only be performed after the + inherited constructors have run, and if they call a virtual method + of the current class, then this virtual method may already have + initialized that field with another value and the constructor + initialization will result in data loss } + ts_jvm_enum_field_init + ); ttargetswitches = set of ttargetswitch; @@ -269,7 +278,8 @@ interface TargetSwitchStr : array[ttargetswitch] of string[19] = ('', 'SMALLTOC', - 'COMPACTINTARRAYINIT'); + 'COMPACTINTARRAYINIT', + 'ENUMFIELDINIT'); { switches being applied to all CPUs at the given level } genericlevel1optimizerswitches = [cs_opt_level1]; diff --git a/mips/compiler/hlcg2ll.pas b/mips/compiler/hlcg2ll.pas index 0086d212fc..1376cbbdb2 100644 --- a/mips/compiler/hlcg2ll.pas +++ b/mips/compiler/hlcg2ll.pas @@ -150,7 +150,7 @@ unit hlcg2ll; @param(tosize type of the pointer that we get as a result) @param(r reference to get address from) } - procedure a_loadaddr_ref_cgpara(list : TAsmList;fromsize, tosize : tdef;const r : treference;const cgpara : TCGPara);override; + procedure a_loadaddr_ref_cgpara(list : TAsmList;fromsize : tdef;const r : treference;const cgpara : TCGPara);override; procedure a_call_name(list : TAsmList;pd : tprocdef;const s : TSymStr; weak: boolean);override; procedure a_call_reg(list : TAsmList;pd : tabstractprocdef;reg : tregister);override; @@ -278,21 +278,6 @@ unit hlcg2ll; } procedure g_concatcopy_unaligned(list : TAsmList;size: tdef; const source,dest : treference);override; - {# This should emit the opcode to a shortrstring from the source - to destination. - - @param(source Source reference of copy) - @param(dest Destination reference of copy) - - } - procedure g_copyshortstring(list : TAsmList;const source,dest : treference;strdef:tstringdef);override; - procedure g_copyvariant(list : TAsmList;const source,dest : treference;vardef:tvariantdef);override; - - procedure g_incrrefcount(list : TAsmList;t: tdef; const ref: treference);override; - procedure g_array_rtti_helper(list: TAsmList; t: tdef; const ref: treference; const highloc: tlocation; - const name: string);override; - procedure g_initialize(list : TAsmList;t : tdef;const ref : treference);override; - procedure g_finalize(list : TAsmList;t : tdef;const ref : treference);override; {# Generates overflow checking code for a node } procedure g_overflowcheck(list: TAsmList; const Loc:tlocation; def:tdef); override; @@ -470,7 +455,7 @@ implementation cg.a_load_loc_cgpara(list,l,cgpara); end; - procedure thlcg2ll.a_loadaddr_ref_cgpara(list: TAsmList; fromsize, tosize: tdef; const r: treference; const cgpara: TCGPara); + procedure thlcg2ll.a_loadaddr_ref_cgpara(list: TAsmList; fromsize: tdef; const r: treference; const cgpara: TCGPara); begin cg.a_loadaddr_ref_cgpara(list,r,cgpara); end; @@ -943,36 +928,6 @@ implementation cg.g_concatcopy_unaligned(list,source,dest,size.size); end; - procedure thlcg2ll.g_copyshortstring(list: TAsmList; const source, dest: treference; strdef: tstringdef); - begin - cg.g_copyshortstring(list,source,dest,strdef.len); - end; - - procedure thlcg2ll.g_copyvariant(list: TAsmList; const source, dest: treference; vardef: tvariantdef); - begin - cg.g_copyvariant(list,source,dest); - end; - - procedure thlcg2ll.g_incrrefcount(list: TAsmList; t: tdef; const ref: treference); - begin - cg.g_incrrefcount(list,t,ref); - end; - - procedure thlcg2ll.g_array_rtti_helper(list: TAsmList; t: tdef; const ref: treference; const highloc: tlocation; const name: string); - begin - cg.g_array_rtti_helper(list, t, ref, highloc, name); - end; - - procedure thlcg2ll.g_initialize(list: TAsmList; t: tdef; const ref: treference); - begin - cg.g_initialize(list,t,ref); - end; - - procedure thlcg2ll.g_finalize(list: TAsmList; t: tdef; const ref: treference); - begin - cg.g_finalize(list,t,ref); - end; - procedure thlcg2ll.g_overflowcheck(list: TAsmList; const Loc: tlocation; def: tdef); begin cg.g_overflowcheck(list,loc,def); diff --git a/mips/compiler/hlcgobj.pas b/mips/compiler/hlcgobj.pas index 5883bb264d..9cb1f8fbff 100644 --- a/mips/compiler/hlcgobj.pas +++ b/mips/compiler/hlcgobj.pas @@ -77,6 +77,16 @@ unit hlcgobj; the cpu specific child cg object have such a method?} function uses_registers(rt:Tregistertype):boolean; inline; + {# Get a specific register.} + procedure getcpuregister(list:TAsmList;r:Tregister);virtual; + procedure ungetcpuregister(list:TAsmList;r:Tregister);virtual; + {# Get multiple registers specified.} + procedure alloccpuregisters(list:TAsmList;rt:Tregistertype;const r:Tcpuregisterset);virtual; + {# Free multiple registers specified.} + procedure dealloccpuregisters(list:TAsmList;rt:Tregistertype;const r:Tcpuregisterset);virtual; + + procedure allocallcpuregisters(list:TAsmList);virtual; + procedure deallocallcpuregisters(list:TAsmList);virtual; procedure do_register_allocation(list:TAsmList;headertai:tai); inline; procedure translate_register(var reg : tregister); inline; @@ -161,7 +171,7 @@ unit hlcgobj; @param(tosize type of the pointer that we get as a result) @param(r reference to get address from) } - procedure a_loadaddr_ref_cgpara(list : TAsmList;fromsize, tosize : tdef;const r : treference;const cgpara : TCGPara);virtual; + procedure a_loadaddr_ref_cgpara(list : TAsmList;fromsize : tdef;const r : treference;const cgpara : TCGPara);virtual; { Remarks: * If a method specifies a size you have only to take care @@ -385,14 +395,14 @@ unit hlcgobj; @param(dest Destination reference of copy) } - procedure g_copyshortstring(list : TAsmList;const source,dest : treference;strdef:tstringdef);virtual;abstract; - procedure g_copyvariant(list : TAsmList;const source,dest : treference;vardef:tvariantdef);virtual;abstract; + procedure g_copyshortstring(list : TAsmList;const source,dest : treference;strdef:tstringdef);virtual; + procedure g_copyvariant(list : TAsmList;const source,dest : treference;vardef:tvariantdef);virtual; - procedure g_incrrefcount(list : TAsmList;t: tdef; const ref: treference);virtual;abstract; - procedure g_initialize(list : TAsmList;t : tdef;const ref : treference);virtual;abstract; - procedure g_finalize(list : TAsmList;t : tdef;const ref : treference);virtual;abstract; + procedure g_incrrefcount(list : TAsmList;t: tdef; const ref: treference);virtual; + procedure g_initialize(list : TAsmList;t : tdef;const ref : treference);virtual; + procedure g_finalize(list : TAsmList;t : tdef;const ref : treference);virtual; procedure g_array_rtti_helper(list: TAsmList; t: tdef; const ref: treference; const highloc: tlocation; - const name: string);virtual;abstract; + const name: string);virtual; {# Generates range checking code. It is to note that this routine does not need to be overridden, @@ -543,7 +553,7 @@ implementation fmodule,export, verbose,defutil,paramgr, symbase,symsym,symtable, - ncon,nld,pass_1,pass_2, + ncon,nld,ncgrtti,pass_1,pass_2, cpuinfo,cgobj,tgobj,cutils,procinfo, ncgutil,ngenutil; @@ -624,6 +634,36 @@ implementation result:=cg.uses_registers(rt); end; + procedure thlcgobj.getcpuregister(list: TAsmList; r: Tregister); + begin + cg.getcpuregister(list,r); + end; + + procedure thlcgobj.ungetcpuregister(list: TAsmList; r: Tregister); + begin + cg.ungetcpuregister(list,r); + end; + + procedure thlcgobj.alloccpuregisters(list: TAsmList; rt: Tregistertype; const r: Tcpuregisterset); + begin + cg.alloccpuregisters(list,rt,r); + end; + + procedure thlcgobj.dealloccpuregisters(list: TAsmList; rt: Tregistertype; const r: Tcpuregisterset); + begin + cg.dealloccpuregisters(list,rt,r); + end; + + procedure thlcgobj.allocallcpuregisters(list: TAsmList); + begin + cg.allocallcpuregisters(list); + end; + + procedure thlcgobj.deallocallcpuregisters(list: TAsmList); + begin + cg.deallocallcpuregisters(list); + end; + procedure thlcgobj.do_register_allocation(list: TAsmList; headertai: tai); begin cg.do_register_allocation(list,headertai); @@ -731,8 +771,8 @@ implementation LOC_FPUREGISTER,LOC_CFPUREGISTER: begin tg.gethltemp(list,size,size.size,tt_normal,ref); - a_load_reg_ref(list,size,size,r,ref); - a_loadfpu_ref_cgpara(list,size,ref,cgpara); + a_load_reg_ref(list,size,cgpara.def,r,ref); + a_loadfpu_ref_cgpara(list,cgpara.def,ref,cgpara); tg.ungettemp(list,ref); end else @@ -810,7 +850,7 @@ implementation end; end; - procedure thlcgobj.a_loadaddr_ref_cgpara(list: TAsmList; fromsize, tosize: tdef; const r: treference; const cgpara: TCGPara); + procedure thlcgobj.a_loadaddr_ref_cgpara(list: TAsmList; fromsize: tdef; const r: treference; const cgpara: TCGPara); var hr : tregister; begin @@ -818,13 +858,13 @@ implementation if cgpara.location^.loc in [LOC_CREGISTER,LOC_REGISTER] then begin paramanager.allocparaloc(list,cgpara.location); - a_loadaddr_ref_reg(list,fromsize,tosize,r,cgpara.location^.register) + a_loadaddr_ref_reg(list,fromsize,cgpara.def,r,cgpara.location^.register) end else begin - hr:=getaddressregister(list,tosize); - a_loadaddr_ref_reg(list,fromsize,tosize,r,hr); - a_load_reg_cgpara(list,tosize,hr,cgpara); + hr:=getaddressregister(list,cgpara.def); + a_loadaddr_ref_reg(list,fromsize,cgpara.def,r,hr); + a_load_reg_cgpara(list,cgpara.def,hr,cgpara); end; end; @@ -1039,7 +1079,7 @@ implementation var fromsubsetregdef, tosubsetregdef: torddef; - tmpreg: tregister; + tmpreg, tmpreg2: tregister; bitmask: aword; stopbit: byte; begin @@ -1047,12 +1087,22 @@ implementation begin fromsubsetregdef:=tcgsize2orddef(fromsreg.subsetregsize); tosubsetregdef:=tcgsize2orddef(tosreg.subsetregsize); - tmpreg:=getintregister(list,tosubsetregdef); - a_load_reg_reg(list,fromsubsetregdef,tosubsetregdef,fromsreg.subsetreg,tmpreg); if (fromsreg.startbit<=tosreg.startbit) then - a_op_const_reg(list,OP_SHL,tosubsetregdef,tosreg.startbit-fromsreg.startbit,tmpreg) + begin + { tosreg may be larger -> use its size to perform the shift } + tmpreg:=getintregister(list,tosubsetregdef); + a_load_reg_reg(list,fromsubsetregdef,tosubsetregdef,fromsreg.subsetreg,tmpreg); + a_op_const_reg(list,OP_SHL,tosubsetregdef,tosreg.startbit-fromsreg.startbit,tmpreg) + end else - a_op_const_reg(list,OP_SHR,tosubsetregdef,fromsreg.startbit-tosreg.startbit,tmpreg); + begin + { fromsreg may be larger -> use its size to perform the shift } + tmpreg:=getintregister(list,fromsubsetregdef); + a_op_const_reg_reg(list,OP_SHR,fromsubsetregdef,fromsreg.startbit-tosreg.startbit,fromsreg.subsetreg,tmpreg); + tmpreg2:=getintregister(list,tosubsetregdef); + a_load_reg_reg(list,fromsubsetregdef,tosubsetregdef,tmpreg,tmpreg2); + tmpreg:=tmpreg2; + end; stopbit:=tosreg.startbit + tosreg.bitlen; // on x86(64), 1 shl 32(64) = 1 instead of 0 if (stopbit<>AIntBits) then @@ -2724,6 +2774,235 @@ implementation g_concatcopy(list,size,source,dest); end; + procedure thlcgobj.g_copyshortstring(list: TAsmList; const source, dest: treference; strdef: tstringdef); + var + cgpara1,cgpara2,cgpara3 : TCGPara; + begin + cgpara1.init; + cgpara2.init; + cgpara3.init; + paramanager.getintparaloc(pocall_default,1,voidpointertype,cgpara1); + paramanager.getintparaloc(pocall_default,2,voidpointertype,cgpara2); + paramanager.getintparaloc(pocall_default,3,s32inttype,cgpara3); + a_loadaddr_ref_cgpara(list,strdef,dest,cgpara3); + a_loadaddr_ref_cgpara(list,strdef,source,cgpara2); + a_load_const_cgpara(list,s32inttype,strdef.len,cgpara1); + paramanager.freecgpara(list,cgpara3); + paramanager.freecgpara(list,cgpara2); + paramanager.freecgpara(list,cgpara1); + g_call_system_proc(list,'fpc_shortstr_assign'); + cgpara3.done; + cgpara2.done; + cgpara1.done; + end; + + procedure thlcgobj.g_copyvariant(list: TAsmList; const source, dest: treference; vardef: tvariantdef); + var + cgpara1,cgpara2 : TCGPara; + pvardata : tdef; + begin + cgpara1.init; + cgpara2.init; + pvardata:=getpointerdef(search_system_type('TVARDATA').typedef); + paramanager.getintparaloc(pocall_default,1,pvardata,cgpara1); + paramanager.getintparaloc(pocall_default,2,pvardata,cgpara2); + a_loadaddr_ref_cgpara(list,vardef,dest,cgpara2); + a_loadaddr_ref_cgpara(list,vardef,source,cgpara1); + paramanager.freecgpara(list,cgpara2); + paramanager.freecgpara(list,cgpara1); + g_call_system_proc(list,'fpc_variant_copy_overwrite'); + cgpara2.done; + cgpara1.done; + end; + + procedure thlcgobj.g_incrrefcount(list: TAsmList; t: tdef; const ref: treference); + var + href : treference; + incrfunc : string; + cgpara1,cgpara2 : TCGPara; + begin + cgpara1.init; + cgpara2.init; + paramanager.getintparaloc(pocall_default,1,voidpointertype,cgpara1); + paramanager.getintparaloc(pocall_default,2,voidpointertype,cgpara2); + if is_interfacecom_or_dispinterface(t) then + incrfunc:='fpc_intf_incr_ref' + else if is_ansistring(t) then + incrfunc:='fpc_ansistr_incr_ref' + else if is_widestring(t) then + incrfunc:='fpc_widestr_incr_ref' + else if is_unicodestring(t) then + incrfunc:='fpc_unicodestr_incr_ref' + else if is_dynamic_array(t) then + incrfunc:='fpc_dynarray_incr_ref' + else + incrfunc:=''; + { call the special incr function or the generic addref } + if incrfunc<>'' then + begin + { widestrings aren't ref. counted on all platforms so we need the address + to create a real copy } + if is_widestring(t) then + a_loadaddr_ref_cgpara(list,t,ref,cgpara1) + else + { these functions get the pointer by value } + a_load_ref_cgpara(list,t,ref,cgpara1); + paramanager.freecgpara(list,cgpara1); + g_call_system_proc(list,incrfunc); + end + else + begin + if is_open_array(t) then + InternalError(201103054); + reference_reset_symbol(href,RTTIWriter.get_rtti_label(t,initrtti),0,sizeof(pint)); + a_loadaddr_ref_cgpara(list,voidpointertype,href,cgpara2); + a_loadaddr_ref_cgpara(list,t,ref,cgpara1); + paramanager.freecgpara(list,cgpara1); + paramanager.freecgpara(list,cgpara2); + g_call_system_proc(list,'fpc_addref'); + end; + cgpara2.done; + cgpara1.done; + end; + + procedure thlcgobj.g_initialize(list: TAsmList; t: tdef; const ref: treference); + var + href : treference; + cgpara1,cgpara2 : TCGPara; + pvardata : tdef; + begin + cgpara1.init; + cgpara2.init; + if is_ansistring(t) or + is_widestring(t) or + is_unicodestring(t) or + is_interfacecom_or_dispinterface(t) or + is_dynamic_array(t) then + a_load_const_ref(list,t,0,ref) + else if t.typ=variantdef then + begin + pvardata:=getpointerdef(search_system_type('TVARDATA').typedef); + paramanager.getintparaloc(pocall_default,1,pvardata,cgpara1); + a_loadaddr_ref_cgpara(list,t,ref,cgpara1); + paramanager.freecgpara(list,cgpara1); + g_call_system_proc(list,'fpc_variant_init'); + end + else + begin + if is_open_array(t) then + InternalError(201103052); + paramanager.getintparaloc(pocall_default,1,voidpointertype,cgpara1); + paramanager.getintparaloc(pocall_default,2,voidpointertype,cgpara2); + reference_reset_symbol(href,RTTIWriter.get_rtti_label(t,initrtti),0,sizeof(pint)); + a_loadaddr_ref_cgpara(list,voidpointertype,href,cgpara2); + a_loadaddr_ref_cgpara(list,t,ref,cgpara1); + paramanager.freecgpara(list,cgpara1); + paramanager.freecgpara(list,cgpara2); + g_call_system_proc(list,'fpc_initialize'); + end; + cgpara1.done; + cgpara2.done; + end; + + procedure thlcgobj.g_finalize(list: TAsmList; t: tdef; const ref: treference); + var + href : treference; + cgpara1,cgpara2 : TCGPara; + paratype : tdef; + decrfunc : string; + dynarr: boolean; + begin + paratype:=getpointerdef(voidpointertype); + if is_interfacecom_or_dispinterface(t) then + decrfunc:='fpc_intf_decr_ref' + else if is_ansistring(t) then + decrfunc:='fpc_ansistr_decr_ref' + else if is_widestring(t) then + decrfunc:='fpc_widestr_decr_ref' + else if is_unicodestring(t) then + decrfunc:='fpc_unicodestr_decr_ref' + else if t.typ=variantdef then + begin + paratype:=getpointerdef(search_system_type('TVARDATA').typedef); + decrfunc:='fpc_variant_clear' + end + else + begin + cgpara1.init; + cgpara2.init; + if is_open_array(t) then + InternalError(201103051); + dynarr:=is_dynamic_array(t); + { fpc_finalize takes a pointer value parameter, fpc_dynarray_clear a + pointer var parameter } + if not dynarr then + paratype:=voidpointertype; + paramanager.getintparaloc(pocall_default,1,paratype,cgpara1); + paramanager.getintparaloc(pocall_default,2,voidpointertype,cgpara2); + reference_reset_symbol(href,RTTIWriter.get_rtti_label(t,initrtti),0,sizeof(pint)); + a_loadaddr_ref_cgpara(list,voidpointertype,href,cgpara2); + a_loadaddr_ref_cgpara(list,t,ref,cgpara1); + paramanager.freecgpara(list,cgpara1); + paramanager.freecgpara(list,cgpara2); + if dynarr then + g_call_system_proc(list,'fpc_dynarray_clear') + else + g_call_system_proc(list,'fpc_finalize'); + cgpara1.done; + cgpara2.done; + exit; + end; + cgpara1.init; + paramanager.getintparaloc(pocall_default,1,paratype,cgpara1); + a_loadaddr_ref_cgpara(list,t,ref,cgpara1); + paramanager.freecgpara(list,cgpara1); + g_call_system_proc(list,decrfunc); + cgpara1.done; + end; + + procedure thlcgobj.g_array_rtti_helper(list: TAsmList; t: tdef; const ref: treference; const highloc: tlocation; const name: string); + var + cgpara1,cgpara2,cgpara3: TCGPara; + href: TReference; + hreg, lenreg: TRegister; + begin + cgpara1.init; + cgpara2.init; + cgpara3.init; + paramanager.getintparaloc(pocall_default,1,voidpointertype,cgpara1); + paramanager.getintparaloc(pocall_default,2,voidpointertype,cgpara2); + paramanager.getintparaloc(pocall_default,3,ptrsinttype,cgpara3); + + reference_reset_symbol(href,RTTIWriter.get_rtti_label(t,initrtti),0,sizeof(pint)); + if highloc.loc=LOC_CONSTANT then + a_load_const_cgpara(list,ptrsinttype,highloc.value+1,cgpara3) + else + begin + if highloc.loc in [LOC_REGISTER,LOC_CREGISTER] then + hreg:=highloc.register + else + begin + hreg:=getintregister(list,ptrsinttype); + a_load_loc_reg(list,ptrsinttype,ptrsinttype,highloc,hreg); + end; + { increment, converts high(x) to length(x) } + lenreg:=getintregister(list,ptrsinttype); + a_op_const_reg_reg(list,OP_ADD,ptrsinttype,1,hreg,lenreg); + a_load_reg_cgpara(list,ptrsinttype,lenreg,cgpara3); + end; + + a_loadaddr_ref_cgpara(list,voidpointertype,href,cgpara2); + a_loadaddr_ref_cgpara(list,t,ref,cgpara1); + paramanager.freecgpara(list,cgpara1); + paramanager.freecgpara(list,cgpara2); + paramanager.freecgpara(list,cgpara3); + g_call_system_proc(list,name); + + cgpara3.done; + cgpara2.done; + cgpara1.done; + end; + procedure thlcgobj.g_rangecheck(list: TAsmList; const l: tlocation; fromdef, todef: tdef); var {$if defined(cpu64bitalu) or defined(cpu32bitalu)} @@ -3201,6 +3480,13 @@ implementation current_filepos:=storepos; end; + + function use_ent : boolean; + begin + use_ent := (target_info.system in [system_mipsel_linux,system_mipseb_linux]) + or (target_info.cpu=cpu_alpha); + end; + procedure thlcgobj.gen_proc_symbol(list: TAsmList); var item, @@ -3234,11 +3520,15 @@ implementation previtem:=item; item := TCmdStrListItem(item.next); end; + if (use_ent) then + list.concat(Tai_ent.create(current_procinfo.procdef.mangledname)); current_procinfo.procdef.procstarttai:=tai(list.last); end; procedure thlcgobj.gen_proc_symbol_end(list: TAsmList); begin + if (use_ent) then + list.concat(Tai_ent_end.create(current_procinfo.procdef.mangledname)); list.concat(Tai_symbol_end.Createname(current_procinfo.procdef.mangledname)); current_procinfo.procdef.procendtai:=tai(list.last); @@ -3600,7 +3890,7 @@ implementation else highloc.loc:=LOC_INVALID; eldef:=tarraydef(tparavarsym(p).vardef).elementdef; - g_array_rtti_helper(list,eldef,href,highloc,'FPC_FINALIZE_ARRAY'); + g_array_rtti_helper(list,eldef,href,highloc,'fpc_finalize_array'); end else g_finalize(list,tparavarsym(p).vardef,href); @@ -3663,7 +3953,7 @@ implementation { open arrays do not contain correct element count in their rtti, the actual count must be passed separately. } eldef:=tarraydef(tparavarsym(p).vardef).elementdef; - g_array_rtti_helper(list,eldef,href,highloc,'FPC_ADDREF_ARRAY'); + g_array_rtti_helper(list,eldef,href,highloc,'fpc_addref_array'); end else g_incrrefcount(list,tparavarsym(p).vardef,href); @@ -3691,7 +3981,7 @@ implementation else highloc.loc:=LOC_INVALID; eldef:=tarraydef(tparavarsym(p).vardef).elementdef; - g_array_rtti_helper(list,eldef,href,highloc,'FPC_INITIALIZE_ARRAY'); + g_array_rtti_helper(list,eldef,href,highloc,'fpc_initialize_array'); end else g_initialize(list,tparavarsym(p).vardef,href); @@ -4022,7 +4312,9 @@ implementation (srsym.typ<>procsym) then Message1(cg_f_unknown_compilerproc,procname); pd:=tprocdef(tprocsym(srsym).procdeflist[0]); + allocallcpuregisters(list); a_call_name(list,pd,pd.mangledname,false); + deallocallcpuregisters(list); end; diff --git a/mips/compiler/htypechk.pas b/mips/compiler/htypechk.pas index a62fff5d57..13f6875242 100644 --- a/mips/compiler/htypechk.pas +++ b/mips/compiler/htypechk.pas @@ -2417,7 +2417,9 @@ implementation ( (count=1) or equal_defs(tprocvardef(currpt.left.resultdef).returndef,def_to) - ) then + ) and + { and if it doesn't require any parameters } + (tprocvardef(currpt.left.resultdef).minparacount=0) then begin releasecurrpt:=true; currpt:=tcallparanode(pt.getcopy); diff --git a/mips/compiler/i386/cpupara.pas b/mips/compiler/i386/cpupara.pas index 0755adabf8..6c904cf451 100644 --- a/mips/compiler/i386/cpupara.pas +++ b/mips/compiler/i386/cpupara.pas @@ -45,7 +45,7 @@ unit cpupara; and if the calling conventions for the helper routines of the rtl are used. } - procedure getintparaloc(calloption : tproccalloption; nr : longint;var cgpara:TCGPara);override; + procedure getintparaloc(calloption : tproccalloption; nr : longint; def : tdef; var cgpara : tcgpara);override; function create_paraloc_info(p : tabstractprocdef; side: tcallercallee):longint;override; function create_varargs_paraloc_info(p : tabstractprocdef; varargspara:tvarargsparalist):longint;override; procedure createtempparaloc(list: TAsmList;calloption : tproccalloption;parasym : tparavarsym;can_use_final_stack_loc : boolean;var cgpara:TCGPara);override; @@ -270,14 +270,15 @@ unit cpupara; end; - procedure ti386paramanager.getintparaloc(calloption : tproccalloption; nr : longint;var cgpara:TCGPara); + procedure ti386paramanager.getintparaloc(calloption : tproccalloption; nr : longint; def : tdef; var cgpara : tcgpara); var paraloc : pcgparalocation; begin cgpara.reset; - cgpara.size:=OS_ADDR; - cgpara.intsize:=sizeof(pint); + cgpara.size:=def_cgsize(def); + cgpara.intsize:=tcgsize2size[cgpara.size]; cgpara.alignment:=get_para_align(calloption); + cgpara.def:=def; paraloc:=cgpara.add_location; with paraloc^ do begin @@ -321,18 +322,6 @@ unit cpupara; paraloc : pcgparalocation; sym: tfieldvarsym; begin - result.init; - result.alignment:=get_para_align(p.proccalloption); - { void has no location } - if is_void(def) then - begin - paraloc:=result.add_location; - result.size:=OS_NO; - result.intsize:=0; - paraloc^.size:=OS_NO; - paraloc^.loc:=LOC_VOID; - exit; - end; { on darwin/i386, if a record has only one field and that field is a single or double, it has to be returned like a single/double } if (target_info.system in [system_i386_darwin,system_i386_iphonesim]) and @@ -342,37 +331,23 @@ unit cpupara; (sym.vardef.typ=floatdef) and (tfloatdef(sym.vardef).floattype in [s32real,s64real]) then def:=sym.vardef; - { Constructors return self instead of a boolean } - if (p.proctypeoption=potype_constructor) then - begin - retcgsize:=OS_ADDR; - result.intsize:=sizeof(pint); - end - else - begin - retcgsize:=def_cgsize(def); - { darwin/x86 requires that results < sizeof(aint) are sign/ } - { zero extended to sizeof(aint) } - if (target_info.system in [system_i386_darwin,system_i386_iphonesim]) and - (side=calleeside) and - (result.intsize>0) and - (result.intsize<sizeof(aint)) then - begin - result.intsize:=sizeof(aint); - retcgsize:=OS_SINT; - end - else - result.intsize:=def.size; - end; - result.size:=retcgsize; - { Return is passed as var parameter } - if ret_in_param(def,p.proccalloption) then + + if set_common_funcretloc_info(p,def,retcgsize,result) then + exit; + + { darwin/x86 requires that results < sizeof(aint) are sign/zero + extended to sizeof(aint) } + if (target_info.system in [system_i386_darwin,system_i386_iphonesim]) and + (side=calleeside) and + (result.intsize>0) and + (result.intsize<sizeof(aint)) then begin - paraloc:=result.add_location; - paraloc^.loc:=LOC_REFERENCE; - paraloc^.size:=retcgsize; - exit; + result.def:=sinttype; + result.intsize:=sizeof(aint); + retcgsize:=OS_SINT; + result.size:=retcgsize; end; + { Return in FPU register? } if def.typ=floatdef then begin @@ -420,6 +395,7 @@ unit cpupara; var i : integer; hp : tparavarsym; + paradef : tdef; paraloc : pcgparalocation; l, paralen, @@ -451,15 +427,17 @@ unit cpupara; (not(p.proccalloption in pushleftright_pocalls) and (i<=paras.count-1)) do begin hp:=tparavarsym(paras[i]); - pushaddr:=push_addr_param(hp.varspez,hp.vardef,p.proccalloption); + paradef:=hp.vardef; + pushaddr:=push_addr_param(hp.varspez,paradef,p.proccalloption); if pushaddr then begin paralen:=sizeof(aint); paracgsize:=OS_ADDR; + paradef:=getpointerdef(paradef); end else begin - paralen:=push_size(hp.varspez,hp.vardef,p.proccalloption); + paralen:=push_size(hp.varspez,paradef,p.proccalloption); { darwin/x86 requires that parameters < sizeof(aint) are sign/ } { zero extended to sizeof(aint) } if (target_info.system in [system_i386_darwin,system_i386_iphonesim]) and @@ -467,15 +445,17 @@ unit cpupara; (paralen > 0) and (paralen < sizeof(aint)) then begin - paralen := sizeof(aint); + paralen:=sizeof(aint); paracgsize:=OS_SINT; + paradef:=sinttype; end else - paracgsize:=def_cgsize(hp.vardef); + paracgsize:=def_cgsize(paradef); end; hp.paraloc[side].reset; hp.paraloc[side].size:=paracgsize; hp.paraloc[side].intsize:=paralen; + hp.paraloc[side].def:=paradef; hp.paraloc[side].Alignment:=paraalign; { Copy to stack? } if (paracgsize=OS_NO) or @@ -553,6 +533,7 @@ unit cpupara; var parareg,parasize:longint); var hp : tparavarsym; + paradef : tdef; paraloc : pcgparalocation; paracgsize : tcgsize; i : integer; @@ -585,14 +566,15 @@ unit cpupara; while true do begin hp:=tparavarsym(paras[i]); + paradef:=hp.vardef; if not(assigned(hp.paraloc[side].location)) then begin - pushaddr:=push_addr_param(hp.varspez,hp.vardef,p.proccalloption); if pushaddr then begin paralen:=sizeof(aint); paracgsize:=OS_ADDR; + paradef:=getpointerdef(paradef); end else begin @@ -602,6 +584,7 @@ unit cpupara; hp.paraloc[side].size:=paracgsize; hp.paraloc[side].intsize:=paralen; hp.paraloc[side].Alignment:=paraalign; + hp.paraloc[side].def:=paradef; { EAX EDX diff --git a/mips/compiler/jvm/cpubase.pas b/mips/compiler/jvm/cpubase.pas index 57e6c46298..ee82ea3ede 100644 --- a/mips/compiler/jvm/cpubase.pas +++ b/mips/compiler/jvm/cpubase.pas @@ -254,7 +254,7 @@ uses ); { this is only for the generic code which is not used for this architecture } - saved_mm_registers : array[0..0] of tsuperregister = (RS_NO); + saved_mm_registers : array[0..0] of tsuperregister = (RS_INVALID); {# Required parameter alignment when calling a routine } diff --git a/mips/compiler/jvm/cpupara.pas b/mips/compiler/jvm/cpupara.pas index 2a63551489..761581f8f6 100644 --- a/mips/compiler/jvm/cpupara.pas +++ b/mips/compiler/jvm/cpupara.pas @@ -42,7 +42,7 @@ interface {Returns a structure giving the information on the storage of the parameter (which must be an integer parameter) @param(nr Parameter number of routine, starting from 1)} - procedure getintparaloc(calloption : tproccalloption; nr : longint;var cgpara : TCGPara);override; + procedure getintparaloc(calloption : tproccalloption; nr : longint; def : tdef; var cgpara : tcgpara);override; function create_paraloc_info(p : TAbstractProcDef; side: tcallercallee):longint;override; function create_varargs_paraloc_info(p : tabstractprocdef; varargspara:tvarargsparalist):longint;override; function get_funcretloc(p : tabstractprocdef; side: tcallercallee; def: tdef): tcgpara;override; @@ -64,9 +64,9 @@ implementation hlcgobj; - procedure TJVMParaManager.GetIntParaLoc(calloption : tproccalloption; nr : longint;var cgpara : tcgpara); + procedure TJVMParaManager.GetIntParaLoc(calloption : tproccalloption; nr : longint; def : tdef; var cgpara : tcgpara); begin - { don't know whether it's an actual integer or a pointer (necessary for cgpara.def) } + { not yet implemented/used } internalerror(2010121001); end; diff --git a/mips/compiler/jvm/hlcgcpu.pas b/mips/compiler/jvm/hlcgcpu.pas index 92f3d2ec56..7e317ae5bc 100644 --- a/mips/compiler/jvm/hlcgcpu.pas +++ b/mips/compiler/jvm/hlcgcpu.pas @@ -1527,7 +1527,7 @@ implementation eleref: treference; begin { only in case of initialisation, we have to set all elements to "empty" } - if name<>'FPC_INITIALIZE_ARRAY' then + if name<>'fpc_initialize_array' then exit; { put array on the stack } a_load_ref_stack(list,java_jlobject,ref,prepare_stack_for_ref(list,ref,false)); @@ -1583,7 +1583,7 @@ implementation not is_dynamic_array(t) then begin dummyloc.loc:=LOC_INVALID; - g_array_rtti_helper(list,tarraydef(t).elementdef,ref,dummyloc,'FPC_INITIALIZE_ARRAY') + g_array_rtti_helper(list,tarraydef(t).elementdef,ref,dummyloc,'fpc_initialize_array') end else if is_record(t) then begin @@ -2128,6 +2128,9 @@ implementation enum instance for 0 if it exists (if not, it remains nil since there is no valid enum value in it) } else if (vs.vardef.typ=enumdef) and + ((vs.typ<>fieldvarsym) or + (tdef(vs.owner.defowner).typ<>objectdef) or + (ts_jvm_enum_field_init in current_settings.targetswitches)) and get_enum_init_val_ref(vs.vardef,initref) then allocate_enum_with_base_ref(list,vs,initref,ref); end; diff --git a/mips/compiler/jvm/njvmld.pas b/mips/compiler/jvm/njvmld.pas index 9c6c7b6fb0..8008b0ff0f 100644 --- a/mips/compiler/jvm/njvmld.pas +++ b/mips/compiler/jvm/njvmld.pas @@ -106,9 +106,12 @@ function tjvmassignmentnode.pass_1: tnode; is_ansistring(tvecnode(target).left.resultdef)) then begin { prevent errors in case of an expression such as - word(str[x]):=1234; + word(unicodestr[x]):=1234; } - inserttypeconv_explicit(right,cwidechartype); + if is_wide_or_unicode_string(tvecnode(target).left.resultdef) then + inserttypeconv_explicit(right,cwidechartype) + else + inserttypeconv_explicit(right,cansichartype); result:=ccallnode.createintern('fpc_'+tstringdef(tvecnode(target).left.resultdef).stringtypname+'_setchar', ccallparanode.create(right, ccallparanode.create(tvecnode(target).right, diff --git a/mips/compiler/link.pas b/mips/compiler/link.pas index bb3acd9d94..f45302de04 100644 --- a/mips/compiler/link.pas +++ b/mips/compiler/link.pas @@ -115,7 +115,8 @@ interface property StaticLibraryList:TFPHashObjectList read FStaticLibraryList; property ImportLibraryList:TFPHashObjectList read FImportLibraryList; procedure DefaultLinkScript;virtual;abstract; - procedure ConcatGenericSections(secnames:string); + procedure ScriptAddGenericSections(secnames:string); + procedure ScriptAddSourceStatements(AddSharedAsStatic:boolean);virtual; public IsSharedLibrary : boolean; UseStabs : boolean; @@ -531,15 +532,11 @@ Implementation end; - procedure AddImportSymbol(const libname,symname,symmangledname:TCmdStr;OrdNr: longint;isvar:boolean); - begin - end; - - procedure TLinker.InitSysInitUnitName; begin end; + function TLinker.MakeExecutable:boolean; begin MakeExecutable:=false; @@ -901,6 +898,35 @@ Implementation end; + procedure TInternalLinker.ScriptAddSourceStatements(AddSharedAsStatic:boolean); + var + s,s2: TCmdStr; + begin + while not ObjectFiles.Empty do + begin + s:=ObjectFiles.GetFirst; + if s<>'' then + LinkScript.Concat('READOBJECT '+MaybeQuoted(s)); + end; + while not StaticLibFiles.Empty do + begin + s:=StaticLibFiles.GetFirst; + if s<>'' then + LinkScript.Concat('READSTATICLIBRARY '+MaybeQuoted(s)); + end; + if not AddSharedAsStatic then + exit; + while not SharedLibFiles.Empty do + begin + S:=SharedLibFiles.GetFirst; + if FindLibraryFile(s,target_info.staticClibprefix,target_info.staticClibext,s2) then + LinkScript.Concat('READSTATICLIBRARY '+MaybeQuoted(s2)) + else + Comment(V_Error,'Import library not found for '+S); + end; + end; + + procedure TInternalLinker.Load_ReadObject(const para:TCmdStr); var objdata : TObjData; @@ -951,7 +977,10 @@ Implementation inc(i); s:=hp.str; if (s='') or (s[1]='#') then - continue; + begin + hp:=TCmdStrListItem(hp.next); + continue; + end; keyword:=Upper(GetToken(s,' ')); para:=GetToken(s,' '); if Trim(s)<>'' then @@ -1037,6 +1066,7 @@ Implementation if (s='') or (s[1]='#') then begin IsHandled^[i]:=true; + hp:=TCmdStrListItem(hp.next); continue; end; handled:=true; @@ -1084,7 +1114,10 @@ Implementation inc(i); s:=hp.str; if (s='') or (s[1]='#') then - continue; + begin + hp:=TCmdStrListItem(hp.next); + continue; + end; handled:=true; keyword:=Upper(GetToken(s,' ')); para:=ParsePara(GetToken(s,' ')); @@ -1136,7 +1169,10 @@ Implementation inc(i); s:=hp.str; if (s='') or (s[1]='#') then - continue; + begin + hp:=TCmdStrListItem(hp.next); + continue; + end; handled:=true; keyword:=Upper(GetToken(s,' ')); para:=ParsePara(GetToken(s,' ')); @@ -1172,7 +1208,10 @@ Implementation inc(i); s:=hp.str; if (s='') or (s[1]='#') then - continue; + begin + hp:=TCmdStrListItem(hp.next); + continue; + end; handled:=true; keyword:=Upper(GetToken(s,' ')); para:=ParsePara(GetToken(s,' ')); @@ -1261,6 +1300,7 @@ Implementation { Calc positions in mem } ParseScript_MemPos; exeoutput.FixupRelocations; + exeoutput.RemoveUnusedExeSymbols; exeoutput.PrintMemoryMap; if ErrorCount>0 then goto myexit; @@ -1335,7 +1375,7 @@ Implementation end; - procedure TInternalLinker.ConcatGenericSections(secnames:string); + procedure TInternalLinker.ScriptAddGenericSections(secnames:string); var secname:string; begin diff --git a/mips/compiler/m68k/cpubase.pas b/mips/compiler/m68k/cpubase.pas index 42979a5dc5..9e8e140d6a 100644 --- a/mips/compiler/m68k/cpubase.pas +++ b/mips/compiler/m68k/cpubase.pas @@ -304,7 +304,7 @@ unit cpubase; saved_standard_address_registers : array[0..3] of tsuperregister = (RS_A2,RS_A3,RS_A4,RS_A5); { this is only for the generic code which is not used for this architecture } - saved_mm_registers : array[0..0] of tsuperregister = (RS_NO); + saved_mm_registers : array[0..0] of tsuperregister = (RS_INVALID); {# Required parameter alignment when calling a routine declared as stdcall and cdecl. The alignment value should be the one defined diff --git a/mips/compiler/m68k/cpupara.pas b/mips/compiler/m68k/cpupara.pas index bf23642a98..1ee1863d55 100644 --- a/mips/compiler/m68k/cpupara.pas +++ b/mips/compiler/m68k/cpupara.pas @@ -41,7 +41,7 @@ unit cpupara; rtl are used. } tm68kparamanager = class(tparamanager) - procedure getintparaloc(calloption : tproccalloption; nr : longint;var cgpara : TCGPara);override; + procedure getintparaloc(calloption : tproccalloption; nr : longint; def : tdef; var cgpara : tcgpara);override; function create_paraloc_info(p : tabstractprocdef; side: tcallercallee):longint;override; function push_addr_param(varspez:tvarspez;def : tdef;calloption : tproccalloption) : boolean;override; function get_funcretloc(p : tabstractprocdef; side: tcallercallee; def: tdef): tcgpara;override; @@ -65,15 +65,17 @@ unit cpupara; cpuinfo,cgutils, defutil; - procedure tm68kparamanager.getintparaloc(calloption : tproccalloption; nr : longint;var cgpara : TCGPara); + procedure tm68kparamanager.getintparaloc(calloption : tproccalloption; nr : longint; def : tdef; var cgpara : tcgpara); var paraloc : pcgparalocation; begin if nr<1 then internalerror(2002070801); cgpara.reset; - cgpara.size:=OS_INT; + cgpara.size:=def_cgsize(def); + cgpara.intsize:=tcgsize2size[cgpara.size]; cgpara.alignment:=std_param_align; + cgpara.def:=def; paraloc:=cgpara.add_location; with paraloc^ do begin @@ -196,38 +198,8 @@ unit cpupara; paraloc : pcgparalocation; retcgsize : tcgsize; begin - result.init; - result.alignment:=get_para_align(p.proccalloption); - { void has no location } - if is_void(def) then - begin - paraloc:=result.add_location; - result.size:=OS_NO; - result.intsize:=0; - paraloc^.size:=OS_NO; - paraloc^.loc:=LOC_VOID; - exit; - end; - { Constructors return self instead of a boolean } - if (p.proctypeoption=potype_constructor) then - begin - retcgsize:=OS_ADDR; - result.intsize:=sizeof(pint); - end - else - begin - retcgsize:=def_cgsize(def); - result.intsize:=def.size; - end; - result.size:=retcgsize; - { Return is passed as var parameter } - if ret_in_param(def,p.proccalloption) then - begin - paraloc:=result.add_location; - paraloc^.loc:=LOC_REFERENCE; - paraloc^.size:=retcgsize; - exit; - end; + if set_common_funcretloc_info(p,def,retcgsize,result) then + exit; paraloc:=result.add_location; { Return in FPU register? } @@ -334,15 +306,12 @@ unit cpupara; break; end; - if (hp.varspez in [vs_var,vs_out]) or - push_addr_param(hp.varspez,paradef,p.proccalloption) or - is_open_array(paradef) or - is_array_of_const(paradef) then + if push_addr_param(hp.varspez,paradef,p.proccalloption) then begin {$ifdef DEBUG_CHARLIE} writeln('loc register'); {$endif DEBUG_CHARLIE} - paradef:=voidpointertype; + paradef:=getpointerdef(paradef); loc:=LOC_REGISTER; paracgsize := OS_ADDR; paralen := tcgsize2size[OS_ADDR]; @@ -367,6 +336,7 @@ unit cpupara; hp.paraloc[side].alignment:=std_param_align; hp.paraloc[side].size:=paracgsize; hp.paraloc[side].intsize:=paralen; + hp.paraloc[side].def:=paradef; if (paralen = 0) then if (paradef.typ = recorddef) then diff --git a/mips/compiler/m68k/ra68kmot.pas b/mips/compiler/m68k/ra68kmot.pas index b61ecbe50b..d2258bcce6 100644 --- a/mips/compiler/m68k/ra68kmot.pas +++ b/mips/compiler/m68k/ra68kmot.pas @@ -99,7 +99,7 @@ Implementation systems, { aasm } cpuinfo,aasmtai,aasmdata,aasmcpu, - cgbase, + cgbase,cgutils, { symtable } symbase,symtype,symsym,symdef,symtable, { pass 1 } diff --git a/mips/compiler/mips/aasmcpu.pas b/mips/compiler/mips/aasmcpu.pas index 065e23d67f..4493fb5abd 100644 --- a/mips/compiler/mips/aasmcpu.pas +++ b/mips/compiler/mips/aasmcpu.pas @@ -28,7 +28,7 @@ interface uses cclasses, globtype, globals, verbose, - aasmbase, aasmsym, aasmtai, + aasmbase, aasmdata, aasmsym, aasmtai, cgbase, cgutils, cpubase, cpuinfo; const @@ -78,11 +78,16 @@ type procedure InitAsm; procedure DoneAsm; + procedure fixup_jmps(list: TAsmList); + function spilling_create_load(const ref: treference; r: tregister): taicpu; function spilling_create_store(r: tregister; const ref: treference): taicpu; implementation + uses + cutils; + {***************************************************************************** taicpu Constructors *****************************************************************************} @@ -452,6 +457,146 @@ procedure DoneAsm; end; +procedure fixup_jmps(list: TAsmList); + var + p,pdelayslot: tai; + newcomment: tai_comment; + newjmp,newnoop: taicpu; + labelpositions: TFPList; + instrpos: ptrint; + l: tasmlabel; + inserted_something: boolean; + begin + // if certainly not enough instructions to cause an overflow, dont bother + if (list.count <= (high(smallint) div 4)) then + exit; + labelpositions := TFPList.create; + p := tai(list.first); + instrpos := 1; + // record label positions + while assigned(p) do + begin + if p.typ = ait_label then + begin + if (tai_label(p).labsym.labelnr >= labelpositions.count) then + labelpositions.count := tai_label(p).labsym.labelnr * 2; + labelpositions[tai_label(p).labsym.labelnr] := pointer(instrpos); + end; + { ait_const is for jump tables } + case p.typ of + ait_instruction: + { probleim here: pseudo-instructions can translate into + several CPU instructions, possibly depending on assembler options, + to obe on safe side, let's assume a mean of two. } + inc(instrpos,2); + ait_const: + begin + if (tai_const(p).consttype<>aitconst_32bit) then + internalerror(2008052101); + inc(instrpos); + end; + end; + p := tai(p.next); + end; + + { If the number of instructions is below limit, we can't overflow either } + if (instrpos <= (high(smallint) div 4)) then + exit; + // check and fix distances + repeat + inserted_something := false; + p := tai(list.first); + instrpos := 1; + while assigned(p) do + begin + case p.typ of + ait_label: + // update labelposition in case it changed due to insertion + // of jumps + begin + // can happen because of newly inserted labels + if (tai_label(p).labsym.labelnr > labelpositions.count) then + labelpositions.count := tai_label(p).labsym.labelnr * 2; + labelpositions[tai_label(p).labsym.labelnr] := pointer(instrpos); + end; + ait_instruction: + begin + inc(instrpos,2); + case taicpu(p).opcode of + A_BA: + if (taicpu(p).oper[0]^.typ = top_ref) and + assigned(taicpu(p).oper[0]^.ref^.symbol) and + (taicpu(p).oper[0]^.ref^.symbol is tasmlabel) and + (labelpositions[tasmlabel(taicpu(p).oper[0]^.ref^.symbol).labelnr] <> NIL) and +{$push} +{$q-} + (ptruint(abs(ptrint(labelpositions[tasmlabel(taicpu(p).oper[0]^.ref^.symbol).labelnr]-instrpos)) - (low(smallint) div 4)) > ptruint((high(smallint) - low(smallint)) div 4)) then +{$pop} + begin + { This is not PIC safe } + taicpu(p).opcode:=A_J; + newcomment:=tai_comment.create(strpnew('fixup_jmps, A_BA changed into A_J')); + list.insertbefore(newcomment,p); + end; + A_BC: + if (taicpu(p).ops=3) and (taicpu(p).oper[2]^.typ = top_ref) and + assigned(taicpu(p).oper[2]^.ref^.symbol) and + (taicpu(p).oper[2]^.ref^.symbol is tasmlabel) and + (labelpositions[tasmlabel(taicpu(p).oper[2]^.ref^.symbol).labelnr] <> NIL) and +{$push} +{$q-} + (ptruint(abs(ptrint(labelpositions[tasmlabel(taicpu(p).oper[2]^.ref^.symbol).labelnr]-instrpos)) - (low(smallint) div 4)) > ptruint((high(smallint) - low(smallint)) div 4)) then +{$pop} + begin + // add a new label after this jump + current_asmdata.getjumplabel(l); + { new label -> may have to increase array size } + if (l.labelnr >= labelpositions.count) then + labelpositions.count := l.labelnr + 10; + { newjmp will be inserted before the label, and it's inserted after } + { plus delay slot } + { the current jump -> instrpos+3 } + labelpositions[l.labelnr] := pointer(instrpos+2*3); + pdelayslot:=tai(p.next); + { We need to insert the new instruction after the delay slot instruction ! } + while assigned(pdelayslot) and (pdelayslot.typ<>ait_instruction) do + pdelayslot:=tai(pdelayslot.next); + + list.insertafter(tai_label.create(l),pdelayslot); + // add a new unconditional jump between this jump and the label + newcomment:=tai_comment.create(strpnew('fixup_jmps, A_BXX changed into A_BNOTXX label;A_J;label:')); + list.insertbefore(newcomment,p); + newjmp := taicpu.op_sym(A_J,taicpu(p).oper[2]^.ref^.symbol); + newjmp.is_jmp := true; + newjmp.fileinfo := taicpu(p).fileinfo; + list.insertafter(newjmp,pdelayslot); + inc(instrpos,2); + { Add a delay slot for new A_J instruction } + newnoop:=taicpu.op_none(A_NOP); + newnoop.fileinfo := taicpu(p).fileinfo; + list.insertafter(newnoop,newjmp); + inc(instrpos,2); + // change the conditional jump to point to the newly inserted label + tasmlabel(taicpu(p).oper[2]^.ref^.symbol).decrefs; + taicpu(p).oper[2]^.ref^.symbol := l; + l.increfs; + // and invert its condition code + taicpu(p).condition := inverse_cond(taicpu(p).condition); + // we inserted an instruction, so will have to check everything again + inserted_something := true; + end; + end; + end; + ait_const: + inc(instrpos); + end; + p := tai(p.next); + end; + until not inserted_something; + labelpositions.free; + end; + + begin cai_cpu := taicpu; cai_align := tai_align; diff --git a/mips/compiler/mips/cgcpu.pas b/mips/compiler/mips/cgcpu.pas index d7e670236e..0482469d88 100644 --- a/mips/compiler/mips/cgcpu.pas +++ b/mips/compiler/mips/cgcpu.pas @@ -27,7 +27,7 @@ interface uses globtype, parabase, - cgbase, cgutils, cgobj, cg64f32, + cgbase, cgutils, cgobj, cg64f32, cpupara, aasmbase, aasmtai, aasmcpu, aasmdata, cpubase, cpuinfo, node, symconst, SymType, symdef, @@ -36,6 +36,7 @@ uses type TCGMIPS = class(tcg) public + procedure init_register_allocators; override; procedure done_register_allocators; override; function getfpuregister(list: tasmlist; size: Tcgsize): Tregister; override; @@ -51,7 +52,6 @@ type procedure a_load_const_cgpara(list: tasmlist; size: tcgsize; a: tcgint; const paraloc: TCGPara); override; procedure a_load_ref_cgpara(list: tasmlist; sz: tcgsize; const r: TReference; const paraloc: TCGPara); override; procedure a_loadaddr_ref_cgpara(list: tasmlist; const r: TReference; const paraloc: TCGPara); override; - procedure a_loadfpu_reg_cgpara(list: tasmlist; size: tcgsize; const r: tregister; const paraloc: TCGPara); override; procedure a_loadfpu_ref_cgpara(list: tasmlist; size: tcgsize; const ref: treference; const paraloc: TCGPara); override; procedure a_call_name(list: tasmlist; const s: string; weak : boolean); override; @@ -508,21 +508,22 @@ procedure TCGMIPS.init_register_allocators; begin inherited init_register_allocators; - if (cs_create_pic in current_settings.moduleswitches) and + { Keep RS_R25, i.e. $t9 for PIC call } + if (cs_create_pic in current_settings.moduleswitches) and assigned(current_procinfo) and (pi_needs_got in current_procinfo.flags) then begin current_procinfo.got := NR_GP; rg[R_INTREGISTER] := Trgcpu.Create(R_INTREGISTER, R_SUBD, [RS_R2,RS_R3,RS_R4,RS_R5,RS_R6,RS_R7,RS_R8,RS_R9, RS_R10,RS_R11,RS_R12,RS_R13,RS_R14,RS_R15,RS_R16,RS_R17,RS_R18,RS_R19, - RS_R20,RS_R21,RS_R22,RS_R23,RS_R24,RS_R25], + RS_R20,RS_R21,RS_R22,RS_R23,RS_R24{,RS_R25}], first_int_imreg, []); end else rg[R_INTREGISTER] := trgcpu.Create(R_INTREGISTER, R_SUBD, [RS_R2,RS_R3,RS_R4,RS_R5,RS_R6,RS_R7,RS_R8,RS_R9, RS_R10,RS_R11,RS_R12,RS_R13,RS_R14,RS_R15,RS_R16,RS_R17,RS_R18,RS_R19, - RS_R20,RS_R21,RS_R22,RS_R23,RS_R24,RS_R25], + RS_R20,RS_R21,RS_R22,RS_R23,RS_R24{,RS_R25}], first_int_imreg, []); { @@ -596,21 +597,21 @@ begin href := r; hloc := paraloc.location; while assigned(hloc) do - begin - paramanager.allocparaloc(list,hloc); - case hloc^.loc of - LOC_REGISTER: - a_load_ref_reg(list, hloc^.size, hloc^.size, href, hloc^.Register); - LOC_FPUREGISTER,LOC_CFPUREGISTER : - a_loadfpu_ref_reg(list,hloc^.size,hloc^.size,href,hloc^.register); - LOC_REFERENCE: - begin - reference_reset_base(href2, hloc^.reference.index, hloc^.reference.offset, sizeof(aint)); - a_load_ref_ref(list, hloc^.size, hloc^.size, href, href2); - end; + begin + paramanager.allocparaloc(list,hloc); + case hloc^.loc of + LOC_REGISTER,LOC_CREGISTER: + a_load_ref_reg(list, hloc^.size, hloc^.size, href, hloc^.Register); + LOC_FPUREGISTER,LOC_CFPUREGISTER : + a_loadfpu_ref_reg(list,hloc^.size,hloc^.size,href,hloc^.register); + LOC_REFERENCE: + begin + reference_reset_base(href2, hloc^.reference.index, hloc^.reference.offset, sizeof(aint)); + a_load_ref_ref(list, hloc^.size, hloc^.size, href, href2); + end else internalerror(200408241); - end; + end; Inc(href.offset, tcgsize2size[hloc^.size]); hloc := hloc^.Next; end; @@ -686,8 +687,18 @@ end; procedure TCGMIPS.a_call_name(list: tasmlist; const s: string; weak: boolean); +var + href: treference; begin - list.concat(taicpu.op_sym(A_JAL,current_asmdata.RefAsmSymbol(s))); + if (cs_create_pic in current_settings.moduleswitches) then + begin + reference_reset(href,sizeof(aint)); + href.symbol:=current_asmdata.RefAsmSymbol(s); + a_loadaddr_ref_reg(list,href,NR_PIC_FUNC); + list.concat(taicpu.op_reg(A_JALR,NR_PIC_FUNC)); + end + else + list.concat(taicpu.op_sym(A_JAL,current_asmdata.RefAsmSymbol(s))); { Delay slot } list.concat(taicpu.op_none(A_NOP)); end; @@ -695,6 +706,9 @@ end; procedure TCGMIPS.a_call_reg(list: tasmlist; Reg: TRegister); begin + if (cs_create_pic in current_settings.moduleswitches) and + (Reg <> NR_PIC_FUNC) then + list.concat(taicpu.op_reg_reg(A_MOVE, reg, NR_PIC_FUNC)); list.concat(taicpu.op_reg(A_JALR, reg)); { Delay slot } list.concat(taicpu.op_none(A_NOP)); @@ -792,7 +806,7 @@ var begin if (tcgsize2size[tosize] < tcgsize2size[fromsize]) or ( - (tcgsize2size[tosize] = tcgsize2size[fromsize]) and (tosize <> fromsize) + (tcgsize2size[tosize] = tcgsize2size[fromsize]) and (tosize <> fromsize) ) or ((fromsize = OS_S8) and (tosize = OS_16)) then begin @@ -851,7 +865,8 @@ begin if (href.base = NR_NO) and (href.index <> NR_NO) then internalerror(200306171); - if (cs_create_pic in current_settings.moduleswitches) and + if ((cs_create_pic in current_settings.moduleswitches) or + (ref.refaddr=addr_pic)) and assigned(href.symbol) then begin tmpreg := r; //GetIntRegister(list, OS_ADDR); @@ -861,6 +876,11 @@ begin tmpref.refaddr := addr_pic; if not (pi_needs_got in current_procinfo.flags) then internalerror(200501161); + if current_procinfo.got=NR_NO then + current_procinfo.got:=NR_GP; + { for addr_pic NR_GP can be implicit or explicit } + if (href.refaddr=addr_pic) and (href.base=current_procinfo.got) then + href.base:=NR_NO; tmpref.base := current_procinfo.got; list.concat(taicpu.op_reg_ref(A_LW, tmpreg, tmpref)); href.symbol := nil; @@ -876,6 +896,8 @@ begin else href.base := tmpreg; end; + if (href.base=NR_NO) and (href.offset=0) then + exit; end; @@ -941,18 +963,19 @@ end; procedure TCGMIPS.a_loadfpu_reg_reg(list: tasmlist; fromsize, tosize: tcgsize; reg1, reg2: tregister); const - FpuMovInstr: array[OS_F32..OS_F64] of TAsmOp = - (A_MOV_S, A_MOV_D); + FpuMovInstr: array[OS_F32..OS_F64,OS_F32..OS_F64] of TAsmOp = + ((A_MOV_S, A_CVT_D_S),(A_CVT_S_D,A_MOV_D)); var instr: taicpu; begin - if reg1 <> reg2 then + if (reg1 <> reg2) or (fromsize<>tosize) then begin - instr := taicpu.op_reg_reg(fpumovinstr[tosize], reg2, reg1); + instr := taicpu.op_reg_reg(fpumovinstr[fromsize,tosize], reg2, reg1); list.Concat(instr); { Notify the register allocator that we have written a move instruction so it can try to eliminate it. } - add_move_instruction(instr); + if (fromsize=tosize) then + add_move_instruction(instr); end; end; @@ -962,7 +985,7 @@ var tmpref: treference; tmpreg: tregister; begin - case tosize of + case fromsize of OS_F32: handle_load_store_fpu(list, False, A_LWC1, reg, ref); OS_F64: @@ -970,6 +993,8 @@ begin else InternalError(2007042701); end; + if tosize<>fromsize then + a_loadfpu_reg_reg(list,fromsize,tosize,reg,reg); end; procedure TCGMIPS.a_loadfpu_reg_ref(list: tasmlist; fromsize, tosize: tcgsize; reg: tregister; const ref: TReference); @@ -977,6 +1002,8 @@ var tmpref: treference; tmpreg: tregister; begin + if tosize<>fromsize then + a_loadfpu_reg_reg(list,fromsize,tosize,reg,reg); case tosize of OS_F32: handle_load_store_fpu(list, True, A_SWC1, reg, ref); @@ -1057,7 +1084,8 @@ var begin case Op of OP_NEG: - list.concat(taicpu.op_reg_reg(A_NEG, dst, src)); + { discard overflow checking } + list.concat(taicpu.op_reg_reg(A_NEGU{A_NEG}, dst, src)); OP_NOT: begin list.concat(taicpu.op_reg_reg(A_NOT, dst, src)); @@ -1275,6 +1303,7 @@ end; ai := taicpu.op_reg_reg_sym(A_BC, reg, tmpreg, l); ai.SetCondition(TOpCmp2AsmCond[cmp_op]); list.concat(ai); + { Delay slot } list.Concat(TAiCpu.Op_none(A_NOP)); end; @@ -1286,6 +1315,7 @@ begin ai := taicpu.op_reg_reg_sym(A_BC, reg2, reg1, l); ai.SetCondition(TOpCmp2AsmCond[cmp_op]); list.concat(ai); + { Delay slot } list.Concat(TAiCpu.Op_none(A_NOP)); end; @@ -1296,6 +1326,7 @@ var begin ai := taicpu.op_sym(A_BA, l); list.concat(ai); + { Delay slot } list.Concat(TAiCpu.Op_none(A_NOP)); end; @@ -1332,17 +1363,21 @@ procedure TCGMIPS.g_proc_entry(list: tasmlist; localsize: longint; nostackframe: var lastintoffset,lastfpuoffset, nextoffset : aint; + i : longint; + ra_save,framesave,gp_save : taicpu; fmask,mask : dword; saveregs : tcpuregisterset; + StoreOp : TAsmOp; href: treference; usesfpr, usesgpr, gotgot : boolean; reg : Tsuperregister; helplist : TAsmList; begin + a_reg_alloc(list,NR_STACK_POINTER_REG); + if nostackframe then exit; - a_reg_alloc(list,NR_STACK_POINTER_REG); if (TMIPSProcinfo(current_procinfo).needs_frame_pointer) then a_reg_alloc(list,NR_FRAME_POINTER_REG); @@ -1356,24 +1391,19 @@ begin fmask:=0; nextoffset:=TMIPSProcInfo(current_procinfo).floatregstart; lastfpuoffset:=LocalSize; - { not sure about how used_in_proc is set, to play safe, we check the even register and save pair if used } - reg := RS_F0; - while reg < RS_F31 do + for reg := RS_F0 to RS_F30 do { to check: what if F30 is double? } begin if reg in (rg[R_FPUREGISTER].used_in_proc-paramanager.get_volatile_registers_fpu(pocall_stdcall)) then begin usesfpr:=true; - fmask:=fmask or (3 shl ord(reg)); + fmask:=fmask or (1 shl ord(reg)); href.offset:=nextoffset; lastfpuoffset:=nextoffset; + if cs_asm_source in current_settings.globalswitches then + helplist.concat(tai_comment.Create(strpnew(std_regname(newreg(R_FPUREGISTER,reg,R_SUBFS))+' register saved.'))); helplist.concat(taicpu.op_reg_ref(A_SWC1,newreg(R_FPUREGISTER,reg,R_SUBFS),href)); inc(nextoffset,4); - href.offset:=nextoffset; - lastfpuoffset:=nextoffset; - helplist.concat(taicpu.op_reg_ref(A_SWC1,newreg(R_FPUREGISTER,reg+1,R_SUBFS),href)); - inc(nextoffset,4); end; - reg := reg + 2; end; usesgpr:=false; @@ -1381,7 +1411,15 @@ begin nextoffset:=TMIPSProcInfo(current_procinfo).intregstart; saveregs:=rg[R_INTREGISTER].used_in_proc-paramanager.get_volatile_registers_int(pocall_stdcall); include(saveregs,RS_R31); + if (TMIPSProcinfo(current_procinfo).needs_frame_pointer) then + include(saveregs,RS_FRAME_POINTER_REG); + if (cs_create_pic in current_settings.moduleswitches) and + (pi_needs_got in current_procinfo.flags) then + include(saveregs,RS_GP); lastintoffset:=LocalSize; + framesave:=nil; + gp_save:=nil; + for reg:=RS_R1 to RS_R31 do begin if reg in saveregs then @@ -1390,35 +1428,161 @@ begin mask:=mask or (1 shl ord(reg)); href.offset:=nextoffset; lastintoffset:=nextoffset; - helplist.concat(taicpu.op_reg_ref(A_SW,newreg(R_INTREGISTER,reg,R_SUBWHOLE),href)); + if (reg=RS_FRAME_POINTER_REG) then + framesave:=taicpu.op_reg_ref(A_SW,newreg(R_INTREGISTER,reg,R_SUBWHOLE),href) + else if (reg=RS_R31) then + ra_save:=taicpu.op_reg_ref(A_SW,newreg(R_INTREGISTER,reg,R_SUBWHOLE),href) + else if (reg=RS_GP) and + (cs_create_pic in current_settings.moduleswitches) and + (pi_needs_got in current_procinfo.flags) then + gp_save:=taicpu.op_const(A_P_CPRESTORE,nextoffset) + else + begin + if cs_asm_source in current_settings.globalswitches then + helplist.concat(tai_comment.Create(strpnew( + std_regname(newreg(R_INTREGISTER,reg,R_SUBWHOLE))+' register saved.'))); + helplist.concat(taicpu.op_reg_ref(A_SW,newreg(R_INTREGISTER,reg,R_SUBWHOLE),href)); + end; inc(nextoffset,4); end; end; + //list.concat(Taicpu.Op_reg_reg_const(A_ADDIU,NR_FRAME_POINTER_REG,NR_STACK_POINTER_REG,current_procinfo.para_stack_size)); list.concat(Taicpu.op_none(A_P_SET_NOMIPS16)); list.concat(Taicpu.op_reg_const_reg(A_P_FRAME,current_procinfo.framepointer,LocalSize,NR_R31)); list.concat(Taicpu.op_const_const(A_P_MASK,mask,-(LocalSize-lastintoffset))); list.concat(Taicpu.op_const_const(A_P_FMASK,Fmask,-(LocalSize-lastfpuoffset))); + if (cs_create_pic in current_settings.moduleswitches) and + (pi_needs_got in current_procinfo.flags) then + begin + list.concat(Taicpu.op_reg(A_P_CPLOAD,NR_PIC_FUNC)); + end; list.concat(Taicpu.op_none(A_P_SET_NOREORDER)); - list.concat(Taicpu.op_none(A_P_SET_NOMACRO)); - if (TMIPSProcinfo(current_procinfo).needs_frame_pointer) then - list.concat(Taicpu.Op_reg_reg(A_MOVE,NR_FRAME_POINTER_REG,NR_STACK_POINTER_REG)); - if (-LocalSize >= simm16lo) and (-LocalSize <= simm16hi) then - list.concat(Taicpu.Op_reg_reg_const(A_ADDIU,NR_STACK_POINTER_REG,NR_STACK_POINTER_REG,-LocalSize)) + begin + list.concat(Taicpu.op_none(A_P_SET_NOMACRO)); + if cs_asm_source in current_settings.globalswitches then + begin + list.concat(tai_comment.Create(strpnew('Stack register updated substract '+tostr(LocalSize)+' for local size'))); + list.concat(tai_comment.Create(strpnew(' 0-'+ + tostr(TMIPSProcInfo(current_procinfo).maxpushedparasize)+' for called function parameters'))); + list.concat(tai_comment.Create(strpnew('Register save area at '+ + tostr(TMIPSProcInfo(current_procinfo).intregstart)))); + list.concat(tai_comment.Create(strpnew('FPU register save area at '+ + tostr(TMIPSProcInfo(current_procinfo).floatregstart)))); + end; + list.concat(Taicpu.Op_reg_reg_const(A_ADDIU,NR_STACK_POINTER_REG,NR_STACK_POINTER_REG,-LocalSize)); + if cs_asm_source in current_settings.globalswitches then + list.concat(tai_comment.Create(strpnew('RA register saved.'))); + list.concat(ra_save); + if assigned(framesave) then + begin + if cs_asm_source in current_settings.globalswitches then + list.concat(tai_comment.Create(strpnew('Frame S8/FP register saved.'))); + list.concat(framesave); + if cs_asm_source in current_settings.globalswitches then + list.concat(tai_comment.Create(strpnew('New frame FP register set to $sp+'+ToStr(LocalSize)))); + list.concat(Taicpu.op_reg_reg_const(A_ADDIU,NR_FRAME_POINTER_REG, + NR_STACK_POINTER_REG,LocalSize)); + end; + end else begin - list.concat(Taicpu.Op_reg_const(A_LI,NR_R1,-LocalSize)); - list.concat(Taicpu.Op_reg_reg_reg(A_ADD,NR_STACK_POINTER_REG,NR_STACK_POINTER_REG,NR_R1)); + if cs_asm_source in current_settings.globalswitches then + list.concat(tai_comment.Create(strpnew('Stack register updated substract '+tostr(LocalSize)+' for local size using R9/t1 register'))); + list.concat(Taicpu.Op_reg_const(A_LI,NR_R9,-LocalSize)); + list.concat(Taicpu.Op_reg_reg_reg(A_ADD,NR_STACK_POINTER_REG,NR_STACK_POINTER_REG,NR_R9)); + if cs_asm_source in current_settings.globalswitches then + list.concat(tai_comment.Create(strpnew('RA register saved.'))); + list.concat(ra_save); + if assigned(framesave) then + begin + if cs_asm_source in current_settings.globalswitches then + list.concat(tai_comment.Create(strpnew('Frame register saved.'))); + list.concat(framesave); + if cs_asm_source in current_settings.globalswitches then + list.concat(tai_comment.Create(strpnew('Frame register updated to $SP+R9 value'))); + list.concat(Taicpu.op_reg_reg_reg(A_SUBU,NR_FRAME_POINTER_REG, + NR_STACK_POINTER_REG,NR_R9)); + end; + { The instructions before are macros that can extend to multiple instructions, + the settings of R9 to -LocalSize surely does, + but the saving of RA and FP also might, and might + even use AT register, which is why we use R9 instead of AT here for -LocalSize } + list.concat(Taicpu.op_none(A_P_SET_NOMACRO)); + end; + if assigned(gp_save) then + begin + if cs_asm_source in current_settings.globalswitches then + list.concat(tai_comment.Create(strpnew('GOT register saved.'))); + list.concat(Taicpu.op_none(A_P_SET_MACRO)); + list.concat(gp_save); + list.concat(Taicpu.op_none(A_P_SET_NOMACRO)); + end; + + with TMIPSProcInfo(current_procinfo) do + begin + href.offset:=0; + //if current_procinfo.framepointer<>NR_STACK_POINTER_REG then + href.base:=NR_FRAME_POINTER_REG; + + for i:=0 to MIPS_MAX_REGISTERS_USED_IN_CALL-1 do + if (register_used[i]) then + begin + reg:=parasupregs[i]; + if register_offset[i]=-1 then + comment(V_warning,'Register parameter has offset -1 in TCGMIPS.g_proc_entry'); + + //if current_procinfo.framepointer=NR_STACK_POINTER_REG then + // href.offset:=register_offset[i]+Localsize + //else + href.offset:=register_offset[i]; +{$ifdef MIPSEL} + if cs_asm_source in current_settings.globalswitches then + list.concat(tai_comment.Create(strpnew('Var '+ + register_name[i]+' Register '+std_regname(newreg(R_INTREGISTER,reg,R_SUBWHOLE)) + +' saved to offset '+tostr(href.offset)))); + list.concat(taicpu.op_reg_ref(A_SW, newreg(R_INTREGISTER,reg,R_SUBWHOLE), href)); +{$else not MIPSEL, for big endian, size matters} + case register_size[i] of + OS_8, + OS_S8: + StoreOp := A_SB; + OS_16, + OS_S16: + StoreOp := A_SH; + OS_32, + OS_NO, + OS_F32, + OS_S32: + StoreOp := A_SW; + OS_F64, + OS_64, + OS_S64: + begin +{$ifdef cpu64bitalu} + StoreOp:=A_SD; +{$else not cpu64bitalu} + StoreOp:= A_SW; +{$endif not cpu64bitalu} + end + else + internalerror(2012061801); + end; + if cs_asm_source in current_settings.globalswitches then + list.concat(tai_comment.Create(strpnew('Var '+ + register_name[i]+' Register '+std_regname(newreg(R_INTREGISTER,reg,R_SUBWHOLE)) + +' saved to offset '+tostr(href.offset)))); + list.concat(taicpu.op_reg_ref(StoreOp, newreg(R_INTREGISTER,reg,R_SUBWHOLE), href)); +{$endif} + end; end; - if (cs_create_pic in current_settings.moduleswitches) and - (pi_needs_got in current_procinfo.flags) then + (pi_needs_got in current_procinfo.flags) then begin current_procinfo.got := NR_GP; end; - list.concatList(helplist); helplist.Free; end; @@ -1446,24 +1610,21 @@ begin href.base:=NR_STACK_POINTER_REG; nextoffset:=TMIPSProcInfo(current_procinfo).floatregstart; - reg := RS_F0; - while reg < RS_F31 do - begin - if reg in (rg[R_FPUREGISTER].used_in_proc-paramanager.get_volatile_registers_fpu(pocall_stdcall)) then - begin - href.offset:=nextoffset; - list.concat(taicpu.op_reg_ref(A_LWC1,newreg(R_FPUREGISTER,reg,R_SUBFS),href)); - inc(nextoffset,4); - href.offset:=nextoffset; - list.concat(taicpu.op_reg_ref(A_LWC1,newreg(R_FPUREGISTER,reg+1,R_SUBFS),href)); - inc(nextoffset,4); - end; - reg := reg + 2; - end; + for reg := RS_F0 to RS_F30 do + begin + if reg in (rg[R_FPUREGISTER].used_in_proc-paramanager.get_volatile_registers_fpu(pocall_stdcall)) then + begin + href.offset:=nextoffset; + list.concat(taicpu.op_reg_ref(A_LWC1,newreg(R_FPUREGISTER,reg,R_SUBFS),href)); + inc(nextoffset,4); + end; + end; nextoffset:=TMIPSProcInfo(current_procinfo).intregstart; saveregs:=rg[R_INTREGISTER].used_in_proc-paramanager.get_volatile_registers_int(pocall_stdcall); include(saveregs,RS_R31); + if (TMIPSProcinfo(current_procinfo).needs_frame_pointer) then + include(saveregs,RS_FRAME_POINTER_REG); for reg:=RS_R1 to RS_R31 do begin if reg in saveregs then @@ -1503,10 +1664,10 @@ begin paraloc1.init; paraloc2.init; paraloc3.init; - paramanager.getintparaloc(pocall_default, 1, paraloc1); - paramanager.getintparaloc(pocall_default, 2, paraloc2); - paramanager.getintparaloc(pocall_default, 3, paraloc3); - a_load_const_cgpara(list, OS_INT, len, paraloc3); + paramanager.getintparaloc(pocall_default, 1, voidpointertype, paraloc1); + paramanager.getintparaloc(pocall_default, 2, voidpointertype, paraloc2); + paramanager.getintparaloc(pocall_default, 3, ptrsinttype, paraloc3); + a_load_const_cgpara(list, OS_SINT, len, paraloc3); a_loadaddr_ref_cgpara(list, dest, paraloc2); a_loadaddr_ref_cgpara(list, Source, paraloc1); paramanager.freecgpara(list, paraloc3); @@ -1677,25 +1838,30 @@ end; procedure TCGMIPS.g_intf_wrapper(list: tasmlist; procdef: tprocdef; const labelname: string; ioffset: longint); - procedure loadvmttor25; + procedure loadvmttorvmt; var href: treference; begin reference_reset_base(href, NR_R2, 0, sizeof(aint)); { return value } - cg.a_load_ref_reg(list, OS_ADDR, OS_ADDR, href, NR_R25); + cg.a_load_ref_reg(list, OS_ADDR, OS_ADDR, href, NR_VMT); end; - procedure op_onr25methodaddr; + procedure op_onrvmtmethodaddr; var href : treference; + reg : tregister; begin if (procdef.extnumber=$ffff) then Internalerror(200006139); { call/jmp vmtoffs(%eax) ; method offs } - reference_reset_base(href, NR_R25, tobjectdef(procdef.struct).vmtmethodoffset(procdef.extnumber), sizeof(aint)); - cg.a_load_ref_reg(list, OS_ADDR, OS_ADDR, href, NR_R25); - list.concat(taicpu.op_reg(A_JR, NR_R25)); + reference_reset_base(href, NR_VMT, tobjectdef(procdef.struct).vmtmethodoffset(procdef.extnumber), sizeof(aint)); + if (cs_create_pic in current_settings.moduleswitches) then + reg:=NR_PIC_FUNC + else + reg:=NR_VMT; + cg.a_load_ref_reg(list, OS_ADDR, OS_ADDR, href, reg); + list.concat(taicpu.op_reg(A_JR, reg)); end; var make_global: boolean; @@ -1726,8 +1892,8 @@ begin if (po_virtualmethod in procdef.procoptions) and not is_objectpascal_helper(procdef.struct) then begin - loadvmttor25; - op_onr25methodaddr; + loadvmttorvmt; + op_onrvmtmethodaddr; end else list.concat(taicpu.op_sym(A_J,current_asmdata.RefAsmSymbol(procdef.mangledname))); @@ -1755,8 +1921,15 @@ procedure TCGMIPS.a_bit_scan_reg_reg(list: TAsmList; reverse: boolean; size: TCG procedure TCg64MPSel.a_load64_reg_ref(list: tasmlist; reg: tregister64; const ref: treference); var tmpref: treference; + tmpreg: tregister; begin { Override this function to prevent loading the reference twice } + if target_info.endian = endian_big then + begin + tmpreg := reg.reglo; + reg.reglo := reg.reghi; + reg.reghi := tmpreg; + end; tmpref := ref; cg.a_load_reg_ref(list, OS_S32, OS_S32, reg.reglo, tmpref); Inc(tmpref.offset, 4); @@ -1767,8 +1940,15 @@ end; procedure TCg64MPSel.a_load64_ref_reg(list: tasmlist; const ref: treference; reg: tregister64); var tmpref: treference; + tmpreg: tregister; begin { Override this function to prevent loading the reference twice } + if target_info.endian = endian_big then + begin + tmpreg := reg.reglo; + reg.reglo := reg.reghi; + reg.reghi := tmpreg; + end; tmpref := ref; cg.a_load_ref_reg(list, OS_S32, OS_S32, tmpref, reg.reglo); Inc(tmpref.offset, 4); diff --git a/mips/compiler/mips/cpubase.pas b/mips/compiler/mips/cpubase.pas index f1dabbe0e9..54898b6c51 100644 --- a/mips/compiler/mips/cpubase.pas +++ b/mips/compiler/mips/cpubase.pas @@ -98,6 +98,9 @@ unit cpubase; regdwarf_table : array[tregisterindex] of shortint = ( {$i rmipsdwf.inc} ); + { registers which may be destroyed by calls } + VOLATILE_INTREGISTERS = [RS_R0..RS_R3,RS_R12..RS_R15]; + VOLATILE_FPUREGISTERS = [RS_F0..RS_F3]; type totherregisterset = set of tregisterindex; @@ -130,17 +133,35 @@ unit cpubase; const max_operands = 4; + maxintregs = 31; - maxfpuregs = 31; + maxfpuregs = 8; + maxaddrregs = 0; {***************************************************************************** Operand Sizes *****************************************************************************} + type + topsize = (S_NO, + S_B,S_W,S_L,S_BW,S_BL,S_WL, + S_IS,S_IL,S_IQ, + S_FS,S_FL,S_FX,S_D,S_Q,S_FV,S_FXX + ); + {***************************************************************************** Constants *****************************************************************************} + const + maxvarregs = 7; + varregs : Array [1..maxvarregs] of tsuperregister = + (RS_R4,RS_R5,RS_R6,RS_R7,RS_R8,RS_R9,RS_R10); + + maxfpuvarregs = 4; + fpuvarregs : Array [1..maxfpuvarregs] of tsuperregister = + (RS_F4,RS_F5,RS_F6,RS_F7); + {***************************************************************************** Default generic sizes *****************************************************************************} @@ -160,13 +181,22 @@ unit cpubase; Generic Register names *****************************************************************************} + + { PIC Code } NR_GP = NR_R28; + NR_PIC_FUNC = NR_R25; + RS_GP = RS_R28; + RS_PIC_FUNC = RS_R25; + + { VMT code } + NR_VMT = NR_R24; + RS_VMT = RS_R24; + NR_SP = NR_R29; NR_S8 = NR_R30; NR_FP = NR_R30; NR_RA = NR_R31; - RS_GP = RS_R28; RS_SP = RS_R29; RS_S8 = RS_R30; RS_FP = RS_R30; @@ -223,7 +253,7 @@ unit cpubase; (RS_NO); { this is only for the generic code which is not used for this architecture } - saved_mm_registers : array[0..0] of tsuperregister = (RS_NO); + saved_mm_registers : array[0..0] of tsuperregister = (RS_INVALID); { Required parameter alignment when calling a routine declared as stdcall and cdecl. The alignment value should be the one defined diff --git a/mips/compiler/mips/cpugas.pas b/mips/compiler/mips/cpugas.pas index a3807882e4..1f36324508 100644 --- a/mips/compiler/mips/cpugas.pas +++ b/mips/compiler/mips/cpugas.pas @@ -31,6 +31,7 @@ unit cpugas; type TMIPSGNUAssembler = class(TGNUassembler) + nomacro, noreorder, noat : boolean; constructor create(smart: boolean); override; end; @@ -38,12 +39,46 @@ unit cpugas; procedure WriteInstruction(hp : tai);override; end; + const + use_std_regnames : boolean = + {$ifndef USE_MIPS_GAS_REGS} + true; + {$else} + false; + {$endif} + implementation uses - cutils, systems, + aasmbase, cutils, systems, verbose, itcpugas, cgbase, cgutils; + function gas_std_regname(r:Tregister):string; + var + hr: tregister; + p: longint; + begin + { Double uses the same table as single } + hr := r; + case getsubreg(hr) of + R_SUBFD: + setsubreg(hr, R_SUBFS); + R_SUBL, R_SUBW, R_SUBD, R_SUBQ: + setsubreg(hr, R_SUBD); + end; + result:=std_regname(hr); + end; + + + function asm_regname(reg : TRegister) : string; + + begin + if use_std_regnames then + asm_regname:='$'+gas_std_regname(reg) + else + asm_regname:=gas_regname(reg); + end; + {****************************************************************************} { GNU MIPS Assembler writer } {****************************************************************************} @@ -52,6 +87,9 @@ unit cpugas; begin inherited create(smart); InstrWriter := TMIPSInstrWriter.create(self); + nomacro:=false; + noreorder:=false; + noat:=false; end; @@ -60,14 +98,25 @@ unit cpugas; {****************************************************************************} function GetReferenceString(var ref: TReference): string; + var + hasgot : boolean; + gotprefix : string; begin GetReferenceString := ''; + hasgot:=false; with ref do begin if (base = NR_NO) and (index = NR_NO) then begin if assigned(symbol) then - GetReferenceString := symbol.Name; + begin + GetReferenceString := symbol.Name; + if symbol.typ=AT_FUNCTION then + gotprefix:='%call16(' + else + gotprefix:='%got('; + hasgot:=true; + end; if offset > 0 then GetReferenceString := GetReferenceString + '+' + ToStr(offset) else if offset < 0 then @@ -77,6 +126,13 @@ unit cpugas; GetReferenceString := '%hi(' + GetReferenceString + ')'; addr_low: GetReferenceString := '%lo(' + GetReferenceString + ')'; + addr_pic: + begin + if hasgot then + GetReferenceString := gotprefix + GetReferenceString + ')' + else + internalerror(2012070401); + end; end; end else @@ -87,7 +143,7 @@ unit cpugas; internalerror(2003052601); {$endif extdebug} if base <> NR_NO then - GetReferenceString := GetReferenceString + '(' + gas_regname(base) + ')'; + GetReferenceString := GetReferenceString + '(' + asm_regname(base) + ')'; if index = NR_NO then begin if offset <> 0 then @@ -96,6 +152,14 @@ unit cpugas; begin if refaddr = addr_low then GetReferenceString := '%lo(' + symbol.Name + ')' + GetReferenceString + else if refaddr = addr_pic then + begin + if symbol.typ=AT_FUNCTION then + gotprefix:='%call16(' + else + gotprefix:='%got('; + GetReferenceString := gotprefix + symbol.Name + ')' + GetReferenceString; + end else GetReferenceString := symbol.Name + {'+' +} GetReferenceString; end; @@ -106,7 +170,7 @@ unit cpugas; if (Offset<>0) or assigned(symbol) then internalerror(2003052603); {$endif extdebug} - GetReferenceString := GetReferenceString + '(' + gas_regname(index) + ')'; + GetReferenceString := GetReferenceString + '(' + asm_regname(index) + ')'; end; end; @@ -119,7 +183,7 @@ unit cpugas; with Oper do case typ of top_reg: - getopstr := gas_regname(reg); + getopstr := asm_regname(reg); top_const: getopstr := tostr(longint(val)); top_ref: @@ -171,6 +235,11 @@ unit cpugas; end; } + function is_macro_instruction(op : TAsmOp) : boolean; + begin + is_macro_instruction := + (op=A_SEQ) or (op=A_SNE); + end; procedure TMIPSInstrWriter.WriteInstruction(hp: Tai); var @@ -201,21 +270,25 @@ unit cpugas; begin s := #9 + '.set' + #9 + 'macro'; owner.AsmWriteLn(s); + TMIPSGNUAssembler(owner).nomacro:=false; end; A_P_SET_REORDER: begin s := #9 + '.set' + #9 + 'reorder'; owner.AsmWriteLn(s); + TMIPSGNUAssembler(owner).noreorder:=false; end; A_P_SET_NOMACRO: begin s := #9 + '.set' + #9 + 'nomacro'; owner.AsmWriteLn(s); + TMIPSGNUAssembler(owner).nomacro:=true; end; A_P_SET_NOREORDER: begin s := #9 + '.set' + #9 + 'noreorder'; owner.AsmWriteLn(s); + TMIPSGNUAssembler(owner).noreorder:=true; end; A_P_SW: begin @@ -229,39 +302,57 @@ unit cpugas; end; A_LDC1: begin - tmpfpu := getopstr(taicpu(hp).oper[0]^); - s := #9 + gas_op2str[A_LWC1] + #9 + tmpfpu + ',' + getopstr(taicpu(hp).oper[1]^); // + '(' + getopstr(taicpu(hp).oper[1]^) + ')'; - owner.AsmWriteLn(s); + if (target_info.endian = endian_big) then + begin + s := #9 + gas_op2str[A_LDC1] + #9 + getopstr(taicpu(hp).oper[0]^) + + ',' + getopstr(taicpu(hp).oper[1]^); + end + else + begin + tmpfpu := getopstr(taicpu(hp).oper[0]^); + s := #9 + gas_op2str[A_LWC1] + #9 + tmpfpu + ',' + getopstr(taicpu(hp).oper[1]^); // + '(' + getopstr(taicpu(hp).oper[1]^) + ')'; + owner.AsmWriteLn(s); { bug if $f9/$f19 tmpfpu_len := length(tmpfpu); tmpfpu[tmpfpu_len] := succ(tmpfpu[tmpfpu_len]); - + } - r := taicpu(hp).oper[0]^.reg; - setsupreg(r, getsupreg(r) + 1); - tmpfpu := gas_regname(r); - s := #9 + gas_op2str[A_LWC1] + #9 + tmpfpu + ',' + getopstr_4(taicpu(hp).oper[1]^); // + '(' + getopstr(taicpu(hp).oper[1]^) + ')'; + r := taicpu(hp).oper[0]^.reg; + setsupreg(r, getsupreg(r) + 1); + tmpfpu := asm_regname(r); + s := #9 + gas_op2str[A_LWC1] + #9 + tmpfpu + ',' + getopstr_4(taicpu(hp).oper[1]^); // + '(' + getopstr(taicpu(hp).oper[1]^) + ')'; + end; owner.AsmWriteLn(s); end; A_SDC1: begin - tmpfpu := getopstr(taicpu(hp).oper[0]^); - s := #9 + gas_op2str[A_SWC1] + #9 + tmpfpu + ',' + getopstr(taicpu(hp).oper[1]^); //+ ',' + getopstr(taicpu(hp).oper[2]^) + '(' + getopstr(taicpu(hp).oper[1]^) + ')'; - owner.AsmWriteLn(s); + if (target_info.endian = endian_big) then + begin + s := #9 + gas_op2str[A_SDC1] + #9 + getopstr(taicpu(hp).oper[0]^) + + ',' + getopstr(taicpu(hp).oper[1]^); + end + else + begin + tmpfpu := getopstr(taicpu(hp).oper[0]^); + s := #9 + gas_op2str[A_SWC1] + #9 + tmpfpu + ',' + getopstr(taicpu(hp).oper[1]^); //+ ',' + getopstr(taicpu(hp).oper[2]^) + '(' + getopstr(taicpu(hp).oper[1]^) + ')'; + owner.AsmWriteLn(s); -{ +{ tmpfpu_len := length(tmpfpu); tmpfpu[tmpfpu_len] := succ(tmpfpu[tmpfpu_len]); } - r := taicpu(hp).oper[0]^.reg; - setsupreg(r, getsupreg(r) + 1); - tmpfpu := gas_regname(r); - s := #9 + gas_op2str[A_SWC1] + #9 + tmpfpu + ',' + getopstr_4(taicpu(hp).oper[1]^); //+ ',' + getopstr(taicpu(hp).oper[2]^) + '(' + getopstr(taicpu(hp).oper[1]^) + ')'; + r := taicpu(hp).oper[0]^.reg; + setsupreg(r, getsupreg(r) + 1); + tmpfpu := asm_regname(r); + s := #9 + gas_op2str[A_SWC1] + #9 + tmpfpu + ',' + getopstr_4(taicpu(hp).oper[1]^); //+ ',' + getopstr(taicpu(hp).oper[2]^) + '(' + getopstr(taicpu(hp).oper[1]^) + ')'; + end; owner.AsmWriteLn(s); end; else begin + if is_macro_instruction(op) and TMIPSGNUAssembler(owner).nomacro then + owner.AsmWriteln(#9'.set'#9'macro'); s := #9 + gas_op2str[op] + cond2str[taicpu(hp).condition]; if taicpu(hp).delayslot_annulled then s := s + ',a'; @@ -272,6 +363,8 @@ unit cpugas; s := s + ',' + getopstr(taicpu(hp).oper[i]^); end; owner.AsmWriteLn(s); + if is_macro_instruction(op) and TMIPSGNUAssembler(owner).nomacro then + owner.AsmWriteln(#9'.set'#9'nomacro'); end; end; end; @@ -283,19 +376,19 @@ unit cpugas; id: as_gas; idtxt: 'AS'; asmbin: 'as'; - asmcmd: '-mips2 -W -EL -o $OBJ $ASM'; + asmcmd: '-mips2 $NOWARN -EL $PIC -o $OBJ $ASM'; supported_targets: [system_mipsel_linux]; flags: [af_allowdirect, af_needar, af_smartlink_sections]; labelprefix: '.L'; comment: '# '; dollarsign: '$'; ); - as_MIPS_as_info: tasminfo = + as_MIPSEB_as_info: tasminfo = ( id: as_gas; idtxt: 'AS'; asmbin: 'as'; - asmcmd: '-mips2 -W -EB -o $OBJ $ASM'; + asmcmd: '-mips2 $NOWARN -EB $PIC -o $OBJ $ASM'; supported_targets: [system_mipseb_linux]; flags: [af_allowdirect, af_needar, af_smartlink_sections]; labelprefix: '.L'; diff --git a/mips/compiler/mips/cpunode.pas b/mips/compiler/mips/cpunode.pas index 89ddf3058f..58f0695588 100644 --- a/mips/compiler/mips/cpunode.pas +++ b/mips/compiler/mips/cpunode.pas @@ -36,6 +36,7 @@ implementation the processor specific nodes must be included after the generic one (FK) } - ncpuadd,ncpucall,ncpumat,ncpuinln,ncpucnv,ncpuset; + ncpuadd,ncpucall,ncpumat,ncpuinln, + ncpuld,ncpucnv,ncpuset; end. diff --git a/mips/compiler/mips/cpupara.pas b/mips/compiler/mips/cpupara.pas index 9d77fc0914..d4c27e940e 100644 --- a/mips/compiler/mips/cpupara.pas +++ b/mips/compiler/mips/cpupara.pas @@ -28,7 +28,45 @@ interface cclasses, aasmtai, cpubase,cpuinfo, - symconst,symbase,symsym,symtype,symdef,paramgr,parabase,cgbase; + symconst,symbase,symsym,symtype,symdef,paramgr,parabase,cgbase,cgutils; + + const + MIPS_MAX_OFFSET = 20; + MIPS_MAX_REGISTERS_USED_IN_CALL = 6; + + { All ABI seem to start with $4 i.e. $a0 } + MIPS_FIRST_REGISTER_USED_IN_CALL = RS_R4; + { O32 ABI uses $a0 to $a3, i.e R4 to R7 } + MIPS_LAST_REGISTER_USED_IN_CALL_ABI_O32 = RS_R7; + { N32 ABI uses also R8 and R9 } + MIPS_LAST_REGISTER_USED_IN_CALL_ABI_N32 = RS_R9; + { The calculation below is based on the assumption + that all registers used for ABI calls are + ordered and follow each other } + MIPS_NB_REGISTERS_USED_IN_CALL_O32 = + MIPS_LAST_REGISTER_USED_IN_CALL_ABI_O32 + - MIPS_FIRST_REGISTER_USED_IN_CALL + 1; + MIPS_NB_REGISTERS_USED_IN_CALL_N32 = + MIPS_LAST_REGISTER_USED_IN_CALL_ABI_N32 + - MIPS_FIRST_REGISTER_USED_IN_CALL + 1; + + + { Set O32 ABI as default } + const + mips_nb_used_registers = MIPS_NB_REGISTERS_USED_IN_CALL_O32; + + { Might need to be changed if we support N64 ABI later } + mips_sizeof_register_param = 4; + + type + tparasupregs = array[0..MIPS_MAX_REGISTERS_USED_IN_CALL-1] of tsuperregister; + tparasupregsused = array[0..MIPS_MAX_REGISTERS_USED_IN_CALL-1] of boolean; + tparasupregsize = array[0..MIPS_MAX_REGISTERS_USED_IN_CALL-1] of tcgsize; + tparasuprename = array[0..MIPS_MAX_REGISTERS_USED_IN_CALL-1] of shortstring; + tparasupregsoffset = array[0..MIPS_MAX_REGISTERS_USED_IN_CALL-1] of longint; + + const + parasupregs : tparasupregs = (RS_R4, RS_R5, RS_R6, RS_R7, RS_R8, RS_R9); type TMIPSParaManager=class(TParaManager) @@ -38,76 +76,77 @@ interface {Returns a structure giving the information on the storage of the parameter (which must be an integer parameter) @param(nr Parameter number of routine, starting from 1)} - procedure getintparaloc(calloption : tproccalloption; nr : longint;var cgpara : TCGPara);override; + procedure getintparaloc(calloption : tproccalloption; nr : longint; def : tdef; var cgpara : tcgpara);override; function create_paraloc_info(p : TAbstractProcDef; side: tcallercallee):longint;override; function create_varargs_paraloc_info(p : TAbstractProcDef; varargspara:tvarargsparalist):longint;override; function get_funcretloc(p : tabstractprocdef; side: tcallercallee; def: tdef): tcgpara;override; private + intparareg, + intparasize : longint; procedure create_funcretloc_info(p : tabstractprocdef; side: tcallercallee); - procedure create_paraloc_info_intern(p : tabstractprocdef; side: tcallercallee; paras: tparalist; - var intparareg,parasize:longint); + procedure create_paraloc_info_intern(p : tabstractprocdef; side: tcallercallee; paras: tparalist); end; implementation uses cutils,verbose,systems, - defutil, - cgutils,cgobj, - procinfo,cpupi; + defutil, cpupi, procinfo, + cgobj; - type - tparasupregs = array[0..3] of tsuperregister; - pparasupregs = ^tparasupregs; - const - paraoutsupregs : tparasupregs = (RS_R4, RS_R5, RS_R6, RS_R7); - parainsupregs : tparasupregs = (RS_R4, RS_R5, RS_R6, RS_R7); function TMIPSParaManager.get_volatile_registers_int(calloption : tproccalloption):TCpuRegisterSet; begin - result:=[RS_R0..RS_R15,RS_R24..RS_R25]; + { O32 ABI values } + result:=[RS_R1..RS_R15,RS_R24..RS_R25,RS_R31]; end; function TMIPSParaManager.get_volatile_registers_fpu(calloption : tproccalloption):TCpuRegisterSet; begin + { O32 ABI values } result:=[RS_F0..RS_F19]; end; - procedure TMIPSParaManager.GetIntParaLoc(calloption : tproccalloption; nr : longint;var cgpara : tcgpara); + procedure TMIPSParaManager.GetIntParaLoc(calloption : tproccalloption; nr : longint; def : tdef; var cgpara : tcgpara); var paraloc : pcgparalocation; begin if nr<1 then InternalError(2002100806); cgpara.reset; - cgpara.size:=OS_INT; - cgpara.intsize:=tcgsize2size[OS_INT]; + cgpara.size:=def_cgsize(def); + cgpara.intsize:=tcgsize2size[cgpara.size]; cgpara.alignment:=std_param_align; + cgpara.def:=def; paraloc:=cgpara.add_location; with paraloc^ do begin - { The first four parameters are passed into registers } + { MIPS: ABI dependent number of first parameters + are passed into registers } dec(nr); - if nr<4 then + if nr<mips_nb_used_registers then begin loc:=LOC_REGISTER; - register:=newreg(R_INTREGISTER,(RS_R4+nr),R_SUBWHOLE); + register:=newreg(R_INTREGISTER,parasupregs[nr],R_SUBWHOLE); end else begin { The other parameters are passed on the stack } loc:=LOC_REFERENCE; reference.index:=NR_STACK_POINTER_REG; - reference.offset:=16 + (nr-4)*4; + reference.offset:=nr*mips_sizeof_register_param; end; size:=OS_INT; + { Be sure to reserve enough stack space tp cope with + that parameter } + if assigned(current_procinfo) then + TMIPSProcinfo(current_procinfo).allocate_push_parasize((nr+1)*mips_sizeof_register_param); end; end; - { true if a parameter is too large to copy and only the address is pushed } function TMIPSParaManager.push_addr_param(varspez:tvarspez;def : tdef;calloption : tproccalloption) : boolean; begin @@ -120,12 +159,13 @@ implementation end; case def.typ of recorddef: - result:=false; + { According to 032 ABI we should have } + result:=false; arraydef: - result:=(tarraydef(def).highrange>=tarraydef(def).lowrange) or - is_open_array(def) or - is_array_of_const(def) or - is_array_constructor(def); + result:=true; {(tarraydef(def).highrange>=tarraydef(def).lowrange) or + is_open_array(def) or + is_array_of_const(def) or + is_array_constructor(def);} variantdef, formaldef : result:=true; @@ -152,40 +192,40 @@ implementation paraloc : pcgparalocation; retcgsize : tcgsize; begin - result.init; - result.alignment:=get_para_align(p.proccalloption); - { void has no location } - if is_void(def) then + if set_common_funcretloc_info(p,def,retcgsize,result) then begin - paraloc:=result.add_location; - result.size:=OS_NO; - result.intsize:=0; - paraloc^.size:=OS_NO; - paraloc^.loc:=LOC_VOID; - exit; - end; - { Constructors return self instead of a boolean } - if (p.proctypeoption=potype_constructor) then - begin - retcgsize:=OS_ADDR; - result.intsize:=sizeof(pint); - end - else - begin - retcgsize:=def_cgsize(def); - result.intsize:=def.size; - end; - result.size:=retcgsize; - { Return is passed as var parameter } -{ - if ret_in_param(def,p.proccalloption) then - begin - paraloc:=result.add_location; - paraloc^.loc:=LOC_REFERENCE; - paraloc^.size:=retcgsize; + { Return is passed as var parameter, + in this case we use the first register R4 for it } + if ret_in_param(def,p.proccalloption) then + begin + if intparareg=0 then + inc(intparareg); + if side=calleeside then + begin + result.reset; + paraloc:=result.add_location; + paraloc^.loc:=LOC_REFERENCE; + paraloc^.reference.index:=NR_STACK_POINTER_REG; + { return is at offset zero } + paraloc^.reference.offset:=0; + paraloc^.size:=retcgsize; + { Reserve first register for ret_in_param } + if assigned(current_procinfo) then + begin + TMIPSProcInfo(current_procinfo).register_used[0]:=true; + TMIPSProcInfo(current_procinfo).register_size[0]:=retcgsize; + TMIPSProcInfo(current_procinfo).register_name[0]:='ret_in_param_result'; + TMIPSProcInfo(current_procinfo).register_offset[0]:=0; + end; + end + else + begin + getIntParaLoc(p.proccalloption,1,result.def,result); + end; + result.def:=getpointerdef(def); + end; exit; end; -} paraloc:=result.add_location; { Return in FPU register? } @@ -232,16 +272,15 @@ implementation end end; - procedure TMIPSParaManager.create_paraloc_info_intern(p : tabstractprocdef; side: tcallercallee;paras:tparalist; - var intparareg,parasize:longint); + + procedure TMIPSParaManager.create_paraloc_info_intern(p : tabstractprocdef; side: tcallercallee;paras:tparalist); var paraloc : pcgparalocation; i : integer; hp : tparavarsym; - paradef : tdef; paracgsize : tcgsize; - hparasupregs : pparasupregs; paralen : longint; + paradef : tdef; fpparareg : integer; can_use_float : boolean; reg : tsuperregister; @@ -250,63 +289,67 @@ implementation begin fpparareg := 0; can_use_float := true; - if side=callerside then - hparasupregs:=@paraoutsupregs - else - hparasupregs:=@parainsupregs; - for i:=0 to paras.count-1 do begin hp:=tparavarsym(paras[i]); paradef := hp.vardef; { currently only support C-style array of const } - if (p.proccalloption in [pocall_cdecl,pocall_cppdecl]) and + if (p.proccalloption in [pocall_cdecl,pocall_cppdecl]) and is_array_of_const(paradef) then begin paraloc:=hp.paraloc[side].add_location; { hack: the paraloc must be valid, but is not actually used } - paraloc^.loc := LOC_REGISTER; - paraloc^.register := NR_R0; - paraloc^.size := OS_ADDR; + paraloc^.loc:=LOC_REGISTER; + paraloc^.register:=NR_R0; + paraloc^.size:=OS_ADDR; break; end; - if (push_addr_param(hp.varspez,paradef,p.proccalloption)) then - begin + if push_addr_param(hp.varspez,paradef,p.proccalloption) then + begin paracgsize := OS_ADDR; - paralen := tcgsize2size[paracgsize]; - end + paralen := tcgsize2size[paracgsize]; + paradef := getpointerdef(paradef); + end else begin paracgsize := def_cgsize(paradef); { for things like formaldef } - if (paracgsize=OS_NO) then + if (paracgsize=OS_NO) and (paradef.typ <> recorddef) then begin paracgsize:=OS_ADDR; + paradef:=voidpointertype; end; if not is_special_array(paradef) then paralen := paradef.size else paralen := tcgsize2size[paracgsize]; + end; - end; - - if (paracgsize in [OS_64, OS_S64, OS_F64]) or (hp.vardef.alignment = 8) then + if (paracgsize in [OS_64, OS_S64, OS_F64]) or (hp.vardef.alignment = 8) then alignment := 8 else alignment := 4; hp.paraloc[side].reset; hp.paraloc[side].Alignment:=alignment; + if paracgsize=OS_NO then + begin + paracgsize:=OS_32; + paralen:=align(paralen,4); + end + else + paralen:=tcgsize2size[paracgsize]; hp.paraloc[side].intsize:=paralen; hp.paraloc[side].size:=paracgsize; + hp.paraloc[side].def:=paradef; { check the alignment, mips O32ABI require a nature alignment } - tmp := align(parasize, alignment) - parasize; + tmp := align(intparasize, alignment) - intparasize; while tmp > 0 do begin inc(intparareg); - inc(parasize,4); + inc(intparasize,4); dec(tmp,4); end; @@ -319,35 +362,52 @@ implementation begin paraloc:=hp.paraloc[side].add_location; { We can allocate at maximum 32 bits per register } - if (paracgsize in [OS_64,OS_S64]) or ((paracgsize in [OS_F32,OS_F64]) and not(can_use_float)) then + if (paracgsize in [OS_64,OS_S64]) or + ((paracgsize in [OS_F32,OS_F64]) and + not(can_use_float)) then paraloc^.size:=OS_32 else paraloc^.size:=paracgsize; { ret in param? } - {if vo_is_funcret in hp.varoptions then + if vo_is_funcret in hp.varoptions then begin - paraloc^.loc:=LOC_REFERENCE; + { This should be the first parameter } + if assigned(current_procinfo) then + begin + TMIPSProcInfo(current_procinfo).register_used[0]:=true; + TMIPSProcInfo(current_procinfo).register_name[0]:='result'; + TMIPSProcInfo(current_procinfo).register_size[0]:=paracgsize; + TMIPSProcInfo(current_procinfo).register_offset[0]:=0; + end; + //if (intparareg<>1) then + // Comment(V_Warning,'intparareg should be one for funcret in TMipsParaManager.create_paraloc_info_intern'); if side=callerside then begin - paraloc^.reference.index := NR_STACK_POINTER_REG; - paraloc^.reference.offset:=parasize; + paraloc^.loc:=LOC_REGISTER; + paraloc^.register:=newreg(R_INTREGISTER,parasupregs[0],R_SUBWHOLE); end else begin - paraloc^.reference.index := NR_FRAME_POINTER_REG; - paraloc^.reference.offset:=target_info.first_parm_offset+parasize; - TMIPSProcinfo(current_procinfo).needs_frame_pointer := true; + paraloc^.loc:=LOC_REFERENCE; + if (po_nostackframe in p.procoptions) then + paraloc^.reference.index := NR_STACK_POINTER_REG + else + begin + paraloc^.reference.index := NR_FRAME_POINTER_REG; + if assigned(current_procinfo) then + TMIPSProcinfo(current_procinfo).needs_frame_pointer := true; + end; + paraloc^.reference.offset:=0; end; - inc(parasize,align(tcgsize2size[paraloc^.size],sizeof(aint))); - inc(intparareg); - //writeln(hs,'funcret',i,' ', parasize); + inc(intparasize,align(tcgsize2size[paraloc^.size],sizeof(aint))); end - // In case of po_delphi_nested_cc, the parent frame pointer is always passed on the stack. - else} if (intparareg<=high(tparasupregs)) and + { In case of po_delphi_nested_cc, the parent frame pointer + is always passed on the stack. } + else if (intparareg<mips_nb_used_registers) and (not(vo_is_parentfp in hp.varoptions) or not(po_delphi_nested_cc in p.procoptions)) then begin - if (can_use_float) then + if (can_use_float) then begin paraloc^.loc:=LOC_FPUREGISTER; if (fpparareg = 0) then @@ -358,79 +418,111 @@ implementation begin paraloc^.register:=newreg(R_FPUREGISTER, reg, R_SUBFD); inc(fpparareg); - inc(intparareg); - inc(intparareg); - inc(parasize,8); + inc(intparareg); + inc(intparareg); + inc(intparasize,8); end else begin paraloc^.register:=newreg(R_FPUREGISTER, reg, R_SUBFS); inc(fpparareg); - inc(intparareg); - inc(parasize,sizeof(aint)); + inc(intparareg); + inc(intparasize,sizeof(aint)); end; end - else - begin - paraloc^.loc:=LOC_REGISTER; - paraloc^.register:=newreg(R_INTREGISTER,hparasupregs^[intparareg],R_SUBWHOLE); - inc(intparareg); - inc(parasize,sizeof(aint)); - end; + else { not can use float } + begin + if assigned(current_procinfo) then + begin + TMIPSProcInfo(current_procinfo).register_used[intparareg]:=true; + TMIPSProcInfo(current_procinfo).register_name[intparareg]:=hp.prettyname; + TMIPSProcInfo(current_procinfo).register_size[intparareg]:=paracgsize; + TMIPSProcInfo(current_procinfo).register_offset[intparareg]:=intparareg*mips_sizeof_register_param; + end; + if side=callerside then + begin + paraloc^.loc:=LOC_REGISTER; + paraloc^.register:=newreg(R_INTREGISTER,parasupregs[intparareg],R_SUBWHOLE); + end + else + begin + paraloc^.loc:=LOC_REFERENCE; + if (po_nostackframe in p.procoptions) then + paraloc^.reference.index := NR_STACK_POINTER_REG + else + begin + paraloc^.reference.index := NR_FRAME_POINTER_REG; + if assigned(current_procinfo) then + TMIPSProcinfo(current_procinfo).needs_frame_pointer := true; + end; + paraloc^.reference.offset:=intparareg*mips_sizeof_register_param; + end; + inc(intparareg); + inc(intparasize,align(tcgsize2size[paraloc^.size],mips_sizeof_register_param)); + end; end else begin paraloc^.loc:=LOC_REFERENCE; - if side=callerside then begin paraloc^.reference.index := NR_STACK_POINTER_REG; - paraloc^.reference.offset:=parasize; + paraloc^.reference.offset:=intparasize; end else begin - paraloc^.reference.index := NR_FRAME_POINTER_REG; - paraloc^.reference.offset:=target_info.first_parm_offset+parasize; - TMIPSProcinfo(current_procinfo).needs_frame_pointer := true; + if (po_nostackframe in p.procoptions) then + paraloc^.reference.index := NR_STACK_POINTER_REG + else + begin + paraloc^.reference.index := NR_FRAME_POINTER_REG; + if assigned(current_procinfo) then + TMIPSProcinfo(current_procinfo).needs_frame_pointer := true; + end; + paraloc^.reference.offset:=intparasize; end; - inc(parasize,align(tcgsize2size[paraloc^.size],sizeof(aint))); + inc(intparasize,align(tcgsize2size[paraloc^.size],mips_sizeof_register_param)); end; dec(paralen,tcgsize2size[paraloc^.size]); - end; { while } - end; {for} - if (parasize < 16) then - parasize := 16; + end; + end; + { O32 ABI reqires at least 16 bytes } + if (intparasize < 16) then + intparasize := 16; + { Increase maxpushparasize, but only if not examining itself } + //if assigned(current_procinfo) and (side=callerside) and + // (current_procinfo.procdef <> p) then + // begin + // TMIPSProcinfo(current_procinfo).allocate_push_parasize(intparasize); + // end; end; function TMIPSParaManager.create_varargs_paraloc_info(p : tabstractprocdef; varargspara:tvarargsparalist):longint; - var - intparareg, - parasize : longint; begin intparareg:=0; - parasize:=0; + intparasize:=0; + { Create Function result paraloc } + create_funcretloc_info(p,callerside); { calculate the registers for the normal parameters } - create_paraloc_info_intern(p,callerside,p.paras,intparareg,parasize); + create_paraloc_info_intern(p,callerside,p.paras); { append the varargs } - create_paraloc_info_intern(p,callerside,varargspara,intparareg,parasize); - result:=parasize; + create_paraloc_info_intern(p,callerside,varargspara); + { We need to return the size allocated on the stack } + result:=intparasize; end; function TMIPSParaManager.create_paraloc_info(p : tabstractprocdef; side: tcallercallee):longint; - var - intparareg, - parasize : longint; begin intparareg:=0; - parasize:=0; - create_paraloc_info_intern(p,side,p.paras,intparareg,parasize); + intparasize:=0; { Create Function result paraloc } create_funcretloc_info(p,side); + create_paraloc_info_intern(p,side,p.paras); { We need to return the size allocated on the stack } - result:=parasize; + result:=intparasize; end; diff --git a/mips/compiler/mips/cpupi.pas b/mips/compiler/mips/cpupi.pas index f01be970bf..6d579faed5 100644 --- a/mips/compiler/mips/cpupi.pas +++ b/mips/compiler/mips/cpupi.pas @@ -27,8 +27,8 @@ interface uses cutils, - globtype, - procinfo,cpuinfo, + globtype,symdef, + procinfo,cpuinfo,cpupara, psub; type @@ -40,27 +40,56 @@ interface floatregstart : aint; intregssave, floatregssave : byte; + needs_frame_pointer: boolean; + register_used : tparasupregsused; + register_size : tparasupregsize; + register_name : tparasuprename; + register_offset : tparasupregsoffset; + computed_local_size : longint; + //intparareg, + //parasize : longint; constructor create(aparent:tprocinfo);override; function calc_stackframe_size:longint;override; procedure set_first_temp_offset;override; - public - needs_frame_pointer: boolean; end; + { Used by Stabs debug info generator } + + function mips_extra_offset(procdef : tprocdef) : longint; + implementation uses - systems,globals, - cpubase,cgbase,cgobj, + systems,globals,verbose, + cpubase,cgbase,cgutils,cgobj, tgobj,paramgr,symconst; constructor TMIPSProcInfo.create(aparent: tprocinfo); + var + i : longint; begin inherited create(aparent); + for i:=low(tparasupregs) to high(tparasupregs) do + begin + register_used[i]:=false; + register_size[i]:=OS_NO; + register_name[i]:='invalid'; + register_offset[i]:=-1; + end; floatregssave:=12; { f20-f31 } intregssave:=12; { r16-r23,r28-r31 } - needs_frame_pointer := false; - maxpushedparasize := 16; + { for testing } + needs_frame_pointer := true;//false; + computed_local_size:=-1; + { pi_needs_got is not yet set correctly + so include it always if creating PIC code } + if (cs_create_pic in current_settings.moduleswitches) then + begin + include(flags, pi_needs_got); + got:=NR_GP; + end + else + got:=NR_NO; end; @@ -72,7 +101,8 @@ implementation if tg.direction = -1 then tg.setfirsttemp(0) else - tg.setfirsttemp(maxpushedparasize+floatregssave*sizeof(aint)+intregssave*sizeof(aint)); + tg.setfirsttemp(maxpushedparasize+ + floatregssave*sizeof(aint)+intregssave*sizeof(aint)); end; @@ -82,14 +112,27 @@ implementation regs: tcpuregisterset; begin result:=maxpushedparasize; - { ABI requirement: start of the register save area must align at 8 byte } - { can we ensure maxpushedparasize is properly aligned? if so unnecessary} - floatregstart:=Align(result,8); + floatregstart:=result; inc(result,floatregssave*4); intregstart:=result; + //inc(result,intregssave*4); result:=Align(tg.lasttemp,max(current_settings.alignment.localalignmin,8)); + if computed_local_size=-1 then + begin + computed_local_size:=result; + procdef.total_local_size:=result; + end + else if computed_local_size <> result then + Comment(V_Error,'TMIPSProcInfo.calc_stackframe_size result changed'); end; + function mips_extra_offset(procdef : tprocdef) : longint; + begin + if procdef=nil then + mips_extra_offset:=0 + else + mips_extra_offset:=procdef.total_local_size; + end; begin cprocinfo:=TMIPSProcInfo; diff --git a/mips/compiler/mips/hlcgcpu.pas b/mips/compiler/mips/hlcgcpu.pas index ecffd1b79b..ad03bee126 100644 --- a/mips/compiler/mips/hlcgcpu.pas +++ b/mips/compiler/mips/hlcgcpu.pas @@ -28,17 +28,82 @@ unit hlcgcpu; interface +uses + globtype, + aasmbase, aasmdata, + cgbase, cgutils, + symdef, + hlcgobj, hlcg2ll; + + type + thlcg2mips = class(thlcg2ll) + procedure a_call_name(list: TAsmList; pd: tprocdef; const s: TSymStr; weak: boolean);override; + procedure a_call_reg(list : TAsmList;pd : tabstractprocdef;reg : tregister);override; + procedure a_call_ref(list : TAsmList;pd : tabstractprocdef;const ref : treference);override; + end; + procedure create_hlcodegen; implementation uses - hlcgobj, hlcg2ll, + aasmtai, + cutils, + cgobj, + cpubase, cgcpu; + procedure thlcg2mips.a_call_name(list: TAsmList; pd: tprocdef; const s: TSymStr; weak: boolean); + var + ref : treference; + begin + if pd.proccalloption=pocall_cdecl then + begin + { Use $gp/$t9 registers as the code might be in a shared library } + reference_reset(ref,sizeof(aint)); + ref.symbol:=current_asmdata.RefAsmSymbol('_gp'); + list.concat(tai_comment.create(strpnew('Using PIC code for a_call_name'))); + cg.a_loadaddr_ref_reg(list,ref,NR_GP); + reference_reset(ref,sizeof(aint)); + ref.symbol:=current_asmdata.RefAsmSymbol(s); + ref.base:=NR_GP; + ref.refaddr:=addr_pic; + cg.a_loadaddr_ref_reg(list,ref,NR_PIC_FUNC); + cg.a_call_reg(list,NR_PIC_FUNC); + end + else + cg.a_call_name(list,s,weak); + end; + + procedure thlcg2mips.a_call_reg(list: TAsmList; pd: tabstractprocdef; reg: tregister); + begin + if (pd.proccalloption=pocall_cdecl) and (reg<>NR_PIC_FUNC) then + begin + list.concat(tai_comment.create(strpnew('Using PIC code for a_call_reg'))); + { Use $t9 register as the code might be in a shared library } + cg.a_load_reg_reg(list,OS_32,OS_32,reg,NR_PIC_FUNC); + cg.a_call_reg(list,NR_PIC_FUNC); + end + else + cg.a_call_reg(list,reg); + end; + + procedure thlcg2mips.a_call_ref(list: TAsmList; pd: tabstractprocdef; const ref: treference); + begin + if pd.proccalloption =pocall_cdecl then + begin + { Use $t9 register as the code might be in a shared library } + list.concat(tai_comment.create(strpnew('Using PIC code for a_call_ref'))); + cg.a_loadaddr_ref_reg(list,ref,NR_PIC_FUNC); + cg.a_call_reg(list,NR_PIC_FUNC); + end + else + cg.a_call_ref(list,ref); + end; + procedure create_hlcodegen; begin - hlcg:=thlcg2ll.create; + hlcg:=thlcg2mips.create; create_codegen; end; diff --git a/mips/compiler/mips/mipsreg.dat b/mips/compiler/mips/mipsreg.dat index 9e47712691..9e4be25b0e 100644 --- a/mips/compiler/mips/mipsreg.dat +++ b/mips/compiler/mips/mipsreg.dat @@ -37,47 +37,47 @@ R27,$01,$04,$1B,k1,$27,27,27 R28,$01,$04,$1C,gp,$28,28,28 R29,$01,$04,$1D,sp,$29,29,29 R30,$01,$04,$1E,fp,$30,30,30 -R31,$01,$04,$1F,$a,$31,31,31 +R31,$01,$04,$1F,ra,$31,31,31 -F0,$02,$06,$00,F0,$f0,32,32 -F1,$02,$06,$01,F1,$f1,33,33 -F2,$02,$06,$02,F2,$f2,34,34 -F3,$02,$06,$03,F3,$f3,35,35 -F4,$02,$06,$04,F4,$f4,36,36 -F5,$02,$06,$05,F5,$f5,37,37 -F6,$02,$06,$06,F6,$f6,38,38 -F7,$02,$06,$07,F7,$f7,39,39 -F8,$02,$06,$08,F8,$f8,40,40 -F9,$02,$06,$09,F9,$f9,41,41 -F10,$02,$06,$0A,F10,$f10,42,42 -F11,$02,$06,$0B,F11,$f11,43,43 -F12,$02,$06,$0C,F12,$f12,44,44 -F13,$02,$06,$0D,F13,$f13,45,45 -F14,$02,$06,$0E,F14,$f14,46,46 -F15,$02,$06,$0F,F15,$f15,47,47 -F16,$02,$06,$10,F16,$f16,48,48 -F17,$02,$06,$11,F17,$f17,49,49 -F18,$02,$06,$12,F18,$f18,50,50 -F19,$02,$06,$13,F19,$f19,51,51 -F20,$02,$06,$14,F20,$f20,52,52 -F21,$02,$06,$15,F21,$f21,53,53 -F22,$02,$06,$16,F22,$f22,54,54 -F23,$02,$06,$17,F23,$f23,55,55 -F24,$02,$06,$18,F24,$f24,56,56 -F25,$02,$06,$19,F25,$f25,57,57 -F26,$02,$06,$1A,F26,$f26,58,58 -F27,$02,$06,$1B,F27,$f27,59,59 -F28,$02,$06,$1C,F28,$f28,60,60 -F29,$02,$06,$1D,F29,$f29,61,61 -F30,$02,$06,$1E,F30,$f30,62,62 -F31,$02,$06,$1F,F31,$f31,63,63 +F0,$02,$06,$00,f0,$f0,32,32 +F1,$02,$06,$01,f1,$f1,33,33 +F2,$02,$06,$02,f2,$f2,34,34 +F3,$02,$06,$03,f3,$f3,35,35 +F4,$02,$06,$04,f4,$f4,36,36 +F5,$02,$06,$05,f5,$f5,37,37 +F6,$02,$06,$06,f6,$f6,38,38 +F7,$02,$06,$07,f7,$f7,39,39 +F8,$02,$06,$08,f8,$f8,40,40 +F9,$02,$06,$09,f9,$f9,41,41 +F10,$02,$06,$0A,f10,$f10,42,42 +F11,$02,$06,$0B,f11,$f11,43,43 +F12,$02,$06,$0C,f12,$f12,44,44 +F13,$02,$06,$0D,f13,$f13,45,45 +F14,$02,$06,$0E,f14,$f14,46,46 +F15,$02,$06,$0F,f15,$f15,47,47 +F16,$02,$06,$10,f16,$f16,48,48 +F17,$02,$06,$11,f17,$f17,49,49 +F18,$02,$06,$12,f18,$f18,50,50 +F19,$02,$06,$13,f19,$f19,51,51 +F20,$02,$06,$14,f20,$f20,52,52 +F21,$02,$06,$15,f21,$f21,53,53 +F22,$02,$06,$16,f22,$f22,54,54 +F23,$02,$06,$17,f23,$f23,55,55 +F24,$02,$06,$18,f24,$f24,56,56 +F25,$02,$06,$19,f25,$f25,57,57 +F26,$02,$06,$1A,f26,$f26,58,58 +F27,$02,$06,$1B,f27,$f27,59,59 +F28,$02,$06,$1C,f28,$f28,60,60 +F29,$02,$06,$1D,f29,$f29,61,61 +F30,$02,$06,$1E,f30,$f30,62,62 +F31,$02,$06,$1F,f31,$f31,63,63 PC,$05,$00,$00,PC,pc,-1,-1 HI,$05,$00,$01,HI,hi,68,68 LO,$05,$00,$02,LO,lo,69,69 CR,$05,$00,$03,CR,cr,70,70 -FCR0,$05,$00,$04,FCR0,fcr0,71,71 -FCR25,$05,$00,$05,FCR25,fcr25,72,72 -FCR26,$05,$00,$06,FCR26,fcr26,73,73 -FCR28,$05,$00,$07,FCR28,fcr28,74,74 -FCSR,$05,$00,$08,FCSR,fcsr,75,75 +FCR0,$05,$00,$04,fcr0,fcr0,71,71 +FCR25,$05,$00,$05,fcr25,fcr25,72,72 +FCR26,$05,$00,$06,fcr26,fcr26,73,73 +FCR28,$05,$00,$07,fcr28,fcr28,74,74 +FCSR,$05,$00,$08,fcsr,fcsr,75,75 diff --git a/mips/compiler/mips/ncpucall.pas b/mips/compiler/mips/ncpucall.pas index 450b3802b7..6477c9c789 100644 --- a/mips/compiler/mips/ncpucall.pas +++ b/mips/compiler/mips/ncpucall.pas @@ -26,10 +26,11 @@ unit ncpucall; interface uses - ncgcal; + node, ncgcal; type tMIPSELcallnode = class(tcgcallnode) + function pass_1 : tnode; override; procedure extra_call_code; override; procedure extra_post_call_code; override; end; @@ -38,11 +39,20 @@ type implementation uses - cpubase, + globtype,cpubase,procinfo, aasmtai,aasmcpu,aasmdata, paramgr, ncal; +function TMIPSELcallnode.pass_1 : tnode; +begin + pass_1 := inherited pass_1; + if assigned(current_procinfo) and + assigned(procdefinition) and + (procdefinition.proccalloption=pocall_cdecl) then + include(current_procinfo.flags,pi_needs_got); +end; + procedure tMIPSELcallnode.extra_call_code; begin { MIPS functions should never modify the stack pointer diff --git a/mips/compiler/mips/ncpuld.pas b/mips/compiler/mips/ncpuld.pas new file mode 100644 index 0000000000..75c103da28 --- /dev/null +++ b/mips/compiler/mips/ncpuld.pas @@ -0,0 +1,72 @@ +{ + Copyright (c) 1998-2002 by Florian Klaempfl + + Generate MIPS assembler for nodes that handle loads and assignments + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + 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. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit ncpuld; + +{$I fpcdefs.inc} + +interface + +uses + node, ncgld; + +type + tmipsloadnode = class(tcgloadnode) + function pass_1 : tnode; override; + procedure generate_picvaraccess; override; + end; + +implementation + +uses + verbose, + globtype, + systems, + cpubase, + cgbase, cgutils, cgobj, + aasmbase, aasmtai,aasmdata, + symconst, symsym, + procinfo, + nld; + +function tmipsloadnode.pass_1 : tnode; +begin + pass_1 := inherited pass_1; + case symtableentry.typ of + staticvarsym, + localvarsym, + paravarsym : + if([vo_is_dll_var,vo_is_external] * tabstractvarsym(symtableentry).varoptions <> []) then + include(current_procinfo.flags,pi_needs_got); + end; +end; + +procedure tmipsloadnode.generate_picvaraccess; +begin + location.reference.base:=current_procinfo.got; + location.reference.refaddr:=addr_pic; + location.reference.symbol:=current_asmdata.RefAsmSymbol(tstaticvarsym(symtableentry).mangledname); +end; + +begin + cloadnode := tmipsloadnode; +end. + diff --git a/mips/compiler/mips/opcode.inc b/mips/compiler/mips/opcode.inc index 1f15252bbb..350c9c4545 100644 --- a/mips/compiler/mips/opcode.inc +++ b/mips/compiler/mips/opcode.inc @@ -9,6 +9,9 @@ A_P_FRAME, A_P_MASK, A_P_FMASK, A_P_SW, +A_P_CPLOAD, +A_P_CPRESTORE, +A_P_CPADD, A_SPARC8UNIMP, A_NOP, A_NOT, diff --git a/mips/compiler/mips/rmipssri.inc b/mips/compiler/mips/rmipssri.inc index 84a19da2f2..3e297e23a4 100644 --- a/mips/compiler/mips/rmipssri.inc +++ b/mips/compiler/mips/rmipssri.inc @@ -1,6 +1,14 @@ { don't edit, this file is generated from mipsreg.dat } -32, 68, +66, +0, +67, +65, +5, +6, +7, +8, +2, 33, 34, 43, @@ -38,19 +46,11 @@ 71, 72, 73, -66, -0, -67, -65, -5, -6, -7, -8, -2, 31, 29, 27, 28, +32, 17, 18, 19, diff --git a/mips/compiler/mips/rmipsstd.inc b/mips/compiler/mips/rmipsstd.inc index f03b0d33cb..1b23ada747 100644 --- a/mips/compiler/mips/rmipsstd.inc +++ b/mips/compiler/mips/rmipsstd.inc @@ -31,45 +31,45 @@ 'gp', 'sp', 'fp', -'$a', -'F0', -'F1', -'F2', -'F3', -'F4', -'F5', -'F6', -'F7', -'F8', -'F9', -'F10', -'F11', -'F12', -'F13', -'F14', -'F15', -'F16', -'F17', -'F18', -'F19', -'F20', -'F21', -'F22', -'F23', -'F24', -'F25', -'F26', -'F27', -'F28', -'F29', -'F30', -'F31', +'ra', +'f0', +'f1', +'f2', +'f3', +'f4', +'f5', +'f6', +'f7', +'f8', +'f9', +'f10', +'f11', +'f12', +'f13', +'f14', +'f15', +'f16', +'f17', +'f18', +'f19', +'f20', +'f21', +'f22', +'f23', +'f24', +'f25', +'f26', +'f27', +'f28', +'f29', +'f30', +'f31', 'PC', 'HI', 'LO', 'CR', -'FCR0', -'FCR25', -'FCR26', -'FCR28', -'FCSR' +'fcr0', +'fcr25', +'fcr26', +'fcr28', +'fcsr' diff --git a/mips/compiler/mips/strinst.inc b/mips/compiler/mips/strinst.inc index ccab5b5e0c..d55f207fe1 100644 --- a/mips/compiler/mips/strinst.inc +++ b/mips/compiler/mips/strinst.inc @@ -9,6 +9,9 @@ '.mask', '.fmask', 'p_sw', +'.cpload', +'.cprestore', +'.cpadd', 'sparc8unimp', 'nop', 'not', diff --git a/mips/compiler/msg/errore.msg b/mips/compiler/msg/errore.msg index 190b1adf2a..bc90ddac13 100644 --- a/mips/compiler/msg/errore.msg +++ b/mips/compiler/msg/errore.msg @@ -390,7 +390,7 @@ scan_w_unavailable_system_codepage=02091_W_Current system codepage "$1" is not a # # Parser # -# 03321 is the last used one +# 03322 is the last used one # % \section{Parser messages} % This section lists all parser messages. The parser takes care of the @@ -1199,8 +1199,8 @@ parser_e_forward_mismatch=03249_E_Forward type definition does not match % when being implemented. A forward interface cannot be changed into a class. parser_n_ignore_lower_visibility=03250_N_Virtual method "$1" has a lower visibility ($2) than parent class $3 ($4) % The virtual method overrides an method that is declared with a higher visibility. This might give -% unexpected results. In case the new visibility is private than it might be that a call to inherited in a -% new child class will call the higher visible method in a parent class and ignores the private method. +% unexpected results. E.g., in case the new visibility is private then a call to ``inherited'' in a +% new child class will call the higher-visible method in a parent class and ignores the private method. parser_e_field_not_allowed_here=03251_E_Fields cannot appear after a method or property definition, start a new visibility section first % Once a method or property has been defined in a class or object, you cannot define any fields afterwards % without starting a new visibility section (such as \var{public}, \var{private}, etc.). The reason is @@ -1444,6 +1444,8 @@ parser_e_jvm_invalid_virtual_constructor_call=03321_E_Calling a virtual construc % The JVM does not natively support virtual constructor. Unforunately, we are not aware of a way to % emulate them in a way that makes it possible to support calling virtual constructors % for the current instance inside another constructor. +parser_e_method_lower_visibility=03322_E_Overring method "$1" cannot have a lower visibility ($2) than in parent class $3 ($4) +% The JVM does not allow lowering the visibility of an overriding method. % \end{description} # Type Checking # @@ -3317,6 +3319,7 @@ J*2CT<x>_Target-specific code generation options p*3CTsmalltoc_ Generate smaller TOCs at the expense of execution speed (AIX) P*3CTsmalltoc_ Generate smaller TOCs at the expense of execution speed (AIX) J*3CTcompactintarrayinit_ Generate smaller (but potentially slower) code for initializing integer array constants +K*3CTenumfieldinit_ Initialize enumeration fields in constructors to enumtype(0), after calling inherited constructors J*2Cv_Var/out parameter copy-out checking **2CX_Create also smartlinked library **1d<x>_Defines the symbol <x> diff --git a/mips/compiler/msgidx.inc b/mips/compiler/msgidx.inc index 8d1dcdd12c..ec61df0ce9 100644 --- a/mips/compiler/msgidx.inc +++ b/mips/compiler/msgidx.inc @@ -416,6 +416,7 @@ const parser_d_internal_parser_string=03319; parser_e_feature_unsupported_for_vm=03320; parser_e_jvm_invalid_virtual_constructor_call=03321; + parser_e_method_lower_visibility=03322; type_e_mismatch=04000; type_e_incompatible_types=04001; type_e_not_equal_types=04002; @@ -943,9 +944,9 @@ const option_info=11024; option_help_pages=11025; - MsgTxtSize = 65789; + MsgTxtSize = 66002; MsgIdxMax : array[1..20] of longint=( - 26,92,322,118,87,56,116,26,202,63, + 26,92,323,118,87,56,116,26,202,63, 53,20,1,1,1,1,1,1,1,1 ); diff --git a/mips/compiler/msgtxt.inc b/mips/compiler/msgtxt.inc index e9fcac859e..73a95c0174 100644 --- a/mips/compiler/msgtxt.inc +++ b/mips/compiler/msgtxt.inc @@ -1,7 +1,7 @@ {$ifdef Delphi} -const msgtxt : array[0..000274] of string[240]=( +const msgtxt : array[0..000275] of string[240]=( {$else Delphi} -const msgtxt : array[0..000274,1..240] of char=( +const msgtxt : array[0..000275,1..240] of char=( {$endif Delphi} '01000_T_Compiler: $1'#000+ '01001_D_Compiler OS: $1'#000+ @@ -514,636 +514,632 @@ const msgtxt : array[0..000274,1..240] of char=( '03320_E_This language feature is not supported on managed VM targets'#000+ '03321_E_Calling a virtual constructor for the current instance inside '+ 'another constructor is not possible',' on the JVM target'#000+ + '03322_E_Overring method "$1" cannot have a lower visibility ($2) than '+ + 'in parent class $3 ($4)'#000+ '04000_E_Type mismatch'#000+ '04001_E_Incompatible types: got "$1" expected "$2"'#000+ '04002_E_Type mismatch between "$1" and "$2"'#000+ - '04003_E_Type identifier expected'#000+ + '04003_E_Ty','pe identifier expected'#000+ '04004_E_Variable identifier expected'#000+ - '04005_E_Integer expression expecte','d, but got "$1"'#000+ + '04005_E_Integer expression expected, but got "$1"'#000+ '04006_E_Boolean expression expected, but got "$1"'#000+ '04007_E_Ordinal expression expected'#000+ - '04008_E_pointer type expected, but got "$1"'#000+ + '04008_E_pointer type expected, but got "$1"'#000, '04009_E_class type expected, but got "$1"'#000+ '04011_E_Can'#039't evaluate constant expression'#000+ - '04012_E_S','et elements are not compatible'#000+ + '04012_E_Set elements are not compatible'#000+ '04013_E_Operation not implemented for sets'#000+ '04014_W_Automatic type conversion from floating type to COMP which is '+ - 'an integer type'#000+ + 'an',' integer type'#000+ '04015_H_use DIV instead to get an integer result'#000+ - '04016_E_String types have to ma','tch exactly in $V+ mode'#000+ + '04016_E_String types have to match exactly in $V+ mode'#000+ '04017_E_succ or pred on enums with assignments not possible'#000+ '04018_E_Can'#039't read or write variables of this type'#000+ - '04019_E_Can'#039't use readln or writeln on typed file'#000+ + '04019_E_Can',#039't use readln or writeln on typed file'#000+ '04020_E_Can'#039't use read or write on untyped file.'#000+ - '04021_','E_Type conflict between set elements'#000+ + '04021_E_Type conflict between set elements'#000+ '04022_W_lo/hi(dword/qword) returns the upper/lower word/dword'#000+ '04023_E_Integer or real expression expected'#000+ - '04024_E_Wrong type "$1" in array constructor'#000+ - '04025_E_Incompatible type for arg no. $1: Got "$2", ','expected "$3"'#000+ + '040','24_E_Wrong type "$1" in array constructor'#000+ + '04025_E_Incompatible type for arg no. $1: Got "$2", expected "$3"'#000+ '04026_E_Method (variable) and Procedure (variable) are not compatible'#000+ '04027_E_Illegal constant passed to internal math function'#000+ - '04028_E_Can'#039't take the address of constant expressions'#000+ + '0402','8_E_Can'#039't take the address of constant expressions'#000+ '04029_E_Argument can'#039't be assigned to'#000+ - '04030','_E_Can'#039't assign local procedure/function to procedure varia'+ - 'ble'#000+ + '04030_E_Can'#039't assign local procedure/function to procedure variabl'+ + 'e'#000+ '04031_E_Can'#039't assign values to an address'#000+ - '04032_E_Can'#039't assign values to const variable'#000+ + '04032_E_Can'#039't assign values to const vari','able'#000+ '04033_E_Array type required'#000+ '04034_E_interface type expected, but got "$1"'#000+ - '04035_H_Mixing ','signed expressions and longwords gives a 64bit result'+ - #000+ + '04035_H_Mixing signed expressions and longwords gives a 64bit result'#000+ '04036_W_Mixing signed expressions and cardinals here may cause a range'+ ' check error'#000+ - '04037_E_Typecast has different size ($1 -> $2) in assignment'#000+ - '04038_E_enums with assignments can'#039't be us','ed as array index'#000+ + '04037_E_T','ypecast has different size ($1 -> $2) in assignment'#000+ + '04038_E_enums with assignments can'#039't be used as array index'#000+ '04039_E_Class or Object types "$1" and "$2" are not related'#000+ '04040_W_Class types "$1" and "$2" are not related'#000+ - '04041_E_Class or interface type expected, but got "$1"'#000+ + '04041_E_Class or i','nterface type expected, but got "$1"'#000+ '04042_E_Type "$1" is not completely defined'#000+ - '04043_W_Strin','g literal has more characters than short string length'#000+ + '04043_W_String literal has more characters than short string length'#000+ '04044_W_Comparison might be always false due to range of constant and '+ 'expression'#000+ - '04045_W_Comparison might be always true due to range of constant and e'+ - 'xpression'#000+ - '04046_W_Constructing a c','lass "$1" with abstract method "$2"'#000+ + '04045_W_Co','mparison might be always true due to range of constant and'+ + ' expression'#000+ + '04046_W_Constructing a class "$1" with abstract method "$2"'#000+ '04047_H_The left operand of the IN operator should be byte sized'#000+ - '04048_W_Type size mismatch, possible loss of data / range check error'#000+ - '04049_H_Type size mismatch, possible loss of data / range check error', - #000+ + '04048_W_Type size mismatch, possible loss of ','data / range check erro'+ + 'r'#000+ + '04049_H_Type size mismatch, possible loss of data / range check error'#000+ '04050_E_The address of an abstract method can'#039't be taken'#000+ '04051_E_Assignments to formal parameters and open arrays are not possi'+ 'ble'#000+ - '04052_E_Constant Expression expected'#000+ + '04052_E_Consta','nt Expression expected'#000+ '04053_E_Operation "$1" not supported for types "$2" and "$3"'#000+ - '04054_E_Il','legal type conversion: "$1" to "$2"'#000+ + '04054_E_Illegal type conversion: "$1" to "$2"'#000+ '04055_H_Conversion between ordinals and pointers is not portable'#000+ - '04056_W_Conversion between ordinals and pointers is not portable'#000+ + '04056_W_Conversion between ordinals and point','ers is not portable'#000+ '04057_E_Can'#039't determine which overloaded function to call'#000+ - '04058_E_Illegal ','counter variable'#000+ + '04058_E_Illegal counter variable'#000+ '04059_W_Converting constant real value to double for C variable argume'+ 'nt, add explicit typecast to prevent this.'#000+ - '04060_E_Class or COM interface type expected, but got "$1"'#000+ - '04061_E_Constant packed arrays are not yet supporte','d'#000+ + '04060_E_Class or',' COM interface type expected, but got "$1"'#000+ + '04061_E_Constant packed arrays are not yet supported'#000+ '04062_E_Incompatible type for arg no. $1: Got "$2" expected "(Bit)Pack'+ 'ed Array"'#000+ - '04063_E_Incompatible type for arg no. $1: Got "$2" expected "(not pack'+ - 'ed) Array"'#000+ + '04063_E_Incompatible type for arg no. $1: Got "$2" expected "(no','t pa'+ + 'cked) Array"'#000+ '04064_E_Elements of packed arrays cannot be of a type which need to be'+ - ' initia','lised'#000+ + ' initialised'#000+ '04065_E_Constant packed records and objects are not yet supported'#000+ '04066_W_Arithmetic "$1" on untyped pointer is unportable to {$T+}, sug'+ - 'gest typecast'#000+ + 'gest',' typecast'#000+ '04076_E_Can'#039't take address of a subroutine marked as local'#000+ - '04077_E_Can'#039't export subr','outine marked as local from a unit'#000+ + '04077_E_Can'#039't export subroutine marked as local from a unit'#000+ '04078_E_Type is not automatable: "$1"'#000+ '04079_H_Converting the operands to "$1" before doing the add could pre'+ - 'vent overflow errors.'#000+ + 'ven','t overflow errors.'#000+ '04080_H_Converting the operands to "$1" before doing the subtract coul'+ - 'd pre','vent overflow errors.'#000+ + 'd prevent overflow errors.'#000+ '04081_H_Converting the operands to "$1" before doing the multiply coul'+ 'd prevent overflow errors.'#000+ - '04082_W_Converting pointers to signed integers may result in wrong com'+ - 'parison results and range errors, use an unsigned t','ype instead.'#000+ + '04082_W_Converting pointers',' to signed integers may result in wrong c'+ + 'omparison results and range errors, use an unsigned type instead.'#000+ '04083_E_Interface type $1 has no valid GUID'#000+ '04084_E_Invalid selector name "$1"'#000+ '04085_E_Expected Objective-C method, but got $1'#000+ - '04086_E_Expected Objective-C method or constant method name'#000+ - '04087_E_No type info available for this ','type'#000+ + '04086_','E_Expected Objective-C method or constant method name'#000+ + '04087_E_No type info available for this type'#000+ '04088_E_Ordinal or string expression expected'#000+ '04089_E_String expression expected'#000+ '04090_W_Converting 0 to NIL'#000+ - '04091_E_Objective-C protocol type expected, but got "$1"'#000+ - '04092_E_The type "$1" is not supported for interaction with the Objec', - 'tive-C runtime.'#000+ + '04091_E_Objective-C protocol typ','e expected, but got "$1"'#000+ + '04092_E_The type "$1" is not supported for interaction with the Object'+ + 'ive-C runtime.'#000+ '04093_E_Class or objcclass type expected, but got "$1"'#000+ '04094_E_Objcclass type expected'#000+ - '04095_W_Coerced univ parameter type in procedural variable may cause c'+ - 'rash or memory corruption: $1 to $2'#000+ - '04096_E_Type parameters of spec','ializations of generics cannot refere'+ - 'nce the currently specialized type'#000+ + '04095_W_Coerced univ parameter type in proc','edural variable may cause'+ + ' crash or memory corruption: $1 to $2'#000+ + '04096_E_Type parameters of specializations of generics cannot referenc'+ + 'e the currently specialized type'#000+ '04097_E_Type parameters are not allowed on non-generic class/record/ob'+ - 'ject procedure or function'#000+ + 'ject',' procedure or function'#000+ '04098_E_Generic declaration of "$1" differs from previous declaration'#000+ - '0','4099_E_Helper type expected'#000+ + '04099_E_Helper type expected'#000+ '04100_E_Record type expected'#000+ '04101_E_Derived class helper must extend a subclass of "$1" or the cla'+ 'ss itself'#000+ - '04102_E_Derived record helper must extend "$1"'#000+ + '04102_E_D','erived record helper must extend "$1"'#000+ '04103_E_Invalid assignment, procedures return no value'#000+ - '0','4104_W_Implicit string type conversion from "$1" to "$2"'#000+ + '04104_W_Implicit string type conversion from "$1" to "$2"'#000+ '04105_W_Implicit string type conversion with potential data loss from '+ '"$1" to "$2"'#000+ - '04106_-W_Explicit string typecast from "$1" to "$2"'#000+ - '04107_-W_Explicit string typecast with potential',' data loss from "$1"'+ - ' to "$2"'#000+ + '04106_','-W_Explicit string typecast from "$1" to "$2"'#000+ + '04107_-W_Explicit string typecast with potential data loss from "$1" t'+ + 'o "$2"'#000+ '04108_W_Unicode constant cast with potential data loss'#000+ - '04109_E_range check error while evaluating constants ($1 must be betwe'+ - 'en $2 and $3)'#000+ + '04109_E_range check error while evaluating constants ($1 must ','be bet'+ + 'ween $2 and $3)'#000+ '04110_W_range check error while evaluating constants ($1 must be betwe'+ - 'en',' $2 and $3)'#000+ + 'en $2 and $3)'#000+ '04111_E_This type is not supported for the Default() intrinsic'#000+ '04112_E_JVM virtual class methods cannot be static'#000+ - '04113_E_Final (class) fields can only be assigned in their class'#039' '+ - '(class) constructor'#000+ - '04114_E_It is not possible t','o typecast untyped parameters on managed'+ - ' platforms, simply assign a value to them instead.'#000+ - '04115_E_The assignment side of an expression cannot be typecasted to a'+ - ' supertype on managed platforms'#000+ - '04116_-W_The interface method "$1" raises the v','isibility of "$2" to '+ - 'public when accessed via an interface instance'#000+ + '04113_E_Final (class',') fields can only be assigned in their class'#039+ + ' (class) constructor'#000+ + '04114_E_It is not possible to typecast untyped parameters on managed p'+ + 'latforms, simply assign a value to them instead.'#000+ + '04115_E_The assignment side of an expression cannot be ','typecasted to'+ + ' a supertype on managed platforms'#000+ + '04116_-W_The interface method "$1" raises the visibility of "$2" to pu'+ + 'blic when accessed via an interface instance'#000+ '04117_E_The interface method "$1" has a higher visibility (public) tha'+ 'n "$2"'#000+ - '05000_E_Identifier not found "$1"'#000+ + '0','5000_E_Identifier not found "$1"'#000+ '05001_F_Internal Error in SymTableStack()'#000+ - '05002_E_Duplicate i','dentifier "$1"'#000+ + '05002_E_Duplicate identifier "$1"'#000+ '05003_H_Identifier already defined in $1 at line $2'#000+ '05004_E_Unknown identifier "$1"'#000+ '05005_E_Forward declaration not solved "$1"'#000+ - '05007_E_Error in type definition'#000+ + '050','07_E_Error in type definition'#000+ '05009_E_Forward type not resolved "$1"'#000+ - '05010_E_Only static varia','bles can be used in static methods or outsi'+ - 'de methods'#000+ + '05010_E_Only static variables can be used in static methods or outside'+ + ' methods'#000+ '05012_F_record or class type expected'#000+ - '05013_E_Instances of classes or objects with an abstract method are no'+ - 't allowed'#000+ + '05013_E_Instances of classes or objects with an abstra','ct method are '+ + 'not allowed'#000+ '05014_W_Label not defined "$1"'#000+ - '05015_E_Label used but not defined "$','1"'#000+ + '05015_E_Label used but not defined "$1"'#000+ '05016_E_Illegal label declaration'#000+ '05017_E_GOTO and LABEL are not supported (use switch -Sg)'#000+ '05018_E_Label not found'#000+ - '05019_E_identifier isn'#039't a label'#000+ + '05019_E_identifier isn'#039't a ','label'#000+ '05020_E_label already defined'#000+ '05021_E_illegal type declaration of set elements'#000+ - '05022_E_F','orward class definition not resolved "$1"'#000+ + '05022_E_Forward class definition not resolved "$1"'#000+ '05023_H_Unit "$1" not used in $2'#000+ '05024_H_Parameter "$1" not used'#000+ '05025_N_Local variable "$1" not used'#000+ - '05026_H_Value parameter "$1" is assigned but never used'#000+ - '05027_N_Local variable "$1" is assigned ','but never used'#000+ + '05','026_H_Value parameter "$1" is assigned but never used'#000+ + '05027_N_Local variable "$1" is assigned but never used'#000+ '05028_H_Local $1 "$2" is not used'#000+ '05029_N_Private field "$1.$2" is never used'#000+ - '05030_N_Private field "$1.$2" is assigned but never used'#000+ + '05030_N_Private field "$1.$2" is assigned but never u','sed'#000+ '05031_N_Private method "$1.$2" never used'#000+ '05032_E_Set type expected'#000+ - '05033_W_Function resul','t does not seem to be set'#000+ + '05033_W_Function result does not seem to be set'#000+ '05034_W_Type "$1" is not aligned correctly in current record for C'#000+ '05035_E_Unknown record field identifier "$1"'#000+ - '05036_W_Local variable "$1" does not seem to be initialized'#000+ - '05037_W_Variable "$1" does not seem to be ','initialized'#000+ + '05036_W_','Local variable "$1" does not seem to be initialized'#000+ + '05037_W_Variable "$1" does not seem to be initialized'#000+ '05038_E_identifier idents no member "$1"'#000+ '05039_H_Found declaration: $1'#000+ '05040_E_Data element too large'#000+ - '05042_E_No matching implementation for interface method "$1" found'#000+ + '05042_E_No matching implementati','on for interface method "$1" found'#000+ '05043_W_Symbol "$1" is deprecated'#000+ - '05044_W_Symbol "$1" is no','t portable'#000+ + '05044_W_Symbol "$1" is not portable'#000+ '05055_W_Symbol "$1" is not implemented'#000+ '05056_E_Can'#039't create unique type from this type'#000+ - '05057_H_Local variable "$1" does not seem to be initialized'#000+ + '05057_H_Local variable "$1" does not seem to be ','initialized'#000+ '05058_H_Variable "$1" does not seem to be initialized'#000+ - '05059_W_Function result vari','able does not seem to initialized'#000+ + '05059_W_Function result variable does not seem to initialized'#000+ '05060_H_Function result variable does not seem to be initialized'#000+ - '05061_W_Variable "$1" read but nowhere assigned'#000+ + '05061_W_Variable "$1" read but nowhere assigned',#000+ '05062_H_Found abstract method: $1'#000+ '05063_W_Symbol "$1" is experimental'#000+ - '05064_W_Forward declara','tion "$1" not resolved, assumed external'#000+ + '05064_W_Forward declaration "$1" not resolved, assumed external'#000+ '05065_W_Symbol "$1" is belongs to a library'#000+ '05066_W_Symbol "$1" is deprecated: "$2"'#000+ - '05067_E_Cannot find an enumerator for the type "$1"'#000+ + '05067_E_Cannot find a','n enumerator for the type "$1"'#000+ '05068_E_Cannot find a "MoveNext" method in enumerator "$1"'#000+ - '0506','9_E_Cannot find a "Current" property in enumerator "$1"'#000+ + '05069_E_Cannot find a "Current" property in enumerator "$1"'#000+ '05070_E_Mismatch between number of declared parameters and number of c'+ - 'olons in message string.'#000+ + 'olons in message str','ing.'#000+ '05071_N_Private type "$1.$2" never used'#000+ '05072_N_Private const "$1.$2" never used'#000+ - '05073_N_','Private property "$1.$2" never used'#000+ + '05073_N_Private property "$1.$2" never used'#000+ '05074_W_Unit "$1" is deprecated'#000+ '05075_W_Unit "$1" is deprecated: "$2"'#000+ '05076_W_Unit "$1" is not portable'#000+ - '05077_W_Unit "$1" is belongs to a library'#000+ + '05077_','W_Unit "$1" is belongs to a library'#000+ '05078_W_Unit "$1" is not implemented'#000+ - '05079_W_Unit "$1" is ','experimental'#000+ + '05079_W_Unit "$1" is experimental'#000+ '05080_E_No complete definition of the formally declared class "$1" is '+ 'in scope'#000+ - '05081_E_Gotos into initialization or finalization blocks of units are '+ - 'not allowed'#000+ + '05081_E_Gotos into initialization or finalization bloc','ks of units ar'+ + 'e not allowed'#000+ '05082_E_Invalid external name "$1" for formal class "$2"'#000+ - '05083_E_C','omplete class definition with external name "$1" here'#000+ + '05083_E_Complete class definition with external name "$1" here'#000+ '05084_W_Possible library conflict: symbol "$1" from library "$2" also '+ - 'found in library "$3"'#000+ + 'found in library "$3"'#000, '05085_E_Cannot add implicit constructor '#039'Create'#039' because ident'+ 'ifier already used by "$1"'#000+ - '05086','_E_Cannot generate default constructor for class, because paren'+ - 't has no parameterless constructor'#000+ - '06009_E_Parameter list size exceeds 65535 bytes'#000+ + '05086_E_Cannot generate default constructor for class, because parent '+ + 'has no parameterless constructor'#000+ + '06009_E_Parameter list size exceeds 65535 bytes'#000, '06012_E_File types must be var parameters'#000+ - '06013_E_The use of a far pointer isn'#039't allowed there',#000+ + '06013_E_The use of a far pointer isn'#039't allowed there'#000+ '06015_E_EXPORT declared functions can'#039't be called'#000+ '06016_W_Possible illegal call of constructor or destructor'#000+ '06017_N_Inefficient code'#000+ - '06018_W_unreachable code'#000+ + '06018_W_unr','eachable code'#000+ '06020_E_Abstract methods can'#039't be called directly'#000+ - '06027_DL_Register $1 weight $2',' $3'#000+ + '06027_DL_Register $1 weight $2 $3'#000+ '06029_DL_Stack frame is omitted'#000+ '06031_E_Object or class methods can'#039't be inline.'#000+ '06032_E_Procvar calls cannot be inline.'#000+ - '06033_E_No code for inline procedure stored'#000+ + '06033_E_No code for i','nline procedure stored'#000+ '06035_E_Element zero of an ansi/wide- or longstring can'#039't be acces'+ - 'sed, ','use (set)length instead'#000+ + 'sed, use (set)length instead'#000+ '06037_E_Constructors or destructors cannot be called inside a '#039'wit'+ 'h'#039' clause'#000+ - '06038_E_Cannot call message handler methods directly'#000+ + '06038_E_Cannot call message handler methods di','rectly'#000+ '06039_E_Jump in or outside of an exception block'#000+ - '06040_E_Control flow statements aren'#039't',' allowed in a finally bloc'+ - 'k'#000+ + '06040_E_Control flow statements aren'#039't allowed in a finally block'#000+ '06041_W_Parameters size exceeds limit for certain cpu'#039's'#000+ '06042_W_Local variable size exceed limit for certain cpu'#039's'#000+ - '06043_E_Local variables size exceeds supported limit'#000+ + '060','43_E_Local variables size exceeds supported limit'#000+ '06044_E_BREAK not allowed'#000+ - '06045_E_CONTINUE n','ot allowed'#000+ + '06045_E_CONTINUE not allowed'#000+ '06046_F_Unknown compilerproc "$1". Check if you use the correct run ti'+ 'me library.'#000+ - '06047_F_Cannot find system type "$1". Check if you use the correct run'+ - ' time library.'#000+ + '06047_F_Cannot find system type "$1". Check if you us','e the correct r'+ + 'un time library.'#000+ '06048_H_Inherited call to abstract method ignored'#000+ - '06049_E_Goto',' label "$1" not defined or optimized away'#000+ + '06049_E_Goto label "$1" not defined or optimized away'#000+ '06050_F_Cannot find type "$1" in unit "$2". Check if you use the corre'+ 'ct run time library.'#000+ - '06051_E_Interprocedural gotos are allowed only to outer subroutines'#000+ - '06052_E_Label must be defined in the sa','me scope as it is declared'#000+ + '06051_E_Inter','procedural gotos are allowed only to outer subroutines'#000+ + '06052_E_Label must be defined in the same scope as it is declared'#000+ '06053_E_Leaving procedures containing explicit or implicit exceptions '+ 'frames using goto is not allowed'#000+ - '06054_E_In ISO mode, the mod operator is defined only for positive quo'+ - 'tient'#000+ + '06054_E_In ISO m','ode, the mod operator is defined only for positive q'+ + 'uotient'#000+ '06055_DL_Auto inlining: $1'#000+ - '07000_D','L_Starting $1 styled assembler parsing'#000+ + '07000_DL_Starting $1 styled assembler parsing'#000+ '07001_DL_Finished $1 styled assembler parsing'#000+ '07002_E_Non-label pattern contains @'#000+ - '07004_E_Error building record offset'#000+ + '07004_E_Error building r','ecord offset'#000+ '07005_E_OFFSET used without identifier'#000+ '07006_E_TYPE used without identifier'#000+ - '07007','_E_Cannot use local variable or parameters here'#000+ + '07007_E_Cannot use local variable or parameters here'#000+ '07008_E_need to use OFFSET here'#000+ '07009_E_need to use $ here'#000+ - '07010_E_Cannot use multiple relocatable symbols'#000+ + '07010_E_Cannot use multiple relocatable',' symbols'#000+ '07011_E_Relocatable symbol can only be added'#000+ '07012_E_Invalid constant expression'#000+ - '0701','3_E_Relocatable symbol is not allowed'#000+ + '07013_E_Relocatable symbol is not allowed'#000+ '07014_E_Invalid reference syntax'#000+ '07015_E_You cannot reach $1 from that code'#000+ - '07016_E_Local symbols/labels aren'#039't allowed as references'#000+ + '07016_E_Local symbols/labels are','n'#039't allowed as references'#000+ '07017_E_Invalid base and index register usage'#000+ - '07018_W_Possible error',' in object field handling'#000+ + '07018_W_Possible error in object field handling'#000+ '07019_E_Wrong scale factor specified'#000+ '07020_E_Multiple index register usage'#000+ '07021_E_Invalid operand type'#000+ - '07022_E_Invalid string as opcode operand: $1'#000+ + '07022_E_Invalid ','string as opcode operand: $1'#000+ '07023_W_@CODE and @DATA not supported'#000+ - '07024_E_Null label referenc','es are not allowed'#000+ + '07024_E_Null label references are not allowed'#000+ '07025_E_Divide by zero in asm evaluator'#000+ '07026_E_Illegal expression'#000+ '07027_E_escape sequence ignored: $1'#000+ - '07028_E_Invalid symbol reference'#000+ + '07028_E_Invalid symbol r','eference'#000+ '07029_W_Fwait can cause emulation problems with emu387'#000+ - '07030_W_$1 without operand tra','nslated into $1P'#000+ + '07030_W_$1 without operand translated into $1P'#000+ '07031_W_ENTER instruction is not supported by Linux kernel'#000+ '07032_W_Calling an overload function in assembler'#000+ - '07033_E_Unsupported symbol type for operand'#000+ + '07033_E_Unsupported ','symbol type for operand'#000+ '07034_E_Constant value out of bounds'#000+ - '07035_E_Error converting decimal ','$1'#000+ + '07035_E_Error converting decimal $1'#000+ '07036_E_Error converting octal $1'#000+ '07037_E_Error converting binary $1'#000+ '07038_E_Error converting hexadecimal $1'#000+ '07039_H_$1 translated to $2'#000+ - '07040_W_$1 is associated to an overloaded function'#000+ + '07040_','W_$1 is associated to an overloaded function'#000+ '07041_E_Cannot use SELF outside a method'#000+ - '07042_E_','Cannot use OLDEBP outside a nested procedure'#000+ + '07042_E_Cannot use OLDEBP outside a nested procedure'#000+ '07043_W_Procedures can'#039't return any value in asm code'#000+ '07044_E_SEG not supported'#000+ - '07045_E_Size suffix and destination or source size do not match'#000+ - '07046_W_Size suffix and destination or source size ','do not match'#000+ + '07045_E_Size suffix a','nd destination or source size do not match'#000+ + '07046_W_Size suffix and destination or source size do not match'#000+ '07047_E_Assembler syntax error'#000+ '07048_E_Invalid combination of opcode and operands'#000+ '07049_E_Assembler syntax error in operand'#000+ - '07050_E_Assembler syntax error in constant'#000+ + '07050_E_A','ssembler syntax error in constant'#000+ '07051_E_Invalid String expression'#000+ - '07052_W_constant with symb','ol $1 for address which is not on a pointe'+ - 'r'#000+ + '07052_W_constant with symbol $1 for address which is not on a pointer'#000+ '07053_E_Unrecognized opcode $1'#000+ '07054_E_Invalid or missing opcode'#000+ - '07055_E_Invalid combination of prefix and opcode: $1'#000+ + '07055_E_Invalid combination of prefix',' and opcode: $1'#000+ '07056_E_Invalid combination of override and opcode: $1'#000+ - '07057_E_Too many operan','ds on line'#000+ + '07057_E_Too many operands on line'#000+ '07058_W_NEAR ignored'#000+ '07059_W_FAR ignored'#000+ '07060_E_Duplicate local symbol $1'#000+ '07061_E_Undefined local symbol $1'#000+ - '07062_E_Unknown label identifier $1'#000+ + '07062_E_Unknown label iden','tifier $1'#000+ '07063_E_Invalid register name'#000+ '07064_E_Invalid floating point register name'#000+ - '07066_W_M','odulo not supported'#000+ + '07066_W_Modulo not supported'#000+ '07067_E_Invalid floating point constant $1'#000+ '07068_E_Invalid floating point expression'#000+ '07069_E_Wrong symbol type'#000+ - '07070_E_Cannot index a local var or parameter with a register'#000+ + '07070_E_Cannot ','index a local var or parameter with a register'#000+ '07071_E_Invalid segment override expression'#000+ - '070','72_W_Identifier $1 supposed external'#000+ + '07072_W_Identifier $1 supposed external'#000+ '07073_E_Strings not allowed as constants'#000+ '07074_E_No type of variable specified'#000+ - '07075_E_assembler code not returned to text section'#000+ + '07075_E_assembler code not ret','urned to text section'#000+ '07076_E_Not a directive or local symbol $1'#000+ - '07077_E_Using a defined name ','as a local label'#000+ + '07077_E_Using a defined name as a local label'#000+ '07078_E_Dollar token is used without an identifier'#000+ '07079_W_32bit constant created for address'#000+ - '07080_N_.align is target specific, use .balign or .p2align'#000+ + '07080_N_.align is target specific, ','use .balign or .p2align'#000+ '07081_E_Can'#039't access fields directly for parameters'#000+ - '07082_E_Can'#039't acce','ss fields of objects/classes directly'#000+ + '07082_E_Can'#039't access fields of objects/classes directly'#000+ '07083_E_No size specified and unable to determine the size of the oper'+ 'ands'#000+ - '07084_E_Cannot use RESULT in this function'#000+ + '07084_E_Cannot use RESULT in this',' function'#000+ '07086_W_"$1" without operand translated into "$1 %st,%st(1)"'#000+ - '07087_W_"$1 %st(n)" tra','nslated into "$1 %st,%st(n)"'#000+ + '07087_W_"$1 %st(n)" translated into "$1 %st,%st(n)"'#000+ '07088_W_"$1 %st(n)" translated into "$1 %st(n),%st"'#000+ '07089_E_Char < not allowed here'#000+ '07090_E_Char > not allowed here'#000+ - '07093_W_ALIGN not supported'#000+ + '0','7093_W_ALIGN not supported'#000+ '07094_E_Inc and Dec cannot be together'#000+ - '07095_E_Invalid reglist for ','movem'#000+ + '07095_E_Invalid reglist for movem'#000+ '07096_E_Reglist invalid for opcode'#000+ '07097_E_Higher cpu mode required ($1)'#000+ - '07098_W_No size specified and unable to determine the size of the oper'+ - 'ands, using DWORD as default'#000+ + '07098_W_No size specified and unable to determine the size of the o','p'+ + 'erands, using DWORD as default'#000+ '07099_E_Syntax error while trying to parse a shifter operand'#000+ - '0','7100_E_Address of packed component is not at a byte boundary'#000+ + '07100_E_Address of packed component is not at a byte boundary'#000+ '07101_W_No size specified and unable to determine the size of the oper'+ - 'ands, using BYTE as default'#000+ + 'ands, using BYT','E as default'#000+ '07102_W_Use of +offset(%ebp) for parameters invalid here'#000+ - '07103_W_Use of +offset(%','ebp) is not compatible with regcall conventi'+ - 'on'#000+ + '07103_W_Use of +offset(%ebp) is not compatible with regcall convention'+ + #000+ '07104_W_Use of -offset(%ebp) is not recommended for local variable acc'+ 'ess'#000+ - '07105_W_Use of -offset(%esp), access may cause a crash or value may be'+ - ' lost'#000+ - '07106_E_VMTOffset must be used in combinati','on with a virtual method,'+ - ' and "$1" is not virtual'#000+ + '07105_W_Use of -offset(%e','sp), access may cause a crash or value may '+ + 'be lost'#000+ + '07106_E_VMTOffset must be used in combination with a virtual method, a'+ + 'nd "$1" is not virtual'#000+ '07107_E_Generating PIC, but reference is not PIC-safe'#000+ - '07108_E_All registers in a register set must be of the same kind and w'+ - 'idth'#000+ + '07108_E_All registers in a register set mu','st be of the same kind and'+ + ' width'#000+ '07109_E_A register set cannot be empty'#000+ - '07110_W_@GOTPCREL is u','seless and potentially dangereous for local sy'+ - 'mbols'#000+ + '07110_W_@GOTPCREL is useless and potentially dangereous for local symb'+ + 'ols'#000+ '07111_W_Constant with general purpose segment register'#000+ '07112_E_Invalid offset value for $1'#000+ - '07113_E_Invalid register for $1'#000+ - '07114_E_SEH directives are allowed only in pure assembler procedu','res'+ - #000+ + '071','13_E_Invalid register for $1'#000+ + '07114_E_SEH directives are allowed only in pure assembler procedures'#000+ '07115_E_Directive "$1" is not supported for the current target'#000+ '08000_F_Too many assembler files'#000+ - '08001_F_Selected assembler output not supported'#000+ + '08001_F_Selected assembler output not supporte','d'#000+ '08002_F_Comp not supported'#000+ '08003_F_Direct not support for binary writers'#000+ - '08004_E_Allocating ','of data is only allowed in bss section'#000+ + '08004_E_Allocating of data is only allowed in bss section'#000+ '08005_F_No binary writer selected'#000+ '08006_E_Asm: Opcode $1 not in table'#000+ - '08007_E_Asm: $1 invalid combination of opcode and operands'#000+ + '08007_E_Asm: $1 invalid combination o','f opcode and operands'#000+ '08008_E_Asm: 16 Bit references not supported'#000+ - '08009_E_Asm: Invalid effect','ive address'#000+ + '08009_E_Asm: Invalid effective address'#000+ '08010_E_Asm: Immediate or reference expected'#000+ '08011_E_Asm: $1 value exceeds bounds $2'#000+ '08012_E_Asm: Short jump is out of range $1'#000+ - '08013_E_Asm: Undefined label $1'#000+ + '08013_','E_Asm: Undefined label $1'#000+ '08014_E_Asm: Comp type not supported for this target'#000+ - '08015_E_Asm: Ex','tended type not supported for this target'#000+ + '08015_E_Asm: Extended type not supported for this target'#000+ '08016_E_Asm: Duplicate label $1'#000+ '08017_E_Asm: Redefined label $1'#000+ '08018_E_Asm: First defined here'#000+ - '08019_E_Asm: Invalid register $1'#000+ + '08019_E_','Asm: Invalid register $1'#000+ '08020_E_Asm: 16 or 32 Bit references not supported'#000+ - '08021_E_Asm: 64 Bi','t operands not supported'#000+ + '08021_E_Asm: 64 Bit operands not supported'#000+ '08022_E_Asm: AH,BH,CH or DH cannot be used in an instruction requiring'+ ' REX prefix'#000+ - '08023_E_Missing .seh_endprologue directive'#000+ + '08023_E_Missing .seh_endprologue direct','ive'#000+ '08024_E_Function prologue exceeds 255 bytes'#000+ - '08025_E_.seh_handlerdata directive without pre','ceding .seh_handler'#000+ + '08025_E_.seh_handlerdata directive without preceding .seh_handler'#000+ '09000_W_Source operating system redefined'#000+ '09001_I_Assembling (pipe) $1'#000+ '09002_E_Can'#039't create assembler file: $1'#000+ - '09003_E_Can'#039't create object file: $1 (error code: $2)'#000+ + '09003_E_Can'#039't c','reate object file: $1 (error code: $2)'#000+ '09004_E_Can'#039't create archive file: $1'#000+ - '09005_E_Assembler',' $1 not found, switching to external assembling'#000+ + '09005_E_Assembler $1 not found, switching to external assembling'#000+ '09006_T_Using assembler: $1'#000+ '09007_E_Error while assembling exitcode $1'#000+ - '09008_E_Can'#039't call the assembler, error $1 switching to external a'+ - 'ssembling'#000+ + '09008_E_Can'#039't call the asse','mbler, error $1 switching to external'+ + ' assembling'#000+ '09009_I_Assembling $1'#000+ - '09010_I_Assembling with',' smartlinking $1'#000+ + '09010_I_Assembling with smartlinking $1'#000+ '09011_W_Object $1 not found, Linking may fail !'#000+ '09012_W_Library $1 not found, Linking may fail !'#000+ '09013_E_Error while linking'#000+ - '09014_E_Can'#039't call the linker, switching to external linking'#000+ + '0901','4_E_Can'#039't call the linker, switching to external linking'#000+ '09015_I_Linking $1'#000+ - '09016_E_Util $1 no','t found, switching to external linking'#000+ + '09016_E_Util $1 not found, switching to external linking'#000+ '09017_T_Using util $1'#000+ '09018_E_Creation of Executables not supported'#000+ - '09019_E_Creation of Dynamic/Shared Libraries not supported'#000+ + '09019_E_Creation of Dynamic/Shared Libr','aries not supported'#000+ '09020_I_Closing script $1'#000+ - '09021_E_resource compiler "$1" not found, switch','ing to external mode'+ - #000+ + '09021_E_resource compiler "$1" not found, switching to external mode'#000+ '09022_I_Compiling resource $1'#000+ '09023_T_unit $1 can'#039't be statically linked, switching to smart lin'+ 'king'#000+ - '09024_T_unit $1 can'#039't be smart linked, switching to static linking'+ - #000+ - '09025_T_unit $1 can'#039't be shared linked, switching t','o static link'+ - 'ing'#000+ + '09024_T_unit $1 can'#039't be',' smart linked, switching to static linki'+ + 'ng'#000+ + '09025_T_unit $1 can'#039't be shared linked, switching to static linkin'+ + 'g'#000+ '09026_E_unit $1 can'#039't be smart or static linked'#000+ '09027_E_unit $1 can'#039't be shared or static linked'#000+ - '09028_D_Calling resource compiler "$1" with "$2" as command line'#000+ + '09028_D_Calling resource compile','r "$1" with "$2" as command line'#000+ '09029_E_Error while compiling resources'#000+ - '09030_E_Can'#039't call th','e resource compiler "$1", switching to exte'+ - 'rnal mode'#000+ + '09030_E_Can'#039't call the resource compiler "$1", switching to extern'+ + 'al mode'#000+ '09031_E_Can'#039't open resource file "$1"'#000+ '09032_E_Can'#039't write resource file "$1"'#000+ - '09033_N_File "$1" not found for backquoted cat command'#000+ + '09033_N_File "$1','" not found for backquoted cat command'#000+ '09128_F_Can'#039't post process executable $1'#000+ - '09129_F_Can'#039't ','open executable $1'#000+ + '09129_F_Can'#039't open executable $1'#000+ '09130_X_Size of Code: $1 bytes'#000+ '09131_X_Size of initialized data: $1 bytes'#000+ '09132_X_Size of uninitialized data: $1 bytes'#000+ - '09133_X_Stack space reserved: $1 bytes'#000+ + '09133_X_','Stack space reserved: $1 bytes'#000+ '09134_X_Stack space committed: $1 bytes'#000+ - '09200_F_Executable imag','e size is too big for $1 target.'#000+ + '09200_F_Executable image size is too big for $1 target.'#000+ '09201_W_Object file "$1" contains 32-bit absolute relocation to symbol'+ ' "$2".'#000+ '10000_T_Unitsearch: $1'#000+ - '10001_T_PPU Loading $1'#000+ + '10001_T_PPU L','oading $1'#000+ '10002_U_PPU Name: $1'#000+ '10003_U_PPU Flags: $1'#000+ '10004_U_PPU Crc: $1'#000+ - '10005_U_PPU Time: $1'#000, + '10005_U_PPU Time: $1'#000+ '10006_U_PPU File too short'#000+ '10007_U_PPU Invalid Header (no PPU at the begin)'#000+ '10008_U_PPU Invalid Version $1'#000+ - '10009_U_PPU is compiled for another processor'#000+ + '10009_U_PPU is compiled for another pro','cessor'#000+ '10010_U_PPU is compiled for another target'#000+ '10011_U_PPU Source: $1'#000+ '10012_U_Writing $1'#000+ - '10','013_F_Can'#039't Write PPU-File'#000+ + '10013_F_Can'#039't Write PPU-File'#000+ '10014_F_Error reading PPU-File'#000+ '10015_F_unexpected end of PPU-File'#000+ '10016_F_Invalid PPU-File entry: $1'#000+ - '10017_F_PPU Dbx count problem'#000+ + '10017_F_PPU Dbx co','unt problem'#000+ '10018_E_Illegal unit name: $1'#000+ '10019_F_Too much units'#000+ - '10020_F_Circular unit referen','ce between $1 and $2'#000+ + '10020_F_Circular unit reference between $1 and $2'#000+ '10021_F_Can'#039't compile unit $1, no sources available'#000+ '10022_F_Can'#039't find unit $1 used by $2'#000+ - '10023_W_Unit $1 was not found but $2 exists'#000+ + '10023_W_Unit $1 was not found but $','2 exists'#000+ '10024_F_Unit $1 searched but $2 found'#000+ - '10025_W_Compiling the system unit requires the ','-Us switch'#000+ + '10025_W_Compiling the system unit requires the -Us switch'#000+ '10026_F_There were $1 errors compiling module, stopping'#000+ '10027_U_Load from $1 ($2) unit $3'#000+ - '10028_U_Recompiling $1, checksum changed for $2'#000+ + '10028_U_Recompiling $1, checksum changed for ','$2'#000+ '10029_U_Recompiling $1, source found only'#000+ - '10030_U_Recompiling unit, static lib is older tha','n ppufile'#000+ + '10030_U_Recompiling unit, static lib is older than ppufile'#000+ '10031_U_Recompiling unit, shared lib is older than ppufile'#000+ '10032_U_Recompiling unit, obj and asm are older than ppufile'#000+ - '10033_U_Recompiling unit, obj is older than asm'#000+ + '10033_U_Recompil','ing unit, obj is older than asm'#000+ '10034_U_Parsing interface of $1'#000+ - '10035_U_Parsing implementation',' of $1'#000+ + '10035_U_Parsing implementation of $1'#000+ '10036_U_Second load for unit $1'#000+ '10037_U_PPU Check file $1 time $2'#000+ '10040_W_Can'#039't recompile unit $1, but found modifed include files'#000+ - '10041_U_File $1 is newer than the one used for creating PPU file $2'#000+ - '10042_U_Trying to use a unit which',' was compiled with a different FPU'+ - ' mode'#000+ + '10041_U_','File $1 is newer than the one used for creating PPU file $2'#000+ + '10042_U_Trying to use a unit which was compiled with a different FPU m'+ + 'ode'#000+ '10043_U_Loading interface units from $1'#000+ '10044_U_Loading implementation units from $1'#000+ - '10045_U_Interface CRC changed for unit $1'#000+ + '10045_U_Interface CRC',' changed for unit $1'#000+ '10046_U_Implementation CRC changed for unit $1'#000+ - '10047_U_Finished compiling',' unit $1'#000+ + '10047_U_Finished compiling unit $1'#000+ '10048_U_Adding dependency: $1 depends on $2'#000+ '10049_U_No reload, is caller: $1'#000+ '10050_U_No reload, already in second compile: $1'#000+ - '10051_U_Flag for reload: $1'#000+ + '10051_U_Fla','g for reload: $1'#000+ '10052_U_Forced reloading'#000+ '10053_U_Previous state of $1: $2'#000+ - '10054_U_Already com','piling $1, setting second compile'#000+ + '10054_U_Already compiling $1, setting second compile'#000+ '10055_U_Loading unit $1'#000+ '10056_U_Finished loading unit $1'#000+ '10057_U_Registering new unit $1'#000+ - '10058_U_Re-resolving unit $1'#000+ + '10058_U_Re-resolving un','it $1'#000+ '10059_U_Skipping re-resolving unit $1, still loading used units'#000+ - '10060_U_Unloading resour','ce unit $1 (not needed)'#000+ + '10060_U_Unloading resource unit $1 (not needed)'#000+ '10061_E_Unit $1 was compiled using a different whole program optimizat'+ - 'ion feedback input ($2, $3); recompile it without wpo or use the same '+ - 'wpo feedback input file for this compilation invocation'#000+ - '10062_U_Indirect int','erface (objects/classes) CRC changed for unit $1'+ - #000+ + 'ion feedback input ($2, $3); recompile it without wp','o or use the sam'+ + 'e wpo feedback input file for this compilation invocation'#000+ + '10062_U_Indirect interface (objects/classes) CRC changed for unit $1'#000+ '11000_O_$1 [options] <inputfile> [options]'#000+ - '11001_W_Only one source file supported, changing source file to compil'+ - 'e from "$1" into "$2"'#000+ + '11001_W_Only one source file supported, changing sourc','e file to comp'+ + 'ile from "$1" into "$2"'#000+ '11002_W_DEF file can be created only for OS/2'#000+ - '11003_E_ne','sted response files are not supported'#000+ + '11003_E_nested response files are not supported'#000+ '11004_F_No source file name in command line'#000+ '11005_N_No option inside $1 config file'#000+ - '11006_E_Illegal parameter: $1'#000+ + '11006_E_Illegal paramete','r: $1'#000+ '11007_H_-? writes help pages'#000+ '11008_F_Too many config files nested'#000+ - '11009_F_Unable to open',' file $1'#000+ + '11009_F_Unable to open file $1'#000+ '11010_D_Reading further options from $1'#000+ '11011_W_Target is already set to: $1'#000+ - '11012_W_Shared libs not supported on DOS platform, reverting to static'+ - #000+ + '11012_W_Shared libs not supported on DOS platform, reverting',' to stat'+ + 'ic'#000+ '11013_F_In options file $1 at line $2 too many \var{\#IF(N)DEFs} encou'+ 'ntered'#000+ - '11014_','F_In options file $1 at line $2 unexpected \var{\#ENDIFs} enco'+ - 'untered'#000+ + '11014_F_In options file $1 at line $2 unexpected \var{\#ENDIFs} encoun'+ + 'tered'#000+ '11015_F_Open conditional at the end of the options file'#000+ - '11016_W_Debug information generation is not supported by this executab'+ - 'le'#000+ + '11016_W_Debug inform','ation generation is not supported by this execut'+ + 'able'#000+ '11017_H_Try recompiling with -dGDB'#000+ - '11018_','W_You are using the obsolete switch $1'#000+ + '11018_W_You are using the obsolete switch $1'#000+ '11019_W_You are using the obsolete switch $1, please use $2'#000+ - '11020_N_Switching assembler to default source writing assembler'#000+ + '11020_N_Switching assembler to default source w','riting assembler'#000+ '11021_W_Assembler output selected "$1" is not compatible with "$2"'#000+ - '11022_W_"$','1" assembler use forced'#000+ + '11022_W_"$1" assembler use forced'#000+ '11026_T_Reading options from file $1'#000+ '11027_T_Reading options from environment $1'#000+ '11028_D_Handling option "$1"'#000+ - '11029_O_*** press enter ***'#000+ + '11029_O_*** ','press enter ***'#000+ '11030_H_Start of reading config file $1'#000+ - '11031_H_End of reading config file $1'#000, + '11031_H_End of reading config file $1'#000+ '11032_D_interpreting option "$1"'#000+ '11036_D_interpreting firstpass option "$1"'#000+ '11033_D_interpreting file option "$1"'#000+ - '11034_D_Reading config file "$1"'#000+ + '11034_D_Reading config file "$1"',#000+ '11035_D_found source file name "$1"'#000+ '11039_E_Unknown codepage "$1"'#000+ - '11040_F_Config file $1 is a',' directory'#000+ + '11040_F_Config file $1 is a directory'#000+ '11041_W_Assembler output selected "$1" cannot generate debug info, deb'+ 'ugging disabled'#000+ - '11042_W_Use of ppc386.cfg is deprecated, please use fpc.cfg instead'#000+ + '11042_W_Use of ppc386.cfg is deprecated, please u','se fpc.cfg instead'#000+ '11043_F_In options file $1 at line $2 \var{\#ELSE} directive without \'+ - 'var{\','#IF(N)DEF} found'#000+ + 'var{\#IF(N)DEF} found'#000+ '11044_F_Option "$1" is not, or not yet, supported on the current targe'+ 't platform'#000+ - '11045_F_The feature "$1" is not, or not yet, supported on the selected'+ - ' target platform'#000+ - '11046_N_DWARF debug information cannot be used with sma','rt linking on'+ - ' this target, switching to static linking'#000+ + '11045_F_The feature "$1" is not, or not yet, sup','ported on the select'+ + 'ed target platform'#000+ + '11046_N_DWARF debug information cannot be used with smart linking on t'+ + 'his target, switching to static linking'#000+ '11047_W_Option "$1" is ignored for the current target platform.'#000+ - '11048_W_Disabling external debug information because it is unsupported'+ - ' for the selected target/debug format combination.'#000, + '11048_W_Disabling external ','debug information because it is unsupport'+ + 'ed for the selected target/debug format combination.'#000+ '11049_N_DWARF debug information cannot be used with smart linking with'+ ' external assembler, disabling static library creation.'#000+ - '11050_E_Invalid value for MACOSX_DEPLOYMENT_TARGET environment variabl'+ - 'e: $1'#000+ - '11051_E_Invalid value for IPHONEOS_DEP','LOYMENT_TARGET environment var'+ - 'iable: $1'#000+ + '11050_E_Invalid valu','e for MACOSX_DEPLOYMENT_TARGET environment varia'+ + 'ble: $1'#000+ + '11051_E_Invalid value for IPHONEOS_DEPLOYMENT_TARGET environment varia'+ + 'ble: $1'#000+ '11052_E_You must use a FPU type of VFPV2, VFPV3 or VFPV3_D16 when usin'+ 'g the EABIHF ABI target'#000+ - '12000_F_Cannot open whole program optimization feedback file "$1"'#000+ - '12001_D_Processing whole program optimiz','ation information in wpo fee'+ - 'dback file "$1"'#000+ + '12000_F_Cann','ot open whole program optimization feedback file "$1"'#000+ + '12001_D_Processing whole program optimization information in wpo feedb'+ + 'ack file "$1"'#000+ '12002_D_Finished processing the whole program optimization information'+ ' in wpo feedback file "$1"'#000+ - '12003_E_Expected section header, but got "$2" at line $1 of wpo feedba'+ - 'ck file'#000+ - '12004_W_No handler re','gistered for whole program optimization section'+ - ' "$2" at line $1 of wpo feedback file, ignoring'#000+ - '12005_D_Found whole program optimization section "$1" with information'+ - ' about "$2"'#000+ - '12006_F_The selected whole program optimizations require a prev','iousl'+ - 'y generated feedback file (use -Fw to specify)'#000+ + '12003','_E_Expected section header, but got "$2" at line $1 of wpo feed'+ + 'back file'#000+ + '12004_W_No handler registered for whole program optimization section "'+ + '$2" at line $1 of wpo feedback file, ignoring'#000+ + '12005_D_Found whole program optimization section "$','1" with informati'+ + 'on about "$2"'#000+ + '12006_F_The selected whole program optimizations require a previously '+ + 'generated feedback file (use -Fw to specify)'#000+ '12007_E_No collected information necessary to perform "$1" whole progr'+ 'am optimization found'#000+ - '12008_F_Specify a whole program optimization feedback file to store th'+ - 'e generated info in (using',' -FW)'#000+ + '12','008_F_Specify a whole program optimization feedback file to store '+ + 'the generated info in (using -FW)'#000+ '12009_E_Not generating any whole program optimization information, yet'+ ' a feedback file was specified (using -FW)'#000+ - '12010_E_Not performing any whole program optimizations, yet an input f'+ - 'eedback file was specified (using -Fw)'#000+ - '12011_D_Skip','ping whole program optimization section "$1", because no'+ - 't needed by the requested optimizations'#000+ - '12012_W_Overriding previously read information for "$1" from feedback '+ - 'input file using information in section "$2"'#000+ - '12013_E_Cannot extract symbol',' liveness information from program when'+ - ' stripping symbols, use -Xs-'#000+ + '12010_E_Not performing any ','whole program optimizations, yet an input'+ + ' feedback file was specified (using -Fw)'#000+ + '12011_D_Skipping whole program optimization section "$1", because not '+ + 'needed by the requested optimizations'#000+ + '12012_W_Overriding previously read information for',' "$1" from feedbac'+ + 'k input file using information in section "$2"'#000+ + '12013_E_Cannot extract symbol liveness information from program when s'+ + 'tripping symbols, use -Xs-'#000+ '12014_E_Cannot extract symbol liveness information from program when w'+ - 'hen not linking'#000+ + 'hen not ','linking'#000+ '12015_F_Cannot find "$1" or "$2" to extract symbol liveness informatio'+ - 'n from linked pr','ogram'#000+ + 'n from linked program'#000+ '12016_E_Error during reading symbol liveness information produced by "'+ '$1"'#000+ - '12017_F_Error executing "$1" (exitcode: $2) to extract symbol informat'+ - 'ion from linked program'#000+ - '12018_E_Collection of symbol liveness information can only help wh','en'+ - ' using smart linking, use -CX -XX'#000+ + '12017_F_Error executing "$1" (exitcode: $2) to extract symbol info','rm'+ + 'ation from linked program'#000+ + '12018_E_Collection of symbol liveness information can only help when u'+ + 'sing smart linking, use -CX -XX'#000+ '12019_E_Cannot create specified whole program optimisation feedback fi'+ 'le "$1"'#000+ - '11023_Free Pascal Compiler version $FPCFULLVERSION [$FPCDATE] for $FPC'+ - 'CPU'#010+ - 'Copyright (c) 1993-2012 by Florian Klaempfl and othe','rs'#000+ + '11023_Free Pascal Compiler versi','on $FPCFULLVERSION [$FPCDATE] for $F'+ + 'PCCPU'#010+ + 'Copyright (c) 1993-2012 by Florian Klaempfl and others'#000+ '11024_Free Pascal Compiler version $FPCVERSION'#010+ #010+ 'Compiler Date : $FPCDATE'#010+ @@ -1152,11 +1148,11 @@ const msgtxt : array[0..000274,1..240] of char=( 'Supported targets:'#010+ ' $OSTARGETS'#010+ #010+ - 'Supported CPU instruction sets:'#010+ + 'Su','pported CPU instruction sets:'#010+ ' $INSTRUCTIONSETS'#010+ #010+ 'Supported FPU instruction sets:'#010+ - ' $FPUINSTRU','CTIONSETS'#010+ + ' $FPUINSTRUCTIONSETS'#010+ #010+ 'Supported ABI targets:'#010+ ' $ABITARGETS'#010+ @@ -1166,228 +1162,228 @@ const msgtxt : array[0..000274,1..240] of char=( #010+ 'Supported Whole Program Optimizations:'#010+ ' All'#010+ - ' $WPOPTIMIZATIONS'#010+ + ' $WPOPTI','MIZATIONS'#010+ #010+ 'Supported Microcontroller types:'#010+ ' $CONTROLLERTYPES'#010+ #010+ - 'This program comes under the G','NU General Public Licence'#010+ + 'This program comes under the GNU General Public Licence'#010+ 'For more information read COPYING.v2'#010+ #010+ 'Please report bugs in our bug tracker on:'#010+ - ' http://bugs.freepascal.org'#010+ + ' http://bugs.freepascal.','org'#010+ #010+ 'More information may be found on our WWW pages (including directions'#010+ - 'for mailing lists us','eful for asking questions or discussing potentia'+ - 'l'#010+ + 'for mailing lists useful for asking questions or discussing potential'#010+ 'new features, etc.):'#010+ ' http://www.freepascal.org'#000+ - '11025_**0*_Put + after a boolean switch option to enable it, - to disa'+ - 'ble it'#010+ - '**1a_The compiler doesn'#039't delete the generated as','sembler file'#010+ + '11025_**0*_Put + after a boolean',' switch option to enable it, - to di'+ + 'sable it'#010+ + '**1a_The compiler doesn'#039't delete the generated assembler file'#010+ '**2al_List sourcecode lines in assembler file'#010+ '**2an_List node info in assembler file (-dEXTDEBUG compiler)'#010+ - '*L2ap_Use pipes instead of creating temporary assembler files'#010+ - '**2ar_List register allocation/release info in assembler f','ile'#010+ + '*L2ap_Use pipes instead of',' creating temporary assembler files'#010+ + '**2ar_List register allocation/release info in assembler file'#010+ '**2at_List temp allocation/release info in assembler file'#010+ '**1A<x>_Output format:'#010+ '**2Adefault_Use default assembler'#010+ - '3*2Aas_Assemble using GNU AS'#010+ + '3*2Aas_Assemble using GNU A','S'#010+ '3*2Amacho_Mach-O (Darwin, Intel 32 bit) using internal writer'#010+ - '3*2Anasmcoff_COFF (Go32v2) fil','e using Nasm'#010+ + '3*2Anasmcoff_COFF (Go32v2) file using Nasm'#010+ '3*2Anasmelf_ELF32 (Linux) file using Nasm'#010+ '3*2Anasmwin32_Win32 object file using Nasm'#010+ - '3*2Anasmwdosx_Win32/WDOSX object file using Nasm'#010+ + '3*2Anasmwdosx_Win32/WDOSX object file using Nasm',#010+ '3*2Awasm_Obj file using Wasm (Watcom)'#010+ '3*2Anasmobj_Obj file using Nasm'#010+ - '3*2Amasm_Obj file using',' Masm (Microsoft)'#010+ + '3*2Amasm_Obj file using Masm (Microsoft)'#010+ '3*2Atasm_Obj file using Tasm (Borland)'#010+ '3*2Aelf_ELF (Linux) using internal writer'#010+ '3*2Acoff_COFF (Go32v2) using internal writer'#010+ - '3*2Apecoff_PE-COFF (Win32) using internal writer'#010+ + '3*','2Apecoff_PE-COFF (Win32) using internal writer'#010+ '4*2Aas_Assemble using GNU AS'#010+ - '4*2Agas_Assemble u','sing GNU GAS'#010+ + '4*2Agas_Assemble using GNU GAS'#010+ '4*2Agas-darwin_Assemble darwin Mach-O64 using GNU GAS'#010+ '4*2Amasm_Win64 object file using ml64 (Microsoft)'#010+ - '4*2Apecoff_PE-COFF (Win64) using internal writer'#010+ + '4*2Apecoff_PE-COFF (Win64) us','ing internal writer'#010+ '4*2Aelf_ELF (Linux-64bit) using internal writer'#010+ - '6*2Aas_Unix o-file using G','NU AS'#010+ + '6*2Aas_Unix o-file using GNU AS'#010+ '6*2Agas_GNU Motorola assembler'#010+ '6*2Amit_MIT Syntax (old GAS)'#010+ '6*2Amot_Standard Motorola assembler'#010+ 'A*2Aas_Assemble using GNU AS'#010+ - 'P*2Aas_Assemble using GNU AS'#010+ + 'P*2Aas_Assemble',' using GNU AS'#010+ 'S*2Aas_Assemble using GNU AS'#010+ '**1b_Generate browser info'#010+ - '**2bl_Generate local sym','bol info'#010+ + '**2bl_Generate local symbol info'#010+ '**1B_Build all modules'#010+ '**1C<x>_Code generation options:'#010+ '**2C3<x>_Turn on ieee error checking for constants'#010+ - '**2Ca<x>_Select ABI, see fpc -i for possible values'#010+ + '**2Ca<x>_Select ABI, see fpc -','i for possible values'#010+ '**2Cb_Generate big-endian code'#010+ - '**2Cc<x>_Set default calling convention t','o <x>'#010+ + '**2Cc<x>_Set default calling convention to <x>'#010+ '**2CD_Create also dynamic library (not supported)'#010+ '**2Ce_Compilation with emulated floating point opcodes'#010+ - '**2Cf<x>_Select fpu instruction set to use, see fpc -i for possible va'+ - 'lues'#010+ - '**2CF<x>_Minimal floating point constant precision (de','fault, 32, 64)'+ - #010+ + '**2Cf<x>_Select fpu instruction set',' to use, see fpc -i for possible '+ + 'values'#010+ + '**2CF<x>_Minimal floating point constant precision (default, 32, 64)'#010+ '**2Cg_Generate PIC code'#010+ '**2Ch<n>_<n> bytes heap (between 1023 and 67107840)'#010+ '**2Ci_IO-checking'#010+ '**2Cn_Omit linking stage'#010+ - 'P*2CN_Generate nil-pointer checks (AIX-only)'#010+ + 'P*2CN_Genera','te nil-pointer checks (AIX-only)'#010+ '**2Co_Check overflow of integer operations'#010+ - '**2CO_Check for po','ssible overflow of integer operations'#010+ + '**2CO_Check for possible overflow of integer operations'#010+ '**2Cp<x>_Select instruction set, see fpc -i for possible values'#010+ '**2CP<x>=<y>_ packing settings'#010+ - '**3CPPACKSET=<y>_ <y> set allocation: 0, 1 or DEFAULT or NORMAL, 2, 4 '+ - 'and 8'#010+ + '**3CPPACKSET=','<y>_ <y> set allocation: 0, 1 or DEFAULT or NORMAL, 2, '+ + '4 and 8'#010+ '**2Cr_Range checking'#010+ - '**2CR_Veri','fy object method call validity'#010+ + '**2CR_Verify object method call validity'#010+ '**2Cs<n>_Set stack checking size to <n>'#010+ '**2Ct_Stack checking (for testing only, see manual)'#010+ - 'p*2CT<x>_Target-specific code generation options'#010+ + 'p*2CT<x>_Target-specifi','c code generation options'#010+ 'P*2CT<x>_Target-specific code generation options'#010+ - 'J*2CT<x>_Target-spe','cific code generation options'#010+ + 'J*2CT<x>_Target-specific code generation options'#010+ 'p*3CTsmalltoc_ Generate smaller TOCs at the expense of execution speed'+ ' (AIX)'#010+ - 'P*3CTsmalltoc_ Generate smaller TOCs at the expense of execution speed'+ - ' (AIX)'#010+ - 'J*3CTcompactintarrayinit_ Generate smaller (but potentia','lly slower) '+ - 'code for initializing integer array constants'#010+ + 'P*3CTsmalltoc_ Generate smaller TOCs at',' the expense of execution spe'+ + 'ed (AIX)'#010+ + 'J*3CTcompactintarrayinit_ Generate smaller (but potentially slower) co'+ + 'de for initializing integer array constants'#010+ + 'K*3CTenumfieldinit_ Initialize enumeration fields in constructors to e'+ + 'numtype(0), after ','calling inherited constructors'#010+ 'J*2Cv_Var/out parameter copy-out checking'#010+ '**2CX_Create also smartlinked library'#010+ '**1d<x>_Defines the symbol <x>'#010+ '**1D_Generate a DEF file'#010+ '**2Dd<x>_Set description to <x>'#010+ - '**2Dv<x>_Set D','LL version to <x>'#010+ - '*O2Dw_PM application'#010+ + '**2Dv<x>_Set DLL version to <x>'#010+ + '*O2Dw_PM ','application'#010+ '**1e<x>_Set path to executable'#010+ '**1E_Same as -Cn'#010+ '**1fPIC_Same as -Cg'#010+ '**1F<x>_Set file names and paths:'#010+ '**2Fa<x>[,y]_(for a program) load units <x> and [y] before uses is par'+ 'sed'#010+ - '**2Fc<x>_Set input codepa','ge to <x>'#010+ - '**2FC<x>_Set RC compiler binary name to <x>'#010+ + '**2Fc<x>_Set input codepage to <x>'#010+ + '**2FC<x>_Set RC c','ompiler binary name to <x>'#010+ '**2Fd_Disable the compiler'#039's internal directory cache'#010+ '**2FD<x>_Set the directory where to search for compiler utilities'#010+ '**2Fe<x>_Redirect error output to <x>'#010+ - '**2Ff<x>_Add <x> to framewor','k path (Darwin only)'#010+ - '**2FE<x>_Set exe/unit output path to <x>'#010+ + '**2Ff<x>_Add <x> to framework path (Darwin only)'#010+ + '**2FE<','x>_Set exe/unit output path to <x>'#010+ '**2Fi<x>_Add <x> to include path'#010+ '**2Fl<x>_Add <x> to library path'#010+ '**2FL<x>_Use <x> as dynamic linker'#010+ '**2Fm<x>_Load unicode conversion table from <x>.txt in the compiler di'+ 'r'#010+ - '**2Fo','<x>_Add <x> to object path'#010+ + '**2Fo<x>_Add <x> to object path'#010, '**2Fr<x>_Load error message file <x>'#010+ '**2FR<x>_Set resource (.res) linker to <x>'#010+ '**2Fu<x>_Add <x> to unit path'#010+ '**2FU<x>_Set unit output path to <x>, overrides -FE'#010+ - '**2FW<x>_Store generated whole-program optimization',' feedback in <x>'#010+ - '**2Fw<x>_Load previously stored whole-program optimization feedback fr'+ - 'om <x>'#010+ + '**2FW<x>_Store generated whole-program optimization feedback in <x>'#010+ + '**2Fw<x>_L','oad previously stored whole-program optimization feedback '+ + 'from <x>'#010+ '*g1g_Generate debug information (default format for target)'#010+ '*g2gc_Generate checks for pointers'#010+ - '*g2gh_Use heaptrace unit (for memory leak/corruptio','n debugging)'#010+ - '*g2gl_Use line info unit (show more info with backtraces)'#010+ + '*g2gh_Use heaptrace unit (for memory leak/corruption debugging)'#010+ + '*g2gl_Use line',' info unit (show more info with backtraces)'#010+ '*g2go<x>_Set debug information options'#010+ '*g3godwarfsets_ Enable DWARF '#039'set'#039' type debug information (bre'+ 'aks gdb < 6.5)'#010+ - '*g3gostabsabsincludes_ Store absolute/full include fi','le paths in Sta'+ - 'bs'#010+ - '*g3godwarfmethodclassprefix_ Prefix method names in DWARF with class n'+ - 'ame'#010+ + '*g3gostabsabsincludes_ Store absolute/full include file paths in Stabs'+ + #010+ + '*g3godwar','fmethodclassprefix_ Prefix method names in DWARF with class'+ + ' name'#010+ '*g2gp_Preserve case in stabs symbol names'#010+ '*g2gs_Generate Stabs debug information'#010+ '*g2gt_Trash local variables (to detect uninitialized uses)'#010+ - '*g2gv_Ge','nerates programs traceable with Valgrind'#010+ + '*g2gv_Generates programs traceable ','with Valgrind'#010+ '*g2gw_Generate DWARFv2 debug information (same as -gw2)'#010+ '*g2gw2_Generate DWARFv2 debug information'#010+ '*g2gw3_Generate DWARFv3 debug information'#010+ '*g2gw4_Generate DWARFv4 debug information (experimental)'#010+ - '**','1i_Information'#010+ - '**2iD_Return compiler date'#010+ + '**1i_Information'#010+ + '**2iD_Return',' compiler date'#010+ '**2iV_Return short compiler version'#010+ '**2iW_Return full compiler version'#010+ '**2iSO_Return compiler OS'#010+ '**2iSP_Return compiler host processor'#010+ '**2iTO_Return target OS'#010+ '**2iTP_Return target processor'#010+ - '**1I<x>_','Add <x> to include path'#010+ - '**1k<x>_Pass <x> to the linker'#010+ + '**1I<x>_Add <x> to include path'#010+ + '**1','k<x>_Pass <x> to the linker'#010+ '**1l_Write logo'#010+ '**1M<x>_Set language mode to <x>'#010+ '**2Mfpc_Free Pascal dialect (default)'#010+ '**2Mobjfpc_FPC mode with Object Pascal support'#010+ '**2Mdelphi_Delphi 7 compatibility mode'#010+ - '**2Mtp_TP/BP',' 7.0 compatibility mode'#010+ - '**2Mmacpas_Macintosh Pascal dialects compatibility mode'#010+ + '**2Mtp_TP/BP 7.0 compatibility mode'#010+ + '**2','Mmacpas_Macintosh Pascal dialects compatibility mode'#010+ '**1n_Do not read the default config files'#010+ '**1N<x>_Node tree optimizations'#010+ '**2Nu_Unroll loops'#010+ '**1o<x>_Change the name of the executable produced to <x>'#010+ - '**1O<x>_O','ptimizations:'#010+ - '**2O-_Disable optimizations'#010+ + '**1O<x>_Optimizations:'#010+ + '**2O-_Disable',' optimizations'#010+ '**2O1_Level 1 optimizations (quick and debugger friendly)'#010+ '**2O2_Level 2 optimizations (-O1 + quick optimizations)'#010+ '**2O3_Level 3 optimizations (-O2 + slow optimizations)'#010+ '**2Oa<x>=<y>_Set alignment'#010+ - '**','2Oo[NO]<x>_Enable or disable optimizations, see fpc -i for possibl'+ + '**2Oo[NO]<x>_Enable or disabl','e optimizations, see fpc -i for possibl'+ 'e values'#010+ '**2Op<x>_Set target cpu for optimizing, see fpc -i for possible values'+ #010+ '**2OW<x>_Generate whole-program optimization feedback for optimization'+ - ' <x>, see fpc -i for pos','sible values'#010+ - '**2Ow<x>_Perform whole-program optimization <x>, see fpc -i for possib'+ - 'le values'#010+ + ' <x>, see fpc -i for possible values'#010+ + '**2Ow<x>_Perfo','rm whole-program optimization <x>, see fpc -i for poss'+ + 'ible values'#010+ '**2Os_Optimize for size rather than speed'#010+ '**1pg_Generate profile code for gprof (defines FPC_PROFILE)'#010+ - 'F*1P<x>_Target CPU / compiler related options',':'#010+ - 'F*2PB_Show default compiler binary'#010+ + 'F*1P<x>_Target CPU / compiler related options:'#010+ + 'F*2PB_Show default compil','er binary'#010+ 'F*2PP_Show default target cpu'#010+ 'F*2P<x>_Set target CPU (arm,i386,m68k,mips,mipsel,powerpc,powerpc64,sp'+ 'arc,x86_64'#010+ '**1R<x>_Assembler reading style:'#010+ '**2Rdefault_Use default assembler for target'#010+ - '3*2Ratt_Read A','T&T style assembler'#010+ - '3*2Rintel_Read Intel style assembler'#010+ + '3*2Ratt_Read AT&T style assembler'#010+ + '3*2Rint','el_Read Intel style assembler'#010+ '6*2RMOT_Read motorola style assembler'#010+ '**1S<x>_Syntax options:'#010+ '**2S2_Same as -Mobjfpc'#010+ '**2Sc_Support operators like C (*=,+=,/= and -=)'#010+ '**2Sa_Turn on assertions'#010+ '**2Sd_Same as -Mdelphi'#010+ - '*','*2Se<x>_Error options. <x> is a combination of the following:'#010+ + '**2Se<x>_Error options. <x> ','is a combination of the following:'#010+ '**3*_<n> : Compiler halts after the <n> errors (default is 1)'#010+ '**3*_w : Compiler also halts after warnings'#010+ '**3*_n : Compiler also halts after notes'#010+ - '**3*_h : Compiler also halts af','ter hints'#010+ - '**2Sg_Enable LABEL and GOTO (default in -Mtp and -Mdelphi)'#010+ + '**3*_h : Compiler also halts after hints'#010+ + '**2Sg_Enable LABE','L and GOTO (default in -Mtp and -Mdelphi)'#010+ '**2Sh_Use reference counted strings (ansistring by default) instead of'+ ' shortstrings'#010+ '**2Si_Turn on inlining of procedures/functions declared as "inline"'#010+ - '**2Sk_Load fpcylix ','unit'#010+ - '**2SI<x>_Set interface style to <x>'#010+ + '**2Sk_Load fpcylix unit'#010+ + '**2SI<x>_Set interface',' style to <x>'#010+ '**3SIcom_COM compatible interface (default)'#010+ '**3SIcorba_CORBA compatible interface'#010+ '**2Sm_Support macros like C (global)'#010+ '**2So_Same as -Mtp'#010+ - '**2Ss_Constructor name must be init (destructor must be done)',#010+ - '**2Sx_Enable exception keywords (default in Delphi/ObjFPC modes)'#010+ + '**2Ss_Constructor name must be init (destructor must be done)'#010+ + '**2Sx_Enable exception key','words (default in Delphi/ObjFPC modes)'#010+ '**2Sy_@<pointer> returns a typed pointer, same as $T+'#010+ '**1s_Do not call assembler and linker'#010+ '**2sh_Generate script to link on host'#010+ '**2st_Generate script to link on target'#010+ - '**2s','r_Skip register allocation phase (use with -alr)'#010+ + '**2sr_Skip register allocation ','phase (use with -alr)'#010+ '**1T<x>_Target operating system:'#010+ '3*2Tdarwin_Darwin/Mac OS X'#010+ '3*2Temx_OS/2 via EMX (including EMX/RSX extender)'#010+ '3*2Tfreebsd_FreeBSD'#010+ '3*2Tgo32v2_Version 2 of DJ Delorie DOS extender'#010+ - '3*2Tiphonesim','_ iPhoneSimulator from iOS SDK 3.2+ (older versions: -T'+ + '3*2Tiphonesim_ iPhoneSimulator from iOS ','SDK 3.2+ (older versions: -T'+ 'darwin)'#010+ '3*2Tlinux_Linux'#010+ '3*2Tnetbsd_NetBSD'#010+ @@ -1395,8 +1391,8 @@ const msgtxt : array[0..000274,1..240] of char=( '3*2Tnetwlibc_Novell Netware Module (libc)'#010+ '3*2Topenbsd_OpenBSD'#010+ '3*2Tos2_OS/2 / eComStation'#010+ - '3*2Tsunos_Sun','OS/Solaris'#010+ - '3*2Tsymbian_Symbian OS'#010+ + '3*2Tsunos_SunOS/Solaris'#010+ + '3*2Tsymbian_Symb','ian OS'#010+ '3*2Tsolaris_Solaris'#010+ '3*2Twatcom_Watcom compatible DOS extender'#010+ '3*2Twdosx_WDOSX DOS extender'#010+ @@ -1404,8 +1400,8 @@ const msgtxt : array[0..000274,1..240] of char=( '3*2Twince_Windows CE'#010+ '4*2Tdarwin_Darwin/Mac OS X'#010+ '4*2Tlinux_Linux'#010+ - '4*2Twin64_Win64 (64 bit Wi','ndows systems)'#010+ - '6*2Tamiga_Commodore Amiga'#010+ + '4*2Twin64_Win64 (64 bit Windows systems)'#010+ + '6*2Tamiga_Co','mmodore Amiga'#010+ '6*2Tatari_Atari ST/STe/TT'#010+ '6*2Tlinux_Linux'#010+ '6*2Tpalmos_PalmOS'#010+ @@ -1415,118 +1411,118 @@ const msgtxt : array[0..000274,1..240] of char=( 'P*2Tamiga_AmigaOS'#010+ 'P*2Tdarwin_Darwin/Mac OS X'#010+ 'P*2Tlinux_Linux'#010+ - 'P*2Tmacos_','Mac OS (classic)'#010+ - 'P*2Tmorphos_MorphOS'#010+ + 'P*2Tmacos_Mac OS (classic)'#010+ + 'P*2Tmorpho','s_MorphOS'#010+ 'S*2Tsolaris_Solaris'#010+ 'S*2Tlinux_Linux'#010+ '**1u<x>_Undefines the symbol <x>'#010+ '**1U_Unit options:'#010+ '**2Un_Do not check where the unit name matches the file name'#010+ - '**2Ur_Generate release unit files (never automatically',' recompiled)'#010+ - '**2Us_Compile a system unit'#010+ + '**2Ur_Generate release unit files (never automatically recompiled)'#010+ + '**2Us_Compile ','a system unit'#010+ '**1v<x>_Be verbose. <x> is a combination of the following letters:'#010+ '**2*_e : Show errors (default) 0 : Show nothing (except errors)'#010+ '**2*_w : Show warnings u : Show unit info'#010+ - '**2*_n',' : Show notes t : Show tried/used files'#010+ + '**2*_n : Show notes ',' t : Show tried/used files'#010+ '**2*_h : Show hints c : Show conditionals'#010+ '**2*_i : Show general info d : Show debug info'#010+ - '**2*_l : Show linenumbers r : Rhide/GCC compatibility mo','d'+ - 'e'#010+ - '**2*_s : Show time stamps q : Show message numbers'#010+ + '**2*_l : Show linenumbers r : Rhide/GCC compatibility mode'#010+ + '**2*_s : Show time stamp','s q : Show message numbers'#010+ '**2*_a : Show everything x : Executable info (Win32 only)'#010+ '**2*_b : Write file names messages p : Write tree.log with parse tre'+ 'e'#010+ - '**2*_ with full path ',' v : Write fpcdebug.txt with'#010+ + '**2*_ with full path v : Write fpcdebug.txt ','with'#010+ '**2*_ lots of debugging info'#010+ '**2*_m<x>,<y> : Don'#039't show messages numbered <x> and <y>'#010+ 'F*1V<x>_Append '#039'-<x>'#039' to the used compiler binary name (e.g. f'+ 'or version)'#010+ - '**1W<x>_Targe','t-specific options (targets)'#010+ + '**1W<x>_Target-specific options (targets',')'#010+ '3*2WA_Specify native type application (Windows)'#010+ '4*2WA_Specify native type application (Windows)'#010+ 'A*2WA_Specify native type application (Windows)'#010+ '3*2Wb_Create a bundle instead of a library (Darwin)'#010+ - 'P*2Wb_Create a ','bundle instead of a library (Darwin)'#010+ + 'P*2Wb_Create a bundle instead of a library',' (Darwin)'#010+ 'p*2Wb_Create a bundle instead of a library (Darwin)'#010+ 'A*2Wb_Create a bundle instead of a library (Darwin)'#010+ '4*2Wb_Create a bundle instead of a library (Darwin)'#010+ - '3*2WB_Create a relocatable image (Windows, Symb','ian)'#010+ - '3*2WBxxxx_Set image base to xxxx (Windows, Symbian)'#010+ + '3*2WB_Create a relocatable image (Windows, Symbian)'#010+ + '3*2WBxxxx_Set image ba','se to xxxx (Windows, Symbian)'#010+ '4*2WB_Create a relocatable image (Windows)'#010+ '4*2WBxxxx_Set image base to xxxx (Windows)'#010+ 'A*2WB_Create a relocatable image (Windows, Symbian)'#010+ - 'A*2WBxxxx_Set image base to xxxx (Windows, Sy','mbian)'#010+ - '3*2WC_Specify console type application (EMX, OS/2, Windows)'#010+ + 'A*2WBxxxx_Set image base to xxxx (Windows, Symbian)'#010+ + '3*2WC_Specify consol','e type application (EMX, OS/2, Windows)'#010+ '4*2WC_Specify console type application (EMX, OS/2, Windows)'#010+ 'A*2WC_Specify console type application (Windows)'#010+ 'P*2WC_Specify console type application (Classic Mac OS)'#010+ - '3*2WD_Us','e DEFFILE to export functions of DLL or EXE (Windows)'#010+ + '3*2WD_Use DEFFILE to export functio','ns of DLL or EXE (Windows)'#010+ '4*2WD_Use DEFFILE to export functions of DLL or EXE (Windows)'#010+ 'A*2WD_Use DEFFILE to export functions of DLL or EXE (Windows)'#010+ '3*2We_Use external resources (Darwin)'#010+ - '4*2We_Use external resou','rces (Darwin)'#010+ - 'A*2We_Use external resources (Darwin)'#010+ + '4*2We_Use external resources (Darwin)'#010+ + 'A*2We_Use ext','ernal resources (Darwin)'#010+ 'P*2We_Use external resources (Darwin)'#010+ 'p*2We_Use external resources (Darwin)'#010+ '3*2WF_Specify full-screen type application (EMX, OS/2)'#010+ - '3*2WG_Specify graphic type application (EMX, OS/2, Window','s)'#010+ - '4*2WG_Specify graphic type application (EMX, OS/2, Windows)'#010+ + '3*2WG_Specify graphic type application (EMX, OS/2, Windows)'#010+ + '4*2WG_Specify graphic ty','pe application (EMX, OS/2, Windows)'#010+ 'A*2WG_Specify graphic type application (Windows)'#010+ 'P*2WG_Specify graphic type application (Classic Mac OS)'#010+ '3*2Wi_Use internal resources (Darwin)'#010+ - '4*2Wi_Use internal resources (Darw','in)'#010+ - 'A*2Wi_Use internal resources (Darwin)'#010+ + '4*2Wi_Use internal resources (Darwin)'#010+ + 'A*2Wi_Use internal reso','urces (Darwin)'#010+ 'P*2Wi_Use internal resources (Darwin)'#010+ 'p*2Wi_Use internal resources (Darwin)'#010+ '3*2WI_Turn on/off the usage of import sections (Windows)'#010+ '4*2WI_Turn on/off the usage of import sections (Windows)'#010+ - 'A*2WI_Tu','rn on/off the usage of import sections (Windows)'#010+ + 'A*2WI_Turn on/off the usage of impo','rt sections (Windows)'#010+ '3*2WM<x>_Minimum Mac OS X deployment version: 10.4, 10.5.1, ... (Darwi'+ 'n)'#010+ '4*2WM<x>_Minimum Mac OS X deployment version: 10.4, 10.5.1, ... (Darwi'+ 'n)'#010+ - 'p*2WM<x>_Minimum Mac OS X deployment version:',' 10.4, 10.5.1, ... (Dar'+ - 'win)'#010+ + 'p*2WM<x>_Minimum Mac OS X deployment version: 10.4, 10.5.1, ... (Darwi'+ + 'n)',#010+ 'P*2WM<x>_Minimum Mac OS X deployment version: 10.4, 10.5.1, ... (Darwi'+ 'n)'#010+ '3*2WN_Do not generate relocation code, needed for debugging (Windows)'#010+ - '4*2WN_Do not generate relocation code, needed for debugging (Windows)', - #010+ - 'A*2WN_Do not generate relocation code, needed for debugging (Windows)'#010+ + '4*2WN_Do not generate relocation code, needed for debugging (Windows)'#010+ + 'A*2WN_Do not generate relo','cation code, needed for debugging (Windows'+ + ')'#010+ 'A*2Wpxxxx_Specify the controller type, see fpc -i for possible values'#010+ 'V*2Wpxxxx_Specify the controller type, see fpc -i for possible values'#010+ - '3*2WP<x>_Minimum iOS deployme','nt version: 3.0, 5.0.1, ... (iphonesim)'+ + '3*2WP<x>_Minimum iOS deployment version: 3.0, 5.0.1, ...',' (iphonesim)'+ #010+ 'A*2WP<x>_Minimum iOS deployment version: 3.0, 5.0.1, ... (Darwin)'#010+ '3*2WR_Generate relocation code (Windows)'#010+ '4*2WR_Generate relocation code (Windows)'#010+ 'A*2WR_Generate relocation code (Windows)'#010+ - 'P*2WT_Speci','fy MPW tool type application (Classic Mac OS)'#010+ + 'P*2WT_Specify MPW tool type applicatio','n (Classic Mac OS)'#010+ '**2WX_Enable executable stack (Linux)'#010+ '**1X_Executable options:'#010+ '**2Xc_Pass --shared/-dynamic to the linker (BeOS, Darwin, FreeBSD, Lin'+ 'ux)'#010+ - '**2Xd_Do not search default library path (sometimes requi','red for cro'+ - 'ss-compiling when not using -XR)'#010+ + '**2Xd_Do not search default library path (sometimes required for cross'+ + '-compiling whe','n not using -XR)'#010+ '**2Xe_Use external linker'#010+ '**2Xg_Create debuginfo in a separate file and add a debuglink section '+ 'to executable'#010+ '**2XD_Try to link units dynamically (defines FPC_LINK_DYNAMIC)'#010+ - '**2Xi_Use internal',' linker'#010+ - '**2Xm_Generate link map'#010+ + '**2Xi_Use internal linker'#010+ + '**2Xm_Generate link',' map'#010+ '**2XM<x>_Set the name of the '#039'main'#039' program routine (default i'+ 's '#039'main'#039')'#010+ 'F*2Xp<x>_First search for the compiler binary in the directory <x>'#010+ '**2XP<x>_Prepend the binutils names with the prefix <x>'#010+ - '**2Xr<x>_Set ','the linker'#039's rlink-path to <x> (needed for cross co'+ + '**2Xr<x>_Set the linker'#039's rlink-path to ','<x> (needed for cross co'+ 'mpile, see the ld manual for more information) (BeOS, Linux)'#010+ '**2XR<x>_Prepend <x> to all linker search paths (BeOS, Darwin, FreeBSD'+ ', Linux, Mac OS, Solaris)'#010+ - '**2Xs_Strip all symbols from exe','cutable'#010+ - '**2XS_Try to link units statically (default, defines FPC_LINK_STATIC)'#010+ + '**2Xs_Strip all symbols from executable'#010+ + '**2XS_Try to link u','nits statically (default, defines FPC_LINK_STATIC'+ + ')'#010+ '**2Xt_Link with static libraries (-static is passed to linker)'#010+ '**2XX_Try to smartlink units (defines FPC_LINK_SMART)'#010+ '**1*_'#010+ '**1?_Show this help'#010+ - '**1h_Sh','ows this help without waiting' + '**1h_Shows this help without waiti','ng' ); diff --git a/mips/compiler/nbas.pas b/mips/compiler/nbas.pas index 2fe6b2db69..608b783862 100644 --- a/mips/compiler/nbas.pas +++ b/mips/compiler/nbas.pas @@ -1201,7 +1201,7 @@ implementation begin inherited printnodedata(t); writeln(t,printnodeindention,'release_to_normal: ',release_to_normal,', temptypedef = ',tempinfo^.typedef.typesymbolprettyname,' = "', - tempinfo^.typedef.GetTypeName,'", tempinfo = $',hexstr(ptrint(tempinfo),sizeof(ptrint)*2)); + tempinfo^.typedef.GetTypeName,'", temptype = ',tempinfo^.temptype,', tempinfo = $',hexstr(ptrint(tempinfo),sizeof(ptrint)*2)); end; end. diff --git a/mips/compiler/ncgcal.pas b/mips/compiler/ncgcal.pas index 7055b9d2b4..2bb4b6d15b 100644 --- a/mips/compiler/ncgcal.pas +++ b/mips/compiler/ncgcal.pas @@ -133,7 +133,7 @@ implementation begin if not(left.location.loc in [LOC_CREFERENCE,LOC_REFERENCE]) then internalerror(200304235); - hlcg.a_loadaddr_ref_cgpara(current_asmdata.CurrAsmList,left.resultdef,tempcgpara.def,left.location.reference,tempcgpara); + hlcg.a_loadaddr_ref_cgpara(current_asmdata.CurrAsmList,left.resultdef,left.location.reference,tempcgpara); end; @@ -203,8 +203,8 @@ implementation if third=nil then InternalError(201103063); secondpass(third); - cg.g_array_rtti_helper(current_asmdata.CurrAsmList,tarraydef(resultdef).elementdef, - href,third.location,'FPC_FINALIZE_ARRAY'); + hlcg.g_array_rtti_helper(current_asmdata.CurrAsmList,tarraydef(resultdef).elementdef, + href,third.location,'fpc_finalize_array'); end; end else @@ -529,7 +529,9 @@ implementation passing a shortstring } if (hp2.nodetype=typeconvn) and (tunarynode(hp2).left.nodetype=addrn) then - hp2:=tunarynode(tunarynode(hp2).left).left; + hp2:=tunarynode(tunarynode(hp2).left).left + else if tunarynode(hp2).nodetype=addrn then + hp2:=tunarynode(hp2).left; location_freetemp(current_asmdata.CurrAsmList,hp2.location); hp:=tarrayconstructornode(hp).right; end; @@ -833,9 +835,9 @@ implementation { call method } extra_call_code; {$ifdef x86} - cg.a_call_ref(current_asmdata.CurrAsmList,href); + hlcg.a_call_ref(current_asmdata.CurrAsmList,tabstractprocdef(procdefinition),href); {$else x86} - cg.a_call_reg(current_asmdata.CurrAsmList,pvreg); + hlcg.a_call_reg(current_asmdata.CurrAsmList,tabstractprocdef(procdefinition),pvreg); {$endif x86} extra_post_call_code; end @@ -911,7 +913,7 @@ implementation if (po_interrupt in procdefinition.procoptions) then extra_interrupt_code; extra_call_code; - cg.a_call_reg(current_asmdata.CurrAsmList,pvreg); + hlcg.a_call_reg(current_asmdata.CurrAsmList,tabstractprocdef(procdefinition),pvreg); extra_post_call_code; end; @@ -971,7 +973,7 @@ implementation (tf_safecall_exceptions in target_info.flags) then begin cgpara.init; - paramanager.getintparaloc(pocall_default,1,cgpara); + paramanager.getintparaloc(pocall_default,1,s32inttype,cgpara); cg.a_load_reg_cgpara(current_asmdata.CurrAsmList,OS_INT,NR_FUNCTION_RESULT_REG,cgpara); paramanager.freecgpara(current_asmdata.CurrAsmList,cgpara); cgpara.done; diff --git a/mips/compiler/ncgflw.pas b/mips/compiler/ncgflw.pas index bc01ed5c6d..10aa87c691 100644 --- a/mips/compiler/ncgflw.pas +++ b/mips/compiler/ncgflw.pas @@ -93,7 +93,7 @@ implementation uses verbose,globals,systems,globtype,constexp, - symconst,symdef,symsym,aasmtai,aasmdata,aasmcpu,defutil, + symconst,symdef,symsym,symtable,aasmtai,aasmdata,aasmcpu,defutil, procinfo,cgbase,pass_2,parabase, cpubase,cpuinfo, nld,ncon, @@ -962,16 +962,17 @@ implementation href2: treference; paraloc1,paraloc2,paraloc3 : tcgpara; begin - paraloc1.init; - paraloc2.init; - paraloc3.init; - paramanager.getintparaloc(pocall_default,1,paraloc1); - paramanager.getintparaloc(pocall_default,2,paraloc2); - paramanager.getintparaloc(pocall_default,3,paraloc3); location_reset(location,LOC_VOID,OS_NO); if assigned(left) then begin + paraloc1.init; + paraloc2.init; + paraloc3.init; + paramanager.getintparaloc(pocall_default,1,class_tobject,paraloc1); + paramanager.getintparaloc(pocall_default,2,voidpointertype,paraloc2); + paramanager.getintparaloc(pocall_default,3,voidpointertype,paraloc3); + { multiple parameters? } if assigned(right) then begin @@ -991,7 +992,7 @@ implementation if assigned(third) then cg.a_load_loc_cgpara(current_asmdata.CurrAsmList,third.location,paraloc3) else - cg.a_load_const_cgpara(current_asmdata.CurrAsmList,OS_INT,0,paraloc3); + cg.a_load_const_cgpara(current_asmdata.CurrAsmList,OS_ADDR,0,paraloc3); { push address } cg.a_load_loc_cgpara(current_asmdata.CurrAsmList,right.location,paraloc2); end @@ -1007,7 +1008,7 @@ implementation if target_info.system <> system_powerpc_macos then cg.a_loadaddr_ref_cgpara(current_asmdata.CurrAsmList,href2,paraloc2) else - cg.a_load_const_cgpara(current_asmdata.CurrAsmList,OS_INT,0,paraloc2); + cg.a_load_const_cgpara(current_asmdata.CurrAsmList,OS_ADDR,0,paraloc2); end; cg.a_load_loc_cgpara(current_asmdata.CurrAsmList,left.location,paraloc1); paramanager.freecgpara(current_asmdata.CurrAsmList,paraloc1); @@ -1016,6 +1017,10 @@ implementation cg.allocallcpuregisters(current_asmdata.CurrAsmList); cg.a_call_name(current_asmdata.CurrAsmList,'FPC_RAISEEXCEPTION',false); cg.deallocallcpuregisters(current_asmdata.CurrAsmList); + + paraloc1.done; + paraloc2.done; + paraloc3.done; end else begin @@ -1024,9 +1029,6 @@ implementation cg.a_call_name(current_asmdata.CurrAsmList,'FPC_RERAISE',false); cg.deallocallcpuregisters(current_asmdata.CurrAsmList); end; - paraloc1.done; - paraloc2.done; - paraloc3.done; end; @@ -1330,7 +1332,7 @@ implementation { send the vmt parameter } reference_reset_symbol(href2,current_asmdata.RefAsmSymbol(excepttype.vmt_mangledname),0,sizeof(pint)); - paramanager.getintparaloc(pocall_default,1,paraloc1); + paramanager.getintparaloc(pocall_default,1,search_system_type('TCLASS').typedef,paraloc1); cg.a_loadaddr_ref_cgpara(current_asmdata.CurrAsmList,href2,paraloc1); paramanager.freecgpara(current_asmdata.CurrAsmList,paraloc1); cg.g_call(current_asmdata.CurrAsmList,'FPC_CATCHES'); @@ -1446,7 +1448,7 @@ implementation { call fpc_safecallhandler, passing self for methods of classes, nil otherwise. } cgpara.init; - paramanager.getintparaloc(pocall_default,1,cgpara); + paramanager.getintparaloc(pocall_default,1,class_tobject,cgpara); if is_class(current_procinfo.procdef.struct) then begin selfsym:=tparavarsym(current_procinfo.procdef.parast.Find('self')); diff --git a/mips/compiler/ncginl.pas b/mips/compiler/ncginl.pas index cfdcb480f4..98265cf399 100644 --- a/mips/compiler/ncginl.pas +++ b/mips/compiler/ncginl.pas @@ -54,8 +54,7 @@ interface procedure second_round_real; virtual; procedure second_trunc_real; virtual; procedure second_abs_long; virtual; - procedure second_rox; virtual; - procedure second_sar; virtual; + procedure second_rox_sar; virtual; procedure second_bsfbsr; virtual; procedure second_new; virtual; procedure second_setlength; virtual; abstract; @@ -168,11 +167,10 @@ implementation in_rol_x, in_rol_x_y, in_ror_x, - in_ror_x_y: - second_rox; + in_ror_x_y, in_sar_x, in_sar_x_y: - second_sar; + second_rox_sar; in_bsf_x, in_bsr_x: second_BsfBsr; @@ -204,10 +202,10 @@ implementation paraloc2.init; paraloc3.init; paraloc4.init; - paramanager.getintparaloc(pocall_default,1,paraloc1); - paramanager.getintparaloc(pocall_default,2,paraloc2); - paramanager.getintparaloc(pocall_default,3,paraloc3); - paramanager.getintparaloc(pocall_default,4,paraloc4); + paramanager.getintparaloc(pocall_default,1,getpointerdef(cshortstringtype),paraloc1); + paramanager.getintparaloc(pocall_default,2,getpointerdef(cshortstringtype),paraloc2); + paramanager.getintparaloc(pocall_default,3,s32inttype,paraloc3); + paramanager.getintparaloc(pocall_default,4,voidpointertype,paraloc4); otlabel:=current_procinfo.CurrTrueLabel; oflabel:=current_procinfo.CurrFalseLabel; current_asmdata.getjumplabel(current_procinfo.CurrTrueLabel); @@ -231,7 +229,7 @@ implementation { push erroraddr } cg.a_load_reg_cgpara(current_asmdata.CurrAsmList,OS_ADDR,NR_FRAME_POINTER_REG,paraloc4); { push lineno } - cg.a_load_const_cgpara(current_asmdata.CurrAsmList,OS_INT,current_filepos.line,paraloc3); + cg.a_load_const_cgpara(current_asmdata.CurrAsmList,OS_S32,current_filepos.line,paraloc3); { push filename } cg.a_loadaddr_ref_cgpara(current_asmdata.CurrAsmList,hp2.location.reference,paraloc2); { push msg } @@ -721,10 +719,9 @@ implementation end; - procedure tcginlinenode.second_rox; + procedure tcginlinenode.second_rox_sar; var op : topcg; - {hcountreg : tregister;} op1,op2 : tnode; begin { one or two parameters? } @@ -733,13 +730,15 @@ implementation begin op1:=tcallparanode(tcallparanode(left).right).left; op2:=tcallparanode(left).left; + secondpass(op2); end else - op1:=left; + begin + op1:=left; + op2:=nil; + end; secondpass(op1); - { load left operator in a register } - location_copy(location,op1.location); case inlinenumber of in_ror_x, in_ror_x_y: @@ -747,66 +746,35 @@ implementation in_rol_x, in_rol_x_y: op:=OP_ROL; + in_sar_x, + in_sar_x_y: + op:=OP_SAR; end; - hlcg.location_force_reg(current_asmdata.CurrAsmList,location,op1.resultdef,resultdef,false); - if (left.nodetype=callparan) and - assigned(tcallparanode(left).right) then + hlcg.location_force_reg(current_asmdata.CurrAsmList,op1.location,op1.resultdef,resultdef,true); + + location_reset(location,LOC_REGISTER,def_cgsize(resultdef)); + location.register:=hlcg.getintregister(current_asmdata.CurrAsmList,resultdef); + + if assigned(op2) then begin - secondpass(op2); { rotating by a constant directly coded: } if op2.nodetype=ordconstn then - cg.a_op_const_reg(current_asmdata.CurrAsmList,op,location.size, - tordconstnode(op2).value.uvalue and (resultdef.size*8-1),location.register) + hlcg.a_op_const_reg_reg(current_asmdata.CurrAsmList,op,resultdef, + tordconstnode(op2).value.uvalue and (resultdef.size*8-1), + op1.location.register, location.register) else begin - hlcg.location_force_reg(current_asmdata.CurrAsmList,op2.location,op2.resultdef,resultdef,false); - { do modulo 2 operation } - cg.a_op_reg_reg(current_asmdata.CurrAsmList,op,location.size,op2.location.register,location.register); + hlcg.location_force_reg(current_asmdata.CurrAsmList,op2.location, + op2.resultdef,resultdef,true); + hlcg.a_op_reg_reg_reg(current_asmdata.CurrAsmList,op,resultdef, + op2.location.register,op1.location.register, + location.register); end; end else - cg.a_op_const_reg(current_asmdata.CurrAsmList,op,location.size,1,location.register); - end; - - - procedure tcginlinenode.second_sar; - var - {hcountreg : tregister;} - op1,op2 : tnode; - begin - if (left.nodetype=callparan) and - assigned(tcallparanode(left).right) then - begin - op1:=tcallparanode(tcallparanode(left).right).left; - op2:=tcallparanode(left).left; - end - else - begin - op1:=left; - op2:=nil; - end; - secondpass(op1); - { load left operator in a register } - location_copy(location,op1.location); - - hlcg.location_force_reg(current_asmdata.CurrAsmList,location,op1.resultdef,resultdef,false); - - if not(assigned(op2)) then - hlcg.a_op_const_reg(current_asmdata.CurrAsmList,OP_SAR,resultdef,1,location.register) - else - begin - secondpass(op2); - { shifting by a constant directly coded: } - if op2.nodetype=ordconstn then - hlcg.a_op_const_reg(current_asmdata.CurrAsmList,OP_SAR,resultdef, - tordconstnode(op2).value.uvalue and (resultdef.size*8-1),location.register) - else - begin - hlcg.location_force_reg(current_asmdata.CurrAsmList,op2.location,op2.resultdef,resultdef,false); - hlcg.a_op_reg_reg(current_asmdata.CurrAsmList,OP_SAR,resultdef,op2.location.register,location.register); - end; - end; + hlcg.a_op_const_reg_reg(current_asmdata.CurrAsmList,op,resultdef,1, + op1.location.register,location.register); end; diff --git a/mips/compiler/ncgld.pas b/mips/compiler/ncgld.pas index cc9f342745..9c7636fe8f 100644 --- a/mips/compiler/ncgld.pas +++ b/mips/compiler/ncgld.pas @@ -362,7 +362,7 @@ implementation current_asmdata.getjumplabel(endrelocatelab); { make sure hregister can't allocate the register necessary for the parameter } paraloc1.init; - paramanager.getintparaloc(pocall_default,1,paraloc1); + paramanager.getintparaloc(pocall_default,1,voidpointertype,paraloc1); hregister:=cg.getaddressregister(current_asmdata.CurrAsmList); reference_reset_symbol(href,current_asmdata.RefAsmSymbol('FPC_THREADVAR_RELOCATE'),0,sizeof(pint)); cg.a_load_ref_reg(current_asmdata.CurrAsmList,OS_ADDR,OS_ADDR,href,hregister); diff --git a/mips/compiler/ncgmat.pas b/mips/compiler/ncgmat.pas index fcc0a57e0e..5d733754ee 100644 --- a/mips/compiler/ncgmat.pas +++ b/mips/compiler/ncgmat.pas @@ -380,7 +380,7 @@ implementation current_asmdata.getjumplabel(hl); cg.a_cmp_const_reg_label(current_asmdata.CurrAsmList,OS_INT,OC_NE,0,hdenom,hl); paraloc1.init; - paramanager.getintparaloc(pocall_default,1,paraloc1); + paramanager.getintparaloc(pocall_default,1,s32inttype,paraloc1); cg.a_load_const_cgpara(current_asmdata.CurrAsmList,OS_S32,aint(200),paraloc1); paramanager.freecgpara(current_asmdata.CurrAsmList,paraloc1); cg.a_call_name(current_asmdata.CurrAsmList,'FPC_HANDLEERROR',false); diff --git a/mips/compiler/ncgmem.pas b/mips/compiler/ncgmem.pas index 86cfd7dc45..ae4256c356 100644 --- a/mips/compiler/ncgmem.pas +++ b/mips/compiler/ncgmem.pas @@ -263,7 +263,7 @@ implementation (location.reference.base<>NR_NO) then begin paraloc1.init; - paramanager.getintparaloc(pocall_default,1,paraloc1); + paramanager.getintparaloc(pocall_default,1,voidpointertype,paraloc1); cg.a_load_reg_cgpara(current_asmdata.CurrAsmList, OS_ADDR,location.reference.base,paraloc1); paramanager.freecgpara(current_asmdata.CurrAsmList,paraloc1); paraloc1.done; @@ -332,7 +332,7 @@ implementation (cs_checkpointer in current_settings.localswitches) and not(cs_compilesystem in current_settings.moduleswitches) then begin - paramanager.getintparaloc(pocall_default,1,paraloc1); + paramanager.getintparaloc(pocall_default,1,voidpointertype,paraloc1); cg.a_load_reg_cgpara(current_asmdata.CurrAsmList, OS_ADDR,location.reference.base,paraloc1); paramanager.freecgpara(current_asmdata.CurrAsmList,paraloc1); cg.allocallcpuregisters(current_asmdata.CurrAsmList); @@ -674,8 +674,8 @@ implementation else if is_dynamic_array(left.resultdef) then begin - paramanager.getintparaloc(pocall_default,1,paraloc1); - paramanager.getintparaloc(pocall_default,2,paraloc2); + paramanager.getintparaloc(pocall_default,1,voidpointertype,paraloc1); + paramanager.getintparaloc(pocall_default,2,search_system_type('TDYNARRAYINDEX').typedef,paraloc2); cg.a_load_loc_cgpara(current_asmdata.CurrAsmList,right.location,paraloc2); cg.a_load_loc_cgpara(current_asmdata.CurrAsmList,left.location,paraloc1); paramanager.freecgpara(current_asmdata.CurrAsmList,paraloc1); @@ -704,8 +704,8 @@ implementation st_widestring, st_ansistring: begin - paramanager.getintparaloc(pocall_default,1,paraloc1); - paramanager.getintparaloc(pocall_default,2,paraloc2); + paramanager.getintparaloc(pocall_default,1,voidpointertype,paraloc1); + paramanager.getintparaloc(pocall_default,2,ptrsinttype,paraloc2); cg.a_load_loc_cgpara(current_asmdata.CurrAsmList,left.location,paraloc1); cg.a_load_loc_cgpara(current_asmdata.CurrAsmList,right.location,paraloc2); diff --git a/mips/compiler/ncgopt.pas b/mips/compiler/ncgopt.pas index 9cb314688c..8037d070de 100644 --- a/mips/compiler/ncgopt.pas +++ b/mips/compiler/ncgopt.pas @@ -43,7 +43,7 @@ uses aasmbase,aasmtai,aasmdata, ncnv, ncon, pass_2, cgbase, cpubase, - tgobj, cgobj, cgutils,ncgutil; + tgobj, cgobj, hlcgobj, cgutils,ncgutil; {***************************************************************************** @@ -91,7 +91,7 @@ begin (tg.sizeoftemp(current_asmdata.CurrAsmList,left.location.reference) = 256)) then begin tg.gethltemp(current_asmdata.CurrAsmList,cshortstringtype,256,tt_normal,href); - cg.g_copyshortstring(current_asmdata.CurrAsmList,left.location.reference,href,255); + hlcg.g_copyshortstring(current_asmdata.CurrAsmList,left.location.reference,href,tstringdef(cshortstringtype)); location_freetemp(current_asmdata.CurrAsmList,left.location); { return temp reference } location_reset_ref(left.location,LOC_REFERENCE,def_cgsize(resultdef),1); diff --git a/mips/compiler/ncgutil.pas b/mips/compiler/ncgutil.pas index 49d935ed28..7f30449866 100644 --- a/mips/compiler/ncgutil.pas +++ b/mips/compiler/ncgutil.pas @@ -417,9 +417,9 @@ implementation paraloc1.init; paraloc2.init; paraloc3.init; - paramanager.getintparaloc(pocall_default,1,paraloc1); - paramanager.getintparaloc(pocall_default,2,paraloc2); - paramanager.getintparaloc(pocall_default,3,paraloc3); + paramanager.getintparaloc(pocall_default,1,s32inttype,paraloc1); + paramanager.getintparaloc(pocall_default,2,voidpointertype,paraloc2); + paramanager.getintparaloc(pocall_default,3,voidpointertype,paraloc3); cg.a_loadaddr_ref_cgpara(list,t.envbuf,paraloc3); cg.a_loadaddr_ref_cgpara(list,t.jmpbuf,paraloc2); { push type of exceptionframe } @@ -431,7 +431,7 @@ implementation cg.a_call_name(list,'FPC_PUSHEXCEPTADDR',false); cg.deallocallcpuregisters(list); - paramanager.getintparaloc(pocall_default,1,paraloc1); + paramanager.getintparaloc(pocall_default,1,search_system_type('PJMP_BUF').typedef,paraloc1); cg.a_load_reg_cgpara(list,OS_ADDR,NR_FUNCTION_RESULT_REG,paraloc1); paramanager.freecgpara(list,paraloc1); cg.allocallcpuregisters(list); @@ -681,7 +681,7 @@ implementation so we're allowed to include pi_do_call here; after pass1 is run, this isn't allowed anymore } include(current_procinfo.flags,pi_do_call); - cg.g_copyshortstring(list,href,localcopyloc.reference,tstringdef(tparavarsym(p).vardef).len) + hlcg.g_copyshortstring(list,href,localcopyloc.reference,tstringdef(tparavarsym(p).vardef)); end else if tparavarsym(p).vardef.typ = variantdef then begin @@ -689,7 +689,7 @@ implementation so we're allowed to include pi_do_call here; after pass1 is run, this isn't allowed anymore } include(current_procinfo.flags,pi_do_call); - cg.g_copyvariant(list,href,localcopyloc.reference) + hlcg.g_copyvariant(list,href,localcopyloc.reference,tvariantdef(tparavarsym(p).vardef)) end else begin @@ -739,10 +739,10 @@ implementation eldef:=tarraydef(tparavarsym(p).vardef).elementdef; if not assigned(hsym) then internalerror(201003031); - cg.g_array_rtti_helper(list,eldef,href,hsym.initialloc,'FPC_ADDREF_ARRAY'); + hlcg.g_array_rtti_helper(list,eldef,href,hsym.initialloc,'fpc_addref_array'); end else - cg.g_incrrefcount(list,tparavarsym(p).vardef,href); + hlcg.g_incrrefcount(list,tparavarsym(p).vardef,href); end; end; vs_out : @@ -757,10 +757,10 @@ implementation eldef:=tarraydef(tparavarsym(p).vardef).elementdef; if not assigned(hsym) then internalerror(201103033); - cg.g_array_rtti_helper(list,eldef,href,hsym.initialloc,'FPC_INITIALIZE_ARRAY'); + hlcg.g_array_rtti_helper(list,eldef,href,hsym.initialloc,'fpc_initialize_array'); end else - cg.g_initialize(list,tparavarsym(p).vardef,href); + hlcg.g_initialize(list,tparavarsym(p).vardef,href); end; end; end; @@ -1310,7 +1310,7 @@ implementation paraloc1 : tcgpara; begin paraloc1.init; - paramanager.getintparaloc(pocall_default,1,paraloc1); + paramanager.getintparaloc(pocall_default,1,ptruinttype,paraloc1); cg.a_load_const_cgpara(list,OS_INT,current_procinfo.calc_stackframe_size,paraloc1); paramanager.freecgpara(list,paraloc1); paraloc1.done; @@ -1323,7 +1323,7 @@ implementation begin paraloc1.init; { Also alloc the register needed for the parameter } - paramanager.getintparaloc(pocall_default,1,paraloc1); + paramanager.getintparaloc(pocall_default,1,ptruinttype,paraloc1); paramanager.freecgpara(list,paraloc1); { Call the helper } cg.allocallcpuregisters(list); diff --git a/mips/compiler/ncnv.pas b/mips/compiler/ncnv.pas index 3ed3576867..db1baaf72f 100644 --- a/mips/compiler/ncnv.pas +++ b/mips/compiler/ncnv.pas @@ -134,6 +134,7 @@ interface function first_cstring_to_int : tnode;virtual; function first_string_to_chararray : tnode;virtual; function first_char_to_string : tnode;virtual; + function first_char_to_chararray : tnode; virtual; function first_nothing : tnode;virtual; function first_array_to_pointer : tnode;virtual; function first_int_to_real : tnode;virtual; @@ -163,6 +164,7 @@ interface function _first_cstring_to_int : tnode; function _first_string_to_chararray : tnode; function _first_char_to_string : tnode; + function _first_char_to_chararray : tnode; function _first_nothing : tnode; function _first_array_to_pointer : tnode; function _first_int_to_real : tnode; @@ -1277,16 +1279,7 @@ implementation function ttypeconvnode.typecheck_char_to_chararray : tnode; begin - if resultdef.size <> 1 then - begin - { convert first to string, then to chararray } - inserttypeconv(left,cshortstringtype); - inserttypeconv(left,resultdef); - result:=left; - left := nil; - exit; - end; - result := nil; + result:=nil; end; @@ -2825,6 +2818,22 @@ implementation end; + function ttypeconvnode.first_char_to_chararray : tnode; + + begin + if resultdef.size <> 1 then + begin + { convert first to string, then to chararray } + inserttypeconv(left,cshortstringtype); + inserttypeconv(left,resultdef); + result:=left; + left := nil; + exit; + end; + result := nil; + end; + + function ttypeconvnode.first_nothing : tnode; begin first_nothing:=nil; @@ -3334,6 +3343,11 @@ implementation result:=first_char_to_string; end; + function ttypeconvnode._first_char_to_chararray: tnode; + begin + result:=first_char_to_chararray; + end; + function ttypeconvnode._first_nothing : tnode; begin result:=first_nothing; @@ -3433,7 +3447,7 @@ implementation @ttypeconvnode._first_nothing, {not_possible} @ttypeconvnode._first_string_to_string, @ttypeconvnode._first_char_to_string, - @ttypeconvnode._first_nothing, { char_2_chararray, needs nothing extra } + @ttypeconvnode._first_char_to_chararray, nil, { removed in typecheck_chararray_to_string } @ttypeconvnode._first_cchar_to_pchar, @ttypeconvnode._first_cstring_to_pchar, diff --git a/mips/compiler/nobj.pas b/mips/compiler/nobj.pas index 837421c188..b78ce2aa05 100644 --- a/mips/compiler/nobj.pas +++ b/mips/compiler/nobj.pas @@ -416,7 +416,12 @@ implementation { Give a note if the new visibility is lower. For a higher visibility update the vmt info } if vmtentryvis>pd.visibility then - MessagePos4(pd.fileinfo,parser_n_ignore_lower_visibility,pd.fullprocname(false), +{$ifdef jvm} + MessagePos4(pd.fileinfo,parser_e_method_lower_visibility, +{$else jvm} + MessagePos4(pd.fileinfo,parser_n_ignore_lower_visibility, +{$endif jvm} + pd.fullprocname(false), visibilityname[pd.visibility],tobjectdef(vmtpd.owner.defowner).objrealname^,visibilityname[vmtentryvis]) else if pd.visibility>vmtentryvis then begin diff --git a/mips/compiler/ogbase.pas b/mips/compiler/ogbase.pas index 0833088a02..08b3a01fcf 100644 --- a/mips/compiler/ogbase.pas +++ b/mips/compiler/ogbase.pas @@ -42,6 +42,7 @@ interface TExeSection = class; TExeSymbol = class; + TExeOutput = class; TObjRelocationType = ( { Relocation to absolute address } @@ -119,11 +120,7 @@ interface oso_Data, { Is loaded into memory } oso_load, - { Not loaded into memory } - oso_noload, - { Read only } - oso_readonly, - { Read/Write } + { Writable } oso_write, { Contains executable instructions } oso_executable, @@ -172,10 +169,12 @@ interface TObjRelocation = class DataOffset, - orgsize : aword; { original size of the symbol to Relocate, required for COFF } + orgsize : aword; { COFF: original size of the symbol to relocate } + { ELF: explicit addend } symbol : TObjSymbol; objsection : TObjSection; { only used if symbol=nil } typ : TObjRelocationType; + size : byte; constructor CreateSymbol(ADataOffset:aword;s:TObjSymbol;Atyp:TObjRelocationType); constructor CreateSymbolSize(ADataOffset:aword;s:TObjSymbol;Aorgsize:aword;Atyp:TObjRelocationType); constructor CreateSection(ADataOffset:aword;aobjsec:TObjSection;Atyp:TObjRelocationType); @@ -189,6 +188,7 @@ interface procedure SetSecOptions(Aoptions:TObjSectionOptions); public ObjData : TObjData; + index : longword; { index of section in section headers } SecSymIdx : longint; { index for the section in symtab } SecAlign : shortint; { alignment of the section } { section Data } @@ -198,8 +198,6 @@ interface DataAlignBytes : shortint; { Relocations (=references) to other sections } ObjRelocations : TFPObjectList; - { Symbols this defines } - ObjSymbolDefines : TFPObjectList; { executable linking } ExeSection : TExeSection; USed : Boolean; @@ -214,8 +212,7 @@ interface procedure alloc(l:aword); procedure addsymReloc(ofs:aword;p:TObjSymbol;Reloctype:TObjRelocationType); procedure addsectionReloc(ofs:aword;aobjsec:TObjSection;Reloctype:TObjRelocationType); - procedure AddSymbolDefine(p:TObjSymbol); - procedure FixupRelocs;virtual; + procedure FixupRelocs(Exe: TExeOutput);virtual; procedure ReleaseData; function FullName:string; property Data:TDynamicArray read FData; @@ -244,7 +241,6 @@ interface property CObjSection:TObjSectionClass read FCObjSection write FCObjSection; public CurrPass : byte; - ImageBase : aword; constructor create(const n:string);virtual; destructor destroy;override; { Sections } @@ -350,7 +346,6 @@ interface TExeSymbol = class(TFPHashObject) ObjSymbol : TObjSymbol; - ExeSection : TExeSection; State : TSymbolState; { Used for vmt references optimization } VTable : TExeVTable; @@ -368,7 +363,7 @@ interface SecOptions : TObjSectionOptions; constructor create(AList:TFPHashObjectList;const AName:string);virtual; destructor destroy;override; - procedure AddObjSection(objsec:TObjSection); + procedure AddObjSection(objsec:TObjSection);virtual; property ObjSectionList:TFPObjectList read FObjSectionList; property SecSymIdx:longint read FSecSymIdx write FSecSymIdx; end; @@ -422,6 +417,7 @@ interface FUnresolvedExeSymbols : TFPObjectList; FExternalObjSymbols, FCommonObjSymbols : TFPObjectList; + FProvidedObjSymbols : TFPObjectList; FEntryName : string; FExeVTableList : TFPObjectList; { Objects } @@ -470,10 +466,12 @@ interface procedure Order_ObjSection(const aname:string);virtual; procedure MemPos_Start;virtual; procedure MemPos_Header;virtual; + procedure MemPos_ExeSection(exesec:TExeSection); procedure MemPos_ExeSection(const aname:string);virtual; procedure MemPos_EndExeSection;virtual; procedure DataPos_Start;virtual; procedure DataPos_Header;virtual; + procedure DataPos_ExeSection(exesec:TExeSection); procedure DataPos_ExeSection(const aname:string);virtual; procedure DataPos_EndExeSection;virtual; procedure DataPos_Symbols;virtual; @@ -483,6 +481,7 @@ interface procedure PrintMemoryMap; procedure FixupSymbols; procedure FixupRelocations; + procedure RemoveUnusedExeSymbols; procedure MergeStabs; procedure RemoveUnreferencedSections; procedure RemoveEmptySections; @@ -644,7 +643,6 @@ implementation secsymidx:=0; { relocation } ObjRelocations:=TFPObjectList.Create(true); - ObjSymbolDefines:=TFPObjectList.Create(false); VTRefList:=TFPObjectList.Create(false); end; @@ -655,7 +653,6 @@ implementation Data.Free; stringdispose(FCachedFullName); ObjRelocations.Free; - ObjSymbolDefines.Free; VTRefList.Free; inherited destroy; end; @@ -748,15 +745,7 @@ implementation end; - procedure TObjSection.AddSymbolDefine(p:TObjSymbol); - begin - if p.bind<>AB_GLOBAL then - exit; - ObjSymbolDefines.Add(p); - end; - - - procedure TObjSection.FixupRelocs; + procedure TObjSection.FixupRelocs(Exe:TExeOutput); begin end; @@ -770,8 +759,6 @@ implementation end; ObjRelocations.free; ObjRelocations:=nil; - ObjSymbolDefines.Free; - ObjSymbolDefines:=nil; if assigned(FCachedFullName) then begin stringdispose(FCachedFullName); @@ -918,7 +905,7 @@ implementation const secoptions : array[TAsmSectiontype] of TObjSectionOptions = ([], {user} [oso_Data,oso_load,oso_write,oso_keep], - {code} [oso_Data,oso_load,oso_readonly,oso_executable,oso_keep], + {code} [oso_Data,oso_load,oso_executable,oso_keep], {Data} [oso_Data,oso_load,oso_write,oso_keep], { TODO: Fix sec_rodata be read-only-with-relocs} {roData} [oso_Data,oso_load,oso_write,oso_keep], @@ -930,29 +917,29 @@ implementation ,oso_keep {$endif FPC_USE_TLS_DIRECTORY} ], - {pdata} [oso_data,oso_load,oso_readonly {$ifndef x86_64},oso_keep{$endif}], - {stub} [oso_Data,oso_load,oso_readonly,oso_executable], + {pdata} [oso_data,oso_load {$ifndef x86_64},oso_keep{$endif}], + {stub} [oso_Data,oso_load,oso_executable], {data_nonlazy} [oso_Data,oso_load,oso_write], {data_lazy} [oso_Data,oso_load,oso_write], {init_func} [oso_Data,oso_load], {term_func} [oso_Data,oso_load], - {stab} [oso_Data,oso_noload,oso_debug], - {stabstr} [oso_Data,oso_noload,oso_strings,oso_debug], + {stab} [oso_Data,oso_debug], + {stabstr} [oso_Data,oso_strings,oso_debug], {iData2} [oso_Data,oso_load,oso_write], {iData4} [oso_Data,oso_load,oso_write], {iData5} [oso_Data,oso_load,oso_write], {iData6} [oso_Data,oso_load,oso_write], {iData7} [oso_Data,oso_load,oso_write], - {eData} [oso_Data,oso_load,oso_readonly], - {eh_frame} [oso_Data,oso_load,oso_readonly], - {debug_frame} [oso_Data,oso_noload,oso_debug], - {debug_info} [oso_Data,oso_noload,oso_debug], - {debug_line} [oso_Data,oso_noload,oso_debug], - {debug_abbrev} [oso_Data,oso_noload,oso_debug], + {eData} [oso_Data,oso_load], + {eh_frame} [oso_Data,oso_load], + {debug_frame} [oso_Data,oso_debug], + {debug_info} [oso_Data,oso_debug], + {debug_line} [oso_Data,oso_debug], + {debug_abbrev} [oso_Data,oso_debug], {fpc} [oso_Data,oso_load,oso_write,oso_keep], - {toc} [oso_Data,oso_load,oso_readonly], - {init} [oso_Data,oso_load,oso_readonly,oso_executable,oso_keep], - {fini} [oso_Data,oso_load,oso_readonly,oso_executable,oso_keep], + {toc} [oso_Data,oso_load], + {init} [oso_Data,oso_load,oso_executable,oso_keep], + {fini} [oso_Data,oso_load,oso_executable,oso_keep], {objc_class} [oso_data,oso_load], {objc_meta_class} [oso_data,oso_load], {objc_cat_cls_meth} [oso_data,oso_load], @@ -1078,8 +1065,6 @@ implementation begin result:=TObjSymbol(asmsym.cachedObjSymbol); result.SetAddress(CurrPass,CurrObjSec,asmsym.bind,asmsym.typ); - { Register also in TObjSection } - CurrObjSec.AddSymbolDefine(result); end; end else @@ -1092,8 +1077,6 @@ implementation if not assigned(CurrObjSec) then internalerror(200603051); result:=CreateSymbol(aname); - { Register also in TObjSection } - CurrObjSec.AddSymbolDefine(result); result.SetAddress(CurrPass,CurrObjSec,abind,atyp); end; @@ -1551,6 +1534,7 @@ implementation FUnresolvedExeSymbols:=TFPObjectList.Create(false); FExternalObjSymbols:=TFPObjectList.Create(false); FCommonObjSymbols:=TFPObjectList.Create(false); + FProvidedObjSymbols:=TFPObjectList.Create(false); FExeVTableList:=TFPObjectList.Create(false); FEntryName:='start'; { sections } @@ -1573,6 +1557,7 @@ implementation FExeSymbolList.free; UnresolvedExeSymbols.free; ExternalObjSymbols.free; + FProvidedObjSymbols.free; CommonObjSymbols.free; ExeVTableList.free; FExeSectionList.free; @@ -1659,7 +1644,7 @@ implementation in a section with adress 0 and at offset 0 } objsec:=internalObjData.createsection('*__image_base__',0,[]); internalObjData.setsection(objsec); - objsym:=internalObjData.SymbolDefine('__image_base__',AB_GLOBAL,AT_FUNCTION); + objsym:=internalObjData.SymbolDefine('__image_base__',AB_GLOBAL,AT_DATA); exesym:=texesymbol.Create(FExeSymbolList,objsym.name); exesym.ObjSymbol:=objsym; end; @@ -1668,7 +1653,7 @@ implementation procedure TExeOutput.Load_Symbol(const aname:string); begin internalObjData.createsection('*'+aname,0,[]); - internalObjData.SymbolDefine(aname,AB_GLOBAL,AT_FUNCTION); + internalObjData.SymbolDefine(aname,AB_GLOBAL,AT_DATA); end; procedure TExeOutput.Load_ProvideSymbol(const aname:string); @@ -1763,13 +1748,17 @@ implementation procedure TExeOutput.Order_ProvideSymbol(const aname:string); var ObjSection : TObjSection; + exesym : TExeSymbol; begin ObjSection:=internalObjData.findsection('*'+aname); if not assigned(ObjSection) then internalerror(200603041); - { Only include this section if the symbol doesn't - exist otherwisee } - if not assigned(ExeSymbolList.Find(aname)) then + exesym:=TExeSymbol(ExeSymbolList.Find(aname)); + if not assigned(exesym) then + internalerror(201206301); + { Only include this section if it actually resolves + the symbol } + if exesym.objsymbol.objsection=objsection then CurrExeSec.AddObjSection(ObjSection); end; @@ -1912,29 +1901,35 @@ implementation end; - procedure TExeOutput.MemPos_ExeSection(const aname:string); + procedure TExeOutput.MemPos_ExeSection(exesec:TExeSection); var i : longint; objsec : TObjSection; begin - { Section can be removed } - FCurrExeSec:=FindExeSection(aname); - if not assigned(CurrExeSec) then - exit; - { Alignment of ExeSection } CurrMemPos:=align(CurrMemPos,SectionMemAlign); - CurrExeSec.MemPos:=CurrMemPos; + exesec.MemPos:=CurrMemPos; { set position of object ObjSections } - for i:=0 to CurrExeSec.ObjSectionList.Count-1 do + for i:=0 to exesec.ObjSectionList.Count-1 do begin - objsec:=TObjSection(CurrExeSec.ObjSectionList[i]); + objsec:=TObjSection(exesec.ObjSectionList[i]); CurrMemPos:=objsec.setmempos(CurrMemPos); end; { calculate size of the section } - CurrExeSec.Size:=CurrMemPos-CurrExeSec.MemPos; + exesec.Size:=CurrMemPos-exesec.MemPos; + end; + + + procedure TExeOutput.MemPos_ExeSection(const aname:string); + begin + { Section can be removed } + FCurrExeSec:=FindExeSection(aname); + if not assigned(CurrExeSec) then + exit; + + MemPos_ExeSection(CurrExeSec); end; @@ -1956,34 +1951,29 @@ implementation end; - procedure TExeOutput.DataPos_ExeSection(const aname:string); + procedure TExeOutput.DataPos_ExeSection(exesec:TExeSection); var i : longint; objsec : TObjSection; begin - { Section can be removed } - FCurrExeSec:=FindExeSection(aname); - if not assigned(CurrExeSec) then - exit; - { don't write normal section if writing only debug info } if (ExeWriteMode=ewm_dbgonly) and - not(oso_debug in CurrExeSec.SecOptions) then + not(oso_debug in exesec.SecOptions) then exit; - if (oso_Data in currexesec.SecOptions) then + if (oso_Data in exesec.SecOptions) then begin CurrDataPos:=align(CurrDataPos,SectionDataAlign); - CurrExeSec.DataPos:=CurrDataPos; + exesec.DataPos:=CurrDataPos; end; { set position of object ObjSections } - for i:=0 to CurrExeSec.ObjSectionList.Count-1 do + for i:=0 to exesec.ObjSectionList.Count-1 do begin - objsec:=TObjSection(CurrExeSec.ObjSectionList[i]); + objsec:=TObjSection(exesec.ObjSectionList[i]); if (oso_Data in objsec.SecOptions) then begin - if not(oso_Data in currexesec.SecOptions) then + if not(oso_Data in exesec.SecOptions) then internalerror(200603043); if not assigned(objsec.Data) then internalerror(200603044); @@ -1993,6 +1983,16 @@ implementation end; + procedure TExeOutput.DataPos_ExeSection(const aname:string); + begin + { Section can be removed } + FCurrExeSec:=FindExeSection(aname); + if not assigned(CurrExeSec) then + exit; + DataPos_ExeSection(CurrExeSec); + end; + + procedure TExeOutput.DataPos_EndExeSection; begin if not assigned(CurrExeSec) then @@ -2002,18 +2002,7 @@ implementation procedure TExeOutput.DataPos_Symbols; - var - i : longint; - sym : TExeSymbol; begin - { Removing unused symbols } - for i:=0 to ExeSymbolList.Count-1 do - begin - sym:=TExeSymbol(ExeSymbolList[i]); - if not sym.ObjSymbol.objsection.Used then - ExeSymbolList[i]:=nil; - end; - ExeSymbolList.Pack; end; @@ -2177,7 +2166,11 @@ implementation exesym.ObjSymbol:=objsym; exesym.State:=symstate_common; end; - CommonObjSymbols.add(objsym); + if assigned(objsym.objsection) and + (objsym.objsection.objdata=internalObjData) then + FProvidedObjSymbols.add(objsym) + else + CommonObjSymbols.add(objsym); end; end; end; @@ -2188,10 +2181,11 @@ implementation VTInheritList:=TFPObjectList.Create(false); { - The symbol resolving is done in 3 steps: + The symbol resolving is done in 4 steps: 1. Register symbols from objects 2. Find symbols in static libraries - 3. Define stil undefined common symbols + 3. Define symbols PROVIDEd by the link script + 4. Define still undefined common symbols } { Step 1, Register symbols from objects } @@ -2246,7 +2240,19 @@ implementation end; PackUnresolvedExeSymbols('after static libraries'); - { Step 3, Match common symbols or add to the globals } + { Step 3, handle symbols provided in script } + for i:=0 to FProvidedObjSymbols.count-1 do + begin + objsym:=TObjSymbol(FProvidedObjSymbols[i]); + if objsym.exesymbol.State=symstate_defined then + continue; + objsym.exesymbol.objsymbol:=objsym; + objsym.bind:=AB_GLOBAL; + objsym.exesymbol.State:=symstate_defined; + end; + PackUnresolvedExeSymbols('after defining symbols provided by link script'); + + { Step 4, Match common symbols or add to the globals } firstcommon:=true; for i:=0 to CommonObjSymbols.count-1 do begin @@ -2268,7 +2274,7 @@ implementation end; internalObjData.setsection(commonObjSection); internalObjData.allocalign(var_align(objsym.size)); - commonsym:=internalObjData.symboldefine(objsym.name,AB_GLOBAL,AT_FUNCTION); + commonsym:=internalObjData.symboldefine(objsym.name,AB_GLOBAL,AT_DATA); commonsym.size:=objsym.size; internalObjData.alloc(objsym.size); if assigned(exemap) then @@ -2331,7 +2337,7 @@ implementation exesec:=CExeSection.create(ExeSectionList,debuglinkname); exesec.SecOptions:=[oso_data,oso_keep]; exesec.SecAlign:=4; - objsec:=internalObjData.createsection(exesec.name,0,exesec.SecOptions); + objsec:=internalObjData.createsection(exesec.name,1,exesec.SecOptions); internalObjData.writebytes(debuglink,len); exesec.AddObjSection(objsec); end; @@ -2342,16 +2348,34 @@ implementation end; + function ByAddress(item1,item2:pointer):longint; + var + sym1:TObjSymbol absolute item1; + sym2:TObjSymbol absolute item2; + begin + result:=sym1.address-sym2.address; + end; + + procedure TExeOutput.PrintMemoryMap; var exesec : TExeSection; objsec : TObjSection; objsym : TObjSymbol; - i,j,k : longint; + i,j,k,m: longint; + list : TFPList; + flag : boolean; begin if not assigned(exemap) then exit; + { create a list of symbols sorted by address } + list:=TFPList.Create; + for i:=0 to ExeSymbolList.Count-1 do + list.Add(TExeSymbol(ExeSymbolList[i]).ObjSymbol); + list.Sort(@ByAddress); + exemap.AddMemoryMapHeader(ImageBase); + k:=0; for i:=0 to ExeSectionList.Count-1 do begin exesec:=TExeSection(ExeSectionList[i]); @@ -2360,13 +2384,43 @@ implementation begin objsec:=TObjSection(exesec.ObjSectionList[j]); exemap.AddMemoryMapObjectSection(objsec); - for k:=0 to objsec.ObjSymbolDefines.Count-1 do + + while (k<list.Count) and (TObjSymbol(list[k]).Address<objsec.MemPos) do + inc(k); + while (k<list.Count) do begin - objsym:=TObjSymbol(objsec.ObjSymbolDefines[k]); - exemap.AddMemoryMapSymbol(objsym); + objsym:=TObjSymbol(list[k]); + if objsym.address>objsec.MemPos+objsec.Size then + break; + if objsym.objsection=objsec then + exemap.AddMemoryMapSymbol(objsym) + else + begin + { Got a symbol with address falling into current section, but + belonging to a different section. This may happen for zero-length + sections because symbol list is sorted by address but not by section. + Do some look-ahead in this case. } + m:=k+1; + flag:=false; + while (m<list.Count) and (TObjSymbol(list[m]).Address=objsym.address) do + begin + if TObjSymbol(list[m]).objsection=objsec then + begin + flag:=true; + list.Exchange(k,m); + exemap.AddMemoryMapSymbol(TObjSymbol(list[k])); + break; + end; + inc(m); + end; + if not flag then + break; + end; + inc(k); end; end; end; + list.Free; end; @@ -2394,10 +2448,6 @@ implementation Comment(V_Error,'Undefined symbol: '+exesym.name); end; - { Update ImageBase to ObjData so it can access from ObjSymbols } - for i:=0 to ObjDataList.Count-1 do - TObjData(ObjDataList[i]).imagebase:=imagebase; - { Fixing up symbols is done in the following steps: 1. Update common references @@ -2841,12 +2891,28 @@ implementation objsec:=TObjSection(exesec.ObjSectionlist[j]); if not objsec.Used then internalerror(200603301); - objsec.FixupRelocs; + objsec.FixupRelocs(Self); end; end; end; + procedure TExeOutput.RemoveUnusedExeSymbols; + var + i : longint; + sym : TExeSymbol; + begin + { Removing unused symbols } + for i:=0 to ExeSymbolList.Count-1 do + begin + sym:=TExeSymbol(ExeSymbolList[i]); + if not sym.ObjSymbol.objsection.Used then + ExeSymbolList[i]:=nil; + end; + ExeSymbolList.Pack; + end; + + procedure TExeOutput.SetCurrMemPos(const AValue: qword); begin if AValue>MaxMemPos then diff --git a/mips/compiler/ogcoff.pas b/mips/compiler/ogcoff.pas index 157aa0a91f..61fc394f22 100644 --- a/mips/compiler/ogcoff.pas +++ b/mips/compiler/ogcoff.pas @@ -107,18 +107,9 @@ interface coffrelocs, coffrelocpos : aword; public - secidx : longword; constructor create(AList:TFPHashObjectList;const Aname:string;Aalign:shortint;Aoptions:TObjSectionOptions);override; procedure addsymsizereloc(ofs:aword;p:TObjSymbol;symsize:aword;reloctype:TObjRelocationType); - procedure fixuprelocs;override; - end; - - TDJCoffObjSection = class(TCoffObjSection) - constructor create(AList:TFPHashObjectList;const Aname:string;Aalign:shortint;Aoptions:TObjSectionOptions);override; - end; - - TPECoffObjSection = class(TCoffObjSection) - constructor create(AList:TFPHashObjectList;const Aname:string;Aalign:shortint;Aoptions:TObjSectionOptions);override; + procedure fixuprelocs(Exe:TExeOutput);override; end; TCoffObjData = class(TObjData) @@ -132,7 +123,6 @@ interface procedure CreateDebugSections;override; function sectionname(atype:TAsmSectiontype;const aname:string;aorder:TAsmSectionOrder):string;override; procedure writereloc(data:aint;len:aword;p:TObjSymbol;reloctype:TObjRelocationType);override; - procedure afteralloc;override; end; TDJCoffObjData = class(TCoffObjData) @@ -172,8 +162,9 @@ interface TCoffObjInput = class(tObjInput) private - FCoffsyms, - FCoffStrs : tdynamicarray; + FCoffsyms : tdynamicarray; + FCoffStrs : PChar; + FCoffStrSize: longword; { Convert symidx -> TObjSymbol } FSymTbl : ^TObjSymbolArray; { Convert secidx -> TObjSection } @@ -199,21 +190,6 @@ interface constructor create;override; end; - TCoffExeSection = class(TExeSection) - private - win32 : boolean; - public - constructor createcoff(AList:TFPHashObjectList;const n:string;awin32:boolean); - end; - - TDJCoffExeSection = class(TCoffExeSection) - constructor create(AList:TFPHashObjectList;const n:string);override; - end; - - TPECoffExeSection = class(TCoffExeSection) - constructor create(AList:TFPHashObjectList;const n:string);override; - end; - TCoffexeoutput = class(texeoutput) private FCoffStrs : tdynamicarray; @@ -254,11 +230,7 @@ interface procedure MemPos_ExeSection(const aname:string);override; end; - TObjSymbolrec = record - sym : TObjSymbol; - orgsize : aword; - end; - TObjSymbolArray = array[0..high(word)] of TObjSymbolrec; + TObjSymbolArray = array[0..high(word)] of TObjSymbol; TObjSectionArray = array[0..high(smallint)] of TObjSection; TDJCoffAssembler = class(tinternalassembler) @@ -796,16 +768,11 @@ const pemagic : array[0..3] of byte = ( include(aoptions,oso_debug); if flags and PE_SCN_CNT_UNINITIALIZED_DATA=0 then include(aoptions,oso_data); - if (flags and PE_SCN_LNK_REMOVE<>0) or - (flags and PE_SCN_MEM_DISCARDABLE<>0) then - include(aoptions,oso_noload) - else + if (flags and (PE_SCN_LNK_REMOVE or PE_SCN_MEM_DISCARDABLE)=0) then include(aoptions,oso_load); { read/write } if flags and PE_SCN_MEM_WRITE<>0 then - include(aoptions,oso_write) - else - include(aoptions,oso_readonly); + include(aoptions,oso_write); { alignment } alignflag:=flags and PE_SCN_ALIGN_MASK; if alignflag=PE_SCN_ALIGN_64BYTES then @@ -845,7 +812,7 @@ const pemagic : array[0..3] of byte = ( end; - procedure TCoffObjSection.fixuprelocs; + procedure TCoffObjSection.fixuprelocs(Exe:TExeOutput); var i,zero,address_size : longint; objreloc : TObjRelocation; @@ -981,7 +948,7 @@ const pemagic : array[0..3] of byte = ( else {$endif arm} inc(address,relocval); - inc(address,relocsec.objdata.imagebase); + inc(address,exe.imagebase); end; else internalerror(200604014); @@ -1010,26 +977,6 @@ const pemagic : array[0..3] of byte = ( {**************************************************************************** - TDJCoffObjSection -****************************************************************************} - - constructor TDJCoffObjSection.create(AList:TFPHashObjectList;const aname:string;aalign:shortint;aoptions:TObjSectionOptions); - begin - inherited create(alist,aname,aalign,aoptions); - end; - - -{**************************************************************************** - TPECoffObjSection -****************************************************************************} - - constructor TPECoffObjSection.create(AList:TFPHashObjectList;const aname:string;aalign:shortint;aoptions:TObjSectionOptions); - begin - inherited create(alist,aname,aalign,aoptions); - end; - - -{**************************************************************************** TCoffObjData ****************************************************************************} @@ -1169,29 +1116,13 @@ const pemagic : array[0..3] of byte = ( end; - procedure TCoffObjData.afteralloc; - var - mempos : qword; - i : longint; - begin - inherited afteralloc; - { DJ Coff requires mempositions } - if not win32 then - begin - mempos:=0; - for i:=0 to ObjSectionList.Count-1 do - mempos:=TObjSection(ObjSectionList[i]).setmempos(mempos); - end; - end; - - {**************************************************************************** TDJCoffObjData ****************************************************************************} constructor TDJCoffObjData.create(const n:string); begin - inherited createcoff(n,false,TDJCoffObjSection); + inherited createcoff(n,false,TCoffObjSection); end; @@ -1201,7 +1132,7 @@ const pemagic : array[0..3] of byte = ( constructor TPECoffObjData.create(const n:string); begin - inherited createcoff(n,true,TPECoffObjSection); + inherited createcoff(n,true,TCoffObjSection); end; @@ -1254,14 +1185,14 @@ const pemagic : array[0..3] of byte = ( with TCoffObjSection(p) do begin Inc(plongword(arg)^); - secidx:=plongword(arg)^; + index:=plongword(arg)^; secsymidx:=symidx; { Both GNU and Microsoft toolchains write section symbols using storage class 3 (STATIC). No reason to use COFF_SYM_SECTION, it is silently converted to 3 by PE binutils and causes warnings with DJGPP binutils. } - write_symbol(name,mempos,secidx,COFF_SYM_LOCAL,1); + write_symbol(name,mempos,index,COFF_SYM_LOCAL,1); { AUX } fillchar(secrec,sizeof(secrec),0); secrec.len:=Size; @@ -1389,13 +1320,13 @@ const pemagic : array[0..3] of byte = ( AB_GLOBAL : begin globalval:=COFF_SYM_GLOBAL; - sectionval:=TCoffObjSection(objsym.objsection).secidx; + sectionval:=objsym.objsection.index; value:=objsym.address; end; AB_LOCAL : begin globalval:=COFF_SYM_LOCAL; - sectionval:=TCoffObjSection(objsym.objsection).secidx; + sectionval:=objsym.objsection.index; value:=objsym.address; end; else @@ -1465,11 +1396,9 @@ const pemagic : array[0..3] of byte = ( function TCoffObjOutput.writedata(data:TObjData):boolean; var - orgdatapos, datapos, sympos : aword; i : longint; - gotreloc : boolean; header : tcoffheader; begin result:=false; @@ -1485,9 +1414,7 @@ const pemagic : array[0..3] of byte = ( { Sections first } layoutsections(datapos); { relocs } - orgdatapos:=datapos; ObjSectionList.ForEachCall(@section_set_reloc_datapos,@datapos); - gotreloc:=(orgdatapos<>datapos); { Symbols } sympos:=datapos; @@ -1499,22 +1426,15 @@ const pemagic : array[0..3] of byte = ( header.syms:=symidx; if win32 then begin -{$ifdef arm} +{$ifndef x86_64} header.flag:=PE_FILE_32BIT_MACHINE or PE_FILE_LINE_NUMS_STRIPPED or PE_FILE_LOCAL_SYMS_STRIPPED; -{$else arm} - header.flag:=PE_FILE_BYTES_REVERSED_LO or PE_FILE_32BIT_MACHINE or - PE_FILE_LINE_NUMS_STRIPPED or PE_FILE_LOCAL_SYMS_STRIPPED; -{$endif arm} - if not gotreloc then - header.flag:=header.flag or PE_FILE_RELOCS_STRIPPED; +{$else x86_64} + header.flag:=PE_FILE_LINE_NUMS_STRIPPED or PE_FILE_LOCAL_SYMS_STRIPPED; +{$endif x86_64} end else - begin - header.flag:=COFF_FLAG_AR32WR or COFF_FLAG_NOLINES or COFF_FLAG_NOLSYMS; - if not gotreloc then - header.flag:=header.flag or COFF_FLAG_NORELOCS; - end; + header.flag:=COFF_FLAG_AR32WR or COFF_FLAG_NOLINES or COFF_FLAG_NOLSYMS; FWriter.write(header,sizeof(header)); { Section headers } ObjSectionList.ForEachCall(@section_write_header,nil); @@ -1567,7 +1487,8 @@ const pemagic : array[0..3] of byte = ( destructor TCoffObjInput.destroy; begin FCoffSyms.free; - FCoffStrs.free; + if assigned(FCoffStrs) then + freemem(FCoffStrs); if assigned(FSymTbl) then freemem(FSymTbl); if assigned(FSecTbl) then @@ -1590,12 +1511,9 @@ const pemagic : array[0..3] of byte = ( function TCoffObjInput.Read_str(strpos:longword):string; begin - FCoffStrs.Seek(strpos-4); - FCoffStrs.Read(result[1],255); - result[255]:=#0; - result[0]:=chr(strlen(@result[1])); - if result='' then + if (FCoffStrs=nil) or (strpos>=FCoffStrSize) or (FCoffStrs[strpos]=#0) then Internalerror(200205172); + result:=string(PChar(@FCoffStrs[strpos])); end; @@ -1664,9 +1582,9 @@ const pemagic : array[0..3] of byte = ( end; end; - p:=FSymTbl^[rel.sym].sym; + p:=FSymTbl^[rel.sym]; if assigned(p) then - s.addsymsizereloc(rel.address-s.mempos,p,FSymTbl^[rel.sym].orgsize,rel_type) + s.addsymsizereloc(rel.address-s.mempos,p,p.size,rel_type) else begin InputError('Failed reading coff file, can''t resolve symbol of relocation'); @@ -1694,7 +1612,7 @@ const pemagic : array[0..3] of byte = ( begin nsyms:=FCoffSyms.Size div sizeof(CoffSymbol); { Allocate memory for symidx -> TObjSymbol table } - FSymTbl:=AllocMem(nsyms*sizeof(TObjSymbolrec)); + FSymTbl:=AllocMem(nsyms*sizeof(TObjSymbol)); { Load the Symbols } FCoffSyms.Seek(0); symidx:=0; @@ -1742,9 +1660,6 @@ const pemagic : array[0..3] of byte = ( objsym.objsection:=objsec; objsym.offset:=address; objsym.size:=size; - { Register in ObjSection } - if assigned(objsec) then - objsec.AddSymbolDefine(objsym); end; COFF_SYM_LABEL, COFF_SYM_LOCAL : @@ -1786,8 +1701,7 @@ const pemagic : array[0..3] of byte = ( else internalerror(200602232); end; - FSymTbl^[symidx].sym:=objsym; - FSymTbl^[symidx].orgsize:=size; + FSymTbl^[symidx]:=objsym; { read aux records } for i:=1 to sym.aux do begin @@ -1822,7 +1736,6 @@ const pemagic : array[0..3] of byte = ( function TCoffObjInput.ReadObjData(AReader:TObjectreader;objdata:TObjData):boolean; var secalign : shortint; - strsize, strpos, i : longint; code : longint; @@ -1837,7 +1750,6 @@ const pemagic : array[0..3] of byte = ( InputFileName:=AReader.FileName; result:=false; FCoffSyms:=TDynamicArray.Create(SymbolMaxGrow); - FCoffStrs:=TDynamicArray.Create(StrsMaxGrow); with TCoffObjData(objdata) do begin { Read COFF header } @@ -1862,15 +1774,23 @@ const pemagic : array[0..3] of byte = ( exit; end; { Strings } - if not AReader.Read(strsize,4) then + if not AReader.Read(FCoffStrSize,4) then begin InputError('Error reading COFF string table'); exit; end; - if (strsize>4) and not AReader.ReadArray(FCoffStrs,Strsize-4) then + if (FCoffStrSize>4) then begin - InputError('Error reading COFF string table'); - exit; + { allocate an extra byte and null-terminate } + GetMem(FCoffStrs,FCoffStrSize+1); + FCoffStrs[FCoffStrSize]:=#0; + for i:=0 to 3 do + FCoffStrs[i]:=#0; + if not AReader.Read(FCoffStrs[4],FCoffStrSize-4) then + begin + InputError('Error reading COFF string table'); + exit; + end; end; { Section headers } { Allocate SecIdx -> TObjSection table, secidx is 1-based } @@ -1907,14 +1827,14 @@ const pemagic : array[0..3] of byte = ( end; if (Length(secname)>3) and (secname[2] in ['e','f','i','p','r']) then begin - if (Copy(secname,1,6)='.edata') or - (Copy(secname,1,5)='.rsrc') or + if (Pos('.edata',secname)=1) or + (Pos('.rsrc',secname)=1) or {$ifndef x86_64} - (Copy(secname,1,6)='.pdata') or + (Pos('.pdata',secname)=1) or {$endif} - (Copy(secname,1,4)='.fpc') then + (Pos('.fpc',secname)=1) then include(secoptions,oso_keep); - if (Copy(secname,1,6)='.idata') then + if (Pos('.idata',secname)=1) then begin { TODO: idata keep can maybe replaced with grouping of text and idata} include(secoptions,oso_keep); @@ -1938,7 +1858,8 @@ const pemagic : array[0..3] of byte = ( { Relocs } ObjSectionList.ForEachCall(@objsections_read_relocs,nil); end; - FCoffStrs.Free; + if assigned(FCoffStrs) then + freemem(FCoffStrs); FCoffStrs:=nil; FCoffSyms.Free; FCoffSyms:=nil; @@ -1961,30 +1882,6 @@ const pemagic : array[0..3] of byte = ( {**************************************************************************** - TCoffexesection -****************************************************************************} - - - constructor TCoffExeSection.createcoff(AList:TFPHashObjectList;const n:string;awin32:boolean); - begin - inherited create(AList,n); - win32:=awin32; - end; - - - constructor TDJCoffExeSection.create(AList:TFPHashObjectList;const n:string); - begin - inherited createcoff(AList,n,false); - end; - - - constructor TPECoffExeSection.create(AList:TFPHashObjectList;const n:string); - begin - inherited createcoff(AList,n,false); - end; - - -{**************************************************************************** TCoffexeoutput ****************************************************************************} @@ -2433,7 +2330,7 @@ const pemagic : array[0..3] of byte = ( begin idataExeSec:=FindExeSection('.idata'); if idataExeSec<>nil then - idataExeSec.SecOptions:=idataExeSec.SecOptions - [oso_write] + [oso_readonly]; + idataExeSec.SecOptions:=idataExeSec.SecOptions - [oso_write]; end; { Section headers } @@ -2483,7 +2380,7 @@ const pemagic : array[0..3] of byte = ( begin inherited createcoff(false); datapos_offset:=sizeof(go32v2stub); - CExeSection:=TDJCoffExeSection; + CExeSection:=TExeSection; CObjData:=TDJCoffObjData; end; @@ -2497,7 +2394,7 @@ const pemagic : array[0..3] of byte = ( constructor TPECoffexeoutput.create; begin inherited createcoff(true); - CExeSection:=TPECoffExeSection; + CExeSection:=TExeSection; CObjData:=TPECoffObjData; end; diff --git a/mips/compiler/ogelf.pas b/mips/compiler/ogelf.pas index f270f24466..6af27003de 100644 --- a/mips/compiler/ogelf.pas +++ b/mips/compiler/ogelf.pas @@ -39,7 +39,6 @@ interface type TElfObjSection = class(TObjSection) public - secshidx : longint; { index for the section in symtab } shstridx, shtype, shflags, @@ -47,7 +46,19 @@ interface shinfo, shentsize : longint; constructor create(AList:TFPHashObjectList;const Aname:string;Aalign:shortint;Aoptions:TObjSectionOptions);override; - constructor create_ext(AList:TFPHashObjectList;const Aname:string;Ashtype,Ashflags,Ashlink,Ashinfo:longint;Aalign:shortint;Aentsize:longint); + constructor create_ext(aobjdata:TObjData;const Aname:string;Ashtype,Ashflags,Ashlink,Ashinfo:longint;Aalign:shortint;Aentsize:longint); + end; + + TElfSymtabKind = (esk_obj,esk_exe,esk_dyn); + + TElfSymtab = class(TElfObjSection) + public + kind: TElfSymtabKind; + fstrsec: TObjSection; + symidx: longint; + constructor create(aObjData:TObjData;aKind:TElfSymtabKind);reintroduce; + procedure writeSymbol(objsym:TObjSymbol); + procedure writeInternalSymbol(astridx:longint;ainfo:byte;ashndx:word); end; TElfObjData = class(TObjData) @@ -60,21 +71,12 @@ interface TElfObjectOutput = class(tObjOutput) private - symtabsect, - strtabsect, + symtabsect: TElfSymtab; shstrtabsect: TElfObjSection; - {gotpcsect, - gotoffsect, - goTSect, - plTSect, - symsect : TElfObjSection;} - symidx, - localsyms : longint; procedure createrelocsection(s:TElfObjSection;data:TObjData); procedure createshstrtab(data:TObjData); procedure createsymtab(data: TObjData); procedure writesectionheader(s:TElfObjSection); - procedure write_internal_symbol(astridx:longint;ainfo:byte;ashndx:word); procedure section_write_symbol(p:TObject;arg:pointer); procedure section_write_sh_string(p:TObject;arg:pointer); procedure section_count_sections(p:TObject;arg:pointer); @@ -123,56 +125,48 @@ implementation {$endif sparc} {$ifdef x86_64} R_X86_64_NONE = 0; - { Direct 64 bit } - R_X86_64_64 = 1; - { PC relative 32 bit signed } - R_X86_64_PC32 = 2; - { 32 bit GOT entry } - R_X86_64_GOT32 = 3; - { 32 bit PLT address } - R_X86_64_PLT32 = 4; - { Copy symbol at runtime } - R_X86_64_COPY = 5; - { Create GOT entry } - R_X86_64_GLOB_DAT = 6; - { Create PLT entry } - R_X86_64_JUMP_SLOT = 7; - { Adjust by program base } - R_X86_64_RELATIVE = 8; - { 32 bit signed PC relative offset to GOT } - R_X86_64_GOTPCREL = 9; - { Direct 32 bit zero extended } - R_X86_64_32 = 10; - { Direct 32 bit sign extended } - R_X86_64_32S = 11; - { Direct 16 bit zero extended } - R_X86_64_16 = 12; - { 16 bit sign extended PC relative } - R_X86_64_PC16 = 13; - { Direct 8 bit sign extended } - R_X86_64_8 = 14; - { 8 bit sign extended PC relative } - R_X86_64_PC8 = 15; - { ID of module containing symbol } - R_X86_64_DTPMOD64 = 16; - { Offset in module's TLS block } - R_X86_64_DTPOFF64 = 17; - { Offset in initial TLS block } - R_X86_64_TPOFF64 = 18; + R_X86_64_64 = 1; { Direct 64 bit } + R_X86_64_PC32 = 2; { PC relative 32 bit signed } + R_X86_64_GOT32 = 3; { 32 bit GOT entry } + R_X86_64_PLT32 = 4; { 32 bit PLT address } + R_X86_64_COPY = 5; { Copy symbol at runtime } + R_X86_64_GLOB_DAT = 6; { Create GOT entry } + R_X86_64_JUMP_SLOT = 7; { Create PLT entry } + R_X86_64_RELATIVE = 8; { Adjust by program base } + R_X86_64_GOTPCREL = 9; { 32 bit signed PC relative offset to GOT } + R_X86_64_32 = 10; { Direct 32 bit zero extended } + R_X86_64_32S = 11; { Direct 32 bit sign extended } + R_X86_64_16 = 12; { Direct 16 bit zero extended } + R_X86_64_PC16 = 13; { 16 bit sign extended PC relative } + R_X86_64_8 = 14; { Direct 8 bit sign extended } + R_X86_64_PC8 = 15; { 8 bit sign extended PC relative } + R_X86_64_DTPMOD64 = 16; { ID of module containing symbol } + R_X86_64_DTPOFF64 = 17; { Offset in module's TLS block } + R_X86_64_TPOFF64 = 18; { Offset in initial TLS block } { 32 bit signed PC relative offset to two GOT entries for GD symbol } R_X86_64_TLSGD = 19; { 32 bit signed PC relative offset to two GOT entries for LD symbol } R_X86_64_TLSLD = 20; - { Offset in TLS block } - R_X86_64_DTPOFF32 = 21; + R_X86_64_DTPOFF32 = 21; { Offset in TLS block } { 32 bit signed PC relative offset to GOT entry for IE symbol } R_X86_64_GOTTPOFF = 22; - { Offset in initial TLS block } - R_X86_64_TPOFF32 = 23; - { GNU extension to record C++ vtable hierarchy } - R_X86_64_GNU_VTINHERIT = 24; - { GNU extension to record C++ vtable member usage } - R_X86_64_GNU_VTENTRY = 25; + R_X86_64_TPOFF32 = 23; { Offset in initial TLS block } + R_X86_64_PC64 = 24; { PC relative 64-bit signed } + R_X86_64_GOTOFF64 = 25; { 64-bit offset from GOT base } + R_X86_64_GOTPC32 = 26; { PC-relative offset GOT } + R_X86_64_GOT64 = 27; { 64-bit GOT entry offset } + R_X86_64_GOTPCREL64 = 28; { 64-bit PC relative offset to GOT entry } + R_X86_64_GOTPC64 = 29; { 64-bit PC relative offset to GOT } + R_X86_64_GOTPLT64 = 30; { Like GOT64, indicates that PLT entry needed } + R_X86_64_PLTOFF64 = 31; { 64-bit GOT relative offset to PLT entry } + R_X86_64_SIZE32 = 32; + R_X86_64_SIZE64 = 33; + R_X86_64_GOTPC32_TLSDESC = 34; + R_X86_64_TLSDESC_CALL = 35; + R_X86_64_TLSDESC = 36; + R_X86_64_IRELATIVE = 37; + R_X86_64_GNU_VTINHERIT = 250; { GNU extension to record C++ vtable hierarchy } + R_X86_64_GNU_VTENTRY = 251; { GNU extension to record C++ vtable member usage } {$endif x86_64} { ELFHeader.file_class } @@ -245,6 +239,64 @@ implementation STT_SECTION = 3; STT_FILE = 4; + { program header types } + PT_NULL = 0; + PT_LOAD = 1; + PT_DYNAMIC = 2; + PT_INTERP = 3; + PT_NOTE = 4; + PT_SHLIB = 5; + PT_PHDR = 6; + PT_LOPROC = $70000000; + PT_HIPROC = $7FFFFFFF; + + { program header flags } + PF_X = 1; + PF_W = 2; + PF_R = 4; + PF_MASKPROC = $F0000000; + + { .dynamic tags } + DT_NULL = 0; + DT_NEEDED = 1; + DT_PLTRELSZ = 2; + DT_PLTGOT = 3; + DT_HASH = 4; + DT_STRTAB = 5; + DT_SYMTAB = 6; + DT_RELA = 7; + DT_RELASZ = 8; + DT_RELAENT = 9; + DT_STRSZ = 10; + DT_SYMENT = 11; + DT_INIT = 12; + DT_FINI = 13; + DT_SONAME = 14; + DT_RPATH = 15; + DT_SYMBOLIC = 16; + DT_REL = 17; + DT_RELSZ = 18; + DT_RELENT = 19; + DT_PLTREL = 20; + DT_DEBUG = 21; + DT_TEXTREL = 22; + DT_JMPREL = 23; + DT_BIND_NOW = 24; + DT_INIT_ARRAY = 25; + DT_FINI_ARRAY = 26; + DT_INIT_ARRAYSZ = 27; + DT_FINI_ARRAYSZ = 28; + DT_RUNPATH = 29; + DT_FLAGS = 30; + DT_ENCODING = 32; + DT_PREINIT_ARRAY = 32; + DT_PREINIT_ARRAYSZ = 33; + DT_NUM = 34; + DT_LOOS = $6000000D; + DT_HIOS = $6ffff000; + DT_LOPROC = $70000000; + DT_HIPROC = $7fffffff; + type { Structures which are written directly to the output file } TElf32header=packed record @@ -255,11 +307,11 @@ implementation padding : array[$07..$0f] of byte; e_type : word; e_machine : word; - e_version : longint; - e_entry : longint; { entrypoint } - e_phoff : longint; { program header offset } - e_shoff : longint; { sections header offset } - e_flags : longint; + e_version : longword; + e_entry : longword; { entrypoint } + e_phoff : longword; { program header offset } + e_shoff : longword; { sections header offset } + e_flags : longword; e_ehsize : word; { elf header size in bytes } e_phentsize : word; { size of an entry in the program header array } e_phnum : word; { 0..e_phnum-1 of entrys } @@ -268,16 +320,16 @@ implementation e_shstrndx : word; { index of string section header } end; TElf32sechdr=packed record - sh_name : longint; - sh_type : longint; - sh_flags : longint; - sh_addr : longint; - sh_offset : longint; - sh_size : longint; - sh_link : longint; - sh_info : longint; - sh_addralign : longint; - sh_entsize : longint; + sh_name : longword; + sh_type : longword; + sh_flags : longword; + sh_addr : longword; + sh_offset : longword; + sh_size : longword; + sh_link : longword; + sh_info : longword; + sh_addralign : longword; + sh_entsize : longword; end; TElf32proghdr=packed record p_type : longword; @@ -290,13 +342,14 @@ implementation p_align : longword; end; TElf32reloc=packed record - address : longint; - info : longint; { bit 0-7: type, 8-31: symbol } + address : longword; + info : longword; { bit 0-7: type, 8-31: symbol } + addend : longint; end; TElf32symbol=packed record - st_name : longint; - st_value : longint; - st_size : longint; + st_name : longword; + st_value : longword; + st_size : longword; st_info : byte; { bit 0-3: type, 4-7: bind } st_other : byte; st_shndx : word; @@ -317,11 +370,11 @@ implementation padding : array[$07..$0f] of byte; e_type : word; e_machine : word; - e_version : longint; + e_version : longword; e_entry : qword; { entrypoint } e_phoff : qword; { program header offset } e_shoff : qword; { sections header offset } - e_flags : longint; + e_flags : longword; e_ehsize : word; { elf header size in bytes } e_phentsize : word; { size of an entry in the program header array } e_phnum : word; { 0..e_phnum-1 of entrys } @@ -330,14 +383,14 @@ implementation e_shstrndx : word; { index of string section header } end; telf64sechdr=packed record - sh_name : longint; - sh_type : longint; + sh_name : longword; + sh_type : longword; sh_flags : qword; sh_addr : qword; sh_offset : qword; sh_size : qword; - sh_link : longint; - sh_info : longint; + sh_link : longword; + sh_info : longword; sh_addralign : qword; sh_entsize : qword; end; @@ -357,7 +410,7 @@ implementation addend : int64; { signed! } end; telf64symbol=packed record - st_name : longint; + st_name : longword; st_info : byte; { bit 0-3: type, 4-7: bind } st_other : byte; st_shndx : word; @@ -394,6 +447,13 @@ implementation telfdyn = telf32dyn; {$endif cpu64bitaddr} +{$ifdef x86_64} + const + relocs_use_addend:Boolean=True; +{$else x86_64} + const + relocs_use_addend:Boolean=False; +{$endif x86_64} procedure MayBeSwapHeader(var h : telf32header); begin @@ -544,6 +604,7 @@ implementation begin address:=swapendian(address); info:=swapendian(info); + addend:=swapendian(addend); end; end; @@ -615,13 +676,9 @@ implementation include(aoptions,oso_strings); { Section Flags } if Ashflags and SHF_ALLOC<>0 then - include(aoptions,oso_load) - else - include(aoptions,oso_noload); + include(aoptions,oso_load); if Ashflags and SHF_WRITE<>0 then - include(aoptions,oso_write) - else - include(aoptions,oso_readonly); + include(aoptions,oso_write); if Ashflags and SHF_EXECINSTR<>0 then include(aoptions,oso_executable); end; @@ -634,7 +691,7 @@ implementation constructor TElfObjSection.create(AList:TFPHashObjectList;const Aname:string;Aalign:shortint;Aoptions:TObjSectionOptions); begin inherited create(AList,Aname,Aalign,aoptions); - secshidx:=0; + index:=0; shstridx:=0; encodesechdrflags(aoptions,shtype,shflags); shlink:=0; @@ -644,13 +701,14 @@ implementation end; - constructor TElfObjSection.create_ext(AList:TFPHashObjectList;const Aname:string;Ashtype,Ashflags,Ashlink,Ashinfo:longint;Aalign:shortint;Aentsize:longint); + constructor TElfObjSection.create_ext(aobjdata:TObjData;const Aname:string;Ashtype,Ashflags,Ashlink,Ashinfo:longint;Aalign:shortint;Aentsize:longint); var aoptions : TObjSectionOptions; begin decodesechdrflags(Ashtype,Ashflags,aoptions); - inherited create(AList,Aname,Aalign,aoptions); - secshidx:=0; + inherited create(aobjdata.ObjSectionList,Aname,Aalign,aoptions); + objdata:=aobjdata; + index:=0; shstridx:=0; shtype:=AshType; shflags:=AshFlags; @@ -671,7 +729,7 @@ implementation { we need at least the following sections } createsection(sec_code); { always a non-PIC data section (will remain empty if doing PIC) } - createsection('.data',sizeof(pint),sectiontype2options(sec_data)); + createsection('.data',sectiontype2align(sec_data),sectiontype2options(sec_data)); createsection(sec_bss); if (cs_create_pic in current_settings.moduleswitches) and not(target_info.system in systems_darwin) then @@ -848,24 +906,18 @@ implementation procedure TElfObjData.writereloc(data:aint;len:aword;p:TObjSymbol;reltype:TObjRelocationType); var symaddr : aint; + objreloc: TObjRelocation; begin if CurrObjSec=nil then internalerror(200403292); -{$ifdef userodata} - if CurrObjSec.sectype in [sec_rodata,sec_bss,sec_threadvar] then - internalerror(200408252); -{$endif userodata} - { Using RELOC_RVA to map 32-bit RELOC_ABSOLUTE to R_X86_64_32 - (RELOC_ABSOLUTE maps to R_X86_64_32S) } - if (reltype=RELOC_ABSOLUTE) and (len<>sizeof(pint)) then - reltype:=RELOC_RVA; + objreloc:=nil; if assigned(p) then begin { real address of the symbol } symaddr:=p.address; { Local ObjSymbols can be resolved already or need a section reloc } if (p.bind=AB_LOCAL) and - (reltype in [RELOC_RELATIVE,RELOC_ABSOLUTE{$ifdef x86_64},RELOC_ABSOLUTE32,RELOC_RVA{$endif x86_64}]) then + (reltype in [RELOC_RELATIVE,RELOC_ABSOLUTE{$ifdef x86_64},RELOC_ABSOLUTE32{$endif x86_64}]) then begin { For a reltype relocation in the same section the value can be calculated } @@ -874,24 +926,140 @@ implementation inc(data,symaddr-len-CurrObjSec.Size) else begin - CurrObjSec.addsectionreloc(CurrObjSec.Size,p.objsection,reltype); + objreloc:=TObjRelocation.CreateSection(CurrObjSec.Size,p.objsection,reltype); + CurrObjSec.ObjRelocations.Add(objreloc); inc(data,symaddr); end; end else begin - CurrObjSec.addsymreloc(CurrObjSec.Size,p,reltype); -{$ifndef x86_64} - if (reltype=RELOC_RELATIVE) or (reltype=RELOC_PLT32) then - dec(data,len); -{$endif x86_64} + objreloc:=TObjRelocation.CreateSymbol(CurrObjSec.Size,p,reltype); + CurrObjSec.ObjRelocations.Add(objreloc); + { If target is a local label and it isn't handled above, + patch its type in order to get it written to symtable. + This may happen e.g. when taking address of Pascal label in PIC mode. } + if (p.bind=AB_LOCAL) and (p.typ=AT_LABEL) then + p.typ:=AT_ADDR; end; end; + if assigned(objreloc) then + begin + objreloc.size:=len; + if reltype in [RELOC_RELATIVE,RELOC_PLT32{$ifdef x86_64},RELOC_GOTPCREL{$endif}] then + dec(data,len); + if relocs_use_addend then + begin + objreloc.orgsize:=data; + data:=0; + end; + end; CurrObjSec.write(data,len); end; {**************************************************************************** + TElfSymtab +****************************************************************************} + + const + symsecnames: array[boolean] of string[8] = ('.symtab','.dynsym'); + strsecnames: array[boolean] of string[8] = ('.strtab','.dynstr'); + symsectypes: array[boolean] of longint = (SHT_SYMTAB,SHT_DYNSYM); + symsecattrs: array[boolean] of longint = (0,SHF_ALLOC); + + + constructor TElfSymtab.create(aObjData:TObjData;aKind:TElfSymtabKind); + var + dyn:boolean; + begin + dyn:=(aKind=esk_dyn); + create_ext(aObjData,symsecnames[dyn],symsectypes[dyn],symsecattrs[dyn],0,0,sizeof(pint),sizeof(TElfSymbol)); + fstrsec:=TElfObjSection.create_ext(aObjData,strsecnames[dyn],SHT_STRTAB,symsecattrs[dyn],0,0,1,0); + fstrsec.writestr(#0); + writezeros(sizeof(TElfSymbol)); + symidx:=1; + shinfo:=1; + kind:=aKind; + end; + + procedure TElfSymtab.writeInternalSymbol(astridx:longint;ainfo:byte;ashndx:word); + var + elfsym:TElfSymbol; + begin + fillchar(elfsym,sizeof(elfsym),0); + elfsym.st_name:=astridx; + elfsym.st_info:=ainfo; + elfsym.st_shndx:=ashndx; + inc(symidx); + inc(shinfo); + MaybeSwapElfSymbol(elfsym); + write(elfsym,sizeof(elfsym)); + end; + + procedure TElfSymtab.writeSymbol(objsym:TObjSymbol); + var + elfsym:TElfSymbol; + begin + fillchar(elfsym,sizeof(elfsym),0); + { symbolname, write the #0 separate to overcome 255+1 char not possible } + elfsym.st_name:=fstrsec.writestr(objsym.name); + fstrsec.writestr(#0); + elfsym.st_size:=objsym.size; + case objsym.bind of + AB_LOCAL : + begin + elfsym.st_value:=objsym.address; + elfsym.st_info:=STB_LOCAL shl 4; + inc(shinfo); + end; + AB_COMMON : + begin + elfsym.st_value:=$10; { ?? should not be hardcoded } + elfsym.st_info:=STB_GLOBAL shl 4; + elfsym.st_shndx:=SHN_COMMON; + end; + AB_EXTERNAL : + elfsym.st_info:=STB_GLOBAL shl 4; + AB_WEAK_EXTERNAL : + elfsym.st_info:=STB_WEAK shl 4; + AB_GLOBAL : + begin + elfsym.st_value:=objsym.address; + elfsym.st_info:=STB_GLOBAL shl 4; + end; + end; + if (objsym.bind<>AB_EXTERNAL) {and + not(assigned(objsym.objsection) and + not(oso_data in objsym.objsection.secoptions))} then + begin + case objsym.typ of + AT_FUNCTION : + elfsym.st_info:=elfsym.st_info or STT_FUNC; + AT_DATA : + elfsym.st_info:=elfsym.st_info or STT_OBJECT; + end; + end; + if objsym.bind<>AB_COMMON then + begin + if kind<>esk_obj then + begin + { TODO } + end + else + begin + if assigned(objsym.objsection) then + elfsym.st_shndx:=objsym.objsection.index + else + elfsym.st_shndx:=SHN_UNDEF; + objsym.symidx:=symidx; + end; + end; + inc(symidx); + MaybeSwapElfSymbol(elfsym); + write(elfsym,sizeof(TElfSymbol)); + end; + +{**************************************************************************** TElfObjectOutput ****************************************************************************} @@ -909,35 +1077,22 @@ implementation objreloc : TObjRelocation; relsym, reltyp : longint; - relocsect : TObjSection; -{$ifdef x86_64} - tmp: aint; - asize: longint; -{$endif x86_64} + relocsect : TElfObjSection; begin with data do begin -{$ifdef userodata} - { rodata can't have relocations } - if s.sectype=sec_rodata then - begin - if assigned(s.relocations.first) then - internalerror(200408251); - exit; - end; -{$endif userodata} { create the reloc section } -{$ifdef i386} - relocsect:=TElfObjSection.create_ext(ObjSectionList,'.rel'+s.name,SHT_REL,0,symtabsect.secshidx,s.secshidx,4,sizeof(TElfReloc)); -{$else i386} - relocsect:=TElfObjSection.create_ext(ObjSectionList,'.rela'+s.name,SHT_RELA,0,symtabsect.secshidx,s.secshidx,4,sizeof(TElfReloc)); -{$endif i386} + if relocs_use_addend then + relocsect:=TElfObjSection.create_ext(data,'.rela'+s.name,SHT_RELA,0,symtabsect.index,s.index,4,3*sizeof(pint)) + else + relocsect:=TElfObjSection.create_ext(data,'.rel'+s.name,SHT_REL,0,symtabsect.index,s.index,4,2*sizeof(pint)); { add the relocations } for i:=0 to s.Objrelocations.count-1 do begin objreloc:=TObjRelocation(s.Objrelocations[i]); fillchar(rel,sizeof(rel),0); rel.address:=objreloc.dataoffset; + rel.addend:=objreloc.orgsize; { when things settle down, we can create processor specific derived classes } @@ -952,67 +1107,40 @@ implementation RELOC_GOTPC : reltyp:=R_386_GOTPC; RELOC_PLT32 : - begin - reltyp:=R_386_PLT32; - end; + reltyp:=R_386_PLT32; {$endif i386} {$ifdef sparc} RELOC_ABSOLUTE : reltyp:=R_SPARC_32; {$endif sparc} {$ifdef x86_64} + { Note: 8 and 16-bit relocations are known to be non-conformant with + AMD64 ABI, so they aren't handled. } RELOC_RELATIVE : - begin - reltyp:=R_X86_64_PC32; - { length of the relocated location is handled here } - rel.addend:=-4; - end; + if objreloc.size=8 then + reltyp:=R_X86_64_PC64 + else if objreloc.size=4 then + reltyp:=R_X86_64_PC32 + else + InternalError(2012061900); RELOC_ABSOLUTE : - reltyp:=R_X86_64_64; + if objreloc.size=8 then + reltyp:=R_X86_64_64 + else if objreloc.size=4 then + reltyp:=R_X86_64_32 + else + InternalError(2012061901); RELOC_ABSOLUTE32 : reltyp:=R_X86_64_32S; - RELOC_RVA : - reltyp:=R_X86_64_32; RELOC_GOTPCREL : - begin - reltyp:=R_X86_64_GOTPCREL; - { length of the relocated location is handled here } - rel.addend:=-4; - end; + reltyp:=R_X86_64_GOTPCREL; RELOC_PLT32 : - begin - reltyp:=R_X86_64_PLT32; - { length of the relocated location is handled here } - rel.addend:=-4; - end; + reltyp:=R_X86_64_PLT32; {$endif x86_64} else internalerror(200602261); end; -{ This handles ELF 'rela'-styled relocations, which are currently used only for x86_64, - but can be used other targets, too. } -{$ifdef x86_64} - s.Data.Seek(objreloc.dataoffset); - if objreloc.typ=RELOC_ABSOLUTE then - begin - asize:=8; - s.Data.Read(tmp,8); - rel.addend:=rel.addend+tmp; - end - else - begin - asize:=4; - s.Data.Read(tmp,4); - rel.addend:=rel.addend+longint(tmp); - end; - - { and zero the data member out } - tmp:=0; - s.Data.Seek(objreloc.dataoffset); - s.Data.Write(tmp,asize); -{$endif} - { Symbol } if assigned(objreloc.symbol) then begin @@ -1036,107 +1164,34 @@ implementation rel.info:=(relsym shl 8) or reltyp; {$endif cpu64bitaddr} { write reloc } + { ElfXX_Rel is essentially ElfXX_Rela without the addend field. } MaybeSwapElfReloc(rel); - relocsect.write(rel,sizeof(rel)); + relocsect.write(rel,relocsect.shentsize); end; end; end; - procedure TElfObjectOutput.write_internal_symbol(astridx:longint;ainfo:byte;ashndx:word); - var - elfsym : telfsymbol; - begin - fillchar(elfsym,sizeof(elfsym),0); - elfsym.st_name:=astridx; - elfsym.st_info:=ainfo; - elfsym.st_shndx:=ashndx; - inc(symidx); - inc(localsyms); - MaybeSwapElfSymbol(elfsym); - symtabsect.write(elfsym,sizeof(elfsym)); - end; - - procedure TElfObjectOutput.section_write_symbol(p:TObject;arg:pointer); begin - TObjSection(p).secsymidx:=symidx; - write_internal_symbol(0,STT_SECTION,TElfObjSection(p).secshidx); + { Must not write symbols for internal sections like .symtab } + { TODO: maybe use inclusive list of section types instead } + if (TElfObjSection(p).shtype in [SHT_SYMTAB,SHT_STRTAB,SHT_REL,SHT_RELA]) then + exit; + TObjSection(p).secsymidx:=symtabsect.symidx; + symtabsect.writeInternalSymbol(0,STT_SECTION,TObjSection(p).index); end; procedure TElfObjectOutput.createsymtab(data: TObjData); - - procedure WriteSym(objsym:TObjSymbol); - var - elfsym : telfsymbol; - begin - fillchar(elfsym,sizeof(elfsym),0); - { symbolname, write the #0 separate to overcome 255+1 char not possible } - elfsym.st_name:=strtabsect.Size; - strtabsect.writestr(objsym.name); - strtabsect.writestr(#0); - elfsym.st_size:=objsym.size; - case objsym.bind of - AB_LOCAL : - begin - elfsym.st_value:=objsym.address; - elfsym.st_info:=STB_LOCAL shl 4; - inc(localsyms); - end; - AB_COMMON : - begin - elfsym.st_value:=$10; - elfsym.st_info:=STB_GLOBAL shl 4; - end; - AB_EXTERNAL : - elfsym.st_info:=STB_GLOBAL shl 4; - AB_WEAK_EXTERNAL : - elfsym.st_info:=STB_WEAK shl 4; - AB_GLOBAL : - begin - elfsym.st_value:=objsym.address; - elfsym.st_info:=STB_GLOBAL shl 4; - end; - end; - if (objsym.bind<>AB_EXTERNAL) {and - not(assigned(objsym.objsection) and - not(oso_data in objsym.objsection.secoptions))} then - begin - case objsym.typ of - AT_FUNCTION : - elfsym.st_info:=elfsym.st_info or STT_FUNC; - AT_DATA : - elfsym.st_info:=elfsym.st_info or STT_OBJECT; - end; - end; - if objsym.bind=AB_COMMON then - elfsym.st_shndx:=SHN_COMMON - else - begin - if assigned(objsym.objsection) then - elfsym.st_shndx:=TElfObjSection(objsym.objsection).secshidx - else - elfsym.st_shndx:=SHN_UNDEF; - end; - objsym.symidx:=symidx; - inc(symidx); - MaybeSwapElfSymbol(elfsym); - symtabsect.write(elfsym,sizeof(elfsym)); - end; - var i : longint; objsym : TObjSymbol; begin with data do begin - symidx:=0; - localsyms:=0; - { empty entry } - write_internal_symbol(0,0,0); { filename entry } - write_internal_symbol(1,STT_FILE,SHN_ABS); + symtabsect.writeInternalSymbol(1,STT_FILE,SHN_ABS); { section } ObjSectionList.ForEachCall(@section_write_symbol,nil); { First the Local Symbols, this is required by ELF. The localsyms @@ -1146,18 +1201,17 @@ implementation begin objsym:=TObjSymbol(ObjSymbolList[i]); if (objsym.bind=AB_LOCAL) and (objsym.typ<>AT_LABEL) then - WriteSym(objsym); + symtabsect.WriteSymbol(objsym); end; { Global Symbols } for i:=0 to ObjSymbolList.Count-1 do begin objsym:=TObjSymbol(ObjSymbolList[i]); if (objsym.bind<>AB_LOCAL) then - WriteSym(objsym); + symtabsect.WriteSymbol(objsym); end; { update the .symtab section header } - symtabsect.shlink:=strtabsect.secshidx; - symtabsect.shinfo:=localsyms; + symtabsect.shlink:=symtabsect.fstrsec.index; end; end; @@ -1199,7 +1253,7 @@ implementation procedure TElfObjectOutput.section_count_sections(p:TObject;arg:pointer); begin - TElfObjSection(p).secshidx:=pword(arg)^; + TElfObjSection(p).index:=pword(arg)^; inc(pword(arg)^); end; @@ -1228,16 +1282,15 @@ implementation with data do begin { default sections } - symtabsect:=TElfObjSection.create_ext(ObjSectionList,'.symtab',SHT_SYMTAB,0,0,0,4,sizeof(telfsymbol)); - strtabsect:=TElfObjSection.create_ext(ObjSectionList,'.strtab',SHT_STRTAB,0,0,0,1,0); - shstrtabsect:=TElfObjSection.create_ext(ObjSectionList,'.shstrtab',SHT_STRTAB,0,0,0,1,0); + symtabsect:=TElfSymtab.create(data,esk_obj); + shstrtabsect:=TElfObjSection.create_ext(data,'.shstrtab',SHT_STRTAB,0,0,0,1,0); { "no executable stack" marker for Linux } if (target_info.system in systems_linux) and not(cs_executable_stack in current_settings.moduleswitches) then - TElfObjSection.create_ext(ObjSectionList,'.note.GNU-stack',SHT_PROGBITS,0,0,0,1,0); - { insert the empty and filename as first in strtab } - strtabsect.writestr(#0); - strtabsect.writestr(ExtractFileName(current_module.mainsource)+#0); + TElfObjSection.create_ext(data,'.note.GNU-stack',SHT_PROGBITS,0,0,0,1,0); + { insert filename as first in strtab } + symtabsect.fstrsec.writestr(ExtractFileName(current_module.mainsource)); + symtabsect.fstrsec.writestr(#0); { calc amount of sections we have } nsections:=1; { also create the index in the section header table } @@ -1276,12 +1329,12 @@ implementation header.e_type:=ET_REL; header.e_machine:=ELFMACHINE; {$ifdef arm} - if (current_settings.fputype=cpu_soft) then + if (current_settings.fputype=fpu_soft) then header.e_flags:=$600; {$endif arm} header.e_version:=1; header.e_shoff:=shoffset; - header.e_shstrndx:=shstrtabsect.secshidx; + header.e_shstrndx:=shstrtabsect.index; header.e_shnum:=nsections; header.e_ehsize:=sizeof(telfheader); diff --git a/mips/compiler/options.pas b/mips/compiler/options.pas index 5392c76882..b277d8352b 100644 --- a/mips/compiler/options.pas +++ b/mips/compiler/options.pas @@ -2746,7 +2746,7 @@ begin def_system_macro('FPC_STATICRIPFIXED'); def_system_macro('FPC_VARIANTCOPY_FIXED'); def_system_macro('FPC_DYNARRAYCOPY_FIXED'); -{$if defined(x86) or defined(powerpc) or defined(powerpc64)} +{$if defined(x86) or defined(powerpc) or defined(powerpc64) or defined(cpuarm)} def_system_macro('FPC_HAS_INTERNAL_ABS_LONG'); {$endif} def_system_macro('FPC_HAS_UNICODESTRING'); @@ -2887,8 +2887,12 @@ begin def_system_macro('CPUMIPSEL'); def_system_macro('CPUMIPSEL32'); def_system_macro('CPU32'); + def_system_macro('FPC_HAS_TYPE_DOUBLE'); + def_system_macro('FPC_HAS_TYPE_SINGLE'); + def_system_macro('FPC_INCLUDE_SOFTWARE_INT64_TO_DOUBLE'); def_system_macro('FPC_CURRENCY_IS_INT64'); def_system_macro('FPC_COMP_IS_INT64'); + def_system_macro('FPC_REQUIRES_PROPER_ALIGNMENT'); {$endif mipsel} {$ifdef mipseb} @@ -2897,8 +2901,12 @@ begin def_system_macro('CPUMIPSEB'); def_system_macro('CPUMIPSEB32'); def_system_macro('CPU32'); + def_system_macro('FPC_HAS_TYPE_DOUBLE'); + def_system_macro('FPC_HAS_TYPE_SINGLE'); + def_system_macro('FPC_INCLUDE_SOFTWARE_INT64_TO_DOUBLE'); def_system_macro('FPC_CURRENCY_IS_INT64'); def_system_macro('FPC_COMP_IS_INT64'); + def_system_macro('FPC_REQUIRES_PROPER_ALIGNMENT'); {$endif} { read configuration file } diff --git a/mips/compiler/paramgr.pas b/mips/compiler/paramgr.pas index 1f6c59ac9c..04cd690fc0 100644 --- a/mips/compiler/paramgr.pas +++ b/mips/compiler/paramgr.pas @@ -81,7 +81,7 @@ unit paramgr; function get_volatile_registers_flags(calloption : tproccalloption):tcpuregisterset;virtual; function get_volatile_registers_mm(calloption : tproccalloption):tcpuregisterset;virtual; - procedure getintparaloc(calloption : tproccalloption; nr : longint;var cgpara:TCGPara);virtual;abstract; + procedure getintparaloc(calloption : tproccalloption; nr : longint; def: tdef; var cgpara : tcgpara);virtual;abstract; {# allocate an individual pcgparalocation that's part of a tcgpara @@ -140,6 +140,10 @@ unit paramgr; function use_fixed_stack: boolean; { whether stack pointer can be changed in the middle of procedure } function use_stackalloc: boolean; + strict protected + { common part of get_funcretloc; returns true if retloc is completely + initialized afterwards } + function set_common_funcretloc_info(p : tabstractprocdef; def: tdef; out retcgsize: tcgsize; out retloc: tcgpara): boolean; end; @@ -492,6 +496,54 @@ implementation result:=not use_fixed_stack; end; + + function tparamanager.set_common_funcretloc_info(p : tabstractprocdef; def: tdef; out retcgsize: tcgsize; out retloc: tcgpara): boolean; + var + paraloc : pcgparalocation; + begin + result:=true; + retloc.init; + retloc.def:=def; + retloc.alignment:=get_para_align(p.proccalloption); + { void has no location } + if is_void(def) then + begin + paraloc:=retloc.add_location; + retloc.size:=OS_NO; + retcgsize:=OS_NO; + retloc.intsize:=0; + paraloc^.size:=OS_NO; + paraloc^.loc:=LOC_VOID; + exit; + end; + { Constructors return self instead of a boolean } + if p.proctypeoption=potype_constructor then + begin + if is_implicit_pointer_object_type(tdef(p.owner.defowner)) then + retloc.def:=tdef(p.owner.defowner) + else + retloc.def:=getpointerdef(tdef(p.owner.defowner)); + retcgsize:=OS_ADDR; + retloc.intsize:=sizeof(pint); + end + else + begin + retcgsize:=def_cgsize(def); + retloc.intsize:=def.size; + end; + retloc.size:=retcgsize; + { Return is passed as var parameter } + if ret_in_param(def,p.proccalloption) then + begin + retloc.def:=getpointerdef(def); + paraloc:=retloc.add_location; + paraloc^.loc:=LOC_REFERENCE; + paraloc^.size:=retcgsize; + exit; + end; + result:=false; + end; + initialization ; finalization diff --git a/mips/compiler/pdecobj.pas b/mips/compiler/pdecobj.pas index 535f810c9a..f284fda740 100644 --- a/mips/compiler/pdecobj.pas +++ b/mips/compiler/pdecobj.pas @@ -133,16 +133,20 @@ implementation consume(_SEMICOLON); include(current_structdef.objectoptions,oo_has_constructor); { Set return type, class and record constructors return the - created instance, object constructors return boolean } + created instance, helper types return the extended type, + object constructors return boolean } if is_class(pd.struct) or is_record(pd.struct) or is_javaclass(pd.struct) then pd.returndef:=pd.struct else + if is_objectpascal_helper(pd.struct) then + pd.returndef:=tobjectdef(pd.struct).extendeddef + else {$ifdef CPU64bitaddr} - pd.returndef:=bool64type; + pd.returndef:=bool64type; {$else CPU64bitaddr} - pd.returndef:=bool32type; + pd.returndef:=bool32type; {$endif CPU64bitaddr} constr_destr_finish_head(pd,pd.struct); result:=pd; @@ -1405,6 +1409,10 @@ implementation include(current_structdef.defoptions, df_generic); parse_generic:=(df_generic in current_structdef.defoptions); + { in non-Delphi modes we need a strict private symbol without type + count and type parameters in the name to simply resolving } + maybe_insert_generic_rename_symbol(n,genericlist); + { parse list of parent classes } { for record helpers in mode Delphi this is not allowed } if not (is_objectpascal_helper(current_objectdef) and diff --git a/mips/compiler/pdecsub.pas b/mips/compiler/pdecsub.pas index cc541b16b6..73ad84b958 100644 --- a/mips/compiler/pdecsub.pas +++ b/mips/compiler/pdecsub.pas @@ -106,7 +106,7 @@ implementation objcutil, { parser } scanner, - pbase,pexpr,ptype,pdecl,pparautl + pbase,pexpr,ptype,pdecl,pparautl,pgenutil {$ifdef jvm} ,pjvm {$endif} @@ -387,7 +387,7 @@ implementation if is_shortstring(hdef) then begin case varspez of - vs_var,vs_out,vs_constref: + vs_var,vs_out: begin { not 100% Delphi-compatible: type xstr=string[255] cannot become an openstring there, while here it can } @@ -680,8 +680,44 @@ implementation Message1(type_e_generic_declaration_does_not_match,genname); srsym:=nil; exit; + end + end; + end; + + procedure consume_generic_interface; + var + genparalist : tfpobjectlist; + prettyname, + specializename : ansistring; + genname, + ugenname : tidstring; + gencount : string; + begin + consume(_LSHARPBRACKET); + genparalist:=tfpobjectlist.create(false); + + if not parse_generic_specialization_types(genparalist,prettyname,specializename,nil) then + srsym:=generrorsym + else + begin + str(genparalist.count,gencount); + genname:=sp+'$'+gencount; + if not parse_generic then + genname:=generate_generic_name(genname,specializename); + ugenname:=upper(genname); + + srsym:=search_object_name(ugenname,false); + + if not assigned(srsym) then + begin + Message1(type_e_generic_declaration_does_not_match,sp+'<'+prettyname+'>'); + srsym:=nil; + exit; end; end; + + genparalist.free; + consume(_RSHARPBRACKET); end; begin @@ -700,16 +736,35 @@ implementation (astruct.typ=objectdef) and assigned(tobjectdef(astruct).ImplementedInterfaces) and (tobjectdef(astruct).ImplementedInterfaces.count>0) and - try_to_consume(_POINT) then + ( + (token = _POINT) or + (token = _LSHARPBRACKET) + ) then begin - srsym:=search_object_name(sp,true); + if token = _POINT then + begin + consume(_POINT); + srsym:=search_object_name(sp,true); + end + else + begin + consume_generic_interface; + consume(_POINT); + { srsym is now either an interface def or generrordef } + end; { qualifier is interface? } ImplIntf:=nil; if (srsym.typ=typesym) and (ttypesym(srsym).typedef.typ=objectdef) then ImplIntf:=tobjectdef(astruct).find_implemented_interface(tobjectdef(ttypesym(srsym).typedef)); if ImplIntf=nil then - Message(parser_e_interface_id_expected); + Message(parser_e_interface_id_expected) + else + { in case of a generic or specialized interface we need to use the + name of the def instead of the symbol, so that always the correct + name is used } + if [df_generic,df_specialization]*ttypesym(srsym).typedef.defoptions<>[] then + sp:=tobjectdef(ttypesym(srsym).typedef).objname^; { must be a directly implemented interface } if Assigned(ImplIntf.ImplementsGetter) then Message2(parser_e_implements_no_mapping,ImplIntf.IntfDef.typename,astruct.objrealname^); @@ -1107,10 +1162,13 @@ implementation is_javaclass(pd.struct) then pd.returndef:=pd.struct else + if is_objectpascal_helper(pd.struct) then + pd.returndef:=tobjectdef(pd.struct).extendeddef + else {$ifdef CPU64bitaddr} - pd.returndef:=bool64type; + pd.returndef:=bool64type; {$else CPU64bitaddr} - pd.returndef:=bool32type; + pd.returndef:=bool32type; {$endif CPU64bitaddr} end else diff --git a/mips/compiler/pexpr.pas b/mips/compiler/pexpr.pas index 78fae9233d..520428b5ff 100644 --- a/mips/compiler/pexpr.pas +++ b/mips/compiler/pexpr.pas @@ -2199,10 +2199,7 @@ implementation ( (token=_LKLAMMER) or ( - ( - (m_tp7 in current_settings.modeswitches) or - (m_delphi in current_settings.modeswitches) - ) and + (([m_tp7,m_delphi,m_mac] * current_settings.modeswitches) <> []) and (afterassignment or in_args) ) ) then diff --git a/mips/compiler/pgenutil.pas b/mips/compiler/pgenutil.pas index 02055054ea..215b7f1be7 100644 --- a/mips/compiler/pgenutil.pas +++ b/mips/compiler/pgenutil.pas @@ -29,12 +29,17 @@ interface uses { common } cclasses, + { global } + globtype, { symtable } symtype,symdef,symbase; procedure generate_specialization(var tt:tdef;parse_class_parent:boolean;_prettyname:string;parsedtype:tdef;symname:string); function parse_generic_parameters:TFPObjectList; + function parse_generic_specialization_types(genericdeflist:tfpobjectlist;out prettyname,specializename:ansistring;parsedtype:tdef):boolean; procedure insert_generic_parameter_types(def:tstoreddef;genericdef:tstoreddef;genericlist:TFPObjectList); + procedure maybe_insert_generic_rename_symbol(const name:tidstring;genericlist:tfpobjectlist); + function generate_generic_name(const name:tidstring;specializename:ansistring):tidstring; type tspecializationstate = record @@ -51,7 +56,7 @@ uses { common } cutils,fpccrc, { global } - globals,globtype,tokens,verbose, + globals,tokens,verbose, { symtable } symconst,symsym,symtable, { modules } @@ -187,59 +192,7 @@ uses genericdeflist:=TFPObjectList.Create(false); { Parse type parameters } - err:=false; - { set the block type to type, so that the parsed type are returned as - ttypenode (e.g. classes are in non type-compatible blocks returned as - tloadvmtaddrnode) } - old_block_type:=block_type; - { if parsedtype is set, then the first type identifer was already parsed - (happens in inline specializations) and thus we only need to parse - the remaining types and do as if the first one was already given } - first:=not assigned(parsedtype); - if assigned(parsedtype) then - begin - genericdeflist.Add(parsedtype); - specializename:='$'+parsedtype.typename; - prettyname:=parsedtype.typesym.prettyname; - end - else - begin - specializename:=''; - prettyname:=''; - end; - while not (token in [_GT,_RSHARPBRACKET]) do - begin - { "first" is set to false at the end of the loop! } - if not first then - consume(_COMMA); - block_type:=bt_type; - pt2:=factor(false,true); - if pt2.nodetype=typen then - begin - if df_generic in pt2.resultdef.defoptions then - Message(parser_e_no_generics_as_params); - genericdeflist.Add(pt2.resultdef); - if not assigned(pt2.resultdef.typesym) then - message(type_e_generics_cannot_reference_itself) - else - begin - specializename:=specializename+'$'+pt2.resultdef.typename; - if first then - prettyname:=prettyname+pt2.resultdef.typesym.prettyname - else - prettyname:=prettyname+','+pt2.resultdef.typesym.prettyname; - end; - end - else - begin - Message(type_e_type_id_expected); - err:=true; - end; - pt2.free; - first:=false; - end; - block_type:=old_block_type; - + err:=not parse_generic_specialization_types(genericdeflist,prettyname,specializename,parsedtype); if err then begin try_to_consume(_RSHARPBRACKET); @@ -257,7 +210,8 @@ uses genname:=symname; { in case of non-Delphi mode the type name could already be a generic def (but maybe the wrong one) } - if assigned(genericdef) and (df_generic in genericdef.defoptions) then + if assigned(genericdef) and + ([df_generic,df_specialization]*genericdef.defoptions<>[]) then begin { remove the type count suffix from the generic's name } for i:=Length(genname) downto 1 do @@ -266,6 +220,15 @@ uses genname:=copy(genname,1,i-1); break; end; + { in case of a specialization we've only reached the specialization + checksum yet } + if df_specialization in genericdef.defoptions then + for i:=length(genname) downto 1 do + if genname[i]='$' then + begin + genname:=copy(genname,1,i-1); + break; + end; end; genname:=genname+'$'+countstr; ugenname:=upper(genname); @@ -292,8 +255,7 @@ uses genericdef:=tstoreddef(ttypesym(srsym).typedef); { build the new type's name } - crc:=UpdateCrc32(0,specializename[1],length(specializename)); - finalspecializename:=genname+'$crc'+hexstr(crc,8); + finalspecializename:=generate_generic_name(genname,specializename); ufinalspecializename:=upper(finalspecializename); prettyname:=genericdef.typesym.prettyname+'<'+prettyname+'>'; @@ -557,6 +519,67 @@ uses until not try_to_consume(_COMMA) ; end; + function parse_generic_specialization_types(genericdeflist:tfpobjectlist;out prettyname,specializename:ansistring;parsedtype:tdef):boolean; + var + old_block_type : tblock_type; + first : boolean; + typeparam : tnode; + begin + result:=true; + if genericdeflist=nil then + internalerror(2012061401); + { set the block type to type, so that the parsed type are returned as + ttypenode (e.g. classes are in non type-compatible blocks returned as + tloadvmtaddrnode) } + old_block_type:=block_type; + { if parsedtype is set, then the first type identifer was already parsed + (happens in inline specializations) and thus we only need to parse + the remaining types and do as if the first one was already given } + first:=not assigned(parsedtype); + if assigned(parsedtype) then + begin + genericdeflist.Add(parsedtype); + specializename:='$'+parsedtype.typename; + prettyname:=parsedtype.typesym.prettyname; + end + else + begin + specializename:=''; + prettyname:=''; + end; + while not (token in [_GT,_RSHARPBRACKET]) do + begin + { "first" is set to false at the end of the loop! } + if not first then + consume(_COMMA); + block_type:=bt_type; + typeparam:=factor(false,true); + if typeparam.nodetype=typen then + begin + if df_generic in typeparam.resultdef.defoptions then + Message(parser_e_no_generics_as_params); + genericdeflist.Add(typeparam.resultdef); + if not assigned(typeparam.resultdef.typesym) then + message(type_e_generics_cannot_reference_itself) + else + begin + specializename:=specializename+'$'+typeparam.resultdef.typename; + if first then + prettyname:=prettyname+typeparam.resultdef.typesym.prettyname + else + prettyname:=prettyname+','+typeparam.resultdef.typesym.prettyname; + end; + end + else + begin + Message(type_e_type_id_expected); + result:=false; + end; + typeparam.free; + first:=false; + end; + block_type:=old_block_type; + end; procedure insert_generic_parameter_types(def:tstoreddef;genericdef:tstoreddef;genericlist:TFPObjectList); var @@ -587,6 +610,51 @@ uses end; end; + procedure maybe_insert_generic_rename_symbol(const name:tidstring;genericlist:tfpobjectlist); + var + gensym : ttypesym; + begin + { for generics in non-Delphi modes we insert a private type symbol + that has the same base name as the currently parsed generic and + that references this defs } + if not (m_delphi in current_settings.modeswitches) and + ( + ( + parse_generic and + assigned(genericlist) and + (genericlist.count>0) + ) or + ( + assigned(current_specializedef) and + assigned(current_structdef.genericdef) and + (current_structdef.genericdef.typ in [objectdef,recorddef]) and + (pos('$',name)>0) + ) + ) then + begin + { we need to pass nil as def here, because the constructor wants + to set the typesym of the def which is not what we want } + gensym:=ttypesym.create(copy(name,1,pos('$',name)-1),nil); + gensym.typedef:=current_structdef; + include(gensym.symoptions,sp_internal); + { the symbol should be only visible to the generic class + itself } + gensym.visibility:=vis_strictprivate; + symtablestack.top.insert(gensym); + end; + end; + + function generate_generic_name(const name:tidstring;specializename:ansistring):tidstring; + var + crc : cardinal; + begin + if specializename='' then + internalerror(2012061901); + { build the new type's name } + crc:=UpdateCrc32(0,specializename[1],length(specializename)); + result:=name+'$crc'+hexstr(crc,8); + end; + procedure specialization_init(genericdef:tdef;var state: tspecializationstate); var pu : tused_unit; @@ -617,10 +685,18 @@ uses if sym.typ=unitsym then unitsyms.add(upper(sym.realname),sym); end; - { add all interface units to the new symtable stack } + { add all units if we are specializing inside the current unit (as the + generic could have been declared in the implementation part), but load + only interface units, if we are in a different unit as then the generic + needs to be in the interface section } pu:=tused_unit(hmodule.used_units.first); while assigned(pu) do begin + if (hmodule<>current_module) and not pu.in_interface then + begin + pu:=tused_unit(pu.next); + continue; + end; if not assigned(pu.u.globalsymtable) then internalerror(200705153); symtablestack.push(pu.u.globalsymtable); diff --git a/mips/compiler/powerpc/cpubase.pas b/mips/compiler/powerpc/cpubase.pas index a33e214d48..629ccfee4a 100644 --- a/mips/compiler/powerpc/cpubase.pas +++ b/mips/compiler/powerpc/cpubase.pas @@ -352,7 +352,7 @@ uses ); { this is only for the generic code which is not used for this architecture } - saved_mm_registers : array[0..0] of tsuperregister = (RS_NO); + saved_mm_registers : array[0..0] of tsuperregister = (RS_INVALID); {# Required parameter alignment when calling a routine declared as stdcall and cdecl. The alignment value should be the one defined diff --git a/mips/compiler/powerpc/cpupara.pas b/mips/compiler/powerpc/cpupara.pas index 8c3266bc5e..0f4970889f 100644 --- a/mips/compiler/powerpc/cpupara.pas +++ b/mips/compiler/powerpc/cpupara.pas @@ -37,7 +37,7 @@ unit cpupara; function get_volatile_registers_fpu(calloption : tproccalloption):tcpuregisterset;override; function push_addr_param(varspez:tvarspez;def : tdef;calloption : tproccalloption) : boolean;override; - procedure getintparaloc(calloption : tproccalloption; nr : longint;var cgpara:TCGPara);override; + procedure getintparaloc(calloption : tproccalloption; nr : longint; def : tdef; var cgpara : tcgpara);override; function create_paraloc_info(p : tabstractprocdef; side: tcallercallee):longint;override; function create_varargs_paraloc_info(p : tabstractprocdef; varargspara:tvarargsparalist):longint;override; function get_funcretloc(p : tabstractprocdef; side: tcallercallee; def: tdef): tcgpara;override; @@ -78,14 +78,15 @@ unit cpupara; end; - procedure tppcparamanager.getintparaloc(calloption : tproccalloption; nr : longint;var cgpara:TCGPara); + procedure tppcparamanager.getintparaloc(calloption : tproccalloption; nr : longint; def : tdef; var cgpara : tcgpara); var paraloc : pcgparalocation; begin cgpara.reset; - cgpara.size:=OS_ADDR; - cgpara.intsize:=sizeof(pint); + cgpara.size:=def_cgsize(def); + cgpara.intsize:=tcgsize2size[cgpara.size]; cgpara.alignment:=get_para_align(calloption); + cgpara.def:=def; paraloc:=cgpara.add_location; with paraloc^ do begin @@ -256,38 +257,8 @@ unit cpupara; paraloc : pcgparalocation; retcgsize : tcgsize; begin - result.init; - result.alignment:=get_para_align(p.proccalloption); - { void has no location } - if is_void(def) then - begin - paraloc:=result.add_location; - result.size:=OS_NO; - result.intsize:=0; - paraloc^.size:=OS_NO; - paraloc^.loc:=LOC_VOID; - exit; - end; - { Constructors return self instead of a boolean } - if (p.proctypeoption=potype_constructor) then - begin - retcgsize:=OS_ADDR; - result.intsize:=sizeof(pint); - end - else - begin - retcgsize:=def_cgsize(def); - result.intsize:=def.size; - end; - result.size:=retcgsize; - { Return is passed as var parameter } - if ret_in_param(def,p.proccalloption) then - begin - paraloc:=result.add_location; - paraloc^.loc:=LOC_REFERENCE; - paraloc^.size:=retcgsize; - exit; - end; + if set_common_funcretloc_info(p,def,retcgsize,result) then + exit; paraloc:=result.add_location; { Return in FPU register? } @@ -403,12 +374,9 @@ unit cpupara; break; end; - if (hp.varspez in [vs_var,vs_out]) or - push_addr_param(hp.varspez,paradef,p.proccalloption) or - is_open_array(paradef) or - is_array_of_const(paradef) then + if push_addr_param(hp.varspez,paradef,p.proccalloption) then begin - paradef:=voidpointertype; + paradef:=getpointerdef(paradef); loc:=LOC_REGISTER; paracgsize := OS_ADDR; paralen := tcgsize2size[OS_ADDR]; @@ -466,6 +434,7 @@ unit cpupara; hp.paraloc[side].alignment:=std_param_align; hp.paraloc[side].size:=paracgsize; hp.paraloc[side].intsize:=paralen; + hp.paraloc[side].def:=paradef; if (target_info.abi = abi_powerpc_aix) and (paradef.typ in [recorddef,arraydef]) then hp.paraloc[side].composite:=true; diff --git a/mips/compiler/powerpc/nppcmat.pas b/mips/compiler/powerpc/nppcmat.pas index 4c49448727..faa2050082 100644 --- a/mips/compiler/powerpc/nppcmat.pas +++ b/mips/compiler/powerpc/nppcmat.pas @@ -403,7 +403,13 @@ end; cg.a_load_const_reg(current_asmdata.CurrAsmList,OS_32,0,location.register64.reglo); cg.a_load_const_reg(current_asmdata.CurrAsmList,OS_32,0,location.register64.reglo); end - else } if shiftval > 31 then + else } + if shiftval = 0 then + begin + cg.a_load_reg_reg(current_asmdata.CurrAsmList,OS_32,OS_32,left.location.register64.reghi,location.register64.reghi); + cg.a_load_reg_reg(current_asmdata.CurrAsmList,OS_32,OS_32,left.location.register64.reglo,location.register64.reglo); + end + else if shiftval > 31 then begin if nodetype = shln then begin diff --git a/mips/compiler/powerpc64/cpubase.pas b/mips/compiler/powerpc64/cpubase.pas index 57cea3cbf4..ded99ac0e4 100644 --- a/mips/compiler/powerpc64/cpubase.pas +++ b/mips/compiler/powerpc64/cpubase.pas @@ -350,7 +350,7 @@ const ); { this is only for the generic code which is not used for this architecture } - saved_mm_registers : array[0..0] of tsuperregister = (RS_NO); + saved_mm_registers : array[0..0] of tsuperregister = (RS_INVALID); {# Required parameter alignment when calling a routine declared as stdcall and cdecl. The alignment value should be the one defined diff --git a/mips/compiler/powerpc64/cpupara.pas b/mips/compiler/powerpc64/cpupara.pas index 8a6164cd3a..b17a4b7ae3 100644 --- a/mips/compiler/powerpc64/cpupara.pas +++ b/mips/compiler/powerpc64/cpupara.pas @@ -40,8 +40,7 @@ type function push_addr_param(varspez: tvarspez; def: tdef; calloption: tproccalloption): boolean; override; - procedure getintparaloc(calloption: tproccalloption; nr: longint; var - cgpara: TCGPara); override; + procedure getintparaloc(calloption: tproccalloption; nr: longint; def: tdef; var cgpara: tcgpara); override; function create_paraloc_info(p: tabstractprocdef; side: tcallercallee): longint; override; function create_varargs_paraloc_info(p: tabstractprocdef; varargspara: tvarargsparalist): longint; override; @@ -79,15 +78,15 @@ begin result := [RS_F0..RS_F13]; end; -procedure tppcparamanager.getintparaloc(calloption: tproccalloption; nr: - longint; var cgpara: TCGPara); +procedure tppcparamanager.getintparaloc(calloption: tproccalloption; nr: longint; def : tdef; var cgpara: tcgpara); var paraloc: pcgparalocation; begin cgpara.reset; - cgpara.size := OS_ADDR; - cgpara.intsize := sizeof(pint); + cgpara.size := def_cgsize(def); + cgpara.intsize := tcgsize2size[cgpara.size]; cgpara.alignment := get_para_align(calloption); + cgpara.def:=def; paraloc := cgpara.add_location; with paraloc^ do begin size := OS_INT; @@ -215,38 +214,8 @@ var paraloc : pcgparalocation; retcgsize : tcgsize; begin - result.init; - result.alignment:=get_para_align(p.proccalloption); - { void has no location } - if is_void(def) then - begin - paraloc:=result.add_location; - result.size:=OS_NO; - result.intsize:=0; - paraloc^.size:=OS_NO; - paraloc^.loc:=LOC_VOID; - exit; - end; - { Constructors return self instead of a boolean } - if (p.proctypeoption=potype_constructor) then - begin - retcgsize:=OS_ADDR; - result.intsize:=sizeof(pint); - end - else - begin - retcgsize:=def_cgsize(def); - result.intsize:=def.size; - end; - result.size:=retcgsize; - { Return is passed as var parameter } - if ret_in_param(def,p.proccalloption) then - begin - paraloc:=result.add_location; - paraloc^.loc:=LOC_REFERENCE; - paraloc^.size:=retcgsize; - exit; - end; + if set_common_funcretloc_info(p,def,retcgsize,result) then + exit; paraloc:=result.add_location; { Return in FPU register? } @@ -334,11 +303,8 @@ begin break; end; - if (hp.varspez in [vs_var, vs_out]) or - push_addr_param(hp.varspez, paradef, p.proccalloption) or - is_open_array(paradef) or - is_array_of_const(paradef) then begin - paradef := voidpointertype; + if push_addr_param(hp.varspez, paradef, p.proccalloption) then begin + paradef := getpointerdef(paradef); loc := LOC_REGISTER; paracgsize := OS_ADDR; paralen := tcgsize2size[OS_ADDR]; @@ -390,6 +356,7 @@ begin hp.paraloc[side].alignment := std_param_align; hp.paraloc[side].size := paracgsize; hp.paraloc[side].intsize := paralen; + hp.paraloc[side].def := paradef; if (paralen = 0) then if (paradef.typ = recorddef) then begin paraloc := hp.paraloc[side].add_location; diff --git a/mips/compiler/pparautl.pas b/mips/compiler/pparautl.pas index 434044db04..66baa37254 100644 --- a/mips/compiler/pparautl.pas +++ b/mips/compiler/pparautl.pas @@ -51,6 +51,7 @@ implementation begin if not(pd.proctypeoption in [potype_constructor,potype_destructor]) and not is_void(pd.returndef) and + not (df_generic in pd.defoptions) and paramanager.ret_in_param(pd.returndef,pd.proccalloption) then begin storepos:=current_tokenpos; @@ -243,7 +244,11 @@ implementation { We need to insert a varsym for the result in the localst when it is returning in a register } - if not paramanager.ret_in_param(pd.returndef,pd.proccalloption) then + { we also need to do this for a generic procdef as we didn't allow + the creation of a result symbol in insert_funcret_para, but we need + a valid funcretsym } + if (df_generic in pd.defoptions) or + not paramanager.ret_in_param(pd.returndef,pd.proccalloption) then begin vs:=tlocalvarsym.create('$result',vs_value,pd.returndef,[vo_is_funcret]); pd.localst.insert(vs); diff --git a/mips/compiler/ppcgen/cgppc.pas b/mips/compiler/ppcgen/cgppc.pas index 4e482f90bd..4facd00538 100644 --- a/mips/compiler/ppcgen/cgppc.pas +++ b/mips/compiler/ppcgen/cgppc.pas @@ -657,7 +657,7 @@ unit cgppc; if (target_info.system in [system_powerpc_darwin]) then begin paraloc1.init; - paramanager.getintparaloc(pocall_cdecl,1,paraloc1); + paramanager.getintparaloc(pocall_cdecl,1,voidpointertype,paraloc1); a_load_reg_cgpara(list,OS_ADDR,NR_R0,paraloc1); paramanager.freecgpara(list,paraloc1); paraloc1.done; diff --git a/mips/compiler/ppu.pas b/mips/compiler/ppu.pas index 3ecad1736e..f9ee577b07 100644 --- a/mips/compiler/ppu.pas +++ b/mips/compiler/ppu.pas @@ -43,7 +43,7 @@ type {$endif Test_Double_checksum} const - CurrentPPUVersion = 149; + CurrentPPUVersion = 151; { buffer sizes } maxentrysize = 1024; diff --git a/mips/compiler/pstatmnt.pas b/mips/compiler/pstatmnt.pas index 69bd5ae084..089e5b955e 100644 --- a/mips/compiler/pstatmnt.pas +++ b/mips/compiler/pstatmnt.pas @@ -1382,6 +1382,7 @@ implementation not (current_procinfo.procdef.owner.symtabletype in [ObjectSymtable,recordsymtable]) and (not assigned(current_procinfo.procdef.funcretsym) or (tabstractvarsym(current_procinfo.procdef.funcretsym).refs<=1)) and + not (df_generic in current_procinfo.procdef.defoptions) and not(paramanager.ret_in_param(current_procinfo.procdef.returndef,current_procinfo.procdef.proccalloption)) then begin { Only need to set the framepointer, the locals will @@ -1395,6 +1396,7 @@ implementation register. } if assigned(current_procinfo.procdef.funcretsym) and + not (df_generic in current_procinfo.procdef.defoptions) and (not paramanager.ret_in_param(current_procinfo.procdef.returndef,current_procinfo.procdef.proccalloption)) then tabstractvarsym(current_procinfo.procdef.funcretsym).varstate:=vs_initialised; diff --git a/mips/compiler/psub.pas b/mips/compiler/psub.pas index 692ec26dfe..73439091e4 100644 --- a/mips/compiler/psub.pas +++ b/mips/compiler/psub.pas @@ -116,7 +116,7 @@ implementation opttail, optcse,optloop, optutils -{$if defined(arm) or defined(powerpc) or defined(powerpc64) or defined(avr)} +{$if defined(arm) or defined(avr) or defined(fpc_compiler_has_fixup_jmps)} ,aasmcpu {$endif arm} {$ifndef NOOPT} @@ -404,6 +404,7 @@ implementation para : tcallparanode; call : tcallnode; newstatement : tstatementnode; + def : tabstractrecorddef; begin result:=internalstatements(newstatement); @@ -412,9 +413,17 @@ implementation { a constructor needs a help procedure } if (current_procinfo.procdef.proctypeoption=potype_constructor) then begin - if is_class(current_structdef) then + if is_class(current_structdef) or + ( + is_objectpascal_helper(current_structdef) and + is_class(tobjectdef(current_structdef).extendeddef) + ) then begin - srsym:=search_struct_member(current_structdef,'NEWINSTANCE'); + if is_objectpascal_helper(current_structdef) then + def:=tabstractrecorddef(tobjectdef(current_structdef).extendeddef) + else + def:=current_structdef; + srsym:=search_struct_member(def,'NEWINSTANCE'); if assigned(srsym) and (srsym.typ=procsym) then begin @@ -882,6 +891,13 @@ implementation end; end; + + const + exception_flags: array[boolean] of tprocinfoflags = ( + [], + [pi_uses_exceptions,pi_needs_implicit_finally,pi_has_implicit_finally] + ); + procedure tcgprocinfo.setup_tempgen; begin tg:=tgobjclass.create; @@ -906,6 +922,9 @@ implementation * incoming parameters on the stack * open arrays - no local variables + + - stack frame cannot be optimized if using Win64 SEH + (at least with the current state of our codegenerator). } if ((po_assembler in procdef.procoptions) and (m_delphi in current_settings.modeswitches) and @@ -915,12 +934,13 @@ implementation ((cs_opt_stackframe in current_settings.optimizerswitches) and not(cs_generate_stackframes in current_settings.localswitches) and not(po_assembler in procdef.procoptions) and - ((flags*[pi_has_assembler_block,pi_is_assembler, -{$ifdef i386} - pi_uses_exceptions,pi_needs_implicit_finally,pi_has_implicit_finally, -{$endif i386} - pi_has_stackparameter, - pi_needs_stackframe])=[]) + ((flags*([pi_has_assembler_block,pi_is_assembler, + pi_has_stackparameter,pi_needs_stackframe]+ + exception_flags[(target_info.cpu=cpu_i386) +{$ifdef TEST_WIN64_SEH} + or (target_info.system=system_x86_64_win64) +{$endif TEST_WIN64_SEH} + ]))=[]) ) then begin @@ -1473,7 +1493,7 @@ implementation current_filepos:=exitpos; hlcg.gen_proc_symbol_end(templist); aktproccode.concatlist(templist); -{$if defined(POWERPC) or defined(POWERPC64)} +{$ifdef fpc_compiler_has_fixup_jmps} fixup_jmps(aktproccode); {$endif} { insert line debuginfo } diff --git a/mips/compiler/psystem.pas b/mips/compiler/psystem.pas index 6d86b4ba06..1cb59e0420 100644 --- a/mips/compiler/psystem.pas +++ b/mips/compiler/psystem.pas @@ -610,10 +610,11 @@ implementation aiclass[ait_stab]:=tai_stab; aiclass[ait_force_line]:=tai_force_line; aiclass[ait_function_name]:=tai_function_name; + aiclass[ait_ent]:=tai_ent; + aiclass[ait_ent_end]:=tai_ent_end; {$ifdef alpha} { the follow is for the DEC Alpha } aiclass[ait_frame]:=tai_frame; - aiclass[ait_ent]:=tai_ent; {$endif alpha} {$ifdef m68k} { TODO: FIXME: tai_labeled_instruction doesn't exists} diff --git a/mips/compiler/ptype.pas b/mips/compiler/ptype.pas index 29319b7d28..cd747b1405 100644 --- a/mips/compiler/ptype.pas +++ b/mips/compiler/ptype.pas @@ -151,6 +151,20 @@ implementation not(is_objcclass(ttypesym(srsym).typedef)) and not(is_javaclass(ttypesym(srsym).typedef)) then MessagePos1(def.typesym.fileinfo,type_e_class_type_expected,ttypesym(srsym).typedef.typename); + { this could also be a generic dummy that was not + overridden with a specific type } + if (sp_generic_dummy in srsym.symoptions) and + ( + (ttypesym(srsym).typedef.typ=undefineddef) or + ( + { or an unspecialized generic symbol, which is + the case for generics defined in non-Delphi + modes } + (df_generic in ttypesym(srsym).typedef.defoptions) and + not parse_generic + ) + ) then + MessagePos(def.typesym.fileinfo,parser_e_no_generics_as_types); end else begin @@ -425,8 +439,22 @@ implementation if ([stoAllowSpecialization,stoAllowTypeDef] * options <> []) and (m_delphi in current_settings.modeswitches) then dospecialize:=token in [_LSHARPBRACKET,_LT]; + if dospecialize and + (def.typ=forwarddef) then + begin + if not assigned(srsym) or not (srsym.typ=typesym) then + begin + Message(type_e_type_is_not_completly_defined); + def:=generrordef; + dospecialize:=false; + end; + end; if dospecialize then - generate_specialization(def,stoParseClassParent in options,'',nil,'') + begin + if def.typ=forwarddef then + def:=ttypesym(srsym).typedef; + generate_specialization(def,stoParseClassParent in options,'',nil,''); + end else begin if assigned(current_specializedef) and (def=current_specializedef.genericdef) then @@ -775,6 +803,10 @@ implementation if old_parse_generic then include(current_structdef.defoptions, df_generic); parse_generic:=(df_generic in current_structdef.defoptions); + { in non-Delphi modes we need a strict private symbol without type + count and type parameters in the name to simply resolving } + maybe_insert_generic_rename_symbol(n,genericlist); + if m_advanced_records in current_settings.modeswitches then begin parse_record_members; @@ -1131,40 +1163,40 @@ implementation begin if pt.nodetype=rangen then begin - { check the expression only if we are not in a generic declaration } - if not(parse_generic) then + { pure ordconstn expressions can be checked for + generics as well, but don't give an error in case + of parsing a generic if that isn't yet the case } + if (trangenode(pt).left.nodetype=ordconstn) and + (trangenode(pt).right.nodetype=ordconstn) then begin - if (trangenode(pt).left.nodetype=ordconstn) and - (trangenode(pt).right.nodetype=ordconstn) then + { make both the same type or give an error. This is not + done when both are integer values, because typecasting + between -3200..3200 will result in a signed-unsigned + conflict and give a range check error (PFV) } + if not(is_integer(trangenode(pt).left.resultdef) and is_integer(trangenode(pt).left.resultdef)) then + inserttypeconv(trangenode(pt).left,trangenode(pt).right.resultdef); + lowval:=tordconstnode(trangenode(pt).left).value; + highval:=tordconstnode(trangenode(pt).right).value; + if highval<lowval then + begin + Message(parser_e_array_lower_less_than_upper_bound); + highval:=lowval; + end + else if (lowval<int64(low(asizeint))) or + (highval>high(asizeint)) then begin - { make both the same type or give an error. This is not - done when both are integer values, because typecasting - between -3200..3200 will result in a signed-unsigned - conflict and give a range check error (PFV) } - if not(is_integer(trangenode(pt).left.resultdef) and is_integer(trangenode(pt).left.resultdef)) then - inserttypeconv(trangenode(pt).left,trangenode(pt).right.resultdef); - lowval:=tordconstnode(trangenode(pt).left).value; - highval:=tordconstnode(trangenode(pt).right).value; - if highval<lowval then - begin - Message(parser_e_array_lower_less_than_upper_bound); - highval:=lowval; - end - else if (lowval<int64(low(asizeint))) or - (highval>high(asizeint)) then - begin - Message(parser_e_array_range_out_of_bounds); - lowval :=0; - highval:=0; - end; - if is_integer(trangenode(pt).left.resultdef) then - range_to_type(lowval,highval,indexdef) - else - indexdef:=trangenode(pt).left.resultdef; - end + Message(parser_e_array_range_out_of_bounds); + lowval :=0; + highval:=0; + end; + if is_integer(trangenode(pt).left.resultdef) then + range_to_type(lowval,highval,indexdef) else - Message(type_e_cant_eval_constant_expr); - end; + indexdef:=trangenode(pt).left.resultdef; + end + else + if not parse_generic then + Message(type_e_cant_eval_constant_expr); end else Message(sym_e_error_in_type_def) @@ -1312,6 +1344,7 @@ implementation const SingleTypeOptionsInTypeBlock:array[Boolean] of TSingleTypeOptions = ([],[stoIsForwardDef]); + SingleTypeOptionsIsDelphi:array[Boolean] of TSingleTypeOptions = ([],[stoAllowSpecialization]); var p : tnode; hdef : tdef; @@ -1441,7 +1474,17 @@ implementation _CARET: begin consume(_CARET); - single_type(tt2,SingleTypeOptionsInTypeBlock[block_type=bt_type]); + single_type(tt2, + SingleTypeOptionsInTypeBlock[block_type=bt_type]+ + SingleTypeOptionsIsDelphi[m_delphi in current_settings.modeswitches] + ); + { in case of e.g. var or const sections we need to especially + check that we don't use a generic dummy symbol } + if (block_type<>bt_type) and + (tt2.typ=undefineddef) and + assigned(tt2.typesym) and + (sp_generic_dummy in tt2.typesym.symoptions) then + Message(parser_e_no_generics_as_types); { don't use getpointerdef() here, since this is a type declaration (-> must create new typedef) } def:=tpointerdef.create(tt2); diff --git a/mips/compiler/rautils.pas b/mips/compiler/rautils.pas index d7c0999097..bc27d5a6ab 100644 --- a/mips/compiler/rautils.pas +++ b/mips/compiler/rautils.pas @@ -689,6 +689,7 @@ begin if (not is_void(returndef)) then begin if (m_tp7 in current_settings.modeswitches) and + not (df_generic in defoptions) and (not paramanager.ret_in_param(returndef,proccalloption)) then begin message(asmr_e_cannot_use_RESULT_here); diff --git a/mips/compiler/rgobj.pas b/mips/compiler/rgobj.pas index 70734179a5..0cd1f1aa63 100644 --- a/mips/compiler/rgobj.pas +++ b/mips/compiler/rgobj.pas @@ -1,5 +1,5 @@ { - Copyright (c) 1998-2002 by Florian Klaempfl + Copyright (c) 1998-2012 by the Free Pascal team This unit implements the base class for the register allocator @@ -191,7 +191,8 @@ unit rgobj; {# Highest register allocated until now.} reginfo : PReginfo; usable_registers_cnt : word; - usable_registers : array[0..maxcpuregister-1] of tsuperregister; + usable_registers : array[0..maxcpuregister] of tsuperregister; + usable_register_set : tcpuregisterset; ibitmap : Tinterferencebitmap; spillednodes, simplifyworklist, @@ -399,7 +400,10 @@ unit rgobj; // default value set by constructor // fillchar(usable_registers,sizeof(usable_registers),0); for i:=low(Ausable) to high(Ausable) do - usable_registers[i]:=Ausable[i]; + begin + usable_registers[i]:=Ausable[i]; + include(usable_register_set,Ausable[i]); + end; usable_registers_cnt:=high(Ausable)+1; { Initialize Worklists } spillednodes.init; @@ -996,6 +1000,7 @@ unit rgobj; begin ok:=(t<first_imaginary) or + ((r<first_imaginary) and (r in usable_register_set)) or (reginfo[t].degree<usable_registers_cnt) or ibitmap[r,t]; end; @@ -1371,7 +1376,7 @@ unit rgobj; n:=coalescednodes.buf^[i-1]; k:=get_alias(n); reginfo[n].colour:=reginfo[k].colour; - if reginfo[k].colour<maxcpuregister then + if reginfo[k].colour<first_imaginary then include(used_in_proc,reginfo[k].colour); end; end; @@ -1567,6 +1572,7 @@ unit rgobj; p:=headertai; while assigned(p) do begin + prefetch(pointer(p.next)^); if p.typ=ait_regalloc then with Tai_regalloc(p) do begin @@ -1632,6 +1638,7 @@ unit rgobj; p:=Tai(list.first); while assigned(p) do begin + prefetch(pointer(p.next)^); case p.typ of ait_regalloc: with Tai_regalloc(p) do @@ -1867,6 +1874,9 @@ unit rgobj; ins:=spilling_create_load(spilltemp,tempreg); add_cpu_interferences(ins); list.insertafter(ins,pos); + {$ifdef DEBUG_SPILLING} + list.Insertbefore(tai_comment.Create(strpnew('XXX: Spill Read')),ins); + {$endif} end; @@ -1877,6 +1887,9 @@ unit rgobj; ins:=spilling_create_store(tempreg,spilltemp); add_cpu_interferences(ins); list.insertafter(ins,pos); + {$ifdef DEBUG_SPILLING} + list.Insertbefore(tai_comment.Create(strpnew('XXX: Spill Write')),ins); + {$endif} end; diff --git a/mips/compiler/scanner.pas b/mips/compiler/scanner.pas index 1fbec44792..5d9eac0050 100644 --- a/mips/compiler/scanner.pas +++ b/mips/compiler/scanner.pas @@ -174,9 +174,16 @@ interface procedure stoprecordtokens; procedure replaytoken; procedure startreplaytokens(buf:tdynamicarray; achange_endian : boolean); - { bit length sizeint is target depend } - procedure tokenwritesizeint(val : sizeint); - function tokenreadsizeint : sizeint; + { bit length asizeint is target depend } + procedure tokenwritesizeint(val : asizeint); + procedure tokenwritelongint(val : longint); + procedure tokenwritelongword(val : longword); + procedure tokenwriteword(val : word); + procedure tokenwriteshortint(val : shortint); + procedure tokenwriteset(var b;size : longint); + procedure tokenwriteenum(var b;size : longint); + function tokenreadsizeint : asizeint; + procedure tokenwritesettings(var asettings : tsettings; var size : asizeint); { longword/longint are 32 bits on all targets } { word/smallint are 16-bits on all targest } function tokenreadlongword : longword; @@ -190,7 +197,7 @@ interface procedure tokenreadset(var b;size : longint); function tokenreadenum(size : longint) : longword; - procedure tokenreadsettings(var asettings : tsettings; expected_size : longint); + procedure tokenreadsettings(var asettings : tsettings; expected_size : asizeint); procedure readchar; procedure readstring; procedure readnumber; @@ -2177,16 +2184,36 @@ In case not, the value returned can be arbitrary. recordtokenbuf.write(b,1); end; - procedure tscannerfile.tokenwritesizeint(val : sizeint); + procedure tscannerfile.tokenwritesizeint(val : asizeint); begin - recordtokenbuf.write(val,sizeof(sizeint)); + recordtokenbuf.write(val,sizeof(asizeint)); end; - function tscannerfile.tokenreadsizeint : sizeint; + procedure tscannerfile.tokenwritelongint(val : longint); + begin + recordtokenbuf.write(val,sizeof(longint)); + end; + + procedure tscannerfile.tokenwriteshortint(val : shortint); + begin + recordtokenbuf.write(val,sizeof(shortint)); + end; + + procedure tscannerfile.tokenwriteword(val : word); + begin + recordtokenbuf.write(val,sizeof(word)); + end; + + procedure tscannerfile.tokenwritelongword(val : longword); + begin + recordtokenbuf.write(val,sizeof(longword)); + end; + + function tscannerfile.tokenreadsizeint : asizeint; var - val : sizeint; + val : asizeint; begin - replaytokenbuf.read(val,sizeof(sizeint)); + replaytokenbuf.read(val,sizeof(asizeint)); if tokenbuf_change_endian then val:=swapendian(val); result:=val; @@ -2268,8 +2295,18 @@ In case not, the value returned can be arbitrary. Pbyte(@b)[i]:=reverse_byte(Pbyte(@b)[i]); end; + procedure tscannerfile.tokenwriteenum(var b;size : longint); + begin + recordtokenbuf.write(b,size); + end; + + procedure tscannerfile.tokenwriteset(var b;size : longint); + begin + recordtokenbuf.write(b,size); + end; - procedure tscannerfile.tokenreadsettings(var asettings : tsettings; expected_size : longint); + + procedure tscannerfile.tokenreadsettings(var asettings : tsettings; expected_size : asizeint); { This procedure needs to be changed whenever @@ -2337,12 +2374,84 @@ In case not, the value returned can be arbitrary. end; end; + procedure tscannerfile.tokenwritesettings(var asettings : tsettings; var size : asizeint); + + { This procedure + needs to be changed whenever + globals.tsettings type is changed, + the problem is that no error will appear + before tests with generics are tested. PM } + + var + sizepos, startpos, endpos : longword; + begin + { WARNING all those fields need to be in the correct + order otherwise cross_endian PPU reading will fail } + sizepos:=recordtokenbuf.pos; + size:=0; + tokenwritesizeint(size); + startpos:=recordtokenbuf.pos; + with asettings do + begin + tokenwritelongint(alignment.procalign); + tokenwritelongint(alignment.loopalign); + tokenwritelongint(alignment.jumpalign); + tokenwritelongint(alignment.constalignmin); + tokenwritelongint(alignment.constalignmax); + tokenwritelongint(alignment.varalignmin); + tokenwritelongint(alignment.varalignmax); + tokenwritelongint(alignment.localalignmin); + tokenwritelongint(alignment.localalignmax); + tokenwritelongint(alignment.recordalignmin); + tokenwritelongint(alignment.recordalignmax); + tokenwritelongint(alignment.maxCrecordalign); + tokenwriteset(globalswitches,sizeof(globalswitches)); + tokenwriteset(targetswitches,sizeof(targetswitches)); + tokenwriteset(moduleswitches,sizeof(moduleswitches)); + tokenwriteset(localswitches,sizeof(localswitches)); + tokenwriteset(modeswitches,sizeof(modeswitches)); + tokenwriteset(optimizerswitches,sizeof(optimizerswitches)); + tokenwriteset(genwpoptimizerswitches,sizeof(genwpoptimizerswitches)); + tokenwriteset(dowpoptimizerswitches,sizeof(dowpoptimizerswitches)); + tokenwriteset(debugswitches,sizeof(debugswitches)); + { 0: old behaviour for sets <=256 elements + >0: round to this size } + tokenwriteshortint(setalloc); + tokenwriteshortint(packenum); + tokenwriteshortint(packrecords); + tokenwriteshortint(maxfpuregisters); + + tokenwriteenum(cputype,sizeof(tcputype)); + tokenwriteenum(optimizecputype,sizeof(tcputype)); + tokenwriteenum(fputype,sizeof(tfputype)); + tokenwriteenum(asmmode,sizeof(tasmmode)); + tokenwriteenum(interfacetype,sizeof(tinterfacetypes)); + tokenwriteenum(defproccall,sizeof(tproccalloption)); + { tstringencoding is word type, + thus this should be OK here } + tokenwriteword(sourcecodepage); + + tokenwriteenum(minfpconstprec,sizeof(tfloattype)); + + recordtokenbuf.write(byte(disabledircache),1); +{$if defined(ARM) or defined(AVR)} + tokenwriteenum(controllertype,sizeof(tcontrollertype)); +{$endif defined(ARM) or defined(AVR)} + endpos:=recordtokenbuf.pos; + size:=endpos-startpos; + recordtokenbuf.seek(sizepos); + tokenwritesizeint(size); + recordtokenbuf.seek(endpos); + end; + end; + procedure tscannerfile.recordtoken; var t : ttoken; s : tspecialgenerictoken; - len,val,msgnb,copy_size : sizeint; + len,msgnb,copy_size : asizeint; + val : longint; b : byte; pmsg : pmessagestaterecord; begin @@ -2360,8 +2469,7 @@ In case not, the value returned can be arbitrary. writetoken(t); recordtokenbuf.write(s,1); copy_size:=sizeof(current_settings)-sizeof(pointer); - tokenwritesizeint(copy_size); - recordtokenbuf.write(current_settings,copy_size); + tokenwritesettings(current_settings,copy_size); last_settings:=current_settings; end; @@ -2375,7 +2483,7 @@ In case not, the value returned can be arbitrary. pmsg:=current_settings.pmessage; while assigned(pmsg) do begin - if msgnb=high(sizeint) then + if msgnb=high(asizeint) then { Too many messages } internalerror(2011090401); inc(msgnb); @@ -2385,11 +2493,12 @@ In case not, the value returned can be arbitrary. pmsg:=current_settings.pmessage; while assigned(pmsg) do begin - { What about endianess here? } + { What about endianess here?} + { SB: this is handled by tokenreadlongint } val:=pmsg^.value; - tokenwritesizeint(val); + tokenwritelongint(val); val:=ord(pmsg^.state); - tokenwritesizeint(val); + tokenwritelongint(val); pmsg:=pmsg^.next; end; last_message:=current_settings.pmessage; @@ -2506,7 +2615,7 @@ In case not, the value returned can be arbitrary. procedure tscannerfile.replaytoken; var - wlen,mesgnb,copy_size : sizeint; + wlen,mesgnb,copy_size : asizeint; specialtoken : tspecialgenerictoken; i : byte; pmsg,prevmsg : pmessagestaterecord; @@ -2575,11 +2684,6 @@ In case not, the value returned can be arbitrary. if (ord(specialtoken) and $80)<>0 then begin current_tokenpos.column:=ord(specialtoken) and $7f; - - { don't generate invalid line info if no sources are available for the current module } - if not(get_module(current_filepos.moduleindex).sources_avail) then - current_tokenpos.column:=0; - current_filepos:=current_tokenpos; end else @@ -2587,8 +2691,8 @@ In case not, the value returned can be arbitrary. ST_LOADSETTINGS: begin copy_size:=tokenreadsizeint; - if copy_size <> sizeof(current_settings)-sizeof(pointer) then - internalerror(2011090501); + //if copy_size <> sizeof(current_settings)-sizeof(pointer) then + // internalerror(2011090501); { replaytokenbuf.read(current_settings,copy_size); } @@ -2610,8 +2714,8 @@ In case not, the value returned can be arbitrary. end else prevmsg^.next:=pmsg; - replaytokenbuf.read(pmsg^.value,sizeof(longint)); - replaytokenbuf.read(pmsg^.state,sizeof(tmsgstate)); + pmsg^.value:=tokenreadlongint; + pmsg^.state:=tmsgstate(tokenreadlongint); pmsg^.next:=nil; prevmsg:=pmsg; end; @@ -2619,32 +2723,16 @@ In case not, the value returned can be arbitrary. ST_LINE: begin current_tokenpos.line:=tokenreadlongint; - - { don't generate invalid line info if no sources are available for the current module } - if not(get_module(current_filepos.moduleindex).sources_avail) then - current_tokenpos.line:=0; - current_filepos:=current_tokenpos; end; ST_COLUMN: begin current_tokenpos.column:=tokenreadword; - { don't generate invalid line info if no sources are available for the current module } - if not(get_module(current_filepos.moduleindex).sources_avail) then - current_tokenpos.column:=0; - current_filepos:=current_tokenpos; end; ST_FILEINDEX: begin current_tokenpos.fileindex:=tokenreadword; - { don't generate invalid line info if no sources are available for the current module } - if not(get_module(current_filepos.moduleindex).sources_avail) then - begin - current_tokenpos.column:=0; - current_tokenpos.line:=0; - end; - current_filepos:=current_tokenpos; end; else diff --git a/mips/compiler/sparc/cgcpu.pas b/mips/compiler/sparc/cgcpu.pas index 4da36945d7..87f232a891 100644 --- a/mips/compiler/sparc/cgcpu.pas +++ b/mips/compiler/sparc/cgcpu.pas @@ -1177,10 +1177,10 @@ implementation paraloc1.init; paraloc2.init; paraloc3.init; - paramanager.getintparaloc(pocall_default,1,paraloc1); - paramanager.getintparaloc(pocall_default,2,paraloc2); - paramanager.getintparaloc(pocall_default,3,paraloc3); - a_load_const_cgpara(list,OS_INT,len,paraloc3); + paramanager.getintparaloc(pocall_default,1,voidpointertype,paraloc1); + paramanager.getintparaloc(pocall_default,2,voidpointertype,paraloc2); + paramanager.getintparaloc(pocall_default,3,ptrsinttype,paraloc3); + a_load_const_cgpara(list,OS_SINT,len,paraloc3); a_loadaddr_ref_cgpara(list,dest,paraloc2); a_loadaddr_ref_cgpara(list,source,paraloc1); paramanager.freecgpara(list,paraloc3); diff --git a/mips/compiler/sparc/cpubase.pas b/mips/compiler/sparc/cpubase.pas index d07eeebbf0..880b0be023 100644 --- a/mips/compiler/sparc/cpubase.pas +++ b/mips/compiler/sparc/cpubase.pas @@ -249,10 +249,10 @@ uses This value can be deduced from CALLED_USED_REGISTERS array in the GCC source. } - saved_standard_registers : array[0..0] of tsuperregister = (RS_NO); + saved_standard_registers : array[0..0] of tsuperregister = (RS_INVALID); { this is only for the generic code which is not used for this architecture } - saved_mm_registers : array[0..0] of tsuperregister = (RS_NO); + saved_mm_registers : array[0..0] of tsuperregister = (RS_INVALID); {# Required parameter alignment when calling a routine declared as stdcall and cdecl. The alignment value should be the one defined diff --git a/mips/compiler/sparc/cpupara.pas b/mips/compiler/sparc/cpupara.pas index aca3bec939..30046ccc4f 100644 --- a/mips/compiler/sparc/cpupara.pas +++ b/mips/compiler/sparc/cpupara.pas @@ -38,7 +38,7 @@ interface {Returns a structure giving the information on the storage of the parameter (which must be an integer parameter) @param(nr Parameter number of routine, starting from 1)} - procedure getintparaloc(calloption : tproccalloption; nr : longint;var cgpara : TCGPara);override; + procedure getintparaloc(calloption : tproccalloption; nr : longint; def : tdef; var cgpara : tcgpara);override; function create_paraloc_info(p : TAbstractProcDef; side: tcallercallee):longint;override; function create_varargs_paraloc_info(p : TAbstractProcDef; varargspara:tvarargsparalist):longint;override; function get_funcretloc(p : tabstractprocdef; side: tcallercallee; def: tdef): tcgpara;override; @@ -75,16 +75,17 @@ implementation end; - procedure TSparcParaManager.GetIntParaLoc(calloption : tproccalloption; nr : longint;var cgpara : tcgpara); + procedure TSparcParaManager.GetIntParaLoc(calloption : tproccalloption; nr : longint; def : tdef; var cgpara : tcgpara); var paraloc : pcgparalocation; begin if nr<1 then InternalError(2002100806); cgpara.reset; - cgpara.size:=OS_ADDR; - cgpara.intsize:=sizeof(pint); + cgpara.size:=def_cgsize(def); + cgpara.intsize:=tcgsize2size[cgpara.size]; cgpara.alignment:=std_param_align; + cgpara.def:=def; paraloc:=cgpara.add_location; with paraloc^ do begin @@ -150,38 +151,8 @@ implementation paraloc : pcgparalocation; retcgsize : tcgsize; begin - result.init; - result.alignment:=get_para_align(p.proccalloption); - { void has no location } - if is_void(def) then - begin - paraloc:=result.add_location; - result.size:=OS_NO; - result.intsize:=0; - paraloc^.size:=OS_NO; - paraloc^.loc:=LOC_VOID; - exit; - end; - { Constructors return self instead of a boolean } - if (p.proctypeoption=potype_constructor) then - begin - retcgsize:=OS_ADDR; - result.intsize:=sizeof(pint); - end - else - begin - retcgsize:=def_cgsize(def); - result.intsize:=def.size; - end; - result.size:=retcgsize; - { Return is passed as var parameter } - if ret_in_param(def,p.proccalloption) then - begin - paraloc:=result.add_location; - paraloc^.loc:=LOC_REFERENCE; - paraloc^.size:=retcgsize; - exit; - end; + if set_common_funcretloc_info(p,def,retcgsize,result) then + exit; paraloc:=result.add_location; { Return in FPU register? } @@ -235,6 +206,7 @@ implementation paraloc : pcgparalocation; i : integer; hp : tparavarsym; + paradef : tdef; paracgsize : tcgsize; hparasupregs : pparasupregs; paralen : longint; @@ -246,10 +218,11 @@ implementation for i:=0 to paras.count-1 do begin hp:=tparavarsym(paras[i]); + paradef:=hp.vardef; { currently only support C-style array of const, there should be no location assigned to the vararg array itself } if (p.proccalloption in [pocall_cdecl,pocall_cppdecl]) and - is_array_of_const(hp.vardef) then + is_array_of_const(paradef) then begin paraloc:=hp.paraloc[side].add_location; { hack: the paraloc must be valid, but is not actually used } @@ -259,20 +232,28 @@ implementation break; end; - if push_addr_param(hp.varspez,hp.vardef,p.proccalloption) then - paracgsize:=OS_ADDR + if push_addr_param(hp.varspez,paradef,p.proccalloption) then + begin + paracgsize:=OS_ADDR; + paradef:=getpointerdef(paradef); + end else begin - paracgsize:=def_cgSize(hp.vardef); + paracgsize:=def_cgsize(paradef); + { for formaldef } if paracgsize=OS_NO then - paracgsize:=OS_ADDR; + begin + paracgsize:=OS_ADDR; + paradef:=voidpointertype; + end; end; hp.paraloc[side].reset; hp.paraloc[side].size:=paracgsize; + hp.paraloc[side].def:=paradef; if (side = callerside) then hp.paraloc[side].Alignment:=std_param_align else - hp.paraloc[side].Alignment:=hp.vardef.alignment; + hp.paraloc[side].Alignment:=paradef.alignment; paralen:=tcgsize2size[paracgsize]; hp.paraloc[side].intsize:=paralen; while paralen>0 do diff --git a/mips/compiler/symdef.pas b/mips/compiler/symdef.pas index 45f2f5891a..a6d6ca874c 100644 --- a/mips/compiler/symdef.pas +++ b/mips/compiler/symdef.pas @@ -635,6 +635,10 @@ interface {$ifdef i386} fpu_used : byte; {$endif i386} +{$ifdef mips} + { needed for stabs debugging } + total_local_size : longint; +{$endif mips} visibility : tvisibility; { set to a value different from tsk_none in case this procdef is for a routine that has to be internally generated by the compiler } diff --git a/mips/compiler/symtable.pas b/mips/compiler/symtable.pas index 2d5dfc4978..627c01ddc8 100644 --- a/mips/compiler/symtable.pas +++ b/mips/compiler/symtable.pas @@ -2402,6 +2402,8 @@ implementation hashedid : THashedIDString; orgclass : tobjectdef; i : longint; + hlpsrsym : tsym; + hlpsrsymtable : tsymtable; begin orgclass:=classh; { in case this is a formal class, first find the real definition } @@ -2454,11 +2456,13 @@ implementation end else begin + hlpsrsym:=nil; + hlpsrsymtable:=nil; while assigned(classh) do begin { search for a class helper method first if this is an Object - Pascal class } - if is_class(classh) and searchhelper then + Pascal class and we haven't yet found a helper symbol } + if is_class(classh) and searchhelper and not assigned(hlpsrsym) then begin result:=search_objectpascal_helper(classh,contextclassh,s,srsym,srsymtable); if result then @@ -2467,7 +2471,14 @@ implementation searching for overloads } if (srsym.typ<>procsym) or not (sp_has_overloaded in tprocsym(srsym).symoptions) then - exit; + exit + else + begin + { remember the found symbol if the class hierarchy + should not contain the a method with that name } + hlpsrsym:=srsym; + hlpsrsymtable:=srsymtable; + end; end; srsymtable:=classh.symtable; srsym:=tsym(srsymtable.FindWithHash(hashedid)); @@ -2480,6 +2491,15 @@ implementation end; classh:=classh.childof; end; + { did we find a helper symbol, but no symbol with the same name in + the extended object's hierarchy? } + if assigned(hlpsrsym) then + begin + srsym:=hlpsrsym; + srsymtable:=hlpsrsymtable; + result:=true; + exit; + end; end; if is_objcclass(orgclass) then result:=search_objc_helper(orgclass,s,srsym,srsymtable) @@ -2493,8 +2513,12 @@ implementation function searchsym_in_record(recordh:tabstractrecorddef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean; var hashedid : THashedIDString; + hlpsrsym : tsym; + hlpsrsymtable : tsymtable; begin result:=false; + hlpsrsym:=nil; + hlpsrsymtable:=nil; hashedid.id:=s; { search for a record helper method first } result:=search_objectpascal_helper(recordh,recordh,s,srsym,srsymtable); @@ -2504,7 +2528,14 @@ implementation searching for overloads } if (srsym.typ<>procsym) or not (sp_has_overloaded in tprocsym(srsym).symoptions) then - exit; + exit + else + begin + { remember the found symbol if we should not find a symbol with + the same name in the extended record } + hlpsrsym:=srsym; + hlpsrsymtable:=srsymtable; + end; srsymtable:=recordh.symtable; srsym:=tsym(srsymtable.FindWithHash(hashedid)); if assigned(srsym) and is_visible_for_object(srsym,recordh) then @@ -2513,8 +2544,9 @@ implementation result:=true; exit; end; - srsym:=nil; - srsymtable:=nil; + srsym:=hlpsrsym; + srsymtable:=hlpsrsymtable; + result:=assigned(srsym); end; function searchsym_in_class_by_msgint(classh:tobjectdef;msgid:longint;out srdef : tdef;out srsym:tsym;out srsymtable:TSymtable):boolean; diff --git a/mips/compiler/systems/i_linux.pas b/mips/compiler/systems/i_linux.pas index cfd4c4f3a8..92e3ffa021 100644 --- a/mips/compiler/systems/i_linux.pas +++ b/mips/compiler/systems/i_linux.pas @@ -966,11 +966,11 @@ initialization set_source_info(system_arm_linux_info); {$endif linux} {$endif CPUARM} -{$ifdef CPUMIPS} +{$ifdef CPUMIPSEB} {$ifdef linux} set_source_info(system_mipseb_linux_info); {$endif linux} -{$endif CPUMIPS} +{$endif CPUMIPSEB} {$ifdef CPUMIPSEL} {$ifdef linux} set_source_info(system_mipsel_linux_info); diff --git a/mips/compiler/systems/t_go32v2.pas b/mips/compiler/systems/t_go32v2.pas index 831611ae11..6a95d72347 100644 --- a/mips/compiler/systems/t_go32v2.pas +++ b/mips/compiler/systems/t_go32v2.pas @@ -164,7 +164,7 @@ implementation Concat(' OBJSECTION .stabstr'); Concat('ENDEXESECTION'); { DWARF 2 } - ConcatGenericSections('.debug_aranges,.debug_pubnames,.debug_info,.debug_abbrev,'+ + ScriptAddGenericSections('.debug_aranges,.debug_pubnames,.debug_info,.debug_abbrev,'+ '.debug_line,.debug_frame,.debug_str,.debug_loc,.debug_macinfo'); Concat('STABS'); Concat('SYMBOLS'); diff --git a/mips/compiler/systems/t_linux.pas b/mips/compiler/systems/t_linux.pas index 75ec90b091..b27e326a6f 100644 --- a/mips/compiler/systems/t_linux.pas +++ b/mips/compiler/systems/t_linux.pas @@ -40,11 +40,11 @@ interface procedure setfininame(list: TAsmList; const s: string); override; end; + TLibcType=(libc5,glibc2,glibc21,uclibc); + tlinkerlinux=class(texternallinker) private - libctype:(libc5,glibc2,glibc21,uclibc); - cprtobj, - gprtobj, + libctype: TLibcType; prtobj : string[80]; reorder : boolean; linklibc: boolean; @@ -108,9 +108,8 @@ implementation TLINKERLINUX *****************************************************************************} -Constructor TLinkerLinux.Create; +procedure SetupLibrarySearchPath; begin - Inherited Create; if not Dontlinkstdlibpath Then {$ifdef x86_64} LibrarySearchPath.AddPath(sysrootpath,'/lib64;/usr/lib64;/usr/X11R6/lib64',true); @@ -123,128 +122,151 @@ begin {$endif x86_64} end; - -procedure TLinkerLinux.SetDefaultInfo; -{ - This will also detect which libc version will be used -} - -const -{$ifdef i386} platform_select='-b elf32-i386 -m elf_i386';{$endif} -{$ifdef x86_64} platform_select='-b elf64-x86-64 -m elf_x86_64';{$endif} -{$ifdef powerpc} platform_select='-b elf32-powerpc -m elf32ppclinux';{$endif} -{$ifdef POWERPC64} platform_select='-b elf64-powerpc -m elf64ppc';{$endif} -{$ifdef sparc} platform_select='-b elf32-sparc -m elf32_sparc';{$endif} -{$ifdef arm} platform_select='';{$endif} {unknown :( } -{$ifdef m68k} platform_select='';{$endif} {unknown :( } -{$ifdef mips} - {$ifdef mipsel} - platform_select='-EL'; - {$else} - platform_select='-EB'; - {$endif} -{$endif} - - -var - defdynlinker: string; -begin - with Info do - begin - ExeCmd[1]:='ld '+platform_select+' $OPT $DYNLINK $STATIC $GCSECTIONS $STRIP -L. -o $EXE'; - { when we want to cross-link we need to override default library paths } - if length(sysrootpath) > 0 then - ExeCmd[1]:=ExeCmd[1]+' -T'; - ExeCmd[1]:=ExeCmd[1]+' $RES'; - DllCmd[1]:='ld '+platform_select+' $OPT $INIT $FINI $SONAME -shared -L. -o $EXE $RES'; - DllCmd[2]:='strip --strip-unneeded $EXE'; - ExtDbgCmd[1]:='objcopy --only-keep-debug $EXE $DBG'; - ExtDbgCmd[2]:='objcopy --add-gnu-debuglink=$DBG $EXE'; - ExtDbgCmd[3]:='strip --strip-unneeded $EXE'; - {$ifdef m68k} - { experimental, is this correct? } - defdynlinker:='/lib/ld-linux.so.2'; + { experimental, is this correct? } + const defdynlinker='/lib/ld-linux.so.2'; {$endif m68k} {$ifdef i386} - defdynlinker:='/lib/ld-linux.so.2'; + const defdynlinker='/lib/ld-linux.so.2'; {$endif} {$ifdef x86_64} - defdynlinker:='/lib64/ld-linux-x86-64.so.2'; + const defdynlinker='/lib64/ld-linux-x86-64.so.2'; {$endif x86_64} {$ifdef sparc} - defdynlinker:='/lib/ld-linux.so.2'; + const defdynlinker='/lib/ld-linux.so.2'; {$endif sparc} {$ifdef powerpc} - defdynlinker:='/lib/ld.so.1'; + const defdynlinker='/lib/ld.so.1'; {$endif powerpc} {$ifdef powerpc64} - defdynlinker:='/lib64/ld64.so.1'; + const defdynlinker='/lib64/ld64.so.1'; {$endif powerpc64} {$ifdef arm} {$ifdef FPC_ARMHF} - defdynlinker:='/lib/arm-linux-gnueabihf/ld-linux.so.3'; + const defdynlinker='/lib/arm-linux-gnueabihf/ld-linux.so.3'; {$else FPC_ARMHF} {$ifdef FPC_ARMEL} - defdynlinker:='/lib/ld-linux.so.3'; + const defdynlinker='/lib/ld-linux.so.3'; {$else FPC_ARMEL} - defdynlinker:='/lib/ld-linux.so.2'; + const defdynlinker='/lib/ld-linux.so.2'; {$endif FPC_ARMEL} {$endif FPC_ARMHF} {$endif arm} {$ifdef mips} - defdynlinker:='/lib/ld.so.1'; + const defdynlinker='/lib/ld.so.1'; {$endif mips} - { - Search order: - glibc 2.1+ - uclibc - glibc 2.0 - If none is found (e.g. when cross compiling) glibc21 is assumed - } - if fileexists(sysrootpath+defdynlinker,false) then - begin - DynamicLinker:=defdynlinker; + +procedure SetupDynlinker(out DynamicLinker:string;out libctype:TLibcType); +begin + { + Search order: + glibc 2.1+ + uclibc + glibc 2.0 + If none is found (e.g. when cross compiling) glibc21 is assumed + } + if fileexists(sysrootpath+defdynlinker,false) then + begin + DynamicLinker:=defdynlinker; {$ifdef i386} - libctype:=glibc21; + libctype:=glibc21; {$else i386} - libctype:=glibc2; + libctype:=glibc2; {$endif i386} - end - else if fileexists(sysrootpath+'/lib/ld-uClibc.so.0',false) then - begin - dynamiclinker:='/lib/ld-uClibc.so.0'; - libctype:=uclibc; - end + end + else if fileexists(sysrootpath+'/lib/ld-uClibc.so.0',false) then + begin + DynamicLinker:='/lib/ld-uClibc.so.0'; + libctype:=uclibc; + end {$ifdef i386} - else if FileExists(sysrootpath+'/lib/ld-linux.so.1',false) then - begin - DynamicLinker:='/lib/ld-linux.so.1'; - libctype:=glibc2; - end + else if FileExists(sysrootpath+'/lib/ld-linux.so.1',false) then + begin + DynamicLinker:='/lib/ld-linux.so.1'; + libctype:=glibc2; + end {$endif i386} - else - begin - { when no dyn. linker is found, we are probably - cross compiling, so use the default dyn. linker } - DynamicLinker:=defdynlinker; - { - the default c startup script is gcrt0.as on all platforms - except i386 - } + else + begin + { when no dyn. linker is found, we are probably + cross compiling, so use the default dyn. linker } + DynamicLinker:=defdynlinker; + { + the default c startup script is gcrt0.as on all platforms + except i386 + } {$ifdef i386} - libctype:=glibc21; + libctype:=glibc21; {$else i386} - libctype:=glibc2; + libctype:=glibc2; {$endif i386} - end; + end; +end; + +function ModulesLinkToLibc:boolean; +var + hp: tmodule; +begin + result:=false; + hp:=tmodule(loaded_units.first); + while assigned(hp) do + begin + result:=hp.linkothersharedlibs.find('c'); + if result then break; + hp:=tmodule(hp.next); + end; +end; + +Constructor TLinkerLinux.Create; +begin + Inherited Create; + SetupLibrarySearchPath; +end; + +procedure TLinkerLinux.SetDefaultInfo; +{ + This will also detect which libc version will be used +} + +const +{$ifdef i386} platform_select='-b elf32-i386 -m elf_i386';{$endif} +{$ifdef x86_64} platform_select='-b elf64-x86-64 -m elf_x86_64';{$endif} +{$ifdef powerpc} platform_select='-b elf32-powerpc -m elf32ppclinux';{$endif} +{$ifdef POWERPC64} platform_select='-b elf64-powerpc -m elf64ppc';{$endif} +{$ifdef sparc} platform_select='-b elf32-sparc -m elf32_sparc';{$endif} +{$ifdef arm} platform_select='';{$endif} {unknown :( } +{$ifdef m68k} platform_select='';{$endif} {unknown :( } +{$ifdef mips} + {$ifdef mipsel} + platform_select='-EL'; + {$else} + platform_select='-EB'; + {$endif} +{$endif} + + +begin + with Info do + begin + ExeCmd[1]:='ld '+platform_select+' $OPT $DYNLINK $STATIC $GCSECTIONS $STRIP -L. -o $EXE'; + { when we want to cross-link we need to override default library paths } + if length(sysrootpath) > 0 then + ExeCmd[1]:=ExeCmd[1]+' -T'; + ExeCmd[1]:=ExeCmd[1]+' $RES'; + DllCmd[1]:='ld '+platform_select+' $OPT $INIT $FINI $SONAME -shared -L. -o $EXE $RES'; + DllCmd[2]:='strip --strip-unneeded $EXE'; + ExtDbgCmd[1]:='objcopy --only-keep-debug $EXE $DBG'; + ExtDbgCmd[2]:='objcopy --add-gnu-debuglink=$DBG $EXE'; + ExtDbgCmd[3]:='strip --strip-unneeded $EXE'; + + SetupDynlinker(DynamicLinker,libctype); end; end; @@ -263,70 +285,39 @@ Begin end; End; +type + tlibcnames=array [TLibcType] of string[8]; + +const { libc5 glibc2 glibc21 uclibc } + cprtnames: tlibcnames = ('cprt0', 'cprt0', 'cprt21', 'ucprt0'); + csinames: tlibcnames = ('si_c', 'si_c', 'si_c21', 'si_uc'); + gprtnames: tlibcnames = ('gprt0', 'gprt0', 'gprt21', 'ugprt0'); + gsinames: tlibcnames = ('si_g', 'si_g', 'si_c21g','si_ucg'); + + defprtnames: array[boolean] of string[8] = ('prt0', 'dllprt0'); + defsinames: array[boolean] of string[8] = ('si_prc','si_dll'); + +{ uclibc and glibc21 are not available on x86_64! si_g is also absent. } Procedure TLinkerLinux.InitSysInitUnitName; -var - csysinitunit, - gsysinitunit : string[20]; - hp : tmodule; begin - hp:=tmodule(loaded_units.first); - while assigned(hp) do - begin - linklibc := hp.linkothersharedlibs.find('c'); - if linklibc then break; - hp:=tmodule(hp.next); - end; - reorder := linklibc and ReOrderEntries; + linklibc:=ModulesLinkToLibc; + reorder:=linklibc and ReOrderEntries; + sysinitunit:=defsinames[current_module.islibrary]; + prtobj:=defprtnames[current_module.islibrary]; + if current_module.islibrary then - begin - sysinitunit:='dll'; - csysinitunit:='dll'; - gsysinitunit:='dll'; - prtobj:='dllprt0'; - cprtobj:='dllprt0'; - gprtobj:='dllprt0'; - end - else - begin - prtobj:='prt0'; - sysinitunit:='prc'; - case libctype of - glibc21: - begin - cprtobj:='cprt21'; - gprtobj:='gprt21'; - csysinitunit:='c21'; - gsysinitunit:='c21g'; - end; - uclibc: - begin - cprtobj:='ucprt0'; - gprtobj:='ugprt0'; - csysinitunit:='uc'; - gsysinitunit:='ucg'; - end - else - cprtobj:='cprt0'; - gprtobj:='gprt0'; - csysinitunit:='c'; - gsysinitunit:='g'; - end; - end; + exit; if cs_profile in current_settings.moduleswitches then - begin - prtobj:=gprtobj; - sysinitunit:=gsysinitunit; - linklibc:=true; - end - else - begin - if linklibc then - begin - prtobj:=cprtobj; - sysinitunit:=csysinitunit; - end; - end; - sysinitunit:='si_'+sysinitunit; + begin + prtobj:=gprtnames[libctype]; + sysinitunit:=gsinames[libctype]; + linklibc:=true; + end + else if linklibc then + begin + prtobj:=cprtnames[libctype]; + sysinitunit:=csinames[libctype]; + end; end; Function TLinkerLinux.WriteResponseFile(isdll:boolean) : Boolean; diff --git a/mips/compiler/systems/t_win.pas b/mips/compiler/systems/t_win.pas index 11dde31245..b43cd6442f 100644 --- a/mips/compiler/systems/t_win.pas +++ b/mips/compiler/systems/t_win.pas @@ -939,31 +939,10 @@ implementation procedure TInternalLinkerWin.DefaultLinkScript; - var - s,s2 : TCmdStr; begin + ScriptAddSourceStatements(true); with LinkScript do begin - while not ObjectFiles.Empty do - begin - s:=ObjectFiles.GetFirst; - if s<>'' then - Concat('READOBJECT '+MaybeQuoted(s)); - end; - while not StaticLibFiles.Empty do - begin - s:=StaticLibFiles.GetFirst; - if s<>'' then - Concat('READSTATICLIBRARY '+MaybeQuoted(s)); - end; - While not SharedLibFiles.Empty do - begin - S:=SharedLibFiles.GetFirst; - if FindLibraryFile(s,target_info.staticClibprefix,target_info.staticClibext,s2) then - Concat('READSTATICLIBRARY '+MaybeQuoted(s2)) - else - Comment(V_Error,'Import library not found for '+S); - end; if IsSharedLibrary then Concat('ISSHAREDLIBRARY'); ConcatEntryName; @@ -1079,7 +1058,7 @@ implementation Concat(' OBJSECTION .idata$6*'); Concat(' OBJSECTION .idata$7*'); Concat('ENDEXESECTION'); - ConcatGenericSections('.edata,.rsrc,.reloc,.gnu_debuglink,'+ + ScriptAddGenericSections('.edata,.rsrc,.reloc,.gnu_debuglink,'+ '.debug_aranges,.debug_pubnames,.debug_info,.debug_abbrev,.debug_line,.debug_frame,.debug_str,.debug_loc,'+ '.debug_macinfo,.debug_weaknames,.debug_funcnames,.debug_typenames,.debug_varnames,.debug_ranges'); { Can't use the generic rules, because that will add also .stabstr to .stab } diff --git a/mips/compiler/utils/Makefile b/mips/compiler/utils/Makefile index e0d3110da2..a7db00e717 100644 --- a/mips/compiler/utils/Makefile +++ b/mips/compiler/utils/Makefile @@ -1,8 +1,8 @@ # -# Don't edit, this file is generated by FPCMake Version 2.0.0 [2012/04/25] +# Don't edit, this file is generated by FPCMake Version 2.0.0 [2012/06/14] # default: all -MAKEFILETARGETS=i386-linux i386-go32v2 i386-win32 i386-os2 i386-freebsd i386-beos i386-haiku i386-netbsd i386-solaris i386-qnx i386-netware i386-openbsd i386-wdosx i386-darwin i386-emx i386-watcom i386-netwlibc i386-wince i386-embedded i386-symbian i386-nativent i386-iphonesim m68k-linux m68k-freebsd m68k-netbsd m68k-amiga m68k-atari m68k-openbsd m68k-palmos m68k-embedded powerpc-linux powerpc-netbsd powerpc-amiga powerpc-macos powerpc-darwin powerpc-morphos powerpc-embedded powerpc-wii powerpc-aix sparc-linux sparc-netbsd sparc-solaris sparc-embedded x86_64-linux x86_64-freebsd x86_64-netbsd x86_64-solaris x86_64-openbsd x86_64-darwin x86_64-win64 x86_64-embedded arm-linux arm-palmos arm-darwin arm-wince arm-gba arm-nds arm-embedded arm-symbian powerpc64-linux powerpc64-darwin powerpc64-embedded powerpc64-aix avr-embedded armeb-linux armeb-embedded mipseb-linux mipsel-linux jvm-java jvm-android +MAKEFILETARGETS=i386-linux i386-go32v2 i386-win32 i386-os2 i386-freebsd i386-beos i386-haiku i386-netbsd i386-solaris i386-qnx i386-netware i386-openbsd i386-wdosx i386-darwin i386-emx i386-watcom i386-netwlibc i386-wince i386-embedded i386-symbian i386-nativent i386-iphonesim m68k-linux m68k-freebsd m68k-netbsd m68k-amiga m68k-atari m68k-openbsd m68k-palmos m68k-embedded powerpc-linux powerpc-netbsd powerpc-amiga powerpc-macos powerpc-darwin powerpc-morphos powerpc-embedded powerpc-wii powerpc-aix sparc-linux sparc-netbsd sparc-solaris sparc-embedded x86_64-linux x86_64-freebsd x86_64-netbsd x86_64-solaris x86_64-openbsd x86_64-darwin x86_64-win64 x86_64-embedded arm-linux arm-palmos arm-darwin arm-wince arm-gba arm-nds arm-embedded arm-symbian powerpc64-linux powerpc64-darwin powerpc64-embedded powerpc64-aix avr-embedded armeb-linux armeb-embedded mips-linux mipsel-linux jvm-java jvm-android BSDs = freebsd netbsd openbsd darwin UNIXs = linux $(BSDs) solaris qnx haiku aix LIMIT83fs = go32v2 os2 emx watcom @@ -492,7 +492,7 @@ endif ifeq ($(FULL_TARGET),armeb-embedded) override TARGET_PROGRAMS+=fpc ppufiles ppudump ppumove fpcsubst mkarmins mkx86ins endif -ifeq ($(FULL_TARGET),mipseb-linux) +ifeq ($(FULL_TARGET),mips-linux) override TARGET_PROGRAMS+=fpc ppufiles ppudump ppumove fpcsubst mkarmins mkx86ins endif ifeq ($(FULL_TARGET),mipsel-linux) @@ -702,7 +702,7 @@ endif ifeq ($(FULL_TARGET),armeb-embedded) override CLEAN_UNITS+=ppu crc usubst endif -ifeq ($(FULL_TARGET),mipseb-linux) +ifeq ($(FULL_TARGET),mips-linux) override CLEAN_UNITS+=ppu crc usubst endif ifeq ($(FULL_TARGET),mipsel-linux) @@ -913,7 +913,7 @@ endif ifeq ($(FULL_TARGET),armeb-embedded) override COMPILER_UNITDIR+=.. endif -ifeq ($(FULL_TARGET),mipseb-linux) +ifeq ($(FULL_TARGET),mips-linux) override COMPILER_UNITDIR+=.. endif ifeq ($(FULL_TARGET),mipsel-linux) @@ -1123,7 +1123,7 @@ endif ifeq ($(FULL_TARGET),armeb-embedded) override COMPILER_SOURCEDIR+=.. endif -ifeq ($(FULL_TARGET),mipseb-linux) +ifeq ($(FULL_TARGET),mips-linux) override COMPILER_SOURCEDIR+=.. endif ifeq ($(FULL_TARGET),mipsel-linux) @@ -1946,7 +1946,7 @@ endif ifeq ($(FULL_TARGET),armeb-embedded) REQUIRE_PACKAGES_RTL=1 endif -ifeq ($(FULL_TARGET),mipseb-linux) +ifeq ($(FULL_TARGET),mips-linux) REQUIRE_PACKAGES_RTL=1 endif ifeq ($(FULL_TARGET),mipsel-linux) @@ -2108,17 +2108,12 @@ endif endif ifdef CREATESHARED override FPCOPT+=-Cg -ifeq ($(CPU_TARGET),i386) -override FPCOPT+=-Aas -endif endif -ifeq ($(findstring 2.0.,$(FPC_VERSION)),) ifneq ($(findstring $(OS_TARGET),freebsd openbsd netbsd linux solaris),) ifeq ($(CPU_TARGET),x86_64) override FPCOPT+=-Cg endif endif -endif ifdef LINKSHARED endif ifdef OPT diff --git a/mips/compiler/utils/fpc.pp b/mips/compiler/utils/fpc.pp index 4108b8e479..a6502f34c9 100644 --- a/mips/compiler/utils/fpc.pp +++ b/mips/compiler/utils/fpc.pp @@ -155,6 +155,15 @@ program fpc; ppcbin:='ppcx64'; processorname:='x86_64'; {$endif x86_64} +{$ifdef mipsel} + ppcbin:='ppcmipsel'; + processorname:='mipsel'; +{$else : not mipsel} + {$ifdef mips} + ppcbin:='ppcmips'; + processorname:='mips'; + {$endif mips} +{$endif not mipsel} versionstr:=''; { Default is just the name } if ParamCount = 0 then begin @@ -201,8 +210,8 @@ program fpc; cpusuffix:='386' else if processorstr='m68k' then cpusuffix:='68k' - else if processorstr='mipseb' then - cpusuffix:='mipseb' + else if processorstr='mips' then + cpusuffix:='mips' else if processorstr='mipsel' then cpusuffix:='mipsel' else if processorstr='powerpc' then diff --git a/mips/compiler/verbose.pas b/mips/compiler/verbose.pas index 12f013ef60..a3ebef5e91 100644 --- a/mips/compiler/verbose.pas +++ b/mips/compiler/verbose.pas @@ -512,11 +512,35 @@ implementation i:=j-1; end; 'w','W' : - status.errorwarning:=true; + begin + if (i<length(s)) and (s[i+1]='-') then + begin + inc(i); + status.errorwarning:=false; + end + else + status.errorwarning:=true; + end; 'n','N' : - status.errornote:=true; + begin + if (i<length(s)) and (s[i+1]='-') then + begin + inc(i); + status.errornote:=false; + end + else + status.errornote:=true; + end; 'h','H' : - status.errorhint:=true; + begin + if (i<length(s)) and (s[i+1]='-') then + begin + inc(i); + status.errorhint:=false; + end + else + status.errorhint:=true; + end; end; end; end; diff --git a/mips/compiler/version.pas b/mips/compiler/version.pas index 0faa32d813..2d8198405a 100644 --- a/mips/compiler/version.pas +++ b/mips/compiler/version.pas @@ -72,7 +72,7 @@ interface source_cpu_string = 'arm'; {$endif cpuarm} {$ifdef cpumipseb} - source_cpu_string = 'mipseb'; + source_cpu_string = 'mips'{'mipseb'}; {$endif cpumipseb} {$ifdef cpumipsel} source_cpu_string = 'mipsel'; diff --git a/mips/compiler/x86/aasmcpu.pas b/mips/compiler/x86/aasmcpu.pas index dc7d7cee8a..ce1f95e493 100644 --- a/mips/compiler/x86/aasmcpu.pas +++ b/mips/compiler/x86/aasmcpu.pas @@ -1038,8 +1038,11 @@ implementation begin currsym:=objdata.symbolref(ref^.symbol); l:=ref^.offset; +{$push} +{$r-} if assigned(currsym) then inc(l,currsym.address); +{$pop} { when it is a forward jump we need to compensate the offset of the instruction since the previous time, because the symbol address is then still using the @@ -2212,8 +2215,11 @@ implementation begin getvalsym(c-40); data:=currval-insend; +{$push} +{$r-} if assigned(currsym) then inc(data,currsym.address); +{$pop} if (data>127) or (data<-128) then Message1(asmw_e_short_jmp_out_of_range,tostr(data)); objdata.writebytes(data,1); diff --git a/mips/compiler/x86/agx86int.pas b/mips/compiler/x86/agx86int.pas index be4cdbe50f..05c9d3ab27 100644 --- a/mips/compiler/x86/agx86int.pas +++ b/mips/compiler/x86/agx86int.pas @@ -902,7 +902,7 @@ implementation hal : tasmlisttype; begin {$ifdef EXTDEBUG} - if assigned(current_module.mainsource) then + if current_module.mainsource<>'' then comment(v_info,'Start writing intel-styled assembler output for '+current_module.mainsource); {$endif} if target_asm.id<>as_x86_64_masm then @@ -943,7 +943,7 @@ implementation AsmLn; {$ifdef EXTDEBUG} - if assigned(current_module.mainsource) then + if current_module.mainsource<>'' then comment(v_info,'Done writing intel-styled assembler output for '+current_module.mainsource); {$endif EXTDEBUG} end; diff --git a/mips/compiler/x86/agx86nsm.pas b/mips/compiler/x86/agx86nsm.pas index 365900910f..43f5f68408 100644 --- a/mips/compiler/x86/agx86nsm.pas +++ b/mips/compiler/x86/agx86nsm.pas @@ -1015,7 +1015,7 @@ interface hal : tasmlisttype; begin {$ifdef EXTDEBUG} - if assigned(current_module.mainsource) then + if current_module.mainsource<>'' then comment(v_info,'Start writing nasm-styled assembler output for '+current_module.mainsource); {$endif} AsmWriteLn('BITS 32'); @@ -1037,7 +1037,7 @@ interface FreeExternChainList; end; {$ifdef EXTDEBUG} - if assigned(current_module.mainsource) then + if current_module.mainsource<>'' then comment(v_info,'Done writing nasm-styled assembler output for '+current_module.mainsource); {$endif EXTDEBUG} end; diff --git a/mips/compiler/x86/cgx86.pas b/mips/compiler/x86/cgx86.pas index e9d4483879..2c5f2ce3b4 100644 --- a/mips/compiler/x86/cgx86.pas +++ b/mips/compiler/x86/cgx86.pas @@ -266,6 +266,8 @@ unit cgx86; procedure tcgx86.inc_fpu_stack; begin + if rgfpu.fpuvaroffset>=7 then + internalerror(2012062901); inc(rgfpu.fpuvaroffset); end; diff --git a/mips/compiler/x86/cpubase.pas b/mips/compiler/x86/cpubase.pas index 056e571cf7..6b300e1597 100644 --- a/mips/compiler/x86/cpubase.pas +++ b/mips/compiler/x86/cpubase.pas @@ -65,9 +65,6 @@ uses *****************************************************************************} const - { Invalid register number } - RS_INVALID = $ff; - { Integer Super registers } RS_RAX = $00; {EAX} RS_RCX = $01; {ECX} diff --git a/mips/compiler/x86/nx86inl.pas b/mips/compiler/x86/nx86inl.pas index c609b332ce..b08ca6d007 100644 --- a/mips/compiler/x86/nx86inl.pas +++ b/mips/compiler/x86/nx86inl.pas @@ -271,6 +271,7 @@ implementation location_reset_ref(location,LOC_REFERENCE,OS_S64,0); tg.GetTemp(current_asmdata.CurrAsmList,resultdef.size,resultdef.alignment,tt_normal,location.reference); emit_ref(A_FISTP,S_IQ,location.reference); + tcgx86(cg).dec_fpu_stack; emit_none(A_FWAIT,S_NO); end; end; @@ -306,6 +307,7 @@ implementation location_reset_ref(location,LOC_REFERENCE,OS_S64,0); tg.GetTemp(current_asmdata.CurrAsmList,resultdef.size,resultdef.alignment,tt_normal,location.reference); emit_ref(A_FISTTP,S_IQ,location.reference); + tcgx86(cg).dec_fpu_stack; end else begin @@ -319,6 +321,7 @@ implementation location_reset_ref(location,LOC_REFERENCE,OS_S64,0); tg.GetTemp(current_asmdata.CurrAsmList,resultdef.size,resultdef.alignment,tt_normal,location.reference); emit_ref(A_FISTP,S_IQ,location.reference); + tcgx86(cg).dec_fpu_stack; emit_ref(A_FLDCW,S_NO,oldcw); emit_none(A_FWAIT,S_NO); tg.UnGetTemp(current_asmdata.CurrAsmList,oldcw); diff --git a/mips/compiler/x86_64/cgcpu.pas b/mips/compiler/x86_64/cgcpu.pas index 8c20107361..99f52b54ca 100644 --- a/mips/compiler/x86_64/cgcpu.pas +++ b/mips/compiler/x86_64/cgcpu.pas @@ -298,8 +298,8 @@ unit cgcpu; end; para1.init; para2.init; - paramanager.getintparaloc(pocall_default,1,para1); - paramanager.getintparaloc(pocall_default,2,para2); + paramanager.getintparaloc(pocall_default,1,voidpointertype,para1); + paramanager.getintparaloc(pocall_default,2,voidpointertype,para2); reference_reset_symbol(href,l,0,1); { TODO: using RSP is correct only while the stack is fixed!! (true now, but will change if/when allocating from stack is implemented) } diff --git a/mips/compiler/x86_64/cpupara.pas b/mips/compiler/x86_64/cpupara.pas index bf785edcfa..eaf74d49cf 100644 --- a/mips/compiler/x86_64/cpupara.pas +++ b/mips/compiler/x86_64/cpupara.pas @@ -42,7 +42,7 @@ unit cpupara; function param_use_paraloc(const cgpara:tcgpara):boolean;override; function push_addr_param(varspez:tvarspez;def : tdef;calloption : tproccalloption) : boolean;override; function ret_in_param(def : tdef;calloption : tproccalloption) : boolean;override; - procedure getintparaloc(calloption : tproccalloption; nr : longint;var cgpara:TCGPara);override; + procedure getintparaloc(calloption : tproccalloption; nr : longint; def : tdef; var cgpara : tcgpara);override; function get_volatile_registers_int(calloption : tproccalloption):tcpuregisterset;override; function get_volatile_registers_mm(calloption : tproccalloption):tcpuregisterset;override; function get_volatile_registers_fpu(calloption : tproccalloption):tcpuregisterset;override; @@ -742,14 +742,15 @@ unit cpupara; end; - procedure tx86_64paramanager.getintparaloc(calloption : tproccalloption; nr : longint;var cgpara:TCGPara); + procedure tx86_64paramanager.getintparaloc(calloption : tproccalloption; nr : longint; def : tdef; var cgpara : tcgpara); var paraloc : pcgparalocation; begin cgpara.reset; - cgpara.size:=OS_ADDR; - cgpara.intsize:=sizeof(pint); + cgpara.size:=def_cgsize(def); + cgpara.intsize:=tcgsize2size[cgpara.size]; cgpara.alignment:=get_para_align(calloption); + cgpara.def:=def; paraloc:=cgpara.add_location; with paraloc^ do begin @@ -809,46 +810,18 @@ unit cpupara; retcgsize : tcgsize; paraloc : pcgparalocation; begin - result.init; - result.alignment:=get_para_align(p.proccalloption); - { void has no location } - if is_void(def) then - begin - paraloc:=result.add_location; - result.size:=OS_NO; - result.intsize:=0; - paraloc^.size:=OS_NO; - paraloc^.loc:=LOC_VOID; - exit; - end; - { Constructors return self instead of a boolean } - if (p.proctypeoption=potype_constructor) then - begin - retcgsize:=OS_ADDR; - result.intsize:=sizeof(pint); - end - else - begin - retcgsize:=def_cgsize(def); - { integer sizes < 32 bit have to be sign/zero extended to 32 bit on - the callee side (caller can expect those bits are valid) } - if (side=calleeside) and - (retcgsize in [OS_8,OS_S8,OS_16,OS_S16]) then - begin - retcgsize:=OS_S32; - result.intsize:=4; - end - else - result.intsize:=def.size; - end; - result.size:=retcgsize; - { Return is passed as var parameter } - if ret_in_param(def,p.proccalloption) then + if set_common_funcretloc_info(p,def,retcgsize,result) then + exit; + + { integer sizes < 32 bit have to be sign/zero extended to 32 bit on + the callee side (caller can expect those bits are valid) } + if (side=calleeside) and + (retcgsize in [OS_8,OS_S8,OS_16,OS_S16]) then begin - paraloc:=result.add_location; - paraloc^.loc:=LOC_REFERENCE; - paraloc^.size:=retcgsize; - exit; + retcgsize:=OS_S32; + result.def:=s32inttype; + result.intsize:=4; + result.size:=retcgsize; end; { Return in FPU register? -> don't use classify_argument(), because @@ -961,6 +934,7 @@ unit cpupara; var intparareg,mmparareg,parasize:longint;varargsparas: boolean); var hp : tparavarsym; + paradef : tdef; paraloc : pcgparalocation; subreg : tsubregister; pushaddr : boolean; @@ -979,19 +953,21 @@ unit cpupara; for i:=0 to paras.count-1 do begin hp:=tparavarsym(paras[i]); - pushaddr:=push_addr_param(hp.varspez,hp.vardef,p.proccalloption); + paradef:=hp.vardef; + pushaddr:=push_addr_param(hp.varspez,paradef,p.proccalloption); if pushaddr then begin loc[1]:=X86_64_INTEGER_CLASS; loc[2]:=X86_64_NO_CLASS; paracgsize:=OS_ADDR; paralen:=sizeof(pint); + paradef:=getpointerdef(paradef); end else begin - getvalueparaloc(hp.varspez,hp.vardef,loc[1],loc[2]); - paralen:=push_size(hp.varspez,hp.vardef,p.proccalloption); - paracgsize:=def_cgsize(hp.vardef); + getvalueparaloc(hp.varspez,paradef,loc[1],loc[2]); + paralen:=push_size(hp.varspez,paradef,p.proccalloption); + paracgsize:=def_cgsize(paradef); { integer sizes < 32 bit have to be sign/zero extended to 32 bit on the caller side } if (side=callerside) and @@ -999,24 +975,27 @@ unit cpupara; begin paracgsize:=OS_S32; paralen:=4; + paradef:=s32inttype; end; end; { cheat for now, we should copy the value to an mm reg as well (FK) } if varargsparas and (target_info.system = system_x86_64_win64) and - (hp.vardef.typ = floatdef) then + (paradef.typ = floatdef) then begin loc[2]:=X86_64_NO_CLASS; if paracgsize=OS_F64 then begin loc[1]:=X86_64_INTEGER_CLASS; - paracgsize:=OS_64 + paracgsize:=OS_64; + paradef:=u64inttype; end else begin loc[1]:=X86_64_INTEGERSI_CLASS; paracgsize:=OS_32; + paradef:=u32inttype; end; end; @@ -1024,6 +1003,7 @@ unit cpupara; hp.paraloc[side].size:=paracgsize; hp.paraloc[side].intsize:=paralen; hp.paraloc[side].Alignment:=paraalign; + hp.paraloc[side].def:=paradef; if paralen>0 then begin { Enough registers free? } diff --git a/mips/ide/fp.pas b/mips/ide/fp.pas index 37a24b54bc..cedc47a803 100644 --- a/mips/ide/fp.pas +++ b/mips/ide/fp.pas @@ -177,8 +177,9 @@ begin 'C' : { custom config file (BP compatiblity) } if BeforeINI then begin + delete(param,1,1); // delete C if (length(Param)>=1) and (Param[1] in['=',':']) then - Delete(Param,1,1); { eat separator } + Delete(Param,1,1); { eat optional separator } IniFileName:=Param; end; 'R' : { enter the directory last exited from (BP comp.) } diff --git a/mips/ide/fpredir.pas b/mips/ide/fpredir.pas index a553911d33..66f8a569ba 100644 --- a/mips/ide/fpredir.pas +++ b/mips/ide/fpredir.pas @@ -79,6 +79,7 @@ const Implementation Uses + sysutils, {$ifdef go32v2} go32, {$endif go32v2} @@ -280,7 +281,8 @@ end; function LocateExeFile(var FileName:string): boolean; var - dir,s,d,n,e : string; + S : AnsiString; + dir,d,n,e : string; i : longint; begin LocateExeFile:=False; @@ -299,7 +301,7 @@ begin Exit; end; - S:=GetEnv('PATH'); + S:=sysutils.GetEnvironmentVariable('PATH'); While Length(S)>0 do begin i:=1; @@ -637,7 +639,8 @@ end; function LocateExeFile(var FileName:string): boolean; var - dir,s,d,n,e : string; + S : AnsiString; + dir,d,n,e : string; i : longint; begin LocateExeFile:=False; @@ -656,7 +659,7 @@ begin Exit; end; - S:=GetEnv('PATH'); + S:=sysutils.GetEnvironmentVariable('PATH'); While Length(S)>0 do begin i:=1; diff --git a/mips/ide/fputils.pas b/mips/ide/fputils.pas index 1000e86570..25f89a2966 100644 --- a/mips/ide/fputils.pas +++ b/mips/ide/fputils.pas @@ -16,11 +16,13 @@ unit FPUtils; interface -uses Objects; +uses + Sysutils, + Objects; const dirsep = System.DirectorySeparator; - + {$ifdef Unix} listsep = [';',':']; exeext = ''; @@ -419,7 +421,8 @@ end; function LocateExeFile(var FileName:string): boolean; var - dir,s : string; + dir : string; + s : ansistring; i : longint; begin LocateExeFile:=False; @@ -429,7 +432,7 @@ begin Exit; end; - S:=GetEnv('PATH'); + S:=sysutils.GetEnvironmentVariable('PATH'); While Length(S)>0 do begin i:=1; diff --git a/mips/packages/fcl-db/src/base/bufdataset.pas b/mips/packages/fcl-db/src/base/bufdataset.pas index 5d88dfcbd5..e271f51d03 100644 --- a/mips/packages/fcl-db/src/base/bufdataset.pas +++ b/mips/packages/fcl-db/src/base/bufdataset.pas @@ -353,7 +353,7 @@ type constructor create(AStream : TStream); virtual; // Load a dataset from stream: // Load the field-definitions from a stream. - procedure LoadFieldDefs(AFieldDefs : TFieldDefs); virtual; abstract; + procedure LoadFieldDefs(AFieldDefs : TFieldDefs; var AnAutoIncValue : integer); virtual; abstract; // Is called before the records are loaded procedure InitLoadRecords; virtual; abstract; // Return the RowState of the current record, and the order of the update @@ -367,7 +367,7 @@ type // Store a dataset to stream: // Save the field-definitions to a stream. - procedure StoreFieldDefs(AFieldDefs : TFieldDefs); virtual; abstract; + procedure StoreFieldDefs(AFieldDefs : TFieldDefs; AnAutoIncValue : integer); virtual; abstract; // Save a record from the current record-buffer to the stream procedure StoreRecord(ADataset : TCustomBufDataset; ARowState : TRowState; AUpdOrder : integer = 0); virtual; abstract; // Is called after all records are stored @@ -381,8 +381,8 @@ type TFpcBinaryDatapacketReader = class(TDataPacketReader) public - procedure LoadFieldDefs(AFieldDefs : TFieldDefs); override; - procedure StoreFieldDefs(AFieldDefs : TFieldDefs); override; + procedure LoadFieldDefs(AFieldDefs : TFieldDefs; var AnAutoIncValue : integer); override; + procedure StoreFieldDefs(AFieldDefs : TFieldDefs; AnAutoIncValue : integer); override; function GetRecordRowState(out AUpdOrder : Integer) : TRowState; override; procedure FinalizeStoreRecords; override; function GetCurrentRecord : boolean; override; @@ -416,6 +416,8 @@ type FOpen : Boolean; FUpdateBuffer : TRecordsUpdateBuffer; FCurrentUpdateBuffer : integer; + FAutoIncValue : longint; + FAutoIncField : TAutoIncField; FIndexDefs : TIndexDefs; @@ -457,7 +459,6 @@ type procedure InitDefaultIndexes; protected procedure UpdateIndexDefs; override; - function GetNewBlobBuffer : PBlobBuffer; function GetNewWriteBlobBuffer : PBlobBuffer; procedure FreeBlobBuffer(var ABlobBuffer: PBlobBuffer); procedure SetRecNo(Value: Longint); override; @@ -523,6 +524,7 @@ type function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; override; procedure AddIndex(const AName, AFields : string; AOptions : TIndexOptions; const ADescFields: string = ''; const ACaseInsFields: string = ''); virtual; + function GetNewBlobBuffer : PBlobBuffer; procedure SetDatasetPacket(AReader : TDataPacketReader); procedure GetDatasetPacket(AWriter : TDataPacketReader); @@ -765,6 +767,7 @@ begin FIndexesCount:=0; FIndexDefs := TIndexDefs.Create(Self); + FAutoIncValue:=-1; SetLength(FUpdateBuffer,0); SetLength(FBlobBuffers,0); @@ -1120,6 +1123,7 @@ var IndexNr : integer; i : integer; begin + FAutoIncField:=nil; if not Assigned(FDatasetReader) and (FileName<>'') then begin FFileStream := TFileStream.Create(FileName,fmOpenRead); @@ -1132,14 +1136,22 @@ begin // reading from a stream in some other way implemented by a descendent) // If there are less fields then FieldDefs we know for sure that the dataset // is not (correctly) created. - if Fields.Count<FieldDefs.Count then - DatabaseError(SErrNoDataset); + + // commented for now. If there are constant expressions in the select + // statement they are ftunknown, and not created. + // See mantis #22030 + + // if Fields.Count<FieldDefs.Count then + // DatabaseError(SErrNoDataset); + // If there is a field with FieldNo=0 then the fields are not found to the // FieldDefs which is a sign that there is no dataset created. (Calculated and - // lookupfields have FielNo=-1) + // lookupfields have FieldNo=-1) for i := 0 to Fields.Count-1 do if fields[i].FieldNo=0 then - DatabaseError(SErrNoDataset); + DatabaseError(SErrNoDataset) + else if (FAutoIncValue>-1) and (fields[i] is TAutoIncField) and not assigned(FAutoIncField) then + FAutoIncField := TAutoIncField(fields[i]); InitDefaultIndexes; CalcRecordSize; @@ -1212,6 +1224,8 @@ begin SetLength(FFieldBufPositions,0); + FAutoIncValue:=-1; + if assigned(FParser) then FreeAndNil(FParser); FReadFromFile:=false; end; @@ -2189,6 +2203,8 @@ Var ABuff : TRecordBuffer; i : integer; blobbuf : tbufblobfield; NullMask : pbyte; + li : longint; + StoreReadOnly: boolean; ABookmark : PBufBookmark; begin @@ -2209,6 +2225,21 @@ begin if State = dsInsert then begin + if assigned(FAutoIncField) then + begin + li := FAutoIncValue; + // In principle all TAutoIncfields are read-only, but in theory it is + // possible to set readonly to false. + StoreReadOnly:=FAutoIncField.ReadOnly; + FAutoIncField.ReadOnly:=false; + try + FAutoIncField.SetData(@li); + finally + FAutoIncField.ReadOnly:=FAutoIncField.ReadOnly; + end; + inc(FAutoIncValue); + end; + // The active buffer is the newly created TDataset record, // from which the bookmark is set to the record where the new record should be // inserted @@ -2650,7 +2681,7 @@ begin try //CheckActive; ABookMark:=@ATBookmark; - FDatasetReader.StoreFieldDefs(FieldDefs); + FDatasetReader.StoreFieldDefs(FieldDefs,FAutoIncValue); StoreDSState:=SetTempState(dsFilter); ScrollResult:=FCurrentIndex.ScrollFirst; @@ -2727,26 +2758,31 @@ begin end; procedure TCustomBufDataset.CreateDataset; +var AStoreFilename: string; + begin CheckInactive; - if not ((FieldCount=0) or (FieldDefs.Count=0)) then + if ((FieldCount=0) or (FieldDefs.Count=0)) then begin - Open; - Exit; + if (FieldDefs.Count>0) then + CreateFields + else if (fields.Count>0) then + begin + InitFieldDefsFromfields; + BindFields(True); + end + else + raise Exception.Create(SErrNoFieldsDefined); + FAutoIncValue:=1; end; - if (FieldDefs.Count>0) then - begin - CreateFields; - Open; - end - else if (fields.Count>0) then - begin - InitFieldDefsFromfields; - BindFields(True); + // When a filename is set, do not read from this file + AStoreFilename:=FFileName; + FFileName := ''; + try Open; - end - else - raise Exception.Create(SErrNoFieldsDefined); + finally + FFileName:=AStoreFilename; + end; end; function TCustomBufDataset.BookmarkValid(ABookmark: TBookmark): Boolean; @@ -2766,8 +2802,12 @@ end; procedure TCustomBufDataset.IntLoadFielddefsFromFile; begin - FDatasetReader.LoadFielddefs(FieldDefs); - if DefaultFields then CreateFields; + FieldDefs.Clear; + FDatasetReader.LoadFielddefs(FieldDefs, FAutoIncValue); + if DefaultFields then + CreateFields + else + BindFields(true); end; procedure TCustomBufDataset.IntLoadRecordsFromFile; @@ -3404,7 +3444,7 @@ end; const FpcBinaryIdent = 'BinBufDataset'; -procedure TFpcBinaryDatapacketReader.LoadFieldDefs(AFieldDefs: TFieldDefs); +procedure TFpcBinaryDatapacketReader.LoadFieldDefs(AFieldDefs: TFieldDefs; var AnAutoIncValue: integer); var FldCount : word; i : integer; @@ -3425,9 +3465,11 @@ begin if Stream.ReadByte = 1 then Attributes := Attributes + [faReadonly]; end; + Stream.ReadBuffer(i,sizeof(i)); + AnAutoIncValue := i; end; -procedure TFpcBinaryDatapacketReader.StoreFieldDefs(AFieldDefs: TFieldDefs); +procedure TFpcBinaryDatapacketReader.StoreFieldDefs(AFieldDefs: TFieldDefs; AnAutoIncValue: integer); var i : integer; begin Stream.Write(FpcBinaryIdent[1],length(FpcBinaryIdent)); @@ -3445,6 +3487,8 @@ begin else Stream.WriteByte(0); end; + i := AnAutoIncValue; + Stream.WriteBuffer(i,sizeof(i)); end; function TFpcBinaryDatapacketReader.GetRecordRowState(out AUpdOrder : Integer) : TRowState; diff --git a/mips/packages/fcl-db/src/base/dataset.inc b/mips/packages/fcl-db/src/base/dataset.inc index a454711166..427c84f319 100644 --- a/mips/packages/fcl-db/src/base/dataset.inc +++ b/mips/packages/fcl-db/src/base/dataset.inc @@ -85,14 +85,8 @@ Procedure TDataset.BindFields(Binding: Boolean); var i, FieldIndex: Integer; FieldDef: TFieldDef; begin - { - Here some magic will be needed later; for now just simply set - Just set fieldno from listindex... - Later we should take it from the fielddefs. - // ATM Set by CreateField ... - For I:=0 to FFieldList.Count-1 do - FFieldList[i].FFieldNo:=I; - } + { FieldNo is set to -1 for calculated/lookup fields, to 0 for unbound field + and for bound fields it is set to FieldDef.FieldNo } FCalcFieldsSize := 0; FBlobFieldCount := 0; for i := 0 to Fields.Count - 1 do @@ -124,7 +118,7 @@ begin FOffset := FBlobFieldCount; Inc(FBlobFieldCount); end; - end else FFieldNo := FieldIndex; + end else FFieldNo := 0; end; end else FFieldNo := 0; end; @@ -910,15 +904,16 @@ begin FieldDefs.BeginUpdate; try for i := 0 to Fields.Count-1 do with fields[i] do - begin - with TFieldDef.Create(FieldDefs,FieldName,DataType,Size,Required,i+1) do + if not (FieldKind in [fkCalculated,fkLookup]) then // Do not add fielddefs for calculated/lookup fields. begin - if Required then Attributes := attributes + [faRequired]; - if ReadOnly then Attributes := attributes + [faReadOnly]; - if DataType = ftBCD then precision := (fields[i] as TBCDField).Precision - else if DataType = ftFMTBcd then precision := (fields[i] as TFMTBCDField).Precision; + with TFieldDef.Create(FieldDefs,FieldName,DataType,Size,Required,FieldDefs.Count+1) do + begin + if Required then Attributes := attributes + [faRequired]; + if ReadOnly then Attributes := attributes + [faReadOnly]; + if DataType = ftBCD then precision := (fields[i] as TBCDField).Precision + else if DataType = ftFMTBcd then precision := (fields[i] as TFMTBCDField).Precision; + end; end; - end; finally FieldDefs.EndUpdate; end; @@ -1822,33 +1817,20 @@ end; Procedure TDataset.GetFieldList(List: TList; const FieldNames: string); - Function NextName(Var S : String) : String; - - Var - P : integer; - - begin - P:=Pos(';',S); - If (P=0) then - P:=Length(S)+1; - Result:=Copy(S,1,P-1); - system.Delete(S,1,P); - end; - var F: TField; - Names,N : String; + N: String; + StrPos: Integer; begin - Names:=FieldNames; - N:=Nextname(Names); - while (N<>'') do - begin - F:=FieldByName(N); - If Assigned(List) then - List.Add(F); - N:=NextName(Names); - end; + if (FieldNames = '') or (List = nil) then + Exit; + StrPos := 1; + repeat + N := ExtractFieldName(FieldNames, StrPos); + F := FieldByName(N); + List.Add(F); + until StrPos > Length(FieldNames); end; Procedure TDataset.GetFieldNames(List: TStrings); diff --git a/mips/packages/fcl-db/src/base/dbconst.pas b/mips/packages/fcl-db/src/base/dbconst.pas index 0ffdb406dc..f8f4a27817 100644 --- a/mips/packages/fcl-db/src/base/dbconst.pas +++ b/mips/packages/fcl-db/src/base/dbconst.pas @@ -111,7 +111,7 @@ Resourcestring SRollBackRetaining = 'Rollback and retaining transaction'; SErrNoFieldsDefined = 'Can not create a dataset when there are no fielddefinitions or fields defined'; SErrApplyUpdBeforeRefresh= 'Must apply updates before refreshing data'; - SErrNoDataset = 'Missing underlying dataset, can not open'; + SErrNoDataset = 'Missing (compatible) underlying dataset, can not open'; Implementation diff --git a/mips/packages/fcl-db/src/base/dsparams.inc b/mips/packages/fcl-db/src/base/dsparams.inc index 601dabb6f7..72d16d0771 100644 --- a/mips/packages/fcl-db/src/base/dsparams.inc +++ b/mips/packages/fcl-db/src/base/dsparams.inc @@ -125,27 +125,20 @@ end; Procedure TParams.GetParamList(List: TList; const ParamNames: string); - Function NextName(Var S : String) : String; - Var - P : Integer; - begin - P:=Pos(';',S); - If (P=0) then - P:=Length(S)+1; - Result:=Copy(S,1,P-1); - system.Delete(S,1,P); - end; - Var - L,N : String; + P: TParam; + N: String; + StrPos: Integer; begin - L:=ParamNames; - While (Length(L)>0) do - begin - N:=NextName(L); - List.Add(ParamByName(N)); - end; + if (ParamNames = '') or (List = nil) then + Exit; + StrPos := 1; + repeat + N := ExtractFieldName(ParamNames, StrPos); + P := ParamByName(N); + List.Add(P); + until StrPos > Length(ParamNames); end; Function TParams.IsEqual(Value: TParams): Boolean; @@ -220,7 +213,8 @@ begin repeat // skip until at end of line Inc(p); until p^ in [#10, #0]; - end + end; + if p^<>#0 then Inc(p); // newline is part of comment end; '/': // possible start of /* */ comment begin diff --git a/mips/packages/fcl-db/src/base/xmldatapacketreader.pp b/mips/packages/fcl-db/src/base/xmldatapacketreader.pp index 94ea8b7c13..ce443f59e0 100644 --- a/mips/packages/fcl-db/src/base/xmldatapacketreader.pp +++ b/mips/packages/fcl-db/src/base/xmldatapacketreader.pp @@ -48,10 +48,10 @@ type FLastChange : integer; public destructor destroy; override; - procedure StoreFieldDefs(AFieldDefs : TFieldDefs); override; + procedure StoreFieldDefs(AFieldDefs : TFieldDefs; AnAutoIncValue : integer); override; procedure StoreRecord(ADataset : TCustomBufDataset; ARowState : TRowState; AUpdOrder : integer = 0); override; procedure FinalizeStoreRecords; override; - procedure LoadFieldDefs(AFieldDefs : TFieldDefs); override; + procedure LoadFieldDefs(AFieldDefs : TFieldDefs; var AnAutoIncValue : integer); override; procedure InitLoadRecords; override; function GetCurrentRecord : boolean; override; function GetRecordRowState(out AUpdOrder : Integer) : TRowState; override; @@ -62,7 +62,7 @@ type implementation -uses xmlwrite, xmlread; +uses xmlwrite, xmlread, base64; const XMLFieldtypenames : Array [TFieldType] of String[15] = @@ -74,21 +74,21 @@ const 'i4', 'boolean', 'r8', - 'r8', + 'r8:Money', 'fixed', 'date', 'time', 'datetime', 'bin.hex', 'bin.hex', - 'i4', - 'bin.hex', - 'bin.hex', - 'bin.hex', - 'bin.hex', - 'bin.hex', - 'bin.hex', - 'bin.hex', + 'i4:Autoinc', + 'bin.hex:Binary', + 'bin.hex:Text', + 'bin.hex:Graphics', + 'bin.hex:Formatted', + 'bin.hex:Ole', + 'bin.hex:Ole', + 'bin.hex:Graphics', '', 'string', 'string', @@ -104,7 +104,7 @@ const '', '', '', - '', + 'fixedFMT', '', '' ); @@ -123,7 +123,7 @@ begin inherited destroy; end; -procedure TXMLDatapacketReader.LoadFieldDefs(AFieldDefs : TFieldDefs); +procedure TXMLDatapacketReader.LoadFieldDefs(AFieldDefs: TFieldDefs; var AnAutoIncValue: integer); function GetNodeAttribute(const aNode : TDOMNode; AttName : String) : string; var AnAttr : TDomNode; @@ -137,7 +137,9 @@ var i : integer; AFieldDef : TFieldDef; iFieldType : TFieldType; FTString : string; + SubFTString : string; AFieldNode : TDOMNode; + AnAutoIncNode: TDomNode; begin ReadXMLFile(XMLDocument,Stream); @@ -160,6 +162,9 @@ begin AFieldDef.Name:=GetNodeAttribute(AFieldNode,'attrname'); AFieldDef.Size:=StrToIntDef(GetNodeAttribute(AFieldNode,'width'),0); FTString:=GetNodeAttribute(AFieldNode,'fieldtype'); + SubFTString:=GetNodeAttribute(AFieldNode,'subtype'); + if SubFTString<>'' then + FTString:=FTString+':'+SubFTString; AFieldDef.DataType:=ftUnknown; for iFieldType:=low(TFieldType) to high(TFieldType) do @@ -171,18 +176,24 @@ begin end; end; - FChangeLogNode := MetaDataNode.FindNode('PARAMS'); - if assigned(FChangeLogNode) then - FChangeLogNode := FChangeLogNode.Attributes.GetNamedItem('CHANGE_LOG'); + FParamsNode := MetaDataNode.FindNode('PARAMS'); + if assigned(FParamsNode) then + begin + FChangeLogNode := FParamsNode.Attributes.GetNamedItem('CHANGE_LOG'); + AnAutoIncNode := FParamsNode.Attributes.GetNamedItem('AUTOINCVALUE'); + if assigned(AnAutoIncNode) then + AnAutoIncValue := StrToIntDef(AnAutoIncNode.NodeValue,-1); + end; FRowDataNode := DataPacketNode.FindNode('ROWDATA'); FRecordNode := nil; end; -procedure TXMLDatapacketReader.StoreFieldDefs(AFieldDefs: TFieldDefs); +procedure TXMLDatapacketReader.StoreFieldDefs(AFieldDefs: TFieldDefs; AnAutoIncValue: integer); -var i : integer; +var i,p : integer; AFieldNode : TDOMElement; + AStringFT : string; begin XMLDocument := TXMLDocument.Create; @@ -198,22 +209,15 @@ begin if Name <> '' then AFieldNode.SetAttribute('fieldname',Name); AFieldNode.SetAttribute('attrname',DisplayName); if size <> 0 then AFieldNode.SetAttribute('width',IntToStr(Size)); - AFieldNode.SetAttribute('fieldtype',XMLFieldtypenames[DataType]); - case DataType of - ftAutoInc : begin - AFieldNode.SetAttribute('readonly','true'); - AFieldNode.SetAttribute('subtype','Autoinc'); - end; - ftCurrency: AFieldNode.SetAttribute('subtype','Money'); - ftVarBytes, - ftBlob : AFieldNode.SetAttribute('subtype','Binary'); - ftMemo : AFieldNode.SetAttribute('subtype','Text'); - ftTypedBinary, - ftGraphic: AFieldNode.SetAttribute('subtype','Graphics'); - ftFmtMemo : AFieldNode.SetAttribute('subtype','Formatted'); - ftParadoxOle, - ftDBaseOle : AFieldNode.SetAttribute('subtype','Ole'); - end; {case} + AStringFT:=XMLFieldtypenames[DataType]; + p := pos(':',AStringFT); + if p > 1 then + begin + AFieldNode.SetAttribute('fieldtype',copy(AStringFT,1,p-1)); + AFieldNode.SetAttribute('subtype',copy(AStringFT,p+1,25)); + end + else + AFieldNode.SetAttribute('fieldtype',AStringFT); if faReadonly in Attributes then AFieldNode.SetAttribute('readonly','true'); FieldsNode.AppendChild(AFieldNode); @@ -221,6 +225,9 @@ begin MetaDataNode.AppendChild(FieldsNode); FParamsNode := XMLDocument.CreateElement('PARAMS'); + if AnAutoIncValue>-1 then + (FParamsNode as TDomElement).SetAttribute('AUTOINCVALUE',IntToStr(AnAutoIncValue)); + MetaDataNode.AppendChild(FParamsNode); DataPacketNode.AppendChild(MetaDataNode); FRowDataNode := XMLDocument.CreateElement('ROWDATA'); @@ -329,28 +336,49 @@ begin end; procedure TXMLDatapacketReader.RestoreRecord(ADataset : TCustomBufDataset); -var FieldNr : integer; - AFieldNode : TDomNode; +var FieldNr : integer; + AFieldNode : TDomNode; + ABufBlobField: TBufBlobField; + AField: TField; + s: string; begin - with ADataset do for FieldNr:=0 to FieldCount-1 do + with ADataset do for FieldNr:=0 to FieldDefs.Count-1 do begin - AFieldNode := FRecordNode.Attributes.GetNamedItem(Fields[FieldNr].FieldName); + AFieldNode := FRecordNode.Attributes.GetNamedItem(FieldDefs[FieldNr].Name); if assigned(AFieldNode) then begin - Fields[FieldNr].AsString := AFieldNode.NodeValue; // set it to the filterbuffer + if FieldDefs[FieldNr].DataType in [ftMemo,ftBlob] then + begin + ABufBlobField.BlobBuffer:=ADataset.GetNewBlobBuffer; + afield := Fields.FieldByNumber(FieldDefs[FieldNr].FieldNo); + AField.SetData(@ABufBlobField); + s := AFieldNode.NodeValue; + if (FieldDefs[FieldNr].DataType = ftBlob) and (s<>'') then + s := DecodeStringBase64(s); + ABufBlobField.BlobBuffer^.Size:=length(s); + ReAllocMem(ABufBlobField.BlobBuffer^.Buffer,ABufBlobField.BlobBuffer^.Size); + move(s[1],ABufBlobField.BlobBuffer^.Buffer^,ABufBlobField.BlobBuffer^.Size); + end + else + Fields.FieldByNumber(FieldDefs[FieldNr].FieldNo).AsString := AFieldNode.NodeValue; // set it to the filterbuffer end end; end; procedure TXMLDatapacketReader.StoreRecord(ADataset : TCustomBufDataset; ARowState : TRowState; AUpdOrder : integer = 0); var FieldNr : Integer; + AField: TField; ARecordNode : TDOMElement; begin inc(FEntryNr); ARecordNode := XMLDocument.CreateElement('ROW'); - for FieldNr := 0 to ADataset.Fields.Count-1 do + for FieldNr := 0 to ADataset.FieldDefs.Count-1 do begin - ARecordNode.SetAttribute(ADataset.fields[FieldNr].FieldName,ADataset.fields[FieldNr].AsString); + AField := ADataset.Fields.FieldByNumber(ADataset.FieldDefs[FieldNr].FieldNo); + if AField.DataType=ftBlob then + ARecordNode.SetAttribute(AField.FieldName,EncodeStringBase64(AField.AsString)) + else + ARecordNode.SetAttribute(AField.FieldName,AField.AsString); end; if ARowState<>[] then begin diff --git a/mips/packages/fcl-db/src/sqldb/mysql/mysqlconn.inc b/mips/packages/fcl-db/src/sqldb/mysql/mysqlconn.inc index 69485ee07a..9dd7f53784 100644 --- a/mips/packages/fcl-db/src/sqldb/mysql/mysqlconn.inc +++ b/mips/packages/fcl-db/src/sqldb/mysql/mysqlconn.inc @@ -530,9 +530,9 @@ begin C:=Cursor as TCursorName; if c.FStatementType in [stSelect,stExecProcedure] then c.FNeedData:=False; - If (C.FRes<>Nil) then + if assigned(C.FRes) then begin - Mysql_free_result(C.FRes); + mysql_free_result(C.FRes); C.FRes:=Nil; end; SetLength(c.MapDSRowToMSQLRow,0); @@ -588,16 +588,15 @@ var ASize, ADecimals: integer; begin Result := True; ASize := AField^.length; + NewSize := 0; case AField^.ftype of FIELD_TYPE_LONGLONG: begin NewType := ftLargeint; - NewSize := 0; end; FIELD_TYPE_TINY, FIELD_TYPE_SHORT, FIELD_TYPE_YEAR: begin NewType := ftSmallint; - NewSize := 0; end; FIELD_TYPE_LONG, FIELD_TYPE_INT24: begin @@ -605,7 +604,6 @@ begin NewType := ftAutoInc else NewType := ftInteger; - NewSize := 0; end; {$ifdef mysql50_up} FIELD_TYPE_NEWDECIMAL, @@ -624,32 +622,25 @@ begin FIELD_TYPE_FLOAT, FIELD_TYPE_DOUBLE: begin NewType := ftFloat; - NewSize := 0; end; FIELD_TYPE_TIMESTAMP, FIELD_TYPE_DATETIME: begin NewType := ftDateTime; - NewSize := 0; end; FIELD_TYPE_DATE: begin NewType := ftDate; - NewSize := 0; end; FIELD_TYPE_TIME: begin NewType := ftTime; - NewSize := 0; end; FIELD_TYPE_VAR_STRING, FIELD_TYPE_STRING, FIELD_TYPE_ENUM, FIELD_TYPE_SET: begin // Since mysql server version 5.0.3 string-fields with a length of more // then 256 characters are suported if ASize>dsMaxStringSize then - begin - NewType := ftMemo; - NewSize := 0; - end + NewType := ftMemo else begin if AField^.ftype = FIELD_TYPE_STRING then @@ -676,8 +667,11 @@ begin {$ELSE} NewType := ftBlob; {$ENDIF} - NewSize := 0; - end + end; +{$IFDEF MYSQL50_UP} + FIELD_TYPE_BIT: + NewType := ftLargeInt; +{$ENDIF} else Result := False; end; @@ -1028,6 +1022,15 @@ begin end; FIELD_TYPE_BLOB: CreateBlob := True; +{$IFDEF MYSQL50_UP} + FIELD_TYPE_BIT: + begin + VL := 0; + for VI := 0 to Len-1 do + VL := VL * 256 + PByte(Source+VI)^; + move(VL, Dest^, sizeof(LargeInt)); + end; +{$ENDIF} end; Result := True; end; diff --git a/mips/packages/fcl-db/src/sqldb/postgres/pqconnection.pp b/mips/packages/fcl-db/src/sqldb/postgres/pqconnection.pp index c335d2457f..c68693921c 100644 --- a/mips/packages/fcl-db/src/sqldb/postgres/pqconnection.pp +++ b/mips/packages/fcl-db/src/sqldb/postgres/pqconnection.pp @@ -39,6 +39,7 @@ type FConnectString : string; FSQLDatabaseHandle : pointer; FIntegerDateTimes : boolean; + procedure CheckResultError(res: PPGresult; conn:PPGconn; ErrMsg: string); function TranslateFldType(res : PPGresult; Tuple : integer; out Size : integer) : TFieldType; procedure ExecuteDirectPG(const Query : String); protected @@ -86,6 +87,15 @@ type Class Function Description : String; override; end; + EPQDatabaseError = class(EDatabaseError) + public + SEVERITY:string; + SQLSTATE: string; + MESSAGE_PRIMARY:string; + MESSAGE_DETAIL:string; + MESSAGE_HINT:string; + STATEMENT_POSITION:string; + end; implementation @@ -179,18 +189,10 @@ begin res := PQexec(ASQLDatabaseHandle,pchar(query)); - if (PQresultStatus(res) <> PGRES_COMMAND_OK) then - begin - msg := PQerrorMessage(ASQLDatabaseHandle); - PQclear(res); - PQFinish(ASQLDatabaseHandle); - DatabaseError(SDBCreateDropFailed + ' (PostgreSQL: ' + Msg + ')',self); - end - else - begin - PQclear(res); - PQFinish(ASQLDatabaseHandle); - end; + CheckResultError(res,ASQLDatabaseHandle,SDBCreateDropFailed); + + PQclear(res); + PQFinish(ASQLDatabaseHandle); {$IfDef LinkDynamically} ReleasePostgres3; {$EndIf} @@ -212,18 +214,12 @@ begin tr := trans as TPQTrans; res := PQexec(tr.PGConn, 'ROLLBACK'); - if (PQresultStatus(res) <> PGRES_COMMAND_OK) then - begin - PQclear(res); - result := false; - DatabaseError(SErrRollbackFailed + ' (PostgreSQL: ' + PQerrorMessage(tr.PGConn) + ')',self); - end - else - begin - PQclear(res); - PQFinish(tr.PGConn); - result := true; - end; + + CheckResultError(res,tr.PGConn,SErrRollbackFailed); + + PQclear(res); + PQFinish(tr.PGConn); + result := true; end; function TPQConnection.Commit(trans : TSQLHandle) : boolean; @@ -236,18 +232,11 @@ begin tr := trans as TPQTrans; res := PQexec(tr.PGConn, 'COMMIT'); - if (PQresultStatus(res) <> PGRES_COMMAND_OK) then - begin - PQclear(res); - result := false; - DatabaseError(SErrCommitFailed + ' (PostgreSQL: ' + PQerrorMessage(tr.PGConn) + ')',self); - end - else - begin - PQclear(res); - PQFinish(tr.PGConn); - result := true; - end; + CheckResultError(res,tr.PGConn,SErrCommitFailed); + + PQclear(res); + PQFinish(tr.PGConn); + result := true; end; function TPQConnection.StartdbTransaction(trans : TSQLHandle; AParams : string) : boolean; @@ -272,19 +261,10 @@ begin begin tr.ErrorOccured := False; res := PQexec(tr.PGConn, 'BEGIN'); - if (PQresultStatus(res) <> PGRES_COMMAND_OK) then - begin - result := false; - PQclear(res); - msg := PQerrorMessage(tr.PGConn); - PQFinish(tr.PGConn); - DatabaseError(sErrTransactionFailed + ' (PostgreSQL: ' + msg + ')',self); - end - else - begin - PQclear(res); - result := true; - end; + CheckResultError(res,tr.PGConn,sErrTransactionFailed); + + PQclear(res); + result := true; end; end; @@ -296,25 +276,13 @@ var begin tr := trans as TPQTrans; res := PQexec(tr.PGConn, 'ROLLBACK'); - if (PQresultStatus(res) <> PGRES_COMMAND_OK) then - begin - PQclear(res); - DatabaseError(SErrRollbackFailed + ' (PostgreSQL: ' + PQerrorMessage(tr.PGConn) + ')',self); - end - else - begin - PQclear(res); - res := PQexec(tr.PGConn, 'BEGIN'); - if (PQresultStatus(res) <> PGRES_COMMAND_OK) then - begin - PQclear(res); - msg := PQerrorMessage(tr.PGConn); - PQFinish(tr.PGConn); - DatabaseError(sErrTransactionFailed + ' (PostgreSQL: ' + msg + ')',self); - end - else - PQclear(res); - end; + CheckResultError(res,tr.PGConn,SErrRollbackFailed); + + PQclear(res); + res := PQexec(tr.PGConn, 'BEGIN'); + CheckResultError(res,tr.PGConn,sErrTransactionFailed); + + PQclear(res); end; procedure TPQConnection.CommitRetaining(trans : TSQLHandle); @@ -325,25 +293,13 @@ var begin tr := trans as TPQTrans; res := PQexec(tr.PGConn, 'COMMIT'); - if (PQresultStatus(res) <> PGRES_COMMAND_OK) then - begin - PQclear(res); - DatabaseError(SErrCommitFailed + ' (PostgreSQL: ' + PQerrorMessage(tr.PGConn) + ')',self); - end - else - begin - PQclear(res); - res := PQexec(tr.PGConn, 'BEGIN'); - if (PQresultStatus(res) <> PGRES_COMMAND_OK) then - begin - PQclear(res); - msg := PQerrorMessage(tr.PGConn); - PQFinish(tr.PGConn); - DatabaseError(sErrTransactionFailed + ' (PostgreSQL: ' + msg + ')',self); - end - else - PQclear(res); - end; + CheckResultError(res,tr.PGConn,SErrCommitFailed); + + PQclear(res); + res := PQexec(tr.PGConn, 'BEGIN'); + CheckResultError(res,tr.PGConn,sErrTransactionFailed); + + PQclear(res); end; @@ -387,6 +343,50 @@ begin end; +procedure TPQConnection.CheckResultError(res: PPGresult; conn: PPGconn; + ErrMsg: string); +var + serr:string; + E: EPQDatabaseError; + CompName: string; + SEVERITY:string; + SQLSTATE: string; + MESSAGE_PRIMARY:string; + MESSAGE_DETAIL:string; + MESSAGE_HINT:string; + STATEMENT_POSITION:string; + +begin + if (PQresultStatus(res) <> PGRES_COMMAND_OK) then + begin + SEVERITY:=PQresultErrorField(res,ord('S')); + SQLSTATE:=PQresultErrorField(res,ord('C')); + MESSAGE_PRIMARY:=PQresultErrorField(res,ord('M')); + MESSAGE_DETAIL:=PQresultErrorField(res,ord('D')); + MESSAGE_HINT:=PQresultErrorField(res,ord('H')); + STATEMENT_POSITION:=PQresultErrorField(res,ord('P')); + serr:=PQresultErrorMessage(res)+LineEnding+ + 'Severity: '+ SEVERITY +LineEnding+ + 'SQL State: '+ SQLSTATE +LineEnding+ + 'Primary Error: '+ MESSAGE_PRIMARY +LineEnding+ + 'Error Detail: '+ MESSAGE_DETAIL +LineEnding+ + 'Hint: '+ MESSAGE_HINT +LineEnding+ + 'Character: '+ STATEMENT_POSITION +LineEnding; + pqclear(res); + if assigned(conn) then + PQFinish(conn); + if Self.Name = '' then CompName := Self.ClassName else CompName := Self.Name; + E:=EPQDatabaseError.CreateFmt('%s : %s (PostgreSQL: %s)', [CompName,ErrMsg, serr]); + E.SEVERITY:=SEVERITY; + E.SQLSTATE:=SQLSTATE; + E.MESSAGE_PRIMARY:=MESSAGE_PRIMARY; + E.MESSAGE_DETAIL:=MESSAGE_DETAIL; + E.MESSAGE_HINT:=MESSAGE_HINT; + E.STATEMENT_POSITION:=STATEMENT_POSITION; + raise E; + end; +end; + function TPQConnection.TranslateFldType(res : PPGresult; Tuple : integer; out Size : integer) : TFieldType; const VARHDRSZ=sizeof(longint); var li : longint; @@ -525,7 +525,7 @@ const TypeStrings : array[TFieldType] of string = ); -var s : string; +var s,serr : string; i : integer; begin @@ -559,11 +559,7 @@ begin end; s := s + ' as ' + buf; res := pqexec(tr.PGConn,pchar(s)); - if (PQresultStatus(res) <> PGRES_COMMAND_OK) then - begin - pqclear(res); - DatabaseError(SErrPrepareFailed + ' (PostgreSQL: ' + PQerrorMessage(tr.PGConn) + ')',self) - end; + CheckResultError(res,nil,SErrPrepareFailed); // if statement is INSERT, UPDATE, DELETE with RETURNING clause, then // override the statement type derrived by parsing the query. if (FStatementType in [stInsert,stUpdate,stDelete]) and (pos('RETURNING', upcase(s)) > 0) then diff --git a/mips/packages/fcl-db/src/sqldb/postgres/pqeventmonitor.pp b/mips/packages/fcl-db/src/sqldb/postgres/pqeventmonitor.pp index f463a3cfa4..fdec42a959 100644 --- a/mips/packages/fcl-db/src/sqldb/postgres/pqeventmonitor.pp +++ b/mips/packages/fcl-db/src/sqldb/postgres/pqeventmonitor.pp @@ -122,7 +122,6 @@ end; procedure TPQEventMonitor.SetRegistered(AValue: Boolean); begin - FRegistered := AValue; if not (csDesigning in ComponentState) then if AValue then RegisterEvents diff --git a/mips/packages/fcl-db/src/sqldb/sqldb.pp b/mips/packages/fcl-db/src/sqldb/sqldb.pp index 97e2f1ee97..9a4ea37b22 100644 --- a/mips/packages/fcl-db/src/sqldb/sqldb.pp +++ b/mips/packages/fcl-db/src/sqldb/sqldb.pp @@ -1010,7 +1010,7 @@ begin end; if FWhereStartPos = 0 then - SQLstr := SQLstr + ' where (' + Filter + ')' + SQLstr := SQLstr + ' where (' + ServerFilter + ')' else if FWhereStopPos > 0 then system.insert(' and ('+ServerFilter+') ',SQLstr,FWhereStopPos+2) else @@ -1217,18 +1217,17 @@ end; function TCustomSQLQuery.SQLParser(const ASQL : string) : TStatementType; -type TParsePart = (ppStart,ppWith,ppSelect,ppFrom,ppWhere,ppGroup,ppOrder,ppComment,ppBogus); +type TParsePart = (ppStart,ppWith,ppSelect,ppTableName,ppFrom,ppWhere,ppGroup,ppOrder,ppBogus); + TPhraseSeparator = (sepNone, sepWhiteSpace, sepComma, sepComment, sepParentheses, sepEnd); Var - PSQL,CurrentP, + PSQL, CurrentP, SavedP, PhraseP, PStatementPart : pchar; S : string; ParsePart : TParsePart; - StrLength : Integer; - EndOfComment : Boolean; BracketCount : Integer; ConnOptions : TConnOptions; - FFromPart : String; + Separator : TPhraseSeparator; begin PSQL:=Pchar(ASQL); @@ -1237,42 +1236,57 @@ begin CurrentP := PSQL-1; PhraseP := PSQL; + FTableName := ''; + FUpdateable := False; + FWhereStartPos := 0; FWhereStopPos := 0; ConnOptions := TSQLConnection(DataBase).ConnOptions; - FUpdateable := False; repeat begin inc(CurrentP); - - EndOfComment := SkipComments(CurrentP, sqEscapeSlash in ConnOptions, sqEscapeRepeat in ConnOptions); - if EndOfcomment then dec(CurrentP); - if EndOfComment and (ParsePart = ppStart) then PhraseP := CurrentP; - - // skip everything between bracket, since it could be a sub-select, and - // further nothing between brackets could be interesting for the parser. - if CurrentP^='(' then - begin - inc(currentp); - BracketCount := 0; - while (currentp^ <> #0) and ((currentp^ <> ')') or (BracketCount > 0 )) do + SavedP := CurrentP; + + case CurrentP^ of + ' ', #9, #10, #11, #12, #13: + Separator := sepWhiteSpace; + ',': + Separator := sepComma; + #0, ';': + Separator := sepEnd; + '(': begin - if currentp^ = '(' then inc(bracketcount) - else if currentp^ = ')' then dec(bracketcount); - inc(currentp); + Separator := sepParentheses; + // skip everything between brackets, since it could be a sub-select, and + // further nothing between brackets could be interesting for the parser. + BracketCount := 1; + repeat + inc(CurrentP); + if CurrentP^ = '(' then inc(BracketCount) + else if CurrentP^ = ')' then dec(BracketCount); + until (CurrentP^ = #0) or (BracketCount = 0); + if CurrentP^ <> #0 then inc(CurrentP); end; - EndOfComment := True; - end; + else + if SkipComments(CurrentP, sqEscapeSlash in ConnOptions, sqEscapeRepeat in ConnOptions) then + Separator := sepComment + else + Separator := sepNone; + end; + + if (CurrentP > SavedP) and (SavedP > PhraseP) then + CurrentP := SavedP; // there is something before comment or left parenthesis - if EndOfComment or (CurrentP^ in [' ',#13,#10,#9,#0,';']) then + if Separator <> sepNone then begin - if (CurrentP-PhraseP > 0) or (CurrentP^ in [';',#0]) then + if ((Separator in [sepWhitespace,sepComment]) and (PhraseP = SavedP)) then + PhraseP := CurrentP; // skip comments(but not parentheses) and white spaces + + if (CurrentP-PhraseP > 0) or (Separator = sepEnd) then begin - strLength := CurrentP-PhraseP; - Setlength(S,strLength); - if strLength > 0 then Move(PhraseP^,S[1],(strLength)); + SetString(s, PhraseP, CurrentP-PhraseP); s := uppercase(s); case ParsePart of @@ -1284,7 +1298,6 @@ begin else break; end; if not FParseSQL then break; - PStatementPart := CurrentP; end; ppWith : begin // WITH [RECURSIVE] CTE_name [ ( column_names ) ] AS ( CTE_query_definition ) [, ...] @@ -1299,69 +1312,53 @@ begin end; ppSelect : begin if s = 'FROM' then + ParsePart := ppTableName; + end; + ppTableName: + begin + // Meta-data requests are never updateable + // and select-statements from more then one table + // and/or derived tables are also not updateable + if (FSchemaType = stNoSchema) and + (Separator in [sepWhitespace, sepComment, sepEnd]) then begin - ParsePart := ppFrom; - PhraseP := CurrentP; - PStatementPart := CurrentP; + FTableName := s; + FUpdateable := True; end; + ParsePart := ppFrom; end; ppFrom : begin - if (s = 'WHERE') or (s = 'ORDER') or (s = 'GROUP') or (s = 'LIMIT') or (CurrentP^=#0) or (CurrentP^=';') then + if (s = 'WHERE') or (s = 'GROUP') or (s = 'ORDER') or (s = 'LIMIT') or (s = 'ROWS') or + (Separator = sepEnd) then begin - if (s = 'WHERE') then - begin - ParsePart := ppWhere; - StrLength := PhraseP-PStatementPart; - end - else if (s = 'GROUP') then - begin - ParsePart := ppGroup; - StrLength := PhraseP-PStatementPart; - end - else if (s = 'ORDER') then - begin - ParsePart := ppOrder; - StrLength := PhraseP-PStatementPart - end - else if (s = 'LIMIT') then - begin - ParsePart := ppBogus; - StrLength := PhraseP-PStatementPart - end - else - begin - ParsePart := ppBogus; - StrLength := CurrentP-PStatementPart; - end; - if Result = stSelect then - begin - Setlength(FFromPart,StrLength); - Move(PStatementPart^,FFromPart[1],(StrLength)); - FFromPart := trim(FFromPart); - - // Meta-data requests and are never updateable select-statements - // from more then one table are not updateable - if (FSchemaType=stNoSchema) and - (ExtractStrings([',',' '],[],pchar(FFromPart),nil) = 1) then - begin - FUpdateable := True; - FTableName := FFromPart; - end; - end; - - FWhereStartPos := PStatementPart-PSQL+StrLength+1; + case s of + 'WHERE': ParsePart := ppWhere; + 'GROUP': ParsePart := ppGroup; + 'ORDER': ParsePart := ppOrder; + else ParsePart := ppBogus; + end; + + FWhereStartPos := PhraseP-PSQL+1; PStatementPart := CurrentP; + end + else + // joined table or user_defined_function (...) + if (s = 'JOIN') or (Separator in [sepComma, sepParentheses]) then + begin + FTableName := ''; + FUpdateable := False; end; end; ppWhere : begin - if (s = 'ORDER') or (s = 'GROUP') or (s = 'LIMIT') or (CurrentP^=#0) or (CurrentP^=';') then + if (s = 'GROUP') or (s = 'ORDER') or (s = 'LIMIT') or (s = 'ROWS') or + (Separator = sepEnd) then begin ParsePart := ppBogus; FWhereStartPos := PStatementPart-PSQL; - if (s = 'ORDER') or (s = 'GROUP') or (s = 'LIMIT') then - FWhereStopPos := PhraseP-PSQL+1 + if (Separator = sepEnd) then + FWhereStopPos := CurrentP-PSQL+1 else - FWhereStopPos := CurrentP-PSQL+1; + FWhereStopPos := PhraseP-PSQL+1; end else if (s = 'UNION') then begin @@ -1371,6 +1368,8 @@ begin end; end; {case} end; + if Separator in [sepComment, sepParentheses] then + dec(CurrentP); PhraseP := CurrentP+1; end end; @@ -1381,7 +1380,6 @@ procedure TCustomSQLQuery.InternalOpen; var tel, fieldc : integer; f : TField; - s : string; IndexFields : TStrings; ReadFromFile: Boolean; begin diff --git a/mips/packages/fcl-db/src/sqldb/sqlite/sqlite3conn.pp b/mips/packages/fcl-db/src/sqldb/sqlite/sqlite3conn.pp index 1d7bc3a74e..c688ef9122 100644 --- a/mips/packages/fcl-db/src/sqldb/sqlite/sqlite3conn.pp +++ b/mips/packages/fcl-db/src/sqldb/sqlite/sqlite3conn.pp @@ -831,6 +831,7 @@ function TSQLite3Connection.GetSchemaInfoSQL(SchemaType: TSchemaType; begin case SchemaType of stTables : result := 'select name as table_name from sqlite_master where type = ''table'' order by 1'; + stSysTables : result := 'select ''sqlite_master'' as table_name'; stColumns : result := 'pragma table_info(''' + (SchemaObjectName) + ''')'; else DatabaseError(SMetadataUnavailable) diff --git a/mips/packages/fcl-db/tests/bufdatasettoolsunit.pas b/mips/packages/fcl-db/tests/bufdatasettoolsunit.pas index 0405650ae2..d40893d95e 100644 --- a/mips/packages/fcl-db/tests/bufdatasettoolsunit.pas +++ b/mips/packages/fcl-db/tests/bufdatasettoolsunit.pas @@ -37,6 +37,9 @@ type implementation +uses + StrUtils, FmtBCD; + type { TPersistentBufDataSet } @@ -85,6 +88,7 @@ var BufDataset : TPersistentBufDataSet; begin BufDataset := TPersistentBufDataSet.Create(nil); + BufDataset.Name := 'NDataset'; BufDataset.FieldDefs.Add('ID',ftInteger); BufDataset.FieldDefs.Add('NAME',ftString,50); BufDataset.CreateDataset; @@ -109,20 +113,20 @@ var BufDataset : TPersistentBufDataSet; i : integer; begin - // Values >= 24:00:00.000 can't be handled by bufdataset + // Values >= 24:00:00.000 can't be handled by StrToTime function testTimeValues[2] := '23:59:59.000'; testTimeValues[3] := '23:59:59.003'; BufDataset := TPersistentBufDataSet.Create(nil); with BufDataset do begin + Name := 'FieldDataset'; UniDirectional := FUniDirectional; FieldDefs.Add('ID',ftInteger); FieldDefs.Add('FSTRING',ftString,10); FieldDefs.Add('FSMALLINT',ftSmallint); FieldDefs.Add('FINTEGER',ftInteger); - // Not supported by BufDataset: - // FieldDefs.Add('FWORD',ftWord); + FieldDefs.Add('FWORD',ftWord); FieldDefs.Add('FBOOLEAN',ftBoolean); FieldDefs.Add('FFLOAT',ftFloat); FieldDefs.Add('FCURRENCY',ftCurrency); @@ -130,7 +134,11 @@ begin FieldDefs.Add('FDATE',ftDate); FieldDefs.Add('FTIME',ftTime); FieldDefs.Add('FDATETIME',ftDateTime); + FieldDefs.Add('FBLOB',ftBlob); + FieldDefs.Add('FMEMO',ftMemo); FieldDefs.Add('FLARGEINT',ftLargeint); + FieldDefs.Add('FFIXEDCHAR',ftFixedChar,10); + FieldDefs.Add('FFMTBCD',ftFmtBCD); CreateDataset; Open; for i := 0 to testValuesCount-1 do @@ -146,7 +154,12 @@ begin FieldByName('FBCD').AsCurrency := testCurrencyValues[i]; FieldByName('FDATE').AsDateTime := StrToDateTime(testDateValues[i], Self.FormatSettings); FieldByName('FTIME').AsDateTime := StrToTime(testTimeValues[i], Self.FormatSettings); + FieldByName('FDATETIME').AsDateTime := StrToDateTime(testValues[ftDateTime,i], Self.FormatSettings); + FieldByName('FBLOB').AsString := testStringValues[i]; + FieldByName('FMEMO').AsString := testStringValues[i]; FieldByName('FLARGEINT').AsLargeInt := testLargeIntValues[i]; + FieldByName('FFIXEDCHAR').AsString := PadRight(testStringValues[i], 10); + FieldByName('FFMTBCD').AsBCD := StrToBCD(testFmtBCDValues[i], Self.FormatSettings); Post; end; BufDataset.TempFileName:=GetTempFileName; diff --git a/mips/packages/fcl-db/tests/dbtestframework.pas b/mips/packages/fcl-db/tests/dbtestframework.pas index 023270e040..8464bf93af 100644 --- a/mips/packages/fcl-db/tests/dbtestframework.pas +++ b/mips/packages/fcl-db/tests/dbtestframework.pas @@ -18,11 +18,12 @@ uses memdstoolsunit, SdfDSToolsUnit, // Units wich contains the tests - testbasics, - testfieldtypes, + TestBasics, + TestFieldTypes, TestDatasources, - testdbbasics, - TestBufDatasetStreams; + TestDBBasics, + TestBufDatasetStreams, + TestSpecificTBufDataset; var FXMLResultsWriter: TXMLResultsWriter; diff --git a/mips/packages/fcl-db/tests/testbasics.pas b/mips/packages/fcl-db/tests/testbasics.pas index 443b6d7693..04379791af 100644 --- a/mips/packages/fcl-db/tests/testbasics.pas +++ b/mips/packages/fcl-db/tests/testbasics.pas @@ -22,6 +22,8 @@ type procedure TestInitFielddefsFromFields; procedure TestDoubleFieldDef; procedure TestFieldDefWithoutDS; + procedure TestGetParamList; + procedure TestGetFieldList; procedure TestExtractFieldName; end; @@ -189,6 +191,130 @@ begin FieldDefs.Free; end; +procedure TTestBasics.TestGetFieldList; +var + ds: TDataSet; + F: TField; + List: TList; + ExceptionRaised: Boolean; +begin + ds := TDataSet.Create(nil); + try + F := TIntegerField.Create(ds); + F.FieldName := 'Field1'; + F.DataSet := ds; + + F := TIntegerField.Create(ds); + F.FieldName := 'Field2'; + F.DataSet := ds; + + F := TIntegerField.Create(ds); + F.FieldName := 'Field3'; + F.DataSet := ds; + + List := TList.Create; + try + //should not + List.Clear; + ds.GetFieldList(List, ''); + AssertEquals(0, List.Count); + + List.Clear; + ExceptionRaised := False; + try + ds.GetFieldList(List, ' '); + except + on E: EDatabaseError do ExceptionRaised := True; + end; + AssertTrue(ExceptionRaised); + + List.Clear; + ds.GetFieldList(List, 'Field1'); + AssertEquals(1, List.Count); + + List.Clear; + ds.GetFieldList(List, ' Field1 '); + AssertEquals(1, List.Count); + + List.Clear; + ds.GetFieldList(List, 'Field1;Field2'); + AssertEquals(2, List.Count); + + List.Clear; + ds.GetFieldList(List, 'Field1;Field2;'); + AssertEquals(2, List.Count); + + List.Clear; + ds.GetFieldList(List, 'Field1;Field2;Field3'); + AssertEquals(3, List.Count); + finally + List.Destroy; + end; + finally + ds.Destroy; + end; +end; + +procedure TTestBasics.TestGetParamList; +var + Params: TParams; + P: TParam; + List: TList; + ExceptionRaised: Boolean; +begin + Params := TParams.Create(nil); + try + P := TParam.Create(Params, ptInput); + P.Name := 'Param1'; + + P := TParam.Create(Params, ptInput); + P.Name := 'Param2'; + + P := TParam.Create(Params, ptInput); + P.Name := 'Param3'; + + List := TList.Create; + try + List.Clear; + Params.GetParamList(List, ''); + AssertEquals(0, List.Count); + + List.Clear; + ExceptionRaised := False; + try + Params.GetParamList(List, ' '); + except + on E: EDatabaseError do ExceptionRaised := True; + end; + AssertTrue(ExceptionRaised); + + List.Clear; + Params.GetParamList(List, 'Param1'); + AssertEquals(1, List.Count); + + List.Clear; + Params.GetParamList(List, ' Param1 '); + AssertEquals(1, List.Count); + + List.Clear; + Params.GetParamList(List, 'Param1;'); + AssertEquals(1, List.Count); + + List.Clear; + Params.GetParamList(List, 'Param1;Param2'); + AssertEquals(2, List.Count); + + List.Clear; + Params.GetParamList(List, 'Param1;Param2;Param3'); + AssertEquals(3, List.Count); + finally + List.Destroy; + end; + finally + Params.Destroy; + end; +end; + procedure TTestBasics.TestExtractFieldName; var diff --git a/mips/packages/fcl-db/tests/testbufdatasetstreams.pas b/mips/packages/fcl-db/tests/testbufdatasetstreams.pas index 93ef270648..c42fc15a24 100644 --- a/mips/packages/fcl-db/tests/testbufdatasetstreams.pas +++ b/mips/packages/fcl-db/tests/testbufdatasetstreams.pas @@ -69,6 +69,9 @@ type procedure TestSeveralEditsXML; procedure TestDeleteAllXML; procedure TestDeleteAllInsertXML; + procedure TestStreamingBlobFieldsXML; + procedure TestStreamingBigBlobFieldsXML; + procedure TestStreamingCalculatedFieldsXML; procedure TestAppendDeleteBIN; @@ -452,6 +455,124 @@ begin TestChangesXML(@DeleteAllInsertChange); end; +procedure TTestBufDatasetStreams.TestStreamingBlobFieldsXML; +var SaveDs: TCustomBufDataset; + LoadDs: TCustomBufDataset; +begin + SaveDs := DBConnector.GetFieldDataset as TCustomBufDataset; + SaveDs.Open; + SaveDs.SaveToFile('FieldsDS.xml',dfXML); + + LoadDs := TCustomBufDataset.Create(nil); + LoadDs.LoadFromFile('FieldsDS.xml'); + + LoadDS.First; + SaveDS.First; + while not LoadDS.EOF do + begin + AssertEquals(LoadDS.FieldByName('FBLOB').AsString,SaveDS.FieldByName('FBLOB').AsString); + AssertEquals(LoadDS.FieldByName('FMEMO').AsString,SaveDS.FieldByName('FMEMO').AsString); + LoadDS.Next; + SaveDS.Next; + end; + + LoadDs.Free; +end; + +procedure TTestBufDatasetStreams.TestStreamingBigBlobFieldsXML; +var + SaveDs: TCustomBufDataset; + LoadDs: TCustomBufDataset; + j: integer; + i: byte; + s: string; + f: file of byte; + fn: string; + fs: TMemoryStream; +begin + // Create a temp. file with blob-data. + fn := GetTempFileName; + assign(f,fn); + Rewrite(f); + s := 'This is a blob-field test file.'; + for j := 0 to 250 do + begin + for i := 1 to length(s) do + write(f,ord(s[i])); + for i := 0 to 255 do + write(f,i); + end; + close(f); + + try + // Open dataset and set blob-field-data to content of blob-file. + SaveDs := DBConnector.GetFieldDataset(true) as TCustomBufDataset; + SaveDs.Open; + SaveDs.Edit; + TBlobField(SaveDs.FieldByName('FBLOB')).LoadFromFile(fn); + SaveDs.Post; + + // Save this dataset to file. + SaveDs.SaveToFile('FieldsDS.xml',dfXML); + + // Load this file in another dataset + LoadDs := TCustomBufDataset.Create(nil); + try + LoadDs.LoadFromFile('FieldsDS.xml'); + LoadDS.First; + + // Compare the content of the blob-field with the file on disc + fs := TMemoryStream.Create; + try + TBlobField(SaveDs.FieldByName('FBLOB')).SaveToStream(fs); + fs.Seek(0,soBeginning); + assign(f,fn); + reset(f); + for j := 0 to fs.Size-1 do + begin + read(f,i); + CheckEquals(i,fs.ReadByte); + end; + finally + fs.free; + end; + finally + LoadDs.Free; + end; + finally + DeleteFile(fn); + end; +end; + +procedure TTestBufDatasetStreams.TestStreamingCalculatedFieldsXML; +var + ADataset: TCustomBufDataset; + f: tfield; +begin + ADataset := DBConnector.GetNDataset(true,10) as TCustomBufDataset; + f := TIntegerField.Create(ADataset); + f.FieldName:='ID'; + f.dataset := ADataset; + + f := TIntegerField.Create(ADataset); + f.FieldName:='CalcID'; + f.dataset := ADataset; + f.FieldKind:=fkCalculated; + + f := TStringField.Create(ADataset); + f.FieldName:='NAME'; + f.dataset := ADataset; + + ADataset.Open; + ADataset.SaveToFile('FieldsDS.xml',dfXML); + ADataset.Close; + + ADataset.LoadFromFile('FieldsDS.xml',dfXML); + AssertEquals(ADataset.FieldByName('ID').AsInteger,1); + AssertEquals(ADataset.FieldByName('NAME').AsString,'TestName1'); + ADataset.Close; +end; + procedure TTestBufDatasetStreams.TestAppendDeleteBIN; begin TestChanges(@AppendDeleteChange); diff --git a/mips/packages/fcl-db/tests/testdbbasics.pas b/mips/packages/fcl-db/tests/testdbbasics.pas index fb8aeab5d0..dedc12e737 100644 --- a/mips/packages/fcl-db/tests/testdbbasics.pas +++ b/mips/packages/fcl-db/tests/testdbbasics.pas @@ -42,6 +42,8 @@ type procedure TestSupportBCDFields; procedure TestSupportfmtBCDFields; procedure TestSupportFixedStringFields; + procedure TestSupportBlobFields; + procedure TestSupportMemoFields; procedure TestDoubleClose; procedure TestCalculatedField; @@ -58,6 +60,7 @@ type procedure TestdeFieldListChange; procedure TestExceptionLocateClosed; // bug 13938 procedure TestCanModifySpecialFields; + procedure TestDetectionNonMatchingDataset; end; { TTestBufDatasetDBBasics } @@ -677,12 +680,39 @@ begin CheckFalse(FieldByName('LookupFld').ReadOnly); CheckEquals(1,FieldByName('ID').AsInteger); - CheckEquals('name1',FieldByName('LookupFld').AsString); - close; + CheckEquals('TestName1',FieldByName('LookupFld').AsString); + Next; + Next; + CheckEquals(3,FieldByName('ID').AsInteger); + CheckEquals('TestName3',FieldByName('LookupFld').AsString); + + Close; lds.Close; end; end; +procedure TTestDBBasics.TestDetectionNonMatchingDataset; +var + F: TField; + ds: tdataset; +begin + // TDataset.Bindfields should detect problems when the underlying data does + // not reflect the fields of the dataset. This test is to check if this is + // really done. + ds := DBConnector.GetNDataset(true,6); + with ds do + begin + open; + close; + + F := TStringField.Create(ds); + F.FieldName:='DOES_NOT_EXIST'; + F.DataSet:=ds; + F.Size:=50; + + CheckException(open,EDatabaseError); + end; +end; procedure TTestCursorDBBasics.TestAppendInsertRecord; begin @@ -2359,6 +2389,37 @@ begin ds.close; end; +procedure TTestDBBasics.TestSupportBlobFields; + +var i : byte; + ds : TDataset; + Fld : TField; +begin + TestfieldDefinition(ftBlob,0,ds,Fld); + + for i := 0 to testValuesCount-1 do + begin + CheckEquals(testValues[ftBlob,i],Fld.AsString); + ds.Next; + end; + ds.close; +end; + +procedure TTestDBBasics.TestSupportMemoFields; +var i : byte; + ds : TDataset; + Fld : TField; +begin + TestfieldDefinition(ftMemo,0,ds,Fld); + + for i := 0 to testValuesCount-1 do + begin + CheckEquals(testValues[ftMemo,i],Fld.AsString); + ds.Next; + end; + ds.close; +end; + procedure TTestDBBasics.TestDoubleClose; begin with DBConnector.GetNDataset(1) do diff --git a/mips/packages/fcl-db/tests/testfieldtypes.pas b/mips/packages/fcl-db/tests/testfieldtypes.pas index cc173501e2..73cdb65421 100644 --- a/mips/packages/fcl-db/tests/testfieldtypes.pas +++ b/mips/packages/fcl-db/tests/testfieldtypes.pas @@ -38,7 +38,7 @@ type procedure TestInsertLargeStrFields; // bug 9600 procedure TestNumericNames; // Bug9661 procedure TestApplyUpdFieldnames; // Bug 12275; - procedure TestLimitQuery; // bug 15456 + procedure TestServerFilter; // bug 15456 procedure Test11Params; procedure TestRowsAffected; // bug 9758 procedure TestLocateNull; @@ -1438,7 +1438,13 @@ begin begin SQL.Text:='select TT.NAME from FPDEV left join FPDEV TT on TT.ID=FPDEV.ID'; Open; - close; + AssertFalse(CanModify); + Close; + + SQL.Text:='select T1.NAME from FPDEV T1,FPDEV T2 where T1.ID=T2.ID'; + Open; + AssertFalse(CanModify); + Close; end; end; end; @@ -1565,25 +1571,57 @@ begin end; end; -procedure TTestFieldTypes.TestLimitQuery; +procedure TTestFieldTypes.TestServerFilter; begin - with TSQLDBConnector(DBConnector) do - begin - with query do - begin - case sqlDBtype of - interbase : SQL.Text:='select first 1 NAME from FPDEV where NAME=''TestName21'''; - mssql : SQL.Text:='select top 1 NAME from FPDEV where NAME=''TestName21'''; - else SQL.Text:='select NAME from FPDEV where NAME=''TestName21'' limit 1'; - end; - Open; - close; - ServerFilter:='ID=21'; - ServerFiltered:=true; - open; - close; - end; + // Tests SQLParser and ServerFilter + with TSQLDBConnector(DBConnector).Query do + begin + ServerFilter:='ID=21'; + ServerFiltered:=true; + + // tests parsing SELECT without WHERE + SQL.Text:='select * from FPDEV'; + Open; + CheckTrue(CanModify, SQL.Text); + CheckEquals(1, RecordCount); + Close; + + SQL.Text:='select *'#13'from FPDEV'#13'order by 1'; + Open; + CheckTrue(CanModify, SQL.Text); + CheckEquals(1, RecordCount); + Close; + + // tests parsing SELECT with simple WHERE + SQL.Text:='select *'#9'from FPDEV'#9'where NAME<>'''''; + Open; + CheckTrue(CanModify, SQL.Text); + CheckEquals(1, RecordCount); + Close; + + // tests parsing SELECT with simple WHERE followed by ORDER BY + SQL.Text:='select *'#10'from FPDEV'#10'where NAME>'''' order by 1'; + Open; + CheckTrue(CanModify, SQL.Text); + CheckEquals(1, RecordCount); + Close; + + // tests parsing of WHERE ... LIMIT + case sqlDBtype of + interbase : SQL.Text:='select first 1 NAME from FPDEV where NAME=''TestName21'''; + mssql : SQL.Text:='select top 1 NAME from FPDEV where NAME=''TestName21'''; + else SQL.Text:='select NAME from FPDEV where NAME=''TestName21'' limit 1'; end; + Open; + CheckTrue(CanModify, SQL.Text); + Close; + + // tests parsing SELECT with table alias and embedded comments (MySQL requires space after -- ) + SQL.Text:='/**/select * from/**/FPDEV as fp-- comment'#13'where(NAME>''TestName20'')/**/order by 1'; + Open; + CheckTrue(CanModify, SQL.Text); + Close; + end; end; procedure TTestFieldTypes.TestRowsAffected; diff --git a/mips/packages/fcl-db/tests/testspecifictbufdataset.pas b/mips/packages/fcl-db/tests/testspecifictbufdataset.pas index 93b9108d34..49866cb224 100644 --- a/mips/packages/fcl-db/tests/testspecifictbufdataset.pas +++ b/mips/packages/fcl-db/tests/testspecifictbufdataset.pas @@ -25,7 +25,9 @@ type TTestSpecificTBufDataset = class(TTestCase) private - procedure TestDataset(ABufDataset: TBufDataset); + procedure TestDataset(ABufDataset: TBufDataset; AutoInc: boolean = false); + function GetAutoIncDataset: TBufDataset; + procedure IntTestAutoIncFieldStreaming(XML: boolean); protected procedure SetUp; override; procedure TearDown; override; @@ -33,6 +35,10 @@ type procedure CreateDatasetFromFielddefs; procedure CreateDatasetFromFields; procedure TestOpeningNonExistingDataset; + procedure TestCreationDatasetWithCalcFields; + procedure TestAutoIncField; + procedure TestAutoIncFieldStreaming; + procedure TestAutoIncFieldStreamingXML; end; implementation @@ -47,14 +53,16 @@ uses { TTestSpecificTBufDataset } -procedure TTestSpecificTBufDataset.TestDataset(ABufDataset: TBufDataset); +procedure TTestSpecificTBufDataset.TestDataset(ABufDataset: TBufDataset; + AutoInc: boolean); var i : integer; begin for i := 1 to 10 do begin ABufDataset.Append; - ABufDataset.FieldByName('ID').AsInteger := i; + if not AutoInc then + ABufDataset.FieldByName('ID').AsInteger := i; ABufDataset.FieldByName('NAME').AsString := 'TestName' + inttostr(i); ABufDataset.Post; end; @@ -68,6 +76,52 @@ begin CheckTrue(ABufDataset.EOF); end; +function TTestSpecificTBufDataset.GetAutoIncDataset: TBufDataset; +var + ds : TBufDataset; + f: TField; +begin + ds := TBufDataset.Create(nil); + F := TAutoIncField.Create(ds); + F.FieldName:='ID'; + F.DataSet:=ds; + F := TStringField.Create(ds); + F.FieldName:='NAME'; + F.DataSet:=ds; + F.Size:=50; + DS.CreateDataset; + + TestDataset(ds,True); + result := ds; +end; + +procedure TTestSpecificTBufDataset.IntTestAutoIncFieldStreaming(XML: boolean); +var + ds : TBufDataset; + fn: string; +begin + ds := GetAutoIncDataset; + fn := GetTempFileName; + if xml then + ds.SaveToFile(fn,dfXML) + else + ds.SaveToFile(fn); + DS.Close; + ds.Free; + + ds := TBufDataset.Create(nil); + ds.LoadFromFile(fn); + ds.Last; + CheckEquals(10,ds.FieldByName('Id').AsInteger); + ds.Append; + ds.FieldByName('NAME').asstring := 'Test'; + ds.Post; + CheckEquals(11,ds.FieldByName('Id').AsInteger); + ds.Free; + + DeleteFile(fn); +end; + procedure TTestSpecificTBufDataset.SetUp; begin DBConnector.StartTest; @@ -129,6 +183,71 @@ begin ds.Free; end; +procedure TTestSpecificTBufDataset.TestCreationDatasetWithCalcFields; +var ds : TBufDataset; + f: TField; + i: integer; +begin + ds := TBufDataset.Create(nil); + try + F := TIntegerField.Create(ds); + F.FieldName:='ID'; + F.DataSet:=ds; + F := TStringField.Create(ds); + F.FieldName:='NAME'; + F.DataSet:=ds; + F.Size:=50; + + F := TStringField.Create(ds); + F.FieldKind:=fkCalculated; + F.FieldName:='NAME_CALC'; + F.DataSet:=ds; + F.Size:=50; + + F := TStringField.Create(ds); + F.FieldKind:=fkLookup; + F.FieldName:='NAME_LKP'; + F.LookupDataSet:=DBConnector.GetNDataset(5); + F.KeyFields:='ID'; + F.LookupKeyFields:='ID'; + F.LookupResultField:='NAME'; + F.DataSet:=ds; + F.Size:=50; + + DS.CreateDataset; + + TestDataset(ds); + + for i := 0 to ds.FieldDefs.Count-1 do + begin + CheckNotEquals(ds.FieldDefs[i].Name,'NAME_CALC'); + CheckNotEquals(ds.FieldDefs[i].Name,'NAME_LKP'); + end; + DS.Close; + finally + ds.Free; + end; +end; + +procedure TTestSpecificTBufDataset.TestAutoIncField; +var + ds : TBufDataset; +begin + ds := GetAutoIncDataset; + DS.Close; + ds.Free; +end; + +procedure TTestSpecificTBufDataset.TestAutoIncFieldStreaming; +begin + IntTestAutoIncFieldStreaming(false); +end; + +procedure TTestSpecificTBufDataset.TestAutoIncFieldStreamingXML; +begin + IntTestAutoIncFieldStreaming(true); +end; + initialization {$ifdef fpc} diff --git a/mips/packages/fcl-db/tests/toolsunit.pas b/mips/packages/fcl-db/tests/toolsunit.pas index 548c857c2c..bdbb494573 100644 --- a/mips/packages/fcl-db/tests/toolsunit.pas +++ b/mips/packages/fcl-db/tests/toolsunit.pas @@ -311,6 +311,8 @@ begin testValues[ftFixedChar] := testStringValues; testValues[ftTime] := testTimeValues; testValues[ftDate] := testDateValues; + testValues[ftBlob] := testStringValues; + testValues[ftMemo] := testStringValues; testValues[ftFMTBcd] := testFmtBCDValues; for i := 0 to testValuesCount-1 do begin diff --git a/mips/packages/fcl-fpcunit/src/fpcunit.pp b/mips/packages/fcl-fpcunit/src/fpcunit.pp index 07a1ee1696..ce7cd5b23f 100644 --- a/mips/packages/fcl-fpcunit/src/fpcunit.pp +++ b/mips/packages/fcl-fpcunit/src/fpcunit.pp @@ -19,22 +19,10 @@ unit fpcunit; interface -{ The following is wrong. The lineinfo unit only works on platforms that - use stabs. It does not work on platforms that use stabx or Dwarf. The - correct unit can only be safely included by compiling the main program - with -gl. Directly using any of those units won't work most of the time. -} -{$IF not defined(MORPHOS) and not defined(AIX)} - {$DEFINE SHOWLINEINFO} -{$ENDIF} - { Uncomment this define to remove the DUnit compatibility interface. } {$DEFINE DUnit} uses - {$ifdef SHOWLINEINFO} - LineInfo, - {$endif} SysUtils ,Classes ; diff --git a/mips/packages/fcl-image/examples/Makefile b/mips/packages/fcl-image/examples/Makefile index c4a95daf72..e7d04919b2 100644 --- a/mips/packages/fcl-image/examples/Makefile +++ b/mips/packages/fcl-image/examples/Makefile @@ -1,8 +1,8 @@ # -# Don't edit, this file is generated by FPCMake Version 2.0.0 [2012/04/25] +# Don't edit, this file is generated by FPCMake Version 2.0.0 [2012/06/18] # default: all -MAKEFILETARGETS=i386-linux i386-go32v2 i386-win32 i386-os2 i386-freebsd i386-beos i386-haiku i386-netbsd i386-solaris i386-qnx i386-netware i386-openbsd i386-wdosx i386-darwin i386-emx i386-watcom i386-netwlibc i386-wince i386-embedded i386-symbian i386-nativent i386-iphonesim m68k-linux m68k-freebsd m68k-netbsd m68k-amiga m68k-atari m68k-openbsd m68k-palmos m68k-embedded powerpc-linux powerpc-netbsd powerpc-amiga powerpc-macos powerpc-darwin powerpc-morphos powerpc-embedded powerpc-wii powerpc-aix sparc-linux sparc-netbsd sparc-solaris sparc-embedded x86_64-linux x86_64-freebsd x86_64-netbsd x86_64-solaris x86_64-openbsd x86_64-darwin x86_64-win64 x86_64-embedded arm-linux arm-palmos arm-darwin arm-wince arm-gba arm-nds arm-embedded arm-symbian powerpc64-linux powerpc64-darwin powerpc64-embedded powerpc64-aix avr-embedded armeb-linux armeb-embedded mips-linux mipsel-linux +MAKEFILETARGETS=i386-linux i386-go32v2 i386-win32 i386-os2 i386-freebsd i386-beos i386-haiku i386-netbsd i386-solaris i386-qnx i386-netware i386-openbsd i386-wdosx i386-darwin i386-emx i386-watcom i386-netwlibc i386-wince i386-embedded i386-symbian i386-nativent i386-iphonesim m68k-linux m68k-freebsd m68k-netbsd m68k-amiga m68k-atari m68k-openbsd m68k-palmos m68k-embedded powerpc-linux powerpc-netbsd powerpc-amiga powerpc-macos powerpc-darwin powerpc-morphos powerpc-embedded powerpc-wii powerpc-aix sparc-linux sparc-netbsd sparc-solaris sparc-embedded x86_64-linux x86_64-freebsd x86_64-netbsd x86_64-solaris x86_64-openbsd x86_64-darwin x86_64-win64 x86_64-embedded arm-linux arm-palmos arm-darwin arm-wince arm-gba arm-nds arm-embedded arm-symbian powerpc64-linux powerpc64-darwin powerpc64-embedded powerpc64-aix avr-embedded armeb-linux armeb-embedded mips-linux mipsel-linux jvm-java jvm-android BSDs = freebsd netbsd openbsd darwin UNIXs = linux $(BSDs) solaris qnx haiku aix LIMIT83fs = go32v2 os2 emx watcom @@ -258,11 +258,13 @@ ifndef BINUTILSPREFIX ifndef CROSSBINDIR ifdef CROSSCOMPILE ifndef DARWIN2DARWIN +ifneq ($(CPU_TARGET),jvm) BINUTILSPREFIX=$(CPU_TARGET)-$(OS_TARGET)- endif endif endif endif +endif UNITSDIR:=$(wildcard $(FPCDIR)/units/$(TARGETSUFFIX)) ifeq ($(UNITSDIR),) UNITSDIR:=$(wildcard $(FPCDIR)/units/$(OS_TARGET)) @@ -293,208 +295,214 @@ FPCFPMAKE=$(FPC) endif endif ifeq ($(FULL_TARGET),i386-linux) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),i386-go32v2) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),i386-win32) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),i386-os2) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),i386-freebsd) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),i386-beos) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),i386-haiku) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),i386-netbsd) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),i386-solaris) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),i386-qnx) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),i386-netware) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),i386-openbsd) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),i386-wdosx) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),i386-darwin) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),i386-emx) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),i386-watcom) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),i386-netwlibc) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),i386-wince) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),i386-embedded) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),i386-symbian) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),i386-nativent) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),i386-iphonesim) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),m68k-linux) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),m68k-freebsd) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),m68k-netbsd) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),m68k-amiga) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),m68k-atari) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),m68k-openbsd) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),m68k-palmos) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),m68k-embedded) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),powerpc-linux) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),powerpc-netbsd) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),powerpc-amiga) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),powerpc-macos) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),powerpc-darwin) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),powerpc-morphos) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),powerpc-embedded) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),powerpc-wii) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),powerpc-aix) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),sparc-linux) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),sparc-netbsd) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),sparc-solaris) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),sparc-embedded) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),x86_64-linux) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),x86_64-freebsd) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),x86_64-netbsd) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),x86_64-solaris) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),x86_64-openbsd) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),x86_64-darwin) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),x86_64-win64) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),x86_64-embedded) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),arm-linux) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),arm-palmos) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),arm-darwin) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),arm-wince) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),arm-gba) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),arm-nds) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),arm-embedded) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),arm-symbian) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),powerpc64-linux) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),powerpc64-darwin) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),powerpc64-embedded) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),powerpc64-aix) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),avr-embedded) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),armeb-linux) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),armeb-embedded) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),mips-linux) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif ifeq ($(FULL_TARGET),mipsel-linux) -override TARGET_PROGRAMS+=imgconv drawing xwdtobmp +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo +endif +ifeq ($(FULL_TARGET),jvm-java) +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo +endif +ifeq ($(FULL_TARGET),jvm-android) +override TARGET_PROGRAMS+=imgconv drawing xwdtobmp interpoldemo endif override INSTALL_FPCPACKAGE=y ifdef REQUIRE_UNITSDIR @@ -854,6 +862,18 @@ BATCHEXT=.sh EXEEXT= SHORTSUFFIX=aix endif +ifeq ($(OS_TARGET),java) +OEXT=.class +ASMEXT=.j +SHAREDLIBEXT=.jar +SHORTSUFFIX=java +endif +ifeq ($(OS_TARGET),android) +OEXT=.class +ASMEXT=.j +SHAREDLIBEXT=.jar +SHORTSUFFIX=android +endif ifneq ($(findstring $(OS_SOURCE),$(LIMIT83fs)),) FPCMADE=fpcmade.$(SHORTSUFFIX) ZIPSUFFIX=$(SHORTSUFFIX) @@ -1640,6 +1660,22 @@ REQUIRE_PACKAGES_HASH=1 REQUIRE_PACKAGES_FPMKUNIT=1 REQUIRE_PACKAGES_FCL-IMAGE=1 endif +ifeq ($(FULL_TARGET),jvm-java) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_PASZLIB=1 +REQUIRE_PACKAGES_FCL-PROCESS=1 +REQUIRE_PACKAGES_HASH=1 +REQUIRE_PACKAGES_FPMKUNIT=1 +REQUIRE_PACKAGES_FCL-IMAGE=1 +endif +ifeq ($(FULL_TARGET),jvm-android) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_PASZLIB=1 +REQUIRE_PACKAGES_FCL-PROCESS=1 +REQUIRE_PACKAGES_HASH=1 +REQUIRE_PACKAGES_FPMKUNIT=1 +REQUIRE_PACKAGES_FCL-IMAGE=1 +endif ifdef REQUIRE_PACKAGES_RTL PACKAGEDIR_RTL:=$(firstword $(subst /Makefile.fpc,,$(strip $(wildcard $(addsuffix /rtl/Makefile.fpc,$(PACKAGESDIR)))))) ifneq ($(PACKAGEDIR_RTL),) @@ -1980,17 +2016,12 @@ endif endif ifdef CREATESHARED override FPCOPT+=-Cg -ifeq ($(CPU_TARGET),i386) -override FPCOPT+=-Aas endif -endif -ifeq ($(findstring 2.0.,$(FPC_VERSION)),) ifneq ($(findstring $(OS_TARGET),freebsd openbsd netbsd linux solaris),) ifeq ($(CPU_TARGET),x86_64) override FPCOPT+=-Cg endif endif -endif ifdef LINKSHARED endif ifdef OPT diff --git a/mips/packages/fcl-image/examples/Makefile.fpc b/mips/packages/fcl-image/examples/Makefile.fpc index 3a6ad2d8fe..aeebf608cb 100644 --- a/mips/packages/fcl-image/examples/Makefile.fpc +++ b/mips/packages/fcl-image/examples/Makefile.fpc @@ -3,7 +3,7 @@ # [target] -programs=imgconv drawing xwdtobmp +programs=imgconv drawing xwdtobmp interpoldemo [require] packages=fcl-image diff --git a/mips/packages/fcl-image/examples/drawing.pp b/mips/packages/fcl-image/examples/drawing.pp index 4a50fc8a68..518e867b43 100644 --- a/mips/packages/fcl-image/examples/drawing.pp +++ b/mips/packages/fcl-image/examples/drawing.pp @@ -2,7 +2,7 @@ program Drawing; uses classes, sysutils, - FPImage, FPCanvas, FPImgCanv, + FPImage, FPCanvas, FPImgCanv, ftFont, FPWritePNG, FPReadPNG; const @@ -13,6 +13,7 @@ var canvas : TFPcustomCAnvas; ci, image : TFPCustomImage; writer : TFPCustomImageWriter; reader : TFPCustomImageReader; + f : TFreeTypeFont; begin image := TFPMemoryImage.Create (100,100); ci := TFPMemoryImage.Create (20,20); @@ -27,7 +28,7 @@ begin GrayScale := false; end; try - ci.LoadFromFile ('test.png', reader); +// ci.LoadFromFile ('test.png', reader); with Canvas as TFPImageCanvas do begin pen.mode := pmCopy; @@ -51,11 +52,13 @@ begin end; pen.style := psSolid; RelativeBrushImage := true; +{ brush.image := ci; brush.style := bsimage; with brush.FPColor do green := green div 2; Ellipse (11,11, 89,89); +} brush.style := bsSolid; brush.FPColor := MyColor; @@ -68,8 +71,19 @@ begin pen.FPColor := colCyan; ellipseC (50,50, 1,1); - writeln ('Saving to inspect !'); + InitEngine; + F:=TFreeTypeFont.Create; + F.Angle:=0.15; + Font:=F; +// Font.Name:='/usr/share/fonts/truetype/ttf-dejavu/DejaVuSans.ttf'; + Font.Name:='/home/michael/Documents/arial.ttf'; + Font.Size:=10; + Font.FPColor:=colWhite; +// Font.Orientation:=900; + + Canvas.TextOut(10,90,'o'); end; + writeln ('Saving to inspect !'); image.SaveToFile ('DrawTest.png', writer); finally Canvas.Free; @@ -81,7 +95,7 @@ begin end; begin - // DefaultFontPath := 'c:\winnt\fonts\'; +// DefaultFontPath := '/usr/share/fonts/truetype/ttf-dejavu/'; DoDraw; end. diff --git a/mips/packages/fcl-image/examples/interpoldemo.pp b/mips/packages/fcl-image/examples/interpoldemo.pp new file mode 100644 index 0000000000..13fed448b9 --- /dev/null +++ b/mips/packages/fcl-image/examples/interpoldemo.pp @@ -0,0 +1,39 @@ +program interpoldemo; +// Interpolation demo for fcl-image by Bernd Kreuss. Mantis #22245 +// Loads original.png (not included) and scales it back to 64x64 + +{$mode objfpc}{$H+} + +uses + Classes, + sysutils, + FPimage, + FPImgCanv, + FPReadPNG, + FPWritePNG; + +var + ImOriginal: TFPMemoryImage; + ImScaled: TFPMemoryImage; + CanvScaled: TFPImageCanvas; + Reader: TFPReaderPNG; + Writer: TFPWriterPNG; + +begin + ImOriginal := TFPMemoryImage.Create(0, 0); + ImScaled := TFPMemoryImage.Create(64, 64); + Reader := TFPReaderPNG.create; + Writer := TFPWriterPNG.create; + Writer.UseAlpha := True; + ImOriginal.LoadFromFile('original.png', Reader); + + CanvScaled := TFPImageCanvas.create(ImScaled); + CanvScaled.StretchDraw(0,0,63,63, ImOriginal); + + ImScaled.SaveToFile('scaled.png', Writer); + Reader.Free; + Writer.Free; + ImOriginal.Free; + ImScaled.Free; +end. + diff --git a/mips/packages/fcl-image/fpmake.pp b/mips/packages/fcl-image/fpmake.pp index f8dcfc0eb7..afaad2723d 100644 --- a/mips/packages/fcl-image/fpmake.pp +++ b/mips/packages/fcl-image/fpmake.pp @@ -87,6 +87,7 @@ begin AddInclude('fphandler.inc'); AddInclude('fppalette.inc'); AddInclude('fpcolcnv.inc'); + AddInclude('fpcompactimg.inc'); end; T:=P.Targets.AddUnit('fpimgcanv.pp'); with T.Dependencies do @@ -260,7 +261,10 @@ begin AddUnit('fpcanvas'); end; T:=P.Targets.AddUnit('targacmn.pp'); - + T:=P.Targets.AddUnit('fpimggauss.pp'); + With T.Dependencies do + AddUnit('fpimage'); + P.ExamplePath.Add('examples'); T:=P.Targets.AddExampleProgram('drawing.pp'); T:=P.Targets.AddExampleProgram('imgconv.pp'); diff --git a/mips/packages/fcl-image/src/fpcompactimg.inc b/mips/packages/fcl-image/src/fpcompactimg.inc new file mode 100644 index 0000000000..6140962b4e --- /dev/null +++ b/mips/packages/fcl-image/src/fpcompactimg.inc @@ -0,0 +1,597 @@ +{%MainUnit fpimage.pp} +{ + This file is part of the Free Pascal run time library. + Copyright (c) 2012 by the Free Pascal development team + + Compact images (images with less than 64-bit depth) support, by Mattias Gaertner + + 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. + + **********************************************************************} + +function GetFPCompactImgDesc(Gray: boolean; Depth: word; HasAlpha: boolean + ): TFPCompactImgDesc; +begin + Result.Gray:=Gray; + Result.Depth:=Depth; + Result.HasAlpha:=HasAlpha; +end; + +function GetFPCompactImgClass(const Desc: TFPCompactImgDesc): TFPCompactImgBaseClass; +begin + if Desc.Gray then begin + if Desc.HasAlpha then begin + // gray, alpha + if Desc.Depth<=8 then + Result:=TFPCompactImgGrayAlpha8Bit + else + Result:=TFPCompactImgGrayAlpha16Bit; + end else begin + // gray, no alpha + if Desc.Depth<=8 then + Result:=TFPCompactImgGray8Bit + else + Result:=TFPCompactImgGray16Bit; + end; + end else begin + // RGB + if Desc.HasAlpha then begin + // RGB, alpha + if Desc.Depth<=8 then + Result:=TFPCompactImgRGBA8Bit + else + Result:=TFPCompactImgRGBA16Bit; + end else begin + // RGB, no alpha + if Desc.Depth<=8 then + Result:=TFPCompactImgRGB8Bit + else + Result:=TFPCompactImgRGB16Bit; + end; + end; +end; + +function CreateFPCompactImg(const Desc: TFPCompactImgDesc; Width, Height: integer + ): TFPCustomImage; +var + ImgClass: TFPCompactImgBaseClass; +begin + ImgClass:=GetFPCompactImgClass(Desc); + Result:=ImgClass.Create(Width,Height); +end; + +function CreateCompatibleFPCompactImg(Img: TFPCustomImage; Width, Height: integer + ): TFPCustomImage; +begin + if Img is TFPCompactImgBase then + Result:=CreateFPCompactImg(TFPCompactImgBase(Img).Desc,Width,Height) + else + Result:=CreateFPCompactImg(GetMinimumPTDesc(Img),Width,Height); +end; + +function CreateCompatibleFPCompactImgWithAlpha(Img: TFPCustomImage; Width, + Height: integer): TFPCustomImage; +var + Desc: TFPCompactImgDesc; +begin + if Img is TFPCompactImgBase then + Desc:=TFPCompactImgBase(Img).Desc + else + Desc:=GetMinimumPTDesc(Img); + Desc.HasAlpha:=true; + Result:=CreateFPCompactImg(Desc,Width,Height); +end; + +function GetMinimumPTDesc(Img: TFPCustomImage; FuzzyDepth: word = 4): TFPCompactImgDesc; +var + AllLoEqualsHi, AllLoAre0: Boolean; + FuzzyMaskLoHi: Word; + + procedure Need16Bit(c: word); inline; + var + l: Byte; + begin + c:=c and FuzzyMaskLoHi; + l:=Lo(c); + AllLoAre0:=AllLoAre0 and (l=0); + AllLoEqualsHi:=AllLoEqualsHi and (l=Hi(c)); + end; + +var + TestGray: Boolean; + TestAlpha: Boolean; + Test16Bit: Boolean; + BaseImg: TFPCompactImgBase; + ImgDesc: TFPCompactImgDesc; + y: Integer; + x: Integer; + col: TFPColor; + FuzzyMaskWord: Word; + FuzzyOpaque: Word; +begin + TestGray:=true; + TestAlpha:=true; + Test16Bit:=FuzzyDepth<8; + Result.HasAlpha:=false; + Result.Gray:=true; + Result.Depth:=8; + if Img is TFPCompactImgBase then begin + BaseImg:=TFPCompactImgBase(Img); + ImgDesc:=BaseImg.Desc; + if ImgDesc.Depth<=8 then Test16Bit:=false; + if ImgDesc.Gray then TestGray:=false; + if not ImgDesc.HasAlpha then TestAlpha:=false; + end; + + if (not TestGray) and (not TestAlpha) and (not Test16Bit) then exit; + + FuzzyMaskWord:=Word($ffff) shl FuzzyDepth; + FuzzyOpaque:=alphaOpaque and FuzzyMaskWord; + FuzzyMaskLoHi:=Word(lo(FuzzyMaskWord))+(Word(lo(FuzzyMaskWord)) shl 8); + AllLoAre0:=true; + AllLoEqualsHi:=true; + for y:=0 to Img.Height-1 do begin + for x:=0 to Img.Width-1 do begin + col:=Img.Colors[x,y]; + if TestAlpha and ((col.alpha and FuzzyMaskWord)<>FuzzyOpaque) then begin + TestAlpha:=false; + Result.HasAlpha:=true; + if (not TestGray) and (not Test16Bit) then break; + end; + if TestGray + and ((col.red and FuzzyMaskWord)<>(col.green and FuzzyMaskWord)) + or ((col.red and FuzzyMaskWord)<>(col.blue and FuzzyMaskWord)) then begin + TestGray:=false; + Result.Gray:=false; + if (not TestAlpha) and (not Test16Bit) then break; + end; + if Test16Bit then begin + Need16Bit(col.red); + Need16Bit(col.green); + Need16Bit(col.blue); + Need16Bit(col.alpha); + if (not AllLoAre0) and (not AllLoEqualsHi) then begin + Test16Bit:=false; + Result.Depth:=16; + if (not TestAlpha) and (not TestGray) then break; + end; + end; + end; + end; +end; + +function GetMinimumFPCompactImg(Img: TFPCustomImage; FreeImg: boolean; + FuzzyDepth: word = 4): TFPCustomImage; +var + Desc: TFPCompactImgDesc; + ImgClass: TFPCompactImgBaseClass; + y: Integer; + x: Integer; +begin + Desc:=GetMinimumPTDesc(Img,FuzzyDepth); + ImgClass:=GetFPCompactImgClass(Desc); + if Img.ClassType=ImgClass then + exit(Img); + Result:=CreateFPCompactImg(Desc,Img.Width,Img.Height); + for y:=0 to Img.Height-1 do + for x:=0 to Img.Width-1 do + Result.Colors[x,y]:=Img.Colors[x,y]; + if FreeImg then + Img.Free; +end; + +function ColorRound (c : double) : word; +begin + if c > $FFFF then + result := $FFFF + else if c < 0.0 then + result := 0 + else + result := round(c); +end; + +{ TFPCompactImgGrayAlpha16Bit } + +function TFPCompactImgGrayAlpha16Bit.GetInternalColor(x, y: integer): TFPColor; +var + v: TFPCompactImgGrayAlpha16BitValue; +begin + v:=FData[x+y*Width]; + Result.red:=v.g; + Result.green:=Result.red; + Result.blue:=Result.red; + Result.alpha:=v.a; +end; + +function TFPCompactImgGrayAlpha16Bit.GetInternalPixel(x, y: integer): integer; +begin + Result:=0; +end; + +procedure TFPCompactImgGrayAlpha16Bit.SetInternalColor(x, y: integer; + const Value: TFPColor); +var + v: TFPCompactImgGrayAlpha16BitValue; +begin + v.g:=Value.red; + v.a:=Value.alpha; + FData[x+y*Width]:=v; +end; + +procedure TFPCompactImgGrayAlpha16Bit.SetInternalPixel(x, y: integer; Value: integer + ); +begin + +end; + +constructor TFPCompactImgGrayAlpha16Bit.Create(AWidth, AHeight: integer); +begin + FDesc:=GetFPCompactImgDesc(true,16,true); + inherited Create(AWidth, AHeight); +end; + +destructor TFPCompactImgGrayAlpha16Bit.Destroy; +begin + ReAllocMem(FData,0); + inherited Destroy; +end; + +procedure TFPCompactImgGrayAlpha16Bit.SetSize(AWidth, AHeight: integer); +begin + if (AWidth=Width) and (AHeight=Height) then exit; + ReAllocMem(FData,SizeOf(TFPCompactImgGrayAlpha16BitValue)*AWidth*AHeight); + inherited SetSize(AWidth, AHeight); +end; + +{ TFPCompactImgGrayAlpha8Bit } + +function TFPCompactImgGrayAlpha8Bit.GetInternalColor(x, y: integer): TFPColor; +var + v: TFPCompactImgGrayAlpha8BitValue; +begin + v:=FData[x+y*Width]; + Result.red:=(v.g shl 8)+v.g; + Result.green:=Result.red; + Result.blue:=Result.red; + Result.alpha:=(v.a shl 8)+v.a; +end; + +function TFPCompactImgGrayAlpha8Bit.GetInternalPixel(x, y: integer): integer; +begin + Result:=0; +end; + +procedure TFPCompactImgGrayAlpha8Bit.SetInternalColor(x, y: integer; + const Value: TFPColor); +var + v: TFPCompactImgGrayAlpha8BitValue; +begin + v.g:=Value.red shr 8; + v.a:=Value.alpha shr 8; + FData[x+y*Width]:=v; +end; + +procedure TFPCompactImgGrayAlpha8Bit.SetInternalPixel(x, y: integer; Value: integer + ); +begin + +end; + +constructor TFPCompactImgGrayAlpha8Bit.Create(AWidth, AHeight: integer); +begin + FDesc:=GetFPCompactImgDesc(true,8,true); + inherited Create(AWidth, AHeight); +end; + +destructor TFPCompactImgGrayAlpha8Bit.Destroy; +begin + ReAllocMem(FData,0); + inherited Destroy; +end; + +procedure TFPCompactImgGrayAlpha8Bit.SetSize(AWidth, AHeight: integer); +begin + if (AWidth=Width) and (AHeight=Height) then exit; + ReAllocMem(FData,SizeOf(TFPCompactImgGrayAlpha8BitValue)*AWidth*AHeight); + inherited SetSize(AWidth, AHeight); +end; + +{ TFPCompactImgGray16Bit } + +function TFPCompactImgGray16Bit.GetInternalColor(x, y: integer): TFPColor; +begin + Result.red:=FData[x+y*Width]; + Result.green:=Result.red; + Result.blue:=Result.red; + Result.alpha:=alphaOpaque; +end; + +function TFPCompactImgGray16Bit.GetInternalPixel(x, y: integer): integer; +begin + Result:=0; +end; + +procedure TFPCompactImgGray16Bit.SetInternalColor(x, y: integer; + const Value: TFPColor); +begin + FData[x+y*Width]:=Value.red; +end; + +procedure TFPCompactImgGray16Bit.SetInternalPixel(x, y: integer; Value: integer); +begin + +end; + +constructor TFPCompactImgGray16Bit.Create(AWidth, AHeight: integer); +begin + FDesc:=GetFPCompactImgDesc(true,16,false); + inherited Create(AWidth, AHeight); +end; + +destructor TFPCompactImgGray16Bit.Destroy; +begin + ReAllocMem(FData,0); + inherited Destroy; +end; + +procedure TFPCompactImgGray16Bit.SetSize(AWidth, AHeight: integer); +begin + if (AWidth=Width) and (AHeight=Height) then exit; + ReAllocMem(FData,SizeOf(Word)*AWidth*AHeight); + inherited SetSize(AWidth,AHeight); +end; + +{ TFPCompactImgGray8Bit } + +function TFPCompactImgGray8Bit.GetInternalColor(x, y: integer): TFPColor; +begin + Result.red:=FData[x+y*Width]; + Result.red:=(Word(Result.red) shl 8)+Result.red; + Result.green:=Result.red; + Result.blue:=Result.red; + Result.alpha:=alphaOpaque; +end; + +function TFPCompactImgGray8Bit.GetInternalPixel(x, y: integer): integer; +begin + Result:=0; +end; + +procedure TFPCompactImgGray8Bit.SetInternalColor(x, y: integer; + const Value: TFPColor); +begin + FData[x+y*Width]:=Value.red shr 8; +end; + +procedure TFPCompactImgGray8Bit.SetInternalPixel(x, y: integer; Value: integer); +begin + +end; + +constructor TFPCompactImgGray8Bit.Create(AWidth, AHeight: integer); +begin + FDesc:=GetFPCompactImgDesc(true,8,false); + inherited Create(AWidth, AHeight); +end; + +destructor TFPCompactImgGray8Bit.Destroy; +begin + ReAllocMem(FData,0); + inherited Destroy; +end; + +procedure TFPCompactImgGray8Bit.SetSize(AWidth, AHeight: integer); +begin + if (AWidth=Width) and (AHeight=Height) then exit; + ReAllocMem(FData,SizeOf(Byte)*AWidth*AHeight); + inherited SetSize(AWidth,AHeight); +end; + +{ TFPCompactImgRGBA8Bit } + +function TFPCompactImgRGBA8Bit.GetInternalColor(x, y: integer): TFPColor; +var + v: TFPCompactImgRGBA8BitValue; +begin + v:=FData[x+y*Width]; + Result.red:=(v.r shl 8)+v.r; + Result.green:=(v.g shl 8)+v.g; + Result.blue:=(v.b shl 8)+v.b; + Result.alpha:=(v.a shl 8)+v.a; +end; + +function TFPCompactImgRGBA8Bit.GetInternalPixel(x, y: integer): integer; +begin + Result:=0; +end; + +procedure TFPCompactImgRGBA8Bit.SetInternalColor(x, y: integer; + const Value: TFPColor); +var + v: TFPCompactImgRGBA8BitValue; +begin + v.r:=Value.red shr 8; + v.g:=Value.green shr 8; + v.b:=Value.blue shr 8; + v.a:=Value.alpha shr 8; + FData[x+y*Width]:=v; +end; + +procedure TFPCompactImgRGBA8Bit.SetInternalPixel(x, y: integer; Value: integer); +begin + +end; + +constructor TFPCompactImgRGBA8Bit.Create(AWidth, AHeight: integer); +begin + FDesc:=GetFPCompactImgDesc(false,8,true); + inherited Create(AWidth, AHeight); +end; + +destructor TFPCompactImgRGBA8Bit.Destroy; +begin + ReAllocMem(FData,0); + inherited Destroy; +end; + +procedure TFPCompactImgRGBA8Bit.SetSize(AWidth, AHeight: integer); +begin + if (AWidth=Width) and (AHeight=Height) then exit; + ReAllocMem(FData,SizeOf(TFPCompactImgRGBA8BitValue)*AWidth*AHeight); + inherited SetSize(AWidth,AHeight); +end; + +{ TFPCompactImgRGB8Bit } + +function TFPCompactImgRGB8Bit.GetInternalColor(x, y: integer): TFPColor; +var + v: TFPCompactImgRGB8BitValue; +begin + v:=FData[x+y*Width]; + Result.red:=(v.r shl 8)+v.r; + Result.green:=(v.g shl 8)+v.g; + Result.blue:=(v.b shl 8)+v.b; + Result.alpha:=alphaOpaque; +end; + +function TFPCompactImgRGB8Bit.GetInternalPixel(x, y: integer): integer; +begin + Result:=0; +end; + +procedure TFPCompactImgRGB8Bit.SetInternalColor(x, y: integer; const Value: TFPColor + ); +var + v: TFPCompactImgRGB8BitValue; +begin + v.r:=Value.red shr 8; + v.g:=Value.green shr 8; + v.b:=Value.blue shr 8; + FData[x+y*Width]:=v; +end; + +procedure TFPCompactImgRGB8Bit.SetInternalPixel(x, y: integer; Value: integer); +begin + +end; + +constructor TFPCompactImgRGB8Bit.Create(AWidth, AHeight: integer); +begin + FDesc:=GetFPCompactImgDesc(false,8,false); + inherited Create(AWidth, AHeight); +end; + +destructor TFPCompactImgRGB8Bit.Destroy; +begin + ReAllocMem(FData,0); + inherited Destroy; +end; + +procedure TFPCompactImgRGB8Bit.SetSize(AWidth, AHeight: integer); +begin + if (AWidth=Width) and (AHeight=Height) then exit; + ReAllocMem(FData,SizeOf(TFPCompactImgRGB8BitValue)*AWidth*AHeight); + inherited SetSize(AWidth,AHeight); +end; + +{ TFPCompactImgRGB16Bit } + +function TFPCompactImgRGB16Bit.GetInternalColor(x, y: integer): TFPColor; +var + v: TFPCompactImgRGB16BitValue; +begin + v:=FData[x+y*Width]; + Result.red:=v.r; + Result.green:=v.g; + Result.blue:=v.b; + Result.alpha:=alphaOpaque; +end; + +function TFPCompactImgRGB16Bit.GetInternalPixel(x, y: integer): integer; +begin + Result:=0; +end; + +procedure TFPCompactImgRGB16Bit.SetInternalColor(x, y: integer; + const Value: TFPColor); +var + v: TFPCompactImgRGB16BitValue; +begin + v.r:=Value.red; + v.g:=Value.green; + v.b:=Value.blue; + FData[x+y*Width]:=v; +end; + +procedure TFPCompactImgRGB16Bit.SetInternalPixel(x, y: integer; Value: integer); +begin + +end; + +constructor TFPCompactImgRGB16Bit.Create(AWidth, AHeight: integer); +begin + FDesc:=GetFPCompactImgDesc(false,16,false); + inherited Create(AWidth, AHeight); +end; + +destructor TFPCompactImgRGB16Bit.Destroy; +begin + ReAllocMem(FData,0); + inherited Destroy; +end; + +procedure TFPCompactImgRGB16Bit.SetSize(AWidth, AHeight: integer); +begin + if (AWidth=Width) and (AHeight=Height) then exit; + ReAllocMem(FData,SizeOf(TFPCompactImgRGB16BitValue)*AWidth*AHeight); + inherited SetSize(AWidth,AHeight); +end; + +{ TFPCompactImgRGBA16Bit } + +function TFPCompactImgRGBA16Bit.GetInternalColor(x, y: integer): TFPColor; +begin + Result:=FData[x+y*Width]; +end; + +function TFPCompactImgRGBA16Bit.GetInternalPixel(x, y: integer): integer; +begin + Result:=0; +end; + +procedure TFPCompactImgRGBA16Bit.SetInternalColor(x, y: integer; + const Value: TFPColor); +begin + FData[x+y*Width]:=Value; +end; + +procedure TFPCompactImgRGBA16Bit.SetInternalPixel(x, y: integer; Value: integer); +begin + +end; + +constructor TFPCompactImgRGBA16Bit.Create(AWidth, AHeight: integer); +begin + FDesc:=GetFPCompactImgDesc(false,16,true); + inherited Create(AWidth, AHeight); +end; + +destructor TFPCompactImgRGBA16Bit.Destroy; +begin + ReAllocMem(FData,0); + inherited Destroy; +end; + +procedure TFPCompactImgRGBA16Bit.SetSize(AWidth, AHeight: integer); +begin + if (AWidth=Width) and (AHeight=Height) then exit; + ReAllocMem(FData,SizeOf(TFPColor)*AWidth*AHeight); + inherited SetSize(AWidth,AHeight); +end; + + diff --git a/mips/packages/fcl-image/src/fpimage.pp b/mips/packages/fcl-image/src/fpimage.pp index e98ebd7c19..fde1c6bf12 100644 --- a/mips/packages/fcl-image/src/fpimage.pp +++ b/mips/packages/fcl-image/src/fpimage.pp @@ -343,6 +343,202 @@ function CreateWebSafePalette : TFPPalette; function CreateGrayScalePalette : TFPPalette; function CreateVGAPalette : TFPPalette; +Type + TFPCompactImgDesc = record + Gray: boolean; // true = red=green=blue, false: a RGB image + Depth: word; // 8 or 16 bit + HasAlpha: boolean; // has alpha channel + end; + + { TFPCompactImgBase } + + TFPCompactImgBase = class(TFPCustomImage) + private + FDesc: TFPCompactImgDesc; + public + property Desc: TFPCompactImgDesc read FDesc; + end; + TFPCompactImgBaseClass = class of TFPCompactImgBase; + + { TFPCompactImgGray16Bit } + + TFPCompactImgGray16Bit = class(TFPCompactImgBase) + protected + FData: PWord; + function GetInternalColor(x, y: integer): TFPColor; override; + function GetInternalPixel({%H-}x, {%H-}y: integer): integer; override; + procedure SetInternalColor (x, y: integer; const Value: TFPColor); override; + procedure SetInternalPixel({%H-}x, {%H-}y: integer; {%H-}Value: integer); override; + public + constructor Create(AWidth, AHeight: integer); override; + destructor Destroy; override; + procedure SetSize(AWidth, AHeight: integer); override; + end; + + TFPCompactImgGrayAlpha16BitValue = packed record + g,a: word; + end; + PFPCompactImgGrayAlpha16BitValue = ^TFPCompactImgGrayAlpha16BitValue; + + { TFPCompactImgGrayAlpha16Bit } + + TFPCompactImgGrayAlpha16Bit = class(TFPCompactImgBase) + protected + FData: PFPCompactImgGrayAlpha16BitValue; + function GetInternalColor(x, y: integer): TFPColor; override; + function GetInternalPixel({%H-}x, {%H-}y: integer): integer; override; + procedure SetInternalColor (x, y: integer; const Value: TFPColor); override; + procedure SetInternalPixel({%H-}x, {%H-}y: integer; {%H-}Value: integer); override; + public + constructor Create(AWidth, AHeight: integer); override; + destructor Destroy; override; + procedure SetSize(AWidth, AHeight: integer); override; + end; + + { TFPCompactImgGray8Bit } + + TFPCompactImgGray8Bit = class(TFPCompactImgBase) + protected + FData: PByte; + function GetInternalColor(x, y: integer): TFPColor; override; + function GetInternalPixel({%H-}x, {%H-}y: integer): integer; override; + procedure SetInternalColor (x, y: integer; const Value: TFPColor); override; + procedure SetInternalPixel({%H-}x, {%H-}y: integer; {%H-}Value: integer); override; + public + constructor Create(AWidth, AHeight: integer); override; + destructor Destroy; override; + procedure SetSize(AWidth, AHeight: integer); override; + end; + + TFPCompactImgGrayAlpha8BitValue = packed record + g,a: byte; + end; + PFPCompactImgGrayAlpha8BitValue = ^TFPCompactImgGrayAlpha8BitValue; + + { TFPCompactImgGrayAlpha8Bit } + + TFPCompactImgGrayAlpha8Bit = class(TFPCompactImgBase) + protected + FData: PFPCompactImgGrayAlpha8BitValue; + function GetInternalColor(x, y: integer): TFPColor; override; + function GetInternalPixel({%H-}x, {%H-}y: integer): integer; override; + procedure SetInternalColor (x, y: integer; const Value: TFPColor); override; + procedure SetInternalPixel({%H-}x, {%H-}y: integer; {%H-}Value: integer); override; + public + constructor Create(AWidth, AHeight: integer); override; + destructor Destroy; override; + procedure SetSize(AWidth, AHeight: integer); override; + end; + + TFPCompactImgRGBA8BitValue = packed record + r,g,b,a: byte; + end; + PFPCompactImgRGBA8BitValue = ^TFPCompactImgRGBA8BitValue; + + { TFPCompactImgRGBA8Bit } + + TFPCompactImgRGBA8Bit = class(TFPCompactImgBase) + protected + FData: PFPCompactImgRGBA8BitValue; + function GetInternalColor(x, y: integer): TFPColor; override; + function GetInternalPixel({%H-}x, {%H-}y: integer): integer; override; + procedure SetInternalColor (x, y: integer; const Value: TFPColor); override; + procedure SetInternalPixel({%H-}x, {%H-}y: integer; {%H-}Value: integer); override; + public + constructor Create(AWidth, AHeight: integer); override; + destructor Destroy; override; + procedure SetSize(AWidth, AHeight: integer); override; + end; + + TFPCompactImgRGB8BitValue = packed record + r,g,b: byte; + end; + PFPCompactImgRGB8BitValue = ^TFPCompactImgRGB8BitValue; + + { TFPCompactImgRGB8Bit } + + TFPCompactImgRGB8Bit = class(TFPCompactImgBase) + protected + FData: PFPCompactImgRGB8BitValue; + function GetInternalColor(x, y: integer): TFPColor; override; + function GetInternalPixel({%H-}x, {%H-}y: integer): integer; override; + procedure SetInternalColor (x, y: integer; const Value: TFPColor); override; + procedure SetInternalPixel({%H-}x, {%H-}y: integer; {%H-}Value: integer); override; + public + constructor Create(AWidth, AHeight: integer); override; + destructor Destroy; override; + procedure SetSize(AWidth, AHeight: integer); override; + end; + + TFPCompactImgRGB16BitValue = packed record + r,g,b: word; + end; + PFPCompactImgRGB16BitValue = ^TFPCompactImgRGB16BitValue; + + { TFPCompactImgRGB16Bit } + + TFPCompactImgRGB16Bit = class(TFPCompactImgBase) + protected + FData: PFPCompactImgRGB16BitValue; + function GetInternalColor(x, y: integer): TFPColor; override; + function GetInternalPixel({%H-}x, {%H-}y: integer): integer; override; + procedure SetInternalColor (x, y: integer; const Value: TFPColor); override; + procedure SetInternalPixel({%H-}x, {%H-}y: integer; {%H-}Value: integer); override; + public + constructor Create(AWidth, AHeight: integer); override; + destructor Destroy; override; + procedure SetSize(AWidth, AHeight: integer); override; + end; + + { TFPCompactImgRGBA16Bit } + + TFPCompactImgRGBA16Bit = class(TFPCompactImgBase) + protected + FData: PFPColor; + function GetInternalColor(x, y: integer): TFPColor; override; + function GetInternalPixel({%H-}x, {%H-}y: integer): integer; override; + procedure SetInternalColor (x, y: integer; const Value: TFPColor); override; + procedure SetInternalPixel({%H-}x, {%H-}y: integer; {%H-}Value: integer); override; + public + constructor Create(AWidth, AHeight: integer); override; + destructor Destroy; override; + procedure SetSize(AWidth, AHeight: integer); override; + end; + +{ Create a descriptor to select a CompactImg class } +function GetFPCompactImgDesc(Gray: boolean; Depth: word; HasAlpha: boolean): TFPCompactImgDesc; + +{ Returns a CompactImg class that fits the descriptor } +function GetFPCompactImgClass(const Desc: TFPCompactImgDesc): TFPCompactImgBaseClass; + +{ Create a CompactImg with the descriptor } +function CreateFPCompactImg(const Desc: TFPCompactImgDesc; Width, Height: integer): TFPCustomImage; + +{ Create a CompactImg with the same features as Img. +If Img is a TFPCompactImgBaseClass it will create that. +Otherwise it returns a CompactImg that fits the Img using GetMinimumPTDesc. } +function CreateCompatibleFPCompactImg(Img: TFPCustomImage; Width, Height: integer +): TFPCustomImage; + +{ As CreateCompatibleFPCompactImg, but the image has always an alpha channel. } +function CreateCompatibleFPCompactImgWithAlpha(Img: TFPCustomImage; +Width, Height: integer): TFPCustomImage; + +{ Returns the smallest descriptor that allows to store the Img. +It returns HasAlpha=false if all pixel are opaque. +It returns Gray=true if all red=green=blue. +It returns Depth=8 if all lo byte equals the hi byte or all lo bytes are 0. +To ignore rounding errors you can pass a FuzzyDepth. For example a FuzzyDepth +of 3 ignores the lower 3 bits when comparing. } +function GetMinimumPTDesc(Img: TFPCustomImage; FuzzyDepth: word = 4): TFPCompactImgDesc; + +{ Create a smaller CompactImg with the same information as Img. +Pass FreeImg=true to call Img.Free } +function GetMinimumFPCompactImg(Img: TFPCustomImage; FreeImg: boolean; +FuzzyDepth: word = 4): TFPCustomImage; + + + implementation procedure FPImgError (Fmt:TErrorTextIndices; data : array of const); @@ -359,6 +555,7 @@ end; {$i FPHandler.inc} {$i FPPalette.inc} {$i FPColCnv.inc} +{$i fpcompactimg.inc} function FPColor (r,g,b:word) : TFPColor; begin diff --git a/mips/packages/fcl-image/src/fpimggauss.pp b/mips/packages/fcl-image/src/fpimggauss.pp new file mode 100644 index 0000000000..3e070abed6 --- /dev/null +++ b/mips/packages/fcl-image/src/fpimggauss.pp @@ -0,0 +1,701 @@ +{ + This file is part of the Free Pascal run time library. + Copyright (c) 2012 by the Free Pascal development team + + fpImage Gaussian blur routines by Mattias Gaertner + + 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 FPImgGauss; + +{$mode objfpc}{$H+} + +interface + +uses + Math, Classes, FPimage; + +{ Fast Gaussian blur to Area (excluding Area.Right and Area.Bottom) + Pixels outside the image are treated as having the same color as the edge. + This is a binominal approximation of fourth degree, so it is pretty near the + real gaussian blur in most cases but much faster for big radius. + Runtime: O((Area.Width+Radius) * (Area.Height+Radius)) } +procedure GaussianBlurBinominal4(AImg: TFPCustomImage; Radius: integer; + SrcArea: TRect); +procedure GaussianBlurBinominal4(SrcImg, DestImg: TFPCustomImage; Radius: integer; + SrcArea: TRect; DestXY: TPoint); + +{ Gaussian blur to Area (excluding Area.Right and Area.Bottom) + Pixels outside the image are treated as having the same color as the edge. + Runtime: O(Area.Width * Area.Height * Radius) } +procedure GaussianBlur(Img: TFPCustomImage; Radius: integer; Area: TRect); + +{ MatrixBlur1D + The Matrix1D has a width of Radius*2+1. + The sum of all entries in the Matrix1D must be <= 65536. + Create Matrix1D with ComputeGaussianBlurMatrix1D. + Each pixel x,y in Area is replaced by a pixel computed from all pixels in + x-Radius..x+Radius, y-Radius..y+Radius + The new value is the sum of all pixels multiplied by Matrix1D, once + horizontally and once vertically. + + Pixels outside the image are treated as having the same color as the edge. + + Runtime is O(Area width * Area height * Radius) } +procedure MatrixBlur1D(Img: TFPCustomImage; Radius: integer; Area: TRect; Matrix1D: PWord); + +{ MatrixBlur2D + The Matrix2D is quadratic and has a width of Radius*2+1. + The sum of all entries in the Matrix2D must be <= 65536. + Create Matrix2D with ComputeGaussianBlurMatrix2D. + Each pixel x,y in Area (Left..Right-1,Top..Bottom-1) is replaced by a pixel + computed from all pixels in x-Radius..x+Radius, y-Radius..y+Radius. + The new value is the sum of all pixels multiplied by Matrix2D. + + Pixels outside the image are treated as having the same color as the edge. + + Runtime is O(Area width * Area height * Radius * Radius) } +procedure MatrixBlur2D(Img: TFPCustomImage; Radius: integer; Area: TRect; Matrix2D: PWord); + +{ ComputeGaussianBlurMatrix1D creates a one dimensional matrix of size + Width = Radius*2+1 + + Deviation := Radius / 3 + G(x) := (1 / SQRT( 2 * pi * Deviation^2)) * e^( - (x^2) / (2 * Deviation^2) ) + + Each word is a factor [0,1) multiplied by 65536. + The total sum of the matrix is 65536. } +function ComputeGaussianBlurMatrix1D(Radius: integer): PWord; + +{ ComputeGaussianBlurMatrix2D creates a two dimensional matrix of quadratic size + Width = Radius*2+1 + + Deviation := Radius / 3 + G(x,y) := (1 / (2 * pi * Deviation^2)) * e^( - (x^2 + y^2) / (2 * Deviation^2) ) + + Each word is a factor [0,1) multiplied by 65536. + The total sum of the matrix is 65536. } +function ComputeGaussianBlurMatrix2D(Radius: integer): PWord; + +implementation + +type + + { TIntRingBuffer } + + TIntRingBuffer = object + private + FSize: integer; + procedure SetSize(AValue: integer); + public + RingBuffer: PFPColor; + procedure Put(Index: integer; const Col: TFPColor); + procedure Get(Index: integer; out Col: TFPColor); + property Size: integer read FSize write SetSize; + procedure Init(len: integer); + procedure Clear; + end; + +{ TIntRingBuffer } + +procedure TIntRingBuffer.SetSize(AValue: integer); +begin + if FSize=AValue then Exit; + FSize:=AValue; + ReAllocMem(RingBuffer,AValue*SizeOf(TFPColor)); +end; + +procedure TIntRingBuffer.Put(Index: integer; const Col: TFPColor); +begin + Index:=Index mod FSize; + if Index<0 then inc(Index,FSize); + RingBuffer[Index]:=Col; +end; + +procedure TIntRingBuffer.Get(Index: integer; out Col: TFPColor); +begin + Index:=Index mod FSize; + if Index<0 then inc(Index,FSize); + Col:=RingBuffer[Index]; +end; + +procedure TIntRingBuffer.Init(len: integer); +begin + FSize:=0; + RingBuffer:=nil; + Size:=len; +end; + +procedure TIntRingBuffer.Clear; +begin + Size:=0; +end; + +procedure GaussianBlurBinominal4(AImg: TFPCustomImage; Radius: integer; + SrcArea: TRect); +begin + GaussianBlurBinominal4(AImg,AImg,Radius,SrcArea,SrcArea.TopLeft); +end; + +procedure GaussianBlurBinominal4(SrcImg, DestImg: TFPCustomImage; + Radius: integer; SrcArea: TRect; DestXY: TPoint); +type + TIntegerColor = record + red, green, blue, alpha: integer; + end; +const + clearIntegerColor: TIntegerColor = (red:0;green:0;blue:0;alpha:0); +var + x,y,i: LongInt; + Pixel: TFPColor; + difference: TIntegerColor; + derivative1: TIntegerColor; + derivative2: TIntegerColor; + sum: TIntegerColor; + Weight: Single; + col: TFPColor; + buffer: TIntRingBuffer; + Col1, Col2, Col3, Col4: TFPColor; +begin + // clip + if SrcArea.Left<0 then begin + dec(DestXY.X,SrcArea.Left); + SrcArea.Left:=0; + end; + if SrcArea.Top<0 then begin + dec(DestXY.Y,SrcArea.Top); + SrcArea.Top:=0; + end; + SrcArea.Right:=Min(SrcImg.Width,SrcArea.Right); + SrcArea.Top:=Min(SrcImg.Height,SrcArea.Top); + SrcArea.Right:=Min(SrcArea.Right,DestImg.Width-DestXY.X+SrcArea.Left); + SrcArea.Bottom:=Min(SrcArea.Bottom,DestImg.Height-DestXY.Y+SrcArea.Top); + if SrcArea.Left>=SrcArea.Right then exit; + if SrcArea.Top>=SrcArea.Bottom then exit; + + // blur -- RingBuffer of Size 147 is needed. range=(0,(int)(N_CELLS/4/1.73)) + // N_CELLS=1024 don't ask! see paper: gauss.pdf, 3.sourcecdoe + // Or 4*Radius+1, sounds better. see Comment underneath + //Radius:=round(sqrt(3*Radius*Radius)); + buffer.Init(4*Radius); + Weight := 1.0/(single(Radius*Radius*Radius*Radius)); + // vertical blur + for x:=SrcArea.Left to SrcArea.Right-1 do begin + // set up init values for the first blur + difference:=clearIntegerColor; + derivative1:=clearIntegerColor; + derivative2:=clearIntegerColor; + sum:=clearIntegerColor; + for y:=SrcArea.Top-4*Radius to SrcArea.Bottom-1 do begin + if y >= SrcArea.Top then begin //{+1,-4,+6,-4,+1} + buffer.Get(y-2*Radius,Col1); + buffer.Get(y-Radius,Col2); + buffer.Get(y,Col3); + buffer.Get(y+Radius,Col4); + difference.alpha :=difference.alpha+Col1.alpha-4*(Col2.alpha+Col4.alpha)+6*Col3.alpha; + difference.red :=difference.red +Col1.red -4*(Col2.red +Col4.red) +6*Col3.red; + difference.green :=difference.green+Col1.green-4*(Col2.green+Col4.green)+6*Col3.green; + difference.blue :=difference.blue +Col1.blue -4*(Col2.blue +Col4.blue) +6*Col3.blue; + col:=SrcImg.Colors[x,y]; + col.alpha:=min($FFFF,max(0,round(sum.alpha*Weight))); + col.red :=min($FFFF,max(0,round(sum.red *Weight))); + col.green:=min($FFFF,max(0,round(sum.green*Weight))); + col.blue :=min($FFFF,max(0,round(sum.blue *Weight))); + DestImg.Colors[x,y]:=col; // set blurred pixel + end else begin + if (y+3*Radius) >= SrcArea.Top then begin + // -4*buffer(y+Radius) + buffer.Get(y+Radius,Col4); + difference.alpha:=difference.alpha-4*Col4.alpha; + difference.red :=difference.red -4*Col4.red; + difference.green:=difference.green-4*Col4.green; + difference.blue :=difference.blue -4*Col4.blue; + end; + if (y+2*Radius) >= SrcArea.Top then begin + // +6*buffer(y) + buffer.Get(y,Col3); + difference.alpha:=difference.alpha+6*Col4.alpha; + difference.red :=difference.red +6*Col4.red; + difference.green:=difference.green+6*Col4.green; + difference.blue :=difference.blue +6*Col4.blue; + end; + if (y+ Radius) >= SrcArea.Top then begin + // -4*buffer(y-Radius) + buffer.Get(y-Radius,Col2); + difference.alpha:=difference.alpha-4*Col2.alpha; + difference.red :=difference.red -4*Col2.red; + difference.green:=difference.green-4*Col2.green; + difference.blue :=difference.blue -4*Col2.blue; + end; + end; + i:=Min(DestImg.Height-1,Max(0,y+2*Radius-1)); + // accumulate pixel blur + pixel := SrcImg.Colors[x,i]; + difference.alpha := difference.alpha+pixel.alpha; + difference.red := difference.red +pixel.red; + difference.green := difference.green+pixel.green; + difference.blue := difference.blue +pixel.blue; + derivative2.alpha := derivative2.alpha+difference.alpha; + derivative2.red := derivative2.red +difference.red; + derivative2.green := derivative2.green+difference.green; + derivative2.blue := derivative2.blue +difference.blue; + derivative1.alpha := derivative1.alpha+derivative2.alpha; + derivative1.red := derivative1.red +derivative2.red; + derivative1.green := derivative1.green+derivative2.green; + derivative1.blue := derivative1.blue +derivative2.blue; + sum.alpha := sum.alpha+derivative1.alpha; + sum.red := sum.red +derivative1.red; + sum.green := sum.green+derivative1.green; + sum.blue := sum.blue +derivative1.blue; + buffer.Put(y+2*Radius,pixel); // buffer pixel, min buffer size: 4*Radius + end; + end; + + //horizontal blur + for y:=SrcArea.Top to SrcArea.Bottom-1 do begin + // set up init values for the first blur + difference:=clearIntegerColor; + derivative1:=clearIntegerColor; + derivative2:=clearIntegerColor; + sum:=clearIntegerColor; + for x:=SrcArea.Left-4*Radius to SrcArea.Right-1 do begin + if x >= SrcArea.Left then begin //{+1,-4,+6,-4,+1} + buffer.Get(x-2*Radius,Col1); + buffer.Get(x-Radius,Col2); + buffer.Get(x,Col3); + buffer.Get(x+Radius,Col4); + difference.alpha :=difference.alpha+Col1.alpha-4*(Col2.alpha+Col4.alpha)+6*Col3.alpha; + difference.red :=difference.red +Col1.red -4*(Col2.red +Col4.red) +6*Col3.red; + difference.green :=difference.green+Col1.green-4*(Col2.green+Col4.green)+6*Col3.green; + difference.blue :=difference.blue +Col1.blue -4*(Col2.blue +Col4.blue) +6*Col3.blue; + col:=DestImg.Colors[x,y]; + col.alpha:=min($FFFF,max(0,round(sum.alpha*Weight))); + col.red :=min($FFFF,max(0,round(sum.red *Weight))); + col.green:=min($FFFF,max(0,round(sum.green*Weight))); + col.blue :=min($FFFF,max(0,round(sum.blue *Weight))); + DestImg.Colors[x,y]:=col; // set blurred pixel + end else begin + if (x+3*Radius) >= SrcArea.Left then begin + // -4*buffer(x+Radius) + buffer.Get(x+Radius,Col4); + difference.alpha:=difference.alpha-4*Col4.alpha; + difference.red :=difference.red -4*Col4.red; + difference.green:=difference.green-4*Col4.green; + difference.blue :=difference.blue -4*Col4.blue; + end; + if (x+2*Radius) >= SrcArea.Left then begin + // +6*buffer(x) + buffer.Get(x,Col3); + difference.alpha:=difference.alpha+6*Col3.alpha; + difference.red :=difference.red +6*Col3.red; + difference.green:=difference.green+6*Col3.green; + difference.blue :=difference.blue +6*Col3.blue; + end; + if (x+ Radius) >= SrcArea.Left then begin + // -4*buffer(x-Radius) + buffer.Get(x-Radius,Col2); + difference.alpha:=difference.alpha-4*Col2.alpha; + difference.red :=difference.red -4*Col2.red; + difference.green:=difference.green-4*Col2.green; + difference.blue :=difference.blue -4*Col2.blue; + end; + end; + i:=Min(DestImg.Width-1,Max(0,x+2*Radius-1)); + // accumulate pixel blur + pixel := DestImg.Colors[i,y]; + difference.alpha := difference.alpha+pixel.alpha; + difference.red := difference.red +pixel.red; + difference.green := difference.green+pixel.green; + difference.blue := difference.blue +pixel.blue; + derivative2.alpha := derivative2.alpha+difference.alpha; + derivative2.red := derivative2.red +difference.red; + derivative2.green := derivative2.green+difference.green; + derivative2.blue := derivative2.blue +difference.blue; + derivative1.alpha := derivative1.alpha+derivative2.alpha; + derivative1.red := derivative1.red +derivative2.red; + derivative1.green := derivative1.green+derivative2.green; + derivative1.blue := derivative1.blue +derivative2.blue; + sum.alpha := sum.alpha+derivative1.alpha; + sum.red := sum.red +derivative1.red; + sum.green := sum.green+derivative1.green; + sum.blue := sum.blue +derivative1.blue; + + buffer.Put(x+2*Radius,pixel); // buffer pixel, min buffer size: 4*Radius + end; + end; + buffer.Clear; +end; + +procedure GaussianBlur(Img: TFPCustomImage; Radius: integer; Area: TRect); +var + Matrix: PWord; +begin + // check input + if (Radius<1) then exit; + Area.Left:=Max(0,Area.Left); + Area.Top:=Max(0,Area.Top); + Area.Right:=Min(Area.Right,Img.Width); + Area.Bottom:=Min(Area.Bottom,Img.Height); + if (Area.Left>=Area.Right) or (Area.Top>=Area.Bottom) then exit; + + // compute gaussian matrix + Matrix:=ComputeGaussianBlurMatrix1D(Radius); + try + MatrixBlur1D(Img,Radius,Area,Matrix); + finally + FreeMem(Matrix); + end; +end; + +procedure MatrixBlur1D(Img: TFPCustomImage; Radius: integer; Area: TRect; + Matrix1D: PWord); +{ Implementation: + It runs line by line from Area.Left to Area.Bottom-1. + It allocates some temporary memory to store the original pixel values + above the current line. +} +var + y: Integer; + x: Integer; + OrigWidth: Integer; + OrigHeight: LongInt; + OrigPixels: PFPColor; + VertSums: PFPColor; + NewRed, NewGreen, NewBlue, NewAlpha: cardinal; + yd: LongInt; + xd: LongInt; + xr: Integer; + yr: Integer; + Col: TFPColor; + NewCol: TFPColor; + Multiplier: Word; + StartX: Integer; + EndX: Integer; +begin + // check input + if (Radius<1) then exit; + Area.Left:=Max(0,Area.Left); + Area.Top:=Max(0,Area.Top); + Area.Right:=Min(Area.Right,Img.Width); + Area.Bottom:=Min(Area.Bottom,Img.Height); + if (Area.Left>=Area.Right) or (Area.Top>=Area.Bottom) then exit; + + //for x:=0 to MatrixWidth-1 do WriteLn('GaussianBlurNew ',x,' ',Matrix[x]); + OrigPixels:=nil; + VertSums:=nil; + try + // allocate space for original pixels + OrigWidth:=Area.Right-Area.Left; + OrigHeight:=Radius+1; + //writeln('GaussianBlur ',OrigWidth,'*',OrigHeight,'*',SizeOf(TFPColor)); + GetMem(OrigPixels,OrigWidth*OrigHeight*SizeOf(TFPColor)); + // get original pixels (the bottom line of OrigPixels will be Area.Top) + y:=Area.Top; + for yd:=-Radius to 0 do begin + yr:=Max(0,y+yd); + for x:=Area.Left to Area.Right-1 do begin + OrigPixels[x-Area.Left+(yd+Radius)*OrigWidth]:=Img.Colors[x,yr]; + end; + end; + + GetMem(VertSums,(OrigWidth+2*Radius)*SizeOf(TFPColor)); + + // compute new pixels + for y:=Area.Top to Area.Bottom-1 do begin + // move OrigPixels one line up + System.Move(OrigPixels[OrigWidth],OrigPixels[0], + OrigWidth*(OrigHeight-1)*SizeOf(TFPColor)); + // and copy current line to OrigPixels + for x:=Area.Left to Area.Right-1 do begin + OrigPixels[x-Area.Left+Radius*OrigWidth]:=Img.Colors[x,y]; + end; + + // compute vertical sums + // (for each x compute the sum of y-Radius..y+Radius colors + // multiplied with the gaussian matrix) + StartX:=Area.Left-Radius; + EndX:=Area.Right-1+Radius; + for x:=StartX to EndX do begin + // xr: x coordinate on img (coords out of bounds are mapped to the edges) + xr:=Min(Max(0,x),Img.Width-1); + // compute new color for this pixel + NewRed:=0; + NewGreen:=0; + NewBlue:=0; + NewAlpha:=0; + for yd:=-Radius to Radius do begin + // yr: y coordinate on img (coords out of bounds are mapped to the edges) + yr:=Min(Max(0,y+yd),Img.Height-1); + // get color + if (yd<=0) and (xr>=Area.Left) and (xr<Area.Right) then begin + // this pixel was replaced => use the OrigPixels + Col:=OrigPixels[xr-Area.Left+(yd+Radius)*OrigWidth]; + end else begin + Col:=Img.Colors[xr,yr]; + end; + // multiply with gaussian matrix + Multiplier:=Matrix1D[yd+Radius]; + inc(NewRed,Col.red*Multiplier); + inc(NewGreen,Col.green*Multiplier); + inc(NewBlue,Col.blue*Multiplier); + inc(NewAlpha,Col.alpha*Multiplier); + //writeln('GaussianBlur x=',x,' y=',y,' xd=',xd,' yd=',yd,' xr=',xr,' yr=',yr,' Col=',dbgs(Col),' NewCol=r=',hexstr(NewRed,8),'g=',hexstr(NewGreen,8),'b=',hexstr(NewBlue,8),'a=',hexstr(NewAlpha,8)); + end; + NewCol.red:=NewRed shr 16; + NewCol.green:=NewGreen shr 16; + NewCol.blue:=NewBlue shr 16; + NewCol.alpha:=NewAlpha shr 16; + VertSums[x-StartX]:=NewCol; + end; + + // compute horizontal sums + // (for each x compute the sum of x-Radius..x+Radius vertical sums + // multiplied with the gaussian matrix) + for x:=Area.Left to Area.Right-1 do begin + // compute new color for this pixel + NewRed:=0; + NewGreen:=0; + NewBlue:=0; + NewAlpha:=0; + for xd:=-Radius to Radius do begin + xr:=x+xd; + Col:=VertSums[xr-StartX]; + // multiply with gaussian matrix + Multiplier:=Matrix1D[xd+Radius]; + inc(NewRed,Col.red*Multiplier); + inc(NewGreen,Col.green*Multiplier); + inc(NewBlue,Col.blue*Multiplier); + inc(NewAlpha,Col.alpha*Multiplier); + //writeln('GaussianBlur x=',x,' y=',y,' xd=',xd,' yd=',yd,' xr=',xr,' yr=',yr,' Col=',dbgs(Col),' NewCol=r=',hexstr(NewRed,8),'g=',hexstr(NewGreen,8),'b=',hexstr(NewBlue,8),'a=',hexstr(NewAlpha,8)); + end; + NewCol.red:=NewRed shr 16; + NewCol.green:=NewGreen shr 16; + NewCol.blue:=NewBlue shr 16; + NewCol.alpha:=NewAlpha shr 16; + // set new pixel + //writeln('GaussianBlur x=',x,' y=',y,' OldCol=',dbgs(img.Colors[x,y]),' NewCol=',dbgs(NewCol)); + Img.Colors[x,y]:=NewCol; + end; + end; + finally + if OrigPixels<>nil then FreeMem(OrigPixels); + if VertSums<>nil then FreeMem(VertSums); + end; +end; + +procedure MatrixBlur2D(Img: TFPCustomImage; Radius: integer; Area: TRect; + Matrix2D: PWord); +{ Implementation: + It runs line by line from Area.Left to Area.Bottom-1. + It allocates some temporary memory to store the original pixel values + above the current line. +} +var + y: Integer; + x: Integer; + OrigWidth: Integer; + OrigHeight: LongInt; + OrigPixels: PFPColor; + NewRed, NewGreen, NewBlue, NewAlpha: cardinal; + yd: LongInt; + xd: LongInt; + xr: Integer; + yr: Integer; + Col: TFPColor; + NewCol: TFPColor; + Multiplier: Word; + MatrixWidth: Integer; +begin + // check input + if (Radius<1) then exit; + Area.Left:=Max(0,Area.Left); + Area.Top:=Max(0,Area.Top); + Area.Right:=Min(Area.Right,Img.Width); + Area.Bottom:=Min(Area.Bottom,Img.Height); + if (Area.Left>=Area.Right) or (Area.Top>=Area.Bottom) then exit; + + MatrixWidth:=Radius*2+1; + //WriteM('matrix ',Matrix2D,MatrixWidth); + OrigPixels:=nil; + try + // allocate space for original pixels + OrigWidth:=Area.Right-Area.Left; + OrigHeight:=Radius+1; + //DebugLn(['GaussianBlur ',OrigWidth,'*',OrigHeight,'*',SizeOf(TFPColor)]); + GetMem(OrigPixels,OrigWidth*OrigHeight*SizeOf(TFPColor)); + // get original pixels (the bottom line of OrigPixels will be Area.Top) + y:=Area.Top; + for yd:=-Radius to 0 do begin + yr:=Max(0,y+yd); + for x:=Area.Left to Area.Right-1 do begin + OrigPixels[x-Area.Left+(yd+Radius)*OrigWidth]:=Img.Colors[x,yr]; + end; + end; + + // compute new pixels + for y:=Area.Top to Area.Bottom-1 do begin + // move OrigPixels one line up + System.Move(OrigPixels[OrigWidth],OrigPixels[0], + OrigWidth*(OrigHeight-1)*SizeOf(TFPColor)); + // and copy current line to OrigPixels + for x:=Area.Left to Area.Right-1 do begin + OrigPixels[x-Area.Left+Radius*OrigWidth]:=Img.Colors[x,y]; + end; + // compute line + for x:=Area.Left to Area.Right-1 do begin + // compute new color for this pixel + NewRed:=0; + NewGreen:=0; + NewBlue:=0; + NewAlpha:=0; + for yd:=-Radius to Radius do begin + // yr: y coordinate on img (coords out of bounds are mapped to the edges) + yr:=Min(Max(0,y+yd),Img.Height-1); + for xd:=-Radius to Radius do begin + // xr: x coordinate on img (coords out of bounds are mapped to the edges) + xr:=Min(Max(0,x+xd),Img.Width-1); + // get color + if (yd<=0) and (xr>=Area.Left) and (xr<Area.Right) then begin + // this pixel was replaced => use the OrigPixels + Col:=OrigPixels[xr-Area.Left+(yd+Radius)*OrigWidth]; + end else begin + Col:=Img.Colors[xr,yr]; + end; + // multiply with gauss Matrix2D + Multiplier:=Matrix2D[xd+Radius+(yd+Radius)*MatrixWidth]; + inc(NewRed,Col.red*Multiplier); + inc(NewGreen,Col.green*Multiplier); + inc(NewBlue,Col.blue*Multiplier); + inc(NewAlpha,Col.alpha*Multiplier); + //DebugLn(['GaussianBlur x=',x,' y=',y,' xd=',xd,' yd=',yd,' xr=',xr,' yr=',yr,' Col=',dbgs(Col),' NewCol=r=',hexstr(NewRed,8),'g=',hexstr(NewGreen,8),'b=',hexstr(NewBlue,8),'a=',hexstr(NewAlpha,8)]); + end; + end; + NewCol.red:=NewRed shr 16; + NewCol.green:=NewGreen shr 16; + NewCol.blue:=NewBlue shr 16; + NewCol.alpha:=NewAlpha shr 16; + // set new pixel + //DebugLn(['GaussianBlur x=',x,' y=',y,' OldCol=',dbgs(img.Colors[x,y]),' NewCol=',dbgs(NewCol)]); + Img.Colors[x,y]:=NewCol; + end; + end; + finally + if OrigPixels<>nil then FreeMem(OrigPixels); + end; +end; + +function ComputeGaussianBlurMatrix1D(Radius: integer): PWord; +// returns a 1dim matrix of Words for the gaussian blur. +// Each word is a factor [0,1) multiplied by 65536. +// The total sum of the matrix is 65536. +const + StandardDeviationToRadius = 3; // Pixels more far away as 3*Deviation are too small +var + Width: Integer; + Size: Integer; + Matrix: PWord; + Deviation: Single; + m,p: Single; + x: Integer; + Value: Integer; + MatrixSum: Integer; + g: Single; +begin + Width:=Radius*2+1; + Size:=SizeOf(Word)*Width*Width; + Matrix:=nil; + GetMem(Matrix,Size); + Result:=Matrix; + FillByte(Matrix^,Size,0); + // Deviation := Radius / 3 + // G(x) := (1 / SQRT( 2 * pi * Deviation^2)) * e^( - (x^2) / (2 * Deviation^2) ) + // m * e^( x^2 * p ) + // m := 1 / SQRT( 2 * pi * Deviation^2) + // p := -1 / (2 * Deviation^2) + Deviation:=single(Radius)/StandardDeviationToRadius; + m:=1/Sqrt(2*pi*Deviation*Deviation); + p:=-1/(2*Deviation*Deviation); + for x:=0 to Radius do begin + g:=m*exp(single(x*x)*p); + Value:=floor(g*65536); + Matrix[Radius+x]:=Value; + Matrix[Radius-x]:=Value; + end; + // fix sum to 65536 + MatrixSum:=0; + for x:=0 to Width-1 do + inc(MatrixSum,Matrix[x]); + Matrix[Radius]:=Min(High(Word),65536-MatrixSum+Matrix[Radius]); +end; + +function ComputeGaussianBlurMatrix2D(Radius: integer): PWord; +// returns a 2dim matrix of Words for the gaussian blur. +// Each word is a factor [0,1) multiplied by 65536. +// The total sum of the matrix is 65536. +const + StandardDeviationToRadius = 3; // Pixels more far away as 3*Deviation are too small +var + Matrix: PWord; + Size: Integer; + Deviation: single; + m,p: single; + g: single; + y: Integer; + x: Integer; + yd: Integer; + xd: Integer; + MatrixSum: Integer; + Value: Word; + Width: Integer; +begin + Width:=Radius*2+1; + Size:=SizeOf(Word)*Width*Width; + Matrix:=nil; + GetMem(Matrix,Size); + Result:=Matrix; + FillByte(Matrix^,Size,0); + // Deviation = Radius / StandardDeviationToRadius + // G(x,y) := (1 / (2 * pi * Deviation^2)) * e^( - (x^2 + y^2) / (2 * Deviation^2) ) + // = m * e^( (x^2 + y^2) * p ) + // m := 1 / (2 * pi * Deviation^2) + // p := -1 / (2 * Deviation^2) + Deviation:=single(Radius)/StandardDeviationToRadius; + m:=1/(2*pi*Deviation*Deviation); + p:=-1/(2*Deviation*Deviation); + for y:=0 to Radius do begin + yd:=Radius-y; + yd:=yd*yd; + for x:=y to Radius do begin + xd:=Radius-x; + xd:=xd*xd; + g:=m*exp((single(xd)+single(yd))*p); + Value:=floor(g*65536); + Matrix[x+y*Width]:=Value; + // mirror diagonally + Matrix[y+x*Width]:=Value; + end; + // mirror horizontally + for x:=Radius+1 to Width-1 do + Matrix[x+y*Width]:=Matrix[(Width-x-1)+y*Width]; + // mirror vertically + System.Move(Matrix[y*Width],Matrix[(Width-y-1)*Width],SizeOf(Word)*Width); + end; + // fix sum to 65536 + MatrixSum:=0; + for y:=0 to Width-1 do + for x:=0 to Width-1 do + inc(MatrixSum,Matrix[x+y*Width]); + Matrix[Radius+Radius*Width]:=Min(High(Word),65536-MatrixSum+Matrix[Radius+Radius*Width]); +end; + +end. + diff --git a/mips/packages/fcl-image/src/fpinterpolation.inc b/mips/packages/fcl-image/src/fpinterpolation.inc index 5fbef42ab8..7d2e594f38 100644 --- a/mips/packages/fcl-image/src/fpinterpolation.inc +++ b/mips/packages/fcl-image/src/fpinterpolation.inc @@ -179,7 +179,7 @@ begin begin sx:=PInteger(xEntry)^; inc(xEntry,SizeOf(integer)); - NewCol:=colBlack; + NewCol:= colTransparent; for cx:=0 to xSupport-1 do begin f:=PSingle(xEntry)^; @@ -198,7 +198,7 @@ begin for dx:=0 to w-1 do begin CurEntry:=yEntry+SizeOf(integer); - NewCol:=colBlack; + NewCol:=colTransparent; for sy:=0 to ySupport-1 do begin f:=PSingle(CurEntry)^; diff --git a/mips/packages/fcl-image/src/fpwritepng.pp b/mips/packages/fcl-image/src/fpwritepng.pp index 022e5a6dc9..32c23daeed 100644 --- a/mips/packages/fcl-image/src/fpwritepng.pp +++ b/mips/packages/fcl-image/src/fpwritepng.pp @@ -449,6 +449,7 @@ begin // signature for PNG TheStream.writeBuffer(Signature,sizeof(Signature)); // Determine all settings for filling the header + fillchar(fheader,sizeof(fheader),#0); DetermineHeader (FHeader); // write the header chunk SetChunkLength (13); // (sizeof(FHeader)); gives 14 and is wrong !! diff --git a/mips/packages/fcl-json/src/fpjson.pp b/mips/packages/fcl-json/src/fpjson.pp index a1a771c1d0..99022cea54 100644 --- a/mips/packages/fcl-json/src/fpjson.pp +++ b/mips/packages/fcl-json/src/fpjson.pp @@ -396,6 +396,7 @@ Type Function IndexOfName(const AName: TJSONStringType; CaseInsensitive : Boolean = False): Integer; Function Find(Const AName : String) : TJSONData; overload; Function Find(Const AName : String; AType : TJSONType) : TJSONData; overload; + Function Get(Const AName : String) : Variant; Function Get(Const AName : String; ADefault : TJSONFloat) : TJSONFloat; Function Get(Const AName : String; ADefault : Integer) : Integer; Function Get(Const AName : String; ADefault : Int64) : Int64; @@ -2059,6 +2060,18 @@ begin Result:=Nil end; +function TJSONObject.Get(const AName: String): Variant; +Var + I : Integer; + +begin + I:=IndexOfName(AName); + If (I<>-1) then + Result:=Items[i].Value + else + Result:=Null; +end; + function TJSONObject.Get(const AName: String; ADefault: TJSONFloat ): TJSONFloat; @@ -2158,7 +2171,7 @@ Var begin I:=IndexOfName(AName); - If (I=-1) then + If (I<>-1) then Result:=Items[i] else Result:=Nil; diff --git a/mips/packages/fcl-json/src/fpjsonrtti.pp b/mips/packages/fcl-json/src/fpjsonrtti.pp index 15f0c46b8c..239183b16d 100644 --- a/mips/packages/fcl-json/src/fpjsonrtti.pp +++ b/mips/packages/fcl-json/src/fpjsonrtti.pp @@ -20,8 +20,9 @@ Type jsoComponentsInline, // Always stream components inline. Default is to stream name, unless csSubcomponent in ComponentStyle jsoTStringsAsArray, // Stream TStrings as an array of strings. Associated objects are not streamed. jsoTStringsAsObject, // Stream TStrings as an object : string = { object } - jsoDateTimeAsString, - jsoUseFormatString); // Use FormatString when creating JSON strings. + jsoDateTimeAsString, // Format a TDateTime value as a string + jsoUseFormatString, // Use FormatString when creating JSON strings. + jsoCheckEmptyDateTime); // If TDateTime value is empty and jsoDateTimeAsString is used, 0 date returns empty string TJSONStreamOptions = Set of TJSONStreamOption; TJSONFiler = Class(TComponent) @@ -999,7 +1000,9 @@ Var S: String; begin - if (DateTimeFormat<>'') then + if (jsoCheckEmptyDateTime in Options) and (DateTime=0) then + S:='' + else if (DateTimeFormat<>'') then S:=FormatDateTime(DateTimeFormat,DateTime) else if Frac(DateTime)=0 then S:=DateToStr(DateTime) diff --git a/mips/packages/fcl-json/src/jsonparser.pp b/mips/packages/fcl-json/src/jsonparser.pp index 22726a79ad..2f03a92f0c 100644 --- a/mips/packages/fcl-json/src/jsonparser.pp +++ b/mips/packages/fcl-json/src/jsonparser.pp @@ -28,9 +28,12 @@ Type TJSONParser = Class(TObject) Private FScanner : TJSONScanner; + FuseUTF8, FStrict: Boolean; function ParseNumber: TJSONNumber; procedure SetStrict(const AValue: Boolean); + function GetUTF8 : Boolean; + procedure SetUTF8(const AValue: Boolean); Protected procedure DoError(const Msg: String); function DoParse(AtCurrent,AllowEOF: Boolean): TJSONData; @@ -42,11 +45,13 @@ Type Property Scanner : TJSONScanner read FScanner; Public function Parse: TJSONData; - Constructor Create(Source : TStream); overload; - Constructor Create(Source : TJSONStringType); overload; + Constructor Create(Source : TStream; AUseUTF8 : Boolean = True); overload; + Constructor Create(Source : TJSONStringType; AUseUTF8 : Boolean = True); overload; destructor Destroy();override; // Use strict JSON: " for strings, object members are strings, not identifiers Property Strict : Boolean Read FStrict Write SetStrict; + // if set to TRUE, then strings will be converted to UTF8 ansistrings, not system codepage ansistrings. + Property UseUTF8 : Boolean Read GetUTF8 Write SetUTF8; end; EJSONParser = Class(EParserError); @@ -152,6 +157,23 @@ begin end; end; +function TJSONParser.GetUTF8 : Boolean; + +begin + if Assigned(FScanner) then + Result:=FScanner.UseUTF8 + else + Result:=FUseUTF8; +end; + +procedure TJSONParser.SetUTF8(const AValue: Boolean); + +begin + FUseUTF8:=AValue; + if Assigned(FScanner) then + FScanner.UseUTF8:=FUseUTF8; +end; + procedure TJSONParser.SetStrict(const AValue: Boolean); begin if (FStrict=AValue) then @@ -250,16 +272,18 @@ begin Raise EJSONParser.Create(S); end; -constructor TJSONParser.Create(Source: TStream); +constructor TJSONParser.Create(Source: TStream; AUseUTF8 : Boolean = True); begin Inherited Create; FScanner:=TJSONScanner.Create(Source); + UseUTF8:=AUseUTF8; end; -constructor TJSONParser.Create(Source: TJSONStringType); +constructor TJSONParser.Create(Source: TJSONStringType; AUseUTF8 : Boolean = True); begin Inherited Create; FScanner:=TJSONScanner.Create(Source); + UseUTF8:=AUseUTF8; end; destructor TJSONParser.Destroy(); diff --git a/mips/packages/fcl-json/src/jsonscanner.pp b/mips/packages/fcl-json/src/jsonscanner.pp index 290307f576..e02a5d7437 100644 --- a/mips/packages/fcl-json/src/jsonscanner.pp +++ b/mips/packages/fcl-json/src/jsonscanner.pp @@ -59,6 +59,7 @@ type FCurTokenString: string; FCurLine: string; FStrict: Boolean; + FUseUTF8 : Boolean; TokenStr: PChar; function GetCurColumn: Integer; protected @@ -66,8 +67,8 @@ type procedure Error(const Msg: string; Args: array of Const);overload; function DoFetchToken: TJSONToken; public - constructor Create(Source : TStream); overload; - constructor Create(const Source : String); overload; + constructor Create(Source : TStream; AUseUTF8 : Boolean = True); overload; + constructor Create(const Source : String; AUseUTF8 : Boolean = True); overload; destructor Destroy; override; function FetchToken: TJSONToken; @@ -80,6 +81,8 @@ type property CurTokenString: string read FCurTokenString; // Use strict JSON: " for strings, object members are strings, not identifiers Property Strict : Boolean Read FStrict Write FStrict; + // if set to TRUE, then strings will be converted to UTF8 ansistrings, not system codepage ansistrings. + Property UseUTF8 : Boolean Read FUseUTF8 Write FUseUTF8; end; const @@ -104,17 +107,19 @@ const implementation -constructor TJSONScanner.Create(Source : TStream); +constructor TJSONScanner.Create(Source : TStream; AUseUTF8 : Boolean = True); begin FSource:=TStringList.Create; FSource.LoadFromStream(Source); + FUseUTF8:=AUseUTF8; end; -constructor TJSONScanner.Create(const Source : String); +constructor TJSONScanner.Create(const Source : String; AUseUTF8 : Boolean = True); begin FSource:=TStringList.Create; FSource.Text:=Source; + FUseUTF8:=AUseUTF8; end; destructor TJSONScanner.Destroy; @@ -235,8 +240,11 @@ begin Error(SErrInvalidCharacter, [CurRow,CurColumn,TokenStr[0]]); end; end; - // Takes care of conversion... - S:=WideChar(StrToInt('$'+S)); + // WideChar takes care of conversion... + if UseUTF8 then + S:=Utf8Encode(WideString(WideChar(StrToInt('$'+S)))) + else + S:=WideChar(StrToInt('$'+S)); end; #0 : Error(SErrOpenString); else diff --git a/mips/packages/fcl-passrc/src/pastree.pp b/mips/packages/fcl-passrc/src/pastree.pp index aacca82f94..71c2b7f2da 100644 --- a/mips/packages/fcl-passrc/src/pastree.pp +++ b/mips/packages/fcl-passrc/src/pastree.pp @@ -103,6 +103,7 @@ type FName: string; FParent: TPasElement; FHints : TPasMemberHints; + FHintMessage : String; protected procedure ProcessHints(const ASemiColonPrefix: boolean; var AResult: string); virtual; public @@ -125,6 +126,7 @@ type property Parent: TPasElement read FParent; Property Hints : TPasMemberHints Read FHints Write FHints; Property CustomData : TObject Read FData Write FData; + Property HintMessage : String Read FHintMessage Write FHintMessage; end; TPasExprKind = (pekIdent, pekNumber, pekString, pekSet, pekNil, pekBoolConst, pekRange, @@ -494,7 +496,7 @@ type - TArgumentAccess = (argDefault, argConst, argVar, argOut); + TArgumentAccess = (argDefault, argConst, argVar, argOut, argConstRef); { TPasArgument } @@ -506,7 +508,8 @@ type public Access: TArgumentAccess; ArgType: TPasType; - Value: string; + ValueExpr: TPasExpr; + Function Value : String; end; { TPasProcedureType } @@ -522,6 +525,7 @@ type function CreateArgument(const AName, AUnresolvedTypeName: string):TPasArgument; public IsOfObject: Boolean; + IsNested : Boolean; Args: TFPList; // List of TPasArgument objects CallingConvention : TCallingConvention; end; @@ -1029,7 +1033,7 @@ type end; const - AccessNames: array[TArgumentAccess] of string[6] = ('', 'const ', 'var ', 'out '); + AccessNames: array[TArgumentAccess] of string[9] = ('', 'const ', 'var ', 'out ','constref '); AllVisibilities: TPasMemberVisibilities = [visDefault, visPrivate, visProtected, visPublic, visPublished, visAutomated]; @@ -1452,6 +1456,7 @@ destructor TPasArgument.Destroy; begin if Assigned(ArgType) then ArgType.Release; + FreeAndNil(ValueExpr); inherited Destroy; end; @@ -2128,7 +2133,9 @@ begin S.Add(TypeName); GetArguments(S); If IsOfObject then - S.Add(' of object'); + S.Add(' of object') + else if IsNested then + S.Add(' is nested'); If Full then Result:=IndentStrings(S,Length(S[0])+Length(S[1])+1) else @@ -2446,6 +2453,14 @@ begin Result:=''; end; +function TPasArgument.Value: String; +begin + If Assigned(ValueExpr) then + Result:=ValueExpr.GetDeclaration(true) + else + Result:=''; +end; + { TPassTreeVisitor } diff --git a/mips/packages/fcl-passrc/src/pparser.pp b/mips/packages/fcl-passrc/src/pparser.pp index 42013d456f..d4b3649aef 100644 --- a/mips/packages/fcl-passrc/src/pparser.pp +++ b/mips/packages/fcl-passrc/src/pparser.pp @@ -36,11 +36,13 @@ resourcestring SParserExpectedCommaRBracket = 'Expected "," or ")"'; SParserExpectedCommaSemicolon = 'Expected "," or ";"'; SParserExpectedCommaColon = 'Expected "," or ":"'; + SParserOnlyOneArgumentCanHaveDefault = 'A default value can only be assigned to 1 parameter'; SParserExpectedLBracketColon = 'Expected "(" or ":"'; SParserExpectedLBracketSemicolon = 'Expected "(" or ";"'; SParserExpectedColonSemicolon = 'Expected ":" or ";"'; SParserExpectedSemiColonEnd = 'Expected ";" or "End"'; SParserExpectedConstVarID = 'Expected "const", "var" or identifier'; + SParserExpectedNested = 'Expected nested keyword'; SParserExpectedColonID = 'Expected ":" or identifier'; SParserSyntaxError = 'Syntax error'; SParserTypeSyntaxError = 'Syntax error in type'; @@ -54,6 +56,7 @@ resourcestring SLogStartImplementation = 'Start parsing implementation section.'; SLogStartInterface = 'Start parsing interface section'; + SParsingUsedUnit = 'Parsing used unit "%s" with commandLine "%s"'; type TPasParserLogHandler = Procedure (Sender : TObject; Const Msg : String) of object; @@ -656,7 +659,17 @@ begin NextToken; Found:=IsCurTokenHint(h); If Found then - Include(Result,h) + begin + Include(Result,h); + if (h=hDeprecated) then + begin + NextToken; + if (Curtoken<>tkString) then + UnGetToken + else + Element.HintMessage:=CurTokenString; + end; + end; Until Not Found; UnGetToken; If Assigned(Element) then @@ -2323,79 +2336,101 @@ procedure TPasParser.ParseArgList(Parent: TPasElement; Args: TFPList; EndToken: var ArgNames: TStringList; IsUntyped: Boolean; - Name, Value: String; + Name : String; + Value : TPasExpr; i: Integer; Arg: TPasArgument; Access: TArgumentAccess; ArgType: TPasType; begin - while True do - begin - ArgNames := TStringList.Create; - Access := argDefault; - IsUntyped := False; - ArgType := nil; + ArgNames := TStringList.Create; + try while True do begin - NextToken; - if CurToken = tkConst then - begin - Access := argConst; - Name := ExpectIdentifier; - end else if CurToken = tkVar then - begin - Access := ArgVar; - Name := ExpectIdentifier; - end else if (CurToken = tkIdentifier) and (UpperCase(CurTokenString) = 'OUT') then + ArgNames.Clear; + Access := argDefault; + IsUntyped := False; + ArgType := nil; + while True do begin - Access := ArgOut; - Name := ExpectIdentifier; - end else if CurToken = tkIdentifier then - Name := CurTokenString - else - ParseExc(SParserExpectedConstVarID); - ArgNames.Add(Name); - NextToken; - if CurToken = tkColon then - break - else if ((CurToken = tkSemicolon) or (CurToken = tkBraceClose)) and - (Access <> argDefault) then - begin - // found an untyped const or var argument - UngetToken; - IsUntyped := True; - break - end - else if CurToken <> tkComma then - ParseExc(SParserExpectedCommaColon); - end; - SetLength(Value, 0); - if not IsUntyped then - begin - ArgType := ParseType(nil); - NextToken; - if CurToken = tkEqual then + NextToken; + if CurToken = tkConst then + begin + Access := argConst; + Name := ExpectIdentifier; + end else if CurToken = tkConstRef then + begin + Access := argConstref; + Name := ExpectIdentifier; + end else if CurToken = tkVar then + begin + Access := ArgVar; + Name := ExpectIdentifier; + end else if (CurToken = tkIdentifier) and (UpperCase(CurTokenString) = 'OUT') then + begin + Access := ArgOut; + Name := ExpectIdentifier; + end else if CurToken = tkIdentifier then + Name := CurTokenString + else + ParseExc(SParserExpectedConstVarID); + ArgNames.Add(Name); + NextToken; + if CurToken = tkColon then + break + else if ((CurToken = tkSemicolon) or (CurToken = tkBraceClose)) and + (Access <> argDefault) then + begin + // found an untyped const or var argument + UngetToken; + IsUntyped := True; + break + end + else if CurToken <> tkComma then + ParseExc(SParserExpectedCommaColon); + end; + Value:=Nil; + if not IsUntyped then + begin + ArgType := ParseType(nil); + try + NextToken; + if CurToken = tkEqual then + begin + if (ArgNames.Count>1) then + begin + FreeAndNil(ArgType); + ParseExc(SParserOnlyOneArgumentCanHaveDefault); + end; + NextToken; + Value := DoParseExpression(Parent,Nil); + // After this, we're on ), which must be unget. + end; + UngetToken; + except + FreeAndNil(ArgType); + Raise; + end; + end; + + for i := 0 to ArgNames.Count - 1 do begin - Value := ParseExpression(Parent); - end else - UngetToken; - end; + Arg := TPasArgument(CreateElement(TPasArgument, ArgNames[i], Parent)); + Arg.Access := Access; + Arg.ArgType := ArgType; + if (i > 0) and Assigned(ArgType) then + ArgType.AddRef; + Arg.ValueExpr := Value; + Value:=Nil; // Only the first gets a value. OK, since Var A,B : Integer = 1 is not allowed. + Args.Add(Arg); + end; - for i := 0 to ArgNames.Count - 1 do - begin - Arg := TPasArgument(CreateElement(TPasArgument, ArgNames[i], Parent)); - Arg.Access := Access; - Arg.ArgType := ArgType; - if (i > 0) and Assigned(ArgType) then - ArgType.AddRef; - Arg.Value := Value; - Args.Add(Arg); + NextToken; + if CurToken = EndToken then + break; end; - + finally ArgNames.Free; - NextToken; - if CurToken = EndToken then - break; end; end; @@ -2458,7 +2493,7 @@ begin begin NextToken; if (CurToken = tkSemicolon) or IsCurtokenHint - or (OfObjectPossible and (CurToken in [tkOf,tkEqual])) + or (OfObjectPossible and (CurToken in [tkOf,tkis,tkEqual])) then UngetToken else @@ -2483,15 +2518,25 @@ begin ParseType(nil); end; end; - - NextToken; - if OfObjectPossible and (CurToken = tkOf) then - begin - ExpectToken(tkObject); - Element.IsOfObject := True; - end else - UngetToken; - + + if OfObjectPossible then + begin + NextToken; + if (curToken =tkOf) then + begin + ExpectToken(tkObject); + Element.IsOfObject := True; + end + else if (curToken = tkIs) then + begin + expectToken(tkIdentifier); + if (lowerCase(CurTokenString)<>'nested') then + ParseExc(SParserExpectedNested); + Element.isNested:=True; + end + else + UnGetToken; + end; NextToken; if CurToken = tkEqual then begin @@ -2567,6 +2612,14 @@ begin if IsCurTokenHint(ahint) then // deprecated,platform,experimental,library, unimplemented etc begin element.hints:=element.hints+[ahint]; + if aHint=hDeprecated then + begin + nextToken; + if (CurToken<>tkString) then + UnGetToken + else + element.HintMessage:=curtokenstring; + end; consumesemi; end else if (tok = 'PUBLIC') then diff --git a/mips/packages/fcl-passrc/src/pscanner.pp b/mips/packages/fcl-passrc/src/pscanner.pp index 454d93e7ca..044105dcd0 100644 --- a/mips/packages/fcl-passrc/src/pscanner.pp +++ b/mips/packages/fcl-passrc/src/pscanner.pp @@ -87,6 +87,7 @@ type tkcase, tkclass, tkconst, + tkconstref, tkconstructor, tkdestructor, tkdiv, @@ -412,6 +413,7 @@ const 'case', 'class', 'const', + 'constref', 'constructor', 'destructor', 'div', diff --git a/mips/packages/fcl-process/src/dummy/pipes.inc b/mips/packages/fcl-process/src/dummy/pipes.inc index d2fe3eeb0d..0ba622be88 100644 --- a/mips/packages/fcl-process/src/dummy/pipes.inc +++ b/mips/packages/fcl-process/src/dummy/pipes.inc @@ -15,7 +15,7 @@ // No pipes under dos, sorry... -Function CreatePipeHandles (Var Inhandle,OutHandle : THandle) : Boolean; +Function CreatePipeHandles (Var Inhandle,OutHandle : THandle; APipeBufferSize : Cardinal = 1024) : Boolean; begin InHandle := THandle (UnusedHandle); diff --git a/mips/packages/fcl-process/src/os2/pipes.inc b/mips/packages/fcl-process/src/os2/pipes.inc index ec92e1aa6a..352cf4c793 100644 --- a/mips/packages/fcl-process/src/os2/pipes.inc +++ b/mips/packages/fcl-process/src/os2/pipes.inc @@ -19,10 +19,10 @@ uses const PipeBufSize = 1024; -Function CreatePipeHandles (Var Inhandle,OutHandle : Longint) : Boolean; +Function CreatePipeHandles (Var Inhandle,OutHandle : Longint; APipeBufferSize : Cardinal = 1024) : Boolean; begin - CreatePipeHandles := DosCreatePipe (InHandle, OutHandle, PipeBufSize) = 0; + CreatePipeHandles := DosCreatePipe (InHandle, OutHandle, APipeBufferSize) = 0; end; Function TInputPipeStream.GetNumBytesAvailable: DWord; diff --git a/mips/packages/fcl-process/src/pipes.pp b/mips/packages/fcl-process/src/pipes.pp index a52123e696..555961d34b 100644 --- a/mips/packages/fcl-process/src/pipes.pp +++ b/mips/packages/fcl-process/src/pipes.pp @@ -50,7 +50,7 @@ Type Function Read (Var Buffer; Count : Longint) : longint; Override; end; -Function CreatePipeHandles (Var Inhandle,OutHandle : THandle) : Boolean; +Function CreatePipeHandles (Var Inhandle,OutHandle : THandle; APipeBufferSize : Cardinal = 1024) : Boolean; Procedure CreatePipeStreams (Var InPipe : TInputPipeStream; Var OutPipe : TOutputPipeStream); diff --git a/mips/packages/fcl-process/src/process.pp b/mips/packages/fcl-process/src/process.pp index 5ec6b1d4cf..bc30c05171 100644 --- a/mips/packages/fcl-process/src/process.pp +++ b/mips/packages/fcl-process/src/process.pp @@ -78,6 +78,7 @@ Type dwYcountChars, dwy : Cardinal; FXTermProgram: String; + FPipeBufferSize : cardinal; Procedure FreeStreams; Function GetExitStatus : Integer; Function GetRunning : Boolean; @@ -134,6 +135,7 @@ Type property OnForkEvent : TProcessForkEvent Read FForkEvent Write FForkEvent; {$endif UNIX} Published + property PipeBufferSize : cardinal read FPipeBufferSize write FPipeBufferSize default 1024; Property Active : Boolean Read GetRunning Write SetActive; Property ApplicationName : String Read FApplicationName Write SetApplicationName; deprecated; Property CommandLine : String Read FCommandLine Write SetCommandLine ; deprecated; @@ -247,6 +249,7 @@ begin {$ifdef UNIX} FForkEvent:=nil; {$endif UNIX} + FPipeBufferSize := 1024; FEnvironment:=TStringList.Create; FParameters:=TStringList.Create; end; @@ -465,8 +468,8 @@ begin try try p.Options := [poUsePipes]; - p.Execute; bytesread:=0; + p.Execute; while p.Running do begin Setlength(outputstring,BytesRead + READ_BYTES); diff --git a/mips/packages/fcl-process/src/unix/pipes.inc b/mips/packages/fcl-process/src/unix/pipes.inc index 8d2e691aa1..269ab12dbc 100644 --- a/mips/packages/fcl-process/src/unix/pipes.inc +++ b/mips/packages/fcl-process/src/unix/pipes.inc @@ -16,7 +16,7 @@ Uses BaseUnix, Unix, TermIO; -Function CreatePipeHandles (Var Inhandle,OutHandle : Longint) : Boolean; +Function CreatePipeHandles (Var Inhandle,OutHandle : Longint; APipeBufferSize : Cardinal = 1024) : Boolean; begin Result := (AssignPipe (Inhandle,OutHandle)<>-1); diff --git a/mips/packages/fcl-process/src/unix/process.inc b/mips/packages/fcl-process/src/unix/process.inc index 2d57d0053b..1339b6460c 100644 --- a/mips/packages/fcl-process/src/unix/process.inc +++ b/mips/packages/fcl-process/src/unix/process.inc @@ -52,7 +52,7 @@ begin // else pass errorvalue unmodified like shell does, bug #22055 end else - FexitCode:=-1; // was 0, better testable for abnormal exit. + FexitCode:=cardinal(-1); // was 0, better testable for abnormal exit. end; Type diff --git a/mips/packages/fcl-process/src/win/pipes.inc b/mips/packages/fcl-process/src/win/pipes.inc index 76f4154a98..899ec5a527 100644 --- a/mips/packages/fcl-process/src/win/pipes.inc +++ b/mips/packages/fcl-process/src/win/pipes.inc @@ -28,10 +28,10 @@ Const piInheritablePipe : TSecurityAttributes = ( PipeBufSize = 1024; -Function CreatePipeHandles (Var Inhandle,OutHandle : THandle) : Boolean; +Function CreatePipeHandles (Var Inhandle,OutHandle : THandle; APipeBufferSize : Cardinal = PipeBufSize) : Boolean; begin - Result := CreatePipe (@Inhandle,@OutHandle,@piNonInheritablePipe,PipeBufSize); + Result := CreatePipe (@Inhandle,@OutHandle,@piNonInheritablePipe,APipeBufferSize); end; diff --git a/mips/packages/fcl-process/src/win/process.inc b/mips/packages/fcl-process/src/win/process.inc index b0c532e10a..58b8eafda7 100644 --- a/mips/packages/fcl-process/src/win/process.inc +++ b/mips/packages/fcl-process/src/win/process.inc @@ -179,15 +179,15 @@ begin end; -Procedure CreatePipes(Var HI,HO,HE : Thandle; Var SI : TStartupInfo; CE : Boolean); +Procedure CreatePipes(Var HI,HO,HE : Thandle; Var SI : TStartupInfo; CE : Boolean; APipeBufferSize : Cardinal); begin - CreatePipeHandles(SI.hStdInput,HI); + CreatePipeHandles(SI.hStdInput,HI, APipeBufferSize); DuplicateHandleFP(SI.hStdInput); - CreatePipeHandles(HO,Si.hStdOutput); + CreatePipeHandles(HO,Si.hStdOutput, APipeBufferSize); DuplicateHandleFP( Si.hStdOutput); if CE then begin - CreatePipeHandles(HE,SI.hStdError); + CreatePipeHandles(HE,SI.hStdError, APipeBufferSize); DuplicateHandleFP( SI.hStdError); end else @@ -262,7 +262,7 @@ begin InitThreadAttributes(Self,FThreadAttributes); InitStartupInfo(Self,FStartUpInfo); If poUsePipes in FProcessOptions then - CreatePipes(HI,HO,HE,FStartupInfo,Not(poStdErrToOutPut in FProcessOptions)); + CreatePipes(HI,HO,HE,FStartupInfo,Not(poStdErrToOutPut in FProcessOptions), FPipeBufferSize); Try If Not CreateProcess (PName,PCommandLine,@FProcessAttributes,@FThreadAttributes, FInheritHandles,FCreationFlags,FEnv,PDir,FStartupInfo, diff --git a/mips/packages/fcl-process/src/wince/process.inc b/mips/packages/fcl-process/src/wince/process.inc index ed641c0b1f..116c78972e 100644 --- a/mips/packages/fcl-process/src/wince/process.inc +++ b/mips/packages/fcl-process/src/wince/process.inc @@ -152,13 +152,13 @@ begin end; end; -Procedure CreatePipes(Var HI,HO,HE : Thandle; Var SI : TStartupInfo; CE : Boolean); +Procedure CreatePipes(Var HI,HO,HE : Thandle; Var SI : TStartupInfo; CE : Boolean; APipeBufferSize : Cardinal); begin - CreatePipeHandles(SI.hStdInput,HI); - CreatePipeHandles(HO,Si.hStdOutput); + CreatePipeHandles(SI.hStdInput,HI,APipeBufferSize); + CreatePipeHandles(HO,Si.hStdOutput,APipeBufferSize); if CE then - CreatePipeHandles(HE,SI.hStdError) + CreatePipeHandles(HE,SI.hStdError,APipeBufferSize) else begin SI.hStdError:=SI.hStdOutput; @@ -213,7 +213,7 @@ begin InitThreadAttributes(Self,FThreadAttributes); InitStartupInfo(Self,FStartUpInfo); If poUsePipes in FProcessOptions then - CreatePipes(HI,HO,HE,FStartupInfo,Not(poStdErrToOutPut in FProcessOptions)); + CreatePipes(HI,HO,HE,FStartupInfo,Not(poStdErrToOutPut in FProcessOptions),FPipeBufferSize); Try If Not CreateProcess (PName,PCommandLine,@FProcessAttributes,@FThreadAttributes, FInheritHandles,FCreationFlags,FEnv,PDir,@FStartupInfo, diff --git a/mips/packages/fcl-web/src/base/httpdefs.pp b/mips/packages/fcl-web/src/base/httpdefs.pp index 782952bfe4..0d91f3a586 100644 --- a/mips/packages/fcl-web/src/base/httpdefs.pp +++ b/mips/packages/fcl-web/src/base/httpdefs.pp @@ -62,11 +62,12 @@ const NoHTTPFields = 24; - HTTPDateFmt = '"%s", dd "%s" yyyy hh:mm:ss'; // For use in FormatDateTime - SCookieExpire = ' "expires="'+HTTPDateFmt+' "GMT;"'; - SCookieDomain = ' domain=%s;'; - SCookiePath = ' path=%s;'; - SCookieSecure = ' secure'; + HTTPDateFmt = '"%s", dd "%s" yyyy hh:mm:ss'; // For use in FormatDateTime + SCookieExpire = ' "Expires="'+HTTPDateFmt+' "GMT"'; + SCookieDomain = ' Domain=%s'; + SCookiePath = ' Path=%s'; + SCookieSecure = ' Secure'; + SCookieHttpOnly = ' HttpOnly'; HTTPMonths: array[1..12] of string[3] = ( 'Jan', 'Feb', 'Mar', 'Apr', @@ -98,6 +99,7 @@ type TCookie = class(TCollectionItem) private + FHttpOnly: Boolean; FName: string; FValue: string; FPath: string; @@ -109,12 +111,14 @@ type public constructor Create(ACollection: TCollection); override; procedure Assign(Source: TPersistent); override; + procedure Expire; property Name: string read FName write FName; property Value: string read FValue write FValue; property Domain: string read FDomain write FDomain; property Path: string read FPath write FPath; property Expires: TDateTime read FExpires write FExpires; property Secure: Boolean read FSecure write FSecure; + property HttpOnly: Boolean read FHttpOnly write FHttpOnly; Property AsString : String Read GetAsString; end; @@ -290,7 +294,9 @@ type Procedure ProcessMultiPart(Stream : TStream; Const Boundary : String;SL:TStrings); virtual; Procedure ProcessQueryString(Const FQueryString : String; SL:TStrings); virtual; procedure ProcessURLEncoded(Stream : TStream;SL:TStrings); virtual; - Function GetTempUploadFileName : String; virtual; + Function RequestUploadDir : String; virtual; + Function GetTempUploadFileName(Const AName, AFileName : String; ASize : Int64) : String; virtual; + Procedure DeleteTempUploadedFiles; virtual; Procedure InitRequestVars; virtual; Procedure InitPostVars; virtual; Procedure InitGetVars; virtual; @@ -427,7 +433,7 @@ Resourcestring SErrUnknownCookie = 'Unknown cookie: "%s"'; SErrUnsupportedContentType = 'Unsupported content type: "%s"'; SErrNoRequestMethod = 'No REQUEST_METHOD passed from server.'; - SErrInvalidRequestMethod = 'Invalid REQUEST_METHOD passed from server.'; + SErrInvalidRequestMethod = 'Invalid REQUEST_METHOD passed from server: %s.'; const hexTable = '0123456789ABCDEF'; @@ -951,18 +957,8 @@ begin end; destructor TRequest.destroy; -var - i: Integer; - s: String; begin - //delete all temporary uploaded files created for this request if there is any - i := FFiles.Count; - if i > 0 then for i := i - 1 downto 0 do - begin - s := FFiles[i].LocalFileName; - if FileExists(s) then DeleteFile(s); - end; - // + DeleteTempUploadedFiles; FreeAndNil(FFiles); inherited destroy; end; @@ -1191,18 +1187,36 @@ begin {$ifdef CGIDEBUG}SendMethodExit('ProcessQueryString');{$endif CGIDEBUG} end; -function TRequest.GetTempUploadFileName: String; +Function TRequest.RequestUploadDir : String; begin -//Result:=GetTempFileName('/tmp/','CGI') {Hard coded path no good for all OS-es} -{ -GetTempDir returns the OS temporary directory if possible, or from the -environment variable TEMP . For CGI programs you need to pass global environment - variables, it is not automatic. For example in the Apache httpd.conf with a -"PassEnv TEMP" or "SetEnv TEMP /pathtotmpdir" line so the web server passes this - global environment variable to the CGI programs' local environment variables. -} - Result := GetTempFileName(GetTempDir, 'CGI'); + Result:=''; +end; + +Function TRequest.GetTempUploadFileName(Const AName, AFileName : String; ASize : Int64): String; + +Var + D : String; + +begin + D:=RequestUploadDir; + if (D='') then + D:=GetTempDir; // Note that this may require a TEMP environment variable to be set by the webserver. + Result:=GetTempFileName(D, 'CGI'); +end; + +Procedure TRequest.DeleteTempUploadedFiles; +var + i: Integer; + s: String; +begin + //delete all temporary uploaded files created for this request if there is any + i := FFiles.Count; + if i > 0 then for i := i - 1 downto 0 do + begin + s := FFiles[i].LocalFileName; + if FileExists(s) then DeleteFile(s); + end; end; procedure TRequest.InitRequestVars; @@ -1223,7 +1237,7 @@ begin if FHandleGetOnPost then InitGetVars; end - else if (CompareText(R,'GET')=0) or (CompareText(R,'HEAD')=0) then + else if (CompareText(R,'GET')=0) or (CompareText(R,'HEAD')=0) or (CompareText(R,'OPTIONS')=0) then InitGetVars else Raise Exception.CreateFmt(SErrInvalidRequestMethod,[R]); @@ -1356,10 +1370,10 @@ begin else begin FI.DLen:=J; - FF:=GetTempUploadFileName; + FF:=GetTempUploadFileName(FI.name,FI.FileName,J); F:=TFileStream.Create(FF,fmCreate); Try - F.Write(FI.Data[1],Length(FI.Data)); + F.Write(FI.Data[1],J); finally F.Free; end; @@ -1655,29 +1669,37 @@ end; function TCookie.GetAsString: string; + Procedure AddToResult(S : String); + + begin + Result:=Result+';'+S; + end; + Var Y,M,D : Word; begin {$ifdef cgidebug}SendMethodEnter('TCookie.GetAsString');{$endif} try - Result:=Format('%s=%s;',[HTTPEncode(FName),HTTPEncode(FValue)]); + Result:=Format('%s=%s',[HTTPEncode(FName),HTTPEncode(FValue)]); if (Length(FDomain)>0) then - Result:=Result+Format(SCookieDomain,[FDomain]); + AddToResult(Format(SCookieDomain,[FDomain])); if (Length(FPath)>0) then - Result:=Result+Format(SCookiePath,[FPath]); + AddToResult(Format(SCookiePath,[FPath])); if (FExpires>-1) then begin DecodeDate(Expires,Y,M,D); - Result:=Result+Format(FormatDateTime(SCookieExpire,Expires), - [HTTPDays[DayOfWeek(Expires)],HTTPMonths[M]]); + AddToResult(Format(FormatDateTime(SCookieExpire,Expires), + [HTTPDays[DayOfWeek(Expires)],HTTPMonths[M]])); end; - if Secure then - Result:=Result+SCookieSecure; + if FHttpOnly then + AddToResult(SCookieHttpOnly); + if FSecure then + AddToResult(SCookieSecure); except {$ifdef cgidebug} On E : Exception do - SendDebug('Exception in cookie asstring : '+E.Message) + SendDebug('Exception in cookie AsString: '+E.Message) {$endif} end; {$ifdef cgidebug}SendMethodExit('TCookie.GetAsString');{$endif} @@ -1699,12 +1721,18 @@ begin Self.FDomain:=Domain; Self.FPath:=Path; Self.FExpires:=Expires; + Self.FHttpOnly:=HttpOnly; Self.FSecure:=Secure; end else inherited Assign(Source); end; +procedure TCookie.Expire; +begin + FExpires := EncodeDate(1970, 1, 1); +end; + { TCookieCollection } function TCookies.GetCookie(Index: Integer): TCookie; diff --git a/mips/packages/fcl-web/src/base/iniwebsession.pp b/mips/packages/fcl-web/src/base/iniwebsession.pp index 738b289b2b..7c31d46072 100644 --- a/mips/packages/fcl-web/src/base/iniwebsession.pp +++ b/mips/packages/fcl-web/src/base/iniwebsession.pp @@ -48,6 +48,7 @@ Type Procedure InitSession(ARequest : TRequest; OnNewSession, OnExpired: TNotifyEvent); override; Procedure InitResponse(AResponse : TResponse); override; Procedure RemoveVariable(VariableName : String); override; + Function GetSessionDir : String; end; TIniWebSessionClass = Class of TIniWebSession; @@ -68,6 +69,7 @@ Type // Sweep session direcory and delete expired files. procedure DoCleanupSessions; override; Procedure DoDoneSession(Var ASession : TCustomSession); override; + Function SessionFilePrefix : String; virtual; Public // Directory where sessions are kept. Property SessionDir : String Read FSessionDir Write SetSessionDir; @@ -212,8 +214,20 @@ begin FreeAndNil(ASession); end; +Function TIniSessionFactory.SessionFilePrefix : String; + +begin + Result:=''; +end; + { TIniWebSession } +Function TIniWebSession.GetSessionDir : String; + +begin + Result:=SessionDir; +end; + function TIniWebSession.GetSessionID: String; begin If (SID='') then @@ -282,8 +296,10 @@ procedure TIniWebSession.InitSession(ARequest: TRequest; OnNewSession,OnExpired: Var S : String; - + SF : TIniSessionFactory; + begin + SF:=SessionFactory as TIniSessionFactory; {$ifdef cgidebug}SendMethodEnter('TIniWebSession.InitSession');{$endif} // First initialize all session-dependent properties to their default, because // in Apache-modules or fcgi programs the session-instance is re-used @@ -299,13 +315,13 @@ begin If (S<>'') then begin {$ifdef cgidebug}SendDebug('Reading ini file:'+S);{$endif} - FIniFile:=TMemIniFile.Create(IncludeTrailingPathDelimiter(SessionDir)+S); - if (SessionFactory as TIniSessionFactory).SessionExpired(FIniFile) then + FIniFile:=TMemIniFile.Create(IncludeTrailingPathDelimiter(SessionDir)+SF.SessionFilePrefix+S); + if SF.SessionExpired(FIniFile) then begin // Expire session. If Assigned(OnExpired) then OnExpired(Self); - (SessionFactory as TIniSessionFactory).DeleteSessionFile(FIniFIle.FileName); + SF.DeleteSessionFile(FIniFIle.FileName); FreeAndNil(FInifile); S:=''; end @@ -317,7 +333,7 @@ begin If Assigned(OnNewSession) then OnNewSession(Self); GetSessionID; - S:=IncludeTrailingPathDelimiter(SessionDir)+SessionID; + S:=IncludeTrailingPathDelimiter(SessionDir)+SF.SessionFilePrefix+SessionID; {$ifdef cgidebug}SendDebug('Creating new Ini file : '+S);{$endif} FIniFile:=TMemIniFile.Create(S); FIniFile.WriteDateTime(SSession,KeyStart,Now); diff --git a/mips/packages/fpindexer/src/dbindexer.pp b/mips/packages/fpindexer/src/dbindexer.pp index 2cfb044119..618d3d733a 100644 --- a/mips/packages/fpindexer/src/dbindexer.pp +++ b/mips/packages/fpindexer/src/dbindexer.pp @@ -394,6 +394,7 @@ Var begin Result:=0; + T:=''; R:=TIReaderTXT.Create; try URL:=TableName+'/'+KeyField.AsString; diff --git a/mips/packages/libpng/src/png.pp b/mips/packages/libpng/src/png.pp index 2924830a86..156d66b522 100644 --- a/mips/packages/libpng/src/png.pp +++ b/mips/packages/libpng/src/png.pp @@ -25,6 +25,7 @@ Const LibPng = 'png'; // Library name { matching lib version for libpng, needed for initialization } PNG_LIBPNG_VER_STRING='1.2.12'; + {$linklib png} {$endif windows} type diff --git a/mips/packages/winunits-base/src/eventsink.pp b/mips/packages/winunits-base/src/eventsink.pp index c6bad57a2c..f2777a9d5c 100644 --- a/mips/packages/winunits-base/src/eventsink.pp +++ b/mips/packages/winunits-base/src/eventsink.pp @@ -41,7 +41,9 @@ type const IID: TGUID; LocaleID: Integer; Flags: Word; Params: TDispParams; VarResult, ExcepInfo, ArgErr: Pointer) of object; - TAbstractEventSink = class(TInterfacedObject, IDispatch) + { TAbstractEventSink } + + TAbstractEventSink = class(TObject, IDispatch,IUnknown) // see mantis #22156 private FDispatch: IDispatch; FDispIntfIID: TGUID; @@ -49,7 +51,10 @@ type FOwner: TComponent; protected { IUnknown } + frefcount : longint; function QueryInterface(constref IID: TGUID; out Obj): HRESULT; stdcall; + function _AddRef : longint;stdcall; + function _Release : longint;stdcall; { IDispatch } function GetTypeInfoCount(out Count: Integer): HRESULT; stdcall; function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HRESULT; stdcall; @@ -166,6 +171,20 @@ begin Result := S_OK; end; +function TAbstractEventSink._AddRef: longint; stdcall; +begin + frefcount:=frefcount+1; + _addref:=frefcount; +end; + +function TAbstractEventSink._Release: longint; stdcall; +begin + frefcount:=frefcount-1; + _Release:=frefcount; + if frefcount=0 then + self.destroy; +end; + procedure TAbstractEventSink.Connect(AnAppDispatch: IDispatch; const AnAppDispIntfIID: TGUID); begin diff --git a/mips/rtl/arm/arm.inc b/mips/rtl/arm/arm.inc index 3387ff8e16..65bcb64d1f 100644 --- a/mips/rtl/arm/arm.inc +++ b/mips/rtl/arm/arm.inc @@ -52,7 +52,7 @@ begin // mask "exception happened" and overflow flags and r0,r0,#0xffffff20 // mask exception flags - and r0,r0,#0xffff40ff + and r0,r0,#0xffff40ff {$ifndef darwin} // Floating point exceptions cause kernel panics on iPhoneOS 2.2.1... @@ -110,7 +110,7 @@ end; {$ENDIF not INTERNAL_BACKTRACE} {$define FPC_SYSTEM_HAS_GET_CALLER_ADDR} -function get_caller_addr(framebp:pointer):pointer;assembler;nostackframe; +function get_caller_addr(framebp:pointer;addr:pointer=nil):pointer;assembler;nostackframe; asm cmp r0,#0 {$ifndef darwin} @@ -122,7 +122,7 @@ end; {$define FPC_SYSTEM_HAS_GET_CALLER_FRAME} -function get_caller_frame(framebp:pointer):pointer;assembler;nostackframe; +function get_caller_frame(framebp:pointer;addr:pointer=nil):pointer;assembler;nostackframe; asm cmp r0,#0 {$ifndef darwin} @@ -145,62 +145,69 @@ end; Procedure FillChar(var x;count:longint;value:byte);assembler;nostackframe; asm // less than 0? - cmp r1,#0 -{$if defined(cpuarmv3) or defined(cpuarmv4) or defined(cpuarmv5)} - movlt pc,lr + cmp r1,#0 +{$if defined(cpuarmv3) or defined(cpuarmv4)} + movle pc,lr {$else} - bxlt lr + bxle lr {$endif} mov r3,r0 - cmp r1,#8 // at least 8 bytes to do? - blt .LFillchar2 - orr r2,r2,r2,lsl #8 - orr r2,r2,r2,lsl #16 -.LFillchar0: - tst r3,#3 // aligned yet? - strneb r2,[r3],#1 - subne r1,r1,#1 - bne .LFillchar0 + + orr r2,r2,r2,lsl #8 + orr r2,r2,r2,lsl #16 + + tst r3, #3 // Aligned? + bne .LFillchar_do_align + +.LFillchar_is_aligned: + subs r1,r1,#8 + bmi .LFillchar_less_than_8bytes + mov ip,r2 -.LFillchar1: - cmp r1,#8 // 8 bytes still to do? - blt .LFillchar2 - stmia r3!,{r2,ip} - sub r1,r1,#8 - cmp r1,#8 // 8 bytes still to do? - blt .LFillchar2 +.LFillchar_at_least_8bytes: + // Do 16 bytes per loop + // More unrolling is uncessary, as we'll just stall on the write buffers stmia r3!,{r2,ip} - sub r1,r1,#8 - cmp r1,#8 // 8 bytes still to do? - blt .LFillchar2 - stmia r3!,{r2,ip} - sub r1,r1,#8 - cmp r1,#8 // 8 bytes still to do? - stmgeia r3!,{r2,ip} - subge r1,r1,#8 - bge .LFillchar1 -.LFillchar2: - movs r1,r1 // anything left? -{$if defined(cpuarmv3) or defined(cpuarmv4) or defined(cpuarmv5)} + subs r1,r1,#8 + stmplia r3!,{r2,ip} + subpls r1,r1,#8 + bpl .LFillchar_at_least_8bytes + +.LFillchar_less_than_8bytes: + // Do the rest + adds r1, r1, #8 + +{$if defined(cpuarmv3) or defined(cpuarmv4)} moveq pc,lr {$else} bxeq lr {$endif} - rsb r1,r1,#7 - add pc,pc,r1,lsl #2 - mov r0,r0 - strb r2,[r3],#1 - strb r2,[r3],#1 - strb r2,[r3],#1 - strb r2,[r3],#1 - strb r2,[r3],#1 - strb r2,[r3],#1 - strb r2,[r3],#1 -{$if defined(cpuarmv3) or defined(cpuarmv4) or defined(cpuarmv5)} + + tst r1, #4 + strne r2,[r3],#4 + tst r1, #2 + strneh r2,[r3],#2 + tst r1, #1 + strneb r2,[r3],#1 +{$if defined(cpuarmv3) or defined(cpuarmv4)} mov pc,lr {$else} bx lr {$endif} + +// Special case for unaligned start +// We make a maximum of 3 loops here +.LFillchar_do_align: + strb r2,[r3],#1 + subs r1, r1, #1 +{$if defined(cpuarmv3) or defined(cpuarmv4)} + moveq pc,lr +{$else} + bxeq lr +{$endif} + tst r3,#3 + bne .LFillchar_do_align + b .LFillchar_is_aligned end; {$endif FPC_SYSTEM_HAS_FILLCHAR} @@ -211,7 +218,7 @@ asm pld [r0] // count <=0 ? cmp r2,#0 -{$if defined(cpuarmv3) or defined(cpuarmv4) or defined(cpuarmv5)} +{$if defined(cpuarmv3) or defined(cpuarmv4)} movle pc,lr {$else} bxle lr @@ -228,7 +235,7 @@ asm ldrb r3,[r0,r2] strb r3,[r1,r2] bne .Loverlapped -{$if defined(cpuarmv3) or defined(cpuarmv4) or defined(cpuarmv5)} +{$if defined(cpuarmv3) or defined(cpuarmv4)} mov pc,lr {$else} bx lr @@ -273,7 +280,7 @@ asm str r3,[r1],#4 bcs .Ldwordloop cmp r2,#0 -{$if defined(cpuarmv3) or defined(cpuarmv4) or defined(cpuarmv5)} +{$if defined(cpuarmv3) or defined(cpuarmv4)} moveq pc,lr {$else} bxeq lr @@ -283,7 +290,7 @@ asm ldrb r3,[r0],#1 strb r3,[r1],#1 bne .Lbyteloop -{$if defined(cpuarmv3) or defined(cpuarmv4) or defined(cpuarmv5)} +{$if defined(cpuarmv3) or defined(cpuarmv4)} mov pc,lr {$else} bx lr @@ -294,7 +301,7 @@ procedure Move_blended(const source;var dest;count:longint);assembler;nostackfra asm // count <=0 ? cmp r2,#0 -{$if defined(cpuarmv3) or defined(cpuarmv4) or defined(cpuarmv5)} +{$if defined(cpuarmv3) or defined(cpuarmv4)} movle pc,lr {$else} bxle lr @@ -311,7 +318,7 @@ asm ldrb r3,[r0,r2] strb r3,[r1,r2] bne .Loverlapped -{$if defined(cpuarmv3) or defined(cpuarmv4) or defined(cpuarmv5)} +{$if defined(cpuarmv3) or defined(cpuarmv4)} mov pc,lr {$else} bx lr @@ -353,7 +360,7 @@ asm str r3,[r1],#4 bcs .Ldwordloop cmp r2,#0 -{$if defined(cpuarmv3) or defined(cpuarmv4) or defined(cpuarmv5)} +{$if defined(cpuarmv3) or defined(cpuarmv4)} moveq pc,lr {$else} bxeq lr @@ -363,7 +370,7 @@ asm ldrb r3,[r0],#1 strb r3,[r1],#1 bne .Lbyteloop -{$if defined(cpuarmv3) or defined(cpuarmv4) or defined(cpuarmv5)} +{$if defined(cpuarmv3) or defined(cpuarmv4)} mov pc,lr {$else} bx lr @@ -542,7 +549,7 @@ asm terminating 0, due to the known carry flag sbc can do this.*) sbc r0,r1,r0 .Ldone: -{$if defined(cpuarmv3) or defined(cpuarmv4) or defined(cpuarmv5)} +{$if defined(cpuarmv3) or defined(cpuarmv4)} mov pc,lr {$else} bx lr diff --git a/mips/rtl/arm/divide.inc b/mips/rtl/arm/divide.inc index 8df2a6524f..42dfe7dd58 100644 --- a/mips/rtl/arm/divide.inc +++ b/mips/rtl/arm/divide.inc @@ -96,7 +96,7 @@ asm .Ldiv_next: bcs .Ldiv_loop mov r0, r3 -{$if defined(cpuarmv3) or defined(cpuarmv4) or defined(cpuarmv5)} +{$if defined(cpuarmv3) or defined(cpuarmv4)} mov pc, lr {$else} bx lr @@ -105,7 +105,7 @@ asm mov r0, #200 mov r1, r11 bl handleerrorframe -{$if defined(cpuarmv3) or defined(cpuarmv4) or defined(cpuarmv5)} +{$if defined(cpuarmv3) or defined(cpuarmv4)} mov pc, lr {$else} bx lr diff --git a/mips/rtl/arm/strings.inc b/mips/rtl/arm/strings.inc index 388f2e0626..f3512975b6 100644 --- a/mips/rtl/arm/strings.inc +++ b/mips/rtl/arm/strings.inc @@ -15,3 +15,50 @@ **********************************************************************} +{$ifndef FPC_UNIT_HAS_STRUPPER} +{$define FPC_UNIT_HAS_STRUPPER} +function strupper(p : pchar) : pchar;assembler;nostackframe; +asm + mov ip, r0 // Don't change r0, because thats our return value + + ldrb r1, [ip] // First loop does not postindex +.LByteLoop: + cmp r1, #0 +{$if defined(cpuarmv3) or defined(cpuarmv4)} + moveq pc, lr +{$else} + bxeq lr +{$endif} + + sub r2, r1, #97 // Normalize to zero + cmp r2, #25 // temp >= 0 and temp <=25 + subls r1, r1, #32 // is lowercase, make uppercase + strlsb r1, [ip] // Store only on change + ldrb r1, [ip, #1]! // Loading here utilizes a load delay slot + b .LByteLoop +end; +{$endif FPC_UNIT_HAS_STRUPPER} + +{$ifndef FPC_UNIT_HAS_STRLOWER} +{$define FPC_UNIT_HAS_STRLOWER} +function strlower(p : pchar) : pchar;assembler;nostackframe; +asm + mov ip, r0 // Don't change r0, because thats our return value + + ldrb r1, [ip] // First loop does not postindex +.LByteLoop: + cmp r1, #0 +{$if defined(cpuarmv3) or defined(cpuarmv4)} + moveq pc, lr +{$else} + bxeq lr +{$endif} + + sub r2, r1, #65 // Normalize to zero + cmp r2, #25 // temp >= 0 and temp <=25 + addls r1, r1, #32 // Is uppercase, make lowercase + strlsb r1, [ip] // Store only on change + ldrb r1, [ip, #1]! // Loading here utilizes a load delay slot + b .LByteLoop +end; +{$endif FPC_UNIT_HAS_STRLOWER} diff --git a/mips/rtl/avr/avr.inc b/mips/rtl/avr/avr.inc index e9d93e85b1..2ad61f5a07 100644 --- a/mips/rtl/avr/avr.inc +++ b/mips/rtl/avr/avr.inc @@ -38,13 +38,13 @@ function get_frame:pointer;assembler;nostackframe; {$define FPC_SYSTEM_HAS_GET_CALLER_ADDR} -function get_caller_addr(framebp:pointer):pointer;assembler; +function get_caller_addr(framebp:pointer;addr:pointer=nil):pointer;assembler; asm end; {$define FPC_SYSTEM_HAS_GET_CALLER_FRAME} -function get_caller_frame(framebp:pointer):pointer;assembler; +function get_caller_frame(framebp:pointer;addr:pointer=nil):pointer;assembler; asm end; diff --git a/mips/rtl/i386/i386.inc b/mips/rtl/i386/i386.inc index 368c7a02f4..9fb8a7d724 100644 --- a/mips/rtl/i386/i386.inc +++ b/mips/rtl/i386/i386.inc @@ -1061,8 +1061,14 @@ end; {$ENDIF not INTERNAL_BACKTRACE} +{$define FPC_SYSTEM_HAS_GET_PC_ADDR} +Function Get_pc_addr : Pointer;assembler;nostackframe; +asm + movl (%esp),%eax +end; + {$define FPC_SYSTEM_HAS_GET_CALLER_ADDR} -function get_caller_addr(framebp:pointer):pointer;nostackframe;assembler; +function get_caller_addr(framebp:pointer;addr:pointer=nil):pointer;nostackframe;assembler; asm orl %eax,%eax jz .Lg_a_null @@ -1072,7 +1078,7 @@ end; {$define FPC_SYSTEM_HAS_GET_CALLER_FRAME} -function get_caller_frame(framebp:pointer):pointer;nostackframe;assembler; +function get_caller_frame(framebp:pointer;addr:pointer=nil):pointer;nostackframe;assembler; asm orl %eax,%eax jz .Lgnf_null diff --git a/mips/rtl/inc/compproc.inc b/mips/rtl/inc/compproc.inc index 0a7d9ccc7f..8024c715d3 100644 --- a/mips/rtl/inc/compproc.inc +++ b/mips/rtl/inc/compproc.inc @@ -40,6 +40,7 @@ procedure fpc_zeromem(p:pointer;len:ptruint);compilerproc; procedure fpc_fillmem(out data;len:ptruint;b : byte);compilerproc; procedure fpc_Shortstr_SetLength(var s:shortstring;len:SizeInt); compilerproc; +procedure fpc_shortstr_assign(len:longint;sstr,dstr:pointer); compilerproc; procedure fpc_shortstr_to_shortstr(out res:shortstring; const sstr: shortstring); compilerproc; procedure fpc_shortstr_concat(var dests:shortstring;const s1,s2:shortstring);compilerproc; @@ -421,7 +422,7 @@ procedure fpc_variant_init(var v: tvardata);compilerproc; procedure fpc_variant_clear(var v: tvardata);compilerproc; {$ifdef FPC_VARIANTCOPY_FIXED} procedure fpc_variant_copy(var d: tvardata; const s : tvardata);compilerproc; -procedure fpc_variant_copy_overwrite(const source: tvardata; var dest : tvardata);compilerproc; +procedure fpc_variant_copy_overwrite(constref source: tvardata; var dest : tvardata);compilerproc; {$else FPC_VARIANTCOPY_FIXED} procedure fpc_variant_copy(d,s : pointer);compilerproc; procedure fpc_variant_copy_overwrite(source, dest : pointer);compilerproc; diff --git a/mips/rtl/inc/except.inc b/mips/rtl/inc/except.inc index e1b4839d8a..e9343dfcb3 100644 --- a/mips/rtl/inc/except.inc +++ b/mips/rtl/inc/except.inc @@ -102,6 +102,7 @@ var frames : PPointer; prev_frame, curr_frame, + curr_addr, caller_frame, caller_addr : Pointer; begin @@ -119,15 +120,16 @@ begin { Backtrace } curr_frame:=AFrame; - prev_frame:=get_frame; + curr_addr:=AnAddr; + prev_frame:=get_caller_frame(curr_addr, curr_frame); frames:=nil; framebufsize:=0; framecount:=0; while (framecount<RaiseMaxFrameCount) and (curr_frame > prev_frame) and (curr_frame<(StackBottom + StackLength)) do Begin - caller_addr := get_caller_addr(curr_frame); - caller_frame := get_caller_frame(curr_frame); + caller_addr := get_caller_addr(curr_frame, curr_addr); + caller_frame := get_caller_frame(curr_frame, curr_addr); if (caller_addr=nil) or (caller_frame=nil) then break; @@ -139,6 +141,7 @@ begin frames[framecount]:=caller_addr; inc(framecount); prev_frame:=curr_frame; + curr_addr:=caller_addr; curr_frame:=caller_frame; End; NewObj^.framecount:=framecount; diff --git a/mips/rtl/inc/generic.inc b/mips/rtl/inc/generic.inc index 87e0a46699..7c351a666c 100644 --- a/mips/rtl/inc/generic.inc +++ b/mips/rtl/inc/generic.inc @@ -892,7 +892,7 @@ begin res[0]:=chr(slen); end; -procedure fpc_shortstr_assign(len:longint;sstr,dstr:pointer);[public,alias:'FPC_SHORTSTR_ASSIGN']; +procedure fpc_shortstr_assign(len:longint;sstr,dstr:pointer);[public,alias:'FPC_SHORTSTR_ASSIGN']; compilerproc; var slen : byte; begin diff --git a/mips/rtl/inc/heaptrc.pp b/mips/rtl/inc/heaptrc.pp index 9963a40e01..1099cc5927 100644 --- a/mips/rtl/inc/heaptrc.pp +++ b/mips/rtl/inc/heaptrc.pp @@ -331,14 +331,21 @@ end; procedure dump_already_free(p : pheap_mem_info;var ptext : text); +var + bp, pcaddr : pointer; begin Writeln(ptext,'Marked memory at $',HexStr(pointer(p)+sizeof(theap_mem_info)),' released'); call_free_stack(p,ptext); Writeln(ptext,'freed again at'); - dump_stack(ptext,get_caller_frame(get_frame)); + bp:=get_frame; + pcaddr:=get_pc_addr; + get_caller_stackinfo(bp,pcaddr); + dump_stack(ptext,bp,pcaddr); end; procedure dump_error(p : pheap_mem_info;var ptext : text); +var + bp, pcaddr : pointer; begin Writeln(ptext,'Marked memory at $',HexStr(pointer(p)+sizeof(theap_mem_info)),' invalid'); Writeln(ptext,'Wrong signature $',hexstr(p^.sig,8),' instead of ',hexstr(calculate_sig(p),8)); @@ -347,7 +354,10 @@ begin write(ptext, 'Block content: '); printhex(pointer(p) + sizeof(theap_mem_info), p^.size, ptext); end; - dump_stack(ptext,get_caller_frame(get_frame)); + bp:=get_frame; + pcaddr:=get_pc_addr; + get_caller_stackinfo(bp,pcaddr); + dump_stack(ptext,bp,pcaddr); end; {$ifdef EXTRA} @@ -367,10 +377,15 @@ end; {$endif EXTRA} procedure dump_wrong_size(p : pheap_mem_info;size : ptruint;var ptext : text); +var + bp, pcaddr : pointer; begin Writeln(ptext,'Marked memory at $',HexStr(pointer(p)+sizeof(theap_mem_info)),' invalid'); Writeln(ptext,'Wrong size : ',p^.size,' allocated ',size,' freed'); - dump_stack(ptext,get_caller_frame(get_frame)); + bp:=get_frame; + pcaddr:=get_pc_addr; + get_caller_stackinfo(bp,pcaddr); + dump_stack(ptext,bp,pcaddr); { the check is done to be sure that the procvar is not overwritten } if assigned(p^.extra_info) and (p^.extra_info^.check=$12345678) and @@ -445,7 +460,7 @@ Function TraceGetMem(size:ptruint):pointer; var allocsize,i : ptruint; oldbp, - bp : pointer; + bp,pcaddr : pointer; pl : pdword; p : pointer; pp : pheap_mem_info; @@ -509,15 +524,16 @@ begin { clear the memory } fillchar(p^,size,#255); { retrieve backtrace info } - bp:=get_caller_frame(get_frame); - + bp:=get_frame; + pcaddr:=get_pc_addr; + get_caller_stackinfo(bp,pcaddr); { valid bp? } if (bp>=StackBottom) and (bp<(StackBottom + StackLength)) then for i:=1 to tracesize do begin - pp^.calls[i]:=get_caller_addr(bp); oldbp:=bp; - bp:=get_caller_frame(bp); + get_caller_stackinfo(bp,pcaddr); + pp^.calls[i]:=pcaddr; if (bp<oldbp) or (bp>(StackBottom + StackLength)) then break; end; @@ -553,7 +569,7 @@ function CheckFreeMemSize(loc_info: pheap_info; pp: pheap_mem_info; size, ppsize: ptruint): boolean; inline; var i: ptruint; - bp : pointer; + bp,pcaddr : pointer; ptext : ^text; {$ifdef EXTRA} pp2 : pheap_mem_info; @@ -612,12 +628,15 @@ begin end else begin - bp:=get_caller_frame(get_frame); + bp:=get_frame; + pcaddr:=get_pc_addr; + get_caller_stackinfo(bp,pcaddr); + if (bp>=StackBottom) and (bp<(StackBottom + StackLength)) then for i:=(tracesize div 2)+1 to tracesize do begin - pp^.calls[i]:=get_caller_addr(bp); - bp:=get_caller_frame(bp); + get_caller_stackinfo(bp,pcaddr); + pp^.calls[i]:=pcaddr; if not((bp>=StackBottom) and (bp<(StackBottom + StackLength))) then break; end; @@ -775,7 +794,8 @@ var movesize, i : ptruint; oldbp, - bp : pointer; + bp, + pcaddr : pointer; pl : pdword; pp : pheap_mem_info; oldsize, @@ -890,13 +910,15 @@ begin inc(loc_info^.getmem_size,size); inc(loc_info^.getmem8_size,(size+7) and not 7); { generate new backtrace } - bp:=get_caller_frame(get_frame); + bp:=get_frame; + pcaddr:=get_pc_addr; + get_caller_stackinfo(bp,pcaddr); if (bp>=StackBottom) and (bp<(StackBottom + StackLength)) then for i:=1 to tracesize do begin - pp^.calls[i]:=get_caller_addr(bp); oldbp:=bp; - bp:=get_caller_frame(bp); + get_caller_stackinfo(bp,pcaddr); + pp^.calls[i]:=pcaddr; if (bp<oldbp) or (bp>(StackBottom + StackLength)) then break; end; @@ -979,6 +1001,7 @@ var {$ifdef morphos} stack_top: longword; {$endif morphos} + bp,pcaddr : pointer; ptext : ^text; label _exit; @@ -1136,7 +1159,10 @@ begin end; end; writeln(ptext^,'pointer $',hexstr(p),' does not point to valid memory block'); - dump_stack(ptext^,get_caller_frame(get_frame)); + bp:=get_frame; + pcaddr:=get_pc_addr; + get_caller_stackinfo(bp,pcaddr); + dump_stack(ptext^,bp,pcaddr); runerror(204); _exit: end; diff --git a/mips/rtl/inc/system.inc b/mips/rtl/inc/system.inc index 25d04d563b..47d5d97e95 100644 --- a/mips/rtl/inc/system.inc +++ b/mips/rtl/inc/system.inc @@ -78,6 +78,7 @@ Const Procedure HandleError (Errno : Longint); forward; Procedure HandleErrorFrame (Errno : longint;frame : Pointer); forward; +Procedure HandleErrorAddrFrame (Errno : longint;addr,frame : Pointer); forward; {$ifdef FPC_HAS_FEATURE_TEXTIO} type @@ -668,33 +669,60 @@ End; Miscellaneous *****************************************************************************} +{$ifndef FPC_SYSTEM_HAS_GET_PC_ADDR} + { This provides a dummy implementation + of get_pc_addr function, for CPU's that don't need + the instruction address to walk the stack. } +function get_pc_addr : pointer; +begin + get_pc_addr:=nil; +end; +{$endif ndef FPC_SYSTEM_HAS_GET_PC_ADDR} + +{$ifndef FPC_SYSTEM_HAS_GET_CALLER_STACKINFO} + { This provides a simpel implementation + of get_caller_stackinfo procedure, + using get_caller_addr and get_caller_frame + functions. } +procedure get_caller_stackinfo(var framebp,addr : pointer); +var + nextbp,nextaddr : pointer; +begin + nextbp:=get_caller_frame(framebp,addr); + nextaddr:=get_caller_addr(framebp,addr); + framebp:=nextbp; + addr:=nextaddr; +end; +{$endif ndef FPC_SYSTEM_HAS_GET_CALLER_STACKINFO} + + procedure fpc_rangeerror;[public,alias:'FPC_RANGEERROR']; compilerproc; begin - HandleErrorFrame(201,get_frame); + HandleErrorAddrFrame(201,get_pc_addr,get_frame); end; procedure fpc_divbyzero;[public,alias:'FPC_DIVBYZERO']; compilerproc; begin - HandleErrorFrame(200,get_frame); + HandleErrorAddrFrame(200,get_pc_addr,get_frame); end; procedure fpc_overflow;[public,alias:'FPC_OVERFLOW']; compilerproc; begin - HandleErrorFrame(215,get_frame); + HandleErrorAddrFrame(215,get_pc_addr,get_frame); end; procedure fpc_threaderror; [public,alias:'FPC_THREADERROR']; begin - HandleErrorFrame(6,get_frame); + HandleErrorAddrFrame(6,get_pc_addr,get_frame); end; procedure fpc_invalidpointer; [public,alias:'FPC_INVALIDPOINTER']; begin - HandleErrorFrame(216,get_frame); + HandleErrorAddrFrame(216,get_pc_addr,get_frame); end; @@ -708,7 +736,7 @@ begin begin l:=HInOutRes^; HInOutRes^:=0; - HandleErrorFrame(l,get_frame); + HandleErrorAddrFrame(l,get_pc_addr,get_frame); end; end; @@ -737,7 +765,7 @@ begin begin if assigned(SafeCallErrorProc) then SafeCallErrorProc(res,get_frame); - HandleErrorFrame(229,get_frame); + HandleErrorAddrFrame(229,get_pc_addr,get_frame); end; result:=res; end; @@ -1024,15 +1052,20 @@ Procedure HandleError (Errno : longint);[public,alias : 'FPC_HANDLEERROR']; Internal function should ALWAYS call HandleError instead of RunError. } begin - HandleErrorFrame(Errno,get_frame); + HandleErrorAddrFrame(Errno,get_pc_addr,get_frame); end; procedure RunError(w : word);[alias: 'FPC_RUNERROR']; +var + bp,pcaddr : pointer; begin errorcode:=w; - erroraddr:=get_caller_addr(get_frame); - errorbase:=get_caller_frame(get_frame); + pcaddr:=get_pc_addr; + bp:=get_frame; + get_caller_stackinfo(bp,pcaddr); + erroraddr:=pcaddr; + errorbase:=bp; Halt(errorcode); end; @@ -1055,10 +1088,11 @@ begin end; -Procedure dump_stack(var f : text;bp : Pointer); +Procedure dump_stack(var f : text;bp,addr : Pointer); var i : Longint; prevbp : Pointer; + prevaddr : pointer; is_dev : boolean; caller_frame, caller_addr : Pointer; @@ -1067,12 +1101,13 @@ Begin try {$endif FPC_HAS_FEATURE_EXCEPTIONS} prevbp:=bp-1; + prevaddr:=nil; i:=0; is_dev:=do_isdevice(textrec(f).Handle); while bp > prevbp Do Begin - caller_addr := get_caller_addr(bp); - caller_frame := get_caller_frame(bp); + caller_addr := get_caller_addr(bp,addr); + caller_frame := get_caller_frame(bp,addr); if (caller_addr=nil) then break; Writeln(f,BackTraceStrFunc(caller_addr)); @@ -1082,7 +1117,9 @@ Begin If ((i>max_frame_dump) and is_dev) or (i>256) Then break; prevbp:=bp; + prevaddr:=addr; bp:=caller_frame; + addr:=caller_addr; End; {$ifdef FPC_HAS_FEATURE_EXCEPTIONS} except @@ -1268,16 +1305,17 @@ procedure fpc_AbstractErrorIntern;compilerproc;[public,alias : 'FPC_ABSTRACTERRO begin If pointer(AbstractErrorProc)<>nil then AbstractErrorProc(); - HandleErrorFrame(211,get_frame); + HandleErrorAddrFrame(211,get_pc_addr,get_frame); end; -Procedure fpc_assert(Const Msg,FName:Shortstring;LineNo:Longint;ErrorAddr:Pointer); [Public,Alias : 'FPC_ASSERT']; compilerproc; +Procedure fpc_assert(Const Msg,FName:Shortstring;LineNo:Longint; + ErrorAddr:Pointer); [Public,Alias : 'FPC_ASSERT']; compilerproc; begin if pointer(AssertErrorProc)<>nil then AssertErrorProc(Msg,FName,LineNo,ErrorAddr) else - HandleErrorFrame(227,get_frame); + HandleErrorAddrFrame(227,get_pc_addr,get_frame); end; diff --git a/mips/rtl/inc/systemh.inc b/mips/rtl/inc/systemh.inc index 511a4487a1..a4715dd2a9 100644 --- a/mips/rtl/inc/systemh.inc +++ b/mips/rtl/inc/systemh.inc @@ -644,7 +644,7 @@ Function Random: extended; Procedure Randomize; {$endif FPC_HAS_FEATURE_RANDOM} -{$ifdef FPC_HAS_INTERNAL_ABS_LONG and (defined(cpui386) or defined(cpux86_64) or defined(cpupowerpc))} +{$ifdef FPC_HAS_INTERNAL_ABS_LONG} {$define FPC_SYSTEM_HAS_ABS_LONGINT} Function abs(l:longint):longint;[internproc:fpc_in_abs_long]; {$else FPC_HAS_INTERNAL_ABS_LONG} @@ -1059,15 +1059,18 @@ Procedure getdir(drivenr:byte;var dir:ansistring); //function get_frame:pointer;[INTERNPROC:fpc_in_get_frame]; (* // still defined externally -function get_caller_addr(framebp:pointer):pointer;[INTERNPROC:fpc_in_get_caller_addr]; -function get_caller_frame(framebp:pointer):pointer;[INTERNPROC:fpc_in_get_caller_frame]; +function get_caller_addr(framebp:pointer;addr:pointer=nil):pointer;[INTERNPROC:fpc_in_get_caller_addr]; +function get_caller_frame(framebp:pointer;addr:pointer=nil):pointer;[INTERNPROC:fpc_in_get_caller_frame]; *) {$ELSE} function get_frame:pointer;{$ifdef SYSTEMINLINE}inline;{$endif} {$ENDIF} -function get_caller_addr(framebp:pointer):pointer; -function get_caller_frame(framebp:pointer):pointer; +Function Get_pc_addr : Pointer; + +function get_caller_addr(framebp:pointer;addr:pointer=nil):pointer; +function get_caller_frame(framebp:pointer;addr:pointer=nil):pointer; +procedure get_caller_stackinfo(var framebp,addr : pointer); Function IOResult:Word; Function Sptr:Pointer;[internconst:fpc_in_const_ptr]; @@ -1149,7 +1152,7 @@ Function Paramcount:Longint; Function ParamStr(l:Longint):string; {$endif FPC_HAS_FEATURE_COMMANDARGS} -Procedure Dump_Stack(var f : text;bp:pointer); +Procedure Dump_Stack(var f : text;bp:pointer;addr : pointer = nil); {$ifdef FPC_HAS_FEATURE_EXCEPTIONS} procedure DumpExceptionBackTrace(var f:text); {$endif FPC_HAS_FEATURE_EXCEPTIONS} diff --git a/mips/rtl/inc/variant.inc b/mips/rtl/inc/variant.inc index 19cf9b4569..b41465346d 100644 --- a/mips/rtl/inc/variant.inc +++ b/mips/rtl/inc/variant.inc @@ -52,7 +52,7 @@ procedure fpc_variant_copy(var d: tvardata; const s : tvardata);[Public,Alias:'F VarCopyProc(d,s); end; -procedure fpc_variant_copy_overwrite(const source: tvardata; var dest : tvardata);[Public,Alias:'FPC_VARIANT_COPY_OVERWRITE']; compilerproc; +procedure fpc_variant_copy_overwrite(constref source: tvardata; var dest : tvardata);[Public,Alias:'FPC_VARIANT_COPY_OVERWRITE']; compilerproc; begin dest.VType := varEmpty; if assigned(VarCopyProc) then diff --git a/mips/rtl/java/jastringh.inc b/mips/rtl/java/jastringh.inc index 2a4fcb0ea4..1570e13749 100644 --- a/mips/rtl/java/jastringh.inc +++ b/mips/rtl/java/jastringh.inc @@ -26,6 +26,7 @@ type constructor Create(len: longint; cp: TSystemCodePage);overload; constructor Create(const arr: array of ansichar; length: longint; cp: TSystemCodePage);overload; constructor Create(const arr: array of unicodechar; cp: TSystemCodePage);overload; + constructor Create(const u: unicodestring);overload; constructor Create(const u: unicodestring; cp: TSystemCodePage);overload; constructor Create(const a: RawByteString; cp: TSystemCodePage);overload; constructor Create(const s: shortstring; cp: TSystemCodePage);overload; diff --git a/mips/rtl/java/jastrings.inc b/mips/rtl/java/jastrings.inc index 6eccb4827f..276f7829ca 100644 --- a/mips/rtl/java/jastrings.inc +++ b/mips/rtl/java/jastrings.inc @@ -79,6 +79,13 @@ begin end; +constructor AnsistringClass.Create(const u: unicodestring); +begin + { for use in Java code } + Create(u,DefaultSystemCodePage); +end; + + constructor AnsistringClass.Create(const a: RawByteString; cp: TSystemCodePage); begin Create(AnsistringClass(a).fdata,system.length(AnsistringClass(a).fdata)-1,cp); diff --git a/mips/rtl/java/java_sysh.inc b/mips/rtl/java/java_sysh.inc index 540e49f8a2..129399a09f 100644 --- a/mips/rtl/java/java_sysh.inc +++ b/mips/rtl/java/java_sysh.inc @@ -1,4 +1,27 @@ -{ Imports for Java packages/classes: java.io.IIOException, java.io.IOException, java.io.Serializable, java.lang.AbstractStringBuilder, java.lang.Appendable, java.lang.AssertionError, java.lang.Boolean, java.lang.Byte, java.lang.CharSequence, java.lang.Character, java.lang.Class, java.lang.Cloneable, java.lang.Comparable, java.lang.Double, java.lang.Enum, java.lang.Error, java.lang.Exception, java.lang.Float, java.lang.IllegalArgumentException, java.lang.IllegalStateException, java.lang.IndexOutOfBoundsException, java.lang.Integer, java.lang.Iterable, java.lang.LinkageError, java.lang.Long, java.lang.Math, java.lang.NoSuchMethodException, java.lang.Number, java.lang.Object, java.lang.Readable, java.lang.Runtime, java.lang.RuntimeException, java.lang.Short, java.lang.String, java.lang.StringBuffer, java.lang.StringBuilder, java.lang.System, java.lang.ThreadLocal, java.lang.Throwable, java.lang.UnsupportedOperationException, java.lang.reflect.AccessibleObject, java.lang.reflect.AnnotatedElement, java.lang.reflect.Array, java.lang.reflect.Field, java.lang.reflect.GenericDeclaration, java.lang.reflect.InvocationTargetException, java.lang.reflect.Member, java.lang.reflect.Method, java.lang.reflect.Type, java.math.BigInteger, java.nio.Buffer, java.nio.ByteBuffer, java.nio.CharBuffer, java.nio.charset., java.text.Collator, java.util.AbstractCollection, java.util.AbstractMap, java.util.AbstractSet, java.util.Arrays, java.util.BitSet, java.util.Calendar, java.util.Collection, java.util.Comparator, java.util.EnumSet, java.util.HashMap, java.util.Iterator, java.util.Map, java.util.Set } +{ Imports for Java packages/classes: + java.io.IIOException, java.io.IOException, java.io.Serializable, + java.lang.AbstractStringBuilder, java.lang.Appendable, + java.lang.AssertionError, java.lang.Boolean, java.lang.Byte, + java.lang.CharSequence, java.lang.Character, java.lang.Class, + java.lang.Cloneable, java.lang.Comparable, java.lang.Double, + java.lang.Enum, java.lang.Error, java.lang.Exception, java.lang.Float, + java.lang.IllegalArgumentException, java.lang.IllegalStateException, + java.lang.IndexOutOfBoundsException, java.lang.Integer, java.lang.Iterable, + java.lang.LinkageError, java.lang.Long, java.lang.Math, + java.lang.NoSuchMethodException, java.lang.Number, java.lang.Object, + java.lang.Readable, java.lang.Runtime, java.lang.RuntimeException, + java.lang.Short, java.lang.String, java.lang.StringBuffer, + java.lang.StringBuilder, java.lang.System, java.lang.ThreadLocal, + java.lang.Throwable, java.lang.UnsupportedOperationException, + java.lang.reflect.AccessibleObject, java.lang.reflect.AnnotatedElement, + java.lang.reflect.Array, java.lang.reflect.Field, + java.lang.reflect.GenericDeclaration, java.lang.reflect.InvocationTargetException, + java.lang.reflect.Member, java.lang.reflect.Method, java.lang.reflect.Type, + java.math.BigInteger, java.nio.Buffer, java.nio.ByteBuffer, java.nio.CharBuffer, + java.nio.charset., java.text.Collator, java.util.AbstractCollection, + java.util.AbstractMap, java.util.AbstractSet, java.util.Arrays, java.util.BitSet, + java.util.Calendar, java.util.Collection, java.util.Comparator, java.util.EnumSet, + java.util.HashMap, java.util.Iterator, java.util.Map, java.util.Set } type JLNoSuchMethodException = class; Arr1JLNoSuchMethodException = array of JLNoSuchMethodException; diff --git a/mips/rtl/java/jcompproc.inc b/mips/rtl/java/jcompproc.inc index 49403c5655..68a9d8bb46 100644 --- a/mips/rtl/java/jcompproc.inc +++ b/mips/rtl/java/jcompproc.inc @@ -376,7 +376,7 @@ procedure fpc_variant_init(var v: tvardata);compilerproc; procedure fpc_variant_clear(var v: tvardata);compilerproc; {$ifdef FPC_VARIANTCOPY_FIXED} procedure fpc_variant_copy(var d: tvardata; const s : tvardata);compilerproc; -procedure fpc_variant_copy_overwrite(const source: tvardata; var dest : tvardata);compilerproc; +procedure fpc_variant_copy_overwrite(constref source: tvardata; var dest : tvardata);compilerproc; {$else FPC_VARIANTCOPY_FIXED} procedure fpc_variant_copy(d,s : pointer);compilerproc; procedure fpc_variant_copy_overwrite(source, dest : pointer);compilerproc; diff --git a/mips/rtl/java/jsystemh.inc b/mips/rtl/java/jsystemh.inc index 583e93b440..e21e2c6bc7 100644 --- a/mips/rtl/java/jsystemh.inc +++ b/mips/rtl/java/jsystemh.inc @@ -169,7 +169,7 @@ Function Random: extended; Procedure Randomize; {$endif FPC_HAS_FEATURE_RANDOM} -{$ifdef FPC_HAS_INTERNAL_ABS_LONG and (defined(cpui386) or defined(cpux86_64) or defined(cpupowerpc))} +{$ifdef FPC_HAS_INTERNAL_ABS_LONG} {$define FPC_SYSTEM_HAS_ABS_LONGINT} Function abs(l:longint):longint;[internproc:fpc_in_abs_long]; {$else FPC_HAS_INTERNAL_ABS_LONG} @@ -591,15 +591,15 @@ Procedure getdir(drivenr:byte;var dir:ansistring); //function get_frame:pointer;[INTERNPROC:fpc_in_get_frame]; (* // still defined externally -function get_caller_addr(framebp:pointer):pointer;[INTERNPROC:fpc_in_get_caller_addr]; -function get_caller_frame(framebp:pointer):pointer;[INTERNPROC:fpc_in_get_caller_frame]; +function get_caller_addr(framebp:pointer;addr:pointer=nil):pointer;[INTERNPROC:fpc_in_get_caller_addr]; +function get_caller_frame(framebp:pointer;addr:pointer=nil):pointer;[INTERNPROC:fpc_in_get_caller_frame]; *) {$ELSE} function get_frame:pointer;{$ifdef SYSTEMINLINE}inline;{$endif} {$ENDIF} (* -function get_caller_addr(framebp:pointer):pointer; -function get_caller_frame(framebp:pointer):pointer; +function get_caller_addr(framebp:pointer;addr:pointer=nil):pointer; +function get_caller_frame(framebp:pointer;addr:pointer=nil):pointer; *) //Function IOResult:Word; diff --git a/mips/rtl/jvm/jvm.inc b/mips/rtl/jvm/jvm.inc index 43b18fddd9..a588dc81e5 100644 --- a/mips/rtl/jvm/jvm.inc +++ b/mips/rtl/jvm/jvm.inc @@ -25,7 +25,7 @@ Procedure SysInitFPU;{$ifdef SYSTEMINLINE}inline;{$endif} begin softfloat_exception_mask:=float_flag_underflow or float_flag_inexact or float_flag_denormal; end; - + {$define FPC_SYSTEM_HAS_SYSRESETFPU} Procedure SysResetFPU;{$ifdef SYSTEMINLINE}inline;{$endif} begin @@ -49,14 +49,14 @@ function get_frame:pointer; {$define FPC_SYSTEM_HAS_GET_CALLER_ADDR} -function get_caller_addr(framebp:pointer):pointer; +function get_caller_addr(framebp:pointer;addr:pointer=nil):pointer; begin result:=nil; end; {$define FPC_SYSTEM_HAS_GET_CALLER_FRAME} -function get_caller_frame(framebp:pointer):pointer; +function get_caller_frame(framebp:pointer;addr:pointer=nil):pointer; begin result:=nil; end; diff --git a/mips/rtl/linux/Makefile b/mips/rtl/linux/Makefile index eefecc7e17..ae78a02681 100644 --- a/mips/rtl/linux/Makefile +++ b/mips/rtl/linux/Makefile @@ -1,5 +1,5 @@ # -# Don't edit, this file is generated by FPCMake Version 2.0.0 [2012/05/29] +# Don't edit, this file is generated by FPCMake Version 2.0.0 [2012/07/07] # default: all MAKEFILETARGETS=i386-linux i386-go32v2 i386-win32 i386-os2 i386-freebsd i386-beos i386-haiku i386-netbsd i386-solaris i386-qnx i386-netware i386-openbsd i386-wdosx i386-darwin i386-emx i386-watcom i386-netwlibc i386-wince i386-embedded i386-symbian i386-nativent i386-iphonesim m68k-linux m68k-freebsd m68k-netbsd m68k-amiga m68k-atari m68k-openbsd m68k-palmos m68k-embedded powerpc-linux powerpc-netbsd powerpc-amiga powerpc-macos powerpc-darwin powerpc-morphos powerpc-embedded powerpc-wii powerpc-aix sparc-linux sparc-netbsd sparc-solaris sparc-embedded x86_64-linux x86_64-freebsd x86_64-netbsd x86_64-solaris x86_64-openbsd x86_64-darwin x86_64-win64 x86_64-embedded arm-linux arm-palmos arm-darwin arm-wince arm-gba arm-nds arm-embedded arm-symbian powerpc64-linux powerpc64-darwin powerpc64-embedded powerpc64-aix avr-embedded armeb-linux armeb-embedded mips-linux mipsel-linux jvm-java jvm-android @@ -3214,6 +3214,11 @@ strings$(PPUEXT) : $(INC)/strings.pp $(INC)/stringsi.inc\ unix$(PPUEXT) : $(UNIXINC)/unix.pp strings$(PPUEXT) baseunix$(PPUEXT) $(INC)/textrec.inc $(INC)/filerec.inc \ unxconst.inc $(UNIXINC)/timezone.inc $(SYSTEMUNIT)$(PPUEXT) \ unxfunc.inc + $(COMPILER) $(UNIXINC)/unix.pp +syscall$(PPUEXT) : $(UNIXINC)/syscall.pp $(ARCH)/syscallh.inc $(ARCH)/sysnr.inc $(SYSTEMUNIT)$(PPUEXT) + $(COMPILER) $(UNIXINC)/syscall.pp +unixutil$(PPUEXT) : $(UNIXINC)/unixutil.pp $(INC)/textrec.inc $(INC)/filerec.inc $(SYSTEMUNIT)$(PPUEXT) + $(COMPILER) $(UNIXINC)/unixutil.pp unixtype$(PPUEXT) : $(UNIXINC)/unixtype.pp ptypes.inc $(UNIXINC)/ctypes.inc $(SYSTEMUNIT)$(PPUEXT) $(COMPILER) $(UNIXINC)/unixtype.pp baseunix$(PPUEXT) : errno.inc ptypes.inc $(UNIXINC)/ctypes.inc \ @@ -3221,7 +3226,9 @@ baseunix$(PPUEXT) : errno.inc ptypes.inc $(UNIXINC)/ctypes.inc \ bunxsysc.inc $(ARCH)/syscallh.inc $(ARCH)/sysnr.inc \ ostypes.inc osmacro.inc $(UNIXINC)/gensigset.inc \ $(UNIXINC)/genfuncs.inc $(SYSTEMUNIT)$(PPUEXT) -ports$(PPUEXT) : ports.pp unix$(PPUEXT) objpas$(PPUEXT) + $(COMPILER) $(UNIXINC)/baseunix.pp +ports$(PPUEXT) : $(UNIXINC)/ports.pp unix$(PPUEXT) objpas$(PPUEXT) + $(COMPILER) $(UNIXINC)/ports.pp dl$(PPUEXT) : $(UNIXINC)/dl.pp $(SYSTEMUNIT)$(PPUEXT) $(COMPILER) $(UNIXINC)/dl.pp dynlibs$(PPUEXT) : $(INC)/dynlibs.pas $(UNIXINC)/dynlibs.inc dl$(PPUEXT) objpas$(PPUEXT) @@ -3284,6 +3291,8 @@ cpu$(PPUEXT) : $(PROCINC)/cpu.pp $(SYSTEMUNIT)$(PPUEXT) endif mmx$(PPUEXT) : $(PROCINC)/mmx.pp cpu$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) $(COMPILER) $(PROCINC)/mmx.pp +x86$(PPUEXT) : $(UNIXINC)/x86.pp baseunix$(PPUEXT) syscall$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) + $(COMPILER) $(UNIXINC)/x86.pp getopts$(PPUEXT) : $(INC)/getopts.pp $(SYSTEMUNIT)$(PPUEXT) $(COMPILER) $(INC)/getopts.pp heaptrc$(PPUEXT) : $(INC)/heaptrc.pp $(SYSTEMUNIT)$(PPUEXT) diff --git a/mips/rtl/linux/Makefile.fpc b/mips/rtl/linux/Makefile.fpc index 8f27da22e3..fcf56b0fe0 100644 --- a/mips/rtl/linux/Makefile.fpc +++ b/mips/rtl/linux/Makefile.fpc @@ -187,6 +187,13 @@ strings$(PPUEXT) : $(INC)/strings.pp $(INC)/stringsi.inc\ unix$(PPUEXT) : $(UNIXINC)/unix.pp strings$(PPUEXT) baseunix$(PPUEXT) $(INC)/textrec.inc $(INC)/filerec.inc \ unxconst.inc $(UNIXINC)/timezone.inc $(SYSTEMUNIT)$(PPUEXT) \ unxfunc.inc + $(COMPILER) $(UNIXINC)/unix.pp + +syscall$(PPUEXT) : $(UNIXINC)/syscall.pp $(ARCH)/syscallh.inc $(ARCH)/sysnr.inc $(SYSTEMUNIT)$(PPUEXT) + $(COMPILER) $(UNIXINC)/syscall.pp + +unixutil$(PPUEXT) : $(UNIXINC)/unixutil.pp $(INC)/textrec.inc $(INC)/filerec.inc $(SYSTEMUNIT)$(PPUEXT) + $(COMPILER) $(UNIXINC)/unixutil.pp unixtype$(PPUEXT) : $(UNIXINC)/unixtype.pp ptypes.inc $(UNIXINC)/ctypes.inc $(SYSTEMUNIT)$(PPUEXT) $(COMPILER) $(UNIXINC)/unixtype.pp @@ -196,8 +203,10 @@ baseunix$(PPUEXT) : errno.inc ptypes.inc $(UNIXINC)/ctypes.inc \ bunxsysc.inc $(ARCH)/syscallh.inc $(ARCH)/sysnr.inc \ ostypes.inc osmacro.inc $(UNIXINC)/gensigset.inc \ $(UNIXINC)/genfuncs.inc $(SYSTEMUNIT)$(PPUEXT) + $(COMPILER) $(UNIXINC)/baseunix.pp -ports$(PPUEXT) : ports.pp unix$(PPUEXT) objpas$(PPUEXT) +ports$(PPUEXT) : $(UNIXINC)/ports.pp unix$(PPUEXT) objpas$(PPUEXT) + $(COMPILER) $(UNIXINC)/ports.pp dl$(PPUEXT) : $(UNIXINC)/dl.pp $(SYSTEMUNIT)$(PPUEXT) $(COMPILER) $(UNIXINC)/dl.pp @@ -303,6 +312,9 @@ endif mmx$(PPUEXT) : $(PROCINC)/mmx.pp cpu$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) $(COMPILER) $(PROCINC)/mmx.pp +x86$(PPUEXT) : $(UNIXINC)/x86.pp baseunix$(PPUEXT) syscall$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) + $(COMPILER) $(UNIXINC)/x86.pp + getopts$(PPUEXT) : $(INC)/getopts.pp $(SYSTEMUNIT)$(PPUEXT) $(COMPILER) $(INC)/getopts.pp diff --git a/mips/rtl/linux/errno-mips.inc b/mips/rtl/linux/errno-mips.inc new file mode 100644 index 0000000000..7d605ab465 --- /dev/null +++ b/mips/rtl/linux/errno-mips.inc @@ -0,0 +1,147 @@ +{ File generated by ../unix/scripts/check_errno.sh + generated on "Linux 2.6.27.1 mips64" machine +List of missing system error number found in +/usr/include/asm-generic/errno-base.h +/usr/include/asm/errno.h +/usr/include/bits/errno.h +/usr/include/bits/wordsize.h +/usr/include/errno.h +/usr/include/features.h +/usr/include/gnu/stubs.h +/usr/include/linux/errno.h +/usr/include/sys/cdefs.h +} + ESysEPERM = 1; { Operation not permitted } + ESysENOENT = 2; { No such file or directory } + ESysESRCH = 3; { No such process } + ESysEINTR = 4; { Interrupted system call } + ESysEIO = 5; { I/O error } + ESysENXIO = 6; { No such device or address } + ESysE2BIG = 7; { Argument list too long } + ESysENOEXEC = 8; { Exec format error } + ESysEBADF = 9; { Bad file number } + ESysECHILD = 10; { No child processes } + ESysEAGAIN = 11; { Try again } + ESysENOMEM = 12; { Out of memory } + ESysEACCES = 13; { Permission denied } + ESysEFAULT = 14; { Bad address } + ESysENOTBLK = 15; { Block device required } + ESysEBUSY = 16; { Device or resource busy } + ESysEEXIST = 17; { File exists } + ESysEXDEV = 18; { Cross-device link } + ESysENODEV = 19; { No such device } + ESysENOTDIR = 20; { Not a directory } + ESysEISDIR = 21; { Is a directory } + ESysEINVAL = 22; { Invalid argument } + ESysENFILE = 23; { File table overflow } + ESysEMFILE = 24; { Too many open files } + ESysENOTTY = 25; { Not a typewriter } + ESysETXTBSY = 26; { Text file busy } + ESysEFBIG = 27; { File too large } + ESysENOSPC = 28; { No space left on device } + ESysESPIPE = 29; { Illegal seek } + ESysEROFS = 30; { Read-only file system } + ESysEMLINK = 31; { Too many links } + ESysEPIPE = 32; { Broken pipe } + ESysEDOM = 33; { Math argument out of domain of func } + ESysERANGE = 34; { Math result not representable } + ESysENOMSG = 35; { No message of desired type } + ESysEIDRM = 36; { Identifier removed } + ESysECHRNG = 37; { Channel number out of range } + ESysEL2NSYNC = 38; { Level 2 not synchronized } + ESysEL3HLT = 39; { Level 3 halted } + ESysEL3RST = 40; { Level 3 reset } + ESysELNRNG = 41; { Link number out of range } + ESysEUNATCH = 42; { Protocol driver not attached } + ESysENOCSI = 43; { No CSI structure available } + ESysEL2HLT = 44; { Level 2 halted } + ESysEDEADLK = 45; { Resource deadlock would occur } + ESysENOLCK = 46; { No record locks available } + ESysEBADE = 50; { Invalid exchange } + ESysEBADR = 51; { Invalid request descriptor } + ESysEXFULL = 52; { Exchange full } + ESysENOANO = 53; { No anode } + ESysEBADRQC = 54; { Invalid request code } + ESysEBADSLT = 55; { Invalid slot } + ESysEDEADLOCK = 56; { File locking deadlock error } + ESysEBFONT = 59; { Bad font file format } + ESysENOSTR = 60; { Device not a stream } + ESysENODATA = 61; { No data available } + ESysETIME = 62; { Timer expired } + ESysENOSR = 63; { Out of streams resources } + ESysENONET = 64; { Machine is not on the network } + ESysENOPKG = 65; { Package not installed } + ESysEREMOTE = 66; { Object is remote } + ESysENOLINK = 67; { Link has been severed } + ESysEADV = 68; { Advertise error } + ESysESRMNT = 69; { Srmount error } + ESysECOMM = 70; { Communication error on send } + ESysEPROTO = 71; { Protocol error } + ESysEDOTDOT = 73; { RFS specific error } + ESysEMULTIHOP = 74; { Multihop attempted } + ESysEBADMSG = 77; { Not a data message } + ESysENAMETOOLONG = 78; { File name too long } + ESysEOVERFLOW = 79; { Value too large for defined data type } + ESysENOTUNIQ = 80; { Name not unique on network } + ESysEBADFD = 81; { File descriptor in bad state } + ESysEREMCHG = 82; { Remote address changed } + ESysELIBACC = 83; { Can not access a needed shared library } + ESysELIBBAD = 84; { Accessing a corrupted shared library } + ESysELIBSCN = 85; { .lib section in a.out corrupted } + ESysELIBMAX = 86; { Attempting to link in too many shared libraries } + ESysELIBEXEC = 87; { Cannot exec a shared library directly } + ESysEILSEQ = 88; { Illegal byte sequence } + ESysENOSYS = 89; { Function not implemented } + ESysELOOP = 90; { Too many symbolic links encountered } + ESysERESTART = 91; { Interrupted system call should be restarted } + ESysESTRPIPE = 92; { Streams pipe error } + ESysENOTEMPTY = 93; { Directory not empty } + ESysEUSERS = 94; { Too many users } + ESysENOTSOCK = 95; { Socket operation on non-socket } + ESysEDESTADDRREQ = 96; { Destination address required } + ESysEMSGSIZE = 97; { Message too long } + ESysEPROTOTYPE = 98; { Protocol wrong type for socket } + ESysENOPROTOOPT = 99; { Protocol not available } + ESysEPROTONOSUPPORT = 120; { Protocol not supported } + ESysESOCKTNOSUPPORT = 121; { Socket type not supported } + ESysEOPNOTSUPP = 122; { Operation not supported on transport endpoint } + ESysEPFNOSUPPORT = 123; { Protocol family not supported } + ESysEAFNOSUPPORT = 124; { Address family not supported by protocol } + ESysEADDRINUSE = 125; { Address already in use } + ESysEADDRNOTAVAIL = 126; { Cannot assign requested address } + ESysENETDOWN = 127; { Network is down } + ESysENETUNREACH = 128; { Network is unreachable } + ESysENETRESET = 129; { Network dropped connection because of reset } + ESysECONNABORTED = 130; { Software caused connection abort } + ESysECONNRESET = 131; { Connection reset by peer } + ESysENOBUFS = 132; { No buffer space available } + ESysEISCONN = 133; { Transport endpoint is already connected } + ESysENOTCONN = 134; { Transport endpoint is not connected } + ESysEUCLEAN = 135; { Structure needs cleaning } + ESysENOTNAM = 137; { Not a XENIX named type file } + ESysENAVAIL = 138; { No XENIX semaphores available } + ESysEISNAM = 139; { Is a named type file } + ESysEREMOTEIO = 140; { Remote I/O error } + ESysEINIT = 141; { Reserved } + ESysEREMDEV = 142; { Error 142 } + ESysESHUTDOWN = 143; { Cannot send after transport endpoint shutdown } + ESysETOOMANYREFS = 144; { Too many references: cannot splice } + ESysETIMEDOUT = 145; { Connection timed out } + ESysECONNREFUSED = 146; { Connection refused } + ESysEHOSTDOWN = 147; { Host is down } + ESysEHOSTUNREACH = 148; { No route to host } + ESysEWOULDBLOCK = EsysEAGAIN; { Operation would block } + ESysEALREADY = 149; { Operation already in progress } + ESysEINPROGRESS = 150; { Operation now in progress } + ESysESTALE = 151; { Stale NFS file handle } + ESysECANCELED = 158; { AIO operation canceled } + ESysENOMEDIUM = 159; { No medium found } + ESysEMEDIUMTYPE = 160; { Wrong medium type } + ESysENOKEY = 161; { Required key not available } + ESysEKEYEXPIRED = 162; { Key has expired } + ESysEKEYREVOKED = 163; { Key has been revoked } + ESysEKEYREJECTED = 164; { Key was rejected by service } + ESysEOWNERDEAD = 165; { Owner died } + ESysENOTRECOVERABLE = 166; { State not recoverable } + ESysERFKILL = 167; { Operation not possible due to RF-kill } + ESysEDQUOT = 1133; { Quota exceeded } diff --git a/mips/rtl/linux/errno.inc b/mips/rtl/linux/errno.inc index 21819b9dd4..f1ccf4b5b4 100644 --- a/mips/rtl/linux/errno.inc +++ b/mips/rtl/linux/errno.inc @@ -24,6 +24,11 @@ const {$i errno-sparc.inc} {$endif CPUSPARC} +{$ifdef CPUMIPS} +{$define FPC_HAS_ESYS} +{$i errno-mips.inc} +{$endif CPUMIPS} + {$ifndef FPC_HAS_ESYS} ESysEPERM = 1; { Operation not permitted } ESysENOENT = 2; { No such file or directory } diff --git a/mips/rtl/linux/mips/cprt0.as b/mips/rtl/linux/mips/cprt0.as index e69de29bb2..2d9902569f 100644 --- a/mips/rtl/linux/mips/cprt0.as +++ b/mips/rtl/linux/mips/cprt0.as @@ -0,0 +1,149 @@ +/* Startup code compliant to the ELF Mips ABI. + Copyright (C) 1995, 1997, 2000, 2001, 2002, 2003, 2004 + Free Software Foundation, Inc. + This file is part of the GNU C Library. + + The GNU C Library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + In addition to the permissions in the GNU Lesser General Public + License, the Free Software Foundation gives you unlimited + permission to link the compiled version of this file with other + programs, and to distribute those programs without any restriction + coming from the use of this file. (The GNU Lesser General Public + License restrictions do apply in other respects; for example, they + cover modification of the file, and distribution when not linked + into another program.) + + Note that people who make modified versions of this file are not + obligated to grant this special exception for their modified + versions; it is their choice whether to do so. The GNU Lesser + General Public License gives permission to release a modified + version without this exception; this exception also makes it + possible to release a modified version which carries forward this + exception. + + The GNU C Library 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. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with the GNU C Library; if not, write to the Free + Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA + 02111-1307 USA. */ + +/* This is the canonical entry point, usually the first thing in the text + segment. The SVR4/Mips ABI (pages 3-31, 3-32) says that when the entry + point runs, most registers' values are unspecified, except for: + + v0 ($2) Contains a function pointer to be registered with `atexit'. + This is how the dynamic linker arranges to have DT_FINI + functions called for shared libraries that have been loaded + before this code runs. + + sp ($29) The stack contains the arguments and environment: + 0(%esp) argc + 4(%esp) argv[0] + ... + (4*argc)(%esp) NULL + (4*(argc+1))(%esp) envp[0] + ... + NULL + ra ($31) The return address register is set to zero so that programs + that search backword through stack frames recognize the last + stack frame. +*/ + + +/* We need to call: + __libc_start_main (int (*main) (int, char **, char **), int argc, + char **argv, void (*init) (void), void (*fini) (void), + void (*rtld_fini) (void), void *stack_end) +*/ + .text + .globl __start + .type __start,@function +__start: +.globl _start + .type _start,@function +_start: + .ent _start + + + .set noreorder + move $0, $31 + bal 10f + nop + 10: + .cpload $31 + move $31, $0 + .set reorder + /* Setup GP correctly if we're non-PIC. */ + la $28,_gp + + la $4, main /* main */ + lw $5, 0($29) /* argc */ + addiu $6, $29, 4 /* argv */ + /* store argc */ + lw $t0,0($29) + lui $t1,%hi(operatingsystem_parameter_argc) + sw $t0,%lo(operatingsystem_parameter_argc)($t1) + + /* store argv */ + addiu $t1,$29,4 + lui $t2,%hi(operatingsystem_parameter_argv) + sw $t1,%lo(operatingsystem_parameter_argv)($t2) + + /* store envp */ + addiu $t2,$t0,1 + sll $t2,$t2,0x2 + addu $t2,$t2,$t1 + lui $t3,%hi(operatingsystem_parameter_envp) + sw $t2,%lo(operatingsystem_parameter_envp)($t3) + + /* Allocate space on the stack for seven arguments (o32 only) + and make sure the stack is aligned to double words (8 bytes) + on o32 and quad words (16 bytes) on n32 and n64. */ + and $29, -2 * 4 + subu $29, 32 + + lw $7,%got(__libc_csu_init)($gp) /* init */ + lw $8,%got(__libc_csu_fini)($gp) /* fini */ + + sw $8, 16($29) /* fini */ + sw $2, 20($29) /* rtld_fini */ + sw $29, 24($29) /* stack_end */ + + lw $t9,%got(__libc_start_main)($gp) + jalr $t9 + .end _start + .size _start, . - _start +/* Crash if somehow it does return. */ + .globl _haltproc + .ent _haltproc + .type _haltproc,@function +_haltproc: +hlt: + li $v0,4001 + syscall + b hlt + .end _haltproc + +/* Define a symbol for the first piece of initialized data. */ + .data + .globl __data_start +__data_start: + .long 0 + .weak data_start + data_start = __data_start + + .comm __stkptr,4 + .comm __dl_fini,4 + + .comm operatingsystem_parameter_envp,4 + .comm operatingsystem_parameter_argc,4 + .comm operatingsystem_parameter_argv,4 + diff --git a/mips/rtl/linux/mips/dllprt0.as b/mips/rtl/linux/mips/dllprt0.as index e69de29bb2..c6db79ac33 100644 --- a/mips/rtl/linux/mips/dllprt0.as +++ b/mips/rtl/linux/mips/dllprt0.as @@ -0,0 +1 @@ +.include "mips/prt0.as" diff --git a/mips/rtl/linux/mips/gprt0.as b/mips/rtl/linux/mips/gprt0.as index e69de29bb2..c6db79ac33 100644 --- a/mips/rtl/linux/mips/gprt0.as +++ b/mips/rtl/linux/mips/gprt0.as @@ -0,0 +1 @@ +.include "mips/prt0.as" diff --git a/mips/rtl/linux/mips/prt0.as b/mips/rtl/linux/mips/prt0.as index 88fc6e28c7..0bd2c63333 100644 --- a/mips/rtl/linux/mips/prt0.as +++ b/mips/rtl/linux/mips/prt0.as @@ -27,7 +27,7 @@ _dynamic_start: nop .end _dynamic_start - .size _dynamic_start, .-_start + .size _dynamic_start, .-_dynamic_start .align 4 .global _start @@ -54,6 +54,8 @@ _dynamic_start: _start: /* load fp */ move $s8,$sp + lui $at,%hi(__stkptr) + sw $s8,%lo(__stkptr)($at) /* align stack */ li $at,-8 @@ -82,8 +84,10 @@ _start: sll $a2,$a2,0x2 addu $a2,$a2,$a1 lui $a3,%hi(operatingsystem_parameter_envp) - jal PASCALMAIN sw $a2,%lo(operatingsystem_parameter_envp)($a3) + lui $t9,%hi(PASCALMAIN) + addiu $t9,$t9,%lo(PASCALMAIN) + jalr $t9 nop b _haltproc nop diff --git a/mips/rtl/linux/mips/sighnd.inc b/mips/rtl/linux/mips/sighnd.inc index ae71d813c4..2a782e21f1 100644 --- a/mips/rtl/linux/mips/sighnd.inc +++ b/mips/rtl/linux/mips/sighnd.inc @@ -15,10 +15,11 @@ **********************************************************************} -procedure SignalToRunerror(sig : longint; SigInfo: PSigInfo; SigContext: PSigContext);cdecl; +procedure SignalToRunerror(sig : longint; SigInfo: PSigInfo; UContext: PUContext);cdecl; var res : word; addr : pointer; + frame : pointer; begin res:=0; addr:=nil; @@ -27,11 +28,12 @@ begin begin addr := siginfo^._sifields._sigfault._addr; res := 207; + case siginfo^.si_code of FPE_INTDIV: res:=200; FPE_INTOVF: - res:=205; + res:=215; FPE_FLTDIV: res:=200; FPE_FLTOVF: @@ -57,5 +59,32 @@ begin reenable_signal(sig); { give runtime error at the position where the signal was raised } if res<>0 then - HandleErrorAddrFrame(res,addr,nil); + begin + if assigned(UContext) then + begin + frame:=pointer(ptruint(UContext^.uc_mcontext.sigc_regs[29])); { stack pointer } + addr:=pointer(ptruint(UContext^.uc_mcontext.sigc_pc)); { program counter } + if sig=SIGFPE then + begin + { Clear FPU exception bits } + UContext^.uc_mcontext.sigc_fpc_csr := UContext^.uc_mcontext.sigc_fpc_csr + and not (fpu_cause_mask or fpu_flags_mask); + end; + { Change $a1, $a2, $a3 and sig_pc to HandleErrorAddrFrame parameters } + UContext^.uc_mcontext.sigc_regs[4]:=res; + UContext^.uc_mcontext.sigc_regs[5]:=ptrint(addr); + UContext^.uc_mcontext.sigc_regs[6]:=ptrint(frame); + UContext^.uc_mcontext.sigc_pc:=ptrint(@HandleErrorAddrFrame); + { Let the system call HandleErrorAddrFrame } + exit; + end + else + begin + frame:=nil; + addr:=nil; + end; + if sig=SIGFPE then + set_fsr(get_fsr and not (fpu_cause_mask or fpu_flags_mask)); + HandleErrorAddrFrame(res,addr,frame); + end; end; diff --git a/mips/rtl/linux/mips/sighndh.inc b/mips/rtl/linux/mips/sighndh.inc index e3cfd870f3..ce4ffdee67 100644 --- a/mips/rtl/linux/mips/sighndh.inc +++ b/mips/rtl/linux/mips/sighndh.inc @@ -25,22 +25,72 @@ type ins : array[0..7] of longint; end; +(* MIPS OABI32 structure +struct sigcontext { + unsigned int sc_regmask; + unsigned int sc_status; + unsigned long long sc_pc; + unsigned long long sc_regs[32]; + unsigned long long sc_fpregs[32]; + unsigned int sc_ownedfp; + unsigned int sc_fpc_csr; + unsigned int sc_fpc_eir; + unsigned int sc_used_math; + unsigned int sc_dsp; + unsigned long long sc_mdhi; + unsigned long long sc_mdlo; + unsigned long sc_hi1; + unsigned long sc_lo1; + unsigned long sc_hi2; + unsigned long sc_lo2; + unsigned long sc_hi3; + unsigned long sc_lo3; +}; +typedef struct ucontext + { + unsigned long int uc_flags; + struct ucontext *uc_link; + stack_t uc_stack; + mcontext_t uc_mcontext; + __sigset_t uc_sigmask; + } ucontext_t; + + *) + FPReg = record + case byte of + 0 : (fp_dreg : double;); + 1 : (fp_reg : single; + fp_pad : cint; ); + end; + PSigContext = ^TSigContext; TSigContext = record - sigc_onstack, { state to restore } - sigc_mask, { sigmask to restore } - sigc_sp, { stack pointer } - sigc_pc, { program counter } - sigc_npc, { next program counter } - sigc_psr, { for condition codes etc } - sigc_g1, { User uses these two registers } - sigc_o0, { within the trampoline code. } - { Now comes information regarding the users window set - * at the time of the signal. } - sigc_oswins : longint; { outstanding windows } - { stack ptrs for each regwin buf } - sigc_spbuf : array[0..__SUNOS_MAXWIN-1] of pchar; - { Windows to restore after signal } - sigc_wbuf : array[0..__SUNOS_MAXWIN] of twbuf; + sigc_regmask, + sigc_status: cuint; + sigc_pc : culonglong; + sigc_regs : array[0..31] of culonglong; + sigc_fpregs : array[0..31] of fpreg; + sigc_fpc_csr, sigc_fpc_eir : cuint; + sigc_used_math : cuint; + sigc_dsp : cuint; + sigc_mdhi, sigc_mdlo : culonglong; + sigc_hi1,sigc_lo1, + sigc_hi2,sigc_lo2, + sigc_hi3,sigc_lo3 : culong; + end; + + TStack = record + ss_sp : pointer; + ss_size : size_t; + ss_flags : cint; + end; + + PUContext = ^TUContext; + TUContext = record + uc_flags : culong; + uc_link : PUContext; + uc_stack : TStack; + uc_mcontext : TSigContext; + uc_sigmask : TSigSet; end; diff --git a/mips/rtl/linux/mips/syscall.inc b/mips/rtl/linux/mips/syscall.inc index 677a20a93a..bc8c1bacce 100644 --- a/mips/rtl/linux/mips/syscall.inc +++ b/mips/rtl/linux/mips/syscall.inc @@ -47,7 +47,7 @@ asm addiu $4,$4,%lo(errno) jalr $8 nop - lw $8,-4($fp) + lw $8,temp sw $8,0($2) .LFailed: li $2,-1 @@ -225,7 +225,7 @@ asm move $a0,$a1 move $a1,$a2 move $a2,$a3 - lw $a3,16($fp) + lw $a3,param4 syscall nop beq $7,$0,.LDone @@ -266,10 +266,10 @@ asm move $a0,$a1 move $a1,$a2 move $a2,$a3 - lw $a3,16($fp) - lw $t0,20($fp) + lw $a3,param4 + lw $t0,param5 sw $t0,16($sp) - + syscall nop beq $7,$0,.LDone @@ -311,10 +311,10 @@ asm move $a0,$a1 move $a1,$a2 move $a2,$a3 - lw $a3,16($fp) - lw $t0,20($fp) + lw $a3,param4 + lw $t0,param5 sw $t0,16($sp) - lw $t0,24($fp) + lw $t0,param6 sw $t0,20($sp) syscall nop diff --git a/mips/rtl/linux/ossysc.inc b/mips/rtl/linux/ossysc.inc index f7040b7aa5..2ff2825b35 100644 --- a/mips/rtl/linux/ossysc.inc +++ b/mips/rtl/linux/ossysc.inc @@ -319,7 +319,14 @@ begin end; end; {$endif} - Fpsigaction:=do_syscall(syscall_nr_rt_sigaction,TSysParam(sig),TSysParam(new_action),TSysParam(old_action),TSysParam(8)); + Fpsigaction:=do_syscall(syscall_nr_rt_sigaction,TSysParam(sig), + TSysParam(new_action),TSysParam(old_action), + {$ifdef cpumips} + TSysParam(16{should be wordsinsigset}) + {$else not cpumips} + TSysParam(8) + {$endif not cpumips} + ); {$endif cpusparc} end; @@ -569,7 +576,14 @@ function FPSigProcMask(how:cint;nset : psigset;oset : psigset):cint; [public, al } begin - FPsigprocmask:=do_syscall(syscall_nr_rt_sigprocmask,TSysParam(how),TSysParam(nset),TSysParam(oset),TSysParam(8)); + FPsigprocmask:=do_syscall(syscall_nr_rt_sigprocmask,TSysParam(how), + TSysParam(nset),TSysParam(oset), +{$ifdef CPUMIPS} + TSysParam(16) +{$else not CPUMIPS} + TSysParam(8) +{$endif not CPUMIPS} + ); end; Function FpNanoSleep(req : ptimespec;rem : ptimespec):cint; [public, alias : 'FPC_SYSC_NANOSLEEP']; diff --git a/mips/rtl/linux/ostypes.inc b/mips/rtl/linux/ostypes.inc index a0bcfa919b..b29a618a72 100644 --- a/mips/rtl/linux/ostypes.inc +++ b/mips/rtl/linux/ostypes.inc @@ -245,7 +245,20 @@ CONST O_DIRECTORY = $10000; O_NOFOLLOW = $20000; O_DIRECT = $100000; -{$else cpusparc} +{$else : not cpusparc} +{$ifdef cpumips} + O_CREAT = $100; + O_EXCL = $400; + O_NOCTTY = $800; + O_TRUNC = $200; + O_APPEND = $8; + O_NONBLOCK = $80; + O_NDELAY = O_NONBLOCK; + O_SYNC = $10; + O_DIRECT = $8000; + O_DIRECTORY = $10000; + O_NOFOLLOW = $20000; +{$else : not cpumips} O_CREAT = $40; O_EXCL = $80; O_NOCTTY = $100; @@ -257,7 +270,8 @@ CONST O_DIRECT = $4000; O_DIRECTORY = $10000; O_NOFOLLOW = $20000; -{$endif cpusparc} +{$endif not cpumips} +{$endif not cpusparc} {$if defined(cpuarm) or defined(cpualpha) or defined(cpublackfin) or defined(cpum68k)} O_LARGEFILE = $20000; diff --git a/mips/rtl/linux/ptypes.inc b/mips/rtl/linux/ptypes.inc index a483ed5cf8..14e6c181b6 100644 --- a/mips/rtl/linux/ptypes.inc +++ b/mips/rtl/linux/ptypes.inc @@ -21,7 +21,7 @@ { Introduced defines - fs32bit, should be on if libc only supports sizeof(off_t)=4 - we assume one typically compiles C applications with + we assume one typically compiles C applications with #define _FILE_OFFSET_BITS 64 All three tested systems (PPC,Alpha,2x i386) gave the same POSIX limits, @@ -30,6 +30,33 @@ and all three 32-bit systems returned completely identical types too introduction) } +{$ifdef CPUMIPS} +{$define USE_PTHREAD_SIZEOF} +{$ifdef CPU64} +const + __SIZEOF_PTHREAD_ATTR_T = 56; + __SIZEOF_PTHREAD_MUTEX_T = 40; + __SIZEOF_PTHREAD_MUTEXATTR_T = 4; + __SIZEOF_PTHREAD_COND_T = 48; + __SIZEOF_PTHREAD_CONDATTR_T = 4; + __SIZEOF_PTHREAD_RWLOCK_T = 56; + __SIZEOF_PTHREAD_RWLOCKATTR_T = 8; + __SIZEOF_PTHREAD_BARRIER_T = 32; + __SIZEOF_PTHREAD_BARRIERATTR_T = 4; +{$else : not CPU64, i.e. CPU32} +const + __SIZEOF_PTHREAD_ATTR_T = 36; + __SIZEOF_PTHREAD_MUTEX_T = 24; + __SIZEOF_PTHREAD_MUTEXATTR_T = 4; + __SIZEOF_PTHREAD_COND_T = 48; + __SIZEOF_PTHREAD_CONDATTR_T = 4; + __SIZEOF_PTHREAD_RWLOCK_T = 32; + __SIZEOF_PTHREAD_RWLOCKATTR_T = 8; + __SIZEOF_PTHREAD_BARRIER_T = 20; + __SIZEOF_PTHREAD_BARRIERATTR_T = 4; +{$endif CPU32} +{$endif MIPS} + {$I ctypes.inc} {$packrecords c} @@ -119,7 +146,7 @@ Type pUid = ^uid_t; TGid = gid_t; pGid = ^gid_t; - + TIOCtlRequest = cInt; @@ -177,7 +204,7 @@ Type 0: (__wch: wint_t); 1: (__wchb: array[0..3] of char); end; - + mbstate_t = record __count: cint; __value: mbstate_value_t; @@ -190,7 +217,26 @@ Type __sched_priority: cint; end; + { MIPS32 size of unions + __SIZEOF_PTHREAD_ATTR_T = 36; + __SIZEOF_PTHREAD_MUTEX_T = 24; + __SIZEOF_PTHREAD_MUTEXATTR_T = 4; + __SIZEOF_PTHREAD_COND_T = 48; + __SIZEOF_PTHREAD_CONDATTR_T = 4; + __SIZEOF_PTHREAD_RWLOCK_T = 32; + __SIZEOF_PTHREAD_RWLOCKATTR_T = 8; + __SIZEOF_PTHREAD_BARRIER_T = 20; + __SIZEOF_PTHREAD_BARRIERATTR_T = 4; } + pthread_attr_t = record + {$ifdef USE_PTHREAD_SIZEOF} + case byte of + 0 : ( + __size : array[0..__SIZEOF_PTHREAD_ATTR_T-1] of char; + __align : clong; + ); + 1 : ( + {$endif} __detachstate: cint; __schedpolicy: cint; __schedparam: sched_param; @@ -200,6 +246,9 @@ Type __stackaddr_set: cint; __stackaddr: pointer; __stacksize: size_t; + {$ifdef USE_PTHREAD_SIZEOF} + ); + {$endif} end; _pthread_fastlock = record @@ -208,26 +257,70 @@ Type end; pthread_mutex_t = record + {$ifdef USE_PTHREAD_SIZEOF} + case byte of + 0 : ( + __size : array[0..__SIZEOF_PTHREAD_MUTEX_T-1] of char; + __align : clong; + ); + 1 : ( + {$endif} __m_reserved: cint; __m_count: cint; __m_owner: pointer; __m_kind: cint; __m_lock: _pthread_fastlock; + {$ifdef USE_PTHREAD_SIZEOF} + ); + {$endif} end; pthread_mutexattr_t = record + {$ifdef USE_PTHREAD_SIZEOF} + case byte of + 0 : ( + __size : array[0..__SIZEOF_PTHREAD_MUTEXATTR_T-1] of char; + __align : clong; + ); + 1 : ( + {$endif} __mutexkind: cint; + {$ifdef USE_PTHREAD_SIZEOF} + ); + {$endif} end; pthread_cond_t = record + {$ifdef USE_PTHREAD_SIZEOF} + case byte of + 0 : ( + __size : array[0..__SIZEOF_PTHREAD_COND_T-1] of char; + ___align : clong; + ); + 1 : ( + {$endif} __c_lock: _pthread_fastlock; __c_waiting: pointer; __padding: array[0..48-1-sizeof(_pthread_fastlock)-sizeof(pointer)-sizeof(clonglong)] of byte; __align: clonglong; + {$ifdef USE_PTHREAD_SIZEOF} + ); + {$endif} end; pthread_condattr_t = record + {$ifdef USE_PTHREAD_SIZEOF} + case byte of + 0 : ( + __size : array[0..__SIZEOF_PTHREAD_CONDATTR_T-1] of char; + __align : clong; + ); + 1 : ( + {$endif} __dummy: cint; + {$ifdef USE_PTHREAD_SIZEOF} + ); + {$endif} end; pthread_key_t = cuint; @@ -235,16 +328,38 @@ Type const pthreadrwlocksize = {$ifdef CPU64} 56{$else}32{$endif}; -type +type pthread_rwlock_t = record // should be 56 for 64-bit, 32 bytes for 32-bit mantis #21552 - case boolean of - false : (_data : array[0..pthreadrwlocksize-1] of char); - true : (align : clong); + {$ifdef USE_PTHREAD_SIZEOF} + case byte of + 0 : ( + __size : array[0..__SIZEOF_PTHREAD_RWLOCK_T-1] of char; + __align : clong; + ); + 1 : ( + {$endif} + case boolean of + false : (_data : array[0..pthreadrwlocksize-1] of char); + true : (align : clong); + {$ifdef USE_PTHREAD_SIZEOF} + ); + {$endif} end; pthread_rwlockattr_t = record + {$ifdef USE_PTHREAD_SIZEOF} + case byte of + 0 : ( + __size : array[0..__SIZEOF_PTHREAD_RWLOCKATTR_T-1] of char; + __align : clong; + ); + 1 : ( + {$endif} __lockkind: cint; __pshared: cint; + {$ifdef USE_PTHREAD_SIZEOF} + ); + {$endif} end; sem_t = record @@ -278,7 +393,11 @@ CONST {$ifdef FPC_USE_LIBC} SIG_MAXSIG = 1024; // highest signal version {$else} + {$ifdef cpumips} + SIG_MAXSIG = 1024; // highest signal version + {$else not cupmips} SIG_MAXSIG = 128; // highest signal version + {$endif not cpumips} {$endif} { For getting/setting priority } diff --git a/mips/rtl/linux/signal.inc b/mips/rtl/linux/signal.inc index f4d92a6ce3..dbd4f3d7da 100644 --- a/mips/rtl/linux/signal.inc +++ b/mips/rtl/linux/signal.inc @@ -28,14 +28,20 @@ Const SIG_UNBLOCK = 2; SIG_SETMASK = 4; {$else CPUSPARC} -{$if defined(cpumips) or defined(cpumipsel)} +{$ifdef CPUMIPS} SA_NOCLDSTOP = 1; SA_NOCLDWAIT = $10000; SA_SIGINFO = 8; + SIG_BLOCK = 1; + SIG_UNBLOCK = 2; + SIG_SETMASK = 3; {$else CPUMIPS} SA_NOCLDSTOP = 1; SA_NOCLDWAIT = 2; SA_SIGINFO = 4; + SIG_BLOCK = 0; + SIG_UNBLOCK = 1; + SIG_SETMASK = 2; {$endif CPUMIPS} SA_RESTORER = $04000000; SA_ONSTACK = $08000000; @@ -47,16 +53,13 @@ Const SA_NOMASK = SA_NODEFER; SA_ONESHOT = SA_RESETHAND; - SIG_BLOCK = 0; - SIG_UNBLOCK = 1; - SIG_SETMASK = 2; {$endif CPUSPARC} SIG_DFL = 0 ; SIG_IGN = 1 ; SIG_ERR = -1 ; -{$ifdef cpusparc} +{$ifdef CPUSPARC} SIGHUP = 1; SIGINT = 2; SIGQUIT = 3; @@ -99,15 +102,37 @@ Const SIGTRAP = 5; SIGABRT = 6; SIGIOT = 6; - SIGBUS = 7; SIGFPE = 8; SIGKILL = 9; - SIGUSR1 = 10; SIGSEGV = 11; - SIGUSR2 = 12; SIGPIPE = 13; SIGALRM = 14; - SIGTerm = 15; + SIGTERM = 15; +{$ifdef CPUMIPS} + SIGEMT = 7; + SIGBUS = 10; + SIGSYS = 12; + SIGUSR1 = 16; + SIGUSR2 = 17; + SIGCHLD = 18; + SIGPWR = 19; + SIGWINCH = 20; + SIGURG = 21; + SIGIO = 22; + SIGPOLL = 22; + SIGSTOP = 23; + SIGTSTP = 24; + SIGCONT = 25; + SIGTTIN = 26; + SIGTTOU = 27; + SIGVTALRM = 28; + SIGPROF = 29; + SIGXCPU = 30; + SIGXFSZ = 31; +{$else not CPUMIPS} + SIGBUS = 7; + SIGUSR1 = 10; + SIGUSR2 = 12; SIGSTKFLT = 16; SIGCHLD = 17; SIGCONT = 18; @@ -125,6 +150,7 @@ Const SIGPOLL = SIGIO; SIGPWR = 30; SIGUNUSED = 31; +{$endif not CPUMIPS} {$endif cpusparc} { si_code field values for tsiginfo.si_code when si_signo = SIGFPE } @@ -150,8 +176,13 @@ type psiginfo = ^tsiginfo; tsiginfo = record si_signo : longint; +{$ifdef CPUMIPS} + si_code : longint; + si_errno : longint; +{$else not CPUMIPS} si_errno : longint; si_code : longint; +{$endif not CPUMIPS} _sifields : record case longint of 0 : ( _pad : array[0..(SI_PAD_SIZE)-1] of longint ); @@ -210,10 +241,20 @@ type sa_restorer: sigrestorerhandler_t; end; {$else} + {$ifdef cpumips} + sigactionrec = record + sa_flags: cuint; + sa_handler: sigactionhandler_t; + sa_mask: sigset_t; + sa_restorer: sigrestorerhandler_t; { Doesn't seem to exist on MIPS } + sa_resv : array [0..0] of cint; + end; + {$else not mips} sigactionrec = record sa_handler: sigactionhandler_t; sa_flags: culong; sa_restorer: sigrestorerhandler_t; sa_mask: sigset_t; end; + {$endif not mips} {$endif} diff --git a/mips/rtl/linux/sparc/sighnd.inc b/mips/rtl/linux/sparc/sighnd.inc index cfbfc35149..5182920cfe 100644 --- a/mips/rtl/linux/sparc/sighnd.inc +++ b/mips/rtl/linux/sparc/sighnd.inc @@ -30,7 +30,7 @@ begin FPE_INTDIV: res:=200; FPE_INTOVF: - res:=205; + res:=215; FPE_FLTDIV: res:=200; FPE_FLTOVF: diff --git a/mips/rtl/linux/unxsockh.inc b/mips/rtl/linux/unxsockh.inc index d85ad09b4c..ccbad9a18d 100644 --- a/mips/rtl/linux/unxsockh.inc +++ b/mips/rtl/linux/unxsockh.inc @@ -170,10 +170,10 @@ Const IPPROTO_RAW = 255; { Raw IP packets. } IPPROTO_MAX = 255; //from /usr/include/bits/in.h -{{ Options for use with etsockopt' and etsockopt' at the IP level. +{ Options for use with getsockopt' and setsockopt' at the IP level. The first word in the comment at the right is the data type used; - "bool" means a boolean value stored in an nt'. } -} + "bool" means a boolean value stored in an int'. } + IP_OPTIONS = 4; { ip_opts; IP per-packet options. } IP_HDRINCL = 3; { int; Header is included with data. } IP_TOS = 1; { int; IP type of service and precedence. } @@ -227,9 +227,9 @@ Const IP_MAX_MEMBERSHIPS = 20; -{ Options for use with etsockopt' and etsockopt' at the IPv6 level. +{ Options for use with getsockopt' and setsockopt' at the IPv6 level. The first word in the comment at the right is the data type used; - "bool" means a boolean value stored in an nt'. } + "bool" means a boolean value stored in an int'. } IPV6_ADDRFORM = 1; IPV6_PKTINFO = 2; IPV6_HOPOPTS = 3; diff --git a/mips/rtl/linux/x86_64/dllprt0.as b/mips/rtl/linux/x86_64/dllprt0.as index 477da7785b..c86bbfd0c6 100644 --- a/mips/rtl/linux/x86_64/dllprt0.as +++ b/mips/rtl/linux/x86_64/dllprt0.as @@ -41,8 +41,8 @@ FPC_SHARED_LIB_START: jmp _startlib@PLT .text - .globl _start - .type _start,@function + .globl _startlib + .type _startlib,@function _startlib: pushq %rbx movq operatingsystem_parameter_argc@GOTPCREL(%rip),%rbx diff --git a/mips/rtl/m68k/m68k.inc b/mips/rtl/m68k/m68k.inc index 56636eacc0..d007587ab5 100644 --- a/mips/rtl/m68k/m68k.inc +++ b/mips/rtl/m68k/m68k.inc @@ -41,7 +41,7 @@ function get_frame : pointer; assembler; {$define FPC_SYSTEM_HAS_GET_CALLER_ADDR} -function get_caller_addr(framebp : pointer) : pointer; +function get_caller_addr(framebp : pointer;addr:pointer=nil) : pointer; begin asm move.l framebp,a0 @@ -55,7 +55,7 @@ function get_caller_addr(framebp : pointer) : pointer; {$define FPC_SYSTEM_HAS_GET_CALLER_FRAME} -function get_caller_frame(framebp : pointer) : pointer; +function get_caller_frame(framebp : pointer;addr:pointer=nil) : pointer; begin asm move.l FRAMEBP,a0 diff --git a/mips/rtl/mips/mathu.inc b/mips/rtl/mips/mathu.inc index 9f3ffff15a..8b3063dfa6 100644 --- a/mips/rtl/mips/mathu.inc +++ b/mips/rtl/mips/mathu.inc @@ -13,8 +13,29 @@ **********************************************************************} { exported by the system unit } -//!!!function get_fsr : dword;external name 'FPC_GETFSR'; -//!!!procedure set_fsr(fsr : dword);external name 'FPC_SETFSR'; +function get_fsr : dword;external name 'FPC_GETFSR'; +procedure set_fsr(fsr : dword);external name 'FPC_SETFSR'; + +const + { FPU enable exception bits for FCSR register } + fpu_enable_inexact = $80; + fpu_enable_underflow = $100; + fpu_enable_overflow = $200; + fpu_enable_div_zero = $400; + fpu_enable_invalid = $800; + fpu_enable_mask = $F80; + default_fpu_enable = fpu_enable_div_zero or fpu_enable_invalid; + + fpu_flags_mask = $7C; + fpu_cause_mask = $3F000; + + { FPU rounding mask and values } + fpu_rounding_mask = $3; + fpu_rounding_nearest = 0; + fpu_rounding_towards_zero = 1; + fpu_rounding_plus_inf = 2; + fpu_rounding_minus_inf = 3; + function FPUExceptionMaskToSoftFloatMask(const Mask: TFPUExceptionMask): byte; begin @@ -35,22 +56,37 @@ end; function GetRoundMode: TFPURoundingMode; begin -//!!! result:=TFPURoundingMode(get_fsr shr 30); + result:=TFPURoundingMode(get_fsr and 3); end; function SetRoundMode(const RoundMode: TFPURoundingMode): TFPURoundingMode; + var + fpu_round : longint; begin + case (RoundMode) of rmNearest : - softfloat_rounding_mode := float_round_nearest_even; + begin + softfloat_rounding_mode := float_round_nearest_even; + fpu_round:=fpu_rounding_nearest; + end; rmTruncate : - softfloat_rounding_mode := float_round_to_zero; - rmUp : - softfloat_rounding_mode := float_round_up; - rmDown : - softfloat_rounding_mode := float_round_down; - end; -//!!! set_fsr((get_fsr and $3fffffff) or (dword(RoundMode) shl 30)); + begin + softfloat_rounding_mode := float_round_to_zero; + fpu_round:=fpu_rounding_towards_zero; + end; + rmUp : + begin + softfloat_rounding_mode := float_round_up; + fpu_round:=fpu_rounding_plus_inf; + end; + rmDown : + begin + softfloat_rounding_mode := float_round_down; + fpu_round:=fpu_rounding_minus_inf; + end; + end; + set_fsr((get_fsr and not fpu_rounding_mask) or fpu_round); //!!! result:=TFPURoundingMode(get_fsr shr 30); end; @@ -71,26 +107,26 @@ function GetExceptionMask: TFPUExceptionMask; var fsr : dword; begin -//!!! fsr:=get_fsr; + fsr:=get_fsr; result:=[]; - { invalid operation: bit 27 } - if (fsr and (1 shl 27))=0 then + { invalid operation } + if (fsr and fpu_enable_invalid)=0 then include(result,exInvalidOp); - { zero divide: bit 24 } - if (fsr and (1 shl 24))=0 then - include(result,exInvalidOp); + { zero divide } + if (fsr and fpu_enable_div_zero)=0 then + include(result,exZeroDivide); - { overflow: bit 26 } - if (fsr and (1 shl 26))=0 then - include(result,exInvalidOp); + { overflow } + if (fsr and fpu_enable_overflow)=0 then + include(result,exOverflow); - { underflow: bit 25 } - if (fsr and (1 shl 25))=0 then + { underflow: } + if (fsr and fpu_enable_underflow)=0 then include(result,exUnderflow); - { Precision (inexact result): bit 23 } - if (fsr and (1 shl 23))=0 then + { Precision (inexact result) } + if (fsr and fpu_enable_inexact)=0 then include(result,exPrecision); end; @@ -100,40 +136,43 @@ function SetExceptionMask(const Mask: TFPUExceptionMask): TFPUExceptionMask; var fsr : dword; begin -//!!! fsr:=get_fsr; + fsr:=get_fsr; - { invalid operation: bit 27 } + { invalid operation } if (exInvalidOp in mask) then - fsr:=fsr and not(1 shl 27) + fsr:=fsr and not(fpu_enable_invalid) else - fsr:=fsr or (1 shl 27); + fsr:=fsr or (fpu_enable_invalid); - { zero divide: bit 24 } + { zero divide } if (exZeroDivide in mask) then - fsr:=fsr and not(1 shl 24) + fsr:=fsr and not(fpu_enable_div_zero) else - fsr:=fsr or (1 shl 24); + fsr:=fsr or (fpu_enable_div_zero); - { overflow: bit 26 } + { overflow } if (exOverflow in mask) then - fsr:=fsr and not(1 shl 26) + fsr:=fsr and not(fpu_enable_overflow) else - fsr:=fsr or (1 shl 26); + fsr:=fsr or (fpu_enable_overflow); - { underflow: bit 25 } + { underflow } if (exUnderflow in mask) then - fsr:=fsr and not(1 shl 25) + fsr:=fsr and not(fpu_enable_underflow) else - fsr:=fsr or (1 shl 25); + fsr:=fsr or (fpu_enable_underflow); - { Precision (inexact result): bit 23 } + { Precision (inexact result) } if (exPrecision in mask) then - fsr:=fsr and not(1 shl 23) + fsr:=fsr and not(fpu_enable_inexact) else - fsr:=fsr or (1 shl 23); + fsr:=fsr or (fpu_enable_inexact); + + { Reset flags and cause } + fsr := fsr and not (fpu_flags_mask or fpu_cause_mask); { update control register contents } -//!!! set_fsr(fsr); + set_fsr(fsr); softfloat_exception_mask:=FPUExceptionMaskToSoftFloatMask(mask); end; @@ -141,6 +180,6 @@ function SetExceptionMask(const Mask: TFPUExceptionMask): TFPUExceptionMask; procedure ClearExceptions(RaisePending: Boolean =true); begin -//!!! set_fsr(get_fsr and $fffffc1f); + set_fsr(get_fsr and not (fpu_flags_mask or fpu_cause_mask)); end; diff --git a/mips/rtl/mips/mips.inc b/mips/rtl/mips/mips.inc index 22c0ba4dc6..f0d839c164 100644 --- a/mips/rtl/mips/mips.inc +++ b/mips/rtl/mips/mips.inc @@ -37,6 +37,26 @@ function get_got_z : pointer;assembler;nostackframe;[public, alias: 'FPC_GETGOT_ move $2,$28 end; +const + { FPU enable exception bits for FCSR register } + fpu_enable_inexact = $80; + fpu_enable_underflow = $100; + fpu_enable_overflow = $200; + fpu_enable_div_zero = $400; + fpu_enable_invalid = $800; + fpu_enable_mask = $F80; + default_fpu_enable = fpu_enable_div_zero or fpu_enable_invalid; + + fpu_flags_mask = $7C; + fpu_cause_mask = $3F000; + + { FPU rounding mask and values } + fpu_rounding_mask = $3; + fpu_rounding_nearest = 0; + fpu_rounding_towards_zero = 1; + fpu_rounding_plus_inf = 2; + fpu_rounding_minus_inf = 3; + procedure fpc_cpuinit; var @@ -45,11 +65,17 @@ var { don't let libraries influence the FPU cw set by the host program } if not IsLibrary then begin - { enable div by 0 and invalid operation fpu exceptions } + tmp32 := get_fsr(); + { enable div by 0 and invalid operation fpu exceptions, + disable the other exceptions } + tmp32 := (tmp32 and not fpu_enable_mask) or default_fpu_enable; + { Reset flags and cause } + tmp32 := tmp32 and not (fpu_flags_mask or fpu_cause_mask); + { round towards nearest; ieee compliant arithmetics } + tmp32 := (tmp32 and not fpu_rounding_mask) or fpu_rounding_nearest; - tmp32 := get_fsr(); - set_fsr(tmp32 and $fffffffc); + set_fsr(tmp32); end; end; @@ -70,25 +96,105 @@ function get_frame:pointer;assembler;nostackframe; Further, we need to know the pc } // lw $2,0($sp) - lui $2,0 + move $2,$30 end; -{$define FPC_SYSTEM_HAS_GET_CALLER_ADDR} -function get_caller_addr(framebp:pointer):pointer;assembler;nostackframe; - asm - // lw $2,4($4) // #movl 4(%eax),%eax - lui $2,0 +{ Try to find previous $fp,$ra register pair + reset both to nil if failure } +{$define FPC_SYSTEM_HAS_GET_CALLER_STACKINFO} +procedure get_caller_stackinfo(var framebp,addr : pointer); +const + instr_size = 4; + MAX_INSTRUCTIONS = 64000; +type + instr_p = pdword; + reg_p = ppointer; +var + instr,stackpos : dword; + i,LocalSize : longint; + ra_offset, s8_offset : longint; + current_ra : pointer; +begin + { Here we need to use GDB approach, + starting at addr + go back to lower $ra values until we find a + position with ADDIU $sp,$sp,-LocalSize + } + if addr=nil then + begin + framebp:=nil; + exit; + end; + Try + current_ra:=addr; + ra_offset:=-1; + s8_offset:=-1; + i:=0; + LocalSize:=0; + repeat + inc(i); + dec(current_ra,4); + instr:=instr_p(current_ra)^; + if (instr shr 16 = $27bd) then + begin + { we found the instruction, + local size is the lo part } + LocalSize:=smallint(instr and $ffff); + break; + end; + until i> MAX_INSTRUCTIONS; + if LocalSize <> 0 then + begin + repeat + inc(current_ra,4); + instr:=instr_p(current_ra)^; + if (instr shr 16 = $afbf) then + ra_offset:=smallint(instr and $ffff) + else if (instr shr 16 = $afbe) then + s8_offset:=smallint(instr and $ffff); + until (current_ra >= addr) + or ((ra_offset<>-1) and (s8_offset<>-1)); + if ra_offset<>-1 then + begin + stackpos:=dword(framebp+LocalSize+ra_offset); + addr:=reg_p(stackpos)^; + end + else + addr:=nil; + if s8_offset<>-1 then + begin + stackpos:=dword(framebp+LocalSize+s8_offset); + framebp:=reg_p(stackpos)^; + end + else + framebp:=nil; + end; + Except + framebp:=nil; + addr:=nil; end; +end; +{$define FPC_SYSTEM_HAS_GET_PC_ADDR} +function get_pc_addr : pointer;assembler;nostackframe; +asm + move $2,$31 +end; -{$define FPC_SYSTEM_HAS_GET_CALLER_FRAME} -function get_caller_frame(framebp:pointer):pointer;assembler;nostackframe; - asm - // lw $2,0($4) // #movl (%eax),%eax - lui $2,0 - end; +{$define FPC_SYSTEM_HAS_GET_CALLER_ADDR} +function get_caller_addr(framebp:pointer;addr:pointer=nil):pointer; +begin + get_caller_stackinfo(framebp,addr); + get_caller_addr:=addr; +end; +{$define FPC_SYSTEM_HAS_GET_CALLER_FRAME} +function get_caller_frame(framebp:pointer;addr:pointer=nil):pointer; +begin + get_caller_stackinfo(framebp,addr); + get_caller_frame:=framebp; +end; {$define FPC_SYSTEM_HAS_SPTR} function Sptr:Pointer;assembler;nostackframe; diff --git a/mips/rtl/objpas/fgl.pp b/mips/rtl/objpas/fgl.pp index 1418c1cbb7..0b6670334f 100644 --- a/mips/rtl/objpas/fgl.pp +++ b/mips/rtl/objpas/fgl.pp @@ -1164,7 +1164,7 @@ end; function TFPSMap.BinaryCompareData(Data1, Data2: Pointer): Integer; begin - Result := CompareByte(Data1^, Data1^, FDataSize); + Result := CompareByte(Data1^, Data2^, FDataSize); end; procedure TFPSMap.SetOnKeyPtrCompare(Proc: TFPSListCompareFunc); diff --git a/mips/rtl/objpas/strutils.pp b/mips/rtl/objpas/strutils.pp index 8290314cb6..aef57f043e 100644 --- a/mips/rtl/objpas/strutils.pp +++ b/mips/rtl/objpas/strutils.pp @@ -97,6 +97,13 @@ Function PosEx(c:char; const S: string; Offset: Cardinal): Integer; function StringsReplace(const S: string; OldPattern, NewPattern: array of string; Flags: TReplaceFlags): string; { --------------------------------------------------------------------- + Delphi compat + ---------------------------------------------------------------------} + +Function ReplaceStr(const AText, AFromText, AToText: string): string;inline; +Function ReplaceText(const AText, AFromText, AToText: string): string;inline; + +{ --------------------------------------------------------------------- Soundex Functions. ---------------------------------------------------------------------} @@ -745,6 +752,20 @@ begin end; { --------------------------------------------------------------------- + Delphi compat + ---------------------------------------------------------------------} + +Function ReplaceStr(const AText, AFromText, AToText: string): string;inline; +begin + AnsiReplaceStr(AText, AFromText, AToText); +end; + +Function ReplaceText(const AText, AFromText, AToText: string): string;inline; +begin + AnsiReplaceText(AText, AFromText, AToText); +end; + +{ --------------------------------------------------------------------- Soundex Functions. ---------------------------------------------------------------------} Const diff --git a/mips/rtl/openbsd/errno.inc b/mips/rtl/openbsd/errno.inc index b5013276da..2f41d87ce2 100644 --- a/mips/rtl/openbsd/errno.inc +++ b/mips/rtl/openbsd/errno.inc @@ -78,7 +78,6 @@ Const ESysEPROTONOSUPPORT = 43; { Protocol not supported } ESysESOCKTNOSUPPORT = 44; { Socket type not supported } ESysEOPNOTSUPP = 45; { Operation not supported } - ESysENOTSUP = ESysEOPNOTSUPP; { Operation not supported } ESysEPFNOSUPPORT = 46; { Protocol family not supported } ESysEAFNOSUPPORT = 47; { Address family not supported by protocol family } ESysEADDRINUSE = 48; { Address already in use } @@ -126,12 +125,15 @@ Const ESysEFTYPE = 79; { Inappropriate file type or format } ESysEAUTH = 80; { Authentication error } ESysENEEDAUTH = 81; { Need authenticator } - ESysEIDRM = 82; { Identifier removed } - ESysENOMSG = 83; { No message of desired type } - ESysEOVERFLOW = 84; { Value too large to be stored in data type } - ESysECANCELED = 85; { Operation canceled } - ESysEILSEQ = 86; { Illegal byte sequence } - ESysELAST = 86; { Must be equal largest errno } - - + ESysEIPSEC = 82; { IPsec processing failure } + ESysENOATTR = 83; { Attribute not found } + ESysEILSEQ = 84; { Illegal byte sequence } + ESysENOMEDIUM = 85; { No medium found } + ESysEMEDIUMTYPE = 86; { Wrong Medium Type } + ESysEOVERFLOW = 87; { Value too large to be stored in data type } + ESysECANCELED = 88; { Operation canceled } + ESysEIDRM = 89; { Identifier removed } + ESysENOMSG = 90; { No message of desired type } + ESysENOTSUP = 91; { Not supported } + ESysELAST = ESysENOTSUP; { Must be equal largest errno } diff --git a/mips/rtl/powerpc/powerpc.inc b/mips/rtl/powerpc/powerpc.inc index 7a8645e007..278d53df68 100644 --- a/mips/rtl/powerpc/powerpc.inc +++ b/mips/rtl/powerpc/powerpc.inc @@ -1024,7 +1024,7 @@ indicated by the first bit set to 1. This is checked below.} {Both routines below assumes that framebp is a valid framepointer or nil.} {$define FPC_SYSTEM_HAS_GET_CALLER_ADDR} -function get_caller_addr(framebp:pointer):pointer;assembler;{$ifdef SYSTEMINLINE}inline;{$endif} nostackframe; +function get_caller_addr(framebp:pointer;addr:pointer=nil):pointer;assembler;{$ifdef SYSTEMINLINE}inline;{$endif} nostackframe; asm cmplwi r3,0 beq .Lcaller_addr_invalid @@ -1048,7 +1048,7 @@ end; {$define FPC_SYSTEM_HAS_GET_CALLER_FRAME} -function get_caller_frame(framebp:pointer):pointer;assembler;{$ifdef SYSTEMINLINE}inline;{$endif} nostackframe; +function get_caller_frame(framebp:pointer;addr:pointer=nil):pointer;assembler;{$ifdef SYSTEMINLINE}inline;{$endif} nostackframe; asm cmplwi r3,0 beq .Lcaller_frame_invalid diff --git a/mips/rtl/powerpc64/powerpc64.inc b/mips/rtl/powerpc64/powerpc64.inc index f613bb7ddb..53dc54f7b1 100644 --- a/mips/rtl/powerpc64/powerpc64.inc +++ b/mips/rtl/powerpc64/powerpc64.inc @@ -520,7 +520,7 @@ asm end; {$define FPC_SYSTEM_HAS_GET_CALLER_ADDR} -function get_caller_addr(framebp:pointer):pointer;assembler;{$ifdef SYSTEMINLINE}inline;{$endif} nostackframe; +function get_caller_addr(framebp:pointer;addr:pointer=nil):pointer;assembler;{$ifdef SYSTEMINLINE}inline;{$endif} nostackframe; asm cmpldi r3,0 beq .Lcaller_addr_frame_null @@ -534,7 +534,7 @@ end; {$define FPC_SYSTEM_HAS_GET_CALLER_FRAME} -function get_caller_frame(framebp:pointer):pointer;assembler;{$ifdef SYSTEMINLINE}inline;{$endif} nostackframe; +function get_caller_frame(framebp:pointer;addr:pointer=nil):pointer;assembler;{$ifdef SYSTEMINLINE}inline;{$endif} nostackframe; asm cmpldi r3,0 beq .Lcaller_frame_null diff --git a/mips/rtl/sparc/sparc.inc b/mips/rtl/sparc/sparc.inc index a4b30eb84d..d773161802 100644 --- a/mips/rtl/sparc/sparc.inc +++ b/mips/rtl/sparc/sparc.inc @@ -53,7 +53,7 @@ Procedure SysInitFPU;{$ifdef SYSTEMINLINE}inline;{$endif} round towards zero; ieee compliant arithmetics } set_fsr((get_fsr and $3fbfffff) or $09000000); end; - + {$define FPC_SYSTEM_HAS_SYSRESETFPU} Procedure SysResetFPU;{$ifdef SYSTEMINLINE}inline;{$endif} begin @@ -77,7 +77,7 @@ function get_frame:pointer;assembler;nostackframe; {$define FPC_SYSTEM_HAS_GET_CALLER_ADDR} -function get_caller_addr(framebp:pointer):pointer;assembler;nostackframe; +function get_caller_addr(framebp:pointer;addr:pointer=nil):pointer;assembler;nostackframe; asm { framebp = %o0 } subcc %o0,0,%o0 @@ -93,7 +93,7 @@ function get_caller_addr(framebp:pointer):pointer;assembler;nostackframe; {$define FPC_SYSTEM_HAS_GET_CALLER_FRAME} -function get_caller_frame(framebp:pointer):pointer;assembler;nostackframe; +function get_caller_frame(framebp:pointer;addr:pointer=nil):pointer;assembler;nostackframe; asm { framebp = %o0 } subcc %o0,0,%o0 diff --git a/mips/rtl/unix/ipc.pp b/mips/rtl/unix/ipc.pp index b506ea9012..66e9e3c13e 100644 --- a/mips/rtl/unix/ipc.pp +++ b/mips/rtl/unix/ipc.pp @@ -548,12 +548,12 @@ const MAX_SOPS = 5; {$if not defined(aix) and not defined(darwin)} - SEM_GETNCNT = 3; { Return the value of sempid {READ} } - SEM_GETPID = 4; { Return the value of semval {READ} } - SEM_GETVAL = 5; { Return semvals into arg.array {READ} } - SEM_GETALL = 6; { Return the value of semzcnt {READ} } - SEM_GETZCNT = 7; { Set the value of semval to arg.val {ALTER} } - SEM_SETVAL = 8; { Set semvals from arg.array {ALTER} } + SEM_GETNCNT = 3; { Return the value of sempid (READ) } + SEM_GETPID = 4; { Return the value of semval (READ) } + SEM_GETVAL = 5; { Return semvals into arg.array (READ) } + SEM_GETALL = 6; { Return the value of semzcnt (READ) } + SEM_GETZCNT = 7; { Set the value of semval to arg.val (ALTER) } + SEM_SETVAL = 8; { Set semvals from arg.array (ALTER) } SEM_SETALL = 9; {$endif} diff --git a/mips/rtl/unix/scripts/check_consts.sh b/mips/rtl/unix/scripts/check_consts.sh index 8f6655bdc9..a7e08b1556 100755 --- a/mips/rtl/unix/scripts/check_consts.sh +++ b/mips/rtl/unix/scripts/check_consts.sh @@ -20,6 +20,8 @@ os=`uname -s` if [ "$os" == "NetBSD" ] ; then needgsed=1 +else + needgsed=0 fi SED=sed @@ -37,7 +39,7 @@ fi for file in $@ ; do echo "Looking for constants in \"$file\"" -$SED -n "s:.*[[:space:]]\([a-zA-Z_][a-zA-Z_0-9]*\)[[:space:]]*=[[:space:]]*\([-+]*[0-9][xX]*[0-9+-\*/]*\)[[:space:]]*;.*:test_const \1 \2:p" $file > check_const_list.sh +$SED -n -e "s:.*[[:space:]]\([a-zA-Z_][a-zA-Z_0-9]*\)[[:space:]]*=[[:space:]]*\([-+]*[0-9][xX]*[-0-9+[:space:]]*\)[[:space:]]*;.*:test_const \1 \2:p" $file > check_const_list.sh test_const () { diff --git a/mips/rtl/unix/scripts/check_errno.sh b/mips/rtl/unix/scripts/check_errno.sh index 22f10d4d6a..c07e28a0f2 100755 --- a/mips/rtl/unix/scripts/check_errno.sh +++ b/mips/rtl/unix/scripts/check_errno.sh @@ -21,10 +21,24 @@ else verbose=0 fi +if [ "$1" == "addall" ] ; then + addall=1 + echo "Adding all entries to errno-new.inc" + shift +else + addall=0 +fi + # Location of error number in system header -errno_header="/usr/include/asm-generic/errno-base.h /usr/include/asm-generic/errno.h" -errno_include=./errno.inc +errno_headers="/usr/include/asm-generic/errno-base.h /usr/include/asm-generic/errno.h" + +if [ "$1" != "" ] ; then + errno_include=$1 + echo "Using $errno_include file" +else + errno_include=./errno.inc +fi # Sustitution made to pass from fpc syscall number # to system define @@ -53,18 +67,53 @@ fi # Use gcc with --save-temps option to create .i file $CC --save-temps -c ./test-errno.c # list of errno.h headers listed -errno_headers=` sed -n "s:.*\"\(.*\.h\)\".*:\1:p" test-errno.i |sort | uniq` -echo "Headers found are \"$errno_headers\"" +errno_headers_CC=` sed -n "s:.*\"\(.*\.h\)\".*:\1:p" test-errno.i |sort | uniq` +echo "Headers found are \"$errno_headers_CC\"" -if [ "$errno_headers" != "" ] ; then - errno_header="$errno_headers" +if [ "$errno_headers_CC" != "" ] ; then + errno_headers="$errno_headers_CC" fi # You should only need to change the variables above sed -n "s:^[[:space:]]*${fpc_errno_prefix}\\([_a-zA-Z0-9]*\\)[[:space:]]*=[[:space:]]*\\([0-9][0-9]*\\).*:check_errno_number ${errno_prefix}\1 \2:p" ${errno_include} > check_errno_list.sh -sed -n "s:#define[[:space:]]*${errno_prefix}\\([_a-zA-Z0-9]*\\)[[:space:]][[:space:]]*\\(-*[0-9A-Za-z_]*\\).*:check_reverse_errno_number ${fpc_errno_prefix}\1 \2:p" ${errno_header} > check_reverse_errno_list.sh +sed -n "s:#define[[:space:]]*${errno_prefix}\\([_a-zA-Z0-9]*\\)[[:space:]][[:space:]]*\\(-*[0-9A-Za-z_]*\\)[[:space:]]*\(.*\):check_reverse_errno_number ${fpc_errno_prefix}\1 \2 \"\3\":p" ${errno_headers} > check_reverse_errno_list.sh + +function rpad { + word="$1" + while [ ${#word} -lt $2 ]; do + word="$word$3"; + done; + echo "$word"; +} + +function compile_errno () +{ + errname=$1 + errvalue=$2 +# Test C file to grab all loaded headers +cat > test-errno.c <<EOF +#include <errno.h> +#include <stdio.h> + +int +main () +{ + printf ("$errname=%d\n",$errname); + return 0; +} +EOF +$CC -o ./test-errno ./test-errno.c +compiledvalue=`./test-errno` +if [ "$compiledvalue" == "$errname=$errvalue" ] ; then + if [ $verbose -ne 0 ]; then + echo "GCC reports $compiledvalue OK" + fi +else + echo "GCC reports $compiledvalue, but $errvalue is expected" +fi +} function check_errno_number () { @@ -75,10 +124,11 @@ function check_errno_number () fi # Remember value of this constant eval ${sys}=${value} + compile_errno $sys $value - found=`sed -n "/#define[[:space:]][[:space:]]*${sys}[^A-Za-z0-9_]/p" ${errno_header}` - val=`sed -n "s:#define[[:space:]][[:space:]]*${sys}[^A-Za-z0-9_][^A-Za-z0-9_]*\([0-9]*\).*:\1:p" ${errno_header}` - extval=`sed -n "s:#define[[:space:]][[:space:]]*${sys}[^A-Za-z0-9_][^A-Za-z0-9_]*\([0-9A-Za-z_]*\).*:\1:p" ${errno_header}` + found=`sed -n "/#define[[:space:]][[:space:]]*${sys}[^A-Za-z0-9_]/p" ${errno_headers}` + val=`sed -n "s:#define[[:space:]][[:space:]]*${sys}[^A-Za-z0-9_][^A-Za-z0-9_]*\([0-9]*\).*:\1:p" ${errno_headers}` + extval=`sed -n "s:#define[[:space:]][[:space:]]*${sys}[^A-Za-z0-9_][^A-Za-z0-9_]*\([0-9A-Za-z_]*\).*:\1:p" ${errno_headers}` if [ $verbose -ne 0 ] ; then echo Test for $sys found \"${found}\" \"${value}\" \"${val}\" fi @@ -87,13 +137,16 @@ function check_errno_number () echo ${sys} value ${val} is correct fi else + if [ $verbose -ne 0 ] ; then + echo "${sys} val=\"$val\", extval=\"$extval\"" + fi if [ "${val}" == "" ] ; then - foundvalue=`sed -n "/#define.*[^A-Za-z0-9_]${value}$/p" ${errno_header}` + foundvalue=`sed -n "/#define.*[^A-Za-z0-9_]${value}$/p" ${errno_headers}` if [ "${foundvalue}" == "" ] ; then - foundvalue=`sed -n "s:\/\* ${value} is compa: ${value} is compa:p" ${errno_header}` + foundvalue=`sed -n "s:\/\* ${value} is compa: ${value} is compa:p" ${errno_headers}` fi fi - if [ "$extval" != "" ] ; then + if [ "$extval" != "$val" ] ; then eval indirectval=\$$extval echo "indirectval =\"$indirectval\" for \"$extval\"" if [ "$indirectval" != "$value" ] ; then @@ -107,19 +160,46 @@ function check_errno_number () fi } +function write_errno_new_head () +{ + echo "{ File generated by $0" > $errnonew + uname_info=`uname -s -r -m` + echo " generated on \"$uname_info\" machine" >> $errnonew + echo "List of missing system error number found in" >> $errnonew + echo "$errno_headers" >> $errnonew + echo "}" >> $errnonew +} function check_reverse_errno_number () { errname=$1 errvalue=$2 + rpaderrname=$(rpad $errname 20 " ") + if ! [[ "$errvalue" =~ ^[0-9]+$ ]] ; then + eval errvalue=\$$errvalue + fi + + printf -v padd "%s = %4d" "$rpaderrname" $errvalue + found=`grep -i -w $1 ${errno_include}` + comment="$3" + comment=${comment##\/\*} + comment=${comment%%\*\/} if [ "${found}" == "" ] ; then echo "Error ${errname}, value ${errvalue}, not in ${errno_include} file" if [ $addtoerrno -eq 0 ] ; then addtoerrno=1 - echo "{ List of missing system error number found in $errno_header }" > $errnonew + write_errno_new_head + fi + echo " $padd; { $comment }" >> $errnonew + else + if [ $addall -eq 1 ] ; then + if [ $addtoerrno -eq 0 ] ; then + addtoerrno=1 + write_errno_new_head + fi + echo " $padd; { $comment }" >> $errnonew fi - echo " $errname = $errvalue;" >> $errnonew fi } diff --git a/mips/rtl/win/crt.pp b/mips/rtl/win/crt.pp index 6369f4c247..824b31e44f 100644 --- a/mips/rtl/win/crt.pp +++ b/mips/rtl/win/crt.pp @@ -711,7 +711,14 @@ begin WriteChar(f.buffer[i]); end else - s:=s+f.buffer[i]; + begin + if length(s)=255 then + begin + WriteStr(s); + s:=''; + end; + s:=s+f.buffer[i]; + end; if s<>'' then WriteStr(s); SetScreenCursor(CurrX, CurrY); diff --git a/mips/rtl/x86_64/x86_64.inc b/mips/rtl/x86_64/x86_64.inc index 6a5947ef07..70e11076e4 100644 --- a/mips/rtl/x86_64/x86_64.inc +++ b/mips/rtl/x86_64/x86_64.inc @@ -35,9 +35,14 @@ asm end; {$ENDIF not INTERNAL_BACKTRACE} +{$define FPC_SYSTEM_HAS_GET_PC_ADDR} +function get_pc_addr:pointer;assembler;nostackframe; +asm + movq (%rsp),%rax +end; {$define FPC_SYSTEM_HAS_GET_CALLER_ADDR} -function get_caller_addr(framebp:pointer):pointer;{$ifdef SYSTEMINLINE}inline;{$endif} +function get_caller_addr(framebp:pointer;addr:pointer=nil):pointer;{$ifdef SYSTEMINLINE}inline;{$endif} begin get_caller_addr:=framebp; if assigned(framebp) then @@ -46,7 +51,7 @@ end; {$define FPC_SYSTEM_HAS_GET_CALLER_FRAME} -function get_caller_frame(framebp:pointer):pointer;{$ifdef SYSTEMINLINE}inline;{$endif} +function get_caller_frame(framebp:pointer;addr:pointer=nil):pointer;{$ifdef SYSTEMINLINE}inline;{$endif} begin get_caller_frame:=framebp; if assigned(framebp) then @@ -942,7 +947,7 @@ Procedure SysInitFPU; { these locals are so we don't have to hack pic code in the assembler } localmxcsr: dword; localfpucw: word; - + begin localmxcsr:=mxcsr; localfpucw:=fpucw; diff --git a/mips/tests/Makefile b/mips/tests/Makefile index cfc720c897..46bc840699 100644 --- a/mips/tests/Makefile +++ b/mips/tests/Makefile @@ -1898,6 +1898,7 @@ endif ifndef TEST_OPT TEST_OPT= endif +override TEST_OPT+=-Fd ifndef TEST_FPC_VERSION TEST_FPC_COMPILERINFO:=$(shell $(TEST_FPC) -iVSPTPSOTODW) TEST_FPC_VERSION:=$(word 1,$(TEST_FPC_COMPILERINFO)) diff --git a/mips/tests/Makefile.fpc b/mips/tests/Makefile.fpc index da9bd9ea6d..b3c4052845 100644 --- a/mips/tests/Makefile.fpc +++ b/mips/tests/Makefile.fpc @@ -36,6 +36,11 @@ ifndef TEST_OPT TEST_OPT= endif +# disable directory cache; completely loading all directories significantly +# slows down running the testsuite because the programs use very few units +# and most testsuite directories contain thousands of files +override TEST_OPT+=-Fd + # Retrieve Test compiler info ifndef TEST_FPC_VERSION TEST_FPC_COMPILERINFO:=$(shell $(TEST_FPC) -iVSPTPSOTODW) diff --git a/mips/tests/tbs/tb0193.pp b/mips/tests/tbs/tb0193.pp index d2b2376b8b..6097cef5b7 100644 --- a/mips/tests/tbs/tb0193.pp +++ b/mips/tests/tbs/tb0193.pp @@ -11,15 +11,18 @@ asm {$ifdef CPUI386} movl stacksize,%eax end ['EAX']; +{$define implemented} {$endif CPUI386} {$ifdef CPUX86_64} movq stacksize@GOTPCREL(%rip),%rax movq (%rax),%rax end ['EAX']; +{$define implemented} {$endif CPUX86_64} {$ifdef CPU68K} move.l stacksize,d0 end ['D0']; +{$define implemented} {$endif CPU68K} {$ifdef cpupowerpc} {$if not defined(macos) and not defined(aix)} @@ -30,11 +33,13 @@ end ['D0']; lwz r3, 0(r3) {$endif macos} end; +{$define implemented} {$endif cpupowerpc} {$ifdef cpusparc} sethi %hi(stacksize),%i0 or %i0,%lo(stacksize),%i0 end; +{$define implemented} {$endif cpusparc} {$ifdef cpuarm} ldr r0,.Lpstacksize @@ -44,7 +49,18 @@ end; .long stacksize .Lend: end; +{$define implemented} {$endif cpuarm} +{$ifdef cpumips} + la $v0,stacksize + lw $v0,($v0) + end; +{$define implemented} +{$endif cpumips} +{$ifndef implemented} + {$error This test does not supported this CPU} +end; +{$endif} begin writeln(getstacksize); diff --git a/mips/tests/tbs/tb0524.pp b/mips/tests/tbs/tb0524.pp index a7be19e064..ba10a014b0 100644 --- a/mips/tests/tbs/tb0524.pp +++ b/mips/tests/tbs/tb0524.pp @@ -1,9 +1,46 @@ -{%TARGET=linux,freebsd,darwin,aix} +{%TARGET=linux,freebsd,darwin,aix,openbsd,netbsd} program tb0524; uses sockets,baseunix,sysutils; + const port=6667; + textfile = 'tb0524.txt'; + +procedure reset_textfile; +var + f : text; +begin + assign(f,textfile); + rewrite(f); + writeln(f,'Normal server start'); + close(f); +end; + +procedure stop(error : longint); +var + f : text; +begin + assign(f,textfile); + rewrite(f); + writeln(f,'Server startup failed'); + close(f); + halt(error); +end; + +function server_failed : boolean; +var + f : text; + st : string; +begin + server_failed:=false; + assign(f,textfile); + reset(f); + readln(f,st); + if pos('Server startup failed',st)=1 then + server_failed:=true; + close(f); +end; procedure do_server; @@ -15,11 +52,12 @@ var s,t:string; i:byte; begin + reset_textfile; lsock:=fpsocket(af_inet,sock_stream,0); if lsock=-1 then begin - writeln('socket:',socketerror); - halt(1); + writeln('socket call error:',socketerror); + stop(1); end; with saddr do @@ -31,22 +69,22 @@ begin if fpbind(lsock,@saddr,sizeof(saddr))<>0 then begin - writeln('bind:',socketerror); - halt(1); + writeln('bind call error:',socketerror); + stop(1); end; if fplisten(lsock,1)<>0 then begin - writeln('listen:',socketerror); - halt(1); + writeln('listen call error:',socketerror); + stop(1); end; len:=sizeof(saddr); usock:=fpaccept(lsock,@saddr,@len); if usock=-1 then begin - writeln('accept:',SocketError); - halt(1); + writeln('accept call error:',SocketError); + stop(1); end; sock2text(usock,sin,sout); @@ -101,6 +139,12 @@ begin begin {Give server some time to start.} sleep(2000); - do_client; + if server_failed then + begin + writeln('Server startup failed, test can not be completed'); + halt(2); + end + else + do_client; end; end. diff --git a/mips/tests/tbs/tb0528.pp b/mips/tests/tbs/tb0528.pp index 8a6899c5a0..d362385828 100644 --- a/mips/tests/tbs/tb0528.pp +++ b/mips/tests/tbs/tb0528.pp @@ -2,7 +2,7 @@ {%skiptarget=darwin,aix} { darwin limits statically declared data structures to 32 bit for efficiency reasons } -{ the aix assembler cannot deal with the way we declare these arrays in assembler code ) +{ the aix assembler cannot deal with the way we declare these arrays in assembler code } program tb0528; diff --git a/mips/tests/test/jvm/tenum2.pp b/mips/tests/test/jvm/tenum2.pp new file mode 100644 index 0000000000..a485691298 --- /dev/null +++ b/mips/tests/test/jvm/tenum2.pp @@ -0,0 +1,34 @@ +program tenum2; + +{$mode delphi} + +type + tenum2enum = (e_zero, e_one, e_two); + + tenum2base = class abstract + constructor create; + procedure init; virtual; abstract; + end; + + tenum2child = class(tenum2base) + fenum: tenum2enum; + procedure init; override; + end; + +constructor tenum2base.create; + begin + init; + end; + +procedure tenum2child.init; + begin + fenum:=e_one; + end; + +var + c: tenum2child; +begin + c:=tenum2child.create; + if c.fenum<>e_one then + halt(1); +end. diff --git a/mips/tests/test/jvm/testall.bat b/mips/tests/test/jvm/testall.bat index 2435e66f15..594e8b76f6 100644 --- a/mips/tests/test/jvm/testall.bat +++ b/mips/tests/test/jvm/testall.bat @@ -64,10 +64,14 @@ if %errorlevel% neq 0 exit /b %errorlevel% java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tbyte if %errorlevel% neq 0 exit /b %errorlevel% del uenum.ppu -ppcjvm -O2 -g tenum +ppcjvm -O2 -g -CTenumfieldinit tenum if %errorlevel% neq 0 exit /b %errorlevel% java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tenum if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g tenum2 +if %errorlevel% neq 0 exit /b %errorlevel% +java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tenum2 +if %errorlevel% neq 0 exit /b %errorlevel% ppcjvm -O2 -g tprop if %errorlevel% neq 0 exit /b %errorlevel% java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tprop @@ -236,4 +240,7 @@ ppcjvm -O2 -g -B taddbool if %errorlevel% neq 0 exit /b %errorlevel% java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. -Sa TAddBool if %errorlevel% neq 0 exit /b %errorlevel% - +ppcjvm -O2 -g -B tsetansistr +if %errorlevel% neq 0 exit /b %errorlevel% +java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. -Sa tsetansistr +if %errorlevel% neq 0 exit /b %errorlevel% diff --git a/mips/tests/test/jvm/testall.sh b/mips/tests/test/jvm/testall.sh index c80baf74a9..ddd869b8a7 100755 --- a/mips/tests/test/jvm/testall.sh +++ b/mips/tests/test/jvm/testall.sh @@ -47,8 +47,10 @@ $PPC -O2 -g forw $PPC -O2 -g tbyte java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/$RTLDIR:. tbyte rm -f uenum.ppu -$PPC -O2 -g tenum +$PPC -O2 -g -CTenumfieldinit tenum java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/$RTLDIR:. tenum +$PPC -O2 -g tenum2 +java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/$RTLDIR:. tenum2 $PPC -O2 -g tprop java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/$RTLDIR:. tprop $PPC -O2 -g tprop2 @@ -133,3 +135,5 @@ $PPC -O2 -g -B -Sa tassert java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/$RTLDIR:. tassert $PPC -O2 -g -B -Sa taddbool java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/$RTLDIR:. TAddBool +$PPC -O2 -g -B -Sa tsetansistr +java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/$RTLDIR:. tsetansistr diff --git a/mips/tests/test/jvm/tsetansistr.pp b/mips/tests/test/jvm/tsetansistr.pp new file mode 100644 index 0000000000..1dd983dff0 --- /dev/null +++ b/mips/tests/test/jvm/tsetansistr.pp @@ -0,0 +1,31 @@ +program tsetansistr;
+
+{$mode delphi}
+{$modeswitch unicodestrings}
+
+type
+ ByteArray = array of byte;
+
+const
+ AnsiStrOffset = 1;
+
+function AnsiStringOfBytes(const Src : ByteArray) : AnsiString;
+var
+ i : integer;
+begin
+ SetLength(Result, Length(Src));
+
+ for i := 0 to Length(Src) - 1 do
+ Result[i + AnsiStrOffset] := Chr(Src[i]);
+end;
+
+var
+ A : ByteArray;
+ B : AnsiString;
+begin
+ DefaultSystemCodePage:=20127; // ASCII
+ SetLength(A, 1); A[0] := $98;
+ B := AnsiStringOfBytes(A);
+ if ord(B[1]) <> $98 then
+ halt(1);
+end.
diff --git a/mips/tests/test/opt/tretopt.pp b/mips/tests/test/opt/tretopt.pp index b10ac0933d..fa1294bd21 100644 --- a/mips/tests/test/opt/tretopt.pp +++ b/mips/tests/test/opt/tretopt.pp @@ -294,7 +294,7 @@ begin {$ifdef darwin} movl %eax,p3-.Lpic(%ecx) {$else darwin} - addl $_GLOBAL_OFFSET_TABLE_,%ecx + addl $_GLOBAL_OFFSET_TABLE_+1,%ecx movl %eax,p3@GOT(%ecx) {$endif darwin} {$endif FPC_PIC} @@ -349,7 +349,7 @@ begin {$ifdef darwin} movl %eax,p3-.Lpic(%ecx) {$else darwin} - addl $_GLOBAL_OFFSET_TABLE_,%ecx + addl $_GLOBAL_OFFSET_TABLE_+1,%ecx movl %eax,p3@GOT(%ecx) {$endif darwin} {$endif FPC_PIC} diff --git a/mips/tests/test/packages/bzip2/tbzip2streamtest.pp b/mips/tests/test/packages/bzip2/tbzip2streamtest.pp index b82616c5be..dfa10fe6ba 100644 --- a/mips/tests/test/packages/bzip2/tbzip2streamtest.pp +++ b/mips/tests/test/packages/bzip2/tbzip2streamtest.pp @@ -70,53 +70,56 @@ begin UncompressedFile:=SysUtils.GetTempFileName(EmptyStr, 'UNC'); CompressedFile:=SysUtils.GetTempFileName(EmptyStr, 'BZ2'); - // Set up test bz2 file - // create a resource stream which points to our resource - ExampleFileResourceStream := TResourceStream.Create(HInstance, 'ALL', 'RT_RCDATA'); try - ExampleFileStream := TFileStream.Create(CompressedFile, fmCreate); + // Set up test bz2 file + // create a resource stream which points to our resource + ExampleFileResourceStream := TResourceStream.Create(HInstance, 'ALL', 'RT_RCDATA'); try - ExampleFileStream.CopyFrom(ExampleFileResourceStream, ExampleFileResourceStream.Size); + ExampleFileStream := TFileStream.Create(CompressedFile, fmCreate); + try + ExampleFileStream.CopyFrom(ExampleFileResourceStream, ExampleFileResourceStream.Size); + finally + ExampleFileStream.Free; + end; finally - ExampleFileStream.Free; + ExampleFileResourceStream.Free; end; - finally - ExampleFileResourceStream.Free; - end; - // Actual decompression - if decompress(CompressedFile, UncompressedFile) then - begin - // Now check if contents match. - UncompressedHash:=MD5Print(MD5File(UncompressedFile, MDDefBufSize)); - if UncompressedHash=ExpectedHash then - begin - code:=0; //success - end - else - begin - writeln('MD5 hash comparison between original file and uncompressed file failed'); - writeln('Got hash:'+UncompressedHash); - writeln('Expected:'+ExpectedHash); - code:=2; - end; - end - else - begin - writeln('bunzip2 decompression failure'); - code:=1; - end; + // Actual decompression + if decompress(CompressedFile, UncompressedFile) then + begin + // Now check if contents match. + UncompressedHash:=MD5Print(MD5File(UncompressedFile, MDDefBufSize)); + if UncompressedHash=ExpectedHash then + begin + code:=0; //success + end + else + begin + writeln('MD5 hash comparison between original file and uncompressed file failed'); + writeln('Got hash:'+UncompressedHash); + writeln('Expected:'+ExpectedHash); + code:=2; + end; + end + else + begin + writeln('bunzip2 decompression failure'); + code:=1; + end; - try - if CompressedFile<>EmptyStr then DeleteFile(CompressedFile); - if UncompressedFile<>EmptyStr then DeleteFile(UncompressedFile); - finally - // Ignore errors; operating system should clean out temp files - end; - if code = 0 then - writeln('Basic bzip2 tests passed') - else - writeln('Basic bzip2 test failed: ', code); + if code = 0 then + writeln('Basic bzip2 tests passed') + else + writeln('Basic bzip2 test failed: ', code); + finally + try + if CompressedFile<>EmptyStr then DeleteFile(CompressedFile); + if UncompressedFile<>EmptyStr then DeleteFile(UncompressedFile); + finally + // Ignore errors; operating system should clean out temp files + end; + end; Halt(code); end. diff --git a/mips/tests/test/tasmread.pp b/mips/tests/test/tasmread.pp index c3ac8fd3a8..b7c0bf7372 100644 --- a/mips/tests/test/tasmread.pp +++ b/mips/tests/test/tasmread.pp @@ -20,7 +20,7 @@ begin {$ifdef darwin} mov [test.l-@@LPIC+ecx],5 {$else darwin} - add ecx, _GLOBAL_OFFSET_TABLE_ + add ecx, _GLOBAL_OFFSET_TABLE_+1 mov [test.l + ecx],5 {$endif darwin} {$endif FPC_PIC} diff --git a/mips/tests/test/tcg1.pp b/mips/tests/test/tcg1.pp index bd8f702c83..59a6818dbc 100644 --- a/mips/tests/test/tcg1.pp +++ b/mips/tests/test/tcg1.pp @@ -2,71 +2,32 @@ {$R-} program test_register_pushing; -var - before, after : longint; - wpush,lpush : longint; const haserror : boolean = false; - + +procedure dotest; +var + wpush,lpush: longint; begin -{$ifdef CPUI386} {$asmmode att} asm -{$ifndef FPC_PIC} - movl %esp,before - pushw %es - movl %esp,after - popw %es -{$else not FPC_PIC} - call .LPIC -.LPIC: - popl %ecx -{$ifdef darwin} - movl %esp,before-.LPIC(%ecx) - pushw %es - movl %esp,after-.LPIC(%ecx) - popw %es -{$else darwin} - addl $_GLOBAL_OFFSET_TABLE_,%ecx - movl %esp,before@GOT(%ecx) + movl %esp,wpush pushw %es - movl %esp,after@GOT(%ecx) + subl %esp,wpush popw %es -{$endif darwin} -{$endif not FPC_PIC} end; - wpush:=before-after; if wpush<>2 then begin Writeln('Compiler does not push "pushw %es" into 2 bytes'); haserror:=true; end; + asm -{$ifndef FPC_PIC} - movl %esp,before + movl %esp,lpush pushl %es - movl %esp,after + subl %esp,lpush popl %es -{$else not FPC_PIC} - call .LPIC -.LPIC: - popl %ecx -{$ifdef darwin} - movl %esp,before-.LPIC(%ecx) - pushl %es - movl %esp,after-.LPIC(%ecx) - popl %es -{$else darwin} - addl $_GLOBAL_OFFSET_TABLE_,%ecx - movl %esp,before@GOT(%ecx) - pushl %es - movl %esp,after@GOT(%ecx) - popl %es -{$endif darwin} -{$endif not FPC_PIC} end; - lpush:=before-after; - if lpush<>4 then begin Writeln('Compiler does not push "pushl %es" into 4 bytes'); @@ -74,61 +35,22 @@ begin end; asm -{$ifndef FPC_PIC} - movl %esp,before - pushw %gs - movl %esp,after - popw %gs -{$else not FPC_PIC} - call .LPIC -.LPIC: - popl %ecx -{$ifdef darwin} - movl %esp,before-.LPIC(%ecx) + movl %esp,wpush pushw %gs - movl %esp,after-.LPIC(%ecx) + subl %esp,wpush popw %gs -{$else darwin} - addl $_GLOBAL_OFFSET_TABLE_,%ecx - movl %esp,before@GOT(%ecx) - pushw %gs - movl %esp,after@GOT(%ecx) - popw %gs -{$endif darwin} -{$endif not FPC_PIC} end; - wpush:=before-after; if wpush<>2 then begin Writeln('Compiler does not push "pushw %gs" into 2 bytes'); haserror:=true; end; asm -{$ifndef FPC_PIC} - movl %esp,before - pushl %gs - movl %esp,after - popl %gs -{$else not FPC_PIC} - call .LPIC -.LPIC: - popl %ecx -{$ifdef darwin} - movl %esp,before-.LPIC(%ecx) + movl %esp,lpush pushl %gs - movl %esp,after-.LPIC(%ecx) + subl %esp,lpush popl %gs -{$else darwin} - addl $_GLOBAL_OFFSET_TABLE_,%ecx - movl %esp,before@GOT(%ecx) - pushl %gs - movl %esp,after@GOT(%ecx) - popl %gs -{$endif darwin} -{$endif not FPC_PIC} end; - lpush:=before-after; - if lpush<>4 then begin Writeln('Compiler does not push "pushl %gs" into 4 bytes'); @@ -136,31 +58,16 @@ begin end; {$asmmode intel} asm -{$ifndef FPC_PIC} - mov before,esp + mov lpush,esp push es - mov after,esp + sub lpush,esp pop es -{$else not FPC_PIC} - call @@LPIC -@@LPIC: - pop ecx -{$ifdef darwin} - mov [before-@@LPIC+ecx],esp - push es - mov [after-@@LPIC+ecx],esp - pop es -{$else darwin} - add ecx,@_GLOBAL_OFFSET_TABLE_ - mov [ecx].OFFSET before,esp - push es - mov [ecx].OFFSET after,esp - pop es -{$endif darwin} -{$endif not FPC_PIC} end; - Writeln('Intel "push es" uses ',before-after,' bytes'); -{$endif CPUI386} + Writeln('Intel "push es" uses ',lpush,' bytes'); if haserror then Halt(1); +end; + +begin + dotest; end. diff --git a/mips/tests/test/testsse2.pp b/mips/tests/test/testsse2.pp index e6ecd81ad9..5ad9cb0d30 100644 --- a/mips/tests/test/testsse2.pp +++ b/mips/tests/test/testsse2.pp @@ -22,7 +22,7 @@ begin psubq %xmm1,%xmm2 psubq q-.LPIC(%ecx),%xmm4 {$else darwin} - addl $_GLOBAL_OFFSET_TABLE_,%ecx + addl $_GLOBAL_OFFSET_TABLE_+1,%ecx movdqa %xmm1,%xmm2 movdqa q@GOT(%ecx),%xmm4 psubq %xmm1,%xmm2 diff --git a/mips/tests/test/tgeneric76.pp b/mips/tests/test/tgeneric76.pp new file mode 100644 index 0000000000..4b2aa6ef6e --- /dev/null +++ b/mips/tests/test/tgeneric76.pp @@ -0,0 +1,45 @@ +{$mode delphi} + +unit tgeneric76; + +interface + +type + + { TPointEx } + + TPointEx<T> = record + X, Y: T; + function Create(const AX, AY: T): TPointEx<T>; + class procedure Swap(var A, B: TPointEx<T>); static; + class procedure OrderByY(var A, B: TPointEx<T>); static; + end; + + TPoint = TPointEx<integer>; + TPointF = TPointEx<single>; + +implementation + +function TPointEx<T>.Create(const AX, AY: T): TPointEx<T>; +begin + result.X:=AX; + result.Y:=AY; +end; + +class procedure TPointEx<T>.Swap(var A, B: TPointEx<T>); +var + tmp: TPointEx<T>; +begin + tmp:=A; + A:=B; + B:=tmp; +end; + +class procedure TPointEx<T>.OrderByY(var A, B: TPointEx<T>); +begin + if A.Y > B.Y then + TPointEx<T>.Swap(A,B); +end; + + +end. diff --git a/mips/tests/test/tgeneric77.pp b/mips/tests/test/tgeneric77.pp new file mode 100644 index 0000000000..060c802d37 --- /dev/null +++ b/mips/tests/test/tgeneric77.pp @@ -0,0 +1,48 @@ +{$mode objfpc}{$h+} +{$modeswitch advancedrecords} + +unit tgeneric77; + +interface + +type + + { TPointEx } + + generic TPointEx<T> = record + X, Y: T; + function Create(const AX, AY: T): TPointEx; + class procedure Swap(var A, B: TPointEx); static; + class procedure OrderByY(var A, B: TPointEx); static; + end; + + //TPoint = specialize TPointEx<integer>; + TPointF = specialize TPointEx<single>; + +implementation + +{ TPoint<T> } + +function TPointEx.Create(const AX, AY: T): TPointEx; +begin + result.X:=AX; + result.Y:=AY; +end; + +class procedure TPointEx.Swap(var A, B: TPointEx); +var + tmp: TPointEx; +begin + tmp:=A; + A:=B; + B:=tmp; +end; + +class procedure TPointEx.OrderByY(var A, B: TPointEx); +begin + if A.Y > B.Y then + TPointEx.Swap(A,B); +end; + + +end. diff --git a/mips/tests/test/tgeneric78.pp b/mips/tests/test/tgeneric78.pp new file mode 100644 index 0000000000..4addc2b12e --- /dev/null +++ b/mips/tests/test/tgeneric78.pp @@ -0,0 +1,27 @@ +{ %NORUN } + +{ additional test based on 21064 } +program tgeneric78; + +{$mode delphi} + +type + IGenericIntf<T> = interface + function SomeMethod: T; + end; + + TGenericClass<T> = class(TInterfacedObject, IGenericIntf<LongInt>) + private + protected + function GenericIntf_SomeMethod: LongInt; + function IGenericIntf<LongInt>.SomeMethod = GenericIntf_SomeMethod; + end; + +function TGenericClass<T>.GenericIntf_SomeMethod: LongInt; +begin +end; + +type + TGenericClassLongInt = TGenericClass<String>; +begin +end. diff --git a/mips/tests/test/tgeneric79.pp b/mips/tests/test/tgeneric79.pp new file mode 100644 index 0000000000..da94c73e20 --- /dev/null +++ b/mips/tests/test/tgeneric79.pp @@ -0,0 +1,27 @@ +{ %NORUN } + +{ additional test based on 21064 } +program tgeneric79; + +{$mode objfpc} + +type + generic IGenericIntf<T> = interface + function SomeMethod: T; + end; + + generic TGenericClass<T> = class(TInterfacedObject, specialize IGenericIntf<LongInt>) + private + protected + function GenericIntf_SomeMethod: LongInt; + function IGenericIntf<LongInt>.SomeMethod = GenericIntf_SomeMethod; + end; + +function TGenericClass.GenericIntf_SomeMethod: LongInt; +begin +end; + +type + TGenericClassLongInt = specialize TGenericClass<String>; +begin +end. diff --git a/mips/tests/test/tgeneric80.pp b/mips/tests/test/tgeneric80.pp new file mode 100644 index 0000000000..f23c900dc1 --- /dev/null +++ b/mips/tests/test/tgeneric80.pp @@ -0,0 +1,18 @@ +{ %NORUN } + +program tgeneric80; + +{$mode delphi} + +type + TTest<T, S> = record + end; + TTest<T> = record + end; + PTest = ^TTest; + TTest = record + end; + +begin + +end. diff --git a/mips/tests/test/tgeneric81.pp b/mips/tests/test/tgeneric81.pp new file mode 100644 index 0000000000..8618e9ad39 --- /dev/null +++ b/mips/tests/test/tgeneric81.pp @@ -0,0 +1,18 @@ +{ %NORUN } + +program tgeneric81; + +{$mode delphi} + +type + PTest = ^TTest; + TTest<T, S> = record + end; + TTest<T> = record + end; + TTest = record + end; + +begin + +end. diff --git a/mips/tests/test/tgeneric82.pp b/mips/tests/test/tgeneric82.pp new file mode 100644 index 0000000000..7b556ce0f7 --- /dev/null +++ b/mips/tests/test/tgeneric82.pp @@ -0,0 +1,18 @@ +{ %NORUN } + +program tgeneric82; + +{$mode delphi} + +type + TTest = record + end; + TTest<T, S> = record + end; + TTest<T> = record + end; + PTest = ^TTest; + +begin + +end. diff --git a/mips/tests/test/tgeneric83.pp b/mips/tests/test/tgeneric83.pp new file mode 100644 index 0000000000..0e081956fd --- /dev/null +++ b/mips/tests/test/tgeneric83.pp @@ -0,0 +1,16 @@ +{ %FAIL } + +program tgeneric83; + +{$mode delphi} + +type + TTest<T> = record + end; + +const + Test: ^TTest = Nil; + +begin + +end. diff --git a/mips/tests/test/tgeneric84.pp b/mips/tests/test/tgeneric84.pp new file mode 100644 index 0000000000..ec33dd07a1 --- /dev/null +++ b/mips/tests/test/tgeneric84.pp @@ -0,0 +1,14 @@ +{ %FAIL } + +program tgeneric84; + +{$mode objfpc} + +type + generic TTest<T> = record + end; + + PTest = ^TTest; + +begin +end. diff --git a/mips/tests/test/tgeneric85.pp b/mips/tests/test/tgeneric85.pp new file mode 100644 index 0000000000..e7c634560f --- /dev/null +++ b/mips/tests/test/tgeneric85.pp @@ -0,0 +1,16 @@ +{ %FAIL } + +program tgeneric85; + +{$mode objfpc} + +type + generic TTest<T> = record + end; + +const + Test: ^TTest = Nil; + +begin + +end. diff --git a/mips/tests/test/tgeneric86.pp b/mips/tests/test/tgeneric86.pp new file mode 100644 index 0000000000..02520a0f41 --- /dev/null +++ b/mips/tests/test/tgeneric86.pp @@ -0,0 +1,17 @@ +{ %NORUN } + +program tgeneric86; + +{$mode objfpc}{$H+} +{$modeswitch advancedrecords} + +type + generic TTest<T> = record + type + PTest = ^TTest; + end; + +begin + +end. + diff --git a/mips/tests/test/tgeneric87.pp b/mips/tests/test/tgeneric87.pp new file mode 100644 index 0000000000..33e2afc92c --- /dev/null +++ b/mips/tests/test/tgeneric87.pp @@ -0,0 +1,18 @@ +{ %FAIL } + +program tgeneric87; + +{$mode objfpc} + +type + generic TTest<T> = record + + end; + +const + TestLongIntNil: ^specialize TTest<LongInt> = Nil; + TestBooleanNil: ^specialize TTest<Boolean> = Nil; + +begin + +end. diff --git a/mips/tests/test/tgeneric88.pp b/mips/tests/test/tgeneric88.pp new file mode 100644 index 0000000000..c8233ee7e2 --- /dev/null +++ b/mips/tests/test/tgeneric88.pp @@ -0,0 +1,17 @@ +{ %FAIL } + +program tgeneric88; + +{$mode objfpc} + +type + generic TTest<T> = record + + end; + + PTestLongInt = ^specialize TTest<LongInt>; + PTestBoolean = ^specialize TTest<Boolean>; + +begin + +end. diff --git a/mips/tests/test/tgeneric89.pp b/mips/tests/test/tgeneric89.pp new file mode 100644 index 0000000000..5e50ef1549 --- /dev/null +++ b/mips/tests/test/tgeneric89.pp @@ -0,0 +1,17 @@ +{ %NORUN } + +program tgeneric89; + +{$mode delphi} + +type + TTest<T> = record + + end; + + PTestLongInt = ^TTest<LongInt>; + PTestBoolean = ^TTest<Boolean>; + +begin + +end. diff --git a/mips/tests/test/tgeneric90.pp b/mips/tests/test/tgeneric90.pp new file mode 100644 index 0000000000..0c9ae3c4cb --- /dev/null +++ b/mips/tests/test/tgeneric90.pp @@ -0,0 +1,26 @@ +{ %NORUN } + +program tgeneric90; + +{$mode delphi} + +type + TTest = record + + end; + + TTest<T> = record + + end; + + TTest<T, S> = record + + end; + + PTestLongInt = ^TTest<LongInt>; + PTestLongIntLongInt = ^TTest<LongInt, LongInt>; + PTest = ^TTest; + +begin + +end. diff --git a/mips/tests/test/tint642.pp b/mips/tests/test/tint642.pp index 7beab28039..c60ab52a3b 100644 --- a/mips/tests/test/tint642.pp +++ b/mips/tests/test/tint642.pp @@ -248,6 +248,8 @@ procedure testshlshrqword; l1:=16; l2:=0; + if (q1 shl 0)<>q1 then + do_error(1499); if (q1 shl 16)<>q3 then do_error(1500); if (q1 shl 48)<>q0 then @@ -277,6 +279,8 @@ procedure testshlshrqword; if ((q1+q0) shl (l1+l2))<>q3 then do_error(1509); + if (q1 shr 0)<>q1 then + do_error(15091); if (q1 shr 16)<>q2 then do_error(1510); if (q1 shr 48)<>q0 then diff --git a/mips/tests/test/trhlp44.pp b/mips/tests/test/trhlp44.pp new file mode 100644 index 0000000000..4c4951ec3b --- /dev/null +++ b/mips/tests/test/trhlp44.pp @@ -0,0 +1,31 @@ +{ %NORUN } + +program trhlp44; + +{$mode delphi} + +type + TTest = record + + end; + + TTestHelper = record helper for TTest + procedure SayHello(const I: Integer); overload; + procedure SayHello(const S: string); overload; + end; + +procedure TTestHelper.SayHello(const I: Integer); overload; +begin + Writeln('Hello ', I); +end; + +procedure TTestHelper.SayHello(const S: string); overload; +begin + Writeln('Hello ', S); +end; + +var + Obj: TTest; +begin + Obj.SayHello('FPC'); +end. diff --git a/mips/tests/webtbf/tw22219.pp b/mips/tests/webtbf/tw22219.pp new file mode 100644 index 0000000000..fa805dffa6 --- /dev/null +++ b/mips/tests/webtbf/tw22219.pp @@ -0,0 +1,16 @@ +{ %FAIL } + +program tw22219; +{$MODE DELPHI} + +type + TWrapper<P, Q> = record end; + TWrapper<R> = record end; + AmbiguousPointer = ^TWrapper; + +var + Z: AmbiguousPointer; + +begin + +end. diff --git a/mips/tests/webtbs/tw20947.pp b/mips/tests/webtbs/tw20947.pp new file mode 100644 index 0000000000..b2d3ac7675 --- /dev/null +++ b/mips/tests/webtbs/tw20947.pp @@ -0,0 +1,21 @@ +{ the important part of this test is a cross compilation which a change in the + size of the bitness, e.g. from Win32 to Win64 where the unit "fgl" was + compiled with the 32-to-64-bit cross compiler and this program itself is + compiled with the native 64-bit compiler } + +program tw20947; + +uses + fgl; + +type + TTestList = specialize TFPGList<Byte>; + +Var + Test : TTestList; +begin + Test := TTestList.Create; + Test.Add(2); + WriteLn(Test[0]); // This should output 2 to console + Test.Free; +end. diff --git a/mips/tests/webtbs/tw20998.pp b/mips/tests/webtbs/tw20998.pp index 92b6f93d15..6ee9ea7cbf 100644 --- a/mips/tests/webtbs/tw20998.pp +++ b/mips/tests/webtbs/tw20998.pp @@ -1,18 +1,23 @@ var i : int64; - + j, k: longint; begin - i:=6400; - i:=i div 64; - if i<>100 then - halt(1); + k:=64; + for j:=6400 to 6464 do + begin + i:=j; + if (i div 64) <> (i div k) then + halt(1); + end; i:=6500; i:=i div 65; if i<>100 then halt(1); - i:=-6400; - i:=i div 64; - if i<>-100 then - halt(1); + for j:=-6400 downto -6464 do + begin + i:=j; + if (i div 64) <> (i div k) then + halt(2); + end; writeln('ok'); end. diff --git a/mips/tests/webtbs/tw21064a.pp b/mips/tests/webtbs/tw21064a.pp new file mode 100644 index 0000000000..e813aab427 --- /dev/null +++ b/mips/tests/webtbs/tw21064a.pp @@ -0,0 +1,26 @@ +{ %NORUN } + +program tw21064a; + +{$mode delphi} + +type + IGenericIntf<T> = interface + function SomeMethod: T; + end; + + TGenericClass<T> = class(TInterfacedObject, IGenericIntf<T>) + private + protected + function GenericIntf_SomeMethod: T; + function IGenericIntf<T>.SomeMethod = GenericIntf_SomeMethod; + end; + +function TGenericClass<T>.GenericIntf_SomeMethod: T; +begin +end; + +type + TGenericClassLongInt = TGenericClass<LongInt>; +begin +end. diff --git a/mips/tests/webtbs/tw21064b.pp b/mips/tests/webtbs/tw21064b.pp new file mode 100644 index 0000000000..64be8cc69c --- /dev/null +++ b/mips/tests/webtbs/tw21064b.pp @@ -0,0 +1,28 @@ +{ %NORUN } + +program tw21064b; + +{$mode delphi} + +type + IGenericIntf<T> = interface + function SomeMethod: T; + end; + + TGenericClass<T> = class(TInterfacedObject, IGenericIntf<T>) + private + type + IntfType = IGenericIntf<T>; + protected + function GenericIntf_SomeMethod: T; + function IntfType.SomeMethod = GenericIntf_SomeMethod; + end; + +function TGenericClass<T>.GenericIntf_SomeMethod: T; +begin +end; + +type + TGenericClassLongInt = TGenericClass<LongInt>; +begin +end. diff --git a/mips/tests/webtbs/tw21350a.pp b/mips/tests/webtbs/tw21350a.pp new file mode 100644 index 0000000000..a67d6b3997 --- /dev/null +++ b/mips/tests/webtbs/tw21350a.pp @@ -0,0 +1,45 @@ +{$mode delphi} + +unit tw21350a; + +interface + +type + + { TPointEx } + + TPointEx<T> = object + X, Y: T; + function Create(const AX, AY: T): TPointEx<T>; + class procedure Swap(var A, B: TPointEx<T>); static; + class procedure OrderByY(var A, B: TPointEx<T>); static; + end; + + TPoint = TPointEx<integer>; + TPointF = TPointEx<single>; + +implementation + +function TPointEx<T>.Create(const AX, AY: T): TPointEx<T>; +begin + result.X:=AX; + result.Y:=AY; +end; + +class procedure TPointEx<T>.Swap(var A, B: TPointEx<T>); +var + tmp: TPointEx<T>; +begin + tmp:=A; + A:=B; + B:=tmp; +end; + +class procedure TPointEx<T>.OrderByY(var A, B: TPointEx<T>); +begin + if A.Y > B.Y then + TPointEx<T>.Swap(A,B); +end; + + +end. diff --git a/mips/tests/webtbs/tw21350b.pp b/mips/tests/webtbs/tw21350b.pp new file mode 100644 index 0000000000..5aefe310db --- /dev/null +++ b/mips/tests/webtbs/tw21350b.pp @@ -0,0 +1,47 @@ +{$mode objfpc}{$h+} + +unit tw21350b; + +interface + +type + + { TPointEx } + + generic TPointEx<T> = object + X, Y: T; + function Create(const AX, AY: T): TPointEx; + class procedure Swap(var A, B: TPointEx); static; + class procedure OrderByY(var A, B: TPointEx); static; + end; + + //TPoint = specialize TPointEx<integer>; + TPointF = specialize TPointEx<single>; + +implementation + +{ TPoint<T> } + +function TPointEx.Create(const AX, AY: T): TPointEx; +begin + result.X:=AX; + result.Y:=AY; +end; + +class procedure TPointEx.Swap(var A, B: TPointEx); +var + tmp: TPointEx; +begin + tmp:=A; + A:=B; + B:=tmp; +end; + +class procedure TPointEx.OrderByY(var A, B: TPointEx); +begin + if A.Y > B.Y then + TPointEx.Swap(A,B); +end; + + +end. diff --git a/mips/tests/webtbs/tw21457.pp b/mips/tests/webtbs/tw21457.pp new file mode 100644 index 0000000000..efde6895ac --- /dev/null +++ b/mips/tests/webtbs/tw21457.pp @@ -0,0 +1,24 @@ +unit tw21457; +{$mode objfpc} +interface +uses Classes; + +Type + TFileStreamHelper = class helper for TFileStream + public + constructor CreateRetry(const AFileName: string; Mode: Word; Rights: Cardinal); + end; + + +implementation + +{ TFileStreamHelper } + +constructor TFileStreamHelper.CreateRetry(const AFileName:string; Mode:Word; Rights: Cardinal); +begin + //TODO + //=> internal error 200305103 +end; + + +end. diff --git a/mips/tests/webtbs/tw21921.pp b/mips/tests/webtbs/tw21921.pp new file mode 100644 index 0000000000..8ed4924b97 --- /dev/null +++ b/mips/tests/webtbs/tw21921.pp @@ -0,0 +1,28 @@ +{ %NORUN } + +program tw21921; + +{$mode Delphi}{$H+} + +type + + { THashEntry } + + THashEntry<T> = record + Key: string; + Value: T; + class function Create(const AKey: string; const AValue: T): THashEntry<T>; static; inline; + end; + +class function THashEntry<T>.Create(const AKey: string; const AValue: T): THashEntry<T>; +begin + Result.Key := AKey; + Result.Value := AValue; +end; + +var + Entry: THashEntry<Integer>; +begin + Entry := THashEntry<Integer>.Create('One', 1); +end. + diff --git a/mips/tests/webtbs/tw22154.pp b/mips/tests/webtbs/tw22154.pp new file mode 100644 index 0000000000..775c14b562 --- /dev/null +++ b/mips/tests/webtbs/tw22154.pp @@ -0,0 +1,18 @@ +program tw22154; + +{$MODE DELPHI} + +type + TWrapper<T> = class + procedure Z; + end; + +procedure TWrapper<T>.Z; +const + A0: array [0..0] of Integer = (0); { OK } + A1: array [0..1] of Integer = (0, 1); { Comma not exepcted } +begin +end; + +begin +end. diff --git a/mips/tests/webtbs/tw22320.pp b/mips/tests/webtbs/tw22320.pp new file mode 100644 index 0000000000..1d5752cf3b --- /dev/null +++ b/mips/tests/webtbs/tw22320.pp @@ -0,0 +1,73 @@ +program Test; + +{$IFDEF FPC} + {$MODE DELPHI} +{$ENDIF} + +{$APPTYPE CONSOLE} + +type + TwbSignature = array[0..3] of AnsiChar; + + TwbConflictPriority = ( + cpIgnore, + cpBenign, + cpTranslate, + cpNormal, + cpCritical, + cpFormID + ); + + IwbElement = interface + ['{F4B4637D-C794-415F-B5C7-587EAA4095B3}'] + end; + + TwbDontShowCallback = function(const aElement: IwbElement): Boolean; + + IwbSubRecordDef = interface + ['{D848E426-8768-45F4-B192-4DEFBE34D40A}'] + end; + + IwbByteArrayDef = interface + ['{3069E1AC-4307-421B-93E4-797E18075EF9}'] + end; + +function wbByteArray(const aName : string = 'Unknown'; + aSize : Cardinal = 0; + aPriority : TwbConflictPriority = cpNormal; + aRequired : Boolean = False; + aDontShow : TwbDontShowCallback = nil) + : IwbByteArrayDef; overload; +begin + Result := nil; +end; + +function wbByteArray(const aSignature : TwbSignature; + const aName : string = 'Unknown'; + aSize : Cardinal = 0; + aPriority : TwbConflictPriority = cpNormal; + aRequired : Boolean = False; + aSizeMatch : Boolean = False; + aDontShow : TwbDontShowCallback = nil) + : IwbSubRecordDef; overload; +begin + Result := nil; + halt(2); +end; + +function wbUnknown(aPriority : TwbConflictPriority = cpNormal; + aRequired : Boolean = False; + aDontShow : TwbDontShowCallback = nil) + : IwbByteArrayDef; +begin + Result := wbByteArray('Unknown', 0, aPriority, aRequired, aDontShow); +end; + +function cb(const aElement: IwbElement): Boolean; +begin + halt(1); +end; + +begin + wbUnknown(cpNormal,False,cb); +end. diff --git a/mips/tests/webtbs/tw22326.pp b/mips/tests/webtbs/tw22326.pp new file mode 100644 index 0000000000..9ff1416934 --- /dev/null +++ b/mips/tests/webtbs/tw22326.pp @@ -0,0 +1,9 @@ +var + q1: QWord; +begin + q1:=$1020304050607080; + if (q1 shl 0) <> q1 then + halt(1); + if (q1 shr 0) <> q1 then + halt(2); +end. diff --git a/mips/tests/webtbs/tw22329.pp b/mips/tests/webtbs/tw22329.pp new file mode 100644 index 0000000000..81a9ec9dc3 --- /dev/null +++ b/mips/tests/webtbs/tw22329.pp @@ -0,0 +1,32 @@ +{ %NORUN } + +program tw22329; + +{$mode delphi} + +type + TObjectHelper = class helper for TObject + procedure SayHello(const I: Integer); overload; + procedure SayHello(const S: string); overload; + end; + +procedure TObjectHelper.SayHello(const I: Integer); overload; +begin + Writeln('Hello ', I); +end; + +procedure TObjectHelper.SayHello(const S: string); overload; +begin + Writeln('Hello ', S); +end; + +var + Obj: TObject; +begin + Obj := TObject.Create; + try + Obj.SayHello('FPC'); + finally + Obj.Free; + end; +end. diff --git a/mips/tests/webtbs/tw22331.pp b/mips/tests/webtbs/tw22331.pp new file mode 100644 index 0000000000..01c1485e6c --- /dev/null +++ b/mips/tests/webtbs/tw22331.pp @@ -0,0 +1,139 @@ +procedure X; +var + w, h: integer; +begin + w:=1; + h:=2; + writeln(round(w / 2 - 0), round(h - 0)); + writeln(round(w / 2 - 138.809093), round(h - 661.165204)); + writeln(round(w / 2 - 138.683051), round(h - 661.003245)); + writeln(round(w / 2 - 138.556540), round(h - 660.840685)); + writeln(round(w / 2 - 138.429558), round(h - 660.677449)); + writeln(round(w / 2 - 138.302098), round(h - 660.513612)); + writeln(round(w / 2 - 138.174178), round(h - 660.349250)); + writeln(round(w / 2 - 138.045779), round(h - 660.184211)); + writeln(round(w / 2 - 137.916911), round(h - 660.018571)); + writeln(round(w / 2 - 137.787573), round(h - 659.852405)); + writeln(round(w / 2 - 137.657765), round(h - 659.685563)); + writeln(round(w / 2 - 137.527488), round(h - 659.518121)); + writeln(round(w / 2 - 137.396732), round(h - 659.350077)); + writeln(round(w / 2 - 137.265516), round(h - 659.181432)); + writeln(round(w / 2 - 137.133821), round(h - 659.012187)); + writeln(round(w / 2 - 137.001656), round(h - 658.842340)); + writeln(round(w / 2 - 136.869023), round(h - 658.671892)); + writeln(round(w / 2 - 136.735910), round(h - 658.500844)); + writeln(round(w / 2 - 136.602337), round(h - 658.329119)); + writeln(round(w / 2 - 136.468294), round(h - 658.156944)); + writeln(round(w / 2 - 136.333773), round(h - 657.984017)); + writeln(round(w / 2 - 136.198782), round(h - 657.810490)); + writeln(round(w / 2 - 136.063322), round(h - 657.636437)); + writeln(round(w / 2 - 135.927392), round(h - 657.461782)); + writeln(round(w / 2 - 135.790993), round(h - 657.286452)); + writeln(round(w / 2 - 135.654114), round(h - 657.110521)); + writeln(round(w / 2 - 135.516776), round(h - 656.933988)); + writeln(round(w / 2 - 135.378959), round(h - 656.756930)); + writeln(round(w / 2 - 135.240672), round(h - 656.579196)); + writeln(round(w / 2 - 135.101916), round(h - 656.400936)); + writeln(round(w / 2 - 134.962690), round(h - 656.222000)); + writeln(round(w / 2 - 134.822995), round(h - 656.042463)); + writeln(round(w / 2 - 134.682821), round(h - 655.862325)); + writeln(round(w / 2 - 134.542186), round(h - 655.681586)); + writeln(round(w / 2 - 134.147430), round(h - 655.174225)); + writeln(round(w / 2 - 134.006815), round(h - 654.993486)); + writeln(round(w / 2 - 133.866669), round(h - 654.813348)); + writeln(round(w / 2 - 133.727002), round(h - 654.633886)); + writeln(round(w / 2 - 133.607551), round(h - 654.480415)); + writeln(round(w / 2 - 133.488777), round(h - 654.287807)); + writeln(round(w / 2 - 133.370406), round(h - 654.095800)); + writeln(round(w / 2 - 133.252440), round(h - 653.904469)); + writeln(round(w / 2 - 133.134877), round(h - 653.713814)); + writeln(round(w / 2 - 133.017708), round(h - 653.523836)); + writeln(round(w / 2 - 132.900953), round(h - 653.334458)); + writeln(round(w / 2 - 132.784592), round(h - 653.145756)); + writeln(round(w / 2 - 132.668644), round(h - 652.957730)); + writeln(round(w / 2 - 132.553090), round(h - 652.770306)); + writeln(round(w / 2 - 132.437940), round(h - 652.583557)); + writeln(round(w / 2 - 132.323204), round(h - 652.397485)); + writeln(round(w / 2 - 132.208862), round(h - 652.212088)); + writeln(round(w / 2 - 132.094923), round(h - 652.027293)); + writeln(round(w / 2 - 131.981379), round(h - 651.843098)); + writeln(round(w / 2 - 131.868248), round(h - 651.659655)); + writeln(round(w / 2 - 131.755521), round(h - 651.476812)); + writeln(round(w / 2 - 131.643198), round(h - 651.294721)); + writeln(round(w / 2 - 131.531269), round(h - 651.113231)); + writeln(round(w / 2 - 131.419753), round(h - 650.932342)); + writeln(round(w / 2 - 131.308631), round(h - 650.752129)); + writeln(round(w / 2 - 131.197914), round(h - 650.572516)); + writeln(round(w / 2 - 131.087609), round(h - 650.393655)); + writeln(round(w / 2 - 130.977699), round(h - 650.215395)); + writeln(round(w / 2 - 130.868193), round(h - 650.037812)); + writeln(round(w / 2 - 130.759090), round(h - 649.860904)); + writeln(round(w / 2 - 130.650391), round(h - 649.684597)); + writeln(round(w / 2 - 130.542087), round(h - 649.508966)); + writeln(round(w / 2 - 130.434196), round(h - 649.334011)); + writeln(round(w / 2 - 130.326708), round(h - 649.159657)); + writeln(round(w / 2 - 130.219615), round(h - 648.985980)); + writeln(round(w / 2 - 130.112935), round(h - 648.813053)); + writeln(round(w / 2 - 130.006650), round(h - 648.640577)); + writeln(round(w / 2 - 129.900768), round(h - 648.468928)); + writeln(round(w / 2 - 129.795290), round(h - 648.297879)); + writeln(round(w / 2 - 129.690215), round(h - 648.127507)); + writeln(round(w / 2 - 129.585554), round(h - 647.957735)); + writeln(round(w / 2 - 129.481278), round(h - 647.788565)); + writeln(round(w / 2 - 129.377415), round(h - 647.620146)); + writeln(round(w / 2 - 129.273956), round(h - 647.452402)); + writeln(round(w / 2 - 129.170901), round(h - 647.285260)); + writeln(round(w / 2 - 129.068240), round(h - 647.118794)); + writeln(round(w / 2 - 128.965992), round(h - 646.952929)); + writeln(round(w / 2 - 128.864138), round(h - 646.787815)); + writeln(round(w / 2 - 128.762689), round(h - 646.623302)); + writeln(round(w / 2 - 128.661652), round(h - 646.459390)); + writeln(round(w / 2 - 128.561010), round(h - 646.296154)); + writeln(round(w / 2 - 128.460771), round(h - 646.133594)); + writeln(round(w / 2 - 128.360937), round(h - 645.971710)); + writeln(round(w / 2 - 128.261506), round(h - 645.810502)); + writeln(round(w / 2 - 128.162469), round(h - 645.649895)); + writeln(round(w / 2 - 128.063846), round(h - 645.489889)); + writeln(round(w / 2 - 127.965627), round(h - 645.330635)); + writeln(round(w / 2 - 127.894723), round(h - 645.215626)); + writeln(round(w / 2 - 127.808626), round(h - 645.050587)); + writeln(round(w / 2 - 127.722895), round(h - 644.886149)); + writeln(round(w / 2 - 127.637511), round(h - 644.722462)); + writeln(round(w / 2 - 127.552485), round(h - 644.559452)); + writeln(round(w / 2 - 127.467815), round(h - 644.397042)); + writeln(round(w / 2 - 127.383502), round(h - 644.235383)); + writeln(round(w / 2 - 127.299537), round(h - 644.074476)); + writeln(round(w / 2 - 127.215937), round(h - 643.914170)); + writeln(round(w / 2 - 127.132695), round(h - 643.754540)); + writeln(round(w / 2 - 127.049800), round(h - 643.595585)); + writeln(round(w / 2 - 126.967261), round(h - 643.437307)); + writeln(round(w / 2 - 126.885080), round(h - 643.279780)); + writeln(round(w / 2 - 126.803255), round(h - 643.122854)); + writeln(round(w / 2 - 126.721788), round(h - 642.966680)); + writeln(round(w / 2 - 126.640677), round(h - 642.811106)); + writeln(round(w / 2 - 126.559923), round(h - 642.656359)); + writeln(round(w / 2 - 126.479516), round(h - 642.502137)); + writeln(round(w / 2 - 126.399475), round(h - 642.348667)); + writeln(round(w / 2 - 126.319782), round(h - 642.195872)); + writeln(round(w / 2 - 126.240446), round(h - 642.043754)); + writeln(round(w / 2 - 126.161467), round(h - 641.892312)); + writeln(round(w / 2 - 126.082844), round(h - 641.741546)); + writeln(round(w / 2 - 126.004578), round(h - 641.591456)); + writeln(round(w / 2 - 125.926669), round(h - 641.442117)); + writeln(round(w / 2 - 125.849108), round(h - 641.293379)); + writeln(round(w / 2 - 125.771913), round(h - 641.145393)); + writeln(round(w / 2 - 125.695065), round(h - 640.998007)); + writeln(round(w / 2 - 125.618583), round(h - 640.851372)); + writeln(round(w / 2 - 125.542449), round(h - 640.705414)); + writeln(round(w / 2 - 125.466671), round(h - 640.560132)); + writeln(round(w / 2 - 125.391251), round(h - 640.415525)); + writeln(round(w / 2 - 125.316178), round(h - 640.271595)); + writeln(round(w / 2 - 125.241471), round(h - 640.128341)); + writeln(round(w / 2 - 125.167121), round(h - 639.985763)); + writeln(round(w / 2 - 125.093118), round(h - 639.843861)); + writeln(round(w / 2 - 125.019472), round(h - 639.702711)); + writeln(round(w / 2 - 124.873260), round(h - 639.422287)); +end; +begin + X +end. diff --git a/mips/tests/webtbs/tw22344.pp b/mips/tests/webtbs/tw22344.pp new file mode 100644 index 0000000000..a20b70ab17 --- /dev/null +++ b/mips/tests/webtbs/tw22344.pp @@ -0,0 +1,24 @@ +program showbug ; + +{$mode macpas} + +var + glob: integer; + +function countchars: INTEGER ; +begin + countchars:=255; + if glob=5 then + countchars := 0 + else + begin + inc(glob); + countchars := 1 + countchars + end + end; + +begin + if countchars<>5 then + halt(1); +end . + |