home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Professional / OS2PRO194.ISO / os2 / prgramer / adaptor / src / adaptf90.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-01-03  |  19.9 KB  |  948 lines
  1. # include "F90.h"
  2. # include "yyAF90.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 24 "AdaptF90.puma"
  36.  
  37. # include <stdio.h>
  38. # include "Idents.h"
  39. # include "StringMe.h"
  40.  
  41. # include "protocol.h"
  42.  
  43. # include "Types.h"
  44. # include "Shapes.h"
  45. # include "Expressi.h"
  46.  
  47. # undef DEBUG
  48.  
  49.  
  50.  
  51. static FILE * yyf = stdout;
  52.  
  53. static void yyAbort
  54. # ifdef __cplusplus
  55.  (char * yyFunction)
  56. # else
  57.  (yyFunction) char * yyFunction;
  58. # endif
  59. {
  60.  (void) fprintf (stderr, "Error: module AdaptF90, routine %s failed\n", yyFunction);
  61.  exit (1);
  62. }
  63.  
  64. tTree MakeArrayAssignment ARGS((tTree t));
  65. static void VectorizeMovement ARGS((tTree body, tTree id, tTree slice, bool * yyP1));
  66. static void FindLoopVar ARGS((tTree var, tTree id, bool * yyP4, int * yyP3, int * yyP2));
  67. static void FindLoopVarIndex ARGS((tTree var, tTree id, bool * yyP7, int * yyP6, int * yyP5));
  68. static void Substitute ARGS((tTree var, tTree id, int val, tTree slice));
  69. static tTree Replace ARGS((tTree exp, tTree id, tTree newexp));
  70. static bool IsNewVectorLegal ARGS((tTree var, int pos, tTree slice));
  71. static void SwitchIndex ARGS((tTree indexes, int n, tTree new, tTree * old));
  72.  
  73. tTree MakeArrayAssignment
  74. # if defined __STDC__ | defined __cplusplus
  75. (register tTree t)
  76. # else
  77. (t)
  78.  register tTree t;
  79. # endif
  80. {
  81.   if (t->Kind == kACF_FORALL) {
  82. # line 62 "AdaptF90.puma"
  83.  {
  84.   tTree result;
  85.   bool done;
  86.   {
  87. # line 64 "AdaptF90.puma"
  88.  
  89. # line 64 "AdaptF90.puma"
  90.  
  91. # line 66 "AdaptF90.puma"
  92.  
  93.  
  94.      t->ACF_FORALL.FORALL_BODY = MakeArrayAssignment (t->ACF_FORALL.FORALL_BODY);
  95.  
  96. #ifdef DEBUG
  97.      printf ("MakeArrayAssignment: body is \n");
  98.      FileUnparse (stdout, t->ACF_FORALL.FORALL_BODY);
  99. #endif
  100.  
  101.  
  102.  
  103.      VectorizeMovement (t->ACF_FORALL.FORALL_BODY, t->ACF_FORALL.FORALL_ID, t->ACF_FORALL.FORALL_RANGE, &done);
  104.  
  105. #ifdef DEBUG
  106.      if (done)
  107.        printf ("MakeArrayAssignment: vectorization has been done \n");
  108.      else
  109.        printf ("MakeArrayAssignment: vectorization has not been done \n");
  110.      FileUnparse (stdout, t->ACF_FORALL.FORALL_BODY);
  111. #endif
  112.  
  113.      if (done)
  114.         result = t->ACF_FORALL.FORALL_BODY->ACF_LIST.Elem;
  115.       else
  116.         result = t;
  117.  
  118.   }
  119.   {
  120.    return result;
  121.   }
  122.  }
  123.  
  124.   }
  125.   if (t->Kind == kACF_LIST) {
  126.   if (t->ACF_LIST.Next->Kind == kACF_EMPTY) {
  127. # line 95 "AdaptF90.puma"
  128.   {
  129. # line 97 "AdaptF90.puma"
  130.  t->ACF_LIST.Elem = MakeArrayAssignment (t->ACF_LIST.Elem);
  131.   }
  132.    return t;
  133.  
  134.   }
  135. # line 101 "AdaptF90.puma"
  136.   {
  137. # line 103 "AdaptF90.puma"
  138.    error_protocol ("Only one assignment in FORALL for MakeArrayAssignment");
  139.   }
  140.    return t;
  141.  
  142.   }
  143.   if (t->Kind == kACF_BASIC) {
  144.   if (t->ACF_BASIC.BASIC_STMT->Kind == kASSIGN_STMT) {
  145.   if (t->ACF_BASIC.BASIC_STMT->ASSIGN_STMT.ASSIGN_EXP->Kind == kVAR_EXP) {
  146. # line 107 "AdaptF90.puma"
  147.    return t;
  148.  
  149.   }
  150.   }
  151.   }
  152. # line 111 "AdaptF90.puma"
  153.   {
  154. # line 112 "AdaptF90.puma"
  155.    error_protocol ("Unknown Statement in FORALL");
  156.   }
  157.    return t;
  158.  
  159. }
  160.  
  161. static void VectorizeMovement
  162. # if defined __STDC__ | defined __cplusplus
  163. (register tTree body, register tTree id, register tTree slice, register bool * yyP1)
  164. # else
  165. (body, id, slice, yyP1)
  166.  register tTree body;
  167.  register tTree id;
  168.  register tTree slice;
  169.  register bool * yyP1;
  170. # endif
  171. {
  172.   if (body == NoTree) return;
  173.   if (id == NoTree) return;
  174.   if (slice == NoTree) return;
  175.   if (body->Kind == kACF_LIST) {
  176.   if (body->ACF_LIST.Next->Kind == kACF_EMPTY) {
  177. # line 132 "AdaptF90.puma"
  178.  {
  179.   bool yyV1;
  180.   {
  181. # line 134 "AdaptF90.puma"
  182.    VectorizeMovement (body->ACF_LIST.Elem, id, slice, & yyV1);
  183.   }
  184.    * yyP1 = yyV1;
  185.    return;
  186.  }
  187.  
  188.   }
  189.   }
  190.   if (body->Kind == kACF_FORALL) {
  191.   if (body->ACF_FORALL.FORALL_ID->Kind == kLOOP_VAR) {
  192.   if (id->Kind == kLOOP_VAR) {
  193. # line 137 "AdaptF90.puma"
  194.  {
  195.   bool yyV1;
  196.   {
  197. # line 143 "AdaptF90.puma"
  198.    if (! (IsVarInExp (id->LOOP_VAR.LOOP_VARNAME->VAR_OBJ.Ident, body->ACF_FORALL.FORALL_RANGE) == 0)) goto yyL2;
  199.   {
  200. # line 147 "AdaptF90.puma"
  201.    VectorizeMovement (body->ACF_FORALL.FORALL_BODY, id, slice, & yyV1);
  202.   }
  203.   }
  204.    * yyP1 = yyV1;
  205.    return;
  206.  }
  207. yyL2:;
  208.  
  209.   }
  210.   }
  211.   }
  212.   if (body->Kind == kACF_BASIC) {
  213.   if (body->ACF_BASIC.BASIC_STMT->Kind == kASSIGN_STMT) {
  214.   if (body->ACF_BASIC.BASIC_STMT->ASSIGN_STMT.ASSIGN_EXP->Kind == kVAR_EXP) {
  215. # line 150 "AdaptF90.puma"
  216.  {
  217.   bool done;
  218.   bool yyV1;
  219.   int yyV2;
  220.   int yyV3;
  221.   bool yyV4;
  222.   int yyV5;
  223.   int yyV6;
  224.   {
  225. # line 152 "AdaptF90.puma"
  226.  
  227. # line 154 "AdaptF90.puma"
  228.    if (! (TreeRank (body->ACF_BASIC.BASIC_STMT->ASSIGN_STMT.ASSIGN_VAR) == TreeRank (body->ACF_BASIC.BASIC_STMT->ASSIGN_STMT.ASSIGN_EXP->VAR_EXP.V))) goto yyL3;
  229.   {
  230. # line 156 "AdaptF90.puma"
  231.    FindLoopVar (body->ACF_BASIC.BASIC_STMT->ASSIGN_STMT.ASSIGN_VAR, id, & yyV1, & yyV2, & yyV3);
  232. # line 157 "AdaptF90.puma"
  233.    FindLoopVar (body->ACF_BASIC.BASIC_STMT->ASSIGN_STMT.ASSIGN_EXP->VAR_EXP.V, id, & yyV4, & yyV5, & yyV6);
  234. # line 159 "AdaptF90.puma"
  235.    if (! (yyV1 && yyV4)) goto yyL3;
  236.   {
  237. # line 160 "AdaptF90.puma"
  238.    if (! (yyV3 != 0)) goto yyL3;
  239.   {
  240. # line 161 "AdaptF90.puma"
  241.    if (! (yyV6 != 0)) goto yyL3;
  242.   {
  243. # line 162 "AdaptF90.puma"
  244.    if (! (yyV2 == yyV5)) goto yyL3;
  245.   {
  246. # line 166 "AdaptF90.puma"
  247.    if (! (IsNewVectorLegal (body->ACF_BASIC.BASIC_STMT->ASSIGN_STMT.ASSIGN_VAR, yyV2, slice))) goto yyL3;
  248.   {
  249. # line 168 "AdaptF90.puma"
  250.  
  251.  
  252. #ifdef DEBUG
  253.      printf ("Movement will be vectorized\n");
  254.      FileUnparse (stdout, body);
  255.      printf ("Left val = %d, right val = %d\n", yyV3, yyV6);
  256.      printf ("Variable is "); FileUnparse (stdout, id); printf ("\n");
  257.      printf ("Slice is    "); FileUnparse (stdout, slice); printf ("\n");
  258. #endif
  259.      Substitute (body->ACF_BASIC.BASIC_STMT->ASSIGN_STMT.ASSIGN_VAR,  id, yyV3, slice);
  260.      Substitute (body->ACF_BASIC.BASIC_STMT->ASSIGN_STMT.ASSIGN_EXP->VAR_EXP.V, id, yyV6, slice);
  261.  
  262. # line 181 "AdaptF90.puma"
  263.    done = true;
  264.   }
  265.   }
  266.   }
  267.   }
  268.   }
  269.   }
  270.   }
  271.    * yyP1 = done;
  272.    return;
  273.  }
  274. yyL3:;
  275.  
  276.   }
  277.   }
  278.   }
  279. # line 184 "AdaptF90.puma"
  280.    * yyP1 = false;
  281.    return;
  282.  
  283. ;
  284. }
  285.  
  286. static void FindLoopVar
  287. # if defined __STDC__ | defined __cplusplus
  288. (register tTree var, register tTree id, register bool * yyP4, register int * yyP3, register int * yyP2)
  289. # else
  290. (var, id, yyP4, yyP3, yyP2)
  291.  register tTree var;
  292.  register tTree id;
  293.  register bool * yyP4;
  294.  register int * yyP3;
  295.  register int * yyP2;
  296. # endif
  297. {
  298.   if (var == NoTree) return;
  299.   if (id == NoTree) return;
  300.   if (var->Kind == kINDEXED_VAR) {
  301. # line 203 "AdaptF90.puma"
  302.  {
  303.   bool yyV1;
  304.   int yyV2;
  305.   int yyV3;
  306.   {
  307. # line 204 "AdaptF90.puma"
  308.    FindLoopVarIndex (var->INDEXED_VAR.IND_EXPS, id, & yyV1, & yyV2, & yyV3);
  309.   }
  310.    * yyP4 = yyV1;
  311.    * yyP3 = yyV2;
  312.    * yyP2 = yyV3;
  313.    return;
  314.  }
  315.  
  316.   }
  317. ;
  318. }
  319.  
  320. static void FindLoopVarIndex
  321. # if defined __STDC__ | defined __cplusplus
  322. (register tTree var, register tTree id, register bool * yyP7, register int * yyP6, register int * yyP5)
  323. # else
  324. (var, id, yyP7, yyP6, yyP5)
  325.  register tTree var;
  326.  register tTree id;
  327.  register bool * yyP7;
  328.  register int * yyP6;
  329.  register int * yyP5;
  330. # endif
  331. {
  332.   if (var == NoTree) return;
  333.   if (id == NoTree) return;
  334. # line 212 "AdaptF90.puma"
  335.  {
  336.   bool found;
  337.   int val;
  338.   {
  339. # line 214 "AdaptF90.puma"
  340.  
  341. # line 214 "AdaptF90.puma"
  342.  
  343. # line 216 "AdaptF90.puma"
  344.    GetIntConstValue (var, & found, & val);
  345. # line 217 "AdaptF90.puma"
  346.    if (! (found)) goto yyL1;
  347.   }
  348.    * yyP7 = true;
  349.    * yyP6 = 0;
  350.    * yyP5 = 0;
  351.    return;
  352.  }
  353. yyL1:;
  354.  
  355.  
  356.   switch (var->Kind) {
  357.   case kLOOP_VAR:
  358.   if (id->Kind == kLOOP_VAR) {
  359. # line 220 "AdaptF90.puma"
  360.   {
  361. # line 222 "AdaptF90.puma"
  362.    if (! (var->LOOP_VAR.LOOP_VARNAME->VAR_OBJ.Ident == id->LOOP_VAR.LOOP_VARNAME->VAR_OBJ.Ident)) goto yyL2;
  363.   }
  364.    * yyP7 = true;
  365.    * yyP6 = 0;
  366.    * yyP5 = 1;
  367.    return;
  368. yyL2:;
  369.  
  370. # line 225 "AdaptF90.puma"
  371.    * yyP7 = true;
  372.    * yyP6 = 0;
  373.    * yyP5 = 0;
  374.    return;
  375.  
  376.   }
  377.   break;
  378.   case kUSED_VAR:
  379.   if (id->Kind == kLOOP_VAR) {
  380. # line 229 "AdaptF90.puma"
  381.   {
  382. # line 231 "AdaptF90.puma"
  383.    if (! (var->USED_VAR.VARNAME->VAR_OBJ.Ident == id->LOOP_VAR.LOOP_VARNAME->VAR_OBJ.Ident)) goto yyL4;
  384.   }
  385.    * yyP7 = true;
  386.    * yyP6 = 0;
  387.    * yyP5 = 1;
  388.    return;
  389. yyL4:;
  390.  
  391. # line 234 "AdaptF90.puma"
  392.    * yyP7 = true;
  393.    * yyP6 = 0;
  394.    * yyP5 = 0;
  395.    return;
  396.  
  397.   }
  398.   break;
  399.   case kINDEXED_VAR:
  400. # line 238 "AdaptF90.puma"
  401.    * yyP7 = false;
  402.    * yyP6 = 0;
  403.    * yyP5 = 0;
  404.    return;
  405.  
  406.   case kBTE_LIST:
  407.   if (var->BTE_LIST.Elem->Kind == kSLICE_EXP) {
  408.   if (id->Kind == kLOOP_VAR) {
  409. # line 241 "AdaptF90.puma"
  410.   {
  411. # line 243 "AdaptF90.puma"
  412.    if (! (IsVarInExp (id->LOOP_VAR.LOOP_VARNAME->VAR_OBJ.Ident, var->BTE_LIST.Elem) > 0)) goto yyL7;
  413.   }
  414.    * yyP7 = false;
  415.    * yyP6 = 0;
  416.    * yyP5 = 0;
  417.    return;
  418. yyL7:;
  419.  
  420.   }
  421. # line 246 "AdaptF90.puma"
  422.  {
  423.   bool yyV1;
  424.   int yyV2;
  425.   int yyV3;
  426.   {
  427. # line 247 "AdaptF90.puma"
  428.    FindLoopVarIndex (var->BTE_LIST.Next, id, & yyV1, & yyV2, & yyV3);
  429.   }
  430.    * yyP7 = yyV1;
  431.    * yyP6 = yyV2 + 1;
  432.    * yyP5 = yyV3;
  433.    return;
  434.  }
  435.  
  436.   }
  437. # line 250 "AdaptF90.puma"
  438.  {
  439.   bool yyV1;
  440.   int yyV2;
  441.   int yyV3;
  442.   bool yyV4;
  443.   int yyV5;
  444.   int yyV6;
  445.   {
  446. # line 252 "AdaptF90.puma"
  447.    FindLoopVarIndex (var->BTE_LIST.Elem, id, & yyV1, & yyV2, & yyV3);
  448. # line 253 "AdaptF90.puma"
  449.    FindLoopVarIndex (var->BTE_LIST.Next, id, & yyV4, & yyV5, & yyV6);
  450. # line 255 "AdaptF90.puma"
  451.  yyV1 = (yyV1 && yyV4);
  452.      if ((yyV3 != 0) && (yyV6 != 0))
  453.        yyV1 = false;
  454.      if (yyV6 != 0)
  455.        { yyV2 = yyV5;
  456.          yyV3     = yyV6;
  457.        }
  458.  
  459.   }
  460.    * yyP7 = yyV1;
  461.    * yyP6 = yyV2;
  462.    * yyP5 = yyV3;
  463.    return;
  464.  }
  465.  
  466.   case kBTE_EMPTY:
  467. # line 265 "AdaptF90.puma"
  468.    * yyP7 = true;
  469.    * yyP6 = 0;
  470.    * yyP5 = 0;
  471.    return;
  472.  
  473.   case kVAR_EXP:
  474. # line 268 "AdaptF90.puma"
  475.  {
  476.   bool yyV1;
  477.   int yyV2;
  478.   int yyV3;
  479.   {
  480. # line 269 "AdaptF90.puma"
  481.    FindLoopVarIndex (var->VAR_EXP.V, id, & yyV1, & yyV2, & yyV3);
  482.   }
  483.    * yyP7 = yyV1;
  484.    * yyP6 = yyV2;
  485.    * yyP5 = yyV3;
  486.    return;
  487.  }
  488.  
  489.   case kOP_EXP:
  490.   if (var->OP_EXP.EXP_OP->Kind == kOP_PLUS) {
  491. # line 272 "AdaptF90.puma"
  492.  {
  493.   bool yyV1;
  494.   int yyV2;
  495.   int yyV3;
  496.   bool yyV4;
  497.   int yyV5;
  498.   int yyV6;
  499.   {
  500. # line 274 "AdaptF90.puma"
  501.    FindLoopVarIndex (var->OP_EXP.OPND1, id, & yyV1, & yyV2, & yyV3);
  502. # line 275 "AdaptF90.puma"
  503.    FindLoopVarIndex (var->OP_EXP.OPND2, id, & yyV4, & yyV5, & yyV6);
  504. # line 277 "AdaptF90.puma"
  505.  yyV1 = (yyV1 && yyV4);
  506.      if ((yyV3 != 0) && (yyV6 != 0))
  507.        {
  508.          yyV1 = (yyV2 == yyV5);
  509.        }
  510.      if (yyV6 != 0)
  511.        yyV2 = yyV5;
  512.      yyV3 += yyV6;
  513.  
  514.   }
  515.    * yyP7 = yyV1;
  516.    * yyP6 = yyV2;
  517.    * yyP5 = yyV3;
  518.    return;
  519.  }
  520.  
  521.   }
  522.   if (var->OP_EXP.EXP_OP->Kind == kOP_MINUS) {
  523. # line 288 "AdaptF90.puma"
  524.  {
  525.   bool yyV1;
  526.   int yyV2;
  527.   int yyV3;
  528.   bool yyV4;
  529.   int yyV5;
  530.   int yyV6;
  531.   {
  532. # line 290 "AdaptF90.puma"
  533.    FindLoopVarIndex (var->OP_EXP.OPND1, id, & yyV1, & yyV2, & yyV3);
  534. # line 291 "AdaptF90.puma"
  535.    FindLoopVarIndex (var->OP_EXP.OPND2, id, & yyV4, & yyV5, & yyV6);
  536. # line 293 "AdaptF90.puma"
  537.  yyV1 = (yyV1 && yyV4);
  538.      if ((yyV3 != 0) && (yyV6 != 0))
  539.        {
  540.          yyV1 = (yyV2 == yyV5);
  541.        }
  542.      if (yyV6 != 0)
  543.        yyV2 = yyV5;
  544.      yyV3 -= yyV6;
  545.  
  546.   }
  547.    * yyP7 = yyV1;
  548.    * yyP6 = yyV2;
  549.    * yyP5 = yyV3;
  550.    return;
  551.  }
  552.  
  553.   }
  554.   if (var->OP_EXP.EXP_OP->Kind == kOP_TIMES) {
  555. # line 304 "AdaptF90.puma"
  556.  {
  557.   bool yyV1;
  558.   int yyV2;
  559.   int yyV3;
  560.   bool yyV4;
  561.   int yyV5;
  562.   int yyV6;
  563.   {
  564. # line 307 "AdaptF90.puma"
  565.    FindLoopVarIndex (var->OP_EXP.OPND1, id, & yyV1, & yyV2, & yyV3);
  566. # line 308 "AdaptF90.puma"
  567.    FindLoopVarIndex (var->OP_EXP.OPND2, id, & yyV4, & yyV5, & yyV6);
  568. # line 310 "AdaptF90.puma"
  569.  yyV1 = (yyV1 && yyV4);
  570.      if ((yyV3 != 0) && (yyV6 != 0))
  571.        yyV1 = false;
  572.      if (yyV6 != 0)
  573.        { yyV2 = yyV5;
  574.          yyV3     = yyV6;
  575.        }
  576.  
  577.   }
  578.    * yyP7 = yyV1;
  579.    * yyP6 = yyV2;
  580.    * yyP5 = yyV3;
  581.    return;
  582.  }
  583.  
  584.   }
  585.   break;
  586.   case kOP1_EXP:
  587.   if (var->OP1_EXP.EXP_OP1->Kind == kOP1_SIGN) {
  588. # line 320 "AdaptF90.puma"
  589.  {
  590.   bool yyV1;
  591.   int yyV2;
  592.   int yyV3;
  593.   {
  594. # line 321 "AdaptF90.puma"
  595.    FindLoopVarIndex (var->OP1_EXP.OPND, id, & yyV1, & yyV2, & yyV3);
  596.   }
  597.    * yyP7 = yyV1;
  598.    * yyP6 = yyV2;
  599.    * yyP5 = - yyV3;
  600.    return;
  601.  }
  602.  
  603.   }
  604.   break;
  605.   case kFUNC_CALL_EXP:
  606. # line 324 "AdaptF90.puma"
  607.    * yyP7 = false;
  608.    * yyP6 = 0;
  609.    * yyP5 = 0;
  610.    return;
  611.  
  612.   }
  613.  
  614. # line 327 "AdaptF90.puma"
  615.   {
  616. # line 328 "AdaptF90.puma"
  617.    printf ("FindLoopVarIndex failed\n");
  618. # line 329 "AdaptF90.puma"
  619.    FileUnparse (stdout, var);
  620. # line 330 "AdaptF90.puma"
  621.    WriteTree (stdout, var);
  622.   }
  623.    * yyP7 = false;
  624.    * yyP6 = 0;
  625.    * yyP5 = 0;
  626.    return;
  627.  
  628. ;
  629. }
  630.  
  631. static void Substitute
  632. # if defined __STDC__ | defined __cplusplus
  633. (register tTree var, register tTree id, register int val, register tTree slice)
  634. # else
  635. (var, id, val, slice)
  636.  register tTree var;
  637.  register tTree id;
  638.  register int val;
  639.  register tTree slice;
  640. # endif
  641. {
  642.   if (var == NoTree) return;
  643.   if (id == NoTree) return;
  644.   if (slice == NoTree) return;
  645.   if (var->Kind == kINDEXED_VAR) {
  646. # line 347 "AdaptF90.puma"
  647.   {
  648. # line 348 "AdaptF90.puma"
  649.    Substitute (var->INDEXED_VAR.IND_EXPS, id, val, slice);
  650.   }
  651.    return;
  652.  
  653.   }
  654.   if (var->Kind == kBTE_LIST) {
  655.   if (id->Kind == kLOOP_VAR) {
  656.   if (slice->Kind == kSLICE_EXP) {
  657. # line 351 "AdaptF90.puma"
  658.  {
  659.   int m;
  660.   tTree nstart;
  661.   tTree nstop;
  662.   tTree ninc;
  663.   {
  664. # line 354 "AdaptF90.puma"
  665.  
  666. # line 356 "AdaptF90.puma"
  667.    m = IsVarInExp (id->LOOP_VAR.LOOP_VARNAME->VAR_OBJ.Ident, var->BTE_LIST.Elem);
  668. # line 358 "AdaptF90.puma"
  669.  
  670. #ifdef DEBUG
  671.      printf ("Substitute in Index, index = "); FileUnparse (stdout, var->BTE_LIST.Elem);
  672.      printf ("\n");
  673.      printf ("Index "); FileUnparse (stdout, id); printf (" appears %d\n", m);
  674. #endif
  675.  
  676. # line 366 "AdaptF90.puma"
  677.    if (! (m > 0)) goto yyL2;
  678.   {
  679. # line 368 "AdaptF90.puma"
  680.  
  681. # line 368 "AdaptF90.puma"
  682.  
  683. # line 368 "AdaptF90.puma"
  684.  
  685. # line 370 "AdaptF90.puma"
  686.  nstop  = CopyTree (var->BTE_LIST.Elem);
  687.      nstart = Replace (var->BTE_LIST.Elem, id, slice->SLICE_EXP.START);
  688.      nstop  = Replace (nstop, id, slice->SLICE_EXP.STOP);
  689.      if (val > 0)
  690.         ninc   = CopyTree (slice->SLICE_EXP.INC);
  691.       else
  692.         {
  693.           if (slice->SLICE_EXP.INC == NoTree)
  694.              ninc = mCONST_EXP (mINT_CONSTANT (-1));
  695.           else if (slice->SLICE_EXP.INC->Kind == kDUMMY_EXP)
  696.              ninc = mCONST_EXP (mINT_CONSTANT (-1));
  697.           else ninc = mOP1_EXP (mOP1_SIGN(), CopyTree (slice->SLICE_EXP.INC));
  698.         }
  699.      var->BTE_LIST.Elem   = mSLICE_EXP (nstart, nstop, ninc);
  700.  
  701.   }
  702.   }
  703.    return;
  704.  }
  705. yyL2:;
  706.  
  707.   }
  708.   }
  709. # line 387 "AdaptF90.puma"
  710.   {
  711. # line 388 "AdaptF90.puma"
  712.    Substitute (var->BTE_LIST.Next, id, val, slice);
  713.   }
  714.    return;
  715.  
  716.   }
  717.   if (var->Kind == kBTE_EMPTY) {
  718. # line 391 "AdaptF90.puma"
  719.   {
  720. # line 392 "AdaptF90.puma"
  721.    printf ("FATAL ERROR: Substitute failed\n");
  722. # line 393 "AdaptF90.puma"
  723.    kill_in_protocol ();
  724.   }
  725.    return;
  726.  
  727.   }
  728. ;
  729. }
  730.  
  731. static tTree Replace
  732. # if defined __STDC__ | defined __cplusplus
  733. (register tTree exp, register tTree id, register tTree newexp)
  734. # else
  735. (exp, id, newexp)
  736.  register tTree exp;
  737.  register tTree id;
  738.  register tTree newexp;
  739. # endif
  740. {
  741.   if (exp->Kind == kVAR_EXP) {
  742.   if (exp->VAR_EXP.V->Kind == kLOOP_VAR) {
  743.   if (id->Kind == kLOOP_VAR) {
  744. # line 404 "AdaptF90.puma"
  745.   {
  746. # line 406 "AdaptF90.puma"
  747.    if (! (exp->VAR_EXP.V->LOOP_VAR.LOOP_VARNAME->VAR_OBJ.Ident == id->LOOP_VAR.LOOP_VARNAME->VAR_OBJ.Ident)) goto yyL1;
  748.   }
  749.    return CopyTree (newexp);
  750. yyL1:;
  751.  
  752.   }
  753.   }
  754.   if (exp->VAR_EXP.V->Kind == kINDEXED_VAR) {
  755. # line 411 "AdaptF90.puma"
  756.    return Replace (exp->VAR_EXP.V->INDEXED_VAR.IND_EXPS, id, newexp);
  757.  
  758.   }
  759. # line 415 "AdaptF90.puma"
  760.    return exp;
  761.  
  762.   }
  763.   if (exp->Kind == kBTE_LIST) {
  764. # line 419 "AdaptF90.puma"
  765.   {
  766. # line 420 "AdaptF90.puma"
  767.  exp->BTE_LIST.Elem = Replace (exp->BTE_LIST.Elem, id, newexp);
  768.      exp->BTE_LIST.Next = Replace (exp->BTE_LIST.Next, id, newexp);
  769.  
  770.   }
  771.    return exp;
  772.  
  773.   }
  774.   if (exp->Kind == kBTE_EMPTY) {
  775. # line 426 "AdaptF90.puma"
  776.    return exp;
  777.  
  778.   }
  779.   if (exp->Kind == kOP_EXP) {
  780. # line 430 "AdaptF90.puma"
  781.   {
  782. # line 431 "AdaptF90.puma"
  783.  exp->OP_EXP.OPND1 = Replace (exp->OP_EXP.OPND1, id, newexp);
  784.      exp->OP_EXP.OPND2 = Replace (exp->OP_EXP.OPND2, id, newexp);
  785.  
  786.   }
  787.    return exp;
  788.  
  789.   }
  790.   if (exp->Kind == kOP1_EXP) {
  791. # line 438 "AdaptF90.puma"
  792.   {
  793. # line 439 "AdaptF90.puma"
  794.  exp->OP1_EXP.OPND = Replace (exp->OP1_EXP.OPND, id, newexp);
  795.  
  796.   }
  797.    return exp;
  798.  
  799.   }
  800.   if (exp->Kind == kCONST_EXP) {
  801. # line 444 "AdaptF90.puma"
  802.    return exp;
  803.  
  804.   }
  805. # line 448 "AdaptF90.puma"
  806.   {
  807. # line 449 "AdaptF90.puma"
  808.    printf ("Internal Error: Replace failed\n");
  809. # line 450 "AdaptF90.puma"
  810.    FileUnparse (stdout, exp);
  811. # line 451 "AdaptF90.puma"
  812.    kill_in_protocol ();
  813.   }
  814.    return exp;
  815.  
  816. }
  817.  
  818. static bool IsNewVectorLegal
  819. # if defined __STDC__ | defined __cplusplus
  820. (register tTree var, register int pos, register tTree slice)
  821. # else
  822. (var, pos, slice)
  823.  register tTree var;
  824.  register int pos;
  825.  register tTree slice;
  826. # endif
  827. {
  828. # line 458 "AdaptF90.puma"
  829.  
  830. bool ok;
  831. tTree save, dummy;
  832.  
  833.   if (var == NoTree) return false;
  834.   if (slice == NoTree) return false;
  835. # line 463 "AdaptF90.puma"
  836.   {
  837. # line 464 "AdaptF90.puma"
  838.    if (! (TreeDistribution (var) == 1)) goto yyL1;
  839.   }
  840.    return true;
  841. yyL1:;
  842.  
  843.   if (var->Kind == kINDEXED_VAR) {
  844.   if (slice->Kind == kSLICE_EXP) {
  845. # line 467 "AdaptF90.puma"
  846.   {
  847. # line 469 "AdaptF90.puma"
  848.  
  849.      SwitchIndex (var->INDEXED_VAR.IND_EXPS, pos, slice, &save);
  850.      ok = IsContiguousSection (var);
  851.  
  852.      SwitchIndex (var->INDEXED_VAR.IND_EXPS, pos, save, &dummy);
  853.      return (ok);
  854.  
  855.   }
  856.    return true;
  857.  
  858.   }
  859.   }
  860. # line 478 "AdaptF90.puma"
  861.   {
  862. # line 479 "AdaptF90.puma"
  863.    printf ("Illegal call of IsNewVectorLegal\n");
  864. # line 480 "AdaptF90.puma"
  865.    WriteTree (stdout, var);
  866. # line 481 "AdaptF90.puma"
  867.    WriteTree (stdout, slice);
  868. # line 482 "AdaptF90.puma"
  869.    FileUnparse (stdout, var);
  870. # line 482 "AdaptF90.puma"
  871.    printf (" is the variable\n");
  872. # line 483 "AdaptF90.puma"
  873.    FileUnparse (stdout, slice);
  874. # line 483 "AdaptF90.puma"
  875.    printf (" is the slice\n");
  876. # line 484 "AdaptF90.puma"
  877.    kill_in_protocol ();
  878.   }
  879.    return true;
  880.  
  881. }
  882.  
  883. static void SwitchIndex
  884. # if defined __STDC__ | defined __cplusplus
  885. (register tTree indexes, register int n, register tTree new, register tTree * old)
  886. # else
  887. (indexes, n, new, old)
  888.  register tTree indexes;
  889.  register int n;
  890.  register tTree new;
  891.  register tTree * old;
  892. # endif
  893. {
  894.   if (indexes == NoTree) return;
  895.   if (new == NoTree) return;
  896.   if (indexes->Kind == kBTE_LIST) {
  897.  {
  898.   tTree save;
  899.   if (equalint (n, 0)) {
  900. # line 489 "AdaptF90.puma"
  901.   {
  902. # line 491 "AdaptF90.puma"
  903.  
  904. # line 493 "AdaptF90.puma"
  905.  save = indexes->BTE_LIST.Elem;
  906.      indexes->BTE_LIST.Elem = new;
  907.  
  908.   }
  909.    * old = save;
  910.    return;
  911.  
  912.   }
  913.  }
  914. # line 498 "AdaptF90.puma"
  915.  {
  916.   tTree yyV1;
  917.   {
  918. # line 499 "AdaptF90.puma"
  919.    SwitchIndex (indexes->BTE_LIST.Next, n - 1, new, & yyV1);
  920.   }
  921.    * old = yyV1;
  922.    return;
  923.  }
  924.  
  925.   }
  926.   if (indexes->Kind == kBTE_EMPTY) {
  927. # line 502 "AdaptF90.puma"
  928.   {
  929. # line 503 "AdaptF90.puma"
  930.    printf ("Illegal call of SwitchIndex in AdaptF90\n");
  931. # line 504 "AdaptF90.puma"
  932.    kill_in_protocol ();
  933.   }
  934.    * old = NoTree;
  935.    return;
  936.  
  937.   }
  938. ;
  939. }
  940.  
  941. void BeginAdaptF90 ()
  942. {
  943. }
  944.  
  945. void CloseAdaptF90 ()
  946. {
  947. }
  948.