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
#include "scope.h"
#include "const.h"
#include "standards.h"
+#include "debug.h"
int
chk_expr(expp)
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;
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;
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;
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;
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;
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;
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");
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;
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;
}
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;
}
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);
}
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);
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;
}
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) == '-') {
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;
}
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 */
#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) */
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;
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;
{
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,
}
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;
}
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;
]?
')'
{ *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; }
]?
;
} :
[ 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;
{
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; }
struct idf *id;
struct def *df, *df1;
struct type *tp;
+ struct node *nd;
} :
[
IdentList(&FldList) ':' type(&tp)
}
|
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)
/* 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",
{ 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; }
]?
;
};
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 */
#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 */
#include <em_label.h>
#include <assert.h>
#include "main.h"
-#include "Lpars.h"
#include "def.h"
#include "type.h"
#include "idf.h"
*/
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
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;
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;
}
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 */
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;
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;
}
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) {
}
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);
}
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;
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++;
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);
}
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) ')'
#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 {
#include <em_arith.h>
#include <em_label.h>
#include "def_sizes.h"
-#include "Lpars.h"
#include "def.h"
#include "type.h"
#include "idf.h"
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);
#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
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
public / ack.git / commitdiff