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

* synchronized with trunk

Browse Source 
git-svn-id: branches/unicodekvm@49511 -
This commit is contained in:
nickysn 2021-06-18 10:14:13 +00:00
commit c24e84e463
51 changed files with 1210 additions and 677 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.gitattributes vendored
View File

@ -15078,6 +15078,7 @@ tests/test/tcustomattr6.pp svneol=native#text/pascal
tests/test/tcustomattr7.pp svneol=native#text/pascal
tests/test/tcustomattr8.pp svneol=native#text/pascal
tests/test/tcustomattr9.pp svneol=native#text/pascal
tests/test/tcustomvar1.pp svneol=native#text/pascal
tests/test/tdefault1.pp svneol=native#text/pascal
tests/test/tdefault10.pp svneol=native#text/pascal
tests/test/tdefault11.pp svneol=native#text/pascal
@ -15163,6 +15164,7 @@ tests/test/testv8.pp svneol=native#text/plain
tests/test/testv9.pp svneol=native#text/plain
tests/test/texception1.pp svneol=native#text/plain
tests/test/texception10.pp svneol=native#text/plain
tests/test/texception11.pp svneol=native#text/pascal
tests/test/texception2.pp svneol=native#text/plain
tests/test/texception3.pp svneol=native#text/plain
tests/test/texception4.pp svneol=native#text/plain
@ -16272,6 +16274,7 @@ tests/test/units/crt/tcrt.pp svneol=native#text/plain
tests/test/units/crt/tctrlc.pp svneol=native#text/plain
tests/test/units/dateutil/test_scandatetime_ampm.pas svneol=native#text/plain
tests/test/units/dateutil/testscandatetime.pas svneol=native#text/plain
tests/test/units/dateutil/tiso8601.pp svneol=native#text/plain
tests/test/units/dateutil/tunitdt1.pp svneol=native#text/pascal
tests/test/units/dos/hello.pp svneol=native#text/plain
tests/test/units/dos/tbreak.pp svneol=native#text/plain
@ -17668,7 +17671,6 @@ tests/webtbs/tw17836.pp svneol=native#text/plain
tests/webtbs/tw17838.pp svneol=native#text/pascal
tests/webtbs/tw17846.pp svneol=native#text/plain
tests/webtbs/tw17862.pp svneol=native#text/plain
tests/webtbs/tw17904.pas svneol=native#text/plain
tests/webtbs/tw17904.pp svneol=native#text/plain
tests/webtbs/tw17907/main/main.pas svneol=native#text/plain
tests/webtbs/tw17907/test.bat svneol=native#text/plain

4
Makefile
View File

@ -349,8 +349,8 @@ endif
endif
override PACKAGE_NAME=fpc
override PACKAGE_VERSION=3.3.1
REQUIREDVERSION=3.2.0
REQUIREDVERSION2=3.2.2
REQUIREDVERSION=3.2.2
REQUIREDVERSION2=3.2.0
ifndef inOS2
override FPCDIR:=$(BASEDIR)
export FPCDIR

4
Makefile.fpc
View File

@ -20,8 +20,8 @@ fpcdir=.
rule=help
[prerules]
REQUIREDVERSION=3.2.0
REQUIREDVERSION2=3.2.2
REQUIREDVERSION=3.2.2
REQUIREDVERSION2=3.2.0
# make versions < 3.77 (OS2 version) are buggy

4
compiler/aarch64/cgcpu.pas
View File

@ -842,7 +842,7 @@ implementation
reg:=makeregsize(reg,OS_64);
fromsize:=tosize;
end;
if (ref.alignment<>0) and
if not(target_info.system=system_aarch64_darwin) and (ref.alignment<>0) and
(ref.alignment<tcgsize2size[tosize]) then
begin
a_load_reg_ref_unaligned(list,fromsize,tosize,reg,ref);
@ -891,7 +891,7 @@ implementation
}
if fromsize in [OS_8,OS_16,OS_32] then
reg:=makeregsize(reg,OS_32);
if (ref.alignment<>0) and
if not(target_info.system=system_aarch64_darwin) and (ref.alignment<>0) and
(ref.alignment<tcgsize2size[fromsize]) then
begin
a_load_ref_reg_unaligned(list,fromsize,tosize,ref,reg);

14
compiler/aggas.pas
View File

@ -1323,13 +1323,17 @@ implementation
begin
if (tai_label(hp).labsym.is_used) then
begin
if (tai_label(hp).labsym.bind=AB_PRIVATE_EXTERN) then
begin
writer.AsmWrite(#9'.private_extern ');
writer.AsmWriteln(tai_label(hp).labsym.name);
end;
{$ifdef DEBUG_LABEL}
writer.AsmWrite(asminfo^.comment);
writer.AsmWriteLn('References = ' + tostr(tai_label(hp).labsym.getrefs));
{$endif DEBUG_LABEL}
if tai_label(hp).labsym.bind in [AB_GLOBAL,AB_PRIVATE_EXTERN] then
begin
if (tai_label(hp).labsym.bind=AB_PRIVATE_EXTERN) then
begin
writer.AsmWrite(#9'.private_extern ');
writer.AsmWriteln(tai_label(hp).labsym.name);
end;
{$ifdef arm}
{ do no change arm mode accidently, .globl seems to reset the mode }
if GenerateThumbCode or GenerateThumb2Code then

779
compiler/arm/aoptcpu.pas
View File

File diff suppressed because it is too large Load Diff

8
compiler/arm/cgcpu.pas
View File

@ -3849,6 +3849,10 @@ unit cgcpu;
stackmisalignment: pint;
stack_parameters : Boolean;
begin
{ a routine not returning needs no exit code,
we trust this directive as arm thumb is normally used if small code shall be generated }
if po_noreturn in current_procinfo.procdef.procoptions then
exit;
if not(nostackframe) then
begin
stack_parameters:=current_procinfo.procdef.stack_tainting_parameter(calleeside);
@ -5052,6 +5056,10 @@ unit cgcpu;
LocalSize : longint;
stackmisalignment: pint;
begin
{ a routine not returning needs no exit code,
we trust this directive as arm thumb is normally used if small code shall be generated }
if po_noreturn in current_procinfo.procdef.procoptions then
exit;
if not(nostackframe) then
begin
stackmisalignment:=0;

6
compiler/armgen/aoptarm.pas
View File

@ -1361,10 +1361,10 @@ Implementation
to
and reg3,reg1,x
}
else if ((taicpu(p).oper[2]^.val and $ffffff00)=0) and
MatchInstruction(p, A_AND, [C_None], [PF_None]) and
else if MatchInstruction(p, A_AND, [C_None], [PF_None]) and
GetNextInstructionUsingReg(p,hp1,taicpu(p).oper[0]^.reg) and
MatchInstruction(hp1, [A_UXTB,A_UXTH], [C_None], [PF_None]) and
((((taicpu(p).oper[2]^.val and $ffffff00)=0) and MatchInstruction(hp1, A_UXTB, [C_None], [PF_None])) or
(((taicpu(p).oper[2]^.val and $ffff0000)=0) and MatchInstruction(hp1, A_UXTH, [C_None], [PF_None]))) and
(taicpu(hp1).ops = 2) and
RegEndofLife(taicpu(p).oper[0]^.reg,taicpu(hp1)) and
MatchOperand(taicpu(hp1).oper[1]^, taicpu(p).oper[0]^.reg) and

2
compiler/avr/agavrgas.pas
View File

@ -96,7 +96,7 @@ unit agavrgas;
internalerror(2011021707)
else if base<>NR_NO then
begin
if addressmode=AM_PREDRECEMENT then
if addressmode=AM_PREDECREMENT then
s:='-';
case base of

102
compiler/avr/cgcpu.pas
View File

@ -120,6 +120,7 @@ unit cgcpu;
procedure a_op_reg_reg_internal(list: TAsmList; Op: TOpCG; size: TCGSize; src, srchi, dst, dsthi: TRegister);
procedure a_op_const_reg_internal(list : TAsmList; Op: TOpCG; size: TCGSize; a: tcgint; reg, reghi: TRegister);
procedure maybegetcpuregister(list : tasmlist; reg : tregister);
function addr_is_io_register(const addr: integer): boolean;
end;
tcg64favr = class(tcg64f32)
@ -1084,6 +1085,14 @@ unit cgcpu;
getcpuregister(list,reg);
end;
{ Returns true if dataspace address falls in I/O register range }
function tcgavr.addr_is_io_register(const addr: integer): boolean;
begin
result := (not(current_settings.cputype in [cpu_avrxmega3,cpu_avrtiny]) and (addr>31)) or
((current_settings.cputype in [cpu_avrxmega3,cpu_avrtiny]) and (addr>=0)) and
(addr<cpuinfo.embedded_controllers[current_settings.controllertype].srambase);
end;
function tcgavr.normalize_ref(list:TAsmList;ref: treference;tmpreg : tregister) : treference;
var
@ -1365,15 +1374,13 @@ unit cgcpu;
end;
if not conv_done then
begin
// CC
// Write to 16 bit ioreg, first high byte then low byte
// sequence required for 16 bit timer registers
// See e.g. atmega328p manual para 15.3 Accessing 16 bit registers
// Avrxmega3: write low byte first then high byte
// See e.g. megaAVR-0 family data sheet 7.5.6 Accessing 16-bit registers
{ Write to 16 bit ioreg, first high byte then low byte
sequence required for 16 bit timer registers
See e.g. atmega328p manual para 15.3 Accessing 16 bit registers
Avrxmega3: write low byte first then high byte
See e.g. megaAVR-0 family data sheet 7.5.6 Accessing 16-bit registers }
if (current_settings.cputype <> cpu_avrxmega3) and
(fromsize in [OS_16, OS_S16]) and QuickRef and (href.offset > 31) and
(href.offset < cpuinfo.embedded_controllers[current_settings.controllertype].srambase) then
(fromsize in [OS_16, OS_S16]) and QuickRef and addr_is_io_register(href.offset) then
begin
tmpreg:=GetNextReg(reg);
href.addressmode:=AM_UNCHANGED;
@ -2600,24 +2607,21 @@ unit cgcpu;
dstref:=dest;
end;
// CC
// If dest is an ioreg (31 < offset < srambase) and size = 16 bit then
// write high byte first, then low byte
// but not for avrxmega3
if (len = 2) and DestQuickRef and (current_settings.cputype <> cpu_avrxmega3) and
(dest.offset > 31) and
(dest.offset < cpuinfo.embedded_controllers[current_settings.controllertype].srambase) then
begin
// If src is also a 16 bit ioreg then read low byte then high byte
if SrcQuickRef and (srcref.offset > 31)
and (srcref.offset < cpuinfo.embedded_controllers[current_settings.controllertype].srambase) then
begin
// First read source into temp registers
tmpreg:=getintregister(list, OS_16);
list.concat(taicpu.op_reg_ref(GetLoad(srcref),tmpreg,srcref));
inc(srcref.offset);
tmpreg2:=GetNextReg(tmpreg);
list.concat(taicpu.op_reg_ref(GetLoad(srcref),tmpreg2,srcref));
{ If dest is an ioreg and size = 16 bit then
write high byte first, then low byte
but not for avrxmega3 }
if (len = 2) and DestQuickRef and (current_settings.cputype <> cpu_avrxmega3) and
addr_is_io_register(dest.offset) then
begin
// If src is also a 16 bit ioreg then read low byte then high byte
if SrcQuickRef and addr_is_io_register(srcref.offset) then
begin
// First read source into temp registers
tmpreg:=getintregister(list, OS_16);
list.concat(taicpu.op_reg_ref(GetLoad(srcref),tmpreg,srcref));
inc(srcref.offset);
tmpreg2:=GetNextReg(tmpreg);
list.concat(taicpu.op_reg_ref(GetLoad(srcref),tmpreg2,srcref));
// then move temp registers to dest in reverse order
inc(dstref.offset);
@ -2627,8 +2631,20 @@ unit cgcpu;
end
else
begin
srcref.addressmode:=AM_UNCHANGED;
inc(srcref.offset);
{ avrtiny doesn't have LDD instruction, so use
predecrement version of LD with pre-incremented pointer }
if current_settings.cputype = cpu_avrtiny then
begin
srcref.addressmode:=AM_PREDECREMENT;
list.concat(taicpu.op_reg_const(A_SUBI,srcref.base,-2));
list.concat(taicpu.op_reg_const(A_SBCI,GetNextReg(srcref.base),$FF));
end
else
begin
srcref.addressmode:=AM_UNCHANGED;
inc(srcref.offset);
end;
dstref.addressmode:=AM_UNCHANGED;
inc(dstref.offset);
@ -2637,12 +2653,15 @@ unit cgcpu;
list.concat(taicpu.op_ref_reg(GetStore(dstref),dstref,GetDefaultTmpReg));
cg.ungetcpuregister(list,GetDefaultTmpReg);
if not(SrcQuickRef) then
if not(SrcQuickRef) and (current_settings.cputype <> cpu_avrtiny) then
srcref.addressmode:=AM_POSTINCREMENT
else if current_settings.cputype = cpu_avrtiny then
srcref.addressmode:=AM_PREDECREMENT
else
srcref.addressmode:=AM_UNCHANGED;
dec(srcref.offset);
if current_settings.cputype <> cpu_avrtiny then
dec(srcref.offset);
dec(dstref.offset);
cg.getcpuregister(list,GetDefaultTmpReg);
@ -2674,17 +2693,18 @@ unit cgcpu;
if DestQuickRef then
inc(dstref.offset);
end;
if not(SrcQuickRef) then
begin
ungetcpuregister(list,srcref.base);
ungetcpuregister(list,TRegister(ord(srcref.base)+1));
end;
if not(DestQuickRef) then
begin
ungetcpuregister(list,dstref.base);
ungetcpuregister(list,TRegister(ord(dstref.base)+1));
end;
end;
if not(SrcQuickRef) then
begin
ungetcpuregister(list,srcref.base);
ungetcpuregister(list,TRegister(ord(srcref.base)+1));
end;
if not(DestQuickRef) then
begin
ungetcpuregister(list,dstref.base);
ungetcpuregister(list,TRegister(ord(dstref.base)+1));
end;
end;
end;

2
compiler/avr/cpubase.pas
View File

@ -160,7 +160,7 @@ unit cpubase;
Operands
*****************************************************************************}
taddressmode = (AM_UNCHANGED,AM_POSTINCREMENT,AM_PREDRECEMENT);
taddressmode = (AM_UNCHANGED,AM_POSTINCREMENT,AM_PREDECREMENT);
{*****************************************************************************
Constants

6
compiler/avr/raavr.pas
View File

@ -164,13 +164,13 @@ unit raavr;
// Perhaps handle separately with a check on sub-architecture? Range check only important if smaller instruction code selected on larger arch
(numOperands: (1 shl 2); Operands: ((typ: top_reg; rt: rt_all), (typ: top_const; max: 65535; min: 0))),
// A_LD
(numOperands: (1 shl 2); Operands: ((typ: top_reg; rt: rt_all), (typ: top_reg; rt: rt_XYZ; am: [AM_UNCHANGED, AM_POSTINCREMENT, AM_PREDRECEMENT]))),
(numOperands: (1 shl 2); Operands: ((typ: top_reg; rt: rt_all), (typ: top_reg; rt: rt_XYZ; am: [AM_UNCHANGED, AM_POSTINCREMENT, AM_PREDECREMENT]))),
// A_LDD
(numOperands: (1 shl 2); Operands: ((typ: top_reg; rt: rt_all), (typ: top_reg; rt: rt_YZ; am: [AM_UNCHANGED]; minconst: 0; maxconst: 63))),
// A_STS TODO: See LDS above
(numOperands: (1 shl 2); Operands: ((typ: top_const; max: 65535; min: 0), (typ: top_reg; rt: rt_all))),
// A_ST
(numOperands: (1 shl 2); Operands: ((typ: top_reg; rt: rt_XYZ; am: [AM_UNCHANGED, AM_POSTINCREMENT, AM_PREDRECEMENT]), (typ: top_reg; rt: rt_all))),
(numOperands: (1 shl 2); Operands: ((typ: top_reg; rt: rt_XYZ; am: [AM_UNCHANGED, AM_POSTINCREMENT, AM_PREDECREMENT]), (typ: top_reg; rt: rt_all))),
// A_STD
(numOperands: (1 shl 2); Operands: ((typ: top_reg; rt: rt_YZ; am: [AM_UNCHANGED]; minconst: 0; maxconst: 63), (typ: top_reg; rt: rt_all))),
// A_LPM
@ -348,7 +348,7 @@ unit raavr;
if not (err) and not(AM_UNCHANGED in AVRInstrConstraint[opcode].Operands[i].am) and
((AM_POSTINCREMENT in AVRInstrConstraint[opcode].Operands[i].am) or
(AM_PREDRECEMENT in AVRInstrConstraint[opcode].Operands[i].am)) then
(AM_PREDECREMENT in AVRInstrConstraint[opcode].Operands[i].am)) then
err := not opregasref;
if not(err) and opregasref then

2
compiler/avr/raavrgas.pas
View File

@ -349,7 +349,7 @@ Unit raavrgas;
begin
{ Special handling of predecrement addressing }
oper.InitRef;
oper.opr.ref.addressmode:=AM_PREDRECEMENT;
oper.opr.ref.addressmode:=AM_PREDECREMENT;
consume(AS_MINUS);

5
compiler/llvm/agllvm.pas
View File

@ -1601,6 +1601,11 @@ implementation
if fputypestrllvm[current_settings.fputype]<>'' then
optstr:=optstr+' -m'+fputypestrllvm[current_settings.fputype];
{ restrict march to aarch64 for now to fix x86_64 compilation failure }
if (cputypestr[current_settings.cputype]<>'')
and (target_info.system in [system_aarch64_darwin, system_aarch64_linux]) then
optstr:=optstr+' -march='+cputypestr[current_settings.cputype];
replace(result,'$OPT',optstr);
inc(fnextpass);
end;

13
compiler/ncal.pas
View File

@ -511,7 +511,7 @@ implementation
{ build up parameters and description }
para:=tcallparanode(parametersnode);
paramssize:=0;
names := #0;
names := '';
while assigned(para) do
begin
{ Skipped parameters are actually (varType=varError, vError=DISP_E_PARAMNOTFOUND).
@ -575,12 +575,11 @@ implementation
if variantdispatch then
begin
{ length-1, because the following names variable *always* starts
with #0 which will be the terminator for methodname }
tcb.emit_pchar_const(pchar(methodname),length(methodname)-1,true);
{ length-1 because we added a null terminator to the string itself
already }
tcb.emit_pchar_const(pchar(names),length(names)-1,true);
tcb.emit_pchar_const(pchar(methodname),length(methodname),true);
if names<>'' then
{ length-1 because we added a null terminator to the string itself
already }
tcb.emit_pchar_const(pchar(names),length(names)-1,true);
end;
{ may be referred from other units in case of inlining -> global

16
compiler/options.pas
View File

@ -4954,9 +4954,21 @@ begin
{ Default alignment settings,
1. load the defaults for the target
2. override with generic optimizer setting (little size)
3. override with the user specified -Oa }
2. adapt defaults specifically for the target
3. override with generic optimizer setting (little size)
4. override with the user specified -Oa }
UpdateAlignment(init_settings.alignment,target_info.alignment);
{$ifdef arm}
if (init_settings.instructionset=is_thumb) and not(CPUARM_HAS_THUMB2 in cpu_capabilities[init_settings.cputype]) then
begin
init_settings.alignment.procalign:=2;
init_settings.alignment.jumpalign:=2;
init_settings.alignment.coalescealign:=2;
init_settings.alignment.loopalign:=2;
end;
{$endif arm}
if (cs_opt_size in init_settings.optimizerswitches) then
begin
init_settings.alignment.procalign:=1;

4
compiler/optutils.pas
View File

@ -307,7 +307,9 @@ unit optutils;
begin
{ not sure if this is enough (FK) }
result:=p;
if not(cnf_call_never_returns in tcallnode(p).callnodeflags) then
if cnf_call_never_returns in tcallnode(p).callnodeflags then
p.successor:=nil
else
p.successor:=succ;
end;
inlinen:

2
compiler/pexpr.pas
View File

@ -2989,7 +2989,7 @@ implementation
(token=_ASSIGNMENT) then
begin
found_arg_name:=true;
p1:=cstringconstnode.createstr(storedpattern);
p1:=cstringconstnode.createstr(orgstoredpattern);
consume(_ASSIGNMENT);
exit;
end;

2
compiler/ppu.pas
View File

@ -277,7 +277,7 @@ end;
function tppufile.readheader: longint;
begin
if fsize<sizeof(tppuheader) then
exit(0);
exit(-1);
result:=f.Read(header,sizeof(tppuheader));
{ The header is always stored in little endian order }
{ therefore swap if on a big endian machine }

2
compiler/riscv/aoptcpurv.pas
View File

@ -249,7 +249,7 @@ implementation
MatchInstruction(hp1,[A_ADDI{$ifdef riscv64},A_ADDIW{$endif}]) and
(taicpu(hp1).ops=3) and
MatchOperand(taicpu(p).oper[0]^,taicpu(hp1).oper[1]^) and
(taicpu(p).oper[2]^.typ=top_const) and
(taicpu(hp1).oper[2]^.typ=top_const) and
is_imm12(taicpu(p).oper[2]^.val+taicpu(hp1).oper[2]^.val) and
(not RegModifiedBetween(taicpu(p).oper[1]^.reg, p,hp1)) and
RegEndOfLife(taicpu(p).oper[0]^.reg, taicpu(hp1)) then

2
compiler/riscv32/cpubase.pas
View File

@ -379,7 +379,7 @@ implementation
begin
is_calljmp:=false;
case o of
A_JAL,A_JALR,A_Bxx:
A_JAL,A_JALR,A_Bxx,A_CALL:
is_calljmp:=true;
else
;

2
compiler/riscv64/cpubase.pas
View File

@ -390,7 +390,7 @@ implementation
begin
is_calljmp:=false;
case o of
A_JAL,A_JALR,A_Bxx:
A_JAL,A_JALR,A_Bxx,A_CALL:
is_calljmp:=true;
else
;

14
compiler/systems/t_android.pas
View File

@ -436,14 +436,16 @@ begin
if IsSharedLib then
Replace(cmdstr,'$SONAME',ExtractFileName(outname));
binstr:=FindUtil(utilsprefix+BinStr);
{ We should use BFD version of LD, since GOLD version does not support INSERT command in linker scripts }
if binstr <> '' then begin
{ Checking if ld.bfd exists }
s:=ChangeFileExt(binstr, '.bfd' + source_info.exeext);
s:=utilsprefix+binstr+'.bfd';
if (source_info.exeext<>'') then
s:=s+source_info.exeext;
s:=FindUtil(s);
if FileExists(s, True) then
binstr:=s;
end;
binstr:=s
else
// fallback to ld for very old or custom binutils
binstr:=FindUtil(utilsprefix+BinStr);
success:=DoExec(binstr,CmdStr,true,false);

3
packages/fcl-db/src/dbase/dbf_fields.pas
View File

@ -617,7 +617,8 @@ begin
// Note: this field can be stored as BCD or integer, depending on FPrecision;
// that's why we allow 0 precision
if FSize < 1 then FSize := 1;
if FSize >= 20 then FSize := 20;
// Removed, bug report 39009
// if FSize >= 20 then FSize := 20;
if FPrecision > FSize-2 then FPrecision := FSize-2; //Leave space for . and -
if FPrecision < 0 then FPrecision := 0;
end;

18
packages/fcl-db/src/sqldb/odbc/odbcconn.pas
View File

@ -986,10 +986,24 @@ begin
// NOTE: I made some guesses here after I found only limited information about TFieldType; please report any problems
case DataType of
SQL_CHAR: begin FieldType:=ftFixedChar; FieldSize:=ColumnSize; end;
SQL_VARCHAR: begin FieldType:=ftString; FieldSize:=ColumnSize; end;
SQL_VARCHAR:
begin
FieldSize:=ColumnSize;
if FieldSize=BLOB_BUF_SIZE then // SQL_VARCHAR declared as NVARCHAR(MAX) must be ftMemo - variable data size
FieldType:=ftMemo
else
FieldType:=ftString;
end;
SQL_LONGVARCHAR: begin FieldType:=ftMemo; FieldSize:=BLOB_BUF_SIZE; end; // is a blob
SQL_WCHAR: begin FieldType:=ftFixedWideChar; FieldSize:=ColumnSize; end;
SQL_WVARCHAR: begin FieldType:=ftWideString; FieldSize:=ColumnSize; end;
SQL_WVARCHAR:
begin
FieldSize:=ColumnSize;
if FieldSize=BLOB_BUF_SIZE then // SQL_WVARCHAR declared as NVARCHAR(MAX) must be ftWideMemo - variable data size
FieldType:=ftWideMemo
else
FieldType:=ftWideString;
end;
SQL_SS_XML,
SQL_WLONGVARCHAR: begin FieldType:=ftWideMemo; FieldSize:=BLOB_BUF_SIZE; end; // is a blob
SQL_DECIMAL: begin FieldType:=ftFloat; FieldSize:=0; end;

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

@ -1809,6 +1809,8 @@ type
procedure OnRangeCheckEl(Sender: TResExprEvaluator; El: TPasElement;
var MsgType: TMessageType); virtual;
function EvalBaseTypeCast(Params: TParamsExpr; bt: TResolverBaseType): TResEvalvalue;
function EvalLengthOfString(ParamResolved: TPasResolverResult;
Param: TPasExpr; Flags: TResEvalFlags): TResEvalValue; virtual;
protected
// generic/specialize
type
@ -14917,6 +14919,7 @@ begin
'0'..'9': i:=i*base+ord(Value[p])-ord('0');
'A'..'Z': i:=i*base+ord(Value[p])-ord('A')+10;
'a'..'z': i:=i*base+ord(Value[p])-ord('a')+10;
else break;
end;
inc(p);
end;
@ -15998,6 +16001,28 @@ begin
end;
end;
function TPasResolver.EvalLengthOfString(ParamResolved: TPasResolverResult;
Param: TPasExpr; Flags: TResEvalFlags): TResEvalValue;
var
Value: TResEvalValue;
begin
Result:=nil;
if rrfReadable in ParamResolved.Flags then
begin
Value:=Eval(Param,Flags);
if Value=nil then exit;
case Value.Kind of
{$ifdef FPC_HAS_CPSTRING}
revkString:
Result:=TResEvalInt.CreateValue(length(TResEvalString(Value).S));
{$endif}
revkUnicodeString:
Result:=TResEvalInt.CreateValue(length(TResEvalUTF16(Value).S));
end;
ReleaseEvalValue(Value);
end
end;
procedure TPasResolver.AddGenericTemplateIdentifiers(
GenericTemplateTypes: TFPList; Scope: TPasIdentifierScope);
var
@ -18776,7 +18801,6 @@ procedure TPasResolver.BI_Length_OnEval(Proc: TResElDataBuiltInProc;
var
Param, Expr: TPasExpr;
ParamResolved: TPasResolverResult;
Value: TResEvalValue;
Ranges: TPasExprArray;
IdentEl: TPasElement;
begin
@ -18785,22 +18809,7 @@ begin
Param:=Params.Params[0];
ComputeElement(Param,ParamResolved,[]);
if ParamResolved.BaseType in btAllStringAndChars then
begin
if rrfReadable in ParamResolved.Flags then
begin
Value:=Eval(Param,Flags);
if Value=nil then exit;
case Value.Kind of
{$ifdef FPC_HAS_CPSTRING}
revkString:
Evaluated:=TResEvalInt.CreateValue(length(TResEvalString(Value).S));
{$endif}
revkUnicodeString:
Evaluated:=TResEvalInt.CreateValue(length(TResEvalUTF16(Value).S));
end;
ReleaseEvalValue(Value);
end
end
Evaluated:=EvalLengthOfString(ParamResolved,Param,Flags)
else if ParamResolved.BaseType=btContext then
begin
if (ParamResolved.LoTypeEl.ClassType=TPasArrayType) then
@ -19366,6 +19375,7 @@ var
Param: TPasExpr;
ParamResolved: TPasResolverResult;
C: TClass;
bt: TResolverBaseType;
begin
if not CheckBuiltInMinParamCount(Proc,Expr,1,RaiseOnError) then
exit(cIncompatible);
@ -19375,12 +19385,15 @@ begin
Param:=Params.Params[0];
ComputeElement(Param,ParamResolved,[]);
Result:=cIncompatible;
if ParamResolved.BaseType in btAllRanges then
bt:=ParamResolved.BaseType;
if bt in btAllRanges then
// e.g. high(char)
Result:=cExact
else if ParamResolved.BaseType=btSet then
else if bt=btSet then
Result:=cExact
else if (ParamResolved.BaseType=btContext) then
else if bt in btAllStrings then
Result:=cExact
else if (bt=btContext) then
begin
C:=ParamResolved.LoTypeEl.ClassType;
if (C=TPasArrayType)
@ -19436,6 +19449,12 @@ begin
ResolvedEl.BaseType:=ResolvedEl.SubType;
ResolvedEl.SubType:=btNone;
end
else if ResolvedEl.BaseType in btAllStrings then
begin
// high(aString)
SetResolverIdentifier(ResolvedEl,BaseTypeLength,Proc.Proc,
FBaseTypes[BaseTypeLength],FBaseTypes[BaseTypeLength],[rrfReadable]);
end
else
;// ordinal: result type is argument type
ResolvedEl.Flags:=ResolvedEl.Flags-[rrfWritable]+[rrfReadable];
@ -19615,6 +19634,13 @@ begin
else
Evaluated:=TResEvalUTF16.CreateValue(#$ffff);
end
else if bt in btAllStrings then
begin
if Proc.BuiltIn=bfLow then
Evaluated:=TResEvalInt.CreateValue(1)
else
Evaluated:=EvalLengthOfString(ParamResolved,Param,Flags);
end
else
begin
{$IFDEF VerbosePasResolver}
@ -19628,6 +19654,13 @@ begin
// e.g. type t = 2..10;
Evaluated:=EvalRangeLimit(TPasRangeType(TypeEl).RangeExpr,FLags,Proc.BuiltIn=bfLow,Param);
end
else if ParamResolved.BaseType in btAllStrings then
begin
if Proc.BuiltIn=bfLow then
Evaluated:=TResEvalInt.CreateValue(1)
else
Evaluated:=EvalLengthOfString(ParamResolved,Param,Flags);
end
else
begin
{$IFDEF VerbosePasResolver}

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

@ -4957,14 +4957,21 @@ end;
procedure TTestResolver.TestHighLow;
begin
StartProgram(false);
Add('var');
Add(' bo: boolean;');
Add(' by: byte;');
Add(' ch: char;');
Add('begin');
Add(' for bo:=low(boolean) to high(boolean) do;');
Add(' for by:=low(byte) to high(byte) do;');
Add(' for ch:=low(char) to high(char) do;');
Add([
'const',
' abc = ''abc'';',
'var',
' bo: boolean;',
' by: byte;',
' ch: char;',
' s: string;',
' i: longint = high(abc);',
'begin',
' for bo:=low(boolean) to high(boolean) do;',
' for by:=low(byte) to high(byte) do;',
' for ch:=low(char) to high(char) do;',
' for i:=low(s) to high(s) do;',
'']);
ParseProgram;
end;

3
packages/ide/Makefile
View File

@ -3409,6 +3409,9 @@ endif
ifdef LLVM
FPMAKE_OPT+=--LLVM=1
endif
ifdef NOLLVM
FPMAKE_OPT+=--NOLLVM=1
endif
.NOTPARALLEL:
PPC_TARGETS=i386 m68k powerpc sparc arm x86_64 powerpc64 mips mipsel avr jvm i8086 aarch64 sparc64
CLEAN_TARGETS=$(addsuffix _clean,$(sort $(PPC_TARGETS)))

4
packages/ide/Makefile.fpc
View File

@ -94,6 +94,10 @@ ifdef LLVM
FPMAKE_OPT+=--LLVM=1
endif
ifdef NOLLVM
FPMAKE_OPT+=--NOLLVM=1
endif
.NOTPARALLEL:
PPC_TARGETS=i386 m68k powerpc sparc arm x86_64 powerpc64 mips mipsel avr jvm i8086 aarch64 sparc64

21
packages/ide/fpmake.pp
View File

@ -11,6 +11,7 @@ const
NoGDBOption: boolean = false;
GDBMIOption: boolean = false;
GDBMI_Disabled: boolean = false;
LLVM_Disabled: boolean = false;
GDBMI_DEFAULT_OSes = [aix, darwin, freebsd, haiku,linux, netbsd, openbsd, solaris, win32, win64];
procedure ide_check_gdb_availability(Sender: TObject);
@ -149,6 +150,7 @@ begin
AddCustomFpmakeCommandlineOption('NoIDE','If value=1 or ''Y'', the IDE will be skipped');
AddCustomFpmakeCommandlineOption('IDE','If value=1 or ''Y'', the IDE will be build for each target');
AddCustomFpmakeCommandlineOption('LLVM','If value=1 or ''Y'', the Compiler codegenerator will use LLVM');
AddCustomFpmakeCommandlineOption('NoLLVM','If value=1 or ''Y'', ito explicitly disable use of LLVM');
end;
procedure add_ide(const ADirectory: string);
@ -187,11 +189,24 @@ begin
CompilerTarget:=StringToCPU(s)
else
CompilerTarget:=Defaults.CPU;
s:=GetCustomFpmakeCommandlineOptionValue('LLVM');
{$ifdef CPULLVM}
llvm:=true;
{$else}
llvm:=false;
{$endif}
s := GetCustomFpmakeCommandlineOptionValue('NOLLVM');
if (s='1') or (s='Y') then
llvm:=true
LLVM_Disabled := true;
if LLVM_Disabled then
llvm:=false
else
llvm:=false;
begin
s:=GetCustomFpmakeCommandlineOptionValue('LLVM');
if (s='1') or (s='Y') then
llvm:=true
else
llvm:=false;
end;
{ Only try to build natively }
{ or for cross-compile if the resulting executable
does not depend on C libs }

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

@ -2025,10 +2025,12 @@ type
Function CreateCallCharCodeAt(Arg: TJSElement; aNumber: integer; El: TPasElement): TJSCallExpression; virtual;
Function CreateCallFromCharCode(Arg: TJSElement; El: TPasElement): TJSCallExpression; virtual;
Function CreateUsesList(UsesSection: TPasSection; AContext : TConvertContext): TJSArrayLiteral;
// js statement list
Procedure AddToStatementList(var First, Last: TJSStatementList;
Add: TJSElement; Src: TPasElement); overload;
Procedure AddToStatementList(St: TJSStatementList; Add: TJSElement; Src: TPasElement); overload;
Procedure PrependToStatementList(var St: TJSElement; Add: TJSElement; PosEl: TPasElement);
// js var
Procedure AddToVarStatement(VarStat: TJSVariableStatement; Add: TJSElement;
Src: TPasElement);
Function CreateValInit(PasType: TPasType; Expr: TPasExpr; El: TPasElement;
@ -2037,6 +2039,15 @@ type
Function CreateVarStatement(const aName: String; Init: TJSElement;
El: TPasElement): TJSVariableStatement; virtual;
Function CreateVarDecl(const aName: String; Init: TJSElement; El: TPasElement): TJSVarDeclaration; virtual;
// misc
Function CreateExternalBracketAccessorCall(El: TParamsExpr; AContext: TConvertContext): TJSElement; virtual;
Function CreateAssignStatement(LeftEl: TPasExpr; AssignContext: TAssignContext): TJSElement; virtual;
Function CreateGetEnumeratorLoop(El: TPasImplForLoop;
AContext: TConvertContext): TJSElement; virtual;
Function CreateCallRTLFreeLoc(Setter, Getter: TJSElement; Src: TPasElement): TJSElement; virtual;
Function CreateDotSplit(El: TPasElement; Expr: TJSElement): TJSElement; virtual;
Function CreatePrecompiledJS(El: TJSElement): string; virtual;
Procedure AddRTLVersionCheck(FuncContext: TFunctionContext; PosEl: TPasElement);
// JS literals
Function CreateLiteralNumber(El: TPasElement; const n: TJSNumber): TJSLiteral; virtual;
Function CreateLiteralFloat(El: TPasElement; const n: TJSNumber): TJSElement; virtual;
@ -2126,25 +2137,18 @@ type
Procedure AddClassConstructors(FuncContext: TFunctionContext; PosEl: TPasElement); virtual;
Procedure AddClassMessageIds(El: TPasClassType; Src: TJSSourceElements;
FuncContext: TFunctionContext; pbivn: TPas2JSBuiltInName); virtual;
// misc
// callbacks
Function CreateCallback(Expr: TPasExpr; ResolvedEl: TPasResolverResult;
aSafeCall: boolean; AContext: TConvertContext): TJSElement; virtual;
Function CreateSafeCallback(Expr: TPasExpr; JS: TJSElement; AContext: TConvertContext): TJSElement; virtual;
Function CreateExternalBracketAccessorCall(El: TParamsExpr; AContext: TConvertContext): TJSElement; virtual;
Function CreateAssignStatement(LeftEl: TPasExpr; AssignContext: TAssignContext): TJSElement; virtual;
Function CreateGetEnumeratorLoop(El: TPasImplForLoop;
AContext: TConvertContext): TJSElement; virtual;
Function CreateCallRTLFreeLoc(Setter, Getter: TJSElement; Src: TPasElement): TJSElement; virtual;
// property
Function CreatePropertyGet(Prop: TPasProperty; Expr: TPasExpr;
AContext: TConvertContext; PosEl: TPasElement): TJSElement; virtual;
Function AppendPropertyAssignArgs(Call: TJSCallExpression; Prop: TPasProperty;
AssignContext: TAssignContext; PosEl: TPasElement): TJSCallExpression; virtual;
Function AppendPropertyReadArgs(Call: TJSCallExpression; Prop: TPasProperty;
aContext: TConvertContext; PosEl: TPasElement): TJSCallExpression; virtual;
Function CreateDotSplit(El: TPasElement; Expr: TJSElement): TJSElement; virtual;
Function CreatePrecompiledJS(El: TJSElement): string; virtual;
Function CreateRaisePropReadOnly(PosEl: TPasElement): TJSElement; virtual;
Procedure AddRTLVersionCheck(FuncContext: TFunctionContext; PosEl: TPasElement);
// create elements for RTTI
Function CreateTypeInfoRef(El: TPasType; AContext: TConvertContext;
ErrorEl: TPasElement): TJSElement; virtual;
@ -13739,6 +13743,20 @@ begin
exit;
end;
end;
btString:
begin
writeln('AAA1 TPasToJSConverter.ConvertBuiltIn_LowHigh ',IsLow);
if isLow then
// low(aString) -> 1
Result:=CreateLiteralNumber(El,1)
else
begin
// high(aString) -> aString.length
Result:=ConvertExpression(Param,AContext);
Result:=CreateDotNameExpr(El,Result,'length');
end;
exit;
end;
end;
DoError(20170210110717,nXExpectedButYFound,sXExpectedButYFound,['enum or array',
AContext.Resolver.GetResolverResultDescription(ResolvedEl)],Param);
@ -19742,6 +19760,7 @@ end;
function TPasToJSConverter.CreateDotSplit(El: TPasElement; Expr: TJSElement
): TJSElement;
// create Expr.split('')
var
DotExpr: TJSDotMemberExpression;
Call: TJSCallExpression;

2
packages/pastojs/src/pas2jsfiler.pp
View File

@ -80,7 +80,7 @@ unit Pas2JsFiler;
{$mode objfpc}{$H+}
{$IF FPC_FULLVERSION>30200}
{$IF FPC_FULLVERSION>=30300}
{$WARN 6060 off : case statement does not handle all possible cases}
{$ENDIF}

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

@ -7862,8 +7862,11 @@ begin
' c = string(''ä'');',
' d = UnicodeString(''b'');',
' e = UnicodeString(''ö'');',
' f = low(a)+high(b);',
' g: word = low(a);',
'var',
' s: string = ''abc'';',
' i: longint;',
'begin',
' s:='''';',
' s:=#13#10;',
@ -7882,6 +7885,7 @@ begin
' s:=concat(s);',
' s:=concat(s,''a'',s);',
' s:=#250#269;',
' i:=low(s)+high(a);',
//' s:=#$2F804;',
// ToDo: \uD87E\uDC04 -> \u{2F804}
'']);
@ -7893,7 +7897,10 @@ begin
'this.c = "ä";',
'this.d = "b";',
'this.e = "ö";',
'this.f = 1 + this.b.length;',
'this.g = 1;',
'this.s="abc";',
'this.i = 0;',
'']),
LinesToStr([
'$mod.s="";',
@ -7913,6 +7920,7 @@ begin
'$mod.s = $mod.s;',
'$mod.s = $mod.s.concat("a", $mod.s);',
'$mod.s = "úč";',
'$mod.i = 1 + $mod.a.length;',
'']));
end;

2
packages/paszlib/src/infblock.pas
View File

@ -45,7 +45,7 @@ function inflate_blocks_sync_point(var s : inflate_blocks_state) : integer;
implementation
uses
infcodes, inftrees, infutil;
infcodes, inftrees, infutil{$IFDEF ZLIB_DEBUG}, SysUtils{$ENDIF};
{ Tables for deflate from PKZIP's appnote.txt. }
Const

4
packages/paszlib/src/infcodes.pas
View File

@ -31,7 +31,7 @@ procedure inflate_codes_free(var c : pInflate_codes_state;
implementation
uses
infutil, inffast;
infutil, inffast{$IFDEF ZLIB_DEBUG}, SysUtils{$ENDIF};
function inflate_codes_new (bl : cardinal;
@ -185,7 +185,7 @@ begin
if (t^.base >= $20) and (t^.base < $7f) then
Tracevv('inflate: literal '+char(t^.base))
else
Tracevv('inflate: literal '+IntToStr(t^.base));
Tracevv('inflate: literal $'+IntToHex(t^.base, 2));
{$ENDIF}
c^.mode := LIT;
continue; { break switch statement }

2
packages/paszlib/src/inffast.pas
View File

@ -29,7 +29,7 @@ function inflate_fast( bl : cardinal;
implementation
uses
infutil;
infutil{$IFDEF ZLIB_DEBUG}, SysUtils{$ENDIF};
{ Called with number of bytes left to write in window at least 258

10
packages/paszlib/src/zbase.pas
View File

@ -380,10 +380,6 @@ const
PRESET_DICT = $20; { preset dictionary flag in zlib header }
{$IFDEF ZLIB_DEBUG}
procedure Assert(cond : boolean; msg : string);
{$ENDIF}
procedure Trace(x : string);
procedure Tracev(x : string);
procedure Tracevv(x : string);
@ -461,12 +457,6 @@ begin
Halt(1);
end;
procedure Assert(cond : boolean; msg : string);
begin
if not cond then
z_error(msg);
end;
procedure Trace(x : string);
begin
WriteLn(x);

6
packages/paszlib/src/zconf.inc
View File

@ -36,3 +36,9 @@
{$UNDEF MAXSEG_64K}
{$UNDEF Delphi32}
{$ENDIF}
{- $DEFINE ZLIB_DEBUG}
{$IFDEF ZLIB_DEBUG}
{$ASSERTIONS ON}
{$ENDIF}

21
packages/paszlib/src/zdeflate.pas
View File

@ -1502,6 +1502,27 @@ end;
{$endif} { FASTEST }
{$ifdef ZLIB_DEBUG}
function zmemcmp(s1p, s2p : PByte; len : Cardinal) : Integer;
var
j : Cardinal;
source,
dest : PByte;
begin
source := s1p;
dest := s2p;
for j := 0 to pred(len) do
begin
if (source^ <> dest^) then
begin
zmemcmp := 2*Ord(source^ > dest^)-1;
exit;
end;
Inc(source);
Inc(dest);
end;
zmemcmp := 0;
end;
{ ===========================================================================
Check that the match at match_start is indeed a match. }

7
packages/paszlib/src/zstream.pp
View File

@ -325,6 +325,7 @@ end;
function Tdecompressionstream.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64;
var c,off: int64;
buf: array[0..8191] of Byte;
begin
off:=Offset;
@ -344,9 +345,9 @@ begin
while off>0 do
begin
c:=off;
if c>bufsize then
c:=bufsize;
if read(Fbuffer^,c)<>c then
if c>SizeOf(buf) then
c:=SizeOf(buf);
if read(buf,c)<>c then
raise Edecompressionerror.create(Sseek_failed);
dec(off,c);
end;

47
packages/rtl-objpas/src/inc/dateutil.inc
View File

@ -2769,7 +2769,9 @@ end;
function TryISOStrToTime(const aString: string; Out outTime: TDateTime): Boolean;
var
xHour, xMinute, xSecond, xMillisecond, xLength: LongInt;
xHour, xMinute, xSecond, xLength, res: LongInt;
xFractionalSecond: Extended;
tmp: String;
begin
Result := True;
xLength := Length(aString);
@ -2829,24 +2831,31 @@ begin
(aString[6] = ':') and
TryStrToInt(Copy(aString, 7, 2), xSecond) and
TryEncodeTime(xHour, xMinute, xSecond, 0, outTime);
10: Result :=
TryStrToInt(Copy(aString, 1, 2), xHour) and
TryStrToInt(Copy(aString, 3, 2), xMinute) and
TryStrToInt(Copy(aString, 5, 2), xSecond) and
(aString[7] = '.') and
TryStrToInt(Copy(aString, 8, 3), xMillisecond) and
TryEncodeTime(xHour, xMinute, xSecond, xMillisecond, outTime);
12: Result :=
TryStrToInt(Copy(aString, 1, 2), xHour) and
(aString[3] = ':') and
TryStrToInt(Copy(aString, 4, 2), xMinute) and
(aString[6] = ':') and
TryStrToInt(Copy(aString, 7, 2), xSecond) and
(aString[9] = '.') and
TryStrToInt(Copy(aString, 10, 3), xMillisecond) and
TryEncodeTime(xHour, xMinute, xSecond, xMillisecond, outTime);
else
Result := False;
else
if xLength >= 9 then
begin
Result :=
TryStrToInt(Copy(aString, 1, 2), xHour) and
(aString[3] = ':') and
TryStrToInt(Copy(aString, 4, 2), xMinute) and
(aString[6] = ':') and
TryStrToInt(Copy(aString, 7, 2), xSecond) and
((aString[9] = '.') or (aString[9] = ',')) and
TryEncodeTime(xHour, xMinute, xSecond, 0, outTime);
if Result then
begin
tmp := Copy(aString, 9, xLength-8);
if tmp <> '' then
begin
tmp[1] := '.';
val(tmp, xFractionalSecond, res);
Result := res = 0;
if Result then
outTime := outTime + xFractionalSecond * OneSecond;
end;
end;
end else
Result := false;
end;
if not Result then

2
rtl/embedded/arm/cortexm0_start.inc
View File

@ -9,7 +9,7 @@ var
procedure Pascalmain; external name 'PASCALMAIN';
procedure HaltProc; assembler; nostackframe; public name'_haltproc';
procedure HaltProc; assembler; nostackframe; public name'_haltproc'; noreturn;
asm
.Lloop:
b .Lloop

2
rtl/embedded/arm/cortexm3_start.inc
View File

@ -9,7 +9,7 @@ var
procedure Pascalmain; external name 'PASCALMAIN';
procedure HaltProc; assembler; nostackframe; public name'_haltproc';
procedure HaltProc; assembler; nostackframe; public name'_haltproc'; noreturn;
asm
.Lloop:
b .Lloop

2
rtl/embedded/system.pp
View File

@ -300,7 +300,7 @@ begin
{$ifdef FPC_HAS_FEATURE_THREADING}
{ threading }
//InitSystemThreads; // Empty call for embedded anyway
InitSystemThreads;
{$endif FPC_HAS_FEATURE_THREADING}
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}

114
rtl/embedded/systhrd.inc
View File

@ -3,7 +3,7 @@
Copyright (c) 2002 by Peter Vreman,
member of the Free Pascal development team.
Embedded empty threading support implementation
Embedded threading support implementation
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
@ -14,8 +14,116 @@
**********************************************************************}
{ resourcestrings are not supported by the system unit,
they are in the objpas unit and not available for fpc/tp modes }
const
SNoThreads = 'This binary has no thread support compiled in.';
SRecompileWithThreads = 'Recompile the application with a thread-driver in the program uses clause before other units using thread.';
Procedure NoThreadError;NoReturn;
begin
{$ifdef FPC_HAS_FEATURE_CONSOLEIO}
If IsConsole then
begin
Writeln(StdErr,SNoThreads);
Writeln(StdErr,SRecompileWithThreads);
end;
{$endif FPC_HAS_FEATURE_CONSOLEIO}
{ providing an rte on embedded makes often little sense and
runerror(...) would pull in a lot of unnecessary code }
system_exit;
end;
function NoGetCurrentThreadId : TThreadID;
begin
if IsMultiThread then
NoThreadError
else
ThreadingAlreadyUsed:=true;
result:=TThreadID(1);
end;
function NoBeginThread(sa : Pointer;stacksize : PtrUInt;
ThreadFunction : tthreadfunc;p : pointer;
creationFlags : dword; var ThreadId : TThreadID) : TThreadID;NoReturn;
begin
NoThreadError;
end;
procedure SysInitCriticalSection(var cs);
begin
end;
procedure SysDoneCriticalSection(var cs);
begin
end;
procedure SysEnterCriticalSection(var cs);
begin
end;
function SysTryEnterCriticalSection(var cs):longint;
begin
end;
procedure SysLeaveCriticalSection(var cs);
begin
end;
const
EmbeddedThreadManager : TThreadManager = (
InitManager : Nil;
DoneManager : Nil;
{ while this is pretty hacky, it reduces the size of typical embedded programs
and works fine on arm and avr }
BeginThread : @NoBeginThread;
EndThread : TEndThreadHandler(@NoThreadError);
SuspendThread : TThreadHandler(@NoThreadError);
ResumeThread : TThreadHandler(@NoThreadError);
KillThread : TThreadHandler(@NoThreadError);
CloseThread : TThreadHandler(@NoThreadError);
ThreadSwitch : TThreadSwitchHandler(@NoThreadError);
WaitForThreadTerminate : TWaitForThreadTerminateHandler(@NoThreadError);
ThreadSetPriority : TThreadSetPriorityHandler(@NoThreadError);
ThreadGetPriority : TThreadGetPriorityHandler(@NoThreadError);
GetCurrentThreadId : @NoGetCurrentThreadId;
SetThreadDebugNameA : TThreadSetThreadDebugNameHandlerA(@NoThreadError);
{$ifdef FPC_HAS_FEATURE_UNICODESTRINGS}
SetThreadDebugNameU : TThreadSetThreadDebugNameHandlerU(@NoThreadError);
{$endif FPC_HAS_FEATURE_UNICODESTRINGS}
InitCriticalSection : @SysInitCriticalSection;
DoneCriticalSection : @SysDoneCriticalSection;
EnterCriticalSection : @SysEnterCriticalSection;
TryEnterCriticalSection: @SysTryEnterCriticalSection;
LeaveCriticalSection : @SysLeaveCriticalSection;
InitThreadVar : TInitThreadVarHandler(@NoThreadError);
RelocateThreadVar : TRelocateThreadVarHandler(@NoThreadError);
AllocateThreadVars : @NoThreadError;
ReleaseThreadVars : @NoThreadError;
BasicEventCreate : TBasicEventCreateHandler(@NoThreadError);
BasicEventdestroy : TBasicEventHandler(@NoThreadError);
BasicEventResetEvent : TBasicEventHandler(@NoThreadError);
BasicEventSetEvent : TBasicEventHandler(@NoThreadError);
BasicEventWaitFor : TBasicEventWaitForHandler(@NoThreadError);
RTLEventCreate : TRTLCreateEventHandler(@NoThreadError);
RTLEventdestroy : TRTLEventHandler(@NoThreadError);
RTLEventSetEvent : TRTLEventHandler(@NoThreadError);
RTLEventResetEvent : TRTLEventHandler(@NoThreadError);
RTLEventWaitFor : TRTLEventHandler(@NoThreadError);
RTLEventwaitfortimeout : TRTLEventHandlerTimeout(@NoThreadError);
);
Procedure InitSystemThreads;
begin
{ calling SetThreadManager pulls in too much code }
CurrentTM:=EmbeddedThreadManager;
end;

2
rtl/objpas/classes/streams.inc
View File

@ -1643,7 +1643,7 @@ Var
begin
B:=FEncoding.GetBytes(AString);
if Length(B)>0 then
WriteBuffer(B[0],Length(Bytes));
WriteBuffer(B[0],Length(B));
end;
function TStringStream.ReadAnsiString(Count: Longint): AnsiString;

35
rtl/win32/seh32.inc
View File

@ -164,11 +164,8 @@ function __FPC_default_handler(
var context: TContext;
var dispatch: TDispatcherContext): EXCEPTION_DISPOSITION; cdecl; [public,alias:'__FPC_DEFAULT_HANDLER'];
var
Exc: TExceptObject;
code: longint;
Obj: TObject;
Adr: Pointer;
Frames: PCodePointer;
FrameCount: Longint;
begin
if (rec.ExceptionFlags and EXCEPTION_UNWIND)=0 then
begin
@ -199,11 +196,11 @@ begin
if code<0 then
SysResetFPU;
code:=abs(code);
Adr:=rec.ExceptionAddress;
Obj:=nil;
Exc.Addr:=rec.ExceptionAddress;
Exc.FObject:=nil;
if Assigned(ExceptObjProc) then
Obj:=TObject(TExceptObjProc(ExceptObjProc)(code,rec));
if Obj=nil then
Exc.FObject:=TObject(TExceptObjProc(ExceptObjProc)(code,rec));
if Exc.FObject=nil then
begin
{ This works because RtlUnwind does not actually unwind the stack on i386
(and only on i386) }
@ -212,26 +209,34 @@ begin
erroraddr:=pointer(context.Eip);
Halt(code);
end;
FrameCount:=GetBacktrace(context,nil,Frames);
Exc.FrameCount:=GetBacktrace(context,nil,Exc.Frames);
end
else
begin
Obj:=TObject(rec.ExceptionInformation[1]);
Adr:=rec.ExceptionInformation[0];
Frames:=PCodePointer(rec.ExceptionInformation[3]);
FrameCount:=ptruint(rec.ExceptionInformation[2]);
Exc.FObject:=TObject(rec.ExceptionInformation[1]);
Exc.Addr:=rec.ExceptionInformation[0];
Exc.Frames:=PCodePointer(rec.ExceptionInformation[3]);
Exc.FrameCount:=ptruint(rec.ExceptionInformation[2]);
code:=217;
end;
Exc.Refcount:=0;
Exc.SEHFrame:=@frame;
Exc.ExceptRec:=@rec;
{ link to ExceptObjectStack }
Exc.Next:=ExceptObjectStack;
ExceptObjectStack:=@Exc;
if Assigned(ExceptProc) then
begin
ExceptProc(Obj,Adr,FrameCount,Frames);
ExceptProc(Exc.FObject,Exc.Addr,Exc.FrameCount,Exc.Frames);
Halt(217);
end
else
begin
errorcode:=word(code);
errorbase:=pointer(rec.ExceptionInformation[4]);
erroraddr:=pointer(Adr);
erroraddr:=pointer(Exc.Addr);
Halt(code);
end;
end;

169
tests/test/tcustomvar1.pp Normal file
View File

@ -0,0 +1,169 @@
program tcustomvar1;
{$APPTYPE CONSOLE}
{$MODE Delphi}
uses
Variants, SysUtils;
type
TSampleVariant = class(TCustomVariantType)
protected
procedure DispInvoke(Dest: PVarData; var Source: TVarData; CallDesc: PCallDesc; Params: Pointer); override;
public
procedure Clear(var V: TVarData); override;
procedure Copy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean ); override;
end;
procedure TSampleVariant.Clear(var V: TVarData);
begin
V.VType:=varEmpty;
end;
procedure TSampleVariant.Copy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean);
begin
if Indirect and VarDataIsByRef(Source) then
VarDataCopyNoInd(Dest, Source)
else with Dest do
VType:=Source.VType;
end;
var
funcname: String;
argnames: array of String;
argtypes: array of Byte;
argvalues: array of Variant;
procedure TSampleVariant.DispInvoke(Dest: PVarData; var Source: TVarData; CallDesc: PCallDesc; Params: Pointer);
var
n: AnsiString;
nptr: PChar;
arg: Pointer;
t: Byte;
i: LongInt;
v: Variant;
begin
nptr := PChar(@CallDesc^.argtypes[CallDesc^.argcount]);
n := StrPas(nptr);
if n <> funcname then begin
Writeln('Func name: got: ', n, ', expected: ', funcname);
Halt(1);
end;
if Length(argnames) <> CallDesc^.namedargcount then
Halt(1);
nptr := nptr + Length(n) + 1;
arg := Params;
for i := 0 to CallDesc^.namedargcount - 1 do begin
n := StrPas(nptr);
if n <> argnames[i] then begin
Writeln('Arg ', i, ': got: ', n, ', expected: ', argnames[i]);
Halt(1);
end;
if CallDesc^.argtypes[i] <> argtypes[i] then begin
Writeln('Arg ', i, ' type: got: ', CallDesc^.ArgTypes[i], ', expected: ', argtypes[i]);
Halt(1);
end;
t := argtypes[i] and $7f;
if argtypes[i] and $80 <> 0 then begin
TVarData(v).VType := t or varByRef;
TVarData(v).VPointer := PPointer(arg)^;
end else begin
TVarData(v).VType := t;
case t of
varStrArg: begin
TVarData(v).VType := varString;
AnsiString(TVarData(v).VString) := AnsiString(StrPas(PPWideChar(arg)^));
end;
varUStrArg: begin
TVarData(v).VType := varUString;
UnicodeString(TVarData(v).VUString) := StrPas(PPWideChar(arg)^);
end;
varSingle,
varSmallint,
varInteger,
varLongWord,
varBoolean,
varShortInt,
varByte,
varWord:
TVarData(v).VInteger := PInteger(arg)^;
else
TVarData(v).VAny := PPointer(arg)^;
end;
end;
if (not VarIsStr(v) and (v <> argvalues[i])) or (VarIsStr(v) and (UnicodeString(v) <> UnicodeString(argvalues[i]))) then begin
Writeln('Arg ', i, ' value: got: ', String(v), ', expected: ', String(argvalues[i]));
Halt(1);
end;
nptr := nptr + Length(n) + 1;
arg := PByte(arg) + SizeOf(Pointer);
{ unset so that VarClear doesn't try to free the constant WideChar }
TVarData(v).vtype:=varEmpty;
end;
end;
function ConvertArgType(aType: Word): Byte;
var
ref: Boolean;
begin
ref := (aType and varByRef) <> 0;
aType := aType and not varByRef;
case aType of
{$ifndef windows}
varOleStr:
Result := varUStrArg;
{$endif}
varString:
{$ifdef windows}
Result := varOleStr;
{$else}
Result := varUStrArg; { not varStrArg }
{$endif}
varUString:
{$ifdef windows}
Result := varOleStr;
{$else}
Result := varUStrArg;
{$endif}
otherwise
Result := aType;
end;
if ref then
Result := Result or $80;
end;
var
SampleVariant: TSampleVariant;
v, v1: Variant;
begin
SampleVariant:=TSampleVariant.Create;
TVarData(v).VType:=SampleVariant.VarType;
funcname := 'SomeProc';
SetLength(argnames, 0);
v.SomeProc;
funcname := 'SomeFunc';
SetLength(argnames, 0);
v1 := v.SomeFunc;
funcname := 'Begin';
SetLength(argnames, 2);
SetLength(argtypes, 2);
SetLength(argvalues, 2);
{ the parameters are passed right-to-left }
argnames[1] := 'Date';
argnames[0] := 'Foobar';
argvalues[1] := 42;
argvalues[0] := UnicodeString('Hello');
argtypes[1] := ConvertArgType(TVarData(argvalues[1]).VType);
argtypes[0] := ConvertArgType(TVarData(argvalues[0]).VType);
v.&Begin(Date:=42,Foobar:='Hello');
funcname := '_';
SetLength(argnames, 0);
v._;
writeln('ok');
end.

25
tests/test/texception11.pp Normal file
View File

@ -0,0 +1,25 @@
program texception11;
{$mode objfpc}
uses
SysUtils;
type
ETest = class(Exception);
procedure TestExcept(Obj : TObject; Addr : CodePointer; FrameCount:Longint; Frame: PCodePointer);
begin
if not (Obj is ETest) then
Halt(1);
if not (ExceptObject is ETest) then
Halt(2);
{ explicitely halt with exit code 0 }
Halt(0);
end;
begin
ExceptProc := @TestExcept;
raise ETest.Create('');
end.

48
tests/test/units/dateutil/tiso8601.pp Normal file
View File

@ -0,0 +1,48 @@
{ %OPT=-Mobjfpc }
program tiso8601;
uses
SysUtils, DateUtils;
const
sd6 = '2021-05-22T13:57:49.191021Z';
sd3 = '2021-05-22T13:57:49.191Z';
sd2 = '2021-05-22T13:57:49.19Z';
sd1 = '2021-05-22T13:57:49.1Z';
sc6 = '2021-05-22T13:57:49,191021Z';
sc3 = '2021-05-22T13:57:49,191Z';
sc2 = '2021-05-22T13:57:49,19Z';
sc1 = '2021-05-22T13:57:49,1Z';
var
dt1, dt2, dt3, dt6: TDateTime;
hasErrors : boolean;
procedure Test(s: String);
var
dt: TDateTime;
begin
Write(s:30, ' ---> ');
try
dt := ISO8601ToDate(s, true);
WriteLn(dt:0:15);
except
WriteLn('ERROR');
hasErrors:=True;
end;
end;
begin
HasErrors:=False;
Test(sd1);
Test(sd2);
Test(sd3);
Test(sd6);
Test(sc1);
Test(sc2);
Test(sc3);
Test(sc6);
Halt(Ord(HasErrors));
end.

198
tests/webtbs/tw17904.pas
View File

@ -1,198 +0,0 @@
{$ifdef fpc}{$mode objfpc}{$h+}{$endif}
{$apptype console}
uses Variants, SysUtils;
type
TTest = class(TCustomVariantType)
procedure Clear(var V: TVarData); override;
procedure Copy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean); override;
procedure DispInvoke(Dest: PVarData; var Source: TVarData; CallDesc: PCallDesc; Params: Pointer); override;
end;
procedure TTest.Clear(var V: TVarData);
begin
end;
procedure TTest.Copy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean);
begin
end;
procedure TTest.DispInvoke(Dest: PVarData; var Source: TVarData; CallDesc: PCallDesc; Params: Pointer);
var
tmp: Word;
begin
if (CallDesc^.ArgCount =2) and Assigned(Dest) then
begin
//writeln(HexStr(PPointer(Params)^), ' ', HexStr(PPointer(Params)[1]));
WordRec(tmp).Lo := CallDesc^.ArgTypes[0];
WordRec(tmp).Hi := CallDesc^.ArgTypes[1];
// !! FPC passes args right-to-left, Delphi does same left-to-right
// Moreover, IDispatch needs args right-to-left, and Variant Dispatch needs left-to-right. Nice, huh?
{$ifdef fpc}
tmp := Swap(tmp);
{$endif}
Variant(Dest^) := tmp;
end;
end;
type
TTestClass=class
u8: byte;
u16: word;
u32: longword;
{$ifdef fpc}
u64: qword;
{$endif}
s8: shortint;
s16: smallint;
s32: longint;
s64: int64;
cy: currency;
b: boolean;
bb: bytebool;
wb: wordbool;
lb: longbool;
sgl: single;
dbl: double;
ext: extended;
dt: TDateTime;
fsstr: shortstring;
fastr: ansistring;
fwstr: widestring;
{$ifdef fpc}
fustr: unicodestring;
{$endif}
fvar: Variant;
fintf: IInterface;
fdisp: IDispatch;
property u8prop: Byte read u8;
property u16prop: Word read u16;
property u32prop: LongWord read u32;
{$ifdef fpc}
property u64prop: QWord read u64;
{$endif}
property s8prop: ShortInt read s8;
property s16prop: SmallInt read s16;
property s32prop: LongInt read s32;
property s64prop: Int64 read s64;
property cyprop: currency read cy;
property bprop: boolean read b;
property bbprop: bytebool read bb;
property wbprop: wordbool read wb;
property lbprop: longbool read lb;
property sglprop: single read sgl;
property dblprop: double read dbl;
property extprop: extended read ext;
property dtprop: TDateTime read dt;
property varprop: Variant read fvar;
property intfprop: IInterface read fintf;
property dispprop: IDispatch read fdisp;
property sstr: shortstring read fsstr;
property astr: ansistring read fastr;
property wstr: widestring read fwstr;
{$ifdef fpc}
property ustr: unicodestring read fustr;
{$endif}
end;
var
cv: TCustomVariantType;
code: Integer;
cl: TTestClass;
v: Variant;
// using negative values of Expected to check that arg is passed by-value only
procedure test(const id: string; const act: Variant; expected: Integer);
var
tmp: word;
absexp: Integer;
begin
tmp := act;
absexp := abs(expected);
write(id, WordRec(tmp).Lo,', ', WordRec(tmp).Hi);
if (expected >= 0) and (WordRec(tmp).Lo <> (expected or $80)) then
begin
write(' BYREF failed');
Code := Code or 1;
end;
if WordRec(tmp).Hi <> absexp then
begin
write(' BYVAL failed');
Code := Code or 2;
end;
writeln;
end;
begin
Code := 0;
cv := TTest.Create;
cl := TTestClass.Create;
TVarData(v).vType := cv.VarType;
test('u8: ', v.foo(cl.u8, cl.u8prop), varbyte);
test('u16: ', v.foo(cl.u16, cl.u16prop), varword); // (Uncertain) D7: treated as Integer
test('u32: ', v.foo(cl.u32, cl.u32prop), varlongword); // (Uncertain) D7: treated as Integer ByRef
test('s8: ', v.foo(cl.s8, cl.s8prop), varshortint); // (Uncertain) D7: treated as Integer
test('s16: ', v.foo(cl.s16, cl.s16prop), varsmallint);
test('s32: ', v.foo(cl.s32, cl.s32prop), varinteger);
test('s64: ', v.foo(cl.s64, cl.s64prop), varint64);
{$ifdef fpc}
test('u64: ', v.foo(cl.u64, cl.u64prop), varword64);
{$endif}
test('wordbool:', v.foo(cl.wb, cl.wbprop), varBoolean);
test('curncy: ', v.foo(cl.cy, cl.cyprop), varCurrency);
test('single: ', v.foo(cl.sgl, cl.sglprop), varSingle);
test('double: ', v.foo(cl.dbl, cl.dblprop), varDouble);
test('extended:', v.foo(cl.ext, cl.extprop), -varDouble); // not a COM type, passed by value
test('date: ', v.foo(cl.dt, cl.dtprop), varDate);
test('ansistr: ', v.foo(cl.fastr, cl.astr), varStrArg);
test('widestr: ', v.foo(cl.fwstr, cl.wstr), varOleStr);
{$ifdef fpc}
test('unistr: ', v.foo(cl.fustr, cl.ustr), varUStrArg);
{$endif}
test('variant: ', v.foo(cl.fvar, cl.varprop), varVariant);
test('IUnknown:', v.foo(cl.fintf, cl.intfprop), varUnknown);
test('IDispatch:', v.foo(cl.fdisp, cl.dispprop), varDispatch);
// not an COM type, passed by value; Delphi uses varStrArg
test('shortstr:', v.foo(cl.fsstr, cl.sstr), -varOleStr);
// not an COM type, passed by value
test('longbool:', v.foo(cl.lb, cl.lbprop), -varBoolean);
// typecasted ordinals (only one arg is actually used)
test('u8+cast: ', v.foo(byte(55), byte(55)), -varByte);
test('u16+cast:', v.foo(word(55), word(55)), -varWord);
test('u32+cast:', v.foo(longword(55), longword(55)), -varLongWord);
{$ifdef fpc}
test('u64+cast:', v.foo(qword(55), qword(55)), -varQWord);
{$endif}
test('s8+cast:', v.foo(shortint(55), shortint(55)), -varShortInt);
test('s16+cast:', v.foo(smallint(55), smallint(55)), -varSmallInt);
test('s32+cast:', v.foo(longint(55), longint(55)), -varInteger);
test('s64+cast:', v.foo(int64(55), int64(55)), -varInt64);
cl.Free;
if Code <> 0 then
writeln('Errors: ', Code);
Halt(Code);
end.