system.pas 28 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075
  1. {
  2. $Id$
  3. ****************************************************************************
  4. This file is part of the Free Pascal run time library.
  5. Copyright (c) 1999-2002 by Free Pascal development team
  6. Free Pascal - OS/2 (EMX) runtime library
  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 {$ifdef VER1_0}sysos2{$else}System{$endif};
  14. {Changelog:
  15. People:
  16. DM - Daniel Mantione
  17. Date: Description of change: Changed by:
  18. - First released version 0.1. DM
  19. Coding style:
  20. My coding style is a bit unusual for Pascal. Nevertheless I friendly ask
  21. you to try to make your changes not look all to different. In general,
  22. set your IDE to use a tabsize of 4.}
  23. interface
  24. {Link the startup code.}
  25. {$l prt1.oo2}
  26. {$I SYSTEMH.INC}
  27. type
  28. { FK: The fields of this record are OS dependent and they shouldn't }
  29. { be used in a program; only the type TCriticalSection is important. }
  30. (* TH: To make things easier, I copied the record definition *)
  31. (* from the Win32 version and just added longint variants, *)
  32. (* because it seemed well suited for OS/2 too. *)
  33. TRTLCriticalSection = packed record
  34. DebugInfo: pointer;
  35. LockCount: longint;
  36. RecursionCount: longint;
  37. case boolean of
  38. false:
  39. (OwningThread: DWord;
  40. LockSemaphore: DWord;
  41. Reserved: DWord);
  42. true:
  43. (OwningThread2: longint;
  44. LockSemaphore2: longint;
  45. Reserved2: longint);
  46. end;
  47. {$I heaph.inc}
  48. {Platform specific information}
  49. const
  50. LineEnding = #13#10;
  51. { LFNSupport is defined separately below!!! }
  52. DirectorySeparator = '\';
  53. DriveSeparator = ':';
  54. PathSeparator = ';';
  55. { FileNameCaseSensitive is defined separately below!!! }
  56. type Tos=(osDOS,osOS2,osDPMI);
  57. var os_mode:Tos;
  58. first_meg:pointer;
  59. type Psysthreadib=^Tsysthreadib;
  60. Pthreadinfoblock=^Tthreadinfoblock;
  61. PPThreadInfoBlock=^PThreadInfoBlock;
  62. Pprocessinfoblock=^Tprocessinfoblock;
  63. PPProcessInfoBlock=^PProcessInfoBlock;
  64. Tbytearray=array[0..$ffff] of byte;
  65. Pbytearray=^Tbytearray;
  66. Tsysthreadib=record
  67. tid,
  68. priority,
  69. version:longint;
  70. MCcount,
  71. MCforceflag:word;
  72. end;
  73. Tthreadinfoblock=record
  74. pexchain,
  75. stack,
  76. stacklimit:pointer;
  77. tib2:Psysthreadib;
  78. version,
  79. ordinal:longint;
  80. end;
  81. Tprocessinfoblock=record
  82. pid,
  83. parentpid,
  84. hmte:longint;
  85. cmd,
  86. env:Pbytearray;
  87. flstatus,
  88. ttype:longint;
  89. end;
  90. const UnusedHandle=$ffff;
  91. StdInputHandle=0;
  92. StdOutputHandle=1;
  93. StdErrorHandle=2;
  94. LFNSupport: boolean = true;
  95. FileNameCaseSensitive: boolean = false;
  96. sLineBreak = LineEnding;
  97. DefaultTextLineBreakStyle : TTextLineBreakStyle = tlbsCRLF;
  98. var
  99. { C-compatible arguments and environment }
  100. argc : longint;external name '_argc';
  101. argv : ppchar;external name '_argv';
  102. envp : ppchar;external name '_environ';
  103. implementation
  104. {$I SYSTEM.INC}
  105. var
  106. heap_base: pointer; external name '__heap_base';
  107. heap_brk: pointer; external name '__heap_brk';
  108. heap_end: pointer; external name '__heap_end';
  109. {$IFDEF CONTHEAP}
  110. BrkLimit: cardinal;
  111. {$ENDIF CONTHEAP}
  112. procedure DosGetInfoBlocks (PATIB: PPThreadInfoBlock;
  113. PAPIB: PPProcessInfoBlock); cdecl;
  114. external 'DOSCALLS' index 312;
  115. function DosSetRelMaxFH (var ReqCount, CurMaxFH: longint): longint; cdecl;
  116. external 'DOSCALLS' index 382;
  117. function DosSetCurrentDir (Name:PChar): longint; cdecl;
  118. external 'DOSCALLS' index 255;
  119. function DosSetDefaultDisk (DiskNum:longint): longint; cdecl;
  120. external 'DOSCALLS' index 220;
  121. { This is not real prototype, but its close enough }
  122. { for us. (The 2nd parameter is acutally a pointer) }
  123. { to a structure. }
  124. function DosCreateDir( Name : pchar; p : pointer): longint; cdecl;
  125. external 'DOSCALLS' index 270;
  126. function DosDeleteDir( Name : pchar) : longint; cdecl;
  127. external 'DOSCALLS' index 226;
  128. {This is the correct way to call external assembler procedures.}
  129. procedure syscall; external name '___SYSCALL';
  130. {
  131. procedure syscall; external 'EMX' index 2;
  132. procedure emx_init; external 'EMX' index 1;
  133. }
  134. { converts an OS/2 error code to a TP compatible error }
  135. { code. Same thing exists under most other supported }
  136. { systems. }
  137. { Only call for OS/2 DLL imported routines }
  138. Procedure Errno2InOutRes;
  139. Begin
  140. { errors 1..18 are the same as in DOS }
  141. case InOutRes of
  142. { simple offset to convert these error codes }
  143. { exactly like the error codes in Win32 }
  144. 19..31 : InOutRes := InOutRes + 131;
  145. { gets a bit more complicated ... }
  146. 32..33 : InOutRes := 5;
  147. 38 : InOutRes := 100;
  148. 39 : InOutRes := 101;
  149. 112 : InOutRes := 101;
  150. 110 : InOutRes := 5;
  151. 114 : InOutRes := 6;
  152. 290 : InOutRes := 290;
  153. end;
  154. { all other cases ... we keep the same error code }
  155. end;
  156. {****************************************************************************
  157. Miscellaneous related routines.
  158. ****************************************************************************}
  159. {$asmmode intel}
  160. procedure system_exit; assembler;
  161. asm
  162. mov ah, 04ch
  163. mov al, byte ptr exitcode
  164. call syscall
  165. end ['EAX'];
  166. {$ASMMODE ATT}
  167. function paramcount:longint;assembler;
  168. asm
  169. movl argc,%eax
  170. decl %eax
  171. end ['EAX'];
  172. function args:pointer;assembler;
  173. asm
  174. movl argv,%eax
  175. end ['EAX'];
  176. function paramstr(l:longint):string;
  177. var p:^Pchar;
  178. begin
  179. { There seems to be a problem with EMX for DOS when trying to }
  180. { access paramstr(0), and to avoid problems between DOS and }
  181. { OS/2 they have been separated. }
  182. if os_Mode = OsOs2 then
  183. begin
  184. if L = 0 then
  185. begin
  186. GetMem (P, 260);
  187. p[0] := #0; { in case of error, initialize to empty string }
  188. {$ASMMODE INTEL}
  189. asm
  190. mov edx, P
  191. mov ecx, 260
  192. mov eax, 7F33h
  193. call syscall { error handle already with empty string }
  194. end;
  195. ParamStr := StrPas (PChar (P));
  196. FreeMem (P, 260);
  197. end
  198. else
  199. if (l>0) and (l<=paramcount) then
  200. begin
  201. p:=args;
  202. paramstr:=strpas(p[l]);
  203. end
  204. else paramstr:='';
  205. end
  206. else
  207. begin
  208. p:=args;
  209. paramstr:=strpas(p[l]);
  210. end;
  211. end;
  212. procedure randomize; assembler;
  213. asm
  214. mov ah, 2Ch
  215. call syscall
  216. mov word ptr [randseed], cx
  217. mov word ptr [randseed + 2], dx
  218. end;
  219. {$ASMMODE ATT}
  220. {****************************************************************************
  221. Heap management releated routines.
  222. ****************************************************************************}
  223. { this function allows to extend the heap by calling
  224. syscall $7f00 resizes the brk area}
  225. function sbrk(size:longint):longint;
  226. {$IFDEF DUMPGROW}
  227. var
  228. L: longint;
  229. begin
  230. WriteLn ('Trying to grow heap by ', Size, ' to ', HeapSize + Size);
  231. {$IFDEF CONTHEAP}
  232. WriteLn ('BrkLimit is ', BrkLimit);
  233. {$ENDIF CONTHEAP}
  234. asm
  235. movl size,%edx
  236. movw $0x7f00,%ax
  237. call syscall { result directly in EAX }
  238. mov %eax,L
  239. end;
  240. WriteLn ('New heap at ', L);
  241. Sbrk := L;
  242. end;
  243. {$ELSE DUMPGROW}
  244. assembler;
  245. asm
  246. movl size,%edx
  247. movw $0x7f00,%ax
  248. call syscall { result directly in EAX }
  249. end;
  250. {$ENDIF DUMPGROW}
  251. function getheapstart:pointer;assembler;
  252. asm
  253. movl heap_base,%eax
  254. end ['EAX'];
  255. function getheapsize:longint;assembler;
  256. asm
  257. movl heap_brk,%eax
  258. end ['EAX'];
  259. {$i heap.inc}
  260. {****************************************************************************
  261. Low Level File Routines
  262. ****************************************************************************}
  263. procedure allowslash(p:Pchar);
  264. {Allow slash as backslash.}
  265. var i:longint;
  266. begin
  267. for i:=0 to strlen(p) do
  268. if p[i]='/' then p[i]:='\';
  269. end;
  270. procedure do_close(h:longint);
  271. begin
  272. { Only three standard handles under real OS/2 }
  273. if (h > 4) or
  274. ((os_MODE = osOS2) and (h > 2)) then
  275. begin
  276. asm
  277. movb $0x3e,%ah
  278. movl h,%ebx
  279. call syscall
  280. jnc .Lnoerror { error code? }
  281. movw %ax, InOutRes { yes, then set InOutRes }
  282. .Lnoerror:
  283. end;
  284. end;
  285. end;
  286. procedure do_erase(p:Pchar);
  287. begin
  288. allowslash(p);
  289. asm
  290. movl P,%edx
  291. movb $0x41,%ah
  292. call syscall
  293. jnc .LERASE1
  294. movw %ax,inoutres;
  295. .LERASE1:
  296. end;
  297. end;
  298. procedure do_rename(p1,p2:Pchar);
  299. begin
  300. allowslash(p1);
  301. allowslash(p2);
  302. asm
  303. movl P1, %edx
  304. movl P2, %edi
  305. movb $0x56,%ah
  306. call syscall
  307. jnc .LRENAME1
  308. movw %ax,inoutres;
  309. .LRENAME1:
  310. end;
  311. end;
  312. function do_read(h,addr,len:longint):longint; assembler;
  313. asm
  314. movl len,%ecx
  315. movl addr,%edx
  316. movl h,%ebx
  317. movb $0x3f,%ah
  318. call syscall
  319. jnc .LDOSREAD1
  320. movw %ax,inoutres;
  321. xorl %eax,%eax
  322. .LDOSREAD1:
  323. end;
  324. function do_write(h,addr,len:longint) : longint; assembler;
  325. asm
  326. xorl %eax,%eax
  327. cmpl $0,len { 0 bytes to write is undefined behavior }
  328. jz .LDOSWRITE1
  329. movl len,%ecx
  330. movl addr,%edx
  331. movl h,%ebx
  332. movb $0x40,%ah
  333. call syscall
  334. jnc .LDOSWRITE1
  335. movw %ax,inoutres;
  336. .LDOSWRITE1:
  337. end;
  338. function do_filepos(handle:longint): longint; assembler;
  339. asm
  340. movw $0x4201,%ax
  341. movl handle,%ebx
  342. xorl %edx,%edx
  343. call syscall
  344. jnc .LDOSFILEPOS
  345. movw %ax,inoutres;
  346. xorl %eax,%eax
  347. .LDOSFILEPOS:
  348. end;
  349. procedure do_seek(handle,pos:longint); assembler;
  350. asm
  351. movw $0x4200,%ax
  352. movl handle,%ebx
  353. movl pos,%edx
  354. call syscall
  355. jnc .LDOSSEEK1
  356. movw %ax,inoutres;
  357. .LDOSSEEK1:
  358. end;
  359. function do_seekend(handle:longint):longint; assembler;
  360. asm
  361. movw $0x4202,%ax
  362. movl handle,%ebx
  363. xorl %edx,%edx
  364. call syscall
  365. jnc .Lset_at_end1
  366. movw %ax,inoutres;
  367. xorl %eax,%eax
  368. .Lset_at_end1:
  369. end;
  370. function do_filesize(handle:longint):longint;
  371. var aktfilepos:longint;
  372. begin
  373. aktfilepos:=do_filepos(handle);
  374. do_filesize:=do_seekend(handle);
  375. do_seek(handle,aktfilepos);
  376. end;
  377. procedure do_truncate(handle,pos:longint); assembler;
  378. asm
  379. (* DOS function 40h isn't safe for this according to EMX documentation *)
  380. movl $0x7F25,%eax
  381. movl Handle,%ebx
  382. movl Pos,%edx
  383. call syscall
  384. incl %eax
  385. movl %ecx, %eax
  386. jnz .LTruncate1 { compare the value of EAX to verify error }
  387. (* File position is undefined after truncation, move to the end. *)
  388. movl $0x4202,%eax
  389. movl Handle,%ebx
  390. movl $0,%edx
  391. call syscall
  392. jnc .LTruncate2
  393. .LTruncate1:
  394. movw %ax,inoutres;
  395. .LTruncate2:
  396. end;
  397. const
  398. FileHandleCount: longint = 20;
  399. function Increase_File_Handle_Count: boolean;
  400. var Err: word;
  401. L1, L2: longint;
  402. begin
  403. if os_mode = osOS2 then
  404. begin
  405. L1 := 10;
  406. if DosSetRelMaxFH (L1, L2) <> 0 then
  407. Increase_File_Handle_Count := false
  408. else
  409. if L2 > FileHandleCount then
  410. begin
  411. FileHandleCount := L2;
  412. Increase_File_Handle_Count := true;
  413. end
  414. else
  415. Increase_File_Handle_Count := false;
  416. end
  417. else
  418. begin
  419. Inc (FileHandleCount, 10);
  420. Err := 0;
  421. asm
  422. movl $0x6700, %eax
  423. movl FileHandleCount, %ebx
  424. call syscall
  425. jnc .LIncFHandles
  426. movw %ax, Err
  427. .LIncFHandles:
  428. end;
  429. if Err <> 0 then
  430. begin
  431. Increase_File_Handle_Count := false;
  432. Dec (FileHandleCount, 10);
  433. end
  434. else
  435. Increase_File_Handle_Count := true;
  436. end;
  437. end;
  438. procedure do_open(var f;p:pchar;flags:longint);
  439. {
  440. filerec and textrec have both handle and mode as the first items so
  441. they could use the same routine for opening/creating.
  442. when (flags and $100) the file will be append
  443. when (flags and $1000) the file will be truncate/rewritten
  444. when (flags and $10000) there is no check for close (needed for textfiles)
  445. }
  446. var Action: longint;
  447. begin
  448. allowslash(p);
  449. { close first if opened }
  450. if ((flags and $10000)=0) then
  451. begin
  452. case filerec(f).mode of
  453. fminput,fmoutput,fminout : Do_Close(filerec(f).handle);
  454. fmclosed:;
  455. else
  456. begin
  457. inoutres:=102; {not assigned}
  458. exit;
  459. end;
  460. end;
  461. end;
  462. { reset file handle }
  463. filerec(f).handle := UnusedHandle;
  464. Action := 0;
  465. { convert filemode to filerec modes }
  466. case (flags and 3) of
  467. 0 : filerec(f).mode:=fminput;
  468. 1 : filerec(f).mode:=fmoutput;
  469. 2 : filerec(f).mode:=fminout;
  470. end;
  471. if (flags and $1000)<>0 then
  472. Action := $50000; (* Create / replace *)
  473. { empty name is special }
  474. if p[0]=#0 then
  475. begin
  476. case FileRec(f).mode of
  477. fminput :
  478. FileRec(f).Handle:=StdInputHandle;
  479. fminout, { this is set by rewrite }
  480. fmoutput :
  481. FileRec(f).Handle:=StdOutputHandle;
  482. fmappend :
  483. begin
  484. FileRec(f).Handle:=StdOutputHandle;
  485. FileRec(f).mode:=fmoutput; {fool fmappend}
  486. end;
  487. end;
  488. exit;
  489. end;
  490. Action := Action or (Flags and $FF);
  491. (* DenyAll if sharing not specified. *)
  492. if Flags and 112 = 0 then
  493. Action := Action or 16;
  494. asm
  495. movl $0x7f2b, %eax
  496. movl Action, %ecx
  497. movl p, %edx
  498. call syscall
  499. cmpl $0xffffffff, %eax
  500. jnz .LOPEN1
  501. movw %cx, InOutRes
  502. movw UnusedHandle, %ax
  503. .LOPEN1:
  504. movl f,%edx { Warning : This assumes Handle is first }
  505. movw %ax,(%edx) { field of FileRec }
  506. end;
  507. if (InOutRes = 4) and Increase_File_Handle_Count then
  508. (* Trying again after increasing amount of file handles *)
  509. asm
  510. movl $0x7f2b, %eax
  511. movl Action, %ecx
  512. movl p, %edx
  513. call syscall
  514. cmpl $0xffffffff, %eax
  515. jnz .LOPEN2
  516. movw %cx, InOutRes
  517. movw UnusedHandle, %ax
  518. .LOPEN2:
  519. movl f,%edx
  520. movw %ax,(%edx)
  521. end;
  522. { for systems that have more handles }
  523. if FileRec (F).Handle > FileHandleCount then
  524. FileHandleCount := FileRec (F).Handle;
  525. if (flags and $100)<>0 then
  526. begin
  527. do_seekend(filerec(f).handle);
  528. FileRec (F).Mode := fmOutput; {fool fmappend}
  529. end;
  530. end;
  531. {$ASMMODE INTEL}
  532. function do_isdevice (Handle: longint): boolean; assembler;
  533. (*
  534. var HT, Attr: longint;
  535. begin
  536. if os_mode = osOS2 then
  537. begin
  538. if DosQueryHType (Handle, HT, Attr) <> 0 then HT := 1;
  539. end
  540. else
  541. *)
  542. asm
  543. mov ebx, Handle
  544. mov eax, 4400h
  545. call syscall
  546. mov eax, 1
  547. jc @IsDevEnd
  548. test edx, 80h { verify if it is a file }
  549. jnz @IsDevEnd
  550. dec eax { nope, so result is zero }
  551. @IsDevEnd:
  552. end;
  553. {$ASMMODE ATT}
  554. {*****************************************************************************
  555. UnTyped File Handling
  556. *****************************************************************************}
  557. {$i file.inc}
  558. {*****************************************************************************
  559. Typed File Handling
  560. *****************************************************************************}
  561. {$i typefile.inc}
  562. {*****************************************************************************
  563. Text File Handling
  564. *****************************************************************************}
  565. {$DEFINE EOF_CTRLZ}
  566. {$i text.inc}
  567. {****************************************************************************
  568. Directory related routines.
  569. ****************************************************************************}
  570. {*****************************************************************************
  571. Directory Handling
  572. *****************************************************************************}
  573. procedure dosdir(func:byte;const s:string);
  574. var buffer:array[0..255] of char;
  575. begin
  576. move(s[1],buffer,length(s));
  577. buffer[length(s)]:=#0;
  578. allowslash(Pchar(@buffer));
  579. asm
  580. leal buffer,%edx
  581. movb func,%ah
  582. call syscall
  583. jnc .LDOS_DIRS1
  584. movw %ax,inoutres
  585. .LDOS_DIRS1:
  586. end;
  587. end;
  588. procedure MkDir (const S: string);[IOCHECK];
  589. var buffer:array[0..255] of char;
  590. Rc : word;
  591. begin
  592. If (s='') or (InOutRes <> 0) then
  593. exit;
  594. if os_mode = osOs2 then
  595. begin
  596. move(s[1],buffer,length(s));
  597. buffer[length(s)]:=#0;
  598. allowslash(Pchar(@buffer));
  599. Rc := DosCreateDir(buffer,nil);
  600. if Rc <> 0 then
  601. begin
  602. InOutRes := Rc;
  603. Errno2Inoutres;
  604. end;
  605. end
  606. else
  607. begin
  608. { Under EMX 0.9d DOS this routine call may sometimes fail }
  609. { The syscall documentation indicates clearly that this }
  610. { routine was NOT tested. }
  611. DosDir ($39, S);
  612. end;
  613. end;
  614. procedure rmdir(const s : string);[IOCHECK];
  615. var buffer:array[0..255] of char;
  616. Rc : word;
  617. begin
  618. if (s = '.' ) then
  619. InOutRes := 16;
  620. If (s='') or (InOutRes <> 0) then
  621. exit;
  622. if os_mode = osOs2 then
  623. begin
  624. move(s[1],buffer,length(s));
  625. buffer[length(s)]:=#0;
  626. allowslash(Pchar(@buffer));
  627. Rc := DosDeleteDir(buffer);
  628. if Rc <> 0 then
  629. begin
  630. InOutRes := Rc;
  631. Errno2Inoutres;
  632. end;
  633. end
  634. else
  635. begin
  636. { Under EMX 0.9d DOS this routine call may sometimes fail }
  637. { The syscall documentation indicates clearly that this }
  638. { routine was NOT tested. }
  639. DosDir ($3A, S);
  640. end;
  641. end;
  642. {$ASMMODE INTEL}
  643. procedure ChDir (const S: string);[IOCheck];
  644. var RC: longint;
  645. Buffer: array [0..255] of char;
  646. begin
  647. If (s='') or (InOutRes <> 0) then
  648. exit;
  649. (* According to EMX documentation, EMX has only one current directory
  650. for all processes, so we'll use native calls under OS/2. *)
  651. if os_Mode = osOS2 then
  652. begin
  653. if (Length (S) >= 2) and (S [2] = ':') then
  654. begin
  655. RC := DosSetDefaultDisk ((Ord (S [1]) and
  656. not ($20)) - $40);
  657. if RC <> 0 then
  658. InOutRes := RC
  659. else
  660. if Length (S) > 2 then
  661. begin
  662. Move (S [1], Buffer, Length (S));
  663. Buffer [Length (S)] := #0;
  664. AllowSlash (PChar (@Buffer));
  665. RC := DosSetCurrentDir (@Buffer);
  666. if RC <> 0 then
  667. begin
  668. InOutRes := RC;
  669. Errno2InOutRes;
  670. end;
  671. end;
  672. end
  673. else
  674. begin
  675. Move (S [1], Buffer, Length (S));
  676. Buffer [Length (S)] := #0;
  677. AllowSlash (PChar (@Buffer));
  678. RC := DosSetCurrentDir (@Buffer);
  679. if RC <> 0 then
  680. begin
  681. InOutRes:= RC;
  682. Errno2InOutRes;
  683. end;
  684. end;
  685. end
  686. else
  687. if (Length (S) >= 2) and (S [2] = ':') then
  688. begin
  689. asm
  690. mov esi, S
  691. mov al, [esi + 1]
  692. and al, not (20h)
  693. sub al, 41h
  694. mov edx, eax
  695. mov ah, 0Eh
  696. call syscall
  697. mov ah, 19h
  698. call syscall
  699. cmp al, dl
  700. jz @LCHDIR
  701. mov InOutRes, 15
  702. @LCHDIR:
  703. end;
  704. if (Length (S) > 2) and (InOutRes <> 0) then
  705. { Under EMX 0.9d DOS this routine may sometime }
  706. { fail or crash the system. }
  707. DosDir ($3B, S);
  708. end
  709. else
  710. { Under EMX 0.9d DOS this routine may sometime }
  711. { fail or crash the system. }
  712. DosDir ($3B, S);
  713. end;
  714. {$ASMMODE ATT}
  715. procedure GetDir (DriveNr: byte; var Dir: ShortString);
  716. {Written by Michael Van Canneyt.}
  717. var sof:Pchar;
  718. i:byte;
  719. begin
  720. Dir [4] := #0;
  721. { Used in case the specified drive isn't available }
  722. sof:=pchar(@dir[4]);
  723. { dir[1..3] will contain '[drivenr]:\', but is not }
  724. { supplied by DOS, so we let dos string start at }
  725. { dir[4] }
  726. { Get dir from drivenr : 0=default, 1=A etc... }
  727. asm
  728. movb drivenr,%dl
  729. movl sof,%esi
  730. mov $0x47,%ah
  731. call syscall
  732. jnc .LGetDir
  733. movw %ax, InOutRes
  734. .LGetDir:
  735. end;
  736. { Now Dir should be filled with directory in ASCIIZ, }
  737. { starting from dir[4] }
  738. dir[0]:=#3;
  739. dir[2]:=':';
  740. dir[3]:='\';
  741. i:=4;
  742. {Conversion to Pascal string }
  743. while (dir[i]<>#0) do
  744. begin
  745. { convert path name to DOS }
  746. if dir[i]='/' then
  747. dir[i]:='\';
  748. dir[0]:=char(i);
  749. inc(i);
  750. end;
  751. { upcase the string (FPC function) }
  752. if drivenr<>0 then { Drive was supplied. We know it }
  753. dir[1]:=chr(64+drivenr)
  754. else
  755. begin
  756. { We need to get the current drive from DOS function 19H }
  757. { because the drive was the default, which can be unknown }
  758. asm
  759. movb $0x19,%ah
  760. call syscall
  761. addb $65,%al
  762. movb %al,i
  763. end;
  764. dir[1]:=char(i);
  765. end;
  766. if not (FileNameCaseSensitive) then dir:=upcase(dir);
  767. end;
  768. {*****************************************************************************
  769. System unit initialization.
  770. ****************************************************************************}
  771. procedure SysInitStdIO;
  772. begin
  773. OpenStdIO(Input,fmInput,StdInputHandle);
  774. OpenStdIO(Output,fmOutput,StdOutputHandle);
  775. OpenStdIO(StdOut,fmOutput,StdOutputHandle);
  776. OpenStdIO(StdErr,fmOutput,StdErrorHandle);
  777. end;
  778. function GetFileHandleCount: longint;
  779. var L1, L2: longint;
  780. begin
  781. L1 := 0; (* Don't change the amount, just check. *)
  782. if DosSetRelMaxFH (L1, L2) <> 0 then GetFileHandleCount := 50
  783. else GetFileHandleCount := L2;
  784. end;
  785. var tib:Pthreadinfoblock;
  786. begin
  787. IsConsole := TRUE;
  788. IsLibrary := FALSE;
  789. {Determine the operating system we are running on.}
  790. {$ASMMODE INTEL}
  791. asm
  792. mov os_mode, 0
  793. mov eax, 7F0Ah
  794. call syscall
  795. test bx, 512 {Bit 9 is OS/2 flag.}
  796. setne byte ptr os_mode
  797. test bx, 4096
  798. jz @noRSX
  799. mov os_mode, 2
  800. @noRSX:
  801. {Enable the brk area by initializing it with the initial heap size.}
  802. mov eax, 7F01h
  803. mov edx, heap_brk
  804. add edx, heap_base
  805. call syscall
  806. cmp eax, -1
  807. jnz @heapok
  808. push dword 204
  809. call HandleError
  810. @heapok:
  811. {$IFDEF CONTHEAP}
  812. { Find out brk limit }
  813. mov eax, 7F02h
  814. mov ecx, 3
  815. call syscall
  816. jcxz @heaplimitknown
  817. mov eax, 0
  818. @heaplimitknown:
  819. mov BrkLimit, eax
  820. {$ELSE CONTHEAP}
  821. { Change sbrk behaviour to allocate arbitrary (non-contiguous) memory blocks }
  822. mov eax, 7F0Fh
  823. mov ecx, 0Ch
  824. mov edx, 8
  825. call syscall
  826. {$ENDIF CONTHEAP}
  827. end;
  828. { in OS/2 this will always be nil, but in DOS mode }
  829. { this can be changed. }
  830. first_meg := nil;
  831. {Now request, if we are running under DOS,
  832. read-access to the first meg. of memory.}
  833. if os_mode in [osDOS,osDPMI] then
  834. asm
  835. mov eax, 7F13h
  836. xor ebx, ebx
  837. mov ecx, 0FFFh
  838. xor edx, edx
  839. call syscall
  840. jnc @endmem
  841. mov first_meg, eax
  842. @endmem:
  843. end
  844. else
  845. begin
  846. (* Initialize the amount of file handles *)
  847. FileHandleCount := GetFileHandleCount;
  848. end;
  849. {At 0.9.2, case for enumeration does not work.}
  850. case os_mode of
  851. osDOS:
  852. stackbottom:=cardinal(heap_brk); {In DOS mode, heap_brk is also the
  853. stack bottom.}
  854. osOS2:
  855. begin
  856. dosgetinfoblocks(@tib,nil);
  857. stackbottom:=cardinal(tib^.stack);
  858. end;
  859. osDPMI:
  860. stackbottom:=0; {Not sure how to get it, but seems to be
  861. always zero.}
  862. end;
  863. exitproc:=nil;
  864. {$ifdef MT}
  865. if os_mode = osOS2 then
  866. begin
  867. { allocate one ThreadVar entry from the OS, we use this entry }
  868. { for a pointer to our threadvars }
  869. if DosAllocThreadLocalMemory (1, DataIndex) <> 0 then RunError (8);
  870. { the exceptions use threadvars so do this _before_ initexceptions }
  871. AllocateThreadVars;
  872. end;
  873. {$endif MT}
  874. {Initialize the heap.}
  875. initheap;
  876. { ... and exceptions }
  877. SysInitExceptions;
  878. { ... and I/O }
  879. SysInitStdIO;
  880. { no I/O-Error }
  881. inoutres:=0;
  882. {$ifdef HASVARIANT}
  883. initvariantmanager;
  884. {$endif HASVARIANT}
  885. {$IFDEF DUMPGROW}
  886. {$IFDEF CONTHEAP}
  887. WriteLn ('Initial brk size is ', GetHeapSize);
  888. WriteLn ('Brk limit is ', BrkLimit);
  889. {$ENDIF CONTHEAP}
  890. {$ENDIF DUMPGROW}
  891. end.
  892. {
  893. $Log$
  894. Revision 1.1 2002-11-17 16:22:54 hajny
  895. + RTL for emx target
  896. Revision 1.26 2002/10/27 14:29:00 hajny
  897. * heap management (hopefully) fixed
  898. Revision 1.25 2002/10/14 19:39:17 peter
  899. * threads unit added for thread support
  900. Revision 1.24 2002/10/13 09:28:45 florian
  901. + call to initvariantmanager inserted
  902. Revision 1.23 2002/09/07 16:01:25 peter
  903. * old logs removed and tabs fixed
  904. Revision 1.22 2002/07/01 16:29:05 peter
  905. * sLineBreak changed to normal constant like Kylix
  906. Revision 1.21 2002/04/21 15:54:20 carl
  907. + initialize some global variables
  908. Revision 1.20 2002/04/12 17:42:16 carl
  909. + generic stack checking
  910. Revision 1.19 2002/03/11 19:10:33 peter
  911. * Regenerated with updated fpcmake
  912. Revision 1.18 2002/02/10 13:46:20 hajny
  913. * heap management corrected (heap_brk)
  914. }