genie-enclosed.c

     
   1  //! @file genie-enclosed.c
   2  //! @author J. Marcel van der Veer
   3  
   4  //! @section Copyright
   5  //!
   6  //! This file is part of Algol68G - an Algol 68 compiler-interpreter.
   7  //! Copyright 2001-2024 J. Marcel van der Veer [algol68g@xs4all.nl].
   8  
   9  //! @section License
  10  //!
  11  //! This program is free software; you can redistribute it and/or modify it 
  12  //! under the terms of the GNU General Public License as published by the 
  13  //! Free Software Foundation; either version 3 of the License, or 
  14  //! (at your option) any later version.
  15  //!
  16  //! This program is distributed in the hope that it will be useful, but 
  17  //! WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 
  18  //! or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for 
  19  //! more details. You should have received a copy of the GNU General Public 
  20  //! License along with this program. If not, see [http://www.gnu.org/licenses/].
  21  
  22  //! @section Synopsis
  23  //!
  24  //! Interpreter routines for enclosed clauses.
  25  
  26  #include "a68g.h"
  27  #include "a68g-genie.h"
  28  #include "a68g-frames.h"
  29  #include "a68g-prelude.h"
  30  #include "a68g-parser.h"
  31  
  32  #define LABEL_FREE(_p_) {\
  33    NODE_T *_m_q; ADDR_T pop_sp_lf = A68_SP;\
  34    for (_m_q = SEQUENCE (_p_); _m_q != NO_NODE; _m_q = SEQUENCE (_m_q)) {\
  35      if (IS (_m_q, UNIT) || IS (_m_q, DECLARATION_LIST)) {\
  36        GENIE_UNIT_TRACE (_m_q);\
  37      }\
  38      if (SEQUENCE (_m_q) != NO_NODE) {\
  39        A68_SP = pop_sp_lf;\
  40        _m_q = SEQUENCE (_m_q);\
  41      }\
  42    }}
  43  
  44  #define SERIAL_CLAUSE(_p_)\
  45    genie_preemptive_gc_heap ((NODE_T *) (_p_));\
  46    if (STATUS_TEST ((_p_), OPTIMAL_MASK)) {\
  47      GENIE_UNIT_TRACE (SEQUENCE (_p_));\
  48    } else if (STATUS_TEST ((_p_), SERIAL_MASK)) {\
  49      LABEL_FREE (_p_);\
  50    } else {\
  51      if (!setjmp (exit_buf)) {\
  52        genie_serial_clause ((NODE_T *) (_p_), (jmp_buf *) exit_buf);\
  53    }}
  54  
  55  #define ENQUIRY_CLAUSE(_p_)\
  56    genie_preemptive_gc_heap ((NODE_T *) (_p_));\
  57    if (STATUS_TEST ((_p_), OPTIMAL_MASK)) {\
  58      GENIE_UNIT (SEQUENCE (_p_));\
  59    } else if (STATUS_TEST ((_p_), SERIAL_MASK)) {\
  60      LABEL_FREE (_p_);\
  61    } else {\
  62      genie_enquiry_clause ((NODE_T *) (_p_));\
  63    }
  64  
  65  //! @brief Execute assertion.
  66  
  67  PROP_T genie_assertion (NODE_T * p)
  68  {
  69    PROP_T self;
  70    if (STATUS_TEST (p, ASSERT_MASK)) {
  71      A68_BOOL z;
  72      GENIE_UNIT (NEXT_SUB (p));
  73      POP_OBJECT (p, &z, A68_BOOL);
  74      if (VALUE (&z) == A68_FALSE) {
  75        diagnostic (A68_RUNTIME_ERROR, p, ERROR_FALSE_ASSERTION);
  76        exit_genie (p, A68_RUNTIME_ERROR);
  77      }
  78    }
  79    UNIT (&self) = genie_assertion;
  80    SOURCE (&self) = p;
  81    return self;
  82  }
  83  
  84  //! @brief Execute a unit, tertiary, secondary or primary.
  85  
  86  PROP_T genie_unit (NODE_T * p)
  87  {
  88    if (IS_COERCION (GINFO (p))) {
  89      GLOBAL_PROP (&A68_JOB) = genie_coercion (p);
  90    } else {
  91      switch (ATTRIBUTE (p)) {
  92      case DECLARATION_LIST: {
  93          genie_declaration (SUB (p));
  94          UNIT (&GLOBAL_PROP (&A68_JOB)) = genie_unit;
  95          SOURCE (&GLOBAL_PROP (&A68_JOB)) = p;
  96          break;
  97        }
  98      case UNIT: {
  99          GENIE_UNIT_2 (SUB (p), GLOBAL_PROP (&A68_JOB));
 100          break;
 101        }
 102      case TERTIARY:
 103      case SECONDARY:
 104      case PRIMARY: {
 105          GLOBAL_PROP (&A68_JOB) = genie_unit (SUB (p));
 106          break;
 107        }
 108  // Ex primary.
 109      case ENCLOSED_CLAUSE: {
 110          GLOBAL_PROP (&A68_JOB) = genie_enclosed ((volatile NODE_T *) p);
 111          break;
 112        }
 113      case IDENTIFIER: {
 114          GLOBAL_PROP (&A68_JOB) = genie_identifier (p);
 115          break;
 116        }
 117      case CALL: {
 118          GLOBAL_PROP (&A68_JOB) = genie_call (p);
 119          break;
 120        }
 121      case SLICE: {
 122          GLOBAL_PROP (&A68_JOB) = genie_slice (p);
 123          break;
 124        }
 125      case DENOTATION: {
 126          GLOBAL_PROP (&A68_JOB) = genie_denotation (p);
 127          break;
 128        }
 129      case CAST: {
 130          GLOBAL_PROP (&A68_JOB) = genie_cast (p);
 131          break;
 132        }
 133      case FORMAT_TEXT: {
 134          GLOBAL_PROP (&A68_JOB) = genie_format_text (p);
 135          break;
 136        }
 137  // Ex secondary.
 138      case GENERATOR: {
 139          GLOBAL_PROP (&A68_JOB) = genie_generator (p);
 140          break;
 141        }
 142      case SELECTION: {
 143          GLOBAL_PROP (&A68_JOB) = genie_selection (p);
 144          break;
 145        }
 146  // Ex tertiary.
 147      case FORMULA: {
 148          GLOBAL_PROP (&A68_JOB) = genie_formula (p);
 149          break;
 150        }
 151      case MONADIC_FORMULA: {
 152          GLOBAL_PROP (&A68_JOB) = genie_monadic (p);
 153          break;
 154        }
 155      case NIHIL: {
 156          GLOBAL_PROP (&A68_JOB) = genie_nihil (p);
 157          break;
 158        }
 159      case DIAGONAL_FUNCTION: {
 160          GLOBAL_PROP (&A68_JOB) = genie_diagonal_function (p);
 161          break;
 162        }
 163      case TRANSPOSE_FUNCTION: {
 164          GLOBAL_PROP (&A68_JOB) = genie_transpose_function (p);
 165          break;
 166        }
 167      case ROW_FUNCTION: {
 168          GLOBAL_PROP (&A68_JOB) = genie_row_function (p);
 169          break;
 170        }
 171      case COLUMN_FUNCTION: {
 172          GLOBAL_PROP (&A68_JOB) = genie_column_function (p);
 173          break;
 174        }
 175  // Ex unit.
 176      case ASSIGNATION: {
 177          GLOBAL_PROP (&A68_JOB) = genie_assignation (p);
 178          break;
 179        }
 180      case IDENTITY_RELATION: {
 181          GLOBAL_PROP (&A68_JOB) = genie_identity_relation (p);
 182          break;
 183        }
 184      case ROUTINE_TEXT: {
 185          GLOBAL_PROP (&A68_JOB) = genie_routine_text (p);
 186          break;
 187        }
 188      case SKIP: {
 189          GLOBAL_PROP (&A68_JOB) = genie_skip (p);
 190          break;
 191        }
 192      case JUMP: {
 193          UNIT (&GLOBAL_PROP (&A68_JOB)) = genie_unit;
 194          SOURCE (&GLOBAL_PROP (&A68_JOB)) = p;
 195          genie_jump (p);
 196          break;
 197        }
 198      case AND_FUNCTION: {
 199          GLOBAL_PROP (&A68_JOB) = genie_and_function (p);
 200          break;
 201        }
 202      case OR_FUNCTION: {
 203          GLOBAL_PROP (&A68_JOB) = genie_or_function (p);
 204          break;
 205        }
 206      case ASSERTION: {
 207          GLOBAL_PROP (&A68_JOB) = genie_assertion (p);
 208          break;
 209        }
 210      case CODE_CLAUSE: {
 211          diagnostic (A68_RUNTIME_ERROR, p, ERROR_CODE);
 212          exit_genie (p, A68_RUNTIME_ERROR);
 213          break;
 214        }
 215      }
 216    }
 217    return GPROP (p) = GLOBAL_PROP (&A68_JOB);
 218  }
 219  
 220  //! @brief Execution of serial clause without labels.
 221  
 222  void genie_serial_units_no_label (NODE_T * p, ADDR_T pop_sp, NODE_T ** seq)
 223  {
 224    for (; p != NO_NODE; FORWARD (p)) {
 225      switch (ATTRIBUTE (p)) {
 226      case DECLARATION_LIST:
 227      case UNIT: {
 228          GENIE_UNIT_TRACE (p);
 229          SEQUENCE (*seq) = p;
 230          (*seq) = p;
 231          return;
 232        }
 233      case SEMI_SYMBOL: {
 234  // Voiden the expression stack.
 235          A68_SP = pop_sp;
 236          SEQUENCE (*seq) = p;
 237          (*seq) = p;
 238          break;
 239        }
 240      default: {
 241          genie_serial_units_no_label (SUB (p), pop_sp, seq);
 242          break;
 243        }
 244      }
 245    }
 246  }
 247  
 248  //! @brief Execution of serial clause with labels.
 249  
 250  void genie_serial_units (NODE_T * p, NODE_T ** jump_to, jmp_buf * exit_buf, ADDR_T pop_sp)
 251  {
 252    LOW_STACK_ALERT (p);
 253    for (; p != NO_NODE; FORWARD (p)) {
 254      switch (ATTRIBUTE (p)) {
 255      case DECLARATION_LIST:
 256      case UNIT: {
 257          if (*jump_to == NO_NODE) {
 258            GENIE_UNIT_TRACE (p);
 259          } else if (p == *jump_to) {
 260  // If we dropped in this clause from a jump then this unit is the target.
 261            *jump_to = NO_NODE;
 262            GENIE_UNIT_TRACE (p);
 263          }
 264          return;
 265        }
 266      case EXIT_SYMBOL: {
 267          if (*jump_to == NO_NODE) {
 268            longjmp (*exit_buf, 1);
 269          }
 270          break;
 271        }
 272      case SEMI_SYMBOL: {
 273          if (*jump_to == NO_NODE) {
 274  // Voiden the expression stack.
 275            A68_SP = pop_sp;
 276          }
 277          break;
 278        }
 279      default: {
 280          genie_serial_units (SUB (p), jump_to, exit_buf, pop_sp);
 281          break;
 282        }
 283      }
 284    }
 285  }
 286  
 287  //! @brief Execute serial clause.
 288  
 289  void genie_serial_clause (NODE_T * p, jmp_buf * exit_buf)
 290  {
 291    if (LABELS (TABLE (p)) == NO_TAG) {
 292  // No labels in this clause.
 293      if (SEQUENCE (p) == NO_NODE && !STATUS_TEST (p, SEQUENCE_MASK)) {
 294        NODE_T top_seq; GINFO_T g; NODE_T *seq = &top_seq;
 295        GINFO (seq) = &g;
 296        SEQUENCE (seq) = NO_NODE;
 297        genie_serial_units_no_label (SUB (p), A68_SP, &seq);
 298        SEQUENCE (p) = SEQUENCE (&top_seq);
 299        STATUS_SET (p, SEQUENCE_MASK);
 300        STATUS_SET (p, SERIAL_MASK);
 301        if (SEQUENCE (p) != NO_NODE && SEQUENCE (SEQUENCE (p)) == NO_NODE) {
 302          STATUS_SET (p, OPTIMAL_MASK);
 303        }
 304      } else {
 305  // A linear list without labels.
 306        ADDR_T pop_sp = A68_SP;
 307        STATUS_SET (p, SERIAL_CLAUSE);
 308        for (NODE_T *q = SEQUENCE (p); q != NO_NODE; q = SEQUENCE (q)) {
 309          switch (ATTRIBUTE (q)) {
 310          case DECLARATION_LIST:
 311          case UNIT: {
 312              GENIE_UNIT_TRACE (q);
 313              break;
 314            }
 315          case SEMI_SYMBOL: {
 316              A68_SP = pop_sp;
 317              break;
 318            }
 319          }
 320        }
 321      }
 322    } else {
 323  // Labels in this clause.
 324      jmp_buf jump_stat;
 325      ADDR_T pop_sp = A68_SP, pop_fp = A68_FP;
 326      ADDR_T pop_dns = FRAME_DNS (A68_FP);
 327      FRAME_JUMP_STAT (A68_FP) = &jump_stat;
 328      if (!setjmp (jump_stat)) {
 329        NODE_T *jump_to = NO_NODE;
 330        genie_serial_units (SUB (p), &jump_to, exit_buf, A68_SP);
 331      } else {
 332  // HIjol! Restore state and look for indicated unit.
 333        NODE_T *jump_to = JUMP_TO (TABLE (p));
 334        A68_SP = pop_sp;
 335        A68_FP = pop_fp;
 336        FRAME_DNS (A68_FP) = pop_dns;
 337        genie_serial_units (SUB (p), &jump_to, exit_buf, A68_SP);
 338      }
 339    }
 340  }
 341  
 342  //! @brief Execute enquiry clause.
 343  
 344  void genie_enquiry_clause (NODE_T * p)
 345  {
 346    if (SEQUENCE (p) == NO_NODE && !STATUS_TEST (p, SEQUENCE_MASK)) {
 347      NODE_T top_seq;
 348      GINFO_T g;
 349      NODE_T *seq = &top_seq;
 350      GINFO (seq) = &g;
 351      SEQUENCE (seq) = NO_NODE;
 352      genie_serial_units_no_label (SUB (p), A68_SP, &seq);
 353      SEQUENCE (p) = SEQUENCE (&top_seq);
 354      STATUS_SET (p, SEQUENCE_MASK);
 355      if (SEQUENCE (p) != NO_NODE && SEQUENCE (SEQUENCE (p)) == NO_NODE) {
 356        STATUS_SET (p, OPTIMAL_MASK);
 357      }
 358    } else {
 359  // A linear list without labels (enquiry clause).
 360      ADDR_T pop_sp = A68_SP;
 361      STATUS_SET (p, SERIAL_MASK);
 362      for (NODE_T *q = SEQUENCE (p); q != NO_NODE; q = SEQUENCE (q)) {
 363        switch (ATTRIBUTE (q)) {
 364        case DECLARATION_LIST:
 365        case UNIT: {
 366            GENIE_UNIT_TRACE (q);
 367            break;
 368          }
 369        case SEMI_SYMBOL: {
 370            A68_SP = pop_sp;
 371            break;
 372          }
 373        }
 374      }
 375    }
 376  }
 377  
 378  //! @brief Execute collateral units.
 379  
 380  void genie_collateral_units (NODE_T * p, int *count)
 381  {
 382    for (; p != NO_NODE; FORWARD (p)) {
 383      if (IS (p, UNIT)) {
 384        GENIE_UNIT_TRACE (p);
 385        STACK_DNS (p, MOID (p), FRAME_DNS (A68_FP));
 386        (*count)++;
 387        return;
 388      } else {
 389        genie_collateral_units (SUB (p), count);
 390      }
 391    }
 392  }
 393  
 394  //! @brief Execute collateral clause.
 395  
 396  PROP_T genie_collateral (NODE_T * p)
 397  {
 398    PROP_T self;
 399  // VOID clause and STRUCT display.
 400    if (MOID (p) == M_VOID || IS_STRUCT (MOID (p))) {
 401      int count = 0;
 402      genie_collateral_units (SUB (p), &count);
 403    } else {
 404  // Row display.
 405      A68_REF new_display;
 406      int count = 0;
 407      ADDR_T pop_sp = A68_SP;
 408      MOID_T *m = MOID (p);
 409      genie_collateral_units (SUB (p), &count);
 410  // [] AMODE vacuum.
 411      if (count == 0) {
 412        A68_SP = pop_sp;
 413        INCREMENT_STACK_POINTER (p, A68_REF_SIZE);
 414        *(A68_REF *) STACK_ADDRESS (pop_sp) = empty_row (p, m);
 415      } else if (DIM (DEFLEX (m)) == 1) {
 416  // [] AMODE display.
 417        new_display = genie_make_row (p, SLICE (DEFLEX (m)), count, pop_sp);
 418        A68_SP = pop_sp;
 419        INCREMENT_STACK_POINTER (p, A68_REF_SIZE);
 420        *(A68_REF *) STACK_ADDRESS (pop_sp) = new_display;
 421      } else {
 422  // [,,] AMODE display, we concatenate 1 + (n-1) to n dimensions.
 423        new_display = genie_make_rowrow (p, m, count, pop_sp);
 424        A68_SP = pop_sp;
 425        INCREMENT_STACK_POINTER (p, A68_REF_SIZE);
 426        *(A68_REF *) STACK_ADDRESS (pop_sp) = new_display;
 427      }
 428    }
 429    UNIT (&self) = genie_collateral;
 430    SOURCE (&self) = p;
 431    return self;
 432  }
 433  
 434  //! @brief Execute unit from integral-case in-part.
 435  
 436  BOOL_T genie_int_case_unit (NODE_T * p, int k, int *count)
 437  {
 438    if (p == NO_NODE) {
 439      return A68_FALSE;
 440    } else {
 441      if (IS (p, UNIT)) {
 442        if (k == *count) {
 443          GENIE_UNIT_TRACE (p);
 444          return A68_TRUE;
 445        } else {
 446          (*count)++;
 447          return A68_FALSE;
 448        }
 449      } else {
 450        if (genie_int_case_unit (SUB (p), k, count)) {
 451          return A68_TRUE;
 452        } else {
 453          return genie_int_case_unit (NEXT (p), k, count);
 454        }
 455      }
 456    }
 457  }
 458  
 459  //! @brief Execute unit from united-case in-part.
 460  
 461  BOOL_T genie_united_case_unit (NODE_T * p, MOID_T * m)
 462  {
 463    if (p == NO_NODE) {
 464      return A68_FALSE;
 465    } else {
 466      if (IS (p, SPECIFIER)) {
 467        MOID_T *spec_moid = MOID (NEXT_SUB (p));
 468        BOOL_T equal_modes;
 469        if (m != NO_MOID) {
 470          if (IS_UNION (spec_moid)) {
 471            equal_modes = is_unitable (m, spec_moid, SAFE_DEFLEXING);
 472          } else {
 473            equal_modes = (BOOL_T) (m == spec_moid);
 474          }
 475        } else {
 476          equal_modes = A68_FALSE;
 477        }
 478        if (equal_modes) {
 479          NODE_T *q = NEXT_NEXT (SUB (p));
 480          OPEN_STATIC_FRAME (p);
 481          INIT_STATIC_FRAME (p);
 482          if (IS (q, IDENTIFIER)) {
 483            if (IS_UNION (spec_moid)) {
 484              COPY ((FRAME_OBJECT (OFFSET (TAX (q)))), STACK_TOP, SIZE (spec_moid));
 485            } else {
 486              COPY ((FRAME_OBJECT (OFFSET (TAX (q)))), STACK_OFFSET (A68_UNION_SIZE), SIZE (spec_moid));
 487            }
 488          }
 489          GENIE_UNIT_TRACE (NEXT_NEXT (p));
 490          CLOSE_FRAME;
 491          return A68_TRUE;
 492        } else {
 493          return A68_FALSE;
 494        }
 495      } else {
 496        if (genie_united_case_unit (SUB (p), m)) {
 497          return A68_TRUE;
 498        } else {
 499          return genie_united_case_unit (NEXT (p), m);
 500        }
 501      }
 502    }
 503  }
 504  
 505  //! @brief Execute integral-case-clause.
 506  
 507  PROP_T genie_int_case (volatile NODE_T * p)
 508  {
 509    volatile int unit_count;
 510    volatile BOOL_T found_unit;
 511    jmp_buf exit_buf;
 512    A68_INT k;
 513    volatile NODE_T *q = SUB (p);
 514    volatile MOID_T *yield = MOID (q);
 515  // CASE or OUSE.
 516    OPEN_STATIC_FRAME ((NODE_T *) SUB (q));
 517    INIT_GLOBAL_POINTER ((NODE_T *) SUB (q));
 518    INIT_STATIC_FRAME ((NODE_T *) SUB (q));
 519    ENQUIRY_CLAUSE (NEXT_SUB (q));
 520    POP_OBJECT (q, &k, A68_INT);
 521  // IN.
 522    FORWARD (q);
 523    OPEN_STATIC_FRAME ((NODE_T *) SUB (q));
 524    INIT_STATIC_FRAME ((NODE_T *) SUB (q));
 525    unit_count = 1;
 526    found_unit = genie_int_case_unit (NEXT_SUB ((NODE_T *) q), (int) VALUE (&k), (int *) &unit_count);
 527    CLOSE_FRAME;
 528  // OUT.
 529    if (!found_unit) {
 530      FORWARD (q);
 531      switch (ATTRIBUTE (q)) {
 532      case CHOICE:
 533      case OUT_PART: {
 534          OPEN_STATIC_FRAME ((NODE_T *) SUB (q));
 535          INIT_STATIC_FRAME ((NODE_T *) SUB (q));
 536          SERIAL_CLAUSE (NEXT_SUB (q));
 537          CLOSE_FRAME;
 538          break;
 539        }
 540      case CLOSE_SYMBOL:
 541      case ESAC_SYMBOL: {
 542          if (yield != M_VOID) {
 543            genie_push_undefined ((NODE_T *) q, (MOID_T *) yield);
 544          }
 545          break;
 546        }
 547      default: {
 548          MOID (SUB ((NODE_T *) q)) = (MOID_T *) yield;
 549          (void) genie_int_case (q);
 550          break;
 551        }
 552      }
 553    }
 554  // ESAC.
 555    CLOSE_FRAME;
 556    return GPROP (p);
 557  }
 558  
 559  //! @brief Execute united-case-clause.
 560  
 561  PROP_T genie_united_case (volatile NODE_T * p)
 562  {
 563    volatile BOOL_T found_unit = A68_FALSE;
 564    volatile MOID_T *um;
 565    volatile ADDR_T pop_sp;
 566    jmp_buf exit_buf;
 567    volatile NODE_T *q = SUB (p);
 568    volatile MOID_T *yield = MOID (q);
 569  // CASE or OUSE.
 570    OPEN_STATIC_FRAME ((NODE_T *) SUB (q));
 571    INIT_GLOBAL_POINTER ((NODE_T *) SUB (q));
 572    INIT_STATIC_FRAME ((NODE_T *) SUB (q));
 573    pop_sp = A68_SP;
 574    ENQUIRY_CLAUSE (NEXT_SUB (q));
 575    A68_SP = pop_sp;
 576    um = (volatile MOID_T *) VALUE ((A68_UNION *) STACK_TOP);
 577  // IN.
 578    FORWARD (q);
 579    if (um != NO_MOID) {
 580      OPEN_STATIC_FRAME ((NODE_T *) SUB (q));
 581      INIT_STATIC_FRAME ((NODE_T *) SUB (q));
 582      found_unit = genie_united_case_unit (NEXT_SUB ((NODE_T *) q), (MOID_T *) um);
 583      CLOSE_FRAME;
 584    } else {
 585      found_unit = A68_FALSE;
 586    }
 587  // OUT.
 588    if (!found_unit) {
 589      FORWARD (q);
 590      switch (ATTRIBUTE (q)) {
 591      case CHOICE:
 592      case OUT_PART: {
 593          OPEN_STATIC_FRAME ((NODE_T *) SUB (q));
 594          INIT_STATIC_FRAME ((NODE_T *) SUB (q));
 595          SERIAL_CLAUSE (NEXT_SUB (q));
 596          CLOSE_FRAME;
 597          break;
 598        }
 599      case CLOSE_SYMBOL:
 600      case ESAC_SYMBOL: {
 601          if (yield != M_VOID) {
 602            genie_push_undefined ((NODE_T *) q, (MOID_T *) yield);
 603          }
 604          break;
 605        }
 606      default: {
 607          MOID (SUB ((NODE_T *) q)) = (MOID_T *) yield;
 608          (void) genie_united_case (q);
 609          break;
 610        }
 611      }
 612    }
 613  // ESAC.
 614    CLOSE_FRAME;
 615    return GPROP (p);
 616  }
 617  
 618  //! @brief Execute conditional-clause.
 619  
 620  PROP_T genie_conditional (volatile NODE_T * p)
 621  {
 622    volatile ADDR_T pop_sp = A68_SP;
 623    jmp_buf exit_buf;
 624    volatile NODE_T *q = SUB (p);
 625    volatile MOID_T *yield = MOID (q);
 626  // IF or ELIF.
 627    OPEN_STATIC_FRAME ((NODE_T *) SUB (q));
 628    INIT_GLOBAL_POINTER ((NODE_T *) SUB (q));
 629    INIT_STATIC_FRAME ((NODE_T *) SUB (q));
 630    ENQUIRY_CLAUSE (NEXT_SUB (q));
 631    A68_SP = pop_sp;
 632    FORWARD (q);
 633    if (VALUE ((A68_BOOL *) STACK_TOP) == A68_TRUE) {
 634  // THEN.
 635      OPEN_STATIC_FRAME ((NODE_T *) SUB (q));
 636      INIT_STATIC_FRAME ((NODE_T *) SUB (q));
 637      SERIAL_CLAUSE (NEXT_SUB (q));
 638      CLOSE_FRAME;
 639    } else {
 640  // ELSE.
 641      FORWARD (q);
 642      switch (ATTRIBUTE (q)) {
 643      case CHOICE:
 644      case ELSE_PART: {
 645          OPEN_STATIC_FRAME ((NODE_T *) SUB (q));
 646          INIT_STATIC_FRAME ((NODE_T *) SUB (q));
 647          SERIAL_CLAUSE (NEXT_SUB (q));
 648          CLOSE_FRAME;
 649          break;
 650        }
 651      case CLOSE_SYMBOL:
 652      case FI_SYMBOL: {
 653          if (yield != M_VOID) {
 654            genie_push_undefined ((NODE_T *) q, (MOID_T *) yield);
 655          }
 656          break;
 657        }
 658      default: {
 659          MOID (SUB ((NODE_T *) q)) = (MOID_T *) yield;
 660          (void) genie_conditional (q);
 661          break;
 662        }
 663      }
 664    }
 665  // FI.
 666    CLOSE_FRAME;
 667    return GPROP (p);
 668  }
 669  
 670  // INCREMENT_COUNTER procures that the counter only increments if there is
 671  // a for-part or a to-part. Otherwise an infinite loop would trigger overflow
 672  // when the anonymous counter reaches max int, which is strange behaviour.
 673  // This is less relevant using 64-bit integers.
 674  
 675  #define INCREMENT_COUNTER\
 676    if (!(for_part == NO_NODE && to_part == NO_NODE)) {\
 677      CHECK_INT_ADDITION ((NODE_T *) p, counter, by);\
 678      counter += by;\
 679    }
 680  
 681  //! @brief Execute loop-clause.
 682  
 683  PROP_T genie_loop (volatile NODE_T * p)
 684  {
 685    volatile ADDR_T pop_sp = A68_SP;
 686    volatile INT_T from, by, to, counter;
 687    volatile BOOL_T siga, conditional;
 688    volatile NODE_T *for_part = NO_NODE, *to_part = NO_NODE, *q = NO_NODE;
 689    jmp_buf exit_buf;
 690  // FOR  identifier.
 691    if (IS (p, FOR_PART)) {
 692      for_part = NEXT_SUB (p);
 693      FORWARD (p);
 694    }
 695  // FROM unit.
 696    if (IS (p, FROM_PART)) {
 697      GENIE_UNIT (NEXT_SUB (p));
 698      A68_SP = pop_sp;
 699      from = VALUE ((A68_INT *) STACK_TOP);
 700      FORWARD (p);
 701    } else {
 702      from = 1;
 703    }
 704  // BY unit.
 705    if (IS (p, BY_PART)) {
 706      GENIE_UNIT (NEXT_SUB (p));
 707      A68_SP = pop_sp;
 708      by = VALUE ((A68_INT *) STACK_TOP);
 709      FORWARD (p);
 710    } else {
 711      by = 1;
 712    }
 713  // TO unit, DOWNTO unit.
 714    if (IS (p, TO_PART)) {
 715      if (IS (SUB (p), DOWNTO_SYMBOL)) {
 716        by = -by;
 717      }
 718      GENIE_UNIT (NEXT_SUB (p));
 719      A68_SP = pop_sp;
 720      to = VALUE ((A68_INT *) STACK_TOP);
 721      to_part = p;
 722      FORWARD (p);
 723    } else {
 724      to = (by >= 0 ? A68_MAX_INT : -A68_MAX_INT);
 725    }
 726    q = NEXT_SUB (p);
 727  // Here the loop part starts.
 728  // We open the frame only once and reinitialise if necessary
 729    OPEN_STATIC_FRAME ((NODE_T *) q);
 730    INIT_GLOBAL_POINTER ((NODE_T *) q);
 731    INIT_STATIC_FRAME ((NODE_T *) q);
 732    counter = from;
 733  // Does the loop contain conditionals?.
 734    if (IS (p, WHILE_PART)) {
 735      conditional = A68_TRUE;
 736    } else if (IS (p, DO_PART) || IS (p, ALT_DO_PART)) {
 737      NODE_T *until_part = NEXT_SUB (p);
 738      if (IS (until_part, SERIAL_CLAUSE)) {
 739        until_part = NEXT (until_part);
 740      }
 741      conditional = (BOOL_T) (until_part != NO_NODE && IS (until_part, UNTIL_PART));
 742    } else {
 743      conditional = A68_FALSE;
 744    }
 745    if (conditional) {
 746  // [FOR ...] [WHILE ...] DO [...] [UNTIL ...] OD.
 747      siga = (BOOL_T) ((by > 0 && counter <= to) || (by < 0 && counter >= to) || (by == 0));
 748      while (siga) {
 749        if (for_part != NO_NODE) {
 750          A68_INT *z = (A68_INT *) (FRAME_OBJECT (OFFSET (TAX (for_part))));
 751          STATUS (z) = INIT_MASK;
 752          VALUE (z) = counter;
 753        }
 754        A68_SP = pop_sp;
 755        if (IS (p, WHILE_PART)) {
 756          ENQUIRY_CLAUSE (q);
 757          A68_SP = pop_sp;
 758          siga = (BOOL_T) (VALUE ((A68_BOOL *) STACK_TOP) != A68_FALSE);
 759        }
 760        if (siga) {
 761          volatile NODE_T *do_part = p, *until_part;
 762          if (IS (p, WHILE_PART)) {
 763            do_part = NEXT_SUB (NEXT (p));
 764            OPEN_STATIC_FRAME ((NODE_T *) do_part);
 765            INIT_STATIC_FRAME ((NODE_T *) do_part);
 766          } else {
 767            do_part = NEXT_SUB (p);
 768          }
 769          if (IS (do_part, SERIAL_CLAUSE)) {
 770            SERIAL_CLAUSE (do_part);
 771            until_part = NEXT (do_part);
 772          } else {
 773            until_part = do_part;
 774          }
 775  // UNTIL part.
 776          if (until_part != NO_NODE && IS (until_part, UNTIL_PART)) {
 777            NODE_T *v = NEXT_SUB (until_part);
 778            OPEN_STATIC_FRAME ((NODE_T *) v);
 779            INIT_STATIC_FRAME ((NODE_T *) v);
 780            A68_SP = pop_sp;
 781            ENQUIRY_CLAUSE (v);
 782            A68_SP = pop_sp;
 783            siga = (BOOL_T) (VALUE ((A68_BOOL *) STACK_TOP) == A68_FALSE);
 784            CLOSE_FRAME;
 785          }
 786          if (IS (p, WHILE_PART)) {
 787            CLOSE_FRAME;
 788          }
 789  // Increment counter.
 790          if (siga) {
 791            INCREMENT_COUNTER;
 792            siga = (BOOL_T) ((by > 0 && counter <= to) || (by < 0 && counter >= to) || (by == 0));
 793          }
 794  // The genie cannot take things to next iteration: re-initialise stack frame.
 795          if (siga) {
 796            FRAME_CLEAR (AP_INCREMENT (TABLE (q)));
 797            if (INITIALISE_FRAME (TABLE (q))) {
 798              initialise_frame ((NODE_T *) q);
 799            }
 800          }
 801        }
 802      }
 803    } else {
 804  // [FOR ...] DO ... OD.
 805      siga = (BOOL_T) ((by > 0 && counter <= to) || (by < 0 && counter >= to) || (by == 0));
 806      while (siga) {
 807        if (for_part != NO_NODE) {
 808          A68_INT *z = (A68_INT *) (FRAME_OBJECT (OFFSET (TAX (for_part))));
 809          STATUS (z) = INIT_MASK;
 810          VALUE (z) = counter;
 811        }
 812        A68_SP = pop_sp;
 813        SERIAL_CLAUSE (q);
 814        INCREMENT_COUNTER;
 815        siga = (BOOL_T) ((by > 0 && counter <= to) || (by < 0 && counter >= to) || (by == 0));
 816  // The genie cannot take things to next iteration: re-initialise stack frame.
 817        if (siga) {
 818          FRAME_CLEAR (AP_INCREMENT (TABLE (q)));
 819          if (INITIALISE_FRAME (TABLE (q))) {
 820            initialise_frame ((NODE_T *) q);
 821          }
 822        }
 823      }
 824    }
 825  // OD.
 826    CLOSE_FRAME;
 827    A68_SP = pop_sp;
 828    return GPROP (p);
 829  }
 830  
 831  #undef INCREMENT_COUNTER
 832  #undef LOOP_OVERFLOW
 833  
 834  //! @brief Execute closed clause.
 835  
 836  PROP_T genie_closed (volatile NODE_T * p)
 837  {
 838    jmp_buf exit_buf;
 839    volatile NODE_T *q = NEXT_SUB (p);
 840    OPEN_STATIC_FRAME ((NODE_T *) q);
 841    INIT_GLOBAL_POINTER ((NODE_T *) q);
 842    INIT_STATIC_FRAME ((NODE_T *) q);
 843    SERIAL_CLAUSE (q);
 844    CLOSE_FRAME;
 845    return GPROP (p);
 846  }
 847  
 848  //! @brief Execute enclosed clause.
 849  
 850  PROP_T genie_enclosed (volatile NODE_T * p)
 851  {
 852    PROP_T self;
 853    UNIT (&self) = (PROP_PROC *) genie_enclosed;
 854    SOURCE (&self) = (NODE_T *) p;
 855    switch (ATTRIBUTE (p)) {
 856    case PARTICULAR_PROGRAM: {
 857        self = genie_enclosed (SUB (p));
 858        break;
 859      }
 860    case ENCLOSED_CLAUSE: {
 861        self = genie_enclosed (SUB (p));
 862        break;
 863      }
 864    case CLOSED_CLAUSE: {
 865        self = genie_closed ((NODE_T *) p);
 866        if (UNIT (&self) == genie_unit) {
 867          UNIT (&self) = (PROP_PROC *) genie_closed;
 868          SOURCE (&self) = (NODE_T *) p;
 869        }
 870        break;
 871      }
 872  #if defined (BUILD_PARALLEL_CLAUSE)
 873    case PARALLEL_CLAUSE: {
 874        (void) genie_parallel ((NODE_T *) NEXT_SUB (p));
 875        break;
 876      }
 877  #endif
 878    case COLLATERAL_CLAUSE: {
 879        (void) genie_collateral ((NODE_T *) p);
 880        break;
 881      }
 882    case CONDITIONAL_CLAUSE: {
 883        MOID (SUB ((NODE_T *) p)) = MOID (p);
 884        (void) genie_conditional (p);
 885        UNIT (&self) = (PROP_PROC *) genie_conditional;
 886        SOURCE (&self) = (NODE_T *) p;
 887        break;
 888      }
 889    case CASE_CLAUSE: {
 890        MOID (SUB ((NODE_T *) p)) = MOID (p);
 891        (void) genie_int_case (p);
 892        UNIT (&self) = (PROP_PROC *) genie_int_case;
 893        SOURCE (&self) = (NODE_T *) p;
 894        break;
 895      }
 896    case CONFORMITY_CLAUSE: {
 897        MOID (SUB ((NODE_T *) p)) = MOID (p);
 898        (void) genie_united_case (p);
 899        UNIT (&self) = (PROP_PROC *) genie_united_case;
 900        SOURCE (&self) = (NODE_T *) p;
 901        break;
 902      }
 903    case LOOP_CLAUSE: {
 904        (void) genie_loop (SUB ((NODE_T *) p));
 905        UNIT (&self) = (PROP_PROC *) genie_loop;
 906        SOURCE (&self) = SUB ((NODE_T *) p);
 907        break;
 908      }
 909    }
 910    GPROP (p) = self;
 911    return self;
 912  }
     


© 2002-2024 J.M. van der Veer (jmvdveer@xs4all.nl)