paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-16 15:59:30 +02:00
Code Issues Packages Projects Releases Wiki Activity
00d8d57c55
fpc/rtl/morphos/system.pp

1290 lines
39 KiB
ObjectPascal
Raw Blame History

{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 2004 by Karoly Balogh for Genesi Sarl
System unit for MorphOS/PowerPC
Uses parts of the Amiga/68k port by Carl Eric Codere
and Nils Sjoholm
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 {$ifdef VER1_0}SysMorph{$else}System{$endif};
interface
{$define FPC_IS_SYSTEM}
{$I systemh.inc}
type
THandle = LongInt;
{$I heaph.inc}
const
LineEnding = #10;
LFNSupport = True;
DirectorySeparator = '/';
DriveSeparator = ':';
PathSeparator = ';';
const
UnusedHandle : LongInt = -1;
StdInputHandle : LongInt = 0;
StdOutputHandle : LongInt = 0;
StdErrorHandle : LongInt = 0;
FileNameCaseSensitive : Boolean = False;
sLineBreak : string[1] = LineEnding;
DefaultTextLineBreakStyle : TTextLineBreakStyle = tlbsLF;
BreakOn : Boolean = True;
{*****************************************************************************
MorphOS structures
*****************************************************************************}
type
PClockData = ^TClockData;
TClockData = packed Record
sec : Word;
min : Word;
hour : Word;
mday : Word;
month: Word;
year : Word;
wday : Word;
end;
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;
PNode = ^TNode;
TNode = packed record
ln_Succ, { Pointer to next (successor) }
ln_Pred: pNode; { Pointer to previous (predecessor) }
ln_Type: Byte;
ln_Pri : Shortint; { Priority, for sorting }
ln_Name: PChar; { ID string, null terminated }
end; { Note: Integer aligned }
PMinNode = ^TMinNode;
tMinNode = packed record
mln_Succ,
mln_Pred: pMinNode;
end;
PList = ^TList;
tList = packed record
lh_Head : pNode;
lh_Tail : pNode;
lh_TailPred: pNode;
lh_Type : Byte;
l_pad : Byte;
end;
PMinList = ^TMinList;
TMinList = packed record
mlh_Head : PMinNode;
mlh_Tail : PMinNode;
mlh_TailPred: PMinNode;
end;
PMsgPort = ^TMsgPort;
TMsgPort = packed record
mp_Node : TNode;
mp_Flags : Byte;
mp_SigBit : Byte; { signal bit number }
mp_SigTask: Pointer; { task to be signalled (TaskPtr) }
mp_MsgList: TList; { message linked list }
end;
PMessage = ^TMessage;
TMessage = packed record
mn_Node : TNode;
mn_ReplyPort: PMsgPort;
mn_Length : Word;
end;
PTask = ^TTask;
TTask = packed record
tc_Node : TNode;
tc_Flags : Byte;
tc_State : Byte;
tc_IDNestCnt : Shortint; { intr disabled nesting }
tc_TDNestCnt : Shortint; { task disabled nesting }
tc_SigAlloc : DWord; { sigs allocated }
tc_SigWait : DWord; { sigs we are waiting for }
tc_SigRecvd : DWord; { sigs we have received }
tc_SigExcept : DWord; { sigs we will take excepts for }
tc_TrapAlloc : Word; { traps allocated }
tc_TrapAble : Word; { traps enabled }
tc_ExceptData: Pointer; { points to except data }
tc_ExceptCode: Pointer; { points to except code }
tc_TrapData : Pointer; { points to trap data }
tc_TrapCode : Pointer; { points to trap code }
tc_SPReg : Pointer; { stack pointer }
tc_SPLower : Pointer; { stack lower bound }
tc_SPUpper : Pointer; { stack upper bound + 2 }
tc_Switch : Pointer; { task losing CPU }
tc_Launch : Pointer; { task getting CPU }
tc_MemEntry : TList; { allocated memory }
tc_UserData : Pointer; { per task data }
end;
PProcess = ^TProcess;
TProcess = packed record
pr_Task : TTask;
pr_MsgPort : TMsgPort; { This is BPTR address from DOS functions }
pr_Pad : Word; { Remaining variables on 4 byte boundaries }
pr_SegList : Pointer; { Array of seg lists used by this process }
pr_StackSize : Longint; { Size of process stack in bytes }
pr_GlobVec : Pointer; { Global vector for this process (BCPL) }
pr_TaskNum : Longint; { CLI task number of zero if not a CLI }
pr_StackBase : DWord; { Ptr to high memory end of process stack }
pr_Result2 : Longint; { Value of secondary result from last call }
pr_CurrentDir : DWord; { Lock associated with current directory }
pr_CIS : DWord; { Current CLI Input Stream }
pr_COS : DWord; { Current CLI Output Stream }
pr_ConsoleTask : Pointer; { Console handler process for current window }
pr_FileSystemTask: Pointer; { File handler process for current drive }
pr_CLI : DWord; { 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 : DWord; { 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 : DWord; { Error stream - IF NULL, use pr_COS }
end;
PLibrary = ^TLibrary;
TLibrary = packed record
lib_Node : tNode;
lib_Flags,
lib_pad : Byte;
lib_NegSize, { number of bytes before library }
lib_PosSize, { number of bytes after library }
lib_Version, { major }
lib_Revision: Word; { minor }
lib_IdString: PChar; { ASCII identification }
lib_Sum : LongInt; { the checksum itself }
lib_OpenCnt : Word; { number of current opens }
end; { * Warning: size is not a longword multiple ! * }
PDevice = ^TDevice;
tDevice = record
dd_Library: TLibrary;
end;
PUnit = ^tUnit;
TUnit = record
unit_MsgPort: TMsgPort; { queue for unprocessed messages }
{ instance of msgport is recommended }
unit_flags,
unit_pad : Byte;
unit_OpenCnt: Word; { number of active opens }
end;
PIORequest = ^TIORequest;
TIORequest = packed record
io_Message: TMessage;
io_Device : PDevice; { device node pointer }
io_Unit : PUnit; { unit (driver private)}
io_Command: Word; { device command }
io_Flags : Byte;
io_Error : Shortint; { error or warning num }
end;
PInfoData = ^TInfoData;
TInfoData = packed record
id_NumSoftErrors: LongInt; { number of soft errors on disk }
id_UnitNumber : LongInt; { Which unit disk is (was) mounted on }
id_DiskState : LongInt; { See defines below }
id_NumBlocks : LongInt; { Number of blocks on disk }
id_NumBlocksUsed: LongInt; { Number of block in use }
id_BytesPerBlock: LongInt;
id_DiskType : LongInt; { Disk Type code }
id_VolumeNode : LongInt; { BCPL pointer to volume node }
id_InUse : LongInt; { Flag, zero if not in use }
end;
PChain = ^TChain;
TChain = packed record
an_Child : PChain;
an_Parent: PChain;
an_Lock : LongInt;
an_info : TFileInfoBlock;
an_Flags : ShortInt;
an_string: Array[0..0] of char;
end;
PAnchorPath = ^TAnchorPath;
TAnchorPath = packed record
ap_Base : PChain; { pointer to first anchor }
ap_First : PChain; { pointer to last anchor }
ap_BreakBits: LongInt; { Bits we want to break on }
ap_FondBreak: LongInt; { Bits we broke on. Also returns ERROR_BREAK }
ap_Flags : ShortInt; { New use for extra word. }
ap_reserved : Byte;
ap_StrLen : Word;
ap_Info : TFileInfoBlock;
ap_Buf : array[0..0] of Char; { Buffer for path name, allocated by user }
end;
PDOSList = ^TDOSList;
TDOSList = packed record
dol_Next: LongInt; { bptr to next device on list }
dol_Type: LongInt; { see DLT below }
dol_Task: Pointer; { ptr to handler task }
dol_Lock: LongInt;
dol_Misc: array[0..23] of ShortInt;
dol_Name: LongInt; { bptr to bcpl name }
end;
var
MOS_ExecBase : Pointer; external name '_ExecBase';
MOS_DOSBase : Pointer;
MOS_UtilityBase: Pointer;
MOS_heapPool: Pointer; { pointer for the OS pool for growing the heap }
MOS_origDir : LongInt; { original directory on startup }
MOS_ambMsg : PMessage;
MOS_ConName : PChar ='CON:10/30/620/100/FPC Console Output/AUTO/CLOSE/WAIT';
MOS_argc: LongInt;
MOS_argv: PPChar;
{*****************************************************************************
MorphOS functions
*****************************************************************************}
{ exec.library functions }
function exec_OpenLibrary(libname: PChar location 'a1';
libver: LongInt location 'd0'): Pointer; SysCall MOS_ExecBase 552;
procedure exec_CloseLibrary(libhandle: Pointer location 'a1'); SysCall MOS_ExecBase 414;
function exec_CreatePool(memflags: LongInt location 'd0';
puddleSize: LongInt location 'd1';
threshSize: LongInt location 'd2'): Pointer; SysCall MOS_ExecBase 696;
procedure exec_DeletePool(poolHeader: Pointer location 'a0'); SysCall MOS_ExecBase 702;
function exec_AllocPooled(poolHeader: Pointer location 'a0';
memSize: LongInt location 'd0'): Pointer; SysCall MOS_ExecBase 708;
function exec_SetSignal(newSignals: LongInt location 'd0';
signalMask: LongInt location 'd1'): LongInt; SysCall MOS_ExecBase 306;
function exec_FindTask(tname: PChar location 'a1'): PTask; SysCall MOS_ExecBase 294;
function exec_GetMsg(port: PMsgPort location 'a0'): PMessage; SysCall MOS_ExecBase 372;
function exec_WaitPort(port: PMsgPort location 'a0'): PMessage; SysCall MOS_ExecBase 384;
function exec_AllocMem(byteSize: LongInt location 'd0';
requirements: LongInt location 'd1'): Pointer; SysCall MOS_ExecBase 198;
procedure exec_FreeMem(memoryBlock: Pointer location 'a1';
byteSize: LongInt location 'd0'); SysCall MOS_ExecBase 210;
function exec_AllocSignal(signalNum: LongInt location 'd0'): ShortInt; SysCall MOS_ExecBase 330;
procedure exec_FreeSignal(signalNum: LongInt location 'd0'); SysCall MOS_ExecBase 336;
procedure exec_AddPort(port: PMsgPort location 'a1'); SysCall MOS_ExecBase 354;
procedure exec_RemPort(port: PMsgPort location 'a1'); SysCall MOS_ExecBase 360;
function exec_DoIO(ioRequest: PIORequest location 'a1'): ShortInt; SysCall MOS_ExecBase 456;
function exec_OpenDevice(const devName: PChar location 'a0';
unite: LongInt location 'd0';
ioRequest: PIORequest location 'a1';
flags: LongInt location 'd1'): ShortInt; SysCall MOS_ExecBase 444;
procedure exec_CloseDevice(ioRequest: PIORequest location 'a1'); SysCall MOS_ExecBase 450;
{ dos.library functions }
function dos_Output: LongInt; SysCall MOS_DOSBase 60;
function dos_Input: LongInt; SysCall MOS_DOSBase 54;
function dos_IoErr: LongInt; SysCall MOS_DOSBase 132;
function dos_GetArgStr: PChar; SysCall MOS_DOSBase 534;
function dos_Open(fname: PChar location 'd1';
accessMode: LongInt location 'd2'): LongInt; SysCall MOS_DOSBase 30;
function dos_Close(fileh: LongInt location 'd1'): Boolean; SysCall MOS_DOSBase 36;
function dos_Seek(fileh: LongInt location 'd1';
position: LongInt location 'd2';
posmode: LongInt location 'd3'): LongInt; SysCall MOS_DOSBase 66;
function dos_SetFileSize(fileh: LongInt location 'd1';
position: LongInt location 'd2';
posmode: LongInt location 'd3'): LongInt; SysCall MOS_DOSBase 456;
function dos_Read(fileh: LongInt location 'd1';
buffer: Pointer location 'd2';
length: LongInt location 'd3'): LongInt; SysCall MOS_DOSBase 40;
function dos_Write(fileh: LongInt location 'd1';
buffer: Pointer location 'd2';
length: LongInt location 'd3'): LongInt; SysCall MOS_DOSBase 48;
function dos_WriteChars(buf: PChar location 'd1';
buflen: LongInt location 'd2'): LongInt; SysCall MOS_DOSBase 942;
function dos_Rename(oldName: PChar location 'd1';
newName: PChar location 'd2'): Boolean; SysCall MOS_DOSBase 78;
function dos_DeleteFile(fname: PChar location 'd1'): Boolean; SysCall MOS_DOSBase 72;
function dos_GetCurrentDirName(buf: PChar location 'd1';
len: LongInt location 'd2'): Boolean; SysCall MOS_DOSBase 564;
function dos_Lock(lname: PChar location 'd1';
accessMode: LongInt location 'd2'): LongInt; SysCall MOS_DOSBase 84;
procedure dos_Unlock(lock: LongInt location 'd1'); SysCall MOS_DOSBase 90;
function dos_CurrentDir(lock: LongInt location 'd1'): LongInt; SysCall MOS_DOSBase 126;
function dos_Examine(lock: LongInt location 'd1';
FileInfoBlock: Pointer location 'd2'): Boolean; SysCall MOS_DOSBase 102;
function dos_NameFromLock(lock: LongInt location 'd1';
buffer: PChar location 'd2';
len: LongInt location 'd3'): Boolean; SysCall MOS_DOSBase 402;
function dos_Info(lock: LongInt location 'd1';
parameterBlock: PInfoData location 'd2'): Boolean; SysCall MOS_DOSBase 114;
function dos_CreateDir(dname: PChar location 'd1'): LongInt; SysCall MOS_DOSBase 120;
function dos_DateStamp(var ds: TDateStamp location 'd1'): LongInt; SysCall MOS_DOSBase 192;
function dos_SystemTagList(command: PChar location 'd1';
tags: Pointer location 'd2'): LongInt; SysCall MOS_DOSBase 606;
function dos_GetVar(vname: PChar location 'd1';
buffer: PChar location 'd2';
size: LongInt location 'd3';
flags: LongInt location 'd4'): LongInt; SysCall MOS_DOSBase 906;
function dos_MatchFirst(pat: PChar location 'd1';
anchor: PAnchorPath location 'd2'): LongInt; SysCall MOS_DOSBase 822;
function dos_MatchNext(anchor: PAnchorPath location 'd1'): LongInt; SysCall MOS_DOSBase 828;
procedure dos_MatchEnd(anchor: PAnchorPath location 'd1') SysCall MOS_DOSBase 834;
function dos_LockDosList(flags: LongInt location 'd1'): PDOSList; SysCall MOS_DOSBase 654;
procedure dos_UnLockDosList(flags: LongInt location 'd2'); SysCall MOS_DOSBase 660;
function dos_NextDosEntry(dlist: PDOSList location 'd1';
flags: LongInt location 'd2'): PDOSList; SysCall MOS_DOSBase 690;
function dos_SetProtection(name: PChar location 'd1';
mask: LongInt location 'd2'): Boolean; SysCall MOS_DOSBase 186;
function dos_SetFileDate(name: PChar location 'd1';
date: PDateStamp location 'd2'): Boolean; SysCall MOS_DOSBase 396;
{ utility.library functions }
function util_Date2Amiga(date: PClockData location 'a0'): LongInt; SysCall MOS_UtilityBase 126;
procedure util_Amiga2Date(amigatime: LongInt location 'd0';
resultat: PClockData location 'a0'); SysCall MOS_UtilityBase 120;
implementation
{$I system.inc}
{*****************************************************************************
System Dependent Structures/Consts
*****************************************************************************}
{ Errors from dos_IoErr(), etc. }
const
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 AOS 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;
{ DOS file offset modes }
const
OFFSET_BEGINNING = -1;
OFFSET_CURRENT = 0;
OFFSET_END = 1;
{ Lock AccessMode }
const
SHARED_LOCK = -2;
ACCESS_READ = SHARED_LOCK;
EXCLUSIVE_LOCK = -1;
ACCESS_WRITE = EXCLUSIVE_LOCK;
{ Memory flags }
const
MEMF_ANY = 0;
MEMF_PUBLIC = 1 Shl 0;
MEMF_CHIP = 1 Shl 1;
MEMF_FAST = 1 Shl 2;
MEMF_LOCAL = 1 Shl 8;
MEMF_24BITDMA = 1 Shl 9;
MEMF_KICK = 1 Shl 10;
MEMF_CLEAR = 1 Shl 16;
MEMF_LARGEST = 1 Shl 17;
MEMF_REVERSE = 1 Shl 18;
MEMF_TOTAL = 1 Shl 19;
MEMF_NO_EXPUNGE = 1 Shl 31;
const
CTRL_C = 20; { Error code on CTRL-C press }
SIGBREAKF_CTRL_C = $1000; { CTRL-C signal flags }
{*****************************************************************************
MorphOS File-handling Support Functions
*****************************************************************************}
type
{ 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 }
end;
var
MOS_fileList: PFileList; { List pointer to opened files }
{ Function to be called at program shutdown, to close all opened files }
procedure CloseList(l: PFileList);
var
tmpNext : PFileList;
tmpHandle : LongInt;
begin
if l=nil then exit;
{ First, close all tracked files }
tmpNext:=l^.next;
while tmpNext<>nil do begin
tmpHandle:=tmpNext^.handle;
if (tmpHandle<>StdInputHandle) and (tmpHandle<>StdOutputHandle)
and (tmpHandle<>StdErrorHandle) then begin
dos_Close(tmpHandle);
end;
tmpNext:=tmpNext^.next;
end;
{ Next, erase the linked list }
while l<>nil do begin
tmpNext:=l;
l:=l^.next;
dispose(tmpNext);
end;
end;
{ Function to be called to add a file to the opened file list }
procedure AddToList(var l: PFileList; h: LongInt);
var
p : PFileList;
inList: Boolean;
begin
inList:=False;
if l<>nil then begin
{ if there is a valid filelist, search for the value }
{ in the list to avoid double additions }
p:=l;
while (p^.next<>nil) and (not inList) do
if p^.next^.handle=h then inList:=True
else p:=p^.next;
p:=nil;
end else begin
{ if the list is not yet allocated, allocate it. }
New(l);
l^.next:=nil;
end;
if not inList then begin
New(p);
p^.handle:=h;
p^.next:=l^.next;
l^.next:=p;
end;
end;
{ Function to be called to remove a file from the list }
procedure RemoveFromList(var l: PFileList; h: longint);
var
p : PFileList;
inList: Boolean;
begin
if l=nil then exit;
inList:=False;
p:=l;
while (p^.next<>nil) and (not inList) do
if p^.next^.handle=h then inList:=True
else p:=p^.next;
if p^.next<>nil then begin
dispose(p^.next);
p^.next:=p^.next^.next;
end;
end;
{*****************************************************************************
Misc. System Dependent Functions
*****************************************************************************}
procedure haltproc(e:longint);cdecl;external name '_haltproc';
procedure System_exit;
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 BreakOn then begin
if (exec_SetSignal(0,0) and SIGBREAKF_CTRL_C)<>0 then
exec_SetSignal(0,SIGBREAKF_CTRL_C);
end;
{ Closing opened files }
CloseList(MOS_fileList);
if MOS_UtilityBase<>nil then exec_CloseLibrary(MOS_UtilityBase);
if MOS_DOSBase<>nil then exec_CloseLibrary(MOS_DOSBase);
if MOS_heapPool<>nil then exec_DeletePool(MOS_heapPool);
haltproc(ExitCode);
end;
{ Converts a MorphOS dos.library error code to a TP compatible error code }
{ Based on 1.0.x Amiga RTL }
procedure dosError2InOut(errno: LongInt);
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;
end;
{ Used for CTRL_C checking in I/O calls }
procedure checkCTRLC;
begin
if BreakOn then begin
if (exec_SetSignal(0,0) And SIGBREAKF_CTRL_C)<>0 then begin
{ Clear CTRL-C signal }
exec_SetSignal(0,SIGBREAKF_CTRL_C);
Halt(CTRL_C);
end;
end;
end;
{ Generates correct argument array on startup }
procedure GenerateArgs;
var
argvlen : longint;
procedure allocarg(idx,len:longint);
var
i,oldargvlen : longint;
begin
if idx>=argvlen then
begin
oldargvlen:=argvlen;
argvlen:=(idx+8) and (not 7);
sysreallocmem(MOS_argv,argvlen*sizeof(pointer));
for i:=oldargvlen to argvlen-1 do
MOS_argv[i]:=nil;
end;
{ use realloc to reuse already existing memory }
sysreallocmem(MOS_argv[idx],len+1);
end;
var
count: word;
start: word;
localindex: word;
p : pchar;
temp : string;
begin
p:=dos_GetArgStr;
argvlen:=0;
{ Set argv[0] }
temp:=paramstr(0);
allocarg(0,length(temp));
move(temp[1],MOS_argv[0]^,length(temp));
MOS_argv[0][length(temp)]:=#0;
{ check if we're started from Ambient }
if MOS_ambMsg<>nil then
begin
MOS_argc:=0;
exit;
end;
{ Handle the other args }
count:=0;
{ first index is one }
localindex:=1;
while (p[count]<>#0) do
begin
while (p[count]=' ') or (p[count]=#9) or (p[count]=LineEnding) do inc(count);
start:=count;
while (p[count]<>#0) and (p[count]<>' ') and (p[count]<>#9) and (p[count]<>LineEnding) do inc(count);
if (count-start>0) then
begin
allocarg(localindex,count-start);
move(p[start],MOS_argv[localindex]^,count-start);
MOS_argv[localindex][count-start]:=#0;
inc(localindex);
end;
end;
MOS_argc:=localindex;
end;
{*****************************************************************************
ParamStr/Randomize
*****************************************************************************}
{ number of args }
function paramcount : longint;
begin
if MOS_ambMsg<>nil then
paramcount:=0
else
paramcount:=MOS_argc-1;
end;
{ argument number l }
function paramstr(l : longint) : string;
begin
if (l>=0) and (l+1<=MOS_argc) then
paramstr:=strpas(MOS_argv[l])
else
paramstr:='';
end;
{ set randseed to a new pseudo random value }
procedure randomize;
var tmpTime: TDateStamp;
begin
dos_DateStamp(tmpTime);
randseed:=tmpTime.ds_tick;
end;
{*****************************************************************************
Heap Management
*****************************************************************************}
var
int_heap : LongInt; external name 'HEAP';
int_heapsize : LongInt; external name 'HEAPSIZE';
{ first address of heap }
function getheapstart:pointer;
begin
getheapstart:=@int_heap;
end;
{ current length of heap }
function getheapsize:longint;
begin
getheapsize:=int_heapsize;
end;
{ function to allocate size bytes more for the program }
{ must return the first address of new data space or nil if fail }
function Sbrk(size : longint):pointer;
begin
Sbrk:=exec_AllocPooled(MOS_heapPool,size);
end;
{$I heap.inc}
{*****************************************************************************
Directory Handling
*****************************************************************************}
procedure mkdir(const s : string);[IOCheck];
var
buffer : array[0..255] of char;
j : Integer;
tmpStr : string;
tmpLock : LongInt;
begin
checkCTRLC;
if (s='') or (InOutRes<>0) then exit;
tmpStr:=s;
for j:=1 to length(tmpStr) do
if tmpStr[j]='\' then tmpStr[j]:='/';
move(tmpStr[1],buffer,length(tmpStr));
buffer[length(tmpStr)]:=#0;
tmpLock:=dos_CreateDir(buffer);
if tmpLock=0 then begin
dosError2InOut(dos_IoErr);
exit;
end;
dos_UnLock(tmpLock);
end;
procedure rmdir(const s : string);[IOCheck];
var
buffer : array[0..255] of char;
j : Integer;
tmpStr : string;
begin
checkCTRLC;
if (s='.') then InOutRes:=16;
If (s='') or (InOutRes<>0) then exit;
tmpStr:=s;
for j:=1 to length(tmpStr) do
if tmpStr[j] = '\' then tmpStr[j] := '/';
move(tmpStr[1],buffer,length(tmpStr));
buffer[length(tmpStr)]:=#0;
if not dos_DeleteFile(buffer) then
dosError2InOut(dos_IoErr);
end;
procedure chdir(const s : string);[IOCheck];
var
buffer : array[0..255] of char;
alock : LongInt;
FIB : PFileInfoBlock;
j : Integer;
tmpStr : string;
begin
checkCTRLC;
If (s='') or (InOutRes<>0) then exit;
tmpStr:=s;
for j:=1 to length(tmpStr) do
if tmpStr[j]='\' then tmpStr[j]:='/';
{ Return parent directory }
if s='..' then begin
getdir(0,tmpStr);
j:=length(tmpStr);
{ Look through the previous paths }
while (tmpStr[j]<>'/') and (tmpStr[j]<>':') and (j>0) do
dec(j);
if j>0 then
tmpStr:=copy(tmpStr,1,j);
end;
alock:=0;
move(tmpStr[1],buffer,length(tmpStr));
buffer[length(tmpStr)]:=#0;
{ Changing the directory is a pretty complicated affair }
{ 1) Obtain a lock on the directory }
{ 2) CurrentDir the lock }
alock:=dos_Lock(buffer,SHARED_LOCK);
if alock=0 then begin
dosError2InOut(dos_IoErr);
exit;
end;
FIB:=nil;
new(FIB);
if (dos_Examine(alock,FIB)=True) and (FIB^.fib_DirEntryType>0) then begin
alock := dos_CurrentDir(alock);
if MOS_OrigDir=0 then begin
MOS_OrigDir:=alock;
alock:=0;
end;
end;
if alock<>0 then dos_Unlock(alock);
if assigned(FIB) then dispose(FIB)
end;
procedure GetDir (DriveNr: byte; var Dir: ShortString);
var tmpbuf: array[0..255] of char;
begin
checkCTRLC;
Dir:='';
if not dos_GetCurrentDirName(tmpbuf,256) then
dosError2InOut(dos_IoErr)
else
Dir:=strpas(tmpbuf);
end;
{****************************************************************************
Low level File Routines
All these functions can set InOutRes on errors
****************************************************************************}
{ close a file from the handle value }
procedure do_close(handle : longint);
begin
RemoveFromList(MOS_fileList,handle);
{ Do _NOT_ check CTRL_C on Close, because it will conflict
with System_Exit! }
if not dos_Close(handle) then
dosError2InOut(dos_IoErr);
end;
procedure do_erase(p : pchar);
begin
checkCTRLC;
if not dos_DeleteFile(p) then
dosError2InOut(dos_IoErr);
end;
procedure do_rename(p1,p2 : pchar);
begin
checkCTRLC;
if not dos_Rename(p1,p2) then
dosError2InOut(dos_IoErr);
end;
function do_write(h:longint; addr: pointer; len: longint) : longint;
var dosResult: LongInt;
begin
checkCTRLC;
do_write:=0;
if len<=0 then exit;
dosResult:=dos_Write(h,addr,len);
if dosResult<0 then begin
dosError2InOut(dos_IoErr);
end else begin
do_write:=dosResult;
end;
end;
function do_read(h:longint; addr: pointer; len: longint) : longint;
var dosResult: LongInt;
begin
checkCTRLC;
do_read:=0;
if len<=0 then exit;
dosResult:=dos_Write(h,addr,len);
if dosResult<0 then begin
dosError2InOut(dos_IoErr);
end else begin
do_read:=dosResult;
end
end;
function do_filepos(handle : longint) : longint;
var dosResult: LongInt;
begin
checkCTRLC;
do_filepos:=0;
{ Seeking zero from OFFSET_CURRENT to find out where we are }
dosResult:=dos_Seek(handle,0,OFFSET_CURRENT);
if dosResult<0 then begin
dosError2InOut(dos_IoErr);
end else begin
do_filepos:=dosResult;
end;
end;
procedure do_seek(handle,pos : longint);
begin
checkCTRLC;
{ Seeking from OFFSET_BEGINNING }
if dos_Seek(handle,pos,OFFSET_BEGINNING)<0 then
dosError2InOut(dos_IoErr);
end;
function do_seekend(handle:longint):longint;
var dosResult: LongInt;
begin
checkCTRLC;
do_seekend:=0;
{ Seeking to OFFSET_END }
dosResult:=dos_Seek(handle,0,OFFSET_END);
if dosResult<0 then begin
dosError2InOut(dos_IoErr);
end else begin
do_seekend:=dosResult;
end
end;
function do_filesize(handle : longint) : longint;
var currfilepos: longint;
begin
checkCTRLC;
currfilepos:=do_filepos(handle);
{ We have to do this twice, because seek returns the OLD position }
do_filesize:=do_seekend(handle);
do_filesize:=do_seekend(handle);
do_seek(handle,currfilepos)
end;
{ truncate at a given position }
procedure do_truncate (handle,pos:longint);
begin
checkCTRLC;
{ Seeking from OFFSET_BEGINNING }
if dos_SetFileSize(handle,pos,OFFSET_BEGINNING)<0 then
dosError2InOut(dos_IoErr);
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;
openflags : 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. }
{ look for parent directory }
if pos('../',path) = 1 then
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
{ look for current directory }
if pos('./',path) = 1 then
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 $10000)=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 }
openflags := 1005;
case (flags and 3) of
0 : filerec(f).mode:=fminput;
1 : filerec(f).mode:=fmoutput;
2 : filerec(f).mode:=fminout;
end;
{ rewrite (create a new file) }
if (flags and $1000)<>0 then openflags := 1006;
{ 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;
i:=dos_Open(buffer,openflags);
if i=0 then
begin
dosError2InOut(dos_IoErr);
end else begin
AddToList(MOS_fileList,i);
filerec(f).handle:=i;
end;
{ append mode }
if ((Flags and $100)<>0) and (FileRec(F).Handle<>UnusedHandle) then
begin
do_seekend(filerec(f).handle);
filerec(f).mode:=fmoutput; {fool fmappend}
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;
{*****************************************************************************
UnTyped File Handling
*****************************************************************************}
{$i file.inc}
{*****************************************************************************
Typed File Handling
*****************************************************************************}
{$i typefile.inc}
{*****************************************************************************
Text File Handling
*****************************************************************************}
{$I text.inc}
{ MorphOS specific startup }
procedure SysInitMorphOS;
var self: PProcess;
begin
self:=PProcess(exec_FindTask(nil));
if self^.pr_CLI=0 then begin
{ if we're running from Ambient/Workbench, we catch its message }
exec_WaitPort(@self^.pr_MsgPort);
MOS_ambMsg:=exec_GetMsg(@self^.pr_MsgPort);
end;
MOS_DOSBase:=exec_OpenLibrary('dos.library',50);
if MOS_DOSBase=nil then Halt(1);
MOS_UtilityBase:=exec_OpenLibrary('utility.library',50);
if MOS_UtilityBase=nil then Halt(1);
{ Creating the memory pool for growing heap }
MOS_heapPool:=exec_CreatePool(MEMF_FAST,growheapsize2,growheapsize1);
if MOS_heapPool=nil then Halt(1);
StdInputHandle:=dos_Input;
StdOutputHandle:=dos_Output;
end;
procedure SysInitStdIO;
begin
OpenStdIO(Input,fmInput,StdInputHandle);
OpenStdIO(Output,fmOutput,StdOutputHandle);
OpenStdIO(StdOut,fmOutput,StdOutputHandle);
{ * MorphOS doesn't have a separate stderr, just like AmigaOS (???) * }
StdErrorHandle:=StdOutputHandle;
// OpenStdIO(StdErr,fmOutput,StdErrorHandle);
end;
{procedure SysInitExecPath;
var
hs : string[16];
link : string;
i : longint;
begin
str(Fpgetpid,hs);
hs:='/proc/'+hs+'/exe'#0;
i:=Fpreadlink(@hs[1],@link[1],high(link));
{ it must also be an absolute filename, linux 2.0 points to a memory
location so this will skip that }
if (i>0) and (link[1]='/') then
begin
link[0]:=chr(i);
ExecPathStr:=link;
end;
end;
}
Begin
IsConsole := TRUE;
IsLibrary := FALSE;
StackLength := InitialStkLen;
StackBottom := Sptr - StackLength;
{ OS specific startup }
MOS_ambMsg:=nil;
MOS_origDir:=0;
MOS_fileList:=nil;
SysInitMorphOS;
{ Set up signals handlers }
// InstallSignals;
{ Setup heap }
InitHeap;
// SysInitExceptions;
{ Setup stdin, stdout and stderr }
SysInitStdIO;
{ Reset IO Error }
InOutRes:=0;
{ Arguments }
// SetupCmdLine;
// SysInitExecPath;
GenerateArgs;
(* This should be changed to a real value during *)
(* thread driver initialization if appropriate. *)
ThreadID := 1;
{$ifdef HASVARIANT}
initvariantmanager;
{$endif HASVARIANT}
End.
{
$Log$
Revision 1.8 2004-05-12 20:26:04 karoly
+ added syscalls and structures necessary for DOS unit
Revision 1.7 2004/05/12 15:34:16 karoly
* fixed startup code from endless wait when not started from Ambient
Revision 1.6 2004/05/09 14:42:59 karoly
* again, few more new things added
Revision 1.5 2004/05/09 02:02:42 karoly
* more things got implemented
Revision 1.4 2004/05/02 02:06:57 karoly
+ most of file I/O calls implemented
Revision 1.3 2004/05/01 15:09:47 karoly
* first working system unit (very limited yet)
Revision 1.2 <20>2004/04/08 06:28:29 <20>karoly
* first steps to have a morphos system unit
Revision 1.1 2004/02/13 07:19:53 karoly
* quick hack from Linux system unit
}
Reference in New Issue View Git Blame Copy Permalink