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

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