diff options
author | nickysn <nickysn@3ad0048d-3df7-0310-abae-a5850022a9f2> | 2021-03-08 00:52:43 +0000 |
---|---|---|
committer | nickysn <nickysn@3ad0048d-3df7-0310-abae-a5850022a9f2> | 2021-03-08 00:52:43 +0000 |
commit | 62c237e276fb82d4b6f2ea98b9c0014279cda9b7 (patch) | |
tree | 1ac876dc6e8dc31d920557e2ed2451fac8f0079d | |
parent | efc9f396e6322803ca30817ffbb7efa47f056254 (diff) | |
parent | 4651201c4ac47d0c9f757aa9c5032c38e74ac89d (diff) | |
download | fpc-62c237e276fb82d4b6f2ea98b9c0014279cda9b7.tar.gz |
* synchronized with trunk
git-svn-id: https://svn.freepascal.org/svn/fpc/branches/wasm@48906 3ad0048d-3df7-0310-abae-a5850022a9f2
59 files changed, 2374 insertions, 1891 deletions
diff --git a/compiler/Makefile b/compiler/Makefile index 821f0612d5..6c7e02ac48 100644 --- a/compiler/Makefile +++ b/compiler/Makefile @@ -4946,7 +4946,7 @@ endif $(COMPILER) pp.pas $(EXECPPAS) $(MOVE) $(COMPILER_TARGETDIR)/$(PPEXENAME) $(EXENAME) -.PHONY: cycle fullcycle wpocycle +.PHONY: cycle full full_targets fullcycle wpocycle ifeq ($(CPU_SOURCE),$(PPC_TARGET)) ifeq ($(OS_SOURCE),$(OS_TARGET)) ifndef NOWPOCYCLE @@ -5113,6 +5113,8 @@ ifdef DOWPOCYCLE $(MAKE) rtl 'FPC=$(BASEDIR)/$(EXENAMEPREFIX)$(EXENAME)' endif $(MAKE) $(FULL_TARGETS) 'FPC=$(BASEDIR)/$(EXENAMEPREFIX)$(EXENAME)' +full_targets: + $(MAKE) $(FULL_TARGETS) 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 installsymlink fullinstall fullinstallsymlink diff --git a/compiler/Makefile.fpc b/compiler/Makefile.fpc index df64aab8fd..38aa832ddf 100644 --- a/compiler/Makefile.fpc +++ b/compiler/Makefile.fpc @@ -851,7 +851,7 @@ endif # ##################################################################### -.PHONY: cycle fullcycle wpocycle +.PHONY: cycle full full_targets fullcycle wpocycle ifeq ($(CPU_SOURCE),$(PPC_TARGET)) @@ -1056,7 +1056,8 @@ cvstest: # unless FPC_SUPPORT_X87_TYPES_ON_WIN64 is set, # win64 cannot compile i386 or i8086 compiler # This is also the case for other CPUs that don't support -# 80bit real type. +# 80bit real type, unless -dFPC_SOFT_FPUX80 +# option is used. ifeq ($(findstring -dFPC_SOFT_FPUX80,$(LOCALOPT)),) ifeq ($(OS_SOURCE),win64) @@ -1086,6 +1087,9 @@ ifdef DOWPOCYCLE endif $(MAKE) $(FULL_TARGETS) 'FPC=$(BASEDIR)/$(EXENAMEPREFIX)$(EXENAME)' +full_targets: + $(MAKE) $(FULL_TARGETS) + ##################################################################### # Docs ##################################################################### diff --git a/compiler/entfile.pas b/compiler/entfile.pas index 8e2dc3df64..14164f2cb5 100644 --- a/compiler/entfile.pas +++ b/compiler/entfile.pas @@ -380,6 +380,11 @@ end; destructor tentryfile.destroy; begin closefile; +{$ifdef DEBUG_PPU} + if flog_open then + close(flog); + flog_open:=false; +{$endif DEBUG_PPU} if assigned(buf) then freemem(buf,entryfilebufsize); end; @@ -573,11 +578,6 @@ begin f.Free; mode:=0; closed:=true; -{$ifdef DEBUG_PPU} - if flog_open then - close(flog); - flog_open:=false; -{$endif DEBUG_PPU} end; end; @@ -683,14 +683,6 @@ var begin p:=pchar(@b); pbuf:=@buf[bufidx]; -{$ifdef DEBUG_PPU} - if ppu_log_level <= 0 then - begin - ppu_log('writedata, length='+tostr(len)+' level='+tostr(ppu_log_level)); - for i:=0 to len-1 do - ppu_log_val('p['+tostr(i)+']=$'+hexstr(byte(p[i]),2)); - end; -{$endif DEBUG_PPU} repeat left:=bufsize-bufidx; if len<left then @@ -704,6 +696,14 @@ begin exit; until false; move(pbuf^,p^,len); +{$ifdef DEBUG_PPU} + if ppu_log_level <= 0 then + begin + ppu_log('writedata, length='+tostr(len)+' level='+tostr(ppu_log_level)); + for i:=0 to len-1 do + ppu_log_val('p['+tostr(i)+']=$'+hexstr(byte(p[i]),2)); + end; +{$endif DEBUG_PPU} inc(bufidx,len); end; diff --git a/compiler/mips/ncpuadd.pas b/compiler/mips/ncpuadd.pas index 0554620030..0edbf04d8a 100644 --- a/compiler/mips/ncpuadd.pas +++ b/compiler/mips/ncpuadd.pas @@ -36,7 +36,7 @@ type private procedure cmp64_lt(left_reg, right_reg: TRegister64;unsigned:boolean); procedure cmp64_le(left_reg, right_reg: TRegister64;unsigned:boolean); - procedure second_generic_cmp32(unsigned: boolean); + procedure second_generic_cmp32(unsigned,is_smallset: boolean); procedure second_mul64bit; protected procedure second_addfloat; override; @@ -72,18 +72,31 @@ uses tmipsaddnode *****************************************************************************} -procedure tmipsaddnode.second_generic_cmp32(unsigned: boolean); +procedure tmipsaddnode.second_generic_cmp32(unsigned,is_smallset: boolean); var cond: TOpCmp; + allow_constant : boolean; + dreg : tregister; begin pass_left_right; - force_reg_left_right(True, True); + allow_constant:=(not is_smallset) or not (nodetype in [lten,gten]); + force_reg_left_right(True, allow_constant); location_reset(location,LOC_FLAGS,OS_NO); cond:=cmpnode2topcmp(unsigned); if nf_swapped in flags then cond:=swap_opcmp(cond); + if is_smallset and (nodetype in [lten,gten]) then + begin + if ((nodetype=lten) and not (nf_swapped in flags)) or + ((nodetype=gten) and (nf_swapped in flags)) then + dreg:=right.location.register + else + dreg:=left.location.register; + current_asmdata.CurrAsmList.Concat(taicpu.op_reg_reg_reg(A_AND,dreg,right.location.register,left.location.register)); + cond:=OC_EQ; + end; location.resflags.cond:=cond; location.resflags.reg1:=left.location.register; location.resflags.use_const:=(right.location.loc=LOC_CONSTANT); @@ -304,13 +317,13 @@ end; procedure tmipsaddnode.second_cmpboolean; begin - second_generic_cmp32(true); + second_generic_cmp32(true,false); end; procedure tmipsaddnode.second_cmpsmallset; begin - second_generic_cmp32(true); + second_generic_cmp32(true,true); end; @@ -319,7 +332,7 @@ var unsigned: boolean; begin unsigned := not (is_signed(left.resultdef)) or not (is_signed(right.resultdef)); - second_generic_cmp32(unsigned); + second_generic_cmp32(unsigned,false); end; diff --git a/compiler/nadd.pas b/compiler/nadd.pas index 063c81b793..3018e6cf42 100644 --- a/compiler/nadd.pas +++ b/compiler/nadd.pas @@ -1715,6 +1715,7 @@ implementation (left.resultdef.typ=orddef) and (left.nodetype=andn) and (right.nodetype=andn) and + (not(is_boolean(resultdef)) or not(might_have_sideeffects(self,[mhs_exceptions])) or not(doshortbooleval(self))) and { this test is not needed but it speeds up the test and allows to bail out early } ((taddnode(left).left.nodetype=notn) or (taddnode(left).right.nodetype=notn) or (taddnode(right).left.nodetype=notn) or (taddnode(right).right.nodetype=notn) diff --git a/compiler/ncginl.pas b/compiler/ncginl.pas index e19eaa35d9..6e54cfb657 100644 --- a/compiler/ncginl.pas +++ b/compiler/ncginl.pas @@ -932,7 +932,8 @@ implementation else {$endif not cpu64bitalu and not cpuhighleveltarget} begin - if not(op2.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then + if not(op2.location.loc in [LOC_REGISTER,LOC_CREGISTER]) or + not(equal_defs(op2.resultdef,resultdef)) then hlcg.location_force_reg(current_asmdata.CurrAsmList,op2.location, op2.resultdef,resultdef,true); hlcg.a_op_reg_reg_reg(current_asmdata.CurrAsmList,op,resultdef, diff --git a/compiler/options.pas b/compiler/options.pas index c84bff9a23..b2ecee0870 100644 --- a/compiler/options.pas +++ b/compiler/options.pas @@ -212,6 +212,7 @@ var p : pchar; hs,hs1,hs3,s : TCmdStr; J: longint; + xmloutput: Text; const NewLineStr = '$\n'; OSTargetsPlaceholder = '$OSTARGETS'; @@ -407,6 +408,17 @@ const end; end; + procedure ListOptimizationsXML; + var + opt: toptimizerswitch; + begin + WriteLn(xmloutput,'<optimizations>'); + for opt:=low(toptimizerswitch) to high(toptimizerswitch) do + if OptimizerSwitchStr[opt]<>'' then + WriteLn(xmloutput,'<optimization name="',OptimizerSwitchStr[opt],'"/>'); + WriteLn(xmloutput,'</optimizations>'); + end; + procedure ListWPOptimizations (OrigString: TCmdStr); var wpopt: twpoptimizerswitch; @@ -502,6 +514,23 @@ const {$POP} end; + procedure ListControllerTypesXML; + var + controllertype : tcontrollertype; + begin +{$PUSH} + {$WARN 6018 OFF} (* Unreachable code due to compile time evaluation *) + if (ControllerSupport) then + begin + WriteLn(xmloutput,'<controllertypes>'); + for controllertype:=low(tcontrollertype) to high(tcontrollertype) do + if embedded_controllers[controllertype].ControllerTypeStr<>'' then + WriteLn(xmloutput,'<controllertype name="',embedded_controllers[controllertype].ControllerTypeStr,'"/>'); + WriteLn(xmloutput,'</controllertypes>'); + end; +{$POP} + end; + procedure ListFeatures (OrigString: TCmdStr); var Feature: TFeature; @@ -627,31 +656,44 @@ begin Comment(V_Normal,s); end; end + else if Copy(More,1,1) = 'x' then + begin + Assign(xmloutput,Copy(More,2,length(More)-1)); + Rewrite(xmloutput); + WriteLn(xmloutput,'<?xml version="1.0" encoding="utf-8"?>'); + WriteLn(xmloutput,'<fpcoutput>'); + WriteLn(xmloutput,'<info>'); + ListOptimizationsXML; + ListControllerTypesXML; + WriteLn(xmloutput,'</info>'); + WriteLn(xmloutput,'</fpcoutput>'); + Close(xmloutput); + end else begin - J := 1; - while J <= Length (More) do - begin - if J > 1 then - Comment(V_Normal,''); (* Put empty line between multiple sections *) - case More [J] of - 'a': ListABITargets (''); - 'b': Comment(V_Normal, cgbackend2str[cgbackend]); - 'c': ListCPUInstructionSets (''); - 'f': ListFPUInstructionSets (''); - 'i': ListAsmModes (''); - 'm': ListModeswitches (''); - 'o': ListOptimizations (''); - 'r': ListFeatures (''); - 't': ListOSTargets (''); - 'u': ListControllerTypes (''); - 'w': ListWPOptimizations (''); - else - IllegalPara ('-i' + More); + J := 1; + while J <= Length (More) do + begin + if J > 1 then + Comment(V_Normal,''); (* Put empty line between multiple sections *) + case More [J] of + 'a': ListABITargets (''); + 'b': Comment(V_Normal, cgbackend2str[cgbackend]); + 'c': ListCPUInstructionSets (''); + 'f': ListFPUInstructionSets (''); + 'i': ListAsmModes (''); + 'm': ListModeswitches (''); + 'o': ListOptimizations (''); + 'r': ListFeatures (''); + 't': ListOSTargets (''); + 'u': ListControllerTypes (''); + 'w': ListWPOptimizations (''); + else + IllegalPara ('-i' + More); + end; + Inc (J); end; - Inc (J); - end; - end; + end; StopOptions(0); end; @@ -1955,7 +1997,7 @@ begin 'i' : begin if (More='') or - (More [1] in ['a', 'b', 'c', 'f', 'i', 'm', 'o', 'r', 't', 'u', 'w']) then + (More [1] in ['a', 'b', 'c', 'f', 'i', 'm', 'o', 'r', 't', 'u', 'w', 'x']) then WriteInfo (More) else QuickInfo:=QuickInfo+More; diff --git a/compiler/raatt.pas b/compiler/raatt.pas index 92d1e8c6ad..0bb96d9ec5 100644 --- a/compiler/raatt.pas +++ b/compiler/raatt.pas @@ -53,7 +53,7 @@ unit raatt; AS_DB,AS_DW,AS_DD,AS_DQ,AS_GLOBAL, AS_ALIGN,AS_BALIGN,AS_P2ALIGN,AS_ASCII, AS_ASCIIZ,AS_LCOMM,AS_COMM,AS_SINGLE,AS_DOUBLE,AS_EXTENDED,AS_CEXTENDED, - AS_DATA,AS_TEXT,AS_INIT,AS_FINI,AS_RVA, + AS_DATA,AS_TEXT,AS_INIT,AS_FINI,AS_RVA,AS_DC_A, AS_SET,AS_WEAK,AS_SECTION,AS_END, {------------------ Assembler Operators --------------------} AS_TYPE,AS_SIZEOF,AS_VMTOFFSET,AS_MOD,AS_SHL,AS_SHR,AS_NOT,AS_AND,AS_OR,AS_XOR,AS_NOR,AS_AT, @@ -80,7 +80,7 @@ unit raatt; '.byte','.word','.long','.quad','.globl', '.align','.balign','.p2align','.ascii', '.asciz','.lcomm','.comm','.single','.double','.tfloat','.tcfloat', - '.data','.text','.init','.fini','.rva', + '.data','.text','.init','.fini','.rva','.dc.a', '.set','.weak','.section','END', 'TYPE','SIZEOF','VMTOFFSET','%','<<','>>','!','&','|','^','~','@','reltype', 'directive'); @@ -227,7 +227,7 @@ unit raatt; actasmpattern[len]:=c; { Let us point to the next character } c:=current_scanner.asmgetchar; - while c in ['A'..'Z','a'..'z','0'..'9','_','$'] do + while c in ['A'..'Z','a'..'z','0'..'9','_','$','.'] do begin inc(len); actasmpattern[len]:=c; @@ -1076,6 +1076,7 @@ unit raatt; section : tai_section; secflags : TSectionFlags; secprogbits : TSectionProgbits; + i: Integer; Begin Message1(asmr_d_start_reading,'GNU AS'); firsttoken:=TRUE; @@ -1163,6 +1164,12 @@ unit raatt; BuildConstant(4); end; + AS_DC_A: + Begin + Consume(AS_DC_A); + BuildConstant(sizeof(aint)); + end; + AS_DQ: Begin Consume(AS_DQ); @@ -1342,18 +1349,17 @@ unit raatt; Consume(AS_COMMA); if actasmtoken=AS_STRING then begin - case actasmpattern of - 'a': - Include(secflags,SF_A); - 'w': - Include(secflags,SF_W); - 'x': - Include(secflags,SF_X); - '': - ; - else - Message(asmr_e_syntax_error); - end; + for i:=1 to length(actasmpattern) do + case actasmpattern[i] of + 'a': + Include(secflags,SF_A); + 'w': + Include(secflags,SF_W); + 'x': + Include(secflags,SF_X); + else + Message(asmr_e_syntax_error); + end; Consume(AS_STRING); if actasmtoken=AS_COMMA then begin diff --git a/compiler/riscv/agrvgas.pas b/compiler/riscv/agrvgas.pas index 4ed6c30e82..a71a06aa74 100644 --- a/compiler/riscv/agrvgas.pas +++ b/compiler/riscv/agrvgas.pas @@ -130,7 +130,9 @@ unit agrvgas; s:=s+gas_regname(base)+','+gas_regname(index) else internalerror(2006052502); - end; + end + else + Internalerror(2021030602); case refaddr of addr_lo12: s:='%lo'+s; diff --git a/compiler/riscv/cgrv.pas b/compiler/riscv/cgrv.pas index 66f02bdaf6..9b5443b7cf 100644 --- a/compiler/riscv/cgrv.pas +++ b/compiler/riscv/cgrv.pas @@ -258,6 +258,10 @@ unit cgrv; procedure tcgrv.a_op_reg_reg_reg(list: TAsmList; op: TOpCg; size: tcgsize; src1, src2, dst: tregister); + var + name: String; + pd: tprocdef; + paraloc1, paraloc2: tcgpara; begin if op=OP_NOT then begin @@ -295,6 +299,47 @@ unit cgrv; end else {$endif RISCV64} + if (op in [OP_IMUL,OP_MUL]) and not(CPURV_HAS_MUL in cpu_capabilities[current_settings.cputype]) then + begin + case size of + OS_8: + name:='fpc_mul_byte'; + OS_S8: + name:='fpc_mul_shortint'; + OS_16: + name:='fpc_mul_word'; + OS_S16: + name:='fpc_mul_integer'; + OS_32: + name:='fpc_mul_dword'; + OS_S32: + name:='fpc_mul_longint'; + else + Internalerror(2021030601); + end; + +// if check_overflow then +// name:=name+'_checkoverflow'; + + pd:=search_system_proc(name); + paraloc1.init; + paraloc2.init; + paramanager.getcgtempparaloc(list,pd,1,paraloc1); + paramanager.getcgtempparaloc(list,pd,2,paraloc2); + a_load_reg_cgpara(list,OS_8,src1,paraloc2); + a_load_reg_cgpara(list,OS_8,src2,paraloc1); + paramanager.freecgpara(list,paraloc2); + paramanager.freecgpara(list,paraloc1); + alloccpuregisters(list,R_INTREGISTER,paramanager.get_volatile_registers_int(pocall_default)); + a_call_name(list,upper(name),false); + dealloccpuregisters(list,R_INTREGISTER,paramanager.get_volatile_registers_int(pocall_default)); + cg.a_reg_alloc(list,NR_FUNCTION_RESULT_REG); + cg.a_load_reg_reg(list,size,size,NR_FUNCTION_RESULT_REG,dst); + cg.a_reg_dealloc(list,NR_FUNCTION_RESULT_REG); + paraloc2.done; + paraloc1.done; + end + else begin list.concat(taicpu.op_reg_reg_reg(TOpCG2AsmOp[op],dst,src2,src1)); maybeadjustresult(list,op,size,dst); diff --git a/compiler/riscv/nrvadd.pas b/compiler/riscv/nrvadd.pas index 734aa6d09a..b081612997 100644 --- a/compiler/riscv/nrvadd.pas +++ b/compiler/riscv/nrvadd.pas @@ -34,7 +34,7 @@ unit nrvadd; trvaddnode = class(tcgaddnode) function pass_1: tnode; override; protected - procedure Cmp(signed: boolean); + procedure Cmp(signed,is_smallset: boolean); function use_mul_helper: boolean; override; @@ -72,14 +72,17 @@ implementation low_value = {$ifdef CPU64BITALU} low(int64) {$else} low(longint) {$endif}; {$endif} - procedure trvaddnode.Cmp(signed: boolean); + procedure trvaddnode.Cmp(signed,is_smallset: boolean); var flabel,tlabel: tasmlabel; op, opi: TAsmOp; + allow_constant : boolean; begin pass_left_right; - force_reg_left_right(true,true); + allow_constant:=(not is_smallset) or not (nodetype in [lten,gten]); + + force_reg_left_right(true,allow_constant); if nf_swapped in flags then swapleftright; @@ -164,12 +167,20 @@ implementation if (left.location.loc=LOC_CONSTANT) and (not is_imm12(left.location.value)) then hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,left.resultdef,left.resultdef,false); - - if left.location.loc=LOC_CONSTANT then - current_asmdata.CurrAsmList.Concat(taicpu.op_reg_reg_const(opi,location.register,right.location.register,left.location.value)) + if is_smallset then + begin + current_asmdata.CurrAsmList.Concat(taicpu.op_reg_reg_reg(A_AND,right.location.register,right.location.register,left.location.register)); + current_asmdata.CurrAsmList.Concat(taicpu.op_reg_reg_reg(A_SUB,location.register,left.location.register,right.location.register)); + current_asmdata.CurrAsmList.Concat(taicpu.op_reg_reg_const(A_SLTIU,location.register,location.register,1)); + end else - current_asmdata.CurrAsmList.Concat(taicpu.op_reg_reg_reg(op,location.register,right.location.register,left.location.register)); - current_asmdata.CurrAsmList.Concat(taicpu.op_reg_reg_const(A_SLTIU,location.register,location.register,1)); + begin + if left.location.loc=LOC_CONSTANT then + current_asmdata.CurrAsmList.Concat(taicpu.op_reg_reg_const(opi,location.register,right.location.register,left.location.value)) + else + current_asmdata.CurrAsmList.Concat(taicpu.op_reg_reg_reg(op,location.register,right.location.register,left.location.register)); + current_asmdata.CurrAsmList.Concat(taicpu.op_reg_reg_const(A_SLTIU,location.register,location.register,1)); + end; end; gten: begin @@ -179,12 +190,20 @@ implementation if (right.location.loc=LOC_CONSTANT) and (not is_imm12(right.location.value)) then hlcg.location_force_reg(current_asmdata.CurrAsmList,right.location,right.resultdef,right.resultdef,false); - - if right.location.loc=LOC_CONSTANT then - current_asmdata.CurrAsmList.Concat(taicpu.op_reg_reg_const(opi,location.register,left.location.register,right.location.value)) + if is_smallset then + begin + current_asmdata.CurrAsmList.Concat(taicpu.op_reg_reg_reg(A_AND,left.location.register,right.location.register,left.location.register)); + current_asmdata.CurrAsmList.Concat(taicpu.op_reg_reg_reg(A_SUB,location.register,left.location.register,right.location.register)); + current_asmdata.CurrAsmList.Concat(taicpu.op_reg_reg_const(A_SLTIU,location.register,location.register,1)); + end else - current_asmdata.CurrAsmList.Concat(taicpu.op_reg_reg_reg(op,location.register,left.location.register,right.location.register)); - current_asmdata.CurrAsmList.Concat(taicpu.op_reg_reg_const(A_SLTIU,location.register,location.register,1)); + begin + if right.location.loc=LOC_CONSTANT then + current_asmdata.CurrAsmList.Concat(taicpu.op_reg_reg_const(opi,location.register,left.location.register,right.location.value)) + else + current_asmdata.CurrAsmList.Concat(taicpu.op_reg_reg_reg(op,location.register,left.location.register,right.location.register)); + current_asmdata.CurrAsmList.Concat(taicpu.op_reg_reg_const(A_SLTIU,location.register,location.register,1)); + end; end; else Internalerror(2016061101); @@ -194,9 +213,7 @@ implementation function trvaddnode.use_mul_helper: boolean; begin - if not (CPURV_HAS_MUL in cpu_capabilities[current_settings.cputype]) and - (nodetype=muln) and - not(torddef(resultdef).ordtype in [u8bit,s8bit]) then + if (nodetype=muln) and not(CPURV_HAS_MUL in cpu_capabilities[current_settings.cputype]) then result:=true else Result:=inherited use_mul_helper; @@ -205,7 +222,7 @@ implementation procedure trvaddnode.second_cmpsmallset; begin - Cmp(true); + Cmp(false,true); end; @@ -216,7 +233,7 @@ implementation unsigned:=not(is_signed(left.resultdef)) or not(is_signed(right.resultdef)); - Cmp(not unsigned); + Cmp(not unsigned,false); end; @@ -227,7 +244,7 @@ implementation unsigned:=not(is_signed(left.resultdef)) or not(is_signed(right.resultdef)); - Cmp(not unsigned); + Cmp(not unsigned,false); end; diff --git a/compiler/riscv64/rarv.pas b/compiler/riscv/rarv.pas index b02c55abab..b02c55abab 100644 --- a/compiler/riscv64/rarv.pas +++ b/compiler/riscv/rarv.pas diff --git a/compiler/riscv/rarvgas.pas b/compiler/riscv/rarvgas.pas index 97bacda10e..f71b568781 100644 --- a/compiler/riscv/rarvgas.pas +++ b/compiler/riscv/rarvgas.pas @@ -26,12 +26,21 @@ unit rarvgas; interface uses - raatt, + raatt,rarv, cpubase; type - trvattreader = class(tattreader) + trvgasreader = class(tattreader) + actmemoryordering: TMemoryOrdering; + function is_register(const s: string): boolean; override; + function is_asmopcode(const s: string):boolean;override; + procedure handleopcode;override; + procedure BuildReference(oper : trvoperand); + procedure BuildOperand(oper : trvoperand); + procedure BuildOpCode(instr : trvinstruction); + procedure ReadAt(oper : trvoperand); + procedure ReadSym(oper : trvoperand); function is_targetdirective(const s: string): boolean; override; procedure HandleTargetDirective; override; end; @@ -54,7 +63,7 @@ unit rarvgas; cgbase,cgobj,cgrv ; - function trvattreader.is_targetdirective(const s: string): boolean; + function trvgasreader.is_targetdirective(const s: string): boolean; begin case s of '.option': @@ -64,7 +73,8 @@ unit rarvgas; end; end; - procedure trvattreader.HandleTargetDirective; + + procedure trvgasreader.HandleTargetDirective; var id: string; begin @@ -81,5 +91,806 @@ unit rarvgas; end; end; + + procedure trvgasreader.ReadSym(oper : trvoperand); + var + tempstr, mangledname : string; + typesize,l,k : TCGInt; + begin + tempstr:=actasmpattern; + Consume(AS_ID); + { typecasting? } + if (actasmtoken=AS_LPAREN) and + SearchType(tempstr,typesize) then + begin + oper.hastype:=true; + Consume(AS_LPAREN); + BuildOperand(oper); + Consume(AS_RPAREN); + if oper.opr.typ in [OPR_REFERENCE,OPR_LOCAL] then + oper.SetSize(typesize,true); + end + else + if not oper.SetupVar(tempstr,false) then + Message1(sym_e_unknown_id,tempstr); + { record.field ? } + if actasmtoken=AS_DOT then + begin + BuildRecordOffsetSize(tempstr,l,k,mangledname,false); + if (mangledname<>'') then + Message(asmr_e_invalid_reference_syntax); + inc(oper.opr.ref.offset,l); + end; + end; + + + procedure trvgasreader.ReadAt(oper : trvoperand); + begin + { check for ...@ } + if actasmtoken=AS_AT then + begin + if (oper.opr.ref.symbol=nil) and + (oper.opr.ref.offset = 0) then + Message(asmr_e_invalid_reference_syntax); + Consume(AS_AT); + if actasmtoken=AS_ID then + begin + {if upper(actasmpattern)='L' then + oper.opr.ref.refaddr:=addr_low + else if upper(actasmpattern)='HI' then + oper.opr.ref.refaddr:=addr_high + else if upper(actasmpattern)='HA' then + oper.opr.ref.refaddr:=addr_higha + else} + Message(asmr_e_invalid_reference_syntax); + Consume(AS_ID); + end + else + Message(asmr_e_invalid_reference_syntax); + end; + end; + + + procedure trvgasreader.BuildReference(oper: trvoperand); + + procedure Consume_RParen; + begin + if actasmtoken <> AS_RPAREN then + Begin + Message(asmr_e_invalid_reference_syntax); + RecoverConsume(true); + end + else + begin + Consume(AS_RPAREN); + if not (actasmtoken in [AS_COMMA,AS_SEPARATOR,AS_END]) then + Begin + Message(asmr_e_invalid_reference_syntax); + RecoverConsume(true); + end; + end; + end; + + var + l : TCGInt; + relsym: string; + asmsymtyp: tasmsymtype; + isflags: tindsymflags; + + begin + Consume(AS_LPAREN); + Case actasmtoken of + AS_INTNUM, + AS_MINUS, + AS_PLUS: + Begin + { offset(offset) is invalid } + If oper.opr.Ref.Offset <> 0 Then + Begin + Message(asmr_e_invalid_reference_syntax); + RecoverConsume(true); + End + Else + Begin + oper.opr.Ref.Offset:=BuildConstExpression(false,true); + Consume(AS_RPAREN); + if actasmtoken=AS_AT then + ReadAt(oper); + end; + exit; + End; + AS_REGISTER: { (reg ... } + Begin + if ((oper.opr.typ=OPR_REFERENCE) and (oper.opr.ref.base<>NR_NO)) or + ((oper.opr.typ=OPR_LOCAL) and (oper.opr.localsym.localloc.loc<>LOC_REGISTER)) then + message(asmr_e_cannot_index_relative_var); + oper.opr.ref.base:=actasmregister; + Consume(AS_REGISTER); + Consume_RParen; + end; {end case } + AS_ID: + Begin + ReadSym(oper); + case actasmtoken of + AS_PLUS: + begin + { add a constant expression? } + l:=BuildConstExpression(true,true); + case oper.opr.typ of + OPR_CONSTANT : + inc(oper.opr.val,l); + OPR_LOCAL : + inc(oper.opr.localsymofs,l); + OPR_REFERENCE : + inc(oper.opr.ref.offset,l); + else + internalerror(2003092016); + end; + end; + AS_MINUS: + begin + Consume(AS_MINUS); + BuildConstSymbolExpression(false,true,false,l,relsym,asmsymtyp); + if (relsym<>'') then + begin + if (oper.opr.typ = OPR_REFERENCE) then + oper.opr.ref.relsymbol:=current_asmdata.RefAsmSymbol(relsym,AT_DATA) + else + begin + Message(asmr_e_invalid_reference_syntax); + RecoverConsume(false); + end + end + else + begin + case oper.opr.typ of + OPR_CONSTANT : + dec(oper.opr.val,l); + OPR_LOCAL : + dec(oper.opr.localsymofs,l); + OPR_REFERENCE : + dec(oper.opr.ref.offset,l); + else + internalerror(2007092601); + end; + end; + end; + else + ; + end; + Consume(AS_RPAREN); + if actasmtoken=AS_AT then + ReadAt(oper); + End; + AS_COMMA: { (, ... can either be scaling, or index } + Begin + Consume(AS_COMMA); + { Index } + if (actasmtoken=AS_REGISTER) then + Begin + oper.opr.ref.index:=actasmregister; + Consume(AS_REGISTER); + { check for scaling ... } + Consume_RParen; + end + else + begin + Message(asmr_e_invalid_reference_syntax); + RecoverConsume(false); + end; + end; + else + Begin + Message(asmr_e_invalid_reference_syntax); + RecoverConsume(false); + end; + end; + end; + + + procedure trvgasreader.BuildOperand(oper: trvoperand); + var + expr : string; + typesize,l : TCGInt; + + + procedure AddLabelOperand(hl:tasmlabel); + begin + if not(actasmtoken in [AS_PLUS,AS_MINUS,AS_LPAREN]) and + is_calljmp(actopcode) then + begin + oper.opr.typ:=OPR_SYMBOL; + oper.opr.symbol:=hl; + end + else + begin + oper.InitRef; + oper.opr.ref.symbol:=hl; + end; + end; + + + procedure MaybeRecordOffset; + var + mangledname: string; + hasdot : boolean; + l, + toffset, + tsize : TCGInt; + begin + if not(actasmtoken in [AS_DOT,AS_PLUS,AS_MINUS]) then + exit; + l:=0; + hasdot:=(actasmtoken=AS_DOT); + if hasdot then + begin + if expr<>'' then + begin + BuildRecordOffsetSize(expr,toffset,tsize,mangledname,false); + if (oper.opr.typ<>OPR_CONSTANT) and + (mangledname<>'') then + Message(asmr_e_wrong_sym_type); + inc(l,toffset); + oper.SetSize(tsize,true); + end; + end; + if actasmtoken in [AS_PLUS,AS_MINUS] then + inc(l,BuildConstExpression(true,false)); + case oper.opr.typ of + OPR_LOCAL : + begin + { don't allow direct access to fields of parameters, because that + will generate buggy code. Allow it only for explicit typecasting } + if hasdot and + (not oper.hastype) and + (tabstractvarsym(oper.opr.localsym).owner.symtabletype=parasymtable) and + (current_procinfo.procdef.proccalloption<>pocall_register) then + Message(asmr_e_cannot_access_field_directly_for_parameters); + inc(oper.opr.localsymofs,l) + end; + OPR_CONSTANT : + if (mangledname<>'') then + begin + if (oper.opr.val<>0) then + Message(asmr_e_wrong_sym_type); + oper.opr.typ:=OPR_SYMBOL; + oper.opr.symbol:=current_asmdata.DefineAsmSymbol(mangledname,AB_EXTERNAL,AT_FUNCTION,voidcodepointertype); + end + else + inc(oper.opr.val,l); + OPR_REFERENCE : + inc(oper.opr.ref.offset,l); + OPR_SYMBOL: + Message(asmr_e_invalid_symbol_ref); + else + internalerror(200309221); + end; + end; + + + function MaybeBuildReference:boolean; + { Try to create a reference, if not a reference is found then false + is returned } + begin + MaybeBuildReference:=true; + case actasmtoken of + AS_INTNUM, + AS_MINUS, + AS_PLUS: + Begin + oper.opr.ref.offset:=BuildConstExpression(True,False); + if actasmtoken<>AS_LPAREN then + Message(asmr_e_invalid_reference_syntax) + else + BuildReference(oper); + end; + AS_LPAREN: + BuildReference(oper); + AS_ID: { only a variable is allowed ... } + Begin + ReadSym(oper); + case actasmtoken of + AS_END, + AS_SEPARATOR, + AS_COMMA: ; + AS_LPAREN: + BuildReference(oper); + else + Begin + Message(asmr_e_invalid_reference_syntax); + Consume(actasmtoken); + end; + end; {end case } + end; + else + MaybeBuildReference:=false; + end; { end case } + end; + + + function is_fenceflag(hs : string): boolean; + var + i: longint; + flags: TFenceFlags; + begin + is_fenceflag := false; + + flags:=[]; + hs:=lower(hs); + + if (actopcode in [A_FENCE]) and (length(hs) >= 1) then + begin + for i:=1 to length(hs) do + begin + case hs[i] of + 'i': + Include(flags,ffi); + 'o': + Include(flags,ffo); + 'r': + Include(flags,ffr); + 'w': + Include(flags,ffw); + else + exit; + end; + end; + oper.opr.typ := OPR_FENCEFLAGS; + oper.opr.fenceflags := flags; + exit(true); + end; + end; + + + var + tempreg : tregister; + hl : tasmlabel; + ofs : aint; + refaddr: trefaddr; + entered_paren: Boolean; + Begin + expr:=''; + entered_paren:=false; + + refaddr:=addr_full; + if actasmtoken=AS_MOD then + begin + consume(AS_MOD); + + if actasmtoken<>AS_ID then + begin + Message(asmr_e_invalid_reference_syntax); + RecoverConsume(false); + end + else + begin + if lower(actasmpattern)='pcrel_hi' then + refaddr:=addr_pcrel_hi20 + else if lower(actasmpattern)='pcrel_lo' then + refaddr:=addr_pcrel_lo12 + else if lower(actasmpattern)='hi' then + refaddr:=addr_hi20 + else if lower(actasmpattern)='lo' then + refaddr:=addr_lo12 + else + begin + Message(asmr_e_invalid_reference_syntax); + RecoverConsume(false); + end; + + consume(AS_ID); + consume(AS_LPAREN); + entered_paren:=true; + end; + end; + + case actasmtoken of + AS_LPAREN: { Memory reference or constant expression } + Begin + oper.InitRef; + BuildReference(oper); + end; + + AS_INTNUM, + AS_MINUS, + AS_PLUS: + Begin + { Constant memory offset } + { This must absolutely be followed by ( } + oper.InitRef; + oper.opr.ref.offset:=BuildConstExpression(True,False); + if actasmtoken<>AS_LPAREN then + begin + ofs:=oper.opr.ref.offset; + BuildConstantOperand(oper); + inc(oper.opr.val,ofs); + end + else + BuildReference(oper); + end; + + AS_DOT, + AS_ID: { A constant expression, or a Variable ref. } + Begin + if is_fenceflag(actasmpattern) then + begin + consume(AS_ID); + end + else + { Local Label ? } + if is_locallabel(actasmpattern) then + begin + CreateLocalLabel(actasmpattern,hl,false); + Consume(AS_ID); + AddLabelOperand(hl); + end + else + { Check for label } + if SearchLabel(actasmpattern,hl,false) then + begin + Consume(AS_ID); + AddLabelOperand(hl); + end + else + { probably a variable or normal expression } + { or a procedure (such as in CALL ID) } + Begin + { is it a constant ? } + if SearchIConstant(actasmpattern,l) then + Begin + if not (oper.opr.typ in [OPR_NONE,OPR_CONSTANT]) then + Message(asmr_e_invalid_operand_type); + BuildConstantOperand(oper); + end + else + begin + expr:=actasmpattern; + Consume(AS_ID); + { typecasting? } + if (actasmtoken=AS_LPAREN) and + SearchType(expr,typesize) then + begin + oper.hastype:=true; + Consume(AS_LPAREN); + BuildOperand(oper); + Consume(AS_RPAREN); + if oper.opr.typ in [OPR_REFERENCE,OPR_LOCAL] then + oper.SetSize(typesize,true); + end + else + begin + if oper.SetupVar(expr,false) then + ReadAt(oper) + else + Begin + { look for special symbols ... } + if expr= '__HIGH' then + begin + consume(AS_LPAREN); + if not oper.setupvar('high'+actasmpattern,false) then + Message1(sym_e_unknown_id,'high'+actasmpattern); + consume(AS_ID); + consume(AS_RPAREN); + end + else + if expr = '__RESULT' then + oper.SetUpResult + else + if expr = '__SELF' then + oper.SetupSelf + else + if expr = '__OLDEBP' then + oper.SetupOldEBP + else + Message1(sym_e_unknown_id,expr); + end; + end; + end; + if actasmtoken=AS_DOT then + MaybeRecordOffset; + { add a constant expression? } + if (actasmtoken=AS_PLUS) then + begin + l:=BuildConstExpression(true,entered_paren); + case oper.opr.typ of + OPR_CONSTANT : + inc(oper.opr.val,l); + OPR_LOCAL : + inc(oper.opr.localsymofs,l); + OPR_REFERENCE : + inc(oper.opr.ref.offset,l); + else + internalerror(2003092017); + end; + end + end; + { Do we have a indexing reference, then parse it also } + if actasmtoken=AS_LPAREN then + begin + oper.InitRef; + BuildReference(oper); + end; + end; + AS_REGISTER: { Register, a variable reference or a constant reference } + Begin + { save the type of register used. } + tempreg:=actasmregister; + Consume(AS_REGISTER); + if (actasmtoken in [AS_END,AS_SEPARATOR,AS_COMMA]) then + begin + if not (oper.opr.typ in [OPR_NONE,OPR_REGISTER]) then + Message(asmr_e_invalid_operand_type); + oper.opr.typ:=OPR_REGISTER; + oper.opr.reg:=tempreg; + end + else + Message(asmr_e_syn_operand); + end; + AS_END, + AS_SEPARATOR, + AS_COMMA: ; + else + Begin + Message(asmr_e_syn_operand); + Consume(actasmtoken); + end; + end; { end case } + + if refaddr<>addr_full then + begin + if oper.opr.typ<>OPR_REFERENCE then + oper.InitRef; + + oper.opr.ref.refaddr:=refaddr; + Consume(AS_RPAREN); + end + else if (oper.opr.typ=OPR_REFERENCE) and + (oper.opr.ref.refaddr=addr_no) and + assigned(oper.opr.ref.symbol) then + oper.opr.ref.refaddr:=addr_full; + end; + + +{***************************************************************************** + trvgasreader +*****************************************************************************} + + procedure trvgasreader.BuildOpCode(instr : trvinstruction); + var + operandnum : longint; + Begin + { opcode } + if (actasmtoken<>AS_OPCODE) then + Begin + Message(asmr_e_invalid_or_missing_opcode); + RecoverConsume(true); + exit; + end; + { Fill the instr object with the current state } + with instr do + begin + Opcode:=ActOpcode; + condition:=ActCondition; + ordering:=actmemoryordering; + end; + + { We are reading operands, so opcode will be an AS_ID } + operandnum:=1; + Consume(AS_OPCODE); + { Zero operand opcode ? } + if actasmtoken in [AS_SEPARATOR,AS_END] then + begin + operandnum:=0; + exit; + end; + { Read the operands } + repeat + case actasmtoken of + AS_COMMA: { Operand delimiter } + Begin + if operandnum>Max_Operands then + Message(asmr_e_too_many_operands) + else + begin + { condition operands doesn't set the operand but write to the + condition field of the instruction + } + if instr.Operands[operandnum].opr.typ<>OPR_NONE then + Inc(operandnum); + end; + Consume(AS_COMMA); + end; + AS_SEPARATOR, + AS_END : { End of asm operands for this opcode } + begin + break; + end; + else + BuildOperand(instr.Operands[operandnum] as trvoperand); + end; { end case } + until false; + if (operandnum=1) and (instr.Operands[operandnum].opr.typ=OPR_NONE) then + dec(operandnum); + instr.Ops:=operandnum; + end; + + function trvgasreader.is_register(const s: string): boolean; + type + treg2str = record + name : string[3]; + reg : tregister; + end; + + const + extraregs : array[0..31] of treg2str = ( + (name: 'A0'; reg : NR_X10), + (name: 'A1'; reg : NR_X11), + (name: 'A2'; reg : NR_X12), + (name: 'A3'; reg : NR_X13), + (name: 'A4'; reg : NR_X14), + (name: 'A5'; reg : NR_X15), + (name: 'A6'; reg : NR_X16), + (name: 'A7'; reg : NR_X17), + (name: 'RA'; reg : NR_X1), + (name: 'SP'; reg : NR_X2), + (name: 'GP'; reg : NR_X3), + (name: 'TP'; reg : NR_X4), + (name: 'T0'; reg : NR_X5), + (name: 'T1'; reg : NR_X6), + (name: 'T2'; reg : NR_X7), + (name: 'S0'; reg : NR_X8), + (name: 'FP'; reg : NR_X8), + (name: 'S1'; reg : NR_X9), + (name: 'S2'; reg : NR_X18), + (name: 'S3'; reg : NR_X19), + (name: 'S4'; reg : NR_X20), + (name: 'S5'; reg : NR_X21), + (name: 'S6'; reg : NR_X22), + (name: 'S7'; reg : NR_X23), + (name: 'S8'; reg : NR_X24), + (name: 'S9'; reg : NR_X25), + (name: 'S10';reg : NR_X26), + (name: 'S11';reg : NR_X27), + (name: 'T3'; reg : NR_X28), + (name: 'T4'; reg : NR_X29), + (name: 'T5'; reg : NR_X30), + (name: 'T6'; reg : NR_X31) + ); + + var + i : longint; + + begin + result:=inherited is_register(s); + { reg found? + possible aliases are always 2 char + } + if result or (not (length(s) in [2,3])) then + exit; + for i:=low(extraregs) to high(extraregs) do + begin + if s=extraregs[i].name then + begin + actasmregister:=extraregs[i].reg; + result:=true; + actasmtoken:=AS_REGISTER; + exit; + end; + end; + end; + + + function trvgasreader.is_asmopcode(const s: string):boolean; + var + cond : tasmcond; + hs, postfix : string; + l: longint; + Begin + { making s a value parameter would break other assembler readers } + hs:=s; + is_asmopcode:=false; + + { clear op code } + actopcode:=A_None; + { clear condition } + fillchar(actcondition,sizeof(actcondition),0); + + { check for direction hint } + actopcode := tasmop(ptruint(iasmops.find(hs))); + if actopcode <> A_NONE then + begin + actasmtoken:=AS_OPCODE; + is_asmopcode:=true; + exit; + end; + { not found, check branch instructions } + if hs[1]='B' then + begin + { we can search here without an extra table which is sorted by string length + because we take the whole remaining string without the leading B } + actopcode := A_Bxx; + for cond:=low(TAsmCond) to high(TAsmCond) do + if copy(hs,2,length(s)-1)=uppercond2str[cond] then + begin + actcondition:=cond; + actasmtoken:=AS_OPCODE; + is_asmopcode:=true; + exit; + end; + end; + + { check atomic instructions } + if (pos('AMO',hs)=1) or + (pos('LR', hs)=1) or + (pos('SC', hs)=1) then + begin + l := length(hs)-1; + while l>1 do + begin + actopcode := tasmop(ptruint(iasmops.find(copy(hs,1,l)))); + if actopcode <> A_None then + begin + postfix := copy(hs,l+1,length(hs)-l); + + if postfix='.AQRL' then actmemoryordering:=[moAq,moRl] + else if postfix='.RL' then actmemoryordering:=[moRl] + else if postfix='.AQ' then actmemoryordering:=[moAq] + else + exit; + + actasmtoken:=AS_OPCODE; + is_asmopcode:=true; + exit; + end; + dec(l); + end; + end; + end; + + + procedure trvgasreader.handleopcode; + var + instr : trvinstruction; + begin + instr:=trvinstruction.Create(trvoperand); + BuildOpcode(instr); + instr.condition := actcondition; + { + instr.AddReferenceSizes; + instr.SetInstructionOpsize; + instr.CheckOperandSizes; + } + instr.ConcatInstruction(curlist); + instr.Free; + actmemoryordering:=[]; + end; + + +{***************************************************************************** + Initialize +*****************************************************************************} + + const + asmmode_rv64_standard_info : tasmmodeinfo = + ( + id : asmmode_standard; + idtxt : 'STANDARD'; + casmreader : trvgasreader; + ); + + asmmode_rv32_standard_info : tasmmodeinfo = + ( + id : asmmode_standard; + idtxt : 'STANDARD'; + casmreader : trvgasreader; + ); + +initialization +{$ifdef RISCV32} + RegisterAsmMode(asmmode_rv32_standard_info); +{$endif RISCV32} +{$ifdef RISCV64} + RegisterAsmMode(asmmode_rv64_standard_info); +{$endif RISCV32} end. diff --git a/compiler/riscv32/cputarg.pas b/compiler/riscv32/cputarg.pas index 0643083eee..4c5643fc43 100644 --- a/compiler/riscv32/cputarg.pas +++ b/compiler/riscv32/cputarg.pas @@ -55,7 +55,7 @@ implementation **************************************} {$ifndef NoRaRVGas} - ,rarv32gas + ,rarvgas {$endif NoRaRVGas} {************************************** diff --git a/compiler/riscv32/rarv32.pas b/compiler/riscv32/rarv32.pas deleted file mode 100644 index 8d7d3effad..0000000000 --- a/compiler/riscv32/rarv32.pas +++ /dev/null @@ -1,41 +0,0 @@ -{ - Copyright (c) 1998-2003 by Carl Eric Codere and Peter Vreman - - Handles the common Risc-V32 assembler reader routines - - 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 rarv32; - -{$i fpcdefs.inc} - - interface - - uses - aasmbase,aasmtai,aasmdata,aasmcpu, - cpubase,rautils,cclasses; - - type - TRVOperand=class(TOperand) - end; - - TRVInstruction=class(TInstruction) - end; - - implementation - -end. diff --git a/compiler/riscv32/rarv32gas.pas b/compiler/riscv32/rarv32gas.pas deleted file mode 100644 index dc8c0fbd4d..0000000000 --- a/compiler/riscv32/rarv32gas.pas +++ /dev/null @@ -1,780 +0,0 @@ -{ - Copyright (c) 1998-2002 by Carl Eric Codere and Peter Vreman - - Does the parsing for the Risc-V32 GNU AS styled inline assembler. - - 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 rarv32gas; - -{$i fpcdefs.inc} - - Interface - - uses - raatt,rarv32,rarvgas; - - type - trv32attreader = class(trvattreader) - function is_register(const s: string): boolean; override; - function is_asmopcode(const s: string):boolean;override; - procedure handleopcode;override; - procedure BuildReference(oper : trvoperand); - procedure BuildOperand(oper : trvoperand); - procedure BuildOpCode(instr : trvinstruction); - procedure ReadAt(oper : trvoperand); - procedure ReadSym(oper : trvoperand); - end; - - - Implementation - - uses - { helpers } - cutils, - { global } - globtype,globals,verbose, - systems, - { aasm } - cpubase,aasmbase,aasmtai,aasmdata,aasmcpu, - { symtable } - symconst,symdef,symsym, - { parser } - procinfo, - rabase,rautils, - cgbase,cgobj,cgrv - ; - - procedure trv32attreader.ReadSym(oper : trvoperand); - var - tempstr, mangledname : string; - l,k,typesize : tcgint; - begin - tempstr:=actasmpattern; - Consume(AS_ID); - { typecasting? } - if (actasmtoken=AS_LPAREN) and - SearchType(tempstr,typesize) then - begin - oper.hastype:=true; - Consume(AS_LPAREN); - BuildOperand(oper); - Consume(AS_RPAREN); - if oper.opr.typ in [OPR_REFERENCE,OPR_LOCAL] then - oper.SetSize(typesize,true); - end - else - if not oper.SetupVar(tempstr,false) then - Message1(sym_e_unknown_id,tempstr); - { record.field ? } - if actasmtoken=AS_DOT then - begin - BuildRecordOffsetSize(tempstr,l,k,mangledname,false); - if (mangledname<>'') then - Message(asmr_e_invalid_reference_syntax); - inc(oper.opr.ref.offset,l); - end; - end; - - - procedure trv32attreader.ReadAt(oper : trvoperand); - begin - { check for ...@ } - if actasmtoken=AS_AT then - begin - if (oper.opr.ref.symbol=nil) and - (oper.opr.ref.offset = 0) then - Message(asmr_e_invalid_reference_syntax); - Consume(AS_AT); - if actasmtoken=AS_ID then - begin - {if upper(actasmpattern)='L' then - oper.opr.ref.refaddr:=addr_low - else if upper(actasmpattern)='HI' then - oper.opr.ref.refaddr:=addr_high - else if upper(actasmpattern)='HA' then - oper.opr.ref.refaddr:=addr_higha - else} - Message(asmr_e_invalid_reference_syntax); - Consume(AS_ID); - end - else - Message(asmr_e_invalid_reference_syntax); - end; - end; - - - Procedure trv32attreader.BuildReference(oper : trvoperand); - - procedure Consume_RParen; - begin - if actasmtoken <> AS_RPAREN then - Begin - Message(asmr_e_invalid_reference_syntax); - RecoverConsume(true); - end - else - begin - Consume(AS_RPAREN); - if not (actasmtoken in [AS_COMMA,AS_SEPARATOR,AS_END]) then - Begin - Message(asmr_e_invalid_reference_syntax); - RecoverConsume(true); - end; - end; - end; - - var - l : tcgint; - relsym: string; - asmsymtyp: tasmsymtype; - isflags: tindsymflags; - - begin - Consume(AS_LPAREN); - Case actasmtoken of - AS_INTNUM, - AS_MINUS, - AS_PLUS: - Begin - { offset(offset) is invalid } - If oper.opr.Ref.Offset <> 0 Then - Begin - Message(asmr_e_invalid_reference_syntax); - RecoverConsume(true); - End - Else - Begin - oper.opr.Ref.Offset:=BuildConstExpression(false,true); - Consume(AS_RPAREN); - if actasmtoken=AS_AT then - ReadAt(oper); - end; - exit; - End; - AS_REGISTER: { (reg ... } - Begin - if ((oper.opr.typ=OPR_REFERENCE) and (oper.opr.ref.base<>NR_NO)) or - ((oper.opr.typ=OPR_LOCAL) and (oper.opr.localsym.localloc.loc<>LOC_REGISTER)) then - message(asmr_e_cannot_index_relative_var); - oper.opr.ref.base:=actasmregister; - Consume(AS_REGISTER); - Consume_RParen; - end; {end case } - AS_ID: - Begin - ReadSym(oper); - case actasmtoken of - AS_PLUS: - begin - { add a constant expression? } - l:=BuildConstExpression(true,true); - case oper.opr.typ of - OPR_CONSTANT : - inc(oper.opr.val,l); - OPR_LOCAL : - inc(oper.opr.localsymofs,l); - OPR_REFERENCE : - inc(oper.opr.ref.offset,l); - else - internalerror(2003092008); - end; - end; - AS_MINUS: - begin - Consume(AS_MINUS); - BuildConstSymbolExpression(false,true,false,l,relsym,asmsymtyp); - if (relsym<>'') then - begin - if (oper.opr.typ = OPR_REFERENCE) then - oper.opr.ref.relsymbol:=current_asmdata.RefAsmSymbol(relsym,AT_DATA) - else - begin - Message(asmr_e_invalid_reference_syntax); - RecoverConsume(false); - end - end - else - begin - case oper.opr.typ of - OPR_CONSTANT : - dec(oper.opr.val,l); - OPR_LOCAL : - dec(oper.opr.localsymofs,l); - OPR_REFERENCE : - dec(oper.opr.ref.offset,l); - else - internalerror(2007092601); - end; - end; - end; - else - ; - end; - Consume(AS_RPAREN); - if actasmtoken=AS_AT then - ReadAt(oper); - End; - AS_COMMA: { (, ... can either be scaling, or index } - Begin - Consume(AS_COMMA); - { Index } - if (actasmtoken=AS_REGISTER) then - Begin - oper.opr.ref.index:=actasmregister; - Consume(AS_REGISTER); - { check for scaling ... } - Consume_RParen; - end - else - begin - Message(asmr_e_invalid_reference_syntax); - RecoverConsume(false); - end; - end; - else - Begin - Message(asmr_e_invalid_reference_syntax); - RecoverConsume(false); - end; - end; - end; - - - Procedure trv32attreader.BuildOperand(oper : trvoperand); - var - expr : string; - typesize,l : tcgint; - - - procedure AddLabelOperand(hl:tasmlabel); - begin - if not(actasmtoken in [AS_PLUS,AS_MINUS,AS_LPAREN]) and - is_calljmp(actopcode) then - begin - oper.opr.typ:=OPR_SYMBOL; - oper.opr.symbol:=hl; - end - else - begin - oper.InitRef; - oper.opr.ref.symbol:=hl; - end; - end; - - - procedure MaybeRecordOffset; - var - mangledname: string; - hasdot : boolean; - l, - toffset, - tsize : tcgint; - begin - if not(actasmtoken in [AS_DOT,AS_PLUS,AS_MINUS]) then - exit; - l:=0; - hasdot:=(actasmtoken=AS_DOT); - if hasdot then - begin - if expr<>'' then - begin - BuildRecordOffsetSize(expr,toffset,tsize,mangledname,false); - if (oper.opr.typ<>OPR_CONSTANT) and - (mangledname<>'') then - Message(asmr_e_wrong_sym_type); - inc(l,toffset); - oper.SetSize(tsize,true); - end; - end; - if actasmtoken in [AS_PLUS,AS_MINUS] then - inc(l,BuildConstExpression(true,false)); - case oper.opr.typ of - OPR_LOCAL : - begin - { don't allow direct access to fields of parameters, because that - will generate buggy code. Allow it only for explicit typecasting } - if hasdot and - (not oper.hastype) and - (tabstractvarsym(oper.opr.localsym).owner.symtabletype=parasymtable) and - (current_procinfo.procdef.proccalloption<>pocall_register) then - Message(asmr_e_cannot_access_field_directly_for_parameters); - inc(oper.opr.localsymofs,l) - end; - OPR_CONSTANT : - if (mangledname<>'') then - begin - if (oper.opr.val<>0) then - Message(asmr_e_wrong_sym_type); - oper.opr.typ:=OPR_SYMBOL; - oper.opr.symbol:=current_asmdata.DefineAsmSymbol(mangledname,AB_EXTERNAL,AT_FUNCTION,voidcodepointertype); - end - else - inc(oper.opr.val,l); - OPR_REFERENCE : - inc(oper.opr.ref.offset,l); - OPR_SYMBOL: - Message(asmr_e_invalid_symbol_ref); - else - internalerror(200309221); - end; - end; - - - function MaybeBuildReference:boolean; - { Try to create a reference, if not a reference is found then false - is returned } - begin - MaybeBuildReference:=true; - case actasmtoken of - AS_INTNUM, - AS_MINUS, - AS_PLUS: - Begin - oper.opr.ref.offset:=BuildConstExpression(True,False); - if actasmtoken<>AS_LPAREN then - Message(asmr_e_invalid_reference_syntax) - else - BuildReference(oper); - end; - AS_LPAREN: - BuildReference(oper); - AS_ID: { only a variable is allowed ... } - Begin - ReadSym(oper); - case actasmtoken of - AS_END, - AS_SEPARATOR, - AS_COMMA: ; - AS_LPAREN: - BuildReference(oper); - else - Begin - Message(asmr_e_invalid_reference_syntax); - Consume(actasmtoken); - end; - end; {end case } - end; - else - MaybeBuildReference:=false; - end; { end case } - end; - - - var - tempreg : tregister; - hl : tasmlabel; - ofs : aint; - refaddr: trefaddr; - entered_paren: Boolean; - Begin - expr:=''; - entered_paren:=false; - - refaddr:=addr_full; - if actasmtoken=AS_MOD then - begin - consume(AS_MOD); - - if actasmtoken<>AS_ID then - begin - Message(asmr_e_invalid_reference_syntax); - RecoverConsume(false); - end - else - begin - if lower(actasmpattern)='pcrel_hi' then - refaddr:=addr_pcrel_hi20 - else if lower(actasmpattern)='pcrel_lo' then - refaddr:=addr_pcrel_lo12 - else if lower(actasmpattern)='hi' then - refaddr:=addr_hi20 - else if lower(actasmpattern)='lo' then - refaddr:=addr_lo12 - else - begin - Message(asmr_e_invalid_reference_syntax); - RecoverConsume(false); - end; - - consume(AS_ID); - consume(AS_LPAREN); - entered_paren:=true; - end; - end; - - case actasmtoken of - AS_LPAREN: { Memory reference or constant expression } - Begin - oper.InitRef; - BuildReference(oper); - end; - - AS_INTNUM, - AS_MINUS, - AS_PLUS: - Begin - { Constant memory offset } - { This must absolutely be followed by ( } - oper.InitRef; - oper.opr.ref.offset:=BuildConstExpression(True,False); - if actasmtoken<>AS_LPAREN then - begin - ofs:=oper.opr.ref.offset; - BuildConstantOperand(oper); - inc(oper.opr.val,ofs); - end - else - BuildReference(oper); - end; - - AS_ID: { A constant expression, or a Variable ref. } - Begin - { Local Label ? } - if is_locallabel(actasmpattern) then - begin - CreateLocalLabel(actasmpattern,hl,false); - Consume(AS_ID); - AddLabelOperand(hl); - end - else - { Check for label } - if SearchLabel(actasmpattern,hl,false) then - begin - Consume(AS_ID); - AddLabelOperand(hl); - end - else - { probably a variable or normal expression } - { or a procedure (such as in CALL ID) } - Begin - { is it a constant ? } - if SearchIConstant(actasmpattern,l) then - Begin - if not (oper.opr.typ in [OPR_NONE,OPR_CONSTANT]) then - Message(asmr_e_invalid_operand_type); - BuildConstantOperand(oper); - end - else - begin - expr:=actasmpattern; - Consume(AS_ID); - { typecasting? } - if (actasmtoken=AS_LPAREN) and - SearchType(expr,typesize) then - begin - oper.hastype:=true; - Consume(AS_LPAREN); - BuildOperand(oper); - Consume(AS_RPAREN); - if oper.opr.typ in [OPR_REFERENCE,OPR_LOCAL] then - oper.SetSize(typesize,true); - end - else - begin - if oper.SetupVar(expr,false) then - ReadAt(oper) - else - Begin - { look for special symbols ... } - if expr= '__HIGH' then - begin - consume(AS_LPAREN); - if not oper.setupvar('high'+actasmpattern,false) then - Message1(sym_e_unknown_id,'high'+actasmpattern); - consume(AS_ID); - consume(AS_RPAREN); - end - else - if expr = '__RESULT' then - oper.SetUpResult - else - if expr = '__SELF' then - oper.SetupSelf - else - if expr = '__OLDEBP' then - oper.SetupOldEBP - else - Message1(sym_e_unknown_id,expr); - end; - end; - end; - if actasmtoken=AS_DOT then - MaybeRecordOffset; - { add a constant expression? } - if (actasmtoken=AS_PLUS) then - begin - l:=BuildConstExpression(true,entered_paren); - case oper.opr.typ of - OPR_CONSTANT : - inc(oper.opr.val,l); - OPR_LOCAL : - inc(oper.opr.localsymofs,l); - OPR_REFERENCE : - inc(oper.opr.ref.offset,l); - else - internalerror(2003092009); - end; - end - end; - { Do we have a indexing reference, then parse it also } - if actasmtoken=AS_LPAREN then - BuildReference(oper); - end; - - AS_REGISTER: { Register, a variable reference or a constant reference } - Begin - { save the type of register used. } - tempreg:=actasmregister; - Consume(AS_REGISTER); - if (actasmtoken in [AS_END,AS_SEPARATOR,AS_COMMA]) then - begin - if not (oper.opr.typ in [OPR_NONE,OPR_REGISTER]) then - Message(asmr_e_invalid_operand_type); - oper.opr.typ:=OPR_REGISTER; - oper.opr.reg:=tempreg; - end - else - Message(asmr_e_syn_operand); - end; - AS_END, - AS_SEPARATOR, - AS_COMMA: ; - else - Begin - Message(asmr_e_syn_operand); - Consume(actasmtoken); - end; - end; { end case } - - if refaddr<>addr_full then - begin - if oper.opr.typ<>OPR_REFERENCE then - oper.InitRef; - - oper.opr.ref.refaddr:=refaddr; - Consume(AS_RPAREN); - end - else if (oper.opr.typ=OPR_REFERENCE) and - (oper.opr.ref.refaddr=addr_no) and - assigned(oper.opr.ref.symbol) then - oper.opr.ref.refaddr:=addr_full; - end; - - -{***************************************************************************** - trv32attreader -*****************************************************************************} - - procedure trv32attreader.BuildOpCode(instr : trvinstruction); - var - operandnum : longint; - Begin - { opcode } - if (actasmtoken<>AS_OPCODE) then - Begin - Message(asmr_e_invalid_or_missing_opcode); - RecoverConsume(true); - exit; - end; - { Fill the instr object with the current state } - with instr do - begin - Opcode:=ActOpcode; - condition:=ActCondition; - end; - - { We are reading operands, so opcode will be an AS_ID } - operandnum:=1; - Consume(AS_OPCODE); - { Zero operand opcode ? } - if actasmtoken in [AS_SEPARATOR,AS_END] then - begin - operandnum:=0; - exit; - end; - { Read the operands } - repeat - case actasmtoken of - AS_COMMA: { Operand delimiter } - Begin - if operandnum>Max_Operands then - Message(asmr_e_too_many_operands) - else - begin - { condition operands doesn't set the operand but write to the - condition field of the instruction - } - if instr.Operands[operandnum].opr.typ<>OPR_NONE then - Inc(operandnum); - end; - Consume(AS_COMMA); - end; - AS_SEPARATOR, - AS_END : { End of asm operands for this opcode } - begin - break; - end; - else - BuildOperand(instr.Operands[operandnum] as trvoperand); - end; { end case } - until false; - if (operandnum=1) and (instr.Operands[operandnum].opr.typ=OPR_NONE) then - dec(operandnum); - instr.Ops:=operandnum; - end; - - - function trv32attreader.is_register(const s: string): boolean; - type - treg2str = record - name : string[3]; - reg : tregister; - end; - - const - extraregs : array[0..31] of treg2str = ( - (name: 'A0'; reg : NR_X10), - (name: 'A1'; reg : NR_X11), - (name: 'A2'; reg : NR_X12), - (name: 'A3'; reg : NR_X13), - (name: 'A4'; reg : NR_X14), - (name: 'A5'; reg : NR_X15), - (name: 'A6'; reg : NR_X16), - (name: 'A7'; reg : NR_X17), - (name: 'RA'; reg : NR_X1), - (name: 'SP'; reg : NR_X2), - (name: 'GP'; reg : NR_X3), - (name: 'TP'; reg : NR_X4), - (name: 'T0'; reg : NR_X5), - (name: 'T1'; reg : NR_X6), - (name: 'T2'; reg : NR_X7), - (name: 'S0'; reg : NR_X8), - (name: 'FP'; reg : NR_X8), - (name: 'S1'; reg : NR_X9), - (name: 'S2'; reg : NR_X18), - (name: 'S3'; reg : NR_X19), - (name: 'S4'; reg : NR_X20), - (name: 'S5'; reg : NR_X21), - (name: 'S6'; reg : NR_X22), - (name: 'S7'; reg : NR_X23), - (name: 'S8'; reg : NR_X24), - (name: 'S9'; reg : NR_X25), - (name: 'S10';reg : NR_X26), - (name: 'S11';reg : NR_X27), - (name: 'T3'; reg : NR_X28), - (name: 'T4'; reg : NR_X29), - (name: 'T5'; reg : NR_X30), - (name: 'T6'; reg : NR_X31) - ); - - var - i : longint; - - begin - result:=inherited is_register(s); - { reg found? - possible aliases are always 2 char - } - if result or (not (length(s) in [2,3])) then - exit; - for i:=low(extraregs) to high(extraregs) do - begin - if s=extraregs[i].name then - begin - actasmregister:=extraregs[i].reg; - result:=true; - actasmtoken:=AS_REGISTER; - exit; - end; - end; - end; - - - function trv32attreader.is_asmopcode(const s: string):boolean; - var - cond : tasmcond; - hs : string; - - Begin - { making s a value parameter would break other assembler readers } - hs:=s; - is_asmopcode:=false; - - { clear op code } - actopcode:=A_None; - { clear condition } - fillchar(actcondition,sizeof(actcondition),0); - - { check for direction hint } - actopcode := tasmop(ptruint(iasmops.find(hs))); - if actopcode <> A_NONE then - begin - actasmtoken:=AS_OPCODE; - is_asmopcode:=true; - exit; - end; - { not found, check branch instructions } - if hs[1]='B' then - begin - { we can search here without an extra table which is sorted by string length - because we take the whole remaining string without the leading B } - actopcode := A_Bxx; - for cond:=low(TAsmCond) to high(TAsmCond) do - if copy(hs,2,length(s)-1)=uppercond2str[cond] then - begin - actcondition:=cond; - actasmtoken:=AS_OPCODE; - is_asmopcode:=true; - exit; - end; - end; - end; - - - procedure trv32attreader.handleopcode; - var - instr : trvinstruction; - begin - instr:=trvinstruction.Create(trvoperand); - BuildOpcode(instr); - instr.condition := actcondition; - { - instr.AddReferenceSizes; - instr.SetInstructionOpsize; - instr.CheckOperandSizes; - } - instr.ConcatInstruction(curlist); - instr.Free; - end; - - -{***************************************************************************** - Initialize -*****************************************************************************} - -const - asmmode_rv32_standard_info : tasmmodeinfo = - ( - id : asmmode_standard; - idtxt : 'STANDARD'; - casmreader : trv32attreader; - ); - -initialization - RegisterAsmMode(asmmode_rv32_standard_info); -end. diff --git a/compiler/riscv64/cputarg.pas b/compiler/riscv64/cputarg.pas index 6986b1f2b6..2fe842893d 100644 --- a/compiler/riscv64/cputarg.pas +++ b/compiler/riscv64/cputarg.pas @@ -55,7 +55,7 @@ implementation **************************************} {$ifndef NoRaRVGas} - ,rarv64gas + ,rarvgas {$endif NoRaRVGas} {************************************** diff --git a/compiler/riscv64/rarv64gas.pas b/compiler/riscv64/rarv64gas.pas deleted file mode 100644 index 5eebf0d591..0000000000 --- a/compiler/riscv64/rarv64gas.pas +++ /dev/null @@ -1,850 +0,0 @@ -{ - Copyright (c) 2016 by Jeppe Johansen - - Does the parsing for the RiscV64 GNU AS styled inline assembler. - - 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 rarv64gas; - -{$I fpcdefs.inc} - - interface - - uses - raatt, rarvgas, rarv, - cpubase; - - type - trv64attreader = class(trvattreader) - actmemoryordering: TMemoryOrdering; - function is_register(const s: string): boolean; override; - function is_asmopcode(const s: string):boolean;override; - procedure handleopcode;override; - procedure BuildReference(oper : trvoperand); - procedure BuildOperand(oper : trvoperand); - procedure BuildOpCode(instr : trvinstruction); - procedure ReadAt(oper : trvoperand); - procedure ReadSym(oper : trvoperand); - end; - - implementation - - uses - { helpers } - cutils, - { global } - globtype,globals,verbose, - systems, - { aasm } - aasmbase,aasmtai,aasmdata,aasmcpu, - { symtable } - symconst,symsym,symdef, - { parser } - procinfo, - rabase,rautils, - cgbase,cgobj,cgrv - ; - - procedure trv64attreader.ReadSym(oper : trvoperand); - var - tempstr, mangledname : string; - typesize,l,k : aint; - begin - tempstr:=actasmpattern; - Consume(AS_ID); - { typecasting? } - if (actasmtoken=AS_LPAREN) and - SearchType(tempstr,typesize) then - begin - oper.hastype:=true; - Consume(AS_LPAREN); - BuildOperand(oper); - Consume(AS_RPAREN); - if oper.opr.typ in [OPR_REFERENCE,OPR_LOCAL] then - oper.SetSize(typesize,true); - end - else - if not oper.SetupVar(tempstr,false) then - Message1(sym_e_unknown_id,tempstr); - { record.field ? } - if actasmtoken=AS_DOT then - begin - BuildRecordOffsetSize(tempstr,l,k,mangledname,false); - if (mangledname<>'') then - Message(asmr_e_invalid_reference_syntax); - inc(oper.opr.ref.offset,l); - end; - end; - - - procedure trv64attreader.ReadAt(oper : trvoperand); - begin - { check for ...@ } - if actasmtoken=AS_AT then - begin - if (oper.opr.ref.symbol=nil) and - (oper.opr.ref.offset = 0) then - Message(asmr_e_invalid_reference_syntax); - Consume(AS_AT); - if actasmtoken=AS_ID then - begin - {if upper(actasmpattern)='L' then - oper.opr.ref.refaddr:=addr_low - else if upper(actasmpattern)='HI' then - oper.opr.ref.refaddr:=addr_high - else if upper(actasmpattern)='HA' then - oper.opr.ref.refaddr:=addr_higha - else} - Message(asmr_e_invalid_reference_syntax); - Consume(AS_ID); - end - else - Message(asmr_e_invalid_reference_syntax); - end; - end; - - - procedure trv64attreader.BuildReference(oper: trvoperand); - - procedure Consume_RParen; - begin - if actasmtoken <> AS_RPAREN then - Begin - Message(asmr_e_invalid_reference_syntax); - RecoverConsume(true); - end - else - begin - Consume(AS_RPAREN); - if not (actasmtoken in [AS_COMMA,AS_SEPARATOR,AS_END]) then - Begin - Message(asmr_e_invalid_reference_syntax); - RecoverConsume(true); - end; - end; - end; - - var - l : aint; - relsym: string; - asmsymtyp: tasmsymtype; - isflags: tindsymflags; - - begin - Consume(AS_LPAREN); - Case actasmtoken of - AS_INTNUM, - AS_MINUS, - AS_PLUS: - Begin - { offset(offset) is invalid } - If oper.opr.Ref.Offset <> 0 Then - Begin - Message(asmr_e_invalid_reference_syntax); - RecoverConsume(true); - End - Else - Begin - oper.opr.Ref.Offset:=BuildConstExpression(false,true); - Consume(AS_RPAREN); - if actasmtoken=AS_AT then - ReadAt(oper); - end; - exit; - End; - AS_REGISTER: { (reg ... } - Begin - if ((oper.opr.typ=OPR_REFERENCE) and (oper.opr.ref.base<>NR_NO)) or - ((oper.opr.typ=OPR_LOCAL) and (oper.opr.localsym.localloc.loc<>LOC_REGISTER)) then - message(asmr_e_cannot_index_relative_var); - oper.opr.ref.base:=actasmregister; - Consume(AS_REGISTER); - Consume_RParen; - end; {end case } - AS_ID: - Begin - ReadSym(oper); - case actasmtoken of - AS_PLUS: - begin - { add a constant expression? } - l:=BuildConstExpression(true,true); - case oper.opr.typ of - OPR_CONSTANT : - inc(oper.opr.val,l); - OPR_LOCAL : - inc(oper.opr.localsymofs,l); - OPR_REFERENCE : - inc(oper.opr.ref.offset,l); - else - internalerror(2003092016); - end; - end; - AS_MINUS: - begin - Consume(AS_MINUS); - BuildConstSymbolExpression(false,true,false,l,relsym,asmsymtyp); - if (relsym<>'') then - begin - if (oper.opr.typ = OPR_REFERENCE) then - oper.opr.ref.relsymbol:=current_asmdata.RefAsmSymbol(relsym,AT_DATA) - else - begin - Message(asmr_e_invalid_reference_syntax); - RecoverConsume(false); - end - end - else - begin - case oper.opr.typ of - OPR_CONSTANT : - dec(oper.opr.val,l); - OPR_LOCAL : - dec(oper.opr.localsymofs,l); - OPR_REFERENCE : - dec(oper.opr.ref.offset,l); - else - internalerror(2007092601); - end; - end; - end; - else - ; - end; - Consume(AS_RPAREN); - if actasmtoken=AS_AT then - ReadAt(oper); - End; - AS_COMMA: { (, ... can either be scaling, or index } - Begin - Consume(AS_COMMA); - { Index } - if (actasmtoken=AS_REGISTER) then - Begin - oper.opr.ref.index:=actasmregister; - Consume(AS_REGISTER); - { check for scaling ... } - Consume_RParen; - end - else - begin - Message(asmr_e_invalid_reference_syntax); - RecoverConsume(false); - end; - end; - else - Begin - Message(asmr_e_invalid_reference_syntax); - RecoverConsume(false); - end; - end; - end; - - - procedure trv64attreader.BuildOperand(oper: trvoperand); - var - expr : string; - typesize,l : aint; - - - procedure AddLabelOperand(hl:tasmlabel); - begin - if not(actasmtoken in [AS_PLUS,AS_MINUS,AS_LPAREN]) and - is_calljmp(actopcode) then - begin - oper.opr.typ:=OPR_SYMBOL; - oper.opr.symbol:=hl; - end - else - begin - oper.InitRef; - oper.opr.ref.symbol:=hl; - end; - end; - - - procedure MaybeRecordOffset; - var - mangledname: string; - hasdot : boolean; - l, - toffset, - tsize : aint; - begin - if not(actasmtoken in [AS_DOT,AS_PLUS,AS_MINUS]) then - exit; - l:=0; - hasdot:=(actasmtoken=AS_DOT); - if hasdot then - begin - if expr<>'' then - begin - BuildRecordOffsetSize(expr,toffset,tsize,mangledname,false); - if (oper.opr.typ<>OPR_CONSTANT) and - (mangledname<>'') then - Message(asmr_e_wrong_sym_type); - inc(l,toffset); - oper.SetSize(tsize,true); - end; - end; - if actasmtoken in [AS_PLUS,AS_MINUS] then - inc(l,BuildConstExpression(true,false)); - case oper.opr.typ of - OPR_LOCAL : - begin - { don't allow direct access to fields of parameters, because that - will generate buggy code. Allow it only for explicit typecasting } - if hasdot and - (not oper.hastype) and - (tabstractvarsym(oper.opr.localsym).owner.symtabletype=parasymtable) and - (current_procinfo.procdef.proccalloption<>pocall_register) then - Message(asmr_e_cannot_access_field_directly_for_parameters); - inc(oper.opr.localsymofs,l) - end; - OPR_CONSTANT : - if (mangledname<>'') then - begin - if (oper.opr.val<>0) then - Message(asmr_e_wrong_sym_type); - oper.opr.typ:=OPR_SYMBOL; - oper.opr.symbol:=current_asmdata.DefineAsmSymbol(mangledname,AB_EXTERNAL,AT_FUNCTION,voidcodepointertype); - end - else - inc(oper.opr.val,l); - OPR_REFERENCE : - inc(oper.opr.ref.offset,l); - OPR_SYMBOL: - Message(asmr_e_invalid_symbol_ref); - else - internalerror(200309221); - end; - end; - - - function MaybeBuildReference:boolean; - { Try to create a reference, if not a reference is found then false - is returned } - begin - MaybeBuildReference:=true; - case actasmtoken of - AS_INTNUM, - AS_MINUS, - AS_PLUS: - Begin - oper.opr.ref.offset:=BuildConstExpression(True,False); - if actasmtoken<>AS_LPAREN then - Message(asmr_e_invalid_reference_syntax) - else - BuildReference(oper); - end; - AS_LPAREN: - BuildReference(oper); - AS_ID: { only a variable is allowed ... } - Begin - ReadSym(oper); - case actasmtoken of - AS_END, - AS_SEPARATOR, - AS_COMMA: ; - AS_LPAREN: - BuildReference(oper); - else - Begin - Message(asmr_e_invalid_reference_syntax); - Consume(actasmtoken); - end; - end; {end case } - end; - else - MaybeBuildReference:=false; - end; { end case } - end; - - - function is_fenceflag(hs : string): boolean; - var - i: longint; - flags: TFenceFlags; - begin - is_fenceflag := false; - - flags:=[]; - hs:=lower(hs); - - if (actopcode in [A_FENCE]) and (length(hs) >= 1) then - begin - for i:=1 to length(hs) do - begin - case hs[i] of - 'i': - Include(flags,ffi); - 'o': - Include(flags,ffo); - 'r': - Include(flags,ffr); - 'w': - Include(flags,ffw); - else - exit; - end; - end; - oper.opr.typ := OPR_FENCEFLAGS; - oper.opr.fenceflags := flags; - exit(true); - end; - end; - - - var - tempreg : tregister; - hl : tasmlabel; - ofs : aint; - refaddr: trefaddr; - entered_paren: Boolean; - Begin - expr:=''; - entered_paren:=false; - - refaddr:=addr_full; - if actasmtoken=AS_MOD then - begin - consume(AS_MOD); - - if actasmtoken<>AS_ID then - begin - Message(asmr_e_invalid_reference_syntax); - RecoverConsume(false); - end - else - begin - if lower(actasmpattern)='pcrel_hi' then - refaddr:=addr_pcrel_hi20 - else if lower(actasmpattern)='pcrel_lo' then - refaddr:=addr_pcrel_lo12 - else if lower(actasmpattern)='hi' then - refaddr:=addr_hi20 - else if lower(actasmpattern)='lo' then - refaddr:=addr_lo12 - else - begin - Message(asmr_e_invalid_reference_syntax); - RecoverConsume(false); - end; - - consume(AS_ID); - consume(AS_LPAREN); - entered_paren:=true; - end; - end; - - case actasmtoken of - AS_LPAREN: { Memory reference or constant expression } - Begin - oper.InitRef; - BuildReference(oper); - end; - - AS_INTNUM, - AS_MINUS, - AS_PLUS: - Begin - { Constant memory offset } - { This must absolutely be followed by ( } - oper.InitRef; - oper.opr.ref.offset:=BuildConstExpression(True,False); - if actasmtoken<>AS_LPAREN then - begin - ofs:=oper.opr.ref.offset; - BuildConstantOperand(oper); - inc(oper.opr.val,ofs); - end - else - BuildReference(oper); - end; - - AS_DOT, - AS_ID: { A constant expression, or a Variable ref. } - Begin - if is_fenceflag(actasmpattern) then - begin - consume(AS_ID); - end - else - { Local Label ? } - if is_locallabel(actasmpattern) then - begin - CreateLocalLabel(actasmpattern,hl,false); - Consume(AS_ID); - AddLabelOperand(hl); - end - else - { Check for label } - if SearchLabel(actasmpattern,hl,false) then - begin - Consume(AS_ID); - AddLabelOperand(hl); - end - else - { probably a variable or normal expression } - { or a procedure (such as in CALL ID) } - Begin - { is it a constant ? } - if SearchIConstant(actasmpattern,l) then - Begin - if not (oper.opr.typ in [OPR_NONE,OPR_CONSTANT]) then - Message(asmr_e_invalid_operand_type); - BuildConstantOperand(oper); - end - else - begin - expr:=actasmpattern; - Consume(AS_ID); - { typecasting? } - if (actasmtoken=AS_LPAREN) and - SearchType(expr,typesize) then - begin - oper.hastype:=true; - Consume(AS_LPAREN); - BuildOperand(oper); - Consume(AS_RPAREN); - if oper.opr.typ in [OPR_REFERENCE,OPR_LOCAL] then - oper.SetSize(typesize,true); - end - else - begin - if oper.SetupVar(expr,false) then - ReadAt(oper) - else - Begin - { look for special symbols ... } - if expr= '__HIGH' then - begin - consume(AS_LPAREN); - if not oper.setupvar('high'+actasmpattern,false) then - Message1(sym_e_unknown_id,'high'+actasmpattern); - consume(AS_ID); - consume(AS_RPAREN); - end - else - if expr = '__RESULT' then - oper.SetUpResult - else - if expr = '__SELF' then - oper.SetupSelf - else - if expr = '__OLDEBP' then - oper.SetupOldEBP - else - Message1(sym_e_unknown_id,expr); - end; - end; - end; - if actasmtoken=AS_DOT then - MaybeRecordOffset; - { add a constant expression? } - if (actasmtoken=AS_PLUS) then - begin - l:=BuildConstExpression(true,entered_paren); - case oper.opr.typ of - OPR_CONSTANT : - inc(oper.opr.val,l); - OPR_LOCAL : - inc(oper.opr.localsymofs,l); - OPR_REFERENCE : - inc(oper.opr.ref.offset,l); - else - internalerror(2003092017); - end; - end - end; - { Do we have a indexing reference, then parse it also } - if actasmtoken=AS_LPAREN then - BuildReference(oper); - end; - - AS_REGISTER: { Register, a variable reference or a constant reference } - Begin - { save the type of register used. } - tempreg:=actasmregister; - Consume(AS_REGISTER); - if (actasmtoken in [AS_END,AS_SEPARATOR,AS_COMMA]) then - begin - if not (oper.opr.typ in [OPR_NONE,OPR_REGISTER]) then - Message(asmr_e_invalid_operand_type); - oper.opr.typ:=OPR_REGISTER; - oper.opr.reg:=tempreg; - end - else - Message(asmr_e_syn_operand); - end; - AS_END, - AS_SEPARATOR, - AS_COMMA: ; - else - Begin - Message(asmr_e_syn_operand); - Consume(actasmtoken); - end; - end; { end case } - - if refaddr<>addr_full then - begin - if oper.opr.typ<>OPR_REFERENCE then - oper.InitRef; - - oper.opr.ref.refaddr:=refaddr; - Consume(AS_RPAREN); - end - else if (oper.opr.typ=OPR_REFERENCE) and - (oper.opr.ref.refaddr=addr_no) and - assigned(oper.opr.ref.symbol) then - oper.opr.ref.refaddr:=addr_full; - end; - - -{***************************************************************************** - trv64attreader -*****************************************************************************} - - procedure trv64attreader.BuildOpCode(instr : trvinstruction); - var - operandnum : longint; - Begin - { opcode } - if (actasmtoken<>AS_OPCODE) then - Begin - Message(asmr_e_invalid_or_missing_opcode); - RecoverConsume(true); - exit; - end; - { Fill the instr object with the current state } - with instr do - begin - Opcode:=ActOpcode; - condition:=ActCondition; - ordering:=actmemoryordering; - end; - - { We are reading operands, so opcode will be an AS_ID } - operandnum:=1; - Consume(AS_OPCODE); - { Zero operand opcode ? } - if actasmtoken in [AS_SEPARATOR,AS_END] then - begin - operandnum:=0; - exit; - end; - { Read the operands } - repeat - case actasmtoken of - AS_COMMA: { Operand delimiter } - Begin - if operandnum>Max_Operands then - Message(asmr_e_too_many_operands) - else - begin - { condition operands doesn't set the operand but write to the - condition field of the instruction - } - if instr.Operands[operandnum].opr.typ<>OPR_NONE then - Inc(operandnum); - end; - Consume(AS_COMMA); - end; - AS_SEPARATOR, - AS_END : { End of asm operands for this opcode } - begin - break; - end; - else - BuildOperand(instr.Operands[operandnum] as trvoperand); - end; { end case } - until false; - if (operandnum=1) and (instr.Operands[operandnum].opr.typ=OPR_NONE) then - dec(operandnum); - instr.Ops:=operandnum; - end; - - function trv64attreader.is_register(const s: string): boolean; - type - treg2str = record - name : string[3]; - reg : tregister; - end; - - const - extraregs : array[0..31] of treg2str = ( - (name: 'A0'; reg : NR_X10), - (name: 'A1'; reg : NR_X11), - (name: 'A2'; reg : NR_X12), - (name: 'A3'; reg : NR_X13), - (name: 'A4'; reg : NR_X14), - (name: 'A5'; reg : NR_X15), - (name: 'A6'; reg : NR_X16), - (name: 'A7'; reg : NR_X17), - (name: 'RA'; reg : NR_X1), - (name: 'SP'; reg : NR_X2), - (name: 'GP'; reg : NR_X3), - (name: 'TP'; reg : NR_X4), - (name: 'T0'; reg : NR_X5), - (name: 'T1'; reg : NR_X6), - (name: 'T2'; reg : NR_X7), - (name: 'S0'; reg : NR_X8), - (name: 'FP'; reg : NR_X8), - (name: 'S1'; reg : NR_X9), - (name: 'S2'; reg : NR_X18), - (name: 'S3'; reg : NR_X19), - (name: 'S4'; reg : NR_X20), - (name: 'S5'; reg : NR_X21), - (name: 'S6'; reg : NR_X22), - (name: 'S7'; reg : NR_X23), - (name: 'S8'; reg : NR_X24), - (name: 'S9'; reg : NR_X25), - (name: 'S10';reg : NR_X26), - (name: 'S11';reg : NR_X27), - (name: 'T3'; reg : NR_X28), - (name: 'T4'; reg : NR_X29), - (name: 'T5'; reg : NR_X30), - (name: 'T6'; reg : NR_X31) - ); - - var - i : longint; - - begin - result:=inherited is_register(s); - { reg found? - possible aliases are always 2 char - } - if result or (not (length(s) in [2,3])) then - exit; - for i:=low(extraregs) to high(extraregs) do - begin - if s=extraregs[i].name then - begin - actasmregister:=extraregs[i].reg; - result:=true; - actasmtoken:=AS_REGISTER; - exit; - end; - end; - end; - - - function trv64attreader.is_asmopcode(const s: string):boolean; - var - cond : tasmcond; - hs, postfix : string; - l: longint; - Begin - { making s a value parameter would break other assembler readers } - hs:=s; - is_asmopcode:=false; - - { clear op code } - actopcode:=A_None; - { clear condition } - fillchar(actcondition,sizeof(actcondition),0); - - { check for direction hint } - actopcode := tasmop(ptruint(iasmops.find(hs))); - if actopcode <> A_NONE then - begin - actasmtoken:=AS_OPCODE; - is_asmopcode:=true; - exit; - end; - { not found, check branch instructions } - if hs[1]='B' then - begin - { we can search here without an extra table which is sorted by string length - because we take the whole remaining string without the leading B } - actopcode := A_Bxx; - for cond:=low(TAsmCond) to high(TAsmCond) do - if copy(hs,2,length(s)-1)=uppercond2str[cond] then - begin - actcondition:=cond; - actasmtoken:=AS_OPCODE; - is_asmopcode:=true; - exit; - end; - end; - - { check atomic instructions } - if (pos('AMO',hs)=1) or - (pos('LR', hs)=1) or - (pos('SC', hs)=1) then - begin - l := length(hs)-1; - while l>1 do - begin - actopcode := tasmop(ptruint(iasmops.find(copy(hs,1,l)))); - if actopcode <> A_None then - begin - postfix := copy(hs,l+1,length(hs)-l); - - if postfix='.AQRL' then actmemoryordering:=[moAq,moRl] - else if postfix='.RL' then actmemoryordering:=[moRl] - else if postfix='.AQ' then actmemoryordering:=[moAq] - else - exit; - - actasmtoken:=AS_OPCODE; - is_asmopcode:=true; - exit; - end; - dec(l); - end; - end; - end; - - - procedure trv64attreader.handleopcode; - var - instr : trvinstruction; - begin - instr:=trvinstruction.Create(trvoperand); - BuildOpcode(instr); - instr.condition := actcondition; - { - instr.AddReferenceSizes; - instr.SetInstructionOpsize; - instr.CheckOperandSizes; - } - instr.ConcatInstruction(curlist); - instr.Free; - actmemoryordering:=[]; - end; - - -{***************************************************************************** - Initialize -*****************************************************************************} - - const - asmmode_rv64_standard_info : tasmmodeinfo = - ( - id : asmmode_standard; - idtxt : 'STANDARD'; - casmreader : trv64attreader; - ); - -initialization - RegisterAsmMode(asmmode_rv64_standard_info); -end. - diff --git a/compiler/x86/aoptx86.pas b/compiler/x86/aoptx86.pas index 646f27d526..c68280130e 100644 --- a/compiler/x86/aoptx86.pas +++ b/compiler/x86/aoptx86.pas @@ -3076,6 +3076,55 @@ unit aoptx86; Result:=true; exit; end; + +{$ifdef x86_64} + { Convert: + movq x(ref),%reg64 + shrq y,%reg64 + To: + movq x+4(ref),%reg32 + shrq y-32,%reg32 (Remove if y = 32) + } + if (taicpu(p).opsize = S_Q) and + (taicpu(p).oper[0]^.typ = top_ref) and { Second operand will be a register } + (taicpu(p).oper[0]^.ref^.offset <= $7FFFFFFB) and + MatchInstruction(hp1, A_SHR, [taicpu(p).opsize]) and + MatchOpType(taicpu(hp1), top_const, top_reg) and + (taicpu(hp1).oper[0]^.val >= 32) and + (taicpu(hp1).oper[1]^.reg = taicpu(p).oper[1]^.reg) then + begin + RegName1 := debug_regname(taicpu(hp1).oper[1]^.reg); + PreMessage := 'movq ' + debug_operstr(taicpu(p).oper[0]^) + ',' + RegName1 + '; ' + + 'shrq $' + debug_tostr(taicpu(hp1).oper[0]^.val) + ',' + RegName1 + ' -> movl '; + + { Convert to 32-bit } + setsubreg(taicpu(p).oper[1]^.reg, R_SUBD); + taicpu(p).opsize := S_L; + + Inc(taicpu(p).oper[0]^.ref^.offset, 4); + + PreMessage := PreMessage + debug_operstr(taicpu(p).oper[0]^) + ',' + debug_regname(taicpu(p).oper[1]^.reg); + if (taicpu(hp1).oper[0]^.val = 32) then + begin + DebugMsg(SPeepholeOptimization + PreMessage + ' (MovShr2Mov)', p); + RemoveInstruction(hp1); + end + else + begin + { This will potentially open up more arithmetic operations since + the peephole optimizer now has a big hint that only the lower + 32 bits are currently in use (and opcodes are smaller in size) } + setsubreg(taicpu(hp1).oper[1]^.reg, R_SUBD); + taicpu(hp1).opsize := S_L; + + Dec(taicpu(hp1).oper[0]^.val, 32); + DebugMsg(SPeepholeOptimization + PreMessage + + '; shrl $' + debug_tostr(taicpu(hp1).oper[0]^.val) + ',' + debug_regname(taicpu(hp1).oper[1]^.reg) + ' (MovShr2MovShr)', p); + end; + Result := True; + Exit; + end; +{$endif x86_64} end; @@ -7076,19 +7125,26 @@ unit aoptx86; movl/q %reg1,%reg2 To: leal/q $-x(%reg1),%reg2 - subl/q $x,%reg1 + subl/q $x,%reg1 (can be removed if %reg1 or the flags are not used afterwards) Breaks the dependency chain and potentially permits the removal of a CMP instruction if one follows. } Result := False; - if not (cs_opt_size in current_settings.optimizerswitches) and - (taicpu(p).opsize in [S_L{$ifdef x86_64}, S_Q{$endif x86_64}]) and + if (taicpu(p).opsize in [S_L{$ifdef x86_64}, S_Q{$endif x86_64}]) and MatchOpType(taicpu(p),top_const,top_reg) and GetNextInstruction(p, hp1) and MatchInstruction(hp1, A_MOV, [taicpu(p).opsize]) and (taicpu(hp1).oper[1]^.typ = top_reg) and - MatchOperand(taicpu(hp1).oper[0]^, taicpu(p).oper[1]^.reg) then + MatchOperand(taicpu(hp1).oper[0]^, taicpu(p).oper[1]^.reg) and + ( + { Don't do SubMov2LeaSub under -Os, but do allow SubMov2Lea } + not (cs_opt_size in current_settings.optimizerswitches) or + ( + not RegUsedAfterInstruction(taicpu(p).oper[1]^.reg, hp1, TmpUsedRegs) and + RegUsedAfterInstruction(NR_DEFAULTFLAGS, hp1, TmpUsedRegs) + ) + ) then begin { Change the MOV instruction to a LEA instruction, and update the first operand } @@ -7100,12 +7156,26 @@ unit aoptx86; taicpu(hp1).opcode := A_LEA; taicpu(hp1).loadref(0, NewRef); - { Move what is now the LEA instruction to before the SUB instruction } - Asml.Remove(hp1); - Asml.InsertBefore(hp1, p); - AllocRegBetween(taicpu(hp1).oper[1]^.reg, hp1, p, UsedRegs); + TransferUsedRegs(TmpUsedRegs); + UpdateUsedRegs(TmpUsedRegs, tai(p.Next)); + if RegUsedAfterInstruction(NewRef.base, hp1, TmpUsedRegs) or + RegUsedAfterInstruction(NR_DEFAULTFLAGS, hp1, TmpUsedRegs) then + begin + { Move what is now the LEA instruction to before the SUB instruction } + Asml.Remove(hp1); + Asml.InsertBefore(hp1, p); + AllocRegBetween(taicpu(hp1).oper[1]^.reg, hp1, p, UsedRegs); + + DebugMsg(SPeepholeOptimization + 'SubMov2LeaSub', p); + p := hp1; + end + else + begin + { Since %reg1 or the flags aren't used afterwards, we can delete p completely } + RemoveCurrentP(p, hp1); + DebugMsg(SPeepholeOptimization + 'SubMov2Lea', p); + end; - DebugMsg(SPeepholeOptimization + 'SubMov2LeaSub', p); Result := True; end; end; diff --git a/compiler/x86/rgx86.pas b/compiler/x86/rgx86.pas index 6285808b2d..27d34fbd5e 100644 --- a/compiler/x86/rgx86.pas +++ b/compiler/x86/rgx86.pas @@ -109,6 +109,14 @@ implementation function avx_opcode_only_op0_may_be_memref(opcode : TAsmOp) : boolean; begin case opcode of + A_VMAXPD, + A_VMAXPS, + A_VMAXSD, + A_VMAXSS, + A_VMINPD, + A_VMINPS, + A_VMINSD, + A_VMINSS, A_VMULSS, A_VMULSD, A_VSUBSS, @@ -350,7 +358,15 @@ implementation A_SHUFPD, A_SHUFPS, A_VCOMISD, - A_VCOMISS: + A_VCOMISS, + A_MINSS, + A_MINSD, + A_MINPS, + A_MINPD, + A_MAXSS, + A_MAXSD, + A_MAXPS, + A_MAXPD: replaceoper:=-1; A_IMUL: diff --git a/packages/fcl-db/src/base/sqlscript.pp b/packages/fcl-db/src/base/sqlscript.pp index 4ec7400457..1d3fe93011 100644 --- a/packages/fcl-db/src/base/sqlscript.pp +++ b/packages/fcl-db/src/base/sqlscript.pp @@ -284,6 +284,7 @@ begin FUseDollarString:=AValue; RecalcSeps; end; + function TCustomSQLScript.GetLine: Integer; begin Result:=FLine - 1; @@ -507,6 +508,7 @@ begin FIsSkipping:=False; FSkipStackIndex:=0; Faborted:=False; + FLine:=1; DefaultDirectives; Repeat NextStatement(); diff --git a/packages/fcl-passrc/src/pasresolver.pp b/packages/fcl-passrc/src/pasresolver.pp index 331baee4c2..5c2b99c479 100644 --- a/packages/fcl-passrc/src/pasresolver.pp +++ b/packages/fcl-passrc/src/pasresolver.pp @@ -6252,7 +6252,7 @@ procedure TPasResolver.FinishSubElementType(Parent: TPasElement; El: TPasType); begin List.Add(El); end; - El.AddRef{$IFDEF CheckPasTreeRefCount}aID{$ENDIF}; + El.AddRef{$IFDEF CheckPasTreeRefCount}(aID){$ENDIF}; El.Parent:=NewParent; end; @@ -29123,20 +29123,23 @@ function TPasResolver.IsTGUID(RecTypeEl: TPasRecordType): boolean; var Members: TFPList; El: TPasElement; + i, MemberIndex: Integer; begin Result:=false; if not SameText(RecTypeEl.Name,'TGUID') then exit; if SameText(RecTypeEl.GetModule.Name,'system') then exit(true); Members:=RecTypeEl.Members; - if Members.Count<4 then exit; - El:=TPasElement(Members[0]); - if not SameText(El.Name,'D1') then exit; - El:=TPasElement(Members[1]); - if not SameText(El.Name,'D2') then exit; - El:=TPasElement(Members[2]); - if not SameText(El.Name,'D3') then exit; - El:=TPasElement(Members[3]); - if not SameText(El.Name,'D4') then exit; + i:=1; + for MemberIndex:=0 to Members.Count-1 do + begin + El:=TPasElement(Members[MemberIndex]); + if (El.ClassType<>TPasVariable) then continue; + if SameText(El.Name,'D'+IntToStr(i)) then + begin + if i=4 then exit(true); + inc(i); + end; + end; Result:=true; end; diff --git a/packages/fcl-passrc/src/pasuseanalyzer.pas b/packages/fcl-passrc/src/pasuseanalyzer.pas index 55e332f61f..d9dea0b85d 100644 --- a/packages/fcl-passrc/src/pasuseanalyzer.pas +++ b/packages/fcl-passrc/src/pasuseanalyzer.pas @@ -262,7 +262,7 @@ type procedure UseElement(El: TPasElement; Access: TResolvedRefAccess; UseFull: boolean); virtual; procedure UseTypeInfo(El: TPasElement); virtual; - procedure UseAttributes(El: TPasElement); virtual; + function UseAttributes(El: TPasElement): boolean; virtual; function UseModule(aModule: TPasModule; Mode: TPAUseMode): boolean; virtual; procedure UseSection(Section: TPasSection; Mode: TPAUseMode); virtual; procedure UseImplBlock(Block: TPasImplBlock; Mark: boolean); virtual; @@ -1322,12 +1322,13 @@ begin UseTypeInfo(El.Parent); end; -procedure TPasAnalyzer.UseAttributes(El: TPasElement); +function TPasAnalyzer.UseAttributes(El: TPasElement): boolean; var Calls: TPasExprArray; i: Integer; begin Calls:=Resolver.GetAttributeCallsEl(El); + Result:=Calls<>nil; for i:=0 to length(Calls)-1 do UseExpr(Calls[i]); end; @@ -2357,11 +2358,18 @@ begin else if IsModuleInternal(Member) then // private or strict private continue - else if (Mode=paumAllPasUsable) and FirstTime - and ((Member.ClassType=TPasProperty) or (Member is TPasType)) then + else if (Mode=paumAllPasUsable) and FirstTime then begin - // non private property can be used by typeinfo by descendants in other units - UseTypeInfo(Member); + if Member.ClassType=TPasProperty then + begin + // non private property can be used by typeinfo by descendants in other units + UseTypeInfo(Member); + end + else if Member is TPasType then + begin + // non private type can be used by descendants in other units + UseType(TPasType(Member),Mode); + end end else ; // else: class/record is in unit interface, mark all non private members @@ -2405,7 +2413,9 @@ begin end; end; - UseAttributes(El); + if UseAttributes(El) and (El.ClassType=TPasClassType) then + UseTypeInfo(El); // class with attributes, + // typeinfo can be used at runtime via typeinfo(aClass) -> always mark end; procedure TPasAnalyzer.UseClassConstructor(El: TPasMembersType); @@ -2847,7 +2857,7 @@ begin begin // write without read if (vmExternal in El.VarModifiers) - + or (El.ClassType=TPasProperty) or ((El.Parent is TPasClassType) and TPasClassType(El.Parent).IsExternal) then exit; if El.Visibility in [visPrivate,visStrictPrivate] then diff --git a/packages/fcl-passrc/tests/tcresolver.pas b/packages/fcl-passrc/tests/tcresolver.pas index d7ac1df835..f1e48cc195 100644 --- a/packages/fcl-passrc/tests/tcresolver.pas +++ b/packages/fcl-passrc/tests/tcresolver.pas @@ -175,7 +175,7 @@ type procedure AddSystemUnit(Parts: TSystemUnitParts = []); procedure StartProgram(NeedSystemUnit: boolean; SystemUnitParts: TSystemUnitParts = []); procedure StartLibrary(NeedSystemUnit: boolean; SystemUnitParts: TSystemUnitParts = []); - procedure StartUnit(NeedSystemUnit: boolean); + procedure StartUnit(NeedSystemUnit: boolean; SystemUnitParts: TSystemUnitParts = []); property Modules[Index: integer]: TTestEnginePasResolver read GetModules; property ModuleCount: integer read GetModuleCount; property Hub: TPasResolverHub read FHub; @@ -2345,10 +2345,11 @@ begin Add('library '+ExtractFileUnitName(MainFilename)+';'); end; -procedure TCustomTestResolver.StartUnit(NeedSystemUnit: boolean); +procedure TCustomTestResolver.StartUnit(NeedSystemUnit: boolean; + SystemUnitParts: TSystemUnitParts); begin if NeedSystemUnit then - AddSystemUnit + AddSystemUnit(SystemUnitParts) else Parser.ImplicitUses.Clear; Add('unit '+ExtractFileUnitName(MainFilename)+';'); diff --git a/packages/fcl-passrc/tests/tcuseanalyzer.pas b/packages/fcl-passrc/tests/tcuseanalyzer.pas index bd7d429648..43530762cc 100644 --- a/packages/fcl-passrc/tests/tcuseanalyzer.pas +++ b/packages/fcl-passrc/tests/tcuseanalyzer.pas @@ -85,6 +85,7 @@ type procedure TestM_Class_PropertyInherited; procedure TestM_Class_MethodOverride; procedure TestM_Class_MethodOverride2; + procedure TestM_Class_NestedClass; procedure TestM_ClassInterface_Corba; procedure TestM_ClassInterface_NoHintsForMethod; procedure TestM_ClassInterface_NoHintsForImpl; @@ -1321,6 +1322,36 @@ begin AnalyzeProgram; end; +procedure TTestUseAnalyzer.TestM_Class_NestedClass; +begin + StartUnit(true,[supTObject]); + Add([ + 'interface', + 'type', + ' TBird = class', + ' public type', + ' TWing = class', + ' private', + ' function GetCurrent: TBird;', + ' public', + ' function MoveNext: Boolean; reintroduce;', + ' property Current: TBird read GetCurrent;', + ' end;', + ' end;', + 'implementation', + 'function TBird.TWing.GetCurrent: TBird;', + 'begin', + ' Result:=nil;', + 'end;', + 'function TBird.TWing.MoveNext: Boolean; reintroduce;', + 'begin', + ' Result:=false;', + 'end;', + '']); + AnalyzeUnit; + CheckUseAnalyzerUnexpectedHints; +end; + procedure TTestUseAnalyzer.TestM_ClassInterface_Corba; begin StartProgram(false); diff --git a/packages/fcl-web/src/base/httpdefs.pp b/packages/fcl-web/src/base/httpdefs.pp index e2886c79b6..c5ed8944c9 100644 --- a/packages/fcl-web/src/base/httpdefs.pp +++ b/packages/fcl-web/src/base/httpdefs.pp @@ -2347,7 +2347,7 @@ begin if FSecure then AddToResult(SCookieSecure); if FSameSite<>ssEmpty then - AddToResult(SCookieSameSite+': '+SSameSiteValues[FSameSite]); + AddToResult(SCookieSameSite+'='+SSameSiteValues[FSameSite]); except {$ifdef cgidebug} On E : Exception do diff --git a/packages/morphunits/src/amigados.pas b/packages/morphunits/src/amigados.pas index 68c12198d1..a411b01527 100644 --- a/packages/morphunits/src/amigados.pas +++ b/packages/morphunits/src/amigados.pas @@ -814,6 +814,24 @@ const ST_LINKFILE = -4; ST_PIPEFILE = -5; +type + TCLIDataItem = record + cdi_CLINum: LongInt; // CLI number of the CLI + cdi_DefaultStack: LongInt; // cli_DefaultStack of the CLI + cdi_GlobVec: LongInt; // pr_GlobVec[0] of the CLI + cdi_Future: LongWord; // For future expansion, 0 for now + cdi_Pri: ShortInt; // CLI priority + cdi_Flags: Byte; // If bit 0 is set cdi_command is valid + cdi_Command: array[0..0] of Char; // 0-terminated command being executed + end; + PCLIDataItem = ^TCLIDataItem; + + TCLIData = record + cd_NumCLIs: LongWord; // Number of entries in cd_cli array + cd_CLI: array[0..100] of PCLIDataItem; // the entries (could be more than 101 though) + end; + PCLIData = ^TCLIData; + { * dos asl definitions @@ -1297,8 +1315,33 @@ const FSCONTEXTINFOTAG_NAME = FSCONTEXTINFOTAG_Dummy + $1; SEGLISTTAG_Dummy = TAG_USER + 3400; - // return the ObjData object when it exists or nil. - SEGLISTTAG_OBJDATA = SEGLISTTAG_Dummy + $1; + + SEGLISTTAG_OBJDATA = SEGLISTTAG_Dummy + $1; // return the ObjData object when it exists or nil. + // V51.52 + SEGLISTTAG_SEGLISTTYPE = SEGLISTTAG_Dummy + $2; // return the seglist type, one of SEGLISTTYPE_*. + SEGLISTTAG_DOS_SEGINDEX = SEGLISTTAG_Dummy + $3; // specify that segment index is the hunk number, starting from 0. + SEGLISTTAG_ELF_SEGINDEX = SEGLISTTAG_Dummy + $4; // specify that the segment index is the elf segment number, starting from 1. + SEGLISTTAG_SEGSTART = SEGLISTTAG_Dummy + $5; // return segment start address for segment specified by either SEGLISTTAG_DOS_SEGINDEX or SEGLISTTAG_ELF_SEGINDEX. + // note that SEGLISTTAG_ELF_SEGINDEX segments might return a nil pointer, so be prepared for this. + SEGLISTTAG_SEGSIZE = SEGLISTTAG_Dummy + $6; // return segment data size for segment specified by either SEGLISTTAG_DOS_SEGINDEX or SEGLISTTAG_ELF_SEGINDEX. + // V51.54 + SEGLISTTAG_ELF_SEGTYPE = SEGLISTTAG_Dummy + $7; // return ELF segment type (ELF SHT_*). Only applicable for ELF. + SEGLISTTAG_ELF_SEGOFFSET = SEGLISTTAG_Dummy + $8; // return ELF segment file offset. Only applicable for ELF. + SEGLISTTAG_ELF_SEGFLAGS = SEGLISTTAG_Dummy + $9; // return ELF segment flags. Meaning depends on segment type. Refer to ELF documentation for details. Only applicable for ELF. + SEGLISTTAG_ELF_SEGADDRALIGN = SEGLISTTAG_Dummy + $a; // return ELF segment alignment. 0 and 1 mean unaligned. Only applicable for ELF. + SEGLISTTAG_ELF_SEGNAME = SEGLISTTAG_Dummy + $b; // return ELF segname name. Only applicable for ELF. + + + // for tag SEGLISTTAG_SEGLISTTYPE + SEGLISTTYPE_ELF = 1; + SEGLISTTYPE_POWERUP = 2; + SEGLISTTYPE_AMIGA = 3; + + // QueryCLIDataTagList tags (V51.51) + CLIDATATAG_Dummy = TAG_USER + 3500; + CLIDATATAG_CLINumber = CLIDATATAG_Dummy + $1; // Return only CLI matching the given CLI number (returns 0 or 1 entries) + CLIDATATAG_CommandName = CLIDATATAG_Dummy + $2; // Return only CLIs matching the given command (0 to n entries possible) + CLIDATATAG_Sorted = CLIDATATAG_Dummy + $3; // When ti_Data is TRUE, return results sorted by CLI number(default to FALSE) { * dos stdio definitions @@ -2264,6 +2307,12 @@ function ExNext64(Lock: BPTR; Fib: PFileInfoBlock; Tags: PTagItem): LongInt; sys function ExNext64TagList(Lock: BPTR; Fib: PFileInfoBlock; Tags: PTagItem): LongInt; syscall BaseSysV MOS_DOSBase 1150; function ExamineFH64(Fh: BPTR; Fib: PFileInfoBlock; Tags: PTagItem): LongInt; syscall BaseSysV MOS_DOSBase 1156; function ExamineFH64TagList(Fh: BPTR; Fib: PFileInfoBlock; Tags: PTagItem): LongInt; syscall BaseSysV MOS_DOSBase 1156; +// V51.51 +procedure ReleaseCLINumber(CLINum: LongInt); syscall BaseSysV MOS_DOSBase 1162; +function QueryCLIDataTagList(Tags: PTagItem): PCLIData; syscall BaseSysV MOS_DOSBase 1168; +procedure FreeCLIData(Data: PCLIData); syscall BaseSysV MOS_DOSBase 1174; +// V51.52 +function GetSegListAttrTagList(SegList: BPTR; Attr: LongInt; Storage: APTR; StorageSize: LongInt; Tags: PTagItem): LongInt; syscall BaseSysV MOS_DOSBase 1180; { * dos global definitions (V50) @@ -2301,6 +2350,9 @@ function Examine64Tags(Lock: BPTR; Fib: PFileInfoBlock; const Tags: array of Ptr function ExNext64Tags(Lock: BPTR; Fib: PFileInfoBlock; const Tags: array of PtrUInt): LongInt; inline; function ExamineFH64Tags(Fh: BPTR; Fib: PFileInfoBlock; const Tags: array of PtrUInt): LongInt; inline; +function QueryCLIDataTags(const Tags: array of PtrUInt): PCLIData; inline; +function GetSegListAttrTags(SegList: BPTR; Attr: LongInt; Storage: APTR; StorageSize: LongInt; const Tags: array of PtrUInt): LongInt; inline; + implementation @@ -2406,6 +2458,17 @@ begin ExamineFH64Tags := ExamineFH64(Fh, Fib, @Tags); end; +function QueryCLIDataTags(const Tags: array of PtrUInt): PCLIData; +begin + QueryCLIDataTags := QueryCLIDataTagList(@Tags); +end; + +function GetSegListAttrTags(SegList: BPTR; Attr: LongInt; Storage: APTR; StorageSize: LongInt; const Tags: array of PtrUInt): LongInt; inline; +begin + GetSegListAttrTags := GetSegListAttrTagList(SegList, Attr, Storage, StorageSize, @Tags); +end; + + begin DosBase:=MOS_DOSBase; end. diff --git a/packages/morphunits/src/asl.pas b/packages/morphunits/src/asl.pas index 9e9689ea9e..b11f48a496 100644 --- a/packages/morphunits/src/asl.pas +++ b/packages/morphunits/src/asl.pas @@ -397,7 +397,7 @@ const ASLSM_MaxWidth = ASL_TB + 117; // Maximum display width to allow ASLSM_MinHeight = ASL_TB + 118; // Minimum display height to allow ASLSM_MaxHeight = ASL_TB + 119; // Maximum display height to allow - ASLSM_MinDepth = ASL_TB + 120; // Minimum display depth + //ASLSM_MinDepth = ASL_TB + 120; // Minimum display depth // obsolete due to a compatibility issue ASLSM_MaxDepth = ASL_TB + 121; // Maximum display depth ASLSM_FilterFunc = ASL_TB + 122; // Function to filter mode id's @@ -406,8 +406,10 @@ const ASLSM_PopToFront = ASL_TB + 131; // Make the requester window visible when it opens // V45 ASLSM_Activate = ASL_TB + 132; // Activate the requester window when it opens + // V51 + ASLSM_MinDepth = ASL_TB + 133; // Minimum display depth - ASL_LAST_TAG = ASL_TB + 133; + ASL_LAST_TAG = ASL_TB + 134; {***************************************************************************} diff --git a/packages/morphunits/src/exec.pas b/packages/morphunits/src/exec.pas index 66b09b337f..b582709190 100644 --- a/packages/morphunits/src/exec.pas +++ b/packages/morphunits/src/exec.pas @@ -676,11 +676,15 @@ const TASKINFOTYPE_USERDATA = $2b; // Get/Set task tc_UserData (LongWord) TASKINFOTYPE_RESURRECT_TASK = $2c; // Tag used to restart a suspended task (LongWord) TASKINFOTYPE_EMULHANDLE = $2d; // Get/Set task emulhandle (APTR) + // Added in exec 50.67 TASKINFOTYPE_EXCEPTIONCOUNT = $2e; // Get task exception count (LongWord) TASKINFOTYPE_HITCOUNT = $2f; // Get task hit count (LongWord) + // Added in exec 51.3 TASKINFOTYPE_MAXHITCOUNT = $30; // Get/Set task max hit count. If more hits happen the task is put to sleep. (LongWord) + // Added in exec 51.13 TASKINFOTYPE_ALERTCOUNT = $31; // Get task alert count (LongWord) TASKINFOTYPE_MAXALERTCOUNT = $32; // Get/Set task max alert count. If more alerts happen the task is put to sleep. (LongWord) + // Added in exec 51.14 TASKINFOTYPE_PID = $33; // Get task unique ID. This ID is unique to every task. (LongWord) TASKINFOTYPE_68K_NEWFRAME = $50; @@ -1747,7 +1751,14 @@ const SYSTEMINFOTAG_MEMHEADER = SYSTEMINFOTAG_DUMMY + $1; SYSTEMINFOTAG_HOOK = SYSTEMINFOTAG_DUMMY + $2; +// TLSAlloc (V51.46) +const + TLS_INVALID_INDEX = $ffffffff; +// tags for TLSAlloc + TLSTAG_DUMMY = TAG_USER + $120000; + TLSTAG_DESTRUCTOR = TLSTAG_DUMMY + $0; // Destructor function to call on task termination if the TLS value is non-nil. The function is called with as: procedure(value: APTR; userdata: APTR); + TLSTAG_USERDATA = TLSTAG_DUMMY + $1; // Userdata for the destructor function. Defaults to nil. function Supervisor(userFunction: Pointer location 'a5'): Cardinal; SysCall MOS_ExecBase 030; @@ -2331,6 +2342,14 @@ procedure PutMsgHead(Port: PMsgPort; Message: PMessage); SysCall BaseSysV MOS_Ex function NewGetTaskPIDAttrsA(PID: LongWord location 'd0'; Data: APTR location 'a0'; DataSize: LongWord location 'd1'; Type_: LongWord location 'd2'; Tags: PTagItem location 'a1'): LongWord; SysCall MOS_ExecBase 1068; function NewSetTaskPIDAttrsA(PID: LongWord location 'd0'; Data: APTR location 'a0'; DataSize: LongWord location 'd1'; Type_: LongWord location 'd2'; Tags: PTagItem location 'a1'): LongWord; SysCall MOS_ExecBase 1074; +// added in V51.46 +function TLSAllocA(Tags: PTagItem): LongWord; SysCall BaseSysV MOS_ExecBase 1084; +function TLSFree(Idx: LongWord): LongInt; SysCall BaseSysV MOS_ExecBase 1090; +function TLSGetValue(Idx: LongWord): APTR; SysCall BaseSysV MOS_ExecBase 1096; +function TLSSetValue(Idx: LongWord; Value: APTR): LongInt; SysCall BaseSysV MOS_ExecBase 1102; +procedure TLSCallDestructors(Task: PTask); SysCall BaseSysV MOS_ExecBase 1108; + + function NewGetTaskAttrs(Task: PTask; Data: APTR; DataSize, TType: LongWord; const Tags: array of PtrUInt): LongWord; Inline; function NewSetTaskAttrs(Task: PTask; Data: APTR; DataSize, TType: Cardinal; const Tags: array of PtrUInt): LongWord; Inline; @@ -2342,6 +2361,8 @@ function AddExecNode(InNode: APTR; const Tags: array of PtrUInt): APTR; inline; function NewGetTaskPIDAttrs(PID: LongWord; Data: APTR; DataSize, Type_: LongWord; const Tags: array of PtrUInt): LongWord; inline; function NewSetTaskPIDAttrs(PID: LongWord; Data: APTR; DataSize, Type_: LongWord; const Tags: array of PtrUInt): LongWord; inline; +function TLSAlloc(const Tags: array of PtrUInt): LongWord; inline; + function CreateExtIO(const Mp: PMsgPort; Size: Integer): PIORequest; procedure DeleteExtIO(ioReq: PIORequest); @@ -2392,6 +2413,11 @@ begin NewSetTaskPIDAttrs := NewSetTaskPIDAttrsA(PID, Data, DataSize, Type_, @Tags); end; +function TLSAlloc(const Tags: array of PtrUInt): LongWord; inline; +begin + TLSAlloc := TLSAllocA(@Tags); +end; + function GetEmulHandle: PEmulHandle; assembler; nostackframe; asm mr r3,r2 diff --git a/packages/morphunits/src/intuition.pas b/packages/morphunits/src/intuition.pas index a65b916a76..8c76e36811 100644 --- a/packages/morphunits/src/intuition.pas +++ b/packages/morphunits/src/intuition.pas @@ -3336,6 +3336,7 @@ const MM_RunBlanker = $406; // Start screensaver for this monitor MM_EnterPowerSaveMode = $407; // Start power saving mode MM_ExitBlanker = $408; // Stop screensaver or power saving mode + MM_Authorization = $409; // Opens the user password authorization screen, added in 51.68 type PmsGetRootBitMap = ^TmsGetRootBitMap; diff --git a/packages/morphunits/src/locale.pas b/packages/morphunits/src/locale.pas index 7b3ece281d..5331a41657 100644 --- a/packages/morphunits/src/locale.pas +++ b/packages/morphunits/src/locale.pas @@ -187,6 +187,7 @@ const OC_Version = OC_TagBase + 3; // catalog version number required OC_Language = OC_TagBase + 4; // preferred language of catalog OC_CodeSet = OC_TagBase + 5; // V51 + OC_BuiltInStrings = OC_TagBase + 6; // V52.3 // Comparison types for StrnCmp() SC_ASCII = 0; diff --git a/packages/morphunits/src/workbench.pas b/packages/morphunits/src/workbench.pas index 7149c30281..8b8b8dcb57 100644 --- a/packages/morphunits/src/workbench.pas +++ b/packages/morphunits/src/workbench.pas @@ -479,6 +479,10 @@ function MakeWorkbenchObjectVisibleA(Name: STRPTR location 'a0'; const Tags: PTa function OpenWorkbenchObjectA(Name: STRPTR location 'a0'; const Tags: PTagItem location 'a1'): LongBool; syscall WorkbenchBase 096; function RemoveAppWindowDropZone(Aw: PAppWindow location 'a0'; DropZone: PAppWindowDropZone location 'a1'): LongBool; syscall WorkbenchBase 120; function WorkbenchControlA(Name: STRPTR location 'a0'; const Tags: PTagItem location 'a1'): LongBool; syscall WorkbenchBase 108; +// V51 +function ManageDesktopObjectA(Name: PChar; Action: LongInt; Tags: PTagItem): Boolean; syscall BaseSysV WorkbenchBase 148; +function CreateDrawerA(Drawer: PChar; Tags: PTagItem): Boolean; syscall BaseSysV WorkbenchBase 154; +function CreateIconA(Name: PChar; Tags: PTagItem): Boolean; syscall BaseSysV WorkbenchBase 160; function AddAppIcon(Id: LongWord; UserData: LongWord; Text_: PChar; MsgPort: PMsgPort; Lock: BPTR; DiskObj: PDiskObject; const TagList: array of PtrUInt): PAppIcon; inline; function AddAppMenuItem(Id: LongWord; UserData: LongWord; Text_: PChar; MsgPort: PMsgPort; const Tags: array of PtrUInt): PAppMenuItem; inline; @@ -490,6 +494,10 @@ function WorkbenchControl(Name: PChar; const Tags: array of PtrUInt): LongBool; function AddAppWindowDropZone(Aw: PAppWindow; Id: LongWord; UserData: LongWord; const Tags: array of PtrUInt): PAppWindowDropZone; inline; function ChangeWorkbenchSelection(Name: STRPTR; Hook: PHook; const Tags: array of PtrUInt): LongBool; inline; function MakeWorkbenchObjectVisible(Name: STRPTR; const Tags: array of PtrUInt): LongBool; inline; +// V51 +function ManageDesktopObjectTags(Name: PChar; Action: LongInt; const Tags: array of PtrUInt): Boolean; inline; +function CreateDrawerTags(Drawer: PChar; const Tags: array of PtrUInt): Boolean; inline; +function CreateIconTags(Name: PChar; const Tags: array of PtrUInt): Boolean; inline; implementation @@ -538,6 +546,21 @@ begin MakeWorkbenchObjectVisible := MakeWorkbenchObjectVisibleA(Name, @Tags); end; +function ManageDesktopObjectTags(Name: PChar; Action: LongInt; const Tags: array of PtrUInt): Boolean; +begin + ManageDesktopObjectTags := ManageDesktopObjectA(Name, Action, @Tags); +end; + +function CreateDrawerTags(Drawer: PChar; const Tags: array of PtrUInt): Boolean; +begin + CreateDrawerTags := CreateDrawerA(Drawer, @Tags); +end; + +function CreateIconTags(Name: PChar; const Tags: array of PtrUInt): Boolean; +begin + CreateIconTags := CreateIconA(Name, @Tags); +end; + const LIBVERSION: LongWord = 0; diff --git a/packages/os4units/src/intuition.pas b/packages/os4units/src/intuition.pas index cc06beb802..738cf6775b 100644 --- a/packages/os4units/src/intuition.pas +++ b/packages/os4units/src/intuition.pas @@ -835,7 +835,7 @@ type TIntuiRawKeyData = record Version: Word; // version of this structure (see below) Reserved: Word; // always 0, reserved for future use - Class: Word; // copy of ie_SubClass (see IECLASS_EXTENDED_RAWKEY) + Class_: Word; // copy of ie_SubClass (see IECLASS_EXTENDED_RAWKEY) Code: Word; // rawkey code DeadKeys: TExtendedDeadKey; // deadkey information end; diff --git a/packages/pastojs/src/fppas2js.pp b/packages/pastojs/src/fppas2js.pp index 2865296ddc..bb479e22f8 100644 --- a/packages/pastojs/src/fppas2js.pp +++ b/packages/pastojs/src/fppas2js.pp @@ -6877,20 +6877,22 @@ function TPas2JSResolver.IsTGUID(TypeEl: TPasRecordType): boolean; var Members: TFPList; El: TPasElement; + MemberIndex, i: Integer; begin Result:=false; if not SameText(TypeEl.Name,'TGUID') then exit; Members:=TypeEl.Members; - if Members.Count<4 then exit; - El:=TPasElement(Members[0]); - if not SameText(El.Name,'D1') then exit; - El:=TPasElement(Members[1]); - if not SameText(El.Name,'D2') then exit; - El:=TPasElement(Members[2]); - if not SameText(El.Name,'D3') then exit; - El:=TPasElement(Members[3]); - if not SameText(El.Name,'D4') then exit; - Result:=true; + i:=1; + for MemberIndex:=0 to Members.Count-1 do + begin + El:=TPasElement(Members[MemberIndex]); + if (El.ClassType<>TPasVariable) then continue; + if SameText(El.Name,'D'+IntToStr(i)) then + begin + if i=4 then exit(true); + inc(i); + end; + end; end; function TPas2JSResolver.GetAssignGUIDString(TypeEl: TPasRecordType; @@ -15577,11 +15579,11 @@ begin RaiseNotSupported(El,AContext,20170927183645); if El.Parent is TProcedureBody then RaiseNotSupported(El,AContext,20181231004355); + if not aResolver.IsFullySpecialized(El) then exit; if El.IsForward then exit(ConvertClassForwardType(El,AContext)) else if El.IsExternal then exit(ConvertExtClassType(El,AContext)); - if not aResolver.IsFullySpecialized(El) then exit; if El.CustomData is TPas2JSClassScope then begin @@ -20518,34 +20520,51 @@ function TPasToJSConverter.CreateGUIDObjLit(aTGUIDRecord: TPasRecordType; const GUID: TGUID; PosEl: TPasElement; AContext: TConvertContext ): TJSObjectLiteral; var + i: integer; Members: TFPList; + + function GetMember(const aName: string): TPasElement; + begin + while i<Members.Count do + begin + Result:=TPasElement(Members[i]); + inc(i); + if (Result is TPasVariable) then + if SameText(Result.Name,aName) then + exit + else + RaiseInconsistency(20180415094721,PosEl); + end; + RaiseInconsistency(20210306223031,PosEl); + end; + +var PropEl: TJSObjectLiteralElement; MemberEl: TPasElement; ArrLit: TJSArrayLiteral; - i: Integer; begin Members:=aTGUIDRecord.Members; Result:=TJSObjectLiteral(CreateElement(TJSObjectLiteral,PosEl)); + i:=0; + // D1: 0x12345678 + MemberEl:=GetMember('D1'); PropEl:=Result.Elements.AddElement; - MemberEl:=TPasElement(Members[0]); - if not SameText(MemberEl.Name,'D1') then - RaiseInconsistency(20180415094721,PosEl); PropEl.Name:=TJSString(TransformElToJSName(MemberEl,AContext)); PropEl.Expr:=CreateLiteralHexNumber(PosEl,GUID.D1,8); // D2: 0x1234 + MemberEl:=GetMember('D2'); PropEl:=Result.Elements.AddElement; - MemberEl:=TPasElement(Members[1]); PropEl.Name:=TJSString(TransformElToJSName(MemberEl,AContext)); PropEl.Expr:=CreateLiteralHexNumber(PosEl,GUID.D2,4); // D3: 0x1234 + MemberEl:=GetMember('D3'); PropEl:=Result.Elements.AddElement; - MemberEl:=TPasElement(Members[2]); PropEl.Name:=TJSString(TransformElToJSName(MemberEl,AContext)); PropEl.Expr:=CreateLiteralHexNumber(PosEl,GUID.D3,4); // D4: [0x12,0x12,0x12,0x12,0x12,0x12,0x12,0x12] + MemberEl:=GetMember('D4'); PropEl:=Result.Elements.AddElement; - MemberEl:=TPasElement(Members[3]); PropEl.Name:=TJSString(TransformElToJSName(MemberEl,AContext)); ArrLit:=TJSArrayLiteral(CreateElement(TJSArrayLiteral,PosEl)); PropEl.Expr:=ArrLit; diff --git a/packages/pastojs/tests/tcmodules.pas b/packages/pastojs/tests/tcmodules.pas index 1092da987a..8731d86b8f 100644 --- a/packages/pastojs/tests/tcmodules.pas +++ b/packages/pastojs/tests/tcmodules.pas @@ -31794,6 +31794,9 @@ begin ' [TCustom(1)]', ' TMyClass = class', ' end;', + ' [TCustom(11)]', + ' TMyDescendant = class(TMyClass)', + ' end;', ' [TCustom(2)]', ' TRec = record', ' end;', @@ -31826,6 +31829,10 @@ begin ' var $r = this.$rtti;', ' $r.attr = [$mod.TCustomAttribute, "Create", [1]];', '});', + 'rtl.createClass(this, "TMyDescendant", this.TMyClass, function () {', + ' var $r = this.$rtti;', + ' $r.attr = [$mod.TCustomAttribute, "Create", [11]];', + '});', 'rtl.recNewT(this, "TRec", function () {', ' this.$eq = function (b) {', ' return true;', diff --git a/packages/rtl-extra/src/linux/unxsockh.inc b/packages/rtl-extra/src/linux/unxsockh.inc index 070ab18e0e..47b987c11d 100644 --- a/packages/rtl-extra/src/linux/unxsockh.inc +++ b/packages/rtl-extra/src/linux/unxsockh.inc @@ -13,7 +13,21 @@ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. } -Const +type + Pucred = ^ucred; + + ucred = record + pid: cuint32; + uid: cuint32; + gid: cuint32; + end; + +const + + SCM_RIGHTS = $01; { rw: access rights (array of int) } + SCM_CREDENTIALS = $02; { rw: struct ucred } + SCM_SECURITY = $03; { rw: security label } + {* Supported address families. *} AF_UNSPEC = 0; AF_UNIX = 1; { Unix domain sockets } @@ -38,14 +52,33 @@ Const AF_ASH = 18; { Ash } AF_ECONET = 19; { Acorn Econet } AF_ATMSVC = 20; { ATM SVCs } + AF_RDS = 21; { RDS sockets } AF_SNA = 22; { Linux SNA Project (nutters!) } AF_IRDA = 23; { IRDA sockets } AF_PPPOX = 24; { PPPoX sockets } AF_WANPIPE = 25; { Wanpipe API Sockets } AF_LLC = 26; { Linux LLC } + AF_IB = 27; { Native InfiniBand address } + AF_MPLS = 28; { MPLS } + AF_CAN = 29; { Controller Area Network } AF_TIPC = 30; { TIPC sockets } AF_BLUETOOTH = 31; { Bluetooth sockets } - AF_MAX = 32; { For now.. } + AF_IUCV = 32; { IUCV sockets } + AF_RXRPC = 33; { RxRPC sockets } + AF_ISDN = 34; { mISDN sockets } + AF_PHONET = 35; { Phonet sockets } + AF_IEEE802154 = 36; { IEEE802154 sockets } + AF_CAIF = 37; { CAIF sockets } + AF_ALG = 38; { Algorithm sockets } + AF_NFC = 39; { NFC sockets } + AF_VSOCK = 40; { vSockets } + AF_KCM = 41; { Kernel Connection Multiplexor} + AF_QIPCRTR = 42; { Qualcomm IPC Router } + AF_SMC = 43; { smc sockets: reserve number for + PF_SMC protocol family that + reuses AF_INET address family} + AF_XDP = 44; { XDP sockets } + AF_MAX = 45; { For now.. } SOCK_MAXADDRLEN = 255; { longest possible addresses } @@ -76,18 +109,35 @@ Const PF_ASH = AF_ASH; PF_ECONET = AF_ECONET; PF_ATMSVC = AF_ATMSVC; + PF_RDS = AF_RDS; PF_SNA = AF_SNA; PF_IRDA = AF_IRDA; PF_PPPOX = AF_PPPOX; PF_WANPIPE = AF_WANPIPE; PF_LLC = AF_LLC; + PF_IB = AF_IB; + PF_MPLS = AF_MPLS; + PF_CAN = AF_CAN; PF_TIPC = AF_TIPC; PF_BLUETOOTH = AF_BLUETOOTH; + PF_IUCV = AF_IUCV; + PF_RXRPC = AF_RXRPC; + PF_ISDN = AF_ISDN; + PF_PHONET = AF_PHONET; + PF_IEEE802154 = AF_IEEE802154; + PF_CAIF = AF_CAIF; + PF_ALG = AF_ALG; + PF_NFC = AF_NFC; + PF_VSOCK = AF_VSOCK; + PF_KCM = AF_KCM; + PF_QIPCRTR = AF_QIPCRTR; + PF_SMC = AF_SMC; + PF_XDP = AF_XDP; PF_MAX = AF_MAX; { Maximum queue length specifiable by listen. } - SOMAXCONN = 128; + SOMAXCONN = 4096; { For setsockoptions(2) } SOL_SOCKET = 1; @@ -220,7 +270,52 @@ Const IP_PMTUDISC_DO = 2; { Always DF. } { To select the IP level. } +{ Setsockoptions(2) level. Thanks to BSD these must match IPPROTO_xxx } SOL_IP = 0; + // SOL_ICMP = 1; { No-no-no! Due to Linux :-) we cannot use SOL_ICMP=1 } + SOL_TCP = 6; + SOL_UDP = 17; + +{ Socket level values for IPv6. } + SOL_IPV6 = 41; + SOL_ICMPV6 = 58; + + SOL_SCTP = 132; + SOL_UDPLITE = 136; { UDP-Lite (RFC 3828) } + SOL_RAW = 255; + SOL_IPX = 256; + SOL_AX25 = 257; + SOL_ATALK = 258; + SOL_NETROM = 259; + SOL_ROSE = 260; + SOL_DECNET = 261; + SOL_X25 = 262; + SOL_PACKET = 263; + SOL_ATM = 264; { ATM layer (cell level) } + SOL_AAL = 265; { ATM Adaption Layer (packet level) } + SOL_IRDA = 266; + SOL_NETBEUI = 267; + SOL_LLC = 268; + SOL_DCCP = 269; + SOL_NETLINK = 270; + SOL_TIPC = 271; + SOL_RXRPC = 272; + SOL_PPPOL2TP = 273; + SOL_BLUETOOTH = 274; + SOL_PNPIPE = 275; + SOL_RDS = 276; + SOL_IUCV = 277; + SOL_CAIF = 278; + SOL_ALG = 279; + SOL_NFC = 280; + SOL_KCM = 281; + SOL_TLS = 282; + SOL_XDP = 283; + + +{ IPX options } + IPX_TYPE = 1; + IP_DEFAULT_MULTICAST_TTL = 1; IP_DEFAULT_MULTICAST_LOOP = 1; @@ -274,10 +369,6 @@ Const IPV6_PMTUDISC_WANT = 1; { Use per route hints. } IPV6_PMTUDISC_DO = 2; { Always DF. } -{ Socket level values for IPv6. } - SOL_IPV6 = 41; - SOL_ICMPV6 = 58; - { Routing header options for IPv6. } IPV6_RTHDR_LOOSE = 0; { Hop doesn't need to be neighbour. } IPV6_RTHDR_STRICT = 1; { Hop must be a neighbour. } @@ -285,24 +376,38 @@ Const IPV6_RTHDR_TYPE_0 = 0; { IPv6 Routing header type 0. } { Flags for send, recv etc. } - MSG_OOB = $0001; { Process out-of-band data} - MSG_PEEK = $0002; { Peek at incoming messages } - MSG_DONTROUTE= $0004; { Don't use local routing } + MSG_OOB = $00000001; { Process out-of-band data} + MSG_PEEK = $00000002; { Peek at incoming messages } + MSG_DONTROUTE = $00000004; { Don't use local routing } MSG_TRYHARD = MSG_DONTROUTE; - MSG_CTRUNC = $0008; { Control data lost before delivery } - MSG_PROXY = $0010; { Supply or ask second address } - MSG_TRUNC = $0020; - MSG_DONTWAIT = $0040; { Non-blocking I/O } - MSG_EOR = $0080; { End of record } - MSG_WAITALL = $0100; { Wait for a full request } - MSG_FIN = $0200; - MSG_SYN = $0400; - MSG_CONFIRM = $0800; { Confirm path validity } - MSG_RST = $1000; - MSG_ERRQUERE = $2000; { Fetch message from error queue } - MSG_NOSIGNAL = $4000; { Do not generate SIGPIPE } - MSG_MORE = $8000; { Sender will send more } + MSG_CTRUNC = $00000008; { Control data lost before delivery } + MSG_PROXY = $00000010; { Supply or ask second address } + MSG_PROBE = MSG_PROXY; { Do not send. Only probe path f.e. for MTU } + MSG_TRUNC = $00000020; + MSG_DONTWAIT = $00000040; { Non-blocking I/O } + MSG_EOR = $00000080; { End of record } + MSG_WAITALL = $00000100; { Wait for a full request } + MSG_FIN = $00000200; + MSG_SYN = $00000400; + MSG_CONFIRM = $00000800; { Confirm path validity } + MSG_RST = $00001000; + MSG_ERRQUERE = $00002000; { Fetch message from error queue } + MSG_NOSIGNAL = $00004000; { Do not generate SIGPIPE } + MSG_MORE = $00008000; { Sender will send more } + MSG_WAITFORONE = $00010000; { recvmmsg(): block until 1+ packets avail } + MSG_SENDPAGE_NOPOLICY = $00010000; { sendpage() internal : do no apply policy } + MSG_SENDPAGE_NOTLAST = $00020000; { sendpage() internal : not the last page } + MSG_BATCH = $00040000; { sendmmsg(): more messages coming } MSG_EOF = MSG_FIN; + MSG_NO_SHARED_FRAGS = $00080000; { sendpage() internal : page frags are not shared } + MSG_SENDPAGE_DECRYPTED = $00100000; { sendpage() internal : page may carry + plain text and require encryption } + MSG_ZEROCOPY = $04000000; { Use user data in kernel path } + MSG_FASTOPEN = $20000000; { Send data in TCP SYN } + MSG_CMSG_CLOEXEC = $40000000; { Set close_on_exec for file + descriptor received through SCM_RIGHTS } + MSG_CMSG_COMPAT = $0; {$80000000} { This message would need 32 bit fixups, so use 0 instead } + TCP_NODELAY = 1; { Limit MSS } diff --git a/packages/rtl-objpas/src/inc/fmtbcd.pp b/packages/rtl-objpas/src/inc/fmtbcd.pp index f26041d984..293bc346fc 100644 --- a/packages/rtl-objpas/src/inc/fmtbcd.pp +++ b/packages/rtl-objpas/src/inc/fmtbcd.pp @@ -797,10 +797,12 @@ INTERFACE {$endif} function __get_null : tBCD; Inline; + function __get_zero : tBCD; Inline; function __get_one : tBCD; Inline; PROPERTY NullBCD : tBCD Read __get_null; + ZeroBCD : tBCD Read __get_zero; OneBCD : tBCD Read __get_one; //{$define __lo_bh := 1 * ( -( MaxFmtBCDFractionSize * 1 + 2 ) ) } @@ -887,16 +889,20 @@ IMPLEMENTATION OneBCD_ : tBCD; function __get_null : tBCD; Inline; - begin __get_null := NullBCD_; - end; + end; - function __get_one : tBCD; Inline; + function __get_zero : tBCD; Inline; + begin + __get_zero := NullBCD_; + __get_zero.Precision := 1; + end; + function __get_one : tBCD; Inline; begin __get_one := OneBCD_; - end; + end; type range_digits = 1..maxfmtbcdfractionsize; @@ -1584,7 +1590,7 @@ IMPLEMENTATION begin _SELECT _WHEN aValue = 0 - _THEN result := NullBCD; + _THEN result := ZeroBCD; _WHEN aValue = 1 _THEN result := OneBCD; _WHEN aValue = low ( myInttype ) @@ -4130,12 +4136,6 @@ begin else { array or something like that } not_implemented; end; - // peephole, avoids problems with databases, mantis #30853 - if (Result.Precision = 0) and (Result.SignSpecialPlaces = 0) then - begin - Result.Precision := 10; - Result.SignSpecialPlaces := 2; - end; end; function VarToBCD ( const aValue : Variant ) : tBCD; diff --git a/packages/rtl-objpas/src/inc/strutils.pp b/packages/rtl-objpas/src/inc/strutils.pp index 8233c1ecce..b89ad41c45 100644 --- a/packages/rtl-objpas/src/inc/strutils.pp +++ b/packages/rtl-objpas/src/inc/strutils.pp @@ -1051,7 +1051,7 @@ begin if (Length(AText) >= Length(ASubText)) and (ASubText <> '') then Result := StrLComp(PChar(ASubText), PChar(AText), Length(ASubText)) = 0 else - Result := False; + Result := (AsubText=''); end; diff --git a/rtl/embedded/Makefile b/rtl/embedded/Makefile index d4d5c1c88b..acb5650df5 100644 --- a/rtl/embedded/Makefile +++ b/rtl/embedded/Makefile @@ -502,6 +502,11 @@ override FPCOPT+=-Cprv32imac CPU_UNITS=fe310g000 fe310g002 gd32vf103xx CPU_UNITS_DEFINED=1 endif +ifeq ($(SUBARCH),rv32i) +override FPCOPT+=-Cprv32i +CPU_UNITS= +CPU_UNITS_DEFINED=1 +endif ifeq ($(CPU_UNITS_DEFINED),) $(error No CPUs enabled for given SUBARCH, pass either a SUBARCH or set CPU_UNITS_DEFINED=1 if you know what you are doing) endif diff --git a/rtl/embedded/Makefile.fpc b/rtl/embedded/Makefile.fpc index 8817d786bd..4751555ec4 100644 --- a/rtl/embedded/Makefile.fpc +++ b/rtl/embedded/Makefile.fpc @@ -207,6 +207,11 @@ override FPCOPT+=-Cprv32imac CPU_UNITS=fe310g000 fe310g002 gd32vf103xx CPU_UNITS_DEFINED=1 endif +ifeq ($(SUBARCH),rv32i) +override FPCOPT+=-Cprv32i +CPU_UNITS= +CPU_UNITS_DEFINED=1 +endif ifeq ($(CPU_UNITS_DEFINED),) $(error No CPUs enabled for given SUBARCH, pass either a SUBARCH or set CPU_UNITS_DEFINED=1 if you know what you are doing) endif @@ -431,7 +436,7 @@ ctypes$(PPUEXT) : $(INC)/ctypes.pp $(SYSTEMUNIT)$(PPUEXT) fpcylix$(PPUEXT) : fpcylix.pp cthreads$(PPUEXT) cwstring$(PPUEXT) dynlibs$(PPUEXT) objpas$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) $(COMPILER) fpcylix.pp - + intrinsics$(PPUEXT) : $(PROCINC)/intrinsics.pp $(SYSTEMUNIT)$(PPUEXT) $(COMPILER) $(PROCINC)/intrinsics.pp @@ -442,4 +447,4 @@ sortbase$(PPUEXT) : $(INC)/sortbase.pp objpas$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) avrsim$(PPUEXT): $(ARCH)/avrsim.pp heapmgr$(PPUEXT) consoleio$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) $(COMPILER) $(ARCH)/avrsim.pp - + diff --git a/rtl/linux/riscv64/si_c.inc b/rtl/linux/riscv64/si_c.inc index 1dd3de3139..942372e934 100644 --- a/rtl/linux/riscv64/si_c.inc +++ b/rtl/linux/riscv64/si_c.inc @@ -22,8 +22,10 @@ var BSS_START: record end; external name '__bss_start'; STACK_PTR: record end; external name '__stkptr'; - libc_init_proc: TProcedure; weakexternal name '_init'; - libc_fini_proc: TProcedure; weakexternal name '_fini'; + { as we do not call these procedures directly, calling conventions do not matter and + even if we did, we use c calling conventions anyways } + procedure __libc_csu_init; external name '__libc_csu_init'; + procedure __libc_csu_fini; external name '__libc_csu_fini'; procedure libc_start_main(main: TProcedure; argc: ptruint; argv: ppchar; init, fini, rtld_fini: TProcedure; stack_end: pointer); cdecl; external name '__libc_start_main'; procedure libc_exit(code: ptruint); cdecl; external name 'exit'; @@ -41,7 +43,7 @@ procedure _FPC_rv_enter(at_exit: TProcedure; sp: pptruint); operatingsystem_parameter_argv:=argv; operatingsystem_parameter_envp:=@sp[argc+2]; - libc_start_main(@PascalMain, argc, argv, libc_init_proc, libc_fini_proc, at_exit, sp); + libc_start_main(@PascalMain, argc, argv, @__libc_csu_init, @__libc_csu_fini, at_exit, sp); end; @@ -51,7 +53,7 @@ procedure _FPC_proc_start; assembler; nostackframe; public name '_start'; .option push .option norelax .L1: - auipc gp, %pcrel_hi(BSS_START+0x800) + auipc gp, %pcrel_hi(BSS_START+0x7f8) addi gp, gp, %pcrel_lo(.L1) .option pop @@ -79,3 +81,20 @@ procedure _FPC_proc_haltproc(e:longint); cdecl; public name '_haltproc'; _FPC_rv_exit(e); end; end; + + + procedure initgp; assembler; nostackframe; + asm + .Linitgp: + .option push + .option norelax + .L1: + auipc gp, %pcrel_hi(BSS_START+0x7f8) + addi gp, gp, %pcrel_lo(.L1) + .option pop + jalr x0, x1 + + .section ".preinit_array","aw" + .dc.a .Linitgp + .text + end; diff --git a/rtl/objpas/sysutils/fina.inc b/rtl/objpas/sysutils/fina.inc index fbc55e6a52..e817d60e6a 100644 --- a/rtl/objpas/sysutils/fina.inc +++ b/rtl/objpas/sysutils/fina.inc @@ -381,7 +381,7 @@ end; Procedure DoDirSeparators (Var FileName : PathStr); {$ifdef FPC_HAS_CPSTRING}rtlproc;{$endif} -VAr I : longint; +Var I : longint; begin For I:=1 to Length(FileName) do diff --git a/rtl/riscv32/setjump.inc b/rtl/riscv32/setjump.inc index be2a0c181c..4be0dc8055 100644 --- a/rtl/riscv32/setjump.inc +++ b/rtl/riscv32/setjump.inc @@ -16,11 +16,124 @@ function fpc_setjmp(var S : jmp_buf) : longint;assembler;[Public, alias : 'FPC_SETJMP'];nostackframe;compilerproc; asm - end; + sw ra, jmp_buf.ra(a0) + sw s0, jmp_buf.s0(a0) + sw s1, jmp_buf.s1(a0) + sw s2, jmp_buf.s2(a0) + sw s3, jmp_buf.s3(a0) + sw s4, jmp_buf.s4(a0) + sw s5, jmp_buf.s5(a0) + sw s6, jmp_buf.s6(a0) + sw s7, jmp_buf.s7(a0) + sw s8, jmp_buf.s8(a0) + sw s9, jmp_buf.s9(a0) + sw s10, jmp_buf.s10(a0) + sw s11, jmp_buf.s11(a0) + sw sp, jmp_buf.sp(a0) + +{$if defined(FPUFD) or defined(FPUD)} + frcsr t0 + + sw t0, jmp_buf.fcsr(a0) + + fsd f8, jmp_buf.f8(a0) + fsd f9, jmp_buf.f9(a0) + fsd f18, jmp_buf.f18(a0) + fsd f19, jmp_buf.f19(a0) + fsd f20, jmp_buf.f20(a0) + fsd f21, jmp_buf.f21(a0) + fsd f22, jmp_buf.f22(a0) + fsd f23, jmp_buf.f23(a0) + fsd f24, jmp_buf.f24(a0) + fsd f25, jmp_buf.f25(a0) + fsd f26, jmp_buf.f26(a0) + fsd f27, jmp_buf.f27(a0) +{$endif FPUFD or FPUD} +{$if defined(FPUF)} + frcsr t0 + + sw t0, jmp_buf.fcsr(a0) + + fsw f8, jmp_buf.f8(a0) + fsw f9, jmp_buf.f9(a0) + fsw f18, jmp_buf.f18(a0) + fsw f19, jmp_buf.f19(a0) + fsw f20, jmp_buf.f20(a0) + fsw f21, jmp_buf.f21(a0) + fsw f22, jmp_buf.f22(a0) + fsw f23, jmp_buf.f23(a0) + fsw f24, jmp_buf.f24(a0) + fsw f25, jmp_buf.f25(a0) + fsw f26, jmp_buf.f26(a0) + fsw f27, jmp_buf.f27(a0) +{$endif FPUF} + + addi x10, x0, 0 +end; procedure fpc_longjmp(var S : jmp_buf;value : longint);assembler;[Public, alias : 'FPC_LONGJMP'];compilerproc; asm + lw ra, jmp_buf.ra(a0) + lw s0, jmp_buf.s0(a0) + lw s1, jmp_buf.s1(a0) + lw s2, jmp_buf.s2(a0) + lw s3, jmp_buf.s3(a0) + lw s4, jmp_buf.s4(a0) + lw s5, jmp_buf.s5(a0) + lw s6, jmp_buf.s6(a0) + lw s7, jmp_buf.s7(a0) + lw s8, jmp_buf.s8(a0) + lw s9, jmp_buf.s9(a0) + lw s10, jmp_buf.s10(a0) + lw s11, jmp_buf.s11(a0) + +{$if defined(FPUFD) or defined(FPUD)} + lw sp, jmp_buf.fcsr(a0) + + fld f8, jmp_buf.f8(a0) + fld f9, jmp_buf.f9(a0) + fld f18, jmp_buf.f18(a0) + fld f19, jmp_buf.f19(a0) + fld f20, jmp_buf.f20(a0) + fld f21, jmp_buf.f21(a0) + fld f22, jmp_buf.f22(a0) + fld f23, jmp_buf.f23(a0) + fld f24, jmp_buf.f24(a0) + fld f25, jmp_buf.f25(a0) + fld f26, jmp_buf.f26(a0) + fld f27, jmp_buf.f27(a0) + + fscsr sp +{$endif FPUFD or FPUD} +{$if defined(FPUF)} + lw sp, jmp_buf.fcsr(a0) + + flw f8, jmp_buf.f8(a0) + flw f9, jmp_buf.f9(a0) + flw f18, jmp_buf.f18(a0) + flw f19, jmp_buf.f19(a0) + flw f20, jmp_buf.f20(a0) + flw f21, jmp_buf.f21(a0) + flw f22, jmp_buf.f22(a0) + flw f23, jmp_buf.f23(a0) + flw f24, jmp_buf.f24(a0) + flw f25, jmp_buf.f25(a0) + flw f26, jmp_buf.f26(a0) + flw f27, jmp_buf.f27(a0) + + fscsr sp +{$endif FPUF} + lw sp, jmp_buf.sp(a0) + + beq a1, x0, .Lone + jal x0, .Lzero + .Lone: + addi a0, x0, 1 + jal x0, .Lexit + .Lzero: + addi a0, a1, 0 + .Lexit: end; diff --git a/rtl/riscv32/setjumph.inc b/rtl/riscv32/setjumph.inc index f27b3c9cbc..d6bafe0623 100644 --- a/rtl/riscv32/setjumph.inc +++ b/rtl/riscv32/setjumph.inc @@ -15,11 +15,20 @@ **********************************************************************} type - jmp_buf = packed record + jmp_buf = record + ra,s0,s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11,sp: dword; +{$if defined(FPUFD) or defined(FPUD)} + fcsr,dummy : dword; + f8,f9,f18,f19,f20,f21, + f22,f23,f24,f25,f26,f27: qword; +{$endif FPUFD or FPUD} +{$if defined(FPUF)} + fcsr : dword; + f8,f9,f18,f19,f20,f21, + f22,f23,f24,f25,f26,f27: longword; +{$endif FPUF} end; pjmp_buf = ^jmp_buf; function setjmp(var S : jmp_buf) : longint;[external name 'FPC_SETJMP']; procedure longjmp(var S : jmp_buf;value : longint);[external name 'FPC_LONGJMP']; - - diff --git a/tests/test/cg/obj/readme.txt b/tests/test/cg/obj/readme.txt index 125095026f..2fd1e01e55 100644 --- a/tests/test/cg/obj/readme.txt +++ b/tests/test/cg/obj/readme.txt @@ -54,7 +54,7 @@ OS/2 (os2-i386): original EMX port of GCC (GCC 2.8.1) except for tcext6.c which Data retieved from .comment or similar section: beos-i386 : GCC: (GNU) 2.95v.3-beos-060710 android-arm-eabi : GCC: (GNU) 4.7.A* -solaris-sparc : .acomp: WorkShop Compilers 4.2 30 Oct 1996 C 4.2 +solaris-sparc : GCC: (GNU) 5.5.0 linux-arm : GCC: (GNU) 2.95.1 19990816 (release) linux-arm-eabi : GCC: (Debian 4.3.2-1) 4.3.2 linux-powerpc : GCC: (GNU) 2.95.4 20011002 (Debian prerelease) diff --git a/tests/test/cg/obj/solaris/sparc/cpptcl1.o b/tests/test/cg/obj/solaris/sparc/cpptcl1.o Binary files differindex c239f81689..f056e7e496 100644 --- a/tests/test/cg/obj/solaris/sparc/cpptcl1.o +++ b/tests/test/cg/obj/solaris/sparc/cpptcl1.o diff --git a/tests/test/cg/obj/solaris/sparc/cpptcl2.o b/tests/test/cg/obj/solaris/sparc/cpptcl2.o Binary files differindex 7a34688558..1f2d97149c 100644 --- a/tests/test/cg/obj/solaris/sparc/cpptcl2.o +++ b/tests/test/cg/obj/solaris/sparc/cpptcl2.o diff --git a/tests/test/cg/obj/solaris/sparc/ctest.o b/tests/test/cg/obj/solaris/sparc/ctest.o Binary files differindex e4e2b84a4a..f148150c54 100644 --- a/tests/test/cg/obj/solaris/sparc/ctest.o +++ b/tests/test/cg/obj/solaris/sparc/ctest.o diff --git a/tests/test/cg/obj/solaris/sparc/tcext3.o b/tests/test/cg/obj/solaris/sparc/tcext3.o Binary files differindex 2bc99121d6..48c7961a9d 100644 --- a/tests/test/cg/obj/solaris/sparc/tcext3.o +++ b/tests/test/cg/obj/solaris/sparc/tcext3.o diff --git a/tests/test/cg/obj/solaris/sparc/tcext4.o b/tests/test/cg/obj/solaris/sparc/tcext4.o Binary files differindex 52edfded52..9b8e9fe492 100644 --- a/tests/test/cg/obj/solaris/sparc/tcext4.o +++ b/tests/test/cg/obj/solaris/sparc/tcext4.o diff --git a/tests/test/cg/obj/solaris/sparc/tcext5.o b/tests/test/cg/obj/solaris/sparc/tcext5.o Binary files differindex decb06834b..b01502ff48 100644 --- a/tests/test/cg/obj/solaris/sparc/tcext5.o +++ b/tests/test/cg/obj/solaris/sparc/tcext5.o diff --git a/tests/test/cg/obj/solaris/sparc/tcext6.o b/tests/test/cg/obj/solaris/sparc/tcext6.o Binary files differindex f101df3a67..a20f53bf5d 100644 --- a/tests/test/cg/obj/solaris/sparc/tcext6.o +++ b/tests/test/cg/obj/solaris/sparc/tcext6.o diff --git a/tests/test/cg/taddbyte.pp b/tests/test/cg/taddbyte.pp new file mode 100644 index 0000000000..e0876db494 --- /dev/null +++ b/tests/test/cg/taddbyte.pp @@ -0,0 +1,345 @@ +{ Program to test Code generator secondadd() } +{ with Byte values } +{ FUNCTIONAL PRE-REQUISITES: } +{ - assignments function correctly. } +{ - if statements function correctly. } +{ - subroutine calls function correctly. } + +procedure fail; +begin + WriteLn('Failed!'); + halt(1); +end; + + +procedure ByteTestAdd; +var + i: Byte; + j: Byte; + result : boolean; +begin + Write('Byte + Byte test...'); + result := true; + i:=0; + j:=0; + i := i + 100; + if i <> 100 then + result := false; + j := 32; + i := i + j; + if i <> 132 then + result := false; + i := i + j + 50; + if i <> 214 then + result := false; + i:=0; + j:=10; + i:= i + j + j + i + j; + if i <> 30 then + result := false; + if not result then + Fail + else + WriteLn('Success.'); +end; + + +procedure ByteTestSub; +var + i, j, k : Byte; + result : boolean; +begin + Write('Byte - Byte test...'); + result := true; + i:=100; + j:=4; + k:=6; + i:= i - 10; + if i <> 90 then + result := false; + i := i - j - k - 11; + if i <> 69 then + result := false; + i:=10; + j:=100; + k:=10; + i:= j - i - k; + if i <> 80 then + result := false; + if not result then + Fail + else + WriteLn('Success.'); +end; + + +procedure ByteTestMul; +var + i : Byte; + j : Byte; + k: Byte; + result: boolean; +begin + Write('Byte * Byte test...'); + result := true; + i:=0; + j:=0; + i:=i * 32; + if i <> 0 then + result := false; + i:=10; + i:=i * 16; + if i <> 160 then + result := false; + j:=10; + i:=10; + i:=i * j; + if i <> 100 then + result := false; + i:=1; + j:=10; + k:=16; + i := i * j * k; + if i <> 160 then + result := false; + i := 1; + j := 2; + k := 4; + i := i * 2 * j * i * j * 4 * k; + if i <> 128 then + result := false; + i := 50; + j := 5; + i := i * j; + if i <> 250 then + result := false; + if not result then + Fail + else + WriteLn('Success.'); +end; + +procedure ByteTestXor; +var + i, j : Byte; + result : boolean; +begin + Write('Byte XOR Byte test...'); + result := true; + i := 0; + j := 0; + i := i xor $11; + if i <> $11 then + result := false; + i:=0; + j:=$11; + i:=i xor j; + if i <> $11 then + result := false; + + i := 0; + j := $55; + i := i xor j xor $AA; + if i <> $FF then + result := false; + if not result then + Fail + else + WriteLn('Success.'); +end; + + +procedure ByteTestOr; +var + i,j : Byte; + result : boolean; +Begin + Write('Byte OR Byte test...'); + result := true; + i := 0; + j := 0; + i := i or $11; + if i <> $11 then + result := false; + i:=0; + j:=$11; + i:=i or j; + if i <> $11 then + result := false; + + i := 0; + j := $55; + i := i or j or $AA; + if i <> $FF then + result := false; + if not result then + Fail + else + WriteLn('Success.'); +end; + + + +procedure ByteTestAnd; +var + i,j : Byte; + result : boolean; +Begin + Write('Byte AND Byte test...'); + result := true; + i := $11; + j := 0; + i := i and $11; + if i <> $11 then + result := false; + i:=0; + j:=$11; + i:=i and j; + if i <> 0 then + result := false; + + i := $FF; + j := $55; + i := i and j; + if i <> $55 then + result := false; + i := $FF; + i := i and $AA; + if i <> $AA then + result := false; + + i := 0; + j := $55; + i := i and j and $AA; + if i <> 0 then + result := false; + if not result then + Fail + else + WriteLn('Success.'); +end; + +procedure ByteTestEqual; +var + i,j : Byte; + result : boolean; +Begin + Write('Byte = Byte test...'); + result := true; + i := $11; + j := 0; + if i = 0 then + result := false; + if i = j then + result := false; + if j = i then + result := false; + if not result then + Fail + else + WriteLn('Success.'); +end; + + +procedure ByteTestNotEqual; +var + i,j : Byte; + result : boolean; +Begin + Write('Byte <> Byte test...'); + result := true; + i := $11; + j := $11; + if i <> $11 then + result := false; + if i <> j then + result := false; + if j <> i then + result := false; + if not result then + Fail + else + WriteLn('Success.'); +end; + +procedure ByteTestLE; +var + i, j: Byte; + result : boolean; +begin +{$ifndef tp} + Write('Byte <= Byte test...'); + result := true; + i := $FF; + j := $FE; + if i <= j then + result := false; + i := $FE; + j := $F; + if i <= j then + result := false; + i := $FF; + if i <= $FE then + result := false; + j := $FF; + if i <= j then + begin + if result then + WriteLn('Success.') + else + Fail; + end + else + Fail; +{$endif} +end; + + +procedure ByteTestGE; +var + i, j: Byte; + result : boolean; +begin +{$ifndef tp} + Write('Byte >= Byte test...'); + result := true; + i := $FE; + j := $FF; + if i >= j then + result := false; + i := $FE; + j := $FF; + if i > j then + result := false; + i := $FE; + if i > $FE then + result := false; + i := $FF; + j := $FF; + if i >= j then + begin + if result then + WriteLn('Success.') + else + Fail; + end + else + Fail; +{$endif} +end; + + +Begin + { These should be tested first, since if they do not } + { work, they will false all other results. } + ByteTestEqual; + ByteTestNotEqual; + ByteTestAdd; + ByteTestMul; + ByteTestOr; + ByteTestAnd; + ByteTestXor; + ByteTestLe; + ByteTestGe; + ByteTestSub; +end. diff --git a/tests/test/tandorandnot1.pp b/tests/test/tandorandnot1.pp index aff04507ea..2890f9d202 100644 --- a/tests/test/tandorandnot1.pp +++ b/tests/test/tandorandnot1.pp @@ -1,34 +1,122 @@ { test (a and b) or (c and not(b)) into c xor ((c xor a) and b) optimization with random values } -var - i,a,b,c,_a,_b,_c : word; +procedure test_word; + var + i,a,b,c,_a,_b,_c : word; + begin + for i:=1 to 1000 do + begin + a:=random(65536); + _a:=a; + b:=random(65536); + _b:=b; + c:=random(65536); + _c:=c; + if (a and b) or (c and not(b))<>_c xor ((_c xor _a) and _b) then + begin + writeln('Error: ','a=',a,'b=',b,'c=',c); + halt(1); + end; + if (a and b) or (not(b) and c)<>_c xor ((_c xor _a) and _b) then + begin + writeln('Error: ','a=',a,'b=',b,'c=',c); + halt(1); + end; + if (not(b) and c) or (a and b)<>_c xor ((_c xor _a) and _b) then + begin + writeln('Error: ','a=',a,'b=',b,'c=',c); + halt(1); + end; + if (not(b) and c) or (b and a)<>_c xor ((_c xor _a) and _b) then + begin + writeln('Error: ','a=',a,'b=',b,'c=',c); + halt(1); + end; + end; + end; + +procedure test_boolean; + var + i : word; + a,b,c,_a,_b,_c : boolean; + begin + for i:=1 to 100 do + begin + a:=boolean(random(2)); + _a:=a; + b:=boolean(random(2)); + _b:=b; + c:=boolean(random(2)); + _c:=c; + if (a and b) or (c and not(b))<>_c xor ((_c xor _a) and _b) then + begin + writeln('Error: ','a=',a,'b=',b,'c=',c); + halt(11); + end; + if (a and b) or (not(b) and c)<>_c xor ((_c xor _a) and _b) then + begin + writeln('Error: ','a=',a,'b=',b,'c=',c); + halt(11); + end; + if (not(b) and c) or (a and b)<>_c xor ((_c xor _a) and _b) then + begin + writeln('Error: ','a=',a,'b=',b,'c=',c); + halt(11); + end; + if (not(b) and c) or (b and a)<>_c xor ((_c xor _a) and _b) then + begin + writeln('Error: ','a=',a,'b=',b,'c=',c); + halt(11); + end; + end; + end; + + +procedure test_pboolean; + var + i : word; + a,b,c : pboolean; + _a,_b,_c : boolean; + begin + new(a); + new(b); + for i:=1 to 100 do + begin + a^:=true; + _a:=a^; + b^:=true; + _b:=b^; + c:=nil; + { c should not matter in this case } + _c:=boolean(random(2)); + if (a^ and b^) or (c^ and not(b^))<>_c xor ((_c xor _a) and _b) then + begin + writeln('Error: ','a=',a^,'b=',b^,'c=',c^); + halt(21); + end; + if (a^ and b^) or (not(b^) and c^)<>_c xor ((_c xor _a) and _b) then + begin + writeln('Error: ','a=',a^,'b=',b^,'c=',c^); + halt(21); + end; + if (not(b^) and c^) or (a^ and b^)<>_c xor ((_c xor _a) and _b) then + begin + writeln('Error: ','a=',a^,'b=',b^,'c=',c^); + halt(21); + end; + if (not(b^) and c^) or (b^ and a^)<>_c xor ((_c xor _a) and _b) then + begin + writeln('Error: ','a=',a^,'b=',b^,'c=',c^); + halt(21); + end; + end; + dispose(a); + dispose(b); + end; + + begin - for i:=1 to 1000 do - begin - a:=random(65536); - _a:=a; - b:=random(65536); - _b:=b; - c:=random(65536); - _c:=c; - if (a and b) or (c and not(b))<>_c xor ((_c xor _a) and _b) then - begin - writeln('Error: ','a=',a,'b=',b,'c=',c); - halt(1); - end; - if (a and b) or (not(b) and c)<>_c xor ((_c xor _a) and _b) then - begin - writeln('Error: ','a=',a,'b=',b,'c=',c); - halt(1); - end; - if (not(b) and c) or (a and b)<>_c xor ((_c xor _a) and _b) then - begin - writeln('Error: ','a=',a,'b=',b,'c=',c); - halt(1); - end; - if (not(b) and c) or (b and a)<>_c xor ((_c xor _a) and _b) then - begin - writeln('Error: ','a=',a,'b=',b,'c=',c); - halt(1); - end; - end; + test_word; + test_boolean; + test_pboolean; end. + diff --git a/tests/webtbs/tw38549.pp b/tests/webtbs/tw38549.pp new file mode 100644 index 0000000000..7661598702 --- /dev/null +++ b/tests/webtbs/tw38549.pp @@ -0,0 +1,226 @@ +type + +{$ifdef SET_39} + {$define SET_31} +{$endif} +{$ifdef SET_31} + {$define SET_25} +{$endif} +{$ifdef SET_25} + {$define SET_23} +{$endif} +{$ifdef SET_23} + {$define SET_17} +{$endif} +{$ifdef SET_17} + {$define SET_15} +{$endif} +{$ifdef SET_15} + {$define SET_9} +{$endif} + + { options for symtables } + tsymtableoption = ( + sto_has_helper, { contains at least one helper symbol } + sto_has_generic, { contains at least one generic symbol } + sto_has_operator, { contains at least one operator overload } + sto_needs_init_final, { the symtable needs initialization and/or + finalization of variables/constants } + sto_has_non_trivial_init, { contains at least on managed type that is not + initialized to zero (e.g. a record with management + operators } + sto_above +{$ifdef SET_9} + ,sto_6 + ,sto_7 + ,sto_8 + ,sto_9 +{$endif} +{$ifdef SET_15} + ,sto_10 + ,sto_11 + ,sto_12 + ,sto_13 + ,sto_14 + ,sto_15 +{$endif} +{$ifdef SET_17} + ,sto_16 + ,sto_17 +{$endif} +{$ifdef SET_23} + ,sto_18 + ,sto_19 + ,sto_20 + ,sto_21 + ,sto_22 + ,sto_23 +{$endif} +{$ifdef SET_25} + ,sto_24 + ,sto_25 +{$endif} +{$ifdef SET_31} + ,sto_26 + ,sto_27 + ,sto_28 + ,sto_29 + ,sto_30 + ,sto_31 +{$endif} +{$ifdef SET_39} + ,sto_32 + ,sto_33 + ,sto_34 + ,sto_35 + ,sto_36 + ,sto_37 + ,sto_38 + ,sto_39 +{$endif} + ); + tsymtableoptions = set of tsymtableoption; + +const + ok_count : longint = 0; + error_count : longint = 0; + +procedure add_error; +begin + writeln('New error'); + inc(error_count); +end; + +procedure test(tableoptions : tsymtableoptions; expected : boolean); +begin + if [sto_needs_init_final,sto_has_non_trivial_init] <= tableoptions then + begin + if expected then + begin + writeln('Ok'); + inc(ok_count); + end + else + add_error; + end + else + begin + if not expected then + begin + writeln('Ok'); + inc(ok_count); + end + else + add_error; + end; + if tableoptions >= [sto_needs_init_final,sto_has_non_trivial_init] then + begin + if expected then + begin + writeln('Ok'); + inc(ok_count); + end + else + add_error; + end + else + begin + if not expected then + begin + writeln('Ok'); + inc(ok_count); + end + else + add_error; + end +end; + +procedure test2(tableoptions1, tableoptions2 : tsymtableoptions; expected : boolean); +begin + if tableoptions1 <= tableoptions2 then + begin + if expected then + begin + writeln('Ok'); + inc(ok_count); + end + else + add_error; + end + else + begin + if not expected then + begin + writeln('Ok'); + inc(ok_count); + end + else + add_error; + end +end; + +var + tableoptions1, tableoptions2 : tsymtableoptions; + +begin + tableoptions1:=[]; + test(tableoptions1,false); + + tableoptions1:=[sto_has_helper]; + test(tableoptions1,false); + + tableoptions1:=[sto_needs_init_final]; + test(tableoptions1,false); + + tableoptions1:=[sto_has_non_trivial_init]; + test(tableoptions1,false); + + tableoptions1:=[sto_needs_init_final,sto_has_non_trivial_init]; + test(tableoptions1,true); + + tableoptions1:=[sto_has_helper,sto_needs_init_final,sto_has_non_trivial_init]; + test(tableoptions1,true); + + tableoptions1:=[sto_has_helper,sto_needs_init_final,sto_has_non_trivial_init,sto_above]; + test(tableoptions1,true); + + tableoptions1:=[sto_has_helper,sto_has_non_trivial_init,sto_above]; + test(tableoptions1,false); + + tableoptions1:=[]; + tableoptions2:=[]; + test2(tableoptions1,tableoptions2,true); + test2(tableoptions2,tableoptions1,true); + + tableoptions2:=[sto_has_helper]; + test2(tableoptions1,tableoptions2,true); + test2(tableoptions2,tableoptions1,false); + + tableoptions1:=[sto_needs_init_final,sto_has_non_trivial_init]; + tableoptions2:=[sto_needs_init_final,sto_has_non_trivial_init,sto_has_helper]; + test2(tableoptions1,tableoptions2,true); + test2(tableoptions2,tableoptions1,false); + test2(tableoptions1,tableoptions1,true); + test2(tableoptions2,tableoptions2,true); + + tableoptions1:=[sto_needs_init_final,sto_has_non_trivial_init]; + tableoptions2:=[sto_has_helper,sto_needs_init_final,sto_has_non_trivial_init]; + test2(tableoptions1,tableoptions2,true); + test2(tableoptions2,tableoptions1,false); + + tableoptions1:=[sto_has_helper,sto_needs_init_final,sto_has_non_trivial_init]; + tableoptions2:=[sto_needs_init_final,sto_has_non_trivial_init,sto_above]; + test2(tableoptions1,tableoptions2,false); + test2(tableoptions2,tableoptions1,false); + + writeln('Test for sets of size : ',sizeof(tableoptions1)); + if error_count > 0 then + begin + writeln(error_count,' test(s) failed'); + writeln(ok_count,' test(s) OK'); + halt(1); + end + else + writeln('Test OK: ',ok_count); +end. + diff --git a/tests/webtbs/tw38549a.pp b/tests/webtbs/tw38549a.pp new file mode 100644 index 0000000000..c4d8c37137 --- /dev/null +++ b/tests/webtbs/tw38549a.pp @@ -0,0 +1,5 @@ + +{$packset 1} + +{$i tw38549.pp} + diff --git a/tests/webtbs/tw38549b.pp b/tests/webtbs/tw38549b.pp new file mode 100644 index 0000000000..6a08dc5bc4 --- /dev/null +++ b/tests/webtbs/tw38549b.pp @@ -0,0 +1,5 @@ + +{$packset 2} + +{$i tw38549.pp} + diff --git a/tests/webtbs/tw38549c.pp b/tests/webtbs/tw38549c.pp new file mode 100644 index 0000000000..1c387adb10 --- /dev/null +++ b/tests/webtbs/tw38549c.pp @@ -0,0 +1,5 @@ + +{$packset 4} + +{$i tw38549.pp} + diff --git a/tests/webtbs/tw38549d.pp b/tests/webtbs/tw38549d.pp new file mode 100644 index 0000000000..1d81388d66 --- /dev/null +++ b/tests/webtbs/tw38549d.pp @@ -0,0 +1,5 @@ + +{$packset 8} + +{$i tw38549.pp} + |