System.pas module

14 Aug 96 04:01:18 EDT

{ Created: 1996-07-26

System module for emulating the Borland Pascal System unit. This one
is specific for the GNU Extended Pascal implementation and provides a
System.Pas interface specifically to emulate the 16-bit Borland Pascal
compilers.

 
  Copyright (C) 1996     Berend de Boer 

  This program is free software; you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation; either version 2 of the License, or
  (at your option) any later version.

  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.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with this program; if not, write to the Free Software
  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.


Notes:
- This one has hardcoded errorcodes!! It probably does not work on every
  machine. One really need to convert errno.h and stat.h first to make
  it portable. But I'll do that when I complete the Extended Pascal
  Posix interface for GNU Pascal.
- assumes all Extended Pascal compilers have the local addition to
  provide an additional parameter to the Halt procedure.
- certain procedures are almost untranslatable as Addr, Move and Str. They are
  therefore not translated, but require a change to the source code
- there is no Assign or Close procedure for a file type variable, only for a
  text type variable.
 - Rename does not work for some reason.


To do:
- Append
- FilePos
- FileSize
- Flush
- Rename
- Seek
- Truncate
 


$Date: 96-08-14 9:45 $
$Revision: 1 $

$Log: /Extended Pascal/Borland/GPC/system.pas $
 * 
 * 1     96-08-14 9:45 Berend
 * Borland Pascal's system unit for Extended Pascal, as far as applicable.

}

module System interface;

export
  System = (shortint, byte, word, longint, PChar, pointer, string255,
	    HeapError, ExitCode, PrefixSeg,
            Assign, BPChDir => ChDir, Close, Copy, Dec, Delete, Erase,
	    GetDir, GetMem,
	    Inc, IOResult,
	    MaxAvail, MemAvail, BPMkDir => MkDir,
            ParamCount, ParamStr,
	    BPRename => Rename, BPRmDir => RmDir,
	    UpCase);

type
  shortint = __byte__ integer;
  byte	   =  __byte__  integer;
  word	   =  __short__ integer;
  longint  = integer;
  TChar	   = array[0..MaxInt] of char;
  PChar	   = TChar;
  pointer  = void;
  string255= string(255);

var
  HeapError: pointer;   { Heap error function }
  {?ExitProc: Pointer;	{ Exit procedure }
  ExitCode: Integer;	{ Exit code }
  {?ErrorAddr: Pointer;	{ Runtime error address }
  PrefixSeg: Word;	{ Program segment prefix }  
  InOutRes : integer;   { I/O result buffer }


procedure Assign(var t: text; protected Name: string);
procedure BPChDir(protected s: string);
procedure Close(var t: text);
function  Copy(protected s: string; Index: integer; Count: integer): string255;
procedure Dec(var i: integer);
procedure Delete(var s: string255; Index: integer; Count: integer);
procedure Erase(var f: text);
procedure GetDir(D: byte; var s: string);
procedure Inc(var i : integer);
function  IOResult : integer;
function  MaxAvail: longint;
function  MemAvail : longint;
procedure BPMkDir(protected s: string);
function  ParamCount: word;
function  ParamStr(Index: word): string255;
procedure BPRename(var f: text; protected Newname: string);
procedure BPRmDir(protected s: string);
function  UpCase(Ch: char): char;


end.



module System implementation;

import
  StandardOutput;


{ support routines }

const
  MaxPath = 4096;
type
  TPath = array[0..MaxPath] of char;

function StrPas(Str: PChar): String255;
var
  i: integer;
  s: string255;
begin
  i := 0;
  s := '';
  while Str[i] <> Chr(0) do  begin
    s := s + Str[i];
    i := i + 1;
  end;
  StrPas := s;
end; { StrPas }

function unlink(path: __cstring__): integer; c;

function chdir(path: __cstring__): integer; c;

function getcwd(var buf: TPath; size: integer): PChar; c;

function mkdir(path: __cstring__; mode: integer): integer; c;

function _p_paramcount: integer; c;

function _p_paramstr(num: integer; var str: string): Boolean; c;

function rename(old: __cstring__; new: __cstring__): integer; c;

function rmdir(path: __cstring__): integer; c;


function MapUnixErrorToDosError(ErrorOccured: integer): integer;
const
  EPERM	      = 1;	{ Not super-user }
  ENOENT      = 2;      { No such file or directory }
  EACCES      = 13;     { Permission denied }
  EBUSY	      = 16;     { Mount device busy }
  EEXIST      = 17;     { File exists }			 
  ENOTDIR     = 20;     { Not a directory }
  ENOSPC      = 28;     { No space left on device }
  EROFS	      = 30;	{ Read only file system }
  EMLINK      = 31;	{ Too many links }	 
  ENAMETOOLONG= 91;     { File or path name too long }
var
  Result: integer;
  UnixError: integer;
begin
  if ErrorOccured
    then  begin
      UnixError := EACCES;  { should be errno... }
      case UnixError of
	ENOENT  : Result := 2;
	ENOTDIR : Result := 3;     
	EPERM,
	EACCES,
	EEXIST,
	ENOSPC,
	EROFS,
	EMLINK,
	ENAMETOOLONG: Result := 5;
	EBUSY   : Result := 152;
	otherwise
	Result  := UnixError;
      end; { case }
    end
    else  begin
      Result := 0;
    end;
  MapUnixErrorToDosError := Result;
end; { MapUnixErrorToDosError }


{ the system routines itself }

procedure Assign;
var
  b : BindingType;
begin
  unbind(t);
  b := binding(t);
  b.Name := Name;
  bind(t, b);
  b := binding(t);
end;


procedure BPChDir(s: string);
begin
  InOutRes := MapUnixErrorToDosError(chdir(s));
end; { ChDir }


procedure Close;
begin
  unbind(t);
end;


function Copy;
begin
  if Index+Count > length(s)
   then  Copy := SubStr(s, Index)
   else  Copy := SubStr(s, Index, Count);
end;


procedure Dec;
begin
  i := i - 1;
end;


procedure Delete;
begin
  if Index = 1
   then  begin
     if 1+Count > length(s)
      then  s := ''
      else  s := s[1+Count..length(s)];
   end
   else  begin
     if Index+Count > length(s)
      then  s := s[1..Index-1]
      else  s := s[1..Index-1] + SubStr(s, Index+Count);
   end;
end;


procedure Erase;
var
  bt: BindingType;
begin
  bt := Binding(f);
  unbind(f);
  InOutRes := MapUnixErrorToDosError(unlink(bt.name));
end;


procedure GetDir(D: byte; var s: string);
var
  Buffer: TPath;
  pc: PChar;
  i: integer;
begin
  pc := getcwd(Buffer, MaxPath);
  s := '';
  i := 0;
  while pc[i] <> Chr(0) do  begin
    s := s + pc[i];
    i := i + 1;
  end;
  { call to StrPas does not work????
  s := StrPas(pc);}
end; { GetDir }



procedure Inc;
begin
  i := i + 1;
end;


function IOResult : integer;
begin
  IOResult := InOutRes;
  InOutRes := 0;
end;


function MaxAvail;
begin
  MaxAvail := MaxInt;
end;


function MemAvail;
begin
  MemAvail := MaxInt;
end;


procedure BPMkDir;
begin
  InOutRes := MapUnixErrorToDosError(mkdir(s, 8#0700));
end; { BPMkDir }


function ParamCount;
begin
  ParamCount := _p_paramcount - 1;
end; { ParamCount }


function ParamStr;
var
  Str	 : string255;
  Success: Boolean;
begin
  Success := _p_paramstr(Index, Str);
  if Success
    then
      ParamStr := Str
    else
      ParamStr := '';
end; { ParamStr }


procedure BPRename;
var
  bt: BindingType;
begin
  bt := Binding(f);
  unbind(f);
  InOutRes := MapUnixErrorToDosError(rename(bt.name, Newname));
  bt.Name := Newname;
  bind(f, bt);  
end; { BPRename }


procedure BPRmDir;
begin
  InOutRes := MapUnixErrorToDosError(rmdir(s));
end; { RmDir }


function UpCase;
begin
  if Ch in ['a'..'z']
   then  UpCase := Chr(Ord('A') + (Ord(Ch) - Ord('a')))
   else  UpCase := Ch;
end;


{ we need an initialization section because gpc doesn't yet have
  initialized variables }

to begin do
begin
  {HeapError := nil;}
  InOutRes := 0;
end;

end.

Berend de Boer (100120.3121@CompuServe.COM)