paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-11 16:06:09 +02:00
Code Issues Packages Projects Releases Wiki Activity

Merged r1666 changes from fixes branch

Browse Source 
git-svn-id: trunk@1813 -
This commit is contained in:
Károly Balogh 2005-11-24 04:58:15 +00:00
parent b6a48cfa0a
commit bd24678ae5
5 changed files with 184 additions and 137 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

98
rtl/morphos/prt0.as
View File

@ -1,20 +1,17 @@
/* #
$Id: prt0.as,v 1.12 2005/02/03 19:09:11 karoly Exp $ # This file is part of the Free Pascal run time library.
*/ # Copyright (c) 2004 by Karoly Balogh for Genesi Sarl
/* #
This file is part of the Free Pascal run time library. # Thanks for Martin 'MarK' Kuchinka <kuchinka@volny.cz>
Copyright (c) 2004 by Karoly Balogh for Genesi Sarl # for his help.
#
Thanks for Martin 'MarK' Kuchinka <kuchinka@volny.cz> # See the file COPYING.FPC, included in this distribution,
for his help. # for details about the copyright.
#
See the file COPYING.FPC, included in this distribution, # This program is distributed in the hope that it will be useful,
for details about the copyright. # but WITHOUT ANY WARRANTY;without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
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.
*/
.section ".text" .section ".text"
.globl _start .globl _start
.align 4 .align 4
@ -23,12 +20,12 @@ _start:
stw 0,4(1) stw 0,4(1)
stwu 1,-16(1) stwu 1,-16(1)
/* Get ExecBase */ # Get ExecBase
lwz 3,4(0) lwz 3,4(0)
lis 4,_ExecBase@ha lis 4,_ExecBase@ha
stw 3,_ExecBase@l(4) stw 3,_ExecBase@l(4)
/* Allocating new stack */ # Allocating new stack
lis 4,__stklen@ha lis 4,__stklen@ha
lwz 3,__stklen@l(4) lwz 3,__stklen@l(4)
stw 3,0(2) stw 3,0(2)
@ -36,7 +33,7 @@ _start:
stw 3,56(2) stw 3,56(2)
lwz 3,100(2) lwz 3,100(2)
mtlr 3 mtlr 3
li 3,-858 /* AllocTaskPooled */ li 3,-858 # AllocTaskPooled
blrl blrl
cmplwi cr0,3,0 cmplwi cr0,3,0
@ -45,7 +42,7 @@ _start:
lis 4,stackArea@ha lis 4,stackArea@ha
stw 3,stackArea@l(4) stw 3,stackArea@l(4)
/* Setting up stackSwap struct */ # Setting up stackSwap struct
lis 4,stackSwap@ha lis 4,stackSwap@ha
addi 4,4,stackSwap@l addi 4,4,stackSwap@l
stw 3,0(4) stw 3,0(4)
@ -55,7 +52,7 @@ _start:
stw 3,4(4) stw 3,4(4)
stw 3,8(4) stw 3,8(4)
/* Calling main function with the new stack */ # Calling main function with the new stack
stw 4,32(2) stw 4,32(2)
lis 4,_initproc@ha lis 4,_initproc@ha
addi 4,4,_initproc@l addi 4,4,_initproc@l
@ -64,10 +61,10 @@ _start:
stw 3,40(2) stw 3,40(2)
lwz 4,100(2) lwz 4,100(2)
mtlr 4 mtlr 4
li 3,-804 /* NewPPCStackSwap */ li 3,-804 # NewPPCStackSwap
blrl blrl
/* Setting return value */ # Setting return value
lis 4,returnValue@ha lis 4,returnValue@ha
lwz 3,returnValue@l(4) lwz 3,returnValue@l(4)
@ -101,7 +98,7 @@ _initproc:
stw 30,120(1) stw 30,120(1)
stw 31,124(1) stw 31,124(1)
/* Save Stackpointer */ # Save Stackpointer
lis 4,OriginalStkPtr@ha lis 4,OriginalStkPtr@ha
stw 1,OriginalStkPtr@l(4) stw 1,OriginalStkPtr@l(4)
@ -109,11 +106,11 @@ _initproc:
.globl _haltproc .globl _haltproc
_haltproc: _haltproc:
/* Restore Stackpointer */ # Restore Stackpointer
lis 4,OriginalStkPtr@ha lis 4,OriginalStkPtr@ha
lwz 1,OriginalStkPtr@l(4) lwz 1,OriginalStkPtr@l(4)
/* Store return value */ # Store return value
lis 4,returnValue@ha lis 4,returnValue@ha
stw 3,returnValue@l(4) stw 3,returnValue@l(4)
@ -175,53 +172,12 @@ stackSwap:
.long 0 .long 0
.long 0 .long 0
/* This is needed to be a proper MOS ABox executable */ # This is needed to be a proper MOS ABox executable
/* This symbol _MUST NOT_ be stripped out from the executable */ # This symbol _MUST NOT_ be stripped out from the executable
/* or else... */ # or else...
.globl __abox__ .globl __abox__
.type __abox__,@object .type __abox__,@object
.size __abox__,4 .size __abox__,4
__abox__: __abox__:
.long 1 .long 1
/*
Revision 1.12 2005/02/03 19:09:11 karoly
* reworked startup code:
- now uses AllocTaskPooled
- check for unsuccessful stack allocation
Revision 1.11 2004/06/06 22:02:22 karoly
* hopefully fixed stack problems causing hits
Revision 1.10 2004/06/06 12:51:06 karoly
* changelog fixed
Revision 1.9 2004/06/06 12:47:57 karoly
* some cleanup, comments added
Revision 1.8 2004/06/05 19:25:12 karoly
+ reworked to support resizing of stack
Revision 1.7 2004/05/13 01:15:42 karoly
- removed comment about argc/argv, made it work another way
Revision 1.6 2004/05/01 15:08:57 karoly
+ haltproc added, saving/restoring stackpointer added
Revision 1.5 2004/04/21 03:24:55 karoly
* rewritten to be similar to GCC startup code
Revision 1.4 2004/04/09 04:02:43 karoly
* abox id symbol fixed
Revision 1.3 2004/04/09 02:58:15 karoly
* typo fixed.
Revision 1.2 2004/04/09 02:54:25 karoly
* execbase loading oops fixed.
Revision 1.1 2004/03/16 10:29:22 karoly
* first implementation of some startup code for MOS
*/

182
rtl/morphos/sysfile.inc
View File

@ -1,8 +1,8 @@
{ {
This file is part of the Free Pascal run time library. This file is part of the Free Pascal run time library.
Copyright (c) 2001 by Free Pascal development team Copyright (c) 2005 by Free Pascal development team
Low leve file functions Low level file functions
See the file COPYING.FPC, included in this distribution, See the file COPYING.FPC, included in this distribution,
for details about the copyright. for details about the copyright.
@ -13,6 +13,9 @@
**********************************************************************} **********************************************************************}
{ Enable this for file handling debug }
{DEFINE MOSFPC_FILEDEBUG}
{***************************************************************************** {*****************************************************************************
MorphOS File-handling Support Functions MorphOS File-handling Support Functions
*****************************************************************************} *****************************************************************************}
@ -22,8 +25,9 @@ type
{ manually on exit. } { manually on exit. }
PFileList = ^TFileList; PFileList = ^TFileList;
TFileList = record { no packed, must be correctly aligned } TFileList = record { no packed, must be correctly aligned }
handle : LongInt; { Handle to file } handle : LongInt; { Handle to file }
next : PFileList; { Next file in list } next : PFileList; { Next file in list }
buffered : boolean; { used buffered I/O? }
end; end;
var var
@ -80,29 +84,74 @@ begin
if not inList then begin if not inList then begin
New(p); New(p);
p^.handle:=h; p^.handle:=h;
p^.buffered:=False;
p^.next:=l^.next; p^.next:=l^.next;
l^.next:=p; l^.next:=p;
end; end
{$IFDEF MOSFPC_FILEDEBUG}
else
RawDoFmt('FPC_FILE_DEBUG: Error! Trying add filehandle a filehandle twice: $%lx !'+#10,@h,pointer(1),nil);
{$ENDIF}
;
end; end;
{ Function to be called to remove a file from the list } { Function to be called to remove a file from the list }
procedure RemoveFromList(var l: PFileList; h: LongInt); alias: 'REMOVEFROMLIST'; [public]; function RemoveFromList(var l: PFileList; h: LongInt): boolean; alias: 'REMOVEFROMLIST'; [public];
var var
p : PFileList; p : PFileList;
inList: Boolean; inList : Boolean;
tmpList: PFileList;
begin begin
if l=nil then exit;
inList:=False; inList:=False;
if l=nil then begin
RemoveFromList:=inList;
exit;
end;
p:=l; p:=l;
while (p^.next<>nil) and (not inList) do while (p^.next<>nil) and (not inList) do
if p^.next^.handle=h then inList:=True if p^.next^.handle=h then inList:=True
else p:=p^.next; else p:=p^.next;
if p^.next<>nil then begin if inList then begin
tmpList:=p^.next^.next;
dispose(p^.next); dispose(p^.next);
p^.next:=p^.next^.next; p^.next:=tmpList;
end
{$IFDEF MOSFPC_FILEDEBUG}
else
RawDoFmt('FPC_FILE_DEBUG: Error! Trying to remove not existing filehandle: $%lx !'+#10,@h,pointer(1),nil);
{$ENDIF}
;
RemoveFromList:=inList;
end;
{ Function to check if file is in the list }
function CheckInList(var l: PFileList; h: LongInt): pointer; alias: 'CHECKINLIST'; [public];
var
p : PFileList;
inList : Pointer;
tmpList: PFileList;
begin
inList:=nil;
if l=nil then begin
CheckInList:=inList;
exit;
end; end;
p:=l;
while (p^.next<>nil) and (inList=nil) do
if p^.next^.handle=h then inList:=p^.next
else p:=p^.next;
{$IFDEF MOSFPC_FILEDEBUG}
if inList=nil then
RawDoFmt('FPC_FILE_DEBUG: Warning! Check for not existing filehandle: $%lx !'+#10,@h,pointer(1),nil);
{$ENDIF}
CheckInList:=inList;
end; end;
@ -114,13 +163,12 @@ end;
{ close a file from the handle value } { close a file from the handle value }
procedure do_close(handle : longint); procedure do_close(handle : longint);
begin begin
if (handle<=0) then exit; if RemoveFromList(MOS_fileList,handle) then begin
{ Do _NOT_ check CTRL_C on Close, because it will conflict
RemoveFromList(MOS_fileList,handle); with System_Exit! }
{ Do _NOT_ check CTRL_C on Close, because it will conflict if not dosClose(handle) then
with System_Exit! } dosError2InOut(IoErr);
if not dosClose(handle) then end;
dosError2InOut(IoErr);
end; end;
procedure do_erase(p : pchar); procedure do_erase(p : pchar);
@ -137,13 +185,18 @@ begin
dosError2InOut(IoErr); dosError2InOut(IoErr);
end; end;
function do_write(h:longint; addr: pointer; len: longint) : longint; function do_write(h: longint; addr: pointer; len: longint) : longint;
var dosResult: LongInt; var dosResult: LongInt;
begin begin
checkCTRLC; checkCTRLC;
do_write:=0; do_write:=0;
if (len<=0) or (h<=0) then exit; if (len<=0) or (h<=0) then exit;
{$IFDEF MOSFPC_FILEDEBUG}
if not ((h=StdOutputHandle) or (h=StdInputHandle) or
(h=StdErrorHandle)) then CheckInList(MOS_fileList,h);
{$ENDIF}
dosResult:=dosWrite(h,addr,len); dosResult:=dosWrite(h,addr,len);
if dosResult<0 then begin if dosResult<0 then begin
dosError2InOut(IoErr); dosError2InOut(IoErr);
@ -152,13 +205,18 @@ begin
end; end;
end; end;
function do_read(h:longint; addr: pointer; len: longint) : longint; function do_read(h: longint; addr: pointer; len: longint) : longint;
var dosResult: LongInt; var dosResult: LongInt;
begin begin
checkCTRLC; checkCTRLC;
do_read:=0; do_read:=0;
if (len<=0) or (h<=0) then exit; if (len<=0) or (h<=0) then exit;
{$IFDEF MOSFPC_FILEDEBUG}
if not ((h=StdOutputHandle) or (h=StdInputHandle) or
(h=StdErrorHandle)) then CheckInList(MOS_fileList,h);
{$ENDIF}
dosResult:=dosRead(h,addr,len); dosResult:=dosRead(h,addr,len);
if dosResult<0 then begin if dosResult<0 then begin
dosError2InOut(IoErr); dosError2InOut(IoErr);
@ -167,46 +225,52 @@ begin
end end
end; end;
function do_filepos(handle : longint) : longint; function do_filepos(handle: longint) : longint;
var dosResult: LongInt; var dosResult: LongInt;
begin begin
checkCTRLC; checkCTRLC;
do_filepos:=-1; do_filepos:=-1;
if (handle<=0) then exit; if CheckInList(MOS_fileList,handle)<>nil then begin
{ Seeking zero from OFFSET_CURRENT to find out where we are }
dosResult:=dosSeek(handle,0,OFFSET_CURRENT);
if dosResult<0 then begin
dosError2InOut(IoErr);
end else begin
do_filepos:=dosResult;
end;
{ Seeking zero from OFFSET_CURRENT to find out where we are }
dosResult:=dosSeek(handle,0,OFFSET_CURRENT);
if dosResult<0 then begin
dosError2InOut(IoErr);
end else begin
do_filepos:=dosResult;
end; end;
end; end;
procedure do_seek(handle,pos : longint); procedure do_seek(handle, pos: longint);
begin begin
checkCTRLC; checkCTRLC;
if (handle<=0) then exit; if CheckInList(MOS_fileList,handle)<>nil then begin
{ Seeking from OFFSET_BEGINNING } { Seeking from OFFSET_BEGINNING }
if dosSeek(handle,pos,OFFSET_BEGINNING)<0 then if dosSeek(handle,pos,OFFSET_BEGINNING)<0 then
dosError2InOut(IoErr); dosError2InOut(IoErr);
end;
end; end;
function do_seekend(handle:longint):longint; function do_seekend(handle: longint):longint;
var dosResult: LongInt; var dosResult: LongInt;
begin begin
checkCTRLC; checkCTRLC;
do_seekend:=-1; do_seekend:=-1;
if (handle<=0) then exit; if CheckInList(MOS_fileList,handle)<>nil then begin
{ Seeking to OFFSET_END } { Seeking to OFFSET_END }
dosResult:=dosSeek(handle,0,OFFSET_END); dosResult:=dosSeek(handle,0,OFFSET_END);
if dosResult<0 then begin if dosResult<0 then begin
dosError2InOut(IoErr); dosError2InOut(IoErr);
end else begin end else begin
do_seekend:=dosResult; do_seekend:=dosResult;
end end;
end;
end; end;
function do_filesize(handle : longint) : longint; function do_filesize(handle : longint) : longint;
@ -214,24 +278,28 @@ var currfilepos: longint;
begin begin
checkCTRLC; checkCTRLC;
do_filesize:=-1; do_filesize:=-1;
if (handle<=0) then exit; if CheckInList(MOS_fileList,handle)<>nil then begin
currfilepos:=do_filepos(handle); currfilepos:=do_filepos(handle);
{ We have to do this twice, because seek returns the OLD position } { We have to do this twice, because seek returns the OLD position }
do_filesize:=do_seekend(handle); do_filesize:=do_seekend(handle);
do_filesize:=do_seekend(handle); do_filesize:=do_seekend(handle);
do_seek(handle,currfilepos) do_seek(handle,currfilepos);
end;
end; end;
{ truncate at a given position } { truncate at a given position }
procedure do_truncate (handle,pos:longint); procedure do_truncate(handle, pos: longint);
begin begin
checkCTRLC; checkCTRLC;
if (handle<=0) then exit; if CheckInList(MOS_fileList,handle)<>nil then begin
{ Seeking from OFFSET_BEGINNING } { Seeking from OFFSET_BEGINNING }
if SetFileSize(handle,pos,OFFSET_BEGINNING)<0 then if SetFileSize(handle,pos,OFFSET_BEGINNING)<0 then
dosError2InOut(IoErr); dosError2InOut(IoErr);
end;
end; end;
procedure do_open(var f;p:pchar;flags:longint); procedure do_open(var f;p:pchar;flags:longint);
@ -307,7 +375,7 @@ begin
end; end;
end; end;
function do_isdevice(handle:longint):boolean; function do_isdevice(handle: longint): boolean;
begin begin
if (handle=StdOutputHandle) or (handle=StdInputHandle) or if (handle=StdOutputHandle) or (handle=StdInputHandle) or
(handle=StdErrorHandle) then (handle=StdErrorHandle) then
@ -316,5 +384,3 @@ begin
do_isdevice:=False; do_isdevice:=False;
end; end;

30
rtl/morphos/sysheap.inc
View File

@ -1,10 +1,8 @@
{ {
This file is part of the Free Pascal run time library. This file is part of the Free Pascal run time library.
Copyright (c) 2001 by Free Pascal development team Copyright (c) 2005 by Free Pascal development team
This file implements all the base types and limits required Low level memory functions
for a minimal POSIX compliant subset required to port the compiler
to a new OS.
See the file COPYING.FPC, included in this distribution, See the file COPYING.FPC, included in this distribution,
for details about the copyright. for details about the copyright.
@ -15,21 +13,39 @@
**********************************************************************} **********************************************************************}
{ Enable this for memory allocation debugging }
{DEFINE MOSFPC_MEMDEBUG}
{***************************************************************************** {*****************************************************************************
OS Memory allocation / deallocation OS Memory allocation / deallocation
****************************************************************************} ****************************************************************************}
function SysOSAlloc(size: ptrint): pointer; function SysOSAlloc(size: ptrint): pointer;
{$IFDEF MOSFPC_MEMDEBUG}
var values: array[0..2] of dword;
{$ENDIF}
begin begin
result:=AllocPooled(MOS_heapPool,size); result:=AllocPooled(MOS_heapPool,size);
{$IFDEF MOSFPC_MEMDEBUG}
values[0]:=dword(result);
values[1]:=dword(size);
values[2]:=DWord(Sptr-StackBottom);
RawDoFmt('FPC_MEM_DEBUG: $%lx:=SysOSAlloc(%ld), free stack: %ld bytes'+#10,@values,pointer(1),nil);
{$ENDIF}
end; end;
{$define HAS_SYSOSFREE} {$define HAS_SYSOSFREE}
procedure SysOSFree(p: pointer; size: ptrint); procedure SysOSFree(p: pointer; size: ptrint);
{$IFDEF MOSFPC_MEMDEBUG}
var values: array[0..2] of dword;
{$ENDIF}
begin begin
FreePooled(MOS_heapPool,p,size); FreePooled(MOS_heapPool,p,size);
{$IFDEF MOSFPC_MEMDEBUG}
values[0]:=dword(p);
values[1]:=dword(size);
values[2]:=DWord(Sptr-StackBottom);
RawDoFmt('FPC_MEM_DEBUG: SysOSFree($%lx,%ld), free stack: %ld bytes'+#10,@values,pointer(1),nil);
{$ENDIF}
end; end;

8
rtl/morphos/system.pp
View File

@ -71,6 +71,14 @@ implementation
{$I system.inc} {$I system.inc}
{$IFDEF MOSFPC_FILEDEBUG}
{$WARNING Compiling with file debug enabled!}
{$ENDIF}
{$IFDEF MOSFPC_MEMDEBUG}
{$WARNING Compiling with memory debug enabled!}
{$ENDIF}
{***************************************************************************** {*****************************************************************************
Misc. System Dependent Functions Misc. System Dependent Functions

3
rtl/morphos/sysutils.pp
View File

@ -52,7 +52,8 @@ uses dos,sysconst;
{ * Followings are implemented in the system unit! * } { * Followings are implemented in the system unit! * }
function PathConv(path: shortstring): shortstring; external name 'PATHCONV'; function PathConv(path: shortstring): shortstring; external name 'PATHCONV';
procedure AddToList(var l: Pointer; h: LongInt); external name 'ADDTOLIST'; procedure AddToList(var l: Pointer; h: LongInt); external name 'ADDTOLIST';
procedure RemoveFromList(var l: Pointer; h: LongInt); external name 'REMOVEFROMLIST'; function RemoveFromList(var l: Pointer; h: LongInt): boolean; external name 'REMOVEFROMLIST';
function CheckInList(var l: Pointer; h: LongInt): pointer; external name 'CHECKINLIST';
var var
MOS_fileList: Pointer; external name 'MOS_FILELIST'; MOS_fileList: Pointer; external name 'MOS_FILELIST';