long str2long();
-struct token dot, aside;
-struct type *toktype;
-struct string string;
-int idfsize = IDFSIZE;
+struct token dot,
+ aside;
+struct type *toktype;
+int idfsize = IDFSIZE;
#ifdef DEBUG
extern int cntlines;
#endif
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
}
else if (ch == '(') {
LoadChar(ch);
- if (ch == '*') ++NestLevel;
- else continue;
+ if (ch == '*') SkipComment();
}
else if (ch == '*') {
LoadChar(ch);
- if (ch == ')') {
- if (NestLevel-- == 0) return;
- }
- else continue;
+ if (ch == ')') break;
}
- 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++;
#endif
break;
}
- if (ch == EOI) {
+ if (ch == EOI) {
lexerror("end-of-file in string");
break;
}
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
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:
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 == '=') {
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:
{
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);
- while (is_oct(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;
+ 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);
+ }
+ 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);
- } while (is_dig(ch));
-
- if (is_hex(ch))
- 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) {
+ 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 'A':
- case 'D':
- case 'E':
- case 'F':
-S2:
- do {
- if (np < &buf[NUMSIZE]) {
- *np++ = ch;
+ 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);
- } while (is_hex(ch));
- if (ch != 'H') {
- lexerror("H expected after hex number");
- PushBack(ch);
+ if (ch == '.') {
+ /* Indeed the '..' token
+ */
+ PushBack(ch);
+ PushBack(ch);
+ state = End;
+ base = 10;
+ break;
+ }
+ state = Real;
+ break;
}
- goto Shex;
+ if (state == Real) break;
+ }
- case '.':
-Sreal:
- /* This '.' could be the first of the '..'
- token. At this point, we need a look-ahead
- of two characters.
+ /* 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 == '.') {
- /* Indeed the '..' token
- */
- PushBack(ch);
- PushBack(ch);
- goto Sdec;
- }
+ }
- /* a real constant */
- if (np < &buf[NUMSIZE]) {
- *np++ = '.';
+ 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)) {
- /* 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';
- }
- 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");
- }
+ else {
+ lexerror("bad scale factor");
}
+ }
- PushBack(ch);
+ 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;
+ 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*/
}
/* $Header$ */
+/* Structure to store a string constant
+*/
struct string {
- arith s_length; /* length of a string */
- char *s_str; /* the string itself */
+ 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 */
+ short tk_symb; /* token itself */
unsigned short tk_lineno; /* linenumber on which it occurred */
union {
struct idf *tk_idf; /* IDENT */
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
LSRC = tokenfile.g program.g declar.g expression.g statement.g
CC = cc
LLGENOPTIONS =
-PROFILE =
+PROFILE =
CFLAGS = $(PROFILE) $(INCLUDES) -DSTATIC=
LINTFLAGS = -DSTATIC= -DNORCSID
LFLAGS = $(PROFILE)
@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
--- /dev/null
+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
return 0;
}
- expp->nd_type = PointedtoType(tp);
+ expp->nd_type = RemoveEqual(PointedtoType(tp));
return 1;
}
return 0;
}
- expp->nd_type = tpl->arr_elem;
+ expp->nd_type = RemoveEqual(tpl->arr_elem);
return 1;
}
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;
}
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,
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;
}
left->nd_def->df_flags |= D_NOREG;
}
- tp = BaseType(left->nd_type);
-
- if (bases && !(tp->tp_fund & bases)) {
- node_error(arg, "unexpected type");
- return 0;
+ if (bases) {
+ tp = BaseType(left->nd_type);
+ if (!(tp->tp_fund & bases)) {
+ node_error(arg, "unexpected type");
+ return 0;
+ }
}
*argp = arg;
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)) {
}
allowed = AllowedTypes(expp->nd_symb);
- if (!(tpl->tp_fund & allowed) ||
- (tpl != bool_type && Boolean(expp->nd_symb))) {
- if (!(tpl->tp_fund == T_POINTER &&
- (T_CARDINAL & allowed) &&
- ChkAddress(tpl, tpr))) {
+
+ /* 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) {
{
/* 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;
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[];
{
label lab;
- if (nd->nd_type == char_type) {
+ if (nd->nd_type->tp_fund != T_STRING) {
C_loc(nd->nd_INT);
}
else {
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);
register struct type *tp;
register struct node *left;
register struct type *left_type;
-
+
assert(param != 0 && arg != 0);
if (param->next) {
CodePadString(left, tp->tp_size);
}
else CodePExpr(left);
- CheckAssign(left_type, tp);
+ RangeCheck(left_type, tp);
}
}
case S_CHR:
CodePExpr(left);
- CheckAssign(char_type, tp);
+ RangeCheck(char_type, tp);
break;
case S_FLOAT:
case S_VAL:
CodePExpr(left);
- CheckAssign(nd->nd_type, tp);
+ RangeCheck(nd->nd_type, tp);
break;
case S_ADR:
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);
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
C_adf(tp->tp_size);
break;
case T_POINTER:
+ case T_EQUAL:
case T_CARDINAL:
case T_INTORCARD:
C_adu(tp->tp_size);
C_sbf(tp->tp_size);
break;
case T_POINTER:
+ case T_EQUAL:
case T_CARDINAL:
case T_INTORCARD:
C_sbu(tp->tp_size);
C_mli(tp->tp_size);
break;
case T_POINTER:
+ case T_EQUAL:
case T_CARDINAL:
case T_INTORCARD:
C_mlu(tp->tp_size);
C_dvi(tp->tp_size);
break;
case T_POINTER:
+ case T_EQUAL:
case T_CARDINAL:
case T_INTORCARD:
C_dvu(tp->tp_size);
C_rmi(tp->tp_size);
break;
case T_POINTER:
+ case T_EQUAL:
case T_CARDINAL:
case T_INTORCARD:
C_rmu(tp->tp_size);
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);
ProcedureDeclaration
{
register struct def *df;
- struct def *df1;
+ struct def *df1; /* only exists because &df is illegal */
} :
{ ++proclevel;
return_occurred = 0;
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);
}
else NBytesParams = 0;
}
- FormalParameters(¶ms, &tp, &NBytesParams)?
- { tp = construct_type(T_PROCEDURE, tp);
+ FormalParameters(¶ms, &tp1, &NBytesParams)?
+ { tp = construct_type(T_PROCEDURE, tp1);
tp->prc_params = params;
tp->prc_nbpar = NBytesParams;
if (df->df_type) {
struct def *df;
struct type *tp;
}:
- IDENT { df = define(dot.TOK_IDF,CurrentScope,D_TYPE); }
+ IDENT { df = define(dot.TOK_IDF, CurrentScope, D_TYPE); }
'=' type(&tp)
{ DeclareType(df, tp); }
;
}
;
-SetType(struct type **ptp;)
-{
-} :
+SetType(struct type **ptp;) :
SET OF SimpleType(ptp)
{ *ptp = set_type(*ptp); }
;
*/
PointerType(struct type **ptp;)
{
- register struct def *df;
register struct node *nd;
} :
POINTER TO
*/
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)); }
]
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;
}
;
} df_value;
};
+#define SetUsed(df) ((df)->df_flags |= D_USED)
+
/* ALLOCDEF "def" */
extern struct def
struct idf *gen_anon_idf();
ill_df = MkDef(gen_anon_idf(), CurrentScope, D_ERROR);
+ ill_df->df_type = error_type;
}
struct def *
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);
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) {
*/
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.
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);
case Def:
df = nd->nd_def;
- df->df_flags |= D_USED;
+ SetUsed(df);
switch(df->df_kind) {
case D_FIELD:
CodeFieldDesig(df, ds);
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) {
}
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;
}
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;
}
}
}
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);
#include "scope.h"
#include "LLlex.h"
#include "node.h"
+#include "type.h"
struct def *
lookup(id, scope)
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;
}
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);
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");
}
break;
}
-
- case 'n':
- options['n'] = 1; /* use no registers */
- break;
-
- case 'w':
- options['w'] = 1; /* no warnings will be given */
- break;
}
}
VAR [ VariableDeclaration Semicolon ]*
|
ProcedureHeading(&dummy, D_PROCHEAD)
- { close_scope(0); }
Semicolon
;
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;
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;
struct node *nd;
} :
statement(pnd)
- [
+ [ %persistent
';' statement(&nd)
{ if (nd) {
*pnd = MkNode(Link, *pnd, nd, &dot);
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
*construct_type(),
*standard_type(),
*set_type(),
- *subr_type(); /* All from type.c */
+ *subr_type(),
+ *RemoveEqual(); /* All from type.c */
#define NULLTYPE ((struct type *) 0)
(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)
/* 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".
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");
}
*/
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;
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:
struct withdesig *WithDesigs;
struct node *Modules;
+#define NO_EXIT_LABEL ((label) 0)
+#define RETURN_LABEL ((label) 1)
+
STATIC
DoProfil()
{
{
/* 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;
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();
*/
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
*/
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--;
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;
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
*/
*/
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");
/* 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 */
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);
}
}
- 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();
/* 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);
+ 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;
}
}
/* 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)
}
}
-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;
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);
}
case CASE:
- CaseCode(nd, lab);
+ CaseCode(nd, exit_label);
break;
case WHILE:
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;
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;
}
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);
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;
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);
}
case EXIT:
- assert(lab != 0);
+ assert(exit_label != 0);
- C_bra(lab);
+ C_bra(exit_label);
break;
case RETURN:
node_error(right, "type incompatibility in RETURN statement");
}
}
- C_bra((label) 1);
+ C_bra(RETURN_LABEL);
break;
default:
int
WalkExpr(nd)
- struct node *nd;
+ register struct node *nd;
{
/* Check an expression and generate code for it
*/
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);
}
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);
*/
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 ?
public / ack.git / commitdiff