Personal tools
You are here: Home Projects SETL SETL Source code TST: SET test library.
Document Actions

TST: SET test library.

by Paul McJones last modified 2021-03-18 20:22

TST: SET test library. stltst.opl

       1 .=member intro
       2$           ssssssss   eeeeeeeeee  tttttttttt  ll
       3$          ssssssssss  eeeeeeeeee  tttttttttt  ll
       4$          ss      ss  ee              tt      ll
       5$          ss          ee              tt      ll
       6$          sssssssss   eeeeee          tt      ll
       7$           sssssssss  eeeeee          tt      ll
       8$                  ss  ee              tt      ll
       9$          ss      ss  ee              tt      ll
      10$          ssssssssss  eeeeeeeee       tt      llllllllll
      11$           ssssssss   eeeeeeeee       tt      llllllllll
      12$
      13$
      14$                tttttttttt   ssssssss   tttttttttt
      15$                tttttttttt  ssssssssss  tttttttttt
      16$                    tt      ss      ss      tt
      17$                    tt      ss              tt
      18$                    tt      sssssssss       tt
      19$                    tt       sssssssss      tt
      20$                    tt              ss      tt
      21$                    tt      ss      ss      tt
      22$                    tt      ssssssssss      tt
      23$                    tt       ssssssss       tt
      24$
      25$
      26$           t h e    s e t l    t e s t    l i b r a r y
      27$
      28$       this software is part of the setl programming system
      29$                address queries and comments to
      30$
      31$                          setl project
      32$                 department of computer science
      33$                      new york university
      34$           courant institute of mathematical sciences
      35$                       251 mercer street
      36$                      new york, ny  10012
      37$
      38
      39
       1 .=member macros
       2      macro maxsi;
       3          131071              $ maximum short integer on cdc 6600
       4          endm;
       5
       6
       7      macro prog_level;
smff   1          'tst(85007)'
       9          endm;
      10
      11
      12      macro nullset;
      13          <
>
      14          endm;
      15
      16      macro nulltup;
      17          (//)
      18          endm;
      19
      20      macro nullstring;
      21          ''
      22          endm;
      23
      24      macro card;
      25          #
      26          endm;
      27
      28
      29$ the print_xxxx - macros presumably should become utility routines.
      30$ for now, it is easier to implement it in two steps: first introduce
      31$ the macros for the source statement sequences, and later replace the
      32$ macros by procs.
      33
      34
      35      macro print_head(text); $ print test identification header
      36
      37          print('start execution of', text);
      38          print
      39
      40          endm;
      41
      42
      43      macro print_line(text); $ print a line as a function of print_mode
      44
      45          if print_mode >= print_full then
      46              print;   print;
      47              print(text);
      48              print;
      49          end if
      50
      51          endm;
      52
      53
      54      macro print_tail(text); $ print test termination message
      55
      56          print;   print;
      57          print('terminate execution of', text);
      58
      59          if print_mode >= print_full then eject; else print; end if
      60
      61          endm;
      62
      63
      64$ the print modes of the test library correspond to the assert modes
      65$ of the run-time library.  the following macros define this corres-
      66$ pondence.
      67
      68      macro print_off;   0 endm;
      69      macro print_part;  1 endm;
      70      macro print_full;  2 endm;
      71      macro print_debug; 3 endm;
      72
      73
       1 .=member opttst6
       2library optimiser_test_6;
       3
       4    $ nyu program id
       5    $ author - s. freudenberger
       6
       7    exports
       8        bug_6;
       9
      10    const x;
      11
      12    init f := <
>;
      13
      14    repr
      15        base b:                 string;
      16        f:                      local smap(elmt b) integer;
      17    end repr;
      18
      19
      20    procedure bug_6;
      21
      22    f(x) := 1;
      23
      24    assert f            =  << (/ 'x', 1 /) >>;
      25    assert x            =  'x';
      26
      27    end procedure bug_6;
      28
      29end library optimiser_test_6;
      30
      31
       1 .=member opttst7
       2
       3
       4library optimiser_test_7;
       5
       6    $ nyu program id
       7    $ author - s. freudenberger
       8
       9    exports
      10        bug_7;
      11
      12    init f := <
>;
      13
      14    repr
      15        base b1:                string;
      16        base b2:                integer;
      17        f:                      local smap(elmt b1) elmt b2;
      18    end repr;
      19
      20
      21    procedure bug_7;
      22
      23    x := 1.0;
      24    g1 := << (/ x, 1 /) >>;
      25    g2 := << (/ x, 'elmt' /) >>;
      26
      27    assert g1           =  << (/ 1.0, 1 /) >>;
      28    assert g2           =  << (/ 1.0, 'elmt' /) >>;
      29    assert x            =  1.0;
      30
      31    f(g2(x)) := g1(x);
      32
      33    assert f            =  << (/ 'elmt', 1 /) >>;
      34    assert g1           =  << (/ 1.0, 1 /) >>;
      35    assert g2           =  << (/ 1.0, 'elmt' /) >>;
      36    assert x            =  1.0;
      37
      38    end procedure bug_7;
      39
      40end library optimiser_test_7;
      41
      42
       1 .=member opttst13
       2
       3
       4library optimiser_test_13;
       5
       6    $ nyu program id
       7    $ author - d. shields (nyu-cims)       15-oct-1981
       8    $ fixed with v82060:
       9    $        - s. freudenberger (nyu-cims)  1-mar-1982
      10
      11    exports
      12        bug_13;
      13$
      14$ this program is erroneous in that 'yes' should be 'true'.  as it
      15$ stands, the program terminates with an error message complaining
      16$ about bad type, 'atom expected'.
      17$
      18$ the problem is due to the implicit repr which occurs in the init
      19$ statement:  input_available has been repr'ed to have the mode atom,
      20$ while yes, being undeclared, has the mode general.  the type check
      21$ required in this context is postponed until run-time.
      22$
      23$ note however that the original problem then should produce an error
      24$ message when input_available is tested in getinp:  'expect boolean
      25$ in test', since omega is not boolean.  the version below has been
      26$ modified to test input_available for true, to avoid this problem.
      27$
      28    init input_available := false;
      29
      30    procedure bug_13;
      31
      32    getinp;                     assert input_available = om;
      33    getinp;                     assert input_available = om;
      34
      35    end procedure bug_13;
      36
      37
      38    procedure getinp;
      39
      40    assert input_available = om or input_available = false;
      41$$--if input_available then return; end if;
      42    if input_available = true then return; end if;
      43
      44    input_available := yes;     assert input_available = om;
      45
      46    end procedure getinp;
      47
      48end library optimiser_test_13;
      49
      50
       1 .=member opttst14
       2
       3
       4library optimiser_test_14;
       5
       6    $ nyu program id
       7    $ author - s. freudenberger
       8
       9    exports
      10        bug_14;
      11
      12    var s1, s2, t1, t2;
      13
      14    repr
      15        base b:                 integer;
      16        s1, s2:                 local set(elmt b);
      17        t1, t2:                 tuple(elmt b);
      18    end repr;
      19
      20
      21    procedure bug_14;
      22
      23    s  := <<  1,   4,   9,  16,  25 >>;
      24    s1 := s;
      25    s2 := <<  1,   8,  27,  64, 125 >>;
      26    t  := (/  1,   4,   9,  16,  25 /);
      27    t1 := t;
      28    t2 := (/  1,   8,  27,  64, 125 /);
      29
      30    assert s            =  s;
      31    assert t1           =  t;
      32    assert forall x in s1 + s2 st x in t1 + t2;
      33    assert s1           =  s;
      34    assert t1           =  t;
      35
      36    end procedure bug_14;
      37
      38end library optimiser_test_14;
      39
      40
       1 .=member opttst16
       2
       3
       4library optimiser_test_16;
       5
       6    $ nyu program id
       7    $ author - s. freudenberger
       8
       9    exports
      10        bug_16;
      11
      12    var l1, l2, l3;
      13
      14    repr
      15        base b:                 integer;
      16        l1, l2, l3:             local set(elmt b);
      17    end repr;
      18
      19
      20    procedure bug_16;
      21$
      22$ the following test was first logged as opt bug 16 on 80-08-11
      23$ by s. m. freudenberger.  it was extended to its current form
      24$ on 80-11-28, and ran successful on opt setl v80333.
      25$
      26    l2 := << 1, 2, 3 >>;   l3 := << 4, 5, 6 >>;
      27
      28    assert l1           =  om;
      29    assert l2           =  << 1, 2, 3 >>;
      30    assert l3           =  << 4, 5, 6 >>;
      31
      32    l1 := l2 + l3;
      33
      34    assert l1           =  << 1, 2, 3, 4, 5, 6 >>;
      35    assert l2           =  << 1, 2, 3 >>;
      36    assert l3           =  << 4, 5, 6 >>;
      37
      38    end procedure bug_16;
      39
      40end library optimiser_test_16;
      41
      42
       1 .=member opttst35
       2
       3
       4library optimiser_test_35;
       5
       6    $ nyu program id
       7    $ author - s. freudenberger
       8
       9    exports
      10        bug_35;
      11
      12    var f, g, s, x, y;
      13
      14    init f := <
>, g := <
>, s := <
>;
      15
      16    repr
      17        plex base b;
      18        f:                      local smap(elmt b) integer;
      19        g:                      sparse smap(elmt b) integer;
      20        s:                      local set(elmt b);
      21        x, y:                   elmt b;
      22    end repr;
      23
      24
      25    procedure bug_35;
      26
      27$ this procedure does a short test to see whether plex bases are
      28$ implemented.
      29
      30    loop forall i in <<1 .. 10>> do
      31        x := newat; f(x) := i*i; g(x) := i; s with:= x;
      32    end loop forall;
      33
      34    (forall i = g(y))
      35        assert f(y) = i * g(y); assert y in s;
      36    end forall;
      37
      38    end procedure bug_35;
      39
      40end library optimiser_test_35;
      41
      42
       1 .=member opttsts
       2
       3
       4library optimiser_tests;
       5
       6    $ nyu program id
       7    $ author - s. freudenberger
       8
       9    libraries
      10        optimiser_test_6,
      11        optimiser_test_7,
      12        optimiser_test_13,
      13        optimiser_test_14,
      14        optimiser_test_16,
      15        optimiser_test_35;
      16    exports
      17        opt_tests;
      18
      19
      20    var
      21        error_mode,             $ setl run-time error mode
      22        error_limit,            $ setl run-time error limit
      23        print_mode;             $ cims.setl.tst print mode
      24
      25
      26    procedure opt_tests;
      27
      28    title('cims.setl.' + prog_level);
      29
      30    getem(error_mode, error_limit);
      31
      32    print_mode := getipp('assert=1/2');
      33    if getipp('tdebug=0/1') = 1 then print_mode := print_debug; end;
      34
      35    print_head('optimiser regression tests');
      36
      37    bug_1;    bug_2;    bug_3;    bug_4;    bug_5;
      38    bug_6;    bug_7;    bug_8;    bug_9;    bug_10;
      39    bug_11;   bug_12;   bug_13;   bug_14;   bug_15;
      40    bug_16;   bug_17;   bug_18;   bug_19;   bug_20;
      41    bug_21;   bug_22;   bug_23;   bug_24;   bug_25;
      42    bug_26;   bug_27;   bug_28;   bug_29;   bug_30;
      43    bug_31;   bug_32;   bug_33;   bug_34;   bug_35;
smfd   2    bug_36;   bug_37;   bug_38;
      44
      45    print_tail('optimiser regression tests');
      46
      47    end procedure opt_tests;
      48
      49
      50    procedure bug_1;
      51$
      52$ this test showed inconsistency in iterations over tuples between the
      53$ interpreter and the general library routine w.r.t. omegas embedded in
      54$ tuples.
      55$
      56    repr
      57        t2:                     tuple(integer);
      58    end repr;
      59
      60
smff   2    t := (/ 1, 2, 3, 4, 5, 6 /); t(3) := om; t(5) := om;
smff   3
smff   4    t3 := t2 := t1 := t;
      62
      63    assert (/ x : x in t1 /)    =  (/ x : x in t2 /);
      64    assert (/ x : x in t2 /)    =  t3;
smff   5    assert t1                   =  t;
smff   6    assert t2                   =  t;
smff   7    assert t3                   =  t;
      68
      69    end procedure bug_1;
      70
      71
      72    procedure bug_2;
      73$
      74$ this example showed that the conversion on a with-operation was done
      75$ at the wrong place:  the conversion should be done before, not after,
      76$ the with operation.
      77$
      78    repr
      79        base b:                 integer;
      80        x:                      elmt b;
      81        t1, t2:                 tuple(elmt b);
      82    end repr;
      83
      84
      85    t1 := (/ 1, 2, 3 /);   x := 4;
      86
      87    assert (/1, 2, 3/) with x           =  (/ 1, 2, 3, 4 /);
      88    assert t1 with x                    =  (/ 1, 2, 3, 4 /);
      89    assert (t2:=(/1,2,3/)) with x       =  (/ 1, 2, 3, 4 /);
      90
      91    end procedure bug_2;
      92
      93
      94    procedure bug_3;
      95$
      96$ this example showed that the omega test for a base element was
      97$ not always done correctly.
      98$
      99    repr
     100        base b:                 string;
     101        x:                      elmt b;
     102        y:                      string;
     103    end repr;
     104
     105
     106    x := om;                    assert x = om;
     107    y := om;   x := y;          assert y = om;   assert x = om;
     108
     109    end procedure bug_3;
     110
     111
     112    procedure bug_4;
     113$
     114$ test example 2 dealt with mixed tuples.  the same holds true,
     115$ of course, for set/map types.
     116$
     117    repr
     118        f:                      smap(general) general;
     119        s:                      set(general);
     120        x:                      general;
     121    end repr;
     122
     123
     124    f := << (/ 1, 1 /), (/ 2, 4 /), (/ 3, 9 /) >>;
     125    x := 2;
     126    s := <
>;
     127
     128    assert f            =  << (/ 1, 1 /), (/ 2, 4 /), (/ 3, 9 /) >>;
     129    assert s            =  <
>;
     130    assert x            =  2;
     131
     132    s := f with x;
     133
     134    assert f            =  << (/ 1, 1 /), (/ 2, 4 /), (/ 3, 9 /) >>;
     135    assert s            =  << (/ 1, 1 /), (/ 2, 4 /), (/ 3, 9 /), 2 >>;
     136    assert x            =  2;
     137
     138    end procedure bug_4;
     139
     140
     141    procedure bug_5;
     142$
     143$ the two maps f and g have the same hash code (at least in one
     144$ particular implementation at a particular time):  it showed a
     145$ bug in the equality routine for map cases, where a branch was
     146$ done under the negated condition.
     147$
     148    repr
     149        base b:                 integer;
     150        f, g:                   remote smap(elmt b) integer;
     151    end repr;
     152
     153
     154    f := << (/ 2, 1 /), (/ 1, 0 /) >>;
     155    g := << (/ 3, 1 /), (/ 0, 0 /) >>;
     156
     157    assert f /= g;
     158
     159    end procedure bug_5;
     160
     161
     162    procedure bug_8;
     163
     164    const x;
     165
     166    repr
     167        base b:                 string;
     168        x:                      elmt b;
     169    end repr;
     170
     171
     172    assert x            =  'x';
     173    assert type x       =  'string';
     174    assert is_string x  =  true;
     175    assert is_atom x    =  false;
     176
     177    end procedure bug_8;
     178
     179
     180    procedure bug_9;
     181
     182    f := << (/ 1, 1 /), (/ 2, 4 /), (/ 3, 9 /) >>;
     183    assert f            =  << (/ 1, 1 /), (/ 2, 4 /), (/ 3, 9 /) >>;
     184
     185    f less:= (/1, 2/);
     186    assert f            =  << (/ 1, 1 /), (/ 2, 4 /), (/ 3, 9 /) >>;
     187
     188    f less:= 2;
     189    assert f            =  << (/ 1, 1 /), (/ 2, 4 /), (/ 3, 9 /) >>;
     190
     191    end procedure bug_9;
     192
     193
     194    procedure bug_10;
     195
     196    s1 := << 1, 2, 3, 4, 5, 6, 7 >>;
     197    s2 := << x : x in s1 >>;
     198
     199    assert s1           =  << 1 .. 7 >>;
     200    assert s2           =  << 1 .. 7 >>;
     201
     202    end procedure bug_10;
     203
     204
     205    procedure bug_11;
     206
     207    repr
     208        s1, s2:                 set(integer);
     209    end repr;
     210
     211
     212    s1 := << 1, 2, 3, 4 >>;
     213
     214    if s1 = <
> then
     215        assert false;
     216    else
     217        s2 := <
>;
     218    end if;
     219
     220    assert s1           =  << 1 .. 4 >>;
     221    assert s2           =  <
>;
     222
     223    end procedure bug_11;
     224
     225
     226    procedure bug_12;
     227$
     228$ this example shows a mode propagation bug in cod.fixasn.  this has
     229$ been fixed with v82060.
     230$
     231    t := (/ <
> /) .dis/
     232            (/tp : tp in <<(/<<'t_set'>>, (/<<'t_om'>>/), false/)>>/);
     233
     234    assert t            =  (/<<'t_set'>>, (/<<'t_om'>>/), false/);
     235
     236    end procedure bug_12;
     237
     238
     239    operator .dis(t1, t2);
     240
     241    if t1 = (/ <
> /) then return t2; end if;
     242
     243    end operator .dis;
     244
     245
     246    procedure bug_15;
     247
     248    repr
     249        f:                      mmap<> smap(integer) integer;
     250    end repr;
     251
     252
     253    f := <>;   f<<1>><<2>> with:= 3;
     254
     255    assert f            =  << (/ 1, (/ 2, 3 /) /) >>;
     256    assert f<<1>>       =  << (/ 2, 3 /) >>;
     257    assert f<<1>><<2>>  =  << 3 >>;
     258    assert f<<1>>(2)    =  3;
     259
     260    end procedure bug_15;
     261
     262
     263    procedure bug_17;
     264$
     265$ the following test was first logged as opt bug 17 on 80-10-08
     266$ by s. m. freudenberger.  it was extended to its current form
     267$ on 80-11-28, and ran successful on opt setl v80333.
     268$
     269    repr
     270        s:                      set(general);
     271    end repr;
     272
     273
     274    s := <>;                  assert s = <>;
     275    s(10) := 'a';               assert s = << (/ 10, 'a' /) >>;
     276
     277    s with:= (/ 5, 'c' /);
     278    assert s = << (/ 5, 'c' /), (/ 10, 'a' /) >>;
     279
     280    x := s(5);
     281    assert s = << (/ 5, 'c' /), (/ 10, 'a' /) >>;
     282
     283                                assert x = 'c';
     284    s lessf:= 10;               assert s = << (/ 5, 'c' /) >>;
     285    s with:= 'x';               assert s = << (/ 5, 'c' /), 'x' >>;
     286    s less:= (/ 5, 'c' /);      assert s = << 'x' >>;
     287
     288
     289    end procedure bug_17;
     290
     291
     292    procedure bug_18;
     293$
     294$ the following was first logged as opt bug 18 on 80-10-16
     295$ by s. m. freudenberger.  it was extended to its current form
     296$ on 80-11-28, and ran successful on opt setl v80333.
     297$
     298    repr
     299        base b:                 integer;
     300        f1, f2, f3:             remote mmap<> set(integer);
     301        x:                      elmt b;
     302    end repr;
     303
     304
     305    f1 := << (/ i, i*i /) : i in (/ 1 .. 10 /) >>;  f2 := f1;
     306    f1(x := 11) := 121;                             f3 := f1;
     307
     308    assert  f1          =  f3;
     309    assert  x           =  11;
     310
     311    f1 lessf:= x;
     312
     313    assert  f1<>     =  <>;
     314    assert  f1<>     /= om;
     315    assert  arb f1<> =  om;
     316    assert  f1(x)       =  om;
     317
     318    assert  f1          =  << (/ i, i*i /) : i in (/ 1 .. 10 /) >>;
     319    assert  f2          =  << (/ i, i*i /) : i in (/ 1 .. 10 /) >>;
     320    assert  f3          =  << (/ i, i*i /) : i in (/ 1 .. 11 /) >>;
     321
     322
     323    end procedure bug_18;
     324
     325
     326    procedure bug_19;
     327$
     328$ the following test was first logged as opt bug 19 on 80-10-14
     329$ by s. m. freudenberger.  it was extended to its current form
     330$ on 80-11-28, and ran successful on opt setl v80333.
     331$
     332    repr
     333        f:                      set(general);
     334        i:                      integer;
     335        j:                      string;
     336        y:                      real;
     337    end repr;
     338
     339
     340    i := 5;   j := 'a';   y := 10.0;   f := <>;
     341
     342    f<><> with:= y;
     343
     344    assert  f           =  << (/ 5, (/ 'a', 10.0 /) /) >>;
     345    assert  i           =  5;
     346    assert  j           =  'a';
     347    assert  y           =  10.0;
     348
     349
     350    end procedure bug_19;
     351
     352
     353    procedure bug_20;
     354$
     355$ the following test was first logged as opt bug 20 on 80-10-15
     356$ by s. m. freudenberger.  it was extended to its current form
     357$ on 80-11-28, and ran successful on opt setl v80333.
     358$
     359    repr
     360        f1, g1:                 mmap(integer) integer;
     361        f2, g2:                 smap(integer) integer;
     362    end repr;
     363
     364    f1 := << (/ 1, 1 /), (/ 2, 4 /), (/ 3, 9 /), (/ 4, 16 /) >>;
     365    f2 := f1;
     366
     367    assert  f1<<3>>     = << 9 >>;
     368    assert  f2(3)       = 9;
     369
     370    g2 := << (/ 1, 1 /), (/ 2, 4 /), (/ 3, 9 /), (/ 4, 16 /) >>;
     371    g1 := g2;
     372
     373    assert  g1<<3>>     = << 9 >>;
     374    assert  g2(3)       = 9;
     375
     376    end procedure bug_20;
     377
     378
     379    procedure bug_21;
     380$
     381$ the following test was first logged as opt bug 21 on 80-10-27
     382$ by s. m. freudenberger.  it was extended to its current form
     383$ on 80-11-28, and ran successful on opt setl v80333.
     384$ (this test originally produced a bad goto index in the equality
     385$ routine.)
     386$
     387    repr
     388        base b1:                string;
     389        base b2:                remote mmap<>
     390                                        sparse set(elmt b1);
     391
     392        f1, f2:                 elmt b2;
     393    end repr;
     394
     395
     396    f1 := << (/ 'a', 'b' /) >>;   f2 := << (/ 'c', 'd' /) >>;
     397
     398    assert  f1          /= f2;
     399    assert  f1          =  << (/ 'a', 'b' /) >>;
     400    assert  f2          =  << (/ 'c', 'd' /) >>;
     401
     402
     403    end procedure bug_21;
     404
     405
     406    procedure bug_22;
     407$
     408$ the following test was first logged as opt bug 22 on 80-11-13.
     409$ by s. m. freudenberger.  it was extended to its current form
     410$ on 81-01-26, and ran successful under opt setl v81021.
     411$
     412    repr
     413        base b1:                integer;
     414        base b2:                tuple(elmt b1, string);
     415
     416        f:                      sparse smap(elmt b1) string;
     417        x:                      elmt b2;
     418    end repr;
     419
     420    x := (/ 3, 'a' /);
     421    f := << (/ 3, 'a' /) >>;
     422
     423    assert  x in f;
     424    assert  f           =  << (/ 3, 'a' /) >>;
     425    assert  x           =  (/ 3, 'a' /);
     426
     427    end procedure bug_22;
     428
     429
     430    procedure bug_23;
     431$
     432$ the following test was first logged as opt bug 23 on 81-01-21
     433$ by s. m. freudenberger.  it was extended to its current form
     434$ on 81-01-26, and ran successful on opt setl v81021.
     435$ (this test originally uncovered a bug in lib.moregen:  the
     436$ conversion from s1 to s2 was not done correctly.)
     437$
     438    repr
     439        base b1:                tuple(string, integer);
     440        base b2:                elmt b1;
     441
     442        s1:                     remote set(elmt b1);
     443        s2:                     remote set(elmt b2);
     444        x1:                     elmt b1;
     445        x2:                     elmt b2;
     446    end repr;
     447
     448
     449    s1 := << (/ 'x', 1 /), (/ 'y', 2 /) >>;
     450    assert forall x1 in s1 st is_string x1(1) and is_integer x1(2);
     451
     452    s2 := s1;
     453    assert forall x2 in s2 st is_string x2(1) and is_integer x2(2);
     454
     455
     456    end procedure bug_23;
     457
     458
     459    procedure bug_24;
     460$
     461$ the following test checks whether a modification to the code
     462$ generator produces correct results.  it improves membership
     463$ tests, so that based tests are done whenever possible.
     464$
     465    repr
     466        base b1:                integer;
     467        base b2:                elmt b1;
     468        base b3:                elmt b2;
     469        base b4:                elmt b3;
     470        base b5:                remote set(elmt b1);
     471
     472        s1:                     remote set(elmt b1);
     473        x1:                     elmt b1;
     474        x2:                     elmt b2;
     475        x3:                     elmt b3;
     476        x4:                     elmt b4;
     477        s5:                     elmt b5;
     478    end repr;
     479
     480
     481    s1 := s5 := << 1 .. 20 >>;   x1 := x2 := x3 := x4 := 5;
     482
     483    assert x1 in s1;    assert x1 in s5;
     484    assert x2 in s1;    assert x2 in s5;
     485    assert x3 in s1;    assert x3 in s5;
     486    assert x4 in s1;    assert x4 in s5;
     487
     488    end procedure bug_24;
     489
     490
     491    procedure bug_25;
     492$
     493$ the following test was first logged as opt bug 25 on 81-01-29
     494$ by s. m. freudenberger.  it was included in its current form
     495$ on 81-02-06, and ran successful under opt setl v81029.
     496$
     497    b := << 1, 3 .. 100 >>;   c := << 1, 2 .. 10 >>;
     498
     499    b := b * c;
     500
     501    assert b            =  << 1, 3 .. 10 >>;
     502    assert c            =  << 1, 2 .. 10 >>;
     503
     504    end procedure bug_25;
     505
     506
     507    procedure bug_26;
     508$
     509$ this program shows an error in the conversion routine w.r.t.
     510$ the range check on short integers.
     511$
     512    init
     513        loser := (/ 1, 2, 3 /),
     514        q     := 1,
     515        t     := 3;
     516
     517    (/ loser(t), q /) := (/ q, loser(t) /);
     518
     519    assert  loser       =  (/ 1, 2, 1 /);
     520    assert  q           =  3;
     521    assert  t           =  3;
     522
     523
     524    end procedure bug_26;
     525
     526
     527    procedure bug_27;
     528$
     529$ this procedure shows a code generator problem w.r.t. mode
     530$ mode propagation on map retrievals:  setl permits the index
     531$ to be outside the map domain, which means that the index mode
     532$ need not be convertable to the map domain mode.  (it is, of
     533$ course, a somewhat redundant operation then, which explains
     534$ the original choice.)
     535$
     536    var f, x;
     537
     538    repr
     539        f:                      smap(integer) integer;
     540        x:                      string;
     541    end repr;
     542
     543
     544    f := << (/ i, i*i /) : i in << 1 .. 5 >> >>;   x := 'a';
     545
     546    assert  f(x)        =  om;
     547    assert  f<>      =  <>;
     548
     549    end procedure bug_27;
     550
     551
     552    procedure bug_28;
     553$
     554$ in these examples, the else clause of the if-expression is an
     555$ expression for which we like to back-propagate the result mode,
     556$ but which cannot be converted to the result mode of the then-
     557$ clause.  this means that the result of the if-expression must
     558$ yield a mode general, and we must reset it accordingly.
     559$
     560    var f, s, x;
     561
     562    repr
     563        f:                      smap(string) string;
     564        s:                      set(integer);
     565        x:                      general;
     566    end repr;
     567
     568
     569    f := << (/ 'a', 'b' /), (/ 'b', 'b' /) >>;
     570    s := << 1 .. 10 >>;
     571    x := 'a';
     572
     573    assert if false then s else << x : i in s >> end = << 'a' >>;
     574    assert if false then s else (/ x /) end          = (/ 'a' /);
     575    assert if false then s else domain f end         = << 'a', 'b' >>;
     576    assert if false then s else range f end          = << 'b' >>;
     577
     578
     579    end procedure bug_28;
     580
     581
     582    procedure bug_29;
     583$
     584$ this program checks the modification to the representation of the
     585$ case map
     586$
     587    const
     588        b1 = << 1, 2, 3, 4, 5, 6, 7, 8, 9 >>;
     589    var
     590        x, y, z;
     591    repr
     592        base b1:                integer;
     593        base b2:                string;
     594        f:                      remote smap(elmt b2) elmt b1;
     595        x:                      elmt b1;
     596        y:                      elmt b2;
     597        z:                      general;
     598    end repr;
     599
     600
     601    f := << (/ 'a', 1 /), (/ 'b', 2 /), (/ 'c', 3 /) >>;
     602    x := 2;   y := 'a';   z := 'c';
     603
     604    case x of
     605        (1):    assert false;
     606        (2):    assert true;
     607        (3):    assert false;
     608        (4):    assert false;
     609    end case;
     610
     611    case y of
     612        ('a'):  assert true;
     613        ('b'):  assert false;
     614        ('c'):  assert false;
     615        ('d'):  assert false;
     616    end case;
     617
     618    case z of
     619        ('a'):  assert false;
     620        ('b'):  assert false;
     621        ('c'):  assert true;
     622        ('d'):  assert false;
     623    end case;
     624
     625    assert  case x of
     626                (1):    false,
     627                (2):    true,
     628                (3):    false,
     629                (4):    false
     630                else    false
     631            end;
     632
     633    assert  case y of
     634                ('a'):  true,
     635                ('b'):  false,
     636                ('c'):  false,
     637                ('d'):  false
     638                else    false
     639            end;
     640
     641    assert  case z of
     642                ('a'):  false,
     643                ('b'):  false,
     644                ('c'):  true,
     645                ('d'):  false
     646                else    false
     647            end;
     648
     649    case x of
     650        (6):    assert false;
     651        (7):    assert false;
     652        (8):    assert false;
     653        else    assert true;
     654    end case;
     655
     656    case y of
     657        ('x'):  assert false;
     658        ('y'):  assert false;
     659        ('z'):  assert false;
     660        else    assert true;
     661    end case;
     662
     663    case z of
     664        ('x'):  assert false;
     665        ('y'):  assert false;
     666        ('z'):  assert false;
     667        else    assert true;
     668    end case;
     669
     670    assert  case x of
     671                (6):    false,
     672                (7):    false,
     673                (8):    false
     674                else    true
     675            end;
     676
     677    assert  case y of
     678                ('x'):  false,
     679                ('y'):  false,
     680                ('z'):  false
     681                else    true
     682            end;
     683
     684    assert  case z of
     685                ('x'):  false,
     686                ('y'):  false,
     687                ('z'):  false
     688                else    true
     689            end;
     690
     691    end procedure bug_29;
     692
     693
     694    procedure bug_30;
     695$
     696$ this program shows an error in the code generator routine which emits
     697$ conversions:  if both a dereference operation and a conversion to a
     698$ primitive mode is required, it should not fail.
     699$
     700    var x, y;
     701
     702    repr
     703        base b:                 general;
     704        x:                      elmt b;
     705        y:                      integer;
     706    end repr;
     707
     708    x := 1;   y := x;
     709
     710    assert  x           =  1;
     711    assert  y           =  1;
     712    assert  x           =  y;
     713
     714    end procedure bug_30;
     715
     716
     717    procedure bug_31;
     718$
     719$ this procedure checks the modification to the operator precedences for
     720$ binary compound operators.
     721$
     722    assert  2 * 3 +/ (/2/)      =  8;
     723    assert  +/(/2/)             =  2;
     724
     725    end procedure bug_31;
     726
     727
     728    procedure bug_32;
     729$
     730$ this procedure checks the modification to the grammar w.r.t. what  can
     731$ indexed:  the new definition allows a factor to be a parenthesised
     732$ expression followed by an index.
     733$
     734    assert  (if true then (/1/) else (/2/) end)(1)  =  1;
     735
     736    end procedure bug_32;
     737
     738
     739    procedure bug_33;
     740$
     741$ this procedure tests whether the ofcl and sofcl inline code sequences
     742$ work properly.
     743$
     744    var s1, s2, s3; repr s1, s2, s3: string; end repr;
     745
     746    s1 := 'abc'; s2 := 'xyz'; s3 := s1;
     747
     748    assert  s1                  =  'abc';
     749    assert  s2                  =  'xyz';
     750    assert  s3                  =  'abc';
     751
     752    s1(2) := s2(2);
     753
     754    assert  s1                  =  'ayc';
     755    assert  s2                  =  'xyz';
     756    assert  s3                  =  'abc';
     757
     758    s1(2) := s2;
     759
     760    assert  s1                  =  'axyzc';
     761    assert  s2                  =  'xyz';
     762    assert  s3                  =  'abc';
     763
     764    end procedure bug_33;
     765
     766
     767    procedure bug_34;
     768$
     769$ this procedure checks whether the correct code is generated to prevent
     770$ loops to become infinite.
     771$
     772    assert  card (/3, 4 .. 4/)  =  2;
     773    assert  card (/3, 4 .. 3/)  =  1;
     774    assert  card (/3, 4 .. 2/)  =  0;
     775
     776    assert  card (/3, 3 .. 4/)  =  0;
     777    assert  card (/3, 3 .. 3/)  =  0;
     778    assert  card (/3, 3 .. 2/)  =  0;
     779
     780    assert  card (/3, 2 .. 4/)  =  0;
     781    assert  card (/3, 2 .. 3/)  =  1;
     782    assert  card (/3, 2 .. 2/)  =  2;
     783
     784    i := 3;
     785
     786    assert  card (/i, i+1..4/)  =  2;
     787    assert  card (/i, i+1..3/)  =  1;
     788    assert  card (/i, i+1..2/)  =  0;
     789
     790    assert  card (/i, i .. 4/)  =  0;
     791    assert  card (/i, i .. 3/)  =  0;
     792    assert  card (/i, i .. 2/)  =  0;
     793
     794    assert  card (/i, i-1..4/)  =  0;
     795    assert  card (/i, i-1..3/)  =  1;
     796    assert  card (/i, i-1..2/)  =  2;
     797
     798    j := 4;
     799
     800    assert  card (/i, j .. 4/)  =  2;
     801    assert  card (/i, j .. 3/)  =  1;
     802    assert  card (/i, j .. 2/)  =  0;
     803
     804    j := 3;
     805
     806    assert  card (/i, j .. 4/)  =  0;
     807    assert  card (/i, j .. 3/)  =  0;
     808    assert  card (/i, j .. 2/)  =  0;
     809
     810    j := 2;
     811
     812    assert  card (/i, j .. 4/)  =  0;
     813    assert  card (/i, j .. 3/)  =  1;
     814    assert  card (/i, j .. 2/)  =  2;
     815
     816    end procedure bug_34;
smfd   3
smfd   4
smfd   5    procedure bug_36;
smfd   6$
smfd   7$ version:   v27 = 83073
smfd   8$ systems:   all
smfd   9$ reported   21-mar-1983  by  s. freudenberger
smfd  10$ fixed      21-mar-1983  by  s. freudenberger
smfd  11$
smfd  12$ problem:   stllib stores the symbol table index instead of the sample
smfd  13$            value when modifying mixed tuples.
smfd  14$
smfd  15    var t1, t2, t3, t4, t5, t6;
smfd  16
smfd  17    repr
smfd  18        t1, t4:         tuple;
smfd  19        t2, t5:         tuple(general, integer, integer 1..10, integer);
smfd  20        t3, t6:         tuple(untyped integer);
smfd  21    end repr;
smfd  22
smfd  23    t1 := (//); t1(1) := 1; t1(4) := 4;
smfd  24    t6 := t5 := t4 := t3 := t2 := t1;
smfd  25
smfd  26    x frome t1;      x frome t2;      x frome t3;
smfd  27    t4(#t4) := om;   t5(#t5) := om;   t6(#t6) := om;
smfd  28
smfd  29    assert  t1 = t2 and t2 = t3 and t3 = t4 and t4 = t5 and t5 = t6;
smfd  30    assert  t1 = t2 and t1 = t3 and t1 = t4 and t1 = t5 and t1 = t6;
smfd  31
smfd  32    end procedure bug_36;
smfd  33
smfd  34
smfd  35    procedure bug_37;
smfd  36$
smfd  37$ version:   v27 = 83077
smfd  38$ systems:   all
smfd  39$ reported   22-mar-1983  by  s. freudenberger
smfd  40$ fixed      23-mar-1983  by  s. freudenberger
smfd  41$
smfd  42$ problem:   cod inhibits the result of domain to be a map;  however,
smfd  43$            the optimiser treats all sets of pairs as maps.
smfd  44$
smfd  45    var f, s;
smfd  46    var i;
smfd  47
smfd  48    repr
smfd  49        base b:         tuple(integer 0..65536, integer 0..65536);
smfd  50        f:              remote mmap<> set(boolean);
smfd  51        s:              mmap<> set(integer 0..65536);
smfd  52        i:              integer 0..65536;
smfd  53    end repr;
smfd  54
smfd  55    f := <<(/(/i, i*i/), even i/) : i in (/1..5/)>>;
smfd  56    s := domain f;
smfd  57
smfd  58    assert  f   =  <<(/(/i, i*i/), even i/) : i in (/1..5/)>>;
smfd  59    assert  s   =  <<(/i, i*i/) : i in (/1..5/)>>;
smfd  60
smfd  61    end procedure bug_37;
smfd  62
smfd  63
smfd  64    procedure bug_38;
smfd  65$
smfd  66$ version:   v28 = 83244
smfd  67$ systems:   all
smfd  68$ reported   4-sep-1983  by  s. freudenberger
smfd  69$ fixed      5-sep-1983  by  s. freudenberger (no new version number)
smfd  70$
smfd  71$ problem:   cod generates a conversion that can cause run-time error;
smfd  72$            in the particular context, a conversion may only be
smfd  73$            emitted if no run-time error can result.
smfd  74$
smfd  75    var f, x;
smfd  76
smfd  77    repr
smfd  78        base b1:        integer;
smfd  79        base b2:        tuple(elmt b1, tuple(elmt b1), integer);
smfd  80        f:              remote smap(elmt b2) tuple(integer, integer);
smfd  81        x:              tuple(integer, general, integer);
smfd  82    end repr;
smfd  83
smfd  84    f := <<(/(/1, (/2, 3, 4/), 2/), (/2, 3/)/)>>;
smfd  85    x := (/6, 'a', 1/);
smfd  86    assert  f(x)        =  om;
smfd  87
smfd  88    end procedure bug_38;
     817
     818
     819end library optimiser_tests;
     820
     821
       1 .=member directory
       2      directory test;
       3
       4      var
       5          error_mode,         $ setl run-time error mode
       6          error_limit,        $ setl run-time error limit
       7          print_mode;         $ cims.setl.tst print mode
       8
       9
      10      program test - main:
      11
      12          imports
      13              binary_ops,
      14              unary_ops,
      15              string_primitive_test,
      16              parse_test,
      17              heap_sort_test,
      18              prime_factorization_test,
      19              set_identity_test,
      20              union_test_2,
      21              power_set_test,
smfc   2              map_identity_test,
      22              circularity_test,
      23              quantifier_test,
      24              recursion_test,
      25              median_test,
      26              huffman_coding_test,
      27              tarjan_test,
      28              iterator_test_1,
      29              iterator_test_2,
      30              tree_print,
      31              opt_tests;
      32          writes
      33              error_mode,
      34              error_limit,
      35              print_mode;
      36
      37
      38      module test - binary_operators:
      39
      40          $ author - s. freudenberger (nyu-cims) (15-dec-78)
      41
      42          exports
      43              binary_ops;
      44          reads
      45              print_mode,
      46              error_mode;
      47          writes
      48              error_limit;
      49
      50
      51      module test - unary_operators:
      52
      53          $ author - s. freudenberger (nyu-cims) (15-aug-81)
      54
      55          exports
      56              unary_ops;
      57          reads
      58              print_mode,
      59              error_mode;
      60          writes
      61              error_limit;
      62
      63
      64      module test - string_primitives:
      65
      66          $ authors - s. freudenberger (nyu-cims) (15-dec-78)
      67          $         - j. schwartz (nyu-cims) (16-feb-79)
      68
      69          exports
      70              string_primitive_test,
      71              parse_test;
      72          reads
      73              error_mode,
      74              print_mode;
      75          writes
      76              error_limit;
      77
      78
      79      module test - heapsort:
      80
      81          $ author - d. shields (nyu-cims) (15-dec-78)
      82
      83          exports
      84              heap_sort_test;
      85          reads
      86              print_mode;
      87
      88
      89      module test - prime_factorization:
      90
      91          $ author - j. schwartz (nyu-cims) (25-jan-79)
      92
      93          exports
      94              prime_factorization_test;
      95          reads
      96              print_mode;
      97
      98
      99      module test - set_identities:
     100
     101          $ author - e. weixelbaum (nyu-cims) (25-jan-79)
     102
     103          exports
     104              set_identity_test;
     105          reads
     106              print_mode;
     107
     108
     109      module test - union_2:
     110
     111          $ author - c. goss (nyu-cims) (25-jan-79)
     112
     113          exports
     114              union_test_2;
     115          reads
     116              print_mode;
     117
     118
     119      module test - power_set:
     120
     121          $ author h. lewis (nyu-cims) (02-feb-79)
     122
     123          exports
     124              power_set_test;
     125          reads
     126              print_mode;
     127
smfc   3
smfc   4      module test - map_identities:
smfc   5
smfc   6          $ author - larry rudolph (nyu-cims)
smfc   7          $ completed by s. freudenberger (nyu-cims)  (29-aug-83)
smfc   8
smfc   9          exports
smfc  10              map_identity_test;
smfc  11          reads
smfc  12              print_mode;
smfc  13
     128
     129      module test - circularity:
     130
     131          $ author - r. lee (nyu-cims) (02-feb-79)
     132
     133          exports
     134              circularity_test;
     135          reads
     136              print_mode;
     137
     138
     139      module test - quantifiers:
     140
     141          $ author - r. lee (nyu-cims)
     142
     143          exports
     144              quantifier_test;
     145          reads
     146              print_mode;
     147
     148
     149      module test - recursion:
     150
     151          $ author - j. schwartz (nyu-cims) (02-feb-79)
     152
     153          exports
     154              recursion_test;
     155          reads
     156              print_mode;
     157
     158
     159      module test - median_finder:
     160
     161          $ author - henry warren (nyu-cims) (20-feb-79)
     162
     163          exports
     164              median_test;
     165          reads
     166              print_mode;
     167
     168
     169      module test - huffman_coding:
     170
     171          $ author - j. schwartz (nyu-cims) (19-feb-79)
     172
     173          exports
     174              huffman_coding_test;
     175          reads
     176              print_mode;
     177
     178
     179      module test - tarjan:
     180
     181          $ tarjan-s fast interval finder.
     182          $ (see setl newsletter no. 204 for details) (15-dec-78)
     183
     184          exports
     185              tarjan_test;
     186          reads
     187              print_mode;
     188
     189
     190      module test - iterators_1:
     191
     192          $ author - r. lee (nyu-cims) (15-dec-78)
     193
     194          exports
     195              iterator_test_1;
     196          reads
     197              print_mode;
     198
     199
     200      module test - iterators_2:
     201
     202          $ author - r. lee (nyu-cims) (15-dec-78)
     203
     204          exports
     205              iterator_test_2;
     206          reads
     207              print_mode;
     208
     209
     210      module test - input_output:
     211
     212          $ author - j. schwartz (nyu-cims) (20-feb-79)
     213
     214          exports
     215              tree_print;
     216          reads
     217              print_mode;
     218
     219
     220      end directory test;
       1 .=member setlmain
       2      program test - main;
       3
       4      title('cims.setl.' + prog_level);
       5
       6      getem(error_mode, error_limit);
       7
       8      print_mode := getipp('assert=1/2');
       9      if getipp('tdebug=0/1') = 1 then print_mode := print_debug; end;
      10
      11      binary_ops;
      12      unary_ops;
      13      string_primitive_test;
      14      parse_test;
      15
      16      heap_sort_test;
      17      prime_factorization_test;
      18
      19      set_identity_test;      $ test  5
      20      union_test_2;           $ test  6
      21      power_set_test;         $ test  8
smfc  14      map_identity_test;      $ test 9
      22      circularity_test;       $ test 16
      23      quantifier_test;        $ test 24
      24      recursion_test;         $ test 28
      25
      26      median_test;
      27      huffman_coding_test;
      28      tarjan_test;
      29
      30      iterator_test_1;
      31      iterator_test_2;
      32
      33      tree_print;
      34      opt_tests;
      35
      36      end program test - main;
      37
      38
      39
      40
       1 .=member binops
       2      module test - binary_operators;
       3
       4          $ nyu test id
       5          $ author - s. freudenberger (nyu-cims)
       6
       7          exports
       8              binary_ops;      $ tests binary operators
       9          reads
      10              print_mode,
      11              error_mode;
      12          writes
      13              error_limit;
      14
      15
      16          const
      17              eps   = 0.1e-04,
      18
      19              ptupb = <<13, 14, 15>>,
      20              lsetb = <<5, 6, 7, 8, 9>>,
suna   2              rsetb = <<10, 11, 12, 13, 14>>;
suna   3
suna   4          init
suna   5              sivar  :=      3,
suna   6              simax  :=  maxsi,
suna   7              livar  :=     -3,
suna   8              revar  :=    3.0,
suna   9              lcvar  :=  'abc',
suna  10
suna  11              sttup  :=  (/1, 2, 3/),
suna  12              uitup  :=  (/4, 5, 6/),
suna  13              urtup  :=  (/7.0, 8.0, 9.0/),
suna  14              pitup  :=  (/10, 11, 12/),
suna  15              pbtup  :=  (/13, 14, 15/),
suna  16
suna  17              uset1  :=  << 1,  2,  3>>,
suna  18              uset2  :=  << 0,  2,  4>>,
suna  19              lset1  :=  << 6,  7,  8>>,
suna  20              lset2  :=  << 5,  7,  9>>,
suna  21              rset1  :=  <<11, 12, 13>>,
suna  22              rset2  :=  <<10, 12, 14>>;
      43
      44          repr
      45              sivar, simax, livar:   integer;
      46              eps, revar:            real;
      47              lcvar:                 string;
      48
      49              base ptupb:            integer;
      50              uitup:                 tuple(untyped integer);
      51              urtup:                 tuple(untyped real);
      52              pitup:                 packed tuple(integer 10...12);
      53              pbtup:                 packed tuple(elmt ptupb);
      54
      55              base lsetb:            integer;
      56              lset1, lset2:          local set(elmt lsetb);
      57
      58              base rsetb:            integer;
      59              rset1, rset2:          remote set(elmt rsetb);
      60
      61          end repr;
      62
      63
      64      proc binary_ops;
      65
      66      print_head('binary operator test');
      67
      70      if print_mode = print_debug then
      71          print;
      72
      73          print('short integer =   ', sivar);
      74          print('max short int =   ', simax);
      75          print('long integer =    ', livar);
      76          print('epsilon =         ', eps  );
      77          print('real =            ', revar);
      78          print('long char string =', lcvar);
      79
      80          print('standard tuple =  ', sttup);
      81          print('untyped int tup = ', uitup);
      82          print('untyped real tup =', urtup);
      83          print('packed int tup =  ', pitup);
      84          print('packed based tup =', pbtup);
      85
      86          print('unbased set 1 =   ', uset1);
      87          print('unbased set 2 =   ', uset2);
      88          print('local set 1 =     ', lset1);
      89          print('local set 2 =     ', lset2);
      90          print('remote set 1 =    ', rset1);
      91          print('remote set 2 =    ', rset2);
      92      end if;
      93
      94      add_test;           $ tests -add-   routine
      95      diff_test;          $ tests -diff-  routine
      96      div_test;           $ tests -div-   routine
      97      slash_test;         $ tests -slash- routine
      98      smod_test;          $ tests -smod-  routine
      99      mult_test;          $ tests -mult-  routine
     100      sexp_test;          $ tests -sexp-  routine
     101      with_test;          $ tests -with-  routine
     102$     less_test;          $ tests -less-  routine
     103$     from_test;          $ tests -from-  routine
     104      incs_test;          $ tests -incs-  routine
     105      npow_test;          $ tests -npow-  routine
suna  23
suna  24      assert  sivar  =      3;
suna  25      assert  simax  =  maxsi;
suna  26      assert  livar  =     -3;
suna  27      assert  lcvar  =  'abc';
suna  28
suna  29      assert  abs(revar - 3.0)  <  eps;
suna  30
suna  31      assert  sttup  =  (/1, 2, 3/);
suna  32      assert  uitup  =  (/4, 5, 6/);
suna  33      assert  urtup  =  (/7.0, 8.0, 9.0/);
null   1$$$--- first need to fix ltlasm...
null   2$$--  assert  pitup  =  (/10, 11, 12/);
null   3$$--  assert  pbtup  =  (/13, 14, 15/);
suna  36
suna  37      assert  uset1  =  << 1,  2,  3>>;
suna  38      assert  uset2  =  << 0,  2,  4>>;
suna  39      assert  lset1  =  << 6,  7,  8>>;
suna  40      assert  lset2  =  << 5,  7,  9>>;
suna  41      assert  rset1  =  <<11, 12, 13>>;
suna  42      assert  rset2  =  <<10, 12, 14>>;
     106
     107      print_tail('binary operator test');
     108
     109      end proc binary_ops;
     110
     111
     112      proc add_test;
     113
     114      print_head('addition test');
     115
     116      assert        sivar + sivar    =       6                         ;
     117      assert        sivar + livar    =       0                         ;
     118      assert        simax + simax    =  262142                         ;
     119      assert        livar + sivar    =       0                         ;
     120      assert        livar + livar    =      -6                         ;
     121      assert  abs( (revar + revar)   -       6.0                ) < eps;
     122      assert        lcvar + lcvar    =  'abcabc'                       ;
     123      assert        sttup + sttup    =  (/1, 2, 3, 1, 2, 3/)           ;
     124      assert        sttup + uitup    =  (/1, 2, 3, 4, 5, 6/)           ;
     125      assert        uitup + sttup    =  (/4, 5, 6, 1, 2, 3/)           ;
     126      assert        uitup + uitup    =  (/4, 5, 6, 4, 5, 6/)           ;
     127      assert        uset1 + uset2    =  <<0, 1, 2, 3, 4>>              ;
     128      assert        uset1 + lset1    =  <<1, 2, 3, 6, 7, 8>>           ;
     129      assert        uset1 + rset1    =  <<1, 2, 3, 11, 12, 13>>        ;
     130      assert        lset1 + uset1    =  <<1, 2, 3, 6, 7, 8>>           ;
     131      assert        lset1 + lset2    =  <<5, 6, 7, 8, 9>>              ;
     132      assert        lset1 + rset1    =  <<6, 7, 8, 11, 12, 13>>        ;
     133      assert        rset1 + uset1    =  <<1, 2, 3, 11, 12, 13>>        ;
     134      assert        rset1 + lset1    =  <<6, 7, 8, 11, 12, 13>>        ;
     135      assert        rset1 + rset2    =  <<10, 11, 12, 13, 14>>         ;
     136
     137      print;
     138      error_limit +:= 9; setem(error_mode, error_limit);
     139      print ( 'error messages om.13 and type.02',
     140                                           'should follow this line.' );
     141      echeck(    om +    om                                           );
     142      print ( 'error message type.03 should follow this line.'        );
     143      echeck( sivar +    om                                           );
     144      print ( 'error message type.03 should follow this line.'        );
     145      echeck( livar +    om                                           );
     146      print ( 'error message type.03 should follow this line.'        );
     147      echeck( lcvar +    om                                           );
     148      print ( 'error message type.03 should follow this line.'        );
     149      echeck( revar +    om                                           );
     150      print ( 'error message type.03 should follow this line.'        );
     151      echeck( sttup +    om                                           );
     152      print ( 'error message type.03 should follow this line.'        );
     153      echeck( uitup +    om                                           );
     154      print ( 'error message type.03 should follow this line.'        );
     155      echeck( uset1 +    om                                           );
     156
     157      print_tail('addition test');
     158
     159      end proc add_test;
     160
     161
     162      proc diff_test;
     163
     164      print_head('difference test');
     165
     166      assert        sivar - sivar    =       0                         ;
     167      assert        sivar - simax    = -131068                         ;
     168      assert        sivar - livar    =       6                         ;
     169      assert        livar - sivar    =      -6                         ;
     170      assert        livar - livar    =       0                         ;
     171      assert  abs( (revar - revar)   -       0.0                ) < eps;
     172      assert        uset1 - uset2    =  <<1, 3>>                       ;
     173      assert        lset1 - lset2    =  <<6, 8>>                       ;
     174      assert        rset1 - rset2    =  <<11, 13>>                     ;
     175
     176      print;
     177      error_limit +:= 9; setem(error_mode, error_limit);
     178      print ( 'error messages om.13 and type.04',
     179                                           'should follow this line.' );
     180      echeck(    om -    om                                           );
     181      print ( 'error message type.04 should follow this line.'        );
     182      echeck( lcvar -    om                                           );
     183      print ( 'error message type.04 should follow this line.'        );
     184      echeck( sttup -    om                                           );
     185      print ( 'error message type.04 should follow this line.'        );
     186      echeck( uitup -    om                                           );
     187      print ( 'error message type.05 should follow this line.'        );
     188      echeck( sivar -    om                                           );
     189      print ( 'error message type.05 should follow this line.'        );
     190      echeck( livar -    om                                           );
     191      print ( 'error message type.05 should follow this line.'        );
     192      echeck( revar -    om                                           );
     193      print ( 'error message type.05 should follow this line.'        );
     194      echeck( uset1 -    om                                           );
     195
     196      print_tail('difference test');
     197
     198      end proc diff_test;
     199
     200
     201      proc div_test;
     202      var temp; repr temp: general; end repr;
     203
     204      print_head('integer division test');
     205
     206      assert        sivar div sivar  =       1                         ;
     207      assert        sivar div livar  =      -1                         ;
     208      assert        simax div sivar  =   43690                         ;
     209      assert        simax div livar  =  -43690                         ;
     210      assert        livar div sivar  =      -1                         ;
     211      assert        livar div livar  =       1                         ;
     212
     213      print;
     214      error_limit +:= 8; setem(error_mode, error_limit);
     215      print ( 'error message type.06 should follow this line.'        );
     216      echeck(    om div    om                                         );
     217      print ( 'error message type.06 should follow this line.'        );
     218      temp := revar;
     219      echeck(  temp div    om                                         );
     220      print ( 'error message type.06 should follow this line.'        );
     221      temp := lcvar;
     222      echeck(  temp div    om                                         );
     223      print ( 'error message type.06 should follow this line.'        );
     224      temp := sttup;
     225      echeck(  temp div    om                                         );
     226      print ( 'error message type.06 should follow this line.'        );
     227      temp := uitup;
     228      echeck(  temp div    om                                         );
     229      print ( 'error message type.06 should follow this line.'        );
     230      temp := uset1;
     231      echeck(  temp div    om                                         );
     232      print ( 'error message type.07 should follow this line.'        );
     233      echeck( sivar div    om                                         );
     234      print ( 'error message type.07 should follow this line.'        );
     235      echeck( livar div    om                                         );
     236
     237      print_tail('integer division test');
     238
     239      end proc div_test;
     240
     241
     242      proc slash_test;
     243
     244      print_head('real division test');
     245
     246      assert  abs( (sivar / sivar)   -       1.0                ) < eps;
     247      assert  abs( (sivar / livar)   -      -1.0                ) < eps;
     248      assert  abs( (livar / sivar)   -      -1.0                ) < eps;
     249      assert  abs( (livar / livar)   -       1.0                ) < eps;
     250      assert  abs( (revar / revar)   -       1.0                ) < eps;
     251
     252      print;
     253      error_limit +:= 8; setem(error_mode, error_limit);
     254      print ( 'error message type.08 should follow this line.'        );
     255      echeck(    om /    om                                           );
     256      print ( 'error message type.08 should follow this line.'        );
     257      echeck( lcvar /    om                                           );
     258      print ( 'error message type.08 should follow this line.'        );
     259      echeck( sttup /    om                                           );
     260      print ( 'error message type.08 should follow this line.'        );
     261      echeck( uitup /    om                                           );
     262      print ( 'error message type.08 should follow this line.'        );
     263      echeck( uset1 /    om                                           );
     264      print ( 'error message type.09 should follow this line.'        );
     265      echeck( sivar /    om                                           );
     266      print ( 'error message type.09 should follow this line.'        );
     267      echeck( livar /    om                                           );
     268      print ( 'error message type.09 should follow this line.'        );
     269      echeck( revar /    om                                           );
     270
     271      print_tail('real division test');
     272
     273      end proc slash_test;
     274
     275
     276      proc smod_test;
     277
     278      print_head('modulo test');
     279
     280      assert        sivar mod sivar   =       0                        ;
     281      assert        sivar mod livar   =       0                        ;
     282      assert        simax mod sivar   =       1                        ;
     283      assert        simax mod livar   =       1                        ;
     284      assert        livar mod sivar   =       0                        ;
     285      assert        livar mod livar   =       0                        ;
     286      assert        uset1 mod uset2   =  <<0, 1, 3, 4>>                ;
     287      assert        lset1 mod lset2   =  <<5, 6, 8, 9>>                ;
     288      assert        rset1 mod rset2   =  <<10, 11, 13, 14>>            ;
     289
     290      print;
     291      error_limit +:= 8; setem(error_mode, error_limit);
     292      print ( 'error message type.10 should follow this line.'        );
     293      echeck(    om mod   om                                          );
     294      print ( 'error message type.10 should follow this line.'        );
     295      echeck( lcvar mod   om                                          );
     296      print ( 'error message type.10 should follow this line.'        );
     297      echeck( revar mod   om                                          );
     298      print ( 'error message type.10 should follow this line.'        );
     299      echeck( sttup mod   om                                          );
     300      print ( 'error message type.10 should follow this line.'        );
     301      echeck( uitup mod   om                                          );
     302      print ( 'error message type.11 should follow this line.'        );
     303      echeck( sivar mod   om                                          );
     304      print ( 'error message type.11 should follow this line.'        );
     305      echeck( livar mod   om                                          );
     306      print ( 'error message type.11 should follow this line.'        );
     307      echeck( uset1 mod   om                                          );
     308
     309      print_tail('modulo test');
     310
     311      end proc smod_test;
     312
     313
     314      proc mult_test;
     315
     316      const one = 1, zero = 0;
     317
     318      var uset3;   init uset3 := <<2, 5>>;
     319
     320      print_head('multiplication test');
     321
     322      assert        sivar * sivar   =       9                          ;
     323      assert        sivar * livar   =      -9                          ;
     324      assert        sivar * lcvar   =  'abcabcabc'                     ;
     325      assert        sivar * sttup   =  (/1, 2, 3, 1, 2, 3, 1, 2, 3/)   ;
     326      assert        sivar * uitup   =  (/4, 5, 6, 4, 5, 6, 4, 5, 6/)   ;
     327      assert        simax * sivar   =  393213                          ;
     328      assert        simax * livar   = -393213                          ;
     329      assert        livar * sivar   =      -9                          ;
     330      assert        livar * livar   =       9                          ;
     331      assert  abs( (revar * revar)  -       9.0                 ) < eps;
     332      assert        lcvar * sivar   =  'abcabcabc'                     ;
     333      assert        lcvar *   one   =  'abc'                           ;
     334      assert        lcvar *  zero   =         ''                       ;
     335      assert        sttup * sivar   =  (/1, 2, 3, 1, 2, 3, 1, 2, 3/)   ;
     336      assert        sttup *   one   =  (/1, 2, 3/)                     ;
     337      assert        sttup *  zero   =  (//)                            ;
     338      assert        uitup * sivar   =  (/4, 5, 6, 4, 5, 6, 4, 5, 6/)   ;
     339      assert        uitup *   one   =  (/4, 5, 6/)                     ;
     340      assert        uitup *  zero   =  (//)                            ;
     341      assert        uset1 * uset2   =  <<2>>                           ;
     342      assert        uset1 * uset3   =  <<2>>                           ;
     343      assert        uset3           =  <<2, 5>>                        ;
     344      assert        lset1 * lset2   =  <<7>>                           ;
     345      assert        rset1 * rset2   =  <<12>>                          ;
     346
     347      print;
     348      error_limit +:= 9; setem(error_mode, error_limit);
     349      print ( 'error messages om.13 and type.12',
     350                                    'should follow this line.'        );
     351      echeck(    om *    om                                           );
     352      print ( 'error message type.13 should follow this line.'        );
     353      echeck( sivar *    om                                           );
     354      print ( 'error message type.13 should follow this line.'        );
     355      echeck( livar *    om                                           );
     356      print ( 'error message type.13 should follow this line.'        );
     357      echeck( lcvar *    om                                           );
     358      print ( 'error message type.13 should follow this line.'        );
     359      echeck( revar *    om                                           );
     360      print ( 'error message type.13 should follow this line.'        );
     361      echeck( sttup *    om                                           );
     362      print ( 'error message type.13 should follow this line.'        );
     363      echeck( uitup *    om                                           );
     364      print ( 'error message type.13 should follow this line.'        );
     365      echeck( uset1 *    om                                           );
     366
     367      print_tail('multiplication test');
     368
     369      end proc mult_test;
     370
     371
     372      proc sexp_test;
     373
     374      print_head('exponentation test');
     375
     376      assert  abs( (  5.0 **   2.0)  -      25.0                ) < eps;
     377      assert  abs( (  5.0 **   0.0)  -       1.0                ) < eps;
     378      assert  abs( (  5.0 **  -1.0)  -       0.2                ) < eps;
     379      echeck(         0.0 **   2.0                                    );
     380      echeck(         0.0 **   0.0                                    );
     381      echeck(         0.0 **  -2.0                                    );
     382      echeck(        -3.0 **   2.0                                    );
     383      echeck(        -3.0 **   0.0                                    );
     384      echeck(        -3.0 **  -2.0                                    );
     385      assert  abs( (  5.0 **     2)  -      25.0                ) < eps;
     386      assert  abs( (  5.0 **     0)  -       1.0                ) < eps;
     387      assert  abs( (  2.0 **    -2)  -       0.25               ) < eps;
     388      assert  abs( (  0.0 **     2)  -       0.0                ) < eps;
     389      echeck(         0.0 **     0                                    );
     390      echeck(         0.0 **    -2                                    );
     391      assert  abs( ( -2.0 **     3)  -      -8.0                ) < eps;
     392      assert  abs( ( -2.0 **     2)  -       4.0                ) < eps;
     393      assert  abs( ( -2.0 **     0)  -       1.0                ) < eps;
     394      assert  abs( ( -2.0 **    -2)  -       0.25               ) < eps;
     395      assert  abs( ( -2.0 **    -3)  -      -0.125              ) < eps;
     396      assert            2 **     2    =       4                        ;
     397      assert            2 **     0    =       1                        ;
     398      assert  abs( (    2 **    -2)  -       0.25               ) < eps;
     399      assert            0 **     2    =       0                        ;
     400      echeck(           0 **     0                                    );
     401      echeck(           0 **    -2                                    );
     402      assert           -2 **     3    =      -8                        ;
     403      assert           -2 **     2    =       4                        ;
     404      assert           -2 **     0    =       1                        ;
     405      assert  abs( (   -2 **    -2)  -       0.25               ) < eps;
     406      assert  abs( (   -2 **    -3)  -      -0.125              ) < eps;
     407
     408      print;
     409      error_limit +:= 5; setem(error_mode, error_limit);
     410      print ( 'error message om.22 should follow this line.'          );
     411      echeck(          om **   2.0                                    );
     412      print ( 'error message om.23 should follow this line.'          );
     413      echeck(         2.0 **    om                                    );
     414      print ( 'error message type.52 should follow this line.'        );
     415      echeck(         'a' **   2.0                                    );
     416      print ( 'error message type.53 should follow this line.'        );
     417      echeck(         2.0 **   'a'                                    );
     418      print ( 'error message type.53 should follow this line.'        );
     419      echeck(           2 **   5.0                                    );
     420
     421      print_tail('exponentation test');
     422
     423      end proc sexp_test;
     424
     425
     426      proc with_test;
     427
     428      var s;
     429      init s := <<1>>;
     430
     431      print_head('with routine test');
     432
     433      s with:= s;
     434      s with:= s;
     435      assert  s = <<1, <<1>>, <<1, <<1>>>> >>;
     436
     437      s := om;
     438
     439      print_tail('with routine test');
     440
     441      end proc with_test;
     442
     443
     444      proc incs_test;
     445
     446      print_head('set inclusion test');
     447
     448      temp1 := <<1, 2, 3, 4>>;
     449
     450      assert        temp1 incs uset1  =      true                      ;
     451      assert        uset1 incs uset1  =      true                      ;
     452      assert        uset1 incs temp1  =      false                     ;
     453      assert        temp1 incs uset2  =      false                     ;
     454      assert        uset2 incs temp1  =      false                     ;
     455      assert        uset1 incs <>   =      true                      ;
     456
     457      print;
     458      error_limit +:= 2; setem(error_mode, error_limit);
     459      print ( 'error message type.46 should follow this line.'        );
     460      assert           om incs uset1  =      false                     ;
     461      print ( 'error message type.47 should follow this line.'        );
     462      assert        uset1 incs    om  =      false                     ;
     463
     464      print_tail('set inclusion test');
     465
     466      end proc incs_test;
     467
     468
     469      proc npow_test;
     470
     471      print_head('k-subset test');
     472
     473      echeck(    -1 npow uset1                                        );
     474      assert        0 npow uset1  =  <<<>>>                          ;
     475      assert        1 npow uset1  =  <<<<1>>, <<2>>, <<3>>>>           ;
     476      assert        2 npow uset1  =  <<<<1, 2>>, <<1, 3>>, <<2, 3>>>>  ;
     477      assert        3 npow uset1  =  <<<<1, 2, 3>>>>                   ;
     478      assert        4 npow uset1  =  <>                              ;
     479      assert    uset1 npow sivar  =  <<<<1, 2, 3>>>>                   ;
     480
     481      print;
     482      error_limit +:= 2; setem(error_mode, error_limit);
     483      print ( 'error message type.49 should follow this line.'        );
     484      echeck(    om npow    om                                        );
     485      print ( 'error message type.01 should follow this line.'        );
     486      echeck( uset1 npow uset2                                        );
     487
     488      print_tail('k-subset test');
     489
     490      end proc npow_test;
     491
     492
     493      proc echeck(rd a);
     494
     495      if error_mode = 4 then
     496          print(a);
     497
     498      elseif a /= om then
     499          print;
     500          print(25 * '*');
     501          print('incorrect error value:', a);
     502          print;
     503
     504      end if;
     505
     506      end proc echeck;
     507
     508
     509      end module test - binary_operators;
     510
     511
     512
     513
       1 .=member unops
       2
       3
       4module test - unary_operators;
       5
       6    $ nyu test id
       7    $ author - s. freudenberger (nyu-cims)
       8
       9    exports
      10        unary_ops;              $ tests unary operators
      11    reads
      12        print_mode,
      13        error_mode;
      14    writes
      15        error_limit;
      16
      17
      18    const
      19        s  = << 1,  3,   5 >>,
      20        d1 = << 1,  9,  25 >>,
      21        d2 = << 1, 27, 125 >>,
      22        d3 = << 1, 81, 625 >>,
      23        r1 = << 1,  9,  25 >>,
      24        r2 = << 1, 27, 125 >>,
      25        r3 = << 1, 81, 625 >>,
      26        r4 = << 1, 3, 5,  9,  25 >>,
      27        r5 = << 1, 3, 5, 27, 125 >>,
      28        r6 = << 1, 3, 5, 81, 625 >>;
      29
      30    var
      31        s1, s2, s3,
      32        f1, f2, f3, f4, f5, f6,
      33        lset, rset, sset,
      34        lsm1, rsm1, ssm1, lmm1, rmm1, smm1,
      35        lsm2, rsm2, ssm2, lmm2, rmm2, smm2,
      36        lsm3, rsm3, ssm3, lmm3, rmm3, smm3;
      37
      38    repr
      39        base b1:                integer;
      40        base b2:                integer;
      41        base b3:                elmt b2;
      42
      43        s1:                     general;
      44        s2:                     set(general);
      45        s3:                     set(integer);
      46
      47        lset:                   local  set(elmt b1);
      48        rset:                   remote set(elmt b1);
      49        sset:                   sparse set(elmt b1);
      50
      51        f1:                     general;
      52        f2:                     smap(general) integer;
      53        f3:                     smap(integer) integer;
      54
      55        lsm1:                   local  smap(elmt b1) elmt b1;
      56        rsm1:                   remote smap(elmt b1) elmt b1;
      57        ssm1:                   sparse smap(elmt b1) elmt b1;
      58
      59        lsm2:                   local  smap(elmt b2) elmt b2;
      60        rsm2:                   remote smap(elmt b2) elmt b2;
      61        ssm2:                   sparse smap(elmt b2) elmt b2;
      62
      63        lsm3:                   local  smap(elmt b3) elmt b3;
      64        rsm3:                   remote smap(elmt b3) elmt b3;
      65        ssm3:                   sparse smap(elmt b3) elmt b3;
      66
      67        f4:                     general;
      68        f5:                     mmap<> set(general);
      69        f6:                     mmap<> set(integer);
      70
      71        lmm1:           local  mmap<> sparse set(elmt b1);
      72        rmm1:           remote mmap<> sparse set(elmt b1);
      73        smm1:           sparse mmap<> sparse set(elmt b1);
      74
      75        lmm2:           local  mmap<> sparse set(elmt b2);
      76        rmm2:           remote mmap<> sparse set(elmt b2);
      77        smm2:           sparse mmap<> sparse set(elmt b2);
      78
      79        lmm3:           local  mmap<> sparse set(elmt b3);
      80        rmm3:           remote mmap<> sparse set(elmt b3);
      81        smm3:           sparse mmap<> sparse set(elmt b3);
      82    end repr;
      83
      84
      85    procedure unary_ops;
      86
      87        print_head('unary operator tests');
      88
      89        dom_test;               $ tests -domain- operator
      90        range_test;             $ tests -range-  operator
      91
      92        print_tail('unary operator tests');
      93
      94    end procedure unary_ops;
      95
      96
      97    procedure dom_test;
      98
      99
     100        print_head('domain test');
     101
     102        f1 := << (/ x**2, x /) : x in s >>;
     103        f2 := << (/ x**3, x /) : x in s >>;
     104        f3 := << (/ x**4, x /) : x in s >>;
     105
     106        lsm1 := lmm1 := rsm1 := rmm1 := ssm1 := smm1 := f1;
     107        lsm2 := lmm2 := rsm2 := rmm2 := ssm2 := smm2 := f2;
     108        lsm3 := lmm3 := rsm3 := rmm3 := ssm3 := smm3 := f3;
     109
     110        unbased_cases;
     111        based_cases;
     112
     113    assert f1 = lsm1;   assert f1 = rsm1;   assert f1 = ssm1;
     114    assert f2 = lsm2;   assert f2 = rsm2;   assert f2 = ssm2;
     115    assert f3 = lsm3;   assert f3 = rsm3;   assert f3 = ssm3;
     116    assert f1 = lmm1;   assert f1 = rmm1;   assert f1 = smm1;
     117    assert f2 = lmm2;   assert f2 = rmm2;   assert f2 = smm2;
     118    assert f3 = lmm3;   assert f3 = rmm3;   assert f3 = smm3;
     119
     120    assert f1 = << (/ x**2, x /) : x in s >>;
     121    assert f2 = << (/ x**3, x /) : x in s >>;
     122    assert f3 = << (/ x**4, x /) : x in s >>;
     123
     124        print_tail('domain test');
     125
     126
     127    end procedure dom_test;
     128
     129
     130    procedure unbased_cases;
     131
     132        s1 := domain f1;        assert s1 = d1;
     133        s2 := domain f1;        assert s2 = d1;
     134        s3 := domain f1;        assert s3 = d1;
     135
     136        s1 := domain f2;        assert s1 = d2;
     137        s2 := domain f2;        assert s2 = d2;
     138        s3 := domain f2;        assert s3 = d2;
     139
     140        s1 := domain f3;        assert s1 = d3;
     141        s2 := domain f3;        assert s2 = d3;
     142        s3 := domain f3;        assert s3 = d3;
     143
     144        s1 := domain lsm1;      assert s1 = d1;
     145        s2 := domain lsm1;      assert s2 = d1;
     146        s3 := domain lsm1;      assert s3 = d1;
     147
     148        s1 := domain lsm2;      assert s1 = d2;
     149        s2 := domain lsm2;      assert s2 = d2;
     150        s3 := domain lsm2;      assert s3 = d2;
     151
     152        s1 := domain lsm3;      assert s1 = d3;
     153        s2 := domain lsm3;      assert s2 = d3;
     154        s3 := domain lsm3;      assert s3 = d3;
     155
     156        s1 := domain lmm1;      assert s1 = d1;
     157        s2 := domain lmm1;      assert s2 = d1;
     158        s3 := domain lmm1;      assert s3 = d1;
     159
     160        s1 := domain lmm2;      assert s1 = d2;
     161        s2 := domain lmm2;      assert s2 = d2;
     162        s3 := domain lmm2;      assert s3 = d2;
     163
     164        s1 := domain lmm3;      assert s1 = d3;
     165        s2 := domain lmm3;      assert s2 = d3;
     166        s3 := domain lmm3;      assert s3 = d3;
     167
     168        s1 := domain rsm1;      assert s1 = d1;
     169        s2 := domain rsm1;      assert s2 = d1;
     170        s3 := domain rsm1;      assert s3 = d1;
     171
     172        s1 := domain rsm2;      assert s1 = d2;
     173        s2 := domain rsm2;      assert s2 = d2;
     174        s3 := domain rsm2;      assert s3 = d2;
     175
     176        s1 := domain rsm3;      assert s1 = d3;
     177        s2 := domain rsm3;      assert s2 = d3;
     178        s3 := domain rsm3;      assert s3 = d3;
     179
     180        s1 := domain rmm1;      assert s1 = d1;
     181        s2 := domain rmm1;      assert s2 = d1;
     182        s3 := domain rmm1;      assert s3 = d1;
     183
     184        s1 := domain rmm2;      assert s1 = d2;
     185        s2 := domain rmm2;      assert s2 = d2;
     186        s3 := domain rmm2;      assert s3 = d2;
     187
     188        s1 := domain rmm3;      assert s1 = d3;
     189        s2 := domain rmm3;      assert s2 = d3;
     190        s3 := domain rmm3;      assert s3 = d3;
     191
     192        s1 := domain ssm1;      assert s1 = d1;
     193        s2 := domain ssm1;      assert s2 = d1;
     194        s3 := domain ssm1;      assert s3 = d1;
     195
     196        s1 := domain ssm2;      assert s1 = d2;
     197        s2 := domain ssm2;      assert s2 = d2;
     198        s3 := domain ssm2;      assert s3 = d2;
     199
     200        s1 := domain ssm3;      assert s1 = d3;
     201        s2 := domain ssm3;      assert s2 = d3;
     202        s3 := domain ssm3;      assert s3 = d3;
     203
     204        s1 := domain smm1;      assert s1 = d1;
     205        s2 := domain smm1;      assert s2 = d1;
     206        s3 := domain smm1;      assert s3 = d1;
     207
     208        s1 := domain smm2;      assert s1 = d2;
     209        s2 := domain smm2;      assert s2 = d2;
     210        s3 := domain smm2;      assert s3 = d2;
     211
     212        s1 := domain smm3;      assert s1 = d3;
     213        s2 := domain smm3;      assert s2 = d3;
     214        s3 := domain smm3;      assert s3 = d3;
     215
     216
     217    end procedure unbased_cases;
     218
     219
     220    procedure based_cases;
     221
     222        lset := domain f1;      assert lset = d1;
     223        rset := domain f1;      assert rset = d1;
     224        sset := domain f1;      assert sset = d1;
     225
     226        lset := domain f2;      assert lset = d2;
     227        rset := domain f2;      assert rset = d2;
     228        sset := domain f2;      assert sset = d2;
     229
     230        lset := domain f3;      assert lset = d3;
     231        rset := domain f3;      assert rset = d3;
     232        sset := domain f3;      assert sset = d3;
     233
     234        lset := domain lsm1;    assert lset = d1;
     235        rset := domain lsm1;    assert rset = d1;
     236        sset := domain lsm1;    assert sset = d1;
     237
     238        lset := domain lsm2;    assert lset = d2;
     239        rset := domain lsm2;    assert rset = d2;
     240        sset := domain lsm2;    assert sset = d2;
     241
     242        lset := domain lsm3;    assert lset = d3;
     243        rset := domain lsm3;    assert rset = d3;
     244        sset := domain lsm3;    assert sset = d3;
     245
     246        lset := domain lmm1;    assert lset = d1;
     247        rset := domain lmm1;    assert rset = d1;
     248        sset := domain lmm1;    assert sset = d1;
     249
     250        lset := domain lmm2;    assert lset = d2;
     251        rset := domain lmm2;    assert rset = d2;
     252        sset := domain lmm2;    assert sset = d2;
     253
     254        lset := domain lmm3;    assert lset = d3;
     255        rset := domain lmm3;    assert rset = d3;
     256        sset := domain lmm3;    assert sset = d3;
     257
     258        lset := domain rsm1;    assert lset = d1;
     259        rset := domain rsm1;    assert rset = d1;
     260        sset := domain rsm1;    assert sset = d1;
     261
     262        lset := domain rsm2;    assert lset = d2;
     263        rset := domain rsm2;    assert rset = d2;
     264        sset := domain rsm2;    assert sset = d2;
     265
     266        lset := domain rsm3;    assert lset = d3;
     267        rset := domain rsm3;    assert rset = d3;
     268        sset := domain rsm3;    assert sset = d3;
     269
     270        lset := domain rmm1;    assert lset = d1;
     271        rset := domain rmm1;    assert rset = d1;
     272        sset := domain rmm1;    assert sset = d1;
     273
     274        lset := domain rmm2;    assert lset = d2;
     275        rset := domain rmm2;    assert rset = d2;
     276        sset := domain rmm2;    assert sset = d2;
     277
     278        lset := domain rmm3;    assert lset = d3;
     279        rset := domain rmm3;    assert rset = d3;
     280        sset := domain rmm3;    assert sset = d3;
     281
     282        lset := domain ssm1;    assert lset = d1;
     283        rset := domain ssm1;    assert rset = d1;
     284        sset := domain ssm1;    assert sset = d1;
     285
     286        lset := domain ssm2;    assert lset = d2;
     287        rset := domain ssm2;    assert rset = d2;
     288        sset := domain ssm2;    assert sset = d2;
     289
     290        lset := domain ssm3;    assert lset = d3;
     291        rset := domain ssm3;    assert rset = d3;
     292        sset := domain ssm3;    assert sset = d3;
     293
     294        lset := domain smm1;    assert lset = d1;
     295        rset := domain smm1;    assert rset = d1;
     296        sset := domain smm1;    assert sset = d1;
     297
     298        lset := domain smm2;    assert lset = d2;
     299        rset := domain smm2;    assert rset = d2;
     300        sset := domain smm2;    assert sset = d2;
     301
     302        lset := domain smm3;    assert lset = d3;
     303        rset := domain smm3;    assert rset = d3;
     304        sset := domain smm3;    assert sset = d3;
     305
     306
     307    end procedure based_cases;
     308
     309
     310    procedure range_test;
     311
     312        print_head('range test');
     313
     314
     315        f1 := << (/ x, x**2 /) : x in s >>;
     316        f2 := << (/ x, x**3 /) : x in s >>;
     317        f3 := << (/ x, x**4 /) : x in s >>;
     318
     319        lsm1 := rsm1 := ssm1 := f1;
     320        lsm2 := rsm2 := ssm2 := f2;
     321        lsm3 := rsm3 := ssm3 := f3;
     322
     323        unbased_smap_cases;
     324        based_smap_cases;
     325
     326    assert f2 = lsm2;   assert f2 = rsm2;   assert f2 = ssm2;
     327    assert f3 = lsm3;   assert f3 = rsm3;   assert f3 = ssm3;
     328    assert f1 = lsm1;   assert f1 = rsm1;   assert f1 = ssm1;
     329
     330    assert f1 = << (/ x, x**2 /) : x in s >>;
     331    assert f2 = << (/ x, x**3 /) : x in s >>;
     332    assert f3 = << (/ x, x**4 /) : x in s >>;
     333
     334
     335        f4 := f1 + << (/ x, x /) : x in s >>;
     336        f5 := f2 + << (/ x, x /) : x in s >>;
     337        f6 := f3 + << (/ x, x /) : x in s >>;
     338
     339        lmm1 := rmm1 := smm1 := f4;
     340        lmm2 := rmm2 := smm2 := f5;
     341        lmm3 := rmm3 := smm3 := f6;
     342
     343        unbased_mmap_cases;
     344        based_mmap_cases;
     345
     346    assert f4 = lmm1;   assert f4 = rmm1;   assert f4 = smm1;
     347    assert f5 = lmm2;   assert f5 = rmm2;   assert f5 = smm2;
     348    assert f6 = lmm3;   assert f6 = rmm3;   assert f6 = smm3;
     349
     350    assert f1 = << (/ x, x**2 /) : x in s >>;
     351    assert f2 = << (/ x, x**3 /) : x in s >>;
     352    assert f3 = << (/ x, x**4 /) : x in s >>;
     353
     354    assert f4 = << (/ x, x**2 /) : x in s >>
     355                        + << (/ x, x /) : x in s >>;
     356    assert f5 = << (/ x, x**3 /) : x in s >>
     357                        + << (/ x, x /) : x in s >>;
     358    assert f6 = << (/ x, x**4 /) : x in s >>
     359                        + << (/ x, x /) : x in s >>;
     360
     361        print_tail('range test');
     362
     363
     364    end procedure range_test;
     365
     366
     367    procedure unbased_smap_cases;
     368
     369        s1 := range f1;         assert s1 = r1;
     370        s2 := range f1;         assert s2 = r1;
     371        s3 := range f1;         assert s3 = r1;
     372
     373        s1 := range f2;         assert s1 = r2;
     374        s2 := range f2;         assert s2 = r2;
     375        s3 := range f2;         assert s3 = r2;
     376
     377        s1 := range f3;         assert s1 = r3;
     378        s2 := range f3;         assert s2 = r3;
     379        s3 := range f3;         assert s3 = r3;
     380
     381        s1 := range lsm1;       assert s1 = r1;
     382        s2 := range lsm1;       assert s2 = r1;
     383        s3 := range lsm1;       assert s3 = r1;
     384
     385        s1 := range lsm2;       assert s1 = r2;
     386        s2 := range lsm2;       assert s2 = r2;
     387        s3 := range lsm2;       assert s3 = r2;
     388
     389        s1 := range lsm3;       assert s1 = r3;
     390        s2 := range lsm3;       assert s2 = r3;
     391        s3 := range lsm3;       assert s3 = r3;
     392
     393        s1 := range rsm1;       assert s1 = r1;
     394        s2 := range rsm1;       assert s2 = r1;
     395        s3 := range rsm1;       assert s3 = r1;
     396
     397        s1 := range rsm2;       assert s1 = r2;
     398        s2 := range rsm2;       assert s2 = r2;
     399        s3 := range rsm2;       assert s3 = r2;
     400
     401        s1 := range rsm3;       assert s1 = r3;
     402        s2 := range rsm3;       assert s2 = r3;
     403        s3 := range rsm3;       assert s3 = r3;
     404
     405        s1 := range ssm1;       assert s1 = r1;
     406        s2 := range ssm1;       assert s2 = r1;
     407        s3 := range ssm1;       assert s3 = r1;
     408
     409        s1 := range ssm2;       assert s1 = r2;
     410        s2 := range ssm2;       assert s2 = r2;
     411        s3 := range ssm2;       assert s3 = r2;
     412
     413        s1 := range ssm3;       assert s1 = r3;
     414        s2 := range ssm3;       assert s2 = r3;
     415        s3 := range ssm3;       assert s3 = r3;
     416
     417    end procedure unbased_smap_cases;
     418
     419
     420    procedure based_smap_cases;
     421
     422        lset := range f1;       assert lset = r1;
     423        rset := range f1;       assert rset = r1;
     424        sset := range f1;       assert sset = r1;
     425
     426        lset := range f2;       assert lset = r2;
     427        rset := range f2;       assert rset = r2;
     428        sset := range f2;       assert sset = r2;
     429
     430        lset := range f3;       assert lset = r3;
     431        rset := range f3;       assert rset = r3;
     432        sset := range f3;       assert sset = r3;
     433
     434        lset := range lsm1;     assert lset = r1;
     435        rset := range lsm1;     assert rset = r1;
     436        sset := range lsm1;     assert sset = r1;
     437
     438        lset := range lsm2;     assert lset = r2;
     439        rset := range lsm2;     assert rset = r2;
     440        sset := range lsm2;     assert sset = r2;
     441
     442        lset := range lsm3;     assert lset = r3;
     443        rset := range lsm3;     assert rset = r3;
     444        sset := range lsm3;     assert sset = r3;
     445
     446        lset := range rsm1;     assert lset = r1;
     447        rset := range rsm1;     assert rset = r1;
     448        sset := range rsm1;     assert sset = r1;
     449
     450        lset := range rsm2;     assert lset = r2;
     451        rset := range rsm2;     assert rset = r2;
     452        sset := range rsm2;     assert sset = r2;
     453
     454        lset := range rsm3;     assert lset = r3;
     455        rset := range rsm3;     assert rset = r3;
     456        sset := range rsm3;     assert sset = r3;
     457
     458        lset := range ssm1;     assert lset = r1;
     459        rset := range ssm1;     assert rset = r1;
     460        sset := range ssm1;     assert sset = r1;
     461
     462        lset := range ssm2;     assert lset = r2;
     463        rset := range ssm2;     assert rset = r2;
     464        sset := range ssm2;     assert sset = r2;
     465
     466        lset := range ssm3;     assert lset = r3;
     467        rset := range ssm3;     assert rset = r3;
     468        sset := range ssm3;     assert sset = r3;
     469
     470    end procedure based_smap_cases;
     471
     472
     473    procedure unbased_mmap_cases;
     474
     475        s1 := range f4;         assert s1 = r4;
     476        s2 := range f4;         assert s2 = r4;
     477        s3 := range f4;         assert s3 = r4;
     478
     479        s1 := range f5;         assert s1 = r5;
     480        s2 := range f5;         assert s2 = r5;
     481        s3 := range f5;         assert s3 = r5;
     482
     483        s1 := range f6;         assert s1 = r6;
     484        s2 := range f6;         assert s2 = r6;
     485        s3 := range f6;         assert s3 = r6;
     486
     487        s1 := range lmm1;       assert s1 = r4;
     488        s2 := range lmm1;       assert s2 = r4;
     489        s3 := range lmm1;       assert s3 = r4;
     490
     491        s1 := range lmm2;       assert s1 = r5;
     492        s2 := range lmm2;       assert s2 = r5;
     493        s3 := range lmm2;       assert s3 = r5;
     494
     495        s1 := range lmm3;       assert s1 = r6;
     496        s2 := range lmm3;       assert s2 = r6;
     497        s3 := range lmm3;       assert s3 = r6;
     498
     499        s1 := range rmm1;       assert s1 = r4;
     500        s2 := range rmm1;       assert s2 = r4;
     501        s3 := range rmm1;       assert s3 = r4;
     502
     503        s1 := range rmm2;       assert s1 = r5;
     504        s2 := range rmm2;       assert s2 = r5;
     505        s3 := range rmm2;       assert s3 = r5;
     506
     507        s1 := range rmm3;       assert s1 = r6;
     508        s2 := range rmm3;       assert s2 = r6;
     509        s3 := range rmm3;       assert s3 = r6;
     510
     511        s1 := range smm1;       assert s1 = r4;
     512        s2 := range smm1;       assert s2 = r4;
     513        s3 := range smm1;       assert s3 = r4;
     514
     515        s1 := range smm2;       assert s1 = r5;
     516        s2 := range smm2;       assert s2 = r5;
     517        s3 := range smm2;       assert s3 = r5;
     518
     519        s1 := range smm3;       assert s1 = r6;
     520        s2 := range smm3;       assert s2 = r6;
     521        s3 := range smm3;       assert s3 = r6;
     522
     523    end procedure unbased_mmap_cases;
     524
     525
     526    procedure based_mmap_cases;
     527
     528        lset := range f4;       assert lset = r4;
     529        rset := range f4;       assert rset = r4;
     530        sset := range f4;       assert sset = r4;
     531
     532        lset := range f5;       assert lset = r5;
     533        rset := range f5;       assert rset = r5;
     534        sset := range f5;       assert sset = r5;
     535
     536        lset := range f6;       assert lset = r6;
     537        rset := range f6;       assert rset = r6;
     538        sset := range f6;       assert sset = r6;
     539
     540        lset := range lmm1;     assert lset = r4;
     541        rset := range lmm1;     assert rset = r4;
     542        sset := range lmm1;     assert sset = r4;
     543
     544        lset := range lmm2;     assert lset = r5;
     545        rset := range lmm2;     assert rset = r5;
     546        sset := range lmm2;     assert sset = r5;
     547
     548        lset := range lmm3;     assert lset = r6;
     549        rset := range lmm3;     assert rset = r6;
     550        sset := range lmm3;     assert sset = r6;
     551
     552        lset := range rmm1;     assert lset = r4;
     553        rset := range rmm1;     assert rset = r4;
     554        sset := range rmm1;     assert sset = r4;
     555
     556        lset := range rmm2;     assert lset = r5;
     557        rset := range rmm2;     assert rset = r5;
     558        sset := range rmm2;     assert sset = r5;
     559
     560        lset := range rmm3;     assert lset = r6;
     561        rset := range rmm3;     assert rset = r6;
     562        sset := range rmm3;     assert sset = r6;
     563
     564        lset := range smm1;     assert lset = r4;
     565        rset := range smm1;     assert rset = r4;
     566        sset := range smm1;     assert sset = r4;
     567
     568        lset := range smm2;     assert lset = r5;
     569        rset := range smm2;     assert rset = r5;
     570        sset := range smm2;     assert sset = r5;
     571
     572        lset := range smm3;     assert lset = r6;
     573        rset := range smm3;     assert rset = r6;
     574        sset := range smm3;     assert sset = r6;
     575
     576    end procedure based_mmap_cases;
     577
     578
     579end module test - unary_operators;
       1 .=member strprim
       2      module test - string_primitives;
       3
       4          $ nyu test id
       5          $ authors - s. freudenberger (nyu-cims) (15-dec-78)
       6          $         - j. schwartz (nyu-cims) (16-feb-79)
       7
       8          exports
       9              string_primitive_test,
      10              parse_test;
      11
      12          reads
      13              error_mode,
      14              print_mode;
      15
      16          writes
      17              error_limit;
      18
      19
      20          const
      21              $ constants for proc string_primitive_test
      22              text      = 'hier steh ich nun, ich armer tor.',
      23              alpha     = ' abcdefghijklmnopqrstuvwxyz',
      24              character = ' abcdefghijklmnopqrstuvwxyz,.',
      25
      26              $ constants for proc parse_test
      27              opsigns = '+-*/()_=';   $ operator signs
      28
      29          var
      30              $ variables for string_primitive_test
      31              temp,
      32
      33              $ variables for parse_test
      34              lp,             $ left precedences
      35              rp;             $ right precedences
      36
      37
      38          repr
      39              temp, text, alpha, character:    string;
      40              opsigns:                         string;
      41          end repr;
      42
      43
      44      proc string_primitive_test;
      45
      46
      47      print_head('string primitive test');
      48
      49      temp := text;
      50      assert  break(temp, ',') = 'hier steh ich nun';
      51      assert  temp = ', ich armer tor.';
      52
      53      temp := text;
      54      assert  break(temp, 'h') = '';
      55      assert  temp = text;
      56
      57      temp := text;
      58      assert  break(temp, '$') = om;
      59      assert  temp = text;
      60
      61
      62      temp := text;
      63      assert  span(temp, alpha) = 'hier steh ich nun';
      64      assert  temp = ', ich armer tor.';
      65
      66      temp := text;
      67      assert  span(temp, character) = text;
      68      assert  temp = '';
      69
      70      temp := text;
      71      assert  span(temp, '$') = om;
      72      assert  temp = text;
      73
      74
      75      temp := text;
      76      assert  match(temp, 'hier') = 'hier';
      77      assert  temp = ' steh ich nun, ich armer tor.';
      78
      79      temp := text;
      80      assert  match(temp, text) = text;
      81      assert  temp = '';
      82
      83      temp := 'hier';
      84      assert  match(temp, text) = om;
      85      assert  temp = 'hier';
      86
      87      temp := text;
      88      assert  match(temp, 'hello') = om;
      89      assert  temp = text;
      90
      91      temp := text;
      92      assert  match(temp, 'tor.') = om;
      93      assert  temp = text;
      94
      95
      96      assert  lpad('abc', 10) = '       abc';
      97      assert  lpad(text,   5) = text;
      98
      99
     100      temp := text;
     101      assert  any(temp, alpha) = 'h';
     102      assert  temp = 'ier steh ich nun, ich armer tor.';
     103
     104      temp := text;
     105      assert  any(temp, '$') = om;
     106      assert  temp = text;
     107
     108
     109      temp := text;
     110      assert  notany(temp, ',') = 'h';
     111      assert  temp = 'ier steh ich nun, ich armer tor.';
     112
     113      temp := text;
     114      assert  notany(temp, alpha) = om;
     115      assert  temp = text;
     116
     117
     118      temp := text;
     119      assert  rbreak(temp, ',') = ' ich armer tor.';
     120      assert  temp = 'hier steh ich nun,';
     121
     122      temp := text;
     123      assert  rbreak(temp, '.') = '';
     124      assert  temp = text;
     125
     126      temp := text;
     127      assert  rbreak(temp, '$') = om;
     128      assert  temp = text;
     129
     130
     131      temp := text;
     132      assert  rspan(temp, '.') = '.';
     133      assert  temp = 'hier steh ich nun, ich armer tor';
     134
     135      temp := text;
     136      assert  rspan(temp, character) = text;
     137      assert  temp = '';
     138
     139      temp := text;
     140      assert  rspan(temp, '$') = om;
     141      assert  temp = text;
     142
     143
     144      temp := text;
     145      assert  rmatch(temp, 'tor.') = 'tor.';
     146      assert  temp = 'hier steh ich nun, ich armer ';
     147
     148      temp := text;
     149      assert  rmatch(temp, text) = text;
     150      assert  temp = '';
     151
     152      temp := 'tor.';
     153      assert  rmatch(temp, text) = om;
     154      assert  temp = 'tor.';
     155
     156      temp := text;
     157      assert  rmatch(temp, 'hello') = om;
     158      assert  temp = text;
     159
     160      temp := text;
     161      assert  rmatch(temp, 'hier') = om;
     162      assert  temp = text;
     163
     164
     165      assert  rpad('abc', 10) = 'abc       ';
     166      assert  rpad(text,   5) = text;
     167
     168
     169      temp := text;
     170      assert  rany(temp, '.') = '.';
     171      assert  temp = 'hier steh ich nun, ich armer tor';
     172
     173      temp := text;
     174      assert  rany(temp, '$') = om;
     175      assert  temp = text;
     176
     177
     178      temp := text;
     179      assert  rnotany(temp, alpha) = '.';
     180      assert  temp = 'hier steh ich nun, ich armer tor';
     181
     182      temp := text;
     183      assert  rnotany(temp, '.') = om;
     184      assert  temp = text;
     185
     186
     187      print_tail('string primitive test');
     188
     189
     190      end proc string_primitive_test;
     191
     192
     193      proc parse_test;  $ test of string primitives by parsing
     194
     195          $ nyu test id
     196          $ author - j. schwartz (nyu-cims)
     197          $ logged in as jts13
     198          $ included into ststpl 16-feb-79
     199
     200
     201      $ the operators we allow are +-*/= and assignment (to the right).
     202      $ this will allow us to test using a mini - interpreter.
     203
     204
     205      print_head('parse test');
     206
     207      lp:=(/1, 1, 2, 2, 4, 0, 0, 0/); lp:=<<(/c,lp(i)/):c=opsigns(i)>>;
     208      rp:=(/1, 1, 2, 2,-1, 3, 3, 0/); rp:=<<(/c,rp(i)/):c=opsigns(i)>>;
     209
     210      print (t:=lexscan('a+b*(c*(d+e))'));
     211      print(parse(t));
     212
     213      print(t:=lexscan('a23+b14*(11.1*(d3+105))'));
     214      print(parse(t));
     215
     216      assert  eval('1+2+3+4')=10;
     217      assert  eval('1+2+3+4=10')=1;
     218
     219      assert  eval('1+1_a+a_a+a_a')=8;
     220      assert  eval('(1_a+2_b*0)+(a+b*b)/b+1=4')=1;
     221
     222      print_tail('parse test');
     223
     224      end proc parse_test;
     225
     226
     227      proc lexscan(s); $ lexical scanner using string primitives
     228
     229      sx:=s;   tokens:=nulltup;
     230
     231      (while sx /= nullstring)
     232        if span(sx,' ') /= om then continue;end;
     233
     234        tokens with:= any(sx,opsigns);
     235        tokens with:= span(sx,'abcdefghijklmnopqrstuvwxyz0123456789.');
     236      end while;
     237
     238      return tokens;
     239
     240      end proc lexscan;
     241
     242
     243      proc parse(toks);       $ operator precedence parse
     244
     245      polish  := nulltup;
     246      opstack := (/'('/);
     247      tokss   := toks;
     248      tokss with:= ')';
     249
     250      (forall tok = tokss(i))
     251
     252          if lp(tok)=om then  $ operand
     253              polish with:= tok;
     254
     255          else
     256              (while rp(opstack(card opstack))>=lp(tok))
     257                  opp frome opstack;
     258                  polish with:= opp;
     259              end while;
     260
     261              if tok=')' then
     262                  opp frome opstack; $ should be '('
     263              else
     264                  opstack with:= tok;
     265              end if;
     266          end if;
     267      end forall;
     268
     269      return polish;
     270
     271      end proc parse;
     272
     273      proc eval(stringg);
     274
     275      pol:= $ convert string to polish tuple
     276          parse(lexscan(stringg));
     277
     278      vars   := <>;
     279      consts := <>;
     281
     282      vall:=<<(/c,cval(c)/): c in consts>>;
     283      vstack:=nulltup;  $ storage stack for evaluation
     284
     285      (forall vop = pol(i))
     286          if vop in vars then
     287        vstack with:= (if not ((v:=vall(vop)) = om) then v else 0 end);
     288
     289          else
     290              x frome vstack; y frome vstack;
     291
     292              case vop of
     293
     294                  ('+'):  vstack with:= y+x;
     295                  ('-'):  vstack with:= y-x;
     296
     297                  ('*'):  vstack with:= y*x;
     298                  ('/'):  vstack with:= y div x;
     299
     300                  ('='):  vstack with:= (if x=y then 1 else 0 end);
     301                  ('_'):  vall(pol(i-1)) := y; vstack with:= y;
     302
     303              end case;
     304          end if;
     305      end forall;
     306
     307      assert  card vstack=1;
     308
     309      return vstack(1);
     310
     311      end proc eval;
     312
     313
     314      proc cval(c);       $ evaluates integer constant
     315
     316      n := 0;
     317      (forall j in (/1...card c/))
     318          digits:= 'x0123456789';
     319          n := n * 10 + card break(digits,c(j))-1;
     320      end forall;
     321
     322      return n;
     323
     324      end proc cval;
     325
     326
     327      end module test - string_primitives;
     328
     329
     330
     331
       1 .=member heapsort
       2      module test - heapsort;
       3
       4          $ nyu test id
       5          $ author - d. shields (nyu-cims)
       6
       7          exports
       8              heap_sort_test;
       9
      10          reads
      11              print_mode;
      12
      13          macro swap(a,b);
      14              temp := seq(a); seq(a) := seq(b); seq(b) := temp
      15              endm;
      16
      17          const
      18
      19              $ rand not yet implemented.
      20              $ read(seqlen);
      21              $ testseq := nulltup;
      22              $ (forall i := 1...seqlen)
      23              $     testseq(i) := random(seqlen);
      24              $ end for;
      25
      26              seqlen =  50,
      27
      28              testseq = (/ 01, 78, 56, 23, 17, 88, 05, 85, 65, 43,
      29                          43, 32, 78, 90, 31, 16, 10, 54, 99, 32,
      30                          38, 55, 99, 02, 25, 07, 54, 88, 77, 66,
      31                          55, 44, 57, 78, 83, 06, 16, 12, 18, 92,
      32                          93, 54, 33, 10, 19, 20, 21, 23, 13, 10 /),
      33
      34              nstodo =  10;
      35
      36          var
      37              sortseq,        $ sorted sequence
      38
      39              timeon;
      40
      41          repr
      42              testseq:        tuple(integer 1...100);
      43              sortseq:        tuple(integer 1...100);
      44              timeon:         integer;
      45              seqlen:         integer 1 .. 100;
      46
      47              heap_sort:      procedure(
      48                                  tuple(integer 1 .. 100),
      49                                  integer 1 .. 100,
      50                                  integer 1 .. 100
      51                                  );
      52          end repr;
      53
      54
      55      proc heap_sort_test;
      56
      57      print_head('heap sort test');
      58
      59      timeon := time;
      60
      61      (forall tmp in (/1...nstodo/))
      62          sortseq := heap_sort(testseq, 1, seqlen);
      63      end forall;
      64
      65      if print_mode >= print_full then
      66          print;   print;
      67          print('sorted', seqlen,        'items',
      68                          nstodo,        'times in',
      69                          time - timeon, 'milliseconds.');
      70          print('unsorted sequence =', testseq);
      71          print('sorted sequence =  ', sortseq);
      72      end if;
      73
      74      print_tail('heap sort test');
      75
      76      end proc heap_sort_test;
      77      proc heap_sort(tseq, lo, hi);
      78
      79      $ sort seq(lo...hi) using heapsort
      80
      81      repr
      82          seq, tseq:          tuple(integer 1...100);
      83          m, i, lo, hi, seqtop,
      84          targ, temp:         integer 1...100;
      85      end repr;
      86
      87      seq := tseq;
      88
      89      $ build initial heap; i is parent
      90      (forall i in (/ lo + 1...hi/))
      91
      92          $ promote large children
      93          loop
      94          init
      95              m := i;
      96          while
      97              m > lo and seq(m div 2) < seq(m)
      98          do
      99              swap(m, m div 2);
     100              m := m div 2;
     101          end loop init;
     102      end forall;
     103
     104      $ sort subtrees in turn
     105      (forall seqtop in (/ hi, hi-1...lo+1/))
     106          swap(lo, seqtop);   $ extract largest element
     107
     108          $ force remaining subtree to be heap
     109          loop
     110          init
     111              m := lo;
     112          doing
     113              targ := if (m*2+1) < seqtop and seq(m*2) < seq(m*2+1)
     114                          then m*2+1
     115                          else m*2
     116                      end;
     117          while
     118              m*2 < seqtop and seq(m) < seq(targ)
     119          do
     120              swap(m, targ);  $ child too big, so exchange
     121              m := targ;      $ move to subtree of largest child
     122          end loop init;
     123      end forall;
     124
     125      return seq;
     126
     127      end proc heap_sort;
     128
     129
     130      drop
     131          swap;
     132
     133
     134      end module test - heapsort;
     135
     136
     137
     138
       1 .=member primfac
       2      module test - prime_factorization;
       3
       4          $ nyu test id
       5          $ author - j. schwartz (nyu-cims) 02-jan-79
       6          $ logged in as jts10
       7
       8          exports
       9              prime_factorization_test;
      10
      11          reads
      12              print_mode;
      13
      14
      15      proc prime_factorization_test;
      16
      17      print_head('prime factorization test');
      18
      19      (forall n in (/ 2, 13...100/)) assert n = */facts(n); end;
      20
      21      print_tail('prime factorization test');
      22
      23      end proc prime_factorization_test;
      24
      25
      26      proc facts(n);     $ prime factorisation procedure
      27      nn := n;
      28      k:=2;                   $ lowest prime
      29      factup:= nulltup;       $ tuple of factors
      30
      31      loop while exists k in (/k..nn/) st (nn mod k)=0 until (k*k>nn) do
      32
      33          nn := nn div k;
      34          factup with:= k;
      35
      36      end loop;
      37
      38      if  nn > 1  then  factup with:= nn;  end if;
      39      return factup;
      40      end proc facts;
      41
      42
      43      end module test - prime_factorization;
      44
      45
      46
      47
       1 .=member test5
       2      module test - set_identities;
       3
       4          $ nyu test id
       5          $ author - e. weixelbaum (nyu-cims)
       6          $ logged in as smf04
       7
       8          exports
       9              set_identity_test;
      10
      11          reads
      12              print_mode;
      13
      14
      15      $ author - elia weixelbaum (nyu)
      16      $ program -- test case 5 of setl tests
      17      $
      18      $ 12 set identities are checked on both sets and maps.  in
      19      $ certain identities, the complement of a set is desired.
      20      $ therefore, there is a universe set and the sets are subsets
      21      $ of the universe.  the sets are a, b and c, the universe is u,
      22      $ and the maps are f and g.  a is repred as aloc, arem, aspa
      23      $ which are local, remote, and sparse sets, resp.  similar
      24      $ reprs are used for b, c, u, f and g.  the identities are
      25      $ checked on as many combinations of reprs as is reasonably
      26      $ possible.
      27      $ assert statements are used to verify these identities.
      28      $
      29      $ the identities are as follows:
      30      $
      31      $    0:  x * y subset x + y
      32      $
      33      $    1:  x * y = x + y - (x - y) - (y - x)
      34      $
      35      $    2:  card (x + y) = card x + card y - card (x * y)
      36      $
      37      $    3:  x = (x - y) + (x * y)
      38      $
      39      $    4:  complement(x) + complement(y) = complement(x * y)
      40      $        this is done as:
      41      $        (u - x) + (u - y) = u - (x * y)
      42      $
      43      $    5:  card (u - x) = card u - card x
      44      $
      45      $    6:  card (x + something not in x) = card x + 1
      46      $
      47      $    7:  empty set * x = empty set
      48      $
      49      $    8:  empty set + x = x
      50      $
      51      $    9:  u + x = u
      52      $
      53      $   10:  u * x = x
      54      $
      55      $   11:  x1 + y1 = x2 + y2   where
      56      $        x1 and y1 are sets, x2 and y2 are corresponding tuples,
      57      $        i.e. x1 = x2 and y1 = y2.  also x1 * y1 = <>.
      58      $
      59      $ this last identity checks that set union of 2 disjoint sets
      60      $ is the same as tuple concatenation where the tuples are the
      61      $ two sets written as tuples.
      62
      63
      64      macro ident11 (aset, cset, atpl, ctpl, msg);
      65          assert (forall x in aset + cset st x in atpl + ctpl)
      66            and card (aset + cset) = card (atpl + ctpl)
      67      endm;
      68
      69
      70      var
      71
      72          x,
      73
      74          uloc,
      75          urem,
      76          uspa,
      77
      78          aloc,
      79          arem,
      80          aspa,
      81
      82          bloc,
      83          brem,
      84          bspa,
      85
      86          cloc,
      87          crem,
      88          cspa,
      89
      90          atup,
      91          ctup,
      92
      93          floc,
      94          frem,
      95          fspa,
      96
      97          gloc,
      98          grem,
      99          gspa;
     100
     101
     102      const
     103
     104          u = <<1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20>>,
     105          a = <<1,2,5,7,14,17,19>>,
     106          b = <<3,6,7,11,12,15,16,17,19,20>>,
     107          c = <<20,15,8,3,0>>,
     108
     109          aaa = (/7,17,19,1,5,2,14/),
     110          ccc = (/15,3,0,8,20/),
     111
     112          arba = 17,
     113          arbb = 11,
     114          arbf = (/3,9/),
     115          arbg = (/8,62/),
     116
     117          f = <<(/1,1/),(/2,4/),(/3,9/),(/4,16/),(/5,25/),(/6,36/)>>,
     118          g = <<(/2,7/),(/4,16/),(/5,40/),(/8,62/)>>;
     119
     120
     121      init
     122
     123          uloc := u,
     124          urem := u,
     125          uspa := u;
     126
     127
     128      repr
     129          base intb:         integer;
     130
     131          uloc:               local  set (elmt intb);
     132          urem:               remote set (elmt intb);
     133          uspa:               sparse set (elmt intb);
     134
     135          aloc:               local  set (elmt intb);
     136          arem:               remote set (elmt intb);
     137          aspa:               sparse set (elmt intb);
     138
     139          bloc:               local  set (elmt intb);
     140          brem:               remote set (elmt intb);
     141          bspa:               sparse set (elmt intb);
     142
     143          cloc:               local  set (elmt intb);
     144          crem:               remote set (elmt intb);
     145          cspa:               sparse set (elmt intb);
     146
     147          atup:               tuple (elmt intb);
     148          ctup:               tuple (elmt intb);
     149
     150          floc:               local  smap (elmt intb) integer;
     151          frem:               remote smap (elmt intb) integer;
     152          fspa:               sparse smap (elmt intb) integer;
     153
     154          gloc:               local  smap (elmt intb) integer;
     155          grem:               remote smap (elmt intb) integer;
     156          gspa:               sparse smap (elmt intb) integer;
     157
     158      end repr;
     159
     160
     161      proc set_identity_test;
     162
     163      print_head('test 5  -  set identity test');
     164
     165      $ test1 uses the different reprs of a, b, f and g in testing
     166      $ identities 0 - 4.  test1 is called 4 times:
     167
     168      $     call 1 - all reprs of a, b, f and g are assigned the
     169      $              constants a, b, f and g respectively.
     170
     171      $     call 2 - all reprs of a and f are assigned the
     172      $              constants a and f, resp., and all reprs of b
     173      $              and g are assigned null- or unit sets.
     174
     175      $     call 3 - all reprs of a and f are assigned null- or
     176      $              unit sets, and all reprs of b and g are
     177      $              assigned the constants b and g respectively.
     178
     179      $     call 4 - all reprs of a, b, f and g are assigned null-
     180      $              or unit sets.
     181
     182      $ note:  all reprs of u are used but are always assigned the
     183      $        constant u.
     184
     185      loop
     186          forall
     187                (/   aloc,   arem,   aspa,   bloc,   brem,   bspa,
     188                    floc,   frem,   fspa,   gloc,   grem,   gspa /)
     189          in
     190              (/ (/      a,      a,      a,      b,      b,      b,
     191                       f,      f,      f,      g,      g,      g /),
     192
     193                (/      a,      a,      a,     <>, <>,     <>,
     194                     f,      f,      f, <>,     <>, <> /),
     195
     196                (/     <>, <>, <>,      b,      b,      b,
     197                <>,     <>,     <>,      g,      g,      g /),
     198
     199         (/ <>,     <>,     <>, <>,     <>, <>,
     200                <>, <>, <>,     <>, <>,    <> /)
     201              /)
     202      do
     203
     204          test1;
     205
     206      end loop forall;
     207
     208
     209      $ test2 uses the different reprs of a and f in testing identities
     210      $ 5 - 10.  test2 is called 3 times:
     211
     212      $     call 1 - all reprs of a and f are assigned the constants
     213      $              a and f respectively.
     214
     215      $     call 2 - all reprs of a and f are assigned <>.
     216
     217      $     call 3 - all reprs of a and f are assigned unit sets.
     218
     219      $ note:  all reprs of u are used but are always assigned the
     220      $        constant u.
     221
     222      loop
     223          forall
     224                (/   aloc,  arem,  aspa,  floc,  frem,  fspa /)
     225          in
     226              (/ (/      a,     a,     a,     f,     f,     f /),
     227            (/     <>,    <>,    <>,    <>,    <>,    <> /),
     228            (/ <>,<>,<>,<>,<>,<> /)
     229               /)
     230      do
     231
     232          test2;
     233
     234      end loop forall;
     235
     236      $ test3 calls identity 11 with different combinations of reprs
     237      $ of a, c, a tuple
     238      $ version of a and a tuple version of c.  test3
     239      $ is called 3 times:
     240      $
     241      $     call 1 - all reprs of a and c are assigned the constants
     242      $
     243      $ a and c respectively and atup and ctup are assigned
     244      $              the constant tuples aaa and ccc respectively.
     245      $
     246      $     call 2 - all sets are assigned <> and all tuples are
     247      $              assigned (//).
     248      $
     249      $     call 3 - the a sets and tuple are assigned unit sets and
     250      $
     251      $ unit tuple respectively and the b sets and tuple
     252      $              are assigned <> and (//) respectively.
     253
     254      (forall (/aloc, arem, aspa,
     255                cloc, crem, cspa,
     256                atup, ctup/)
     257
     258          in (/ (/  a,  a,  a,                  c,  c,  c,
     259                                 aaa,  ccc/),
     260
     261                 (/ <>, <>, <>,                 <>, <>, <>,
     262                                 (//), (//)/),
     263
     264                 (/<>,<>,<>,    <>,<>,<>,
     265                          (/arba/), (//)/)/))
     266
     267
     268          test3;
     269
     270      end forall;
     271
     272      print_tail('test 5  -  set identity test');
     273
     274
     275      end proc set_identity_test;
     276      proc test1;
     277
     278      assert  aloc * bloc  subset  aloc + bloc;
     279      assert  aloc * brem  subset  aloc + brem;
     280      assert  aloc * bspa  subset  aloc + bspa;
     281      assert  arem * bloc  subset  arem + bloc;
     282      assert  arem * brem  subset  arem + brem;
     283      assert  arem * bspa  subset  arem + bspa;
     284      assert  aspa * bloc  subset  aspa + bloc;
     285      assert  aspa * brem  subset  aspa + brem;
     286      assert  aspa * bspa  subset  aspa + bspa;
     287
     288      assert  floc * gloc  subset  floc + gloc;
     289      assert  floc * grem  subset  floc + grem;
     290      assert  floc * gspa  subset  floc + gspa;
     291      assert  frem * gloc  subset  frem + gloc;
     292      assert  frem * grem  subset  frem + grem;
     293      assert  frem * gspa  subset  frem + gspa;
     294      assert  fspa * gloc  subset  fspa + gloc;
     295      assert  fspa * grem  subset  fspa + grem;
     296      assert  fspa * gspa  subset  fspa + gspa;
     297
     298
     299      assert  aloc * bloc = aloc + bloc - (aloc - bloc) - (bloc - aloc);
     300      assert  aloc * brem = aloc + brem - (aloc - brem) - (brem - aloc);
     301      assert  aloc * bspa = aloc + bspa - (aloc - bspa) - (bspa - aloc);
     302      assert  arem * bloc = arem + bloc - (arem - bloc) - (bloc - arem);
     303      assert  arem * brem = arem + brem - (arem - brem) - (brem - arem);
     304      assert  arem * bspa = arem + bspa - (arem - bspa) - (bspa - arem);
     305      assert  aspa * bloc = aspa + bloc - (aspa - bloc) - (bloc - aspa);
     306      assert  aspa * brem = aspa + brem - (aspa - brem) - (brem - aspa);
     307      assert  aspa * bspa = aspa + bspa - (aspa - bspa) - (bspa - aspa);
     308
     309      assert  floc * gloc = floc + gloc - (floc - gloc) - (gloc - floc);
     310      assert  floc * grem = floc + grem - (floc - grem) - (grem - floc);
     311      assert  floc * gspa = floc + gspa - (floc - gspa) - (gspa - floc);
     312      assert  frem * gloc = frem + gloc - (frem - gloc) - (gloc - frem);
     313      assert  frem * grem = frem + grem - (frem - grem) - (grem - frem);
     314      assert  frem * gspa = frem + gspa - (frem - gspa) - (gspa - frem);
     315      assert  fspa * gloc = fspa + gloc - (fspa - gloc) - (gloc - fspa);
     316      assert  fspa * grem = fspa + grem - (fspa - grem) - (grem - fspa);
     317      assert  fspa * gspa = fspa + gspa - (fspa - gspa) - (gspa - fspa);
     318
     319
     320      assert  card(aloc+bloc) = card aloc + card bloc - card(aloc*bloc);
     321      assert  card(aloc+brem) = card aloc + card brem - card(aloc*brem);
     322      assert  card(aloc+bspa) = card aloc + card bspa - card(aloc*bspa);
     323      assert  card(arem+bloc) = card arem + card bloc - card(arem*bloc);
     324      assert  card(arem+brem) = card arem + card brem - card(arem*brem);
     325      assert  card(arem+bspa) = card arem + card bspa - card(arem*bspa);
     326      assert  card(aspa+bloc) = card aspa + card bloc - card(aspa*bloc);
     327      assert  card(aspa+brem) = card aspa + card brem - card(aspa*brem);
     328      assert  card(aspa+bspa) = card aspa + card bspa - card(aspa*bspa);
     329
     330      assert  card(floc+gloc) = card floc + card gloc - card(floc*gloc);
     331      assert  card(floc+grem) = card floc + card grem - card(floc*grem);
     332      assert  card(floc+gspa) = card floc + card gspa - card(floc*gspa);
     333      assert  card(frem+gloc) = card frem + card gloc - card(frem*gloc);
     334      assert  card(frem+grem) = card frem + card grem - card(frem*grem);
     335      assert  card(frem+gspa) = card frem + card gspa - card(frem*gspa);
     336      assert  card(fspa+gloc) = card fspa + card gloc - card(fspa*gloc);
     337      assert  card(fspa+grem) = card fspa + card grem - card(fspa*grem);
     338      assert  card(fspa+gspa) = card fspa + card gspa - card(fspa*gspa);
     339
     340
     341      assert  aloc  =  (aloc - bloc)  +  (aloc * bloc);
     342      assert  aloc  =  (aloc - brem)  +  (aloc * brem);
     343      assert  aloc  =  (aloc - bspa)  +  (aloc * bspa);
     344      assert  arem  =  (arem - bloc)  +  (arem * bloc);
     345      assert  arem  =  (arem - brem)  +  (arem * brem);
     346      assert  arem  =  (arem - bspa)  +  (arem * bspa);
     347      assert  aspa  =  (aspa - bloc)  +  (aspa * bloc);
     348      assert  aspa  =  (aspa - brem)  +  (aspa * brem);
     349      assert  aspa  =  (aspa - bspa)  +  (aspa * bspa);
     350
     351      assert  floc  =  (floc - gloc)  +  (floc * gloc);
     352      assert  floc  =  (floc - grem)  +  (floc * grem);
     353      assert  floc  =  (floc - gspa)  +  (floc * gspa);
     354      assert  frem  =  (frem - gloc)  +  (frem * gloc);
     355      assert  frem  =  (frem - grem)  +  (frem * grem);
     356      assert  frem  =  (frem - gspa)  +  (frem * gspa);
     357      assert  fspa  =  (fspa - gloc)  +  (fspa * gloc);
     358      assert  fspa  =  (fspa - grem)  +  (fspa * grem);
     359      assert  fspa  =  (fspa - gspa)  +  (fspa * gspa);
     360
     361
     362      assert  (uloc - aloc)  +  (uloc - bloc) = uloc  -  (aloc * bloc);
     363      assert  (urem - arem)  +  (urem - brem) = urem  -  (arem * brem);
     364      assert  (uspa - aspa)  +  (uspa - bspa) = uspa  -  (aspa * bspa);
     365      assert  (uspa - aloc)  +  (uspa - brem) = uspa  -  (aloc * brem);
     366
     367      end proc test1;
     368      proc test2;
     369
     370
     371
     372      assert  card (uloc - aloc)  =  card uloc - card aloc;
     373      assert  card (uloc - arem)  =  card uloc - card arem;
     374      assert  card (uloc - aspa)  =  card uloc - card aspa;
     375      assert  card (urem - aloc)  =  card urem - card aloc;
     376      assert  card (urem - arem)  =  card urem - card arem;
     377      assert  card (urem - aspa)  =  card urem - card aspa;
     378      assert  card (uspa - aloc)  =  card uspa - card aloc;
     379      assert  card (uspa - arem)  =  card uspa - card arem;
     380      assert  card (uspa - aspa)  =  card uspa - card aspa;
     381
     382
     383      assert  card (aloc + << arb (uloc - aloc) >> ) = card aloc + 1;
     384      assert  card (aloc + << arb (urem - aloc) >> ) = card aloc + 1;
     385      assert  card (aloc + << arb (uspa - aloc) >> ) = card aloc + 1;
     386      assert  card (arem + << arb (uloc - arem) >> ) = card arem + 1;
     387      assert  card (arem + << arb (urem - arem) >> ) = card arem + 1;
     388      assert  card (arem + << arb (uspa - arem) >> ) = card arem + 1;
     389      assert  card (aspa + << arb (uloc - aspa) >> ) = card aspa + 1;
     390      assert  card (aspa + << arb (urem - aspa) >> ) = card aspa + 1;
     391      assert  card (aspa + << arb (uspa - aspa) >> ) = card aspa + 1;
     392
     393
     394      assert  nullset * aloc  =  nullset;
     395      assert  nullset * arem  =  nullset;
     396      assert  nullset * aspa  =  nullset;
     397
     398      assert  aloc * nullset  =  nullset;
     399      assert  arem * nullset  =  nullset;
     400      assert  aspa * nullset  =  nullset;
     401
     402      assert  nullset * floc  =  nullset;
     403      assert  nullset * frem  =  nullset;
     404      assert  nullset * fspa  =  nullset;
     405
     406      assert  floc * nullset  =  nullset;
     407      assert  frem * nullset  =  nullset;
     408      assert  fspa * nullset  =  nullset;
     409
     410
     411      assert  nullset + aloc  =  aloc;
     412      assert  nullset + arem  =  arem;
     413      assert  nullset + aspa  =  aspa;
     414
     415      assert  aloc + nullset  =  aloc;
     416      assert  arem + nullset  =  arem;
     417      assert  aspa + nullset  =  aspa;
     418
     419      assert  nullset + floc  =  floc;
     420      assert  nullset + frem  =  frem;
     421      assert  nullset + fspa  =  fspa;
     422
     423      assert  floc + nullset  =  floc;
     424      assert  frem + nullset  =  frem;
     425      assert  fspa + nullset  =  fspa;
     426
     427
     428      assert  uloc + aloc  =  uloc;
     429      assert  uloc + arem  =  uloc;
     430      assert  uloc + aspa  =  uloc;
     431      assert  urem + aloc  =  urem;
     432      assert  urem + arem  =  urem;
     433      assert  urem + aspa  =  urem;
     434      assert  uspa + aloc  =  uspa;
     435      assert  uspa + arem  =  uspa;
     436      assert  uspa + aspa  =  uspa;
     437
     438      assert  aloc + uloc  =  uloc;
     439      assert  arem + uloc  =  uloc;
     440      assert  aspa + uloc  =  uloc;
     441      assert  aloc + urem  =  urem;
     442      assert  arem + urem  =  urem;
     443      assert  aspa + urem  =  urem;
     444      assert  aloc + uspa  =  uspa;
     445      assert  arem + uspa  =  uspa;
     446      assert  aspa + uspa  =  uspa;
     447
     448
     449      assert  aloc * uloc  =  aloc;
     450      assert  aloc * urem  =  aloc;
     451      assert  aloc * uspa  =  aloc;
     452      assert  arem * uloc  =  arem;
     453      assert  arem * urem  =  arem;
     454      assert  arem * uspa  =  arem;
     455      assert  aspa * uloc  =  aspa;
     456      assert  aspa * urem  =  aspa;
     457      assert  aspa * uspa  =  aspa;
     458
     459      assert  uloc * aloc  =  aloc;
     460      assert  urem * aloc  =  aloc;
     461      assert  uspa * aloc  =  aloc;
     462      assert  uloc * arem  =  arem;
     463      assert  urem * arem  =  arem;
     464      assert  uspa * arem  =  arem;
     465      assert  uloc * aspa  =  aspa;
     466      assert  urem * aspa  =  aspa;
     467      assert  uspa * aspa  =  aspa;
     468
     469      end proc test2;
     470      proc test3;
     471
     472
     473
     474      ident11(aloc, cloc, atup, ctup, 'local sets            ');
     475      ident11(arem, crem, atup, ctup, 'remote sets           ');
     476      ident11(aspa, cspa, atup, ctup, 'sparse sets           ');
     477      ident11(aloc, crem, atup, ctup, 'local and remote sets ');
     478      ident11(aloc, cspa, atup, ctup, 'local and sparse sets ');
     479      ident11(arem, cspa, atup, ctup, 'remote and sparse sets');
     480
     481      end proc test3;
     482
     483
     484      drop
     485          ident11;
     486
     487
     488      end module test - set_identities;
     489
     490
     491
       1 .=member test6
       2      module test - union_2;
       3
       4          $ nyu test id
       5          $ author - c. goss (nyu-cims)
       6
       7          exports
       8              union_test_2;
       9
      10          reads
      11              print_mode;
      12
      13
      14$ this test consists of a set of 'bag' manipulation routines which
      15$ bags as represented by both tuples and maps. (conceptually,
      16$ a 'bag' is a set which allows duplicate members.) with each pair
      17$ of test bags we perform union, intersection, and difference
      18$ operations for each representation and ensure that the results
      19$ are identical.
      20
      21
      22      const
      23          test_tup1 = << (/01, (/'a', 'b', 'c'/)/),
      24                         (/02, (/  1,   2,   3/)/),
      25                         (/03, (/1.0, 2.0, 3.0/)/) >>,
      26
      27          test_tup2 = << (/01, (/'a', 'd', 'e'/)/),
      28                        (/02, (/  2,   5,   6,   7,   8,   1,   576/)/),
      29                     (/03, (/2.0, 5.0, 6.0, 7.0, 8.0, 1.0, 576.0/)/) >>;
      30
      31      var
      32          failnum;            $ number of unsuccessful tests
      33
      34      init
      35          failnum := 0;
      36
      37
      38      procedure union_test_2;
      39
      40      print_head('test 6  -  bag manipulation test');
      41
      42      loop
      43        init
      44          i:=1;
      45          print;
      46          print('test program 6    clint goss');
      47        doing                 $ simulate the reading of input
      48          tup1 := test_tup1(i);
      49          tup2 := test_tup2(i);
      50        while
      51          test_tup1(i) /= om  $ <===> not eof
      52        step
      53          i := i + 1;
      54        term                  $ print final statistics about test 6
      55          print;
      56          print(i-1, 'pairs of bags tested.');
      57          if failnum /= 0 then
      58              print(failnum, 'test(s) failed.');
      59          else
      60              print('all tests passed.');
      61          end if;
      62      do
      63          formmaps;           $ form maps for each tuple bag
      64          echodata;           $ echo data depending on print mode
      65          applytsests;        $ finally, perform tests
      66
      67      end loop;
      68
      69
      70      print_tail('test 6  -  bag manipulation test');
      71
      72formmaps::
      73                              $ maps corresponding to the tuples.
      74
      75      if print_mode = print_debug then
      76          print;
      77          print('forming maps');
      78      end if;
      79
      80      t  := tup1;             $ start with first tuple
      81      m  := nullset;          $ initialize map bag to empty.
      82      jj := 1;
      83
      84setmap:
      85      loop
      86          forall j in (/ 1...card t /)
      87      do
      88          if t(j) in domain m then
      89                              $ replace the old pair by a new pair
      90                              $ with an incremented image.
      91              v := m(t(j));
      92              m less:= (/t(j), v/);
      93              m with:= (/t(j), v+1/);
      94
      95          else                $ add new pair with image = 1.
      96              m with:= (/t(j), 1/);
      97          end if;
      98      end loop forall j;
      99
     100      if jj = 1 then
     101          map1 := m;
     102
     103          m := nullset;
     104          t := tup2;
     105          jj := 2;
     106          goto setmap;
     107
     108      else
     109          map2 := m;
     110      end if;
     111
     112echodata::
     113
     114      if print_mode = print_debug then
     115          print;
     116          print('test', i);
     117          print('tuple 1 =', tup1);
     118          print('tuple 2 =', tup2);
     119          print('map 1 =  ', map1);
     120          print('map 2 =  ', map2);
     121      end if;
     122
     123applytsests::                 $ here we test the tuple results of
     124                              $ the tuple bag operations are
     125                              $ identical to the map results of the
     126                              $ map bag operations.
     127
     128      eqtest(tup1 .ti tup2, map1 .mi map2, 'intersection');
     129      eqtest(tup1 .tu tup2, map1 .mu map2, 'union'       );
     130      eqtest(tup1 .td tup2, map1 .md map2, 'difference'  );
     131
     132      end procedure union_test_2;
     133
     134
     135      procedure eqtest(tup, mapp, msg);
     136      $
     137      $ this routine tests for equality between a tuple bag and
     138      $ a map bag.
     139      $
     140      if print_mode >= print_full then
     141          print;   print;
     142          print('testing equlity after', msg);
     143          print;
     144      end if;
     145
     146      m := mapp;              $ start with the full map
     147      loop
     148          forall i in (/ 1...card tup /)
     149      do
     150          assert tup(i) in domain m;
     151          v := m(tup(i));     $ decrement image of tuple element in map
     152          m with:= (/tup(i), v-1/);
     153          m less:= (/tup(i), v/);
     154      end loop forall i;
     155      $
     156      $ ensure final map has the singleton range <<0>>.
     157      $
     158      (forall i in domain m) assert m(i) = 0; end forall;
     159
     160      end procedure eqtest;
     161
     162
     163      op .ti(a, b);           $ tuple bag intersection
     164
     165      if print_mode = print_debug then
     166          print;
     167          print('ti.01: a =     ', a);
     168          print('ti.02: b =     ', b);
     169          print('ti.03: result =', (/x in a st x in b/));
     170      end if;
     171
     172      return (/x in a st x in b/);
     173
     174      end op .ti;
     175
     176
     177      op .tu(a, b);           $ tuple bag union
     178
     179      if print_mode = print_debug then
     180          print;
     181          print('tu.01: a =     ', a);
     182          print('tu.02: b =     ', b);
     183          print('tu.03: result =', a + b);
     184      end if;
     185
     186      return  a + b;
     187
     188      end op .tu;
     189
     190
     191      op .td(a, b);           $ tuple bag difference
     192
     193      if print_mode = print_debug then
     194          print;
     195          print('td.01: a =     ', a);
     196          print('td.02: b =     ', b);
     197          print('td.03: result =', (/x in a st x notin b/));
     198      end if;
     199
     200      return (/x in a st x notin b/);
     201
     202      end op .td;
     203
     204
     205      op .mi(a, b);           $ map bag intersection
     206
     207          r := nullset;
     208      loop
     209          forall elem in domain a st elem in domain b
     210      do
     211          if a(elem) > b(elem) then
     212              r with:= (/elem, b(elem)/);
     213          else
     214              r with:= (/elem, a(elem)/);
     215          end if;
     216      end loop;
     217      if print_mode = print_debug then
     218          print;
     219          print('mi.01: a =     ', a);
     220          print('mi.02: b =     ', b);
     221          print('mi.03: result =', r);
     222      end if;
     223
     224      return r;
     225
     226      end op .mi;
     227
     228
     229      op .mu(a, b);           $ map bag union
     230
     231          r := a + b;
     232      loop
     233          forall elem in (domain a) * (domain b)
     234      do
     235          r less:= (/elem, a(elem)/);
     236          r less:= (/elem, b(elem)/);
     237          r with:= (/elem, a(elem)+b(elem)/);
     238      end loop;
     239      if print_mode = print_debug then
     240          print;
     241          print('mu.01: a =     ', a);
     242          print('mu.02: b =     ', b);
     243          print('mu.03: result =', r);
     244      end if;
     245
     246      return r;
     247
     248      end op .mu;
     249
     250
     251      op .md(a, b);           $ map bag difference
     252
     253          r := a;
     254      loop
     255          forall x in (domain a) * (domain b)
     256      do
     257          r less:= (/x, a(x)/);
     258          if a(x) > b(x) then r with:= (/x, a(x) - b(x)/); end;
     259      end loop;
     260      if print_mode = print_debug then
     261          print;
     262          print('md.01: a =     ', a);
     263          print('md.02: b =     ', b);
     264          print('md.03: result =', r);
     265      end if;
     266
     267      return r;
     268
     269      end op .md;
     270
     271
     272      end module test - union_2;
     273
     274
     275
     276
       1 .=member test8
       2      module test - power_set;
       3
       4          $ nyu test id
       5          $ author - h. lewis (nyu-cims)
       6          $ logged in as jts10
       7          $ submitted as file ds01 (22 jan 79)
       8
       9          exports
      10              power_set_test;
      11
      12          reads
      13              print_mode;
      14
      15
      16 $             test routine for pow and npow operators
      17 $
      18 $                          henry m. lewis
      19 $
      20 $ this program exercises the built-in setl operators  pow s  and
      21 $ n npow s , verifying thier results by comparison with those
      22 $ of a program function  powr(s) , by verifying cardinalities,
      23 $ and by application of the following identities for various small
      24 $ sets of integers:
      25
      26 $    pow (set + << singleton >> ) =
      27 $        (pow set) + << y with singleton : y elmt pow set >>
      28
      29 $    pow (s + t) = << y + z : y elmt pow s, z elmt pow t >>
      30
      31 $    n npow (set + << singleton >> ) =
      32 $        (n npow set) + << y with singleton :
      33 $        y elmt (n - 1) npow set >>      $ n >= 1
      34
      35 $    n npow (s + t) =
      36 $        << y + z :
      37 $        nn:=0...n, y elmt nn npow s, z elmt (n-nn) npow t >>
      38
      39 $ the size of the sets tested and their contents may be altered by
      40 $ adjustment to the macros  'inititems' ,  'newitem' ,
      41 $ 'singl_iterator' , and 'sets_iterator' .
      42
      43
      44      var  $ globals for messages.
      45          recursion_,
      46          singl_identity,
      47          set_identity,
      48          n_recursion,
      49          n_single_identity,
      50          n_set_identity;
      51
      52      macro newitem;
      53          (item +:= 1)  endm;
      54      macro singl_iterator;
      55          (/1...lim1/)              endm;
      56
      57      macro sets_iterator;
      58          (/1...lim2/)              endm;
      59
      60
      61
      62 $ variable declarations
      63
      64      var
      65          test_status, $ set to 'fail if one or more tests fail
      66
      67          n, nn,       $ cardinality for npow tests
      68
      69          x,           $ singleton
      70
      71 $ set arguments for pow and npow tests
      72
      73          slocal,  tlocal,
      74          sremote, tremote,
      75          ssparse, tsparse,
      76
      77 $ power sets
      78
      79          spowlocal,  tpowlocal,
      80          spowremote, tpowremote,
      81          spowsparse, tpowsparse,
      82
      83 $ elements of a power set
      84
      85          ylocal,  zlocal,
      86          yremote, zremote,
      87          ysparse, zsparse;
      88
      89
      90      repr
      91          base items:   *;
      92
      93          base sets      : set( elmt items );
      94
      95          x                : elmt items;
      96
      97          slocal,  tlocal  : local  set( elmt items );
      98          sremote, tremote : remote set( elmt items );
      99          ssparse, tsparse : sparse set( elmt items );
     100
     101          spowlocal,  tpowlocal  : local  set( elmt sets );
     102          spowremote, tpowremote : remote set( elmt sets );
     103          spowsparse, tpowsparse : sparse set( elmt sets );
     104
     105          ylocal,  zlocal  : local  set( elmt items );
     106          yremote, zremote : remote set( elmt items );
     107          ysparse, zsparse : sparse set( elmt items );
     108
     109          n                : integer;
     110      end repr;
     111
     112
     113      proc power_set_test;
     114
     115      print_head('test 8  -  power set test');
     116
     117      item := 0;
     118
     119      lim1 := 3;  lim2 := 3;
     120      recursion_ :=
     121          'pow s = powr(s)    $ powr is a program function ';
     122
     123      singl_identity :=
     124          'pow (set + << singleton >> ) = (pow set)  '
     125              ' << y with singleton : y in pow set >>';
     126
     127      set_identity :=
     128          'pow (s + t) = << y + z : y in pow s, z in pow t >>';
     129
     130      n_recursion :=
     131          'n npow s = << x in powr(s) st card s = n >> '
     132              '   $ powr is a program function ';
     133      n_singl_identity :=
     134          'n npow (set + << singleton >> ) '
     135              '= (n npow set)  + << y with singleton '
     136              ': y in (n - 1) npow set >>';
     137
     138      n_set_identity :=
     139          'n npow (s + t) '
     140          '= << y + z : nn:=0...n, y in nn npow s, '
     141          'z in (n - nn) npow t >>';
     142
     143      item := 0;
     144
     145      slocal := sremote := ssparse := << >>;
     146
     147      loop forall i in singl_iterator
     148      do
     149
     150          spowlocal  := pow slocal;
     151          spowremote := pow sremote;
     152          spowsparse := pow ssparse;
     153
     154          tpowlocal  := powr(slocal);
     155          tpowremote := powr(sremote);
     156          tpowsparse := powr(ssparse);
     157
     158 $ verify the identity  card pow s = 2**card s
     159
     160          assert card spowlocal  = 2 ** (card slocal);
     161          assert card spowremote = 2 ** (card sremote);
     162          assert card spowsparse = 2 ** (card ssparse);
     163
     164 $ compare the result of  pow s  with that of  powr(s)
     165
     166          rec_test;
     167
     168          (forall n in (/0...2**i/))     $ test power sets of all sizes
     169
     170              spowlocal  := n npow slocal;
     171              spowremote := n npow sremote;
     172              spowsparse := n npow ssparse;
     173
     174 $ verify the identity  n npow s = << x in powr(s) st card x = n >>
     175
     176              n_rec_test;
     177
     178          end forall n;
     179
     180          x := newitem;
     181
     182 $ verify the identity:
     183
     184 $    pow (set + << singleton >> ) =
     185 $        (pow set) + << y with singleton : y in pow set >>
     186
     187          singl_ident_test;
     188
     189          (forall n in (/0...2**i/))     $ test power sets of all sizes
     190
     191 $ verify the identity:
     192
     193 $    n npow (set + << singleton >> )
     194 $        = <>
     196
     197              n_singl_ident_test;
     198
     199          end forall n;
     200
     201          slocal  with:= newitem;
     202          sremote with:= newitem;
     203          ssparse with:= newitem;
     204
     205      end loop forall i;
     206
     207      tpowlocal  := powr(slocal);
     208      tpowremote := powr(sremote);
     209      tpowsparse := powr(ssparse);
     210
     211      tlocal := tremote := tsparse := << >>;
     212      slocal := sremote := ssparse := << >>;
     213
     214      loop forall i in sets_iterator
     215      do
     216          loop forall tmp in (/ 1... if i=1 then 1 else 2 end /)
     217          do
     218
     219 $ verify the identity:
     220
     221 $    pow (s + t) = << y + z : y in pow s, z in pow t >>
     222
     223              set_ident_test;
     224
     225              (forall n in (/0...2**i/))  $ test power sets of all sizes
     226
     227 $ verify the identity:
     228
     229 $    n npow (s + t) =
     230 $        << y + z : nn:=0...n, y in nn npow s,
     231 $             z in (n-nn) npow t >>
     232
     233                  n_set_ident_test;
     234
     235              end forall n;
     236              tlocal  from tpowlocal;
     237              tremote from tpowremote;
     238              tsparse from tpowsparse;
     239
     240          end loop forall tmp;
     241          slocal  with:= newitem;
     242          sremote with:= newitem;
     243          ssparse with:= newitem;
     244
     245      end loop forall i;
     246
     247      if test_status /= 'fail'      $ so set by cardtest or eqtest
     248      then
     249          print;
     250          print_line('all tests passed');
     251      end if;
     252
     253      print_tail('test 8  -  power set test');
     254
     255      end proc power_set_test;
     256
     257
     258      proc powr(s);
     259
     260      if s = << >>
     261      then
     262          return << << >> >>;
     263      else
     264          singleton := arb s;
     265          return powr(s - << singleton >> ) + << subset_ with singleton
     266              : subset_ in powr(s - << singleton >> ) >>;
     267      end if;
     268
     269      end proc powr;
     270
     271
     272      proc rec_test;
     273
     274      eqtest(
     275          spowlocal,
     276          tpowlocal,
     277          slocal,
     278          om,
     279          recursion_,
     280          's',
     281          om,
     282          'local',
     283          om);
     284      eqtest(
     285          spowremote,
     286          tpowremote,
     287          sremote,
     288          om,
     289          recursion_,
     290          's',
     291          om,
     292          'remote',
     293          om);
     294      eqtest(
     295          spowsparse,
     296          tpowsparse,
     297          ssparse,
     298          om,
     299          recursion_,
     300          's',
     301          om,
     302          'sparse',
     303          om);
     304
     305      end proc rec_test;
     306
     307      proc n_rec_test;
     308
     309      eqtest(
     310          spowlocal,
     311          << ylocal in tpowlocal st card ylocal = n >>,
     312          slocal,
     313          om,
     314          n_recursion,
     315          's',
     316          om,
     317          'local',
     318          n);
     319      eqtest(
     320          spowremote,
     321          << yremote in tpowremote st card yremote = n >>,
     322          sremote,
     323          om,
     324          n_recursion,
     325          's',
     326          om,
     327          'remote',
     328          n);
     329      eqtest(
     330          spowsparse,
     331          << ysparse in tpowsparse st card ysparse = n >>,
     332          ssparse,
     333          om,
     334          n_recursion,
     335          's',
     336          om,
     337          'sparse',
     338          n);
     339
     340      end proc n_rec_test;
     341
     342      proc singl_ident_test;
     343
     344      eqtest(
     345          pow (slocal + << x >> ),
     346          (pow slocal) + << ylocal with x
     347              : ylocal in pow slocal >>,
     348          slocal,
     349          x,
     350          singl_identity,
     351          'set',
     352          'singleton',
     353          'local',
     354          om);
     355      eqtest(
     356          pow (sremote + << x >> ),
     357          (pow sremote) + << yremote with x
     358              : yremote in pow sremote >>,
     359          sremote,
     360          x,
     361          singl_identity,
     362          'set',
     363          'singleton',
     364          'remote',
     365          om);
     366      eqtest(
     367          pow (ssparse + << x >> ),
     368          (pow ssparse) + << ysparse with x
     369              : ysparse in pow ssparse >>,
     370          ssparse,
     371          x,
     372          singl_identity,
     373          'set',
     374          'singleton',
     375          'sparse',
     376          om);
     377
     378      end proc singl_ident_test;
     379
     380      proc n_singl_ident_test;
     381
     382      eqtest(
     383          n npow (slocal + << x >> ),
     384          (n npow slocal) + if n<=0 then << >> else << ylocal
     385              with x : ylocal in (n - 1) npow slocal >> end,
     386          slocal,
     387          x,
     388          n_singl_identity,
     389          'set',
     390          'singleton',
     391          'local',
     392          n);
     393      eqtest(
     394          n npow (sremote + << x >> ),
     395          (n npow sremote) + if n<=0 then << >> else << yremote
     396              with x : yremote in (n - 1) npow sremote >> end,
     397          sremote,
     398          x,
     399          n_singl_identity,
     400          'set',
     401          'singleton',
     402          'remote',
     403          n);
     404      eqtest(
     405          n npow (ssparse + << x >> ),
     406          (n npow ssparse) + if n<=0 then << >> else << ysparse
     407              with x : ysparse in (n - 1) npow ssparse >> end,
     408          ssparse,
     409          x,
     410          n_singl_identity,
     411          'set',
     412          'singleton',
     413          'sparse',
     414          n);
     415
     416      end proc n_singl_ident_test;
     417
     418      proc set_ident_test;
     419
     420      eqtest(
     421          pow (slocal + tlocal),
     422          << ylocal + zlocal
     423              : ylocal in pow slocal, zlocal in pow tlocal >>,
     424          slocal,
     425          tlocal,
     426          set_identity,
     427          's',
     428          't',
     429          'local',
     430          om);
     431      eqtest(
     432          pow (sremote + tremote),
     433          << yremote + zremote
     434              : yremote in pow sremote, zremote in pow tremote >>,
     435          sremote,
     436          tremote,
     437          set_identity,
     438          's',
     439          't',
     440          'remote',
     441          om);
     442      eqtest(
     443          pow (ssparse + tsparse),
     444          << ysparse + zsparse
     445              : ysparse in pow ssparse, zsparse in pow tsparse >>,
     446          ssparse,
     447          tsparse,
     448          set_identity,
     449          's',
     450          't',
     451          'sparse',
     452          om);
     453
     454      end proc set_ident_test;
     455
     456      proc n_set_ident_test;
     457
     458      eqtest(
     459          n npow (slocal + tlocal),
     460          << ylocal + zlocal : nn in (/0...n/),
     461              ylocal in nn npow slocal,
     462              zlocal in (n - nn) npow tlocal >>,
     463          slocal,
     464          tlocal,
     465          n_set_identity,
     466          's',
     467          't',
     468          'local',
     469          n);
     470      eqtest(
     471          n npow (sremote + tremote),
     472          << yremote + zremote : nn in (/0...n/),
     473              yremote in nn npow sremote,
     474              zremote in (n - nn) npow tremote >>,
     475          sremote,
     476          tremote,
     477          n_set_identity,
     478          's',
     479          't',
     480          'remote',
     481          n);
     482      eqtest(
     483          n npow (ssparse + tsparse),
     484          << ysparse + zsparse : nn in (/0...n/),
     485              ysparse in nn npow ssparse,
     486              zsparse in (n - nn) npow tsparse >>,
     487          ssparse,
     488          tsparse,
     489          n_set_identity,
     490          's',
     491          't',
     492          'sparse',
     493          n);
     494
     495      end proc n_set_ident_test;
     496
     497      proc eqtest(pow1,pow2,s1,s2,test_,nams1,nams2,base_,npowsize);
     498
     499      if print_mode = print_debug then
     500          print;   print;
     501          print('test the identity', test_,
     502                'using', base_, 'data representation.');
     503          print('    ',nams1,' = ',s1);
     504          if s2 /= om then print('    ', nams2, '=', s2); end if;
     505          if npowsize /= om then print('     n = ', npowsize); end if;
     506          print('     lhs identity  = ',pow1);
     507          print('     rhs identity  = ',pow2);
     508      end if;
     509
     510      assert  pow1 = pow2;
     511
     512      end proc eqtest;
     513
     514
     515      drop
     516          newitem,
     517          singl_iterator,
     518          sets_iterator;
     519
     520
     521      end module test - power_set;
     522
     523
     524
     525
       1 .=member test9
       2    module test - map_identities;
       3
       4        $ nyu test id
       5        $ author - larry rudolph (nyu-cims)
       6
       7        exports
       8            map_identity_test;
       9        reads
      10            print_mode;
      11
      12$   this program tests the following identies:
      13$
      14$    1. cardinality of <> = cardinality of a * domain f
      15$
      16$    2. the set <> = range <<(/x, f(x)/) : x in a>>
      17$
      18$    3. the set <> = the set <>
      19$
      20$  the map f and the set a have the following restrictions:
      21$
      22$    1. f must be one-to-one.
      23$
      24$    2. a must be a subset of the domain of f.
      25$
      26$
      27$       single parameter maps are tested via the proceedure 'svmtest'.
      28$  these maps have variable names begining with the letter 'f'.  two
      29$  parameter maps are tested in proceedure 'mpmtest' and all two
      30$  parameter maps begin with the letter 'g'.
      31$
      32$       the program runs in two modes:  brief and verbose.  the brief
      33$  mode only signals test failures;  in the verbose mode, a running
      34$  comentary is supplied along with the results of all tests.
      35$
      36$       n.b. the statement of the assignment contained a error.
      37$            the set <> does not equal the
      38$            set <>.
      39$            (see number 3 above for the correct equalities.)
      40
      41    var
      42        flsm,   frsm,  fssm,  flbsm, frbsm, fsbsm,
      43        flm,    frm,   fsm,   flbm,  frbm,  fsbm,
      44        glm,    grm,   gsm,   glbm,  grbm,  gsbm,
      45        glmm,   grmm,  gsmm,  glbmm, grbmm, gsbmm,
      46        als, ars, ass,
      47        bls, brs, bss;
      48
      49    const
      50        setofsets =
      51            <<  <<3,4,5>>, <<4,5>>, <<3>>, <>  >>;
      52
      53
      54    repr
      55        base intb:              integer;
      56        base rng:               integer;
      57        base pairs:             tuple(elmt rng, elmt rng);
      58        mode remote_smap:       remote smap(elmt rng) integer;
      59        mode remote_set:        remote set(elmt pairs);
      60
      61        flm:            local  map (elmt intb) integer;
      62        frm:            remote map (elmt intb) integer;
      63        fsm:            sparse map (elmt intb) integer;
      64        flbm:           local  map (elmt intb) elmt rng;
      65        frbm:           remote map (elmt intb) elmt rng;
      66        fsbm:           sparse map (elmt intb) elmt rng;
      67
      68        flsm:           local  smap(elmt intb) integer;
      69        frsm:           remote smap(elmt intb) integer;
      70        fssm:           sparse smap(elmt intb) integer;
      71        flbsm:          local  smap(elmt intb) elmt rng;
      72        frbsm:          remote smap(elmt intb) elmt rng;
      73        fsbsm:          sparse smap(elmt intb) elmt rng;
      74
      75        glm:            local  map (elmt intb) tuple(elmt rng, integer);
      76        grm:            remote map (elmt intb) tuple(elmt rng, integer);
      77        gsm:            sparse map (elmt intb) tuple(elmt rng, integer);
      78        glbm:           local  map (elmt intb) elmt pairs;
      79        grbm:           remote map (elmt intb) elmt pairs;
      80        gsbm:           sparse map (elmt intb) elmt pairs;
      81
      82        glmm:           local  mmap<> remote_smap;
      83        grmm:           remote mmap<> remote_smap;
      84        gsmm:           sparse mmap<> remote_smap;
      85        glbmm:          local  mmap<> remote_set;
      86        grbmm:          remote mmap<> remote_set;
      87        gsbmm:          sparse mmap<> remote_set;
      88
      89        als, bls:       local  set(elmt intb);
      90        ars, brs:       remote set(elmt intb);
      91        ass, bss:       sparse set(elmt intb);
      92    end repr;
      93
      94    procedure map_identity_test;
      95
      96    print_head('test 9  -  map identity test');
      97
      98    if print_mode = print_debug then
      99        print('note:  f indicates a 1-parameter map');
     100        print('       g indicates a 2-parameter map');
     101    end if;
     102
     103
     104    svmtest(    <<(/-55, 33/)>>,
     105                <<-55>>,
     106                'a and f both contain only one element');
     107
     108    svmtest(    <<(/x, x+x/) : x in (/1..10/)>>,
     109                <<1..10>>,
     110                'a is identical to domain f');
     111
     112    svmtest(    <<(/x, x/) : x in (/1..10/)>>,
     113                <<2, 10>>,
     114                'a is a proper subset of domain f');
     115
     116    svmtest(    <<(/x+x+2, x/) : x in (/17..23/)>>,
     117                <<36>>,
     118                'a contains only one element');
     119
     120    svmtest(    <<(/x, x/) : x in (/1..5/)>>,
     121                <>,
     122                'a is the empty set');
     123
     124
     125    $ test two parameter maps
     126    (forall a in setofsets, b in setofsets)
     127        mpmtest(
     128            <<(/x, (/y, 2**x * 3**y/)/) : x in a, y in b>>,
     129            a,
     130            b
     131            );
     132    end forall a;
     133
     134    print_tail('test 9  -  map identity tests');
     135
     136    end procedure map_identity_test;
     137
     138
     139    procedure svmtest(fmap, aset, heading);
     140
     141    $ test one parameter maps.
     142
     143    if print_mode = print_debug then
     144        print; print(heading); print;
     145    end if;
     146
     147    svmtest_1(fmap, aset, heading);
     148    svmtest_2(fmap, aset, heading);
     149
     150    end procedure svmtest;
     151
     152
     153    procedure svmtest_1(fmap, aset, heading);
     154
     155    if print_mode = print_debug then
     156        print;
     157        print('    test single-valued map representation');
     158        print;
     159    end if;
     160
     161    als   := ars   := ass   := aset;
     162    flsm  := frsm  := fssm  := fmap;
     163    flbsm := frbsm := fsbsm := fmap;
     164
     165
     166    $ test unbased map
     167    assert  <> =
     168                        range <<(/x, fmap(x)/) : x in aset>>
     169        and range <<(/x, fmap(x)/) : x in aset>> =
     170                        <>
     171        and # <> =
     172                        # (aset * domain fmap);
     173
     174    $ test local smap
     175    assert  <> =
     176                        range <<(/x, flsm(x)/) : x in als>>
     177        and range <<(/x, flsm(x)/) : x in ars>> =
     178                        <>
     179        and # <> =
     180                        # (als * domain flsm);
     181
     182    $ test remote smap
     183    assert  <> =
     184                        range <<(/x, frsm(x)/) : x in ars>>
     185        and range <<(/x, frsm(x)/) : x in ass>> =
     186                        <>
     187        and # <> =
     188                        # (ars * domain frsm);
     189
     190    $ test sparse smap
     191    assert  <> =
     192                        range <<(/x, fssm(x)/) : x in ass>>
     193        and range <<(/x, fssm(x)/) : x in aset>> =
     194                        <>
     195        and # <> =
     196                        # (ass * domain fssm);
     197
     198
     199    $ test local smap
     200    assert  <> =
     201                        range <<(/x, flbsm(x)/) : x in aset>>
     202        and range <<(/x, flbsm(x)/) : x in als>> =
     203                        <>
     204        and # <> =
     205                        # (aset * domain flbsm);
     206
     207    $ test remote smap
     208    assert  <> =
     209                        range <<(/x, frbsm(x)/) : x in ars>>
     210        and range <<(/x, frbsm(x)/) : x in ass>> =
     211                        <>
     212        and # <> =
     213                        # (ars * domain frbsm);
     214
     215    $ test sparse smap
     216    assert  <> =
     217                        range <<(/x, fsbsm(x)/) : x in ass>>
     218        and range <<(/x, fsbsm(x)/) : x in als>> =
     219                        <>
     220        and # <> =
     221                        # (ass * domain fsbsm);
     222
     223
     224    end procedure svmtest_1;
     225
     226
     227    procedure svmtest_2(fmap, aset, heading);
     228
     229    if print_mode = print_debug then
     230        print;
     231        print('    test ambiguous map representation');
     232        print;
     233    end if;
     234
     235    als   := ars   := ass   := aset;
     236    flm   := frm   := fsm   := fmap;
     237    flbm  := frbm  := fsbm  := fmap;
     238
     239
     240    $ test local map
     241    assert  <> =
     242                        range <<(/x, flm(x)/) : x in ass>>
     243        and range <<(/x, flm(x)/) : x in als>> =
     244                        <>
     245        and # <> =
     246                        # (ass * domain flm);
     247
     248    $ test remote map
     249    assert  <> =
     250                        range <<(/x, frm(x)/) : x in als>>
     251        and range <<(/x, frm(x)/) : x in aset>> =
     252                        <>
     253        and # <> =
     254                        # (als * domain frm);
     255
     256    $ test sparse map
     257    assert  <> =
     258                        range <<(/x, fsm(x)/) : x in aset>>
     259        and range <<(/x, fsm(x)/) : x in ars>> =
     260                        <>
     261        and # <> =
     262                        # (aset * domain fsm);
     263
     264
     265    $ test local map
     266    assert  <> =
     267                        range <<(/x, flbm(x)/) : x in als>>
     268        and range <<(/x, flbm(x)/) : x in ass>> =
     269                        <>
     270        and # <> =
     271                        # (ass * domain flbm);
     272
     273    $ test remote map
     274    assert  <> =
     275                        range <<(/x, frbm(x)/) : x in ass>>
     276        and range <<(/x, frbm(x)/) : x in ars>> =
     277                        <>
     278        and # <> =
     279                        # (ars * domain frbm);
     280
     281    $ test sparse map
     282    assert  <> =
     283                        range <<(/x, fsbm(x)/) : x in ars>>
     284        and range <<(/x, fsbm(x)/) : x in als>> =
     285                        <>
     286        and # <> =
     287                        # (als * domain fsbm);
     288
     289
     290    end procedure svmtest_2;
     291
     292    procedure mpmtest(g, aset, bset);
     293
     294    $ test 2-parameter maps (nameed g).
     295
     296    if print_mode = print_debug then
     297        print;
     298        print('two parameter map test');
     299        print;
     300    end if;
     301
     302    mpmtest_1(g, aset, bset);
     303    mpmtest_2(g, aset, bset);
     304    mpmtest_3(g, aset, bset);
     305    mpmtest_4(g, aset, bset);
     306
     307    end procedure mpmtest;
     308    procedure mpmtest_1(g, aset, bset);
     309
     310    if print_mode = print_debug then
     311        print; print('   range is unbased pair'); print;
     312    end if;
     313
     314    als := ars := ass := aset;
     315    bls := brs := bss := bset;
     316    glm := grm := gsm := g;
     317
     318
     319    $ test unbased map
     320    assert  <<>(y) : x in ars, y in bss>> =
     321            range range
     322                <<(/x, (/y, g<>(y)/)/) : x in als, y in bss>>
     323        and range range
     324                <<(/x, (/y, g<>(y)/)/) : x in als, y in bss>> =
     325            <>
     326        and # <> =
     327            # aset  *  # bset;
     328
     329    $ test local map
     330    assert  <<>(y) : x in ars, y in bss>> =
     331            range range
     332                <<(/x, (/y, glm<>(y)/)/) : x in als, y in bss>>
     333        and range range
     334                <<(/x, (/y, glm<>(y)/)/) : x in als, y in bss>> =
     335            <>
     336        and # <> =
     337            # aset  *  # bset;
     338
     339    $ test remote map
     340    assert  <<>(y) : x in ars, y in bss>> =
     341            range range
     342                <<(/x, (/y, grm<>(y)/)/) : x in als, y in bss>>
     343        and range range
     344                <<(/x, (/y, grm<>(y)/)/) : x in als, y in bss>> =
     345            <>
     346        and # <> =
     347            # aset  *  # bset;
     348
     349    $ test sparse map
     350    assert  <<>(y) : x in ars, y in bss>> =
     351            range range
     352                <<(/x, (/y, gsm<>(y)/)/) : x in als, y in bss>>
     353        and range range
     354                <<(/x, (/y, gsm<>(y)/)/) : x in als, y in bss>> =
     355            <>
     356        and # <> =
     357            # aset  *  # bset;
     358
     359
     360    end procedure mpmtest_1;
     361
     362
     363    procedure mpmtest_2(gmap, aset, bset);
     364
     365    if print_mode = print_debug then
     366        print; print('   range is element-of-base'); print;
     367    end if;
     368
     369    als  := ars  := ass  := aset;
     370    bls  := brs  := bss  := bset;
     371    glbm := grbm := gsbm := gmap;
     372
     373
     374    $ test local map
     375    assert  <<>(y) : x in ars, y in bss>> =
     376            range range
     377                <<(/x, (/y, glbm<>(y)/)/) : x in als, y in bss>>
     378        and range range
     379                <<(/x, (/y, glbm<>(y)/)/) : x in als, y in bss>> =
     380            <>
     381        and # <> =
     382            # aset  *  # bset;
     383
     384    $ test remote map
     385    assert  <<>(y) : x in ars, y in bss>> =
     386            range range
     387                <<(/x, (/y, grbm<>(y)/)/) : x in als, y in bss>>
     388        and range range
     389                <<(/x, (/y, grbm<>(y)/)/) : x in als, y in bss>> =
     390            <>
     391        and # <> =
     392            # aset  *  # bset;
     393
     394    $ test sparse map
     395    assert  <<>(y) : x in ars, y in bss>> =
     396            range range
     397                <<(/x, (/y, gsbm<>(y)/)/) : x in als, y in bss>>
     398        and range range
     399                <<(/x, (/y, gsbm<>(y)/)/) : x in als, y in bss>> =
     400            <>
     401        and # <> =
     402            # aset  *  # bset;
     403
     404
     405    end procedure mpmtest_2;
     406
     407
     408    procedure mpmtest_3(gmap, aset, bset);
     409
     410    if print_mode = print_debug then
     411        print; print('   map is multi-valued by declaration'); print;
     412    end if;
     413
     414    als := ars := ass := aset;
     415    bls := brs := bss := bset;
     416    glmm:= grmm:= gsmm:= gmap;
     417
     418
     419    $ test local mmap
     420    assert  <<>(y) : x in ars, y in bss>> =
     421            range range
     422                <<(/x, (/y, glmm<>(y)/)/) : x in als, y in bss>>
     423        and range range
     424                <<(/x, (/y, glmm<>(y)/)/) : x in als, y in bss>> =
     425            <>
     426        and # <> =
     427            # aset  *  # bset;
     428
     429    $ test remote mmap
     430    assert  <<>(y) : x in ars, y in bss>> =
     431            range range
     432                <<(/x, (/y, grmm<>(y)/)/) : x in als, y in bss>>
     433        and range range
     434                <<(/x, (/y, grmm<>(y)/)/) : x in als, y in bss>> =
     435            <>
     436        and # <> =
     437            # aset  *  # bset;
     438
     439    $ test sparse mmap
     440    assert  <<>(y) : x in ars, y in bss>> =
     441            range range
     442                <<(/x, (/y, gsmm<>(y)/)/) : x in als, y in bss>>
     443        and range range
     444                <<(/x, (/y, gsmm<>(y)/)/) : x in als, y in bss>> =
     445            <>
     446        and # <> =
     447            # aset  *  # bset;
     448
     449
     450    end procedure mpmtest_3;
     451
     452
     453    procedure mpmtest_4(gmap, aset, bset);
     454
     455    if print_mode = print_debug then
     456        print; print('   range is remote smap'); print;
     457    end if;
     458
     459    als   := ars   := ass   := aset;
     460    bls   := brs   := bss   := bset;
     461    glbmm := grbmm := gsbmm := gmap;
     462
     463
     464    $ test local mmap
     465    assert  <<>(y) : x in ars, y in bss>>
     466            = range range
     467                <<(/x, (/y, glbmm<>(y)/)/) : x in als, y in bss>>
     468        and range range
     469                <<(/x, (/y, glbmm<>(y)/)/) : x in als, y in bss>>
     470            = <>
     471        and # <>
     472            = # aset  *  # bset;
     473
     474    $ test remote mmap
     475    assert  <<>(y) : x in ars, y in bss>>
     476            = range range
     477                <<(/x, (/y, grbmm<>(y)/)/) : x in als, y in bss>>
     478        and range range
     479                <<(/x, (/y, grbmm<>(y)/)/) : x in als, y in bss>>
     480            = <>
     481        and # <>
     482            = # aset  *  # bset;
     483
     484    $ test sparse mmap
     485    assert  <<>(y) : x in ars, y in bss>>
     486            = range range
     487                <<(/x, (/y, gsbmm<>(y)/)/) : x in als, y in bss>>
     488        and range range
     489                <<(/x, (/y, gsbmm<>(y)/)/) : x in als, y in bss>>
     490            = <>
     491        and # <>
     492            = # aset  *  # bset;
     493
     494
     495    end procedure mpmtest_4;
     496
     497
     498    end module test - map_identities;
     499
     500
     501
     502
       1 .=member test16
       2      module test - circularity;
       3
       4          $ nyu test id
       5          $ author - r. lee (nyu-cims)
       6          $ logged in as lee16
       7
       8          exports
       9              circularity_test;
      10
      11          reads
      12              print_mode;
      13
      14      $   circularity test  (by richard lee)
      15      $
      16      $ in this test we build various circular structures
      17      $ and subject these structures to equality tests with
      18      $ equivalent ones built explicitly which are not
      19      $ self-referent.
      20
      21      macro unitset;
      22         <<1>>  endm;
      23
      24
      25          var
      26              sibase,  $ set of based integers
      27              srbase,  $ set of based reals
      28              sloc,    $ local set of integers
      29              srem,    $ remote set of integers
      30              stint,   $ set of tuples of integers
      31              stibase, $ set of tuples of based integers
      32              ssbase,  $ set of based sets
      33              sm,      $ single valued map
      34              mm,      $ multivalued map
      35              mmr,     $ remote multivalued map
      36              mml,     $ local multivalued map
      37              mmlr;    $ multivalued local map of remote map
      38
      39          repr
      40
      41              base  ibase :  integer;
      42              base  rbase :  real;
      43              base  tint :  tuple( integer);
      44              base  tibase :  tuple(elmt ibase);
      45              base  sbase :  set( integer);
      46
      47              sibase :   set(elmt ibase);
      48              srbase :   set(elmt rbase);
      49              stint  :   set(elmt tint);
      50              stibase:   set(elmt tibase);
      51              sloc   :   local  set(elmt ibase);
      52              srem   :   remote  set(elmt ibase);
      53              ssbase :   set(elmt sbase);
      54              sm     :   smap(elmt ibase)
      55                             elmt ibase;
      56              mm     :   mmap <>
      57                             set(elmt ibase);
      58              mmr    :   remote mmap  <>
      59                             set(elmt ibase);
      60              mml    :   local  mmap  <>
      61                             set(elmt ibase);
      62              mmlr   :   local  mmap  <>
      63                             remote mmap  <>
      64                                 set(elmt ibase);
      65
      66          end repr;
      67
      68
      69      proc circularity_test;
      70
      71      print_head('test 16  -  circular structure test');
      72
      73
      74      si := satom := gmap := sr := nullset;
      75
      76      loop forall i in (/ 1... 10 /) do         $ build
      77          si +:= <>;                  $       set of integers,
      78          sr +:= << float(i)+0.5>>;      $       set of reals,
      79          satom  with:=  newat;          $       set of atoms,
      80          gmap(i) := 2*i+1;            $       single valued map
      81      end loop;                        $ respectively
      82
      83      sm := gmap;                      $ force into new repr
      84
      85      sibase := si;                    $ force into new repr
      86
      87      srbase := sr;                    $ force into new repr
      88
      89      sloc := si;                      $ force into new repr
      90      srem := sloc;                    $ force into new repr
      91      sspar := srem;                   $ force into default repr
      92
      93      stup := nullset;                 $ build set of tuples of varying
      94      tup := nulltup;                  $  lengths
      95      sett := sset := nullset;         $ and set of sets
      96      loop forall i in (/ 1...10 /) do
      97        tup  with:= i;
      98        stup  with:= tup;
      99        sett with:= i;
     100        sset  with:= sett;
     101      end;
     102
     103      stint := stup;                   $ force into new repr
     104      stibase := stint;                $ force into new repr
     105
     106      ssbase := sset;                  $ force into new repr
     107
     108      mm := gmap;                      $ build multivalued map
     109      (forall x in sm)
     110          mm<> +:= <>;
     111      end forall;
     112
     113      mml := mm ;                      $ force into new repr
     114      mmr := mml;                      $ force into new repr
     115
     116      mmlr := << (/i,(/i+j,2*j/)/) : i in (/1...10/), j in (/1...5/) >>;
     117                                                 $ doubly indexed map
     118
     119
     120      sgen := << 3, (/10,4/), 2.5, 'abcd' >>;        $ mixed set
     121      sgen  with:= sgen;
     122
     123      sch := << 'a', 'b', 'c', 'dd', 'zzz', 'set of characters' >>;
     124                                            $ set of character strings
     125
     126      setnc := <>;             $ set of null character
     127
     128      setns := <>;              $ set of empty set
     129
     130      setnt := <>;              $ set of null tuple
     131
     132
     133      circtest(nullset,   'empty set'                           );
     134      circtest(unitset,   'unit set'                            );
     135
     136      circtest(setnc,     'set of null character'               );
     137      circtest(setns,     'set of null set'                     );
     138      circtest(setnt,     'set of null tuple'                   );
     139
     140      circtest(satom,     'set of atoms'                        );
     141
     142      circtest(stup,      'set of tuples'                       );
     143      circtest(stint,     'set of based tuples'                 );
     144      circtest(stibase,   'set of tuples of based integers'     );
     145
     146      circtest(si,        'set of integers'                     );
     147      circtest(sibase,    'set of based integers'               );
     148
     149      circtest(sr,        'set of reals'                        );
     150      circtest(srbase,    'set of based reals'                  );
     151
     152      circtest(sloc,      'local set of integers'               );
     153      circtest(srem,      'remote set of integers'              );
     154      circtest(sspar,     'sparse set of integers'              );
     155
     156      circtest(sgen,      'general set'                         );
     157
     158      circtest(sch,       'set of character strings'            );
     159
     160      circtest(sset,      'set of sets'                         );
     161      circtest(ssbase,    'set of based sets'                   );
     162
     163      circtest(gmap,      'general map'                         );
     164      circtest(sm,        'single valued map'                   );
     165      circtest(mm,        'multi-valued map'                    );
     166      circtest(mmr,       'multi-valued remote map'             );
     167      circtest(mml,       'multi-valued local map'              );
     168      circtest(mmlr,      'multi-valued local/remote map'       );
     169
     170
     171      print_tail('test 16  -  circular structure test');
     172
     173      end proc circularity_test;
     174
     175
     176      proc circtest(sinit, mesg);
     177
     178         $ build circular sets
     179         loop init   $ base step
     180                   simp:=sexp:=sinit;
     181                   simp with:= simp;
     182                   temp := sexp;
     183                   sexp with:= temp;
     184                   if print_mode = print_debug then
     185                       print('++++ building circular',mesg);
     186                       print('++ step = 1    implicit set =',simp);
     187                       print('++             explicit set =',sexp);
     188                   end if;
     189                   i := card sinit div 2 + 1;
     190                   j := i;
     191              while ( i <= card sinit )
     192              step j+:= 1;
     193              until j > i + 1
     194         do          $ i th step
     195              simp with:= simp;
     196              temp :=sexp;
     197              sexp with:= temp;
     198              if print_mode = print_debug then
     199                  print('++ step =',j,'   implicit set =',simp);
     200                  print('++             explicit set =',sexp);
     201              end if;
     202         end;
     203         $ circular equality test
     204         assert simp = sexp;
     205
     206      end proc circtest;
     207
     208
     209      drop
     210          unitset;
     211
     212
     213      end module test - circularity;
     214
     215
     216
     217
       1 .=member test24
       2      module test - quantifiers;
       3
       4          $ nyu program identification
       5          $ author - richard lee
       6          $ entered in as file lee24a  in tstbag/un=shwrtzj
       7          $ renamed as rtl24a  24 jan 79
       8
       9          exports
      10              quantifier_test;
      11
      12          reads
      13              print_mode;
      14
      15
      16      $ this is first of a series of quantifier tests
      17      $ in this test we build sets and tuples of integers
      18      $ and reals.
      19      $ in particular three of each repr is built such
      20      $ that the first is always false on p(x), the
      21      $ second is partially true and partially false on
      22      $ p(x), and the third is always true on p(x) where
      23      $ p(x) is a chosen predicate of one variable.
      24
      25      macro p(x);
      26         x > zero(x)  endm;
      27
      28      var
      29
      30         teststatus,
      31
      32         sibase,                  $ based integer sets
      33         srbase,                  $ based real sets
      34         tibase,                  $ based integer tuples
      35         trbase,                  $ based real tuples
      36         sirem;                   $ remote integer sets
      37
      38      repr
      39
      40         base ibase  : integer;
      41         base rbase  : real;
      42
      43         sibase    : tuple( set(elmt ibase) );
      44         srbase    : tuple( set(elmt rbase) );
      45         tibase    : tuple( tuple(elmt ibase) );
      46         trbase    : tuple( tuple(elmt rbase) );
      47         sirem     : tuple( remote set(elmt ibase) );
      48
      49      end repr;
      50
      51
      52      proc quantifier_test;
      53
      54      print_head('quantifier test');
      55
      56      $ build our basic sets and tuples
      57      rsets := isets := (/nullset,nullset,nullset/);
      58      rtups := itups := (/nulltup,nulltup,nulltup/);
      59      lims  := (/(/-10,-1/),(/-5,5/),(/1,10/)/);
      60      loop forall (/lwb, upb/) = lims(j) do
      61        loop forall i in (/ lwb...upb /)do
      62          isets(j) with:= i;
      63          rsets(j) with:= float(i);
      64          itups(j) with:= i;
      65          rtups(j) with:= float(i);
      66        end;
      67      end;
      68
      69      $ now try some different reprs
      70      srbase := rsets;
      71      sibase := isets;
      72      siloc  := sibase;
      73      sirem  := siloc;
      74      trbase := rtups;
      75      tibase := itups;
      76
      77      loop forall i in (/ 1...3 /) do
      78        qtest1(isets(i),  'sparse integer set '  + str(i));
      79        qtest1(rsets(i),  'sparse real set '     + str(i));
      80        qtest1(sibase(i), 'based integer set '   + str(i));
      81        qtest1(srbase(i), 'based real set '      + str(i));
      82        qtest1(siloc(i),  'local set '           + str(i));
      83        qtest1(sirem(i),  'remote set '          + str(i));
      84        qtest1(tibase(i), 'based integer tuple ' + str(i));
      85        qtest1(trbase(i), 'based real tuple '    + str(i));
      86      end;
      87
      88      print_tail('quantifier test');
      89
      90
      91      end proc quantifier_test;
      92
      93
      94      proc qtest1(s,mesg2);
      95
      96      $ checks some fundamental properties of quantifiers
      97
      98      tracecheck(s,'entering qtest1',mesg2);
      99
     100      mesg1 := '++ semantic test of universal quantifier - part a';
     101      tracecheck(s,mesg1,mesg2);
     102
     103      if (forall x in s st p(x)) then
     104         if +/(/1 : x in s st p(x)/) = card s then
     105                   tracecheck(s,mesg1+' passed',mesg2);
     106         else failed_(s,mesg1,mesg2);  end;
     107      else tracecheck(s,mesg1+' passed',mesg2);
     108      end if;
     109
     110      mesg1 := '++ semantic test of universal quantifier - part b';
     111      tracecheck(s,mesg1,mesg2);
     112
     113      if +/(/1 : x in s st p(x)/) = card s then
     114         if (forall x in s st p(x)) then
     115                   tracecheck(s,mesg1+' passed',mesg2);
     116         else failed_(s,mesg1,mesg2);  end;
     117      else tracecheck(s,mesg1+' passed',mesg2);
     118      end if;
     119
     120      mesg1 := '++ semantic test of existential quantifier - part a';
     121      tracecheck(s,mesg1,mesg2);
     122
     123      if (exists x in s st p(x)) then
     124          if +/(/ 1 : x in s st p(x) /) /= om then
     125                   tracecheck(s,mesg1+' passed',mesg2);
     126         else failed_(s,mesg1,mesg2);  end;
     127      else tracecheck(s,mesg1+' passed',mesg2);
     128      end if;
     129
     130      mesg1 := '++ semantic test of existential quantifier - part b';
     131      tracecheck(s,mesg1,mesg2);
     132
     133      if not (+/(/1 : x in s st p(x)/) = om) then
     134         if (exists x in s st p(x)) then
     135                   tracecheck(s,mesg1+' passed',mesg2);
     136         else failed_(s,mesg1,mesg2);  end;
     137      else tracecheck(s,mesg1+' passed',mesg2);
     138      end if;
     139
     140      passall(s,'semantic tests',mesg2);
     141
     142      tracecheck(s,'leaving qtest1',mesg2);
     143
     144      end proc qtest1;
     145
     146
     147      proc passall(s,mesg1,mesg2);
     148
     149      $ prints success messages
     150
     151      if teststatus = 'failed' then teststatus := ''; return;
     152                               else teststatus := 'passed';
     153      end if;
     154
     155      if print_mode >= print_full then
     156         print(mesg1,'with',mesg2,'all passed');
     157      end if;
     158
     159      end proc passall;
     160
     161
     162      proc failed_(s,mesg1,mesg2);
     163
     164      $ failure diagnostic dump
     165
     166      teststatus := 'failed';
     167      print(60*'-');
     168      print(mesg1,'with',mesg2,'failed');
     169      print('s =',s);
     170      print(60*'-');
     171
     172      end proc failed_;
     173
     174      proc tracecheck(s,mesg1,mesg2);
     175
     176      $ print trace messages
     177
     178      if print_mode = print_debug then
     179         print('*trace*',mesg1,'with',mesg2);
     180         end;
     181
     182      end proc tracecheck;
     183
     184
     185     proc zero(x);
     186      return(x-x);
     187     end proc zero;
     188
     189
     190      drop
     191          p;
     192
     193
     194      end module test - quantifiers;
     195
     196
     197
     198
       1 .=member test28
       2      module test - recursion;
       3
       4          $ nyu test id
       5          $ author - j. schwartz (nyu-cims)
       6          $ logged in as jts14
       7          $ passed xsetl 30 jan 79
       8          $ forward to stefan as file ds05
       9
      10          exports
      11              recursion_test;
      12
      13          reads
      14              print_mode;
      15
      16          var
      17              have;           $ memo function map
      18
      19
      20      proc recursion_test;   $ tests recursive routines
      21
      22      print_head('recursion test');
      23
      24      (forall n in (/ 1...6/)) assert factorial(n) = */(/1...n/); end;
      25
      26      have:=nullset;
      27      (forall n in (/ 1...10/)) assert fib(n) = fib2(n)
      28                                and fib2(n) = fib3(n); end;
      29
      30      have:=nullset;
      31      (forall n in (/ 10, 9...1 /)) assert fib(n) = fib2(n)
      32                                   and fib2(n) = fib3(n); end;
      33
      34      $ recursive sorting test
      35      tupa := (/1,3,2/);              tupb := (/1,4,3/);
      36      tup  := tupa + tupb + tupa;   tup  := tup + tup;
      37      tups := tupa + tupa + tupb;   tups := tups + tups;
      38
      39      assert  bsort(tup) = msort(tups);
      40
      41      print_tail('recursion test');
      42
      43      end proc recursion_test;
      44
      45
      46      proc factorial(n);
      47
      48      return if n=1 then 1 else n*factorial (n-1) end;
      49
      50      end proc factorial;
      51
      52
      53      proc fib(n);
      54
      55      return if n=1 or n=2 then 1 else
      56               fib(n-1)+fib(n-2) end;
      57
      58      end proc fib;
      59
      60
      61      proc fib2(n);
      62
      63      if have(n) = om then
      64
      65          have(n):= if n=1 or n=2 then 1 else
      66                          fib(n-1)+fib(n-2) end;
      67
      68      end if;
      69
      70      return have(n);
      71
      72      end proc fib2;
      73
      74
      75      proc fib3(m);
      76
      77      fibmap :=<<(/1,1/),(/2,1/)>>;
      78
      79      (forall n in (/ 3...m /))
      80
      81          fibmap(n) := fibmap(n-1)+fibmap(n-2);
      82          fibmap(n-2):=om;
      83
      84      end forall;
      85
      86      return fibmap(m);
      87
      88
      89      end proc fib3;
      90
      91
      92      proc bsort(tup);
      93
      94      return if(card tup)=1 then tup else
      95                             putin(tup(1), bsort(tup(2..))) end ;
      96
      97      end proc bsort;
      98
      99
     100      proc putin (x,tup);
     101
     102      return if x <= tup(1) then (/x/)+ tup
     103               elseif (card tup)=1 then tup+(/x/) else
     104                          (/tup(1)/)+putin(x,tup(2..)) end ;
     105
     106      end proc putin;
     107
     108
     109      proc msort (tups);
     110
     111      return if(card tups)=1 then tups else
     112                          merge(msort(tups(1...(card tups)div 2)),
     113                          bsort(tups((card tups)div 2 + 1..))) end ;
     114
     115      end proc msort;
     116
     117
     118      proc merge(t1,t2);
     119
     120      return if t1=(//) then t2
     121
     122          elseif t2=(//) then t1
     123
     124          elseif t1(1)<< random(100): 1...cases(i) >>;
      36          $ random not implemented, fake it.
      37          testset := << 1...cases(i) >>;
      38
      39          print;   print;   print;
      40          print('case number', i, ', test set is', testset);
      41
      42          median := kthone((card testset+1) div 2, testset);
      43          print('the median of the test set is', median);
      44      end forall;
      45
      46      print_tail('median test');
      47
      48      end proc median_test;
      49
      50
      51      proc kthone(kparam, setparam);
      52
      53      $ the value of this function is the kparam'th number, in
      54      $ ascending order, of the given set 'setparam' of numbers.  if
      55      $ kparam is out of range, the result is undefined.
      56      $ this is the algorithm discovered by floyd, et al, in late
      57      $ 1971, that runs in linear time.
      58
      59      $ 'kthonebl' is a global variable (to prevent stacking on
      60      $ recursion).  user must initialize it to null char. string.
      61
      62      if setparam = nullset then return om; end if;
      63
      64      $ save parameters - this routine does not alter them.
      65      k := kparam;
      66      sett := setparam;
      67
      68      kthonebl +:= '   ';     $ change print identing level
      69
      70      (while (card sett)>= 3) $ number of comparisons
      71          $ build set 'midpts', the set of middle values from
      72          $ 'set', taking the numbers three at a time.
      73          i := 2;
      74          midpts := <>;
      75          (forall x in sett)
      76              i := (i+1) mod 3;
      77
      78              if     i = 0 then u := x;
      79              elseif i = 1 then v := x;
      80              elseif i = 2 then
      81                  $ put median of u, v, and the current x into set
      82                  $ midpts.  requires 3 comparisons (worst case).
      83
      84                  if x  <  v then
      85                      cas := 1;
      86                  else
      87                      cas := 0;
      88                  end;
      89
      90                  if u  <  x then
      91                      cas := cas + 2;
      92                  end;
      93
      94                  if v  <  u then
      95                      cas := 3 - cas;
      96                  end;
      97                  $ now cas must be 1, 2, or 3.
      98                 tmp:=(/u, v, x/);
      99                 midpts with:= tmp(cas);
     100              end if i ;
     101          end forall x;
     102
     103          $ print number of comparisons, indented.
     104          print(kthonebl, (card sett div 3)*3);
     105          $ as many as two members of -sett- have not been considered
     106          $ for placement in -midpts-.  but the error is not sufficient
     107          $ to prevent this algorithm from working in linear time.
     108          $ note that card midpts ge. 1, because card set ge. 3.
     109          $ now find the (exact) median of 'midpts', in linear time.
     110          $ this algorithm chooses on the low side if card midpts is eve
     111          median := kthone((card midpts+1) div 2, midpts);
     112          $ note that 'median' is somewhere in the middle third of
     113          $ -sett-.
     114          $ precisely, the number of members of -sett- that
     115          $ are less than 'median' is at least (n/3-1)/2 + (n/3+1)/2,
     116          $ and the number of members that are greater is at least
     117          $ n/6 + (n/3+2)/2, where n = card set.
     118
     119          $ now divide -sett- into two piles;members of 'smalpile'
     120          $ are le. median, and members of 'bigpile' are gt. median.
     121          smalpile := nullset ;
     122          bigpile := nullset ;
     123          (forall x in sett)
     124              if x <= median then
     125                  smalpile with:=  x;
     126              else
     127                  bigpile with:=  x;
     128              end if;
     129          end forall x;
     130          $ print number of comparisons.
     131          print(kthonebl, card sett);
     132          $ since card set ge. 3, and we have thrown the median into
     133          $ 'smalpile', we have card smalpile ge. 2 and card bigpile ge.
     134          $ iterate to find the appropriate member of the appropriate
     135          $ pile.
     136
     137          if k <= card smalpile then
     138              sett := smalpile;
     139          else
     140              sett := bigpile;
     141              k := k - card smalpile;
     142          end if;
     143      end while;
     144      $ go back with new set and possibly new k.
     145      kthonebl := if card kthonebl > 3  then
     146          kthonebl(1...card kthonebl-3)  else  ''  end;
     147      $ now card set is 1 or 2 (it can't be zero).  k may be out of
     148      $ range if the original call had kparam out of range.
     149
     150      if (card sett) = 1 then
     151          if k = 1 then
     152              return arb  sett;
     153          else
     154              return om ;
     155          end if k;
     156
     157      else
     158          $ card set must be 2.
     159          if k = 1 then
     160              return min/sett;
     161          elseif k = 2 then
     162              return max/sett;
     163              else
     164                  return om ;
     165              end if;
     166      end if;
     167
     168      end proc kthone;
     169
     170
     171      end module test - median_finder;
     172
     173
     174
     175
       1 .=member huff
       2      module test - huffman_coding;
       3
       4          $ nyu program identification
       5          $ huffman encode and decode
       6          $ author - j. schwartz (nyu-cims)
       7          $ entered as file huff in tstbag/un=jts
       8          $ conversion of setla program  deck huff on t880 stestpl
       9          $ passed xsetl 14-feb-79
      10          $ forward for inclusion in standard tests  14-feb-79
      11
      12          exports
      13              huffman_coding_test;
      14
      15          reads
      16              print_mode;
      17
      18          const
      19              csq  = 'etaionshrdlubcfgjkmpqvwxyz .,',
      20              fseq = (/ 10,  8,  7,  6,  5,  4,  4,  4,  4,  4,
      21                         3,  3,  3,  3,  3,  2,  2,  2,  2,  2,
      22                         1,  1,  1,  1,  1,  1, 10,  1,  1 /);
      23
      24          var
      25              cseq,
      26              code,
      27              seq,
      28              l,
      29              r,
      30              wfreq,
      31              work;
      32
      33
      34      proc huffman_coding_test;
      35
      36      print_head('huffman coding test');
      37
      38      cseq := (/csq(n): n in (/ 1...card csq /)/);
      39      chs := nullset;  $ character set
      40
      41      frq := nullset;  $ frequency mapping
      42      (forall n in (/ 1...card cseq/))
      43          chs with:= cseq(n);
      44          frq(cseq(n)) := fseq(n);
      45      end forall;
      46
      47      huftabs := huftabl(chs, frq);
      48      (/code, l, r, tp/) := huftabs;
      49
      50      strng := 'if you can read this, the huffman test has passed.';
      51
      52      coded := +/(/code(strng(n)): n in (/1...card strng/)/);
      53      print( (decode := codsq(huftabs, coded)) );
      54
      55      assert decode = strng;
      56
      57      print_tail('huffman coding test');
      58
      59      end proc huffman_coding_test;
      60
      61
      62      op .getmin (s);      $
      63
      64      keep  := arb s;
      65      least := wfreq(keep);
      66
      67      (forall x in s)
      68          if wfreq(x) < least then
      69              keep  := x;
      70              least := wfreq(x);
      71          end if;
      72      end forall;
      73
      74      work less:= keep;
      75
      76      return keep;
      77
      78      end op .getmin;
      79
      80
      81      $ routine to produce huffman tree and code table.
      82      proc  huftabl  (chars, freq);
      83      work := chars;
      84      wfreq := freq;
      85      l := nullset;
      86      r := nullset;
      87
      88      (while (card work)  >  1)
      89          c1 := .getmin  work;
      90          c2 := .getmin  work;
      91          n := newat;
      92          l(n) := c1;
      93          r(n) := c2;
      94          wfreq(n) := wfreq(c1)+wfreq(c2);
      95          work with:= n;
      96      end while;
      97
      98      code  :=  nullset;
      99      seq  :=  nullstring;
     100
     101      if print_mode = print_debug then
     102          print;   print;
     103          print('work =', work);
     104          print('l =   ', l   );
     105          print('r =   ', r   );
     106          print;
     107      end if;
     108
     109      tp := arb work;
     110          walk(tp);
     111      return (/code, l, r, tp/);
     112
     113      end proc huftabl;
     114
     115      proc walk(tp);          $ recursive tree-walker
     116                              $ builds-up address of each twig
     117
     118      if l(tp) /= om then
     119          seq := seq + '0';
     120          walk(l(tp));
     121          seq := seq + '1';
     122          walk(r(tp));
     123      else   $ at twig
     124          code(tp) := seq;
     125      end if;
     126
     127      if(card seq) > 1 then
     128          seq := seq(1...card seq-1);
     129      else
     130          seq := nullstring;
     131      end;
     132
     133      end proc walk;
     134
     135
     136      proc codsq(huftabs, sq);   $ huffman decoding routine
     137
     138      (/jk, l, r, tp/) := huftabs;
     139
     140      outpu := nullstring;
     141      node := tp;
     142      n := 1;
     143
     144      (while n <= card sq step n := n+1;)
     145          if l(node) = om then   $ so that we are at twig
     146              outpu := outpu + node;
     147              node := tp;
     148              n := n-1;
     149          else
     150              node := if sq(n) = '0' then l(node) else r(node) end;
     151          end if;
     152      end while;
     153
     154      return outpu + node;
     155
     156      end proc codsq;
     157
     158
     159      end module test - huffman_coding;
     160
     161
     162
     163
       1 .=member tarjan
       2
       3
       4      module test - tarjan;
       5
       6      $ tarjan's fast interval finder.
       7      $ (see setl newsletter no. 204 for details)
       8
       9          exports
      10              tarjan_test;
      11
      12          reads
      13              print_mode;
      14
      15
      16      $ this example analyses the following graph:
      17
      18      $            [301]
      19      $              ?
      20      $            [302] ---------<---------
      21      $              ?                      '
      22      $            [303] --------<--------  '
      23      $              ?                    ' '
      24      $            [304] -------<-------  ' '
      25      $              ?                  ' ' '
      26      $            [305] ------<------  ' ' '
      27      $              ?                ' ' ' '
      28      $            [306] -----<-----  ' ' ' '
      29      $              ?              ' ' ' ' '
      30      $            [307] ----<----  ' ' ' ' '
      31      $              ?            ' ' ' ' ' '
      32      $            [308] ---<---  ' ' ' ' ' '
      33      $              ?          ' ' ' ' ' ' '
      34      $            [309] --<--  ' ' ' ' ' ' '
      35      $              ?        ' ' ' ' ' ' ' '
      36      $            [310] -->--  ' ' ' ' ' ' '
      37      $              ?          ' ' ' ' ' ' '
      38      $            [311] --->---  ' ' ' ' ' '
      39      $              ?            ' ' ' ' ' '
      40      $            [312] ---->----  ' ' ' ' '
      41      $              ?              ' ' ' ' '
      42      $            [313] ----->-----  ' ' ' '
      43      $              ?                ' ' ' '
      44      $            [314] ------>------  ' ' '
      45      $              ?                  ' ' '
      46      $            [315] ------->-------  ' '
      47      $              ?                    ' '
      48      $            [316] -------->--------  '
      49      $              ?                      '
      50      $            [317] --------->---------
      51      $              ?
      52      $            [318]
      53
      54
      55      const
      56          int_graph =    << (/301, 302/), (/302, 303/), (/303, 304/),
      57                            (/304, 305/), (/305, 306/), (/306, 307/),
      58                            (/307, 308/), (/308, 309/), (/309, 310/),
      59                            (/310, 311/), (/311, 312/), (/312, 313/),
      60                            (/313, 314/), (/314, 315/), (/315, 316/),
      61                            (/316, 317/), (/317, 318/),
      62                            (/310, 309/), (/311, 308/), (/312, 307/),
      63                            (/313, 306/), (/314, 305/), (/315, 304/),
      64                            (/316, 303/), (/317, 302/) >>,
      65
      66          int_root =      301,
      67
      68          int_intervals = << (/301, (/301, 302, 318/) /),
      69                            (/302, (/302, 303, 317/) /),
      70                            (/303, (/303, 304, 316/) /),
      71                            (/304, (/304, 305, 315/) /),
      72                            (/305, (/305, 306, 314/) /),
      73                            (/306, (/306, 307, 313/) /),
      74                            (/307, (/307, 308, 312/) /),
      75                            (/308, (/308, 309, 311/) /),
      76                            (/309, (/309, 310/) /) >>;
      77
      78
      79      $ evaluate head lim x using virtual tree
      80
      81      macro headlim(x);   vreps(vheadlim(x))   endm;
      82
      83      var
      84          head,      $ maps each node to its interval head
      85          vpar,      $ parent mapping in virtual tree
      86          vndescs,   $ number of descendants in virtual tree
      87          vreps;     $ node represented by virtual tree head
      88
      89
      90      repr
      91          base nodebase: integer;
      92                              $ base for graph nodes
      93
      94      $ reprs for all procedures
      95
      96          intsof:    proc( remote mmap <>
      97                               set(elmt nodebase) ,
      98                           elmt nodebase )
      99                         smap(elmt nodebase) tuple(elmt nodebase);
     100          initvt:    proc( remote set(elmt nodebase) );
     101          collapse:  proc( elmt nodebase, elmt nodebase );
     102          vheadlim:  proc( elmt nodebase )
     103                         elmt nodebase;
     104          dfst:      proc( remote mmap <>
     105                               set(elmt nodebase),
     106                           elmt nodebase )
     107                         tuple( remote smap(elmt nodebase)
     108                               elmt nodebase,
     109                           remote smap(elmt nodebase) integer,
     110                           remote smap(elmt nodebase) integer,
     111                           remote smap(elmt nodebase) integer );
     112
     113      $ reprs for global variables
     114
     115          head:           local smap(elmt nodebase)
     116                              elmt nodebase;
     117                              $ maps each node to its interval head
     118          vpar:           local smap(elmt nodebase)
     119                              elmt nodebase;
     120                              $ parent mapping in virtual tree
     121          vndescs:        local smap(elmt nodebase) integer;
     122                              $ number of descendants in virtual tree
     123          vreps:          local smap(elmt nodebase)
     124                              elmt nodebase;
     125                              $ node represented by virtual tree root
     126
     127      $ reprs for examples
     128
     129          int_graph:      remote mmap <>
     130                              set(elmt nodebase);
     131          int_root:       elmt nodebase;
     132          int_intervals:  smap(elmt nodebase) tuple(elmt nodebase);
     133
     134      end repr;
     135
     136
     137      proc tarjan_test;
     138
     139      print_head('tarjan-s interval finder');
     140
     141      assert  intsof(int_graph, int_root) = int_intervals;
     142$     assert  intsof(str_graph, str_root) = str_intervals;
     143
     144      print_tail('tarjan-s interval finder (based version)');
     145
     146      end proc tarjan_test;
     147
     148
     149      proc intsof(graph, root);   $ tarjan-s interval finder
     150
     151
     152      repr
     153          intervals:      smap(elmt nodebase) tuple( elmt nodebase);
     154                              $ maps each interval head into its interva
     155          nodes:          remote set(elmt nodebase);
     156                              $ set of all graph nodes
     157          inverse:        remote mmap <>
     158                              set(elmt nodebase);
     159                              $ the inverse graph
     160          parent:         remote smap(elmt nodebase)
     161                              elmt nodebase;
     162                              $ parent mapping in depth first tree
     163          nodeno,
     164          postno:         remote smap(elmt nodebase) integer;
     165                              $ pre- and postorder node numbers
     166          ndescs:         remote smap(elmt nodebase) integer;
     167                              $ number of descendants in depth first tre
     168          nodevect:       smap(integer) elmt nodebase;
     169                              $ vector of nodes in nodeno order
     170          backedgesinv:   remote mmap <>
     171                              set(elmt nodebase);
     172                              $ set of all inverse back edges
     173          targbackedges:  remote set(elmt nodebase);
     174                              $ set of all back edge targets
     175          n:              integer;
     176                              $ do-loop counter
     177          x, y, z:        elmt nodebase;
     178                              $ particular nodes
     179          reachunder,
     180          newreachunder,
     181          newmorereachunder:
     182                          set(elmt nodebase);
     183                              $ growing 'reachunder' set and its parts
     184          rleftvec:       smap(integer) elmt nodebase;
     185                              $ nodes in right-to-left top-down order
     186
     187      end repr;
     188
     189      nodes := domain graph + range graph;  $ the nodes of the graph
     190
     191      $ compute the inverse of the graph
     192      inverse := << (/y,x/) : (/x,y/) in graph >>;
     193
     194      $ call depth first spanning tree routine, to return:
     195      $ parent := parent map in tree,
     196      $ nodeno := node number map in preorder,
     197      $ ndescs := number of descendants,
     198      $ postno := postorder number map of nodes.
     199      (/parent, nodeno, ndescs, postno/) := dfst(graph, root);
     200
     201      $ -nodevect- is the inverse of -nodeno-
     202      nodevect := << (/n,x/) : (/x,n/) in nodeno>>;
     203
     204      $ -backedgesinv- is the set of all inverse back edges
     205      backedgesinv := << (/y,x/) : (/x,y/) in graph st
     206                          nodeno(y) <= nodeno(x)
     207                          and nodeno(x) <= nodeno(y) + ndescs(y)>>;
     208
     209      targbackedges := domain backedgesinv; $ back edge targets
     210
     211      head := <>;   $ will map nodes to their interval heads
     212      initvt(nodes);  $ initialize virtual forest
     213
     214      $ process back edge targets right-to-left, bottom-up
     215      (forall n in (/ card nodevect, card nodevect-1...2 /) st
     216                      (x := nodevect(n)) in targbackedges)
     217
     218          reachunder := <>;
     219          newreachunder := << headlim(y) : y in backedgesinv<>>>;
     220          newreachunder less:= x;
     221
     222          $ start reachunder set, extend along reversed edges
     223          (while newreachunder /= <>)
     224              y from newreachunder;
     225              reachunder with:= y;
     226
     227              head(y) := x;   $ identify interval head
     228              collapse(y, x);   $ collapse y into x
     229
     230              if root in (morereachunder :=
     231                    <<>>>-reachunder) then
     232                  print('the graph is irreducible.');
     233                  stop;
     234              else
     235                  newreachunder := newreachunder + morereachunder;
     236              end if;
     237
     238          end while;
     239      end forall;
     240
     241
     242      $ the remaining nodes form the last acyclic interval.
     243      $ its head is root.  extend the 'head' mapping to these nodes.
     244      (forall y in nodes st head(y) = om)
     245          head(y) := root;
     246      end forall;
     247
     248
     249      $ next we walk the tree in right-to-left, top-down order
     250      $ to build the intervals
     251      rleftvec := << (/card nodes+1-n, x/) : (/x,n/) in postno>>;
     252      intervals := << (/x, (/x/)/) : x in range head>>;
     253
     254      (forall n in (/ 2...card rleftvec/))
     255      $ note that root is bypassed in this loop, as head(root)
     256      $ currently points to root, whereas it should be undefined.
     257          y := rleftvec(n);
     258          intervals(head(y)) with:= y;
     259      end forall;
     260
     261      return intervals;
     262
     263      end proc intsof;
     264
     265      proc initvt(nodes);     $ initialize virtual forest mappings
     266
     267
     268      repr
     269          x : elmt nodebase; $ a particular node
     270      end repr;
     271
     272      vpar    := <>;          $ virtual parent map
     273      vndescs := << (/x, 1/) : x in nodes >>;
     274                              $ number of descendants
     275      vreps   := << (/x, x/) : x in nodes >>;
     276                              $ node represented by virtual node
     277
     278      end proc initvt;
     279
     280
     281      proc collapse(y, x);   $ collapse y into x.
     282
     283      $ perform logical collapse of y into x, but use virtual
     284      $ tree and maintain its balance.
     285
     286
     287      repr
     288          rx, ry : elmt nodebase;  $ virtual roots of x, y
     289      end repr;
     290
     291      $ get roots for x and y
     292      rx := vheadlim(x);
     293      ry := vheadlim(y);
     294
     295      if vndescs(rx) < vndescs(ry) then $ subordinate y to x
     296          vpar(rx) := ry;
     297          vndescs(ry) := vndescs(rx) + vndescs(ry);
     298          vreps(ry) := x;
     299      else   $ subordinate x to y (reversed assignment)
     300          vpar(ry) := rx;
     301          vndescs(rx) := vndescs(rx) + vndescs(ry);
     302          vreps(rx) := x;
     303      end if;
     304
     305      end proc collapse;
     306
     307
     308      proc vheadlim(x);
     309
     310      $ locate virtual subtree root and compress path
     311
     312
     313      repr
     314          nd,
     315          par1,
     316          par2,
     317          par3:           elmt nodebase;
     318                              $ nodes on the path to top
     319          pathnodes:      set(elmt nodebase);
     320                              $ set of path nodes
     321      end repr;
     322
     323
     324      if (par1 := vpar(x)) = om then   $ top of tree
     325          return x;
     326      elseif (par2 := vpar(par1)) = om then  $ no need to compress
     327          return par1;
     328      else    $ climb to top and compress path
     329          pathnodes := <>;
     330          (while (par3 := vpar(par2)) /= om)
     331              $ pathnodes contains all but
     332              $ the last two nodes on the path
     333              pathnodes with:= par1;
     334              par1 := par2;
     335              par2 := par3;
     336          end while;
     337
     338          (forall nd in pathnodes)  $ compress path
     339              vpar(nd) := par2;
     340          end forall;
     341
     342          return par2;
     343      end if;
     344
     345      end proc vheadlim;
     346
     347
     348      proc dfst(graph, root); $ depth first spanning tree
     349
     350      $ builds depth first spanning tree and several auxiliary mappings
     351
     352
     353      repr
     354          x, y:           elmt nodebase;
     355          parent:         remote smap(elmt nodebase)
     356                              elmt nodebase;
     357          nodeno,
     358          ndescs,
     359          postno:         remote smap(elmt nodebase) integer;
     360          descs:          set(elmt nodebase);
     361          seen:           remote set(elmt nodebase);
     362          stk:            tuple(elmt nodebase);
     363      end repr;
     364
     365      parent := <>;           $ parent map in spanning tree
     366      nodeno := <>;           $ preorder node number
     367      ndescs := <>;           $ number of descendants
     368      postno := <>;           $ postorder node number
     369
     370      seen := <>;             $ nodes processed
     371      stk  := (//);           $ stack of ancestors
     372      x    := root;
     373
     374      loop do
     375          if x notin seen then $ a new node
     376              nodeno(x) := card nodeno + 1; $ preorder number
     377              ndescs(x) := 0; $ initialize descendant count
     378              seen with:= x;
     379          end if;
     380
     381
     382          if (descs := graph<> - seen) /= <> then
     383              y := arb descs; $ descend in search to y
     384              stk with:= x;     $ stacking x
     385              x := y;
     386          else                $ ascend in stack
     387              postno(x) := card postno + 1;
     388              if stk = (//) then
     389                  quit loop;  $ last time at the root
     390              else            $ ascend to the parent of x
     391                  y frome stk;
     392                  parent(x) := y;
     393                              $ update parent map
     394                  ndescs(y) := ndescs(y) + ndescs(x) + 1;
     395                              $ update descendant count
     396                  x := y;
     397              end if;
     398          end if;
     399      end loop;
     400
     401      return (/parent, nodeno, ndescs, postno/);
     402
     403      end proc dfst;
     404
     405      drop headlim;
     406
     407      end module test - tarjan;
     408
     409
       1 .=member iter1
       2      module test - iterators_1;
       3
       4          $ nyu test id
       5          $ author - r. lee (nyu-cims)
       6
       7          exports
       8              iterator_test_1;
       9
      10          reads
      11              print_mode;
      12
      13          const
      14              lim   = 5,
      15              bfact = 300000;
      16
      17
      18          var
      19              sum,            $ accumulate sum
      20
      21              std_set,        $ unbased set of small integers
      22              big_set,        $ unbased set of large integers
      23              neg_set,        $ unbased set of small negative integers
      24              bneg_set,       $ unbased set of large negative integers
      25
      26              tup,            $ unbased tuple of small integers
      27              tup_neg,        $ unbased tuple of small negative integers
      28              tup_big,        $ unbased tuple of large integers
      29              tup_bneg,       $ unbased tuple of large negative integers
      30
      31              locset,         $ local set of small integers
      32              remset,         $ remote set of small integers
      33              locbset,        $ local set of large integers
      34              rembset,        $ remote set of large integers
      35              locnset,        $ local set of small negative integers
      36              remnset,        $ remote set of small negative integers
      37              locbnset,       $ local set of large negative integers
      38              rembnset,       $ remote set of large negative integers
      39
      40              locset2,        $ copies of the above sets
      41              remset2,
      42              locbset2,
      43              rembset2,
      44              locnset2,
      45              remnset2,
      46              locbnset2,
      47              rembnset2,
      48
      49              etup,           $ tuple of small positive based integers
      50              utup,           $ tuple of small positive untyped integers
      51              etup_big,       $ tuple of large positive based integers
      52              utup_big,       $ tuple of large positive untyped integers
      53              etup_neg,       $ tuple of small negative based integers
      54              utup_neg,       $ tuple of small negative untyped integers
      55              etup_bneg,      $ tuple of large negative based integers
      56              utup_bneg;      $ tuple of large negative untyped integers
      57
      58
      59          repr
      60
      61              base intb:     integer;   $ base for all integers, etc.
      62
      63              locset:         local  set(elmt intb);
      64              remset:         remote set(elmt intb);
      65              locbset:        local  set(elmt intb);
      66              rembset:        remote set(elmt intb);
      67
      68              locnset:        local  set(elmt intb);
      69              remnset:        remote set(elmt intb);
      70              locbnset:       local  set(elmt intb);
      71              rembnset:       remote set(elmt intb);
      72
      73              locset2:        local  set(elmt intb);
      74              remset2:        remote set(elmt intb);
      75              locbset2:       local  set(elmt intb);
      76              rembset2:       remote set(elmt intb);
      77              locnset2:       local  set(elmt intb);
      78              remnset2:       remote set(elmt intb);
      79              locbnset2:      local  set(elmt intb);
      80              rembnset2:      remote set(elmt intb);
      81
      82              etup:           tuple(elmt intb);
      83              utup:           tuple(untyped integer);
      84              etup_big:       tuple(elmt intb);
      85              utup_big:       tuple(untyped integer);
      86              etup_neg:       tuple(elmt intb);
      87              utup_neg:       tuple(untyped integer);
      88              etup_bneg:      tuple(elmt intb);
      89              utup_bneg:      tuple(untyped integer);
      90
      91          end repr;
      92
      93
      94      proc iterator_test_1;
      95
      96      print_head('iterator tests');
      97      print_head('iterator test 1');
      98      print;
      99
     100      if print_mode >= print_full then
     101          print;
     102          print('commencing aritmetic tests with limit =', lim,
     103              ', bfact =', bfact, '.');
     104      end if;
     105
     106      sum      := 0;          $ accumulate sum
     107      sum_big  := 0;          $ accumulate sum of large integers
     108      sum_neg  := 0;          $ accumulate sum of negatives
     109      sum_bneg := 0;          $ accumulate sum of large negatives
     110      sum_nbig := 0;          $ large negatives by subtraction
     111
     112      std_set  := nullset;    $ set of integers
     113      big_set  := nullset;    $ set of big integers
     114      neg_set  := nullset;    $ set of negatives
     115      bneg_set := nullset;    $ set of big negatives
     116
     117      tup      := nulltup;    $ tuple of integers
     118      tup_neg  := nulltup;    $ tuple of negatives
     119      tup_big  := nulltup;    $ tuple of big integers
     120      tup_neg  := nulltup;    $ tuple of negatives
     121      tup_bneg := nulltup;    $ tuple of big negatives
     122
     123      (forall k in (/1...lim/))      $ iterative addition loop
     124
     125          kbig := k * bfact;  $ calculate big integers
     126
     127          sum      +:= k;     $ calculate total in various ways
     128          sum_big  +:= kbig;
     129          sum_neg  +:= - k;
     130          sum_bneg +:= - kbig;
     131          sum_nbig -:= kbig;  $ calculate by subtraction
     132
     133          std_set  with:= k;
     134          big_set  with:= kbig;
     135          neg_set  with:= - k;
     136          bneg_set with:= - kbig;
     137
     138          tup      with:= k;
     139          tup_big  with:= kbig;
     140          tup_neg  with:= - k;
     141          tup_bneg with:= - kbig;
     142
     143      end forall;
     144
     145      print_line('test the (unbased) sums.');
     146
     147      assert  sum = sum_big div bfact;      $ long int
     148      assert  sum = -sum_neg;               $ neg arithmetic
     149      assert  sum = -sum_bneg div bfact;    $ long neg arithmetic
     150      assert  sum = +/std_set;              $ set member add
     151      assert  sum = (+/big_set) div bfact;  $ long member add
     152      assert  sum = -(+/neg_set);           $ neg member add
     153      assert  sum = (+/bneg_set)div -bfact; $ long neg member add
     154      assert  sum = +/tup;                  $ component add
     155      assert  sum = (+/tup_big) div bfact;  $ long component add
     156      assert  sum = -(+/tup_neg);           $ neg component add
     157      assert  sum = (+/tup_bneg) div -bfact;$ long neg component add
     158
     159      print_line('repeat the tests after conversion to based cases.');
     160
     161      locset   := std_set;             $ local basing
     162      remset   := std_set;             $ remote basing
     163      locbset  := big_set;             $ local based,big set
     164      rembset  := big_set;             $ remote based,big set
     165      locnset  := neg_set;             $ local neg set
     166      remnset  := neg_set;             $ remote neg set
     167      locbnset := bneg_set;            $ local long neg set
     168      rembnset := bneg_set;            $ remote long neg set
     169
     170      assert  std_set  = locset;       $ local integer basing
     171      assert  std_set  = remset;       $ remote integer basing
     172      assert  big_set  = locbset;      $ local long integer basing
     173      assert  big_set  = rembset;      $ remote long integer basing
     174      assert  neg_set  = locnset;      $ local negint basing
     175      assert  neg_set  = remnset;      $ remote negint basing
     176      assert  bneg_set = locbnset;     $ local long negint basing
     177      assert  bneg_set = rembnset;     $ remote long negint basing
     178
     179      assert  sum = +/locset;               $ loc int sum
     180      assert  sum = +/remset;               $ rem int sum
     181      assert  sum = (+/locbset) div bfact;  $ loc long int sum
     182      assert  sum = (+/rembset) div bfact;  $ rem long int sum
     183      assert  sum = -(+/locnset);           $ loc neg sum
     184      assert  sum = -(+/remnset);           $ rem neg sum
     185      assert  sum = (+/locbnset)div -bfact; $ loc long neg int sum
     186      assert  sum = (+/rembnset)div -bfact; $ rem long neg int sum
     187
     188
     189      print_line('copy the sets, and remove an element.');
     190      print_line('check proper observance of the copy semantic.');
     191
     192      set2      := std_set;        std_set  := std_set  less n;
     193      big_set2  := big_set;        big_set  := big_set  less n;
     194      neg_set2  := neg_set;        neg_set  := neg_set  less n;
     195      bneg_set2 := bneg_set;       bneg_set := bneg_set less n;
     196      locset2   := locset;         locset   := locset   less n;
     197      remset2   := remset;         remset   := remset   less n;
     198      locbset2  := locbset;        locbset  := locbset  less n;
     199      rembset2  := rembset;        rembset  := rembset  less n;
     200      locnset2  := locnset;        locnset  := locnset  less n;
     201      remnset2  := remnset;        remnset  := remnset  less n;
     202      locbnset2 := locbnset;       locbnset := locbnset less n;
     203      rembnset2 := rembnset;       rembnset := rembnset less n;
     204
     205      assert  set2      = locset2;     $ local set deletion
     206      assert  set2      = remset2;     $ remote set deletion
     207      assert  big_set2  = locbset2;    $ loc long int set deletion
     208      assert  big_set2  = rembset2;    $ rem long int set deletion
     209      assert  neg_set2  = locnset2;    $ loc neg int set deletion
     210      assert  neg_set2  = remnset2;    $ rem neg int set deletion
     211      assert  bneg_set2 = locbnset2;   $ loc long neg set deletion
     212      assert  bneg_set2 = rembnset2;   $ rem long neg set deletion
     213
     214      assert  sum = +/set2;            $ sum after deletion
     215      assert  sum = (+/big_set2) div bfact; $ long sum after deletion
     216      assert  sum = -(+/neg_set2);     $ neg sum after deletion
     217      assert  sum = (+/bneg_set)div -bfact; $ long neg after deletion
     218
     219      print_line('repeat the sequence of copy tests for tuples.');
     220
     221      tup2      := tup;            tup      with:= 1;
     222      tup2_big  := tup_big;        tup_big  with:= 1;
     223      tup2_neg  := tup_neg;        tup_neg  with:= 1;
     224      tup2_bneg := tup_bneg;       tup_bneg with:= 1;
     225
     226      assert  sum = +/tup2;            $ tup sum extension
     227      assert  sum = (+/tup2_big) div bfact; $ tup long sum extension
     228      assert  sum = -(+/tup2_neg);     $ tup neg sum extension
     229      assert  sum = (+/tup2_bneg) div -bfact;    $ long neg sum ext
     230
     231      print_line('perform a series of explicit loop tests.');
     232
     233      assert  sum = sumof(set2);       $ sum maniter
     234      assert  sum = sumof(locset2);    $ loc sum maniter
     235      assert  sum = sumof(remset2);    $ rem sum maniter
     236      assert  sum = sumof(big_set2) div bfact;   $ long sum maniter
     237      assert  sum = sumof(locbset2) div bfact;   $ loc long sum maniter
     238      assert  sum = sumof(rembset2) div bfact;   $ rem long sum maniter
     239      assert  sum = -sumof(neg_set2);  $ neg sum maniter
     240      assert  sum = -sumof(locnset2);  $ loc neg sum maniter
     241      assert  sum = -sumof(remnset2);  $ rem neg sum maniter
     242      assert  sum = sumof(bneg_set2) div -bfact; $ long neg sum maniter
     243      assert  sum = sumof(locbnset2) div -bfact; $ loc long neg sum man
     244      assert  sum = sumof(rembnset2) div -bfact; $ rem long neg sum man
     245
     246      print_line('perform a series of tests on based tuples.');
     247
     248      etup      := tup2;
     249      utup      := tup2;
     250      etup_big  := tup2_big;
     251      utup_big  := tup2_big;
     252      etup_neg  := tup2_neg;
     253      utup_neg  := tup2_neg;
     254      etup_bneg := tup2_bneg;
     255      utup_bneg := tup2_bneg;
     256
     257      assert sum = tupsum(etup);       $ tupsum maniter elements
     258      assert sum = tupsum(utup);       $ tupsum maniter untyped
     259      assert sum = tupsum(etup_big) div bfact;   $
     260      assert sum = tupsum(utup_big) div bfact;   $
     261      assert sum = -tupsum(etup_neg);  $ neg tupsum maniter elements
     262      assert sum = -tupsum(utup_neg);  $ neg tupsum maniter untyped
     263      assert sum = -tupsum(etup_bneg) div bfact; $
     264      assert sum = -tupsum(utup_bneg) div bfact; $
     265
     266      print_tail('iterator test 1');
     267
     268
     269      end proc iterator_test_1;
     270
     271
     272      proc sumof(rw setup);   $ calculates sum by manual iteration
     273
     274      sum1 := 0;
     275
     276      loop do
     277
     278          x from setup;
     279          if x=om then quit; end;
     280          sum1 +:= x;
     281
     282      end;
     283
     284      return sum1;
     285
     286      end proc sumof;
     287
     288
     289      procedure tupsum(x);    $ calculates sum by manual iteration
     290
     291      y := 0;
     292
     293      loop do
     294
     295          z frome x;
     296          if z = om then quit; end;
     297          y +:= z;
     298
     299      end;
     300
     301      return y;
     302
     303      end procedure tupsum;
     304
     305
     306      end module test - iterators_1;
     307
     308
     309
     310
       1 .=member iter2
       2      module test - iterators_2;
       3
       4          exports
       5              iterator_test_2;
       6
       7          reads
       8              print_mode;
       9
      10
      11      var
      12          i, j, k, n,
      13
      14          unbased_set_1,
      15          unbased_set_2,
      16          unbased_set_3,
      17          unbased_set_4,
      18          unbased_set_6,
      19          unbased_set_8,
      20
      21          unbased_map_1,
      22          unbased_map_2,
      23          unbased_map_3,
      24          unbased_map_4,
      25          unbased_map_5,
      26          unbased_map_6,
      27
      28          unbased_mmap_1,
      29          unbased_mmap_2,
      30          unbased_mmap_3,
      31          unbased_mmap_4,
      32
      33          unbased_tup_1,
      34          unbased_tup_2,
      35          unbased_tup_3,
      36          unbased_tup_4,
      37
      38          loc_set_1,
      39          loc_set_5,
      40
      41          rem_set_1,
      42          rem_set_7,
      43
      44          rem_mmap_1,
      45          rem_mmap_2,
      46          loc_mmap_1,
      47
      48          packed_int_tup_1,
      49          untyped_real_tup,
      50          untyped_int_tup_1,
      51          untyped_int_tup_2;
      52
      53
      54      repr
      55          i, j, k, n:         integer 1...100;
      56
      57          base ibase:        integer;
      58          base tint:         tuple(integer);
      59          base tibase:       tuple(elmt ibase);
      60
      61          loc_set_1:          local  set(elmt ibase);
      62          loc_set_5:          local  set(elmt tint);
      63          rem_set_1:          remote set(elmt ibase);
      64          rem_set_7:          remote set(elmt tibase);
      65
      66          rem_mmap_1:         remote mmap <>
      67                                  set(elmt ibase);
      68          loc_mmap_1:         local mmap <>
      69                                  remote set(elmt ibase);
      70          rem_mmap_2:         remote mmap <>
      71                                  mmap <<*>>
      72                                      remote smap (elmt ibase)
      73                                          integer;
      74
      75          packed_int_tup_1:   packed tuple(integer 1...66);
      76          untyped_real_tup:   tuple(untyped real);
      77          untyped_int_tup_1:  tuple(untyped integer);
      78          untyped_int_tup_2:  tuple(untyped integer);
      79
      80      end repr;
      81
      82
      83      $       iterator tests
      84
      85      $   in this series of tests we iterate over
      86      $   a variety of sets and tuples, using the
      87      $   iteration to rebuild them, and then checking
      88      $   equality between the original and the rebuilt
      89      $   object.
      90
      91      $   we build up a set of objects
      92      $ having a variety of forms to which the
      93      $ iterator routines are sensitive, and then
      94      $ test the iterators by rebuilding the sets
      95      $ iteratively and testing for equality after rebuild
      96
      97
      98      proc iterator_test_2;
      99
     100      print_head('iterator test 2');
     101
     102      $ build a general (unbased) tuple, set, and map
     103      unbased_set_1 := nullset;
     104      unbased_map_1 := nullset;
     105      unbased_tup_1 := nulltup;
     106
     107      (forall n in (/ 1...10 /))
     108          unbased_tup_1 with:= n;
     109          unbased_set_1 with:= n;
     110          unbased_map_1(n) := 2*n + 1;
     111      end forall;
     112
smff   8      $ -unbased_tup_2- is undefined for various indices
     114      unbased_tup_2    := unbased_tup_1;
     115      unbased_tup_2(2) := unbased_tup_2(4) := unbased_tup_2(10) := om;
     116
     117      $ -unbased_tup_3- has an undefined initial segment
     118      unbased_tup_3    := unbased_tup_2;
     119      unbased_tup_3(1) := om;
     120
     121      $ unbased_tup_4 will be totally undefined since the initial
     122      $ segement of -unbased_tup_3- is undefined.
     123      unbased_tup_4 := unbased_tup_3(1...2);
     124
     125      $ check conversions between different representations
     126      packed_int_tup_1  := unbased_tup_1;
     127      untyped_int_tup_1 := unbased_tup_1;
     128
     129      $ build tuples of untyped values
     130      untyped_real_tup  := (/ float j : j in (/1...10/) /);
     131      untyped_int_tup_2 := (/1...10/);
     132
     133      loc_set_1 := unbased_set_1 - <<1, 3, 5, 6>>;
     134
     135      $ build a general (unbased) multi-valued map
     136      unbased_mmap_1 := unbased_map_1;
     137      (forall x in unbased_map_1 st x(1) > 5)
     138          unbased_mmap_1<> with:= x(2)+1;
     139      end forall;
     140
     141      $ build a general (unbased) map with both single- and multi-
     142      $ valued points
     143      unbased_map_2 := unbased_mmap_1;
     144      (forall n in (/ 1...5 /))
     145          unbased_map_2(n) := 2*n;
     146      end forall;
     147
     148      $ now we build up a variety of multiparameter
     149      $ maps to test the more complex iterator cases
     150
     151      $ doubly indexed map
     152      unbased_mmap_2 := << (/i, (/j, i+j/) /) :
     153                                i in (/1...10/),
     154                                    j in (/1...5/) >>;
     155
     156      $ delete some points from -unbased_mmap_2-
     157      unbased_mmap_3 := unbased_mmap_2;
     158      (forall i in (/ 1...5 /))
     159          unbased_mmap_3(i, i) := om;
     160      end forall;
     161
     162      $ delete all points from -unbased_mmap_3-
     163      unbased_map_3 := unbased_mmap_3;
     164      (forall i in (/ 1...10 /), j in (/ 1...5 /))
     165          unbased_map_3(i, j) := om;
     166      end forall;
     167
     168      rem_mmap_1 := << (/i, 2*i/) : i in (/1...10/) >>
     169                      + <<(/i, 3*i/): i in (/1...5/)>>;
     170      loc_mmap_1 := rem_mmap_1;
     171
     172      $ build a triply indexed map
     173      unbased_mmap_4 := << (/i, (/j, (/k, 3*k - 1/) /) /) :
     174                                i in (/1...5/),
     175                                    j in (/1...4/),
     176                                        k in (/1...3/) >>;
     177
     178      rem_mmap_2 := unbased_mmap_4;
     179
     180      $ build a set of tuples
     181      unbased_set_4 := << (/i, i+1/) : i in (/1...10/) >>;
     182
     183      $ check conversions between different representations
     184      loc_set_5 := unbased_set_4;
     185      rem_set_7 := loc_set_5;
     186
     187      $ create a set of strings
     188      unbased_set_8 := << i*'a' + 'b'*j + k*'c' :
     189                             i in (/1...3/),
     190                                 j in (/1...3/),
     191                                     k in (/1...3/) >>;
     192
     193      $ build a set of unit tuples
     194      unbased_set_6 := << (/i/) : i in (/1...10/) >>;
     195
     196      $ remove several elements from -unbased_mmap_1-
     197      unbased_map_4 := unbased_mmap_1;
     198      unbased_map_4 lessf:= 3;
     199      unbased_map_4(10) := om;
     200      unbased_map_4<<1>>  := nullset;
     201
     202      $ extend and restrict -unbased_mmap_1-
     203      unbased_map_5 := unbased_mmap_1
     204                           + << (/i, i*i/) : i in (/1...5/) >>
     205                               - <<(/5, 11/), (/6, 14/), (/1, 1/)>>;
     206
     207      unbased_map_6 := << (/x, x + x*10 /) : x in unbased_set_1 >>;
     208
     209      rem_set_1 := unbased_set_1;
     210
     211      unbased_set_2 := unbased_set_1;
     212      unbased_set_2 with:= 20;
     213      unbased_set_2 with:= 100;
     214      unbased_set_2 with:= -5;
     215
     216      unbased_set_2 less:= 2;
     217      unbased_set_2 less:= 4;
     218      unbased_set_2 less:= 10;
     219
     220
     221      print_line('start execution of iteration test 2.');
     222
     223      rebtestt(unbased_tup_1,     'tuple of integers');
     224      rebtests(unbased_map_1,     'integer-valued map');
     225      rebtests(loc_set_1,         'local set of integers');
     226
     227      rebtests(<>,                'null set');
     228      rebtestt((//),                'null tuple');
     229      rebtests(<<1>>,               'unit set');
     230      rebtestt((/1/),               'unit tuple');
     231
smff   9      tup_denot_2 := [];
smff  10      tup_denot_2(1) := 1; tup_denot_2(3) := 3;
smff  11      tup_denot_2(5..9) := [ 5, 6, 7, 8, 9 ];
smff  12      assert  unbased_tup_2 = tup_denot_2;
smff  13
smff  14      tup_denot_3 := [];
smff  15      tup_denot_3(3) := 3;
smff  16      tup_denot_3(5..9) := [ 5, 6, 7, 8, 9 ];
smff  17      assert  unbased_tup_3 = tup_denot_3;
smff  18
     234      rebtestt(unbased_tup_4,     'generated null tuple');
     235
     236      rebtestc('abcde',           'long string');
     237
     238      rebtests(unbased_set_4,     'set of tuples');
     239      rebtests(loc_set_5,         'local set of tuples');
     240      rebtests(rem_set_7,         'remote set of tuples');
     241      rebtests(unbased_set_6,     'set of unit tuples');
     242      rebtests(unbased_set_8,     'set of character strings');
     243
     244      rebtestt(packed_int_tup_1,  'packed tuple');
     245      rebtestt(untyped_real_tup,  'real tuple');
     246      rebtestt(untyped_int_tup_1, 'integer tuple');
     247      rebtestt(untyped_int_tup_2, 'integer tuple');
     248
     249      rebtests(unbased_mmap_1,    'multi-valued map');
     250      rebtests(unbased_map_2,     'multi-map with some sval elts');
     251      rebtests(unbased_mmap_2,    'double indexed map');
     252      rebtests(unbased_mmap_3,    'double indexed map with degen locs');
     253
     254      rebtests(unbased_map_3,     'multi-valued nullmap');
     255      rebtests(rem_mmap_1,        'remote map with set range');
     256      rebtests(loc_mmap_1,        'local map with remote range');
     257      rebtests(unbased_mmap_4,    'triply indexed map');
     258      rebtests(rem_mmap_2,        'triply indexed map');
     259
     260      rebtests(unbased_map_4,     'map with deleted elements');
     261      rebtests(unbased_map_5,     'map after expansion and deletion');
     262      rebtests(unbased_map_6,     'set after conversion to map');
     263      rebtests(rem_set_1,         'remote set of integers');
     264      rebtests(unbased_set_2,     'set after expansion and deletion');
     265
     266
     267      print_tail('iterator test 2');
     268
     269      end proc iterator_test_2;
     270
     271
     272      proc rebtests(rd sett, rd mesg);
     273
     274      $ this iterates over a set to rebuild it and
     275      $ then tests for equality between the original
     276      $ and the rebuilt copy
     277
     278      news := nullset;
     279
     280      (forall x in sett)
     281          news with:= x;
     282      end forall;
     283
     284      assert  sett = news;
     285
     286      end proc rebtests;
     287
     288
     289      proc rebtestt(rd tup, rd mesg);
     290
     291      $ this is the tuple analog of rebtests
     292
     293      newt:=nulltup;
     294
     295      (forall x = tup(j))
     296          newt with:= x;
     297      end forall;
     298
     299      assert  tup = newt;
     300
     301      end proc rebtestt;
     302
     303
     304      proc rebtestc(rd cstr, rd mesg);
     305
     306      $ this is the string analog of rebtests
     307
     308      newc:= nullstring;
     309
     310      (forall n in (/ 1...card cstr /))
     311          newc +:= cstr(n);
     312      end forall;
     313
     314      assert  cstr = newc;
     315
     316      end proc rebtestc;
     317
     318
     319      end module test - iterators_2;
     320
     321
     322
     323
       1 .=member testio
       2      module test - input_output;
       3
       4          $ nyu test id
       5          $ author - j. schwartz
       6          $ logged in as jts15 (20 jan 79)
       7          $ passed xsetl 30 jan 79
       8
       9          exports
      10              tree_print;
      11
      12          reads
      13              print_mode;
      14
      15          var
      16              left_child,
      17              right_child,
      18              value,
      19              blanks;
      20
      21
      22      proc tree_print;   $ indenting tree print program
      23
      24      print_head('tree print');
      25
smff  19      l := []; l(1) := 2; l(2) := 4; l(5) := 6; l(6) := 7;
smff  20      r := []; r(1) := 3; r(3) := 5; r(5) := 9; r(6) := 8; r(9) := 10;
      28
      29      l := << (/i,n/) : n = l(i) st n /= om >>;
      30      r := << (/i,n/) : n = r(i) st n /= om >>;
      31
      32      vall := << (/i,i/) : i in (/1...10/) >>;
      33
      34      print('the following should be aligned:'
      35            ' 1, 2-3, 4-5, 6-9, 7-8-10');
      36      tprint(l, r, vall, 1);
      37
      38      print_tail('tree print');
      39
      40      end proc tree_print;
      41
      42
      43      proc tprint(l, r, vall, topp);  $ binary tree print routine
      44
      45      $ n.b. left_child,right_child,value,blanks must be global
      46      left_child := l;   right_child := r;   value := vall;
      47      blanks := 44 * ' ';
      48
      49      tp(topp, 1);
      50
      51      end proc tprint;
      52
      53
      54      proc tp(node,level);
      55
      56      if node=om then return; end;
      57
      58      print(blanks(1..4*(level mod 12)), value(node));
      59
      60      tp(left_child(node),  level+1);
      61      tp(right_child(node), level+1);
      62
      63      end proc tp;
      64
      65
      66      end module test - input_output;
      67
      68
      69
      70

« October 2024 »
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: