system.pp 12 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399
  1. {
  2. This file is part of the Free Pascal run time library.
  3. Copyright (c) 2004-2006 by Karoly Balogh
  4. System unit for AmigaOS 3.x/4.x
  5. Uses parts of the Free Pascal 1.0.x for Commodore Amiga/68k port
  6. by Carl Eric Codere and Nils Sjoholm
  7. See the file COPYING.FPC, included in this distribution,
  8. for details about the copyright.
  9. This program is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  12. **********************************************************************}
  13. unit System;
  14. interface
  15. {$define FPC_IS_SYSTEM}
  16. {$define FPC_ANSI_TEXTFILEREC}
  17. {$ifdef cpum68k}
  18. {$define FPC_SYSTEM_HAS_BACKTRACESTR}
  19. {$endif}
  20. {$if defined(AMIGA_V1_0_ONLY) or defined(AMIGA_V1_2_ONLY)}
  21. {$define AMIGA_LEGACY}
  22. {$endif}
  23. {$if defined(AMIGA_LEGACY) or defined(AMIGA_USE_OSHEAP)}
  24. {$define FPC_AMIGA_USE_OSHEAP}
  25. {$endif}
  26. {$ifdef FPC_AMIGA_USE_OSHEAP}
  27. {$define HAS_MEMORYMANAGER}
  28. {$endif FPC_AMIGA_USE_OSHEAP}
  29. {$I systemh.inc}
  30. {$I osdebugh.inc}
  31. {$if defined(cpum68k) and defined(fpusoft)}
  32. {$define fpc_softfpu_interface}
  33. {$i softfpu.pp}
  34. {$undef fpc_softfpu_interface}
  35. {$endif defined(cpum68k) and defined(fpusoft)}
  36. const
  37. {$if defined(AMIGA_V1_0_ONLY)}
  38. AMIGA_OS_MINVERSION = 0;
  39. {$else}
  40. {$if defined(AMIGA_V1_2_ONLY)}
  41. AMIGA_OS_MINVERSION = 33;
  42. {$else}
  43. {$if defined(AMIGA_V2_0_ONLY)}
  44. AMIGA_OS_MINVERSION = 37;
  45. {$else}
  46. {$ifndef cpupowerpc}
  47. AMIGA_OS_MINVERSION = 39;
  48. {$else}
  49. AMIGA_OS_MINVERSION = 50;
  50. {$endif}
  51. {$endif}
  52. {$endif}
  53. {$endif}
  54. const
  55. LineEnding = #10;
  56. LFNSupport = True;
  57. DirectorySeparator = '/';
  58. DriveSeparator = ':';
  59. ExtensionSeparator = '.';
  60. PathSeparator = ';';
  61. AllowDirectorySeparators : set of char = ['\','/'];
  62. AllowDriveSeparators : set of char = [':'];
  63. maxExitCode = 255;
  64. MaxPathLen = 256;
  65. AllFilesMask = '#?';
  66. const
  67. UnusedHandle : LongInt = -1;
  68. StdInputHandle : LongInt = 0;
  69. StdOutputHandle : LongInt = 0;
  70. StdErrorHandle : LongInt = 0;
  71. FileNameCaseSensitive : Boolean = False;
  72. FileNameCasePreserving: boolean = True;
  73. CtrlZMarksEOF: boolean = false; (* #26 not considered as end of file *)
  74. sLineBreak = LineEnding;
  75. DefaultTextLineBreakStyle : TTextLineBreakStyle = tlbsLF;
  76. BreakOn : Boolean = True;
  77. { FIX ME: remove the kludge required by amunits package, which needs a huge rework }
  78. var
  79. AOS_ExecBase : Pointer; external name '_ExecBase';
  80. _ExecBase: Pointer; external name '_ExecBase'; { amunits compatibility kludge }
  81. AOS_DOSBase : Pointer; public name '_DOSBase'; { the "public" part is amunits compatibility kludge }
  82. _DOSBase: Pointer; external name '_DOSBase'; { amunits compatibility kludge }
  83. AOS_UtilityBase: Pointer; public name '_UtilityBase'; { the "public" part is amunits compatibility kludge }
  84. _UtilityBase: Pointer; external name '_UtilityBase'; { amunits compatibility kludge }
  85. AOS_IntuitionBase: Pointer; public name '_IntuitionBase'; { amunits compatibility kludge }
  86. _IntuitionBase: Pointer; external name '_IntuitionBase'; { amunits compatibility kludge }
  87. {$IFDEF AMIGAOS4}
  88. {$WARNING iExec, iDOS and iUtility should be typed pointer later}
  89. var
  90. IExec : Pointer; external name '_IExec';
  91. IDOS : Pointer;
  92. IUtility : Pointer;
  93. {$ENDIF}
  94. ASYS_heapPool : Pointer; { pointer for the OS pool for growing the heap }
  95. ASYS_heapSemaphore: Pointer; { 68k OS from 3.x has no MEMF_SEM_PROTECTED for pools, have to do it ourselves }
  96. ASYS_fileSemaphore: Pointer; { mutex semaphore for filelist access arbitration }
  97. ASYS_origDir : LongInt; { original directory on startup }
  98. AOS_wbMsg : Pointer; public name '_WBenchMsg'; { the "public" part is amunits compatibility kludge }
  99. _WBenchMsg : Pointer; external name '_WBenchMsg'; { amunits compatibility kludge }
  100. AOS_ConName : PChar ='CON:10/30/620/100/FPC Console Output/AUTO/CLOSE/WAIT';
  101. AOS_ConHandle: LongInt;
  102. argc: LongInt;
  103. argv: PPChar;
  104. envp: PPChar;
  105. implementation
  106. {$if defined(cpum68k) and defined(fpusoft)}
  107. {$define fpc_softfpu_implementation}
  108. {$define softfpu_compiler_mul32to64}
  109. {$define softfpu_inline}
  110. {$i softfpu.pp}
  111. {$undef fpc_softfpu_implementation}
  112. { we get these functions and types from the softfpu code }
  113. {$define FPC_SYSTEM_HAS_float64}
  114. {$define FPC_SYSTEM_HAS_float32}
  115. {$define FPC_SYSTEM_HAS_flag}
  116. {$define FPC_SYSTEM_HAS_extractFloat64Frac0}
  117. {$define FPC_SYSTEM_HAS_extractFloat64Frac1}
  118. {$define FPC_SYSTEM_HAS_extractFloat64Exp}
  119. {$define FPC_SYSTEM_HAS_extractFloat64Sign}
  120. {$define FPC_SYSTEM_HAS_ExtractFloat32Frac}
  121. {$define FPC_SYSTEM_HAS_extractFloat32Exp}
  122. {$define FPC_SYSTEM_HAS_extractFloat32Sign}
  123. {$endif defined(cpum68k) and defined(fpusoft)}
  124. {$ifdef FPC_SYSTEM_HAS_BACKTRACESTR}
  125. var
  126. _start: byte; external name '_start';
  127. { __text_size is provided by the linker }
  128. __text_size: ptruint; external name '___text_size';
  129. var
  130. codestart: pointer;
  131. codeend: pointer;
  132. {$endif FPC_SYSTEM_HAS_BACKTRACESTR}
  133. {$I system.inc}
  134. {$ifdef FPC_AMIGA_USE_OSHEAP}
  135. {$i osheap.inc}
  136. {$endif FPC_AMIGA_USE_OSHEAP}
  137. {$I osdebug.inc}
  138. {$IFDEF AMIGAOS4}
  139. // Required to allow opening of utility library interface...
  140. {$include utilf.inc}
  141. {$ENDIF}
  142. {$IFDEF ASYS_FPC_FILEDEBUG}
  143. {$WARNING Compiling with file debug enabled!}
  144. {$ENDIF}
  145. {$IFDEF ASYS_FPC_MEMDEBUG}
  146. {$WARNING Compiling with memory debug enabled!}
  147. {$ENDIF}
  148. type
  149. PWBArg = ^TWBArg;
  150. TWBArg = record
  151. wa_Lock : LongInt; { a lock descriptor }
  152. wa_Name : PChar; { a string relative to that lock }
  153. end;
  154. WBArgList = array[1..MaxInt] of TWBArg; { Only 1..smNumArgs are valid }
  155. PWBArgList = ^WBArgList;
  156. PWBStartup = ^TWBStartup;
  157. TWBStartup = record
  158. sm_Message : TMessage; { a standard message structure }
  159. sm_Process : Pointer; { the process descriptor for you }
  160. sm_Segment : Pointer; { a descriptor for your code }
  161. sm_NumArgs : Longint; { the number of elements in ArgList }
  162. sm_ToolWindow : Pointer; { description of window }
  163. sm_ArgList : PWBArgList; { the arguments themselves }
  164. end;
  165. {*****************************************************************************
  166. Misc. System Dependent Functions
  167. *****************************************************************************}
  168. procedure haltproc(e:longint);cdecl;external name '_haltproc';
  169. procedure System_exit;
  170. var
  171. oldDirLock: LongInt;
  172. begin
  173. { Dispose the thread init/exit chains }
  174. CleanupThreadProcChain(threadInitProcList);
  175. CleanupThreadProcChain(threadExitProcList);
  176. { We must remove the CTRL-C FLAG here because halt }
  177. { may call I/O routines, which in turn might call }
  178. { halt, so a recursive stack crash }
  179. if BreakOn then begin
  180. if (SetSignal(0,0) and SIGBREAKF_CTRL_C)<>0 then
  181. SetSignal(0,SIGBREAKF_CTRL_C);
  182. end;
  183. { Closing opened files }
  184. CloseList(ASYS_fileList);
  185. { Changing back to original directory if changed }
  186. if ASYS_origDir<>0 then begin
  187. oldDirLock:=CurrentDir(ASYS_origDir);
  188. { unlock our lock if its safe, so we won't leak the lock }
  189. if (oldDirLock<>0) and (oldDirLock<>ASYS_origDir) then
  190. Unlock(oldDirLock);
  191. end;
  192. {$IFDEF AMIGAOS4}
  193. if iDOS<>nil then DropInterface(iDOS);
  194. if iUtility<>nil then DropInterface(iUtility);
  195. {$ENDIF}
  196. if AOS_IntuitionBase<>nil then CloseLibrary(AOS_IntuitionBase); { amunits kludge }
  197. if AOS_UtilityBase<>nil then CloseLibrary(AOS_UtilityBase);
  198. if AOS_DOSBase<>nil then CloseLibrary(AOS_DOSBase);
  199. if ASYS_heapPool<>nil then DeletePool(ASYS_heapPool);
  200. { If in Workbench mode, replying WBMsg }
  201. if AOS_wbMsg<>nil then begin
  202. Forbid;
  203. ReplyMsg(AOS_wbMsg);
  204. end;
  205. haltproc(ExitCode);
  206. end;
  207. {*****************************************************************************
  208. Parameterhandling
  209. as include in amicommon
  210. *****************************************************************************}
  211. {$I paramhandling.inc}
  212. {*****************************************************************************
  213. Randomize
  214. *****************************************************************************}
  215. { set randseed to a new pseudo random value }
  216. procedure randomize;
  217. var tmpTime: TDateStamp;
  218. begin
  219. DateStamp(@tmpTime);
  220. randseed:=tmpTime.ds_tick;
  221. end;
  222. {$IFDEF FPC_AMIGA_USE_OSHEAP}
  223. var
  224. { generated by the compiler based on the $MEMORY directive }
  225. heapsize : PtrInt; external name '__heapsize';
  226. {$ENDIF FPC_AMIGA_USE_OSHEAP}
  227. { AmigaOS specific startup }
  228. procedure SysInitAmigaOS;
  229. var self: PProcess;
  230. begin
  231. self:=PProcess(FindTask(nil));
  232. if self^.pr_CLI=0 then begin
  233. { if we're running from Ambient/Workbench, we catch its message }
  234. WaitPort(@self^.pr_MsgPort);
  235. AOS_wbMsg:=GetMsg(@self^.pr_MsgPort);
  236. end;
  237. AOS_DOSBase:=OpenLibrary('dos.library',AMIGA_OS_MINVERSION);
  238. if AOS_DOSBase=nil then Halt(1);
  239. {$ifndef AMIGA_LEGACY}
  240. AOS_UtilityBase:=OpenLibrary('utility.library',AMIGA_OS_MINVERSION);
  241. if AOS_UtilityBase=nil then Halt(1);
  242. {$endif}
  243. AOS_IntuitionBase:=OpenLibrary('intuition.library',AMIGA_OS_MINVERSION); { amunits support kludge }
  244. if AOS_IntuitionBase=nil then Halt(1);
  245. {$IFDEF AMIGAOS4}
  246. { Open main interfaces on OS4 }
  247. iDOS := GetInterface(AOS_DOSBase,'main',1,nil);
  248. iUtility := GetInterface(AOS_UtilityBase,'main',1,nil);
  249. {$ENDIF}
  250. { Creating the memory pool for growing heap }
  251. {$IFNDEF FPC_AMIGA_USE_OSHEAP}
  252. ASYS_heapPool:=CreatePool(MEMF_ANY,growheapsize2,growheapsize1);
  253. {$ELSE FPC_AMIGA_USE_OSHEAP}
  254. ASYS_heapPool:=CreatePool(MEMF_ANY,min(heapsize,1024),min(heapsize div 2,1024));
  255. {$ENDIF FPC_AMIGA_USE_OSHEAP}
  256. if ASYS_heapPool=nil then Halt(1);
  257. ASYS_heapSemaphore:=AllocPooled(ASYS_heapPool,sizeof(TSignalSemaphore));
  258. if ASYS_heapSemaphore = nil then Halt(1);
  259. InitSemaphore(ASYS_heapSemaphore);
  260. { Initialize semaphore for filelist access arbitration }
  261. ASYS_fileSemaphore:=AllocPooled(ASYS_heapPool,sizeof(TSignalSemaphore));
  262. if ASYS_fileSemaphore = nil then Halt(1);
  263. InitSemaphore(ASYS_fileSemaphore);
  264. if AOS_wbMsg=nil then begin
  265. StdInputHandle:=dosInput;
  266. StdOutputHandle:=dosOutput;
  267. StdErrorHandle:=StdOutputHandle;
  268. end else begin
  269. AOS_ConHandle:=Open(AOS_ConName,MODE_OLDFILE);
  270. if AOS_ConHandle<>0 then begin
  271. StdInputHandle:=AOS_ConHandle;
  272. StdOutputHandle:=AOS_ConHandle;
  273. StdErrorHandle:=AOS_ConHandle;
  274. end else
  275. Halt(1);
  276. end;
  277. end;
  278. procedure SysInitStdIO;
  279. begin
  280. OpenStdIO(Input,fmInput,StdInputHandle);
  281. OpenStdIO(Output,fmOutput,StdOutputHandle);
  282. OpenStdIO(ErrOutput,fmOutput,StdErrorHandle);
  283. {$ifndef FPC_STDOUT_TRUE_ALIAS}
  284. OpenStdIO(StdOut,fmOutput,StdOutputHandle);
  285. OpenStdIO(StdErr,fmOutput,StdErrorHandle);
  286. {$endif FPC_STDOUT_TRUE_ALIAS}
  287. end;
  288. function GetProcessID: SizeUInt;
  289. begin
  290. GetProcessID:=SizeUInt(FindTask(NIL));
  291. end;
  292. function CheckInitialStkLen(stklen : SizeUInt) : SizeUInt;
  293. begin
  294. result := stklen;
  295. end;
  296. begin
  297. IsConsole := TRUE;
  298. StackLength := CheckInitialStkLen(InitialStkLen);
  299. StackBottom := StackTop - StackLength;
  300. {$ifdef FPC_SYSTEM_HAS_BACKTRACESTR}
  301. codestart := @_start;
  302. codeend := pointer(ptruint(@_start) + ptruint(@__text_size));
  303. {$endif FPC_SYSTEM_HAS_BACKTRACESTR}
  304. { OS specific startup }
  305. AOS_wbMsg:=nil;
  306. ASYS_origDir:=0;
  307. ASYS_fileList:=nil;
  308. envp:=nil;
  309. SysInitAmigaOS;
  310. { Set up signals handlers }
  311. // InstallSignals;
  312. {$ifndef FPC_AMIGA_USE_OSHEAP}
  313. { Setup heap }
  314. InitHeap;
  315. {$endif FPC_AMIGA_USE_OSHEAP}
  316. SysInitExceptions;
  317. {$ifdef cpum68k}
  318. fpc_cpucodeinit;
  319. {$endif}
  320. initunicodestringmanager;
  321. { Setup stdin, stdout and stderr }
  322. SysInitStdIO;
  323. { Reset IO Error }
  324. InOutRes:=0;
  325. { Arguments }
  326. GenerateArgs;
  327. InitSystemThreads;
  328. {$ifdef FPC_HAS_FEATURE_DYNLIBS}
  329. InitSystemDynLibs;
  330. {$endif}
  331. end.