system.pp 24 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953
  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 FLAG 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; alias: 'PATHCONV'; [public];
  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:='' else
  331. if path='..' then path:='/' else
  332. if path='*' then path:='#?';
  333. end else begin
  334. { convert parent directories }
  335. tmppos:=pos('../',path);
  336. while tmppos<>0 do begin
  337. { delete .. to have / as parent dir sign }
  338. delete(path,tmppos,2);
  339. tmppos:=pos('../',path);
  340. end;
  341. { convert current directories }
  342. tmppos:=pos('./',path);
  343. while tmppos<>0 do begin
  344. { delete ./ since we doesn't need to sign current directory }
  345. delete(path,tmppos,2);
  346. tmppos:=pos('./',path);
  347. end;
  348. { convert wildstart to #? }
  349. tmppos:=pos('*',path);
  350. while tmppos<>0 do begin
  351. delete(path,tmppos,1);
  352. insert('#?',path,tmppos);
  353. tmppos:=pos('*',path);
  354. end;
  355. end;
  356. PathConv:=path;
  357. end;
  358. {*****************************************************************************
  359. ParamStr/Randomize
  360. *****************************************************************************}
  361. { number of args }
  362. function paramcount : longint;
  363. begin
  364. if MOS_ambMsg<>nil then
  365. paramcount:=0
  366. else
  367. paramcount:=argc-1;
  368. end;
  369. { argument number l }
  370. function paramstr(l : longint) : string;
  371. var
  372. s1: String;
  373. begin
  374. paramstr:='';
  375. if MOS_ambMsg<>nil then exit;
  376. if l=0 then begin
  377. s1:=GetProgDir;
  378. if s1[length(s1)]=':' then paramstr:=s1+GetProgramName
  379. else paramstr:=s1+'/'+GetProgramName;
  380. end else begin
  381. if (l>0) and (l+1<=argc) then paramstr:=strpas(argv[l]);
  382. end;
  383. end;
  384. { set randseed to a new pseudo random value }
  385. procedure randomize;
  386. var tmpTime: TDateStamp;
  387. begin
  388. DateStamp(@tmpTime);
  389. randseed:=tmpTime.ds_tick;
  390. end;
  391. {*****************************************************************************
  392. OS Memory allocation / deallocation
  393. ****************************************************************************}
  394. function SysOSAlloc(size: ptrint): pointer;
  395. begin
  396. result := AllocPooled(MOS_heapPool,size);
  397. end;
  398. {$define HAS_SYSOSFREE}
  399. procedure SysOSFree(p: pointer; size: ptrint);
  400. begin
  401. FreePooled(MOS_heapPool,p,size);
  402. end;
  403. {$I heap.inc}
  404. {*****************************************************************************
  405. Directory Handling
  406. *****************************************************************************}
  407. procedure mkdir(const s : string);[IOCheck];
  408. var
  409. tmpStr : array[0..255] of char;
  410. tmpLock: LongInt;
  411. begin
  412. checkCTRLC;
  413. if (s='') or (InOutRes<>0) then exit;
  414. tmpStr:=PathConv(s)+#0;
  415. tmpLock:=CreateDir(@tmpStr);
  416. if tmpLock=0 then begin
  417. dosError2InOut(IoErr);
  418. exit;
  419. end;
  420. UnLock(tmpLock);
  421. end;
  422. procedure rmdir(const s : string);[IOCheck];
  423. var
  424. tmpStr : array[0..255] of Char;
  425. begin
  426. checkCTRLC;
  427. if (s='.') then InOutRes:=16;
  428. If (s='') or (InOutRes<>0) then exit;
  429. tmpStr:=PathConv(s)+#0;
  430. if not DeleteFile(@tmpStr) then
  431. dosError2InOut(IoErr);
  432. end;
  433. procedure chdir(const s : string);[IOCheck];
  434. var
  435. tmpStr : array[0..255] of Char;
  436. tmpLock: LongInt;
  437. FIB : PFileInfoBlock;
  438. begin
  439. checkCTRLC;
  440. If (s='') or (InOutRes<>0) then exit;
  441. tmpStr:=PathConv(s)+#0;
  442. tmpLock:=0;
  443. { Changing the directory is a pretty complicated affair }
  444. { 1) Obtain a lock on the directory }
  445. { 2) CurrentDir the lock }
  446. tmpLock:=Lock(@tmpStr,SHARED_LOCK);
  447. if tmpLock=0 then begin
  448. dosError2InOut(IoErr);
  449. exit;
  450. end;
  451. FIB:=nil;
  452. new(FIB);
  453. if (Examine(tmpLock,FIB)=True) and (FIB^.fib_DirEntryType>0) then begin
  454. tmpLock:=CurrentDir(tmpLock);
  455. if MOS_OrigDir=0 then begin
  456. MOS_OrigDir:=tmpLock;
  457. tmpLock:=0;
  458. end;
  459. end;
  460. if tmpLock<>0 then Unlock(tmpLock);
  461. if assigned(FIB) then dispose(FIB);
  462. end;
  463. procedure GetDir (DriveNr: byte; var Dir: ShortString);
  464. var tmpbuf: array[0..255] of char;
  465. begin
  466. checkCTRLC;
  467. Dir:='';
  468. if not GetCurrentDirName(tmpbuf,256) then
  469. dosError2InOut(IoErr)
  470. else
  471. Dir:=strpas(tmpbuf);
  472. end;
  473. {****************************************************************************
  474. Low level File Routines
  475. All these functions can set InOutRes on errors
  476. ****************************************************************************}
  477. { close a file from the handle value }
  478. procedure do_close(handle : longint);
  479. begin
  480. RemoveFromList(MOS_fileList,handle);
  481. { Do _NOT_ check CTRL_C on Close, because it will conflict
  482. with System_Exit! }
  483. if not dosClose(handle) then
  484. dosError2InOut(IoErr);
  485. end;
  486. procedure do_erase(p : pchar);
  487. begin
  488. checkCTRLC;
  489. if not DeleteFile(p) then
  490. dosError2InOut(IoErr);
  491. end;
  492. procedure do_rename(p1,p2 : pchar);
  493. begin
  494. checkCTRLC;
  495. if not dosRename(p1,p2) then
  496. dosError2InOut(IoErr);
  497. end;
  498. function do_write(h:longint; addr: pointer; len: longint) : longint;
  499. var dosResult: LongInt;
  500. begin
  501. checkCTRLC;
  502. do_write:=0;
  503. if len<=0 then exit;
  504. dosResult:=dosWrite(h,addr,len);
  505. if dosResult<0 then begin
  506. dosError2InOut(IoErr);
  507. end else begin
  508. do_write:=dosResult;
  509. end;
  510. end;
  511. function do_read(h:longint; addr: pointer; len: longint) : longint;
  512. var dosResult: LongInt;
  513. begin
  514. checkCTRLC;
  515. do_read:=0;
  516. if len<=0 then exit;
  517. dosResult:=dosRead(h,addr,len);
  518. if dosResult<0 then begin
  519. dosError2InOut(IoErr);
  520. end else begin
  521. do_read:=dosResult;
  522. end
  523. end;
  524. function do_filepos(handle : longint) : longint;
  525. var dosResult: LongInt;
  526. begin
  527. checkCTRLC;
  528. do_filepos:=0;
  529. { Seeking zero from OFFSET_CURRENT to find out where we are }
  530. dosResult:=dosSeek(handle,0,OFFSET_CURRENT);
  531. if dosResult<0 then begin
  532. dosError2InOut(IoErr);
  533. end else begin
  534. do_filepos:=dosResult;
  535. end;
  536. end;
  537. procedure do_seek(handle,pos : longint);
  538. begin
  539. checkCTRLC;
  540. { Seeking from OFFSET_BEGINNING }
  541. if dosSeek(handle,pos,OFFSET_BEGINNING)<0 then
  542. dosError2InOut(IoErr);
  543. end;
  544. function do_seekend(handle:longint):longint;
  545. var dosResult: LongInt;
  546. begin
  547. checkCTRLC;
  548. do_seekend:=0;
  549. { Seeking to OFFSET_END }
  550. dosResult:=dosSeek(handle,0,OFFSET_END);
  551. if dosResult<0 then begin
  552. dosError2InOut(IoErr);
  553. end else begin
  554. do_seekend:=dosResult;
  555. end
  556. end;
  557. function do_filesize(handle : longint) : longint;
  558. var currfilepos: longint;
  559. begin
  560. checkCTRLC;
  561. currfilepos:=do_filepos(handle);
  562. { We have to do this twice, because seek returns the OLD position }
  563. do_filesize:=do_seekend(handle);
  564. do_filesize:=do_seekend(handle);
  565. do_seek(handle,currfilepos)
  566. end;
  567. { truncate at a given position }
  568. procedure do_truncate (handle,pos:longint);
  569. begin
  570. checkCTRLC;
  571. { Seeking from OFFSET_BEGINNING }
  572. if SetFileSize(handle,pos,OFFSET_BEGINNING)<0 then
  573. dosError2InOut(IoErr);
  574. end;
  575. procedure do_open(var f;p:pchar;flags:longint);
  576. {
  577. filerec and textrec have both handle and mode as the first items so
  578. they could use the same routine for opening/creating.
  579. when (flags and $10) the file will be append
  580. when (flags and $100) the file will be truncate/rewritten
  581. when (flags and $1000) there is no check for close (needed for textfiles)
  582. }
  583. var
  584. handle : LongInt;
  585. openflags: LongInt;
  586. tmpStr : array[0..255] of Char;
  587. begin
  588. tmpStr:=PathConv(strpas(p))+#0;
  589. { close first if opened }
  590. if ((flags and $10000)=0) then begin
  591. case filerec(f).mode of
  592. fminput,fmoutput,fminout : Do_Close(filerec(f).handle);
  593. fmclosed : ;
  594. else begin
  595. inoutres:=102; {not assigned}
  596. exit;
  597. end;
  598. end;
  599. end;
  600. { reset file handle }
  601. filerec(f).handle:=UnusedHandle;
  602. { convert filemode to filerec modes }
  603. { READ/WRITE on existing file }
  604. { RESET/APPEND }
  605. openflags := 1005;
  606. case (flags and 3) of
  607. 0 : filerec(f).mode:=fminput;
  608. 1 : filerec(f).mode:=fmoutput;
  609. 2 : filerec(f).mode:=fminout;
  610. end;
  611. { rewrite (create a new file) }
  612. if (flags and $1000)<>0 then openflags := 1006;
  613. { empty name is special }
  614. if p[0]=#0 then begin
  615. case filerec(f).mode of
  616. fminput :
  617. filerec(f).handle:=StdInputHandle;
  618. fmappend,
  619. fmoutput : begin
  620. filerec(f).handle:=StdOutputHandle;
  621. filerec(f).mode:=fmoutput; {fool fmappend}
  622. end;
  623. end;
  624. exit;
  625. end;
  626. handle:=Open(@tmpStr,openflags);
  627. if handle=0 then begin
  628. dosError2InOut(IoErr);
  629. end else begin
  630. AddToList(MOS_fileList,handle);
  631. filerec(f).handle:=handle;
  632. end;
  633. { append mode }
  634. if ((Flags and $100)<>0) and
  635. (FileRec(F).Handle<>UnusedHandle) then begin
  636. do_seekend(filerec(f).handle);
  637. filerec(f).mode:=fmoutput; {fool fmappend}
  638. end;
  639. end;
  640. function do_isdevice(handle:longint):boolean;
  641. begin
  642. if (handle=StdOutputHandle) or (handle=StdInputHandle) or
  643. (handle=StdErrorHandle) then
  644. do_isdevice:=True
  645. else
  646. do_isdevice:=False;
  647. end;
  648. {*****************************************************************************
  649. UnTyped File Handling
  650. *****************************************************************************}
  651. {$i file.inc}
  652. {*****************************************************************************
  653. Typed File Handling
  654. *****************************************************************************}
  655. {$i typefile.inc}
  656. {*****************************************************************************
  657. Text File Handling
  658. *****************************************************************************}
  659. {$I text.inc}
  660. { MorphOS specific startup }
  661. procedure SysInitMorphOS;
  662. var self: PProcess;
  663. begin
  664. self:=PProcess(FindTask(nil));
  665. if self^.pr_CLI=0 then begin
  666. { if we're running from Ambient/Workbench, we catch its message }
  667. WaitPort(@self^.pr_MsgPort);
  668. MOS_ambMsg:=GetMsg(@self^.pr_MsgPort);
  669. end;
  670. MOS_DOSBase:=OpenLibrary('dos.library',50);
  671. if MOS_DOSBase=nil then Halt(1);
  672. MOS_UtilityBase:=OpenLibrary('utility.library',50);
  673. if MOS_UtilityBase=nil then Halt(1);
  674. { Creating the memory pool for growing heap }
  675. MOS_heapPool:=CreatePool(MEMF_FAST,growheapsize2,growheapsize1);
  676. if MOS_heapPool=nil then Halt(1);
  677. if MOS_ambMsg=nil then begin
  678. StdInputHandle:=dosInput;
  679. StdOutputHandle:=dosOutput;
  680. end else begin
  681. MOS_ConHandle:=Open(MOS_ConName,1005);
  682. if MOS_ConHandle<>0 then begin
  683. StdInputHandle:=MOS_ConHandle;
  684. StdOutputHandle:=MOS_ConHandle;
  685. end else
  686. Halt(1);
  687. end;
  688. end;
  689. procedure SysInitStdIO;
  690. begin
  691. OpenStdIO(Input,fmInput,StdInputHandle);
  692. OpenStdIO(Output,fmOutput,StdOutputHandle);
  693. OpenStdIO(StdOut,fmOutput,StdOutputHandle);
  694. { * MorphOS doesn't have a separate stderr, just like AmigaOS (???) * }
  695. StdErrorHandle:=StdOutputHandle;
  696. // OpenStdIO(StdErr,fmOutput,StdErrorHandle);
  697. // OpenStdIO(ErrOutput,fmOutput,StdErrorHandle);
  698. end;
  699. function GetProcessID: SizeUInt;
  700. begin
  701. GetProcessID:=SizeUInt(FindTask(NIL));
  702. end;
  703. begin
  704. IsConsole := TRUE;
  705. IsLibrary := FALSE;
  706. StackLength := InitialStkLen;
  707. StackBottom := Sptr - StackLength;
  708. { OS specific startup }
  709. MOS_ambMsg:=nil;
  710. MOS_origDir:=0;
  711. MOS_fileList:=nil;
  712. envp:=nil;
  713. SysInitMorphOS;
  714. { Set up signals handlers }
  715. // InstallSignals;
  716. { Setup heap }
  717. InitHeap;
  718. SysInitExceptions;
  719. { Setup stdin, stdout and stderr }
  720. SysInitStdIO;
  721. { Reset IO Error }
  722. InOutRes:=0;
  723. { Arguments }
  724. GenerateArgs;
  725. (* This should be changed to a real value during *)
  726. (* thread driver initialization if appropriate. *)
  727. ThreadID := 1;
  728. {$ifdef HASVARIANT}
  729. initvariantmanager;
  730. {$endif HASVARIANT}
  731. end.
  732. {
  733. $Log$
  734. Revision 1.27 2004-12-14 21:01:16 karoly
  735. * GetProcessID implemented
  736. Revision 1.26 2004/12/07 10:07:50 karoly
  737. * removed debug code accidentally left in
  738. Revision 1.25 2004/12/07 09:55:46 karoly
  739. * previous change broke PathConv, fixed
  740. Revision 1.24 2004/12/06 20:09:55 karoly
  741. * added a public alias to PathConv for use in DOS unit
  742. Revision 1.23 2004/12/05 14:36:37 hajny
  743. + GetProcessID added
  744. Revision 1.22 2004/11/15 23:18:16 karoly
  745. * Reworked path handling to be less messy
  746. Revision 1.21 2004/11/04 09:32:31 peter
  747. ErrOutput added
  748. Revision 1.20 2004/10/25 15:38:59 peter
  749. * compiler defined HEAP and HEAPSIZE removed
  750. Revision 1.19 2004/09/03 19:26:15 olle
  751. + added maxExitCode to all System.pp
  752. * constrained error code to be below maxExitCode in RunError et. al.
  753. Revision 1.18 2004/08/09 00:12:40 karoly
  754. * changes to work with updated doslib includes
  755. Revision 1.17 2004/08/03 15:59:41 karoly
  756. * more cleanup & more includes
  757. Revision 1.16 2004/06/26 20:48:24 karoly
  758. * more cleanup + changes to use new includes
  759. Revision 1.15 2004/06/23 13:27:32 karoly
  760. * fixed system unit for the new heap manager
  761. Revision 1.14 2004/06/17 16:16:14 peter
  762. * New heapmanager that releases memory back to the OS, donated
  763. by Micha Nelissen
  764. Revision 1.13 2004/06/13 22:50:47 karoly
  765. * cleanup and changes to use new includes
  766. Revision 1.12 2004/06/06 23:31:13 karoly
  767. * fixed dos_UnLockDosList from being nonsense, and some cleanup
  768. Revision 1.11 2004/06/06 19:18:05 karoly
  769. + added support for paramstr(0)
  770. Revision 1.10 2004/06/05 19:49:19 karoly
  771. + added console I/O support when running from Ambient
  772. Revision 1.9 2004/05/12 23:18:54 karoly
  773. * fixed do_read and dos_Read from being nonsense
  774. Revision 1.8 2004/05/12 20:26:04 karoly
  775. + added syscalls and structures necessary for DOS unit
  776. Revision 1.7 2004/05/12 15:34:16 karoly
  777. * fixed startup code from endless wait when not started from Ambient
  778. Revision 1.6 2004/05/09 14:42:59 karoly
  779. * again, few more new things added
  780. Revision 1.5 2004/05/09 02:02:42 karoly
  781. * more things got implemented
  782. Revision 1.4 2004/05/02 02:06:57 karoly
  783. + most of file I/O calls implemented
  784. Revision 1.3 2004/05/01 15:09:47 karoly
  785. * first working system unit (very limited yet)
  786. Revision 1.2  2004/04/08 06:28:29  karoly
  787. * first steps to have a morphos system unit
  788. Revision 1.1 2004/02/13 07:19:53 karoly
  789. * quick hack from Linux system unit
  790. }