From 3030eb8cae10f61ff50fc74880877516abbb955a Mon Sep 17 00:00:00 2001 From: ceriel Date: Mon, 6 Oct 1986 20:36:30 +0000 Subject: [PATCH] newer version --- lang/m2/comp/LLlex.c | 25 ++-- lang/m2/comp/LLlex.h | 2 - lang/m2/comp/LLmessage.c | 22 +-- lang/m2/comp/Makefile | 40 +++--- lang/m2/comp/Parameters | 16 +-- lang/m2/comp/Resolve | 8 +- lang/m2/comp/Version.c | 1 + lang/m2/comp/casestat.C | 97 +++++++------ lang/m2/comp/chk_expr.c | 224 ++++++++++++++++------------- lang/m2/comp/chk_expr.h | 2 - lang/m2/comp/class.h | 2 - lang/m2/comp/code.c | 150 ++++++++----------- lang/m2/comp/const.h | 2 - lang/m2/comp/cstoper.c | 8 +- lang/m2/comp/declar.g | 293 +++++++++++++++++--------------------- lang/m2/comp/def.H | 15 +- lang/m2/comp/def.c | 179 ++++++++++++----------- lang/m2/comp/defmodule.c | 36 +++-- lang/m2/comp/desig.c | 5 - lang/m2/comp/desig.h | 2 - lang/m2/comp/enter.c | 79 +++++----- lang/m2/comp/error.c | 4 - lang/m2/comp/expression.g | 31 ++-- lang/m2/comp/f_info.h | 2 - lang/m2/comp/idf.c | 2 - lang/m2/comp/idf.h | 2 - lang/m2/comp/input.c | 12 +- lang/m2/comp/input.h | 2 - lang/m2/comp/lookup.c | 4 - lang/m2/comp/main.c | 24 ++-- lang/m2/comp/main.h | 5 - lang/m2/comp/make.allocd | 13 +- lang/m2/comp/misc.c | 4 - lang/m2/comp/misc.h | 2 - lang/m2/comp/node.H | 4 +- lang/m2/comp/node.c | 4 - lang/m2/comp/options.c | 28 ++-- lang/m2/comp/program.g | 43 +++--- lang/m2/comp/scope.C | 99 ++++++------- lang/m2/comp/scope.h | 2 - lang/m2/comp/standards.h | 2 - lang/m2/comp/statement.g | 36 +++-- lang/m2/comp/tmpvar.C | 10 +- lang/m2/comp/tokenname.c | 4 - lang/m2/comp/tokenname.h | 2 - lang/m2/comp/type.H | 8 +- lang/m2/comp/type.c | 85 ++++++----- lang/m2/comp/typequiv.c | 4 - lang/m2/comp/walk.c | 109 +++++++------- lang/m2/comp/walk.h | 2 - 50 files changed, 836 insertions(+), 921 deletions(-) create mode 100644 lang/m2/comp/Version.c diff --git a/lang/m2/comp/LLlex.c b/lang/m2/comp/LLlex.c index d97afee18..2f4887342 100644 --- a/lang/m2/comp/LLlex.c +++ b/lang/m2/comp/LLlex.c @@ -1,9 +1,5 @@ /* 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" @@ -40,9 +36,10 @@ SkipComment() 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 @@ -51,12 +48,22 @@ SkipComment() } 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); } } @@ -69,7 +76,8 @@ GetString(upto) 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"); @@ -394,6 +402,7 @@ lexwarning("Character constant out of range"); case STCHAR: default: crash("(LLlex) Impossible character class"); + /*NOTREACHED*/ } /*NOTREACHED*/ } diff --git a/lang/m2/comp/LLlex.h b/lang/m2/comp/LLlex.h index 16495e10b..c6cc4a406 100644 --- a/lang/m2/comp/LLlex.h +++ b/lang/m2/comp/LLlex.h @@ -1,7 +1,5 @@ /* 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 { diff --git a/lang/m2/comp/LLmessage.c b/lang/m2/comp/LLmessage.c index 3fabfbc6c..ead8f103a 100644 --- a/lang/m2/comp/LLmessage.c +++ b/lang/m2/comp/LLmessage.c @@ -1,9 +1,5 @@ /* 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 @@ -39,24 +35,28 @@ LLmessage(tk) 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; } } diff --git a/lang/m2/comp/Makefile b/lang/m2/comp/Makefile index 02c58fe24..772b3ac7b 100644 --- a/lang/m2/comp/Makefile +++ b/lang/m2/comp/Makefile @@ -1,5 +1,4 @@ # make modula-2 "compiler" -# $Header$ EMDIR = /usr/ceriel/em MHDIR = $(EMDIR)/modules/h PKGDIR = $(EMDIR)/modules/pkg @@ -8,19 +7,26 @@ LLGEN = $(EMDIR)/bin/LLgen 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! @@ -44,11 +50,11 @@ all: Cfiles @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 @@ -57,20 +63,22 @@ 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 @@ -78,7 +86,7 @@ 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 @@ -114,7 +122,7 @@ char.c: ../src/char.tab ../src/tab 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 @@ -128,13 +136,13 @@ main.o: LLlex.h Lpars.h debug.h def.h f_info.h idf.h input.h inputtype.h ndir.h 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 @@ -145,7 +153,7 @@ casestat.o: LLlex.h Lpars.h debug.h density.h desig.h node.h type.h walk.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 diff --git a/lang/m2/comp/Parameters b/lang/m2/comp/Parameters index a1d3ff8ce..0fe8880a4 100644 --- a/lang/m2/comp/Parameters +++ b/lang/m2/comp/Parameters @@ -34,13 +34,13 @@ /* 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 @@ -55,7 +55,7 @@ extern char options[]; #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 diff --git a/lang/m2/comp/Resolve b/lang/m2/comp/Resolve index cabad11d5..7c96827f6 100755 --- a/lang/m2/comp/Resolve +++ b/lang/m2/comp/Resolve @@ -19,10 +19,10 @@ then : 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 diff --git a/lang/m2/comp/Version.c b/lang/m2/comp/Version.c new file mode 100644 index 000000000..ac7bbbfa6 --- /dev/null +++ b/lang/m2/comp/Version.c @@ -0,0 +1 @@ +char Version[] = "Version 0.5"; diff --git a/lang/m2/comp/casestat.C b/lang/m2/comp/casestat.C index eeb9162a5..8216036fb 100644 --- a/lang/m2/comp/casestat.C +++ b/lang/m2/comp/casestat.C @@ -1,8 +1,11 @@ /* 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" @@ -22,30 +25,32 @@ static char *RcsId = "$Header$"; #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) @@ -56,30 +61,36 @@ CaseCode(nd, exitlabel) { /* 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; } @@ -90,19 +101,20 @@ CaseCode(nd, exitlabel) */ 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; @@ -115,24 +127,27 @@ CaseCode(nd, exitlabel) 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) { @@ -148,7 +163,7 @@ CaseCode(nd, exitlabel) C_df_ilb(sh->sh_default); WalkNode(pnode, exitlabel); - pnode = 0; + break; } } @@ -157,7 +172,7 @@ CaseCode(nd, exitlabel) } FreeSh(sh) - struct switch_hdr *sh; + register struct switch_hdr *sh; { /* free the allocated switch structure */ @@ -176,7 +191,7 @@ FreeSh(sh) 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 @@ -208,7 +223,7 @@ AddCases(sh, node, lbl) 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(); @@ -222,15 +237,17 @@ AddOneCase(sh, node, lbl) 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; diff --git a/lang/m2/comp/chk_expr.c b/lang/m2/comp/chk_expr.c index 981b98069..0b9638385 100644 --- a/lang/m2/comp/chk_expr.c +++ b/lang/m2/comp/chk_expr.c @@ -1,9 +1,5 @@ /* 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. */ @@ -31,6 +27,9 @@ int ChkVariable(expp) register struct node *expp; { + /* Check that "expp" indicates an item that can be + assigned to. + */ if (! ChkDesignator(expp)) return 0; @@ -47,6 +46,9 @@ STATIC int 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); @@ -59,8 +61,7 @@ ChkArrow(expp) 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; } @@ -72,6 +73,12 @@ STATIC int 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); @@ -91,7 +98,7 @@ ChkArr(expp) 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; } @@ -110,6 +117,7 @@ ChkArr(expp) return 1; } +#ifdef DEBUG STATIC int ChkValue(expp) struct node *expp; @@ -125,11 +133,15 @@ ChkValue(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; @@ -140,6 +152,9 @@ ChkLinkOrName(expp) 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 == '.'); @@ -188,16 +203,17 @@ df->df_idf->id_text); 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; } @@ -210,25 +226,28 @@ STATIC int 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; } } @@ -236,20 +255,6 @@ node_error(expp, "it is illegal to take the address of a standard or local proce 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; @@ -279,7 +284,7 @@ ChkElement(expp, tp, set) if (left->nd_INT > right->nd_INT) { node_error(expp, "lower bound exceeds upper bound in range"); - return RemoveSet(set); + return 0; } if (*set) { @@ -298,28 +303,24 @@ node_error(expp, "lower bound exceeds upper bound in range"); /* 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)); @@ -353,9 +354,11 @@ ChkSet(expp) 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; @@ -394,7 +397,8 @@ node_error(expp, "specifier does not represent a set 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; @@ -417,7 +421,6 @@ getarg(argp, bases, designator) 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; @@ -437,8 +440,7 @@ getarg(argp, bases, designator) } 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; } @@ -452,7 +454,12 @@ STATIC struct node * 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"); @@ -460,25 +467,26 @@ getname(argp, kinds) } 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 */ @@ -487,11 +495,12 @@ ChkProcCall(expp) 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)); } @@ -504,8 +513,8 @@ node_error(left, "type incompatibility in parameter"); } } - 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; } @@ -517,7 +526,7 @@ ChkCall(expp) 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; @@ -531,14 +540,14 @@ ChkCall(expp) 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 @@ -559,6 +568,10 @@ STATIC struct type * ResultOfOperation(operator, tp) struct type *tp; { + /* Return the result type of the binary operation "operator", + with operand type "tp". + */ + switch(operator) { case '=': case '#': @@ -582,6 +595,10 @@ Boolean(operator) STATIC int AllowedTypes(operator) { + /* Return a bit mask indicating the allowed operand types + for binary operator "operator". + */ + switch(operator) { case '+': case '-': @@ -615,13 +632,17 @@ STATIC int 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; @@ -656,21 +677,26 @@ ChkBinOper(expp) } } - 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) { @@ -679,38 +705,31 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R 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) { @@ -737,9 +756,8 @@ ChkUnOper(expp) 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 '+': @@ -799,6 +817,9 @@ STATIC struct node * 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; @@ -807,10 +828,11 @@ getvariable(argp) 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 @@ -1104,7 +1126,11 @@ done_before(expp) extern int NodeCrash(); int (*ExprChkTable[])() = { +#ifdef DEBUG ChkValue, +#else + done_before, +#endif ChkArr, ChkBinOper, ChkUnOper, @@ -1120,7 +1146,11 @@ int (*ExprChkTable[])() = { }; int (*DesigChkTable[])() = { +#ifdef DEBUG ChkValue, +#else + done_before, +#endif ChkArr, no_desig, no_desig, diff --git a/lang/m2/comp/chk_expr.h b/lang/m2/comp/chk_expr.h index 288bb7193..7b9b4b187 100644 --- a/lang/m2/comp/chk_expr.h +++ b/lang/m2/comp/chk_expr.h @@ -1,7 +1,5 @@ /* 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 */ diff --git a/lang/m2/comp/class.h b/lang/m2/comp/class.h index 5fb0f3d2e..50f88e540 100644 --- a/lang/m2/comp/class.h +++ b/lang/m2/comp/class.h @@ -1,7 +1,5 @@ /* 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. diff --git a/lang/m2/comp/code.c b/lang/m2/comp/code.c index d70f2f3e3..9a58a7a16 100644 --- a/lang/m2/comp/code.c +++ b/lang/m2/comp/code.c @@ -1,9 +1,5 @@ /* 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 */ @@ -34,7 +30,6 @@ CodeConst(cst, size) { /* Generate code to push constant "cst" with size "size" */ - label dlab; if (size <= word_size) { C_loc(cst); @@ -43,23 +38,28 @@ CodeConst(cst, size) 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); } @@ -85,16 +85,6 @@ CodePadString(nd, sz) 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; @@ -136,8 +126,14 @@ CodeExpr(nd, ds, true_label, false_label) 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); @@ -157,8 +153,8 @@ CodeExpr(nd, ds, true_label, false_label) 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; @@ -182,6 +178,8 @@ CodeExpr(nd, ds, true_label, false_label) } if (true_label != 0) { + /* Only for boolean expressions + */ CodeValue(ds, tp->tp_size); *ds = InitDesig; C_zne(true_label); @@ -293,6 +291,7 @@ CodeCall(nd) 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) { @@ -303,16 +302,16 @@ CodeCall(nd) 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) { @@ -387,11 +386,9 @@ CodeParameters(param, arg) 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) { @@ -417,7 +414,7 @@ CodeStd(nd) 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; @@ -425,7 +422,7 @@ CodeStd(nd) 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) { @@ -446,7 +443,7 @@ CodeStd(nd) case S_CAP: CodePExpr(left); - C_loc((arith) 0137); + C_loc((arith) 0137); /* ASCII assumed */ C_and(word_size); break; @@ -498,34 +495,25 @@ CodeStd(nd) 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"); @@ -552,29 +540,30 @@ CodeStd(nd) } 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) @@ -593,7 +582,10 @@ 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); @@ -806,6 +798,7 @@ CodeOper(expr, true_label, false_label) C_bra(false_label); } break; + case OR: case AND: case '&': { label l_true, l_false, l_maybe = ++text_label, l_end; @@ -822,7 +815,10 @@ CodeOper(expr, true_label, false_label) } 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); @@ -836,34 +832,6 @@ CodeOper(expr, true_label, false_label) } 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)); } @@ -958,9 +926,9 @@ CodeUoper(nd) 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 == ','); diff --git a/lang/m2/comp/const.h b/lang/m2/comp/const.h index 28cf5c99a..378748082 100644 --- a/lang/m2/comp/const.h +++ b/lang/m2/comp/const.h @@ -1,7 +1,5 @@ /* 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 diff --git a/lang/m2/comp/cstoper.c b/lang/m2/comp/cstoper.c index 6620b9850..9e5135c7e 100644 --- a/lang/m2/comp/cstoper.c +++ b/lang/m2/comp/cstoper.c @@ -1,9 +1,5 @@ /* 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" @@ -35,8 +31,10 @@ cstunary(expp) register arith o1 = expp->nd_right->nd_INT; switch(expp->nd_symb) { + /* Should not get here case '+': break; + */ case '-': o1 = -o1; @@ -71,7 +69,7 @@ cstbin(expp) */ 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); diff --git a/lang/m2/comp/declar.g b/lang/m2/comp/declar.g index 167bcf997..9087a00f1 100644 --- a/lang/m2/comp/declar.g +++ b/lang/m2/comp/declar.g @@ -1,10 +1,6 @@ /* D E C L A R A T I O N S */ { -#ifndef NORCSID -static char *RcsId = "$Header$"; -#endif - #include "debug.h" #include @@ -23,69 +19,38 @@ static char *RcsId = "$Header$"; #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) | @@ -106,15 +71,12 @@ declaration: 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) ]* ]? ')' @@ -134,12 +96,12 @@ FPSection(struct paramlist **ppr; arith *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); } @@ -194,12 +156,12 @@ SimpleType(struct type **ptp;) 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"); } } @@ -230,7 +192,10 @@ SubrangeType(struct type **ptp;) '[' 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;) @@ -254,18 +219,18 @@ 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 @@ -281,10 +246,10 @@ FieldListSequence(struct scope *scope; arith *cnt; int *palign;): 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; } : [ @@ -294,77 +259,81 @@ FieldList(struct scope *scope; arith *cnt; int *palign;) } | 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;): @@ -376,27 +345,29 @@ 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;) : @@ -410,7 +381,7 @@ 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); } @@ -418,49 +389,51 @@ PointerType(struct type **ptp;) /* 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); } diff --git a/lang/m2/comp/def.H b/lang/m2/comp/def.H index 56431ae62..226395c3a 100644 --- a/lang/m2/comp/def.H +++ b/lang/m2/comp/def.H @@ -1,7 +1,5 @@ /* 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 */ @@ -82,12 +80,12 @@ struct def { /* list of definitions for a name */ #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; @@ -115,14 +113,13 @@ struct def { /* list of definitions for a name */ #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(), diff --git a/lang/m2/comp/def.c b/lang/m2/comp/def.c index 04b43ebe6..c57f91548 100644 --- a/lang/m2/comp/def.c +++ b/lang/m2/comp/def.c @@ -1,9 +1,5 @@ /* 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 @@ -25,11 +21,42 @@ struct def *h_def; /* pointer to free list of def structures */ 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 @@ -38,7 +65,6 @@ MkDef(id, scope, kind) register struct def *df; df = new_def(); - clear((char *) df, sizeof (*df)); df->df_idf = id; df->df_scope = scope; df->df_kind = kind; @@ -52,24 +78,16 @@ MkDef(id, scope, 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; @@ -133,7 +151,8 @@ define(id, scope, kind) 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; @@ -143,7 +162,7 @@ error("identifier \"%s\" already declared", id->id_text); } 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 @@ -165,16 +184,15 @@ RemoveImports(pdf) } 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; @@ -184,13 +202,15 @@ RemoveFromIdList(df) } 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]; @@ -200,85 +220,61 @@ DeclProc(type) 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); } } @@ -326,6 +322,27 @@ DefineLocalModule(id) 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; diff --git a/lang/m2/comp/defmodule.c b/lang/m2/comp/defmodule.c index 94881826f..3ba1f6d8f 100644 --- a/lang/m2/comp/defmodule.c +++ b/lang/m2/comp/defmodule.c @@ -1,9 +1,5 @@ /* 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 @@ -15,23 +11,27 @@ static char *RcsId = "$Header$"; #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))) { @@ -42,17 +42,18 @@ GetFile(name) } 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. @@ -62,6 +63,8 @@ GetDefinitionModule(id) } else { GetFile(id->id_text); + CurrentId = id; + open_scope(CLOSEDSCOPE); DefModule(); if (level == 1) { /* The module is directly imported by the @@ -69,12 +72,23 @@ GetDefinitionModule(id) 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; } diff --git a/lang/m2/comp/desig.c b/lang/m2/comp/desig.c index c9fca7264..b8736335c 100644 --- a/lang/m2/comp/desig.c +++ b/lang/m2/comp/desig.c @@ -1,9 +1,5 @@ /* 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" @@ -166,7 +162,6 @@ CodeFieldDesig(df, ds) 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 diff --git a/lang/m2/comp/desig.h b/lang/m2/comp/desig.h index a7c1c736f..4b6bb97bb 100644 --- a/lang/m2/comp/desig.h +++ b/lang/m2/comp/desig.h @@ -1,7 +1,5 @@ /* 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. diff --git a/lang/m2/comp/enter.c b/lang/m2/comp/enter.c index 237ee29bb..85f1f7640 100644 --- a/lang/m2/comp/enter.c +++ b/lang/m2/comp/enter.c @@ -1,9 +1,5 @@ /* 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 @@ -119,7 +115,8 @@ EnterVarList(Idlist, type, local) 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; } @@ -155,8 +152,8 @@ node_error(idlist->nd_left,"Illegal type for address"); } EnterParamList(ppr, Idlist, type, VARp, off) - struct node *Idlist; struct paramlist **ppr; + struct node *Idlist; struct type *type; int VARp; arith *off; @@ -178,18 +175,14 @@ EnterParamList(ppr, Idlist, type, VARp, 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; @@ -259,11 +252,11 @@ ForwModule(df, idn) 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; } @@ -294,7 +287,6 @@ EnterExportList(Idlist, qualified) */ 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); @@ -302,13 +294,16 @@ EnterExportList(Idlist, qualified) 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; @@ -317,13 +312,13 @@ idlist->nd_IDF->id_text); 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 @@ -345,7 +340,9 @@ idlist->nd_IDF->id_text); 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; @@ -388,23 +385,23 @@ EnterFromImportList(Idlist, FromDef) 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); @@ -422,14 +419,14 @@ EnterImportList(Idlist, local) 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); } diff --git a/lang/m2/comp/error.c b/lang/m2/comp/error.c index 3c612e163..cde6d7c39 100644 --- a/lang/m2/comp/error.c +++ b/lang/m2/comp/error.c @@ -5,10 +5,6 @@ number of arguments! */ -#ifndef NORCSID -static char *RcsId = "$Header$"; -#endif - #include "errout.h" #include "debug.h" diff --git a/lang/m2/comp/expression.g b/lang/m2/comp/expression.g index 18a04cba1..bd2f8d646 100644 --- a/lang/m2/comp/expression.g +++ b/lang/m2/comp/expression.g @@ -1,10 +1,6 @@ /* E X P R E S S I O N S */ { -#ifndef NORCSID -static char *RcsId = "$Header$"; -#endif - #include "debug.h" #include @@ -38,22 +34,19 @@ qualident(int types; 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); @@ -62,9 +55,8 @@ 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; @@ -170,10 +162,9 @@ MulOperator: 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)? [ @@ -236,10 +227,8 @@ element(struct node *nd;) ; designator(struct node **pnd;) -{ - struct def *df; -} : - qualident(0, &df, (char *) 0, pnd) +: + qualident(0, (struct def **) 0, (char *) 0, pnd) designator_tail(pnd)? ; diff --git a/lang/m2/comp/f_info.h b/lang/m2/comp/f_info.h index edee620d0..7efbec727 100644 --- a/lang/m2/comp/f_info.h +++ b/lang/m2/comp/f_info.h @@ -1,7 +1,5 @@ /* 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; diff --git a/lang/m2/comp/idf.c b/lang/m2/comp/idf.c index 3f59640a7..6fc41b525 100644 --- a/lang/m2/comp/idf.c +++ b/lang/m2/comp/idf.c @@ -1,6 +1,4 @@ /* 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 diff --git a/lang/m2/comp/idf.h b/lang/m2/comp/idf.h index 60322ff4f..62e72bb57 100644 --- a/lang/m2/comp/idf.h +++ b/lang/m2/comp/idf.h @@ -1,7 +1,5 @@ /* 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; diff --git a/lang/m2/comp/input.c b/lang/m2/comp/input.c index 7dd53d9ba..acf29915a 100644 --- a/lang/m2/comp/input.c +++ b/lang/m2/comp/input.c @@ -1,17 +1,25 @@ /* 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 +#include +#include "def.h" +#include "idf.h" +#include "scope.h" #include +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; } diff --git a/lang/m2/comp/input.h b/lang/m2/comp/input.h index abb111c60..74ac774bd 100644 --- a/lang/m2/comp/input.h +++ b/lang/m2/comp/input.h @@ -1,7 +1,5 @@ /* 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 diff --git a/lang/m2/comp/lookup.c b/lang/m2/comp/lookup.c index a2785916d..7109e6a5a 100644 --- a/lang/m2/comp/lookup.c +++ b/lang/m2/comp/lookup.c @@ -1,9 +1,5 @@ /* 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 diff --git a/lang/m2/comp/main.c b/lang/m2/comp/main.c index 18d1ad6d3..2ac8c2e58 100644 --- a/lang/m2/comp/main.c +++ b/lang/m2/comp/main.c @@ -1,9 +1,5 @@ /* M A I N P R O G R A M */ -#ifndef NORCSID -static char *RcsId = "$Header$"; -#endif - #include "debug.h" #include "ndir.h" @@ -26,7 +22,6 @@ static char *RcsId = "$Header$"; int state; /* either IMPLEMENTATION or PROGRAM */ char options[128]; int DefinitionModule; -int SYSTEMModule; char *ProgName; char *DEFPATH[NDIRS+1]; struct def *Defined; @@ -73,7 +68,6 @@ Compile(src, dst) reserve(tkidf); InitScope(); InitTypes(); - InitDef(); AddStandards(); #ifdef DEBUG if (options['l']) { @@ -186,27 +180,29 @@ AddStandards() 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 diff --git a/lang/m2/comp/main.h b/lang/m2/comp/main.h index 642f7f5ea..906af4cbd 100644 --- a/lang/m2/comp/main.h +++ b/lang/m2/comp/main.h @@ -1,7 +1,5 @@ /* 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; @@ -9,9 +7,6 @@ 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 diff --git a/lang/m2/comp/make.allocd b/lang/m2/comp/make.allocd index 364ff9d35..ae2ae6f3c 100755 --- a/lang/m2/comp/make.allocd +++ b/lang/m2/comp/make.allocd @@ -1,25 +1,26 @@ 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))\ :' diff --git a/lang/m2/comp/misc.c b/lang/m2/comp/misc.c index d3f00bad6..573fd0356 100644 --- a/lang/m2/comp/misc.c +++ b/lang/m2/comp/misc.c @@ -1,9 +1,5 @@ /* 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 #include #include diff --git a/lang/m2/comp/misc.h b/lang/m2/comp/misc.h index 82a8ed5e6..5cf1ae8e5 100644 --- a/lang/m2/comp/misc.h +++ b/lang/m2/comp/misc.h @@ -1,7 +1,5 @@ /* 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 diff --git a/lang/m2/comp/node.H b/lang/m2/comp/node.H index 800069753..0bb5a28ba 100644 --- a/lang/m2/comp/node.H +++ b/lang/m2/comp/node.H @@ -1,7 +1,5 @@ /* 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 @@ -35,7 +33,7 @@ struct node { #define nd_REL nd_token.TOK_REL }; -/* ALLOCDEF "node" */ +/* ALLOCDEF "node" 50 */ extern struct node *MkNode(), *MkLeaf(); diff --git a/lang/m2/comp/node.c b/lang/m2/comp/node.c index 6f16617c8..1a5b33b95 100644 --- a/lang/m2/comp/node.c +++ b/lang/m2/comp/node.c @@ -1,9 +1,5 @@ /* 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 diff --git a/lang/m2/comp/options.c b/lang/m2/comp/options.c index 69931fe3a..c66341bda 100644 --- a/lang/m2/comp/options.c +++ b/lang/m2/comp/options.c @@ -1,9 +1,5 @@ /* 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" @@ -17,7 +13,7 @@ extern int idfsize; static int ndirs; DoOption(text) - char *text; + register char *text; { switch(*text++) { @@ -33,12 +29,15 @@ DoOption(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' : @@ -53,13 +52,16 @@ DoOption(text) 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) { @@ -104,7 +106,7 @@ DoOption(text) int txt2int(tp) - char **tp; + register char **tp; { /* the integer pointed to by *tp is read, while increasing *tp; the resulting value is yielded. diff --git a/lang/m2/comp/program.g b/lang/m2/comp/program.g index 993d53c35..b6a1d27ee 100644 --- a/lang/m2/comp/program.g +++ b/lang/m2/comp/program.g @@ -1,10 +1,6 @@ /* 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 @@ -42,14 +38,11 @@ static char *RcsId = "$Header$"; 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)* @@ -59,7 +52,7 @@ ModuleDeclaration 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); } ; @@ -104,7 +97,7 @@ import(int local;) df = lookfor(nd,enclosing(CurrVis),0); FreeNode(nd); } - else df = GetDefinitionModule(dot.TOK_IDF); + else df = GetDefinitionModule(dot.TOK_IDF, 1); } | { fromid = 0; } @@ -124,16 +117,13 @@ import(int local;) 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; @@ -154,15 +144,14 @@ node_warning(exportlist, "export list in definition module ignored"); /* 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); } '.' ; @@ -206,19 +195,17 @@ Semicolon: 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"; @@ -229,13 +216,15 @@ ProgramModule ';' 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; } diff --git a/lang/m2/comp/scope.C b/lang/m2/comp/scope.C index 23959a2f3..fda13e58d 100644 --- a/lang/m2/comp/scope.C +++ b/lang/m2/comp/scope.C @@ -1,9 +1,5 @@ /* 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 @@ -23,9 +19,9 @@ struct scopelist *CurrVis; extern int proclevel; static struct scopelist *PervVis; -/* STATICALLOCDEF "scope" */ +/* STATICALLOCDEF "scope" 10 */ -/* STATICALLOCDEF "scopelist" */ +/* STATICALLOCDEF "scopelist" 10 */ open_scope(scopetype) { @@ -36,15 +32,14 @@ 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; } @@ -71,7 +66,7 @@ struct forwards { struct type *fo_ptyp; }; -/* STATICALLOCDEF "forwards" */ +/* STATICALLOCDEF "forwards" 5 */ Forward(tk, ptp) struct node *tk; @@ -83,11 +78,12 @@ Forward(tk, ptp) 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 @@ -95,13 +91,14 @@ chk_proc(df) 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; @@ -110,46 +107,48 @@ error("procedure \"%s\" not defined", df->df_idf->id_text); 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; } } @@ -163,20 +162,17 @@ rem_forwards(fo) 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. @@ -188,23 +184,18 @@ Reverse(pdf) 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) diff --git a/lang/m2/comp/scope.h b/lang/m2/comp/scope.h index 9657870e3..770919c1a 100644 --- a/lang/m2/comp/scope.h +++ b/lang/m2/comp/scope.h @@ -1,7 +1,5 @@ /* 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) */ diff --git a/lang/m2/comp/standards.h b/lang/m2/comp/standards.h index 4c445b971..3f1bd60af 100644 --- a/lang/m2/comp/standards.h +++ b/lang/m2/comp/standards.h @@ -1,7 +1,5 @@ /* 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 diff --git a/lang/m2/comp/statement.g b/lang/m2/comp/statement.g index c04b36bd3..45dc3993d 100644 --- a/lang/m2/comp/statement.g +++ b/lang/m2/comp/statement.g @@ -1,10 +1,6 @@ /* S T A T E M E N T S */ { -#ifndef NORCSID -static char *RcsId = "$Header$"; -#endif - #include #include #include @@ -22,6 +18,7 @@ static int loopcount = 0; /* Count nested loops */ statement(register struct node **pnd;) { register struct node *nd; + extern int return_occurred; } : /* * This part is not in the reference grammar. The reference grammar @@ -64,6 +61,7 @@ statement(register struct node **pnd;) } | ReturnStatement(pnd) + { return_occurred = 1; } | /* empty */ { *pnd = 0; } ; @@ -88,9 +86,12 @@ StatementSequence(register struct node **pnd;) [ %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); } } ]* @@ -178,31 +179,29 @@ RepeatStatement(struct node **pnd;) 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 ; @@ -227,12 +226,9 @@ ReturnStatement(struct node **pnd;) { 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)) { diff --git a/lang/m2/comp/tmpvar.C b/lang/m2/comp/tmpvar.C index 0c5ade1ca..7e0cea211 100644 --- a/lang/m2/comp/tmpvar.C +++ b/lang/m2/comp/tmpvar.C @@ -1,9 +1,5 @@ /* 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 @@ -29,7 +25,7 @@ struct tmpvar { arith t_offset; /* offset from LocalBase */ }; -/* STATICALLOCDEF "tmpvar" */ +/* STATICALLOCDEF "tmpvar" 10 */ static struct tmpvar *TmpInts, /* for integer temporaries */ *TmpPtrs; /* for pointer temporaries */ @@ -47,7 +43,7 @@ TmpOpen(sc) struct scope *sc; arith NewInt() { - arith offset; + register arith offset; register struct tmpvar *tmp; if (!TmpInts) { @@ -67,7 +63,7 @@ NewInt() arith NewPtr() { - arith offset; + register arith offset; register struct tmpvar *tmp; if (!TmpPtrs) { diff --git a/lang/m2/comp/tokenname.c b/lang/m2/comp/tokenname.c index e6add6124..1e8dd3e33 100644 --- a/lang/m2/comp/tokenname.c +++ b/lang/m2/comp/tokenname.c @@ -1,9 +1,5 @@ /* 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" diff --git a/lang/m2/comp/tokenname.h b/lang/m2/comp/tokenname.h index 7838ae874..79ccdc4cd 100644 --- a/lang/m2/comp/tokenname.h +++ b/lang/m2/comp/tokenname.h @@ -1,7 +1,5 @@ /* 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 */ diff --git a/lang/m2/comp/type.H b/lang/m2/comp/type.H index 68dc16661..0e612f20e 100644 --- a/lang/m2/comp/type.H +++ b/lang/m2/comp/type.H @@ -1,7 +1,5 @@ /* 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 */ @@ -9,7 +7,7 @@ struct paramlist { /* structure for parameterlist of a PROCEDURE */ #define TypeOfParam(xpar) ((xpar)->par_def->df_type) }; -/* ALLOCDEF "paramlist" */ +/* ALLOCDEF "paramlist" 20 */ struct enume { struct def *en_enums; /* Definitions of enumeration literals */ @@ -86,7 +84,7 @@ struct type { } tp_value; }; -/* ALLOCDEF "type" */ +/* ALLOCDEF "type" 50 */ extern struct type *bool_type, @@ -125,11 +123,11 @@ extern arith 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) diff --git a/lang/m2/comp/type.c b/lang/m2/comp/type.c index 41727ea76..9fc4435cf 100644 --- a/lang/m2/comp/type.c +++ b/lang/m2/comp/type.c @@ -1,9 +1,5 @@ /* 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" @@ -66,21 +62,6 @@ struct type *h_type; 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; @@ -89,9 +70,9 @@ construct_type(fund, tp) /* 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: @@ -135,8 +116,9 @@ standard_type(fund, align, size) 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; @@ -167,10 +149,6 @@ InitTypes() 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); @@ -303,6 +281,19 @@ subr_type(lb, ub) 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; { @@ -310,20 +301,22 @@ genrck(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); @@ -385,7 +378,7 @@ ArrayElSize(tp) 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); @@ -446,6 +439,7 @@ FreeType(tp) while (pr) { pr1 = pr; pr = pr->next; + free_def(pr1->par_def); free_paramlist(pr1); } @@ -520,21 +514,14 @@ DumpType(tp) { 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: @@ -562,7 +549,7 @@ DumpType(tp) print("PROCEDURE"); if (par) { - print("; p:"); + print("("); while(par) { if (IsVarParam(par)) print("VAR "); DumpType(TypeOfParam(par)); @@ -573,11 +560,12 @@ DumpType(tp) } 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: @@ -585,6 +573,13 @@ DumpType(tp) default: crash("DumpType"); } + if (tp->next && tp->tp_fund != T_POINTER) { + /* Avoid printing recursive types! + */ + print(" next:("); + DumpType(tp->next); + print(")"); + } print(";"); } #endif diff --git a/lang/m2/comp/typequiv.c b/lang/m2/comp/typequiv.c index 422638c8e..0f4e8c3c4 100644 --- a/lang/m2/comp/typequiv.c +++ b/lang/m2/comp/typequiv.c @@ -1,9 +1,5 @@ /* 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 */ diff --git a/lang/m2/comp/walk.c b/lang/m2/comp/walk.c index 098744dfe..2679b5370 100644 --- a/lang/m2/comp/walk.c +++ b/lang/m2/comp/walk.c @@ -1,9 +1,5 @@ /* 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. */ @@ -103,11 +99,6 @@ WalkModule(module) 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) { @@ -415,17 +406,16 @@ WalkStat(nd, exit_label) 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); @@ -440,73 +430,72 @@ WalkStat(nd, 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); } @@ -517,7 +506,6 @@ WalkStat(nd, exit_label) 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) { @@ -532,7 +520,7 @@ WalkStat(nd, exit_label) 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; @@ -544,7 +532,7 @@ WalkStat(nd, exit_label) WalkNode(right, exit_label); CurrVis = link.next; WithDesigs = wds.w_next; - FreePtr(tmp); + FreePtr(ds.dsg_offset); break; } @@ -648,12 +636,13 @@ DoForInit(nd, left) 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; } @@ -665,14 +654,15 @@ DoForInit(nd, left) 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 || @@ -691,8 +681,6 @@ DoForInit(nd, left) node_warning(nd, "old-fashioned! compatibility required in FOR statement"); } - CodePExpr(left->nd_left); - return 1; } @@ -703,11 +691,12 @@ DoAssign(nd, left, right) /* 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); diff --git a/lang/m2/comp/walk.h b/lang/m2/comp/walk.h index 439f2c2a7..4222dbeb5 100644 --- a/lang/m2/comp/walk.h +++ b/lang/m2/comp/walk.h @@ -1,7 +1,5 @@ /* P A R S E T R E E W A L K E R */ -/* $Header$ */ - /* Definition of WalkNode macro */ -- 2.34.1