program stest;

{ a program to exercise the string functions of the Facilis compiler }

{ by Anthony M. Marcy
  updated: 11 Jan 85  }

var
  i,j,n,e: integer;

procedure one;

const
  con = 'a constant string';
  v = 'a constant string';
  w = v;

type
  atyp = array[1..10] of string;
  rtyp = record
           h:integer;
           s:string;
         end;

var
  p,q,r,s,t : string;
  s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,s11,s12,s13,s14,s15,s16,s17: string;
  a: atyp;
  ch,c,c1: char;
  rec,rec2:rtyp;
  carray: array[1..5] of char;
  re: real;

  procedure parpass(var v1,v2: string; v3:string; v4:atyp);

    procedure level_2(var w1: string);

    begin
      w1 := w1 + 'r';
    end;

  begin
    v1 := v1 + 'mete';
    v3 := v3 + 'mete';
    level_2(v1); level_2(v3);
    v2 := v3;
    if v4[5] <> 'Value para' then begin
      writeln('***ARRAY VAL PARAM FAILURE'); e := e+1; end;
    V4[5] := 'a long dummy string';
  end; {parpass}

begin  {one}
  write('''','7 chars long':7,'''');
    writeln('            =   ''7 chars ''');
  write('''','13 cha'+'rs long':13,'''');
    writeln('      =   ''13 chars long''');
  writeln('''',w,'   =   ''a constant string''');
  if w <> v then begin
    writeln('***CONSTANT DECLARATION FAILURE'); e := e+1; end;
  s1 := 'a literal string'; write('''',s1,'''');
     writeln('   =   ''a literal string''');
  s2 := 'assignment';
  t := s2; write('''',t,'''');
    writeln('         =   ''assignment''');

  s := 'ab';
  if not (('abc'='abc') and (s+'d'>'abc') and ('abc'<'abd') and ('abc'>'ab')
    and (s<>'ba') and ('a'<'abc') and ('b'>s+'c') and ('abc'>'a')
    and (s+'c'<'b'))
    or ((s+s)=s) or ('a'>'b') or ('ba'<=copy(s,1,1)+'b')
    or (s>=('a'+'b'+'c'))
    then begin
      writeln('***RELATIONAL OPERATOR FAILURE'); e := e+1; end;

  t := 'arrays and records';
  a[7] := t; rec.s := a[7]; s3 := rec.s;
  write('''',s3,'''');
    writeln(' =   ''arrays and records''');
  rec2 := rec; rec2.s := 'X';
  if (rec.s <> t) or (rec2.s <> 'X')
    then begin
      writeln('***RECORD ASSIGNMENT FAILURE'); e := e+1; end;

  c := 's'; s4 := c; write('''',s4,'tring := char''');
    writeln('     =   ''string := char''');
  s5 := t;  s5 := 'c';  c := s5; write('''',c,'har := string''');
    writeln('     =   ''char := string''');
  if (s4 <> 's') or (c <> 'c')
    then begin
      writeln('***CHAR ASSIGNMENT FAILURE'); e := e+1; end;

  s6 := 'h' + 'a'; write('''char + c',s6,'r''');
    writeln('        =   ''char + char''');
  s7 := 'c' + 'har'; write('''',s7,' + string''');
    writeln('      =   ''char + string''');
  s8 := 'cha' + 'r'; write('''string + ',s8,'''');
    writeln('      =   ''string + char''');
  s9 := 'string'; s9 := s9+' + '+s9; write('''',s9,'''');
    writeln('    =   ''string + string''');
  if (s6 <> 'ha') or (s7 <> 'char') or (s8 <> 'char')
    or (s9 <> 'string + string')
    then begin
      writeln('***CONCATENATION FAILURE'); e := e+1; end;

  writeln; write('Please enter a string: ');
  read(s17);
  writeln( 'Your string is        ''',s17,''''); writeln;

  s := 'ghCopy fudd'; s10 := copy(s,3,7); writeln(s10,'nction');
  s14 := copy('XXXtemp '+'stringXXX',4,11);
  c := 'A'; s15 := copy(c,1,1);
  s11 := copy('XXXXrightstring',5);
  if (s14 <> 'temp string') or (s15 <> 'A') or (s11 <> 'rightstring')
    then begin
      writeln('***COPY FUNCTION FAILURE'); e := e+1; end;

  q := 'avprnlwcif'; s := 'Pos fu'; n := pos('f',s);
  writeln(s,q[n],'ction');
  if (pos('lw',q) <> 6) or (pos('za','z'+q) <> 1) or (pos('',q) <> 0)
    or (pos(q,'') <> 0) or (pos('wc'+'ifx',q) <> 0)
    or (pos('ci'+'fx',q+'xu') <> 8) or (n <> 5)
    then begin
      writeln('***POS FUNCTION FAILURE'); e := e+1; end;

  s := 'gnixednI gnirtS'; for n := 15 downto 1 do write(s[n]); writeln;
    if (s[1] <> 'g') or (s[13] <> 'r')
      then begin
        writeln('***INDEXING FAILURE'); e := e+1; end;

  q := ' dummy';
  if (length(q) <> 6) or (length(q+s) <> 21)
     or (length('') <> 0) or (length('Q') <> 1)
     then begin
       writeln('***LENGTH FUNCTION FAILURE'); e := e+1; end;

  s12 := 'Var para'; q := 'Value para'; t := 'oops'; a[5] := q;
  parpass(s12,t,q,a); writeln(s12); writeln(t);
  if (q <> 'Value para') or (a[5] <> 'Value para')
    then begin
      writeln('***VALUE PARAMETER CHANGED'); e := e+1; end;

  carray := 'charXr'; carray[5] := 'a'; s16 := carray;
  carray := 'rr'+'ay'; s := carray;
    if (s16 <> 'chara') or (s <> 'rray ')
      then begin
        writeln('***CHAR ARRAY NOT COMPATIBLE'); e := e+1; end;

  if (str(-12345) <> '-12345') or (str(765.4321E21) <> '  7.6543210000E+23')
    then begin
      writeln('***STR FUNCTION FAILURE'); e := e+1; end;

  if (val('12345') <> 12345) or (val('-111'+'11') <> -11111)
    then begin
      writeln('***VAL FUNCTION FAILURE'); e := e+1; end;
  if (rval('12345678.0') <> 1.2345678e7) or (rval('3.1'+'416') <> 3.1416)
    then begin
      writeln('***RVAL FUNCTION FAILURE'); e := e+1; end;

  writeln('four null strings: ''','','''   ''',copy(c,4,1),'''   ''',
      copy('xx',-3,2),'''   ''',copy('xx',1,-3),'''');

end; {one}

begin  {main}
  e := 0; writeln; writeln;
  writeln('                STEST.PAS -- string testing program'); writeln;
  i := maxavail;
  one;
  j := maxavail; writeln;
  if i <> j then writeln('***GARBAGE COLLECTION FAILURE')
            else writeln('garbage collection OK');
  writeln; writeln('STRING TESTING COMPLETED');
  if e > 0 then write(e) else write('NO');
  writeln(' ERRORS FOUND');
  writeln;

end.