diff --git a/.gitattributes b/.gitattributes
index de310ccc01..668e8511a7 100644
--- a/.gitattributes
+++ b/.gitattributes
@@ -11941,6 +11941,9 @@ rtl/riscv64/strings.inc svneol=native#text/plain
rtl/riscv64/stringss.inc svneol=native#text/plain
rtl/sinclairql/Makefile.fpc svneol=native#text/plain
rtl/sinclairql/buildrtl.pp svneol=native#text/plain
+rtl/sinclairql/qdos.inc svneol=native#text/plain
+rtl/sinclairql/qdosfuncs.inc svneol=native#text/plain
+rtl/sinclairql/qdosh.inc svneol=native#text/plain
rtl/sinclairql/rtl.cfg svneol=native#text/plain
rtl/sinclairql/rtldefs.inc svneol=native#text/plain
rtl/sinclairql/si_prc.pp svneol=native#text/plain
@@ -18559,6 +18562,8 @@ tests/webtbs/tw37969.pp svneol=native#text/pascal
tests/webtbs/tw38012.pp svneol=native#text/pascal
tests/webtbs/tw38022.pp svneol=native#text/pascal
tests/webtbs/tw3805.pp svneol=native#text/plain
+tests/webtbs/tw38051.pp svneol=native#text/pascal
+tests/webtbs/tw38054.pp svneol=native#text/plain
tests/webtbs/tw3814.pp svneol=native#text/plain
tests/webtbs/tw3827.pp svneol=native#text/plain
tests/webtbs/tw3829.pp svneol=native#text/plain
diff --git a/compiler/m68k/ra68kmot.pas b/compiler/m68k/ra68kmot.pas
index acfc37abbf..8a4664336b 100644
--- a/compiler/m68k/ra68kmot.pas
+++ b/compiler/m68k/ra68kmot.pas
@@ -1522,6 +1522,8 @@ const
end
else
begin
+ if actasmtoken = AS_LPAREN then
+ oper.initref;
if not oper.SetupVar(expr,false) then
begin
{ not a variable, check special variables.. }
diff --git a/compiler/pexpr.pas b/compiler/pexpr.pas
index 27c3757c81..1558e38263 100644
--- a/compiler/pexpr.pas
+++ b/compiler/pexpr.pas
@@ -290,13 +290,14 @@ implementation
statement_syssym:=new_dispose_statement(false);
end;
- in_ord_x :
+ in_ord_x,
+ in_chr_byte:
begin
consume(_LKLAMMER);
in_args:=true;
p1:=comp_expr([ef_accept_equal]);
consume(_RKLAMMER);
- p1:=geninlinenode(in_ord_x,false,p1);
+ p1:=geninlinenode(l,false,p1);
statement_syssym := p1;
end;
diff --git a/compiler/pinline.pas b/compiler/pinline.pas
index ef4eee9026..2f47fee9b3 100644
--- a/compiler/pinline.pas
+++ b/compiler/pinline.pas
@@ -382,7 +382,7 @@ implementation
{ create call to fpc_getmem }
para := ccallparanode.create(cordconstnode.create
- (tpointerdef(p.resultdef).pointeddef.size,s32inttype,true),nil);
+ (tpointerdef(p.resultdef).pointeddef.size,ptruinttype,true),nil);
addstatement(newstatement,cassignmentnode.create(
ctemprefnode.create(temp),
ccallnode.createintern('fpc_getmem',para)));
diff --git a/compiler/ppu.pas b/compiler/ppu.pas
index deb898422f..559934288b 100644
--- a/compiler/ppu.pas
+++ b/compiler/ppu.pas
@@ -50,7 +50,7 @@ const
CurrentPPUVersion = 208;
{ for any other changes to the ppu format, increase this version number
(it's a cardinal) }
- CurrentPPULongVersion = 11;
+ CurrentPPULongVersion = 12;
{ unit flags }
uf_big_endian = $000004;
diff --git a/compiler/psystem.pas b/compiler/psystem.pas
index 807abe4e9e..b33c370cac 100644
--- a/compiler/psystem.pas
+++ b/compiler/psystem.pas
@@ -70,6 +70,7 @@ implementation
systemunit.insert(csyssym.create('Slice',in_slice_x));
systemunit.insert(csyssym.create('Seg',in_seg_x));
systemunit.insert(csyssym.create('Ord',in_ord_x));
+ systemunit.insert(csyssym.create('Chr',in_chr_byte));
systemunit.insert(csyssym.create('Pred',in_pred_x));
systemunit.insert(csyssym.create('Succ',in_succ_x));
systemunit.insert(csyssym.create('Exclude',in_exclude_x_y));
diff --git a/compiler/systems/t_sinclairql.pas b/compiler/systems/t_sinclairql.pas
index e6e8ddfc66..51ae1ca233 100644
--- a/compiler/systems/t_sinclairql.pas
+++ b/compiler/systems/t_sinclairql.pas
@@ -35,6 +35,7 @@ type
private
Origin: DWord;
UseVLink: boolean;
+ ExeLength: longint;
function WriteResponseFile(isdll: boolean): boolean;
procedure SetSinclairQLInfo;
function MakeSinclairQLExe: boolean;
@@ -54,7 +55,7 @@ implementation
const
- DefaultOrigin = $20000;
+ DefaultOrigin = $0;
constructor TLinkerSinclairQL.Create;
@@ -83,7 +84,7 @@ begin
end
else
begin
- ExeCmd[1]:='vlink -b rawbin1 $FLAGS $GCSECTIONS $OPT $STRIP -o $EXE -T $RES';
+ ExeCmd[1]:='vlink -b rawseg -q $FLAGS $GCSECTIONS $OPT $STRIP -o $EXE -T $RES';
end;
end;
end;
@@ -105,10 +106,8 @@ end;
function TLinkerSinclairQL.WriteResponseFile(isdll: boolean): boolean;
var
linkres : TLinkRes;
- i : longint;
HPath : TCmdStrListItem;
s : string;
- linklibc : boolean;
begin
WriteResponseFile:=False;
@@ -177,9 +176,13 @@ begin
Add('SECTIONS');
Add('{');
Add(' . = 0x'+hexstr(Origin,8)+';');
- Add(' .text : { *(.text .text.* _CODE _CODE.* ) }');
- Add(' .data : { *(.data .data.* .rodata .rodata.* .fpc.* ) }');
- Add(' .bss : { *(_BSS _BSS.*) *(.bss .bss.*) *(_BSSEND _BSSEND.*) *(_HEAP _HEAP.*) *(.stack .stack.*) *(_STACK _STACK.*) }');
+ Add(' .text : {');
+ Add(' _stext = .;');
+ Add(' *(.text .text.* _CODE _CODE.* ) ');
+ Add(' *(.data .data.* .rodata .rodata.* .fpc.* ) ');
+ Add(' *(_BSS _BSS.*) *(.bss .bss.*) *(_BSSEND _BSSEND.*) *(_HEAP _HEAP.*) *(.stack .stack.*) *(_STACK _STACK.*) ');
+ Add(' _etext = .;');
+ Add(' }');
Add('}');
end;
@@ -200,6 +203,9 @@ var
GCSectionsStr : string;
FlagsStr : string;
ExeName: string;
+ fd,fs: file;
+ buf: pointer;
+ bufread,bufsize: longint;
begin
StripStr:='';
GCSectionsStr:='';
@@ -213,12 +219,10 @@ begin
if UseVLink then
begin
if create_smartlink_sections then
- GCSectionsStr:='-gc-all -sc';
+ GCSectionsStr:='-gc-all';
end;
ExeName:=current_module.exefilename;
- if apptype = app_gui then
- Replace(ExeName,target_info.exeext,'.prg');
{ Call linker }
SplitBinCmd(Info.ExeCmd[1],BinStr,CmdStr);
@@ -232,12 +236,57 @@ begin
Replace(cmdstr,'$DYNLINK',DynLinkStr);
MakeSinclairQLExe:=DoExec(BinStr,CmdStr,true,false);
+
+ { Kludge:
+ With the above linker script, vlink will produce two files,
+ "exename. text" and "exename. text.rel text". The former is the
+ binary itself, the second is the relocation info. Here we copy
+ the two together. I'll try to get vlink to do this for me in the
+ future. (KB) }
+ if MakeSinclairQLExe then
+ begin
+ ExeLength:=0;
+ bufsize:=16384;
+{$push}
+{$i-}
+ buf:=GetMem(bufsize);
+ assign(fd,exename);
+ rewrite(fd,1);
+
+ assign(fs,exename+'. text');
+ reset(fs,1);
+ repeat
+ blockread(fs,buf^,bufsize,bufread);
+ blockwrite(fd,buf^,bufread);
+ until eof(fs);
+ close(fs);
+ // erase(fs);
+
+ assign(fs,exename+'. text.rel text');
+ reset(fs,1);
+ repeat
+ blockread(fs,buf^,bufsize,bufread);
+ blockwrite(fd,buf^,bufread);
+ until eof(fs);
+ close(fs);
+ // erase(fs);
+
+ ExeLength:=FileSize(fd);
+ close(fd);
+{$pop}
+ MakeSinclairQLExe:=not (ExeLength = 0);
+ end;
end;
function TLinkerSinclairQL.MakeExecutable:boolean;
+const
+ DefaultBootString = '10 $SYM=RESPR($BINSIZE):LBYTES"win1_$EXENAME",$SYM:CALL $SYM';
var
success : boolean;
+ bootfile : TScript;
+ ExeName: String;
+ BootStr: String;
begin
if not(cs_link_nolink in current_settings.globalswitches) then
Message1(exec_i_linking,current_module.exefilename);
@@ -251,6 +300,24 @@ begin
if (success) and not(cs_link_nolink in current_settings.globalswitches) then
DeleteFile(outputexedir+Info.ResName);
+ if (success) then
+ begin
+ ExeName:=current_module.exefilename;
+ BootStr:=DefaultBootString;
+
+ Replace(BootStr,'$BINSIZE',tostr(ExeLength)); { FIX ME }
+ Replace(BootStr,'$EXENAME',ExeName);
+
+ Replace(ExeName,target_info.exeext,'');
+ Replace(BootStr,'$SYM',ExeName);
+
+ { Write bootfile }
+ bootfile:=TScript.Create(outputexedir+ExeName);
+ bootfile.Add(BootStr);
+ bootfile.writetodisk;
+ bootfile.Free;
+ end;
+
MakeExecutable:=success; { otherwise a recursive call to link method }
end;
diff --git a/compiler/x86/cgx86.pas b/compiler/x86/cgx86.pas
index a2a4749e8e..3530dd1e69 100644
--- a/compiler/x86/cgx86.pas
+++ b/compiler/x86/cgx86.pas
@@ -178,8 +178,6 @@ unit cgx86;
winstackpagesize = 4096;
{$endif NOTARGETWIN}
- function UseAVX: boolean;
-
function UseIncDec: boolean;
{ returns true, if the compiler should use leave instead of mov/pop }
@@ -196,12 +194,6 @@ unit cgx86;
paramgr,procinfo,
tgobj,ncgutil;
- function UseAVX: boolean;
- begin
- Result:={$ifdef i8086}false{$else i8086}(FPUX86_HAS_AVXUNIT in fpu_capabilities[current_settings.fputype]){$endif i8086};
- end;
-
-
{ modern CPUs prefer add/sub over inc/dec because add/sub break instructions dependencies on flags
because they modify all flags }
function UseIncDec: boolean;
diff --git a/compiler/x86/cpubase.pas b/compiler/x86/cpubase.pas
index 319a4d4802..ebbf642151 100644
--- a/compiler/x86/cpubase.pas
+++ b/compiler/x86/cpubase.pas
@@ -385,11 +385,15 @@ topsize2memsize: array[topsize] of integer =
function requires_fwait_on_8087(op: TAsmOp): boolean;
{$endif i8086}
+ function UseAVX: boolean;
+ function UseAVX512: boolean;
+
implementation
uses
globtype,
- rgbase,verbose;
+ rgbase,verbose,
+ cpuinfo;
const
{$if defined(x86_64)}
@@ -948,4 +952,17 @@ implementation
{$endif i8086}
+ function UseAVX: boolean;
+ begin
+ Result:={$ifdef i8086}false{$else i8086}(FPUX86_HAS_AVXUNIT in fpu_capabilities[current_settings.fputype]){$endif i8086};
+ end;
+
+
+ function UseAVX512: boolean;
+ begin
+ // Result:=(current_settings.fputype in fpu_avx_instructionsets) {$ifndef i8086}or (CPUX86_HAS_AVXUNIT in cpu_capabilities[current_settings.cputype]){$endif i8086};
+ Result:=false;
+ end;
+
+
end.
diff --git a/compiler/x86/nx86add.pas b/compiler/x86/nx86add.pas
index c530f02e23..954c0af3bd 100644
--- a/compiler/x86/nx86add.pas
+++ b/compiler/x86/nx86add.pas
@@ -1268,15 +1268,32 @@ unit nx86add;
{ we can use only right as left operand if the operation is commutative }
if (right.location.loc=LOC_MMREGISTER) and (op in [OP_ADD,OP_MUL]) then
begin
- location.register:=right.location.register;
- cg.a_opmm_loc_reg(current_asmdata.CurrAsmList,op,tfloat2tcgsize[tfloatdef(left.resultdef).floattype],left.location,location.register,nil);
+ if UseAVX then
+ begin
+ location.register:=cg.getmmregister(current_asmdata.CurrAsmList,OS_VECTOR);
+ cg.a_opmm_loc_reg_reg(current_asmdata.CurrAsmList,op,tfloat2tcgsize[tfloatdef(left.resultdef).floattype],left.location,right.location.register,location.register,nil);
+ end
+ else
+ begin
+ location.register:=right.location.register;
+ cg.a_opmm_loc_reg(current_asmdata.CurrAsmList,op,tfloat2tcgsize[tfloatdef(left.resultdef).floattype],left.location,location.register,nil);
+ end;
end
else
begin
location_force_mmreg(current_asmdata.CurrAsmList,left.location,false);
- location.register:=left.location.register;
- cg.a_opmm_loc_reg(current_asmdata.CurrAsmList,op,
- tfloat2tcgsize[tfloatdef(tarraydef(left.resultdef).elementdef).floattype],right.location,location.register,nil);
+ if UseAVX then
+ begin
+ location.register:=cg.getmmregister(current_asmdata.CurrAsmList,OS_VECTOR);
+ cg.a_opmm_loc_reg_reg(current_asmdata.CurrAsmList,op,
+ tfloat2tcgsize[tfloatdef(tarraydef(left.resultdef).elementdef).floattype],right.location,left.location.register,location.register,nil);
+ end
+ else
+ begin
+ location.register:=left.location.register;
+ cg.a_opmm_loc_reg(current_asmdata.CurrAsmList,op,
+ tfloat2tcgsize[tfloatdef(tarraydef(left.resultdef).elementdef).floattype],right.location,location.register,nil);
+ end;
end;
end
else
diff --git a/packages/fcl-db/src/sqldb/interbase/fbadmin.pp b/packages/fcl-db/src/sqldb/interbase/fbadmin.pp
index 3dafa32e94..2366e83b97 100644
--- a/packages/fcl-db/src/sqldb/interbase/fbadmin.pp
+++ b/packages/fcl-db/src/sqldb/interbase/fbadmin.pp
@@ -392,13 +392,16 @@ end;
destructor TFBAdmin.Destroy;
begin
- if FSvcHandle<>FB_API_NULLHANDLE then
- begin
- WaitInterval:=100;
- DisConnect;
+ try
+ if FSvcHandle<>FB_API_NULLHANDLE then
+ begin
+ WaitInterval:=100;
+ DisConnect; // This can raise an exception
+ end;
+ Finally
+ FOutput.Destroy;
+ inherited Destroy;
end;
- FOutput.Destroy;
- inherited Destroy;
end;
function TFBAdmin.Connect: boolean;
diff --git a/packages/fcl-json/src/jsonreader.pp b/packages/fcl-json/src/jsonreader.pp
index bd1b601922..598331a0de 100644
--- a/packages/fcl-json/src/jsonreader.pp
+++ b/packages/fcl-json/src/jsonreader.pp
@@ -179,7 +179,8 @@ Resourcestring
SErrInvalidNumber = 'Number is not an integer or real number: %s';
SErrNoScanner = 'No scanner. No source specified ?';
SErrorAt = 'Error at line %d, Pos %d: ';
-
+ SErrGarbageFound = 'Expected EOF, but got %s';
+
{ TBaseJSONReader }
@@ -189,6 +190,14 @@ begin
if (FScanner=Nil) then
DoError(SErrNoScanner);
DoParse(False,True);
+ if joStrict in Options then
+ begin
+ Repeat
+ GetNextToken;
+ Until CurrentToken<>tkWhiteSpace;
+ If CurrentToken<>tkEOF then
+ DoError(Format(SErrGarbageFound,[CurrentTokenString]));
+ end;
end;
{
diff --git a/packages/fcl-json/src/jsonscanner.pp b/packages/fcl-json/src/jsonscanner.pp
index 45ef299ac2..5294e02ac6 100644
--- a/packages/fcl-json/src/jsonscanner.pp
+++ b/packages/fcl-json/src/jsonscanner.pp
@@ -169,6 +169,8 @@ constructor TJSONScanner.Create(const aSource: RawByteString; AOptions: TJSONOpt
begin
FSource:=aSource;
FCurPos:=PAnsiChar(FSource);
+ if FCurPos<>Nil then
+ FCurRow:=1;
FOptions:=AOptions;
end;
diff --git a/packages/fcl-json/tests/testjsonreader.pp b/packages/fcl-json/tests/testjsonreader.pp
index 132dbf4fe0..195041610a 100644
--- a/packages/fcl-json/tests/testjsonreader.pp
+++ b/packages/fcl-json/tests/testjsonreader.pp
@@ -75,6 +75,8 @@ type
procedure TestMixed;
Procedure TestComment;
procedure TestErrors;
+ procedure TestGarbageOK;
+ procedure TestGarbageFail;
end;
TTestReader = Class(TBaseTestReader)
@@ -450,6 +452,18 @@ begin
end;
+procedure TBaseTestReader.TestGarbageOK;
+begin
+ TestRead('"a"sss',['string:a']);
+ TestRead('[null]xxx',['sa','null','ea']);
+end;
+
+procedure TBaseTestReader.TestGarbageFail;
+begin
+ DoTestError('"a"sss',[joStrict]);
+ DoTestError('[null]aaa',[joStrict]);
+end;
+
procedure TBaseTestReader.CallNoHandlerStream;
diff --git a/packages/fcl-net/src/sslbase.pp b/packages/fcl-net/src/sslbase.pp
index dc93c670c8..13237744af 100644
--- a/packages/fcl-net/src/sslbase.pp
+++ b/packages/fcl-net/src/sslbase.pp
@@ -36,6 +36,7 @@ Type
Private
FStrData : Array[0..StrDataCount] of string;
FCertData : Array[0..SSLDataCount] of TSSLData;
+ FTrustedCertsDir: String;
function GetSSLData(AIndex: Integer): TSSLData;
procedure SetSSLData(AIndex: Integer; AValue: TSSLData);
function GetString(AIndex: Integer): String;
@@ -54,6 +55,8 @@ Type
property PrivateKey : TSSLData Index 2 Read GetSSLData Write SetSSLData;
property PFX: TSSLData Index 3 Read GetSSLData Write SetSSLData;
property CertCA: TSSLData Index 4 Read GetSSLData Write SetSSLData;
+ // OpenSSL allows both a PEM file or a Dir. We separate out the dir.
+ Property TrustedCertsDir : String Read FTrustedCertsDir Write FTrustedCertsDir;
end;
{ TX509Certificate }
diff --git a/packages/fcl-net/src/sslsockets.pp b/packages/fcl-net/src/sslsockets.pp
index 9d75856ade..7a4ae8ce5c 100644
--- a/packages/fcl-net/src/sslsockets.pp
+++ b/packages/fcl-net/src/sslsockets.pp
@@ -51,9 +51,12 @@ Type
protected
Procedure SetSSLActive(aValue : Boolean);
function DoVerifyCert: boolean; virtual; // if event define's change not accceptable, suggest to set virtual
+ Function GetLastSSLErrorString : String; virtual; abstract;
+ Function GetLastSSLErrorCode : Integer; virtual; abstract;
public
constructor Create; override;
Destructor Destroy; override;
+ Function GetLastErrorDescription : String;override;
// Class factory methods
Class Procedure SetDefaultHandlerClass(aClass : TSSLSocketHandlerClass);
Class Function GetDefaultHandlerClass : TSSLSocketHandlerClass;
@@ -64,6 +67,8 @@ Type
function CreateSelfSignedCertificate: Boolean; virtual;
Property CertGenerator : TX509Certificate Read FCertGenerator;
Property SSLActive: Boolean read FSSLActive;
+ Property LastSSLErrorString : String Read GetLastSSLErrorString;
+ Property LastSSLErrorCode : Integer Read GetLastSSLErrorCode;
published
property SSLType: TSSLType read FSSLType write FSSLType;
property VerifyPeerCert: Boolean read FVerifyPeerCert Write FVerifyPeerCert;
@@ -92,6 +97,7 @@ Resourcestring
'Please include opensslsockets unit in program and recompile it.';
SErrNoX509Certificate =
'Cannot create a X509 certificate without SLL support';
+ SSSLErrorCode = 'SSL error code: %d';
{ TSSLSocketHandler }
@@ -177,6 +183,19 @@ begin
inherited Destroy;
end;
+function TSSLSocketHandler.GetLastErrorDescription: String;
+begin
+ Result:='';
+ if LastSSLErrorCode<>0 then
+ Result:=Format(SSSLErrorCode,[GetLastSSLErrorCode]);
+ if LastSSLErrorString<>'' then
+ begin
+ if (Result<>'') then
+ Result:=Result+': ';
+ Result:=Result+LastSSLErrorString;
+ end;
+end;
+
class procedure TSSLSocketHandler.SetDefaultHandlerClass(aClass: TSSLSocketHandlerClass);
begin
FDefaultHandlerClass:=aClass;
diff --git a/packages/fcl-net/src/ssockets.pp b/packages/fcl-net/src/ssockets.pp
index 21a5ed83d9..973aea40e3 100644
--- a/packages/fcl-net/src/ssockets.pp
+++ b/packages/fcl-net/src/ssockets.pp
@@ -70,6 +70,8 @@ type
function Recv(Const Buffer; Count: Integer): Integer; virtual;
function Send(Const Buffer; Count: Integer): Integer; virtual;
function BytesAvailable: Integer; virtual;
+ // Call this to get extra error info.
+ Function GetLastErrorDescription : String; virtual;
Property Socket : TSocketStream Read FSocket;
Property LastError : Integer Read FLastError;
end;
@@ -289,7 +291,7 @@ resourcestring
strSocketCreationFailed = 'Creation of socket failed: %s';
strSocketBindFailed = 'Binding of socket failed: %s';
strSocketListenFailed = 'Listening on port #%d failed, error: %d';
- strSocketConnectFailed = 'Connect to %s failed.';
+ strSocketConnectFailed = 'Connect to %s failed: %s';
strSocketAcceptFailed = 'Could not accept a client connection on socket: %d, error %d';
strSocketAcceptWouldBlock = 'Accept would block on socket: %d';
strSocketIOTimeOut = 'Failed to set IO Timeout to %d';
@@ -380,6 +382,11 @@ begin
{ we need ioctlsocket here }
end;
+function TSocketHandler.GetLastErrorDescription: String;
+begin
+ Result:='';
+end;
+
Function TSocketHandler.Close: Boolean;
begin
@@ -401,7 +408,7 @@ begin
seAcceptFailed : s := strSocketAcceptFailed;
seAcceptWouldBLock : S := strSocketAcceptWouldBlock;
seIOTimeout : S := strSocketIOTimeOut;
- seConnectTimeOut : s := strSocketConnectTimeout;
+ seConnectTimeOut : s := strSocketConnectTimeout;
end;
s := Format(s, MsgArgs);
inherited Create(s);
@@ -1117,6 +1124,7 @@ Var
IsError : Boolean;
TimeOutResult : TCheckTimeOutResult;
Err: Integer;
+ aErrMsg : String;
{$IFDEF HAVENONBLOCKING}
FDS: TFDSet;
TimeV: TTimeVal;
@@ -1171,7 +1179,10 @@ begin
if TimeoutResult=ctrTimeout then
Raise ESocketError.Create(seConnectTimeOut, [Format('%s:%d',[FHost, FPort])])
else
- Raise ESocketError.Create(seConnectFailed, [Format('%s:%d',[FHost, FPort])]);
+ begin
+ aErrMsg:=FHandler.GetLastErrorDescription;
+ Raise ESocketError.Create(seConnectFailed, [Format('%s:%d',[FHost, FPort]),aErrMsg]);
+ end;
end;
{ ---------------------------------------------------------------------
@@ -1203,7 +1214,7 @@ Var
begin
Str2UnixSockAddr(FFilename,UnixAddr,AddrLen);
If FpConnect(ASocket,@UnixAddr,AddrLen)<>0 then
- Raise ESocketError.Create(seConnectFailed,[FFilename]);
+ Raise ESocketError.Create(seConnectFailed,[FFilename,'']);
end;
{$endif}
end.
diff --git a/packages/fcl-web/examples/httpclient/httpget.pas b/packages/fcl-web/examples/httpclient/httpget.pas
index 0fc118e695..3dbfc9001a 100644
--- a/packages/fcl-web/examples/httpclient/httpget.pas
+++ b/packages/fcl-web/examples/httpclient/httpget.pas
@@ -4,7 +4,7 @@ program httpget;
{$DEFINE USEGNUTLS}
uses
- SysUtils, Classes, fphttpclient,
+ SysUtils, Classes, fphttpclient, ssockets,
{$IFNDEF USEGNUTLS}
fpopenssl, opensslsockets,
{$else}
@@ -17,6 +17,9 @@ Type
{ TTestApp }
TTestApp = Class(Tobject)
+ private
+ procedure DoHaveSocketHandler(Sender: TObject; AHandler: TSocketHandler);
+ procedure DoVerifyCertificate(Sender: TObject; AHandler: TSSLSocketHandler; var aAllow: Boolean);
procedure DoProgress(Sender: TObject; Const ContentLength, CurrentPos : Int64);
procedure DoHeaders(Sender : TObject);
procedure DoPassword(Sender: TObject; var RepeatRequest: Boolean);
@@ -84,6 +87,7 @@ begin
Writeln('Following redirect from ',ASrc,' ==> ',ADest);
end;
+
procedure TTestApp.Run;
begin
@@ -99,6 +103,9 @@ begin
OnPassword:=@DoPassword;
OnDataReceived:=@DoProgress;
OnHeaders:=@DoHeaders;
+ VerifySSlCertificate:=True;
+ OnVerifySSLCertificate:=@DoVerifyCertificate;
+ AfterSocketHandlerCreate:=@DoHaveSocketHandler;
{ Set this if you want to try a proxy.
Proxy.Host:='195.207.46.20';
Proxy.Port:=8080;
@@ -109,6 +116,30 @@ begin
end;
end;
+procedure TTestApp.DoHaveSocketHandler(Sender: TObject; AHandler: TSocketHandler);
+
+Var
+ SSLHandler : TSSLSocketHandler absolute aHandler;
+
+begin
+ if (aHandler is TSSLSocketHandler) then
+ begin
+ SSLHandler.CertificateData.TrustedCertsDir:='/etc/ssl/certs/';
+ end
+end;
+
+procedure TTestApp.DoVerifyCertificate(Sender: TObject; AHandler: TSSLSocketHandler; var aAllow: Boolean);
+
+Var
+ S : String;
+
+begin
+ Writeln('SSL Certificate verification requested, allowing');
+ S:=TEncoding.ASCII.GetAnsiString( aHandler.CertificateData.Certificate.Value);
+ Writeln('Cert: ',S);
+ aAllow:=True;
+end;
+
begin
With TTestApp.Create do
try
diff --git a/packages/fcl-web/src/base/fphttpclient.pp b/packages/fcl-web/src/base/fphttpclient.pp
index ca535d7323..fdecc9e0af 100644
--- a/packages/fcl-web/src/base/fphttpclient.pp
+++ b/packages/fcl-web/src/base/fphttpclient.pp
@@ -14,17 +14,12 @@
**********************************************************************}
unit fphttpclient;
-{ ---------------------------------------------------------------------
- Todo:
- * Proxy support ?
- ---------------------------------------------------------------------}
-
{$mode objfpc}{$H+}
interface
uses
- Classes, SysUtils, ssockets, httpdefs, uriparser, base64;
+ Classes, SysUtils, ssockets, httpdefs, uriparser, base64, sslsockets;
Const
// Socket Read buffer size
@@ -42,6 +37,7 @@ Type
// Use this to set up a socket handler. UseSSL is true if protocol was https
TGetSocketHandlerEvent = Procedure (Sender : TObject; Const UseSSL : Boolean; Out AHandler : TSocketHandler) of object;
TSocketHandlerCreatedEvent = Procedure (Sender : TObject; AHandler : TSocketHandler) of object;
+ THTTPVerifyCertificateEvent = Procedure (Sender : TObject; AHandler : TSSLSocketHandler; var aAllow : Boolean) of object;
TFPCustomHTTPClient = Class;
@@ -79,6 +75,7 @@ Type
FOnHeaders: TNotifyEvent;
FOnPassword: TPasswordEvent;
FOnRedirect: TRedirectEvent;
+ FOnVerifyCertificate: THTTPVerifyCertificateEvent;
FPassword: String;
FIOTimeout: Integer;
FConnectTimeout: Integer;
@@ -98,6 +95,7 @@ Type
FOnGetSocketHandler : TGetSocketHandlerEvent;
FAfterSocketHandlerCreated : TSocketHandlerCreatedEvent;
FProxy : TProxyData;
+ FVerifySSLCertificate: Boolean;
function CheckContentLength: Int64;
function CheckTransferEncoding: string;
function GetCookies: TStrings;
@@ -113,7 +111,8 @@ Type
Procedure ExtractHostPort(AURI: TURI; Out AHost: String; Out APort: Word);
Procedure CheckConnectionCloseHeader;
protected
-
+ // Called with TSSLSocketHandler as sender
+ procedure DoVerifyCertificate(Sender: TObject; var Allow: Boolean); virtual;
Function NoContentAllowed(ACode : Integer) : Boolean;
// Peform a request, close connection.
Procedure DoNormalRequest(const AURI: TURI; const AMethod: string;
@@ -305,9 +304,6 @@ Type
// Maximum chunk size: If chunk sizes bigger than this are encountered, an error will be raised.
// Set to zero to disable the check.
Property MaxChunkSize : SizeUInt Read FMaxChunkSize Write FMaxChunkSize;
- // Called On redirect. Dest URL can be edited.
- // If The DEST url is empty on return, the method is aborted (with redirect status).
- Property OnRedirect : TRedirectEvent Read FOnRedirect Write FOnRedirect;
// Proxy support
Property Proxy : TProxyData Read GetProxy Write SetProxy;
// Authentication.
@@ -319,6 +315,11 @@ Type
Property Connected: Boolean read IsConnected;
// Keep-Alive support. Setting to true will set HTTPVersion to 1.1
Property KeepConnection: Boolean Read FKeepConnection Write SetKeepConnection;
+ // SSL certificate validation.
+ Property VerifySSLCertificate : Boolean Read FVerifySSLCertificate Write FVerifySSLCertificate;
+ // Called On redirect. Dest URL can be edited.
+ // If The DEST url is empty on return, the method is aborted (with redirect status).
+ Property OnRedirect : TRedirectEvent Read FOnRedirect Write FOnRedirect;
// If a request returns a 401, then the OnPassword event is fired.
// It can modify the username/password and set RepeatRequest to true;
Property OnPassword : TPasswordEvent Read FOnPassword Write FOnPassword;
@@ -330,6 +331,8 @@ Type
Property OnGetSocketHandler : TGetSocketHandlerEvent Read FOnGetSocketHandler Write FOnGetSocketHandler;
// Called after create socket handler was created, with the created socket handler.
Property AfterSocketHandlerCreate : TSocketHandlerCreatedEvent Read FAfterSocketHandlerCreated Write FAfterSocketHandlerCreated;
+ // Called when a SSL certificate must be verified.
+ Property OnVerifySSLCertificate : THTTPVerifyCertificateEvent Read FOnVerifyCertificate Write FOnVerifyCertificate;
end;
@@ -357,6 +360,10 @@ Type
Property OnHeaders;
Property OnGetSocketHandler;
Property Proxy;
+ Property VerifySSLCertificate;
+ Property AfterSocketHandlerCreate;
+ Property OnVerifySSLCertificate;
+
end;
EHTTPClient = Class(EHTTP);
@@ -366,8 +373,6 @@ Function DecodeURLElement(Const S : String) : String;
implementation
-uses sslsockets;
-
resourcestring
SErrInvalidProtocol = 'Invalid protocol : "%s"';
SErrReadingSocket = 'Error reading data from socket';
@@ -585,13 +590,21 @@ end;
function TFPCustomHTTPClient.GetSocketHandler(const UseSSL: Boolean): TSocketHandler;
+Var
+ SSLHandler : TSSLSocketHandler;
+
begin
Result:=Nil;
if Assigned(FonGetSocketHandler) then
FOnGetSocketHandler(Self,UseSSL,Result);
if (Result=Nil) then
If UseSSL then
- Result:=TSSLSocketHandler.GetDefaultHandler
+ begin
+ SSLHandler:=TSSLSocketHandler.GetDefaultHandler;
+ SSLHandler.VerifyPeerCert:=FVerifySSLCertificate;
+ SSLHandler.OnVerifyCertificate:=@DoVerifyCertificate;
+ Result:=SSLHandler;
+ end
else
Result:=TSocketHandler.Create;
if Assigned(AfterSocketHandlerCreate) then
@@ -945,6 +958,12 @@ begin
end;
end;
+procedure TFPCustomHTTPClient.DoVerifyCertificate(Sender: TObject; var Allow: Boolean);
+begin
+ If Assigned(FOnVerifyCertificate) then
+ FOnVerifyCertificate(Self,Sender as TSSLSocketHandler,Allow);
+end;
+
function TFPCustomHTTPClient.GetCookies: TStrings;
begin
If (FCookies=Nil) then
diff --git a/packages/fcl-web/src/base/fpjwt.pp b/packages/fcl-web/src/base/fpjwt.pp
index ccde8ee24b..1788c2fb62 100644
--- a/packages/fcl-web/src/base/fpjwt.pp
+++ b/packages/fcl-web/src/base/fpjwt.pp
@@ -128,7 +128,7 @@ Type
Destructor Destroy; override;
// Owned by the JWT. The JSON header.
Property JOSE : TJOSE Read FJOSE Write SetJOSE;
- // Owned by the JWT. The set of claims. The actuall class will depend on the descendant.
+ // Owned by the JWT. The set of claims. The actual class will depend on the descendant.
Property Claims : TClaims Read FClaims Write SetClaims;
Property Signature : String Read FSignature Write FSignature;
end;
diff --git a/packages/fcl-web/src/base/fpwebfile.pp b/packages/fcl-web/src/base/fpwebfile.pp
index 5dc5e7cde7..36bdc1b451 100644
--- a/packages/fcl-web/src/base/fpwebfile.pp
+++ b/packages/fcl-web/src/base/fpwebfile.pp
@@ -124,7 +124,7 @@ begin
else
begin
D:=ADirectory;
- if Copy(D,1,1)<>'/' then
+ if (D<>ExpandFileName(D)) then
D:=BaseDir+D;
if not DirectoryExists(D) then
Raise HTTPError.CreateFmt(SErrInvalidDirectory,[D]);
diff --git a/packages/gnutls/src/gnutlssockets.pp b/packages/gnutls/src/gnutlssockets.pp
index 9f47ded8c4..337264b625 100644
--- a/packages/gnutls/src/gnutlssockets.pp
+++ b/packages/gnutls/src/gnutlssockets.pp
@@ -40,6 +40,8 @@ Type
function InitSession(AsServer: Boolean): Boolean; virtual;
function DoneSession: Boolean; virtual;
function InitSslKeys: boolean;virtual;
+ function GetLastSSLErrorCode: Integer; override;
+ function GetLastSSLErrorString: String; override;
Public
Constructor create; override;
destructor destroy; override;
@@ -288,7 +290,7 @@ begin
exit;
Result:=DoHandShake;
if Result and VerifyPeerCert then
- Result:=(not DoVerifyCert);
+ Result:=DoVerifyCert;
if Result then
SetSSLActive(True);
end;
@@ -480,8 +482,8 @@ begin
Result:=LoadCertificate(CertificateData.Certificate,CertificateData.PrivateKey);
if Result and Not CertificateData.TrustedCertificate.Empty then
Result:=LoadTrustedCertificate(CertificateData.TrustedCertificate);
- if Result and (CertificateData.CertCA.FileName<>'') then
- Result:=Result and SetTrustedCertificateDir(CertificateData.CertCA.FileName);
+ if Result and (CertificateData.TrustedCertsDir<>'') then
+ Result:=Result and SetTrustedCertificateDir(CertificateData.TrustedCertsDir);
// If nothing was set, set defaults.
if not Assigned(FCred) then
begin
@@ -598,6 +600,16 @@ begin
Result:=FGNUTLSLastError;
end;
+function TGNUTLSSocketHandler.GetLastSSLErrorString: String;
+begin
+ Result:=FGNUTLSLastErrorString;
+end;
+
+function TGNUTLSSocketHandler.GetLastSSLErrorCode: Integer;
+begin
+ Result:=FGNUTLSLastError;
+end;
+
initialization
TSSLSocketHandler.SetDefaultHandlerClass(TGNUTLSSocketHandler);
end.
diff --git a/packages/openssl/src/opensslsockets.pp b/packages/openssl/src/opensslsockets.pp
index 3f1e254d26..9a8c84373f 100644
--- a/packages/openssl/src/opensslsockets.pp
+++ b/packages/openssl/src/opensslsockets.pp
@@ -25,6 +25,8 @@ Type
function InitContext(NeedCertificate: Boolean): Boolean; virtual;
function DoneContext: Boolean; virtual;
function InitSslKeys: boolean;virtual;
+ Function GetLastSSLErrorString : String; override;
+ Function GetLastSSLErrorCode : Integer; override;
Public
Constructor create; override;
destructor destroy; override;
@@ -171,12 +173,22 @@ begin
Result:=CheckSSL(FCTX.UseCertificate(CertificateData.Certificate));
if Result and not CertificateData.PrivateKey.Empty then
Result:=CheckSSL(FCTX.UsePrivateKey(CertificateData.PrivateKey));
- if Result and (CertificateData.CertCA.FileName<>'') then
- Result:=CheckSSL(FCTX.LoadVerifyLocations(CertificateData.CertCA.FileName,''));
+ if Result and ((CertificateData.CertCA.FileName<>'') or (CertificateData.TrustedCertsDir<>'')) then
+ Result:=CheckSSL(FCTX.LoadVerifyLocations(CertificateData.CertCA.FileName,CertificateData.TrustedCertsDir));
if Result and not CertificateData.PFX.Empty then
Result:=CheckSSL(FCTX.LoadPFX(CertificateData.PFX,CertificateData.KeyPassword));
end;
+function TOpenSSLSocketHandler.GetLastSSLErrorString: String;
+begin
+ Result:=FSSLLastErrorString;
+end;
+
+function TOpenSSLSocketHandler.GetLastSSLErrorCode: Integer;
+begin
+ Result:=FSSLLastError;
+end;
+
constructor TOpenSSLSocketHandler.create;
begin
inherited create;
diff --git a/rtl/inc/systemh.inc b/rtl/inc/systemh.inc
index b0124d0404..f056edd743 100644
--- a/rtl/inc/systemh.inc
+++ b/rtl/inc/systemh.inc
@@ -1293,7 +1293,9 @@ Function HexStr(Val:Pointer):shortstring;
{$endif CPUI8086}
{ Char functions }
+{$ifdef VER3_2}
Function Chr(b : byte) : Char; [INTERNPROC: fpc_in_chr_byte];
+{$endif VER3_2}
Function UpCase(c:Char):Char;
Function LowerCase(c:Char):Char; overload;
function Pos(const substr : shortstring;c:char; Offset: Sizeint = 1): SizeInt;
diff --git a/rtl/sinclairql/qdos.inc b/rtl/sinclairql/qdos.inc
new file mode 100644
index 0000000000..2216f051d6
--- /dev/null
+++ b/rtl/sinclairql/qdos.inc
@@ -0,0 +1,91 @@
+{
+ This file is part of the Free Pascal run time library.
+ Copyright (c) 2020 by Karoly Balogh
+
+ Interface QDOS OS functions used by the Sinclair QL RTL
+
+ See the file COPYING.FPC, included in this distribution,
+ for details about the copyright.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+{$i qdosh.inc}
+
+const
+ _MT_ALCHP = $18;
+ _MT_RECHP = $19;
+
+function mt_alchp(size: dword; sizegot: pdword; jobid: Tjobid): pointer; assembler; nostackframe; public name '_mt_alchp';
+asm
+ movem.l d2-d3/a2-a3,-(sp)
+ move.l sizegot,-(sp)
+ move.l jobid,d2
+ move.l size,d1
+ moveq.l #_MT_ALCHP,d0
+ trap #1
+ move.l (sp)+,d2 // sizegot ptr
+ tst d0
+ bne @quit
+ move.l d2,a1
+ beq @nosizegot
+ move.l d1,(a1)
+@nosizegot:
+ move.l a0,d0
+@quit:
+ movem.l (sp)+,d2-d3/a2-a3
+end;
+
+procedure mt_rechp(area: pointer); assembler; nostackframe; public name '_mt_rechp';
+asm
+ movem.l d2-d3/a2-a3,-(sp)
+ move.l area,a0
+ moveq.l #_MT_RECHP,d0
+ trap #1
+ movem.l (sp)+,d2-d3/a2-a3
+end;
+
+
+const
+ _IO_SBYTE = $05;
+ _IO_SSTRG = $07;
+
+function io_sbyte(chan: Tchanid; timeout: Ttimeout; c: char): longint; assembler; public name '_io_sbyte';
+asm
+ move.l d3,-(sp)
+ move.w timeout,d3
+ clr.l d1
+ move.b c,d1
+ move.l chan,a0
+ moveq.l #_IO_SBYTE,d0
+ trap #3
+ move.l (sp)+,d3
+end;
+
+function io_sstrg(chan: Tchanid; timeout: Ttimeout; buf: pointer; len: smallint): smallint; assembler; public name '_io_sstrg';
+asm
+ movem.l d2-d3,-(sp)
+ move.w len,d2
+ move.l buf,a1
+ move.w timeout,d3
+ move.l chan,a0
+ moveq.l #_IO_SSTRG,d0
+ trap #3
+ tst.l d0
+ beq @ok
+ cmp.w #ERR_EF,d0
+ beq @eof
+ cmp.w #ERR_NC,d0
+ bne @quit
+@eof:
+ tst.w d1
+ beq @quit
+@ok:
+ clr.l d0
+ move.w d1,d0
+@quit:
+ movem.l (sp)+,d2-d3
+end;
diff --git a/rtl/sinclairql/qdosfuncs.inc b/rtl/sinclairql/qdosfuncs.inc
new file mode 100644
index 0000000000..a0f0363e8d
--- /dev/null
+++ b/rtl/sinclairql/qdosfuncs.inc
@@ -0,0 +1,22 @@
+{
+ This file is part of the Free Pascal run time library.
+ Copyright (c) 2020 by Karoly Balogh
+
+ Headers to QDOS OS functions used by the Sinclair QL RTL
+
+ See the file COPYING.FPC, included in this distribution,
+ for details about the copyright.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+{$i qdosh.inc}
+
+function mt_alchp(size: dword; sizegot: pdword; jobid: Tjobid): pointer; external name '_mt_alchp';
+procedure mt_rechp(area: pointer); external name '_mt_rechp';
+
+function io_sbyte(chan: Tchanid; timeout: Ttimeout; c: char): longint; external name '_io_sbyte';
+function io_sstrg(chan: Tchanid; timeout: Ttimeout; buf: pointer; len: smallint): smallint; external name '_io_sstrg';
diff --git a/rtl/sinclairql/qdosh.inc b/rtl/sinclairql/qdosh.inc
new file mode 100644
index 0000000000..8010d9951f
--- /dev/null
+++ b/rtl/sinclairql/qdosh.inc
@@ -0,0 +1,43 @@
+{
+ This file is part of the Free Pascal run time library.
+ Copyright (c) 2020 by Karoly Balogh
+
+ Types and Constants used by QDOS OS functions in the Sinclair QL RTL
+
+ See the file COPYING.FPC, included in this distribution,
+ for details about the copyright.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+type
+ Tchanid = longint;
+ Tjobid = longint;
+ Ttimeout = smallint;
+
+
+const
+ ERR_NC = -1; { Operation not complete }
+ ERR_NJ = -2; { Not a (valid) job. }
+ ERR_OM = -3; { Out of memory. }
+ ERR_OR = -4; { Out of range. }
+ ERR_BO = -5; { Buffer overflow. }
+ ERR_NO = -6; { Channel not open. }
+ ERR_NF = -7; { File or device not found. }
+ ERR_FX = -8; { File already exists. }
+ ERR_IU = -9; { File or device already in use. }
+ ERR_EF = -10; { End of file. }
+ ERR_DF = -11; { Drive full. }
+ ERR_BN = -12; { Bad device. }
+ ERR_TE = -13; { Transmission error. }
+ ERR_FF = -14; { Format failed. }
+ ERR_BP = -15; { Bad parameter. }
+ ERR_FE = -16; { File error. }
+ ERR_EX = -17; { Expression error. }
+ ERR_OV = -18; { Arithmetic overflow. }
+ ERR_NI = -19; { Not implemented. }
+ ERR_RO = -20; { Read only. }
+ ERR_BL = -21; { Bad line of Basic. }
diff --git a/rtl/sinclairql/si_prc.pp b/rtl/sinclairql/si_prc.pp
index 0b87e59aad..d934adbd20 100644
--- a/rtl/sinclairql/si_prc.pp
+++ b/rtl/sinclairql/si_prc.pp
@@ -19,23 +19,79 @@ interface
implementation
+{$i qdosfuncs.inc}
+
var
- procdesc: PPD; public name '__base';
stacktop: pointer;
+ stackorig: pointer;
+ setjmpbuf: jmp_buf;
stklen: longint; external name '__stklen';
+ binstart: pointer; external name '_stext';
+ binend: pointer; external name '_etext';
procedure PascalMain; external name 'PASCALMAIN';
-
{ this function must be the first in this unit which contains code }
{$OPTIMIZATION OFF}
-procedure _FPC_proc_start(pd: PPD); cdecl; public name '_start';
+function _FPC_proc_start: longint; cdecl; public name '_start';
+var
+ newstack: pointer;
begin
+ _FPC_proc_start:=0;
+ asm
+ move.l d7,-(sp)
+ { relocation code }
+
+ { get our actual position in RAM }
+ lea.l binstart(pc),a0
+ move.l a0,d0
+ { get an offset to the end of the binary. this depends on the
+ fact that at this point the binary is not relocated yet }
+ lea.l binend,a1
+ add.l d0,a1
+
+ { first item in the relocation table is the number of relocs }
+ move.l (a1),d7
+ beq @noreloc
+
+ { zero out the number of relocs in RAM, so if our code is
+ called again, without reload, it won't relocate itself twice }
+ move.l #0,(a1)+
+@relocloop:
+ { we read the offsets and relocate them }
+ move.l (a1)+,d1
+ add.l d0,(a0,d1)
+ subq.l #1,d7
+ bne @relocloop
+
+@noreloc:
+ move.l (sp)+,d7
+
+ { save the original stack pointer }
+ move.l a7,stackorig
+ end;
+
+ newstack:=mt_alchp(stklen,nil,-1);
+ if not assigned(newstack) then
+ _FPC_proc_start:=ERR_OM
+ else
+ begin
+ asm
+ move.l newstack,sp
+ end;
+ if setjmp(setjmpbuf) = 0 then
+ PascalMain;
+ asm
+ move.l stackorig,sp
+ end;
+ mt_rechp(newstack);
+ end;
end;
-procedure _FPC_proc_halt(_ExitCode: longint); cdecl; public name '_haltproc';
+procedure _FPC_proc_halt(_ExitCode: longint); public name '_haltproc';
begin
+ longjmp(setjmpbuf,1);
end;
diff --git a/rtl/sinclairql/sysheap.inc b/rtl/sinclairql/sysheap.inc
index b980279b53..0e6daf4b0c 100644
--- a/rtl/sinclairql/sysheap.inc
+++ b/rtl/sinclairql/sysheap.inc
@@ -18,12 +18,15 @@
****************************************************************************}
+
function SysOSAlloc(size: ptruint): pointer;
begin
+ Result:=mt_alchp(size, nil, -1);
end;
{$define HAS_SYSOSFREE}
procedure SysOSFree(p: pointer; size: ptruint);
begin
+ mt_rechp(p);
end;
diff --git a/rtl/sinclairql/sysos.inc b/rtl/sinclairql/sysos.inc
index 53aa04fe37..94c7af10a2 100644
--- a/rtl/sinclairql/sysos.inc
+++ b/rtl/sinclairql/sysos.inc
@@ -15,6 +15,8 @@
**********************************************************************}
+{$i qdos.inc}
+
procedure Error2InOutRes(errno: longint);
begin
end;
diff --git a/rtl/sinclairql/system.pp b/rtl/sinclairql/system.pp
index 57260048e8..a7eaca656a 100644
--- a/rtl/sinclairql/system.pp
+++ b/rtl/sinclairql/system.pp
@@ -122,8 +122,12 @@ var
{*****************************************************************************
System Dependent Exit code
*****************************************************************************}
+
+procedure haltproc(e:longint); external name '_haltproc';
+
procedure system_exit;
begin
+ haltproc(exitcode);
end;
{*****************************************************************************
@@ -146,6 +150,19 @@ begin
CheckInitialStkLen := StkLen;
end;
+procedure PrintStr(const s: shortstring);
+begin
+ io_sstrg($00010001,-1,@s[1],ord(s[0]));
+end;
+
+procedure PrintStr2(const s: shortstring);
+var
+ i: smallint;
+begin
+ for i:=1 to ord(s[0]) do
+ io_sbyte($00010001,-1,s[i]);
+end;
+
begin
StackLength := CheckInitialStkLen (InitialStkLen);
@@ -160,7 +177,7 @@ begin
InitUnicodeStringManager;
{$endif FPC_HAS_FEATURE_UNICODESTRINGS}
{ Setup stdin, stdout and stderr }
- SysInitStdIO;
+(* SysInitStdIO;*)
{ Reset IO Error }
InOutRes:=0;
{ Setup command line arguments }
diff --git a/rtl/unix/timezone.inc b/rtl/unix/timezone.inc
index 4db0de669f..24f9aa07fa 100644
--- a/rtl/unix/timezone.inc
+++ b/rtl/unix/timezone.inc
@@ -104,7 +104,7 @@ begin
end;
-procedure DoGetLocalTimezone(info:pttinfo;const trans_start,trans_end:longint;var ATZInfo:TTZInfo);
+procedure DoGetLocalTimezone(info:pttinfo;const trans_start,trans_end:int64;var ATZInfo:TTZInfo);
begin
ATZInfo.validsince:=trans_start;
ATZInfo.validuntil:=trans_end;
diff --git a/tests/webtbs/tw38051.pp b/tests/webtbs/tw38051.pp
new file mode 100644
index 0000000000..5d54bcb0dc
--- /dev/null
+++ b/tests/webtbs/tw38051.pp
@@ -0,0 +1,21 @@
+{ %NORUN }
+
+program tw38051;
+
+const cChr = chr(12); { Ok }
+
+type Tcha = ord(3)..ord(12); { Ok }
+type Tchz = 0000003..0000012; { Ok }
+type Tcho = char(3)..char(12);{ Ok }
+type Tchr = chr(3)..chr(12); { Error: Identifier not found "chr" }
+
+type TArrChr = array [chr(3)..chr(12)] of char; { Ok }
+
+var cz : 0000003..0000012; { Ok }
+var ch : chr(3)..chr(12); { Error: Identifier not found "chr" }
+
+
+var c : char;
+begin
+ c:=chr(12); { Ok }
+end.
diff --git a/tests/webtbs/tw38054.pp b/tests/webtbs/tw38054.pp
new file mode 100644
index 0000000000..1012c41810
--- /dev/null
+++ b/tests/webtbs/tw38054.pp
@@ -0,0 +1,12 @@
+{ %norun }
+const
+ l = high(ptrint); // 2000 <--> 2100
+type
+ t = array[ 1..l ]of int8; // 1.95 <--> 2.05 GiBy
+var
+ p: ^t;
+begin
+ new(p);
+ writeln( sizeof(p^) );
+ p^[l]:=0; writeln(p^[l])
+end .