home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ftp.barnyard.co.uk
/
2015.02.ftp.barnyard.co.uk.tar
/
ftp.barnyard.co.uk
/
cpm
/
walnut-creek-CDROM
/
CPM
/
TURBOPAS
/
ENVIRON.LBR
/
STDUTIL.PZS
/
STDUTIL.PAS
Wrap
Pascal/Delphi Source File
|
2000-06-30
|
6KB
|
280 lines
{ standard utilities for Turbo Pascal, a la Kernighan and Plauger }
procedure halt;
{ halts program, returns to operating system }
begin
bdos(0);
end;
procedure error(s:string80);
{ writes msg., then halts }
{ may require macro implementation on some systems }
begin
writeln(s);
halt;
end;
function islower(c:character):boolean;
{ returns 'true' if c is lower case }
begin
islower := (chartbl[c]='L');
end;
function isupper(c:character):boolean;
{ returns 'true' if c is upper case }
begin
isupper := (chartbl[c]='U');
end;
function toupper(c:character):character;
{ converts a character to upper case }
begin
if islower(c) then toupper := c - CASEDIFF else toupper := c;
end;
function uc(c:character):character;
{ alias for toupper }
begin
uc := toupper(c);
end;
function tolower(c:character):character;
{ makes a character lower-case }
begin
if isupper(c) then tolower := c + CASEDIFF else tolower := c;
end;
function isletter(c:character):boolean;
{ returns 'true' if c is a letter }
begin
isletter := (chartbl[c] = 'L') or (chartbl[c] = 'U');
end;
function isdigit(c:character):boolean;
{ returns 'true' if c is a digit }
begin
isdigit := (chartbl[c] = 'D');
end;
function isalphanum(c:character):boolean;
{ returns 'true' if character is a number or a digit }
begin
isalphanum := chartbl[c] <> 'X';
end;
function max(x,y:integer):integer;
{ returns maximum of x and y }
begin
if x>y then max := x else max := y;
end;
function min(x,y:integer):integer;
{ returns minimum of x and y }
begin
if x<y then min := x else min := y;
end;
function slength(var s:textline):integer;
{ returns length of a string }
var
i,ls :integer;
begin
i := 1; ls := 0;
while (s[i]<>EOS) do begin ls := ls + 1; i:=i+1 end;
slength := ls;
end;
function addstr(c:character; var outset: textline;
var j:integer; maxset: integer):boolean;
{ add c to outset[j]; if it fits, increment j. }
begin
if (j>maxset) then
addstr := false
else
begin
outset[j] := c;
j := j + 1;
addstr := true;
end;
end;
function concat(var s1,s2:textline):boolean;
{ adds s2 to the end of s1, returns true if not overflow }
var
i,j :integer;
toomuch :boolean;
begin
i := slength(s1)+1; j:=1;
toomuch := false;
while (not toomuch) and (s2[j]<>EOS) do
begin
toomuch := not addstr(s2[j],s1,i,MAXSTR);
if not toomuch then j := j + 1;
end;
s1[i] := EOS;
concat := not toomuch;
end;
procedure setstring(var st:textline; ss:string80);
{ initializes string variable st to literal string ss }
{ this may require a macro implementation for some compilers }
var
i :integer;
begin
i := 1;
while i <= min(ord(ss[0]),MAXSTR) do
begin
st[i] := ord(ss[i]);
i := i + 1;
end;
st[i] := EOS;
end;
function makestring(var s:textline):string80;
{ converts our string format to native string format }
{ needed for implementation of some primitives, should not be called
by application programs }
var
i : integer;
ns :string80;
begin
ns := '';
i := 1;
while s[i] <> EOS do begin ns := ns + chr(s[i]); i := i + 1; end;
makestring := ns;
end;
function index(c:character; start:integer; var s:textline):integer;
{ searches for character c, starting at s[start] }
{ returns index at which s[index]=c, or 0 if c is not in s }
{ caution: may bomb if start not in 1..length(s) }
var
k :integer;
begin
k := start;
while not (s[k] in [c,EOS]) do
k := k + 1;
if s[k] = EOS then
index := 0
else
index := k;
end;
function skipsp(var s:textline;var i:integer):character;
{ skips spaces and tabs, returns 1st non-blank char. and index to it }
begin
while s[i] in [SPACE,TAB] do i:=i+1;
skipsp := s[i];
end;
procedure scopy(var src: textline; i :integer;
var dest: textline; j :integer);
{ copy string from src[i] to dest[j] until EOS }
begin
while src[i] <> EOS do
begin
dest[j] := src[i];
i := i + 1; j := j + 1;
end;
dest[j] := EOS;
end;
function equal(var s1,s2:textline):boolean;
{ test two strings for equality }
var
i :integer;
begin
i := 1;
while (s1[i] = s2[i]) and (s1[i] <> EOS) do
i := i + 1;
equal := s1[i] = s2[i];
end;
function ctoi(var s:textline; var i:integer):integer;
{ converts string at s[i] to integer, increments i to point past string }
var
n,sign :integer;
c :character;
begin
if skipsp(s,i) = minus then
sign := - 1
else
sign := + 1;
if s[i] in [PLUS,MINUS] then i := i + 1;
n := 0;
while isdigit(s[i]) do
begin
n := 10*n + s[i] - ord('0');
i := i + 1;
end;
ctoi := sign*n;
end;
{$a-}
function itoc(n:integer; var s:textline; i: integer): integer;
{ converts integer n to character string s[i], returns end of s }
begin
if (n<0) then
begin
s[i] := minus;
itoc := itoc(-n,s,i+1);
end
else
begin
if (n >= 10) then
i := itoc(n div 10,s,i);
s[i] := n mod 10 + ord('0');
s[i+1] := EOS;
itoc := i + 1;
end;
end;
{$a+}