home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / adaptor.zip / adapt.zip / adaptor / src / semexp.c < prev    next >
Text File  |  1994-01-03  |  29KB  |  1,358 lines
  1. # include "SemExp.h"
  2. # include "yySExp.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 46 "SemExp.puma"
  36.  
  37. # include "Idents.h"
  38. # include "StringMe.h"
  39. # include "protocol.h"
  40.  
  41. # include "Types.h"
  42. # include "ShowDefs.h"
  43.  
  44. bool IsAllocated (); /* global used from Semantic.puma */
  45. void SemanticCall (); /* global used from Semantic.puma */
  46.  
  47. int   Nesting;          /* actual nesting depth */
  48. tTree Nest[MAXLoops];   /* actual loops of loop nesting */
  49.  
  50.  
  51.  
  52. static FILE * yyf = stdout;
  53.  
  54. static void yyAbort
  55. # ifdef __cplusplus
  56.  (char * yyFunction)
  57. # else
  58.  (yyFunction) char * yyFunction;
  59. # endif
  60. {
  61.  (void) fprintf (stderr, "Error: module SemExp, routine %s failed\n", yyFunction);
  62.  exit (1);
  63. }
  64.  
  65. void SemExp ARGS((tTree t, int * ResultRank));
  66. static void SemIndexList ARGS((tTree t, int * ResultRank));
  67. void SemExpList ARGS((tTree t));
  68. static void SemIntrParamList ARGS((tTree t, int * ResultRank));
  69. void SemParamList ARGS((tTree t));
  70. static void AnalIntrinsicFunction ARGS((tIdent name, tTree params, int * ResultRank));
  71. static void CheckMerge ARGS((tTree params, int * ResultRank));
  72. static void CheckCShift ARGS((tTree params, int * ResultRank));
  73. static void CheckTranspose ARGS((tTree params, int * ResultRank));
  74. static void CheckSpread ARGS((tTree params, int * ResultRank));
  75. static void CheckRed ARGS((tTree params, int * ResultRank));
  76. static bool IsCurrentLoopVar ARGS((tTree t));
  77. static tTree CheckNamedParameters ARGS((tTree t));
  78. static void DefineNamedParameters ARGS((tTree t));
  79. static tTree GetUnnamedParameters ARGS((tTree t));
  80.  
  81. void SemExp
  82. # if defined __STDC__ | defined __cplusplus
  83. (register tTree t, register int * ResultRank)
  84. # else
  85. (t, ResultRank)
  86.  register tTree t;
  87.  register int * ResultRank;
  88. # endif
  89. {
  90.   if (t == NoTree) return;
  91.  
  92.   switch (t->Kind) {
  93.   case kUSED_VAR:
  94. # line 81 "SemExp.puma"
  95.  {
  96.   int yyV1;
  97.   {
  98. # line 83 "SemExp.puma"
  99.  if (IsCurrentLoopVar (t))
  100.          t->Kind = kLOOP_VAR;
  101.  
  102. # line 87 "SemExp.puma"
  103.    SemExp (t->USED_VAR.VARNAME, & yyV1);
  104.   }
  105.    * ResultRank = yyV1;
  106.    return;
  107.  }
  108.  
  109.   case kLOOP_VAR:
  110. # line 90 "SemExp.puma"
  111.  {
  112.   int yyV1;
  113.   {
  114. # line 91 "SemExp.puma"
  115.    SemExp (t->LOOP_VAR.LOOP_VARNAME, & yyV1);
  116.   }
  117.    * ResultRank = yyV1;
  118.    return;
  119.  }
  120.  
  121.   case kSELECTED_VAR:
  122. # line 94 "SemExp.puma"
  123.  {
  124.   int yyV1;
  125.   {
  126. # line 95 "SemExp.puma"
  127.    SemExp (t->SELECTED_VAR.SELEC_VAR, & yyV1);
  128.   }
  129.    * ResultRank = yyV1 + VarRank (t->SELECTED_VAR.SELECTOR->REC_COMP.Object);
  130.    return;
  131.  }
  132.  
  133.   case kSUBSTRING_VAR:
  134. # line 98 "SemExp.puma"
  135.  {
  136.   int yyV1;
  137.   int yyV2;
  138.   {
  139. # line 100 "SemExp.puma"
  140.    SemExp (t->SUBSTRING_VAR.IND_VAR, & yyV1);
  141. # line 101 "SemExp.puma"
  142.  if (yyV1 != 0)
  143.         { error_protocol ("rank of string variable > 0");
  144.           tree_protocol ("string variable is ", t);
  145.         }
  146.  
  147. # line 106 "SemExp.puma"
  148.    SemExp (t->SUBSTRING_VAR.IND_EXP, & yyV2);
  149.   }
  150.    * ResultRank = 0;
  151.    return;
  152.  }
  153.  
  154.   case kINDEXED_VAR:
  155. # line 109 "SemExp.puma"
  156.  {
  157.   int yyV1;
  158.   int yyV2;
  159.   {
  160. # line 111 "SemExp.puma"
  161.    SemExp (t->INDEXED_VAR.IND_VAR, & yyV1);
  162. # line 112 "SemExp.puma"
  163.  if (yyV1 != TreeListLength (t->INDEXED_VAR.IND_EXPS))
  164.         { error_protocol ("Illegal number of indexes");
  165.           tree_protocol ("Indexed variable is ", t);
  166.         }
  167.  
  168. # line 117 "SemExp.puma"
  169.    SemIndexList (t->INDEXED_VAR.IND_EXPS, & yyV2);
  170.   }
  171.    * ResultRank = yyV2;
  172.    return;
  173.  }
  174.  
  175.   case kVAR_OBJ:
  176. # line 120 "SemExp.puma"
  177.  {
  178.   int rank;
  179.   {
  180. # line 122 "SemExp.puma"
  181.  
  182. # line 124 "SemExp.puma"
  183.  if (t->VAR_OBJ.Object == NoObject)
  184.         { error_protocol ("No object for use of variable found");
  185.           tree_protocol ("Variable is ", t);
  186.           rank = 0;
  187.         }
  188.       else if (t->VAR_OBJ.Object != GetGlobalDecl (t->VAR_OBJ.Ident))
  189.         { error_protocol ("var name has become a function name");
  190.           obj_error_protocol ("var has obj = ", t->VAR_OBJ.Object);
  191.           obj_error_protocol ("table has obj = ", GetGlobalDecl(t->VAR_OBJ.Ident));
  192.           rank = 0;
  193.         }
  194.        else
  195.         { rank = VarRank (t->VAR_OBJ.Object);
  196.  
  197.  
  198.           if (IsVarAllocatable (t->VAR_OBJ.Object))
  199.            { if (!IsAllocated (t->VAR_OBJ.Ident))
  200.               { error_protocol ("Allocatable Variable used before allocate");
  201.                 tree_protocol ("Variable is ", t);
  202.               }
  203.            }
  204.         }
  205.  
  206.   }
  207.    * ResultRank = rank;
  208.    return;
  209.  }
  210.  
  211.   case kDUMMY_EXP:
  212. # line 156 "SemExp.puma"
  213.    * ResultRank = 0;
  214.    return;
  215.  
  216.   case kCONST_EXP:
  217. # line 159 "SemExp.puma"
  218.    * ResultRank = 0;
  219.    return;
  220.  
  221.   case kARRAY_EXP:
  222. # line 162 "SemExp.puma"
  223.   {
  224. # line 163 "SemExp.puma"
  225.    SemExpList (t->ARRAY_EXP.ELEMENTS);
  226.   }
  227.    * ResultRank = 1;
  228.    return;
  229.  
  230.   case kSLICE_EXP:
  231. # line 166 "SemExp.puma"
  232.  {
  233.   int yyV1;
  234.   int yyV2;
  235.   int yyV3;
  236.   {
  237. # line 168 "SemExp.puma"
  238.    SemExp (t->SLICE_EXP.START, & yyV1);
  239. # line 169 "SemExp.puma"
  240.  if (yyV1 != 0)
  241.         { error_protocol ("Start in Slice has illegal rank");
  242.           tree_protocol  ("Expression is ", t->SLICE_EXP.START);
  243.         }
  244.  
  245. # line 175 "SemExp.puma"
  246.    SemExp (t->SLICE_EXP.STOP, & yyV2);
  247. # line 176 "SemExp.puma"
  248.  if (yyV2 != 0)
  249.         { error_protocol ("Stop in Slice has illegal rank");
  250.           tree_protocol  ("Expression is ", t->SLICE_EXP.STOP);
  251.         }
  252.  
  253. # line 182 "SemExp.puma"
  254.    SemExp (t->SLICE_EXP.INC, & yyV3);
  255. # line 183 "SemExp.puma"
  256.  if (yyV3 != 0)
  257.         { error_protocol ("Increment in Slice has illegal rank");
  258.           tree_protocol  ("Expression is ", t->SLICE_EXP.INC);
  259.         }
  260.  
  261.   }
  262.    * ResultRank = 1;
  263.    return;
  264.  }
  265.  
  266.   case kOP_EXP:
  267. # line 190 "SemExp.puma"
  268.  {
  269.   int yyV1;
  270.   int yyV2;
  271.   {
  272. # line 192 "SemExp.puma"
  273.    SemExp (t->OP_EXP.OPND1, & yyV1);
  274. # line 193 "SemExp.puma"
  275.    SemExp (t->OP_EXP.OPND2, & yyV2);
  276. # line 195 "SemExp.puma"
  277.  if (yyV1 == 0)
  278.         yyV1 = yyV2;
  279.       else if (yyV2 == 0)
  280.         yyV1 = yyV1;
  281.       else if (yyV1 != yyV2)
  282.         { error_protocol ("Rank Error for binary expression");
  283.           tree_protocol ("Expression is : ", t);
  284.         }
  285.  
  286.   }
  287.    * ResultRank = yyV1;
  288.    return;
  289.  }
  290.  
  291.   case kOP1_EXP:
  292. # line 206 "SemExp.puma"
  293.  {
  294.   int yyV1;
  295.   {
  296. # line 207 "SemExp.puma"
  297.    SemExp (t->OP1_EXP.OPND, & yyV1);
  298.   }
  299.    * ResultRank = yyV1;
  300.    return;
  301.  }
  302.  
  303.   case kTYPE_EXP:
  304. # line 210 "SemExp.puma"
  305.   {
  306. # line 211 "SemExp.puma"
  307.    SemExpList (t->TYPE_EXP.ELEMENTS);
  308.   }
  309.    * ResultRank = 0;
  310.    return;
  311.  
  312.   case kVAR_EXP:
  313. # line 214 "SemExp.puma"
  314.  {
  315.   int yyV1;
  316.   {
  317. # line 215 "SemExp.puma"
  318.    SemExp (t->VAR_EXP.V, & yyV1);
  319.   }
  320.    * ResultRank = yyV1;
  321.    return;
  322.  }
  323.  
  324.   case kDO_EXP:
  325. # line 218 "SemExp.puma"
  326.  {
  327.   int yyV1;
  328.   int yyV2;
  329.   {
  330. # line 219 "SemExp.puma"
  331.    SemExp (t->DO_EXP.DO_ID, & yyV1);
  332. # line 220 "SemExp.puma"
  333.    SemExp (t->DO_EXP.RANGE, & yyV2);
  334. # line 221 "SemExp.puma"
  335.    SemExpList (t->DO_EXP.BODY);
  336.   }
  337.    * ResultRank = 1;
  338.    return;
  339.  }
  340.  
  341.   case kFUNC_CALL_EXP:
  342. # line 224 "SemExp.puma"
  343.  {
  344.   int rank;
  345.   int len;
  346.   {
  347. # line 226 "SemExp.puma"
  348.    if (! (IsIntrFunc (t) == true)) goto yyL16;
  349.   {
  350. # line 228 "SemExp.puma"
  351.  
  352. # line 229 "SemExp.puma"
  353.  
  354. # line 231 "SemExp.puma"
  355.    len = TreeListLength (t->FUNC_CALL_EXP.FUNC_PARAMS);
  356. # line 232 "SemExp.puma"
  357.  if (IntrFuncKind1 (t->FUNC_CALL_EXP.FUNC_ID->PROC_OBJ.Ident))
  358.        { if (len != 1)
  359.          { error_protocol ("One parameter for function call is required");
  360.            tree_protocol ("Function call is : ", t);
  361.          }
  362.          SemIntrParamList (t->FUNC_CALL_EXP.FUNC_PARAMS, &rank);
  363.        }
  364.      else if (IntrFuncKind2 (t->FUNC_CALL_EXP.FUNC_ID->PROC_OBJ.Ident))
  365.        { if (len != 2)
  366.          { error_protocol ("Two parameters for function call are required");
  367.            tree_protocol ("Function call is : ", t);
  368.          }
  369.          SemIntrParamList (t->FUNC_CALL_EXP.FUNC_PARAMS, &rank);
  370.        }
  371.      else if (IntrFuncKindn (t->FUNC_CALL_EXP.FUNC_ID->PROC_OBJ.Ident))
  372.        { if (len < 1)
  373.          { error_protocol ("No parameter in intrinsic function");
  374.            tree_protocol ("Function call is : ", t);
  375.          }
  376.          SemIntrParamList (t->FUNC_CALL_EXP.FUNC_PARAMS, &rank);
  377.        }
  378.      else
  379.        { t->FUNC_CALL_EXP.FUNC_PARAMS = GetUnnamedParameters (t->FUNC_CALL_EXP.FUNC_PARAMS);
  380.          AnalIntrinsicFunction (t->FUNC_CALL_EXP.FUNC_ID->PROC_OBJ.Ident, t->FUNC_CALL_EXP.FUNC_PARAMS, &rank);
  381.        }
  382.  
  383.   }
  384.   }
  385.    * ResultRank = rank;
  386.    return;
  387.  }
  388. yyL16:;
  389.  
  390. # line 260 "SemExp.puma"
  391.   {
  392. # line 263 "SemExp.puma"
  393.    SemanticCall (t, t->FUNC_CALL_EXP.FUNC_ID->PROC_OBJ.Object);
  394.   }
  395.    * ResultRank = 0;
  396.    return;
  397.  
  398.   case kVAR_PARAM:
  399. # line 272 "SemExp.puma"
  400.  {
  401.   int yyV1;
  402.   {
  403. # line 274 "SemExp.puma"
  404.    SemExp (t->VAR_PARAM.V, & yyV1);
  405.   }
  406.    * ResultRank = yyV1;
  407.    return;
  408.  }
  409.  
  410.   case kNAMED_PARAM:
  411. # line 277 "SemExp.puma"
  412.  {
  413.   int yyV1;
  414.   {
  415. # line 279 "SemExp.puma"
  416.    SemExp (t->NAMED_PARAM.VAL, & yyV1);
  417.   }
  418.    * ResultRank = yyV1;
  419.    return;
  420.  }
  421.  
  422.   case kPROC_PARAM:
  423. # line 282 "SemExp.puma"
  424.    * ResultRank = 0;
  425.    return;
  426.  
  427.   case kADDR:
  428. # line 285 "SemExp.puma"
  429.  {
  430.   int yyV1;
  431.   {
  432. # line 286 "SemExp.puma"
  433.    SemExp (t->ADDR.E, & yyV1);
  434.   }
  435.    * ResultRank = yyV1;
  436.    return;
  437.  }
  438.  
  439.   }
  440.  
  441. # line 289 "SemExp.puma"
  442.   {
  443. # line 290 "SemExp.puma"
  444.  error_protocol ("Unknown Tree Node for SemExp");
  445.      printf ("Unknown Tree Node in SemExp");
  446.      FileUnparse (stdout, t);
  447.      WriteTree (stdout, t);
  448.      kill_in_protocol ();
  449.  
  450.   }
  451.    * ResultRank = 0;
  452.    return;
  453.  
  454. ;
  455. }
  456.  
  457. static void SemIndexList
  458. # if defined __STDC__ | defined __cplusplus
  459. (register tTree t, register int * ResultRank)
  460. # else
  461. (t, ResultRank)
  462.  register tTree t;
  463.  register int * ResultRank;
  464. # endif
  465. {
  466.   if (t == NoTree) return;
  467.   if (t->Kind == kBTE_LIST) {
  468. # line 315 "SemExp.puma"
  469.  {
  470.   int yyV1;
  471.   int yyV2;
  472.   {
  473. # line 317 "SemExp.puma"
  474.    SemExp (t->BTE_LIST.Elem, & yyV1);
  475. # line 318 "SemExp.puma"
  476.  if (yyV1 > 1)
  477.        { error_protocol ("Illegal Rank of an Index");
  478.          tree_protocol  ("Index is : ", t->BTE_LIST.Elem);
  479.        }
  480.  
  481. # line 323 "SemExp.puma"
  482.    SemIndexList (t->BTE_LIST.Next, & yyV2);
  483.   }
  484.    * ResultRank = yyV2 + yyV1;
  485.    return;
  486.  }
  487.  
  488.   }
  489.   if (t->Kind == kBTE_EMPTY) {
  490. # line 326 "SemExp.puma"
  491.    * ResultRank = 0;
  492.    return;
  493.  
  494.   }
  495. # line 329 "SemExp.puma"
  496.   {
  497. # line 330 "SemExp.puma"
  498.    error_protocol ("Illegal Call of SemIndexList");
  499. # line 331 "SemExp.puma"
  500.    printf ("Illegal Call of SemIndexList, Tree : ");
  501. # line 332 "SemExp.puma"
  502.    FileUnparse (stdout, t);
  503. # line 333 "SemExp.puma"
  504.    WriteTree (stdout, t);
  505. # line 334 "SemExp.puma"
  506.    kill_in_protocol ();
  507.   }
  508.    * ResultRank = 0;
  509.    return;
  510.  
  511. ;
  512. }
  513.  
  514. void SemExpList
  515. # if defined __STDC__ | defined __cplusplus
  516. (register tTree t)
  517. # else
  518. (t)
  519.  register tTree t;
  520. # endif
  521. {
  522.   if (t == NoTree) return;
  523.   if (t->Kind == kBTE_LIST) {
  524. # line 347 "SemExp.puma"
  525.  {
  526.   int yyV1;
  527.   {
  528. # line 349 "SemExp.puma"
  529.    SemExp (t->BTE_LIST.Elem, & yyV1);
  530. # line 350 "SemExp.puma"
  531.    SemExpList (t->BTE_LIST.Next);
  532.   }
  533.    return;
  534.  }
  535.  
  536.   }
  537.   if (t->Kind == kBTE_EMPTY) {
  538. # line 353 "SemExp.puma"
  539.    return;
  540.  
  541.   }
  542. # line 356 "SemExp.puma"
  543.   {
  544. # line 357 "SemExp.puma"
  545.    error_protocol ("Illegal Call of SemExpList");
  546. # line 358 "SemExp.puma"
  547.    printf ("Illegal Call of SemExpList, Tree : ");
  548. # line 359 "SemExp.puma"
  549.    FileUnparse (stdout, t);
  550. # line 360 "SemExp.puma"
  551.    WriteTree (stdout, t);
  552. # line 361 "SemExp.puma"
  553.    kill_in_protocol ();
  554.   }
  555.    return;
  556.  
  557. ;
  558. }
  559.  
  560. static void SemIntrParamList
  561. # if defined __STDC__ | defined __cplusplus
  562. (register tTree t, register int * ResultRank)
  563. # else
  564. (t, ResultRank)
  565.  register tTree t;
  566.  register int * ResultRank;
  567. # endif
  568. {
  569.   if (t == NoTree) return;
  570.   if (t->Kind == kBTP_LIST) {
  571. # line 372 "SemExp.puma"
  572.  {
  573.   int rank;
  574.   int yyV1;
  575.   int yyV2;
  576.   {
  577. # line 374 "SemExp.puma"
  578.  
  579. # line 376 "SemExp.puma"
  580.    SemExp (t->BTP_LIST.Elem, & yyV1);
  581. # line 377 "SemExp.puma"
  582.    SemIntrParamList (t->BTP_LIST.Next, & yyV2);
  583. # line 379 "SemExp.puma"
  584.  if (yyV1 == 0)
  585.         rank = yyV2;
  586.      else if (yyV2 == 0)
  587.         rank = yyV1;
  588.      else if (yyV1 == yyV2)
  589.         rank = yyV1;
  590.      else
  591.         { error_protocol ("Illegal Rank combination in Parameter List");
  592.           tree_protocol ("parameter list is ", t);
  593.         };
  594.  
  595.   }
  596.    * ResultRank = rank;
  597.    return;
  598.  }
  599.  
  600.   }
  601.   if (t->Kind == kBTP_EMPTY) {
  602. # line 392 "SemExp.puma"
  603.    * ResultRank = 0;
  604.    return;
  605.  
  606.   }
  607. # line 395 "SemExp.puma"
  608.   {
  609. # line 396 "SemExp.puma"
  610.    error_protocol ("Illegal Call of SemIntrParamList");
  611. # line 397 "SemExp.puma"
  612.    printf ("Illegal Call of SemIntrParamList, Tree : ");
  613. # line 398 "SemExp.puma"
  614.    FileUnparse (stdout, t);
  615. # line 399 "SemExp.puma"
  616.    WriteTree (stdout, t);
  617. # line 400 "SemExp.puma"
  618.    kill_in_protocol ();
  619.   }
  620.    * ResultRank = 0;
  621.    return;
  622.  
  623. ;
  624. }
  625.  
  626. void SemParamList
  627. # if defined __STDC__ | defined __cplusplus
  628. (register tTree t)
  629. # else
  630. (t)
  631.  register tTree t;
  632. # endif
  633. {
  634.   if (t == NoTree) return;
  635.   if (t->Kind == kBTP_LIST) {
  636. # line 405 "SemExp.puma"
  637.  {
  638.   int yyV1;
  639.   {
  640. # line 407 "SemExp.puma"
  641.    SemExp (t->BTP_LIST.Elem, & yyV1);
  642. # line 408 "SemExp.puma"
  643.    SemParamList (t->BTP_LIST.Next);
  644.   }
  645.    return;
  646.  }
  647.  
  648.   }
  649.   if (t->Kind == kBTP_EMPTY) {
  650. # line 411 "SemExp.puma"
  651.    return;
  652.  
  653.   }
  654. # line 414 "SemExp.puma"
  655.   {
  656. # line 415 "SemExp.puma"
  657.    error_protocol ("Illegal Call of SemParamList");
  658. # line 416 "SemExp.puma"
  659.    printf ("Illegal Call of SemParamList, Tree : ");
  660. # line 417 "SemExp.puma"
  661.    FileUnparse (stdout, t);
  662. # line 418 "SemExp.puma"
  663.    WriteTree (stdout, t);
  664. # line 419 "SemExp.puma"
  665.    kill_in_protocol ();
  666.   }
  667.    return;
  668.  
  669. ;
  670. }
  671.  
  672. static void AnalIntrinsicFunction
  673. # if defined __STDC__ | defined __cplusplus
  674. (register tIdent name, register tTree params, register int * ResultRank)
  675. # else
  676. (name, params, ResultRank)
  677.  register tIdent name;
  678.  register tTree params;
  679.  register int * ResultRank;
  680. # endif
  681. {
  682. # line 431 "SemExp.puma"
  683.  
  684. int no;
  685.  
  686.   if (params == NoTree) return;
  687. # line 437 "SemExp.puma"
  688.  {
  689.   int yyV1;
  690.   {
  691. # line 439 "SemExp.puma"
  692.    if (! (IntrFuncRed (name) == true)) goto yyL1;
  693.   {
  694. # line 441 "SemExp.puma"
  695.    SemParamList (params);
  696. # line 442 "SemExp.puma"
  697.    CheckRed (params, & yyV1);
  698.   }
  699.   }
  700.    * ResultRank = yyV1;
  701.    return;
  702.  }
  703. yyL1:;
  704.  
  705.   if (equaltIdent (name, MakeIdent ("MINLOC", 6))) {
  706. # line 445 "SemExp.puma"
  707.   {
  708. # line 446 "SemExp.puma"
  709.    SemParamList (params);
  710. # line 447 "SemExp.puma"
  711.    error_protocol ("MINLOC is not supported until now");
  712.   }
  713.    * ResultRank = 0;
  714.    return;
  715.  
  716.   }
  717.   if (equaltIdent (name, MakeIdent ("MAXLOC", 6))) {
  718. # line 450 "SemExp.puma"
  719.   {
  720. # line 451 "SemExp.puma"
  721.    SemParamList (params);
  722. # line 452 "SemExp.puma"
  723.    error_protocol ("MAXLOC is not supported until now");
  724.   }
  725.    * ResultRank = 0;
  726.    return;
  727.  
  728.   }
  729.  {
  730.   int len;
  731.   int rank;
  732.   if (equaltIdent (name, MakeIdent ("SPREAD", 6))) {
  733. # line 455 "SemExp.puma"
  734.   {
  735. # line 457 "SemExp.puma"
  736.  
  737. # line 458 "SemExp.puma"
  738.  
  739. # line 460 "SemExp.puma"
  740.    SemParamList (params);
  741. # line 461 "SemExp.puma"
  742.  len = TreeListLength (params);
  743.       if (len != 3)
  744.         error_protocol ("SPREAD has not three parameters");
  745.       if (len >= 1)
  746.         rank = TreeRank (params->BTP_LIST.Elem) + 1;
  747.        else
  748.         rank = 0;
  749.  
  750.   }
  751.    * ResultRank = rank;
  752.    return;
  753.  
  754.   }
  755.  }
  756.  {
  757.   int yyV1;
  758.   if (equaltIdent (name, MakeIdent ("CSHIFT", 6))) {
  759. # line 471 "SemExp.puma"
  760.   {
  761. # line 472 "SemExp.puma"
  762.    CheckCShift (params, & yyV1);
  763.   }
  764.    * ResultRank = yyV1;
  765.    return;
  766.  
  767.   }
  768.  }
  769.  {
  770.   int yyV1;
  771.   if (equaltIdent (name, MakeIdent ("TRANSPOSE", 9))) {
  772. # line 475 "SemExp.puma"
  773.   {
  774. # line 476 "SemExp.puma"
  775.    CheckTranspose (params, & yyV1);
  776.   }
  777.    * ResultRank = yyV1;
  778.    return;
  779.  
  780.   }
  781.  }
  782.   if (equaltIdent (name, MakeIdent ("DOTPRODUCT", 10))) {
  783. # line 479 "SemExp.puma"
  784.   {
  785. # line 480 "SemExp.puma"
  786.    SemParamList (params);
  787. # line 481 "SemExp.puma"
  788.    error_protocol ("DOTPRODUCT is not supported until now");
  789.   }
  790.    * ResultRank = 0;
  791.    return;
  792.  
  793.   }
  794.   if (equaltIdent (name, MakeIdent ("MATMUL", 6))) {
  795. # line 484 "SemExp.puma"
  796.   {
  797. # line 485 "SemExp.puma"
  798.    SemParamList (params);
  799. # line 486 "SemExp.puma"
  800.    error_protocol ("MATMUL is not supported until now");
  801.   }
  802.    * ResultRank = 0;
  803.    return;
  804.  
  805.   }
  806.  {
  807.   int yyV1;
  808.   if (equaltIdent (name, MakeIdent ("MERGE", 5))) {
  809. # line 489 "SemExp.puma"
  810.   {
  811. # line 490 "SemExp.puma"
  812.    CheckMerge (params, & yyV1);
  813.   }
  814.    * ResultRank = yyV1;
  815.    return;
  816.  
  817.   }
  818.  }
  819.   if (equaltIdent (name, MakeIdent ("EOSHIFT", 7))) {
  820. # line 493 "SemExp.puma"
  821.   {
  822. # line 494 "SemExp.puma"
  823.    SemParamList (params);
  824. # line 495 "SemExp.puma"
  825.    error_protocol ("EOSHIFT is not supported until now");
  826.   }
  827.    * ResultRank = 0;
  828.    return;
  829.  
  830.   }
  831.   if (equaltIdent (name, MakeIdent ("DIAGONAL", 8))) {
  832. # line 498 "SemExp.puma"
  833.   {
  834. # line 499 "SemExp.puma"
  835.    SemParamList (params);
  836. # line 500 "SemExp.puma"
  837.    error_protocol ("DIAGONAL ist not supported until now");
  838.   }
  839.    * ResultRank = 0;
  840.    return;
  841.  
  842.   }
  843.   if (equaltIdent (name, MakeIdent ("PACK", 4))) {
  844. # line 503 "SemExp.puma"
  845.   {
  846. # line 504 "SemExp.puma"
  847.    SemParamList (params);
  848. # line 505 "SemExp.puma"
  849.    error_protocol ("PACK ist not supported until now");
  850.   }
  851.    * ResultRank = 0;
  852.    return;
  853.  
  854.   }
  855.   if (equaltIdent (name, MakeIdent ("UNPACK", 6))) {
  856. # line 508 "SemExp.puma"
  857.   {
  858. # line 509 "SemExp.puma"
  859.    SemParamList (params);
  860. # line 510 "SemExp.puma"
  861.    error_protocol ("UNPACK ist not supported until now");
  862.   }
  863.    * ResultRank = 0;
  864.    return;
  865.  
  866.   }
  867. # line 513 "SemExp.puma"
  868.   {
  869. # line 514 "SemExp.puma"
  870.    SemParamList (params);
  871. # line 515 "SemExp.puma"
  872.    error_protocol ("Unknown intrinsic Function in Semantic Analysis");
  873.   }
  874.    * ResultRank = 0;
  875.    return;
  876.  
  877. ;
  878. }
  879.  
  880. static void CheckMerge
  881. # if defined __STDC__ | defined __cplusplus
  882. (register tTree params, register int * ResultRank)
  883. # else
  884. (params, ResultRank)
  885.  register tTree params;
  886.  register int * ResultRank;
  887. # endif
  888. {
  889.   if (params == NoTree) return;
  890.   if (params->Kind == kBTP_LIST) {
  891.   if (params->BTP_LIST.Next->Kind == kBTP_LIST) {
  892.   if (params->BTP_LIST.Next->BTP_LIST.Next->Kind == kBTP_LIST) {
  893.   if (params->BTP_LIST.Next->BTP_LIST.Next->BTP_LIST.Next->Kind == kBTP_EMPTY) {
  894. # line 526 "SemExp.puma"
  895.  {
  896.   int yyV1;
  897.   int yyV2;
  898.   int yyV3;
  899.   {
  900. # line 528 "SemExp.puma"
  901.    SemExp (params->BTP_LIST.Elem, & yyV1);
  902. # line 529 "SemExp.puma"
  903.    SemExp (params->BTP_LIST.Next->BTP_LIST.Elem, & yyV2);
  904. # line 530 "SemExp.puma"
  905.  if (yyV1 != yyV2)
  906.        error_protocol ("Parameters in MERGE have different rank");
  907.  
  908. # line 533 "SemExp.puma"
  909.    SemExp (params->BTP_LIST.Next->BTP_LIST.Next->BTP_LIST.Elem, & yyV3);
  910. # line 534 "SemExp.puma"
  911.  if (yyV1 != yyV3)
  912.        error_protocol ("Mask in MERGE has wrong rank");
  913.  
  914.   }
  915.    * ResultRank = yyV1;
  916.    return;
  917.  }
  918.  
  919.   }
  920.   }
  921.   }
  922.   }
  923. # line 539 "SemExp.puma"
  924.   {
  925. # line 540 "SemExp.puma"
  926.    error_protocol ("MERGE has not three Parameters");
  927.   }
  928.    * ResultRank = 0;
  929.    return;
  930.  
  931. ;
  932. }
  933.  
  934. static void CheckCShift
  935. # if defined __STDC__ | defined __cplusplus
  936. (register tTree params, register int * ResultRank)
  937. # else
  938. (params, ResultRank)
  939.  register tTree params;
  940.  register int * ResultRank;
  941. # endif
  942. {
  943.   if (params == NoTree) return;
  944.   if (params->Kind == kBTP_LIST) {
  945.   if (params->BTP_LIST.Next->Kind == kBTP_LIST) {
  946.   if (params->BTP_LIST.Next->BTP_LIST.Next->Kind == kBTP_LIST) {
  947.   if (params->BTP_LIST.Next->BTP_LIST.Next->BTP_LIST.Next->Kind == kBTP_EMPTY) {
  948. # line 551 "SemExp.puma"
  949.  {
  950.   int yyV1;
  951.   int yyV2;
  952.   int yyV3;
  953.   {
  954. # line 553 "SemExp.puma"
  955.    SemExp (params->BTP_LIST.Elem, & yyV1);
  956. # line 554 "SemExp.puma"
  957.    SemExp (params->BTP_LIST.Next->BTP_LIST.Elem, & yyV2);
  958. # line 555 "SemExp.puma"
  959.  if (yyV2 != 0)
  960.        error_protocol ("Dim Parameter in CSHIFT is not a scalar");
  961.  
  962. # line 558 "SemExp.puma"
  963.    SemExp (params->BTP_LIST.Next->BTP_LIST.Next->BTP_LIST.Elem, & yyV3);
  964. # line 559 "SemExp.puma"
  965.  if (yyV3 != 0)
  966.        error_protocol ("Shift Parameter in CSHIFT is not a scalar");
  967.  
  968.   }
  969.    * ResultRank = yyV1;
  970.    return;
  971.  }
  972.  
  973.   }
  974.   }
  975.   }
  976.   }
  977. # line 564 "SemExp.puma"
  978.   {
  979. # line 565 "SemExp.puma"
  980.    error_protocol ("CSHIFT has not three Parameters");
  981.   }
  982.    * ResultRank = 0;
  983.    return;
  984.  
  985. ;
  986. }
  987.  
  988. static void CheckTranspose
  989. # if defined __STDC__ | defined __cplusplus
  990. (register tTree params, register int * ResultRank)
  991. # else
  992. (params, ResultRank)
  993.  register tTree params;
  994.  register int * ResultRank;
  995. # endif
  996. {
  997.   if (params == NoTree) return;
  998.   if (params->Kind == kBTP_LIST) {
  999.   if (params->BTP_LIST.Next->Kind == kBTP_EMPTY) {
  1000. # line 576 "SemExp.puma"
  1001.  {
  1002.   int yyV1;
  1003.   {
  1004. # line 578 "SemExp.puma"
  1005.    SemExp (params->BTP_LIST.Elem, & yyV1);
  1006. # line 579 "SemExp.puma"
  1007.  if (yyV1 != 2)
  1008.        error_protocol ("Array in transpose must be two-dimensional");
  1009.  
  1010.   }
  1011.    * ResultRank = yyV1;
  1012.    return;
  1013.  }
  1014.  
  1015.   }
  1016.   }
  1017. # line 584 "SemExp.puma"
  1018.   {
  1019. # line 585 "SemExp.puma"
  1020.    error_protocol ("TRANSPOSE has not one Parameter");
  1021.   }
  1022.    * ResultRank = 0;
  1023.    return;
  1024.  
  1025. ;
  1026. }
  1027.  
  1028. static void CheckSpread
  1029. # if defined __STDC__ | defined __cplusplus
  1030. (register tTree params, register int * ResultRank)
  1031. # else
  1032. (params, ResultRank)
  1033.  register tTree params;
  1034.  register int * ResultRank;
  1035. # endif
  1036. {
  1037.   if (params == NoTree) return;
  1038.   if (params->Kind == kBTP_LIST) {
  1039.   if (params->BTP_LIST.Next->Kind == kBTP_LIST) {
  1040.   if (params->BTP_LIST.Next->BTP_LIST.Next->Kind == kBTP_LIST) {
  1041.   if (params->BTP_LIST.Next->BTP_LIST.Next->BTP_LIST.Next->Kind == kBTP_EMPTY) {
  1042. # line 596 "SemExp.puma"
  1043.  {
  1044.   int yyV1;
  1045.   int yyV2;
  1046.   int yyV3;
  1047.   {
  1048. # line 598 "SemExp.puma"
  1049.    SemExp (params->BTP_LIST.Elem, & yyV1);
  1050. # line 599 "SemExp.puma"
  1051.    SemExp (params->BTP_LIST.Next->BTP_LIST.Elem, & yyV2);
  1052. # line 600 "SemExp.puma"
  1053.  if (yyV2 != 0)
  1054.        error_protocol ("Dim Parameter in CSHIFT is not a scalar");
  1055.  
  1056. # line 603 "SemExp.puma"
  1057.    SemExp (params->BTP_LIST.Next->BTP_LIST.Next->BTP_LIST.Elem, & yyV3);
  1058. # line 604 "SemExp.puma"
  1059.  if (yyV3 != 0)
  1060.        error_protocol ("Shift Parameter in CSHIFT is not a scalar");
  1061.  
  1062.   }
  1063.    * ResultRank = yyV1 + 1;
  1064.    return;
  1065.  }
  1066.  
  1067.   }
  1068.   }
  1069.   }
  1070.   }
  1071. # line 609 "SemExp.puma"
  1072.   {
  1073. # line 610 "SemExp.puma"
  1074.    error_protocol ("SPREAD has not three Parameters");
  1075.   }
  1076.    * ResultRank = 0;
  1077.    return;
  1078.  
  1079. ;
  1080. }
  1081.  
  1082. static void CheckRed
  1083. # if defined __STDC__ | defined __cplusplus
  1084. (register tTree params, register int * ResultRank)
  1085. # else
  1086. (params, ResultRank)
  1087.  register tTree params;
  1088.  register int * ResultRank;
  1089. # endif
  1090. {
  1091.   if (params == NoTree) return;
  1092.   if (params->Kind == kBTP_LIST) {
  1093.   if (params->BTP_LIST.Next->Kind == kBTP_EMPTY) {
  1094. # line 624 "SemExp.puma"
  1095.  {
  1096.   int yyV1;
  1097.   {
  1098. # line 625 "SemExp.puma"
  1099.    SemExp (params->BTP_LIST.Elem, & yyV1);
  1100. # line 626 "SemExp.puma"
  1101.  if (yyV1 <= 0)
  1102.         error_protocol ("reduction: first parameter must be an array");
  1103.  
  1104.   }
  1105.    * ResultRank = 0;
  1106.    return;
  1107.  }
  1108.  
  1109.   }
  1110.   if (params->BTP_LIST.Next->Kind == kBTP_LIST) {
  1111.   if (params->BTP_LIST.Next->BTP_LIST.Next->Kind == kBTP_EMPTY) {
  1112. # line 631 "SemExp.puma"
  1113.  {
  1114.   int yyV1;
  1115.   int yyV2;
  1116.   {
  1117. # line 632 "SemExp.puma"
  1118.    SemExp (params->BTP_LIST.Elem, & yyV1);
  1119. # line 633 "SemExp.puma"
  1120.    SemExp (params->BTP_LIST.Next->BTP_LIST.Elem, & yyV2);
  1121. # line 634 "SemExp.puma"
  1122.  if (yyV1 <= 0)
  1123.         error_protocol ("reduction: first parameter must be an array");
  1124.  
  1125. # line 637 "SemExp.puma"
  1126.    if (! (yyV2 == 0)) goto yyL2;
  1127.   }
  1128.    * ResultRank = yyV1 - 1;
  1129.    return;
  1130.  }
  1131. yyL2:;
  1132.  
  1133. # line 640 "SemExp.puma"
  1134.  {
  1135.   int yyV1;
  1136.   int yyV2;
  1137.   {
  1138. # line 641 "SemExp.puma"
  1139.    SemExp (params->BTP_LIST.Elem, & yyV1);
  1140. # line 642 "SemExp.puma"
  1141.    SemExp (params->BTP_LIST.Next->BTP_LIST.Elem, & yyV2);
  1142. # line 643 "SemExp.puma"
  1143.  if (yyV1 <= 0)
  1144.         error_protocol ("reduction: first parameter must be an array");
  1145.      if (yyV2 != yyV1)
  1146.        error_protocol ("reduction: mask has not same rank as array");
  1147.  
  1148.   }
  1149.    * ResultRank = 0;
  1150.    return;
  1151.  }
  1152.  
  1153.   }
  1154.   if (params->BTP_LIST.Next->BTP_LIST.Next->Kind == kBTP_LIST) {
  1155.   if (params->BTP_LIST.Next->BTP_LIST.Next->BTP_LIST.Next->Kind == kBTP_EMPTY) {
  1156. # line 650 "SemExp.puma"
  1157.  {
  1158.   int yyV1;
  1159.   int yyV2;
  1160.   int yyV3;
  1161.   {
  1162. # line 651 "SemExp.puma"
  1163.    SemExp (params->BTP_LIST.Elem, & yyV1);
  1164. # line 652 "SemExp.puma"
  1165.    SemExp (params->BTP_LIST.Next->BTP_LIST.Elem, & yyV2);
  1166. # line 653 "SemExp.puma"
  1167.    SemExp (params->BTP_LIST.Next->BTP_LIST.Next->BTP_LIST.Elem, & yyV3);
  1168. # line 654 "SemExp.puma"
  1169.  if (yyV1 <= 0)
  1170.         error_protocol ("reduction: first parameter must be an array");
  1171.      if (yyV2 != 0)
  1172.        error_protocol ("reduction: dim is not a scalar");
  1173.      if (yyV3 != yyV1)
  1174.        error_protocol ("reduction: mask has not same rank as array");
  1175.  
  1176.   }
  1177.    * ResultRank = yyV1 - 1;
  1178.    return;
  1179.  }
  1180.  
  1181.   }
  1182.   }
  1183.   }
  1184.   }
  1185. # line 663 "SemExp.puma"
  1186.   {
  1187. # line 664 "SemExp.puma"
  1188.    error_protocol ("reduction: has not one - three Parameters");
  1189.   }
  1190.    * ResultRank = 0;
  1191.    return;
  1192.  
  1193. ;
  1194. }
  1195.  
  1196. static bool IsCurrentLoopVar
  1197. # if defined __STDC__ | defined __cplusplus
  1198. (register tTree t)
  1199. # else
  1200. (t)
  1201.  register tTree t;
  1202. # endif
  1203. {
  1204.   if (t == NoTree) return false;
  1205.   if (t->Kind == kUSED_VAR) {
  1206. # line 676 "SemExp.puma"
  1207.  {
  1208.   bool found;
  1209.   int i;
  1210.   tTree lv;
  1211.   {
  1212. # line 678 "SemExp.puma"
  1213.  
  1214. # line 679 "SemExp.puma"
  1215.  
  1216. # line 680 "SemExp.puma"
  1217.  
  1218. # line 682 "SemExp.puma"
  1219.  
  1220.       found = false;
  1221.       i     = 0;
  1222.       while ((!found) && (i < Nesting))
  1223.          { if (Nest[i]->Kind == kACF_DOALL)
  1224.               lv = Nest[i]->ACF_DOALL.DOALL_ID;
  1225.             else if (Nest[i]->Kind == kACF_FORALL)
  1226.               lv = Nest[i]->ACF_FORALL.FORALL_ID;
  1227.             else if (Nest[i]->Kind == kACF_DOLOCAL)
  1228.               lv = Nest[i]->ACF_DOLOCAL.DOLOCAL_ID;
  1229.             else
  1230.               lv = Nest[i]->ACF_DO.DO_ID;
  1231.            lv = lv->LOOP_VAR.LOOP_VARNAME;
  1232.            found = EqualExpression (t->USED_VAR.VARNAME, lv);
  1233.            i += 1;
  1234.          }
  1235.  
  1236. # line 699 "SemExp.puma"
  1237.    if (! (found)) goto yyL1;
  1238.   }
  1239.    return true;
  1240.  }
  1241. yyL1:;
  1242.  
  1243.   }
  1244.   if (t->Kind == kLOOP_VAR) {
  1245. # line 702 "SemExp.puma"
  1246.    return true;
  1247.  
  1248.   }
  1249.   return false;
  1250. }
  1251.  
  1252. static tTree CheckNamedParameters
  1253. # if defined __STDC__ | defined __cplusplus
  1254. (register tTree t)
  1255. # else
  1256. (t)
  1257.  register tTree t;
  1258. # endif
  1259. {
  1260. # line 721 "SemExp.puma"
  1261.   {
  1262. # line 722 "SemExp.puma"
  1263.    DefineNamedParameters (t);
  1264.   }
  1265.    return GetUnnamedParameters (t);
  1266.  
  1267. }
  1268.  
  1269. static void DefineNamedParameters
  1270. # if defined __STDC__ | defined __cplusplus
  1271. (register tTree t)
  1272. # else
  1273. (t)
  1274.  register tTree t;
  1275. # endif
  1276. {
  1277.   if (t == NoTree) return;
  1278.   if (t->Kind == kBTP_LIST) {
  1279.   if (t->BTP_LIST.Elem->Kind == kNAMED_PARAM) {
  1280. # line 728 "SemExp.puma"
  1281.   {
  1282. # line 729 "SemExp.puma"
  1283.    DefineNamedParameters (t->BTP_LIST.Next);
  1284.   }
  1285.    return;
  1286.  
  1287.   }
  1288. # line 732 "SemExp.puma"
  1289.   {
  1290. # line 734 "SemExp.puma"
  1291.    DefineNamedParameters (t->BTP_LIST.Next);
  1292.   }
  1293.    return;
  1294.  
  1295.   }
  1296.   if (t->Kind == kBTP_EMPTY) {
  1297. # line 737 "SemExp.puma"
  1298.    return;
  1299.  
  1300.   }
  1301. # line 740 "SemExp.puma"
  1302.   {
  1303. # line 741 "SemExp.puma"
  1304.    printf ("Illegal Call of DefineNamedParameters\n");
  1305. # line 742 "SemExp.puma"
  1306.    WriteTree (stdout, t);
  1307. # line 743 "SemExp.puma"
  1308.    kill_in_protocol ();
  1309.   }
  1310.    return;
  1311.  
  1312. ;
  1313. }
  1314.  
  1315. static tTree GetUnnamedParameters
  1316. # if defined __STDC__ | defined __cplusplus
  1317. (register tTree t)
  1318. # else
  1319. (t)
  1320.  register tTree t;
  1321. # endif
  1322. {
  1323.   if (t->Kind == kBTP_LIST) {
  1324.   if (t->BTP_LIST.Elem->Kind == kNAMED_PARAM) {
  1325. # line 748 "SemExp.puma"
  1326.   {
  1327. # line 749 "SemExp.puma"
  1328.  t->BTP_LIST.Elem = t->BTP_LIST.Elem->NAMED_PARAM.VAL;
  1329.      t->BTP_LIST.Next = GetUnnamedParameters (t->BTP_LIST.Next);
  1330.  
  1331.   }
  1332.    return t;
  1333.  
  1334.   }
  1335. # line 755 "SemExp.puma"
  1336.   {
  1337. # line 757 "SemExp.puma"
  1338.  t->BTP_LIST.Next = GetUnnamedParameters (t->BTP_LIST.Next);
  1339.   }
  1340.    return t;
  1341.  
  1342.   }
  1343.   if (t->Kind == kBTP_EMPTY) {
  1344. # line 761 "SemExp.puma"
  1345.    return t;
  1346.  
  1347.   }
  1348.  yyAbort ("GetUnnamedParameters");
  1349. }
  1350.  
  1351. void BeginSemExp ()
  1352. {
  1353. }
  1354.  
  1355. void CloseSemExp ()
  1356. {
  1357. }
  1358.