{ $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 Truncate!! } {$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; argc : 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 } var OrigDir : Longint; implementation {$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; Const _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; { 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; errno : word; {$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; { 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; 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; if (OrigDir <> 0) then Begin Unlock(CurrentDir(OrigDir)); OrigDir := 0; 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; { ************************ 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; { 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; 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 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 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 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 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 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 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 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 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 {!!!!!!!!!!!!} 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; { 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 p,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 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; 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; begin If InOutRes <> 0 then exit; 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 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; begin If InOutRes <> 0 then exit; move(s[1],buffer,length(s)); buffer[length(s)]:=#0; do_erase(buffer); end; procedure chdir(const s : string);[IOCheck]; var buffer : array[0..255] of char; alock : longint; FIB :pFileInfoBlock; begin If InOutRes <> 0 then exit; alock := 0; fib:=nil; new(fib); move(s[1],buffer,length(s)); buffer[length(s)]:=#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 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; { 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; end. { $Log$ 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 :)) }