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