freepascal.compiler/rtl/win32/syswin32.pp

{
    $Id$
    This file is part of the Free Pascal run time library.
    FPC Pascal system unit for the Win32 API.

    Copyright (c) 1993-98 by Florian Klaempfl and Pavel Ozerski
    member of the Free Pascal development team.

    See the file COPYING.FPC, included in this distribution,
    for details about the copyright.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

 **********************************************************************}
unit syswin32;

{$I os.inc}

  interface

    {$I systemh.inc}

    var
       hprevinst,hinstance,cmdshow : longint;
       heaperror : pointer;

    { $I heaph.inc}

const
  UnusedHandle    : longint = -1;
  StdInputHandle  : longint = 0;
  StdOutputHandle : longint = 0;
  StdErrorHandle  : longint = 0;

  implementation

    { some declarations for Win32 API calls }
    {$I Win32.inc}
    {$I system.inc}

    type
       plongint = ^longint;

{$ifdef dummy}
{$S-}
    procedure st1(stack_size : longint);[public,alias: 'STACKCHECK'];

      begin
         { called when trying to get local stack }
         { if the compiler directive $S is set   }
         { this function must preserve esi !!!!  }
         { because esi is set by the calling     }
         { proc for methods                      }
         { it must preserve all registers !!     }

         asm
            pushl %eax
            pushl %ebx
            movl stack_size,%ebx
            movl %esp,%eax
            subl %ebx,%eax
{$ifdef SYSTEMDEBUG}
            movl U_SYSTEM_LOWESTSTACK,%ebx
            cmpl %eax,%ebx
            jb   _is_not_lowest
            movl %eax,U_SYSTEM_LOWESTSTACK
            _is_not_lowest:
{$endif SYSTEMDEBUG}
            movl __stkbottom,%ebx
            cmpl %eax,%ebx
            jae  __short_on_stack
            popl %ebx
            popl %eax
            leave
            ret  $4
            __short_on_stack:
            { can be usefull for error recovery !! }
            popl %ebx
            popl %eax
         end['EAX','EBX'];
         RunError(202);
         { this needs a local variable }
         { so the function called itself !! }
         { Writeln('low in stack ');
         RunError(202);             }
      end;
{$endif dummy}
    var
       argc : longint;
       args : pointer;
       arg_buffer : pointer;

    procedure halt(errnum : byte);

      begin
         do_exit;
         flush(stderr);
         LocalFree(arg_buffer);
         ExitProcess(errnum);
      end;

    function paramcount : longint;

      begin
         paramcount:=argc-1;
      end;

    function paramstr(l : longint) : string;

      var
         p : ^pchar;

      begin
         if (l>=0) and (l<=paramcount) then
           begin
              p:=args;
              paramstr:=strpas(p[l]);
           end
         else paramstr:='';
      end;

    procedure randomize;

      begin
         randseed:=GetTickCount;
      end;

{$i winheap.inc}
{ $I heap.inc}

{****************************************************************************
                          Low Level File Routines
 ****************************************************************************}

    procedure AllowSlash(p:pchar);

      var
         i : longint;

      begin
         { allow slash as backslash }
         for i:=0 to strlen(p) do
           if p[i]='/' then p[i]:='\';
      end;

    procedure do_close(h : longint);

      begin
         closehandle(h);
      end;

    procedure do_erase(p : pchar);

      begin
         AllowSlash(p);
         if DeleteFile(p)=0 then
            inoutres:=GetLastError;
      end;

     procedure do_rename(p1,p2 : pchar);

       begin
          AllowSlash(p1);
          AllowSlash(p2);
          if MoveFile(p1,p2)=0 then
            inoutres:=GetLastError;
       end;

    function do_write(h,addr,len : longint) : longint;

      var
         size:longint;

      begin
         if writefile(h,pointer(addr),len,size,nil)=0 then
           inoutres:=GetLastError;
         do_write:=size;
      end;

function do_read(h,addr,len : longint) : longint;
 var
  result:longint;
 begin
  if readfile(h,pointer(addr),len,result,nil)=0 then
   inoutres:=GetLastError;
  do_read:=result;
 end;

function do_filepos(handle : longint) : longint;
 var
  l:longint;
 begin
  l:=SetFilePointer(handle,0,nil,1);
  if l=-1 then
   begin
    l:=0;
    inoutres:=GetLastError;
   end;
  do_filepos:=l;
 end;

procedure do_seek(handle,pos : longint);
begin
  if SetFilePointer(handle,pos,nil,0)=-1 then
   inoutres:=GetLastError;
end;

function do_seekend(handle:longint):longint;
begin
   {!!!!!!!!!!!!}
end;


function do_filesize(handle : longint) : longint;
var
   aktfilepos : longint;
begin
   aktfilepos:=do_filepos(handle);
   do_filesize:=do_seekend(handle);
   do_seek(handle,aktfilepos);
end;


procedure do_truncate (handle,pos:longint);
begin
  {!!!!!!!!!!!!}
end;

procedure do_open(var f;p:pchar;flags:longint);
{
  filerec and textrec have both handle and mode as the first items so
  they could use the same routine for opening/creating.
  when (flags and $10)   the file will be append
  when (flags and $100)  the file will be truncate/rewritten
  when (flags and $1000) there is no check for close (needed for textfiles)
}
begin
  AllowSlash(p);
  {!!!!!!!!!!!!}
end;

{*****************************************************************************
                           UnTyped File Handling
*****************************************************************************}

{$i file.inc}

{*****************************************************************************
                           Typed File Handling
*****************************************************************************}

{$i typefile.inc}

{*****************************************************************************
                           Text File Handling
*****************************************************************************}

{$DEFINE EOF_CTRLZ}

{$i text.inc}

{*****************************************************************************
                           Directory Handling
*****************************************************************************}

type
 TDirFnType=function(name:pointer):word;

procedure dirfn(afunc : TDirFnType;const s:string);
var
  buffer : array[0..255] of char;
begin
  move(s[1],buffer,length(s));
  buffer[length(s)]:=#0;
  AllowSlash(pchar(@buffer));
  if aFunc(@buffer)=0 then
   inoutres:=GetLastError;
end;

function CreateDirectoryTrunc(name:pointer):word;
 begin
  CreateDirectoryTrunc:=CreateDirectory(name,nil);
 end;

procedure mkdir(const s:string);[IOCHECK];
 begin
  dirfn(TDirFnType(@CreateDirectoryTrunc),s);
 end;

procedure rmdir(const s:string);[IOCHECK];
 begin
  dirfn(TDirFnType(@RemoveDirectory),s);
 end;

procedure chdir(const s:string);[IOCHECK];
 begin
  dirfn(TDirFnType(@SetCurrentDirectory),s);
 end;

procedure getdir(drivenr:byte;var dir:string);
 const
  Drive:array[0..3]of char=(#0,':',#0,#0);
 var
  defaultdrive:boolean;
  DirBuf,SaveBuf:array[0..259] of Char;
 begin
  defaultdrive:=drivenr=0;
  if not defaultdrive then
   begin
    byte(Drive[0]):=Drivenr+64;
    GetCurrentDirectory(SizeOf(SaveBuf),SaveBuf);
    SetCurrentDirectory(@Drive);
   end;
  GetCurrentDirectory(SizeOf(DirBuf),DirBuf);
  if not defaultdrive then
   SetCurrentDirectory(@SaveBuf);
  dir:=strpas(DirBuf);
 end;

{*****************************************************************************
                         SystemUnit Initialization
*****************************************************************************}

procedure Entry;[public,alias: '_mainCRTStartup'];
{
  the following procedure is written with the help of an article of
  the german computer magazine c't (3/97 p. 372)
}
var
   cmdline : pchar;
begin
   cmdline:=GetCommandLine;
   argc:=0;
   while true do
    begin
      break;
    end;
   arg_buffer:=LocalAlloc(LMEM_FIXED,8);
   { call to the pascal main }
   asm
     call PASCALMAIN
   end;
   { that's all folks }
   LocalFree(arg_buffer);
   ExitProcess(0);
end;


procedure OpenStdIO(var f:text;mode:word;hdl:longint);
begin
  Assign(f,'');
  TextRec(f).Handle:=hdl;
  TextRec(f).Mode:=mode;
  TextRec(f).InOutFunc:=@FileInOutFunc;
  TextRec(f).FlushFunc:=@FileInOutFunc;
  TextRec(f).Closefunc:=@fileclosefunc;
end;

{$PACKRECORDS 1}
var
 s : string;
 StartupInfo : record
    cb : longint;
    lpReserved : Pointer;
    lpDesktop : Pointer;
    lpTitle : Pointer;
    dwX : longint;
    dwY : longint;
    dwXSize : longint;
    dwYSize : longint;
    dwXCountChars : longint;
    dwYCountChars : longint;
    dwFillAttribute : longint;
    dwFlags : longint;
    wShowWindow : Word;
    cbReserved2 : Word;
    lpReserved2 : Pointer;
    hStdInput : longint;
    hStdOutput : longint;
    hStdError : longint;
 end;

{$PACKRECORDS NORMAL}

begin
{ get some helpful informations }
  GetStartupInfo(@startupinfo);
{ Initialize ExitProc }
  ExitProc:=Nil;
{ to test stack depth }
  loweststack:=maxlongint;
{ Setup heap }
{!!!  InitHeap; }
{ Setup stdin, stdout and stderr }
  StdInputHandle:=longint(GetStdHandle(STD_INPUT_HANDLE));
  StdOutputHandle:=longint(GetStdHandle(STD_OUTPUT_HANDLE));
  StdErrorHandle:=longint(GetStdHandle(STD_ERROR_HANDLE));
  OpenStdIO(Input,fmInput,StdInputHandle);
  OpenStdIO(Output,fmOutput,StdOutputHandle);
  OpenStdIO(StdErr,fmOutput,StdErrorHandle);
{ Reset IO Error }
  InOutRes:=0;
{ some misc Win32 stuff }
  hprevinst:=0;
  getmodulefilename(0,@s,256);
  hinstance:=getmodulehandle(@s);
  cmdshow:=startupinfo.wshowwindow;
end.

{
  $Log$
  Revision 1.4  1998-04-26 22:37:22  florian
    * some small extensions

  Revision 1.3  1998/04/26 21:49:57  florian
    + more stuff added (??dir procedures etc.)

  Revision 1.2  1998/03/27 00:50:22  peter
    * small fixes so it compiles

  Revision 1.1.1.1  1998/03/25 11:18:47  root
  * Restored version

  Revision 1.13  1998/03/05 22:37:36  florian
    * some stuff added

  Revision 1.12  1998/01/26 12:02:28  michael
  + Added log at the end

  Working file: rtl/win32/syswin32.pp
  description:
  ----------------------------
  revision 1.11
  date: 1998/01/25 21:53:37;  author: peter;  state: Exp;  lines: +415 -408
    + Universal Handles support for StdIn/StdOut/StdErr
    * Updated layout of sysamiga.pas
  ----------------------------
  revision 1.10
  date: 1998/01/16 22:22:59;  author: michael;  state: Exp;  lines: +408 -544
  * Synchronised with other system files (Peter Vreman)
  ----------------------------
  revision 1.9
  date: 1998/01/07 00:04:55;  author: michael;  state: Exp;  lines: +84 -124
  + Final adjustments  for a uniform file handling interface.
     (From Peter Vreman)
  ----------------------------
  revision 1.8
  date: 1998/01/05 16:51:26;  author: michael;  state: Exp;  lines: +18 -52
  + Moved init of heap to heap.inc: INITheap() (From Peter Vreman)
  ----------------------------
  revision 1.7
  date: 1997/12/19 11:47:08;  author: florian;  state: Exp;  lines: +2 -2
  *** empty log message ***
  ----------------------------
  revision 1.6
  date: 1997/12/01 12:42:52;  author: michael;  state: Exp;  lines: +12 -5
  + added copyright reference in header.
  ----------------------------
  revision 1.5
  date: 1997/11/27 23:04:10;  author: florian;  state: Exp;  lines: +1 -13
  Old log entries to log-file added
  ----------------------------
  revision 1.4
  date: 1997/11/27 23:01:09;  author: florian;  state: Exp;  lines: +8 -3
  This was a test
  ----------------------------
  revision 1.3
  date: 1997/11/27 22:49:06;  author: florian;  state: Exp;  lines: +12 -9
  - CPU.PP added
  - some bugs in DOS fixed (espsecially for go32v1)
  - the win32 system unit is now compilable
  ----------------------------
  revision 1.2
  date: 1997/11/27 17:40:12;  author: florian;  state: Exp;  lines: +8 -1
  Added log and id to syswin32.pp for test purposes
  ----------------------------
  revision 1.1
  date: 1997/11/27 10:15:33;  author: florian;  state: Exp;
  Win32 files added (they are untested)
  =============================================================================
}