{ $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 var Initial: boolean; {$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 !! } move.l stack_size, d0 add.l sp,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); { Close the library pointed to in lib } Begin asm MOVE.L A6,-(A7) MOVE.L lib,a1 MOVE.L _ExecBase,A6 JSR _LVOCloseLibrary(A6) MOVE.L (A7)+,A6 end; 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 { WE can only FLUSH the stdio } { if the handles have correctly } { been set. } { No exit procedures exist } { if in initial state } If NOT Initial then Begin do_exit; flush(stderr); end; { 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 p,d1 move.l _DOSBase,a6 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 if len <= 0 then Begin do_write:=0; exit; end; asm move.l a6,d6 movem.l d2/d3,-(sp) move.l h,d1 { we must of course set up the } move.l addr,d2 { parameters BEFORE getting } move.l len,d3 { _DOSBase } move.l _DOSBase,a6 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: { we must restore the base pointer before setting the result } move.l d6,a6 move.l d0,@RESULT bra @end @doswrend2: move.l d6,a6 @end: end; end; function do_read(h,addr,len : longint) : longint; begin if len <= 0 then Begin do_read:=0; exit; end; asm move.l a6,d6 movem.l d2/d3,-(sp) move.l h,d1 { we must set up aparamters BEFORE } move.l addr,d2 { setting up a6 for the OS call } move.l len,d3 move.l _DOSBase,a6 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: { to store a result for the function } { we must of course first get back the} { base pointer! } move.l d6,a6 move.l d0,@RESULT bra @end @doswrend2: move.l d6,a6 @end: 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 } move.l _DOSBase,a6 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 d6,a6 { restore a6 } move.l d0,@Result bra @end @fposend: move.l d6,a6 { restore a6 } @end: 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 } move.l _DOSBase,a6 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 } move.l _DOSBase,a6 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 d6,a6 { restore a6 } move.l d0,@Result bra @end @seekend: move.l d6,a6 { restore a6 } @end: 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 d6,a6 { restore a6 } move.l d0,i { we need the base pointer to access this variable } bra @end @openend: move.l d6,a6 { restore a6 } @end: 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 { we must load the parameters BEFORE setting up the } { OS call with a6 } lea buffer,a0 move.l a0,d1 move.l _DosBase,a6 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 lea buffer,a1 move.l a1,d1 move.l _DosBase,a6 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 p,d1 move.l l,d2 move.l _DosBase,a6 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 move.l intuitionname,a1 { directly since it is a pchar } jsr _LVOOpenLibrary(a6) move.l d0,_IntuitionBase beq @exitprg moveq.l #0,d0 move.l utilityname,a1 { directly since it is a pchar } jsr _LVOOpenLibrary(a6) move.l d0,_UtilityBase beq @exitprg moveq.l #0,d0 move.l dosname,a1 { directly since it is a pchar } 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 { Initial state is on -- in case of RunErrors before the i/o handles are } { ok. } Initial:=TRUE; { Initialize ExitProc } ExitProc:=Nil; Startup; { to test stack depth } loweststack:=maxlongint; { Setup heap } InitHeap; { Setup stdin, stdout and stderr } OpenStdIO(Input,fmInput,StdInputHandle); OpenStdIO(Output,fmOutput,StdOutputHandle); { The Amiga does not seem to have a StdError } { handle, therefore make the StdError handle } { equal to the StdOutputHandle. } StdErrorHandle := StdOutputHandle; OpenStdIO(StdErr,fmOutput,StdErrorHandle); { Now Handles and function handlers are setup } { correctly. } Initial:=FALSE; { Reset IO Error } InOutRes:=0; { Startup } { Only AmigaOS v2.04 or greater is supported } If KickVersion < 36 then Begin WriteLn('v36 or greater of Kickstart required.'); Halt(1); end; end. { $Log$ Revision 1.2 1998-05-25 12:08:49 carl * Handles now proprely setup * Correct Exit code on init failure * Library pointer now ok (Thanks to Nils Sjoholm) * OpenStdError was never initialized * ;assembler; routines problems bugfixed * stackcheck routine fix Revision 1.1.1.1 1998/03/25 11:18:47 root * Restored version 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 :)) }