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

New version, with an option for strict Modula-2, and

Browse source 
warnings for unused or uninitialized variables
This commit is contained in:
ceriel 1987-10-19 11:28:37 +00:00
parent 211d2bcfff
commit 503edee161
21 changed files with 341 additions and 196 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

13
lang/m2/comp/Makefile
View file

@ -40,7 +40,7 @@ OBJ = $(COBJ) $(LOBJ) Lpars.o
GENH= errout.h\
idfsize.h numsize.h strsize.h target_sizes.h \
inputtype.h maxset.h density.h squeeze.h \
def.h debugcst.h type.h Lpars.h node.h desig.h
def.h debugcst.h type.h Lpars.h node.h desig.h strict3rd.h
HFILES= LLlex.h\
chk_expr.h class.h const.h debug.h f_info.h idf.h\
input.h main.h misc.h scope.h standards.h tokenname.h\
@ -181,6 +181,7 @@ error.o: input.h
error.o: inputtype.h
error.o: main.h
error.o: node.h
error.o: strict3rd.h
error.o: warning.h
main.o: LLlex.h
main.o: Lpars.h
@ -195,6 +196,7 @@ main.o: inputtype.h
main.o: node.h
main.o: scope.h
main.o: standards.h
main.o: strict3rd.h
main.o: tokenname.h
main.o: type.h
main.o: warning.h
@ -264,7 +266,9 @@ typequiv.o: debug.h
typequiv.o: debugcst.h
typequiv.o: def.h
typequiv.o: idf.h
typequiv.o: main.h
typequiv.o: node.h
typequiv.o: strict3rd.h
typequiv.o: type.h
typequiv.o: warning.h
node.o: LLlex.h
@ -291,14 +295,17 @@ chk_expr.o: debug.h
chk_expr.o: debugcst.h
chk_expr.o: def.h
chk_expr.o: idf.h
chk_expr.o: main.h
chk_expr.o: misc.h
chk_expr.o: node.h
chk_expr.o: scope.h
chk_expr.o: standards.h
chk_expr.o: strict3rd.h
chk_expr.o: type.h
chk_expr.o: warning.h
options.o: idfsize.h
options.o: main.h
options.o: strict3rd.h
options.o: type.h
options.o: warning.h
walk.o: LLlex.h
@ -314,6 +321,7 @@ walk.o: main.h
walk.o: node.h
walk.o: scope.h
walk.o: squeeze.h
walk.o: strict3rd.h
walk.o: type.h
walk.o: walk.h
walk.o: warning.h
@ -360,6 +368,7 @@ program.o: idf.h
program.o: main.h
program.o: node.h
program.o: scope.h
program.o: strict3rd.h
program.o: type.h
program.o: warning.h
declar.o: LLlex.h
@ -373,6 +382,7 @@ declar.o: main.h
declar.o: misc.h
declar.o: node.h
declar.o: scope.h
declar.o: strict3rd.h
declar.o: type.h
declar.o: warning.h
expression.o: LLlex.h
@ -401,6 +411,7 @@ casestat.o: Lpars.h
casestat.o: chk_expr.h
casestat.o: debug.h
casestat.o: debugcst.h
casestat.o: def.h
casestat.o: density.h
casestat.o: desig.h
casestat.o: node.h

7
lang/m2/comp/Parameters
View file

@ -65,3 +65,10 @@
#undef SQUEEZE 1 /* define on "small" machines */
!File: strict3rd.h
#undef STRICT_3RD_ED 1 /* define on "small" machines, and if you want
a compiler that only implements "3rd edition"
Modula-2
*/

7
lang/m2/comp/SYSTEM.h
View file

@ -11,8 +11,15 @@
/* Text of SYSTEM module, for as far as it can be expressed in Modula-2 */
#ifndef STRICT_3RD_ED
#define SYSTEMTEXT "DEFINITION MODULE SYSTEM;\n\
TYPE PROCESS = ADDRESS;\n\
PROCEDURE NEWPROCESS(P:PROC; A:ADDRESS; n:CARDINAL; VAR p1:ADDRESS);\n\
PROCEDURE TRANSFER(VAR p1,p2:ADDRESS);\n\
END SYSTEM.\n"
#else
#define SYSTEMTEXT "DEFINITION MODULE SYSTEM;\n\
PROCEDURE NEWPROCESS(P:PROC; A:ADDRESS; n:CARDINAL; VAR p1:ADDRESS);\n\
PROCEDURE TRANSFER(VAR p1,p2:ADDRESS);\n\
END SYSTEM.\n"
#endif

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

@ -1 +1 @@
static char Version[] = "ACK Modula-2 compiler Version 0.20";
static char Version[] = "ACK Modula-2 compiler Version 0.21";

1
lang/m2/comp/casestat.C
View file

@ -32,6 +32,7 @@
#include "desig.h"
#include "walk.h"
#include "chk_expr.h"
#include "def.h"
#include "density.h"

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

@ -19,6 +19,7 @@
#include <assert.h>
#include <alloc.h>
#include "strict3rd.h"
#include "Lpars.h"
#include "idf.h"
#include "type.h"
@ -31,6 +32,7 @@
#include "chk_expr.h"
#include "misc.h"
#include "warning.h"
#include "main.h"
extern char *symbol2str();
extern char *sprint();
@ -125,14 +127,14 @@ MkCoercion(pnd, tp)
}
int
ChkVariable(expp)
ChkVariable(expp, flags)
register t_node *expp;
{
/* Check that "expp" indicates an item that can be
assigned to.
*/
return ChkDesignator(expp) &&
return ChkDesig(expp, flags) &&
( expp->nd_class != Def ||
( expp->nd_def->df_kind & (D_FIELD|D_VARIABLE)) ||
df_error(expp, "variable expected", expp->nd_def));
@ -152,7 +154,7 @@ ChkArrow(expp)
expp->nd_type = error_type;
if (! ChkVariable(expp->nd_right)) return 0;
if (! ChkVariable(expp->nd_right, D_USED)) return 0;
tp = expp->nd_right->nd_type;
@ -166,7 +168,7 @@ ChkArrow(expp)
}
STATIC int
ChkArr(expp)
ChkArr(expp, flags)
register t_node *expp;
{
/* Check an array selection.
@ -182,7 +184,7 @@ ChkArr(expp)
expp->nd_type = error_type;
if (! (ChkVariable(expp->nd_left) & ChkExpression(expp->nd_right))) {
if (! (ChkVariable(expp->nd_left, flags) & ChkExpression(expp->nd_right))) {
/* Bitwise and, because we want them both evaluated.
*/
return 0;
@ -225,7 +227,7 @@ ChkValue(expp)
#endif
STATIC int
ChkLinkOrName(expp)
ChkLinkOrName(expp, flags)
register t_node *expp;
{
/* Check either an ID or a construction of the form
@ -236,9 +238,10 @@ ChkLinkOrName(expp)
expp->nd_type = error_type;
if (expp->nd_class == Name) {
expp->nd_def = lookfor(expp, CurrVis, 1);
expp->nd_def = df = lookfor(expp, CurrVis, 1);
expp->nd_class = Def;
expp->nd_type = RemoveEqual(expp->nd_def->df_type);
expp->nd_type = RemoveEqual(df->df_type);
df->df_flags |= flags;
}
else if (expp->nd_class == Link) {
/* A selection from a record or a module.
@ -248,7 +251,7 @@ ChkLinkOrName(expp)
assert(expp->nd_symb == '.');
if (! ChkDesignator(left)) return 0;
if (! ChkDesig(left, flags)) return 0;
if (left->nd_class==Def &&
(left->nd_type->tp_fund != T_RECORD ||
@ -266,6 +269,7 @@ ChkLinkOrName(expp)
id_not_declared(expp);
return 0;
}
df->df_flags |= flags;
expp->nd_def = df;
expp->nd_type = RemoveEqual(df->df_type);
expp->nd_class = Def;
@ -300,7 +304,7 @@ ChkExLinkOrName(expp)
*/
register t_def *df;
if (! ChkLinkOrName(expp)) return 0;
if (! ChkLinkOrName(expp, D_USED)) return 0;
df = expp->nd_def;
@ -537,7 +541,7 @@ getarg(argp, bases, designator, edf)
register t_node *left = nextarg(argp, edf);
if (! left ||
! (designator ? ChkVariable(left) : ChkExpression(left))) {
! (designator ? ChkVariable(left, D_USED|D_DEFINED) : ChkExpression(left))) {
return 0;
}
@ -616,7 +620,9 @@ ChkProcCall(expp)
*/
for (param = ParamList(left->nd_type); param; param = param->par_next) {
if (!(left = getarg(&expp, 0, IsVarParam(param), edf))) {
return 0;
retval = 0;
cnt++;
continue;
}
cnt++;
if (left->nd_symb == STRING) {
@ -673,7 +679,7 @@ ChkCall(expp)
/* First, get the name of the function or procedure
*/
if (ChkDesignator(left)) {
if (ChkDesig(left, D_USED)) {
if (IsCast(left)) {
/* It was a type cast.
*/
@ -920,8 +926,8 @@ ChkUnOper(expp)
return 1;
case '-':
if (tpr->tp_fund & T_INTORCARD) {
if (tpr == intorcard_type || tpr == card_type) {
if (tpr->tp_fund == T_INTORCARD || tpr->tp_fund == T_INTEGER) {
if (tpr == intorcard_type) {
expp->nd_type = int_type;
}
if (right->nd_class == Value) {
@ -957,7 +963,7 @@ ChkUnOper(expp)
}
STATIC t_node *
getvariable(argp, edf)
getvariable(argp, edf, flags)
t_node **argp;
t_def *edf;
{
@ -966,7 +972,7 @@ getvariable(argp, edf)
*/
register t_node *left = nextarg(argp, edf);
if (!left || !ChkVariable(left)) return 0;
if (!left || !ChkVariable(left, flags)) return 0;
return left;
}
@ -1072,6 +1078,7 @@ ChkStandard(expp)
if (left->nd_type->tp_fund == T_ARRAY) {
expp->nd_type = IndexType(left->nd_type);
if (! IsConformantArray(left->nd_type)) {
left->nd_type = expp->nd_type;
cstcall(expp, S_MAX);
}
break;
@ -1120,11 +1127,19 @@ ChkStandard(expp)
if (!warning_given) {
warning_given = 1;
#ifndef STRICT_3RD_ED
if (! options['3'])
node_warning(expp, W_OLDFASHIONED, "NEW and DISPOSE are obsolete");
else
#endif
node_error(expp, "NEW and DISPOSE are obsolete");
}
}
#ifdef STRICT_3RD_ED
return 0;
#else
expp->nd_type = 0;
if (! (left = getvariable(&arg, edf))) return 0;
if (! (left = getvariable(&arg, edf,D_DEFINED))) return 0;
if (! (left->nd_type->tp_fund == T_POINTER)) {
return df_error(left, "pointer variable expected", edf);
}
@ -1150,6 +1165,7 @@ ChkStandard(expp)
expp->nd_left = MkLeaf(Name, &dt);
}
return ChkCall(expp);
#endif
case S_TSIZE: /* ??? */
case S_SIZE:
@ -1197,7 +1213,7 @@ ChkStandard(expp)
case S_DEC:
case S_INC:
expp->nd_type = 0;
if (! (left = getvariable(&arg, edf))) return 0;
if (! (left = getvariable(&arg, edf, D_USED|D_DEFINED))) return 0;
if (! (left->nd_type->tp_fund & T_DISCRETE)) {
return df_error(left,"illegal parameter type", edf);
}
@ -1217,7 +1233,7 @@ ChkStandard(expp)
t_node *dummy;
expp->nd_type = 0;
if (!(left = getvariable(&arg, edf))) return 0;
if (!(left = getvariable(&arg, edf, D_USED|D_DEFINED))) return 0;
tp = left->nd_type;
if (tp->tp_fund != T_SET) {
return df_error(arg, "SET parameter expected", edf);

5
lang/m2/comp/chk_expr.h
View file

@ -16,8 +16,9 @@ extern int (*DesigChkTable[])(); /* table of designator checking
functions, indexed by node class
*/
#define ChkExpression(expp) ((*ExprChkTable[(expp)->nd_class])(expp))
#define ChkDesignator(expp) ((*DesigChkTable[(expp)->nd_class])(expp))
#define ChkExpression(expp) ((*ExprChkTable[(expp)->nd_class])(expp,D_USED))
#define ChkDesignator(expp) ((*DesigChkTable[(expp)->nd_class])(expp,0))
#define ChkDesig(expp, flags) ((*DesigChkTable[(expp)->nd_class])(expp,flags))
#define inc_refcount(s) (*((s) - 1) += 1)
#define dec_refcount(s) (*((s) - 1) -= 1)

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

@ -14,8 +14,6 @@ extern long
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_longint; /* maximum longint on target machine */
max_int; /* maximum integer on target machine */
extern unsigned int
wrd_bits; /* Number of bits in a word */

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

@ -29,8 +29,6 @@ int mach_long_size; /* size of long on this machine == sizeof(long) */
long full_mask[MAXSIZE];/* full_mask[1] == 0xFF, full_mask[2] == 0xFFFF, .. */
long int_mask[MAXSIZE]; /* int_mask[1] == 0x7F, int_mask[2] == 0x7FFF, .. */
arith max_int; /* maximum integer on target machine */
arith max_unsigned; /* maximum unsigned on target machine */
arith max_longint; /* maximum longint on target machine */
unsigned int wrd_bits; /* number of bits in a word */
extern char options[];
@ -52,10 +50,10 @@ cstunary(expp)
*/
case '-':
if (right->nd_INT < -int_mask[(int)(right->nd_type->tp_size)])
node_warning(expp, W_ORDINARY, ovflow);
expp->nd_INT = -right->nd_INT;
if (expp->nd_type->tp_fund == T_INTORCARD) {
expp->nd_type = int_type;
}
break;
case NOT:
@ -74,6 +72,62 @@ cstunary(expp)
expp->nd_right = 0;
}
STATIC
divide(pdiv, prem, uns)
arith *pdiv, *prem;
{
/* Divide *pdiv by *prem, and store result in *pdiv,
remainder in *prem
*/
register arith o1 = *pdiv;
register arith o2 = *prem;
if (uns) {
/* this is more of a problem than you might
think on C compilers which do not have
unsigned long.
*/
if (o2 & mach_long_sign) {/* o2 > max_long */
if (! (o1 >= 0 || o1 < o2)) {
/* this is the unsigned test
o1 < o2 for o2 > max_long
*/
*prem = o2 - o1;
*pdiv = 1;
}
else {
*pdiv = 0;
}
}
else { /* o2 <= max_long */
long half, bit, hdiv, hrem, rem;
half = (o1 >> 1) & ~mach_long_sign;
bit = o1 & 01;
/* now o1 == 2 * half + bit
and half <= max_long
and bit <= max_long
*/
hdiv = half / o2;
hrem = half % o2;
rem = 2 * hrem + bit;
*pdiv = 2*hdiv;
*prem = rem;
if (rem < 0 || rem >= o2) {
/* that is the unsigned compare
rem >= o2 for o2 <= max_long
*/
*pdiv += 1;
*prem -= o2;
}
}
}
else {
*pdiv = o1 / o2; /* ??? */
*prem = o1 - *pdiv * o2;
}
}
cstbin(expp)
register t_node *expp;
{
@ -81,8 +135,8 @@ cstbin(expp)
expressions below it, and the result restored in
expp.
*/
register arith o1 = expp->nd_left->nd_INT;
register arith o2 = expp->nd_right->nd_INT;
arith o1 = expp->nd_left->nd_INT;
arith o2 = expp->nd_right->nd_INT;
register int uns = expp->nd_left->nd_type != int_type;
assert(expp->nd_class == Oper);
@ -99,37 +153,7 @@ cstbin(expp)
node_error(expp, "division by 0");
return;
}
if (uns) {
/* this is more of a problem than you might
think on C compilers which do not have
unsigned long.
*/
if (o2 & mach_long_sign) {/* o2 > max_long */
o1 = ! (o1 >= 0 || o1 < o2);
/* this is the unsigned test
o1 < o2 for o2 > max_long
*/
}
else { /* o2 <= max_long */
long half, bit, hdiv, hrem, rem;
half = (o1 >> 1) & ~mach_long_sign;
bit = o1 & 01;
/* now o1 == 2 * half + bit
and half <= max_long
and bit <= max_long
*/
hdiv = half / o2;
hrem = half % o2;
rem = 2 * hrem + bit;
o1 = 2 * hdiv + (rem < 0 || rem >= o2);
/* that is the unsigned compare
rem >= o2 for o2 <= max_long
*/
}
}
else
o1 /= o2;
divide(&o1, &o2, uns);
break;
case MOD:
@ -137,29 +161,8 @@ cstbin(expp)
node_error(expp, "modulo by 0");
return;
}
if (uns) {
if (o2 & mach_long_sign) {/* o2 > max_long */
o1 = (o1 >= 0 || o1 < o2) ? o1 : o1 - o2;
/* this is the unsigned test
o1 < o2 for o2 > max_long
*/
}
else { /* o2 <= max_long */
long half, bit, hrem, rem;
half = (o1 >> 1) & ~mach_long_sign;
bit = o1 & 01;
/* now o1 == 2 * half + bit
and half <= max_long
and bit <= max_long
*/
hrem = half % o2;
rem = 2 * hrem + bit;
o1 = (rem < 0 || rem >= o2) ? rem - o2 : rem;
}
}
else
o1 %= o2;
divide(&o1, &o2, uns);
o1 = o2;
break;
case '+':
@ -343,15 +346,15 @@ cstcall(expp, call)
/* a standard procedure call is found that can be evaluated
compile time, so do so.
*/
register t_node *expr = 0;
register t_node *expr;
register t_type *tp;
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);
}
expr = expp->nd_right->nd_left;
expp->nd_right->nd_left = 0;
FreeNode(expp->nd_right);
tp = expr->nd_type;
expp->nd_class = Value;
expp->nd_symb = INTEGER;
@ -370,32 +373,25 @@ cstcall(expp, call)
break;
case S_MAX:
if (expp->nd_type == int_type) {
expp->nd_INT = max_int;
if (tp->tp_fund == T_INTEGER) {
expp->nd_INT = int_mask[(int)(tp->tp_size)];
}
else if (expp->nd_type == longint_type) {
expp->nd_INT = max_longint;
else if (tp == card_type) {
expp->nd_INT = full_mask[(int)(int_size)];
}
else if (expp->nd_type == card_type) {
expp->nd_INT = max_unsigned;
else if (tp->tp_fund == T_SUBRANGE) {
expp->nd_INT = tp->sub_ub;
}
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;
else expp->nd_INT = tp->enm_ncst - 1;
break;
case S_MIN:
if (expp->nd_type == int_type) {
expp->nd_INT = -max_int;
if (tp->tp_fund == T_INTEGER) {
expp->nd_INT = -int_mask[(int)(tp->tp_size)];
if (! options['s']) expp->nd_INT--;
}
else if (expp->nd_type == longint_type) {
expp->nd_INT = - max_longint;
if (! options['s']) expp->nd_INT--;
}
else if (expp->nd_type->tp_fund == T_SUBRANGE) {
expp->nd_INT = expp->nd_type->sub_lb;
else if (tp->tp_fund == T_SUBRANGE) {
expp->nd_INT = tp->sub_lb;
}
else expp->nd_INT = 0;
break;
@ -405,7 +401,7 @@ cstcall(expp, call)
break;
case S_SIZE:
expp->nd_INT = expr->nd_type->tp_size;
expp->nd_INT = tp->tp_size;
break;
default:
@ -466,8 +462,6 @@ InitCst()
fatal("sizeof (long) insufficient on this machine");
}
max_int = int_mask[int_size];
max_unsigned = full_mask[int_size];
max_longint = int_mask[long_size];
max_int = int_mask[(int)int_size];
wrd_bits = 8 * (unsigned) word_size;
}

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

@ -17,6 +17,7 @@
#include <alloc.h>
#include <assert.h>
#include "strict3rd.h"
#include "idf.h"
#include "LLlex.h"
#include "def.h"
@ -336,8 +337,13 @@ FieldList(t_scope *scope; arith *cnt; int *palign;)
| /* Old fashioned! the first qualident now represents
the type
*/
{ warning(W_OLDFASHIONED,
{
#ifndef STRICT_3RD_ED
if (! options['3']) warning(W_OLDFASHIONED,
"old fashioned Modula-2 syntax; ':' missing");
else
#endif
error("':' missing");
tp = qualified_type(nd);
}
]

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

@ -73,6 +73,7 @@ MkDef(id, scope, kind)
df->df_scope = scope;
df->df_kind = kind;
df->df_next = id->id_def;
df->df_flags = D_USED | D_DEFINED;
id->id_def = df;
if (kind == D_ERROR || kind == D_FORWARD) df->df_type = error_type;
@ -241,6 +242,7 @@ DeclProc(type, id)
*/
df = define(id, CurrentScope, type);
df->for_node = dot2leaf(Name);
df->df_flags |= D_USED | D_DEFINED;
if (CurrentScope->sc_definedby->df_flags & D_FOREIGN) {
df->for_name = id->id_text;
}
@ -275,6 +277,7 @@ DeclProc(type, id)
C_exp(buf);
}
else C_inp(buf);
df->df_flags |= D_DEFINED;
}
open_scope(OPENSCOPE);
scope = CurrentScope;
@ -360,11 +363,12 @@ CheckWithDef(df, tp)
possible earlier definition in the definition module.
*/
if (df->df_kind == D_PROCHEAD && df->df_type != error_type) {
if (df->df_kind == D_PROCHEAD &&
df->df_type &&
df->df_type != error_type) {
/* We already saw a definition of this type
in the definition module.
*/
assert(df->df_type != 0);
if (!TstProcEquiv(tp, df->df_type)) {
error("inconsistent procedure declaration for \"%s\"",

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

@ -129,6 +129,7 @@ EnterVarList(Idlist, type, local)
for (; idlist; idlist = idlist->nd_right) {
df = define(idlist->nd_IDF, CurrentScope, D_VARIABLE);
df->df_type = type;
df->df_flags &= ~(D_USED | D_DEFINED);
if (idlist->nd_left) {
/* An address was supplied
*/
@ -166,6 +167,7 @@ EnterVarList(Idlist, type, local)
df->df_flags |= D_NOREG;
if (DefinitionModule) {
df->df_flags |= D_USED | D_DEFINED;
if (sc == Defined->mod_vis) {
C_exa_dnam(df->var_name);
}
@ -212,7 +214,8 @@ EnterParamList(ppr, Idlist, type, VARp, off)
else df = new_def();
pr->par_def = df;
df->df_type = type;
df->df_flags = VARp;
df->df_flags |= (VARp | D_DEFINED);
if (df->df_flags & D_VARPAR) df->df_flags |= D_USED;
if (IsConformantArray(type)) {
/* we need room for the base address and a descriptor
@ -240,6 +243,10 @@ DoImport(df, scope)
define(df->df_idf, scope, D_IMPORT)->imp_def = df;
while (df->df_kind == D_IMPORT) {
df = df->imp_def;
}
if (df->df_kind == D_TYPE && df->df_type->tp_fund == T_ENUMERATION) {
/* Also import all enumeration literals
*/
@ -305,7 +312,7 @@ ForwDef(ids, scope)
*/
register t_def *df;
if (!(df = lookup(ids->nd_IDF, scope, 1))) {
if (!(df = lookup(ids->nd_IDF, scope, 0))) {
df = define(ids->nd_IDF, scope, D_FORWARD);
df->for_node = MkLeaf(Name, &(ids->nd_token));
}
@ -341,8 +348,6 @@ EnterExportList(Idlist, qualified)
idlist->nd_IDF->id_text);
}
if (df->df_kind == D_IMPORT) df = df->imp_def;
df->df_flags |= qualified;
if (qualified == D_EXPORTED) {
/* Export, but not qualified.
@ -368,15 +373,20 @@ EnterExportList(Idlist, qualified)
scope. There are two legal possibilities,
which are examined below.
*/
t_def *df2 = df;
while (df2->df_kind == D_IMPORT) {
df2 = df2->imp_def;
}
if (df1->df_kind == D_PROCHEAD &&
df->df_kind == D_PROCEDURE) {
df2->df_kind == D_PROCEDURE) {
df1->df_kind = D_IMPORT;
df1->imp_def = df;
continue;
}
if (df1->df_kind == D_HIDDEN &&
df->df_kind == D_TYPE) {
DeclareType(idlist, df1, df->df_type);
df2->df_kind == D_TYPE) {
DeclareType(idlist, df1, df2->df_type);
df1->df_kind = D_TYPE;
continue;
}
@ -388,14 +398,13 @@ EnterExportList(Idlist, qualified)
FreeNode(Idlist);
}
EnterFromImportList(Idlist, FromDef, FromId)
t_node *Idlist;
EnterFromImportList(idlist, FromDef, FromId)
register t_node *idlist;
register t_def *FromDef;
t_node *FromId;
{
/* Import the list Idlist from the module indicated by Fromdef.
*/
register t_node *idlist = Idlist;
register t_scopelist *vis;
register t_def *df;
char *module_name = FromDef->df_idf->id_text;
@ -430,7 +439,7 @@ node_error(FromId,"identifier \"%s\" does not represent a module",module_name);
for (; idlist; idlist = idlist->nd_left) {
if (forwflag) df = ForwDef(idlist, vis->sc_scope);
else if (! (df = lookup(idlist->nd_IDF, vis->sc_scope, 1))) {
else if (! (df = lookup(idlist->nd_IDF, vis->sc_scope, 0))) {
if (! is_anon_idf(idlist->nd_IDF)) {
node_error(idlist,
"identifier \"%s\" not declared in module \"%s\"",
@ -450,30 +459,38 @@ node_error(FromId,"identifier \"%s\" does not represent a module",module_name);
}
if (!forwflag) FreeNode(FromId);
FreeNode(Idlist);
}
EnterImportList(Idlist, local)
t_node *Idlist;
EnterGlobalImportList(idlist)
register t_node *idlist;
{
/* Import "Idlist" from the enclosing scope.
An exception must be made for imports of the compilation unit.
In this case, definition modules must be read for "Idlist".
This case is indicated by the value 0 of the "local" flag.
/* Import "idlist" from the enclosing scope.
Definition modules must be read for "idlist".
*/
register t_node *idlist = Idlist;
t_scope *sc = enclosing(CurrVis)->sc_scope;
extern t_def *GetDefinitionModule();
struct f_info f;
f = file_info;
for (; idlist; idlist = idlist->nd_left) {
DoImport(local ?
ForwDef(idlist, sc) :
GetDefinitionModule(idlist->nd_IDF, 1) ,
CurrentScope);
DoImport(GetDefinitionModule(idlist->nd_IDF, 1), CurrentScope);
file_info = f;
}
FreeNode(Idlist);
}
EnterImportList(idlist)
register t_node *idlist;
{
/* Import "idlist" from the enclosing scope.
*/
t_scope *sc = enclosing(CurrVis)->sc_scope;
extern t_def *GetDefinitionModule();
for (; idlist; idlist = idlist->nd_left) {
t_def *df;
DoImport(ForwDef(idlist, sc), CurrentScope);
df = lookup(idlist->nd_def, CurrentScope, 0);
df->df_flags |= D_EXPORTED;
}
}

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

@ -21,6 +21,7 @@
#include <em_arith.h>
#include <em_label.h>
#include "strict3rd.h"
#include "input.h"
#include "f_info.h"
#include "LLlex.h"
@ -170,9 +171,11 @@ _error(class, node, fmt, argv)
case WARNING:
case LEXWARNING:
switch(warn_class) {
#ifndef STRICT_3RD_ED
case W_OLDFASHIONED:
remark = "(old-fashioned use)";
break;
#endif
case W_STRICT:
remark = "(strict)";
break;

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

@ -16,6 +16,7 @@
#include <em_label.h>
#include <alloc.h>
#include "strict3rd.h"
#include "input.h"
#include "f_info.h"
#include "idf.h"

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

@ -15,6 +15,7 @@
#include <em_label.h>
#include <alloc.h>
#include "strict3rd.h"
#include "type.h"
#include "main.h"
#include "warning.h"
@ -44,6 +45,9 @@ DoOption(text)
case 'n': /* no register messages */
case 'x': /* every name global */
case 's': /* symmetric: MIN(INTEGER) = -MAX(INTEGER) */
#ifndef STRICT_3RD_ED
case '3': /* strict 3rd edition Modula-2 */
#endif
options[text[-1]]++;
break;
@ -64,9 +68,11 @@ DoOption(text)
if (*text) {
while (*text) {
switch(*text++) {
#ifndef STRICT_3RD_ED
case 'O':
warning_classes &= ~W_OLDFASHIONED;
break;
#endif
case 'R':
warning_classes &= ~W_STRICT;
break;
@ -83,9 +89,11 @@ DoOption(text)
if (*text) {
while (*text) {
switch(*text++) {
#ifndef STRICT_3RD_ED
case 'O':
warning_classes |= W_OLDFASHIONED;
break;
#endif
case 'R':
warning_classes |= W_STRICT;
break;

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

@ -16,6 +16,7 @@
#include <em_arith.h>
#include <em_label.h>
#include "strict3rd.h"
#include "main.h"
#include "idf.h"
#include "LLlex.h"
@ -114,7 +115,9 @@ import(int local;)
{ if (FromId) {
EnterFromImportList(ImportList, df, FromId);
}
else EnterImportList(ImportList, local);
else if (local) EnterImportList(ImportList);
else EnterGlobalImportList(ImportList);
FreeNode(ImportList);
}
;
@ -150,8 +153,13 @@ DefinitionModule
modules. Issue a warning.
*/
{
#ifndef STRICT_3RD_ED
if (! options['3'])
node_warning(exportlist, W_OLDFASHIONED, "export list in definition module ignored");
FreeNode(exportlist);
else
#endif
error("export list not allowed in definition module");
FreeNode(exportlist);
}
|
/* empty */

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

@ -217,6 +217,10 @@ close_scope(flag)
assert(sc != 0);
if (! sc->sc_end) {
sc->sc_end = dot2leaf(Link);
}
if (flag) {
DO_DEBUG(options['S'],(print("List of definitions in currently ended scope:\n"), DumpScope(sc->sc_def)));
if (flag & SC_CHKPROC) chk_proc(sc->sc_def);

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

@ -30,6 +30,7 @@ struct scope {
char sc_scopeclosed; /* flag indicating closed or open scope */
int sc_level; /* level of this scope */
struct def *sc_definedby; /* The def structure defining this scope */
struct node *sc_end; /* node to remember line number of end of scope */
};
struct scopelist {

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

@ -611,7 +611,7 @@ type_or_forward(ptp)
in this scope, so this is the correct identification
*/
if (df1->df_kind == D_FORWTYPE) {
nd = dot2node(NULLNODE, df1->df_forw_node, 0);
nd = dot2node(0, NULLNODE, df1->df_forw_node);
df1->df_forw_node = nd;
nd->nd_type = *ptp;
}

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

@ -18,12 +18,14 @@
#include <em_label.h>
#include <assert.h>
#include "strict3rd.h"
#include "type.h"
#include "LLlex.h"
#include "idf.h"
#include "def.h"
#include "node.h"
#include "warning.h"
#include "main.h"
extern char *sprint();
@ -239,7 +241,8 @@ TstParCompat(parno, formaltype, VARflag, nd, edf)
)
)
return 1;
if (VARflag && TstCompat(formaltype, actualtype)) {
#ifndef STRICT_3RD_ED
if (! options['3'] && VARflag && TstCompat(formaltype, actualtype)) {
if (formaltype->tp_size == actualtype->tp_size) {
sprint(ebuf1, ebuf, "identical types required");
node_warning(*nd,
@ -251,7 +254,7 @@ TstParCompat(parno, formaltype, VARflag, nd, edf)
node_error(*nd, ebuf1);
return 0;
}
#endif
sprint(ebuf1, ebuf, "type incompatibility");
node_error(*nd, ebuf1);
return 0;

149
lang/m2/comp/walk.c
View file

@ -23,6 +23,7 @@
#include <assert.h>
#include <alloc.h>
#include "strict3rd.h"
#include "squeeze.h"
#include "LLlex.h"
#include "def.h"
@ -40,14 +41,22 @@
extern arith NewPtr();
extern arith NewInt();
extern int proclevel;
label text_label;
label data_label = 1;
static t_type *func_type;
struct withdesig *WithDesigs;
t_node *Modules;
t_node *Modules;
static t_type *func_type;
static arith priority;
static int RegisterMessage();
static int WalkDef();
static int MkCalls();
static int UseWarnings();
#define NO_EXIT_LABEL ((label) 0)
#define RETURN_LABEL ((label) 1)
@ -119,7 +128,7 @@ WalkModule(module)
/* Walk through it's local definitions
*/
WalkDef(sc->sc_def);
WalkDefList(sc->sc_def, WalkDef);
/* Now, generate initialization code for this module.
First call initialization routines for modules defined within
@ -156,7 +165,7 @@ WalkModule(module)
C_cal(nd->nd_IDF->id_text);
}
}
MkCalls(sc->sc_def);
WalkDefList(sc->sc_def, MkCalls);
proclevel++;
WalkNode(module->mod_body, NO_EXIT_LABEL);
DO_DEBUG(options['X'], PrNode(module->mod_body, 0));
@ -168,6 +177,7 @@ WalkModule(module)
TmpClose();
CurrVis = savevis;
WalkDefList(sc->sc_def, UseWarnings);
}
WalkProcedure(procedure)
@ -190,7 +200,7 @@ WalkProcedure(procedure)
/* Generate code for all local modules and procedures
*/
WalkDef(sc->sc_def);
WalkDefList(sc->sc_def, WalkDef);
/* Generate code for this procedure
*/
@ -221,7 +231,7 @@ WalkProcedure(procedure)
/* Generate calls to initialization routines of modules defined within
this procedure
*/
MkCalls(sc->sc_def);
WalkDefList(sc->sc_def, MkCalls);
/* Make sure that arguments of size < word_size are on a
fixed place.
@ -327,54 +337,53 @@ WalkProcedure(procedure)
}
EndPriority();
C_ret(func_res_size);
if (! options['n']) RegisterMessages(sc->sc_def);
if (! options['n']) WalkDefList(sc->sc_def, RegisterMessage);
C_end(-sc->sc_off);
TmpClose();
CurrVis = savevis;
proclevel--;
WalkDefList(sc->sc_def, UseWarnings);
}
static int
WalkDef(df)
register t_def *df;
{
/* Walk through a list of definitions
*/
for ( ; df; df = df->df_nextinscope) {
switch(df->df_kind) {
case D_MODULE:
WalkModule(df);
break;
case D_PROCEDURE:
WalkProcedure(df);
break;
case D_VARIABLE:
if (!proclevel && !(df->df_flags & D_ADDRGIVEN)) {
C_df_dnam(df->var_name);
C_bss_cst(
WA(df->df_type->tp_size),
(arith) 0, 0);
}
break;
default:
/* nothing */
;
switch(df->df_kind) {
case D_MODULE:
WalkModule(df);
break;
case D_PROCEDURE:
WalkProcedure(df);
break;
case D_VARIABLE:
if (!proclevel && !(df->df_flags & D_ADDRGIVEN)) {
C_df_dnam(df->var_name);
C_bss_cst(
WA(df->df_type->tp_size),
(arith) 0, 0);
}
break;
default:
/* nothing */
;
}
}
static int
MkCalls(df)
register t_def *df;
{
/* Generate calls to initialization routines of modules
*/
for ( ; df; df = df->df_nextinscope) {
if (df->df_kind == D_MODULE) {
C_lxl((arith) 0);
C_cal(df->mod_vis->sc_scope->sc_name);
C_asp(pointer_size);
}
if (df->df_kind == D_MODULE) {
C_lxl((arith) 0);
C_cal(df->mod_vis->sc_scope->sc_name);
C_asp(pointer_size);
}
}
@ -579,7 +588,7 @@ WalkStat(nd, exit_label)
struct withdesig wds;
t_desig ds;
if (! WalkDesignator(left, &ds)) break;
if (! WalkDesignator(left, &ds, D_USED|D_DEFINED)) break;
if (left->nd_type->tp_fund != T_RECORD) {
node_error(left, "record variable expected");
break;
@ -686,14 +695,14 @@ ExpectBool(nd, true_label, false_label)
}
int
WalkDesignator(nd, ds)
WalkDesignator(nd, ds, flags)
t_node *nd;
t_desig *ds;
{
/* Check designator and generate code for it
*/
if (! ChkVariable(nd)) return 0;
if (! ChkVariable(nd, flags)) return 0;
clear((char *) ds, sizeof(t_desig));
CodeDesig(nd, ds);
@ -711,7 +720,7 @@ DoForInit(nd)
nd->nd_class = Name;
nd->nd_symb = IDENT;
if (!( ChkVariable(nd) &
if (!( ChkVariable(nd, D_USED|D_DEFINED) &
ChkExpression(left->nd_left) &
ChkExpression(left->nd_right))) return 0;
@ -749,13 +758,22 @@ DoForInit(nd)
tpl = left->nd_left->nd_type;
tpr = left->nd_right->nd_type;
if (!ChkAssCompat(&(left->nd_left), df->df_type, "FOR statement") ||
!ChkAssCompat(&(left->nd_right), BaseType(df->df_type), "FOR statement")) {
#ifndef STRICT_3RD_ED
if (! options['3']) {
if (!ChkAssCompat(&(left->nd_left), df->df_type, "FOR statement") ||
!ChkAssCompat(&(left->nd_right), BaseType(df->df_type), "FOR statement")) {
return 1;
}
if (!TstCompat(df->df_type, tpl) ||
!TstCompat(df->df_type, tpr)) {
}
if (!TstCompat(df->df_type, tpl) ||
!TstCompat(df->df_type, tpr)) {
node_warning(nd, W_OLDFASHIONED, "compatibility required in FOR statement");
node_error(nd, "compatibility required in FOR statement");
}
} else
#endif
if (!ChkCompat(&(left->nd_left), df->df_type, "FOR statement") ||
!ChkCompat(&(left->nd_right), BaseType(df->df_type), "FOR statement")) {
return 1;
}
CodePExpr(left->nd_left);
@ -774,7 +792,7 @@ DoAssign(left, right)
register t_desig *dsr;
register t_type *tp;
if (! (ChkExpression(right) & ChkVariable(left))) return;
if (! (ChkExpression(right) & ChkVariable(left, D_DEFINED))) return;
tp = left->nd_type;
if (right->nd_symb == STRING) TryToString(right, tp);
@ -798,20 +816,22 @@ DoAssign(left, right)
free_desig(dsr);
}
RegisterMessages(df)
static int
RegisterMessage(df)
register t_def *df;
{
register t_type *tp;
arith sz;
int regtype = -1;
int regtype;
for (; df; df = df->df_nextinscope) {
if (df->df_kind == D_VARIABLE && !(df->df_flags & D_NOREG)) {
if (df->df_kind == D_VARIABLE) {
if ( !(df->df_flags & D_NOREG)) {
/* Examine type and size
*/
regtype = -1;
tp = BaseType(df->df_type);
if ((df->df_flags & D_VARPAR) ||
(tp->tp_fund & (T_POINTER|T_HIDDEN|T_EQUAL))) {
(tp->tp_fund&(T_POINTER|T_HIDDEN|T_EQUAL))) {
sz = pointer_size;
regtype = reg_pointer;
}
@ -826,3 +846,38 @@ RegisterMessages(df)
}
}
}
static int
UseWarnings(df)
register t_def *df;
{
if (df->df_kind & (D_IMPORT | D_VARIABLE | D_PROCEDURE)) {
struct node *nd;
if (df->df_flags & (D_EXPORTED | D_QEXPORTED)) return;
if (df->df_kind == D_IMPORT) df = df->imp_def;
if (! (df->df_kind & (D_VARIABLE|D_PROCEDURE))) return;
nd = df->df_scope->sc_end;
if (! (df->df_flags & D_DEFINED)) {
node_warning(nd,
W_ORDINARY,
"identifier \"%s\" never assigned",
df->df_idf->id_text);
}
if (! (df->df_flags & D_USED)) {
node_warning(nd,
W_ORDINARY,
"identifier \"%s\" never used",
df->df_idf->id_text);
}
}
}
WalkDefList(df, proc)
register t_def *df;
int (*proc)();
{
for (; df; df = df->df_nextinscope) {
(*proc)(df);
}
}