system.pp 24 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959
  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. if MOS_UtilityBase<>nil then CloseLibrary(MOS_UtilityBase);
  168. if MOS_DOSBase<>nil then CloseLibrary(MOS_DOSBase);
  169. if MOS_heapPool<>nil then DeletePool(MOS_heapPool);
  170. haltproc(ExitCode);
  171. end;
  172. { Converts a MorphOS dos.library error code to a TP compatible error code }
  173. { Based on 1.0.x Amiga RTL }
  174. procedure dosError2InOut(errno: LongInt);
  175. begin
  176. case errno of
  177. ERROR_BAD_NUMBER,
  178. ERROR_ACTION_NOT_KNOWN,
  179. ERROR_NOT_IMPLEMENTED : InOutRes := 1;
  180. ERROR_OBJECT_NOT_FOUND : InOutRes := 2;
  181. ERROR_DIR_NOT_FOUND : InOutRes := 3;
  182. ERROR_DISK_WRITE_PROTECTED : InOutRes := 150;
  183. ERROR_OBJECT_WRONG_TYPE : InOutRes := 151;
  184. ERROR_OBJECT_EXISTS,
  185. ERROR_DELETE_PROTECTED,
  186. ERROR_WRITE_PROTECTED,
  187. ERROR_READ_PROTECTED,
  188. ERROR_OBJECT_IN_USE,
  189. ERROR_DIRECTORY_NOT_EMPTY : InOutRes := 5;
  190. ERROR_NO_MORE_ENTRIES : InOutRes := 18;
  191. ERROR_RENAME_ACROSS_DEVICES : InOutRes := 17;
  192. ERROR_DISK_FULL : InOutRes := 101;
  193. ERROR_INVALID_RESIDENT_LIBRARY : InoutRes := 153;
  194. ERROR_BAD_HUNK : InOutRes := 153;
  195. ERROR_NOT_A_DOS_DISK : InOutRes := 157;
  196. ERROR_NO_DISK,
  197. ERROR_DISK_NOT_VALIDATED,
  198. ERROR_DEVICE_NOT_MOUNTED : InOutRes := 152;
  199. ERROR_SEEK_ERROR : InOutRes := 156;
  200. ERROR_LOCK_COLLISION,
  201. ERROR_LOCK_TIMEOUT,
  202. ERROR_UNLOCK_ERROR,
  203. ERROR_INVALID_LOCK,
  204. ERROR_INVALID_COMPONENT_NAME,
  205. ERROR_BAD_STREAM_NAME,
  206. ERROR_FILE_NOT_OBJECT : InOutRes := 6;
  207. else
  208. InOutres := errno;
  209. end;
  210. end;
  211. { Used for CTRL_C checking in I/O calls }
  212. procedure checkCTRLC;
  213. begin
  214. if BreakOn then begin
  215. if (SetSignal(0,0) And SIGBREAKF_CTRL_C)<>0 then begin
  216. { Clear CTRL-C signal }
  217. SetSignal(0,SIGBREAKF_CTRL_C);
  218. Halt(CTRL_C);
  219. end;
  220. end;
  221. end;
  222. { Generates correct argument array on startup }
  223. procedure GenerateArgs;
  224. var
  225. argvlen : longint;
  226. procedure allocarg(idx,len:longint);
  227. var
  228. i,oldargvlen : longint;
  229. begin
  230. if idx>=argvlen then
  231. begin
  232. oldargvlen:=argvlen;
  233. argvlen:=(idx+8) and (not 7);
  234. sysreallocmem(argv,argvlen*sizeof(pointer));
  235. for i:=oldargvlen to argvlen-1 do
  236. argv[i]:=nil;
  237. end;
  238. { use realloc to reuse already existing memory }
  239. sysreallocmem(argv[idx],len+1);
  240. end;
  241. var
  242. count: word;
  243. start: word;
  244. localindex: word;
  245. p : pchar;
  246. temp : string;
  247. begin
  248. p:=GetArgStr;
  249. argvlen:=0;
  250. { Set argv[0] }
  251. temp:=paramstr(0);
  252. allocarg(0,length(temp));
  253. move(temp[1],argv[0]^,length(temp));
  254. argv[0][length(temp)]:=#0;
  255. { check if we're started from Ambient }
  256. if MOS_ambMsg<>nil then
  257. begin
  258. argc:=0;
  259. exit;
  260. end;
  261. { Handle the other args }
  262. count:=0;
  263. { first index is one }
  264. localindex:=1;
  265. while (p[count]<>#0) do
  266. begin
  267. while (p[count]=' ') or (p[count]=#9) or (p[count]=LineEnding) do inc(count);
  268. start:=count;
  269. while (p[count]<>#0) and (p[count]<>' ') and (p[count]<>#9) and (p[count]<>LineEnding) do inc(count);
  270. if (count-start>0) then
  271. begin
  272. allocarg(localindex,count-start);
  273. move(p[start],argv[localindex]^,count-start);
  274. argv[localindex][count-start]:=#0;
  275. inc(localindex);
  276. end;
  277. end;
  278. argc:=localindex;
  279. end;
  280. function GetProgDir: String;
  281. var
  282. s1 : String;
  283. alock : LongInt;
  284. counter: Byte;
  285. begin
  286. GetProgDir:='';
  287. FillChar(s1,255,#0);
  288. { GetLock of program directory }
  289. alock:=GetProgramDir;
  290. if alock<>0 then begin
  291. if NameFromLock(alock,@s1[1],255) then begin
  292. counter:=1;
  293. while (s1[counter]<>#0) and (counter<>0) do Inc(counter);
  294. s1[0]:=Char(counter-1);
  295. GetProgDir:=s1;
  296. end;
  297. end;
  298. end;
  299. function GetProgramName: String;
  300. { Returns ONLY the program name }
  301. var
  302. s1 : String;
  303. counter: Byte;
  304. begin
  305. GetProgramName:='';
  306. FillChar(s1,255,#0);
  307. if GetProgramName(@s1[1],255) then begin
  308. { now check out and assign the length of the string }
  309. counter := 1;
  310. while (s1[counter]<>#0) and (counter<>0) do Inc(counter);
  311. s1[0]:=Char(counter-1);
  312. { now remove any component path which should not be there }
  313. for counter:=length(s1) downto 1 do
  314. if (s1[counter] = '/') or (s1[counter] = ':') then break;
  315. { readjust counterv to point to character }
  316. if counter<>1 then Inc(counter);
  317. GetProgramName:=copy(s1,counter,length(s1));
  318. end;
  319. end;
  320. {*****************************************************************************
  321. ParamStr/Randomize
  322. *****************************************************************************}
  323. { number of args }
  324. function paramcount : longint;
  325. begin
  326. if MOS_ambMsg<>nil then
  327. paramcount:=0
  328. else
  329. paramcount:=argc-1;
  330. end;
  331. { argument number l }
  332. function paramstr(l : longint) : string;
  333. var
  334. s1: String;
  335. begin
  336. paramstr:='';
  337. if MOS_ambMsg<>nil then exit;
  338. if l=0 then begin
  339. s1:=GetProgDir;
  340. if s1[length(s1)]=':' then paramstr:=s1+GetProgramName
  341. else paramstr:=s1+'/'+GetProgramName;
  342. end else begin
  343. if (l>0) and (l+1<=argc) then paramstr:=strpas(argv[l]);
  344. end;
  345. end;
  346. { set randseed to a new pseudo random value }
  347. procedure randomize;
  348. var tmpTime: TDateStamp;
  349. begin
  350. DateStamp(@tmpTime);
  351. randseed:=tmpTime.ds_tick;
  352. end;
  353. {*****************************************************************************
  354. OS Memory allocation / deallocation
  355. ****************************************************************************}
  356. function SysOSAlloc(size: ptrint): pointer;
  357. begin
  358. result := AllocPooled(MOS_heapPool,size);
  359. end;
  360. {$define HAS_SYSOSFREE}
  361. procedure SysOSFree(p: pointer; size: ptrint);
  362. begin
  363. FreePooled(MOS_heapPool,p,size);
  364. end;
  365. {$I heap.inc}
  366. {*****************************************************************************
  367. Directory Handling
  368. *****************************************************************************}
  369. procedure mkdir(const s : string);[IOCheck];
  370. var
  371. buffer : array[0..255] of char;
  372. j : Integer;
  373. tmpStr : string;
  374. tmpLock : LongInt;
  375. begin
  376. checkCTRLC;
  377. if (s='') or (InOutRes<>0) then exit;
  378. tmpStr:=s;
  379. for j:=1 to length(tmpStr) do
  380. if tmpStr[j]='\' then tmpStr[j]:='/';
  381. move(tmpStr[1],buffer,length(tmpStr));
  382. buffer[length(tmpStr)]:=#0;
  383. tmpLock:=CreateDir(buffer);
  384. if tmpLock=0 then begin
  385. dosError2InOut(IoErr);
  386. exit;
  387. end;
  388. UnLock(tmpLock);
  389. end;
  390. procedure rmdir(const s : string);[IOCheck];
  391. var
  392. buffer : array[0..255] of char;
  393. j : Integer;
  394. tmpStr : string;
  395. begin
  396. checkCTRLC;
  397. if (s='.') then InOutRes:=16;
  398. If (s='') or (InOutRes<>0) then exit;
  399. tmpStr:=s;
  400. for j:=1 to length(tmpStr) do
  401. if tmpStr[j] = '\' then tmpStr[j] := '/';
  402. move(tmpStr[1],buffer,length(tmpStr));
  403. buffer[length(tmpStr)]:=#0;
  404. if not DeleteFile(buffer) then
  405. dosError2InOut(IoErr);
  406. end;
  407. procedure chdir(const s : string);[IOCheck];
  408. var
  409. buffer : array[0..255] of char;
  410. alock : LongInt;
  411. FIB : PFileInfoBlock;
  412. j : Integer;
  413. tmpStr : string;
  414. begin
  415. checkCTRLC;
  416. If (s='') or (InOutRes<>0) then exit;
  417. tmpStr:=s;
  418. for j:=1 to length(tmpStr) do
  419. if tmpStr[j]='\' then tmpStr[j]:='/';
  420. { Return parent directory }
  421. if s='..' then begin
  422. getdir(0,tmpStr);
  423. j:=length(tmpStr);
  424. { Look through the previous paths }
  425. while (tmpStr[j]<>'/') and (tmpStr[j]<>':') and (j>0) do
  426. dec(j);
  427. if j>0 then
  428. tmpStr:=copy(tmpStr,1,j);
  429. end;
  430. alock:=0;
  431. move(tmpStr[1],buffer,length(tmpStr));
  432. buffer[length(tmpStr)]:=#0;
  433. { Changing the directory is a pretty complicated affair }
  434. { 1) Obtain a lock on the directory }
  435. { 2) CurrentDir the lock }
  436. alock:=Lock(buffer,SHARED_LOCK);
  437. if alock=0 then begin
  438. dosError2InOut(IoErr);
  439. exit;
  440. end;
  441. FIB:=nil;
  442. new(FIB);
  443. if (Examine(alock,FIB)=True) and (FIB^.fib_DirEntryType>0) then begin
  444. alock := CurrentDir(alock);
  445. if MOS_OrigDir=0 then begin
  446. MOS_OrigDir:=alock;
  447. alock:=0;
  448. end;
  449. end;
  450. if alock<>0 then Unlock(alock);
  451. if assigned(FIB) then dispose(FIB)
  452. end;
  453. procedure GetDir (DriveNr: byte; var Dir: ShortString);
  454. var tmpbuf: array[0..255] of char;
  455. begin
  456. checkCTRLC;
  457. Dir:='';
  458. if not GetCurrentDirName(tmpbuf,256) then
  459. dosError2InOut(IoErr)
  460. else
  461. Dir:=strpas(tmpbuf);
  462. end;
  463. {****************************************************************************
  464. Low level File Routines
  465. All these functions can set InOutRes on errors
  466. ****************************************************************************}
  467. { close a file from the handle value }
  468. procedure do_close(handle : longint);
  469. begin
  470. RemoveFromList(MOS_fileList,handle);
  471. { Do _NOT_ check CTRL_C on Close, because it will conflict
  472. with System_Exit! }
  473. if not dosClose(handle) then
  474. dosError2InOut(IoErr);
  475. end;
  476. procedure do_erase(p : pchar);
  477. begin
  478. checkCTRLC;
  479. if not DeleteFile(p) then
  480. dosError2InOut(IoErr);
  481. end;
  482. procedure do_rename(p1,p2 : pchar);
  483. begin
  484. checkCTRLC;
  485. if not dosRename(p1,p2) then
  486. dosError2InOut(IoErr);
  487. end;
  488. function do_write(h:longint; addr: pointer; len: longint) : longint;
  489. var dosResult: LongInt;
  490. begin
  491. checkCTRLC;
  492. do_write:=0;
  493. if len<=0 then exit;
  494. dosResult:=dosWrite(h,addr,len);
  495. if dosResult<0 then begin
  496. dosError2InOut(IoErr);
  497. end else begin
  498. do_write:=dosResult;
  499. end;
  500. end;
  501. function do_read(h:longint; addr: pointer; len: longint) : longint;
  502. var dosResult: LongInt;
  503. begin
  504. checkCTRLC;
  505. do_read:=0;
  506. if len<=0 then exit;
  507. dosResult:=dosRead(h,addr,len);
  508. if dosResult<0 then begin
  509. dosError2InOut(IoErr);
  510. end else begin
  511. do_read:=dosResult;
  512. end
  513. end;
  514. function do_filepos(handle : longint) : longint;
  515. var dosResult: LongInt;
  516. begin
  517. checkCTRLC;
  518. do_filepos:=0;
  519. { Seeking zero from OFFSET_CURRENT to find out where we are }
  520. dosResult:=dosSeek(handle,0,OFFSET_CURRENT);
  521. if dosResult<0 then begin
  522. dosError2InOut(IoErr);
  523. end else begin
  524. do_filepos:=dosResult;
  525. end;
  526. end;
  527. procedure do_seek(handle,pos : longint);
  528. begin
  529. checkCTRLC;
  530. { Seeking from OFFSET_BEGINNING }
  531. if dosSeek(handle,pos,OFFSET_BEGINNING)<0 then
  532. dosError2InOut(IoErr);
  533. end;
  534. function do_seekend(handle:longint):longint;
  535. var dosResult: LongInt;
  536. begin
  537. checkCTRLC;
  538. do_seekend:=0;
  539. { Seeking to OFFSET_END }
  540. dosResult:=dosSeek(handle,0,OFFSET_END);
  541. if dosResult<0 then begin
  542. dosError2InOut(IoErr);
  543. end else begin
  544. do_seekend:=dosResult;
  545. end
  546. end;
  547. function do_filesize(handle : longint) : longint;
  548. var currfilepos: longint;
  549. begin
  550. checkCTRLC;
  551. currfilepos:=do_filepos(handle);
  552. { We have to do this twice, because seek returns the OLD position }
  553. do_filesize:=do_seekend(handle);
  554. do_filesize:=do_seekend(handle);
  555. do_seek(handle,currfilepos)
  556. end;
  557. { truncate at a given position }
  558. procedure do_truncate (handle,pos:longint);
  559. begin
  560. checkCTRLC;
  561. { Seeking from OFFSET_BEGINNING }
  562. if SetFileSize(handle,pos,OFFSET_BEGINNING)<0 then
  563. dosError2InOut(IoErr);
  564. end;
  565. procedure do_open(var f;p:pchar;flags:longint);
  566. {
  567. filerec and textrec have both handle and mode as the first items so
  568. they could use the same routine for opening/creating.
  569. when (flags and $10) the file will be append
  570. when (flags and $100) the file will be truncate/rewritten
  571. when (flags and $1000) there is no check for close (needed for textfiles)
  572. }
  573. var
  574. i,j : LongInt;
  575. openflags : LongInt;
  576. path : String;
  577. buffer : array[0..255] of Char;
  578. index : Integer;
  579. s : String;
  580. begin
  581. path:=strpas(p);
  582. for index:=1 to length(path) do
  583. if path[index]='\' then path[index]:='/';
  584. { remove any dot characters and replace by their current }
  585. { directory equivalent. }
  586. { look for parent directory }
  587. if pos('../',path) = 1 then
  588. begin
  589. delete(path,1,3);
  590. getdir(0,s);
  591. j:=length(s);
  592. while (s[j]<>'/') and (s[j]<>':') and (j>0) do
  593. dec(j);
  594. if j > 0 then
  595. s:=copy(s,1,j);
  596. path:=s+path;
  597. end
  598. else
  599. { look for current directory }
  600. if pos('./',path) = 1 then
  601. begin
  602. delete(path,1,2);
  603. getdir(0,s);
  604. if (s[length(s)]<>'/') and (s[length(s)]<>':') then
  605. s:=s+'/';
  606. path:=s+path;
  607. end;
  608. move(path[1],buffer,length(path));
  609. buffer[length(path)]:=#0;
  610. { close first if opened }
  611. if ((flags and $10000)=0) then
  612. begin
  613. case filerec(f).mode of
  614. fminput,fmoutput,fminout : Do_Close(filerec(f).handle);
  615. fmclosed : ;
  616. else begin
  617. inoutres:=102; {not assigned}
  618. exit;
  619. end;
  620. end;
  621. end;
  622. { reset file handle }
  623. filerec(f).handle:=UnusedHandle;
  624. { convert filemode to filerec modes }
  625. { READ/WRITE on existing file }
  626. { RESET/APPEND }
  627. openflags := 1005;
  628. case (flags and 3) of
  629. 0 : filerec(f).mode:=fminput;
  630. 1 : filerec(f).mode:=fmoutput;
  631. 2 : filerec(f).mode:=fminout;
  632. end;
  633. { rewrite (create a new file) }
  634. if (flags and $1000)<>0 then openflags := 1006;
  635. { empty name is special }
  636. if p[0]=#0 then
  637. begin
  638. case filerec(f).mode of
  639. fminput :
  640. filerec(f).handle:=StdInputHandle;
  641. fmappend,
  642. fmoutput : begin
  643. filerec(f).handle:=StdOutputHandle;
  644. filerec(f).mode:=fmoutput; {fool fmappend}
  645. end;
  646. end;
  647. exit;
  648. end;
  649. i:=Open(buffer,openflags);
  650. if i=0 then
  651. begin
  652. dosError2InOut(IoErr);
  653. end else begin
  654. AddToList(MOS_fileList,i);
  655. filerec(f).handle:=i;
  656. end;
  657. { append mode }
  658. if ((Flags and $100)<>0) and (FileRec(F).Handle<>UnusedHandle) then
  659. begin
  660. do_seekend(filerec(f).handle);
  661. filerec(f).mode:=fmoutput; {fool fmappend}
  662. end;
  663. end;
  664. function do_isdevice(handle:longint):boolean;
  665. begin
  666. if (handle=StdOutputHandle) or (handle=StdInputHandle) or
  667. (handle=StdErrorHandle) then
  668. do_isdevice:=True
  669. else
  670. do_isdevice:=False;
  671. end;
  672. {*****************************************************************************
  673. UnTyped File Handling
  674. *****************************************************************************}
  675. {$i file.inc}
  676. {*****************************************************************************
  677. Typed File Handling
  678. *****************************************************************************}
  679. {$i typefile.inc}
  680. {*****************************************************************************
  681. Text File Handling
  682. *****************************************************************************}
  683. {$I text.inc}
  684. { MorphOS specific startup }
  685. procedure SysInitMorphOS;
  686. var self: PProcess;
  687. begin
  688. self:=PProcess(FindTask(nil));
  689. if self^.pr_CLI=0 then begin
  690. { if we're running from Ambient/Workbench, we catch its message }
  691. WaitPort(@self^.pr_MsgPort);
  692. MOS_ambMsg:=GetMsg(@self^.pr_MsgPort);
  693. end;
  694. MOS_DOSBase:=OpenLibrary('dos.library',50);
  695. if MOS_DOSBase=nil then Halt(1);
  696. MOS_UtilityBase:=OpenLibrary('utility.library',50);
  697. if MOS_UtilityBase=nil then Halt(1);
  698. { Creating the memory pool for growing heap }
  699. MOS_heapPool:=CreatePool(MEMF_FAST,growheapsize2,growheapsize1);
  700. if MOS_heapPool=nil then Halt(1);
  701. if MOS_ambMsg=nil then begin
  702. StdInputHandle:=dosInput;
  703. StdOutputHandle:=dosOutput;
  704. end else begin
  705. MOS_ConHandle:=Open(MOS_ConName,1005);
  706. if MOS_ConHandle<>0 then begin
  707. StdInputHandle:=MOS_ConHandle;
  708. StdOutputHandle:=MOS_ConHandle;
  709. end else
  710. Halt(1);
  711. end;
  712. end;
  713. procedure SysInitStdIO;
  714. begin
  715. OpenStdIO(Input,fmInput,StdInputHandle);
  716. OpenStdIO(Output,fmOutput,StdOutputHandle);
  717. OpenStdIO(StdOut,fmOutput,StdOutputHandle);
  718. { * MorphOS doesn't have a separate stderr, just like AmigaOS (???) * }
  719. StdErrorHandle:=StdOutputHandle;
  720. // OpenStdIO(StdErr,fmOutput,StdErrorHandle);
  721. // OpenStdIO(ErrOutput,fmOutput,StdErrorHandle);
  722. end;
  723. begin
  724. IsConsole := TRUE;
  725. IsLibrary := FALSE;
  726. StackLength := InitialStkLen;
  727. StackBottom := Sptr - StackLength;
  728. { OS specific startup }
  729. MOS_ambMsg:=nil;
  730. MOS_origDir:=0;
  731. MOS_fileList:=nil;
  732. envp:=nil;
  733. SysInitMorphOS;
  734. { Set up signals handlers }
  735. // InstallSignals;
  736. { Setup heap }
  737. InitHeap;
  738. SysInitExceptions;
  739. { Setup stdin, stdout and stderr }
  740. SysInitStdIO;
  741. { Reset IO Error }
  742. InOutRes:=0;
  743. { Arguments }
  744. GenerateArgs;
  745. (* This should be changed to a real value during *)
  746. (* thread driver initialization if appropriate. *)
  747. ThreadID := 1;
  748. {$ifdef HASVARIANT}
  749. initvariantmanager;
  750. {$endif HASVARIANT}
  751. end.
  752. {
  753. $Log$
  754. Revision 1.21 2004-11-04 09:32:31 peter
  755. ErrOutput added
  756. Revision 1.20 2004/10/25 15:38:59 peter
  757. * compiler defined HEAP and HEAPSIZE removed
  758. Revision 1.19 2004/09/03 19:26:15 olle
  759. + added maxExitCode to all System.pp
  760. * constrained error code to be below maxExitCode in RunError et. al.
  761. Revision 1.18 2004/08/09 00:12:40 karoly
  762. * changes to work with updated doslib includes
  763. Revision 1.17 2004/08/03 15:59:41 karoly
  764. * more cleanup & more includes
  765. Revision 1.16 2004/06/26 20:48:24 karoly
  766. * more cleanup + changes to use new includes
  767. Revision 1.15 2004/06/23 13:27:32 karoly
  768. * fixed system unit for the new heap manager
  769. Revision 1.14 2004/06/17 16:16:14 peter
  770. * New heapmanager that releases memory back to the OS, donated
  771. by Micha Nelissen
  772. Revision 1.13 2004/06/13 22:50:47 karoly
  773. * cleanup and changes to use new includes
  774. Revision 1.12 2004/06/06 23:31:13 karoly
  775. * fixed dos_UnLockDosList from being nonsense, and some cleanup
  776. Revision 1.11 2004/06/06 19:18:05 karoly
  777. + added support for paramstr(0)
  778. Revision 1.10 2004/06/05 19:49:19 karoly
  779. + added console I/O support when running from Ambient
  780. Revision 1.9 2004/05/12 23:18:54 karoly
  781. * fixed do_read and dos_Read from being nonsense
  782. Revision 1.8 2004/05/12 20:26:04 karoly
  783. + added syscalls and structures necessary for DOS unit
  784. Revision 1.7 2004/05/12 15:34:16 karoly
  785. * fixed startup code from endless wait when not started from Ambient
  786. Revision 1.6 2004/05/09 14:42:59 karoly
  787. * again, few more new things added
  788. Revision 1.5 2004/05/09 02:02:42 karoly
  789. * more things got implemented
  790. Revision 1.4 2004/05/02 02:06:57 karoly
  791. + most of file I/O calls implemented
  792. Revision 1.3 2004/05/01 15:09:47 karoly
  793. * first working system unit (very limited yet)
  794. Revision 1.2  2004/04/08 06:28:29  karoly
  795. * first steps to have a morphos system unit
  796. Revision 1.1 2004/02/13 07:19:53 karoly
  797. * quick hack from Linux system unit
  798. }