Bladeren bron

Many improvements by Hans van Eck

ceriel 35 jaren geleden
bovenliggende
commit
5ce88603df

+ 2 - 0
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

+ 178 - 14
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;

+ 1 - 0
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

+ 6 - 2
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 *)

+ 165 - 46
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

+ 12 - 6
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 */

+ 60 - 0
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 <<EOF
+
+$i:	clashes $PW/$i
+	\$(CID) -Fclashes < $PW/$i > $i
+EOF
+done
+make EMHOME=$EMHOME CURRDIR=$currdir/ COPTIONS=$options $target

+ 1 - 0
lang/pc/comp/Version.c

@@ -0,0 +1 @@
+static char Version[] = "ACK Pascal compiler Version 2.2";

+ 140 - 16
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);
 }

+ 1 - 0
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");

+ 206 - 46
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,24 +672,18 @@ ChkSet(expp)
 	return 1;
 }
 
-ChkVarPar(nd, name)
-	register struct node *nd, *name;
+char *
+ChkAllowedVar(nd, reading)		/* reading indicates read or readln */
+	register struct node *nd;
 {
-	/* 	ISO 6.6.3.3 :
-		An actual variable parameter shall not denote a field
-		that is the selector of a variant-part or a component
-		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];
-	char *message = (char *) 0;
-	extern char *sprint();
-
-	if( !ChkVariable(nd) ) return 0;
+	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 */
 
@@ -626,27 +691,49 @@ ChkVarPar(nd, name)
 		assert(nd->nd_def->df_kind == D_FIELD);
 
 		if( nd->nd_def->fld_flags & F_PACKED )
-			message = "field of packed record %s";
+			message = "field of packed record";
 		else if( nd->nd_def->fld_flags & F_SELECTOR )
-			message = "variant selector %s";
+			message = "variant selector";
 		break;
 
 	case Arrsel:
 		if( IsPacked(nd->nd_left->nd_type) )
-			message = "component of packed array %s";
+			if( !reading ) message = "component of packed array";
 		break;
 
 	case Arrow:
 		if( nd->nd_right->nd_type->tp_fund == T_FILE )
-			message = "filebuffer variable %s";
+			message = "filebuffer variable";
 		break;
 
 	default:
-		crash("(ChkVarPar)");
+		crash("(ChkAllowedVar)");
 		/*NOTREACHED*/
 	}
+	MarkDef(nd, D_SET, 1);
+	return message;
+}
+
+int
+ChkVarPar(nd, name)
+	register struct node *nd, *name;
+{
+	/* 	ISO 6.6.3.3 :
+		An actual variable parameter shall not denote a field
+		that is the selector of a variant-part or a component
+		of a variable where that variable possesses a type
+		that is designated packed.
+	*/
+	static char err_mes[80];
+	char *message = (char *) 0;
+	extern char *sprint();
+
+	if( !ChkVariable(nd) ) return 0;
+
+	message = ChkAllowedVar(nd, 0);
+
 	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
 };

+ 151 - 22
lang/pc/comp/code.c

@@ -4,12 +4,16 @@
 #include	<assert.h>
 #include	<em.h>
 #include	<em_reg.h>
+#include	<em_abs.h>
 
 #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 integer to real */
+	/* 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(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);
 

+ 54 - 5
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;

+ 97 - 51
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	<alloc.h>
 #include	<assert.h>
 #include	<em_arith.h>
 #include	<em_label.h>
+#include	<pc_file.h>
 
 #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) &&

+ 46 - 29
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 */

+ 73 - 6
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;
+	}
+}

+ 18 - 1
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;

+ 38 - 16
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.

+ 29 - 8
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)

+ 15 - 7
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
 	}

+ 10 - 2
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);
 			}
 ;
 

+ 5 - 2
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	{

+ 55 - 9
lang/pc/comp/lookup.c

@@ -1,7 +1,9 @@
 /* L O O K U P   R O U T I N E S */
 
+#include	<alloc.h>
 #include	<em_arith.h>
 #include	<em_label.h>
+#include	<assert.h>
 
 #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);
 	}
 

+ 42 - 4
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;
 }
 

+ 9 - 0
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();

+ 4 - 0
lang/pc/comp/nmclash.c

@@ -0,0 +1,4 @@
+/* Accepted if many characters of long names are significant */
+abcdefghijklmnopr() { }
+abcdefghijklmnopq() { }
+main() { }

+ 2 - 0
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;

+ 21 - 9
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
 	}
 	}
 }

+ 13 - 0
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(); }
 	]?
 ;
 

+ 29 - 10
lang/pc/comp/progs.c

@@ -1,6 +1,7 @@
 #include	"debug.h"
 
 #include	<em.h>
+#include	<assert.h>
 
 #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");

+ 66 - 11
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");

+ 24 - 19
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

+ 1 - 1
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",

+ 18 - 1
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);
 					}
 		]?
 	]?

+ 29 - 6
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();

+ 100 - 17
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	<alloc.h>
 #include	<assert.h>
@@ -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;

+ 12 - 5
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 !!
 		*/