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-10 01:08:49 +00:00
parent d1a2112163
commit ba47f9fe7c
11 changed files with 287 additions and 187 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -8,18 +8,18 @@ static char *RcsId = "$Header$";
#include <em_label.h> #include <em_label.h>
#include <assert.h> #include <assert.h>
#include <alloc.h> #include <alloc.h>
#include "Lpars.h"
#include "idf.h" #include "idf.h"
#include "type.h" #include "type.h"
#include "def.h" #include "def.h"
#include "LLlex.h" #include "LLlex.h"
#include "node.h" #include "node.h"
#include "Lpars.h"
#include "scope.h" #include "scope.h"
#include "const.h" #include "const.h"
#include "standards.h" #include "standards.h"
int int
chk_expr(expp, const) chk_expr(expp)
register struct node *expp; register struct node *expp;
{ {
/* Check the expression indicated by expp for semantic errors, /* Check the expression indicated by expp for semantic errors,
@ -29,12 +29,12 @@ chk_expr(expp, const)
switch(expp->nd_class) { switch(expp->nd_class) {
case Oper: case Oper:
return chk_expr(expp->nd_left, const) && return chk_expr(expp->nd_left) &&
chk_expr(expp->nd_right, const) && chk_expr(expp->nd_right) &&
chk_oper(expp, const); chk_oper(expp);
case Uoper: case Uoper:
return chk_expr(expp->nd_right, const) && return chk_expr(expp->nd_right) &&
chk_uoper(expp, const); chk_uoper(expp);
case Value: case Value:
switch(expp->nd_symb) { switch(expp->nd_symb) {
case REAL: case REAL:
@ -46,13 +46,13 @@ chk_expr(expp, const)
} }
break; break;
case Xset: case Xset:
return chk_set(expp, const); return chk_set(expp);
case Name: case Name:
return chk_name(expp, const); return chk_name(expp);
case Call: case Call:
return chk_call(expp, const); return chk_call(expp);
case Link: case Link:
return chk_name(expp, const); return chk_name(expp);
default: default:
assert(0); assert(0);
} }
@ -60,7 +60,7 @@ chk_expr(expp, const)
} }
int int
chk_set(expp, const) chk_set(expp)
register struct node *expp; register struct node *expp;
{ {
/* Check the legality of a SET aggregate, and try to evaluate it /* Check the legality of a SET aggregate, and try to evaluate it
@ -82,7 +82,7 @@ chk_set(expp, const)
assert(expp->nd_left->nd_class == Def); assert(expp->nd_left->nd_class == Def);
df = expp->nd_left->nd_def; df = expp->nd_left->nd_def;
if ((df->df_kind != D_TYPE && df->df_kind != D_ERROR) || if ((df->df_kind != D_TYPE && df->df_kind != D_ERROR) ||
(df->df_type->tp_fund != SET)) { (df->df_type->tp_fund != T_SET)) {
node_error(expp, "Illegal set type"); node_error(expp, "Illegal set type");
return 0; return 0;
} }
@ -96,11 +96,10 @@ chk_set(expp, const)
nd = expp->nd_right; nd = expp->nd_right;
while (nd) { while (nd) {
assert(nd->nd_class == Link && nd->nd_symb == ','); assert(nd->nd_class == Link && nd->nd_symb == ',');
if (!chk_el(nd->nd_left, const, tp->next, &set)) return 0; if (!chk_el(nd->nd_left, tp->next, &set)) return 0;
nd = nd->nd_right; nd = nd->nd_right;
} }
expp->nd_type = tp; expp->nd_type = tp;
assert(!const || set);
if (set) { if (set) {
/* Yes, in was a constant set, and we managed to compute it! /* Yes, in was a constant set, and we managed to compute it!
*/ */
@ -114,7 +113,7 @@ chk_set(expp, const)
} }
int int
chk_el(expp, const, tp, set) chk_el(expp, tp, set)
register struct node *expp; register struct node *expp;
struct type *tp; struct type *tp;
arith **set; arith **set;
@ -127,8 +126,8 @@ chk_el(expp, const, tp, set)
/* { ... , expr1 .. expr2, ... } /* { ... , expr1 .. expr2, ... }
First check expr1 and expr2, and try to compute them. First check expr1 and expr2, and try to compute them.
*/ */
if (!chk_el(expp->nd_left, const, tp, set) || if (!chk_el(expp->nd_left, tp, set) ||
!chk_el(expp->nd_right, const, tp, set)) { !chk_el(expp->nd_right, tp, set)) {
return 0; return 0;
} }
if (expp->nd_left->nd_class == Value && if (expp->nd_left->nd_class == Value &&
@ -157,7 +156,7 @@ node_error(expp, "Lower bound exceeds upper bound in range");
/* Here, a single element is checked /* Here, a single element is checked
*/ */
if (!chk_expr(expp, const)) { if (!chk_expr(expp)) {
return rem_set(set); return rem_set(set);
} }
if (!TstCompat(tp, expp->nd_type)) { if (!TstCompat(tp, expp->nd_type)) {
@ -165,10 +164,10 @@ node_error(expp, "Lower bound exceeds upper bound in range");
return rem_set(set); return rem_set(set);
} }
if (expp->nd_class == Value) { if (expp->nd_class == Value) {
if ((tp->tp_fund != ENUMERATION && if ((tp->tp_fund != T_ENUMERATION &&
(expp->nd_INT < tp->sub_lb || expp->nd_INT > tp->sub_ub)) (expp->nd_INT < tp->sub_lb || expp->nd_INT > tp->sub_ub))
|| ||
(tp->tp_fund == ENUMERATION && (tp->tp_fund == T_ENUMERATION &&
(expp->nd_INT < 0 || expp->nd_INT > tp->enm_ncst)) (expp->nd_INT < 0 || expp->nd_INT > tp->enm_ncst))
) { ) {
node_error(expp, "Set element out of range"); node_error(expp, "Set element out of range");
@ -193,12 +192,52 @@ rem_set(set)
return 0; return 0;
} }
struct node *
getarg(argp, bases)
struct node *argp;
{
struct type *tp;
if (!argp->nd_right) {
node_error(argp, "Too few arguments supplied");
return 0;
}
argp = argp->nd_right;
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");
return 0;
}
return argp;
}
struct node *
getname(argp, kinds)
struct node *argp;
{
if (!argp->nd_right) {
node_error(argp, "Too few arguments supplied");
return 0;
}
argp = argp->nd_right;
if (!findname(argp->nd_left)) return 0;
assert(argp->nd_left->nd_class == Def);
if (!(argp->nd_left->nd_def->df_kind & kinds)) {
node_error(argp, "Unexpected type");
return 0;
}
return argp;
}
int int
chk_call(expp, const) chk_call(expp)
register struct node *expp; register struct node *expp;
{ {
register struct type *tp; register struct type *tp;
register struct node *left; register struct node *left;
register struct node *arg;
expp->nd_type = error_type; expp->nd_type = error_type;
(void) findname(expp->nd_left); (void) findname(expp->nd_left);
@ -211,57 +250,148 @@ chk_call(expp, const)
/* A type cast. This is of course not portable. /* A type cast. This is of course not portable.
No runtime action. Remove it. No runtime action. Remove it.
*/ */
if (!expp->nd_right || arg = expp->nd_right;
(expp->nd_right->nd_symb == ',')) { 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; return 0;
} }
if (! chk_expr(expp->nd_right, const)) return 0; if (! chk_expr(arg->nd_left)) return 0;
if (expp->nd_right->nd_type->tp_size != if (arg->nd_left->nd_type->tp_size !=
left->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; return 0;
} }
expp->nd_right->nd_type = left->nd_type; arg->nd_left->nd_type = left->nd_type;
left = expp->nd_right;
FreeNode(expp->nd_left); FreeNode(expp->nd_left);
*expp = *(expp->nd_right); *expp = *(arg->nd_left);
left->nd_left = left->nd_right = 0; arg->nd_left->nd_left = 0;
FreeNode(left); arg->nd_left->nd_right = 0;
FreeNode(arg);
return 1; return 1;
} }
if ((left->nd_class == Def && left->nd_def->df_kind == D_PROCEDURE) || if ((left->nd_class == Def && left->nd_def->df_kind == D_PROCEDURE) ||
tp->tp_fund == PROCVAR) { tp->tp_fund == T_PROCEDURE) {
/* A procedure call. it may also be a call to a /* A procedure call. it may also be a call to a
standard procedure standard procedure
*/ */
arg = expp;
if (tp == std_type) { if (tp == std_type) {
assert(left->nd_class == Def); assert(left->nd_class == Def);
switch(left->nd_def->df_value.df_stdname) { switch(left->nd_def->df_value.df_stdname) {
case S_ABS: case S_ABS:
arg = getarg(arg, T_INTEGER|T_CARDINAL|T_REAL);
if (! arg) return 0;
expp->nd_type = arg->nd_left->nd_type;
break;
case S_CAP: case S_CAP:
arg = getarg(arg, T_CHAR);
expp->nd_type = char_type;
if (!arg) return 0;
break;
case S_CHR: case S_CHR:
arg = getarg(arg, T_INTEGER|T_CARDINAL);
expp->nd_type = char_type;
if (!arg) return 0;
break;
case S_FLOAT: case S_FLOAT:
arg = getarg(arg, T_CARDINAL|T_INTEGER);
expp->nd_type = real_type;
if (!arg) return 0;
break;
case S_HIGH: case S_HIGH:
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;
break;
case S_MAX: case S_MAX:
case S_MIN: case S_MIN:
arg = getarg(arg, T_ENUMERATION|T_CHAR|T_INTEGER|T_CARDINAL);
if (!arg) return 0;
expp->nd_type = arg->nd_left->nd_type;
break;
case S_ODD: case S_ODD:
arg = getarg(arg, T_INTEGER|T_CARDINAL);
if (!arg) return 0;
expp->nd_type = bool_type;
break;
case S_ORD: case S_ORD:
arg = getarg(arg, T_ENUMERATION|T_CHAR|T_INTEGER|T_CARDINAL);
if (!arg) return 0;
expp->nd_type = card_type;
break;
case S_TSIZE: /* ??? */
case S_SIZE: 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;
break;
case S_TRUNC: case S_TRUNC:
arg = getarg(arg, T_REAL);
if (!arg) return 0;
expp->nd_type = card_type;
break;
case S_VAL: case S_VAL:
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))) {
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);
if (!arg) return 0;
break;
case S_ADR:
arg = getname(arg, D_VARIABLE|D_FIELD|D_PROCEDURE);
expp->nd_type = address_type;
if (!arg) return 0;
break; break;
case S_DEC: case S_DEC:
case S_INC: case S_INC:
expp->nd_type = 0;
arg = getname(arg, D_VARIABLE|D_FIELD);
if (!arg) return 0;
if (arg->nd_right) {
arg = getarg(arg, T_INTEGER|T_CARDINAL);
if (!arg) return 0;
}
break;
case S_HALT: case S_HALT:
expp->nd_type = 0;
break;
case S_EXCL: case S_EXCL:
case S_INCL: case S_INCL:
expp->nd_type = 0; expp->nd_type = 0;
arg = getname(arg, D_VARIABLE|D_FIELD);
if (!arg) return 0;
tp = arg->nd_left->nd_type;
if (tp->tp_fund != T_SET) {
node_error(arg, "EXCL and INCL expect a SET parameter");
return 0;
}
arg = getarg(arg, T_INTEGER|T_CARDINAL|T_CHAR|T_ENUMERATION);
if (!arg) return 0;
if (!TstCompat(tp->next, arg->nd_left->nd_type)) {
node_error(arg, "Unexpected type");
return 0;
}
break; break;
default: default:
assert(0); assert(0);
} }
if (arg->nd_right) {
node_error(arg->nd_right,
"Too many parameters supplied");
return 0;
}
FreeNode(expp->nd_left);
expp->nd_left = 0;
return 1; return 1;
} }
return 1; return 1;
@ -297,7 +427,7 @@ findname(expp)
if (tp == error_type) { if (tp == error_type) {
df = ill_df; df = ill_df;
} }
else if (tp->tp_fund != RECORD) { else if (tp->tp_fund != T_RECORD) {
/* This is also true for modules */ /* This is also true for modules */
node_error(expp,"Illegal selection"); node_error(expp,"Illegal selection");
df = ill_df; df = ill_df;
@ -341,18 +471,15 @@ df->df_idf->id_text);
} }
int int
chk_name(expp, const) chk_name(expp)
register struct node *expp; register struct node *expp;
{ {
register struct def *df; register struct def *df;
int retval = 1;
(void) findname(expp); (void) findname(expp);
assert(expp->nd_class == Def); assert(expp->nd_class == Def);
df = expp->nd_def; df = expp->nd_def;
if (df->df_kind == D_ERROR) { if (df->df_kind == D_ERROR) return 0;
retval = 0;
}
if (df->df_kind & (D_ENUM | D_CONST)) { if (df->df_kind & (D_ENUM | D_CONST)) {
if (df->df_kind == D_ENUM) { if (df->df_kind == D_ENUM) {
expp->nd_class = Value; expp->nd_class = Value;
@ -363,20 +490,14 @@ chk_name(expp, const)
*expp = *(df->con_const); *expp = *(df->con_const);
} }
} }
else if (const) { return 1;
node_error(expp, "constant expected");
retval = 0;
}
return retval;
} }
int int
chk_oper(expp, const) chk_oper(expp)
register struct node *expp; register struct node *expp;
{ {
/* Check a binary operation. If "const" is set, also check /* Check a binary operation.
that it is constant.
The code is ugly !
*/ */
register struct type *tpl = expp->nd_left->nd_type; register struct type *tpl = expp->nd_left->nd_type;
register struct type *tpr = expp->nd_right->nd_type; register struct type *tpr = expp->nd_right->nd_type;
@ -398,7 +519,7 @@ chk_oper(expp, const)
if (expp->nd_symb == IN) { if (expp->nd_symb == IN) {
/* Handle this one specially */ /* Handle this one specially */
expp->nd_type = bool_type; expp->nd_type = bool_type;
if (tpr->tp_fund != SET) { if (tpr->tp_fund != T_SET) {
node_error(expp, "RHS of IN operator not a SET type"); node_error(expp, "RHS of IN operator not a SET type");
return 0; return 0;
} }
@ -411,7 +532,7 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
if (expp->nd_symb == '[') { if (expp->nd_symb == '[') {
/* Handle ARRAY selection specially too! */ /* Handle ARRAY selection specially too! */
if (tpl->tp_fund != ARRAY) { 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; return 0;
} }
@ -420,11 +541,10 @@ node_error(expp, "incompatible index type");
return 0; return 0;
} }
expp->nd_type = tpl->arr_elem; expp->nd_type = tpl->arr_elem;
if (const) return 0;
return 1; return 1;
} }
if (tpl->tp_fund == SUBRANGE) tpl = tpl->next; if (tpl->tp_fund == T_SUBRANGE) tpl = tpl->next;
expp->nd_type = tpl; expp->nd_type = tpl;
if (!TstCompat(tpl, tpr)) { if (!TstCompat(tpl, tpr)) {
@ -437,49 +557,35 @@ node_error(expp, "Incompatible types for operator \"%s\"", symbol2str(expp->nd_s
case '-': case '-':
case '*': case '*':
switch(tpl->tp_fund) { switch(tpl->tp_fund) {
case INTEGER: case T_INTEGER:
case INTORCARD: case T_CARDINAL:
case CARDINAL: case T_SET:
case LONGINT:
case SET:
if (expp->nd_left->nd_class == Value && if (expp->nd_left->nd_class == Value &&
expp->nd_right->nd_class == Value) { expp->nd_right->nd_class == Value) {
cstbin(expp); cstbin(expp);
} }
return 1; return 1;
case REAL: case T_REAL:
case LONGREAL:
if (const) {
errval = 2;
break;
}
return 1; return 1;
} }
break; break;
case '/': case '/':
switch(tpl->tp_fund) { switch(tpl->tp_fund) {
case SET: case T_SET:
if (expp->nd_left->nd_class == Value && if (expp->nd_left->nd_class == Value &&
expp->nd_right->nd_class == Value) { expp->nd_right->nd_class == Value) {
cstbin(expp); cstbin(expp);
} }
return 1; return 1;
case REAL: case T_REAL:
case LONGREAL:
if (const) {
errval = 2;
break;
}
return 1; return 1;
} }
break; break;
case DIV: case DIV:
case MOD: case MOD:
switch(tpl->tp_fund) { switch(tpl->tp_fund) {
case INTEGER: case T_INTEGER:
case INTORCARD: case T_CARDINAL:
case CARDINAL:
case LONGINT:
if (expp->nd_left->nd_class == Value && if (expp->nd_left->nd_class == Value &&
expp->nd_right->nd_class == Value) { expp->nd_right->nd_class == Value) {
cstbin(expp); cstbin(expp);
@ -505,32 +611,30 @@ node_error(expp, "Incompatible types for operator \"%s\"", symbol2str(expp->nd_s
case '<': case '<':
case '>': case '>':
switch(tpl->tp_fund) { switch(tpl->tp_fund) {
case SET: case T_SET:
if (expp->nd_symb == '<' || expp->nd_symb == '>') { if (expp->nd_symb == '<' || expp->nd_symb == '>') {
break; break;
} }
case INTEGER: if (expp->nd_left->nd_class == Set &&
case INTORCARD: expp->nd_right->nd_class == Set) {
case LONGINT: cstbin(expp);
case CARDINAL: }
case ENUMERATION: /* includes boolean */ return 1;
case CHAR: case T_INTEGER:
case T_CARDINAL:
case T_ENUMERATION: /* includes boolean */
case T_CHAR:
if (expp->nd_left->nd_class == Value && if (expp->nd_left->nd_class == Value &&
expp->nd_right->nd_class == Value) { expp->nd_right->nd_class == Value) {
cstbin(expp); cstbin(expp);
} }
return 1; return 1;
case POINTER: case T_POINTER:
if (!(expp->nd_symb == '=' || expp->nd_symb == '#')) { if (!(expp->nd_symb == '=' || expp->nd_symb == '#')) {
break; break;
} }
/* Fall through */ /* Fall through */
case REAL: case T_REAL:
case LONGREAL:
if (const) {
errval = 2;
break;
}
return 1; return 1;
} }
default: default:
@ -540,37 +644,32 @@ node_error(expp, "Incompatible types for operator \"%s\"", symbol2str(expp->nd_s
case 1: 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; break;
case 2:
node_error(expp, "Expression not constant");
break;
case 3: case 3:
node_error(expp, "BOOLEAN type(s) expected"); node_error(expp, "BOOLEAN type(s) expected");
break; break;
default:
assert(0);
} }
return 0; return 0;
} }
int int
chk_uoper(expp, const) chk_uoper(expp)
register struct node *expp; register struct node *expp;
{ {
/* Check an unary operation. If "const" is set, also check that /* Check an unary operation.
it can be evaluated compile-time.
*/ */
register struct type *tpr = expp->nd_right->nd_type; register struct type *tpr = expp->nd_right->nd_type;
if (tpr->tp_fund == SUBRANGE) tpr = tpr->next; if (tpr->tp_fund == T_SUBRANGE) tpr = tpr->next;
expp->nd_type = tpr; expp->nd_type = tpr;
switch(expp->nd_symb) { switch(expp->nd_symb) {
case '+': case '+':
switch(tpr->tp_fund) { switch(tpr->tp_fund) {
case INTEGER: case T_INTEGER:
case LONGINT: case T_REAL:
case REAL: case T_CARDINAL:
case LONGREAL:
case CARDINAL:
case INTORCARD:
expp->nd_token = expp->nd_right->nd_token; expp->nd_token = expp->nd_right->nd_token;
FreeNode(expp->nd_right); FreeNode(expp->nd_right);
expp->nd_right = 0; expp->nd_right = 0;
@ -579,15 +678,12 @@ chk_uoper(expp, const)
break; break;
case '-': case '-':
switch(tpr->tp_fund) { switch(tpr->tp_fund) {
case INTEGER: case T_INTEGER:
case LONGINT:
case INTORCARD:
if (expp->nd_right->nd_class == Value) { if (expp->nd_right->nd_class == Value) {
cstunary(expp); cstunary(expp);
} }
return 1; return 1;
case REAL: case T_REAL:
case LONGREAL:
if (expp->nd_right->nd_class == Value) { if (expp->nd_right->nd_class == Value) {
expp->nd_token = expp->nd_right->nd_token; expp->nd_token = expp->nd_right->nd_token;
if (*(expp->nd_REL) == '-') { if (*(expp->nd_REL) == '-') {
@ -609,9 +705,8 @@ chk_uoper(expp, const)
} }
break; break;
case '^': case '^':
if (tpr->tp_fund != POINTER) break; if (tpr->tp_fund != T_POINTER) break;
expp->nd_type = tpr->next; expp->nd_type = tpr->next;
if (const) return 0;
return 1; return 1;
default: default:
assert(0); assert(0);

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

@ -60,7 +60,7 @@ cstbin(expp)
int uns = expp->nd_type != int_type; int uns = expp->nd_type != int_type;
assert(expp->nd_class == Oper); assert(expp->nd_class == Oper);
if (expp->nd_right->nd_type->tp_fund == SET) { if (expp->nd_right->nd_type->tp_fund == T_SET) {
cstset(expp); cstset(expp);
return; return;
} }

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

@ -56,7 +56,7 @@ ProcedureHeading(struct def **pdf; int type;)
} }
FormalParameters(type == D_PROCEDURE, &params, &tp)? FormalParameters(type == D_PROCEDURE, &params, &tp)?
{ {
df->df_type = tp = construct_type(PROCEDURE, tp); df->df_type = tp = construct_type(T_PROCEDURE, tp);
tp->prc_params = params; tp->prc_params = params;
if (tp1 && !TstTypeEquiv(tp, tp1)) { if (tp1 && !TstTypeEquiv(tp, tp1)) {
error("inconsistent procedure declaration for \"%s\"", df->df_idf->id_text); error("inconsistent procedure declaration for \"%s\"", df->df_idf->id_text);
@ -137,7 +137,7 @@ FormalType(struct type **tp;)
]? ]?
qualident(D_TYPE | D_HTYPE, &df, "type", (struct node **) 0) qualident(D_TYPE | D_HTYPE, &df, "type", (struct node **) 0)
{ if (ARRAYflag) { { if (ARRAYflag) {
*tp = construct_type(ARRAY, NULLTYPE); *tp = construct_type(T_ARRAY, NULLTYPE);
(*tp)->arr_elem = df->df_type; (*tp)->arr_elem = df->df_type;
} }
else *tp = df->df_type; else *tp = df->df_type;
@ -153,12 +153,12 @@ TypeDeclaration
'=' type(&tp) '=' type(&tp)
{ df->df_type = tp; { df->df_type = tp;
if ((df->df_flags&D_EXPORTED) && if ((df->df_flags&D_EXPORTED) &&
tp->tp_fund == ENUMERATION) { tp->tp_fund == T_ENUMERATION) {
exprt_literals(tp->enm_enums, exprt_literals(tp->enm_enums,
enclosing(CurrentScope)); enclosing(CurrentScope));
} }
if (df->df_kind == D_HTYPE && if (df->df_kind == D_HTYPE &&
tp->tp_fund != POINTER) { tp->tp_fund != T_POINTER) {
error("Opaque type \"%s\" is not a pointer type", df->df_idf->id_text); error("Opaque type \"%s\" is not a pointer type", df->df_idf->id_text);
} }
@ -207,11 +207,11 @@ enumeration(struct type **ptp;)
struct node *EnumList; struct node *EnumList;
} : } :
'(' IdentList(&EnumList) ')' '(' IdentList(&EnumList) ')'
{ {
*ptp = standard_type(ENUMERATION,int_align,int_size); *ptp = standard_type(T_ENUMERATION,int_align,int_size);
EnterIdList(EnumList, D_ENUM, 0, *ptp, CurrentScope); EnterIdList(EnumList, D_ENUM, 0, *ptp, CurrentScope);
FreeNode(EnumList); FreeNode(EnumList);
} }
; ;
@ -252,12 +252,12 @@ ArrayType(struct type **ptp;)
} : } :
ARRAY SimpleType(&tp) ARRAY SimpleType(&tp)
{ {
*ptp = tp2 = construct_type(ARRAY, tp); *ptp = tp2 = construct_type(T_ARRAY, tp);
} }
[ [
',' SimpleType(&tp) ',' SimpleType(&tp)
{ tp2 = tp2->arr_elem = { tp2 = tp2->arr_elem =
construct_type(ARRAY, tp); construct_type(T_ARRAY, tp);
} }
]* OF type(&tp) ]* OF type(&tp)
{ tp2->arr_elem = tp; } { tp2->arr_elem = tp; }
@ -273,10 +273,10 @@ RecordType(struct type **ptp;)
scope.next = CurrentScope; scope.next = CurrentScope;
} }
FieldListSequence(&scope) FieldListSequence(&scope)
{ {
*ptp = standard_type(RECORD, record_align, (arith) 0 /* ???? */); *ptp = standard_type(T_RECORD, record_align, (arith) 0 /* ???? */);
(*ptp)->rec_scope = scope.sc_scope; (*ptp)->rec_scope = scope.sc_scope;
} }
END END
; ;
@ -380,7 +380,7 @@ PointerType(struct type **ptp;)
{ tp = NULLTYPE; } { tp = NULLTYPE; }
] ]
{ {
*ptp = construct_type(POINTER, tp); *ptp = construct_type(T_POINTER, tp);
if (!tp) Forward(&dot, &((*ptp)->next)); if (!tp) Forward(&dot, &((*ptp)->next));
} }
; ;
@ -391,7 +391,7 @@ ProcedureType(struct type **ptp;)
struct type *tp = 0; struct type *tp = 0;
} : } :
PROCEDURE FormalTypeList(&pr, &tp)? PROCEDURE FormalTypeList(&pr, &tp)?
{ *ptp = construct_type(PROCVAR, tp); { *ptp = construct_type(T_PROCEDURE, tp);
(*ptp)->prc_params = pr; (*ptp)->prc_params = pr;
} }
; ;

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

@ -204,7 +204,7 @@ ids->nd_IDF->id_text);
DO_DEBUG(2, debug("importing \"%s\", kind %d", ids->nd_IDF->id_text, df->df_kind)); DO_DEBUG(2, debug("importing \"%s\", kind %d", ids->nd_IDF->id_text, df->df_kind));
define(ids->nd_IDF, CurrentScope, kind)->imp_def = df; define(ids->nd_IDF, CurrentScope, kind)->imp_def = df;
if (df->df_kind == D_TYPE && if (df->df_kind == D_TYPE &&
df->df_type->tp_fund == ENUMERATION) { df->df_type->tp_fund == T_ENUMERATION) {
/* Also import all enumeration literals */ /* Also import all enumeration literals */
exprt_literals(df->df_type->enm_enums, exprt_literals(df->df_type->enm_enums,
CurrentScope); CurrentScope);

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

@ -68,12 +68,15 @@ ExpList(struct node **pnd;)
{ {
struct node **nd; struct node **nd;
} : } :
expression(pnd) { nd = pnd; } expression(pnd) { *pnd = MkNode(Link, *pnd, NULLNODE, &dot);
[ (*pnd)->nd_symb = ',';
',' { *nd = MkNode(Link, *nd, NULLNODE, &dot); nd = &((*pnd)->nd_right);
nd = &(*nd)->nd_right;
} }
expression(nd) [
',' { *nd = MkNode(Link, NULLNODE, NULLNODE, &dot);
}
expression(&(*nd)->nd_left)
{ nd = &((*pnd)->nd_right); }
]* ]*
; ;
@ -86,7 +89,10 @@ ConstExpression(struct node **pnd;):
{ DO_DEBUG(3, { DO_DEBUG(3,
( debug("Constant expression:"), ( debug("Constant expression:"),
PrNode(*pnd))); PrNode(*pnd)));
(void) chk_expr(*pnd, 1); if (chk_expr(*pnd) &&
((*pnd)->nd_class != Set && (*pnd)->nd_class != Value)) {
error("Constant expression expected");
}
DO_DEBUG(3, PrNode(*pnd)); DO_DEBUG(3, PrNode(*pnd));
} }
; ;

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

@ -156,7 +156,7 @@ add_standards()
(void) Enter("NIL", D_CONST, address_type, 0); (void) Enter("NIL", D_CONST, address_type, 0);
(void) Enter("PROC", (void) Enter("PROC",
D_TYPE, D_TYPE,
construct_type(PROCEDURE, NULLTYPE), construct_type(T_PROCEDURE, NULLTYPE),
0); 0);
df = Enter("BITSET", D_TYPE, bitset_type, 0); df = Enter("BITSET", D_TYPE, bitset_type, 0);
df = Enter("FALSE", D_ENUM, bool_type, 0); df = Enter("FALSE", D_ENUM, bool_type, 0);

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

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

12
lang/m2/comp/tokenname.c
View file

@ -76,22 +76,10 @@ struct tokenname tkidf[] = { /* names of the identifier tokens */
struct tokenname tkinternal[] = { /* internal keywords */ struct tokenname tkinternal[] = { /* internal keywords */
{PROGRAM, ""}, {PROGRAM, ""},
{SUBRANGE, ""},
{ENUMERATION, ""},
{ERRONEOUS, ""},
{PROCVAR, ""},
{INTORCARD, ""},
{0, "0"} {0, "0"}
}; };
struct tokenname tkstandard[] = { /* standard identifiers */ struct tokenname tkstandard[] = { /* standard identifiers */
{CHAR, ""},
{BOOLEAN, ""},
{LONGINT, ""},
{CARDINAL, ""},
{LONGREAL, ""},
{WORD, ""},
{ADDRESS, ""},
{0, ""} {0, ""}
}; };

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

@ -53,9 +53,23 @@ struct type {
SUBRANGE SUBRANGE
*/ */
int tp_fund; /* fundamental type or constructor */ int tp_fund; /* fundamental type or constructor */
#define T_RECORD 0x0001
#define T_ENUMERATION 0x0002
#define T_INTEGER 0x0004
#define T_CARDINAL 0x0008
/* #define T_LONGINT 0x0010 */
#define T_REAL 0x0020
/* #define T_LONGREAL 0x0040 */
#define T_POINTER 0x0080
#define T_CHAR 0x0100
#define T_WORD 0x0200
#define T_SET 0x0400
#define T_SUBRANGE 0x0800
#define T_PROCEDURE 0x1000
#define T_ARRAY 0x2000
#define T_STRING 0x4000
int tp_align; /* alignment requirement of this type */ int tp_align; /* alignment requirement of this type */
arith tp_size; /* size of this type */ arith tp_size; /* size of this type */
/* struct idf *tp_idf; /* name of this type */
union { union {
struct enume tp_enum; struct enume tp_enum;
struct subrange tp_subrange; struct subrange tp_subrange;

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

@ -82,21 +82,21 @@ construct_type(fund, tp)
struct type *dtp = create_type(fund); struct type *dtp = create_type(fund);
switch (fund) { switch (fund) {
case PROCEDURE: case T_PROCEDURE:
case POINTER: case T_POINTER:
dtp->tp_align = ptr_align; dtp->tp_align = ptr_align;
dtp->tp_size = ptr_size; dtp->tp_size = ptr_size;
dtp->next = tp; dtp->next = tp;
break; break;
case SET: case T_SET:
dtp->tp_align = wrd_align; dtp->tp_align = wrd_align;
dtp->next = tp; dtp->next = tp;
break; break;
case ARRAY: case T_ARRAY:
dtp->tp_align = tp->tp_align; dtp->tp_align = tp->tp_align;
dtp->next = tp; dtp->next = tp;
break; break;
case SUBRANGE: case T_SUBRANGE:
dtp->tp_align = tp->tp_align; dtp->tp_align = tp->tp_align;
dtp->tp_size = tp->tp_size; dtp->tp_size = tp->tp_size;
dtp->next = tp; dtp->next = tp;
@ -131,25 +131,25 @@ init_types()
{ {
register struct type *tp; register struct type *tp;
char_type = standard_type(CHAR, 1, (arith) 1); char_type = standard_type(T_CHAR, 1, (arith) 1);
char_type->enm_ncst = 256; char_type->enm_ncst = 256;
bool_type = standard_type(ENUMERATION, 1, (arith) 1); bool_type = standard_type(T_ENUMERATION, 1, (arith) 1);
bool_type->enm_ncst = 2; bool_type->enm_ncst = 2;
int_type = standard_type(INTEGER, int_align, int_size); int_type = standard_type(T_INTEGER, int_align, int_size);
longint_type = standard_type(LONGINT, lint_align, lint_size); longint_type = standard_type(T_INTEGER, lint_align, lint_size);
card_type = standard_type(CARDINAL, int_align, int_size); card_type = standard_type(T_CARDINAL, int_align, int_size);
real_type = standard_type(REAL, real_align, real_size); real_type = standard_type(T_REAL, real_align, real_size);
longreal_type = standard_type(LONGREAL, lreal_align, lreal_size); longreal_type = standard_type(T_REAL, lreal_align, lreal_size);
word_type = standard_type(WORD, wrd_align, wrd_size); word_type = standard_type(T_WORD, wrd_align, wrd_size);
intorcard_type = standard_type(INTORCARD, int_align, int_size); intorcard_type = standard_type(T_INTEGER, int_align, int_size);
string_type = standard_type(STRING, 1, (arith) -1); string_type = standard_type(T_STRING, 1, (arith) -1);
address_type = construct_type(POINTER, word_type); address_type = construct_type(T_POINTER, word_type);
tp = construct_type(SUBRANGE, int_type); tp = construct_type(T_SUBRANGE, int_type);
tp->sub_lb = 0; tp->sub_lb = 0;
tp->sub_ub = wrd_size * 8 - 1; tp->sub_ub = wrd_size * 8 - 1;
bitset_type = set_type(tp); bitset_type = set_type(tp);
std_type = construct_type(PROCEDURE, NULLTYPE); std_type = construct_type(T_PROCEDURE, NULLTYPE);
error_type = standard_type(ERRONEOUS, 1, (arith) 1); error_type = standard_type(T_CHAR, 1, (arith) 1);
} }
int int
@ -160,14 +160,11 @@ has_selectors(df)
switch(df->df_kind) { switch(df->df_kind) {
case D_MODULE: case D_MODULE:
return df->df_value.df_module.mo_scope; return df->df_value.df_module.mo_scope;
case D_VARIABLE: { case D_VARIABLE:
register struct type *tp = df->df_type; if (df->df_type->tp_fund == T_RECORD) {
return df->df_type->rec_scope;
if (tp->tp_fund == RECORD) {
return tp->rec_scope;
} }
break; break;
}
} }
error("no selectors for \"%s\"", df->df_idf->id_text); error("no selectors for \"%s\"", df->df_idf->id_text);
return 0; return 0;
@ -205,7 +202,7 @@ ParamList(ids, tp, VARp)
chk_basesubrange(tp, base) chk_basesubrange(tp, base)
register struct type *tp, *base; register struct type *tp, *base;
{ {
if (base->tp_fund == SUBRANGE) { if (base->tp_fund == T_SUBRANGE) {
/* Check that the bounds of "tp" fall within the range /* Check that the bounds of "tp" fall within the range
of "base" of "base"
*/ */
@ -214,7 +211,7 @@ chk_basesubrange(tp, base)
} }
base = base->next; base = base->next;
} }
if (base->tp_fund == ENUMERATION || base->tp_fund == CHAR) { if (base->tp_fund == T_ENUMERATION || base->tp_fund == T_CHAR) {
if (tp->next != base) { if (tp->next != base) {
error("Specified base does not conform"); error("Specified base does not conform");
} }
@ -247,13 +244,13 @@ subr_type(lb, ub)
return error_type; return error_type;
} }
if (tp->tp_fund == SUBRANGE) tp = tp->next; if (tp->tp_fund == T_SUBRANGE) tp = tp->next;
if (tp == intorcard_type) tp = card_type; /* lower bound > 0 */ if (tp == intorcard_type) tp = card_type; /* lower bound > 0 */
/* Check base type /* Check base type
*/ */
if (tp != int_type && tp != card_type && tp != char_type && if (tp != int_type && tp != card_type && tp != char_type &&
tp->tp_fund != ENUMERATION) { tp->tp_fund != T_ENUMERATION) {
/* BOOLEAN is also an ENUMERATION type /* BOOLEAN is also an ENUMERATION type
*/ */
node_error(ub, "Illegal base type for subrange"); node_error(ub, "Illegal base type for subrange");
@ -268,7 +265,7 @@ subr_type(lb, ub)
/* Now construct resulting type /* Now construct resulting type
*/ */
tp = construct_type(SUBRANGE, tp); tp = construct_type(T_SUBRANGE, tp);
tp->sub_lb = lb->nd_INT; tp->sub_lb = lb->nd_INT;
tp->sub_ub = ub->nd_INT; tp->sub_ub = ub->nd_INT;
DO_DEBUG(2,debug("Creating subrange type %ld-%ld", (long)lb->nd_INT,(long)ub->nd_INT)); DO_DEBUG(2,debug("Creating subrange type %ld-%ld", (long)lb->nd_INT,(long)ub->nd_INT));
@ -285,13 +282,13 @@ set_type(tp)
*/ */
int lb, ub; int lb, ub;
if (tp->tp_fund == SUBRANGE) { if (tp->tp_fund == T_SUBRANGE) {
if ((lb = tp->sub_lb) < 0 || (ub = tp->sub_ub) > MAX_SET - 1) { if ((lb = tp->sub_lb) < 0 || (ub = tp->sub_ub) > MAX_SET - 1) {
error("Set type limits exceeded"); error("Set type limits exceeded");
return error_type; return error_type;
} }
} }
else if (tp->tp_fund == ENUMERATION || tp == char_type) { else if (tp->tp_fund == T_ENUMERATION || tp == char_type) {
lb = 0; lb = 0;
if ((ub = tp->enm_ncst - 1) > MAX_SET - 1) { if ((ub = tp->enm_ncst - 1) > MAX_SET - 1) {
error("Set type limits exceeded"); error("Set type limits exceeded");
@ -302,7 +299,7 @@ set_type(tp)
error("illegal base type for set"); error("illegal base type for set");
return error_type; return error_type;
} }
tp = construct_type(SET, tp); tp = construct_type(T_SET, tp);
tp->tp_size = align(((ub - lb) + 7)/8, wrd_align); tp->tp_size = align(((ub - lb) + 7)/8, wrd_align);
return tp; return tp;
} }

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

@ -25,9 +25,9 @@ TstTypeEquiv(tp1, tp2)
tp2 == error_type tp2 == error_type
|| ||
( (
tp1 && tp1->tp_fund == PROCEDURE tp1 && tp1->tp_fund == T_PROCEDURE
&& &&
tp2 && tp2->tp_fund == PROCEDURE tp2 && tp2->tp_fund == T_PROCEDURE
&& &&
TstProcEquiv(tp1, tp2) TstProcEquiv(tp1, tp2)
); );
@ -65,8 +65,8 @@ TstCompat(tp1, tp2)
Modula-2 Report for a definition of "compatible". Modula-2 Report for a definition of "compatible".
*/ */
if (TstTypeEquiv(tp1, tp2)) return 1; if (TstTypeEquiv(tp1, tp2)) return 1;
if (tp1->tp_fund == SUBRANGE) tp1 = tp1->next; if (tp1->tp_fund == T_SUBRANGE) tp1 = tp1->next;
if (tp2->tp_fund == SUBRANGE) tp2 = tp2->next; if (tp2->tp_fund == T_SUBRANGE) tp2 = tp2->next;
return tp1 == tp2 return tp1 == tp2
|| ||
( tp1 == intorcard_type ( tp1 == intorcard_type
@ -83,7 +83,7 @@ TstCompat(tp1, tp2)
&& &&
( tp2 == card_type ( tp2 == card_type
|| tp2 == intorcard_type || tp2 == intorcard_type
|| tp2->tp_fund == POINTER || tp2->tp_fund == T_POINTER
) )
) )
|| ||
@ -91,7 +91,7 @@ TstCompat(tp1, tp2)
&& &&
( tp1 == card_type ( tp1 == card_type
|| tp1 == intorcard_type || tp1 == intorcard_type
|| tp1->tp_fund == POINTER || tp1->tp_fund == T_POINTER
) )
) )
; ;