mirror of
https://github.com/autc04/Retro68.git
synced 2024-09-27 12:57:21 +00:00
406 lines
11 KiB
C
406 lines
11 KiB
C
/****************************************************************************
|
|
* *
|
|
* GNAT COMPILER COMPONENTS *
|
|
* *
|
|
* A D A D E C O D E *
|
|
* *
|
|
* C Implementation File *
|
|
* *
|
|
* Copyright (C) 2001-2022, Free Software Foundation, Inc. *
|
|
* *
|
|
* GNAT is free software; you can redistribute it and/or modify it under *
|
|
* terms of the GNU General Public License as published by the Free Soft- *
|
|
* ware Foundation; either version 3, or (at your option) any later ver- *
|
|
* sion. GNAT is distributed in the hope that it will be useful, but WITH- *
|
|
* OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
|
|
* or FITNESS FOR A PARTICULAR PURPOSE. *
|
|
* *
|
|
* As a special exception under Section 7 of GPL version 3, you are granted *
|
|
* additional permissions described in the GCC Runtime Library Exception, *
|
|
* version 3.1, as published by the Free Software Foundation. *
|
|
* *
|
|
* You should have received a copy of the GNU General Public License and *
|
|
* a copy of the GCC Runtime Library Exception along with this program; *
|
|
* see the files COPYING3 and COPYING.RUNTIME respectively. If not, see *
|
|
* <http://www.gnu.org/licenses/>. *
|
|
* *
|
|
* GNAT was originally developed by the GNAT team at New York University. *
|
|
* Extensive contributions were provided by Ada Core Technologies Inc. *
|
|
* *
|
|
****************************************************************************/
|
|
|
|
#include "runtime.h"
|
|
#include <string.h>
|
|
#include <stdio.h>
|
|
#include <ctype.h>
|
|
|
|
#include "adaint.h" /* for a macro version of xstrdup. */
|
|
|
|
#ifndef ISDIGIT
|
|
#define ISDIGIT(c) isdigit(c)
|
|
#endif
|
|
|
|
#ifndef PARMS
|
|
#define PARMS(ARGS) ARGS
|
|
#endif
|
|
|
|
#include "adadecode.h"
|
|
|
|
static void add_verbose (const char *, char *);
|
|
static int has_prefix (const char *, const char *);
|
|
static int has_suffix (const char *, const char *);
|
|
|
|
/* This is a safe version of strcpy that can be used with overlapped
|
|
pointers. Does nothing if s2 <= s1. */
|
|
static void ostrcpy (char *s1, char *s2);
|
|
|
|
/* Set to nonzero if we have written any verbose info. */
|
|
static int verbose_info;
|
|
|
|
/* Add TEXT to end of ADA_NAME, putting a leading " (" or ", ", depending
|
|
on VERBOSE_INFO. */
|
|
|
|
static void add_verbose (const char *text, char *ada_name)
|
|
{
|
|
strcat (ada_name, verbose_info ? ", " : " (");
|
|
strcat (ada_name, text);
|
|
|
|
verbose_info = 1;
|
|
}
|
|
|
|
/* Returns 1 if NAME starts with PREFIX. */
|
|
|
|
static int
|
|
has_prefix (const char *name, const char *prefix)
|
|
{
|
|
return strncmp (name, prefix, strlen (prefix)) == 0;
|
|
}
|
|
|
|
/* Returns 1 if NAME ends with SUFFIX. */
|
|
|
|
static int
|
|
has_suffix (const char *name, const char *suffix)
|
|
{
|
|
int nlen = strlen (name);
|
|
int slen = strlen (suffix);
|
|
|
|
return nlen > slen && strncmp (name + nlen - slen, suffix, slen) == 0;
|
|
}
|
|
|
|
/* Safe overlapped pointers version of strcpy. */
|
|
|
|
static void
|
|
ostrcpy (char *s1, char *s2)
|
|
{
|
|
if (s2 > s1)
|
|
{
|
|
while (*s2) *s1++ = *s2++;
|
|
*s1 = '\0';
|
|
}
|
|
}
|
|
|
|
/* This function will return the Ada name from the encoded form.
|
|
The Ada coding is done in exp_dbug.ads and this is the inverse function.
|
|
see exp_dbug.ads for full encoding rules, a short description is added
|
|
below. Right now only objects and routines are handled. Ada types are
|
|
stripped of their encodings.
|
|
|
|
CODED_NAME is the encoded entity name.
|
|
|
|
ADA_NAME is a pointer to a buffer, it will receive the Ada name. A safe
|
|
size for this buffer is: strlen (coded_name) * 2 + 60. (60 is for the
|
|
verbose information).
|
|
|
|
VERBOSE is nonzero if more information about the entity is to be
|
|
added at the end of the Ada name and surrounded by ( and ).
|
|
|
|
Coded name Ada name verbose info
|
|
---------------------------------------------------------------------
|
|
_ada_xyz xyz library level
|
|
x__y__z x.y.z
|
|
x__yTKB x.y task body
|
|
x__yB x.y task body
|
|
x__yX x.y body nested
|
|
x__yXb x.y body nested
|
|
xTK__y x.y in task
|
|
x__y$2 x.y overloaded
|
|
x__y__3 x.y overloaded
|
|
x__Oabs "abs"
|
|
x__Oand "and"
|
|
x__Omod "mod"
|
|
x__Onot "not"
|
|
x__Oor "or"
|
|
x__Orem "rem"
|
|
x__Oxor "xor"
|
|
x__Oeq "="
|
|
x__One "/="
|
|
x__Olt "<"
|
|
x__Ole "<="
|
|
x__Ogt ">"
|
|
x__Oge ">="
|
|
x__Oadd "+"
|
|
x__Osubtract "-"
|
|
x__Oconcat "&"
|
|
x__Omultiply "*"
|
|
x__Odivide "/"
|
|
x__Oexpon "**" */
|
|
|
|
void
|
|
__gnat_decode (const char *coded_name, char *ada_name, int verbose)
|
|
{
|
|
int lib_subprog = 0;
|
|
int overloaded = 0;
|
|
int task_body = 0;
|
|
int in_task = 0;
|
|
int body_nested = 0;
|
|
|
|
/* Deal with empty input early. This allows assuming non-null length
|
|
later on, simplifying coding. In principle, it should be our callers
|
|
business not to call here for empty inputs. It is easy enough to
|
|
allow it, however, and might allow simplifications upstream so is not
|
|
a bad thing per se. We need a guard in any case. */
|
|
|
|
if (*coded_name == '\0')
|
|
{
|
|
*ada_name = '\0';
|
|
return;
|
|
}
|
|
|
|
/* Check for library level subprogram. */
|
|
else if (has_prefix (coded_name, "_ada_"))
|
|
{
|
|
strcpy (ada_name, coded_name + 5);
|
|
lib_subprog = 1;
|
|
}
|
|
else
|
|
strcpy (ada_name, coded_name);
|
|
|
|
/* Check for the first triple underscore in the name. This indicates
|
|
that the name represents a type with encodings; in this case, we
|
|
need to strip the encodings. */
|
|
{
|
|
char *encodings;
|
|
|
|
if ((encodings = (char *) strstr (ada_name, "___")) != NULL)
|
|
{
|
|
*encodings = '\0';
|
|
}
|
|
}
|
|
|
|
/* Check for task body. */
|
|
if (has_suffix (ada_name, "TKB"))
|
|
{
|
|
ada_name[strlen (ada_name) - 3] = '\0';
|
|
task_body = 1;
|
|
}
|
|
|
|
if (has_suffix (ada_name, "B"))
|
|
{
|
|
ada_name[strlen (ada_name) - 1] = '\0';
|
|
task_body = 1;
|
|
}
|
|
|
|
/* Check for body-nested entity: X[bn] */
|
|
if (has_suffix (ada_name, "X"))
|
|
{
|
|
ada_name[strlen (ada_name) - 1] = '\0';
|
|
body_nested = 1;
|
|
}
|
|
|
|
if (has_suffix (ada_name, "Xb"))
|
|
{
|
|
ada_name[strlen (ada_name) - 2] = '\0';
|
|
body_nested = 1;
|
|
}
|
|
|
|
if (has_suffix (ada_name, "Xn"))
|
|
{
|
|
ada_name[strlen (ada_name) - 2] = '\0';
|
|
body_nested = 1;
|
|
}
|
|
|
|
/* Change instance of TK__ (object declared inside a task) to __. */
|
|
{
|
|
char *tktoken;
|
|
|
|
while ((tktoken = (char *) strstr (ada_name, "TK__")) != NULL)
|
|
{
|
|
ostrcpy (tktoken, tktoken + 2);
|
|
in_task = 1;
|
|
}
|
|
}
|
|
|
|
/* Check for overloading: name terminated by $nn or __nn. */
|
|
{
|
|
int len = strlen (ada_name);
|
|
int n_digits = 0;
|
|
|
|
if (len > 1)
|
|
while (ISDIGIT ((int) ada_name[(int) len - 1 - n_digits]))
|
|
n_digits++;
|
|
|
|
/* Check if we have $ or __ before digits. */
|
|
if (ada_name[len - 1 - n_digits] == '$')
|
|
{
|
|
ada_name[len - 1 - n_digits] = '\0';
|
|
overloaded = 1;
|
|
}
|
|
else if (ada_name[len - 1 - n_digits] == '_'
|
|
&& ada_name[len - 1 - n_digits - 1] == '_')
|
|
{
|
|
ada_name[len - 1 - n_digits - 1] = '\0';
|
|
overloaded = 1;
|
|
}
|
|
}
|
|
|
|
/* Check for nested subprogram ending in .nnnn and strip suffix. */
|
|
{
|
|
int last = strlen (ada_name) - 1;
|
|
|
|
while (ISDIGIT (ada_name[last]) && last > 0)
|
|
{
|
|
last--;
|
|
}
|
|
|
|
if (ada_name[last] == '.')
|
|
{
|
|
ada_name[last] = (char) 0;
|
|
}
|
|
}
|
|
|
|
/* Change all "__" to ".". */
|
|
{
|
|
int len = strlen (ada_name);
|
|
int k = 0;
|
|
|
|
while (k < len)
|
|
{
|
|
if (ada_name[k] == '_' && ada_name[k+1] == '_')
|
|
{
|
|
ada_name[k] = '.';
|
|
ostrcpy (ada_name + k + 1, ada_name + k + 2);
|
|
len = len - 1;
|
|
}
|
|
k++;
|
|
}
|
|
}
|
|
|
|
/* Checks for operator name. */
|
|
{
|
|
const char *trans_table[][2]
|
|
= {{"Oabs", "\"abs\""}, {"Oand", "\"and\""}, {"Omod", "\"mod\""},
|
|
{"Onot", "\"not\""}, {"Oor", "\"or\""}, {"Orem", "\"rem\""},
|
|
{"Oxor", "\"xor\""}, {"Oeq", "\"=\""}, {"One", "\"/=\""},
|
|
{"Olt", "\"<\""}, {"Ole", "\"<=\""}, {"Ogt", "\">\""},
|
|
{"Oge", "\">=\""}, {"Oadd", "\"+\""}, {"Osubtract", "\"-\""},
|
|
{"Oconcat", "\"&\""}, {"Omultiply", "\"*\""}, {"Odivide", "\"/\""},
|
|
{"Oexpon", "\"**\""}, {NULL, NULL} };
|
|
int k = 0;
|
|
|
|
while (1)
|
|
{
|
|
char *optoken;
|
|
|
|
if ((optoken = (char *) strstr (ada_name, trans_table[k][0])) != NULL)
|
|
{
|
|
int codedlen = strlen (trans_table[k][0]);
|
|
int oplen = strlen (trans_table[k][1]);
|
|
|
|
if (codedlen > oplen)
|
|
/* We shrink the space. */
|
|
ostrcpy (optoken, optoken + codedlen - oplen);
|
|
else if (oplen > codedlen)
|
|
{
|
|
/* We need more space. */
|
|
int len = strlen (ada_name);
|
|
int space = oplen - codedlen;
|
|
int num_to_move = &ada_name[len] - optoken;
|
|
int t;
|
|
|
|
for (t = 0; t < num_to_move; t++)
|
|
ada_name[len + space - t - 1] = ada_name[len - t - 1];
|
|
}
|
|
|
|
/* Write symbol in the space. */
|
|
memcpy (optoken, trans_table[k][1], oplen);
|
|
}
|
|
else
|
|
k++;
|
|
|
|
/* Check for table's ending. */
|
|
if (trans_table[k][0] == NULL)
|
|
break;
|
|
}
|
|
}
|
|
|
|
/* If verbose mode is on, we add some information to the Ada name. */
|
|
if (verbose)
|
|
{
|
|
if (overloaded)
|
|
add_verbose ("overloaded", ada_name);
|
|
|
|
if (lib_subprog)
|
|
add_verbose ("library level", ada_name);
|
|
|
|
if (body_nested)
|
|
add_verbose ("body nested", ada_name);
|
|
|
|
if (in_task)
|
|
add_verbose ("in task", ada_name);
|
|
|
|
if (task_body)
|
|
add_verbose ("task body", ada_name);
|
|
|
|
if (verbose_info == 1)
|
|
strcat (ada_name, ")");
|
|
}
|
|
}
|
|
|
|
#ifdef __cplusplus
|
|
extern "C" {
|
|
#endif
|
|
|
|
void
|
|
get_encoding (const char *coded_name, char *encoding)
|
|
{
|
|
char * dest_index = encoding;
|
|
const char *p;
|
|
int found = 0;
|
|
int count = 0;
|
|
|
|
/* The heuristics is the following: we assume that the first triple
|
|
underscore in an encoded name indicates the beginning of the
|
|
first encoding, and that subsequent triple underscores indicate
|
|
the next encodings. We assume that the encodings are always at the
|
|
end of encoded names. */
|
|
|
|
for (p = coded_name; *p != '\0'; p++)
|
|
{
|
|
if (*p != '_')
|
|
count = 0;
|
|
else
|
|
if (++count == 3)
|
|
{
|
|
count = 0;
|
|
|
|
if (found)
|
|
{
|
|
dest_index = dest_index - 2;
|
|
*dest_index++ = ':';
|
|
}
|
|
|
|
p++;
|
|
found = 1;
|
|
}
|
|
|
|
if (found)
|
|
*dest_index++ = *p;
|
|
}
|
|
|
|
*dest_index = '\0';
|
|
}
|
|
|
|
#ifdef __cplusplus
|
|
}
|
|
#endif
|