home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / adaptor.zip / adapt.zip / adaptor / src / adaptf77.c < prev    next >
Text File  |  1994-01-03  |  27KB  |  1,161 lines
  1. # include "F77.h"
  2. # include "yyAF77.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 35 "AdaptF77.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 "Transfor.h"    /* AppendDECLS */
  45. # include "Shapes.h"
  46.  
  47. # include "TempScal.h"  /* MakeNewLoopVar */
  48.  
  49. # include "Expressi.h"
  50. # include "Reductio.h"
  51.  
  52. # include "IndexSha.h"  /* FindShapeExp */
  53.  
  54. # undef DEBUG
  55.  
  56. tObject loop_var_objs [10];  /* decl entries for new loop variables   */
  57.  
  58.        /***************************************
  59.        *                                      *
  60.        *  split_shape :     dim  = d          *
  61.        *                                      *
  62.        *                                      *
  63.        *   ug1:og1:str1                       *
  64.        *   ....                               *
  65.        *   ugd:ogd:strd   -> move to s1       *
  66.        *   ....                               *
  67.        *   ugn:ogn:strn                       *
  68.        *                                      *
  69.        ***************************************/
  70.  
  71. void split_shape (s, s1, dim)
  72. shape s, s1;
  73. int dim;
  74. { int i, j;
  75.  
  76.   if ((dim < 1) || (dim > s->rank))
  77.      { printf ("Illegal shape - dim in split_shape\n");
  78.        exit (-1);
  79.      }
  80.  
  81.   /* set up one-dimensional shape for reduction loop */
  82.  
  83.   s1->rank = 1;
  84.   for (i = 0; i < 3; i ++)
  85.     s1->bounds[0][i] = s->bounds[dim-1][i];
  86.   s1->perm[0] = s->perm[dim-1];
  87.  
  88.   /* reduced shape back in s */
  89.  
  90.   for (j = 0; j < s->rank; j ++)
  91.     if (j >= dim)
  92.       for (i = 0; i < 3; i++)
  93.         { s->bounds[j-1][i] = s->bounds[j][i];
  94.           s->perm[j-1] = s->perm[j];
  95.         }
  96.  
  97.   s->rank = s->rank - 1;
  98.  
  99. } /* split_shape */
  100.  
  101.  
  102.  
  103. static FILE * yyf = stdout;
  104.  
  105. static void yyAbort
  106. # ifdef __cplusplus
  107.  (char * yyFunction)
  108. # else
  109.  (yyFunction) char * yyFunction;
  110. # endif
  111. {
  112.  (void) fprintf (stderr, "Error: module AdaptF77, routine %s failed\n", yyFunction);
  113.  exit (1);
  114. }
  115.  
  116. tTree F77Where ARGS((tTree t));
  117. void F77IO ARGS((tTree t));
  118. tTree F77Assign ARGS((tTree t));
  119. tTree F77Reduction ARGS((tTree var, tTree exp));
  120. static void GetFormalShape ARGS((tTree t, shape s));
  121. static void UpdateFormalShape ARGS((tTree indexes, shape s, int n));
  122. static tTree SetActualShape ARGS((tTree t, shape s));
  123. static tTree SetSpreadActualShape ARGS((tTree t, shape s));
  124. static void SetActualIndexShape ARGS((tTree ind, shape s, int n));
  125. static tTree MakeOuterLoops ARGS((shape s, tTree body, int k));
  126. static tTree MakeListBody ARGS((tTree t));
  127. static tTree MakeOuterImpliedLoops ARGS((shape s, tTree body));
  128. static tTree MakeOuterImpliedLoopsV ARGS((shape s, tTree body));
  129.  
  130. tTree F77Where
  131. # if defined __STDC__ | defined __cplusplus
  132. (register tTree t)
  133. # else
  134. (t)
  135.  register tTree t;
  136. # endif
  137. {
  138. # line 110 "AdaptF77.puma"
  139.  
  140. struct_shape shp;
  141. tTree newacf;
  142.  
  143.   if (t->Kind == kACF_WHERE) {
  144. # line 115 "AdaptF77.puma"
  145.   {
  146. # line 116 "AdaptF77.puma"
  147.  GetFormalShape (t->ACF_WHERE.WHERE_EXP, &shp);
  148.  
  149.      t->ACF_WHERE.WHERE_EXP = SetActualShape (t->ACF_WHERE.WHERE_EXP, &shp);
  150.      t->ACF_WHERE.TRUE_PART = SetActualShape (t->ACF_WHERE.TRUE_PART, &shp);
  151.      t->ACF_WHERE.FALSE_PART = SetActualShape (t->ACF_WHERE.FALSE_PART, &shp);
  152.  
  153.      newacf = mACF_IF (t->ACF_WHERE.WHERE_EXP, t->ACF_WHERE.TRUE_PART, t->ACF_WHERE.FALSE_PART);
  154.      newacf->ACF_NODE.Line  = t->ACF_WHERE.Line;
  155.  
  156.      newacf = MakeOuterLoops (&shp, newacf,1);
  157.  
  158.   }
  159.    return newacf;
  160.  
  161.   }
  162.  yyAbort ("F77Where");
  163. }
  164.  
  165. void F77IO
  166. # if defined __STDC__ | defined __cplusplus
  167. (register tTree t)
  168. # else
  169. (t)
  170.  register tTree t;
  171. # endif
  172. {
  173. # line 140 "AdaptF77.puma"
  174.  
  175. struct_shape shp;
  176. tTree new;
  177.  
  178.   if (t == NoTree) return;
  179.   if (t->Kind == kBTP_LIST) {
  180.   if (t->BTP_LIST.Elem->Kind == kVAR_PARAM) {
  181.   if (t->BTP_LIST.Elem->VAR_PARAM.V->Kind == kADDR) {
  182.   if (t->BTP_LIST.Elem->VAR_PARAM.V->ADDR.E->Kind == kDO_EXP) {
  183. # line 145 "AdaptF77.puma"
  184.   {
  185. # line 147 "AdaptF77.puma"
  186.    F77IO (t->BTP_LIST.Next);
  187.   }
  188.    return;
  189.  
  190.   }
  191. # line 153 "AdaptF77.puma"
  192.   {
  193. # line 154 "AdaptF77.puma"
  194.  if (TreeRank (t->BTP_LIST.Elem->VAR_PARAM.V->ADDR.E) > 0)
  195.        {
  196.          GetFormalShape (t->BTP_LIST.Elem->VAR_PARAM.V->ADDR.E, &shp);
  197.          new = SetActualShape (t->BTP_LIST.Elem->VAR_PARAM.V->ADDR.E, &shp);
  198.          new = MakeOuterImpliedLoops (&shp, new);
  199.          t->BTP_LIST.Elem->VAR_PARAM.V->ADDR.E = new;
  200.        }
  201.    F77IO (t->BTP_LIST.Next);
  202.  
  203.   }
  204.    return;
  205.  
  206.   }
  207.   if (t->BTP_LIST.Elem->VAR_PARAM.V->Kind == kDO_VAR) {
  208. # line 149 "AdaptF77.puma"
  209.   {
  210. # line 152 "AdaptF77.puma"
  211.    F77IO (t->BTP_LIST.Next);
  212.   }
  213.  
  214.    return;
  215.  
  216.   }
  217.   if (t->BTP_LIST.Elem->VAR_PARAM.V->Kind == kUSED_VAR) {
  218. # line 164 "AdaptF77.puma"
  219.   {
  220. # line 169 "AdaptF77.puma"
  221.    F77IO (t->BTP_LIST.Next);
  222.   }
  223.  
  224.    return;
  225.  
  226.   }
  227. # line 168 "AdaptF77.puma"
  228.   {
  229. # line 169 "AdaptF77.puma"
  230.  if (TreeRank (t->BTP_LIST.Elem->VAR_PARAM.V) > 0)
  231.        {
  232.          GetFormalShape (t->BTP_LIST.Elem->VAR_PARAM.V, &shp);
  233.          new = SetActualShape (t->BTP_LIST.Elem->VAR_PARAM.V, &shp);
  234.          new = MakeOuterImpliedLoopsV (&shp, new);
  235.          t->BTP_LIST.Elem->VAR_PARAM.V = new;
  236.        }
  237.  
  238.   }
  239.    return;
  240.  
  241.   }
  242.   }
  243.   if (t->Kind == kBTP_EMPTY) {
  244. # line 179 "AdaptF77.puma"
  245.    return;
  246.  
  247.   }
  248. # line 182 "AdaptF77.puma"
  249.   {
  250. # line 183 "AdaptF77.puma"
  251.    printf ("Illegal Tree in IOF77\n");
  252. # line 184 "AdaptF77.puma"
  253.    FileUnparse (stdout, t);
  254. # line 185 "AdaptF77.puma"
  255.    WriteTree (stdout, t);
  256. # line 186 "AdaptF77.puma"
  257.    exit (- 1);
  258.   }
  259.    return;
  260.  
  261. ;
  262. }
  263.  
  264. tTree F77Assign
  265. # if defined __STDC__ | defined __cplusplus
  266. (register tTree t)
  267. # else
  268. (t)
  269.  register tTree t;
  270. # endif
  271. {
  272. # line 191 "AdaptF77.puma"
  273.  
  274. struct_shape shp;
  275. tTree new;
  276.  
  277.   if (t->Kind == kACF_BASIC) {
  278.   if (t->ACF_BASIC.BASIC_STMT->Kind == kASSIGN_STMT) {
  279. # line 196 "AdaptF77.puma"
  280.   {
  281. # line 197 "AdaptF77.puma"
  282.  
  283.      GetFormalShape (t->ACF_BASIC.BASIC_STMT->ASSIGN_STMT.ASSIGN_VAR, &shp);
  284. # ifdef DEBUG
  285.      printf ("Call of F77 Assign\n"); FileUnparse (stdout, t);
  286.      printf ("Here is the Actual shape of the lhs variable\n");
  287.      PrintCurrentShape (&shp);
  288.      printf ("Will actualize shape in var and exp\n");
  289. # endif
  290.      if (shp.rank > 0)
  291.        {
  292.          t->ACF_BASIC.BASIC_STMT->ASSIGN_STMT.ASSIGN_VAR = SetActualShape (t->ACF_BASIC.BASIC_STMT->ASSIGN_STMT.ASSIGN_VAR, &shp);
  293.          t->ACF_BASIC.BASIC_STMT->ASSIGN_STMT.ASSIGN_EXP = SetActualShape (t->ACF_BASIC.BASIC_STMT->ASSIGN_STMT.ASSIGN_EXP, &shp);
  294.          new = MakeOuterLoops (&shp, t, 1);
  295.          new->ACF_NODE.Line = t->ACF_BASIC.Line;
  296.        }
  297.      else
  298.        new = t;
  299.  
  300.   }
  301.    return new;
  302.  
  303.   }
  304.   }
  305.  yyAbort ("F77Assign");
  306. }
  307.  
  308. tTree F77Reduction
  309. # if defined __STDC__ | defined __cplusplus
  310. (register tTree var, register tTree exp)
  311. # else
  312. (var, exp)
  313.  register tTree var;
  314.  register tTree exp;
  315. # endif
  316. {
  317. # line 230 "AdaptF77.puma"
  318.  
  319. tTree stmt, params;
  320. struct_shape shp, shp_red;
  321. tTree red_var;
  322.  
  323.   if (exp->Kind == kFUNC_CALL_EXP) {
  324.   if (exp->FUNC_CALL_EXP.FUNC_PARAMS->Kind == kBTP_LIST) {
  325.   if (exp->FUNC_CALL_EXP.FUNC_PARAMS->BTP_LIST.Elem->Kind == kVAR_PARAM) {
  326.   if (exp->FUNC_CALL_EXP.FUNC_PARAMS->BTP_LIST.Next->Kind == kBTP_LIST) {
  327.   if (exp->FUNC_CALL_EXP.FUNC_PARAMS->BTP_LIST.Next->BTP_LIST.Next->Kind == kBTP_EMPTY) {
  328. # line 258 "AdaptF77.puma"
  329.  {
  330.   bool found;
  331.   int idim;
  332.   {
  333. # line 261 "AdaptF77.puma"
  334.  
  335. # line 262 "AdaptF77.puma"
  336.  
  337. # line 264 "AdaptF77.puma"
  338.  GetIntConstValue (exp->FUNC_CALL_EXP.FUNC_PARAMS->BTP_LIST.Next->BTP_LIST.Elem, &found, &idim);
  339.       if (!found)
  340.        { error_protocol ("dim parameter of reduction unknown at compile time");
  341.          idim = 1;
  342.        }
  343.  
  344.       GetFormalShape (exp->FUNC_CALL_EXP.FUNC_PARAMS->BTP_LIST.Elem->VAR_PARAM.V, &shp);
  345.       exp->FUNC_CALL_EXP.FUNC_PARAMS->BTP_LIST.Elem->VAR_PARAM.V = SetActualShape (exp->FUNC_CALL_EXP.FUNC_PARAMS->BTP_LIST.Elem->VAR_PARAM.V, &shp);
  346.       split_shape (&shp, &shp_red, idim);
  347.  
  348.       red_var = SetActualShape (var, &shp);
  349.  
  350.       params = mBTP_EMPTY ();
  351.       params = mBTP_LIST (exp->FUNC_CALL_EXP.FUNC_PARAMS->BTP_LIST.Elem, params);
  352.       params = mBTP_LIST (mVAR_PARAM (red_var), params);
  353.       stmt   = mREDUCE_STMT (exp->FUNC_CALL_EXP.FUNC_ID, params);
  354.       stmt   = mACF_BASIC (stmt);
  355.       stmt   = MakeOuterLoops (&shp_red, stmt, 0);
  356.       stmt   = mACF_LIST (stmt, mACF_EMPTY());
  357.       stmt   = mACF_LIST (InitReductionStmt (CopyTree(red_var),
  358.                                              TreeType(var),
  359.                                              exp->FUNC_CALL_EXP.FUNC_ID),
  360.                           stmt);
  361.       stmt   = MakeOuterLoops (&shp, stmt, 0);
  362.  
  363.   }
  364.   {
  365.    return stmt;
  366.   }
  367.  }
  368.  
  369.   }
  370.   }
  371.   if (exp->FUNC_CALL_EXP.FUNC_PARAMS->BTP_LIST.Next->Kind == kBTP_EMPTY) {
  372. # line 298 "AdaptF77.puma"
  373.   {
  374. # line 300 "AdaptF77.puma"
  375.  
  376.       GetFormalShape (exp->FUNC_CALL_EXP.FUNC_PARAMS->BTP_LIST.Elem->VAR_PARAM.V, &shp);
  377.       exp->FUNC_CALL_EXP.FUNC_PARAMS->BTP_LIST.Elem->VAR_PARAM.V = SetActualShape (exp->FUNC_CALL_EXP.FUNC_PARAMS->BTP_LIST.Elem->VAR_PARAM.V, &shp);
  378.       params = mBTP_EMPTY();
  379.       params = mBTP_LIST (exp->FUNC_CALL_EXP.FUNC_PARAMS->BTP_LIST.Elem, params);
  380.       params = mBTP_LIST (mVAR_PARAM (var), params);
  381.       stmt   = mREDUCE_STMT (exp->FUNC_CALL_EXP.FUNC_ID, params);
  382.       stmt   = mACF_BASIC (stmt);
  383.       stmt   = MakeOuterLoops (&shp, stmt, 0);
  384.       stmt   = mACF_LIST (stmt, NoTree);
  385.       stmt   = mACF_LIST (InitReductionStmt (CopyTree(var),
  386.                                              TreeType(var),
  387.                                              exp->FUNC_CALL_EXP.FUNC_ID),
  388.                           stmt);
  389.  
  390.  
  391.   }
  392.    return stmt;
  393.  
  394.   }
  395.   }
  396.   }
  397. # line 319 "AdaptF77.puma"
  398.   {
  399. # line 320 "AdaptF77.puma"
  400.    error_protocol ("this kind of reduction is not handled");
  401.   }
  402.    return mACF_DUMMY ();
  403.  
  404.   }
  405.  yyAbort ("F77Reduction");
  406. }
  407.  
  408. static void GetFormalShape
  409. # if defined __STDC__ | defined __cplusplus
  410. (register tTree t, shape s)
  411. # else
  412. (t, s)
  413.  register tTree t;
  414.  shape s;
  415. # endif
  416. {
  417. # line 339 "AdaptF77.puma"
  418.  
  419. int i;
  420.  
  421.   if (t == NoTree) return;
  422.  
  423.   switch (t->Kind) {
  424.   case kOP_EXP:
  425. # line 343 "AdaptF77.puma"
  426.   {
  427. # line 344 "AdaptF77.puma"
  428.  GetFormalShape (t->OP_EXP.OPND1, s);
  429.      if (s->rank == 0)
  430.         GetFormalShape (t->OP_EXP.OPND2, s);
  431.  
  432.   }
  433.    return;
  434.  
  435.   case kOP1_EXP:
  436. # line 349 "AdaptF77.puma"
  437.   {
  438. # line 350 "AdaptF77.puma"
  439.  GetFormalShape (t->OP1_EXP.OPND, s);
  440.  
  441.   }
  442.    return;
  443.  
  444.   case kCONST_EXP:
  445. # line 353 "AdaptF77.puma"
  446.   {
  447. # line 354 "AdaptF77.puma"
  448.  s->rank = 0;
  449.  
  450.   }
  451.    return;
  452.  
  453.   case kADDR:
  454. # line 357 "AdaptF77.puma"
  455.   {
  456. # line 358 "AdaptF77.puma"
  457.    GetFormalShape (t->ADDR.E, s);
  458.   }
  459.    return;
  460.  
  461.   case kARRAY_EXP:
  462.   if (t->ARRAY_EXP.ELEMENTS->Kind == kBTE_LIST) {
  463.   if (t->ARRAY_EXP.ELEMENTS->BTE_LIST.Elem->Kind == kSLICE_EXP) {
  464.   if (t->ARRAY_EXP.ELEMENTS->BTE_LIST.Next->Kind == kBTE_EMPTY) {
  465. # line 367 "AdaptF77.puma"
  466.   {
  467. # line 368 "AdaptF77.puma"
  468.  
  469.      s->rank = 1;
  470.      s->bounds[0][0] = t->ARRAY_EXP.ELEMENTS->BTE_LIST.Elem->SLICE_EXP.START;
  471.      s->bounds[0][1] = t->ARRAY_EXP.ELEMENTS->BTE_LIST.Elem->SLICE_EXP.STOP;
  472.      s->bounds[0][2] = t->ARRAY_EXP.ELEMENTS->BTE_LIST.Elem->SLICE_EXP.INC;
  473.      s->perm[0] = 1;
  474.  
  475.   }
  476.    return;
  477.  
  478.   }
  479.   }
  480.   }
  481.   break;
  482.   case kFUNC_CALL_EXP:
  483.   if (t->FUNC_CALL_EXP.FUNC_PARAMS->Kind == kBTP_LIST) {
  484.   if (t->FUNC_CALL_EXP.FUNC_PARAMS->BTP_LIST.Elem->Kind == kVAR_PARAM) {
  485. # line 376 "AdaptF77.puma"
  486.   {
  487. # line 377 "AdaptF77.puma"
  488.  
  489.      s->rank = 0;
  490.      if (IsIntrFunc (t))
  491.       { if (IntrFuncKind1 (t->FUNC_CALL_EXP.FUNC_ID->PROC_OBJ.Ident))
  492.           {
  493.             GetFormalShape (t->FUNC_CALL_EXP.FUNC_PARAMS->BTP_LIST.Elem->VAR_PARAM.V, s);
  494.           }
  495.       }
  496.  
  497.   }
  498.    return;
  499.  
  500.   }
  501.   }
  502. # line 388 "AdaptF77.puma"
  503.   {
  504. # line 389 "AdaptF77.puma"
  505.  
  506.      s->rank = 0;
  507.  
  508.   }
  509.    return;
  510.  
  511.   case kVAR_EXP:
  512. # line 393 "AdaptF77.puma"
  513.   {
  514. # line 394 "AdaptF77.puma"
  515.    GetFormalShape (t->VAR_EXP.V, s);
  516.   }
  517.    return;
  518.  
  519.   case kUSED_VAR:
  520. # line 403 "AdaptF77.puma"
  521.   {
  522. # line 404 "AdaptF77.puma"
  523.  if (TreeRank (t) == 0)
  524.         s->rank = 0;
  525.        else
  526.         { GetCurrentShape (t, s);
  527.  
  528.           for (i=0;i<s->rank;i++)
  529.              s->perm[i] = i+1;
  530.         }
  531.  
  532.   }
  533.    return;
  534.  
  535.   case kINDEXED_VAR:
  536.   if (t->INDEXED_VAR.IND_VAR->Kind == kUSED_VAR) {
  537. # line 414 "AdaptF77.puma"
  538.   {
  539. # line 415 "AdaptF77.puma"
  540.  GetCurrentShape (t->INDEXED_VAR.IND_VAR, s);
  541.      s->rank = 0;
  542.      UpdateFormalShape (t->INDEXED_VAR.IND_EXPS, s, 0);
  543.  
  544.   }
  545.    return;
  546.  
  547.   }
  548.   break;
  549.   }
  550.  
  551. # line 420 "AdaptF77.puma"
  552.   {
  553. # line 421 "AdaptF77.puma"
  554.    printf ("GetFormalShape failed\n");
  555. # line 422 "AdaptF77.puma"
  556.    FileUnparse (stdout, t);
  557. # line 423 "AdaptF77.puma"
  558.    WriteTree (stdout, t);
  559. # line 424 "AdaptF77.puma"
  560.    exit (- 1);
  561.   }
  562.    return;
  563.  
  564. ;
  565. }
  566.  
  567. static void UpdateFormalShape
  568. # if defined __STDC__ | defined __cplusplus
  569. (register tTree indexes, shape s, register int n)
  570. # else
  571. (indexes, s, n)
  572.  register tTree indexes;
  573.  shape s;
  574.  register int n;
  575. # endif
  576. {
  577. # line 441 "AdaptF77.puma"
  578.  
  579. int r, m;
  580. struct_shape h_shp;
  581.  
  582.   if (indexes == NoTree) return;
  583.   if (indexes->Kind == kBTE_LIST) {
  584.   if (indexes->BTE_LIST.Elem->Kind == kSLICE_EXP) {
  585. # line 446 "AdaptF77.puma"
  586.   {
  587. # line 448 "AdaptF77.puma"
  588.  m = s->rank;
  589.      if (indexes->BTE_LIST.Elem->SLICE_EXP.START->Kind != kDUMMY_EXP)
  590.         s->bounds[m][0] = indexes->BTE_LIST.Elem->SLICE_EXP.START;
  591.       else
  592.         s->bounds[m][0] = s->bounds[n][0];
  593.      if (indexes->BTE_LIST.Elem->SLICE_EXP.STOP->Kind != kDUMMY_EXP)
  594.         s->bounds[m][1] = indexes->BTE_LIST.Elem->SLICE_EXP.STOP;
  595.       else
  596.         s->bounds[m][1] = s->bounds[n][1];
  597.      if (indexes->BTE_LIST.Elem->SLICE_EXP.INC->Kind != kDUMMY_EXP)
  598.         s->bounds[m][2] = indexes->BTE_LIST.Elem->SLICE_EXP.INC;
  599.       else
  600.         s->bounds[m][2] = s->bounds[n][2];
  601.      s->perm[m] = m + 1;
  602.      s->rank = m + 1;
  603.  
  604. # line 464 "AdaptF77.puma"
  605.    UpdateFormalShape (indexes->BTE_LIST.Next, s, n + 1);
  606.   }
  607.    return;
  608.  
  609.   }
  610. # line 467 "AdaptF77.puma"
  611.   {
  612. # line 469 "AdaptF77.puma"
  613.  r = TreeRank(indexes->BTE_LIST.Elem);
  614.      if (r > 0)
  615.         {
  616.           if (r == 1)
  617.             { GetFormalShape (indexes->BTE_LIST.Elem, &h_shp);
  618.               if (h_shp.rank != 1)
  619.                  error_protocol ("unknown fatal error");
  620.               m = s->rank;
  621.               s->bounds[m][0] = h_shp.bounds[0][0];
  622.               s->bounds[m][1] = h_shp.bounds[0][1];
  623.               s->bounds[m][2] = h_shp.bounds[0][2];
  624.               s->perm[m] = m+1;
  625.               s->rank = m+1;
  626.             }
  627.            else
  628.              error_protocol ("illegal rank in indirect addressing");
  629.          }
  630.  
  631. # line 487 "AdaptF77.puma"
  632.    UpdateFormalShape (indexes->BTE_LIST.Next, s, n + 1);
  633.   }
  634.    return;
  635.  
  636.   }
  637.   if (indexes->Kind == kBTE_EMPTY) {
  638. # line 490 "AdaptF77.puma"
  639.    return;
  640.  
  641.   }
  642. # line 493 "AdaptF77.puma"
  643.   {
  644. # line 494 "AdaptF77.puma"
  645.    printf ("Illegal Tree in UpdateFormalShape\n");
  646. # line 495 "AdaptF77.puma"
  647.    WriteTree (stdout, indexes);
  648. # line 496 "AdaptF77.puma"
  649.    exit (- 1);
  650.   }
  651.    return;
  652.  
  653. ;
  654. }
  655.  
  656. static tTree SetActualShape
  657. # if defined __STDC__ | defined __cplusplus
  658. (register tTree t, shape s)
  659. # else
  660. (t, s)
  661.  register tTree t;
  662.  shape s;
  663. # endif
  664. {
  665. # line 512 "AdaptF77.puma"
  666.  
  667. tTree newexp;
  668.  
  669.  
  670.   switch (t->Kind) {
  671.   case kACF_LIST:
  672. # line 516 "AdaptF77.puma"
  673.   {
  674. # line 517 "AdaptF77.puma"
  675.  t->ACF_LIST.Elem = SetActualShape (t->ACF_LIST.Elem, s);
  676.      t->ACF_LIST.Next = SetActualShape (t->ACF_LIST.Next, s);
  677.   }
  678.    return t;
  679.  
  680.   case kACF_EMPTY:
  681. # line 522 "AdaptF77.puma"
  682.    return t;
  683.  
  684.   case kACF_BASIC:
  685. # line 526 "AdaptF77.puma"
  686.   {
  687. # line 527 "AdaptF77.puma"
  688.  t->ACF_BASIC.BASIC_STMT = SetActualShape (t->ACF_BASIC.BASIC_STMT, s);
  689.   }
  690.    return t;
  691.  
  692.   case kASSIGN_STMT:
  693. # line 531 "AdaptF77.puma"
  694.   {
  695. # line 532 "AdaptF77.puma"
  696.  t->ASSIGN_STMT.ASSIGN_VAR = SetActualShape (t->ASSIGN_STMT.ASSIGN_VAR, s);
  697.      t->ASSIGN_STMT.ASSIGN_EXP = SetActualShape (t->ASSIGN_STMT.ASSIGN_EXP, s);
  698.   }
  699.    return t;
  700.  
  701.   case kOP_EXP:
  702. # line 537 "AdaptF77.puma"
  703.   {
  704. # line 538 "AdaptF77.puma"
  705.  t->OP_EXP.OPND1 = SetActualShape (t->OP_EXP.OPND1, s);
  706.      t->OP_EXP.OPND2 = SetActualShape (t->OP_EXP.OPND2, s);
  707.   }
  708.    return t;
  709.  
  710.   case kOP1_EXP:
  711. # line 543 "AdaptF77.puma"
  712.   {
  713. # line 544 "AdaptF77.puma"
  714.  t->OP1_EXP.OPND = SetActualShape (t->OP1_EXP.OPND, s);
  715.   }
  716.    return t;
  717.  
  718.   case kCONST_EXP:
  719. # line 548 "AdaptF77.puma"
  720.    return t;
  721.  
  722.   case kARRAY_EXP:
  723.   if (t->ARRAY_EXP.ELEMENTS->Kind == kBTE_LIST) {
  724.   if (t->ARRAY_EXP.ELEMENTS->BTE_LIST.Elem->Kind == kSLICE_EXP) {
  725.   if (t->ARRAY_EXP.ELEMENTS->BTE_LIST.Next->Kind == kBTE_EMPTY) {
  726. # line 552 "AdaptF77.puma"
  727.   {
  728. # line 553 "AdaptF77.puma"
  729.  if (s->rank != 1)
  730.         { printf ("Illegal formal shape for current array expression\n");
  731.           WriteTree (stdout, t);
  732.           exit(-1);
  733.         }
  734.      newexp = mVAR_EXP (MakeNewLoopVar (s->perm[0]));
  735.  
  736.      newexp = FindShapeExp (t->ARRAY_EXP.ELEMENTS->BTE_LIST.Elem, s->bounds[0][0], s->bounds[0][1],
  737.                                s->bounds[0][2], newexp );
  738.  
  739.   }
  740.    return newexp;
  741.  
  742.   }
  743.   }
  744.   }
  745.   break;
  746.   case kFUNC_CALL_EXP:
  747. # line 566 "AdaptF77.puma"
  748.   {
  749. # line 567 "AdaptF77.puma"
  750.  
  751.      newexp = t;
  752.      if (IsIntrFunc (t))
  753.       { if (IntrFuncKind1 (t->FUNC_CALL_EXP.FUNC_ID->PROC_OBJ.Ident) ||
  754.             IntrFuncKindn (t->FUNC_CALL_EXP.FUNC_ID->PROC_OBJ.Ident) ||
  755.             IntrFuncKind2 (t->FUNC_CALL_EXP.FUNC_ID->PROC_OBJ.Ident) )
  756.           {
  757.             t->FUNC_CALL_EXP.FUNC_PARAMS = SetActualShape (t->FUNC_CALL_EXP.FUNC_PARAMS, s);
  758.           }
  759.          else if (t->FUNC_CALL_EXP.FUNC_ID->PROC_OBJ.Ident == MakeIdent ("SPREAD", 6))
  760.           newexp = SetSpreadActualShape (t->FUNC_CALL_EXP.FUNC_PARAMS, s);
  761.          else
  762.           error_protocol ("Illegal Intrinsic function for SetActualShape");
  763.       }
  764.      else
  765.       error_protocol ("Illegal function call in SetActualShape");
  766.  
  767.   }
  768.    return newexp;
  769.  
  770.   case kBTP_LIST:
  771. # line 585 "AdaptF77.puma"
  772.   {
  773. # line 586 "AdaptF77.puma"
  774.  t->BTP_LIST.Elem = SetActualShape (t->BTP_LIST.Elem, s);
  775.      t->BTP_LIST.Next = SetActualShape (t->BTP_LIST.Next, s);
  776.  
  777.   }
  778.    return t;
  779.  
  780.   case kBTP_EMPTY:
  781. # line 592 "AdaptF77.puma"
  782.    return t;
  783.  
  784.   case kVAR_PARAM:
  785. # line 596 "AdaptF77.puma"
  786.   {
  787. # line 597 "AdaptF77.puma"
  788.  t->VAR_PARAM.V = SetActualShape (t->VAR_PARAM.V, s);
  789.   }
  790.    return t;
  791.  
  792.   case kADDR:
  793. # line 601 "AdaptF77.puma"
  794.   {
  795. # line 602 "AdaptF77.puma"
  796.  t->ADDR.E = SetActualShape (t->ADDR.E, s);
  797.   }
  798.    return t;
  799.  
  800.   case kVAR_EXP:
  801. # line 606 "AdaptF77.puma"
  802.   {
  803. # line 607 "AdaptF77.puma"
  804.  t->VAR_EXP.V = SetActualShape (t->VAR_EXP.V, s);
  805.   }
  806.    return t;
  807.  
  808.   case kUSED_VAR:
  809. # line 611 "AdaptF77.puma"
  810.   {
  811. # line 612 "AdaptF77.puma"
  812.  if (TreeRank (t) > 0)
  813.        {
  814.          newexp = MakeFullShape (t);
  815.          newexp = SetActualShape (newexp, s);
  816.        }
  817.      else
  818.          newexp = t;
  819.  
  820.   }
  821.    return newexp;
  822.  
  823.   case kLOOP_VAR:
  824. # line 623 "AdaptF77.puma"
  825.    return t;
  826.  
  827.   case kINDEXED_VAR:
  828. # line 627 "AdaptF77.puma"
  829.   {
  830. # line 628 "AdaptF77.puma"
  831.  newexp = MakeFullShape (t);
  832.      SetActualIndexShape (t->INDEXED_VAR.IND_EXPS, s, 0);
  833.   }
  834.    return t;
  835.  
  836.   }
  837.  
  838. # line 633 "AdaptF77.puma"
  839.   {
  840. # line 634 "AdaptF77.puma"
  841.    printf ("SetActualShape failed\n");
  842. # line 635 "AdaptF77.puma"
  843.    FileUnparse (stdout, t);
  844. # line 636 "AdaptF77.puma"
  845.    WriteTree (stdout, t);
  846. # line 637 "AdaptF77.puma"
  847.    exit (- 1);
  848.   }
  849.    return NoTree;
  850.  
  851. }
  852.  
  853. static tTree SetSpreadActualShape
  854. # if defined __STDC__ | defined __cplusplus
  855. (register tTree t, shape s)
  856. # else
  857. (t, s)
  858.  register tTree t;
  859.  shape s;
  860. # endif
  861. {
  862. # line 643 "AdaptF77.puma"
  863.  
  864. int i, k, dimval;
  865. bool found;
  866. tTree newexp;
  867. struct_shape h_shp;
  868.  
  869.   if (t->Kind == kBTP_LIST) {
  870.   if (t->BTP_LIST.Elem->Kind == kVAR_PARAM) {
  871.   if (t->BTP_LIST.Next->Kind == kBTP_LIST) {
  872.   if (t->BTP_LIST.Next->BTP_LIST.Elem->Kind == kVAR_PARAM) {
  873.   if (t->BTP_LIST.Next->BTP_LIST.Elem->VAR_PARAM.V->Kind == kADDR) {
  874.   if (t->BTP_LIST.Next->BTP_LIST.Next->Kind == kBTP_LIST) {
  875.   if (t->BTP_LIST.Next->BTP_LIST.Next->BTP_LIST.Next->Kind == kBTP_EMPTY) {
  876. # line 650 "AdaptF77.puma"
  877.   {
  878. # line 654 "AdaptF77.puma"
  879.  
  880.     if (t->BTP_LIST.Elem->VAR_PARAM.V->Kind == kADDR)
  881.          newexp = t->BTP_LIST.Elem->VAR_PARAM.V->ADDR.E;
  882.       else
  883.          newexp = mVAR_EXP (t->BTP_LIST.Elem->VAR_PARAM.V);
  884.     GetIntConstValue (t->BTP_LIST.Next->BTP_LIST.Elem->VAR_PARAM.V->ADDR.E, &found, &dimval);
  885.     if (!found)
  886.        error_protocol ("DIM in SPREAD only at run-time");
  887.      else if ((dimval <= 0) || (dimval > s->rank))
  888.        error_protocol ("DIM in SPREAD out of range");
  889.      else
  890.        {
  891.          h_shp.rank = s->rank-1;
  892.          for (i=0;i<s->rank;i++)
  893.            if (i != dimval-1)
  894.                { k = i;
  895.                  if (i>=dimval) k = i-1;
  896.                  h_shp.bounds[k][0] = s->bounds[i][0];
  897.                  h_shp.bounds[k][1] = s->bounds[i][1];
  898.                  h_shp.bounds[k][2] = s->bounds[i][2];
  899.                  h_shp.perm[k] = s->perm[i];
  900.                }
  901.          newexp = SetActualShape (newexp, &h_shp);
  902.        }
  903.  
  904.   }
  905.    return newexp;
  906.  
  907.   }
  908.   }
  909.   }
  910.   }
  911.   }
  912.   }
  913.   }
  914. # line 683 "AdaptF77.puma"
  915.   {
  916. # line 684 "AdaptF77.puma"
  917.    error_protocol ("illegal SPREAD for SetSpreadActualShape");
  918.   }
  919.    return t;
  920.  
  921. }
  922.  
  923. static void SetActualIndexShape
  924. # if defined __STDC__ | defined __cplusplus
  925. (register tTree ind, shape s, register int n)
  926. # else
  927. (ind, s, n)
  928.  register tTree ind;
  929.  shape s;
  930.  register int n;
  931. # endif
  932. {
  933. # line 690 "AdaptF77.puma"
  934.  
  935. int rank;
  936. struct_shape h_shp;
  937.  
  938.   if (ind == NoTree) return;
  939.   if (ind->Kind == kBTE_LIST) {
  940.   if (ind->BTE_LIST.Elem->Kind == kSLICE_EXP) {
  941. # line 695 "AdaptF77.puma"
  942.  {
  943.   tTree nexp;
  944.   {
  945. # line 697 "AdaptF77.puma"
  946.  
  947. # line 699 "AdaptF77.puma"
  948.  nexp = mVAR_EXP (MakeNewLoopVar (s->perm[n]));
  949.  
  950.      ind->BTE_LIST.Elem = FindShapeExp (ind->BTE_LIST.Elem, s->bounds[n][0], s->bounds[n][1],
  951.                                s->bounds[n][2], nexp);
  952.  
  953.      SetActualIndexShape (ind, s, n+1);
  954.  
  955.   }
  956.    return;
  957.  }
  958.  
  959.   }
  960. # line 708 "AdaptF77.puma"
  961.   {
  962. # line 709 "AdaptF77.puma"
  963.  rank = TreeRank (ind->BTE_LIST.Elem);
  964.     if (rank > 0)
  965.        {
  966.          if (rank != 1)
  967.            error_protocol ("wrong indirect addressing in SetActualIndexShape");
  968.           else
  969.            {
  970.              h_shp.rank = 1;
  971.              h_shp.bounds[0][0] = s->bounds[n][0];
  972.              h_shp.bounds[0][1] = s->bounds[n][1];
  973.              h_shp.bounds[0][2] = s->bounds[n][2];
  974.              h_shp.perm [0]     = s->perm[n];
  975.              ind->BTE_LIST.Elem = SetActualShape (ind->BTE_LIST.Elem, &h_shp);
  976.            }
  977.          SetActualIndexShape (ind->BTE_LIST.Next, s, n+1);
  978.        }
  979.      else
  980.        SetActualIndexShape (ind->BTE_LIST.Next, s, n);
  981.  
  982.   }
  983.    return;
  984.  
  985.   }
  986.   if (ind->Kind == kBTE_EMPTY) {
  987. # line 730 "AdaptF77.puma"
  988.    return;
  989.  
  990.   }
  991. # line 733 "AdaptF77.puma"
  992.   {
  993. # line 734 "AdaptF77.puma"
  994.    printf ("SetActualIndexShape failed\n");
  995. # line 735 "AdaptF77.puma"
  996.    exit (- 1);
  997.   }
  998.    return;
  999.  
  1000. ;
  1001. }
  1002.  
  1003. static tTree MakeOuterLoops
  1004. # if defined __STDC__ | defined __cplusplus
  1005. (shape s, register tTree body, register int k)
  1006. # else
  1007. (s, body, k)
  1008.  shape s;
  1009.  register tTree body;
  1010.  register int k;
  1011. # endif
  1012. {
  1013. # line 750 "AdaptF77.puma"
  1014.  
  1015. tTree new, var, range;
  1016. int i;
  1017.  
  1018. # line 761 "AdaptF77.puma"
  1019.   {
  1020. # line 762 "AdaptF77.puma"
  1021.  new = body;
  1022.     for (i=0; i<s->rank; i++)
  1023.       {
  1024.         if (s->bounds[i][0] != s->bounds[i][1])
  1025.           {
  1026.             new = MakeListBody (new);
  1027.             var = MakeNewLoopVar (s->perm[i]);
  1028.  
  1029.             if (s->bounds[i][2] != NoTree)
  1030.                 range = s->bounds[i][2];
  1031.               else
  1032.                 range = mDUMMY_EXP();
  1033.  
  1034.             range = mSLICE_EXP (s->bounds[i][0],
  1035.                                 s->bounds[i][1], range);
  1036.             new = mACF_DOLOCAL (var, range, new);
  1037.             if (k!=0) new->Kind = kACF_FORALL;
  1038.           }
  1039.       }
  1040.  
  1041.   }
  1042.    return new;
  1043.  
  1044. }
  1045.  
  1046. static tTree MakeListBody
  1047. # if defined __STDC__ | defined __cplusplus
  1048. (register tTree t)
  1049. # else
  1050. (t)
  1051.  register tTree t;
  1052. # endif
  1053. {
  1054.   if (t->Kind == kACF_LIST) {
  1055. # line 787 "AdaptF77.puma"
  1056.    return t;
  1057.  
  1058.   }
  1059.   if (t->Kind == kACF_EMPTY) {
  1060. # line 791 "AdaptF77.puma"
  1061.    return t;
  1062.  
  1063.   }
  1064.   if (Tree_IsType (t, kACF_NODE)) {
  1065. # line 795 "AdaptF77.puma"
  1066.    return mACF_LIST (t, mACF_EMPTY ());
  1067.  
  1068.   }
  1069.  yyAbort ("MakeListBody");
  1070. }
  1071.  
  1072. static tTree MakeOuterImpliedLoops
  1073. # if defined __STDC__ | defined __cplusplus
  1074. (shape s, register tTree body)
  1075. # else
  1076. (s, body)
  1077.  shape s;
  1078.  register tTree body;
  1079. # endif
  1080. {
  1081. # line 807 "AdaptF77.puma"
  1082.  
  1083. tTree new, var, range;
  1084. int i;
  1085.  
  1086. # line 812 "AdaptF77.puma"
  1087.   {
  1088. # line 813 "AdaptF77.puma"
  1089.  new = body;
  1090.     for (i=0; i<s->rank; i++)
  1091.       {
  1092.         if (s->bounds[i][0] != s->bounds[i][1])
  1093.           {
  1094.             new = mBTE_LIST (new, mBTE_EMPTY());
  1095.             var = MakeNewLoopVar (i+1);
  1096.  
  1097.             if (s->bounds[i][2] != NoTree)
  1098.                 range = s->bounds[i][2];
  1099.               else
  1100.                 range = mDUMMY_EXP();
  1101.  
  1102.             range = mSLICE_EXP (s->bounds[i][0],
  1103.                                 s->bounds[i][1], range);
  1104.             new = mDO_EXP (var, range, new);
  1105.           }
  1106.       }
  1107.  
  1108.   }
  1109.    return new;
  1110.  
  1111. }
  1112.  
  1113. static tTree MakeOuterImpliedLoopsV
  1114. # if defined __STDC__ | defined __cplusplus
  1115. (shape s, register tTree body)
  1116. # else
  1117. (s, body)
  1118.  shape s;
  1119.  register tTree body;
  1120. # endif
  1121. {
  1122. # line 843 "AdaptF77.puma"
  1123.  
  1124. tTree new, var, range;
  1125. int i;
  1126.  
  1127. # line 848 "AdaptF77.puma"
  1128.   {
  1129. # line 849 "AdaptF77.puma"
  1130.  new = body;
  1131.     for (i=0; i<s->rank; i++)
  1132.       {
  1133.         if (s->bounds[i][0] != s->bounds[i][1])
  1134.           {
  1135.             new = mBTV_LIST (new, mBTV_EMPTY());
  1136.             var = MakeNewLoopVar (i+1);
  1137.  
  1138.             if (s->bounds[i][2] != NoTree)
  1139.                 range = s->bounds[i][2];
  1140.               else
  1141.                 range = mDUMMY_EXP();
  1142.  
  1143.             range = mSLICE_EXP (s->bounds[i][0],
  1144.                                 s->bounds[i][1], range);
  1145.             new = mDO_VAR (var, range, new);
  1146.           }
  1147.       }
  1148.  
  1149.   }
  1150.    return new;
  1151.  
  1152. }
  1153.  
  1154. void BeginAdaptF77 ()
  1155. {
  1156. }
  1157.  
  1158. void CloseAdaptF77 ()
  1159. {
  1160. }
  1161.