PROGRAM tstrings (output);

  { Test of Extended Pascal string facilities }
  { 18 December 1990, from Prospero Software }
  { 13 Nov 2005, modified to remove Prospero extensions }

CONST maxcapacity = 32760;
      maxerror = 99;
      diagnose = false;

TYPE  caprange = 0..maxcapacity;
      errors = 1..maxerror;
      s20 = string(20);
      pac20 = packed array [1..20] of char;

VAR   s1,s2: s20;
      s3: string(100);
      x1,x2: pac20;
      err: Boolean VALUE false;

PROCEDURE fail(n: errors);
  BEGIN
    writeln('Fail ',n);  err := true;
  END {fail};

PROCEDURE comparisons;
  VAR   lstring: string(40);
  BEGIN
    s1 := '123456789';
    x1 := 'abcdefgh';
    lstring := s1 + ' ' + x1;
    IF (s1 <> '123456789   ') OR (x1 <> 'abcdefgh') THEN fail(11);
    IF lstring <> s1 + ' abcdefgh' THEN fail(12);
    IF NOT lt(s1,'123456789  ') THEN fail(13);
  END {comparisons};

PROCEDURE substrings(n: caprange);
  VAR   j,k: caprange;
	lstring: string(40);
	nstring: string(n);
  BEGIN
    j := 3;  k := 4;
    s1 := '123456789';
    x1 := 'abcdefgh';
    lstring := s1[j..j+3] + x1[k..k+5];
    IF length(lstring) <> 10 THEN fail(21);
    lstring[j..k] := ' ';
    IF NOT eq(lstring,'34  defgh ') THEN
      BEGIN
	fail(22);
	IF diagnose THEN writeln(lstring,length(lstring));
      END;
    nstring := s1[j..j+3] + x1[k..k+5];
    IF length(nstring) <> 10 THEN fail(23);
    nstring[j..k] := ' ';
    IF NOT eq(nstring,'34  defgh ') THEN
      BEGIN
	fail(24);
	IF diagnose THEN writeln(nstring,length(nstring));
      END;
  END {substrings};

PROCEDURE indexing(n: caprange);
  VAR   j,k: caprange;
	ls: string(n) VALUE '0000000000';
	lx: pac20 VALUE [1:'1'; 3:'3'; 5:'5'; OTHERWISE '0'];
  BEGIN
    j := 3;
    s1 := '0000000000';
    x1 := ' ';
    FOR k := 1 TO 9 DO
      BEGIN
	s1[k] := chr(ord(s1[k]) + k);
	ls[k] := succ('0',k);
      END;
    FOR k := 2 TO 12 DO x1[k] := succ('a',k-2);
    k := 4;
    REPEAT
      IF s1[j+5] <> '8' THEN fail(31);
      IF x1[j] <> 'b' THEN fail(32);
      IF NOT eq(s1[k..k+2],s1[k]+s1[k+1]+s1[k+2]) THEN fail(33);
      IF x1[j*k..20][1] <> 'k' THEN fail(34);
      IF ls[j+5] <> '8' THEN fail(35);
      IF NOT eq(ls[k..k+2],ls[k]+ls[k+1]+ls[k+2]) THEN fail(36);
      IF NOT eq(ls[k-1]+ls[k+1],lx[k-1]+lx[k+1]) THEN fail(37);
    UNTIL true;
  END {indexing};

PROCEDURE parameters(n: word; fval: string);
  VAR   ls1,ls2: s20;  ls3,ls4: string(n);

  PROCEDURE variableparam(VAR fs1,fs2: string);
    BEGIN
      fs1 := 'one';
      fs2 := fs1 + ' ' + 'two';
    END {variableparam};

  PROCEDURE valueparam(fst1,fst2: s20);
    VAR   lst: string(40);
    BEGIN
      lst := fst1 + ' ' + fst2;
      IF length(lst) <> succ(length(fst1) + length(fst2)) THEN
	BEGIN
	  fail(42);
	  IF diagnose THEN writeln(lst,length(lst):4);
	END;
    END {valueparam};

  BEGIN {parameters};
    variableparam(ls1,ls2);
    IF ls2 <> 'one two ' THEN
      BEGIN
	fail(41);
	IF diagnose THEN writeln(ls2,length(ls2):4);
      END;
    valueparam(fval,ls2);
    variableparam(ls3,ls4);
    IF ls4 <> 'one two ' THEN
      BEGIN
	fail(43);
	IF diagnose THEN writeln(ls4,length(ls4):4);
      END;
    variableparam(ls1,ls4);
    IF ls4 <> 'one two ' THEN
      BEGIN
	fail(43);
	IF diagnose THEN writeln(ls4,length(ls4):4);
      END;
  END {parameters};

PROCEDURE DynamicAllocation(fcap: caprange);
  VAR   sp1: ^s20;  sp2: ^string;
  BEGIN
    new(sp1);
    sp1^ := 'one two ';
    new(sp2,fcap);
    sp2^ := 'three';
    IF (sp2^.capacity <> fcap) or (length(sp2^) <> length('three')) THEN
      BEGIN
	fail(51);
	IF diagnose THEN writeln(sp2^,sp2^.capacity:4,length(sp2^):4);
      END;
    IF NOT eq(sp1^ + sp2^,'one two three') THEN fail(52);
    dispose(sp1);
    dispose(sp2);
  END {DynamicAllocation};

PROCEDURE ReadingAndWriting;
  BEGIN
  END {ReadingAndWriting};

PROCEDURE RequiredProcedures;
  CONST lin = '   543 543.21 Fred Bloggs';
  VAR   i: integer; r: real; ch: char;
	lstring: string(50);
	lpac: pac20;
  BEGIN
    readstr(lin,i,r,ch,lpac);
    writestr(lstring,i,r:7:2,ch,lpac);
    IF lstring <> lin THEN fail(71);
  END {RequiredProcedures};

PROCEDURE RequiredFunctions;
  VAR  i,j,k: caprange;
       ls1,ls2: string(30);
       lx: pac20;
  BEGIN
    i := 7;  j := 16;  k := 0;
    ls1 := 'ABCDEFGHIJKLMNOPQRSTUVWXYZ';
    ls2 := 'PQX';
    IF index(ls1,'') <> 1 THEN fail(61);
    IF index(ls1,'G') <> 7 THEN fail(62);
    IF index(ls1 + ls2 + 'YZ',ls2) <> succ(length(ls1)) THEN fail(63);
    IF index(ls1 + 'bcdefghij','a') <> 0 THEN fail(64);
    ls2 := substr(ls1,i,j);
    IF substr(ls2,10,3) <> 'PQR' THEN
      BEGIN
	fail(65);
	IF diagnose THEN writeln('ls2 = |',ls2,'|');
      END;
    IF length(substr(ls2,i,k)) > 0 THEN fail(66);
    IF substr(ls1,1,i-1) + ls2 + substr(ls1,i+j) <> ls1 THEN
      BEGIN
	fail(67);
	IF diagnose THEN
	  BEGIN
	    s1 := substr(ls1,1,i-1);
	    s2 := substr(ls1,i+j);
	    writeln('|',s1,'|',ls2,'|',s2,'|');
	  END;
      END;
    lx := ls2;
    IF NE(trim(lx),ls2) THEN fail(68);
  { IF length(ls1 + ls2) <> length(ls1) + length(ls2) THEN fail(69); }
  END {RequiredFunctions};

PROCEDURE StringExtensions;
  VAR  j,k: caprange;
       ls1,ls2: string(30);
       ls3: string(20);
  BEGIN
    k := 5;
    ls1 := 'abcdefhijk';
    setlength(ls2,k+length(ls1));
    FOR j := 1 TO k DO ls2[j] := ' ';
    FOR j := 1 TO length(ls1) DO ls2[j+k] := ls1[j];
    IF ls2[k+2..k+4] <> 'bcd' THEN fail(71);
{     IF ne(ltrim(ls2),ls1) THEN fail(72);  }
    ls1 := 'abcde';
    ls2 := concat(ls1,'fgh');
    ls3 := copy(ls2,4,4);
    IF ne(ls3,'defg') THEN fail(73);
    IF pos(ls3,ls2) <> 4 THEN fail(74);
    insert('x',ls3,3);
    insert(ls3,ls2,6);
    IF ne(ls2,'abcdedexfgfgh') THEN fail(75);
    delete(ls3,3,1);
    delete(ls2,6,5);
    IF concat(ls2,'Ý',ls3) <> concat(ls1,'fghÝdefg') THEN fail(76);
    ls1 := 'abcdefghIJK';
    ls2 := 'uvwXYZ';
{    IF (UpperCase(ls1[8]) <> 'H') OR
       (LowerCase(ls2[5]) <> 'y') THEN fail(77);
    IF (UpperCase(ls1) + LowerCase(ls2)) <>
	      'ABCDEFGHIJKuvwxyz' THEN fail(78);
}
  END {StringExtensions};

BEGIN
  writeln('String tests');
  comparisons;
  substrings(25);
  indexing(14);
  parameters(20,'initial value ');
  DynamicAllocation(20);
  RequiredProcedures;
  RequiredFunctions;
  StringExtensions;
  IF err THEN halt(2)
  ELSE writeln('No errors');
END.