diff options
Diffstat (limited to 'rtl')
| -rw-r--r-- | rtl/aarch64/math.inc | 15 | ||||
| -rw-r--r-- | rtl/aarch64/mathu.inc | 16 | ||||
| -rw-r--r-- | rtl/darwin/Makefile | 2 | ||||
| -rw-r--r-- | rtl/darwin/Makefile.fpc | 2 | ||||
| -rw-r--r-- | rtl/objpas/sysutils/dati.inc | 12 | ||||
| -rw-r--r-- | rtl/objpas/sysutils/filutilh.inc | 2 | ||||
| -rw-r--r-- | rtl/objpas/sysutils/osutil.inc | 2 | ||||
| -rw-r--r-- | rtl/sinclairql/buildrtl.pp | 7 | ||||
| -rw-r--r-- | rtl/sinclairql/classes.pp | 50 | ||||
| -rw-r--r-- | rtl/sinclairql/si_prc.pp | 2 | ||||
| -rw-r--r-- | rtl/sinclairql/sysutils.pp | 501 | ||||
| -rw-r--r-- | rtl/win/sysutils.pp | 13 |
12 files changed, 597 insertions, 27 deletions
diff --git a/rtl/aarch64/math.inc b/rtl/aarch64/math.inc index 8be40b21a8..6bdaebbcff 100644 --- a/rtl/aarch64/math.inc +++ b/rtl/aarch64/math.inc @@ -51,6 +51,19 @@ {$endif FPC_SYSTEM_HAS_SQRT} +{$ifndef VER3_2} + {$ifndef FPC_SYSTEM_HAS_FRAC} + {$define FPC_SYSTEM_HAS_FRAC} + function fpc_frac_real(d : ValReal) : ValReal;compilerproc; + begin + { Function is handled internal in the compiler } + runerror(207); + result:=0; + end; + {$endif FPC_SYSTEM_HAS_FRAC} +{$endif VER3_2} + + {$ifndef FPC_SYSTEM_HAS_INT} {$define FPC_SYSTEM_HAS_INT} function fpc_int_real(d : ValReal) : ValReal;assembler;nostackframe;compilerproc; @@ -82,5 +95,3 @@ fcvtzs x0,d0 end; {$endif FPC_SYSTEM_HAS_ROUND} - - diff --git a/rtl/aarch64/mathu.inc b/rtl/aarch64/mathu.inc index f55471e963..5e1235171c 100644 --- a/rtl/aarch64/mathu.inc +++ b/rtl/aarch64/mathu.inc @@ -14,25 +14,25 @@ {$asmmode gas} -function getfpcr: dword; nostackframe; assembler; +function getfpcr: qword; nostackframe; assembler; asm mrs x0,fpcr end; -procedure setfpcr(val: dword); nostackframe; assembler; +procedure setfpcr(val: qword); nostackframe; assembler; asm msr fpcr,x0 end; -function getfpsr: dword; nostackframe; assembler; +function getfpsr: qword; nostackframe; assembler; asm mrs x0,fpsr end; -procedure setfpsr(val: dword); nostackframe; assembler; +procedure setfpsr(val: qword); nostackframe; assembler; asm msr fpsr, x0 end; @@ -75,7 +75,7 @@ const fpu_ufe = 1 shl 11; fpu_ixe = 1 shl 12; fpu_ide = 1 shl 15; - fpu_exception_mask = fpu_ioe or fpu_dze or fpu_ofe or fpu_ufe or fpu_ixe or fpu_ide; + fpu_exception_mask = qword(fpu_ioe or fpu_dze or fpu_ofe or fpu_ufe or fpu_ixe or fpu_ide); fpu_exception_mask_to_status_mask_shift = 8; @@ -111,13 +111,13 @@ function GetExceptionMask: TFPUExceptionMask; function SetExceptionMask(const Mask: TFPUExceptionMask): TFPUExceptionMask; var - newfpcr: dword; + newfpcr: qword; begin { clear "exception happened" flags } ClearExceptions(false); softfloat_exception_mask:=mask; - { at least the ThunderX AArch64 support apperently hardware exceptions, + { at least the ThunderX AArch64 support apparently hardware exceptions, so set fpcr correctly, thought it might be WI on most implementations it does not hurt } newfpcr:=fpu_exception_mask; @@ -143,7 +143,7 @@ function SetExceptionMask(const Mask: TFPUExceptionMask): TFPUExceptionMask; procedure ClearExceptions(RaisePending: Boolean); var - fpsr: dword; + fpsr: qword; f: TFPUException; begin fpsr:=getfpsr; diff --git a/rtl/darwin/Makefile b/rtl/darwin/Makefile index ec43154a29..18ad8c7628 100644 --- a/rtl/darwin/Makefile +++ b/rtl/darwin/Makefile @@ -3293,7 +3293,7 @@ include $(INC)/makefile.inc SYSINCDEPS=$(addprefix $(INC)/,$(SYSINCNAMES)) include $(PROCINC)/makefile.cpu SYSCPUDEPS=$(addprefix $(PROCINC)/,$(CPUINCNAMES)) -SYSDEPS=$(SYSINCDEPS) $(SYSCPUDEPS) +SYSDEPS=$(SYSINCDEPS) $(SYSCPUDEPS) sighnd.inc sig_cpu.inc $(SYSTEMUNIT)$(PPUEXT) : $(BSDINC)/$(SYSTEMUNIT).pp $(SYSDEPS) $(COMPILER) $(FPC_SYSTEM_OPT) -Us -Sg $(BSDINC)/$(SYSTEMUNIT).pp sysinit$(PPUEXT) : sysinit.pas $(SYSTEMUNIT)$(PPUEXT) diff --git a/rtl/darwin/Makefile.fpc b/rtl/darwin/Makefile.fpc index 1a0e19d6a3..42a2ebaa9d 100644 --- a/rtl/darwin/Makefile.fpc +++ b/rtl/darwin/Makefile.fpc @@ -116,7 +116,7 @@ include $(PROCINC)/makefile.cpu SYSCPUDEPS=$(addprefix $(PROCINC)/,$(CPUINCNAMES)) # Put system unit dependencies together. -SYSDEPS=$(SYSINCDEPS) $(SYSCPUDEPS) +SYSDEPS=$(SYSINCDEPS) $(SYSCPUDEPS) sighnd.inc sig_cpu.inc # diff --git a/rtl/objpas/sysutils/dati.inc b/rtl/objpas/sysutils/dati.inc index 19848e57bf..667d7c1360 100644 --- a/rtl/objpas/sysutils/dati.inc +++ b/rtl/objpas/sysutils/dati.inc @@ -75,18 +75,20 @@ end; { MSecsToTimeStamp } function MSecsToTimeStamp(MSecs: comp): TTimeStamp; +var + D1:Int64; begin - result.Date := Trunc(msecs / msecsperday); - msecs:= msecs-comp(result.date)*msecsperday; - result.Time := Round(MSecs); -end ; + D1:=Trunc(msecs); + result.Date := D1 div msecsperday; + result.Time := D1 - result.date * msecsperday; +end; { TimeStampToMSecs } function TimeStampToMSecs(const TimeStamp: TTimeStamp): comp; begin result := TimeStamp.Time + comp(timestamp.date)*msecsperday; -end ; +end; Function TryEncodeDate(Year,Month,Day : Word; Out Date : TDateTime) : Boolean; diff --git a/rtl/objpas/sysutils/filutilh.inc b/rtl/objpas/sysutils/filutilh.inc index 8fef58596d..afe45a6666 100644 --- a/rtl/objpas/sysutils/filutilh.inc +++ b/rtl/objpas/sysutils/filutilh.inc @@ -17,7 +17,7 @@ Type // Some operating systems need FindHandle to be a Pointer -{$if defined(unix) or defined(msdos) or defined(hasamiga) or defined(atari) or defined(win16)} +{$if defined(unix) or defined(msdos) or defined(hasamiga) or defined(atari) or defined(win16) or defined(sinclairql)} {$define FINDHANDLE_IS_POINTER} {$endif} diff --git a/rtl/objpas/sysutils/osutil.inc b/rtl/objpas/sysutils/osutil.inc index ffa7531efd..729f96d285 100644 --- a/rtl/objpas/sysutils/osutil.inc +++ b/rtl/objpas/sysutils/osutil.inc @@ -245,7 +245,7 @@ begin Repeat Result:=Format('%s%.5d.tmp',[Start,I]); Inc(I); - Until not FileExists(Result); + Until not (FileExists(Result) or DirectoryExists(Result)); end; end; {$endif} diff --git a/rtl/sinclairql/buildrtl.pp b/rtl/sinclairql/buildrtl.pp index ec7f7d0b48..36d1352544 100644 --- a/rtl/sinclairql/buildrtl.pp +++ b/rtl/sinclairql/buildrtl.pp @@ -4,11 +4,12 @@ unit buildrtl; uses si_prc, + sysutils, ctypes, strings, - rtlconsts, {sysconst,} {math,} {types,} - {typinfo,} sortbase, {fgl,} {classes,} - charset, {character,} {getopts,} + rtlconsts, sysconst, math, types, + typinfo, sortbase, fgl, classes, + charset, character, getopts, fpwidestring; implementation diff --git a/rtl/sinclairql/classes.pp b/rtl/sinclairql/classes.pp new file mode 100644 index 0000000000..ca7f60f810 --- /dev/null +++ b/rtl/sinclairql/classes.pp @@ -0,0 +1,50 @@ +{ + This file is part of the Free Component Library (FCL) + Copyright (c) 2021 by the Free Pascal development team + + Classes unit for the Sinclair QL + + 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. + + **********************************************************************} + +{$mode objfpc} + +{ determine the type of the resource/form file } +{$define Win16Res} + +unit Classes; + +interface + +uses + sysutils, + rtlconsts, + types, + sortbase, +{$ifdef FPC_TESTGENERICS} + fgl, +{$endif} + typinfo; + +{$i classesh.inc} + + +implementation + +{ OS - independent class implementations are in /inc directory. } +{$i classes.inc} + + +initialization + CommonInit; + +finalization + CommonCleanup; + +end. diff --git a/rtl/sinclairql/si_prc.pp b/rtl/sinclairql/si_prc.pp index 0d4133ee82..95993c65fe 100644 --- a/rtl/sinclairql/si_prc.pp +++ b/rtl/sinclairql/si_prc.pp @@ -107,7 +107,7 @@ asm add.l d1,d2 add.l d0,(a0,d2) subq.l #1,d7 - bpl @relocloop + bgt @relocloop {$ENDIF PACKEDRELOCS} @noreloc: diff --git a/rtl/sinclairql/sysutils.pp b/rtl/sinclairql/sysutils.pp new file mode 100644 index 0000000000..bd45660a8b --- /dev/null +++ b/rtl/sinclairql/sysutils.pp @@ -0,0 +1,501 @@ +{ + This file is part of the Free Pascal run time library. + Copyright (c) 2021 by Free Pascal development team + + Sysutils unit for Sinclair QL + + 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. + + **********************************************************************} + +unit sysutils; + +interface + +{$MODE objfpc} +{$MODESWITCH OUT} +{ force ansistrings } +{$H+} +{$modeswitch typehelpers} +{$modeswitch advancedrecords} + +{$DEFINE OS_FILESETDATEBYNAME} +{$DEFINE HAS_SLEEP} +{$DEFINE HAS_OSERROR} + +{OS has only 1 byte version for ExecuteProcess} +{$define executeprocuni} + +{ used OS file system APIs use ansistring } +{$define SYSUTILS_HAS_ANSISTR_FILEUTIL_IMPL} +{ OS has an ansistring/single byte environment variable API } +{$define SYSUTILS_HAS_ANSISTR_ENVVAR_IMPL} + +{ Include platform independent interface part } +{$i sysutilh.inc} + +{ Platform dependent calls } + + +implementation + +uses + sysconst; + +{$DEFINE FPC_FEXPAND_UNC} (* UNC paths are supported *) +{$DEFINE FPC_FEXPAND_DRIVES} (* Full paths begin with drive specification *) + +{ Include platform independent implementation part } +{$i sysutils.inc} + +{$i qdosfuncs.inc} +{$i smsfuncs.inc} + +{**************************************************************************** + File Functions +****************************************************************************} +{$I-}{ Required for correct usage of these routines } + + +(****** non portable routines ******) + +function FileOpen(const FileName: rawbytestring; Mode: Integer): THandle; +begin + FileOpen:=-1; + if FileOpen < -1 then + FileOpen:=-1; +end; + + +function FileGetDate(Handle: THandle) : Int64; +begin + result:=-1; +end; + + +function FileSetDate(Handle: THandle; Age: Int64) : LongInt; +begin + result:=0; +end; + + +function FileSetDate(const FileName: RawByteString; Age: Int64) : LongInt; +var + f: THandle; +begin + result:=-1; + f:=FileOpen(FileName,fmOpenReadWrite); + if f < 0 then + exit; + result:=FileSetDate(f,Age); + FileClose(f); +end; + + +function FileCreate(const FileName: RawByteString) : THandle; +begin + FileCreate:=-1; + if FileCreate < -1 then + FileCreate:=-1; +end; + +function FileCreate(const FileName: RawByteString; Rights: integer): THandle; +begin + { Rights don't exist on the QL, so we simply map this to FileCreate() } + FileCreate:=FileCreate(FileName); +end; + +function FileCreate(const FileName: RawByteString; ShareMode: integer; Rights : integer): THandle; +begin + { Rights and ShareMode don't exist on the QL so we simply map this to FileCreate() } + FileCreate:=FileCreate(FileName); +end; + + +function FileRead(Handle: THandle; out Buffer; Count: LongInt): LongInt; +begin + FileRead:=-1; + if (Count<=0) then + exit; + + FileRead:=-1; + if FileRead < -1 then + FileRead:=-1; +end; + + +function FileWrite(Handle: THandle; const Buffer; Count: LongInt): LongInt; +begin + FileWrite:=-1; + if (Count<=0) then + exit; + + FileWrite:=-1; + if FileWrite < -1 then + FileWrite:=-1; +end; + + +function FileSeek(Handle: THandle; FOffset, Origin: LongInt) : LongInt; +var + dosResult: longint; +begin + FileSeek:=-1; + + dosResult:=-1; + if dosResult < 0 then + exit; + + FileSeek:=dosResult; +end; + +function FileSeek(Handle: THandle; FOffset: Int64; Origin: Longint): Int64; +begin + FileSeek:=FileSeek(Handle,LongInt(FOffset),Origin); +end; + + +procedure FileClose(Handle: THandle); +begin +end; + + +function FileTruncate(Handle: THandle; Size: Int64): Boolean; +begin + FileTruncate:=False; +end; + + +function DeleteFile(const FileName: RawByteString) : Boolean; +begin + DeleteFile:=false; +end; + + +function RenameFile(const OldName, NewName: RawByteString): Boolean; +begin + RenameFile:=false; +end; + + + +(****** end of non portable routines ******) + + +function FileAge (const FileName : RawByteString): Int64; +var + f: THandle; +begin + FileAge:=-1; + f:=FileOpen(FileName,fmOpenRead); + if f < 0 then + exit; + FileAge:=FileGetDate(f); + FileClose(f); +end; + + +function FileGetSymLinkTarget(const FileName: RawByteString; out SymLinkRec: TRawbyteSymLinkRec): Boolean; +begin + Result := False; +end; + + +function FileExists (const FileName : RawByteString; FollowLink : Boolean) : Boolean; +var + Attr: longint; +begin + FileExists:=false; + Attr:=FileGetAttr(FileName); + if Attr < 0 then + exit; + + result:=(Attr and (faVolumeID or faDirectory)) = 0; +end; + + +type + PInternalFindData = ^TInternalFindData; + TInternalFindData = record + dummy: pointer; + end; + + +Function InternalFindFirst (Const Path : RawByteString; Attr : Longint; out Rslt : TAbstractSearchRec; var Name: RawByteString) : Longint; +var + dosResult: longint; + IFD: PInternalFindData; +begin + result:=-1; { We emulate Linux/Unix behaviour, and return -1 on errors. } + + new(IFD); + IFD^.dummy:=nil; + + Rslt.FindHandle:=nil; + dosResult:=-1; { add findfirst here } + if dosResult < 0 then + begin + InternalFindClose(IFD); + exit; + end; + + Rslt.FindHandle:=IFD; + + Name:=''; + SetCodePage(Name,DefaultFileSystemCodePage,false); + + Rslt.Time:=0; + Rslt.Size:=0; + + { "128" is Windows "NORMALFILE" attribute. Some buggy code depend on this... :( (KB) } + Rslt.Attr := 128 or 0; + + result:=0; +end; + + +Function InternalFindNext (var Rslt : TAbstractSearchRec; var Name : RawByteString) : Longint; +var + dosResult: longint; + IFD: PInternalFindData; +begin + result:=-1; + IFD:=PInternalFindData(Rslt.FindHandle); + if not assigned(IFD) then + exit; + + dosResult:=-1; + if dosResult < 0 then + exit; + + Name:=''; + SetCodePage(Name,DefaultFileSystemCodePage,false); + + Rslt.Time:=0; + Rslt.Size:=0; + + { "128" is Windows "NORMALFILE" attribute. Some buggy code depend on this... :( (KB) } + Rslt.Attr := 128 or 0; + + result:=0; +end; + + +Procedure InternalFindClose(var Handle: Pointer); +var + IFD: PInternalFindData; +begin + IFD:=PInternalFindData(Handle); + if not assigned(IFD) then + exit; + + dispose(IFD); +end; + + +(****** end of non portable routines ******) + +Function FileGetAttr (Const FileName : RawByteString) : Longint; +begin + FileGetAttr:=0; +end; + + +Function FileSetAttr (Const Filename : RawByteString; Attr: longint) : Longint; +begin + FileSetAttr:=-1; + + if FileSetAttr < -1 then + FileSetAttr:=-1 + else + FileSetAttr:=0; +end; + + + +{**************************************************************************** + Disk Functions +****************************************************************************} + +function DiskSize(Drive: Byte): Int64; +var + dosResult: longint; +begin + DiskSize := -1; + + dosResult:=-1; + if dosResult < 0 then + exit; + + DiskSize:=0; +end; + +function DiskFree(Drive: Byte): Int64; +var + dosResult: longint; +begin + DiskFree := -1; + + dosResult:=-1; + if dosResult < 0 then + exit; + + DiskFree:=0; +end; + +function DirectoryExists(const Directory: RawByteString; FollowLink : Boolean): Boolean; +var + Attr: longint; +begin + DirectoryExists:=false; + Attr:=FileGetAttr(Directory); + if Attr < 0 then + exit; + + result:=(Attr and faDirectory) <> 0; +end; + + + +{**************************************************************************** + Locale Functions +****************************************************************************} + +Procedure GetLocalTime(var SystemTime: TSystemTime); +begin + DateTimeToSystemTime(FileDateToDateTime(0),SystemTime); +end; + + +Procedure InitAnsi; +Var + i : longint; +begin + { Fill table entries 0 to 127 } + for i := 0 to 96 do + UpperCaseTable[i] := chr(i); + for i := 97 to 122 do + UpperCaseTable[i] := chr(i - 32); + for i := 123 to 191 do + UpperCaseTable[i] := chr(i); + Move (CPISO88591UCT,UpperCaseTable[192],SizeOf(CPISO88591UCT)); + + for i := 0 to 64 do + LowerCaseTable[i] := chr(i); + for i := 65 to 90 do + LowerCaseTable[i] := chr(i + 32); + for i := 91 to 191 do + LowerCaseTable[i] := chr(i); + Move (CPISO88591LCT,UpperCaseTable[192],SizeOf(CPISO88591UCT)); +end; + + +Procedure InitInternational; +begin + InitInternationalGeneric; + InitAnsi; +end; + +function SysErrorMessage(ErrorCode: Integer): String; +begin + Result:=Format(SUnknownErrorCode,[ErrorCode]); +end; + +function GetLastOSError: Integer; +begin + result:=-1; +end; + +{**************************************************************************** + OS utility functions +****************************************************************************} + +function GetPathString: String; +begin + {writeln('Unimplemented GetPathString');} + result := ''; +end; + +Function GetEnvironmentVariable(Const EnvVar : String) : String; +begin + {writeln('Unimplemented GetEnvironmentVariable');} + result:=''; +end; + +Function GetEnvironmentVariableCount : Integer; +begin + {writeln('Unimplemented GetEnvironmentVariableCount');} + result:=0; +end; + +Function GetEnvironmentString(Index : Integer) : {$ifdef FPC_RTL_UNICODE}UnicodeString{$else}AnsiString{$endif}; +begin + {writeln('Unimplemented GetEnvironmentString');} + result:=''; +end; + +function ExecuteProcess (const Path: RawByteString; const ComLine: RawByteString;Flags:TExecuteFlags=[]): + integer; +var + tmpPath: RawByteString; + pcmdline: ShortString; + CommandLine: RawByteString; + E: EOSError; +begin + tmpPath:=ToSingleByteFileSystemEncodedFileName(Path); + pcmdline:=ToSingleByteFileSystemEncodedFileName(ComLine); + + result:=-1; { execute here } + + if result < 0 then begin + if ComLine = '' then + CommandLine := Path + else + CommandLine := Path + ' ' + ComLine; + + E := EOSError.CreateFmt (SExecuteProcessFailed, [CommandLine, result]); + E.ErrorCode := result; + raise E; + end; +end; + +function ExecuteProcess (const Path: RawByteString; + const ComLine: array of RawByteString;Flags:TExecuteFlags=[]): integer; +var + CommandLine: RawByteString; + I: integer; + +begin + Commandline := ''; + for I := 0 to High (ComLine) do + if Pos (' ', ComLine [I]) <> 0 then + CommandLine := CommandLine + ' ' + '"' + ToSingleByteFileSystemEncodedFileName(ComLine [I]) + '"' + else + CommandLine := CommandLine + ' ' + ToSingleByteFileSystemEncodedFileName(Comline [I]); + ExecuteProcess := ExecuteProcess (Path, CommandLine); +end; + +procedure Sleep(Milliseconds: cardinal); +begin + {writeln('Unimplemented sleep');} +end; + + +{**************************************************************************** + Initialization code +****************************************************************************} + +Initialization + InitExceptions; + InitInternational; { Initialize internationalization settings } + OnBeep:=Nil; { No SysBeep() on the QL for now. } + +Finalization + FreeTerminateProcs; + DoneExceptions; +end. diff --git a/rtl/win/sysutils.pp b/rtl/win/sysutils.pp index 726b389fe2..2776b5e135 100644 --- a/rtl/win/sysutils.pp +++ b/rtl/win/sysutils.pp @@ -1037,14 +1037,19 @@ end; Locale Functions ****************************************************************************} -function GetLocaleStr(LID, LT: Longint; const Def: string): ShortString; +function GetLocaleStr(LID, LT: Longint; const Def: string): AnsiString; var L: Integer; - Buf: array[0..255] of Char; + Buf: unicodestring; begin - L := GetLocaleInfoA(LID, LT, Buf, SizeOf(Buf)); + L := GetLocaleInfoW(LID, LT, nil, 0); if L > 0 then - SetString(Result, @Buf[0], L - 1) + begin + SetLength(Buf,L-1); // L includes terminating NULL + if l>1 Then + L := GetLocaleInfoW(LID, LT, @Buf[1], L); + result:=buf; + end else Result := Def; end; |