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

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+}