system.pas 27 KB

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