language-Modula2-0.1: examples/Modula-2_Libraries/C.-Lins_Modula-2_Software_Component_Library/Vol1/STRINGS/STRSBMI.MOD
IMPLEMENTATION MODULE StrSBMI;
(*==============================================================
Version : 1.00 29 Apr 1989 C. Lins
Compiler : TopSpeed Modula-2
Component: Monolithic Structure String (Opaque version)
Sequential Bounded Managed Iterator
REVISION HISTORY
v1.00 29 Apr 1989 C. Lins:
Initial implementation.
==============================================================*)
FROM JPIStorage IMPORT
(*--Proc*) Allocate, Deallocate;
FROM ErrorHandling IMPORT
(*--Type*) HandlerProc,
(*--Proc*) NullHandler, ExitOnError, Raise;
FROM Items IMPORT
(*--Cons*) NullItem,
(*--Type*) Item, AssignProc, CompareProc, DisposeProc,
AccessProc, LoopAccessProc, LoopChangeProc;
FROM Relations IMPORT
(*--Type*) Relation;
FROM StrEnum IMPORT
(*--Type*) Exceptions, Operations, ComponentID;
FROM TypeManager IMPORT
(*--Cons*) NullType,
(*--Type*) TypeID,
(*--Proc*) AssignOf, DisposeOf, CompareOf;
(*-----------------------*)
TYPE Substring = ARRAY StringSize OF Item;
TYPE BoundedString = RECORD
dataID : TypeID; (*-- data type identifier *)
size : StringSize; (*-- Maximum String Size *)
length : CARDINAL; (*-- Current String Length *)
items : Substring; (*-- ARRAY[1..size] of Items *)
END (*-- BoundedString *);
TYPE String = POINTER TO BoundedString;
(*---------------------------------*)
(*-- EXCEPTIONS --*)
VAR stringError : Exceptions;
VAR handler : ARRAY Exceptions OF HandlerProc;
(*-----------------------*)
PROCEDURE StringError () : Exceptions (*-- out *);
BEGIN
RETURN stringError;
END StringError;
(*----------------------------*)
PROCEDURE GetHandler ( ofError : Exceptions (*-- in *))
: HandlerProc (*-- out *);
BEGIN
RETURN handler[ofError];
END GetHandler;
(*----------------------------*)
PROCEDURE SetHandler ( ofError : Exceptions (*-- in *);
toHandler : HandlerProc (*-- in *));
BEGIN
handler[ofError] := toHandler;
END SetHandler;
(*----------------------------*)
PROCEDURE RaiseErrIn ( theRoutine : Operations (*-- in *);
theError : Exceptions (*-- in *));
BEGIN
stringError := theError;
Raise(ComponentID + ModuleID, theRoutine, theError, handler[theError]);
END RaiseErrIn;
(*----------------------------*)
(*---------------------------------*)
(*-- LOCAL ROUTINES --*)
PROCEDURE LengthSubstr (VAR theSubstring : ARRAY OF Item (*-- in *))
: CARDINAL (*-- out *);
BEGIN
IF (HIGH(theSubstring) = 0) & (theSubstring[0] = NullItem) THEN
RETURN 0;
END (*--if*);
RETURN HIGH(theSubstring) + 1;
END LengthSubstr;
(*----------------------------*)
PROCEDURE FromToOK ( fromIndex : Position (*-- in *);
toIndex : Position (*-- in *);
stringLength : CARDINAL (*-- in *))
: BOOLEAN (*-- out *);
(*-- Checks whether: fromPosition ▓ toPosition ▓ stringLength. Takes
-- advantage of the fact that if toIndex is ▓ the stringLength and
-- fromIndex is ▓ toIndex, then fromIndex must also be ▓ stringLength. *)
BEGIN
RETURN (toIndex <= stringLength) & (fromIndex <= toIndex);
END FromToOK;
(*----------------------------*)
(*---------------------------------*)
(*-- CONSTRUCTORS --*)
PROCEDURE Create ( withSizeOf : StringSize (*-- in *);
theDataType : TypeID (*-- in *))
: String (*-- out *);
CONST staticSize = SIZE(BoundedString)-SIZE(Substring);
CONST itemSize = SIZE(Item);
VAR newString : String;
BEGIN
IF (withSizeOf <= MAX(StringSize)) THEN
Allocate(newString, staticSize + itemSize * withSizeOf);
IF (newString # NIL) THEN
WITH newString^ DO
dataID := theDataType;
size := withSizeOf;
length := 0;
END (*--with*);
RETURN newString;
END (*--if*);
END (*--if*);
RaiseErrIn(create, overflow);
RETURN NullString;
END Create;
(*----------------------------*)
PROCEDURE Destroy (VAR theString : String (*-- inout *));
CONST staticSize = SIZE(BoundedString)-SIZE(Substring);
CONST itemSize = SIZE(Item);
BEGIN
Clear(theString);
IF (stringError = noerr) THEN
Deallocate(theString, staticSize + itemSize * theString^.size);
END (*--if*);
END Destroy;
(*----------------------------*)
PROCEDURE Clear (VAR theString : String (*-- inout *));
VAR index : CARDINAL;
free : DisposeProc;
BEGIN
stringError := noerr;
IF (theString # NIL) THEN
WITH theString^ DO
free := DisposeOf(dataID);
FOR index := MIN(StringSize) TO length DO
free(items[index]);
END (*--for*);
length := 0;
END (*--with*);
ELSE
RaiseErrIn(clear, undefined);
END (*--if*);
END Clear;
(*----------------------------*)
PROCEDURE Assign ( fromString : String (*-- in *);
VAR toString : String (*-- inout *));
VAR index : CARDINAL;
assignment : AssignProc;
BEGIN
stringError := noerr;
IF (fromString = NIL) THEN
RaiseErrIn(assign, undefined);
ELSIF (fromString # toString) THEN
IF (toString = NIL) THEN
toString := Create(fromString^.size, fromString^.dataID);
ELSIF (fromString^.length <= toString^.size) THEN
Clear(toString);
toString^.dataID := fromString^.dataID;
ELSE
RaiseErrIn(assign, overflow);
END (*--if*);
IF (stringError = noerr) THEN
WITH fromString^ DO
assignment := AssignOf(dataID);
FOR index := MIN(StringSize) TO length DO
toString^.items[index] := assignment(items[index]);
END (*--for*);
toString^.length := length;
END (*--with*);
END (*--if*);
END (*--if*);
END Assign;
(*----------------------------*)
PROCEDURE Prepend ( theString : String (*-- in *);
VAR toString : String (*-- inout *));
BEGIN
Insert(theString, toString, 1);
END Prepend;
(*----------------------------*)
PROCEDURE Append ( theString : String (*-- in *);
VAR toString : String (*-- inout *));
BEGIN
Insert(theString, toString, LengthOf(toString) + 1);
END Append;
(*----------------------------*)
PROCEDURE Insert ( theString : String (*-- in *);
VAR toString : String (*-- inout *);
theIndex : Position (*-- in *));
VAR newLength : CARDINAL;
index : CARDINAL;
assignment: AssignProc;
BEGIN
stringError := noerr;
IF (theString # NIL) & (toString # NIL) THEN
IF (theString^.dataID = toString^.dataID) THEN
WITH toString^ DO
newLength := theString^.length + length;
IF (theIndex > length + 1) THEN
RaiseErrIn(insert, positionerr);
ELSIF (newLength > size) THEN
RaiseErrIn(insert, overflow);
ELSE
assignment := AssignOf(dataID);
FOR index := length TO theIndex BY -1 DO
items[index + theString^.length] := items[index];
END (*--for*);
FOR index := MIN(StringSize) TO theString^.length DO
items[theIndex + index - 1] := assignment(theString^.items[index]);
END (*--for*);
length := newLength;
END (*--if*);
END (*--with*);
ELSE
RaiseErrIn(insert, typeerror);
END (*--if*);
ELSE
RaiseErrIn(insert, undefined);
END (*--if*);
END Insert;
(*----------------------------*)
PROCEDURE Delete (VAR theString : String (*-- inout *);
fromIndex : Position (*-- in *);
toIndex : Position (*-- in *));
VAR index : CARDINAL;
offset : CARDINAL;
free : DisposeProc;
BEGIN
stringError := noerr;
IF (theString # NIL) THEN
WITH theString^ DO
IF FromToOK(fromIndex, toIndex, length) THEN
free := DisposeOf(dataID);
offset := toIndex - fromIndex + 1;
FOR index := toIndex + 1 TO length DO
free(items[index - offset]);
items[index - offset] := items[index];
END (*--for*);
DEC(length, offset);
ELSE
RaiseErrIn(delete, positionerr);
END (*--if*);
END (*--with*);
ELSE
RaiseErrIn(delete, undefined);
END (*--if*);
END Delete;
(*----------------------------*)
PROCEDURE Replace (VAR theString : String (*-- inout *);
theIndex : Position (*-- in *);
withString : String (*-- in *));
VAR endPosition : CARDINAL;
index : CARDINAL;
free : DisposeProc;
assignment : AssignProc;
BEGIN
stringError := noerr;
IF (theString # NIL) & (withString # NIL) THEN
IF (theString^.dataID = withString^.dataID) THEN
endPosition := theIndex + withString^.length - 1;
WITH theString^ DO
IF (theIndex <= length) & (endPosition <= size) THEN
free := DisposeOf(theString^.dataID);
assignment := AssignOf(theString^.dataID);
FOR index := MIN(StringSize) TO withString^.length DO
free(items[theIndex + index - 1]);
items[theIndex + index - 1] := assignment(withString^.items[index]);
END (*--for*);
IF (endPosition > length) THEN
length := endPosition;
END (*--if*);
ELSE
RaiseErrIn(replace, positionerr);
END (*--if*);
END (*--with*);
ELSE
RaiseErrIn(replace, typeerror);
END (*--if*);
ELSE
RaiseErrIn(replace, undefined);
END (*--if*);
END Replace;
(*----------------------------*)
PROCEDURE SetItem (VAR theString : String (*-- inout *);
theIndex : Position (*-- in *);
theItem : Item (*-- in *));
BEGIN
stringError := noerr;
IF (theString # NIL) THEN
WITH theString^ DO
IF (theIndex <= length) THEN
items[theIndex] := theItem;
ELSE
RaiseErrIn(setitem, positionerr);
END (*--if*);
END (*--with*);
ELSE
RaiseErrIn(setitem, undefined);
END (*--if*);
END SetItem;
(*----------------------------*)
PROCEDURE Construct (VAR theString : String (*-- inout *);
theDataType : TypeID (*-- in *);
VAR theSubstring : ARRAY OF Item (*-- in *));
VAR index : CARDINAL;
lenSubstr : CARDINAL;
newString : String;
BEGIN
stringError := noerr;
lenSubstr := LengthSubstr(theSubstring);
IF (theString # NIL) THEN
IF (lenSubstr = 0) THEN
Clear(theString);
RETURN;
END (*--if*);
ELSIF (lenSubstr = 0) THEN
(*-- ERROR: cannot create string of length zero *)
RaiseErrIn(construct, positionerr);
RETURN;
ELSE
newString := Create(lenSubstr, theDataType);
IF (stringError = noerr) THEN
theString := newString;
ELSE
RETURN;
END (*--if*);
END (*--if*);
WITH theString^ DO
(*-- The minimum lenSubstr is one (1). *)
index := MIN(Position);
WHILE (index <= lenSubstr) & (theSubstring[index - 1] # NullItem) DO
items[index] := theSubstring[index - 1];
INC(index);
END (*--while*);
length := index - 1;
END (*--with*);
END Construct;
(*----------------------------*)
(*---------------------------------*)
(*-- SELECTORS --*)
PROCEDURE IsDefined ( theString : String (*-- in *))
: BOOLEAN (*-- out *);
BEGIN
RETURN (theString # NIL);
END IsDefined;
(*----------------------------*)
PROCEDURE IsEmpty ( theString : String (*-- in *))
: BOOLEAN (*-- out *);
BEGIN
stringError := noerr;
IF (theString # NIL) THEN
RETURN theString^.length = 0;
END (*--if*);
RaiseErrIn(isempty, undefined);
RETURN TRUE;
END IsEmpty;
(*----------------------------*)
PROCEDURE LengthOf ( theString : String (*-- in *))
: CARDINAL (*-- out *);
BEGIN
stringError := noerr;
IF (theString # NIL) THEN
RETURN theString^.length;
END (*--if*);
RaiseErrIn(lengthof, undefined);
RETURN 0;
END LengthOf;
(*----------------------------*)
PROCEDURE SizeOf ( theString : String (*-- in *))
: CARDINAL (*-- out *);
BEGIN
stringError := noerr;
IF (theString # NIL) THEN
RETURN theString^.size;
END (*--if*);
RaiseErrIn(sizeof, undefined);
RETURN 0;
END SizeOf;
(*----------------------------*)
PROCEDURE TypeOf ( theString : String (*-- in *))
: TypeID (*-- out *);
BEGIN
stringError := noerr;
IF (theString # NIL) THEN
RETURN theString^.dataID;
END (*--if*);
RaiseErrIn(typeof, undefined);
RETURN NullType;
END TypeOf;
(*----------------------------*)
PROCEDURE Compare ( left : String (*-- in *);
right : String (*-- in *))
: Relation (*-- out *);
VAR index : CARDINAL; (*-- Index into items arrays *)
minLength : CARDINAL; (*-- Smaller of the two string lengths *)
relOrder : Relation; (*-- Most recent comparison result *)
comparison: CompareProc;
BEGIN
stringError := noerr;
relOrder := incomparable;
IF (left # NIL) & (right # NIL) THEN
IF (left^.dataID = right^.dataID) THEN
WITH left^ DO
comparison := CompareOf(dataID);
IF (length = right^.length) THEN
relOrder := equal;
minLength := length;
ELSIF (length < right^.length) THEN
relOrder := less;
minLength := length;
ELSE
relOrder := greater;
minLength := right^.length;
END (*--if*);
END (*--with*);
index := MIN(StringSize);
WITH left^ DO
LOOP
IF (index > minLength) THEN
EXIT (*--loop*);
END (*--if*);
relOrder := comparison(items[index], right^.items[index]);
IF (relOrder # equal) THEN
EXIT (*--loop*);
END (*--if*);
INC(index);
END (*--loop*);
END (*--with*);
ELSE
RaiseErrIn(compare, typeerror);
END (*--if*);
ELSE
RaiseErrIn(compare, undefined);
END (*--if*);
RETURN relOrder;
END Compare;
(*----------------------------*)
PROCEDURE IsEqual ( left : String (*-- in *);
right : String (*-- in *))
: BOOLEAN (*-- out *);
BEGIN
stringError := noerr;
RETURN Compare(left, right) = equal;
END IsEqual;
(*----------------------------*)
PROCEDURE ItemOf ( theString : String (*-- in *);
theIndex : Position (*-- in *))
: Item (*-- out *);
BEGIN
stringError := noerr;
IF (theString # NIL) THEN
WITH theString^ DO
IF (theIndex <= length) THEN
RETURN items[theIndex];
END (*--if*);
END (*--with*);
RaiseErrIn(itemof, positionerr);
ELSE
RaiseErrIn(itemof, undefined);
END (*--if*);
RETURN NullItem;
END ItemOf;
(*----------------------------*)
PROCEDURE SliceOf ( theString : String (*-- in *);
fromIndex : Position (*-- in *);
toIndex : Position (*-- in *);
VAR theSlice : ARRAY OF Item (*-- out *));
VAR index : CARDINAL;
sliceSize : CARDINAL;
BEGIN
stringError := noerr;
IF (theString # NIL) THEN
WITH theString^ DO
IF FromToOK(fromIndex, toIndex, length) THEN
sliceSize := toIndex - fromIndex;
IF (sliceSize <= HIGH(theSlice)) THEN
FOR index := fromIndex TO toIndex DO
theSlice[index - fromIndex] := items[index];
END (*--for*);
IF (sliceSize < HIGH(theSlice)) THEN
theSlice[sliceSize + 1] := NullItem;
END (*--if*);
ELSE
RaiseErrIn(sliceof, overflow);
END (*--if*);
ELSE
RaiseErrIn(sliceof, positionerr);
END (*--if*);
END (*--with*);
ELSE
RaiseErrIn(sliceof, undefined);
END (*--if*);
END SliceOf;
(*----------------------------*)
PROCEDURE SubstringOf( theString : String (*-- in *);
VAR toSubstring: ARRAY OF Item (*-- out *));
VAR index : CARDINAL;
copyLength : CARDINAL; (*-- # of items to copy into substring *)
BEGIN
stringError := noerr;
IF (theString # NIL) THEN
WITH theString^ DO
IF (length > HIGH(toSubstring) + 1) THEN
RaiseErrIn(substringof, overflow);
copyLength := HIGH(toSubstring) + 1;
ELSE
copyLength := length;
END (*--if*);
FOR index := MIN(StringSize) TO copyLength DO
toSubstring[index - 1] := items[index];
END (*--for*);
IF (copyLength < HIGH(toSubstring)) THEN
toSubstring[copyLength + 1] := NullItem;
END (*--if*);
END (*--with*);
ELSE
RaiseErrIn(substringof, undefined);
END (*--if*);
END SubstringOf;
(*----------------------------*)
(*---------------------------------*)
(*-- ITERATORS --*)
PROCEDURE LoopOver ( theString : String (*-- in *);
process : LoopAccessProc (*-- in *));
VAR index : CARDINAL;
BEGIN
stringError := noerr;
IF (theString # NIL) THEN
WITH theString^ DO
FOR index := MIN(StringSize) TO length DO
IF ~process(items[index]) THEN
RETURN;
END (*--if*);
END (*--for*);
END (*--with*);
ELSE
RaiseErrIn(loopover, undefined);
END (*--if*);
END LoopOver;
(*----------------------------*)
PROCEDURE LoopChange ( theString : String (*-- in *);
process : LoopChangeProc (*-- in *));
VAR index : CARDINAL;
BEGIN
stringError := noerr;
IF (theString # NIL) THEN
WITH theString^ DO
FOR index := MIN(StringSize) TO length DO
IF ~process(items[index]) THEN
RETURN;
END (*--if*);
END (*--for*);
END (*--with*);
ELSE
RaiseErrIn(loopchange, undefined);
END (*--if*);
END LoopChange;
(*----------------------------*)
PROCEDURE Traverse ( theString : String (*-- in *);
process : AccessProc (*-- in *));
VAR index : CARDINAL;
BEGIN
stringError := noerr;
IF (theString # NIL) THEN
WITH theString^ DO
FOR index := MIN(StringSize) TO length DO
process(items[index]);
END (*--for*);
END (*--with*);
ELSE
RaiseErrIn(traverse, undefined);
END (*--if*);
END Traverse;
(*----------------------------*)
(*~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
(*~~ Module Initialization ~~*)
BEGIN
FOR stringError := MIN(Exceptions) TO MAX(Exceptions) DO
SetHandler(stringError, ExitOnError);
END (*--for*);
SetHandler(noerr, NullHandler);
stringError := noerr;
END StrSBMI.