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-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 <assert.h>
#include <alloc.h>
#include "Lpars.h"
#include "idf.h"
#include "type.h"
#include "def.h"
#include "LLlex.h"
#include "node.h"
#include "Lpars.h"
#include "scope.h"
#include "const.h"
#include "standards.h"
int
chk_expr(expp, const)
chk_expr(expp)
register struct node *expp;
{
/* Check the expression indicated by expp for semantic errors,
@ -29,12 +29,12 @@ chk_expr(expp, const)
switch(expp->nd_class) {
case Oper:
return chk_expr(expp->nd_left, const) &&
chk_expr(expp->nd_right, const) &&
chk_oper(expp, const);
return chk_expr(expp->nd_left) &&
chk_expr(expp->nd_right) &&
chk_oper(expp);
case Uoper:
return chk_expr(expp->nd_right, const) &&
chk_uoper(expp, const);
return chk_expr(expp->nd_right) &&
chk_uoper(expp);
case Value:
switch(expp->nd_symb) {
case REAL:
@ -46,13 +46,13 @@ chk_expr(expp, const)
}
break;
case Xset:
return chk_set(expp, const);
return chk_set(expp);
case Name:
return chk_name(expp, const);
return chk_name(expp);
case Call:
return chk_call(expp, const);
return chk_call(expp);
case Link:
return chk_name(expp, const);
return chk_name(expp);
default:
assert(0);
}
@ -60,7 +60,7 @@ chk_expr(expp, const)
}
int
chk_set(expp, const)
chk_set(expp)
register struct node *expp;
{
/* 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);
df = expp->nd_left->nd_def;
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");
return 0;
}
@ -96,11 +96,10 @@ chk_set(expp, const)
nd = expp->nd_right;
while (nd) {
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;
}
expp->nd_type = tp;
assert(!const || set);
if (set) {
/* Yes, in was a constant set, and we managed to compute it!
*/
@ -114,7 +113,7 @@ chk_set(expp, const)
}
int
chk_el(expp, const, tp, set)
chk_el(expp, tp, set)
register struct node *expp;
struct type *tp;
arith **set;
@ -127,8 +126,8 @@ chk_el(expp, const, tp, set)
/* { ... , 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)) {
if (!chk_el(expp->nd_left, tp, set) ||
!chk_el(expp->nd_right, tp, set)) {
return 0;
}
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
*/
if (!chk_expr(expp, const)) {
if (!chk_expr(expp)) {
return rem_set(set);
}
if (!TstCompat(tp, expp->nd_type)) {
@ -165,10 +164,10 @@ node_error(expp, "Lower bound exceeds upper bound in range");
return rem_set(set);
}
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))
||
(tp->tp_fund == ENUMERATION &&
(tp->tp_fund == T_ENUMERATION &&
(expp->nd_INT < 0 || expp->nd_INT > tp->enm_ncst))
) {
node_error(expp, "Set element out of range");
@ -193,12 +192,52 @@ rem_set(set)
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
chk_call(expp, const)
chk_call(expp)
register struct node *expp;
{
register struct type *tp;
register struct node *left;
register struct node *arg;
expp->nd_type = error_type;
(void) findname(expp->nd_left);
@ -211,57 +250,148 @@ chk_call(expp, const)
/* A type cast. This is of course not portable.
No runtime action. Remove it.
*/
if (!expp->nd_right ||
(expp->nd_right->nd_symb == ',')) {
arg = expp->nd_right;
if (!arg || arg->nd_right) {
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 !=
if (! chk_expr(arg->nd_left)) return 0;
if (arg->nd_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");
return 0;
}
expp->nd_right->nd_type = left->nd_type;
left = expp->nd_right;
arg->nd_left->nd_type = left->nd_type;
FreeNode(expp->nd_left);
*expp = *(expp->nd_right);
left->nd_left = left->nd_right = 0;
FreeNode(left);
*expp = *(arg->nd_left);
arg->nd_left->nd_left = 0;
arg->nd_left->nd_right = 0;
FreeNode(arg);
return 1;
}
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
standard procedure
*/
arg = expp;
if (tp == std_type) {
assert(left->nd_class == Def);
switch(left->nd_def->df_value.df_stdname) {
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:
arg = getarg(arg, T_CHAR);
expp->nd_type = char_type;
if (!arg) return 0;
break;
case S_CHR:
arg = getarg(arg, T_INTEGER|T_CARDINAL);
expp->nd_type = char_type;
if (!arg) return 0;
break;
case S_FLOAT:
arg = getarg(arg, T_CARDINAL|T_INTEGER);
expp->nd_type = real_type;
if (!arg) return 0;
break;
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_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:
arg = getarg(arg, T_INTEGER|T_CARDINAL);
if (!arg) return 0;
expp->nd_type = bool_type;
break;
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:
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:
arg = getarg(arg, T_REAL);
if (!arg) return 0;
expp->nd_type = card_type;
break;
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;
case S_DEC:
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:
expp->nd_type = 0;
break;
case S_EXCL:
case S_INCL:
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;
default:
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;
@ -297,7 +427,7 @@ findname(expp)
if (tp == error_type) {
df = ill_df;
}
else if (tp->tp_fund != RECORD) {
else if (tp->tp_fund != T_RECORD) {
/* This is also true for modules */
node_error(expp,"Illegal selection");
df = ill_df;
@ -341,18 +471,15 @@ df->df_idf->id_text);
}
int
chk_name(expp, const)
chk_name(expp)
register struct node *expp;
{
register struct def *df;
int retval = 1;
(void) findname(expp);
assert(expp->nd_class == Def);
df = expp->nd_def;
if (df->df_kind == D_ERROR) {
retval = 0;
}
if (df->df_kind == D_ERROR) return 0;
if (df->df_kind & (D_ENUM | D_CONST)) {
if (df->df_kind == D_ENUM) {
expp->nd_class = Value;
@ -363,20 +490,14 @@ chk_name(expp, const)
*expp = *(df->con_const);
}
}
else if (const) {
node_error(expp, "constant expected");
retval = 0;
}
return retval;
return 1;
}
int
chk_oper(expp, const)
chk_oper(expp)
register struct node *expp;
{
/* Check a binary operation. If "const" is set, also check
that it is constant.
The code is ugly !
/* Check a binary operation.
*/
register struct type *tpl = expp->nd_left->nd_type;
register struct type *tpr = expp->nd_right->nd_type;
@ -398,7 +519,7 @@ chk_oper(expp, const)
if (expp->nd_symb == IN) {
/* Handle this one specially */
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");
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 == '[') {
/* 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");
return 0;
}
@ -420,11 +541,10 @@ 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;
if (tpl->tp_fund == T_SUBRANGE) tpl = tpl->next;
expp->nd_type = tpl;
if (!TstCompat(tpl, tpr)) {
@ -437,49 +557,35 @@ node_error(expp, "Incompatible types for operator \"%s\"", symbol2str(expp->nd_s
case '-':
case '*':
switch(tpl->tp_fund) {
case INTEGER:
case INTORCARD:
case CARDINAL:
case LONGINT:
case SET:
case T_INTEGER:
case T_CARDINAL:
case T_SET:
if (expp->nd_left->nd_class == Value &&
expp->nd_right->nd_class == Value) {
cstbin(expp);
}
return 1;
case REAL:
case LONGREAL:
if (const) {
errval = 2;
break;
}
case T_REAL:
return 1;
}
break;
case '/':
switch(tpl->tp_fund) {
case SET:
case T_SET:
if (expp->nd_left->nd_class == Value &&
expp->nd_right->nd_class == Value) {
cstbin(expp);
}
return 1;
case REAL:
case LONGREAL:
if (const) {
errval = 2;
break;
}
case T_REAL:
return 1;
}
break;
case DIV:
case MOD:
switch(tpl->tp_fund) {
case INTEGER:
case INTORCARD:
case CARDINAL:
case LONGINT:
case T_INTEGER:
case T_CARDINAL:
if (expp->nd_left->nd_class == Value &&
expp->nd_right->nd_class == Value) {
cstbin(expp);
@ -505,32 +611,30 @@ node_error(expp, "Incompatible types for operator \"%s\"", symbol2str(expp->nd_s
case '<':
case '>':
switch(tpl->tp_fund) {
case SET:
case T_SET:
if (expp->nd_symb == '<' || expp->nd_symb == '>') {
break;
}
case INTEGER:
case INTORCARD:
case LONGINT:
case CARDINAL:
case ENUMERATION: /* includes boolean */
case CHAR:
if (expp->nd_left->nd_class == Set &&
expp->nd_right->nd_class == Set) {
cstbin(expp);
}
return 1;
case T_INTEGER:
case T_CARDINAL:
case T_ENUMERATION: /* includes boolean */
case T_CHAR:
if (expp->nd_left->nd_class == Value &&
expp->nd_right->nd_class == Value) {
cstbin(expp);
}
return 1;
case POINTER:
case T_POINTER:
if (!(expp->nd_symb == '=' || expp->nd_symb == '#')) {
break;
}
/* Fall through */
case REAL:
case LONGREAL:
if (const) {
errval = 2;
break;
}
case T_REAL:
return 1;
}
default:
@ -540,37 +644,32 @@ node_error(expp, "Incompatible types for operator \"%s\"", symbol2str(expp->nd_s
case 1:
node_error(expp,"Operator \"%s\": illegal operand type(s)", symbol2str(expp->nd_symb));
break;
case 2:
node_error(expp, "Expression not constant");
break;
case 3:
node_error(expp, "BOOLEAN type(s) expected");
break;
default:
assert(0);
}
return 0;
}
int
chk_uoper(expp, const)
chk_uoper(expp)
register struct node *expp;
{
/* Check an unary operation. If "const" is set, also check that
it can be evaluated compile-time.
/* Check an unary operation.
*/
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;
switch(expp->nd_symb) {
case '+':
switch(tpr->tp_fund) {
case INTEGER:
case LONGINT:
case REAL:
case LONGREAL:
case CARDINAL:
case INTORCARD:
case T_INTEGER:
case T_REAL:
case T_CARDINAL:
expp->nd_token = expp->nd_right->nd_token;
FreeNode(expp->nd_right);
expp->nd_right = 0;
@ -579,15 +678,12 @@ chk_uoper(expp, const)
break;
case '-':
switch(tpr->tp_fund) {
case INTEGER:
case LONGINT:
case INTORCARD:
case T_INTEGER:
if (expp->nd_right->nd_class == Value) {
cstunary(expp);
}
return 1;
case REAL:
case LONGREAL:
case T_REAL:
if (expp->nd_right->nd_class == Value) {
expp->nd_token = expp->nd_right->nd_token;
if (*(expp->nd_REL) == '-') {
@ -609,9 +705,8 @@ chk_uoper(expp, const)
}
break;
case '^':
if (tpr->tp_fund != POINTER) break;
if (tpr->tp_fund != T_POINTER) break;
expp->nd_type = tpr->next;
if (const) return 0;
return 1;
default:
assert(0);

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

@ -60,7 +60,7 @@ cstbin(expp)
int uns = expp->nd_type != int_type;
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);
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)?
{
df->df_type = tp = construct_type(PROCEDURE, tp);
df->df_type = tp = construct_type(T_PROCEDURE, tp);
tp->prc_params = params;
if (tp1 && !TstTypeEquiv(tp, tp1)) {
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)
{ if (ARRAYflag) {
*tp = construct_type(ARRAY, NULLTYPE);
*tp = construct_type(T_ARRAY, NULLTYPE);
(*tp)->arr_elem = df->df_type;
}
else *tp = df->df_type;
@ -153,12 +153,12 @@ TypeDeclaration
'=' type(&tp)
{ df->df_type = tp;
if ((df->df_flags&D_EXPORTED) &&
tp->tp_fund == ENUMERATION) {
tp->tp_fund == T_ENUMERATION) {
exprt_literals(tp->enm_enums,
enclosing(CurrentScope));
}
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);
}
@ -207,11 +207,11 @@ enumeration(struct type **ptp;)
struct node *EnumList;
} :
'(' IdentList(&EnumList) ')'
{
*ptp = standard_type(ENUMERATION,int_align,int_size);
EnterIdList(EnumList, D_ENUM, 0, *ptp, CurrentScope);
FreeNode(EnumList);
}
{
*ptp = standard_type(T_ENUMERATION,int_align,int_size);
EnterIdList(EnumList, D_ENUM, 0, *ptp, CurrentScope);
FreeNode(EnumList);
}
;
@ -252,12 +252,12 @@ ArrayType(struct type **ptp;)
} :
ARRAY SimpleType(&tp)
{
*ptp = tp2 = construct_type(ARRAY, tp);
*ptp = tp2 = construct_type(T_ARRAY, tp);
}
[
',' SimpleType(&tp)
{ tp2 = tp2->arr_elem =
construct_type(ARRAY, tp);
construct_type(T_ARRAY, tp);
}
]* OF type(&tp)
{ tp2->arr_elem = tp; }
@ -273,10 +273,10 @@ RecordType(struct type **ptp;)
scope.next = CurrentScope;
}
FieldListSequence(&scope)
{
*ptp = standard_type(RECORD, record_align, (arith) 0 /* ???? */);
(*ptp)->rec_scope = scope.sc_scope;
}
{
*ptp = standard_type(T_RECORD, record_align, (arith) 0 /* ???? */);
(*ptp)->rec_scope = scope.sc_scope;
}
END
;
@ -380,7 +380,7 @@ PointerType(struct type **ptp;)
{ tp = NULLTYPE; }
]
{
*ptp = construct_type(POINTER, tp);
*ptp = construct_type(T_POINTER, tp);
if (!tp) Forward(&dot, &((*ptp)->next));
}
;
@ -391,7 +391,7 @@ ProcedureType(struct type **ptp;)
struct type *tp = 0;
} :
PROCEDURE FormalTypeList(&pr, &tp)?
{ *ptp = construct_type(PROCVAR, tp);
{ *ptp = construct_type(T_PROCEDURE, tp);
(*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));
define(ids->nd_IDF, CurrentScope, kind)->imp_def = df;
if (df->df_kind == D_TYPE &&
df->df_type->tp_fund == ENUMERATION) {
df->df_type->tp_fund == T_ENUMERATION) {
/* Also import all enumeration literals */
exprt_literals(df->df_type->enm_enums,
CurrentScope);

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

@ -68,12 +68,15 @@ ExpList(struct node **pnd;)
{
struct node **nd;
} :
expression(pnd) { nd = pnd; }
[
',' { *nd = MkNode(Link, *nd, NULLNODE, &dot);
nd = &(*nd)->nd_right;
expression(pnd) { *pnd = MkNode(Link, *pnd, NULLNODE, &dot);
(*pnd)->nd_symb = ',';
nd = &((*pnd)->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,
( debug("Constant expression:"),
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));
}
;

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

@ -156,7 +156,7 @@ add_standards()
(void) Enter("NIL", D_CONST, address_type, 0);
(void) Enter("PROC",
D_TYPE,
construct_type(PROCEDURE, NULLTYPE),
construct_type(T_PROCEDURE, NULLTYPE),
0);
df = Enter("BITSET", D_TYPE, bitset_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);
df->mod_scope = CurrentScope->sc_scope;
df->df_type =
standard_type(RECORD, 0, (arith) 0);
standard_type(T_RECORD, 0, (arith) 0);
df->df_type->rec_scope = df->mod_scope;
}
priority? ';'
@ -116,7 +116,7 @@ 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 = 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));

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 */
{PROGRAM, ""},
{SUBRANGE, ""},
{ENUMERATION, ""},
{ERRONEOUS, ""},
{PROCVAR, ""},
{INTORCARD, ""},
{0, "0"}
};
struct tokenname tkstandard[] = { /* standard identifiers */
{CHAR, ""},
{BOOLEAN, ""},
{LONGINT, ""},
{CARDINAL, ""},
{LONGREAL, ""},
{WORD, ""},
{ADDRESS, ""},
{0, ""}
};

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

@ -53,9 +53,23 @@ struct type {
SUBRANGE
*/
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 */
arith tp_size; /* size of this type */
/* struct idf *tp_idf; /* name of this type */
union {
struct enume tp_enum;
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);
switch (fund) {
case PROCEDURE:
case POINTER:
case T_PROCEDURE:
case T_POINTER:
dtp->tp_align = ptr_align;
dtp->tp_size = ptr_size;
dtp->next = tp;
break;
case SET:
case T_SET:
dtp->tp_align = wrd_align;
dtp->next = tp;
break;
case ARRAY:
case T_ARRAY:
dtp->tp_align = tp->tp_align;
dtp->next = tp;
break;
case SUBRANGE:
case T_SUBRANGE:
dtp->tp_align = tp->tp_align;
dtp->tp_size = tp->tp_size;
dtp->next = tp;
@ -131,25 +131,25 @@ init_types()
{
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;
bool_type = standard_type(ENUMERATION, 1, (arith) 1);
bool_type = standard_type(T_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);
real_type = standard_type(REAL, real_align, real_size);
longreal_type = standard_type(LONGREAL, lreal_align, lreal_size);
word_type = standard_type(WORD, wrd_align, wrd_size);
intorcard_type = standard_type(INTORCARD, int_align, int_size);
string_type = standard_type(STRING, 1, (arith) -1);
address_type = construct_type(POINTER, word_type);
tp = construct_type(SUBRANGE, int_type);
int_type = standard_type(T_INTEGER, int_align, int_size);
longint_type = standard_type(T_INTEGER, lint_align, lint_size);
card_type = standard_type(T_CARDINAL, int_align, int_size);
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);
string_type = standard_type(T_STRING, 1, (arith) -1);
address_type = construct_type(T_POINTER, word_type);
tp = construct_type(T_SUBRANGE, int_type);
tp->sub_lb = 0;
tp->sub_ub = wrd_size * 8 - 1;
bitset_type = set_type(tp);
std_type = construct_type(PROCEDURE, NULLTYPE);
error_type = standard_type(ERRONEOUS, 1, (arith) 1);
std_type = construct_type(T_PROCEDURE, NULLTYPE);
error_type = standard_type(T_CHAR, 1, (arith) 1);
}
int
@ -160,14 +160,11 @@ has_selectors(df)
switch(df->df_kind) {
case D_MODULE:
return df->df_value.df_module.mo_scope;
case D_VARIABLE: {
register struct type *tp = df->df_type;
if (tp->tp_fund == RECORD) {
return tp->rec_scope;
case D_VARIABLE:
if (df->df_type->tp_fund == T_RECORD) {
return df->df_type->rec_scope;
}
break;
}
}
error("no selectors for \"%s\"", df->df_idf->id_text);
return 0;
@ -205,7 +202,7 @@ ParamList(ids, tp, VARp)
chk_basesubrange(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
of "base"
*/
@ -214,7 +211,7 @@ chk_basesubrange(tp, base)
}
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) {
error("Specified base does not conform");
}
@ -247,13 +244,13 @@ subr_type(lb, ub)
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 */
/* Check base 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
*/
node_error(ub, "Illegal base type for subrange");
@ -268,7 +265,7 @@ subr_type(lb, ub)
/* Now construct resulting type
*/
tp = construct_type(SUBRANGE, tp);
tp = construct_type(T_SUBRANGE, tp);
tp->sub_lb = lb->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));
@ -285,13 +282,13 @@ set_type(tp)
*/
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) {
error("Set type limits exceeded");
return error_type;
}
}
else if (tp->tp_fund == ENUMERATION || tp == char_type) {
else if (tp->tp_fund == T_ENUMERATION || tp == char_type) {
lb = 0;
if ((ub = tp->enm_ncst - 1) > MAX_SET - 1) {
error("Set type limits exceeded");
@ -302,7 +299,7 @@ set_type(tp)
error("illegal base type for set");
return error_type;
}
tp = construct_type(SET, tp);
tp = construct_type(T_SET, tp);
tp->tp_size = align(((ub - lb) + 7)/8, wrd_align);
return tp;
}

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

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