ian@unix.computer-science.manchester.ac.uk (Ian Cottam) (03/15/88)
Submitted-By: "Ian Cottam" <ian@unix.computer-science.manchester.ac.uk>
Archive-Name: pstrings
comp.sources.misc: Volume 2, Issue 75
Submitted-By: "Ian Cottam" <ian@unix.computer-science.manchester.ac.uk>
Archive-Name: pstrings
#! /bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #! /bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create the files:
# README
# strings.h
# CtoS.p
# assignS.p
# compare.p
# concatS.p
# disposeS.p
# emptyS.p
# eqS.p
# finalS.p
# first.p
# geS.p
# getsubS.p
# gtS.p
# indexS.p
# initS.p
# initvalparamS.p
# leS.p
# lengthS.p
# ltS.p
# matchS.p
# mk.p
# mkS.p
# mkStaticS.p
# neS.p
# newS.p
# next.p
# readS.p
# readtS.p
# repS.p
# updateS.p
# writeS.p
# writelnS.p
# Makefile
# This archive created: Tue Mar 15 10:11:49 1988
export PATH; PATH=/bin:$PATH
if test -f 'README'
then
echo shar: will not over-write existing file "'README'"
else
cat << \SHAR_EOF > 'README'
This is an Unbounded-length Strings package I wrote for our
first year undergrads to use some years ago. It is written in
and assumes you are using an ISO level 1 conforming Pascal
compiler. (If they come pretty close e.g. SUN Pascal then you
will be alright. N.B. Berkeley pc is NOT close enough -- at least
the version I have which is that with 4.3BSD.)
I have used the package with: SUN Pascal, VAX-VMS-Pascal, and York Pascal
(a UN*X/portable Pascal compiler) on VAX-UN*X.
See the strings.h header file for some implementation comments.
Where you put things like #include is, of course, compiler specific.
The distributed version should work on SUNs; other systems will require
you to make trivial (hopefully) mods. Even on SUNs you may have trouble
with erroneous complaints from /usr/lib/pc3 -- the separate compilation
checker -- about redefinitions. Personally, I don't bother with
/usr/lib/pc3.
Good luck
-Ian Cottam
Univ of Manchester, Dept of Comp Sci, Oxford Rd, Manchester
M13 9PL, UK, ian@ux.cs.man.ac.uk
SHAR_EOF
fi # end of overwriting check
if test -f 'strings.h'
then
echo shar: will not over-write existing file "'strings.h'"
else
cat << \SHAR_EOF > 'strings.h'
{
*
* String handling package in Pascal (ISO Level 1).
*
* This package of procedures and functions implements unbounded
* Strings of Characters.
*
* N.B. All string variables MUST be initialised via initS(s).
* Assignment MUST be via assignS(dest, src).
* If desired, storage may be reclaimed via finalS(s).
* i.e.
* var s,t: String;
* . . .
* initS(s); initS(t);
* . . .
* assignS(t, concatS(mkS('Join this string '), mkS('to this')));
* assignS(s, t);
* . . .
* finalS(s); finalS(t);
*
* Additionally, string by-value parameters must be initialised by calling
* initvalparamS(s).
* * e.g.
*
* procedure p(s:String);
* begin writelnS(output, concatS(s, concatS(s,s)))
* end;
*
* MUST be written as:
*
* procedure p(s:String);
* begin initvalparamS(s);
* writelnS(output, concatS(s, concatS(s,s)))
* end;
* (This is because the package performs incremental garbage collection
* on unassigned strings, but extant by-value references cannot be
* detected.)
*
*
*
* Implementation Issues:
*
* The representation is a header record containing a
* length field, a reference count, and a packed array [1..slength]
* of Char, followed by zero or more `tail' chunks - also
* containing a packed array [1..slength] of Char.
* The empty string is represented by nil. Beware of
* s1 := s2 this copies pointers (!) not the strings themselves.
* `:=' between strings should not be used; it cannot be banned
* because types inherit assignment in Pascal.
* The procedure assignS(dest, source)
* should be used to copy strings, it uses the reference count to
* avoid copying. Only if updateS is used will the string
* actually be copied (if the ref count is > 1).
*
* All the routines end with a capital S.
*
* Ian Cottam, University of Manchester, NOV.85. revised MAR.86 and DEC.86.
* revised MAR.88 - better names,
* plus use of initvalparamS.
}
{ -- string chunk length - any length > 0 will work }
const slength = 16;
type
String = ^ stringrec;
Nat0 = 0 .. maxint;
Nat1 = 1 .. maxint;
stringtail = ^ tailrec;
stringrec = record
LEN: Nat1; { -- Note: no 0 as nil represents '' }
REFS: Nat0; { -- How many refs are there to this string }
{ -- N.B. only = 0 when string generated by a function }
HEAD: packed array [1..slength] of Char;
TAIL: stringtail
end;
tailrec = record
MORE: packed array [1..slength] of Char;
REST: stringtail
end;
{ -- Result of compare - internal function to ADT }
StrCmpResult = (lt, eq, gt);
{ -- type for sequencing thru strings - internal to ADT at the moment}
CharOfString = record
POS: 1..slength;
case KIND: Boolean of
true: (HD: String);
false: (TL: stringtail)
end;
{************ function and procedure headings **************}
{ -- ... in Alphabetical order ... }
procedure assignS(var lhs: String; rhs: String);
{
* lhs := rhs
}
external;
{ ***** AUXILIARY FUNCTION ***** }
function compare(left, right:String):StrCmpResult;
{
* String comparison - used in the impl. of eqS, neS, ltS, etc.
}
external;
function concatS(s1, s2: String):String;
{
* Returns s1 + s2
* Concatenates s1 and s2.
}
external;
function CtoS(c: Char):String;
{
* Converts a character into a string of length 1
}
external;
procedure disposeS(var s: String);
{
* reclaims the storage associated with the string s
}
external;
function emptyS: String;
{
* Returns the empty or null string ''
}
external;
function eqS(left,right: String):Boolean;
{
* left = right
}
external;
procedure finalS(var s: String);
{
* same as disposeS but possibly better name
* reclaims the storage associated with the string s
}
external;
{ ***** AUXILIARY FUNCTION ***** }
procedure first(var c:CharOfString; var s: String);
{
* c initialised to point to the first char of s
*
* precondition
* s <> ''
}
external;
function geS(left,right: String):Boolean;
{
* left >= right
}
external;
function getsubS(s: String; frompos, topos: Nat0):String;
{
* Returns s[frompos..topos]
* Extracts a substring of s.
* returns '' if frompos..topos not in range.
}
external;
function gtS(left,right: String):Boolean;
{
* left > right
}
external;
function indexS(s: String; i: Nat1):Char;
{
* Returns s[i]
*
* precondition:
* i <= lengthS(s)
}
external;
procedure initS(var s: String);
{
* Initialises s to be the empty or null string ''
* Same as newS, but possibly less confusing name.
}
external;
procedure initvalparamS(var s: String);
{
* Initialises s, which should be a value parameter, to be
* safely useable within the current procedure.
}
external;
function leS(left,right: String):Boolean;
{
* left <= right
}
external;
function lengthS(s: String):Nat0;
{
* Returns the dynamic length of a string
}
external;
function ltS(left,right: String):Boolean;
{
* left < right
}
external;
function matchS(s, pat: String):Nat0;
{
* Returns position of pat in s or 0 if not present.
* Empty strings are not considered present!
}
external;
{ ***** AUXILIARY FUNCTION ***** }
function mk(var static: packed array [lo..hi:Integer] of Char;
limit: Integer):String;
{
* Converts a static Pascal string into a (dynamic) String.
* From lo to limit rather than hi.
* This internal procedure may be made generally available
* should there be a demand.
}
external;
function mkS(static: packed array [lo..hi:Integer] of Char):String;
{
* Converts a static Pascal string into a (dynamic) String.
}
external;
procedure mkStaticS(s: String; var p: packed array[lo..hi:Integer] of Char);
{
* Converts a dynamic string into a static string.
* p is null padded if necessary.
* Info will be lost if lengthS(s) > hi-lo+1.
}
external;
function neS(left,right: String):Boolean;
{
* left <> right
}
external;
procedure newS(var s: String);
{
* Initialises s to be the empty or null string ''
}
external;
{ ***** AUXILIARY FUNCTION ***** }
procedure next(var c: CharOfString; var ch: Char);
{
* c is advanced to point to next char in its string and current char
* returned in ch
*
* precondition
* c initialised by call to first and not at end of string
}
external;
procedure readS(var f: Text; var s: String);
{
* Reads a string from text file f; eoln terminating. The input is
* left pointing to the beginning of the next line, if any.
*
* precondition:
* f open for reading & not eof(f)
}
external;
procedure readtS(var f: Text; var s: String; function stop(c:Char):Boolean);
{
* Reads a string from text file f; eoln or stop(c) returning true
* (whichever occurs first) terminating. In either case,
* input is left positioned at the terminator.
*
* precondition:
* f open for reading & not eof(f)
}
external;
function repS(s: String; n: Nat0):String;
{
* Returns s * n
* Replicates s, n times.
}
external;
procedure updateS(var s: String; i: Nat1; c:Char);
{
* Updates the string s at position i with the char c.
* if i > lengthS(s), s is first space filled upto i-1.
}
external;
procedure writeS(var f: Text; s: String);
{
* Write the dynamic string s to file f
*
* precondition:
* f open for writing
}
external;
procedure writelnS(var f: Text; s: String);
{
* Write the dynamic string s to file f followed by an eoln marker
*
* precondition:
* f open for writing
}
external;
SHAR_EOF
fi # end of overwriting check
if test -f 'CtoS.p'
then
echo shar: will not over-write existing file "'CtoS.p'"
else
cat << \SHAR_EOF > 'CtoS.p'
# include "strings.h"
function CtoS{(c: Char):String};
{
* Converts a character into a string of length 1
}
var ss: packed array [1 .. 1] of Char;
begin
ss[1] := c;
CtoS := mkS(ss)
end{ -- CtoS};
SHAR_EOF
fi # end of overwriting check
if test -f 'assignS.p'
then
echo shar: will not over-write existing file "'assignS.p'"
else
cat << \SHAR_EOF > 'assignS.p'
# include "strings.h"
procedure assignS{(var lhs: String; rhs: String)};
{
* lhs := rhs
}
begin
if lhs <> rhs then begin { -- Care with case, e.g., assignS(x,x) }
disposeS(lhs);
if rhs = nil then { -- Empty string } lhs := nil
else begin
lhs := rhs; { -- Ref. copy }
with rhs^ do REFS := REFS+1
end
end
end{ -- assignS};
SHAR_EOF
fi # end of overwriting check
if test -f 'compare.p'
then
echo shar: will not over-write existing file "'compare.p'"
else
cat << \SHAR_EOF > 'compare.p'
# include "strings.h"
function compare{(left, right: String):StrCmpResult};
var lenl, lenr: Nat0; ltail, rtail: stringtail;
state: (GoOn, Less, Greater, Stop);
begin
lenl := lengthS(left); lenr := lengthS(right);
{ -- Do trivial cases first }
if lenl = 0 then
if lenr = 0 then compare := eq else compare := lt
else if lenr = 0 then compare := gt else begin
{ -- Non-trivial cases - both left and right are non empty }
ltail := left^.TAIL; rtail := right^.TAIL;
if left^.HEAD < right^.HEAD then state := Less else
if left^.HEAD > right^.HEAD then state := Greater else
if (ltail = nil) or (rtail = nil)
then state := Stop
else state := GoOn;
{ -- Check tails if necessary }
while state = GoOn do
if ltail^.MORE < rtail^.MORE then state := Less else
if ltail^.MORE > rtail^.MORE then state := Greater else
if (ltail^.REST = nil) or (rtail^.REST = nil)
then state := Stop
else
begin ltail := ltail^.REST; rtail := rtail^.REST end;
{ -- Final check for differing lengths (etc.) }
case state of
Less: compare := lt;
Greater: compare := gt;
Stop: if lenl < lenr then compare := lt else
if lenl > lenr then compare := gt
else compare := eq
end
end;
{ -- comparison may have involved constant strings }
if left <> nil then if left^.REFS = 0 then disposeS(left);
if right <> nil then if right^.REFS = 0 then disposeS(right)
end{ -- compare};
SHAR_EOF
fi # end of overwriting check
if test -f 'concatS.p'
then
echo shar: will not over-write existing file "'concatS.p'"
else
cat << \SHAR_EOF > 'concatS.p'
# include "strings.h"
function concatS{(s1, s2: String):String};
{
* Returns s1 + s2
* Concatenates s1 and s2.
}
var t: String; { -- Result is built in t }
l, r, End1: stringtail;
StillInHeadOfT, InTailOfT, InTailOfS2: Boolean;
i, j: Nat1;
tindx, rindx: 1..slength;
null: Char;
begin
t := nil;
null := chr(0);
{ -- Deal with trivial cases first }
if s1 = nil then concatS := s2 else
if s2 = nil then concatS := s1 else
{ -- Both s1 and s2 are non-empty }
begin
new(t);
with t^ do begin
LEN := s1^.LEN + s2^.LEN;
{ -- Copy head of s1 }
HEAD := s1^.HEAD;
TAIL := nil;
{ -- Allocate and link in any extra string chunks needed }
for i := 1 to (LEN-1) div slength do begin
new(l);
{ -- pad with nulls if chunk is last one }
if i=1 then
for j:=1 to slength do l^.MORE[j] := null;
l^.REST := TAIL;
TAIL := l
end;
{ -- Loop through copying string tail of s1, if required }
l := TAIL; End1 := TAIL; r := s1^.TAIL;
for i := 1 to (s1^.LEN-1) div slength do begin
l^.MORE := r^.MORE;
End1 := l;
l := l^.REST;
r := r^.REST
end;
{ -- End1 points to the last tail entry (partially) filled}
if s1^.LEN mod slength <> 0 then l := End1;
r := s2^.TAIL;
{ -- Loop thru copying s2 to end of t char by char! }
tindx := s1^.LEN mod slength + 1;
rindx := 1;
StillInHeadOfT := s1^.LEN < slength;
InTailOfT := false; InTailOfS2 := false;
for i := 1 to s2^.LEN do begin
if StillInHeadOfT then begin
HEAD[tindx] := s2^.HEAD[rindx];
StillInHeadOfT := tindx < slength
end
else
if i <= slength then begin
InTailOfT := true;
l^.MORE[tindx] := s2^.HEAD[rindx]
end
else begin
InTailOfS2 := true;
l^.MORE[tindx] := r^.MORE[rindx]
end;
{ -- Always inc indices and step down lists if req. }
tindx := tindx mod slength + 1;
if (tindx = 1) and InTailOfT then l := l^.REST;
rindx := rindx mod slength + 1;
if (rindx = 1) and InTailOfS2 then r := r^.REST
end
end{ -- with};
{ -- Make 0 ref count }
t^.REFS := 0;
{ -- Tidy up any intermediate storage }
if s1 <> nil then if s1^.REFS = 0 then disposeS(s1);
if s2 <> nil then if s2^.REFS = 0 then disposeS(s2);
concatS := t
end
end{ -- concatS};
SHAR_EOF
fi # end of overwriting check
if test -f 'disposeS.p'
then
echo shar: will not over-write existing file "'disposeS.p'"
else
cat << \SHAR_EOF > 'disposeS.p'
# include "strings.h"
procedure disposeS{(var s: String)};
{
* reclaims the storage associated with the string s
}
var t, next: stringtail;
begin
if s = nil then { -- Do nothing } else
if s^.REFS < 2 then begin { -- Only ref. to this string }
t := s^.TAIL;
dispose(s); s := nil; { -- emptyS }
while t <> nil do begin
next := t^.REST;
dispose(t);
t := next
end
end
else begin
{ -- Decrement the references count, and make s = the empty string }
with s^ do REFS := REFS-1;
s := nil
end
end{ -- disposeS};
SHAR_EOF
fi # end of overwriting check
if test -f 'emptyS.p'
then
echo shar: will not over-write existing file "'emptyS.p'"
else
cat << \SHAR_EOF > 'emptyS.p'
# include "strings.h"
function emptyS{: String};
{
* Returns the empty or null string ''
}
begin
emptyS := nil
end{ -- emptyS};
SHAR_EOF
fi # end of overwriting check
if test -f 'eqS.p'
then
echo shar: will not over-write existing file "'eqS.p'"
else
cat << \SHAR_EOF > 'eqS.p'
# include "strings.h"
function eqS{(left,right: String):Boolean};
{
* left = right
}
begin
eqS := compare(left, right) = eq
end{ -- eqS};
SHAR_EOF
fi # end of overwriting check
if test -f 'finalS.p'
then
echo shar: will not over-write existing file "'finalS.p'"
else
cat << \SHAR_EOF > 'finalS.p'
# include "strings.h"
procedure finalS{(var s: String)};
{
* reclaims the storage associated with the string s
}
begin
disposeS(s)
end{ -- finalS};
SHAR_EOF
fi # end of overwriting check
if test -f 'first.p'
then
echo shar: will not over-write existing file "'first.p'"
else
cat << \SHAR_EOF > 'first.p'
# include "strings.h"
procedure first{(var c:CharOfString; var s: String)};
{
* c initialised to point to the first char of s
*
* precondition
* s <> ''
}
begin
with c do begin
KIND := true; { -- head record }
HD := s;
POS := 1
end
end{ -- first};
SHAR_EOF
fi # end of overwriting check
if test -f 'geS.p'
then
echo shar: will not over-write existing file "'geS.p'"
else
cat << \SHAR_EOF > 'geS.p'
# include "strings.h"
function geS{(left,right: String):Boolean};
{
* left >= right
}
begin
geS := compare(left, right) <> lt
end{ -- geS};
SHAR_EOF
fi # end of overwriting check
if test -f 'getsubS.p'
then
echo shar: will not over-write existing file "'getsubS.p'"
else
cat << \SHAR_EOF > 'getsubS.p'
# include "strings.h"
function getsubS{(s: String; frompos, topos: Nat0):String};
{
* Returns s[frompos..topos]
* Extracts a substring of s.
* returns '' if frompos..topos not in range.
}
const BufferLength = 512;
var t: String; j,i, stoppos: Nat1; ch: Char; sp: CharOfString;
buf: packed array [1..BufferLength] of Char;
begin
t := nil; { -- empty string }
if topos <= lengthS(s) then begin
{ -- convert max(BufferLength) chars to fixed string }
if topos-frompos+1 > BufferLength then
stoppos := frompos+BufferLength-1
else
stoppos := topos;
j := 1;
first(sp, s);
for i := 1 to frompos-1 do next(sp, ch);
for i := frompos to stoppos do begin
next(sp, ch);
buf[j] := ch;
j := j+1
end{ -- for};
{ -- convert to String }
if j <> 1 then { -- positive slice }
t := mk(buf, j-1);
{ -- check any more left }
if topos <> stoppos then
t := concatS(t, getsubS(s, stoppos+1, topos))
end;
if s <> nil then if s^.REFS = 0 then disposeS(s);
getsubS := t
end{ -- getsubS};
SHAR_EOF
fi # end of overwriting check
if test -f 'gtS.p'
then
echo shar: will not over-write existing file "'gtS.p'"
else
cat << \SHAR_EOF > 'gtS.p'
# include "strings.h"
function gtS{(left,right: String):Boolean};
{
* left > right
}
begin
gtS := compare(left, right) = gt
end{ -- gtS};
SHAR_EOF
fi # end of overwriting check
if test -f 'indexS.p'
then
echo shar: will not over-write existing file "'indexS.p'"
else
cat << \SHAR_EOF > 'indexS.p'
# include "strings.h"
function indexS{(s: String; i: Nat1):Char};
{
* Returns s[i]
*
* precondition:
* i <= lengthS(s)
}
var j: 2..maxint; chunk: stringtail;
begin
with s^ do
if i <= slength then indexS := HEAD[i]
else begin
chunk := TAIL;
for j := 2 to (i-1) div slength do chunk := chunk^.REST;
indexS := chunk^.MORE[ (i-1) mod slength + 1 ]
end
end{ -- indexS};
SHAR_EOF
fi # end of overwriting check
if test -f 'initS.p'
then
echo shar: will not over-write existing file "'initS.p'"
else
cat << \SHAR_EOF > 'initS.p'
# include "strings.h"
procedure initS{(var s: String)};
{
* Initialises s to be the empty or null string ''
* This is a copy of newS for those people that prefer the name initS!
}
begin
s := nil
end{ -- initS};
SHAR_EOF
fi # end of overwriting check
if test -f 'initvalparamS.p'
then
echo shar: will not over-write existing file "'initvalparamS.p'"
else
cat << \SHAR_EOF > 'initvalparamS.p'
# include "strings.h"
procedure initvalparamS{(var s: String)};
{
* Initialises s, which should be a value parameter, to be
* safely useable within the current procedure.
*
* increase ref count for a by-value param
}
begin
s^.REFS := s^.REFS + 1
end{ -- initvalparamS};
SHAR_EOF
fi # end of overwriting check
if test -f 'leS.p'
then
echo shar: will not over-write existing file "'leS.p'"
else
cat << \SHAR_EOF > 'leS.p'
# include "strings.h"
function leS{(left,right: String):Boolean};
{
* left <= right
}
begin
leS := compare(left, right) <> gt
end{ -- leS};
SHAR_EOF
fi # end of overwriting check
if test -f 'lengthS.p'
then
echo shar: will not over-write existing file "'lengthS.p'"
else
cat << \SHAR_EOF > 'lengthS.p'
# include "strings.h"
function lengthS{(s: String):Nat0};
{
* Returns the dynamic length of a string
}
begin
if s = nil then lengthS := 0 else lengthS := s^.LEN
end{ -- lengthS};
SHAR_EOF
fi # end of overwriting check
if test -f 'ltS.p'
then
echo shar: will not over-write existing file "'ltS.p'"
else
cat << \SHAR_EOF > 'ltS.p'
# include "strings.h"
function ltS{(left,right: String):Boolean};
{
* left < right
}
begin
ltS := compare(left, right) = lt
end{ -- ltS};
SHAR_EOF
fi # end of overwriting check
if test -f 'matchS.p'
then
echo shar: will not over-write existing file "'matchS.p'"
else
cat << \SHAR_EOF > 'matchS.p'
# include "strings.h"
function matchS{(s, pat: String):Nat0};
{
* Returns position of pat in s or 0 if not present.
* Empty strings are not considered present!
}
var diff, lens, lenp, start, next: Nat0; nomatch: Boolean;
begin
lens := lengthS(s); lenp := lengthS(pat);
if (lens = 0) or (lenp = 0) or (lenp > lens) then
matchS := 0
else begin
start := 0;
diff := lens - lenp;
repeat
start := start+1;
next := 0;
repeat
next := next+1;
nomatch := indexS(pat, next) <> indexS(s, start+next-1)
until nomatch or (next = lenp);
until not nomatch or (start > diff);
if nomatch then matchS := 0 else matchS := start
end;
{ -- possible that function called with constant string for pat }
if pat <> nil then if pat^.REFS = 0 then disposeS(pat)
end{ -- matchS};
SHAR_EOF
fi # end of overwriting check
if test -f 'mk.p'
then
echo shar: will not over-write existing file "'mk.p'"
else
cat << \SHAR_EOF > 'mk.p'
# include "strings.h"
function mk{(var static: packed array [lo..hi:Integer] of Char; limit: Integer):String};
{
* Converts a static Pascal string into a (dynamic) String.
* From lo to limit rather than hi.
* This internal procedure may be made generally available
* should there be a demand.
}
var null: Char;
StaticLength: Nat1;
i, ExtraChunks, CurrentLength: Nat0;
StringHead: String;
temp: stringtail;
k: Integer;
j: 1..slength;
begin
null := chr(0);
StaticLength := limit-lo+1;
ExtraChunks := (StaticLength-1) div slength;
{ -- Copy into String head }
new(StringHead);
with StringHead^ do begin
LEN := StaticLength;
REFS := 0;
TAIL := nil;
k := lo;
{ -- Copy string, null padding if necessary }
for j := 1 to slength do
if j > StaticLength
then HEAD[j] := null
else begin
HEAD[j] := static[k];
k := k+1
end;
{ -- Allocate and link in any extra string chunks needed}
for i := 1 to ExtraChunks do begin
new(temp); temp^.REST := TAIL; TAIL := temp
end;
{ -- Loop through copying string tail if required }
temp := TAIL;
CurrentLength := 0;
while temp <> nil do begin
with temp^ do begin
CurrentLength := CurrentLength+slength;
{ -- Copy string, null padding if necessary }
for j := 1 to slength do
if j+CurrentLength > StaticLength
then MORE[j] := null
else begin
MORE[j] := static[k];
k := k+1
end
end;
temp := temp^.REST
end{ -- while}
end{ -- with};
{ -- Return the newly created dynamic string }
mk := StringHead
end{ -- mk};
SHAR_EOF
fi # end of overwriting check
if test -f 'mkS.p'
then
echo shar: will not over-write existing file "'mkS.p'"
else
cat << \SHAR_EOF > 'mkS.p'
# include "strings.h"
function mkS{(static: packed array[lo..hi:Integer]of Char):String};
{
* Converts a static Pascal string into a (dynamic) String.
}
begin
mkS := mk(static, hi)
end{ -- mkS};
SHAR_EOF
fi # end of overwriting check
if test -f 'mkStaticS.p'
then
echo shar: will not over-write existing file "'mkStaticS.p'"
else
cat << \SHAR_EOF > 'mkStaticS.p'
# include "strings.h"
procedure mkStaticS{(s: String; var p: packed array[lo..hi:Integer] of Char)};
{
* Converts a dynamic string into a static string.
* p is null padded if necessary.
* Info will be lost if lengthS(s) > hi-lo+1.
}
var i: Integer; j: Nat1; lens: Nat0; ch,null: Char; sp: CharOfString;
begin
j := 1; lens := lengthS(s); null := chr(0);
if lens <> 0 then
first(sp, s);
for i := lo to hi do
if j <= lens then begin
next(sp, ch);
p[i] := ch;
j := j+1
end
else
p[i] := null
end{ -- mkStaticS};
SHAR_EOF
fi # end of overwriting check
if test -f 'neS.p'
then
echo shar: will not over-write existing file "'neS.p'"
else
cat << \SHAR_EOF > 'neS.p'
# include "strings.h"
function neS{(left,right: String):Boolean};
{
* left <> right
}
begin
neS := compare(left, right) <> eq
end{ -- neS};
SHAR_EOF
fi # end of overwriting check
if test -f 'newS.p'
then
echo shar: will not over-write existing file "'newS.p'"
else
cat << \SHAR_EOF > 'newS.p'
# include "strings.h"
procedure newS{(var s: String)};
{
* Initialises s to be the empty or null string ''
}
begin
s := nil
end{ -- newS};
SHAR_EOF
fi # end of overwriting check
if test -f 'next.p'
then
echo shar: will not over-write existing file "'next.p'"
else
cat << \SHAR_EOF > 'next.p'
# include "strings.h"
procedure next{(var c: CharOfString; var ch: Char)};
{
* c is advanced to point to next char in its string and current char
* returned in ch
*
* precondition
* c initialised by call to first and not at end of string
}
var nxtchunk: stringtail;
begin
with c do
case KIND of
true: begin { -- header record }
ch := HD^.HEAD[POS];
if POS <> slength then
POS := POS+1
else begin
POS := 1;
nxtchunk := HD^.TAIL;
{ -- change variant }
KIND := false;
TL := nxtchunk
end
end;
false: begin { -- tail record }
ch := TL^.MORE[POS];
if POS <> slength then
POS := POS+1
else begin
POS := 1;
TL := TL^.REST
end
end
end{ -- case}
end;
SHAR_EOF
fi # end of overwriting check
if test -f 'readS.p'
then
echo shar: will not over-write existing file "'readS.p'"
else
cat << \SHAR_EOF > 'readS.p'
# include "strings.h"
procedure readS{(var f: Text; var s: String)};
{
* Reads a string from text file f; eoln terminating. The input is
* left pointing to the beginning of the next line, if any.
*
* precondition:
* f open for reading & not eof(f)
}
const BufferLength = 120;
var t : String;
i : Nat0;
line : packed array [1..BufferLength] of Char;
begin
i := 0;
while not eoln(f) and (i <> BufferLength) do begin
i := i+1;
read(f, line[i])
end;
if i = 0 then assignS(s, nil) else assignS(s, mk(line, i));
{ -- Check for more characters on the input line }
if (i = BufferLength) and not eoln(f) then begin
{ -- Get the rest }
t := nil;
readS(f, t);
assignS(s, concatS(s, t))
end;
if eoln(f) then get(f)
end{ -- readS};
SHAR_EOF
fi # end of overwriting check
if test -f 'readtS.p'
then
echo shar: will not over-write existing file "'readtS.p'"
else
cat << \SHAR_EOF > 'readtS.p'
# include "strings.h"
procedure readtS{(var f: Text; var s: String; function stop(c:Char):Boolean)};
{
* Reads a string from text file f; eoln or stop(c) returning true
* (whichever occurs first) terminating. In either case,
* input is left positioned at the terminator.
*
* precondition:
* f open for reading & not eof(f)
}
const BufferLength = 120;
var t : String;
i : Nat0;
line : packed array [1..BufferLength] of Char;
begin
i := 0;
while not eoln(f) and (i <> BufferLength) and not stop(f^) do begin
i := i+1;
read(f, line[i])
end;
if i = 0 then assignS(s, nil) else assignS(s, mk(line, i));
{ -- Check for more characters on the input line }
if (i = BufferLength) and not stop(f^) and not eoln(f) then begin
{ -- Get the rest }
t := nil;
readS(f, t);
assignS(s, concatS(s, t))
end
end{ -- readtS};
SHAR_EOF
fi # end of overwriting check
if test -f 'repS.p'
then
echo shar: will not over-write existing file "'repS.p'"
else
cat << \SHAR_EOF > 'repS.p'
# include "strings.h"
function repS{(s: String; n: Nat0):String};
{
* [[ Returns s * n ]]
* Replicates s, n times.
}
var null, ChFromS: Char;
lens, StaticLength: Nat0;
i, ExtraChunks, CurrentLength: Nat0;
StringHead: String;
temp: stringtail;
k: Integer;
j: 1..slength;
sp: CharOfString;
begin
null := chr(0); lens := lengthS(s); StaticLength := lens*n;
if StaticLength = 0 then repS := nil { -- emptyS} else begin
ExtraChunks := (StaticLength-1) div slength;
{ -- Copy into String head }
new(StringHead);
with StringHead^ do begin
LEN := StaticLength;
REFS := 0;
TAIL := nil;
first(sp, s); k := 1;
{ -- Copy string, null padding if necessary }
for j := 1 to slength do
if j > StaticLength
then HEAD[j] := null
else begin
next(sp, ChFromS);
if k = lens then begin
k := 1; first(sp, s)
end else
k := k+1;
HEAD[j] := ChFromS
end;
{ -- Allocate and link in any extra string chunks needed}
for i := 1 to ExtraChunks do begin
new(temp); temp^.REST := TAIL; TAIL := temp
end;
{ -- Loop through copying string tail if required }
temp := TAIL;
CurrentLength := 0;
while temp <> nil do begin
with temp^ do begin
CurrentLength := CurrentLength+slength;
{ -- Copy string, null padding if necessary }
for j := 1 to slength do
if j+CurrentLength > StaticLength
then MORE[j] := null
else begin
next(sp, ChFromS);
if k = lens then begin
k := 1; first(sp, s)
end else
k := k+1;
MORE[j] := ChFromS
end
end;
temp := temp^.REST
end{ -- while};
end{ -- with};
{ -- Return the newly created dynamic string }
repS := StringHead
end;
if s <> nil then if s^.REFS = 0 then disposeS(s);
end{ -- repS};
SHAR_EOF
fi # end of overwriting check
if test -f 'updateS.p'
then
echo shar: will not over-write existing file "'updateS.p'"
else
cat << \SHAR_EOF > 'updateS.p'
# include "strings.h"
procedure updateS{(var s: String; i: Nat1; c:Char)};
{
* Updates the string s at position i with the char c.
* if i > lengthS(s), s is first space filled upto i-1.
}
var j: 2..maxint;
chunk: stringtail;
procedure copy(var lhs: String; rhs: String);
{
* lhs := rhs (forces a string copy)
}
var ExtraChunks: Nat0; i: Nat1; temp, l, r: stringtail;
begin
new(lhs);
{ -- Copy string head }
lhs^ := rhs^;
with lhs^ do begin
REFS := 1;
ExtraChunks := (rhs^.LEN-1) div slength;
TAIL := nil;
{ -- Allocate and link in any extra string chunks needed }
for i := 1 to ExtraChunks do begin
new(temp); temp^.REST := TAIL; TAIL := temp
end
end;
{ -- Loop through copying string tail if required }
l := lhs^.TAIL; r := rhs^.TAIL;
for i := 1 to ExtraChunks do begin
l^.MORE := r^.MORE;
l := l^.REST;
r := r^.REST
end
end{ -- copy};
begin { -- of updateS }
if s <> nil then
with s^ do
if REFS > 1 then begin
{ -- Make a unique copy before update }
REFS := REFS-1;
copy(s, s) { -- N.B. careful (!) use of var and value params. }
end;
if i <= lengthS(s) then
with s^ do
if i <= slength
then { -- pos is in string head } HEAD[i] := c
else begin
{ -- find tail chunk containing pos. i }
chunk := TAIL;
for j := 2 to (i-1) div slength do
chunk := chunk^.REST;
chunk^.MORE[ (i-1) mod slength + 1 ] := c
end
else { -- Inefficient but rare case }
assignS(s, concatS(s,concatS(repS(CtoS(' '),i-lengthS(s)-1),CtoS(c))))
end{ -- updateS};
SHAR_EOF
fi # end of overwriting check
if test -f 'writeS.p'
then
echo shar: will not over-write existing file "'writeS.p'"
else
cat << \SHAR_EOF > 'writeS.p'
# include "strings.h"
procedure writeS{var f: Text; s: String)};
{
* Write the dynamic string s to file f
*
* precondition:
* f open for writing
}
var temp: stringtail;
i, Currentlength: Nat1; ExtraChunks: Nat0;
begin
if s = nil then { -- Do nothing if string = '' }
else begin
with s^ do begin
ExtraChunks := (LEN-1) div slength;
if LEN > slength then
CurrentLength := slength
else
CurrentLength := LEN;
write(f, HEAD:CurrentLength);
temp := TAIL;
{ -- Output any tail chunks }
for i := 1 to ExtraChunks do with temp^ do
if i <> ExtraChunks then begin
write(f, MORE);
temp := REST
end else
if LEN mod slength <> 0 then
write(f, MORE:(LEN mod slength))
else
write(f, MORE)
end;
{ -- may have been asked to output a constant string }
if s^.REFS = 0 then disposeS(s)
end
end{ -- writeS};
SHAR_EOF
fi # end of overwriting check
if test -f 'writelnS.p'
then
echo shar: will not over-write existing file "'writelnS.p'"
else
cat << \SHAR_EOF > 'writelnS.p'
# include "strings.h"
procedure writelnS{(var f: Text; s: String)};
{
* Write the dynamic string s to file f followed by an eoln marker
*
* precondition:
* f open for writing
}
begin
writeS(f, s);
writeln(f)
end{ -- writelnS};
SHAR_EOF
fi # end of overwriting check
if test -f 'Makefile'
then
echo shar: will not over-write existing file "'Makefile'"
else
cat << \SHAR_EOF > 'Makefile'
PFLAGS=-O -L
OBJ= initvalparamS.o finalS.o initS.o mk.o mkS.o CtoS.o writeS.o emptyS.o lengthS.o writelnS.o assignS.o repS.o concatS.o disposeS.o readtS.o readS.o indexS.o getsubS.o mkStaticS.o matchS.o updateS.o compare.o eqS.o\
neS.o ltS.o \
first.o next.o gtS.o leS.o geS.o newS.o
strings.a: strings.h ${OBJ}
ar ruv strings.a ${OBJ}
ranlib strings.a
${OBJ}: strings.h
SHAR_EOF
fi # end of overwriting check
# End of shell archive
exit 0
----- End Forwarded Message -----