gcc/m2/gm2-libs/DynamicStrings.mod

   1 (* DynamicStrings.mod provides a dynamic string type and procedures.
   2
   3 Copyright (C) 2001-2024 Free Software Foundation, Inc.
   4 Contributed by Gaius Mulley <gaius.mulley@southwales.ac.uk>.
   5
   6 This file is part of GNU Modula-2.
   7
   8 GNU Modula-2 is free software; you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation; either version 3, or (at your option)
  11 any later version.
  12
  13 GNU Modula-2 is distributed in the hope that it will be useful, but
  14 WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  16 General Public License for more details.
  17
  18 Under Section 7 of GPL version 3, you are granted additional
  19 permissions described in the GCC Runtime Library Exception, version
  20 3.1, as published by the Free Software Foundation.
  21
  22 You should have received a copy of the GNU General Public License and
  23 a copy of the GCC Runtime Library Exception along with this program;
  24 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
  25 <http://www.gnu.org/licenses/>.  *)
  26
  27 IMPLEMENTATION MODULE DynamicStrings ;
  28
  29 FROM libc IMPORT strlen, strncpy, write, exit, snprintf ;
  30 FROM StrLib IMPORT StrLen ;
  31 FROM Storage IMPORT ALLOCATE, DEALLOCATE ;
  32 FROM Assertion IMPORT Assert ;
  33 FROM SYSTEM IMPORT ADR ;
  34 FROM ASCII IMPORT nul, tab, lf ;
  35 FROM M2RTS IMPORT Halt ;
  36
  37 CONST
  38    MaxBuf   = 127 ;
  39    PoisonOn = FALSE ;    (* to enable debugging of this module, turn on PoisonOn and DebugOn.  *)
  40    DebugOn  = FALSE ;
  41    CheckOn  = FALSE ;    (* to enable debugging of users of this module turn on                *)
  42    TraceOn  = FALSE ;    (* CheckOn and TraceOn.  Enabling both of these is very expensive.    *)
  43
  44 TYPE
  45    Contents = RECORD
  46                  buf : ARRAY [0..MaxBuf-1] OF CHAR ;
  47                  len : CARDINAL ;
  48                  next: String ;
  49               END ;
  50
  51    Descriptor = POINTER TO descriptor ;
  52
  53    String = POINTER TO stringRecord ;
  54
  55    DebugInfo = RECORD
  56                   next: String ;   (* a mechanism for tracking used/lost strings *)
  57                   file: ADDRESS ;
  58                   line: CARDINAL ;
  59                   proc: ADDRESS ;
  60                END ;
  61
  62    stringRecord = RECORD
  63                      contents: Contents ;
  64                      head    : Descriptor ;
  65                      debug   : DebugInfo ;
  66                   END ;
  67
  68    desState = (inuse, marked, onlist, poisoned) ;
  69
  70    descriptor = RECORD
  71                    charStarUsed : BOOLEAN ;     (* can we garbage collect this? *)
  72                    charStar     : ADDRESS ;
  73                    charStarSize : CARDINAL ;
  74                    charStarValid: BOOLEAN ;
  75                    state        : desState ;
  76                    garbage      : String ;      (* temporary strings to be destroyed
  77                                                    once this string is killed *)
  78                 END ;
  79
  80    frame    = POINTER TO frameRec ;
  81    frameRec =            RECORD
  82                             alloc, dealloc: String ;
  83                             next          : frame ;
  84                          END ;
  85
  86 VAR
  87    Initialized: BOOLEAN ;
  88    frameHead  : frame ;
  89    captured   : String ;  (* debugging aid.  *)
  90
  91
  92 (* writeStringDesc write out debugging information about string, s.  *)
  93
  94 PROCEDURE writeStringDesc (s: String) ;
  95 BEGIN
  96    writeCstring (s^.debug.file) ; writeString (':') ;
  97    writeCard (s^.debug.line) ; writeString (':') ;
  98    writeCstring (s^.debug.proc) ; writeString (' ') ;
  99    writeAddress (s) ;
 100    writeString (' ') ;
 101    CASE s^.head^.state OF
 102
 103    inuse   :  writeString ("still in use (") ; writeCard (s^.contents.len) ; writeString (") characters") |
 104    marked  :  writeString ("marked") |
 105    onlist  :  writeString ("on a (lost) garbage list") |
 106    poisoned:  writeString ("poisoned")
 107
 108    ELSE
 109       writeString ("unknown state")
 110    END
 111 END writeStringDesc ;
 112
 113
 114 (*
 115    writeNspace -
 116 *)
 117
 118 PROCEDURE writeNspace (n: CARDINAL) ;
 119 BEGIN
 120    WHILE n > 0 DO
 121       writeString (' ') ;
 122       DEC (n)
 123    END
 124 END writeNspace ;
 125
 126
 127 (*
 128    DumpStringInfo -
 129 *)
 130
 131 PROCEDURE DumpStringInfo (s: String; i: CARDINAL) ;
 132 BEGIN
 133    IF s # NIL
 134    THEN
 135       writeNspace (i) ; writeStringDesc (s) ; writeLn ;
 136       IF s^.head^.garbage # NIL
 137       THEN
 138          writeNspace (i) ; writeString ('garbage list:') ; writeLn ;
 139          REPEAT
 140             s := s^.head^.garbage ;
 141             DumpStringInfo (s, i+1) ; writeLn
 142          UNTIL s = NIL
 143       END
 144    END
 145 END DumpStringInfo ;
 146
 147
 148 PROCEDURE stop ;
 149 END stop ;
 150
 151
 152 (*
 153    PopAllocationExemption - test to see that all strings are deallocated, except
 154                             string e since the last push.
 155                             Post-condition: it pops to the previous allocation/deallocation
 156                             lists.
 157
 158                             If halt is true then the application terminates
 159                             with an exit code of 1.
 160 *)
 161
 162 PROCEDURE PopAllocationExemption (halt: BOOLEAN; e: String) : String ;
 163 VAR
 164    s: String ;
 165    b: BOOLEAN ;
 166 BEGIN
 167    Init ;
 168    IF CheckOn
 169    THEN
 170       IF frameHead = NIL
 171       THEN
 172          stop ;
 173          Halt ("mismatched number of PopAllocation's compared to PushAllocation's",
 174                __FILE__, __FUNCTION__, __LINE__) ;
 175          (* writeString ("mismatched number of PopAllocation's compared to PushAllocation's") *)
 176       ELSE
 177          IF frameHead^.alloc # NIL
 178          THEN
 179             b := FALSE ;
 180             s := frameHead^.alloc ;
 181             WHILE s # NIL DO
 182                IF NOT ((e = s) OR IsOnGarbage (e, s) OR IsOnGarbage (s, e))
 183                THEN
 184                   IF NOT b
 185                   THEN
 186                      writeString ("the following strings have been lost") ; writeLn ;
 187                      b := TRUE
 188                   END ;
 189                   DumpStringInfo (s, 0)
 190                END ;
 191                s := s^.debug.next
 192             END ;
 193             IF b AND halt
 194             THEN
 195                exit (1)
 196             END
 197          END ;
 198          frameHead := frameHead^.next
 199       END
 200    END ;
 201    RETURN e
 202 END PopAllocationExemption ;
 203
 204
 205 (*
 206    PopAllocation - test to see that all strings are deallocated since
 207                    the last push.  Then it pops to the previous
 208                    allocation/deallocation lists.
 209
 210                    If halt is true then the application terminates
 211                    with an exit code of 1.
 212 *)
 213
 214 PROCEDURE PopAllocation (halt: BOOLEAN) ;
 215 BEGIN
 216    IF CheckOn
 217    THEN
 218       IF PopAllocationExemption (halt, NIL) = NIL
 219       THEN
 220       END
 221    END
 222 END PopAllocation ;
 223
 224
 225 (*
 226    PushAllocation - pushes the current allocation/deallocation lists.
 227 *)
 228
 229 PROCEDURE PushAllocation ;
 230 VAR
 231    f: frame ;
 232 BEGIN
 233    IF CheckOn
 234    THEN
 235       Init ;
 236       NEW (f) ;
 237       WITH f^ DO
 238          next := frameHead ;
 239          alloc := NIL ;
 240          dealloc := NIL
 241       END ;
 242       frameHead := f
 243    END
 244 END PushAllocation ;
 245
 246
 247 (*
 248    doDSdbEnter -
 249 *)
 250
 251 PROCEDURE doDSdbEnter ;
 252 BEGIN
 253    IF CheckOn
 254    THEN
 255       PushAllocation
 256    END
 257 END doDSdbEnter ;
 258
 259
 260 (*
 261    doDSdbExit -
 262 *)
 263
 264 PROCEDURE doDSdbExit (s: String) ;
 265 BEGIN
 266    IF CheckOn
 267    THEN
 268       s := PopAllocationExemption (TRUE, s)
 269    END
 270 END doDSdbExit ;
 271
 272
 273 (*
 274    DSdbEnter -
 275 *)
 276
 277 PROCEDURE DSdbEnter ;
 278 BEGIN
 279 END DSdbEnter ;
 280
 281
 282 (*
 283    DSdbExit -
 284 *)
 285
 286 PROCEDURE DSdbExit (s: String) ;
 287 BEGIN
 288 END DSdbExit ;
 289
 290
 291 (*
 292  *   #undef GM2_DEBUG_DYNAMICSTINGS
 293  *   #if defined(GM2_DEBUG_DYNAMICSTINGS)
 294  *   #  define DSdbEnter doDSdbEnter
 295  *   #  define DSdbExit  doDSdbExit
 296  *   #  define CheckOn   TRUE
 297  *   #  define TraceOn   TRUE
 298  *   #endif
 299  *)
 300
 301
 302 PROCEDURE Capture (s: String) : CARDINAL ;
 303 BEGIN
 304    captured := s ;
 305    RETURN 1
 306 END Capture ;
 307
 308
 309 (*
 310    Min -
 311 *)
 312
 313 PROCEDURE Min (a, b: CARDINAL) : CARDINAL ;
 314 BEGIN
 315    IF a < b
 316    THEN
 317       RETURN a
 318    ELSE
 319       RETURN b
 320    END
 321 END Min ;
 322
 323
 324 (*
 325    Max -
 326 *)
 327
 328 PROCEDURE Max (a, b: CARDINAL) : CARDINAL ;
 329 BEGIN
 330    IF a > b
 331    THEN
 332       RETURN a
 333    ELSE
 334       RETURN b
 335    END
 336 END Max ;
 337
 338
 339 (*
 340    writeString - writes a string to stdout.
 341 *)
 342
 343 PROCEDURE writeString (a: ARRAY OF CHAR) ;
 344 VAR
 345    i: INTEGER ;
 346 BEGIN
 347    i := write (1, ADR (a), StrLen (a))
 348 END writeString ;
 349
 350
 351 (*
 352    writeCstring - writes a C string to stdout.
 353 *)
 354
 355 PROCEDURE writeCstring (a: ADDRESS) ;
 356 VAR
 357    i: INTEGER ;
 358 BEGIN
 359    IF a = NIL
 360    THEN
 361       writeString ('(null)')
 362    ELSE
 363       i := write (1, a, strlen (a))
 364    END
 365 END writeCstring ;
 366
 367
 368 (*
 369    writeCard -
 370 *)
 371
 372 PROCEDURE writeCard (c: CARDINAL) ;
 373 VAR
 374    ch: CHAR ;
 375    i : INTEGER ;
 376 BEGIN
 377    IF c > 9
 378    THEN
 379       writeCard (c DIV 10) ;
 380       writeCard (c MOD 10)
 381    ELSE
 382       ch := CHR (ORD ('0') + c) ;
 383       i := write (1, ADR (ch), 1)
 384    END
 385 END writeCard ;
 386
 387
 388 (*
 389    writeLongcard -
 390 *)
 391
 392 PROCEDURE writeLongcard (l: LONGCARD) ;
 393 VAR
 394    ch: CHAR ;
 395    i : INTEGER ;
 396 BEGIN
 397    IF l > 16
 398    THEN
 399       writeLongcard (l DIV 16) ;
 400       writeLongcard (l MOD 16)
 401    ELSIF l < 10
 402    THEN
 403       ch := CHR (ORD ('0') + VAL (CARDINAL, l)) ;
 404       i := write(1, ADR(ch), 1)
 405    ELSIF l<16
 406    THEN
 407       ch := CHR (ORD ('a') + VAL(CARDINAL, l) - 10) ;
 408       i := write (1, ADR (ch), 1)
 409    END
 410 END writeLongcard ;
 411
 412
 413 (*
 414    writeAddress - writes out the address of a with a C style hex prefix.
 415 *)
 416
 417 PROCEDURE writeAddress (a: ADDRESS) ;
 418 VAR
 419    buffer: ARRAY [0..30] OF CHAR ;
 420 BEGIN
 421    snprintf (ADR (buffer), SIZE (buffer), "0x%", a) ;
 422    writeString (buffer) ;
 423 END writeAddress ;
 424
 425
 426 (*
 427    writeLn - writes a newline.
 428 *)
 429
 430 PROCEDURE writeLn ;
 431 VAR
 432    ch: CHAR ;
 433    i : INTEGER ;
 434 BEGIN
 435    ch := lf ;
 436    i := write (1, ADR (ch), 1)
 437 END writeLn ;
 438
 439
 440 (*
 441    AssignDebug - assigns, file, and, line, information to string, s.
 442 *)
 443
 444 PROCEDURE AssignDebug (s: String; file: ARRAY OF CHAR; line: CARDINAL; proc: ARRAY OF CHAR) : String ;
 445 VAR
 446    f, p: ADDRESS ;
 447 BEGIN
 448    f := ADR (file) ;
 449    p := ADR (proc) ;
 450    WITH s^ DO
 451       ALLOCATE (debug.file, StrLen (file) + 1) ;
 452       IF strncpy(debug.file, f, StrLen(file)+1)=NIL
 453       THEN
 454       END ;
 455       debug.line := line ;
 456       ALLOCATE (debug.proc, StrLen (proc) + 1) ;
 457       IF strncpy (debug.proc, p, StrLen (proc) + 1) = NIL
 458       THEN
 459       END
 460    END ;
 461    RETURN( s )
 462 END AssignDebug ;
 463
 464
 465 (*
 466    CopyOut - copies string, s, to a.
 467 *)
 468
 469 PROCEDURE CopyOut (VAR a: ARRAY OF CHAR; s: String) ;
 470 VAR
 471    i, l: CARDINAL ;
 472 BEGIN
 473    l := Min (HIGH (a) + 1, Length (s)) ;
 474    i := 0 ;
 475    WHILE i < l DO
 476       a[i] := char (s, i) ;
 477       INC (i)
 478    END ;
 479    IF i <= HIGH (a)
 480    THEN
 481       a[i] := nul
 482    END
 483 END CopyOut ;
 484
 485
 486 (*
 487    IsOn - returns TRUE if, s, is on one of the debug lists.
 488 *)
 489
 490 PROCEDURE IsOn (list, s: String) : BOOLEAN ;
 491 BEGIN
 492    WHILE (list # s) AND (list # NIL) DO
 493       list := list^.debug.next
 494    END ;
 495    RETURN list = s
 496 END IsOn ;
 497
 498
 499 (*
 500    AddTo - adds string, s, to, list.
 501 *)
 502
 503 PROCEDURE AddTo (VAR list: String; s: String) ;
 504 BEGIN
 505    IF list = NIL
 506    THEN
 507       list := s ;
 508       s^.debug.next := NIL
 509    ELSE
 510       s^.debug.next := list ;
 511       list := s
 512    END
 513 END AddTo ;
 514
 515
 516 (*
 517    SubFrom - removes string, s, from, list.
 518 *)
 519
 520 PROCEDURE SubFrom (VAR list: String; s: String) ;
 521 VAR
 522    p: String ;
 523 BEGIN
 524    IF list = s
 525    THEN
 526       list := s^.debug.next ;
 527    ELSE
 528       p := list ;
 529       WHILE (p^.debug.next # NIL) AND (p^.debug.next # s) DO
 530          p := p^.debug.next
 531       END ;
 532       IF p^.debug.next = s
 533       THEN
 534          p^.debug.next := s^.debug.next
 535       ELSE
 536          (* not found, quit *)
 537          RETURN
 538       END
 539    END ;
 540    s^.debug.next := NIL
 541 END SubFrom ;
 542
 543
 544 (*
 545    AddAllocated - adds string, s, to the head of the allocated list.
 546 *)
 547
 548 PROCEDURE AddAllocated (s: String) ;
 549 BEGIN
 550    Init ;
 551    AddTo (frameHead^.alloc, s)
 552 END AddAllocated ;
 553
 554
 555 (*
 556    AddDeallocated - adds string, s, to the head of the deallocated list.
 557 *)
 558
 559 PROCEDURE AddDeallocated (s: String) ;
 560 BEGIN
 561    Init ;
 562    AddTo (frameHead^.dealloc, s)
 563 END AddDeallocated ;
 564
 565
 566 (*
 567    IsOnAllocated - returns TRUE if the string, s, has ever been allocated.
 568 *)
 569
 570 PROCEDURE IsOnAllocated (s: String) : BOOLEAN ;
 571 VAR
 572    f: frame ;
 573 BEGIN
 574    Init ;
 575    f := frameHead ;
 576    REPEAT
 577       IF IsOn (f^.alloc, s)
 578       THEN
 579          RETURN TRUE
 580       ELSE
 581          f := f^.next
 582       END
 583    UNTIL f = NIL ;
 584    RETURN FALSE
 585 END IsOnAllocated ;
 586
 587
 588 (*
 589    IsOnDeallocated - returns TRUE if the string, s, has ever been deallocated.
 590 *)
 591
 592 PROCEDURE IsOnDeallocated (s: String) : BOOLEAN ;
 593 VAR
 594    f: frame ;
 595 BEGIN
 596    Init ;
 597    f := frameHead ;
 598    REPEAT
 599       IF IsOn (f^.dealloc, s)
 600       THEN
 601          RETURN TRUE
 602       ELSE
 603          f := f^.next
 604       END
 605    UNTIL f = NIL ;
 606    RETURN FALSE
 607 END IsOnDeallocated ;
 608
 609
 610 (*
 611    SubAllocated - removes string, s, from the list of allocated strings.
 612 *)
 613
 614 PROCEDURE SubAllocated (s: String) ;
 615 VAR
 616    f: frame ;
 617 BEGIN
 618    Init ;
 619    f := frameHead ;
 620    REPEAT
 621       IF IsOn (f^.alloc, s)
 622       THEN
 623          SubFrom (f^.alloc, s) ;
 624          RETURN
 625       ELSE
 626          f := f^.next
 627       END
 628    UNTIL f = NIL
 629 END SubAllocated ;
 630
 631
 632 (*
 633    SubDeallocated - removes string, s, from the list of deallocated strings.
 634 *)
 635
 636 PROCEDURE SubDeallocated (s: String) ;
 637 VAR
 638    f: frame ;
 639 BEGIN
 640    Init ;
 641    f := frameHead ;
 642    REPEAT
 643       IF IsOn (f^.dealloc, s)
 644       THEN
 645          SubFrom (f^.dealloc, s) ;
 646          RETURN
 647       ELSE
 648          f := f^.next
 649       END
 650    UNTIL f = NIL
 651 END SubDeallocated ;
 652
 653
 654 (*
 655    SubDebugInfo - removes string, s, from the list of allocated strings.
 656 *)
 657
 658 PROCEDURE SubDebugInfo (s: String) ;
 659 BEGIN
 660    IF IsOnDeallocated (s)
 661    THEN
 662       Assert (NOT DebugOn) ;
 663       (* string has already been deallocated *)
 664       RETURN
 665    END ;
 666    IF IsOnAllocated (s)
 667    THEN
 668       SubAllocated (s) ;
 669       AddDeallocated (s)
 670    ELSE
 671       Assert (NOT DebugOn)
 672       (* string has not been allocated *)
 673    END
 674 END SubDebugInfo ;
 675
 676
 677 (*
 678    AddDebugInfo - adds string, s, to the list of allocated strings.
 679 *)
 680
 681 PROCEDURE AddDebugInfo (s: String) ;
 682 BEGIN
 683    WITH s^ DO
 684       debug.next := NIL ;
 685       debug.file := NIL ;
 686       debug.line := 0 ;
 687       debug.proc := NIL ;
 688    END ;
 689    IF CheckOn
 690    THEN
 691       AddAllocated (s)
 692    END
 693 END AddDebugInfo ;
 694
 695
 696 (*
 697    ConcatContents - add the contents of string, a, where, h, is the
 698                     total length of, a. The offset is in, o.
 699 *)
 700
 701 PROCEDURE ConcatContents (VAR c: Contents; a: ARRAY OF CHAR; h, o: CARDINAL) ;
 702 VAR
 703    i: CARDINAL ;
 704 BEGIN
 705    i := c.len ;
 706    WHILE (o < h) AND (i < MaxBuf) DO
 707       c.buf[i] := a[o] ;
 708       INC (o) ;
 709       INC (i)
 710    END ;
 711    IF o < h
 712    THEN
 713       c.len := MaxBuf ;
 714       NEW (c.next) ;
 715       WITH c.next^ DO
 716          head := NIL ;
 717          contents.len := 0 ;
 718          contents.next := NIL ;
 719          ConcatContents (contents, a, h, o)
 720       END ;
 721       AddDebugInfo (c.next) ;
 722       c.next := AssignDebug (c.next, __FILE__, __LINE__, __FUNCTION__)
 723    ELSE
 724       c.len := i
 725    END
 726 END ConcatContents ;
 727
 728
 729 (*
 730    InitString - creates and returns a String type object.
 731                 Initial contents are, a.
 732 *)
 733
 734 PROCEDURE InitString (a: ARRAY OF CHAR) : String ;
 735 VAR
 736    s: String ;
 737 BEGIN
 738    NEW(s) ;
 739    WITH s^ DO
 740       WITH contents DO
 741          len := 0 ;
 742          next := NIL
 743       END ;
 744       ConcatContents (contents, a, StrLen (a), 0) ;
 745       NEW (head) ;
 746       WITH head^ DO
 747          charStarUsed  := FALSE ;
 748          charStar      := NIL ;
 749          charStarSize  := 0;
 750          charStarValid := FALSE ;
 751          garbage       := NIL ;
 752          state         := inuse ;
 753       END
 754    END ;
 755    AddDebugInfo (s) ;
 756    IF TraceOn
 757    THEN
 758       s := AssignDebug (s, __FILE__, __LINE__, __FUNCTION__)
 759    END ;
 760    RETURN s
 761 END InitString ;
 762
 763
 764 (*
 765    DeallocateCharStar - deallocates any charStar.
 766 *)
 767
 768 PROCEDURE DeallocateCharStar (s: String) ;
 769 BEGIN
 770    IF (s # NIL) AND (s^.head # NIL)
 771    THEN
 772       WITH s^.head^ DO
 773          IF charStarUsed AND (charStar # NIL)
 774          THEN
 775             DEALLOCATE (charStar, charStarSize)
 776          END ;
 777          charStarUsed  := FALSE ;
 778          charStar      := NIL ;
 779          charStarSize  := 0 ;
 780          charStarValid := FALSE
 781       END
 782    END
 783 END DeallocateCharStar ;
 784
 785
 786 (*
 787    CheckPoisoned - checks for a poisoned string, s.
 788 *)
 789
 790 PROCEDURE CheckPoisoned (s: String) : String ;
 791 BEGIN
 792    IF PoisonOn AND (s # NIL) AND (s^.head # NIL) AND (s^.head^.state = poisoned)
 793    THEN
 794       HALT
 795    END ;
 796    RETURN s
 797 END CheckPoisoned ;
 798
 799
 800 (*
 801    KillString - frees String, s, and its contents.
 802                 NIL is returned.
 803 *)
 804
 805 PROCEDURE KillString (s: String) : String ;
 806 VAR
 807    t: String ;
 808 BEGIN
 809    IF PoisonOn
 810    THEN
 811       s := CheckPoisoned (s)
 812    END ;
 813    IF s # NIL
 814    THEN
 815       IF CheckOn
 816       THEN
 817          IF IsOnAllocated (s)
 818          THEN
 819             SubAllocated (s)
 820          ELSIF IsOnDeallocated (s)
 821          THEN
 822             SubDeallocated (s)
 823          END
 824       END ;
 825       WITH s^ DO
 826          IF head # NIL
 827          THEN
 828             WITH head^ DO
 829                state := poisoned ;
 830                garbage := KillString (garbage) ;
 831                IF NOT PoisonOn
 832                THEN
 833                   DeallocateCharStar (s)
 834                END
 835             END ;
 836             IF NOT PoisonOn
 837             THEN
 838                DISPOSE (head) ;
 839                head := NIL
 840             END
 841          END ;
 842          t := KillString (s^.contents.next) ;
 843          IF NOT PoisonOn
 844          THEN
 845             DISPOSE (s)
 846          END
 847       END
 848    END ;
 849    RETURN NIL
 850 END KillString ;
 851
 852
 853 (*
 854    Fin - finishes with a string, it calls KillString with, s.
 855          The purpose of the procedure is to provide a short cut
 856          to calling KillString and then testing the return result.
 857 *)
 858
 859 PROCEDURE Fin (s: String) ;
 860 BEGIN
 861    IF KillString (s) # NIL
 862    THEN
 863       HALT
 864    END
 865 END Fin ;
 866
 867
 868 (*
 869    MarkInvalid - marks the char * version of String, s, as invalid.
 870 *)
 871
 872 PROCEDURE MarkInvalid (s: String) ;
 873 BEGIN
 874    IF PoisonOn
 875    THEN
 876       s := CheckPoisoned (s)
 877    END ;
 878    IF s^.head # NIL
 879    THEN
 880       s^.head^.charStarValid := FALSE
 881    END
 882 END MarkInvalid ;
 883
 884
 885 (*
 886    ConcatContentsAddress - concatenate the string, a, where, h, is the
 887                            total length of, a.
 888 *)
 889
 890 PROCEDURE ConcatContentsAddress (VAR c: Contents; a: ADDRESS; h: CARDINAL) ;
 891 VAR
 892    p   : POINTER TO CHAR ;
 893    i, j: CARDINAL ;
 894 BEGIN
 895    j := 0 ;
 896    i := c.len ;
 897    p := a ;
 898    WHILE (j < h) AND (i < MaxBuf) DO
 899       c.buf[i] := p^ ;
 900       INC (i) ;
 901       INC (j) ;
 902       INC (p)
 903    END ;
 904    IF j < h
 905    THEN
 906       c.len := MaxBuf ;
 907       NEW (c.next) ;
 908       WITH c.next^ DO
 909          head          := NIL ;
 910          contents.len  := 0 ;
 911          contents.next := NIL ;
 912          ConcatContentsAddress (contents, p, h - j)
 913       END ;
 914       AddDebugInfo (c.next) ;
 915       IF TraceOn
 916       THEN
 917          c.next := AssignDebug (c.next, __FILE__, __LINE__, __FUNCTION__)
 918       END
 919    ELSE
 920       c.len := i ;
 921       c.next := NIL
 922    END
 923 END ConcatContentsAddress ;
 924
 925
 926 (*
 927    InitStringCharStar - initializes and returns a String to contain the C string.
 928 *)
 929
 930 PROCEDURE InitStringCharStar (a: ADDRESS) : String ;
 931 VAR
 932    s: String ;
 933 BEGIN
 934    NEW (s) ;
 935    WITH s^ DO
 936       WITH contents DO
 937          len := 0 ;
 938          next := NIL
 939       END ;
 940       IF a#NIL
 941       THEN
 942          ConcatContentsAddress (contents, a, strlen (a))
 943       END ;
 944       NEW (head) ;
 945       WITH head^ DO
 946          charStarUsed  := FALSE ;
 947          charStar      := NIL ;
 948          charStarSize  := 0 ;
 949          charStarValid := FALSE ;
 950          garbage       := NIL ;
 951          state         := inuse
 952       END
 953    END ;
 954    AddDebugInfo (s) ;
 955    IF TraceOn
 956    THEN
 957       s := AssignDebug (s, __FILE__, __LINE__, __FUNCTION__)
 958    END ;
 959    RETURN s
 960 END InitStringCharStar ;
 961
 962
 963 (*
 964    InitStringChar - initializes and returns a String to contain the single character, ch.
 965 *)
 966
 967 PROCEDURE InitStringChar (ch: CHAR) : String ;
 968 VAR
 969    a: ARRAY [0..1] OF CHAR ;
 970    s: String ;
 971 BEGIN
 972    a[0] := ch ;
 973    a[1] := nul ;
 974    s := InitString (a) ;
 975    IF TraceOn
 976    THEN
 977       s := AssignDebug (s, __FILE__, __LINE__, __FUNCTION__)
 978    END ;
 979    RETURN s
 980 END InitStringChar ;
 981
 982
 983 (*
 984    Mark - marks String, s, ready for garbage collection.
 985 *)
 986
 987 PROCEDURE Mark (s: String) : String ;
 988 BEGIN
 989    IF PoisonOn
 990    THEN
 991       s := CheckPoisoned (s)
 992    END ;
 993    IF (s # NIL) AND (s^.head^.state = inuse)
 994    THEN
 995       s^.head^.state := marked
 996    END ;
 997    RETURN s
 998 END Mark ;
 999
1000
1001 (*
1002    AddToGarbage - adds String, b, onto the garbage list of, a.  Providing
1003                   the state of b is marked.  The state is then altered to
1004                   onlist.  String, a, is returned.
1005 *)
1006
1007 PROCEDURE AddToGarbage (a, b: String) : String ;
1008 VAR
1009    c: String ;
1010 BEGIN
1011    IF PoisonOn
1012    THEN
1013       a := CheckPoisoned (a) ;
1014       b := CheckPoisoned (b)
1015    END ;
1016 (*
1017    IF (a#NIL) AND (a#b) AND (a^.head^.state=marked)
1018    THEN
1019       writeString('warning trying to add to a marked string') ; writeLn
1020    END ;
1021 *)
1022    IF (a # b) AND (a # NIL) AND (b # NIL) AND (b^.head^.state = marked) AND (a^.head^.state = inuse)
1023    THEN
1024       c := a ;
1025       WHILE c^.head^.garbage # NIL DO
1026          c := c^.head^.garbage
1027       END ;
1028       c^.head^.garbage := b ;
1029       b^.head^.state := onlist ;
1030       IF CheckOn
1031       THEN
1032          SubDebugInfo (b)
1033       END
1034    END ;
1035    RETURN a
1036 END AddToGarbage ;
1037
1038
1039 (*
1040    IsOnGarbage - returns TRUE if, s, is on string, e, garbage list.
1041 *)
1042
1043 PROCEDURE IsOnGarbage (e, s: String) : BOOLEAN ;
1044 BEGIN
1045    IF (e # NIL) AND (s # NIL)
1046    THEN
1047       WHILE e^.head^.garbage # NIL DO
1048          IF e^.head^.garbage = s
1049          THEN
1050             RETURN TRUE
1051          ELSE
1052             e := e^.head^.garbage
1053          END
1054       END
1055    END ;
1056    RETURN FALSE
1057 END IsOnGarbage ;
1058
1059
1060 (*
1061    Length - returns the length of the String, s.
1062 *)
1063
1064 PROCEDURE Length (s: String) : CARDINAL ;
1065 BEGIN
1066    IF s = NIL
1067    THEN
1068       RETURN 0
1069    ELSE
1070       RETURN s^.contents.len + Length (s^.contents.next)
1071    END
1072 END Length ;
1073
1074
1075 (*
1076    ConCat - returns String, a, after the contents of, b, have been appended.
1077 *)
1078
1079 PROCEDURE ConCat (a, b: String) : String ;
1080 VAR
1081    t: String ;
1082 BEGIN
1083    IF PoisonOn
1084    THEN
1085       a := CheckPoisoned (a) ;
1086       b := CheckPoisoned (b)
1087    END ;
1088    IF a = b
1089    THEN
1090       RETURN ConCat (a, Mark (Dup (b)))
1091    ELSIF a # NIL
1092    THEN
1093       a := AddToGarbage (a, b) ;
1094       MarkInvalid (a) ;
1095       t := a ;
1096       WHILE b # NIL DO
1097          WHILE (t^.contents.len = MaxBuf) AND (t^.contents.next # NIL) DO
1098             t := t^.contents.next
1099          END ;
1100          ConcatContents (t^.contents, b^.contents.buf, b^.contents.len, 0) ;
1101          b := b^.contents.next
1102       END
1103    END ;
1104    IF (a = NIL) AND (b # NIL)
1105    THEN
1106       HALT
1107    END ;
1108    RETURN a
1109 END ConCat ;
1110
1111
1112 (*
1113    ConCatChar - returns String, a, after character, ch, has been appended.
1114 *)
1115
1116 PROCEDURE ConCatChar (a: String; ch: CHAR) : String ;
1117 VAR
1118    b: ARRAY [0..1] OF CHAR ;
1119    t: String ;
1120 BEGIN
1121    IF PoisonOn
1122    THEN
1123       a := CheckPoisoned (a)
1124    END ;
1125    b[0] := ch ;
1126    b[1] := nul ;
1127    t := a ;
1128    MarkInvalid (a) ;
1129    WHILE (t^.contents.len = MaxBuf) AND (t^.contents.next # NIL) DO
1130       t := t^.contents.next
1131    END ;
1132    ConcatContents (t^.contents, b, 1, 0) ;
1133    RETURN a
1134 END ConCatChar ;
1135
1136
1137 (*
1138    ReplaceChar - returns string s after it has changed all occurances of from to to.
1139 *)
1140
1141 PROCEDURE ReplaceChar (s: String; from, to: CHAR) : String ;
1142 VAR
1143    t: String ;
1144    i: CARDINAL ;
1145 BEGIN
1146    t := s ;
1147    WHILE t # NIL DO
1148       i := 0 ;
1149       WHILE i < t^.contents.len DO
1150          IF t^.contents.buf[i] = from
1151          THEN
1152             t^.contents.buf[i] := to
1153          END ;
1154          INC (i)
1155       END ;
1156       t := t^.contents.next
1157    END ;
1158    RETURN s
1159 END ReplaceChar ;
1160
1161
1162 (*
1163    Assign - assigns the contents of, b, into, a.
1164             String, a, is returned.
1165 *)
1166
1167 PROCEDURE Assign (a, b: String) : String ;
1168 BEGIN
1169    IF PoisonOn
1170    THEN
1171       a := CheckPoisoned (a) ;
1172       b := CheckPoisoned (b)
1173    END ;
1174    IF (a # NIL) AND (b # NIL)
1175    THEN
1176       WITH a^ DO
1177          contents.next := KillString (contents.next) ;
1178          contents.len  := 0
1179       END
1180    END ;
1181    RETURN ConCat (a, b)
1182 END Assign ;
1183
1184
1185 (*
1186    Dup - duplicate a String, s, returning the copy of s.
1187 *)
1188
1189 PROCEDURE Dup (s: String) : String ;
1190 BEGIN
1191    IF PoisonOn
1192    THEN
1193       s := CheckPoisoned (s)
1194    END ;
1195    s := Assign (InitString (''), s) ;
1196    IF TraceOn
1197    THEN
1198       s := AssignDebug (s, __FILE__, __LINE__, __FUNCTION__)
1199    END ;
1200    RETURN s
1201 END Dup ;
1202
1203
1204 (*
1205    Add - returns a new String which contains the contents of a and b.
1206 *)
1207
1208 PROCEDURE Add (a, b: String) : String ;
1209 BEGIN
1210    IF PoisonOn
1211    THEN
1212       a := CheckPoisoned (a) ;
1213       b := CheckPoisoned (b)
1214    END ;
1215    a := ConCat (ConCat (InitString (''), a), b) ;
1216    IF TraceOn
1217    THEN
1218       a := AssignDebug (a, __FILE__, __LINE__, __FUNCTION__)
1219    END ;
1220    RETURN a
1221 END Add ;
1222
1223
1224 (*
1225    Equal - returns TRUE if String, a, and, b, are equal.
1226 *)
1227
1228 PROCEDURE Equal (a, b: String) : BOOLEAN ;
1229 VAR
1230    i: CARDINAL ;
1231 BEGIN
1232    IF PoisonOn
1233    THEN
1234       a := CheckPoisoned (a) ;
1235       b := CheckPoisoned (b)
1236    END ;
1237    IF Length (a) = Length (b)
1238    THEN
1239       WHILE (a # NIL) AND (b # NIL) DO
1240          i := 0 ;
1241          Assert (a^.contents.len = b^.contents.len) ;
1242          WHILE i<a^.contents.len DO
1243             IF a^.contents.buf[i] # b^.contents.buf[i]
1244             THEN
1245                RETURN FALSE
1246             END ;
1247             INC (i)
1248          END ;
1249          a := a^.contents.next ;
1250          b := b^.contents.next
1251       END ;
1252       RETURN TRUE
1253    ELSE
1254       RETURN FALSE
1255    END
1256 END Equal ;
1257
1258
1259 (*
1260    EqualCharStar - returns TRUE if contents of String, s, is the same as the
1261                    string, a.
1262 *)
1263
1264 PROCEDURE EqualCharStar (s: String; a: ADDRESS) : BOOLEAN ;
1265 VAR
1266    t: String ;
1267 BEGIN
1268    IF PoisonOn
1269    THEN
1270       s := CheckPoisoned (s)
1271    END ;
1272    t := InitStringCharStar (a) ;
1273    IF TraceOn
1274    THEN
1275       t := AssignDebug (t, __FILE__, __LINE__, __FUNCTION__)
1276    END ;
1277    t := AddToGarbage (t, s) ;
1278    IF Equal (t, s)
1279    THEN
1280       t := KillString (t) ;
1281       RETURN TRUE
1282    ELSE
1283       t := KillString (t) ;
1284       RETURN FALSE
1285    END
1286 END EqualCharStar ;
1287
1288
1289 (*
1290    EqualArray - returns TRUE if contents of String, s, is the same as the
1291                 string, a.
1292 *)
1293
1294 PROCEDURE EqualArray (s: String; a: ARRAY OF CHAR) : BOOLEAN ;
1295 VAR
1296    t: String ;
1297 BEGIN
1298    IF PoisonOn
1299    THEN
1300       s := CheckPoisoned (s)
1301    END ;
1302    t := InitString (a) ;
1303    IF TraceOn
1304    THEN
1305       t := AssignDebug (t, __FILE__, __LINE__, __FUNCTION__)
1306    END ;
1307    t := AddToGarbage (t, s) ;
1308    IF Equal (t, s)
1309    THEN
1310       t := KillString (t) ;
1311       RETURN TRUE
1312    ELSE
1313       t := KillString (t) ;
1314       RETURN FALSE
1315    END
1316 END EqualArray ;
1317
1318
1319 (*
1320    Mult - returns a new string which is n concatenations of String, s.
1321 *)
1322
1323 PROCEDURE Mult (s: String; n: CARDINAL) : String ;
1324 BEGIN
1325    IF PoisonOn
1326    THEN
1327       s := CheckPoisoned (s)
1328    END ;
1329    IF n<=0
1330    THEN
1331       s := AddToGarbage (InitString (''), s)
1332    ELSE
1333       s := ConCat (Mult (s, n-1), s)
1334    END ;
1335    IF TraceOn
1336    THEN
1337       s := AssignDebug (s, __FILE__, __LINE__, __FUNCTION__)
1338    END ;
1339    RETURN s
1340 END Mult ;
1341
1342
1343 (*
1344    Slice - returns a new string which contains the elements
1345            low..high-1
1346
1347            strings start at element 0
1348            Slice(s, 0, 2)  will return elements 0, 1 but not 2
1349            Slice(s, 1, 3)  will return elements 1, 2 but not 3
1350            Slice(s, 2, 0)  will return elements 2..max
1351            Slice(s, 3, -1) will return elements 3..max-1
1352            Slice(s, 4, -2) will return elements 4..max-2
1353 *)
1354
1355 PROCEDURE Slice (s: String; low, high: INTEGER) : String ;
1356 VAR
1357    d, t          : String ;
1358    start, stop, o: INTEGER ;
1359 BEGIN
1360    IF PoisonOn
1361    THEN
1362       s := CheckPoisoned (s)
1363    END ;
1364    IF low < 0
1365    THEN
1366       low := VAL (INTEGER, Length (s)) + low
1367    END ;
1368    IF high <= 0
1369    THEN
1370       high := VAL (INTEGER, Length (s)) + high
1371    ELSE
1372       (* make sure high is <= Length (s) *)
1373       high := Min (Length (s), high)
1374    END ;
1375    d := InitString ('') ;
1376    d := AddToGarbage (d, s) ;
1377    o := 0 ;
1378    t := d ;
1379    WHILE s # NIL DO
1380       IF low < o + VAL (INTEGER, s^.contents.len)
1381       THEN
1382          IF o > high
1383          THEN
1384             s := NIL
1385          ELSE
1386             (* found sliceable unit *)
1387             IF low < o
1388             THEN
1389                start := 0
1390             ELSE
1391                start := low - o
1392             END ;
1393             stop := Max (Min (MaxBuf, high - o), 0) ;
1394             WHILE t^.contents.len = MaxBuf DO
1395                IF t^.contents.next = NIL
1396                THEN
1397                   NEW (t^.contents.next) ;
1398                   WITH t^.contents.next^ DO
1399                      head         := NIL ;
1400                      contents.len := 0
1401                   END ;
1402                   AddDebugInfo (t^.contents.next) ;
1403                   IF TraceOn
1404                   THEN
1405                      t^.contents.next := AssignDebug (t^.contents.next, __FILE__, __LINE__, __FUNCTION__)
1406                   END
1407                END ;
1408                t := t^.contents.next
1409             END ;
1410             ConcatContentsAddress (t^.contents,
1411                                    ADR (s^.contents.buf[start]), stop - start) ;
1412             INC (o, s^.contents.len) ;
1413             s := s^.contents.next
1414          END
1415       ELSE
1416          INC (o, s^.contents.len) ;
1417          s := s^.contents.next
1418       END ;
1419    END ;
1420    IF TraceOn
1421    THEN
1422       d := AssignDebug (d, __FILE__, __LINE__, __FUNCTION__)
1423    END ;
1424    RETURN d
1425 END Slice ;
1426
1427
1428 (*
1429    Index - returns the indice of the first occurance of, ch, in
1430            String, s. -1 is returned if, ch, does not exist.
1431            The search starts at position, o.
1432 *)
1433
1434 PROCEDURE Index (s: String; ch: CHAR; o: CARDINAL) : INTEGER ;
1435 VAR
1436    i, k: CARDINAL ;
1437 BEGIN
1438    IF PoisonOn
1439    THEN
1440       s := CheckPoisoned (s)
1441    END ;
1442    k := 0 ;
1443    WHILE s # NIL DO
1444       WITH s^ DO
1445          IF k + contents.len < o
1446          THEN
1447             INC (k, contents.len)
1448          ELSE
1449             i := o - k ;
1450             WHILE i < contents.len DO
1451                IF contents.buf[i] = ch
1452                THEN
1453                   RETURN k + i
1454                END ;
1455                INC (i)
1456             END ;
1457             INC (k, i) ;
1458             o := k
1459          END
1460       END ;
1461       s := s^.contents.next
1462    END ;
1463    RETURN -1
1464 END Index ;
1465
1466
1467 (*
1468    RIndex - returns the indice of the last occurance of, ch,
1469             in String, s.  The search starts at position, o.
1470             -1 is returned if, ch, is not found.  The search
1471             is performed left to right.
1472 *)
1473
1474 PROCEDURE RIndex (s: String; ch: CHAR; o: CARDINAL) : INTEGER ;
1475 VAR
1476    i, k: CARDINAL ;
1477    j   : INTEGER ;
1478 BEGIN
1479    IF PoisonOn
1480    THEN
1481       s := CheckPoisoned (s)
1482    END ;
1483    j := -1 ;
1484    k :=  0 ;
1485    WHILE s # NIL DO
1486       WITH s^ DO
1487          IF k + contents.len < o
1488          THEN
1489             INC (k, contents.len)
1490          ELSE
1491             IF o < k
1492             THEN
1493                i := 0
1494             ELSE
1495                i := o - k
1496             END ;
1497             WHILE i < contents.len DO
1498                IF contents.buf[i] = ch
1499                THEN
1500                   j := k
1501                END ;
1502                INC (k) ;
1503                INC (i)
1504             END
1505          END
1506       END ;
1507       s := s^.contents.next
1508    END ;
1509    RETURN j
1510 END RIndex ;
1511
1512
1513 (*
1514    ReverseIndex - returns the indice of the last occurance of ch
1515                   in String s.  The search starts at position o
1516                   and searches from right to left.  The start position
1517                   may be indexed negatively from the right (-1 is the
1518                   last index).
1519                   The return value if ch is found will always be positive.
1520                   -1 is returned if ch is not found.
1521 *)
1522
1523 PROCEDURE ReverseIndex (s: String; ch: CHAR; o: INTEGER) : INTEGER ;
1524 VAR
1525    c: CARDINAL ;
1526 BEGIN
1527    IF PoisonOn
1528    THEN
1529       s := CheckPoisoned (s)
1530    END ;
1531    IF o < 0
1532    THEN
1533       o := VAL (INTEGER, Length (s)) + o ;
1534       IF o < 0
1535       THEN
1536          RETURN -1
1537       END
1538    END ;
1539    IF VAL (CARDINAL, o) < Length (s)
1540    THEN
1541       WHILE o >= 0 DO
1542          IF char (s, o) = ch
1543          THEN
1544             RETURN o
1545          ELSE
1546             DEC (o)
1547          END
1548       END
1549    END ;
1550    RETURN -1
1551 END ReverseIndex ;
1552
1553
1554 (*
1555    RemoveComment - assuming that, comment, is a comment delimiter
1556                    which indicates anything to its right is a comment
1557                    then strip off the comment and also any white space
1558                    on the remaining right hand side.
1559                    It leaves any white space on the left hand side alone.
1560 *)
1561
1562 PROCEDURE RemoveComment (s: String; comment: CHAR) : String ;
1563 VAR
1564    i: INTEGER ;
1565 BEGIN
1566    i := Index (s, comment, 0) ;
1567    IF i = 0
1568    THEN
1569       s := InitString ('')
1570    ELSIF i > 0
1571    THEN
1572       s := RemoveWhitePostfix (Slice (Mark (s), 0, i))
1573    END ;
1574    IF TraceOn
1575    THEN
1576       s := AssignDebug (s, __FILE__, __LINE__, __FUNCTION__)
1577    END ;
1578    RETURN s
1579 END RemoveComment ;
1580
1581
1582 (*
1583    char - returns the character, ch, at position, i, in String, s.
1584 *)
1585
1586 PROCEDURE char (s: String; i: INTEGER) : CHAR ;
1587 VAR
1588    c: CARDINAL ;
1589 BEGIN
1590    IF PoisonOn
1591    THEN
1592       s := CheckPoisoned (s)
1593    END ;
1594    IF i<0
1595    THEN
1596       c := VAL (CARDINAL, VAL (INTEGER, Length (s)) + i)
1597    ELSE
1598       c := i
1599    END ;
1600    WHILE (s # NIL) AND (c >= s^.contents.len) DO
1601       DEC (c, s^.contents.len) ;
1602       s := s^.contents.next
1603    END ;
1604    IF (s = NIL) OR (c >= s^.contents.len)
1605    THEN
1606       RETURN nul
1607    ELSE
1608       RETURN s^.contents.buf[c]
1609    END
1610 END char ;
1611
1612
1613 (*
1614    string - returns the C style char * of String, s.
1615 *)
1616
1617 PROCEDURE string (s: String) : ADDRESS ;
1618 VAR
1619    a   : String ;
1620    l, i: CARDINAL ;
1621    p   : POINTER TO CHAR ;
1622 BEGIN
1623    IF PoisonOn
1624    THEN
1625       s := CheckPoisoned (s)
1626    END ;
1627    IF s = NIL
1628    THEN
1629       RETURN NIL
1630    ELSE
1631       IF NOT s^.head^.charStarValid
1632       THEN
1633          l := Length (s) ;
1634          WITH s^.head^ DO
1635             IF NOT (charStarUsed AND (charStarSize > l))
1636             THEN
1637                DeallocateCharStar (s) ;
1638                ALLOCATE (charStar, l+1) ;
1639                charStarSize := l+1 ;
1640                charStarUsed := TRUE
1641             END ;
1642             p := charStar ;
1643          END ;
1644          a := s ;
1645          WHILE a#NIL DO
1646             i := 0 ;
1647             WHILE i < a^.contents.len DO
1648                p^ := a^.contents.buf[i] ;
1649                INC (i) ;
1650                INC (p)
1651             END ;
1652             a := a^.contents.next
1653          END ;
1654          p^ := nul ;
1655          s^.head^.charStarValid := TRUE
1656       END ;
1657       RETURN s^.head^.charStar
1658    END
1659 END string ;
1660
1661
1662 (*
1663    IsWhite - returns TRUE if, ch, is a space or a tab.
1664 *)
1665
1666 PROCEDURE IsWhite (ch: CHAR) : BOOLEAN ;
1667 BEGIN
1668    RETURN (ch = ' ') OR (ch = tab)
1669 END IsWhite ;
1670
1671
1672 (*
1673    RemoveWhitePrefix - removes any leading white space from String, s.
1674                        A new string is returned.
1675 *)
1676
1677 PROCEDURE RemoveWhitePrefix (s: String) : String ;
1678 VAR
1679    i: CARDINAL ;
1680 BEGIN
1681    i := 0 ;
1682    WHILE IsWhite (char (s, i)) DO
1683       INC (i)
1684    END ;
1685    s := Slice (s, INTEGER (i), 0) ;
1686    IF TraceOn
1687    THEN
1688       s := AssignDebug (s, __FILE__, __LINE__, __FUNCTION__)
1689    END ;
1690    RETURN s
1691 END RemoveWhitePrefix ;
1692
1693
1694 (*
1695    RemoveWhitePostfix - removes any leading white space from String, s.
1696                         A new string is returned.
1697 *)
1698
1699 PROCEDURE RemoveWhitePostfix (s: String) : String ;
1700 VAR
1701    i: INTEGER ;
1702 BEGIN
1703    i := VAL(INTEGER, Length (s)) - 1 ;
1704    WHILE (i >= 0) AND IsWhite (char (s, i)) DO
1705       DEC (i)
1706    END ;
1707    s := Slice (s, 0, i+1) ;
1708    IF TraceOn
1709    THEN
1710       s := AssignDebug (s, __FILE__, __LINE__, __FUNCTION__)
1711    END ;
1712    RETURN s
1713 END RemoveWhitePostfix ;
1714
1715
1716 (*
1717    ToUpper - returns string, s, after it has had its lower case characters
1718              replaced by upper case characters.
1719              The string, s, is not duplicated.
1720 *)
1721
1722 PROCEDURE ToUpper (s: String) : String ;
1723 VAR
1724    ch: CHAR ;
1725    i : CARDINAL ;
1726    t : String ;
1727 BEGIN
1728    IF s # NIL
1729    THEN
1730       MarkInvalid (s) ;
1731       t := s ;
1732       WHILE t # NIL DO
1733          WITH t^ DO
1734             i := 0 ;
1735             WHILE i < contents.len DO
1736                ch := contents.buf[i] ;
1737                IF (ch >= 'a') AND (ch <= 'z')
1738                THEN
1739                   contents.buf[i] := CHR (ORD (ch) - ORD ('a') + ORD ('A'))
1740                END ;
1741                INC (i)
1742             END
1743          END ;
1744          t := t^.contents.next
1745       END
1746    END ;
1747    RETURN s
1748 END ToUpper ;
1749
1750
1751 (*
1752    ToLower - returns string, s, after it has had its upper case characters
1753              replaced by lower case characters.
1754              The string, s, is not duplicated.
1755 *)
1756
1757 PROCEDURE ToLower (s: String) : String ;
1758 VAR
1759    ch: CHAR ;
1760    i : CARDINAL ;
1761    t : String ;
1762 BEGIN
1763    IF s # NIL
1764    THEN
1765       MarkInvalid (s) ;
1766       t := s ;
1767       WHILE t # NIL DO
1768          WITH t^ DO
1769             i := 0 ;
1770             WHILE i < contents.len DO
1771                ch := contents.buf[i] ;
1772                IF (ch >= 'A') AND (ch <= 'Z')
1773                THEN
1774                   contents.buf[i] := CHR (ORD (ch) - ORD ('A') + ORD ('a'))
1775                END ;
1776                INC (i)
1777             END
1778          END ;
1779          t := t^.contents.next
1780       END
1781    END ;
1782    RETURN s
1783 END ToLower ;
1784
1785
1786 (*
1787    InitStringDB - the debug version of InitString.
1788 *)
1789
1790 PROCEDURE InitStringDB (a: ARRAY OF CHAR; file: ARRAY OF CHAR; line: CARDINAL) : String ;
1791 BEGIN
1792    RETURN AssignDebug (InitString (a), file, line, 'InitString')
1793 END InitStringDB ;
1794
1795
1796 (*
1797    InitStringCharStarDB - the debug version of InitStringCharStar.
1798 *)
1799
1800 PROCEDURE InitStringCharStarDB (a: ADDRESS; file: ARRAY OF CHAR; line: CARDINAL) : String ;
1801 BEGIN
1802    RETURN AssignDebug (InitStringCharStar (a), file, line, 'InitStringCharStar')
1803 END InitStringCharStarDB ;
1804
1805
1806 (*
1807    InitStringCharDB - the debug version of InitStringChar.
1808 *)
1809
1810 PROCEDURE InitStringCharDB (ch: CHAR; file: ARRAY OF CHAR; line: CARDINAL) : String ;
1811 BEGIN
1812    RETURN AssignDebug (InitStringChar (ch), file, line, 'InitStringChar')
1813 END InitStringCharDB ;
1814
1815
1816 (*
1817    MultDB - the debug version of MultDB.
1818 *)
1819
1820 PROCEDURE MultDB (s: String; n: CARDINAL; file: ARRAY OF CHAR; line: CARDINAL) : String ;
1821 BEGIN
1822    RETURN AssignDebug (Mult (s, n), file, line, 'Mult')
1823 END MultDB ;
1824
1825
1826 (*
1827    DupDB - the debug version of Dup.
1828 *)
1829
1830 PROCEDURE DupDB (s: String; file: ARRAY OF CHAR; line: CARDINAL) : String ;
1831 BEGIN
1832    RETURN AssignDebug (Dup (s), file, line, 'Dup')
1833 END DupDB ;
1834
1835
1836 (*
1837    SliceDB - debug version of Slice.
1838 *)
1839
1840 PROCEDURE SliceDB (s: String; low, high: INTEGER;
1841                    file: ARRAY OF CHAR; line: CARDINAL) : String ;
1842 BEGIN
1843    DSdbEnter ;
1844    s := AssignDebug (Slice (s, low, high), file, line, 'Slice') ;
1845    DSdbExit (s) ;
1846    RETURN s
1847 END SliceDB ;
1848
1849
1850 (*
1851    DumpState -
1852 *)
1853
1854 PROCEDURE DumpState (s: String) ;
1855 BEGIN
1856    CASE s^.head^.state OF
1857
1858    inuse   :  writeString ("still in use (") ; writeCard (s^.contents.len) ; writeString (") characters") |
1859    marked  :  writeString ("marked") |
1860    onlist  :  writeString ("on a garbage list") |
1861    poisoned:  writeString ("poisoned")
1862
1863    ELSE
1864       writeString ("unknown state")
1865    END
1866 END DumpState ;
1867
1868
1869 (*
1870    DumpStringSynopsis -
1871 *)
1872
1873 PROCEDURE DumpStringSynopsis (s: String) ;
1874 BEGIN
1875    writeCstring (s^.debug.file) ; writeString (':') ;
1876    writeCard (s^.debug.line) ; writeString (':') ;
1877    writeCstring (s^.debug.proc) ;
1878    writeString (' string ') ;
1879    writeAddress (s) ;
1880    writeString (' ') ;
1881    DumpState (s) ;
1882    IF IsOnAllocated (s)
1883    THEN
1884       writeString (' globally allocated')
1885    ELSIF IsOnDeallocated (s)
1886    THEN
1887       writeString (' globally deallocated')
1888    ELSE
1889       writeString (' globally unknown')
1890    END ;
1891    writeLn
1892 END DumpStringSynopsis ;
1893
1894
1895 (*
1896    DumpString - displays the contents of string, s.
1897 *)
1898
1899 PROCEDURE DumpString (s: String) ;
1900 VAR
1901    t: String ;
1902 BEGIN
1903    IF s # NIL
1904    THEN
1905       DumpStringSynopsis (s) ;
1906       IF (s^.head # NIL) AND (s^.head^.garbage # NIL)
1907       THEN
1908          writeString ('display chained strings on the garbage list') ; writeLn ;
1909          t := s^.head^.garbage ;
1910          WHILE t # NIL DO
1911             DumpStringSynopsis (t) ;
1912             t := t^.head^.garbage
1913          END
1914       END
1915    END
1916 END DumpString ;
1917
1918
1919 (*
1920    Init - initialize the module.
1921 *)
1922
1923 PROCEDURE Init ;
1924 BEGIN
1925    IF NOT Initialized
1926    THEN
1927       Initialized := TRUE ;
1928       frameHead := NIL ;
1929       PushAllocation ;
1930    END
1931 END Init ;
1932
1933
1934 BEGIN
1935    Initialized := FALSE ;
1936    Init
1937 END DynamicStrings.