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}

    procedure halt(errnum : byte);

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

    function paramcount : longint;

      var
         count : longint;
         cmdline : pchar;
         quote : set of char;

      begin
         cmdline:=GetCommandLine;
         count:=0;
         while true do
           begin
              { skip leading spaces }
              while cmdline^ in [' ',#9] do
                cmdline:=cmdline+1;
              if cmdline^='"' then
                begin
                   quote:=['"'];
                   cmdline:=cmdline+1;
                end
              else
		quote:=[' ',#9];
              if cmdline^=#0 then
                break;
              inc(count);
              while (cmdline^<>#0) and not(cmdline^ in quote) do
                cmdline:=cmdline+1;
              { skip quote }
              if cmdline^ in quote then
                cmdline:=cmdline+1;
           end;
         paramcount:=count-1;
      end;

    function paramstr(l : longint) : string;

      var
         s : string;
         count : longint;
         cmdline : pchar;
         quote : set of char;

      begin
         s:='';
         if (l>=0) and (l<=paramcount) then
           begin
              cmdline:=GetCommandLine;
              count:=0;
              while true do
                begin
                   { skip leading spaces }
                   while cmdline^ in [' ',#9] do
                     cmdline:=cmdline+1;
                   if cmdline^='"' then
                     begin
                        quote:=['"'];
                        cmdline:=cmdline+1;
                     end
                   else
		     quote:=[' ',#9];
                   if cmdline^=#0 then
                     break;
                   if count=l then
                     begin
                        while (cmdline^<>#0) and not(cmdline^ in quote) do
                          begin
                             s:=s+cmdline^;
                             cmdline:=cmdline+1;
                          end;
                        break;
                     end
                   else
                     begin
                        while (cmdline^<>#0) and not(cmdline^ in quote) do
                          cmdline:=cmdline+1;
                     end;
                   { skip quote }
                   if cmdline^ in quote then
                     cmdline:=cmdline+1;
                   inc(count);
                end;

           end;
         paramstr:=s;
      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'];

begin
   { call to the pascal main }
   asm
     call PASCALMAIN
   end;
   { that's all folks }
   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.5  1998-04-27 13:58:21  florian
    + paramstr/paramcount implemented

  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)
  =============================================================================
}