plugin-folder.c

     
   1  //! @file plugin-folder.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-2023 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  //! Plugin compiler constant folder.
  25  
  26  #include "a68g.h"
  27  #include "a68g-prelude.h"
  28  #include "a68g-genie.h"
  29  #include "a68g-listing.h"
  30  #include "a68g-mp.h"
  31  #include "a68g-optimiser.h"
  32  #include "a68g-plugin.h"
  33  #include "a68g-parser.h"
  34  #include "a68g-transput.h"
  35  
  36  // Constant folder                                                .
  37  // Uses interpreter routines to calculate compile-time expressions.
  38  
  39  //! @brief Whether mode is handled by the constant folder.
  40  
  41  BOOL_T folder_mode (MOID_T * m)
  42  {
  43    if (primitive_mode (m)) {
  44      return A68_TRUE;
  45    } else if (m == M_COMPLEX) {
  46      return A68_TRUE;
  47    } else {
  48      return A68_FALSE;
  49    }
  50  }
  51  
  52  // Constant unit check.
  53  
  54  //! @brief Whether constant collateral clause.
  55  
  56  BOOL_T constant_collateral (NODE_T * p)
  57  {
  58    if (p == NO_NODE) {
  59      return A68_TRUE;
  60    } else if (IS (p, UNIT)) {
  61      return (BOOL_T) (folder_mode (MOID (p)) && constant_unit (SUB (p)) && constant_collateral (NEXT (p)));
  62    } else {
  63      return (BOOL_T) (constant_collateral (SUB (p)) && constant_collateral (NEXT (p)));
  64    }
  65  }
  66  
  67  //! @brief Whether constant serial clause.
  68  
  69  void count_constant_units (NODE_T * p, int *total, int *good)
  70  {
  71    if (p != NO_NODE) {
  72      if (IS (p, UNIT)) {
  73        (*total)++;
  74        if (constant_unit (p)) {
  75          (*good)++;
  76        }
  77        count_constant_units (NEXT (p), total, good);
  78      } else {
  79        count_constant_units (SUB (p), total, good);
  80        count_constant_units (NEXT (p), total, good);
  81      }
  82    }
  83  }
  84  
  85  //! @brief Whether constant serial clause.
  86  
  87  BOOL_T constant_serial (NODE_T * p, int want)
  88  {
  89    int total = 0, good = 0;
  90    count_constant_units (p, &total, &good);
  91    if (want > 0) {
  92      return total == want && total == good;
  93    } else {
  94      return total == good;
  95    }
  96  }
  97  
  98  //! @brief Whether constant argument.
  99  
 100  BOOL_T constant_argument (NODE_T * p)
 101  {
 102    if (p == NO_NODE) {
 103      return A68_TRUE;
 104    } else if (IS (p, UNIT)) {
 105      return (BOOL_T) (folder_mode (MOID (p)) && constant_unit (p) && constant_argument (NEXT (p)));
 106    } else {
 107      return (BOOL_T) (constant_argument (SUB (p)) && constant_argument (NEXT (p)));
 108    }
 109  }
 110  
 111  //! @brief Whether constant call.
 112  
 113  BOOL_T constant_call (NODE_T * p)
 114  {
 115    if (IS (p, CALL)) {
 116      NODE_T *prim = SUB (p);
 117      NODE_T *idf = stems_from (prim, IDENTIFIER);
 118      if (idf != NO_NODE) {
 119        int k;
 120        for (k = 0; PROCEDURE (&functions[k]) != NO_GPROC; k++) {
 121          if (PROCEDURE (TAX (idf)) == PROCEDURE (&functions[k])) {
 122            NODE_T *args = NEXT (prim);
 123            return constant_argument (args);
 124          }
 125        }
 126      }
 127    }
 128    return A68_FALSE;
 129  }
 130  
 131  //! @brief Whether constant monadic formula.
 132  
 133  BOOL_T constant_monadic_formula (NODE_T * p)
 134  {
 135    if (IS (p, MONADIC_FORMULA)) {
 136      NODE_T *op = SUB (p);
 137      int k;
 138      for (k = 0; PROCEDURE (&monadics[k]) != NO_GPROC; k++) {
 139        if (PROCEDURE (TAX (op)) == PROCEDURE (&monadics[k])) {
 140          NODE_T *rhs = NEXT (op);
 141          return constant_unit (rhs);
 142        }
 143      }
 144    }
 145    return A68_FALSE;
 146  }
 147  
 148  //! @brief Whether constant dyadic formula.
 149  
 150  BOOL_T constant_formula (NODE_T * p)
 151  {
 152    if (IS (p, FORMULA)) {
 153      NODE_T *lhs = SUB (p);
 154      NODE_T *op = NEXT (lhs);
 155      if (op == NO_NODE) {
 156        return constant_monadic_formula (lhs);
 157      } else {
 158        int k;
 159        for (k = 0; PROCEDURE (&dyadics[k]) != NO_GPROC; k++) {
 160          if (PROCEDURE (TAX (op)) == PROCEDURE (&dyadics[k])) {
 161            NODE_T *rhs = NEXT (op);
 162            return (BOOL_T) (constant_unit (lhs) && constant_unit (rhs));
 163          }
 164        }
 165      }
 166    }
 167    return A68_FALSE;
 168  }
 169  
 170  //! @brief Whether constant unit.
 171  
 172  BOOL_T constant_unit (NODE_T * p)
 173  {
 174    if (p == NO_NODE) {
 175      return A68_FALSE;
 176    } else if (IS (p, UNIT)) {
 177      return constant_unit (SUB (p));
 178    } else if (IS (p, TERTIARY)) {
 179      return constant_unit (SUB (p));
 180    } else if (IS (p, SECONDARY)) {
 181      return constant_unit (SUB (p));
 182    } else if (IS (p, PRIMARY)) {
 183      return constant_unit (SUB (p));
 184    } else if (IS (p, ENCLOSED_CLAUSE)) {
 185      return constant_unit (SUB (p));
 186    } else if (IS (p, CLOSED_CLAUSE)) {
 187      return constant_serial (NEXT_SUB (p), 1);
 188    } else if (IS (p, COLLATERAL_CLAUSE)) {
 189      return folder_mode (MOID (p)) && constant_collateral (NEXT_SUB (p));
 190    } else if (IS (p, WIDENING)) {
 191      if (WIDEN_TO (p, INT, REAL)) {
 192        return constant_unit (SUB (p));
 193      } else if (WIDEN_TO (p, REAL, COMPLEX)) {
 194        return constant_unit (SUB (p));
 195      } else {
 196        return A68_FALSE;
 197      }
 198    } else if (IS (p, IDENTIFIER)) {
 199      if (A68_STANDENV_PROC (TAX (p))) {
 200        int k;
 201        for (k = 0; PROCEDURE (&constants[k]) != NO_GPROC; k++) {
 202          if (PROCEDURE (TAX (p)) == PROCEDURE (&constants[k])) {
 203            return A68_TRUE;
 204          }
 205        }
 206        return A68_FALSE;
 207      } else {
 208  // Possible constant folding.
 209        NODE_T *def = NODE (TAX (p));
 210        BOOL_T ret = A68_FALSE;
 211        if (STATUS (p) & COOKIE_MASK) {
 212          diagnostic (A68_WARNING, p, WARNING_UNINITIALISED);
 213        } else {
 214          STATUS (p) |= COOKIE_MASK;
 215          if (folder_mode (MOID (p)) && def != NO_NODE && NEXT (def) != NO_NODE && IS (NEXT (def), EQUALS_SYMBOL)) {
 216            ret = constant_unit (NEXT_NEXT (def));
 217          }
 218        }
 219        STATUS (p) &= !(COOKIE_MASK);
 220        return ret;
 221      }
 222    } else if (IS (p, DENOTATION)) {
 223      return primitive_mode (MOID (p));
 224    } else if (IS (p, MONADIC_FORMULA)) {
 225      return (BOOL_T) (folder_mode (MOID (p)) && constant_monadic_formula (p));
 226    } else if (IS (p, FORMULA)) {
 227      return (BOOL_T) (folder_mode (MOID (p)) && constant_formula (p));
 228    } else if (IS (p, CALL)) {
 229      return (BOOL_T) (folder_mode (MOID (p)) && constant_call (p));
 230    } else if (IS (p, CAST)) {
 231      return (BOOL_T) (folder_mode (MOID (SUB (p))) && constant_unit (NEXT_SUB (p)));
 232    } else {
 233      return A68_FALSE;
 234    }
 235  }
 236  
 237  // Evaluate compile-time expressions using interpreter routines.
 238  
 239  //! @brief Push denotation.
 240  
 241  void push_denotation (NODE_T * p)
 242  {
 243  #define PUSH_DENOTATION(mode, decl) {\
 244    decl z;\
 245    NODE_T *s = (IS (SUB (p), SHORTETY) ? NEXT_SUB (p) : SUB (p));\
 246    if (genie_string_to_value_internal (p, MODE (mode), NSYMBOL (s), (BYTE_T *) & z) == A68_FALSE) {\
 247      diagnostic (A68_SYNTAX_ERROR, p, ERROR_IN_DENOTATION, MODE (mode));\
 248    }\
 249    PUSH_VALUE (p, VALUE (&z), decl);}
 250  
 251    if (MOID (p) == M_INT) {
 252      PUSH_DENOTATION (INT, A68_INT);
 253    } else if (MOID (p) == M_REAL) {
 254      PUSH_DENOTATION (REAL, A68_REAL);
 255    } else if (MOID (p) == M_BOOL) {
 256      PUSH_DENOTATION (BOOL, A68_BOOL);
 257    } else if (MOID (p) == M_CHAR) {
 258      if ((NSYMBOL (p))[0] == NULL_CHAR) {
 259        PUSH_VALUE (p, NULL_CHAR, A68_CHAR);
 260      } else {
 261        PUSH_VALUE (p, (NSYMBOL (p))[0], A68_CHAR);
 262      }
 263    } else if (MOID (p) == M_BITS) {
 264      PUSH_DENOTATION (BITS, A68_BITS);
 265    }
 266  #undef PUSH_DENOTATION
 267  }
 268  
 269  //! @brief Push widening.
 270  
 271  void push_widening (NODE_T * p)
 272  {
 273    push_unit (SUB (p));
 274    if (WIDEN_TO (p, INT, REAL)) {
 275      A68_INT k;
 276      POP_OBJECT (p, &k, A68_INT);
 277      PUSH_VALUE (p, (REAL_T) VALUE (&k), A68_REAL);
 278    } else if (WIDEN_TO (p, REAL, COMPLEX)) {
 279      PUSH_VALUE (p, 0.0, A68_REAL);
 280    }
 281  }
 282  
 283  //! @brief Code collateral units.
 284  
 285  void push_collateral_units (NODE_T * p)
 286  {
 287    if (p == NO_NODE) {
 288      return;
 289    } else if (IS (p, UNIT)) {
 290      push_unit (p);
 291    } else {
 292      push_collateral_units (SUB (p));
 293      push_collateral_units (NEXT (p));
 294    }
 295  }
 296  
 297  //! @brief Code argument.
 298  
 299  void push_argument (NODE_T * p)
 300  {
 301    for (; p != NO_NODE; FORWARD (p)) {
 302      if (IS (p, UNIT)) {
 303        push_unit (p);
 304      } else {
 305        push_argument (SUB (p));
 306      }
 307    }
 308  }
 309  
 310  //! @brief Push unit.
 311  
 312  void push_unit (NODE_T * p)
 313  {
 314    if (p == NO_NODE) {
 315      return;
 316    }
 317    if (IS (p, UNIT)) {
 318      push_unit (SUB (p));
 319    } else if (IS (p, TERTIARY)) {
 320      push_unit (SUB (p));
 321    } else if (IS (p, SECONDARY)) {
 322      push_unit (SUB (p));
 323    } else if (IS (p, PRIMARY)) {
 324      push_unit (SUB (p));
 325    } else if (IS (p, ENCLOSED_CLAUSE)) {
 326      push_unit (SUB (p));
 327    } else if (IS (p, CLOSED_CLAUSE)) {
 328      push_unit (SUB (NEXT_SUB (p)));
 329    } else if (IS (p, COLLATERAL_CLAUSE)) {
 330      push_collateral_units (NEXT_SUB (p));
 331    } else if (IS (p, WIDENING)) {
 332      push_widening (p);
 333    } else if (IS (p, IDENTIFIER)) {
 334      if (A68_STANDENV_PROC (TAX (p))) {
 335        (void) (*(PROCEDURE (TAX (p)))) (p);
 336      } else {
 337  // Possible constant folding 
 338        NODE_T *def = NODE (TAX (p));
 339        push_unit (NEXT_NEXT (def));
 340      }
 341    } else if (IS (p, DENOTATION)) {
 342      push_denotation (p);
 343    } else if (IS (p, MONADIC_FORMULA)) {
 344      NODE_T *op = SUB (p);
 345      NODE_T *rhs = NEXT (op);
 346      push_unit (rhs);
 347      (*(PROCEDURE (TAX (op)))) (op);
 348    } else if (IS (p, FORMULA)) {
 349      NODE_T *lhs = SUB (p);
 350      NODE_T *op = NEXT (lhs);
 351      if (op == NO_NODE) {
 352        push_unit (lhs);
 353      } else {
 354        NODE_T *rhs = NEXT (op);
 355        push_unit (lhs);
 356        push_unit (rhs);
 357        (*(PROCEDURE (TAX (op)))) (op);
 358      }
 359    } else if (IS (p, CALL)) {
 360      NODE_T *prim = SUB (p);
 361      NODE_T *args = NEXT (prim);
 362      NODE_T *idf = stems_from (prim, IDENTIFIER);
 363      push_argument (args);
 364      (void) (*(PROCEDURE (TAX (idf)))) (p);
 365    } else if (IS (p, CAST)) {
 366      push_unit (NEXT_SUB (p));
 367    }
 368  }
 369  
 370  //! @brief Code constant folding.
 371  
 372  void constant_folder (NODE_T * p, FILE_T out, int phase)
 373  {
 374    if (phase == L_DECLARE) {
 375      if (MOID (p) == M_COMPLEX) {
 376        char acc[NAME_SIZE];
 377        A68_REAL re, im;
 378        (void) make_name (acc, CON, "", NUMBER (p));
 379        A68_SP = 0;
 380        push_unit (p);
 381        POP_OBJECT (p, &im, A68_REAL);
 382        POP_OBJECT (p, &re, A68_REAL);
 383        indentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "A68_COMPLEX %s = {", acc));
 384        undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "{INIT_MASK, %.*g}", REAL_WIDTH + 2, VALUE (&re)));
 385        undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, ", {INIT_MASK, %.*g}", REAL_WIDTH + 2, VALUE (&im)));
 386        undent (out, "};\n");
 387        ABEND (A68_SP > 0, ERROR_INTERNAL_CONSISTENCY, __func__);
 388      }
 389    } else if (phase == L_EXECUTE) {
 390      if (MOID (p) == M_COMPLEX) {
 391  // Done at declaration stage 
 392      }
 393    } else if (phase == L_YIELD) {
 394      if (MOID (p) == M_INT) {
 395        A68_INT k;
 396        A68_SP = 0;
 397        push_unit (p);
 398        POP_OBJECT (p, &k, A68_INT);
 399        ASSERT (snprintf (A68 (edit_line), SNPRINTF_SIZE, A68_LD, VALUE (&k)) >= 0);
 400        undent (out, A68 (edit_line));
 401        ABEND (A68_SP > 0, ERROR_INTERNAL_CONSISTENCY, __func__);
 402      } else if (MOID (p) == M_REAL) {
 403        A68_REAL x;
 404        A68_SP = 0;
 405        push_unit (p);
 406        POP_OBJECT (p, &x, A68_REAL);
 407  // Mind overflowing or underflowing values.
 408        if (!finite (VALUE (&x))) {
 409          A68_OPT (code_errors)++;
 410          VALUE (&x) = 0.0;
 411        }
 412        if (VALUE (&x) == REAL_MAX) {
 413          undent (out, "REAL_MAX");
 414        } else if (VALUE (&x) == -REAL_MAX) {
 415          undent (out, "(-REAL_MAX)");
 416        } else {
 417          ASSERT (snprintf (A68 (edit_line), SNPRINTF_SIZE, "%.*g", REAL_WIDTH + 2, VALUE (&x)) >= 0);
 418          undent (out, A68 (edit_line));
 419        }
 420        ABEND (A68_SP > 0, ERROR_INTERNAL_CONSISTENCY, __func__);
 421      } else if (MOID (p) == M_BOOL) {
 422        A68_BOOL b;
 423        A68_SP = 0;
 424        push_unit (p);
 425        POP_OBJECT (p, &b, A68_BOOL);
 426        ASSERT (snprintf (A68 (edit_line), SNPRINTF_SIZE, "%s", (VALUE (&b) ? "A68_TRUE" : "A68_FALSE")) >= 0);
 427        undent (out, A68 (edit_line));
 428        ABEND (A68_SP > 0, ERROR_INTERNAL_CONSISTENCY, __func__);
 429      } else if (MOID (p) == M_CHAR) {
 430        A68_CHAR c;
 431        A68_SP = 0;
 432        push_unit (p);
 433        POP_OBJECT (p, &c, A68_CHAR);
 434        if (VALUE (&c) == '\'') {
 435          undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "'\\\''"));
 436        } else if (VALUE (&c) == '\\') {
 437          undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "'\\\\'"));
 438        } else if (VALUE (&c) == NULL_CHAR) {
 439          undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "NULL_CHAR"));
 440        } else if (IS_PRINT (VALUE (&c))) {
 441          undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "'%c'", (CHAR_T) VALUE (&c)));
 442        } else {
 443          undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "(CHAR_T) %d", VALUE (&c)));
 444        }
 445        ABEND (A68_SP > 0, ERROR_INTERNAL_CONSISTENCY, __func__);
 446      } else if (MOID (p) == M_BITS) {
 447        A68_BITS b;
 448        A68_SP = 0;
 449        push_unit (p);
 450        POP_OBJECT (p, &b, A68_BITS);
 451        ASSERT (snprintf (A68 (edit_line), SNPRINTF_SIZE, "(UNSIGNED_T) 0x" A68_LX, VALUE (&b)) >= 0);
 452        undent (out, A68 (edit_line));
 453        ABEND (A68_SP > 0, ERROR_INTERNAL_CONSISTENCY, __func__);
 454      } else if (MOID (p) == M_COMPLEX) {
 455        char acc[NAME_SIZE];
 456        (void) make_name (acc, CON, "", NUMBER (p));
 457        undentf (out, snprintf (A68 (edit_line), SNPRINTF_SIZE, "(A68_REAL *) %s", acc));
 458      }
 459    }
 460  }