paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-05-05 20:52:33 +02:00
Code Issues Packages Projects Releases Wiki Activity
86d943719c
fpc/rtl/morphos/system.pp
Károly Balogh 86d943719c + added support for paramstr(0)
2004-06-06 19:18:05 +00:00

1371 lines
41 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 S.a.r.l.
System unit for MorphOS/PowerPC
Uses parts of the Commodore Amiga/68k port by Carl Eric Codere
and Nils Sjoholm
MorphOS port was done on a free Pegasos II/G4 machine
provided by Genesi S.a.r.l. <www.genesi.lu>
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 = packed record
dd_Library: TLibrary;
end;
PUnit = ^tUnit;
TUnit = packed 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_ConHandle: LongInt;
argc: LongInt;
argv: PPChar;
envp: 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 42;
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;
function dos_GetProgramDir: LongInt; SysCall MOS_DOSBase 600;
function dos_GetProgramName(buf: PChar location 'd1';
len: LongInt location 'd2'): Boolean; SysCall MOS_DOSBase 576;
{ 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(argv,argvlen*sizeof(pointer));
for i:=oldargvlen to argvlen-1 do
argv[i]:=nil;
end;
{ use realloc to reuse already existing memory }
sysreallocmem(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],argv[0]^,length(temp));
argv[0][length(temp)]:=#0;
{ check if we're started from Ambient }
if MOS_ambMsg<>nil then
begin
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],argv[localindex]^,count-start);
argv[localindex][count-start]:=#0;
inc(localindex);
end;
end;
argc:=localindex;
end;
function GetProgramDir: String;
var
s1 : String;
alock : LongInt;
counter: Byte;
begin
GetProgramDir:='';
FillChar(s1,255,#0);
{ GetLock of program directory }
alock:=dos_GetProgramDir;
if alock<>0 then begin
if dos_NameFromLock(alock,@s1[1],255) then begin
counter:=1;
while (s1[counter]<>#0) and (counter<>0) do Inc(counter);
s1[0]:=Char(counter-1);
GetProgramDir:=s1;
end;
end;
end;
function GetProgramName: String;
{ Returns ONLY the program name }
var
s1 : String;
counter: Byte;
begin
GetProgramName:='';
FillChar(s1,255,#0);
if dos_GetProgramName(@s1[1],255) then begin
{ now check out and assign the length of the string }
counter := 1;
while (s1[counter]<>#0) and (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;
end;
{*****************************************************************************
ParamStr/Randomize
*****************************************************************************}
{ number of args }
function paramcount : longint;
begin
if MOS_ambMsg<>nil then
paramcount:=0
else
paramcount:=argc-1;
end;
{ argument number l }
function paramstr(l : longint) : string;
var
s1: String;
begin
paramstr:='';
if MOS_ambMsg<>nil then exit;
if l=0 then begin
s1:=GetProgramDir;
if s1[length(s1)]=':' then paramstr:=s1+GetProgramName
else paramstr:=s1+'/'+GetProgramName;
end else begin
if (l>0) and (l+1<=argc) then paramstr:=strpas(argv[l]);
end;
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_Read(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);
if MOS_ambMsg=nil then begin
StdInputHandle:=dos_Input;
StdOutputHandle:=dos_Output;
end else begin
MOS_ConHandle:=dos_Open(MOS_ConName,1005);
if MOS_ConHandle<>0 then begin
StdInputHandle:=MOS_ConHandle;
StdOutputHandle:=MOS_ConHandle;
end else
Halt(1);
end;
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;
envp:=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.11 2004-06-06 19:18:05 karoly
+ added support for paramstr(0)
Revision 1.10 2004/06/05 19:49:19 karoly
+ added console I/O support when running from Ambient
Revision 1.9 2004/05/12 23:18:54 karoly
* fixed do_read and dos_Read from being nonsense
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