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

many minor corrections

Browse source
This commit is contained in:
ceriel 1987-05-18 15:57:33 +00:00
parent e0c3807b29
commit 946006fb08
15 changed files with 193 additions and 186 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

9
lang/m2/comp/LLlex.c
View file

@ -156,13 +156,6 @@ getch()
return ch; return ch;
} }
STATIC
linedirective() {
/* Read a line directive
*/
register int ch;
}
CheckForLineDirective() CheckForLineDirective()
{ {
register int ch = getch(); register int ch = getch();
@ -529,7 +522,7 @@ lexwarning(W_ORDINARY, "character constant out of range");
tk->TOK_REL = Salloc("0.0", 5); tk->TOK_REL = Salloc("0.0", 5);
lexerror("floating constant too long"); lexerror("floating constant too long");
} }
else tk->TOK_REL = Salloc(buf, np - buf) + 1; else tk->TOK_REL = Salloc(buf, (unsigned) (np - buf)) + 1;
toktype = real_type; toktype = real_type;
return tk->tk_symb = REAL; return tk->tk_symb = REAL;

70
lang/m2/comp/Makefile
View file

@ -20,7 +20,7 @@ PROFILE =
CFLAGS = $(PROFILE) $(INCLUDES) -O -DSTATIC= CFLAGS = $(PROFILE) $(INCLUDES) -O -DSTATIC=
LINTFLAGS = -DSTATIC= -DNORCSID LINTFLAGS = -DSTATIC= -DNORCSID
MALLOC = $(LIBDIR)/malloc.o MALLOC = $(LIBDIR)/malloc.o
LFLAGS = $(PROFILE) LDFLAGS = -i $(PROFILE)
LSRC = tokenfile.c program.c declar.c expression.c statement.c LSRC = tokenfile.c program.c declar.c expression.c statement.c
LOBJ = tokenfile.o program.o declar.o expression.o statement.o LOBJ = tokenfile.o program.o declar.o expression.o statement.o
CSRC = LLlex.c LLmessage.c error.c main.c \ CSRC = LLlex.c LLmessage.c error.c main.c \
@ -34,7 +34,7 @@ COBJ = LLlex.o LLmessage.o char.o error.o main.o \
cstoper.o chk_expr.o options.o walk.o casestat.o desig.o \ cstoper.o chk_expr.o options.o walk.o casestat.o desig.o \
code.o tmpvar.o lookup.o Version.o next.o code.o tmpvar.o lookup.o Version.o next.o
GENC= $(LSRC) symbol2str.c char.c Lpars.c casestat.c tmpvar.c scope.c next.c GENC= $(LSRC) symbol2str.c char.c Lpars.c casestat.c tmpvar.c scope.c next.c
SRC = $(CSRC) $(GENC) Lpars.c SRC = $(CSRC) $(GENC)
OBJ = $(COBJ) $(LOBJ) Lpars.o OBJ = $(COBJ) $(LOBJ) Lpars.o
GENH= errout.h\ GENH= errout.h\
@ -137,10 +137,18 @@ depend:
#INCLINCLINCLINCL #INCLINCLINCLINCL
Xlint: Xlint:
lint $(INCLUDES) $(LINTFLAGS) $(SRC) lint $(INCLUDES) $(LINTFLAGS) $(SRC) \
$(LIBDIR)/llib-lem_mes.ln \
$(LIBDIR)/llib-lemk.ln \
$(LIBDIR)/llib-linput.ln \
$(LIBDIR)/llib-lassert.ln \
$(LIBDIR)/llib-lalloc.ln \
$(LIBDIR)/llib-lprint.ln \
$(LIBDIR)/llib-lstring.ln \
$(LIBDIR)/llib-lsystem.ln
$(CURRDIR)/main: $(OBJ) $(CURRDIR)/main: $(OBJ)
$(CC) $(LFLAGS) $(OBJ) $(LIBDIR)/libem_mes.a $(OBJECTCODE) $(LIBDIR)/libinput.a $(LIBDIR)/libassert.a $(LIBDIR)/liballoc.a $(MALLOC) $(LIBDIR)/libprint.a $(LIBDIR)/libstring.a $(LIBDIR)/libsystem.a -o $(CURRDIR)/main $(CC) $(LDFLAGS) $(OBJ) $(LIBDIR)/libem_mes.a $(OBJECTCODE) $(LIBDIR)/libinput.a $(LIBDIR)/libassert.a $(LIBDIR)/liballoc.a $(MALLOC) $(LIBDIR)/libprint.a $(LIBDIR)/libstring.a $(LIBDIR)/libsystem.a -o $(CURRDIR)/main
size $(CURRDIR)/main size $(CURRDIR)/main
#AUTOAUTOAUTOAUTOAUTOAUTOAUTOAUTO #AUTOAUTOAUTOAUTOAUTOAUTOAUTOAUTO
@ -162,7 +170,6 @@ LLlex.o: warning.h
LLmessage.o: LLlex.h LLmessage.o: LLlex.h
LLmessage.o: Lpars.h LLmessage.o: Lpars.h
LLmessage.o: idf.h LLmessage.o: idf.h
char.o: class.h
error.o: LLlex.h error.o: LLlex.h
error.o: debug.h error.o: debug.h
error.o: debugcst.h error.o: debugcst.h
@ -189,7 +196,6 @@ main.o: standards.h
main.o: tokenname.h main.o: tokenname.h
main.o: type.h main.o: type.h
main.o: warning.h main.o: warning.h
symbol2str.o: Lpars.h
tokenname.o: Lpars.h tokenname.o: Lpars.h
tokenname.o: idf.h tokenname.o: idf.h
tokenname.o: tokenname.h tokenname.o: tokenname.h
@ -223,14 +229,6 @@ def.o: main.h
def.o: node.h def.o: node.h
def.o: scope.h def.o: scope.h
def.o: type.h def.o: type.h
scope.o: LLlex.h
scope.o: debug.h
scope.o: debugcst.h
scope.o: def.h
scope.o: idf.h
scope.o: node.h
scope.o: scope.h
scope.o: type.h
misc.o: LLlex.h misc.o: LLlex.h
misc.o: f_info.h misc.o: f_info.h
misc.o: idf.h misc.o: idf.h
@ -316,15 +314,6 @@ walk.o: scope.h
walk.o: type.h walk.o: type.h
walk.o: walk.h walk.o: walk.h
walk.o: warning.h walk.o: warning.h
casestat.o: LLlex.h
casestat.o: Lpars.h
casestat.o: debug.h
casestat.o: debugcst.h
casestat.o: density.h
casestat.o: desig.h
casestat.o: node.h
casestat.o: type.h
casestat.o: walk.h
desig.o: LLlex.h desig.o: LLlex.h
desig.o: debug.h desig.o: debug.h
desig.o: debugcst.h desig.o: debugcst.h
@ -344,12 +333,6 @@ code.o: scope.h
code.o: standards.h code.o: standards.h
code.o: type.h code.o: type.h
code.o: walk.h code.o: walk.h
tmpvar.o: debug.h
tmpvar.o: debugcst.h
tmpvar.o: def.h
tmpvar.o: main.h
tmpvar.o: scope.h
tmpvar.o: type.h
lookup.o: LLlex.h lookup.o: LLlex.h
lookup.o: debug.h lookup.o: debug.h
lookup.o: debugcst.h lookup.o: debugcst.h
@ -359,8 +342,6 @@ lookup.o: misc.h
lookup.o: node.h lookup.o: node.h
lookup.o: scope.h lookup.o: scope.h
lookup.o: type.h lookup.o: type.h
next.o: debug.h
next.o: debugcst.h
tokenfile.o: Lpars.h tokenfile.o: Lpars.h
program.o: LLlex.h program.o: LLlex.h
program.o: Lpars.h program.o: Lpars.h
@ -405,4 +386,31 @@ statement.o: idf.h
statement.o: node.h statement.o: node.h
statement.o: scope.h statement.o: scope.h
statement.o: type.h statement.o: type.h
symbol2str.o: Lpars.h
char.o: class.h
Lpars.o: Lpars.h Lpars.o: Lpars.h
casestat.o: LLlex.h
casestat.o: Lpars.h
casestat.o: debug.h
casestat.o: debugcst.h
casestat.o: density.h
casestat.o: desig.h
casestat.o: node.h
casestat.o: type.h
casestat.o: walk.h
tmpvar.o: debug.h
tmpvar.o: debugcst.h
tmpvar.o: def.h
tmpvar.o: main.h
tmpvar.o: scope.h
tmpvar.o: type.h
scope.o: LLlex.h
scope.o: debug.h
scope.o: debugcst.h
scope.o: def.h
scope.o: idf.h
scope.o: node.h
scope.o: scope.h
scope.o: type.h
next.o: debug.h
next.o: debugcst.h

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

@ -33,6 +33,7 @@
#include "warning.h" #include "warning.h"
extern char *symbol2str(); extern char *symbol2str();
extern char *sprint();
STATIC STATIC
Xerror(nd, mess, edf) Xerror(nd, mess, edf)
@ -293,7 +294,7 @@ ChkElement(expp, tp, set, level)
register struct node *expr = *expp; register struct node *expr = *expp;
register struct node *left = expr->nd_left; register struct node *left = expr->nd_left;
register struct node *right = expr->nd_right; register struct node *right = expr->nd_right;
register int i; register arith i;
if (expr->nd_class == Link && expr->nd_symb == UPTO) { if (expr->nd_class == Link && expr->nd_symb == UPTO) {
/* { ... , expr1 .. expr2, ... } /* { ... , expr1 .. expr2, ... }
@ -310,7 +311,7 @@ ChkElement(expp, tp, set, level)
*/ */
if (left->nd_INT > right->nd_INT) { if (left->nd_INT > right->nd_INT) {
node_error(expp, "lower bound exceeds upper bound in range"); node_error(expr, "lower bound exceeds upper bound in range");
return 0; return 0;
} }
@ -385,7 +386,7 @@ ChkSet(expp)
if (!is_type(df) || if (!is_type(df) ||
(df->df_type->tp_fund != T_SET)) { (df->df_type->tp_fund != T_SET)) {
if (df->df_kind != D_ERROR) { if (df->df_kind != D_ERROR) {
Xerror(expp, "not a set type", df); Xerror(nd, "not a set type", df);
} }
return 0; return 0;
} }
@ -571,6 +572,23 @@ ChkProcCall(expp)
return retval; return retval;
} }
int
ChkFunCall(expp)
register struct node *expp;
{
/* Check a call that must have a result
*/
int retval = 1;
if (!ChkCall(expp)) retval = 0;
if (expp->nd_type == 0) {
node_error(expp, "function call expected");
expp->nd_type = error_type;
retval = 0;
}
return retval;
}
int int
ChkCall(expp) ChkCall(expp)
register struct node *expp; register struct node *expp;
@ -1007,7 +1025,7 @@ ChkStandard(expp, left)
tk->TOK_INT = PointedtoType(left->nd_type)->tp_size; tk->TOK_INT = PointedtoType(left->nd_type)->tp_size;
tk->tk_symb = INTEGER; tk->tk_symb = INTEGER;
tk->tk_lineno = left->nd_lineno; tk->tk_lineno = left->nd_lineno;
nd = MkLeaf(Value, &dt); nd = MkLeaf(Value, tk);
nd->nd_type = card_type; nd->nd_type = card_type;
tk->tk_symb = ','; tk->tk_symb = ',';
arg->nd_right = MkNode(Link, nd, NULLNODE, tk); arg->nd_right = MkNode(Link, nd, NULLNODE, tk);
@ -1199,7 +1217,7 @@ int (*ExprChkTable[])() = {
ChkBinOper, ChkBinOper,
ChkUnOper, ChkUnOper,
ChkArrow, ChkArrow,
ChkCall, ChkFunCall,
ChkExLinkOrName, ChkExLinkOrName,
NodeCrash, NodeCrash,
ChkSet, ChkSet,

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

@ -49,11 +49,9 @@ CodeConst(cst, size)
else { else {
crash("(CodeConst)"); crash("(CodeConst)");
/* /*
label dlab = ++data_label; C_df_dlb(++data_label);
C_df_dlb(dlab);
C_rom_icon(long2str((long) cst), size); C_rom_icon(long2str((long) cst), size);
C_lae_dlb(dlab, (arith) 0); C_lae_dlb(data_label, (arith) 0);
C_loi(size); C_loi(size);
*/ */
} }
@ -63,14 +61,13 @@ CodeString(nd)
register struct node *nd; register struct node *nd;
{ {
if (nd->nd_type->tp_fund != T_STRING) { if (nd->nd_type->tp_fund != T_STRING) {
/* Character constant */
C_loc(nd->nd_INT); C_loc(nd->nd_INT);
} }
else { else {
label lab = ++data_label; C_df_dlb(++data_label);
C_df_dlb(lab);
C_rom_scon(nd->nd_STR, WA(nd->nd_SLE + 1)); C_rom_scon(nd->nd_STR, WA(nd->nd_SLE + 1));
C_lae_dlb(lab, (arith) 0); C_lae_dlb(data_label, (arith) 0);
} }
} }
@ -100,11 +97,8 @@ CodeExpr(nd, ds, true_label, false_label)
case Oper: case Oper:
CodeOper(nd, true_label, false_label); CodeOper(nd, true_label, false_label);
if (true_label == 0) ds->dsg_kind = DSG_LOADED; ds->dsg_kind = DSG_LOADED;
else { true_label = NO_LABEL;
ds->dsg_kind = DSG_INIT;
true_label = 0;
}
break; break;
case Uoper: case Uoper:
@ -114,14 +108,11 @@ CodeExpr(nd, ds, true_label, false_label)
case Value: case Value:
switch(nd->nd_symb) { switch(nd->nd_symb) {
case REAL: { case REAL:
label lab = ++data_label; C_df_dlb(++data_label);
C_df_dlb(lab);
C_rom_fcon(nd->nd_REL, nd->nd_type->tp_size); C_rom_fcon(nd->nd_REL, nd->nd_type->tp_size);
C_lae_dlb(lab, (arith) 0); C_lae_dlb(data_label, (arith) 0);
C_loi(nd->nd_type->tp_size); C_loi(nd->nd_type->tp_size);
}
break; break;
case STRING: case STRING:
CodeString(nd); CodeString(nd);
@ -142,16 +133,11 @@ CodeExpr(nd, ds, true_label, false_label)
case Xset: case Xset:
case Set: { case Set: {
register arith *st = nd->nd_set; register int i = tp->tp_size / word_size;
register int i; register arith *st = nd->nd_set + i;
st = nd->nd_set;
ds->dsg_kind = DSG_LOADED; ds->dsg_kind = DSG_LOADED;
if (!st) { for (; i > 0; i--) {
C_zer(tp->tp_size);
break;
}
for (i = tp->tp_size / word_size, st += i; i > 0; i--) {
C_loc(*--st); C_loc(*--st);
} }
CodeSet(nd); CodeSet(nd);
@ -162,11 +148,10 @@ CodeExpr(nd, ds, true_label, false_label)
crash("(CodeExpr) bad node type"); crash("(CodeExpr) bad node type");
} }
if (true_label != 0) { if (true_label != NO_LABEL) {
/* Only for boolean expressions /* Only for boolean expressions
*/ */
CodeValue(ds, tp->tp_size, tp->tp_align); CodeValue(ds, tp->tp_size, tp->tp_align);
*ds = InitDesig;
C_zne(true_label); C_zne(true_label);
C_bra(false_label); C_bra(false_label);
} }
@ -304,10 +289,10 @@ CodeCall(nd)
register struct def *df = left->nd_def; register struct def *df = left->nd_def;
if (df->df_kind == D_PROCEDURE) { if (df->df_kind == D_PROCEDURE) {
arith level = df->df_scope->sc_level; int level = df->df_scope->sc_level;
if (level > 0) { if (level > 0) {
C_lxl((arith) proclevel - level); C_lxl((arith) (proclevel - level));
} }
C_cal(NameOfProc(df)); C_cal(NameOfProc(df));
break; break;
@ -321,7 +306,7 @@ CodeCall(nd)
CodePExpr(left); CodePExpr(left);
C_cai(); C_cai();
} }
if (left->nd_type->prc_nbpar) C_asp(left->nd_type->prc_nbpar); C_asp(left->nd_type->prc_nbpar);
if (result_tp = ResultType(left->nd_type)) { if (result_tp = ResultType(left->nd_type)) {
if (IsConstructed(result_tp)) { if (IsConstructed(result_tp)) {
C_lfr(pointer_size); C_lfr(pointer_size);
@ -353,7 +338,7 @@ CodeParameters(param, arg)
C_loc(tp->arr_elsize); C_loc(tp->arr_elsize);
if (IsConformantArray(left_type)) { if (IsConformantArray(left_type)) {
DoHIGH(left); DoHIGH(left->nd_def);
if (elem->tp_size != left_type->arr_elem->tp_size) { if (elem->tp_size != left_type->arr_elem->tp_size) {
/* This can only happen if the formal type is /* This can only happen if the formal type is
ARRAY OF (WORD|BYTE) ARRAY OF (WORD|BYTE)
@ -478,13 +463,13 @@ CodeStd(nd)
case S_HIGH: case S_HIGH:
assert(IsConformantArray(tp)); assert(IsConformantArray(tp));
DoHIGH(left); DoHIGH(left->nd_def);
break; break;
case S_SIZE: case S_SIZE:
case S_TSIZE: case S_TSIZE:
assert(IsConformantArray(tp)); assert(IsConformantArray(tp));
DoHIGH(left); DoHIGH(left->nd_def);
C_inc(); C_inc();
C_loc(tp->arr_elem->tp_size); C_loc(tp->arr_elem->tp_size);
C_mlu(word_size); C_mlu(word_size);
@ -777,7 +762,7 @@ CodeOper(expr, true_label, false_label)
default: default:
crash("bad type COMPARE"); crash("bad type COMPARE");
} }
if (true_label != 0) { if (true_label != NO_LABEL) {
compare(expr->nd_symb, true_label); compare(expr->nd_symb, true_label);
C_bra(false_label); C_bra(false_label);
} }
@ -794,7 +779,7 @@ CodeOper(expr, true_label, false_label)
CodePExpr(leftop); CodePExpr(leftop);
CodeCoercion(leftop->nd_type, word_type); CodeCoercion(leftop->nd_type, word_type);
C_inn(rightop->nd_type->tp_size); C_inn(rightop->nd_type->tp_size);
if (true_label != 0) { if (true_label != NO_LABEL) {
C_zne(true_label); C_zne(true_label);
C_bra(false_label); C_bra(false_label);
} }
@ -806,7 +791,7 @@ CodeOper(expr, true_label, false_label)
struct desig Des; struct desig Des;
int genlabels = 0; int genlabels = 0;
if (true_label == 0) { if (true_label == NO_LABEL) {
genlabels = 1; genlabels = 1;
true_label = ++text_label; true_label = ++text_label;
false_label = ++text_label; false_label = ++text_label;
@ -1000,17 +985,15 @@ CodeDStore(nd)
CodeStore(&designator, nd->nd_type->tp_size, nd->nd_type->tp_align); CodeStore(&designator, nd->nd_type->tp_size, nd->nd_type->tp_align);
} }
DoHIGH(nd) DoHIGH(df)
struct node *nd; register struct def *df;
{ {
/* Get the high index of a conformant array, indicated by "nd". /* Get the high index of a conformant array, indicated by "nd".
The high index is the second field in the descriptor of The high index is the second field in the descriptor of
the array, so it is easily found. the array, so it is easily found.
*/ */
register struct def *df = nd->nd_def;
register arith highoff; register arith highoff;
assert(nd->nd_class == Def);
assert(df->df_kind == D_VARIABLE); assert(df->df_kind == D_VARIABLE);
assert(IsConformantArray(df->df_type)); assert(IsConformantArray(df->df_type));

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

@ -132,7 +132,7 @@ TypeDeclaration
{ {
struct def *df; struct def *df;
struct type *tp; struct type *tp;
struct node *nd; register struct node *nd;
}: }:
IDENT { df = define(dot.TOK_IDF, CurrentScope, D_TYPE); IDENT { df = define(dot.TOK_IDF, CurrentScope, D_TYPE);
nd = MkLeaf(Name, &dot); nd = MkLeaf(Name, &dot);
@ -143,7 +143,7 @@ TypeDeclaration
} }
; ;
type(struct type **ptp;): type(register struct type **ptp;):
%default SimpleType(ptp) %default SimpleType(ptp)
| |
ArrayType(ptp) ArrayType(ptp)
@ -157,7 +157,7 @@ type(struct type **ptp;):
ProcedureType(ptp) ProcedureType(ptp)
; ;
SimpleType(struct type **ptp;) SimpleType(register struct type **ptp;)
{ {
struct type *tp; struct type *tp;
} : } :
@ -264,9 +264,9 @@ FieldListSequence(struct scope *scope; arith *cnt; int *palign;):
FieldList(struct scope *scope; arith *cnt; int *palign;) FieldList(struct scope *scope; arith *cnt; int *palign;)
{ {
struct node *FldList; struct node *FldList;
register struct idf *id = 0;
struct type *tp; struct type *tp;
struct node *nd; struct node *nd;
register struct def *df;
arith tcnt, max; arith tcnt, max;
} : } :
[ [
@ -288,7 +288,17 @@ FieldList(struct scope *scope; arith *cnt; int *palign;)
{ if (nd->nd_class != Name) { { if (nd->nd_class != Name) {
error("illegal variant tag"); error("illegal variant tag");
} }
else id = nd->nd_IDF; else {
df = define(nd->nd_IDF, scope, D_FIELD);
*palign = lcm(*palign, tp->tp_align);
if (!(tp->tp_fund & T_DISCRETE)) {
error("illegal type in variant");
}
df->df_type = tp;
df->fld_off = align(*cnt, tp->tp_align);
*cnt = df->fld_off + tp->tp_size;
df->df_flags |= D_QEXPORTED;
}
FreeNode(nd); FreeNode(nd);
} }
| /* Old fashioned! the first qualident now represents | /* Old fashioned! the first qualident now represents
@ -302,22 +312,7 @@ FieldList(struct scope *scope; arith *cnt; int *palign;)
| ':' qualtype(&tp) | ':' qualtype(&tp)
/* Aha, third edition. Well done! */ /* Aha, third edition. Well done! */
] ]
{ { tcnt = *cnt; }
*palign = lcm(*palign, tp->tp_align);
if (id) {
register struct def *df =
define(id, scope, D_FIELD);
if (!(tp->tp_fund & T_DISCRETE)) {
error("illegal type in variant");
}
df->df_type = tp;
df->fld_off = align(*cnt, tp->tp_align);
*cnt = df->fld_off + tp->tp_size;
df->df_flags |= D_QEXPORTED;
}
tcnt = *cnt;
}
OF variant(scope, &tcnt, tp, palign) OF variant(scope, &tcnt, tp, palign)
{ max = tcnt; tcnt = *cnt; } { max = tcnt; tcnt = *cnt; }
[ [
@ -360,26 +355,26 @@ CaseLabelList(struct type **ptp; struct node **pnd;):
CaseLabels(struct type **ptp; register struct node **pnd;) CaseLabels(struct type **ptp; register struct node **pnd;)
{ {
register struct node *nd1; register struct node *nd;
}: }:
ConstExpression(pnd) ConstExpression(pnd)
{ nd1 = *pnd; } { nd = *pnd; }
[ [
UPTO { *pnd = MkNode(Link,nd1,NULLNODE,&dot); } UPTO { *pnd = MkNode(Link,nd,NULLNODE,&dot); }
ConstExpression(&(*pnd)->nd_right) ConstExpression(&(*pnd)->nd_right)
{ if (!TstCompat(nd1->nd_type, { if (!TstCompat(nd->nd_type,
(*pnd)->nd_right->nd_type)) { (*pnd)->nd_right->nd_type)) {
node_error((*pnd)->nd_right, node_error((*pnd)->nd_right,
"type incompatibility in case label"); "type incompatibility in case label");
nd1->nd_type = error_type; nd->nd_type = error_type;
} }
} }
]? ]?
{ if (*ptp != 0 && !TstCompat(*ptp, nd1->nd_type)) { { if (*ptp != 0 && !TstCompat(*ptp, nd->nd_type)) {
node_error(nd1, node_error(nd,
"type incompatibility in case label"); "type incompatibility in case label");
} }
*ptp = nd1->nd_type; *ptp = nd->nd_type;
} }
; ;
@ -392,7 +387,7 @@ SetType(struct type **ptp;) :
have to be declared yet, so be careful about identifying have to be declared yet, so be careful about identifying
type-identifiers type-identifiers
*/ */
PointerType(struct type **ptp;) : PointerType(register struct type **ptp;) :
POINTER TO POINTER TO
[ %if (type_or_forward(ptp)) [ %if (type_or_forward(ptp))
type(&((*ptp)->next)) type(&((*ptp)->next))
@ -409,7 +404,7 @@ qualtype(struct type **ptp;)
{ *ptp = qualified_type(nd); } { *ptp = qualified_type(nd); }
; ;
ProcedureType(struct type **ptp;) ProcedureType(register struct type **ptp;)
{ {
struct paramlist *pr = 0; struct paramlist *pr = 0;
arith parmaddr = 0; arith parmaddr = 0;
@ -423,18 +418,12 @@ ProcedureType(struct type **ptp;)
{ *ptp = proc_type(*ptp, pr, parmaddr); } { *ptp = proc_type(*ptp, pr, parmaddr); }
; ;
FormalTypeList(struct paramlist **ppr; arith *parmaddr; struct type **ptp;) FormalTypeList(struct paramlist **ppr; arith *parmaddr; struct type **ptp;):
{
struct type *tp;
int VARp;
} :
'(' '('
[ [
var(&VARp) FormalType(&tp) VarFormalType(ppr, parmaddr)
{ EnterParamList(ppr,NULLNODE,tp,VARp,parmaddr); }
[ [
',' var(&VARp) FormalType(&tp) ',' VarFormalType(ppr, parmaddr)
{ EnterParamList(ppr,NULLNODE,tp,VARp,parmaddr); }
]* ]*
]? ]?
')' ')'
@ -442,10 +431,22 @@ FormalTypeList(struct paramlist **ppr; arith *parmaddr; struct type **ptp;)
]? ]?
; ;
var(int *VARp;): VarFormalType(struct paramlist **ppr; arith *parmaddr;)
VAR { *VARp = D_VARPAR; } {
| struct type *tp;
/* empty */ { *VARp = D_VALPAR; } int isvar;
} :
var(&isvar)
FormalType(&tp)
{ EnterParamList(ppr,NULLNODE,tp,isvar,parmaddr); }
;
var(int *VARp;) :
[
VAR { *VARp = D_VARPAR; }
|
/* empty */ { *VARp = D_VALPAR; }
]
; ;
ConstantDeclaration ConstantDeclaration

6
lang/m2/comp/defmodule.c
View file

@ -36,7 +36,7 @@ struct idf *DefId;
STATIC char * STATIC char *
getwdir(fn) getwdir(fn)
char *fn; register char *fn;
{ {
register char *p; register char *p;
char *strrindex(); char *strrindex();
@ -49,7 +49,7 @@ getwdir(fn)
if (p) { if (p) {
*p = '\0'; *p = '\0';
fn = Salloc(fn, p - &fn[0] + 1); fn = Salloc(fn, (unsigned) (p - &fn[0] + 1));
*p = '/'; *p = '/';
return fn; return fn;
} }
@ -64,7 +64,7 @@ GetFile(name)
in the directories mentioned in "DEFPATH". in the directories mentioned in "DEFPATH".
*/ */
char buf[15]; char buf[15];
char *strcpy(), *strcat(); char *strncpy(), *strcat();
static char *WorkingDir = "."; static char *WorkingDir = ".";
strncpy(buf, name, 10); strncpy(buf, name, 10);

18
lang/m2/comp/desig.c
View file

@ -67,7 +67,6 @@ CodeValue(ds, size, al)
/* Generate code to load the value of the designator described /* Generate code to load the value of the designator described
in "ds" in "ds"
*/ */
arith tmp = 0;
switch(ds->dsg_kind) { switch(ds->dsg_kind) {
case DSG_LOADED: case DSG_LOADED:
@ -100,14 +99,16 @@ CodeValue(ds, size, al)
break; break;
} }
if (ds->dsg_kind == DSG_PLOADED) { if (ds->dsg_kind == DSG_PLOADED) {
tmp = NewPtr(); arith sz = WA(size) - pointer_size;
C_stl(tmp);
C_asp(-sz);
C_lor((arith) 1);
C_adp(sz);
C_loi(pointer_size);
} }
C_asp(-WA(size)); else {
if (!tmp) CodeAddress(ds); C_asp(-WA(size));
else { CodeAddress(ds);
C_lol(tmp);
FreePtr(tmp);
} }
C_loc(size); C_loc(size);
C_cal("_load"); C_cal("_load");
@ -300,6 +301,7 @@ CodeMove(rhs, left, rtp)
} }
{ {
arith tmp; arith tmp;
extern arith NewPtr();
if (loadedflag) { if (loadedflag) {
tmp = NewPtr(); tmp = NewPtr();

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

@ -14,6 +14,7 @@
#include <system.h> #include <system.h>
#include <em_arith.h> #include <em_arith.h>
#include <em_label.h> #include <em_label.h>
#include <alloc.h>
#include "input.h" #include "input.h"
#include "f_info.h" #include "f_info.h"
@ -101,7 +102,7 @@ Compile(src, dst)
C_ms_emx(word_size, pointer_size); C_ms_emx(word_size, pointer_size);
CheckForLineDirective(); CheckForLineDirective();
CompUnit(); CompUnit();
C_ms_src((arith) (LineNumber - 1), FileName); C_ms_src((int)LineNumber - 1, FileName);
if (!err_occurred) { if (!err_occurred) {
C_exp(Defined->mod_vis->sc_scope->sc_name); C_exp(Defined->mod_vis->sc_scope->sc_name);
WalkModule(Defined); WalkModule(Defined);

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

@ -13,6 +13,7 @@
#include <em_arith.h> #include <em_arith.h>
#include <em_label.h> #include <em_label.h>
#include <alloc.h>
#include "type.h" #include "type.h"
#include "main.h" #include "main.h"
@ -117,7 +118,7 @@ DoOption(text)
if (++nDEF > mDEF) { if (++nDEF > mDEF) {
char **n = (char **) char **n = (char **)
Malloc((10+mDEF)*sizeof(char *)); Malloc((unsigned)((10+mDEF)*sizeof(char *)));
for (i = 0; i < mDEF; i++) { for (i = 0; i < mDEF; i++) {
n[i] = DEFPATH[i]; n[i] = DEFPATH[i];

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

@ -66,10 +66,7 @@ ModuleDeclaration
} }
; ;
priority(register struct def *df;) priority(register struct def *df;):
{
register struct node *nd;
} :
[ [
'[' ConstExpression(&(df->mod_priority)) ']' '[' ConstExpression(&(df->mod_priority)) ']'
{ if (!(df->mod_priority->nd_type->tp_fund & { if (!(df->mod_priority->nd_type->tp_fund &

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

@ -60,7 +60,7 @@ open_and_close_scope(scopetype)
open_scope(scopetype); open_scope(scopetype);
sc = CurrentScope; sc = CurrentScope;
close_scope(); close_scope(0);
return sc; return sc;
} }
@ -106,7 +106,7 @@ chk_proc(df)
STATIC STATIC
chk_forw(pdf) chk_forw(pdf)
register struct def **pdf; struct def **pdf;
{ {
/* Called at scope close. Look for all forward definitions and /* Called at scope close. Look for all forward definitions and
if the scope was a closed scope, give an error message for if the scope was a closed scope, give an error message for
@ -197,6 +197,7 @@ Reverse(pdf)
} }
close_scope(flag) close_scope(flag)
register int flag;
{ {
/* Close a scope. If "flag" is set, check for forward declarations, /* Close a scope. If "flag" is set, check for forward declarations,
either POINTER declarations, or EXPORTs, or forward references either POINTER declarations, or EXPORTs, or forward references

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

@ -20,6 +20,7 @@
Also, the "token2str.c" file is produced from this file. Also, the "token2str.c" file is produced from this file.
*/ */
#ifdef ___XXX___
struct tokenname tkspec[] = { /* the names of the special tokens */ struct tokenname tkspec[] = { /* the names of the special tokens */
{IDENT, "identifier"}, {IDENT, "identifier"},
{STRING, "string"}, {STRING, "string"},
@ -35,6 +36,7 @@ struct tokenname tkcomp[] = { /* names of the composite tokens */
{BECOMES, ":="}, {BECOMES, ":="},
{0, ""} {0, ""}
}; };
#endif
struct tokenname tkidf[] = { /* names of the identifier tokens */ struct tokenname tkidf[] = { /* names of the identifier tokens */
{AND, "AND"}, {AND, "AND"},
@ -80,6 +82,7 @@ struct tokenname tkidf[] = { /* names of the identifier tokens */
{0, ""} {0, ""}
}; };
#ifdef ___XXX___
struct tokenname tkinternal[] = { /* internal keywords */ struct tokenname tkinternal[] = { /* internal keywords */
{PROGRAM, ""}, {PROGRAM, ""},
{0, "0"} {0, "0"}
@ -88,6 +91,7 @@ struct tokenname tkinternal[] = { /* internal keywords */
struct tokenname tkstandard[] = { /* standard identifiers */ struct tokenname tkstandard[] = { /* standard identifiers */
{0, ""} {0, ""}
}; };
#endif
/* Some routines to handle tokennames */ /* Some routines to handle tokennames */

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

@ -12,7 +12,7 @@
struct paramlist { /* structure for parameterlist of a PROCEDURE */ struct paramlist { /* structure for parameterlist of a PROCEDURE */
struct paramlist *next; struct paramlist *next;
struct def *par_def; /* "df" of parameter */ struct def *par_def; /* "df" of parameter */
#define IsVarParam(xpar) ((xpar)->par_def->df_flags & D_VARPAR) #define IsVarParam(xpar) ((int) ((xpar)->par_def->df_flags & D_VARPAR))
#define TypeOfParam(xpar) ((xpar)->par_def->df_type) #define TypeOfParam(xpar) ((xpar)->par_def->df_type)
}; };

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

@ -217,7 +217,7 @@ u_small(tp, n)
tp->tp_size = 1; tp->tp_size = 1;
tp->tp_align = 1; tp->tp_align = 1;
} }
else if (ufit(n, short_size)) { else if (ufit(n, (int)short_size)) {
tp->tp_size = short_size; tp->tp_size = short_size;
tp->tp_align = short_align; tp->tp_align = short_align;
} }
@ -302,16 +302,18 @@ chk_basesubrange(tp, base)
struct type * struct type *
subr_type(lb, ub) subr_type(lb, ub)
struct node *lb, *ub; register struct node *lb;
struct node *ub;
{ {
/* Construct a subrange type from the constant expressions /* Construct a subrange type from the constant expressions
indicated by "lb" and "ub", but first perform some indicated by "lb" and "ub", but first perform some
checks checks
*/ */
register struct type *tp = BaseType(lb->nd_type), *res; register struct type *tp = BaseType(lb->nd_type);
register struct type *res;
if (!TstCompat(lb->nd_type, ub->nd_type)) { if (!TstCompat(lb->nd_type, ub->nd_type)) {
node_error(ub, "types of subrange bounds not equal"); node_error(lb, "types of subrange bounds not equal");
return error_type; return error_type;
} }
@ -326,14 +328,14 @@ subr_type(lb, ub)
/* Check base type /* Check base type
*/ */
if (! (tp->tp_fund & T_DISCRETE)) { if (! (tp->tp_fund & T_DISCRETE)) {
node_error(ub, "illegal base type for subrange"); node_error(lb, "illegal base type for subrange");
return error_type; return error_type;
} }
/* Check bounds /* Check bounds
*/ */
if (lb->nd_INT > ub->nd_INT) { if (lb->nd_INT > ub->nd_INT) {
node_error(ub, "lower bound exceeds upper bound"); node_error(lb, "lower bound exceeds upper bound");
} }
/* Now construct resulting type /* Now construct resulting type
@ -351,8 +353,8 @@ subr_type(lb, ub)
res->tp_size = 1; res->tp_size = 1;
res->tp_align = 1; res->tp_align = 1;
} }
else if (fit(res->sub_lb, short_size) && else if (fit(res->sub_lb, (int)short_size) &&
fit(res->sub_ub, short_size)) { fit(res->sub_ub, (int)short_size)) {
res->tp_size = short_size; res->tp_size = short_size;
res->tp_align = short_align; res->tp_align = short_align;
} }
@ -381,22 +383,19 @@ genrck(tp)
*/ */
arith lb, ub; arith lb, ub;
register label ol; register label ol;
int newlabel = 0;
getbounds(tp, &lb, &ub); getbounds(tp, &lb, &ub);
if (tp->tp_fund == T_SUBRANGE) { if (tp->tp_fund == T_SUBRANGE) {
if (!(ol = tp->sub_rck)) { if (!(ol = tp->sub_rck)) {
tp->sub_rck = ol = ++data_label; tp->sub_rck = ++data_label;
newlabel = 1;
} }
} }
else if (!(ol = tp->enm_rck)) { else if (!(ol = tp->enm_rck)) {
tp->enm_rck = ol = ++data_label; tp->enm_rck = ++data_label;
newlabel = 1;
} }
if (newlabel) { if (!ol) {
C_df_dlb(ol); C_df_dlb(ol = data_label);
C_rom_cst(lb); C_rom_cst(lb);
C_rom_cst(ub); C_rom_cst(ub);
} }
@ -571,18 +570,21 @@ int
type_or_forward(ptp) type_or_forward(ptp)
struct type **ptp; struct type **ptp;
{ {
struct node *nd = 0; /* POINTER TO IDENTIFIER construction. The IDENTIFIER resides
in "dot". This routine handles the different cases.
*/
register struct node *nd;
*ptp = construct_type(T_POINTER, NULLTYPE); *ptp = construct_type(T_POINTER, NULLTYPE);
if (lookup(dot.TOK_IDF, CurrentScope, 1) if (lookup(dot.TOK_IDF, CurrentScope, 1)) {
/* Either a Module or a Type, but in both cases defined /* Either a Module or a Type, but in both cases defined
in this scope, so this is the correct identification in this scope, so this is the correct identification
*/ */
|| return 1;
( nd = new_node(), }
nd->nd_token = dot, nd = new_node();
lookfor(nd, CurrVis, 0)->df_kind == D_MODULE nd->nd_token = dot;
) if (lookfor(nd, CurrVis, 0)->df_kind == D_MODULE) {
/* A Modulename in one of the enclosing scopes. /* A Modulename in one of the enclosing scopes.
It is not clear from the language definition that It is not clear from the language definition that
it is correct to handle these like this, but it is correct to handle these like this, but
@ -591,8 +593,7 @@ type_or_forward(ptp)
one token. one token.
??? ???
*/ */
) { free_node(nd);
if (nd) free_node(nd);
return 1; return 1;
} }
/* Enter a forward reference into a list belonging to the /* Enter a forward reference into a list belonging to the
@ -652,7 +653,7 @@ DumpType(tp)
switch(tp->tp_fund) { switch(tp->tp_fund) {
case T_RECORD: case T_RECORD:
print("RECORD\n"); print("RECORD\n");
DumpScope(tp->rec_scope); DumpScope(tp->rec_scope->sc_def);
break; break;
case T_ENUMERATION: case T_ENUMERATION:
print("ENUMERATION; ncst:%d", tp->enm_ncst); break; print("ENUMERATION; ncst:%d", tp->enm_ncst); break;

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

@ -75,15 +75,14 @@ DoProfil()
static label filename_label = 0; static label filename_label = 0;
if (! options['L']) { if (! options['L']) {
register label fn_label = filename_label;
if (!fn_label) { if (!filename_label) {
filename_label = fn_label = ++data_label; filename_label = ++data_label;
C_df_dlb(fn_label); C_df_dlb(filename_label);
C_rom_scon(FileName, (arith) (strlen(FileName) + 1)); C_rom_scon(FileName, (arith) (strlen(FileName) + 1));
} }
C_fil_dlb(fn_label, (arith) 0); C_fil_dlb(filename_label, (arith) 0);
} }
} }
@ -126,16 +125,14 @@ WalkModule(module)
/* We don't actually prevent recursive calls, /* We don't actually prevent recursive calls,
but do nothing if called recursively but do nothing if called recursively
*/ */
label l1 = ++data_label; C_df_dlb(++data_label);
C_con_cst((arith) 0);
C_df_dlb(l1);
C_bss_cst(word_size, (arith) 0, 1);
/* if this one is set to non-zero, the initialization /* if this one is set to non-zero, the initialization
was already done. was already done.
*/ */
C_loe_dlb(l1, (arith) 0); C_loe_dlb(data_label, (arith) 0);
C_zne(RETURN_LABEL); C_zne(RETURN_LABEL);
C_ine_dlb(l1, (arith) 0); C_ine_dlb(data_label, (arith) 0);
} }
for (; nd; nd = nd->next) { for (; nd; nd = nd->next) {