Merged r1666 changes from fixes branch

git-svn-id: trunk@1813 -

rtl/morphos/prt0.as

@@ -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 <[email protected]>
-   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 <[email protected]>
+#  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
-
-*/

rtl/morphos/sysfile.inc

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

rtl/morphos/sysheap.inc

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

rtl/morphos/system.pp

@@ -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

rtl/morphos/sysutils.pp

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