d0p1/ack
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

newer version

Browse source
This commit is contained in:
ceriel 1986-04-11 11:57:19 +00:00
parent ba47f9fe7c
commit 64a9f1e5d7
12 changed files with 379 additions and 107 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
lang/m2/comp/Makefile
View file

@ -82,16 +82,16 @@ symbol2str.o: Lpars.h
tokenname.o: Lpars.h idf.h tokenname.h
idf.o: idf.h
input.o: f_info.h input.h
type.o: LLlex.h Lpars.h const.h debug.h def.h def_sizes.h idf.h node.h type.h
def.o: LLlex.h Lpars.h debug.h def.h idf.h main.h node.h scope.h type.h
type.o: LLlex.h const.h debug.h def.h def_sizes.h idf.h node.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
enter.o: LLlex.h def.h idf.h node.h scope.h type.h
defmodule.o: LLlex.h debug.h def.h f_info.h idf.h input.h scope.h
typequiv.o: Lpars.h def.h type.h
typequiv.o: def.h type.h
node.o: LLlex.h debug.h def.h node.h type.h
cstoper.o: LLlex.h Lpars.h def_sizes.h idf.h node.h type.h
chk_expr.o: LLlex.h Lpars.h const.h def.h idf.h node.h scope.h standards.h type.h
cstoper.o: LLlex.h Lpars.h def_sizes.h idf.h node.h standards.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
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 misc.h node.h scope.h type.h

159
lang/m2/comp/chk_expr.c
View file

@ -17,6 +17,7 @@ static char *RcsId = "$Header$";
#include "scope.h"
#include "const.h"
#include "standards.h"
#include "debug.h"
int
chk_expr(expp)
@ -199,7 +200,7 @@ getarg(argp, bases)
struct type *tp;
if (!argp->nd_right) {
node_error(argp, "Too few arguments supplied");
node_error(argp, "too few arguments supplied");
return 0;
}
argp = argp->nd_right;
@ -218,7 +219,7 @@ getname(argp, kinds)
struct node *argp;
{
if (!argp->nd_right) {
node_error(argp, "Too few arguments supplied");
node_error(argp, "too few arguments supplied");
return 0;
}
argp = argp->nd_right;
@ -235,67 +236,84 @@ int
chk_call(expp)
register struct node *expp;
{
register struct type *tp;
/* Check something that looks like a procedure or function call.
Of course this does not have to be a call at all.
it may also be a cast or a standard procedure call.
*/
register struct node *left;
register struct node *arg;
expp->nd_type = error_type;
(void) findname(expp->nd_left);
(void) findname(expp->nd_left); /* parser made sure it is a name */
left = expp->nd_left;
tp = left->nd_type;
if (tp == error_type) return 0;
if (left->nd_type == error_type) return 0;
if (left->nd_class == Def &&
(left->nd_def->df_kind & (D_HTYPE|D_TYPE|D_HIDDEN))) {
/* A type cast. This is of course not portable.
No runtime action. Remove it.
*/
arg = expp->nd_right;
if (!arg || arg->nd_right) {
if ((! arg) || arg->nd_right) {
node_error(expp, "Only one parameter expected in type cast");
return 0;
}
if (! chk_expr(arg->nd_left)) return 0;
if (arg->nd_left->nd_type->tp_size !=
left->nd_type->tp_size) {
arg = arg->nd_left;
if (! chk_expr(arg)) return 0;
if (arg->nd_type->tp_size != left->nd_type->tp_size) {
node_error(expp, "Size of type in type cast does not match size of operand");
return 0;
}
arg->nd_left->nd_type = left->nd_type;
arg->nd_type = left->nd_type;
FreeNode(expp->nd_left);
*expp = *(arg->nd_left);
arg->nd_left->nd_left = 0;
arg->nd_left->nd_right = 0;
arg->nd_left = 0;
arg->nd_right = 0;
FreeNode(arg);
return 1;
}
if ((left->nd_class == Def && left->nd_def->df_kind == D_PROCEDURE) ||
tp->tp_fund == T_PROCEDURE) {
left->nd_type->tp_fund == T_PROCEDURE) {
/* A procedure call. it may also be a call to a
standard procedure
*/
arg = expp;
if (tp == std_type) {
if (left->nd_type == std_type) {
/* A standard procedure
*/
assert(left->nd_class == Def);
DO_DEBUG(3, debug("Standard name \"%s\", %d",
left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname));
switch(left->nd_def->df_value.df_stdname) {
case S_ABS:
arg = getarg(arg, T_INTEGER|T_CARDINAL|T_REAL);
arg = getarg(arg, T_NUMERIC);
if (! arg) return 0;
expp->nd_type = arg->nd_left->nd_type;
left = arg->nd_left;
expp->nd_type = left->nd_type;
if (left->nd_class == Value) {
cstcall(expp, S_ABS);
}
break;
case S_CAP:
arg = getarg(arg, T_CHAR);
expp->nd_type = char_type;
if (!arg) return 0;
left = arg->nd_left;
if (left->nd_class == Value) {
cstcall(expp, S_CAP);
}
break;
case S_CHR:
arg = getarg(arg, T_INTEGER|T_CARDINAL);
arg = getarg(arg, T_INTORCARD);
expp->nd_type = char_type;
if (!arg) return 0;
if (arg->nd_left->nd_class == Value) {
cstcall(expp, S_CHR);
}
break;
case S_FLOAT:
arg = getarg(arg, T_CARDINAL|T_INTEGER);
arg = getarg(arg, T_INTORCARD);
expp->nd_type = real_type;
if (!arg) return 0;
break;
@ -303,50 +321,71 @@ node_error(expp, "Size of type in type cast does not match size of operand");
arg = getarg(arg, T_ARRAY);
if (!arg) return 0;
expp->nd_type = arg->nd_left->nd_type->next;
if (!expp->nd_type) expp->nd_type = int_type;
if (!expp->nd_type) {
/* A dynamic array has no explicit
index type
*/
expp->nd_type = int_type;
}
else cstcall(expp, S_MAX);
break;
case S_MAX:
case S_MIN:
arg = getarg(arg, T_ENUMERATION|T_CHAR|T_INTEGER|T_CARDINAL);
arg = getarg(arg, T_DISCRETE);
if (!arg) return 0;
expp->nd_type = arg->nd_left->nd_type;
cstcall(expp,left->nd_def->df_value.df_stdname);
break;
case S_ODD:
arg = getarg(arg, T_INTEGER|T_CARDINAL);
arg = getarg(arg, T_INTORCARD);
if (!arg) return 0;
expp->nd_type = bool_type;
if (arg->nd_left->nd_class == Value) {
cstcall(expp, S_ODD);
}
break;
case S_ORD:
arg = getarg(arg, T_ENUMERATION|T_CHAR|T_INTEGER|T_CARDINAL);
arg = getarg(arg, T_DISCRETE);
if (!arg) return 0;
expp->nd_type = card_type;
if (arg->nd_left->nd_class == Value) {
cstcall(expp, S_ORD);
}
break;
case S_TSIZE: /* ??? */
case S_SIZE:
arg = getname(arg, D_FIELD|D_VARIABLE|D_TYPE|D_HIDDEN|D_HTYPE);
expp->nd_type = intorcard_type;
if (!arg) return 0;
cstcall(expp, S_SIZE);
break;
case S_TRUNC:
arg = getarg(arg, T_REAL);
if (!arg) return 0;
expp->nd_type = card_type;
break;
case S_VAL:
case S_VAL: {
struct type *tp;
arg = getname(arg, D_HIDDEN|D_HTYPE|D_TYPE);
if (!arg) return 0;
tp = arg->nd_left->nd_def->df_type;
if (tp->tp_fund == T_SUBRANGE) tp = tp->next;
if (!(tp->tp_fund & (T_ENUMERATION|T_CHAR|T_INTEGER|T_CARDINAL))) {
if (!(tp->tp_fund & T_DISCRETE)) {
node_error(arg, "unexpected type");
return 0;
}
expp->nd_type = arg->nd_left->nd_def->df_type;
FreeNode(arg->nd_left);
arg->nd_left = 0;
arg = getarg(arg, T_INTEGER|T_CARDINAL);
expp->nd_right = arg->nd_right;
arg->nd_right = 0;
FreeNode(arg);
arg = getarg(expp, T_INTORCARD);
if (!arg) return 0;
if (arg->nd_left->nd_class == Value) {
cstcall(expp, S_VAL);
}
break;
}
case S_ADR:
arg = getname(arg, D_VARIABLE|D_FIELD|D_PROCEDURE);
expp->nd_type = address_type;
@ -358,7 +397,7 @@ node_error(expp, "Size of type in type cast does not match size of operand");
arg = getname(arg, D_VARIABLE|D_FIELD);
if (!arg) return 0;
if (arg->nd_right) {
arg = getarg(arg, T_INTEGER|T_CARDINAL);
arg = getarg(arg, T_INTORCARD);
if (!arg) return 0;
}
break;
@ -366,7 +405,9 @@ node_error(expp, "Size of type in type cast does not match size of operand");
expp->nd_type = 0;
break;
case S_EXCL:
case S_INCL:
case S_INCL: {
struct type *tp;
expp->nd_type = 0;
arg = getname(arg, D_VARIABLE|D_FIELD);
if (!arg) return 0;
@ -375,25 +416,26 @@ node_error(expp, "Size of type in type cast does not match size of operand");
node_error(arg, "EXCL and INCL expect a SET parameter");
return 0;
}
arg = getarg(arg, T_INTEGER|T_CARDINAL|T_CHAR|T_ENUMERATION);
arg = getarg(arg, T_DISCRETE);
if (!arg) return 0;
if (!TstCompat(tp->next, arg->nd_left->nd_type)) {
node_error(arg, "Unexpected type");
return 0;
}
break;
}
default:
assert(0);
}
if (arg->nd_right) {
node_error(arg->nd_right,
"Too many parameters supplied");
"too many parameters supplied");
return 0;
}
FreeNode(expp->nd_left);
expp->nd_left = 0;
return 1;
}
/* Here, we have found a real procedure call
*/
return 1;
}
node_error(expp->nd_left, "procedure, type, or function expected");
@ -527,17 +569,22 @@ node_error(expp, "RHS of IN operator not a SET type");
node_error(expp, "IN operator: type of LHS not compatible with element type of RHS");
return 0;
}
if (expp->nd_left->nd_class == Value &&
expp->nd_right->nd_class == Set) {
cstset(expp);
}
return 1;
}
if (expp->nd_symb == '[') {
/* Handle ARRAY selection specially too! */
if (tpl->tp_fund != T_ARRAY) {
node_error(expp, "array index not belonging to an ARRAY");
node_error(expp,
"array index not belonging to an ARRAY");
return 0;
}
if (!TstCompat(tpl->next, tpr)) {
node_error(expp, "incompatible index type");
node_error(expp, "incompatible index type");
return 0;
}
expp->nd_type = tpl->arr_elem;
@ -548,7 +595,9 @@ node_error(expp, "incompatible index type");
expp->nd_type = tpl;
if (!TstCompat(tpl, tpr)) {
node_error(expp, "Incompatible types for operator \"%s\"", symbol2str(expp->nd_symb));
node_error(expp,
"Incompatible types for operator \"%s\"",
symbol2str(expp->nd_symb));
return 0;
}
@ -559,12 +608,18 @@ node_error(expp, "Incompatible types for operator \"%s\"", symbol2str(expp->nd_s
switch(tpl->tp_fund) {
case T_INTEGER:
case T_CARDINAL:
case T_SET:
case T_INTORCARD:
if (expp->nd_left->nd_class == Value &&
expp->nd_right->nd_class == Value) {
cstbin(expp);
}
return 1;
case T_SET:
if (expp->nd_left->nd_class == Set &&
expp->nd_right->nd_class == Set) {
cstset(expp);
}
/* Fall through */
case T_REAL:
return 1;
}
@ -572,20 +627,18 @@ node_error(expp, "Incompatible types for operator \"%s\"", symbol2str(expp->nd_s
case '/':
switch(tpl->tp_fund) {
case T_SET:
if (expp->nd_left->nd_class == Value &&
expp->nd_right->nd_class == Value) {
cstbin(expp);
if (expp->nd_left->nd_class == Set &&
expp->nd_right->nd_class == Set) {
cstset(expp);
}
return 1;
/* Fall through */
case T_REAL:
return 1;
}
break;
case DIV:
case MOD:
switch(tpl->tp_fund) {
case T_INTEGER:
case T_CARDINAL:
if (tpl->tp_fund & T_INTORCARD) {
if (expp->nd_left->nd_class == Value &&
expp->nd_right->nd_class == Value) {
cstbin(expp);
@ -617,13 +670,14 @@ node_error(expp, "Incompatible types for operator \"%s\"", symbol2str(expp->nd_s
}
if (expp->nd_left->nd_class == Set &&
expp->nd_right->nd_class == Set) {
cstbin(expp);
cstset(expp);
}
return 1;
case T_INTEGER:
case T_CARDINAL:
case T_ENUMERATION: /* includes boolean */
case T_CHAR:
case T_INTORCARD:
if (expp->nd_left->nd_class == Value &&
expp->nd_right->nd_class == Value) {
cstbin(expp);
@ -666,10 +720,7 @@ chk_uoper(expp)
switch(expp->nd_symb) {
case '+':
switch(tpr->tp_fund) {
case T_INTEGER:
case T_REAL:
case T_CARDINAL:
if (tpr->tp_fund & T_NUMERIC) {
expp->nd_token = expp->nd_right->nd_token;
FreeNode(expp->nd_right);
expp->nd_right = 0;
@ -677,13 +728,13 @@ chk_uoper(expp)
}
break;
case '-':
switch(tpr->tp_fund) {
case T_INTEGER:
if (tpr->tp_fund & T_INTORCARD) {
if (expp->nd_right->nd_class == Value) {
cstunary(expp);
}
return 1;
case T_REAL:
}
else if (tpr->tp_fund == T_REAL) {
if (expp->nd_right->nd_class == Value) {
expp->nd_token = expp->nd_right->nd_token;
if (*(expp->nd_REL) == '-') {
@ -711,7 +762,7 @@ chk_uoper(expp)
default:
assert(0);
}
node_error(expp, "Illegal operand for unary operator \"%s\"",
node_error(expp, "illegal operand for unary operator \"%s\"",
symbol2str(expp->nd_symb));
return 0;
}

1
lang/m2/comp/const.h
View file

@ -9,4 +9,5 @@ extern int
extern arith
max_int, /* maximum integer on target machine */
max_unsigned, /* maximum unsigned on target machine */
max_longint, /* maximum longint on target machine */
wrd_bits; /* Number of bits in a word */

118
lang/m2/comp/cstoper.c
View file

@ -11,6 +11,7 @@ static char *RcsId = "$Header$";
#include "LLlex.h"
#include "node.h"
#include "Lpars.h"
#include "standards.h"
long mach_long_sign; /* sign bit of the machine long */
int mach_long_size; /* size of long on this machine == sizeof(long) */
@ -60,10 +61,7 @@ cstbin(expp)
int uns = expp->nd_type != int_type;
assert(expp->nd_class == Oper);
if (expp->nd_right->nd_type->tp_fund == T_SET) {
cstset(expp);
return;
}
assert(expp->nd_left->nd_class == Value && expp->nd_right->nd_class == Value);
switch (expp->nd_symb) {
case '*':
o1 *= o2;
@ -288,6 +286,108 @@ cstset(expp)
expp->nd_left = expp->nd_right = 0;
}
cstcall(expp, call)
register struct node *expp;
{
/* a standard procedure call is found that can be evaluated
compile time, so do so.
*/
register struct node *expr = 0;
assert(expp->nd_class == Call);
if (expp->nd_right) {
expr = expp->nd_right->nd_left;
expp->nd_right->nd_left = 0;
FreeNode(expp->nd_right);
}
expp->nd_class = Value;
switch(call) {
case S_ABS:
if (expr->nd_type->tp_fund == T_REAL) {
expp->nd_symb = REAL;
expp->nd_REL = expr->nd_REL;
if (*(expr->nd_REL) == '-') (expp->nd_REL)++;
break;
}
if (expr->nd_INT < 0) expp->nd_INT = - expr->nd_INT;
else expp->nd_INT = expr->nd_INT;
cut_size(expp);
break;
case S_CAP:
if (expr->nd_INT >= 'a' && expr->nd_INT <= 'z') {
expp->nd_INT = expr->nd_INT + ('A' - 'a');
}
else expp->nd_INT = expr->nd_INT;
cut_size(expp);
break;
case S_CHR:
expp->nd_INT = expr->nd_INT;
cut_size(expp);
break;
case S_MAX:
if (expp->nd_type == int_type) {
expp->nd_INT = max_int;
}
else if (expp->nd_type == longint_type) {
expp->nd_INT = max_longint;
}
else if (expp->nd_type == card_type) {
expp->nd_INT = max_unsigned;
}
else if (expp->nd_type->tp_fund == T_SUBRANGE) {
expp->nd_INT = expp->nd_type->sub_ub;
}
else expp->nd_INT = expp->nd_type->enm_ncst - 1;
break;
case S_MIN:
if (expp->nd_type == int_type) {
expp->nd_INT = (-max_int) - 1;
}
else if (expp->nd_type == longint_type) {
expp->nd_INT = (-max_longint) - 1;
}
else if (expp->nd_type->tp_fund == T_SUBRANGE) {
expp->nd_INT = expp->nd_type->sub_lb;
}
else expp->nd_INT = 0;
break;
case S_ODD:
expp->nd_INT = (expr->nd_INT & 1);
break;
case S_ORD:
expp->nd_INT = expr->nd_INT;
cut_size(expp);
break;
case S_SIZE:
expp->nd_INT = align(expr->nd_type->tp_size, wrd_size)/wrd_size;
break;
case S_VAL:
expp->nd_INT = expr->nd_INT;
if ( /* Check overflow of subranges or enumerations */
( expp->nd_type->tp_fund == T_SUBRANGE
&&
( expp->nd_INT < expp->nd_type->sub_lb
|| expp->nd_INT > expp->nd_type->sub_ub
)
)
||
( expp->nd_type->tp_fund == T_ENUMERATION
&&
( expp->nd_INT < 0
|| expp->nd_INT >= expp->nd_type->enm_ncst
)
)
) node_warning(expp,"overflow in constant expression");
else cut_size(expp);
break;
default:
assert(0);
}
FreeNode(expr);
FreeNode(expp->nd_left);
expp->nd_right = expp->nd_left = 0;
}
cut_size(expr)
register struct node *expr;
{
@ -295,10 +395,13 @@ cut_size(expr)
conform to the size of the type of the expression.
*/
arith o1 = expr->nd_INT;
int uns = expr->nd_type == card_type || expr->nd_type == intorcard_type;
int size = expr->nd_type->tp_size;
struct type *tp = expr->nd_type;
int uns;
int size = tp->tp_size;
assert(expr->nd_class == Value);
if (tp->tp_fund == T_SUBRANGE) tp = tp->next;
uns = (tp->tp_fund & (T_CARDINAL|T_CHAR));
if (uns) {
if (o1 & ~full_mask[size]) {
node_warning(expr,
@ -332,11 +435,12 @@ init_cst()
}
mach_long_size = i;
mach_long_sign = 1 << (mach_long_size * 8 - 1);
if (int_size > mach_long_size) {
if (lint_size > mach_long_size) {
fatal("sizeof (long) insufficient on this machine");
}
max_int = full_mask[int_size] & ~(1 << (int_size * 8 - 1));
max_unsigned = full_mask[int_size];
max_longint = full_mask[lint_size] & ~(1 << (lint_size * 8 - 1));
wrd_bits = 8 * wrd_size;
}

63
lang/m2/comp/declar.g
View file

@ -30,7 +30,7 @@ ProcedureDeclaration
ProcedureHeading(struct def **pdf; int type;)
{
struct type *tp;
struct type *tp = 0;
struct type *tp1 = 0;
struct paramlist *params = 0;
register struct def *df;
@ -97,7 +97,7 @@ FormalParameters(int doparams; struct paramlist **pr; struct type **tp;)
]?
')'
{ *tp = 0; }
[ ':' qualident(D_TYPE | D_HTYPE, &df, "type", (struct node **) 0)
[ ':' qualident(D_TYPE|D_HTYPE|D_HIDDEN, &df, "type", (struct node **) 0)
{ *tp = df->df_type; }
]?
;
@ -135,7 +135,7 @@ FormalType(struct type **tp;)
} :
[ ARRAY OF { ARRAYflag = 1; }
]?
qualident(D_TYPE | D_HTYPE, &df, "type", (struct node **) 0)
qualident(D_TYPE|D_HTYPE|D_HIDDEN, &df, "type", (struct node **) 0)
{ if (ARRAYflag) {
*tp = construct_type(T_ARRAY, NULLTYPE);
(*tp)->arr_elem = df->df_type;
@ -183,7 +183,7 @@ SimpleType(struct type **ptp;)
{
struct def *df;
} :
qualident(D_TYPE | D_HTYPE, &df, "type", (struct node **) 0)
qualident(D_TYPE|D_HTYPE|D_HIDDEN, &df, "type", (struct node **) 0)
[
/* nothing */
{ *ptp = df->df_type; }
@ -293,6 +293,7 @@ FieldList(struct scope *scope;)
struct idf *id;
struct def *df, *df1;
struct type *tp;
struct node *nd;
} :
[
IdentList(&FldList) ':' type(&tp)
@ -301,13 +302,51 @@ FieldList(struct scope *scope;)
}
|
CASE
[
IDENT { id = dot.TOK_IDF; }
/* Also accept old fashioned Modula-2 syntax, but give a warning
*/
[ qualident(0, &df, (char *) 0, &nd)
[ /* This is good, in both kinds of Modula-2, if
the first qualident is a single identifier.
*/
{
if (nd->nd_class != Name) {
error("illegal variant tag");
id = gen_anon_idf();
}
else id = nd->nd_IDF;
}
':' qualident(D_TYPE|D_HTYPE|D_HIDDEN,
&df, "type", (struct node **) 0)
|
/* Old fashioned! the first qualident now represents
the type
*/
{
warning("Old fashioned Modula-2 syntax!");
id = gen_anon_idf();
findname(nd);
assert(nd->nd_class == Def);
df = nd->nd_def;
if (!(df->df_kind &
(D_ERROR|D_TYPE|D_HTYPE|D_HIDDEN))) {
error("identifier \"%s\" is not a type",
df->df_idf->id_text);
}
FreeNode(nd);
}
]
|
{ id = gen_anon_idf(); }
] /* Changed rule in new modula-2 */
':' qualident(D_TYPE|D_HTYPE, &df, "type", (struct node **) 0)
{ df1 = define(id, scope, D_FIELD);
/* Aha, third edition? */
':' qualident(D_TYPE|D_HTYPE|D_HIDDEN,
&df,
"type",
(struct node **) 0)
{
id = gen_anon_idf();
}
]
{
df1 = define(id, scope, D_FIELD);
df1->df_type = df->df_type;
}
OF variant(scope)
@ -362,7 +401,7 @@ PointerType(struct type **ptp;)
/* Either a Module or a Type, but in both cases defined
in this scope, so this is the correct identification
*/
qualident(D_TYPE|D_HTYPE, &df, "type", (struct node **) 0)
qualident(D_TYPE|D_HTYPE|D_HIDDEN, &df, "type", (struct node **) 0)
{
if (!df->df_type) {
error("type \"%s\" not declared",
@ -428,7 +467,7 @@ FormalTypeList(struct paramlist **ppr; struct type **ptp;)
{ p->next = 0; }
]?
')'
[ ':' qualident(D_TYPE|D_HTYPE, &df, "type", (struct node **) 0)
[ ':' qualident(D_TYPE|D_HTYPE|D_HIDDEN, &df, "type", (struct node **) 0)
{ *ptp = df->df_type; }
]?
;

16
lang/m2/comp/def.H
View file

@ -43,8 +43,12 @@ struct dfproc {
};
struct import {
struct def *im_def; /* imported definition */
#define imp_def df_value.df_import.im_def
union {
struct def *im_def; /* imported definition */
struct node *im_nodef; /* imported from undefined name */
} im_u;
#define imp_def df_value.df_import.im_u.im_def
#define imp_nodef df_value.df_import.im_u.im_nodef
};
struct def { /* list of definitions for a name */
@ -65,12 +69,12 @@ struct def { /* list of definitions for a name */
#define D_PROCHEAD 0x0100 /* a procedure heading in a definition module */
#define D_HIDDEN 0x0200 /* a hidden type */
#define D_HTYPE 0x0400 /* definition of a hidden type seen */
#define D_STDPROC 0x0800 /* a standard procedure */
#define D_STDFUNC 0x1000 /* a standard function */
#define D_ERROR 0x2000 /* a compiler generated definition for an
#define D_FORWARD 0x0800 /* not yet defined */
#define D_UNDEF_IMPORT 0x1000 /* imported from an undefined name */
#define D_FORWMODULE 0x2000 /* module must be declared later */
#define D_ERROR 0x4000 /* a compiler generated definition for an
undefined variable
*/
#define D_ISEXPORTED 0x4000 /* not yet defined */
char df_flags;
#define D_ADDRESS 0x01 /* set if address was taken */
#define D_USED 0x02 /* set if used */

83
lang/m2/comp/def.c
View file

@ -7,7 +7,6 @@ static char *RcsId = "$Header$";
#include <em_label.h>
#include <assert.h>
#include "main.h"
#include "Lpars.h"
#include "def.h"
#include "type.h"
#include "idf.h"
@ -33,7 +32,8 @@ define(id, scope, kind)
*/
register struct def *df;
DO_DEBUG(5, debug("Defining identifier \"%s\" in scope %d", id->id_text, scope->sc_scope));
DO_DEBUG(5, debug("Defining identifier \"%s\" in scope %d, kind = %d",
id->id_text, scope->sc_scope, kind));
df = lookup(id, scope->sc_scope);
if ( /* Already in this scope */
df
@ -47,7 +47,10 @@ define(id, scope, kind)
switch(df->df_kind) {
case D_PROCHEAD:
if (kind == D_PROCEDURE) {
df->df_kind = D_PROCEDURE;
/* Definition of which the heading was
already seen in a definition module
*/
df->df_kind = kind;
return df;
}
break;
@ -57,8 +60,14 @@ define(id, scope, kind)
return df;
}
break;
case D_FORWMODULE:
if (kind & (D_FORWMODULE|D_MODULE)) {
df->df_kind = kind;
return df;
}
break;
case D_ERROR:
case D_ISEXPORTED:
case D_FORWARD:
df->df_kind = kind;
return df;
}
@ -72,6 +81,7 @@ error("identifier \"%s\" already declared", id->id_text);
df->df_scope = scope->sc_scope;
df->df_kind = kind;
df->next = id->id_def;
df->df_flags = 0;
id->id_def = df;
/* enter the definition in the list of definitions in this scope */
@ -101,6 +111,21 @@ lookup(id, scope)
assert(df != 0);
return df;
}
if (df->df_kind == D_UNDEF_IMPORT) {
df1 = df->imp_def;
assert(df1 != 0);
if (df1->df_kind == D_MODULE) {
df1 = lookup(id, df1->mod_scope);
if (df1) {
df->df_kind = D_IMPORT;
df->imp_def = df1;
}
return df1;
}
return df;
}
if (df1) {
df1->next = df->next;
df->next = id->id_def;
@ -122,17 +147,31 @@ Export(ids, qualified)
all the "ids" visible in the enclosing scope by defining them
in this scope as "imported".
*/
register struct def *df;
register struct def *df, *df1;
while (ids) {
df = define(ids->nd_IDF, CurrentScope, D_ISEXPORTED);
df = define(ids->nd_IDF, CurrentScope, D_FORWARD);
if (qualified) {
df->df_flags |= D_QEXPORTED;
}
else {
df->df_flags |= D_EXPORTED;
df = define(ids->nd_IDF, enclosing(CurrentScope),
D_IMPORT);
df1 = lookup(ids->nd_IDF,
enclosing(CurrentScope)->sc_scope);
if (! df1 || !(df1->df_kind & (D_PROCHEAD|D_HIDDEN))) {
df1 = define(ids->nd_IDF,
enclosing(CurrentScope),
D_IMPORT);
}
else {
/* A hidden type or a procedure of which only
the head is seen. Apparently, they are
exported from a local module!
*/
df->df_kind = df1->df_kind;
df1->df_kind = D_IMPORT;
}
df1->imp_def = df;
}
ids = ids->next;
}
@ -168,9 +207,24 @@ Import(ids, idn, local)
if (!idn) imp_kind = FROM_ENCLOSING;
else {
imp_kind = FROM_MODULE;
if (local) df = lookfor(idn, enclosing(CurrentScope), 1);
else df = GetDefinitionModule(idn->nd_IDF);
if (df->df_kind != D_MODULE) {
if (local) {
df = lookfor(idn, enclosing(CurrentScope), 0);
if (df->df_kind == D_ERROR) {
/* The module from which the import was done
is not yet declared. I'm not sure if I must
accept this, but for the time being I will.
???
*/
df->df_scope = scope;
df->df_kind = D_FORWMODULE;
df->mod_scope = -1;
kind = D_UNDEF_IMPORT;
}
}
else {
df = GetDefinitionModule(idn->nd_IDF);
}
if (!(df->df_kind & (D_MODULE|D_FORWMODULE))) {
/* enter all "ids" with type D_ERROR */
kind = D_ERROR;
if (df->df_kind != D_ERROR) {
@ -181,13 +235,14 @@ node_error(idn, "identifier \"%s\" does not represent a module", idn->nd_IDF->id
}
while (ids) {
if (imp_kind == FROM_MODULE) {
if (!(df = lookup(ids->nd_IDF, scope))) {
if (scope == -1) {
}
else if (!(df = lookup(ids->nd_IDF, scope))) {
node_error(ids, "identifier \"%s\" not declared in qualifying module",
ids->nd_IDF->id_text);
df = ill_df;
}
else
if (!(df->df_flags&(D_EXPORTED|D_QEXPORTED))) {
else if (!(df->df_flags&(D_EXPORTED|D_QEXPORTED))) {
node_error(ids,"identifier \"%s\" not exported from qualifying module",
ids->nd_IDF->id_text);
}

4
lang/m2/comp/enter.c
View file

@ -29,7 +29,7 @@ Enter(name, kind, type, pnam)
if (!id) fatal("Out of core");
df = define(id, CurrentScope, kind);
df->df_type = type;
if (kind == D_STDPROC || kind == D_STDFUNC) {
if (type = std_type) {
df->df_value.df_stdname = pnam;
}
return df;
@ -54,7 +54,7 @@ EnterIdList(idlist, kind, flags, type, scope)
while (idlist) {
df = define(idlist->nd_IDF, scope, kind);
df->df_type = type;
df->df_flags = flags;
df->df_flags |= flags;
if (kind == D_ENUM) {
if (!first) first = df;
df->enm_val = assval++;

9
lang/m2/comp/expression.g
View file

@ -48,8 +48,7 @@ qualident(int types; struct def **pdf; char *str; struct node **p;)
findname(nd);
assert(nd->nd_class == Def);
*pdf = df = nd->nd_def;
if (df->df_kind != D_ERROR &&
!(types & df->df_kind)) {
if ( !((types|D_ERROR) & df->df_kind)) {
error("identifier \"%s\" is not a %s",
df->df_idf->id_text, str);
}
@ -183,7 +182,11 @@ factor(struct node **p;)
number(p)
|
STRING { *p = MkNode(Value, NULLNODE, NULLNODE, &dot);
(*p)->nd_type = string_type;
if (dot.TOK_SLE == 1) {
dot.TOK_INT = *(dot.TOK_STR);
(*p)->nd_type = char_type;
}
else (*p)->nd_type = string_type;
}
|
'(' expression(p) ')'

3
lang/m2/comp/type.H
View file

@ -68,6 +68,9 @@ struct type {
#define T_PROCEDURE 0x1000
#define T_ARRAY 0x2000
#define T_STRING 0x4000
#define T_INTORCARD (T_INTEGER|T_CARDINAL)
#define T_DISCRETE (T_ENUMERATION|T_INTORCARD|T_CHAR)
#define T_NUMERIC (T_INTORCARD|T_REAL)
int tp_align; /* alignment requirement of this type */
arith tp_size; /* size of this type */
union {

3
lang/m2/comp/type.c
View file

@ -7,7 +7,6 @@ static char *RcsId = "$Header$";
#include <em_arith.h>
#include <em_label.h>
#include "def_sizes.h"
#include "Lpars.h"
#include "def.h"
#include "type.h"
#include "idf.h"
@ -141,7 +140,7 @@ init_types()
real_type = standard_type(T_REAL, real_align, real_size);
longreal_type = standard_type(T_REAL, lreal_align, lreal_size);
word_type = standard_type(T_WORD, wrd_align, wrd_size);
intorcard_type = standard_type(T_INTEGER, int_align, int_size);
intorcard_type = standard_type(T_INTORCARD, int_align, int_size);
string_type = standard_type(T_STRING, 1, (arith) -1);
address_type = construct_type(T_POINTER, word_type);
tp = construct_type(T_SUBRANGE, int_type);

17
lang/m2/comp/typequiv.c
View file

@ -6,16 +6,17 @@ static char *RcsId = "$Header$";
#include <em_label.h>
#include "type.h"
#include "def.h"
#include "Lpars.h"
int
TstTypeEquiv(tp1, tp2)
register struct type *tp1, *tp2;
{
/* test if two types are equivalent. The only complication comes
/* 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 the
same base type are also equivalent.
*/
return tp1 == tp2
@ -23,6 +24,18 @@ TstTypeEquiv(tp1, tp2)
tp1 == error_type
||
tp2 == error_type
||
(
tp1->tp_fund == T_ARRAY
&&
tp1->next == 0
&&
tp2->tp_fund == T_ARRAY
&&
tp2->next == 0
&&
TstTypeEquiv(tp1->arr_elem, tp2->arr_elem)
)
||
(
tp1 && tp1->tp_fund == T_PROCEDURE