1{
2    This file is part of the Free Pascal run time library.
3    Copyright (c) 2004-2006 by Karoly Balogh
4
5    AROS conversion
6    Copyright (c) 2011 by Marcus Sackrow
7
8    System unit for AROS
9
10    Uses parts of the Free Pascal 1.0.x for Commodore Amiga/68k port
11    by Carl Eric Codere and Nils Sjoholm
12
13    See the file COPYING.FPC, included in this distribution,
14    for details about the copyright.
15
16    This program is distributed in the hope that it will be useful,
17    but WITHOUT ANY WARRANTY; without even the implied warranty of
18    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
19
20 **********************************************************************}
21
22unit System;
23
24interface
25
26{$define FPC_IS_SYSTEM}
27
28{$I systemh.inc}
29{$I osdebugh.inc}
30
31const
32  LineEnding = #10;
33  LFNSupport = True;
34  DirectorySeparator = '/';
35  DriveSeparator = ':';
36  ExtensionSeparator = '.';
37  PathSeparator = ';';
38  AllowDirectorySeparators : set of char = ['\','/'];
39  AllowDriveSeparators : set of char = [':'];
40  maxExitCode = 255;
41  MaxPathLen = 256;
42  AllFilesMask = '#?';
43
44const
45  UnusedHandle    : THandle = 0;
46  StdInputHandle  : THandle = 0;
47  StdOutputHandle : THandle = 0;
48  StdErrorHandle  : THandle = 0;
49
50  FileNameCaseSensitive : Boolean = False;
51  FileNameCasePreserving: boolean = True;
52  CtrlZMarksEOF: Boolean = false; (* #26 not considered as end of file *)
53
54  sLineBreak = LineEnding;
55  DefaultTextLineBreakStyle : TTextLineBreakStyle = tlbsLF;
56
57  BreakOn : Boolean = True;
58
59
60
61var
62  AOS_ExecBase   : Pointer; external name '_ExecBase';
63  AOS_DOSBase    : Pointer;
64  AOS_UtilityBase: Pointer;
65  AROS_ThreadLib : Pointer; public name 'AROS_THREADLIB';
66
67  ASYS_heapPool : Pointer; { pointer for the OS pool for growing the heap }
68  ASYS_fileSemaphore: Pointer; { mutex semaphore for filelist access arbitration }
69  ASYS_origDir  : LongInt; { original directory on startup }
70  AOS_wbMsg    : Pointer;
71  AOS_ConName  : PChar ='CON:10/30/620/100/FPC Console Output/AUTO/CLOSE/WAIT';
72  AOS_ConHandle: THandle;
73
74  SysDebugBase: Pointer = nil;
75
76  argc: LongInt;
77  argv: PPChar;
78  envp: PPChar;
79  killed : Boolean = False;
80
81function GetLibAdress(Base: Pointer; Offset: LongInt): Pointer;
82procedure Debug(s: string);
83procedure Debugln(s: string);
84procedure EnableBackTraceStr;
85
86implementation
87
88{$I system.inc}
89{$I osdebug.inc}
90type
91    PWBArg = ^TWBArg;
92    TWBArg = record
93        wa_Lock         : LongInt;      { a lock descriptor }
94        wa_Name         : PChar;       { a string relative to that lock }
95    end;
96
97    WBArgList = array[1..MaxInt] of TWBArg; { Only 1..smNumArgs are valid }
98    PWBArgList = ^WBArgList;
99
100
101    PWBStartup = ^TWBStartup;
102    TWBStartup = record
103        sm_Message      : TMessage;      { a standard message structure }
104        sm_Process      : Pointer;   { the process descriptor for you }
105        sm_Segment      : Pointer;     { a descriptor for your code }
106        sm_NumArgs      : Longint;      { the number of elements in ArgList }
107        sm_ToolWindow   : Pointer;       { description of window }
108        sm_ArgList      : PWBArgList; { the arguments themselves }
109    end;
110
111{*****************************************************************************
112                       Misc. System Dependent Functions
113*****************************************************************************}
114
115procedure haltproc(e:longint); cdecl; external name '_haltproc';
116
117procedure System_exit;
118var
119  oldDirLock: LongInt;
120begin
121  if Killed then
122    Exit;
123  Killed := True;
124
125  { Dispose the thread init/exit chains }
126  CleanupThreadProcChain(threadInitProcList);
127  CleanupThreadProcChain(threadExitProcList);
128
129  { Closing opened files }
130  CloseList(ASYS_fileList);
131  { Changing back to original directory if changed }
132  if ASYS_OrigDir <> 0 then begin
133    oldDirLock:=CurrentDir(ASYS_origDir);
134    { unlock our lock if its safe, so we won't leak the lock }
135    if (oldDirLock<>0) and (oldDirLock<>ASYS_origDir) then
136      Unlock(oldDirLock);
137  end;
138  // debug lib
139  if SysDebugBase <> nil then
140    CloseLibrary(SysDebugBase);
141  SysDebugBase := nil;
142  // utility
143  if AOS_UtilityBase <> nil then
144    CloseLibrary(AOS_UtilityBase);
145  // Heap
146  if ASYS_heapPool <> nil then
147    DeletePool(ASYS_heapPool);
148  AOS_UtilityBase := nil;
149  ASYS_HeapPool := nil;
150  // dos
151  if AOS_DOSBase<>nil then
152    CloseLibrary(AOS_DOSBase);
153  AOS_DOSBase := nil;
154  //
155  if AOS_wbMsg <> nil then
156  begin
157    // forbid -> Amiga RKM Libraries Manual
158    Forbid();
159    // Reply WBStartupMessage
160    ReplyMsg(AOS_wbMsg);
161  end;
162  //
163  HaltProc(ExitCode);
164end;
165
166{*****************************************************************************
167                          Parameterhandling
168                       as include in amicommon
169*****************************************************************************}
170
171{$I paramhandling.inc}
172
173{*****************************************************************************
174                             Randomize
175*****************************************************************************}
176
177{ set randseed to a new pseudo random value }
178procedure Randomize;
179var
180  tmpTime: TDateStamp;
181begin
182  DateStamp(@tmpTime);
183  randseed := tmpTime.ds_tick;
184end;
185
186
187
188
189{ AmigaOS specific startup }
190procedure SysInitAmigaOS;
191var
192  self: PProcess;
193begin
194  self := PProcess(FindTask(nil));
195  if self^.pr_CLI = 0 then begin
196    { if we're running from Ambient/Workbench, we catch its message }
197    WaitPort(@self^.pr_MsgPort);
198    AOS_wbMsg:=GetMsg(@self^.pr_MsgPort);
199  end;
200
201  AOS_DOSBase := OpenLibrary('dos.library', 0);
202  if AOS_DOSBase = nil then
203    Halt(1);
204  AOS_UtilityBase := OpenLibrary('utility.library', 0);
205  if AOS_UtilityBase = nil then
206    Halt(1);
207
208  { Creating the memory pool for growing heap }
209  ASYS_heapPool := CreatePool(MEMF_ANY or MEMF_SEM_PROTECTED, growheapsize2, growheapsize1);
210  if ASYS_heapPool = nil then
211    Halt(1);
212
213  { Initialize semaphore for filelist access arbitration }
214  ASYS_fileSemaphore:=AllocPooled(ASYS_heapPool,sizeof(TSignalSemaphore));
215  if ASYS_fileSemaphore = nil then
216    Halt(1);
217  InitSemaphore(ASYS_fileSemaphore);
218
219  if AOS_wbMsg = nil then begin
220    StdInputHandle := THandle(dosInput);
221    StdOutputHandle := THandle(dosOutput);
222    StdErrorHandle := THandle(DosError1);
223  end else begin
224    AOS_ConHandle := Open(AOS_ConName, MODE_OLDFILE);
225    if AOS_ConHandle <> 0 then begin
226      StdInputHandle := AOS_ConHandle;
227      StdOutputHandle := AOS_ConHandle;
228      StdErrorHandle := AOS_ConHandle;
229    end else
230      Halt(1);
231  end;
232end;
233
234function AROSBackTraceStr(Addr: CodePointer): ShortString;
235const
236  DL_Dummy = TAG_USER + $03e00000;
237  DL_ModuleName = DL_Dummy + 1;
238  DL_SymbolName = DL_Dummy + 7;
239var
240  SymName, ModName: PChar;
241  Tags: array[0..5] of PtrUInt;
242  s: AnsiString;
243  Res: AnsiString;
244begin
245  if Assigned(SysDebugBase) then
246  begin
247    ModName := nil;
248    SymName := nil;
249    Tags[0] := DL_Modulename;
250    Tags[1] := PtrUInt(@ModName);
251    Tags[2] := DL_SymbolName;
252    Tags[3] := PtrUInt(@SymName);
253    Tags[4] := 0;
254    Tags[5] := 0;
255    DecodeLocation(Addr, @Tags[0]);
256    s := '-';
257    if not Assigned(ModName) then
258      ModName := @S[1];
259    if not Assigned(SymName) then
260      SymName := @S[1];
261    Res := '  $' + HexStr(Addr) + ' ' + ModName  + ' ' + SymName;
262    AROSBackTraceStr := Copy(Res, 1, 254);
263  end
264  else
265  begin
266    AROSBackTraceStr := '  $' + HexStr(Addr) + ' - ';
267  end;
268end;
269
270procedure EnableBackTraceStr;
271begin
272  if not Assigned(SysDebugBase) then
273  begin
274    SysDebugBase := OpenLibrary('debug.library', 0);
275    if Assigned(SysDebugBase) then
276      BackTraceStrFunc := @AROSBackTraceStr;
277  end;
278end;
279
280
281procedure SysInitStdIO;
282begin
283  OpenStdIO(Input,fmInput,StdInputHandle);
284  OpenStdIO(Output,fmOutput,StdOutputHandle);
285  OpenStdIO(StdOut,fmOutput,StdOutputHandle);
286  OpenStdIO(StdErr,fmOutput,StdErrorHandle);
287end;
288
289function GetProcessID: SizeUInt;
290begin
291  GetProcessID := SizeUInt(FindTask(NIL));
292end;
293
294function CheckInitialStkLen(stklen : SizeUInt) : SizeUInt;
295begin
296  result := stklen;
297end;
298
299begin
300  IsConsole := TRUE;
301  SysResetFPU;
302  if not (IsLibrary) then
303    SysInitFPU;
304  StackLength := CheckInitialStkLen(InitialStkLen);
305  StackBottom := Sptr - StackLength;
306{ OS specific startup }
307  AOS_wbMsg := nil;
308  ASYS_origDir := 0;
309  ASYS_fileList := nil;
310  envp := nil;
311  SysInitAmigaOS;
312{ Set up signals handlers }
313  //InstallSignals;
314{ Setup heap }
315  InitHeap;
316  SysInitExceptions;
317  initunicodestringmanager;
318{ Setup stdin, stdout and stderr }
319  SysInitStdIO;
320{ Reset IO Error }
321  InOutRes:=0;
322  { Arguments }
323  GenerateArgs;
324  InitSystemThreads;
325  InitSystemDynLibs;
326end.
327