system.pp 17 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667
  1. {
  2. This file is part of the Free Pascal run time library.
  3. Copyright (c) 1999-2000 by the Free Pascal development team.
  4. See the file COPYING.FPC, included in this distribution,
  5. for details about the copyright.
  6. This program is distributed in the hope that it will be useful,
  7. but WITHOUT ANY WARRANTY; without even the implied warranty of
  8. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  9. **********************************************************************}
  10. unit system;
  11. interface
  12. { two debug conditionnals can be used
  13. - SYSTEMDEBUG
  14. -for STACK checks
  15. -for non closed files at exit (or at any time with GDB)
  16. - SYSTEM_DEBUG_STARTUP
  17. specifically for
  18. - proxy command line (DJGPP feature)
  19. - list of args
  20. - list of env variables (PM) }
  21. {$ifndef NO_EXCEPTIONS_IN_SYSTEM}
  22. {$define EXCEPTIONS_IN_SYSTEM}
  23. {$endif NO_EXCEPTIONS_IN_SYSTEM}
  24. {$define USE_NOTHREADMANAGER}
  25. { include system-independent routine headers }
  26. {$I systemh.inc}
  27. const
  28. LineEnding = #13#10;
  29. { LFNSupport is a variable here, defined below!!! }
  30. DirectorySeparator = '\';
  31. DriveSeparator = ':';
  32. PathSeparator = ';';
  33. { FileNameCaseSensitive is defined separately below!!! }
  34. maxExitCode = 255;
  35. MaxPathLen = 256;
  36. const
  37. { Default filehandles }
  38. UnusedHandle = -1;
  39. StdInputHandle = 0;
  40. StdOutputHandle = 1;
  41. StdErrorHandle = 2;
  42. FileNameCaseSensitive : boolean = false;
  43. CtrlZMarksEOF: boolean = true; (* #26 is considered as end of file *)
  44. sLineBreak = LineEnding;
  45. DefaultTextLineBreakStyle : TTextLineBreakStyle = tlbsCRLF;
  46. { Default memory segments (Tp7 compatibility) }
  47. seg0040 = $0040;
  48. segA000 = $A000;
  49. segB000 = $B000;
  50. segB800 = $B800;
  51. var
  52. { Mem[] support }
  53. mem : array[0..$7fffffff-1] of byte absolute $0:$0;
  54. memw : array[0..($7fffffff div sizeof(word))-1] of word absolute $0:$0;
  55. meml : array[0..($7fffffff div sizeof(longint))-1] of longint absolute $0:$0;
  56. { C-compatible arguments and environment }
  57. argc : longint;
  58. argv : ppchar;
  59. envp : ppchar;
  60. dos_argv0 : pchar;
  61. AllFilesMask: string [3];
  62. {$ifndef RTLLITE}
  63. { System info }
  64. LFNSupport : boolean;
  65. {$ELSE RTLLITE}
  66. const
  67. LFNSupport = false;
  68. {$endif RTLLITE}
  69. type
  70. { Dos Extender info }
  71. p_stub_info = ^t_stub_info;
  72. t_stub_info = packed record
  73. magic : array[0..15] of char;
  74. size : longint;
  75. minstack : longint;
  76. memory_handle : longint;
  77. initial_size : longint;
  78. minkeep : word;
  79. ds_selector : word;
  80. ds_segment : word;
  81. psp_selector : word;
  82. cs_selector : word;
  83. env_size : word;
  84. basename : array[0..7] of char;
  85. argv0 : array [0..15] of char;
  86. dpmi_server : array [0..15] of char;
  87. end;
  88. p_go32_info_block = ^t_go32_info_block;
  89. t_go32_info_block = packed record
  90. size_of_this_structure_in_bytes : longint; {offset 0}
  91. linear_address_of_primary_screen : longint; {offset 4}
  92. linear_address_of_secondary_screen : longint; {offset 8}
  93. linear_address_of_transfer_buffer : longint; {offset 12}
  94. size_of_transfer_buffer : longint; {offset 16}
  95. pid : longint; {offset 20}
  96. master_interrupt_controller_base : byte; {offset 24}
  97. slave_interrupt_controller_base : byte; {offset 25}
  98. selector_for_linear_memory : word; {offset 26}
  99. linear_address_of_stub_info_structure : longint; {offset 28}
  100. linear_address_of_original_psp : longint; {offset 32}
  101. run_mode : word; {offset 36}
  102. run_mode_info : word; {offset 38}
  103. end;
  104. var
  105. stub_info : p_stub_info;
  106. go32_info_block : t_go32_info_block;
  107. {$ifdef SYSTEMDEBUG}
  108. const
  109. accept_sbrk : boolean = true;
  110. {$endif}
  111. {
  112. necessary for objects.pas, should be removed (at least from the interface
  113. to the implementation)
  114. }
  115. type
  116. trealregs=record
  117. realedi,realesi,realebp,realres,
  118. realebx,realedx,realecx,realeax : longint;
  119. realflags,
  120. reales,realds,realfs,realgs,
  121. realip,realcs,realsp,realss : word;
  122. end;
  123. function do_write(h:longint;addr:pointer;len : longint) : longint;
  124. function do_read(h:longint;addr:pointer;len : longint) : longint;
  125. procedure syscopyfromdos(addr : longint; len : longint);
  126. procedure syscopytodos(addr : longint; len : longint);
  127. procedure sysrealintr(intnr : word;var regs : trealregs);
  128. function tb : longint;
  129. implementation
  130. { include system independent routines }
  131. {$I system.inc}
  132. var
  133. _args : ppchar;external name '_args';
  134. __stubinfo : p_stub_info;external name '__stubinfo';
  135. ___dos_argv0 : pchar;external name '___dos_argv0';
  136. procedure setup_arguments;
  137. type
  138. arrayword = array [0..255] of word;
  139. var
  140. psp : word;
  141. proxy_s : string[50];
  142. proxy_argc,proxy_seg,proxy_ofs,lin : longint;
  143. rm_argv : ^arrayword;
  144. argv0len : longint;
  145. useproxy : boolean;
  146. hp : ppchar;
  147. doscmd : string[129]; { Dos commandline copied from PSP, max is 128 chars +1 for terminating zero }
  148. arglen,cmdlen,
  149. count : longint;
  150. argstart,
  151. pc,arg : pchar;
  152. quote : char;
  153. argvlen : longint;
  154. function atohex(s : pchar) : longint;
  155. var
  156. rv : longint;
  157. v : byte;
  158. begin
  159. rv:=0;
  160. while (s^<>#0) do
  161. begin
  162. v:=byte(s^)-byte('0');
  163. if (v > 9) then
  164. dec(v,7);
  165. v:=v and 15; { in case it's lower case }
  166. rv:=(rv shl 4) or v;
  167. inc(longint(s));
  168. end;
  169. atohex:=rv;
  170. end;
  171. procedure allocarg(idx,len:longint);
  172. var
  173. oldargvlen : longint;
  174. begin
  175. if idx>=argvlen then
  176. begin
  177. oldargvlen:=argvlen;
  178. argvlen:=(idx+8) and (not 7);
  179. sysreallocmem(argv,argvlen*sizeof(pointer));
  180. fillchar(argv[oldargvlen],(argvlen-oldargvlen)*sizeof(pointer),0);
  181. end;
  182. { use realloc to reuse already existing memory }
  183. { always allocate, even if length is zero, since }
  184. { the arg. is still present! }
  185. sysreallocmem(argv[idx],len+1);
  186. end;
  187. begin
  188. count:=0;
  189. argc:=1;
  190. argv:=nil;
  191. argvlen:=0;
  192. { load commandline from psp }
  193. psp:=stub_info^.psp_selector;
  194. sysseg_move(psp, 128, get_ds, longint(@doscmd), 128);
  195. doscmd[length(doscmd)+1]:=#0;
  196. {$IfDef SYSTEM_DEBUG_STARTUP}
  197. Writeln(stderr,'Dos command line is #',doscmd,'# size = ',length(doscmd));
  198. {$EndIf }
  199. { create argv[0] }
  200. argv0len:=strlen(dos_argv0);
  201. allocarg(count,argv0len+1);
  202. move(dos_argv0^,argv[count]^,argv0len+1);
  203. inc(count);
  204. { setup cmdline variable }
  205. cmdlen:=argv0len+length(doscmd)+2;
  206. cmdline:=Getmem(cmdlen);
  207. move(dos_argv0^,cmdline^,argv0len);
  208. cmdline[argv0len]:=' ';
  209. inc(argv0len);
  210. move(doscmd[1],cmdline[argv0len],length(doscmd));
  211. cmdline[cmdlen-1]:=#0;
  212. { parse dos commandline }
  213. pc:=@doscmd[1];
  214. while pc^<>#0 do
  215. begin
  216. { skip leading spaces }
  217. while pc^ in [#1..#32] do
  218. inc(pc);
  219. if pc^=#0 then
  220. break;
  221. { calc argument length }
  222. quote:=' ';
  223. argstart:=pc;
  224. arglen:=0;
  225. while (pc^<>#0) do
  226. begin
  227. case pc^ of
  228. #1..#32 :
  229. begin
  230. if quote<>' ' then
  231. inc(arglen)
  232. else
  233. break;
  234. end;
  235. '"' :
  236. begin
  237. if quote<>'''' then
  238. begin
  239. if pchar(pc+1)^<>'"' then
  240. begin
  241. if quote='"' then
  242. quote:=' '
  243. else
  244. quote:='"';
  245. end
  246. else
  247. inc(pc);
  248. end
  249. else
  250. inc(arglen);
  251. end;
  252. '''' :
  253. begin
  254. if quote<>'"' then
  255. begin
  256. if pchar(pc+1)^<>'''' then
  257. begin
  258. if quote='''' then
  259. quote:=' '
  260. else
  261. quote:='''';
  262. end
  263. else
  264. inc(pc);
  265. end
  266. else
  267. inc(arglen);
  268. end;
  269. else
  270. inc(arglen);
  271. end;
  272. inc(pc);
  273. end;
  274. { copy argument }
  275. allocarg(count,arglen);
  276. quote:=' ';
  277. pc:=argstart;
  278. arg:=argv[count];
  279. while (pc^<>#0) do
  280. begin
  281. case pc^ of
  282. #1..#32 :
  283. begin
  284. if quote<>' ' then
  285. begin
  286. arg^:=pc^;
  287. inc(arg);
  288. end
  289. else
  290. break;
  291. end;
  292. '"' :
  293. begin
  294. if quote<>'''' then
  295. begin
  296. if pchar(pc+1)^<>'"' then
  297. begin
  298. if quote='"' then
  299. quote:=' '
  300. else
  301. quote:='"';
  302. end
  303. else
  304. inc(pc);
  305. end
  306. else
  307. begin
  308. arg^:=pc^;
  309. inc(arg);
  310. end;
  311. end;
  312. '''' :
  313. begin
  314. if quote<>'"' then
  315. begin
  316. if pchar(pc+1)^<>'''' then
  317. begin
  318. if quote='''' then
  319. quote:=' '
  320. else
  321. quote:='''';
  322. end
  323. else
  324. inc(pc);
  325. end
  326. else
  327. begin
  328. arg^:=pc^;
  329. inc(arg);
  330. end;
  331. end;
  332. else
  333. begin
  334. arg^:=pc^;
  335. inc(arg);
  336. end;
  337. end;
  338. inc(pc);
  339. end;
  340. arg^:=#0;
  341. {$IfDef SYSTEM_DEBUG_STARTUP}
  342. Writeln(stderr,'dos arg ',count,' #',arglen,'#',argv[count],'#');
  343. {$EndIf SYSTEM_DEBUG_STARTUP}
  344. inc(count);
  345. end;
  346. argc:=count;
  347. { check for !proxy for long commandlines passed using environment }
  348. hp:=envp;
  349. useproxy:=false;
  350. while assigned(hp^) do
  351. begin
  352. if (hp^[0]=' ') then
  353. begin
  354. proxy_s:=strpas(hp^);
  355. if Copy(proxy_s,1,7)=' !proxy' then
  356. begin
  357. proxy_s[13]:=#0;
  358. proxy_s[18]:=#0;
  359. proxy_s[23]:=#0;
  360. argv[2]:=@proxy_s[9];
  361. argv[3]:=@proxy_s[14];
  362. argv[4]:=@proxy_s[19];
  363. useproxy:=true;
  364. break;
  365. end;
  366. end;
  367. inc(hp);
  368. end;
  369. { check for !proxy for long commandlines passed using commandline }
  370. if (not useproxy) and
  371. (argc > 1) and (far_strlen(get_ds,longint(argv[1])) = 6) then
  372. begin
  373. move(argv[1]^,proxy_s[1],6);
  374. proxy_s[0] := #6;
  375. if (proxy_s = '!proxy') then
  376. useproxy:=true;
  377. end;
  378. { use proxy when found }
  379. if useproxy then
  380. begin
  381. proxy_argc:=atohex(argv[2]);
  382. proxy_seg:=atohex(argv[3]);
  383. proxy_ofs:=atohex(argv[4]);
  384. {$IfDef SYSTEM_DEBUG_STARTUP}
  385. Writeln(stderr,'proxy command line found');
  386. writeln(stderr,'argc: ',proxy_argc,' seg: ',proxy_seg,' ofs: ',proxy_ofs);
  387. {$EndIf SYSTEM_DEBUG_STARTUP}
  388. rm_argv:=SysGetmem(proxy_argc*sizeof(word));
  389. sysseg_move(dos_selector,proxy_seg*16+proxy_ofs, get_ds,longint(rm_argv),proxy_argc*sizeof(word));
  390. for count:=0 to proxy_argc - 1 do
  391. begin
  392. lin:=proxy_seg*16+rm_argv^[count];
  393. arglen:=far_strlen(dos_selector,lin);
  394. allocarg(count,arglen);
  395. sysseg_move(dos_selector,lin,get_ds,longint(argv[count]),arglen+1);
  396. {$IfDef SYSTEM_DEBUG_STARTUP}
  397. Writeln(stderr,'arg ',count,' #',rm_argv^[count],'#',arglen,'#',argv[count],'#');
  398. {$EndIf SYSTEM_DEBUG_STARTUP}
  399. end;
  400. SysFreemem(rm_argv);
  401. argc:=proxy_argc;
  402. end;
  403. { create an nil entry }
  404. allocarg(argc,0);
  405. { free unused memory }
  406. sysreallocmem(argv,(argc+1)*sizeof(pointer));
  407. _args:=argv;
  408. end;
  409. procedure setup_environment;
  410. var env_selector : word;
  411. env_count : longint;
  412. dos_env,cp : pchar;
  413. begin
  414. stub_info:=__stubinfo;
  415. dos_env := sysgetmem(stub_info^.env_size);
  416. env_count:=0;
  417. sysseg_move(stub_info^.psp_selector,$2c, get_ds, longint(@env_selector), 2);
  418. sysseg_move(env_selector, 0, get_ds, longint(dos_env), stub_info^.env_size);
  419. cp:=dos_env;
  420. while cp ^ <> #0 do
  421. begin
  422. inc(env_count);
  423. while (cp^ <> #0) do inc(longint(cp)); { skip to NUL }
  424. inc(longint(cp)); { skip to next character }
  425. end;
  426. envp := sysgetmem((env_count+1) * sizeof(pchar));
  427. if (envp = nil) then HandleError (203);
  428. cp:=dos_env;
  429. env_count:=0;
  430. while cp^ <> #0 do
  431. begin
  432. envp[env_count] := sysgetmem(strlen(cp)+1);
  433. strcopy(envp[env_count], cp);
  434. {$IfDef SYSTEM_DEBUG_STARTUP}
  435. Writeln(stderr,'env ',env_count,' = "',envp[env_count],'"');
  436. {$EndIf SYSTEM_DEBUG_STARTUP}
  437. inc(env_count);
  438. while (cp^ <> #0) do
  439. inc(longint(cp)); { skip to NUL }
  440. inc(longint(cp)); { skip to next character }
  441. end;
  442. envp[env_count]:=nil;
  443. longint(cp):=longint(cp)+3;
  444. dos_argv0 := sysgetmem(strlen(cp)+1);
  445. if (dos_argv0 = nil) then HandleError (203);
  446. strcopy(dos_argv0, cp);
  447. { update ___dos_argv0 also }
  448. ___dos_argv0:=dos_argv0
  449. end;
  450. {*****************************************************************************
  451. System Dependent Exit code
  452. *****************************************************************************}
  453. procedure __exit(exitcode:longint);cdecl;external;
  454. Procedure system_exit;
  455. var
  456. h : byte;
  457. begin
  458. for h:=0 to max_files-1 do
  459. if openfiles[h] then
  460. begin
  461. {$ifdef SYSTEMDEBUG}
  462. writeln(stderr,'file ',opennames[h],' not closed at exit');
  463. {$endif SYSTEMDEBUG}
  464. if h>=5 then
  465. do_close(h);
  466. end;
  467. { halt is not allways called !! }
  468. { not on normal exit !! PM }
  469. set_pm_interrupt($00,old_int00);
  470. {$ifndef EXCEPTIONS_IN_SYSTEM}
  471. set_pm_interrupt($75,old_int75);
  472. {$endif EXCEPTIONS_IN_SYSTEM}
  473. __exit(exitcode);
  474. end;
  475. procedure new_int00;
  476. begin
  477. HandleError(200);
  478. end;
  479. {$ifndef EXCEPTIONS_IN_SYSTEM}
  480. procedure new_int75;
  481. begin
  482. asm
  483. xorl %eax,%eax
  484. outb %al,$0x0f0
  485. movb $0x20,%al
  486. outb %al,$0x0a0
  487. outb %al,$0x020
  488. end;
  489. HandleError(200);
  490. end;
  491. {$endif EXCEPTIONS_IN_SYSTEM}
  492. var
  493. __stkbottom : pointer;external name '__stkbottom';
  494. {*****************************************************************************
  495. ParamStr/Randomize
  496. *****************************************************************************}
  497. function paramcount : longint;
  498. begin
  499. paramcount := argc - 1;
  500. end;
  501. function paramstr(l : longint) : string;
  502. begin
  503. if (l>=0) and (l+1<=argc) then
  504. paramstr:=strpas(argv[l])
  505. else
  506. paramstr:='';
  507. end;
  508. procedure randomize;
  509. var
  510. hl : longint;
  511. regs : trealregs;
  512. begin
  513. regs.realeax:=$2c00;
  514. sysrealintr($21,regs);
  515. hl:=lo(regs.realedx);
  516. randseed:=hl*$10000+ lo(regs.realecx);
  517. end;
  518. {*****************************************************************************
  519. SystemUnit Initialization
  520. *****************************************************************************}
  521. function CheckLFN:boolean;
  522. var
  523. regs : TRealRegs;
  524. RootName : pchar;
  525. begin
  526. { Check LFN API on drive c:\ }
  527. RootName:='C:\';
  528. syscopytodos(longint(RootName),strlen(RootName)+1);
  529. { Call 'Get Volume Information' ($71A0) }
  530. regs.realeax:=$71a0;
  531. regs.reales:=tb_segment;
  532. regs.realedi:=tb_offset;
  533. regs.realecx:=32;
  534. regs.realds:=tb_segment;
  535. regs.realedx:=tb_offset;
  536. regs.realflags:=carryflag;
  537. sysrealintr($21,regs);
  538. { If carryflag=0 and LFN API bit in ebx is set then use Long file names }
  539. CheckLFN:=(regs.realflags and carryflag=0) and (regs.realebx and $4000=$4000);
  540. end;
  541. {$ifdef EXCEPTIONS_IN_SYSTEM}
  542. {$define IN_SYSTEM}
  543. {$i dpmiexcp.pp}
  544. {$endif EXCEPTIONS_IN_SYSTEM}
  545. procedure SysInitStdIO;
  546. begin
  547. OpenStdIO(Input,fmInput,StdInputHandle);
  548. OpenStdIO(Output,fmOutput,StdOutputHandle);
  549. OpenStdIO(ErrOutput,fmOutput,StdErrorHandle);
  550. OpenStdIO(StdOut,fmOutput,StdOutputHandle);
  551. OpenStdIO(StdErr,fmOutput,StdErrorHandle);
  552. end;
  553. function GetProcessID: SizeUInt;
  554. begin
  555. GetProcessID := SizeUInt (Go32_info_block.pid);
  556. end;
  557. function CheckInitialStkLen(stklen : SizeUInt) : SizeUInt;
  558. begin
  559. result := stklen;
  560. end;
  561. var
  562. temp_int : tseginfo;
  563. Begin
  564. StackLength := CheckInitialStkLen(InitialStkLen);
  565. StackBottom := __stkbottom;
  566. { To be set if this is a GUI or console application }
  567. IsConsole := TRUE;
  568. { To be set if this is a library and not a program }
  569. IsLibrary := FALSE;
  570. { save old int 0 and 75 }
  571. get_pm_interrupt($00,old_int00);
  572. get_pm_interrupt($75,old_int75);
  573. temp_int.segment:=get_cs;
  574. temp_int.offset:=@new_int00;
  575. set_pm_interrupt($00,temp_int);
  576. {$ifndef EXCEPTIONS_IN_SYSTEM}
  577. temp_int.offset:=@new_int75;
  578. set_pm_interrupt($75,temp_int);
  579. {$endif EXCEPTIONS_IN_SYSTEM}
  580. { Setup heap }
  581. InitHeap;
  582. SysInitExceptions;
  583. { Setup stdin, stdout and stderr }
  584. SysInitStdIO;
  585. { Setup environment and arguments }
  586. Setup_Environment;
  587. Setup_Arguments;
  588. { Use LFNSupport LFN }
  589. LFNSupport:=CheckLFN;
  590. if LFNSupport then
  591. begin
  592. FileNameCaseSensitive:=true;
  593. AllFilesMask := '*';
  594. end
  595. else
  596. AllFilesMask := '*.*';
  597. { Reset IO Error }
  598. InOutRes:=0;
  599. {$ifdef FPC_HAS_FEATURE_THREADING}
  600. InitSystemThreads;
  601. {$endif}
  602. {$ifdef EXCEPTIONS_IN_SYSTEM}
  603. InitDPMIExcp;
  604. InstallDefaultHandlers;
  605. {$endif EXCEPTIONS_IN_SYSTEM}
  606. initvariantmanager;
  607. End.