* synchronized with trunk

git-svn-id: branches/wasm@47357 -

.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

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

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;
 

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

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;

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

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;
 

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;

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.

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

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;

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

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;
 

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;
 

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 }

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;

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.

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

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

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;

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

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.

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;

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;

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;

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

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

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;
 
 

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;

rtl/sinclairql/sysos.inc

@@ -15,6 +15,8 @@
 
  **********************************************************************}
 
+{$i qdos.inc}
+
 procedure Error2InOutRes(errno: longint);
 begin
 end;

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 }

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;

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.

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 .