}
else
if (nch == '>') {
- return tk->tk_symb = UNEQUAL;
+ return tk->tk_symb = '#';
}
PushBack(nch);
return tk->tk_symb = ch;
case STSTR:
GetString(ch);
- tk->tk_data.tk_str = string;
+ tk->tk_data.tk_str = (struct string *)
+ Malloc(sizeof (struct string));
+ *(tk->tk_data.tk_str) = string;
return tk->tk_symb = STRING;
case STNUM:
int tk_lineno; /* linenumber on which it occurred */
union {
struct idf *tk_idf; /* IDENT */
- struct string tk_str; /* STRING */
+ struct string *tk_str; /* STRING */
arith tk_int; /* INTEGER */
char *tk_real; /* REAL */
arith *tk_set; /* only used in parse tree node */
};
#define TOK_IDF tk_data.tk_idf
-#define TOK_STR tk_data.tk_str.s_str
-#define TOK_SLE tk_data.tk_str.s_length
+#define TOK_STR tk_data.tk_str->s_str
+#define TOK_SLE tk_data.tk_str->s_length
#define TOK_INT tk_data.tk_int
#define TOK_REL tk_data.tk_real
LLmessage.o: LLlex.h Lpars.h idf.h
char.o: class.h
error.o: LLlex.h debug.h errout.h f_info.h input.h inputtype.h main.h node.h
-main.o: LLlex.h Lpars.h debug.h def.h f_info.h idf.h input.h inputtype.h scope.h standards.h tokenname.h type.h
+main.o: LLlex.h Lpars.h debug.h def.h f_info.h idf.h input.h inputtype.h node.h scope.h standards.h tokenname.h type.h
symbol2str.o: Lpars.h
tokenname.o: Lpars.h idf.h tokenname.h
idf.o: idf.h
input.o: f_info.h input.h inputtype.h
-type.o: LLlex.h const.h debug.h def.h idf.h node.h target_sizes.h type.h
+type.o: LLlex.h const.h debug.h def.h idf.h maxset.h node.h target_sizes.h type.h
def.o: LLlex.h debug.h def.h idf.h main.h node.h scope.h type.h
scope.o: LLlex.h debug.h def.h idf.h node.h scope.h type.h
misc.o: LLlex.h f_info.h idf.h misc.h node.h
cstoper.o: LLlex.h Lpars.h idf.h node.h standards.h target_sizes.h type.h
chk_expr.o: LLlex.h Lpars.h const.h debug.h def.h idf.h node.h scope.h standards.h type.h
options.o: idfsize.h type.h
-walk.o: debug.h def.h main.h scope.h type.h
+walk.o: LLlex.h Lpars.h debug.h def.h main.h node.h scope.h type.h
tokenfile.o: Lpars.h
program.o: LLlex.h Lpars.h debug.h def.h idf.h main.h node.h scope.h type.h
declar.o: LLlex.h Lpars.h def.h idf.h main.h misc.h node.h scope.h type.h
expression.o: LLlex.h Lpars.h const.h debug.h def.h idf.h node.h scope.h type.h
-statement.o: LLlex.h Lpars.h node.h type.h
+statement.o: LLlex.h Lpars.h def.h idf.h node.h scope.h type.h
Lpars.o: Lpars.h
#undef INP_READ_IN_ONE 1 /* read input file in one */
+!File: maxset.h
+#define MAXSET 1024 /* maximum number of elements in a set,
+ but what is a reasonable choice ???
+ */
+
+
case Link:
return chk_name(expp);
+
default:
assert(0);
}
/* First determine the type of the set
*/
- if (expp->nd_left) {
+ if (nd = expp->nd_left) {
/* A type was given. Check it out
*/
- findname(expp->nd_left);
- assert(expp->nd_left->nd_class == Def);
- df = expp->nd_left->nd_def;
+ findname(nd);
+ assert(nd->nd_class == Def);
+ df = nd->nd_def;
+
if (!(df->df_kind & (D_TYPE|D_ERROR)) ||
(df->df_type->tp_fund != T_SET)) {
- node_error(expp, "illegal set type");
+ node_error(expp, "specifier does not represent a set type");
return 0;
}
tp = df->df_type;
+ FreeNode(expp->nd_left);
+ expp->nd_left = 0;
}
else tp = bitset_type;
/* Now check the elements given, and try to compute a constant set.
+ First allocate room for the set
*/
set = (arith *)
Malloc((unsigned) (tp->tp_size * sizeof(arith) / word_size));
+
+ /* Now check the elements, one by one
+ */
nd = expp->nd_right;
while (nd) {
assert(nd->nd_class == Link && nd->nd_symb == ',');
+
if (!chk_el(nd->nd_left, tp->next, &set)) return 0;
nd = nd->nd_right;
}
+
expp->nd_type = tp;
+
if (set) {
/* Yes, it was a constant set, and we managed to compute it!
Notice that at the moment there is no such thing as
*/
expp->nd_class = Set;
expp->nd_set = set;
- FreeNode(expp->nd_left);
FreeNode(expp->nd_right);
- expp->nd_left = expp->nd_right = 0;
+ expp->nd_right = 0;
}
+
return 1;
}
Also try to compute the set!
*/
register int i;
+ register struct node *left = expp->nd_left;
+ register struct node *right = expp->nd_right;
if (expp->nd_class == Link && expp->nd_symb == UPTO) {
/* { ... , expr1 .. expr2, ... }
First check expr1 and expr2, and try to compute them.
*/
- if (!chk_el(expp->nd_left, tp, set) ||
- !chk_el(expp->nd_right, tp, set)) {
+ if (!chk_el(left, tp, set) || !chk_el(right, tp, set)) {
return 0;
}
- if (expp->nd_left->nd_class == Value &&
- expp->nd_right->nd_class == Value) {
+
+ if (left->nd_class == Value && right->nd_class == Value) {
/* We have a constant range. Put all elements in the
set
*/
- if (expp->nd_left->nd_INT > expp->nd_right->nd_INT) {
+ if (left->nd_INT > right->nd_INT) {
node_error(expp, "lower bound exceeds upper bound in range");
return rem_set(set);
}
-
- if (*set) for (i = expp->nd_left->nd_INT + 1;
- i < expp->nd_right->nd_INT; i++) {
- (*set)[i/wrd_bits] |= (1 << (i % wrd_bits));
+
+ if (*set) {
+ for (i=left->nd_INT+1; i<right->nd_INT; i++) {
+ (*set)[i/wrd_bits] |= (1<<(i%wrd_bits));
+ }
}
}
else if (*set) {
free((char *) *set);
*set = 0;
}
+
return 1;
}
if (!chk_expr(expp)) {
return rem_set(set);
}
+
if (!TstCompat(tp, expp->nd_type)) {
node_error(expp, "set element has incompatible type");
return rem_set(set);
}
+
if (expp->nd_class == Value) {
+ /* a constant element
+ */
i = expp->nd_INT;
+
if ((tp->tp_fund != T_ENUMERATION &&
(i < tp->sub_lb || i > tp->sub_ub))
||
node_error(expp, "set element out of range");
return rem_set(set);
}
+
if (*set) (*set)[i/wrd_bits] |= (1 << (i%wrd_bits));
}
+
return 1;
}
expp->nd_type = df->df_type;
if (!(df->df_flags & (D_EXPORTED|D_QEXPORTED))) {
node_error(expp->nd_right,
-"identifier \"%s\" not exprted from qualifying module",
+"identifier \"%s\" not exported from qualifying module",
df->df_idf->id_text);
}
}
case OR:
case AND:
+ case '&':
if (tpl == bool_type) {
if (expp->nd_left->nd_class == Value &&
expp->nd_right->nd_class == Value) {
case '=':
case '#':
+ case UNEQUAL:
case GREATEREQUAL:
case LESSEQUAL:
case '<':
case '>':
+ expp->nd_type = bool_type;
switch(tpl->tp_fund) {
case T_SET:
if (expp->nd_symb == '<' || expp->nd_symb == '>') {
return 1;
case T_POINTER:
- if (!(expp->nd_symb == '=' || expp->nd_symb == '#')) {
- break;
- }
- /* Fall through */
+ if (expp->nd_symb == '=' ||
+ expp->nd_symb == UNEQUAL ||
+ expp->nd_symb == '#') return 1;
+ break;
case T_REAL:
return 1;
break;
case NOT:
+ case '~':
if (tpr == bool_type) {
if (expp->nd_right->nd_class == Value) {
cstunary(expp);
o1 = -o1;
break;
case NOT:
+ case '~':
o1 = !o1;
break;
default:
o1 = o1 == o2;
break;
case '#':
+ case UNEQUAL:
o1 = o1 != o2;
break;
case AND:
+ case '&':
o1 = o1 && o2;
break;
case OR:
case LESSEQUAL:
case '=':
case '#':
+ case UNEQUAL:
/* Clumsy, but who cares? Nobody writes these things! */
for (j = 0; j < setsize; j++) {
switch(expp->nd_symb) {
continue;
case '=':
case '#':
+ case UNEQUAL:
if (*set1++ != *set2++) break;
continue;
}
- expp->nd_INT = expp->nd_symb == '#';
+ expp->nd_INT = expp->nd_symb != '=';
break;
}
- if (j == setsize) expp->nd_INT = expp->nd_symb != '#';
+ if (j == setsize) expp->nd_INT = expp->nd_symb == '=';
expp->nd_class = Value;
free((char *) expp->nd_left->nd_set);
free((char *) expp->nd_right->nd_set);
#include <em_label.h>
#include <alloc.h>
#include <assert.h>
+
#include "idf.h"
#include "LLlex.h"
#include "def.h"
int proclevel = 0; /* nesting level of procedures */
extern char *sprint();
+extern struct def *currentdef;
}
ProcedureDeclaration
{
struct def *df;
+ struct def *savecurr = currentdef;
} :
ProcedureHeading(&df, D_PROCEDURE)
{
df->prc_level = proclevel++;
-
+ currentdef = df;
}
';' block(&(df->prc_body)) IDENT
{
match_id(dot.TOK_IDF, df->df_idf);
df->prc_scope = CurrentScope;
- close_scope(SC_CHKFORW);
+ close_scope(SC_CHKFORW|SC_REVERSE);
proclevel--;
+ currentdef = savecurr;
}
;
{
tp = construct_type(T_PROCEDURE, tp);
tp->prc_params = params;
- if (df->df_type && !TstTypeEquiv(tp, df->df_type)) {
+ if (df->df_type) {
+ /* We already saw a definition of this type
+ in the definition module.
+ */
+ if (!TstTypeEquiv(tp, df->df_type)) {
error("inconsistent procedure declaration for \"%s\"", df->df_idf->id_text);
+ }
+ FreeType(df->df_type);
}
df->df_type = tp;
*pdf = df;
}:
IDENT { df = define(dot.TOK_IDF, CurrentScope, D_TYPE); }
'=' type(&tp)
- { df->df_type = tp;
+ { if (df->df_type) free_type(df->df_type);
+ df->df_type = tp;
if ((df->df_flags&D_EXPORTED) &&
tp->tp_fund == T_ENUMERATION) {
exprt_literals(tp->enm_enums,
[
IdentList(&FldList) ':' type(&tp)
{ *palign = lcm(*palign, tp->tp_align);
- EnterIdList(FldList, D_FIELD, 0, tp, scope, cnt);
+ EnterIdList(FldList, D_FIELD, D_QEXPORTED,
+ tp, scope, cnt);
FreeNode(FldList);
}
|
df->df_type = tp;
df->fld_off = align(*cnt, tp->tp_align);
*cnt = tcnt = df->fld_off + tp->tp_size;
+ df->df_flags |= D_QEXPORTED;
}
OF variant(scope, &tcnt, tp, palign)
{ max = tcnt; tcnt = *cnt; }
struct dfproc {
struct scope *pr_scope; /* scope of procedure */
short pr_level; /* depth level of this procedure */
- char *pr_name; /* name of this procedure */
arith pr_nbpar; /* number of bytes parameters */
struct node *pr_body; /* body of this procedure */
#define prc_scope df_value.df_proc.pr_scope
#define prc_level df_value.df_proc.pr_level
#define prc_nbpar df_value.df_proc.pr_nbpar
#define prc_body df_value.df_proc.pr_body
-#define prc_name df_value.df_proc.pr_name
};
struct import {
(df = lookup(id, PervasiveScope)))
) {
switch(df->df_kind) {
- case D_PROCHEAD:
- if (kind == D_PROCEDURE) {
- /* Definition of which the heading was
- already seen in a definition module
- */
- df->df_kind = kind;
- df->prc_name = df->for_name;
- return df;
- }
- break;
case D_HIDDEN:
if (kind == D_TYPE && !DefinitionModule) {
df->df_kind = D_HTYPE;
exported from a local module!
*/
df->df_kind = df1->df_kind;
+ df->df_value.df_forward = df1->df_value.df_forward;
df1->df_kind = D_IMPORT;
}
df1->imp_def = df;
/* C_exp already generated when we saw the definition
in the definition module
*/
- df->df_kind = type;
+ df->df_kind = D_PROCEDURE;
+ open_scope(OPENSCOPE);
+ CurrentScope->sc_name = df->for_name;
+ df->prc_scope = CurrentScope;
}
else {
df = define(dot.TOK_IDF, CurrentScope, type);
}
else (sprint(buf, "%s_%s",df->df_scope->sc_name,
df->df_idf->id_text));
- df->prc_name = Malloc((unsigned)(strlen(buf)+1));
- strcpy(df->prc_name, buf);
+ open_scope(OPENSCOPE);
+ df->prc_scope = CurrentScope;
+ CurrentScope->sc_name = Malloc((unsigned)(strlen(buf)+1));
+ strcpy(CurrentScope->sc_name, buf);
C_inp(buf);
}
df->prc_nbpar = 0;
- open_scope(OPENSCOPE);
}
return df;
}
else {
assert(kind == D_FIELD);
+
df->fld_off = off;
}
}
extern char *sprint(), *Malloc(), *strcpy();
scope = CurrentScope;
+
if (local) {
/* Find the closest enclosing open scope. This
is the procedure that we are dealing with
df->var_off = IdList->nd_left->nd_INT;
}
else if (local) {
- arith off;
-
- /* add aligned size of variable to the offset
+ /* subtract aligned size of variable to the offset,
+ as the variable list exists only local to a
+ procedure
*/
- off = scope->sc_off - type->tp_size;
- off = -align(-off, type->tp_align);
- df->var_off = off;
- scope->sc_off = off;
+ scope->sc_off = -align(type->tp_size - scope->sc_off,
+ type->tp_align);
+ df->var_off = scope->sc_off;
}
else if (!DefinitionModule &&
CurrentScope != Defined->mod_scope) {
+ /* variable list belongs to an internal global
+ module. Align offset and add size
+ */
scope->sc_off = align(scope->sc_off, type->tp_align);
df->var_off = scope->sc_off;
scope->sc_off += type->tp_size;
}
else {
+ /* Global name, possibly external
+ */
sprint(buf,"%s_%s", df->df_scope->sc_name,
df->df_idf->id_text);
df->var_name = Malloc((unsigned)(strlen(buf)+1));
]*
']'
|
- '^' { *pnd = MkNode(Oper, NULLNODE, *pnd, &dot); }
+ '^' { *pnd = MkNode(Uoper, NULLNODE, *pnd, &dot); }
;
#include "scope.h"
#include "standards.h"
#include "tokenname.h"
+#include "node.h"
#include "debug.h"
{
register struct def *df;
struct def *Enter();
+ static struct node nilnode = { 0, 0, Value, 0, { INTEGER, 0, 0}};
(void) Enter("ABS", D_PROCEDURE, std_type, S_ABS);
(void) Enter("CAP", D_PROCEDURE, std_type, S_CAP);
(void) Enter("LONGREAL", D_TYPE, longreal_type, 0);
(void) Enter("BOOLEAN", D_TYPE, bool_type, 0);
(void) Enter("CARDINAL", D_TYPE, card_type, 0);
- (void) Enter("NIL", D_CONST, address_type, 0);
+ df = Enter("NIL", D_CONST, address_type, 0);
+ df->con_const = &nilnode;
+ nilnode.nd_INT = 0;
+ nilnode.nd_type = address_type;
+
(void) Enter("PROC",
D_TYPE,
construct_type(T_PROCEDURE, NULLTYPE),
implementation module currently being
compiled
*/
+struct def *currentdef; /* current definition of module or procedure */
}
/*
The grammar as given by Wirth is already almost LL(1); the
{
struct idf *id;
register struct def *df;
+ struct def *savecurr = currentdef;
extern int proclevel;
static int modulecount = 0;
char buf[256];
MODULE IDENT {
id = dot.TOK_IDF;
df = define(id, CurrentScope, D_MODULE);
+ currentdef = df;
+
if (!df->mod_scope) {
open_scope(CLOSEDSCOPE);
df->mod_scope = CurrentScope;
}
else CurrentScope = df->mod_scope;
+
df->df_type = standard_type(T_RECORD, 0, (arith) 0);
df->df_type->rec_scope = df->mod_scope;
df->mod_number = ++modulecount;
import(1)*
export(0)?
block(&(df->mod_body))
- IDENT { close_scope(SC_CHKFORW|SC_CHKPROC);
+ IDENT { close_scope(SC_CHKFORW|SC_CHKPROC|SC_REVERSE);
match_id(id, dot.TOK_IDF);
+ currentdef = savecurr;
}
;
It is restricted to pointer types.
*/
{ df->df_kind = D_HIDDEN;
+ df->df_type = construct_type(T_POINTER, NULLTYPE);
}
]
Semicolon
if (state == IMPLEMENTATION) {
DEFofIMPL = 1;
df = GetDefinitionModule(id);
+ currentdef = df;
CurrentScope = df->mod_scope;
DEFofIMPL = 0;
}
priority(&(df->mod_priority))?
';' import(0)*
block(&(df->mod_body)) IDENT
- { close_scope(SC_CHKFORW|SC_CHKPROC);
+ { close_scope(SC_CHKFORW|SC_CHKPROC|SC_REVERSE);
match_id(id, dot.TOK_IDF);
}
'.'
#include <alloc.h>
#include <em_arith.h>
#include <em_label.h>
+
#include "LLlex.h"
#include "idf.h"
#include "scope.h"
#include "type.h"
#include "def.h"
#include "node.h"
+
#include "debug.h"
struct scope *CurrentScope, *PervasiveScope, *GlobalScope;
DO_DEBUG(2, PrScopeDef(sc->sc_def));
if (flag & SC_CHKPROC) chk_proc(sc->sc_def);
if (flag & SC_CHKFORW) chk_forw(&(sc->sc_def));
- Reverse(&(sc->sc_def));
+ if (flag & SC_REVERSE) Reverse(&(sc->sc_def));
}
CurrentScope = sc->next;
scp_level = CurrentScope->sc_level;
#define SC_CHKPROC 2 /* Check for forward procedure definitions
when closing a scope
*/
+#define SC_REVERSE 4 /* Reverse list of definitions, to get it
+ back into original order
+ */
struct scope {
struct scope *next;
#include <em_arith.h>
#include <em_label.h>
+#include "idf.h"
#include "LLlex.h"
+#include "scope.h"
+#include "def.h"
#include "type.h"
#include "node.h"
static int loopcount = 0; /* Count nested loops */
+extern struct def *currentdef;
}
statement(struct node **pnd;)
|
EXIT
{ if (!loopcount) {
- error("EXIT not in a LOOP");
+error("EXIT not in a LOOP");
}
*pnd = MkNode(Stat, NULLNODE, NULLNODE, &dot);
}
RETURN { *pnd = nd = MkNode(Stat, NULLNODE, NULLNODE, &dot); }
[
expression(&(nd->nd_right))
+ { if (scopeclosed(CurrentScope)) {
+error("a module body has no result value");
+ }
+ else if (! currentdef->df_type->next) {
+error("procedure \"%s\" has no result value", currentdef->df_idf->id_text);
+ }
+ }
]?
]?
;
#include "target_sizes.h"
#include "debug.h"
+#include "maxset.h"
#include "def.h"
#include "type.h"
init_types()
{
+ /* Initialize the predefined types
+ */
register struct type *tp;
+ /* character type
+ */
char_type = standard_type(T_CHAR, 1, (arith) 1);
char_type->enm_ncst = 256;
+
+ /* character constant, different from char because of compatibility
+ with ARRAY OF CHAR
+ */
charc_type = standard_type(T_CHAR, 1, (arith) 1);
charc_type->enm_ncst = 256;
+
+ /* boolean type
+ */
bool_type = standard_type(T_ENUMERATION, 1, (arith) 1);
bool_type->enm_ncst = 2;
+
+ /* integer types, also a "intorcard", for integer constants between
+ 0 and MAX(INTEGER)
+ */
int_type = standard_type(T_INTEGER, int_align, int_size);
longint_type = standard_type(T_INTEGER, long_align, long_size);
card_type = standard_type(T_CARDINAL, int_align, int_size);
+ intorcard_type = standard_type(T_INTORCARD, int_align, int_size);
+
+ /* floating types
+ */
real_type = standard_type(T_REAL, float_align, float_size);
longreal_type = standard_type(T_REAL, double_align, double_size);
- word_type = standard_type(T_WORD, word_align, word_size);
- intorcard_type = standard_type(T_INTORCARD, int_align, int_size);
+
+ /* string constant type
+ */
string_type = standard_type(T_STRING, 1, (arith) -1);
+
+ /* SYSTEM types
+ */
+ word_type = standard_type(T_WORD, word_align, word_size);
address_type = construct_type(T_POINTER, word_type);
+
+ /* create BITSET type
+ */
tp = construct_type(T_SUBRANGE, int_type);
tp->sub_lb = 0;
tp->sub_ub = word_size * 8 - 1;
bitset_type = set_type(tp);
+
+ /* a unique type for standard procedures and functions
+ */
std_type = construct_type(T_PROCEDURE, NULLTYPE);
+
+ /* a unique type indicating an error
+ */
error_type = standard_type(T_CHAR, 1, (arith) 1);
}
return pstart;
}
-/* A subrange had a specified base. Check that the bases conform ...
-*/
chk_basesubrange(tp, base)
register struct type *tp, *base;
{
+ /* A subrange had a specified base. Check that the bases conform.
+ */
+
if (base->tp_fund == T_SUBRANGE) {
/* Check that the bounds of "tp" fall within the range
of "base"
}
base = base->next;
}
+
if (base->tp_fund == T_ENUMERATION || base->tp_fund == T_CHAR) {
if (tp->next != base) {
error("Specified base does not conform");
else if (base != tp->next && base != int_type) {
error("Specified base does not conform");
}
+
tp->next = base;
tp->tp_size = base->tp_size;
tp->tp_align = base->tp_align;
}
if (tp->tp_fund == T_SUBRANGE) tp = tp->next;
- if (tp == intorcard_type) tp = card_type; /* lower bound > 0 */
+
+ if (tp == intorcard_type) {
+ /* Lower bound >= 0; in this case, the base type is CARDINAL,
+ according to the language definition, par. 6.3
+ */
+ assert(lb->nd_INT >= 0);
+ tp = card_type;
+ }
/* Check base type
*/
- if (tp != int_type && tp != card_type && tp != char_type &&
- tp->tp_fund != T_ENUMERATION) {
- /* BOOLEAN is also an ENUMERATION type
- */
+ if (! (tp->tp_fund & T_DISCRETE)) {
node_error(ub, "Illegal base type for subrange");
return error_type;
}
res->sub_ub = ub->nd_INT;
res->tp_size = tp->tp_size;
res->tp_align = tp->tp_align;
- DO_DEBUG(2,debug("Creating subrange type %ld-%ld", (long)lb->nd_INT,(long)ub->nd_INT));
return res;
}
-#define MAX_SET 1024 /* ??? Maximum number of elements in a set */
struct type *
set_type(tp)
arith lb, ub;
if (tp->tp_fund == T_SUBRANGE) {
- if ((lb = tp->sub_lb) < 0 || (ub = tp->sub_ub) > MAX_SET - 1) {
+ if ((lb = tp->sub_lb) < 0 || (ub = tp->sub_ub) > MAXSET - 1) {
error("Set type limits exceeded");
return error_type;
}
}
else if (tp->tp_fund == T_ENUMERATION || tp == char_type) {
lb = 0;
- if ((ub = tp->enm_ncst - 1) > MAX_SET - 1) {
+ if ((ub = tp->enm_ncst - 1) > MAXSET - 1) {
error("Set type limits exceeded");
return error_type;
}
error("illegal base type for set");
return error_type;
}
+
tp = construct_type(T_SET, tp);
tp->tp_size = align(((ub - lb) + 7)/8, word_align);
return tp;
ArraySizes(tp)
register struct type *tp;
{
- /* Assign sizes to an array type
+ /* Assign sizes to an array type, and check index type
*/
arith elem_size;
- register struct type *itype = tp->next; /* the index type */
+ register struct type *index_type = tp->next;
+ register struct type *elem_type = tp->arr_elem;
- if (tp->arr_elem->tp_fund == T_ARRAY) {
- ArraySizes(tp->arr_elem);
+ if (elem_type->tp_fund == T_ARRAY) {
+ ArraySizes(elem_type);
}
- elem_size = align(tp->arr_elem->tp_size, tp->arr_elem->tp_align);
- tp->tp_align = tp->arr_elem->tp_align;
+ /* align element size to alignment requirement of element type
+ */
+ elem_size = align(elem_type->tp_size, elem_type->tp_align);
+ tp->tp_align = elem_type->tp_align;
- if (! (itype->tp_fund & T_INDEX)) {
+ /* check index type
+ */
+ if (! (index_type->tp_fund & T_INDEX)) {
error("Illegal index type");
tp->tp_size = 0;
return;
}
- switch(itype->tp_fund) {
+ /* find out HIGH, LOW and size of ARRAY
+ */
+ switch(index_type->tp_fund) {
case T_SUBRANGE:
- tp->arr_lb = itype->sub_lb;
- tp->arr_ub = itype->sub_ub;
- tp->tp_size = elem_size * (itype->sub_ub - itype->sub_lb + 1);
+ tp->arr_lb = index_type->sub_lb;
+ tp->arr_ub = index_type->sub_ub;
+ tp->tp_size = elem_size *
+ (index_type->sub_ub - index_type->sub_lb + 1);
break;
case T_CHAR:
case T_ENUMERATION:
tp->arr_lb = 0;
- tp->arr_ub = itype->enm_ncst - 1;
- tp->tp_size = elem_size * itype->enm_ncst;
+ tp->arr_ub = index_type->enm_ncst - 1;
+ tp->tp_size = elem_size * index_type->enm_ncst;
break;
default:
assert(0);
}
- /* ??? overflow checking ??? */
+ /* ??? overflow checking ???
+ */
+}
+
+FreeType(tp)
+ struct type *tp;
+{
+ /* Release type structures indicated by "tp"
+ */
+ register struct paramlist *pr, *pr1;
+
+ assert(tp->tp_fund == T_PROCEDURE);
+
+ pr = tp->prc_params;
+ while (pr) {
+ pr1 = pr;
+ pr = pr->next;
+ free_paramlist(pr1);
+ }
+
+ free_type(tp);
}
int
int
TstTypeEquiv(tp1, tp2)
- register struct type *tp1, *tp2;
+ struct type *tp1, *tp2;
{
- /* test if two types are equivalent. A complication comes
- from the fact that for some procedures two declarations may
- be given: one in the specification module and one in the
- definition module.
- A related problem is that two dynamic arrays with
- equivalent base types are also equivalent.
+ /* test if two types are equivalent.
*/
return tp1 == tp2
||
tp1 == error_type
||
- tp2 == error_type
+ tp2 == error_type;
+}
+
+int
+TstParEquiv(tp1, tp2)
+ register struct type *tp1, *tp2;
+{
+ /* test if two parameter types are equivalent. This routine
+ is used to check if two different procedure declarations
+ (one in the definition module, one in the implementation
+ module) are equivalent. A complication comes from dynamic
+ arrays.
+ */
+
+ return
+ TstTypeEquiv(tp1, tp2)
||
(
tp1->tp_fund == T_ARRAY
tp2->next == 0
&&
TstTypeEquiv(tp1->arr_elem, tp2->arr_elem)
- )
- ||
- (
- tp1 && tp1->tp_fund == T_PROCEDURE
- &&
- tp2 && tp2->tp_fund == T_PROCEDURE
- &&
- TstProcEquiv(tp1, tp2)
);
-
}
int
register struct paramlist *p1, *p2;
if (!TstTypeEquiv(tp1->next, tp2->next)) return 0;
+
p1 = tp1->prc_params;
p2 = tp2->prc_params;
+
while (p1 && p2) {
if (p1->par_var != p2->par_var ||
- !TstTypeEquiv(p1->par_type, p2->par_type)) return 0;
+ !TstParEquiv(p1->par_type, p2->par_type)) return 0;
p1 = p1->next;
p2 = p2->next;
}
+
return p1 == p2;
}
/* test if two types are compatible. See section 6.3 of the
Modula-2 Report for a definition of "compatible".
*/
+
if (TstTypeEquiv(tp1, tp2)) return 1;
+
if (tp1->tp_fund == T_SUBRANGE) tp1 = tp1->next;
if (tp2->tp_fund == T_SUBRANGE) tp2 = tp2->next;
+
return tp1 == tp2
||
( tp1 == intorcard_type
{
/* Test if two types are assignment compatible.
*/
+
if (TstCompat(tp1, tp2)) return 1;
if (tp1->tp_fund == T_SUBRANGE) tp1 = tp1->next;
if (tp2->tp_fund == T_SUBRANGE) tp2 = tp2->next;
- if ((tp1->tp_fund & (T_INTEGER|T_CARDINAL)) &&
- (tp2->tp_fund & (T_INTEGER|T_CARDINAL))) return 1;
+
+ if ((tp1->tp_fund & T_INTORCARD) &&
+ (tp2->tp_fund & T_INTORCARD)) return 1;
+
if (tp1 == char_type && tp2 == charc_type) return 1;
if (tp1->tp_fund == T_ARRAY &&
(tp2 == charc_type || tp2 == string_type)) {
if (tp1->tp_fund == T_SUBRANGE) tp1 = tp1->next;
return tp1 == char_type;
}
+
return 0;
}
#include "main.h"
#include "LLlex.h"
#include "node.h"
+#include "Lpars.h"
#include "debug.h"
extern arith align();
static int prclev = 0;
+static label instructionlabel = 0;
+static label datalabel = 0;
WalkModule(module)
register struct def *module;
scope = CurrentScope;
CurrentScope = module->mod_scope;
+
if (!prclev && module->mod_number) {
/* This module is a local module, but not within a
procedure. Generate code to allocate storage for its
- variables
+ variables. This is done by generating a "bss",
+ with label "_<modulenumber><modulename>".
*/
arith size = align(CurrentScope->sc_off, word_size);
CurrentScope->sc_off = 0;
C_pro_narg(CurrentScope->sc_name);
MkCalls(CurrentScope->sc_def);
- WalkNode(module->mod_body);
+ WalkNode(module->mod_body, (label) 0);
C_end(align(-CurrentScope->sc_off, word_size));
CurrentScope = scope;
/* Generate code for this procedure
*/
- C_pro_narg(procedure->prc_name);
+ C_pro_narg(CurrentScope->sc_name);
/* generate calls to initialization routines of modules defined within
this procedure
*/
+ instructionlabel = 1;
MkCalls(CurrentScope->sc_def);
- WalkNode(procedure->prc_body);
+ WalkNode(procedure->prc_body, (label) 0);
C_end(align(-CurrentScope->sc_off, word_size));
CurrentScope = scope;
prclev--;
while (df) {
if (df->df_kind == D_MODULE) {
C_lxl((arith) 0);
- C_cal(df->df_scope->sc_name);
+ C_cal(df->mod_scope->sc_name);
}
df = df->df_nextinscope;
}
}
-WalkNode(nd)
- struct node *nd;
+WalkNode(nd, lab)
+ register struct node *nd;
+ label lab;
{
/* Node "nd" represents either a statement or a statement list.
- Generate code for it.
+ Walk through it.
+ "lab" represents the label that must be jumped to on
+ encountering an EXIT statement.
+ */
+
+ while (nd->nd_class == Link) { /* statement list */
+ WalkStat(nd->nd_left, lab);
+ nd = nd->nd_right;
+ }
+
+ WalkStat(nd, lab);
+}
+
+WalkStat(nd, lab)
+ register struct node *nd;
+ label lab;
+{
+ /* Walk through a statement, generating code for it.
+ "lab" represents the label that must be jumped to on
+ encountering an EXIT statement.
+ */
+ register struct node *left = nd->nd_left;
+ register struct node *right = nd->nd_right;
+
+ if (nd->nd_class == Call) {
+ /* ??? */
+ return;
+ }
+
+ assert(nd->nd_class == Stat);
+
+ switch(nd->nd_symb) {
+ case BECOMES:
+ /* ??? */
+ break;
+
+ case IF:
+ { label l1, l2;
+
+ l1 = instructionlabel++;
+ l2 = instructionlabel++;
+ ExpectBool(left);
+ assert(right->nd_symb == THEN);
+ C_zeq(l1);
+ WalkNode(right->nd_left, lab);
+
+ if (right->nd_right) { /* ELSE part */
+ C_bra(l2);
+ C_df_ilb(l1);
+ WalkNode(right->nd_right, lab);
+ C_df_ilb(l2);
+ }
+ else C_df_ilb(l1);
+ break;
+ }
+
+ case CASE:
+ /* ??? */
+ break;
+
+ case WHILE:
+ { label l1, l2;
+
+ l1 = instructionlabel++;
+ l2 = instructionlabel++;
+ C_df_ilb(l1);
+ ExpectBool(left);
+ C_zeq(l2);
+ WalkNode(right, lab);
+ C_bra(l1);
+ C_df_ilb(l2);
+ break;
+ }
+
+ case REPEAT:
+ { label l1;
+
+ l1 = instructionlabel++;
+ C_df_ilb(l1);
+ WalkNode(left, lab);
+ ExpectBool(right);
+ C_zeq(l1);
+ break;
+ }
+
+ case LOOP:
+ { label l1, l2;
+
+ l1 = instructionlabel++;
+ l2 = instructionlabel++;
+ C_df_ilb(l1);
+ WalkNode(left, l2);
+ C_bra(l1);
+ C_df_ilb(l2);
+ break;
+ }
+
+ case FOR:
+ /* ??? */
+ break;
+
+ case WITH:
+ /* ??? */
+ break;
+
+ case EXIT:
+ assert(lab != 0);
+
+ C_bra(lab);
+ break;
+
+ case RETURN:
+ /* ??? */
+ break;
+
+ default:
+ assert(0);
+ }
+}
+
+ExpectBool(nd)
+ struct node *nd;
+{
+ /* "nd" must indicate a boolean expression. Check this and
+ generate code to evaluate the expression.
+ */
+
+ chk_expr(nd);
+
+ if (nd->nd_type != bool_type) {
+ node_error(nd, "boolean expression expected");
+ }
+
+ /* generate code
*/
/* ??? */
}
public / ack.git / commitdiff