home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Professional / OS2PRO194.ISO / os2 / prgramer / adaptor / src / semantic.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-01-03  |  54.0 KB  |  2,396 lines
  1. # include "Semantic.h"
  2. # include "yySemant.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 44 "Semantic.puma"
  36.  
  37. # include "Idents.h"
  38. # include "StringMe.h"
  39. # include "Types.h"
  40. # include "protocol.h"
  41.  
  42. # include "Globals.h"    /* CheckGlobalGetParams, CheckGlobalSendParams */
  43.  
  44. # include "SemDecls.h"  /* SemDefinitions, SemDeclarations */
  45. # include "SemExp.h"    /* SemExp, SemExpList              */
  46.  
  47. /*********************************************************************
  48. *                                                                    *
  49. *  Global Data for Semantic Analysis                                 *
  50. *                                                                    *
  51. *********************************************************************/
  52.  
  53. static tTree current_unit;
  54.  
  55. /*********************************************************************
  56. *                                                                    *
  57. *    allocate_stack:                                                 *
  58. *                                MAX_ALLOCATES                       *
  59. *    -------------------------                                       *
  60. *    |                       |                                       *
  61. *    -------------------------                                       *
  62. *    |                       |                                       *
  63. *    |   ...............     |                                       *
  64. *    |                       |                                       *
  65. *    -------------------------                                       *
  66. *    |                       |   3  <- allocate_top                  *
  67. *    -------------------------                                       *
  68. *    |    alloc_var 3        |   2                                   *
  69. *    -------------------------                                       *
  70. *    |    alloc_var 2        |   1                                   *
  71. *    -------------------------                                       *
  72. *    |    alloc_var 1        |   0                                   *
  73. *    -------------------------                                       *
  74. *                                                                    *
  75. *********************************************************************/
  76.  
  77. # define MAX_ALLOCATES 100
  78.  
  79. static int allocate_top;
  80. static tIdent allocate_stack [MAX_ALLOCATES];
  81.  
  82.        /*************************************************
  83.        *                                                *
  84.        *  Check that allocate_stack is empty at the end *
  85.        *                                                *
  86.        *************************************************/
  87.  
  88. void DeallocateCheck ()
  89. { int i;
  90.   char name[100], msg[130];
  91.   for (i=allocate_top-1; i>=0; i--)
  92.     { /* missing deallocate for allocate_stack[i] */
  93.       GetString (allocate_stack[i], name);
  94.       sprintf (msg, "Missing DEALLOCATE for %s", name);
  95.       simple_error_protocol (msg);
  96.     }
  97. } /* DeallocateCheck */
  98.  
  99.        /*************************************************
  100.        *                                                *
  101.        *  Check if name has been allocated              *
  102.        *                                                *
  103.        *************************************************/
  104.  
  105. bool IsAllocated (var)
  106. tIdent var;
  107. { bool found;
  108.   int  i;
  109.   i = 0;
  110.   found = false;
  111.   while ((i < allocate_top) && (!found))
  112.    { found = (allocate_stack[i] == var);
  113.      if (!found) i+=1;
  114.    }
  115.   return found;
  116. } /* IsAllocated */
  117.  
  118.  
  119.  
  120. static FILE * yyf = stdout;
  121.  
  122. static void yyAbort
  123. # ifdef __cplusplus
  124.  (char * yyFunction)
  125. # else
  126.  (yyFunction) char * yyFunction;
  127. # endif
  128. {
  129.  (void) fprintf (stderr, "Error: module Semantic, routine %s failed\n", yyFunction);
  130.  exit (1);
  131. }
  132.  
  133. void Semantic ARGS((tTree t));
  134. static void BodyCheck ARGS((tTree body, tTree unit));
  135. static void SemanticWhere ARGS((tTree t, int whererank));
  136. static void SemanticForall ARGS((tTree t));
  137. static void ForallLoopVarCheck ARGS((tTree loop, tTree var));
  138. static void SemanticIO ARGS((tTree t));
  139. static void SemReadParams ARGS((tTree items));
  140. static tTree MakeDoVar ARGS((tTree DoExp));
  141. void SemanticCall ARGS((tTree t, tDefinitions p));
  142. static void SemanticCallParams ARGS((tTree a, tTree f, tDefinitions d));
  143. static void SemanticMatchParam ARGS((tTree actual, tDefinitions formal));
  144. static void AnalIntrinsicSubroutine ARGS((tIdent name, tTree params));
  145. static void CheckReduceParams ARGS((tTree t));
  146. static void CheckRandomParams ARGS((tTree t));
  147. static void CheckRandomTypes ARGS((tTree type, tTree limit));
  148. static void CheckRandomizeParams ARGS((tTree t));
  149. static void CheckWalltimeParams ARGS((tTree t));
  150. static void CheckTimerParams ARGS((tTree t));
  151. static void CheckAllocateParams ARGS((tTree t));
  152. static void NormalAllocateParams ARGS((tTree t));
  153. static void CheckDeallocateParams ARGS((tTree t));
  154. static bool IsVarParameter ARGS((tTree t));
  155. static void CheckLHSVar ARGS((tTree t));
  156. static void SemPureCheck ARGS((tTree t));
  157.  
  158. void Semantic
  159. # if defined __STDC__ | defined __cplusplus
  160. (register tTree t)
  161. # else
  162. (t)
  163.  register tTree t;
  164. # endif
  165. {
  166. # line 130 "Semantic.puma"
  167.  
  168. char string[256];
  169. tObject Obj, Obj1;
  170. int dist;
  171. bool okay;
  172.  
  173.  
  174.   switch (t->Kind) {
  175.   case kCOMP_UNIT:
  176. # line 143 "Semantic.puma"
  177.   {
  178. # line 144 "Semantic.puma"
  179.    open_protocol ("adaptor.sem");
  180. # line 145 "Semantic.puma"
  181.    Semantic (t->COMP_UNIT.COMP_ELEMENTS);
  182. # line 146 "Semantic.puma"
  183.    close_protocol ();
  184.   }
  185.    return;
  186.  
  187.   case kDECL_EMPTY:
  188. # line 151 "Semantic.puma"
  189.    return;
  190.  
  191.   case kDECL_LIST:
  192. # line 154 "Semantic.puma"
  193.   {
  194. # line 155 "Semantic.puma"
  195.    Semantic (t->DECL_LIST.Elem);
  196. # line 156 "Semantic.puma"
  197.    Semantic (t->DECL_LIST.Next);
  198.   }
  199.    return;
  200.  
  201.   case kPROGRAM_DECL:
  202. # line 169 "Semantic.puma"
  203.  {
  204.   tDefinitions Obj;
  205.   {
  206. # line 170 "Semantic.puma"
  207.    set_protocol_unit (t);
  208. # line 171 "Semantic.puma"
  209.    current_unit = t;
  210. # line 172 "Semantic.puma"
  211.    IsPure = false;
  212. # line 173 "Semantic.puma"
  213.  
  214. # line 174 "Semantic.puma"
  215.    Obj = GetDeclEntry (t->PROGRAM_DECL.Name, GetUnitEntries ());
  216. # line 175 "Semantic.puma"
  217.    OpenScope (Obj->ProcObject.Declarations);
  218. # line 176 "Semantic.puma"
  219.    SemDefinitions (GetCurrentScope ());
  220. # line 177 "Semantic.puma"
  221.    Semantic (t->PROGRAM_DECL.PROGRAM_BODY);
  222. # line 178 "Semantic.puma"
  223.    CloseScope ();
  224.   }
  225.    return;
  226.  }
  227.  
  228.   case kPROC_DECL:
  229. # line 181 "Semantic.puma"
  230.  {
  231.   tDefinitions Obj;
  232.   {
  233. # line 182 "Semantic.puma"
  234.    set_protocol_unit (t);
  235. # line 183 "Semantic.puma"
  236.    current_unit = t;
  237. # line 184 "Semantic.puma"
  238.    IsPure = t->PROC_DECL.IsPure;
  239. # line 185 "Semantic.puma"
  240.  
  241. # line 186 "Semantic.puma"
  242.    Obj = GetDeclEntry (t->PROC_DECL.Name, GetUnitEntries ());
  243. # line 187 "Semantic.puma"
  244.    OpenScope (Obj->ProcObject.Declarations);
  245. # line 188 "Semantic.puma"
  246.    SemDefinitions (GetCurrentScope ());
  247. # line 189 "Semantic.puma"
  248.    Semantic (t->PROC_DECL.PROC_BODY);
  249. # line 190 "Semantic.puma"
  250.    CloseScope ();
  251.   }
  252.    return;
  253.  }
  254.  
  255.   case kFUNC_DECL:
  256. # line 193 "Semantic.puma"
  257.  {
  258.   tDefinitions Obj;
  259.   {
  260. # line 194 "Semantic.puma"
  261.    set_protocol_unit (t);
  262. # line 195 "Semantic.puma"
  263.    current_unit = t;
  264. # line 196 "Semantic.puma"
  265.    IsPure = t->FUNC_DECL.IsPure;
  266. # line 197 "Semantic.puma"
  267.  
  268. # line 198 "Semantic.puma"
  269.    Obj = GetDeclEntry (t->FUNC_DECL.Name, GetUnitEntries ());
  270. # line 199 "Semantic.puma"
  271.    OpenScope (Obj->FuncObject.Declarations);
  272. # line 200 "Semantic.puma"
  273.    SemDefinitions (GetCurrentScope ());
  274. # line 201 "Semantic.puma"
  275.    Semantic (t->FUNC_DECL.FUNC_BODY);
  276. # line 202 "Semantic.puma"
  277.    CloseScope ();
  278.   }
  279.    return;
  280.  }
  281.  
  282.   case kMODULE_DECL:
  283. # line 205 "Semantic.puma"
  284.  {
  285.   tDefinitions Obj;
  286.   {
  287. # line 206 "Semantic.puma"
  288.    set_protocol_unit (t);
  289. # line 207 "Semantic.puma"
  290.    current_unit = t;
  291. # line 208 "Semantic.puma"
  292.    IsPure = false;
  293. # line 209 "Semantic.puma"
  294.  
  295. # line 210 "Semantic.puma"
  296.    Obj = GetDeclEntry (t->MODULE_DECL.Name, GetUnitEntries ());
  297. # line 211 "Semantic.puma"
  298.    OpenScope (Obj->ModuleObject.Declarations);
  299. # line 212 "Semantic.puma"
  300.    SemDefinitions (GetCurrentScope ());
  301. # line 213 "Semantic.puma"
  302.    Semantic (t->MODULE_DECL.MODULE_BODY);
  303. # line 214 "Semantic.puma"
  304.    CloseScope ();
  305.   }
  306.    return;
  307.  }
  308.  
  309.   case kBLOCK_DATA_DECL:
  310. # line 217 "Semantic.puma"
  311.  {
  312.   tDefinitions Obj;
  313.   {
  314. # line 218 "Semantic.puma"
  315.    set_protocol_unit (t);
  316. # line 219 "Semantic.puma"
  317.    current_unit = t;
  318. # line 220 "Semantic.puma"
  319.    IsPure = false;
  320. # line 221 "Semantic.puma"
  321.  
  322. # line 222 "Semantic.puma"
  323.    Obj = GetDeclEntry (t->BLOCK_DATA_DECL.Name, GetUnitEntries ());
  324. # line 223 "Semantic.puma"
  325.    OpenScope (Obj->BlockObject.Declarations);
  326. # line 224 "Semantic.puma"
  327.    SemDefinitions (GetCurrentScope ());
  328. # line 225 "Semantic.puma"
  329.    Semantic (t->BLOCK_DATA_DECL.DATA_BODY);
  330. # line 226 "Semantic.puma"
  331.    CloseScope ();
  332.   }
  333.    return;
  334.  }
  335.  
  336.   case kBODY_NODE:
  337. # line 239 "Semantic.puma"
  338.   {
  339. # line 240 "Semantic.puma"
  340.    BodyCheck (t, current_unit);
  341. # line 241 "Semantic.puma"
  342.    allocate_top = 0;
  343. # line 242 "Semantic.puma"
  344.    Nesting = 0;
  345. # line 243 "Semantic.puma"
  346.    SemDeclarations (t->BODY_NODE.DECLS, current_unit);
  347. # line 244 "Semantic.puma"
  348.    Semantic (t->BODY_NODE.STATS);
  349. # line 246 "Semantic.puma"
  350.    DeallocateCheck ();
  351. # line 247 "Semantic.puma"
  352.  if (IsPure) SemPureCheck (t);
  353.   }
  354.    return;
  355.  
  356.   case kACF_LIST:
  357. # line 256 "Semantic.puma"
  358.   {
  359. # line 257 "Semantic.puma"
  360.    set_protocol_stmt (t->ACF_LIST.Elem);
  361. # line 258 "Semantic.puma"
  362.    Semantic (t->ACF_LIST.Elem);
  363. # line 259 "Semantic.puma"
  364.    Semantic (t->ACF_LIST.Next);
  365.   }
  366.    return;
  367.  
  368.   case kACF_EMPTY:
  369. # line 262 "Semantic.puma"
  370.    return;
  371.  
  372.   case kACF_DUMMY:
  373. # line 265 "Semantic.puma"
  374.    return;
  375.  
  376.   case kACF_BASIC:
  377. # line 268 "Semantic.puma"
  378.   {
  379. # line 269 "Semantic.puma"
  380.    Semantic (t->ACF_BASIC.BASIC_STMT);
  381.   }
  382.    return;
  383.  
  384.   case kACF_IF:
  385. # line 272 "Semantic.puma"
  386.  {
  387.   int rank;
  388.   {
  389. # line 274 "Semantic.puma"
  390.  
  391. # line 276 "Semantic.puma"
  392.    SemExp (t->ACF_IF.IF_EXP, & rank);
  393. # line 277 "Semantic.puma"
  394.  if (rank != 0)
  395.             error_protocol ("Rank of EXP > 0 in IF");
  396.  
  397. # line 280 "Semantic.puma"
  398.    Semantic (t->ACF_IF.THEN_PART);
  399. # line 281 "Semantic.puma"
  400.    Semantic (t->ACF_IF.ELSE_PART);
  401.   }
  402.    return;
  403.  }
  404.  
  405.   case kACF_WHERE:
  406. # line 284 "Semantic.puma"
  407.  {
  408.   int whererank;
  409.   {
  410. # line 286 "Semantic.puma"
  411.  
  412. # line 288 "Semantic.puma"
  413.    SemExp (t->ACF_WHERE.WHERE_EXP, & whererank);
  414. # line 290 "Semantic.puma"
  415.  if (whererank > 0)
  416.            { SemanticWhere (t->ACF_WHERE.TRUE_PART, whererank);
  417.              SemanticWhere (t->ACF_WHERE.FALSE_PART, whererank);
  418.            }
  419.           else
  420.            error_protocol ("Illegal Rank of Expression in WHERE");
  421.  
  422.   }
  423.    return;
  424.  }
  425.  
  426.   case kACF_CASE:
  427. # line 299 "Semantic.puma"
  428.  {
  429.   int rank;
  430.   {
  431. # line 301 "Semantic.puma"
  432.  
  433. # line 303 "Semantic.puma"
  434.    SemExp (t->ACF_CASE.CASE_EXP, & rank);
  435. # line 304 "Semantic.puma"
  436.  if (rank != 0)
  437.             error_protocol ("Illegal Rank of Expression in CASE");
  438.  
  439. # line 307 "Semantic.puma"
  440.    Semantic (t->ACF_CASE.CASE_ALTS);
  441. # line 308 "Semantic.puma"
  442.    Semantic (t->ACF_CASE.CASE_OTHERWISE);
  443.   }
  444.    return;
  445.  }
  446.  
  447.   case kSELECTED_ACF_LIST:
  448. # line 311 "Semantic.puma"
  449.   {
  450. # line 312 "Semantic.puma"
  451.    Semantic (t->SELECTED_ACF_LIST.Elem);
  452. # line 313 "Semantic.puma"
  453.    Semantic (t->SELECTED_ACF_LIST.Next);
  454.   }
  455.    return;
  456.  
  457.   case kSELECTED_ACF_EMPTY:
  458. # line 316 "Semantic.puma"
  459.    return;
  460.  
  461.   case kSELECTED_ACF_NODE:
  462. # line 319 "Semantic.puma"
  463.   {
  464. # line 321 "Semantic.puma"
  465.    SemExpList (t->SELECTED_ACF_NODE.SELECT_LIST);
  466. # line 322 "Semantic.puma"
  467.    Semantic (t->SELECTED_ACF_NODE.SELECT_ACFS);
  468.   }
  469.    return;
  470.  
  471.   case kACF_WHILE:
  472. # line 325 "Semantic.puma"
  473.  {
  474.   int rank;
  475.   {
  476. # line 327 "Semantic.puma"
  477.  
  478. # line 329 "Semantic.puma"
  479.    SemExp (t->ACF_WHILE.WHILE_EXP, & rank);
  480. # line 331 "Semantic.puma"
  481.  if (rank != 0)
  482.         error_protocol ("Rank of EXP > 0 in WHILE");
  483.  
  484. # line 334 "Semantic.puma"
  485.    Semantic (t->ACF_WHILE.WHILE_BODY);
  486.   }
  487.    return;
  488.  }
  489.  
  490.   case kACF_DOALL:
  491. # line 337 "Semantic.puma"
  492.  {
  493.   int rank;
  494.   {
  495. # line 339 "Semantic.puma"
  496.  
  497. # line 343 "Semantic.puma"
  498.    SemExp (t->ACF_DOALL.DOALL_ID, & rank);
  499. # line 344 "Semantic.puma"
  500.    SemExp (t->ACF_DOALL.DOALL_RANGE, & rank);
  501. # line 346 "Semantic.puma"
  502.  if (Nesting >= MAXLoops)
  503.        simple_error_protocol ("to deep do/doall loop nesting");
  504.      else
  505.        { Nest [Nesting] = t;
  506.          Nesting += 1;
  507.          Semantic (t->ACF_DOALL.DOALL_BODY);
  508.          Nesting -= 1;
  509.        }
  510.  
  511.   }
  512.    return;
  513.  }
  514.  
  515.   case kACF_DOLOCAL:
  516. # line 357 "Semantic.puma"
  517.  {
  518.   int rank;
  519.   {
  520. # line 359 "Semantic.puma"
  521.  
  522. # line 361 "Semantic.puma"
  523.    SemExp (t->ACF_DOLOCAL.DOLOCAL_ID, & rank);
  524. # line 362 "Semantic.puma"
  525.    SemExp (t->ACF_DOLOCAL.DOLOCAL_RANGE, & rank);
  526. # line 364 "Semantic.puma"
  527.  if (Nesting >= MAXLoops)
  528.        simple_error_protocol ("to deep do/forall loop nesting");
  529.      else
  530.        { Nest [Nesting] = t;
  531.          Nesting += 1;
  532.          Semantic (t->ACF_DOLOCAL.DOLOCAL_BODY);
  533.          Nesting -= 1;
  534.        }
  535.  
  536.   }
  537.    return;
  538.  }
  539.  
  540.   case kACF_FORALL:
  541. # line 380 "Semantic.puma"
  542.  {
  543.   int rank;
  544.   {
  545. # line 382 "Semantic.puma"
  546.  
  547. # line 384 "Semantic.puma"
  548.    SemExp (t->ACF_FORALL.FORALL_ID, & rank);
  549. # line 385 "Semantic.puma"
  550.    SemExp (t->ACF_FORALL.FORALL_RANGE, & rank);
  551. # line 387 "Semantic.puma"
  552.  if (Nesting >= MAXLoops)
  553.        simple_error_protocol ("to deep do/forall loop nesting");
  554.      else
  555.        { Nest [Nesting] = t;
  556.          Nesting += 1;
  557.          SemanticForall (t->ACF_FORALL.FORALL_BODY);
  558.          Nesting -= 1;
  559.        }
  560.  
  561.   }
  562.    return;
  563.  }
  564.  
  565.   case kACF_DO:
  566. # line 403 "Semantic.puma"
  567.  {
  568.   int rank;
  569.   {
  570. # line 405 "Semantic.puma"
  571.  
  572. # line 407 "Semantic.puma"
  573.    SemExp (t->ACF_DO.DO_ID, & rank);
  574. # line 408 "Semantic.puma"
  575.    SemExp (t->ACF_DO.DO_RANGE, & rank);
  576. # line 410 "Semantic.puma"
  577.  if (Nesting >= MAXLoops)
  578.        simple_error_protocol ("to deep do/forall loop nesting");
  579.      else
  580.        { Nest [Nesting] = t;
  581.          Nesting += 1;
  582.          Semantic (t->ACF_DO.DO_BODY);
  583.          Nesting -= 1;
  584.        }
  585.  
  586.   }
  587.    return;
  588.  }
  589.  
  590.   case kACF_ENTRY:
  591. # line 421 "Semantic.puma"
  592.   {
  593. # line 422 "Semantic.puma"
  594.    tree_error_protocol ("ENTRY not supported", t);
  595.   }
  596.    return;
  597.  
  598.   case kASSIGN_STMT:
  599. # line 425 "Semantic.puma"
  600.  {
  601.   int rank_lhs;
  602.   int rank_rhs;
  603.   {
  604. # line 427 "Semantic.puma"
  605.  
  606. # line 428 "Semantic.puma"
  607.  
  608. # line 430 "Semantic.puma"
  609.    SemExp (t->ASSIGN_STMT.ASSIGN_VAR, & rank_lhs);
  610. # line 431 "Semantic.puma"
  611.    SemExp (t->ASSIGN_STMT.ASSIGN_EXP, & rank_rhs);
  612. # line 433 "Semantic.puma"
  613.    CheckLHSVar (t->ASSIGN_STMT.ASSIGN_VAR);
  614. # line 435 "Semantic.puma"
  615.  if (rank_rhs > 0)
  616.       { if (rank_lhs != rank_rhs)
  617.          { error_protocol ("LHS and RHS have different rank");
  618.            sprintf (string, "Rank of LHS = %d : " , rank_lhs);
  619.            tree_protocol (string, t->ASSIGN_STMT.ASSIGN_VAR);
  620.            sprintf (string, "Rank of RHS = %d : " , rank_rhs);
  621.            tree_protocol (string, t->ASSIGN_STMT.ASSIGN_EXP);
  622.          }
  623.       }
  624.  
  625.   }
  626.    return;
  627.  }
  628.  
  629.   case kPTR_ASSIGN_STMT:
  630. # line 447 "Semantic.puma"
  631.   {
  632. # line 448 "Semantic.puma"
  633.    tree_error_protocol ("pointer assignment not supported", t);
  634.   }
  635.    return;
  636.  
  637.   case kLABEL_ASSIGN_STMT:
  638. # line 451 "Semantic.puma"
  639.  {
  640.   int rank;
  641.   {
  642. # line 453 "Semantic.puma"
  643.  
  644. # line 455 "Semantic.puma"
  645.    SemExp (t->LABEL_ASSIGN_STMT.LABEL_VAR, & rank);
  646. # line 456 "Semantic.puma"
  647.  if (rank != 0)
  648.         error_protocol ("variable in LABEL ASSIGN must have rank 0");
  649.  
  650.   }
  651.    return;
  652.  }
  653.  
  654.   case kFORMAT_STMT:
  655. # line 461 "Semantic.puma"
  656.    return;
  657.  
  658.   case kIO_STMT:
  659. # line 464 "Semantic.puma"
  660.   {
  661. # line 465 "Semantic.puma"
  662.    SemanticIO (t);
  663.   }
  664.    return;
  665.  
  666.   case kCALL_STMT:
  667. # line 468 "Semantic.puma"
  668.   {
  669. # line 470 "Semantic.puma"
  670.    if (! (t->CALL_STMT.CALL_ID->PROC_OBJ.Object == GetDeclEntry (t->CALL_STMT.CALL_ID->PROC_OBJ.Ident, GetIntrinsicEntries ()))) goto yyL31;
  671.   {
  672. # line 473 "Semantic.puma"
  673.    AnalIntrinsicSubroutine (t->CALL_STMT.CALL_ID->PROC_OBJ.Ident, t->CALL_STMT.CALL_PARAMS);
  674.   }
  675.   }
  676.    return;
  677. yyL31:;
  678.  
  679. # line 476 "Semantic.puma"
  680.   {
  681. # line 480 "Semantic.puma"
  682.    SemanticCall (t, t->CALL_STMT.CALL_ID->PROC_OBJ.Object);
  683.   }
  684.    return;
  685.  
  686.   case kGOTO_STMT:
  687. # line 483 "Semantic.puma"
  688.    return;
  689.  
  690.   case kASS_GOTO_STMT:
  691. # line 486 "Semantic.puma"
  692.  {
  693.   int rank;
  694.   {
  695. # line 488 "Semantic.puma"
  696.  
  697. # line 490 "Semantic.puma"
  698.    SemExp (t->ASS_GOTO_STMT.GOTO_VAR, & rank);
  699. # line 492 "Semantic.puma"
  700.  if (rank != 0)
  701.         error_protocol ("Illegal rank for expression in ASSIGNED GOTO");
  702.  
  703.   }
  704.    return;
  705.  }
  706.  
  707.   case kCOMP_GOTO_STMT:
  708. # line 498 "Semantic.puma"
  709.  {
  710.   int rank;
  711.   {
  712. # line 500 "Semantic.puma"
  713.  
  714. # line 502 "Semantic.puma"
  715.    SemExp (t->COMP_GOTO_STMT.GOTO_EXP, & rank);
  716. # line 504 "Semantic.puma"
  717.  if (rank != 0)
  718.         error_protocol ("Illegal rank for expression in COMPUTED GOTO");
  719.  
  720.   }
  721.    return;
  722.  }
  723.  
  724.   case kCOMP_IF_STMT:
  725. # line 510 "Semantic.puma"
  726.  {
  727.   int rank;
  728.   {
  729. # line 512 "Semantic.puma"
  730.  
  731. # line 514 "Semantic.puma"
  732.    SemExp (t->COMP_IF_STMT.IF_EXP, & rank);
  733. # line 516 "Semantic.puma"
  734.  if (rank != 0)
  735.         error_protocol ("Illegal rank for expression in COMPUTED IF");
  736.  
  737.   }
  738.    return;
  739.  }
  740.  
  741.   case kSTOP_STMT:
  742. # line 521 "Semantic.puma"
  743.    return;
  744.  
  745.   case kPAUSE_STMT:
  746. # line 524 "Semantic.puma"
  747.    return;
  748.  
  749.   case kEXIT_STMT:
  750. # line 527 "Semantic.puma"
  751.    return;
  752.  
  753.   case kCYCLE_STMT:
  754. # line 530 "Semantic.puma"
  755.    return;
  756.  
  757.   case kRETURN_STMT:
  758. # line 533 "Semantic.puma"
  759.   {
  760. # line 534 "Semantic.puma"
  761.  if (current_unit->Kind == kPROGRAM_DECL)
  762.         error_protocol ("RETURN not permitted in main program");
  763.  
  764.   }
  765.    return;
  766.  
  767.   case kREDUCE_STMT:
  768. # line 539 "Semantic.puma"
  769.  {
  770.   bool parloop;
  771.   int i;
  772.   {
  773. # line 541 "Semantic.puma"
  774.  
  775. # line 541 "Semantic.puma"
  776.  
  777. # line 543 "Semantic.puma"
  778.  
  779.        parloop = false;
  780.        for (i=0; i<Nesting; i++)
  781.          parloop = (parloop || (Nest[i]->Kind == kACF_DOLOCAL));
  782.        if (!parloop)
  783.          error_protocol ("REDUCE only in parallel loops allowed");
  784.        else
  785.        {
  786.          if (    (t->REDUCE_STMT.RED_FUNC->PROC_OBJ.Ident != MakeIdent("MINVAL",6))
  787.               && (t->REDUCE_STMT.RED_FUNC->PROC_OBJ.Ident != MakeIdent("MAXVAL",6))
  788.               && (TreeListLength (t->REDUCE_STMT.RED_PARAMS) > 2  )   )
  789.            error_protocol ("REDUCE with too many parameters");
  790.          CheckReduceParams (t->REDUCE_STMT.RED_PARAMS);
  791.        }
  792.  
  793.   }
  794.    return;
  795.  }
  796.  
  797.   case kALLOCATE_STMT:
  798. # line 560 "Semantic.puma"
  799.   {
  800. # line 562 "Semantic.puma"
  801.    CheckAllocateParams (t->ALLOCATE_STMT.PARAMS);
  802.   }
  803.    return;
  804.  
  805.   case kDEALLOCATE_STMT:
  806. # line 565 "Semantic.puma"
  807.   {
  808. # line 567 "Semantic.puma"
  809.    CheckDeallocateParams (t->DEALLOCATE_STMT.PARAMS);
  810.   }
  811.    return;
  812.  
  813.   case kNULLIFY_STMT:
  814. # line 570 "Semantic.puma"
  815.   {
  816. # line 571 "Semantic.puma"
  817.    tree_error_protocol ("NULLIFY not supported", t);
  818.   }
  819.    return;
  820.  
  821.   case kALIGN_STMT:
  822. # line 574 "Semantic.puma"
  823.   {
  824. # line 575 "Semantic.puma"
  825.    tree_error_protocol ("dynamic alignment not supported", t);
  826.   }
  827.    return;
  828.  
  829.   case kDISTRIBUTE_STMT:
  830. # line 578 "Semantic.puma"
  831.   {
  832. # line 579 "Semantic.puma"
  833.    tree_error_protocol ("dynamic distribution not supported", t);
  834.   }
  835.    return;
  836.  
  837.   }
  838.  
  839. # line 582 "Semantic.puma"
  840.   {
  841. # line 583 "Semantic.puma"
  842.  error_protocol ("unknown tree node Semantic");
  843.      printf ("Unknown Tree Node");
  844.      WriteTree (stdout, t);
  845.      kill_in_protocol ();
  846.  
  847.   }
  848.    return;
  849.  
  850. ;
  851. }
  852.  
  853. static void BodyCheck
  854. # if defined __STDC__ | defined __cplusplus
  855. (register tTree body, register tTree unit)
  856. # else
  857. (body, unit)
  858.  register tTree body;
  859.  register tTree unit;
  860. # endif
  861. {
  862.   if (body->Kind == kBODY_NODE) {
  863.   if (body->BODY_NODE.STATS->Kind == kACF_EMPTY) {
  864.   if (unit->Kind == kMODULE_DECL) {
  865. # line 603 "Semantic.puma"
  866.    return;
  867.  
  868.   }
  869.   if (body->BODY_NODE.INTERNALS->Kind == kDECL_EMPTY) {
  870.   if (unit->Kind == kBLOCK_DATA_DECL) {
  871. # line 610 "Semantic.puma"
  872.    return;
  873.  
  874.   }
  875.   }
  876.   }
  877.   if (unit->Kind == kMODULE_DECL) {
  878. # line 606 "Semantic.puma"
  879.   {
  880. # line 607 "Semantic.puma"
  881.    simple_error_protocol ("statements in MODULE not allowed");
  882.   }
  883.    return;
  884.  
  885.   }
  886.   if (body->BODY_NODE.INTERNALS->Kind == kDECL_EMPTY) {
  887.   if (unit->Kind == kBLOCK_DATA_DECL) {
  888. # line 613 "Semantic.puma"
  889.   {
  890. # line 614 "Semantic.puma"
  891.    simple_error_protocol ("statements in BLOCK_DATA not allowed");
  892.   }
  893.    return;
  894.  
  895.   }
  896.   }
  897.   if (unit->Kind == kBLOCK_DATA_DECL) {
  898. # line 617 "Semantic.puma"
  899.   {
  900. # line 618 "Semantic.puma"
  901.    simple_error_protocol ("internal subroutines in BLOCK_DATA not allowed");
  902.   }
  903.    return;
  904.  
  905.   }
  906.   }
  907. ;
  908. }
  909.  
  910. static void SemanticWhere
  911. # if defined __STDC__ | defined __cplusplus
  912. (register tTree t, register int whererank)
  913. # else
  914. (t, whererank)
  915.  register tTree t;
  916.  register int whererank;
  917. # endif
  918. {
  919. # line 632 "Semantic.puma"
  920.  
  921. char string[50];
  922.  
  923.   if (t->Kind == kACF_LIST) {
  924. # line 636 "Semantic.puma"
  925.   {
  926. # line 637 "Semantic.puma"
  927.    set_protocol_stmt (t->ACF_LIST.Elem);
  928. # line 638 "Semantic.puma"
  929.    SemanticWhere (t->ACF_LIST.Elem, whererank);
  930. # line 639 "Semantic.puma"
  931.    SemanticWhere (t->ACF_LIST.Next, whererank);
  932.   }
  933.    return;
  934.  
  935.   }
  936.   if (t->Kind == kACF_EMPTY) {
  937. # line 642 "Semantic.puma"
  938.    return;
  939.  
  940.   }
  941.   if (t->Kind == kACF_BASIC) {
  942.   if (t->ACF_BASIC.BASIC_STMT->Kind == kASSIGN_STMT) {
  943. # line 645 "Semantic.puma"
  944.  {
  945.   int rank_lhs;
  946.   int rank_rhs;
  947.   {
  948. # line 647 "Semantic.puma"
  949.  
  950. # line 648 "Semantic.puma"
  951.  
  952. # line 650 "Semantic.puma"
  953.    SemExp (t->ACF_BASIC.BASIC_STMT->ASSIGN_STMT.ASSIGN_VAR, & rank_lhs);
  954. # line 651 "Semantic.puma"
  955.    SemExp (t->ACF_BASIC.BASIC_STMT->ASSIGN_STMT.ASSIGN_EXP, & rank_rhs);
  956. # line 653 "Semantic.puma"
  957.  if (rank_lhs != whererank)
  958.       { error_protocol ("Assignment in WHERE has wrong rank");
  959.         sprintf (string, "Rank of LHS = %d : " , rank_lhs);
  960.         tree_protocol (string, t->ACF_BASIC.BASIC_STMT->ASSIGN_STMT.ASSIGN_VAR);
  961.         sprintf (string, "Rank of WHERE exp = %d : " , whererank);
  962.         tree_protocol (string, t->ACF_BASIC.BASIC_STMT->ASSIGN_STMT.ASSIGN_EXP);
  963.       }
  964.      if (rank_rhs > 0)
  965.       { if (rank_lhs != rank_rhs)
  966.          { error_protocol ("LHS and RHS have different rank");
  967.            sprintf (string, "Rank of LHS = %d : " , rank_lhs);
  968.            tree_protocol (string, t->ACF_BASIC.BASIC_STMT->ASSIGN_STMT.ASSIGN_VAR);
  969.            sprintf (string, "Rank of RHS = %d : " , rank_rhs);
  970.            tree_protocol (string, t->ACF_BASIC.BASIC_STMT->ASSIGN_STMT.ASSIGN_EXP);
  971.          }
  972.       }
  973.  
  974.   }
  975.    return;
  976.  }
  977.  
  978.   }
  979.   }
  980.   if (t->Kind == kACF_WHERE) {
  981. # line 672 "Semantic.puma"
  982.   {
  983. # line 673 "Semantic.puma"
  984.    error_protocol ("Nesting of WHERE not allowed until now");
  985.   }
  986.    return;
  987.  
  988.   }
  989. # line 676 "Semantic.puma"
  990.   {
  991. # line 677 "Semantic.puma"
  992.    error_protocol ("Illegal Statement in WHERE");
  993.   }
  994.    return;
  995.  
  996. ;
  997. }
  998.  
  999. static void SemanticForall
  1000. # if defined __STDC__ | defined __cplusplus
  1001. (register tTree t)
  1002. # else
  1003. (t)
  1004.  register tTree t;
  1005. # endif
  1006. {
  1007. # line 691 "Semantic.puma"
  1008.  
  1009. char string[50];
  1010. int i;
  1011.  
  1012.   if (t->Kind == kACF_LIST) {
  1013. # line 696 "Semantic.puma"
  1014.   {
  1015. # line 697 "Semantic.puma"
  1016.    set_protocol_stmt (t->ACF_LIST.Elem);
  1017. # line 698 "Semantic.puma"
  1018.    SemanticForall (t->ACF_LIST.Elem);
  1019. # line 699 "Semantic.puma"
  1020.    SemanticForall (t->ACF_LIST.Next);
  1021.   }
  1022.    return;
  1023.  
  1024.   }
  1025.   if (t->Kind == kACF_EMPTY) {
  1026. # line 702 "Semantic.puma"
  1027.    return;
  1028.  
  1029.   }
  1030.   if (t->Kind == kACF_BASIC) {
  1031.   if (t->ACF_BASIC.BASIC_STMT->Kind == kASSIGN_STMT) {
  1032. # line 705 "Semantic.puma"
  1033.  {
  1034.   int rank_lhs;
  1035.   int rank_rhs;
  1036.   {
  1037. # line 707 "Semantic.puma"
  1038.  
  1039. # line 708 "Semantic.puma"
  1040.  
  1041. # line 710 "Semantic.puma"
  1042.    SemExp (t->ACF_BASIC.BASIC_STMT->ASSIGN_STMT.ASSIGN_VAR, & rank_lhs);
  1043. # line 711 "Semantic.puma"
  1044.    SemExp (t->ACF_BASIC.BASIC_STMT->ASSIGN_STMT.ASSIGN_EXP, & rank_rhs);
  1045. # line 713 "Semantic.puma"
  1046.  if (rank_rhs > 0)
  1047.       { if (rank_lhs != rank_rhs)
  1048.          { error_protocol ("LHS and RHS have different rank");
  1049.            sprintf (string, "Rank of LHS = %d : " , rank_lhs);
  1050.            tree_protocol (string, t->ACF_BASIC.BASIC_STMT->ASSIGN_STMT.ASSIGN_VAR);
  1051.            sprintf (string, "Rank of RHS = %d : " , rank_rhs);
  1052.            tree_protocol (string, t->ACF_BASIC.BASIC_STMT->ASSIGN_STMT.ASSIGN_EXP);
  1053.          }
  1054.       }
  1055.  
  1056.  
  1057.  
  1058.      for (i=0; i<Nesting; i++)
  1059.         ForallLoopVarCheck (Nest[i], t->ACF_BASIC.BASIC_STMT->ASSIGN_STMT.ASSIGN_VAR);
  1060.  
  1061.   }
  1062.    return;
  1063.  }
  1064.  
  1065.   }
  1066.   }
  1067.   if (t->Kind == kACF_FORALL) {
  1068. # line 730 "Semantic.puma"
  1069.  {
  1070.   int rank;
  1071.   {
  1072. # line 732 "Semantic.puma"
  1073.  
  1074. # line 734 "Semantic.puma"
  1075.    SemExp (t->ACF_FORALL.FORALL_ID, & rank);
  1076. # line 735 "Semantic.puma"
  1077.    SemExp (t->ACF_FORALL.FORALL_RANGE, & rank);
  1078. # line 737 "Semantic.puma"
  1079.  if (Nesting >= MAXLoops)
  1080.        simple_error_protocol ("to deep do/forall loop nesting");
  1081.      else
  1082.        { Nest [Nesting] = t;
  1083.          Nesting += 1;
  1084.          SemanticForall (t->ACF_FORALL.FORALL_BODY);
  1085.          Nesting -= 1;
  1086.        }
  1087.  
  1088.   }
  1089.    return;
  1090.  }
  1091.  
  1092.   }
  1093.   if (t->Kind == kACF_WHERE) {
  1094. # line 749 "Semantic.puma"
  1095.  {
  1096.   int rank;
  1097.   {
  1098. # line 751 "Semantic.puma"
  1099.  
  1100. # line 753 "Semantic.puma"
  1101.    SemExp (t->ACF_WHERE.WHERE_EXP, & rank);
  1102. # line 755 "Semantic.puma"
  1103.    SemanticForall (t->ACF_WHERE.TRUE_PART);
  1104. # line 756 "Semantic.puma"
  1105.    SemanticForall (t->ACF_WHERE.FALSE_PART);
  1106.   }
  1107.    return;
  1108.  }
  1109.  
  1110.   }
  1111.   if (t->Kind == kACF_IF) {
  1112. # line 759 "Semantic.puma"
  1113.  {
  1114.   int rank;
  1115.   {
  1116. # line 761 "Semantic.puma"
  1117.  
  1118. # line 763 "Semantic.puma"
  1119.    SemExp (t->ACF_IF.IF_EXP, & rank);
  1120. # line 765 "Semantic.puma"
  1121.    SemanticForall (t->ACF_IF.THEN_PART);
  1122. # line 766 "Semantic.puma"
  1123.    SemanticForall (t->ACF_IF.ELSE_PART);
  1124.   }
  1125.    return;
  1126.  }
  1127.  
  1128.   }
  1129. # line 769 "Semantic.puma"
  1130.   {
  1131. # line 770 "Semantic.puma"
  1132.    error_protocol ("Illegal Statement in FORALL");
  1133.   }
  1134.    return;
  1135.  
  1136. ;
  1137. }
  1138.  
  1139. static void ForallLoopVarCheck
  1140. # if defined __STDC__ | defined __cplusplus
  1141. (register tTree loop, register tTree var)
  1142. # else
  1143. (loop, var)
  1144.  register tTree loop;
  1145.  register tTree var;
  1146. # endif
  1147. {
  1148.   if (loop->Kind == kACF_FORALL) {
  1149.   if (var->Kind == kUSED_VAR) {
  1150. # line 786 "Semantic.puma"
  1151.   {
  1152. # line 790 "Semantic.puma"
  1153.    error_protocol ("Only indexed variable in lhs of FORALL assignments");
  1154.   }
  1155.    return;
  1156.  
  1157.   }
  1158.   if (loop->ACF_FORALL.FORALL_ID->Kind == kLOOP_VAR) {
  1159.   if (var->Kind == kINDEXED_VAR) {
  1160. # line 793 "Semantic.puma"
  1161.   {
  1162. # line 798 "Semantic.puma"
  1163.  if (IsVarInExp (loop->ACF_FORALL.FORALL_ID->LOOP_VAR.LOOP_VARNAME->VAR_OBJ.Ident, var->INDEXED_VAR.IND_EXPS) == 0)
  1164.        { error_protocol ("loop index appears not in lhs in FORALL");
  1165.          tree_protocol  ("assignment variable is ", var);
  1166.          tree_protocol  ("loop variable is ", loop->ACF_FORALL.FORALL_ID);
  1167.        }
  1168.  
  1169.   }
  1170.    return;
  1171.  
  1172.   }
  1173.   }
  1174.   }
  1175. ;
  1176. }
  1177.  
  1178. static void SemanticIO
  1179. # if defined __STDC__ | defined __cplusplus
  1180. (register tTree t)
  1181. # else
  1182. (t)
  1183.  register tTree t;
  1184. # endif
  1185. {
  1186. # line 814 "Semantic.puma"
  1187.  
  1188. char string[256];
  1189. tObject Obj;
  1190. int dist;
  1191.  
  1192.   if (t->Kind == kIO_STMT) {
  1193.   if (equaltIdent (t->IO_STMT.ID->PROC_OBJ.Ident, MakeIdent ("PRINT", 5))) {
  1194. # line 820 "Semantic.puma"
  1195.   {
  1196. # line 821 "Semantic.puma"
  1197.    SemParamList (t->IO_STMT.IO_ITEMS);
  1198.   }
  1199.    return;
  1200.  
  1201.   }
  1202.   if (equaltIdent (t->IO_STMT.ID->PROC_OBJ.Ident, MakeIdent ("READ", 4))) {
  1203. # line 824 "Semantic.puma"
  1204.   {
  1205. # line 825 "Semantic.puma"
  1206.    SemParamList (t->IO_STMT.IO_ITEMS);
  1207. # line 826 "Semantic.puma"
  1208.    SemReadParams (t->IO_STMT.IO_ITEMS);
  1209.   }
  1210.    return;
  1211.  
  1212.   }
  1213.   if (equaltIdent (t->IO_STMT.ID->PROC_OBJ.Ident, MakeIdent ("WRITE", 5))) {
  1214. # line 829 "Semantic.puma"
  1215.   {
  1216. # line 830 "Semantic.puma"
  1217.    SemParamList (t->IO_STMT.IO_ITEMS);
  1218.   }
  1219.    return;
  1220.  
  1221.   }
  1222.   if (equaltIdent (t->IO_STMT.ID->PROC_OBJ.Ident, MakeIdent ("OPEN", 4))) {
  1223. # line 833 "Semantic.puma"
  1224.    return;
  1225.  
  1226.   }
  1227.   if (equaltIdent (t->IO_STMT.ID->PROC_OBJ.Ident, MakeIdent ("CLOSE", 5))) {
  1228. # line 836 "Semantic.puma"
  1229.    return;
  1230.  
  1231.   }
  1232.   if (equaltIdent (t->IO_STMT.ID->PROC_OBJ.Ident, MakeIdent ("REWIND", 6))) {
  1233. # line 839 "Semantic.puma"
  1234.    return;
  1235.  
  1236.   }
  1237.   if (equaltIdent (t->IO_STMT.ID->PROC_OBJ.Ident, MakeIdent ("BACKSPACE", 9))) {
  1238. # line 842 "Semantic.puma"
  1239.    return;
  1240.  
  1241.   }
  1242.   if (equaltIdent (t->IO_STMT.ID->PROC_OBJ.Ident, MakeIdent ("INQUIRE", 7))) {
  1243. # line 845 "Semantic.puma"
  1244.    return;
  1245.  
  1246.   }
  1247.   if (equaltIdent (t->IO_STMT.ID->PROC_OBJ.Ident, MakeIdent ("ENDFILE", 7))) {
  1248. # line 848 "Semantic.puma"
  1249.    return;
  1250.  
  1251.   }
  1252. # line 851 "Semantic.puma"
  1253.   {
  1254. # line 852 "Semantic.puma"
  1255.    GetString (t->IO_STMT.ID->PROC_OBJ.Ident, string);
  1256. # line 853 "Semantic.puma"
  1257.  printf ("%s in I/O\n",string);
  1258.           error_protocol ("Unknown name in I/O");
  1259.  
  1260.   }
  1261.    return;
  1262.  
  1263.   }
  1264.   if (t->Kind == kBTP_LIST) {
  1265. # line 858 "Semantic.puma"
  1266.   {
  1267. # line 859 "Semantic.puma"
  1268.    SemanticIO (t->BTP_LIST.Elem);
  1269. # line 860 "Semantic.puma"
  1270.    SemanticIO (t->BTP_LIST.Next);
  1271.   }
  1272.    return;
  1273.  
  1274.   }
  1275.   if (t->Kind == kBTP_EMPTY) {
  1276. # line 863 "Semantic.puma"
  1277.    return;
  1278.  
  1279.   }
  1280.   if (t->Kind == kVAR_PARAM) {
  1281. # line 866 "Semantic.puma"
  1282.    return;
  1283.  
  1284.   }
  1285. # line 869 "Semantic.puma"
  1286.   {
  1287. # line 870 "Semantic.puma"
  1288.    printf ("Unknown Tree Node for Semantic Analysis of IO \n");
  1289. # line 871 "Semantic.puma"
  1290.    WriteTreeNode (stdout, t);
  1291. # line 872 "Semantic.puma"
  1292.    kill_in_protocol ();
  1293.   }
  1294.    return;
  1295.  
  1296. ;
  1297. }
  1298.  
  1299. static void SemReadParams
  1300. # if defined __STDC__ | defined __cplusplus
  1301. (register tTree items)
  1302. # else
  1303. (items)
  1304.  register tTree items;
  1305. # endif
  1306. {
  1307.   if (items->Kind == kBTP_LIST) {
  1308. # line 883 "Semantic.puma"
  1309.   {
  1310. # line 884 "Semantic.puma"
  1311.    SemReadParams (items->BTP_LIST.Elem);
  1312. # line 885 "Semantic.puma"
  1313.    SemReadParams (items->BTP_LIST.Next);
  1314.   }
  1315.    return;
  1316.  
  1317.   }
  1318.   if (items->Kind == kBTP_EMPTY) {
  1319. # line 888 "Semantic.puma"
  1320.    return;
  1321.  
  1322.   }
  1323.   if (items->Kind == kVAR_PARAM) {
  1324.   if (items->VAR_PARAM.V->Kind == kUSED_VAR) {
  1325. # line 891 "Semantic.puma"
  1326.    return;
  1327.  
  1328.   }
  1329.   if (items->VAR_PARAM.V->Kind == kINDEXED_VAR) {
  1330. # line 895 "Semantic.puma"
  1331.    return;
  1332.  
  1333.   }
  1334.   if (items->VAR_PARAM.V->Kind == kADDR) {
  1335.   if (items->VAR_PARAM.V->ADDR.E->Kind == kDO_EXP) {
  1336. # line 899 "Semantic.puma"
  1337.   {
  1338. # line 901 "Semantic.puma"
  1339.  items->VAR_PARAM.V = MakeDoVar (items->VAR_PARAM.V->ADDR.E);
  1340.   }
  1341.    return;
  1342.  
  1343.   }
  1344. # line 904 "Semantic.puma"
  1345.   {
  1346. # line 905 "Semantic.puma"
  1347.    error_protocol ("Illegal READ parameter");
  1348. # line 906 "Semantic.puma"
  1349.    tree_protocol ("Parameter is ", items);
  1350.   }
  1351.    return;
  1352.  
  1353.   }
  1354.   }
  1355. # line 909 "Semantic.puma"
  1356.   {
  1357. # line 910 "Semantic.puma"
  1358.    error_protocol ("Cannot handle this READ parameter");
  1359. # line 911 "Semantic.puma"
  1360.    tree_protocol ("Parameter is ", items);
  1361.   }
  1362.    return;
  1363.  
  1364. ;
  1365. }
  1366.  
  1367. static tTree MakeDoVar
  1368. # if defined __STDC__ | defined __cplusplus
  1369. (register tTree DoExp)
  1370. # else
  1371. (DoExp)
  1372.  register tTree DoExp;
  1373. # endif
  1374. {
  1375.   if (DoExp->Kind == kDO_EXP) {
  1376. # line 916 "Semantic.puma"
  1377.    return mDO_VAR (DoExp->DO_EXP.DO_ID, DoExp->DO_EXP.RANGE, MakeDoVar (DoExp->DO_EXP.BODY));
  1378.  
  1379.   }
  1380.   if (DoExp->Kind == kBTE_LIST) {
  1381.   if (DoExp->BTE_LIST.Elem->Kind == kVAR_EXP) {
  1382. # line 920 "Semantic.puma"
  1383.    return mBTV_LIST (DoExp->BTE_LIST.Elem->VAR_EXP.V, MakeDoVar (DoExp->BTE_LIST.Next));
  1384.  
  1385.   }
  1386.   if (DoExp->BTE_LIST.Elem->Kind == kDO_EXP) {
  1387. # line 925 "Semantic.puma"
  1388.    return mBTV_LIST (MakeDoVar (DoExp->BTE_LIST.Elem), MakeDoVar (DoExp->BTE_LIST.Next));
  1389.  
  1390.   }
  1391. # line 929 "Semantic.puma"
  1392.   {
  1393. # line 931 "Semantic.puma"
  1394.    error_protocol ("Illegal READ parameter in DO_EXP");
  1395. # line 932 "Semantic.puma"
  1396.    tree_protocol ("Expression is : ", DoExp->BTE_LIST.Elem);
  1397.   }
  1398.    return mBTV_LIST (mADDR (DoExp->BTE_LIST.Elem), MakeDoVar (DoExp->BTE_LIST.Next));
  1399.  
  1400.   }
  1401.   if (DoExp->Kind == kBTE_EMPTY) {
  1402. # line 936 "Semantic.puma"
  1403.    return mBTV_EMPTY ();
  1404.  
  1405.   }
  1406.  yyAbort ("MakeDoVar");
  1407. }
  1408.  
  1409. void SemanticCall
  1410. # if defined __STDC__ | defined __cplusplus
  1411. (register tTree t, register tDefinitions p)
  1412. # else
  1413. (t, p)
  1414.  register tTree t;
  1415.  register tDefinitions p;
  1416. # endif
  1417. {
  1418.   if (t->Kind == kCALL_STMT) {
  1419.   if (Definitions_IsType (t->CALL_STMT.CALL_ID->PROC_OBJ.Object, kObject)) {
  1420.   if (p->Kind == kProcObject) {
  1421.   if (p->ProcObject.decl->Kind == kPROC_DECL) {
  1422. # line 954 "Semantic.puma"
  1423.   {
  1424. # line 957 "Semantic.puma"
  1425.  
  1426.      if (TreeListLength (t->CALL_STMT.CALL_PARAMS) != TreeListLength (p->ProcObject.decl->PROC_DECL.FORMALS))
  1427.        { error_protocol ("Number of parameters mismatch");
  1428.          tree_protocol  ("formals : ", p->ProcObject.decl->PROC_DECL.FORMALS);
  1429.        }
  1430.       else
  1431.          SemanticCallParams (t->CALL_STMT.CALL_PARAMS, p->ProcObject.decl->PROC_DECL.FORMALS, p->ProcObject.Declarations);
  1432.  
  1433.   }
  1434.    return;
  1435.  
  1436.   }
  1437.   if (p->ProcObject.decl->Kind == kPROC_PARAM_DECL) {
  1438. # line 973 "Semantic.puma"
  1439.   {
  1440. # line 976 "Semantic.puma"
  1441.    SemParamList (t->CALL_STMT.CALL_PARAMS);
  1442.   }
  1443.    return;
  1444.  
  1445.   }
  1446.   if (p->ProcObject.decl->Kind == kEXT_PROC_DECL) {
  1447. # line 985 "Semantic.puma"
  1448.   {
  1449. # line 988 "Semantic.puma"
  1450.    SemParamList (t->CALL_STMT.CALL_PARAMS);
  1451.   }
  1452.    return;
  1453.  
  1454.   }
  1455.   }
  1456.   }
  1457.   }
  1458.   if (t->Kind == kFUNC_CALL_EXP) {
  1459.   if (Definitions_IsType (t->FUNC_CALL_EXP.FUNC_ID->PROC_OBJ.Object, kObject)) {
  1460.   if (p->Kind == kFuncObject) {
  1461.   if (p->FuncObject.decl->Kind == kFUNC_DECL) {
  1462. # line 997 "Semantic.puma"
  1463.   {
  1464. # line 1000 "Semantic.puma"
  1465.  
  1466.      if (TreeListLength (t->FUNC_CALL_EXP.FUNC_PARAMS) != TreeListLength (p->FuncObject.decl->FUNC_DECL.FORMALS))
  1467.        { error_protocol ("Number of parameters mismatch");
  1468.          tree_protocol ("formals : ", p->FuncObject.decl->FUNC_DECL.FORMALS);
  1469.        }
  1470.       else
  1471.          SemanticCallParams (t->FUNC_CALL_EXP.FUNC_PARAMS, p->FuncObject.decl->FUNC_DECL.FORMALS, p->FuncObject.Declarations);
  1472.  
  1473.   }
  1474.    return;
  1475.  
  1476.   }
  1477.   if (p->FuncObject.decl->Kind == kSTMT_FUNC_DECL) {
  1478. # line 1016 "Semantic.puma"
  1479.   {
  1480. # line 1019 "Semantic.puma"
  1481.  
  1482.      if (TreeListLength (t->FUNC_CALL_EXP.FUNC_PARAMS) != TreeListLength (p->FuncObject.decl->STMT_FUNC_DECL.FORMALS))
  1483.        { error_protocol ("Number of parameters mismatch");
  1484.          tree_protocol ("formals : ", p->FuncObject.decl->STMT_FUNC_DECL.FORMALS);
  1485.        }
  1486.       else
  1487.        SemParamList (t->FUNC_CALL_EXP.FUNC_PARAMS);
  1488.  
  1489.   }
  1490.    return;
  1491.  
  1492.   }
  1493.   if (p->FuncObject.decl->Kind == kEXT_FUNC_DECL) {
  1494. # line 1035 "Semantic.puma"
  1495.   {
  1496. # line 1037 "Semantic.puma"
  1497.    SemParamList (t->FUNC_CALL_EXP.FUNC_PARAMS);
  1498.   }
  1499.    return;
  1500.  
  1501.   }
  1502.   if (p->FuncObject.decl->Kind == kFUNC_PARAM_DECL) {
  1503. # line 1046 "Semantic.puma"
  1504.   {
  1505. # line 1048 "Semantic.puma"
  1506.    SemParamList (t->FUNC_CALL_EXP.FUNC_PARAMS);
  1507.   }
  1508.    return;
  1509.  
  1510.   }
  1511.   }
  1512.   }
  1513.   }
  1514. # line 1051 "Semantic.puma"
  1515.   {
  1516. # line 1052 "Semantic.puma"
  1517.    printf ("Illegal Tree in SemanticCall\n");
  1518. # line 1053 "Semantic.puma"
  1519.    FileUnparse (stdout, t);
  1520. # line 1054 "Semantic.puma"
  1521.    kill_in_protocol ();
  1522.   }
  1523.    return;
  1524.  
  1525. ;
  1526. }
  1527.  
  1528. static void SemanticCallParams
  1529. # if defined __STDC__ | defined __cplusplus
  1530. (register tTree a, register tTree f, register tDefinitions d)
  1531. # else
  1532. (a, f, d)
  1533.  register tTree a;
  1534.  register tTree f;
  1535.  register tDefinitions d;
  1536. # endif
  1537. {
  1538.   if (a->Kind == kBTP_LIST) {
  1539.   if (f->Kind == kDECL_LIST) {
  1540.   if (f->DECL_LIST.Elem->Kind == kVAR_PARAM_DECL) {
  1541. # line 1065 "Semantic.puma"
  1542.  {
  1543.   tDefinitions Obj;
  1544.   {
  1545. # line 1068 "Semantic.puma"
  1546.  
  1547. # line 1070 "Semantic.puma"
  1548.    Obj = GetDeclEntry (f->DECL_LIST.Elem->VAR_PARAM_DECL.Name, d);
  1549. # line 1073 "Semantic.puma"
  1550.    SemanticMatchParam (a->BTP_LIST.Elem, Obj);
  1551. # line 1074 "Semantic.puma"
  1552.    SemanticCallParams (a->BTP_LIST.Next, f->DECL_LIST.Next, d);
  1553.   }
  1554.    return;
  1555.  }
  1556.  
  1557.   }
  1558.   }
  1559.   }
  1560.   if (a->Kind == kBTP_EMPTY) {
  1561.   if (f->Kind == kDECL_EMPTY) {
  1562. # line 1077 "Semantic.puma"
  1563.    return;
  1564.  
  1565.   }
  1566.   }
  1567. # line 1080 "Semantic.puma"
  1568.   {
  1569. # line 1081 "Semantic.puma"
  1570.    printf ("Cannot compare actual and formal parameters");
  1571. # line 1082 "Semantic.puma"
  1572.    kill_in_protocol ();
  1573.   }
  1574.    return;
  1575.  
  1576. ;
  1577. }
  1578.  
  1579. static void SemanticMatchParam
  1580. # if defined __STDC__ | defined __cplusplus
  1581. (register tTree actual, register tDefinitions formal)
  1582. # else
  1583. (actual, formal)
  1584.  register tTree actual;
  1585.  register tDefinitions formal;
  1586. # endif
  1587. {
  1588. # line 1093 "Semantic.puma"
  1589.  
  1590. char msg[100];
  1591.  
  1592.   if (actual->Kind == kVAR_PARAM) {
  1593. # line 1097 "Semantic.puma"
  1594.  {
  1595.   int rank;
  1596.   {
  1597. # line 1099 "Semantic.puma"
  1598.  
  1599. # line 1101 "Semantic.puma"
  1600.    SemExp (actual->VAR_PARAM.V, & rank);
  1601. # line 1103 "Semantic.puma"
  1602.  if (VarRank (formal) != rank)
  1603.         {
  1604.           if (TreeDistribution (actual) > 0)
  1605.            { error_protocol ("rank mismatch of actual and formal parameter");
  1606.              sprintf (msg, "Rank of actual parameter = %d : ", rank);
  1607.              tree_protocol (msg, actual);
  1608.              sprintf (msg, "Rank of formal parameter = %d : ", VarRank(formal));
  1609.              obj_protocol (msg, formal);
  1610.            }
  1611.           else
  1612.            { sprintf (msg, "Rank mismatch of actual parameter = %d : ", rank);
  1613.              tree_warning_protocol (msg, actual);
  1614.              sprintf (msg, "Rank of formal parameter = %d : ", VarRank(formal));
  1615.              simple_warning_protocol (msg);
  1616.            }
  1617.         }
  1618.  
  1619.   }
  1620.    return;
  1621.  }
  1622.  
  1623.   }
  1624.   if (actual->Kind == kFUNC_PARAM) {
  1625. # line 1122 "Semantic.puma"
  1626.    return;
  1627.  
  1628.   }
  1629.   if (actual->Kind == kPROC_PARAM) {
  1630. # line 1125 "Semantic.puma"
  1631.    return;
  1632.  
  1633.   }
  1634. # line 1128 "Semantic.puma"
  1635.   {
  1636. # line 1129 "Semantic.puma"
  1637.    printf ("SemanticMatchParam fails\n");
  1638. # line 1130 "Semantic.puma"
  1639.    FileUnparse (stdout, actual);
  1640. # line 1131 "Semantic.puma"
  1641.    kill_in_protocol ();
  1642.   }
  1643.    return;
  1644.  
  1645. ;
  1646. }
  1647.  
  1648. static void AnalIntrinsicSubroutine
  1649. # if defined __STDC__ | defined __cplusplus
  1650. (register tIdent name, register tTree params)
  1651. # else
  1652. (name, params)
  1653.  register tIdent name;
  1654.  register tTree params;
  1655. # endif
  1656. {
  1657.   if (equaltIdent (name, MakeIdent ("CMF_RANDOM", 10))) {
  1658. # line 1142 "Semantic.puma"
  1659.   {
  1660. # line 1143 "Semantic.puma"
  1661.  
  1662.       CheckRandomParams (params);
  1663.  
  1664.   }
  1665.    return;
  1666.  
  1667.   }
  1668.   if (equaltIdent (name, MakeIdent ("CMF_RANDOMIZE", 13))) {
  1669. # line 1148 "Semantic.puma"
  1670.   {
  1671. # line 1150 "Semantic.puma"
  1672.    CheckRandomizeParams (params);
  1673.   }
  1674.    return;
  1675.  
  1676.   }
  1677.   if (equaltIdent (name, MakeIdent ("WALLTIME", 8))) {
  1678. # line 1153 "Semantic.puma"
  1679.   {
  1680. # line 1155 "Semantic.puma"
  1681.    CheckWalltimeParams (params);
  1682.   }
  1683.    return;
  1684.  
  1685.   }
  1686.   if (equaltIdent (name, MakeIdent ("CM_TIMER_CLEAR", 14))) {
  1687. # line 1158 "Semantic.puma"
  1688.   {
  1689. # line 1159 "Semantic.puma"
  1690.    CheckTimerParams (params);
  1691.   }
  1692.    return;
  1693.  
  1694.   }
  1695.   if (equaltIdent (name, MakeIdent ("CM_TIMER_PRINT", 14))) {
  1696. # line 1162 "Semantic.puma"
  1697.   {
  1698. # line 1163 "Semantic.puma"
  1699.    CheckTimerParams (params);
  1700.   }
  1701.    return;
  1702.  
  1703.   }
  1704.   if (equaltIdent (name, MakeIdent ("CM_TIMER_START", 14))) {
  1705. # line 1166 "Semantic.puma"
  1706.   {
  1707. # line 1167 "Semantic.puma"
  1708.    CheckTimerParams (params);
  1709.   }
  1710.    return;
  1711.  
  1712.   }
  1713.   if (equaltIdent (name, MakeIdent ("CM_TIMER_STOP", 13))) {
  1714. # line 1170 "Semantic.puma"
  1715.   {
  1716. # line 1171 "Semantic.puma"
  1717.    CheckTimerParams (params);
  1718.   }
  1719.    return;
  1720.  
  1721.   }
  1722.   if (equaltIdent (name, MakeIdent ("GLOBAL_GET", 10))) {
  1723. # line 1174 "Semantic.puma"
  1724.   {
  1725. # line 1176 "Semantic.puma"
  1726.    CheckGlobalGetParams (params);
  1727.   }
  1728.    return;
  1729.  
  1730.   }
  1731.   if (equaltIdent (name, MakeIdent ("GLOBAL_SEND", 11))) {
  1732. # line 1179 "Semantic.puma"
  1733.   {
  1734. # line 1181 "Semantic.puma"
  1735.    CheckGlobalSendParams (params);
  1736.   }
  1737.    return;
  1738.  
  1739.   }
  1740. # line 1184 "Semantic.puma"
  1741.   {
  1742. # line 1185 "Semantic.puma"
  1743.    error_protocol ("Unknown intrinsic Subroutine in Analysis");
  1744.   }
  1745.    return;
  1746.  
  1747. ;
  1748. }
  1749.  
  1750. static void CheckReduceParams
  1751. # if defined __STDC__ | defined __cplusplus
  1752. (register tTree t)
  1753. # else
  1754. (t)
  1755.  register tTree t;
  1756. # endif
  1757. {
  1758.   if (t->Kind == kBTP_EMPTY) {
  1759. # line 1198 "Semantic.puma"
  1760.    return;
  1761.  
  1762.   }
  1763.   if (t->Kind == kBTP_LIST) {
  1764.   if (t->BTP_LIST.Next->Kind == kBTP_LIST) {
  1765. # line 1201 "Semantic.puma"
  1766.   {
  1767. # line 1202 "Semantic.puma"
  1768.  if (!IsVarParameter (t->BTP_LIST.Elem))
  1769.        { error_protocol ("Variable required for reduce");
  1770.          tree_protocol ("This parameter is not a variable : ", t->BTP_LIST.Elem);
  1771.        }
  1772.  
  1773. # line 1207 "Semantic.puma"
  1774.    CheckReduceParams (t->BTP_LIST.Next->BTP_LIST.Next);
  1775.   }
  1776.    return;
  1777.  
  1778.   }
  1779.   }
  1780. # line 1210 "Semantic.puma"
  1781.   {
  1782. # line 1211 "Semantic.puma"
  1783.    error_protocol ("Illegal parameter list for REDUCE");
  1784. # line 1212 "Semantic.puma"
  1785.    print_protocol ("REDUCE (f, var, exp, var, exp, ..., var, exp)");
  1786.   }
  1787.    return;
  1788.  
  1789. ;
  1790. }
  1791.  
  1792. static void CheckRandomParams
  1793. # if defined __STDC__ | defined __cplusplus
  1794. (register tTree t)
  1795. # else
  1796. (t)
  1797.  register tTree t;
  1798. # endif
  1799. {
  1800.   if (t->Kind == kBTP_EMPTY) {
  1801. # line 1226 "Semantic.puma"
  1802.   {
  1803. # line 1227 "Semantic.puma"
  1804.    error_protocol ("CMF_RANDOM needs on or two parameters");
  1805.   }
  1806.    return;
  1807.  
  1808.   }
  1809.   if (t->Kind == kBTP_LIST) {
  1810. # line 1230 "Semantic.puma"
  1811.   {
  1812. # line 1231 "Semantic.puma"
  1813.    if (! ((! IsVarParameter (t->BTP_LIST.Elem)))) goto yyL2;
  1814.   {
  1815. # line 1232 "Semantic.puma"
  1816.    error_protocol ("CMF_RANDOM: first parameter must be variable");
  1817.   }
  1818.   }
  1819.    return;
  1820. yyL2:;
  1821.  
  1822.   if (t->BTP_LIST.Elem->Kind == kVAR_PARAM) {
  1823.   if (t->BTP_LIST.Next->Kind == kBTP_EMPTY) {
  1824. # line 1235 "Semantic.puma"
  1825.   {
  1826. # line 1236 "Semantic.puma"
  1827.    CheckRandomTypes (TreeType (t->BTP_LIST.Elem->VAR_PARAM.V), NoTree);
  1828.   }
  1829.    return;
  1830.  
  1831.   }
  1832.   if (t->BTP_LIST.Next->Kind == kBTP_LIST) {
  1833.   if (t->BTP_LIST.Next->BTP_LIST.Elem->Kind == kVAR_PARAM) {
  1834.   if (t->BTP_LIST.Next->BTP_LIST.Next->Kind == kBTP_EMPTY) {
  1835. # line 1239 "Semantic.puma"
  1836.  {
  1837.   int rank;
  1838.   {
  1839. # line 1241 "Semantic.puma"
  1840.  
  1841. # line 1243 "Semantic.puma"
  1842.    SemExp (t->BTP_LIST.Next->BTP_LIST.Elem->VAR_PARAM.V, & rank);
  1843. # line 1245 "Semantic.puma"
  1844.  if (rank != 0)
  1845.        error_protocol ("Second Parameter of CMF_RANDOM must be a scalar");
  1846.  
  1847. # line 1248 "Semantic.puma"
  1848.    CheckRandomTypes (TreeType (t->BTP_LIST.Elem->VAR_PARAM.V), t->BTP_LIST.Next->BTP_LIST.Elem->VAR_PARAM.V);
  1849.   }
  1850.    return;
  1851.  }
  1852.  
  1853.   }
  1854.   }
  1855.   }
  1856.   }
  1857.   }
  1858. # line 1251 "Semantic.puma"
  1859.   {
  1860. # line 1252 "Semantic.puma"
  1861.    error_protocol ("Illegal parameter list for CMF_RANDOM");
  1862.   }
  1863.    return;
  1864.  
  1865. ;
  1866. }
  1867.  
  1868. static void CheckRandomTypes
  1869. # if defined __STDC__ | defined __cplusplus
  1870. (register tTree type, register tTree limit)
  1871. # else
  1872. (type, limit)
  1873.  register tTree type;
  1874.  register tTree limit;
  1875. # endif
  1876. {
  1877.   if (type->Kind == kREAL_TYPE) {
  1878.   if (equalint (type->REAL_TYPE.size, 4)) {
  1879. # line 1258 "Semantic.puma"
  1880.    return;
  1881.  
  1882.   }
  1883.   if (equalint (type->REAL_TYPE.size, 8)) {
  1884. # line 1261 "Semantic.puma"
  1885.    return;
  1886.  
  1887.   }
  1888. # line 1264 "Semantic.puma"
  1889.   {
  1890. # line 1265 "Semantic.puma"
  1891.    error_protocol ("CMF_RANDOM: real, but not real*4 or real*8");
  1892.   }
  1893.    return;
  1894.  
  1895.   }
  1896.   if (type->Kind == kINTEGER_TYPE) {
  1897.   if (equalint (type->INTEGER_TYPE.size, 4)) {
  1898. # line 1268 "Semantic.puma"
  1899.   {
  1900. # line 1269 "Semantic.puma"
  1901.  if (limit == NoTree)
  1902.         error_protocol ("CMF_RANDOM: integer array requires limit parameter");
  1903.  
  1904.   }
  1905.    return;
  1906.  
  1907.   }
  1908. # line 1274 "Semantic.puma"
  1909.   {
  1910. # line 1275 "Semantic.puma"
  1911.    error_protocol ("CMF_RANDOM: integer, but not integer*4");
  1912.   }
  1913.    return;
  1914.  
  1915.   }
  1916. # line 1278 "Semantic.puma"
  1917.   {
  1918. # line 1279 "Semantic.puma"
  1919.    error_protocol ("CMF_RANDOM: first parameter must be real or integer");
  1920.   }
  1921.    return;
  1922.  
  1923. ;
  1924. }
  1925.  
  1926. static void CheckRandomizeParams
  1927. # if defined __STDC__ | defined __cplusplus
  1928. (register tTree t)
  1929. # else
  1930. (t)
  1931.  register tTree t;
  1932. # endif
  1933. {
  1934.   if (t->Kind == kBTP_LIST) {
  1935.   if (t->BTP_LIST.Elem->Kind == kVAR_PARAM) {
  1936.   if (t->BTP_LIST.Next->Kind == kBTP_EMPTY) {
  1937. # line 1290 "Semantic.puma"
  1938.  {
  1939.   int rank;
  1940.   {
  1941. # line 1292 "Semantic.puma"
  1942.  
  1943. # line 1294 "Semantic.puma"
  1944.    SemExp (t->BTP_LIST.Elem, & rank);
  1945. # line 1296 "Semantic.puma"
  1946.  if (rank != 0)
  1947.        error_protocol ("Randomize Parameter must be a scalar");
  1948.  
  1949.   }
  1950.    return;
  1951.  }
  1952.  
  1953.   }
  1954.   }
  1955.   }
  1956. # line 1301 "Semantic.puma"
  1957.   {
  1958. # line 1302 "Semantic.puma"
  1959.    error_protocol ("CMF_RANDOMIZE requires one integer parameter");
  1960.   }
  1961.    return;
  1962.  
  1963. ;
  1964. }
  1965.  
  1966. static void CheckWalltimeParams
  1967. # if defined __STDC__ | defined __cplusplus
  1968. (register tTree t)
  1969. # else
  1970. (t)
  1971.  register tTree t;
  1972. # endif
  1973. {
  1974.   if (t->Kind == kBTP_LIST) {
  1975.   if (t->BTP_LIST.Elem->Kind == kVAR_PARAM) {
  1976.   if (t->BTP_LIST.Next->Kind == kBTP_EMPTY) {
  1977. # line 1313 "Semantic.puma"
  1978.  {
  1979.   int rank;
  1980.   tTree type;
  1981.   {
  1982. # line 1315 "Semantic.puma"
  1983.  
  1984. # line 1316 "Semantic.puma"
  1985.  
  1986. # line 1318 "Semantic.puma"
  1987.  if (!IsVarParameter (t->BTP_LIST.Elem))
  1988.         error_protocol ("WALLTIME: requires REAL*4 variable");
  1989.      else
  1990.         {
  1991.           type = TreeType (t->BTP_LIST.Elem->VAR_PARAM.V);
  1992.           if (type->Kind != kREAL_TYPE)
  1993.              error_protocol ("walltime: parameter must be REAL");
  1994.           else if (type->REAL_TYPE.size != 4)
  1995.              error_protocol ("walltime: parameter must be REAL*4");
  1996.         }
  1997.  
  1998.     SemExp (t->BTP_LIST.Elem, &rank);
  1999.  
  2000.      if (rank != 0)
  2001.        error_protocol ("Walltime Parameter must be a scalar");
  2002.  
  2003.   }
  2004.    return;
  2005.  }
  2006.  
  2007.   }
  2008.   }
  2009.   }
  2010. # line 1336 "Semantic.puma"
  2011.   {
  2012. # line 1337 "Semantic.puma"
  2013.    error_protocol ("Walltime: exactly one parameter is required");
  2014.   }
  2015.    return;
  2016.  
  2017. ;
  2018. }
  2019.  
  2020. static void CheckTimerParams
  2021. # if defined __STDC__ | defined __cplusplus
  2022. (register tTree t)
  2023. # else
  2024. (t)
  2025.  register tTree t;
  2026. # endif
  2027. {
  2028.   if (t->Kind == kBTP_LIST) {
  2029.   if (t->BTP_LIST.Elem->Kind == kVAR_PARAM) {
  2030.   if (t->BTP_LIST.Next->Kind == kBTP_EMPTY) {
  2031. # line 1348 "Semantic.puma"
  2032.  {
  2033.   int rank;
  2034.   {
  2035. # line 1350 "Semantic.puma"
  2036.  
  2037. # line 1352 "Semantic.puma"
  2038.    SemExp (t->BTP_LIST.Elem, & rank);
  2039. # line 1354 "Semantic.puma"
  2040.  if (rank != 0)
  2041.        error_protocol ("Timer Parameter must be a scalar");
  2042.  
  2043.   }
  2044.    return;
  2045.  }
  2046.  
  2047.   }
  2048.   }
  2049.   }
  2050. # line 1359 "Semantic.puma"
  2051.   {
  2052. # line 1360 "Semantic.puma"
  2053.    error_protocol ("CM_TIMER_... requires one integer parameter");
  2054.   }
  2055.    return;
  2056.  
  2057. ;
  2058. }
  2059.  
  2060. static void CheckAllocateParams
  2061. # if defined __STDC__ | defined __cplusplus
  2062. (register tTree t)
  2063. # else
  2064. (t)
  2065.  register tTree t;
  2066. # endif
  2067. {
  2068.   if (t->Kind == kBTP_LIST) {
  2069.   if (t->BTP_LIST.Elem->Kind == kVAR_PARAM) {
  2070.   if (t->BTP_LIST.Elem->VAR_PARAM.V->Kind == kINDEXED_VAR) {
  2071.   if (t->BTP_LIST.Elem->VAR_PARAM.V->INDEXED_VAR.IND_VAR->Kind == kUSED_VAR) {
  2072. # line 1373 "Semantic.puma"
  2073.   {
  2074. # line 1376 "Semantic.puma"
  2075.  if (TreeRank (t->BTP_LIST.Elem->VAR_PARAM.V->INDEXED_VAR.IND_VAR) != TreeListLength (t->BTP_LIST.Elem->VAR_PARAM.V->INDEXED_VAR.IND_EXPS))
  2076.       { error_protocol ("Illegal dimensioned parameter in ALLOCATE");
  2077.         tree_protocol ("wrong parameter is ", t->BTP_LIST.Elem->VAR_PARAM.V);
  2078.       }
  2079.      else if (!IsVarAllocatable (t->BTP_LIST.Elem->VAR_PARAM.V->INDEXED_VAR.IND_VAR->USED_VAR.VARNAME->VAR_OBJ.Object))
  2080.       { error_protocol ("Not allocatable parameter in ALLOCATE");
  2081.         tree_protocol ("wrong parameter is ", t->BTP_LIST.Elem->VAR_PARAM.V);
  2082.       }
  2083.      else if (IsAllocated (t->BTP_LIST.Elem->VAR_PARAM.V->INDEXED_VAR.IND_VAR->USED_VAR.VARNAME->VAR_OBJ.Ident))
  2084.       { error_protocol ("Allocatable array has already been allocated");
  2085.         tree_protocol ("wrong parameter is ", t->BTP_LIST.Elem->VAR_PARAM.V);
  2086.       }
  2087.      else
  2088.       {
  2089.         if (allocate_top == MAX_ALLOCATES)
  2090.            { error_protocol ("too many allocates");
  2091.              kill_in_protocol ();
  2092.            }
  2093.         allocate_stack [allocate_top] = t->BTP_LIST.Elem->VAR_PARAM.V->INDEXED_VAR.IND_VAR->USED_VAR.VARNAME->VAR_OBJ.Ident;
  2094.         allocate_top += 1;
  2095.         NormalAllocateParams (t->BTP_LIST.Elem->VAR_PARAM.V->INDEXED_VAR.IND_EXPS);
  2096.       }
  2097.  
  2098. # line 1399 "Semantic.puma"
  2099.    CheckAllocateParams (t->BTP_LIST.Next);
  2100.   }
  2101.    return;
  2102.  
  2103.   }
  2104.   }
  2105.   }
  2106. # line 1402 "Semantic.puma"
  2107.   {
  2108. # line 1403 "Semantic.puma"
  2109.  error_protocol ("Illegal Parameter in ALLOCATE");
  2110.     tree_protocol ("wrong parameter is ", t->BTP_LIST.Elem);
  2111.  
  2112. # line 1406 "Semantic.puma"
  2113.    CheckAllocateParams (t->BTP_LIST.Next);
  2114.   }
  2115.    return;
  2116.  
  2117.   }
  2118.   if (t->Kind == kBTP_EMPTY) {
  2119. # line 1409 "Semantic.puma"
  2120.    return;
  2121.  
  2122.   }
  2123. ;
  2124. }
  2125.  
  2126. static void NormalAllocateParams
  2127. # if defined __STDC__ | defined __cplusplus
  2128. (register tTree t)
  2129. # else
  2130. (t)
  2131.  register tTree t;
  2132. # endif
  2133. {
  2134.   if (t->Kind == kBTE_EMPTY) {
  2135. # line 1422 "Semantic.puma"
  2136.    return;
  2137.  
  2138.   }
  2139.   if (t->Kind == kBTE_LIST) {
  2140.   if (t->BTE_LIST.Elem->Kind == kSLICE_EXP) {
  2141. # line 1425 "Semantic.puma"
  2142.   {
  2143. # line 1426 "Semantic.puma"
  2144.    NormalAllocateParams (t->BTE_LIST.Next);
  2145.   }
  2146.    return;
  2147.  
  2148.   }
  2149. # line 1429 "Semantic.puma"
  2150.   {
  2151. # line 1430 "Semantic.puma"
  2152.  t->BTE_LIST.Elem = mSLICE_EXP (mCONST_EXP(mINT_CONSTANT (1)), t->BTE_LIST.Elem, mDUMMY_EXP());
  2153. # line 1431 "Semantic.puma"
  2154.    NormalAllocateParams (t->BTE_LIST.Next);
  2155.   }
  2156.    return;
  2157.  
  2158.   }
  2159. ;
  2160. }
  2161.  
  2162. static void CheckDeallocateParams
  2163. # if defined __STDC__ | defined __cplusplus
  2164. (register tTree t)
  2165. # else
  2166. (t)
  2167.  register tTree t;
  2168. # endif
  2169. {
  2170. # line 1442 "Semantic.puma"
  2171.  
  2172. bool found;
  2173. char s[80], msg[110];
  2174.  
  2175.   if (t->Kind == kBTP_LIST) {
  2176.   if (t->BTP_LIST.Elem->Kind == kVAR_PARAM) {
  2177.   if (t->BTP_LIST.Elem->VAR_PARAM.V->Kind == kUSED_VAR) {
  2178. # line 1447 "Semantic.puma"
  2179.   {
  2180. # line 1449 "Semantic.puma"
  2181.  
  2182.     found = false;
  2183.     while ((!found) && (allocate_top > 0))
  2184.       { allocate_top -= 1;
  2185.         found = (allocate_stack [allocate_top] == t->BTP_LIST.Elem->VAR_PARAM.V->USED_VAR.VARNAME->VAR_OBJ.Ident);
  2186.         if (!found)
  2187.            { GetString (allocate_stack[allocate_top], s);
  2188.              sprintf (msg, "need at first DEALLOCATE for %s", s);
  2189.              error_protocol (msg);
  2190.            }
  2191.       }
  2192.     if (!found)
  2193.       { GetString (t->BTP_LIST.Elem->VAR_PARAM.V->USED_VAR.VARNAME->VAR_OBJ.Ident, s);
  2194.         sprintf (msg,"There was no ALLOCATE for %s", s);
  2195.         error_protocol (msg);
  2196.       }
  2197.  
  2198. # line 1466 "Semantic.puma"
  2199.    CheckDeallocateParams (t->BTP_LIST.Next);
  2200.   }
  2201.    return;
  2202.  
  2203.   }
  2204.   }
  2205. # line 1469 "Semantic.puma"
  2206.   {
  2207. # line 1470 "Semantic.puma"
  2208.  error_protocol ("Illegal Parameter in DEALLOCATE");
  2209.     tree_protocol ("wrong parameter is ", t->BTP_LIST.Elem);
  2210.  
  2211. # line 1473 "Semantic.puma"
  2212.    CheckDeallocateParams (t->BTP_LIST.Next);
  2213.   }
  2214.    return;
  2215.  
  2216.   }
  2217.   if (t->Kind == kBTP_EMPTY) {
  2218. # line 1476 "Semantic.puma"
  2219.    return;
  2220.  
  2221.   }
  2222. ;
  2223. }
  2224.  
  2225. static bool IsVarParameter
  2226. # if defined __STDC__ | defined __cplusplus
  2227. (register tTree t)
  2228. # else
  2229. (t)
  2230.  register tTree t;
  2231. # endif
  2232. {
  2233.   if (t->Kind == kVAR_PARAM) {
  2234.   if (t->VAR_PARAM.V->Kind == kADDR) {
  2235. # line 1487 "Semantic.puma"
  2236.   {
  2237. # line 1488 "Semantic.puma"
  2238.    return false;
  2239.   }
  2240.  
  2241.   }
  2242. # line 1491 "Semantic.puma"
  2243.    return true;
  2244.  
  2245.   }
  2246.   return false;
  2247. }
  2248.  
  2249. static void CheckLHSVar
  2250. # if defined __STDC__ | defined __cplusplus
  2251. (register tTree t)
  2252. # else
  2253. (t)
  2254.  register tTree t;
  2255. # endif
  2256. {
  2257.   if (t->Kind == kINDEXED_VAR) {
  2258. # line 1502 "Semantic.puma"
  2259.   {
  2260. # line 1503 "Semantic.puma"
  2261.    CheckLHSVar (t->INDEXED_VAR.IND_VAR);
  2262.   }
  2263.    return;
  2264.  
  2265.   }
  2266.   if (t->Kind == kUSED_VAR) {
  2267. # line 1506 "Semantic.puma"
  2268.   {
  2269. # line 1507 "Semantic.puma"
  2270.    if (! (t->USED_VAR.VARNAME->VAR_OBJ.Object == NoObject)) goto yyL2;
  2271.   {
  2272. # line 1508 "Semantic.puma"
  2273.    error_protocol ("left hand side undefined");
  2274.   }
  2275.   }
  2276.    return;
  2277. yyL2:;
  2278.  
  2279.   if (t->USED_VAR.VARNAME->VAR_OBJ.Object->Kind == kVarObject) {
  2280.   if (t->USED_VAR.VARNAME->VAR_OBJ.Object->VarObject.Kind->Kind == kVarConstant) {
  2281. # line 1511 "Semantic.puma"
  2282.   {
  2283. # line 1512 "Semantic.puma"
  2284.    error_protocol ("left hand side of assignment must not be parameter");
  2285.   }
  2286.    return;
  2287.  
  2288.   }
  2289.   }
  2290.   }
  2291. ;
  2292. }
  2293.  
  2294. static void SemPureCheck
  2295. # if defined __STDC__ | defined __cplusplus
  2296. (register tTree t)
  2297. # else
  2298. (t)
  2299.  register tTree t;
  2300. # endif
  2301. {
  2302.   if (t->Kind == kBODY_NODE) {
  2303. # line 1527 "Semantic.puma"
  2304.   {
  2305. # line 1528 "Semantic.puma"
  2306.    SemPureCheck (t->BODY_NODE.DECLS);
  2307. # line 1529 "Semantic.puma"
  2308.    SemPureCheck (t->BODY_NODE.STATS);
  2309.   }
  2310.    return;
  2311.  
  2312.   }
  2313.   if (t->Kind == kDECL_LIST) {
  2314. # line 1532 "Semantic.puma"
  2315.   {
  2316. # line 1533 "Semantic.puma"
  2317.    SemPureCheck (t->DECL_LIST.Elem);
  2318. # line 1534 "Semantic.puma"
  2319.    SemPureCheck (t->DECL_LIST.Next);
  2320.   }
  2321.    return;
  2322.  
  2323.   }
  2324.   if (t->Kind == kVAR_DECL) {
  2325.   if (t->VAR_DECL.VAL->Kind == kARRAY_TYPE) {
  2326. # line 1537 "Semantic.puma"
  2327.  {
  2328.   tDefinitions Obj;
  2329.   {
  2330. # line 1539 "Semantic.puma"
  2331.  
  2332. # line 1540 "Semantic.puma"
  2333.    Obj = GetLocalDecl (t->VAR_DECL.Name);
  2334. # line 1541 "Semantic.puma"
  2335.  if (VarDistribution (Obj) == -1)
  2336.           error_protocol ("Host variable in PURE subprogram not allowed");
  2337.  
  2338.   }
  2339.    return;
  2340.  }
  2341.  
  2342.   }
  2343.   }
  2344.   if (t->Kind == kACF_LIST) {
  2345. # line 1546 "Semantic.puma"
  2346.   {
  2347. # line 1547 "Semantic.puma"
  2348.    set_protocol_stmt (t->ACF_LIST.Elem);
  2349. # line 1548 "Semantic.puma"
  2350.    SemPureCheck (t->ACF_LIST.Elem);
  2351. # line 1549 "Semantic.puma"
  2352.    SemPureCheck (t->ACF_LIST.Next);
  2353.   }
  2354.    return;
  2355.  
  2356.   }
  2357.   if (t->Kind == kACF_BASIC) {
  2358.   if (t->ACF_BASIC.BASIC_STMT->Kind == kIO_STMT) {
  2359. # line 1552 "Semantic.puma"
  2360.   {
  2361. # line 1553 "Semantic.puma"
  2362.    error_protocol ("IO in pure function/subroutine not allowed");
  2363.   }
  2364.    return;
  2365.  
  2366.   }
  2367.   if (t->ACF_BASIC.BASIC_STMT->Kind == kCALL_STMT) {
  2368. # line 1556 "Semantic.puma"
  2369.   {
  2370. # line 1557 "Semantic.puma"
  2371.    if (! (t->ACF_BASIC.BASIC_STMT->CALL_STMT.CALL_ID->PROC_OBJ.Object == GetDeclEntry (t->ACF_BASIC.BASIC_STMT->CALL_STMT.CALL_ID->PROC_OBJ.Ident, GetUnitEntries ()))) goto yyL6;
  2372.   {
  2373. # line 1559 "Semantic.puma"
  2374.    if (! ((IsPureObj (t->ACF_BASIC.BASIC_STMT->CALL_STMT.CALL_ID->PROC_OBJ.Object) == false))) goto yyL6;
  2375.   {
  2376. # line 1560 "Semantic.puma"
  2377.    error_protocol ("CALL of not pure subroutine in PURE subprogram");
  2378.   }
  2379.   }
  2380.   }
  2381.    return;
  2382. yyL6:;
  2383.  
  2384.   }
  2385.   }
  2386. ;
  2387. }
  2388.  
  2389. void BeginSemantic ()
  2390. {
  2391. }
  2392.  
  2393. void CloseSemantic ()
  2394. {
  2395. }
  2396.