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

many bug fixes

Browse source
This commit is contained in:
ceriel 1986-09-25 19:39:06 +00:00
parent c967d1ab3a
commit c3d4d40d1b
21 changed files with 480 additions and 398 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -25,10 +25,10 @@ static char *RcsId = "$Header$";
long str2long(); long str2long();
struct token dot, aside; struct token dot,
struct type *toktype; aside;
struct string string; struct type *toktype;
int idfsize = IDFSIZE; int idfsize = IDFSIZE;
#ifdef DEBUG #ifdef DEBUG
extern int cntlines; extern int cntlines;
#endif #endif
@ -40,10 +40,9 @@ SkipComment()
Note that comments may be nested (par. 3.5). Note that comments may be nested (par. 3.5).
*/ */
register int ch; register int ch;
register int NestLevel = 0;
LoadChar(ch);
for (;;) { for (;;) {
LoadChar(ch);
if (class(ch) == STNL) { if (class(ch) == STNL) {
LineNumber++; LineNumber++;
#ifdef DEBUG #ifdef DEBUG
@ -52,32 +51,26 @@ SkipComment()
} }
else if (ch == '(') { else if (ch == '(') {
LoadChar(ch); LoadChar(ch);
if (ch == '*') ++NestLevel; if (ch == '*') SkipComment();
else continue;
} }
else if (ch == '*') { else if (ch == '*') {
LoadChar(ch); LoadChar(ch);
if (ch == ')') { if (ch == ')') break;
if (NestLevel-- == 0) return;
}
else continue;
} }
LoadChar(ch);
} }
} }
STATIC STATIC struct string *
GetString(upto) GetString(upto)
{ {
/* Read a Modula-2 string, delimited by the character "upto". /* Read a Modula-2 string, delimited by the character "upto".
*/ */
register int ch; register int ch;
register struct string *str = &string; register struct string *str = (struct string *) Malloc(sizeof(struct string));
register char *p; register char *p;
str->s_str = p = Malloc((unsigned int) (str->s_length = ISTRSIZE)); str->s_str = p = Malloc((unsigned int) (str->s_length = ISTRSIZE));
LoadChar(ch); while (LoadChar(ch), ch != upto) {
while (ch != upto) {
if (class(ch) == STNL) { if (class(ch) == STNL) {
lexerror("newline in string"); lexerror("newline in string");
LineNumber++; LineNumber++;
@ -86,7 +79,7 @@ GetString(upto)
#endif #endif
break; break;
} }
if (ch == EOI) { if (ch == EOI) {
lexerror("end-of-file in string"); lexerror("end-of-file in string");
break; break;
} }
@ -97,10 +90,10 @@ GetString(upto)
p = str->s_str + str->s_length; p = str->s_str + str->s_length;
str->s_length += RSTRSIZE; str->s_length += RSTRSIZE;
} }
LoadChar(ch);
} }
*p = '\0'; *p = '\0';
str->s_length = p - str->s_str; str->s_length = p - str->s_str;
return str;
} }
int int
@ -131,15 +124,15 @@ again:
switch (class(ch)) { switch (class(ch)) {
case STSKIP:
goto again;
case STNL: case STNL:
LineNumber++; LineNumber++;
#ifdef DEBUG #ifdef DEBUG
cntlines++; cntlines++;
#endif #endif
tk->tk_lineno++; tk->tk_lineno++;
/* Fall Through */
case STSKIP:
goto again; goto again;
case STGARB: case STGARB:
@ -172,15 +165,13 @@ again:
if (nch == '.') { if (nch == '.') {
return tk->tk_symb = UPTO; return tk->tk_symb = UPTO;
} }
PushBack(nch); break;
return tk->tk_symb = ch;
case ':': case ':':
if (nch == '=') { if (nch == '=') {
return tk->tk_symb = BECOMES; return tk->tk_symb = BECOMES;
} }
PushBack(nch); break;
return tk->tk_symb = ch;
case '<': case '<':
if (nch == '=') { if (nch == '=') {
@ -190,50 +181,52 @@ again:
lexwarning("'<>' is old-fashioned; use '#'"); lexwarning("'<>' is old-fashioned; use '#'");
return tk->tk_symb = '#'; return tk->tk_symb = '#';
} }
PushBack(nch); break;
return tk->tk_symb = ch;
case '>': case '>':
if (nch == '=') { if (nch == '=') {
return tk->tk_symb = GREATEREQUAL; return tk->tk_symb = GREATEREQUAL;
} }
PushBack(nch); break;
return tk->tk_symb = ch;
default : default :
crash("(LLlex, STCOMP)"); crash("(LLlex, STCOMP)");
} }
PushBack(nch);
return tk->tk_symb = ch;
case STIDF: case STIDF:
{ {
register char *tg = &buf[0]; register char *tag = &buf[0];
register struct idf *id; register struct idf *id;
do { do {
if (tg - buf < idfsize) *tg++ = ch; if (tag - buf < idfsize) *tag++ = ch;
LoadChar(ch); LoadChar(ch);
} while(in_idf(ch)); } while(in_idf(ch));
if (ch != EOI) PushBack(ch); if (ch != EOI) PushBack(ch);
*tg++ = '\0'; *tag++ = '\0';
tk->TOK_IDF = id = str2idf(buf, 1); tk->TOK_IDF = id = str2idf(buf, 1);
return tk->tk_symb = id->id_reserved ? id->id_reserved : IDENT; return tk->tk_symb = id->id_reserved ? id->id_reserved : IDENT;
} }
case STSTR: case STSTR: {
GetString(ch); register struct string *str = GetString(ch);
if (string.s_length == 1) {
tk->TOK_INT = *(string.s_str) & 0377; if (str->s_length == 1) {
tk->TOK_INT = *(str->s_str) & 0377;
toktype = char_type; toktype = char_type;
free(str->s_str);
free((char *) str);
} }
else { else {
tk->tk_data.tk_str = (struct string *) tk->tk_data.tk_str = str;
Malloc(sizeof (struct string)); toktype = standard_type(T_STRING, 1, str->s_length);
*(tk->tk_data.tk_str) = string;
toktype = standard_type(T_STRING, 1, string.s_length);
} }
return tk->tk_symb = STRING; return tk->tk_symb = STRING;
}
case STNUM: case STNUM:
{ {
@ -241,172 +234,157 @@ again:
is that we don't know the base in advance so we is that we don't know the base in advance so we
have to read the number with the help of a rather have to read the number with the help of a rather
complex finite automaton. complex finite automaton.
Excuses for the very ugly code!
*/ */
enum statetp {Oct,Hex,Dec,OctEndOrHex,End,OptReal,Real};
register enum statetp state;
register int base;
register char *np = &buf[1]; register char *np = &buf[1];
/* allow a '-' to be added */ /* allow a '-' to be added */
buf[0] = '-'; buf[0] = '-';
*np++ = ch; *np++ = ch;
state = is_oct(ch) ? Oct : Dec;
LoadChar(ch); LoadChar(ch);
while (is_oct(ch)) { for (;;) {
if (np < &buf[NUMSIZE]) { switch(state) {
*np++ = ch; case Oct:
} while (is_oct(ch)) {
LoadChar(ch); if (np < &buf[NUMSIZE]) *np++ = ch;
} LoadChar(ch);
switch (ch) {
case 'H':
Shex: *np++ = '\0';
tk->TOK_INT = str2long(&buf[1], 16);
if (tk->TOK_INT >= 0 && tk->TOK_INT <= max_int) {
toktype = intorcard_type;
}
else toktype = card_type;
return tk->tk_symb = INTEGER;
case '8':
case '9':
do {
if (np < &buf[NUMSIZE]) {
*np++ = ch;
} }
LoadChar(ch); if (ch == 'B' || ch == 'C') {
} while (is_dig(ch)); base = 8;
state = OctEndOrHex;
if (is_hex(ch)) break;
goto S2;
if (ch == 'H')
goto Shex;
if (ch == '.')
goto Sreal;
PushBack(ch);
goto Sdec;
case 'B':
case 'C':
if (np < &buf[NUMSIZE]) {
*np++ = ch;
}
LoadChar(ch);
if (ch == 'H')
goto Shex;
if (is_hex(ch))
goto S2;
PushBack(ch);
ch = *--np;
*np++ = '\0';
tk->TOK_INT = str2long(&buf[1], 8);
if (ch == 'C') {
toktype = char_type;
if (tk->TOK_INT < 0 || tk->TOK_INT > 255) {
lexwarning("Character constant out of range");
} }
} /* Fall Through */
else if (tk->TOK_INT >= 0 && tk->TOK_INT <= max_int) { case Dec:
toktype = intorcard_type; base = 10;
} while (is_dig(ch)) {
else toktype = card_type;
return tk->tk_symb = INTEGER;
case 'A':
case 'D':
case 'E':
case 'F':
S2:
do {
if (np < &buf[NUMSIZE]) {
*np++ = ch;
}
LoadChar(ch);
} while (is_hex(ch));
if (ch != 'H') {
lexerror("H expected after hex number");
PushBack(ch);
}
goto Shex;
case '.':
Sreal:
/* This '.' could be the first of the '..'
token. At this point, we need a look-ahead
of two characters.
*/
LoadChar(ch);
if (ch == '.') {
/* Indeed the '..' token
*/
PushBack(ch);
PushBack(ch);
goto Sdec;
}
/* a real constant */
if (np < &buf[NUMSIZE]) {
*np++ = '.';
}
if (is_dig(ch)) {
/* Fractional part
*/
do {
if (np < &buf[NUMSIZE]) { if (np < &buf[NUMSIZE]) {
*np++ = ch; *np++ = ch;
} }
LoadChar(ch); LoadChar(ch);
}
if (is_hex(ch)) state = Hex;
else if (ch == '.') state = OptReal;
else {
state = End;
if (ch == 'H') base = 16;
else PushBack(ch);
}
break;
case Hex:
while (is_hex(ch)) {
if (np < &buf[NUMSIZE]) *np++ = ch;
LoadChar(ch);
}
base = 16;
state = End;
if (ch != 'H') {
lexerror("H expected after hex number");
PushBack(ch);
}
break;
case OctEndOrHex:
if (np < &buf[NUMSIZE]) *np++ = ch;
LoadChar(ch);
if (ch == 'H') {
base = 16;
state = End;
break;
}
if (is_hex(ch)) {
state = Hex;
break;
}
PushBack(ch);
ch = *--np;
*np++ = '\0';
base = 8;
/* Fall through */
case End:
*np++ = '\0';
tk->TOK_INT = str2long(&buf[1], base);
if (ch == 'C' && base == 8) {
toktype = char_type;
if (tk->TOK_INT<0 || tk->TOK_INT>255) {
lexwarning("Character constant out of range");
}
}
else if (tk->TOK_INT>=0 &&
tk->TOK_INT<=max_int) {
toktype = intorcard_type;
}
else toktype = card_type;
return tk->tk_symb = INTEGER;
case OptReal:
/* The '.' could be the first of the '..'
token. At this point, we need a
look-ahead of two characters.
*/
LoadChar(ch);
if (ch == '.') {
/* Indeed the '..' token
*/
PushBack(ch);
PushBack(ch);
state = End;
base = 10;
break;
}
state = Real;
break;
}
if (state == Real) break;
}
/* a real real constant */
if (np < &buf[NUMSIZE]) *np++ = '.';
while (is_dig(ch)) {
/* Fractional part
*/
if (np < &buf[NUMSIZE]) *np++ = ch;
LoadChar(ch);
}
if (ch == 'E') {
/* Scale factor
*/
if (np < &buf[NUMSIZE]) *np++ = 'E';
LoadChar(ch);
if (ch == '+' || ch == '-') {
/* Signed scalefactor
*/
if (np < &buf[NUMSIZE]) *np++ = ch;
LoadChar(ch);
}
if (is_dig(ch)) {
do {
if (np < &buf[NUMSIZE]) *np++ = ch;
LoadChar(ch);
} while (is_dig(ch)); } while (is_dig(ch));
} }
else {
if (ch == 'E') { lexerror("bad scale factor");
/* Scale factor
*/
if (np < &buf[NUMSIZE]) {
*np++ = 'E';
}
LoadChar(ch);
if (ch == '+' || ch == '-') {
/* Signed scalefactor
*/
if (np < &buf[NUMSIZE]) {
*np++ = ch;
}
LoadChar(ch);
}
if (is_dig(ch)) {
do {
if (np < &buf[NUMSIZE]) {
*np++ = ch;
}
LoadChar(ch);
} while (is_dig(ch));
}
else {
lexerror("bad scale factor");
}
} }
PushBack(ch);
if (np == &buf[NUMSIZE + 1]) {
tk->TOK_REL = Salloc("0.0", 5);
lexerror("floating constant too long");
}
else tk->TOK_REL = Salloc(buf, np - buf) + 1;
toktype = real_type;
return tk->tk_symb = REAL;
default:
PushBack(ch);
Sdec:
*np++ = '\0';
tk->TOK_INT = str2long(&buf[1], 10);
if (tk->TOK_INT < 0 || tk->TOK_INT > max_int) {
toktype = card_type;
}
else toktype = intorcard_type;
return tk->tk_symb = INTEGER;
} }
PushBack(ch);
if (np >= &buf[NUMSIZE]) {
tk->TOK_REL = Salloc("0.0", 5);
lexerror("floating constant too long");
}
else tk->TOK_REL = Salloc(buf, np - buf) + 1;
toktype = real_type;
return tk->tk_symb = REAL;
/*NOTREACHED*/ /*NOTREACHED*/
} }

10
lang/m2/comp/LLlex.h
View file

@ -2,13 +2,17 @@
/* $Header$ */ /* $Header$ */
/* Structure to store a string constant
*/
struct string { struct string {
arith s_length; /* length of a string */ arith s_length; /* length of a string */
char *s_str; /* the string itself */ char *s_str; /* the string itself */
}; };
/* Token structure. Keep it small, as it is part of a parse-tree node
*/
struct token { struct token {
short tk_symb; /* token itself */ short tk_symb; /* token itself */
unsigned short tk_lineno; /* linenumber on which it occurred */ unsigned short tk_lineno; /* linenumber on which it occurred */
union { union {
struct idf *tk_idf; /* IDENT */ struct idf *tk_idf; /* IDENT */

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

@ -20,12 +20,11 @@ static char *RcsId = "$Header$";
extern char *symbol2str(); extern char *symbol2str();
extern struct idf *gen_anon_idf(); extern struct idf *gen_anon_idf();
int err_occurred = 0; extern int err_occurred;
LLmessage(tk) LLmessage(tk)
int tk; int tk;
{ {
++err_occurred;
if (tk) { if (tk) {
/* if (tk != 0), it represents the token to be inserted. /* if (tk != 0), it represents the token to be inserted.
otherwize, the current token is deleted otherwize, the current token is deleted

6
lang/m2/comp/Makefile
View file

@ -52,13 +52,13 @@ lint: Cfiles
@rm -f nmclash.o a.out @rm -f nmclash.o a.out
mkdep: mkdep.o mkdep: mkdep.o
$(CC) -o mkdep mkdep.o $(CC) $(LFLAGS) -o mkdep mkdep.o
cclash: cclash.o cclash: cclash.o
$(CC) -o cclash cclash.o $(CC) $(LFLAGS) -o cclash cclash.o
cid: cid.o cid: cid.o
$(CC) -o cid cid.o $(CC) $(LFLAGS) -o cid cid.o
# entry points not to be used directly # entry points not to be used directly

43
lang/m2/comp/Resolve Executable file
View file

@ -0,0 +1,43 @@
case $# in
1)
;;
*) echo "$0: one argument expected" 1>&2
exit 1
;;
esac
case $1 in
main)
;;
Xlint)
;;
*) echo "$0: $1: Illegal argument" 1>&2
exit 1
;;
esac
if test -d ../Xsrc
then
:
else mkdir ../Xsrc
fi
make cclash
make cid
./cclash -c -l7 `cat Cfiles` > clashes
sed '/^C_/d' < clashes > ../Xsrc/Xclashes
cd ../Xsrc
if cmp -s Xclashes clashes
then
:
else
mv Xclashes clashes
fi
rm -f Makefile
for i in `cat ../src/Cfiles`
do
cat >> Makefile <<EOF
$i: clashes ../src/$i
../src/cid -Fclashes < ../src/$i > $i
EOF
done
make `cat ../src/Cfiles`
make -f ../src/Makefile $1

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

@ -64,7 +64,7 @@ ChkArrow(expp)
return 0; return 0;
} }
expp->nd_type = PointedtoType(tp); expp->nd_type = RemoveEqual(PointedtoType(tp));
return 1; return 1;
} }
@ -106,7 +106,7 @@ ChkArr(expp)
return 0; return 0;
} }
expp->nd_type = tpl->arr_elem; expp->nd_type = RemoveEqual(tpl->arr_elem);
return 1; return 1;
} }
@ -137,7 +137,7 @@ ChkLinkOrName(expp)
if (expp->nd_class == Name) { if (expp->nd_class == Name) {
expp->nd_def = lookfor(expp, CurrVis, 1); expp->nd_def = lookfor(expp, CurrVis, 1);
expp->nd_class = Def; expp->nd_class = Def;
expp->nd_type = expp->nd_def->df_type; expp->nd_type = RemoveEqual(expp->nd_def->df_type);
} }
else if (expp->nd_class == Link) { else if (expp->nd_class == Link) {
register struct node *left = expp->nd_left; register struct node *left = expp->nd_left;
@ -161,7 +161,7 @@ ChkLinkOrName(expp)
} }
else { else {
expp->nd_def = df; expp->nd_def = df;
expp->nd_type = df->df_type; expp->nd_type = RemoveEqual(df->df_type);
expp->nd_class = LinkDef; expp->nd_class = LinkDef;
if (!(df->df_flags & (D_EXPORTED|D_QEXPORTED))) { if (!(df->df_flags & (D_EXPORTED|D_QEXPORTED))) {
/* Fields of a record are always D_QEXPORTED, /* Fields of a record are always D_QEXPORTED,
@ -418,19 +418,17 @@ getarg(argp, bases, designator)
variable. variable.
*/ */
struct type *tp; struct type *tp;
register struct node *arg = *argp; register struct node *arg = (*argp)->nd_right;
register struct node *left; register struct node *left;
if (! arg->nd_right) { if (! arg) {
node_error(arg, "too few arguments supplied"); node_error(*argp, "too few arguments supplied");
return 0; return 0;
} }
arg = arg->nd_right;
left = arg->nd_left; left = arg->nd_left;
if ((!designator && !ChkExpression(left)) || if (designator ? !ChkVariable(left) : !ChkExpression(left)) {
(designator && !ChkVariable(left))) {
return 0; return 0;
} }
@ -438,11 +436,12 @@ getarg(argp, bases, designator)
left->nd_def->df_flags |= D_NOREG; left->nd_def->df_flags |= D_NOREG;
} }
tp = BaseType(left->nd_type); if (bases) {
tp = BaseType(left->nd_type);
if (bases && !(tp->tp_fund & bases)) { if (!(tp->tp_fund & bases)) {
node_error(arg, "unexpected type"); node_error(arg, "unexpected type");
return 0; return 0;
}
} }
*argp = arg; *argp = arg;
@ -489,14 +488,14 @@ ChkProcCall(expp)
left = expp->nd_left; left = expp->nd_left;
arg = expp; arg = expp;
expp->nd_type = ResultType(left->nd_type); expp->nd_type = RemoveEqual(ResultType(left->nd_type));
for (param = ParamList(left->nd_type); param; param = param->next) { for (param = ParamList(left->nd_type); param; param = param->next) {
if (!(left = getarg(&arg, 0, IsVarParam(param)))) return 0; if (!(left = getarg(&arg, 0, IsVarParam(param)))) return 0;
if (left->nd_symb == STRING) { if (left->nd_symb == STRING) {
TryToString(left, TypeOfParam(param)); TryToString(left, TypeOfParam(param));
} }
if (! TstParCompat(TypeOfParam(param), if (! TstParCompat(RemoveEqual(TypeOfParam(param)),
left->nd_type, left->nd_type,
IsVarParam(param), IsVarParam(param),
left)) { left)) {
@ -689,15 +688,29 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
} }
allowed = AllowedTypes(expp->nd_symb); allowed = AllowedTypes(expp->nd_symb);
if (!(tpl->tp_fund & allowed) ||
(tpl != bool_type && Boolean(expp->nd_symb))) { /* Check that the application of the operator is allowed on the type
if (!(tpl->tp_fund == T_POINTER && of the operands.
(T_CARDINAL & allowed) && There are two tricky parts:
ChkAddress(tpl, tpr))) { - Boolean operators are only allowed on boolean operands, but
the "allowed-mask" of "AllowedTypes" can only indicate
an enumeration type.
- All operations that are allowed on CARDINALS are also allowed
on ADDRESS.
*/
if (Boolean(expp->nd_symb) && tpl != bool_type) {
node_error(expp,"operator \"%s\": illegal operand type(s)", symbol2str(expp->nd_symb));
return 0;
}
if (!(tpl->tp_fund & allowed)) {
if (!(tpl->tp_fund == T_POINTER &&
(T_CARDINAL & allowed) &&
ChkAddress(tpl, tpr))) {
node_error(expp,"operator \"%s\": illegal operand type(s)", symbol2str(expp->nd_symb)); node_error(expp,"operator \"%s\": illegal operand type(s)", symbol2str(expp->nd_symb));
return 0; return 0;
} }
expp->nd_type = card_type; if (expp->nd_type == card_type) expp->nd_type = address_type;
} }
if (tpl->tp_fund == T_SET) { if (tpl->tp_fund == T_SET) {
@ -1058,6 +1071,9 @@ TryToString(nd, tp)
{ {
/* Try a coercion from character constant to string. /* Try a coercion from character constant to string.
*/ */
assert(nd->nd_symb == STRING);
if (tp->tp_fund == T_ARRAY && nd->nd_type == char_type) { if (tp->tp_fund == T_ARRAY && nd->nd_type == char_type) {
int ch = nd->nd_INT; int ch = nd->nd_INT;

8
lang/m2/comp/class.h
View file

@ -29,10 +29,10 @@
class. This is implemented as a collection of tables to speed up class. This is implemented as a collection of tables to speed up
the decision whether a character has a special meaning. the decision whether a character has a special meaning.
*/ */
#define in_idf(ch) (inidf[ch]) #define in_idf(ch) ((unsigned)ch < 0177 && inidf[ch])
#define is_oct(ch) (isoct[ch]) #define is_oct(ch) ((unsigned)ch < 0177 && isoct[ch])
#define is_dig(ch) (isdig[ch]) #define is_dig(ch) ((unsigned)ch < 0177 && isdig[ch])
#define is_hex(ch) (ishex[ch]) #define is_hex(ch) ((unsigned)ch < 0177 && ishex[ch])
extern char tkclass[]; extern char tkclass[];
extern char inidf[], isoct[], isdig[], ishex[]; extern char inidf[], isoct[], isdig[], ishex[];

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

@ -55,7 +55,7 @@ CodeString(nd)
{ {
label lab; label lab;
if (nd->nd_type == char_type) { if (nd->nd_type->tp_fund != T_STRING) {
C_loc(nd->nd_INT); C_loc(nd->nd_INT);
} }
else { else {
@ -237,6 +237,7 @@ CodeCoercion(t1, t2)
case T_CHAR: case T_CHAR:
case T_CARDINAL: case T_CARDINAL:
case T_POINTER: case T_POINTER:
case T_EQUAL:
case T_INTORCARD: case T_INTORCARD:
if (t2->tp_size > word_size) { if (t2->tp_size > word_size) {
C_loc(word_size); C_loc(word_size);
@ -406,7 +407,7 @@ CodeParameters(param, arg)
CodePadString(left, tp->tp_size); CodePadString(left, tp->tp_size);
} }
else CodePExpr(left); else CodePExpr(left);
CheckAssign(left_type, tp); RangeCheck(left_type, tp);
} }
} }
@ -451,7 +452,7 @@ CodeStd(nd)
case S_CHR: case S_CHR:
CodePExpr(left); CodePExpr(left);
CheckAssign(char_type, tp); RangeCheck(char_type, tp);
break; break;
case S_FLOAT: case S_FLOAT:
@ -489,7 +490,7 @@ CodeStd(nd)
case S_VAL: case S_VAL:
CodePExpr(left); CodePExpr(left);
CheckAssign(nd->nd_type, tp); RangeCheck(nd->nd_type, tp);
break; break;
case S_ADR: case S_ADR:
@ -510,7 +511,7 @@ CodeStd(nd)
if (tp->tp_fund == T_INTEGER) C_adi(word_size); if (tp->tp_fund == T_INTEGER) C_adi(word_size);
else C_adu(word_size); else C_adu(word_size);
} }
CheckAssign(tp, int_type); RangeCheck(tp, int_type);
} }
else { else {
CodeCoercion(int_type, tp); CodeCoercion(int_type, tp);
@ -576,7 +577,7 @@ CodeAssign(nd, dss, dst)
C_blm(nd->nd_left->nd_type->tp_size); C_blm(nd->nd_left->nd_type->tp_size);
} }
CheckAssign(tpl, tpr) RangeCheck(tpl, tpr)
register struct type *tpl, *tpr; register struct type *tpl, *tpr;
{ {
/* Generate a range check if neccessary /* Generate a range check if neccessary
@ -634,6 +635,7 @@ CodeOper(expr, true_label, false_label)
C_adf(tp->tp_size); C_adf(tp->tp_size);
break; break;
case T_POINTER: case T_POINTER:
case T_EQUAL:
case T_CARDINAL: case T_CARDINAL:
case T_INTORCARD: case T_INTORCARD:
C_adu(tp->tp_size); C_adu(tp->tp_size);
@ -655,6 +657,7 @@ CodeOper(expr, true_label, false_label)
C_sbf(tp->tp_size); C_sbf(tp->tp_size);
break; break;
case T_POINTER: case T_POINTER:
case T_EQUAL:
case T_CARDINAL: case T_CARDINAL:
case T_INTORCARD: case T_INTORCARD:
C_sbu(tp->tp_size); C_sbu(tp->tp_size);
@ -674,6 +677,7 @@ CodeOper(expr, true_label, false_label)
C_mli(tp->tp_size); C_mli(tp->tp_size);
break; break;
case T_POINTER: case T_POINTER:
case T_EQUAL:
case T_CARDINAL: case T_CARDINAL:
case T_INTORCARD: case T_INTORCARD:
C_mlu(tp->tp_size); C_mlu(tp->tp_size);
@ -708,6 +712,7 @@ CodeOper(expr, true_label, false_label)
C_dvi(tp->tp_size); C_dvi(tp->tp_size);
break; break;
case T_POINTER: case T_POINTER:
case T_EQUAL:
case T_CARDINAL: case T_CARDINAL:
case T_INTORCARD: case T_INTORCARD:
C_dvu(tp->tp_size); C_dvu(tp->tp_size);
@ -723,6 +728,7 @@ CodeOper(expr, true_label, false_label)
C_rmi(tp->tp_size); C_rmi(tp->tp_size);
break; break;
case T_POINTER: case T_POINTER:
case T_EQUAL:
case T_CARDINAL: case T_CARDINAL:
case T_INTORCARD: case T_INTORCARD:
C_rmu(tp->tp_size); C_rmu(tp->tp_size);
@ -744,8 +750,9 @@ CodeOper(expr, true_label, false_label)
case T_INTEGER: case T_INTEGER:
C_cmi(tp->tp_size); C_cmi(tp->tp_size);
break; break;
case T_HIDDEN:
case T_POINTER: case T_POINTER:
case T_EQUAL:
case T_HIDDEN:
case T_CARDINAL: case T_CARDINAL:
case T_INTORCARD: case T_INTORCARD:
C_cmu(tp->tp_size); C_cmu(tp->tp_size);

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

@ -31,7 +31,7 @@ int return_occurred; /* set if a return occurred in a
ProcedureDeclaration ProcedureDeclaration
{ {
register struct def *df; register struct def *df;
struct def *df1; struct def *df1; /* only exists because &df is illegal */
} : } :
{ ++proclevel; { ++proclevel;
return_occurred = 0; return_occurred = 0;
@ -53,9 +53,10 @@ error("function procedure %s does not return a value", df->df_idf->id_text);
ProcedureHeading(struct def **pdf; int type;) ProcedureHeading(struct def **pdf; int type;)
{ {
struct paramlist *params = 0; struct paramlist *params = 0;
struct type *tp = 0; register struct type *tp;
struct type *tp1 = 0;
register struct def *df; register struct def *df;
arith NBytesParams; arith NBytesParams; /* parameter offset counter */
} : } :
PROCEDURE IDENT PROCEDURE IDENT
{ df = DeclProc(type); { df = DeclProc(type);
@ -64,8 +65,8 @@ ProcedureHeading(struct def **pdf; int type;)
} }
else NBytesParams = 0; else NBytesParams = 0;
} }
FormalParameters(&params, &tp, &NBytesParams)? FormalParameters(&params, &tp1, &NBytesParams)?
{ tp = construct_type(T_PROCEDURE, tp); { tp = construct_type(T_PROCEDURE, tp1);
tp->prc_params = params; tp->prc_params = params;
tp->prc_nbpar = NBytesParams; tp->prc_nbpar = NBytesParams;
if (df->df_type) { if (df->df_type) {
@ -151,7 +152,7 @@ TypeDeclaration
struct def *df; struct def *df;
struct type *tp; struct type *tp;
}: }:
IDENT { df = define(dot.TOK_IDF,CurrentScope,D_TYPE); } IDENT { df = define(dot.TOK_IDF, CurrentScope, D_TYPE); }
'=' type(&tp) '=' type(&tp)
{ DeclareType(df, tp); } { DeclareType(df, tp); }
; ;
@ -398,9 +399,7 @@ node_error(nd1,"type incompatibility in case label");
} }
; ;
SetType(struct type **ptp;) SetType(struct type **ptp;) :
{
} :
SET OF SimpleType(ptp) SET OF SimpleType(ptp)
{ *ptp = set_type(*ptp); } { *ptp = set_type(*ptp); }
; ;
@ -411,7 +410,6 @@ SetType(struct type **ptp;)
*/ */
PointerType(struct type **ptp;) PointerType(struct type **ptp;)
{ {
register struct def *df;
register struct node *nd; register struct node *nd;
} : } :
POINTER TO POINTER TO
@ -422,10 +420,9 @@ PointerType(struct type **ptp;)
*/ */
qualtype(&((*ptp)->next)) qualtype(&((*ptp)->next))
| %if ( nd = new_node(), nd->nd_token = dot, | %if ( nd = new_node(), nd->nd_token = dot,
df = lookfor(nd, CurrVis, 0), lookfor(nd, CurrVis, 0)->df_kind == D_MODULE)
df->df_kind == D_MODULE) { if (dot.tk_symb == IDENT) free_node(nd); }
type(&((*ptp)->next)) type(&((*ptp)->next))
{ free_node(nd); }
| |
IDENT { Forward(nd, (*ptp)); } IDENT { Forward(nd, (*ptp)); }
] ]
@ -436,11 +433,10 @@ qualtype(struct type **ptp;)
struct def *df; struct def *df;
} : } :
qualident(D_ISTYPE, &df, "type", (struct node **) 0) qualident(D_ISTYPE, &df, "type", (struct node **) 0)
{ if (!df->df_type) { { if (!(*ptp = df->df_type)) {
error("type \"%s\" not declared", df->df_idf->id_text); error("type \"%s\" not declared", df->df_idf->id_text);
*ptp = error_type; *ptp = error_type;
} }
else *ptp = df->df_type;
} }
; ;

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

@ -113,6 +113,8 @@ struct def { /* list of definitions for a name */
} df_value; } df_value;
}; };
#define SetUsed(df) ((df)->df_flags |= D_USED)
/* ALLOCDEF "def" */ /* ALLOCDEF "def" */
extern struct def extern struct def

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

@ -60,6 +60,7 @@ InitDef()
struct idf *gen_anon_idf(); struct idf *gen_anon_idf();
ill_df = MkDef(gen_anon_idf(), CurrentScope, D_ERROR); ill_df = MkDef(gen_anon_idf(), CurrentScope, D_ERROR);
ill_df->df_type = error_type;
} }
struct def * struct def *
@ -204,7 +205,6 @@ DeclProc(type)
sprint(buf,"%s_%s",CurrentScope->sc_name,df->df_idf->id_text); sprint(buf,"%s_%s",CurrentScope->sc_name,df->df_idf->id_text);
df->for_name = Salloc(buf, (unsigned) (strlen(buf)+1)); df->for_name = Salloc(buf, (unsigned) (strlen(buf)+1));
if (CurrVis == Defined->mod_vis) C_exp(df->for_name); if (CurrVis == Defined->mod_vis) C_exp(df->for_name);
open_scope(OPENSCOPE);
} }
else { else {
df = lookup(dot.TOK_IDF, CurrentScope); df = lookup(dot.TOK_IDF, CurrentScope);

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

@ -166,18 +166,17 @@ CodeFieldDesig(df, ds)
in "ds". "df" indicates the definition of the field. in "ds". "df" indicates the definition of the field.
*/ */
register struct withdesig *wds;
if (ds->dsg_kind == DSG_INIT) { if (ds->dsg_kind == DSG_INIT) {
/* In a WITH statement. We must find the designator in the /* In a WITH statement. We must find the designator in the
WITH statement, and act as if the field is a selection WITH statement, and act as if the field is a selection
of this designator. of this designator.
So, first find the right WITH statement, which is the So, first find the right WITH statement, which is the
first one of the proper record type. first one of the proper record type, which is
Notice that the proper record type is recognized by its recognized by its scope indication.
scope indication.
*/ */
wds = WithDesigs; register struct withdesig *wds = WithDesigs;
assert(wds != 0); assert(wds != 0);
while (wds->w_scope != df->df_scope) { while (wds->w_scope != df->df_scope) {
@ -225,7 +224,7 @@ CodeVarDesig(df, ds)
*/ */
assert(ds->dsg_kind == DSG_INIT); assert(ds->dsg_kind == DSG_INIT);
df->df_flags |= D_USED; SetUsed(df);
if (df->var_addrgiven) { if (df->var_addrgiven) {
/* the programmer specified an address in the declaration of /* the programmer specified an address in the declaration of
the variable. Generate code to push the address. the variable. Generate code to push the address.
@ -258,7 +257,9 @@ CodeVarDesig(df, ds)
C_lxa((arith) (proclevel - sc->sc_level)); C_lxa((arith) (proclevel - sc->sc_level));
if ((df->df_flags & D_VARPAR) || if ((df->df_flags & D_VARPAR) ||
IsConformantArray(df->df_type)) { IsConformantArray(df->df_type)) {
/* var parameter /* var parameter or conformant array.
For conformant array's, the address is
passed.
*/ */
C_adp(df->var_off); C_adp(df->var_off);
C_loi(pointer_size); C_loi(pointer_size);
@ -297,7 +298,7 @@ CodeDesig(nd, ds)
case Def: case Def:
df = nd->nd_def; df = nd->nd_def;
df->df_flags |= D_USED; SetUsed(df);
switch(df->df_kind) { switch(df->df_kind) {
case D_FIELD: case D_FIELD:
CodeFieldDesig(df, ds); CodeFieldDesig(df, ds);

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

@ -172,6 +172,7 @@ EnterParamList(ppr, Idlist, type, VARp, off)
static struct paramlist *last; static struct paramlist *last;
if (! idlist) { if (! idlist) {
/* Can only happen when a procedure type is defined */
dummy = Idlist = idlist = MkLeaf(Name, &dot); dummy = Idlist = idlist = MkLeaf(Name, &dot);
} }
for ( ; idlist; idlist = idlist->next) { for ( ; idlist; idlist = idlist->next) {
@ -182,7 +183,7 @@ EnterParamList(ppr, Idlist, type, VARp, off)
} }
else last->next = pr; else last->next = pr;
last = pr; last = pr;
if (idlist != dummy) { if (!DefinitionModule && idlist != dummy) {
df = define(idlist->nd_IDF, CurrentScope, D_VARIABLE); df = define(idlist->nd_IDF, CurrentScope, D_VARIABLE);
df->var_off = *off; df->var_off = *off;
} }
@ -222,22 +223,20 @@ DoImport(df, scope)
if (df->df_kind == D_TYPE && df->df_type->tp_fund == T_ENUMERATION) { if (df->df_kind == D_TYPE && df->df_type->tp_fund == T_ENUMERATION) {
/* Also import all enumeration literals /* Also import all enumeration literals
*/ */
df = df->df_type->enm_enums; for (df = df->df_type->enm_enums; df; df = df->enm_next) {
while (df) {
define(df->df_idf, scope, D_IMPORT)->imp_def = df; define(df->df_idf, scope, D_IMPORT)->imp_def = df;
df = df->enm_next;
} }
} }
else if (df->df_kind == D_MODULE) { else if (df->df_kind == D_MODULE) {
/* Also import all definitions that are exported from this /* Also import all definitions that are exported from this
module module
*/ */
df = df->mod_vis->sc_scope->sc_def; for (df = df->mod_vis->sc_scope->sc_def;
while (df) { df;
df = df->df_nextinscope) {
if (df->df_flags & D_EXPORTED) { if (df->df_flags & D_EXPORTED) {
define(df->df_idf,scope,D_IMPORT)->imp_def = df; define(df->df_idf,scope,D_IMPORT)->imp_def = df;
} }
df = df->df_nextinscope;
} }
} }
} }
@ -337,18 +336,22 @@ idlist->nd_IDF->id_text);
scope. There are two legal possibilities, scope. There are two legal possibilities,
which are examined below. which are examined below.
*/ */
if ((df1->df_kind == D_PROCHEAD && if (df1->df_kind == D_PROCHEAD &&
df->df_kind == D_PROCEDURE) || df->df_kind == D_PROCEDURE) {
(df1->df_kind == D_HIDDEN &&
df->df_kind == D_TYPE)) {
if (df->df_kind == D_TYPE &&
df->df_type->tp_fund != T_POINTER) {
node_error(idlist, "opaque type \"%s\" is not a pointer type", df->df_idf->id_text);
}
df1->df_kind = D_IMPORT; df1->df_kind = D_IMPORT;
df1->imp_def = df; df1->imp_def = df;
continue; continue;
} }
if (df1->df_kind == D_HIDDEN &&
df->df_kind == D_TYPE) {
if (df->df_type->tp_fund != T_POINTER) {
node_error(idlist, "opaque type \"%s\" is not a pointer type", df->df_idf->id_text);
}
assert(df1->df_type->next == NULLTYPE);
df1->df_kind = D_TYPE;
df1->df_type->next = df->df_type;
continue;
}
} }
DoImport(df, enclosing(CurrVis)->sc_scope); DoImport(df, enclosing(CurrVis)->sc_scope);

5
lang/m2/comp/lookup.c
View file

@ -15,6 +15,7 @@ static char *RcsId = "$Header$";
#include "scope.h" #include "scope.h"
#include "LLlex.h" #include "LLlex.h"
#include "node.h" #include "node.h"
#include "type.h"
struct def * struct def *
lookup(id, scope) lookup(id, scope)
@ -73,5 +74,7 @@ lookfor(id, vis, give_error)
if (give_error) id_not_declared(id); if (give_error) id_not_declared(id);
return MkDef(id->nd_IDF, vis->sc_scope, D_ERROR); df = MkDef(id->nd_IDF, vis->sc_scope, D_ERROR);
df->df_type = error_type;
return df;
} }

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

@ -24,10 +24,14 @@ DoOption(text)
default: default:
options[text[-1]]++; /* flags, debug options etc. */ options[text[-1]]++; /* flags, debug options etc. */
break; break;
/* recognized flags:
-L: don't generate fil/lin
-p: generate procentry/procexit
-w: no warnings
-n: no register messages
and many more if DEBUG
*/
case 'L' : /* don't generate fil/lin */
options['L'] = 1;
break;
case 'M': /* maximum identifier length */ case 'M': /* maximum identifier length */
idfsize = txt2int(&text); idfsize = txt2int(&text);
@ -37,10 +41,6 @@ DoOption(text)
fatal("maximum identifier length is %d", IDFSIZE); fatal("maximum identifier length is %d", IDFSIZE);
break; break;
case 'p' : /* generate profiling code procentry/procexit ???? */
options['p'] = 1;
break;
case 'I' : case 'I' :
if (++ndirs >= NDIRS) { if (++ndirs >= NDIRS) {
fatal("Too many -I options"); fatal("Too many -I options");
@ -99,14 +99,6 @@ DoOption(text)
} }
break; break;
} }
case 'n':
options['n'] = 1; /* use no registers */
break;
case 'w':
options['w'] = 1; /* no warnings will be given */
break;
} }
} }

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

@ -193,7 +193,6 @@ definition
VAR [ VariableDeclaration Semicolon ]* VAR [ VariableDeclaration Semicolon ]*
| |
ProcedureHeading(&dummy, D_PROCHEAD) ProcedureHeading(&dummy, D_PROCHEAD)
{ close_scope(0); }
Semicolon Semicolon
; ;

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

@ -90,19 +90,6 @@ Forward(tk, ptp)
CurrentScope->sc_forw = f; CurrentScope->sc_forw = f;
} }
ChForward(was, becomes)
struct type *was, *becomes;
{
/* The declaration of a hidden type had a forward reference.
In this case, the "forwards" list must be adapted.
*/
register struct forwards *f = CurrentScope->sc_forw;
while (f && f->fo_ptyp != was) f = f->next;
assert(f != 0);
f->fo_ptyp = becomes;
}
STATIC STATIC
chk_proc(df) chk_proc(df)
register struct def *df; register struct def *df;
@ -114,7 +101,7 @@ chk_proc(df)
if (df->df_kind == D_PROCHEAD) { if (df->df_kind == D_PROCHEAD) {
/* A not defined procedure /* A not defined procedure
*/ */
node_error(df->for_node, "procedure \"%s\" not defined", df->df_idf->id_text); error("procedure \"%s\" not defined", df->df_idf->id_text);
FreeNode(df->for_node); FreeNode(df->for_node);
} }
df = df->df_nextinscope; df = df->df_nextinscope;

2
lang/m2/comp/statement.g
View file

@ -85,7 +85,7 @@ StatementSequence(register struct node **pnd;)
struct node *nd; struct node *nd;
} : } :
statement(pnd) statement(pnd)
[ [ %persistent
';' statement(&nd) ';' statement(&nd)
{ if (nd) { { if (nd) {
*pnd = MkNode(Link, *pnd, nd, &dot); *pnd = MkNode(Link, *pnd, nd, &dot);

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

@ -52,14 +52,14 @@ struct proc {
struct type { struct type {
struct type *next; /* used with ARRAY, PROCEDURE, POINTER, SET, struct type *next; /* used with ARRAY, PROCEDURE, POINTER, SET,
SUBRANGE SUBRANGE, EQUAL
*/ */
int tp_fund; /* fundamental type or constructor */ int tp_fund; /* fundamental type or constructor */
#define T_RECORD 0x0001 #define T_RECORD 0x0001
#define T_ENUMERATION 0x0002 #define T_ENUMERATION 0x0002
#define T_INTEGER 0x0004 #define T_INTEGER 0x0004
#define T_CARDINAL 0x0008 #define T_CARDINAL 0x0008
/* #define T_LONGINT 0x0010 */ #define T_EQUAL 0x0010
#define T_REAL 0x0020 #define T_REAL 0x0020
#define T_HIDDEN 0x0040 #define T_HIDDEN 0x0040
#define T_POINTER 0x0080 #define T_POINTER 0x0080
@ -129,7 +129,8 @@ struct type
*construct_type(), *construct_type(),
*standard_type(), *standard_type(),
*set_type(), *set_type(),
*subr_type(); /* All from type.c */ *subr_type(),
*RemoveEqual(); /* All from type.c */
#define NULLTYPE ((struct type *) 0) #define NULLTYPE ((struct type *) 0)
@ -147,6 +148,6 @@ struct type
(tpx)->next) (tpx)->next)
#define PointedtoType(tpx) (assert((tpx)->tp_fund == T_POINTER),\ #define PointedtoType(tpx) (assert((tpx)->tp_fund == T_POINTER),\
(tpx)->next) (tpx)->next)
#define BaseType(tpx) ((tpx)->tp_fund == T_SUBRANGE ? (tpx)->next\ #define BaseType(tpx) ((tpx)->tp_fund == T_SUBRANGE ? (tpx)->next : \
: (tpx)) (tpx))
#define IsConstructed(tpx) ((tpx)->tp_fund & T_CONSTRUCTED) #define IsConstructed(tpx) ((tpx)->tp_fund & T_CONSTRUCTED)

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

@ -224,6 +224,8 @@ chk_basesubrange(tp, base)
/* A subrange had a specified base. Check that the bases conform. /* A subrange had a specified base. Check that the bases conform.
*/ */
assert(tp->tp_fund == T_SUBRANGE);
if (base->tp_fund == T_SUBRANGE) { if (base->tp_fund == T_SUBRANGE) {
/* Check that the bounds of "tp" fall within the range /* Check that the bounds of "tp" fall within the range
of "base". of "base".
@ -231,22 +233,22 @@ chk_basesubrange(tp, base)
if (base->sub_lb > tp->sub_lb || base->sub_ub < tp->sub_ub) { if (base->sub_lb > tp->sub_lb || base->sub_ub < tp->sub_ub) {
error("Base type has insufficient range"); error("Base type has insufficient range");
} }
base = BaseType(base); base = base->next;
} }
if (base->tp_fund & (T_ENUMERATION|T_CHAR)) { if (base->tp_fund & (T_ENUMERATION|T_CHAR)) {
if (BaseType(tp) != base) { if (tp->next != base) {
error("Specified base does not conform"); error("Specified base does not conform");
} }
} }
else if (base != card_type && base != int_type) { else if (base != card_type && base != int_type) {
error("Illegal base for a subrange"); error("Illegal base for a subrange");
} }
else if (base == int_type && BaseType(tp) == card_type && else if (base == int_type && tp->next == card_type &&
(tp->sub_ub > max_int || tp->sub_ub < 0)) { (tp->sub_ub > max_int || tp->sub_ub < 0)) {
error("Upperbound to large for type INTEGER"); error("Upperbound to large for type INTEGER");
} }
else if (base != BaseType(tp) && base != int_type) { else if (base != tp->next && base != int_type) {
error("Specified base does not conform"); error("Specified base does not conform");
} }
@ -462,24 +464,31 @@ DeclareType(df, tp)
*/ */
if (df->df_type && df->df_type->tp_fund == T_HIDDEN) { if (df->df_type && df->df_type->tp_fund == T_HIDDEN) {
if (tp->tp_fund != T_POINTER) { if (! (tp->tp_fund & (T_POINTER|T_HIDDEN|T_EQUAL))) {
error("opaque type \"%s\" is not a pointer type", df->df_idf->id_text); error("opaque type \"%s\" is not a pointer type", df->df_idf->id_text);
} }
/* Careful now ... we might have declarations df->df_type->next = tp;
referring to the hidden type. df->df_type->tp_fund = T_EQUAL;
*/ while (tp != df->df_type && tp->tp_fund == T_EQUAL) {
*(df->df_type) = *tp; tp = tp->next;
if (! tp->next) { }
/* It also contains a forward reference, if (tp == df->df_type) {
so update the forwardlist /* Circular definition! */
*/ error("opaque type \"%s\" has a circular definition", df->df_idf->id_text);
ChForward(tp, df->df_type);
} }
free_type(tp);
} }
else df->df_type = tp; else df->df_type = tp;
} }
struct type *
RemoveEqual(tpx)
register struct type *tpx;
{
if (tpx) while (tpx->tp_fund == T_EQUAL) tpx = tpx->next;
return tpx;
}
int int
gcd(m, n) gcd(m, n)
register int m, n; register int m, n;
@ -532,6 +541,10 @@ DumpType(tp)
print("CARDINAL"); break; print("CARDINAL"); break;
case T_REAL: case T_REAL:
print("REAL"); break; print("REAL"); break;
case T_HIDDEN:
print("HIDDEN"); break;
case T_EQUAL:
print("EQUAL"); break;
case T_POINTER: case T_POINTER:
print("POINTER"); break; print("POINTER"); break;
case T_CHAR: case T_CHAR:

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

@ -38,6 +38,9 @@ static struct type *func_type;
struct withdesig *WithDesigs; struct withdesig *WithDesigs;
struct node *Modules; struct node *Modules;
#define NO_EXIT_LABEL ((label) 0)
#define RETURN_LABEL ((label) 1)
STATIC STATIC
DoProfil() DoProfil()
{ {
@ -59,6 +62,7 @@ WalkModule(module)
{ {
/* Walk through a module, and all its local definitions. /* Walk through a module, and all its local definitions.
Also generate code for its body. Also generate code for its body.
This code is collected in an initialization routine.
*/ */
register struct scope *sc; register struct scope *sc;
struct scopelist *savevis = CurrVis; struct scopelist *savevis = CurrVis;
@ -75,7 +79,7 @@ WalkModule(module)
this module. this module.
*/ */
sc->sc_off = 0; /* no locals (yet) */ sc->sc_off = 0; /* no locals (yet) */
text_label = 1; text_label = 1; /* label at end of initialization routine */
TmpOpen(sc); /* Initialize for temporaries */ TmpOpen(sc); /* Initialize for temporaries */
C_pro_narg(sc->sc_name); C_pro_narg(sc->sc_name);
DoProfil(); DoProfil();
@ -93,10 +97,12 @@ WalkModule(module)
*/ */
C_df_dlb(l1); C_df_dlb(l1);
C_bss_cst(word_size, (arith) 0, 1); C_bss_cst(word_size, (arith) 0, 1);
/* if this one is set to non-zero, the initialization
was already done.
*/
C_loe_dlb(l1, (arith) 0); C_loe_dlb(l1, (arith) 0);
C_zne((label) 1); C_zne(RETURN_LABEL);
C_loc((arith) 1); C_ine_dlb(l1, (arith) 0);
C_ste_dlb(l1, (arith) 0);
/* Prevent this module from calling its own /* Prevent this module from calling its own
initialization routine initialization routine
*/ */
@ -111,8 +117,8 @@ WalkModule(module)
MkCalls(sc->sc_def); MkCalls(sc->sc_def);
proclevel++; proclevel++;
DO_DEBUG(options['X'], PrNode(module->mod_body, 0)); DO_DEBUG(options['X'], PrNode(module->mod_body, 0));
WalkNode(module->mod_body, (label) 0); WalkNode(module->mod_body, NO_EXIT_LABEL);
C_df_ilb((label) 1); C_df_ilb(RETURN_LABEL);
C_ret((arith) 0); C_ret((arith) 0);
C_end(-sc->sc_off); C_end(-sc->sc_off);
proclevel--; proclevel--;
@ -132,8 +138,9 @@ WalkProcedure(procedure)
register struct type *tp; register struct type *tp;
register struct paramlist *param; register struct paramlist *param;
label func_res_label = 0; label func_res_label = 0;
arith tmpvar1 = 0; arith StackAdjustment = 0;
arith retsav = 0; arith retsav = 0;
arith func_res_size = 0;
proclevel++; proclevel++;
CurrVis = procedure->prc_vis; CurrVis = procedure->prc_vis;
@ -152,11 +159,19 @@ WalkProcedure(procedure)
func_type = tp = ResultType(procedure->df_type); func_type = tp = ResultType(procedure->df_type);
if (tp && IsConstructed(tp)) { if (tp && IsConstructed(tp)) {
/* The result type of this procedure is constructed.
The actual procedure will return a pointer to a global
data area in which the function result is stored.
Notice that this does make the code non-reentrant.
Here, we create the data area for the function result.
*/
func_res_label = ++data_label; func_res_label = ++data_label;
C_df_dlb(func_res_label); C_df_dlb(func_res_label);
C_bss_cst(tp->tp_size, (arith) 0, 0); C_bss_cst(tp->tp_size, (arith) 0, 0);
} }
if (tp) func_res_size = WA(tp->tp_size);
/* Generate calls to initialization routines of modules defined within /* Generate calls to initialization routines of modules defined within
this procedure this procedure
*/ */
@ -192,22 +207,25 @@ WalkProcedure(procedure)
*/ */
arith tmpvar = NewInt(); arith tmpvar = NewInt();
if (! tmpvar1) { if (! StackAdjustment) {
/* First time we get here
*/
if (tp && !func_res_label) { if (tp && !func_res_label) {
/* Some local space, only /* Some local space, only
needed if the value itself needed if the value itself
is returned is returned
*/ */
sc->sc_off -= WA(tp->tp_size); sc->sc_off -= func_res_size;
retsav = sc->sc_off; retsav = sc->sc_off;
} }
tmpvar1 = NewInt(); StackAdjustment = NewInt();
C_loc((arith) 0); C_loc((arith) 0);
C_stl(tmpvar1); C_stl(StackAdjustment);
} }
/* First compute the size */ /* First compute the size of the array */
C_lol(param->par_def->var_off + C_lol(param->par_def->var_off +
pointer_size + word_size); pointer_size + word_size);
/* upper - lower */
C_inc(); /* gives number of elements */ C_inc(); /* gives number of elements */
C_loc(tp->arr_elem->tp_size); C_loc(tp->arr_elem->tp_size);
C_cal("_wa"); C_cal("_wa");
@ -219,15 +237,22 @@ WalkProcedure(procedure)
/* size in bytes */ /* size in bytes */
C_stl(tmpvar); C_stl(tmpvar);
C_lol(tmpvar); C_lol(tmpvar);
C_dup(word_size); C_lol(tmpvar);
C_lol(tmpvar1); C_lol(StackAdjustment);
C_adi(word_size); C_adi(word_size);
C_stl(tmpvar1); /* remember all stack adjustments */ C_stl(StackAdjustment);
/* remember stack adjustments */
C_ngi(word_size); C_ngi(word_size);
/* Assumption: stack grows
downwards!! ???
*/
C_ass(word_size); C_ass(word_size);
/* adjusted stack pointer */ /* adjusted stack pointer */
C_lor((arith) 1); C_lor((arith) 1);
/* destination address */ /* destination address (sp),
also assumes stack grows
downwards ???
*/
C_lal(param->par_def->var_off); C_lal(param->par_def->var_off);
C_loi(pointer_size); C_loi(pointer_size);
/* push source address */ /* push source address */
@ -237,7 +262,9 @@ WalkProcedure(procedure)
C_bls(word_size); C_bls(word_size);
/* copy */ /* copy */
C_lor((arith) 1); C_lor((arith) 1);
/* push new address of array */ /* push new address of array
... downwards ... ???
*/
C_lal(param->par_def->var_off); C_lal(param->par_def->var_off);
C_sti(pointer_size); C_sti(pointer_size);
FreeInt(tmpvar); FreeInt(tmpvar);
@ -245,41 +272,50 @@ WalkProcedure(procedure)
} }
} }
text_label = 1; text_label = 1; /* label at end of procedure */
DO_DEBUG(options['X'], PrNode(procedure->prc_body, 0)); DO_DEBUG(options['X'], PrNode(procedure->prc_body, 0));
WalkNode(procedure->prc_body, (label) 0); WalkNode(procedure->prc_body, NO_EXIT_LABEL);
C_df_ilb((label) 1); C_df_ilb(RETURN_LABEL); /* label at end */
tp = func_type; tp = func_type;
if (func_res_label) { if (func_res_label) {
/* Fill the data area reserved for the function result
with the result
*/
C_lae_dlb(func_res_label, (arith) 0); C_lae_dlb(func_res_label, (arith) 0);
C_sti(tp->tp_size); C_sti(tp->tp_size);
if (tmpvar1) { if (StackAdjustment) {
C_lol(tmpvar1); /* Remove copies of conformant arrays
*/
C_lol(StackAdjustment);
C_ass(word_size); C_ass(word_size);
} }
C_lae_dlb(func_res_label, (arith) 0); C_lae_dlb(func_res_label, (arith) 0);
C_ret(pointer_size); C_ret(pointer_size);
} }
else if (tp) { else if (tp) {
if (tmpvar1) { if (StackAdjustment) {
/* First save the function result in a safe place.
Then remove copies of conformant arrays,
and put function result back on the stack
*/
C_lal(retsav); C_lal(retsav);
C_sti(WA(tp->tp_size)); C_sti(func_res_size);
C_lol(tmpvar1); C_lol(StackAdjustment);
C_ass(word_size); C_ass(word_size);
C_lal(retsav); C_lal(retsav);
C_loi(WA(tp->tp_size)); C_loi(func_res_size);
} }
C_ret(WA(tp->tp_size)); C_ret(func_res_size);
} }
else { else {
if (tmpvar1) { if (StackAdjustment) {
C_lol(tmpvar1); C_lol(StackAdjustment);
C_ass(word_size); C_ass(word_size);
} }
C_ret((arith) 0); C_ret((arith) 0);
} }
if (tmpvar1) FreeInt(tmpvar1); if (StackAdjustment) FreeInt(StackAdjustment);
if (! options['n']) RegisterMessages(sc->sc_def); if (! options['n']) RegisterMessages(sc->sc_def);
C_end(-sc->sc_off); C_end(-sc->sc_off);
TmpClose(); TmpClose();
@ -293,20 +329,26 @@ WalkDef(df)
/* Walk through a list of definitions /* Walk through a list of definitions
*/ */
while (df) { for ( ; df; df = df->df_nextinscope) {
if (df->df_kind == D_MODULE) { switch(df->df_kind) {
case D_MODULE:
WalkModule(df); WalkModule(df);
} break;
else if (df->df_kind == D_PROCEDURE) { case D_PROCEDURE:
WalkProcedure(df); WalkProcedure(df);
break;
case D_VARIABLE:
if (!proclevel) {
C_df_dnam(df->var_name);
C_bss_cst(
WA(df->df_type->tp_size),
(arith) 0, 0);
}
break;
default:
/* nothing */
;
} }
else if (!proclevel && df->df_kind == D_VARIABLE) {
C_df_dnam(df->var_name);
C_bss_cst(
WA(df->df_type->tp_size),
(arith) 0, 0);
}
df = df->df_nextinscope;
} }
} }
@ -316,31 +358,28 @@ MkCalls(df)
/* Generate calls to initialization routines of modules /* Generate calls to initialization routines of modules
*/ */
while (df) { for ( ; df; df = df->df_nextinscope) {
if (df->df_kind == D_MODULE) { if (df->df_kind == D_MODULE) {
C_lxl((arith) 0); C_lxl((arith) 0);
C_cal(df->mod_vis->sc_scope->sc_name); C_cal(df->mod_vis->sc_scope->sc_name);
C_asp(pointer_size); C_asp(pointer_size);
} }
df = df->df_nextinscope;
} }
} }
WalkLink(nd, lab) WalkLink(nd, exit_label)
register struct node *nd; register struct node *nd;
label lab; label exit_label;
{ {
/* Walk node "nd", which is a link. /* Walk node "nd", which is a link.
"lab" represents the label that must be jumped to on
encountering an EXIT statement.
*/ */
while (nd && nd->nd_class == Link) { /* statement list */ while (nd && nd->nd_class == Link) { /* statement list */
WalkNode(nd->nd_left, lab); WalkNode(nd->nd_left, exit_label);
nd = nd->nd_right; nd = nd->nd_right;
} }
WalkNode(nd, lab); WalkNode(nd, exit_label);
} }
WalkCall(nd) WalkCall(nd)
@ -358,13 +397,11 @@ WalkCall(nd)
} }
} }
WalkStat(nd, lab) WalkStat(nd, exit_label)
struct node *nd; struct node *nd;
label lab; label exit_label;
{ {
/* Walk through a statement, generating code for it. /* Walk through a statement, generating code for it.
"lab" represents the label that must be jumped to on
encountering an EXIT statement.
*/ */
register struct node *left = nd->nd_left; register struct node *left = nd->nd_left;
register struct node *right = nd->nd_right; register struct node *right = nd->nd_right;
@ -386,12 +423,12 @@ WalkStat(nd, lab)
ExpectBool(left, l3, l1); ExpectBool(left, l3, l1);
assert(right->nd_symb == THEN); assert(right->nd_symb == THEN);
C_df_ilb(l3); C_df_ilb(l3);
WalkNode(right->nd_left, lab); WalkNode(right->nd_left, exit_label);
if (right->nd_right) { /* ELSE part */ if (right->nd_right) { /* ELSE part */
C_bra(l2); C_bra(l2);
C_df_ilb(l1); C_df_ilb(l1);
WalkNode(right->nd_right, lab); WalkNode(right->nd_right, exit_label);
C_df_ilb(l2); C_df_ilb(l2);
} }
else C_df_ilb(l1); else C_df_ilb(l1);
@ -399,7 +436,7 @@ WalkStat(nd, lab)
} }
case CASE: case CASE:
CaseCode(nd, lab); CaseCode(nd, exit_label);
break; break;
case WHILE: case WHILE:
@ -411,7 +448,7 @@ WalkStat(nd, lab)
C_df_ilb(l1); C_df_ilb(l1);
ExpectBool(left, l3, l2); ExpectBool(left, l3, l2);
C_df_ilb(l3); C_df_ilb(l3);
WalkNode(right, lab); WalkNode(right, exit_label);
C_bra(l1); C_bra(l1);
C_df_ilb(l2); C_df_ilb(l2);
break; break;
@ -423,7 +460,7 @@ WalkStat(nd, lab)
l1 = ++text_label; l1 = ++text_label;
l2 = ++text_label; l2 = ++text_label;
C_df_ilb(l1); C_df_ilb(l1);
WalkNode(left, lab); WalkNode(left, exit_label);
ExpectBool(right, l2, l1); ExpectBool(right, l2, l1);
C_df_ilb(l2); C_df_ilb(l2);
break; break;
@ -457,9 +494,9 @@ WalkStat(nd, lab)
} }
C_bra(l1); C_bra(l1);
C_df_ilb(l2); C_df_ilb(l2);
CheckAssign(nd->nd_type, int_type); RangeCheck(nd->nd_type, int_type);
CodeDStore(nd); CodeDStore(nd);
WalkNode(right, lab); WalkNode(right, exit_label);
CodePExpr(nd); CodePExpr(nd);
C_loc(left->nd_INT); C_loc(left->nd_INT);
C_adi(int_size); C_adi(int_size);
@ -493,8 +530,7 @@ WalkStat(nd, lab)
wds.w_scope = left->nd_type->rec_scope; wds.w_scope = left->nd_type->rec_scope;
CodeAddress(&ds); CodeAddress(&ds);
ds.dsg_kind = DSG_FIXED; ds.dsg_kind = DSG_FIXED;
/* Create a designator structure for the /* Create a designator structure for the temporary.
temporary.
*/ */
ds.dsg_offset = tmp = NewPtr(); ds.dsg_offset = tmp = NewPtr();
ds.dsg_name = 0; ds.dsg_name = 0;
@ -505,7 +541,7 @@ WalkStat(nd, lab)
link.sc_scope = wds.w_scope; link.sc_scope = wds.w_scope;
link.next = CurrVis; link.next = CurrVis;
CurrVis = &link; CurrVis = &link;
WalkNode(right, lab); WalkNode(right, exit_label);
CurrVis = link.next; CurrVis = link.next;
WithDesigs = wds.w_next; WithDesigs = wds.w_next;
FreePtr(tmp); FreePtr(tmp);
@ -513,9 +549,9 @@ WalkStat(nd, lab)
} }
case EXIT: case EXIT:
assert(lab != 0); assert(exit_label != 0);
C_bra(lab); C_bra(exit_label);
break; break;
case RETURN: case RETURN:
@ -529,7 +565,7 @@ WalkStat(nd, lab)
node_error(right, "type incompatibility in RETURN statement"); node_error(right, "type incompatibility in RETURN statement");
} }
} }
C_bra((label) 1); C_bra(RETURN_LABEL);
break; break;
default: default:
@ -576,7 +612,7 @@ ExpectBool(nd, true_label, false_label)
int int
WalkExpr(nd) WalkExpr(nd)
struct node *nd; register struct node *nd;
{ {
/* Check an expression and generate code for it /* Check an expression and generate code for it
*/ */
@ -664,12 +700,15 @@ DoAssign(nd, left, right)
struct node *nd; struct node *nd;
register struct node *left, *right; register struct node *left, *right;
{ {
/* May we do it in this order (expression first) ??? */ /* May we do it in this order (expression first) ???
The reference manual sais nothing about it, but the book does:
it sais that the left hand side is evaluated first.
*/
struct desig dsl, dsr; struct desig dsl, dsr;
if (! ChkExpression(right)) return; if (! ChkExpression(right)) return;
if (! ChkVariable(left)) return; if (! ChkVariable(left)) return;
TryToString(right, left->nd_type); if (right->nd_symb == STRING) TryToString(right, left->nd_type);
dsr = InitDesig; dsr = InitDesig;
CodeExpr(right, &dsr, NO_LABEL, NO_LABEL); CodeExpr(right, &dsr, NO_LABEL, NO_LABEL);
@ -683,7 +722,7 @@ DoAssign(nd, left, right)
} }
else { else {
CodeValue(&dsr, right->nd_type->tp_size); CodeValue(&dsr, right->nd_type->tp_size);
CheckAssign(left->nd_type, right->nd_type); RangeCheck(left->nd_type, right->nd_type);
} }
dsl = InitDesig; dsl = InitDesig;
CodeDesig(left, &dsl); CodeDesig(left, &dsl);
@ -702,12 +741,11 @@ RegisterMessages(df)
*/ */
tp = BaseType(df->df_type); tp = BaseType(df->df_type);
if ((df->df_flags & D_VARPAR) || if ((df->df_flags & D_VARPAR) ||
tp->tp_fund == T_POINTER) { (tp->tp_fund & (T_POINTER|T_HIDDEN|T_EQUAL))) {
C_ms_reg(df->var_off, pointer_size, C_ms_reg(df->var_off, pointer_size,
reg_pointer, 0); reg_pointer, 0);
} }
else if ((tp->tp_fund & T_NUMERIC) && else if (tp->tp_fund & T_NUMERIC) {
tp->tp_size <= dword_size) {
C_ms_reg(df->var_off, C_ms_reg(df->var_off,
tp->tp_size, tp->tp_size,
tp->tp_fund == T_REAL ? tp->tp_fund == T_REAL ?