Make your own free website on Tripod.com

adds` history: pascal string package (1990) 

. this is a string package I built while programming at EWU (1990) ;
file handling utilities type conversions (string -to- { char, char array, text file, int } functions)
Format operations (tabs vs spaces )

String -to- String functions


functions that operate on a Word

-- a word being a textual unit deefined as:<
(1) any string of non-space non-tab chars;
(2) any quoted string.


string -to- index-finding functions

-- finding the beginning or end off the next occurrence
going forwards or backwards
depending on whether parameter"Start is positive or negative

-- we supposedly used pascal in college
only because object-oriented programming hadn.t been invented yet;
but when I was introduced to it after starting out on microsoft`basica,
I thought it was the most beautiful language I'd ever seen
. my current idea of what beautiful is
can be found in -- what else ? the language I designed myself -- adda

{ v.platform addx, links, home, pkg"string}

  1. ADDX` history: pascal string package (1990) 

    1. types and subroutines specific to and shared among String modules
      1. {}{ " -- String functions that are dependent on string-heap's implementation. --" }
        1. {}{2} FUNCTION Rd( A, i:int ): char;
        2. {}{2} PROCEDURE Wr( A, i:int; ch:char );
        3. {}{2} FUNCTION Length(A:int ): int;
        4. {}{2} PROCEDURE SetLength( A, Length: int );
        5. {}{2} PROCEDURE OldStr( VAR C:int );
        6. {}{2} FUNCTION NewStr( VAR C:int ): boolean;
        7. {}{2} PROCEDURE InitStringHeap; VAR i: int;
      2. {}FUNCTION tabzone_index( length: int ): int;
      3. {}FUNCTION TabClass( length: int ): int;
      4. {}FUNCTION LenForLim( P1, P2 : int ): int;
      5. {} FUNCTION Range( VAR Start, Length: int; Limit: int ): boolean;
      6. {}FUNCTION RangeEO ( A : int ; VAR Start, Next, EO : int ): boolean ;
      7. {}PROCEDURE Mov ( Lay ,Start , SubLength , C , BedIndex : int );
        { v.platform addx, links, home, pkg"string}
    2. file handling utilities
      1. {}PROCEDURE InitStrFile ;
      2. {}FUNCTION GetFileName ( A, Start, DefaultName, DefaultType, C: int ): int;
      3. {}PROCEDURE OpenFile ( VAR f : text ; Physical : int; Writing : boolean );
      4. {}PROCEDURE message( VAR Outs : text; VAR f: intfile; msg: int );
      5. {}FUNCTION FoundNameDate ( VAR f : text ; C : int ) : int ;
      6. {}PROCEDURE ReadFile ( VAR Outs , Ins : text );
    3. String conversions (string -to- { char, char array, text file, int } functions)
      1. {}FUNCTION ReadStr( VAR f:text; C: int ): int; { -- Read to end of line. }
      2. {}PROCEDURE WriteStr( VAR f:text; A: int );
      3. {}FUNCTION Str32( A:String32; Length, C: int ): int;
      4. {}FUNCTION Str8( A:String8; Length, C: int ): int;
      5. {}FUNCTION IntStr( num, FieldSize, C: int ): int;
      6. {}FUNCTION CharStr( ch:char; C: int ): int;
      7. {}FUNCTION StrInt( A, Start : int ): int;
        { v.platform addx, links, home, pkg"string}
    4. String Format operations (tabs vs spaces )
      1. {}FUNCTION LengthDeSpaced( A: int ): int;
      2. {}FUNCTION DeSpace( A, C: int ): int;
      3. {}FUNCTION DeTab( A, C: int ): int;
        1. {}{2}PROCEDURE PerformDeTab;
      4. {}FUNCTION EnTab( A, C: int ): int;
        1. {}{2}PROCEDURE PerformEntab; {---length(A) > 0 }
          { v.platform addx, links, home, pkg"string}
    5. other String  operations ( String -to- String functions)
      1. {}FUNCTION EmbedSubCopy ( Lay, Start, SubLength, Bed, BedIndex, C: int ): int;
        1. {} {2}PROCEDURE Perform;
      2. {}FUNCTION Embed( Lay, Bed, BedIndex, C: int ): int;
      3. {}FUNCTION EmbedMasking ( Lay, Start, SubLength, Bed, C: int ): int;
      4. {}FUNCTION SubCopy( A, Start, SubLength, C: int ): int;
      5. {}FUNCTION Copy( A,C:int ): int;
      6. {} FUNCTION Delete ( A, Start , Len, C : int ) : int ;
      7. {} FUNCTION Insert ( A, InsertPtr, B, Start , Len, C : int ) : int ;
        1. {} {2} PROCEDURE CopyB;
      8. {}FUNCTION Fillin( A: int; ch: char; Start, FiLength, C: int ): int;
        1. {} {2} PROCEDURE FillinSizeSpecified;
        2. {} {2} PROCEDURE FieldSizeSpecified;
      9. {} FUNCTION LeftJustified( A:int; ch:char; FieldSize, C: int ): int;
      10. {}FUNCTION Spaces( Length, C: int ): int;
      11. {} FUNCTION Indent( A, IndentSize, C: int ): int;
        { v.platform addx, links, home, pkg"string}
    6. functions that operate on a Word
      1. {} FUNCTION WordLength ( Word : int ; Start : int ): int ;
      2. {}FUNCTION WordCopy( Word, Start, C: int ): int;
      3. {}FUNCTION ReadWord( VAR f:text; C: int ): int;
    7. string -to- index-finding functions
      1. {}FUNCTION IndexNonSpace( A, Start: int ): int;
      2. {}FUNCTION IndexSpace( A, Start: int ): int;
      3. {} FUNCTION IndexStr( Target, Domain, Start: int ): int;
        1. {} {2}PROCEDURE ForwardIndex ;
      4. {}FUNCTION IndexKeyed ( Target, Domain: int ): int;
      5. {}FUNCTION IndexChar( ch: char; A, Start: int ): int;
      6. {}FUNCTION IndexNextWord ( A , Start : int ): int;
    8. the test harness
      1. PROCEDURE Main;
        1. PROCEDURE pr( A: int );
{ v.platform addx, links, home, pkg"string}

types and subroutines specific to and shared among String modules

[ ENVIRONMENT ] (* NON-STD *)
{}{0} MODULE StrType ( input, output );
{


DOCUMENT NAME: StrType.PAS DATE: 1990.09.06 /08.24 /06.27

DESCRIPTION: Common types, and utility routines for all other Str Packages
InitStringHeap must be called by the application program before any other Str
routines are used. Temp and temp2 are available for temporary results.
OK is available to indicate fatal errors.

}
CONST
TabSize = 8 ;
StrNil = 0; Tab = ' '; Space = ' ' ; FormFeed = chr(12);
{Heap string count}Max = 256;
TYPE
int = integer;
String8 = PACKED ARRAY [ 1..8 ] OF char;
String32 = PACKED ARRAY [ 1..32 ] OF char;
String = PACKED ARRAY [ 0..255 ] OF char;
Str = ^String;
VAR
Warning, OK: boolean;
S : ARRAY[ 1..Max ] OF Str;
P: int; { --gives function a parameter without arguments so in CALL can be used in debug
--SET LANG PAS; DEP P:=
CALL Len. }
temp, temp2, { -- Spares to contain temporary results ( initing a local string is expensive ). }
Av: int; { --Points at the next available place in StringHeap for a new string. }
{ v.platform addx, links, home, pkg"string}

{}{ " -- String functions that are dependent on string-heap's implementation. --" }

{}{2} FUNCTION Rd( A, i:int ): char;

BEGIN Rd := S[ A ]^[ i ] END;

{}{2} PROCEDURE Wr( A, i:int; ch:char );

BEGIN S[ A ]^[ i ] := ch END;

{}{2} FUNCTION Length(A:int ): int;

BEGIN Length := ord( S[ A ]^[ 0 ] ) END;

{}{2} PROCEDURE SetLength( A, Length: int );

BEGIN S[ A ]^[ 0 ] := chr( Length ) END;
{ v.platform addx, links, home, pkg"string}

{}{2} PROCEDURE OldStr( VAR C:int );

VAR temp: Str; BEGIN temp := S[ C ]; dispose( temp ); S[ C ]:= NIL; C:= StrNil END;

{}{2} FUNCTION NewStr( VAR C:int ): boolean;

LABEL Top;
VAR temp: Str; Maxed: boolean;
{--This heap expects StringHeap components to be NIL if available.
For each call to NewStr, successive components are allocated, until Av is Maxed,
apon which NewStr looks for components that OldStr may have set to NIL. }
BEGIN
Maxed:= ( Av > Max ); OK:= false;
IF NOT Maxed THEN
OK := ( S[ Av ] = NIL );
Top:
IF NOT OK THEN BEGIN
IF Maxed THEN Av:= 0;
REPEAT Av:= Av+1;
OK:= ( S[ Av ] = NIL )
UNTIL NOT( Av < 256 ) OR OK END;
{--- NOT OK ==> searched from ( 1, or Av ) to Max and found no free heap space. }
IF NOT( OK OR Maxed ) THEN { --- NOT Maxed ==> it may not have started the check from the beginning, so...}
BEGIN Maxed:= true; GOTO Top END;
{--- NOT OK ==> searched from 1 to Max and found no free heap space. }
IF OK THEN BEGIN
new( temp ); S[ Av ]:= temp; C:= Av; SetLength( C, 0 );
Av:= Av +1; NewStr := true END
ELSE BEGIN
writeln( 'ERROR: string NewStr failed.' );
NewStr := false END
END;

{}{2} PROCEDURE InitStringHeap; VAR i: int;

BEGIN Warning := true; Av := 1; FOR i:= 1 TO Max DO s[i] := NIL;
OK := NewStr ( temp ) AND NewStr ( temp2 ) END;
{ v.platform addx, links, home, pkg"string}

{}FUNCTION tabzone_index( length: int ): int;

BEGIN 
tabzone_index:= length DIV TabSize END;

{}FUNCTION TabClass( length: int ): int;

BEGIN TabClass:= length MOD TabSize END;

{}FUNCTION LenForLim( P1, P2 : int ): int;

BEGIN LenForLim:= abs ( p1 - p2 ) +1 END;
{ v.platform addx, links, home, pkg"string}

{} FUNCTION Range( VAR Start, Length: int; Limit: int ): boolean;

{-- insures range doesn't exceed Limit, and that Length is positive with Start from left. }
VAR M
axindex, Trim: int;
BEGIN
Range:= NOT( Start = 0 );
IF Start < 0 THEN Start := -Start;
IF Length < 0 THEN BEGIN { -- Assume Start is indicating the right-most limit of the range. }
Start := Start +1 +Length; { -- Now Start indicates the Left-most limit. }
IF Start < 0 THEN Start := 1;
Length:= -Length END;
IF Start > Limit THEN
Length:= 0
ELSE BEGIN Maxindex:= Start -1 +Length; Trim:= Maxindex -Limit;
IF Trim > 0 THEN BEGIN
Length:= Length -Trim;
IF Warning THEN writeln( 'WARNING StrType Range: Overflow truncation.' ) END
END
END{ Range };
{ v.platform addx, links, home, pkg"string}

{}FUNCTION RangeEO ( A : int ; VAR Start, Next, EO : int ): boolean ;

{
DESCRIPTION: the caller will use Start, Next, and EO like so:
i := Start ; WHILE NOT i = EO DO ( Body; i := i + Next )
}

VAR LenA : int ;
BEGIN{ RangeEO }
LenA := Length(A); RangeEO := true ;

IF ( Start = 0 ) THEN BEGIN
RangeEO := false ; writeln( 'ERROR StrType RangeEO : start range. ' ) END
ELSE IF Start < 0 THEN BEGIN
Start := - Start ; Next := -1; EO := 0 END
ELSE BEGIN
Next := 1; EO := LenA +1
END{ if };
IF ( Start > LenA ) THEN BEGIN
Start := EO; IF Warning THEN writeln( 'WARNING StrType RangeEO : start range. ' ) END
END;{ RangeEO }
{ v.platform addx, links, home, pkg"string}

{}PROCEDURE Mov ( Lay ,Start , SubLength , C , BedIndex : int );

{
DESCRIPTION: moves a string between 2 possibly overlapping areas.
Doesn't calculate length, but Start and BedIndex may equal zero.
Kernel routine -- no type-checking.
-- an expensive block move:
FOR i:= Start TO Finish DO Wr( C, i+Cdif, Rd( A, i+Adif ));
could be replaced by this efficient assembly language algorithm:
PROCEDURE BlockMov( C, Cdif, A, Adif, Start, Finish: int );
VAR i, Cstr, Astr: int;
BEGIN
Astr := VAX_ADDRESS( StringHeap[ A ]^[ 1 + Adif ] );
Cstr := VAX_ADDRESS( StringHeap[ C ]^[ 1 + Cdif ] );
FOR i:= Start TO Finish DO
VAX_MOV( Astr+i, Cstr+i )
END;
}
VAR LayEnd , Shift , i , d : int ;
BEGIN{ Mov }
LayEnd := Start -1 + SubLength; Shift:= BedIndex -Start;
IF Shift > 0 THEN BEGIN d:= Shift + LayEnd ;
FOR i:= LayEnd DOWNTO Start DO BEGIN
Wr( C, d, Rd( Lay, i )); d:= d-1 END END
ELSE IF( Shift < 0 ) OR NOT( Lay=C ) THEN BEGIN d := BedIndex ; { ==> S<0 or ( S=0 and FreshLay ) }
FOR i:= Start TO LayEnd DO BEGIN
Wr( C, d, Rd( Lay, i )); d:= d+1 END
END{ else Shift=0 and Lay = C so do nothing. }
END;{ Mov }

END.{ MODULE StrType }

{ v.platform addx, links, home, pkg"string}

file handling utilities


[ ENVIRONMENT , INHERIT ( 'StrType.PEN', 'StrCvt.PEN', 'StrFun.PEN', 'StrWord.PEN', 'StrIndex.PEN' ) ] (* NON-STD *)
{}{0} MODULE StrFile ;
{

DOCUMENT NAME: StrFile.PAS DATE: 1990.09.04

DESCRIPTION:
 utilities for handling files. Needs initialization with InitStrFile.

}
TYPE
intfile = FILE OF int;

VAR
{ CONSTANT STRINGS }
NameQue, DateQue, { -- Keys "NAME:" and "DATE:" that identify corresponding strings. }

{ VARIABLE STRINGS }
Name, Date: int ;{ -- The strings keyed by "NAME:" and "DATE:" found in user's file. }
{ v.platform addx, links, home, pkg"string}

{}PROCEDURE InitStrFile ;

BEGIN
NameQue:= Str8( 'NAME: ', 5, strNil ); DateQue:= Str8( 'DATE: ', 5, StrNil );
OK:= OK AND NewStr( Date ) AND NewStr( Name );
IF NOT OK THEN writeln( 'ERROR StrFile InitStrFile : mem. ')
END;{ InitStrFile }

{}FUNCTION GetFileName ( A, Start, DefaultName, DefaultType, C: int ): int;

{
GLOBAL: LOCAL Name ;
}
VAR LenC : int ; ch: char;
BEGIN
IF C = StrNIl THEN OK := NewStr( C ) ELSE OK:= true;
IF OK THEN C:= WordCopy ( A, Start, C );
IF NOT OK THEN
writeln ( 'ERROR StrFile GetFileName : mem or range. ' )
ELSE BEGIN LenC := Length ( C ); GetFileName := C;
IF LenC = 0 THEN
C:= Copy ( DefaultName, C )
ELSE IF IndexChar ( '.' , C , 1 ) = 0 THEN BEGIN
Start := IndexChar ( ';' , C , 1 ); IF Start = 0 THEN Start := LenC +1 ;
C := Insert ( C, Start, Append ( DefaultType , CharStr ( '.', Name), Name), 1, 255, C )
END{ if }
END END;{ GetFileName }
{ v.platform addx, links, home, pkg"string}

{}PROCEDURE OpenFile ( VAR f : text ; Physical : int; Writing : boolean );

VAR Name : String32 ; i , Len : int ;
BEGIN Len := Length( Physical ); FOR i := 1 TO 32 DO Name [i] := chr(0);
IF Len > 32 THEN
writeln ( 'ERROR StrFile OpenFile : name truncation.' )
ELSE BEGIN FOR i := 1 TO Len DO Name [ i ] := Rd ( Physical , i );
IF Writing THEN BEGIN OPEN ( f, Name, NEW ); rewrite( f ) END
ELSE BEGIN OPEN ( f, Name, OLD ); reset( f ) END
END END;{ OpenFile }
{ v.platform addx, links, home, pkg"string}

{}PROCEDURE message( VAR Outs : text; VAR f: intfile; msg: int );

{
GLOBALS: OUT output , Outs ; WITH StrCvt USING WriteStr ;
DESCRIPTION: the file f contains indexes relevant to the string msg.
These indexes and the message are written out to both the output and Outs files.
Rewrites the intfile.
}
CONST PageNumFieldSize = 5;
VAR z, Col: int;
BEGIN reset( f ); Col:= 0;
WriteStr( output, msg ); writeln;
WriteStr( Outs, msg ); writeln( Outs );
WHILE NOT eof( f ) DO BEGIN read( f, z );
write( z: PageNumFieldSize ); write( Outs, z: PageNumFieldSize ); Col:= Col +PageNumFieldSize;
IF Col > 80 THEN BEGIN writeln; writeln( Outs ); Col:= 0 END END;
writeln; writeln( Outs ); rewrite ( f )
END;{ message }
{ v.platform addx, links, home, pkg"string}

{}FUNCTION FoundNameDate ( VAR f : text ; C : int ) : int ;

{
GLOBALS: NameQue , DateQue; OUT , output, Name , Date ;
WITH StrType IN temp, StrNil ; USING SetLength, ReadStr , NewStr ;
WITH StrIndex IN StrNil USING IndexKeyed, WordCopy
DESCRIPTION: Defines Name and Date with lines fed to it from file f.
If either Name or Date has already been found then FoundNameDate is
still looping for the other; it returns StrNil if neither is found.
If either string is found, then the returned string has the format:
( Name, 2 spaces, Date ). Expects file f to be reset and leaves the same.
}
VAR Named, Dated: int; {indices} Done: boolean;
BEGIN
Named:= 0; Dated:= 0; Done:= false; SetLength( Name , 0 ); SetLength( Date , 0 );
WHILE NOT Done AND NOT eof( f ) DO BEGIN temp:= ReadStr( f, temp );
IF Named = 0 THEN BEGIN
Named := IndexKeyed ( NameQue , temp );
IF NOT( Named =0 ) THEN Name := WordCopy( temp, Named , Name )
END;{ if }
IF Dated = 0 THEN BEGIN
Dated := IndexKeyed ( DateQue, temp );
IF NOT( Dated =0 ) THEN Date := WordCopy( temp, Dated , Date )
END;{ if }
Done:= NOT( Dated=0 ) AND NOT( Named=0 ) END;{while}
reset( f );
IF (Dated=0) AND (Named=0) THEN
FoundNameDate := StrNil
ELSE BEGIN
IF C = StrNIl THEN OK := NewStr( C ) ELSE OK:= true;
IF NOT OK THEN
writeln( 'ERROR StrFile FoundNameDate : mem.' )
ELSE
FoundNameDate := Append ( RightJustified( Date, Space, Length(Date)+2, C ), Name, C )
END{ if }
END;{ FoundNameDate }
{ v.platform addx, links, home, pkg"string}

{}PROCEDURE ReadFile ( VAR Outs , Ins : text );

{
DESCRIPTION: Append file Ins to file Outs.
}
BEGIN
WHILE NOT eof( Ins ) DO BEGIN
WHILE NOT eoln( Ins ) DO BEGIN
Outs^ := Ins^ ; get( Ins ); put( Outs );
END{ while };
readln( Ins ); writeln( Outs );
END{ while }
END;{ ReadFile }

END.{ module StrFile }
{ v.platform addx, links, home, pkg"string}

String conversions (string -to- { char, char array, text file, int } functions)

[ ENVIRONMENT , INHERIT ( 'StrType.PEN' ) ] (* NON-STD *)
{}{ 0 } MODULE StrCvt ;
{

DOCUMENT NAME: StrCvt.PAS DATE: 1990.08.22

DESCRIPTION: Convert between strings and other datatypes. See also StrWord, StrFile.

}
{ v.platform addx, links, home, pkg"string}

{}FUNCTION ReadStr( VAR f:text; C: int ): int; { -- Read to end of line. }

LABEL Exit ;
VAR ch: char; i: int;
BEGIN i:= 0;
IF C = StrNIl THEN OK := NewStr( C ) ELSE OK:= true;
IF OK THEN BEGIN
WHILE NOT eoln( f ) OR eof( f ) DO BEGIN
read( f, ch ); i:= i+1; Wr( C, i, ch );
IF i = 255 THEN GOTO Exit END;
Exit : IF eoln ( f ) AND NOT eof( f ) THEN readln( f );
SetLength( C, i ); ReadStr:= C END
ELSE
writeln( 'ERROR: string file-read failed.' );
END;{ ReadStr }
{ v.platform addx, links, home, pkg"string}

{}PROCEDURE WriteStr( VAR f:text; A: int );

VAR ALen, i: int;
BEGIN ALen:= Length(A);
IF ALen > 132 THEN BEGIN
FOR i:= 1 TO 132 DO write( f, Rd( A, i ));
writeln( f ); FOR i:= 133 TO ALen DO write( f, Rd( A, i ));
IF Warning THEN writeln( 'WARNING string WriteStr: string longer than 132' ) END
ELSE
FOR i:= 1 TO ALen DO write( f, Rd( A, i ))
END;{ WriteStr }
{ v.platform addx, links, home, pkg"string}

{}FUNCTION Str32( A:String32; Length, C: int ): int;

VAR i: int;
BEGIN
IF C = StrNil THEN OK:= NewStr( C ) ELSE OK:= ( Length > 0 );
Str32:= C;
IF OK AND ( Length <= 32 ) THEN BEGIN
FOR i:= 1 TO Length DO Wr( C, i, A[i] );
SetLength( C, Length ) END
ELSE writeln( 'ERROR string Str32: mem or length arg.' );
END;{Str32}
{ v.platform addx, links, home, pkg"string}

{}FUNCTION Str8( A:String8; Length, C: int ): int;

VAR i: int;
BEGIN
IF C = StrNil THEN OK:= NewStr( C ) ELSE OK:= ( Length > 0 );
Str8:= C;
IF OK AND ( Length <= 8 ) THEN BEGIN
FOR i:= 1 TO Length DO Wr( C, i, A[i] );
SetLength( C, Length ) END
ELSE writeln( 'ERROR string Str8: mem or Length arg.' );
END;{Str8}
{ v.platform addx, links, home, pkg"string}

{}FUNCTION IntStr( num, FieldSize, C: int ): int;

VAR temp: text;
BEGIN
open(temp); rewrite(temp); writeln( temp, num:FieldSize ); reset(temp);
IntStr:= ReadStr( temp, C ); { --ReadStr sets OK. } close(temp );

IF NOT OK THEN writeln( 'ERROR string IntStr: mem.' )
END;{IntStr}
{ v.platform addx, links, home, pkg"string}

{}FUNCTION CharStr( ch:char; C: int ): int;

BEGIN 
IF C = StrNil THEN OK:= NewStr( C ) ELSE OK:= true;
CharStr:= C;
IF OK THEN BEGIN
Wr( C, 1, ch );
SetLength( C, 1 ) END
ELSE writeln( 'ERROR string CharStr: mem.' );
END;{CharStr}
{ v.platform addx, links, home, pkg"string}

{}FUNCTION StrInt( A, Start : int ): int;

LABEL ExitLoop , Exit ;
VAR temp: text; i : int ; Found : boolean ; ch : char ;
BEGIN
open(temp); rewrite(temp); Found := false ;
FOR i := Start TO 256 DO BEGIN
ch := Rd( A, i );
IF ch IN ['0'..'9'] THEN BEGIN
writeln( temp, ch ); Found := true END
ELSE IF Found THEN
GOTO ExitLoop
ELSE BEGIN
writeln( 'ERROR StrCvt StrInt : number not found.' );
StrInt := 0; GOTO Exit END
END{ for };
ExitLoop : reset(temp); read ( temp, i ); StrInt := i ;
Exit : END;{IntStr}

END.{ module StrCvt }
{ v.platform addx, links, home, pkg"string}

String Format operations (tabs vs spaces )

[ ENVIRONMENT , INHERIT ( 'StrType.PEN' , 'StrIndex.PEN' , 'StrFun.PEN') ] (* NON-STD *)
{}{0}MODULE StrTab ;
{

DOCUMENT NAME: StrTab.PAS DATE: 1990.09.10

DESCRIPTION: String Format functions ( involving tabs or spaces ).

}
{ v.platform addx, links, home, pkg"string}

{}FUNCTION LengthDeSpaced( A: int ): int;

{
GLOBAL: WITH StrIndex USING IndexNonSpace ; WITH StrType IN Space,Tab ; USING Rd .
DESCRIPTION: counts Length when there are no spaces or tabs, except for one space between
words. A quoted string is considered one word, and is assumed to contain no tabs.
}
VAR Start, i, ALen, Len: int; ch: char; Run, Quoted: boolean;
BEGIN ALen:= Length( A ); Len:= 0; Run:= false; Quoted:= false;
IF ALen > 0 THEN BEGIN
Start:= IndexNonSpace( A, 1 );
FOR i:= Start TO ALen DO BEGIN
ch:= Rd( A, i );
IF ch = '"' THEN Quoted:= NOT Quoted;
IF Quoted THEN BEGIN
Len:= Len+1;
IF ch = Tab THEN writeln( 'ERROR string LengthDeSpaced: Tab in quoted string. ' ) END
ELSE IF ch IN [Space,Tab] THEN BEGIN
IF NOT Run THEN BEGIN { -- This is the first space in a run, so count it. }
Run:= true; Len:= Len+1 END END
ELSE BEGIN
Run := false ; Len:= Len+1 END
END{ for } END{ if };
IF Quoted THEN
BEGIN IF Warning THEN writeln( 'ERROR string LengthDeSpaced: Closing quote missing. ' ) END
ELSE
LengthDeSpaced:= Len
END;{LengthDeSpaced}
{ v.platform addx, links, home, pkg"string}

{}FUNCTION DeSpace( A, C: int ): int;

{
GLOBAL: WITH StrIndex USING IndexNonSpace ;
WITH StrType IN StrNil,Space ; OUT OK ; USING NewStr, Length, Rd , Wr.
DESCRIPTION: returns a copy with no spaces or tabs, except for one space between
words. A quoted string is considered one word, and is assumed to contain no tabs.
}
VAR i,j,Start: int; InSpaces: boolean; ch: char;
BEGIN
IF C = StrNIl THEN OK := NewStr( C ) ELSE OK:= true;
DeSpace:= C;
IF OK THEN BEGIN
InSpaces:= false; j:= 1; Start:= IndexNonSpace( A, 1 );
FOR i:= Start TO Length(A) DO
ch:= Rd( A, i );
IF ch = Space THEN BEGIN
IF NOT InSpaces THEN InSpaces:= true END
ELSE BEGIN
IF InSpaces THEN BEGIN InSpaces:= false; Wr( C, j, Space ); j:= j+1 END;
Wr( C, j, ch ); j:= j+1 END;
SetLength( C, j-1 ) END
ELSE writeln( 'ERROR string DeSpace' )
END{ DeSpace };
{ v.platform addx, links, home, pkg"string}

{}FUNCTION DeTab( A, C: int ): int;

{
GLOBAL: WITH StrType IN StrNIl,Space,Tab ; OUT OK ; USING Rd, Length, Wr, TabClass,
SetLength, NewStr, OldStr ; WITH StrFun USING Fillin, Copy
DESCRIPTION: Chars are copied from A to C. When a tab occurs, not only is it adding multiple
spaces, but it's also shifting the remaining string into the zero tabclass; thus, beyond the
first tab, a char's tabclass won't necessarily correspond to its position in the unexpanded
string. If the result C is A then it must be copied to another structure.
}
VAR B: int;
{ v.platform addx, links, home, pkg"string}

 {}{2}PROCEDURE PerformDeTab;

	VAR	ch: char;
SpaceLength: int; { The number of spaces caused by a tab. }
i: int { Index for A. }; j: int { Index for C. };
iClass: int { ( range 0..TabSize -1 ) ---Tab class index for the i-th character of A. };
BEGIN iClass:= 0; j:= 1;
FOR i:= 1 TO Length(A) DO BEGIN
ch:= Rd( A, i );
IF ch = Tab THEN BEGIN
SpaceLength := TabSize - iClass;
C := Fillin( C, Space, j, SpaceLength, C );
j:= j + SpaceLength; iClass:= 0 END
ELSE BEGIN
Wr( C, j, ch );
j:= j+1; iClass:= TabClass( iClass+1 ) END
END{for};
SetLength( C, j-1 ); DeTab:= C
END;{ PerformDeTab }
{}{2}
BEGIN{ function DeTab }
{-- If A = C then C exists, but a new structure may be needed for destructive intermediate results,
--unless Length(A) = 0. If A <> C and tthen if C = StrNil, then it needs a new structure. }
IF A = C THEN BEGIN
IF Length( A ) = 0 THEN
DeTab:= Copy( A, C )
ELSE IF NewStr( B ) THEN BEGIN { Give the local ptr, A, the same data in a different structure. }
A := Copy( A, B );
PerformDeTab; OldStr(B) END
ELSE writeln( 'ERROR: string DeTab failed.' ) END
ELSE BEGIN OK:= true;
IF C = StrNIl THEN OK := NewStr( C );
IF OK THEN PerformDeTab ELSE writeln( 'ERROR: string DeTab failed.' )
END END;{ DeTab }
{ v.platform addx, links, home, pkg"string}

{}FUNCTION EnTab( A, C: int ): int;

{
GLOBAL: WITH StrType IN StrNIl,Space,Tab,TabSize ; OUT OK ;
USING Rd, Wr, Length, SetLength, NewStr, TabClass, TabZone_index, Mov .
DESCRIPTION: If the string, A, has any tabs, run it through DeTab first. With no tabs, EnTab
will return a string that prints like A would, but uses less characters by replacing spaces
with tabs. --Recall that a string is partitioned by Tab Zones:
zone 0 = ( 1 .. TabSize-1 ), zone 1 = ( TabSize .. 2*TabSize-1 ), etc.
If there are 2 or more spaces at the end of a Tab Zone, then one tab is copied in their place.
--Since this is always a sequential proccess that either preserves or shortens string-length,
it doesn't matter if ( A = C ).
NOTE: Pascal is particular about fixed strs: Entab may change the length of strings.
}
{ v.platform addx, links, home, pkg"string}

 {}{2}PROCEDURE PerformEntab; {---length(A) > 0 }

	VAR	ch: char; Len, LastTabClass: int;
SpaceLength: int; { The number of consecutive spaces found in one Tab Zone. }
i: int { Index for A. }; j: int { Index for C. };
WholeZones: int; { number of entire Tab Zones in string A. }
iClass: int { ( range 0..TabSize -1 ) ---Tab class index for the i-th character of A. };
BEGIN
j:= 1; i:= 1; LastTabClass:= TabSize - 1; Len:= Length(A);
FOR WholeZones := 1 TO TabZone_index( Len ) DO BEGIN SpaceLength := 0;
FOR iClass := 0 TO LastTabClass DO BEGIN
ch:= Rd( A, i ); i:= i+1;
Wr( C, j, ch ); j:=j+1;
IF ch = Space THEN { --The length of the last run of spaces is counted. }
SpaceLength := SpaceLength +1
ELSE SpaceLength := 0
END{ for classes };
IF SpaceLength > 1 THEN BEGIN{ --the last spaces must be replaced with a tab. }
j:= j- SpaceLength;
Wr( C, j, Tab ); j:=j+1 END END{ for zones };
{ -- FOR i:= i TO Len DO BEGIN Wr( C, j, Rd( A, i )); j:=j+1 END; SetLength( C, j-1 ); }
Len := Len-i+1 ; Mov ( A, i, Len, C, j ); SetLength( C, j+Len-1 );
EnTab:= C END{ PerformEnTab };
{}{2}
BEGIN{ function EnTab }
IF A = C THEN {-- C exists so no new structure is needed. }
PerformEnTab
ELSE BEGIN OK:= true;
IF C = StrNIl THEN OK := NewStr( C );
IF OK THEN PerformEnTab ELSE writeln( 'ERROR: string EnTab failed.' )
END END;{ EnTab }

END. { module StrTab }
{ v.platform addx, links, home, pkg"string}

other String  operations ( String -to- String functions)


[ ENVIRONMENT , INHERIT ( 'StrType.PEN' ) ] (* NON-STD *)
{}{0} MODULE StrFun ;
{

DOCUMENT NAME: StrFun.PAS DATE: 1990.08.27

DESCRIPTION: string --> string functions
CONVENTIONS: input strings have the names: [ A, B, Lay, Bed ], and the string to return is
named C. If ( C = StrNil ) then a new string is allocated. Input strings are never affected
unless C is one of the input strings. C is always the last parameter. A string Descriptor
refers to the info: ( Start , Length ) which specifies a substring within an input string.

}
{ v.platform addx, links, home, pkg"string}

{}FUNCTION EmbedSubCopy ( Lay, Start, SubLength, Bed, BedIndex, C: int ): int;

{
GLOBAL: WITH StrType IN StrNil ; USING Mov , Length , Range , NewStr , SetLength .
DESCRIPTION: The descripted string in Lay is embedded into Bed starting at BedIndex.
Only string C is affected; a portion of C may remain undefined if ( BedIndex > Length(Bed) )
PROOF: Embed Now, the worst-case is when B=C and A<>C and start<>1 ; example :
C( 1..3 ):= A( 1..3 ); ---here A has stepped on B values.
C( 2..4 ):= B => C( 1..3 ); ---here C(2):= C(1), and then C(3):= (stepped on) C(2).
(Start=1) and (Length(A) >= Length(B)) ==> trivial.
Others: A=B<>C, A<>B<>C ==> A, B are never written, so no precautions needed.
B<>A=C ==> A is already written correctly alligned as C, and B is only read.
(Length(B)=0 ==> trivial)
A=B=C ==> B is shifted forward, and safe only with a backwards transfer.
(Start=1 ==> trivial)
}
VAR LayLen, LayEnd : int; FreshBed: boolean;
{ v.platform addx, links, home, pkg"string}

 {} {2}PROCEDURE Perform;

	VAR	AppendLen, BLen: int ;
BEGIN
Mov ( Lay , Start , SubLength , { to } C , BedIndex );
FreshBed:= NOT(Bed=C); BedIndex := BedIndex -1; AppendLen := BedIndex + SubLength;
IF NOT ( BedIndex = 0 )AND FreshBed THEN {--- Copy the intact first part of Lay into C. }
Mov ( Bed, 1, BedIndex, { to } C, 1 );
BLen := Length( Bed );
IF BLen > AppendLen THEN BEGIN {--- LAY was properly contained within Bed, so unless Lay = C, }
IF FreshBed THEN BEGIN {--- ..copy the last part of Bed, and Blen into C. }
Mov ( Bed, AppendLen+1, BLen - AppendLen, { to } C, AppendLen+1 );
SetLength( C, Blen ) END END
ELSE{ ---the new string is longer than A. }
SetLength( C, AppendLen )
END;{ EmbedSubCopy \Perform }
{} {2}
BEGIN{ EmbedSubCopy } LayLen := Length( Lay );
IF C = StrNil THEN OK := NewStr( C ) ELSE OK:= true;
OK := OK AND Range( Start, SubLength, LayLen ); {--This trims SubLength to fit within Lay. }
OK := OK AND Range( BedIndex, SubLength, 255 );
EmbedSubCopy := C;
IF OK THEN Perform ELSE writeln( 'ERROR: string Embed failed.' )
END;{ EmbedSubCopy }
{ v.platform addx, links, home, pkg"string}

{}FUNCTION Embed( Lay, Bed, BedIndex, C: int ): int;

{
GLOBAL: USING EmbedSubCopy ; WITH StrType USING Length.
}
BEGIN Embed:= EmbedSubCopy( Lay, 1, Length(Lay), Bed, BedIndex, C )
END;{ Embed }
{ v.platform addx, links, home, pkg"string}

{}FUNCTION EmbedMasking ( Lay, Start, SubLength, Bed, C: int ): int;

{
GLOBAL: USING EmbedSubCopy .
DESCRIPTION: The embedded string starts at the same place in Bed as it does in Lay.
}
BEGIN EmbedMasking := EmbedSubCopy( Lay, Start, SubLength, Bed, Start, C )
END;{ EmbedMasking }

{}FUNCTION Append( Lay, Bed, C: int ): int;
{
GLOBAL: USING EmbedSubCopy ; WITH StrType USING Length .
DESCRIPTION: Lay is appended to Bed.
}
BEGIN Append:= EmbedSubCopy( Lay, 1, Length(Lay), Bed, Length(Bed)+1, C )
END;{ Append }
{ v.platform addx, links, home, pkg"string}

{}FUNCTION SubCopy( A, Start, SubLength, C: int ): int;

{
GLOBAL: WITH StrType IN StrNil ; USING Length , NewStr , Mov , SetLength , Range .
DESCRIPTION: And it accepts a reversed descriptor ( SubLength can be negative ).
}
BEGIN
IF (C = StrNil) THEN OK := NewStr( C ) ELSE OK := Range( Start, SubLength, Length(A) );
SubCopy:= C;
IF OK THEN BEGIN
IF NOT( (A=C) AND (Start=1) ) THEN Mov ( A, Start, SubLength, C, 1 );
SetLength( C, SubLength ) END
ELSE writeln( 'ERROR: string SubCopy --bad arg( Start ) or no mem.' )
END;{ SubCopy }
{ v.platform addx, links, home, pkg"string}

{}FUNCTION Copy( A,C:int ): int;

{
GLOBAL: USING SubCopy ; WITH StrType USING Length .
}
BEGIN Copy:= SubCopy( A, 1, Length(A), C )
END;{ Copy }
{ v.platform addx, links, home, pkg"string}

{} FUNCTION Delete ( A, Start , Len, C : int ) : int ;

{
GLOBAL: WITH StrType IN StrNil ; USING Length , NewStr , Mov , SetLength , Range .
DESCRIPTION: NOT the inverse of Insert: if the deletion is to be buffered,
then the user should calculate the substring descriptor first, and then
use this descriptor to first copy the deletion, and then delete it.
}
VAR RemLen , StartnLen, LenA : int ;
BEGIN LenA := Length( A );
IF C = StrNil THEN OK:= NewStr( C ) ELSE OK := Range( Start, Len, LenA );
Delete := C ; SetLength ( C, LenA - Len ); StartnLen := Start + Len ;
RemLen := LenA - StartnLen +1;
IF Len = 0 THEN BEGIN
IF NOT ( A=C ) THEN Mov ( A, 0, LenA+1, C, 1 ) END
ELSE BEGIN
IF NOT ( A=C ) AND NOT ( Start = 1 ) THEN { -- truncation requested. }
Mov ( A, 1, Start-1, C, 1 );
IF NOT ( RemLen = 0 ) THEN
Mov ( A, StartnLen, RemLen, C, Start );
END{ if }
END;{ Delete }

{ v.platform addx, links, home, pkg"string}

{} FUNCTION Insert ( A, InsertPtr, B, Start , Len, C : int ) : int ;

{
GLOBAL: WITH StrType IN StrNil ; USING Length , NewStr , Mov , SetLength , Range .
DESCRIPTION: Insert the descripted substring of B at the InsertPtr of A.
}
LABEL Exit ;
VAR PreLen , ShiftLen, LenA : int ;

 {} {2} PROCEDURE CopyB;

	VAR	BCopy : String ;   i , d : int ;
BEGIN d := Start ;
FOR i := 1 TO Len DO BEGIN BCopy [ i ] := Rd ( B, d ); d:= d+1 END;
Mov ( A, InsertPtr, LenA - PreLen, C, InsertPtr+Len ); d := InsertPtr ;
FOR i := 1 TO Len DO BEGIN Wr ( C, d, BCopy [ i ] ); d:= d+1 END
END;{ Insert \ CopyB }
{} {2}
BEGIN LenA := Length( A );
IF C = StrNil THEN OK:= NewStr( C ) ELSE OK := Range( Start, Len, Length( B ) );
PreLen := InsertPtr -1; OK := OK AND ( PreLen + Len < 256 ); IF NOT OK THEN GOTO Exit ;
Insert := C ; SetLength ( C, LenA + Len ); ShiftLen := LenA - PreLen ;
IF ( ShiftLen < 0 ) AND Warning THEN
writeln( 'WARNING StrFun Insert : Beyond EO leaves mid undefined.' );
IF A=C THEN
IF (B=C) AND ( InsertPtr < Start ) THEN
CopyB
ELSE BEGIN
Mov ( A, InsertPtr, LenA - PreLen, C, InsertPtr + Len ); { -- Shift A. }
Mov ( B, Start, Len, C, InsertPtr ) { -- Embed B. }
END { if }
ELSE BEGIN { -- A is safe but PreInsert needed. }
Mov ( B, Start, Len, C, InsertPtr ); { -- Embed B first, since it isn't safe. }
IF ShiftLen > 0 THEN Mov ( A, InsertPtr, ShiftLen, C, InsertPtr + Len ); { -- Shift A. }
Mov ( A, 1, PreLen, C, 1 ) { -- Move A. }
END{ if };
Exit : END;{ Insert }
{ v.platform addx, links, home, pkg"string}

{}FUNCTION Fillin( A: int; ch: char; Start, FiLength, C: int ): int;

{
GLOBAL: WITH StrType IN StrNil ; USING Length , NewStr , Mov , Wr, SetLength , Range .
DESCRIPTION:
---Start and/or FiLength may be negative, and have the following affects:
(- Start, - FiLength ): pad to the left of (C) until Length(C) = (| FiLength |);
(- Start, + FiLength ): pad to the right of (C) until Length(C)= FiLength;
(+ Start, - FiLength ): C.( Start -(| FiLength |)+1 ) .. Start ) := pad;
---Doesn't warn if Start is beyond original length: mid-string may be undefined.
( + Start, + FiLength ): C.( Start .. ( Start +FiLength-1) ) := pad;
}
VAR i, ALen, IndexDiffs, AppendLen: int; AFresh : boolean;

 {} {2} PROCEDURE FillinSizeSpecified;

	BEGIN IF OK THEN BEGIN IndexDiffs := Start-1; { ---Diffs of beginnings of A, B. }
AppendLen := IndexDiffs + FiLength;
FOR i:= Start TO AppendLen DO Wr( C, i, ch ); { ---Lay the fill. }
AFresh:= NOT( A=C );
IF AFresh THEN Mov ( A, 1, IndexDiffs, C, 1 ); { -- Copy the intact first part of A into C. }
END{if OK } END;{ FillinSizeSpecified } { -- Now what happens depends on the caller. }

 {} {2} PROCEDURE FieldSizeSpecified;

	VAR	FieldSize: int ;   PadLeft : boolean ;
BEGIN PadLeft:= (FiLength < 0); IF PadLeft THEN FiLength := -FiLength ;
FieldSize := FiLength;
FiLength := FieldSize - ALen; {---add padding until ( Length( C ) = | FiLength |). }
SetLength( C, FieldSize);
IF FiLength < 1 THEN BEGIN {--- truncate, if needed, to fit A within FieldSize. }
IF NOT ( A = C ) THEN Mov( A, 1, FieldSize, C, 1 ) END
ELSE BEGIN
IF PadLeft THEN { -- ( Add padding on the left ). } BEGIN Start:= 1;
Mov ( A, 1, ALen, C, 1+FiLength ); { -- make room for padding. }
A:= C { -- FillinSizeSpecified will fill but not copy. } END
ELSE BEGIN{-- Add right padding. }
Start:= ALen +1 { -- FillinSizeSpecified will copy and fill. }
END{ if };
FillinSizeSpecified
END{ if }END;{ FieldSizeSpecified }
{} {2}
BEGIN{ Fillin }
IF C = StrNil THEN OK := NewStr( C ) ELSE OK:= true;
Fillin:= C; ALen := Length( A );
IF OK THEN
IF Start < 0 THEN
FieldSizeSpecified
ELSE BEGIN OK:= Range( Start, FiLength, 255 );
FillinSizeSpecified ;
IndexDiffs := ALen - AppendLen; {--- The length of A that remains to the right of the fill. }
IF 0 < IndexDiffs THEN BEGIN{--- the fill was properly contained within A, so copy the last part of A. }
IF AFresh THEN BEGIN AppendLen := AppendLen + 1;
Mov ( A, AppendLen, IndexDiffs, C, AppendLen ); SetLength( C, ALen )
END{ if } END
ELSE{ ---the new string is longer than A. }
SetLength( C, AppendLen )
END{ if };
IF NOT OK THEN {---checks for success of Embed as well as NewStr. }
writeln( 'ERROR: string Fillin.' )
END;{ Fillin }
{ v.platform addx, links, home, pkg"string}

{} FUNCTION LeftJustified( A:int; ch:char; FieldSize, C: int ): int;

{
GLOBAL: USING Fillin .
}
BEGIN LeftJustified := Fillin( A, ch, -1, FieldSize, C )
END{ LeftJustified };

{}FUNCTION RightJustified( A:int; ch:char; FieldSize, C: int ): int;
{
GLOBAL: USING Fillin .
}
BEGIN RightJustified:= Fillin( A, ch, -1, -FieldSize, C )
END{ RightJustified };
{ v.platform addx, links, home, pkg"string}

{}FUNCTION Spaces( Length, C: int ): int;

{
GLOBAL:
WITH StrType IN Space, StrNil ; USING SetLength, Wr, NewStr ; OUT OK
}
VAR i:int;
BEGIN
IF C = StrNil THEN OK:= NewStr( C ) ELSE OK:= true;
Spaces := C;
IF OK THEN BEGIN
FOR i:= 1 TO Length DO Wr( C, i, Space );
SetLength( C, Length ) END
ELSE writeln( 'ERROR string Spaces: mem.' )
END;{Spaces}
{ v.platform addx, links, home, pkg"string}

{} FUNCTION Indent( A, IndentSize, C: int ): int;

{
GLOBAL: USING Append, Spaces ; WITH StrType IN StrNil ; USING NewStr ; OUT OK .
DESCRIPTION: returns a copy of string A with ( IndentSize ) spaces prefixed.
}
VAR i:int;
BEGIN
IF C = StrNil THEN OK:= NewStr( C ) ELSE OK:= true;
IF OK THEN Indent := Append( A, Spaces( IndentSize, C ), C )
ELSE writeln ( 'ERROR StrFun Indent : mem. ' )
END{ Indent };

END. { module StrFun }
{ v.platform addx, links, home, pkg"string}

functions that operate on a Word

[ ENVIRONMENT , INHERIT ( 'MathUtl.PEN' , 'StrType.PEN' , 'StrIndex.PEN' ) ] (* NON-STD *)
{}{0} MODULE StrWord ;
{

DOCUMENT NAME: StrWord.PAS DATE: 1990.08.31

DESCRIPTION: String Package functions that operate on a Word,
a textual unit defined as:
(1) any string of non-space non-tab chars;
(2) any quoted string.

}
{ v.platform addx, links, home, pkg"string}

{} FUNCTION WordLength ( Word : int ; Start : int ): int ;

{
GLOBAL: WITH MathUtl USING Absol ; WITH StrType OUT OK ; USING Rd ;
WITH StrIndex USING IndexChar , IndexSpace ;
DESCRIPTION: Returns a negative length if Start is negative, and gets word size.
Start represents the [ begin, end ] of the word when it is [ positive, negative ].
The size includes the quotes in the case of the quoted-phrase-word.
ALGORITHM: IndexSpace and IndexChar both react to a negative Start the same way WordLength
does. Absol sets Direction := [ 1, -1 ] depending on Starts sign, and this is convenient when
the case decides [ adding, subtraction ].
}
VAR ch : char ; AbStart , Lim, LenWord , Direction : int ;
BEGIN LenWord := Length ( Word ); AbStart := Absol ( Start, Direction );
IF LenWord = 0 THEN
WordLength := 0
ELSE IF ( Start = 0 ) OR ( AbStart > LenWord ) THEN BEGIN
OK := false ; writeln( 'ERROR StrType WordLength : start range. ' ) END
ELSE BEGIN
ch := Rd( Word, AbStart );
IF ch = '"' THEN BEGIN { -- Pick up a quoted phrase. }
Lim := IndexChar( '"', Word, Start+1 );
IF Lim = 0 THEN BEGIN
OK := false ; writeln( 'ERROR StrType WordLength : missing quote.' ) END END
ELSE BEGIN { -- Pick up a word. }
Lim := IndexSpace ( Word, Start );
IF Lim = 0 THEN
IF Direction < 0 THEN Lim := 1 ELSE Lim := LenWord
ELSE BEGIN
Lim := Lim - Direction
END{ if }
END{ if };
WordLength := (Lim - AbStart) + Direction
END{ if }
END;{ WordLength }
{ v.platform addx, links, home, pkg"string}

{}FUNCTION WordCopy( Word, Start, C: int ): int;

{
GLOBAL: USING WordLength ;
WITH StrType IN StrNil ; OUT OK ; USING Rd, Range, Length, Mov, SetLength NewStr .
DESCRIPTION: copy the word (Dequoted) from start and going [ forward , backward ]
from [ beginning, end ] of word, depending on whether Start is [ positive, negative ].
ALGORITHM: WordLength finds the length of the word, and it is negative if Start was.
When Range finds a negative Length, then it assumes start is pointing at the end of the word,
and reverses this condition, so Start points at the beginning, and both Start and Length are
positive. Mov accomodates overlapping source and destination strings.
}
LABEL Exit ;
VAR WordLen : int ;
BEGIN
IF C = StrNil THEN OK:= NewStr( C );
IF NOT OK THEN BEGIN writeln( 'ERROR StrFun WordCopy: mem. ' ); GOTO Exit END;
WordLen := WordLength( Word, Start ); WordCopy:= C;
IF WordLen = 0 THEN BEGIN Setlength( C, 0 ); GOTO Exit END;
OK := Range( Start, WordLen, Length( Word ));
IF NOT OK THEN BEGIN writeln( 'ERROR StrFun WordCopy: range.' ); GOTO Exit END;
IF Rd( Word, Start ) = '"' THEN BEGIN Start := Start +1; WordLen := WordLen -2 END;
Mov ( Word, Start, WordLen, C, 1 ); SetLength( C, WordLen );
Exit : END;{ WordCopy }
{ v.platform addx, links, home, pkg"string}

{}FUNCTION ReadWord( VAR f:text; C: int ): int;

{
GLOBAL: WITH StrType IN StrNil,Tab,Space ; OUT OK ; USING Wr, SetLength NewStr ;
DESCRIPTION: gets through spaces and picks up next word.
}
LABEL ExitWhile, Loop , Exit ;
VAR EOChar , ch: char; i: int;
BEGIN i:= 0;
IF C = StrNIl THEN OK := NewStr( C ) ELSE OK:= true;
IF OK THEN BEGIN
WHILE NOT eof( f ) DO
IF ( f^ IN [Tab,Space] ) THEN get( f )
ELSE IF eoln( f ) THEN readln( f )
ELSE GOTO ExitWhile ;
ExitWhile : IF eof( f ) THEN GOTO Exit ;
IF f^ = '"' THEN read ( f, EOChar ) ELSE EOChar := Space ;

Loop : IF eoln( f ) OR eof( f ) OR (f^ = EOChar) THEN
GOTO Exit ;
IF (i = 255) THEN BEGIN
writeln( 'ERROR: StrWord ReadWord : Word truncation.' );
GOTO Exit
END{ if };
read( f, ch ); i:= i+1; Wr( C, i, ch );
GOTO Loop { END while };

Exit : IF eoln ( f ) AND NOT eof( f ) THEN readln( f );
SetLength( C, i ); ReadWord := C END
ELSE
writeln( 'ERROR: StrWord ReadWord : mem.' )
END;{ ReadWord }

END.{ module StrWord }
{ v.platform addx, links, home, pkg"string}


string -to- index-finding functions

-- finding the beginning or end off the nextt occurrence
going forwards or backwards
depending on whether parameter"Start is positive or negative

[ ENVIRONMENT , INHERIT ( 'StrType.PEN' ) ] (* NON-STD *)
{}{0} MODULE StrIndex ;
{

DOCUMENT NAME: StrIndex.PAS DATE: 1990.08.31

DESCRIPTION: String index functions.
-- Any routine that uses a Start parametter finds the index of the [ beginning, end ]
of the next occurrence going [ forwards, backwards ] depending on whether start is
[ positive, negative ].
FUNCTION IndexCharSet( s, A: int ): int; --not implemented.
--- (s) is a string of chars to look forr, consecutive duplicates signal a range;
--eg, AAZ means A..Z.

}
{ v.platform addx, links, home, pkg"string}

{}FUNCTION IndexNonSpace( A, Start: int ): int;

{
GLOBAL: WITH StrType IN Tab, Space ; OUT OK ; USING Rd, RangeEO .
}
LABEL Exit;
VAR i, Next, EO : int ;
BEGIN IndexNonSpace:= 0; OK := RangeEO ( A , Start, Next, EO );
IF NOT OK THEN BEGIN writeln( 'ERROR StrIndex IndexNonSpace : range ' ); GOTO Exit END;
i := Start ;
WHILE NOT ( i = EO ) DO BEGIN
IF NOT( Rd( A, i ) IN [Tab,Space] ) THEN BEGIN IndexNonSpace := i; GOTO Exit END;
i := i + Next
END;{ while }
Exit: END{ IndexNonSpace };
{ v.platform addx, links, home, pkg"string}

{}FUNCTION IndexSpace( A, Start: int ): int;

{
GLOBAL: WITH StrType IN Tab, Space ; OUT OK ; USING Rd, RangeEO .
}
LABEL Exit;
VAR i, Next, EO : int ;
BEGIN IndexSpace:= 0; OK := RangeEO ( A , Start, Next, EO );
IF NOT OK THEN BEGIN writeln( 'ERROR StrIndex IndexSpace : range ' ); GOTO Exit END;
i := Start ;
WHILE NOT ( i = EO ) DO BEGIN
IF Rd( A, i ) IN [Tab,Space] THEN BEGIN IndexSpace := i; GOTO Exit END;
i := i + Next
END;{ while }
Exit: END{ IndexSpace };
{ v.platform addx, links, home, pkg"string}

{} FUNCTION IndexStr( Target, Domain, Start: int ): int;

{
GLOBAL: WITH StrType USING Length, Rd.
}
VAR i, j: int; Found: boolean;

 {} {2}PROCEDURE ForwardIndex ;

	LABEL BadStart, GoodStart;
BEGIN
FOR i:= Start TO Length( Domain ) - Length( Target) +1 DO BEGIN Found:= true;
FOR j:= 1 TO Length( Target ) DO
IF Rd( Target, j ) <> Rd( Domain, i+(j-1) ) THEN BEGIN
Found:= false; GOTO BadStart END;
IF Found THEN BEGIN IndexStr:= i; GOTO GoodStart END;
BadStart: END;{for i}
GoodStart: END;{ ForwardIndex }

{} {2}PROCEDURE ReverseIndex ;
LABEL BadStart, GoodStart;
BEGIN
FOR i:= Start DOWNTO Length( Target) DO BEGIN Found:= true;
FOR j:= Length( Target ) DOWNTO 1 DO
IF Rd( Target, j ) <> Rd( Domain, i-(j-1) ) THEN BEGIN
Found:= false; GOTO BadStart END;
IF Found THEN BEGIN IndexStr:= i; GOTO GoodStart END;
BadStart: END;{for i}
GoodStart: END;{ ReverseIndex }
{} {2}
BEGIN{IndexStr} IndexStr:= 0;
IF Start = 0 THEN writeln( 'ERROR StrIndex IndexStr : Start range. ' )
ELSE IF Start > 0 THEN ForwardIndex
ELSE ReverseIndex
END;{IndexStr}
{ v.platform addx, links, home, pkg"string}

{}FUNCTION IndexKeyed ( Target, Domain: int ): int;

{
GLOBAL: USING IndexStr, IndexNonSpace ; WITH StrType USING Length.
}
VAR TargetStart: int;
BEGIN
TargetStart:= IndexStr( Target, Domain, 1 );
IF TargetStart > 0 THEN
IndexKeyed:= IndexNonSpace( Domain, TargetStart +Length( Target ))
ELSE
IndexKeyed:= 0
END;{ IndexKeyed }
{ v.platform addx, links, home, pkg"string}

{}FUNCTION IndexChar( ch: char; A, Start: int ): int;

{
GLOBAL: WITH StrType OUT OK ; USING Rd, RangeEO .
}
LABEL Exit;
VAR i, Next, EO : int ;
BEGIN IndexChar:= 0; OK := RangeEO ( A , Start, Next, EO );
IF NOT OK THEN BEGIN writeln( 'ERROR StrIndex IndexChar : range. ' ); GOTO Exit END;
i := Start ;
WHILE NOT ( i = EO ) DO BEGIN
IF Rd( A, i ) = ch THEN BEGIN IndexChar:= i; GOTO Exit END;
i := i + Next
END;{ while }
Exit: END{ IndexChar };
{ v.platform addx, links, home, pkg"string}

{}FUNCTION IndexNextWord ( A , Start : int ): int;

{
GLOBAL: USING IndexChar , IndexSpace, IndexNonSpace ;
WITH StrType IN Tab, Space ; USING Rd .
DESCRIPTION: Assumes Start is index of current word, and gives index
of char of next word: beyond current word and then beyond spaces.
}
VAR ch : char ;
BEGIN
ch := Rd ( A, Start );
CASE ch OF
'"' : BEGIN Start := IndexChar( ch, A, Start+1 ); Start := Start +1 END;
Tab, Space: ;
OTHERWISE (* NON-STD *)
Start := IndexSpace( A, Start )
END{ case };
IndexNextWord := IndexNonSpace( A, Start )
END;{ IndexNextWord }

END. { module StrIndex }
{ v.platform addx, links, home, pkg"string}

the test harness

[ ENVIRONMENT ] MODULE str( input, output );

PROCEDURE Main;

VAR B,A,line: int;

PROCEDURE pr( A: int );

BEGIN write( line:1,' Line="' );  Line:= Line+1;
WriteStr( output, A ); writeln( '"', Length(A):1) END;
BEGIN InitStrHeap; Line := 1;
REPEAT
writeln( 'string with/out tabs' );
A:= ReadStr( input, StrNil ); pr(A);
writeln( 'string with/out tabs' );
B:= ReadStr( input, StrNil ); pr(B);
pr( embed( A, B, 1, StrNil ));
pr( embed( A, B, Length(A), StrNil ));
pr( embed( A, B, 255, StrNil ));
pr( subcopy( A, 5, 2, B ));
pr( subcopy( A, -5, 2, B ));
pr( fillin( A, '*', 5, 2, StrNIl ));
pr( fillin( A, '*', 5, -2, StrNIl ));
pr( fillin( A, '*', -5, Length(A)+3, StrNIl ));
pr( fillin( A, '*', -5, -(Length(A)+3), StrNIl ));

writeln( 'string with/out tabs' );
A:= ReadStr( input, StrNil ); pr(A);
A:= Detab( A, A ); write( 'de tabbed:' ); pr( A);
A:= Entab( A, A ); write( 'tabbed:' ); pr(A)
UNTIL false END;

BEGIN MAIN

END.

{ v.platform addx, links, home, pkg"string}