system.pp 33 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381
  1. {
  2. $Id$
  3. This file is part of the Free Pascal run time library.
  4. Copyright (c) 1993,97 by the Free Pascal development team.
  5. See the file COPYING.FPC, included in this distribution,
  6. for details about the copyright.
  7. This program is distributed in the hope that it will be useful,
  8. but WITHOUT ANY WARRANTY; without even the implied warranty of
  9. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  10. **********************************************************************}
  11. unit system;
  12. interface
  13. { two debug conditionnals can be used
  14. - SYSTEMDEBUG
  15. -for STACK checks
  16. -for non closed files at exit (or at any time with GDB)
  17. - SYSTEM_DEBUG_STARTUP
  18. specifically for
  19. - proxy command line (DJGPP feature)
  20. - list of args
  21. - list of env variables (PM) }
  22. { include system-independent routine headers }
  23. {$I systemh.inc}
  24. { include heap support headers }
  25. {$I heaph.inc}
  26. const
  27. { Default filehandles }
  28. UnusedHandle = -1;
  29. StdInputHandle = 0;
  30. StdOutputHandle = 1;
  31. StdErrorHandle = 2;
  32. FileNameCaseSensitive : boolean = false;
  33. { Default memory segments (Tp7 compatibility) }
  34. seg0040 = $0040;
  35. segA000 = $A000;
  36. segB000 = $B000;
  37. segB800 = $B800;
  38. var
  39. { Mem[] support }
  40. mem : array[0..$7fffffff] of byte absolute $0:$0;
  41. memw : array[0..$7fffffff] of word absolute $0:$0;
  42. meml : array[0..$7fffffff] of longint absolute $0:$0;
  43. { C-compatible arguments and environment }
  44. argc : longint;
  45. argv : ppchar;
  46. envp : ppchar;
  47. dos_argv0 : pchar;
  48. {$ifndef RTLLITE}
  49. { System info }
  50. LFNSupport : boolean;
  51. {$endif RTLLITE}
  52. type
  53. { Dos Extender info }
  54. p_stub_info = ^t_stub_info;
  55. t_stub_info = packed record
  56. magic : array[0..15] of char;
  57. size : longint;
  58. minstack : longint;
  59. memory_handle : longint;
  60. initial_size : longint;
  61. minkeep : word;
  62. ds_selector : word;
  63. ds_segment : word;
  64. psp_selector : word;
  65. cs_selector : word;
  66. env_size : word;
  67. basename : array[0..7] of char;
  68. argv0 : array [0..15] of char;
  69. dpmi_server : array [0..15] of char;
  70. end;
  71. p_go32_info_block = ^t_go32_info_block;
  72. t_go32_info_block = packed record
  73. size_of_this_structure_in_bytes : longint; {offset 0}
  74. linear_address_of_primary_screen : longint; {offset 4}
  75. linear_address_of_secondary_screen : longint; {offset 8}
  76. linear_address_of_transfer_buffer : longint; {offset 12}
  77. size_of_transfer_buffer : longint; {offset 16}
  78. pid : longint; {offset 20}
  79. master_interrupt_controller_base : byte; {offset 24}
  80. slave_interrupt_controller_base : byte; {offset 25}
  81. selector_for_linear_memory : word; {offset 26}
  82. linear_address_of_stub_info_structure : longint; {offset 28}
  83. linear_address_of_original_psp : longint; {offset 32}
  84. run_mode : word; {offset 36}
  85. run_mode_info : word; {offset 38}
  86. end;
  87. var
  88. stub_info : p_stub_info;
  89. go32_info_block : t_go32_info_block;
  90. {
  91. necessary for objects.pas, should be removed (at least from the interface
  92. to the implementation)
  93. }
  94. type
  95. trealregs=record
  96. realedi,realesi,realebp,realres,
  97. realebx,realedx,realecx,realeax : longint;
  98. realflags,
  99. reales,realds,realfs,realgs,
  100. realip,realcs,realsp,realss : word;
  101. end;
  102. function do_write(h,addr,len : longint) : longint;
  103. function do_read(h,addr,len : longint) : longint;
  104. procedure syscopyfromdos(addr : longint; len : longint);
  105. procedure syscopytodos(addr : longint; len : longint);
  106. procedure sysrealintr(intnr : word;var regs : trealregs);
  107. function tb : longint;
  108. implementation
  109. { include system independent routines }
  110. {$I system.inc}
  111. const
  112. carryflag = 1;
  113. type
  114. tseginfo=packed record
  115. offset : pointer;
  116. segment : word;
  117. end;
  118. var
  119. doscmd : string[128]; { Dos commandline copied from PSP, max is 128 chars }
  120. old_int00 : tseginfo;cvar;
  121. old_int75 : tseginfo;cvar;
  122. {$asmmode ATT}
  123. {*****************************************************************************
  124. Go32 Helpers
  125. *****************************************************************************}
  126. function far_strlen(selector : word;linear_address : longint) : longint;
  127. begin
  128. asm
  129. movl linear_address,%edx
  130. movl %edx,%ecx
  131. movw selector,%gs
  132. .Larg19:
  133. movb %gs:(%edx),%al
  134. testb %al,%al
  135. je .Larg20
  136. incl %edx
  137. jmp .Larg19
  138. .Larg20:
  139. movl %edx,%eax
  140. subl %ecx,%eax
  141. movl %eax,__RESULT
  142. end;
  143. end;
  144. function tb : longint;
  145. begin
  146. tb:=go32_info_block.linear_address_of_transfer_buffer;
  147. end;
  148. function tb_segment : longint;
  149. begin
  150. tb_segment:=go32_info_block.linear_address_of_transfer_buffer shr 4;
  151. end;
  152. function tb_offset : longint;
  153. begin
  154. tb_offset:=go32_info_block.linear_address_of_transfer_buffer and $f;
  155. end;
  156. function tb_size : longint;
  157. begin
  158. tb_size:=go32_info_block.size_of_transfer_buffer;
  159. end;
  160. function dos_selector : word;
  161. begin
  162. dos_selector:=go32_info_block.selector_for_linear_memory;
  163. end;
  164. function get_ds : word;assembler;
  165. asm
  166. movw %ds,%ax
  167. end;
  168. function get_cs : word;assembler;
  169. asm
  170. movw %cs,%ax
  171. end;
  172. procedure sysseg_move(sseg : word;source : longint;dseg : word;dest : longint;count : longint);
  173. begin
  174. if count=0 then
  175. exit;
  176. if (sseg<>dseg) or ((sseg=dseg) and (source>dest)) then
  177. asm
  178. pushw %es
  179. pushw %ds
  180. cld
  181. movl count,%ecx
  182. movl source,%esi
  183. movl dest,%edi
  184. movw dseg,%ax
  185. movw %ax,%es
  186. movw sseg,%ax
  187. movw %ax,%ds
  188. movl %ecx,%eax
  189. shrl $2,%ecx
  190. rep
  191. movsl
  192. movl %eax,%ecx
  193. andl $3,%ecx
  194. rep
  195. movsb
  196. popw %ds
  197. popw %es
  198. end ['ESI','EDI','ECX','EAX']
  199. else if (source<dest) then
  200. { copy backward for overlapping }
  201. asm
  202. pushw %es
  203. pushw %ds
  204. std
  205. movl count,%ecx
  206. movl source,%esi
  207. movl dest,%edi
  208. movw dseg,%ax
  209. movw %ax,%es
  210. movw sseg,%ax
  211. movw %ax,%ds
  212. addl %ecx,%esi
  213. addl %ecx,%edi
  214. movl %ecx,%eax
  215. andl $3,%ecx
  216. orl %ecx,%ecx
  217. jz .LSEG_MOVE1
  218. { calculate esi and edi}
  219. decl %esi
  220. decl %edi
  221. rep
  222. movsb
  223. incl %esi
  224. incl %edi
  225. .LSEG_MOVE1:
  226. subl $4,%esi
  227. subl $4,%edi
  228. movl %eax,%ecx
  229. shrl $2,%ecx
  230. rep
  231. movsl
  232. cld
  233. popw %ds
  234. popw %es
  235. end ['ESI','EDI','ECX'];
  236. end;
  237. function atohex(s : pchar) : longint;
  238. var
  239. rv : longint;
  240. v : byte;
  241. begin
  242. rv:=0;
  243. while (s^ <>#0) do
  244. begin
  245. v:=byte(s^)-byte('0');
  246. if (v > 9) then
  247. dec(v,7);
  248. v:=v and 15; { in case it's lower case }
  249. rv:=(rv shl 4) or v;
  250. inc(longint(s));
  251. end;
  252. atohex:=rv;
  253. end;
  254. var
  255. _args : ppchar;external name '_args';
  256. procedure setup_arguments;
  257. type arrayword = array [0..0] of word;
  258. var psp : word;
  259. i,j : byte;
  260. quote : char;
  261. proxy_s : string[7];
  262. al,proxy_argc,proxy_seg,proxy_ofs,lin : longint;
  263. largs : array[0..127] of pchar;
  264. rm_argv : ^arrayword;
  265. begin
  266. for i := 1 to 127 do
  267. largs[i] := nil;
  268. psp:=stub_info^.psp_selector;
  269. largs[0]:=dos_argv0;
  270. argc := 1;
  271. sysseg_move(psp, 128, get_ds, longint(@doscmd), 128);
  272. {$IfDef SYSTEM_DEBUG_STARTUP}
  273. Writeln(stderr,'Dos command line is #',doscmd,'# size = ',length(doscmd));
  274. {$EndIf }
  275. // setup cmdline variable
  276. getmem(cmdline,length(doscmd)+1);
  277. move(doscmd[1],cmdline^,length(doscmd));
  278. cmdline[length(doscmd)]:=#0;
  279. j := 1;
  280. quote := #0;
  281. for i:=1 to length(doscmd) do
  282. Begin
  283. if doscmd[i] = quote then
  284. begin
  285. quote := #0;
  286. doscmd[i] := #0;
  287. largs[argc]:=@doscmd[j];
  288. inc(argc);
  289. j := i+1;
  290. end else
  291. if (quote = #0) and ((doscmd[i] = '''') or (doscmd[i]='"')) then
  292. begin
  293. quote := doscmd[i];
  294. j := i + 1;
  295. end else
  296. if (quote = #0) and ((doscmd[i] = ' ')
  297. or (doscmd[i] = #9) or (doscmd[i] = #10) or
  298. (doscmd[i] = #12) or (doscmd[i] = #9)) then
  299. begin
  300. doscmd[i]:=#0;
  301. if j<i then
  302. begin
  303. largs[argc]:=@doscmd[j];
  304. inc(argc);
  305. j := i+1;
  306. end else inc(j);
  307. end else
  308. if (i = length(doscmd)) then
  309. begin
  310. doscmd[i+1]:=#0;
  311. largs[argc]:=@doscmd[j];
  312. inc(argc);
  313. end;
  314. end;
  315. if (argc > 1) and (far_strlen(get_ds,longint(largs[1])) = 6) then
  316. begin
  317. move(largs[1]^,proxy_s[1],6);
  318. proxy_s[0] := #6;
  319. if (proxy_s = '!proxy') then
  320. begin
  321. {$IfDef SYSTEM_DEBUG_STARTUP}
  322. Writeln(stderr,'proxy command line ');
  323. {$EndIf SYSTEM_DEBUG_STARTUP}
  324. proxy_argc := atohex(largs[2]);
  325. proxy_seg := atohex(largs[3]);
  326. proxy_ofs := atohex(largs[4]);
  327. getmem(rm_argv,proxy_argc*sizeof(word));
  328. sysseg_move(dos_selector,proxy_seg*16+proxy_ofs, get_ds,longint(rm_argv),proxy_argc*sizeof(word));
  329. for i:=0 to proxy_argc - 1 do
  330. begin
  331. lin := proxy_seg*16 + rm_argv^[i];
  332. al :=far_strlen(dos_selector, lin);
  333. getmem(largs[i],al+1);
  334. sysseg_move(dos_selector, lin, get_ds,longint(largs[i]), al+1);
  335. {$IfDef SYSTEM_DEBUG_STARTUP}
  336. Writeln(stderr,'arg ',i,' #',largs[i],'#');
  337. {$EndIf SYSTEM_DEBUG_STARTUP}
  338. end;
  339. argc := proxy_argc;
  340. end;
  341. end;
  342. getmem(argv,argc shl 2);
  343. for i := 0 to argc-1 do
  344. argv[i] := largs[i];
  345. _args:=argv;
  346. end;
  347. function strcopy(dest,source : pchar) : pchar;
  348. begin
  349. asm
  350. cld
  351. movl 12(%ebp),%edi
  352. movl $0xffffffff,%ecx
  353. xorb %al,%al
  354. repne
  355. scasb
  356. not %ecx
  357. movl 8(%ebp),%edi
  358. movl 12(%ebp),%esi
  359. movl %ecx,%eax
  360. shrl $2,%ecx
  361. rep
  362. movsl
  363. movl %eax,%ecx
  364. andl $3,%ecx
  365. rep
  366. movsb
  367. movl 8(%ebp),%eax
  368. leave
  369. ret $8
  370. end;
  371. end;
  372. var
  373. __stubinfo : p_stub_info;external name '__stubinfo';
  374. ___dos_argv0 : pchar;external name '___dos_argv0';
  375. procedure setup_environment;
  376. var env_selector : word;
  377. env_count : longint;
  378. dos_env,cp : pchar;
  379. begin
  380. stub_info:=__stubinfo;
  381. getmem(dos_env,stub_info^.env_size);
  382. env_count:=0;
  383. sysseg_move(stub_info^.psp_selector,$2c, get_ds, longint(@env_selector), 2);
  384. sysseg_move(env_selector, 0, get_ds, longint(dos_env), stub_info^.env_size);
  385. cp:=dos_env;
  386. while cp ^ <> #0 do
  387. begin
  388. inc(env_count);
  389. while (cp^ <> #0) do inc(longint(cp)); { skip to NUL }
  390. inc(longint(cp)); { skip to next character }
  391. end;
  392. getmem(envp,(env_count+1) * sizeof(pchar));
  393. if (envp = nil) then exit;
  394. cp:=dos_env;
  395. env_count:=0;
  396. while cp^ <> #0 do
  397. begin
  398. getmem(envp[env_count],strlen(cp)+1);
  399. strcopy(envp[env_count], cp);
  400. {$IfDef SYSTEM_DEBUG_STARTUP}
  401. Writeln(stderr,'env ',env_count,' = "',envp[env_count],'"');
  402. {$EndIf SYSTEM_DEBUG_STARTUP}
  403. inc(env_count);
  404. while (cp^ <> #0) do
  405. inc(longint(cp)); { skip to NUL }
  406. inc(longint(cp)); { skip to next character }
  407. end;
  408. envp[env_count]:=nil;
  409. longint(cp):=longint(cp)+3;
  410. getmem(dos_argv0,strlen(cp)+1);
  411. if (dos_argv0 = nil) then halt;
  412. strcopy(dos_argv0, cp);
  413. { update ___dos_argv0 also }
  414. ___dos_argv0:=dos_argv0
  415. end;
  416. procedure syscopytodos(addr : longint; len : longint);
  417. begin
  418. if len > tb_size then
  419. HandleError(217);
  420. sysseg_move(get_ds,addr,dos_selector,tb,len);
  421. end;
  422. procedure syscopyfromdos(addr : longint; len : longint);
  423. begin
  424. if len > tb_size then
  425. HandleError(217);
  426. sysseg_move(dos_selector,tb,get_ds,addr,len);
  427. end;
  428. procedure sysrealintr(intnr : word;var regs : trealregs);
  429. begin
  430. regs.realsp:=0;
  431. regs.realss:=0;
  432. asm
  433. movw intnr,%bx
  434. xorl %ecx,%ecx
  435. movl regs,%edi
  436. movw $0x300,%ax
  437. int $0x31
  438. end;
  439. end;
  440. procedure set_pm_interrupt(vector : byte;const intaddr : tseginfo);
  441. begin
  442. asm
  443. movl intaddr,%eax
  444. movl (%eax),%edx
  445. movw 4(%eax),%cx
  446. movl $0x205,%eax
  447. movb vector,%bl
  448. int $0x31
  449. end;
  450. end;
  451. procedure get_pm_interrupt(vector : byte;var intaddr : tseginfo);
  452. begin
  453. asm
  454. movb vector,%bl
  455. movl $0x204,%eax
  456. int $0x31
  457. movl intaddr,%eax
  458. movl %edx,(%eax)
  459. movw %cx,4(%eax)
  460. end;
  461. end;
  462. {$ifdef SYSTEMDEBUG}
  463. { Keep Track of open files }
  464. const
  465. max_files = 50;
  466. free_closed_names : boolean = true;
  467. var
  468. opennames : array [0..max_files-1] of pchar;
  469. openfiles : array [0..max_files-1] of boolean;
  470. {$endif SYSTEMDEBUG}
  471. {*****************************************************************************
  472. System Dependent Exit code
  473. *****************************************************************************}
  474. procedure ___exit(exitcode:byte);cdecl;external name '___exit';
  475. Procedure system_exit;
  476. {$ifdef SYSTEMDEBUG}
  477. var
  478. h : byte;
  479. {$endif SYSTEMDEBUG}
  480. begin
  481. {$ifdef SYSTEMDEBUG}
  482. for h:=0 to max_files-1 do
  483. if openfiles[h] then
  484. writeln(stderr,'file ',opennames[h],' not closed at exit');
  485. {$endif SYSTEMDEBUG}
  486. { halt is not allways called !! }
  487. { not on normal exit !! PM }
  488. set_pm_interrupt($00,old_int00);
  489. set_pm_interrupt($75,old_int75);
  490. ___exit(exitcode);
  491. end;
  492. procedure halt(errnum : byte);
  493. begin
  494. exitcode:=errnum;
  495. do_exit;
  496. { do_exit should call system_exit but this does not hurt }
  497. System_exit;
  498. end;
  499. procedure new_int00;
  500. begin
  501. HandleError(200);
  502. end;
  503. procedure new_int75;
  504. begin
  505. asm
  506. xorl %eax,%eax
  507. outb %al,$0x0f0
  508. movb $0x20,%al
  509. outb %al,$0x0a0
  510. outb %al,$0x020
  511. end;
  512. HandleError(200);
  513. end;
  514. var
  515. __stkbottom : longint;external name '__stkbottom';
  516. procedure int_stackcheck(stack_size:longint);[public,alias:'FPC_STACKCHECK'];
  517. {
  518. called when trying to get local stack if the compiler directive $S
  519. is set this function must preserve esi !!!! because esi is set by
  520. the calling proc for methods it must preserve all registers !!
  521. With a 2048 byte safe area used to write to StdIo without crossing
  522. the stack boundary
  523. }
  524. begin
  525. asm
  526. pushl %eax
  527. pushl %ebx
  528. movl stack_size,%ebx
  529. addl $2048,%ebx
  530. movl %esp,%eax
  531. subl %ebx,%eax
  532. {$ifdef SYSTEMDEBUG}
  533. movl loweststack,%ebx
  534. cmpl %eax,%ebx
  535. jb .L_is_not_lowest
  536. movl %eax,loweststack
  537. .L_is_not_lowest:
  538. {$endif SYSTEMDEBUG}
  539. movl __stkbottom,%ebx
  540. cmpl %eax,%ebx
  541. jae .L__short_on_stack
  542. popl %ebx
  543. popl %eax
  544. leave
  545. ret $4
  546. .L__short_on_stack:
  547. { can be usefull for error recovery !! }
  548. popl %ebx
  549. popl %eax
  550. end['EAX','EBX'];
  551. HandleError(202);
  552. end;
  553. {*****************************************************************************
  554. ParamStr/Randomize
  555. *****************************************************************************}
  556. function paramcount : longint;
  557. begin
  558. paramcount := argc - 1;
  559. end;
  560. function paramstr(l : longint) : string;
  561. begin
  562. if (l>=0) and (l+1<=argc) then
  563. paramstr:=strpas(argv[l])
  564. else
  565. paramstr:='';
  566. end;
  567. procedure randomize;
  568. var
  569. hl : longint;
  570. regs : trealregs;
  571. begin
  572. regs.realeax:=$2c00;
  573. sysrealintr($21,regs);
  574. hl:=regs.realedx and $ffff;
  575. randseed:=hl*$10000+ (regs.realecx and $ffff);
  576. end;
  577. {*****************************************************************************
  578. Heap Management
  579. *****************************************************************************}
  580. var
  581. int_heap : longint;external name 'HEAP';
  582. int_heapsize : longint;external name 'HEAPSIZE';
  583. function getheapstart:pointer;
  584. begin
  585. getheapstart:=@int_heap;
  586. end;
  587. function getheapsize:longint;
  588. begin
  589. getheapsize:=int_heapsize;
  590. end;
  591. function ___sbrk(size:longint):longint;cdecl;external name '___sbrk';
  592. function Sbrk(size : longint):longint;assembler;
  593. asm
  594. movl size,%eax
  595. pushl %eax
  596. call ___sbrk
  597. addl $4,%esp
  598. end;
  599. { include standard heap management }
  600. {$I heap.inc}
  601. {****************************************************************************
  602. Low level File Routines
  603. ****************************************************************************}
  604. procedure AllowSlash(p:pchar);
  605. var
  606. i : longint;
  607. begin
  608. { allow slash as backslash }
  609. for i:=0 to strlen(p) do
  610. if p[i]='/' then p[i]:='\';
  611. end;
  612. procedure do_close(handle : longint);
  613. var
  614. regs : trealregs;
  615. begin
  616. regs.realebx:=handle;
  617. {$ifdef SYSTEMDEBUG}
  618. if handle<max_files then
  619. begin
  620. openfiles[handle]:=false;
  621. if assigned(opennames[handle]) and free_closed_names then
  622. begin
  623. freemem(opennames[handle],strlen(opennames[handle])+1);
  624. opennames[handle]:=nil;
  625. end;
  626. end;
  627. {$endif SYSTEMDEBUG}
  628. regs.realeax:=$3e00;
  629. sysrealintr($21,regs);
  630. if (regs.realflags and carryflag) <> 0 then
  631. InOutRes:=lo(regs.realeax);
  632. end;
  633. procedure do_erase(p : pchar);
  634. var
  635. regs : trealregs;
  636. begin
  637. AllowSlash(p);
  638. syscopytodos(longint(p),strlen(p)+1);
  639. regs.realedx:=tb_offset;
  640. regs.realds:=tb_segment;
  641. {$ifndef RTLLITE}
  642. if LFNSupport then
  643. regs.realeax:=$7141
  644. else
  645. {$endif RTLLITE}
  646. regs.realeax:=$4100;
  647. regs.realesi:=0;
  648. regs.realecx:=0;
  649. sysrealintr($21,regs);
  650. if (regs.realflags and carryflag) <> 0 then
  651. InOutRes:=lo(regs.realeax);
  652. end;
  653. procedure do_rename(p1,p2 : pchar);
  654. var
  655. regs : trealregs;
  656. begin
  657. AllowSlash(p1);
  658. AllowSlash(p2);
  659. if strlen(p1)+strlen(p2)+3>tb_size then
  660. HandleError(217);
  661. sysseg_move(get_ds,longint(p2),dos_selector,tb,strlen(p2)+1);
  662. sysseg_move(get_ds,longint(p1),dos_selector,tb+strlen(p2)+2,strlen(p1)+1);
  663. regs.realedi:=tb_offset;
  664. regs.realedx:=tb_offset + strlen(p2)+2;
  665. regs.realds:=tb_segment;
  666. regs.reales:=tb_segment;
  667. {$ifndef RTLLITE}
  668. if LFNSupport then
  669. regs.realeax:=$7156
  670. else
  671. {$endif RTLLITE}
  672. regs.realeax:=$5600;
  673. regs.realecx:=$ff; { attribute problem here ! }
  674. sysrealintr($21,regs);
  675. if (regs.realflags and carryflag) <> 0 then
  676. InOutRes:=lo(regs.realeax);
  677. end;
  678. function do_write(h,addr,len : longint) : longint;
  679. var
  680. regs : trealregs;
  681. size,
  682. writesize : longint;
  683. begin
  684. writesize:=0;
  685. while len > 0 do
  686. begin
  687. if len>tb_size then
  688. size:=tb_size
  689. else
  690. size:=len;
  691. syscopytodos(addr+writesize,size);
  692. regs.realecx:=size;
  693. regs.realedx:=tb_offset;
  694. regs.realds:=tb_segment;
  695. regs.realebx:=h;
  696. regs.realeax:=$4000;
  697. sysrealintr($21,regs);
  698. if (regs.realflags and carryflag) <> 0 then
  699. begin
  700. InOutRes:=lo(regs.realeax);
  701. exit(writesize);
  702. end;
  703. len:=len-size;
  704. writesize:=writesize+size;
  705. end;
  706. Do_Write:=WriteSize
  707. end;
  708. function do_read(h,addr,len : longint) : longint;
  709. var
  710. regs : trealregs;
  711. size,
  712. readsize : longint;
  713. begin
  714. readsize:=0;
  715. while len > 0 do
  716. begin
  717. if len>tb_size then
  718. size:=tb_size
  719. else
  720. size:=len;
  721. regs.realecx:=size;
  722. regs.realedx:=tb_offset;
  723. regs.realds:=tb_segment;
  724. regs.realebx:=h;
  725. regs.realeax:=$3f00;
  726. sysrealintr($21,regs);
  727. if (regs.realflags and carryflag) <> 0 then
  728. begin
  729. InOutRes:=lo(regs.realeax);
  730. do_read:=0;
  731. exit;
  732. end
  733. else
  734. if regs.realeax<size then
  735. begin
  736. syscopyfromdos(addr+readsize,regs.realeax);
  737. do_read:=readsize+regs.realeax;
  738. exit;
  739. end;
  740. syscopyfromdos(addr+readsize,regs.realeax);
  741. readsize:=readsize+regs.realeax;
  742. len:=len-regs.realeax;
  743. end;
  744. do_read:=readsize;
  745. end;
  746. function do_filepos(handle : longint) : longint;
  747. var
  748. regs : trealregs;
  749. begin
  750. regs.realebx:=handle;
  751. regs.realecx:=0;
  752. regs.realedx:=0;
  753. regs.realeax:=$4201;
  754. sysrealintr($21,regs);
  755. if (regs.realflags and carryflag) <> 0 then
  756. Begin
  757. InOutRes:=lo(regs.realeax);
  758. do_filepos:=0;
  759. end
  760. else
  761. do_filepos:=lo(regs.realedx) shl 16+lo(regs.realeax);
  762. end;
  763. procedure do_seek(handle,pos : longint);
  764. var
  765. regs : trealregs;
  766. begin
  767. regs.realebx:=handle;
  768. regs.realecx:=pos shr 16;
  769. regs.realedx:=pos and $ffff;
  770. regs.realeax:=$4200;
  771. sysrealintr($21,regs);
  772. if (regs.realflags and carryflag) <> 0 then
  773. InOutRes:=lo(regs.realeax);
  774. end;
  775. function do_seekend(handle:longint):longint;
  776. var
  777. regs : trealregs;
  778. begin
  779. regs.realebx:=handle;
  780. regs.realecx:=0;
  781. regs.realedx:=0;
  782. regs.realeax:=$4202;
  783. sysrealintr($21,regs);
  784. if (regs.realflags and carryflag) <> 0 then
  785. Begin
  786. InOutRes:=lo(regs.realeax);
  787. do_seekend:=0;
  788. end
  789. else
  790. do_seekend:=lo(regs.realedx) shl 16+lo(regs.realeax);
  791. end;
  792. function do_filesize(handle : longint) : longint;
  793. var
  794. aktfilepos : longint;
  795. begin
  796. aktfilepos:=do_filepos(handle);
  797. do_filesize:=do_seekend(handle);
  798. do_seek(handle,aktfilepos);
  799. end;
  800. { truncate at a given position }
  801. procedure do_truncate (handle,pos:longint);
  802. var
  803. regs : trealregs;
  804. begin
  805. do_seek(handle,pos);
  806. regs.realecx:=0;
  807. regs.realedx:=tb_offset;
  808. regs.realds:=tb_segment;
  809. regs.realebx:=handle;
  810. regs.realeax:=$4000;
  811. sysrealintr($21,regs);
  812. if (regs.realflags and carryflag) <> 0 then
  813. InOutRes:=lo(regs.realeax);
  814. end;
  815. procedure do_open(var f;p:pchar;flags:longint);
  816. {
  817. filerec and textrec have both handle and mode as the first items so
  818. they could use the same routine for opening/creating.
  819. when (flags and $10) the file will be append
  820. when (flags and $100) the file will be truncate/rewritten
  821. when (flags and $1000) there is no check for close (needed for textfiles)
  822. }
  823. var
  824. regs : trealregs;
  825. action : longint;
  826. begin
  827. AllowSlash(p);
  828. { close first if opened }
  829. if ((flags and $1000)=0) then
  830. begin
  831. case filerec(f).mode of
  832. fminput,fmoutput,fminout : Do_Close(filerec(f).handle);
  833. fmclosed : ;
  834. else
  835. begin
  836. inoutres:=102; {not assigned}
  837. exit;
  838. end;
  839. end;
  840. end;
  841. { reset file handle }
  842. filerec(f).handle:=UnusedHandle;
  843. action:=$1;
  844. { convert filemode to filerec modes }
  845. case (flags and 3) of
  846. 0 : filerec(f).mode:=fminput;
  847. 1 : filerec(f).mode:=fmoutput;
  848. 2 : filerec(f).mode:=fminout;
  849. end;
  850. if (flags and $100)<>0 then
  851. begin
  852. filerec(f).mode:=fmoutput;
  853. action:=$12; {create file function}
  854. end;
  855. { empty name is special }
  856. if p[0]=#0 then
  857. begin
  858. case filerec(f).mode of
  859. fminput : filerec(f).handle:=StdInputHandle;
  860. fmappend,
  861. fmoutput : begin
  862. filerec(f).handle:=StdOutputHandle;
  863. filerec(f).mode:=fmoutput; {fool fmappend}
  864. end;
  865. end;
  866. exit;
  867. end;
  868. { real dos call }
  869. syscopytodos(longint(p),strlen(p)+1);
  870. {$ifndef RTLLITE}
  871. if LFNSupport then
  872. regs.realeax:=$716c
  873. else
  874. {$endif RTLLITE}
  875. regs.realeax:=$6c00;
  876. regs.realedx:=action;
  877. regs.realds:=tb_segment;
  878. regs.realesi:=tb_offset;
  879. regs.realebx:=$2000+(flags and $ff);
  880. regs.realecx:=$20;
  881. sysrealintr($21,regs);
  882. if (regs.realflags and carryflag) <> 0 then
  883. begin
  884. InOutRes:=lo(regs.realeax);
  885. exit;
  886. end
  887. else
  888. filerec(f).handle:=regs.realeax;
  889. {$ifdef SYSTEMDEBUG}
  890. if regs.realeax<max_files then
  891. begin
  892. openfiles[regs.realeax]:=true;
  893. getmem(opennames[regs.realeax],strlen(p)+1);
  894. move(p^,opennames[regs.realeax]^,strlen(p)+1);
  895. end;
  896. {$endif SYSTEMDEBUG}
  897. { append mode }
  898. if (flags and $10)<>0 then
  899. begin
  900. do_seekend(filerec(f).handle);
  901. filerec(f).mode:=fmoutput; {fool fmappend}
  902. end;
  903. end;
  904. function do_isdevice(handle:longint):boolean;
  905. var
  906. regs : trealregs;
  907. begin
  908. regs.realebx:=handle;
  909. regs.realeax:=$4400;
  910. sysrealintr($21,regs);
  911. do_isdevice:=(regs.realedx and $80)<>0;
  912. if (regs.realflags and carryflag) <> 0 then
  913. InOutRes:=lo(regs.realeax);
  914. end;
  915. {*****************************************************************************
  916. UnTyped File Handling
  917. *****************************************************************************}
  918. {$i file.inc}
  919. {*****************************************************************************
  920. Typed File Handling
  921. *****************************************************************************}
  922. {$i typefile.inc}
  923. {*****************************************************************************
  924. Text File Handling
  925. *****************************************************************************}
  926. {$DEFINE EOF_CTRLZ}
  927. {$i text.inc}
  928. {*****************************************************************************
  929. Directory Handling
  930. *****************************************************************************}
  931. procedure DosDir(func:byte;const s:string);
  932. var
  933. buffer : array[0..255] of char;
  934. regs : trealregs;
  935. begin
  936. move(s[1],buffer,length(s));
  937. buffer[length(s)]:=#0;
  938. AllowSlash(pchar(@buffer));
  939. syscopytodos(longint(@buffer),length(s)+1);
  940. regs.realedx:=tb_offset;
  941. regs.realds:=tb_segment;
  942. {$ifndef RTLLITE}
  943. if LFNSupport then
  944. regs.realeax:=$7100+func
  945. else
  946. {$endif RTLLITE}
  947. regs.realeax:=func shl 8;
  948. sysrealintr($21,regs);
  949. if (regs.realflags and carryflag) <> 0 then
  950. InOutRes:=lo(regs.realeax);
  951. end;
  952. procedure mkdir(const s : string);[IOCheck];
  953. begin
  954. If InOutRes <> 0 then
  955. exit;
  956. DosDir($39,s);
  957. end;
  958. procedure rmdir(const s : string);[IOCheck];
  959. begin
  960. If InOutRes <> 0 then
  961. exit;
  962. DosDir($3a,s);
  963. end;
  964. procedure chdir(const s : string);[IOCheck];
  965. var
  966. regs : trealregs;
  967. begin
  968. If InOutRes <> 0 then
  969. exit;
  970. { First handle Drive changes }
  971. if (length(s)>=2) and (s[2]=':') then
  972. begin
  973. regs.realedx:=(ord(s[1]) and (not 32))-ord('A');
  974. regs.realeax:=$0e00;
  975. sysrealintr($21,regs);
  976. regs.realeax:=$1900;
  977. sysrealintr($21,regs);
  978. if byte(regs.realeax)<>byte(regs.realedx) then
  979. begin
  980. Inoutres:=15;
  981. exit;
  982. end;
  983. end;
  984. { do the normal dos chdir }
  985. DosDir($3b,s);
  986. end;
  987. procedure getdir(drivenr : byte;var dir : shortstring);
  988. var
  989. temp : array[0..255] of char;
  990. i : longint;
  991. regs : trealregs;
  992. begin
  993. regs.realedx:=drivenr;
  994. regs.realesi:=tb_offset;
  995. regs.realds:=tb_segment;
  996. {$ifndef RTLLITE}
  997. if LFNSupport then
  998. regs.realeax:=$7147
  999. else
  1000. {$endif RTLLITE}
  1001. regs.realeax:=$4700;
  1002. sysrealintr($21,regs);
  1003. if (regs.realflags and carryflag) <> 0 then
  1004. Begin
  1005. InOutRes:=lo(regs.realeax);
  1006. exit;
  1007. end
  1008. else
  1009. syscopyfromdos(longint(@temp),251);
  1010. { conversion to Pascal string including slash conversion }
  1011. i:=0;
  1012. while (temp[i]<>#0) do
  1013. begin
  1014. if temp[i]='/' then
  1015. temp[i]:='\';
  1016. dir[i+4]:=temp[i];
  1017. inc(i);
  1018. end;
  1019. dir[2]:=':';
  1020. dir[3]:='\';
  1021. dir[0]:=char(i+3);
  1022. { upcase the string }
  1023. if not FileNameCaseSensitive then
  1024. dir:=upcase(dir);
  1025. if drivenr<>0 then { Drive was supplied. We know it }
  1026. dir[1]:=char(65+drivenr-1)
  1027. else
  1028. begin
  1029. { We need to get the current drive from DOS function 19H }
  1030. { because the drive was the default, which can be unknown }
  1031. regs.realeax:=$1900;
  1032. sysrealintr($21,regs);
  1033. i:= (regs.realeax and $ff) + ord('A');
  1034. dir[1]:=chr(i);
  1035. end;
  1036. end;
  1037. {*****************************************************************************
  1038. SystemUnit Initialization
  1039. *****************************************************************************}
  1040. {$ifndef RTLLITE}
  1041. function CheckLFN:boolean;
  1042. var
  1043. regs : TRealRegs;
  1044. RootName : pchar;
  1045. begin
  1046. { Check LFN API on drive c:\ }
  1047. RootName:='C:\';
  1048. syscopytodos(longint(RootName),strlen(RootName)+1);
  1049. { Call 'Get Volume Information' ($71A0) }
  1050. regs.realeax:=$71a0;
  1051. regs.reales:=tb_segment;
  1052. regs.realedi:=tb_offset;
  1053. regs.realecx:=32;
  1054. regs.realds:=tb_segment;
  1055. regs.realedx:=tb_offset;
  1056. regs.realflags:=carryflag;
  1057. sysrealintr($21,regs);
  1058. { If carryflag=0 and LFN API bit in ebx is set then use Long file names }
  1059. CheckLFN:=(regs.realflags and carryflag=0) and (regs.realebx and $4000=$4000);
  1060. end;
  1061. {$endif RTLLITE}
  1062. {$ifdef MT}
  1063. {$I thread.inc}
  1064. {$endif MT}
  1065. var
  1066. temp_int : tseginfo;
  1067. Begin
  1068. { save old int 0 and 75 }
  1069. get_pm_interrupt($00,old_int00);
  1070. get_pm_interrupt($75,old_int75);
  1071. temp_int.segment:=get_cs;
  1072. temp_int.offset:=@new_int00;
  1073. set_pm_interrupt($00,temp_int);
  1074. { temp_int.offset:=@new_int75;
  1075. set_pm_interrupt($75,temp_int); }
  1076. { to test stack depth }
  1077. loweststack:=maxlongint;
  1078. { Setup heap }
  1079. InitHeap;
  1080. {$ifdef MT}
  1081. { before this, you can't use thread vars !!!! }
  1082. { threadvarblocksize is calculate before the initialization }
  1083. { of the system unit }
  1084. getmem(mainprogramthreadblock,threadvarblocksize);
  1085. {$endif MT}
  1086. { Setup stdin, stdout and stderr }
  1087. OpenStdIO(Input,fmInput,StdInputHandle);
  1088. OpenStdIO(Output,fmOutput,StdOutputHandle);
  1089. OpenStdIO(StdOut,fmOutput,StdOutputHandle);
  1090. OpenStdIO(StdErr,fmOutput,StdErrorHandle);
  1091. { Setup environment and arguments }
  1092. Setup_Environment;
  1093. Setup_Arguments;
  1094. { Use LFNSupport LFN }
  1095. LFNSupport:=CheckLFN;
  1096. if LFNSupport then
  1097. FileNameCaseSensitive:=true;
  1098. { Reset IO Error }
  1099. InOutRes:=0;
  1100. End.
  1101. {
  1102. $Log$
  1103. Revision 1.11 1999-05-04 23:28:40 pierre
  1104. SYSTEM_DEBUG_STARTUP used to output args and env at start
  1105. Revision 1.10 1999/04/28 11:42:45 peter
  1106. + FileNameCaseSensetive boolean
  1107. Revision 1.9 1999/04/28 06:01:25 florian
  1108. * define MT for multithreading introduced
  1109. Revision 1.8 1999/04/08 12:23:02 peter
  1110. * removed os.inc
  1111. Revision 1.7 1999/03/10 22:15:28 florian
  1112. + system.cmdline variable for go32v2 and win32 added
  1113. Revision 1.6 1999/03/01 15:40:52 peter
  1114. * use external names
  1115. * removed all direct assembler modes
  1116. Revision 1.5 1999/01/18 10:05:50 pierre
  1117. + system_exit procedure added
  1118. Revision 1.4 1998/12/30 22:17:59 peter
  1119. * fixed mem decls to use $0:$0
  1120. Revision 1.3 1998/12/28 15:50:45 peter
  1121. + stdout, which is needed when you write something in the system unit
  1122. to the screen. Like the runtime error
  1123. Revision 1.2 1998/12/21 14:22:02 pierre
  1124. * old_int?? transformed to cvar to be readable by dpmiexcp
  1125. Revision 1.1 1998/12/21 13:07:03 peter
  1126. * use -FE
  1127. Revision 1.25 1998/12/15 22:42:52 peter
  1128. * removed temp symbols
  1129. Revision 1.24 1998/11/29 22:28:10 peter
  1130. + io-error 103 added
  1131. Revision 1.23 1998/11/16 14:15:02 pierre
  1132. * changed getdir(byte,string) to getdir(byte,shortstring)
  1133. Revision 1.22 1998/10/26 14:49:46 pierre
  1134. * system debug info output to stderr
  1135. Revision 1.21 1998/10/20 07:34:07 pierre
  1136. + systemdebug reports about unclosed files at exit
  1137. Revision 1.20 1998/10/13 21:41:06 peter
  1138. + int 0 for divide by zero
  1139. Revision 1.19 1998/09/14 10:48:05 peter
  1140. * FPC_ names
  1141. * Heap manager is now system independent
  1142. Revision 1.18 1998/08/28 10:48:04 peter
  1143. * fixed chdir with drive changing
  1144. * updated checklfn from mailinglist
  1145. Revision 1.17 1998/08/27 10:30:51 pierre
  1146. * go32v1 RTL did not compile (LFNsupport outside go32v2 defines !)
  1147. I renamed tb_selector to tb_segment because
  1148. it is a real mode segment as opposed to
  1149. a protected mode selector
  1150. Fixed it for go32v1 (remove the $E0000000 offset !)
  1151. Revision 1.16 1998/08/26 10:04:03 peter
  1152. * new lfn check from mailinglist
  1153. * renamed win95 -> LFNSupport
  1154. + tb_selector, tb_offset for easier access to transferbuffer
  1155. Revision 1.15 1998/08/19 10:56:34 pierre
  1156. + added some special code for C interface
  1157. to avoid loading of crt1.o or dpmiexcp.o from the libc.a
  1158. Revision 1.14 1998/08/04 14:34:38 pierre
  1159. * small bug fix to get it compiled with bugfix version !!
  1160. (again the asmmode problem !!!
  1161. Peter it was really not the best idea you had !!)
  1162. Revision 1.13 1998/07/30 13:26:22 michael
  1163. + Added support for ErrorProc variable. All internal functions are required
  1164. to call HandleError instead of runerror from now on.
  1165. This is necessary for exception support.
  1166. Revision 1.12 1998/07/13 21:19:08 florian
  1167. * some problems with ansi string support fixed
  1168. Revision 1.11 1998/07/07 12:33:08 carl
  1169. * added 2k buffer for stack checking for correct io on error
  1170. Revision 1.10 1998/07/02 12:29:20 carl
  1171. * IOCheck for rmdir,chdir and mkdir as in TP
  1172. NOTE: I'm pretty SURE this will not compile and link correctly with FPC
  1173. 0.99.5
  1174. Revision 1.9 1998/07/01 15:29:57 peter
  1175. * better readln/writeln
  1176. Revision 1.8 1998/06/26 08:19:10 pierre
  1177. + all debug in ifdef SYSTEMDEBUG
  1178. + added local arrays :
  1179. opennames names of opened files
  1180. fileopen boolean array to know if still open
  1181. usefull with gdb if you get problems about too
  1182. many open files !!
  1183. Revision 1.7 1998/06/15 15:17:08 daniel
  1184. * RTLLITE conditional added to produce smaller RTL.
  1185. Revision 1.6 1998/05/31 14:18:29 peter
  1186. * force att or direct assembling
  1187. * cleanup of some files
  1188. Revision 1.5 1998/05/21 19:30:52 peter
  1189. * objects compiles for linux
  1190. + assign(pchar), assign(char), rename(pchar), rename(char)
  1191. * fixed read_text_as_array
  1192. + read_text_as_pchar which was not yet in the rtl
  1193. Revision 1.4 1998/05/04 17:58:41 peter
  1194. * fix for smartlinking with _ARGS
  1195. Revision 1.3 1998/05/04 16:21:54 florian
  1196. + LFNSupport flag to the interface moved
  1197. }