home *** CD-ROM | disk | FTP | other *** search
- 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.
-
-
-