Personal tools
You are here: Home Projects SETL LITTLE Source code TST: Various test programs for the LITTLE system software, principally the compiler.
Document Actions

TST: Various test programs for the LITTLE system software, principally the compiler.

by Paul McJones last modified 2021-03-17 19:54

TST: Various test programs for the LITTLE system software, principally the compiler.

       1 .=member intro
       2$
       3$      !$&'()*+,-./0123456789:;<=>abcdefghijklmnopqrstuvwxyz^_
       4$     the above line contains, in order of ascii codes, the 56
       5$     characters of the little language, starting in column 7.
       6$
       7$ $$          $$$$$$$$$$  $$$$$$$$$$  $$$$$$$$$$  $$          $$$$$$$$$$
       8$ $$          $$$$$$$$$$  $$$$$$$$$$  $$$$$$$$$$  $$          $$$$$$$$$$
       9$ $$              $$          $$          $$      $$          $$
      10$ $$              $$          $$          $$      $$          $$
      11$ $$              $$          $$          $$      $$          $$$$$$
      12$ $$              $$          $$          $$      $$          $$$$$$
      13$ $$              $$          $$          $$      $$          $$
      14$ $$              $$          $$          $$      $$          $$
      15$ $$$$$$$$$$  $$$$$$$$$$      $$          $$      $$$$$$$$$$  $$$$$$$$$$
      16$ $$$$$$$$$$  $$$$$$$$$$      $$          $$      $$$$$$$$$$  $$$$$$$$$$
      17$
      18
      19$             $$$$$$$$$$  $$$$$$$$$$   $$$$$$$$   $$$$$$$$$$
      20$             $$$$$$$$$$  $$$$$$$$$$  $$$$$$$$$$  $$$$$$$$$$
      21$                 $$      $$          $$       $      $$
      22$                 $$      $$          $$              $$
      23$                 $$      $$$$$$      $$$$$$$$$       $$
      24$                 $$      $$$$$$       $$$$$$$$$      $$
      25$                 $$      $$                  $$      $$
      26$                 $$      $$          $       $$      $$
      27$                 $$      $$$$$$$$$$  $$$$$$$$$$      $$
      28$                 $$      $$$$$$$$$$   $$$$$$$$       $$
      29$
      30$     this software is part of the little programming system.
      31$              address queries and comments to
      32$
      33$                       little project
      34$               department of computer science
      35$                    new york university
      36$         courant institute of mathematical sciences
      37$                     251 mercer street
      38$                    new york,  ny  10012
      39$
      40$     this file contains various test programs for the little
      41$     system software, principally the compiler.
      42$
      43$     the principal authors of the little compiler are
      44$     robert abes, edith deak, richard kenner, david shields
      45$     and aaron stein.
      46$
      47$
dsa    1$  bint
dsa    2$     bootstrap test, prints integer
dsa    3$
dsa    4$  bstr
dsa    5$     bootstrap tset, prints string
dsa    6$
dsa    7$  bparm
dsa    8$     bootstrap test, prints 'n' numeric program parameter, 's'
dsa    9$     string program parameter
dsa   10$
dsa   11$  bcopy
dsa   12$     bootstrap test, does file copy with optional case folding.
dsa   13$     use to check that cases fold correctly (where appropriate).
dsa   14$
dsa   15$  berror
dsa   16$     bootstrap test, generates errors selected by program parameter.
dsa   17
      48$
      49$
      50$  tcomp
      51$       comprehensive (sic) test of the little compiler.  includes
      52$       most of the examples given in little guide.
      53$
      54$  tmac
      55$       test of macro processor in scan phase (lex).
      56$
      57$  treal
      58$       test of real arithmetic
      59$
      60$  tsynerr
      61$       contains various syntactic errors to test error
      62$       processing, principally that of the gen phase.
      63$
      64$  tcodgen
      65$       contains various fragments to be examined to study
      66$       correctness and quality of generated code.
      67$
       1 .=member mods
       2 $    --- all corrections are to include self-description at mods.2 ---
dsa   18
dsa   19 $    dsa       d. shields          18-dec-81
dsa   20 $
dsa   21 $    add several simple tests for bootstrap checkout.
dsa   22 $    decks affected - bint, bstr, bparm, bcopy, berror (all new)
dsa   23
       3
       4 $    (none)    d. shields          20 jun 78
       5 $
       6 $    release initial version, show form of mods notice.
       7 $    decks affected - all.
       8
       1 .=member bint
       2$ simple little test program, just print an integer
       3prog bint;
       4put ,x :1,i ,skip;
       5end;
       1 .=member bstr
       2$ bstr: simple little test program, just print a string
       3prog bstr;
       4put ,' hello world!' ,skip;
       5end;
       1 .=member bparm
       2prog bparm;
       3$ bparm: little test program
       4+* ws = .ws. ** +* ps=.ps.** +* cs=.cs. **
       5+*  filenamelen = 20 **
       6 .+s32  +* filenamelen = 64 **
       7 .+s47  +* filenamelen = 64 **
       8size n(ws);
       9size s(.sds. filenamelen);
      10size c(ws);
      11call getipp(n,'n=0/1');
      12put ,'n parameter (numeric) is ' :n,i ,skip;
      13call getspp(s,'s=default/alternate');
      14put ,'s parameter (string) is <' :s,a ,'>' ,skip;
      15end;
       1 .=member bcopy
       2prog bcopy;
       3$ bcopy: copy standard output to standard output according
       4$ to parameter c:
       5$       c=0 (default)   straight copy
       6$       c=1             fold to lower case
       7$       c=2             fold to upper case
       8+* ws = .ws. ** +* ps=.ps.** +* cs=.cs. **
       9+*  filenamelen = 20 **
      10 .+s32  +* filenamelen = 64 **
      11 .+s47  +* filenamelen = 64 **
      12size c(ws);
      13size line (.sds. 80);
      14call getipp(c,'c=0/0');
      15if c<0 ! c>2 then
      16  put ,'usage: c=1 to fold lower, c=2 to fold upper',skip;
      17  return;
      18end if;
      19call fold;
      20end;
      21subr fold;
      22while 1;
      23  get 1 ,skip :line,a(80);
      24  if (filestat(1,end)) quit;
      25  if c=1 then call stlc(line);
      26  elseif c=2 then call stuc(line);
      27  end if;
      28  put 2 :line,a ,skip;
      29end while;
      30end subr;
       1 .=member berror
       2prog berror;
       3$ berror: little test program of errors
       4$ generate various tests of (intentional) program errors.
       5$ test error handling. with program parameter e as follows:
       6$       e=0 (default)   print 'it works!'
       7$       e=1             address exception.
       8$       e=2             bad goto index
       9$       e=3             bad file number
      10$       e=4             bad file name
      11+* ws = .ws. ** +* ps=.ps.** +* cs=.cs. **
      12+*  filenamelen = 20 **
      13 .+s32  +* filenamelen = 64 **
      14 .+s47  +* filenamelen = 64 **
      15+* errmax = 4 **
      16size e(.ws.);
      17size a(.ws.),b(.ps.);
      18size i(ws);
      19
      20call getipp(e,'e=0/1');
      21if e=0 then
      22  put, 'it works',skip;
      23  return;
      24end if;
      25if e<1 ! e>errmax then
      26  put ,'usage: e in 1..' :errmax,i ,skip;
      27  return;
      28end if;
      29put ,'error test ' :e,i ,skip;
      30go to l(e) in 1 to errmax;
      31/l(1)/
      32  put ,'generating address exception (large index).',skip;
      33  size e2ara(ws); dims e2ara(10); size e2i(ps);
      34  e2i=1000000;
      35  a = e2ara(e2i);
      36  $ should never reach here
      37  put ,'exception not noted',skip;
      38  return;
      39/l(2)/ $ bad goto index
      40  i = 3;
      41  go to el(i) in 1 to 2;
      42  /el(1)/
      43  /el(2)/
      44        put ,'error, test 3 fell through',skip;
      45        return;
      46  $ should not reach here.
      47/l(3)/ $ bad file number
      48  put ,'trying to open file with bad file number',skip;
      49  i = 220;
      50  file i title='',access=get;
      51  return;
      52/l(4)/ $ bad file name
      53  put ,'bad file name !@#$' ,skip;
      54  file 3 access=put,title='!@#$',linesize=80;
      55  i = filestat(3,access);
      56  put ,'filestat after file statement ' :i,i ,skip;
      57  put ,'status reported in above line should be zero.' ,skip;
      58$  put 3 ,'should not appear, bad file name' ,skip;
      59  put 3 :i,i ,skip;
      60end prog;
      61subr usratp;
      62  put ,'if see this, user supplied usratp loaded,'
      63    ,' after fatal error',skip;
      64end;
      65
       1 .=member tcomp
       2 $ basic test program.
       3 $ on s66, run with  (mlev=2).
       4      +*  ws = .ws. **  +* ps = .ps. **  +* cs = .cs. **
       5      +*  iv(i) = (i) **  +*  rv(i) = (i) **
       6      +*  iassert(a,b) = $ check that real a, b close.
       7          assert iv(a) = iv(b);  **
       8      +*  rassert(a,b) = $ check that real a, b close.
       9          assert abs((a)-(b)) < 0.01;  **
      10      $   little test program, based on little guide.
      11      prog main;
      12      size i(ws);
      13 /*   variable naming conventions.
      14      a - array
      15      c - constant
      16      e - expression
      17      i - integer
      18      n - name
      19      r - real
      20      v - variable
      21 */
      22
      23      $   test comment scan.
      24      i = 0;
      25      i = 1;  $ comment
      26      i = i+1;  /* comment */
      27      i = /* comment */ i + 1;  $ comment
      28      /* comment i = i+1  */
      29      /** double stars once caused trouble. **/
      30      assert i=3;
      31
      32      $   test conditional assembly.
      33      i = 0;
      34 .+set son1
      35 .+son1.
      36 .+set son2   $ set within set.
      37 ..son1
      38 .-son2   assert 1=0;
      39 .-son1   assert 1=0;
      40 .+son3   assert 1=0;
      41 .+son1.
      42      i = i+1;
      43 .-son1.
      44      assert 1=0;
      45 ..son1
      46 .+son1.
      47 .+son2.
      48      i = i+1;
      49 ..son2
      50 ..son1
      51
      52      assert i=2;
      53
      54      $   test byte constants
      55      assert 1b'0' = 0;
      56      assert 1b'0 0' = 0;
      57      assert 1b'0 1' = 1;
      58      assert 2b'1' = 1;
      59      assert 2b'23' = 1b'1011';
      60      assert 3b'7' = 7;
      61      assert 3b'20' = 16;
      62      assert 3b'1 4 4' = 100;
      63      assert 4b'a' = 10;
      64      assert 4b'b' = 11;
      65      assert 4b'c' = 12;
      66      assert 4b'd' = 13;
      67      assert 4b'e' = 14;
      68      assert 4b'f' = 15;
      69
      70      $   test formation of integer constants.
      71
      72      assert +100 = 100;
      73      assert 1 0 0 = 100;
      74      assert 10 0 = 10 0;
      75      assert -100 = (0-100);
      76
      77      $   test formation of floating point constants.
      78      real piara;  dims piara(6);
      79      data piara = 3.1416, 3.14 16, +3.14 16e+0,
      80                   .31416e+0 1,  31.416e-1, 31416.0e-04;
      81      do  i = 1 to 6;
      82          assert abs(piara(i)-3.1416) < 0.01;
      83          end do;
      84
      85      $   test formation of character code and string constants.
      86      assert 1ra = .ch. 2, 'ba';
      87      assert .s. 2, 1, 'ab' .seq. 'b';
      88      assert .s. 3, 0, 'abc' .seq. '';
      89      assert .s. 2, 1, 'ab' .ne. 1rb;  $ code is not string.
      90      assert 'a''b' .seq. 3qa'b;
      91      assert 1rb = 0r/b/;
      92      assert 0q/ab'/ .seq. 'ab''';
      93      assert 'little' .seq. 6qlittle;
      94      assert 6qlittle .seq. 0q little ; $ blank delmits q const.
      95
      96      $   test .e. extractor.
      97      size e1(100), e2(100), e3(100);
      98      e1 = 0;
      99      assert e1 = 0;
     100      .e. 51, 1, e1 = 1;
     101      assert  .e. 50,2,e1 = 1b'10';
     102      i = 0;  assert .e. 60, i, e1 = 0;
     103      e1 = 0;
     104      .e. ws, 1, e1 = 1;  .e. ws+1, 1, e1 = 1;
     105      assert  .e. ws-1, 3, e1 = 1b'110';  $ cross word boundary.
     106
     107      $   test .f. extractor.
     108      size  w1(ws), w2(ws), w3(ws);
     109      w1 = 0;
     110      w2 = 0;  do i = 1 to ws;  .f. i, 1, w2 = 1;  end do;  $ all ones
     111      assert (.nb. w2) = ws;
     112      i = 0;  assert .f. 6, i, w2 = 0;  $ zero length extract.
     113      .f. 7, i, w2 = 0;  assert (.nb. w2) = ws;
     114      .f. 3, 2, w2 = 0;
     115      .f. 3, 2, w2 = 0;
     116      assert .f. 1, 6, w2 = 1b'110011';
     117      i = 2;
     118      .f. 4, i, w2 = 0;
     119      assert .f. 1, 6, w2 = 1b'100011';
     120      assert (.nb. w2) = ws-3;
     121
     122      $   test .s. character substring extraction
     123      size sds1(.sds. 1), sds4(.sds. 4), sds8(.sds. 8);
     124      size sdt1(.sds. 1), sdt4(.sds. 4), sdt8(.sds. 8);
     125      sds1 = 'a';  assert .ch. 1, sds1 = 1ra;
     126      sds1 = 'a'; sds4 = 'wxyz'; sds8 = '';
     127      assert .ch. 1, sds1 = 1ra;
     128      assert .s. 1,0, sds1 .seq. '';
     129      assert .len. sds4 = 4;
     130      assert .s. 2, 2, sds4 .seq. 'xy';
     131      sdt8 = sds1 .cc. sds4;  assert sdt8 .seq. 'awxyz';
     132      .s. 2, 3, sdt8 = '1';  assert sdt8 .seq. 'a1  z';
     133
     134      $   test .ch. character extraction.
     135      assert .ch. 3, sds4 = 1ry;
     136
     137      $   test bitstring operators.
     138      assert (.not. 1b'10') = 1b'01';
     139      assert (.not. 1b'0') = 1b'1';
     140      assert (^ 1b'10') = 1b'01';
     141      assert (^ 1b'0') = 1b'1';
     142      assert (.n. 1b'10') = 1b'01';
     143      assert (.n. 1b'0') = 1b'1';
     144      assert (1b'1100' & 1b'1010') = 1b'1000';
     145      assert (1b'1100' .and. 1b'1010') = 1b'1000';
     146      assert (1b'1100' .a. 1b'1010') = 1b'1000';
     147      assert (1b'1100' .exor. 1b'1010') = 1b'0110';
     148      assert (1b'1100' ! 1b'1010') = 1b'1110';
     149      assert (1b'1100' .or. 1b'1010') = 1b'1110';
     150
     151      assert (.fb. 1b'0') = 0;
     152      assert (.fb. 1b'01') = 1;
     153      assert (.fb. 1b'01') = 1;
     154      assert (.fb. 4b'0f') = 4;
     155
     156      assert (.nb. 1b'0') = 0;
     157      assert (.nb. 1b'0101') = 2;
     158      assert (.nb. 1b'100') = 1;
     159      assert (.nb. 1b'100') = 1;
     160
     161      assert  1=1;
     162      assert  1 .eq. 1;
     163      assert  1 ^= 0;
     164      assert  1 .ne. 0;
     165      assert  1 > 0;
     166      assert  1 .gt. 0;
     167      assert  1 >= 0;
     168      assert  1 .ge. 0;
     169      assert  0 < 1;
     170      assert  0 .lt. 1;
     171      assert  0 <= 1;
     172      assert  0 .le. 1;
     173
     174      $   check .sds. operator to yield multiple of ws.
     175      size l(ps);  l = .sds. 0;  assert l=ws;
     176      do  i = 1 to 100;
     177          assert .sds. i >= l;
     178          l = .sds. i;
     179          assert mod(l,ws) = 0;
     180          end do;
     181
     182      $   test .sne. and .seq. string comparisons
     183      assert 'ab' .seq. (.s. 3, 2, 'xyab');
     184      assert 'ab' .sne. '';
     185      assert 'ab' .sne. 'ab ';
     186      assert 'ab' .sne. 'xy';
     187
     188      $   concatenation has been tested as part of prior tests.
     189
     190      $   test .in. character instance operator.
     191      assert ('' .in. 'a') = 0;
     192      assert ('' .in. '') = 0;
     193      assert ('a' .in. '') = 0;
     194      assert ('ab' .in. 'wxyzabab') = 5;
     195      assert ('setl' .in. 'little') = 0;
     196      assert ('tl'.in. 'setl' = 'tl'.in.'little'-1);
     197
     198      $   test .pad. string padding operator.
     199      assert (.len. ('a'.pad.6)) = 6;
     200      assert ('little'.pad.10) .seq. 'little    ';
     201      assert ('little'.pad.3) .seq. 'lit';
     202      assert ('abc'.pad.6 !! 'xy' .pad. 10) .seq.
     203                 'abc   xy  ';
     204
     205
     206      $   test integer arithmetic.
     207
     208      iassert (iv(-15)/iv(4), -3);
     209      iassert (iv(15)/iv(-4), -3)
     210      iassert (iv(-13)/iv(-7), 1);
     211      iassert (iv(13)/iv(-7), -1);
     212      iassert (iv(-13)/iv(7), -1);
     213      iassert (iv(-13)/iv(13), -1);
     214      iassert (iv(13)/iv(13), 1);
     215
     216      +*  modchk(a,b,c) = iassert (mod(iv(a),iv(b)), c); **
     217      modchk(10, 3, 1);
     218      modchk(11, 10, 1);
     219      modchk(13, 7, 6);
     220      modchk(13, -7, 6);
     221      modchk(-13, 7, -6);
     222      modchk(-13, -7, -6);
     223      modchk(13, 13, 0);
     224      modchk(13, -13, 0);
     225      modchk(-13, 13, 0);
     226      modchk(-13, -13, 0);
     227      $   test standard mathematical functions.
     228
     229
     230      rassert(abs(4.5), 4.5);
     231      rassert (abs(-4.5), 4.5);
     232      rassert (aint(0.5), 0.0);
     233$     rassert (aint(1.1), 1.0);
     234      rassert (aint(-3.2), -3.0);
     235      +*  e = 2.718281828 **
     236      rassert(alog(e), 1.0);
     237      rassert (alog(1.0), 0.0);
     238      rassert (alog(10.0), 2.3026);
     239
     240      rassert (alog10(100.0), 2.0);
     241      rassert (alog10(1 000 000.0), 6.0);
     242
     243      rassert (amod(4.5,2.1), 0.3);
     244      rassert (amod(4.5, 1.0), 0.5);
     245      rassert (amod(-3.2, 1.5), -0.2);
     246
     247      rassert (alog(exp(20.0)), 20.0);
     248      rassert (atan(1.0), 0.7854)
     249      rassert (atan(100.0), 1.5608);
     250      rassert (atan(-100.0), -1.5608);
     251
     252      rassert (atan(2.5), atan2(5.0,2.0));
     253      rassert (atan(-2.5), atan2(-5.0, 2.0));
     254      rassert (atan(0.5), atan2(3.0, 6.0));
     255
     256      rassert (cos(1.0), 0.5406);
     257      rassert (cos(0.0), 1.0000);
     258      rassert (cos(100.0), 0.8623);
     259      rassert (cos(-100.0), 0.86232);
     260
     261      rassert ((dim(4.5, 2.2)), 2.3);
     262      rassert ((dim(2.2, 4.5)), 0.0);
     263      rassert ((dim(-10.0, -4.0)), 0.0);
     264      rassert ((dim(-4.0, -10.0)), 6.0);
     265
     266      rassert (exp(1.0), e);
     267      rassert (alog(exp(1.0)), 1.0);
     268      rassert (exp(alog(10.0)), 10.0);
     269      rassert (exp(3.0), 20.08554);
     270      rassert (exp(0.5), 1.6487);
     271      rassert (exp(-50.0), -1.92875e-22);
     272
     273      rassert (float(1), 1.0);
     274      rassert (float(0), 0.0);
     275      rassert (float(-3), -3.0);
     276      rassert (float(10000), 10000.0);
     277
     278      rassert(abs(4.5), 4.5);
     279      rassert (abs(-4.5), 4.5);
     280      rassert (aint(0.5), 0.0);
     281      rassert (aint(1.1), 1.0);
     282      rassert (aint(-3.2), -3.0);
     283      iassert (iabs(10), 10);
     284      iassert (iabs(0), 0);
     285      iassert (iabs(-20), 20);
     286
     287      iassert ((idim(20,10)), 10);
     288      iassert ((idim(10,20)), 0);
     289
     290      iassert ((idim(-10,-4)), 0);
     291      iassert ((idim(-4,-10)), 6);
     292
     293      iassert (ifix(2.1), 2);
     294      iassert (ifix(0.5), 0);
     295      iassert (ifix(-3.2), -3);
     296
     297      iassert (ifix(2.1), int(2.1));
     298      iassert (ifix(0.5), int(0.4));
     299      iassert (ifix(-4.9), int(-4.9));
     300
     301      iassert (isign(4,5), 4);
     302      iassert (isign(10,-2), -10);
     303 $   isign(0,-1) may be -0 on ones complement.
     304$     iassert (isign(0, -1), 0);
     305      iassert (isign(-10,-2), -10);
     306
     307      iassert (mod(10,3), 1);
     308      iassert (mod(6, 3), 0);
     309      iassert (mod(0, 5), 0);
     310      iassert (mod(-10, 3), -1);
     311      iassert (mod(-12,-4), 0);
     312      iassert (mod(-15, 7), -1);
     313
     314      rassert (sqrt(100.0), 10.0);
     315      rassert (sqrt(1.0),  1.0);
     316      rassert (sqrt(2.0), 1.41414);
     317
     318      rassert (tanh(0.10), 0.09967);
     319      rassert (tanh(0.50), 0.46212);
     320      rassert (tanh(1.00), 0.76159);
     321      rassert (tanh(1.50), 0.90515);
     322
     323      end prog;
       1 .=member tmac
       2 $ this deck tests macro processor
       3      setlistc01
       4      this card should be seen
       5      setlistc00
       6      this card should not be seen
       7      setlistc01
       8      this seen
       9      setlistc26
      10      not this
      11      +*thislong(w)=this long macro definitin should eventually be seen
      12      w w w**
      13      setlistc00
      14while this should be totally absent
      15      setlistc40
      16and this should be in buffer bt no listed
      17      thislong (along with its call)
      18      setlistc17
      19      thislong (along with its call in punched form)
      20      and., a., terminator., should., start., a.,
      21      new., line., every., once., in., a., while.,
      22      while a /label/, yes a /label/,
      23      should always start a new line.
      24      +*withthe=present setting this macro should appear in both
      25     xlistings**
      26      setlistc23
      27      +*with a new = setting this macro definition should not be shown**
      28      with a new withanew
      29      even though its expansion will be shown
      30      setlistc40
      31      withanew should restore the 'punch format'
      32      listing
      33setlistc15
      34   +*awdsiz=20**    +*iwd=newiwd**   +*nexunwd(wd)=routine(wd,0)**
      35+*mstklim=100**
      36+*quote(wd)=wd**  +*s=quote(*)**+*p=quote(+)**
      37+*oldmac = original version**
      38oldmac oldmac
      39      +*q3(w1,w2,w3)=w1   w2   w3**
      40      +* revisor=q3(+,*oldmac=new revised version*,*)**
      41      revisor
      42      oldmac   oldmac   oldmac
      43+*newmac= p s quote(oldmac) =revised second version s s **
      44newmac
      45oldmac oldmac oldmac
      46      **test data for the above**
      47+*aa=aa**
      48*a=aa*b
      49+a=aa*b
      50+*c(,**
      51+*da,-**
      52+*ab(c) def edf**
      53+*ab(z,z)=x**
      54+*ab(ab)=y**
      55+*d(a,-**
      56amac +*z=y**
      57      data for systematic macro testing
      58      +*mac1=this is a first macro**
      59      mac1           mac1(with an argument)
      60      +*mac1=this is a second version of same macro**
      61      mac1           mac1(with an argument)
      62      +*macro=showing double nesting**
      63      mac1
      64      +*nesting=and even triple level expansion**
      65      mac1
      66      +*macro=**
      67      mac1
      68      +*mac3(wd)=wd is substituted in this macro**
      69      mac3(oneword)
      70bmac
      71      mac3(two words)
      72zmac
      73      mac3(a   whole long phrase)
      74      mac3     omitting arguments
      75      mac3(a  phrase,separated by commas)
      76      mac3(a  phrase., containing the delimiter)
      77      mac1(unnecessary arguments)
      78      mac3(a  phrase(with embedded .,terminator)  in parentheses)
      79      +*mac4(a,b)=a is first,b second**
      80      mac4(one word,another)
      81      mac4(just one)
      82      mac4(with,three,parameters)
      83      mac4(mac1,mac2)
      84      mac4(mac4(inward,outward),final)
      85      +*mac5=zzza and zzzb are generated symbols.
      86      zzza and zzzb can be repeated.  they
      87      contain the integers zzya and zzyb**
      88      mac5
      89      +*mac5=**
      90      mac5
      91      mac3(a phrase  (with parenthesized)   subphrase)
      92      mac3(a  phrase(with comma,separated)  subphrase)
      93      +*mac5=whatever**
      94      mac5
      95      +*mac6=first version,macro 6**
      96      mac6
      97      +*mac6=second version,macro 6**
      98      mac6
       1 .=member treal
       2
       3 /*   test floating point features by seeing if various points
       4      define a tetrahedron.
       5
       6      author  r. abes (cims)  jul 74
       7              d. shields (cims) dec 77  (revise to level 2.3)
       8 */
       9      prog treal;
      10
      11      +*  yes = 1 **  +* no = 0 **
      12
      13      size  nerrors(.ps.);  nerrors = 0;  $ number of errors detected.
      14
      15      call tetra(1.1, 1.2, 1.3, 1.4, 1.5, 1.6, yes);
      16      call tetra(1.5, 1.3, 1.6, 1.2, 1.1, 1.4, yes);
      17      call tetra(5.2, 5.2, 100.1, 5.2, 5.2, 5.2, no);
      18      call tetra(8.0, 8.0, 20.1, 20.1, 8.0, 8.0, no);
      19      call tetra(1.1, 1.2, -1.2, 1.1, 1.1, 1.1, no);
      20      call tetra(.5, .5, 0.0, .5, .4, .3, no);
      21      call tetra(10., 9., .5, 1.1, 1.1, 10., yes);
      22      call tetra(.2e10, .2e10, .25e10, 7.e10, 7.e10, 7.e10, yes);
      23      call tetra(.2e-10, .2e-10, .25e-10, 7.e-10, 7.e-10, 7.e-10, yes);
      24      if  nerrors  then
      25          put ,'*** error - test failed ' :nerrors,i ,' times ***',skip;
      26      else
      27          put ,'*** test passed ***' ,skip;
      28          end if;
      29      end prog treal;
      30      subr tetra(a, b, c, d, e, f, valid);;
      31
      32 $    this subroutine decides whether its six floating point input
      33 $    arguments can be the lengths of the edges of a non-degenerate
      34 $    tetrahedron.
      35
      36      real a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, area;
      37      size  valid(1);     $ true if points define tetrahedron.
      38
      39      +* check =
      40      l = area(f, j, h);
      41      m = area(g, h, i);
      42      n = area(g, j, k);
      43      o = area(f, i, k);
      44      if ((l > 0.0) & (m > 0.0) & (n > 0.0) &
      45         (o > 0.0)) then
      46        if ((l < m+n+o) & (m < l+n+o) & (n < l+m+o)
      47        & (o < l+m+n)) go to pgood;  end if **
      48
      49      +* setup(t, u, v, w, x) =
      50      g = t;  h = u;
      51      i = v;  j = w;  k = x;  check;  j = x;  k = w;  check;
      52      i = w;  j = v;  k = x;  check;  j = x;  k = v;  check;
      53      i = x;  j = v;  k = w;  check;  j = w;  k = v;  check **
      54
      55
      56
      57
      58      if ((a <= 0.0) .or. (b <= 0.0) .or. (c <= 0.0) .or.
      59          (d <= 0.0) .or. (e <= 0.0) .or. (f <= 0.0)) go to nono;
      60
      61 $    test for tetrahedron
      62
      63      setup(a, b, c, d, e);
      64      setup(b, a, c, d, e);
      65      setup(c, a, b, d, e);
      66      setup(d, a, b, c, e);
      67      setup(e, a, b, c, d);
      68
      69 /nono/
      70      if  (valid = no)  return;  $ if expect invalid case.
      71      nerrors = nerrors+1;
      72      put ,skip ,' input parameters to tetra:' ,skip;
      73      put :a:b:c,ne(12,5) ,skip :d:e:f,ne(12,5) ,skip;
      74          put ,'   these cannot be lengths of edges of a tetrahedron'
      75              ,skip;
      76      return;
      77
      78 /pgood/
      79      if (valid=yes)  return;  $ if expect valid tetrahedron.
      80      nerrors = nerrors+1;
      81      put ,skip ,' input parameters to tetra:' ,skip;
      82      put :a:b:c,ne(12,5) ,skip :d:e:f,ne(12,5) ,skip;
      83          put ,'   a non-degenerate tetrahedron exists with'
      84           ,' these quantities as the lengths of its edges' ,skip;
      85      put ,'   side q s = ' :f,e(12,5);
      86      put ,'   side p r = ' :g,e(12,5);
      87      put ,'   side p s = ' :h,e(12,5) ,skip;
      88      put ,'   side r s = ' :i,e(12,5);
      89      put ,'   side p q = ' :j,e(12,5);
      90      put ,'   side q r = ' :k,e(12,5);
      91
      92      end subr tetra;
      93      fnct area(x, y, z);
      94
      95 $    returns four times the area of the triangle with sides x, y, z.
      96
      97      real area, x, y, z;
      98      area = (x+y+z) * (x+y-z) * (x+z-y) * (y+z-x);
      99      if (area > 0.0)
     100        then area = sqrt(area);
     101        else area = 0.0;
     102        end if;
     103      end fnct area;
       1 .=member tsynerr
       2      $   this program contains a number of syntactic errors to check
       3      $   error detection of little parser.
       4      $   author - d. shields (cims) 01 oct 77
       5      prog main;
       6      +*  ws = .ws. **  +* ps = .ps. **  +* cs = .cs. **
       7      size  e1(ws), e2(ws), e3(ws);
       8      size  i1(ps), i2(ps), i3(ps), i4(ps);
       9      size  str1(.sds. 80), str2(.sds. 80);
      10      size  c1(cs), c2(cs), c3(cs);
      11      size ara1(ws), ara2(ws);  dims ara1(10), ara2(20);
      12
      13
      14      put ,g(10);  $ illformed o
      15      put ,g(10);             $ illformed control format.
      16      put : fw
      17      put : i1 ,-20;  $ illformed data format
      18      e1 = e2 + /;
      19      put : e1,i()();
      20      file 3 recordlen = 200;  $ recordlen is invalid attribute.
      21      file 2 ttile=20;
      22      monitor +;              $ illformed parameter list.
      23      put 3 : e1 , i(10/;     $ illformed data format
      24      e1 = 10/  ;  $ not terminated by semicolon;
      25      10 = e1;
      26      e1 = .not. *;
      27      /l(+)/  e1=1;
      28      /l(1//  e1 = 1;
      29      /+1/ e1=1;
      30      access 1;               $ expect nameset name.
      31      assr
      32      assert +;
      33      call 1;
      34      call p1,+,2);
      35      call p1(1,2)/;
      36      call p1(a ());
      37      call p1(a+1 +);
      38      check index;
      39      data e1 10;
      40      data e1=+;
      41      data 10=e1;
      42      data a1(+) = 1;
      43      data a1(+/ = 1;
      44      data a1 = 10(a);
      45      data a1 = 'abc'(10);
      46      dims a
      47      dima
      48      size dv(ws);
      49      dims dv(10;
      50      dimvs dv 10;
      51      si
      52      dims dv /10);
      53      dims dv(100000);
      54      do i1 = 10 two 20;
      55          end do;
      56      do i1 from 10 to 20;  end do;
      57      do i1 = + to 20;  end do;
      58      do i1 = 10 to +/;
      59      if  e1  then  e2=2; elsyif
      60      if  e1  then e2=1  elseif e2  thenn  e2=2;  edd if;
      61      if  e1  then e2=1  elseif e2  thenn  e2=2;  end if;
      62      if  e1  then e2=1  elseif 6/  then e2=2;  end if;
      63      file + title='';
      64      e1 = filestat(+,err);
      65      e1 = filestat(1 err)
      66      e1 = filestat(1 erry
      67      e1 = filestat(1, err/;
      68      e1 = filestat(1 err);
      69      e1 = filestat(down,3);
      70      e1 = filestat(1, violet);
      71      e1 = filestat+2;
      72      go to l1(e1) inrange 1 to 2;
      73      go to l2(e1) in 1 two 3;
      74      go to l1(e1) in i1 to 4;
      75      go to l1(e1) in 1 to e3;
      76      go to l1(+);
      77      go to l1(1/;
      78      go two l1;
      79      goto l1;
      80      goto 10;
      81      go to 10;
      82      goby e1+l1,l2,l3);
      83      goby e1;
      84      goby e1(l1,l2;
      85      goby e1(10,l2);
      86      if + then a=1;  end if;
      87      monitor limit = thursday+;
      88      monitor limit 100;
      89      monitor lymit = 10;
      90      nameset 10;
      91      read + a,b;
      92      read a,b;
      93      read 3, a,b,.;
      94      rewind +;
      95      size s1,+);
      96      size s1(10;
      97      size s1+10);
      98      size s1(100000);  $ very large size.
      99      subr 1;  end subr;
     100      subr subr1(10,20);
     101      subr s2(10;
     102          end subr;
     103      until +;  end until;
     104      while +;  end while;
     105      while )/2;  end while;
     106      e1 == 10;
     107      e1 := 10;
     108      e1 = +;
     109      read 4, a(1) two a(4);
     110      read 4, a(10 to 20;
     111      read 4, a(1) to 30;
     112      read 4, a(1) to aa(4);
     113      .f. +, 20, e1 = 2;
     114      .f. 1, +, e1 = 0;
     115      .f. 1, 20, a1(+) = 1;
     116      .f. 1, 1, e1 = +;
     117      .ch. 1, str1 = +;
     118      .ch. 1, 2, a(1) = 10;
     119      .s. 0, 10, str1 = +;
     120      .s. +, 20, str1 = '';
     121      .s. 1, +, str1 == '';
     122      .s. 1, 1, str1 =
     123      .s. 1, +, str1 = '';
     124      size  c1(.cs., c2(.cs., c3(.cs.)
       1 .=member tcodgen
       2     +* ws=60**  +* ps=17 **
       3      subr code;
       4 $        examine code produced by little compiler
       5 $        check for expected optimizations;
       6      +* d(v) = size v(ws); **
       7      d(w) d(w1) d(w2) d(w3) d(w4) d(w5) d(w6)
       8      d(wa) d(wa1) d(wa2)
       9      dims wa(100), wa1(100), wa2(100);
      10      +* d(v) = size v(ps); **  $ declare pointer size
      11      d(p) d(p1) d(p2) d(p3) d(p4) d(p5) d(p6)
      12      d(pa) d(pa1) d(pa2) d(pa3) d(pa4)
      13      dims pa(100), pa1(100), pa2(50), pa3(50);
      14
      15 $        constont folding
      16      call confold;
      17      w1 = 50*4 - 5*6;  $ should be constant
      18      w3 = w1-4;
      19      w4 = w1+5;
      20      w2 = wa1(10);  $ constant subscript;
      21
      22 $        redundant subexpressions
      23      call redund;
      24      w1 = w;
      25      w3 = w1+w2;
      26      w4=w1;
      27      w5=w4+w2;  $ should be same as w3
      28      w = w4;
      29      wa(1) = w1+w2;
      30      wa(3) = w3;
      31      wa(4) = w1+w2;
      32      w2 = wa(1)+wa(2);  $ constant subscripts
      33      w3 = wa(1) + wa(2);
      34
      35          $  check field extracts
      36      call fldext;
      37      p1 = .f. 3, 2, w;
      38      p2 = .f. 3, 2, w;  $ same field
      39      .f. 3, 2, w1 = 1;
      40      p3 = .f. 3, 2, w;  $ seting p3 to 1
      41 $        tests
      42      call tests;
      43      if(w=0) go to lab;
      44      if(w>0) go to lab;
      45      if(w1=w2) go to lab;
      46      if( (w1>w2) & (w1 ^= w3)) go to lab;
      47      if ( .f. 31, 1, w3 = 0) go to lab;  $ testing single bit
      48      call other; /lab/;
      49          $  indexed field
      50      call ndxfld;
      51      w1 = .f. 2, 3, wa(p1);
      52      w2 = .f. 2, 3, wa(p1);
      53     call array2;
      54      w = wa(p1);
      55      w4 = wa(p1);
      56      call array3;
      57      .f. 2, 7, w4 = .f. 2, 7, w1;
      58          $ multi-word index and fld extract
      59      call multwd;
      60      size ww(120), ww1(120), ww3(120), ww4(120);  $ two word
      61      w1 = .f. 2, 5, ww1;
      62      size ww2(120);
      63      w3 = .f. 62, 4, ww1;
      64      .f. 1, 1, ww2 = 0;
      65          $ redundant function call
      66      call redfunc;
      67      size fun(ws);
      68      w1 = fun(p1);  w2 = fun(p1); $ only 1 call needed
      69      call muldiv;
      70      p1 = p2/10;  p3 = p4/60;
      71      p4 = p4*2;  p1 = p1/2;
      72      $short loops  ( see if in stack)
      73      call memzero;
      74      p1=1;
      75  /memloop/  wa(p1)=0; p1=p1+1; if(p1.le.100) go to memloop;
      76
      77          $  loop  - memory move
      78      call memove;
      79      p1 = 20;
      80   /moveloop/  wa(p1) = wa1(p1);
      81 +*d=**
      82      call done;  end;
      83      subr srtl;
      84  /* srtl code fragments  for code test */
      85      size t(ws), maxzzyz(ws), tres(ws), running(ws);
      86      t=5000 - maxzzyz; tres=t; running=t;
      87         return; end;
      88    subr getstg(n,p); size n(ps), p(ps);
      89      if(n=0) go to l1;  go to l2;
      90   /l1/ call abort;  /l2/ return;  end;
      91      subr eg3;
      92    size u(ws), t(ps); dims u(100);
      93      u(t*1) = 0;  t=t+1;  return; end;
      94       subr eg4;
      95      size temp(ws), storage(ws);  dims storage(100);
      96    temp=1;
      97   /a/  if(temp.gt. 5000) go to b;
      98      storage(temp)=0;  temp=temp+1;  go to a;
      99 /b/
     100      return;  end;
     101      subr eg5;
     102      size storage(ws);  dims storage(500);
     103     size p1(ps), p2(ps), p3(ps); size w1(ws), w2(ws), w3(ws);
     104      storage(400-10+1) = 1;  storage(400-5+1) = 6;
     105      storage( .f. 1, ps, w1) = .f. 20, ps, w1;
     106      storage(w1-10 + 1) = 1;  $  var -con + con case
     107      return; end;
       1 .=member testss
       2 +* ws = .ws. ** +* ps =.ps. **  +* cs = .cs. **
       3      +*  ss_blank = 1b'000001' **
       4      +*  ss_separ = 1b'000010' **
       5      +*  ss_digit = 1b'000100' **
       6      +*  ss_ucltr = 1b'001000' **
       7      +*  ss_lcltr = 1b'010000' **
       8      +*  ss_break = 1b'100000' **
       9      prog testss;
      10      size  al(.sds. 26);  data al = 'abcdefghijklmnopqrstuvwxyz';
      11      size  nu(.sds. 10);  data nu = '1234567890';
      12      size  bl(.sds. 1);   data bl = ' ';
      13      size  brkc(ws),brks(ws),spnc(ws),spns(ws);
      14      size  anys(ws), nays(ws), anyc(ws);
      15      size  rbrc(ws), rbrs(ws), rspc(ws), rsps(ws);
      16      size  ss_vow(ps);  $ string set for vowels.
      17      size  ss_pri(ps);  $ string set for primes.
      18
      19
      20      assert anyc(1ra, ss_ucltr) = 1;
      21      assert anyc(1r1, ss_digit) = 1;
      22      assert anyc(1r  , ss_blank) = 1;
      23      assert anyc(1r  , ss_separ) = 1;
      24      assert anyc(1r_ , ss_break) = 1;
      25      assert anys(al, 1, ss_digit) = 0;
      26      assert anys(al, 1, ss_ucltr) = 1;
      27      assert anys(al, 26, ss_ucltr) = 1;
      28      assert anys(al, 13, ss_ucltr) = 1;
      29      assert nays(al, 1, ss_digit) = 1;
      30      assert nays(al, 1, ss_ucltr) = 0;
      31
      32      assert brkc(al, 1, 1re) = 4;
      33      assert brks(al, 1, ss_ucltr) = 0;
      34      assert brks(al, 1, ss_blank)   = -1;
      35      assert brkc(al, 1, 1ra) = 0;
      36
      37      assert spnc(al, 1, 1rb) = -1;
      38      assert spnc(al, 1, 1ra) = 1;
      39      assert spns(al, 1, ss_digit) = -1;
      40      assert spns(al, 1, ss_ucltr) = 26;
      41      assert spns(nu, 1, ss_digit) = 10;
      42
      43      assert rbrc(al, (.len. al), 1re) = 21;
      44      assert rbrs(al, (.len. al), ss_blank)   = -1;
      45      assert rbrc(al, (.len. al), 1rz) = 0;
      46
      47      assert rspc(al, (.len. al), 1rb) = -1;
      48      assert rspc(al, (.len. al), 1rz) = 1;
      49      assert rsps(al, (.len. al), ss_digit) = -1;
      50      assert rsps(al, (.len. al), ss_ucltr) = 26;
      51
      52      ss_vow = 1b'1000000';  $ search set for vowels
      53      ss_pri = 1b'10000000';  $ search set for pri digitss.
      54
      55      call blds('aeiou', ss_vow);
      56      call blds('357', ss_pri);
      57
      58      assert anys(al, 1, ss_vow) = 1;
      59      assert nays(al, 1, ss_pri) = 1;
      60
      61      assert brks(al, 1, ss_vow) = 0;
      62      assert rbrs(al, (.len. al), ss_vow) = 5;  $ u is rightmost vowel.
      63
      64      assert brks(nu, 1, ss_pri) = 2;
      65      assert spns(nu, 1, ss_pri) = -1;
      66
      67      assert rbrs(nu, (.len. nu), ss_pri) = 3;
      68
      69      call rpld('0123456789', 'abcdefghij');
      70      call rple(nu);
      71      assert nu .seq. 'bcdefghija';
      72
      73      end prog;

« August 2022 »
Su Mo Tu We Th Fr Sa
1 2 3 4 5 6
7 8 9 10 11 12 13
14 15 16 17 18 19 20
21 22 23 24 25 26 27
28 29 30 31
 

Powered by Plone CMS, the Open Source Content Management System

This site conforms to the following standards: