{ 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 <berend(a)pobox.com>
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.