paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-09 22:48:57 +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
Thanks for Martin 'MarK' Kuchinka <kuchinka@volny.cz>
for his help.
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.
*/
#
# This file is part of the Free Pascal run time library.
# Copyright (c) 2004 by Karoly Balogh for Genesi Sarl
#
# Thanks for Martin 'MarK' Kuchinka <kuchinka@volny.cz>
# for his help.
#
# 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.
#
.section ".text"
.globl _start
.align 4
@ -23,12 +20,12 @@ _start:
stw 0,4(1)
stwu 1,-16(1)
/* Get ExecBase */
# Get ExecBase
lwz 3,4(0)
lis 4,_ExecBase@ha
stw 3,_ExecBase@l(4)
/* Allocating new stack */
# Allocating new stack
lis 4,__stklen@ha
lwz 3,__stklen@l(4)
stw 3,0(2)
@ -36,7 +33,7 @@ _start:
stw 3,56(2)
lwz 3,100(2)
mtlr 3
li 3,-858 /* AllocTaskPooled */
li 3,-858 # AllocTaskPooled
blrl
cmplwi cr0,3,0
@ -45,7 +42,7 @@ _start:
lis 4,stackArea@ha
stw 3,stackArea@l(4)
/* Setting up stackSwap struct */
# Setting up stackSwap struct
lis 4,stackSwap@ha
addi 4,4,stackSwap@l
stw 3,0(4)
@ -55,7 +52,7 @@ _start:
stw 3,4(4)
stw 3,8(4)
/* Calling main function with the new stack */
# Calling main function with the new stack
stw 4,32(2)
lis 4,_initproc@ha
addi 4,4,_initproc@l
@ -64,10 +61,10 @@ _start:
stw 3,40(2)
lwz 4,100(2)
mtlr 4
li 3,-804 /* NewPPCStackSwap */
li 3,-804 # NewPPCStackSwap
blrl
/* Setting return value */
# Setting return value
lis 4,returnValue@ha
lwz 3,returnValue@l(4)
@ -101,7 +98,7 @@ _initproc:
stw 30,120(1)
stw 31,124(1)
/* Save Stackpointer */
# Save Stackpointer
lis 4,OriginalStkPtr@ha
stw 1,OriginalStkPtr@l(4)
@ -109,11 +106,11 @@ _initproc:
.globl _haltproc
_haltproc:
/* Restore Stackpointer */
# Restore Stackpointer
lis 4,OriginalStkPtr@ha
lwz 1,OriginalStkPtr@l(4)
/* Store return value */
# Store return value
lis 4,returnValue@ha
stw 3,returnValue@l(4)
@ -175,53 +172,12 @@ stackSwap:
.long 0
.long 0
/* This is needed to be a proper MOS ABox executable */
/* This symbol _MUST NOT_ be stripped out from the executable */
/* or else... */
# This is needed to be a proper MOS ABox executable
# This symbol _MUST NOT_ be stripped out from the executable
# or else...
.globl __abox__
.type __abox__,@object
.size __abox__,4
__abox__:
.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.
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,
for details about the copyright.
@ -13,6 +13,9 @@
**********************************************************************}
{ Enable this for file handling debug }
{DEFINE MOSFPC_FILEDEBUG}
{*****************************************************************************
MorphOS File-handling Support Functions
*****************************************************************************}
@ -22,8 +25,9 @@ type
{ manually on exit. }
PFileList = ^TFileList;
TFileList = record { no packed, must be correctly aligned }
handle : LongInt; { Handle to file }
next : PFileList; { Next file in list }
handle : LongInt; { Handle to file }
next : PFileList; { Next file in list }
buffered : boolean; { used buffered I/O? }
end;
var
@ -80,29 +84,74 @@ begin
if not inList then begin
New(p);
p^.handle:=h;
p^.buffered:=False;
p^.next:=l^.next;
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;
{ 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
p : PFileList;
inList: Boolean;
p : PFileList;
inList : Boolean;
tmpList: PFileList;
begin
if l=nil then exit;
inList:=False;
if l=nil then begin
RemoveFromList:=inList;
exit;
end;
p:=l;
while (p^.next<>nil) and (not inList) do
if p^.next^.handle=h then inList:=True
else p:=p^.next;
if p^.next<>nil then begin
if inList then begin
tmpList:=p^.next^.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;
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;
@ -114,13 +163,12 @@ end;
{ close a file from the handle value }
procedure do_close(handle : longint);
begin
if (handle<=0) then exit;
RemoveFromList(MOS_fileList,handle);
{ Do _NOT_ check CTRL_C on Close, because it will conflict
with System_Exit! }
if not dosClose(handle) then
dosError2InOut(IoErr);
if RemoveFromList(MOS_fileList,handle) then begin
{ Do _NOT_ check CTRL_C on Close, because it will conflict
with System_Exit! }
if not dosClose(handle) then
dosError2InOut(IoErr);
end;
end;
procedure do_erase(p : pchar);
@ -137,13 +185,18 @@ begin
dosError2InOut(IoErr);
end;
function do_write(h:longint; addr: pointer; len: longint) : longint;
function do_write(h: longint; addr: pointer; len: longint) : longint;
var dosResult: LongInt;
begin
checkCTRLC;
do_write:=0;
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);
if dosResult<0 then begin
dosError2InOut(IoErr);
@ -152,13 +205,18 @@ begin
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;
begin
checkCTRLC;
do_read:=0;
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);
if dosResult<0 then begin
dosError2InOut(IoErr);
@ -167,46 +225,52 @@ begin
end
end;
function do_filepos(handle : longint) : longint;
function do_filepos(handle: longint) : longint;
var dosResult: LongInt;
begin
checkCTRLC;
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;
procedure do_seek(handle,pos : longint);
procedure do_seek(handle, pos: longint);
begin
checkCTRLC;
if (handle<=0) then exit;
if CheckInList(MOS_fileList,handle)<>nil then begin
{ Seeking from OFFSET_BEGINNING }
if dosSeek(handle,pos,OFFSET_BEGINNING)<0 then
dosError2InOut(IoErr);
{ Seeking from OFFSET_BEGINNING }
if dosSeek(handle,pos,OFFSET_BEGINNING)<0 then
dosError2InOut(IoErr);
end;
end;
function do_seekend(handle:longint):longint;
function do_seekend(handle: longint):longint;
var dosResult: LongInt;
begin
checkCTRLC;
do_seekend:=-1;
if (handle<=0) then exit;
if CheckInList(MOS_fileList,handle)<>nil then begin
{ Seeking to OFFSET_END }
dosResult:=dosSeek(handle,0,OFFSET_END);
if dosResult<0 then begin
dosError2InOut(IoErr);
end else begin
do_seekend:=dosResult;
end
{ Seeking to OFFSET_END }
dosResult:=dosSeek(handle,0,OFFSET_END);
if dosResult<0 then begin
dosError2InOut(IoErr);
end else begin
do_seekend:=dosResult;
end;
end;
end;
function do_filesize(handle : longint) : longint;
@ -214,24 +278,28 @@ var currfilepos: longint;
begin
checkCTRLC;
do_filesize:=-1;
if (handle<=0) then exit;
if CheckInList(MOS_fileList,handle)<>nil then begin
currfilepos:=do_filepos(handle);
{ We have to do this twice, because seek returns the OLD position }
do_filesize:=do_seekend(handle);
do_filesize:=do_seekend(handle);
do_seek(handle,currfilepos)
currfilepos:=do_filepos(handle);
{ We have to do this twice, because seek returns the OLD position }
do_filesize:=do_seekend(handle);
do_filesize:=do_seekend(handle);
do_seek(handle,currfilepos);
end;
end;
{ truncate at a given position }
procedure do_truncate (handle,pos:longint);
procedure do_truncate(handle, pos: longint);
begin
checkCTRLC;
if (handle<=0) then exit;
if CheckInList(MOS_fileList,handle)<>nil then begin
{ Seeking from OFFSET_BEGINNING }
if SetFileSize(handle,pos,OFFSET_BEGINNING)<0 then
dosError2InOut(IoErr);
{ Seeking from OFFSET_BEGINNING }
if SetFileSize(handle,pos,OFFSET_BEGINNING)<0 then
dosError2InOut(IoErr);
end;
end;
procedure do_open(var f;p:pchar;flags:longint);
@ -307,7 +375,7 @@ begin
end;
end;
function do_isdevice(handle:longint):boolean;
function do_isdevice(handle: longint): boolean;
begin
if (handle=StdOutputHandle) or (handle=StdInputHandle) or
(handle=StdErrorHandle) then
@ -316,5 +384,3 @@ begin
do_isdevice:=False;
end;

30
rtl/morphos/sysheap.inc
View File

@ -1,10 +1,8 @@
{
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
for a minimal POSIX compliant subset required to port the compiler
to a new OS.
Low level memory functions
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
@ -15,21 +13,39 @@
**********************************************************************}
{ Enable this for memory allocation debugging }
{DEFINE MOSFPC_MEMDEBUG}
{*****************************************************************************
OS Memory allocation / deallocation
****************************************************************************}
function SysOSAlloc(size: ptrint): pointer;
{$IFDEF MOSFPC_MEMDEBUG}
var values: array[0..2] of dword;
{$ENDIF}
begin
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;
{$define HAS_SYSOSFREE}
procedure SysOSFree(p: pointer; size: ptrint);
{$IFDEF MOSFPC_MEMDEBUG}
var values: array[0..2] of dword;
{$ENDIF}
begin
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;

8
rtl/morphos/system.pp
View File

@ -71,6 +71,14 @@ implementation
{$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

3
rtl/morphos/sysutils.pp
View File

@ -52,7 +52,8 @@ uses dos,sysconst;
{ * Followings are implemented in the system unit! * }
function PathConv(path: shortstring): shortstring; external name 'PATHCONV';
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
MOS_fileList: Pointer; external name 'MOS_FILELIST';