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

newer version

Browse source
This commit is contained in:
ceriel 1986-04-18 17:53:47 +00:00
parent 53255dcf48
commit 6715e3b171
17 changed files with 246 additions and 60 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
lang/m2/comp/LLlex.c
View file

@ -76,7 +76,7 @@ GetString(upto)
register struct string *str = &string;
register char *p;
str->s_str = p = Malloc((unsigned) (str->s_length = ISTRSIZE));
str->s_str = p = Malloc(str->s_length = ISTRSIZE);
LoadChar(ch);
while (ch != upto) {
if (class(ch) == STNL) {

5
lang/m2/comp/Makefile
View file

@ -38,7 +38,7 @@ hfiles: Parameters make.hfiles
touch hfiles
main: $(OBJ) Makefile
$(CC) $(LFLAGS) $(OBJ) $(LIBDIR)/libcomp.a $(LIBDIR)/malloc.o /user1/erikb/em/lib/libprint.a /user1/erikb/em/lib/libstr.a /user1/erikb/em/lib/libsystem.a -o main
$(CC) $(LFLAGS) $(OBJ) /user1/erikb/em/lib/libem_mes.a /user1/erikb/em/lib/libeme.a $(LIBDIR)/libcomp.a $(LIBDIR)/malloc.o /user1/erikb/em/lib/libprint.a /user1/erikb/em/lib/libstr.a /user1/erikb/em/lib/libsystem.a -o main
size main
clean:
@ -91,12 +91,13 @@ type.o: LLlex.h const.h debug.h def.h idf.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
enter.o: LLlex.h def.h idf.h node.h scope.h type.h
enter.o: LLlex.h def.h idf.h main.h node.h scope.h type.h
defmodule.o: LLlex.h debug.h def.h f_info.h idf.h input.h inputtype.h scope.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 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
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

2
lang/m2/comp/char.tab
View file

@ -23,7 +23,7 @@ STEOI:\200
% INIDF
%
%C
1:a-zA-Z_0-9
1:a-zA-Z0-9
%Tchar inidf[] = {
%F %s,
%p

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

@ -8,6 +8,7 @@ static char *RcsId = "$Header$";
#include <em_label.h>
#include <assert.h>
#include <alloc.h>
#include "Lpars.h"
#include "idf.h"
#include "type.h"
@ -17,6 +18,7 @@ static char *RcsId = "$Header$";
#include "scope.h"
#include "const.h"
#include "standards.h"
#include "debug.h"
int
@ -25,7 +27,7 @@ chk_expr(expp)
{
/* Check the expression indicated by expp for semantic errors,
identify identifiers used in it, replace constants by
their value.
their value, and try to evaluate the expression.
*/
switch(expp->nd_class) {
@ -33,25 +35,32 @@ chk_expr(expp)
return chk_expr(expp->nd_left) &&
chk_expr(expp->nd_right) &&
chk_oper(expp);
case Uoper:
return chk_expr(expp->nd_right) &&
chk_uoper(expp);
case Value:
switch(expp->nd_symb) {
case REAL:
case STRING:
case INTEGER:
return 1;
default:
assert(0);
}
break;
case Xset:
return chk_set(expp);
case Name:
return chk_name(expp);
case Call:
return chk_call(expp);
case Link:
return chk_name(expp);
default:
@ -82,9 +91,9 @@ chk_set(expp)
findname(expp->nd_left);
assert(expp->nd_left->nd_class == Def);
df = expp->nd_left->nd_def;
if ((df->df_kind != D_TYPE && df->df_kind != D_ERROR) ||
if (!(df->df_kind & (D_TYPE|D_ERROR)) ||
(df->df_type->tp_fund != T_SET)) {
node_error(expp, "Illegal set type");
node_error(expp, "illegal set type");
return 0;
}
tp = df->df_type;
@ -93,7 +102,8 @@ chk_set(expp)
/* Now check the elements given, and try to compute a constant set.
*/
set = (arith *) Malloc(tp->tp_size * sizeof(arith) / word_size);
set = (arith *)
Malloc((unsigned) (tp->tp_size * sizeof(arith) / word_size));
nd = expp->nd_right;
while (nd) {
assert(nd->nd_class == Link && nd->nd_symb == ',');
@ -102,7 +112,10 @@ chk_set(expp)
}
expp->nd_type = tp;
if (set) {
/* Yes, in was a constant set, and we managed to compute it!
/* Yes, it was a constant set, and we managed to compute it!
Notice that at the moment there is no such thing as
partial evaluation. Either we evaluate the set, or we
don't (at all). Improvement not neccesary. (???)
*/
expp->nd_class = Set;
expp->nd_set = set;
@ -123,6 +136,8 @@ chk_el(expp, tp, set)
recursively.
Also try to compute the set!
*/
register int i;
if (expp->nd_class == Link && expp->nd_symb == UPTO) {
/* { ... , expr1 .. expr2, ... }
First check expr1 and expr2, and try to compute them.
@ -136,10 +151,9 @@ chk_el(expp, tp, set)
/* We have a constant range. Put all elements in the
set
*/
register int i;
if (expp->nd_left->nd_INT > expp->nd_right->nd_INT) {
node_error(expp, "Lower bound exceeds upper bound in range");
node_error(expp, "lower bound exceeds upper bound in range");
return rem_set(set);
}
@ -161,20 +175,21 @@ node_error(expp, "Lower bound exceeds upper bound in range");
return rem_set(set);
}
if (!TstCompat(tp, expp->nd_type)) {
node_error(expp, "Set element has incompatible type");
node_error(expp, "set element has incompatible type");
return rem_set(set);
}
if (expp->nd_class == Value) {
i = expp->nd_INT;
if ((tp->tp_fund != T_ENUMERATION &&
(expp->nd_INT < tp->sub_lb || expp->nd_INT > tp->sub_ub))
(i < tp->sub_lb || i > tp->sub_ub))
||
(tp->tp_fund == T_ENUMERATION &&
(expp->nd_INT < 0 || expp->nd_INT > tp->enm_ncst))
(i < 0 || i > tp->enm_ncst))
) {
node_error(expp, "Set element out of range");
node_error(expp, "set element out of range");
return rem_set(set);
}
if (*set) (*set)[expp->nd_INT/wrd_bits] |= (1 << (expp->nd_INT%wrd_bits));
if (*set) (*set)[i/wrd_bits] |= (1 << (i%wrd_bits));
}
return 1;
}
@ -207,8 +222,8 @@ getarg(argp, bases)
if (!chk_expr(argp->nd_left)) return 0;
tp = argp->nd_left->nd_type;
if (tp->tp_fund == T_SUBRANGE) tp = tp->next;
if (!(tp->tp_fund & bases)) {
node_error(argp, "Unexpected type");
if (bases && !(tp->tp_fund & bases)) {
node_error(argp, "unexpected type");
return 0;
}
return argp;
@ -226,7 +241,7 @@ getname(argp, kinds)
findname(argp->nd_left);
assert(argp->nd_left->nd_class == Def);
if (!(argp->nd_left->nd_def->df_kind & kinds)) {
node_error(argp, "Unexpected type");
node_error(argp, "unexpected type");
return 0;
}
return argp;
@ -243,6 +258,8 @@ chk_call(expp)
register struct node *left;
register struct node *arg;
/* First, get the name of the function or procedure
*/
expp->nd_type = error_type;
left = expp->nd_left;
findname(left);
@ -250,18 +267,18 @@ chk_call(expp)
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.
/* It was a type cast. This is of course not portable.
No runtime action. Remove it.
*/
arg = expp->nd_right;
if ((! arg) || arg->nd_right) {
node_error(expp, "Only one parameter expected in type cast");
node_error(expp, "only one parameter expected in type cast");
return 0;
}
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");
node_error(expp, "size of type in type cast does not match size of operand");
return 0;
}
arg->nd_type = left->nd_type;
@ -285,7 +302,7 @@ node_error(expp, "Size of type in type cast does not match size of operand");
/* A standard procedure
*/
assert(left->nd_class == Def);
DO_DEBUG(3, debug("Standard name \"%s\", %d",
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:
@ -297,6 +314,7 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname));
cstcall(expp, S_ABS);
}
break;
case S_CAP:
arg = getarg(arg, T_CHAR);
expp->nd_type = char_type;
@ -306,6 +324,7 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname));
cstcall(expp, S_CAP);
}
break;
case S_CHR:
arg = getarg(arg, T_INTORCARD);
expp->nd_type = char_type;
@ -314,11 +333,13 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname));
cstcall(expp, S_CHR);
}
break;
case S_FLOAT:
arg = getarg(arg, T_INTORCARD);
expp->nd_type = real_type;
if (!arg) return 0;
break;
case S_HIGH:
arg = getarg(arg, T_ARRAY);
if (!arg) return 0;
@ -331,6 +352,7 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname));
}
else cstcall(expp, S_MAX);
break;
case S_MAX:
case S_MIN:
arg = getarg(arg, T_DISCRETE);
@ -338,6 +360,7 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname));
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_INTORCARD);
if (!arg) return 0;
@ -346,6 +369,7 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname));
cstcall(expp, S_ODD);
}
break;
case S_ORD:
arg = getarg(arg, T_DISCRETE);
if (!arg) return 0;
@ -354,6 +378,7 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname));
cstcall(expp, S_ORD);
}
break;
case S_TSIZE: /* ??? */
case S_SIZE:
arg = getname(arg, D_FIELD|D_VARIABLE|D_TYPE|D_HIDDEN|D_HTYPE);
@ -361,11 +386,13 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname));
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: {
struct type *tp;
@ -388,11 +415,13 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname));
}
break;
}
case S_ADR:
arg = getname(arg, D_VARIABLE|D_FIELD|D_PROCEDURE);
expp->nd_type = address_type;
if (!arg) return 0;
break;
case S_DEC:
case S_INC:
expp->nd_type = 0;
@ -403,9 +432,11 @@ left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname));
if (!arg) return 0;
}
break;
case S_HALT:
expp->nd_type = 0;
break;
case S_EXCL:
case S_INCL: {
struct type *tp;
@ -421,11 +452,12 @@ node_error(arg, "EXCL and INCL expect a SET parameter");
arg = getarg(arg, T_DISCRETE);
if (!arg) return 0;
if (!TstCompat(tp->next, arg->nd_left->nd_type)) {
node_error(arg, "Unexpected type");
node_error(arg, "unexpected type");
return 0;
}
break;
}
default:
assert(0);
}
@ -436,14 +468,51 @@ node_error(arg, "EXCL and INCL expect a SET parameter");
}
return 1;
}
/* Here, we have found a real procedure call
/* Here, we have found a real procedure call. The left hand
side may also represent a procedure variable.
*/
return 1;
return chk_proccall(expp);
}
node_error(expp->nd_left, "procedure, type, or function expected");
return 0;
}
chk_proccall(expp)
struct node *expp;
{
/* Check a procedure call
*/
register struct node *left = expp->nd_left;
register struct node *arg;
register struct paramlist *param;
expp->nd_type = left->nd_type->next;
param = left->nd_type->prc_params;
arg = expp;
while (param) {
arg = getarg(arg, 0);
if (!arg) return 0;
if (param->par_var &&
! TstCompat(param->par_type, arg->nd_left->nd_type)) {
node_error(arg->nd_left, "type incompatibility in var parameter");
return 0;
}
else
if (!param->par_var &&
!TstAssCompat(param->par_type, arg->nd_left->nd_type)) {
node_error(arg->nd_left, "type incompatibility in value parameter");
return 0;
}
param = param->next;
}
if (arg->nd_right) {
node_error(arg->nd_right, "too many parameters supplied");
return 0;
}
return 1;
}
findname(expp)
register struct node *expp;
{
@ -471,7 +540,7 @@ findname(expp)
}
else if (tp->tp_fund != T_RECORD) {
/* This is also true for modules */
node_error(expp,"Illegal selection");
node_error(expp,"illegal selection");
df = ill_df;
}
else df = lookup(expp->nd_right->nd_IDF, tp->rec_scope);
@ -614,16 +683,19 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
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;
}
break;
case '/':
switch(tpl->tp_fund) {
case T_SET:
@ -632,10 +704,12 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
cstset(expp);
}
/* Fall through */
case T_REAL:
return 1;
}
break;
case DIV:
case MOD:
if (tpl->tp_fund & T_INTORCARD) {
@ -646,6 +720,7 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
return 1;
}
break;
case OR:
case AND:
if (tpl == bool_type) {
@ -657,6 +732,7 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
}
errval = 3;
break;
case '=':
case '#':
case GREATEREQUAL:
@ -673,6 +749,7 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
cstset(expp);
}
return 1;
case T_INTEGER:
case T_CARDINAL:
case T_ENUMERATION: /* includes boolean */
@ -683,24 +760,29 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
cstbin(expp);
}
return 1;
case T_POINTER:
if (!(expp->nd_symb == '=' || expp->nd_symb == '#')) {
break;
}
/* Fall through */
case T_REAL:
return 1;
}
default:
assert(0);
}
switch(errval) {
case 1:
node_error(expp,"Operator \"%s\": illegal operand type(s)", symbol2str(expp->nd_symb));
node_error(expp,"operator \"%s\": illegal operand type(s)", symbol2str(expp->nd_symb));
break;
case 3:
node_error(expp, "BOOLEAN type(s) expected");
break;
default:
assert(0);
}
@ -727,6 +809,7 @@ chk_uoper(expp)
return 1;
}
break;
case '-':
if (tpr->tp_fund & T_INTORCARD) {
if (expp->nd_right->nd_class == Value) {
@ -747,6 +830,7 @@ chk_uoper(expp)
return 1;
}
break;
case NOT:
if (tpr == bool_type) {
if (expp->nd_right->nd_class == Value) {
@ -755,10 +839,12 @@ chk_uoper(expp)
return 1;
}
break;
case '^':
if (tpr->tp_fund != T_POINTER) break;
expp->nd_type = tpr->next;
return 1;
default:
assert(0);
}

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

@ -14,16 +14,24 @@ static char *RcsId = "$Header$";
#include "scope.h"
#include "node.h"
#include "misc.h"
#include "main.h"
static int proclevel = 0; /* nesting level of procedures */
char * sprint();
}
ProcedureDeclaration
{
struct def *df;
char buf[256];
} :
ProcedureHeading(&df, D_PROCEDURE)
{ df->prc_level = proclevel++;
if (DefinitionModule) {
C_exp(sprint(buf, "%s_%s",
df->df_scope->sc_name,
df->df_idf->id_text));
}
}
';' block(&(df->prc_body)) IDENT
{ match_id(dot.TOK_IDF, df->df_idf);

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

@ -14,8 +14,13 @@ struct module {
struct variable {
arith va_off; /* address or offset of variable */
char va_addrgiven; /* an address was given in the program */
char va_noreg; /* may not be in a register */
short va_number; /* number of this variable in definition module
*/
#define var_off df_value.df_variable.va_off
#define var_addrgiven df_value.df_variable.va_addrgiven
#define var_noreg df_value.df_variable.va_noreg
#define var_number df_value.df_variable.va_number
};
struct constant {
@ -43,13 +48,16 @@ struct field {
struct dfproc {
struct scope *pr_scope; /* scope of procedure */
int pr_level; /* depth level of this procedure */
arith pr_nbpar; /* Number of bytes parameters */
short pr_level; /* depth level of this procedure */
short pr_number; /* number of this procedure in definition module
*/
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_number df_value.df_proc.pr_number
};
struct import {

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

@ -22,6 +22,32 @@ static struct def illegal_def =
struct def *ill_df = &illegal_def;
struct def *
MkDef(id, scope, kind)
struct idf *id;
struct scope *scope;
{
/* Create a new definition structure in scope "scope", with
id "id" and kind "kind".
*/
register struct def *df;
df = new_def();
df->df_flags = 0;
df->df_idf = id;
df->df_scope = scope;
df->df_kind = kind;
df->df_type = 0;
df->next = id->id_def;
id->id_def = df;
/* enter the definition in the list of definitions in this scope
*/
df->df_nextinscope = scope->sc_def;
scope->sc_def = df;
return df;
}
struct def *
define(id, scope, kind)
register struct idf *id;
@ -85,19 +111,7 @@ error("identifier \"%s\" already declared", id->id_text);
}
return df;
}
df = new_def();
df->df_flags = 0;
df->df_idf = id;
df->df_scope = scope;
df->df_kind = kind;
df->df_type = 0;
df->next = id->id_def;
id->id_def = df;
/* enter the definition in the list of definitions in this scope */
df->df_nextinscope = scope->sc_def;
scope->sc_def = df;
return df;
return MkDef(id, scope, kind);
}
struct def *

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

@ -12,6 +12,7 @@ static char *RcsId = "$Header$";
#include "scope.h"
#include "LLlex.h"
#include "node.h"
#include "main.h"
struct def *
Enter(name, kind, type, pnam)
@ -126,6 +127,13 @@ node_error(IdList->nd_left,"Illegal type for address");
df->var_off = off;
scope->sc_off = off;
}
else if (DefinitionModule) {
char buf[256];
char *sprint();
C_exa_dnam(sprint(buf,"%s_%s",df->df_scope->sc_name,
df->df_idf->id_text));
}
IdList = IdList->nd_right;
}
}
@ -137,17 +145,20 @@ lookfor(id, scope, give_error)
{
/* Look for an identifier in the visibility range started by
"scope".
If it is not defined, give an error message, and
If it is not defined, maybe give an error message, and
create a dummy definition.
*/
struct def *df;
register struct scope *sc = scope;
struct def *MkDef();
while (sc) {
df = lookup(id->nd_IDF, sc);
if (df) return df;
sc = nextvisible(sc);
}
if (give_error) id_not_declared(id);
return define(id->nd_IDF, scope, D_ERROR);
return MkDef(id->nd_IDF, scope, D_ERROR);
}

1
lang/m2/comp/error.c
View file

@ -11,6 +11,7 @@ static char *RcsId = "$Header$";
#include <em_arith.h>
#include "errout.h"
#include "debug.h"
#include "input.h"
#include "f_info.h"

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

@ -183,10 +183,15 @@ factor(struct node **p;)
| %default
number(p)
|
STRING { *p = MkNode(Value, NULLNODE, NULLNODE, &dot);
STRING {
*p = MkNode(Value, NULLNODE, NULLNODE, &dot);
if (dot.TOK_SLE == 1) {
dot.TOK_INT = *(dot.TOK_STR);
(*p)->nd_type = char_type;
int i;
i = *(dot.TOK_STR) & 0377;
(*p)->nd_type = charc_type;
free(dot.TOK_STR);
dot.TOK_INT = i;
}
else (*p)->nd_type = string_type;
}

25
lang/m2/comp/main.c
View file

@ -40,23 +40,24 @@ main(argc, argv)
Nargv[Nargc++] = *argv++;
}
Nargv[Nargc] = 0; /* terminate the arg vector */
if (Nargc != 2) {
fprint(STDERR, "%s: Use one file argument\n", ProgName);
if (Nargc < 2) {
fprint(STDERR, "%s: Use a file argument\n", ProgName);
return 1;
}
#ifdef DEBUG
print("Mod2 compiler -- Debug version\n");
#endif DEBUG
print("MODULA-2 compiler -- Debug version\n");
DO_DEBUG(1, debug("Debugging level: %d", options['D']));
return !Compile(Nargv[1]);
#endif DEBUG
return !Compile(Nargv[1], Nargv[2]);
}
Compile(src)
char *src;
Compile(src, dst)
char *src, *dst;
{
extern struct tokenname tkidf[];
DO_DEBUG(1, debug("Filename : %s", src));
DO_DEBUG(1, (!dst || debug("Targetfile: %s", dst)));
if (! InsertFile(src, (char **) 0, &src)) {
fprint(STDERR,"%s: cannot open %s\n", ProgName, src);
return 0;
@ -77,8 +78,15 @@ Compile(src)
{
(void) open_scope(CLOSEDSCOPE);
GlobalScope = CurrentScope;
C_init(word_size, pointer_size);
if (! C_open(dst)) {
fatal("Could not open output file");
}
C_magic();
C_ms_emx(word_size, pointer_size);
CompUnit();
}
C_close();
if (err_occurred) return 0;
return 1;
}
@ -87,6 +95,7 @@ Compile(src)
LexScan()
{
register int symb;
char *symbol2str();
while ((symb = LLlex()) > 0) {
print(">>> %s ", symbol2str(symb));
@ -171,6 +180,8 @@ init_DEFPATH()
if (*p) *p++ = '\0';
}
}
else DEFPATH[i++] = "";
DEFPATH[i] = 0;
}

17
lang/m2/comp/program.g
View file

@ -20,6 +20,9 @@ static int DEFofIMPL = 0; /* Flag indicating that we are currently
implementation module currently being
compiled
*/
short nmcount = 0; /* count names in definition modules in order
to create suitable names in the object code
*/
}
/*
The grammar as given by Wirth is already almost LL(1); the
@ -95,7 +98,7 @@ export(int def;)
Export(ExportList, QUALflag);
}
else {
warning("export list in definition module ignored");
node_warning(ExportList, "export list in definition module ignored");
FreeNode(ExportList);
}
}
@ -125,16 +128,20 @@ DefinitionModule
{
register struct def *df;
struct idf *id;
int savnmcount = nmcount;
} :
DEFINITION
MODULE IDENT { id = dot.TOK_IDF;
df = define(id, GlobalScope, D_MODULE);
if (!SYSTEMModule) open_scope(CLOSEDSCOPE);
df->mod_scope = CurrentScope;
CurrentScope->sc_name = id->id_text;
df->df_type = standard_type(T_RECORD, 0, (arith) 0);
df->df_type->rec_scope = df->mod_scope;
DefinitionModule = 1;
DO_DEBUG(1, debug("Definition module \"%s\"", id->id_text));
DefinitionModule++;
nmcount = 0;
DO_DEBUG(1, debug("Definition module \"%s\" %d",
id->id_text, DefinitionModule));
}
';'
import(0)*
@ -158,8 +165,9 @@ DefinitionModule
df = df->df_nextinscope;
}
if (!SYSTEMModule) close_scope(SC_CHKFORW);
DefinitionModule = 0;
DefinitionModule--;
match_id(id, dot.TOK_IDF);
nmcount = savnmcount;
}
'.'
;
@ -210,7 +218,6 @@ ProgramModule(int state;)
df = GetDefinitionModule(id);
CurrentScope = df->mod_scope;
DEFofIMPL = 0;
DefinitionModule = 0;
}
else {
df = define(id, CurrentScope, D_MODULE);

4
lang/m2/comp/scope.C
View file

@ -15,6 +15,7 @@ static char *RcsId = "$Header$";
#include "debug.h"
struct scope *CurrentScope, *PervasiveScope, *GlobalScope;
static int scp_level;
/* STATICALLOCDEF "scope" */
@ -26,6 +27,7 @@ open_scope(scopetype)
assert(scopetype == OPENSCOPE || scopetype == CLOSEDSCOPE);
sc->sc_scopeclosed = scopetype == CLOSEDSCOPE;
sc->sc_level = scp_level++;
sc->sc_forw = 0;
sc->sc_def = 0;
sc->sc_off = 0;
@ -45,6 +47,7 @@ init_scope()
sc->sc_scopeclosed = 0;
sc->sc_forw = 0;
sc->sc_def = 0;
sc->sc_level = scp_level++;
sc->next = 0;
PervasiveScope = sc;
CurrentScope = sc;
@ -197,6 +200,7 @@ close_scope(flag)
Reverse(&(sc->sc_def));
}
CurrentScope = sc->next;
scp_level = CurrentScope->sc_level;
}
#ifdef DEBUG

2
lang/m2/comp/scope.h
View file

@ -15,9 +15,11 @@
struct scope {
struct scope *next;
struct forwards *sc_forw;
char *sc_name; /* name of this scope */
struct def *sc_def; /* list of definitions in this scope */
arith sc_off; /* offsets of variables in this scope */
char sc_scopeclosed; /* flag indicating closed or open scope */
int sc_level; /* level of this scope */
};
extern struct scope

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

@ -88,6 +88,7 @@ struct type {
extern struct type
*bool_type,
*char_type,
*charc_type,
*int_type,
*card_type,
*longint_type,

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

@ -40,6 +40,7 @@ arith
struct type
*bool_type,
*char_type,
*charc_type,
*int_type,
*card_type,
*longint_type,
@ -134,6 +135,8 @@ init_types()
char_type = standard_type(T_CHAR, 1, (arith) 1);
char_type->enm_ncst = 256;
charc_type = standard_type(T_CHAR, 1, (arith) 1);
charc_type->enm_ncst = 256;
bool_type = standard_type(T_ENUMERATION, 1, (arith) 1);
bool_type->enm_ncst = 2;
int_type = standard_type(T_INTEGER, int_align, int_size);

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

@ -111,3 +111,27 @@ TstCompat(tp1, tp2)
)
;
}
int TstAssCompat(tp1, tp2)
struct type *tp1, *tp2;
{
/* 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 == char_type && tp2 == charc_type) return 1;
if (tp1->tp_fund == T_ARRAY &&
(tp2 == charc_type || tp2 == string_type)) {
/* Unfortunately the length of the string is not
available here, so this must be tested somewhere else (???)
*/
tp1 = tp1->arr_elem;
if (tp1->tp_fund == T_SUBRANGE) tp1 = tp1->next;
return tp1 == char_type;
}
return 0;
}