paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-13 06:29:32 +02:00
Code Issues Packages Projects Releases Wiki Activity

* synchronized with trunk

Browse Source 
git-svn-id: branches/wasm@48906 -
This commit is contained in:
nickysn 2021-03-08 00:52:43 +00:00
commit f8052134e3
60 changed files with 2381 additions and 1895 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
.gitattributes vendored
View File

@ -712,6 +712,7 @@ compiler/riscv/nrvcnv.pas svneol=native#text/plain
compiler/riscv/nrvcon.pas svneol=native#text/plain
compiler/riscv/nrvinl.pas svneol=native#text/plain
compiler/riscv/nrvset.pas svneol=native#text/plain
compiler/riscv/rarv.pas svneol=native#text/pascal
compiler/riscv/rarvgas.pas svneol=native#text/plain
compiler/riscv/rgcpu.pas svneol=native#text/plain
compiler/riscv32/aoptcpu.pas svneol=native#text/plain
@ -731,8 +732,6 @@ compiler/riscv32/nrv32add.pas svneol=native#text/plain
compiler/riscv32/nrv32cal.pas svneol=native#text/plain
compiler/riscv32/nrv32cnv.pas svneol=native#text/plain
compiler/riscv32/nrv32mat.pas svneol=native#text/plain
compiler/riscv32/rarv32.pas svneol=native#text/plain
compiler/riscv32/rarv32gas.pas svneol=native#text/plain
compiler/riscv32/rrv32con.inc svneol=native#text/plain
compiler/riscv32/rrv32dwa.inc svneol=native#text/plain
compiler/riscv32/rrv32nor.inc svneol=native#text/plain
@ -763,8 +762,6 @@ compiler/riscv64/nrv64cal.pas svneol=native#text/plain
compiler/riscv64/nrv64cnv.pas svneol=native#text/plain
compiler/riscv64/nrv64ld.pas svneol=native#text/plain
compiler/riscv64/nrv64mat.pas svneol=native#text/plain
compiler/riscv64/rarv.pas svneol=native#text/plain
compiler/riscv64/rarv64gas.pas svneol=native#text/plain
compiler/riscv64/rrv32con.inc svneol=native#text/plain
compiler/riscv64/rrv32dwa.inc svneol=native#text/plain
compiler/riscv64/rrv32nor.inc svneol=native#text/plain
@ -13923,6 +13920,7 @@ tests/test/cg/obj/wince/arm/tcext4.o -text
tests/test/cg/obj/wince/arm/tcext5.o -text
tests/test/cg/ptest.pp svneol=native#text/plain
tests/test/cg/taddbool.pp svneol=native#text/plain
tests/test/cg/taddbyte.pp svneol=native#text/pascal
tests/test/cg/taddcard.pp svneol=native#text/plain
tests/test/cg/taddcurr.pp svneol=native#text/plain
tests/test/cg/taddint.pp svneol=native#text/plain
@ -18742,6 +18740,11 @@ tests/webtbs/tw38413.pp svneol=native#text/pascal
tests/webtbs/tw38429.pp svneol=native#text/pascal
tests/webtbs/tw38497.pp svneol=native#text/pascal
tests/webtbs/tw38527.pp svneol=native#text/plain
tests/webtbs/tw38549.pp svneol=native#text/plain
tests/webtbs/tw38549a.pp svneol=native#text/plain
tests/webtbs/tw38549b.pp svneol=native#text/plain
tests/webtbs/tw38549c.pp svneol=native#text/plain
tests/webtbs/tw38549d.pp svneol=native#text/plain
tests/webtbs/tw3863.pp svneol=native#text/plain
tests/webtbs/tw3864.pp svneol=native#text/plain
tests/webtbs/tw3865.pp svneol=native#text/plain

4
compiler/Makefile
View File

@ -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

8
compiler/Makefile.fpc
View File

@ -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
#####################################################################

26
compiler/entfile.pas
View File

@ -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;

25
compiler/mips/ncpuadd.pas
View File

@ -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;

1
compiler/nadd.pas
View File

@ -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)

3
compiler/ncginl.pas
View File

@ -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,

88
compiler/options.pas
View File

@ -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;

36
compiler/raatt.pas
View File

@ -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

4
compiler/riscv/agrvgas.pas
View File

@ -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;

45
compiler/riscv/cgrv.pas
View File

@ -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);

55
compiler/riscv/nrvadd.pas
View File

@ -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;

0
compiler/riscv64/rarv.pas → compiler/riscv/rarv.pas
View File

819
compiler/riscv/rarvgas.pas
View File

@ -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.

2
compiler/riscv32/cputarg.pas
View File

@ -55,7 +55,7 @@ implementation
**************************************}
{$ifndef NoRaRVGas}
,rarv32gas
,rarvgas
{$endif NoRaRVGas}
{**************************************

41
compiler/riscv32/rarv32.pas
View File

@ -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.

780
compiler/riscv32/rarv32gas.pas
View File

@ -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.

2
compiler/riscv64/cputarg.pas
View File

@ -55,7 +55,7 @@ implementation
**************************************}
{$ifndef NoRaRVGas}
,rarv64gas
,rarvgas
{$endif NoRaRVGas}
{**************************************

850
compiler/riscv64/rarv64gas.pas
View File

@ -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.

88
compiler/x86/aoptx86.pas
View File

@ -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;

18
compiler/x86/rgx86.pas
View File

@ -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:

2
packages/fcl-db/src/base/sqlscript.pp
View File

@ -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();

23
packages/fcl-passrc/src/pasresolver.pp
View File

@ -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;

26
packages/fcl-passrc/src/pasuseanalyzer.pas
View File

@ -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.ClassType=TPasProperty)
or ((El.Parent is TPasClassType) and TPasClassType(El.Parent).IsExternal) then
exit;
if El.Visibility in [visPrivate,visStrictPrivate] then

7
packages/fcl-passrc/tests/tcresolver.pas
View File

@ -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)+';');

31
packages/fcl-passrc/tests/tcuseanalyzer.pas
View File

@ -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);

2
packages/fcl-web/src/base/httpdefs.pp
View File

@ -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

67
packages/morphunits/src/amigados.pas
View File

@ -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.

6
packages/morphunits/src/asl.pas
View File

@ -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;
{***************************************************************************}

26
packages/morphunits/src/exec.pas
View File

@ -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

1
packages/morphunits/src/intuition.pas
View File

@ -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;

1
packages/morphunits/src/locale.pas
View File

@ -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;

23
packages/morphunits/src/workbench.pas
View File

@ -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;

2
packages/os4units/src/intuition.pas
View File

@ -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;

55
packages/pastojs/src/fppas2js.pp
View File

@ -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;

7
packages/pastojs/tests/tcmodules.pas
View File

@ -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;',

151
packages/rtl-extra/src/linux/unxsockh.inc
View File

@ -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 }

22
packages/rtl-objpas/src/inc/fmtbcd.pp
View File

@ -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_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;

2
packages/rtl-objpas/src/inc/strutils.pp
View File

@ -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;

5
rtl/embedded/Makefile
View File

@ -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

9
rtl/embedded/Makefile.fpc
View File

@ -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

27
rtl/linux/riscv64/si_c.inc
View File

@ -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;

2
rtl/objpas/sysutils/fina.inc
View File

@ -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

115
rtl/riscv32/setjump.inc
View File

@ -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;

15
rtl/riscv32/setjumph.inc
View File

@ -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'];

2
tests/test/cg/obj/readme.txt
View File

@ -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)

BIN
tests/test/cg/obj/solaris/sparc/cpptcl1.o
View File

Binary file not shown.

BIN
tests/test/cg/obj/solaris/sparc/cpptcl2.o
View File

Binary file not shown.

BIN
tests/test/cg/obj/solaris/sparc/ctest.o
View File

Binary file not shown.

BIN
tests/test/cg/obj/solaris/sparc/tcext3.o
View File

Binary file not shown.

BIN
tests/test/cg/obj/solaris/sparc/tcext4.o
View File

Binary file not shown.

BIN
tests/test/cg/obj/solaris/sparc/tcext5.o
View File

Binary file not shown.

BIN
tests/test/cg/obj/solaris/sparc/tcext6.o
View File

Binary file not shown.

345
tests/test/cg/taddbyte.pp Normal file
View File

@ -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.

150
tests/test/tandorandnot1.pp
View File

@ -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.

226
tests/webtbs/tw38549.pp Normal file
View File

@ -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.

5
tests/webtbs/tw38549a.pp Normal file
View File

@ -0,0 +1,5 @@
{$packset 1}
{$i tw38549.pp}

5
tests/webtbs/tw38549b.pp Normal file
View File

@ -0,0 +1,5 @@
{$packset 2}
{$i tw38549.pp}

5
tests/webtbs/tw38549c.pp Normal file
View File

@ -0,0 +1,5 @@
{$packset 4}
{$i tw38549.pp}

5
tests/webtbs/tw38549d.pp Normal file
View File

@ -0,0 +1,5 @@
{$packset 8}
{$i tw38549.pp}