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

safety commit

Browse source
This commit is contained in:
ceriel 1986-04-09 18:14:49 +00:00
parent b853ce1546
commit d1a2112163
13 changed files with 365 additions and 130 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -16,6 +16,8 @@ struct token {
struct string tk_str; /* STRING */
arith tk_int; /* INTEGER */
char *tk_real; /* REAL */
arith *tk_set; /* only used in parse tree node */
struct def *tk_def; /* only used in parse tree node */
} tk_data;
};

2
lang/m2/comp/Makefile
View file

@ -91,7 +91,7 @@ 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
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 def.h idf.h node.h scope.h type.h
chk_expr.o: LLlex.h Lpars.h const.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

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

@ -7,6 +7,7 @@ static char *RcsId = "$Header$";
#include <em_arith.h>
#include <em_label.h>
#include <assert.h>
#include <alloc.h>
#include "idf.h"
#include "type.h"
#include "def.h"
@ -14,6 +15,8 @@ static char *RcsId = "$Header$";
#include "node.h"
#include "Lpars.h"
#include "scope.h"
#include "const.h"
#include "standards.h"
int
chk_expr(expp, const)
@ -60,10 +63,13 @@ int
chk_set(expp, const)
register struct node *expp;
{
/* Check the legality of a SET aggregate, and try to evaluate it
compile time. Unfortunately this is all rather complicated.
*/
struct type *tp;
struct def *df;
register struct node *nd;
extern struct def *findname();
arith *set;
assert(expp->nd_symb == SET);
@ -72,7 +78,9 @@ chk_set(expp, const)
if (expp->nd_left) {
/* A type was given. Check it out
*/
df = findname(expp->nd_left);
(void) 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) ||
(df->df_type->tp_fund != SET)) {
node_error(expp, "Illegal set type");
@ -82,48 +90,79 @@ chk_set(expp, const)
}
else tp = bitset_type;
/* Now check the elements given
/* Now check the elements given, and try to compute a constant set.
*/
set = (arith *) Malloc(tp->tp_size * sizeof(arith) / wrd_size);
nd = expp->nd_right;
while (nd) {
assert(nd->nd_class == Link && nd->nd_symb == ',');
if (!chk_el(nd->nd_left, const, tp->next, 0)) return 0;
if (!chk_el(nd->nd_left, const, tp->next, &set)) return 0;
nd = nd->nd_right;
}
expp->nd_type = tp;
assert(!const || set);
if (set) {
/* Yes, in was a constant set, and we managed to compute it!
*/
expp->nd_class = Set;
expp->nd_set = set;
FreeNode(expp->nd_left);
FreeNode(expp->nd_right);
expp->nd_left = expp->nd_right = 0;
}
return 1;
}
int
chk_el(expp, const, tp, level)
struct node *expp;
chk_el(expp, const, tp, set)
register struct node *expp;
struct type *tp;
arith **set;
{
/* Check elements of a set. This routine may call itself
recursively, but only once.
recursively.
Also try to compute the set!
*/
if (expp->nd_class == Link && expp->nd_symb == UPTO) {
/* { ... , expr1 .. expr2, ... } */
if (level) {
node_error(expp, "Illegal set element");
return 0;
}
if (!chk_el(expp->nd_left, const, tp, 1) ||
!chk_el(expp->nd_right, const, tp, 1)) {
/* { ... , expr1 .. expr2, ... }
First check expr1 and expr2, and try to compute them.
*/
if (!chk_el(expp->nd_left, const, tp, set) ||
!chk_el(expp->nd_right, const, tp, set)) {
return 0;
}
if (expp->nd_left->nd_class == Value &&
expp->nd_right->nd_class == Value) {
/* 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");
return 0;
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));
}
}
else if (*set) {
free(*set);
*set = 0;
}
return 1;
}
if (!chk_expr(expp, const)) return 0;
/* Here, a single element is checked
*/
if (!chk_expr(expp, const)) {
return rem_set(set);
}
if (!TstCompat(tp, expp->nd_type)) {
node_error(expp, "Set element has incompatible type");
return 0;
return rem_set(set);
}
if (expp->nd_class == Value) {
if ((tp->tp_fund != ENUMERATION &&
@ -133,24 +172,104 @@ node_error(expp, "Lower bound exceeds upper bound in range");
(expp->nd_INT < 0 || expp->nd_INT > tp->enm_ncst))
) {
node_error(expp, "Set element out of range");
#ifdef DEBUG
debug("%d (%d, %d)", (int) expp->nd_INT, (int) tp->sub_lb, (int) tp->sub_ub);
#endif
return 0;
return rem_set(set);
}
if (*set) (*set)[expp->nd_INT/wrd_bits] |= (1 << (expp->nd_INT%wrd_bits));
}
return 1;
}
int
rem_set(set)
arith **set;
{
/* This routine is only used for error exits of chk_el.
It frees the set indicated by "set", and returns 0.
*/
if (*set) {
free((char *) *set);
*set = 0;
}
return 0;
}
int
chk_call(expp, const)
register struct node *expp;
{
/* ??? */
return 1;
register struct type *tp;
register struct node *left;
expp->nd_type = error_type;
(void) findname(expp->nd_left);
left = expp->nd_left;
tp = left->nd_type;
if (tp == 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.
*/
if (!expp->nd_right ||
(expp->nd_right->nd_symb == ',')) {
node_error(expp, "Only one parameter expected in type cast");
return 0;
}
if (! chk_expr(expp->nd_right, const)) return 0;
if (expp->nd_right->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;
}
expp->nd_right->nd_type = left->nd_type;
left = expp->nd_right;
FreeNode(expp->nd_left);
*expp = *(expp->nd_right);
left->nd_left = left->nd_right = 0;
FreeNode(left);
return 1;
}
if ((left->nd_class == Def && left->nd_def->df_kind == D_PROCEDURE) ||
tp->tp_fund == PROCVAR) {
/* A procedure call. it may also be a call to a
standard procedure
*/
if (tp == std_type) {
assert(left->nd_class == Def);
switch(left->nd_def->df_value.df_stdname) {
case S_ABS:
case S_CAP:
case S_CHR:
case S_FLOAT:
case S_HIGH:
case S_MAX:
case S_MIN:
case S_ODD:
case S_ORD:
case S_SIZE:
case S_TRUNC:
case S_VAL:
break;
case S_DEC:
case S_INC:
case S_HALT:
case S_EXCL:
case S_INCL:
expp->nd_type = 0;
break;
default:
assert(0);
}
return 1;
}
return 1;
}
node_error(expp->nd_left, "procedure, type, or function expected");
return 0;
}
struct def *
findname(expp)
register struct node *expp;
{
@ -159,41 +278,66 @@ findname(expp)
*/
register struct def *df;
struct def *lookfor();
register struct node *nd;
register struct type *tp;
int scope;
int module;
expp->nd_type = error_type;
if (expp->nd_class == Name) {
return lookfor(expp, CurrentScope, 1);
expp->nd_def = lookfor(expp, CurrentScope, 1);
expp->nd_class = Def;
expp->nd_type = expp->nd_def->df_type;
return;
}
assert(expp->nd_class == Link && expp->nd_symb == '.');
assert(expp->nd_left->nd_class == Name);
df = lookfor(expp->nd_left, CurrentScope, 1);
if (df->df_kind == D_ERROR) return df;
nd = expp;
while (nd->nd_class == Link) {
struct node *nd1;
if (!(scope = has_selectors(df))) {
node_error(nd, "identifier \"%s\" has no selectors",
df->df_idf->id_text);
return ill_df;
if (expp->nd_class == Link) {
assert(expp->nd_symb == '.');
assert(expp->nd_right->nd_class == Name);
findname(expp->nd_left);
tp = expp->nd_left->nd_type;
if (tp == error_type) {
df = ill_df;
}
nd = nd->nd_right;
if (nd->nd_class == Name) nd1 = nd;
else nd1 = nd->nd_left;
module = (df->df_kind == D_MODULE);
df = lookup(nd1->nd_IDF, scope);
else if (tp->tp_fund != RECORD) {
/* This is also true for modules */
node_error(expp,"Illegal selection");
df = ill_df;
}
else df = lookup(expp->nd_right->nd_IDF, tp->rec_scope);
if (!df) {
id_not_declared(nd1);
return ill_df;
df = ill_df;
id_not_declared(expp->nd_right);
}
if (module && !(df->df_flags&(D_EXPORTED|D_QEXPORTED))) {
node_error(nd1, "identifier \"%s\" not exprted from qualifying module",
else if (df != ill_df) {
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",
df->df_idf->id_text);
}
}
if (expp->nd_left->nd_class == Def) {
expp->nd_class = Def;
expp->nd_def = df;
FreeNode(expp->nd_left);
FreeNode(expp->nd_right);
expp->nd_left = expp->nd_right = 0;
}
return;
}
return df;
if (expp->nd_class == Oper) {
assert(expp->nd_symb == '[');
(void) findname(expp->nd_left);
if (chk_expr(expp->nd_right, 0) &&
expp->nd_left->nd_type != error_type &&
chk_oper(expp)) /* ??? */ ;
return 1;
}
if (expp->nd_class == Uoper && expp->nd_symb == '^') {
(void) findname(expp->nd_right);
if (expp->nd_right->nd_type != error_type &&
chk_uoper(expp)) /* ??? */ ;
}
return 0;
}
int
@ -203,16 +347,14 @@ chk_name(expp, const)
register struct def *df;
int retval = 1;
df = findname(expp);
(void) findname(expp);
assert(expp->nd_class == Def);
df = expp->nd_def;
if (df->df_kind == D_ERROR) {
retval = 0;
}
expp->nd_type = df->df_type;
if (df->df_kind == D_ENUM || df->df_kind == D_CONST) {
if (expp->nd_left) FreeNode(expp->nd_left);
if (expp->nd_right) FreeNode(expp->nd_right);
if (df->df_kind & (D_ENUM | D_CONST)) {
if (df->df_kind == D_ENUM) {
expp->nd_left = expp->nd_right = 0;
expp->nd_class = Value;
expp->nd_INT = df->enm_val;
expp->nd_symb = INTEGER;
@ -251,10 +393,11 @@ chk_oper(expp, const)
expp->nd_right->nd_type = tpr = tpl;
}
}
expp->nd_type = error_type;
if (expp->nd_symb == IN) {
/* Handle this one specially */
expp->nd_type == bool_type;
expp->nd_type = bool_type;
if (tpr->tp_fund != SET) {
node_error(expp, "RHS of IN operator not a SET type");
return 0;
@ -266,6 +409,21 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
return 1;
}
if (expp->nd_symb == '[') {
/* Handle ARRAY selection specially too! */
if (tpl->tp_fund != ARRAY) {
node_error(expp, "array index not belonging to an ARRAY");
return 0;
}
if (!TstCompat(tpl->next, tpr)) {
node_error(expp, "incompatible index type");
return 0;
}
expp->nd_type = tpl->arr_elem;
if (const) return 0;
return 1;
}
if (tpl->tp_fund == SUBRANGE) tpl = tpl->next;
expp->nd_type = tpl;
@ -450,6 +608,11 @@ chk_uoper(expp, const)
return 1;
}
break;
case '^':
if (tpr->tp_fund != POINTER) break;
expp->nd_type = tpr->next;
if (const) return 0;
return 1;
default:
assert(0);
}

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

@ -8,4 +8,5 @@ extern int
mach_long_size; /* size of long on this machine == sizeof(long) */
extern arith
max_int, /* maximum integer on target machine */
max_unsigned; /* maximum unsigned on target machine */
max_unsigned, /* maximum unsigned on target machine */
wrd_bits; /* Number of bits in a word */

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

@ -18,6 +18,7 @@ long full_mask[MAXSIZE];/* full_mask[1] == 0xFF, full_mask[2] == 0xFFFF, .. */
arith max_int; /* maximum integer on target machine */
arith max_unsigned; /* maximum unsigned on target machine */
arith max_longint; /* maximum longint on target machine */
arith wrd_bits; /* number of bits in a word */
cstunary(expp)
register struct node *expp;
@ -206,21 +207,85 @@ cstbin(expp)
cstset(expp)
register struct node *expp;
{
switch(expp->nd_symb) {
case IN:
case '+':
case '-':
case '*':
case '/':
case GREATEREQUAL:
case LESSEQUAL:
case '=':
case '#':
/* ??? */
break;
default:
assert(0);
register arith *set1 = 0, *set2;
register int setsize, j;
assert(expp->nd_right->nd_class == Set);
assert(expp->nd_symb == IN || expp->nd_left->nd_class == Set);
set2 = expp->nd_right->nd_set;
setsize = expp->nd_right->nd_type->tp_size / wrd_size;
if (expp->nd_symb == IN) {
arith i;
assert(expp->nd_left->nd_class == Value);
i = expp->nd_left->nd_INT;
expp->nd_INT = (i >= 0 &&
i < setsize * wrd_bits &&
(set2[i / wrd_bits] & (1 << (i % wrd_bits))));
free((char *) set2);
}
else {
set1 = expp->nd_left->nd_set;
switch(expp->nd_symb) {
case '+':
for (j = 0; j < setsize; j++) {
*set1++ |= *set2++;
}
break;
case '-':
for (j = 0; j < setsize; j++) {
*set1++ &= ~*set2++;
}
break;
case '*':
for (j = 0; j < setsize; j++) {
*set1++ &= *set2++;
}
break;
case '/':
for (j = 0; j < setsize; j++) {
*set1++ ^= *set2++;
}
break;
case GREATEREQUAL:
case LESSEQUAL:
case '=':
case '#':
/* Clumsy, but who cares? Nobody writes these things! */
for (j = 0; j < setsize; j++) {
switch(expp->nd_symb) {
case GREATEREQUAL:
if ((*set1 | *set2++) != *set1) break;
set1++;
continue;
case LESSEQUAL:
if ((*set2 | *set1++) != *set2) break;
set2++;
continue;
case '=':
case '#':
if (*set1++ != *set2++) break;
continue;
}
expp->nd_INT = expp->nd_symb == '#';
break;
}
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);
break;
default:
assert(0);
}
free((char *) expp->nd_right->nd_set);
expp->nd_class = Set;
expp->nd_set = expp->nd_left->nd_set;
}
FreeNode(expp->nd_left);
FreeNode(expp->nd_right);
expp->nd_left = expp->nd_right = 0;
}
cut_size(expr)
@ -273,4 +338,5 @@ init_cst()
max_int = full_mask[int_size] & ~(1 << (int_size * 8 - 1));
max_unsigned = full_mask[int_size];
wrd_bits = 8 * wrd_size;
}

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

@ -234,7 +234,6 @@ IdentList(struct node **p;)
SubrangeType(struct type **ptp;)
{
struct node *nd1, *nd2;
extern struct type *subr_type();
}:
/*
This is not exactly the rule in the new report, but see
@ -340,7 +339,6 @@ CaseLabels
SetType(struct type **ptp;)
{
struct type *tp;
struct type *set_type();
} :
SET OF SimpleType(&tp)
{

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

@ -6,6 +6,7 @@ static char *RcsId = "$Header$";
#include <alloc.h>
#include <em_arith.h>
#include <em_label.h>
#include <assert.h>
#include "LLlex.h"
#include "idf.h"
#include "def.h"
@ -36,21 +37,17 @@ qualident(int types; struct def **pdf; char *str; struct node **p;)
register struct def *df;
register struct node **pnd;
struct node *nd;
struct def *findname();
} :
IDENT { nd = MkNode(Name, NULLNODE, NULLNODE, &dot);
pnd = &nd;
}
[
/* selector */
'.' { *pnd = MkNode(Link,*pnd,NULLNODE,&dot);
pnd = &(*pnd)->nd_right;
}
IDENT
{ *pnd = MkNode(Name,NULLNODE,NULLNODE,&dot); }
selector(pnd)
]*
{ if (types) {
*pdf = df = findname(nd);
findname(nd);
assert(nd->nd_class == Def);
*pdf = df = nd->nd_def;
if (df->df_kind != D_ERROR &&
!(types & df->df_kind)) {
error("identifier \"%s\" is not a %s",
@ -62,11 +59,10 @@ qualident(int types; struct def **pdf; char *str; struct node **p;)
}
;
/* Inline substituted wherever it occurred
selector:
'.' IDENT
selector(struct node **pnd;):
'.' { *pnd = MkNode(Link,*pnd,NULLNODE,&dot); }
IDENT { (*pnd)->nd_right = MkNode(Name,NULLNODE,NULLNODE,&dot); }
;
*/
ExpList(struct node **pnd;)
{
@ -238,11 +234,7 @@ designator(struct node **pnd;)
designator_tail(struct node **pnd;):
visible_designator_tail(pnd)
[
/* selector */
'.' { *pnd = MkNode(Link, *pnd, NULLNODE, &dot); }
IDENT { (*pnd)->nd_right =
MkNode(Name, NULLNODE, NULLNODE, &dot);
}
selector(pnd)
|
visible_designator_tail(pnd)
]*
@ -250,8 +242,15 @@ designator_tail(struct node **pnd;):
visible_designator_tail(struct node **pnd;):
'[' { *pnd = MkNode(Oper, *pnd, NULLNODE, &dot); }
ExpList(&((*pnd)->nd_right))
expression(&((*pnd)->nd_right))
[
','
{ *pnd = MkNode(Oper, *pnd, NULLNODE, &dot);
(*pnd)->nd_symb = '[';
}
expression(&((*pnd)->nd_right))
]*
']'
|
'^' { *pnd = MkNode(Oper, *pnd, NULLNODE, &dot); }
'^' { *pnd = MkNode(Oper, NULLNODE, *pnd, &dot); }
;

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

@ -128,23 +128,23 @@ add_standards()
register struct def *df;
struct def *Enter();
(void) Enter("ABS", D_STDFUNC, NULLTYPE, S_ABS);
(void) Enter("CAP", D_STDFUNC, NULLTYPE, S_CAP);
(void) Enter("CHR", D_STDFUNC, NULLTYPE, S_CHR);
(void) Enter("FLOAT", D_STDFUNC, NULLTYPE, S_FLOAT);
(void) Enter("HIGH", D_STDFUNC, NULLTYPE, S_HIGH);
(void) Enter("HALT", D_STDPROC, NULLTYPE, S_HALT);
(void) Enter("EXCL", D_STDPROC, NULLTYPE, S_EXCL);
(void) Enter("DEC", D_STDPROC, NULLTYPE, S_DEC);
(void) Enter("INC", D_STDPROC, NULLTYPE, S_INC);
(void) Enter("VAL", D_STDFUNC, NULLTYPE, S_VAL);
(void) Enter("TRUNC", D_STDFUNC, NULLTYPE, S_TRUNC);
(void) Enter("SIZE", D_STDFUNC, NULLTYPE, S_SIZE);
(void) Enter("ORD", D_STDFUNC, NULLTYPE, S_ORD);
(void) Enter("ODD", D_STDFUNC, NULLTYPE, S_ODD);
(void) Enter("MAX", D_STDFUNC, NULLTYPE, S_MAX);
(void) Enter("MIN", D_STDFUNC, NULLTYPE, S_MIN);
(void) Enter("INCL", D_STDPROC, NULLTYPE, S_INCL);
(void) Enter("ABS", D_PROCEDURE, std_type, S_ABS);
(void) Enter("CAP", D_PROCEDURE, std_type, S_CAP);
(void) Enter("CHR", D_PROCEDURE, std_type, S_CHR);
(void) Enter("FLOAT", D_PROCEDURE, std_type, S_FLOAT);
(void) Enter("HIGH", D_PROCEDURE, std_type, S_HIGH);
(void) Enter("HALT", D_PROCEDURE, std_type, S_HALT);
(void) Enter("EXCL", D_PROCEDURE, std_type, S_EXCL);
(void) Enter("DEC", D_PROCEDURE, std_type, S_DEC);
(void) Enter("INC", D_PROCEDURE, std_type, S_INC);
(void) Enter("VAL", D_PROCEDURE, std_type, S_VAL);
(void) Enter("TRUNC", D_PROCEDURE, std_type, S_TRUNC);
(void) Enter("SIZE", D_PROCEDURE, std_type, S_SIZE);
(void) Enter("ORD", D_PROCEDURE, std_type, S_ORD);
(void) Enter("ODD", D_PROCEDURE, std_type, S_ODD);
(void) Enter("MAX", D_PROCEDURE, std_type, S_MAX);
(void) Enter("MIN", D_PROCEDURE, std_type, S_MIN);
(void) Enter("INCL", D_PROCEDURE, std_type, S_INCL);
(void) Enter("CHAR", D_TYPE, char_type, 0);
(void) Enter("INTEGER", D_TYPE, int_type, 0);
@ -195,8 +195,8 @@ END SYSTEM.\n";
open_scope(CLOSEDSCOPE, 0);
(void) Enter("WORD", D_TYPE, word_type, 0);
(void) Enter("ADDRESS", D_TYPE, address_type, 0);
(void) Enter("ADR", D_STDFUNC, NULLTYPE, S_ADR);
(void) Enter("TSIZE", D_STDFUNC, NULLTYPE, S_TSIZE);
(void) Enter("ADR", D_PROCEDURE, std_type, S_ADR);
(void) Enter("TSIZE", D_PROCEDURE, std_type, S_TSIZE);
if (!InsertText(SYSTEM, strlen(SYSTEM))) {
fatal("Could not insert text");
}

18
lang/m2/comp/node.H
View file

@ -11,24 +11,16 @@ struct node {
#define Oper 2 /* binary operator */
#define Uoper 3 /* unary operator */
#define Call 4 /* cast or procedure - or function call */
#define Name 5 /* a qualident */
#define Name 5 /* an identifier */
#define Set 6 /* a set constant */
#define Xset 7 /* a set */
#define Def 8 /* an identified name */
#define Stat 9 /* a statement */
#define Link 11
struct type *nd_type; /* type of this node */
union {
struct token ndu_token; /* (Value, Oper, Uoper, Call, Name,
Link)
*/
arith *ndu_set; /* pointer to a set constant (Set) */
struct def *ndu_def; /* pointer to definition structure for
identified name (Def)
*/
} nd_val;
#define nd_token nd_val.ndu_token
#define nd_set nd_val.ndu_set
#define nd_def nd_val.ndu_def
struct token nd_token;
#define nd_set nd_token.tk_data.tk_set
#define nd_def nd_token.tk_data.tk_def
#define nd_symb nd_token.tk_symb
#define nd_lineno nd_token.tk_lineno
#define nd_filename nd_token.tk_filename

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

@ -47,6 +47,9 @@ ModuleDeclaration
df = define(id, CurrentScope, D_MODULE);
open_scope(CLOSEDSCOPE, 0);
df->mod_scope = CurrentScope->sc_scope;
df->df_type =
standard_type(RECORD, 0, (arith) 0);
df->df_type->rec_scope = df->mod_scope;
}
priority? ';'
import(1)*
@ -113,6 +116,8 @@ DefinitionModule
df = define(id, GlobalScope, D_MODULE);
if (!SYSTEMModule) open_scope(CLOSEDSCOPE, 0);
df->mod_scope = CurrentScope->sc_scope;
df->df_type = standard_type(RECORD, 0, (arith) 0);
df->df_type->rec_scope = df->mod_scope;
DefinitionModule = 1;
DO_DEBUG(1, debug("Definition module \"%s\"", id->id_text));
}

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

@ -10,7 +10,7 @@ static char *RcsId = "$Header$";
statement
{
struct node *nd1, *nd2;
struct node *nd1, *nd2 = 0;
} :
[
/*
@ -21,8 +21,12 @@ statement
designator(&nd1)
[
ActualParameters(&nd2)?
{ nd1 = MkNode(Call, nd1, nd2, &dot);
nd1->nd_symb = '(';
}
|
BECOMES expression(&nd2)
BECOMES { nd1 = MkNode(Stat, nd1, NULLNODE, &dot); }
expression(&(nd1->nd_right))
]
/*
* end of changed part

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

@ -80,6 +80,7 @@ extern struct type
*intorcard_type,
*string_type,
*bitset_type,
*std_type,
*error_type; /* All from type.c */
extern int
@ -105,6 +106,8 @@ extern arith
struct type
*create_type(),
*construct_type(),
*standard_type(); /* All from type.c */
*standard_type(),
*set_type(),
*subr_type(); /* All from type.c */
#define NULLTYPE ((struct type *) 0)

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

@ -49,6 +49,7 @@ struct type
*intorcard_type,
*string_type,
*bitset_type,
*std_type,
*error_type;
struct paramlist *h_paramlist;
@ -132,7 +133,8 @@ init_types()
char_type = standard_type(CHAR, 1, (arith) 1);
char_type->enm_ncst = 256;
bool_type = standard_type(BOOLEAN, 1, (arith) 1);
bool_type = standard_type(ENUMERATION, 1, (arith) 1);
bool_type->enm_ncst = 2;
int_type = standard_type(INTEGER, int_align, int_size);
longint_type = standard_type(LONGINT, lint_align, lint_size);
card_type = standard_type(CARDINAL, int_align, int_size);
@ -145,8 +147,8 @@ init_types()
tp = construct_type(SUBRANGE, int_type);
tp->sub_lb = 0;
tp->sub_ub = wrd_size * 8 - 1;
bitset_type = construct_type(SET, tp);
bitset_type->tp_size = wrd_size;
bitset_type = set_type(tp);
std_type = construct_type(PROCEDURE, NULLTYPE);
error_type = standard_type(ERRONEOUS, 1, (arith) 1);
}