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

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

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

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

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

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

@ -20,12 +20,11 @@ static char *RcsId = "$Header$";
extern char *symbol2str();
extern struct idf *gen_anon_idf();
int err_occurred = 0;
extern int err_occurred;
LLmessage(tk)
int tk;
{
++err_occurred;
if (tk) {
/* if (tk != 0), it represents the token to be inserted.
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
mkdep: mkdep.o
$(CC) -o mkdep mkdep.o
$(CC) $(LFLAGS) -o mkdep mkdep.o
cclash: cclash.o
$(CC) -o cclash cclash.o
$(CC) $(LFLAGS) -o cclash cclash.o
cid: cid.o
$(CC) -o cid cid.o
$(CC) $(LFLAGS) -o cid cid.o
# 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

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

@ -64,7 +64,7 @@ ChkArrow(expp)
return 0;
}
expp->nd_type = PointedtoType(tp);
expp->nd_type = RemoveEqual(PointedtoType(tp));
return 1;
}
@ -106,7 +106,7 @@ ChkArr(expp)
return 0;
}
expp->nd_type = tpl->arr_elem;
expp->nd_type = RemoveEqual(tpl->arr_elem);
return 1;
}
@ -137,7 +137,7 @@ ChkLinkOrName(expp)
if (expp->nd_class == Name) {
expp->nd_def = lookfor(expp, CurrVis, 1);
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) {
register struct node *left = expp->nd_left;
@ -161,7 +161,7 @@ ChkLinkOrName(expp)
}
else {
expp->nd_def = df;
expp->nd_type = df->df_type;
expp->nd_type = RemoveEqual(df->df_type);
expp->nd_class = LinkDef;
if (!(df->df_flags & (D_EXPORTED|D_QEXPORTED))) {
/* Fields of a record are always D_QEXPORTED,
@ -418,19 +418,17 @@ getarg(argp, bases, designator)
variable.
*/
struct type *tp;
register struct node *arg = *argp;
register struct node *arg = (*argp)->nd_right;
register struct node *left;
if (! arg->nd_right) {
node_error(arg, "too few arguments supplied");
if (! arg) {
node_error(*argp, "too few arguments supplied");
return 0;
}
arg = arg->nd_right;
left = arg->nd_left;
if ((!designator && !ChkExpression(left)) ||
(designator && !ChkVariable(left))) {
if (designator ? !ChkVariable(left) : !ChkExpression(left)) {
return 0;
}
@ -438,12 +436,13 @@ getarg(argp, bases, designator)
left->nd_def->df_flags |= D_NOREG;
}
if (bases) {
tp = BaseType(left->nd_type);
if (bases && !(tp->tp_fund & bases)) {
if (!(tp->tp_fund & bases)) {
node_error(arg, "unexpected type");
return 0;
}
}
*argp = arg;
return left;
@ -489,14 +488,14 @@ ChkProcCall(expp)
left = expp->nd_left;
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) {
if (!(left = getarg(&arg, 0, IsVarParam(param)))) return 0;
if (left->nd_symb == STRING) {
TryToString(left, TypeOfParam(param));
}
if (! TstParCompat(TypeOfParam(param),
if (! TstParCompat(RemoveEqual(TypeOfParam(param)),
left->nd_type,
IsVarParam(param),
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);
if (!(tpl->tp_fund & allowed) ||
(tpl != bool_type && Boolean(expp->nd_symb))) {
/* Check that the application of the operator is allowed on the type
of the operands.
There are two tricky parts:
- 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));
return 0;
}
expp->nd_type = card_type;
if (expp->nd_type == card_type) expp->nd_type = address_type;
}
if (tpl->tp_fund == T_SET) {
@ -1058,6 +1071,9 @@ TryToString(nd, tp)
{
/* Try a coercion from character constant to string.
*/
assert(nd->nd_symb == STRING);
if (tp->tp_fund == T_ARRAY && nd->nd_type == char_type) {
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
the decision whether a character has a special meaning.
*/
#define in_idf(ch) (inidf[ch])
#define is_oct(ch) (isoct[ch])
#define is_dig(ch) (isdig[ch])
#define is_hex(ch) (ishex[ch])
#define in_idf(ch) ((unsigned)ch < 0177 && inidf[ch])
#define is_oct(ch) ((unsigned)ch < 0177 && isoct[ch])
#define is_dig(ch) ((unsigned)ch < 0177 && isdig[ch])
#define is_hex(ch) ((unsigned)ch < 0177 && ishex[ch])
extern char tkclass[];
extern char inidf[], isoct[], isdig[], ishex[];

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

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

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

@ -31,7 +31,7 @@ int return_occurred; /* set if a return occurred in a
ProcedureDeclaration
{
register struct def *df;
struct def *df1;
struct def *df1; /* only exists because &df is illegal */
} :
{ ++proclevel;
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;)
{
struct paramlist *params = 0;
struct type *tp = 0;
register struct type *tp;
struct type *tp1 = 0;
register struct def *df;
arith NBytesParams;
arith NBytesParams; /* parameter offset counter */
} :
PROCEDURE IDENT
{ df = DeclProc(type);
@ -64,8 +65,8 @@ ProcedureHeading(struct def **pdf; int type;)
}
else NBytesParams = 0;
}
FormalParameters(&params, &tp, &NBytesParams)?
{ tp = construct_type(T_PROCEDURE, tp);
FormalParameters(&params, &tp1, &NBytesParams)?
{ tp = construct_type(T_PROCEDURE, tp1);
tp->prc_params = params;
tp->prc_nbpar = NBytesParams;
if (df->df_type) {
@ -398,9 +399,7 @@ node_error(nd1,"type incompatibility in case label");
}
;
SetType(struct type **ptp;)
{
} :
SetType(struct type **ptp;) :
SET OF SimpleType(ptp)
{ *ptp = set_type(*ptp); }
;
@ -411,7 +410,6 @@ SetType(struct type **ptp;)
*/
PointerType(struct type **ptp;)
{
register struct def *df;
register struct node *nd;
} :
POINTER TO
@ -422,10 +420,9 @@ PointerType(struct type **ptp;)
*/
qualtype(&((*ptp)->next))
| %if ( nd = new_node(), nd->nd_token = dot,
df = lookfor(nd, CurrVis, 0),
df->df_kind == D_MODULE)
lookfor(nd, CurrVis, 0)->df_kind == D_MODULE)
{ if (dot.tk_symb == IDENT) free_node(nd); }
type(&((*ptp)->next))
{ free_node(nd); }
|
IDENT { Forward(nd, (*ptp)); }
]
@ -436,11 +433,10 @@ qualtype(struct type **ptp;)
struct def *df;
} :
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);
*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;
};
#define SetUsed(df) ((df)->df_flags |= D_USED)
/* ALLOCDEF "def" */
extern struct def

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

@ -60,6 +60,7 @@ InitDef()
struct idf *gen_anon_idf();
ill_df = MkDef(gen_anon_idf(), CurrentScope, D_ERROR);
ill_df->df_type = error_type;
}
struct def *
@ -204,7 +205,6 @@ DeclProc(type)
sprint(buf,"%s_%s",CurrentScope->sc_name,df->df_idf->id_text);
df->for_name = Salloc(buf, (unsigned) (strlen(buf)+1));
if (CurrVis == Defined->mod_vis) C_exp(df->for_name);
open_scope(OPENSCOPE);
}
else {
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.
*/
register struct withdesig *wds;
if (ds->dsg_kind == DSG_INIT) {
/* In a WITH statement. We must find the designator in the
WITH statement, and act as if the field is a selection
of this designator.
So, first find the right WITH statement, which is the
first one of the proper record type.
Notice that the proper record type is recognized by its
scope indication.
first one of the proper record type, which is
recognized by its scope indication.
*/
wds = WithDesigs;
register struct withdesig *wds = WithDesigs;
assert(wds != 0);
while (wds->w_scope != df->df_scope) {
@ -225,7 +224,7 @@ CodeVarDesig(df, ds)
*/
assert(ds->dsg_kind == DSG_INIT);
df->df_flags |= D_USED;
SetUsed(df);
if (df->var_addrgiven) {
/* the programmer specified an address in the declaration of
the variable. Generate code to push the address.
@ -258,7 +257,9 @@ CodeVarDesig(df, ds)
C_lxa((arith) (proclevel - sc->sc_level));
if ((df->df_flags & D_VARPAR) ||
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_loi(pointer_size);
@ -297,7 +298,7 @@ CodeDesig(nd, ds)
case Def:
df = nd->nd_def;
df->df_flags |= D_USED;
SetUsed(df);
switch(df->df_kind) {
case D_FIELD:
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;
if (! idlist) {
/* Can only happen when a procedure type is defined */
dummy = Idlist = idlist = MkLeaf(Name, &dot);
}
for ( ; idlist; idlist = idlist->next) {
@ -182,7 +183,7 @@ EnterParamList(ppr, Idlist, type, VARp, off)
}
else last->next = pr;
last = pr;
if (idlist != dummy) {
if (!DefinitionModule && idlist != dummy) {
df = define(idlist->nd_IDF, CurrentScope, D_VARIABLE);
df->var_off = *off;
}
@ -222,22 +223,20 @@ DoImport(df, scope)
if (df->df_kind == D_TYPE && df->df_type->tp_fund == T_ENUMERATION) {
/* Also import all enumeration literals
*/
df = df->df_type->enm_enums;
while (df) {
for (df = df->df_type->enm_enums; df; df = df->enm_next) {
define(df->df_idf, scope, D_IMPORT)->imp_def = df;
df = df->enm_next;
}
}
else if (df->df_kind == D_MODULE) {
/* Also import all definitions that are exported from this
module
*/
df = df->mod_vis->sc_scope->sc_def;
while (df) {
for (df = df->mod_vis->sc_scope->sc_def;
df;
df = df->df_nextinscope) {
if (df->df_flags & D_EXPORTED) {
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,
which are examined below.
*/
if ((df1->df_kind == D_PROCHEAD &&
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);
}
if (df1->df_kind == D_PROCHEAD &&
df->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) {
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);

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

@ -15,6 +15,7 @@ static char *RcsId = "$Header$";
#include "scope.h"
#include "LLlex.h"
#include "node.h"
#include "type.h"
struct def *
lookup(id, scope)
@ -73,5 +74,7 @@ lookfor(id, vis, give_error)
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:
options[text[-1]]++; /* flags, debug options etc. */
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 */
idfsize = txt2int(&text);
@ -37,10 +41,6 @@ DoOption(text)
fatal("maximum identifier length is %d", IDFSIZE);
break;
case 'p' : /* generate profiling code procentry/procexit ???? */
options['p'] = 1;
break;
case 'I' :
if (++ndirs >= NDIRS) {
fatal("Too many -I options");
@ -99,14 +99,6 @@ DoOption(text)
}
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 ]*
|
ProcedureHeading(&dummy, D_PROCHEAD)
{ close_scope(0); }
Semicolon
;

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

@ -90,19 +90,6 @@ Forward(tk, ptp)
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
chk_proc(df)
register struct def *df;
@ -114,7 +101,7 @@ chk_proc(df)
if (df->df_kind == D_PROCHEAD) {
/* 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);
}
df = df->df_nextinscope;

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

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

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

@ -52,14 +52,14 @@ struct proc {
struct type {
struct type *next; /* used with ARRAY, PROCEDURE, POINTER, SET,
SUBRANGE
SUBRANGE, EQUAL
*/
int tp_fund; /* fundamental type or constructor */
#define T_RECORD 0x0001
#define T_ENUMERATION 0x0002
#define T_INTEGER 0x0004
#define T_CARDINAL 0x0008
/* #define T_LONGINT 0x0010 */
#define T_EQUAL 0x0010
#define T_REAL 0x0020
#define T_HIDDEN 0x0040
#define T_POINTER 0x0080
@ -129,7 +129,8 @@ struct type
*construct_type(),
*standard_type(),
*set_type(),
*subr_type(); /* All from type.c */
*subr_type(),
*RemoveEqual(); /* All from type.c */
#define NULLTYPE ((struct type *) 0)
@ -147,6 +148,6 @@ struct type
(tpx)->next)
#define PointedtoType(tpx) (assert((tpx)->tp_fund == T_POINTER),\
(tpx)->next)
#define BaseType(tpx) ((tpx)->tp_fund == T_SUBRANGE ? (tpx)->next\
: (tpx))
#define BaseType(tpx) ((tpx)->tp_fund == T_SUBRANGE ? (tpx)->next : \
(tpx))
#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.
*/
assert(tp->tp_fund == T_SUBRANGE);
if (base->tp_fund == T_SUBRANGE) {
/* Check that the bounds of "tp" fall within the range
of "base".
@ -231,22 +233,22 @@ chk_basesubrange(tp, base)
if (base->sub_lb > tp->sub_lb || base->sub_ub < tp->sub_ub) {
error("Base type has insufficient range");
}
base = BaseType(base);
base = base->next;
}
if (base->tp_fund & (T_ENUMERATION|T_CHAR)) {
if (BaseType(tp) != base) {
if (tp->next != base) {
error("Specified base does not conform");
}
}
else if (base != card_type && base != int_type) {
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)) {
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");
}
@ -462,24 +464,31 @@ DeclareType(df, tp)
*/
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);
}
/* Careful now ... we might have declarations
referring to the hidden type.
*/
*(df->df_type) = *tp;
if (! tp->next) {
/* It also contains a forward reference,
so update the forwardlist
*/
ChForward(tp, df->df_type);
df->df_type->next = tp;
df->df_type->tp_fund = T_EQUAL;
while (tp != df->df_type && tp->tp_fund == T_EQUAL) {
tp = tp->next;
}
if (tp == df->df_type) {
/* Circular definition! */
error("opaque type \"%s\" has a circular definition", df->df_idf->id_text);
}
free_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
gcd(m, n)
register int m, n;
@ -532,6 +541,10 @@ DumpType(tp)
print("CARDINAL"); break;
case T_REAL:
print("REAL"); break;
case T_HIDDEN:
print("HIDDEN"); break;
case T_EQUAL:
print("EQUAL"); break;
case T_POINTER:
print("POINTER"); break;
case T_CHAR:

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

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