plugin-basic.c

     
   1  //! @file plugin-basic.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  //! Plugin compiler routines.
  25  
  26  #include "a68g.h"
  27  #include "a68g-optimiser.h"
  28  #include "a68g-plugin.h"
  29  
  30  // Whether stuff is sufficiently "basic" to be compiled.
  31  
  32  //! @brief Whether primitive mode, with simple C equivalent.
  33  
  34  BOOL_T primitive_mode (const MOID_T * m)
  35  {
  36    if (m == M_INT) {
  37      return A68_TRUE;
  38    } else if (m == M_REAL) {
  39      return A68_TRUE;
  40    } else if (m == M_BOOL) {
  41      return A68_TRUE;
  42    } else if (m == M_CHAR) {
  43      return A68_TRUE;
  44    } else if (m == M_BITS) {
  45      return A68_TRUE;
  46    } else {
  47      return A68_FALSE;
  48    }
  49  }
  50  
  51  //! @brief Whether basic mode, for which units are compiled.
  52  
  53  BOOL_T basic_mode (MOID_T * m)
  54  {
  55    if (primitive_mode (m)) {
  56      return A68_TRUE;
  57    } else if (IS (m, REF_SYMBOL)) {
  58      if (IS (SUB (m), REF_SYMBOL) || IS (SUB (m), PROC_SYMBOL)) {
  59        return A68_FALSE;
  60      } else {
  61        return basic_mode (SUB (m));
  62      }
  63    } else if (IS (m, ROW_SYMBOL)) {
  64      return A68_FALSE;
  65  // Not (fully) implemented yet.
  66  // TODO: code to convert stacked units into an array.
  67  //  if (primitive_mode (SUB (m))) {
  68  //    return A68_TRUE;
  69  //  } else if (IS (SUB (m), STRUCT_SYMBOL)) {
  70  //    return basic_mode (SUB (m));
  71  //  } else {
  72  //    return A68_FALSE;
  73  //  }
  74    } else if (IS (m, STRUCT_SYMBOL)) {
  75      for (PACK_T *p = PACK (m); p != NO_PACK; FORWARD (p)) {
  76        if (!primitive_mode (MOID (p))) {
  77          return A68_FALSE;
  78        }
  79      }
  80      return A68_TRUE;
  81    } else {
  82      return A68_FALSE;
  83    }
  84  }
  85  
  86  //! @brief Whether basic mode, which is not a row.
  87  
  88  BOOL_T basic_mode_non_row (MOID_T * m)
  89  {
  90    if (primitive_mode (m)) {
  91      return A68_TRUE;
  92    } else if (IS (m, REF_SYMBOL)) {
  93      if (IS (SUB (m), REF_SYMBOL) || IS (SUB (m), PROC_SYMBOL)) {
  94        return A68_FALSE;
  95      } else {
  96        return basic_mode_non_row (SUB (m));
  97      }
  98    } else if (IS (m, STRUCT_SYMBOL)) {
  99      for (PACK_T *p = PACK (m); p != NO_PACK; FORWARD (p)) {
 100        if (!primitive_mode (MOID (p))) {
 101          return A68_FALSE;
 102        }
 103      }
 104      return A68_TRUE;
 105    } else {
 106      return A68_FALSE;
 107    }
 108  }
 109  
 110  //! @brief Whether basic collateral clause.
 111  
 112  BOOL_T basic_collateral (NODE_T * p)
 113  {
 114    if (p == NO_NODE) {
 115      return A68_TRUE;
 116    } else if (IS (p, UNIT)) {
 117      return (BOOL_T) (basic_mode (MOID (p)) && basic_unit (SUB (p)) && basic_collateral (NEXT (p)));
 118    } else {
 119      return (BOOL_T) (basic_collateral (SUB (p)) && basic_collateral (NEXT (p)));
 120    }
 121  }
 122  
 123  //! @brief Whether basic serial clause.
 124  
 125  void count_basic_units (NODE_T * p, int *total, int *good)
 126  {
 127    for (; p != NO_NODE; FORWARD (p)) {
 128      if (IS (p, UNIT)) {
 129        (*total)++;
 130        if (basic_unit (p)) {
 131          (*good)++;
 132        }
 133      } else if (IS (p, DECLARATION_LIST)) {
 134        (*total)++;
 135      } else {
 136        count_basic_units (SUB (p), total, good);
 137      }
 138    }
 139  }
 140  
 141  //! @brief Whether basic serial clause.
 142  
 143  BOOL_T basic_serial (NODE_T * p, int want)
 144  {
 145    int total = 0, good = 0;
 146    count_basic_units (p, &total, &good);
 147    if (want > 0) {
 148      return total == want && total == good;
 149    } else {
 150      return total == good;
 151    }
 152  }
 153  
 154  //! @brief Whether basic indexer.
 155  
 156  BOOL_T basic_indexer (NODE_T * p)
 157  {
 158    if (p == NO_NODE) {
 159      return A68_TRUE;
 160    } else if (IS (p, TRIMMER)) {
 161      return A68_FALSE;
 162    } else if (IS (p, UNIT)) {
 163      return basic_unit (p);
 164    } else {
 165      return (BOOL_T) (basic_indexer (SUB (p)) && basic_indexer (NEXT (p)));
 166    }
 167  }
 168  
 169  //! @brief Whether basic slice.
 170  
 171  BOOL_T basic_slice (NODE_T * p)
 172  {
 173    if (IS (p, SLICE)) {
 174      NODE_T *prim = SUB (p);
 175      NODE_T *idf = stems_from (prim, IDENTIFIER);
 176      if (idf != NO_NODE) {
 177        NODE_T *indx = NEXT (prim);
 178        return basic_indexer (indx);
 179      }
 180    }
 181    return A68_FALSE;
 182  }
 183  
 184  //! @brief Whether basic argument.
 185  
 186  BOOL_T basic_argument (NODE_T * p)
 187  {
 188    if (p == NO_NODE) {
 189      return A68_TRUE;
 190    } else if (IS (p, UNIT)) {
 191      return (BOOL_T) (basic_mode (MOID (p)) && basic_unit (p) && basic_argument (NEXT (p)));
 192    } else {
 193      return (BOOL_T) (basic_argument (SUB (p)) && basic_argument (NEXT (p)));
 194    }
 195  }
 196  
 197  //! @brief Whether basic call.
 198  
 199  BOOL_T basic_call (NODE_T * p)
 200  {
 201    if (IS (p, CALL)) {
 202      NODE_T *prim = SUB (p);
 203      NODE_T *idf = stems_from (prim, IDENTIFIER);
 204      if (idf == NO_NODE) {
 205        return A68_FALSE;
 206      } else if (SUB_MOID (idf) == MOID (p)) {    // Prevent partial parametrisation
 207        for (int k = 0; PROCEDURE (&functions[k]) != NO_GPROC; k++) {
 208          if (PROCEDURE (TAX (idf)) == PROCEDURE (&functions[k])) {
 209            NODE_T *args = NEXT (prim);
 210            return basic_argument (args);
 211          }
 212        }
 213      }
 214    }
 215    return A68_FALSE;
 216  }
 217  
 218  //! @brief Whether basic monadic formula.
 219  
 220  BOOL_T basic_monadic_formula (NODE_T * p)
 221  {
 222    if (IS (p, MONADIC_FORMULA)) {
 223      NODE_T *op = SUB (p);
 224      for (int k = 0; PROCEDURE (&monadics[k]) != NO_GPROC; k++) {
 225        if (PROCEDURE (TAX (op)) == PROCEDURE (&monadics[k])) {
 226          NODE_T *rhs = NEXT (op);
 227          return basic_unit (rhs);
 228        }
 229      }
 230    }
 231    return A68_FALSE;
 232  }
 233  
 234  //! @brief Whether basic dyadic formula.
 235  
 236  BOOL_T basic_formula (NODE_T * p)
 237  {
 238    if (IS (p, FORMULA)) {
 239      NODE_T *lhs = SUB (p);
 240      NODE_T *op = NEXT (lhs);
 241      if (op == NO_NODE) {
 242        return basic_monadic_formula (lhs);
 243      } else {
 244        for (int k = 0; PROCEDURE (&dyadics[k]) != NO_GPROC; k++) {
 245          if (PROCEDURE (TAX (op)) == PROCEDURE (&dyadics[k])) {
 246            NODE_T *rhs = NEXT (op);
 247            return (BOOL_T) (basic_unit (lhs) && basic_unit (rhs));
 248          }
 249        }
 250      }
 251    }
 252    return A68_FALSE;
 253  }
 254  
 255  //! @brief Whether basic conditional clause.
 256  
 257  BOOL_T basic_conditional (NODE_T * p)
 258  {
 259    if (!(IS (p, IF_PART) || IS (p, OPEN_PART))) {
 260      return A68_FALSE;
 261    }
 262    if (!basic_serial (NEXT_SUB (p), 1)) {
 263      return A68_FALSE;
 264    }
 265    FORWARD (p);
 266    if (!(IS (p, THEN_PART) || IS (p, CHOICE))) {
 267      return A68_FALSE;
 268    }
 269    if (!basic_serial (NEXT_SUB (p), 1)) {
 270      return A68_FALSE;
 271    }
 272    FORWARD (p);
 273    if (IS (p, ELSE_PART) || IS (p, CHOICE)) {
 274      return basic_serial (NEXT_SUB (p), 1);
 275    } else if (IS (p, FI_SYMBOL)) {
 276      return A68_TRUE;
 277    } else {
 278      return A68_FALSE;
 279    }
 280  }
 281  
 282  //! @brief Whether basic unit.
 283  
 284  BOOL_T basic_unit (NODE_T * p)
 285  {
 286    if (p == NO_NODE) {
 287      return A68_FALSE;
 288    } else if (IS (p, UNIT)) {
 289      return basic_unit (SUB (p));
 290    } else if (IS (p, TERTIARY)) {
 291      return basic_unit (SUB (p));
 292    } else if (IS (p, SECONDARY)) {
 293      return basic_unit (SUB (p));
 294    } else if (IS (p, PRIMARY)) {
 295      return basic_unit (SUB (p));
 296    } else if (IS (p, ENCLOSED_CLAUSE)) {
 297      return basic_unit (SUB (p));
 298    }
 299    if (A68_OPT (OPTION_CODE_LEVEL) >= 3) {
 300      if (IS (p, CLOSED_CLAUSE)) {
 301        return basic_serial (NEXT_SUB (p), 1);
 302      } else if (IS (p, COLLATERAL_CLAUSE)) {
 303        return basic_mode (MOID (p)) && basic_collateral (NEXT_SUB (p));
 304      } else if (IS (p, CONDITIONAL_CLAUSE)) {
 305        return basic_mode (MOID (p)) && basic_conditional (SUB (p));
 306      }
 307    }
 308    if (A68_OPT (OPTION_CODE_LEVEL) >= 2) {
 309      if (IS (p, VOIDING) && IS (SUB (p), ASSIGNATION) && stems_from (SUB_SUB (p), IDENTIFIER) != NO_NODE) {
 310        NODE_T *dst = SUB_SUB (p);
 311        NODE_T *src = NEXT_NEXT (dst);
 312        return (BOOL_T) basic_unit (src) && basic_mode_non_row (MOID (src));
 313      } else if (IS (p, VOIDING) && IS (SUB (p), ASSIGNATION) && stems_from (SUB_SUB (p), SLICE) != NO_NODE) {
 314        NODE_T *dst = SUB_SUB (p);
 315        NODE_T *src = NEXT_NEXT (dst);
 316        NODE_T *slice = stems_from (dst, SLICE);
 317        return (BOOL_T) (IS (MOID (slice), REF_SYMBOL) && basic_slice (slice) && basic_unit (src) && basic_mode_non_row (MOID (src)));
 318      } else if (IS (p, VOIDING) && IS (SUB (p), ASSIGNATION) && stems_from (SUB_SUB (p), SELECTION) != NO_NODE) {
 319        NODE_T *dst = SUB_SUB (p);
 320        NODE_T *src = NEXT_NEXT (dst);
 321        return (BOOL_T) (stems_from (NEXT_SUB (stems_from (dst, SELECTION)), IDENTIFIER) != NO_NODE && basic_unit (src) && basic_mode_non_row (MOID (dst)));
 322      } else if (IS (p, VOIDING)) {
 323        return basic_unit (SUB (p));
 324      } else if (IS (p, DEREFERENCING) && stems_from (SUB (p), SLICE)) {
 325        NODE_T *slice = stems_from (SUB (p), SLICE);
 326        return (BOOL_T) (basic_mode (MOID (p)) && IS (MOID (SUB (slice)), REF_SYMBOL) && basic_slice (slice));
 327      } else if (IS (p, DEREFERENCING) && stems_from (SUB (p), SELECTION)) {
 328        return (BOOL_T) (primitive_mode (MOID (p)) && BASIC (SUB (p), SELECTION));
 329      } else if (IS (p, WIDENING)) {
 330        if (WIDEN_TO (p, INT, REAL)) {
 331          return basic_unit (SUB (p));
 332        } else if (WIDEN_TO (p, REAL, COMPLEX)) {
 333          return basic_unit (SUB (p));
 334        } else {
 335          return A68_FALSE;
 336        }
 337      } else if (IS (p, CAST)) {
 338        return (BOOL_T) (folder_mode (MOID (SUB (p))) && basic_unit (NEXT_SUB (p)));
 339      } else if (IS (p, SLICE)) {
 340        return (BOOL_T) (basic_mode (MOID (p)) && basic_slice (p));
 341      } else if (IS (p, SELECTION)) {
 342        NODE_T *sec = stems_from (NEXT_SUB (p), IDENTIFIER);
 343        if (sec == NO_NODE) {
 344          return A68_FALSE;
 345        } else {
 346          return basic_mode_non_row (MOID (sec));
 347        }
 348      } else if (IS (p, IDENTITY_RELATION)) {
 349  #define GOOD(p) (stems_from (p, IDENTIFIER) != NO_NODE && IS (MOID (stems_from ((p), IDENTIFIER)), REF_SYMBOL))
 350        NODE_T *lhs = SUB (p);
 351        NODE_T *rhs = NEXT_NEXT (lhs);
 352        if (GOOD (lhs) && GOOD (rhs)) {
 353          return A68_TRUE;
 354        } else if (GOOD (lhs) && stems_from (rhs, NIHIL) != NO_NODE) {
 355          return A68_TRUE;
 356        } else {
 357          return A68_FALSE;
 358        }
 359  #undef GOOD
 360      }
 361    }
 362    if (A68_OPT (OPTION_CODE_LEVEL) >= 1) {
 363      if (IS (p, IDENTIFIER)) {
 364        if (A68_STANDENV_PROC (TAX (p))) {
 365          for (int k = 0; PROCEDURE (&constants[k]) != NO_GPROC; k++) {
 366            if (PROCEDURE (TAX (p)) == PROCEDURE (&constants[k])) {
 367              return A68_TRUE;
 368            }
 369          }
 370          return A68_FALSE;
 371        } else {
 372          return basic_mode (MOID (p));
 373        }
 374      } else if (IS (p, DEREFERENCING) && stems_from (SUB (p), IDENTIFIER)) {
 375        return (BOOL_T) (basic_mode (MOID (p)) && BASIC (SUB (p), IDENTIFIER));
 376      } else if (IS (p, DENOTATION)) {
 377        return primitive_mode (MOID (p));
 378      } else if (IS (p, MONADIC_FORMULA)) {
 379        return (BOOL_T) (basic_mode (MOID (p)) && basic_monadic_formula (p));
 380      } else if (IS (p, FORMULA)) {
 381        return (BOOL_T) (basic_mode (MOID (p)) && basic_formula (p));
 382      } else if (IS (p, CALL)) {
 383        return (BOOL_T) (basic_mode (MOID (p)) && basic_call (p));
 384      }
 385    }
 386    return A68_FALSE;
 387  }
 388  
     


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