MUDDLE/tester.putget

   1 ;"TESTER FOR PUT-GET ASSOCIATIONS"
   2 ;"MAKES RANDOM ASSOCIATIONS THEN CHECKS LATER TO SEE IF MISSING"
   3
   4 <SETG TEST <FUNCTION ("OPTIONAL" (COUNT <MIN>) (OUTCHAN .OUTCHAN)
   5         "EXTRA" (X ()) (Y ()) (Z ()))
   6         <REPEAT (I)
   7                 <SET I <MIN 1000 <MOD <RANDOM> .COUNT>>>
   8                 <SET COUNT <- .COUNT .I>>
   9                 <MAKE-ASSOCS .I>
  10                 <IVECTOR 5000>  ;"CALL GARBAGE COLLECTOR"
  11                 <CHECK-ASSOCS .I TENTATIVE>
  12                 <COND (<L? .COUNT 1> <RETURN "DONE">)>>
  13         <CHECK-ASSOCS <LENGTH .X> FINAL>>>
  14
  15 <SETG MAKE-ASSOCS <FUNCTION (I)
  16         <REPEAT ()
  17                 <SET X (<MAKE-OBJ> !.X)>
  18                 <SET Y (<MAKE-OBJ> !.Y)>
  19                 <SET Z (<MAKE-OBJ> !.Z)>
  20                 <PUT <1 .X> <1 .Y> <1 .Z>>      ;"DO THE ASSOCIATION"
  21                 <CHECK-ASSOCS 1 INITIAL>
  22                 <COND (<0? <DEC I>> <RETURN "DONE">)>>>>
  23
  24 <SETG MAKE-OBJ <FUNCTION ("EXTRA" (N <MOD <RANDOM> 19>))
  25         <COND   (<0? .N> <IVECTOR <MOD <RANDOM> 10> <MAKE-OBJ>>)
  26                 (<1? .N> <IUVECTOR <MOD <RANDOM> 10> <MAKE-OBJ>>)
  27                 (<L? .N 3> <ILIST <MOD <RANDOM> 10> <MAKE-OBJ>>)
  28                 (<L? .N 4> <ISTRING <MOD <RANDOM> 10> !"A>)
  29                 (<L? .N 5> <<+ 1 <MOD <RANDOM> <LENGTH .X>>> .X>)
  30                 (<L? .N 6> <<+ 1 <MOD <RANDOM> <LENGTH .Y>>> .Y>)
  31                 (<L? .N 7> <<+ 1 <MOD <RANDOM> <LENGTH .Z>>> .Z>)
  32                 (<L? .N 10> <ATOM <ISTRING <MOD <RANDOM> 10>
  33                                 <ASCII <MOD <RANDOM> 127>>>>)
  34                 (<L? .N 16> <CHTYPE <RANDOM> FLOAT>)
  35                 (<L? .N 19> <ASCII <MOD <RANDOM> 127>>)>>>
  36
  37
  38 <SETG CHECK-ASSOCS <FUNCTION (I LEVEL)
  39         <REPEAT ((X .X) (Y .Y) (Z .Z))
  40                 <COND (<NOT <==? <GET <1 .X> <1 .Y>>
  41                                 <1 .Z>>>
  42                         <PRINT .LEVEL>
  43                         <PRIN1 LOSER>
  44                         <TERPRI>
  45                         <PRINT-ASSOC 0>
  46                         <PUT .X 1 0>
  47                         <PUT .Y 1 0>
  48                         <PUT .Z 1 0>)>
  49                 <CHOP X>
  50                 <CHOP Y>
  51                 <CHOP Z>
  52                 <COND (<0? <DEC I>> <RETURN "DONE">)>>>>
  53
  54
  55 <PUT 0 0 0>
  56
  57
  58 <SETG PRINT-ASSOC <FUNCTION (K)
  59         <INDENT-TO .K>
  60         <PRINC "ITEM: ">
  61         <PRINT-IT <1 .X> <+ .K 10>>
  62         <INDENT-TO .K>
  63         <PRINC "INDIC: ">
  64         <PRINT-IT <1 .Y> <+ .K 10>>
  65         <INDENT-TO .K>
  66         <PRINC "VALUE: ">
  67         <PRINT-IT <1 .Z> <+ .K 10>>>>
  68
  69
  70
  71 <SETG PRINT-IT <FUNCTION (IT K)
  72         <PRINC <TYPE .IT>>
  73         <COND   (<MONAD? .IT> <TERPRI>)
  74                 (ELSE
  75                  <PRINC " LENGTH: ">
  76                  <PRINC <LENGTH .IT>>
  77                  <PRINC " OF:">
  78                  <TERPRI>
  79                  <INDENT-TO .K>
  80                  <PRINT-IT <1 .IT> <+ .K 10>>)>
  81         <COND (<MEMQ .IT <REST .X>>
  82                 <INDENT-TO .K>
  83                 <PRINC "***SHARED ITEM">
  84                 <TERPRI>)>
  85         <COND (<MEMQ .IT <REST .Y>>
  86                 <INDENT-TO .K>
  87                 <PRINC "***SHARED INDIC">
  88                 <TERPRI>)>
  89         <COND (<MEMQ .IT <REST .Z>>
  90                 <INDENT-TO .K>
  91                 <PRINC "***SHARED VALUE">
  92                 <TERPRI>)>>>
  93 \f\ 3\f