From a94dec52d82f8bc374570ec38ce3ce9647ef13db Mon Sep 17 00:00:00 2001 From: ceriel Date: Wed, 3 May 1989 10:30:22 +0000 Subject: [PATCH] Many improvements by Hans van Eck --- lang/pc/comp/.distr | 2 + lang/pc/comp/LLlex.c | 192 +++++++++++++++++++++++++-- lang/pc/comp/LLlex.h | 1 + lang/pc/comp/LLmessage.c | 8 +- lang/pc/comp/Makefile | 211 ++++++++++++++++++++++------- lang/pc/comp/Parameters | 18 ++- lang/pc/comp/Resolve | 60 +++++++++ lang/pc/comp/Version.c | 1 + lang/pc/comp/body.c | 156 +++++++++++++++++++--- lang/pc/comp/casestat.C | 1 + lang/pc/comp/chk_expr.c | 272 ++++++++++++++++++++++++++++++-------- lang/pc/comp/code.c | 173 +++++++++++++++++++++--- lang/pc/comp/cstoper.c | 59 ++++++++- lang/pc/comp/declar.g | 148 ++++++++++++++------- lang/pc/comp/def.H | 75 +++++++---- lang/pc/comp/def.c | 79 ++++++++++- lang/pc/comp/desig.c | 19 ++- lang/pc/comp/em_pc.6 | 54 +++++--- lang/pc/comp/enter.c | 37 ++++-- lang/pc/comp/error.c | 22 ++- lang/pc/comp/expression.g | 12 +- lang/pc/comp/label.c | 7 +- lang/pc/comp/lookup.c | 64 +++++++-- lang/pc/comp/main.c | 46 ++++++- lang/pc/comp/misc.h | 9 ++ lang/pc/comp/nmclash.c | 4 + lang/pc/comp/node.H | 2 + lang/pc/comp/options.c | 30 +++-- lang/pc/comp/program.g | 13 ++ lang/pc/comp/progs.c | 39 ++++-- lang/pc/comp/readwrite.c | 77 +++++++++-- lang/pc/comp/required.h | 43 +++--- lang/pc/comp/scope.c | 2 +- lang/pc/comp/statement.g | 19 ++- lang/pc/comp/type.H | 35 ++++- lang/pc/comp/type.c | 117 +++++++++++++--- lang/pc/comp/typequiv.c | 17 ++- 37 files changed, 1743 insertions(+), 381 deletions(-) create mode 100755 lang/pc/comp/Resolve create mode 100644 lang/pc/comp/Version.c create mode 100644 lang/pc/comp/nmclash.c diff --git a/lang/pc/comp/.distr b/lang/pc/comp/.distr index 8d8e03622..181d571a7 100644 --- a/lang/pc/comp/.distr +++ b/lang/pc/comp/.distr @@ -3,6 +3,7 @@ LLlex.h LLmessage.c Makefile Parameters +Resolve body.c casestat.C char.tab @@ -38,6 +39,7 @@ make.tokcase make.tokfile misc.c misc.h +nmclash.c node.H node.c options.c diff --git a/lang/pc/comp/LLlex.c b/lang/pc/comp/LLlex.c index f8b29f289..123e2ce44 100644 --- a/lang/pc/comp/LLlex.c +++ b/lang/pc/comp/LLlex.c @@ -36,6 +36,89 @@ struct type *toktype, *asidetype; static int eofseen; +extern int in_compound; + +int tokenseen = 0; /* Some comment-options must precede any program text */ + +/* Warning: The options specified inside comments take precedence over + * the ones on the command line. + */ +CommentOptions() +{ + register int ch, ci; + /* Parse options inside comments */ + + do { + LoadChar(ch); + ci = ch; + switch ( ci ) { + case 'c': /* for strings */ + case 'd': /* for longs */ + case 's': /* check for standard */ + case 'u': /* for underscores */ + case 'C': /* for different cases */ + case 'U': /* for underscores */ + if( tokenseen ) { + lexwarning("the '%c' option must precede any program text", ci); + break; + } + + LoadChar(ch); + if( ci == 's' && options[ci] && ch == '-') + lexwarning("option '%c-' overrides previous one", ci); + if( ch == '-' ) options[ci] = 0; + else if( ch == '+' ) options[ci] = 1; + else PushBack(); + break; + + case 'l': ci = 'L' ; /* for indexing */ + /* fall through */ + case 'a': /* assertions */ + case 't': /* tracing */ + case 'A': /* extra array range-checks */ + case 'L': /* FIL & LIN instructions */ + case 'R': /* range checks */ + { + int on_on_minus = (ci == 'L' || ci == 'R'); + + LoadChar(ch); + if( ch == '-' ) options[ci] = on_on_minus; + else if( ch == '+' ) options[ci] = !on_on_minus; + else PushBack(); + break; + } + + case 'i': + { + register int i=0; + + LoadChar(ch); + while( ch >= '0' && ch <= '9' ) { + i = 10 * i + (ch - '0'); + LoadChar(ch); + } + PushBack(); + if( tokenseen ) { + lexwarning("the '%c' option must precede any program text", ci); + break; + } + if( i <= 0 ) { + lexwarning("bad '%c' option", ci); + break; + } + max_intset = i; + break; + } + + default: + break; + } + LoadChar(ch); + } while (ch == ',' ); + + PushBack(); +} + STATIC SkipComment() @@ -48,6 +131,7 @@ SkipComment() register int ch; LoadChar(ch); + if (ch == '$') CommentOptions(); for (;;) { if( class(ch) == STNL ) { LineNumber++; @@ -70,9 +154,10 @@ SkipComment() } STATIC struct string * -GetString() +GetString( delim ) +register int delim; { - /* Read a Pascal string, delimited by the character "'". + /* Read a Pascal string, delimited by the character ' or ". */ register int ch; register struct string *str = (struct string *) @@ -83,9 +168,10 @@ GetString() str->s_str = p = Malloc((unsigned int) ISTRSIZE); for( ; ; ) { LoadChar(ch); - if( ch & 0200 ) + if( ch & 0200 ) { fatal("non-ascii '\\%03o' read", ch & 0377); /*NOTREACHED*/ + } if( class(ch) == STNL ) { lexerror("newline in string"); LineNumber++; @@ -98,9 +184,9 @@ GetString() lexerror("end-of-file in string"); break; } - if( ch == '\'' ) { + if( ch == delim ) { LoadChar(ch); - if( ch != '\'' ) + if( ch != delim ) break; } *p++ = ch; @@ -128,6 +214,71 @@ GetString() return str; } +static char *s_error = "illegal line directive"; + +CheckForLineDirective() +{ + register int ch; + register int i = 0; + char buf[IDFSIZE + 2]; + register char *c = buf; + + LoadChar(ch); + + if( ch != '#' ) { + PushBack(); + return; + } + do { /* + * Skip to next digit. Do not skip newlines. + */ + LoadChar(ch); + if( class(ch) == STNL ) { + LineNumber++; + lexerror(s_error); + return; + } + else if( ch == EOI ) { + eofseen = 1; + break; + } + } while( class(ch) != STNUM ); + while( class(ch) == STNUM ) { + i = i * 10 + (ch - '0'); + LoadChar(ch); + } + if( ch == EOI ) { + eofseen = 1; + } + while( ch != '"' && ch != EOI && class(ch) != STNL) LoadChar(ch); + if( ch == '"' ) { + do { + LoadChar(ch); + *c++ = ch; + if( class(ch) == STNL ) { + LineNumber++; + error(s_error); + return; + } + } while( ch != '"' ); + *--c = '\0'; + do { + LoadChar(ch); + } while( class(ch) != STNL ); + /* + * Remember the filename + */ + if( !eofseen && strcmp(FileName, buf) ) { + FileName = Salloc(buf,(unsigned) strlen(buf) + 1); + } + } + if( eofseen ) { + error(s_error); + return; + } + LineNumber = i; +} + int LLlex() { @@ -148,6 +299,7 @@ LLlex() tk->tk_lineno = LineNumber; +again1: if( eofseen ) { eofseen = 0; ch = EOI; @@ -158,9 +310,10 @@ again: if( !options['C'] ) /* -C : cases are different */ TO_LOWER(ch); - if( (ch & 0200) && ch != EOI ) + if( (ch & 0200) && ch != EOI ) { fatal("non-ascii '\\%03o' read", ch & 0377); /*NOTREACHED*/ + } } switch( class(ch) ) { @@ -171,12 +324,16 @@ again: #ifdef DEBUG cntlines++; #endif - goto again; + CheckForLineDirective(); + goto again1; case STSKIP: goto again; case STGARB: + if( !tokenseen && (ch == '"' || ch == '_') ) { + return tk->tk_symb = ch; + } if( (unsigned) ch < 0177 ) lexerror("garbage char %c", ch); else @@ -189,7 +346,7 @@ again: if( nch == '*' ) { /* (* */ SkipComment(); tk->tk_lineno = LineNumber; - goto again; + goto again1; } if( nch == '.' ) /* (. is [ */ return tk->tk_symb = '['; @@ -199,7 +356,7 @@ again: else if( ch == '{' ) { SkipComment(); tk->tk_lineno = LineNumber; - goto again; + goto again1; } else if( ch == '@' ) ch = '^'; /* @ is ^ */ @@ -259,14 +416,15 @@ again: if( ch == EOI ) eofseen = 1; else PushBack(); + if( buf[0] == '_' ) lexerror("underscore starts identifier"); tk->TOK_IDF = id = str2idf(buf, 1); return tk->tk_symb = id->id_reserved ? id->id_reserved : IDENT; } case STSTR: { - register struct string *str = GetString(); + register struct string *str = GetString(ch); - if( str->s_length == 1 ) { + if( str->s_length == 1 && ch == '\'') { #ifdef DEBUG if( options['l'] ) { /* to prevent LexScan from crashing */ @@ -280,8 +438,14 @@ again: free((char *) str); } else { - tk->tk_data.tk_str = str; - toktype = standard_type(T_STRING, 1, str->s_length); + if( ch == '\'' ) { + tk->tk_data.tk_str = str; + toktype = standard_type(T_STRINGCONST, 1, str->s_length); + } + else { + tk->tk_data.tk_str = str; + toktype = string_type; + } } return tk->tk_symb = STRING; } @@ -391,7 +555,7 @@ again: tk->TOK_REL = Salloc("0.0", 4); lexerror("floating constant too long"); } - else tk->TOK_REL = Salloc(buf, np - buf); + else tk->TOK_REL = Salloc(buf,(unsigned) (np - buf)); toktype = real_type; return tk->tk_symb = REAL; diff --git a/lang/pc/comp/LLlex.h b/lang/pc/comp/LLlex.h index adc50fa9b..dfe82097b 100644 --- a/lang/pc/comp/LLlex.h +++ b/lang/pc/comp/LLlex.h @@ -45,5 +45,6 @@ struct token { extern struct token dot, aside; extern struct type *toktype, *asidetype; +extern int tokenseen; #define ASIDE aside.tk_symb diff --git a/lang/pc/comp/LLmessage.c b/lang/pc/comp/LLmessage.c index 79636a95b..efab3e2cd 100644 --- a/lang/pc/comp/LLmessage.c +++ b/lang/pc/comp/LLmessage.c @@ -18,6 +18,7 @@ extern char *symbol2str(); extern char *Malloc(), *Salloc(); extern struct idf *gen_anon_idf(); +extern int expect_label; LLmessage(tk) register int tk; @@ -44,11 +45,14 @@ LLmessage(tk) Malloc(sizeof (struct string)); dotp->TOK_SLE = 1; dotp->TOK_STR = Salloc("", 1); - toktype = standard_type(T_STRING, 1, (arith) 1); + toktype = standard_type(T_STRINGCONST, 1, (arith) 1); break; case INTEGER: - dotp->TOK_INT = 1; toktype = int_type; + if( !expect_label ) + dotp->TOK_INT = 1; + else + dotp->TOK_INT = -1; break; case REAL: dotp->tk_data.tk_real = (struct real *) diff --git a/lang/pc/comp/Makefile b/lang/pc/comp/Makefile index 656d9d699..4fde90fda 100644 --- a/lang/pc/comp/Makefile +++ b/lang/pc/comp/Makefile @@ -1,24 +1,33 @@ # make iso-pascal "compiler" EMHOME = ../../.. -MHDIR = $(EMHOME)/modules/h -PKGDIR = $(EMHOME)/modules/pkg -LIBDIR = $(EMHOME)/modules/lib -OBJECTCODE = $(LIBDIR)/libemk.a $(EMHOME)/lib/em_data.a +MDIR = $(EMHOME)/modules +MHDIR = $(MDIR)/h +PKGDIR = $(MDIR)/pkg +LIBDIR = $(MDIR)/lib +OBJECTCODE = $(LIBDIR)/libemk.a LLGEN = $(EMHOME)/bin/LLgen MKDEP = $(EMHOME)/bin/mkdep -CURRDIR = . +PRID = $(EMHOME)/bin/prid +CID = $(EMHOME)/bin/cid +CURRDIR = CC = fcc +CC = cc PRINTER = vu45 +LINT = lint INCLUDES = -I$(MHDIR) -I$(EMHOME)/h -I$(PKGDIR) +OLIBS = $(LIBDIR)/libem_mes.a $(OBJECTCODE) $(LIBDIR)/libinput.a $(LIBDIR)/libassert.a $(LIBDIR)/liballoc.a $(MALLOC) $(LIBDIR)/libprint.a $(LIBDIR)/libstring.a $(LIBDIR)/libsystem.a + GFILES = tokenfile.g declar.g expression.g program.g statement.g LLGENOPTIONS = PROFILE = -CFLAGS = $(PROFILE) $(INCLUDES) -DSTATIC= -LINTFLAGS = -DSTATIC= +COPTIONS = +OPTIM= -O +CFLAGS = $(PROFILE) $(INCLUDES) $(OPTIM) $(COPTIONS) -DSTATIC= +LINTFLAGS = -DSTATIC= -DNORCSID MALLOC = $(LIBDIR)/malloc.o -LFLAGS = $(PROFILE) +LDFLAGS = -i $(PROFILE) LSRC = declar.c expression.c program.c statement.c tokenfile.c LOBJ = declar.o expression.o program.o statement.o tokenfile.o CSRC = LLlex.c LLmessage.c body.c chk_expr.c code.c\ @@ -32,13 +41,12 @@ COBJ = LLlex.o LLmessage.o body.o casestat.o char.o chk_expr.o code.o\ OBJ = Lpars.o $(COBJ) $(LOBJ) # Keep the next entries up to date! -GENCFILES= Lpars.c declar.c expression.c program.c statement.c\ - tokenfile.c symbol2str.c casestat.c tmpvar.c char.c next.c -SRC = Lpars.c $(CSRC) $(GENCFILES) +GENCFILES= $(LSRC) Lpars.c symbol2str.c casestat.c tmpvar.c char.c next.c +SRC = $(CSRC) $(GENCFILES) GENGFILES= tokenfile.g GENHFILES= Lpars.h debugcst.h density.h errout.h idfsize.h inputtype.h\ numsize.h strsize.h def.h type.h desig.h scope.h node.h\ - target_sizes.h + target_sizes.h nocross.h HFILES= LLlex.h chk_expr.h class.h const.h debug.h def.h desig.h\ f_info.h idf.h input.h main.h misc.h node.h required.h scope.h\ tokenname.h type.h $(GENHFILES) @@ -49,27 +57,58 @@ NEXTFILES = def.H desig.H node.H scope.H type.H casestat.C tmpvar.C #EXCLEXCLEXCLEXCL all: Cfiles - make $(CURRDIR)/main + sh -c 'if $(CC) nmclash.c > /dev/null 2>&1 ; then make "EMHOME="$(EMHOME) $(CURRDIR)main ; else EMHOME=$(EMHOME); export EMHOME; sh Resolve main ; fi' + @rm -f nmclash.o a.out + +Omain: Cfiles + rm -f *.o + sh -c 'if $(CC) nmclash.c > /dev/null 2>&1 ; then make "EMHOME="$(EMHOME) "COPTIONS="-DPEEPHOLE $(CURRDIR)omain ; else EMHOME=$(EMHOME); export EMHOME; ./Resolve omain ; fi' + @rm -f nmclash.o a.out + mv *.o PEEPHOLE + +CEmain: Cfiles + rm -f *.o + sh -c 'if $(CC) nmclash.c > /dev/null 2>&1 ; then make "EMHOME="$(EMHOME) "COPTIONS="-DCODE_EXPANDER $(CURRDIR)cemain ; else EMHOME=$(EMHOME); export EMHOME; ./Resolve cemain ; fi' + @rm -f nmclash.o a.out + mv *.o CODE_EXPANDER + +install: all + cp $(CURRDIR)main $(EMHOME)/lib/em_pc + +cmp: all + -cmp $(CURRDIR)main $(EMHOME)/lib/em_pc + +opr: + make pr | opr + +pr: + @pr Makefile Resolve Parameters $(GFILES) *.H $(HFILES) *.C $(CSRC) clean: - rm -f *.o main $(GENFILES) hfiles Cfiles LLfiles + rm -f $(OBJ) $(CURRDIR)main $(GENFILES) hfiles Cfiles LLfiles clashes \ + LL.output + (cd .. ; rm -rf Xsrc) + +lint: Cfiles + sh -c 'if $(CC) nmclash.c > /dev/null 2>&1 ; then make "EMHOME="$(EMHOME) Xlint ; else EMHOME=$(EMHOME); export EMHOME; sh Resolve Xlint ; fi' + @rm -f nmclash.o a.out + +longnames: $(SRC) $(HFILES) + sh -c 'if test -f longnames ; then $(PRID) -l7 longnames $? > Xlongnames ; mv Xlongnames longnames ; else $(PRID) -l7 $? > longnames ; fi' # entry points not to be used directly -Cfiles: hfiles LLfiles $(GENCFILES) $(GENHFILES) Makefile +Cfiles: hfiles LLfiles $(GENCFILES) $(GENHFILES) Makefile echo $(SRC) $(HFILES) > Cfiles LLfiles: $(GFILES) $(LLGEN) $(LLGENOPTIONS) $(GFILES) @touch LLfiles -hfiles: Parameters make.hfiles +hfiles: Parameters make.hfiles make.hfiles Parameters touch hfiles -lint: Cfiles - lint $(INCLUDES) $(LINTFLAGS) $(SRC) - tokenfile.g: tokenname.c make.tokfile make.tokfile < tokenname.c > tokenfile.g @@ -95,10 +134,10 @@ tmpvar.c: make.allocd next.c: $(NEXTFILES) ./make.next ./make.next $(NEXTFILES) > next.c -char.c: char.tab +char.c: char.tab $(EMHOME)/bin/tabgen -fchar.tab > char.c -depend: +depend: Cfiles sed '/^#AUTOAUTO/,$$d' Makefile > Makefile.new echo '#AUTOAUTOAUTOAUTOAUTOAUTOAUTOAUTO' >> Makefile.new $(MKDEP) $(SRC) |\ @@ -110,19 +149,37 @@ print: $(CSRC) $(GFILES) $(HFILES) # print recently changed files pr -t $? | rpr $(PRINTER) @touch print -xref: +xref: ctags -x $(CSRC) $(HFILES) | sed "s/).*/)/">Xref #INCLINCLINCLINCL -$(CURRDIR)/main: $(OBJ) - -mv main main.old - $(CC) $(LFLAGS) $(OBJ) $(LIBDIR)/libem_mes.a $(OBJECTCODE) $(LIBDIR)/libinput.a $(LIBDIR)/liballoc.a $(MALLOC) $(LIBDIR)/libassert.a $(LIBDIR)/libprint.a $(LIBDIR)/libstring.a $(LIBDIR)/libsystem.a -o $(CURRDIR)/main - size $(CURRDIR)/main.old - size $(CURRDIR)/main +Xlint: + $(LINT) $(INCLUDES) $(LINTFLAGS) $(SRC) \ + $(LIBDIR)/llib-lem_mes.ln \ + $(LIBDIR)/llib-lemk.ln \ + $(LIBDIR)/llib-linput.ln \ + $(LIBDIR)/llib-lassert.ln \ + $(LIBDIR)/llib-lalloc.ln \ + $(LIBDIR)/llib-lprint.ln \ + $(LIBDIR)/llib-lstring.ln \ + $(LIBDIR)/llib-lsystem.ln + +$(CURRDIR)main: $(OBJ) $(CURRDIR)Makefile + -mv $(CURRDIR)main $(CURRDIR)main.old + $(CC) $(LDFLAGS) $(OBJ) $(OLIBS) -o $(CURRDIR)main + size $(CURRDIR)main.old + size $(CURRDIR)main + +$(CURRDIR)omain: $(OBJ) #$(CURRDIR)Makefile +# #$(CC) $(LDFLAGS) $(OBJ) $(OLIBS) -o $(CURRDIR)omain +# #size $(CURRDIR)omain + +$(CURRDIR)cemain: $(OBJ) #$(CURRDIR)Makefile +# #$(CC) $(LDFLAGS) $(OBJ) $(OLIBS) -o $(CURRDIR)cemain +# # #size $(CURRDIR)cemain #AUTOAUTOAUTOAUTOAUTOAUTOAUTOAUTO -Lpars.o: Lpars.h LLlex.o: LLlex.h LLlex.o: Lpars.h LLlex.o: class.h @@ -135,12 +192,16 @@ LLlex.o: idfsize.h LLlex.o: input.h LLlex.o: inputtype.h LLlex.o: main.h +LLlex.o: nocross.h LLlex.o: numsize.h LLlex.o: strsize.h +LLlex.o: target_sizes.h LLlex.o: type.h LLmessage.o: LLlex.h LLmessage.o: Lpars.h LLmessage.o: idf.h +LLmessage.o: nocross.h +LLmessage.o: target_sizes.h LLmessage.o: type.h body.o: LLlex.h body.o: chk_expr.h @@ -150,19 +211,12 @@ body.o: def.h body.o: desig.h body.o: idf.h body.o: main.h +body.o: misc.h +body.o: nocross.h body.o: node.h body.o: scope.h +body.o: target_sizes.h body.o: type.h -casestat.o: LLlex.h -casestat.o: Lpars.h -casestat.o: chk_expr.h -casestat.o: debug.h -casestat.o: debugcst.h -casestat.o: density.h -casestat.o: main.h -casestat.o: node.h -casestat.o: type.h -char.o: class.h chk_expr.o: LLlex.h chk_expr.o: Lpars.h chk_expr.o: chk_expr.h @@ -173,9 +227,11 @@ chk_expr.o: def.h chk_expr.o: idf.h chk_expr.o: main.h chk_expr.o: misc.h +chk_expr.o: nocross.h chk_expr.o: node.h chk_expr.o: required.h chk_expr.o: scope.h +chk_expr.o: target_sizes.h chk_expr.o: type.h code.o: LLlex.h code.o: Lpars.h @@ -184,15 +240,19 @@ code.o: debugcst.h code.o: def.h code.o: desig.h code.o: main.h +code.o: misc.h +code.o: nocross.h code.o: node.h code.o: required.h code.o: scope.h +code.o: target_sizes.h code.o: type.h cstoper.o: LLlex.h cstoper.o: Lpars.h cstoper.o: const.h cstoper.o: debug.h cstoper.o: debugcst.h +cstoper.o: nocross.h cstoper.o: node.h cstoper.o: required.h cstoper.o: target_sizes.h @@ -204,24 +264,31 @@ def.o: def.h def.o: idf.h def.o: main.h def.o: misc.h +def.o: nocross.h def.o: node.h def.o: scope.h +def.o: target_sizes.h def.o: type.h desig.o: LLlex.h desig.o: debug.h desig.o: debugcst.h desig.o: def.h desig.o: desig.h +desig.o: idf.h desig.o: main.h +desig.o: nocross.h desig.o: node.h desig.o: scope.h +desig.o: target_sizes.h desig.o: type.h enter.o: LLlex.h enter.o: def.h enter.o: idf.h enter.o: main.h +enter.o: nocross.h enter.o: node.h enter.o: scope.h +enter.o: target_sizes.h enter.o: type.h error.o: LLlex.h error.o: debug.h @@ -241,18 +308,23 @@ label.o: LLlex.h label.o: def.h label.o: idf.h label.o: main.h +label.o: nocross.h label.o: node.h label.o: scope.h +label.o: target_sizes.h label.o: type.h lookup.o: LLlex.h lookup.o: def.h lookup.o: idf.h lookup.o: misc.h +lookup.o: nocross.h lookup.o: node.h lookup.o: scope.h +lookup.o: target_sizes.h lookup.o: type.h main.o: LLlex.h main.o: Lpars.h +main.o: class.h main.o: const.h main.o: debug.h main.o: debugcst.h @@ -262,8 +334,10 @@ main.o: idf.h main.o: input.h main.o: inputtype.h main.o: main.h +main.o: nocross.h main.o: node.h main.o: required.h +main.o: target_sizes.h main.o: tokenname.h main.o: type.h misc.o: LLlex.h @@ -272,25 +346,31 @@ misc.o: idf.h misc.o: main.h misc.o: misc.h misc.o: node.h -next.o: debug.h -next.o: debugcst.h node.o: LLlex.h node.o: debug.h node.o: debugcst.h +node.o: nocross.h node.o: node.h +node.o: target_sizes.h node.o: type.h options.o: class.h options.o: const.h options.o: idfsize.h options.o: main.h +options.o: nocross.h +options.o: target_sizes.h options.o: type.h readwrite.o: LLlex.h readwrite.o: debug.h readwrite.o: debugcst.h readwrite.o: def.h +readwrite.o: idf.h readwrite.o: main.h +readwrite.o: misc.h +readwrite.o: nocross.h readwrite.o: node.h readwrite.o: scope.h +readwrite.o: target_sizes.h readwrite.o: type.h scope.o: LLlex.h scope.o: debug.h @@ -298,16 +378,12 @@ scope.o: debugcst.h scope.o: def.h scope.o: idf.h scope.o: misc.h +scope.o: nocross.h scope.o: node.h scope.o: scope.h +scope.o: target_sizes.h scope.o: type.h symbol2str.o: Lpars.h -tmpvar.o: debug.h -tmpvar.o: debugcst.h -tmpvar.o: def.h -tmpvar.o: main.h -tmpvar.o: scope.h -tmpvar.o: type.h tokenname.o: Lpars.h tokenname.o: idf.h tokenname.o: tokenname.h @@ -318,6 +394,7 @@ type.o: debugcst.h type.o: def.h type.o: idf.h type.o: main.h +type.o: nocross.h type.o: node.h type.o: scope.h type.o: target_sizes.h @@ -326,24 +403,32 @@ typequiv.o: LLlex.h typequiv.o: debug.h typequiv.o: debugcst.h typequiv.o: def.h +typequiv.o: nocross.h typequiv.o: node.h +typequiv.o: target_sizes.h typequiv.o: type.h progs.o: LLlex.h progs.o: debug.h progs.o: debugcst.h progs.o: def.h progs.o: main.h +progs.o: nocross.h progs.o: scope.h +progs.o: target_sizes.h progs.o: type.h declar.o: LLlex.h declar.o: Lpars.h declar.o: chk_expr.h +declar.o: debug.h +declar.o: debugcst.h declar.o: def.h declar.o: idf.h declar.o: main.h declar.o: misc.h +declar.o: nocross.h declar.o: node.h declar.o: scope.h +declar.o: target_sizes.h declar.o: type.h expression.o: LLlex.h expression.o: Lpars.h @@ -351,13 +436,19 @@ expression.o: chk_expr.h expression.o: debug.h expression.o: debugcst.h expression.o: def.h +expression.o: idf.h expression.o: main.h +expression.o: misc.h +expression.o: nocross.h expression.o: node.h expression.o: scope.h +expression.o: target_sizes.h expression.o: type.h program.o: LLlex.h program.o: Lpars.h program.o: def.h +program.o: f_info.h +program.o: idf.h program.o: main.h program.o: node.h program.o: scope.h @@ -366,9 +457,37 @@ statement.o: Lpars.h statement.o: chk_expr.h statement.o: def.h statement.o: desig.h +statement.o: f_info.h statement.o: idf.h statement.o: main.h +statement.o: misc.h +statement.o: nocross.h statement.o: node.h statement.o: scope.h +statement.o: target_sizes.h statement.o: type.h tokenfile.o: Lpars.h +Lpars.o: Lpars.h +symbol2str.o: Lpars.h +casestat.o: LLlex.h +casestat.o: Lpars.h +casestat.o: chk_expr.h +casestat.o: debug.h +casestat.o: debugcst.h +casestat.o: density.h +casestat.o: main.h +casestat.o: nocross.h +casestat.o: node.h +casestat.o: target_sizes.h +casestat.o: type.h +tmpvar.o: debug.h +tmpvar.o: debugcst.h +tmpvar.o: def.h +tmpvar.o: main.h +tmpvar.o: nocross.h +tmpvar.o: scope.h +tmpvar.o: target_sizes.h +tmpvar.o: type.h +char.o: class.h +next.o: debug.h +next.o: debugcst.h diff --git a/lang/pc/comp/Parameters b/lang/pc/comp/Parameters index 7dc87b376..ef4bc8db1 100644 --- a/lang/pc/comp/Parameters +++ b/lang/pc/comp/Parameters @@ -1,5 +1,5 @@ !File: debugcst.h -#define DEBUG 1 /* perform various self-tests */ +#undef DEBUG 1 /* perform various self-tests */ !File: density.h @@ -39,13 +39,19 @@ #define SZ_CHAR (arith)1 #define SZ_WORD (arith)4 #define SZ_INT (arith)4 +#define SZ_LONG (arith)4 #define SZ_POINTER (arith)4 #define SZ_REAL (arith)8 /* target machine alignment requirements */ #define AL_CHAR 1 -#define AL_WORD (int)SZ_WORD -#define AL_INT (int)SZ_WORD -#define AL_POINTER (int)SZ_WORD -#define AL_REAL (int)SZ_WORD -#define AL_STRUCT 1 +#define AL_WORD ((int)SZ_WORD) +#define AL_INT ((int)SZ_WORD) +#define AL_LONG ((int)SZ_WORD) +#define AL_POINTER ((int)SZ_WORD) +#define AL_REAL ((int)SZ_WORD) +#define AL_STRUCT ((int)SZ_WORD) + + +!File: nocross.h +#undef NOCROSS 1 /* define when cross compiler not needed */ diff --git a/lang/pc/comp/Resolve b/lang/pc/comp/Resolve new file mode 100755 index 000000000..a551de292 --- /dev/null +++ b/lang/pc/comp/Resolve @@ -0,0 +1,60 @@ +: create a directory Xsrc with name clashes resolved +: and run make in that directory + +case $# in +1) + ;; +*) echo "$0: one argument expected" 1>&2 + exit 1 + ;; +esac +currdir=`pwd` +case $1 in +main) target=$currdir/$1 + ;; +omain) target=$currdir/$1 + options=-DPEEPHOLE + ;; +cemain) target=$currdir/$1 + options=-DCODE_EXPANDER + ;; +Xlint) target=$1 + ;; +*) echo "$0: $1: Illegal argument" 1>&2 + exit 1 + ;; +esac +if test -d ../Xsrc +then + : +else mkdir ../Xsrc +fi +make EMHOME=$EMHOME longnames +: remove code generating routines from the clashes list as they are defines. +: code generating routine names start with C_ +sed '/^C_/d' < longnames > tmp$$ +cclash -c -l7 tmp$$ > ../Xsrc/Xclashes +rm -f tmp$$ +PW=`pwd` +cd ../Xsrc +if cmp -s Xclashes clashes +then + : +else + mv Xclashes clashes +fi +rm -f Makefile +ed - $PW/Makefile <<'EOF' +/^#EXCLEXCL/,/^#INCLINCL/d +w Makefile +q +EOF +for i in `cat $PW/Cfiles` +do + cat >> Makefile < $i +EOF +done +make EMHOME=$EMHOME CURRDIR=$currdir/ COPTIONS=$options $target diff --git a/lang/pc/comp/Version.c b/lang/pc/comp/Version.c new file mode 100644 index 000000000..42ba0f21c --- /dev/null +++ b/lang/pc/comp/Version.c @@ -0,0 +1 @@ +static char Version[] = "ACK Pascal compiler Version 2.2"; diff --git a/lang/pc/comp/body.c b/lang/pc/comp/body.c index 486e4bf11..bb102f369 100644 --- a/lang/pc/comp/body.c +++ b/lang/pc/comp/body.c @@ -10,28 +10,100 @@ #include "desig.h" #include "idf.h" #include "main.h" +#include "misc.h" #include "node.h" #include "scope.h" #include "type.h" +MarkDef(nd, flags, on) + register struct node *nd; + unsigned short flags; +{ + while( nd && nd->nd_class != Def ) { + if( (nd->nd_class == Arrsel) || + (nd->nd_class == LinkDef) ) + nd = nd->nd_left; + else if( nd->nd_class == Arrow ) + nd = nd->nd_right; + else break; + } + if( nd && (nd->nd_class == Def) ) { + if( (flags & D_SET) && on && + BlockScope != nd->nd_def->df_scope ) + nd->nd_def->df_flags |= D_SETINHIGH; + if( on ) { + if( (flags & D_SET) && + (nd->nd_def->df_flags & D_WITH) ) + node_warning(nd, + "variable \"%s\" already referenced in with", + nd->nd_def->df_idf->id_text); + nd->nd_def->df_flags |= flags; + } + else + nd->nd_def->df_flags &= ~flags; + } +} + +AssertStat(expp, line) + register struct node *expp; + unsigned short line; +{ + struct desig dsr; + + if( !ChkExpression(expp) ) + return; + + if( expp->nd_type != bool_type ) { + node_error(expp, "type of assertion should be boolean"); + return; + } + + if( options['a'] && !err_occurred ) { + dsr = InitDesig; + CodeExpr(expp, &dsr, NO_LABEL); + C_loc((arith)line); + C_cal("_ass"); + } +} AssignStat(left, right) register struct node *left, *right; { register struct type *ltp, *rtp; + int retval = 0; struct desig dsr; - if( !(ChkExpression(right) && ChkLhs(left)) ) - return; + retval = ChkExpression(right); + MarkUsed(right); + retval &= ChkLhs(left); ltp = left->nd_type; rtp = right->nd_type; + MarkDef(left, (unsigned short)D_SET, 1); + + if( !retval ) return; + + if( ltp == int_type && rtp == long_type ) { + right = MkNode(IntReduc, NULLNODE, right, &dot); + right->nd_type = int_type; + } + else if( ltp == long_type && rtp == int_type ) { + right = MkNode(IntCoerc, NULLNODE, right, &dot); + right->nd_type = long_type; + } + if( !TstAssCompat(ltp, rtp) ) { node_error(left, "type incompatibility in assignment"); return; } + if( left->nd_class == Def && + (left->nd_def->df_flags & D_INLOOP) ) { + node_error(left, "assignment to a control variable"); + return; + } + if( rtp == emptyset_type ) right->nd_type = ltp; @@ -45,7 +117,7 @@ AssignStat(left, right) CodeValue(&dsr, rtp); if( ltp == real_type && BaseType(rtp) == int_type ) - Int2Real(); + Int2Real(rtp->tp_size); RangeCheck(ltp, rtp); } @@ -71,11 +143,15 @@ ChkForStat(nd) register struct node *nd; { register struct def *df; + int retvar = 0; + + retvar = ChkVariable(nd); + retvar &= ChkExpression(nd->nd_left); + MarkUsed(nd->nd_left); + retvar &= ChkExpression(nd->nd_right); + MarkUsed(nd->nd_right); + if( !retvar ) return; - if( !(ChkVariable(nd) && ChkExpression(nd->nd_left) && - ChkExpression(nd->nd_right)) ) - return; - assert(nd->nd_class == Def); df = nd->nd_def; @@ -88,12 +164,15 @@ ChkForStat(nd) assert(df->df_kind == D_VARIABLE); if( df->df_scope != GlobalScope && df->var_off >= 0 ) { - node_error(nd,"for loop: control variable can't be a parameter"); - return; + node_error(nd, + "for loop: control variable can't be a parameter"); + MarkDef(nd,(unsigned short)(D_LOOPVAR | D_SET | D_USED), 1); + return; } if( !(df->df_type->tp_fund & T_ORDINAL) ) { node_error(nd, "for loop: control variable must be ordinal"); + MarkDef(nd,(unsigned short)(D_LOOPVAR | D_SET | D_USED), 1); return; } @@ -105,11 +184,37 @@ ChkForStat(nd) node_error(nd, "for loop: final value incompatible with control variable"); - df->df_flags |= D_LOOPVAR; + if( df->df_type == long_type ) + node_error(nd, "for loop: control variable can not be a long"); + + if( df->df_flags & D_INLOOP ) + node_error(nd, "for loop: control variable already used"); + + if( df->df_flags & D_SETINHIGH ) + node_error(nd, + "for loop: control variable already set in block"); + + MarkDef(nd,(unsigned short) (D_LOOPVAR | D_INLOOP | D_SET | D_USED), 1); return; } +EndForStat(nd) + register struct node *nd; +{ + register struct def *df; + + df = nd->nd_def; + + if( (df->df_scope != BlockScope) || + (df->df_scope != GlobalScope && df->var_off >= 0) || + !(df->df_type->tp_fund & T_ORDINAL) + ) + return; + + MarkDef(nd,(unsigned short) (D_INLOOP | D_SET), 0); +} + arith CodeInitFor(nd, priority) register struct node *nd; @@ -123,8 +228,10 @@ CodeInitFor(nd, priority) CodePExpr(nd); if( nd->nd_class != Value ) { tmp = NewInt(priority); + C_dup(int_size); C_stl(tmp); + return tmp; } return (arith) 0; @@ -191,6 +298,19 @@ WithStat(nd) return; } + MarkDef(nd, (unsigned short)(D_USED | D_SET | D_WITH), 1); + /* + if( (nd->nd_class == Arrow) && + (nd->nd_right->nd_type->tp_fund & T_FILE) ) { + nd->nd_right->nd_def->df_flags |= D_WITH; + } + */ + + scl = new_scopelist(); + scl->sc_scope = nd->nd_type->rec_scope; + scl->next = CurrVis; + CurrVis = scl; + if( err_occurred ) return; /* Generate code */ @@ -200,7 +320,7 @@ WithStat(nd) wds = new_withdesig(); wds->w_next = WithDesigs; WithDesigs = wds; - wds->w_scope = nd->nd_type->rec_scope; + wds->w_scope = scl->sc_scope; /* create a desig structure for the temporary */ ds.dsg_kind = DSG_FIXED; @@ -213,11 +333,6 @@ WithStat(nd) /* record is indirectly available */ ds.dsg_kind = DSG_PFIXED; wds->w_desig = ds; - - scl = new_scopelist(); - scl->sc_scope = wds->w_scope; - scl->next = CurrVis; - CurrVis = scl; } EndWith(saved_scl, nd) @@ -227,6 +342,7 @@ EndWith(saved_scl, nd) /* restore scope, and release structures */ struct scopelist *scl; struct withdesig *wds; + struct node *nd1; while( CurrVis != saved_scl ) { @@ -235,6 +351,9 @@ EndWith(saved_scl, nd) CurrVis = CurrVis->next; free_scopelist(scl); + if( WithDesigs == 0 ) + continue; /* we didn't generate any code */ + /* release temporary */ FreePtr(WithDesigs->w_desig.dsg_offset); @@ -243,5 +362,10 @@ EndWith(saved_scl, nd) WithDesigs = WithDesigs->w_next; free_withdesig(wds); } + + for( nd1 = nd; nd1 != NULLNODE; nd1 = nd1->nd_right ) { + MarkDef(nd1->nd_left, (unsigned short)(D_WITH), 0); + } + FreeNode(nd); } diff --git a/lang/pc/comp/casestat.C b/lang/pc/comp/casestat.C index e9e9c3a73..ab6a6c9b4 100644 --- a/lang/pc/comp/casestat.C +++ b/lang/pc/comp/casestat.C @@ -49,6 +49,7 @@ CaseExpr(nd) register struct node *expp = nd->nd_left; if( !ChkExpression(expp) ) return; + MarkUsed(expp); if( !(expp->nd_type->tp_fund & T_ORDINAL) ) { node_error(expp, "case-expression must be ordinal"); diff --git a/lang/pc/comp/chk_expr.c b/lang/pc/comp/chk_expr.c index be1651a5c..563321676 100644 --- a/lang/pc/comp/chk_expr.c +++ b/lang/pc/comp/chk_expr.c @@ -33,11 +33,51 @@ Xerror(nd, mess) if( nd->nd_class == Def && nd->nd_def ) { if( nd->nd_def->df_kind != D_ERROR ) node_error(nd,"\"%s\": %s", - nd->nd_def->df_idf->id_text, mess); + nd->nd_def->df_idf->id_text, mess); } else node_error(nd, "%s", mess); } +struct node * +ZeroParam() +{ + register struct node *nd; + + nd = MkLeaf(Value, &dot); + nd->nd_type = int_type; + nd->nd_symb = INTEGER; + nd->nd_INT = (arith) 0; + nd = MkNode(Link, nd, NULLNODE, &dot); + nd->nd_symb = ','; + + return nd; +} + +MarkUsed(nd) + register struct node *nd; +{ + while( nd && nd->nd_class != Def ) { + if( (nd->nd_class == Arrsel) || (nd->nd_class == LinkDef) ) + nd = nd->nd_left; + else if( nd->nd_class == Arrow) + nd = nd->nd_right; + else break; + } + + if( nd && nd->nd_class == Def ) { + if( !((nd->nd_def->df_flags & D_VARPAR) || + (nd->nd_def->df_kind == D_FIELD)) ) { + if( !(nd->nd_def->df_flags & D_SET) && + (nd->nd_def->df_scope == CurrentScope) ) + if( !is_anon_idf(nd->nd_def->df_idf) ) { + warning("\"%s\" used before set", + nd->nd_def->df_idf->id_text); + } + nd->nd_def->df_flags |= (D_USED | D_SET); + } + } +} + STATIC int ChkConstant(expp) register struct node *expp; @@ -89,6 +129,7 @@ ChkLhs(expp) if( !ChkVarAccess(expp) ) return 0; class = expp->nd_class; + /* a constant is replaced by it's value in ChkLinkOrName, check here !, * the remaining classes are checked by ChkVarAccess */ @@ -160,7 +201,7 @@ ChkLinkOrName(expp) return 0; } - if( !(df = lookup(expp->nd_IDF, left->nd_type->rec_scope)) ) { + if( !(df = lookup(expp->nd_IDF, left->nd_type->rec_scope, D_INUSE)) ) { id_not_declared(expp); return 0; } @@ -176,6 +217,7 @@ ChkLinkOrName(expp) df = expp->nd_def; if( df->df_kind & (D_ENUM | D_CONST) ) { + MarkUsed(expp); /* Replace an enum-literal or a CONST identifier by its value. */ if( df->df_kind == D_ENUM ) { @@ -201,8 +243,9 @@ ChkExLinkOrName(expp) if( !ChkLinkOrName(expp) ) return 0; if( expp->nd_class != Def ) return 1; - if( !(expp->nd_def->df_kind & D_VALUE) ) + if( !(expp->nd_def->df_kind & D_VALUE) ) { Xerror(expp, "value expected"); + } return 1; } @@ -218,6 +261,8 @@ ChkUnOper(expp) if( !ChkExpression(right) ) return 0; + MarkUsed(right); + expp->nd_type = tpr = BaseType(right->nd_type); switch( expp->nd_symb ) { @@ -230,7 +275,7 @@ ChkUnOper(expp) break; case '-': - if( tpr->tp_fund == T_INTEGER ) { + if( tpr->tp_fund == T_INTEGER || tpr->tp_fund == T_LONG ) { if( right->nd_class == Value ) cstunary(expp); return 1; @@ -256,6 +301,9 @@ ChkUnOper(expp) break; case '(': + /* Delete the brackets */ + *expp = *right; + free_node(right); return 1; default: @@ -287,10 +335,13 @@ ResultOfOperation(operator, tpl, tpr) case '*' : if( tpl == real_type || tpr == real_type ) return real_type; + if( tpl == long_type || tpr == long_type) + return long_type; return tpl; case '/' : return real_type; } + if (tpr == long_type && tpl == int_type) return tpr; return tpl; } @@ -310,22 +361,23 @@ AllowedTypes(operator) return T_NUMERIC; case DIV : case MOD : - return T_INTEGER; + return T_INTEGER | T_LONG; case OR : case AND : return T_ENUMERATION; case '=' : case NOTEQUAL : return T_ENUMERATION | T_CHAR | T_NUMERIC | - T_SET | T_POINTER | T_STRING; + T_SET | T_POINTER | T_STRINGCONST | + T_STRING; case LESSEQUAL : case GREATEREQUAL: return T_ENUMERATION | T_CHAR | T_NUMERIC | - T_SET | T_STRING; + T_SET | T_STRINGCONST; case '<' : case '>' : return T_ENUMERATION | T_CHAR | T_NUMERIC | - T_STRING; + T_STRINGCONST; default : crash("(AllowedTypes)"); } @@ -353,6 +405,9 @@ ChkBinOper(expp) retval = ChkExpression(left) & ChkExpression(right); + MarkUsed(left); + MarkUsed(right); + tpl = BaseType(left->nd_type); tpr = BaseType(right->nd_type); @@ -362,7 +417,7 @@ ChkBinOper(expp) of the operands. There are some needles and pins: - Boolean operators are only allowed on boolean operands, but the - "allowed-mask" of "AllowedTyped" can only indicate an enumeration + "allowed-mask" of "AllowedTypes" can only indicate an enumeration type. - The IN-operator has as right-hand-side operand a set. - Strings and packed arrays can be equivalent. @@ -393,7 +448,7 @@ ChkBinOper(expp) arith ub; extern arith IsString(); - if( allowed & T_STRING && (ub = IsString(tpl)) ) + if( allowed & T_STRINGCONST && (ub = IsString(tpl)) ) { if( ub == IsString(tpr) ) return 1; else { @@ -401,6 +456,10 @@ ChkBinOper(expp) symbol2str(expp->nd_symb)); return 0; } + } + else if( allowed & T_STRING && tpl->tp_fund == T_STRING ) + return 1; + node_error(expp, "\"%s\": illegal operand type(s)", symbol2str(expp->nd_symb)); return 0; @@ -413,17 +472,28 @@ ChkBinOper(expp) } if( allowed & T_NUMERIC ) { - if( tpl == int_type && + if( (tpl == int_type || tpl == long_type) && (tpr == real_type || expp->nd_symb == '/') ) { expp->nd_left = MkNode(Cast, NULLNODE, expp->nd_left, &dot); expp->nd_left->nd_type = tpl = real_type; } - if( tpl == real_type && tpr == int_type ) { + if( tpl == real_type && + (tpr == int_type || tpr == long_type)) { expp->nd_right = MkNode(Cast, NULLNODE, expp->nd_right, &dot); expp->nd_right->nd_type = tpr = real_type; } + if( tpl == int_type && tpr == long_type) { + expp->nd_left = + MkNode(IntCoerc, NULLNODE, expp->nd_left, &dot); + expp->nd_left->nd_type = long_type; + } + else if( tpl == long_type && tpr == int_type) { + expp->nd_right = + MkNode(IntCoerc, NULLNODE, expp->nd_right, &dot); + expp->nd_right->nd_type = long_type; + } } /* Operands must be compatible */ @@ -499,6 +569,7 @@ ChkElement(expp, tp, set, cnt) /* Here, a single element is checked */ if( !ChkExpression(expp) ) return 0; + MarkUsed(expp); if( *tp == emptyset_type ) { /* first element in set determines the type of the set */ @@ -590,7 +661,7 @@ ChkSet(expp) /* after all the work we've done, the set turned out out to be empty! */ - free(set); + free((char *) set); set = (arith *) 0; } expp->nd_set = set; @@ -601,6 +672,49 @@ ChkSet(expp) return 1; } +char * +ChkAllowedVar(nd, reading) /* reading indicates read or readln */ + register struct node *nd; +{ + char *message = 0; + + switch( nd->nd_class ) { + case Def: + if( nd->nd_def->df_flags & D_INLOOP ) { + message = "control variable"; + break; + } + if( nd->nd_def->df_kind != D_FIELD ) break; + /* FALL THROUGH */ + + case LinkDef: + assert(nd->nd_def->df_kind == D_FIELD); + + if( nd->nd_def->fld_flags & F_PACKED ) + message = "field of packed record"; + else if( nd->nd_def->fld_flags & F_SELECTOR ) + message = "variant selector"; + break; + + case Arrsel: + if( IsPacked(nd->nd_left->nd_type) ) + if( !reading ) message = "component of packed array"; + break; + + case Arrow: + if( nd->nd_right->nd_type->tp_fund == T_FILE ) + message = "filebuffer variable"; + break; + + default: + crash("(ChkAllowedVar)"); + /*NOTREACHED*/ + } + MarkDef(nd, D_SET, 1); + return message; +} + +int ChkVarPar(nd, name) register struct node *nd, *name; { @@ -610,43 +724,16 @@ ChkVarPar(nd, name) of a variable where that variable possesses a type that is designated packed. */ - static char var_mes[] = "can't be a variable parameter"; - static char err_mes[64]; + static char err_mes[80]; char *message = (char *) 0; extern char *sprint(); if( !ChkVariable(nd) ) return 0; - switch( nd->nd_class ) { - case Def: - if( nd->nd_def->df_kind != D_FIELD ) break; - /* FALL THROUGH */ + message = ChkAllowedVar(nd, 0); - case LinkDef: - assert(nd->nd_def->df_kind == D_FIELD); - - if( nd->nd_def->fld_flags & F_PACKED ) - message = "field of packed record %s"; - else if( nd->nd_def->fld_flags & F_SELECTOR ) - message = "variant selector %s"; - break; - - case Arrsel: - if( IsPacked(nd->nd_left->nd_type) ) - message = "component of packed array %s"; - break; - - case Arrow: - if( nd->nd_right->nd_type->tp_fund == T_FILE ) - message = "filebuffer variable %s"; - break; - - default: - crash("(ChkVarPar)"); - /*NOTREACHED*/ - } if( message ) { - sprint(err_mes, message, var_mes); + sprint(err_mes, "%s can't be a variable parameter", message); Xerror(name, err_mes); return 0; } @@ -684,13 +771,29 @@ getarg(argp, bases, varaccess, name, paramtp) Xerror(name, "illegal proc/func parameter"); return 0; } - else if( ChkLinkOrName(left->nd_left) ) + else if( ChkLinkOrName(left->nd_left) ) { left->nd_type = left->nd_left->nd_type; - + MarkUsed(left->nd_left); + } else return 0; } - else if( varaccess ? !ChkVarPar(left, name) : !ChkExpression(left) ) - return 0; + else if( varaccess ) { + if( !ChkVarPar(left, name) ) + return 0; + } + else if( !ChkExpression(left) ) { + MarkUsed(left); + return 0; + } + + if( !varaccess ) MarkUsed(left); + + if( !varaccess && bases == T_INTEGER && + BaseType(left->nd_type)->tp_fund == T_LONG) { + arg->nd_left = MkNode(IntReduc, NULLNODE, left, &dot); + arg->nd_left->nd_type = int_type; + left = arg->nd_left; + } if( bases && !(BaseType(left->nd_type)->tp_fund & bases) ) { Xerror(name, "unexpected parameter type"); @@ -709,7 +812,7 @@ ChkProcCall(expp) register struct node *left; struct node *name; register struct paramlist *param; - char ebuf[64]; + char ebuf[80]; int retval = 1; int cnt = 0; int new_par_section; @@ -731,20 +834,39 @@ ChkProcCall(expp) /* Check parameter list */ for( param = ParamList(left->nd_type); param; param = param->next ) { - if( !(left = getarg(&expp, 0, IsVarParam(param), name, + if( !(left = getarg(&expp, 0, (int) IsVarParam(param), name, TypeOfParam(param))) ) return 0; cnt++; - new_par_section = lasttp != TypeOfParam(param); if( !TstParCompat(TypeOfParam(param), left->nd_type, - IsVarParam(param), left, new_par_section) ) { + (int) IsVarParam(param), left, new_par_section) ) { sprint(ebuf, "type incompatibility in parameter %d", cnt); Xerror(name, ebuf); retval = 0; } + + /* Convert between integers and longs. + */ + if( !IsVarParam(param) && options['d'] ) { + if( left->nd_type->tp_fund == T_INTEGER && + TypeOfParam(param)->tp_fund == T_LONG) { + expp->nd_left = + MkNode(IntCoerc, NULLNODE, left, &dot); + expp->nd_left->nd_type = long_type; + left = expp->nd_left; + } + else if( left->nd_type->tp_fund == T_LONG && + TypeOfParam(param)->tp_fund == T_INTEGER) { + expp->nd_left = + MkNode(IntReduc, NULLNODE, left, &dot); + expp->nd_left->nd_type = int_type; + left = expp->nd_left; + } + } + if( left->nd_type == emptyset_type ) /* type of emptyset determined by the context */ left->nd_type = TypeOfParam(param); @@ -780,6 +902,7 @@ ChkCall(expp) if( ChkLinkOrName(left) ) { + MarkUsed(left); if( IsProcCall(left) || left->nd_type == error_type ) { /* A call. It may also be a call to a standard procedure @@ -862,7 +985,8 @@ ChkStandard(expp,left) if( !(left = getarg(&arg, T_NUMERIC, 0, name, NULLTYPE)) ) return 0; expp->nd_type = real_type; - if( BaseType(left->nd_type)->tp_fund == T_INTEGER ) { + if( BaseType(left->nd_type)->tp_fund == T_INTEGER || + BaseType(left->nd_type)->tp_fund == T_LONG) { arg->nd_left = MkNode(Cast,NULLNODE, arg->nd_left,&dot); arg->nd_left->nd_type = real_type; } @@ -878,6 +1002,10 @@ ChkStandard(expp,left) case R_ORD: if( !(left = getarg(&arg, T_ORDINAL, 0, name, NULLTYPE)) ) return 0; + if( BaseType(left->nd_type)->tp_fund == T_LONG ) { + arg->nd_left = MkNode(IntReduc, NULLNODE, arg->nd_left, &dot); + arg->nd_left->nd_type = int_type; + } expp->nd_type = int_type; if( left->nd_class == Value ) cstcall(expp, R_ORD); @@ -896,12 +1024,12 @@ ChkStandard(expp,left) if( !(left = getarg(&arg, T_ORDINAL, 0, name, NULLTYPE)) ) return 0; expp->nd_type = left->nd_type; - if( left->nd_class == Value && !options['r'] ) + if( left->nd_class == Value && options['R'] ) cstcall(expp, req); break; case R_ODD: - if( !(left = getarg(&arg, T_INTEGER, 0, name, NULLTYPE)) ) + if( !(left = getarg(&arg, T_INTEGER | T_LONG , 0, name, NULLTYPE)) ) return 0; expp->nd_type = bool_type; if( left->nd_class == Value ) @@ -924,7 +1052,7 @@ ChkStandard(expp,left) if( !arg->nd_right ) { struct node *nd; - if( !(nd = ChkStdInOut(name, st_out)) ) + if( !(nd = ChkStdInOut(name->nd_IDF->id_text, st_out)) ) return 0; expp->nd_right = MkNode(Link, nd, NULLNODE, &dot); @@ -1042,6 +1170,21 @@ ChkStandard(expp,left) expp->nd_type = NULLTYPE; break; + case R_MARK: + case R_RELEASE: + if( !(left = getarg(&arg, T_POINTER, 1, name, NULLTYPE)) ) + return 0; + expp->nd_type = NULLTYPE; + break; + + case R_HALT: + if( !arg->nd_right ) /* insert 0 parameter */ + arg->nd_right = ZeroParam(); + if( !(left = getarg(&arg, T_INTEGER, 0, name, NULLTYPE)) ) + return 0; + expp->nd_type = NULLTYPE; + break; + default: crash("(ChkStandard)"); } @@ -1072,6 +1215,8 @@ ChkArrow(expp) if( !ChkVariable(expp->nd_right) ) return 0; + MarkUsed(expp->nd_right); + tp = expp->nd_right->nd_type; if( !(tp->tp_fund & (T_POINTER | T_FILE)) ) { @@ -1101,7 +1246,13 @@ ChkArr(expp) expp->nd_type = error_type; - retval = ChkVariable(expp->nd_left) & ChkExpression(expp->nd_right); + /* Check the index first, so a[a[j]] is checked in order of + * evaluation. This to make sure that warnings are generated + * in the right order. + */ + retval = ChkExpression(expp->nd_right); + MarkUsed(expp->nd_right); + retval &= ChkVariable(expp->nd_left); tpl = expp->nd_left->nd_type; tpr = expp->nd_right->nd_type; @@ -1120,6 +1271,11 @@ ChkArr(expp) return 0; } + if( tpr == long_type ) { + expp->nd_right = MkNode(IntReduc, NULLNODE, expp->nd_right, &dot); + expp->nd_right->nd_type = int_type; + } + expp->nd_type = tpl->arr_elem; return retval; } @@ -1158,6 +1314,8 @@ int (*ExprChkTable[])() = { NodeCrash, ChkExLinkOrName, NodeCrash, + NodeCrash, + NodeCrash, NodeCrash }; @@ -1175,5 +1333,7 @@ int (*VarAccChkTable[])() = { done_before, ChkLinkOrName, done_before, + no_var_access, + no_var_access, no_var_access }; diff --git a/lang/pc/comp/code.c b/lang/pc/comp/code.c index c69bd4514..6880060ac 100644 --- a/lang/pc/comp/code.c +++ b/lang/pc/comp/code.c @@ -4,12 +4,16 @@ #include #include #include +#include #include "LLlex.h" #include "Lpars.h" #include "def.h" #include "desig.h" +#include "f_info.h" +#include "idf.h" #include "main.h" +#include "misc.h" #include "node.h" #include "required.h" #include "scope.h" @@ -23,11 +27,25 @@ CodeFil() C_fil_dlb((label) 1, (arith) 0); } +routine_label(df) + register struct def * df; +{ + df->prc_label = ++data_label; + C_df_dlb(df->prc_label); + C_rom_scon(df->df_idf->id_text, strlen(df->df_idf->id_text) + 1); +} + RomString(nd) register struct node *nd; { C_df_dlb(++data_label); - C_rom_scon(nd->nd_STR, nd->nd_SLE); /* no trailing '\0' */ + + /* A string of the string_type is null-terminated. */ + if( nd->nd_type == string_type ) + C_rom_scon(nd->nd_STR, nd->nd_SLE + 1); /* with trailing '\0' */ + else + C_rom_scon(nd->nd_STR, nd->nd_SLE); /* no trailing '\0' */ + nd->nd_SLA = data_label; } @@ -94,12 +112,13 @@ CodeBeginBlock(df) */ arith StackAdjustment = 0; - arith offset; /* offset to save StackPointer */ + arith offset = 0; /* offset to save StackPointer */ TmpOpen(df->prc_vis->sc_scope); switch( df->df_kind ) { + case D_MODULE : break; /* nothing */ case D_PROGRAM : C_exp("m_a_i_n"); C_pro_narg("m_a_i_n"); @@ -108,8 +127,13 @@ CodeBeginBlock(df) CodeFil(); /* initialize external files */ - make_extfl(); call_ini(); + /* ignore floating point underflow */ + C_lim(); + C_loc((arith) (1 << EFUNFL)); + C_ior(int_size); + C_sim(); + break; case D_PROCEDURE : @@ -123,6 +147,21 @@ CodeBeginBlock(df) offset = CodeGtoDescr(df->prc_vis->sc_scope); CodeFil(); + if( options['t'] ) { + C_lae_dlb(df->prc_label,(arith)0); + C_cal("procentry"); + C_asp(pointer_size); + } + + /* prc_bool is the local variable that indicates if the + * function result is assigned. This and can be disabled + * with the -R option. The variable, however, is always + * allocated and initialized. + */ + if( df->prc_res ) { + C_zer((arith) int_size); + C_stl(df->prc_bool); + } for( param = ParamList(df->df_type); param; param = param->next) if( !IsVarParam(param) ) { tp = TypeOfParam(param); @@ -213,8 +252,19 @@ CodeEndBlock(df, StackAdjustment) if( !options['n'] ) RegisterMessages(df->prc_vis->sc_scope->sc_def); + if( options['t'] ) { + C_lae_dlb(df->prc_label,(arith)0); + C_cal("procexit"); + C_asp(pointer_size); + } if( tp = ResultType(df->df_type) ) { - if( tp->tp_size == real_size ) + if( !options['R'] ) { + C_lin(LineNumber); + C_lol(df->prc_bool); + C_cal("_nfa"); + C_asp(word_size); + } + if( tp->tp_size == 2 * word_size ) C_ldl(-tp->tp_size); else C_lol(-tp->tp_size); @@ -345,11 +395,28 @@ CodeExpr(nd, ds, true_label) struct node *right = nd->nd_right; CodePExpr(right); - Int2Real(); + Int2Real(right->nd_type->tp_size); ds->dsg_kind = DSG_LOADED; break; } + case IntCoerc: { + /* convert integer to long integer */ + struct node *right = nd->nd_right; + CodePExpr(right); + Int2Long(); + ds->dsg_kind = DSG_LOADED; + break; + } + case IntReduc: { + /* convert a long to an integer */ + struct node *right = nd->nd_right; + + CodePExpr(right); + Long2Int(); + ds->dsg_kind = DSG_LOADED; + break; + } default: crash("(CodeExpr : bad node type)"); /*NOTREACHED*/ @@ -373,7 +440,7 @@ CodeUoper(nd) switch( nd->nd_symb ) { case '-': assert(tp->tp_fund & T_NUMERIC); - if( tp->tp_fund == T_INTEGER ) + if( tp->tp_fund == T_INTEGER || tp->tp_fund == T_LONG ) C_ngi(tp->tp_size); else C_ngf(tp->tp_size); @@ -412,6 +479,7 @@ CodeBoper(expr, true_label) Operands(leftop, rightop); switch( tp->tp_fund ) { case T_INTEGER: + case T_LONG: C_adi(tp->tp_size); break; case T_REAL: @@ -429,6 +497,7 @@ CodeBoper(expr, true_label) Operands(leftop, rightop); switch( tp->tp_fund ) { case T_INTEGER: + case T_LONG: C_sbi(tp->tp_size); break; case T_REAL: @@ -447,6 +516,7 @@ CodeBoper(expr, true_label) Operands(leftop, rightop); switch( tp->tp_fund ) { case T_INTEGER: + case T_LONG: C_mli(tp->tp_size); break; case T_REAL: @@ -470,7 +540,7 @@ CodeBoper(expr, true_label) case DIV: Operands(leftop, rightop); - if( tp->tp_fund == T_INTEGER ) + if( tp->tp_fund == T_INTEGER || tp->tp_fund == T_LONG) C_dvi(tp->tp_size); else crash("(CodeBoper: bad type DIV)"); @@ -478,11 +548,16 @@ CodeBoper(expr, true_label) case MOD: Operands(leftop, rightop); - if( tp->tp_fund == T_INTEGER ) { + if( tp->tp_fund == T_INTEGER ) { C_cal("_mdi"); C_asp(2 * tp->tp_size); C_lfr(tp->tp_size); } + else if( tp->tp_fund == T_LONG) { + C_cal("_mdil"); + C_asp(2 * tp->tp_size); + C_lfr(tp->tp_size); + } else crash("(CodeBoper: bad type MOD)"); break; @@ -499,6 +574,7 @@ CodeBoper(expr, true_label) switch( tp->tp_fund ) { case T_INTEGER: + case T_LONG: C_cmi(tp->tp_size); break; case T_REAL: @@ -532,14 +608,18 @@ CodeBoper(expr, true_label) C_cms(tp->tp_size); break; - case T_STRING: + case T_STRINGCONST: case T_ARRAY: - C_loc(IsString(tp)); + C_loc((arith) IsString(tp)); C_cal("_bcp"); C_asp(2 * pointer_size + word_size); C_lfr(word_size); break; + case T_STRING: + C_cmp(); + break; + default: crash("(CodeBoper : bad type COMPARE)"); } @@ -644,7 +724,7 @@ CodeParameters(param, arg) struct paramlist *param; struct node *arg; { - register struct type *tp, *left_tp, *last_tp; + register struct type *tp, *left_tp, *last_tp = (struct type *) 0; struct node *left; struct desig ds; @@ -669,7 +749,7 @@ CodeParameters(param, arg) CodeDAddress(left); return tp; } - if( left_tp->tp_fund == T_STRING ) { + if( left_tp->tp_fund == T_STRINGCONST ) { CodePString(left, tp); return tp; } @@ -680,7 +760,7 @@ CodeParameters(param, arg) RangeCheck(tp, left_tp); if( tp == real_type && BaseType(left_tp) == int_type ) - Int2Real(); + Int2Real(int_size); return tp; } @@ -693,7 +773,7 @@ CodeConfDescr(ftp, atp) if( IsConformantArray(elemtp) ) CodeConfDescr(elemtp, atp->arr_elem); - if( atp->tp_fund == T_STRING ) { + if( atp->tp_fund == T_STRINGCONST ) { C_loc((arith) 1); C_loc(atp->tp_psize - 1); C_loc((arith) 1); @@ -807,6 +887,8 @@ CodeStd(nd) CodePExpr(left); if( tp == int_type ) C_cal("_abi"); + else if ( tp == long_type ) + C_cal("_abl"); else C_cal("_abr"); C_asp(tp->tp_size); @@ -816,8 +898,8 @@ CodeStd(nd) case R_SQR: CodePExpr(left); C_dup(tp->tp_size); - if( tp == int_type ) - C_mli(int_size); + if( tp == int_type || tp == long_type ) + C_mli(tp->tp_size); else C_mlf(real_size); break; @@ -884,10 +966,14 @@ CodeStd(nd) case R_SUCC: case R_PRED: CodePExpr(left); + C_loc((arith)1); + if( tp == long_type) Int2Long(); + if( req == R_SUCC ) - C_inc(); + C_adi(tp->tp_size); else - C_dec(); + C_sbi(tp->tp_size); + if( bounded(left->nd_type) ) genrck(left->nd_type); break; @@ -895,7 +981,9 @@ CodeStd(nd) case R_ODD: CodePExpr(left); C_loc((arith) 1); - C_and(word_size); + if( tp == long_type ) Int2Long(); + C_and(tp->tp_size); + if( tp == long_type ) Long2Int(); /* bool_size == int_size */ break; case R_EOF: @@ -989,16 +1077,57 @@ CodeStd(nd) C_asp(pointer_size + word_size); break; + case R_MARK: + case R_RELEASE: + CodeDAddress(left); + if( req == R_MARK ) + C_cal("_sav"); + else + C_cal("_rst"); + C_asp(pointer_size); + break; + + case R_HALT: + if( left ) + CodePExpr(left); + else + C_zer(int_size); + C_cal("_hlt"); /* can't return */ + C_asp(int_size); /* help the optimizer(s) */ + break; + default: crash("(CodeStd)"); /*NOTREACHED*/ } } -Int2Real() +Long2Int() +{ + /* convert a long to integer */ + + if (int_size == long_size) return; + + C_loc(long_size); + C_loc(int_size); + C_cii(); +} + +Int2Long() +{ + /* convert integer to long */ + + if (int_size == long_size) return; + C_loc(int_size); + C_loc(long_size); + C_cii(); +} + +Int2Real(size) /* size is different for integers and longs */ +arith size; { /* convert integer to real */ - C_loc(int_size); + C_loc(size); C_loc(real_size); C_cif(); } @@ -1049,7 +1178,7 @@ genrck(tp) register label o1; int newlabel = 0; - if( !options['r'] ) return; + if( options['R'] ) return; getbounds(tp, &lb, &ub); diff --git a/lang/pc/comp/cstoper.c b/lang/pc/comp/cstoper.c index d6615ab4c..6ea44324e 100644 --- a/lang/pc/comp/cstoper.c +++ b/lang/pc/comp/cstoper.c @@ -18,11 +18,18 @@ long mach_long_sign; /* sign bit of the machine long */ int mach_long_size; /* size of long on this machine == sizeof(long) */ long full_mask[MAXSIZE+1];/* full_mask[1] == 0xFF, full_mask[2] == 0xFFFF, .. */ -arith max_int; /* maximum integer on target machine */ +arith max_int; /* maximum integer on the target machine */ +arith min_int; /* mimimum integer on the target machin */ char *maxint_str; /* string representation of maximum integer */ arith wrd_bits; /* number of bits in a word */ arith max_intset; /* largest value of set of integer */ +overflow(expp) + struct node *expp; +{ + node_warning(expp, "overflow in constant expression"); +} + cstunary(expp) register struct node *expp; { @@ -66,13 +73,15 @@ cstbin(expp) */ register arith o1, o2; register char *s1, *s2; - int str = expp->nd_left->nd_type->tp_fund & T_STRING; + int str = expp->nd_left->nd_type->tp_fund & T_STRINGCONST; if( str ) { + o1 = o2 = 0; /* so LINT won't complain */ s1 = expp->nd_left->nd_STR; s2 = expp->nd_right->nd_STR; } else { + s1 = s2 = (char *) 0; /* so LINT won't complain */ o1 = expp->nd_left->nd_INT; o2 = expp->nd_right->nd_INT; } @@ -83,14 +92,39 @@ cstbin(expp) switch( expp->nd_symb ) { case '+': + if (o1 > 0 && o2 > 0) { + if (max_int - o1 < o2) overflow(expp); + } + else if (o1 < 0 && o2 < 0) { + if (min_int - o1 > o2) overflow(expp); + } o1 += o2; break; case '-': + if ( o1 >= 0 && o2 < 0) { + if (max_int + o2 < o1) overflow(expp); + } + else if (o1 < 0 && o2 >= 0) { + if (min_int + o2 > o1) overflow(expp); + } o1 -= o2; break; case '*': + if (o1 > 0 && o2 > 0) { + if (max_int / o1 < o2) overflow(expp); + } + else if (o1 < 0 && o2 < 0) { + if (o1 == min_int || o2 == min_int || + max_int / (-o1) < (-o2)) overflow(expp); + } + else if (o1 > 0) { + if (min_int / o1 > o2) overflow(expp); + } + else if (o2 > 0) { + if (min_int / o2 > o1) overflow(expp); + } o1 *= o2; break; @@ -171,7 +205,7 @@ cstset(expp) assert(expp->nd_right->nd_class == Set); assert(expp->nd_symb == IN || expp->nd_left->nd_class == Set); set2 = expp->nd_right->nd_set; - setsize = expp->nd_right->nd_type->tp_size / word_size; + setsize = (unsigned) (expp->nd_right->nd_type->tp_size) / (unsigned) word_size; if( expp->nd_symb == IN ) { arith i; @@ -331,12 +365,26 @@ cstcall(expp, req) expp->nd_symb = INTEGER; switch( req ) { case R_ABS: - if( expr->nd_INT < 0 ) expp->nd_INT = - expr->nd_INT; + if( expr->nd_INT < 0 ) { + if (expr->nd_INT <= min_int) { + overflow(expr); + } + expp->nd_INT = - expr->nd_INT; + } else expp->nd_INT = expr->nd_INT; CutSize(expp); break; case R_SQR: + if (expr->nd_INT < 0) { + if ( expr->nd_INT == min_int || + max_int / expr->nd_INT > expr->nd_INT) { + overflow(expr); + } + } + else if (max_int / expr->nd_INT < expr->nd_INT) { + overflow(expr); + } expp->nd_INT = expr->nd_INT * expr->nd_INT; CutSize(expp); break; @@ -413,7 +461,7 @@ CutSize(expr) /* integers in [-maxint .. maxint] */ int nbits = (int) (mach_long_size - size) * 8; - node_warning(expr, "overflow in constant expression"); + /* overflow(expr); */ /* sign bit of o1 in sign bit of mach_long */ o1 <<= nbits; /* shift back to get sign extension */ @@ -441,6 +489,7 @@ InitCst() fatal("sizeof (long) insufficient on this machine"); max_int = full_mask[int_size] & ~(1 << (int_size * 8 - 1)); + min_int = - max_int; maxint_str = long2str(max_int, 10); maxint_str = Salloc(maxint_str, (unsigned int) strlen(maxint_str)); wrd_bits = 8 * word_size; diff --git a/lang/pc/comp/declar.g b/lang/pc/comp/declar.g index e080c2f35..c04b2748a 100644 --- a/lang/pc/comp/declar.g +++ b/lang/pc/comp/declar.g @@ -1,10 +1,14 @@ /* D E C L A R A T I O N S */ { +/* next line DEBUG */ +#include "debug.h" + #include #include #include #include +#include #include "LLlex.h" #include "chk_expr.h" @@ -16,8 +20,12 @@ #include "scope.h" #include "type.h" +#define offsetof(type, field) (int) &(((type *)0)->field) +#define PC_BUFSIZ (sizeof(struct file) - (int)((struct file *)0)->bufadr) + int proclevel = 0; /* nesting level of procedures */ int parlevel = 0; /* nesting level of parametersections */ +int expect_label = 0; /* so the parser knows that we expect a label */ static int in_type_defs; /* in type definition part or not */ } @@ -25,42 +33,14 @@ static int in_type_defs; /* in type definition part or not */ Block(struct def *df;) { arith i; - label save_label; } : { text_label = (label) 0; } LabelDeclarationPart - ConstantDefinitionPart - { in_type_defs = 1; } - TypeDefinitionPart - { in_type_defs = 0; - /* resolve forward references */ - chk_forw_types(); - } - VariableDeclarationPart - { if( !proclevel ) { - chk_prog_params(); - BssVar(); - } - proclevel++; - save_label = text_label; - } - ProcedureAndFunctionDeclarationPart - { text_label = save_label; - - proclevel--; - chk_directives(); - - /* needed with labeldefinitions - and for-statement - */ - BlockScope = CurrentScope; - - if( !err_occurred ) - i = CodeBeginBlock( df ); - } + Module(df, &i) CompoundStatement { if( !err_occurred ) CodeEndBlock(df, i); + if( df ) EndBlock(df); FreeNode(BlockScope->sc_lablist); } ; @@ -90,6 +70,44 @@ LabelDeclarationPart ]? ; +Module(struct def *df; arith *i;) +{ + label save_label; +} : + ConstantDefinitionPart + { in_type_defs = 1; } + TypeDefinitionPart + { in_type_defs = 0; + /* resolve forward references */ + chk_forw_types(); + } + VariableDeclarationPart + { if( !proclevel ) { + chk_prog_params(); + BssVar(); + } + proclevel++; + save_label = text_label; + } + ProcedureAndFunctionDeclarationPart + { text_label = save_label; + + proclevel--; + chk_directives(); + + /* needed with labeldefinitions + and for-statement + */ + BlockScope = CurrentScope; + + if( !err_occurred ) + *i = CodeBeginBlock( df ); + } +; + + + + ConstantDefinitionPart: [ CONST @@ -132,10 +150,11 @@ Label(struct node **pnd;) { char lab[5]; extern char *sprint(); -} : +} : { expect_label = 1; } INTEGER /* not really an integer, in [0..9999] */ { if( dot.TOK_INT < 0 || dot.TOK_INT > 9999 ) { - error("label must lie in closed interval [0..9999]"); + if( dot.TOK_INT != -1 ) /* This means insertion */ + error("label must lie in closed interval [0..9999]"); *pnd = NULLNODE; } else { @@ -143,6 +162,7 @@ Label(struct node **pnd;) *pnd = MkLeaf(Name, &dot); (*pnd)->nd_IDF = str2idf(lab, 1); } + expect_label = 0; } ; @@ -159,6 +179,7 @@ ConstantDefinition { if( df = define(id,CurrentScope,D_CONST) ) { df->con_const = nd; df->df_type = nd->nd_type; + df->df_flags |= D_SET; } } ; @@ -172,8 +193,10 @@ TypeDefinition } : IDENT { id = dot.TOK_IDF; } '=' TypeDenoter(&tp) - { if( df = define(id, CurrentScope, D_TYPE) ) + { if( df = define(id, CurrentScope, D_TYPE) ) { df->df_type = tp; + df->df_flags |= D_SET; + } } ; @@ -276,7 +299,9 @@ ProcedureHeading(register struct node **pnd; register struct type **ptp;) struct node *fpl; } : PROCEDURE - IDENT { *pnd = MkLeaf(Name, &dot); } + IDENT { + *pnd = MkLeaf(Name, &dot); + } [ FormalParameterList(&fpl) { arith nb_pars = 0; @@ -287,14 +312,16 @@ ProcedureHeading(register struct node **pnd; register struct type **ptp;) nb_pars = EnterParamList(fpl, &pr); else /* procedure parameter */ - EnterParTypes(fpl, &pr); + nb_pars = EnterParTypes(fpl, &pr); *ptp = proc_type(pr, nb_pars); FreeNode(fpl); } | /* empty */ - { *ptp = proc_type(0, 0); } + { *ptp = + proc_type((struct paramlist *)0, (arith) 0); + } ] ; @@ -329,16 +356,18 @@ FunctionDeclaration else DoDirective(dot.TOK_IDF, nd, tp, scl, 1); } | - { if( df = DeclFunc(nd, tp, scl) ) - df->prc_res = CurrentScope->sc_off = + { if( df = DeclFunc(nd, tp, scl) ) { + df->prc_res = - ResultType(df->df_type)->tp_size; + df->prc_bool = + CurrentScope->sc_off = + df->prc_res - int_size; + } } Block(df) - { if( df ) - /* assignment to functionname is illegal - outside the functionblock - */ - df->prc_res = 0; + { if( df ) { + EndFunc(df); + } /* open_scope() is simulated in DeclFunc() */ close_scope(); @@ -368,7 +397,7 @@ FunctionHeading(register struct node **pnd; register struct type **ptp;) nb_pars = EnterParamList(fpl, &pr); else /* function parameter */ - EnterParTypes(fpl, &pr); + nb_pars = EnterParTypes(fpl, &pr); } | /* empty */ @@ -627,7 +656,7 @@ VariantPart(struct scope *scope; arith *cnt; int *palign; /* initialize selector */ (*sel)->sel_ptrs = (struct selector **) - Malloc(ncst * sizeof(struct selector *)); + Malloc((unsigned)ncst * sizeof(struct selector *)); (*sel)->sel_ncst = ncst; (*sel)->sel_lb = lb; @@ -758,6 +787,12 @@ FileType(register struct type **ptp;): error("file type has an illegal component type"); (*ptp)->next = error_type; } + else { + if( (*ptp)->next->tp_size > PC_BUFSIZ ) + (*ptp)->tp_size = (*ptp)->tp_psize = + (*ptp)->next->tp_size + + sizeof(struct file) - PC_BUFSIZ; + } } ; @@ -771,7 +806,10 @@ PointerType(register struct type **ptp;) { *ptp = construct_type(T_POINTER, NULLTYPE); } IDENT { nd = MkLeaf(Name, &dot); - df = lookup(nd->nd_IDF, CurrentScope); + df = lookup(nd->nd_IDF, CurrentScope, D_INUSE); + /* if( !df && CurrentScope == GlobalScope) + df = lookup(nd->nd_IDF, PervasiveScope, D_INUSE); + */ if( in_type_defs && (!df || (df->df_kind & (D_ERROR | D_FORWTYPE))) ) @@ -814,11 +852,11 @@ FormalParameterSection(struct node *nd;): [ /* ValueParameterSpecification */ /* empty */ - { nd->nd_INT = D_VALPAR; } + { nd->nd_INT = (D_VALPAR | D_SET); } | /* VariableParameterSpecification */ VAR - { nd->nd_INT = D_VARPAR; } + { nd->nd_INT = (D_VARPAR | D_USED); } ] IdentifierList(&(nd->nd_left)) ':' [ @@ -829,15 +867,17 @@ FormalParameterSection(struct node *nd;): TypeIdentifier(&(nd->nd_type)) ] { if( nd->nd_type->tp_flags & T_HASFILE && - nd->nd_INT == D_VALPAR ) { + (nd->nd_INT & D_VALPAR) ) { error("value parameter can't have a filecomponent"); nd->nd_type = error_type; } } | ProceduralParameterSpecification(&(nd->nd_left), &(nd->nd_type)) + { nd->nd_INT = (D_VALPAR | D_SET); } | FunctionalParameterSpecification(&(nd->nd_left), &(nd->nd_type)) + { nd->nd_INT = (D_VALPAR | D_SET); } ] ; @@ -923,13 +963,19 @@ Index_TypeSpecification(register struct type **ptp, *tp;) register struct def *df1, *df2; } : IDENT - { if( df1 = define(dot.TOK_IDF, CurrentScope, D_LBOUND)) + { if( df1 = + define(dot.TOK_IDF, CurrentScope, D_LBOUND)) { df1->bnd_type = tp; /* type conf. array */ + df1->df_flags |= D_SET; + } } UPTO IDENT - { if( df2 = define(dot.TOK_IDF, CurrentScope, D_UBOUND)) + { if( df2 = + define(dot.TOK_IDF, CurrentScope, D_UBOUND)) { df2->bnd_type = tp; /* type conf. array */ + df2->df_flags |= D_SET; + } } ':' TypeIdentifier(ptp) { if( !bounded(*ptp) && diff --git a/lang/pc/comp/def.H b/lang/pc/comp/def.H index 843fc7b56..10f5e14e9 100644 --- a/lang/pc/comp/def.H +++ b/lang/pc/comp/def.H @@ -47,6 +47,11 @@ struct lab { /* ALLOCDEF "lab" 10 */ +struct used { + struct def *us_def; /* used definition */ +#define usd_def df_value.df_used.us_def +}; + struct forwtype { struct forwtype *f_next; struct node *f_node; @@ -58,10 +63,14 @@ struct forwtype { struct dfproc { /* used for procedures and functions */ struct scopelist *pc_vis; /* scope of this procedure/function */ char *pc_name; /* internal name */ + label pc_label; /* label of name (for tracing) */ arith pc_res; /* offset of function result */ + arith pc_bool; /* offset of run-time boolean */ #define prc_vis df_value.df_proc.pc_vis #define prc_name df_value.df_proc.pc_name +#define prc_label df_value.df_proc.pc_label #define prc_res df_value.df_proc.pc_res +#define prc_bool df_value.df_proc.pc_bool }; struct def { /* list of definitions for a name */ @@ -71,39 +80,46 @@ struct def { /* list of definitions for a name */ struct idf *df_idf; /* link back to the name */ struct scope *df_scope; /* scope in which this definition resides */ long df_kind; /* the kind of this definition: */ -#define D_PROCEDURE 0x00001 /* procedure */ -#define D_FUNCTION 0x00002 /* function */ -#define D_TYPE 0x00004 /* a type */ -#define D_CONST 0x00008 /* a constant */ -#define D_ENUM 0x00010 /* an enumeration literal */ -#define D_FIELD 0x00020 /* a field in a record */ -#define D_PROGRAM 0x00040 /* the program */ -#define D_VARIABLE 0x00080 /* a variable */ -#define D_PARAMETER 0x00100 /* program parameter */ -#define D_FORWTYPE 0x00200 /* forward type */ -#define D_FTYPE 0x00400 /* resolved forward type */ -#define D_FWPROCEDURE 0x00800 /* forward procedure */ -#define D_FWFUNCTION 0x01000 /* forward function */ -#define D_LABEL 0x02000 /* a label */ -#define D_LBOUND 0x04000 /* lower bound identifier in conformant array */ -#define D_UBOUND 0x08000 /* upper bound identifier in conformant array */ -#define D_FORWARD 0x10000 /* directive "forward" */ -#define D_EXTERN 0x20000 /* directive "extern" */ -#define D_ERROR 0x40000 /* a compiler generated definition for an - * undefined variable - */ +#define D_PROCEDURE 0x000001 /* procedure */ +#define D_FUNCTION 0x000002 /* function */ +#define D_TYPE 0x000004 /* a type */ +#define D_CONST 0x000008 /* a constant */ +#define D_ENUM 0x000010 /* an enumeration literal */ +#define D_FIELD 0x000020 /* a field in a record */ +#define D_PROGRAM 0x000040 /* the program */ +#define D_VARIABLE 0x000080 /* a variable */ +#define D_PARAMETER 0x000100 /* program parameter */ +#define D_FORWTYPE 0x000200 /* forward type */ +#define D_FTYPE 0x000400 /* resolved forward type */ +#define D_FWPROCEDURE 0x000800 /* forward procedure */ +#define D_FWFUNCTION 0x001000 /* forward function */ +#define D_LABEL 0x002000 /* a label */ +#define D_LBOUND 0x004000 /* lower bound id. in conform. array */ +#define D_UBOUND 0x008000 /* upper bound id. in conform. array */ +#define D_FORWARD 0x010000 /* directive "forward" */ +#define D_EXTERN 0x020000 /* directive "extern" */ +#define D_ERROR 0x040000 /* a compiler generated definition + * for an undefined variable */ +#define D_MODULE 0x080000 /* the module */ +#define D_INUSE 0x100000 /* variable is in use */ + #define D_VALUE (D_FUNCTION | D_CONST | D_ENUM | D_FIELD | D_VARIABLE\ | D_FWFUNCTION | D_LBOUND | D_UBOUND) #define D_ROUTINE (D_FUNCTION | D_FWFUNCTION | D_PROCEDURE | D_FWPROCEDURE) unsigned short df_flags; -#define D_NOREG 0x01 /* set if it may not reside in a register */ -#define D_VALPAR 0x02 /* set if it is a value parameter */ -#define D_VARPAR 0x04 /* set if it is a var parameter */ -#define D_LOOPVAR 0x08 /* set if it is a contol-variable */ -#define D_EXTERNAL 0x10 /* set if proc/func is external declared */ -#define D_PROGPAR 0x20 /* set if input/output was mentioned in - * the program-heading - */ +#define D_NOREG 0x001 /* set if it may not reside in a register */ +#define D_VALPAR 0x002 /* set if it is a value parameter */ +#define D_VARPAR 0x004 /* set if it is a var parameter */ +#define D_LOOPVAR 0x008 /* set if it is a control-variable */ +#define D_EXTERNAL 0x010 /* set if proc/func is external declared */ +#define D_PROGPAR 0x020 /* set if input/output was mentioned in + * the program-heading */ +#define D_USED 0x040 /* set when the variable is used */ +#define D_SET 0x080 /* set when the variable is set */ +#define D_INLOOP 0x100 /* set when we are inside a loop */ +#define D_WITH 0x200 /* set inside a with statement */ +#define D_SETINHIGH 0x400 /* set in a higher scope level (for loops) */ + struct type *df_type; union { struct constant df_constant; @@ -112,6 +128,7 @@ struct def { /* list of definitions for a name */ struct enumval df_enum; struct field df_field; struct lab df_label; + struct used df_used; struct forwtype *df_fwtype; struct dfproc df_proc; int df_reqname; /* define for required name */ diff --git a/lang/pc/comp/def.c b/lang/pc/comp/def.c index 124ab7d24..564d6af76 100644 --- a/lang/pc/comp/def.c +++ b/lang/pc/comp/def.c @@ -52,9 +52,16 @@ define(id, scope, kind) */ register struct def *df; - if( df = lookup(id, scope) ) { + if( df = lookup(id, scope, 0) ) { switch( df->df_kind ) { + case D_INUSE : + if( kind != D_INUSE ) { + error("\"%s\" already used in this block", + id->id_text); + } + return MkDef(id, scope, kind); + case D_LABEL : /* generate error message somewhere else */ return NULLDEF; @@ -113,7 +120,7 @@ DoDirective(directive, nd, tp, scl, function) int kind; /* kind of directive */ int inp; /* internal or external name */ int ext = 0; /* directive = EXTERN */ - struct def *df = lookup(directive, PervasiveScope); + struct def *df = lookup(directive, PervasiveScope, D_INUSE); if( !df ) { if( !is_anon_idf(directive) ) @@ -136,6 +143,7 @@ DoDirective(directive, nd, tp, scl, function) default: crash("(DoDirective)"); + /* NOTREACHED */ } if( df = define(nd->nd_IDF, CurrentScope, kind) ) { @@ -150,9 +158,10 @@ DoDirective(directive, nd, tp, scl, function) df->prc_vis = scl; df->prc_name = gen_proc_name(nd->nd_IDF, inp); if( ext ) df->df_flags |= D_EXTERNAL; + df->df_flags |= D_SET; } } - + struct def * DeclProc(nd, tp, scl) register struct node *nd; @@ -162,6 +171,7 @@ DeclProc(nd, tp, scl) register struct def *df; if( df = define(nd->nd_IDF, CurrentScope, D_PROCEDURE) ) { + df->df_flags |= D_SET; if( df->df_kind == D_FWPROCEDURE ) { df->df_kind = D_PROCEDURE; /* identification */ @@ -172,7 +182,7 @@ DeclProc(nd, tp, scl) if( tp->prc_params ) node_error(nd, - "procedure identification \"%s\" expected", + "\"%s\" already declared", nd->nd_IDF->id_text); } else { /* normal declaration */ @@ -181,6 +191,7 @@ DeclProc(nd, tp, scl) /* simulate open_scope() */ CurrVis = df->prc_vis = scl; } + routine_label(df); } else CurrVis = scl; /* simulate open_scope() */ @@ -196,11 +207,12 @@ DeclFunc(nd, tp, scl) register struct def *df; if( df = define(nd->nd_IDF, CurrentScope, D_FUNCTION) ) { + df->df_flags &= ~D_SET; if( df->df_kind == D_FUNCTION ) { /* declaration */ if( !tp ) { node_error(nd, "\"%s\" illegal function declaration", nd->nd_IDF->id_text); - tp = error_type; + tp = construct_type(T_FUNCTION, error_type); } /* simulate open_scope() */ CurrVis = df->prc_vis = scl; @@ -215,12 +227,67 @@ DeclFunc(nd, tp, scl) if( tp ) node_error(nd, - "function identification \"%s\" expected", + "\"%s\" already declared", nd->nd_IDF->id_text); } + routine_label(df); } else CurrVis = scl; /* simulate open_scope() */ return df; } + +EndFunc(df) + register struct def *df; +{ + /* assignment to functionname is illegal outside the functionblock */ + df->prc_res = 0; + + /* Give the error about assignment as soon as possible. The + * |= assignment inhibits a warning in the main procedure. + */ + if( !(df->df_flags & D_SET) ) { + error("function \"%s\" not assigned",df->df_idf->id_text); + df->df_flags |= D_SET; + } +} + +EndBlock(block_df) + register struct def *block_df; +{ + register struct def *tmp_def = CurrentScope->sc_def; + register struct def *df; + + while( tmp_def ) { + df = tmp_def; + /* The length of a usd_def chain is at most 1. + * The while is just defensive programming. + */ + while( df->df_kind & D_INUSE ) + df = df->usd_def; + + if( !is_anon_idf(df->df_idf) + && (df->df_scope == CurrentScope) ) { + if( !(df->df_kind & (D_ENUM|D_LABEL|D_ERROR)) ) { + if( !(df->df_flags & D_USED) ) { + if( !(df->df_flags & D_SET) ) { + warning("\"%s\" neither set nor used in \"%s\"", + df->df_idf->id_text, block_df->df_idf->id_text); + } + else { + warning("\"%s\" unused in \"%s\"", + df->df_idf->id_text, block_df->df_idf->id_text); + } + } + else if( !(df->df_flags & D_SET) ) { + if( !(df->df_flags & D_LOOPVAR) ) + warning("\"%s\" not set in \"%s\"", + df->df_idf->id_text, block_df->df_idf->id_text); + } + } + + } + tmp_def = tmp_def->df_nextinscope; + } +} diff --git a/lang/pc/comp/desig.c b/lang/pc/comp/desig.c index 639a85063..18ed92deb 100644 --- a/lang/pc/comp/desig.c +++ b/lang/pc/comp/desig.c @@ -16,6 +16,8 @@ #include "def.h" #include "desig.h" #include "main.h" +/* next line DEBUG */ +#include "idf.h" #include "node.h" #include "scope.h" #include "type.h" @@ -87,7 +89,7 @@ CodeMove(rhs, left, rtp) switch( rhs->dsg_kind ) { case DSG_LOADED: CodeDesig(left, lhs); - if( rtp->tp_fund == T_STRING ) { + if( rtp->tp_fund == T_STRINGCONST ) { CodeAddress(lhs); C_blm(lhs->dsg_packed ? ltp->tp_psize : ltp->tp_size); return; @@ -439,6 +441,13 @@ CodeFuncDesig(df, ds) the function (i.e. in the statement-part of a nested function or procedure). */ + if( !options['R'] ) { + C_loc((arith)1); + C_lxl((arith) (proclevel - df->df_scope->sc_level - 1)); + C_adp(df->prc_bool); + C_sti(int_size); + } + C_lxl((arith) (proclevel - df->df_scope->sc_level - 1)); ds->dsg_kind = DSG_PLOADED; } @@ -446,6 +455,11 @@ CodeFuncDesig(df, ds) /* Assignment to function-identifier in the statement-part of the function. */ + if( !options['R'] ) { + C_loc((arith)1); + C_stl(df->prc_bool); + } + ds->dsg_kind = DSG_FIXED; } assert(df->prc_res < 0); @@ -518,6 +532,9 @@ CodeDesig(nd, ds) else C_lae_dlb(tp->arr_ardescr, (arith) 0); + if( options['A'] ) { + C_cal("_rcka"); + } ds->dsg_kind = DSG_INDEXED; ds->dsg_packed = IsPacked(tp); break; diff --git a/lang/pc/comp/em_pc.6 b/lang/pc/comp/em_pc.6 index 59bb7b894..d0f55f482 100644 --- a/lang/pc/comp/em_pc.6 +++ b/lang/pc/comp/em_pc.6 @@ -4,15 +4,18 @@ em_pc \- Pascal compiler .SH SYNOPSIS .B em_pc -.RI [ option ] +.RI [ option ] .I source .I destination .SH DESCRIPTION .I Em_pc is a compiler that translates Pascal programs into EM code. +Normally the compiler is called by means of the user interface program +\fIack\fR(I). +.PP The input is taken from .IR source , -while the EM code is written on +while the EM code is written on .IR destination . .br .I Option @@ -21,6 +24,7 @@ is a, possibly empty, sequence of the following combinations: set maximum identifier length to \fIn\fP. The minimum value for \fIn\fR is 9, because the keyword "PROCEDURE" is that long. +.IR n .IP \fB\-n\fR do not generate EM register messages. The user-declared variables will not be stored into registers on the target @@ -32,7 +36,8 @@ an interpreter to keep track of the current location in the source code. .br set the size and alignment requirements. The letter \fIc\fR indicates the simple type, which is one of -\fBw\fR(word size), \fBi\fR(INTEGER), \fBf\fR(REAL), or \fBp\fR(POINTER). +\fBw\fR(word size), \fBi\fR(INTEGER), \fBl\fR(LONG), \fBr\fR(REAL), +\fBp\fR(POINTER). It may also be the letter \fBS\fR, indicating that an initial record alignment follows. The \fIm\fR parameter can be used to specify the length of the type (in bytes) @@ -40,22 +45,39 @@ and the \fIn\fR parameter for the alignment of that type. Absence of \fIm\fR or \fIn\fR causes a default value to be retained. .IP \fB\-w\fR suppress warning messages. -.IP \fB\-u\fR -The character '_' is treated like a letter, so it is allowed to use the -underscore in identifiers. -.IP \fB\-i\fR\fInum\fR -maximum number of bits in a set. When not used, a default value is -retained. +.IP +.IP \fB\-R\fR +disable range checks. Additionally, the run-time tests to see if +a function is assigned, are skipped. +.IP \fB\-A\fR +enable extra array bound checks, for machines that do not implement the +EM ones. .IP \fB\-C\fR -The lower case and upper case letters are treated different. -.IP \fB\-r\fR -The rangechecks are generated where necessary. -.LP +the lower case and upper case letters are treated differently. +.IP "\fB\-u\fR, \fB\-U\fR" +allow underscores in identifiers. It is not allowed to start an identifier +with an underscore. +.IP \fB\-a\fR +don't generate code for assertions. +.IP \fB\-c\fR +allow C-like strings. This option is mainly intended for usage with +C-functions. This option will cause the type 'string' to be known. +.IP \fB\-d\fR +allow the type 'long'. +.IP \fB\-i\fR\fIn\fR +set the size of integer sets to \fIn\fR. When not used, a default value is +retained. +.IP \fB\-s\fR +allow only standard Pascal. This disables the \fB\-c\fR, \fB\-d\fR, \fB\-u\fR, +\fB\-U\fR and \fB\-C\fR +options. Furthermore, assertions are not recognized at all (instead of just +being skipped). +.IP \fB\-t\fR +trace calls and exits of procedures and functions. +.PP .SH FILES .IR ~em/lib/em_pc : binary of the Pascal compiler. .SH DIAGNOSTICS All warning and error messages are written on standard error output. -.SH REMARKS -Debugging and profiling facilities may be present during the development -of \fIem_pc\fP. +Descriptions of run-time errors are read from ~em/etc/pc_rt_errors. diff --git a/lang/pc/comp/enter.c b/lang/pc/comp/enter.c index c3d612c0c..2a73229d5 100644 --- a/lang/pc/comp/enter.c +++ b/lang/pc/comp/enter.c @@ -23,13 +23,17 @@ Enter(name, kind, type, pnam) { /* Enter a definition for "name" with kind "kind" and type "type" in the Current Scope. If it is a standard name, also - put its number in the definition structure. + put its number in the definition structure, and mark the + name as set, to inhibit warnings about used before set. */ register struct def *df; df = define(str2idf(name, 0), CurrentScope, kind); df->df_type = type; - if( pnam ) df->df_value.df_reqname = pnam; + if( pnam ) { + df->df_value.df_reqname = pnam; + df->df_flags |= D_SET; + } return df; } @@ -45,13 +49,13 @@ EnterProgList(Idlist) !strcmp(output, idlist->nd_IDF->id_text) ) { /* the occurence of input or output as program- - * parameter is their declartion as a GLOBAL variable - * of type text + * parameter is their declaration as a GLOBAL + * variable of type text */ if( df = define(idlist->nd_IDF, CurrentScope, D_VARIABLE) ) { df->df_type = text_type; - df->df_flags |= (D_PROGPAR | D_NOREG); + df->df_flags |= (D_SET | D_PROGPAR | D_NOREG); if( !strcmp(input, idlist->nd_IDF->id_text) ) { df->var_name = input; set_inp(); @@ -67,6 +71,7 @@ EnterProgList(Idlist) D_PARAMETER) ) { df->df_type = error_type; df->df_flags |= D_PROGPAR; + df->var_name = idlist->nd_IDF->id_text; } } @@ -88,6 +93,7 @@ EnterEnumList(Idlist, type) if( df = define(idlist->nd_IDF, CurrentScope, D_ENUM) ) { df->df_type = type; df->enm_val = (type->enm_ncst)++; + df->df_flags |= D_SET; } FreeNode(Idlist); } @@ -171,7 +177,7 @@ EnterParamList(fpl, parlist) for( id = fpl->nd_left; id; id = id->nd_next ) if( df = define(id->nd_IDF, CurrentScope, D_VARIABLE) ) { df->var_off = nb_pars; - if( fpl->nd_INT == D_VARPAR || IsConformantArray(tp) ) + if( fpl->nd_INT & D_VARPAR || IsConformantArray(tp) ) nb_pars += pointer_size; else nb_pars += tp->tp_size; @@ -192,6 +198,7 @@ EnterParamList(fpl, parlist) return nb_pars; } +arith EnterParTypes(fpl, parlist) register struct node *fpl; struct paramlist **parlist; @@ -199,16 +206,30 @@ EnterParTypes(fpl, parlist) /* Parameters in heading of procedural and functional parameters (only types are important, not the names). */ + register arith nb_pars = 0; register struct node *id; + struct type *tp; struct def *df; - for( ; fpl; fpl = fpl->nd_right ) + for( ; fpl; fpl = fpl->nd_right ) { + tp = fpl->nd_type; for( id = fpl->nd_left; id; id = id->nd_next ) if( df = new_def() ) { + if( fpl->nd_INT & D_VARPAR || + IsConformantArray(tp) ) + nb_pars += pointer_size; + else + nb_pars += tp->tp_size; LinkParam(parlist, df); - df->df_type = fpl->nd_type; + df->df_type = tp; df->df_flags |= fpl->nd_INT; } + while( IsConformantArray(tp) ) { + nb_pars += 3 * word_size; + tp = tp->arr_elem; + } + } + return nb_pars; } LinkParam(parlist, df) diff --git a/lang/pc/comp/error.c b/lang/pc/comp/error.c index 340786e80..ce40ce5d5 100644 --- a/lang/pc/comp/error.c +++ b/lang/pc/comp/error.c @@ -130,7 +130,7 @@ _error(class, node, fmt, argv) static unsigned int last_ln = 0; unsigned int ln = 0; static char * last_fn = 0; - static int e_seen = 0; + static int e_seen = 0, w_seen = 0; register char *remark = 0; /* Since name and number are gathered from different places @@ -189,17 +189,25 @@ _error(class, node, fmt, argv) #endif if( FileName == last_fn && ln == last_ln ) { /* we've seen this place before */ - e_seen++; - if( e_seen == MAXERR_LINE ) fmt = "etc ..."; - else if( e_seen > MAXERR_LINE ) - /* and too often, I'd say ! */ - return; + if( class != WARNING && class != LEXWARNING ) { + e_seen++; + if( e_seen == MAXERR_LINE ) fmt = "etc ..."; + else if( e_seen > MAXERR_LINE ) + /* and too often, I'd say ! */ + return; + } + else { + w_seen++; + if( w_seen == MAXERR_LINE ) fmt = "etc ..."; + else if( w_seen > MAXERR_LINE ) + return; + } } else { /* brand new place */ last_ln = ln; last_fn = FileName; - e_seen = 0; + e_seen = w_seen = 0; } #ifdef DEBUG } diff --git a/lang/pc/comp/expression.g b/lang/pc/comp/expression.g index 0dfe6808a..3ba7e1e35 100644 --- a/lang/pc/comp/expression.g +++ b/lang/pc/comp/expression.g @@ -11,6 +11,8 @@ #include "chk_expr.h" #include "def.h" #include "main.h" +#include "misc.h" +#include "idf.h" #include "node.h" #include "scope.h" #include "type.h" @@ -49,7 +51,8 @@ UnsignedNumber(register struct node **pnd;): ; ConstantIdentifier(register struct node **pnd;): - IDENT { *pnd = MkLeaf(Name, &dot); } + IDENT { *pnd = MkLeaf(Name, &dot); + } ; /* ISO section 6.7.1, p. 121 */ @@ -98,13 +101,16 @@ Factor(register struct node **pnd;) /* This is a changed rule, because the grammar as specified in the * reference is not LL(1), and this gives conflicts. */ + %default %prefer /* solve conflicts on IDENT and UnsignedConstant */ IDENT { *pnd = MkLeaf(Name, &dot); } [ /* ISO section 6.7.3, p. 126 * IDENT is a FunctionIdentifier */ - { *pnd = MkNode(Call, *pnd, NULLNODE, &dot); } + { + *pnd = MkNode(Call, *pnd, NULLNODE, &dot); + } ActualParameterList(&((*pnd)->nd_right)) | /* IDENT can be a BoundIdentifier or a ConstantIdentifier or @@ -116,6 +122,7 @@ Factor(register struct node **pnd;) { int class; df = lookfor(*pnd, CurrVis, 1); + /* df->df_flags |= D_USED; */ if( df->df_type->tp_fund & T_ROUTINE ) { /* This part is context-sensitive: is the occurence of the proc/func name @@ -200,6 +207,7 @@ BooleanExpression(register struct node **pnd;): { if( ChkExpression(*pnd) && (*pnd)->nd_type != bool_type ) node_error(*pnd, "boolean expression expected"); + MarkUsed(*pnd); } ; diff --git a/lang/pc/comp/label.c b/lang/pc/comp/label.c index db2d8f660..ee8d11d7d 100644 --- a/lang/pc/comp/label.c +++ b/lang/pc/comp/label.c @@ -17,8 +17,9 @@ DeclLabel(nd) { struct def *df; - if( !(df = define(nd->nd_IDF, CurrentScope, D_LABEL)) ) + if( !(df = define(nd->nd_IDF, CurrentScope, D_LABEL)) ) { node_error(nd, "label %s redeclared", nd->nd_IDF->id_text); + } else { df->lab_no = ++text_label; nd->nd_def = df; @@ -74,6 +75,7 @@ TstLabel(nd, Slevel) else FreeNode(nd); + df->df_flags = D_USED; if( !df->lab_level ) { /* forward jump */ register struct lab *labelptr; @@ -105,7 +107,7 @@ DefLabel(nd, Slevel) { register struct def *df; - if( !(df = lookup(nd->nd_IDF, BlockScope)) ) { + if( !(df = lookup(nd->nd_IDF, BlockScope, D_INUSE)) ) { node_error(nd, "label %s must be declared in same block" , nd->nd_IDF->id_text); df = define(nd->nd_IDF, BlockScope, D_LABEL); @@ -116,6 +118,7 @@ DefLabel(nd, Slevel) } else FreeNode(nd); + df->df_flags |= D_SET; if( df->lab_level) node_error(nd, "label %s already defined", nd->nd_IDF->id_text); else { diff --git a/lang/pc/comp/lookup.c b/lang/pc/comp/lookup.c index 0b21704d5..d0694bda9 100644 --- a/lang/pc/comp/lookup.c +++ b/lang/pc/comp/lookup.c @@ -1,7 +1,9 @@ /* L O O K U P R O U T I N E S */ +#include #include #include +#include #include "LLlex.h" #include "def.h" @@ -11,8 +13,22 @@ #include "scope.h" #include "type.h" +remove_def(df) + register struct def *df; +{ + struct idf *id= df->df_idf; + struct def *df1 = id->id_def; + + if( df1 == df ) id->id_def = df->df_next; + else { + while( df1 && df1->df_next != df ) df1 = df1->df_next; + df1->df_next = df->df_next; + free_def(df); + } +} + struct def * -lookup(id, scope) +lookup(id, scope, inuse) register struct idf *id; struct scope *scope; { @@ -30,13 +46,22 @@ lookup(id, scope) df && df->df_scope != scope; df1 = df, df = df->df_next ) { /* nothing */ } - if( df && df1 ) { - /* Put the definition in front + if( df ) { + /* Found it */ - df1->df_next = df->df_next; - df->df_next = id->id_def; - id->id_def = df; + if( df1) { + /* Put the definition in front + */ + df1->df_next = df->df_next; + df->df_next = id->id_def; + id->id_def = df; + } + while( df->df_kind & inuse ) { + assert(df->usd_def != 0); + df=df->usd_def; + } } + return df; } @@ -49,12 +74,33 @@ lookfor(id, vis, give_error) If it is not defined create a dummy definition and if give_error is set, give an error message. */ - register struct def *df; + register struct def *df, *tmp_df; register struct scopelist *sc = vis; while( sc ) { - df = lookup(id->nd_IDF, sc->sc_scope); - if( df ) return df; + df = lookup(id->nd_IDF, sc->sc_scope, D_INUSE); + if( df ) { + while( vis->sc_scope->sc_level > + sc->sc_scope->sc_level ) { + if( tmp_df = define(id->nd_IDF, vis->sc_scope, + D_INUSE)) + tmp_df->usd_def = df; + vis = nextvisible(vis); + } + /* Since the scope-level of standard procedures is the + * same as for the user-defined procedures, the procedure + * must be marked as used. Not doing so would mean that + * such a procedure could redefined after usage. + */ + if( (vis->sc_scope == GlobalScope) && + !lookup(id->nd_IDF, GlobalScope, D_INUSE) ) { + if( tmp_df = define(id->nd_IDF, vis->sc_scope, + D_INUSE)) + tmp_df->usd_def = df; + } + + return df; + } sc = nextvisible(sc); } diff --git a/lang/pc/comp/main.c b/lang/pc/comp/main.c index 76da21697..1833b6f99 100644 --- a/lang/pc/comp/main.c +++ b/lang/pc/comp/main.c @@ -8,6 +8,7 @@ #include "LLlex.h" #include "Lpars.h" +#include "class.h" #include "const.h" #include "def.h" #include "f_info.h" @@ -48,9 +49,10 @@ main(argc, argv) Nargv[Nargc] = 0; /* terminate the arg vector */ if( Nargc < 2 ) { fprint(STDERR, "%s: Use a file argument\n", ProgName); - exit(1); + sys_stop(S_EXIT); } - exit(!Compile(Nargv[1], Nargv[2])); + if(!Compile(Nargv[1], Nargv[2])) sys_stop(S_EXIT); + sys_stop(S_END); } Compile(src, dst) @@ -58,6 +60,7 @@ Compile(src, dst) { extern struct tokenname tkidf[]; extern struct tokenname tkstandard[]; + int tk; if( !InsertFile(src, (char **) 0, &src) ) { fprint(STDERR, "%s: cannot open %s\n", ProgName, src); @@ -69,13 +72,32 @@ Compile(src, dst) InitCst(); reserve(tkidf); reserve(tkstandard); + + CheckForLineDirective(); + tk = LLlex(); /* Read the first token and put */ + aside = dot; /* it aside. In this way, options */ + asidetype = toktype; /* inside comments will be seen */ + dot.tk_symb = tk; /* before the program starts. */ + tokenseen = 1; + InitScope(); InitTypes(); AddRequired(); + + if( options['c'] ) tkclass['"'] = STSTR; + if( options['u'] || options['U'] ) { + class('_') = STIDF; + inidf['_'] = 1; + } + if( tk == '"' || tk == '_' ) { + PushBack(); + ASIDE = 0; + } + #ifdef DEBUG if( options['l'] ) { LexScan(); - return 1; + return 0; /* running the optimizer is not very useful */ } #endif DEBUG C_init(word_size, pointer_size); @@ -84,7 +106,7 @@ Compile(src, dst) C_magic(); C_ms_emx(word_size, pointer_size); C_df_dlb(++data_label); - C_rom_scon(FileName, strlen(FileName) + 1); + C_rom_scon(FileName,(arith) strlen(FileName) + 1); LLparse(); C_ms_src((arith) (LineNumber - 1), FileName); if( fp_used ) C_ms_flt(); @@ -148,6 +170,14 @@ AddRequired() /* DYNAMIC ALLOCATION PROCEDURES */ (void) Enter("new", D_PROCEDURE, std_type, R_NEW); (void) Enter("dispose", D_PROCEDURE, std_type, R_DISPOSE); + if( !options['s'] ) { + (void) Enter("mark", D_PROCEDURE, std_type, R_MARK); + (void) Enter("release", D_PROCEDURE, std_type, R_RELEASE); + } + + /* MISCELLANEOUS PROCEDURE(S) */ + if( !options['s'] ) + (void) Enter("halt", D_PROCEDURE, std_type, R_HALT); /* TRANSFER PROCEDURES */ (void) Enter("pack", D_PROCEDURE, std_type, R_PACK); @@ -187,6 +217,11 @@ AddRequired() (void) Enter("boolean", D_TYPE, bool_type, 0); (void) Enter("text", D_TYPE, text_type, 0); + if( options['d'] ) + (void) Enter("long", D_TYPE, long_type, 0); + if( options['c'] ) + (void) Enter("string", D_TYPE, string_type, 0); + /* DIRECTIVES */ (void) Enter("forward", D_FORWARD, NULLTYPE, 0); (void) Enter("extern", D_EXTERN, NULLTYPE, 0); @@ -196,13 +231,16 @@ AddRequired() df = Enter("maxint", D_CONST, int_type, 0); df->con_const = &maxintnode; + df->df_flags |= D_SET; maxintnode.nd_type = int_type; maxintnode.nd_INT = max_int; /* defined in cstoper.c */ df = Enter("true", D_ENUM, bool_type, 0); df->enm_val = 1; + df->df_flags |= D_SET; df->enm_next = Enter("false", D_ENUM, bool_type, 0); df = df->enm_next; df->enm_val = 0; + df->df_flags |= D_SET; df->enm_next = NULLDEF; } diff --git a/lang/pc/comp/misc.h b/lang/pc/comp/misc.h index cb9c9b274..ec1abe06c 100644 --- a/lang/pc/comp/misc.h +++ b/lang/pc/comp/misc.h @@ -8,3 +8,12 @@ extern struct idf extern char *gen_proc_name(); + +extern char *symbol2str(); +extern arith NewInt(); +extern arith NewPtr(); +extern arith CodeBeginBlock(); +extern arith EnterParamList(); +extern arith EnterParTypes(); +extern arith CodeInitFor(); +extern arith IsString(); diff --git a/lang/pc/comp/nmclash.c b/lang/pc/comp/nmclash.c new file mode 100644 index 000000000..ca2567a80 --- /dev/null +++ b/lang/pc/comp/nmclash.c @@ -0,0 +1,4 @@ +/* Accepted if many characters of long names are significant */ +abcdefghijklmnopr() { } +abcdefghijklmnopq() { } +main() { } diff --git a/lang/pc/comp/node.H b/lang/pc/comp/node.H index b51476ade..fabf56633 100644 --- a/lang/pc/comp/node.H +++ b/lang/pc/comp/node.H @@ -19,6 +19,8 @@ struct node { #define Link 11 #define LinkDef 12 #define Cast 13 /* convert integer to real */ +#define IntCoerc 14 /* coercion of integers to longs */ +#define IntReduc 15 /* reduction of longs to integers */ /* do NOT change the order or the numbers!!! */ struct type *nd_type; /* type of this node */ struct token nd_token; diff --git a/lang/pc/comp/options.c b/lang/pc/comp/options.c index 18753db0d..85b0789d0 100644 --- a/lang/pc/comp/options.c +++ b/lang/pc/comp/options.c @@ -8,6 +8,7 @@ #include "idfsize.h" #include "main.h" #include "type.h" +#include "nocross.h" #define MINIDFSIZE 9 @@ -28,8 +29,10 @@ DoOption(text) break; /* recognized flags: -i: largest value of set of integer - -u: allow underscore in identifier + -u, -U: allow underscore in identifier -w: no warnings + -R: no range checks + -A: range checks for array references and many more if DEBUG */ @@ -51,9 +54,10 @@ DoOption(text) idfsize = txt2int(&t); text = t; - if( idfsize <= 0 || *t ) + if( idfsize <= 0 || *t ) { fatal("malformed -M option"); /*NOTREACHED*/ + } if( idfsize > IDFSIZE ) { idfsize = IDFSIZE; warning("maximum identifier length is %d", IDFSIZE); @@ -65,14 +69,15 @@ DoOption(text) break; } - case 'u': /* underscore allowed in identifiers */ - class('_') = STIDF; - inidf['_'] = 1; - break; + /* case 'u': /* underscore allowed in identifiers */ + /* class('_') = STIDF; + /* inidf['_'] = 1; + /* break; + */ case 'V' : { /* set object sizes and alignment requirements */ - /* syntax : -V[ [w|i|f|p] size? [.alignment]? ]* */ - + /* syntax : -V[ [w|i|l|f|p] size? [.alignment]? ]* */ +#ifndef NOCROSS register arith size; register int align; char c, *t; @@ -88,7 +93,7 @@ DoOption(text) align = txt2int(&t); text = t; } - if( !strindex("wifpS", c) ) + if( !strindex("wilfpS", c) ) error("-V: bad type indicator %c\n", c); if( size ) switch( c ) { @@ -98,6 +103,9 @@ DoOption(text) case 'i': /* int */ int_size = size; break; + case 'l': /* long */ + long_size = size; + break; case 'f': /* real */ real_size = size; break; @@ -117,6 +125,9 @@ DoOption(text) case 'i': /* int */ int_align = align; break; + case 'l': /* long */ + long_align = align; + break; case 'f': /* real */ real_align = align; break; @@ -129,6 +140,7 @@ DoOption(text) } } break; +#endif NOCROSS } } } diff --git a/lang/pc/comp/program.g b/lang/pc/comp/program.g index faa1d50b2..594b585a3 100644 --- a/lang/pc/comp/program.g +++ b/lang/pc/comp/program.g @@ -7,6 +7,8 @@ #include "LLlex.h" #include "def.h" +#include "f_info.h" +#include "idf.h" #include "main.h" #include "node.h" #include "scope.h" @@ -20,8 +22,18 @@ Program { struct def *df; + arith dummy; }: ProgramHeading(&df) ';' Block(df) '.' + | { df = new_def(); + df->df_idf = str2idf(FileName, 1); + df->df_kind = D_MODULE; + open_scope(); + GlobalScope = CurrentScope; + df->prc_vis = CurrVis; + } + + Module(df, &dummy) ; ProgramHeading(register struct def **df;): @@ -37,6 +49,7 @@ ProgramHeading(register struct def **df;): '(' ProgramParameters ')' + { make_extfl(); } ]? ; diff --git a/lang/pc/comp/progs.c b/lang/pc/comp/progs.c index 0b7dfbdc6..fde2e2f12 100644 --- a/lang/pc/comp/progs.c +++ b/lang/pc/comp/progs.c @@ -1,6 +1,7 @@ #include "debug.h" #include +#include #include "LLlex.h" #include "def.h" @@ -25,35 +26,53 @@ set_outp() make_extfl() { - register struct def *df; + if( err_occurred ) return; extfl_label = ++data_label; C_df_dlb(extfl_label); - if( inpflag ) + if( inpflag ) { + C_ina_dnam(input); C_con_dnam(input, (arith) 0); + } else C_con_ucon("0", pointer_size); - if( outpflag ) + if( outpflag ) { + C_ina_dnam(output); C_con_dnam(output, (arith) 0); + } else C_con_ucon("0", pointer_size); extflc = 2; - for( df = GlobalScope->sc_def; df; df = df->df_nextinscope ) - if( (df->df_flags & D_PROGPAR) && - df->var_name != input && df->var_name != output) { - C_con_dnam(df->var_name, (arith) 0); - extflc++; - } + /* Process the identifiers in the global scope (at this point only + * the program parameters) in order of specification. + */ + make_extfl_args( GlobalScope->sc_def ); +} + +make_extfl_args(df) + register struct def *df; +{ + if( !df ) return; + make_extfl_args(df->df_nextinscope); + assert(df->df_flags & D_PROGPAR); + if( df->var_name != input && df->var_name != output ) { + C_ina_dnam(df->var_name); + C_con_dnam(df->var_name, (arith) 0); + extflc++; + } } call_ini() { C_lxl((arith) 0); - C_lae_dlb(extfl_label, (arith) 0); + if( extflc ) + C_lae_dlb(extfl_label, (arith) 0); + else + C_zer(pointer_size); C_loc((arith) extflc); C_lxa((arith) 0); C_cal("_ini"); diff --git a/lang/pc/comp/readwrite.c b/lang/pc/comp/readwrite.c index 4afb2c513..c2a41de9f 100644 --- a/lang/pc/comp/readwrite.c +++ b/lang/pc/comp/readwrite.c @@ -8,15 +8,21 @@ #include "LLlex.h" #include "def.h" #include "main.h" +#include "misc.h" #include "node.h" #include "scope.h" #include "type.h" +/* DEBUG */ +#include "idf.h" + ChkRead(arg) register struct node *arg; { struct node *file; char *name = "read"; + char *message, buff[80]; + extern char *ChkAllowedVar(); assert(arg); assert(arg->nd_symb == ','); @@ -43,6 +49,19 @@ ChkRead(arg) "\"%s\": illegal parameter type",name); return; } + else if( (BaseType(file->nd_type->next) == long_type + && arg->nd_left->nd_type == int_type) + || + (BaseType(file->nd_type->next) == int_type + && arg->nd_left->nd_type == long_type) ) { + if( int_size != long_size ) { + node_error(arg->nd_left, + "\"%s\": longs and integers have different sizes",name); + return; + } + else node_warning(arg->nd_left, + "\"%s\": mixture of longs and integers", name); + } } else if( !(BaseType(arg->nd_left->nd_type)->tp_fund & ( T_CHAR | T_NUMERIC )) ) { @@ -50,6 +69,14 @@ ChkRead(arg) "\"%s\": illegal parameter type",name); return; } + message = ChkAllowedVar(arg->nd_left, 1); + if( message ) { + sprint(buff,"\"%%s\": %s can't be a variable parameter", + message); + node_error(arg->nd_left, buff, name); + return; + } + CodeRead(file, arg->nd_left); arg = arg->nd_right; } @@ -60,6 +87,8 @@ ChkReadln(arg) { struct node *file; char *name = "readln"; + char *message, buff[80]; + extern char *ChkAllowedVar(); if( !arg ) { if( !(file = ChkStdInOut(name, 0)) ) @@ -95,6 +124,13 @@ ChkReadln(arg) "\"%s\": illegal parameter type",name); return; } + message = ChkAllowedVar(arg->nd_left, 1); + if( message ) { + sprint(buff,"\"%%s\": %s can't be a variable parameter", + message); + node_error(arg->nd_left, buff, name); + return; + } CodeRead(file, arg->nd_left); arg = arg->nd_right; } @@ -203,8 +239,9 @@ ChkWriteParameter(filetype, arg, name) tp = BaseType(arg->nd_left->nd_type); if( filetype == text_type ) { - if( !(tp == bool_type || tp->tp_fund & (T_CHAR | T_NUMERIC) || - IsString(tp)) ) { + if( !(tp == bool_type || + tp->tp_fund & (T_CHAR | T_NUMERIC | T_STRING) || + IsString(tp)) ) { node_error(arg->nd_left, "\"%s\": %s", name, mess); return 0; } @@ -259,8 +296,9 @@ ChkStdInOut(name, st_out) register struct def *df; register struct node *nd; - if( !(df = lookup(str2idf(st_out ? output : input, 0), GlobalScope)) || - !(df->df_flags & D_PROGPAR) ) { + if( !(df = lookup(str2idf(st_out ? output : input, 0), + GlobalScope, D_INUSE)) || + !(df->df_flags & D_PROGPAR) ) { error("\"%s\": standard input/output not defined", name); return NULLNODE; } @@ -268,6 +306,7 @@ ChkStdInOut(name, st_out) nd = MkLeaf(Def, &dot); nd->nd_def = df; nd->nd_type = df->df_type; + df->df_flags |= D_USED; return nd; } @@ -291,6 +330,10 @@ CodeRead(file, arg) C_cal("_rdi"); break; + case T_LONG: + C_cal("_rdl"); + break; + case T_REAL: C_cal("_rdr"); break; @@ -314,9 +357,11 @@ CodeRead(file, arg) RangeCheck(arg->nd_type, file->nd_type->next); C_loi(file->nd_type->next->tp_psize); - if( BaseType(file->nd_type->next) == int_type && - tp == real_type ) - Int2Real(); + if( tp == real_type ) { + if( BaseType(file->nd_type->next) == int_type || + BaseType(file->nd_type->next) == long_type ) + Int2Real(file->nd_type->next->tp_psize); + } CodeDStore(arg); C_cal("_get"); @@ -349,7 +394,7 @@ CodeWrite(file, arg) CodePExpr(expp); if( file->nd_type == text_type ) { - if( tp->tp_fund & (T_ARRAY | T_STRING) ) { + if( tp->tp_fund & (T_ARRAY | T_STRINGCONST) ) { C_loc(IsString(tp)); nbpars += pointer_size + int_size; } @@ -375,6 +420,10 @@ CodeWrite(file, arg) C_cal(width ? "_wsi" : "_wri"); break; + case T_LONG: + C_cal(width ? "_wsl" : "_wrl"); + break; + case T_REAL: if( right ) { CodePExpr(right->nd_left); @@ -385,19 +434,25 @@ CodeWrite(file, arg) break; case T_ARRAY: - case T_STRING: + case T_STRINGCONST: C_cal(width ? "_wss" : "_wrs"); break; + case T_STRING: + C_cal(width ? "_wsz" : "_wrz"); + break; + default: - crash("CodeWrite)"); + crash("(CodeWrite)"); /*NOTREACHED*/ } C_asp(nbpars); } else { if( file->nd_type->next == real_type && tp == int_type ) - Int2Real(); + Int2Real(int_size); + else if( file->nd_type->next == real_type && tp == long_type ) + Int2Real(long_size); CodeDAddress(file); C_cal("_wdw"); diff --git a/lang/pc/comp/required.h b/lang/pc/comp/required.h index 1a0bb669a..20b9a5fad 100644 --- a/lang/pc/comp/required.h +++ b/lang/pc/comp/required.h @@ -11,33 +11,38 @@ /* DYNAMIC ALLOCATION */ #define R_NEW 6 #define R_DISPOSE 7 +#define R_MARK 8 +#define R_RELEASE 9 + +/* MISCELLANEOUS PROCEDURE(S) */ +#define R_HALT 10 /* TRANSFER */ -#define R_PACK 8 -#define R_UNPACK 9 +#define R_PACK 11 +#define R_UNPACK 12 /* FUNCTIONS */ /* ARITHMETIC */ -#define R_ABS 10 -#define R_SQR 11 -#define R_SIN 12 -#define R_COS 13 -#define R_EXP 14 -#define R_LN 15 -#define R_SQRT 16 -#define R_ARCTAN 17 +#define R_ABS 13 +#define R_SQR 14 +#define R_SIN 15 +#define R_COS 16 +#define R_EXP 17 +#define R_LN 18 +#define R_SQRT 19 +#define R_ARCTAN 20 /* TRANSFER */ -#define R_TRUNC 18 -#define R_ROUND 19 +#define R_TRUNC 21 +#define R_ROUND 22 /* ORDINAL */ -#define R_ORD 20 -#define R_CHR 21 -#define R_SUCC 22 -#define R_PRED 23 +#define R_ORD 23 +#define R_CHR 24 +#define R_SUCC 25 +#define R_PRED 26 /* BOOLEAN */ -#define R_ODD 24 -#define R_EOF 25 -#define R_EOLN 26 +#define R_ODD 27 +#define R_EOF 28 +#define R_EOLN 29 diff --git a/lang/pc/comp/scope.c b/lang/pc/comp/scope.c index 3f4f70f7a..bd635a7ef 100644 --- a/lang/pc/comp/scope.c +++ b/lang/pc/comp/scope.c @@ -80,7 +80,7 @@ chk_prog_params() if( df->df_kind & D_PARAMETER ) { if( !is_anon_idf(df->df_idf) ) { if( df->df_type == error_type ) - error("program parameter \"%s\" must be a global variable", + error("program parameter \"%s\" must be a global variable", df->df_idf->id_text); else if( df->df_type->tp_fund != T_FILE ) error("program parameter \"%s\" must have a file type", diff --git a/lang/pc/comp/statement.g b/lang/pc/comp/statement.g index c4a326d64..e9cff0332 100644 --- a/lang/pc/comp/statement.g +++ b/lang/pc/comp/statement.g @@ -7,8 +7,10 @@ #include "chk_expr.h" #include "def.h" #include "desig.h" +#include "f_info.h" #include "idf.h" #include "main.h" +#include "misc.h" #include "node.h" #include "scope.h" #include "type.h" @@ -57,11 +59,14 @@ Statement SimpleStatement { struct node *pnd, *expp; + unsigned short line; } : /* This is a changed rule, because the grammar as specified in the * reference is not LL(1), and this gives conflicts. * Note : the grammar states : AssignmentStatement | * ProcedureStatement | ... + * In order to add assertions, there is an extra entry, which gives + * a conflict. This conflict is then resolved using an %if clause. */ EmptyStatement | @@ -69,13 +74,20 @@ SimpleStatement | /* Evidently this is the beginning of the changed part */ + %if( !options['s'] && !strcmp(dot.TOK_IDF->id_text, "assert") ) + IDENT { line = LineNumber; } + Expression(&expp) + { AssertStat(expp, line); } +| IDENT { pnd = MkLeaf(Name, &dot); } - [ + [ %default + /* At this point the IDENT can be a FunctionIdentifier in * which case the VariableAccessTail must be empty. */ VariableAccessTail(&pnd) [ + %default BECOMES | '=' { error("':=' expected instead of '='"); } @@ -92,6 +104,7 @@ SimpleStatement FreeNode(pnd); } + ] | InputOutputStatement @@ -353,6 +366,7 @@ ForStatement Statement { if( !err_occurred ) CodeEndFor(nd, stepsize, l1, l2, tmp2); + EndForStat(nd); chk_labels(slevel + 1); FreeNode(nd); if( tmp1 ) FreeInt(tmp1); @@ -415,6 +429,7 @@ WriteParameter(register struct node **pnd;) Expression(pnd) { if( !ChkExpression(*pnd) ) (*pnd)->nd_type = error_type; + MarkUsed(*pnd); *pnd = nd = MkNode(Link, *pnd, NULLNODE, &dot); nd->nd_symb = ':'; @@ -428,6 +443,7 @@ WriteParameter(register struct node **pnd;) Expression(&(nd->nd_left)) { if( !ChkExpression(nd->nd_left) ) nd->nd_left->nd_type = error_type; + MarkUsed(nd->nd_left); } [ ':' { nd->nd_right = MkLeaf(Link, &dot); @@ -436,6 +452,7 @@ WriteParameter(register struct node **pnd;) Expression(&(nd->nd_left)) { if( !ChkExpression(nd->nd_left) ) nd->nd_left->nd_type = error_type; + MarkUsed(nd->nd_left); } ]? ]? diff --git a/lang/pc/comp/type.H b/lang/pc/comp/type.H index 117c062b1..c6ce93d1f 100644 --- a/lang/pc/comp/type.H +++ b/lang/pc/comp/type.H @@ -77,17 +77,19 @@ struct type { #define T_PROCEDURE 0x0010 #define T_FUNCTION 0x0020 #define T_FILE 0x0040 -#define T_STRING 0x0080 +#define T_STRINGCONST 0x0080 #define T_SUBRANGE 0x0100 #define T_SET 0x0200 #define T_ARRAY 0x0400 #define T_RECORD 0x0800 #define T_POINTER 0x1000 -#define T_ERROR 0x2000 /* bad type */ -#define T_NUMERIC (T_INTEGER | T_REAL) -#define T_INDEX (T_SUBRANGE | T_ENUMERATION | T_CHAR) -#define T_ORDINAL (T_INTEGER | T_INDEX) -#define T_CONSTRUCTED (T_ARRAY | T_SET | T_RECORD | T_FILE | T_STRING) +#define T_LONG 0x2000 +#define T_STRING 0x4000 +#define T_ERROR 0x8000 /* bad type */ +#define T_NUMERIC (T_INTEGER | T_REAL | T_LONG) +#define T_INDEX (T_SUBRANGE | T_ENUMERATION | T_CHAR | T_INTEGER ) +#define T_ORDINAL (T_INDEX | T_LONG) +#define T_CONSTRUCTED (T_ARRAY | T_SET | T_RECORD | T_FILE | T_STRINGCONST) #define T_ROUTINE (T_FUNCTION | T_PROCEDURE) unsigned short tp_flags; #define T_HASFILE 0x1 /* set if type has a filecomponent */ @@ -112,16 +114,35 @@ extern struct type *bool_type, *char_type, *int_type, + *long_type, *real_type, + *string_type, *std_type, *text_type, *nil_type, *emptyset_type, *error_type; /* All from type.c */ +#include "nocross.h" +#ifdef NOCROSS +#include "target_sizes.h" +#define word_align (AL_WORD) +#define int_align (AL_INT) +#define long_align (AL_LONG) +#define pointer_align (AL_POINTER) +#define real_align (AL_REAL) +#define struct_align (AL_STRUCT) + +#define word_size (SZ_WORD) +#define int_size (SZ_INT) +#define long_size (SZ_LONG) +#define pointer_size (SZ_POINTER) +#define real_size (SZ_REAL) +#else NOCROSS extern int word_align, int_align, + long_align, pointer_align, real_align, struct_align; /* All from type.c */ @@ -129,8 +150,10 @@ extern int extern arith word_size, int_size, + long_size, pointer_size, real_size; /* All from type.c */ +#endif NOCROSS extern arith align(); diff --git a/lang/pc/comp/type.c b/lang/pc/comp/type.c index c9c8128e1..968003fdd 100644 --- a/lang/pc/comp/type.c +++ b/lang/pc/comp/type.c @@ -1,7 +1,6 @@ /* T Y P E D E F I N I T I O N M E C H A N I S M */ #include "debug.h" -#include "target_sizes.h" #include #include @@ -18,9 +17,12 @@ #include "scope.h" #include "type.h" +#ifndef NOCROSS +#include "target_sizes.h" int word_align = AL_WORD, int_align = AL_INT, + long_align = AL_LONG, pointer_align = AL_POINTER, real_align = AL_REAL, struct_align = AL_STRUCT; @@ -28,29 +30,63 @@ int arith word_size = SZ_WORD, int_size = SZ_INT, + long_size = SZ_LONG, pointer_size = SZ_POINTER, real_size = SZ_REAL; +#endif NOCROSS + +extern arith max_int; struct type *bool_type, *char_type, *int_type, + *long_type, *real_type, + *string_type, *std_type, *text_type, *nil_type, *emptyset_type, *error_type; -InitTypes() +CheckTypeSizes() { - /* Initialize the predefined types - */ - /* first, do some checking */ if( int_size != word_size ) fatal("integer size not equal to word size"); + if( word_size != 2 && word_size != 4 ) + fatal("illegal wordsize"); + if( pointer_size != 2 && pointer_size != 4 ) + fatal("illegal pointersize"); + if( options['d'] ) { + if( long_size < int_size ) + fatal("longsize should be at least the integersize"); + if( long_size > 2 * int_size) + fatal("longsize should be at most twice the integersize"); + } + if( pointer_size < word_size ) + fatal("pointersize should be at least the wordsize"); + if( real_size != 4 && real_size != 8 ) + fatal("illegal realsize"); +} + +InitTypes() +{ + /* First check the sizes of some basic EM-types + */ + CheckTypeSizes(); + if( options['s'] ) { + options['c'] = 0; + options['d'] = 0; + options['u'] = 0; + options['C'] = 0; + options['U'] = 0; + } + + /* Initialize the predefined types + */ /* character type */ @@ -70,6 +106,16 @@ InitTypes() */ real_type = standard_type(T_REAL, real_align, real_size); + /* long type + */ + if( options['d'] ) + long_type = standard_type(T_LONG, long_align, long_size); + + /* string type + */ + if( options['c'] ) + string_type = standard_type(T_STRING, pointer_align, pointer_size); + /* an unique type for standard procedures and functions */ std_type = construct_type(T_PROCEDURE, NULLTYPE); @@ -94,6 +140,13 @@ InitTypes() emptyset_type->tp_align = word_align; } +int +fit(sz, nbytes) + arith sz; +{ + return ((sz) + ((arith)0x80<<(((nbytes)-1)*8)) & ~full_mask[(nbytes)]) == 0; +} + struct type * standard_type(fund, algn, size) arith size; @@ -184,19 +237,24 @@ chk_type_id(ptp, nd) register struct type **ptp; register struct node *nd; { + register struct def *df; + *ptp = error_type; if( ChkLinkOrName(nd) ) { if( nd->nd_class != Def ) node_error(nd, "type expected"); else { - register struct def *df = nd->nd_def; + /* register struct def *df = nd->nd_def; */ + df = nd->nd_def; - if( df->df_kind & (D_TYPE | D_FTYPE | D_ERROR) ) + df->df_flags |= D_USED; + if( df->df_kind & (D_TYPE | D_FTYPE | D_ERROR) ) { if( !df->df_type ) node_error(nd, "type \"%s\" not declared", df->df_idf->id_text); else *ptp = df->df_type; + } else node_error(nd,"identifier \"%s\" is not a type", df->df_idf->id_text); @@ -253,7 +311,11 @@ getbounds(tp, plo, phi) *plo = tp->sub_lb; *phi = tp->sub_ub; } - else { + else if( tp->tp_fund & T_INTEGER ) { + *plo = -max_int; + *phi = max_int; + } + else { *plo = 0; *phi = tp->enm_ncst - 1; } @@ -350,7 +412,10 @@ ArrayElSize(tp, packed) /* algn is not a dividor of the word size, so make sure it is a multiple */ - return WA(algn); + algn = WA(algn); + } + if( !fit(algn, (int) word_size) ) { + error("element of array too large"); } return algn; } @@ -362,10 +427,10 @@ ArraySizes(tp) */ register struct type *index_type = IndexType(tp); register struct type *elem_type = tp->arr_elem; - arith lo, hi; + arith lo, hi, diff; tp->tp_flags |= T_CHECKED; - tp->arr_elsize = ArrayElSize(elem_type, IsPacked(tp)); + tp->arr_elsize = ArrayElSize(elem_type,(int) IsPacked(tp)); /* check index type */ @@ -378,8 +443,17 @@ ArraySizes(tp) } getbounds(index_type, &lo, &hi); + diff = hi - lo; - tp->tp_psize = (hi - lo + 1) * tp->arr_elsize; + if( diff < 0 || !fit(diff, (int) word_size) ) { + error("too many elements in array"); + } + + if( (unsigned long)full_mask[(int) pointer_size]/(diff + 1) < + tp->arr_elsize ) { + error("array too large"); + } + tp->tp_psize = (diff + 1) * tp->arr_elsize; tp->tp_palign = (word_size % tp->tp_psize) ? word_align : tp->tp_psize; tp->tp_size = WA(tp->tp_psize); tp->tp_align = word_align; @@ -389,7 +463,7 @@ ArraySizes(tp) tp->arr_ardescr = ++data_label; C_df_dlb(data_label); C_rom_cst(lo); - C_rom_cst(hi - lo); + C_rom_cst(diff); C_rom_cst(tp->arr_elsize); } @@ -424,14 +498,15 @@ chk_forw_types() while( scl ) { /* look in enclosing scopes */ df1 = lookup(df->df_fortype->f_node->nd_IDF, - scl->sc_scope); + scl->sc_scope, D_INUSE); if( df1 ) break; scl = nextvisible( scl ); } - if( !df1 || df1->df_kind != D_TYPE ) + if( !df1 || df1->df_kind != D_TYPE ) { /* bad forward type */ tp = error_type; + } else { /* ok */ tp = df1->df_type; @@ -440,6 +515,9 @@ chk_forw_types() CurrentScope->sc_def = df->df_nextinscope; else ldf->df_nextinscope = df->df_nextinscope; + + /* remove the def struct from symbol-table */ + remove_def(df); } } else /* forward type was resolved */ @@ -455,6 +533,7 @@ chk_forw_types() } FreeForward( df->df_fortype ); + df->df_flags |= D_USED; if( tp == error_type ) df->df_kind = D_ERROR; else @@ -540,10 +619,14 @@ DumpType(tp) print("ENUMERATION; ncst:%d", tp->enm_ncst); break; case T_INTEGER: print("INTEGER"); break; + case T_LONG: + print("LONG"); break; case T_REAL: print("REAL"); break; case T_CHAR: print("CHAR"); break; + case T_STRING: + print("STRING"); break; case T_PROCEDURE: case T_FUNCTION: { @@ -565,8 +648,8 @@ DumpType(tp) } case T_FILE: print("FILE"); break; - case T_STRING: - print("STRING"); break; + case T_STRINGCONST: + print("STRINGCONST"); break; case T_SUBRANGE: print("SUBRANGE %ld-%ld", (long) tp->sub_lb, (long) tp->sub_ub); break; diff --git a/lang/pc/comp/typequiv.c b/lang/pc/comp/typequiv.c index 860a4de10..bdc8b068e 100644 --- a/lang/pc/comp/typequiv.c +++ b/lang/pc/comp/typequiv.c @@ -21,7 +21,6 @@ TstTypeEquiv(tp1, tp2) { /* test if two types are equivalent. */ - return tp1 == tp2 || tp1 == error_type || tp2 == error_type; } @@ -30,7 +29,7 @@ IsString(tp) register struct type *tp; { /* string = packed array[1..ub] of char and ub > 1 */ - if( tp->tp_fund & T_STRING ) return tp->tp_psize; + if( tp->tp_fund & T_STRINGCONST ) return tp->tp_psize; if( IsConformantArray(tp) ) return 0; @@ -94,6 +93,13 @@ TstCompat(tp1, tp2) else return 0; } + /* no clause, just check for longs and ints */ + /* BaseType is used in case of array indexing */ + if ((BaseType(tp1) == int_type && tp2 == long_type) || + (tp1 == long_type && tp2 == int_type)) + return 1; + + /* clause b */ tp1 = BaseType(tp1); tp2 = BaseType(tp2); @@ -114,7 +120,7 @@ TstAssCompat(tp1, tp2) /* clause b */ if( tp1 == real_type ) - return BaseType(tp2) == int_type; + return BaseType(tp2) == int_type || BaseType(tp2) == long_type; return 0; } @@ -247,7 +253,7 @@ TstConform(formaltype, actualtype, new_par_section) lastactual = actualtype; - if( actualtype->tp_fund == T_STRING ) { + if( actualtype->tp_fund == T_STRINGCONST ) { actualindextp = int_type; alb = 1; aub = actualtype->tp_psize; @@ -271,7 +277,8 @@ TstConform(formaltype, actualtype, new_par_section) return 0; /* clause (b) */ - if( bounded(actualindextp) || actualindextp->tp_fund == T_STRING ) { + if( bounded(actualindextp) || + actualindextp->tp_fund == T_STRINGCONST ) { /* test was necessary because the actual type could be confor- mant !! */