IMPLEMENTATION MODULE StrSUUN;
(*==========================================================
    Version  : 2.00  30 Apr 1989  C. Lins
    Compiler : TopSpeed Modula-2
    Code Size: R-  bytes
    Component: Monolithic Structure String (Opaque version)
               Sequential Unbounded Unmanaged Non-Iterator

    REVISION HISTORY
    v2.00  30 Apr 1989  C. Lins:
        Initial re-implementation from StringSUUI module.

    (C) Copyright 1989 Charles A. Lins
==========================================================*)

FROM JPIStorage IMPORT
    (*--Proc*) Allocate, Deallocate;

FROM ErrorHandling IMPORT
    (*--Type*) HandlerProc,
    (*--Proc*) NullHandler, ExitOnError, Raise;

FROM Items IMPORT
    (*--Cons*) NullItem,
    (*--Type*) Item, CompareProc;

FROM Relations IMPORT
    (*--Type*) Relation;

FROM StrEnum IMPORT
    (*--Type*) Exceptions, Operations, ComponentID;

FROM TypeManager IMPORT
    (*--Cons*) NullType,
    (*--Type*) TypeID,
    (*--Proc*) CompareOf;

    (*-----------------------*)


TYPE  Substring  = POINTER TO ARRAY Position OF Item;

TYPE  UnboundedString = RECORD
	dataID : TypeID;      (*-- data type of the string *)
	size   : CARDINAL;    (*-- allocated size *)
        length : CARDINAL;    (*-- Current String Length *)
        items  : Substring;   (*-- ARRAY[1..length] of Items *)
      END (*-- UnboundedString *);

TYPE  String = POINTER TO UnboundedString;


    (*-----------------------*)


VAR   stringError : Exceptions;
VAR   handler     : ARRAY Exceptions OF HandlerProc;

    (*-----------------------*)

PROCEDURE StringError ()              : Exceptions  (*-- out   *);
BEGIN
  RETURN stringError;
END StringError;
(*----------------------------*)

PROCEDURE GetHandler  (    theError   : Exceptions  (*-- in    *))
                                      : HandlerProc (*-- out   *);
BEGIN
  RETURN handler[theError];
END GetHandler;
(*----------------------------*)

PROCEDURE SetHandler  (    theError   : Exceptions  (*-- in    *);
                           theHandler : HandlerProc (*-- in    *));
BEGIN
  handler[theError] := theHandler;
END SetHandler;
(*----------------------------*)

PROCEDURE RaiseErrIn  (    theRoutine : Operations    (*-- in    *);
                           theError   : Exceptions    (*-- in    *));
BEGIN
  stringError := theError;
  Raise(ComponentID + ModuleID, theRoutine, theError, handler[theError]);
END RaiseErrIn;
(*----------------------------*)


    (*-----------------------*)

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   *);
BEGIN
  RETURN (toIndex <= stringLength) & (fromIndex <= toIndex);
END FromToOK;
(*----------------------------*)


TYPE  SetOptions = (preservevalue, trashvalue);
VAR   setSizeOK  : BOOLEAN;

PROCEDURE SetSize   (VAR theString   : UnboundedString (*-- inout *);
                         totheSize   : CARDINAL        (*-- in    *);
                         valueOption : SetOptions      (*-- in    *));

CONST itemSize = SIZE(Item);
VAR   newItems : Substring;
      index    : CARDINAL; (*-- loop index over items *)

BEGIN
  setSizeOK := TRUE;
  WITH theString DO
    IF (totheSize = 0) THEN
      Deallocate(items, itemSize * size);
      size := 0;
    ELSIF (items = NIL) THEN
      Allocate(items, itemSize * totheSize);
      IF (items = NIL) THEN
        setSizeOK := FALSE;
        RETURN;
      END (*--if*);
      size := totheSize;

    ELSIF (totheSize > length) THEN
      Allocate(newItems, itemSize * totheSize);
      IF (newItems = NIL) THEN
        setSizeOK := FALSE;
        RETURN;
      END (*--if*);

      IF (valueOption = preservevalue) THEN
        FOR index := MIN(Position) TO length DO
          newItems^[index] := items^[index];
        END (*--for*);
      END (*--if*);

      Deallocate(items, itemSize * size);
      items := newItems;
      size  := totheSize;
    END (*--if*);
    length := totheSize;
  END (*--with*);
END SetSize;
(*----------------------------*)


    (*-----------------------*)

PROCEDURE Create    (    theDataType: TypeID     (*-- in    *)) 
				    : String     (*-- out   *);

VAR   newString : String;

BEGIN
  stringError := noerr;
  Allocate(newString, SIZE(UnboundedString));
  IF (newString # NIL) THEN
    WITH newString^ DO
      dataID := theDataType;
      size   := 0;
      length := 0;
      items  := NIL;
    END (*--with*);
    RETURN newString;
  END (*--if*);
  RaiseErrIn(create, overflow);
  RETURN NullString;
END Create;
(*----------------------------*)


PROCEDURE Destroy   (VAR theString  : String     (*-- inout *));
BEGIN
  stringError := noerr;
  IF (theString # NIL) THEN
    SetSize(theString^, 0, trashvalue);
    Deallocate(theString, SIZE(UnboundedString));
  ELSE
    RaiseErrIn(destroy, undefined);
  END (*--if*);
END Destroy;
(*----------------------------*)


PROCEDURE Clear     (VAR theString  : String     (*-- inout *));
BEGIN
  stringError := noerr;
  IF (theString # NIL) THEN
    SetSize(theString^, 0, trashvalue);
  ELSE
    RaiseErrIn(clear, undefined);
  END (*--if*);
END Clear;
(*----------------------------*)


PROCEDURE Assign    (    theString  : String     (*-- in    *);
                     VAR toString   : String     (*-- inout *));

VAR   index : CARDINAL; (*-- loop index over items *)

BEGIN
  stringError := noerr;
  IF (theString # NIL) THEN
    IF (theString # toString) THEN
      IF (toString # NIL) THEN
        SetSize(toString^, theString^.length, trashvalue);
        IF ~setSizeOK THEN
          RaiseErrIn(assign, overflow);
          RETURN;
        END (*--if*);
      ELSE
        toString := Create(theString^.dataID);
        IF (stringError # noerr) THEN
          RETURN;
        END (*--if*);
      END (*--if*);

      WITH theString^ DO
        FOR index := MIN(Position) TO length DO
          toString^.items^[index] := items^[index];
        END (*--for*);
      END (*--with*);
    END (*--if*);
  ELSE
    RaiseErrIn(assign, undefined);
  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   oldLength : CARDINAL;
      newLength : CARDINAL;
      index     : CARDINAL; (*-- loop index over items *)

BEGIN
  stringError := noerr;
  IF (toString # NIL) & (theString # NIL) THEN

    WITH toString^ DO
      oldLength := length;
      newLength := theString^.length + length;

      IF (theIndex > oldLength + 1) THEN
        RaiseErrIn(insert, positionerr);
      ELSE
        SetSize(toString^, newLength, preservevalue);
        IF setSizeOK THEN

          FOR index := oldLength TO theIndex BY -1 DO
            items^[index + theString^.length] := items^[index];
          END (*--for*);

          FOR index := MIN(Position) TO theString^.length DO
            items^[theIndex + index - 1] := theString^.items^[index];
          END (*--for*);
        ELSE
          RaiseErrIn(insert, overflow);
        END (*--if*);
      END (*--if*);
    END (*--with*);
  ELSE
    RaiseErrIn(insert, undefined);
  END (*--if*);
END Insert;
(*----------------------------*)


PROCEDURE Delete    (VAR theString  : String     (*-- inout *);
                         fromIndex  : Position   (*-- in    *);
                         toIndex    : Position   (*-- in    *));

VAR   index  : CARDINAL; (*-- loop index over items *)
      offset : CARDINAL; (*-- distance to move items *)

BEGIN
  stringError := noerr;
  IF (theString # NIL) THEN
    WITH theString^ DO
      IF FromToOK(fromIndex, toIndex, length) THEN
        offset := toIndex - fromIndex + 1;
        FOR index := toIndex + 1 TO length DO
          items^[index - offset] := items^[index];
        END (*--for*);
        SetSize(theString^, length - offset, preservevalue);
      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   endIndex : CARDINAL;
      index    : CARDINAL; (*-- loop index over items *)

BEGIN
  stringError := noerr;
  IF (theString # NIL) & (withString # NIL) THEN
    WITH theString^ DO
      IF (theIndex <= length) THEN

        endIndex := theIndex + withString^.length - 1;
        IF (endIndex > length) THEN
          SetSize(theString^, endIndex, preservevalue);
          IF ~setSizeOK THEN
            RaiseErrIn(replace, overflow);
            RETURN;
          END (*--if*);
        END (*--if*);

        FOR index := MIN(Position) TO withString^.length DO
          items^[theIndex + index - 1] := withString^.items^[index];
        END (*--for*);
      ELSE
        RaiseErrIn(replace, positionerr);
      END (*--if*);
    END (*--with*);
  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    *);
                         theSubstring: ARRAY OF Item (*-- in    *));

VAR   index     : CARDINAL; (*-- loop index over items *)
      lenSubstr : CARDINAL; (*-- # of items in substring *)
      newString : String;   (*-- new string, if necessary *)

BEGIN
  stringError := noerr;
  lenSubstr := LengthSubstr(theSubstring);

  IF (theString # NIL) THEN
    IF (lenSubstr = 0) THEN
      Clear(theString);
      RETURN;
    END (*--if*);
  ELSIF (lenSubstr = 0) THEN
    RaiseErrIn(construct, positionerr);
  ELSE
    newString := Create(theDataType);
    IF (stringError # noerr) THEN
      RETURN;
    END (*--if*);
    theString := newString;
  END (*--if*);

  SetSize(theString^, lenSubstr, trashvalue);
  IF setSizeOK THEN
    WITH theString^ DO
      index := MIN(Position);
      WHILE (index <= lenSubstr) &
            (theSubstring[index - 1] # NullItem) DO
        items^[index] := theSubstring[index - 1];
        INC(index);
      END (*--while*);
    END (*--with*);
    SetSize(theString^, index-1, preservevalue);
  ELSE
    RaiseErrIn(construct, overflow);
  END (*--if*);
END Construct;
(*----------------------------*)


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 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(Position);
      LOOP
        IF (index > minLength) THEN
          EXIT (*--loop*);
        END (*--if*);

        IF (comparison(left^.items^[index], right^.items^[index]) = less) THEN
          relOrder := less;
          EXIT (*--loop*);
        ELSIF (comparison(left^.items^[index], right^.items^[index]) = greater) THEN
          relOrder := greater;
          EXIT (*--loop*);
        END (*--if*);

        INC(index);

      END (*--loop*);
    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
  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; (*-- loop index over items *)
      sliceSize : CARDINAL; (*-- # items between from & to indexes *)

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; (*-- loop index over items *)
      copyLength : CARDINAL; (*-- # 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(Position) 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;
(*----------------------------*)


BEGIN
  FOR stringError := MIN(Exceptions) TO MAX(Exceptions) DO
    SetHandler(stringError, ExitOnError);
  END (*--for*);
  SetHandler(noerr, NullHandler);
  stringError := noerr;
END StrSUUN.