syswin32.pp 13 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525
  1. {
  2. $Id$
  3. This file is part of the Free Pascal run time library.
  4. FPC Pascal system unit for the Win32 API.
  5. Copyright (c) 1993,98 by Florian Klaempfl and Pavel Ozerski
  6. member of the Free Pascal development team.
  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 syswin32;
  14. {$I os.inc}
  15. interface
  16. {$I systemh.inc}
  17. var
  18. hprevinst,hinstance,cmdshow : longint;
  19. heaperror : pointer;
  20. { $I heaph.inc}
  21. const
  22. UnusedHandle : longint = -1;
  23. StdInputHandle : longint = 0;
  24. StdOutputHandle : longint = 0;
  25. StdErrorHandle : longint = 0;
  26. implementation
  27. { some declarations for Win32 API calls }
  28. {$I Win32.inc}
  29. {$I system.inc}
  30. type
  31. plongint = ^longint;
  32. {$ifdef dummy}
  33. {$S-}
  34. procedure st1(stack_size : longint);[public,alias: 'STACKCHECK'];
  35. begin
  36. { called when trying to get local stack }
  37. { if the compiler directive $S is set }
  38. { this function must preserve esi !!!! }
  39. { because esi is set by the calling }
  40. { proc for methods }
  41. { it must preserve all registers !! }
  42. asm
  43. pushl %eax
  44. pushl %ebx
  45. movl stack_size,%ebx
  46. movl %esp,%eax
  47. subl %ebx,%eax
  48. {$ifdef SYSTEMDEBUG}
  49. movl U_SYSTEM_LOWESTSTACK,%ebx
  50. cmpl %eax,%ebx
  51. jb _is_not_lowest
  52. movl %eax,U_SYSTEM_LOWESTSTACK
  53. _is_not_lowest:
  54. {$endif SYSTEMDEBUG}
  55. movl __stkbottom,%ebx
  56. cmpl %eax,%ebx
  57. jae __short_on_stack
  58. popl %ebx
  59. popl %eax
  60. leave
  61. ret $4
  62. __short_on_stack:
  63. { can be usefull for error recovery !! }
  64. popl %ebx
  65. popl %eax
  66. end['EAX','EBX'];
  67. RunError(202);
  68. { this needs a local variable }
  69. { so the function called itself !! }
  70. { Writeln('low in stack ');
  71. RunError(202); }
  72. end;
  73. {$endif dummy}
  74. var
  75. argc : longint;
  76. args : pointer;
  77. arg_buffer : pointer;
  78. procedure halt(errnum : byte);
  79. begin
  80. do_exit;
  81. flush(stderr);
  82. LocalFree(arg_buffer);
  83. ExitProcess(errnum);
  84. end;
  85. function paramcount : longint;
  86. begin
  87. paramcount:=argc-1;
  88. end;
  89. function paramstr(l : longint) : string;
  90. var
  91. p : ^pchar;
  92. begin
  93. if (l>=0) and (l<=paramcount) then
  94. begin
  95. p:=args;
  96. paramstr:=strpas(p[l]);
  97. end
  98. else paramstr:='';
  99. end;
  100. procedure randomize;
  101. var
  102. hl : longint;
  103. begin
  104. asm
  105. movb $0x2c,%ah
  106. int $0x21
  107. movw %cx,-4(%ebp)
  108. movw %dx,-2(%ebp)
  109. end;
  110. randseed:=hl;
  111. end;
  112. { use standard heap management }
  113. { sbrk function of go32v1 }
  114. function Sbrk(size : longint) : longint;
  115. begin
  116. asm
  117. movl size,%ebx
  118. movl $0x4a01,%eax
  119. int $0x21
  120. movl %eax,__RESULT
  121. end;
  122. end;
  123. {$i winheap.inc}
  124. { $I heap.inc}
  125. {****************************************************************************
  126. Low Level File Routines
  127. ****************************************************************************}
  128. procedure AllowSlash(p:pchar);
  129. var
  130. i : longint;
  131. begin
  132. { allow slash as backslash }
  133. for i:=0 to strlen(p) do
  134. if p[i]='/' then p[i]:='\';
  135. end;
  136. procedure do_close(h : longint);
  137. begin
  138. closehandle(h);
  139. end;
  140. procedure do_erase(p : pchar);
  141. begin
  142. AllowSlash(p);
  143. if DeleteFile(p)=0 then
  144. inoutres:=GetLastError;
  145. end;
  146. procedure do_rename(p1,p2 : pchar);
  147. begin
  148. AllowSlash(p1);
  149. AllowSlash(p2);
  150. if MoveFile(p1,p2)=0 then
  151. inoutres:=GetLastError;
  152. end;
  153. function do_write(h,addr,len : longint) : longint;
  154. var
  155. size:longint;
  156. begin
  157. if writefile(h,pointer(addr),len,size,nil)=0 then
  158. inoutres:=GetLastError;
  159. do_write:=size;
  160. end;
  161. function do_read(h,addr,len : longint) : longint;
  162. var
  163. result:longint;
  164. begin
  165. if readfile(h,pointer(addr),len,result,nil)=0 then
  166. inoutres:=GetLastError;
  167. do_read:=result;
  168. end;
  169. function do_filepos(handle : longint) : longint;
  170. var
  171. l:longint;
  172. begin
  173. l:=SetFilePointer(handle,0,nil,1);
  174. if l=-1 then
  175. begin
  176. l:=0;
  177. inoutres:=GetLastError;
  178. end;
  179. do_filepos:=l;
  180. end;
  181. procedure do_seek(handle,pos : longint);
  182. begin
  183. if SetFilePointer(handle,pos,nil,0)=-1 then
  184. inoutres:=GetLastError;
  185. end;
  186. function do_seekend(handle:longint):longint;
  187. begin
  188. {!!!!!!!!!!!!}
  189. end;
  190. function do_filesize(handle : longint) : longint;
  191. var
  192. aktfilepos : longint;
  193. begin
  194. aktfilepos:=do_filepos(handle);
  195. do_filesize:=do_seekend(handle);
  196. do_seek(handle,aktfilepos);
  197. end;
  198. procedure do_truncate (handle,pos:longint);
  199. begin
  200. {!!!!!!!!!!!!}
  201. end;
  202. procedure do_open(var f;p:pchar;flags:longint);
  203. {
  204. filerec and textrec have both handle and mode as the first items so
  205. they could use the same routine for opening/creating.
  206. when (flags and $10) the file will be append
  207. when (flags and $100) the file will be truncate/rewritten
  208. when (flags and $1000) there is no check for close (needed for textfiles)
  209. }
  210. begin
  211. AllowSlash(p);
  212. {!!!!!!!!!!!!}
  213. end;
  214. {*****************************************************************************
  215. UnTyped File Handling
  216. *****************************************************************************}
  217. {$i file.inc}
  218. {*****************************************************************************
  219. Typed File Handling
  220. *****************************************************************************}
  221. {$i typefile.inc}
  222. {*****************************************************************************
  223. Text File Handling
  224. *****************************************************************************}
  225. {$DEFINE EOF_CTRLZ}
  226. {$i text.inc}
  227. {*****************************************************************************
  228. Directory Handling
  229. *****************************************************************************}
  230. procedure DosDir(func:byte;const s:string);
  231. var
  232. buffer : array[0..255] of char;
  233. begin
  234. move(s[1],buffer,length(s));
  235. buffer[length(s)]:=#0;
  236. AllowSlash(pchar(@buffer));
  237. {!!!!!!!!!!!!}
  238. end;
  239. procedure mkdir(const s : string);
  240. begin
  241. {!!!!!!!!!!!!}
  242. end;
  243. procedure rmdir(const s : string);
  244. begin
  245. {!!!!!!!!!!!!}
  246. end;
  247. procedure chdir(const s : string);
  248. begin
  249. DosDir($3b,s);
  250. end;
  251. { thanks to Michael Van Canneyt <[email protected]>, }
  252. { who writes this code }
  253. { her is a problem if the getdir is called with a pathstr var in dos.pp }
  254. procedure getdir(drivenr : byte;var dir : string);
  255. var
  256. temp : array[0..255] of char;
  257. sof : pchar;
  258. i : byte;
  259. begin
  260. sof:=pchar(@dir[4]);
  261. { dir[1..3] will contain '[drivenr]:\', but is not }
  262. { supplied by DOS, so we let dos string start at }
  263. { dir[4] }
  264. { Get dir from drivenr : 0=default, 1=A etc... }
  265. asm
  266. movb drivenr,%dl
  267. movl sof,%esi
  268. mov $0x47,%ah
  269. int $0x21
  270. end;
  271. { Now Dir should be filled with directory in ASCIIZ, }
  272. { starting from dir[4] }
  273. dir[0]:=#3;
  274. dir[2]:=':';
  275. dir[3]:='\';
  276. i:=4;
  277. { conversation to Pascal string }
  278. while (dir[i]<>#0) do
  279. begin
  280. { convert path name to DOS }
  281. if dir[i]='/' then
  282. dir[i]:='\';
  283. dir[0]:=chr(i);
  284. inc(i);
  285. end;
  286. { upcase the string (FPKPascal function) }
  287. dir:=upcase(dir);
  288. if drivenr<>0 then { Drive was supplied. We know it }
  289. dir[1]:=chr(65+drivenr-1)
  290. else
  291. begin
  292. { We need to get the current drive from DOS function 19H }
  293. { because the drive was the default, which can be unknown }
  294. asm
  295. movb $0x19,%ah
  296. int $0x21
  297. addb $65,%al
  298. movb %al,i
  299. end;
  300. dir[1]:=chr(i);
  301. end;
  302. end;
  303. {*****************************************************************************
  304. SystemUnit Initialization
  305. *****************************************************************************}
  306. procedure Entry;[public,alias: '_mainCRTStartup'];
  307. {
  308. the following procedure is written with the help of an article of
  309. the german computer magazine c't (3/97 p. 372)
  310. }
  311. var
  312. cmdline : pchar;
  313. begin
  314. cmdline:=GetCommandLine;
  315. argc:=0;
  316. while true do
  317. begin
  318. break;
  319. end;
  320. arg_buffer:=LocalAlloc(LMEM_FIXED,8);
  321. { call to the pascal main }
  322. asm
  323. call PASCALMAIN
  324. end;
  325. { that's all folks }
  326. LocalFree(arg_buffer);
  327. ExitProcess(0);
  328. end;
  329. procedure OpenStdIO(var f:text;mode:word;hdl:longint);
  330. begin
  331. Assign(f,'');
  332. TextRec(f).Handle:=hdl;
  333. TextRec(f).Mode:=mode;
  334. TextRec(f).InOutFunc:=@FileInOutFunc;
  335. TextRec(f).FlushFunc:=@FileInOutFunc;
  336. TextRec(f).Closefunc:=@fileclosefunc;
  337. end;
  338. {$PACKRECORDS 1}
  339. var
  340. s : string;
  341. StartupInfo : record
  342. cb : longint;
  343. lpReserved : Pointer;
  344. lpDesktop : Pointer;
  345. lpTitle : Pointer;
  346. dwX : longint;
  347. dwY : longint;
  348. dwXSize : longint;
  349. dwYSize : longint;
  350. dwXCountChars : longint;
  351. dwYCountChars : longint;
  352. dwFillAttribute : longint;
  353. dwFlags : longint;
  354. wShowWindow : Word;
  355. cbReserved2 : Word;
  356. lpReserved2 : Pointer;
  357. hStdInput : longint;
  358. hStdOutput : longint;
  359. hStdError : longint;
  360. end;
  361. {$PACKRECORDS NORMAL}
  362. begin
  363. { get some helpful informations }
  364. GetStartupInfo(@startupinfo);
  365. { Initialize ExitProc }
  366. ExitProc:=Nil;
  367. { to test stack depth }
  368. loweststack:=maxlongint;
  369. { Setup heap }
  370. {!!! InitHeap; }
  371. { Setup stdin, stdout and stderr }
  372. StdInputHandle:=longint(GetStdHandle(STD_INPUT_HANDLE));
  373. StdOutputHandle:=longint(GetStdHandle(STD_OUTPUT_HANDLE));
  374. StdErrorHandle:=longint(GetStdHandle(STD_ERROR_HANDLE));
  375. OpenStdIO(Input,fmInput,StdInputHandle);
  376. OpenStdIO(Output,fmOutput,StdOutputHandle);
  377. OpenStdIO(StdErr,fmOutput,StdErrorHandle);
  378. { Reset IO Error }
  379. InOutRes:=0;
  380. { some misc Win32 stuff }
  381. hprevinst:=0;
  382. getmodulefilename(0,@s,256);
  383. hinstance:=getmodulehandle(@s);
  384. cmdshow:=startupinfo.wshowwindow;
  385. end.
  386. {
  387. $Log$
  388. Revision 1.2 1998-03-27 00:50:22 peter
  389. * small fixes so it compiles
  390. Revision 1.1.1.1 1998/03/25 11:18:47 root
  391. * Restored version
  392. Revision 1.13 1998/03/05 22:37:36 florian
  393. * some stuff added
  394. Revision 1.12 1998/01/26 12:02:28 michael
  395. + Added log at the end
  396. Working file: rtl/win32/syswin32.pp
  397. description:
  398. ----------------------------
  399. revision 1.11
  400. date: 1998/01/25 21:53:37; author: peter; state: Exp; lines: +415 -408
  401. + Universal Handles support for StdIn/StdOut/StdErr
  402. * Updated layout of sysamiga.pas
  403. ----------------------------
  404. revision 1.10
  405. date: 1998/01/16 22:22:59; author: michael; state: Exp; lines: +408 -544
  406. * Synchronised with other system files (Peter Vreman)
  407. ----------------------------
  408. revision 1.9
  409. date: 1998/01/07 00:04:55; author: michael; state: Exp; lines: +84 -124
  410. + Final adjustments for a uniform file handling interface.
  411. (From Peter Vreman)
  412. ----------------------------
  413. revision 1.8
  414. date: 1998/01/05 16:51:26; author: michael; state: Exp; lines: +18 -52
  415. + Moved init of heap to heap.inc: INITheap() (From Peter Vreman)
  416. ----------------------------
  417. revision 1.7
  418. date: 1997/12/19 11:47:08; author: florian; state: Exp; lines: +2 -2
  419. *** empty log message ***
  420. ----------------------------
  421. revision 1.6
  422. date: 1997/12/01 12:42:52; author: michael; state: Exp; lines: +12 -5
  423. + added copyright reference in header.
  424. ----------------------------
  425. revision 1.5
  426. date: 1997/11/27 23:04:10; author: florian; state: Exp; lines: +1 -13
  427. Old log entries to log-file added
  428. ----------------------------
  429. revision 1.4
  430. date: 1997/11/27 23:01:09; author: florian; state: Exp; lines: +8 -3
  431. This was a test
  432. ----------------------------
  433. revision 1.3
  434. date: 1997/11/27 22:49:06; author: florian; state: Exp; lines: +12 -9
  435. - CPU.PP added
  436. - some bugs in DOS fixed (espsecially for go32v1)
  437. - the win32 system unit is now compilable
  438. ----------------------------
  439. revision 1.2
  440. date: 1997/11/27 17:40:12; author: florian; state: Exp; lines: +8 -1
  441. Added log and id to syswin32.pp for test purposes
  442. ----------------------------
  443. revision 1.1
  444. date: 1997/11/27 10:15:33; author: florian; state: Exp;
  445. Win32 files added (they are untested)
  446. =============================================================================
  447. }