Update copyright years.

[thirdparty/gcc.git] / gcc / m2 / gm2-libs / DynamicStrings.mod

(* DynamicStrings.mod provides a dynamic string type and procedures.

Copyright (C) 2001-2024 Free Software Foundation, Inc.
Contributed by Gaius Mulley <gaius.mulley@southwales.ac.uk>.

This file is part of GNU Modula-2.

GNU Modula-2 is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3, or (at your option)
any later version.

GNU Modula-2 is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.

You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
<http://www.gnu.org/licenses/>.  *)

IMPLEMENTATION MODULE DynamicStrings ;

FROM libc IMPORT strlen, strncpy, write, exit, snprintf ;
FROM StrLib IMPORT StrLen ;
FROM Storage IMPORT ALLOCATE, DEALLOCATE ;
FROM Assertion IMPORT Assert ;
FROM SYSTEM IMPORT ADR ;
FROM ASCII IMPORT nul, tab, lf ;
FROM M2RTS IMPORT Halt ;

CONST
   MaxBuf   = 127 ;
   PoisonOn = FALSE ;    (* to enable debugging of this module, turn on PoisonOn and DebugOn.  *)
   DebugOn  = FALSE ;
   CheckOn  = FALSE ;    (* to enable debugging of users of this module turn on                *)
   TraceOn  = FALSE ;    (* CheckOn and TraceOn.  Enabling both of these is very expensive.    *)

TYPE
   Contents = RECORD
                 buf : ARRAY [0..MaxBuf-1] OF CHAR ;
                 len : CARDINAL ;
                 next: String ;
              END ;

   Descriptor = POINTER TO descriptor ;

   String = POINTER TO stringRecord ;

   DebugInfo = RECORD
                  next: String ;   (* a mechanism for tracking used/lost strings *)
                  file: ADDRESS ;
                  line: CARDINAL ;
                  proc: ADDRESS ;
               END ;

   stringRecord = RECORD
                     contents: Contents ;
                     head    : Descriptor ;
                     debug   : DebugInfo ;
                  END ;

   desState = (inuse, marked, onlist, poisoned) ;

   descriptor = RECORD
                   charStarUsed : BOOLEAN ;     (* can we garbage collect this? *)
                   charStar     : ADDRESS ;
                   charStarSize : CARDINAL ;
                   charStarValid: BOOLEAN ;
                   state        : desState ;
                   garbage      : String ;      (* temporary strings to be destroyed
                                                   once this string is killed *)
                END ;

   frame    = POINTER TO frameRec ;
   frameRec =            RECORD
                            alloc, dealloc: String ;
                            next          : frame ;
                         END ;

VAR
   Initialized: BOOLEAN ;
   frameHead  : frame ;
   captured   : String ;  (* debugging aid.  *)


(* writeStringDesc write out debugging information about string, s.  *)

PROCEDURE writeStringDesc (s: String) ;
BEGIN
   writeCstring (s^.debug.file) ; writeString (':') ;
   writeCard (s^.debug.line) ; writeString (':') ;
   writeCstring (s^.debug.proc) ; writeString (' ') ;
   writeAddress (s) ;
   writeString (' ') ;
   CASE s^.head^.state OF

   inuse   :  writeString ("still in use (") ; writeCard (s^.contents.len) ; writeString (") characters") |
   marked  :  writeString ("marked") |
   onlist  :  writeString ("on a (lost) garbage list") |
   poisoned:  writeString ("poisoned")

   ELSE
      writeString ("unknown state")
   END
END writeStringDesc ;


(*
   writeNspace -
*)

PROCEDURE writeNspace (n: CARDINAL) ;
BEGIN
   WHILE n > 0 DO
      writeString (' ') ;
      DEC (n)
   END
END writeNspace ;


(*
   DumpStringInfo -
*)

PROCEDURE DumpStringInfo (s: String; i: CARDINAL) ;
BEGIN
   IF s # NIL
   THEN
      writeNspace (i) ; writeStringDesc (s) ; writeLn ;
      IF s^.head^.garbage # NIL
      THEN
         writeNspace (i) ; writeString ('garbage list:') ; writeLn ;
         REPEAT
            s := s^.head^.garbage ;
            DumpStringInfo (s, i+1) ; writeLn
         UNTIL s = NIL
      END
   END
END DumpStringInfo ;


PROCEDURE stop ;
END stop ;


(*
   PopAllocationExemption - test to see that all strings are deallocated, except
                            string e since the last push.
                            Post-condition: it pops to the previous allocation/deallocation
                            lists.

                            If halt is true then the application terminates
                            with an exit code of 1.
*)

PROCEDURE PopAllocationExemption (halt: BOOLEAN; e: String) : String ;
VAR
   s: String ;
   b: BOOLEAN ;
BEGIN
   Init ;
   IF CheckOn
   THEN
      IF frameHead = NIL
      THEN
         stop ;
         Halt ("mismatched number of PopAllocation's compared to PushAllocation's",
               __FILE__, __FUNCTION__, __LINE__) ;
         (* writeString ("mismatched number of PopAllocation's compared to PushAllocation's") *)
      ELSE
         IF frameHead^.alloc # NIL
         THEN
            b := FALSE ;
            s := frameHead^.alloc ;
            WHILE s # NIL DO
               IF NOT ((e = s) OR IsOnGarbage (e, s) OR IsOnGarbage (s, e))
               THEN
                  IF NOT b
                  THEN
                     writeString ("the following strings have been lost") ; writeLn ;
                     b := TRUE
                  END ;
                  DumpStringInfo (s, 0)
               END ;
               s := s^.debug.next
            END ;
            IF b AND halt
            THEN
               exit (1)
            END
         END ;
         frameHead := frameHead^.next
      END
   END ;
   RETURN e
END PopAllocationExemption ;


(*
   PopAllocation - test to see that all strings are deallocated since
                   the last push.  Then it pops to the previous
                   allocation/deallocation lists.

                   If halt is true then the application terminates
                   with an exit code of 1.
*)

PROCEDURE PopAllocation (halt: BOOLEAN) ;
BEGIN
   IF CheckOn
   THEN
      IF PopAllocationExemption (halt, NIL) = NIL
      THEN
      END
   END
END PopAllocation ;


(*
   PushAllocation - pushes the current allocation/deallocation lists.
*)

PROCEDURE PushAllocation ;
VAR
   f: frame ;
BEGIN
   IF CheckOn
   THEN
      Init ;
      NEW (f) ;
      WITH f^ DO
         next := frameHead ;
         alloc := NIL ;
         dealloc := NIL
      END ;
      frameHead := f
   END
END PushAllocation ;


(*
   doDSdbEnter -
*)

PROCEDURE doDSdbEnter ;
BEGIN
   IF CheckOn
   THEN
      PushAllocation
   END
END doDSdbEnter ;


(*
   doDSdbExit -
*)

PROCEDURE doDSdbExit (s: String) ;
BEGIN
   IF CheckOn
   THEN
      s := PopAllocationExemption (TRUE, s)
   END
END doDSdbExit ;


(*
   DSdbEnter -
*)

PROCEDURE DSdbEnter ;
BEGIN
END DSdbEnter ;


(*
   DSdbExit -
*)

PROCEDURE DSdbExit (s: String) ;
BEGIN
END DSdbExit ;


(*
 *   #undef GM2_DEBUG_DYNAMICSTINGS
 *   #if defined(GM2_DEBUG_DYNAMICSTINGS)
 *   #  define DSdbEnter doDSdbEnter
 *   #  define DSdbExit  doDSdbExit
 *   #  define CheckOn   TRUE
 *   #  define TraceOn   TRUE
 *   #endif
 *)


PROCEDURE Capture (s: String) : CARDINAL ;
BEGIN
   captured := s ;
   RETURN 1
END Capture ;


(*
   Min -
*)

PROCEDURE Min (a, b: CARDINAL) : CARDINAL ;
BEGIN
   IF a < b
   THEN
      RETURN a
   ELSE
      RETURN b
   END
END Min ;


(*
   Max -
*)

PROCEDURE Max (a, b: CARDINAL) : CARDINAL ;
BEGIN
   IF a > b
   THEN
      RETURN a
   ELSE
      RETURN b
   END
END Max ;


(*
   writeString - writes a string to stdout.
*)

PROCEDURE writeString (a: ARRAY OF CHAR) ;
VAR
   i: INTEGER ;
BEGIN
   i := write (1, ADR (a), StrLen (a))
END writeString ;


(*
   writeCstring - writes a C string to stdout.
*)

PROCEDURE writeCstring (a: ADDRESS) ;
VAR
   i: INTEGER ;
BEGIN
   IF a = NIL
   THEN
      writeString ('(null)')
   ELSE
      i := write (1, a, strlen (a))
   END
END writeCstring ;


(*
   writeCard -
*)

PROCEDURE writeCard (c: CARDINAL) ;
VAR
   ch: CHAR ;
   i : INTEGER ;
BEGIN
   IF c > 9
   THEN
      writeCard (c DIV 10) ;
      writeCard (c MOD 10)
   ELSE
      ch := CHR (ORD ('0') + c) ;
      i := write (1, ADR (ch), 1)
   END
END writeCard ;


(*
   writeLongcard -
*)

PROCEDURE writeLongcard (l: LONGCARD) ;
VAR
   ch: CHAR ;
   i : INTEGER ;
BEGIN
   IF l > 16
   THEN
      writeLongcard (l DIV 16) ;
      writeLongcard (l MOD 16)
   ELSIF l < 10
   THEN
      ch := CHR (ORD ('0') + VAL (CARDINAL, l)) ;
      i := write(1, ADR(ch), 1)
   ELSIF l<16
   THEN
      ch := CHR (ORD ('a') + VAL(CARDINAL, l) - 10) ;
      i := write (1, ADR (ch), 1)
   END
END writeLongcard ;


(*
   writeAddress - writes out the address of a with a C style hex prefix.
*)

PROCEDURE writeAddress (a: ADDRESS) ;
VAR
   buffer: ARRAY [0..30] OF CHAR ;
BEGIN
   snprintf (ADR (buffer), SIZE (buffer), "0x%", a) ;
   writeString (buffer) ;
END writeAddress ;


(*
   writeLn - writes a newline.
*)

PROCEDURE writeLn ;
VAR
   ch: CHAR ;
   i : INTEGER ;
BEGIN
   ch := lf ;
   i := write (1, ADR (ch), 1)
END writeLn ;


(*
   AssignDebug - assigns, file, and, line, information to string, s.
*)

PROCEDURE AssignDebug (s: String; file: ARRAY OF CHAR; line: CARDINAL; proc: ARRAY OF CHAR) : String ;
VAR
   f, p: ADDRESS ;
BEGIN
   f := ADR (file) ;
   p := ADR (proc) ;
   WITH s^ DO
      ALLOCATE (debug.file, StrLen (file) + 1) ;
      IF strncpy(debug.file, f, StrLen(file)+1)=NIL
      THEN
      END ;
      debug.line := line ;
      ALLOCATE (debug.proc, StrLen (proc) + 1) ;
      IF strncpy (debug.proc, p, StrLen (proc) + 1) = NIL
      THEN
      END
   END ;
   RETURN( s )
END AssignDebug ;


(*
   CopyOut - copies string, s, to a.
*)

PROCEDURE CopyOut (VAR a: ARRAY OF CHAR; s: String) ;
VAR
   i, l: CARDINAL ;
BEGIN
   l := Min (HIGH (a) + 1, Length (s)) ;
   i := 0 ;
   WHILE i < l DO
      a[i] := char (s, i) ;
      INC (i)
   END ;
   IF i <= HIGH (a)
   THEN
      a[i] := nul
   END
END CopyOut ;


(*
   IsOn - returns TRUE if, s, is on one of the debug lists.
*)

PROCEDURE IsOn (list, s: String) : BOOLEAN ;
BEGIN
   WHILE (list # s) AND (list # NIL) DO
      list := list^.debug.next
   END ;
   RETURN list = s
END IsOn ;


(*
   AddTo - adds string, s, to, list.
*)

PROCEDURE AddTo (VAR list: String; s: String) ;
BEGIN
   IF list = NIL
   THEN
      list := s ;
      s^.debug.next := NIL
   ELSE
      s^.debug.next := list ;
      list := s
   END
END AddTo ;


(*
   SubFrom - removes string, s, from, list.
*)

PROCEDURE SubFrom (VAR list: String; s: String) ;
VAR
   p: String ;
BEGIN
   IF list = s
   THEN
      list := s^.debug.next ;
   ELSE
      p := list ;
      WHILE (p^.debug.next # NIL) AND (p^.debug.next # s) DO
         p := p^.debug.next
      END ;
      IF p^.debug.next = s
      THEN
         p^.debug.next := s^.debug.next
      ELSE
         (* not found, quit *)
         RETURN
      END
   END ;
   s^.debug.next := NIL
END SubFrom ;


(*
   AddAllocated - adds string, s, to the head of the allocated list.
*)

PROCEDURE AddAllocated (s: String) ;
BEGIN
   Init ;
   AddTo (frameHead^.alloc, s)
END AddAllocated ;


(*
   AddDeallocated - adds string, s, to the head of the deallocated list.
*)

PROCEDURE AddDeallocated (s: String) ;
BEGIN
   Init ;
   AddTo (frameHead^.dealloc, s)
END AddDeallocated ;


(*
   IsOnAllocated - returns TRUE if the string, s, has ever been allocated.
*)

PROCEDURE IsOnAllocated (s: String) : BOOLEAN ;
VAR
   f: frame ;
BEGIN
   Init ;
   f := frameHead ;
   REPEAT
      IF IsOn (f^.alloc, s)
      THEN
         RETURN TRUE
      ELSE
         f := f^.next
      END
   UNTIL f = NIL ;
   RETURN FALSE
END IsOnAllocated ;


(*
   IsOnDeallocated - returns TRUE if the string, s, has ever been deallocated.
*)

PROCEDURE IsOnDeallocated (s: String) : BOOLEAN ;
VAR
   f: frame ;
BEGIN
   Init ;
   f := frameHead ;
   REPEAT
      IF IsOn (f^.dealloc, s)
      THEN
         RETURN TRUE
      ELSE
         f := f^.next
      END
   UNTIL f = NIL ;
   RETURN FALSE
END IsOnDeallocated ;


(*
   SubAllocated - removes string, s, from the list of allocated strings.
*)

PROCEDURE SubAllocated (s: String) ;
VAR
   f: frame ;
BEGIN
   Init ;
   f := frameHead ;
   REPEAT
      IF IsOn (f^.alloc, s)
      THEN
         SubFrom (f^.alloc, s) ;
         RETURN
      ELSE
         f := f^.next
      END
   UNTIL f = NIL
END SubAllocated ;


(*
   SubDeallocated - removes string, s, from the list of deallocated strings.
*)

PROCEDURE SubDeallocated (s: String) ;
VAR
   f: frame ;
BEGIN
   Init ;
   f := frameHead ;
   REPEAT
      IF IsOn (f^.dealloc, s)
      THEN
         SubFrom (f^.dealloc, s) ;
         RETURN
      ELSE
         f := f^.next
      END
   UNTIL f = NIL
END SubDeallocated ;


(*
   SubDebugInfo - removes string, s, from the list of allocated strings.
*)

PROCEDURE SubDebugInfo (s: String) ;
BEGIN
   IF IsOnDeallocated (s)
   THEN
      Assert (NOT DebugOn) ;
      (* string has already been deallocated *)
      RETURN
   END ;
   IF IsOnAllocated (s)
   THEN
      SubAllocated (s) ;
      AddDeallocated (s)
   ELSE
      Assert (NOT DebugOn)
      (* string has not been allocated *)
   END
END SubDebugInfo ;


(*
   AddDebugInfo - adds string, s, to the list of allocated strings.
*)

PROCEDURE AddDebugInfo (s: String) ;
BEGIN
   WITH s^ DO
      debug.next := NIL ;
      debug.file := NIL ;
      debug.line := 0 ;
      debug.proc := NIL ;
   END ;
   IF CheckOn
   THEN
      AddAllocated (s)
   END
END AddDebugInfo ;


(*
   ConcatContents - add the contents of string, a, where, h, is the
                    total length of, a. The offset is in, o.
*)

PROCEDURE ConcatContents (VAR c: Contents; a: ARRAY OF CHAR; h, o: CARDINAL) ;
VAR
   i: CARDINAL ;
BEGIN
   i := c.len ;
   WHILE (o < h) AND (i < MaxBuf) DO
      c.buf[i] := a[o] ;
      INC (o) ;
      INC (i)
   END ;
   IF o < h
   THEN
      c.len := MaxBuf ;
      NEW (c.next) ;
      WITH c.next^ DO
         head := NIL ;
         contents.len := 0 ;
         contents.next := NIL ;
         ConcatContents (contents, a, h, o)
      END ;
      AddDebugInfo (c.next) ;
      c.next := AssignDebug (c.next, __FILE__, __LINE__, __FUNCTION__)
   ELSE
      c.len := i
   END
END ConcatContents ;


(*
   InitString - creates and returns a String type object.
                Initial contents are, a.
*)

PROCEDURE InitString (a: ARRAY OF CHAR) : String ;
VAR
   s: String ;
BEGIN
   NEW(s) ;
   WITH s^ DO
      WITH contents DO
         len := 0 ;
         next := NIL
      END ;
      ConcatContents (contents, a, StrLen (a), 0) ;
      NEW (head) ;
      WITH head^ DO
         charStarUsed  := FALSE ;
         charStar      := NIL ;
         charStarSize  := 0;
         charStarValid := FALSE ;
         garbage       := NIL ;
         state         := inuse ;
      END
   END ;
   AddDebugInfo (s) ;
   IF TraceOn
   THEN
      s := AssignDebug (s, __FILE__, __LINE__, __FUNCTION__)
   END ;
   RETURN s
END InitString ;


(*
   DeallocateCharStar - deallocates any charStar.
*)

PROCEDURE DeallocateCharStar (s: String) ;
BEGIN
   IF (s # NIL) AND (s^.head # NIL)
   THEN
      WITH s^.head^ DO
         IF charStarUsed AND (charStar # NIL)
         THEN
            DEALLOCATE (charStar, charStarSize)
         END ;
         charStarUsed  := FALSE ;
         charStar      := NIL ;
         charStarSize  := 0 ;
         charStarValid := FALSE
      END
   END
END DeallocateCharStar ;


(*
   CheckPoisoned - checks for a poisoned string, s.
*)

PROCEDURE CheckPoisoned (s: String) : String ;
BEGIN
   IF PoisonOn AND (s # NIL) AND (s^.head # NIL) AND (s^.head^.state = poisoned)
   THEN
      HALT
   END ;
   RETURN s
END CheckPoisoned ;


(*
   KillString - frees String, s, and its contents.
                NIL is returned.
*)

PROCEDURE KillString (s: String) : String ;
VAR
   t: String ;
BEGIN
   IF PoisonOn
   THEN
      s := CheckPoisoned (s)
   END ;
   IF s # NIL
   THEN
      IF CheckOn
      THEN
         IF IsOnAllocated (s)
         THEN
            SubAllocated (s)
         ELSIF IsOnDeallocated (s)
         THEN
            SubDeallocated (s)
         END
      END ;
      WITH s^ DO
         IF head # NIL
         THEN
            WITH head^ DO
               state := poisoned ;
               garbage := KillString (garbage) ;
               IF NOT PoisonOn
               THEN
                  DeallocateCharStar (s)
               END
            END ;
            IF NOT PoisonOn
            THEN
               DISPOSE (head) ;
               head := NIL
            END
         END ;
         t := KillString (s^.contents.next) ;
         IF NOT PoisonOn
         THEN
            DISPOSE (s)
         END
      END
   END ;
   RETURN NIL
END KillString ;


(*
   Fin - finishes with a string, it calls KillString with, s.
         The purpose of the procedure is to provide a short cut
         to calling KillString and then testing the return result.
*)

PROCEDURE Fin (s: String) ;
BEGIN
   IF KillString (s) # NIL
   THEN
      HALT
   END
END Fin ;


(*
   MarkInvalid - marks the char * version of String, s, as invalid.
*)

PROCEDURE MarkInvalid (s: String) ;
BEGIN
   IF PoisonOn
   THEN
      s := CheckPoisoned (s)
   END ;
   IF s^.head # NIL
   THEN
      s^.head^.charStarValid := FALSE
   END
END MarkInvalid ;


(*
   ConcatContentsAddress - concatenate the string, a, where, h, is the
                           total length of, a.
*)

PROCEDURE ConcatContentsAddress (VAR c: Contents; a: ADDRESS; h: CARDINAL) ;
VAR
   p   : POINTER TO CHAR ;
   i, j: CARDINAL ;
BEGIN
   j := 0 ;
   i := c.len ;
   p := a ;
   WHILE (j < h) AND (i < MaxBuf) DO
      c.buf[i] := p^ ;
      INC (i) ;
      INC (j) ;
      INC (p)
   END ;
   IF j < h
   THEN
      c.len := MaxBuf ;
      NEW (c.next) ;
      WITH c.next^ DO
         head          := NIL ;
         contents.len  := 0 ;
         contents.next := NIL ;
         ConcatContentsAddress (contents, p, h - j)
      END ;
      AddDebugInfo (c.next) ;
      IF TraceOn
      THEN
         c.next := AssignDebug (c.next, __FILE__, __LINE__, __FUNCTION__)
      END
   ELSE
      c.len := i ;
      c.next := NIL
   END
END ConcatContentsAddress ;


(*
   InitStringCharStar - initializes and returns a String to contain the C string.
*)

PROCEDURE InitStringCharStar (a: ADDRESS) : String ;
VAR
   s: String ;
BEGIN
   NEW (s) ;
   WITH s^ DO
      WITH contents DO
         len := 0 ;
         next := NIL
      END ;
      IF a#NIL
      THEN
         ConcatContentsAddress (contents, a, strlen (a))
      END ;
      NEW (head) ;
      WITH head^ DO
         charStarUsed  := FALSE ;
         charStar      := NIL ;
         charStarSize  := 0 ;
         charStarValid := FALSE ;
         garbage       := NIL ;
         state         := inuse
      END
   END ;
   AddDebugInfo (s) ;
   IF TraceOn
   THEN
      s := AssignDebug (s, __FILE__, __LINE__, __FUNCTION__)
   END ;
   RETURN s
END InitStringCharStar ;


(*
   InitStringChar - initializes and returns a String to contain the single character, ch.
*)

PROCEDURE InitStringChar (ch: CHAR) : String ;
VAR
   a: ARRAY [0..1] OF CHAR ;
   s: String ;
BEGIN
   a[0] := ch ;
   a[1] := nul ;
   s := InitString (a) ;
   IF TraceOn
   THEN
      s := AssignDebug (s, __FILE__, __LINE__, __FUNCTION__)
   END ;
   RETURN s
END InitStringChar ;


(*
   Mark - marks String, s, ready for garbage collection.
*)

PROCEDURE Mark (s: String) : String ;
BEGIN
   IF PoisonOn
   THEN
      s := CheckPoisoned (s)
   END ;
   IF (s # NIL) AND (s^.head^.state = inuse)
   THEN
      s^.head^.state := marked
   END ;
   RETURN s
END Mark ;


(*
   AddToGarbage - adds String, b, onto the garbage list of, a.  Providing
                  the state of b is marked.  The state is then altered to
                  onlist.  String, a, is returned.
*)

PROCEDURE AddToGarbage (a, b: String) : String ;
VAR
   c: String ;
BEGIN
   IF PoisonOn
   THEN
      a := CheckPoisoned (a) ;
      b := CheckPoisoned (b)
   END ;
(*
   IF (a#NIL) AND (a#b) AND (a^.head^.state=marked)
   THEN
      writeString('warning trying to add to a marked string') ; writeLn
   END ;
*)
   IF (a # b) AND (a # NIL) AND (b # NIL) AND (b^.head^.state = marked) AND (a^.head^.state = inuse)
   THEN
      c := a ;
      WHILE c^.head^.garbage # NIL DO
         c := c^.head^.garbage
      END ;
      c^.head^.garbage := b ;
      b^.head^.state := onlist ;
      IF CheckOn
      THEN
         SubDebugInfo (b)
      END
   END ;
   RETURN a
END AddToGarbage ;


(*
   IsOnGarbage - returns TRUE if, s, is on string, e, garbage list.
*)

PROCEDURE IsOnGarbage (e, s: String) : BOOLEAN ;
BEGIN
   IF (e # NIL) AND (s # NIL)
   THEN
      WHILE e^.head^.garbage # NIL DO
         IF e^.head^.garbage = s
         THEN
            RETURN TRUE
         ELSE
            e := e^.head^.garbage
         END
      END
   END ;
   RETURN FALSE
END IsOnGarbage ;


(*
   Length - returns the length of the String, s.
*)

PROCEDURE Length (s: String) : CARDINAL ;
BEGIN
   IF s = NIL
   THEN
      RETURN 0
   ELSE
      RETURN s^.contents.len + Length (s^.contents.next)
   END
END Length ;


(*
   ConCat - returns String, a, after the contents of, b, have been appended.
*)

PROCEDURE ConCat (a, b: String) : String ;
VAR
   t: String ;
BEGIN
   IF PoisonOn
   THEN
      a := CheckPoisoned (a) ;
      b := CheckPoisoned (b)
   END ;
   IF a = b
   THEN
      RETURN ConCat (a, Mark (Dup (b)))
   ELSIF a # NIL
   THEN
      a := AddToGarbage (a, b) ;
      MarkInvalid (a) ;
      t := a ;
      WHILE b # NIL DO
         WHILE (t^.contents.len = MaxBuf) AND (t^.contents.next # NIL) DO
            t := t^.contents.next
         END ;
         ConcatContents (t^.contents, b^.contents.buf, b^.contents.len, 0) ;
         b := b^.contents.next
      END
   END ;
   IF (a = NIL) AND (b # NIL)
   THEN
      HALT
   END ;
   RETURN a
END ConCat ;


(*
   ConCatChar - returns String, a, after character, ch, has been appended.
*)

PROCEDURE ConCatChar (a: String; ch: CHAR) : String ;
VAR
   b: ARRAY [0..1] OF CHAR ;
   t: String ;
BEGIN
   IF PoisonOn
   THEN
      a := CheckPoisoned (a)
   END ;
   b[0] := ch ;
   b[1] := nul ;
   t := a ;
   MarkInvalid (a) ;
   WHILE (t^.contents.len = MaxBuf) AND (t^.contents.next # NIL) DO
      t := t^.contents.next
   END ;
   ConcatContents (t^.contents, b, 1, 0) ;
   RETURN a
END ConCatChar ;


(*
   ReplaceChar - returns string s after it has changed all occurances of from to to.
*)

PROCEDURE ReplaceChar (s: String; from, to: CHAR) : String ;
VAR
   t: String ;
   i: CARDINAL ;
BEGIN
   t := s ;
   WHILE t # NIL DO
      i := 0 ;
      WHILE i < t^.contents.len DO
         IF t^.contents.buf[i] = from
         THEN
            t^.contents.buf[i] := to
         END ;
         INC (i)
      END ;
      t := t^.contents.next
   END ;
   RETURN s
END ReplaceChar ;


(*
   Assign - assigns the contents of, b, into, a.
            String, a, is returned.
*)

PROCEDURE Assign (a, b: String) : String ;
BEGIN
   IF PoisonOn
   THEN
      a := CheckPoisoned (a) ;
      b := CheckPoisoned (b)
   END ;
   IF (a # NIL) AND (b # NIL)
   THEN
      WITH a^ DO
         contents.next := KillString (contents.next) ;
         contents.len  := 0
      END
   END ;
   RETURN ConCat (a, b)
END Assign ;


(*
   Dup - duplicate a String, s, returning the copy of s.
*)

PROCEDURE Dup (s: String) : String ;
BEGIN
   IF PoisonOn
   THEN
      s := CheckPoisoned (s)
   END ;
   s := Assign (InitString (''), s) ;
   IF TraceOn
   THEN
      s := AssignDebug (s, __FILE__, __LINE__, __FUNCTION__)
   END ;
   RETURN s
END Dup ;


(*
   Add - returns a new String which contains the contents of a and b.
*)

PROCEDURE Add (a, b: String) : String ;
BEGIN
   IF PoisonOn
   THEN
      a := CheckPoisoned (a) ;
      b := CheckPoisoned (b)
   END ;
   a := ConCat (ConCat (InitString (''), a), b) ;
   IF TraceOn
   THEN
      a := AssignDebug (a, __FILE__, __LINE__, __FUNCTION__)
   END ;
   RETURN a
END Add ;


(*
   Equal - returns TRUE if String, a, and, b, are equal.
*)

PROCEDURE Equal (a, b: String) : BOOLEAN ;
VAR
   i: CARDINAL ;
BEGIN
   IF PoisonOn
   THEN
      a := CheckPoisoned (a) ;
      b := CheckPoisoned (b)
   END ;
   IF Length (a) = Length (b)
   THEN
      WHILE (a # NIL) AND (b # NIL) DO
         i := 0 ;
         Assert (a^.contents.len = b^.contents.len) ;
         WHILE i<a^.contents.len DO
            IF a^.contents.buf[i] # b^.contents.buf[i]
            THEN
               RETURN FALSE
            END ;
            INC (i)
         END ;
         a := a^.contents.next ;
         b := b^.contents.next
      END ;
      RETURN TRUE
   ELSE
      RETURN FALSE
   END
END Equal ;


(*
   EqualCharStar - returns TRUE if contents of String, s, is the same as the
                   string, a.
*)

PROCEDURE EqualCharStar (s: String; a: ADDRESS) : BOOLEAN ;
VAR
   t: String ;
BEGIN
   IF PoisonOn
   THEN
      s := CheckPoisoned (s)
   END ;
   t := InitStringCharStar (a) ;
   IF TraceOn
   THEN
      t := AssignDebug (t, __FILE__, __LINE__, __FUNCTION__)
   END ;
   t := AddToGarbage (t, s) ;
   IF Equal (t, s)
   THEN
      t := KillString (t) ;
      RETURN TRUE
   ELSE
      t := KillString (t) ;
      RETURN FALSE
   END
END EqualCharStar ;


(*
   EqualArray - returns TRUE if contents of String, s, is the same as the
                string, a.
*)

PROCEDURE EqualArray (s: String; a: ARRAY OF CHAR) : BOOLEAN ;
VAR
   t: String ;
BEGIN
   IF PoisonOn
   THEN
      s := CheckPoisoned (s)
   END ;
   t := InitString (a) ;
   IF TraceOn
   THEN
      t := AssignDebug (t, __FILE__, __LINE__, __FUNCTION__)
   END ;
   t := AddToGarbage (t, s) ;
   IF Equal (t, s)
   THEN
      t := KillString (t) ;
      RETURN TRUE
   ELSE
      t := KillString (t) ;
      RETURN FALSE
   END
END EqualArray ;


(*
   Mult - returns a new string which is n concatenations of String, s.
*)

PROCEDURE Mult (s: String; n: CARDINAL) : String ;
BEGIN
   IF PoisonOn
   THEN
      s := CheckPoisoned (s)
   END ;
   IF n<=0
   THEN
      s := AddToGarbage (InitString (''), s)
   ELSE
      s := ConCat (Mult (s, n-1), s)
   END ;
   IF TraceOn
   THEN
      s := AssignDebug (s, __FILE__, __LINE__, __FUNCTION__)
   END ;
   RETURN s
END Mult ;


(*
   Slice - returns a new string which contains the elements
           low..high-1

           strings start at element 0
           Slice(s, 0, 2)  will return elements 0, 1 but not 2
           Slice(s, 1, 3)  will return elements 1, 2 but not 3
           Slice(s, 2, 0)  will return elements 2..max
           Slice(s, 3, -1) will return elements 3..max-1
           Slice(s, 4, -2) will return elements 4..max-2
*)

PROCEDURE Slice (s: String; low, high: INTEGER) : String ;
VAR
   d, t         : String ;
   start, end, o: INTEGER ;
BEGIN
   IF PoisonOn
   THEN
      s := CheckPoisoned (s)
   END ;
   IF low < 0
   THEN
      low := VAL (INTEGER, Length (s)) + low
   END ;
   IF high <= 0
   THEN
      high := VAL (INTEGER, Length (s)) + high
   ELSE
      (* make sure high is <= Length (s) *)
      high := Min (Length (s), high)
   END ;
   d := InitString ('') ;
   d := AddToGarbage (d, s) ;
   o := 0 ;
   t := d ;
   WHILE s # NIL DO
      IF low < o + VAL (INTEGER, s^.contents.len)
      THEN
         IF o > high
         THEN
            s := NIL
         ELSE
            (* found sliceable unit *)
            IF low < o
            THEN
               start := 0
            ELSE
               start := low - o
            END ;
            end := Max (Min (MaxBuf, high - o), 0) ;
            WHILE t^.contents.len = MaxBuf DO
               IF t^.contents.next = NIL
               THEN
                  NEW (t^.contents.next) ;
                  WITH t^.contents.next^ DO
                     head         := NIL ;
                     contents.len := 0
                  END ;
                  AddDebugInfo (t^.contents.next) ;
                  IF TraceOn
                  THEN
                     t^.contents.next := AssignDebug (t^.contents.next, __FILE__, __LINE__, __FUNCTION__)
                  END
               END ;
               t := t^.contents.next
            END ;
            ConcatContentsAddress (t^.contents,
                                   ADR (s^.contents.buf[start]), end - start) ;
            INC (o, s^.contents.len) ;
            s := s^.contents.next
         END
      ELSE
         INC (o, s^.contents.len) ;
         s := s^.contents.next
      END ;
   END ;
   IF TraceOn
   THEN
      d := AssignDebug (d, __FILE__, __LINE__, __FUNCTION__)
   END ;
   RETURN d
END Slice ;


(*
   Index - returns the indice of the first occurance of, ch, in
           String, s. -1 is returned if, ch, does not exist.
           The search starts at position, o.
*)

PROCEDURE Index (s: String; ch: CHAR; o: CARDINAL) : INTEGER ;
VAR
   i, k: CARDINAL ;
BEGIN
   IF PoisonOn
   THEN
      s := CheckPoisoned (s)
   END ;
   k := 0 ;
   WHILE s # NIL DO
      WITH s^ DO
         IF k + contents.len < o
         THEN
            INC (k, contents.len)
         ELSE
            i := o - k ;
            WHILE i < contents.len DO
               IF contents.buf[i] = ch
               THEN
                  RETURN k + i
               END ;
               INC (i)
            END ;
            INC (k, i) ;
            o := k
         END
      END ;
      s := s^.contents.next
   END ;
   RETURN -1
END Index ;


(*
   RIndex - returns the indice of the last occurance of, ch,
            in String, s. The search starts at position, o.
            -1 is returned if, ch, is not found.
*)

PROCEDURE RIndex (s: String; ch: CHAR; o: CARDINAL) : INTEGER ;
VAR
   i, k: CARDINAL ;
   j   : INTEGER ;
BEGIN
   IF PoisonOn
   THEN
      s := CheckPoisoned (s)
   END ;
   j := -1 ;
   k :=  0 ;
   WHILE s # NIL DO
      WITH s^ DO
         IF k + contents.len < o
         THEN
            INC (k, contents.len)
         ELSE
            IF o < k
            THEN
               i := 0
            ELSE
               i := o - k
            END ;
            WHILE i < contents.len DO
               IF contents.buf[i] = ch
               THEN
                  j := k
               END ;
               INC (k) ;
               INC (i)
            END
         END
      END ;
      s := s^.contents.next
   END ;
   RETURN j
END RIndex ;


(*
   RemoveComment - assuming that, comment, is a comment delimiter
                   which indicates anything to its right is a comment
                   then strip off the comment and also any white space
                   on the remaining right hand side.
                   It leaves any white space on the left hand side alone.
*)

PROCEDURE RemoveComment (s: String; comment: CHAR) : String ;
VAR
   i: INTEGER ;
BEGIN
   i := Index (s, comment, 0) ;
   IF i = 0
   THEN
      s := InitString ('')
   ELSIF i > 0
   THEN
      s := RemoveWhitePostfix (Slice (Mark (s), 0, i))
   END ;
   IF TraceOn
   THEN
      s := AssignDebug (s, __FILE__, __LINE__, __FUNCTION__)
   END ;
   RETURN s
END RemoveComment ;


(*
   char - returns the character, ch, at position, i, in String, s.
*)

PROCEDURE char (s: String; i: INTEGER) : CHAR ;
VAR
   c: CARDINAL ;
BEGIN
   IF PoisonOn
   THEN
      s := CheckPoisoned (s)
   END ;
   IF i<0
   THEN
      c := VAL (CARDINAL, VAL (INTEGER, Length (s)) + i)
   ELSE
      c := i
   END ;
   WHILE (s # NIL) AND (c >= s^.contents.len) DO
      DEC (c, s^.contents.len) ;
      s := s^.contents.next
   END ;
   IF (s = NIL) OR (c >= s^.contents.len)
   THEN
      RETURN nul
   ELSE
      RETURN s^.contents.buf[c]
   END
END char ;


(*
   string - returns the C style char * of String, s.
*)

PROCEDURE string (s: String) : ADDRESS ;
VAR
   a   : String ;
   l, i: CARDINAL ;
   p   : POINTER TO CHAR ;
BEGIN
   IF PoisonOn
   THEN
      s := CheckPoisoned (s)
   END ;
   IF s = NIL
   THEN
      RETURN NIL
   ELSE
      IF NOT s^.head^.charStarValid
      THEN
         l := Length (s) ;
         WITH s^.head^ DO
            IF NOT (charStarUsed AND (charStarSize > l))
            THEN
               DeallocateCharStar (s) ;
               ALLOCATE (charStar, l+1) ;
               charStarSize := l+1 ;
               charStarUsed := TRUE
            END ;
            p := charStar ;
         END ;
         a := s ;
         WHILE a#NIL DO
            i := 0 ;
            WHILE i < a^.contents.len DO
               p^ := a^.contents.buf[i] ;
               INC (i) ;
               INC (p)
            END ;
            a := a^.contents.next
         END ;
         p^ := nul ;
         s^.head^.charStarValid := TRUE
      END ;
      RETURN s^.head^.charStar
   END
END string ;


(*
   IsWhite - returns TRUE if, ch, is a space or a tab.
*)

PROCEDURE IsWhite (ch: CHAR) : BOOLEAN ;
BEGIN
   RETURN (ch = ' ') OR (ch = tab)
END IsWhite ;


(*
   RemoveWhitePrefix - removes any leading white space from String, s.
                       A new string is returned.
*)

PROCEDURE RemoveWhitePrefix (s: String) : String ;
VAR
   i: CARDINAL ;
BEGIN
   i := 0 ;
   WHILE IsWhite (char (s, i)) DO
      INC (i)
   END ;
   s := Slice (s, INTEGER (i), 0) ;
   IF TraceOn
   THEN
      s := AssignDebug (s, __FILE__, __LINE__, __FUNCTION__)
   END ;
   RETURN s
END RemoveWhitePrefix ;


(*
   RemoveWhitePostfix - removes any leading white space from String, s.
                        A new string is returned.
*)

PROCEDURE RemoveWhitePostfix (s: String) : String ;
VAR
   i: INTEGER ;
BEGIN
   i := VAL(INTEGER, Length (s)) - 1 ;
   WHILE (i >= 0) AND IsWhite (char (s, i)) DO
      DEC (i)
   END ;
   s := Slice (s, 0, i+1) ;
   IF TraceOn
   THEN
      s := AssignDebug (s, __FILE__, __LINE__, __FUNCTION__)
   END ;
   RETURN s
END RemoveWhitePostfix ;


(*
   ToUpper - returns string, s, after it has had its lower case characters
             replaced by upper case characters.
             The string, s, is not duplicated.
*)

PROCEDURE ToUpper (s: String) : String ;
VAR
   ch: CHAR ;
   i : CARDINAL ;
   t : String ;
BEGIN
   IF s # NIL
   THEN
      MarkInvalid (s) ;
      t := s ;
      WHILE t # NIL DO
         WITH t^ DO
            i := 0 ;
            WHILE i < contents.len DO
               ch := contents.buf[i] ;
               IF (ch >= 'a') AND (ch <= 'z')
               THEN
                  contents.buf[i] := CHR (ORD (ch) - ORD ('a') + ORD ('A'))
               END ;
               INC (i)
            END
         END ;
         t := t^.contents.next
      END
   END ;
   RETURN s
END ToUpper ;


(*
   ToLower - returns string, s, after it has had its upper case characters
             replaced by lower case characters.
             The string, s, is not duplicated.
*)

PROCEDURE ToLower (s: String) : String ;
VAR
   ch: CHAR ;
   i : CARDINAL ;
   t : String ;
BEGIN
   IF s # NIL
   THEN
      MarkInvalid (s) ;
      t := s ;
      WHILE t # NIL DO
         WITH t^ DO
            i := 0 ;
            WHILE i < contents.len DO
               ch := contents.buf[i] ;
               IF (ch >= 'A') AND (ch <= 'Z')
               THEN
                  contents.buf[i] := CHR (ORD (ch) - ORD ('A') + ORD ('a'))
               END ;
               INC (i)
            END
         END ;
         t := t^.contents.next
      END
   END ;
   RETURN s
END ToLower ;


(*
   InitStringDB - the debug version of InitString.
*)

PROCEDURE InitStringDB (a: ARRAY OF CHAR; file: ARRAY OF CHAR; line: CARDINAL) : String ;
BEGIN
   RETURN AssignDebug (InitString (a), file, line, 'InitString')
END InitStringDB ;


(*
   InitStringCharStarDB - the debug version of InitStringCharStar.
*)

PROCEDURE InitStringCharStarDB (a: ADDRESS; file: ARRAY OF CHAR; line: CARDINAL) : String ;
BEGIN
   RETURN AssignDebug (InitStringCharStar (a), file, line, 'InitStringCharStar')
END InitStringCharStarDB ;


(*
   InitStringCharDB - the debug version of InitStringChar.
*)

PROCEDURE InitStringCharDB (ch: CHAR; file: ARRAY OF CHAR; line: CARDINAL) : String ;
BEGIN
   RETURN AssignDebug (InitStringChar (ch), file, line, 'InitStringChar')
END InitStringCharDB ;


(*
   MultDB - the debug version of MultDB.
*)

PROCEDURE MultDB (s: String; n: CARDINAL; file: ARRAY OF CHAR; line: CARDINAL) : String ;
BEGIN
   RETURN AssignDebug (Mult (s, n), file, line, 'Mult')
END MultDB ;


(*
   DupDB - the debug version of Dup.
*)

PROCEDURE DupDB (s: String; file: ARRAY OF CHAR; line: CARDINAL) : String ;
BEGIN
   RETURN AssignDebug (Dup (s), file, line, 'Dup')
END DupDB ;


(*
   SliceDB - debug version of Slice.
*)

PROCEDURE SliceDB (s: String; low, high: INTEGER;
                   file: ARRAY OF CHAR; line: CARDINAL) : String ;
BEGIN
   DSdbEnter ;
   s := AssignDebug (Slice (s, low, high), file, line, 'Slice') ;
   DSdbExit (s) ;
   RETURN s
END SliceDB ;


(*
   DumpState -
*)

PROCEDURE DumpState (s: String) ;
BEGIN
   CASE s^.head^.state OF

   inuse   :  writeString ("still in use (") ; writeCard (s^.contents.len) ; writeString (") characters") |
   marked  :  writeString ("marked") |
   onlist  :  writeString ("on a garbage list") |
   poisoned:  writeString ("poisoned")

   ELSE
      writeString ("unknown state")
   END
END DumpState ;


(*
   DumpStringSynopsis -
*)

PROCEDURE DumpStringSynopsis (s: String) ;
BEGIN
   writeCstring (s^.debug.file) ; writeString (':') ;
   writeCard (s^.debug.line) ; writeString (':') ;
   writeCstring (s^.debug.proc) ;
   writeString (' string ') ;
   writeAddress (s) ;
   writeString (' ') ;
   DumpState (s) ;
   IF IsOnAllocated (s)
   THEN
      writeString (' globally allocated')
   ELSIF IsOnDeallocated (s)
   THEN
      writeString (' globally deallocated')
   ELSE
      writeString (' globally unknown')
   END ;
   writeLn
END DumpStringSynopsis ;


(*
   DumpString - displays the contents of string, s.
*)

PROCEDURE DumpString (s: String) ;
VAR
   t: String ;
BEGIN
   IF s # NIL
   THEN
      DumpStringSynopsis (s) ;
      IF (s^.head # NIL) AND (s^.head^.garbage # NIL)
      THEN
         writeString ('display chained strings on the garbage list') ; writeLn ;
         t := s^.head^.garbage ;
         WHILE t # NIL DO
            DumpStringSynopsis (t) ;
            t := t^.head^.garbage
         END
      END
   END
END DumpString ;


(*
   Init - initialize the module.
*)

PROCEDURE Init ;
BEGIN
   IF NOT Initialized
   THEN
      Initialized := TRUE ;
      frameHead := NIL ;
      PushAllocation ;
   END
END Init ;


BEGIN
   Initialized := FALSE ;
   Init
END DynamicStrings.