paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-05-05 02:43:43 +02:00
Code Issues Packages Projects Releases Wiki Activity
ec29df131a
fpc/rtl/amiga/sysamiga.pas
carl ec29df131a * 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
1998-07-01 14:13:50 +00:00

1405 lines
40 KiB
ObjectPascal
Raw Blame History

{
$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 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 ************************* }
{ 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;
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.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
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
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
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);[IOCheck];
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;
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
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.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 :))
}
Reference in New Issue View Git Blame Copy Permalink