Algol 68 Genie

call.c

     1  //! @file call.c
     2  //! @author J. Marcel van der Veer
     3  //
     4  //! @section Copyright
     5  //
     6  // This file is part of VIF - vintage FORTRAN compiler.
     7  // Copyright 2020-2025 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  //! Compile CALL and function calls.
    25  
    26  #include <vif.h>
    27  
    28  void code_parms (RECORD pack)
    29  {
    30    int_4 rc = scan (EXPECT_NONE);
    31    if (TOKEN ("(") && strlen (pack) == 0) {
    32      bufcat (pack, "(", RECLN);
    33      code_parms (pack);
    34    } else if (TOKEN (",")) {
    35      bufcat (pack, ", ", RECLN);
    36      code_parms (pack);
    37    } else if (TOKEN (")")) {
    38      bufcat (pack, ")", RECLN);
    39      return;
    40    } else {
    41      EXPR reg;
    42      NEW_RECORD (str);
    43      NEW_RECORD (name);
    44      RECCPY (name, curlex);
    45      memset (&reg, 0, sizeof (EXPR));
    46      express (&reg, NOTYPE, 0);
    47      if (reg.variant == EXPR_VAR) {
    48        if (IS_ROW (reg.mode) || reg.mode.type == CHARACTER) {
    49          _srecordf (str, "%s", reg.str);
    50        } else if (reg.str[0] == '*') {
    51          _srecordf (str, "%s", &reg.str[1]);
    52        } else if (reg.idf->external) {
    53          _srecordf (str, "%s", edit_f (reg.str));
    54        } else if (reg.idf->intrinsic) {
    55          _srecordf (str, "%s", edit_i (reg.str));
    56        } else if (reg.idf->arg || reg.idf->alias != NO_IDENT) {
    57          // Peephole optimization: &(*x) -> x
    58          _srecordf (str, "%s", C_NAME (reg.idf));
    59        } else {
    60          (void) impl_decl (name, NO_MODE);
    61          _srecordf (str, "&%s", reg.str);
    62        }
    63        bufcat (pack, str, RECLN);
    64      } else if (reg.variant == EXPR_SLICE) {
    65        _srecordf (str, "&%s", reg.str);
    66        bufcat (pack, str, RECLN);
    67      } else if (reg.variant == EXPR_CONST && reg.mode.type == CHARACTER) {
    68        bufcat (pack, reg.str, RECLN);
    69      } else if (reg.variant == EXPR_CONST && EQUAL (reg.str, "-1")) {
    70        bufcat (pack, "&_km1", RECLN);
    71      } else if (reg.variant == EXPR_CONST && EQUAL (reg.str, "0")) {
    72        bufcat (pack, "&_k0", RECLN);
    73      } else if (reg.variant == EXPR_CONST && EQUAL (reg.str, "1")) {
    74        bufcat (pack, "&_k1", RECLN);
    75      } else {
    76        NEW_RECORD (tmp);
    77        _srecordf (tmp, "%s", edit_tmp (nloctmps++));
    78        if (reg.mode.len > 0) {
    79          add_local (tmp, reg.mode.type, reg.mode.len, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
    80        } else {
    81          add_local (tmp, reg.mode.type, MAX_STRLEN, UNIQ, NOPATCH, NOARG, LOCAL, TEMP);
    82        }
    83        if (reg.mode.type == CHARACTER) {
    84          norm_mode (&reg.mode);
    85          _srecordf (str, "(bufcpy (%s, %s, %d), %s)", tmp, reg.str, reg.mode.len, tmp);
    86        } else {
    87          _srecordf (str, "(%s = %s, &%s)", tmp, reg.str, tmp);
    88        }
    89        bufcat (pack, str, RECLN);
    90      }
    91      code_parms (pack);
    92    }
    93    (void) rc;
    94  }
    95  
    96  void factor_function_call (EXPR *loc, RECORD name)
    97  {
    98    UNSCAN;
    99    MODE mode;
   100    IDENT *idf = find_local (name, &mode);
   101    NEW_RECORD (pack);
   102    curlin = prelin;
   103    curcol = precol;
   104    code_parms (pack);
   105    if (idf != NO_IDENT && idf->intrinsic) {
   106      _srecordf (loc->str, "%s %s", edit_i (name), pack);
   107    } else {
   108      _srecordf (loc->str, "%s %s", edit_f (name), pack);
   109    }
   110    loc->variant = EXPR_OTHER;
   111    loc->idf = NO_IDENT;
   112    if (idf == NO_IDENT) {
   113      idf = extf_decl (name, &(loc->mode));
   114    } else {
   115      loc->mode = idf->mode;
   116    }
   117    if (loc->mode.type == NOTYPE) {
   118      ERROR (401, "function has no type", name);
   119    }
   120    idf->external = TRUE;
   121    idf->used = TRUE;
   122  }
   123  
   124  void recursion (EXPR *loc, RECORD fun, IDENT * idf)
   125  {
   126    UNSCAN;
   127    NEW_RECORD (pack);
   128    curlin = prelin;
   129    curcol = precol;
   130    code_parms (pack);
   131    _srecordf (loc->str, "%s %s", edit_f (fun), pack);
   132    loc->variant = EXPR_OTHER;
   133    loc->idf = NO_IDENT;
   134    loc->mode = idf->mode;
   135  }
   136  
   137  void call (void)
   138  {
   139    int_4 rc = scan (EXPECT_NONE);
   140    NEW_RECORD (str);
   141    if (TOKEN ("exit")) {
   142      _srecordf (str, "_vif_exit ();\n");
   143      code (nprocs, BODY, str);
   144      _srecordf (str, "exit (EXIT_SUCCESS);\n", curlex);
   145      code (nprocs, BODY, str);
   146      return;
   147    } else {
   148      MODE mode;
   149      IDENT *idf = find_local (curlex, &mode);
   150      if (idf != NO_IDENT) {
   151        if (idf->arg == ARG) {
   152          idf->external = TRUE;
   153        }
   154        idf->used = TRUE;
   155        idf->mode = (MODE) {.type = INTEGER, .len = 4};
   156      }
   157      _srecordf (str, "(void) %s", edit_f (curlex));
   158      code (nprocs, BODY, str);
   159    }
   160    rc = scan (EXPECT_NONE);
   161    if (TOKEN ("(")) {
   162      UNSCAN;
   163      RECCLR (str);
   164      code_parms (str);
   165      code (nprocs, BODY, str);
   166    } else {
   167      if (rc != END_OF_LINE) {
   168        UNSCAN;
   169      }
   170      code (nprocs, BODY, " ()");
   171    }
   172    (void) rc;
   173  }
   174
Deze website is gearchiveerd door de KB, nationale bibliotheek.

This website is archived by the National Library of the Netherlands.