1/* Miscellaneous stuff that doesn't fit anywhere else.
2   Copyright (C) 2000-2020 Free Software Foundation, Inc.
3   Contributed by Andy Vaught
4
5This file is part of GCC.
6
7GCC is free software; you can redistribute it and/or modify it under
8the terms of the GNU General Public License as published by the Free
9Software Foundation; either version 3, or (at your option) any later
10version.
11
12GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13WARRANTY; without even the implied warranty of MERCHANTABILITY or
14FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
15for more details.
16
17You should have received a copy of the GNU General Public License
18along with GCC; see the file COPYING3.  If not see
19<http://www.gnu.org/licenses/>.  */
20
21#include "config.h"
22#include "system.h"
23#include "coretypes.h"
24#include "gfortran.h"
25#include "spellcheck.h"
26#include "tree.h"
27
28
29/* Initialize a typespec to unknown.  */
30
31void
32gfc_clear_ts (gfc_typespec *ts)
33{
34  ts->type = BT_UNKNOWN;
35  ts->u.derived = NULL;
36  ts->kind = 0;
37  ts->u.cl = NULL;
38  ts->interface = NULL;
39  /* flag that says if the type is C interoperable */
40  ts->is_c_interop = 0;
41  /* says what f90 type the C kind interops with */
42  ts->f90_type = BT_UNKNOWN;
43  /* flag that says whether it's from iso_c_binding or not */
44  ts->is_iso_c = 0;
45  ts->deferred = false;
46}
47
48
49/* Open a file for reading.  */
50
51FILE *
52gfc_open_file (const char *name)
53{
54  if (!*name)
55    return stdin;
56
57  return fopen (name, "r");
58}
59
60
61/* Return a string for each type.  */
62
63const char *
64gfc_basic_typename (bt type)
65{
66  const char *p;
67
68  switch (type)
69    {
70    case BT_INTEGER:
71      p = "INTEGER";
72      break;
73    case BT_REAL:
74      p = "REAL";
75      break;
76    case BT_COMPLEX:
77      p = "COMPLEX";
78      break;
79    case BT_LOGICAL:
80      p = "LOGICAL";
81      break;
82    case BT_CHARACTER:
83      p = "CHARACTER";
84      break;
85    case BT_HOLLERITH:
86      p = "HOLLERITH";
87      break;
88    case BT_UNION:
89      p = "UNION";
90      break;
91    case BT_DERIVED:
92      p = "DERIVED";
93      break;
94    case BT_CLASS:
95      p = "CLASS";
96      break;
97    case BT_PROCEDURE:
98      p = "PROCEDURE";
99      break;
100    case BT_VOID:
101      p = "VOID";
102      break;
103    case BT_BOZ:
104      p = "BOZ";
105      break;
106    case BT_UNKNOWN:
107      p = "UNKNOWN";
108      break;
109    case BT_ASSUMED:
110      p = "TYPE(*)";
111      break;
112    default:
113      gfc_internal_error ("gfc_basic_typename(): Undefined type");
114    }
115
116  return p;
117}
118
119
120/* Return a string describing the type and kind of a typespec.  Because
121   we return alternating buffers, this subroutine can appear twice in
122   the argument list of a single statement.  */
123
124const char *
125gfc_typename (gfc_typespec *ts, bool for_hash)
126{
127  static char buffer1[GFC_MAX_SYMBOL_LEN + 7];  /* 7 for "TYPE()" + '\0'.  */
128  static char buffer2[GFC_MAX_SYMBOL_LEN + 7];
129  static int flag = 0;
130  char *buffer;
131  gfc_typespec *ts1;
132  gfc_charlen_t length = 0;
133
134  buffer = flag ? buffer1 : buffer2;
135  flag = !flag;
136
137  switch (ts->type)
138    {
139    case BT_INTEGER:
140      sprintf (buffer, "INTEGER(%d)", ts->kind);
141      break;
142    case BT_REAL:
143      sprintf (buffer, "REAL(%d)", ts->kind);
144      break;
145    case BT_COMPLEX:
146      sprintf (buffer, "COMPLEX(%d)", ts->kind);
147      break;
148    case BT_LOGICAL:
149      sprintf (buffer, "LOGICAL(%d)", ts->kind);
150      break;
151    case BT_CHARACTER:
152      if (for_hash)
153	{
154	  sprintf (buffer, "CHARACTER(%d)", ts->kind);
155	  break;
156	}
157
158      if (ts->u.cl && ts->u.cl->length)
159	length = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
160      if (ts->kind == gfc_default_character_kind)
161	sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ")", length);
162      else
163	sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ",%d)", length,
164		 ts->kind);
165      break;
166    case BT_HOLLERITH:
167      sprintf (buffer, "HOLLERITH");
168      break;
169    case BT_UNION:
170      sprintf (buffer, "UNION(%s)", ts->u.derived->name);
171      break;
172    case BT_DERIVED:
173      if (ts->u.derived == NULL)
174	{
175	  sprintf (buffer, "invalid type");
176	  break;
177	}
178      sprintf (buffer, "TYPE(%s)", ts->u.derived->name);
179      break;
180    case BT_CLASS:
181      if (ts->u.derived == NULL)
182	{
183	  sprintf (buffer, "invalid class");
184	  break;
185	}
186      ts1 = ts->u.derived->components ? &ts->u.derived->components->ts : NULL;
187      if (ts1 && ts1->u.derived && ts1->u.derived->attr.unlimited_polymorphic)
188	sprintf (buffer, "CLASS(*)");
189      else
190	sprintf (buffer, "CLASS(%s)", ts->u.derived->name);
191      break;
192    case BT_ASSUMED:
193      sprintf (buffer, "TYPE(*)");
194      break;
195    case BT_PROCEDURE:
196      strcpy (buffer, "PROCEDURE");
197      break;
198    case BT_BOZ:
199      strcpy (buffer, "BOZ");
200      break;
201    case BT_UNKNOWN:
202      strcpy (buffer, "UNKNOWN");
203      break;
204    default:
205      gfc_internal_error ("gfc_typename(): Undefined type");
206    }
207
208  return buffer;
209}
210
211
212const char *
213gfc_typename (gfc_expr *ex)
214{
215  /* 34 character buffer: 14 for "CHARACTER(n,4)", n can be upto 20 characters,
216     add 19 for the extra width and 1 for '\0' */
217  static char buffer1[34];
218  static char buffer2[34];
219  static bool flag = false;
220  char *buffer;
221  gfc_charlen_t length;
222  buffer = flag ? buffer1 : buffer2;
223  flag = !flag;
224
225  if (ex->ts.type == BT_CHARACTER)
226    {
227      if (ex->expr_type == EXPR_CONSTANT)
228	length = ex->value.character.length;
229      else if (ex->ts.deferred)
230	{
231	  if (ex->ts.kind == gfc_default_character_kind)
232	    return "CHARACTER(:)";
233	  sprintf (buffer, "CHARACTER(:,%d)", ex->ts.kind);
234	  return buffer;
235	}
236      else if (ex->ts.u.cl && ex->ts.u.cl->length == NULL)
237	{
238	  if (ex->ts.kind == gfc_default_character_kind)
239	    return "CHARACTER(*)";
240	  sprintf (buffer, "CHARACTER(*,%d)", ex->ts.kind);
241	  return buffer;
242	}
243      else if (ex->ts.u.cl == NULL
244	       || ex->ts.u.cl->length->expr_type != EXPR_CONSTANT)
245	{
246	  if (ex->ts.kind == gfc_default_character_kind)
247	    return "CHARACTER";
248	  sprintf (buffer, "CHARACTER(KIND=%d)", ex->ts.kind);
249	  return buffer;
250	}
251      else
252	length = gfc_mpz_get_hwi (ex->ts.u.cl->length->value.integer);
253      if (ex->ts.kind == gfc_default_character_kind)
254	sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ")", length);
255      else
256	sprintf (buffer, "CHARACTER(" HOST_WIDE_INT_PRINT_DEC ",%d)", length,
257		 ex->ts.kind);
258      return buffer;
259    }
260  return gfc_typename(&ex->ts);
261}
262
263/* The type of a dummy variable can also be CHARACTER(*).  */
264
265const char *
266gfc_dummy_typename (gfc_typespec *ts)
267{
268  static char buffer1[15];  /* 15 for "CHARACTER(*,4)" + '\0'.  */
269  static char buffer2[15];
270  static bool flag = false;
271  char *buffer;
272
273  buffer = flag ? buffer1 : buffer2;
274  flag = !flag;
275
276  if (ts->type == BT_CHARACTER)
277    {
278      bool has_length = false;
279      if (ts->u.cl)
280	has_length = ts->u.cl->length != NULL;
281      if (!has_length)
282	{
283	  if (ts->kind == gfc_default_character_kind)
284	    sprintf(buffer, "CHARACTER(*)");
285	  else if (ts->kind < 10)
286	    sprintf(buffer, "CHARACTER(*,%d)", ts->kind);
287	  else
288	    sprintf(buffer, "CHARACTER(*,?)");
289	  return buffer;
290	}
291    }
292  return gfc_typename(ts);
293}
294
295
296/* Given an mstring array and a code, locate the code in the table,
297   returning a pointer to the string.  */
298
299const char *
300gfc_code2string (const mstring *m, int code)
301{
302  while (m->string != NULL)
303    {
304      if (m->tag == code)
305	return m->string;
306      m++;
307    }
308
309  gfc_internal_error ("gfc_code2string(): Bad code");
310  /* Not reached */
311}
312
313
314/* Given an mstring array and a string, returns the value of the tag
315   field.  Returns the final tag if no matches to the string are found.  */
316
317int
318gfc_string2code (const mstring *m, const char *string)
319{
320  for (; m->string != NULL; m++)
321    if (strcmp (m->string, string) == 0)
322      return m->tag;
323
324  return m->tag;
325}
326
327
328/* Convert an intent code to a string.  */
329/* TODO: move to gfortran.h as define.  */
330
331const char *
332gfc_intent_string (sym_intent i)
333{
334  return gfc_code2string (intents, i);
335}
336
337
338/***************** Initialization functions ****************/
339
340/* Top level initialization.  */
341
342void
343gfc_init_1 (void)
344{
345  gfc_error_init_1 ();
346  gfc_scanner_init_1 ();
347  gfc_arith_init_1 ();
348  gfc_intrinsic_init_1 ();
349}
350
351
352/* Per program unit initialization.  */
353
354void
355gfc_init_2 (void)
356{
357  gfc_symbol_init_2 ();
358  gfc_module_init_2 ();
359}
360
361
362/******************* Destructor functions ******************/
363
364/* Call all of the top level destructors.  */
365
366void
367gfc_done_1 (void)
368{
369  gfc_scanner_done_1 ();
370  gfc_intrinsic_done_1 ();
371  gfc_arith_done_1 ();
372}
373
374
375/* Per program unit destructors.  */
376
377void
378gfc_done_2 (void)
379{
380  gfc_symbol_done_2 ();
381  gfc_module_done_2 ();
382}
383
384
385/* Returns the index into the table of C interoperable kinds where the
386   kind with the given name (c_kind_name) was found.  */
387
388int
389get_c_kind(const char *c_kind_name, CInteropKind_t kinds_table[])
390{
391  int index = 0;
392
393  for (index = 0; index < ISOCBINDING_LAST; index++)
394    if (strcmp (kinds_table[index].name, c_kind_name) == 0)
395      return index;
396
397  return ISOCBINDING_INVALID;
398}
399
400
401/* For a given name TYPO, determine the best candidate from CANDIDATES
402   using get_edit_distance.  Frees CANDIDATES before returning.  */
403
404const char *
405gfc_closest_fuzzy_match (const char *typo, char **candidates)
406{
407  /* Determine closest match.  */
408  const char *best = NULL;
409  char **cand = candidates;
410  edit_distance_t best_distance = MAX_EDIT_DISTANCE;
411  const size_t tl = strlen (typo);
412
413  while (cand && *cand)
414    {
415      edit_distance_t dist = get_edit_distance (typo, tl, *cand,
416	  strlen (*cand));
417      if (dist < best_distance)
418	{
419	   best_distance = dist;
420	   best = *cand;
421	}
422      cand++;
423    }
424  /* If more than half of the letters were misspelled, the suggestion is
425     likely to be meaningless.  */
426  if (best)
427    {
428      unsigned int cutoff = MAX (tl, strlen (best)) / 2;
429
430      if (best_distance > cutoff)
431	{
432	  XDELETEVEC (candidates);
433	  return NULL;
434	}
435      XDELETEVEC (candidates);
436    }
437  return best;
438}
439
440/* Convert between GMP integers (mpz_t) and HOST_WIDE_INT.  */
441
442HOST_WIDE_INT
443gfc_mpz_get_hwi (mpz_t op)
444{
445  /* Using long_long_integer_type_node as that is the integer type
446     node that closest matches HOST_WIDE_INT; both are guaranteed to
447     be at least 64 bits.  */
448  const wide_int w = wi::from_mpz (long_long_integer_type_node, op, true);
449  return w.to_shwi ();
450}
451
452
453void
454gfc_mpz_set_hwi (mpz_t rop, const HOST_WIDE_INT op)
455{
456  const wide_int w = wi::shwi (op, HOST_BITS_PER_WIDE_INT);
457  wi::to_mpz (w, rop, SIGNED);
458}
459