{ $Id$ This file is part of the Free Pascal run time library. Copyright (c) 1993,98 by Carl Eric Codere Some parts taken from Marcel Timmermans - Modula 2 Compiler Nils Sjoholm - Amiga porter Matthew Dillon - Dice C (with his kind permission) dillon@backplane.com 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; {--------------------------------------------------------------------} { LEFT TO DO: } {--------------------------------------------------------------------} { o GetDir with different drive numbers } {--------------------------------------------------------------------} {$I os.inc} { AmigaOS uses character #10 as eoln only } {$DEFINE SHORT_LINEBREAK} 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; _IntuitionBase : pointer = nil; { intuition library pointer } _DosBase : pointer = nil; { DOS library pointer } _UtilityBase : pointer = nil; { utiity library pointer } { Required for crt unit } function do_read(h,addr,len : longint) : longint; function do_write(h,addr,len : longint) : longint; implementation const intuitionname : pchar = 'intuition.library'; dosname : pchar = 'dos.library'; utilityname : pchar = 'utility.library'; argc : longint = 0; { AmigaOS does not autoamtically deallocate memory on program termination } { therefore we have to handle this manually. This is a list of allocated } { pointers from the OS, we cannot use a linked list, because the linked } { list itself uses the HEAP! } pointerlist : array[1..8] of longint = (0,0,0,0,0,0,0,0); {$I exec.inc} TYPE TDateStamp = packed record ds_Days : Longint; { Number of days since Jan. 1, 1978 } ds_Minute : Longint; { Number of minutes past midnight } ds_Tick : Longint; { Number of ticks past minute } end; PDateStamp = ^TDateStamp; PFileInfoBlock = ^TfileInfoBlock; TFileInfoBlock = packed record fib_DiskKey : Longint; fib_DirEntryType : Longint; { Type of Directory. If < 0, then a plain file. If > 0 a directory } fib_FileName : Array [0..107] of Char; { Null terminated. Max 30 chars used for now } fib_Protection : Longint; { bit mask of protection, rwxd are 3-0. } fib_EntryType : Longint; fib_Size : Longint; { Number of bytes in file } fib_NumBlocks : Longint; { Number of blocks in file } fib_Date : TDateStamp; { Date file last changed } fib_Comment : Array [0..79] of Char; { Null terminated comment associated with file } fib_Reserved : Array [0..35] of Char; end; TProcess = packed record pr_Task : TTask; pr_MsgPort : TMsgPort; { This is BPTR address from DOS functions } {126} pr_Pad : Word; { Remaining variables on 4 byte boundaries } {128} pr_SegList : Pointer; { Array of seg lists used by this process } {132} pr_StackSize : Longint; { Size of process stack in bytes } {136} pr_GlobVec : Pointer; { Global vector for this process (BCPL) } {140} pr_TaskNum : Longint; { CLI task number of zero if not a CLI } {144} pr_StackBase : BPTR; { Ptr to high memory end of process stack } {148} pr_Result2 : Longint; { Value of secondary result from last call } {152} pr_CurrentDir : BPTR; { Lock associated with current directory } {156} pr_CIS : BPTR; { Current CLI Input Stream } {160} pr_COS : BPTR; { Current CLI Output Stream } {164} pr_ConsoleTask : Pointer; { Console handler process for current window} {168} pr_FileSystemTask : Pointer; { File handler process for current drive } {172} pr_CLI : BPTR; { pointer to ConsoleLineInterpreter } pr_ReturnAddr : Pointer; { pointer to previous stack frame } pr_PktWait : Pointer; { Function to be called when awaiting msg } pr_WindowPtr : Pointer; { Window for error printing } { following definitions are new with 2.0 } pr_HomeDir : BPTR; { Home directory of executing program } pr_Flags : Longint; { flags telling dos about process } pr_ExitCode : Pointer; { code to call on exit of program OR NULL } pr_ExitData : Longint; { Passed as an argument to pr_ExitCode. } pr_Arguments : PChar; { Arguments passed to the process at start } pr_LocalVars : TMinList; { Local environment variables } pr_ShellPrivate : Longint; { for the use of the current shell } pr_CES : BPTR; { Error stream - IF NULL, use pr_COS } end; PProcess = ^TProcess; { AmigaOS does not automatically close opened files on exit back to } { the operating system, therefore as a precuation we close all files } { manually on exit. } PFileList = ^TFileList; TFileList = record { no packed, must be correctly aligned } Handle: longint; { Handle to file } next: pfilelist; { Next file in list } closed: boolean; { TRUE=file already closed } end; Const CTRL_C = 20; { Error code on CTRL-C press } SIGBREAKF_CTRL_C = $1000; { CTRL-C signal flags } _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; _LVOUnLock = -90; _LVOLock = -84; _LVOCurrentDir = -126; _LVONameFromLock = -402; _LVONameFromFH = -408; _LVOGetProgramName = -576; _LVOGetProgramDir = -600; _LVODupLock = -96; _LVOExamine = -102; _LVOParentDir = -210; _LVOSetFileSize = -456; _LVOSetSignal = -306; _LVOAllocVec = -684; _LVOFreeVec = -690; { Errors from IoErr(), etc. } ERROR_NO_FREE_STORE = 103; ERROR_TASK_TABLE_FULL = 105; ERROR_BAD_TEMPLATE = 114; ERROR_BAD_NUMBER = 115; ERROR_REQUIRED_ARG_MISSING = 116; ERROR_KEY_NEEDS_ARG = 117; ERROR_TOO_MANY_ARGS = 118; ERROR_UNMATCHED_QUOTES = 119; ERROR_LINE_TOO_LONG = 120; ERROR_FILE_NOT_OBJECT = 121; ERROR_INVALID_RESIDENT_LIBRARY = 122; ERROR_NO_DEFAULT_DIR = 201; ERROR_OBJECT_IN_USE = 202; ERROR_OBJECT_EXISTS = 203; ERROR_DIR_NOT_FOUND = 204; ERROR_OBJECT_NOT_FOUND = 205; ERROR_BAD_STREAM_NAME = 206; ERROR_OBJECT_TOO_LARGE = 207; ERROR_ACTION_NOT_KNOWN = 209; ERROR_INVALID_COMPONENT_NAME = 210; ERROR_INVALID_LOCK = 211; ERROR_OBJECT_WRONG_TYPE = 212; ERROR_DISK_NOT_VALIDATED = 213; ERROR_DISK_WRITE_PROTECTED = 214; ERROR_RENAME_ACROSS_DEVICES = 215; ERROR_DIRECTORY_NOT_EMPTY = 216; ERROR_TOO_MANY_LEVELS = 217; ERROR_DEVICE_NOT_MOUNTED = 218; ERROR_SEEK_ERROR = 219; ERROR_COMMENT_TOO_BIG = 220; ERROR_DISK_FULL = 221; ERROR_DELETE_PROTECTED = 222; ERROR_WRITE_PROTECTED = 223; ERROR_READ_PROTECTED = 224; ERROR_NOT_A_DOS_DISK = 225; ERROR_NO_DISK = 226; ERROR_NO_MORE_ENTRIES = 232; { added for 1.4 } ERROR_IS_SOFT_LINK = 233; ERROR_OBJECT_LINKED = 234; ERROR_BAD_HUNK = 235; ERROR_NOT_IMPLEMENTED = 236; ERROR_RECORD_NOT_LOCKED = 240; ERROR_LOCK_COLLISION = 241; ERROR_LOCK_TIMEOUT = 242; ERROR_UNLOCK_ERROR = 243; var Initial: boolean; { Have successfully opened Std I/O } errno : word; { AmigaOS IO Error number } FileList : pFileList; { Linked list of opened files } old_exit: Pointer; FromHalt : boolean; OrigDir : Longint; { Current lock on original startup directory } {$I system.inc} {$I lowmath.inc} { ************************ AMIGAOS STUB ROUTINES ************************* } procedure DateStamp(var ds : tDateStamp); begin asm MOVE.L A6,-(A7) MOVE.L ds,d1 { LAST THING TO SETUP SHOULD BE A6, otherwise you can } { not accept local variable, nor any parameters! :) } MOVE.L _DOSBase,A6 JSR -192(A6) MOVE.L (A7)+,A6 end; end; { UNLOCK the BPTR pointed to in L } Procedure Unlock(alock: longint); Begin asm move.l alock,d1 move.l a6,d6 { save base pointer } move.l _DosBase,a6 jsr _LVOUnlock(a6) move.l d6,a6 { restore base pointer } end; end; { Change to the directory pointed to in the lock } Function CurrentDir(alock : longint) : longint; Begin asm move.l alock,d1 move.l a6,d6 { save base pointer } move.l _DosBase,a6 jsr _LVOCurrentDir(a6) move.l d6,a6 { restore base pointer } move.l d0,@Result end; end; { Duplicate a lock } Function DupLock(alock: longint): Longint; Begin asm move.l alock,d1 move.l a6,d6 { save base pointer } move.l _DosBase,a6 jsr _LVODupLock(a6) move.l d6,a6 { restore base pointer } move.l d0,@Result end; end; { Returns a lock on the directory was loaded from } Function GetProgramLock: longint; Begin asm move.l a6,d6 { save base pointer } move.l _DosBase,a6 jsr _LVOGetProgramDir(a6) move.l d6,a6 { restore base pointer } move.l d0,@Result end; end; Function Examine(alock :longint; var fib: TFileInfoBlock) : Boolean; Begin asm move.l d2,-(sp) move.l fib,d2 { pointer to FIB } move.l alock,d1 move.l a6,d6 { save base pointer } move.l _DosBase,a6 jsr _LVOExamine(a6) move.l d6,a6 { restore base pointer } tst.l d0 bne @success bra @end @success: move.b #1,d0 @end: move.b d0,@Result move.l (sp)+,d2 end; end; { Returns the parent directory of a lock } Function ParentDir(alock : longint): longint; Begin asm move.l alock,d1 move.l a6,d6 { save base pointer } move.l _DosBase,a6 jsr _LVOParentDir(a6) move.l d6,a6 { restore base pointer } move.l d0,@Result end; end; Function FindTask(p : PChar): PProcess; Begin asm move.l a6,d6 { Save base pointer } move.l p,d0 move.l d0,a1 move.l _ExecBase,a6 jsr _LVOFindTask(a6) move.l d6,a6 { Restore base pointer } move.l d0,@Result end; end; {$S-} Procedure stack_check; assembler; { Check for local variable allocation } { On Entry -> d0 : size of local stack we are trying to allocate } asm XDEF STACKCHECK move.l sp,d1 { get value of stack pointer } { We must add some security, because Writing the RunError strings } { requires a LOT of stack space (at least 1030 bytes!) } add.l #2048,d0 sub.l d0,d1 { sp - stack_size } move.l _ExecBase,a0 move.l 276(A0),A0 { ExecBase.thisTask } { if allocated stack_pointer - splower <= 0 then stack_ovf } cmp.l 58(A0),D1 { Task.SpLower } bgt @Ok move.l #202,d0 jsr HALT_ERROR { stack overflow } @Ok: end; { This routine from EXEC determines if the Ctrl-C key has } { been used since the last call to I/O routines. } { Use to halt the program. } { Returns the state of the old signals. } Function SetSignal(newSignal: longint; SignalMask: longint): longint; Begin asm move.l newSignal,d0 move.l SignalMask,d1 move.l a6,d6 { save Base pointer into scratch register } move.l _ExecBase,a6 jsr _LVOSetSignal(a6) move.l d6,a6 move.l d0,@Result end; end; Function AllocVec(bytesize: longint; attributes: longint):longint; Begin asm move.l bytesize,d0 move.l attributes,d1 move.l a6,d6 { save Base pointer into scratch register } move.l _ExecBase,a6 jsr _LVOAllocVec(a6) move.l d6,a6 move.l d0,@Result end; end; Procedure FreeVec(p: longint); Begin asm move.l p,a1 move.l a6,d6 { save Base pointer into scratch register } move.l _ExecBase,a6 jsr _LVOFreeVec(a6) move.l d6,a6 end; end; { Converts an AMIGAOS error code to a TP compatible error code } Procedure Error2InOut; Begin case errno of ERROR_BAD_NUMBER, ERROR_ACTION_NOT_KNOWN, ERROR_NOT_IMPLEMENTED : InOutRes := 1; ERROR_OBJECT_NOT_FOUND : InOutRes := 2; ERROR_DIR_NOT_FOUND : InOutRes := 3; ERROR_DISK_WRITE_PROTECTED : InOutRes := 150; ERROR_OBJECT_WRONG_TYPE : InOutRes := 151; ERROR_OBJECT_EXISTS, ERROR_DELETE_PROTECTED, ERROR_WRITE_PROTECTED, ERROR_READ_PROTECTED, ERROR_OBJECT_IN_USE, ERROR_DIRECTORY_NOT_EMPTY : InOutRes := 5; ERROR_NO_MORE_ENTRIES : InOutRes := 18; ERROR_RENAME_ACROSS_DEVICES : InOutRes := 17; ERROR_DISK_FULL : InOutRes := 101; ERROR_INVALID_RESIDENT_LIBRARY : InoutRes := 153; ERROR_BAD_HUNK : InOutRes := 153; ERROR_NOT_A_DOS_DISK : InOutRes := 157; ERROR_NO_DISK, ERROR_DISK_NOT_VALIDATED, ERROR_DEVICE_NOT_MOUNTED : InOutRes := 152; ERROR_SEEK_ERROR : InOutRes := 156; ERROR_LOCK_COLLISION, ERROR_LOCK_TIMEOUT, ERROR_UNLOCK_ERROR, ERROR_INVALID_LOCK, ERROR_INVALID_COMPONENT_NAME, ERROR_BAD_STREAM_NAME, ERROR_FILE_NOT_OBJECT : InOutRes := 6; else InOutres := errno; end; errno:=0; 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.w 20(a0), d0 { Return version - version at this offset } end; { ************************ AMIGAOS SUPP ROUTINES ************************* } (* Procedure CloseList(p: pFileList);*) (***********************************************************************) (* PROCEDURE CloseList *) (* Description: This routine each time the program is about to *) (* terminate, it closes all opened file handles, as this is not *) (* handled by the operating system. *) (* p -> Start of linked list of opened files *) (***********************************************************************) (* var hp: pFileList; hp1: pFileList; h: longint; Begin hp:=p; while Assigned(hp) do Begin if NOT hp^.closed then Begin h:=hp^.handle; if (h <> StdInputHandle) and (h <> StdOutputHandle) and (h <> StdErrorHandle) then Begin { directly close file here, it is faster then doing } { it do_close. } 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; end; hp1:=hp; hp:=hp^.next; dispose(hp1); end; end;*) (* Procedure AddToList(var p: pFileList; h: longint);*) (***********************************************************************) (* PROCEDURE AddToList *) (* Description: Adds a node to the linked list of files. *) (* *) (* p -> Start of File list linked list, if not allocated allocates *) (* it for you. *) (* h -> handle of file to add *) (***********************************************************************) (* var hp: pFileList; hp1: pFileList; Begin if p = nil then Begin new(p); p^.handle:=h; p^.closed := FALSE; p^.next := nil; exit; end; hp:=p; { Find last list in entry } while assigned(hp) do Begin if hp^.next = nil then break; hp:=hp^.next; end; { Found last list in entry then add it to the list } new(hp1); hp^.next:=hp1; hp1^.next:=nil; hp1^.handle:=h; hp1^.closed:=FALSE; end; Procedure SetClosedList(var p: pFileList; h: longint); { Set the file flag to closed if the file is being closed } var hp: pFileList; Begin hp:=p; while assigned(hp) do Begin if hp^.handle = h then Begin hp^.closed:=TRUE; break; end; hp:=hp^.next; end; end;*) Procedure ExitCall; var i: byte; Begin { We must remove the CTRL-C FALG here because halt } { may call I/O routines, which in turn might call } { halt, so a recursive stack crash } IF (SetSignal(0,0) AND SIGBREAKF_CTRL_C) <> 0 THEN SetSignal(0,SIGBREAKF_CTRL_C); { Close remaining opened files } { CloseList(FileList); } if (OrigDir <> 0) then Begin Unlock(CurrentDir(OrigDir)); OrigDir := 0; end; { Is this a normal exit - YES, close libs } IF NOT FromHalt then Begin { close the libraries } If _UtilityBase <> nil then CloseLibrary(_UtilityBase); If _DosBase <> nil then CloseLibrary(_DosBase); If _IntuitionBase <> nil then CloseLibrary(_IntuitionBase); _UtilityBase := nil; _DosBase := nil; _IntuitionBase := nil; end; { Dispose of extraneous allocated pointers } for I:=1 to 8 do Begin if pointerlist[i] <> 0 then FreeVec(pointerlist[i]); end; exitproc:=old_exit; end; procedure halt(errnum : byte); begin { Indicate to the SYSTEM EXIT procedure that we are calling it } { from halt, and that its library will be closed HERE and not } { in the exit procedure. } FromHalt:=TRUE; { We must remove the CTRL-C FALG here because halt } { may call I/O routines, which in turn might call } { halt, so a recursive stack crash } IF (SetSignal(0,0) AND SIGBREAKF_CTRL_C) <> 0 THEN SetSignal(0,SIGBREAKF_CTRL_C); { 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 CloseLibrary(_UtilityBase); If _DosBase <> nil then CloseLibrary(_DosBase); If _IntuitionBase <> nil then CloseLibrary(_IntuitionBase); _UtilityBase := nil; _DosBase := nil; _IntuitionBase := nil; asm clr.l d0 move.b errnum,d0 move.l STKPTR,sp rts end; end; { ************************ PARAMCOUNT/PARAMSTR *************************** } function paramcount : longint; Begin paramcount := argc; end; function args : pointer; assembler; asm move.l __ARGS,d0 end; Function GetParamCount(const p: pchar): longint; var i: word; count: word; Begin i:=0; count:=0; while p[count] <> #0 do Begin if (p[count] <> ' ') and (p[count] <> #9) and (p[count] <> #0) then Begin i:=i+1; while (p[count] <> ' ') and (p[count] <> #9) and (p[count] <> #0) do count:=count+1; end; if p[count] = #0 then break; count:=count+1; end; GetParamCount:=longint(i); end; Function GetParam(index: word; const p : pchar): string; { On Entry: index = string index to correct parameter } { On exit: = correct character index into pchar array } { Returns correct index to command line argument } var count: word; localindex: word; l: byte; temp: string; Begin temp:=''; count := 0; { first index is one } localindex := 1; l:=0; While p[count] <> #0 do Begin if (p[count] <> ' ') and (p[count] <> #9) then Begin if localindex = index then Begin while (p[count] <> #0) and (p[count] <> ' ') and (p[count] <> #9) and (l < 256) do Begin temp:=temp+p[count]; l:=l+1; count:=count+1; end; temp[0]:=char(l); GetParam:=temp; exit; end; { Point to next argument in list } while (p[count] <> #0) and (p[count] <> ' ') and (p[count] <> #9) do Begin count:=count+1; end; localindex:=localindex+1; end; if p[count] = #0 then break; count:=count+1; end; GetParam:=temp; end; Function GetProgramDir : String; var s1: string; alock: longint; counter : byte; Begin FillChar(@s1,255,#0); { GetLock of program directory } asm move.l a6,d6 { save a6 } move.l _DOSBase,a6 jsr _LVOGetProgramDir(a6) move.l d6,a6 { restore a6 } move.l d0,alock { save the lock } end; if alock <> 0 then Begin { Get the name from the lock! } asm movem.l d2/d3,-(sp) { save used registers } move.l alock,d1 lea s1,a0 { Get pointer to string! } move.l a0,d2 add.l #1,d2 { let us point past the length byte! } move.l #255,d3 move.l a6,d6 { save a6 } move.l _DOSBase,a6 jsr _LVONameFromLock(a6) move.l d6,a6 { restore a6 } movem.l (sp)+,d2/d3 end; { no check out the length of the string } counter := 1; while s1[counter] <> #0 do Inc(counter); s1[0] := char(counter-1); GetProgramDir := s1; end else GetProgramDir := ''; end; Function GetProgramName : string; { Returns ONLY the program name } { There seems to be a bug in v39 since if the program is not } { called from its home directory the program name will also } { contain the path! } var s1: string; counter : byte; Begin FillChar(@s1,255,#0); asm move.l d2,-(sp) { Save used register } lea s1,a0 { Get pointer to string! } move.l a0,d1 add.l #1,d1 { point to correct offset } move.l #255,d2 move.l a6,d6 { save a6 } move.l _DOSBase,a6 jsr _LVOGetProgramName(a6) move.l d6,a6 { restore a6 } move.l (sp)+,d2 { restore saved register } end; { no check out and assign the length of the string } counter := 1; while s1[counter] <> #0 do Inc(counter); s1[0] := char(counter-1); { now remove any component path which should not be there } for counter:=length(s1) downto 1 do if (s1[counter] = '/') or (s1[counter] = ':') then break; { readjust counterv to point to character } if counter <> 1 then Inc(counter); GetProgramName:=copy(s1,counter,length(s1)); end; function paramstr(l : longint) : string; var p : pchar; s1 : string; begin { -> Call AmigaOS GetProgramName } if l = 0 then Begin s1 := GetProgramDir; { If this is a root, then simply don't add '/' } if s1[length(s1)] = ':' then paramstr:=s1+GetProgramName else { add backslash directory } paramstr:=s1+'/'+GetProgramName end else if (l>0) and (l<=paramcount) then begin p:=args; paramstr:=GetParam(word(l),p); end else paramstr:=''; end; { ************************************************************************ } procedure randomize; var hl : longint; time : TDateStamp; begin DateStamp(time); randseed:=time.ds_tick; 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; var { on exit -1 = if fails. } p: longint; i: byte; Begin p:=0; { Is the pointer list full } if pointerlist[8] <> 0 then begin { yes, then don't allocate and simply exit } sbrk:=-1; exit; end; { Allocate best available memory } p:=AllocVec(size,0); if p = 0 then sbrk:=-1 else Begin i:=1; { add it to the list of allocated pointers } { first find the last pointer in the list } while (i < 8) and (pointerlist[i] <> 0) do i:=i+1; pointerlist[i]:=p; sbrk:=p; end; end; {$I heap.inc} {**************************************************************************** Low Level File Routines ****************************************************************************} procedure do_close(h : longint); { We cannot check for CTRL-C because this routine will be called } { on HALT to close all remaining opened files. Therefore no } { CTRL-C checking otherwise a recursive call might result! } {$ifdef debug} var buffer: array[0..255] of char; {$endif} begin { check if the file handle is in the list } { if so the put its field to closed } { SetClosedList(FileList,h);} {$ifdef debug} asm move.l h,d1 move.l a6,d6 move.l d2,-(sp) move.l d3,-(sp) lea buffer,a0 move.l a0,d2 move.l #255,d3 move.l _DosBase,a6 jsr _LVONameFromFH(a6) move.l d6,a6 move.l (sp)+,d3 move.l (sp)+,d2 end; WriteLn(Buffer); {$endif debug} 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; function do_isdevice(handle:longint):boolean; begin if (handle=stdoutputhandle) or (handle=stdinputhandle) or (handle=stderrorhandle) then do_isdevice:=TRUE else do_isdevice:=FALSE; end; procedure do_erase(p : pchar); begin if (Setsignal(0,0) AND SIGBREAKF_CTRL_C) <> 0 then Begin SetSignal(0,SIGBREAKF_CTRL_C); Halt(CTRL_C); end; 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.w d0,errno @noerror: move.l d6,a6 { restore a6 } end; if errno <> 0 then Error2InOut; end; procedure do_rename(p1,p2 : pchar); begin if (Setsignal(0,0) AND SIGBREAKF_CTRL_C) <> 0 then Begin SetSignal(0,SIGBREAKF_CTRL_C); Halt(CTRL_C); end; 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.w d0,errno @dosreend: move.l d6,a6 { restore a6 } end; if errno <> 0 then Error2InOut; end; function do_write(h,addr,len : longint) : longint; begin if (Setsignal(0,0) AND SIGBREAKF_CTRL_C) <> 0 then Begin SetSignal(0,SIGBREAKF_CTRL_C); Halt(CTRL_C); end; 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 cmp.l #-1,d0 bne @doswrend { if -1 = error } jsr _LVOIoErr(a6) move.w d0,errno 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; If errno <> 0 then Error2InOut; end; function do_read(h,addr,len : longint) : longint; begin if (Setsignal(0,0) AND SIGBREAKF_CTRL_C) <> 0 then Begin SetSignal(0,SIGBREAKF_CTRL_C); Halt(CTRL_C); end; 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 cmp.l #-1,d0 bne @doswrend { if -1 = error } jsr _LVOIoErr(a6) move.w d0,errno 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; If errno <> 0 then Error2InOut; end; function do_filepos(handle : longint) : longint; begin if (Setsignal(0,0) AND SIGBREAKF_CTRL_C) <> 0 then Begin { Clear CTRL-C signal } SetSignal(0,SIGBREAKF_CTRL_C); Halt(CTRL_C); end; 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.w d0,errno bra @fposend @noerr: move.l d6,a6 { restore a6 } move.l d0,@Result bra @end @fposend: move.l d6,a6 { restore a6 } @end: end; If errno <> 0 then Error2InOut; end; procedure do_seek(handle,pos : longint); begin if (Setsignal(0,0) AND SIGBREAKF_CTRL_C) <> 0 then Begin { Clear CTRL-C signal } SetSignal(0,SIGBREAKF_CTRL_C); Halt(CTRL_C); end; asm move.l a6,d6 move.l handle,d1 move.l d2,-(sp) move.l d3,-(sp) { save registers } move.l pos,d2 { -1 } move.l #$ffffffff,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.w d0,errno bra @seekend @noerr: @seekend: move.l d6,a6 { restore a6 } end; If errno <> 0 then Error2InOut; end; function do_seekend(handle:longint):longint; begin if (Setsignal(0,0) AND SIGBREAKF_CTRL_C) <> 0 then Begin { Clear CTRL-C signal } SetSignal(0,SIGBREAKF_CTRL_C); Halt(CTRL_C); end; 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.w d0,errno bra @seekend @noerr: move.l d6,a6 { restore a6 } move.l d0,@Result bra @end @seekend: move.l d6,a6 { restore a6 } @end: end; If Errno <> 0 then Error2InOut; end; function do_filesize(handle : longint) : longint; var aktfilepos : longint; begin if (Setsignal(0,0) AND SIGBREAKF_CTRL_C) <> 0 then Begin { Clear CTRL-C signal } SetSignal(0,SIGBREAKF_CTRL_C); Halt(CTRL_C); end; aktfilepos:=do_filepos(handle); { We have to do this two times, because seek returns the } { OLD position } do_filesize:=do_seekend(handle); do_filesize:=do_seekend(handle); do_seek(handle,aktfilepos); end; procedure do_truncate (handle,pos:longint); begin { Point to the end of the file } { with the new size } asm @noerr_one: { Seek a second time } move.l a6,d6 { Save base pointer } move.l handle,d1 move.l d2,-(sp) move.l d3,-(sp) { save registers } move.l pos,d2 move.l #-1,d3 { Setup correct move type } move.l _DOSBase,a6 { from beginning of file } jsr _LVOSetFileSize(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.w d0,errno { Global variable, so no need } @noerr: { to restore base pointer now } move.l d6,a6 { Restore base pointer } end; If Errno <> 0 then Error2InOut; 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,j : longint; oflags: longint; path : string; buffer : array[0..255] of char; index : integer; s : string; begin path:=strpas(p); for index:=1 to length(path) do if path[index]='\' then path[index]:='/'; { remove any dot characters and replace by their current } { directory equivalent. } if pos('../',path) = 1 then { look for parent directory } Begin delete(path,1,3); getdir(0,s); j:=length(s); while (s[j] <> '/') AND (s[j] <> ':') AND (j > 0 ) do dec(j); if j > 0 then s:=copy(s,1,j); path:=s+path; end else if pos('./',path) = 1 then { look for current directory } Begin delete(path,1,2); getdir(0,s); if (s[length(s)] <> '/') and (s[length(s)] <> ':') then s:=s+'/'; path:=s+path; end; move(path[1],buffer,length(path)); buffer[length(path)]:=#0; { 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; { convert filemode to filerec modes } { READ/WRITE on existing file } { RESET/APPEND } oflags := 1005; case (flags and 3) of 0 : begin filerec(f).mode:=fminput; end; 1 : filerec(f).mode:=fmoutput; 2 : filerec(f).mode:=fminout; end; { READ/WRITE mode, create file in all cases } { REWRITE } if (flags and $100)<>0 then begin filerec(f).mode:=fmoutput; oflags := 1006; end else { READ/WRITE mode on existing file } { APPEND } if (flags and $10)<>0 then begin filerec(f).mode:=fmoutput; oflags := 1005; 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; asm move.l a6,d6 { save a6 } move.l d2,-(sp) lea buffer,a0 move.l a0,d1 move.l oflags,d2 { MODE_READWRITE } move.l _DOSBase,a6 jsr _LVOOpen(a6) tst.l d0 bne @noopenerror { on zero an error occured } jsr _LVOIoErr(a6) move.w d0,errno bra @openend @noopenerror: move.l (sp)+,d2 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 } move.l (sp)+,d2 @end: end; (* if Errno = 0 then*) { No error, add file handle to linked list } { this must be checked before the call to } { Error2InIOut since it resets Errno to 0 } (* AddToList(FileList,i);*) If Errno <> 0 then Error2InOut; 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);[IOCheck]; var buffer : array[0..255] of char; j: Integer; temp : string; begin { We must check the Ctrl-C before IOChecking of course! } if (Setsignal(0,0) AND SIGBREAKF_CTRL_C) <> 0 then Begin { Clear CTRL-C signal } SetSignal(0,SIGBREAKF_CTRL_C); Halt(CTRL_C); end; If InOutRes <> 0 then exit; temp:=s; for j:=1 to length(temp) do if temp[j] = '\' then temp[j] := '/'; move(temp[1],buffer,length(temp)); buffer[length(temp)]:=#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 jsr _LVOIoErr(a6) move.w d0,errno bra @end @noerror: { Now we must unlock the directory } { d0 = lock returned by create dir } move.l d0,d1 jsr _LVOUnlock(a6) @end: { restore base pointer } move.l d6,a6 end; If errno <> 0 then Error2InOut; end; procedure rmdir(const s : string);[IOCheck]; var buffer : array[0..255] of char; j : Integer; temp : string; begin { We must check the Ctrl-C before IOChecking of course! } if (Setsignal(0,0) AND SIGBREAKF_CTRL_C) <> 0 then Begin { Clear CTRL-C signal } SetSignal(0,SIGBREAKF_CTRL_C); Halt(CTRL_C); end; If InOutRes <> 0 then exit; temp:=s; for j:=1 to length(temp) do if temp[j] = '\' then temp[j] := '/'; move(temp[1],buffer,length(temp)); buffer[length(temp)]:=#0; do_erase(buffer); end; procedure chdir(const s : string);[IOCheck]; var buffer : array[0..255] of char; alock : longint; FIB :pFileInfoBlock; j: integer; temp : string; begin if (Setsignal(0,0) AND SIGBREAKF_CTRL_C) <> 0 then Begin { Clear CTRL-C signal } SetSignal(0,SIGBREAKF_CTRL_C); Halt(CTRL_C); end; If InOutRes <> 0 then exit; temp:=s; for j:=1 to length(temp) do if temp[j] = '\' then temp[j] := '/'; { Return parent directory } if s = '..' then Begin getdir(0,temp); j:=length(temp); { Look through the previous paths } while (temp[j] <> '/') AND (temp[j] <> ':') AND (j > 0 ) do dec(j); if j > 0 then temp:=copy(temp,1,j); end; alock := 0; fib:=nil; new(fib); move(temp[1],buffer,length(temp)); buffer[length(temp)]:=#0; { Changing the directory is a pretty complicated affair } { 1) Obtain a lock on the directory } { 2) CurrentDir the lock } asm lea buffer,a0 move.l a0,d1 { pointer to buffer in d1 } move.l d2,-(sp) { save d2 register } move.l #-2,d2 { ACCESS_READ lock } move.l a6,d6 { Save base pointer } move.l _DosBase,a6 jsr _LVOLock(a6){ Lock the directory } move.l (sp)+,d2 { Restore d2 register } tst.l d0 { zero = error! } bne @noerror jsr _LVOIoErr(a6) move.w d0,errno move.l d6,a6 { reset base pointer } bra @End @noerror: move.l d6,a6 { reset base pointer } move.l d0,alock { save the lock } @End: end; If errno <> 0 then Begin Error2InOut; exit; end; if (Examine(alock, fib^) = TRUE) AND (fib^.fib_DirEntryType > 0) then Begin alock := CurrentDir(alock); if OrigDir = 0 then Begin OrigDir := alock; alock := 0; end; end; if alock <> 0 then Unlock(alock); if assigned(fib) then dispose(fib); end; Procedure GetCwd(var path: string); var lock: longint; fib: PfileInfoBlock; len : integer; newlock : longint; elen : integer; Process : PProcess; Begin len := 0; path := ''; fib := nil; { By using a pointer instead of a local variable} { we are assured that the pointer is aligned on } { a dword boundary. } new(fib); Process := FindTask(nil); if (process^.pr_Task.tc_Node.ln_Type = NT_TASK) then Begin path:=''; exit; end; lock := DupLock(process^.pr_CurrentDir); if (Lock = 0) then Begin path:=''; exit; end; While (lock <> 0) and (Examine(lock,FIB^) = TRUE) do Begin elen := strlen(fib^.fib_FileName); if (len + elen + 2 > 255) then break; newlock := ParentDir(lock); if (len <> 0) then Begin if (newlock <> 0) then path:='/'+path else path:=':'+path; path:=strpas(fib^.fib_FileName)+path; Inc(len); end else Begin path:=strpas(fib^.fib_Filename); if (newlock = 0) then path:=path+':'; end; len := len + elen; UnLock(lock); lock := newlock; end; if (lock <> 0) then Begin UnLock(lock); path := ''; end; if assigned(fib) then dispose(fib); end; procedure getdir(drivenr : byte;var dir : string); begin if (Setsignal(0,0) AND SIGBREAKF_CTRL_C) <> 0 then Begin { Clear CTRL-C signal } SetSignal(0,SIGBREAKF_CTRL_C); Halt(CTRL_C); end; GetCwd(dir); If errno <> 0 then Error2InOut; 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; begin errno:= 0; FromHalt := FALSE; { 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; argc:=GetParamCount(args); OrigDir := 0; FileList := nil; old_Exit:=exitproc; Exitproc:=@ExitCall; end. { $Log$ Revision 1.9 1998-08-17 12:34:22 carl * chdir accepts .. characters + added ctrl-c checking + implemented sbrk * exit code was never called if no error was found on exit! * register was not saved in do_open Revision 1.8 1998/07/13 12:32:18 carl * do_truncate works, some cleanup Revision 1.6 1998/07/02 12:37:52 carl * IOCheck for chdir,rmdir and mkdir as in TP Revision 1.5 1998/07/01 14:30:56 carl * forgot that includes are case sensitive Revision 1.4 1998/07/01 14:13:50 carl * do_open bugfix * correct conversion of Amiga error codes to TP error codes * InoutRes word bugfix * parameter counting fixed * new stack checking implemented + IOCheck for chdir,rmdir,getdir and rmdir * do_filepos was wrong + chdir correctly implemented * getdir correctly implemented 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 :)) }