|
|
@@ -93,8 +93,8 @@ Const
|
|
|
|
|
|
Procedure HandleError (Errno : Longint); external name 'fpc_handleerror';
|
|
|
Procedure HandleErrorFrame (Errno : longint;frame : Pointer); forward;
|
|
|
-Procedure HandleErrorAddrFrame (Errno : longint;addr,frame : Pointer); forward;
|
|
|
-Procedure HandleErrorAddrFrameInd (Errno : longint;addr,frame : Pointer); forward;
|
|
|
+Procedure HandleErrorAddrFrame (Errno : longint;addr : CodePointer; frame : Pointer); forward;
|
|
|
+Procedure HandleErrorAddrFrameInd (Errno : longint;addr : CodePointer; frame : Pointer); forward;
|
|
|
|
|
|
{$ifdef FPC_HAS_FEATURE_TEXTIO}
|
|
|
type
|
|
|
@@ -178,6 +178,14 @@ function do_isdevice(handle:thandle):boolean;forward;
|
|
|
{$define SYSPROCDEFINED}
|
|
|
{$endif cpui386}
|
|
|
|
|
|
+{$ifdef cpui8086}
|
|
|
+ {$ifdef SYSPROCDEFINED}
|
|
|
+ {$Error Can't determine processor type !}
|
|
|
+ {$endif}
|
|
|
+ {$i i8086.inc} { Case dependent, don't change }
|
|
|
+ {$define SYSPROCDEFINED}
|
|
|
+{$endif cpui8086}
|
|
|
+
|
|
|
{$ifdef cpum68k}
|
|
|
{$ifdef SYSPROCDEFINED}
|
|
|
{$Error Can't determine processor type !}
|
|
|
@@ -239,10 +247,14 @@ function do_isdevice(handle:thandle):boolean;forward;
|
|
|
{$Error Can't determine processor type !}
|
|
|
{$endif}
|
|
|
{$i armdefines.inc}
|
|
|
- {$if defined(CPUARMV7EM) or defined(CPUARMV7M)}
|
|
|
+ {$if defined(CPUTHUMB2)}
|
|
|
{$i thumb2.inc} { Case dependent, don't change }
|
|
|
{$else}
|
|
|
- {$i arm.inc} { Case dependent, don't change }
|
|
|
+ {$if defined(CPUTHUMB)}
|
|
|
+ {$i thumb.inc} { Case dependent, don't change }
|
|
|
+ {$else}
|
|
|
+ {$i arm.inc} { Case dependent, don't change }
|
|
|
+ {$endif}
|
|
|
{$endif}
|
|
|
{$define SYSPROCDEFINED}
|
|
|
{$endif cpuarm}
|
|
|
@@ -255,21 +267,22 @@ function do_isdevice(handle:thandle):boolean;forward;
|
|
|
{$define SYSPROCDEFINED}
|
|
|
{$endif cpuavr}
|
|
|
|
|
|
-{$ifdef cpumips}
|
|
|
+{$ifdef cpumipsel}
|
|
|
{$ifdef SYSPROCDEFINED}
|
|
|
{$Error Can't determine processor type !}
|
|
|
{$endif}
|
|
|
+ { there is no mipsel.inc, we use mips.inc instead }
|
|
|
{$i mips.inc} { Case dependent, don't change }
|
|
|
{$define SYSPROCDEFINED}
|
|
|
-{$endif cpumips}
|
|
|
-
|
|
|
-{$ifdef cpumipsel}
|
|
|
+{$else not cpumipsel}
|
|
|
+{$ifdef cpumips}
|
|
|
{$ifdef SYSPROCDEFINED}
|
|
|
{$Error Can't determine processor type !}
|
|
|
{$endif}
|
|
|
- {$i mipsel.inc} { Case dependent, don't change }
|
|
|
+ {$i mips.inc} { Case dependent, don't change }
|
|
|
{$define SYSPROCDEFINED}
|
|
|
-{$endif cpumipsel}
|
|
|
+{$endif cpumips}
|
|
|
+{$endif not cpumipsel}
|
|
|
|
|
|
{$ifdef cpujvm}
|
|
|
{$ifdef SYSPROCDEFINED}
|
|
|
@@ -318,6 +331,12 @@ procedure fpc_zeromem(p:pointer;len:ptruint);
|
|
|
begin
|
|
|
FillChar(p^,len,0);
|
|
|
end;
|
|
|
+
|
|
|
+
|
|
|
+procedure fpc_fillmem(out data;len:ptruint;b : byte);
|
|
|
+begin
|
|
|
+ FillByte(data,len,b);
|
|
|
+end;
|
|
|
{$endif cpujvm}
|
|
|
|
|
|
{ Include generic pascal only routines which are not defined in the processor
|
|
|
@@ -424,6 +443,7 @@ function aligntoptr(p : pointer) : pointer;inline;
|
|
|
****************************************************************************}
|
|
|
|
|
|
{ Needs to be before RTTI handling }
|
|
|
+
|
|
|
{$i sstrings.inc}
|
|
|
|
|
|
{ requires sstrings.inc for initval }
|
|
|
@@ -668,29 +688,36 @@ end;
|
|
|
Memory Management
|
|
|
****************************************************************************}
|
|
|
(*
|
|
|
-Function Ptr(sel,off : Longint) : farpointer;{$ifdef SYSTEMINLINE}inline;{$endif}
|
|
|
+{$ifndef FPC_SYSTEM_HAS_PTR}
|
|
|
+Function Ptr(sel,off : {$ifdef CPU16}Word{$else}Longint{$endif}) : farpointer;{$ifdef SYSTEMINLINE}inline;{$endif}
|
|
|
Begin
|
|
|
ptr:=farpointer((sel shl 4)+off);
|
|
|
End;
|
|
|
+{$endif not FPC_SYSTEM_HAS_PTR}
|
|
|
|
|
|
+{$ifndef FPC_SYSTEM_HAS_CSEG}
|
|
|
Function CSeg : Word;{$ifdef SYSTEMINLINE}inline;{$endif}
|
|
|
Begin
|
|
|
Cseg:=0;
|
|
|
End;
|
|
|
+{$endif not FPC_SYSTEM_HAS_CSEG}
|
|
|
|
|
|
+{$ifndef FPC_SYSTEM_HAS_DSEG}
|
|
|
Function DSeg : Word;{$ifdef SYSTEMINLINE}inline;{$endif}
|
|
|
Begin
|
|
|
Dseg:=0;
|
|
|
End;
|
|
|
+{$endif not FPC_SYSTEM_HAS_DSEG}
|
|
|
|
|
|
+{$ifndef FPC_SYSTEM_HAS_SSEG}
|
|
|
Function SSeg : Word;{$ifdef SYSTEMINLINE}inline;{$endif}
|
|
|
Begin
|
|
|
Sseg:=0;
|
|
|
End;
|
|
|
+{$endif not FPC_SYSTEM_HAS_SSEG}
|
|
|
*)
|
|
|
|
|
|
|
|
|
-
|
|
|
{$push}
|
|
|
{$R-}
|
|
|
{$I-}
|
|
|
@@ -700,11 +727,20 @@ End;
|
|
|
Miscellaneous
|
|
|
*****************************************************************************}
|
|
|
|
|
|
+{$ifndef FPC_SYSTEM_HAS_STACKTOP}
|
|
|
+(*
|
|
|
+function StackTop: pointer;
|
|
|
+begin
|
|
|
+ result:=StackBottom+StackLength;
|
|
|
+end;
|
|
|
+*)
|
|
|
+{$endif FPC_SYSTEM_HAS_STACKTOP}
|
|
|
+
|
|
|
{$ifndef FPC_SYSTEM_HAS_GET_PC_ADDR}
|
|
|
{ This provides a dummy implementation
|
|
|
of get_pc_addr function, for CPU's that don't need
|
|
|
the instruction address to walk the stack. }
|
|
|
-function get_pc_addr : pointer;
|
|
|
+function get_pc_addr : codepointer;
|
|
|
begin
|
|
|
get_pc_addr:=nil;
|
|
|
end;
|
|
|
@@ -715,9 +751,10 @@ end;
|
|
|
of get_caller_stackinfo procedure,
|
|
|
using get_caller_addr and get_caller_frame
|
|
|
functions. }
|
|
|
-procedure get_caller_stackinfo(var framebp,addr : pointer);
|
|
|
+procedure get_caller_stackinfo(var framebp : pointer; var addr : codepointer);
|
|
|
var
|
|
|
- nextbp,nextaddr : pointer;
|
|
|
+ nextbp : pointer;
|
|
|
+ nextaddr : codepointer;
|
|
|
begin
|
|
|
nextbp:=get_caller_frame(framebp,addr);
|
|
|
nextaddr:=get_caller_addr(framebp,addr);
|
|
|
@@ -768,7 +805,7 @@ begin
|
|
|
begin
|
|
|
l:=HInOutRes^;
|
|
|
HInOutRes^:=0;
|
|
|
- HandleErrorAddrFrameInd(l,get_pc_addr,get_frame)
|
|
|
+ HandleErrorAddrFrameInd(l,get_pc_addr,get_frame);
|
|
|
end;
|
|
|
end;
|
|
|
|
|
|
@@ -850,7 +887,7 @@ type
|
|
|
end;
|
|
|
TInitFinalTable = record
|
|
|
TableCount,
|
|
|
- InitCount : longint;
|
|
|
+ InitCount : {$ifdef VER2_6}longint{$else}sizeint{$endif};
|
|
|
Procs : array[1..maxunits] of TInitFinalRec;
|
|
|
end;
|
|
|
PInitFinalTable = ^TInitFinalTable;
|
|
|
@@ -864,13 +901,22 @@ var
|
|
|
|
|
|
procedure fpc_InitializeUnits;[public,alias:'FPC_INITIALIZEUNITS']; compilerproc;
|
|
|
var
|
|
|
- i : longint;
|
|
|
+ i : ObjpasInt;
|
|
|
+{$ifdef DEBUG}
|
|
|
+ pt : PInitFinalTable;
|
|
|
+{$endif}
|
|
|
begin
|
|
|
{ call cpu/fpu initialisation routine }
|
|
|
fpc_cpuinit;
|
|
|
{$ifdef FPC_HAS_INDIRECT_MAIN_INFORMATION}
|
|
|
+{$ifdef DEBUG}
|
|
|
+ pt := PInitFinalTable(EntryInformation.InitFinalTable);
|
|
|
+{$endif}
|
|
|
with PInitFinalTable(EntryInformation.InitFinalTable)^ do
|
|
|
{$else FPC_HAS_INDIRECT_MAIN_INFORMATION}
|
|
|
+{$ifdef DEBUG}
|
|
|
+ pt := @InitFinalTable;
|
|
|
+{$endif}
|
|
|
with InitFinalTable do
|
|
|
{$endif FPC_HAS_INDIRECT_MAIN_INFORMATION}
|
|
|
begin
|
|
|
@@ -932,33 +978,19 @@ Procedure FinalizeHeap;forward;
|
|
|
|
|
|
{$ifdef FPC_HAS_FEATURE_CONSOLEIO}
|
|
|
procedure SysFlushStdIO;
|
|
|
-var
|
|
|
- pstdout : ^Text;
|
|
|
begin
|
|
|
- { Show runtime error and exit }
|
|
|
- pstdout:=@stdout;
|
|
|
- If erroraddr<>nil Then
|
|
|
- Begin
|
|
|
- Writeln(pstdout^,'Runtime error ',Errorcode,' at $',hexstr(erroraddr));
|
|
|
- { to get a nice symify }
|
|
|
- Writeln(pstdout^,BackTraceStrFunc(Erroraddr));
|
|
|
- dump_stack(pstdout^,ErrorBase,ErrorAddr);
|
|
|
- Writeln(pstdout^,'');
|
|
|
- End;
|
|
|
-
|
|
|
{ Make sure that all output is written to the redirected file }
|
|
|
if Textrec(Output).Mode=fmOutput then
|
|
|
Flush(Output);
|
|
|
if Textrec(ErrOutput).Mode=fmOutput then
|
|
|
Flush(ErrOutput);
|
|
|
- if Textrec(pstdout^).Mode=fmOutput then
|
|
|
- Flush(pstdout^);
|
|
|
+ if Textrec(stdout).Mode=fmOutput then
|
|
|
+ Flush(stdout);
|
|
|
if Textrec(StdErr).Mode=fmOutput then
|
|
|
Flush(StdErr);
|
|
|
end;
|
|
|
{$endif FPC_HAS_FEATURE_CONSOLEIO}
|
|
|
|
|
|
-
|
|
|
Procedure InternalExit;
|
|
|
(*
|
|
|
var
|
|
|
@@ -997,7 +1029,7 @@ Begin
|
|
|
Writeln(pstdout^,'Runtime error ',Errorcode,' at $',hexstr(erroraddr));
|
|
|
{ to get a nice symify }
|
|
|
Writeln(pstdout^,BackTraceStrFunc(Erroraddr));
|
|
|
- dump_stack(pstdout^,ErrorBase);
|
|
|
+ dump_stack(pstdout^,ErrorBase,ErrorAddr);
|
|
|
Writeln(pstdout^,'');
|
|
|
End;
|
|
|
SysFlushStdIO;
|
|
|
@@ -1023,16 +1055,22 @@ Begin
|
|
|
{$endif}
|
|
|
{$ifdef LINUX}
|
|
|
{sysfreemem already checks for nil}
|
|
|
- sysfreemem(calculated_cmdline);
|
|
|
+ { Do not try to do anything if the heap manager already reported an error }
|
|
|
+ if (errorcode<>203) and (errorcode<>204) then
|
|
|
+ sysfreemem(calculated_cmdline);
|
|
|
{$endif}
|
|
|
{$ifdef BSD}
|
|
|
- sysfreemem(cmdline);
|
|
|
+ { Do not try to do anything if the heap manager already reported an error }
|
|
|
+ if (errorcode<>203) and (errorcode<>204) then
|
|
|
+ sysfreemem(cmdline);
|
|
|
{$endif}
|
|
|
|
|
|
{$ifdef FPC_HAS_FEATURE_HEAP}
|
|
|
{$ifndef HAS_MEMORYMANAGER}
|
|
|
+{$ifndef FPC_NO_DEFAULT_HEAP}
|
|
|
FinalizeHeap;
|
|
|
-{$endif HAS_MEMORYMANAGER}
|
|
|
+{$endif not FPC_NO_DEFAULT_HEAP}
|
|
|
+{$endif not HAS_MEMORYMANAGER}
|
|
|
{$endif FPC_HAS_FEATURE_HEAP}
|
|
|
*)
|
|
|
End;
|
|
|
@@ -1053,20 +1091,56 @@ end;
|
|
|
|
|
|
Procedure Halt(ErrNum: Longint);
|
|
|
Begin
|
|
|
- ExitCode:=Errnum;
|
|
|
+{$ifdef FPC_HAS_FEATURE_EXITCODE}
|
|
|
+{$ifdef FPC_LIMITED_EXITCODE}
|
|
|
+ if ErrNum > maxExitCode then
|
|
|
+ ExitCode:=255
|
|
|
+ else
|
|
|
+{$endif FPC_LIMITED_EXITCODE}
|
|
|
+ ExitCode:=ErrNum;
|
|
|
+{$endif FPC_HAS_FEATURE_EXITCODE}
|
|
|
Do_Exit;
|
|
|
end;
|
|
|
|
|
|
(*
|
|
|
-function SysBackTraceStr (Addr: Pointer): ShortString;
|
|
|
+function SysBackTraceStr (Addr: CodePointer): ShortString;
|
|
|
begin
|
|
|
SysBackTraceStr:=' $'+hexstr(addr);
|
|
|
end;
|
|
|
*)
|
|
|
|
|
|
+(*
|
|
|
+function CaptureBacktrace(skipframes,count:sizeint;frames:PCodePointer):sizeint;
|
|
|
+var
|
|
|
+ curr_frame,prev_frame: pointer;
|
|
|
+ curr_addr: codepointer;
|
|
|
+ i: sizeint;
|
|
|
+begin
|
|
|
+ curr_frame:=get_frame;
|
|
|
+ curr_addr:=get_pc_addr;
|
|
|
+ prev_frame:=curr_frame;
|
|
|
+ get_caller_stackinfo(curr_frame,curr_addr);
|
|
|
+ i:=-skipframes;
|
|
|
+ while (i<count) and (curr_frame>prev_frame) and
|
|
|
+ (curr_frame<StackTop) do
|
|
|
+ begin
|
|
|
+ prev_frame:=curr_frame;
|
|
|
+ get_caller_stackinfo(curr_frame,curr_addr);
|
|
|
+ if (curr_addr=nil) or
|
|
|
+ (curr_frame=nil) then
|
|
|
+ break;
|
|
|
+ if (i>=0) then
|
|
|
+ frames[i]:=curr_addr;
|
|
|
+ inc(i);
|
|
|
+ end;
|
|
|
+ if i<0 then
|
|
|
+ result:=0
|
|
|
+ else
|
|
|
+ result:=i;
|
|
|
+end;
|
|
|
+*)
|
|
|
|
|
|
-
|
|
|
-Procedure HandleErrorAddrFrame (Errno : longint;addr,frame : Pointer);[public,alias:'FPC_BREAK_ERROR']; {$ifdef CPU86} register; {$endif}
|
|
|
+Procedure HandleErrorAddrFrame (Errno : longint;addr : CodePointer; frame : Pointer);[public,alias:'FPC_BREAK_ERROR']; {$ifdef CPUI386} register; {$endif}
|
|
|
begin
|
|
|
If pointer(ErrorProc)<>Nil then
|
|
|
ErrorProc(Errno,addr,frame);
|
|
|
@@ -1079,7 +1153,6 @@ begin
|
|
|
if ExceptAddrStack <> nil then
|
|
|
raise TObject(nil) at addr,frame;
|
|
|
{$endif FPC_HAS_FEATURE_EXCEPTIONS}
|
|
|
-
|
|
|
Halt(errorcode);
|
|
|
*)
|
|
|
end;
|
|
|
@@ -1087,7 +1160,7 @@ end;
|
|
|
{ This is used internally by system skip first level,
|
|
|
and generated the same output as before, when
|
|
|
HandleErrorFrame function was used internally. }
|
|
|
-Procedure HandleErrorAddrFrameInd (Errno : longint;addr,frame : Pointer);
|
|
|
+Procedure HandleErrorAddrFrameInd (Errno : longint;addr : CodePointer; frame : Pointer);
|
|
|
begin
|
|
|
get_caller_stackinfo (frame, addr);
|
|
|
HandleErrorAddrFrame (Errno,addr,frame);
|
|
|
@@ -1104,23 +1177,29 @@ begin
|
|
|
end;
|
|
|
|
|
|
|
|
|
-Procedure fpc_handleerror (Errno : longint); compilerproc; [public,alias : 'FPC_HANDLEERROR'];
|
|
|
+procedure fpc_handleerror (Errno : longint); compilerproc; [public,alias : 'FPC_HANDLEERROR'];
|
|
|
{
|
|
|
Procedure to handle internal errors, i.e. not user-invoked errors
|
|
|
Internal function should ALWAYS call HandleError instead of RunError.
|
|
|
}
|
|
|
begin
|
|
|
- HandleErrorAddrFrame(Errno,get_pc_addr,get_frame);
|
|
|
+ HandleErrorAddrFrameInd(Errno,get_pc_addr,get_frame);
|
|
|
end;
|
|
|
|
|
|
|
|
|
procedure RunError(w : word);[alias: 'FPC_RUNERROR'];
|
|
|
+var
|
|
|
+ bp : pointer;
|
|
|
+ pcaddr : codepointer;
|
|
|
begin
|
|
|
errorcode:=w;
|
|
|
(*
|
|
|
- erroraddr:=get_caller_addr(get_frame,get_pc_addr,);
|
|
|
- errorbase:=get_caller_frame(get_frame,get_pc_addr);
|
|
|
- *)
|
|
|
+ pcaddr:=get_pc_addr;
|
|
|
+ bp:=get_frame;
|
|
|
+ get_caller_stackinfo(bp,pcaddr);
|
|
|
+ erroraddr:=pcaddr;
|
|
|
+ errorbase:=bp;
|
|
|
+*)
|
|
|
Halt(errorcode);
|
|
|
end;
|
|
|
|
|
|
@@ -1138,45 +1217,39 @@ End;
|
|
|
|
|
|
|
|
|
Procedure Error(RunTimeError : TRunTimeError);
|
|
|
-
|
|
|
begin
|
|
|
RunError(RuntimeErrorExitCodes[RunTimeError]);
|
|
|
end;
|
|
|
|
|
|
|
|
|
{$ifndef CPUJVM}
|
|
|
-Procedure dump_stack(var f : text;bp,addr : Pointer);
|
|
|
+Procedure dump_stack(var f : text;fp : Pointer; addr : CodePointer);
|
|
|
var
|
|
|
i : Longint;
|
|
|
- prevbp : Pointer;
|
|
|
- prevaddr : pointer;
|
|
|
+ prevfp : Pointer;
|
|
|
is_dev : boolean;
|
|
|
- caller_frame,
|
|
|
- caller_addr : Pointer;
|
|
|
Begin
|
|
|
{$ifdef FPC_HAS_FEATURE_EXCEPTIONS}
|
|
|
try
|
|
|
{$endif FPC_HAS_FEATURE_EXCEPTIONS}
|
|
|
- prevbp:=bp-1;
|
|
|
- prevaddr:=nil;
|
|
|
+ { Frame of this procedure acts as StackBottom, fp values below that are invalid. }
|
|
|
+ prevfp:=get_frame;
|
|
|
i:=0;
|
|
|
is_dev:=do_isdevice(textrec(f).Handle);
|
|
|
- while bp > prevbp Do
|
|
|
+ { sanity checks, new frame pointer must be always greater than the old one, further
|
|
|
+ it must point into the stack area, else something went wrong }
|
|
|
+ while (fp>prevfp) and (fp<StackTop) do
|
|
|
Begin
|
|
|
- caller_addr := get_caller_addr(bp,addr);
|
|
|
- caller_frame := get_caller_frame(bp,addr);
|
|
|
- if (caller_addr=nil) then
|
|
|
+ prevfp:=fp;
|
|
|
+ get_caller_stackinfo(fp,addr);
|
|
|
+ if (addr=nil) then
|
|
|
break;
|
|
|
- Writeln(f,BackTraceStrFunc(caller_addr));
|
|
|
- if (caller_frame=nil) then
|
|
|
+ Writeln(f,BackTraceStrFunc(addr));
|
|
|
+ if (fp=nil) then
|
|
|
break;
|
|
|
Inc(i);
|
|
|
If ((i>max_frame_dump) and is_dev) or (i>256) Then
|
|
|
break;
|
|
|
- prevbp:=bp;
|
|
|
- prevaddr:=addr;
|
|
|
- bp:=caller_frame;
|
|
|
- addr:=caller_addr;
|
|
|
End;
|
|
|
{$ifdef FPC_HAS_FEATURE_EXCEPTIONS}
|
|
|
except
|
|
|
@@ -1191,7 +1264,7 @@ procedure DumpExceptionBackTrace(var f:text);
|
|
|
var
|
|
|
FrameNumber,
|
|
|
FrameCount : longint;
|
|
|
- Frames : PPointer;
|
|
|
+ Frames : PCodePointer;
|
|
|
begin
|
|
|
if RaiseList=nil then
|
|
|
exit;
|
|
|
@@ -1211,7 +1284,7 @@ Type
|
|
|
PExitProcInfo = ^TExitProcInfo;
|
|
|
TExitProcInfo = Record
|
|
|
Next : PExitProcInfo;
|
|
|
- SaveExit : Pointer;
|
|
|
+ SaveExit : CodePointer;
|
|
|
Proc : TProcedure;
|
|
|
End;
|
|
|
const
|
|
|
@@ -1360,6 +1433,11 @@ end;
|
|
|
Abstract/Assert support.
|
|
|
*****************************************************************************}
|
|
|
|
|
|
+procedure fpc_emptymethod;[public,alias : 'FPC_EMPTYMETHOD'];
|
|
|
+begin
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
procedure fpc_AbstractErrorIntern;compilerproc;[public,alias : 'FPC_ABSTRACTERROR'];
|
|
|
begin
|
|
|
(*
|
|
|
@@ -1403,7 +1481,7 @@ end;
|
|
|
{$i setjump.inc}
|
|
|
|
|
|
|
|
|
-{$pop} //{$I-,R-,Q-} before 'procedure fpc_rangeerror'
|
|
|
+{$pop} //{$I-,R-,Q-} before 'procedure fpc_rangeerror'
|
|
|
|
|
|
|
|
|
{*****************************************************************************
|
|
|
@@ -1424,8 +1502,10 @@ end;
|
|
|
{ Generic threadmanager }
|
|
|
{$i thread.inc}
|
|
|
|
|
|
+{$ifndef FPC_SECTION_THREADVARS}
|
|
|
{ Generic threadvar support }
|
|
|
{$i threadvr.inc}
|
|
|
+{$endif FPC_SECTION_THREADVARS}
|
|
|
|
|
|
{$ifdef DISABLE_NO_THREAD_MANAGER}
|
|
|
{ OS Dependent implementation }
|
|
|
@@ -1441,13 +1521,49 @@ end;
|
|
|
|
|
|
{$ifdef FPC_HAS_FEATURE_FILEIO}
|
|
|
{ Allow slash and backslash as separators }
|
|
|
-procedure DoDirSeparators(p:Pchar);
|
|
|
+procedure DoDirSeparators(var p: pchar; inplace: boolean = true);
|
|
|
var
|
|
|
i : longint;
|
|
|
+ len : sizeint;
|
|
|
+ newp : pchar;
|
|
|
begin
|
|
|
- for i:=0 to strlen(p) do
|
|
|
+ len:=length(p);
|
|
|
+ newp:=nil;
|
|
|
+ for i:=0 to len do
|
|
|
if p[i] in AllowDirectorySeparators then
|
|
|
- p[i]:=DirectorySeparator;
|
|
|
+ begin
|
|
|
+ if not inplace and
|
|
|
+ not assigned(newp) then
|
|
|
+ begin
|
|
|
+ getmem(newp,len+1);
|
|
|
+ move(p^,newp^,len+1);
|
|
|
+ p:=newp;
|
|
|
+ end;
|
|
|
+ p[i]:=DirectorySeparator;
|
|
|
+ end;
|
|
|
+end;
|
|
|
+
|
|
|
+procedure DoDirSeparators(var p: pwidechar; inplace: boolean = true);
|
|
|
+var
|
|
|
+ i : longint;
|
|
|
+ len : sizeint;
|
|
|
+ newp : pwidechar;
|
|
|
+begin
|
|
|
+ len:=length(p);
|
|
|
+ newp:=nil;
|
|
|
+ for i:=0 to len do
|
|
|
+ if (ord(p[i])<255) and
|
|
|
+ (ansichar(ord(p[i])) in AllowDirectorySeparators) then
|
|
|
+ begin
|
|
|
+ if not inplace and
|
|
|
+ not assigned(newp) then
|
|
|
+ begin
|
|
|
+ getmem(newp,(len+1)*2);
|
|
|
+ move(p^,newp^,(len+1)*2);
|
|
|
+ p:=newp;
|
|
|
+ end;
|
|
|
+ p[i]:=DirectorySeparator;
|
|
|
+ end;
|
|
|
end;
|
|
|
|
|
|
procedure DoDirSeparators(var p:shortstring);
|
|
|
@@ -1458,11 +1574,129 @@ begin
|
|
|
if p[i] in AllowDirectorySeparators then
|
|
|
p[i]:=DirectorySeparator;
|
|
|
end;
|
|
|
+
|
|
|
+
|
|
|
+procedure DoDirSeparators(var ps:RawByteString);
|
|
|
+var
|
|
|
+ i : longint;
|
|
|
+ p : pchar;
|
|
|
+ unique : boolean;
|
|
|
+begin
|
|
|
+ unique:=false;
|
|
|
+ for i:=1 to length(ps) do
|
|
|
+ if ps[i] in AllowDirectorySeparators then
|
|
|
+ begin
|
|
|
+ if not unique then
|
|
|
+ begin
|
|
|
+ uniquestring(ps);
|
|
|
+ p:=pchar(ps);
|
|
|
+ unique:=true;
|
|
|
+ end;
|
|
|
+ p[i-1]:=DirectorySeparator;
|
|
|
+ end;
|
|
|
+end;
|
|
|
+
|
|
|
+procedure DoDirSeparators(var ps:UnicodeString);
|
|
|
+var
|
|
|
+ i : longint;
|
|
|
+ p : pwidechar;
|
|
|
+ unique : boolean;
|
|
|
+begin
|
|
|
+ unique:=false;
|
|
|
+ for i:=1 to length(ps) do
|
|
|
+ if ps[i] in AllowDirectorySeparators then
|
|
|
+ begin
|
|
|
+ if not unique then
|
|
|
+ begin
|
|
|
+ uniquestring(ps);
|
|
|
+ p:=pwidechar(ps);
|
|
|
+ unique:=true;
|
|
|
+ end;
|
|
|
+ p[i-1]:=DirectorySeparator;
|
|
|
+ end;
|
|
|
+end;
|
|
|
+
|
|
|
{$endif FPC_HAS_FEATURE_FILEIO}
|
|
|
|
|
|
{ OS dependent low level file functions }
|
|
|
{$ifdef FPC_HAS_FEATURE_FILEIO}
|
|
|
{$i sysfile.inc}
|
|
|
+
|
|
|
+{$ifndef FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
|
|
|
+{$ifdef FPC_ANSI_TEXTFILEREC}
|
|
|
+procedure do_open(var f; p: pansichar; flags: longint; pchangeable: boolean);
|
|
|
+var
|
|
|
+ u: UnicodeString;
|
|
|
+begin
|
|
|
+ widestringmanager.Ansi2UnicodeMoveProc(p,DefaultFileSystemCodePage,u,length(p));
|
|
|
+ do_open(f,pwidechar(u),flags,true);
|
|
|
+end;
|
|
|
+
|
|
|
+procedure do_erase(p: pansichar; pchangeable: boolean);
|
|
|
+var
|
|
|
+ u: UnicodeString;
|
|
|
+begin
|
|
|
+ widestringmanager.Ansi2UnicodeMoveProc(p,DefaultFileSystemCodePage,u,length(p));
|
|
|
+ do_erase(pwidechar(u),true);
|
|
|
+end;
|
|
|
+
|
|
|
+procedure do_rename(src, dst: pansichar; srcchangeable, dstchangeable: boolean);
|
|
|
+var
|
|
|
+ usrc, udst: UnicodeString;
|
|
|
+begin
|
|
|
+ widestringmanager.Ansi2UnicodeMoveProc(src,DefaultFileSystemCodePage,usrc,length(src));
|
|
|
+ widestringmanager.Ansi2UnicodeMoveProc(dst,DefaultFileSystemCodePage,udst,length(dst));
|
|
|
+ do_rename(pwidechar(usrc),pwidechar(udst),true,true);
|
|
|
+end;
|
|
|
+
|
|
|
+procedure do_rename(src: pansichar; dst: pwidechar; srcchangeable, dstchangeable: boolean);
|
|
|
+var
|
|
|
+ usrc: UnicodeString;
|
|
|
+begin
|
|
|
+ widestringmanager.Ansi2UnicodeMoveProc(src,DefaultFileSystemCodePage,usrc,length(src));
|
|
|
+ do_rename(pwidechar(usrc),dst,true,dstchangeable);
|
|
|
+end;
|
|
|
+{$endif FPC_ANSI_TEXTFILEREC}
|
|
|
+{$endif not FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
|
|
|
+
|
|
|
+
|
|
|
+{$ifndef FPCRTL_FILESYSTEM_TWO_BYTE_API}
|
|
|
+{$ifndef FPC_ANSI_TEXTFILEREC}
|
|
|
+procedure do_open(var f; p: pwidechar; flags: longint; pchangeable: boolean);
|
|
|
+var
|
|
|
+ s: RawByteString;
|
|
|
+begin
|
|
|
+ widestringmanager.Unicode2AnsiMoveProc(p,s,DefaultFileSystemCodePage,length(p));
|
|
|
+ do_open(f,pansichar(s),flags,true);
|
|
|
+end;
|
|
|
+
|
|
|
+procedure do_erase(p: pwidechar; pchangeable: boolean);
|
|
|
+var
|
|
|
+ s: RawByteString;
|
|
|
+begin
|
|
|
+ widestringmanager.Unicode2AnsiMoveProc(p,s,DefaultFileSystemCodePage,length(p));
|
|
|
+ do_erase(pansichar(s),true);
|
|
|
+end;
|
|
|
+
|
|
|
+procedure do_rename(src, dst: pwidechar; srcchangeable, dstchangeable: boolean);
|
|
|
+var
|
|
|
+ rsrc, rdst: RawByteString;
|
|
|
+begin
|
|
|
+ widestringmanager.Unicode2AnsiMoveProc(src,rsrc,DefaultFileSystemCodePage,length(src));
|
|
|
+ widestringmanager.Unicode2AnsiMoveProc(dst,rdst,DefaultFileSystemCodePage,length(dst));
|
|
|
+ do_rename(pansichar(rsrc),pansichar(rdst),true,true);
|
|
|
+end;
|
|
|
+
|
|
|
+procedure do_rename(src: pwidechar; dst: pansichar; srcchangeable, dstchangeable: boolean);
|
|
|
+var
|
|
|
+ rsrc: RawByteString;
|
|
|
+begin
|
|
|
+ widestringmanager.Unicode2AnsiMoveProc(src,rsrc,DefaultFileSystemCodePage,length(src));
|
|
|
+ do_rename(pansichar(rsrc),dst,true,dstchangeable);
|
|
|
+end;
|
|
|
+{$endif not FPC_ANSI_TEXTFILEREC}
|
|
|
+{$endif not FPCRTL_FILESYSTEM_TWO_BYTE_API}
|
|
|
+
|
|
|
{$endif FPC_HAS_FEATURE_FILEIO}
|
|
|
|
|
|
{ Text file }
|
|
|
@@ -1486,55 +1720,182 @@ end;
|
|
|
{$ifdef FPC_HAS_FEATURE_FILEIO}
|
|
|
{ OS dependent dir functions }
|
|
|
{$i sysdir.inc}
|
|
|
-{$endif FPC_HAS_FEATURE_FILEIO}
|
|
|
|
|
|
-{$if defined(FPC_HAS_FEATURE_FILEIO) and defined(FPC_HAS_FEATURE_ANSISTRINGS)}
|
|
|
-Procedure getdir(drivenr:byte;Var dir:ansistring);
|
|
|
-{ this is needed to also allow ansistrings, the shortstring version is
|
|
|
- OS dependent }
|
|
|
+
|
|
|
+{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
|
|
|
+
|
|
|
+{$ifndef FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
|
|
|
+procedure do_getdir(drivenr : byte;var dir : rawbytestring);
|
|
|
var
|
|
|
- s : shortstring;
|
|
|
+ u: unicodestring;
|
|
|
begin
|
|
|
- getdir(drivenr,s);
|
|
|
- dir:=s;
|
|
|
+ Do_getdir(drivenr,u);
|
|
|
+ widestringmanager.Unicode2AnsiMoveProc(pwidechar(u),dir,DefaultRTLFileSystemCodePage,length(u));
|
|
|
end;
|
|
|
+{$endif FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
|
|
|
+
|
|
|
+Procedure MkDir(Const s: RawByteString);[IOCheck];
|
|
|
+Begin
|
|
|
+ If (s='') or (InOutRes <> 0) then
|
|
|
+ exit;
|
|
|
+{$ifdef FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
|
|
|
+ Do_mkdir(ToSingleByteFileSystemEncodedFileName(S));
|
|
|
+{$else FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
|
|
|
+ Do_mkdir(S);
|
|
|
{$endif}
|
|
|
+end;
|
|
|
|
|
|
-{$if defined(FPC_HAS_FEATURE_FILEIO)}
|
|
|
|
|
|
-Procedure MkDir(Const s: String);
|
|
|
-Var
|
|
|
- Buffer: Array[0..255] of Char;
|
|
|
+Procedure RmDir(Const s: RawByteString);[IOCheck];
|
|
|
Begin
|
|
|
If (s='') or (InOutRes <> 0) then
|
|
|
exit;
|
|
|
- Move(s[1], Buffer, Length(s));
|
|
|
- Buffer[Length(s)] := #0;
|
|
|
- MkDir(@buffer[0],length(s));
|
|
|
+{$ifdef FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
|
|
|
+ Do_rmdir(ToSingleByteFileSystemEncodedFileName(S));
|
|
|
+{$else FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
|
|
|
+ Do_rmdir(S);
|
|
|
+{$endif}
|
|
|
End;
|
|
|
|
|
|
-Procedure RmDir(Const s: String);
|
|
|
-Var
|
|
|
- Buffer: Array[0..255] of Char;
|
|
|
+
|
|
|
+Procedure ChDir(Const s: RawByteString);[IOCheck];
|
|
|
Begin
|
|
|
If (s='') or (InOutRes <> 0) then
|
|
|
exit;
|
|
|
- Move(s[1], Buffer, Length(s));
|
|
|
- Buffer[Length(s)] := #0;
|
|
|
- RmDir(@buffer[0],length(s));
|
|
|
+{$ifdef FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
|
|
|
+ Do_chdir(ToSingleByteFileSystemEncodedFileName(S));
|
|
|
+{$else FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
|
|
|
+ Do_chdir(S);
|
|
|
+{$endif}
|
|
|
End;
|
|
|
|
|
|
-Procedure ChDir(Const s: String);
|
|
|
-Var
|
|
|
- Buffer: Array[0..255] of Char;
|
|
|
+
|
|
|
+Procedure getdir(drivenr:byte;Var dir:rawbytestring);
|
|
|
+begin
|
|
|
+ Do_getdir(drivenr,dir);
|
|
|
+ { we should return results in the DefaultRTLFileSystemCodePage -> convert if
|
|
|
+ necessary }
|
|
|
+ setcodepage(dir,DefaultRTLFileSystemCodePage,true);
|
|
|
+end;
|
|
|
+
|
|
|
+{ the generic shortstring ones are only implemented elsewhere for systems *not*
|
|
|
+ supporting ansi/unicodestrings; for now assume there are no systems that
|
|
|
+ support unicodestrings but not ansistrings }
|
|
|
+
|
|
|
+{ avoid double string conversions }
|
|
|
+{$ifdef FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
|
|
|
+function GetDirStrFromShortstring(const s: shortstring): RawByteString;
|
|
|
+begin
|
|
|
+ GetDirStrFromShortstring:=ToSingleByteFileSystemEncodedFileName(ansistring(s));
|
|
|
+end;
|
|
|
+{$else FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
|
|
|
+function GetDirStrFromShortstring(const s: shortstring): UnicodeString;
|
|
|
+begin
|
|
|
+ GetDirStrFromShortstring:=s;
|
|
|
+end;
|
|
|
+{$endif FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
|
|
|
+
|
|
|
+Procedure MkDir(Const s: shortstring);[IOCheck];
|
|
|
Begin
|
|
|
If (s='') or (InOutRes <> 0) then
|
|
|
exit;
|
|
|
- Move(s[1], Buffer, Length(s));
|
|
|
- Buffer[Length(s)] := #0;
|
|
|
- ChDir(@buffer[0],length(s));
|
|
|
+ Do_mkdir(GetDirStrFromShortstring(S));
|
|
|
End;
|
|
|
-{$endif}
|
|
|
+
|
|
|
+
|
|
|
+Procedure RmDir(Const s: shortstring);[IOCheck];
|
|
|
+Begin
|
|
|
+ If (s='') or (InOutRes <> 0) then
|
|
|
+ exit;
|
|
|
+ Do_rmdir(GetDirStrFromShortstring(S));
|
|
|
+End;
|
|
|
+
|
|
|
+
|
|
|
+Procedure ChDir(Const s: shortstring);[IOCheck];
|
|
|
+Begin
|
|
|
+ If (s='') or (InOutRes <> 0) then
|
|
|
+ exit;
|
|
|
+ Do_chdir(GetDirStrFromShortstring(S));
|
|
|
+End;
|
|
|
+
|
|
|
+
|
|
|
+Procedure getdir(drivenr:byte;Var dir:shortstring);
|
|
|
+var
|
|
|
+ s: rawbytestring;
|
|
|
+begin
|
|
|
+ Do_getdir(drivenr,s);
|
|
|
+ if length(s)<=high(dir) then
|
|
|
+ dir:=s
|
|
|
+ else
|
|
|
+ inoutres:=3;
|
|
|
+end;
|
|
|
+{$endif FPC_HAS_FEATURE_ANSISTRINGS}
|
|
|
+
|
|
|
+
|
|
|
+{$if defined(FPC_HAS_FEATURE_WIDESTRINGS)}
|
|
|
+
|
|
|
+{$ifndef FPCRTL_FILESYSTEM_TWO_BYTE_API}
|
|
|
+{ overloads required for mkdir/rmdir/chdir to ensure that the string is
|
|
|
+ converted to the right code page }
|
|
|
+procedure do_mkdir(const s: unicodestring); {$ifdef SYSTEMINLINE}inline;{$endif}
|
|
|
+begin
|
|
|
+ do_mkdir(ToSingleByteFileSystemEncodedFileName(s));
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure do_rmdir(const s: unicodestring); {$ifdef SYSTEMINLINE}inline;{$endif}
|
|
|
+begin
|
|
|
+ do_rmdir(ToSingleByteFileSystemEncodedFileName(s));
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure do_chdir(const s: unicodestring); {$ifdef SYSTEMINLINE}inline;{$endif}
|
|
|
+begin
|
|
|
+ do_chdir(ToSingleByteFileSystemEncodedFileName(s));
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure do_getdir(drivenr : byte;var dir : unicodestring);
|
|
|
+var
|
|
|
+ s: rawbytestring;
|
|
|
+begin
|
|
|
+ Do_getdir(drivenr,s);
|
|
|
+ dir:=s;
|
|
|
+end;
|
|
|
+{$endif FPCRTL_FILESYSTEM_TWO_BYTE_API}
|
|
|
+
|
|
|
+Procedure MkDir(Const s: UnicodeString);[IOCheck];
|
|
|
+Begin
|
|
|
+ if (s='') or (InOutRes <> 0) then
|
|
|
+ exit;
|
|
|
+ Do_mkdir(S);
|
|
|
+End;
|
|
|
+
|
|
|
+
|
|
|
+Procedure RmDir(Const s: UnicodeString);[IOCheck];
|
|
|
+Begin
|
|
|
+ if (s='') or (InOutRes <> 0) then
|
|
|
+ exit;
|
|
|
+ Do_rmdir(S);
|
|
|
+End;
|
|
|
+
|
|
|
+
|
|
|
+Procedure ChDir(Const s: UnicodeString);[IOCheck];
|
|
|
+Begin
|
|
|
+ if (s='') or (InOutRes <> 0) then
|
|
|
+ exit;
|
|
|
+ Do_chdir(S);
|
|
|
+End;
|
|
|
+
|
|
|
+
|
|
|
+Procedure getdir(drivenr:byte;Var dir:unicodestring);
|
|
|
+begin
|
|
|
+ Do_getdir(drivenr,dir);
|
|
|
+end;
|
|
|
+{$endif FPC_HAS_FEATURE_WIDESTRINGS}
|
|
|
+
|
|
|
+{$endif FPC_HAS_FEATURE_FILEIO}
|
|
|
+
|
|
|
|
|
|
{*****************************************************************************
|
|
|
Resources support
|
Jonas Maebe