freepascal.compiler/rtl/amiga/sysamiga.pas

{
    $Id$
    This file is part of the Free Pascal run time library.
    Copyright (c) 1993,97 by the Free Pascal development team.
    Some parts taken from
       Marcel Timmermans - Modula 2 Compiler
       Nils Sjoholm - Amiga porter

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

{ Things left to do :                                          }
{   - Fix randomize                                            }
{   - Fix DOSError result variable to conform to IOResult of   }
{      Turbo Pascal                                            }

{$I os.inc}

  interface

    { used for single computations }
    const BIAS4 = $7f-1;

    {$I systemh.inc}

    {$I heaph.inc}

const
  UnusedHandle    : longint = -1; 
  StdInputHandle  : longint = 0;
  StdOutputHandle : longint = 0;
  StdErrorHandle  : longint = 0; 

 _ExecBase:longint = $4;
 _WorkbenchMsg : longint = 0;
 intuitionname : pchar = 'intuition.library';
 dosname : pchar = 'dos.library';
 utilityname : pchar = 'utility.library';

 _IntuitionBase : pointer = nil;       { intuition library pointer }
 _DosBase       : pointer = nil;       { DOS library pointer       }
 _UtilityBase   : pointer = nil;       { utiity library pointer    }

 _LVOFindTask          = -294;
 _LVOWaitPort          = -384;
 _LVOGetMsg            = -372;
 _LVOOpenLibrary       = -552;
 _LVOCloseLibrary      = -414;
 _LVOClose             = -36;
 _LVOOpen              = -30;
 _LVOIoErr             = -132;
 _LVOSeek              = -66;
 _LVODeleteFile        = -72;
 _LVORename            = -78;
 _LVOWrite             = -48;
 _LVORead              = -42;
 _LVOCreateDir         = -120;
 _LVOSetCurrentDirName = -558;
 _LVOGetCurrentDirName = -564;
 _LVOInput             = -54;
 _LVOOutput            = -60;


  implementation

    {$I system.inc}
    {$I lowmath.inc}

    type
       plongint = ^longint;


{$S-}
    PROCEDURE St1(stack_size: longint);[public,alias: 'STACKCHECK'];
    begin
     asm
         { called when trying to get local stack }
         { if the compiler directive $S is set   }
         { it must preserve all registers !!     }
        ADD.L   A7,D0     {  stacksize + actual stackpointer }
        MOVE.L  _ExecBase,A0
        MOVE.L  276(A0),A0       { ExecBase.thisTask }
        CMP.L   58(A0),D0        { Task.SpLower      }
        BGT     @Ok
        move.l  #202,d0
        jsr     HALT_ERROR       { stack overflow    }
    @Ok:
     end;
   end;


    procedure CloseLibrary(lib : pointer); Assembler;
    {  Close the library pointed to in lib }
    asm
      MOVE.L  A6,-(A7)
      MOVE.L  _ExecBase,A6
      MOVE.L  lib,a1
      JSR     _LVOCloseLibrary(A6)
      MOVE.L  (A7)+,A6
   end;


   Function KickVersion: word; assembler;
   asm
     move.l  _ExecBase, a0       { Get Exec Base                           }
     move.l  20(a0), d0          { Return version - version at this offset }
   end;

    procedure halt(errnum : byte);
      begin
         do_exit;
         flush(stderr);
         { close the libraries }
         If _UtilityBase <> nil then
         Begin
           CloseLibrary(_UtilityBase);
         end;
         If _DosBase <> nil then
         Begin
           CloseLibrary(_DosBase);
         end;
         If _IntuitionBase <> nil then
         Begin
           CloseLibrary(_IntuitionBase);
         end;
         asm
            clr.l   d0
            move.b  errnum,d0
            move.l  STKPTR,sp
            rts
         end;
      end;

    function paramcount : longint; assembler;
    asm
            clr.l   d0
            move.w  __ARGC,d0
            sub.w   #1,d0
    end;

    function paramstr(l : longint) : string;

      function args : pointer; assembler;
      asm
         move.l __ARGS,d0
      end;

      var
         p : ^pchar;

      begin
         if (l>=0) and (l<=paramcount) then
           begin
              p:=args;
              paramstr:=strpas(p[l]);
           end
         else paramstr:='';
      end;

    procedure randomize;

      var
         hl : longint;

      begin
         asm
           { !!!!!!! }
         end;
         randseed:=hl;
      end;

  { This routine is used to grow the heap.  }
  { But here we do a trick, we say that the }
  { heap cannot be regrown!                 }
  function sbrk( size: longint): longint;
  { on exit -1 = if fails.               }
  Begin
   sbrk:=-1;
  end;



{$I heap.inc}


{****************************************************************************
                          Low Level File Routines
 ****************************************************************************}

procedure do_close(h : longint);
begin
  asm
            move.l  h,d1
            move.l  a6,d6              { save a6 }
            move.l  _DOSBase,a6
            jsr     _LVOClose(a6)
            move.l  d6,a6              { restore a6 }
  end;
end;


procedure do_erase(p : pchar);
begin
  asm
           move.l  a6,d6               { save a6 }

           move.l  _DOSBase,a6
           move.l  p,d1
           jsr     _LVODeleteFile(a6)
           tst.l   d0                  { zero = failure }
           bne     @noerror

           jsr     _LVOIoErr(a6)
           move.l  d0,InOutRes

         @noerror:
           move.l  d6,a6               { restore a6 }
  end;
end;


procedure do_rename(p1,p2 : pchar);
begin
  asm
           move.l  a6,d6                  { save a6 }
           move.l  d2,-(sp)               { save d2 }

           move.l  p1,d1
           move.l  p2,d2
           move.l  _DOSBase,a6
           jsr     _LVORename(a6)
           move.l  (sp)+,d2               { restore d2 }
           tst.l   d0
           bne     @dosreend              { if zero = error }
           jsr     _LVOIoErr(a6)
           move.l  d0,InOutRes
         @dosreend:
           move.l  d6,a6                  { restore a6 }
  end;
end;


function do_write(h,addr,len : longint) : longint;
begin
  asm
            move.l  a6,d6

            movem.l d2/d3,-(sp)
            move.l  _DOSBase,a6
            move.l  h,d1
            move.l  addr,d2
            move.l  len,d3
            jsr     _LVOWrite(a6)
            movem.l (sp)+,d2/d3

            tst.l   d0
            bne     @doswrend              { if zero = error }
            jsr     _LVOIoErr(a6)
            move.l  d0,InOutRes
            bra     @doswrend2
          @doswrend:
            move.l  d0,@RESULT
          @doswrend2:
            move.l  d6,a6
  end;
end;


function do_read(h,addr,len : longint) : longint;
begin
  asm
            move.l  a6,d6

            movem.l d2/d3,-(sp)
            move.l  _DOSBase,a6
            move.l  h,d1
            move.l  addr,d2
            move.l  len,d3
            jsr     _LVORead(a6)
            movem.l (sp)+,d2/d3

            tst.l   d0
            bne     @doswrend              { if zero = error }
            jsr     _LVOIoErr(a6)
            move.l  d0,InOutRes
            bra     @doswrend2
          @doswrend:
            move.l  d0,@RESULT
          @doswrend2:
            move.l  d6,a6
  end;
end;


function do_filepos(handle : longint) : longint;
begin
  asm
             move.l  a6,d6

             move.l  handle,d1
             move.l  d2,-(sp)
             move.l  d3,-(sp)              { save registers              }

             clr.l   d2                    { offset 0 }
             move.l  #0,d3                 { OFFSET_CURRENT }
             jsr    _LVOSeek(a6)

             move.l  (sp)+,d3              { restore registers }
             move.l  (sp)+,d2
             cmp.l   #-1,d0                { is there a file access error? }
             bne     @noerr
             jsr     _LVOIoErr(a6)
             move.l  d0,InOutRes
             bra     @fposend
      @noerr:
             move.l  d0,@Result
      @fposend:
             move.l  d6,a6                 { restore a6 }
  end;
end;


procedure do_seek(handle,pos : longint);
begin
  asm
             move.l  a6,d6

             move.l  handle,d1
             move.l  d2,-(sp)
             move.l  d3,-(sp)              { save registers              }

             move.l  pos,d2
             move.l  #-1,d3                 { OFFSET_BEGINNING }
             jsr    _LVOSeek(a6)

             move.l  (sp)+,d3              { restore registers }
             move.l  (sp)+,d2
             cmp.l   #-1,d0                { is there a file access error? }
             bne     @noerr
             jsr     _LVOIoErr(a6)
             move.l  d0,InOutRes
             bra     @seekend
      @noerr:
      @seekend:
             move.l  d6,a6                 { restore a6 }
  end;
end;


function do_seekend(handle:longint):longint;
begin
  asm
             { seek from end of file }
             move.l  a6,d6

             move.l  handle,d1
             move.l  d2,-(sp)
             move.l  d3,-(sp)              { save registers              }

             clr.l   d2
             move.l  #1,d3                 { OFFSET_END }
             jsr    _LVOSeek(a6)

             move.l  (sp)+,d3              { restore registers }
             move.l  (sp)+,d2
             cmp.l   #-1,d0                { is there a file access error? }
             bne     @noerr
             jsr     _LVOIoErr(a6)
             move.l  d0,InOutRes
             bra     @seekend
      @noerr:
             move.l  d0,@Result
      @seekend:
             move.l  d6,a6                 { restore a6 }
  end;
end;


function do_filesize(handle : longint) : longint;
var
  aktfilepos : longint;
begin
   aktfilepos:=do_filepos(handle);
   do_filesize:=do_seekend(handle);
   do_seek(handle,aktfilepos);
end;


procedure do_truncate (handle,pos:longint);
begin
  {!!!!!!!!!!!!}
end;


procedure do_open(var f;p:pchar;flags:longint);
{
  filerec and textrec have both handle and mode as the first items so
  they could use the same routine for opening/creating.
  when (flags and $10)   the file will be append
  when (flags and $100)  the file will be truncate/rewritten
  when (flags and $1000) there is no check for close (needed for textfiles)
}
var
  i : longint;
  oflags: longint;
begin
 { close first if opened }
  if ((flags and $1000)=0) then
   begin
     case filerec(f).mode of
      fminput,fmoutput,fminout : Do_Close(filerec(f).handle);
      fmclosed : ;
     else
      begin
        inoutres:=102; {not assigned}
        exit;
      end;
     end;
   end;
{ reset file handle }
  filerec(f).handle:=UnusedHandle;
  oflags:=$04;
{ convert filemode to filerec modes }
  case (flags and 3) of
   0 : begin
         filerec(f).mode:=fminput;
         oflags:=$01;
       end;
   1 : filerec(f).mode:=fmoutput;
   2 : filerec(f).mode:=fminout;
  end;
  if (flags and $100)<>0 then
   begin
     filerec(f).mode:=fmoutput;
     oflags:=$02;
   end
  else
   if (flags and $10)<>0 then
    begin
      filerec(f).mode:=fmoutput;
      oflags:=$04;
    end;
{ empty name is special }
  if p[0]=#0 then
   begin
     case filerec(f).mode of
       fminput : filerec(f).handle:=StdInputHandle;
      fmappend,
      fmoutput : begin
                   filerec(f).handle:=StdOutputHandle;
                   filerec(f).mode:=fmoutput; {fool fmappend}
                 end;
     end;
     exit;
   end;
    { THE AMIGA AUTOMATICALLY OPENS IN READ-WRITE MODE }
    { FOR ALL CASES.                                   }
         asm
             move.l  a6,d6                  { save a6 }

             move.l  f,d1
             move.l  #1004,d0               { MODE_READWRITE }
             move.l  _DOSBase,a6
             jsr     _LVOOpen(a6)
             tst.l   d0
             bne     @noopenerror           { on zero an error occured }
             jsr     _LVOIoErr(a6)
             move.l  d0,InOutRes
             bra     @openend
          @noopenerror:
             move.l  d0,i
          @openend:

             move.l  d6,a6                 { restore a6 }
         end;
    filerec(f).handle:=i;
    if (flags and $10)<>0 then
       do_seekend(filerec(f).handle);
end;

{*****************************************************************************
                           UnTyped File Handling
*****************************************************************************}

{$i file.inc}

{*****************************************************************************
                           Typed File Handling
*****************************************************************************}

{$i typefile.inc}

{*****************************************************************************
                           Text File Handling
*****************************************************************************}

{$i text.inc}

{*****************************************************************************
                           Directory Handling
*****************************************************************************}
      
procedure mkdir(const s : string);
var
  buffer : array[0..255] of char;
begin
  move(s[1],buffer,length(s));
  buffer[length(s)]:=#0;
  asm
        move.l  a6,d6
        move.l  _DosBase,a6
        lea     buffer,a0
        move.l  a0,d1
        jsr     _LVOCreateDir(a6)
        tst.l   d0
        bne     @noerror
        move.l  #1,InOutRes
@noerror:
        move.l  d6,a6
  end;
end;


procedure rmdir(const s : string);
var
  buffer : array[0..255] of char;
begin
  move(s[1],buffer,length(s));
  buffer[length(s)]:=#0;
  do_erase(buffer);
end;
  

procedure chdir(const s : string);
var
  buffer : array[0..255] of char;
begin
  move(s[1],buffer,length(s));
  buffer[length(s)]:=#0;
  asm
        move.l  a6,d6
        move.l  _DosBase,a6
        lea     buffer,a1
        move.l  a1,d1
        jsr     _LVOSetCurrentDirName(a6)
        bne     @noerror
        move.l  #1,InOutRes
@noerror:
        move.l  d6,a6
  end;
end;


procedure getdir(drivenr : byte;var dir : string);
var
  l : longint;
  p : pointer;
begin
  l:=length(dir);
  if drivenr <> 0 then
   begin
     dir:='';
     exit;
   end;
  p:=@dir[1];
  if l <> 0 then         { workaround for v36 bug }
   Begin
     asm
        move.l  a6,d6
        move.l  _DosBase,a6
        move.l  p,d1
        move.l  l,d2
        jsr     _LVOGetCurrentDirName(a6)
        bne     @noerror
        move.l  #1,InOutRes
      @noerror:
        move.l  d6,a6
     end;
   end
  else
   dir:='';
{ upcase the string (FPKPascal function) }
  dir:=upcase(dir);
end;

        
{*****************************************************************************
                         SystemUnit Initialization
*****************************************************************************}

Procedure Startup; Assembler;
asm
    move.l  a6,d6         { save a6             }

    move.l  (4),a6        { get ExecBase pointer }
    move.l  a6,_ExecBase
    suba.l  a1,a1
    jsr     _LVOFindTask(a6)
    move.l  d0,a0
    { Check the stack value }

    {   are we running from a CLI?             }

    tst.l   172(a0)         { 172 = pr_CLI     }
    bne     @fromCLI

    { we do not support Workbench yet ..       }
    move.l  d6,a6           { restore a6       }
    move.l  #1,d0
    jsr     HALT_ERROR

@fromCLI:
    {  Open the following libraries:            }
    {   Intuition.library                       }
    {   dos.library                             }

    moveq.l  #0,d0
    lea      intuitionname,a1
    jsr      _LVOOpenLibrary(a6)
    move.l   d0,_IntuitionBase
    beq      @exitprg

    moveq.l  #0,d0
    lea      utilityname,a1
    jsr      _LVOOpenLibrary(a6)
    move.l   d0,_UtilityBase
    beq      @exitprg

    moveq.l  #0,d0
    lea      dosname,a1
    jsr      _LVOOpenLibrary(a6)
    move.l   d0,_DOSBase
    beq      @exitprg

    { Find standard input and output               }
    { for CLI                                      }
@OpenFiles:
    move.l  _DOSBase,a6
    jsr     _LVOInput(a6)        { get standard in                   }
    move.l  d0, StdInputHandle   { save standard Input handle        }
{    move.l  d0,d1               }{ set up for next call              }
{   jsr     _LVOIsInteractive(a6)}{ is it interactive?             }
{   move.l  #_Input,a0          }{ get file record again             }
{   move.b  d0,INTERACTIVE(a0)  }{ set flag                          }
{   beq     StdInNotInteractive }{ skip this if not interactive    }
{   move.l  BUFFER(a0),a1       }{ get buffer address                }
{   add.l   #1,a1               }{ make end one byte further on      }
{   move.l  a1,MAX(a0)          }{ set buffer size                   }
{   move.l  a1,CURRENT(a0)      }{ will need a read                  }
    bra     @OpenStdOutput
@StdInNotInteractive
{    jsr _p%FillBuffer     }      { fill the buffer                   }
@OpenStdOutput
    jsr     _LVOOutput(a6)      { get ouput file handle             }
    move.l  d0,StdOutputHandle  { get file record                   }
    bra     @startupend
{    move.l  d0,d1             }  { set up for call                   }
{    jsr _LVOIsInteractive(a6) }  { is it interactive?                }
{    move.l  #_Output,a0       }  { get file record                   }
{    move.b  d0,INTERACTIVE(a0)}  { set flag                          }
@exitprg:
     move.l d6,a6                 { restore a6                        }
     move.l #219,d0
     jsr    HALT_ERROR
@startupend:
     move.l d6,a6                 { restore a6                        }
end;


procedure OpenStdIO(var f:text;mode:word;hdl:longint);
begin
  Assign(f,'');
  TextRec(f).Handle:=hdl;
  TextRec(f).Mode:=mode;
  TextRec(f).InOutFunc:=@FileInOutFunc;
  TextRec(f).FlushFunc:=@FileInOutFunc;
  TextRec(f).Closefunc:=@fileclosefunc;
end;


begin
{ Startup }
  Startup;
  { Only AmigaOS v2.04 or greater is supported }
  If KickVersion < 36 then
   Begin
     WriteLn('v36 or greater of Kickstart required.');
     Halt(1);
   end;
{ Initialize ExitProc }
  ExitProc:=Nil;
{ to test stack depth }
  loweststack:=maxlongint;
{ Setup heap }
  InitHeap;
{ Setup stdin, stdout and stderr }
  OpenStdIO(Input,fmInput,StdInputHandle);
  OpenStdIO(Output,fmOutput,StdOutputHandle);
  OpenStdIO(StdErr,fmOutput,StdErrorHandle);
{ Reset IO Error }
  InOutRes:=0;
end.


{
  $Log$
  Revision 1.1  1998-03-25 11:18:47  root
  Initial revision

  Revision 1.14  1998/03/21 04:20:09  carl
    * correct ExecBase pointer (from Nils Sjoholm)
    * correct OpenLibrary vector (from Nils Sjoholm)

  Revision 1.13  1998/03/14 21:34:32  carl
    * forgot to save a6 in Startup routine

  Revision 1.12  1998/02/24 21:19:42  carl
  *** empty log message ***

  Revision 1.11  1998/02/23 02:22:49  carl
    * bugfix if linking problems

  Revision 1.9  1998/02/06 16:34:32  carl
    + do_open is now standard with other platforms

  Revision 1.8  1998/02/02 15:01:45  carl
    * fixed bug with opening library versions (from Nils Sjoholm)

  Revision 1.7  1998/01/31 19:35:19  carl
    + added opening of utility.library

  Revision 1.6  1998/01/29 23:20:54  peter
    - Removed Backslash convert

  Revision 1.5  1998/01/27 10:55:04  peter
    * Amiga uses / not \, so change AllowSlash -> AllowBackSlash

  Revision 1.4  1998/01/25 21:53:20  peter
    + Universal Handles support for StdIn/StdOut/StdErr
    * Updated layout of sysamiga.pas

  Revision 1.3  1998/01/24 21:09:53  carl
    + added missing input/output function pointers

  Revision 1.2  1998/01/24 14:08:25  carl
    * RunError 217 --> RunError 219 (cannot open lib)
    + Standard Handle names implemented

  Revision 1.1  1998/01/24 05:12:15  carl
    + initial revision, some stuff still missing though.
      (and as you might imagine ... untested :))
}