system.pp 23 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935
  1. {
  2. $Id$
  3. This file is part of the Free Pascal run time library.
  4. Copyright (c) 2004 by Karoly Balogh for Genesi S.a.r.l.
  5. System unit for MorphOS/PowerPC
  6. Uses parts of the Commodore Amiga/68k port by Carl Eric Codere
  7. and Nils Sjoholm
  8. MorphOS port was done on a free Pegasos II/G4 machine
  9. provided by Genesi S.a.r.l. <www.genesi.lu>
  10. See the file COPYING.FPC, included in this distribution,
  11. for details about the copyright.
  12. This program is distributed in the hope that it will be useful,
  13. but WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  15. **********************************************************************}
  16. unit {$ifdef VER1_0}SysMorph{$else}System{$endif};
  17. interface
  18. {$define FPC_IS_SYSTEM}
  19. {$I systemh.inc}
  20. type
  21. THandle = LongInt;
  22. {$I heaph.inc}
  23. const
  24. LineEnding = #10;
  25. LFNSupport = True;
  26. DirectorySeparator = '/';
  27. DriveSeparator = ':';
  28. PathSeparator = ';';
  29. maxExitCode = 255;
  30. const
  31. UnusedHandle : LongInt = -1;
  32. StdInputHandle : LongInt = 0;
  33. StdOutputHandle : LongInt = 0;
  34. StdErrorHandle : LongInt = 0;
  35. FileNameCaseSensitive : Boolean = False;
  36. sLineBreak : string[1] = LineEnding;
  37. DefaultTextLineBreakStyle : TTextLineBreakStyle = tlbsLF;
  38. BreakOn : Boolean = True;
  39. var
  40. MOS_ExecBase : Pointer; external name '_ExecBase';
  41. MOS_DOSBase : Pointer;
  42. MOS_UtilityBase: Pointer;
  43. MOS_heapPool : Pointer; { pointer for the OS pool for growing the heap }
  44. MOS_origDir : LongInt; { original directory on startup }
  45. MOS_ambMsg : Pointer;
  46. MOS_ConName : PChar ='CON:10/30/620/100/FPC Console Output/AUTO/CLOSE/WAIT';
  47. MOS_ConHandle: LongInt;
  48. argc: LongInt;
  49. argv: PPChar;
  50. envp: PPChar;
  51. implementation
  52. {$I system.inc}
  53. {*****************************************************************************
  54. MorphOS structures
  55. *****************************************************************************}
  56. {$include execd.inc}
  57. {$include timerd.inc}
  58. {$include doslibd.inc}
  59. {*****************************************************************************
  60. MorphOS functions
  61. *****************************************************************************}
  62. { exec.library functions }
  63. {$include execf.inc}
  64. {$include doslibf.inc}
  65. {*****************************************************************************
  66. System Dependent Structures/Consts
  67. *****************************************************************************}
  68. const
  69. CTRL_C = 20; { Error code on CTRL-C press }
  70. {*****************************************************************************
  71. MorphOS File-handling Support Functions
  72. *****************************************************************************}
  73. type
  74. { AmigaOS does not automatically close opened files on exit back to }
  75. { the operating system, therefore as a precuation we close all files }
  76. { manually on exit. }
  77. PFileList = ^TFileList;
  78. TFileList = record { no packed, must be correctly aligned }
  79. handle : LongInt; { Handle to file }
  80. next : PFileList; { Next file in list }
  81. end;
  82. var
  83. MOS_fileList: PFileList; { List pointer to opened files }
  84. { Function to be called at program shutdown, to close all opened files }
  85. procedure CloseList(l: PFileList);
  86. var
  87. tmpNext : PFileList;
  88. tmpHandle : LongInt;
  89. begin
  90. if l=nil then exit;
  91. { First, close all tracked files }
  92. tmpNext:=l^.next;
  93. while tmpNext<>nil do begin
  94. tmpHandle:=tmpNext^.handle;
  95. if (tmpHandle<>StdInputHandle) and (tmpHandle<>StdOutputHandle)
  96. and (tmpHandle<>StdErrorHandle) then begin
  97. dosClose(tmpHandle);
  98. end;
  99. tmpNext:=tmpNext^.next;
  100. end;
  101. { Next, erase the linked list }
  102. while l<>nil do begin
  103. tmpNext:=l;
  104. l:=l^.next;
  105. dispose(tmpNext);
  106. end;
  107. end;
  108. { Function to be called to add a file to the opened file list }
  109. procedure AddToList(var l: PFileList; h: LongInt);
  110. var
  111. p : PFileList;
  112. inList: Boolean;
  113. begin
  114. inList:=False;
  115. if l<>nil then begin
  116. { if there is a valid filelist, search for the value }
  117. { in the list to avoid double additions }
  118. p:=l;
  119. while (p^.next<>nil) and (not inList) do
  120. if p^.next^.handle=h then inList:=True
  121. else p:=p^.next;
  122. p:=nil;
  123. end else begin
  124. { if the list is not yet allocated, allocate it. }
  125. New(l);
  126. l^.next:=nil;
  127. end;
  128. if not inList then begin
  129. New(p);
  130. p^.handle:=h;
  131. p^.next:=l^.next;
  132. l^.next:=p;
  133. end;
  134. end;
  135. { Function to be called to remove a file from the list }
  136. procedure RemoveFromList(var l: PFileList; h: longint);
  137. var
  138. p : PFileList;
  139. inList: Boolean;
  140. begin
  141. if l=nil then exit;
  142. inList:=False;
  143. p:=l;
  144. while (p^.next<>nil) and (not inList) do
  145. if p^.next^.handle=h then inList:=True
  146. else p:=p^.next;
  147. if p^.next<>nil then begin
  148. dispose(p^.next);
  149. p^.next:=p^.next^.next;
  150. end;
  151. end;
  152. {*****************************************************************************
  153. Misc. System Dependent Functions
  154. *****************************************************************************}
  155. procedure haltproc(e:longint);cdecl;external name '_haltproc';
  156. procedure System_exit;
  157. begin
  158. { We must remove the CTRL-C FALG here because halt }
  159. { may call I/O routines, which in turn might call }
  160. { halt, so a recursive stack crash }
  161. if BreakOn then begin
  162. if (SetSignal(0,0) and SIGBREAKF_CTRL_C)<>0 then
  163. SetSignal(0,SIGBREAKF_CTRL_C);
  164. end;
  165. { Closing opened files }
  166. CloseList(MOS_fileList);
  167. { Changing back to original directory if changed }
  168. if MOS_origDir<>0 then begin
  169. CurrentDir(MOS_origDir);
  170. end;
  171. if MOS_UtilityBase<>nil then CloseLibrary(MOS_UtilityBase);
  172. if MOS_DOSBase<>nil then CloseLibrary(MOS_DOSBase);
  173. if MOS_heapPool<>nil then DeletePool(MOS_heapPool);
  174. haltproc(ExitCode);
  175. end;
  176. { Converts a MorphOS dos.library error code to a TP compatible error code }
  177. { Based on 1.0.x Amiga RTL }
  178. procedure dosError2InOut(errno: LongInt);
  179. begin
  180. case errno of
  181. ERROR_BAD_NUMBER,
  182. ERROR_ACTION_NOT_KNOWN,
  183. ERROR_NOT_IMPLEMENTED : InOutRes := 1;
  184. ERROR_OBJECT_NOT_FOUND : InOutRes := 2;
  185. ERROR_DIR_NOT_FOUND : InOutRes := 3;
  186. ERROR_DISK_WRITE_PROTECTED : InOutRes := 150;
  187. ERROR_OBJECT_WRONG_TYPE : InOutRes := 151;
  188. ERROR_OBJECT_EXISTS,
  189. ERROR_DELETE_PROTECTED,
  190. ERROR_WRITE_PROTECTED,
  191. ERROR_READ_PROTECTED,
  192. ERROR_OBJECT_IN_USE,
  193. ERROR_DIRECTORY_NOT_EMPTY : InOutRes := 5;
  194. ERROR_NO_MORE_ENTRIES : InOutRes := 18;
  195. ERROR_RENAME_ACROSS_DEVICES : InOutRes := 17;
  196. ERROR_DISK_FULL : InOutRes := 101;
  197. ERROR_INVALID_RESIDENT_LIBRARY : InoutRes := 153;
  198. ERROR_BAD_HUNK : InOutRes := 153;
  199. ERROR_NOT_A_DOS_DISK : InOutRes := 157;
  200. ERROR_NO_DISK,
  201. ERROR_DISK_NOT_VALIDATED,
  202. ERROR_DEVICE_NOT_MOUNTED : InOutRes := 152;
  203. ERROR_SEEK_ERROR : InOutRes := 156;
  204. ERROR_LOCK_COLLISION,
  205. ERROR_LOCK_TIMEOUT,
  206. ERROR_UNLOCK_ERROR,
  207. ERROR_INVALID_LOCK,
  208. ERROR_INVALID_COMPONENT_NAME,
  209. ERROR_BAD_STREAM_NAME,
  210. ERROR_FILE_NOT_OBJECT : InOutRes := 6;
  211. else
  212. InOutres := errno;
  213. end;
  214. end;
  215. { Used for CTRL_C checking in I/O calls }
  216. procedure checkCTRLC;
  217. begin
  218. if BreakOn then begin
  219. if (SetSignal(0,0) And SIGBREAKF_CTRL_C)<>0 then begin
  220. { Clear CTRL-C signal }
  221. SetSignal(0,SIGBREAKF_CTRL_C);
  222. Halt(CTRL_C);
  223. end;
  224. end;
  225. end;
  226. { Generates correct argument array on startup }
  227. procedure GenerateArgs;
  228. var
  229. argvlen : longint;
  230. procedure allocarg(idx,len:longint);
  231. var
  232. i,oldargvlen : longint;
  233. begin
  234. if idx>=argvlen then
  235. begin
  236. oldargvlen:=argvlen;
  237. argvlen:=(idx+8) and (not 7);
  238. sysreallocmem(argv,argvlen*sizeof(pointer));
  239. for i:=oldargvlen to argvlen-1 do
  240. argv[i]:=nil;
  241. end;
  242. { use realloc to reuse already existing memory }
  243. sysreallocmem(argv[idx],len+1);
  244. end;
  245. var
  246. count: word;
  247. start: word;
  248. localindex: word;
  249. p : pchar;
  250. temp : string;
  251. begin
  252. p:=GetArgStr;
  253. argvlen:=0;
  254. { Set argv[0] }
  255. temp:=paramstr(0);
  256. allocarg(0,length(temp));
  257. move(temp[1],argv[0]^,length(temp));
  258. argv[0][length(temp)]:=#0;
  259. { check if we're started from Ambient }
  260. if MOS_ambMsg<>nil then
  261. begin
  262. argc:=0;
  263. exit;
  264. end;
  265. { Handle the other args }
  266. count:=0;
  267. { first index is one }
  268. localindex:=1;
  269. while (p[count]<>#0) do
  270. begin
  271. while (p[count]=' ') or (p[count]=#9) or (p[count]=LineEnding) do inc(count);
  272. start:=count;
  273. while (p[count]<>#0) and (p[count]<>' ') and (p[count]<>#9) and (p[count]<>LineEnding) do inc(count);
  274. if (count-start>0) then
  275. begin
  276. allocarg(localindex,count-start);
  277. move(p[start],argv[localindex]^,count-start);
  278. argv[localindex][count-start]:=#0;
  279. inc(localindex);
  280. end;
  281. end;
  282. argc:=localindex;
  283. end;
  284. function GetProgDir: String;
  285. var
  286. s1 : String;
  287. alock : LongInt;
  288. counter: Byte;
  289. begin
  290. GetProgDir:='';
  291. FillChar(s1,255,#0);
  292. { GetLock of program directory }
  293. alock:=GetProgramDir;
  294. if alock<>0 then begin
  295. if NameFromLock(alock,@s1[1],255) then begin
  296. counter:=1;
  297. while (s1[counter]<>#0) and (counter<>0) do Inc(counter);
  298. s1[0]:=Char(counter-1);
  299. GetProgDir:=s1;
  300. end;
  301. end;
  302. end;
  303. function GetProgramName: String;
  304. { Returns ONLY the program name }
  305. var
  306. s1 : String;
  307. counter: Byte;
  308. begin
  309. GetProgramName:='';
  310. FillChar(s1,255,#0);
  311. if GetProgramName(@s1[1],255) then begin
  312. { now check out and assign the length of the string }
  313. counter := 1;
  314. while (s1[counter]<>#0) and (counter<>0) do Inc(counter);
  315. s1[0]:=Char(counter-1);
  316. { now remove any component path which should not be there }
  317. for counter:=length(s1) downto 1 do
  318. if (s1[counter] = '/') or (s1[counter] = ':') then break;
  319. { readjust counterv to point to character }
  320. if counter<>1 then Inc(counter);
  321. GetProgramName:=copy(s1,counter,length(s1));
  322. end;
  323. end;
  324. { Converts an Unix-like path to Amiga-like path }
  325. function PathConv(path: string): string;
  326. var tmppos: longint;
  327. begin
  328. { check for short paths }
  329. if length(path)<=2 then begin
  330. if (path='.') or (path='./') then path:='';
  331. if path='..' then path:='/';
  332. end else begin
  333. { convert parent directories }
  334. tmppos:=pos('../',path);
  335. while tmppos<>0 do begin
  336. { delete .. to have / as parent dir sign }
  337. delete(path,tmppos,2);
  338. tmppos:=pos('../',path);
  339. end;
  340. { convert current directories }
  341. tmppos:=pos('./',path);
  342. while tmppos<>0 do begin
  343. { delete ./ since we doesn't need to sign current directory }
  344. delete(path,tmppos,2);
  345. tmppos:=pos('./',path);
  346. end;
  347. end;
  348. PathConv:=path;
  349. end;
  350. {*****************************************************************************
  351. ParamStr/Randomize
  352. *****************************************************************************}
  353. { number of args }
  354. function paramcount : longint;
  355. begin
  356. if MOS_ambMsg<>nil then
  357. paramcount:=0
  358. else
  359. paramcount:=argc-1;
  360. end;
  361. { argument number l }
  362. function paramstr(l : longint) : string;
  363. var
  364. s1: String;
  365. begin
  366. paramstr:='';
  367. if MOS_ambMsg<>nil then exit;
  368. if l=0 then begin
  369. s1:=GetProgDir;
  370. if s1[length(s1)]=':' then paramstr:=s1+GetProgramName
  371. else paramstr:=s1+'/'+GetProgramName;
  372. end else begin
  373. if (l>0) and (l+1<=argc) then paramstr:=strpas(argv[l]);
  374. end;
  375. end;
  376. { set randseed to a new pseudo random value }
  377. procedure randomize;
  378. var tmpTime: TDateStamp;
  379. begin
  380. DateStamp(@tmpTime);
  381. randseed:=tmpTime.ds_tick;
  382. end;
  383. {*****************************************************************************
  384. OS Memory allocation / deallocation
  385. ****************************************************************************}
  386. function SysOSAlloc(size: ptrint): pointer;
  387. begin
  388. result := AllocPooled(MOS_heapPool,size);
  389. end;
  390. {$define HAS_SYSOSFREE}
  391. procedure SysOSFree(p: pointer; size: ptrint);
  392. begin
  393. FreePooled(MOS_heapPool,p,size);
  394. end;
  395. {$I heap.inc}
  396. {*****************************************************************************
  397. Directory Handling
  398. *****************************************************************************}
  399. procedure mkdir(const s : string);[IOCheck];
  400. var
  401. tmpStr : array[0..255] of char;
  402. tmpLock: LongInt;
  403. begin
  404. checkCTRLC;
  405. if (s='') or (InOutRes<>0) then exit;
  406. tmpStr:=PathConv(s)+#0;
  407. tmpLock:=CreateDir(@tmpStr);
  408. if tmpLock=0 then begin
  409. dosError2InOut(IoErr);
  410. exit;
  411. end;
  412. UnLock(tmpLock);
  413. end;
  414. procedure rmdir(const s : string);[IOCheck];
  415. var
  416. tmpStr : array[0..255] of Char;
  417. begin
  418. checkCTRLC;
  419. if (s='.') then InOutRes:=16;
  420. If (s='') or (InOutRes<>0) then exit;
  421. tmpStr:=PathConv(s)+#0;
  422. if not DeleteFile(@tmpStr) then
  423. dosError2InOut(IoErr);
  424. end;
  425. procedure chdir(const s : string);[IOCheck];
  426. var
  427. tmpStr : array[0..255] of Char;
  428. tmpLock: LongInt;
  429. FIB : PFileInfoBlock;
  430. begin
  431. checkCTRLC;
  432. If (s='') or (InOutRes<>0) then exit;
  433. tmpStr:=PathConv(s)+#0;
  434. tmpLock:=0;
  435. { Changing the directory is a pretty complicated affair }
  436. { 1) Obtain a lock on the directory }
  437. { 2) CurrentDir the lock }
  438. tmpLock:=Lock(@tmpStr,SHARED_LOCK);
  439. if tmpLock=0 then begin
  440. dosError2InOut(IoErr);
  441. exit;
  442. end;
  443. FIB:=nil;
  444. new(FIB);
  445. if (Examine(tmpLock,FIB)=True) and (FIB^.fib_DirEntryType>0) then begin
  446. tmpLock := CurrentDir(tmpLock);
  447. if MOS_OrigDir=0 then begin
  448. MOS_OrigDir:=tmpLock;
  449. tmpLock:=0;
  450. end;
  451. end;
  452. if tmpLock<>0 then Unlock(tmpLock);
  453. if assigned(FIB) then dispose(FIB);
  454. end;
  455. procedure GetDir (DriveNr: byte; var Dir: ShortString);
  456. var tmpbuf: array[0..255] of char;
  457. begin
  458. checkCTRLC;
  459. Dir:='';
  460. if not GetCurrentDirName(tmpbuf,256) then
  461. dosError2InOut(IoErr)
  462. else
  463. Dir:=strpas(tmpbuf);
  464. end;
  465. {****************************************************************************
  466. Low level File Routines
  467. All these functions can set InOutRes on errors
  468. ****************************************************************************}
  469. { close a file from the handle value }
  470. procedure do_close(handle : longint);
  471. begin
  472. RemoveFromList(MOS_fileList,handle);
  473. { Do _NOT_ check CTRL_C on Close, because it will conflict
  474. with System_Exit! }
  475. if not dosClose(handle) then
  476. dosError2InOut(IoErr);
  477. end;
  478. procedure do_erase(p : pchar);
  479. begin
  480. checkCTRLC;
  481. if not DeleteFile(p) then
  482. dosError2InOut(IoErr);
  483. end;
  484. procedure do_rename(p1,p2 : pchar);
  485. begin
  486. checkCTRLC;
  487. if not dosRename(p1,p2) then
  488. dosError2InOut(IoErr);
  489. end;
  490. function do_write(h:longint; addr: pointer; len: longint) : longint;
  491. var dosResult: LongInt;
  492. begin
  493. checkCTRLC;
  494. do_write:=0;
  495. if len<=0 then exit;
  496. dosResult:=dosWrite(h,addr,len);
  497. if dosResult<0 then begin
  498. dosError2InOut(IoErr);
  499. end else begin
  500. do_write:=dosResult;
  501. end;
  502. end;
  503. function do_read(h:longint; addr: pointer; len: longint) : longint;
  504. var dosResult: LongInt;
  505. begin
  506. checkCTRLC;
  507. do_read:=0;
  508. if len<=0 then exit;
  509. dosResult:=dosRead(h,addr,len);
  510. if dosResult<0 then begin
  511. dosError2InOut(IoErr);
  512. end else begin
  513. do_read:=dosResult;
  514. end
  515. end;
  516. function do_filepos(handle : longint) : longint;
  517. var dosResult: LongInt;
  518. begin
  519. checkCTRLC;
  520. do_filepos:=0;
  521. { Seeking zero from OFFSET_CURRENT to find out where we are }
  522. dosResult:=dosSeek(handle,0,OFFSET_CURRENT);
  523. if dosResult<0 then begin
  524. dosError2InOut(IoErr);
  525. end else begin
  526. do_filepos:=dosResult;
  527. end;
  528. end;
  529. procedure do_seek(handle,pos : longint);
  530. begin
  531. checkCTRLC;
  532. { Seeking from OFFSET_BEGINNING }
  533. if dosSeek(handle,pos,OFFSET_BEGINNING)<0 then
  534. dosError2InOut(IoErr);
  535. end;
  536. function do_seekend(handle:longint):longint;
  537. var dosResult: LongInt;
  538. begin
  539. checkCTRLC;
  540. do_seekend:=0;
  541. { Seeking to OFFSET_END }
  542. dosResult:=dosSeek(handle,0,OFFSET_END);
  543. if dosResult<0 then begin
  544. dosError2InOut(IoErr);
  545. end else begin
  546. do_seekend:=dosResult;
  547. end
  548. end;
  549. function do_filesize(handle : longint) : longint;
  550. var currfilepos: longint;
  551. begin
  552. checkCTRLC;
  553. currfilepos:=do_filepos(handle);
  554. { We have to do this twice, because seek returns the OLD position }
  555. do_filesize:=do_seekend(handle);
  556. do_filesize:=do_seekend(handle);
  557. do_seek(handle,currfilepos)
  558. end;
  559. { truncate at a given position }
  560. procedure do_truncate (handle,pos:longint);
  561. begin
  562. checkCTRLC;
  563. { Seeking from OFFSET_BEGINNING }
  564. if SetFileSize(handle,pos,OFFSET_BEGINNING)<0 then
  565. dosError2InOut(IoErr);
  566. end;
  567. procedure do_open(var f;p:pchar;flags:longint);
  568. {
  569. filerec and textrec have both handle and mode as the first items so
  570. they could use the same routine for opening/creating.
  571. when (flags and $10) the file will be append
  572. when (flags and $100) the file will be truncate/rewritten
  573. when (flags and $1000) there is no check for close (needed for textfiles)
  574. }
  575. var
  576. handle : LongInt;
  577. openflags: LongInt;
  578. tmpStr : array[0..255] of Char;
  579. begin
  580. tmpStr:=PathConv(strpas(p))+#0;
  581. { close first if opened }
  582. if ((flags and $10000)=0) then begin
  583. case filerec(f).mode of
  584. fminput,fmoutput,fminout : Do_Close(filerec(f).handle);
  585. fmclosed : ;
  586. else begin
  587. inoutres:=102; {not assigned}
  588. exit;
  589. end;
  590. end;
  591. end;
  592. { reset file handle }
  593. filerec(f).handle:=UnusedHandle;
  594. { convert filemode to filerec modes }
  595. { READ/WRITE on existing file }
  596. { RESET/APPEND }
  597. openflags := 1005;
  598. case (flags and 3) of
  599. 0 : filerec(f).mode:=fminput;
  600. 1 : filerec(f).mode:=fmoutput;
  601. 2 : filerec(f).mode:=fminout;
  602. end;
  603. { rewrite (create a new file) }
  604. if (flags and $1000)<>0 then openflags := 1006;
  605. { empty name is special }
  606. if p[0]=#0 then begin
  607. case filerec(f).mode of
  608. fminput :
  609. filerec(f).handle:=StdInputHandle;
  610. fmappend,
  611. fmoutput : begin
  612. filerec(f).handle:=StdOutputHandle;
  613. filerec(f).mode:=fmoutput; {fool fmappend}
  614. end;
  615. end;
  616. exit;
  617. end;
  618. handle:=Open(@tmpStr,openflags);
  619. if handle=0 then begin
  620. dosError2InOut(IoErr);
  621. end else begin
  622. AddToList(MOS_fileList,handle);
  623. filerec(f).handle:=handle;
  624. end;
  625. { append mode }
  626. if ((Flags and $100)<>0) and
  627. (FileRec(F).Handle<>UnusedHandle) then begin
  628. do_seekend(filerec(f).handle);
  629. filerec(f).mode:=fmoutput; {fool fmappend}
  630. end;
  631. end;
  632. function do_isdevice(handle:longint):boolean;
  633. begin
  634. if (handle=StdOutputHandle) or (handle=StdInputHandle) or
  635. (handle=StdErrorHandle) then
  636. do_isdevice:=True
  637. else
  638. do_isdevice:=False;
  639. end;
  640. {*****************************************************************************
  641. UnTyped File Handling
  642. *****************************************************************************}
  643. {$i file.inc}
  644. {*****************************************************************************
  645. Typed File Handling
  646. *****************************************************************************}
  647. {$i typefile.inc}
  648. {*****************************************************************************
  649. Text File Handling
  650. *****************************************************************************}
  651. {$I text.inc}
  652. { MorphOS specific startup }
  653. procedure SysInitMorphOS;
  654. var self: PProcess;
  655. begin
  656. self:=PProcess(FindTask(nil));
  657. if self^.pr_CLI=0 then begin
  658. { if we're running from Ambient/Workbench, we catch its message }
  659. WaitPort(@self^.pr_MsgPort);
  660. MOS_ambMsg:=GetMsg(@self^.pr_MsgPort);
  661. end;
  662. MOS_DOSBase:=OpenLibrary('dos.library',50);
  663. if MOS_DOSBase=nil then Halt(1);
  664. MOS_UtilityBase:=OpenLibrary('utility.library',50);
  665. if MOS_UtilityBase=nil then Halt(1);
  666. { Creating the memory pool for growing heap }
  667. MOS_heapPool:=CreatePool(MEMF_FAST,growheapsize2,growheapsize1);
  668. if MOS_heapPool=nil then Halt(1);
  669. if MOS_ambMsg=nil then begin
  670. StdInputHandle:=dosInput;
  671. StdOutputHandle:=dosOutput;
  672. end else begin
  673. MOS_ConHandle:=Open(MOS_ConName,1005);
  674. if MOS_ConHandle<>0 then begin
  675. StdInputHandle:=MOS_ConHandle;
  676. StdOutputHandle:=MOS_ConHandle;
  677. end else
  678. Halt(1);
  679. end;
  680. end;
  681. procedure SysInitStdIO;
  682. begin
  683. OpenStdIO(Input,fmInput,StdInputHandle);
  684. OpenStdIO(Output,fmOutput,StdOutputHandle);
  685. OpenStdIO(StdOut,fmOutput,StdOutputHandle);
  686. { * MorphOS doesn't have a separate stderr, just like AmigaOS (???) * }
  687. StdErrorHandle:=StdOutputHandle;
  688. // OpenStdIO(StdErr,fmOutput,StdErrorHandle);
  689. // OpenStdIO(ErrOutput,fmOutput,StdErrorHandle);
  690. end;
  691. function GetProcessID: SizeUInt;
  692. begin
  693. GetProcessID := 1;
  694. {$WARNING Implementation of GetProcessID missing!}
  695. end;
  696. begin
  697. IsConsole := TRUE;
  698. IsLibrary := FALSE;
  699. StackLength := InitialStkLen;
  700. StackBottom := Sptr - StackLength;
  701. { OS specific startup }
  702. MOS_ambMsg:=nil;
  703. MOS_origDir:=0;
  704. MOS_fileList:=nil;
  705. envp:=nil;
  706. SysInitMorphOS;
  707. { Set up signals handlers }
  708. // InstallSignals;
  709. { Setup heap }
  710. InitHeap;
  711. SysInitExceptions;
  712. { Setup stdin, stdout and stderr }
  713. SysInitStdIO;
  714. { Reset IO Error }
  715. InOutRes:=0;
  716. { Arguments }
  717. GenerateArgs;
  718. (* This should be changed to a real value during *)
  719. (* thread driver initialization if appropriate. *)
  720. ThreadID := 1;
  721. {$ifdef HASVARIANT}
  722. initvariantmanager;
  723. {$endif HASVARIANT}
  724. end.
  725. {
  726. $Log$
  727. Revision 1.23 2004-12-05 14:36:37 hajny
  728. + GetProcessID added
  729. Revision 1.22 2004/11/15 23:18:16 karoly
  730. * Reworked path handling to be less messy
  731. Revision 1.21 2004/11/04 09:32:31 peter
  732. ErrOutput added
  733. Revision 1.20 2004/10/25 15:38:59 peter
  734. * compiler defined HEAP and HEAPSIZE removed
  735. Revision 1.19 2004/09/03 19:26:15 olle
  736. + added maxExitCode to all System.pp
  737. * constrained error code to be below maxExitCode in RunError et. al.
  738. Revision 1.18 2004/08/09 00:12:40 karoly
  739. * changes to work with updated doslib includes
  740. Revision 1.17 2004/08/03 15:59:41 karoly
  741. * more cleanup & more includes
  742. Revision 1.16 2004/06/26 20:48:24 karoly
  743. * more cleanup + changes to use new includes
  744. Revision 1.15 2004/06/23 13:27:32 karoly
  745. * fixed system unit for the new heap manager
  746. Revision 1.14 2004/06/17 16:16:14 peter
  747. * New heapmanager that releases memory back to the OS, donated
  748. by Micha Nelissen
  749. Revision 1.13 2004/06/13 22:50:47 karoly
  750. * cleanup and changes to use new includes
  751. Revision 1.12 2004/06/06 23:31:13 karoly
  752. * fixed dos_UnLockDosList from being nonsense, and some cleanup
  753. Revision 1.11 2004/06/06 19:18:05 karoly
  754. + added support for paramstr(0)
  755. Revision 1.10 2004/06/05 19:49:19 karoly
  756. + added console I/O support when running from Ambient
  757. Revision 1.9 2004/05/12 23:18:54 karoly
  758. * fixed do_read and dos_Read from being nonsense
  759. Revision 1.8 2004/05/12 20:26:04 karoly
  760. + added syscalls and structures necessary for DOS unit
  761. Revision 1.7 2004/05/12 15:34:16 karoly
  762. * fixed startup code from endless wait when not started from Ambient
  763. Revision 1.6 2004/05/09 14:42:59 karoly
  764. * again, few more new things added
  765. Revision 1.5 2004/05/09 02:02:42 karoly
  766. * more things got implemented
  767. Revision 1.4 2004/05/02 02:06:57 karoly
  768. + most of file I/O calls implemented
  769. Revision 1.3 2004/05/01 15:09:47 karoly
  770. * first working system unit (very limited yet)
  771. Revision 1.2  2004/04/08 06:28:29  karoly
  772. * first steps to have a morphos system unit
  773. Revision 1.1 2004/02/13 07:19:53 karoly
  774. * quick hack from Linux system unit
  775. }