//! @file type.c
//! @author J. Marcel van der Veer
//
//! @section Copyright
//
// This file is part of VIF - vintage FORTRAN compiler.
// Copyright 2020-2025 J. Marcel van der Veer <algol68g@xs4all.nl>.
//
//! @section License
//
// This program is free software; you can redistribute it and/or modify it 
// under the terms of the GNU General Public License as published by the 
// Free Software Foundation; either version 3 of the License, or 
// (at your option) any later version.
//
// This program is distributed in the hope that it will be useful, but 
// WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 
// or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for 
// more details. You should have received a copy of the GNU General Public 
// License along with this program. If not, see <http://www.gnu.org/licenses/>.

//! @section Synopsis
//!
//! Type routines.

#include <vif.h>

void compute_row_size (RECORD buf, IDENT *idf)
{
  NEW_RECORD (str);
  for (int_4 n = 0; n < idf->mode.dim; n++) {
    if (EQUAL (idf->len[n], "VARY")) {
      _srecordf (buf, "VARY");
      return;
    } else {
      fold_int_4 (buf, idf->len[n]);
    }
    if (is_int4 (buf, NO_REF_INTEGER)) {
      bufcat (str, buf, RECLN);
    } else {
      bufcat (str,"(", RECLN);
      bufcat (str, buf, RECLN);
      bufcat (str,")", RECLN);
    }
    if (n < idf->mode.dim - 1) {
      bufcat (str, " * ", RECLN);
    }
  }
  fold_int_4 (buf, str);
}

void norm_mode (MODE *mode)
{
  if (mode != NO_MODE && mode->type == CHARACTER) {
    if (mode->len == 0) {
// CHARACTER*(*)
      return;
    }
    for (int k = 0, lim = 2; k < MAX_STRLENS; k++, lim *= 2) {
      if (lim > mode->len) {
        strlens[k] = TRUE;
        mode->len = lim - 1;
        return;
      }
    }
    NEW_RECORD (str);
    _srecordf (str, "%d", mode->len);
    ERROR (3401, "character length overflow", str);
    mode->len = MAX_STRLEN;
  }
}

void default_impl (void)
{
  int_4 k;
  for (k = ord ('a'); k <= ord ('h'); k++) {
    if (implicit_r8) {
      f2c_type ("real*8", &(implic[k].mode), NOARG, NOFUN);
    } else {
      f2c_type ("real*4", &(implic[k].mode), NOARG, NOFUN);
    }
    implic[k].mode.save = STATIC;
  }
  for (k = ord ('i'); k <= ord ('n'); k++) {
    f2c_type ("integer*4", &(implic[k].mode), NOARG, NOFUN);
    implic[k].mode.save = STATIC;
  }
  for (k = ord ('o'); k <= ord ('z'); k++) {
    if (implicit_r8) {
      f2c_type ("real*8", &(implic[k].mode), NOARG, NOFUN);
    } else {
      f2c_type ("real*4", &(implic[k].mode), NOARG, NOFUN);
    }
    implic[k].mode.save = STATIC;
  }
  implic[k].mode.save = STATIC;
}

char *qtype (MODE * mode)
{
  NEW_RECORD (t);
  if (mode->type == NOTYPE) {
    _srecordf (t, "%s", "void");
  } else if (mode->type == ETYPE) {
    _srecordf (t, "%s", "type error");
  } else if (mode->len > 0) {
    switch (mode->type) {
    case INTEGER:
      _srecordf (t, "%s*%d", "integer", mode->len);
      break;
    case LOGICAL:
      _srecordf (t, "%s*%d", "logical", mode->len);
      break;
    case REAL:
      _srecordf (t, "%s*%d", "real", mode->len);
      break;
    case COMPLEX:
      _srecordf (t, "%s*%d", "complex", mode->len);
      break;
    case CHARACTER:
      _srecordf (t, "%s*%d", "character", mode->len);
      break;
    }
  } else {
    switch (mode->type) {
    case INTEGER:
      _srecordf (t, "%s", "integer");
      break;
    case LOGICAL:
      _srecordf (t, "%s", "logical");
      break;
    case REAL:
      _srecordf (t, "%s", "real");
      break;
    case COMPLEX:
      _srecordf (t, "%s", "complex");
      break;
    case CHARACTER:
      _srecordf (t, "%s", "character");
      break;
    }
  }
  return f_stralloc (t);
}

char *wtype (MODE * mode, int_4 arg, int_4 fun)
{
  switch (mode->type) {
  case INTEGER:{
      if (mode->len == 2) {
        return (arg ? "int_2 _p_ " : "int_2");
      } else if (mode->len == 4) {
        return (arg ? "int_4 _p_ " : "int_4");
      } else if (mode->len == 8) {
        return (arg ? "int_8 _p_ " : "int_8");
      } else {
        return "notype";
      }
    }
  case LOGICAL:
    if (arg) {
      return "logical_4 _p_ ";
    } else {
      return "logical_4";
    }
  case REAL:
    if (mode->len == 4) {
      return (arg ? "real_4 _p_ " : "real_4");
    } else if (mode->len == 8) {
      return (arg ? "real_8 _p_ " : "real_8");
    } else if (mode->len == 16) {
      return (arg ? "real_16 _p_ " : "real_16");
    } else if (mode->len == 32) {
      return (arg ? "real_32 _p_ " : "real_32");
    } else {
      return "notype";
    }
  case COMPLEX:
    if (mode->len == 8) {
      return (arg ? "complex_8 _p_ " : "complex_8");
    } else if (mode->len == 16) {
      return (arg ? "complex_16 _p_ " : "complex_16");
    } else if (mode->len == 32) {
      return (arg ? "complex_32 _p_ " : "complex_32");
    } else if (mode->len == 64) {
      return (arg ? "complex_64 _p_ " : "complex_64");
    } else {
      return "notype";
    }
  case CHARACTER:{
      if (fun || arg) {
        return "char _p_ ";
      } else {
        NEW_RECORD (str);
        _srecordf (str, "char_%d", mode->len);
        return f_stralloc (str);
      }
    }
  case NOTYPE: { // C routine type
      return "int_4";
    }
  default: {
      return "notype";
    }
  }
}

char *f2c_type (char *ftype, MODE * mode, int_4 arg, int_4 fun)
{
  MODE m = (MODE) {.type = NOTYPE,.len = NOLEN,.dim = 0 };
  int_4 found = FALSE;
#define TEST(name, f_type, f_len, f_trunc)\
  if (EQUAL (ftype, name)) {\
    m = (MODE) {.type = f_type, .len = f_trunc, .dim = 0};\
    found = TRUE;\
  }
  TEST ("none", NOTYPE, 0, 0);
  TEST ("doublecomplex", COMPLEX, 16, 16);
  TEST ("doubleprecision", REAL, 8, 8);
  TEST ("logical", LOGICAL, 4, 4);
  TEST ("logical*1", LOGICAL, 1, 4);
  TEST ("logical*2", LOGICAL, 2, 4);
  TEST ("logical*4", LOGICAL, 4, 4);
  TEST ("logical*8", LOGICAL, 8, 4);
  TEST ("integer", INTEGER, 4, 4);
  TEST ("integer*1", INTEGER, 2, 2);
  TEST ("integer*2", INTEGER, 2, 2);
  TEST ("integer*4", INTEGER, 4, 4);
  TEST ("integer*8", INTEGER, 8, 8);
  if (implicit_r8) {
    TEST ("real", REAL, 8, 8);
  } else {
    TEST ("real", REAL, 4, 4);
  }
  TEST ("real*4", REAL, 4, 4);
  TEST ("real*8", REAL, 8, 8);
  TEST ("real*16", REAL, 16, 16);
  TEST ("real*32", REAL, 32, 32);
  if (implicit_r8) {
    TEST ("complex", COMPLEX, 16, 16);
  } else {
    TEST ("complex", COMPLEX, 8, 8);
  }
  TEST ("complex*8", COMPLEX, 8, 8);
  TEST ("complex*16", COMPLEX, 16, 16);
  TEST ("complex*32", COMPLEX, 32, 32);
  TEST ("complex*64", COMPLEX, 64, 64);
  TEST ("character", CHARACTER, 1, 1);
  if (LEQUAL ("character*", ftype)) {
    int_4 len;
    if (strcmp (ftype, "character*(*)") == 0) {
      m = (MODE) {.type = CHARACTER, .len = 0, .dim = 0};
      found = TRUE;
    } else {
      char *op = strchr (ftype, '('), *cl = strrchr(ftype, ')');
      if (op != NO_TEXT && cl != NO_TEXT) {
        NEW_RECORD (fact);
        _srecordf (fact, "%s", ++op);
        if (strlen (fact) > 0 && fact[strlen (fact) - 1] == ')') {
          fact[strlen (fact) - 1] = '\0';
        }
        if (!is_int4 (fact, &len)) {
          MODE pm;
          IDENT *idf = find_local (fact, &pm);
          if (idf->parm != NO_TEXT && idf->mode.type == INTEGER) {
            (void) is_int4 (idf->parm, &len);
          } else {
            ERROR (3402, "invalid length", fact);
            len = MAX_STRLEN;
          }
        } 
      } else {
        sscanf (ftype, "character*%d", &len);
      }
      m = (MODE) {.type = CHARACTER, .len = len, .dim = 0};
      found = TRUE;
    }
    if (found && m.len > 1) {
      norm_mode (&m);
    }
  }
  if (mode != NO_MODE) {
    *mode = m;
  }
  if (found) {
    return (wtype (&m, arg, fun));
  } else {
    ERROR (3403, "unknown type", ftype);
    return "notype";
  }
}

char *ptr_to_array (IDENT * idf, int_4 constant, int_4 cast, int_4 formal)
{
  NEW_RECORD (str);
  NEW_RECORD (name);
  if (formal) {
    _srecordf (name, "%s", edit_f (C_NAME (idf)));
  } else {
    _srecordf (name, "%s", C_NAME (idf));
  }
  if (idf->mode.dim <= 1) {
    if (cast) {
      _srecordf (str, "(%s _p_)", wtype (&idf->mode, NOARG, NOFUN));
    } else if (constant) {
      _srecordf (str, "_p_ const %s", name);
    } else {
      _srecordf (str, "_p_ %s", name);
    }
  } else {
    if (cast) {
      _srecordf (str, "(%s (_p_)", wtype (&idf->mode, NOARG, NOFUN));
    } else if (constant) {
      _srecordf (str, "(_p_ const %s)", name);
    } else {
      _srecordf (str, "(_p_ %s)", name);
    }
    if (cast) {
      bufcat (str, ")", RECLN);
    }
  }
  return f_stralloc (str);
}

logical_4 accept_mode (int_4 Lt, int_4 Ll, int_4 Rt, int_4 Rl)
{
// Whether L is acceptable to R.
  if (Rt == REAL && Lt == REAL) {
    return Ll <= Rl;
  }
  if (Rt == INTEGER && Lt == INTEGER) {
    return Ll <= Rl;
  }
  if (Rt == LOGICAL && Lt == LOGICAL) {
    return Ll <= Rl;
  }
  if (Rt == REAL && Lt == INTEGER) {
    return Ll <= Rl;
  } 
  if (Rt == COMPLEX && Lt == REAL) {
    return 2 * Ll <= Rl;
  }
  if (Rt == COMPLEX && Lt == INTEGER) {
    return 2 * Ll <= Rl;
  }
  if (Rt == INTEGER && Lt == CHARACTER) {
    return Rl == 4;
  }
  if (Rt == INTEGER && Lt == REAL) {
    return FALSE;
  }
// Generic cases.
  if (Rt == NOTYPE) {
    return TRUE;
  } else if (Lt != Rt) {
    return FALSE;
  } else if (Rl == NOLEN) {
    return TRUE;
  }
  return Ll <= Rl;
}

