/* L E X I C A L A N A L Y S E R F O R M O D U L A - 2 */
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
#include "debug.h"
#include "idfsize.h"
#include "numsize.h"
Note that comments may be nested (par. 3.5).
*/
register int ch;
+ register int CommentLevel = 0;
+ LoadChar(ch);
for (;;) {
- LoadChar(ch);
if (class(ch) == STNL) {
LineNumber++;
#ifdef DEBUG
}
else if (ch == '(') {
LoadChar(ch);
- if (ch == '*') SkipComment();
+ if (ch == '*') CommentLevel++;
+ else continue;
}
else if (ch == '*') {
LoadChar(ch);
- if (ch == ')') break;
+ if (ch == ')') {
+ CommentLevel--;
+ if (CommentLevel < 0) break;
+ }
+ else continue;
}
+ else if (ch == EOI) {
+ lexerror("unterminated comment");
+ break;
+ }
+ LoadChar(ch);
}
}
register struct string *str = (struct string *) Malloc(sizeof(struct string));
register char *p;
- str->s_str = p = Malloc((unsigned int) (str->s_length = ISTRSIZE));
+ str->s_length = ISTRSIZE;
+ str->s_str = p = Malloc((unsigned int) ISTRSIZE);
while (LoadChar(ch), ch != upto) {
if (class(ch) == STNL) {
lexerror("newline in string");
case STCHAR:
default:
crash("(LLlex) Impossible character class");
+ /*NOTREACHED*/
}
/*NOTREACHED*/
}
/* T O K E N D E S C R I P T O R D E F I N I T I O N */
-/* $Header$ */
-
/* Structure to store a string constant
*/
struct string {
/* S Y N T A X E R R O R R E P O R T I N G */
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
/* Defines the LLmessage routine. LLgen-generated parsers require the
existence of a routine of that name.
The routine must do syntax-error reporting and must be able to
insert_token(tk)
int tk;
{
- aside = dot;
+ register struct token *dotp = ˙
+
+ aside = *dotp;
- dot.tk_symb = tk;
+ dotp->tk_symb = tk;
switch (tk) {
/* The operands need some body */
case IDENT:
- dot.TOK_IDF = gen_anon_idf();
+ dotp->TOK_IDF = gen_anon_idf();
break;
case STRING:
- dot.TOK_SLE = 1;
- dot.TOK_STR = Salloc("", 1);
+ dotp->tk_data.tk_str = (struct string *)
+ Malloc(sizeof (struct string));
+ dotp->TOK_SLE = 1;
+ dotp->TOK_STR = Salloc("", 1);
break;
case INTEGER:
- dot.TOK_INT = 1;
+ dotp->TOK_INT = 1;
break;
case REAL:
- dot.TOK_REL = Salloc("0.0", 4);
+ dotp->TOK_REL = Salloc("0.0", 4);
break;
}
}
# make modula-2 "compiler"
-# $Header$
EMDIR = /usr/ceriel/em
MHDIR = $(EMDIR)/modules/h
PKGDIR = $(EMDIR)/modules/pkg
INCLUDES = -I$(MHDIR) -I$(EMDIR)/h -I$(PKGDIR)
-LSRC = tokenfile.g program.g declar.g expression.g statement.g
+GFILES = tokenfile.g program.g declar.g expression.g statement.g
CC = cc
LLGENOPTIONS =
PROFILE =
CFLAGS = $(PROFILE) $(INCLUDES) -DSTATIC=
LINTFLAGS = -DSTATIC= -DNORCSID
LFLAGS = $(PROFILE)
+LSRC = tokenfile.c program.c declar.c expression.c statement.c
LOBJ = tokenfile.o program.o declar.o expression.o statement.o
+CSRC = LLlex.c LLmessage.c char.c error.c main.c \
+ symbol2str.c tokenname.c idf.c input.c type.c def.c \
+ scope.c misc.c enter.c defmodule.c typequiv.c node.c \
+ cstoper.c chk_expr.c options.c walk.c casestat.c desig.c \
+ code.c tmpvar.c lookup.c Version.c
COBJ = LLlex.o LLmessage.o char.o error.o main.o \
symbol2str.o tokenname.o idf.o input.o type.o def.o \
scope.o misc.o enter.o defmodule.o typequiv.o node.o \
cstoper.o chk_expr.o options.o walk.o casestat.o desig.o \
- code.o tmpvar.o lookup.o
+ code.o tmpvar.o lookup.o Version.o
+SRC = $(CSRC) $(LSRC) Lpars.c
OBJ = $(COBJ) $(LOBJ) Lpars.o
# Keep the next entries up to date!
@rm -f nmclash.o a.out
clean:
- rm -f $(OBJ) $(GENFILES) LLfiles hfiles Cfiles tab cclash.o cid.o cclash cid
+ rm -f $(OBJ) $(GENFILES) LLfiles hfiles Cfiles tab cclash.o cid.o cclash cid clashes
(cd .. ; rm -rf Xsrc)
lint: Cfiles
- sh -c `if $(CC) nmclash.c > /dev/null 2>&1 ; then make Xlint ; else sh Resolve Xlint ; fi'
+ sh -c 'if $(CC) nmclash.c > /dev/null 2>&1 ; then make Xlint ; else sh Resolve Xlint ; fi'
@rm -f nmclash.o a.out
mkdep: mkdep.o
cclash: cclash.o
$(CC) $(LFLAGS) -o cclash cclash.o
+clashes: $(SRC) $(HFILES)
+ sh -c 'if test -f clashes ; then ./cclash -l7 clashes $? > Xclashes ; mv Xclashes clashes ; else ./cclash -l7 $? > clashes ; fi'
+
cid: cid.o
$(CC) $(LFLAGS) -o cid cid.o
# entry points not to be used directly
Xlint:
- lint $(INCLUDES) $(LINTFLAGS) `./sources $(OBJ)`
+ lint $(INCLUDES) $(LINTFLAGS) $(SRC)
-Cfiles: hfiles LLfiles $(GENHFILES) $(GENCFILES)
- ./sources $(OBJ) > Cfiles
- sh -c 'for i in $(HFILES) ; do echo $$i ; done >> Cfiles'
+Cfiles: hfiles LLfiles $(GENCFILES) $(GENHFILES)
+ echo $(SRC) $(HFILES) > Cfiles
-LLfiles: $(LSRC)
- $(LLGEN) $(LLGENOPTIONS) $(LSRC)
+LLfiles: $(GFILES)
+ $(LLGEN) $(LLGENOPTIONS) $(GFILES)
@touch LLfiles
hfiles: Parameters make.hfiles
touch hfiles
main: $(OBJ) ../src/Makefile
- $(CC) $(LFLAGS) $(OBJ) $(LIBDIR)/libem_mes.a $(LIBDIR)/libemk.a $(LIBDIR)/input.a $(LIBDIR)/assert.a $(LIBDIR)/alloc.a $(LIBDIR)/malloc.o $(LIBDIR)/libprint.a $(LIBDIR)/libstr.a $(LIBDIR)/libsystem.a -o ../src/main
+ $(CC) $(LFLAGS) $(OBJ) $(LIBDIR)/libem_mes.a $(LIBDIR)/libemk.a $(LIBDIR)/input.a $(LIBDIR)/assert.a $(LIBDIR)/alloc.a $(LIBDIR)/dickmalloc.o $(LIBDIR)/libprint.a $(LIBDIR)/libstr.a $(LIBDIR)/libsystem.a -o ../src/main
size ../src/main
tokenfile.g: tokenname.c make.tokfile
depend: mkdep
sed '/^#AUTOAUTO/,$$d' Makefile > Makefile.new
echo '#AUTOAUTOAUTOAUTOAUTOAUTOAUTOAUTO' >> Makefile.new
- ./mkdep `./sources $(OBJ)` |\
+ ./mkdep $(SRC) |\
sed 's/\.c:/\.o:/' >> Makefile.new
mv Makefile Makefile.old
mv Makefile.new Makefile
symbol2str.o: Lpars.h
tokenname.o: Lpars.h idf.h tokenname.h
idf.o: idf.h
-input.o: f_info.h input.h inputtype.h
+input.o: def.h f_info.h idf.h input.h inputtype.h scope.h
type.o: LLlex.h const.h debug.h def.h idf.h maxset.h node.h scope.h target_sizes.h type.h walk.h
def.o: LLlex.h Lpars.h debug.h def.h idf.h main.h node.h scope.h type.h
scope.o: LLlex.h debug.h def.h idf.h node.h scope.h type.h
misc.o: LLlex.h f_info.h idf.h misc.h node.h
enter.o: LLlex.h debug.h def.h idf.h main.h node.h scope.h type.h
-defmodule.o: LLlex.h debug.h def.h f_info.h idf.h input.h inputtype.h main.h scope.h
+defmodule.o: LLlex.h Lpars.h debug.h def.h f_info.h idf.h input.h inputtype.h main.h node.h scope.h
typequiv.o: LLlex.h debug.h def.h node.h type.h
node.o: LLlex.h debug.h def.h node.h type.h
cstoper.o: LLlex.h Lpars.h debug.h idf.h node.h standards.h target_sizes.h type.h
desig.o: LLlex.h debug.h def.h desig.h node.h scope.h type.h
code.o: LLlex.h Lpars.h debug.h def.h desig.h node.h scope.h standards.h type.h walk.h
tmpvar.o: debug.h def.h main.h scope.h type.h
-lookup.o: LLlex.h debug.h def.h idf.h node.h scope.h
+lookup.o: LLlex.h debug.h def.h idf.h node.h scope.h type.h
tokenfile.o: Lpars.h
program.o: LLlex.h Lpars.h debug.h def.h f_info.h idf.h main.h node.h scope.h type.h
declar.o: LLlex.h Lpars.h chk_expr.h debug.h def.h idf.h main.h misc.h node.h scope.h type.h
/* target machine alignment requirements */
#define AL_CHAR 1
-#define AL_SHORT SZ_SHORT
-#define AL_WORD SZ_WORD
-#define AL_INT SZ_WORD
-#define AL_LONG SZ_WORD
-#define AL_FLOAT SZ_WORD
-#define AL_DOUBLE SZ_WORD
-#define AL_POINTER SZ_WORD
+#define AL_SHORT (int)SZ_SHORT
+#define AL_WORD (int)SZ_WORD
+#define AL_INT (int)SZ_WORD
+#define AL_LONG (int)SZ_WORD
+#define AL_FLOAT (int)SZ_WORD
+#define AL_DOUBLE (int)SZ_WORD
+#define AL_POINTER (int)SZ_WORD
#define AL_STRUCT 1
#define AL_UNION 1
#endif DEBUG
!File: inputtype.h
-#undef INP_READ_IN_ONE 1 /* read input file in one */
+#define INP_READ_IN_ONE 1 /* read input file in one */
!File: maxset.h
:
else mkdir ../Xsrc
fi
-make cclash
-make cid
-./cclash -c -l7 `cat Cfiles` > clashes
-sed '/^C_/d' < clashes > ../Xsrc/Xclashes
+make cclash clashes cid
+sed '/^C_/d' < clashes > tmp$$
+./cclash -c -l7 tmp$$ > ../Xsrc/Xclashes
+rm -f tmp$$
cd ../Xsrc
if cmp -s Xclashes clashes
then
--- /dev/null
+char Version[] = "Version 0.5";
/* C A S E S T A T E M E N T C O D E G E N E R A T I O N */
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
+/* Generation of case statements is done by first creating a
+ description structure for the statement, build a list of the
+ case-labels, then generating a case description in the code,
+ and generating either CSA or CSB, and then generating code for the
+ cases themselves.
+*/
#include "debug.h"
#include "density.h"
struct switch_hdr {
- struct switch_hdr *next;
- label sh_break;
- label sh_default;
- int sh_nrofentries;
- struct type *sh_type;
- arith sh_lowerbd;
- arith sh_upperbd;
- struct case_entry *sh_entries;
+ struct switch_hdr *next; /* in the free list */
+ label sh_break; /* label of statement after this one */
+ label sh_default; /* label of ELSE part, or 0 */
+ int sh_nrofentries; /* number of cases */
+ struct type *sh_type; /* type of case expression */
+ arith sh_lowerbd; /* lowest case label */
+ arith sh_upperbd; /* highest case label */
+ struct case_entry *sh_entries; /* the cases with their generated
+ labels
+ */
};
-/* STATICALLOCDEF "switch_hdr" */
+/* STATICALLOCDEF "switch_hdr" 5 */
struct case_entry {
- struct case_entry *next;
- label ce_label;
- arith ce_value;
+ struct case_entry *next; /* next in list */
+ label ce_label; /* generated label */
+ arith ce_value; /* value of case label */
};
-/* STATICALLOCDEF "case_entry" */
+/* STATICALLOCDEF "case_entry" 20 */
/* The constant DENSITY determines when CSA and when CSB instructions
are generated. Reasonable values are: 2, 3, 4.
On machines that have lots of address space and memory, higher values
- are also reasonable. On these machines the density of jump tables
+ might also be reasonable. On these machines the density of jump tables
may be lower.
*/
#define compact(nr, low, up) (nr != 0 && (up - low) / nr <= DENSITY)
{
/* Check the expression, stack a new case header and
fill in the necessary fields.
+ "exitlabel" is the exit-label of the closest enclosing
+ LOOP-statement, or 0.
*/
register struct switch_hdr *sh = new_switch_hdr();
register struct node *pnode = nd;
register struct case_entry *ce;
register arith val;
- label tablabel;
+ label CaseDescrLab;
assert(pnode->nd_class == Stat && pnode->nd_symb == CASE);
- clear((char *) sh, sizeof(*sh));
- WalkExpr(pnode->nd_left);
+ WalkExpr(pnode->nd_left); /* evaluate case expression */
sh->sh_type = pnode->nd_left->nd_type;
sh->sh_break = ++text_label;
/* Now, create case label list
*/
- while (pnode && pnode->nd_right) {
+ while (pnode->nd_right) {
pnode = pnode->nd_right;
if (pnode->nd_class == Link && pnode->nd_symb == '|') {
if (pnode->nd_left) {
+ /* non-empty case
+ */
pnode->nd_lab = ++text_label;
- if (! AddCases(sh,
+ if (! AddCases(sh, /* to descriptor */
pnode->nd_left->nd_left,
- pnode->nd_lab)) {
+ /* of case labels */
+ pnode->nd_lab
+ /* and code label */
+ )) {
FreeSh(sh);
return;
}
*/
sh->sh_default = ++text_label;
- pnode = 0;
+ break;
}
}
/* Now generate code for the switch itself
+ First the part that CSA and CSB descriptions have in common.
*/
- tablabel = ++data_label; /* the rom must have a label */
- C_df_dlb(tablabel);
+ CaseDescrLab = ++data_label; /* the rom must have a label */
+ C_df_dlb(CaseDescrLab);
if (sh->sh_default) C_rom_ilb(sh->sh_default);
else C_rom_ucon("0", pointer_size);
if (compact(sh->sh_nrofentries, sh->sh_lowerbd, sh->sh_upperbd)) {
- /* CSA */
-
+ /* CSA
+ */
C_rom_cst(sh->sh_lowerbd);
C_rom_cst(sh->sh_upperbd - sh->sh_lowerbd);
ce = sh->sh_entries;
else if (sh->sh_default) C_rom_ilb(sh->sh_default);
else C_rom_ucon("0", pointer_size);
}
- C_lae_dlb(tablabel, (arith)0); /* perform the switch */
+ C_lae_dlb(CaseDescrLab, (arith)0); /* perform the switch */
C_csa(word_size);
}
- else { /* CSB */
+ else {
+ /* CSB
+ */
C_rom_cst((arith)sh->sh_nrofentries);
for (ce = sh->sh_entries; ce; ce = ce->next) {
- /* generate the entries: value + prog.label */
+ /* generate the entries: value + prog.label
+ */
C_rom_cst(ce->ce_value);
C_rom_ilb(ce->ce_label);
}
- C_lae_dlb(tablabel, (arith)0); /* perform the switch */
+ C_lae_dlb(CaseDescrLab, (arith)0); /* perform the switch */
C_csb(word_size);
}
/* Now generate code for the cases
*/
pnode = nd;
- while (pnode && pnode->nd_right) {
+ while (pnode->nd_right) {
pnode = pnode->nd_right;
if (pnode->nd_class == Link && pnode->nd_symb == '|') {
if (pnode->nd_left) {
C_df_ilb(sh->sh_default);
WalkNode(pnode, exitlabel);
- pnode = 0;
+ break;
}
}
}
FreeSh(sh)
- struct switch_hdr *sh;
+ register struct switch_hdr *sh;
{
/* free the allocated switch structure
*/
AddCases(sh, node, lbl)
struct switch_hdr *sh;
- struct node *node;
+ register struct node *node;
label lbl;
{
/* Add case labels to the case label list
AddOneCase(sh, node, lbl)
register struct switch_hdr *sh;
- struct node *node;
+ register struct node *node;
label lbl;
{
register struct case_entry *ce = new_case_entry();
return 0;
}
if (sh->sh_entries == 0) {
- /* first case entry */
+ /* first case entry
+ */
ce->next = (struct case_entry *) 0;
sh->sh_entries = ce;
sh->sh_lowerbd = sh->sh_upperbd = ce->ce_value;
sh->sh_nrofentries = 1;
}
else {
- /* second etc. case entry */
- /* find the proper place to put ce into the list */
+ /* second etc. case entry
+ find the proper place to put ce into the list
+ */
if (ce->ce_value < sh->sh_lowerbd) {
sh->sh_lowerbd = ce->ce_value;
/* E X P R E S S I O N C H E C K I N G */
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
/* Check expressions, and try to evaluate them as far as possible.
*/
ChkVariable(expp)
register struct node *expp;
{
+ /* Check that "expp" indicates an item that can be
+ assigned to.
+ */
if (! ChkDesignator(expp)) return 0;
ChkArrow(expp)
register struct node *expp;
{
+ /* Check an application of the '^' operator.
+ The operand must be a variable of a pointer type.
+ */
register struct type *tp;
assert(expp->nd_class == Arrow);
tp = expp->nd_right->nd_type;
if (tp->tp_fund != T_POINTER) {
- node_error(expp, "illegal operand for unary operator \"%s\"",
- symbol2str(expp->nd_symb));
+ node_error(expp, "illegal operand for unary operator \"^\"");
return 0;
}
ChkArr(expp)
register struct node *expp;
{
+ /* Check an array selection.
+ The left hand side must be a variable of an array type,
+ and the right hand side must be an expression that is
+ assignment compatible with the array-index.
+ */
+
register struct type *tpl, *tpr;
assert(expp->nd_class == Arrsel);
tpr = expp->nd_right->nd_type;
if (tpl->tp_fund != T_ARRAY) {
- node_error(expp, "array index not belonging to an ARRAY");
+ node_error(expp, "not indexing an ARRAY type");
return 0;
}
return 1;
}
+#ifdef DEBUG
STATIC int
ChkValue(expp)
struct node *expp;
}
/*NOTREACHED*/
}
+#endif
STATIC int
ChkLinkOrName(expp)
register struct node *expp;
{
+ /* Check either an ID or a construction of the form
+ ID.ID [ .ID ]*
+ */
register struct def *df;
expp->nd_type = error_type;
expp->nd_type = RemoveEqual(expp->nd_def->df_type);
}
else if (expp->nd_class == Link) {
+ /* A selection from a record or a module.
+ Modules also have a record type.
+ */
register struct node *left = expp->nd_left;
assert(expp->nd_symb == '.');
if (df->df_kind == D_ERROR) return 0;
if (df->df_kind & (D_ENUM | D_CONST)) {
+ /* Replace an enum-literal or a CONST identifier by its value.
+ */
if (df->df_kind == D_ENUM) {
expp->nd_class = Value;
expp->nd_INT = df->enm_val;
expp->nd_symb = INTEGER;
}
else {
- unsigned int ln;
+ unsigned int ln = expp->nd_lineno;
assert(df->df_kind == D_CONST);
- ln = expp->nd_lineno;
*expp = *(df->con_const);
expp->nd_lineno = ln;
}
ChkExLinkOrName(expp)
register struct node *expp;
{
+ /* Check either an ID or an ID.ID [.ID]* occurring in an
+ expression.
+ */
register struct def *df;
if (! ChkLinkOrName(expp)) return 0;
if (expp->nd_class != Def) return 1;
df = expp->nd_def;
- if (!(df->df_kind & (D_ENUM|D_CONST|D_PROCEDURE|D_FIELD|D_VARIABLE|D_PROCHEAD))) {
+ if (!(df->df_kind & D_VALUE)) {
node_error(expp, "value expected");
}
if (df->df_kind == D_PROCEDURE) {
- /* Check that this procedure is one that we
- may take the address from.
+ /* Check that this procedure is one that we may take the
+ address from.
*/
if (df->df_type == std_type || df->df_scope->sc_level > 0) {
/* Address of standard or nested procedure
taken.
*/
-node_error(expp, "it is illegal to take the address of a standard or local procedure");
+node_error(expp, "standard or local procedures may not be assigned");
return 0;
}
}
return 1;
}
-STATIC int
-RemoveSet(set)
- arith **set;
-{
- /* This routine is only used for error exits of ChkElement.
- It frees the set indicated by "set", and returns 0.
- */
- if (*set) {
- free((char *) *set);
- *set = 0;
- }
- return 0;
-}
-
STATIC int
ChkElement(expp, tp, set)
register struct node *expp;
if (left->nd_INT > right->nd_INT) {
node_error(expp, "lower bound exceeds upper bound in range");
- return RemoveSet(set);
+ return 0;
}
if (*set) {
/* Here, a single element is checked
*/
- if (!ChkExpression(expp)) {
- return RemoveSet(set);
- }
+ if (!ChkExpression(expp)) return 0;
if (!TstCompat(tp, expp->nd_type)) {
node_error(expp, "set element has incompatible type");
- return RemoveSet(set);
+ return 0;
}
if (expp->nd_class == Value) {
/* a constant element
*/
+ arith low, high;
+
i = expp->nd_INT;
+ getbounds(tp, &low, &high);
- if ((tp->tp_fund != T_ENUMERATION &&
- (i < tp->sub_lb || i > tp->sub_ub))
- ||
- (tp->tp_fund == T_ENUMERATION &&
- (i < 0 || i > tp->enm_ncst))
- ) {
+ if (i < low || i > high) {
node_error(expp, "set element out of range");
- return RemoveSet(set);
+ return 0;
}
if (*set) (*set)[i/wrd_bits] |= (1 << (i%wrd_bits));
assert(nd->nd_class == Def);
df = nd->nd_def;
- if (!(df->df_kind & (D_TYPE|D_ERROR)) ||
+ if (!is_type(df) ||
(df->df_type->tp_fund != T_SET)) {
-node_error(expp, "specifier does not represent a set type");
+ if (df->df_kind != D_ERROR) {
+node_error(expp, "type specifier does not represent a set type");
+ }
return 0;
}
tp = df->df_type;
/* Yes, it was a constant set, and we managed to compute it!
Notice that at the moment there is no such thing as
partial evaluation. Either we evaluate the set, or we
- don't (at all). Improvement not neccesary. (???)
+ don't (at all). Improvement not neccesary (???)
+ ??? sets have a contant part and a variable part ???
*/
expp->nd_class = Set;
expp->nd_set = set;
that it must be a designator and may not be a register
variable.
*/
- struct type *tp;
register struct node *arg = (*argp)->nd_right;
register struct node *left;
}
if (bases) {
- tp = BaseType(left->nd_type);
- if (!(tp->tp_fund & bases)) {
+ if (!(BaseType(left->nd_type)->tp_fund & bases)) {
node_error(arg, "unexpected type");
return 0;
}
getname(argp, kinds)
struct node **argp;
{
+ /* Get the next argument from argument list "argp".
+ The argument must indicate a definition, and the
+ definition kind must be one of "kinds".
+ */
register struct node *arg = *argp;
+ register struct node *left;
if (!arg->nd_right) {
node_error(arg, "too few arguments supplied");
}
arg = arg->nd_right;
- if (! ChkDesignator(arg->nd_left)) return 0;
+ left = arg->nd_left;
+ if (! ChkDesignator(left)) return 0;
- if (arg->nd_left->nd_class != Def && arg->nd_left->nd_class != LinkDef) {
+ if (left->nd_class != Def && left->nd_class != LinkDef) {
node_error(arg, "identifier expected");
return 0;
}
- if (!(arg->nd_left->nd_def->df_kind & kinds)) {
+ if (!(left->nd_def->df_kind & kinds)) {
node_error(arg, "unexpected type");
return 0;
}
*argp = arg;
- return arg->nd_left;
+ return left;
}
STATIC int
ChkProcCall(expp)
- register struct node *expp;
+ struct node *expp;
{
/* Check a procedure call
*/
register struct paramlist *param;
left = expp->nd_left;
- arg = expp;
expp->nd_type = RemoveEqual(ResultType(left->nd_type));
+ /* Check parameter list
+ */
for (param = ParamList(left->nd_type); param; param = param->next) {
- if (!(left = getarg(&arg, 0, IsVarParam(param)))) return 0;
+ if (!(left = getarg(&expp, 0, IsVarParam(param)))) return 0;
if (left->nd_symb == STRING) {
TryToString(left, TypeOfParam(param));
}
}
}
- if (arg->nd_right) {
- node_error(arg->nd_right, "too many parameters supplied");
+ if (expp->nd_right) {
+ node_error(expp->nd_right, "too many parameters supplied");
return 0;
}
register struct node *expp;
{
/* Check something that looks like a procedure or function call.
- Of course this does not have to be a call at all.
+ Of course this does not have to be a call at all,
it may also be a cast or a standard procedure call.
*/
register struct node *left;
if (! ChkDesignator(left)) return 0;
if (IsCast(left)) {
- /* It was a type cast. This is of course not portable.
+ /* It was a type cast.
*/
return ChkCast(expp, left);
}
if (IsProcCall(left)) {
- /* A procedure call. it may also be a call to a
- standard procedure
+ /* A procedure call.
+ It may also be a call to a standard procedure
*/
if (left->nd_type == std_type) {
/* A standard procedure
ResultOfOperation(operator, tp)
struct type *tp;
{
+ /* Return the result type of the binary operation "operator",
+ with operand type "tp".
+ */
+
switch(operator) {
case '=':
case '#':
STATIC int
AllowedTypes(operator)
{
+ /* Return a bit mask indicating the allowed operand types
+ for binary operator "operator".
+ */
+
switch(operator) {
case '+':
case '-':
ChkAddress(tpl, tpr)
register struct type *tpl, *tpr;
{
+ /* Check that either "tpl" or "tpr" are both of type
+ address_type, or that one of them is, but the other is
+ of type cardinal.
+ */
if (tpl == address_type) {
- return tpr == address_type || tpr->tp_fund != T_POINTER;
+ return tpr == address_type || (tpr->tp_fund & T_CARDINAL);
}
if (tpr == address_type) {
- return tpl->tp_fund != T_POINTER;
+ return (tpl->tp_fund & T_CARDINAL);
}
return 0;
}
}
- expp->nd_type = ResultOfOperation(expp->nd_symb, tpl);
+ expp->nd_type = ResultOfOperation(expp->nd_symb, tpr);
+ /* Check that the application of the operator is allowed on the type
+ of the operands.
+ There are three 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.
+ - The IN-operator has as right-hand-size operand a set.
+ */
if (expp->nd_symb == IN) {
- /* Handle this one specially */
- if (tpr->tp_fund != T_SET) {
-node_error(expp, "RHS of IN operator not a SET type");
- return 0;
- }
if (!TstAssCompat(tpl, ElementType(tpr))) {
/* Assignment compatible ???
I don't know! Should we be allowed to check
if a CARDINAL is a member of a BITSET???
*/
-node_error(expp, "IN operator: type of LHS not compatible with element type of RHS");
+node_error(expp, "incompatible types for operator \"IN\"");
return 0;
}
if (left->nd_class == Value && right->nd_class == Set) {
return 1;
}
- /* Operands must be compatible (distilled from Def 8.2)
- */
- if (!TstCompat(tpl, tpr)) {
- node_error(expp, "incompatible types for operator \"%s\"",
- symbol2str(expp->nd_symb));
- return 0;
- }
-
allowed = AllowedTypes(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 (!(tpr->tp_fund & allowed) || !(tpl->tp_fund & allowed)) {
+ if (!((T_CARDINAL & allowed) &&
+ ChkAddress(tpl, tpr))) {
+node_error(expp,"operator \"%s\": illegal operand type(s)", symbol2str(expp->nd_symb));
+ return 0;
+ }
+ if (expp->nd_type->tp_fund & T_CARDINAL) {
+ expp->nd_type = address_type;
+ }
+ }
+
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;
- }
- if (expp->nd_type == card_type) expp->nd_type = address_type;
+
+ /* Operands must be compatible (distilled from Def 8.2)
+ */
+ if (!TstCompat(tpl, tpr)) {
+ node_error(expp, "incompatible types for operator \"%s\"",
+ symbol2str(expp->nd_symb));
+ return 0;
}
if (tpl->tp_fund == T_SET) {
if (! ChkExpression(right)) return 0;
- tpr = BaseType(right->nd_type);
+ expp->nd_type = tpr = BaseType(right->nd_type);
if (tpr == address_type) tpr = card_type;
- expp->nd_type = tpr;
switch(expp->nd_symb) {
case '+':
getvariable(argp)
struct node **argp;
{
+ /* Get the next argument from argument list "argp".
+ It must obey the rules of "ChkVariable".
+ */
register struct node *arg = *argp;
arg = arg->nd_right;
return 0;
}
- if (! ChkVariable(arg->nd_left)) return 0;
-
*argp = arg;
- return arg->nd_left;
+ arg = arg->nd_left;
+ if (! ChkVariable(arg)) return 0;
+
+ return arg;
}
STATIC int
extern int NodeCrash();
int (*ExprChkTable[])() = {
+#ifdef DEBUG
ChkValue,
+#else
+ done_before,
+#endif
ChkArr,
ChkBinOper,
ChkUnOper,
};
int (*DesigChkTable[])() = {
+#ifdef DEBUG
ChkValue,
+#else
+ done_before,
+#endif
ChkArr,
no_desig,
no_desig,
/* E X P R E S S I O N C H E C K I N G */
-/* $Header$ */
-
extern int (*ExprChkTable[])(); /* table of expression checking
functions, indexed by node class
*/
/* U S E O F C H A R A C T E R C L A S S E S */
-/* $Header$ */
-
/* As a starter, chars are divided into classes, according to which
token they can be the start of.
At present such a class number is supposed to fit in 4 bits.
/* C O D E G E N E R A T I O N R O U T I N E S */
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
/* Code generation for expressions and coercions
*/
{
/* Generate code to push constant "cst" with size "size"
*/
- label dlab;
if (size <= word_size) {
C_loc(cst);
C_ldc(cst);
}
else {
- C_df_dlb(dlab = ++data_label);
+ crash("(CodeConst)");
+/*
+ label dlab = ++data_label;
+
+ C_df_dlb(dlab);
C_rom_icon(long2str((long) cst), size);
C_lae_dlb(dlab, (arith) 0);
C_loi(size);
+*/
}
}
CodeString(nd)
register struct node *nd;
{
- label lab;
-
if (nd->nd_type->tp_fund != T_STRING) {
C_loc(nd->nd_INT);
}
else {
- C_df_dlb(lab = ++data_label);
+ label lab = ++data_label;
+
+ C_df_dlb(lab);
C_rom_scon(nd->nd_STR, WA(nd->nd_SLE + 1));
C_lae_dlb(lab, (arith) 0);
}
C_loi(sizearg);
}
-CodeReal(nd)
- register struct node *nd;
-{
- label lab = ++data_label;
-
- C_df_dlb(lab);
- C_rom_fcon(nd->nd_REL, nd->nd_type->tp_size);
- C_lae_dlb(lab, (arith) 0);
- C_loi(nd->nd_type->tp_size);
-}
CodeExpr(nd, ds, true_label, false_label)
register struct node *nd;
case Value:
switch(nd->nd_symb) {
- case REAL:
- CodeReal(nd);
+ case REAL: {
+ label lab = ++data_label;
+
+ C_df_dlb(lab);
+ C_rom_fcon(nd->nd_REL, nd->nd_type->tp_size);
+ C_lae_dlb(lab, (arith) 0);
+ C_loi(nd->nd_type->tp_size);
+ }
break;
case STRING:
CodeString(nd);
break;
case Set: {
- arith *st;
- int i;
+ register arith *st = nd->nd_set;
+ register int i;
st = nd->nd_set;
ds->dsg_kind = DSG_LOADED;
}
if (true_label != 0) {
+ /* Only for boolean expressions
+ */
CodeValue(ds, tp->tp_size);
*ds = InitDesig;
C_zne(true_label);
and result is already done.
*/
register struct node *left = nd->nd_left;
+ register struct node *right = nd->nd_right;
register struct type *result_tp;
if (left->nd_type == std_type) {
if (IsCast(left)) {
/* it was just a cast. Simply ignore it
*/
- CodePExpr(nd->nd_right->nd_left);
- *nd = *(nd->nd_right->nd_left);
+ CodePExpr(right->nd_left);
+ *nd = *(right->nd_left);
nd->nd_type = left->nd_def->df_type;
return;
}
assert(IsProcCall(left));
- if (nd->nd_right) {
- CodeParameters(ParamList(left->nd_type), nd->nd_right);
+ if (right) {
+ CodeParameters(ParamList(left->nd_type), right);
}
switch(left->nd_class) {
C_loc((left_type->tp_size+word_size-1) / word_size - 1);
}
else {
- tp = IndexType(left_type);
- if (tp->tp_fund == T_SUBRANGE) {
- C_loc(tp->sub_ub - tp->sub_lb);
- }
- else C_loc((arith) (tp->enm_ncst - 1));
+ arith lb, ub;
+ getbounds(IndexType(left_type), &lb, &ub);
+ C_loc(ub - lb);
}
C_loc((arith) 0);
if (left->nd_symb == STRING) {
register struct node *arg = nd->nd_right;
register struct node *left = 0;
register struct type *tp = 0;
- int std;
+ int std = nd->nd_left->nd_def->df_value.df_stdname;
if (arg) {
left = arg->nd_left;
arg = arg->nd_right;
}
- switch(std = nd->nd_left->nd_def->df_value.df_stdname) {
+ switch(std) {
case S_ABS:
CodePExpr(left);
if (tp->tp_fund == T_INTEGER) {
case S_CAP:
CodePExpr(left);
- C_loc((arith) 0137);
+ C_loc((arith) 0137); /* ASCII assumed */
C_and(word_size);
break;
break;
case S_DEC:
- case S_INC:
+ case S_INC: {
+ register arith size = tp->tp_size;
+
+ if (size < word_size) size = word_size;
CodePExpr(left);
if (arg) CodePExpr(arg->nd_left);
else C_loc((arith) 1);
- if (tp->tp_size <= word_size) {
- if (std == S_DEC) {
- if (tp->tp_fund == T_INTEGER) C_sbi(word_size);
- else C_sbu(word_size);
- }
- else {
- if (tp->tp_fund == T_INTEGER) C_adi(word_size);
- else C_adu(word_size);
- }
- RangeCheck(tp, int_type);
+ if (std == S_DEC) {
+ if (tp->tp_fund == T_INTEGER) C_sbi(size);
+ else C_sbu(size);
}
else {
- CodeCoercion(int_type, tp);
- if (std == S_DEC) {
- if (tp->tp_fund==T_INTEGER) C_sbi(tp->tp_size);
- else C_sbu(tp->tp_size);
- }
- else {
- if (tp->tp_fund==T_INTEGER) C_adi(tp->tp_size);
- else C_adu(tp->tp_size);
- }
+ if (tp->tp_fund == T_INTEGER) C_adi(size);
+ else C_adu(size);
}
+ if (size == word_size) RangeCheck(tp, int_type);
CodeDStore(left);
break;
+ }
case S_HALT:
C_cal("_halt");
}
CodeAssign(nd, dss, dst)
- struct node *nd;
+ register struct node *nd;
struct desig *dst, *dss;
{
/* Generate code for an assignment. Testing of type
compatibility and the like is already done.
*/
register struct type *tp = nd->nd_right->nd_type;
+ arith size = nd->nd_left->nd_type->tp_size;
if (dss->dsg_kind == DSG_LOADED) {
if (tp->tp_fund == T_STRING) {
CodeAddress(dst);
C_loc(tp->tp_size);
- C_loc(nd->nd_left->nd_type->tp_size);
+ C_loc(size);
C_cal("_StringAssign");
C_asp((int_size << 1) + (pointer_size << 1));
return;
}
- CodeStore(dst, nd->nd_left->nd_type->tp_size);
+ CodeStore(dst, size);
return;
}
CodeAddress(dss);
CodeAddress(dst);
- C_blm(nd->nd_left->nd_type->tp_size);
+ C_blm(size);
}
RangeCheck(tpl, tpr)
}
else {
/* both types are restricted. check the bounds
- to see wether we need a range check
+ to see wether we need a range check.
+ We don't need one if the range of values of the
+ right hand side is a subset of the range of values
+ of the left hand side.
*/
getbounds(tpl, &llo, &lhi);
getbounds(tpr, &rlo, &rhi);
C_bra(false_label);
}
break;
+ case OR:
case AND:
case '&': {
label l_true, l_false, l_maybe = ++text_label, l_end;
}
Des = InitDesig;
- CodeExpr(leftop, &Des, l_maybe, l_false);
+ if (expr->nd_symb == OR) {
+ CodeExpr(leftop, &Des, l_true, l_maybe);
+ }
+ else CodeExpr(leftop, &Des, l_maybe, l_false);
C_df_ilb(l_maybe);
Des = InitDesig;
CodeExpr(rightop, &Des, l_true, l_false);
}
break;
}
- case OR: {
- label l_true, l_false, l_maybe = ++text_label, l_end;
- struct desig Des;
-
- if (true_label == 0) {
- l_true = ++text_label;
- l_false = ++text_label;
- l_end = ++text_label;
- }
- else {
- l_true = true_label;
- l_false = false_label;
- }
- Des = InitDesig;
- CodeExpr(leftop, &Des, l_true, l_maybe);
- C_df_ilb(l_maybe);
- Des = InitDesig;
- CodeExpr(rightop, &Des, l_true, l_false);
- if (true_label == 0) {
- C_df_ilb(l_false);
- C_loc((arith)0);
- C_bra(l_end);
- C_df_ilb(l_true);
- C_loc((arith)1);
- C_df_ilb(l_end);
- }
- break;
- }
default:
crash("(CodeOper) Bad operator %s\n",symbol2str(expr->nd_symb));
}
CodeSet(nd)
register struct node *nd;
{
- struct type *tp = nd->nd_type;
+ register struct type *tp = nd->nd_type;
- C_zer(nd->nd_type->tp_size); /* empty set */
+ C_zer(tp->tp_size); /* empty set */
nd = nd->nd_right;
while (nd) {
assert(nd->nd_class == Link && nd->nd_symb == ',');
/* C O N S T A N T S F O R E X P R E S S I O N H A N D L I N G */
-/* $Header$ */
-
extern long
mach_long_sign; /* sign bit of the machine long */
extern int
/* C O N S T A N T E X P R E S S I O N H A N D L I N G */
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
#include "debug.h"
#include "target_sizes.h"
register arith o1 = expp->nd_right->nd_INT;
switch(expp->nd_symb) {
+ /* Should not get here
case '+':
break;
+ */
case '-':
o1 = -o1;
*/
register arith o1 = expp->nd_left->nd_INT;
register arith o2 = expp->nd_right->nd_INT;
- int uns = expp->nd_type != int_type;
+ register int uns = expp->nd_type != int_type;
assert(expp->nd_class == Oper);
assert(expp->nd_left->nd_class == Value);
/* D E C L A R A T I O N S */
{
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
#include "debug.h"
#include <em_arith.h>
#include "chk_expr.h"
int proclevel = 0; /* nesting level of procedures */
-int return_occurred; /* set if a return occurred in a
- procedure or function
- */
+int return_occurred; /* set if a return occurs in a block */
}
ProcedureDeclaration
{
- register struct def *df;
- struct def *df1; /* only exists because &df is illegal */
+ struct def *df;
} :
- { ++proclevel;
- return_occurred = 0;
- }
- ProcedureHeading(&df1, D_PROCEDURE)
- { CurrentScope->sc_definedby = df = df1;
- df->prc_vis = CurrVis;
- }
- ';' block(&(df->prc_body)) IDENT
- { match_id(dot.TOK_IDF, df->df_idf);
- close_scope(SC_CHKFORW|SC_REVERSE);
- if (! return_occurred && ResultType(df->df_type)) {
-error("function procedure %s does not return a value", df->df_idf->id_text);
- }
+ { ++proclevel; }
+ ProcedureHeading(&df, D_PROCEDURE)
+ ';' block(&(df->prc_body))
+ IDENT
+ { EndProc(df, dot.TOK_IDF);
--proclevel;
}
;
ProcedureHeading(struct def **pdf; int type;)
{
- struct paramlist *params = 0;
- register struct type *tp;
- struct type *tp1 = 0;
- register struct def *df;
- arith NBytesParams; /* parameter offset counter */
+ struct type *tp = 0;
+#define needs_static_link() (proclevel > 1)
+ arith parmaddr = needs_static_link() ? pointer_size : 0;
+ struct paramlist *pr = 0;
} :
PROCEDURE IDENT
- { df = DeclProc(type);
- if (proclevel > 1) { /* need room for static link */
- NBytesParams = pointer_size;
- }
- else NBytesParams = 0;
- }
- FormalParameters(¶ms, &tp1, &NBytesParams)?
- { tp = construct_type(T_PROCEDURE, tp1);
- tp->prc_params = params;
- tp->prc_nbpar = NBytesParams;
- if (df->df_type) {
- /* We already saw a definition of this type
- in the definition module.
- */
- if (!TstProcEquiv(tp, df->df_type)) {
-error("inconsistent procedure declaration for \"%s\"", df->df_idf->id_text);
- }
- FreeType(df->df_type);
- }
- df->df_type = tp;
- *pdf = df;
- }
+ { *pdf = DeclProc(type, dot.TOK_IDF); }
+ FormalParameters(&pr, &parmaddr, &tp)?
+ { CheckWithDef(*pdf, proc_type(tp, pr, parmaddr)); }
;
block(struct node **pnd;) :
declaration*
- [
+ [ { return_occurred = 0; }
BEGIN
StatementSequence(pnd)
|
ModuleDeclaration ';'
;
-FormalParameters(struct paramlist **pr;
- struct type **ptp;
- arith *parmaddr;)
-:
+FormalParameters(struct paramlist *ppr; arith *parmaddr; struct type **ptp;):
'('
[
- FPSection(pr, parmaddr)
+ FPSection(ppr, parmaddr)
[
- ';' FPSection(pr, parmaddr)
+ ';' FPSection(ppr, parmaddr)
]*
]?
')'
FormalType(struct type **ptp;)
{
- register struct type *tp;
extern arith ArrayElSize();
} :
ARRAY OF qualtype(ptp)
- { tp = construct_type(T_ARRAY, NULLTYPE);
- tp->arr_elem = *ptp; *ptp = tp;
+ { register struct type *tp = construct_type(T_ARRAY, NULLTYPE);
+ tp->arr_elem = *ptp;
+ *ptp = tp;
tp->arr_elsize = ArrayElSize(tp->arr_elem);
tp->tp_align = lcm(word_align, pointer_align);
}
enumeration(struct type **ptp;)
{
struct node *EnumList;
- register struct type *tp;
} :
'(' IdentList(&EnumList) ')'
- { *ptp = tp = standard_type(T_ENUMERATION, 1, (arith) 1);
- EnterEnumList(EnumList, tp);
- if (tp->enm_ncst > 256) { /* ??? is this reasonable ??? */
+ {
+ *ptp = standard_type(T_ENUMERATION, 1, (arith) 1);
+ EnterEnumList(EnumList, *ptp);
+ if ((*ptp)->enm_ncst > 256) { /* ??? is this reasonable ??? */
error("Too many enumeration literals");
}
}
'[' ConstExpression(&nd1)
UPTO ConstExpression(&nd2)
']'
- { *ptp = subr_type(nd1, nd2); }
+ { *ptp = subr_type(nd1, nd2);
+ free_node(nd1);
+ free_node(nd2);
+ }
;
ArrayType(struct type **ptp;)
RecordType(struct type **ptp;)
{
register struct scope *scope;
- arith count;
+ arith size;
int xalign = struct_align;
}
:
RECORD
- { open_scope(OPENSCOPE);
+ { open_scope(OPENSCOPE); /* scope for fields of record */
scope = CurrentScope;
close_scope(0);
- count = 0;
+ size = 0;
}
- FieldListSequence(scope, &count, &xalign)
- { *ptp = standard_type(T_RECORD, xalign, WA(count));
+ FieldListSequence(scope, &size, &xalign)
+ { *ptp = standard_type(T_RECORD, xalign, WA(size));
(*ptp)->rec_scope = scope;
}
END
FieldList(struct scope *scope; arith *cnt; int *palign;)
{
struct node *FldList;
- register struct idf *id = gen_anon_idf();
- register struct def *df;
+ register struct idf *id = 0;
struct type *tp;
- struct node *nd;
+ struct node *nd1;
+ register struct node *nd;
arith tcnt, max;
} :
[
}
|
CASE
- /* Also accept old fashioned Modula-2 syntax, but give a warning
+ /* Also accept old fashioned Modula-2 syntax, but give a warning.
+ Sorry for the complicated code.
*/
- [ qualident(0, (struct def **) 0, (char *) 0, &nd)
- [ ':' qualtype(&tp)
+ [ qualident(0, (struct def **) 0, (char *) 0, &nd1)
+ { nd = nd1; }
+ [ ':' qualtype(&tp)
/* This is correct, in both kinds of Modula-2, if
- the first qualident is a single identifier.
+ the first qualident is a single identifier.
*/
- { if (nd->nd_class != Name) {
- error("illegal variant tag");
- }
- else id = nd->nd_IDF;
- }
- |
- /* Old fashioned! the first qualident now represents
+ { if (nd->nd_class != Name) {
+ error("illegal variant tag");
+ }
+ else id = nd->nd_IDF;
+ FreeNode(nd);
+ }
+ | /* Old fashioned! the first qualident now represents
the type
*/
- { warning("Old fashioned Modula-2 syntax!");
- if (ChkDesignator(nd) &&
- (nd->nd_class != Def ||
- !(nd->nd_def->df_kind&(D_ERROR|D_ISTYPE)) ||
- !nd->nd_def->df_type)) {
- node_error(nd, "type expected");
- tp = error_type;
- }
- else tp = nd->nd_def->df_type;
- FreeNode(nd);
- }
- ]
- |
- /* Aha, third edition. Well done! */
- ':' qualtype(&tp)
+ { warning("Old fashioned Modula-2 syntax; ':' missing");
+ if (ChkDesignator(nd) &&
+ (nd->nd_class != Def ||
+ !(nd->nd_def->df_kind&(D_ERROR|D_ISTYPE)) ||
+ !nd->nd_def->df_type)) {
+ node_error(nd, "type expected");
+ tp = error_type;
+ }
+ else tp = nd->nd_def->df_type;
+ FreeNode(nd);
+ }
+ ]
+ | ':' qualtype(&tp)
+ /* Aha, third edition. Well done! */
]
- { if (!(tp->tp_fund & T_DISCRETE)) {
+ { if (id) {
+ register struct def *df = define(id,
+ scope,
+ D_FIELD);
+ if (!(tp->tp_fund & T_DISCRETE)) {
error("Illegal type in variant");
- }
- df = define(id, scope, D_FIELD);
- df->df_type = tp;
- df->fld_off = align(*cnt, tp->tp_align);
- *cnt = tcnt = df->fld_off + tp->tp_size;
- df->df_flags |= D_QEXPORTED;
- }
+ }
+ df->df_type = tp;
+ df->fld_off = align(*cnt, tp->tp_align);
+ *cnt = tcnt = df->fld_off + tp->tp_size;
+ df->df_flags |= D_QEXPORTED;
+ }
+ }
OF variant(scope, &tcnt, tp, palign)
- { max = tcnt; tcnt = *cnt; }
+ { max = tcnt; tcnt = *cnt; }
[
- '|' variant(scope, &tcnt, tp, palign)
- { if (tcnt > max) max = tcnt; tcnt = *cnt; }
+ '|' variant(scope, &tcnt, tp, palign)
+ { if (tcnt > max) max = tcnt; tcnt = *cnt; }
]*
[ ELSE FieldListSequence(scope, &tcnt, palign)
- { if (tcnt > max) max = tcnt; }
+ { if (tcnt > max) max = tcnt; }
]?
END
- { *cnt = max; }
+ { *cnt = max; }
]?
;
variant(struct scope *scope; arith *cnt; struct type *tp; int *palign;)
{
- struct type *tp1 = tp;
struct node *nd;
} :
[
- CaseLabelList(&tp1, &nd)
- { /* Ignore the cases for the time being.
- Maybe a checking version will be supplied
- later ???
- */
- FreeNode(nd);
- }
+ CaseLabelList(&tp, &nd)
+ { /* Ignore the cases for the time being.
+ Maybe a checking version will be supplied
+ later ??? (Improbable)
+ */
+ FreeNode(nd);
+ }
':' FieldListSequence(scope, cnt, palign)
]?
- /* Changed rule in new modula-2 */
+ /* Changed rule in new modula-2 */
;
CaseLabelList(struct type **ptp; struct node **pnd;):
]*
;
-CaseLabels(struct type **ptp; struct node **pnd;)
+CaseLabels(struct type **ptp; register struct node **pnd;)
{
- struct node *nd1, *nd2 = 0;
+ register struct node *nd1;
}:
- ConstExpression(&nd1) { *pnd = nd1; }
+ ConstExpression(pnd)
+ { nd1 = *pnd; }
[
- UPTO { *pnd = MkNode(Link,nd1,NULLNODE,&dot); }
- ConstExpression(&nd2)
- { if (!TstCompat(nd1->nd_type, nd2->nd_type)) {
-node_error(nd2,"type incompatibility in case label");
- nd1->nd_type = error_type;
- }
- (*pnd)->nd_right = nd2;
- }
+ UPTO { *pnd = MkNode(Link,nd1,NULLNODE,&dot); }
+ ConstExpression(&(*pnd)->nd_right)
+ { if (!TstCompat(nd1->nd_type,
+ (*pnd)->nd_right->nd_type)) {
+ node_error((*pnd)->nd_right,
+ "type incompatibility in case label");
+ nd1->nd_type = error_type;
+ }
+ }
]?
- { if (*ptp != 0 &&
- !TstCompat(*ptp, nd1->nd_type)) {
-node_error(nd1,"type incompatibility in case label");
- }
- *ptp = nd1->nd_type;
- }
+ { if (*ptp != 0 && !TstCompat(*ptp, nd1->nd_type)) {
+ node_error(nd1,
+ "type incompatibility in case label");
+ }
+ *ptp = nd1->nd_type;
+ }
;
SetType(struct type **ptp;) :
*/
PointerType(struct type **ptp;)
{
- register struct node *nd;
+ register struct node *nd = 0;
} :
POINTER TO
{ *ptp = construct_type(T_POINTER, NULLTYPE); }
/* Either a Module or a Type, but in both cases defined
in this scope, so this is the correct identification
*/
- qualtype(&((*ptp)->next))
- | %if ( nd = new_node(), nd->nd_token = dot,
+ qualtype(&((*ptp)->next))
+ | %if ( nd = new_node(),
+ nd->nd_token = dot,
lookfor(nd, CurrVis, 0)->df_kind == D_MODULE)
- { if (dot.tk_symb == IDENT) free_node(nd); }
- type(&((*ptp)->next))
+ type(&((*ptp)->next))
+ { if (nd) free_node(nd); }
|
- IDENT { Forward(nd, (*ptp)); }
+ IDENT { Forward(nd, (*ptp)); }
]
;
qualtype(struct type **ptp;)
{
- struct def *df;
+ struct def *df = 0;
} :
qualident(D_ISTYPE, &df, "type", (struct node **) 0)
- { if (!(*ptp = df->df_type)) {
- error("type \"%s\" not declared", df->df_idf->id_text);
- *ptp = error_type;
- }
- }
+ { if (df && !(*ptp = df->df_type)) {
+ error("type \"%s\" not declared",
+ df->df_idf->id_text);
+ *ptp = error_type;
+ }
+ }
;
ProcedureType(struct type **ptp;)
{
struct paramlist *pr = 0;
- register struct type *tp;
- arith nbytes = 0;
-} :
+ arith parmaddr = 0;
+}
+:
{ *ptp = 0; }
- PROCEDURE FormalTypeList(&pr, ptp, &nbytes)?
- { *ptp = tp = construct_type(T_PROCEDURE, *ptp);
- tp->prc_params = pr;
- tp->prc_nbpar = nbytes;
- }
+ PROCEDURE
+ [
+ FormalTypeList(&pr, &parmaddr, ptp)
+ ]?
+ { *ptp = proc_type(*ptp, pr, parmaddr); }
;
-FormalTypeList(struct paramlist **ppr; struct type **ptp; arith *parmaddr;)
+FormalTypeList(struct paramlist **ppr; arith *parmaddr; struct type **ptp;)
{
- int VARp;
struct type *tp;
+ int VARp;
} :
- '(' { *ppr = 0; }
+ '('
[
var(&VARp) FormalType(&tp)
{ EnterParamList(ppr,NULLNODE,tp,VARp,parmaddr); }
/* I D E N T I F I E R D E S C R I P T O R S T R U C T U R E */
-/* $Header$ */
-
struct module {
arith mo_priority; /* priority of a module */
struct scopelist *mo_vis;/* scope of this module */
#define D_IMPORT 0x0080 /* an imported definition */
#define D_PROCHEAD 0x0100 /* a procedure heading in a definition module */
#define D_HIDDEN 0x0200 /* a hidden type */
-#define D_FORWARD 0x0800 /* not yet defined */
-#define D_UNDEF_IMPORT 0x1000 /* imported from an undefined name */
-#define D_FORWMODULE 0x2000 /* module must be declared later */
-#define D_ERROR 0x4000 /* a compiler generated definition for an
+#define D_FORWARD 0x0400 /* not yet defined */
+#define D_FORWMODULE 0x0800 /* module must be declared later */
+#define D_ERROR 0x1000 /* a compiler generated definition for an
undefined variable
*/
+#define D_VALUE (D_PROCEDURE|D_VARIABLE|D_FIELD|D_ENUM|D_CONST|D_PROCHEAD)
#define D_ISTYPE (D_HIDDEN|D_TYPE)
#define is_type(dfx) ((dfx)->df_kind & D_ISTYPE)
char df_flags;
#define SetUsed(df) ((df)->df_flags |= D_USED)
-/* ALLOCDEF "def" */
+/* ALLOCDEF "def" 50 */
extern struct def
*define(),
*DefineLocalModule(),
*MkDef(),
- *DeclProc(),
- *ill_df;
+ *DeclProc();
extern struct def
*lookup(),
/* D E F I N I T I O N M E C H A N I S M */
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
#include "debug.h"
#include <alloc.h>
int cnt_def; /* count number of allocated ones */
#endif
-struct def *ill_df;
+STATIC
+DefInFront(df)
+ register struct def *df;
+{
+ /* Put definition "df" in front of the list of definitions
+ in its scope.
+ This is neccessary because in some cases the order in this
+ list is important.
+ */
+ register struct def *df1 = df->df_scope->sc_def;
+
+ if (df1 != df) {
+ /* Definition "df" is not in front of the list
+ */
+ while (df1) {
+ /* Find definition "df"
+ */
+ if (df1->df_nextinscope == df) {
+ /* It already was in the list. Remove it
+ */
+ df1->df_nextinscope = df->df_nextinscope;
+ break;
+ }
+ df1 = df1->df_nextinscope;
+ }
+
+ /* Now put it in front
+ */
+ df->df_nextinscope = df->df_scope->sc_def;
+ df->df_scope->sc_def = df;
+ }
+}
struct def *
MkDef(id, scope, kind)
- struct idf *id;
+ register struct idf *id;
register struct scope *scope;
{
/* Create a new definition structure in scope "scope", with
register struct def *df;
df = new_def();
- clear((char *) df, sizeof (*df));
df->df_idf = id;
df->df_scope = scope;
df->df_kind = kind;
return df;
}
-InitDef()
-{
- /* Initialize this module. Easy, the only thing to be initialized
- is "ill_df".
- */
- struct idf *gen_anon_idf();
-
- ill_df = MkDef(gen_anon_idf(), CurrentScope, D_ERROR);
- ill_df->df_type = error_type;
-}
-
struct def *
define(id, scope, kind)
register struct idf *id;
register struct scope *scope;
+ int kind;
{
/* Declare an identifier in a scope, but first check if it
- already has been defined. If so, error message.
+ already has been defined.
+ If so, then check for the cases in which this is legal,
+ and otherwise give an error message.
*/
register struct def *df;
if (kind != D_ERROR) {
/* Avoid spurious error messages
*/
-error("identifier \"%s\" already declared", id->id_text);
+ error("identifier \"%s\" already declared",
+ id->id_text);
}
return df;
}
RemoveImports(pdf)
- struct def **pdf;
+ register struct def **pdf;
{
/* Remove all imports from a definition module. This is
neccesary because the implementation module might import
}
RemoveFromIdList(df)
- struct def *df;
+ register struct def *df;
{
/* Remove definition "df" from the definition list
*/
register struct idf *id = df->df_idf;
register struct def *df1;
- if (id->id_def == df) id->id_def = df->next;
+ if ((df1 = id->id_def) == df) id->id_def = df->next;
else {
- df1 = id->id_def;
while (df1->next != df) {
assert(df1->next != 0);
df1 = df1->next;
}
struct def *
-DeclProc(type)
+DeclProc(type, id)
+ register struct idf *id;
{
/* A procedure is declared, either in a definition or a program
module. Create a def structure for it (if neccessary).
Also create a name for it.
*/
register struct def *df;
+ register struct scope *scope;
extern char *sprint();
static int nmcount;
char buf[256];
if (type == D_PROCHEAD) {
/* In a definition module
*/
- df = define(dot.TOK_IDF, CurrentScope, type);
+ df = define(id, CurrentScope, type);
df->for_node = MkLeaf(Name, &dot);
- sprint(buf,"%s_%s",CurrentScope->sc_name,df->df_idf->id_text);
+ sprint(buf,"%s_%s",CurrentScope->sc_name,id->id_text);
df->for_name = Salloc(buf, (unsigned) (strlen(buf)+1));
- if (CurrVis == Defined->mod_vis) C_exp(df->for_name);
+ if (CurrVis == Defined->mod_vis) {
+ /* The current module will define this routine.
+ make sure the name is exported.
+ */
+ C_exp(df->for_name);
+ }
}
else {
- df = lookup(dot.TOK_IDF, CurrentScope);
+ char *name;
+
+ df = lookup(id, CurrentScope);
if (df && df->df_kind == D_PROCHEAD) {
/* C_exp already generated when we saw the definition
in the definition module
*/
df->df_kind = D_PROCEDURE;
- open_scope(OPENSCOPE);
- CurrentScope->sc_name = df->for_name;
- df->prc_vis = CurrVis;
+ name = df->for_name;
DefInFront(df);
}
else {
- df = define(dot.TOK_IDF, CurrentScope, type);
- open_scope(OPENSCOPE);
- df->prc_vis = CurrVis;
- sprint(buf,"_%d_%s",++nmcount,df->df_idf->id_text);
- CurrentScope->sc_name =
- Salloc(buf, (unsigned)(strlen(buf)+1));
+ df = define(id, CurrentScope, type);
+ sprint(buf,"_%d_%s",++nmcount,id->id_text);
+ name = Salloc(buf, (unsigned)(strlen(buf)+1));
C_inp(buf);
}
+ open_scope(OPENSCOPE);
+ scope = CurrentScope;
+ scope->sc_name = name;
+ scope->sc_definedby = df;
+ df->prc_vis = CurrVis;
}
return df;
}
-AddModule(id)
+EndProc(df, id)
+ register struct def *df;
struct idf *id;
{
- /* Add the name of a module to the Module list. This list is
- maintained to create the initialization routine of the
- program/implementation module currently defined.
+ /* The end of a procedure declaration.
+ Check that the closing identifier matches the name of the
+ procedure, close the scope, and check that a function
+ procedure has at least one RETURN statement.
*/
- static struct node *nd_end; /* to remember end of list */
- register struct node *n;
- extern struct node *Modules;
-
- n = MkLeaf(Name, &dot);
- n->nd_IDF = id;
- n->nd_symb = IDENT;
- if (nd_end) nd_end->next = n;
- else Modules = n;
- nd_end = n;
-}
+ extern int return_occurred;
-DefInFront(df)
- register struct def *df;
-{
- /* Put definition "df" in front of the list of definitions
- in its scope.
- This is neccessary because in some cases the order in this
- list is important.
- */
- register struct def *df1 = df->df_scope->sc_def;
-
- if (df1 != df) {
- /* Definition "df" is not in front of the list
- */
- while (df1 && df1->df_nextinscope != df) {
- /* Find definition "df"
- */
- df1 = df1->df_nextinscope;
- }
- if (df1) {
- /* It already was in the list. Remove it
- */
- df1->df_nextinscope = df->df_nextinscope;
- }
-
- /* Now put it in front
- */
- df->df_nextinscope = df->df_scope->sc_def;
- df->df_scope->sc_def = df;
+ match_id(id, df->df_idf);
+ close_scope(SC_CHKFORW|SC_REVERSE);
+ if (! return_occurred && ResultType(df->df_type)) {
+ error("function procedure %s does not return a value",
+ df->df_idf->id_text);
}
}
return df;
}
+CheckWithDef(df, tp)
+ register struct def *df;
+ struct type *tp;
+{
+ /* Check the header of a procedure declaration against a
+ possible earlier definition in the definition module.
+ */
+
+ if (df->df_type) {
+ /* We already saw a definition of this type
+ in the definition module.
+ */
+ if (!TstProcEquiv(tp, df->df_type)) {
+ error("inconsistent procedure declaration for \"%s\"",
+ df->df_idf->id_text);
+ }
+ FreeType(df->df_type);
+ }
+ df->df_type = tp;
+}
+
#ifdef DEBUG
PrDef(df)
register struct def *df;
/* D E F I N I T I O N M O D U L E S */
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
#include "debug.h"
#include <assert.h>
#include "scope.h"
#include "def.h"
#include "LLlex.h"
+#include "Lpars.h"
#include "f_info.h"
#include "main.h"
+#include "node.h"
#ifdef DEBUG
long sys_filesize();
#endif
+struct idf * CurrentId;
+
GetFile(name)
char *name;
{
/* Try to find a file with basename "name" and extension ".def",
in the directories mentioned in "DEFPATH".
*/
- char buf[256];
+ char buf[15];
char *strcpy(), *strcat();
- strcpy(buf, name);
+ strncpy(buf, name, 10);
buf[10] = '\0'; /* maximum length */
strcat(buf, ".def");
if (! InsertFile(buf, DEFPATH, &(FileName))) {
}
struct def *
-GetDefinitionModule(id)
- struct idf *id;
+GetDefinitionModule(id, incr)
+ register struct idf *id;
{
/* Return a pointer to the "def" structure of the definition
module indicated by "id".
We may have to read the definition module itself.
+ Also increment level by "incr".
*/
struct def *df;
static int level;
- level++;
+ level += incr;
df = lookup(id, GlobalScope);
if (!df) {
/* Read definition module. Make an exception for SYSTEM.
}
else {
GetFile(id->id_text);
+ CurrentId = id;
+ open_scope(CLOSEDSCOPE);
DefModule();
if (level == 1) {
/* The module is directly imported by the
remember its name because we have to call
its initialization routine
*/
- AddModule(id);
+ static struct node *nd_end; /* end of list */
+ register struct node *n;
+ extern struct node *Modules;
+
+ n = MkLeaf(Name, &dot);
+ n->nd_IDF = id;
+ n->nd_symb = IDENT;
+ if (nd_end) nd_end->next = n;
+ else Modules = n;
+ nd_end = n;
}
+ close_scope(SC_CHKFORW);
}
df = lookup(id, GlobalScope);
}
+ CurrentId = 0;
assert(df && df->df_kind == D_MODULE);
- level--;
+ level -= incr;
return df;
}
/* D E S I G N A T O R E V A L U A T I O N */
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
/* Code generation for designators.
This file contains some routines that generate code common to address
as well as value computations, and leave a description in a "desig"
in "ds". "df" indicates the definition of the field.
*/
-
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
/* D E S I G N A T O R D E S C R I P T I O N S */
-/* $Header$ */
-
/* Generating code for designators is not particularly easy, especially if
you don't know wether you want the address or the value.
The next structure is used to generate code for designators.
/* H I G H L E V E L S Y M B O L E N T R Y */
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
#include "debug.h"
#include <alloc.h>
df->var_addrgiven = 1;
df->df_flags |= D_NOREG;
if (idlist->nd_left->nd_type != card_type) {
-node_error(idlist->nd_left,"Illegal type for address");
+ node_error(idlist->nd_left,
+ "Illegal type for address");
}
df->var_off = idlist->nd_left->nd_INT;
}
}
EnterParamList(ppr, Idlist, type, VARp, off)
- struct node *Idlist;
struct paramlist **ppr;
+ struct node *Idlist;
struct type *type;
int VARp;
arith *off;
for ( ; idlist; idlist = idlist->next) {
pr = new_paramlist();
pr->next = 0;
- if (!*ppr) {
- *ppr = pr;
- }
+ if (!*ppr) *ppr = pr;
else last->next = pr;
last = pr;
if (!DefinitionModule && idlist != dummy) {
df = define(idlist->nd_IDF, CurrentScope, D_VARIABLE);
df->var_off = *off;
}
- else {
- df = new_def();
- }
+ else df = new_def();
pr->par_def = df;
df->df_type = type;
df->df_flags = VARp;
enclosing scope, but this must be done AFTER
closing this one
*/
- df->for_vis = vis;
- df->for_node = MkLeaf(Name, &(idn->nd_token));
close_scope(0);
vis->sc_encl = enclosing(CurrVis);
/* Here ! */
+ df->for_vis = vis;
+ df->for_node = MkLeaf(Name, &(idn->nd_token));
return vis;
}
*/
register struct node *idlist = Idlist;
register struct def *df, *df1;
- register struct def *impmod;
for (;idlist; idlist = idlist->next) {
df = lookup(idlist->nd_IDF, CurrentScope);
if (!df) {
/* undefined item in export list
*/
-node_error(idlist, "identifier \"%s\" not defined", idlist->nd_IDF->id_text);
+ node_error(idlist,
+ "identifier \"%s\" not defined",
+ idlist->nd_IDF->id_text);
continue;
}
if (df->df_flags & (D_EXPORTED|D_QEXPORTED)) {
-node_error(idlist, "identifier \"%s\" occurs more than once in export list",
-idlist->nd_IDF->id_text);
+ node_error(idlist,
+ "multiple occurrences of \"%s\" in export list",
+ idlist->nd_IDF->id_text);
}
df->df_flags |= qualified;
Find all imports of the module in which this export
occurs, and export the current definition to it
*/
- impmod = CurrentScope->sc_definedby->df_idf->id_def;
- while (impmod) {
- if (impmod->df_kind == D_IMPORT &&
- impmod->imp_def == CurrentScope->sc_definedby) {
- DoImport(df, impmod->df_scope);
+ df1 = CurrentScope->sc_definedby->df_idf->id_def;
+ while (df1) {
+ if (df1->df_kind == D_IMPORT &&
+ df1->imp_def == CurrentScope->sc_definedby) {
+ DoImport(df, df1->df_scope);
}
- impmod = impmod->next;
+ df1 = df1->next;
}
/* Also handle the definition as if the enclosing
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);
+ 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;
vis = FromDef->mod_vis;
break;
default:
-error("identifier \"%s\" does not represent a module",
-FromDef->df_idf->id_text);
+ error("identifier \"%s\" does not represent a module",
+ FromDef->df_idf->id_text);
break;
}
for (; idlist; idlist = idlist->next) {
- if (forwflag) {
- df = ForwDef(idlist, vis->sc_scope);
- }
- else if (!(df = lookup(idlist->nd_IDF, vis->sc_scope))) {
-node_error(idlist, "identifier \"%s\" not declared in qualifying module",
-idlist->nd_IDF->id_text);
+ if (forwflag) df = ForwDef(idlist, vis->sc_scope);
+ else if (! (df = lookup(idlist->nd_IDF, vis->sc_scope))) {
+ node_error(idlist,
+ "identifier \"%s\" not declared in qualifying module",
+ idlist->nd_IDF->id_text);
df = define(idlist->nd_IDF,vis->sc_scope,D_ERROR);
}
- else if (!(df->df_flags&(D_EXPORTED|D_QEXPORTED))) {
-node_error(idlist,"identifier \"%s\" not exported from qualifying module",
-idlist->nd_IDF->id_text);
+ else if (! (df->df_flags & (D_EXPORTED|D_QEXPORTED))) {
+ node_error(idlist,
+ "identifier \"%s\" not exported from qualifying module",
+ idlist->nd_IDF->id_text);
df->df_flags |= D_QEXPORTED;
}
DoImport(df, CurrentScope);
This case is indicated by the value 0 of the "local" flag.
*/
register struct node *idlist = Idlist;
- register struct def *df;
- struct scopelist *vis = enclosing(CurrVis);
+ struct scope *sc = enclosing(CurrVis)->sc_scope;
extern struct def *GetDefinitionModule();
for (; idlist; idlist = idlist->next) {
- if (local) df = ForwDef(idlist, vis->sc_scope);
- else df = GetDefinitionModule(idlist->nd_IDF);
- DoImport(df, CurrentScope);
+ DoImport(local ?
+ ForwDef(idlist, sc) :
+ GetDefinitionModule(idlist->nd_IDF) ,
+ CurrentScope);
}
FreeNode(Idlist);
}
number of arguments!
*/
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
#include "errout.h"
#include "debug.h"
/* E X P R E S S I O N S */
{
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
#include "debug.h"
#include <alloc.h>
struct node **p;
)
{
- register struct def *df;
struct node *nd;
} :
IDENT { nd = MkLeaf(Name, &dot); }
[
selector(&nd)
]*
- { if (types) {
- df = ill_df;
-
- if (ChkDesignator(nd)) {
- if (nd->nd_class != Def) {
+ { if (types && ChkDesignator(nd)) {
+ if (nd->nd_class != Def) {
node_error(nd, "%s expected", str);
- }
- else {
- df = nd->nd_def;
+ }
+ else {
+ register struct def *df = nd->nd_def;
+
if ( !((types|D_ERROR) & df->df_kind)) {
if (df->df_kind == D_FORWARD) {
node_error(nd,"%s \"%s\" not declared", str, df->df_idf->id_text);
node_error(nd,"identifier \"%s\" is not a %s", df->df_idf->id_text, str);
}
}
- }
+ if (pdf) *pdf = df;
}
- *pdf = df;
}
if (!p) FreeNode(nd);
else *p = nd;
factor(register struct node **p;)
{
- struct def *df;
struct node *nd;
} :
- qualident(0, &df, (char *) 0, p)
+ qualident(0, (struct def **) 0, (char *) 0, p)
[
designator_tail(p)?
[
;
designator(struct node **pnd;)
-{
- struct def *df;
-} :
- qualident(0, &df, (char *) 0, pnd)
+:
+ qualident(0, (struct def **) 0, (char *) 0, pnd)
designator_tail(pnd)?
;
/* F I L E D E S C R I P T O R S T R U C T U R E */
-/* $Header$ */
-
struct f_info {
unsigned short f_lineno;
char *f_filename;
/* I N S T A N T I A T I O N O F I D F P A C K A G E */
-/* $Header$ */
-
#include "idf.h"
#include <idf_pkg.body>
/* U S E R D E C L A R E D P A R T O F I D F */
-/* $Header$ */
-
struct id_u {
int id_res;
struct def *id_df;
/* I N S T A N T I A T I O N O F I N P U T P A C K A G E */
-/* $Header$ */
-
#include "f_info.h"
struct f_info file_info;
#include "input.h"
+#include <em_arith.h>
+#include <em_label.h>
+#include "def.h"
+#include "idf.h"
+#include "scope.h"
#include <inp_pkg.body>
+extern struct idf *CurrentId;
+
AtEoIF()
{
/* Make the unstacking of input streams noticable to the
lexical analyzer
*/
+ if (CurrentId && ! lookup(CurrentId, GlobalScope)) {
+fatal("No definition module read for \"%s\"", CurrentId->id_text);
+ }
return 1;
}
/* I N S T A N T I A T I O N O F I N P U T M O D U L E */
-/* $Header$ */
-
#include "inputtype.h"
#define INP_NPUSHBACK 2
/* L O O K U P R O U T I N E S */
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
#include "debug.h"
#include <em_arith.h>
/* M A I N P R O G R A M */
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
#include "debug.h"
#include "ndir.h"
int state; /* either IMPLEMENTATION or PROGRAM */
char options[128];
int DefinitionModule;
-int SYSTEMModule;
char *ProgName;
char *DEFPATH[NDIRS+1];
struct def *Defined;
reserve(tkidf);
InitScope();
InitTypes();
- InitDef();
AddStandards();
#ifdef DEBUG
if (options['l']) {
df->enm_next = 0;
}
-do_SYSTEM()
-{
- /* Simulate the reading of the SYSTEM definition module
- */
- char *SYSTEM = "\
+/* How do you like that! Modula-2 in a C-program.
+*/
+char SYSTEM[] = "\
DEFINITION MODULE SYSTEM;\n\
+TYPE PROCESS = ADDRESS;\n\
PROCEDURE NEWPROCESS(P:PROC; A:ADDRESS; n:CARDINAL; VAR p1:ADDRESS);\n\
PROCEDURE TRANSFER(VAR p1,p2:ADDRESS);\n\
END SYSTEM.\n";
+do_SYSTEM()
+{
+ /* Simulate the reading of the SYSTEM definition module
+ */
open_scope(CLOSEDSCOPE);
(void) Enter("WORD", D_TYPE, word_type, 0);
(void) Enter("ADDRESS", D_TYPE, address_type, 0);
(void) Enter("ADR", D_PROCEDURE, std_type, S_ADR);
(void) Enter("TSIZE", D_PROCEDURE, std_type, S_TSIZE);
- if (!InsertText(SYSTEM, strlen(SYSTEM))) {
+ if (!InsertText(SYSTEM, sizeof(SYSTEM) - 1)) {
fatal("Could not insert text");
}
- SYSTEMModule = 1;
DefModule();
- SYSTEMModule = 0;
+ close_scope(SC_CHKFORW);
}
#ifdef DEBUG
/* S O M E G L O B A L V A R I A B L E S */
-/* $Header$ */
-
extern char options[]; /* indicating which options were given */
extern int DefinitionModule;
module
*/
-extern int SYSTEMModule;/* flag indicating that we are handling the SYSTEM
- module
- */
extern struct def *Defined;
/* definition structure of module defined in this
compilation
sed -e '
-s:^.*[ ]ALLOCDEF[ ].*"\(.*\)".*$:\
+s:^.*[ ]ALLOCDEF[ ].*"\(.*\)"[ ]*\([0-9][0-9]*\).*$:\
/* allocation definitions of struct \1 */\
extern char *st_alloc();\
extern struct \1 *h_\1;\
#ifdef DEBUG\
extern int cnt_\1;\
-#define new_\1() ((struct \1 *) std_alloc((char **)\&h_\1, sizeof(struct \1), \&cnt_\1))\
+extern char *std_alloc();\
+#define new_\1() ((struct \1 *) std_alloc((char **)\&h_\1, sizeof(struct \1), \2, \&cnt_\1))\
#else\
-#define new_\1() ((struct \1 *) st_alloc((char **)\&h_\1, sizeof(struct \1)))\
+#define new_\1() ((struct \1 *) st_alloc((char **)\&h_\1, sizeof(struct \1), \2))\
#endif\
#define free_\1(p) st_free(p, h_\1, sizeof(struct \1))\
:' -e '
-s:^.*[ ]STATICALLOCDEF[ ].*"\(.*\)".*$:\
+s:^.*[ ]STATICALLOCDEF[ ].*"\(.*\)"[ ]*\([0-9][0-9]*\).*$:\
/* allocation definitions of struct \1 */\
extern char *st_alloc();\
struct \1 *h_\1;\
#ifdef DEBUG\
int cnt_\1;\
-#define new_\1() ((struct \1 *) std_alloc((char **)\&h_\1, sizeof(struct \1), \&cnt_\1))\
+#define new_\1() ((struct \1 *) std_alloc((char **)\&h_\1, sizeof(struct \1), \2, \&cnt_\1))\
#else\
-#define new_\1() ((struct \1 *) st_alloc((char **)\&h_\1, sizeof(struct \1)))\
+#define new_\1() ((struct \1 *) st_alloc((char **)\&h_\1, sizeof(struct \1), \2))\
#endif\
#define free_\1(p) st_free(p, h_\1, sizeof(struct \1))\
:'
/* M I S C E L L A N E O U S R O U T I N E S */
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
#include <alloc.h>
#include <em_arith.h>
#include <em_label.h>
/* M I S C E L L A N E O U S */
-/* $Header$ */
-
#define is_anon_idf(x) ((x)->id_text[0] == '#')
extern struct idf
/* N O D E O F A N A B S T R A C T P A R S E T R E E */
-/* $Header$ */
-
struct node {
struct node *next;
#define nd_left next
#define nd_REL nd_token.TOK_REL
};
-/* ALLOCDEF "node" */
+/* ALLOCDEF "node" 50 */
extern struct node *MkNode(), *MkLeaf();
/* N O D E O F A N A B S T R A C T P A R S E T R E E */
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
#include "debug.h"
#include <em_label.h>
/* U S E R O P T I O N - H A N D L I N G */
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
#include "idfsize.h"
#include "ndir.h"
static int ndirs;
DoOption(text)
- char *text;
+ register char *text;
{
switch(*text++) {
*/
- case 'M': /* maximum identifier length */
- idfsize = txt2int(&text);
- if (*text || idfsize <= 0)
+ case 'M': { /* maximum identifier length */
+ char *t = text; /* because &text is illegal */
+
+ idfsize = txt2int(&t);
+ if (*t || idfsize <= 0)
fatal("malformed -M option");
if (idfsize > IDFSIZE)
fatal("maximum identifier length is %d", IDFSIZE);
+ }
break;
case 'I' :
arith size;
int align;
char c;
+ char *t;
while (c = *text++) {
- size = txt2int(&text);
+ t = text;
+ size = txt2int(&t);
align = 0;
- if (*text == '.') {
- text++;
- align = txt2int(&text);
+ if (*(text = t) == '.') {
+ t = text + 1;
+ align = txt2int(&t);
+ text = t;
}
switch (c) {
int
txt2int(tp)
- char **tp;
+ register char **tp;
{
/* the integer pointed to by *tp is read, while increasing
*tp; the resulting value is yielded.
/* O V E R A L L S T R U C T U R E */
{
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
#include "debug.h"
#include <alloc.h>
ModuleDeclaration
{
- struct idf *id; /* save module identifier */
register struct def *df;
struct node *exportlist = 0;
int qualified;
} :
- MODULE IDENT { id = dot.TOK_IDF;
- df = DefineLocalModule(id);
- }
+ MODULE IDENT { df = DefineLocalModule(dot.TOK_IDF); }
priority(&(df->mod_priority))?
';'
import(1)*
EnterExportList(exportlist, qualified);
}
close_scope(SC_CHKFORW|SC_CHKPROC|SC_REVERSE);
- match_id(id, dot.TOK_IDF);
+ match_id(df->df_idf, dot.TOK_IDF);
}
;
df = lookfor(nd,enclosing(CurrVis),0);
FreeNode(nd);
}
- else df = GetDefinitionModule(dot.TOK_IDF);
+ else df = GetDefinitionModule(dot.TOK_IDF, 1);
}
|
{ fromid = 0; }
DefinitionModule
{
register struct def *df;
- struct idf *id; /* save module identifier */
struct node *exportlist;
int dummy;
} :
DEFINITION
- MODULE IDENT { id = dot.TOK_IDF;
- df = define(id, GlobalScope, D_MODULE);
+ MODULE IDENT { df = define(dot.TOK_IDF, GlobalScope, D_MODULE);
if (!Defined) Defined = df;
- if (!SYSTEMModule) open_scope(CLOSEDSCOPE);
- CurrentScope->sc_name = id->id_text;
+ CurrentScope->sc_name = df->df_idf->id_text;
df->mod_vis = CurrVis;
df->df_type = standard_type(T_RECORD, 0, (arith) 0);
df->df_type->rec_scope = df->mod_vis->sc_scope;
/* empty */
]
definition* END IDENT
- { df = CurrentScope->sc_def;
- while (df) {
+ { register struct def *df1 = CurrentScope->sc_def;
+ while (df1) {
/* Make all definitions "QUALIFIED EXPORT" */
- df->df_flags |= D_QEXPORTED;
- df = df->df_nextinscope;
+ df1->df_flags |= D_QEXPORTED;
+ df1 = df1->df_nextinscope;
}
- close_scope(SC_CHKFORW);
DefinitionModule--;
- match_id(id, dot.TOK_IDF);
+ match_id(df->df_idf, dot.TOK_IDF);
}
'.'
;
ProgramModule
{
- struct idf *id;
struct def *GetDefinitionModule();
register struct def *df;
} :
MODULE
- IDENT { id = dot.TOK_IDF;
- if (state == IMPLEMENTATION) {
- df = GetDefinitionModule(id);
+ IDENT { if (state == IMPLEMENTATION) {
+ df = GetDefinitionModule(dot.TOK_IDF, 0);
CurrVis = df->mod_vis;
RemoveImports(&(CurrentScope->sc_def));
}
else {
- Defined = df = define(id, CurrentScope, D_MODULE);
+ Defined = df = define(dot.TOK_IDF, CurrentScope, D_MODULE);
open_scope(CLOSEDSCOPE);
df->mod_vis = CurrVis;
CurrentScope->sc_name = "_M2M";
';' import(0)*
block(&(df->mod_body)) IDENT
{ close_scope(SC_CHKFORW|SC_CHKPROC|SC_REVERSE);
- match_id(id, dot.TOK_IDF);
+ match_id(df->df_idf, dot.TOK_IDF);
}
'.'
;
Module:
+ { open_scope(CLOSEDSCOPE); }
DefinitionModule
+ { close_scope(SC_CHKFORW); }
|
[
IMPLEMENTATION { state = IMPLEMENTATION; }
/* S C O P E M E C H A N I S M */
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
#include "debug.h"
#include <assert.h>
extern int proclevel;
static struct scopelist *PervVis;
-/* STATICALLOCDEF "scope" */
+/* STATICALLOCDEF "scope" 10 */
-/* STATICALLOCDEF "scopelist" */
+/* STATICALLOCDEF "scopelist" 10 */
open_scope(scopetype)
{
assert(scopetype == OPENSCOPE || scopetype == CLOSEDSCOPE);
- clear((char *) sc, sizeof (struct scope));
sc->sc_scopeclosed = scopetype == CLOSEDSCOPE;
sc->sc_level = proclevel;
+ ls->sc_scope = sc;
+ ls->sc_encl = CurrVis;
if (scopetype == OPENSCOPE) {
- ls->next = CurrVis;
+ ls->next = ls->sc_encl;
}
else ls->next = PervVis;
- ls->sc_scope = sc;
- ls->sc_encl = CurrVis;
CurrVis = ls;
}
struct type *fo_ptyp;
};
-/* STATICALLOCDEF "forwards" */
+/* STATICALLOCDEF "forwards" 5 */
Forward(tk, ptp)
struct node *tk;
same scope.
*/
register struct forwards *f = new_forwards();
+ register struct scope *sc = CurrentScope;
f->fo_tok = tk;
f->fo_ptyp = ptp;
- f->next = CurrentScope->sc_forw;
- CurrentScope->sc_forw = f;
+ f->next = sc->sc_forw;
+ sc->sc_forw = f;
}
STATIC
register struct def *df;
{
/* Called at scope closing. Check all definitions, and if one
- is a D_PROCHEAD, the procedure was not defined
+ is a D_PROCHEAD, the procedure was not defined.
*/
while (df) {
if (df->df_kind == D_PROCHEAD) {
/* A not defined procedure
*/
-error("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;
STATIC
chk_forw(pdf)
- register struct def **pdf;
+ struct def **pdf;
{
/* Called at scope close. Look for all forward definitions and
if the scope was a closed scope, give an error message for
them, and otherwise move them to the enclosing scope.
*/
- while (*pdf) {
- if ((*pdf)->df_kind & (D_FORWARD|D_FORWMODULE)) {
+ register struct def *df;
+
+ while (df = *pdf) {
+ if (df->df_kind & (D_FORWARD|D_FORWMODULE)) {
/* These definitions must be found in
the enclosing closed scope, which of course
may be the scope that is now closed!
*/
- struct def *df1 = (*pdf)->df_nextinscope;
-
if (scopeclosed(CurrentScope)) {
/* Indeed, the scope was a closed
scope, so give error message
*/
-node_error((*pdf)->for_node, "identifier \"%s\" has not been declared",
-(*pdf)->df_idf->id_text);
- FreeNode((*pdf)->for_node);
- pdf = &(*pdf)->df_nextinscope;
+node_error(df->for_node, "identifier \"%s\" has not been declared",
+df->df_idf->id_text);
+ FreeNode(df->for_node);
}
- else { /* This scope was an open scope.
+ else {
+ /* This scope was an open scope.
Maybe the definitions are in the
enclosing scope?
*/
- struct scopelist *ls;
-
- ls = nextvisible(CurrVis);
- if ((*pdf)->df_kind == D_FORWMODULE) {
- (*pdf)->for_vis->next = ls;
+ register struct scopelist *ls =
+ nextvisible(CurrVis);
+ struct def *df1 = df->df_nextinscope;
+
+ if (df->df_kind == D_FORWMODULE) {
+ df->for_vis->next = ls;
}
- (*pdf)->df_nextinscope = ls->sc_scope->sc_def;
- ls->sc_scope->sc_def = *pdf;
- (*pdf)->df_scope = ls->sc_scope;
+ df->df_nextinscope = ls->sc_scope->sc_def;
+ ls->sc_scope->sc_def = df;
+ df->df_scope = ls->sc_scope;
*pdf = df1;
+ continue;
}
}
- else pdf = &(*pdf)->df_nextinscope;
+ pdf = &df->df_nextinscope;
}
}
if (fo->next) rem_forwards(fo->next);
df = lookfor(fo->fo_tok, CurrVis, 0);
- if (df->df_kind == D_ERROR) {
- node_error(fo->fo_tok, "identifier \"%s\" not declared",
- df->df_idf->id_text);
- }
- else if (df->df_kind != D_TYPE) {
- node_error(fo->fo_tok, "identifier \"%s\" not a type",
- df->df_idf->id_text);
+ if (! is_type(df)) {
+ node_error(fo->fo_tok,
+ "identifier \"%s\" does not represent a type",
+ df->df_idf->id_text);
}
fo->fo_ptyp->next = df->df_type;
free_forwards(fo);
}
Reverse(pdf)
- register struct def **pdf;
+ struct def **pdf;
{
/* Reverse the order in the list of definitions in a scope.
This is neccesary because this list is built in reverse.
df = 0;
df1 = *pdf;
- while (df1) {
- if (df1->df_kind & INTERESTING) break;
- df1 = df1->df_nextinscope;
- }
-
- if (!(*pdf = df1)) return;
while (df1) {
- *pdf = df1;
- df1 = df1->df_nextinscope;
- while (df1) {
- if (df1->df_kind & INTERESTING) break;
+ if (df1->df_kind & INTERESTING) {
+ struct def *prev = df;
+
+ df = df1;
df1 = df1->df_nextinscope;
+ df->df_nextinscope = prev;
}
- (*pdf)->df_nextinscope = df;
- df = *pdf;
+ else df1 = df1->df_nextinscope;
}
+ *pdf = df;
}
close_scope(flag)
/* S C O P E M E C H A N I S M */
-/* $Header$ */
-
#define OPENSCOPE 0 /* Indicating an open scope */
#define CLOSEDSCOPE 1 /* Indicating a closed scope (module) */
/* S T A N D A R D P R O C E D U R E S A N D F U N C T I O N S */
-/* $Header$ */
-
#define S_ABS 1
#define S_CAP 2
#define S_CHR 3
/* S T A T E M E N T S */
{
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
#include <assert.h>
#include <em_arith.h>
#include <em_label.h>
statement(register struct node **pnd;)
{
register struct node *nd;
+ extern int return_occurred;
} :
/*
* This part is not in the reference grammar. The reference grammar
}
|
ReturnStatement(pnd)
+ { return_occurred = 1; }
|
/* empty */ { *pnd = 0; }
;
[ %persistent
';' statement(&nd)
{ if (nd) {
- *pnd = MkNode(Link, *pnd, nd, &dot);
- (*pnd)->nd_symb = ';';
- pnd = &((*pnd)->nd_right);
+ register struct node *nd1 =
+ MkNode(Link, *pnd, nd, &dot);
+
+ *pnd = nd1;
+ nd1->nd_symb = ';';
+ pnd = &(nd1->nd_right);
}
}
]*
ForStatement(struct node **pnd;)
{
- register struct node *nd;
+ register struct node *nd, *nd1;
struct node *dummy;
}:
FOR { *pnd = nd = MkLeaf(Stat, &dot); }
IDENT { nd->nd_IDF = dot.TOK_IDF; }
- BECOMES { nd->nd_left = MkLeaf(Stat, &dot);
- nd = nd->nd_left;
- }
- expression(&(nd->nd_left))
+ BECOMES { nd->nd_left = nd1 = MkLeaf(Stat, &dot); }
+ expression(&(nd1->nd_left))
TO
- expression(&(nd->nd_right))
+ expression(&(nd1->nd_right))
[
BY
ConstExpression(&dummy)
{ if (!(dummy->nd_type->tp_fund & T_INTORCARD)) {
error("illegal type in BY clause");
}
- nd->nd_INT = dummy->nd_INT;
+ nd1->nd_INT = dummy->nd_INT;
FreeNode(dummy);
}
|
- { nd->nd_INT = 1; }
+ { nd1->nd_INT = 1; }
]
DO
- StatementSequence(&((*pnd)->nd_right))
+ StatementSequence(&(nd->nd_right))
END
;
{
register struct def *df = CurrentScope->sc_definedby;
register struct node *nd;
- extern int return_occurred;
} :
- RETURN { *pnd = nd = MkLeaf(Stat, &dot);
- return_occurred = 1;
- }
+ RETURN { *pnd = nd = MkLeaf(Stat, &dot); }
[
expression(&(nd->nd_right))
{ if (scopeclosed(CurrentScope)) {
/* T E M P O R A R Y V A R I A B L E S */
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
/* Code for the allocation and de-allocation of temporary variables,
allowing re-use.
The routines use "ProcScope" instead of "CurrentScope", because
arith t_offset; /* offset from LocalBase */
};
-/* STATICALLOCDEF "tmpvar" */
+/* STATICALLOCDEF "tmpvar" 10 */
static struct tmpvar *TmpInts, /* for integer temporaries */
*TmpPtrs; /* for pointer temporaries */
arith
NewInt()
{
- arith offset;
+ register arith offset;
register struct tmpvar *tmp;
if (!TmpInts) {
arith
NewPtr()
{
- arith offset;
+ register arith offset;
register struct tmpvar *tmp;
if (!TmpPtrs) {
/* T O K E N D E F I N I T I O N S */
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
#include "tokenname.h"
#include "Lpars.h"
#include "idf.h"
/* T O K E N N A M E S T R U C T U R E */
-/* $Header$ */
-
struct tokenname { /* Used for defining the name of a
token as identified by its symbol
*/
/* T Y P E D E S C R I P T O R S T R U C T U R E */
-/* $Header$ */
-
struct paramlist { /* structure for parameterlist of a PROCEDURE */
struct paramlist *next;
struct def *par_def; /* "df" of parameter */
#define TypeOfParam(xpar) ((xpar)->par_def->df_type)
};
-/* ALLOCDEF "paramlist" */
+/* ALLOCDEF "paramlist" 20 */
struct enume {
struct def *en_enums; /* Definitions of enumeration literals */
} tp_value;
};
-/* ALLOCDEF "type" */
+/* ALLOCDEF "type" 50 */
extern struct type
*bool_type,
align(); /* type.c */
struct type
- *create_type(),
*construct_type(),
*standard_type(),
*set_type(),
*subr_type(),
+ *proc_type(),
*RemoveEqual(); /* All from type.c */
#define NULLTYPE ((struct type *) 0)
/* T Y P E D E F I N I T I O N M E C H A N I S M */
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
#include "target_sizes.h"
#include "debug.h"
#include "maxset.h"
int cnt_type;
#endif
-struct type *
-create_type(fund)
- int fund;
-{
- /* A brand new struct type is created, and its tp_fund set
- to fund.
- */
- register struct type *ntp = new_type();
-
- clear((char *)ntp, sizeof(struct type));
- ntp->tp_fund = fund;
-
- return ntp;
-}
-
struct type *
construct_type(fund, tp)
int fund;
/* fund must be a type constructor.
The pointer to the constructed type is returned.
*/
- register struct type *dtp = create_type(fund);
+ register struct type *dtp = new_type();
- switch (fund) {
+ switch (dtp->tp_fund = fund) {
case T_PROCEDURE:
case T_POINTER:
case T_HIDDEN:
int align;
arith size;
{
- register struct type *tp = create_type(fund);
+ register struct type *tp = new_type();
+ tp->tp_fund = fund;
tp->tp_align = align;
tp->tp_size = size;
fatal("long real size smaller than real size");
}
- if (!pointer_size || pointer_size % word_size != 0) {
- fatal("illegal pointer size");
- }
-
/* character type
*/
char_type = standard_type(T_CHAR, 1, (arith) 1);
return res;
}
+struct type *
+proc_type(result_type, parameters, n_bytes_params)
+ struct type *result_type;
+ struct paramlist *parameters;
+ arith n_bytes_params;
+{
+ register struct type *tp = construct_type(T_PROCEDURE, result_type);
+
+ tp->prc_params = parameters;
+ tp->prc_nbpar = n_bytes_params;
+ return tp;
+}
+
genrck(tp)
register struct type *tp;
{
neccessary. Return its label.
*/
arith lb, ub;
- label ol, l;
+ register label ol;
+ int newlabel = 0;
getbounds(tp, &lb, &ub);
if (tp->tp_fund == T_SUBRANGE) {
if (!(ol = tp->sub_rck)) {
- tp->sub_rck = l = ++data_label;
+ tp->sub_rck = ol = ++data_label;
+ newlabel = 1;
}
}
else if (!(ol = tp->enm_rck)) {
- tp->enm_rck = l = ++data_label;
+ tp->enm_rck = ol = ++data_label;
+ newlabel = 1;
}
- if (!ol) {
- ol = l;
+ if (newlabel) {
C_df_dlb(ol);
C_rom_cst(lb);
C_rom_cst(ub);
Also make sure that its size is either a dividor of the word_size,
or a multiple of it.
*/
- arith algn;
+ register arith algn;
if (tp->tp_fund == T_ARRAY) ArraySizes(tp);
algn = align(tp->tp_size, tp->tp_align);
while (pr) {
pr1 = pr;
pr = pr->next;
+ free_def(pr1->par_def);
free_paramlist(pr1);
}
{
if (!tp) return;
- print(" a:%d; s:%ld;", tp->tp_align, (long) tp->tp_size);
- if (tp->next && tp->tp_fund != T_POINTER) {
- /* Avoid printing recursive types!
- */
- print(" n:(");
- DumpType(tp->next);
- print(")");
- }
+ print("align:%d; size:%ld;", tp->tp_align, (long) tp->tp_size);
- print(" f:");
+ print(" fund:");
switch(tp->tp_fund) {
case T_RECORD:
print("RECORD"); break;
case T_ENUMERATION:
- print("ENUMERATION; n:%d", tp->enm_ncst); break;
+ print("ENUMERATION; ncst:%d", tp->enm_ncst); break;
case T_INTEGER:
print("INTEGER"); break;
case T_CARDINAL:
print("PROCEDURE");
if (par) {
- print("; p:");
+ print("(");
while(par) {
if (IsVarParam(par)) print("VAR ");
DumpType(TypeOfParam(par));
}
case T_ARRAY:
print("ARRAY");
- print("; el:");
+ print("; element:");
DumpType(tp->arr_elem);
print("; index:");
DumpType(tp->next);
- break;
+ print(";");
+ return;
case T_STRING:
print("STRING"); break;
case T_INTORCARD:
default:
crash("DumpType");
}
+ if (tp->next && tp->tp_fund != T_POINTER) {
+ /* Avoid printing recursive types!
+ */
+ print(" next:(");
+ DumpType(tp->next);
+ print(")");
+ }
print(";");
}
#endif
/* T Y P E E Q U I V A L E N C E */
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
/* Routines for testing type equivalence, type compatibility, and
assignment compatibility
*/
/* P A R S E T R E E W A L K E R */
-#ifndef NORCSID
-static char *RcsId = "$Header$";
-#endif
-
/* Routines to walk through parts of the parse tree, and generate
code for these parts.
*/
C_loe_dlb(l1, (arith) 0);
C_zne(RETURN_LABEL);
C_ine_dlb(l1, (arith) 0);
- /* Prevent this module from calling its own
- initialization routine
- */
- assert(nd->nd_IDF == module->df_idf);
- nd = nd->next;
}
for (; nd; nd = nd->next) {
break;
case IF:
- { label l1, l2, l3;
+ { label l1 = ++text_label, l3 = ++text_label;
- l1 = ++text_label;
- l2 = ++text_label;
- l3 = ++text_label;
ExpectBool(left, l3, l1);
assert(right->nd_symb == THEN);
C_df_ilb(l3);
WalkNode(right->nd_left, exit_label);
if (right->nd_right) { /* ELSE part */
+ label l2 = ++text_label;
+
C_bra(l2);
C_df_ilb(l1);
WalkNode(right->nd_right, exit_label);
break;
case WHILE:
- { label l1, l2, l3;
+ { label loop = ++text_label,
+ exit = ++text_label,
+ dummy = ++text_label;
- l1 = ++text_label;
- l2 = ++text_label;
- l3 = ++text_label;
- C_df_ilb(l1);
- ExpectBool(left, l3, l2);
- C_df_ilb(l3);
+ C_df_ilb(loop);
+ ExpectBool(left, dummy, exit);
+ C_df_ilb(dummy);
WalkNode(right, exit_label);
- C_bra(l1);
- C_df_ilb(l2);
+ C_bra(loop);
+ C_df_ilb(exit);
break;
}
case REPEAT:
- { label l1, l2;
+ { label loop = ++text_label, exit = ++text_label;
- l1 = ++text_label;
- l2 = ++text_label;
- C_df_ilb(l1);
+ C_df_ilb(loop);
WalkNode(left, exit_label);
- ExpectBool(right, l2, l1);
- C_df_ilb(l2);
+ ExpectBool(right, exit, loop);
+ C_df_ilb(exit);
break;
}
case LOOP:
- { label l1, l2;
+ { label loop = ++text_label, exit = ++text_label;
- l1 = ++text_label;
- l2 = ++text_label;
- C_df_ilb(l1);
- WalkNode(right, l2);
- C_bra(l1);
- C_df_ilb(l2);
+ C_df_ilb(loop);
+ WalkNode(right, exit);
+ C_bra(loop);
+ C_df_ilb(exit);
break;
}
case FOR:
{
arith tmp = 0;
- struct node *fnd;
+ register struct node *fnd;
label l1 = ++text_label;
label l2 = ++text_label;
if (! DoForInit(nd, left)) break;
fnd = left->nd_right;
if (fnd->nd_class != Value) {
+ /* Upperbound not constant.
+ The expression may only be evaluated once,
+ so generate a temporary for it
+ */
CodePExpr(fnd);
tmp = NewInt();
C_stl(tmp);
}
- C_bra(l1);
- C_df_ilb(l2);
+ C_df_ilb(l1);
+ C_dup(int_size);
+ if (tmp) C_lol(tmp); else C_loc(fnd->nd_INT);
+ if (left->nd_INT > 0) {
+ C_bgt(l2);
+ }
+ else C_blt(l2);
RangeCheck(nd->nd_type, int_type);
CodeDStore(nd);
WalkNode(right, exit_label);
CodePExpr(nd);
C_loc(left->nd_INT);
C_adi(int_size);
- C_df_ilb(l1);
- C_dup(int_size);
- if (tmp) C_lol(tmp); else C_loc(fnd->nd_INT);
- if (left->nd_INT > 0) {
- C_ble(l2);
- }
- else C_bge(l2);
+ C_bra(l1);
+ C_df_ilb(l2);
C_asp(int_size);
if (tmp) FreeInt(tmp);
}
struct scopelist link;
struct withdesig wds;
struct desig ds;
- arith tmp = 0;
if (! WalkDesignator(left, &ds)) break;
if (left->nd_type->tp_fund != T_RECORD) {
ds.dsg_kind = DSG_FIXED;
/* Create a designator structure for the temporary.
*/
- ds.dsg_offset = tmp = NewPtr();
+ ds.dsg_offset = NewPtr();
ds.dsg_name = 0;
CodeStore(&ds, pointer_size);
ds.dsg_kind = DSG_PFIXED;
WalkNode(right, exit_label);
CurrVis = link.next;
WithDesigs = wds.w_next;
- FreePtr(tmp);
+ FreePtr(ds.dsg_offset);
break;
}
nd->nd_symb = IDENT;
if (! ChkVariable(nd) ||
- ! ChkExpression(left->nd_left) ||
+ ! WalkExpr(left->nd_left) ||
! ChkExpression(left->nd_right)) return 0;
df = nd->nd_def;
if (df->df_kind == D_FIELD) {
- node_error(nd, "FOR-loop variable may not be a field of a record");
+ node_error(nd,
+ "FOR-loop variable may not be a field of a record");
return 0;
}
if (df->df_scope != CurrentScope) {
register struct scopelist *sc = CurrVis;
- while (sc && sc->sc_scope != df->df_scope) {
+ for (;;) {
+ if (!sc) {
+ node_error(nd,
+ "FOR-loop variable may not be imported");
+ return 0;
+ }
+ if (sc->sc_scope == df->df_scope) break;
sc = nextvisible(sc);
}
-
- if (!sc) {
- node_error(nd, "FOR-loop variable may not be imported");
- return 0;
- }
}
if (df->df_type->tp_size > word_size ||
node_warning(nd, "old-fashioned! compatibility required in FOR statement");
}
- CodePExpr(left->nd_left);
-
return 1;
}
/* 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.
+ DAMN THE BOOK!
*/
struct desig dsl, dsr;
- if (! ChkExpression(right)) return;
- if (! ChkVariable(left)) return;
+ if (! ChkExpression(right) || ! ChkVariable(left)) return;
+
if (right->nd_symb == STRING) TryToString(right, left->nd_type);
dsr = InitDesig;
CodeExpr(right, &dsr, NO_LABEL, NO_LABEL);
/* P A R S E T R E E W A L K E R */
-/* $Header$ */
-
/* Definition of WalkNode macro
*/
public / ack.git / commitdiff