/* marst.c */
/*----------------------------------------------------------------------
-- This file is part of GNU MARST, an Algol-to-C translator.
--
-- Copyright (C) 2000, 2001, 2002, 2007 Free Software Foundation, Inc.
--
-- 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 .
----------------------------------------------------------------------*/
#include
#include
#include
#include
#include
#include
#include
/*----------------------------------------------------------------------
-- Quod si digna tua minus est mea pagina laude
-- At voluisse sat est: animum, non carmina jacto.
--
--
-- This program is a translator. It translates Algol 60 programs to the
-- C programming language.
--
-- Input language of the translator is hardware representation of the
-- reference language Algol 60 as described in IFIP document:
--
-- Modified Report on the Algorithmic Language ALGOL 60. The Computer
-- Journal, Vol. 19, No. 4, Nov. 1976, pp. 364-379. (This document is
-- an official IFIP standard document. It is NOT a part of the MARST
-- package.)
--
-- Note that there are some differences between the Revised Report and
-- the Modified Report since the latter is a result of application of
-- the following IFIP document to the Revised Report:
--
-- R.M.De Morgan, I.D.Hill, and B.A.Wichmann. A Supplement to the
-- ALGOL 60 Revised Report. The Computer Journal, Vol. 19, No. 3, 1976,
-- pp. 276-288. (This document is an official IFIP standard document.
-- It is NOT a part of the MARST package.)
--
-- The translator as well as library routines are programmed in basic
-- dialect of the C programming language which is a subset of ISO C as
-- described in preliminary ISO document (this dialect is practically
-- the same as widely known 1989' ANSI C):
--
-- ISO, Programming languages - C, WG14/N843, Commitee Draft - August 3,
-- 1998. (This document is an official ISO standard document. It is NOT
-- a part of the MARST package.)
--
-- The output code produced by the translator is on the same dialect.
--
-- To translate source Algol 60 program the translator uses so called
-- recursive descent technique for parsing. This technique means that
-- the parsing tree is (implicitly) built from its root to its leaves.
-- Each parsing routine builds subtree the root of which corresponds to
-- the appropriate non-terminal.
--
-- The translation is performed in two passes. The first pass is used
-- to determine structure of blocks and to accumulate information about
-- identifiers. On the second pass source program is read once again
-- and the syntax directed translation is used to generate output code.
--
-- The syntax listed below in the description of each parsing routine
-- and which is used by these routines is not the original syntax of the
-- reference language. But this syntax is equivalent to the original one
-- in the sense that they both define the same language.
----------------------------------------------------------------------*/
static char *version = "MARST -- Algol-to-C Translator, Version 2.6";
/* Version information. */
static char *infilename = "";
/* The name of input text file that contains source Algol 60 program.
If this file is the standard input file then its name is "(stdin)".
This name used in error and warning messages. */
static FILE *infile;
/* The stream connected to the input text file. */
static char *outfilename = "";
/* The name of output text file to which the translator emits output
C code. If this file is the standard output file then its name is
"(stdout)". */
static FILE *outfile;
/* The stream connected to the output text file. */
static int debug = 0;
/* Debug mode flag. If this flag is set then the translator emits all
tokens of source program to the output text file as comments. */
static int errmax = 0;
/* Maximal error count. The translator stops after the specified number
of errors has been detected. Zero means to continue translation until
the end of the file. This value must be in range from 0 to 255. */
static int warn = 1;
/* Warning flag. If this flag is set then the translator send warning
messages to stderr; otherwise all warning messages are suppressed */
static int width = 72;
/* Desirable line width used in output C code. This value must be in
range from 50 to 255. */
static int time_stamp = 1;
/* Time stamp flag. If this flag is set then the translator writes date
and time of translation to output C code as comment. */
static int first_pass;
/* First pass flag. This flag is set during the first pass and is clear
during the second pass. */
static int second_pass;
/* Second pass flag. This flag is clear during the first pass and is set
during the second pass. */
static int e_count = 0;
/* Error count. */
static int w_count = 0;
/* Warning count. */
static int l_count;
/* Source line count. This value is increased by one each time when the
next line has been read from the input text file. */
static int l_maxlen = 100;
/* Maximal length of source line (excluding '\0'). This value will be
increased automatically when it will be necessary. */
static char *line /* [l_maxlen+1] */;
/* Current source line (i.e. line of source Algol 60 program) read from
the input text file. */
static int pos;
/* Position of the current (i.e. not processed yet) character in the
current source line. This value is changed from 0 to l_maxlen. */
static int symbol;
/* Code of the current basic symbol: */
#define S_EOF 0 /* _|_ */
#define S_LETTER 1 /* a, b, ..., z, A, B, ..., Z */
#define S_DIGIT 2 /* 0, 1, ..., 9 */
#define S_PLUS 3 /* + */
#define S_MINUS 4 /* - */
#define S_TIMES 5 /* * */
#define S_SLASH 6 /* / */
#define S_INTDIV 7 /* % */
#define S_POWER 8 /* ^, ** */
#define S_LESS 9 /* < */
#define S_NOTGREATER 10 /* <= */
#define S_EQUAL 11 /* = */
#define S_NOTLESS 12 /* >= */
#define S_GREATER 13 /* > */
#define S_NOTEQUAL 14 /* != */
#define S_EQUIV 15 /* == */
#define S_IMPL 16 /* -> */
#define S_OR 17 /* | */
#define S_AND 18 /* & */
#define S_NOT 19 /* ! */
#define S_COMMA 20 /* , */
#define S_POINT 21 /* . */
#define S_TEN 22 /* # */
#define S_COLON 23 /* : */
#define S_SEMICOLON 24 /* ; */
#define S_ASSIGN 25 /* := */
#define S_LEFT 26 /* ( */
#define S_RIGHT 27 /* ) */
#define S_BEGSUB 28 /* [ */
#define S_ENDSUB 29 /* ] */
#define S_OPEN 30 /* " (opening quote) */
#define S_CLOSE 31 /* " (closing quote, not used at this time) */
#define S_ARRAY 32 /* array */
#define S_BEGIN 33 /* begin */
#define S_BOOLEAN 34 /* Boolean, boolean */
#define S_CODE 35 /* code */
#define S_COMMENT 36 /* comment */
#define S_DO 37 /* do */
#define S_ELSE 38 /* else */
#define S_END 39 /* end */
#define S_FALSE 40 /* false */
#define S_FOR 41 /* for */
#define S_GOTO 42 /* go to, goto */
#define S_IF 43 /* if */
#define S_INTEGER 44 /* integer */
#define S_LABEL 45 /* label */
#define S_OWN 46 /* own */
#define S_PROCEDURE 47 /* procedure */
#define S_REAL 48 /* real */
#define S_STEP 49 /* step */
#define S_STRING 50 /* string */
#define S_SWITCH 51 /* switch */
#define S_THEN 52 /* then */
#define S_TRUE 53 /* true */
#define S_UNTIL 54 /* until */
#define S_VALUE 55 /* value */
#define S_WHILE 56 /* while */
static int s_char;
/* Value of the current basic symbol. It has sense only for S_LETTER and
S_DIGIT. */
/*----------------------------------------------------------------------
-- my_assert - perform diagnostics.
--
-- This routine is used indirectly through 'assert' macro and checks
-- some error conditions that can happen only if there is a bug in the
-- translator. */
static void my_assert(char *expr, char *file, int line)
{ fprintf(stderr,
"Internal translator error: %s, file %s, line %d\n",
expr, file, line);
fprintf(stderr, "Please, report to \n");
exit(EXIT_FAILURE);
/* no return */
}
#undef assert
#define assert(expr)\
((void)((expr) || (my_assert(#expr, __FILE__, __LINE__), 1)))
/*----------------------------------------------------------------------
-- my_malloc - allocate memory area.
--
-- This routine allocates a memory area of size bytes long and returns
-- a pointer to the beginning of this area. It is a fatal error if this
-- request cannot be satisfied. */
static void *my_malloc(int size)
{ void *ptr;
assert(size > 0);
ptr = malloc(size);
if (ptr == NULL)
{ fprintf(stderr, "Main storage requested not available\n");
exit(EXIT_FAILURE);
}
return ptr;
}
#undef malloc
#define malloc ??? /* further usage is verboten */
/*----------------------------------------------------------------------
-- my_realloc - reallocate memory area.
--
-- This routine reallocates a memory area pointed to by ptr to increase
-- it to size bytes long and returns pointer to reallocated area. It is
-- a fatal error if this request cannot be satisfied. */
static void *my_realloc(void *ptr, int size)
{ assert(ptr != NULL && size > 0);
ptr = realloc(ptr, size);
if (ptr == NULL)
{ fprintf(stderr, "Main storage requested not available\n");
exit(EXIT_FAILURE);
}
return ptr;
}
#undef realloc
#define realloc ??? /* further usage is verboten */
/*----------------------------------------------------------------------
-- my_free - free memory area.
--
-- This routine frees memory area pointed to by ptr. */
static void my_free(void *ptr)
{ assert(ptr != NULL);
free(ptr);
return;
}
#undef free
#define free ??? /* further usage is verboten */
/*----------------------------------------------------------------------
-- error - print error message.
--
-- This routine formats and sends to stderr a message that reflects an
-- error in source Algol 60 program. */
static void error(char *msg, ...)
{ va_list arg;
fprintf(stderr, "%s:%d: ", infilename, l_count);
va_start(arg, msg);
vfprintf(stderr, msg, arg);
va_end(arg);
fprintf(stderr, "\n");
if (debug && first_pass)
{ fprintf(outfile, ">>%s:%d: ", infilename, l_count);
va_start(arg, msg);
vfprintf(outfile, msg, arg);
va_end(arg);
fprintf(outfile, "\n");
}
e_count++;
if (e_count == errmax)
{ error("too many errors detected; translation terminated");
exit(EXIT_FAILURE);
}
return;
}
/*----------------------------------------------------------------------
-- warning - print warning message.
--
-- This routine formats and sends to stderr a message that reflects
-- some potential error or usage of some non-standard feature in source
-- Algol 60 program. */
static void warning(char *msg, ...)
{ if (first_pass && warn)
{ va_list arg;
fprintf(stderr, "%s:%d: warning: ", infilename, l_count);
va_start(arg, msg);
vfprintf(stderr, msg, arg);
va_end(arg);
fprintf(stderr, "\n");
if (debug)
{ fprintf(outfile, ">>%s:%d: warning: ", infilename, l_count);
va_start(arg, msg);
vfprintf(outfile, msg, arg);
va_end(arg);
fprintf(outfile, "\n");
}
w_count++;
}
return;
}
/*----------------------------------------------------------------------
-- read_line - read the next source line.
--
-- This routine scans the input text file char by char until '\n' to
-- build the next line of source Algol 60 program. If the next line has
-- been built, then the routine returns zero; if not (due to the end of
-- file), then the routine places an empty string as the next line and
-- returns non-zero. */
static int read_line(void)
{ int c, len = 0;
for (;;)
{ c = fgetc(infile);
if (ferror(infile))
{ fprintf(stderr, "Read error on `%s' - %s\n", infilename,
strerror(errno));
exit(EXIT_FAILURE);
}
if (feof(infile))
{ if (len > 0)
{ l_count++;
warning("missing final newline");
l_count--;
break;
}
line[0] = '\0';
return 1; /* end of file reached */
}
if (c == '\n') break;
if (iscntrl(c) && !isspace(c))
{ l_count++;
error("invalid control character 0x%02X", c);
l_count--;
c = ' ';
}
if (len == l_maxlen)
{ /* line too long; increase buffer size */
l_maxlen += l_maxlen;
line = my_realloc(line, l_maxlen + 1);
}
line[len++] = (char)c;
}
/* end of line reached */
line[len] = '\0';
l_count++;
return 0;
}
/*----------------------------------------------------------------------
-- skip_pad - skip non-significant characters.
--
-- This routine scans the current source line to skip all characters
-- that are non-significant. If the end of line occurs then the routine
-- automatically reads the next source line. After return the current
-- characters will be the first significant one. */
static void skip_pad(void)
{ for (;;)
{ if (line[pos] == '\0')
{ /* end of line reached */
if (read_line()) line[0] = 0x1A; /* end of file reached */
pos = 0;
}
else if (isspace(line[pos]))
{ /* ignore non-significant character */
pos++;
}
else
{ /* significant character detected */
break;
}
}
return;
}
/*----------------------------------------------------------------------
-- scan_symbol - scan basic symbol.
--
-- This routine scans the next basic symbol. The code of scanned symbol
-- is assigned to 'symbol' and its value (if the symbol is a letter or
-- a digit) is assigned to 's_char'. */
#define TEN_CHAR '#'
/* character used to denote decimal exponent (subscripted ten) */
#define check_word(len, word, code)\
if (!memcmp(line+pos, word, len) && !isalnum(line[pos+len]))\
{ symbol = code, pos += len;\
break;\
}
#define check_spec(c, code1, code2)\
if (line[pos+1] != c)\
symbol = code1, pos++;\
else\
symbol = code2, pos += 2;
static void scan_symbol(void)
{ /* skip optional non-significant characters that can precede to
basic symbol */
scan: skip_pad();
/* now the current character is significant */
if (isalpha(line[pos]))
{ /* letter */
/* a sequence of letters is recognized as keyword if and only
if there are no letters and digits immediately preceding or
following that sequence */
if (pos > 0 && isalnum(line[pos-1])) goto alfa;
switch (line[pos])
{ case 'a':
check_word(5, "array", S_ARRAY);
goto alfa;
case 'b':
check_word(5, "begin", S_BEGIN);
check_word(7, "boolean", S_BOOLEAN);
goto alfa;
case 'B':
check_word(7, "Boolean", S_BOOLEAN);
goto alfa;
case 'c':
check_word(4, "code", S_CODE);
check_word(7, "comment", S_COMMENT);
goto alfa;
case 'd':
check_word(2, "do", S_DO);
goto alfa;
case 'e':
check_word(4, "else", S_ELSE);
check_word(3, "end", S_END);
goto alfa;
case 'f':
check_word(5, "false", S_FALSE);
check_word(3, "for", S_FOR);
goto alfa;
case 'g':
check_word(4, "goto", S_GOTO);
check_word(5, "go to", S_GOTO);
check_word(6, "go to", S_GOTO);
check_word(7, "go to", S_GOTO);
goto alfa;
case 'i':
check_word(2, "if", S_IF);
check_word(7, "integer", S_INTEGER);
goto alfa;
case 'l':
check_word(5, "label", S_LABEL);
goto alfa;
case 'o':
check_word(3, "own", S_OWN);
goto alfa;
case 'p':
check_word(9, "procedure", S_PROCEDURE);
goto alfa;
case 'r':
check_word(4, "real", S_REAL);
goto alfa;
case 's':
check_word(4, "step", S_STEP);
check_word(6, "string", S_STRING);
check_word(6, "switch", S_SWITCH);
goto alfa;
case 't':
check_word(4, "then", S_THEN);
check_word(4, "true", S_TRUE);
goto alfa;
case 'u':
check_word(5, "until", S_UNTIL);
goto alfa;
case 'v':
check_word(5, "value", S_VALUE);
goto alfa;
case 'w':
check_word(5, "while", S_WHILE);
goto alfa;
default:
alfa: symbol = S_LETTER, s_char = (unsigned char)line[pos++];
}
}
else if (isdigit(line[pos]))
{ /* digit */
symbol = S_DIGIT, s_char = (unsigned char)line[pos++];
}
else
{ /* special character */
switch (line[pos])
{ case 0x1A:
symbol = S_EOF; break;
case '+':
symbol = S_PLUS, pos++; break;
case '-':
check_spec('>', S_MINUS, S_IMPL); break;
case '*':
check_spec('*', S_TIMES, S_POWER); break;
case '/':
symbol = S_SLASH, pos++; break;
case '%':
symbol = S_INTDIV, pos++; break;
case '^':
symbol = S_POWER, pos++; break;
case '<':
check_spec('=', S_LESS, S_NOTGREATER); break;
case '=':
check_spec('=', S_EQUAL, S_EQUIV); break;
case '>':
check_spec('=', S_GREATER, S_NOTLESS); break;
case '!':
check_spec('=', S_NOT, S_NOTEQUAL); break;
case '|':
symbol = S_OR, pos++; break;
case '&':
symbol = S_AND, pos++; break;
case ',':
symbol = S_COMMA, pos++; break;
case '.':
symbol = S_POINT, pos++; break;
case TEN_CHAR:
symbol = S_TEN, pos++; break;
case ':':
check_spec('=', S_COLON, S_ASSIGN); break;
case ';':
symbol = S_SEMICOLON, pos++; break;
case '(':
symbol = S_LEFT, pos++; break;
case ')':
symbol = S_RIGHT, pos++; break;
case '[':
symbol = S_BEGSUB, pos++; break;
case ']':
symbol = S_ENDSUB, pos++; break;
case '"':
symbol = S_OPEN, pos++; break;
default:
error("invalid character `%c'", line[pos]);
pos++;
goto scan; /* ignore it */
}
}
return;
}
/*----------------------------------------------------------------------
-- The structure declared below defines a token (elementary syntactic
-- unit) of source Algol 60 program. The grammar describing the input
-- language and which is used by parsing routines is LL(2). This means
-- that in general case the translator needs two tokens: the current
-- token and the next one. In some cases the translator also needs the
-- token preceding the current token. These tokens are placed in the
-- array 'token' (see declaration below) in the following manner:
--
-- token[0] is the token preceding the current token;
-- token[1] is the current (being processed) token;
-- token[2] is the token following the current token.
--
-- Should note that token[0] and token[1] are always defined, but
-- token[2] may be undefined, because most productions can be properly
-- resolved without token[2] hint. */
static int t_maxlen = 100;
/* Maximal length of token image (excluding '\0'); this value will be
increased automatically when it will be necessary */
static struct
{ /* source program token */
int ssn;
/* source line number where token starts */
int code;
/* token code: */
#define T_UNDEF 0 /* token undefined (for token[2] only) */
#define T_IDENT 1 /* identifier */
#define T_INT 2 /* integer constant */
#define T_REAL 3 /* real constant */
#define T_FALSE 4 /* logical constant 'false' */
#define T_TRUE 5 /* logical constant 'true' */
#define T_STRING 6 /* character string */
#define T_DELIM 7 /* delimiter */
int delim;
/* delimiter code, i.e. code of corresponding basic symbol (has
sense only for T_DELIM) */
int len;
/* current length if token image (excluding '\0') */
char *image /* [t_maxlen+1] */;
/* character string representing "image" of token */
} token[3];
/* Some handy-to-use macros. */
#define t_ssn (token[1].ssn)
#define t_code (token[1].code)
#define t_delim(what) (t_code == T_DELIM && token[1].delim == what)
#define t_image (token[1].image)
/*----------------------------------------------------------------------
-- add_char - add character to a token image.
--
-- This routine adds the character c to the image of token[k]. */
static void add_char(int k, int c)
{ if (token[k].len == t_maxlen)
{ int kk;
t_maxlen += t_maxlen;
for (kk = 0; kk <= 2; kk++)
token[kk].image =
my_realloc(token[kk].image, t_maxlen + 1);
}
token[k].image[token[k].len++] = (char)c;
token[k].image[token[k].len] = '\0';
return;
}
/*----------------------------------------------------------------------
-- scan_token - scan the next token.
--
-- This routine scans the next token from the input file and places it
-- into token[k]. This routine also skips comment sequences that follows
-- 'comment' and 'end' delimiters.
--
-- Normally this routine is called with k = 1. Special call with k = 2
-- is used only to forescan a token that follows the current token. */
#define T_MAXLEN 100
/* Maximal length of character string representing identifier or number
constant. (May be increased if necessary.) */
static void scan_token(int k)
{ assert(k == 1 || (k == 2 && token[2].code == T_UNDEF));
scan: /* skip optional comment sequence following 'end' symbol */
if (token[k-1].code == T_DELIM && token[k-1].delim == S_END)
{ int some = 0; /* something follows 'end' */
int flag = 0; /* message displayed */
for (;;)
{ if (symbol == S_EOF || symbol == S_SEMICOLON ||
symbol == S_ELSE || symbol == S_END) break;
some = 1;
if (!(symbol == S_LETTER || symbol == S_DIGIT ||
symbol == S_FALSE || symbol == S_TRUE) && !flag)
{ warning("comment sequence following `end' contains delim"
"iter(s)");
flag = 1;
}
scan_symbol();
}
if (symbol == S_EOF && some)
warning("comment sequence following `end' terminated by eof"
);
}
/* skip optional comment sequence following 'comment' symbol */
{ int flag = 0; /* message displayed */
while (symbol == S_COMMENT)
{ if (!(token[k-1].code == T_DELIM &&
(token[k-1].delim == S_SEMICOLON ||
token[k-1].delim == S_BEGIN)))
{ if (token[k-1].code == T_DELIM &&
token[k-1].delim == S_EOF)
{ if (!flag)
{ warning("no symbols preceding delimiter `comment'")
;
flag = 1;
}
}
else
error("delimiter `comment' in invalid position");
}
/* skip comment sequence including semicolon */
for (;;)
{ skip_pad();
if (line[pos] == 0x1A)
{ error("comment sequence following `comment' terminate"
"d by eof");
break;
}
if (line[pos++] == ';') break;
}
/* get the first basic symbol following comment ... ; */
scan_symbol();
/* it may be comment again */
}
}
/* now the current basic symbol is the first symbol of the next
token */
token[k].ssn = l_count;
token[k].code = T_UNDEF;
token[k].delim = 0;
token[k].len = 0;
token[k].image[0] = '\0';
if (symbol == S_LETTER)
{ /* letter begins identifier (or letter string) */
token[k].code = T_IDENT;
while (symbol == S_LETTER || symbol == S_DIGIT)
add_char(k, s_char), scan_symbol();
if (strlen(token[k].image) > T_MAXLEN)
{ token[k].image[T_MAXLEN] = '\0';
error("identifier `%s...' too long", token[k].image);
}
}
else if (symbol == S_DIGIT)
{ /* digit begins numeric constant */
token[k].code = T_INT;
/* scan integer part */
while (symbol == S_DIGIT)
add_char(k, s_char), scan_symbol();
/* scan fractional part */
if (symbol == S_POINT)
{ token[k].code = T_REAL;
add_char(k, '.'), scan_symbol();
/* after point must be digit */
if (symbol != S_DIGIT)
error("real constant `%s' incomplete", token[k].image);
frac: while (symbol == S_DIGIT)
add_char(k, s_char), scan_symbol();
}
/* scan optional decimal exponent part */
if (symbol == S_TEN)
{ token[k].code = T_REAL;
add_char(k, TEN_CHAR), scan_symbol();
dexp: /* scan optional decimal exponent sign */
if (symbol == S_PLUS)
add_char(k, '+'), scan_symbol();
else if (symbol == S_MINUS)
add_char(k, '-'), scan_symbol();
/* after ten symbol or sign must be digit */
if (symbol != S_DIGIT)
error("real constant `%s' incomplete", token[k].image);
while (symbol == S_DIGIT)
add_char(k, s_char), scan_symbol();
}
if (strlen(token[k].image) > T_MAXLEN)
{ token[k].image[T_MAXLEN] = '\0';
error("constant `%s...' too long", token[k].image);
}
}
else if (symbol == S_FALSE)
{ /* logical constant 'false' */
token[k].code = T_FALSE;
strcpy(token[k].image, "false"), scan_symbol();
}
else if (symbol == S_TRUE)
{ /* logical constant 'true' */
token[k].code = T_TRUE;
strcpy(token[k].image, "true"), scan_symbol();
}
else if (symbol == S_OPEN)
{ /* character string */
token[k].code = T_STRING;
add_char(k, '"'); /* opening quote */
for (;;)
{ for (;;)
{ if (line[pos] == 0x1A)
{ /* eof detected */
error("unexpected eof within string");
goto clos;
}
if (line[pos] == '\0')
{ error("string incomplete");
break;
}
if (iscntrl(line[pos]))
{ error("invalid use of control character 0x%02X within"
" string", line[pos]);
pos++;
continue; /* ignore it */
}
if (line[pos] == '\\')
{ pos++;
if (line[pos] == 0x1A || line[pos] == '\0')
{ error("invalid use of backslash within string");
continue; /* ignore it */
}
add_char(k, '\\');
}
else if (line[pos] == '"')
{ pos++;
break;
}
add_char(k, line[pos++]);
}
/* string can have another part */
skip_pad();
if (line[pos] != '"') break;
pos++; /* continue to scan another part */
}
clos: add_char(k, '"'); /* closing quote */
scan_symbol(); /* symbol following character string */
}
else if (symbol == S_POINT)
{ /* point begins numeric constant */
token[k].code = T_REAL;
add_char(k, '.'), scan_symbol();
/* after point must be digit */
if (symbol != S_DIGIT)
{ error("invalid use of period");
goto scan; /* ignore it */
}
goto frac; /* continue scan numeric constant */
}
else if (symbol == S_TEN)
{ /* ten symbol begins numeric constant */
token[k].code = T_REAL;
add_char(k, TEN_CHAR), scan_symbol();
/* after ten must be sign or digit */
if (!(symbol == S_PLUS || symbol == S_MINUS ||
symbol == S_DIGIT))
{ error("invalid use of subscripted ten");
goto scan; /* ignore it */
}
goto dexp; /* continue scan numeric constant */
}
else
{ /* may be only delimiter */
char *image;
token[k].code = T_DELIM;
token[k].delim = symbol;
switch (symbol)
{ case S_EOF: image = "eof"; break;
case S_PLUS: image = "+"; break;
case S_MINUS: image = "-"; break;
case S_TIMES: image = "*"; break;
case S_SLASH: image = "/"; break;
case S_INTDIV: image = "%"; break;
case S_POWER: image = "^"; break;
case S_LESS: image = "<"; break;
case S_NOTGREATER: image = "<="; break;
case S_EQUAL: image = "="; break;
case S_NOTLESS: image = ">="; break;
case S_GREATER: image = ">"; break;
case S_NOTEQUAL: image = "!="; break;
case S_EQUIV: image = "=="; break;
case S_IMPL: image = "->"; break;
case S_OR: image = "|"; break;
case S_AND: image = "&"; break;
case S_NOT: image = "!"; break;
case S_COMMA: image = ","; break;
case S_COLON: image = ":"; break;
case S_SEMICOLON: image = ";"; break;
case S_ASSIGN: image = ":="; break;
case S_LEFT: image = "("; break;
case S_RIGHT: image = ")"; break;
case S_BEGSUB: image = "["; break;
case S_ENDSUB: image = "]"; break;
case S_ARRAY: image = "array"; break;
case S_BEGIN: image = "begin"; break;
case S_BOOLEAN: image = "Boolean"; break;
case S_CODE: image = "code"; break;
case S_DO: image = "do"; break;
case S_ELSE: image = "else"; break;
case S_END: image = "end"; break;
case S_FOR: image = "for"; break;
case S_GOTO: image = "go to"; break;
case S_IF: image = "if"; break;
case S_INTEGER: image = "integer"; break;
case S_LABEL: image = "label"; break;
case S_OWN: image = "own"; break;
case S_PROCEDURE: image = "procedure"; break;
case S_REAL: image = "real"; break;
case S_STEP: image = "step"; break;
case S_STRING: image = "string"; break;
case S_SWITCH: image = "switch"; break;
case S_THEN: image = "then"; break;
case S_UNTIL: image = "until"; break;
case S_VALUE: image = "value"; break;
case S_WHILE: image = "while"; break;
default: assert(symbol != symbol);
}
strcpy(token[k].image, image), scan_symbol();
}
/* it is appropriate place to print the next token */
if (debug && first_pass)
{ fprintf(outfile, "%6d: %-6s |%s|\n", token[k].ssn,
token[k].code == T_IDENT ? "ident" :
token[k].code == T_INT ? "int" :
token[k].code == T_REAL ? "real" :
token[k].code == T_FALSE ? "false" :
token[k].code == T_TRUE ? "true" :
token[k].code == T_STRING ? "string" :
token[k].code == T_DELIM ? "delim" : "???",
token[k].image);
}
return;
};
/*----------------------------------------------------------------------
-- get_token - scanning routine.
--
-- This routine is a scanner that is used by all parsing routines. It
-- copies the current token from token[1] to token[0] and then scans the
-- next token into token[1] or copies token[2] to token[1] (if token[2]
-- is defined). In any case after a call token[2] becomes undefined. */
static void get_token(void)
{ /* token[0] := current token */
token[0].ssn = token[1].ssn;
token[0].code = token[1].code;
token[0].delim = token[1].delim;
token[0].len = token[1].len;
strcpy(token[0].image, token[1].image);
/* token[1] := next token (becomes current) */
if (token[2].code == T_UNDEF)
scan_token(1);
else
{ token[1].ssn = token[2].ssn;
token[1].code = token[2].code;
token[1].delim = token[2].delim;
token[1].len = token[2].len;
strcpy(token[1].image, token[2].image);
/* token[2] is no longer defined */
token[2].code = T_UNDEF;
}
return;
}
/*----------------------------------------------------------------------
-- get_token2 - forescanning routine.
--
-- This routine forescans the token following the current token and
-- assign it to token[2]. The current token remains unchanged. */
static void get_token2(void)
{ if (token[2].code == T_UNDEF) scan_token(2);
return;
}
/*----------------------------------------------------------------------
-- Two types CODE and CSQE declared below are used to represent output
-- code generated by the translator.
--
-- Any object of CODE type is a character string which is a result of
-- translation of a part of source program corresponding to appropriate
-- non-terminal. For example, if parsing routine has finished parsing
-- of , it returns pointer to object of CODE type
-- that represents appropriate output code written in the C programming
-- language.
--
-- Since several parts of output code need to be essentially rearranged
-- during translation, it is impossible to emit output code immediately
-- to output text file. So we need keep all that parts in the main core
-- as objects of CODE type.
--
-- In order to deal with character strings of arbitrary length each
-- object of CODE type is represented as linked list of objects of CSQE
-- types, where the latter objects represent usual character strings
-- allocated dynamically.
--
-- If an object of CODE type corresponds to expression or to left part
-- of assignment statement some additional semantic information (lvalue
-- flag and type of expression) is linked with such object. This is used
-- further by the other parsing routines to perform appropriate semantic
-- checks and to build proper output code.
--
-- Objects of CODE type actually used only during the second pass. */
typedef struct CODE CODE;
typedef struct CSQE CSQE;
struct CODE
{ /* output code */
int lval;
/* lvalue flag (has sense for expression only) */
int type;
/* value type (has sense for expression only) */
CSQE *head;
/* pointer to the first linked list entry */
CSQE *tail;
/* pointer to the last linked list entry */
};
struct CSQE
{ /* output code linked list entry */
char *str;
/* pointer to character string */
CSQE *next;
/* ponter to next linked list entry */
};
/* These are names of all library routines used in the output code. */
#define a_active_dsa "active_dsa"
#define a_alloc_array "alloc_array"
#define a_alloc_same "alloc_same"
#define a_and "and"
#define a_copy_bool "copy_bool"
#define a_copy_int "copy_int"
#define a_copy_real "copy_real"
#define a_equal "equal"
#define a_equiv "equiv"
#define a_expi "expi"
#define a_expn "expn"
#define a_expr "expr"
#define a_false "false"
#define a_fault "fault"
#define a_get_bool "get_bool"
#define a_get_int "get_int"
#define a_get_label "get_label"
#define a_get_real "get_real"
#define a_global_dsa "global_dsa"
#define a_go_to "go_to"
#define a_greater "greater"
#define a_impl "impl"
#define a_int2real "int2real"
#define a_less "less"
#define a_loc_bool "loc_bool"
#define a_loc_int "loc_int"
#define a_loc_real "loc_real"
#define a_make_arg "make_arg"
#define a_make_label "make_label"
#define a_not "not"
#define a_notequal "notequal"
#define a_notgreater "notgreater"
#define a_notless "notless"
#define a_or "or"
#define a_own_array "own_array"
#define a_own_same "own_same"
#define a_pop_stack "pop_stack"
#define a_print "print"
#define a_real2int "real2int"
#define a_set_bool "set_bool"
#define a_set_int "set_int"
#define a_set_real "set_real"
#define a_stack_top "stack_top"
#define a_true "true"
static char codebuf[4000];
/* Auxiliary buffer to format output code. */
/*----------------------------------------------------------------------
-- new_code - create empty output code.
--
-- This routine creates empty output code (i.e. code which is an empty
-- character string) and returns pointer to it. */
static CODE *new_code(void)
{ if (first_pass)
return NULL;
else
{ CODE *code = my_malloc(sizeof(CODE));
code->lval = code->type = 0;
code->head = code->tail = NULL;
return code;
}
}
/*----------------------------------------------------------------------
-- prepend - prepend character string to output code.
--
-- This routine formats character string (like sprintf) using format
-- fmt and variable parameter list. Then the routine places this string
-- BEFORE character string represented by code. */
static void prepend(CODE *code, char *fmt, ...)
{ /* code := text || code */
if (second_pass)
{ va_list arg;
CSQE *sqe;
va_start(arg, fmt);
vsprintf(codebuf, fmt, arg);
assert(strlen(codebuf) < sizeof(codebuf));
va_end(arg);
sqe = my_malloc(sizeof(CSQE));
sqe->str = my_malloc(strlen(codebuf)+1);
strcpy(sqe->str, codebuf);
sqe->next = code->head;
code->head = sqe;
if (code->tail == NULL) code->tail = sqe;
}
return;
}
/*----------------------------------------------------------------------
-- append - append character string to output code.
--
-- This routine formats character string (like sprintf) using format
-- fmt and variable parameter list. Then the routine places this string
-- AFTER character string represented by code. */
static void append(CODE *code, char *fmt, ...)
{ /* code := code || text */
if (second_pass)
{ va_list arg;
CSQE *sqe;
va_start(arg, fmt);
vsprintf(codebuf, fmt, arg);
assert(strlen(codebuf) < sizeof(codebuf));
va_end(arg);
sqe = my_malloc(sizeof(CSQE));
sqe->str = my_malloc(strlen(codebuf)+1);
strcpy(sqe->str, codebuf);
sqe->next = NULL;
if (code->head == NULL)
code->head = sqe;
else
code->tail->next = sqe;
code->tail = sqe;
}
return;
}
/*----------------------------------------------------------------------
-- catenate - catenate output codes.
--
-- This routine catenates two character strings represented by output
-- code x and y, and assigns resulting string to output code x. After
-- this operation output code y becomes invalid and it can't be used
-- in any further operation. */
static void catenate(CODE *x, CODE *y)
{ /* x := x || y; free(y) */
if (second_pass)
{ if (x->head == NULL)
x->head = y->head;
else
x->tail->next = y->head;
if (y->tail != NULL) x->tail = y->tail;
my_free(y);
}
return;
}
/*----------------------------------------------------------------------
-- free_code - delete output code.
--
-- This routine frees memory used by output code. After this operation
-- pointer to output code becomes invalid. */
static void free_code(CODE *code)
{ if (second_pass)
{ CSQE *sqe;
while (code->head != NULL)
{ sqe = code->head;
code->head = sqe->next;
my_free(sqe->str);
my_free(sqe);
}
my_free(code);
}
return;
}
/*----------------------------------------------------------------------
-- The type BLOCK declared below is used to represent information about
-- each actual or dummy block that appears in source Algol 60 program.
--
-- The following kinds of block exist:
--
-- dummy block enclosing entire module (the environmental block). This
-- block is the root of the block tree and always has the number 0;
--
-- dummy block representing procedure (procedure block). This block
-- localizes all formal parameters of the corresponding procedure;
--
-- dummy block enclosing procedure body;
--
-- dummy block enclosing statement following 'do';
--
-- ordinary (explicit) program block.
--
-- The type IDENT declared below is used to represent information about
-- each identifier that appears in source Algol 60 program. */
typedef struct BLOCK BLOCK;
typedef struct IDENT IDENT;
struct BLOCK
{ /* program block */
int seqn;
/* block sequential number; all blocks are numbered in that order
in which they appear in source program; the first block (i.e.
the dummy environmental block enclosing entire module) has the
number 0; these numbers are used mainly to form unique C names
for identifiers localized in the corresponding blocks */
int ssn;
/* source line number in which block starts */
IDENT *proc;
/* pointer to procedure identifier (if this block is dummy block
representing procedure) or NULL (for blocks of other kinds) */
IDENT *first, *last;
/* pointers to first and to last identifiers localized in block */
BLOCK *surr;
/* pointer to surround block (to parent block in block tree) */
BLOCK *next;
/* pointer to the next block (to block having the next sequential
number) */
};
static BLOCK *first_b, *last_b;
/* Pointers to first and to last blocks. During the first pass as well
as the second pass last_b always points to last considered block. */
static BLOCK *current = NULL;
/* Pointer to the current active block. */
struct IDENT
{ /* identifier */
char *name;
/* name (image) of identifier */
int ssn_decl;
/* source line number where declaration or specification of
identifier appeared (0 if id is not declared/specified yet) */
int ssn_used;
/* source line number where identifier was referenced for the
first time (0 if id is not referenced yet) */
int flags;
/* identifier properties (if flags is zero then identifier is not
declared/specified yet): */
#define F_REAL 0x0001 /* real */
#define F_INT 0x0002 /* integer */
#define F_BOOL 0x0004 /* Boolean */
#define F_LABEL 0x0008 /* label */
#define F_ARRAY 0x0010 /* array */
#define F_SWITCH 0x0020 /* switch */
#define F_PROC 0x0040 /* procedure */
#define F_STRING 0x0080 /* string */
#define F_BYVAL 0x0100 /* formal parameter called by value */
#define F_BYNAME 0x0200 /* formal parameter called by name */
#define F_OWN 0x0400 /* own */
#define F_CODE 0x0800 /* code procedure */
#define F_BLTIN 0x1000 /* built-in procedure */
int dim;
/* identifier dimension (number of subscripts for array, number
of parameters for procedure, number of label used in longjmp,
etc.); if dimension is not applicable or is unknown yet then
dim is equal to -1 */
BLOCK *block;
/* pointer to block where identifier is localized */
IDENT *next;
/* pointer to the next identifier localized in the same block */
};
/*----------------------------------------------------------------------
-- look_up - search for identifier.
--
-- This routine is used to search for identifier by its name.
--
-- If decl is set then the routine was called to declare identifier,
-- and if decl is clear then the routine was called to make reference
-- to identifier. In any case ssn is the number of source line where
-- the identifier appeared.
--
-- On the first pass the routine performs search only in the current
-- block and if the identifier is not found the routine adds it to the
-- current block (since in Algol 60 declaration of identifier is not
-- necessarily preceding its usage). Of course, an attempt to declare
-- identifier which is already declared in the same block raises error.
--
-- On the second pass all identifiers are localized in blocks properly
-- and there are no undeclared identifiers. So the routine performs
-- a search in blocks of all levels starting from the current block. */
static int array_decl_flag = 0;
/* This flag is set when bound expression is processed. This is used
to catch invalid references to identifiers that are declared in the
same block as array */
static IDENT *look_up(char *name, int decl, int ssn)
{ IDENT *id;
if (first_pass)
{ /* search only in the current block */
for (id = current->first; id != NULL; id = id->next)
if (strcmp(id->name, name) == 0) break;
/* check for multiple declaration */
if (decl && id != NULL && id->flags != 0)
{ error("identifier `%s' multiply declared (see line %d)",
id->name, id->ssn_decl);
id = NULL; /* as if it were not found */
}
/* if identifier not found then add it to the current block */
if (id == NULL)
{ id = my_malloc(sizeof(IDENT));
id->name = my_malloc(strlen(name)+1);
strcpy(id->name, name);
id->ssn_decl = id->ssn_used = 0;
id->flags = 0;
id->dim = -1;
id->block = current;
id->next = NULL;
if (current->first == NULL)
current->first = id;
else
current->last->next = id;
current->last = id;
}
/* set source line number */
if (decl)
id->ssn_decl = ssn;
else
if (id->ssn_used == 0) id->ssn_used = ssn;
}
else
{ /* search in blocks of all levels starting from the current
block */
BLOCK *b;
for (b = current; ; b = b->surr)
{ assert(b != NULL);
for (id = b->first; id != NULL; id = id->next)
if (strcmp(id->name, name) == 0) break;
if (id != NULL) break;
}
/* check clause 5.2.4.2 (see Modified Report) */
if (array_decl_flag && !decl && id->block == current)
error("identifier `%s' in bound expression declared in same"
" program block as array", id->name);
}
return id;
}
/*----------------------------------------------------------------------
-- to_real - generate code to convert integer expression to real one.
--
-- This routine generates code to convert expression of integer type to
-- expression of real type. */
static void to_real(CODE *x)
{ if (second_pass && x->type == F_INT)
{ x->lval = 0;
x->type = F_REAL;
prepend(x, a_int2real "(");
append(x, ")");
}
return;
}
/*----------------------------------------------------------------------
-- to_int - generate code to convert real expression to integer one.
--
-- This routine generates code to convert expression of real type to
-- expression of integer type. */
static void to_int(CODE *x)
{ if (second_pass && x->type == F_REAL)
{ x->lval = 0;
x->type = F_INT;
prepend(x, a_real2int "(");
append(x, ")");
}
return;
}
/*----------------------------------------------------------------------
-- dsa_level - determine DSA level.
--
-- This routine determines DSA (Dynamic Storage Area) level of those
-- procedure in some block of which identifier id is declared.
--
-- DSA level is the level of procedure in the procedure tree. Outermost
-- procedure (i.e. precompiled procedure or dummy procedure representing
-- main program) has level 0. This level is used to access to that DSA
-- where the appropriate identifier is placed. */
static int dsa_level(IDENT *id)
{ BLOCK *b;
int level = -1;
for (b = id->block; b != NULL; b = b->surr)
if (b->proc != NULL) level++;
return level;
}
/*----------------------------------------------------------------------
-- current_level - determine current procedure level.
--
-- This routine determines level of current procedure in the same way
-- as the routine dsa_level (see above). */
static int current_level(void)
{ BLOCK *b;
int level = -1;
for (b = current; b != NULL; b = b->surr)
if (b->proc != NULL) level++;
return level;
}
/*----------------------------------------------------------------------
-- subscripted_variable - parse subscripted variable.
--
-- This routine parses subscripted variable using the syntax:
--
-- ::= [ ]
-- ::=
-- ::= ,
--
-- Output code generated by the routine has the form:
--
-- (*loc_xxx(dv, n, i1, i2, ..., in))
--
-- where loc_xxx is library routine loc_real, loc_int, or loc_bool that
-- computes pointer to appropriate array element (subscripted variable);
-- dv is dope vector of array placed in DSA (for local arrays) or in
-- static storage (for own arrays), n is number of subscripts, and i1,
-- i2, ..., in are subscript expressions. */
static CODE *expression(void);
static CODE *subscripted_variable(void)
{ CODE *code = new_code();
IDENT *arr; /* array identifier */
int dim = 0; /* number of subscripts */
char *place;
/* the current token must be (array) identifier */
assert(t_code == T_IDENT);
arr = look_up(t_image, 0, t_ssn);
if (second_pass && !(arr->flags & F_ARRAY))
error("invalid use of `%s' as array identifier", arr->name);
/* generate head of code */
if (second_pass)
{ code->lval = 1;
code->type = arr->flags & (F_REAL | F_INT | F_BOOL);
append(code, "(*%s(",
code->type == F_REAL ? a_loc_real :
code->type == F_INT ? a_loc_int : a_loc_bool);
if (arr->flags & F_OWN)
{ /* own array */
append(code, "%s_%d, ?, ",
arr->name, arr->block->seqn);
}
else
{ /* local or formal array */
append(code, "dsa_%d->%s_%d, ?, ",
dsa_level(arr), arr->name, arr->block->seqn);
}
/* remember place to substitute number of subscripts */
place = strchr(code->tail->str, '?');
assert(place);
}
get_token(/* id */);
/* after (array) identifier there must be '[' */
assert(t_delim(S_BEGSUB));
/* process subscript list */
for (;;)
{ /* parse the next subscript expression */
CODE *expr;
if (dim == 9)
{ error("number of subscripts exceeds allowable maximum");
dim = 0;
}
get_token(/* [ or , */);
expr = expression(), to_int(expr);
if (second_pass && expr->type != F_INT)
{ error("invalid type of subscript expression");
expr->type = F_INT;
}
catenate(code, expr);
dim++;
if (!t_delim(S_COMMA)) break;
append(code, ", ");
}
if (!t_delim(S_ENDSUB))
error("missing right parenthesis in subscripted variable");
/* check number of subscripts */
if (arr->dim < 0) arr->dim = dim;
if (second_pass && (arr->flags & F_ARRAY) && arr->dim != dim)
{ if (arr->flags & (F_BYVAL | F_BYNAME))
error("number of subscripts in subscripted variable conflic"
"ts with earlier use of array `%s'", arr->name);
else
error("number of subscripts in subscripted variable conflic"
"ts with declaration of array `%s' at line %d",
arr->name, arr->ssn_decl);
}
if (t_delim(S_ENDSUB)) get_token(/* ] */);
/* generate tail of code */
assert(1 <= dim && dim <= 9);
if (second_pass) *place = (char)(dim + '0');
append(code, "))");
return code;
}
/*----------------------------------------------------------------------
-- switch_designator - parse switch designator.
--
-- This routine parses switch designator using the syntax:
--
-- ::= [ ]
--
-- Output code generated by the routine has the form:
--
-- (global_dsa = ..., id(k))
--
-- where id is name of routine that computes value of designational
-- expression (value of label type represented by struct label), k is
-- subscript expression.
--
-- If switch is local then global_dsa is assigned to point to dsa of
-- calling procedure, and id is name of static routine generated from
-- switch declaration. If switch is formal then global_dsa is assigned
-- to arg.arg2 and id is arg.arg1, where arg is formal parameter that
-- represents formal switch. */
static CODE *switch_designator(void)
{ CODE *code;
IDENT *swit; /* switch identifier */
int dim = 0; /* number of subscripts */
assert(second_pass);
/* the current token must be switch identifier */
assert(t_code == T_IDENT);
swit = look_up(t_image, 0, t_ssn);
assert(swit->flags & F_SWITCH);
/* although switch designator has only one subscript, we should
process it as it were subscripted variable, since on the first
pass switch designator is processed by subscripted_variable
routine */
get_token(/* id */);
/* after switch identifier there must be '[' */
assert(t_delim(S_BEGSUB));
/* process subscript list */
for (;;)
{ /* parse the next subscript expression */
if (dim == 1)
error("invalid number of subscripts in switch designator fo"
"r `%s'", swit->name);
get_token(/* [ or , */);
code = expression(), to_int(code);
if (code->type != F_INT)
{ error("invalid type of subscript expression");
code->type = F_INT;
}
dim++;
if (!t_delim(S_COMMA)) break;
}
/* after subscript list there must be ']' */
assert(t_delim(S_ENDSUB));
get_token(/* ] */);
/* generate code */
code->lval = 0;
code->type = F_LABEL;
if (swit->flags & F_BYNAME)
{ /* formal switch */
prepend(code, "(" a_global_dsa " = dsa_%d->%s_%d.arg2, (*(stru"
"ct label (*)(int))dsa_%d->%s_%d.arg1)(",
dsa_level(swit), swit->name, swit->block->seqn,
dsa_level(swit), swit->name, swit->block->seqn);
}
else
{ /* local switch */
prepend(code, "(" a_global_dsa " = (void *)dsa_%d, %s_%d(",
current_level(), swit->name, swit->block->seqn);
}
append(code, "))");
return code;
}
/*----------------------------------------------------------------------
-- emit_dsa_pointers - generate code for DSA pointers.
--
-- This routine generates code to initialize DSA pointers. These
-- pointers are used in each routine representing thunk, or switch, or
-- statement following 'do' to access to identifiers placed in DSAs.
-- It is assumed that initialization is performed after entering to the
-- corresponding routine and global_dsa points to DSA of the current
-- procedure in some block of which the corresponding actual parameter,
-- or switch declaration, or statement following 'do' are placed.
--
-- Generated code is immediately appended to final output code. */
static CODE *emit = NULL;
/* Final output code. This code is the accumulated result of translation
and corresponds to the root of parsing tree. */
static void emit_dsa_pointers(void)
{ BLOCK *b;
int level = current_level(); /* level of current procedure */
for (b = current; b != NULL; b = b->surr)
{ if (b->proc == NULL) continue;
append(emit, " register struct dsa_%s_%d *dsa_%d = (vo"
"id *)" a_global_dsa "->vector[%d];\n",
b->proc->name, b->proc->block->seqn, level, level);
level--;
}
return;
}
/*----------------------------------------------------------------------
-- actual_parameter - parse actual parameter.
--
-- This routine parses the next actual parameter using the syntax:
--
-- ::=
-- ::=
-- ::=
-- ::=
--
-- If arg != NULL then it points to an identifier of appropriate formal
-- parameter. This is used to check actual-formal correspondence.
--
-- Generated output code always has the form:
--
-- make_arg(arg1, arg2)
--
-- where make_arg is library routine that makes struct arg representing
-- actual parameter of any kind using two pointers arg1 and arg2.
--
-- If actual parameter is quoted string then arg1 points to the string
-- body (i.e. to the first character), and arg2 is NULL.
--
-- If actual parameter is array identifier then arg1 points to the dope
-- vector of the array, and arg2 is 'r', 'i', or 'b' (casted to void *)
-- to determine array type (real, integer, or Boolean).
--
-- If actual parameter is formal parameter called by name (but not an
-- array) then make_arg routine is not used since pair (arg1, arg2) as
-- struct arg is placed in DSA of the appropriate procedure.
--
-- If actual parameter is expression (including simple or subscripted
-- variable) then it is translated to static routine (so called thunk).
-- That routine computes struct desc that represents value of expression
-- (including value of label), or pointer to variable. In this case
-- arg1 is pointer to thunk, and arg2 is pointer to DSA of calling
-- procedure (used by thunk to access to appropriate identifiers).
--
-- If actual parameter is switch or procedure identifier then arg1 is
-- pointer to routine representing switch or procedure declaration, and
-- arg2 is again pointer to DSA of calling procedure. */
static int thunk_count = 0;
/* Thunk count. This value is used to form unique name of corresponding
static routine. */
static int thunk_real0 = 0; /* thunk count for 0.0 */
static int thunk_real1 = 0; /* thunk count for 1.0 */
static int thunk_int0 = 0; /* thunk count for 0 */
static int thunk_int1 = 0; /* thunk count for 1 */
static int thunk_false = 0; /* thunk count for false */
static int thunk_true = 0; /* thunk count for true */
static CODE *emit_ssn(int ssn);
static CODE *actual_parameter(IDENT *arg)
{ CODE *code = new_code();
/* the current token is a head of actual parameter */
if (t_code == T_STRING)
{ /* the corresponding formal parameter must be string only */
if (second_pass && arg != NULL && !(arg->flags & F_STRING))
{ error("string passed as actual parameter conflicts with kin"
"d of formal parameter `%s' as specified in declaration "
"of procedure `%s' beginning at line %d", arg->name,
arg->block->proc->name, arg->block->proc->ssn_decl);
goto skip1;
}
/* generate code for actual string */
append(code, a_make_arg "(");
append(code, t_image);
append(code, ", NULL)");
skip1: get_token(/* string */);
goto done;
}
/* to make parsing easier we need hint token[2] */
get_token2();
/* special cases when actual parameter is identifier */
if (t_code == T_IDENT && token[2].code == T_DELIM &&
(token[2].delim == S_COMMA || token[2].delim == S_RIGHT))
{ IDENT *id = look_up(t_image, 0, t_ssn);
/* at the first pass any identifier being actual parameter is
treated as expression */
if (second_pass)
{ if (id->flags == (F_REAL | F_BYNAME) ||
id->flags == (F_INT | F_BYNAME) ||
id->flags == (F_BOOL | F_BYNAME))
{ /* actual parameter is a simple formal parameter called
by name (except labels) */
if (arg != NULL)
{ /* the corresponding formal parameter must be simple
formal parameter of appropriate type */
int actual_type, formal_type;
if (arg->flags & ~(F_REAL | F_INT | F_BOOL | F_BYVAL |
F_BYNAME))
{ error("formal parameter `%s' called by name and pa"
"ssed as actual parameter conflicts with kind o"
"f formal parameter `%s' as specified in declar"
"ation of procedure `%s' beginning at line %d",
id->name, arg->name, arg->block->proc->name,
arg->block->proc->ssn_decl);
goto skip1a;
}
actual_type = id->flags & (F_REAL | F_INT | F_BOOL);
formal_type = arg->flags & (F_REAL | F_INT | F_BOOL);
if (actual_type & (F_REAL | F_INT))
{ actual_type &= ~(F_REAL | F_INT);
formal_type &= ~(F_REAL | F_INT);
}
if (actual_type != formal_type)
{ error("type of formal parameter `%s' called by nam"
"e and passed as actual parameter conflicts wit"
"h type of formal parameter `%s' as specified i"
"n declaration of procedure `%s' beginning at l"
"ine %d",
id->name, arg->name, arg->block->proc->name,
arg->block->proc->ssn_decl);
goto skip1a;
}
}
/* generate code */
append(code, "dsa_%d->%s_%d", dsa_level(id), id->name,
id->block->seqn);
skip1a: get_token(/* id */);
goto done;
}
if (id->flags & F_ARRAY)
{ /* actual parameter is array identifier */
if (arg != NULL)
{ /* so the corresponding formal parameter must be only
array of appropriate type and dimension */
int actual_type, formal_type;
if (!(arg->flags & F_ARRAY))
{ error("array `%s' passed as actual parameter confl"
"icts with kind of formal parameter `%s' as spe"
"cified in declaration of procedure `%s' beginn"
"ing at line %d",
id->name, arg->name, arg->block->proc->name,
arg->block->proc->ssn_decl);
goto skip2;
}
actual_type = id->flags & (F_REAL | F_INT | F_BOOL);
formal_type = arg->flags & (F_REAL | F_INT | F_BOOL);
if (arg->flags & F_BYVAL)
{ actual_type &= ~(F_REAL | F_INT);
formal_type &= ~(F_REAL | F_INT);
}
if (actual_type != formal_type)
{ error("type of array `%s' passed as actual paramet"
"er conflicts with type of formal array `%s' as"
" specified in declaration of procedure `%s' be"
"ginning at line %d",
id->name, arg->name, arg->block->proc->name,
arg->block->proc->ssn_decl);
goto skip2;
}
if (id->dim >= 0 && arg->dim >= 0 &&
id->dim != arg->dim)
{ error("dimension of array `%s' passed as actual pa"
"rameter not equal to dimension of formal array"
" `%s' as implied in declaration of procedure `"
"%s' beginning at line %d",
id->name, arg->name, arg->block->proc->name,
arg->block->proc->ssn_decl);
goto skip2;
}
}
/* generate code */
if (!(id->flags & F_OWN))
{ /* local or formal array */
append(code, a_make_arg "(dsa_%d->%s_%d",
dsa_level(id), id->name, id->block->seqn);
}
else
{ /* own array */
append(code, a_make_arg "(%s_%d",
id->name, id->block->seqn);
}
append(code, ", (void *)'%c')",
(id->flags & F_REAL) ? 'r' :
(id->flags & F_INT) ? 'i' :
(id->flags & F_BOOL) ? 'b' : '?');
skip2: get_token(/* id */);
goto done;
}
if (id->flags & F_SWITCH)
{ /* actual parameter is switch identifier */
if (arg != NULL)
{ /* so the corresponding formal parameter must be only
switch */
if (!(arg->flags & F_SWITCH))
{ error("switch `%s' passed as actual parameter conf"
"licts with kind of formal parameter `%s' as sp"
"ecified in declaration of procedure `%s' begin"
"ning at line %d",
id->name, arg->name, arg->block->proc->name,
arg->block->proc->ssn_decl);
goto skip3;
}
}
/* generate code */
if (!(id->flags & F_BYNAME))
{ /* local switch */
append(code, a_make_arg "((void *)%s_%d, dsa_%d)",
id->name, id->block->seqn, current_level());
}
else
{ /* formal switch */
append(code, "dsa_%d->%s_%d",
dsa_level(id), id->name, id->block->seqn);
}
skip3: get_token(/* id */);
goto done;
}
if (id->flags & F_PROC)
{ /* actual parameter is procedure identifier */
if (arg != NULL)
{ /* so the corresponding formal parameter must be only
formal procedure of appropriate type and dimension,
or simple formal parameter of appropriate type
(since identifier of procedure having no
parameters is in itself an expression) */
int simple = !(arg->flags & ~(F_REAL | F_INT | F_BOOL
| F_BYVAL | F_BYNAME));
int actual_type, formal_type;
if (!(simple || (arg->flags & F_PROC)))
{ error("procedure `%s' passed as actual parameter c"
"onflicts with kind of formal parameter `%s' as"
" specified in declaration of procedure `%s' be"
"ginning at line %d",
id->name, arg->name, arg->block->proc->name,
arg->block->proc->ssn_decl);
goto skip4;
}
actual_type = id->flags & (F_REAL | F_INT | F_BOOL);
formal_type = arg->flags & (F_REAL | F_INT | F_BOOL);
if (actual_type & (F_REAL | F_INT))
{ actual_type &= ~(F_REAL | F_INT);
formal_type &= ~(F_REAL | F_INT);
}
if (!simple) goto proc;
/* if the corresponding formal parameter is simple
formal parameter then actual procedure must have
appropriate type and empty formal parameter part */
if (!(id->flags & (F_REAL | F_INT | F_BOOL)) ||
id->dim > 0)
{ error("procedure identifier `%s' that is not in it"
"self a complete expression and passed as actua"
"l parameter conflicts with kind of formal para"
"meter `%s' as specified in declaration of proc"
"edure `%s' beginning at line %d",
id->name, arg->name, arg->block->proc->name,
arg->block->proc->ssn_decl);
goto skip4;
}
if (actual_type != formal_type)
{ error("procedure identifier `%s' that is in itself"
" a complete expression and passed as actual pa"
"rameter conflicts with type of formal paramete"
"r `%s' as specified in declaration of procedur"
"e `%s' beginning at line %d",
id->name, arg->name, arg->block->proc->name,
arg->block->proc->ssn_decl);
goto skip4;
}
goto gen1;
proc: /* the corresponding formal parameter is formal
procedure that must be of appropriate type and
dimension (deeper checking is more expensive and
sometimes impossible, that's why omitted) */
if (actual_type != formal_type && formal_type)
{ error("type of procedure `%s' passed as actual par"
"ameter conflicts with type of formal procedure"
" `%s' as specified in declaration of procedure"
" `%s' beginning at line %d",
id->name, arg->name, arg->block->proc->name,
arg->block->proc->ssn_decl);
goto skip4;
}
if (id->dim >= 0 && arg->dim >= 0 &&
id->dim != arg->dim)
{ error("number of parameters of procedure `%s' pass"
"ed as actual parameter not equal to number of "
"parameters of formal procedure `%s' as implied"
" in declaration of procedure `%s' beginning at"
" line %d",
id->name, arg->name, arg->block->proc->name,
arg->block->proc->ssn_decl);
goto skip4;
}
}
gen1: /* generate code */
if (!(id->flags & F_BYNAME))
{ /* local procedure */
append(code, a_make_arg "((void *)%s_%d, dsa_%d)",
id->name, id->block->seqn, current_level());
}
else
{ /* formal procedure */
append(code, "dsa_%d->%s_%d",
dsa_level(id), id->name, id->block->seqn);
}
skip4: get_token(/* id */);
goto done;
}
if (id->flags & F_STRING)
{ /* actual parameter is formal string identifier */
if (arg != NULL && !(arg->flags & F_STRING))
{ error("formal string passed as actual parameter confl"
"icts with kind of formal parameter `%s' as specif"
"ied in declaration of procedure `%s' beginning at"
" line %d", arg->name, arg->block->proc->name,
arg->block->proc->ssn_decl);
goto skip5;
}
append(code, a_make_arg "(dsa_%d->%s_%d, NULL)",
dsa_level(id), id->name, id->block->seqn);
skip5: get_token(/* id */);
goto done;
}
/* in the other cases identifier as actual parameter is
treated as expression */
}
}
/* actual parameter is expression */
{ CODE *expr;
int need_dsa = 1, thunk, ssn;
/* check for constant */
if ((t_code == T_REAL || t_code == T_INT ||
t_code == T_FALSE || t_code == T_TRUE) &&
token[2].code == T_DELIM &&
(token[2].delim == S_COMMA || token[2].delim == S_RIGHT))
{ /* if expression is constant then dsa pointers is not
needed */
/* for often used constants thunks generated only once */
need_dsa = 0;
if (second_pass && t_code == T_REAL)
{ if (strcmp(t_image, "0.0") == 0 ||
strcmp(t_image, ".0") == 0)
{ /* real constant 0.0 */
if (thunk_real0 != 0)
{ thunk = thunk_real0, get_token(/* 0.0 */);
goto gen2;
}
else
thunk_real0 = thunk_count + 1;
}
else if (strcmp(t_image, "1.0") == 0)
{ /* real constant 1.0 */
if (thunk_real1 != 0)
{ thunk = thunk_real1, get_token(/* 1.0 */);
goto gen2;
}
else
thunk_real1 = thunk_count + 1;
}
}
else if (second_pass && t_code == T_INT)
{ if (strcmp(t_image, "0") == 0)
{ /* integer constant 0 */
if (thunk_int0 != 0)
{ thunk = thunk_int0, get_token(/* 0 */);
goto gen2;
}
else
thunk_int0 = thunk_count + 1;
}
else if (strcmp(t_image, "1") == 0)
{ /* integer constant 1 */
if (thunk_int1 != 0)
{ thunk = thunk_int1, get_token(/* 1 */);
goto gen2;
}
else
thunk_int1 = thunk_count + 1;
}
}
else if (second_pass && t_code == T_FALSE)
{ /* Boolean constant false */
if (thunk_false != 0)
{ thunk = thunk_false, get_token(/* false */);
goto gen2;
}
else
thunk_false = thunk_count + 1;
}
else if (second_pass && t_code == T_TRUE)
{ /* Boolean constant true */
if (thunk_true != 0)
{ thunk = thunk_true, get_token(/* true */);
goto gen2;
}
else
thunk_true = thunk_count + 1;
}
}
/* general expression which is actual parameter */
ssn = t_ssn;
expr = expression();
if (second_pass)
{ if (arg != NULL)
{ /* the corresponding formal parameter must be simple
formal parameter of appropriate type */
int actual_type, formal_type;
if (arg->flags & ~(F_REAL | F_INT | F_BOOL | F_LABEL |
F_BYVAL | F_BYNAME))
{ error("expression passed as actual parameter conflict"
"s with kind of formal parameter `%s' as specified"
" in declaration of procedure `%s' beginning at li"
"ne %d", arg->name, arg->block->proc->name,
arg->block->proc->ssn_decl);
goto skip6;
}
actual_type = expr->type;
formal_type = arg->flags &
(F_REAL | F_INT | F_BOOL | F_LABEL);
if (actual_type & (F_REAL | F_INT))
{ actual_type &= ~(F_REAL | F_INT);
formal_type &= ~(F_REAL | F_INT);
}
if (actual_type != formal_type)
{ error("type of expression passed as actual parameter "
"conflicts with type of formal parameter `%s' as s"
"pecified in declaration of procedure `%s' beginni"
"ng at line %d", arg->name, arg->block->proc->name,
arg->block->proc->ssn_decl);
goto skip6;
}
}
/* generate thunk to evaluate expression */
thunk_count++;
append(emit, "static struct desc _thunk_%d(void)\n",
thunk_count);
append(emit, "{ /* actual parameter at line %d */\n",
ssn);
append(emit, " struct desc res;\n");
if (need_dsa)
{ emit_dsa_pointers();
catenate(emit, emit_ssn(ssn));
}
append(emit, " res.lval = %d;\n", expr->lval);
switch (expr->type)
{ case F_REAL:
append(emit, " res.type = 'r';\n");
if (expr->lval)
append(emit, " res.u.real_ptr = ");
else
append(emit, " res.u.real_val = ");
break;
case F_INT:
append(emit, " res.type = 'i';\n");
if (expr->lval)
append(emit, " res.u.int_ptr = ");
else
append(emit, " res.u.int_val = ");
break;
case F_BOOL:
append(emit, " res.type = 'b';\n");
if (expr->lval)
append(emit, " res.u.bool_ptr = ");
else
append(emit, " res.u.bool_val = ");
break;
case F_LABEL:
append(emit, " res.type = 'l';\n");
append(emit, " res.u.label = ");
break;
default:
assert(expr->type != expr->type);
}
if (expr->lval)
{ append(emit, "&(");
catenate(emit, expr);
append(emit, ")");
}
else
catenate(emit, expr);
append(emit, ";\n");
append(emit, " return res;\n");
append(emit, "}\n");
append(emit, "\n");
/* generate code for actual parameter */
thunk = thunk_count;
gen2: append(code, a_make_arg "((void *)_thunk_%d, dsa_%d)",
thunk, current_level());
skip6: ;
}
}
done: return code;
}
/*----------------------------------------------------------------------
-- ext_comma - parse extended parameter delimiter.
--
-- This routine parses extended parameter delimiter using the following
-- syntax:
--
-- ::= ,
-- ::= ) : (
-- ::=
-- ::=
--
-- If the current context is an extended parameter delimiter, then the
-- routine returns non-zero, otherwise zero. */
static int ext_comma(void)
{ if (t_delim(S_COMMA))
{ get_token(/* , */);
return 1;
}
if (t_delim(S_RIGHT))
{ get_token2();
if (token[2].code != T_IDENT) return 0;
/* it is a parameter delimiter */
get_token(/* ) */);
assert(t_code == T_IDENT);
/* check that identifier is a letter string */
{ char *t;
for (t = t_image; *t; t++)
{ if (!isalpha(*t))
{ error("invalid letter string in parameter delimiter");
break;
}
}
}
get_token(/* letter string */);
if (t_delim(S_COLON))
get_token(/* : */);
else
error("missing colon in parameter delimiter");
if (t_delim(S_LEFT))
get_token(/* ( */);
else
error("missing left parenthesis in parameter delimiter");
return 1;
}
return 0;
}
/*----------------------------------------------------------------------
-- function_designator - parse function designator.
--
-- This routine parses function designator (if stmt is clear) or
-- procedure statement (if stmt is set) using the syntax:
--
-- ::=
-- ::= ( )
-- ::=
-- ::= ,
--
-- Note that is syntactically equivalent to
-- .
--
-- Output code generated by the routine has the form:
--
-- get_xxx((global_dsa = ..., id(p1, p2, ..., pn)))
--
-- where get_xxx is library routine get_real, get_int, or get_bool,
-- that converts struct desc to real, int, or bool respectively; id is
-- name of routine that represents procedure declaration and computes
-- value in form of struct desc; p1, p2, ..., pn are actual parameters
-- in form of struct arg.
--
-- If called procedure is local then global_dsa is assigned to point to
-- dsa of calling procedure, and id is name of static routine generated
-- from procedure declaration. If called procedure is formal one, then
-- global_dsa is assigned to arg.arg2 and id is arg.arg1, where arg is
-- formal parameter that represents formal procedure. */
static CODE *function_designator(int stmt)
{ IDENT *proc; /* procedure identifier */
IDENT *arg = NULL; /* formal parameter identifier */
CODE *code = new_code();
int list; /* if there is parameter list */
int dim = 0; /* number of actual parameters */
/* the current token must be (procedure) identifier */
assert(t_code == T_IDENT);
proc = look_up(t_image, 0, t_ssn);
if (second_pass)
{ /* identifier must be only procedure identifier */
if (!(proc->flags & F_PROC))
error("invalid use of `%s' as procedure identifier",
proc->name);
code->lval = 0;
code->type = proc->flags & (F_REAL | F_INT | F_BOOL);
if ((proc->flags & F_BLTIN) &&
(strcmp(proc->name, "inline") == 0 ||
strcmp(proc->name, "print") == 0))
{ /* use of pseudo procedures inline and print in function
designator is not allowed */
error("invalid use of pseudo procedure `%s' in function des"
"ignator", proc->name);
}
else if ((proc->flags & F_PROC) && code->type == 0 && !stmt)
{ /* use of typeless procedure is allowed only in procedure
statement, but not in function designator */
error("invalid use of typeless procedure `%s' in function d"
"esignator", proc->name);
}
/* generate the head of code */
append(code, "%s(",
(code->type & F_REAL) ? a_get_real :
(code->type & F_INT) ? a_get_int :
(code->type & F_BOOL) ? a_get_bool : "" /* void */);
if (proc->flags & F_BYNAME)
{ /* formal procedure */
append(code, "(" a_global_dsa " = dsa_%d->%s_%d.arg2, (*(st"
"ruct desc (*)())dsa_%d->%s_%d.arg1)(",
dsa_level(proc), proc->name, proc->block->seqn,
dsa_level(proc), proc->name, proc->block->seqn);
}
else
{ /* local procedure */
append(code, "(" a_global_dsa " = (void *)dsa_%d, %s_%d(",
current_level(), proc->name, proc->block->seqn);
}
}
get_token(/* id */);
/* process actual parameter part */
list = t_delim(S_LEFT);
if (!list) goto skip; /* actual parameter part is empty */
/* get pointer to the first formal parameter in order to check
actual-formal correspondence (this checking is performed on
the second pass and is possible only for local procedure) */
if (second_pass && (proc->flags & F_PROC) &&
!(proc->flags & F_BYNAME))
{ /* all formal parameters are localized in procedure block */
BLOCK *b;
for (b = first_b; b != NULL; b = b->next)
if (b->proc == proc) break;
assert(b != NULL);
arg = b->first;
}
/* process actual parameter list */
get_token(/* ( */);
for (;;)
{ /* translate the current actual parameter */
catenate(code, actual_parameter(arg));
dim++;
if (!ext_comma()) break;
append(code, ", ");
/* get pointer to the next formal parameter */
if (second_pass && arg != NULL) arg = arg->next;
/* extended parameter delimiter following actual parameter
means that more actual parameter is expected */
}
/* end of actual parameter list */
if (!t_delim(S_RIGHT))
error("missing right parenthesis after actual parameter list");
skip: /* check number of actual parameter */
if (proc->dim < 0) proc->dim = dim;
if (second_pass && (proc->flags & F_PROC) && proc->dim != dim)
{ if (proc->flags & F_BYNAME)
error("number of parameters in function designator or proce"
"dure statement conflicts with earlier use of procedure "
"`%s'", proc->name);
else
error("number of parameters in function designator or proce"
"dure statement conflicts with declaration of procedure "
"`%s' beginning at line %d", proc->name, proc->ssn_decl);
}
if (list && t_delim(S_RIGHT)) get_token(/* ) */);
/* generate the tail of code */
append(code, ")))");
return code;
}
/*----------------------------------------------------------------------
-- block_level - determine current block level.
--
-- This routine determines level of current block. This level is depth
-- of block in procedure, i.e. in block subtree the root of which is
-- procedure block that has level 0. */
static int block_level(BLOCK *b)
{ int level = -1;
for (b = b; b != NULL; b = b->surr)
{ level++;
if (b->proc != NULL) break;
}
assert(level >= 0);
return level;
}
/*----------------------------------------------------------------------
-- call_by_name - generate code to call by name.
--
-- This routine generates output code to call formal parameter id by
-- name (the corresponding actual parameter must be thunk or procedure
-- with empty parameter part).
--
-- Output code generated by the routine has the form:
--
-- (global_dsa = arg.arg2, arg.arg1())
--
-- where arg is object of struct arg type representing formal parameter
-- to be called. The result of evaluation if this code is always value
-- represented by struct desc. */
static CODE *call_by_name(IDENT *id)
{ CODE *code = new_code();
if (second_pass)
{ append(code,
"(" a_global_dsa " = dsa_%d->%s_%d.arg2, (*(struct desc (*)"
"(void))dsa_%d->%s_%d.arg1)())",
dsa_level(id), id->name, id->block->seqn,
dsa_level(id), id->name, id->block->seqn);
}
return code;
}
/*----------------------------------------------------------------------
-- primary - parse primary expression.
--
-- This routine parse primary expression using the following syntax:
--
-- ::=
-- ::=
-- ::=
-- ::=
-- ::=
-- ::= ( )
--
-- If primary expression is a constant then output code has the form:
--
-- con
--
-- where con is appropriate constant valid in the C.
--
-- If primary expression is identifier of local or own simple variable,
-- or is identifier of formal parameter called by value then output code
-- has the form:
--
-- dsa_k->id_n (or id_n for own variables)
--
-- where k is level of DSA in which identifier is placed, and n is the
-- number of block used as suffix.
--
-- If primary expression is identifier of simple formal parameter called
-- by name then output code has the form:
--
-- get_xxx((global_dsa = arg.arg2, arg.arg1()))
--
-- where get_xxx is library routine get_real, get_int, or get_bool,
-- that converts struct desc (returned by thunk or routine corresponding
-- to type procedure with empty formal parameter list) to real, int, or
-- bool respectively (see also the routine call_by_name).
--
-- If primary expression is identifier of local label then output code
-- has the form:
--
-- make_label(dsa_k->jump_l, kase)
--
-- where l is level of block in which local label implicitly declared,
-- kase is the sequential number of label in that block (this number
-- used as the second parameter to longjmp to perform global go to).
-- The library routine make_label uses two parameters to make struct
-- label that can be considered as "value of label".
--
-- If primary expression is identifier of formal label called by value
-- then output code is the same as if it were local variable that has
-- "value of label" (struct label).
--
-- If primary expression is identifier of formal label called by name
-- then output code is the same as if it were formal variable called by
-- name that has "value of label" (struct label). Of course, this value
-- will be evaluated by thunk as value of designational expression.
--
-- If primary expression is an expression enclosed by parenthesis then
-- output code inherits these parenthesis.
--
-- In the other cases output code is the same as generated by the
-- corresponding parsing routines of low level. */
static CODE *primary(void)
{ CODE *code;
if (t_code == T_REAL)
{ /* real constant */
code = new_code();
if (second_pass)
{ code->lval = 0;
code->type = F_REAL;
/* leading zeros should be removed (to avoid treatment as
something like octal literal), and ten symbol should be
replaced by 'e'; we need be careful when something like
'000#+123' or '#-321' is processed */
{ char *ptr, *ten;
for (ptr = t_image; *ptr != '\0'; ptr++)
if (*ptr != '0') break;
assert(*ptr != '\0');
if (*ptr == TEN_CHAR && ptr != t_image) ptr--;
ten = strchr(ptr, TEN_CHAR);
if (ten != NULL) *ten = 'e';
append(code, "%s%s", ten == ptr ? "1" : "", ptr);
}
}
get_token(/* real constant */);
}
else if (t_code == T_INT)
{ /* integer constant */
code = new_code();
if (second_pass)
{ code->lval = 0;
code->type = F_INT;
/* leading zeros should be removed to avoid error treatment
of integer constant as octal one */
{ char *ptr;
for (ptr = t_image; *ptr != '\0'; ptr++)
if (*ptr != '0') break;
if (*ptr == '\0') ptr--;
append(code, "%s", ptr);
}
}
get_token(/* integer constant */);
}
else if (t_code == T_FALSE || t_code == T_TRUE)
{ /* logical constant false or true */
code = new_code();
if (second_pass)
{ code->lval = 0;
code->type = F_BOOL;
append(code, "%s",
t_code == T_FALSE ? a_false : a_true);
}
get_token(/* false or true */);
}
else if (t_code == T_IDENT)
{ /* identifier */
IDENT *id = look_up(t_image, 0, t_ssn);
/* we need token[2] hint */
get_token2();
if (token[2].code == T_DELIM && token[2].delim == S_BEGSUB)
{ /* subscripted variable or switch designator */
/* on the first pass switch designator is processed as if it
were subscripted variable */
if (first_pass || !(id->flags & F_SWITCH))
code = subscripted_variable();
else
code = switch_designator();
}
else if (token[2].code == T_DELIM && token[2].delim == S_LEFT)
{ /* function designator (with non-empty parameter part) */
proc: code = function_designator(0);
}
else
{ /* identifier or function designator (with empty parameter
part) */
if (second_pass && (id->flags & F_PROC)) goto proc;
/* on the first pass function designator is processed as if
if it were simple variable */
code = new_code();
if (second_pass)
{ switch (id->flags)
{ case F_REAL:
/* real local simple variable */
case F_REAL | F_OWN:
/* real own simple variable */
case F_REAL | F_BYVAL:
/* real formal parameter called by value */
case F_INT:
/* integer local simple variable */
case F_INT | F_OWN:
/* integer own simple variable */
case F_INT | F_BYVAL:
/* integer formal parameter called by value */
case F_BOOL:
/* Boolean local simple variable */
case F_BOOL | F_OWN:
/* Boolean own simple variable */
case F_BOOL | F_BYVAL:
/* Boolean formal parameter called by value */
code->lval = 1;
code->type = id->flags & (F_REAL | F_INT | F_BOOL);
if (id->flags & F_OWN)
append(code, "%s_%d", id->name, id->block->seqn)
;
else
append(code, "dsa_%d->%s_%d",
dsa_level(id), id->name, id->block->seqn);
break;
case F_REAL | F_BYNAME:
/* real formal parameter called by name */
/* only value is processed here */
code->lval = 0;
code->type = F_REAL;
append(code, a_get_real "(");
catenate(code, call_by_name(id));
append(code, ")");
break;
case F_INT | F_BYNAME:
/* integer formal parameter called by name */
/* only value is processed here */
code->lval = 0;
code->type = F_INT;
append(code, a_get_int "(");
catenate(code, call_by_name(id));
append(code, ")");
break;
case F_BOOL | F_BYNAME:
/* Boolean formal parameter called by name */
/* only value is processed here */
code->lval = 0;
code->type = F_BOOL;
append(code, a_get_bool "(");
catenate(code, call_by_name(id));
append(code, ")");
break;
case F_LABEL:
/* local label */
code->lval = 0;
code->type = F_LABEL;
append(code, a_make_label "(dsa_%d->jump_%d, %d)",
dsa_level(id), block_level(id->block), id->dim);
break;
case F_LABEL | F_BYVAL:
/* formal label called by value */
code->lval = 0;
code->type = F_LABEL;
append(code, "dsa_%d->%s_%d",
dsa_level(id), id->name, id->block->seqn);
break;
case F_LABEL | F_BYNAME:
/* formal label called by name */
code->lval = 0;
code->type = F_LABEL;
append(code, a_get_label "(");
catenate(code, call_by_name(id));
append(code, ")");
break;
default:
error("invalid use of identifier `%s' as expressio"
"n operand", id->name);
code->lval = 0;
code->type = F_INT;
break;
}
}
get_token(/* id */);
}
}
else if (t_delim(S_LEFT))
{ /* expression enclosed by parentheses */
get_token(/* ( */);
code = expression();
if (t_delim(S_RIGHT))
get_token(/* ) */);
else
error("missing right parenthesis after expression");
if (second_pass)
{ code->lval = 0;
prepend(code, "(");
append(code, ")");
}
}
else if (t_code == T_STRING)
{ error("invalid use of string as expression operand");
get_token(/* "..." */);
code = new_code();
}
else if (t_code == T_DELIM)
{ error("invalid use of delimiter `%s' as expression operand",
t_image);
get_token(/* delim */);
code = new_code();
}
else
assert(t_code != t_code);
return code;
}
/*----------------------------------------------------------------------
-- factor, term, arith_expression, relation, bool_primary, bool_factor,
-- bool_term, implication, simple_expr - parse intermediate expression.
--
-- These routines parse intermediate expression using the following
-- productions:
--
-- ::=
-- ::= **
-- ::=
-- ::= *
-- ::= /
-- ::= %
-- ::=
-- ::= +
-- ::= -
-- ::= +
-- ::= -
-- ::=
-- ::= < | <= | = | >= | > | !=
-- ::=
-- ::= !
-- ::=
-- ::= &
-- ::=
-- ::= |
-- ::=
-- ::= ->
-- ::=
-- ::= ==
--
-- Each parsing routine of this group parses intermediate expression
-- that corresponds to appropriate non-terminal (exculding ). And
-- all these routines work in the same manner.
--
-- Output code generated by each routine inherits output code of source
-- expression operands connected by appropriate operator (for relations
-- and Boolean expressions operators are implemented through macros to
-- avoid some problems due to "lazy calculations" specific to the C). */
static CODE *factor(void)
{ CODE *x, *y;
x = primary();
while (t_delim(S_POWER))
{ if (second_pass)
{ if (!(x->type == F_INT || x->type == F_REAL))
{ error("operand preceding `^' is not of arithmetic type");
x->type = F_INT;
}
}
get_token(/* ^ */);
y = primary();
if (second_pass)
{ if (!(y->type == F_INT || y->type == F_REAL))
{ error("operand following `^' is not of arithmetic type");
y->type = F_INT;
}
x->lval = 0;
if (y->type == F_REAL)
to_real(x), prepend(x, a_expr "(");
else if (x->type == F_REAL)
prepend(x, a_expn "(");
else
prepend(x, a_expi "(");
append(x, ", ");
catenate(x, y);
append(x, ")");
}
}
return x;
}
static CODE *term(void)
{ CODE *x, *y;
x = factor();
while (t_delim(S_TIMES) || t_delim(S_SLASH) || t_delim(S_INTDIV))
{ int op = token[1].delim;
if (second_pass)
{ if (!(x->type == F_INT || x->type == F_REAL))
{ error("operand preceding `*', `/', or `%%' is not of ari"
"thmetic type");
x->type = F_INT;
}
if (op == S_INTDIV && x->type != F_INT)
{ error("operand preceding `%%' is not of integer type");
x->type = F_INT;
}
}
get_token(/* * or / or % */);
y = factor();
if (second_pass)
{ if (!(y->type == F_INT || y->type == F_REAL))
{ error("operand following `*', `/', or `%%' is not of ari"
"thmetic type");
y->type = F_INT;
}
if (op == S_INTDIV && y->type != F_INT)
{ error("operand following `%%' is not of integer type");
y->type = F_INT;
}
x->lval = 0;
if (x->type == F_REAL || op == S_SLASH || y->type == F_REAL)
to_real(x), to_real(y);
append(x, " %c ", op == S_TIMES ? '*' : '/');
catenate(x, y);
}
}
return x;
}
static CODE *arith_expression(void)
{ CODE *x, *y;
if (t_delim(S_PLUS) || t_delim(S_MINUS))
{ int op = token[1].delim;
get_token(/* + or - */);
x = term();
if (second_pass)
{ if (!(x->type == F_INT || x->type == F_REAL))
{ error("operand following unary `+' or `-' is not of arit"
"hmetic type");
x->type = F_INT;
}
x->lval = 0;
prepend(x, "%c", op == S_PLUS ? '+' : '-');
}
}
else
x = term();
while (t_delim(S_PLUS) || t_delim(S_MINUS))
{ int op = token[1].delim;
if (second_pass)
{ if (!(x->type == F_INT || x->type == F_REAL))
{ error("operand preceding `+' or `-' is not of arithmetic"
" type");
x->type = F_INT;
}
}
get_token(/* + or - */);
y = term();
if (second_pass)
{ if (!(y->type == F_INT || y->type == F_REAL))
{ error("operand following `+' or `-' is not of arithmetic"
" type");
y->type = F_INT;
}
x->lval = 0;
if (x->type == F_REAL || y->type == F_REAL)
to_real(x), to_real(y);
append(x, " %c ", op == S_PLUS ? '+' : '-');
catenate(x, y);
}
}
return x;
}
static CODE *relation(void)
{ CODE *x, *y;
int flag = 0;
/* context ... ... ... is invalid because
can't be operand of relational operator; nevertheless such
context is processed as if it were valid to correct error */
x = arith_expression();
while (t_delim(S_LESS) || t_delim(S_NOTGREATER) ||
t_delim(S_EQUAL) || t_delim(S_NOTLESS) ||
t_delim(S_GREATER) || t_delim(S_NOTEQUAL))
{ int op = token[1].delim;
if (flag)
error("invalid use of relational operator");
flag = 1;
if (second_pass)
{ if (!(x->type == F_INT || x->type == F_REAL))
{ error("operand preceding relational operator is not of a"
"rithmetic type");
x->type = F_INT;
}
}
get_token(/* */);
y = arith_expression();
if (second_pass)
{ if (!(y->type == F_INT || y->type == F_REAL))
{ error("operand following relational operator is not of a"
"rithmetic type");
y->type = F_INT;
}
if (x->type == F_REAL || y->type == F_REAL)
to_real(x), to_real(y);
x->lval = 0;
x->type = F_BOOL;
prepend(x, "%s(",
op == S_LESS ? a_less :
op == S_NOTGREATER ? a_notgreater :
op == S_EQUAL ? a_equal :
op == S_NOTLESS ? a_notless :
op == S_GREATER ? a_greater :
op == S_NOTEQUAL ? a_notequal : "???");
append(x, ", ");
catenate(x, y);
append(x, ")");
}
}
return x;
}
static CODE *bool_primary(void)
{ CODE *x;
if (!t_delim(S_NOT))
x = relation();
else
{ get_token(/* ! */);
x = relation();
if (second_pass)
{ if (x->type != F_BOOL)
{ error("operand following `!' is not of Boolean type");
x->type = F_BOOL;
}
x->lval = 0;
prepend(x, a_not "(");
append(x, ")");
}
}
return x;
}
static CODE *bool_factor(void)
{ CODE *x, *y;
x = bool_primary();
while (t_delim(S_AND))
{ if (second_pass)
{ if (x->type != F_BOOL)
{ error("operand preceding `&' is not of Boolean type");
x->type = F_BOOL;
}
}
get_token(/* & */);
y = bool_primary();
if (second_pass)
{ if (y->type != F_BOOL)
{ error("operand following `&' is not of Boolean type");
y->type = F_BOOL;
}
x->lval = 0;
prepend(x, a_and "(");
append(x, ", ");
catenate(x, y);
append(x, ")");
}
}
return x;
}
static CODE *bool_term(void)
{ CODE *x, *y;
x = bool_factor();
while (t_delim(S_OR))
{ if (second_pass)
{ if (x->type != F_BOOL)
{ error("operand preceding `|' is not of Boolean type");
x->type = F_BOOL;
}
}
get_token(/* & */);
y = bool_factor();
if (second_pass)
{ if (y->type != F_BOOL)
{ error("operand following `|' is not of Boolean type");
y->type = F_BOOL;
}
x->lval = 0;
prepend(x, a_or "(");
append(x, ", ");
catenate(x, y);
append(x, ")");
}
}
return x;
}
static CODE *implication(void)
{ CODE *x, *y;
x = bool_term();
while (t_delim(S_IMPL))
{ if (second_pass)
{ if (x->type != F_BOOL)
{ error("operand preceding `->' is not of Boolean type");
x->type = F_BOOL;
}
}
get_token(/* & */);
y = bool_term();
if (second_pass)
{ if (y->type != F_BOOL)
{ error("operand following `->' is not of Boolean type");
y->type = F_BOOL;
}
x->lval = 0;
prepend(x, a_impl "(");
append(x, ", ");
catenate(x, y);
append(x, ")");
}
}
return x;
}
static CODE *simple_expr(void)
{ CODE *x, *y;
x = implication();
while (t_delim(S_EQUIV))
{ if (second_pass)
{ if (x->type != F_BOOL)
{ error("operand preceding `==' is not of Boolean type");
x->type = F_BOOL;
}
}
get_token(/* & */);
y = implication();
if (second_pass)
{ if (y->type != F_BOOL)
{ error("operand following `==' is not of Boolean type");
y->type = F_BOOL;
}
x->lval = 0;
prepend(x, a_equiv "(");
append(x, ", ");
catenate(x, y);
append(x, ")");
}
}
return x;
}
/*----------------------------------------------------------------------
-- expression - parse general expression.
--
-- This routine parse expression of general kind using the syntax:
--
-- ::=
-- ::= if then else
--
--
-- The first case is obvious. In the second case output code has the
-- form:
--
-- ((condition) ? (simple expression) : (expression))
--
-- where condition is expression following 'if' symbol. */
static CODE *expression(void)
{ CODE *x;
if (!t_delim(S_IF))
x = simple_expr();
else
{ CODE *sae, *ae;
get_token(/* if */);
x = expression();
if (!t_delim(S_THEN))
error("missing `then' delimiter");
if (second_pass && x->type != F_BOOL)
error("expression following `if' is not of Boolean type");
if (t_delim(S_THEN)) get_token(/* then */);
sae = simple_expr(); /* expression before else */
if (t_delim(S_ELSE))
get_token(/* else */);
else
error("missing `else' delimiter");
ae = expression(); /* expression after else */
if (second_pass)
{ if (sae->type == F_INT && ae->type == F_REAL) to_real(sae);
if (sae->type == F_REAL && ae->type == F_INT) to_real(ae);
if (sae->type != ae->type)
error("expressions before and after 'else' incompatible")
;
x->lval = 0;
x->type = sae->type;
prepend(x, "((");
append(x, ") ? (");
catenate(x, sae);
append(x, ") : (");
catenate(x, ae);
append(x, "))");
}
}
return x;
}
/*----------------------------------------------------------------------
-- assignment_statement - parse assignment statement.
--
-- This routine parses assignment statement using the syntax:
--
-- ::= :=
-- ::= :=
-- ::=
-- ::=
-- ::=
-- ::=
--
-- If flag is clear then the routine is called on statement level.
-- Otherwise if flag is set the routine is called after ':=' delimiter.
--
-- If destination is simple local or own variable or simple formal
-- parameter called by value then output code has the form:
--
-- dsa_k->id_n = expression (or id_n = expression for own variables)
--
-- where k is level of DSA in which identifier is placed, and n is the
-- number of block used as suffix.
--
-- If destination is simple formal parameter called by name then the
-- output code has the form:
--
-- set_xxx((global_dsa = arg.arg2, arg.arg1()), expression)
--
-- where set_xxx is library routine set_real, set_int, or set_bool,
-- that uses struct desc (returned by thunk) to assign expression value
-- to the appropriate variable. Each routine set_xxx returns the value
-- of expression so it can be used to further assignment.
--
-- If destination is procedure identifier (in this case assignment
-- statement must be located inside the procedure body) then the output
-- code has the form:
--
-- dsa_k->retval.u.xxx_val = expression
--
-- where retval is object of struct desc type used as value returned
-- by procedure.
--
-- If destination is subscripted variable then the output code has the
-- form:
--
-- *loc_xxx(dv, n, i1, i2, ..., in) = expression
--
-- (see also the routine subscripted_variable). */
static CODE *assignment_statement(int flag)
{ CODE *x;
if (t_code == T_IDENT) get_token2();
if (t_code == T_IDENT &&
token[2].code == T_DELIM && token[2].delim == S_ASSIGN)
{ /* the current context has the form id := ... */
IDENT *id = look_up(t_image, 0, t_ssn);
if (first_pass)
{ /* skip all semantic checks */
get_token(/* id */), get_token(/* := */);
assignment_statement(1);
goto skip1;
}
/* identifier must denote only simple variable, simple formal
parameter, or type procedure */
if (id->flags & F_LABEL)
error("invalid use of label `%s' in left part of assignment"
" statement", id->name);
else if (id->flags & F_ARRAY)
error("invalid use of array identifier `%s' in left part of"
" assignment statement", id->name);
else if (id->flags & F_SWITCH)
error("invalid use of switch identifier `%s' in left part o"
"f assignment statement", id->name);
else if (id->flags & F_STRING)
error("invalid use of formal string `%s' in left part of as"
"signment statement", id->name);
else if (id->flags & F_PROC)
{ /* if identifier denotes procedure then assignment statement
must be located only inside body of that procedure */
BLOCK *b;
for (b = current; b != NULL; b = b->surr)
if (b->proc == id) break;
if (b == NULL)
error("invalid assignment to procedure identifier `%s' o"
"utside procedure declaration body", id->name);
/* and procedure must have type */
if (!(id->flags & (F_REAL | F_INT | F_BOOL)))
error("invalid use of typeless procedure identifier `%s'"
" in left part of assignment statement", id->name);
}
get_token(/* id */), get_token(/* := */);
/* parse the rest part of assignment statement that can be
again assignment statement or final expression; this is
resolved by means of lval flag */
x = assignment_statement(1);
/* clear lvalue flag if x is final expression */
if (!t_delim(S_ASSIGN)) x->lval = 0;
/* type conversion is allowed only for final expression */
if (x->lval == 0)
{ /* after delimiter := final expression detected */
if ((id->flags & F_REAL) && x->type == F_INT) to_real(x);
if ((id->flags & F_INT) && x->type == F_REAL) to_int(x);
if ((id->flags & (F_REAL | F_INT | F_BOOL)) != x->type)
error("type of identifier `%s' in left part of assignmen"
"t statement incompatible with type of assigned expre"
"ssion", id->name);
}
else
{ /* after delimiter := assignement statement detected; type
conversion is not allowed */
if ((id->flags & (F_REAL | F_INT | F_BOOL)) != x->type)
error("different types in left part list of assignment s"
"tatement");
}
/* generate code */
switch (id->flags)
{ case F_REAL:
/* real local simple variable */
case F_REAL | F_OWN:
/* real own simple variable */
case F_REAL | F_BYVAL:
/* real simple formal parameter called by value */
case F_INT:
/* integer local simple variable */
case F_INT | F_OWN:
/* integer own simple variable */
case F_INT | F_BYVAL:
/* integer simple formal parameter called by value */
case F_BOOL:
/* Boolean local simple variable */
case F_BOOL | F_OWN:
/* Boolean own simple variable */
case F_BOOL | F_BYVAL:
/* Boolean simple formal parameter called by value */
x->lval = 1; /* mark assignment statement */
x->type = id->flags & (F_REAL | F_INT | F_BOOL);
if (id->flags & F_OWN)
prepend(x, "%s_%d = ", id->name, id->block->seqn);
else
prepend(x, "dsa_%d->%s_%d = ",
dsa_level(id), id->name, id->block->seqn);
break;
case F_REAL | F_BYNAME:
/* real simple formal parameter called by name */
{ CODE *code = call_by_name(id);
prepend(code, a_set_real "(");
append(code, ", ");
catenate(code, x);
append(code, ")");
x = code;
x->lval = 1; /* mark assignment statement */
x->type = F_REAL;
}
break;
case F_INT | F_BYNAME:
/* integer simple formal parameter called by name */
{ CODE *code = call_by_name(id);
prepend(code, a_set_int "(");
append(code, ", ");
catenate(code, x);
append(code, ")");
x = code;
x->lval = 1; /* mark assignment statement */
x->type = F_INT;
}
break;
case F_BOOL | F_BYNAME:
/* Boolean simple formal parameter called by name */
{ CODE *code = call_by_name(id);
prepend(code, a_set_bool "(");
append(code, ", ");
catenate(code, x);
append(code, ")");
x = code;
x->lval = 1; /* mark assignment statement */
x->type = F_BOOL;
}
break;
case F_REAL | F_PROC:
/* real local procedure */
case F_INT | F_PROC:
/* integer local procedure */
case F_BOOL | F_PROC:
/* Boolean local procedure */
x->lval = 1; /* mark assignment statement */
x->type = id->flags & (F_REAL | F_INT | F_BOOL);
prepend(x, "dsa_%d->retval.u.%s = ", dsa_level(id)+1,
x->type == F_REAL ? "real_val" :
x->type == F_INT ? "int_val" :
x->type == F_BOOL ? "bool_val" : "???");
break;
default:
/* error diagnostics has yet generated */
break;
}
skip1: ;
}
else
{ /* the current context or begins left part (which must be only
subscripted variable), or is final expression */
CODE *y;
x = expression();
if (t_delim(S_ASSIGN))
{ /* the current context has the form ... := ergo expression
must be only subscripted variable */
if (second_pass && !x->lval)
error("invalid use of delimiter `:=' after expression in"
" assignment statement");
get_token(/* := */);
y = assignment_statement(1);
/* igitur, x := y */
if (first_pass) goto skip2;
/* type conversion is allowed only for final expression */
if (y->lval == 0)
{ /* after delimiter := final expression detected */
if (x->type == F_REAL && y->type == F_INT) to_real(y);
if (x->type == F_INT && y->type == F_REAL) to_int(y);
if (x->type != y->type)
error("type of destination in left part of assignment"
" statement incompatible with type of assigned exp"
"ression");
}
else
{ /* after delimiter := assignement statement detected;
type conversion is not allowed */
if (x->type != y->type)
error("different types in left part list of assignmen"
"t statement");
}
/* generate code */
x->lval = 1; /* mark assignment statement */
append(x, " = ");
catenate(x, y);
skip2: ;
}
else
{ /* final expression reached */
if (first_pass) goto skip3;
/* it is allowed only after := delimiter */
if (!flag)
{ error("invalid use of expression");
goto skip3;
}
if (!(x->type == F_REAL || x->type == F_INT ||
x->type == F_BOOL))
{ error("invalid type of assigned expression in assignment"
" statement");
x->type = F_REAL;
}
/* x is final expression, so clear its lvalue flag */
x->lval = 0;
skip3: ;
}
}
if (!flag)
{ prepend(x, " ");
append(x, ";\n");
}
return x;
}
/*----------------------------------------------------------------------
-- go_to_statement - parse go to statement.
--
-- This routine parses go to statement using the syntax:
--
-- ::= go to
--
-- If and only if designational expression is a label which is located
-- in the same block as go to statement it is possible to perform go to
-- directly. In this case output code has the form:
--
-- goto id_n
--
-- where id_n is label identifier suffixed by sequential number of
-- block in which the label is localized.
--
-- In all other cases output code has the form:
--
-- go_to(expression)
--
-- where go_to is a library routine that uses expression as the value
-- of struct label to perform global go to. */
static CODE *go_to_statement(void)
{ CODE *code;
/* the current token must be 'go to' */
assert(t_delim(S_GOTO));
get_token(/* go to */);
/* if delimiter 'go to' is followed by label identifier (but not
general designational expression) and if this label is located
in the current block then direct go to is possible*/
if (second_pass && t_code == T_IDENT)
{ get_token2();
if (token[2].code == T_DELIM &&
(token[2].delim == S_SEMICOLON ||
token[2].delim == S_ELSE || token[2].delim == S_END))
{ IDENT *id = look_up(t_image, 0, t_ssn);
if (!(id->flags & F_LABEL))
error("invalid use identifier `%s' as a label in go to s"
"tatement", id->name);
if (id->flags == F_LABEL && id->block == current)
{ /* go to local label in the same block */
code = new_code();
append(code, " goto %s_%d;\n",
id->name, id->block->seqn);
get_token(/* id */);
goto done;
}
}
}
/* otherwise general designational expression is used */
code = expression();
if (second_pass)
{ if (code->type != F_LABEL)
error("expression following `go to' is not of label type");
prepend(code, " " a_go_to "(");
append(code, ");\n");
}
done: return code;
}
/*----------------------------------------------------------------------
-- dummy_statement - parse dummy statement.
--
-- This routine parses dummy statement using the syntax:
--
-- ::=
--
-- Output code has obvious form. */
static CODE *dummy_statement(void)
{ CODE *code = new_code();
append(code, " /* */;\n");
return code;
}
/*----------------------------------------------------------------------
-- emit_ssn - generate source line number.
--
-- This routine generates output code to remember source line number
-- ssn in DSA of current procedure. */
static CODE *emit_ssn(int ssn)
{ CODE *code = new_code();
append(code, " dsa_%d->line = %d;\n", current_level(), ssn);
return code;
}
/*----------------------------------------------------------------------
-- label_list - parse label list.
--
-- This routine parses list of labels optionally preceding a statement
-- using the syntax:
--
--