home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / adaptor.zip / adapt.zip / adaptor / src / globals.c < prev    next >
Text File  |  1994-01-03  |  29KB  |  1,261 lines
  1. # include "Globals.h"
  2. # include "yyGlobal.w"
  3. # include <stdio.h>
  4. # if defined __STDC__ | defined __cplusplus
  5. #  include <stdlib.h>
  6. # else
  7.    extern void exit ();
  8. # endif
  9. # include "Tree.h"
  10. # include "Definiti.h"
  11.  
  12. # ifndef NULL
  13. # define NULL 0L
  14. # endif
  15. # ifndef false
  16. # define false 0
  17. # endif
  18. # ifndef true
  19. # define true 1
  20. # endif
  21.  
  22. # ifdef yyInline
  23. # define yyALLOC(tree, free, max, alloc, nodesize, make, ptr, kind) \
  24.   if ((ptr = (tree) free) >= (tree) max) ptr = alloc (); \
  25.   free += nodesize [kind]; \
  26.   ptr->yyHead.yyMark = 0; \
  27.   ptr->Kind = kind;
  28. # else
  29. # define yyALLOC(tree, free, max, alloc, nodesize, make, ptr, kind) ptr = make (kind);
  30. # endif
  31.  
  32. # define yyWrite(s) (void) fputs (s, yyf)
  33. # define yyWriteNl (void) fputc ('\n', yyf)
  34.  
  35. # line 49 "Globals.puma"
  36.  
  37. # include "Idents.h"
  38. # include "StringMe.h"
  39. # include "Types.h"      /* IntrFuncRed */
  40. # include "protocol.h"
  41.  
  42. # include "MoveCont.h"          /* CountMovement */
  43. # include "Transfor.h"            /* ExpToVarParam */
  44.  
  45. # include "Dalib.h"                /* DALIB parameters */
  46. # include "Expressi.h"          /* MakeConstant     */
  47.  
  48.  
  49. static FILE * yyf = stdout;
  50.  
  51. static void yyAbort
  52. # ifdef __cplusplus
  53.  (char * yyFunction)
  54. # else
  55.  (yyFunction) char * yyFunction;
  56. # endif
  57. {
  58.  (void) fprintf (stderr, "Error: module Globals, routine %s failed\n", yyFunction);
  59.  exit (1);
  60. }
  61.  
  62. static bool FullParameters ARGS((tTree plist));
  63. static void GlobalTestFullParams ARGS((tTree plist));
  64. static void GlobalTestIndexes ARGS((tTree a, tTree indexlist, int n));
  65. static void CheckIndexParam ARGS((tTree a, tTree p, tTree ptype));
  66. static void GlobalTestConform ARGS((tTree a, tTree b));
  67. static void GlobalTestMask ARGS((tTree a, tTree mask, tTree masktype));
  68. void SplitGet ARGS((tTree params, int * rank, tTree * A_, tTree * B_, tTree * indexes, tTree * Mask));
  69. void SplitSend ARGS((tTree params, int * rank, tTree * A_, tTree * B_, tTree * indexes, tTree * Mask, tTree * op));
  70. static void SplitParams ARGS((tTree plist, int n, tTree * tail));
  71. static void FindGetMask ARGS((tTree plist, tTree * mask));
  72. static void FindSend ARGS((tTree plist, tTree * arr, tTree * mask, tTree * op));
  73. void CheckGlobalGetParams ARGS((tTree parameter_list));
  74. void CheckGlobalSendParams ARGS((tTree parameter_list));
  75. tTree GenGlobalGet ARGS((tTree parameter_list));
  76. tTree GenGlobalSend ARGS((tTree parameter_list));
  77. static void GetTheIndexes ARGS((tTree indexes, int rank, tTree * last));
  78. static void ConcatParams ARGS((tTree indexes, tTree params));
  79. static int GenGlobalSendOp ARGS((tTree type, tIdent redfunc));
  80. static tIdent FuncName ARGS((tTree f));
  81.  
  82. static bool FullParameters
  83. # if defined __STDC__ | defined __cplusplus
  84. (register tTree plist)
  85. # else
  86. (plist)
  87.  register tTree plist;
  88. # endif
  89. {
  90.   if (plist == NoTree) return false;
  91.   if (plist->Kind == kBTP_LIST) {
  92.   if (plist->BTP_LIST.Elem->Kind == kVAR_PARAM) {
  93.   if (plist->BTP_LIST.Elem->VAR_PARAM.V->Kind == kUSED_VAR) {
  94. # line 72 "Globals.puma"
  95.   {
  96. # line 73 "Globals.puma"
  97.    if (! (FullParameters (plist->BTP_LIST.Next))) goto yyL1;
  98.   }
  99.    return true;
  100. yyL1:;
  101.  
  102.   }
  103.   }
  104.   if (plist->BTP_LIST.Elem->Kind == kFUNC_PARAM) {
  105.   if (plist->BTP_LIST.Next->Kind == kBTP_EMPTY) {
  106. # line 76 "Globals.puma"
  107.    return true;
  108.  
  109.   }
  110.   }
  111.   }
  112.   if (plist->Kind == kBTP_EMPTY) {
  113. # line 80 "Globals.puma"
  114.    return true;
  115.  
  116.   }
  117.   return false;
  118. }
  119.  
  120. static void GlobalTestFullParams
  121. # if defined __STDC__ | defined __cplusplus
  122. (register tTree plist)
  123. # else
  124. (plist)
  125.  register tTree plist;
  126. # endif
  127. {
  128.   if (plist == NoTree) return;
  129.   if (plist->Kind == kBTP_LIST) {
  130.   if (plist->BTP_LIST.Elem->Kind == kVAR_PARAM) {
  131.   if (plist->BTP_LIST.Elem->VAR_PARAM.V->Kind == kUSED_VAR) {
  132. # line 85 "Globals.puma"
  133.   {
  134. # line 87 "Globals.puma"
  135.    GlobalTestFullParams (plist->BTP_LIST.Next);
  136.   }
  137.    return;
  138.  
  139.   }
  140.   if (plist->BTP_LIST.Elem->VAR_PARAM.V->Kind == kINDEXED_VAR) {
  141. # line 90 "Globals.puma"
  142.   {
  143. # line 91 "Globals.puma"
  144.    error_protocol ("only full variables for global send/get");
  145. # line 92 "Globals.puma"
  146.    tree_protocol ("this parameter is wrong : ", plist->BTP_LIST.Elem->VAR_PARAM.V);
  147. # line 93 "Globals.puma"
  148.    GlobalTestFullParams (plist->BTP_LIST.Next);
  149.   }
  150.    return;
  151.  
  152.   }
  153.   if (plist->BTP_LIST.Elem->VAR_PARAM.V->Kind == kADDR) {
  154. # line 96 "Globals.puma"
  155.   {
  156. # line 97 "Globals.puma"
  157.    error_protocol ("no parameter expressions for global send/get");
  158. # line 98 "Globals.puma"
  159.    tree_protocol ("this parameter is wrong : ", plist->BTP_LIST.Elem->VAR_PARAM.V);
  160. # line 99 "Globals.puma"
  161.    GlobalTestFullParams (plist->BTP_LIST.Next);
  162.   }
  163.    return;
  164.  
  165.   }
  166.   }
  167.   if (plist->BTP_LIST.Elem->Kind == kFUNC_PARAM) {
  168.   if (plist->BTP_LIST.Next->Kind == kBTP_EMPTY) {
  169. # line 102 "Globals.puma"
  170.   {
  171. # line 104 "Globals.puma"
  172.  if (!IntrFuncRed (plist->BTP_LIST.Elem->FUNC_PARAM.F->PROC_OBJ.Ident))
  173.        { error_protocol ("function must be a reduction");
  174.          tree_protocol ("function name is : ", plist->BTP_LIST.Elem);
  175.        }
  176.  
  177.   }
  178.    return;
  179.  
  180.   }
  181. # line 111 "Globals.puma"
  182.   {
  183. # line 112 "Globals.puma"
  184.    error_protocol ("reduction must be last parameter");
  185. # line 113 "Globals.puma"
  186.    tree_protocol ("reduction function is : ", plist->BTP_LIST.Elem);
  187. # line 114 "Globals.puma"
  188.    GlobalTestFullParams (plist->BTP_LIST.Next);
  189.   }
  190.    return;
  191.  
  192.   }
  193. # line 117 "Globals.puma"
  194.   {
  195. # line 118 "Globals.puma"
  196.    error_protocol ("illegal parameter for global send/get");
  197. # line 119 "Globals.puma"
  198.    tree_protocol ("this parameter is wrong : ", plist->BTP_LIST.Elem);
  199. # line 120 "Globals.puma"
  200.    GlobalTestFullParams (plist->BTP_LIST.Next);
  201.   }
  202.    return;
  203.  
  204.   }
  205.   if (plist->Kind == kBTP_EMPTY) {
  206. # line 123 "Globals.puma"
  207.    return;
  208.  
  209.   }
  210. # line 126 "Globals.puma"
  211.   {
  212. # line 127 "Globals.puma"
  213.    error_protocol ("GlobalTestFullParams failed\n");
  214. # line 128 "Globals.puma"
  215.    printf ("GlobalTestFullParams failed\n");
  216. # line 129 "Globals.puma"
  217.    WriteTree (stdout, plist);
  218. # line 130 "Globals.puma"
  219.    kill_in_protocol ();
  220.   }
  221.    return;
  222.  
  223. ;
  224. }
  225.  
  226. static void GlobalTestIndexes
  227. # if defined __STDC__ | defined __cplusplus
  228. (register tTree a, register tTree indexlist, register int n)
  229. # else
  230. (a, indexlist, n)
  231.  register tTree a;
  232.  register tTree indexlist;
  233.  register int n;
  234. # endif
  235. {
  236.   if (a == NoTree) return;
  237.   if (indexlist == NoTree) return;
  238.   if (equalint (n, 0)) {
  239. # line 148 "Globals.puma"
  240.    return;
  241.  
  242.   }
  243.   if (indexlist->Kind == kBTP_LIST) {
  244.   if (indexlist->BTP_LIST.Elem->Kind == kVAR_PARAM) {
  245. # line 151 "Globals.puma"
  246.   {
  247. # line 152 "Globals.puma"
  248.    CheckIndexParam (a, indexlist->BTP_LIST.Elem->VAR_PARAM.V, TreeType (indexlist->BTP_LIST.Elem->VAR_PARAM.V));
  249. # line 153 "Globals.puma"
  250.    GlobalTestIndexes (a, indexlist->BTP_LIST.Next, n - 1);
  251.   }
  252.    return;
  253.  
  254.   }
  255.   }
  256. # line 156 "Globals.puma"
  257.   {
  258. # line 157 "Globals.puma"
  259.    printf ("Test of %d indexes failed\n", n);
  260. # line 158 "Globals.puma"
  261.    WriteTree (stdout, a);
  262. # line 159 "Globals.puma"
  263.    WriteTree (stdout, indexlist);
  264.   }
  265.    return;
  266.  
  267. ;
  268. }
  269.  
  270. static void CheckIndexParam
  271. # if defined __STDC__ | defined __cplusplus
  272. (register tTree a, register tTree p, register tTree ptype)
  273. # else
  274. (a, p, ptype)
  275.  register tTree a;
  276.  register tTree p;
  277.  register tTree ptype;
  278. # endif
  279. {
  280.   if (a == NoTree) return;
  281.   if (p == NoTree) return;
  282.   if (ptype == NoTree) return;
  283.   if (ptype->Kind == kINTEGER_TYPE) {
  284.   if (equalint (ptype->INTEGER_TYPE.size, 4)) {
  285. # line 164 "Globals.puma"
  286.   {
  287. # line 166 "Globals.puma"
  288.   if (TreeRank (p) != TreeRank (a))
  289.          { error_protocol ("rank conflict for index in global get/send");
  290.            tree_protocol  ("this is the integer index : ", p);
  291.            tree_protocol  ("must have same rank as : ", a);
  292.          }
  293.  
  294.   }
  295.    return;
  296.  
  297.   }
  298. # line 174 "Globals.puma"
  299.   {
  300. # line 175 "Globals.puma"
  301.    error_protocol ("illegal index type in global get/send");
  302. # line 176 "Globals.puma"
  303.    tree_protocol ("index not integer*4 : ", p);
  304.   }
  305.    return;
  306.  
  307.   }
  308. # line 179 "Globals.puma"
  309.   {
  310. # line 180 "Globals.puma"
  311.    error_protocol ("index vector not integer in global get/send");
  312. # line 181 "Globals.puma"
  313.    tree_protocol ("index vector is : ", p);
  314. # line 182 "Globals.puma"
  315.    tree_protocol ("this is the index type : ", ptype);
  316.   }
  317.    return;
  318.  
  319. ;
  320. }
  321.  
  322. static void GlobalTestConform
  323. # if defined __STDC__ | defined __cplusplus
  324. (register tTree a, register tTree b)
  325. # else
  326. (a, b)
  327.  register tTree a;
  328.  register tTree b;
  329. # endif
  330. {
  331.   if (a == NoTree) return;
  332.   if (b == NoTree) return;
  333. # line 198 "Globals.puma"
  334.  {
  335.   tTree type_a;
  336.   tTree type_b;
  337.   bool ok;
  338.   {
  339. # line 199 "Globals.puma"
  340.  
  341. # line 200 "Globals.puma"
  342.  
  343. # line 202 "Globals.puma"
  344.  
  345. # line 204 "Globals.puma"
  346.  type_a = TreeType (a);
  347.      type_b = TreeType (b);
  348.      ok     = true;
  349.  
  350.      if (TreeSize (a) != TreeSize (b))
  351.          { error_protocol ("source and target must have same size");
  352.            tree_protocol ("source is ", b);
  353.            tree_protocol ("source size is ", type_a);
  354.            tree_protocol ("target is ", a);
  355.            tree_protocol ("target size is ", type_b);
  356.            ok = false;
  357.          }
  358.  
  359.       if (type_a->Kind != type_b->Kind)
  360.          { error_protocol ("source and target must have same type");
  361.            tree_protocol ("source is ", b);
  362.            tree_protocol ("source type is ", type_a);
  363.            tree_protocol ("target is ", a);
  364.            tree_protocol ("target type is ", type_b);
  365.            ok = false;
  366.          }
  367.  
  368.   }
  369.    return;
  370.  }
  371.  
  372. ;
  373. }
  374.  
  375. static void GlobalTestMask
  376. # if defined __STDC__ | defined __cplusplus
  377. (register tTree a, register tTree mask, register tTree masktype)
  378. # else
  379. (a, mask, masktype)
  380.  register tTree a;
  381.  register tTree mask;
  382.  register tTree masktype;
  383. # endif
  384. {
  385.   if (a == NoTree) return;
  386.   if (mask == NoTree) return;
  387.   if (masktype == NoTree) return;
  388.   if (masktype->Kind == kBOOLEAN_TYPE) {
  389.   if (equalint (masktype->BOOLEAN_TYPE.size, 4)) {
  390. # line 242 "Globals.puma"
  391.   {
  392. # line 244 "Globals.puma"
  393.   if (TreeRank (mask) != TreeRank (a))
  394.          { error_protocol ("rank conflict for mask in global get/send");
  395.            tree_protocol  ("this is the mask : ", mask);
  396.            tree_protocol  ("must have same rank as : ", a);
  397.          }
  398.  
  399.   }
  400.    return;
  401.  
  402.   }
  403. # line 252 "Globals.puma"
  404.   {
  405. # line 253 "Globals.puma"
  406.    error_protocol ("illegal mask type in global get/send");
  407. # line 254 "Globals.puma"
  408.    tree_protocol ("mask not logical*4 : ", mask);
  409.   }
  410.    return;
  411.  
  412.   }
  413. # line 257 "Globals.puma"
  414.   {
  415. # line 258 "Globals.puma"
  416.    error_protocol ("mask not logical in global get/send");
  417. # line 259 "Globals.puma"
  418.    tree_protocol ("mask is : ", mask);
  419. # line 260 "Globals.puma"
  420.    tree_protocol ("this is the mask type : ", masktype);
  421.   }
  422.    return;
  423.  
  424. ;
  425. }
  426.  
  427. void SplitGet
  428. # if defined __STDC__ | defined __cplusplus
  429. (register tTree params, register int * rank, register tTree * A_, register tTree * B_, register tTree * indexes, register tTree * Mask)
  430. # else
  431. (params, rank, A_, B_, indexes, Mask)
  432.  register tTree params;
  433.  register int * rank;
  434.  register tTree * A_;
  435.  register tTree * B_;
  436.  register tTree * indexes;
  437.  register tTree * Mask;
  438. # endif
  439. {
  440.   if (params == NoTree) return;
  441.   if (params->Kind == kBTP_LIST) {
  442.   if (params->BTP_LIST.Elem->Kind == kVAR_PARAM) {
  443.   if (params->BTP_LIST.Next->Kind == kBTP_LIST) {
  444.   if (params->BTP_LIST.Next->BTP_LIST.Elem->Kind == kVAR_PARAM) {
  445. # line 293 "Globals.puma"
  446.  {
  447.   int b_rank;
  448.   tTree tail1;
  449.   tTree M;
  450.   int len;
  451.   {
  452. # line 296 "Globals.puma"
  453.  
  454. # line 297 "Globals.puma"
  455.  
  456. # line 298 "Globals.puma"
  457.  
  458. # line 299 "Globals.puma"
  459.  
  460. # line 301 "Globals.puma"
  461.  b_rank = TreeRank (params->BTP_LIST.Next->BTP_LIST.Elem->VAR_PARAM.V);
  462.       if (TreeListLength (params->BTP_LIST.Next->BTP_LIST.Next) < b_rank)
  463.          { error_protocol ("not enough indexes in global get");
  464.            M = NoTree;
  465.          }
  466.         else
  467.          { SplitParams (params->BTP_LIST.Next->BTP_LIST.Next, b_rank, &tail1);
  468.            FindGetMask (tail1, &M);
  469.          }
  470.  
  471.   }
  472.    * rank = b_rank;
  473.    * A_ = params->BTP_LIST.Elem->VAR_PARAM.V;
  474.    * B_ = params->BTP_LIST.Next->BTP_LIST.Elem->VAR_PARAM.V;
  475.    * indexes = params->BTP_LIST.Next->BTP_LIST.Next;
  476.    * Mask = M;
  477.    return;
  478.  }
  479.  
  480.   }
  481.   }
  482.   }
  483.   }
  484. # line 313 "Globals.puma"
  485.   {
  486. # line 314 "Globals.puma"
  487.    error_protocol ("use must be : global_get (A, B, I1, .., In [,M])");
  488.   }
  489.    * rank = 0;
  490.    * A_ = NoTree;
  491.    * B_ = NoTree;
  492.    * indexes = NoTree;
  493.    * Mask = NoTree;
  494.    return;
  495.  
  496. ;
  497. }
  498.  
  499. void SplitSend
  500. # if defined __STDC__ | defined __cplusplus
  501. (register tTree params, register int * rank, register tTree * A_, register tTree * B_, register tTree * indexes, register tTree * Mask, register tTree * op)
  502. # else
  503. (params, rank, A_, B_, indexes, Mask, op)
  504.  register tTree params;
  505.  register int * rank;
  506.  register tTree * A_;
  507.  register tTree * B_;
  508.  register tTree * indexes;
  509.  register tTree * Mask;
  510.  register tTree * op;
  511. # endif
  512. {
  513.   if (params == NoTree) return;
  514.   if (params->Kind == kBTP_LIST) {
  515.   if (params->BTP_LIST.Elem->Kind == kVAR_PARAM) {
  516. # line 326 "Globals.puma"
  517.  {
  518.   int b_rank;
  519.   tTree tail1;
  520.   tTree A;
  521.   tTree M;
  522.   tTree red_op;
  523.   {
  524. # line 328 "Globals.puma"
  525.  
  526. # line 329 "Globals.puma"
  527.  
  528. # line 330 "Globals.puma"
  529.  
  530. # line 331 "Globals.puma"
  531.  
  532. # line 332 "Globals.puma"
  533.  
  534. # line 334 "Globals.puma"
  535.  b_rank = TreeRank (params->BTP_LIST.Elem->VAR_PARAM.V);
  536.       if (TreeListLength (params->BTP_LIST.Next) < b_rank+1)
  537.          { error_protocol ("not enough indexes in global send");
  538.            M    = NoTree;
  539.            A    = NoTree;
  540.          }
  541.         else
  542.          { SplitParams (params->BTP_LIST.Next, b_rank, &tail1);
  543.            FindSend (tail1, &A, &M, &red_op);
  544.          }
  545.  
  546.   }
  547.    * rank = b_rank;
  548.    * A_ = A;
  549.    * B_ = params->BTP_LIST.Elem->VAR_PARAM.V;
  550.    * indexes = params->BTP_LIST.Next;
  551.    * Mask = M;
  552.    * op = red_op;
  553.    return;
  554.  }
  555.  
  556.   }
  557.   }
  558. # line 347 "Globals.puma"
  559.   {
  560. # line 348 "Globals.puma"
  561.    error_protocol ("use must be : global_send (B, I1, .., In, A [,M]) [,op]");
  562.   }
  563.    * rank = 0;
  564.    * A_ = NoTree;
  565.    * B_ = NoTree;
  566.    * indexes = NoTree;
  567.    * Mask = NoTree;
  568.    * op = NoTree;
  569.    return;
  570.  
  571. ;
  572. }
  573.  
  574. static void SplitParams
  575. # if defined __STDC__ | defined __cplusplus
  576. (register tTree plist, register int n, register tTree * tail)
  577. # else
  578. (plist, n, tail)
  579.  register tTree plist;
  580.  register int n;
  581.  register tTree * tail;
  582. # endif
  583. {
  584.   if (plist == NoTree) return;
  585.   if (equalint (n, 0)) {
  586. # line 363 "Globals.puma"
  587.    * tail = plist;
  588.    return;
  589.  
  590.   }
  591.   if (plist->Kind == kBTP_LIST) {
  592. # line 366 "Globals.puma"
  593.  {
  594.   tTree yyV1;
  595.   {
  596. # line 367 "Globals.puma"
  597.    SplitParams (plist->BTP_LIST.Next, n - 1, & yyV1);
  598.   }
  599.    * tail = yyV1;
  600.    return;
  601.  }
  602.  
  603.   }
  604.   if (plist->Kind == kBTP_EMPTY) {
  605. # line 370 "Globals.puma"
  606.    * tail = plist;
  607.    return;
  608.  
  609.   }
  610. # line 373 "Globals.puma"
  611.   {
  612. # line 374 "Globals.puma"
  613.    printf ("SplitParams failed\n");
  614. # line 375 "Globals.puma"
  615.    WriteTree (stdout, plist);
  616. # line 376 "Globals.puma"
  617.    kill_in_protocol ();
  618.   }
  619.    * tail = NoTree;
  620.    return;
  621.  
  622. ;
  623. }
  624.  
  625. static void FindGetMask
  626. # if defined __STDC__ | defined __cplusplus
  627. (register tTree plist, register tTree * mask)
  628. # else
  629. (plist, mask)
  630.  register tTree plist;
  631.  register tTree * mask;
  632. # endif
  633. {
  634.   if (plist == NoTree) return;
  635.   if (plist->Kind == kBTP_EMPTY) {
  636. # line 389 "Globals.puma"
  637.    * mask = NoTree;
  638.    return;
  639.  
  640.   }
  641.   if (plist->Kind == kBTP_LIST) {
  642.   if (plist->BTP_LIST.Elem->Kind == kVAR_PARAM) {
  643.   if (plist->BTP_LIST.Next->Kind == kBTP_EMPTY) {
  644. # line 392 "Globals.puma"
  645.    * mask = plist->BTP_LIST.Elem->VAR_PARAM.V;
  646.    return;
  647.  
  648.   }
  649. # line 395 "Globals.puma"
  650.   {
  651. # line 396 "Globals.puma"
  652.    error_protocol ("too many parameters in global get");
  653.   }
  654.    * mask = plist->BTP_LIST.Elem->VAR_PARAM.V;
  655.    return;
  656.  
  657.   }
  658.   if (plist->BTP_LIST.Elem->Kind == kFUNC_PARAM) {
  659. # line 399 "Globals.puma"
  660.   {
  661. # line 400 "Globals.puma"
  662.    error_protocol ("no reduction op allowed in global get");
  663.   }
  664.    * mask = NoTree;
  665.    return;
  666.  
  667.   }
  668.   }
  669. ;
  670. }
  671.  
  672. static void FindSend
  673. # if defined __STDC__ | defined __cplusplus
  674. (register tTree plist, register tTree * arr, register tTree * mask, register tTree * op)
  675. # else
  676. (plist, arr, mask, op)
  677.  register tTree plist;
  678.  register tTree * arr;
  679.  register tTree * mask;
  680.  register tTree * op;
  681. # endif
  682. {
  683.   if (plist == NoTree) return;
  684. # line 413 "Globals.puma"
  685.   {
  686. # line 414 "Globals.puma"
  687.    if (! (plist == NoTree)) goto yyL1;
  688.   {
  689. # line 415 "Globals.puma"
  690.    error_protocol ("missing source array in global send");
  691.   }
  692.   }
  693.    * arr = NoTree;
  694.    * mask = NoTree;
  695.    * op = NoTree;
  696.    return;
  697. yyL1:;
  698.  
  699.   if (plist->Kind == kBTP_LIST) {
  700.   if (plist->BTP_LIST.Elem->Kind == kVAR_PARAM) {
  701.   if (plist->BTP_LIST.Next->Kind == kBTP_EMPTY) {
  702. # line 418 "Globals.puma"
  703.    * arr = plist->BTP_LIST.Elem->VAR_PARAM.V;
  704.    * mask = NoTree;
  705.    * op = NoTree;
  706.    return;
  707.  
  708.   }
  709.   if (plist->BTP_LIST.Next->Kind == kBTP_LIST) {
  710.   if (plist->BTP_LIST.Next->BTP_LIST.Elem->Kind == kVAR_PARAM) {
  711.   if (plist->BTP_LIST.Next->BTP_LIST.Next->Kind == kBTP_EMPTY) {
  712. # line 421 "Globals.puma"
  713.    * arr = plist->BTP_LIST.Elem->VAR_PARAM.V;
  714.    * mask = plist->BTP_LIST.Next->BTP_LIST.Elem->VAR_PARAM.V;
  715.    * op = NoTree;
  716.    return;
  717.  
  718.   }
  719.   if (plist->BTP_LIST.Next->BTP_LIST.Next->Kind == kBTP_LIST) {
  720.   if (plist->BTP_LIST.Next->BTP_LIST.Next->BTP_LIST.Elem->Kind == kFUNC_PARAM) {
  721.   if (plist->BTP_LIST.Next->BTP_LIST.Next->BTP_LIST.Next->Kind == kBTP_EMPTY) {
  722. # line 429 "Globals.puma"
  723.    * arr = plist->BTP_LIST.Elem->VAR_PARAM.V;
  724.    * mask = plist->BTP_LIST.Next->BTP_LIST.Elem->VAR_PARAM.V;
  725.    * op = plist->BTP_LIST.Next->BTP_LIST.Next->BTP_LIST.Elem;
  726.    return;
  727.  
  728.   }
  729.   }
  730.   }
  731.   }
  732.   if (plist->BTP_LIST.Next->BTP_LIST.Elem->Kind == kFUNC_PARAM) {
  733.   if (plist->BTP_LIST.Next->BTP_LIST.Next->Kind == kBTP_EMPTY) {
  734. # line 425 "Globals.puma"
  735.    * arr = plist->BTP_LIST.Elem->VAR_PARAM.V;
  736.    * mask = NoTree;
  737.    * op = plist->BTP_LIST.Next->BTP_LIST.Elem;
  738.    return;
  739.  
  740.   }
  741.   }
  742.   }
  743.   }
  744.   }
  745. # line 434 "Globals.puma"
  746.   {
  747. # line 435 "Globals.puma"
  748.    error_protocol ("illegal parameters in global send");
  749. # line 436 "Globals.puma"
  750.    print_protocol ("use must be : global_send (B, I1, .., In, A [,M]) [,op]");
  751.   }
  752.    * arr = NoTree;
  753.    * mask = NoTree;
  754.    * op = NoTree;
  755.    return;
  756.  
  757. ;
  758. }
  759.  
  760. void CheckGlobalGetParams
  761. # if defined __STDC__ | defined __cplusplus
  762. (register tTree parameter_list)
  763. # else
  764. (parameter_list)
  765.  register tTree parameter_list;
  766. # endif
  767. {
  768.   if (parameter_list == NoTree) return;
  769. # line 462 "Globals.puma"
  770.   {
  771. # line 463 "Globals.puma"
  772.    if (! ((TreeListLength (parameter_list) < 3))) goto yyL1;
  773.   {
  774. # line 464 "Globals.puma"
  775.    error_protocol ("global get requires at least 3 parameters (A,B,P,..)");
  776.   }
  777.   }
  778.    return;
  779. yyL1:;
  780.  
  781. # line 467 "Globals.puma"
  782.   {
  783. # line 468 "Globals.puma"
  784.    if (! ((FullParameters (parameter_list) == false))) goto yyL2;
  785.   {
  786. # line 470 "Globals.puma"
  787.    GlobalTestFullParams (parameter_list);
  788.   }
  789.   }
  790.    return;
  791. yyL2:;
  792.  
  793. # line 473 "Globals.puma"
  794.  {
  795.   int yyV1;
  796.   tTree yyV2;
  797.   tTree yyV3;
  798.   tTree yyV4;
  799.   tTree yyV5;
  800.   {
  801. # line 475 "Globals.puma"
  802.    SplitGet (parameter_list, & yyV1, & yyV2, & yyV3, & yyV4, & yyV5);
  803. # line 477 "Globals.puma"
  804.  
  805.      if (TreeListLength (yyV4) >= yyV1)
  806.         GlobalTestIndexes (yyV2, yyV4, yyV1);
  807.      if (yyV1 > 2)
  808.         error_protocol ("global get: rank must be <= 2");
  809.  
  810.      GlobalTestConform (yyV2, yyV3);
  811.  
  812.      if (yyV5 != NoTree)
  813.         GlobalTestMask (yyV2, yyV5, TreeType(yyV5));
  814.  
  815.   }
  816.    return;
  817.  }
  818.  
  819. ;
  820. }
  821.  
  822. void CheckGlobalSendParams
  823. # if defined __STDC__ | defined __cplusplus
  824. (register tTree parameter_list)
  825. # else
  826. (parameter_list)
  827.  register tTree parameter_list;
  828. # endif
  829. {
  830.   if (parameter_list == NoTree) return;
  831. # line 498 "Globals.puma"
  832.   {
  833. # line 499 "Globals.puma"
  834.    if (! ((TreeListLength (parameter_list) < 3))) goto yyL1;
  835.   {
  836. # line 500 "Globals.puma"
  837.    error_protocol ("global send requires at least 3 parameters (B,P,A,..)");
  838.   }
  839.   }
  840.    return;
  841. yyL1:;
  842.  
  843. # line 503 "Globals.puma"
  844.   {
  845. # line 504 "Globals.puma"
  846.    if (! ((FullParameters (parameter_list) == false))) goto yyL2;
  847.   {
  848. # line 506 "Globals.puma"
  849.    GlobalTestFullParams (parameter_list);
  850.   }
  851.   }
  852.    return;
  853. yyL2:;
  854.  
  855. # line 509 "Globals.puma"
  856.  {
  857.   int yyV1;
  858.   tTree yyV2;
  859.   tTree yyV3;
  860.   tTree yyV4;
  861.   tTree yyV5;
  862.   tTree yyV6;
  863.   {
  864. # line 510 "Globals.puma"
  865.    SplitSend (parameter_list, & yyV1, & yyV2, & yyV3, & yyV4, & yyV5, & yyV6);
  866. # line 512 "Globals.puma"
  867.  if (yyV2 != NoTree)
  868.         {
  869.  
  870.  
  871.           GlobalTestIndexes (yyV2, yyV4, yyV1);
  872.  
  873.  
  874.           GlobalTestConform (yyV2, yyV3);
  875.  
  876.         }
  877.  
  878.      if (yyV1 > 2)
  879.         error_protocol ("global send: rank must be <= 2");
  880.  
  881.  
  882.      if (yyV5 != NoTree)
  883.         GlobalTestMask (yyV2, yyV5, TreeType(yyV5));
  884.  
  885.   }
  886.    return;
  887.  }
  888.  
  889. ;
  890. }
  891.  
  892. tTree GenGlobalGet
  893. # if defined __STDC__ | defined __cplusplus
  894. (register tTree parameter_list)
  895. # else
  896. (parameter_list)
  897.  register tTree parameter_list;
  898. # endif
  899. {
  900. # line 549 "Globals.puma"
  901.  {
  902.   tTree params;
  903.   tTree call;
  904.   int yyV1;
  905.   tTree yyV2;
  906.   tTree yyV3;
  907.   tTree yyV4;
  908.   tTree yyV5;
  909.   {
  910. # line 551 "Globals.puma"
  911.  
  912. # line 552 "Globals.puma"
  913.  
  914. # line 554 "Globals.puma"
  915.    SplitGet (parameter_list, & yyV1, & yyV2, & yyV3, & yyV4, & yyV5);
  916. # line 558 "Globals.puma"
  917.  params = yyV4;
  918.  
  919.      params = DalibFormalSize (yyV3, params);
  920.      params = mBTP_LIST (mVAR_PARAM (yyV3), params);
  921.      params = DalibLocalSize (yyV2, params);
  922.      params = DalibTreeSizeParam (yyV2, params);
  923.      params = mBTP_LIST (mVAR_PARAM (yyV2), params);
  924.  
  925.      if (TreeDistribution (yyV3) == 1)
  926.       { if (yyV5 == NoTree)
  927.            call = mPROC_OBJ (MakeDalibId1 ("global_get", yyV1));
  928.           else
  929.            call = mPROC_OBJ (MakeDalibId1 ("global_getm", yyV1));
  930.       }
  931.       else
  932.       { if (yyV5 == NoTree)
  933.            call = mPROC_OBJ (MakeDalibId1 ("local_get", yyV1));
  934.           else
  935.            call = mPROC_OBJ (MakeDalibId1 ("local_getm", yyV1));
  936.       }
  937.      call = mACF_BASIC (mCALL_STMT (call, params));
  938.  
  939.   }
  940.   {
  941.    return call;
  942.   }
  943.  }
  944.  
  945. }
  946.  
  947. tTree GenGlobalSend
  948. # if defined __STDC__ | defined __cplusplus
  949. (register tTree parameter_list)
  950. # else
  951. (parameter_list)
  952.  register tTree parameter_list;
  953. # endif
  954. {
  955. # line 596 "Globals.puma"
  956.  
  957. tTree params, call, last_one;
  958. int nop;
  959.  
  960. # line 601 "Globals.puma"
  961.  {
  962.   int yyV1;
  963.   tTree yyV2;
  964.   tTree yyV3;
  965.   tTree yyV4;
  966.   tTree yyV5;
  967.   tTree yyV6;
  968.   {
  969. # line 603 "Globals.puma"
  970.    SplitSend (parameter_list, & yyV1, & yyV2, & yyV3, & yyV4, & yyV5, & yyV6);
  971. # line 607 "Globals.puma"
  972.  if (yyV6 != NoTree)
  973.          nop = GenGlobalSendOp (TreeType (yyV3), FuncName (yyV6));
  974.        else
  975.          nop = 0;
  976.  
  977.      params = mBTP_EMPTY();
  978.  
  979.  
  980.  
  981.      GetTheIndexes (yyV4, yyV1, &last_one);
  982.  
  983.      if (yyV5 != NoTree)
  984.         params = mBTP_LIST (mVAR_PARAM (yyV5), params);
  985.        else
  986.         params = mBTP_LIST (last_one, params);
  987.  
  988.      params = DalibLocalSize (yyV2, params);
  989.      params = DalibTreeSizeParam (yyV2, params);
  990.      params = mBTP_LIST (mVAR_PARAM (yyV2), params);
  991.  
  992.      ConcatParams (yyV4, params);
  993.      params = yyV4;
  994.  
  995.      params = DalibFormalSize (yyV3, params);
  996.      params = mBTP_LIST (mVAR_PARAM (yyV3), params);
  997.  
  998.      params = mBTP_LIST (ExpToVarParam (MakeConstant (nop)), params);
  999.  
  1000.      if (TreeDistribution(yyV3) == 1)
  1001.         call = mPROC_OBJ (MakeDalibId1 ("global_setm", yyV1));
  1002.       else
  1003.         call = mPROC_OBJ (MakeDalibId1 ("local_setm", yyV1));
  1004.      call = mACF_BASIC (mCALL_STMT (call, params));
  1005.  
  1006.   }
  1007.   {
  1008.    return call;
  1009.   }
  1010.  }
  1011.  
  1012. }
  1013.  
  1014. static void GetTheIndexes
  1015. # if defined __STDC__ | defined __cplusplus
  1016. (register tTree indexes, register int rank, register tTree * last)
  1017. # else
  1018. (indexes, rank, last)
  1019.  register tTree indexes;
  1020.  register int rank;
  1021.  register tTree * last;
  1022. # endif
  1023. {
  1024.   if (indexes == NoTree) return;
  1025.   if (indexes->Kind == kBTP_LIST) {
  1026.   if (equalint (rank, 1)) {
  1027. # line 652 "Globals.puma"
  1028.   {
  1029. # line 653 "Globals.puma"
  1030.  indexes->BTP_LIST.Next = NoTree;
  1031.   }
  1032.    * last = indexes->BTP_LIST.Elem;
  1033.    return;
  1034.  
  1035.   }
  1036. # line 656 "Globals.puma"
  1037.  {
  1038.   tTree yyV1;
  1039.   {
  1040. # line 658 "Globals.puma"
  1041.    GetTheIndexes (indexes->BTP_LIST.Next, rank - 1, & yyV1);
  1042.   }
  1043.    * last = yyV1;
  1044.    return;
  1045.  }
  1046.  
  1047.   }
  1048. ;
  1049. }
  1050.  
  1051. static void ConcatParams
  1052. # if defined __STDC__ | defined __cplusplus
  1053. (register tTree indexes, register tTree params)
  1054. # else
  1055. (indexes, params)
  1056.  register tTree indexes;
  1057.  register tTree params;
  1058. # endif
  1059. {
  1060.   if (indexes == NoTree) return;
  1061.   if (params == NoTree) return;
  1062.   if (indexes->Kind == kBTP_LIST) {
  1063. # line 663 "Globals.puma"
  1064.   {
  1065. # line 664 "Globals.puma"
  1066.    if (! ((indexes->BTP_LIST.Next == NoTree))) goto yyL1;
  1067.   {
  1068. # line 665 "Globals.puma"
  1069.  indexes->BTP_LIST.Next = params;
  1070.   }
  1071.   }
  1072.    return;
  1073. yyL1:;
  1074.  
  1075. # line 668 "Globals.puma"
  1076.   {
  1077. # line 669 "Globals.puma"
  1078.    ConcatParams (indexes->BTP_LIST.Next, params);
  1079.   }
  1080.    return;
  1081.  
  1082.   }
  1083. ;
  1084. }
  1085.  
  1086. static int GenGlobalSendOp
  1087. # if defined __STDC__ | defined __cplusplus
  1088. (register tTree type, register tIdent redfunc)
  1089. # else
  1090. (type, redfunc)
  1091.  register tTree type;
  1092.  register tIdent redfunc;
  1093. # endif
  1094. {
  1095.   if (type->Kind == kBOOLEAN_TYPE) {
  1096.   if (equalint (type->BOOLEAN_TYPE.size, 4)) {
  1097.   if (equaltIdent (redfunc, MakeIdent ("ANY", 3))) {
  1098. # line 680 "Globals.puma"
  1099.    return 17;
  1100.  
  1101.   }
  1102.   }
  1103.   if (equalint (type->BOOLEAN_TYPE.size, 4)) {
  1104.   if (equaltIdent (redfunc, MakeIdent ("ALL", 3))) {
  1105. # line 682 "Globals.puma"
  1106.    return 16;
  1107.  
  1108.   }
  1109.   }
  1110.   if (equalint (type->BOOLEAN_TYPE.size, 4)) {
  1111.   if (equaltIdent (redfunc, MakeIdent ("PARITY", 6))) {
  1112. # line 684 "Globals.puma"
  1113.    return 18;
  1114.  
  1115.   }
  1116.   }
  1117.   }
  1118.   if (type->Kind == kINTEGER_TYPE) {
  1119.   if (equalint (type->INTEGER_TYPE.size, 4)) {
  1120.   if (equaltIdent (redfunc, MakeIdent ("SUM", 3))) {
  1121. # line 686 "Globals.puma"
  1122.    return 7;
  1123.  
  1124.   }
  1125.   }
  1126.   if (equalint (type->INTEGER_TYPE.size, 4)) {
  1127.   if (equaltIdent (redfunc, MakeIdent ("PRODUCT", 7))) {
  1128. # line 688 "Globals.puma"
  1129.    return 10;
  1130.  
  1131.   }
  1132.   }
  1133.   if (equalint (type->INTEGER_TYPE.size, 4)) {
  1134.   if (equaltIdent (redfunc, MakeIdent ("MINVAL", 6))) {
  1135. # line 690 "Globals.puma"
  1136.    return 1;
  1137.  
  1138.   }
  1139.   }
  1140.   if (equalint (type->INTEGER_TYPE.size, 4)) {
  1141.   if (equaltIdent (redfunc, MakeIdent ("MAXVAL", 6))) {
  1142. # line 692 "Globals.puma"
  1143.    return 4;
  1144.  
  1145.   }
  1146.   }
  1147.   if (equalint (type->INTEGER_TYPE.size, 4)) {
  1148.   if (equaltIdent (redfunc, MakeIdent ("IALL", 4))) {
  1149. # line 694 "Globals.puma"
  1150.    return 13;
  1151.  
  1152.   }
  1153.   }
  1154.   if (equalint (type->INTEGER_TYPE.size, 4)) {
  1155.   if (equaltIdent (redfunc, MakeIdent ("IANY", 4))) {
  1156. # line 696 "Globals.puma"
  1157.    return 14;
  1158.  
  1159.   }
  1160.   }
  1161.   if (equalint (type->INTEGER_TYPE.size, 4)) {
  1162.   if (equaltIdent (redfunc, MakeIdent ("IPARITY", 7))) {
  1163. # line 698 "Globals.puma"
  1164.    return 15;
  1165.  
  1166.   }
  1167.   }
  1168.   }
  1169.   if (type->Kind == kREAL_TYPE) {
  1170.   if (equalint (type->REAL_TYPE.size, 4)) {
  1171.   if (equaltIdent (redfunc, MakeIdent ("SUM", 3))) {
  1172. # line 702 "Globals.puma"
  1173.    return 8;
  1174.  
  1175.   }
  1176.   }
  1177.   if (equalint (type->REAL_TYPE.size, 4)) {
  1178.   if (equaltIdent (redfunc, MakeIdent ("PRODUCT", 7))) {
  1179. # line 704 "Globals.puma"
  1180.    return 11;
  1181.  
  1182.   }
  1183.   }
  1184.   if (equalint (type->REAL_TYPE.size, 4)) {
  1185.   if (equaltIdent (redfunc, MakeIdent ("MINVAL", 6))) {
  1186. # line 706 "Globals.puma"
  1187.    return 2;
  1188.  
  1189.   }
  1190.   }
  1191.   if (equalint (type->REAL_TYPE.size, 4)) {
  1192.   if (equaltIdent (redfunc, MakeIdent ("MAXVAL", 6))) {
  1193. # line 708 "Globals.puma"
  1194.    return 5;
  1195.  
  1196.   }
  1197.   }
  1198.   if (equalint (type->REAL_TYPE.size, 8)) {
  1199.   if (equaltIdent (redfunc, MakeIdent ("SUM", 3))) {
  1200. # line 710 "Globals.puma"
  1201.    return 9;
  1202.  
  1203.   }
  1204.   }
  1205.   if (equalint (type->REAL_TYPE.size, 8)) {
  1206.   if (equaltIdent (redfunc, MakeIdent ("PRODUCT", 7))) {
  1207. # line 712 "Globals.puma"
  1208.    return 12;
  1209.  
  1210.   }
  1211.   }
  1212.   if (equalint (type->REAL_TYPE.size, 8)) {
  1213.   if (equaltIdent (redfunc, MakeIdent ("MINVAL", 6))) {
  1214. # line 714 "Globals.puma"
  1215.    return 3;
  1216.  
  1217.   }
  1218.   }
  1219.   if (equalint (type->REAL_TYPE.size, 8)) {
  1220.   if (equaltIdent (redfunc, MakeIdent ("MAXVAL", 6))) {
  1221. # line 716 "Globals.puma"
  1222.    return 6;
  1223.  
  1224.   }
  1225.   }
  1226.   }
  1227. # line 718 "Globals.puma"
  1228.   {
  1229. # line 719 "Globals.puma"
  1230.    error_protocol ("This reduction is not handled for global set");
  1231. # line 720 "Globals.puma"
  1232.    tree_protocol ("type is ", type);
  1233.   }
  1234.    return - 1;
  1235.  
  1236. }
  1237.  
  1238. static tIdent FuncName
  1239. # if defined __STDC__ | defined __cplusplus
  1240. (register tTree f)
  1241. # else
  1242. (f)
  1243.  register tTree f;
  1244. # endif
  1245. {
  1246.   if (f->Kind == kFUNC_PARAM) {
  1247. # line 726 "Globals.puma"
  1248.    return f->FUNC_PARAM.F->PROC_OBJ.Ident;
  1249.  
  1250.   }
  1251.  yyAbort ("FuncName");
  1252. }
  1253.  
  1254. void BeginGlobals ()
  1255. {
  1256. }
  1257.  
  1258. void CloseGlobals ()
  1259. {
  1260. }
  1261.