From 64a9f1e5d73715672656a5868b903d74aba19c35 Mon Sep 17 00:00:00 2001 From: ceriel Date: Fri, 11 Apr 1986 11:57:19 +0000 Subject: [PATCH] newer version --- lang/m2/comp/Makefile | 10 +-- lang/m2/comp/chk_expr.c | 159 +++++++++++++++++++++++++------------- lang/m2/comp/const.h | 1 + lang/m2/comp/cstoper.c | 118 ++++++++++++++++++++++++++-- lang/m2/comp/declar.g | 63 ++++++++++++--- lang/m2/comp/def.H | 16 ++-- lang/m2/comp/def.c | 83 ++++++++++++++++---- lang/m2/comp/enter.c | 4 +- lang/m2/comp/expression.g | 9 ++- lang/m2/comp/type.H | 3 + lang/m2/comp/type.c | 3 +- lang/m2/comp/typequiv.c | 17 +++- 12 files changed, 379 insertions(+), 107 deletions(-) diff --git a/lang/m2/comp/Makefile b/lang/m2/comp/Makefile index 74969ac11..7cb39541f 100644 --- a/lang/m2/comp/Makefile +++ b/lang/m2/comp/Makefile @@ -82,16 +82,16 @@ symbol2str.o: Lpars.h tokenname.o: Lpars.h idf.h tokenname.h idf.o: idf.h input.o: f_info.h input.h -type.o: LLlex.h Lpars.h const.h debug.h def.h def_sizes.h idf.h node.h type.h -def.o: LLlex.h Lpars.h debug.h def.h idf.h main.h node.h scope.h type.h +type.o: LLlex.h const.h debug.h def.h def_sizes.h idf.h node.h type.h +def.o: LLlex.h debug.h def.h idf.h main.h node.h scope.h type.h scope.o: LLlex.h debug.h def.h idf.h node.h scope.h type.h misc.o: LLlex.h f_info.h idf.h misc.h node.h enter.o: LLlex.h def.h idf.h node.h scope.h type.h defmodule.o: LLlex.h debug.h def.h f_info.h idf.h input.h scope.h -typequiv.o: Lpars.h def.h type.h +typequiv.o: def.h type.h node.o: LLlex.h debug.h def.h node.h type.h -cstoper.o: LLlex.h Lpars.h def_sizes.h idf.h node.h type.h -chk_expr.o: LLlex.h Lpars.h const.h def.h idf.h node.h scope.h standards.h type.h +cstoper.o: LLlex.h Lpars.h def_sizes.h idf.h node.h standards.h type.h +chk_expr.o: LLlex.h Lpars.h const.h debug.h def.h idf.h node.h scope.h standards.h type.h tokenfile.o: Lpars.h program.o: LLlex.h Lpars.h debug.h def.h idf.h main.h node.h scope.h type.h declar.o: LLlex.h Lpars.h def.h idf.h misc.h node.h scope.h type.h diff --git a/lang/m2/comp/chk_expr.c b/lang/m2/comp/chk_expr.c index 21ba93bb4..67075d10d 100644 --- a/lang/m2/comp/chk_expr.c +++ b/lang/m2/comp/chk_expr.c @@ -17,6 +17,7 @@ static char *RcsId = "$Header$"; #include "scope.h" #include "const.h" #include "standards.h" +#include "debug.h" int chk_expr(expp) @@ -199,7 +200,7 @@ getarg(argp, bases) struct type *tp; if (!argp->nd_right) { - node_error(argp, "Too few arguments supplied"); + node_error(argp, "too few arguments supplied"); return 0; } argp = argp->nd_right; @@ -218,7 +219,7 @@ getname(argp, kinds) struct node *argp; { if (!argp->nd_right) { - node_error(argp, "Too few arguments supplied"); + node_error(argp, "too few arguments supplied"); return 0; } argp = argp->nd_right; @@ -235,67 +236,84 @@ int chk_call(expp) register struct node *expp; { - register struct type *tp; + /* Check something that looks like a procedure or function call. + Of course this does not have to be a call at all. + it may also be a cast or a standard procedure call. + */ register struct node *left; register struct node *arg; expp->nd_type = error_type; - (void) findname(expp->nd_left); + (void) findname(expp->nd_left); /* parser made sure it is a name */ left = expp->nd_left; - tp = left->nd_type; - if (tp == error_type) return 0; + if (left->nd_type == error_type) return 0; if (left->nd_class == Def && (left->nd_def->df_kind & (D_HTYPE|D_TYPE|D_HIDDEN))) { /* A type cast. This is of course not portable. No runtime action. Remove it. */ arg = expp->nd_right; - if (!arg || arg->nd_right) { + if ((! arg) || arg->nd_right) { node_error(expp, "Only one parameter expected in type cast"); return 0; } - if (! chk_expr(arg->nd_left)) return 0; - if (arg->nd_left->nd_type->tp_size != - left->nd_type->tp_size) { + arg = arg->nd_left; + if (! chk_expr(arg)) return 0; + if (arg->nd_type->tp_size != left->nd_type->tp_size) { node_error(expp, "Size of type in type cast does not match size of operand"); return 0; } - arg->nd_left->nd_type = left->nd_type; + arg->nd_type = left->nd_type; FreeNode(expp->nd_left); *expp = *(arg->nd_left); - arg->nd_left->nd_left = 0; - arg->nd_left->nd_right = 0; + arg->nd_left = 0; + arg->nd_right = 0; FreeNode(arg); return 1; } if ((left->nd_class == Def && left->nd_def->df_kind == D_PROCEDURE) || - tp->tp_fund == T_PROCEDURE) { + left->nd_type->tp_fund == T_PROCEDURE) { /* A procedure call. it may also be a call to a standard procedure */ arg = expp; - if (tp == std_type) { + if (left->nd_type == std_type) { + /* A standard procedure + */ assert(left->nd_class == Def); +DO_DEBUG(3, debug("Standard name \"%s\", %d", +left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname)); switch(left->nd_def->df_value.df_stdname) { case S_ABS: - arg = getarg(arg, T_INTEGER|T_CARDINAL|T_REAL); + arg = getarg(arg, T_NUMERIC); if (! arg) return 0; - expp->nd_type = arg->nd_left->nd_type; + left = arg->nd_left; + expp->nd_type = left->nd_type; + if (left->nd_class == Value) { + cstcall(expp, S_ABS); + } break; case S_CAP: arg = getarg(arg, T_CHAR); expp->nd_type = char_type; if (!arg) return 0; + left = arg->nd_left; + if (left->nd_class == Value) { + cstcall(expp, S_CAP); + } break; case S_CHR: - arg = getarg(arg, T_INTEGER|T_CARDINAL); + arg = getarg(arg, T_INTORCARD); expp->nd_type = char_type; if (!arg) return 0; + if (arg->nd_left->nd_class == Value) { + cstcall(expp, S_CHR); + } break; case S_FLOAT: - arg = getarg(arg, T_CARDINAL|T_INTEGER); + arg = getarg(arg, T_INTORCARD); expp->nd_type = real_type; if (!arg) return 0; break; @@ -303,50 +321,71 @@ node_error(expp, "Size of type in type cast does not match size of operand"); arg = getarg(arg, T_ARRAY); if (!arg) return 0; expp->nd_type = arg->nd_left->nd_type->next; - if (!expp->nd_type) expp->nd_type = int_type; + if (!expp->nd_type) { + /* A dynamic array has no explicit + index type + */ + expp->nd_type = int_type; + } + else cstcall(expp, S_MAX); break; case S_MAX: case S_MIN: - arg = getarg(arg, T_ENUMERATION|T_CHAR|T_INTEGER|T_CARDINAL); + arg = getarg(arg, T_DISCRETE); if (!arg) return 0; expp->nd_type = arg->nd_left->nd_type; + cstcall(expp,left->nd_def->df_value.df_stdname); break; case S_ODD: - arg = getarg(arg, T_INTEGER|T_CARDINAL); + arg = getarg(arg, T_INTORCARD); if (!arg) return 0; expp->nd_type = bool_type; + if (arg->nd_left->nd_class == Value) { + cstcall(expp, S_ODD); + } break; case S_ORD: - arg = getarg(arg, T_ENUMERATION|T_CHAR|T_INTEGER|T_CARDINAL); + arg = getarg(arg, T_DISCRETE); if (!arg) return 0; expp->nd_type = card_type; + if (arg->nd_left->nd_class == Value) { + cstcall(expp, S_ORD); + } break; case S_TSIZE: /* ??? */ case S_SIZE: arg = getname(arg, D_FIELD|D_VARIABLE|D_TYPE|D_HIDDEN|D_HTYPE); expp->nd_type = intorcard_type; if (!arg) return 0; + cstcall(expp, S_SIZE); break; case S_TRUNC: arg = getarg(arg, T_REAL); if (!arg) return 0; expp->nd_type = card_type; break; - case S_VAL: + case S_VAL: { + struct type *tp; + arg = getname(arg, D_HIDDEN|D_HTYPE|D_TYPE); if (!arg) return 0; tp = arg->nd_left->nd_def->df_type; if (tp->tp_fund == T_SUBRANGE) tp = tp->next; - if (!(tp->tp_fund & (T_ENUMERATION|T_CHAR|T_INTEGER|T_CARDINAL))) { + if (!(tp->tp_fund & T_DISCRETE)) { node_error(arg, "unexpected type"); return 0; } expp->nd_type = arg->nd_left->nd_def->df_type; - FreeNode(arg->nd_left); - arg->nd_left = 0; - arg = getarg(arg, T_INTEGER|T_CARDINAL); + expp->nd_right = arg->nd_right; + arg->nd_right = 0; + FreeNode(arg); + arg = getarg(expp, T_INTORCARD); if (!arg) return 0; + if (arg->nd_left->nd_class == Value) { + cstcall(expp, S_VAL); + } break; + } case S_ADR: arg = getname(arg, D_VARIABLE|D_FIELD|D_PROCEDURE); expp->nd_type = address_type; @@ -358,7 +397,7 @@ node_error(expp, "Size of type in type cast does not match size of operand"); arg = getname(arg, D_VARIABLE|D_FIELD); if (!arg) return 0; if (arg->nd_right) { - arg = getarg(arg, T_INTEGER|T_CARDINAL); + arg = getarg(arg, T_INTORCARD); if (!arg) return 0; } break; @@ -366,7 +405,9 @@ node_error(expp, "Size of type in type cast does not match size of operand"); expp->nd_type = 0; break; case S_EXCL: - case S_INCL: + case S_INCL: { + struct type *tp; + expp->nd_type = 0; arg = getname(arg, D_VARIABLE|D_FIELD); if (!arg) return 0; @@ -375,25 +416,26 @@ node_error(expp, "Size of type in type cast does not match size of operand"); node_error(arg, "EXCL and INCL expect a SET parameter"); return 0; } - arg = getarg(arg, T_INTEGER|T_CARDINAL|T_CHAR|T_ENUMERATION); + arg = getarg(arg, T_DISCRETE); if (!arg) return 0; if (!TstCompat(tp->next, arg->nd_left->nd_type)) { node_error(arg, "Unexpected type"); return 0; } break; + } default: assert(0); } if (arg->nd_right) { node_error(arg->nd_right, - "Too many parameters supplied"); + "too many parameters supplied"); return 0; } - FreeNode(expp->nd_left); - expp->nd_left = 0; return 1; } + /* Here, we have found a real procedure call + */ return 1; } node_error(expp->nd_left, "procedure, type, or function expected"); @@ -527,17 +569,22 @@ node_error(expp, "RHS of IN operator not a SET type"); node_error(expp, "IN operator: type of LHS not compatible with element type of RHS"); return 0; } + if (expp->nd_left->nd_class == Value && + expp->nd_right->nd_class == Set) { + cstset(expp); + } return 1; } if (expp->nd_symb == '[') { /* Handle ARRAY selection specially too! */ if (tpl->tp_fund != T_ARRAY) { -node_error(expp, "array index not belonging to an ARRAY"); + node_error(expp, + "array index not belonging to an ARRAY"); return 0; } if (!TstCompat(tpl->next, tpr)) { -node_error(expp, "incompatible index type"); + node_error(expp, "incompatible index type"); return 0; } expp->nd_type = tpl->arr_elem; @@ -548,7 +595,9 @@ node_error(expp, "incompatible index type"); expp->nd_type = tpl; if (!TstCompat(tpl, tpr)) { -node_error(expp, "Incompatible types for operator \"%s\"", symbol2str(expp->nd_symb)); + node_error(expp, + "Incompatible types for operator \"%s\"", + symbol2str(expp->nd_symb)); return 0; } @@ -559,12 +608,18 @@ node_error(expp, "Incompatible types for operator \"%s\"", symbol2str(expp->nd_s switch(tpl->tp_fund) { case T_INTEGER: case T_CARDINAL: - case T_SET: + case T_INTORCARD: if (expp->nd_left->nd_class == Value && expp->nd_right->nd_class == Value) { cstbin(expp); } return 1; + case T_SET: + if (expp->nd_left->nd_class == Set && + expp->nd_right->nd_class == Set) { + cstset(expp); + } + /* Fall through */ case T_REAL: return 1; } @@ -572,20 +627,18 @@ node_error(expp, "Incompatible types for operator \"%s\"", symbol2str(expp->nd_s case '/': switch(tpl->tp_fund) { case T_SET: - if (expp->nd_left->nd_class == Value && - expp->nd_right->nd_class == Value) { - cstbin(expp); + if (expp->nd_left->nd_class == Set && + expp->nd_right->nd_class == Set) { + cstset(expp); } - return 1; + /* Fall through */ case T_REAL: return 1; } break; case DIV: case MOD: - switch(tpl->tp_fund) { - case T_INTEGER: - case T_CARDINAL: + if (tpl->tp_fund & T_INTORCARD) { if (expp->nd_left->nd_class == Value && expp->nd_right->nd_class == Value) { cstbin(expp); @@ -617,13 +670,14 @@ node_error(expp, "Incompatible types for operator \"%s\"", symbol2str(expp->nd_s } if (expp->nd_left->nd_class == Set && expp->nd_right->nd_class == Set) { - cstbin(expp); + cstset(expp); } return 1; case T_INTEGER: case T_CARDINAL: case T_ENUMERATION: /* includes boolean */ case T_CHAR: + case T_INTORCARD: if (expp->nd_left->nd_class == Value && expp->nd_right->nd_class == Value) { cstbin(expp); @@ -666,10 +720,7 @@ chk_uoper(expp) switch(expp->nd_symb) { case '+': - switch(tpr->tp_fund) { - case T_INTEGER: - case T_REAL: - case T_CARDINAL: + if (tpr->tp_fund & T_NUMERIC) { expp->nd_token = expp->nd_right->nd_token; FreeNode(expp->nd_right); expp->nd_right = 0; @@ -677,13 +728,13 @@ chk_uoper(expp) } break; case '-': - switch(tpr->tp_fund) { - case T_INTEGER: + if (tpr->tp_fund & T_INTORCARD) { if (expp->nd_right->nd_class == Value) { cstunary(expp); } return 1; - case T_REAL: + } + else if (tpr->tp_fund == T_REAL) { if (expp->nd_right->nd_class == Value) { expp->nd_token = expp->nd_right->nd_token; if (*(expp->nd_REL) == '-') { @@ -711,7 +762,7 @@ chk_uoper(expp) default: assert(0); } - node_error(expp, "Illegal operand for unary operator \"%s\"", + node_error(expp, "illegal operand for unary operator \"%s\"", symbol2str(expp->nd_symb)); return 0; } diff --git a/lang/m2/comp/const.h b/lang/m2/comp/const.h index 41f44cf93..28cf5c99a 100644 --- a/lang/m2/comp/const.h +++ b/lang/m2/comp/const.h @@ -9,4 +9,5 @@ extern int extern arith max_int, /* maximum integer on target machine */ max_unsigned, /* maximum unsigned on target machine */ + max_longint, /* maximum longint on target machine */ wrd_bits; /* Number of bits in a word */ diff --git a/lang/m2/comp/cstoper.c b/lang/m2/comp/cstoper.c index a6182bd83..81411b290 100644 --- a/lang/m2/comp/cstoper.c +++ b/lang/m2/comp/cstoper.c @@ -11,6 +11,7 @@ static char *RcsId = "$Header$"; #include "LLlex.h" #include "node.h" #include "Lpars.h" +#include "standards.h" long mach_long_sign; /* sign bit of the machine long */ int mach_long_size; /* size of long on this machine == sizeof(long) */ @@ -60,10 +61,7 @@ cstbin(expp) int uns = expp->nd_type != int_type; assert(expp->nd_class == Oper); - if (expp->nd_right->nd_type->tp_fund == T_SET) { - cstset(expp); - return; - } + assert(expp->nd_left->nd_class == Value && expp->nd_right->nd_class == Value); switch (expp->nd_symb) { case '*': o1 *= o2; @@ -288,6 +286,108 @@ cstset(expp) expp->nd_left = expp->nd_right = 0; } +cstcall(expp, call) + register struct node *expp; +{ + /* a standard procedure call is found that can be evaluated + compile time, so do so. + */ + register struct node *expr = 0; + + assert(expp->nd_class == Call); + if (expp->nd_right) { + expr = expp->nd_right->nd_left; + expp->nd_right->nd_left = 0; + FreeNode(expp->nd_right); + } + expp->nd_class = Value; + switch(call) { + case S_ABS: + if (expr->nd_type->tp_fund == T_REAL) { + expp->nd_symb = REAL; + expp->nd_REL = expr->nd_REL; + if (*(expr->nd_REL) == '-') (expp->nd_REL)++; + break; + } + if (expr->nd_INT < 0) expp->nd_INT = - expr->nd_INT; + else expp->nd_INT = expr->nd_INT; + cut_size(expp); + break; + case S_CAP: + if (expr->nd_INT >= 'a' && expr->nd_INT <= 'z') { + expp->nd_INT = expr->nd_INT + ('A' - 'a'); + } + else expp->nd_INT = expr->nd_INT; + cut_size(expp); + break; + case S_CHR: + expp->nd_INT = expr->nd_INT; + cut_size(expp); + break; + case S_MAX: + if (expp->nd_type == int_type) { + expp->nd_INT = max_int; + } + else if (expp->nd_type == longint_type) { + expp->nd_INT = max_longint; + } + else if (expp->nd_type == card_type) { + expp->nd_INT = max_unsigned; + } + else if (expp->nd_type->tp_fund == T_SUBRANGE) { + expp->nd_INT = expp->nd_type->sub_ub; + } + else expp->nd_INT = expp->nd_type->enm_ncst - 1; + break; + case S_MIN: + if (expp->nd_type == int_type) { + expp->nd_INT = (-max_int) - 1; + } + else if (expp->nd_type == longint_type) { + expp->nd_INT = (-max_longint) - 1; + } + else if (expp->nd_type->tp_fund == T_SUBRANGE) { + expp->nd_INT = expp->nd_type->sub_lb; + } + else expp->nd_INT = 0; + break; + case S_ODD: + expp->nd_INT = (expr->nd_INT & 1); + break; + case S_ORD: + expp->nd_INT = expr->nd_INT; + cut_size(expp); + break; + case S_SIZE: + expp->nd_INT = align(expr->nd_type->tp_size, wrd_size)/wrd_size; + break; + case S_VAL: + expp->nd_INT = expr->nd_INT; + if ( /* Check overflow of subranges or enumerations */ + ( expp->nd_type->tp_fund == T_SUBRANGE + && + ( expp->nd_INT < expp->nd_type->sub_lb + || expp->nd_INT > expp->nd_type->sub_ub + ) + ) + || + ( expp->nd_type->tp_fund == T_ENUMERATION + && + ( expp->nd_INT < 0 + || expp->nd_INT >= expp->nd_type->enm_ncst + ) + ) + ) node_warning(expp,"overflow in constant expression"); + else cut_size(expp); + break; + default: + assert(0); + } + FreeNode(expr); + FreeNode(expp->nd_left); + expp->nd_right = expp->nd_left = 0; +} + cut_size(expr) register struct node *expr; { @@ -295,10 +395,13 @@ cut_size(expr) conform to the size of the type of the expression. */ arith o1 = expr->nd_INT; - int uns = expr->nd_type == card_type || expr->nd_type == intorcard_type; - int size = expr->nd_type->tp_size; + struct type *tp = expr->nd_type; + int uns; + int size = tp->tp_size; assert(expr->nd_class == Value); + if (tp->tp_fund == T_SUBRANGE) tp = tp->next; + uns = (tp->tp_fund & (T_CARDINAL|T_CHAR)); if (uns) { if (o1 & ~full_mask[size]) { node_warning(expr, @@ -332,11 +435,12 @@ init_cst() } mach_long_size = i; mach_long_sign = 1 << (mach_long_size * 8 - 1); - if (int_size > mach_long_size) { + if (lint_size > mach_long_size) { fatal("sizeof (long) insufficient on this machine"); } max_int = full_mask[int_size] & ~(1 << (int_size * 8 - 1)); max_unsigned = full_mask[int_size]; + max_longint = full_mask[lint_size] & ~(1 << (lint_size * 8 - 1)); wrd_bits = 8 * wrd_size; } diff --git a/lang/m2/comp/declar.g b/lang/m2/comp/declar.g index 79bc4dc02..857f35c06 100644 --- a/lang/m2/comp/declar.g +++ b/lang/m2/comp/declar.g @@ -30,7 +30,7 @@ ProcedureDeclaration ProcedureHeading(struct def **pdf; int type;) { - struct type *tp; + struct type *tp = 0; struct type *tp1 = 0; struct paramlist *params = 0; register struct def *df; @@ -97,7 +97,7 @@ FormalParameters(int doparams; struct paramlist **pr; struct type **tp;) ]? ')' { *tp = 0; } - [ ':' qualident(D_TYPE | D_HTYPE, &df, "type", (struct node **) 0) + [ ':' qualident(D_TYPE|D_HTYPE|D_HIDDEN, &df, "type", (struct node **) 0) { *tp = df->df_type; } ]? ; @@ -135,7 +135,7 @@ FormalType(struct type **tp;) } : [ ARRAY OF { ARRAYflag = 1; } ]? - qualident(D_TYPE | D_HTYPE, &df, "type", (struct node **) 0) + qualident(D_TYPE|D_HTYPE|D_HIDDEN, &df, "type", (struct node **) 0) { if (ARRAYflag) { *tp = construct_type(T_ARRAY, NULLTYPE); (*tp)->arr_elem = df->df_type; @@ -183,7 +183,7 @@ SimpleType(struct type **ptp;) { struct def *df; } : - qualident(D_TYPE | D_HTYPE, &df, "type", (struct node **) 0) + qualident(D_TYPE|D_HTYPE|D_HIDDEN, &df, "type", (struct node **) 0) [ /* nothing */ { *ptp = df->df_type; } @@ -293,6 +293,7 @@ FieldList(struct scope *scope;) struct idf *id; struct def *df, *df1; struct type *tp; + struct node *nd; } : [ IdentList(&FldList) ':' type(&tp) @@ -301,13 +302,51 @@ FieldList(struct scope *scope;) } | CASE - [ - IDENT { id = dot.TOK_IDF; } + /* Also accept old fashioned Modula-2 syntax, but give a warning + */ + [ qualident(0, &df, (char *) 0, &nd) + [ /* This is good, in both kinds of Modula-2, if + the first qualident is a single identifier. + */ + { + if (nd->nd_class != Name) { + error("illegal variant tag"); + id = gen_anon_idf(); + } + else id = nd->nd_IDF; + } + ':' qualident(D_TYPE|D_HTYPE|D_HIDDEN, + &df, "type", (struct node **) 0) + | + /* Old fashioned! the first qualident now represents + the type + */ + { + warning("Old fashioned Modula-2 syntax!"); + id = gen_anon_idf(); + findname(nd); + assert(nd->nd_class == Def); + df = nd->nd_def; + if (!(df->df_kind & + (D_ERROR|D_TYPE|D_HTYPE|D_HIDDEN))) { + error("identifier \"%s\" is not a type", + df->df_idf->id_text); + } + FreeNode(nd); + } + ] | - { id = gen_anon_idf(); } - ] /* Changed rule in new modula-2 */ - ':' qualident(D_TYPE|D_HTYPE, &df, "type", (struct node **) 0) - { df1 = define(id, scope, D_FIELD); + /* Aha, third edition? */ + ':' qualident(D_TYPE|D_HTYPE|D_HIDDEN, + &df, + "type", + (struct node **) 0) + { + id = gen_anon_idf(); + } + ] + { + df1 = define(id, scope, D_FIELD); df1->df_type = df->df_type; } OF variant(scope) @@ -362,7 +401,7 @@ PointerType(struct type **ptp;) /* Either a Module or a Type, but in both cases defined in this scope, so this is the correct identification */ - qualident(D_TYPE|D_HTYPE, &df, "type", (struct node **) 0) + qualident(D_TYPE|D_HTYPE|D_HIDDEN, &df, "type", (struct node **) 0) { if (!df->df_type) { error("type \"%s\" not declared", @@ -428,7 +467,7 @@ FormalTypeList(struct paramlist **ppr; struct type **ptp;) { p->next = 0; } ]? ')' - [ ':' qualident(D_TYPE|D_HTYPE, &df, "type", (struct node **) 0) + [ ':' qualident(D_TYPE|D_HTYPE|D_HIDDEN, &df, "type", (struct node **) 0) { *ptp = df->df_type; } ]? ; diff --git a/lang/m2/comp/def.H b/lang/m2/comp/def.H index 274f92906..30fc1b497 100644 --- a/lang/m2/comp/def.H +++ b/lang/m2/comp/def.H @@ -43,8 +43,12 @@ struct dfproc { }; struct import { - struct def *im_def; /* imported definition */ -#define imp_def df_value.df_import.im_def + union { + struct def *im_def; /* imported definition */ + struct node *im_nodef; /* imported from undefined name */ + } im_u; +#define imp_def df_value.df_import.im_u.im_def +#define imp_nodef df_value.df_import.im_u.im_nodef }; struct def { /* list of definitions for a name */ @@ -65,12 +69,12 @@ struct def { /* list of definitions for a name */ #define D_PROCHEAD 0x0100 /* a procedure heading in a definition module */ #define D_HIDDEN 0x0200 /* a hidden type */ #define D_HTYPE 0x0400 /* definition of a hidden type seen */ -#define D_STDPROC 0x0800 /* a standard procedure */ -#define D_STDFUNC 0x1000 /* a standard function */ -#define D_ERROR 0x2000 /* a compiler generated definition for an +#define D_FORWARD 0x0800 /* not yet defined */ +#define D_UNDEF_IMPORT 0x1000 /* imported from an undefined name */ +#define D_FORWMODULE 0x2000 /* module must be declared later */ +#define D_ERROR 0x4000 /* a compiler generated definition for an undefined variable */ -#define D_ISEXPORTED 0x4000 /* not yet defined */ char df_flags; #define D_ADDRESS 0x01 /* set if address was taken */ #define D_USED 0x02 /* set if used */ diff --git a/lang/m2/comp/def.c b/lang/m2/comp/def.c index b0f444806..d8888c66a 100644 --- a/lang/m2/comp/def.c +++ b/lang/m2/comp/def.c @@ -7,7 +7,6 @@ static char *RcsId = "$Header$"; #include #include #include "main.h" -#include "Lpars.h" #include "def.h" #include "type.h" #include "idf.h" @@ -33,7 +32,8 @@ define(id, scope, kind) */ register struct def *df; - DO_DEBUG(5, debug("Defining identifier \"%s\" in scope %d", id->id_text, scope->sc_scope)); + DO_DEBUG(5, debug("Defining identifier \"%s\" in scope %d, kind = %d", + id->id_text, scope->sc_scope, kind)); df = lookup(id, scope->sc_scope); if ( /* Already in this scope */ df @@ -47,7 +47,10 @@ define(id, scope, kind) switch(df->df_kind) { case D_PROCHEAD: if (kind == D_PROCEDURE) { - df->df_kind = D_PROCEDURE; + /* Definition of which the heading was + already seen in a definition module + */ + df->df_kind = kind; return df; } break; @@ -57,8 +60,14 @@ define(id, scope, kind) return df; } break; + case D_FORWMODULE: + if (kind & (D_FORWMODULE|D_MODULE)) { + df->df_kind = kind; + return df; + } + break; case D_ERROR: - case D_ISEXPORTED: + case D_FORWARD: df->df_kind = kind; return df; } @@ -72,6 +81,7 @@ error("identifier \"%s\" already declared", id->id_text); df->df_scope = scope->sc_scope; df->df_kind = kind; df->next = id->id_def; + df->df_flags = 0; id->id_def = df; /* enter the definition in the list of definitions in this scope */ @@ -101,6 +111,21 @@ lookup(id, scope) assert(df != 0); return df; } + + if (df->df_kind == D_UNDEF_IMPORT) { + df1 = df->imp_def; + assert(df1 != 0); + if (df1->df_kind == D_MODULE) { + df1 = lookup(id, df1->mod_scope); + if (df1) { + df->df_kind = D_IMPORT; + df->imp_def = df1; + } + return df1; + } + return df; + } + if (df1) { df1->next = df->next; df->next = id->id_def; @@ -122,17 +147,31 @@ Export(ids, qualified) all the "ids" visible in the enclosing scope by defining them in this scope as "imported". */ - register struct def *df; + register struct def *df, *df1; while (ids) { - df = define(ids->nd_IDF, CurrentScope, D_ISEXPORTED); + df = define(ids->nd_IDF, CurrentScope, D_FORWARD); if (qualified) { df->df_flags |= D_QEXPORTED; } else { df->df_flags |= D_EXPORTED; - df = define(ids->nd_IDF, enclosing(CurrentScope), - D_IMPORT); + df1 = lookup(ids->nd_IDF, + enclosing(CurrentScope)->sc_scope); + if (! df1 || !(df1->df_kind & (D_PROCHEAD|D_HIDDEN))) { + df1 = define(ids->nd_IDF, + enclosing(CurrentScope), + D_IMPORT); + } + else { + /* A hidden type or a procedure of which only + the head is seen. Apparently, they are + exported from a local module! + */ + df->df_kind = df1->df_kind; + df1->df_kind = D_IMPORT; + } + df1->imp_def = df; } ids = ids->next; } @@ -168,9 +207,24 @@ Import(ids, idn, local) if (!idn) imp_kind = FROM_ENCLOSING; else { imp_kind = FROM_MODULE; - if (local) df = lookfor(idn, enclosing(CurrentScope), 1); - else df = GetDefinitionModule(idn->nd_IDF); - if (df->df_kind != D_MODULE) { + if (local) { + df = lookfor(idn, enclosing(CurrentScope), 0); + if (df->df_kind == D_ERROR) { + /* The module from which the import was done + is not yet declared. I'm not sure if I must + accept this, but for the time being I will. + ??? + */ + df->df_scope = scope; + df->df_kind = D_FORWMODULE; + df->mod_scope = -1; + kind = D_UNDEF_IMPORT; + } + } + else { + df = GetDefinitionModule(idn->nd_IDF); + } + if (!(df->df_kind & (D_MODULE|D_FORWMODULE))) { /* enter all "ids" with type D_ERROR */ kind = D_ERROR; if (df->df_kind != D_ERROR) { @@ -181,13 +235,14 @@ node_error(idn, "identifier \"%s\" does not represent a module", idn->nd_IDF->id } while (ids) { if (imp_kind == FROM_MODULE) { - if (!(df = lookup(ids->nd_IDF, scope))) { + if (scope == -1) { + } + else if (!(df = lookup(ids->nd_IDF, scope))) { node_error(ids, "identifier \"%s\" not declared in qualifying module", ids->nd_IDF->id_text); df = ill_df; } - else - if (!(df->df_flags&(D_EXPORTED|D_QEXPORTED))) { + else if (!(df->df_flags&(D_EXPORTED|D_QEXPORTED))) { node_error(ids,"identifier \"%s\" not exported from qualifying module", ids->nd_IDF->id_text); } diff --git a/lang/m2/comp/enter.c b/lang/m2/comp/enter.c index 8ae0e285a..52380bc3a 100644 --- a/lang/m2/comp/enter.c +++ b/lang/m2/comp/enter.c @@ -29,7 +29,7 @@ Enter(name, kind, type, pnam) if (!id) fatal("Out of core"); df = define(id, CurrentScope, kind); df->df_type = type; - if (kind == D_STDPROC || kind == D_STDFUNC) { + if (type = std_type) { df->df_value.df_stdname = pnam; } return df; @@ -54,7 +54,7 @@ EnterIdList(idlist, kind, flags, type, scope) while (idlist) { df = define(idlist->nd_IDF, scope, kind); df->df_type = type; - df->df_flags = flags; + df->df_flags |= flags; if (kind == D_ENUM) { if (!first) first = df; df->enm_val = assval++; diff --git a/lang/m2/comp/expression.g b/lang/m2/comp/expression.g index 6a9e1556f..60c33ca2f 100644 --- a/lang/m2/comp/expression.g +++ b/lang/m2/comp/expression.g @@ -48,8 +48,7 @@ qualident(int types; struct def **pdf; char *str; struct node **p;) findname(nd); assert(nd->nd_class == Def); *pdf = df = nd->nd_def; - if (df->df_kind != D_ERROR && - !(types & df->df_kind)) { + if ( !((types|D_ERROR) & df->df_kind)) { error("identifier \"%s\" is not a %s", df->df_idf->id_text, str); } @@ -183,7 +182,11 @@ factor(struct node **p;) number(p) | STRING { *p = MkNode(Value, NULLNODE, NULLNODE, &dot); - (*p)->nd_type = string_type; + if (dot.TOK_SLE == 1) { + dot.TOK_INT = *(dot.TOK_STR); + (*p)->nd_type = char_type; + } + else (*p)->nd_type = string_type; } | '(' expression(p) ')' diff --git a/lang/m2/comp/type.H b/lang/m2/comp/type.H index d144e4458..8abf6981c 100644 --- a/lang/m2/comp/type.H +++ b/lang/m2/comp/type.H @@ -68,6 +68,9 @@ struct type { #define T_PROCEDURE 0x1000 #define T_ARRAY 0x2000 #define T_STRING 0x4000 +#define T_INTORCARD (T_INTEGER|T_CARDINAL) +#define T_DISCRETE (T_ENUMERATION|T_INTORCARD|T_CHAR) +#define T_NUMERIC (T_INTORCARD|T_REAL) int tp_align; /* alignment requirement of this type */ arith tp_size; /* size of this type */ union { diff --git a/lang/m2/comp/type.c b/lang/m2/comp/type.c index f509f0d06..7efa40a44 100644 --- a/lang/m2/comp/type.c +++ b/lang/m2/comp/type.c @@ -7,7 +7,6 @@ static char *RcsId = "$Header$"; #include #include #include "def_sizes.h" -#include "Lpars.h" #include "def.h" #include "type.h" #include "idf.h" @@ -141,7 +140,7 @@ init_types() real_type = standard_type(T_REAL, real_align, real_size); longreal_type = standard_type(T_REAL, lreal_align, lreal_size); word_type = standard_type(T_WORD, wrd_align, wrd_size); - intorcard_type = standard_type(T_INTEGER, int_align, int_size); + intorcard_type = standard_type(T_INTORCARD, int_align, int_size); string_type = standard_type(T_STRING, 1, (arith) -1); address_type = construct_type(T_POINTER, word_type); tp = construct_type(T_SUBRANGE, int_type); diff --git a/lang/m2/comp/typequiv.c b/lang/m2/comp/typequiv.c index 9cf8621ff..9c97fdd2c 100644 --- a/lang/m2/comp/typequiv.c +++ b/lang/m2/comp/typequiv.c @@ -6,16 +6,17 @@ static char *RcsId = "$Header$"; #include #include "type.h" #include "def.h" -#include "Lpars.h" int TstTypeEquiv(tp1, tp2) register struct type *tp1, *tp2; { - /* test if two types are equivalent. The only complication comes + /* test if two types are equivalent. A complication comes from the fact that for some procedures two declarations may be given: one in the specification module and one in the definition module. + A related problem is that two dynamic arrays with the + same base type are also equivalent. */ return tp1 == tp2 @@ -23,6 +24,18 @@ TstTypeEquiv(tp1, tp2) tp1 == error_type || tp2 == error_type + || + ( + tp1->tp_fund == T_ARRAY + && + tp1->next == 0 + && + tp2->tp_fund == T_ARRAY + && + tp2->next == 0 + && + TstTypeEquiv(tp1->arr_elem, tp2->arr_elem) + ) || ( tp1 && tp1->tp_fund == T_PROCEDURE -- 2.34.1