System.pas module

{ 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@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.