system.pp 15 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682
  1. {
  2. $Id$
  3. This file is part of the Free Pascal run time library.
  4. Copyright (c) 1993,97 by Florian Klaempfl,
  5. member of the Free Pascal development team.
  6. See the file COPYING.FPC, included in this distribution,
  7. for details about the copyright.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  11. **********************************************************************}
  12. { system unit for go32v1 }
  13. {$define DOS}
  14. unit system;
  15. {$I os.inc}
  16. interface
  17. { die betriebssystemunabhangigen Deklarationen einfuegen: }
  18. {$I systemh.inc}
  19. {$I heaph.inc}
  20. const
  21. UnusedHandle=$ffff;
  22. StdInputHandle=0;
  23. StdOutputHandle=1;
  24. StdErrorHandle=2;
  25. type
  26. {$PACKRECORDS 1}
  27. t_stub_info = record
  28. magic : array[0..15] of char;
  29. size : longint;
  30. minstack : longint;
  31. memory_handle : longint;
  32. initial_size : longint;
  33. minkeep : word;
  34. ds_selector : word;
  35. ds_segment : word;
  36. psp_selector : word;
  37. cs_selector : word;
  38. env_size : word;
  39. basename : array[0..7] of char;
  40. argv0 : array [0..15] of char;
  41. dpmi_server : array [0..15] of char;
  42. end;
  43. p_stub_info = ^t_stub_info;
  44. t_go32_info_block = record
  45. size_of_this_structure_in_bytes : longint; {offset 0}
  46. linear_address_of_primary_screen : longint; {offset 4}
  47. linear_address_of_secondary_screen : longint; {offset 8}
  48. linear_address_of_transfer_buffer : longint; {offset 12}
  49. size_of_transfer_buffer : longint; {offset 16}
  50. pid : longint; {offset 20}
  51. master_interrupt_controller_base : byte; {offset 24}
  52. slave_interrupt_controller_base : byte; {offset 25}
  53. selector_for_linear_memory : word; {offset 26}
  54. linear_address_of_stub_info_structure : longint; {offset 28}
  55. linear_address_of_original_psp : longint; {offset 32}
  56. run_mode : word; {offset 36}
  57. run_mode_info : word; {offset 38}
  58. end;
  59. {$PACKRECORDS NORMAL}
  60. var
  61. stub_info : p_stub_info;
  62. go32_info_block : t_go32_info_block;
  63. environ : ppchar;
  64. implementation
  65. { include system independent routines }
  66. {$I system.inc}
  67. {$S-}
  68. procedure st1(stack_size : longint);[public,alias: 'STACKCHECK'];
  69. begin
  70. { called when trying to get local stack }
  71. { if the compiler directive $S is set }
  72. { this function must preserve esi !!!! }
  73. { because esi is set by the calling }
  74. { proc for methods }
  75. { it must preserve all registers !! }
  76. asm
  77. pushl %eax
  78. pushl %ebx
  79. movl stack_size,%ebx
  80. movl %esp,%eax
  81. subl %ebx,%eax
  82. {$ifdef SYSTEMDEBUG}
  83. movl U_SYSTEM_LOWESTSTACK,%ebx
  84. cmpl %eax,%ebx
  85. jb _is_not_lowest
  86. movl %eax,U_SYSTEM_LOWESTSTACK
  87. _is_not_lowest:
  88. {$endif SYSTEMDEBUG}
  89. movl __stkbottom,%ebx
  90. cmpl %eax,%ebx
  91. jae __short_on_stack
  92. popl %ebx
  93. popl %eax
  94. leave
  95. ret $4
  96. __short_on_stack:
  97. { can be usefull for error recovery !! }
  98. popl %ebx
  99. popl %eax
  100. end['EAX','EBX'];
  101. RunError(202);
  102. { this needs a local variable }
  103. { so the function called itself !! }
  104. { Writeln('low in stack ');
  105. RunError(202); }
  106. end;
  107. procedure halt(errnum : byte);
  108. begin
  109. do_exit;
  110. flush(stderr);
  111. asm
  112. movl $0x4c00,%eax
  113. movb 8(%ebp),%al
  114. int $0x21
  115. end;
  116. end;
  117. function paramcount : longint;
  118. begin
  119. asm
  120. movl _argc,%eax
  121. decl %eax
  122. leave
  123. ret
  124. end ['EAX'];
  125. end;
  126. function paramstr(l : longint) : string;
  127. function args : pointer;
  128. begin
  129. asm
  130. movl _args,%eax
  131. leave
  132. ret
  133. end ['EAX'];
  134. end;
  135. var
  136. p : ^pchar;
  137. begin
  138. if (l>=0) and (l<=paramcount) then
  139. begin
  140. p:=args;
  141. paramstr:=strpas(p[l]);
  142. end
  143. else paramstr:='';
  144. end;
  145. procedure randomize;
  146. var
  147. hl : longint;
  148. begin
  149. asm
  150. movb $0x2c,%ah
  151. int $0x21
  152. movw %cx,-4(%ebp)
  153. movw %dx,-2(%ebp)
  154. end;
  155. randseed:=hl;
  156. end;
  157. { use standard heap management }
  158. { sbrk function of go32v1 }
  159. function Sbrk(size : longint) : longint;
  160. begin
  161. asm
  162. movl size,%ebx
  163. movl $0x4a01,%eax
  164. int $0x21
  165. movl %eax,__RESULT
  166. end;
  167. end;
  168. {$I heap.inc}
  169. {****************************************************************************
  170. Low Level File Routines
  171. ****************************************************************************}
  172. procedure AllowSlash(p:pchar);
  173. var
  174. i : longint;
  175. begin
  176. { allow slash as backslash }
  177. for i:=0 to strlen(p) do
  178. if p[i]='/' then p[i]:='\';
  179. end;
  180. procedure do_close(h : longint);
  181. begin
  182. asm
  183. movl 8(%ebp),%ebx
  184. movb $0x3e,%ah
  185. pushl %ebp
  186. intl $0x21
  187. popl %ebp
  188. end;
  189. end;
  190. procedure do_erase(p : pchar);
  191. begin
  192. AllowSlash(p);
  193. asm
  194. movl 8(%ebp),%edx
  195. movb $0x41,%ah
  196. pushl %ebp
  197. int $0x21
  198. popl %ebp
  199. jnc .LERASE1
  200. movw %ax,U_SYSTEM_INOUTRES;
  201. .LERASE1:
  202. end;
  203. end;
  204. procedure do_rename(p1,p2 : pchar);
  205. begin
  206. AllowSlash(p1);
  207. AllowSlash(p2);
  208. asm
  209. movl 8(%ebp),%edx
  210. movl 12(%ebp),%edi
  211. movb $0x56,%ah
  212. pushl %ebp
  213. int $0x21
  214. popl %ebp
  215. jnc .LRENAME1
  216. movw %ax,U_SYSTEM_INOUTRES;
  217. .LRENAME1:
  218. end;
  219. end;
  220. function do_write(h,addr,len : longint) : longint;
  221. begin
  222. asm
  223. movl 16(%ebp),%ecx
  224. movl 12(%ebp),%edx
  225. movl 8(%ebp),%ebx
  226. movb $0x40,%ah
  227. int $0x21
  228. jnc .LDOSWRITE1
  229. movw %ax,U_SYSTEM_INOUTRES;
  230. .LDOSWRITE1:
  231. movl %eax,-4(%ebp)
  232. end;
  233. end;
  234. function do_read(h,addr,len : longint) : longint;
  235. begin
  236. asm
  237. movl 16(%ebp),%ecx
  238. movl 12(%ebp),%edx
  239. movl 8(%ebp),%ebx
  240. movb $0x3f,%ah
  241. int $0x21
  242. jnc .LDOSREAD1
  243. movw %ax,U_SYSTEM_INOUTRES;
  244. xorl %eax,%eax
  245. .LDOSREAD1:
  246. leave
  247. ret $12
  248. end;
  249. end;
  250. function do_filepos(handle : longint) : longint;
  251. begin
  252. asm
  253. movb $0x42,%ah
  254. movb $0x1,%al
  255. movl 8(%ebp),%ebx
  256. xorl %ecx,%ecx
  257. xorl %edx,%edx
  258. pushl %ebp
  259. int $0x21
  260. popl %ebp
  261. jnc .LDOSFILEPOS1
  262. movw %ax,U_SYSTEM_INOUTRES;
  263. xorl %eax,%eax
  264. jmp .LDOSFILEPOS2
  265. .LDOSFILEPOS1:
  266. shll $16,%edx
  267. movzwl %ax,%eax
  268. orl %edx,%eax
  269. .LDOSFILEPOS2:
  270. leave
  271. ret $4
  272. end;
  273. end;
  274. procedure do_seek(handle,pos : longint);
  275. begin
  276. asm
  277. movl $0x4200,%eax
  278. movl 8(%ebp),%ebx
  279. movl 12(%ebp),%edx
  280. movl %edx,%ecx
  281. shrl $16,%ecx
  282. pushl %ebp
  283. int $0x21
  284. popl %ebp
  285. jnc .LDOSSEEK1
  286. movw %ax,U_SYSTEM_INOUTRES;
  287. .LDOSSEEK1:
  288. leave
  289. ret $8
  290. end;
  291. end;
  292. function do_seekend(handle : longint) : longint;
  293. begin
  294. asm
  295. movl $0x4202,%eax
  296. movl 8(%ebp),%ebx
  297. xorl %ecx,%ecx
  298. xorl %edx,%edx
  299. pushl %ebp
  300. int $0x21
  301. popl %ebp
  302. jnc .Lset_at_end1
  303. movw %ax,U_SYSTEM_INOUTRES;
  304. xorl %eax,%eax
  305. jmp .Lset_at_end2
  306. .Lset_at_end1:
  307. shll $16,%edx
  308. movzwl %ax,%eax
  309. orl %edx,%eax
  310. .Lset_at_end2:
  311. leave
  312. ret $4
  313. end;
  314. end;
  315. function do_filesize(handle : longint) : longint;
  316. var
  317. aktfilepos : longint;
  318. begin
  319. aktfilepos:=do_filepos(handle);
  320. do_filesize:=do_seekend(handle);
  321. do_seek(handle,aktfilepos);
  322. end;
  323. procedure do_truncate(handle,pos : longint);
  324. begin
  325. asm
  326. movl $0x4200,%eax
  327. movl 8(%ebp),%ebx
  328. movl 12(%ebp),%edx
  329. movl %edx,%ecx
  330. shrl $16,%ecx
  331. pushl %ebp
  332. int $0x21
  333. popl %ebp
  334. jc .LTruncate1
  335. movl 8(%ebp),%ebx
  336. movl 12(%ebp),%edx
  337. movl %ebp,%edx
  338. xorl %ecx,%ecx
  339. movb $0x40,%ah
  340. int $0x21
  341. jnc .LTruncate2
  342. .LTruncate1:
  343. movw %ax,U_SYSTEM_INOUTRES;
  344. .LTruncate2:
  345. leave
  346. ret $8
  347. end;
  348. end;
  349. procedure do_open(var f;p:pchar;flags:longint);
  350. {
  351. filerec and textrec have both handle and mode as the first items so
  352. they could use the same routine for opening/creating.
  353. when (flags and $10) the file will be append
  354. when (flags and $100) the file will be truncate/rewritten
  355. when (flags and $1000) there is no check for close (needed for textfiles)
  356. }
  357. var
  358. oflags : longint;
  359. begin
  360. AllowSlash(p);
  361. { close first if opened }
  362. if ((flags and $1000)=0) then
  363. begin
  364. case filerec(f).mode of
  365. fminput,fmoutput,fminout : Do_Close(filerec(f).handle);
  366. fmclosed : ;
  367. else
  368. begin
  369. inoutres:=102; {not assigned}
  370. exit;
  371. end;
  372. end;
  373. end;
  374. { reset file handle }
  375. filerec(f).handle:=UnusedHandle;
  376. oflags:=$8404;
  377. { convert filemode to filerec modes }
  378. case (flags and 3) of
  379. 0 : begin
  380. filerec(f).mode:=fminput;
  381. oflags:=$8001;
  382. end;
  383. 1 : filerec(f).mode:=fmoutput;
  384. 2 : filerec(f).mode:=fminout;
  385. end;
  386. if (flags and $100)<>0 then
  387. begin
  388. filerec(f).mode:=fmoutput;
  389. oflags:=$8302;
  390. end
  391. else
  392. if (flags and $10)<>0 then
  393. begin
  394. filerec(f).mode:=fmoutput;
  395. oflags:=$8404;
  396. end;
  397. { empty name is special }
  398. if p[0]=#0 then
  399. begin
  400. case filerec(f).mode of
  401. fminput : filerec(f).handle:=StdInputHandle;
  402. fmappend,
  403. fmoutput : begin
  404. filerec(f).handle:=StdOutputHandle;
  405. filerec(f).mode:=fmoutput; {fool fmappend}
  406. end;
  407. end;
  408. exit;
  409. end;
  410. asm
  411. movl $0xff02,%ax
  412. movl -4(%ebp),%ecx
  413. movl 12(%ebp),%ebx
  414. int $0x21
  415. jnc .LOPEN1
  416. movw %ax,U_SYSTEM_INOUTRES;
  417. movw $0xffff,%ax
  418. .LOPEN1:
  419. movl 8(%ebp),%edx
  420. movw %ax,(%edx)
  421. end;
  422. if (flags and $10)<>0 then
  423. do_seekend(filerec(f).handle);
  424. end;
  425. {*****************************************************************************
  426. UnTyped File Handling
  427. *****************************************************************************}
  428. {$i file.inc}
  429. {*****************************************************************************
  430. Typed File Handling
  431. *****************************************************************************}
  432. {$i typefile.inc}
  433. {*****************************************************************************
  434. Text File Handling
  435. *****************************************************************************}
  436. {$DEFINE EOF_CTRLZ}
  437. {$i text.inc}
  438. {*****************************************************************************
  439. Directory Handling
  440. *****************************************************************************}
  441. procedure DosDir(func:byte;const s:string);
  442. var
  443. buffer : array[0..255] of char;
  444. begin
  445. move(s[1],buffer,length(s));
  446. buffer[length(s)]:=#0;
  447. AllowSlash(pchar(@buffer));
  448. asm
  449. leal buffer,%edx
  450. movb 8(%ebp),%ah
  451. int $0x21
  452. jnc .LDOS_DIRS1
  453. movw %ax,U_SYSTEM_INOUTRES;
  454. .LDOS_DIRS1:
  455. end;
  456. end;
  457. procedure mkdir(const s : string);
  458. begin
  459. DosDir($39,s);
  460. end;
  461. procedure rmdir(const s : string);
  462. begin
  463. DosDir($3a,s);
  464. end;
  465. procedure chdir(const s : string);
  466. begin
  467. DosDir($3b,s);
  468. end;
  469. { thanks to Michael Van Canneyt <[email protected]>, }
  470. { who writes this code }
  471. { her is a problem if the getdir is called with a pathstr var in dos.pp }
  472. procedure getdir(drivenr : byte;var dir : string);
  473. var
  474. temp : array[0..255] of char;
  475. sof : pchar;
  476. i : byte;
  477. begin
  478. sof:=pchar(@dir[4]);
  479. { dir[1..3] will contain '[drivenr]:\', but is not }
  480. { supplied by DOS, so we let dos string start at }
  481. { dir[4] }
  482. { Get dir from drivenr : 0=default, 1=A etc... }
  483. asm
  484. movb drivenr,%dl
  485. movl sof,%esi
  486. mov $0x47,%ah
  487. int $0x21
  488. end;
  489. { Now Dir should be filled with directory in ASCIIZ, }
  490. { starting from dir[4] }
  491. dir[0]:=#3;
  492. dir[2]:=':';
  493. dir[3]:='\';
  494. i:=4;
  495. { conversation to Pascal string }
  496. while (dir[i]<>#0) do
  497. begin
  498. { convert path name to DOS }
  499. if dir[i]='/' then
  500. dir[i]:='\';
  501. dir[0]:=chr(i);
  502. inc(i);
  503. end;
  504. { upcase the string (FPKPascal function) }
  505. dir:=upcase(dir);
  506. if drivenr<>0 then { Drive was supplied. We know it }
  507. dir[1]:=chr(65+drivenr-1)
  508. else
  509. begin
  510. { We need to get the current drive from DOS function 19H }
  511. { because the drive was the default, which can be unknown }
  512. asm
  513. movb $0x19,%ah
  514. int $0x21
  515. addb $65,%al
  516. movb %al,i
  517. end;
  518. dir[1]:=chr(i);
  519. end;
  520. end;
  521. {*****************************************************************************
  522. SystemUnit Initialization
  523. *****************************************************************************}
  524. procedure OpenStdIO(var f:text;mode:word;hdl:longint);
  525. begin
  526. Assign(f,'');
  527. TextRec(f).Handle:=hdl;
  528. TextRec(f).Mode:=mode;
  529. TextRec(f).InOutFunc:=@FileInOutFunc;
  530. TextRec(f).FlushFunc:=@FileInOutFunc;
  531. TextRec(f).Closefunc:=@fileclosefunc;
  532. end;
  533. Begin
  534. { Initialize ExitProc }
  535. ExitProc:=Nil;
  536. { to test stack depth }
  537. loweststack:=maxlongint;
  538. { Setup heap }
  539. InitHeap;
  540. { Setup stdin, stdout and stderr }
  541. OpenStdIO(Input,fmInput,StdInputHandle);
  542. OpenStdIO(Output,fmOutput,StdOutputHandle);
  543. OpenStdIO(StdErr,fmOutput,StdErrorHandle);
  544. { Reset IO Error }
  545. InOutRes:=0;
  546. End.
  547. {
  548. $Log$
  549. Revision 1.2 1998-03-26 12:21:02 peter
  550. * makefile works again
  551. * environ is now defined in system.pp (like go32v2)
  552. Revision 1.1.1.1 1998/03/25 11:18:41 root
  553. * Restored version
  554. Revision 1.9 1998/02/14 01:41:35 peter
  555. * fixed unusedhandle bug which was -1
  556. Revision 1.8 1998/01/26 11:57:03 michael
  557. + Added log at the end
  558. Working file: rtl/dos/go32v1/system.pp
  559. description:
  560. ----------------------------
  561. revision 1.7
  562. date: 1998/01/25 21:53:22; author: peter; state: Exp; lines: +12 -8
  563. + Universal Handles support for StdIn/StdOut/StdErr
  564. * Updated layout of sysamiga.pas
  565. ----------------------------
  566. revision 1.6
  567. date: 1998/01/16 23:10:50; author: florian; state: Exp; lines: +2 -2
  568. + some tobject stuff
  569. ----------------------------
  570. revision 1.5
  571. date: 1998/01/11 02:47:31; author: michael; state: Exp; lines: +384 -507
  572. * Changed files to use the new filestructure in /inc directory.
  573. (By Peter Vreman)
  574. ----------------------------
  575. revision 1.4
  576. date: 1998/01/07 00:05:04; author: michael; state: Exp; lines: +189 -184
  577. + Final adjustments for a uniform file handling interface.
  578. (From Peter Vreman)
  579. ----------------------------
  580. revision 1.3
  581. date: 1998/01/05 16:51:04; author: michael; state: Exp; lines: +18 -46
  582. + Moved init of heap to heap.inc: INITheap() (From Peter Vreman)
  583. ----------------------------
  584. revision 1.2
  585. date: 1997/12/01 12:24:06; author: michael; state: Exp; lines: +12 -3
  586. + added copyright reference in header.
  587. ----------------------------
  588. revision 1.1
  589. date: 1997/11/27 08:33:53; author: michael; state: Exp;
  590. Initial revision
  591. ----------------------------
  592. revision 1.1.1.1
  593. date: 1997/11/27 08:33:53; author: michael; state: Exp; lines: +0 -0
  594. FPC RTL CVS start
  595. =============================================================================
  596. }