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\
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
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
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
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
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
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
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
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
#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
+ */
+
+
/* 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
-static char Version[] = "ACK Modula-2 compiler Version 0.20";
+static char Version[] = "ACK Modula-2 compiler Version 0.21";
#include "desig.h"
#include "walk.h"
#include "chk_expr.h"
+#include "def.h"
#include "density.h"
#include <assert.h>
#include <alloc.h>
+#include "strict3rd.h"
#include "Lpars.h"
#include "idf.h"
#include "type.h"
#include "chk_expr.h"
#include "misc.h"
#include "warning.h"
+#include "main.h"
extern char *symbol2str();
extern char *sprint();
}
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));
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;
}
STATIC int
-ChkArr(expp)
+ChkArr(expp, flags)
register t_node *expp;
{
/* Check an array selection.
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;
#endif
STATIC int
-ChkLinkOrName(expp)
+ChkLinkOrName(expp, flags)
register t_node *expp;
{
/* Check either an ID or a construction of the form
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.
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 ||
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;
*/
register t_def *df;
- if (! ChkLinkOrName(expp)) return 0;
+ if (! ChkLinkOrName(expp, D_USED)) return 0;
df = expp->nd_def;
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;
}
*/
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) {
/* 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.
*/
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) {
}
STATIC t_node *
-getvariable(argp, edf)
+getvariable(argp, edf, flags)
t_node **argp;
t_def *edf;
{
*/
register t_node *left = nextarg(argp, edf);
- if (!left || !ChkVariable(left)) return 0;
+ if (!left || !ChkVariable(left, flags)) return 0;
return left;
}
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;
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);
}
expp->nd_left = MkLeaf(Name, &dt);
}
return ChkCall(expp);
+#endif
case S_TSIZE: /* ??? */
case S_SIZE:
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);
}
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);
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)
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 */
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[];
*/
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:
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;
{
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);
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:
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 '+':
/* 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;
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 (! options['s']) expp->nd_INT--;
- }
- else if (expp->nd_type == longint_type) {
- expp->nd_INT = - max_longint;
+ 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->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;
break;
case S_SIZE:
- expp->nd_INT = expr->nd_type->tp_size;
+ expp->nd_INT = tp->tp_size;
break;
default:
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;
}
#include <alloc.h>
#include <assert.h>
+#include "strict3rd.h"
#include "idf.h"
#include "LLlex.h"
#include "def.h"
| /* 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);
}
]
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;
*/
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;
}
C_exp(buf);
}
else C_inp(buf);
+ df->df_flags |= D_DEFINED;
}
open_scope(OPENSCOPE);
scope = CurrentScope;
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\"",
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
*/
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);
}
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
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
*/
*/
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));
}
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.
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;
}
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;
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\"",
}
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;
+ }
}
#include <em_arith.h>
#include <em_label.h>
+#include "strict3rd.h"
#include "input.h"
#include "f_info.h"
#include "LLlex.h"
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;
#include <em_label.h>
#include <alloc.h>
+#include "strict3rd.h"
#include "input.h"
#include "f_info.h"
#include "idf.h"
#include <em_label.h>
#include <alloc.h>
+#include "strict3rd.h"
#include "type.h"
#include "main.h"
#include "warning.h"
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;
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;
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;
#include <em_arith.h>
#include <em_label.h>
+#include "strict3rd.h"
#include "main.h"
#include "idf.h"
#include "LLlex.h"
{ if (FromId) {
EnterFromImportList(ImportList, df, FromId);
}
- else EnterImportList(ImportList, local);
+ else if (local) EnterImportList(ImportList);
+ else EnterGlobalImportList(ImportList);
+ FreeNode(ImportList);
}
;
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 */
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);
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 {
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;
}
#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();
)
)
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,
node_error(*nd, ebuf1);
return 0;
}
-
+#endif
sprint(ebuf1, ebuf, "type incompatibility");
node_error(*nd, ebuf1);
return 0;
#include <assert.h>
#include <alloc.h>
+#include "strict3rd.h"
#include "squeeze.h"
#include "LLlex.h"
#include "def.h"
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)
/* 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
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));
TmpClose();
CurrVis = savevis;
+ WalkDefList(sc->sc_def, UseWarnings);
}
WalkProcedure(procedure)
/* Generate code for all local modules and procedures
*/
- WalkDef(sc->sc_def);
+ WalkDefList(sc->sc_def, WalkDef);
/* Generate code for this 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.
}
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);
}
}
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;
}
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);
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;
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);
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);
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;
}
}
}
}
+
+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);
+ }
+}
public / ack.git / commitdiff