123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252 |
- {
- This file is part of the Free Pascal run time library.
- Copyright (c) 2001 by Free Pascal development team
- This file implements all the base types and limits required
- for a minimal POSIX compliant subset required to port the compiler
- to a new OS.
- 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.
- **********************************************************************}
- {*****************************************************************************
- AmigaOS structures
- *****************************************************************************}
- {$include execd.inc}
- {$include timerd.inc}
- {$include doslibd.inc}
- {*****************************************************************************
- AmigaOS functions
- *****************************************************************************}
- {$include execf.inc}
- {$include doslibf.inc}
- {*****************************************************************************
- CPU specific
- *****************************************************************************}
- {$ifdef cpum68k}
- {$include m68kamiga.inc}
- {$endif}
- {*****************************************************************************
- System Dependent Structures/Consts
- *****************************************************************************}
- {$ifndef FPC_SYSTEM_HAS_STACKTOP}
- {$define FPC_SYSTEM_HAS_STACKTOP}
- function StackTop: pointer;
- begin
- StackTop:=FindTask(nil)^.tc_SPUpper;
- end;
- {$endif FPC_SYSTEM_HAS_STACKTOP}
- const
- CTRL_C = 20; { Error code on CTRL-C press }
- { Used for CTRL_C checking in I/O calls }
- procedure checkCTRLC;
- begin
- if BreakOn then begin
- if (SetSignal(0,0) And SIGBREAKF_CTRL_C)<>0 then begin
- { Clear CTRL-C signal }
- SetSignal(0,SIGBREAKF_CTRL_C);
- Halt(CTRL_C);
- end;
- end;
- end;
- { Converts a AmigaOS 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;
- { Converts an Unix-like path to Amiga-like path }
- function PathConv(path: string): string; alias: 'PATHCONV'; [public];
- var tmppos: longint;
- begin
- { check for short paths }
- if length(path)<=2 then begin
- if (path='.') or (path='./') then path:='' else
- if path='..' then path:='/' else
- if path='*' then path:='#?';
- end else begin
- { convert parent directories }
- tmppos:=pos('../',path);
- while tmppos<>0 do begin
- { delete .. to have / as parent dir sign }
- delete(path,tmppos,2);
- tmppos:=pos('../',path);
- end;
- { convert current directories }
- tmppos:=pos('./',path);
- while tmppos<>0 do begin
- { delete ./ since we doesn't need to sign current directory }
- delete(path,tmppos,2);
- tmppos:=pos('./',path);
- end;
- { convert wildstar to #? }
- tmppos:=pos('*',path);
- while tmppos<>0 do begin
- delete(path,tmppos,1);
- insert('#?',path,tmppos);
- tmppos:=pos('*',path);
- end;
- end;
- PathConv:=path;
- end;
- { Converts an Unix-like path to Amiga-like path }
- function PathConv(const path: rawbytestring): rawbytestring; alias: 'PATHCONVRBS'; [public];
- var tmppos: longint;
- begin
- { check for short paths }
- if length(path)<=2 then begin
- if (path='.') or (path='./') then PathConv:='' else
- if path='..' then PathConv:='/' else
- if path='*' then PathConv:='#?'
- else PathConv:=path;
- end else begin
- { convert parent directories }
- PathConv:=path;
- tmppos:=pos('../',PathConv);
- while tmppos<>0 do begin
- { delete .. to have / as parent dir sign }
- delete(PathConv,tmppos,2);
- tmppos:=pos('../',PathConv);
- end;
- { convert current directories }
- tmppos:=pos('./',PathConv);
- while tmppos<>0 do begin
- { delete ./ since we doesn't need to sign current directory }
- delete(PathConv,tmppos,2);
- tmppos:=pos('./',PathConv);
- end;
- { convert wildstar to #? }
- tmppos:=pos('*',PathConv);
- while tmppos<>0 do begin
- delete(PathConv,tmppos,1);
- insert('#?',PathConv,tmppos);
- tmppos:=pos('*',PathConv);
- end;
- end;
- end;
- { Thread Init/Exit Procedure support }
- Type
- PThreadProcInfo = ^TThreadProcInfo;
- TThreadProcInfo = Record
- Next : PThreadProcInfo;
- Proc : TProcedure;
- End;
- const
- threadInitProcList :PThreadProcInfo = nil;
- threadExitProcList :PThreadProcInfo = nil;
- Procedure DoThreadProcChain(p: PThreadProcInfo);
- Begin
- while p <> nil do
- begin
- p^.proc;
- p:=p^.next;
- end;
- End;
- Procedure AddThreadProc(var procList: PThreadProcInfo; Proc: TProcedure);
- var
- P : PThreadProcInfo;
- Begin
- // the ThreadProc chain is only freed after the memory manager has
- // shut down, therefore native OS allocation
- P := AllocPooled(ASYS_heapPool,sizeof(TThreadProcInfo));
- P^.Next:=procList;
- P^.Proc:=Proc;
- procList:=P;
- End;
- Procedure CleanupThreadProcChain(var procList: PThreadProcInfo);
- var
- P : PThreadProcInfo;
- Begin
- while procList <> nil do
- begin
- p:=procList;
- procList:=procList^.next;
- FreePooled(ASYS_heapPool,P,sizeof(TThreadProcInfo));
- end;
- End;
- Procedure AddThreadInitProc(Proc: TProcedure);
- Begin
- AddThreadProc(threadInitProcList,Proc);
- End;
- Procedure AddThreadExitProc(Proc: TProcedure);
- Begin
- AddThreadProc(threadExitProcList,Proc);
- End;
- Procedure DoThreadInitProcChain;
- Begin
- DoThreadProcChain(threadInitProcList);
- End;
- Procedure DoThreadExitProcChain;
- Begin
- DoThreadProcChain(threadExitProcList);
- End;
|