Initial revision

lang/pc/comp/.distr

@@ -0,0 +1,59 @@
+LLlex.c
+LLlex.h
+LLmessage.c
+Makefile
+Parameters
+body.c
+casestat.C
+char.c
+char.tab
+chk_expr.c
+chk_expr.h
+class.h
+code.c
+const.h
+cstoper.c
+debug.h
+declar.g
+def.H
+def.c
+desig.H
+desig.c
+em_pc.6
+enter.c
+error.c
+expression.g
+f_info.h
+idf.c
+idf.h
+input.c
+input.h
+label.c
+lookup.c
+main.c
+main.h
+make.allocd
+make.hfiles
+make.next
+make.tokcase
+make.tokfile
+misc.c
+misc.h
+next.c
+node.H
+node.c
+options.c
+program.g
+progs.c
+readwrite.c
+required.h
+scope.H
+scope.c
+statement.g
+tab.c
+tmpvar.C
+tokenname.c
+tokenname.h
+type.H
+type.c
+typequiv.c

lang/pc/comp/LLlex.c

@@ -0,0 +1,411 @@
+/* L E X I C A L   A N A L Y S E R   F O R   I S O - P A S C A L */
+
+#include	"debug.h"
+#include	"idfsize.h"
+#include	"numsize.h"
+#include	"strsize.h"
+
+#include	<alloc.h>
+#include	<em_arith.h>
+#include	<em_label.h>
+
+#include	"LLlex.h"
+#include	"Lpars.h"
+#include	"class.h"
+#include	"const.h"
+#include	"f_info.h"
+#include	"idf.h"
+#include	"input.h"
+#include	"main.h"
+#include	"type.h"
+
+extern long	str2long();
+extern char	*Malloc();
+
+#define	TO_LOWER(ch)	(ch |= ( ch>='A' && ch<='Z' ) ? 0x0020 : 0)
+
+#ifdef DEBUG
+extern int cntlines;
+#endif
+
+int idfsize = IDFSIZE;
+struct token	dot,
+		aside;
+
+struct type	*toktype,
+		*asidetype;
+
+static int	eofseen;
+
+STATIC
+SkipComment()
+{
+	/*	Skip ISO-Pascal comments (* ... *) or { ... }.
+		Note :
+			comments may not be nested (ISO 6.1.8).
+			(* and { are interchangeable, so are *) and }.
+	*/
+	register int ch;
+
+	LoadChar(ch);
+	for (;;)	{
+		if( class(ch) == STNL )	{
+			LineNumber++;
+#ifdef DEBUG
+			cntlines++;
+#endif
+		}
+		else if( ch == '*' )	{
+			LoadChar(ch);
+			if( ch == ')' ) return;		/* *) */
+			else continue;
+		}
+		else if( ch == '}' ) return;
+		else if( ch == EOI )	{
+			lexerror("unterminated comment");
+			break;
+		}
+		LoadChar(ch);
+	}
+}
+
+STATIC struct string *
+GetString()
+{
+	/*	Read a Pascal string, delimited by the character "'".
+	*/
+	register int ch;
+	register struct string *str = (struct string *)
+				Malloc((unsigned) sizeof(struct string));
+	register char *p;
+	register int len = ISTRSIZE;
+	
+	str->s_str = p = Malloc((unsigned int) ISTRSIZE);
+	for( ; ; )	{
+		LoadChar(ch);
+		if( ch & 0200 )
+			fatal("non-ascii '\\%03o' read", ch & 0377);
+			/*NOTREACHED*/
+		if( class(ch) == STNL )	{
+			lexerror("newline in string");
+			LineNumber++;
+#ifdef DEBUG
+			cntlines++;
+#endif
+			break;
+		}
+		if( ch == EOI )	{
+			lexerror("end-of-file in string");
+			break;
+		}
+		if( ch == '\'' )	{
+			LoadChar(ch);
+			if( ch != '\'' )
+				break;
+		}
+		*p++ = ch;
+		if( p - str->s_str == len )	{
+			extern char *Srealloc();
+
+			str->s_str = Srealloc(str->s_str,
+					(unsigned int) len + RSTRSIZE);
+			p = str->s_str + len;
+			len += RSTRSIZE;
+		}
+	}
+	if( ch == EOI ) eofseen = 1;
+	else PushBack();
+
+	str->s_length = p - str->s_str;
+	*p++ = '\0';
+
+	/* ISO 6.1.7: string length at least 1 */
+	if( str->s_length == 0 )	{
+		lexerror("character-string: at least one character expected");
+		str->s_length = 1;
+	}
+
+	return str;
+}
+
+int
+LLlex()
+{
+	/*	LLlex() is the Lexical Analyzer.
+		The putting aside of tokens is taken into account.
+	*/
+	register struct token *tk = &dot;
+	register int ch, nch;
+
+	toktype = error_type;
+
+	if( ASIDE )	{	/* a token is put aside */
+		*tk = aside;
+		toktype = asidetype;
+		ASIDE = 0;
+		return tk->tk_symb;
+	}
+
+	tk->tk_lineno = LineNumber;
+
+	if( eofseen )	{
+		eofseen = 0;
+		ch = EOI;
+	}
+	else	{
+again:
+		LoadChar(ch);
+		if( !options['C'] )		/* -C : cases are different */
+			TO_LOWER(ch);
+
+		if( (ch & 0200) && ch != EOI )
+			fatal("non-ascii '\\%03o' read", ch & 0377);
+			/*NOTREACHED*/
+	}
+
+	switch( class(ch) )	{
+
+	case STNL:
+		LineNumber++;
+		tk->tk_lineno++;
+#ifdef DEBUG
+		cntlines++;
+#endif
+		goto again;
+
+	case STSKIP:
+		goto again;
+
+	case STGARB:
+		if( (unsigned) ch < 0177 )
+			lexerror("garbage char %c", ch);
+		else
+			crash("(LLlex) garbage char \\%03o", ch);
+		goto again;
+
+	case STSIMP:
+		if( ch == '(' )	{
+			LoadChar(nch);
+			if( nch == '*' )	{		/* (* */
+				SkipComment();
+				tk->tk_lineno = LineNumber;
+				goto again;
+			}
+			if( nch == '.' )			/* (. is [ */
+				return tk->tk_symb = '[';
+			if( nch == EOI ) eofseen = 1;
+			else PushBack();
+		}
+		else if( ch == '{' )	{
+			SkipComment();
+			tk->tk_lineno = LineNumber;
+			goto again;
+		}
+		else if( ch == '@' ) ch = '^';		/* @ is ^ */
+
+		return tk->tk_symb = ch;
+
+	case STCOMP:
+		LoadChar(nch);
+		switch( ch )	{
+
+		case '.':
+			if( nch == '.' )			/* .. */
+				return tk->tk_symb = UPTO;
+			if( nch == ')' )			/* .) is ] */
+				return tk->tk_symb = ']';
+			break;
+
+		case ':':
+			if( nch == '=' )			/* := */
+				return tk->tk_symb = BECOMES;
+			break;
+
+		case '<':
+			if( nch == '=' )			/* <= */
+				return tk->tk_symb = LESSEQUAL;
+			if( nch == '>' )			/* <> */
+				return tk->tk_symb = NOTEQUAL;
+			break;
+
+		case '>':
+			if( nch == '=' )			/* >= */
+				return tk->tk_symb = GREATEREQUAL;
+			break;
+
+		default :
+			crash("(LLlex, STCOMP)");
+			/*NOTREACHED*/
+		}
+		if( nch == EOI ) eofseen = 1;
+		else PushBack();
+		return tk->tk_symb = ch;
+
+	case STIDF:	{
+		char buf[IDFSIZE + 1];
+		register char *tag = &buf[0];
+		register struct idf *id;
+		extern struct idf *str2idf();
+
+		do	{
+			if( !options['C'] )	/* -C : cases are different */
+				TO_LOWER(ch);
+			if( tag - buf < idfsize )
+				*tag++ = ch;
+			LoadChar(ch);
+		} while( in_idf(ch) );
+		*tag = '\0';
+
+		if( ch == EOI ) eofseen = 1;
+		else PushBack();
+
+		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();
+
+		if( str->s_length == 1 )	{
+#ifdef DEBUG
+			if( options['l'] )	{
+				/* to prevent LexScan from crashing */
+				tk->tk_data.tk_str = str;
+				return tk->tk_symb = STRING;
+			}
+#endif
+			tk->TOK_INT = *(str->s_str) & 0377;
+			toktype = char_type;
+			free(str->s_str);
+			free((char *) str);
+		}
+		else	{
+			tk->tk_data.tk_str = str;
+			toktype = standard_type(T_STRING, 1, str->s_length);
+		}
+		return tk->tk_symb = STRING;
+	}
+
+	case STNUM:	{
+#define INT_MODE	0
+#define REAL_MODE	1
+
+		char buf[NUMSIZE+2];
+		register char *np = buf;
+		register int state = INT_MODE;
+		extern char *Salloc();
+
+		do	{
+			if( np <= &buf[NUMSIZE] )
+				*np++ = ch;
+			LoadChar(ch);
+		} while( is_dig(ch) );
+
+		if( ch == '.' )	{
+			LoadChar(ch);
+			if( is_dig(ch) )	{
+				if( np <= &buf[NUMSIZE] )
+					*np++ = '.';
+				do	{
+					/* fractional part */
+					if( np <= &buf[NUMSIZE] )
+						*np++ = ch;
+					LoadChar(ch);
+				} while( is_dig(ch) );
+				state = REAL_MODE;
+			}
+			else	{
+				PushBack();
+				PushBack();
+				goto end;
+			}
+				
+		}
+		if( ch == 'e' || ch == 'E' )	{
+			char *tp = np;		/* save position in string */
+
+			/* scale factor */
+			if( np <= &buf[NUMSIZE] )
+				*np++ = ch;
+			LoadChar(ch);
+			if( ch == '+' || ch == '-' )	{
+				/* signed scale factor */
+				if( np <= &buf[NUMSIZE] )
+					*np++ = ch;
+				LoadChar(ch);
+			}
+			if( is_dig(ch) )	{
+				do	{
+					if( np <= &buf[NUMSIZE] )
+						*np++ = ch;
+					LoadChar(ch);
+				} while( is_dig(ch) );
+				state = REAL_MODE;
+			}
+			else	{
+				PushBack();
+				PushBack();
+				if( np - tp == 2 )	/* sign */
+					PushBack();
+				np = tp;		/* restore position */
+				goto end;
+			}
+		}
+		/* syntax of number is correct */
+		if( ch == EOI ) eofseen = 1;
+		else PushBack();
+	end:
+		*np++ = '\0';
+
+		if( state == INT_MODE )	{
+			if( np > &buf[NUMSIZE+1] )	{
+				tk->TOK_INT = 1;
+				lexerror("constant too long");
+			}
+			else	{
+				np = buf;
+				while (*np == '0')	/* skip leading zeros */
+					np++;
+				tk->TOK_INT = str2long(np, 10);
+				if( tk->TOK_INT < 0 ||
+				    strlen(np) > strlen(maxint_str) ||
+					strlen(np) == strlen(maxint_str) &&
+					strcmp(np, maxint_str) > 0 )
+					     lexwarning("overflow in constant");
+			}
+			toktype = int_type;
+			return tk->tk_symb = INTEGER;
+		}
+		/* REAL_MODE */
+		tk->tk_data.tk_real = (struct real *)
+						Malloc(sizeof(struct real));
+		/* allocate struct for inverse */
+		tk->TOK_RIV = (struct real *) Malloc(sizeof(struct real));
+		tk->TOK_RIV->r_inverse = tk->tk_data.tk_real;
+
+		/* sign */
+		tk->TOK_RSI = 0;
+		tk->TOK_RIV->r_sign = 1;
+
+		if( np > &buf[NUMSIZE+1] )	{
+			tk->TOK_REL = Salloc("0.0", 4);
+			lexerror("floating constant too long");
+		}
+		else tk->TOK_REL = Salloc(buf, np - buf);
+
+		toktype = real_type;
+		return tk->tk_symb = REAL;
+
+		/*NOTREACHED*/
+	}
+
+	case STEOI:
+		return tk->tk_symb = -1;
+
+	case STCHAR:
+	default:
+		crash("(LLlex) Impossible character class");
+		/*NOTREACHED*/
+	}
+	/*NOTREACHED*/
+}

lang/pc/comp/LLlex.h

@@ -0,0 +1,49 @@
+/* T O K E N   D E S C R I P T O R   D E F I N I T I O N */
+
+/* Structure to store a string constant
+*/
+struct string {
+	arith s_length;			/* length of a string */
+	char *s_str;			/* the string itself */
+	label s_lab;			/* data label of string */
+};
+
+/* Structure to store a real constant
+*/
+struct real {
+	char *r_real;			/* string representation of real */
+	struct real *r_inverse;		/* the inverse of this real */
+	label r_lab;			/* data label of real */
+	int r_sign;			/* positive or negative */
+};
+
+/* Token structure. Keep it small, as it is part of a parse-tree node
+*/
+struct token	{
+	short tk_symb;			/* token itself	*/
+	unsigned short tk_lineno;	/* linenumber on which it occurred */
+	union {
+		struct idf *tk_idf;	/* IDENT	*/
+		struct string *tk_str;	/* STRING	*/
+		arith tk_int;		/* INTEGER	*/
+		struct real *tk_real;	/* REAL		*/
+		struct def *tk_def;	/* only used in parse tree node */
+		arith *tk_set;		/* only used in parse tree node */
+		label tk_lab;		/* only used in parse tree node */
+	} tk_data;
+};
+
+#define TOK_IDF	tk_data.tk_idf
+#define TOK_STR	tk_data.tk_str->s_str
+#define TOK_SLE tk_data.tk_str->s_length
+#define TOK_SLA	tk_data.tk_str->s_lab
+#define TOK_INT	tk_data.tk_int
+#define TOK_REL	tk_data.tk_real->r_real
+#define TOK_RIV	tk_data.tk_real->r_inverse
+#define TOK_RLA	tk_data.tk_real->r_lab
+#define TOK_RSI	tk_data.tk_real->r_sign
+
+extern struct token dot, aside;
+extern struct type *toktype, *asidetype;
+
+#define	ASIDE	aside.tk_symb

lang/pc/comp/LLmessage.c

@@ -0,0 +1,72 @@
+/* S Y N T A X   E R R O R   R E P O R T I N G */
+
+/*	Defines the LLmessage routine. LLgen-generated parsers require the
+	existence of a routine of that name.
+	The routine must do syntax-error reporting and must be able to
+	insert tokens in the token stream.
+*/
+
+#include	<alloc.h>
+#include	<em_arith.h>
+#include	<em_label.h>
+
+#include	"LLlex.h"
+#include	"Lpars.h"
+#include	"idf.h"
+#include	"type.h"
+
+extern char		*symbol2str();
+extern char		*Malloc(), *Salloc();
+extern struct idf	*gen_anon_idf();
+
+LLmessage(tk)
+	register int tk;
+{
+	if( tk > 0 )	{
+		/* if( tk > 0 ), it represents the token to be inserted.
+		*/
+		register struct token *dotp = &dot;
+
+		error("%s missing", symbol2str(tk));
+
+		aside = *dotp;
+		asidetype = toktype;
+
+		dotp->tk_symb = tk;
+
+		switch( tk )	{
+		/* The operands need some body */
+		case IDENT:
+			dotp->TOK_IDF = gen_anon_idf();
+			break;
+		case STRING:
+			dotp->tk_data.tk_str = (struct string *)
+						Malloc(sizeof (struct string));
+			dotp->TOK_SLE = 1;
+			dotp->TOK_STR = Salloc("", 1);
+			toktype = standard_type(T_STRING, 1, (arith) 1);
+			break;
+		case INTEGER:
+			dotp->TOK_INT = 1;
+			toktype = int_type;
+			break;
+		case REAL:
+			dotp->tk_data.tk_real = (struct real *)
+						Malloc(sizeof(struct real));
+			/* inverse struct */
+			dotp->TOK_RIV = (struct real *)
+						Malloc(sizeof(struct real));
+			dotp->TOK_RIV->r_inverse = dotp->tk_data.tk_real;
+
+			/* sign */
+			dotp->TOK_RSI = 0;
+			dotp->TOK_RIV->r_sign = 1;
+
+			dotp->TOK_REL = Salloc("0.0", 4);
+			toktype = real_type;
+			break;
+		}
+	}
+	else if( tk < 0 ) error("garbage at end of program");
+	     else error("%s deleted", symbol2str(dot.tk_symb));
+}

lang/pc/comp/Makefile

@@ -0,0 +1,376 @@
+# 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
+LLGEN =		$(EMHOME)/bin/LLgen
+MKDEP =		$(EMHOME)/bin/mkdep
+CURRDIR =	.
+CC =		fcc
+PRINTER =	vu45
+
+INCLUDES = -I$(MHDIR) -I$(EMHOME)/h -I$(PKGDIR)
+
+GFILES =	tokenfile.g declar.g expression.g program.g statement.g
+LLGENOPTIONS =
+PROFILE =
+CFLAGS = $(PROFILE) $(INCLUDES) -DSTATIC=
+LINTFLAGS = -DSTATIC=
+MALLOC = $(LIBDIR)/malloc.o
+LFLAGS = $(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 char.c chk_expr.c code.c\
+	cstoper.c def.c desig.c enter.c error.c idf.c input.c label.c\
+	lookup.c main.c misc.c next.c node.c options.c readwrite.c\
+	scope.c symbol2str.c tokenname.c type.c typequiv.c progs.c
+COBJ =	LLlex.o LLmessage.o body.o casestat.o char.o chk_expr.o code.o\
+	cstoper.o def.o desig.o enter.o error.o idf.o input.o label.o\
+	lookup.o main.o misc.o next.o node.o options.o readwrite.o\
+	scope.o symbol2str.o tmpvar.o tokenname.o type.o typequiv.o progs.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
+SRC =	Lpars.c $(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
+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)
+#
+GENFILES = $(GENGFILES) $(GENCFILES) $(GENHFILES)
+NEXTFILES = def.H desig.H node.H scope.H type.H casestat.C tmpvar.C
+
+#EXCLEXCLEXCLEXCL
+
+all:	Cfiles
+	make $(CURRDIR)/main
+
+clean:
+	rm -f *.o main $(GENFILES) hfiles Cfiles LLfiles
+
+# entry points not to be used directly
+
+Cfiles:	hfiles LLfiles $(GENCFILES) $(GENHFILES) Makefile
+	echo $(SRC) $(HFILES) > Cfiles
+
+LLfiles:	$(GFILES)
+	$(LLGEN) $(LLGENOPTIONS) $(GFILES)
+	@touch LLfiles
+
+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
+
+symbol2str.c:	tokenname.c make.tokcase
+	make.tokcase < tokenname.c > symbol2str.c
+
+.SUFFIXES:	.H .h
+.H.h:
+		./make.allocd < $*.H > $*.h
+
+.SUFFIXES:	.C .c
+.C.c:
+		./make.allocd < $*.C > $*.c
+
+def.h:		make.allocd
+type.h:		make.allocd
+node.h:		make.allocd
+scope.h:	make.allocd
+desig.h:	make.allocd
+casestat.c:	make.allocd
+tmpvar.c:	make.allocd
+
+next.c:		$(NEXTFILES) ./make.next
+		./make.next $(NEXTFILES) > next.c
+
+char.c:	char.tab tab
+	tab -fchar.tab > char.c
+
+tab:
+	$(CC) tab.c -o tab
+depend:
+	sed '/^#AUTOAUTO/,$$d' Makefile > Makefile.new
+	echo '#AUTOAUTOAUTOAUTOAUTOAUTOAUTOAUTO' >> Makefile.new
+	$(MKDEP) $(SRC) |\
+		sed 's/\.c:/\.o:/' >> Makefile.new
+	mv Makefile Makefile.old
+	mv Makefile.new Makefile
+
+print:	$(CSRC) $(GFILES) $(HFILES)	# print recently changed files
+	pr -t $? | rpr $(PRINTER)
+	@touch print
+
+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
+
+#AUTOAUTOAUTOAUTOAUTOAUTOAUTOAUTO
+Lpars.o: Lpars.h
+LLlex.o: LLlex.h
+LLlex.o: Lpars.h
+LLlex.o: class.h
+LLlex.o: const.h
+LLlex.o: debug.h
+LLlex.o: debugcst.h
+LLlex.o: f_info.h
+LLlex.o: idf.h
+LLlex.o: idfsize.h
+LLlex.o: input.h
+LLlex.o: inputtype.h
+LLlex.o: main.h
+LLlex.o: numsize.h
+LLlex.o: strsize.h
+LLlex.o: type.h
+LLmessage.o: LLlex.h
+LLmessage.o: Lpars.h
+LLmessage.o: idf.h
+LLmessage.o: type.h
+body.o: LLlex.h
+body.o: chk_expr.h
+body.o: debug.h
+body.o: debugcst.h
+body.o: def.h
+body.o: desig.h
+body.o: idf.h
+body.o: main.h
+body.o: node.h
+body.o: scope.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
+chk_expr.o: const.h
+chk_expr.o: debug.h
+chk_expr.o: debugcst.h
+chk_expr.o: def.h
+chk_expr.o: idf.h
+chk_expr.o: main.h
+chk_expr.o: misc.h
+chk_expr.o: node.h
+chk_expr.o: required.h
+chk_expr.o: scope.h
+chk_expr.o: type.h
+code.o: LLlex.h
+code.o: Lpars.h
+code.o: debug.h
+code.o: debugcst.h
+code.o: def.h
+code.o: desig.h
+code.o: main.h
+code.o: node.h
+code.o: required.h
+code.o: scope.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: node.h
+cstoper.o: required.h
+cstoper.o: target_sizes.h
+cstoper.o: type.h
+def.o: LLlex.h
+def.o: debug.h
+def.o: debugcst.h
+def.o: def.h
+def.o: idf.h
+def.o: main.h
+def.o: misc.h
+def.o: node.h
+def.o: scope.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: main.h
+desig.o: node.h
+desig.o: scope.h
+desig.o: type.h
+enter.o: LLlex.h
+enter.o: def.h
+enter.o: idf.h
+enter.o: main.h
+enter.o: node.h
+enter.o: scope.h
+enter.o: type.h
+error.o: LLlex.h
+error.o: debug.h
+error.o: debugcst.h
+error.o: errout.h
+error.o: f_info.h
+error.o: input.h
+error.o: inputtype.h
+error.o: main.h
+error.o: node.h
+idf.o: idf.h
+input.o: f_info.h
+input.o: idf.h
+input.o: input.h
+input.o: inputtype.h
+label.o: LLlex.h
+label.o: def.h
+label.o: idf.h
+label.o: main.h
+label.o: node.h
+label.o: scope.h
+label.o: type.h
+lookup.o: LLlex.h
+lookup.o: def.h
+lookup.o: idf.h
+lookup.o: misc.h
+lookup.o: node.h
+lookup.o: scope.h
+lookup.o: type.h
+main.o: LLlex.h
+main.o: Lpars.h
+main.o: const.h
+main.o: debug.h
+main.o: debugcst.h
+main.o: def.h
+main.o: f_info.h
+main.o: idf.h
+main.o: input.h
+main.o: inputtype.h
+main.o: main.h
+main.o: node.h
+main.o: required.h
+main.o: tokenname.h
+main.o: type.h
+misc.o: LLlex.h
+misc.o: f_info.h
+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: node.h
+node.o: type.h
+options.o: class.h
+options.o: const.h
+options.o: idfsize.h
+options.o: main.h
+options.o: type.h
+readwrite.o: LLlex.h
+readwrite.o: debug.h
+readwrite.o: debugcst.h
+readwrite.o: def.h
+readwrite.o: main.h
+readwrite.o: node.h
+readwrite.o: scope.h
+readwrite.o: type.h
+scope.o: LLlex.h
+scope.o: debug.h
+scope.o: debugcst.h
+scope.o: def.h
+scope.o: idf.h
+scope.o: misc.h
+scope.o: node.h
+scope.o: scope.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
+type.o: LLlex.h
+type.o: const.h
+type.o: debug.h
+type.o: debugcst.h
+type.o: def.h
+type.o: idf.h
+type.o: main.h
+type.o: node.h
+type.o: scope.h
+type.o: target_sizes.h
+type.o: type.h
+typequiv.o: LLlex.h
+typequiv.o: debug.h
+typequiv.o: debugcst.h
+typequiv.o: def.h
+typequiv.o: node.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: scope.h
+progs.o: type.h
+declar.o: LLlex.h
+declar.o: Lpars.h
+declar.o: chk_expr.h
+declar.o: def.h
+declar.o: idf.h
+declar.o: main.h
+declar.o: misc.h
+declar.o: node.h
+declar.o: scope.h
+declar.o: type.h
+expression.o: LLlex.h
+expression.o: Lpars.h
+expression.o: chk_expr.h
+expression.o: debug.h
+expression.o: debugcst.h
+expression.o: def.h
+expression.o: main.h
+expression.o: node.h
+expression.o: scope.h
+expression.o: type.h
+program.o: LLlex.h
+program.o: Lpars.h
+program.o: def.h
+program.o: main.h
+program.o: node.h
+program.o: scope.h
+statement.o: LLlex.h
+statement.o: Lpars.h
+statement.o: chk_expr.h
+statement.o: def.h
+statement.o: desig.h
+statement.o: idf.h
+statement.o: main.h
+statement.o: node.h
+statement.o: scope.h
+statement.o: type.h
+tokenfile.o: Lpars.h

lang/pc/comp/Parameters

@@ -0,0 +1,51 @@
+!File: debugcst.h
+#define DEBUG		1	/* perform various self-tests	*/
+
+
+!File: density.h
+#define DENSITY		3	/* to determine, if a csa or csb
+					instruction must be generated	*/
+
+
+!File: errout.h
+#define	ERROUT		STDERR	/* file pointer for writing messages	*/
+#define	MAXERR_LINE	5	/* maximum number of error messages given
+					on the same input line.		*/
+
+
+!File: idfsize.h
+#define IDFSIZE		128	/* max. significant length of an identifier */
+
+
+!File: inputtype.h
+#define INP_READ_IN_ONE	1	/* read input file in one	*/
+
+
+!File: numsize.h
+#define	NUMSIZE	256		/* maximum length of a numeric constant	*/
+
+
+!File: strsize.h
+#define ISTRSIZE	32	/* minimum number of bytes allocated for
+					storing a string		*/
+#define RSTRSIZE	8	/* step size in enlarging the memory for
+					the storage of a string		*/
+
+
+!File: target_sizes.h
+#define MAXSIZE		8	/* the maximum of the SZ_* constants	*/
+
+/* target machine sizes	*/
+#define	SZ_CHAR		(arith)1
+#define SZ_WORD		(arith)4
+#define	SZ_INT		(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

lang/pc/comp/body.c

@@ -0,0 +1,247 @@
+#include	"debug.h"
+
+#include	<alloc.h>
+#include	<assert.h>
+#include	<em.h>
+
+#include	"LLlex.h"
+#include	"chk_expr.h"
+#include	"def.h"
+#include	"desig.h"
+#include	"idf.h"
+#include	"main.h"
+#include	"node.h"
+#include	"scope.h"
+#include	"type.h"
+
+
+AssignStat(left, right)
+	register struct node *left, *right;
+{
+	register struct type *ltp, *rtp;
+	struct desig dsr;
+
+	if( !(ChkExpression(right) && ChkLhs(left)) )
+		return;
+
+	ltp = left->nd_type;
+	rtp = right->nd_type;
+
+	if( !TstAssCompat(ltp, rtp) )	{
+		node_error(left, "type incompatibility in assignment");
+		return;
+	}
+
+	if( rtp == emptyset_type )
+		right->nd_type = ltp;
+
+	if( !err_occurred )	{
+		dsr = InitDesig;
+		CodeExpr(right, &dsr, NO_LABEL);
+
+		if( rtp->tp_fund & (T_ARRAY | T_RECORD) )
+			CodeAddress(&dsr);
+		else	{
+			CodeValue(&dsr, rtp);
+
+			if( ltp == real_type && BaseType(rtp) == int_type )
+				Int2Real();
+
+			RangeCheck(ltp, rtp);
+		}
+		CodeMove(&dsr, left, rtp);
+	}
+
+	FreeNode(left);
+	FreeNode(right);
+}
+
+ProcStat(nd)
+	register struct node *nd;
+{
+	if( !ChkCall(nd) ) return;
+
+	if( nd->nd_type )	{
+		node_error(nd, "procedure call expected");
+		return;
+	}
+}
+
+ChkForStat(nd)
+	register struct node *nd;
+{
+	register struct def *df;
+
+	if( !(ChkVariable(nd) && ChkExpression(nd->nd_left) &&
+						ChkExpression(nd->nd_right)) )
+		return;
+	
+	assert(nd->nd_class == Def);
+
+	df = nd->nd_def;
+
+	if( df->df_scope != BlockScope )	{
+		node_error(nd, "for loop: control variable must be local");
+		return;
+	}
+
+	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;
+	}
+
+	if( !(df->df_type->tp_fund & T_ORDINAL) )	{
+		node_error(nd, "for loop: control variable must be ordinal");
+		return;
+	}
+
+	if( !TstCompat(df->df_type, nd->nd_left->nd_type) )
+		node_error(nd,
+		  "for loop: initial value incompatible with control variable");
+
+	if( !TstCompat(df->df_type, nd->nd_right->nd_type) )
+		node_error(nd,
+		    "for loop: final value incompatible with control variable");
+	
+	df->df_flags |= D_LOOPVAR;
+
+	return;
+}
+
+arith
+CodeInitFor(nd, priority)
+	register struct node *nd;
+{
+	/* Push init-value or final-value, the value may only be evaluated
+	   once, so generate a temporary for it, when not a constant.
+	*/
+
+	arith tmp;
+
+	CodePExpr(nd);
+	if( nd->nd_class != Value )	{
+		tmp = NewInt(priority);
+		C_dup(int_size);
+		C_stl(tmp);
+		return tmp;
+	}
+	return (arith) 0;
+}
+
+CodeFor(nd, stepsize, l1, l2, tmp1)
+	struct node *nd;
+	label l1, l2;
+	arith tmp1;
+{
+	/* Test if loop has to be done */
+	if( stepsize == 1 )	/* TO */
+		C_bgt(l2);
+	else			/* DOWNTO */
+		C_blt(l2);
+
+	/* Store init-value in control-variable */
+	if( tmp1 )
+		C_lol(tmp1);
+	else
+		CodePExpr(nd->nd_left);
+
+	/* Label at begin of the body */
+	C_df_ilb(l1);
+
+	RangeCheck(nd->nd_type, nd->nd_left->nd_type);
+	CodeDStore(nd);
+}
+
+CodeEndFor(nd, stepsize, l1, l2, tmp2)
+	struct node *nd;
+	label l1, l2;
+	arith tmp2;
+{
+	/* Test if loop has to be done once more */
+	CodePExpr(nd);
+	C_dup(int_size);
+	if( tmp2 )
+		C_lol(tmp2);
+	else
+		CodePExpr(nd->nd_right);
+	C_beq(l2);
+
+	/* Increment/decrement the control-variable */
+	if( stepsize == 1 )	/* TO */
+		C_inc();
+	else			/* DOWNTO */
+		C_dec();
+	C_bra(l1);
+
+	/* Exit label */
+	C_df_ilb(l2);
+}
+
+WithStat(nd)
+	struct node *nd;
+{
+	struct withdesig *wds;
+	struct desig ds;
+	struct scopelist *scl;
+
+	if( nd->nd_type->tp_fund != T_RECORD )	{
+		node_error(nd, "record variable expected");
+		return;
+	}
+
+	if( err_occurred ) return;
+
+	/* Generate code */
+
+	CodeDAddress(nd);
+
+	wds = new_withdesig();
+	wds->w_next = WithDesigs;
+	WithDesigs = wds;
+	wds->w_scope = nd->nd_type->rec_scope;
+
+	/* create a desig structure for the temporary */
+	ds.dsg_kind = DSG_FIXED;
+	ds.dsg_offset = NewPtr(1);
+	ds.dsg_name = 0;
+
+	/* need some pointertype to store pointer */
+	CodeStore(&ds, nil_type);
+
+	/* 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)
+	struct scopelist *saved_scl;
+	struct node *nd;
+{
+	/* restore scope, and release structures */
+	struct scopelist *scl;
+	struct withdesig *wds;
+
+	while( CurrVis != saved_scl )	{
+
+		/* release scopelist */
+		scl = CurrVis;
+		CurrVis = CurrVis->next;
+		free_scopelist(scl);
+
+		/* release temporary */
+		FreePtr(WithDesigs->w_desig.dsg_offset);
+
+		/* release withdesig */
+		wds = WithDesigs;
+		WithDesigs = WithDesigs->w_next;
+		free_withdesig(wds);
+	}
+	FreeNode(nd);
+}

lang/pc/comp/casestat.C

@@ -0,0 +1,254 @@
+/* C A S E   S T A T E M E N T   C O D E   G E N E R A T I O N */
+#include	"debug.h"
+
+#include	<alloc.h>
+#include	<assert.h>
+#include	<em.h>
+
+#include	"LLlex.h"
+#include	"Lpars.h"
+#include	"chk_expr.h"
+#include	"density.h"
+#include	"main.h"
+#include	"node.h"
+#include	"type.h"
+
+struct case_hdr	{
+	struct case_hdr *ch_next;		/* in the free list */
+	int ch_nrofentries;		/* number of cases */
+	struct type *ch_type;		/* type of case expression */
+	arith ch_lowerbd;		/* lowest case label */
+	arith ch_upperbd;		/* highest case label */
+	struct case_entry *ch_entries;	/* the cases */
+};
+
+/* ALLOCDEF "case_hdr" 5 */
+
+struct case_entry	{
+	struct case_entry *ce_next;	/* next in list */
+	arith ce_value;			/* value of case label */
+	label ce_label;			/* generated label */
+};
+
+/* ALLOCDEF "case_entry" 10 */
+
+/* The constant DENSITY determines when CSA and when CSB instructions
+   are generated. Reasonable values are: 2, 3, 4.
+   On machines that have lots of address space and memory, higher values
+   might also be reasonable. On these machines the density of jump tables
+   may be lower.
+*/
+#define	compact(nr, low, up)	(nr != 0 && (up - low) / nr <= DENSITY)
+
+CaseExpr(nd)
+	struct node *nd;
+{
+	/* Check the expression and generate code for it
+	*/
+
+	register struct node *expp = nd->nd_left;
+
+	if( !ChkExpression(expp) ) return;
+
+	if( !(expp->nd_type->tp_fund & T_ORDINAL) )	{
+		node_error(expp, "case-expression must be ordinal");
+		return;
+	}
+
+	if( !err_occurred )	{
+		CodePExpr(expp);
+		C_bra(nd->nd_lab);
+	}
+}
+
+CaseEnd(nd, exit_label)
+	struct node *nd;
+	label exit_label;
+{
+	/*	Stack a new case header and fill in the necessary fields.
+	*/
+	register struct case_hdr *ch = new_case_hdr();
+	register struct node *right;
+
+	assert(nd->nd_class == Link && nd->nd_symb == CASE);
+
+	ch->ch_type = nd->nd_left->nd_type;
+
+	right = nd->nd_right;
+
+	/* Now, create case label list
+	*/
+	while( right )	{
+		assert(right->nd_class == Link && right->nd_symb == ':');
+
+		if( !AddCases(ch, right->nd_left, right->nd_lab) )	{
+				FreeCh(ch);
+				return;
+		}
+		right = right->nd_right;
+	}
+
+	if( !err_occurred )
+		CaseCode(nd->nd_lab, ch, exit_label);
+
+	FreeCh(ch);
+}
+
+FreeCh(ch)
+	register struct case_hdr *ch;
+{
+	/*	 free the allocated case structure	
+	*/
+	register struct case_entry *ce;
+
+	ce = ch->ch_entries;
+	while( ce )	{
+		struct case_entry *tmp = ce->ce_next;
+
+		free_case_entry(ce);
+		ce = tmp;
+	}
+
+	free_case_hdr(ch);
+}
+
+AddCases(ch, nd, CaseLabel)
+	register struct case_hdr *ch;
+	register struct node *nd;
+	label CaseLabel;
+{
+	while( nd )	{
+		if( !AddOneCase(ch, nd, CaseLabel) )
+			return 0;
+		nd = nd->nd_next;
+	}
+	return 1;
+}
+
+AddOneCase(ch, nd, lbl)
+	register struct case_hdr *ch;
+	register struct node *nd;
+	label lbl;
+{
+	register struct case_entry *ce = new_case_entry();
+	register struct case_entry *c1 = ch->ch_entries, *c2 = 0;
+
+	ce->ce_value = nd->nd_INT;
+	ce->ce_label = lbl;
+	if( !TstCompat(ch->ch_type, nd->nd_type) )	{
+		node_error(nd, "case-statement: type incompatibility in case");
+		free_case_entry(ce);
+		return 0;
+	}
+	if( bounded(ch->ch_type) )	{
+		arith lo, hi;
+
+		getbounds(ch->ch_type, &lo, &hi);
+		if( ce->ce_value < lo || ce->ce_value > hi )
+			warning("case-statement: constant out of bounds");
+	}
+
+	if( !ch->ch_entries )	{
+		/* first case entry
+		*/
+		ce->ce_next = (struct case_entry *) 0;
+		ch->ch_entries = ce;
+		ch->ch_lowerbd = ch->ch_upperbd = ce->ce_value;
+		ch->ch_nrofentries = 1;
+	}
+	else	{
+		/* second etc. case entry
+		   find the proper place to put ce into the list
+		*/
+		
+		if( ce->ce_value < ch->ch_lowerbd )
+			ch->ch_lowerbd = ce->ce_value;
+		else if( ce->ce_value > ch->ch_upperbd )
+			ch->ch_upperbd = ce->ce_value;
+
+		while( c1 && c1->ce_value < ce->ce_value )	{
+			c2 = c1;
+			c1 = c1->ce_next;
+		}
+		/*	At this point three cases are possible:
+			1: c1 != 0 && c2 != 0:
+				insert ce somewhere in the middle
+			2: c1 != 0 && c2 == 0:
+				insert ce right after the head
+			3: c1 == 0 && c2 != 0:
+				append ce to last element
+			The case c1 == 0 && c2 == 0 cannot occur, since
+			the list is guaranteed not to be empty.
+		*/
+		if( c1 )	{
+			if( c1->ce_value == ce->ce_value )	{
+				node_error(nd,
+					"case-statement: multiple case entry");
+				free_case_entry(ce);
+				return 0;
+			}
+			if( c2 )	{
+				ce->ce_next = c2->ce_next;
+				c2->ce_next = ce;
+			}
+			else	{
+				ce->ce_next = ch->ch_entries;
+				ch->ch_entries = ce;
+			}
+		}
+		else	{
+			assert(c2);
+
+			ce->ce_next = (struct case_entry *) 0;
+			c2->ce_next = ce;
+		}
+		(ch->ch_nrofentries)++;
+	}
+	return 1;
+}
+
+CaseCode(lbl, ch, exit_label)
+	label lbl;
+	struct case_hdr *ch;
+	label exit_label;
+{
+	label CaseDescrLab = ++data_label;	/* rom must have a label */
+
+	register struct case_entry *ce;
+	register arith val;
+
+	C_df_dlb(CaseDescrLab);
+	C_rom_icon("0", pointer_size);
+
+	if( compact(ch->ch_nrofentries, ch->ch_lowerbd, ch->ch_upperbd) ) {
+		/* CSA */
+		C_rom_cst(ch->ch_lowerbd);
+		C_rom_cst(ch->ch_upperbd - ch->ch_lowerbd);
+		ce = ch->ch_entries;
+		for( val = ch->ch_lowerbd; val <= ch->ch_upperbd; val++ ) {
+			assert(ce);
+			if( val == ce->ce_value )	{
+				C_rom_ilb(ce->ce_label);
+				ce = ce->ce_next;
+			}
+			else
+				C_rom_icon("0", pointer_size);
+		}
+		C_df_ilb(lbl);
+		C_lae_dlb(CaseDescrLab, (arith) 0);
+		C_csa(word_size);
+	}
+	else	{
+		/* CSB */
+		C_rom_cst((arith) ch->ch_nrofentries);
+		for( ce = ch->ch_entries; ce; ce = ce->ce_next )	{
+				C_rom_cst(ce->ce_value);
+				C_rom_ilb(ce->ce_label);
+		}
+		C_df_ilb(lbl);
+		C_lae_dlb(CaseDescrLab, (arith) 0);
+		C_csb(word_size);
+	}
+ 
+	C_df_ilb(exit_label);
+}

lang/pc/comp/char.c

@@ -0,0 +1,394 @@
+#include "class.h"
+char tkclass[] = {
+	STGARB,
+	STGARB,
+	STGARB,
+	STGARB,
+	STGARB,
+	STGARB,
+	STGARB,
+	STGARB,
+	STGARB,
+	STSKIP,
+	STNL,
+	STNL,
+	STNL,
+	STSKIP,
+	STGARB,
+	STGARB,
+	STGARB,
+	STGARB,
+	STGARB,
+	STGARB,
+	STGARB,
+	STGARB,
+	STGARB,
+	STGARB,
+	STGARB,
+	STGARB,
+	STGARB,
+	STGARB,
+	STGARB,
+	STGARB,
+	STGARB,
+	STGARB,
+	STSKIP,
+	STGARB,
+	STGARB,
+	STGARB,
+	STGARB,
+	STGARB,
+	STGARB,
+	STSTR,
+	STSIMP,
+	STSIMP,
+	STSIMP,
+	STSIMP,
+	STSIMP,
+	STSIMP,
+	STCOMP,
+	STSIMP,
+	STNUM,
+	STNUM,
+	STNUM,
+	STNUM,
+	STNUM,
+	STNUM,
+	STNUM,
+	STNUM,
+	STNUM,
+	STNUM,
+	STCOMP,
+	STSIMP,
+	STCOMP,
+	STSIMP,
+	STCOMP,
+	STGARB,
+	STSIMP,
+	STIDF,
+	STIDF,
+	STIDF,
+	STIDF,
+	STIDF,
+	STIDF,
+	STIDF,
+	STIDF,
+	STIDF,
+	STIDF,
+	STIDF,
+	STIDF,
+	STIDF,
+	STIDF,
+	STIDF,
+	STIDF,
+	STIDF,
+	STIDF,
+	STIDF,
+	STIDF,
+	STIDF,
+	STIDF,
+	STIDF,
+	STIDF,
+	STIDF,
+	STIDF,
+	STSIMP,
+	STGARB,
+	STSIMP,
+	STSIMP,
+	STGARB,
+	STGARB,
+	STIDF,
+	STIDF,
+	STIDF,
+	STIDF,
+	STIDF,
+	STIDF,
+	STIDF,
+	STIDF,
+	STIDF,
+	STIDF,
+	STIDF,
+	STIDF,
+	STIDF,
+	STIDF,
+	STIDF,
+	STIDF,
+	STIDF,
+	STIDF,
+	STIDF,
+	STIDF,
+	STIDF,
+	STIDF,
+	STIDF,
+	STIDF,
+	STIDF,
+	STIDF,
+	STSIMP,
+	STGARB,
+	STSIMP,
+	STGARB,
+	STGARB,
+	STEOI,
+};
+char inidf[] = {
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+};
+char isdig[] = {
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	1,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+	0,
+};

lang/pc/comp/char.tab

@@ -0,0 +1,37 @@
+% character tables for ISO-PASCAL compiler
+%S129
+%F	%s,
+%
+%	CHARACTER CLASSES
+%
+%C
+STGARB:\000-\200
+STSKIP: \r\t
+STNL:\012\013\014
+STSIMP:()*+,-/;=@[]^{}
+STCOMP:.:<>
+STIDF:a-zA-Z
+STSTR:'
+STNUM:0-9
+STEOI:\200
+%T#include "class.h"
+%Tchar tkclass[] = {
+%p
+%T};
+%
+%	INIDF
+%
+%C
+1:a-zA-Z0-9
+%Tchar inidf[] = {
+%F	%s,
+%p
+%T};
+%
+%	ISDIG
+%
+%C
+1:0-9
+%Tchar isdig[] = {
+%p
+%T};

lang/pc/comp/chk_expr.h

@@ -0,0 +1,12 @@
+/* E X P R E S S I O N   C H E C K I N G */
+
+extern int	(*ExprChkTable[])();	/* table of expression checking
+					   functions, indexed by node class
+					*/
+
+extern int	(*VarAccChkTable[])();	/* table of variable-access checking
+					   functions, indexed by node class
+					*/
+
+#define	ChkExpression(expp)	((*ExprChkTable[(expp)->nd_class])(expp))
+#define	ChkVarAccess(expp)	((*VarAccChkTable[(expp)->nd_class])(expp))

lang/pc/comp/class.h

@@ -0,0 +1,34 @@
+/* U S E   O F   C H A R A C T E R   C L A S S E S */
+
+/*	As a starter, chars are divided into classes, according to which
+	token they can be the start of.
+	At present such a class number is supposed to fit in 4 bits.
+*/
+
+#define	class(ch)	(tkclass[ch])
+
+/*	Being the start of a token is, fortunately, a mutual exclusive
+	property, so, as there are less than 16 classes they can be
+	packed in 4 bits.
+*/
+
+#define	STSKIP	0	/* spaces and so on: skipped characters		*/
+#define	STNL	1	/* newline character(s): update linenumber etc.	*/
+#define	STGARB	2	/* garbage ascii character: not allowed		*/
+#define	STSIMP	3	/* this character can occur as token		*/
+#define	STCOMP	4	/* this one can start a compound token		*/
+#define	STIDF	5	/* being the initial character of an identifier	*/
+#define	STCHAR	6	/* the starter of a character constant		*/
+#define	STSTR	7	/* the starter of a string			*/
+#define	STNUM	8	/* the starter of a numeric constant		*/
+#define	STEOI	9	/* End-Of-Information mark			*/
+
+/*	But occurring inside a token is not, so we need 1 bit for each
+	class.  This is implemented as a collection of tables to speed up
+	the decision whether a character has a special meaning.
+*/
+#define	in_idf(ch)	((unsigned)ch < 0177 && inidf[ch])
+#define	is_dig(ch)	((unsigned)ch < 0177 && isdig[ch])
+
+extern char tkclass[];
+extern char inidf[], isdig[];

lang/pc/comp/const.h

@@ -0,0 +1,12 @@
+/* C O N S T A N T S   F O R   E X P R E S S I O N   H A N D L I N G */
+
+extern long
+	mach_long_sign;	/* sign bit of the machine long */
+extern int
+	mach_long_size;	/* size of long on this machine == sizeof(long) */
+extern arith
+	max_int,	/* maximum integer on target machine */
+	wrd_bits,	/* number of bits in a word */
+	max_intset;	/* largest value of set of integer */
+extern char
+	*maxint_str;	/* string representation of maximum integer */

lang/pc/comp/cstoper.c

@@ -0,0 +1,448 @@
+/* C O N S T A N T   E X P R E S S I O N   H A N D L I N G */
+
+#include	"debug.h"
+#include	"target_sizes.h"
+
+#include	<alloc.h>
+#include	<assert.h>
+#include	<em_arith.h>
+#include	<em_label.h>
+
+#include	"LLlex.h"
+#include	"Lpars.h"
+#include	"const.h"
+#include	"node.h"
+#include	"required.h"
+#include	"type.h"
+
+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	*/
+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 */
+
+cstunary(expp)
+	register struct node *expp;
+{
+	/*	The unary operation in "expp" is performed on the constant
+		expression below it, and the result restored in expp.
+	*/
+	register arith o1 = expp->nd_right->nd_INT;
+
+	switch( expp->nd_symb )	{
+		/* Should not get here
+		case '+':
+		case '(':
+			break;
+		*/
+
+		case '-':
+			o1 = -o1;
+			break;
+
+		case NOT:
+			o1 = !o1;
+			break;
+
+		default:
+			crash("(cstunary)");
+	}
+
+	expp->nd_class = Value;
+	expp->nd_token = expp->nd_right->nd_token;
+	expp->nd_INT = o1;
+	CutSize(expp);
+	FreeNode(expp->nd_right);
+	expp->nd_right = NULLNODE;
+}
+
+cstbin(expp)
+	register struct node *expp;
+{
+	/*	The binary operation in "expp" is performed on the constant
+		expressions below it, and the result restored in expp.
+	*/
+	register arith o1, o2;
+	register char *s1, *s2;
+	int str = expp->nd_left->nd_type->tp_fund & T_STRING;
+
+	if( str )	{
+		s1 = expp->nd_left->nd_STR;
+		s2 = expp->nd_right->nd_STR;
+	}
+	else	{
+		o1 = expp->nd_left->nd_INT;
+		o2 = expp->nd_right->nd_INT;
+	}
+
+	assert(expp->nd_class == Boper);
+	assert(expp->nd_left->nd_class == Value);
+	assert(expp->nd_right->nd_class == Value);
+
+	switch( expp->nd_symb )	{
+		case '+':
+			o1 += o2;
+			break;
+
+		case '-':
+			o1 -= o2;
+			break;
+
+		case '*':
+			o1 *= o2;
+			break;
+
+		case DIV:
+			if( o2 == 0 )	{
+				node_error(expp, "division by 0");
+				return;
+			}
+			else o1 /= o2;
+			break;
+
+		case MOD:
+			if( o2 == 0 )	{
+				node_error(expp, "modulo by 0");
+				return;
+			}
+			else
+				o1 %= o2;
+			break;
+
+		case OR:
+			o1 = (o1 || o2);
+			break;
+
+		case AND:
+			o1 = (o1 && o2);
+			break;
+
+		case '=':
+			o1 = str ? !strcmp(s1, s2) : (o1 == o2);
+			break;
+
+		case NOTEQUAL:
+			o1 = str ? (strcmp(s1, s2) != 0) : (o1 != o2);
+			break;
+
+		case LESSEQUAL:
+			o1 = str ? (strcmp(s1, s2) <= 0) : (o1 <= o2);
+			break;
+
+		case GREATEREQUAL:
+			o1 = str ? (strcmp(s1, s2) >= 0) : (o1 >= o2);
+			break;
+
+		case '<':
+			o1 = str ? (strcmp(s1, s2) < 0) : (o1 < o2);
+			break;
+
+		case '>':
+			o1 = str ? (strcmp(s1, s2) > 0) : (o1 > o2);
+			break;
+
+		/* case '/': */
+		default:
+			crash("(cstbin)");
+
+	}
+
+	expp->nd_class = Value;
+	expp->nd_token = expp->nd_right->nd_token;
+	/* STRING compare has a bool_type as result */
+	if( expp->nd_type == bool_type ) expp->nd_symb = INTEGER;
+	expp->nd_INT = o1;
+	CutSize(expp);
+	FreeNode(expp->nd_left);
+	FreeNode(expp->nd_right);
+	expp->nd_left = expp->nd_right = NULLNODE;
+}
+
+cstset(expp)
+	register struct node *expp;
+{
+	register arith *set1, *set2;
+	arith *resultset = (arith *) 0;
+	int empty_result = 0;
+	register int setsize, j;
+
+	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;
+
+	if( expp->nd_symb == IN )	{
+		arith i;
+
+		assert(expp->nd_left->nd_class == Value);
+
+		i = expp->nd_left->nd_INT;
+		expp->nd_class = Value;
+		expp->nd_symb = INTEGER;
+
+		expp->nd_INT = (i >= 0 && set2 && i < (setsize * wrd_bits) &&
+				(set2[i/wrd_bits] & (1 << (i%wrd_bits))));
+
+		if( set2 ) free((char *) set2);
+	}
+	else	{
+		set1 = expp->nd_left->nd_set;
+		resultset = set1;
+		expp->nd_left->nd_set = (arith *) 0;
+		switch( expp->nd_symb )	{
+		case '+':
+			/* Set union
+			*/
+			if( !set1 )	{
+				resultset = set2;
+				expp->nd_right->nd_set = (arith *) 0;
+				break;
+			}
+			if( set2 )
+				for( j = 0; j < setsize; j++ )
+					*set1++ |= *set2++;
+			break;
+
+		case '-':
+			/* Set difference
+			*/
+			if( !set1 || !set2 )	{
+				/* The set from which something is substracted
+				   is already empty, or the set that is
+				   substracted is empty. In either case, the
+				   result set is set1.
+				*/
+				break;
+			}
+			empty_result = 1;
+			for( j = 0; j < setsize; j++ )
+				if( *set1++ &= ~*set2++ ) empty_result = 0;
+			break;
+
+		case '*':
+			/* Set intersection
+			*/
+			if( !set1 )	{
+				/* set1 is empty, and so is the result set
+				*/
+				break;
+			}
+			if( !set2 )	{
+				/* set 2 is empty, so the result set must be
+				   empty too.
+				*/
+				resultset = set2;
+				expp->nd_right->nd_set = (arith *) 0;
+				break;
+			}
+			empty_result = 1;
+			for( j = 0; j < setsize; j++ )
+				if( *set1++ &= *set2++ ) empty_result = 0;
+			break;
+
+		case '=':
+		case NOTEQUAL:
+		case LESSEQUAL:
+		case GREATEREQUAL:
+			/* Constant set comparisons
+			*/
+			if( !setsize ) setsize++;	/* force comparison */
+			expp->nd_left->nd_set = set1;	/* may be disposed of */
+			for( j = 0; j < setsize; j++ )	{
+				switch( expp->nd_symb )	{
+				case '=':
+				case NOTEQUAL:
+					if( !set1 && !set2 )	{
+						j = setsize;
+						break;
+					}
+					if( !set1 || !set2 ) break;
+					if( *set1++ != *set2++ ) break;
+					continue;
+				case LESSEQUAL:
+					if( !set1 )	{
+						j = setsize;
+						break;
+					}
+					if( !set2 ) break;
+					if( (*set2 | *set1++) != *set2 ) break;
+					set2++;
+					continue;
+				case GREATEREQUAL:
+					if( !set2 )	{
+						j = setsize;
+						break;
+					}
+					if( !set1 ) break;
+					if( (*set1 | *set2++) != *set1 ) break;
+					set1++;
+					continue;
+				}
+				break;
+			}
+			if( j < setsize )
+				expp->nd_INT = expp->nd_symb == NOTEQUAL;
+			else
+				expp->nd_INT = expp->nd_symb != NOTEQUAL;
+			expp->nd_class = Value;
+			expp->nd_symb = INTEGER;
+			if( expp->nd_left->nd_set )
+				free((char *) expp->nd_left->nd_set);
+			if( expp->nd_right->nd_set )
+				free((char *) expp->nd_right->nd_set);
+			FreeNode(expp->nd_left);
+			FreeNode(expp->nd_right);
+			expp->nd_left = expp->nd_right = NULLNODE;
+			return;
+		default:
+			crash("(cstset)");
+		}
+		if( expp->nd_right->nd_set )
+			free((char *) expp->nd_right->nd_set);
+		if( expp->nd_left->nd_set )
+			free((char *) expp->nd_left->nd_set);
+		if( empty_result )	{
+			free((char *) resultset);
+			resultset = (arith *) 0;
+		}
+		expp->nd_class = Set;
+		expp->nd_set = resultset;
+	}
+	FreeNode(expp->nd_left);
+	FreeNode(expp->nd_right);
+	expp->nd_left = expp->nd_right = NULLNODE;
+}
+
+cstcall(expp, req)
+	register struct node *expp;
+{
+	/*	a standard procedure call is found that can be evaluated
+		compile time, so do so.
+	*/
+	register struct node *expr = NULLNODE;
+
+	assert(expp->nd_class == Call);
+
+	expr = expp->nd_right->nd_left;
+
+	expp->nd_class = Value;
+	expp->nd_symb = INTEGER;
+	switch( req )	{
+	    case R_ABS:
+		if( expr->nd_INT < 0 ) expp->nd_INT = - expr->nd_INT;
+		else expp->nd_INT = expr->nd_INT;
+		CutSize(expp);
+		break;
+
+	    case R_SQR:
+		expp->nd_INT = expr->nd_INT * expr->nd_INT;
+		CutSize(expp);
+		break;
+
+	    case R_ORD:
+	    case R_CHR:
+		expp->nd_INT = expr->nd_INT;
+		CutSize(expp);
+		break;
+
+	    case R_ODD:
+		expp->nd_INT = (expr->nd_INT & 1);
+		break;
+
+	    case R_SUCC:
+		expp->nd_INT = expr->nd_INT + 1;
+		if(	/* Check overflow of subranges or enumerations */
+			(expp->nd_type->tp_fund & T_SUBRANGE &&
+				expp->nd_INT > expp->nd_type->sub_ub
+			)
+		   ||
+			( expp->nd_type->tp_fund & T_ENUMERATION &&
+				expp->nd_INT >= expp->nd_type->enm_ncst
+			)
+		  )
+			node_warning(expp, "\"succ\": no successor");
+		else CutSize(expp);
+		break;
+
+	    case R_PRED:
+		expp->nd_INT = expr->nd_INT - 1;
+		if(	/* Check with lowerbound of subranges or enumerations */
+			(expp->nd_type->tp_fund & T_SUBRANGE &&
+				expp->nd_INT < expp->nd_type->sub_lb
+			)
+		   ||
+			( expp->nd_type->tp_fund & T_ENUMERATION &&
+				expp->nd_INT < 0
+			)
+		  )
+			node_warning(expp, "\"pred\": no predecessor");
+		else CutSize(expp);
+		break;
+
+	    default:
+		crash("(cstcall)");
+	}
+	FreeNode(expp->nd_left);
+	FreeNode(expp->nd_right);
+	expp->nd_right = expp->nd_left = NULLNODE;
+}
+
+CutSize(expr)
+	register struct node *expr;
+{
+	/* The constant value of the expression expr is made to conform
+	 * to the size of the type of the expression
+	 */
+	register arith o1 = expr->nd_INT;
+	register struct type *tp = BaseType(expr->nd_type);
+	int size = tp->tp_size;
+	long remainder = o1 & ~full_mask[size];
+
+	assert(expr->nd_class == Value);
+
+	if( tp->tp_fund & T_CHAR )	{
+		if( o1 & (~full_mask[size] >> 1) ) 	{
+			node_warning(expr, "overflow in character value");
+			o1 &= 0177;
+		}
+	}
+	else if( remainder != 0 && remainder != ~full_mask[size] ||
+	    		(o1 & full_mask[size]) == 1 << (size * 8 - 1) )	{
+		/* integers in [-maxint .. maxint] */
+		int nbits = (int) (mach_long_size - size) * 8;
+
+		node_warning(expr, "overflow in constant expression");
+		/* sign bit of o1 in sign bit of mach_long */
+		o1 <<= nbits;
+		/* shift back to get sign extension */
+		o1 >>= nbits;
+	}
+	expr->nd_INT = o1;
+}
+
+InitCst()
+{
+	extern char *long2str(), *Salloc();
+	register int i = 0;
+	register arith bt = (arith)0;
+
+	while( !(bt < 0) )	{
+		bt = (bt << 8) + 0377;
+		i++;
+		if( i == MAXSIZE + 1 )
+			fatal("array full_mask too small for this machine");
+		full_mask[i] = bt;
+	}
+	mach_long_size = i;
+	mach_long_sign = 1 << (mach_long_size * 8 - 1);
+	if( int_size > mach_long_size )
+		fatal("sizeof (long) insufficient on this machine");
+
+	max_int = full_mask[int_size] & ~(1 << (int_size * 8 - 1));
+	maxint_str = long2str(max_int, 10);
+	maxint_str = Salloc(maxint_str, (unsigned int) strlen(maxint_str));
+	wrd_bits = 8 * word_size;
+	if( !max_intset ) max_intset = wrd_bits - 1;
+}

lang/pc/comp/debug.h

@@ -0,0 +1,10 @@
+/* A debugging macro
+*/
+
+#include "debugcst.h"
+
+#ifdef DEBUG
+#define DO_DEBUG(x, y)	((x) && (y))
+#else
+#define DO_DEBUG(x, y)
+#endif

lang/pc/comp/declar.g

@@ -0,0 +1,942 @@
+/* D E C L A R A T I O N S */
+
+{
+#include	<alloc.h>
+#include	<assert.h>
+#include	<em_arith.h>
+#include	<em_label.h>
+
+#include	"LLlex.h"
+#include	"chk_expr.h"
+#include	"def.h"
+#include	"idf.h"
+#include	"main.h"
+#include	"misc.h"
+#include	"node.h"
+#include	"scope.h"
+#include	"type.h"
+
+int proclevel = 0;		/* nesting level of procedures */
+int parlevel = 0;		/* nesting level of parametersections */
+static int in_type_defs;	/* in type definition part or not */
+}
+
+/* ISO section 6.2.1, p. 93 */
+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 );
+					}
+	CompoundStatement
+					{ if( !err_occurred )
+						CodeEndBlock(df, i);
+					  FreeNode(BlockScope->sc_lablist);
+					}
+;
+
+LabelDeclarationPart
+{
+	struct node *nd;
+} :
+	[
+		LABEL Label(&nd)
+				{ if( nd )	{
+					DeclLabel(nd);
+					nd->nd_next = CurrentScope->sc_lablist;
+					CurrentScope->sc_lablist = nd;
+				  }
+				}
+		[ %persistent
+			',' Label(&nd)
+				{ if( nd )	{
+					DeclLabel(nd);
+					nd->nd_next = CurrentScope->sc_lablist;
+					CurrentScope->sc_lablist = nd;
+				  }
+				}
+		]*
+		';'
+	]?
+;
+
+ConstantDefinitionPart:
+	[
+		CONST
+		[ %persistent
+			ConstantDefinition ';'
+		]+
+	]?
+;
+
+TypeDefinitionPart:
+	[
+		TYPE
+		[ %persistent
+			TypeDefinition ';'
+		]+
+	]?
+;
+
+VariableDeclarationPart:
+	[
+		VAR 
+		[ %persistent
+			VariableDeclaration ';'
+		]+
+	]?
+;
+
+ProcedureAndFunctionDeclarationPart:
+	[
+		[
+			ProcedureDeclaration
+		|
+			FunctionDeclaration
+		] ';'
+	]*
+;
+
+/* ISO section 6.1.6, p. 92 */
+Label(struct node **pnd;)
+{
+	char lab[5];
+	extern char *sprint();
+} :
+	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]");
+		*pnd = NULLNODE;
+	  }
+	  else	{
+		sprint(lab, "%d", dot.TOK_INT);
+		*pnd = MkLeaf(Name, &dot);
+		(*pnd)->nd_IDF = str2idf(lab, 1);
+	  }
+	}
+;
+
+
+/* ISO section 6.3, p. 95 */
+ConstantDefinition
+{
+	register struct idf *id;
+	register struct def *df;
+	struct node *nd;
+} :
+	IDENT			{ id = dot.TOK_IDF; }
+	'=' Constant(&nd)
+			{ if( df = define(id,CurrentScope,D_CONST) )	{
+			  	df->con_const = nd;
+				df->df_type = nd->nd_type;
+			  }
+			}
+;
+
+/* ISO section 6.4.1, p. 96 */
+TypeDefinition
+{
+	register struct idf *id;
+	register struct def *df;
+	struct type *tp;
+} :
+	IDENT			{ id = dot.TOK_IDF; }
+	'=' TypeDenoter(&tp)
+			{ if( df = define(id, CurrentScope, D_TYPE) )
+			  	df->df_type = tp;
+			}
+;
+
+TypeDenoter(register struct type **ptp;):
+	/* This is a changed rule, because the grammar as specified in the
+	 * reference is not LL(1), and this gives conflicts.
+	 */
+	TypeIdentifierOrSubrangeType(ptp)
+|
+	PointerType(ptp)
+|
+	StructuredType(ptp)
+|
+	EnumeratedType(ptp)
+;
+
+TypeIdentifierOrSubrangeType(register struct type **ptp;)
+{
+	struct node *nd1, *nd2;
+} :
+	/* This is a new rule because the grammar specified by the standard
+	 * is not exactly LL(1) (see TypeDenoter).
+	 */
+[
+	%prefer
+	IDENT			{ nd1 = MkLeaf(Name, &dot); }
+	[
+		/* empty */
+		/* at this point IDENT must be a TypeIdentifier !! */
+				{ chk_type_id(ptp, nd1);
+			  	  FreeNode(nd1);
+				}
+	|
+		/* at this point IDENT must be a Constant !! */
+				{ (void) ChkConstant(nd1); }
+		UPTO Constant(&nd2)
+				{ *ptp = subr_type(nd1, nd2);
+				  FreeNode(nd1);
+				  FreeNode(nd2);
+				}
+	]
+|
+	Constant(&nd1) UPTO Constant(&nd2)
+				{ *ptp = subr_type(nd1, nd2);
+				  FreeNode(nd1);
+				  FreeNode(nd2);
+				}
+]
+;
+
+TypeIdentifier(register struct type **ptp;):
+	IDENT			{ register struct node *nd = MkLeaf(Name, &dot);
+				  chk_type_id(ptp, nd);
+				  FreeNode(nd);
+				}
+;
+
+/* ISO section 6.5.1, p. 105 */
+VariableDeclaration
+{
+	struct node *VarList;
+	struct type *tp;
+} :
+	IdentifierList(&VarList) ':' TypeDenoter(&tp)
+				{ EnterVarList(VarList, tp, proclevel > 0); }
+;
+
+/* ISO section 6.6.1, p. 108 */
+ProcedureDeclaration
+{
+	struct node *nd;
+	struct type *tp;
+	register struct scopelist *scl;
+	register struct def *df;
+} :
+	/* This is a changed rule, because the grammar as specified in the
+	 * reference is not LL(1), and this gives conflicts.
+	 *
+	 * ProcedureHeading without a FormalParameterList can be a
+	 * ProcedureIdentification, i.e. the IDENT used in the Heading is
+	 * also used in a "forward" declaration.
+	 */
+				{ open_scope(); }
+	ProcedureHeading(&nd, &tp) ';'
+				{ scl = CurrVis; close_scope(); }
+	[
+		Directive
+				{ DoDirective(dot.TOK_IDF, nd, tp, scl, 0); }
+	|
+				{ df = DeclProc(nd, tp, scl); }
+		Block(df)
+				{ /* open_scope() is simulated in DeclProc() */
+				  close_scope();
+				}
+	]
+;
+
+ProcedureHeading(register struct node **pnd; register struct type **ptp;)
+{
+	struct node *fpl;
+} :
+	PROCEDURE
+	IDENT			{ *pnd = MkLeaf(Name, &dot); }
+	[
+		FormalParameterList(&fpl)
+				{ arith nb_pars = 0;
+				  struct paramlist *pr = 0;
+
+				  if( !parlevel )
+					/* procedure declaration */
+					nb_pars = EnterParamList(fpl, &pr);
+				  else
+					/* procedure parameter */
+					EnterParTypes(fpl, &pr);
+				
+				  *ptp = proc_type(pr, nb_pars);
+				  FreeNode(fpl);
+				}
+	|
+		/* empty */
+				{ *ptp = proc_type(0, 0); }
+	]
+;
+
+Directive:
+	/* see also Functiondeclaration (6.6.2, p. 110)
+	 * Not actually an identifier but 'letter {letter | digit}'
+	 */
+	IDENT
+;
+
+/* ISO section 6.6.1, p. 108 */
+FunctionDeclaration
+{
+	struct node *nd;
+	struct type *tp;
+	register struct scopelist *scl;
+	register struct def *df;
+} :
+	/* This is a changed rule, because the grammar as specified in the
+	 * reference is not LL(1), and this gives conflicts.
+	 */
+				{ open_scope(); }
+	FunctionHeading(&nd, &tp) ';'
+				{ scl = CurrVis; close_scope(); }
+	[
+		Directive
+				{ if( !tp )	{
+					node_error(nd,
+					 "function \"%s\": illegal declaration",
+							nd->nd_IDF->id_text);
+				  }
+				  else DoDirective(dot.TOK_IDF, nd, tp, scl, 1);
+				}
+	|
+				{ if( df = DeclFunc(nd, tp, scl) )
+					df->prc_res = CurrentScope->sc_off =
+					     - ResultType(df->df_type)->tp_size;
+				}
+			Block(df)
+				{ if( df )
+					/* assignment to functionname is illegal
+					   outside the functionblock
+					 */
+					df->prc_res = 0;
+
+				  /* open_scope() is simulated in DeclFunc() */
+				  close_scope();
+				}
+	]
+;
+
+FunctionHeading(register struct node **pnd; register struct type **ptp;)
+{
+	/*	This is the Function AND FunctionIdentification part.
+		If it is a identification, *ptp is set to NULLTYPE.
+	*/
+	struct node *fpl = NULLNODE;
+	struct type *tp;
+	struct paramlist *pr = 0;
+	arith nb_pars = 0;
+} :
+	FUNCTION
+	IDENT			{ *pnd = MkLeaf(Name, &dot);
+				  *ptp = NULLTYPE;
+				}
+[
+	[
+		FormalParameterList(&fpl)
+				{ if( !parlevel )
+					/* function declaration */
+					nb_pars = EnterParamList(fpl, &pr);
+				  else
+					/* function parameter */
+					EnterParTypes(fpl, &pr);
+				}
+	|
+		/* empty */
+	]
+	':' TypeIdentifier(&tp)
+				{ if( IsConstructed(tp) )	{
+				        node_error(*pnd,
+				         "function has an illegal result type");
+					tp = error_type;
+				  }
+				  *ptp = func_type(pr, nb_pars, tp);
+				  FreeNode(fpl);
+				}
+]?
+;
+
+/* ISO section 6.4.2.1, p. 96 */
+OrdinalType(register struct type **ptp;):
+	/* This is a changed rule, because the grammar as specified in the
+	 * reference states that a SubrangeType can start with an IDENT and
+	 * so can an OrdinalTypeIdentifier, and this is not LL(1).
+	 */
+	TypeIdentifierOrSubrangeType(ptp)
+|
+	EnumeratedType(ptp)
+;
+
+/* ISO section 6.4.2.3, p. 97 */
+EnumeratedType(register struct type **ptp;)
+{
+	struct node *EnumList;
+	arith i = (arith) 1;
+} :
+	'(' IdentifierList(&EnumList) ')'
+		{ register struct type *tp =
+		  	standard_type(T_ENUMERATION, word_align, word_size);
+
+		  *ptp = tp;
+		  EnterEnumList(EnumList, tp);
+		  if( tp->enm_ncst == 0 )
+			*ptp = error_type;
+		  else do	{
+			if( ufit(tp->enm_ncst-1, i) )	{
+				tp->tp_psize = i;
+				tp->tp_palign = i;
+				break;
+		  	}
+			i <<= 1;
+		  } while( i < word_size );
+		}
+;
+
+IdentifierList(register struct node **nd;)
+{
+	register struct node *tnd;
+} :
+	IDENT		{ *nd = tnd = MkLeaf(Name, &dot); }
+	[ %persistent
+		',' IDENT
+			{ tnd->nd_next = MkLeaf(Name, &dot);
+			  tnd = tnd->nd_next;
+			}
+	]*
+;
+
+/* ISO section 6.4.3.2, p. 98 */
+StructuredType(register struct type **ptp;)
+{
+	unsigned short packed = 0;
+} :
+	[
+		PACKED { packed = T_PACKED; }
+	]?
+	UnpackedStructuredType(ptp, packed)
+;
+
+UnpackedStructuredType(register struct type **ptp; unsigned short packed;):
+	ArrayType(ptp, packed)
+|
+	RecordType(ptp, packed)
+|
+	SetType(ptp, packed)
+|
+	FileType(ptp)
+;
+
+/* ISO section 6.4.3.2, p. 98 */
+ArrayType(register struct type **ptp; unsigned short packed;)
+{
+	struct type *tp;
+	register struct type *tp2;
+} :
+	ARRAY
+	'['
+		Indextype(&tp)
+			{ *ptp = tp2 = construct_type(T_ARRAY, tp);
+			  tp2->tp_flags |= packed;
+			}
+		[ %persistent
+			',' Indextype(&tp)
+			{ tp2->arr_elem = construct_type(T_ARRAY, tp);
+			  tp2 = tp2->arr_elem;
+			  tp2->tp_flags |= packed;
+			}
+		]*
+	']'
+	OF ComponentType(&tp)
+			{ tp2->arr_elem = tp;
+			  ArraySizes(*ptp);
+			  if( tp->tp_flags & T_HASFILE )
+			  	(*ptp)->tp_flags |= T_HASFILE;
+			}
+;
+
+Indextype(register struct type **ptp;):
+	OrdinalType(ptp)
+;
+
+ComponentType(register struct type **ptp;):
+	TypeDenoter(ptp)
+;
+
+/* ISO section 6.4.3.3, p. 99 */
+RecordType(register struct type **ptp; unsigned short packed;)
+{
+	register struct scope *scope;
+	register struct def *df;
+	struct selector *sel = 0;
+	arith size = 0;
+	int xalign = struct_align;
+} :
+	RECORD
+		{ open_scope();		/* scope for fields of record */
+		  scope = CurrentScope;
+		  close_scope();
+		}
+	FieldList(scope, &size, &xalign, packed, &sel)
+		{ if( size == 0 )	{
+			warning("empty record declaration");
+			size = 1;
+		  }
+		  *ptp = standard_type(T_RECORD, xalign, size);
+		  (*ptp)->rec_scope = scope;
+		  (*ptp)->rec_sel = sel;
+		  (*ptp)->tp_flags |= packed;
+
+		  /* copy the file component flag */
+		  df = scope->sc_def;
+		  while( df && !(df->df_type->tp_flags & T_HASFILE) )
+			df = df->df_nextinscope;
+
+		  if( df )
+			(*ptp)->tp_flags |= T_HASFILE;
+		}
+	END
+;
+
+FieldList(struct scope *scope; arith *cnt; int *palign; unsigned short packed;
+							struct selector **sel;):
+	/* This is a changed rule, because the grammar as specified in the
+	 * reference is not LL(1), and this gives conflicts.
+	 * Those irritating, annoying (Siklossy !!) semicolons.
+	 */
+
+	/* empty */
+|
+	FixedPart(scope, cnt, palign, packed, sel)
+|
+	VariantPart(scope, cnt, palign, packed, sel)
+;
+
+FixedPart(struct scope *scope; arith *cnt; int *palign; unsigned short packed;
+							struct selector **sel;):
+	/* This is a changed rule, because the grammar as specified in the
+	 * reference is not LL(1), and this gives conflicts.
+	 * Again those frustrating semicolons !!
+	 */
+	RecordSection(scope, cnt, palign, packed)
+	FixedPartTail(scope, cnt, palign, packed, sel)
+;
+
+FixedPartTail(struct scope *scope; arith *cnt; int *palign;
+				unsigned short packed; struct selector **sel;):
+	/* This is a new rule because the grammar specified by the standard
+	 * is not exactly LL(1).
+	 * We see the light at the end of the tunnel !
+	 */
+
+	/* empty */
+|
+	%default
+	';'
+	[
+		/* empty */
+	|
+		VariantPart(scope, cnt, palign, packed, sel)
+	|
+		RecordSection(scope, cnt, palign, packed)
+		FixedPartTail(scope, cnt, palign, packed, sel)
+	]
+;
+
+RecordSection(struct scope *scope; arith *cnt; int *palign;
+							unsigned short packed;)
+{
+	struct node *FldList;
+	struct type *tp;
+} :
+
+	IdentifierList(&FldList) ':' TypeDenoter(&tp)
+			{ *palign =
+			      lcm(*palign, packed ? tp->tp_palign : word_align);
+			  EnterFieldList(FldList, tp, scope, cnt, packed);
+			}
+;
+
+VariantPart(struct scope *scope; arith *cnt; int *palign;
+				unsigned short packed; struct selector **sel;)
+{
+	struct type *tp;
+	struct def *df = 0;
+	struct idf *id = 0;
+	arith tcnt, max;
+	register arith ncst = 0;/* the number of values of the tagtype */
+	register struct selector **sp;
+	extern char *Malloc();
+} :
+	/* This is a changed rule, because the grammar as specified in the
+	 * reference is not LL(1), and this gives conflicts.
+	 * We're almost there !!
+	 */
+
+		{ *sel = (struct selector *) Malloc(sizeof(struct selector));
+		  (*sel)->sel_ptrs = 0;
+		}
+	CASE
+	VariantSelector(&tp, &id)
+		{ if (id)
+		  	df = define(id, scope, D_FIELD);
+/* ISO 6.4.3.3 (p. 100)
+ * The standard permits the integertype as tagtype, but demands that the set
+ * of values denoted by the case-constants is equal to the set of values
+ * specified by the tagtype. So we've decided not to allow integer as tagtype,
+ * because it's not practical to enumerate ALL integers as case-constants. 
+ * Though it wouldn't make a great difference to allow it as tagtype.
+ */
+	  	  if( !(tp->tp_fund & T_INDEX) )	{
+			error("illegal type in variant");
+			tp = error_type;
+		  }
+		  else	{
+			arith lb, ub;
+
+			getbounds(tp, &lb, &ub);
+			ncst = ub - lb + 1;
+
+			/* initialize selector */
+			(*sel)->sel_ptrs = (struct selector **)
+				       Malloc(ncst * sizeof(struct selector *));
+			(*sel)->sel_ncst = ncst;
+			(*sel)->sel_lb = lb;
+
+			/* initialize tagvalue-table */
+			sp = (*sel)->sel_ptrs;
+			while( ncst-- ) *sp++ = *sel;
+		  }
+		  (*sel)->sel_type = tp;
+		  if( df )	{
+	  		df->df_type = tp;
+	  		df->fld_flags |=
+				  packed ? (F_PACKED | F_SELECTOR) : F_SELECTOR;
+	  		df->fld_off = align(*cnt,
+					 packed ? tp->tp_palign : tp->tp_align);
+	  		*cnt = df->fld_off +
+					 (packed ? tp->tp_psize : tp->tp_size);
+		  }
+		  tcnt = *cnt;
+		}
+	OF
+	Variant(scope, &tcnt, palign, packed, *sel)
+			{ max = tcnt; }
+	VariantTail(scope, &tcnt, &max, cnt, palign, packed, *sel)
+			{ *cnt = max;
+			  if( sp = (*sel)->sel_ptrs )	{
+				int errflag = 0;
+
+				ncst = (*sel)->sel_ncst;
+				while( ncst-- )
+					if( *sp == *sel )	{
+						*sp++ = 0;
+						errflag = 1;
+					}
+					else *sp++;
+				if( errflag )
+		error("record variant part: each tagvalue must have a variant");
+			  }
+			}
+;
+
+VariantTail(register struct scope *scope; arith *tcnt, *max, *cnt;
+		int *palign; unsigned short packed; struct selector *sel;):
+	/* This is a new rule because the grammar specified by the standard
+	 * is not exactly LL(1).
+	 * At last, the garden of Eden !!
+	 */
+
+	/* empty */
+|
+%default
+	';'
+	[
+		/* empty */
+	|
+					{ *tcnt = *cnt; }
+		Variant(scope, tcnt, palign, packed, sel)
+					{ if( *tcnt > *max ) *max = *tcnt; }
+		VariantTail(scope, tcnt, max, cnt, palign, packed, sel)
+	]
+;
+
+VariantSelector(register struct type **ptp; register struct idf **pid;)
+{
+	register struct node *nd;
+} :
+	/* This is a changed rule, because the grammar as specified in the
+	 * reference is not LL(1), and this gives conflicts.
+	 */
+
+	IDENT				{ nd = MkLeaf(Name, &dot); }
+	[
+		/* Old fashioned ! at this point the IDENT represents
+		 * the TagType
+		 */
+				{ warning("old-fashioned syntax ':' missing");
+				  chk_type_id(ptp, nd);
+				  FreeNode(nd);
+				}
+	|
+		/* IDENT is now the TagField */
+		':'
+		TypeIdentifier(ptp)
+					{ *pid = nd->nd_IDF;
+					  FreeNode(nd);
+					}
+	]
+;
+
+Variant(struct scope *scope; arith *cnt; int *palign; unsigned short packed;
+							struct selector *sel;)
+{
+	struct node *nd;
+	struct selector *sel1 = 0;
+} :
+	CaseConstantList(&nd)
+	':'
+	'(' FieldList(scope, cnt, palign, packed, &sel1) ')'
+					{ TstCaseConstants(nd, sel, sel1);
+					  FreeNode(nd);
+					}
+;
+
+CaseConstantList(struct node **nd;)
+{
+	struct node *nd1;
+} :
+	Constant(&nd1)			{ *nd = nd1; }
+	[ %persistent
+		',' Constant(&(nd1->nd_next))
+					{ nd1 = nd1->nd_next; }
+	]*
+;
+
+/* ISO section 6.4.3.4, p. 101 */
+SetType(register struct type **ptp; unsigned short packed;):
+	SET OF OrdinalType(ptp)
+		{ *ptp = set_type(*ptp, packed); }
+;
+
+/* ISO section 6.4.3.5, p. 101 */
+FileType(register struct type **ptp;):
+	FILE OF
+			{ *ptp = construct_type(T_FILE, NULLTYPE);
+			  (*ptp)->tp_flags |= T_HASFILE;
+			}
+	ComponentType(&(*ptp)->next)
+			{ if( (*ptp)->next->tp_flags & T_HASFILE ) {
+			      error("file type has an illegal component type");
+			      (*ptp)->next = error_type;
+			  }
+			}
+;
+
+/* ISO section 6.4.4, p. 103 */
+PointerType(register struct type **ptp;)
+{
+	register struct node *nd;
+	register struct def *df;
+} :
+	'^'
+			{ *ptp = construct_type(T_POINTER, NULLTYPE); }
+	IDENT
+			{ nd = MkLeaf(Name, &dot);
+			  df = lookup(nd->nd_IDF, CurrentScope);
+			  if( in_type_defs &&
+			      (!df || (df->df_kind & (D_ERROR | D_FORWTYPE)))
+			    )
+				/* forward declarations only in typedefintion
+				   part
+				*/
+				Forward(nd, *ptp);
+			  else	{
+				chk_type_id(&(*ptp)->next, nd);
+			  	FreeNode(nd);
+			  }
+			}
+;
+
+/* ISO section 6.6.3.1, p. 112 */
+FormalParameterList(struct node **pnd;)
+{
+	struct node *nd;
+} :
+	'('
+					{ *pnd = nd = MkLeaf(Link, &dot); }
+		FormalParameterSection(nd)
+		[ %persistent
+					{ nd->nd_right = MkLeaf(Link, &dot);
+					  nd = nd->nd_right;
+					}
+		';' FormalParameterSection(nd)
+		]*
+	')'
+;
+
+FormalParameterSection(struct node *nd;):
+/* This is a changed rule, because the grammar as specified
+ * in the reference is not LL(1), and this gives conflicts.
+ */
+					{ /* kind of parameter */
+					  nd->nd_INT = 0;
+					}
+[
+	[
+		/* ValueParameterSpecification */
+		/* empty */
+					{ nd->nd_INT = D_VALPAR; }
+	|
+		/* VariableParameterSpecification */
+		VAR
+					{ nd->nd_INT = D_VARPAR; }
+	]
+	IdentifierList(&(nd->nd_left)) ':'
+	[
+		/* ISO section 6.6.3.7.1, p. 115 */
+		/* ConformantArrayParameterSpecification */
+		ConformantArraySchema(&(nd->nd_type))
+	|
+		TypeIdentifier(&(nd->nd_type))
+	]
+			{ if( nd->nd_type->tp_flags & T_HASFILE  &&
+			      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))
+|
+	FunctionalParameterSpecification(&(nd->nd_left), &(nd->nd_type))
+]
+;
+
+ProceduralParameterSpecification(register struct node **pnd;
+						register struct type **ptp;):
+				{ parlevel++; }
+	ProcedureHeading(pnd, ptp)
+				{ parlevel--; }
+;
+
+FunctionalParameterSpecification(register struct node **pnd;
+						register struct type **ptp;):
+				{ parlevel++; }
+	FunctionHeading(pnd, ptp)
+				{ parlevel--;
+				  if( !*ptp )	{
+				      node_error(*pnd,
+				      "illegal function parameter declaration");
+				      *ptp = error_type;
+				  }
+				}
+;
+
+ConformantArraySchema(register struct type **ptp;):
+	PackedConformantArraySchema(ptp)
+|
+	%default
+	UnpackedConformantArraySchema(ptp)
+;
+
+PackedConformantArraySchema(register struct type **ptp;)
+{
+	struct type *tp;
+} :
+	PACKED ARRAY
+				{ tp = construct_type(T_ARRAY, NULLTYPE);
+				  tp->tp_flags |= T_PACKED;
+				}
+	'['
+		Index_TypeSpecification(ptp, tp)
+				{ tp->next = *ptp; }
+	']'
+	OF TypeIdentifier(ptp)
+				{ if( (*ptp)->tp_flags & T_HASFILE )
+					tp->tp_flags |= T_HASFILE;
+				  tp->arr_elem = *ptp;
+				  *ptp = tp;
+				}
+;
+
+UnpackedConformantArraySchema(register struct type **ptp;)
+{
+	struct type *tp, *tp2;
+} :
+	ARRAY
+				{ *ptp = tp = construct_type(T_ARRAY,NULLTYPE);}
+	'['
+		Index_TypeSpecification(&tp2, tp)
+				{ tp->next = tp2; }
+		[
+				{ tp->arr_elem =
+					construct_type(T_ARRAY, NULLTYPE);
+				  tp = tp->arr_elem;
+				}
+		';' Index_TypeSpecification(&tp2, tp)
+				{ tp->next = tp2; }
+		]*
+	']'
+	OF
+	[
+		TypeIdentifier(&tp2)
+	|
+		ConformantArraySchema(&tp2)
+	]
+				{ if( tp2->tp_flags & T_HASFILE )
+					(*ptp)->tp_flags |= T_HASFILE;
+				  tp->arr_elem = tp2;
+				}
+;
+
+Index_TypeSpecification(register struct type **ptp, *tp;)
+{
+	register struct def *df1, *df2;
+} :
+	IDENT
+			{ if( df1 = define(dot.TOK_IDF, CurrentScope, D_LBOUND))
+				df1->bnd_type = tp;	/* type conf. array */
+			}
+	UPTO
+	IDENT
+			{ if( df2 = define(dot.TOK_IDF, CurrentScope, D_UBOUND))
+				df2->bnd_type = tp;	/* type conf. array */
+			}
+	':' TypeIdentifier(ptp)
+			{ if( !bounded(*ptp) &&
+			      (*ptp)->tp_fund != T_INTEGER )	{
+				error("Indextypespecification: illegal type");
+				*ptp = error_type;
+			  }
+			  df1->df_type = df2->df_type = *ptp;
+			}
+;

lang/pc/comp/def.H

@@ -0,0 +1,134 @@
+/* I D E N T I F I E R   D E S C R I P T O R   S T R U C T U R E */
+
+struct constant	{
+	struct node *co_const;	/* result of a constant expression */
+#define con_const	df_value.df_constant.co_const
+};
+
+struct variable	{
+	arith va_off;		/* address of variable */
+	char *va_name;		/* name of variable if given */
+#define var_off		df_value.df_variable.va_off
+#define var_name	df_value.df_variable.va_name
+};
+
+struct bound	{
+	struct type *bo_type;	/* type of conformant array */
+#define bnd_type	df_value.df_bound.bo_type
+};
+
+struct enumval	{
+	unsigned int en_val;	/* value of this enumeration literal */
+	struct def *en_next;	/* next enumeration literal */
+#define enm_val		df_value.df_enum.en_val
+#define enm_next	df_value.df_enum.en_next
+};
+
+struct field	{
+	arith fd_off;
+	unsigned short fd_flags;
+#define F_SELECTOR	0x1	/* set if field is a variant selector */
+#define F_PACKED	0x2	/* set if record is packed */
+
+#define fld_off		df_value.df_field.fd_off
+#define fld_flags	df_value.df_field.fd_flags
+};
+
+struct lab	{
+	struct lab *lb_next;	/* list of goto statements to this label */
+	int lb_level;		/* level of nesting */
+	label lb_no;		/* instruction label */
+	label lb_descr;		/* label of goto descriptor */
+#define lab_next	df_value.df_label.lb_next
+#define lab_level	df_value.df_label.lb_level
+#define lab_no		df_value.df_label.lb_no
+#define lab_descr	df_value.df_label.lb_descr
+};
+
+/* ALLOCDEF "lab" 10 */
+
+struct forwtype	{
+	struct forwtype *f_next;
+	struct node *f_node;
+	struct type *f_type;
+};
+
+/* ALLOCDEF "forwtype" 50 */
+
+struct dfproc	{			/* used for procedures and functions */
+	struct scopelist *pc_vis;	/* scope of this procedure/function */
+	char *pc_name;			/* internal name */
+	arith pc_res;			/* offset of function result */
+#define prc_vis		df_value.df_proc.pc_vis
+#define prc_name	df_value.df_proc.pc_name
+#define prc_res		df_value.df_proc.pc_res
+};
+
+struct def	{		/* list of definitions for a name */
+	struct def *df_next;	/* next definition in definitions chain */
+	struct def *df_nextinscope;
+				/* link all definitions in a scope */
+	struct idf *df_idf;	/* link back to the name */
+	struct scope *df_scope;	/* scope in which this definition resides */
+	unsigned int 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_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
+				 */
+	struct type *df_type;
+	union {
+		struct constant df_constant;
+		struct variable df_variable;
+		struct bound df_bound;
+		struct enumval df_enum;
+		struct field df_field;
+		struct lab df_label;
+		struct forwtype *df_fwtype;
+		struct dfproc df_proc;
+		int df_reqname;	/* define for required name */
+	} df_value;
+#define df_fortype	df_value.df_fwtype
+};
+
+/* ALLOCDEF "def" 50 */
+
+extern struct def
+	*define(),
+	*MkDef(),
+	*DeclProc(),
+	*DeclFunc();
+
+extern struct def
+	*lookup(),
+	*lookfor();
+
+#define NULLDEF ((struct def *) 0)

lang/pc/comp/def.c

@@ -0,0 +1,226 @@
+/* D E F I N I T I O N   M E C H A N I S M */
+
+#include	"debug.h"
+
+#include	<alloc.h>
+#include	<assert.h>
+#include	<em_arith.h>
+#include	<em_label.h>
+
+#include	"LLlex.h"
+#include	"def.h"
+#include	"idf.h"
+#include	"main.h"
+#include	"misc.h"
+#include	"node.h"
+#include	"scope.h"
+#include	"type.h"
+
+struct def *
+MkDef(id, scope, kind)
+	register struct idf *id;
+	register struct scope *scope;
+{
+	/*	Create a new definition structure in scope "scope", with
+	 *	id "id" and kind "kind".
+	 */
+	register struct def *df = new_def();
+
+	df->df_idf = id;
+	df->df_scope = scope;
+	df->df_kind = kind;
+	df->df_type = error_type;
+	df->df_next = id->id_def;
+	id->id_def = df;
+
+	/* enter the definition in the list of definitions in this scope
+	*/
+	df->df_nextinscope = scope->sc_def;
+	scope->sc_def = df;
+	return df;
+}
+
+struct def *
+define(id, scope, kind)
+	register struct idf *id;
+	register struct scope *scope;
+{
+	/*	Declare an identifier in a scope, but first check if it
+		already has been defined.
+		If so, then check for the cases in which this is legal,
+		and otherwise give an error message.
+	*/
+	register struct def *df;
+
+	if( df = lookup(id, scope) )	{
+		switch( df->df_kind )	{
+
+		    case D_LABEL :
+			/* generate error message somewhere else */
+			return NULLDEF;
+
+		    case D_PARAMETER :
+			if( kind == D_VARIABLE )
+			/* program parameter declared as variable */
+				return df;
+			break;
+
+		    case D_FORWTYPE :
+			if( kind == D_FORWTYPE ) return df;
+			if( kind == D_TYPE )	{
+			/* forward reference resolved */
+				df->df_kind = D_FTYPE;
+				return df;
+			}
+			else
+				error("identifier \"%s\" must be a type",
+							id->id_text);
+			return NULLDEF;
+
+		    case D_FWPROCEDURE :
+			if( kind == D_PROCEDURE ) return df;
+			error("procedure identification \"%s\" expected",
+								id->id_text);
+			return NULLDEF;
+
+		    case D_FWFUNCTION :
+			if( kind == D_FUNCTION ) return df;
+			error("function identification \"%s\" expected",
+								id->id_text);
+			return NULLDEF;
+
+		    case D_ERROR :
+			/* used in forward references */
+			df->df_kind = kind;
+			return df;
+		}
+		if( kind != D_ERROR )
+			/* avoid spurious error messages */
+		        error("identifier \"%s\" already declared",id->id_text);
+
+		return NULLDEF;
+	}
+
+	return MkDef(id, scope, kind);
+}
+
+DoDirective(directive, nd, tp, scl, function)
+	struct idf *directive;
+	struct node *nd;
+	struct type *tp;
+	struct scopelist *scl;
+{
+	int kind;			/* kind of directive */
+	int inp;			/* internal or external name */
+	int ext = 0;		/* directive = EXTERN */
+	struct def *df = lookup(directive, PervasiveScope);
+
+	if( !df )	{
+		if( !is_anon_idf(directive) )
+			node_error(nd, "\"%s\" unknown directive",
+							directive->id_text);
+		return;
+	}
+
+	switch( df->df_kind)	{
+		case D_FORWARD:
+			kind = function ? D_FWFUNCTION : D_FWPROCEDURE;
+			inp = (proclevel > 1);
+			break;
+
+		case D_EXTERN:
+			kind = function ? D_FUNCTION : D_PROCEDURE;
+			inp = 0;
+			ext = 1;
+			break;
+
+		default:
+			crash("(DoDirective)");
+	}
+
+	if( df = define(nd->nd_IDF, CurrentScope, kind) )	{
+		if( df->df_kind != kind )	{
+			/* identifier already forward declared */
+			node_error(nd, "\"%s\" already forward declared",
+							nd->nd_IDF->id_text);
+			return;
+		}
+
+		df->df_type = tp;
+		df->prc_vis = scl;
+		df->prc_name = gen_proc_name(nd->nd_IDF, inp);
+		if( ext ) df->df_flags |= D_EXTERNAL;
+	}
+}
+			
+struct def *
+DeclProc(nd, tp, scl)
+	register struct node *nd;
+	struct type *tp;
+	register struct scopelist *scl;
+{
+	register struct def *df;
+
+	if( df = define(nd->nd_IDF, CurrentScope, D_PROCEDURE) )	{
+		if( df->df_kind == D_FWPROCEDURE )	{
+			df->df_kind = D_PROCEDURE;	/* identification */
+
+			/* Simulate a call to open_scope(), which has already
+			 * been performed in the forward declaration.
+			 */
+			CurrVis = df->prc_vis;
+
+			if( tp->prc_params )
+				node_error(nd,
+				  "procedure identification \"%s\" expected",
+							nd->nd_IDF->id_text);
+		}
+		else	{	/* normal declaration */
+			df->df_type = tp;
+			df->prc_name = gen_proc_name(nd->nd_IDF, (proclevel>1));
+			/* simulate open_scope() */
+			CurrVis = df->prc_vis = scl;
+		}
+	}
+	else CurrVis = scl;		/* simulate open_scope() */
+
+	return df;
+}
+
+struct def *
+DeclFunc(nd, tp, scl)
+	register struct node *nd;
+	struct type *tp;
+	register struct scopelist *scl;
+{
+	register struct def *df;
+
+	if( df = define(nd->nd_IDF, CurrentScope, D_FUNCTION) )	{
+	    if( df->df_kind == D_FUNCTION )	{	/* declaration */
+		if( !tp )	{
+			node_error(nd, "\"%s\" illegal function declaration",
+							nd->nd_IDF->id_text);
+			tp = error_type;
+		}
+		/* simulate open_scope() */
+		CurrVis = df->prc_vis = scl;
+		df->df_type = tp;
+		df->prc_name = gen_proc_name(nd->nd_IDF, (proclevel > 1));
+	    }
+	    else	{			/* identification */
+		assert(df->df_kind == D_FWFUNCTION);
+
+		df->df_kind = D_FUNCTION;
+		CurrVis = df->prc_vis;
+
+		if( tp )
+			node_error(nd,
+				   "function identification \"%s\" expected",
+				   nd->nd_IDF->id_text);
+
+	    }
+	}
+	else CurrVis = scl;			/* simulate open_scope() */
+
+	return df;
+}

lang/pc/comp/desig.H

@@ -0,0 +1,59 @@
+/* D E S I G N A T O R   D E S C R I P T I O N S */
+
+/* Generating code for designators is not particularly easy, especially if
+   you don't know whether you want the address or the value.
+   The next structure is used to generate code for designators.
+   It contains information on how to find the designator, after generation
+   of the code that is common to both address and value computations.
+*/
+
+struct desig	{
+	int	dsg_kind;
+#define DSG_INIT	0	/* don't know anything yet */
+#define DSG_LOADED	1	/* designator loaded on top of the stack */
+#define DSG_PLOADED	2	/* designator accessible through pointer on
+				   stack, possibly with an offset
+				*/
+#define DSG_FIXED	3	/* designator directly accessible */
+#define DSG_PFIXED	4	/* designator accessible through directly
+				   accessible pointer
+				*/
+#define DSG_INDEXED	5	/* designator accessible through array
+				   operation. Address of array descriptor on
+				   top of the stack, index beneath that, and
+				   base address beneath that
+				*/
+	arith	dsg_offset;	/* contains an offset for PLOADED,
+				   or for FIXED or PFIXED it contains an
+				   offset from dsg_name, if it exists,
+				   or from the current Local Base
+				*/
+	char	*dsg_name;	/* name of global variable, used for
+				   FIXED and PFIXED
+				*/
+	struct def *dsg_def;	/* def structure associated with this
+				   designator, or 0
+				*/
+	int dsg_packed;		/* designator is packed or not */
+};
+
+/* The next structure describes the designator in a with-statement.
+   We have a linked list of them, as with-statements may be nested.
+*/
+
+struct withdesig	{
+	struct withdesig *w_next;
+	struct scope *w_scope;	/* scope in which fields of this record
+				   reside
+				*/
+	struct desig w_desig;	/* a desig structure for this particular
+				   designator
+				*/
+};
+
+/* ALLOCDEF "withdesig" 5 */
+
+extern struct withdesig	*WithDesigs;
+extern struct desig	InitDesig;
+
+#define NO_LABEL	((label) 0)

lang/pc/comp/desig.c

@@ -0,0 +1,565 @@
+/* D E S I G N A T O R   E V A L U A T I O N */
+
+/*	Code generation for designators.
+	This file contains some routines that generate code common to address
+	as well as value computations, and leave a description in a "desig"
+	structure. It also contains routines to load an address, load a value
+	or perform a store.
+*/
+
+#include	"debug.h"
+
+#include	<assert.h>
+#include	<em.h>
+
+#include	"LLlex.h"
+#include	"def.h"
+#include	"desig.h"
+#include	"main.h"
+#include	"node.h"
+#include	"scope.h"
+#include	"type.h"
+
+struct desig	InitDesig = {DSG_INIT, 0, 0, NULLDEF, 0};
+struct withdesig *WithDesigs;
+
+
+STATIC int
+properly(ds, size, al)
+	register struct desig *ds;
+	arith size;
+{
+	/*	Check if it is allowed to load or store the value indicated
+		by "ds" with LOI/STI.
+		- if the size is not either a multiple or a dividor of the
+		  wordsize, then not.
+		- if the alignment is at least "word" then OK.
+		- if size is dividor of word_size and alignment >= size then OK.
+		- otherwise check alignment of address. This can only be done
+		  with DSG_FIXED.
+	*/
+
+	arith szmodword = size % word_size;	/* 0 if multiple of wordsize */
+	arith wordmodsz = word_size % size;	/* 0 if dividor of wordsize */
+
+	if( szmodword && wordmodsz ) return 0;
+	if( al >= word_align ) return 1;
+	if( szmodword && al >= szmodword ) return 1;
+
+	return ds->dsg_kind == DSG_FIXED &&
+	       ((! szmodword && ds->dsg_offset % word_align == 0) ||
+		(! wordmodsz && ds->dsg_offset % size == 0));
+}
+
+CodeCopy(lhs, rhs, sz, psize)
+	register struct desig *lhs, *rhs;
+	arith sz, *psize;
+{
+	struct desig l, r;
+
+	l = *lhs;
+	r = *rhs;
+	*psize -= sz;
+	lhs->dsg_offset += sz;
+	rhs->dsg_offset += sz;
+	CodeAddress(&r);
+	C_loi(sz);
+	CodeAddress(&l);
+	C_sti(sz);
+}
+
+CodeMove(rhs, left, rtp)
+	register struct desig *rhs;
+	register struct node *left;
+	struct type *rtp;
+{
+	struct desig dsl;
+	register struct desig *lhs = &dsl;
+	register struct type *ltp = left->nd_type;
+
+	dsl = InitDesig;
+	/*	Generate code for an assignment. Testing of type
+		compatibility and the like is already done.
+		Go through some (considerable) trouble to see if
+		a BLM can be generated.
+	*/
+
+	switch( rhs->dsg_kind )	{
+	case DSG_LOADED:
+		CodeDesig(left, lhs);
+		if( rtp->tp_fund == T_STRING )	{
+			CodeAddress(lhs);
+			C_blm(lhs->dsg_packed ? ltp->tp_psize : ltp->tp_size);
+			return;
+		}
+		CodeStore(lhs, ltp);
+		return;
+
+	case DSG_PLOADED:
+	case DSG_PFIXED:
+		CodeAddress(rhs);
+		CodeValue(rhs, rtp);
+		CodeDStore(left);
+		return;
+
+	case DSG_FIXED:	{
+		arith tpsize;
+
+		CodeDesig(left, lhs);
+		tpsize = lhs->dsg_packed ? ltp->tp_psize : ltp->tp_size;
+		if( lhs->dsg_kind == DSG_FIXED &&
+		    lhs->dsg_offset % word_size == rhs->dsg_offset % word_size
+		  )	{
+			arith size = tpsize;
+
+			if( size > 6 * word_size )	{
+				/*	Do a block move
+				*/
+				struct desig l, r;
+
+				l = *lhs;
+				r = *rhs;
+				CodeAddress(&r);
+				CodeAddress(&l);
+				C_blm(size);
+			}
+			else	{
+				register arith sz;
+
+				for( sz = 2 * word_size; sz; sz -= word_size) {
+					while( size >= sz )
+					/*	Then copy dwords, words.
+						Depend on peephole optimizer
+					*/
+					CodeCopy(lhs, rhs, sz, &size);
+				}
+			}
+			return;
+		}
+		if( lhs->dsg_kind == DSG_PLOADED ||
+		    lhs->dsg_kind == DSG_INDEXED )	{
+			CodeAddress(lhs);
+		}
+	}
+	default:
+		crash("(CodeMove)");
+		/*NOTREACHED*/
+	}
+}
+
+CodeValue(ds, tp)
+	register struct desig *ds;
+	register struct type *tp;
+{
+	/*	Generate code to load the value of the designator described
+		in "ds"
+	*/
+	arith size = ds->dsg_packed ? tp->tp_psize : tp->tp_size;
+	int align = ds->dsg_packed ? tp->tp_palign : tp->tp_align;
+
+	switch( ds->dsg_kind )	{
+	case DSG_LOADED:
+		break;
+
+	case DSG_FIXED:
+		if( ds->dsg_offset % word_size == 0 && size == word_size ) {
+			if( ds->dsg_name )
+				C_loe_dnam(ds->dsg_name, ds->dsg_offset);
+			else
+				C_lol(ds->dsg_offset);
+			break;
+		}
+		/* Fall through */
+	case DSG_PLOADED:
+	case DSG_PFIXED:
+		if( properly(ds, size, align) )	{
+			CodeAddress(ds);
+			C_loi(size);
+			break;
+		}
+		printf("(CodeValue) : not properly");
+		break;
+
+	case DSG_INDEXED:
+		C_lar(word_size);
+		break;
+
+	default:
+		crash("(CodeValue)");
+		/*NOTREACHED*/
+	}
+
+	ds->dsg_kind = DSG_LOADED;
+}
+
+CodeStore(ds, tp)
+	register struct desig *ds;
+	register struct type *tp;
+{
+	/*	Generate code to store the value on the stack in the designator
+		described in "ds"
+	*/
+	struct desig save;
+	arith size = ds->dsg_packed ? tp->tp_psize : tp->tp_size;
+	int align = ds->dsg_packed ? tp->tp_palign : tp->tp_align;
+
+	save = *ds;
+	
+	switch( ds->dsg_kind )	{
+	case DSG_FIXED:
+		if( ds->dsg_offset % word_size == 0 && size == word_size ) {
+			if( ds->dsg_name )
+				C_ste_dnam(ds->dsg_name, ds->dsg_offset);
+			else
+				C_stl(ds->dsg_offset);
+			break;
+		}
+		/* Fall through */
+	case DSG_PLOADED:
+	case DSG_PFIXED:
+		CodeAddress(&save);
+		if( properly(ds, size, align) )	{
+			C_sti(size);
+			break;
+		}
+		printf("(CodeStore) : not properly");
+		break;
+
+	case DSG_INDEXED:
+		C_sar(word_size);
+		break;
+
+	default:
+		crash("(CodeStore)");
+		/*NOTREACHED*/
+	}
+
+	ds->dsg_kind = DSG_INIT;
+}
+
+CodeAddress(ds)
+	register struct desig *ds;
+{
+	/*	Generate code to load the address of the designator described
+	   	in "ds"
+	*/
+
+	switch( ds->dsg_kind )	{
+	case DSG_PLOADED:
+		if( ds->dsg_offset )
+			C_adp(ds->dsg_offset);
+		break;
+
+	case DSG_FIXED:
+		if( ds->dsg_name )	{
+			C_lae_dnam(ds->dsg_name, ds->dsg_offset);
+			break;
+		}
+		C_lal(ds->dsg_offset);
+		if( ds->dsg_def )
+			ds->dsg_def->df_flags |= D_NOREG;
+		break;
+		
+	case DSG_PFIXED:
+		if( ds->dsg_name )
+			C_loe_dnam(ds->dsg_name, ds->dsg_offset);
+		else
+			C_lol(ds->dsg_offset);
+		break;
+
+	case DSG_INDEXED:
+		C_aar(word_size);
+		break;
+
+	default:
+		crash("(CodeAddress)");
+		/*NOTREACHED*/
+	}
+
+	ds->dsg_offset = 0;
+	ds->dsg_kind = DSG_PLOADED;
+}
+
+CodeFieldDesig(df, ds)
+	register struct def *df;
+	register struct desig *ds;
+{
+	/* Generate code for a field designator. Only the code common for
+	   address as well as value computation is generated, and the
+	   resulting information on where to find the designator is placed
+	   in "ds". "df" indicates the definition of the field.
+	*/
+
+	if( ds->dsg_kind == DSG_INIT )	{
+		/* In a WITH statement. We must find the designator in the
+		   WITH statement, and act as if the field is a selection
+		   of this designator.
+		   So, first find the right WITH statement, which is the
+		   first one of the proper record type, which is
+		   recognized by its scope indication.
+		*/
+		register struct withdesig *wds = WithDesigs;
+
+		assert(wds != 0);
+
+		while( wds->w_scope != df->df_scope )	{
+			wds = wds->w_next;
+			assert(wds != 0);
+		}
+
+		/* Found it. Now, act like it was a selection.
+		*/
+		*ds = wds->w_desig;
+		assert(ds->dsg_kind == DSG_PFIXED);
+	}
+
+	switch( ds->dsg_kind )	{
+		case DSG_PLOADED:
+		case DSG_FIXED:
+			ds->dsg_offset += df->fld_off;
+			break;
+
+		case DSG_PFIXED:
+		case DSG_INDEXED:
+			CodeAddress(ds);
+			ds->dsg_kind = DSG_PLOADED;
+			ds->dsg_offset = df->fld_off;
+			break;
+
+		default:
+			crash("(CodeFieldDesig)");
+	}
+
+	ds->dsg_packed = df->fld_flags & F_PACKED;
+}
+
+CodeVarDesig(df, ds)
+	register struct def *df;
+	register struct desig *ds;
+{
+	/*	Generate code for a variable represented by a "def" structure.
+		Of course, there are numerous cases: the variable is local,
+		it is a value parameter, it is a var parameter, it is one of
+		those of an enclosing procedure, or it is global.
+	*/
+	register struct scope *sc = df->df_scope;
+
+	assert(ds->dsg_kind == DSG_INIT);
+
+	if( df->var_name )	{
+		/* this variable has been given a name, so it is global.
+		   It is directly accessible.
+		*/
+		ds->dsg_name = df->var_name;
+		ds->dsg_offset = 0;
+		ds->dsg_kind = DSG_FIXED;
+		return;
+	}
+
+	if( sc->sc_level != proclevel )	{
+		/* the variable is local to a statically enclosing procedure.
+		*/
+		assert(proclevel > sc->sc_level);
+
+		df->df_flags |= D_NOREG;
+		if( df->df_flags & (D_VARPAR|D_VALPAR) )	{
+			/* value or var parameter
+			*/
+			C_lxa((arith) (proclevel - sc->sc_level));
+			if( (df->df_flags & D_VARPAR) ||
+			    IsConformantArray(df->df_type) )	{
+				/* var parameter or conformant array.
+				   For conformant array's, the address is
+				   passed.
+				*/
+				C_adp(df->var_off);
+				C_loi(pointer_size);
+				ds->dsg_offset = 0;
+				ds->dsg_kind = DSG_PLOADED;
+				return;
+			}
+		}
+		else
+			C_lxl((arith) (proclevel - sc->sc_level));
+
+		ds->dsg_kind = DSG_PLOADED;
+		ds->dsg_offset = df->var_off;
+		return;
+	}
+
+	/* Now, finally, we have a local variable or a local parameter
+	*/
+	if( (df->df_flags & D_VARPAR) || IsConformantArray(df->df_type) )
+		/* a var parameter; address directly accessible. */
+		ds->dsg_kind = DSG_PFIXED;
+	else
+		ds->dsg_kind = DSG_FIXED;
+
+	ds->dsg_offset = df->var_off;
+	ds->dsg_def = df;
+}
+
+CodeBoundDesig(df, ds)
+	register struct def *df;
+	register struct desig *ds;
+{
+	/* Generate code for the lower- and upperbound of a conformant array */
+
+	assert(ds->dsg_kind == DSG_INIT);
+
+	if( df->df_scope->sc_level < proclevel )	{
+		C_lxa((arith) (proclevel - df->df_scope->sc_level));
+		if( df->df_kind == D_UBOUND )	{
+			C_ldf(df->bnd_type->arr_cfdescr);
+			C_adi(word_size);
+		}
+		else
+			C_lof(df->bnd_type->arr_cfdescr);
+	}
+	else	{
+		if( df->df_kind == D_UBOUND )	{
+			C_ldl(df->bnd_type->arr_cfdescr);
+			C_adi(word_size);
+		}
+		else
+			C_lol(df->bnd_type->arr_cfdescr);
+	}
+
+	ds->dsg_kind = DSG_LOADED;
+}
+
+CodeFuncDesig(df, ds)
+	register struct def *df;
+	register struct desig *ds;
+{
+	/* generate code to store the function result */
+
+	if( df->df_scope->sc_level + 1 < proclevel )	{
+		/* Assignment to function-identifier in the declaration-part of
+		   the function (i.e. in the statement-part of a nested function
+		   or procedure).
+		*/
+		C_lxl((arith) (proclevel - df->df_scope->sc_level - 1));
+		ds->dsg_kind = DSG_PLOADED;
+	}
+	else	{
+		/* Assignment to function-identifier in the statement-part of
+		   the function.
+		*/
+		ds->dsg_kind = DSG_FIXED;
+	}
+	assert(df->prc_res < 0);
+	ds->dsg_offset = df->prc_res;
+}
+
+CodeDesig(nd, ds)
+	register struct node *nd;
+	register struct desig *ds;
+{
+	/*	Generate code for a designator. Use divide and conquer
+		principle
+	*/
+	register struct def *df;
+
+	switch( nd->nd_class )	{	/* Divide */
+	case Def:
+		df = nd->nd_def;
+
+		switch( df->df_kind )	{
+		case D_FIELD:
+			CodeFieldDesig(df, ds);
+			break;
+
+		case D_VARIABLE:
+			CodeVarDesig(df, ds);
+			break;
+
+		case D_LBOUND:
+		case D_UBOUND:
+			CodeBoundDesig(df, ds);
+			break;
+
+		case D_FUNCTION:
+			CodeFuncDesig(df, ds);
+			break;
+
+		default:
+			crash("(CodeDesig) Def");
+		}
+		break;
+
+	case LinkDef:
+		assert(nd->nd_symb == '.');
+
+		CodeDesig(nd->nd_left, ds);
+		CodeFieldDesig(nd->nd_def, ds);
+		break;
+
+	case Arrsel:	{
+		struct type *tp;
+
+		assert(nd->nd_symb == '[');
+
+		CodeDesig(nd->nd_left, ds);
+		CodeAddress(ds);
+		CodePExpr(nd->nd_right);
+
+		/* Now load address of descriptor
+		*/
+		tp = nd->nd_left->nd_type;
+		if( IsConformantArray(tp) )	{
+			if( tp->arr_sclevel < proclevel )	{
+				C_lxa((arith) (proclevel - tp->arr_sclevel));
+				C_adp(tp->arr_cfdescr);
+			}
+			else
+				C_lal(tp->arr_cfdescr);
+		}
+		else
+			C_lae_dlb(tp->arr_ardescr, (arith) 0);
+
+		ds->dsg_kind = DSG_INDEXED;
+		ds->dsg_packed = IsPacked(tp);
+		break;
+	}
+
+	case Arrow:
+		assert(nd->nd_symb == '^');
+
+		if( nd->nd_right->nd_type->tp_fund == T_FILE )	{
+			CodeDAddress(nd->nd_right);
+			C_cal("_wdw");
+			C_asp(pointer_size);
+			C_lfr(pointer_size);
+			ds->dsg_kind = DSG_PLOADED;
+			ds->dsg_packed = 1;
+			break;
+		}
+
+		CodeDesig(nd->nd_right, ds);
+		switch(ds->dsg_kind) {
+		case DSG_LOADED:
+			ds->dsg_kind = DSG_PLOADED;
+			break;
+
+		case DSG_INDEXED:
+		case DSG_PLOADED:
+		case DSG_PFIXED:
+			CodeValue(ds, nd->nd_right->nd_type);
+			ds->dsg_kind = DSG_PLOADED;
+			ds->dsg_offset = 0;
+			break;
+
+		case DSG_FIXED:
+			ds->dsg_kind = DSG_PFIXED;
+			break;
+
+		default:
+			crash("(CodeDesig) Uoper");
+		}
+		break;
+		
+	default:
+		crash("(CodeDesig) class");
+	}
+}

lang/pc/comp/em_pc.6

@@ -0,0 +1,61 @@
+.TH EM_PC ACK
+.ad
+.SH NAME
+em_pc \- Pascal compiler
+.SH SYNOPSIS
+.B em_pc
+.RI [ option ] 
+.I source
+.I destination
+.SH DESCRIPTION
+.I Em_pc
+is a compiler that translates Pascal programs into EM code.
+The input is taken from
+.IR source ,
+while the EM code is written on 
+.IR destination .
+.br
+.I Option
+is a, possibly empty, sequence of the following combinations:
+.IP \fB\-M\fP\fIn\fP
+set maximum identifier length to \fIn\fP.
+The minimum value for \fIn\fR is 9, because the keyword
+"PROCEDURE" is that long.
+.IP \fB\-n\fR
+do not generate EM register messages.
+The user-declared variables will not be stored into registers on the target
+machine.
+.IP \fB\-L\fR
+do not generate the EM \fBfil\fR and \fBlin\fR instructions that enable
+an interpreter to keep track of the current location in the source code.
+.IP \fB\-V\fIcm\fR.\fIn\fR,\ \fB\-V\fIcm\fR.\fIncm\fR.\fIn\fR\ ...
+.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).
+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)
+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 \fB\-C\fR
+The lower case and upper case letters are treated different.
+.IP \fB\-r\fR
+The rangechecks are generated where necessary.
+.LP
+.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.

lang/pc/comp/enter.c

@@ -0,0 +1,227 @@
+/* H I G H   L E V E L   S Y M B O L   E N T R Y */
+
+#include	<alloc.h>
+#include	<assert.h>
+#include	<em_arith.h>
+#include	<em_label.h>
+
+#include	"LLlex.h"
+#include	"def.h"
+#include	"idf.h"
+#include	"main.h"
+#include	"node.h"
+#include	"scope.h"
+#include	"type.h"
+
+extern int	proclevel;
+extern int	parlevel;
+
+struct def *
+Enter(name, kind, type, pnam)
+	char *name;
+	register struct type *type;
+{
+	/*	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.
+	*/
+	register struct def *df;
+
+	df = define(str2idf(name, 0), CurrentScope, kind);
+	df->df_type = type;
+	if( pnam ) df->df_value.df_reqname = pnam;
+	return df;
+}
+
+EnterProgList(Idlist)
+	register struct node *Idlist;
+{
+	register struct node *idlist = Idlist;
+	register struct def *df;
+
+	for( ; idlist; idlist = idlist->nd_next )
+		if (	!strcmp(input, idlist->nd_IDF->id_text)
+			||
+			!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
+			 */
+			if( df = define(idlist->nd_IDF, CurrentScope,
+							D_VARIABLE) )	{
+				df->df_type = text_type;
+				df->df_flags |= (D_PROGPAR | D_NOREG);
+				if( !strcmp(input, idlist->nd_IDF->id_text) ) {
+					df->var_name = input;
+					set_inp();	/* %%% */
+				}
+				else {
+					df->var_name = output;
+					set_outp();	/* %%% */
+				}
+			}
+		}
+		else	{
+			if( df = define(idlist->nd_IDF, CurrentScope,
+								D_PARAMETER) ) {
+				df->df_type = error_type;
+				set_prog(df);		/* %%% */
+			}
+		}
+	
+	FreeNode(Idlist);
+}
+
+EnterEnumList(Idlist, type)
+	struct node *Idlist;
+	register struct type *type;
+{
+	/*	Put a list of enumeration literals in the symbol table.
+		They all have type "type". Also assign numbers to them.
+	*/
+	register struct def *df;
+	register struct node *idlist = Idlist;
+
+	type->enm_ncst = 0;
+	for( ; idlist; idlist = idlist->nd_next )
+		if( df = define(idlist->nd_IDF, CurrentScope, D_ENUM) )	{
+			df->df_type = type;
+			df->enm_val = (type->enm_ncst)++;
+		}
+	FreeNode(Idlist);
+}
+
+EnterFieldList(Idlist, type, scope, addr, packed)
+	struct node *Idlist;
+	register struct type *type;
+	struct scope *scope;
+	arith *addr;
+	unsigned short packed;
+{
+	/*	Put a list of fields in the symbol table.
+		They all have type "type", and are put in scope "scope".
+	*/
+	register struct def *df;
+	register struct node *idlist = Idlist;
+
+	for( ; idlist; idlist = idlist->nd_next )
+		if( df = define(idlist->nd_IDF, scope, D_FIELD) )	{
+			df->df_type = type;
+			if( packed )	{
+				df->fld_flags |= F_PACKED;
+				df->fld_off = align(*addr, type->tp_palign);
+				*addr = df->fld_off + type->tp_psize;
+			}
+			else	{
+				df->fld_off = align(*addr, type->tp_align);
+				*addr = df->fld_off + type->tp_size;
+			}
+		}
+	FreeNode(Idlist);
+}
+
+EnterVarList(Idlist, type, local)
+	struct node *Idlist;
+	struct type *type;
+{
+	/*	Enter a list of identifiers representing variables into the
+		name list. "type" represents the type of the variables.
+		"local" is set if the variables are declared local to a
+		procedure.
+	*/
+	register struct def *df;
+	register struct node *idlist = Idlist;
+	register struct scopelist *sc = CurrVis;
+
+	for( ; idlist; idlist = idlist->nd_next )	{
+		if( !(df = define(idlist->nd_IDF, CurrentScope, D_VARIABLE)) )
+			continue;	/* skip this identifier */
+		df->df_type = type;
+		if( local )	{
+			/* subtract size, which is already aligned, of
+			 * variable to the offset, as the variable list
+			 * exists only local to a procedure
+			 */
+			sc->sc_scope->sc_off -= type->tp_size;
+			df->var_off = sc->sc_scope->sc_off;
+		}
+		else	{ /* Global name */
+			df->var_name = df->df_idf->id_text;
+			df->df_flags |= D_NOREG;
+		}
+	}
+	FreeNode(Idlist);
+}
+
+arith
+EnterParamList(fpl, parlist)
+	register struct node *fpl;
+	struct paramlist **parlist;
+{
+	register arith nb_pars = (proclevel > 1) ? pointer_size : 0;
+	register struct node *id;
+	struct type *tp;
+	struct def *df;
+
+	for( ; fpl; fpl = fpl->nd_right )	{
+		assert(fpl->nd_class == Link);
+
+		tp = fpl->nd_type;
+		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) )
+				nb_pars += pointer_size;
+			else
+				nb_pars += tp->tp_size;
+			LinkParam(parlist, df);
+			df->df_type = tp;
+			df->df_flags |= fpl->nd_INT;
+		    }
+
+		while( IsConformantArray(tp) )	{
+			/* we need room for the descriptors */
+
+			tp->arr_sclevel = CurrentScope->sc_level;
+			tp->arr_cfdescr = nb_pars;
+			nb_pars += 3 * word_size;
+			tp = tp->arr_elem;
+    		}
+	}
+	return nb_pars;
+}
+
+EnterParTypes(fpl, parlist)
+	register struct node *fpl;
+	struct paramlist **parlist;
+{
+	/* Parameters in heading of procedural and functional
+	   parameters (only types are important, not the names).
+	*/
+	register struct node *id;
+	struct def *df;
+
+	for( ; fpl; fpl = fpl->nd_right )
+		for( id = fpl->nd_left; id; id = id->nd_next )
+			if( df = new_def() )	{
+				LinkParam(parlist, df);
+				df->df_type = fpl->nd_type;
+				df->df_flags |= fpl->nd_INT;
+			}
+}
+
+LinkParam(parlist, df)
+	struct paramlist **parlist;
+	struct def *df;
+{
+	static struct paramlist *pr;
+
+	if( !*parlist )
+		*parlist = pr = new_paramlist();
+	else	{
+		pr->next = new_paramlist();
+		pr = pr->next;
+	}
+	pr->par_def = df;
+}

lang/pc/comp/error.c

@@ -0,0 +1,214 @@
+/* E R R O R   A N D   D I A G N O S T I C   R O U T I N E S */
+
+/*	This file contains the (non-portable) error-message and diagnostic
+	giving functions.  Be aware that they are called with a variable
+	number of arguments!
+*/
+
+#include	"debug.h"
+#include	"errout.h"
+
+#include	<em_arith.h>
+#include	<em_code.h>
+#include	<em_label.h>
+#include	<system.h>
+
+#include	"LLlex.h"
+#include	"f_info.h"
+#include	"input.h"
+#include	"main.h"
+#include	"node.h"
+
+/* error classes */
+#define	ERROR		1
+#define	WARNING		2
+#define	LEXERROR	3
+#define	LEXWARNING	4
+#define	CRASH		5
+#define	FATAL		6
+#ifdef DEBUG
+#define VDEBUG		7
+#endif
+
+int err_occurred;
+
+extern char *symbol2str();
+
+/*	There are three general error-message functions:
+		lexerror()	lexical and pre-processor error messages
+		error()		syntactic and pre-processor messagese
+		node_error()	errors in nodes
+	The difference lies in the place where the file name and line
+	number come from.
+	Lexical errors report from the global variables LineNumber and
+	FileName, node errors get their information from the
+	node, whereas other errors use the information in the token.
+*/
+
+#ifdef DEBUG
+/*VARARGS1*/
+debug(fmt, args)
+	char *fmt;
+{
+	_error(VDEBUG, NULLNODE, fmt, &args);
+}
+#endif DEBUG
+
+/*VARARGS1*/
+error(fmt, args)
+	char *fmt;
+{
+	_error(ERROR, NULLNODE, fmt, &args);
+}
+
+/*VARARGS2*/
+node_error(node, fmt, args)
+	struct node *node;
+	char *fmt;
+{
+	_error(ERROR, node, fmt, &args);
+}
+
+/*VARARGS1*/
+warning(fmt, args)
+	char *fmt;
+{
+	if( !options['w'] ) _error(WARNING, NULLNODE, fmt, &args);
+}
+
+/*VARARGS2*/
+node_warning(node, fmt, args)
+	struct node *node;
+	char *fmt;
+{
+	if( !options['w'] ) _error(WARNING, node, fmt, &args);
+}
+
+/*VARARGS1*/
+lexerror(fmt, args)
+	char *fmt;
+{
+	_error(LEXERROR, NULLNODE, fmt, &args);
+}
+
+/*VARARGS1*/
+lexwarning(fmt, args) 
+	char *fmt;
+{
+	if( !options['w'] ) _error(LEXWARNING, NULLNODE, fmt, &args);
+}
+
+/*VARARGS1*/
+fatal(fmt, args)
+	char *fmt;
+{
+	_error(FATAL, NULLNODE, fmt, &args);
+	sys_stop(S_EXIT);
+}
+
+/*VARARGS1*/
+crash(fmt, args)
+	char *fmt;
+{
+	_error(CRASH, NULLNODE, fmt, &args);
+#ifdef DEBUG
+	sys_stop(S_ABORT);
+#else
+	sys_stop(S_EXIT);
+#endif
+}
+
+_error(class, node, fmt, argv)
+	int class;
+	struct node *node;
+	char *fmt;
+	int argv[];
+{
+	/*	_error attempts to limit the number of error messages
+		for a given line to MAXERR_LINE.
+	*/
+	static unsigned int last_ln = 0;
+	unsigned int ln = 0;
+	static char * last_fn = 0;
+	static int e_seen = 0;
+	register char *remark = 0;
+
+	/*	Since name and number are gathered from different places
+		depending on the class, we first collect the relevant
+		values and then decide what to print.
+	*/
+	/* preliminaries */
+	switch( class )	{
+		case ERROR:
+		case LEXERROR:
+		case CRASH:
+		case FATAL:
+			if( C_busy() ) C_ms_err();
+			err_occurred = 1;
+			break;
+	}
+
+	/* the remark */
+	switch( class )	{
+		case WARNING:
+		case LEXWARNING:
+			remark = "(warning)";
+			break;
+		case CRASH:
+			remark = "CRASH\007";
+			break;
+		case FATAL:
+			remark = "fatal error --";
+			break;
+#ifdef DEBUG
+		case VDEBUG:
+			remark = "(debug)";
+			break;
+#endif DEBUG
+	}
+
+	/* the place */
+	switch( class )	{
+		case ERROR:
+		case WARNING:
+			ln = node ? node->nd_lineno : dot.tk_lineno;
+			break;
+		case LEXWARNING:
+		case LEXERROR:
+		case CRASH:
+		case FATAL:
+#ifdef DEBUG
+		case VDEBUG:
+#endif DEBUG
+			ln = LineNumber;
+			break;
+	}
+
+#ifdef DEBUG
+	if( class != VDEBUG )	{
+#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;
+	}
+	else	{
+		/* brand new place */
+		last_ln = ln;
+		last_fn = FileName;
+		e_seen = 0;
+	}
+#ifdef DEBUG
+	}
+#endif DEBUG
+
+	if( FileName ) fprint(ERROUT, "\"%s\", line %u: ", FileName, ln);
+
+	if( remark ) fprint(ERROUT, "%s ", remark);
+
+	doprnt(ERROUT, fmt, argv);		/* contents of error */
+	fprint(ERROUT, "\n");
+}

lang/pc/comp/expression.g

@@ -0,0 +1,290 @@
+/* EXPRESSIONS */
+
+{
+#include	"debug.h"
+
+#include	<assert.h>
+#include	<em_arith.h>
+#include	<em_label.h>
+
+#include	"LLlex.h"
+#include	"chk_expr.h"
+#include	"def.h"
+#include	"main.h"
+#include	"node.h"
+#include	"scope.h"
+#include	"type.h"
+}
+
+Constant(register struct node **pnd;)
+{
+	register struct node **nd = pnd;
+} :
+%default
+	[
+		Sign(nd)	{ nd = &((*nd)->nd_right); }
+	]?
+	[ %default
+		UnsignedNumber(nd)
+	|
+		ConstantIdentifier(nd)
+	]
+				{ (void) ChkConstant(*pnd); }
+|
+	STRING			{ *pnd = MkLeaf(Value, &dot);
+				  if( ((*pnd)->nd_type = toktype) != char_type )
+					RomString(*pnd);
+				}
+;
+
+Sign(register struct node **pnd;):
+	['+' | '-']		{ *pnd = MkLeaf(Uoper, &dot); }
+;
+
+UnsignedNumber(register struct node **pnd;):
+	[INTEGER | REAL]	{ *pnd = MkLeaf(Value, &dot);
+				  if( ((*pnd)->nd_type = toktype) == real_type )
+					RomReal(*pnd);
+				}
+;
+
+ConstantIdentifier(register struct node **pnd;):
+	IDENT			{ *pnd = MkLeaf(Name, &dot); }
+;
+
+/* ISO section 6.7.1, p. 121 */
+Expression(register struct node **pnd;):
+	SimpleExpression(pnd)
+	[
+		/* RelationalOperator substituted inline */
+		[ '=' | NOTEQUAL | '<' | '>' | LESSEQUAL | GREATEREQUAL | IN ]
+				{ *pnd = MkNode(Boper, *pnd, NULLNODE, &dot); }
+		SimpleExpression(&((*pnd)->nd_right))
+	]?
+;
+
+SimpleExpression(register struct node **pnd;):
+	/* ISO 6.7.1: The signs and the adding-operators have equal precedence,
+		      and are left-associative.
+	*/
+	[
+		Sign(pnd)
+		Term(&((*pnd)->nd_right))
+	|
+		Term(pnd)
+	]
+	[
+		/* AddingOperator substituted inline */
+		[ '+' | '-' | OR ]
+				{ *pnd = MkNode(Boper, *pnd, NULLNODE, &dot); }
+		Term(&((*pnd)->nd_right))
+	]*
+;
+
+Term(register struct node **pnd;):
+	Factor(pnd)
+	[
+		/* MultiplyingOperator substituted inline */
+		[ '*' | '/' | DIV | MOD | AND ]
+				{ *pnd = MkNode(Boper, *pnd, NULLNODE, &dot); }
+		Factor(&((*pnd)->nd_right))
+	]*
+;
+
+Factor(register struct node **pnd;)
+{
+	register struct def *df;
+} :
+	/* This is a changed rule, because the grammar as specified in the
+	 * reference is not LL(1), and this gives conflicts.
+	 */
+	%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); }
+		ActualParameterList(&((*pnd)->nd_right))
+	|
+		/* IDENT can be a BoundIdentifier or a ConstantIdentifier or
+		 * a FunctionIdentifier (no parameterlist), in which case
+		 * VariableAccessTail is empty.
+		 * It could also be the beginning of a normal VariableAccess
+		 * (most likely).
+		 */
+			{ int class;
+
+			  df = lookfor(*pnd, CurrVis, 1);
+			  if( df->df_type->tp_fund & T_ROUTINE )	{
+				/* This part is context-sensitive:
+				   is the occurence of the proc/func name
+				   a call or not ?
+				*/
+				if( df->df_type == std_type )
+					class = Call;
+				else
+					class = NameOrCall;
+				*pnd = MkNode(class, *pnd, NULLNODE, &dot);
+				(*pnd)->nd_symb = '(';
+			  }
+			}
+
+		VariableAccessTail(pnd)
+	]
+|
+	UnsignedConstant(pnd)
+|
+	SetConstructor(pnd)
+|
+	'('			{ /* dummy node to force ChkVariable */
+				  *pnd = MkLeaf(Uoper, &dot);
+				}
+	Expression(&((*pnd)->nd_right))
+	')'
+|
+	NOT			{ *pnd = MkLeaf(Uoper, &dot); }
+	Factor(&((*pnd)->nd_right))
+;
+
+UnsignedConstant(register struct node **pnd;):
+	UnsignedNumber(pnd)
+|
+	STRING			{ *pnd = MkLeaf(Value, &dot);
+				  if( ((*pnd)->nd_type = toktype) != char_type )
+					RomString(*pnd);
+				}
+|
+	ConstantIdentifier(pnd)
+|
+	NIL			{ *pnd = MkLeaf(Value, &dot);
+				  (*pnd)->nd_type = nil_type;
+				  /* to evaluate NIL = NIL */
+				  (*pnd)->nd_INT = 0;
+				}
+;
+
+SetConstructor(register struct node **pnd;)
+{
+	register struct node *nd;
+} :
+	'['		{ dot.tk_symb = SET;
+			  *pnd = nd = MkLeaf(Xset, &dot);
+			}
+		[
+			MemberDesignator(nd)
+			[ %persistent
+				{ nd = nd->nd_right; }
+				',' MemberDesignator(nd)
+			]*
+		]?
+	']'
+;
+
+MemberDesignator(register struct node *nd;)
+{
+	struct node *nd1;
+} :
+	Expression(&nd1)
+	[ UPTO			{ nd1 = MkNode(Link, nd1, NULLNODE, &dot); }
+	  Expression(&(nd1->nd_right))
+	]?
+			{ nd->nd_right = MkNode(Link, nd1, NULLNODE, &dot);
+			  nd->nd_right->nd_symb = ',';
+			}
+;
+
+/* ISO section 6.7.2.1, p. 123 */
+BooleanExpression(register struct node **pnd;):
+	Expression(pnd)
+			{ if( ChkExpression(*pnd) &&
+						(*pnd)->nd_type != bool_type )
+				node_error(*pnd, "boolean expression expected");
+			}
+;
+
+ActualParameterList(register struct node **pnd;)
+{
+	register struct node *nd;
+} :
+	'('
+		/* ActualParameter substituted inline */
+		Expression(pnd)		{ *pnd = nd =
+					     MkNode(Link, *pnd, NULLNODE, &dot);
+					  nd->nd_symb = ',';
+					}
+		[ %persistent
+			','		{ nd->nd_right = MkLeaf(Link, &dot);
+					  nd = nd->nd_right;
+					}
+			Expression(&(nd->nd_left))
+		]*
+	')'
+;
+
+/* ISO section 6.5.1, p. 105 */
+VariableAccess(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.
+	 *
+	 * IDENT is an EntireVariable or
+	 * a FieldDesignatorIdentifier (see also 6.8.3.10, p. 132).
+	 */
+	IDENT				{ *pnd = MkLeaf(Name, &dot); }
+	VariableAccessTail(pnd)		{ (void) ChkVariable(*pnd); }
+;
+
+VariableAccessTail(register struct node **pnd;):
+	/* This is a new rule because the grammar specified by the standard
+	 * is not exactly LL(1).
+	 */
+
+	 /* empty */
+|
+	/* PointerVariable or FileVariable
+	 */
+
+	'^'			{ *pnd = MkNode(Arrow, NULLNODE, *pnd, &dot); }
+
+	/* At this point the VariableAccess is an IdentifiedVariable
+	 * ISO section 6.5.4, p. 107 (IdentifiedVariable: PointerVariable '^'),
+	 * or
+	 * it is a BufferVariable
+	 * ISO section 6.5.5, p. 107 (BufferVariable: FileVariable '^').
+	 */
+
+	VariableAccessTail(pnd)
+|
+	/* ArrayVariable
+	 */
+
+	'['			{ *pnd = MkNode(Arrsel, *pnd, NULLNODE, &dot); }
+		/* IndexExpression substituted inline */
+		Expression(&((*pnd)->nd_right))
+		[ %persistent
+			','	{ *pnd = MkNode(Arrsel, *pnd, NULLNODE, &dot);
+				  (*pnd)->nd_symb = '[';
+				}
+			Expression(&((*pnd)->nd_right))
+		]*
+	']'
+
+	/* At this point the VariableAccess is an IndexedVariable
+	 * ISO section 6.5.3.2, p. 106
+	 */
+
+	VariableAccessTail(pnd)
+|
+	/* RecordVariable
+	 */
+
+	'.'			{ *pnd = MkNode(Link, *pnd, NULLNODE, &dot); }
+	/* FieldSpecifier & FieldIdentifier substituted inline */
+	IDENT			{ (*pnd)->nd_IDF = dot.TOK_IDF; }
+
+	/* At this point the VariableAccess is a FieldDesignator
+	 * ISO section 6.5.3.3, p. 107
+	 */
+
+	VariableAccessTail(pnd)
+;

lang/pc/comp/f_info.h

@@ -0,0 +1,11 @@
+/* F I L E   D E S C R I P T O R   S T R U C T U R E */
+
+struct f_info {
+	unsigned short f_lineno;
+	char *f_filename;
+	char *f_workingdir;
+};
+
+extern struct f_info file_info;
+#define LineNumber file_info.f_lineno
+#define FileName file_info.f_filename

lang/pc/comp/idf.c

@@ -0,0 +1,4 @@
+/* I N S T A N T I A T I O N   O F   I D F   P A C K A G E */
+
+#include	"idf.h"
+#include	<idf_pkg.body>

lang/pc/comp/idf.h

@@ -0,0 +1,12 @@
+/* U S E R   D E C L A R E D   P A R T   O F   I D F */
+
+struct id_u {
+	int id_res;
+	struct def *id_df;
+};
+
+#define IDF_TYPE	struct id_u
+#define id_reserved	id_user.id_res
+#define id_def		id_user.id_df
+
+#include	<idf_pkg.spec>

lang/pc/comp/input.c

@@ -0,0 +1,17 @@
+/* I N S T A N T I A T I O N   O F   I N P U T   P A C K A G E */
+
+#include	"f_info.h"
+struct f_info	file_info;
+#include	"input.h"
+#include	<em_arith.h>
+#include	"idf.h"
+#include	<inp_pkg.body>
+
+
+AtEoIF()
+{
+	/*	Make the unstacking of input streams noticable to the
+	   	lexical analyzer
+	*/
+	return 1;
+}

lang/pc/comp/input.h

@@ -0,0 +1,9 @@
+/* I N S T A N T I A T I O N   O F   I N P U T   M O D U L E */
+
+#include	"inputtype.h"
+
+#define INP_NPUSHBACK 3
+#define INP_TYPE	struct f_info
+#define INP_VAR		file_info
+
+#include <inp_pkg.spec>

lang/pc/comp/label.c

@@ -0,0 +1,165 @@
+/*	L A B E L   H A N D L I N G	*/
+
+#include	<alloc.h>
+#include	<em.h>
+
+#include	"LLlex.h"
+#include	"def.h"
+#include	"idf.h"
+#include	"main.h"
+#include	"node.h"
+#include	"scope.h"
+#include	"type.h"
+
+
+DeclLabel(nd)
+	struct node *nd;
+{
+	struct def *df;
+
+	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;
+	}
+}
+
+chk_labels(Slevel)
+{
+	register struct node *labnd = BlockScope->sc_lablist;
+	register struct def *df;
+
+	while( labnd )	{
+		df = labnd->nd_def;
+		if( Slevel == 1 )	{
+			if( !df->lab_level )
+				if( df->lab_next )
+				/* jump to undefined label */
+					error("jump to undefined label %s",
+							df->df_idf->id_text);
+				else
+					warning(
+					  "label %s declared but never defined",
+							df->df_idf->id_text);
+		}
+		else if( df->lab_level == Slevel )
+			df->lab_level = -1;
+		else if( !df->lab_level )	{
+			struct lab *plab = df->lab_next;
+
+			while( plab )	{
+				if( plab->lb_level > 1 )
+					plab->lb_level--;
+				plab = plab->lb_next;
+			}
+		}
+		labnd = labnd->nd_next;
+	}
+}
+
+TstLabel(nd, Slevel)
+	register struct node *nd;
+{
+	register struct def *df;
+
+	df = lookfor(nd, CurrVis, 0);
+	if( df->df_kind == D_ERROR )	{
+		node_error(nd, "label %s not declared", df->df_idf->id_text);
+		df->df_kind = D_LABEL;
+		nd->nd_def = df;
+		nd->nd_next = BlockScope->sc_lablist;
+		BlockScope->sc_lablist = nd;
+	}
+	else
+		FreeNode(nd);
+
+	if( !df->lab_level )	{
+		/* forward jump */
+		register struct lab *labelptr;
+
+		labelptr = new_lab();
+		labelptr->lb_next = df->lab_next;
+		df->lab_next = labelptr;
+		if( df->df_scope == BlockScope )	{
+			/* local jump */
+			labelptr->lb_level = Slevel;
+			CodeLabel(df, 1);
+		}
+		else	{
+			/* non-local jump, only permitted to
+			   outermost level (ISO 6.8.1 Note 2)
+			*/
+			labelptr->lb_level = 1;
+			CodeLabel(df, 0);
+		}
+	}
+	else if( df->lab_level == -1 || df->lab_level > Slevel )
+		node_error(nd, "illegal jump to label %s", df->df_idf->id_text);
+	else
+		CodeLabel(df, 1);
+}
+
+DefLabel(nd, Slevel)
+	register struct node *nd;
+{
+	register struct def *df;
+
+	if( !(df = lookup(nd->nd_IDF, BlockScope)) )	{
+		node_error(nd, "label %s must be declared in same block"
+							, nd->nd_IDF->id_text);
+		df = define(nd->nd_IDF, BlockScope, D_LABEL);
+		nd->nd_def = df;
+		df->lab_no = ++text_label;
+		nd->nd_next = BlockScope->sc_lablist;
+		BlockScope->sc_lablist = nd;
+	}
+	else FreeNode(nd);
+
+	if( df->lab_level)
+		node_error(nd, "label %s already defined", nd->nd_IDF->id_text);
+	else	{
+		register struct lab *labelptr;
+
+		df->lab_level = Slevel;
+		labelptr = df->lab_next;
+		while( labelptr )	{
+			if( labelptr->lb_level < Slevel )	{
+				node_error(nd, "illegal jump to label %s",
+							nd->nd_IDF->id_text);
+				return;
+			}
+			labelptr = labelptr->lb_next;
+		}
+		C_df_ilb(df->lab_no);
+	}
+}
+
+CodeLabel(df, local)
+	register struct def *df;
+{
+	if( err_occurred ) return;
+
+	if( local )
+		C_bra(df->lab_no);
+	else	{
+		/* non-local jump */
+		int level = df->df_scope->sc_level;
+
+		if( !df->lab_descr )	{
+			/* generate label for goto descriptor */
+			df->lab_descr = ++data_label;
+			C_ina_dlb(data_label);
+		}
+		/* perform the jump */
+		C_lae_dlb(df->lab_descr, (arith) 0);
+
+		/* LB of target procedure */
+		if( level > 0 )
+			C_lxl((arith) proclevel - level);
+		else
+			C_zer(pointer_size);
+		C_cal("_gto");
+		C_asp( 2 * pointer_size);
+	}
+}

lang/pc/comp/lookup.c

@@ -0,0 +1,65 @@
+/* L O O K U P   R O U T I N E S */
+
+#include	<em_arith.h>
+#include	<em_label.h>
+
+#include	"LLlex.h"
+#include	"def.h"
+#include	"idf.h"
+#include	"misc.h"
+#include	"node.h"
+#include	"scope.h"
+#include	"type.h"
+
+struct def *
+lookup(id, scope)
+	register struct idf *id;
+	struct scope *scope;
+{
+	/*	Look up a definition of an identifier in scope "scope".
+		Make the "def" list self-organizing.
+		Return a pointer to its "def" structure if it exists,
+		otherwise return 0.
+	*/
+	register struct def *df, *df1;
+
+	/* Look in the chain of definitions of this "id" for one with scope
+	   "scope".
+	*/
+	for( df = id->id_def, df1 = 0;
+	     df && df->df_scope != scope;
+	     df1 = df, df = df->df_next ) { /* nothing */ }
+
+	if( df && df1 )	{
+		/* Put the definition in front
+		*/
+		df1->df_next = df->df_next;
+		df->df_next = id->id_def;
+		id->id_def = df;
+	}
+	return df;
+}
+
+struct def *
+lookfor(id, vis, give_error)
+	register struct node *id;
+	struct scopelist *vis;
+{
+	/*	Look for an identifier in the visibility range started by "vis".
+		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 scopelist *sc = vis;
+
+	while( sc )	{
+		df = lookup(id->nd_IDF, sc->sc_scope);
+		if( df ) return df;
+		sc = nextvisible(sc);
+	}
+
+	if( give_error ) id_not_declared(id);
+
+	df = MkDef(id->nd_IDF, vis->sc_scope, D_ERROR);
+	return df;
+}

lang/pc/comp/main.c

@@ -0,0 +1,224 @@
+/* M A I N   P R O G R A M */
+
+#include	"debug.h"
+
+#include	<em.h>
+#include	<em_mes.h>
+#include	<system.h>
+
+#include	"LLlex.h"
+#include	"Lpars.h"
+#include	"const.h"
+#include	"def.h"
+#include	"f_info.h"
+#include	"idf.h"
+#include	"input.h"
+#include	"main.h"
+#include	"node.h"
+#include	"required.h"
+#include	"tokenname.h"
+#include	"type.h"
+
+char		options[128];
+char		*ProgName;
+char		*input = "input";
+char		*output = "output";
+
+label		data_label;
+label		text_label;
+
+struct def	*program;
+extern int	fp_used;	/* set if floating point used */
+
+
+main(argc, argv)
+	register char **argv;
+{
+	register int Nargc = 1;
+	register char **Nargv = &argv[0];
+
+	ProgName = *argv++;
+
+	while( --argc > 0 )	{
+		if( **argv == '-' )
+			DoOption((*argv++) + 1);
+		else
+			Nargv[Nargc++] = *argv++;
+	}
+	Nargv[Nargc] = 0;	/* terminate the arg vector	*/
+	if( Nargc < 2 )	{
+		fprint(STDERR, "%s: Use a file argument\n", ProgName);
+		exit(1);
+	}
+	exit(!Compile(Nargv[1], Nargv[2]));
+}
+
+Compile(src, dst)
+	char *src, *dst;
+{
+	extern struct tokenname tkidf[];
+	extern struct tokenname tkstandard[];
+
+	if( !InsertFile(src, (char **) 0, &src) )	{
+		fprint(STDERR, "%s: cannot open %s\n", ProgName, src);
+		return 0;
+	}
+	LineNumber = 1;
+	FileName = src;
+	init_idf();
+	InitCst();
+	reserve(tkidf);
+	reserve(tkstandard);
+	InitScope();
+	InitTypes();
+	AddRequired();
+#ifdef DEBUG
+	if( options['l'] )	{
+		LexScan();
+		return 1;
+	}
+#endif DEBUG
+	C_init(word_size, pointer_size);
+	if( !C_open(dst) )
+		fatal("couldn't open output file");
+	C_magic();
+	C_ms_emx(word_size, pointer_size);
+	C_df_dlb(++data_label);
+	C_rom_scon(FileName, strlen(FileName) + 1);
+	LLparse();
+	C_ms_src((arith) (LineNumber - 1), FileName);
+	if( fp_used ) C_ms_flt();
+	C_close();
+#ifdef DEBUG
+	if( options['I'] ) Info();
+#endif DEBUG
+	return !err_occurred;
+}
+
+#ifdef DEBUG
+LexScan()
+{
+	register struct token *tkp = &dot;
+	extern char *symbol2str();
+
+	while( LLlex() > 0 )	{
+		print(">>> %s ", symbol2str(tkp->tk_symb));
+		switch( tkp->tk_symb )	{
+			case IDENT:
+				print("%s\n", tkp->TOK_IDF->id_text);
+				break;
+
+			case INTEGER:
+				print("%ld\n", tkp->TOK_INT);
+				break;
+
+			case REAL:
+				print("%s\n", tkp->TOK_REL);
+				break;
+
+			case STRING:
+				print("'%s'\n", tkp->TOK_STR);
+				break;
+
+			default:
+				print("\n");
+		}
+	}
+}
+#endif
+
+AddRequired()
+{
+	register struct def *df;
+	extern struct def *Enter();
+	static struct node maxintnode = { 0, 0, Value, 0, { INTEGER, 0 } };
+
+	/* PROCEDURES */
+
+	/* File handling procedures, Read(ln) & Write(ln) are handled
+	 * in the grammar
+	 */
+
+	(void) Enter("rewrite", D_PROCEDURE, std_type, R_REWRITE);
+	(void) Enter("put", D_PROCEDURE, std_type, R_PUT);
+	(void) Enter("reset", D_PROCEDURE, std_type, R_RESET);
+	(void) Enter("get", D_PROCEDURE, std_type, R_GET);
+	(void) Enter("page", D_PROCEDURE, std_type, R_PAGE);
+
+	/* DYNAMIC ALLOCATION PROCEDURES */
+	(void) Enter("new", D_PROCEDURE, std_type, R_NEW);
+	(void) Enter("dispose", D_PROCEDURE, std_type, R_DISPOSE);
+
+	/* TRANSFER PROCEDURES */
+	(void) Enter("pack", D_PROCEDURE, std_type, R_PACK);
+	(void) Enter("unpack", D_PROCEDURE, std_type, R_UNPACK);
+
+	/* FUNCTIONS */
+
+	/* ARITHMETIC FUNCTIONS */
+	(void) Enter("abs", D_FUNCTION, std_type, R_ABS);
+	(void) Enter("sqr", D_FUNCTION, std_type, R_SQR);
+	(void) Enter("sin", D_FUNCTION, std_type, R_SIN);
+	(void) Enter("cos", D_FUNCTION, std_type, R_COS);
+	(void) Enter("exp", D_FUNCTION, std_type, R_EXP);
+	(void) Enter("ln", D_FUNCTION, std_type, R_LN);
+	(void) Enter("sqrt", D_FUNCTION, std_type, R_SQRT);
+	(void) Enter("arctan", D_FUNCTION, std_type, R_ARCTAN);
+
+	/* TRANSFER FUNCTIONS */
+	(void) Enter("trunc", D_FUNCTION, std_type, R_TRUNC);
+	(void) Enter("round", D_FUNCTION, std_type, R_ROUND);
+
+	/* ORDINAL FUNCTIONS */
+	(void) Enter("ord", D_FUNCTION, std_type, R_ORD);
+	(void) Enter("chr", D_FUNCTION, std_type, R_CHR);
+	(void) Enter("succ", D_FUNCTION, std_type, R_SUCC);
+	(void) Enter("pred", D_FUNCTION, std_type, R_PRED);
+
+	/* BOOLEAN FUNCTIONS */
+	(void) Enter("odd", D_FUNCTION, std_type, R_ODD);
+	(void) Enter("eof", D_FUNCTION, std_type, R_EOF);
+	(void) Enter("eoln", D_FUNCTION, std_type, R_EOLN);
+
+	/* TYPES */
+	(void) Enter("char", D_TYPE, char_type, 0);
+	(void) Enter("integer", D_TYPE, int_type, 0);
+	(void) Enter("real", D_TYPE, real_type, 0);
+	(void) Enter("boolean", D_TYPE, bool_type, 0);
+	(void) Enter("text", D_TYPE, text_type, 0);
+
+	/* DIRECTIVES */
+	(void) Enter("forward", D_FORWARD, NULLTYPE, 0);
+	(void) Enter("extern", D_EXTERN, NULLTYPE, 0);
+
+	/* CONSTANTS */
+	/* nil is TOKEN and thus part of the grammar */
+
+	df = Enter("maxint", D_CONST, int_type, 0);
+	df->con_const = &maxintnode;
+	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->enm_next = Enter("false", D_ENUM, bool_type, 0);
+	df = df->enm_next;
+	df->enm_val = 0;
+	df->enm_next = NULLDEF;
+}
+
+#ifdef DEBUG
+	int cntlines;
+
+Info()
+{
+	extern int cnt_def, cnt_node, cnt_paramlist, cnt_type, cnt_scope,
+			cnt_scopelist, cnt_tmpvar, cnt_withdesig,
+			cnt_case_hdr, cnt_case_entry;
+
+	print("\
+%6d def\n%6d node\n%6d paramlist\n%6d type\n%6d scope\n%6d scopelist\n\
+%6d lab\n%6d tmpvar\n%6d withdesig\n%6d casehdr\n%6d caseentry\n",
+cnt_def, cnt_node, cnt_paramlist, cnt_type, cnt_scope, cnt_scopelist, cnt_lab, cnt_tmpvar, cnt_withdesig, cnt_case_hdr, cnt_case_entry);
+print("\nNumber of lines read: %d\n", cntlines);
+}
+#endif

lang/pc/comp/main.h

@@ -0,0 +1,13 @@
+/* S O M E   G L O B A L   V A R I A B L E S */
+
+extern char options[];		/* indicating which options were given */
+extern char *input;		/* name of required filevariable */
+extern char *output;		/* name of required filevariable */
+
+extern struct def *program;	/* definition of the program compiled */
+
+extern int proclevel;		/* nesting level of procedures */
+extern int err_occurred;
+
+extern label data_label;
+extern label text_label;

lang/pc/comp/make.allocd

@@ -0,0 +1,26 @@
+sed -e '
+s:^.*[ 	]ALLOCDEF[ 	].*"\(.*\)"[ 	]*\([0-9][0-9]*\).*$:\
+/* allocation definitions of struct \1 */\
+extern char *st_alloc();\
+extern struct \1 *h_\1;\
+#ifdef DEBUG\
+extern int cnt_\1;\
+extern char *std_alloc();\
+#define	new_\1() ((struct \1 *) std_alloc((char **)\&h_\1, sizeof(struct \1), \2, \&cnt_\1))\
+#else\
+#define	new_\1() ((struct \1 *) st_alloc((char **)\&h_\1, sizeof(struct \1), \2))\
+#endif\
+#define	free_\1(p) st_free(p, \&h_\1, sizeof(struct \1))\
+:' -e '
+s:^.*[ 	]STATICALLOCDEF[ 	].*"\(.*\)"[ 	]*\([0-9][0-9]*\).*$:\
+/* allocation definitions of struct \1 */\
+extern char *st_alloc();\
+struct \1 *h_\1;\
+#ifdef DEBUG\
+int cnt_\1;\
+#define	new_\1() ((struct \1 *) std_alloc((char **)\&h_\1, sizeof(struct \1), \2, \&cnt_\1))\
+#else\
+#define	new_\1() ((struct \1 *) st_alloc((char **)\&h_\1, sizeof(struct \1), \2))\
+#endif\
+#define	free_\1(p) st_free(p, \&h_\1, sizeof(struct \1))\
+:'

lang/pc/comp/make.hfiles

@@ -0,0 +1,35 @@
+: Update Files from database
+
+PATH=/bin:/usr/bin
+
+case $# in
+1) ;;
+*)	echo use: $0 file >&2
+	exit 1
+esac
+
+(
+IFCOMMAND="if (<\$FN) 2>/dev/null;\
+	then	if cmp -s \$FN \$TMP;\
+		then	rm \$TMP;\
+		else	mv \$TMP \$FN;\
+			echo update \$FN;\
+		fi;\
+	else	mv \$TMP \$FN;\
+		echo create \$FN;\
+	fi"
+echo 'TMP=.uf$$'
+echo 'FN=$TMP'
+echo 'cat >$TMP <<\!EOF!'
+sed -n '/^!File:/,${
+/^$/d
+/^!File:[	 ]*\(.*\)$/s@@!EOF!\
+'"$IFCOMMAND"'\
+FN=\1\
+cat >$TMP <<\\!EOF!@
+p
+}' $1
+echo '!EOF!'
+echo $IFCOMMAND
+) |
+sh

lang/pc/comp/make.next

@@ -0,0 +1,7 @@
+echo '#include "debug.h"'
+sed -n '
+s:^.*[ 	]ALLOCDEF[ 	].*"\(.*\)".*$:struct \1 *h_\1 = 0;\
+#ifdef DEBUG\
+int cnt_\1 = 0;\
+#endif:p
+' $*

lang/pc/comp/make.tokcase

@@ -0,0 +1,34 @@
+cat <<'--EOT--'
+#include "Lpars.h"
+
+char *
+symbol2str(tok)
+	int tok;
+{
+	static char buf[2] = { '\0', '\0' };
+
+	if (040 <= tok && tok < 0177) {
+		buf[0] = tok;
+		buf[1] = '\0';
+		return buf;
+	}
+	switch (tok) {
+--EOT--
+sed '
+/{[A-Z]/!d
+s/.*{\(.*\),.*\(".*"\).*$/	case \1 :\
+		return \2;/
+'
+cat <<'--EOT--'
+	case '\n':
+	case '\f':
+	case '\v':
+	case '\r':
+	case '\t':
+		buf[0] = tok;
+		return buf;
+	default:
+		return "bad token";
+	}
+}
+--EOT--

lang/pc/comp/make.tokfile

@@ -0,0 +1,6 @@
+sed '
+/{[A-Z]/!d
+s/.*{//
+s/,.*//
+s/.*/%token	&;/
+'

lang/pc/comp/misc.c

@@ -0,0 +1,60 @@
+/* M I S C E L L A N E O U S    R O U T I N E S */
+
+#include	<alloc.h>
+#include	<em.h>
+
+#include	"LLlex.h"
+#include	"f_info.h"
+#include	"idf.h"
+#include	"main.h"
+#include	"misc.h"
+#include	"node.h"
+
+struct idf *
+gen_anon_idf()
+{
+	/*	A new idf is created out of nowhere, to serve as an
+		anonymous name.
+	*/
+	static int name_cnt;
+	char buff[100];
+	char *sprint();
+
+	sprint(buff, "#%d in %s, line %u", ++name_cnt, FileName, LineNumber);
+	return str2idf(buff, 1);
+}
+
+not_declared(what, id, where)
+	char *what, *where;
+	register struct node *id;
+{
+	/*	The identifier "id" is not declared. If it is not generated,
+		give an error message
+	*/
+	if( !is_anon_idf(id->nd_IDF) )	{
+		node_error(id, "%s \"%s\" not declared%s",
+			   		what, id->nd_IDF->id_text, where);
+	}
+}
+
+char *
+gen_proc_name(id, inp)
+	register struct idf *id;
+{
+	/* generate pseudo and internal name for procedure or function */
+
+	static int name_cnt;
+	static char buf[256];
+	char *sprint(), *Salloc();
+
+	if( inp )	{
+		sprint(buf, "_%d%s", ++name_cnt, id->id_text);
+		C_inp(buf);
+		return Salloc(buf, (unsigned) (strlen(buf) + 1));
+	}
+	else	{
+		C_exp(id->id_text);
+		return id->id_text;
+	}
+
+}

lang/pc/comp/misc.h

@@ -0,0 +1,10 @@
+/* M I S C E L L A N E O U S */
+
+#define is_anon_idf(x)		((x)->id_text[0] == '#')
+#define id_not_declared(x)	(not_declared("identifier", (x), ""))
+
+extern struct idf
+	*gen_anon_idf();
+
+extern char 
+	*gen_proc_name();

lang/pc/comp/next.c

@@ -0,0 +1,49 @@
+#include "debug.h"
+struct lab *h_lab = 0;
+#ifdef DEBUG
+int cnt_lab = 0;
+#endif
+struct forwtype *h_forwtype = 0;
+#ifdef DEBUG
+int cnt_forwtype = 0;
+#endif
+struct def *h_def = 0;
+#ifdef DEBUG
+int cnt_def = 0;
+#endif
+struct withdesig *h_withdesig = 0;
+#ifdef DEBUG
+int cnt_withdesig = 0;
+#endif
+struct node *h_node = 0;
+#ifdef DEBUG
+int cnt_node = 0;
+#endif
+struct scope *h_scope = 0;
+#ifdef DEBUG
+int cnt_scope = 0;
+#endif
+struct scopelist *h_scopelist = 0;
+#ifdef DEBUG
+int cnt_scopelist = 0;
+#endif
+struct paramlist *h_paramlist = 0;
+#ifdef DEBUG
+int cnt_paramlist = 0;
+#endif
+struct type *h_type = 0;
+#ifdef DEBUG
+int cnt_type = 0;
+#endif
+struct case_hdr *h_case_hdr = 0;
+#ifdef DEBUG
+int cnt_case_hdr = 0;
+#endif
+struct case_entry *h_case_entry = 0;
+#ifdef DEBUG
+int cnt_case_entry = 0;
+#endif
+struct tmpvar *h_tmpvar = 0;
+#ifdef DEBUG
+int cnt_tmpvar = 0;
+#endif

lang/pc/comp/node.H

@@ -0,0 +1,47 @@
+/* N O D E   O F   A N   A B S T R A C T   P A R S E T R E E */
+
+struct node {
+	struct node *nd_left;
+#define nd_next nd_left
+	struct node *nd_right;
+	int nd_class;		/* kind of node */
+#define Value		0	/* constant */
+#define Name		1	/* an identifier */
+#define Uoper		2	/* unary operator */
+#define Boper		3	/* binary operator */
+#define Xset		4	/* a set */
+#define Set		5	/* a set constant */
+#define Call		6	/* a function call */
+#define NameOrCall	7	/* call or name of function */
+#define Arrow		8	/* ^ construction */
+#define Arrsel		9	/* array selection */
+#define Def		10	/* an identified name */
+#define Link		11
+#define LinkDef		12
+#define Cast		13	/* convert integer to real */
+				/* do NOT change the order or the numbers!!! */
+	struct type *nd_type;	/* type of this node */
+	struct token nd_token;
+#define nd_def		nd_token.tk_data.tk_def
+#define nd_set		nd_token.tk_data.tk_set
+#define nd_lab		nd_token.tk_data.tk_lab
+#define nd_symb		nd_token.tk_symb
+#define nd_lineno	nd_token.tk_lineno
+#define nd_IDF		nd_token.TOK_IDF
+#define nd_STR		nd_token.TOK_STR
+#define nd_SLE		nd_token.TOK_SLE
+#define nd_SLA		nd_token.TOK_SLA
+#define nd_INT		nd_token.TOK_INT
+#define nd_REL		nd_token.TOK_REL
+#define nd_RLA		nd_token.TOK_RLA
+#define nd_RIV		nd_token.TOK_RIV
+#define nd_RSI		nd_token.TOK_RSI
+};
+
+/* ALLOCDEF "node" 50 */
+
+extern struct node *MkNode(), *MkLeaf(), *ChkStdInOut();
+
+#define IsProcCall(lnd)	((lnd)->nd_type->tp_fund & T_ROUTINE)
+
+#define	NULLNODE ((struct node *) 0)

lang/pc/comp/node.c

@@ -0,0 +1,95 @@
+/* N O D E   O F   A N   A B S T R A C T   P A R S E T R E E */
+
+#include	"debug.h"
+
+#include	<alloc.h>
+#include	<em_arith.h>
+#include	<em_label.h>
+#include	<system.h>
+
+#include	"LLlex.h"
+#include	"node.h"
+#include	"type.h"
+
+struct node *
+MkNode(class, left, right, token)
+	struct node *left, *right;
+	struct token *token;
+{
+	/*	Create a node and initialize it with the given parameters
+	*/
+	register struct node *nd = new_node();
+
+	nd->nd_left = left;
+	nd->nd_right = right;
+	nd->nd_token = *token;
+	nd->nd_class = class;
+	nd->nd_type = error_type;
+	return nd;
+}
+
+struct node *
+MkLeaf(class, token)
+	struct token *token;
+{
+	register struct node *nd = new_node();
+
+	nd->nd_left = nd->nd_right = NULLNODE;
+	nd->nd_token = *token;
+	nd->nd_type = error_type;
+	nd->nd_class = class;
+	return nd;
+}
+
+FreeNode(nd)
+	register struct node *nd;
+{
+	/*	Put nodes that are no longer needed back onto the free list
+	*/
+	if( !nd ) return;
+	FreeNode(nd->nd_left);
+	FreeNode(nd->nd_right);
+	free_node(nd);
+}
+
+NodeCrash(expp)
+	struct node *expp;
+{
+	crash("Illegal node %d", expp->nd_class);
+}
+
+#ifdef DEBUG
+
+extern char *symbol2str();
+
+indnt(lvl)
+{
+	while( lvl-- )
+		print("  ");
+}
+
+printnode(nd, lvl)
+	register struct node *nd;
+{
+	indnt(lvl);
+	print("Class: %d; Symbol: %s\n", nd->nd_class, symbol2str(nd->nd_symb));
+	if( nd->nd_type )	{
+		indnt(lvl);
+		print("Type: ");
+		DumpType(nd->nd_type);
+		print("\n");
+	}
+}
+
+PrNode(nd, lvl)
+	register struct node *nd;
+{
+	if( !nd )	{
+		indnt(lvl); print("<nilnode>\n");
+		return;
+	}
+	PrNode(nd->nd_left, lvl + 1);
+	printnode(nd, lvl);
+	PrNode(nd->nd_right, lvl + 1);
+}
+#endif

lang/pc/comp/options.c

@@ -0,0 +1,151 @@
+/* U S E R   O P T I O N - H A N D L I N G */
+
+#include	<em_arith.h>
+#include	<em_label.h>
+
+#include	"class.h"
+#include	"const.h"
+#include	"idfsize.h"
+#include	"main.h"
+#include	"type.h"
+
+#define	MINIDFSIZE	9
+
+#if MINIDFSIZE < 9
+You fouled up! MINIDFSIZE has to be at least 10 or the compiler will not
+recognize some keywords!
+#endif
+
+extern int	idfsize;
+
+DoOption(text)
+	register char *text;
+{
+	switch( *text++ )	{
+
+	default:
+		options[text[-1]]++;	/* flags, debug options etc.	*/
+		break;
+				/* recognized flags:
+					-i: largest value of set of integer
+					-u: allow underscore in identifier
+					-w: no warnings
+				   and many more if DEBUG
+				*/
+
+
+	case 'i':	{		/* largest value of set of integer */
+		char *t = text;
+
+		max_intset = txt2int(&t);
+		text = t;
+		if( max_intset <= (arith) 0 || *t )	{
+			error("bad -i flag : use -i<num>");
+			max_intset = 0;
+		}
+		break;
+	}
+
+	case 'M': {	/* maximum identifier length */
+		char *t = text;
+
+		idfsize = txt2int(&t);
+		text = t;
+		if( idfsize <= 0 || *t )
+			fatal("malformed -M option");
+			/*NOTREACHED*/
+		if( idfsize > IDFSIZE )	{
+			idfsize = IDFSIZE;
+			warning("maximum identifier length is %d", IDFSIZE);
+		}
+		if( idfsize < MINIDFSIZE )	{
+			idfsize = MINIDFSIZE;
+			warning("minimum identifier length is %d", MINIDFSIZE);
+		}
+		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]? ]* */
+
+		register arith size;
+		register int align;
+		char c, *t;
+
+		while( c = *text++ )	{
+			char *strindex();
+
+			t = text;
+			size = txt2int(&t);
+			align = 0;
+			if( *(text = t) == '.' )	{
+				t = text + 1;
+				align = txt2int(&t);
+				text = t;
+			}
+			if( !strindex("wifpS", c) )
+				error("-V: bad type indicator %c\n", c);
+			if( size )
+				switch( c )	{
+				case 'w':	/* word		*/
+					word_size = size;
+					break;
+				case 'i':	/* int		*/
+					int_size = size;
+					break;
+				case 'f':	/* real		*/
+					real_size = size;
+					break;
+				case 'p':	/* pointer	*/
+					pointer_size = size;
+					break;
+				case 'S':	/* structure	*/
+					/* discard size */
+					break;
+				}
+
+			if( align )
+				switch( c )	{
+				case 'w':	/* word		*/
+					word_align = align;
+					break;
+				case 'i':	/* int		*/
+					int_align = align;
+					break;
+				case 'f':	/* real		*/
+					real_align = align;
+					break;
+				case 'p':	/* pointer	*/
+					pointer_align = align;
+					break;
+				case 'S':	/* initial record alignment */
+					struct_align = align;
+					break;
+				}
+		}
+		break;
+	}
+	}
+}
+
+int
+txt2int(tp)
+	register char **tp;
+{
+	/*	the integer pointed to by *tp is read, while increasing
+		*tp; the resulting value is yielded.
+	*/
+	register int val = 0;
+	register int ch;
+	
+	while( ch = **tp, ch >= '0' && ch <= '9' )	{
+		val = val * 10 + ch - '0';
+		(*tp)++;
+	}
+	return val;
+}

lang/pc/comp/program.g

@@ -0,0 +1,49 @@
+/* The grammar of ISO-Pascal as given by the specification, BS6192: 1982. */
+
+{
+#include	<alloc.h>
+#include	<em_arith.h>
+#include	<em_label.h>
+
+#include	"LLlex.h"
+#include	"def.h"
+#include	"main.h"
+#include	"node.h"
+#include	"scope.h"
+}
+
+%lexical LLlex;
+
+%start LLparse, Program;
+
+/* ISO section 6.10, p. 137 */
+Program
+{
+	struct def *df;
+}:
+	ProgramHeading(&df) ';' Block(df) '.'
+;
+
+ProgramHeading(register struct def **df;):
+	PROGRAM IDENT
+			{ program = *df = new_def();
+			  (*df)->df_idf = dot.TOK_IDF;
+			  (*df)->df_kind = D_PROGRAM;
+			  open_scope();
+			  GlobalScope = CurrentScope;
+			  (*df)->prc_vis = CurrVis;
+			}
+	[
+		'('
+		ProgramParameters
+		')'
+	]?
+;
+
+ProgramParameters
+{
+	struct node *Proglist;
+}:
+	IdentifierList(&Proglist)
+				{ EnterProgList(Proglist); }
+;

lang/pc/comp/progs.c

@@ -0,0 +1,71 @@
+/* TYDELYK !!!!!! */
+
+#include	"debug.h"
+
+#include	<assert.h>
+#include	<em.h>
+
+#include	"LLlex.h"
+#include	"def.h"
+#include	"main.h"
+#include	"scope.h"
+#include	"type.h"
+
+arith cnt = 2;			/* standaard input & output */
+int inpflag = 0;		/* std input gedefinieerd of niet */
+int outpflag = 0;		/* std output gedefinieerd of niet */
+label con_label;
+
+set_inp()
+{
+	inpflag = 1;
+}
+
+set_outp()
+{
+	outpflag = 1;
+}
+
+set_prog(df)
+	struct def *df;
+{
+	cnt++;
+	df->df_flags |= 0x40;
+}
+
+make_con()
+{
+	register struct def *df;
+
+	con_label = ++data_label;
+	C_df_dlb(con_label);
+	C_con_cst(cnt);
+
+	if( inpflag )
+		C_con_dnam("input", (arith) 0);
+	else
+		C_con_cst((arith) -1);
+
+	if( outpflag )
+		C_con_dnam("output", (arith) 0);
+	else
+		C_con_cst((arith) -1);
+
+	for( df = GlobalScope->sc_def; df; df = df->df_nextinscope )
+		if( df->df_flags & 0x40 )	{
+			C_con_dnam(df->var_name, (arith) 0);
+			cnt--;
+		}
+
+	assert(cnt == 2);
+}
+
+call_ini()
+{
+	C_lxl((arith) 0);
+	C_lae_dlb(con_label, (arith) 0);
+	C_zer(pointer_size);
+	C_lxa((arith) 0);
+	C_cal("_ini");
+	C_asp(4 * pointer_size);
+}

lang/pc/comp/readwrite.c

@@ -0,0 +1,421 @@
+/* R E A D ( L N )   &   W R I T E ( L N ) */
+
+#include	"debug.h"
+
+#include	<assert.h>
+#include	<em.h>
+
+#include	"LLlex.h"
+#include	"def.h"
+#include	"main.h"
+#include	"node.h"
+#include	"scope.h"
+#include	"type.h"
+
+ChkRead(arg)
+	register struct node *arg;
+{
+	struct node *file;
+	char *name = "read";
+
+	assert(arg);
+	assert(arg->nd_symb == ',');
+
+	if( arg->nd_left->nd_type->tp_fund == T_FILE )	{
+		file = arg->nd_left;
+		arg = arg->nd_right;
+		if( !arg )	{
+			error("\"%s\": variable-access expected", name);
+			return;
+		}
+	}
+	else if( !(file = ChkStdInOut(name, 0)) )
+		return;
+
+	while( arg )	{
+		assert(arg->nd_symb == ',');
+
+		if( file->nd_type != text_type )	{
+					/* real var & file of integer */
+			if( !TstAssCompat(arg->nd_left->nd_type,
+					BaseType(file->nd_type->next)) ) {
+				node_error(arg->nd_left,
+					"\"%s\": illegal parameter type",name);
+				return;
+			}
+		}
+		else if( !(BaseType(arg->nd_left->nd_type)->tp_fund &
+					( T_CHAR | T_NUMERIC )) )	{
+			node_error(arg->nd_left,
+					"\"%s\": illegal parameter type",name);
+			return;
+		}
+		CodeRead(file, arg->nd_left);
+		arg = arg->nd_right;
+	}
+}
+
+ChkReadln(arg)
+	register struct node *arg;
+{
+	struct node *file;
+	char *name = "readln";
+
+	if( !arg )	{
+		if( !(file = ChkStdInOut(name, 0)) )
+			return;
+		else	{
+			CodeReadln(file);
+			return;
+		}
+	}
+
+	assert(arg->nd_symb == ',');
+
+	if( arg->nd_left->nd_type->tp_fund == T_FILE )	{
+		if( arg->nd_left->nd_type != text_type )	{
+			node_error(arg->nd_left,
+					"\"%s\": textfile expected", name);
+			return;
+		}
+		else	{
+			file = arg->nd_left;
+			arg = arg->nd_right;
+		}
+	}
+	else if( !(file = ChkStdInOut(name, 0)) )
+		return;
+
+	while( arg )	{
+		assert(arg->nd_symb == ',');
+
+		if( !(BaseType(arg->nd_left->nd_type)->tp_fund &
+					( T_CHAR | T_NUMERIC )) )	{
+			node_error(arg->nd_left,
+					"\"%s\": illegal parameter type",name);
+			return;
+		}
+		CodeRead(file, arg->nd_left);
+		arg = arg->nd_right;
+	}
+	CodeReadln(file);
+}
+
+ChkWrite(arg)
+	register struct node *arg;
+{
+	struct node *left, *expp, *file;
+	char *name = "write";
+
+	assert(arg);
+	assert(arg->nd_symb == ',');
+	assert(arg->nd_left->nd_symb == ':');
+
+	left = arg->nd_left;
+	expp = left->nd_left;
+
+	if( expp->nd_type->tp_fund == T_FILE )	{
+		if( left->nd_right )	{
+			node_error(expp,
+			       "\"%s\": filevariable can't have a width",name);
+			return;
+		}
+		file = expp;
+		arg = arg->nd_right;
+		if( !arg )	{
+			error("\"%s\": expression expected", name);
+			return;
+		}
+	}
+	else if( !(file = ChkStdInOut(name, 1)) )
+		return;
+
+	while( arg )	{
+		assert(arg->nd_symb == ',');
+
+		if( !ChkWriteParameter(file->nd_type, arg->nd_left, name) )
+			return;
+
+		CodeWrite(file, arg->nd_left);
+		arg = arg->nd_right;
+	}
+}
+
+ChkWriteln(arg)
+	register struct node *arg;
+{
+	struct node *left, *expp, *file;
+	char *name = "writeln";
+
+	if( !arg )	{
+		if( !(file = ChkStdInOut(name, 1)) )
+			return;
+		else	{
+			CodeWriteln(file);
+			return;
+		}
+	}
+
+	assert(arg->nd_symb == ',');
+	assert(arg->nd_left->nd_symb == ':');
+
+	left = arg->nd_left;
+	expp = left->nd_left;
+
+	if( expp->nd_type->tp_fund == T_FILE )	{
+		if( expp->nd_type != text_type )	{
+			node_error(expp, "\"%s\": textfile expected", name);
+			return;
+		}
+		if( left->nd_right )	{
+			node_error(expp,
+			      "\"%s\": filevariable can't have a width", name);
+			return;
+		}
+		file = expp;
+		arg = arg->nd_right;
+	}
+	else if( !(file = ChkStdInOut(name, 1)) )
+		return;
+
+	while( arg )	{
+		assert(arg->nd_symb == ',');
+
+		if( !ChkWriteParameter(text_type, arg->nd_left, name) )
+			return;
+
+		CodeWrite(file, arg->nd_left);
+		arg = arg->nd_right;
+	}
+	CodeWriteln(file);
+}
+
+ChkWriteParameter(filetype, arg, name)
+	struct type *filetype;
+	struct node *arg;
+	char *name;
+{
+	struct type *tp;
+	char *mess = "illegal write parameter";
+
+	assert(arg->nd_symb == ':');
+
+	tp = BaseType(arg->nd_left->nd_type);
+
+	if( filetype == text_type )	{
+		if( !(tp == bool_type || tp->tp_fund & (T_CHAR | T_NUMERIC) ||
+							IsString(tp)) )	{
+			node_error(arg->nd_left, "\"%s\": %s", name, mess);
+			return 0;
+		}
+	}
+	else	{
+		if( !TstAssCompat(BaseType(filetype->next), tp) )	{
+			node_error(arg->nd_left, "\"%s\": %s", name, mess);
+			return 0;
+		}
+		if( arg->nd_right )	{
+			node_error(arg->nd_left, "\"%s\": %s", name, mess);
+			return 0;
+		}
+		else
+			return 1;
+	}
+
+	/* Here we have a text-file */
+
+	if( arg = arg->nd_right )	{
+		/* Total width */
+
+		assert(arg->nd_symb == ':');
+		if( BaseType(arg->nd_left->nd_type) != int_type )	{
+			node_error(arg->nd_left, "\"%s\": %s", name, mess);
+			return 0;
+		}
+	}
+	else
+		return 1;
+
+	if( arg = arg->nd_right )	{
+		/* Fractional Part */
+
+		assert(arg->nd_symb == ':');
+		if( tp != real_type )	{
+			node_error(arg->nd_left, "\"%s\": %s", name, mess);
+			return 0;
+		}
+		if( BaseType(arg->nd_left->nd_type) != int_type )	{
+			node_error(arg->nd_left, "\"%s\": %s", name, mess);
+			return 0;
+		}
+	}
+	return 1;
+}
+
+struct node *
+ChkStdInOut(name, st_out)
+	char *name;
+{
+	register struct def *df;
+	register struct node *nd;
+
+	if( !(df = lookup(str2idf(st_out ? output : input, 0), GlobalScope)) ||
+				!(df->df_flags & D_PROGPAR) )	{
+		error("\"%s\": standard input/output not defined", name);
+		return NULLNODE;
+	}
+
+	nd = MkLeaf(Def, &dot);
+	nd->nd_def = df;
+	nd->nd_type = df->df_type;
+
+	return nd;
+}
+
+CodeRead(file, arg)
+	register struct node *file, *arg;
+{
+	struct type *tp = BaseType(arg->nd_type);
+
+	if( err_occurred ) return;
+
+	CodeDAddress(file);
+
+	if( file->nd_type == text_type )	{
+		switch( tp->tp_fund )	{
+			case T_CHAR:
+				C_cal("_rdc");
+				break;
+
+			case T_INTEGER:
+				C_cal("_rdi");
+				break;
+
+			case T_REAL:
+				C_cal("_rdr");
+				break;
+
+			default:
+				crash("(CodeRead)");
+				/*NOTREACHED*/
+		}
+		C_asp(pointer_size);
+		C_lfr(tp->tp_size);
+		RangeCheck(arg->nd_type, file->nd_type->next);
+		CodeDStore(arg);
+	}
+	else	{
+		/* Keep the address of the file on the stack */
+		C_dup(pointer_size);
+
+		C_cal("_wdw");
+		C_asp(pointer_size);
+		C_lfr(pointer_size);
+		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();
+
+		CodeDStore(arg);
+		C_cal("_get");
+		C_asp(pointer_size);
+	}
+}
+
+CodeReadln(file)
+	struct node *file;
+{
+	if( err_occurred ) return;
+
+	CodeDAddress(file);
+	C_cal("_rln");
+	C_asp(pointer_size);
+}
+
+CodeWrite(file, arg)
+	register struct node *file, *arg;
+{
+	int width = 0;
+	register arith nbpars = pointer_size;
+	register struct node *expp = arg->nd_left;
+	struct node *right = arg->nd_right;
+	struct type *tp = BaseType(expp->nd_type);
+
+	if( err_occurred ) return;
+
+	CodeDAddress(file);
+	CodePExpr(expp);
+
+	if( file->nd_type == text_type )	{
+		if( tp->tp_fund & (T_ARRAY | T_STRING) )	{
+			C_loc(IsString(tp));
+			nbpars += pointer_size + int_size;
+		}
+		else nbpars += tp->tp_size;
+
+		if( right )	{
+			width = 1;
+			CodePExpr(right->nd_left);
+			nbpars += int_size;
+			right = right->nd_right;
+		}
+
+		switch( tp->tp_fund )	{
+			case T_ENUMERATION:	/* boolean */
+				C_cal(width ? "_wsb" : "_wrb");
+				break;
+
+			case T_CHAR:
+				C_cal(width ? "_wsc" : "_wrc");
+				break;
+
+			case T_INTEGER:
+				C_cal(width ? "_wsi" : "_wri");
+				break;
+
+			case T_REAL:
+				if( right )	{
+					CodePExpr(right->nd_left);
+					nbpars += int_size;
+					C_cal("_wrf");
+				}
+				else C_cal(width ? "_wsr" : "_wrr");
+				break;
+
+			case T_ARRAY:
+			case T_STRING:
+				C_cal(width ? "_wss" : "_wrs");
+				break;
+
+			default:
+				crash("CodeWrite)");
+				/*NOTREACHED*/
+		}
+		C_asp(nbpars);
+	}
+	else	{
+		if( file->nd_type->next == real_type && tp == int_type )
+			Int2Real();
+
+		CodeDAddress(file);
+		C_cal("_wdw");
+		C_asp(pointer_size);
+		C_lfr(pointer_size);
+		C_sti(file->nd_type->next->tp_psize);
+
+		C_cal("_put");
+		C_asp(pointer_size);
+	}
+}
+
+CodeWriteln(file)
+	register struct node *file;
+{
+	if( err_occurred ) return;
+
+	CodeDAddress(file);
+	C_cal("_wln");
+	C_asp(pointer_size);
+}

lang/pc/comp/required.h

@@ -0,0 +1,43 @@
+/* REQUIRED PROCEDURES AND FUNCTIONS */
+
+/* PROCEDURES */
+/* FILE HANDLING */
+#define R_REWRITE	1
+#define R_PUT		2
+#define R_RESET		3
+#define R_GET		4
+#define R_PAGE		5
+
+/* DYNAMIC ALLOCATION */
+#define R_NEW		6
+#define R_DISPOSE	7
+
+/* TRANSFER */
+#define R_PACK		8
+#define R_UNPACK	9
+
+/* 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
+
+/* TRANSFER */
+#define R_TRUNC		18
+#define R_ROUND		19
+
+/* ORDINAL */
+#define R_ORD		20
+#define R_CHR		21
+#define R_SUCC		22
+#define R_PRED		23
+
+/* BOOLEAN */
+#define R_ODD		24
+#define R_EOF		25
+#define R_EOLN		26

lang/pc/comp/scope.H

@@ -0,0 +1,31 @@
+/* S C O P E   M E C H A N I S M */
+
+struct scope {
+	struct scope *next;
+	struct def *sc_def;	/* list of definitions in this scope */
+	int sc_level;		/* level of this scope */
+	arith sc_off;		/* offsets of variables in this scope */
+	struct node *sc_lablist;/* list of labels in this scope, to speed
+				   up label handling
+				*/
+};
+
+/* ALLOCDEF "scope" 10 */
+
+struct scopelist {
+	struct scopelist *next;
+	struct scope *sc_scope;
+};
+
+/* ALLOCDEF "scopelist" 10 */
+
+extern struct scope
+	*GlobalScope,
+	*PervasiveScope,
+	*BlockScope;
+
+extern struct scopelist
+	*CurrVis;
+
+#define	CurrentScope	(CurrVis->sc_scope)
+#define	nextvisible(x)	((x)->next)		/* use with scopelists */

lang/pc/comp/scope.c

@@ -0,0 +1,111 @@
+/* S C O P E   M E C H A N I S M */
+
+#include	"debug.h"
+
+#include	<alloc.h>
+#include	<assert.h>
+#include	<em_arith.h>
+#include	<em_label.h>
+
+#include	"LLlex.h"
+#include	"def.h"
+#include	"idf.h"
+#include	"misc.h"
+#include	"node.h"
+#include	"scope.h"
+#include	"type.h"
+
+struct scope *GlobalScope, *PervasiveScope, *BlockScope;
+struct scopelist *CurrVis;
+extern int proclevel;			/* declared in declar.g */
+
+InitScope()
+{
+	register struct scope *sc = new_scope();
+	register struct scopelist *ls = new_scopelist();
+
+	sc->sc_def = 0;
+	sc->sc_level = proclevel;
+	PervasiveScope = sc;
+	ls->next = 0;
+	ls->sc_scope = PervasiveScope;
+	CurrVis = ls;
+}
+
+open_scope()
+{
+	register struct scope *sc = new_scope();
+	register struct scopelist *ls = new_scopelist();
+
+	sc->sc_level = proclevel;
+	ls->sc_scope = sc;
+	ls->next = CurrVis;
+	CurrVis = ls;
+}
+
+close_scope()
+{
+	/* When this procedure is called, the next visible scope is equal to
+	   the statically enclosing scope
+	*/
+
+	assert(CurrentScope != 0);
+	CurrVis = CurrVis->next;
+}
+
+Forward(nd, tp)
+	register struct node *nd;
+	register struct type *tp;
+{
+	/* Enter a forward reference into the current scope. This is
+	 * used in pointertypes.
+	 */
+	register struct def *df = define(nd->nd_IDF, CurrentScope, D_FORWTYPE);
+	register struct forwtype *fw_type = new_forwtype();
+
+	fw_type->f_next = df->df_fortype;
+	df->df_fortype = fw_type;
+
+	fw_type->f_node = nd;
+	fw_type->f_type = tp;
+}
+
+STATIC
+chk_prog_params()
+{
+	/* the program parameters must be global variables of some file type */
+	register struct def *df = CurrentScope->sc_def;
+
+	while( df )	{
+	    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",
+							df->df_idf->id_text);
+		    else if( df->df_type->tp_fund != T_FILE )
+			error("program parameter \"%s\" must have a file type",
+							df->df_idf->id_text);
+
+		    df->df_kind = D_VARIABLE;
+		}
+		else df->df_kind = D_ERROR;
+	    }
+	    df = df->df_nextinscope;
+	}
+}
+
+STATIC
+chk_directives()
+{
+	/* check if all forward declarations are defined */
+	register struct def *df = CurrentScope->sc_def;
+
+	while( df )	{
+		if( df->df_kind == D_FWPROCEDURE )
+		     error("procedure \"%s\" not defined", df->df_idf->id_text);
+		else if( df->df_kind == D_FWFUNCTION )
+		      error("function \"%s\" not defined", df->df_idf->id_text);
+
+		df = df->df_nextinscope;
+	}
+}

lang/pc/comp/statement.g

@@ -0,0 +1,442 @@
+/* S T A T E M E N T S */
+{
+#include	<alloc.h>
+#include	<em.h>
+
+#include	"LLlex.h"
+#include	"chk_expr.h"
+#include	"def.h"
+#include	"desig.h"
+#include	"idf.h"
+#include	"main.h"
+#include	"node.h"
+#include	"scope.h"
+#include	"type.h"
+
+int slevel = 0;		/* nesting level of statements */
+}
+
+
+/* ISO section 6.8.3.2, p. 128 */
+CompoundStatement:
+	BEGIN StatementSequence END
+;
+
+/* ISO section 6.8.3.1, p. 128 */
+StatementSequence:
+	Statement
+	[ %persistent
+		';' Statement
+	]*
+					{ chk_labels(slevel + 1); }
+;
+
+/* ISO section 6.8.1, p. 126 */
+Statement
+{
+	struct node *nd;
+} :
+					{
+					  slevel++;
+					}
+	[ Label(&nd) ':'
+					{ if( nd ) DefLabel(nd, slevel); }
+	]?
+					{ if( !options['L'] )
+						C_lin((arith) dot.tk_lineno);
+					}
+	[
+		SimpleStatement
+	|
+		StructuredStatement
+	]
+					{ slevel--; }
+;
+
+/* ISO section 6.8.2.1, p. 126 */
+SimpleStatement
+{
+	struct node *pnd, *expp;
+} :
+	/* 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 | ...
+	 */
+	EmptyStatement
+|
+	GotoStatement
+|
+	/* Evidently this is the beginning of the changed part
+	 */
+	IDENT			{ pnd = MkLeaf(Name, &dot); }
+	[
+		/* At this point the IDENT can be a FunctionIdentifier in
+		 * which case the VariableAccessTail must be empty.
+		 */
+		VariableAccessTail(&pnd)
+		[
+			BECOMES
+		|
+			'='	{ error("':=' expected instead of '='"); }
+		]
+		Expression(&expp)
+				{ AssignStat(pnd, expp); }
+	|
+				{ pnd = MkNode(Call, pnd, NULLNODE, &dot); }
+		ActualParameterList(&(pnd->nd_right))?
+				{ ProcStat(pnd);
+
+				  if( !err_occurred )
+					CodeCall(pnd);
+
+				  FreeNode(pnd);
+				}
+	]
+|
+	InputOutputStatement
+	/* end of changed part
+	 */
+;
+
+InputOutputStatement
+{
+	struct node *nd = NULLNODE;
+} :
+	/* This is a new rule because the grammar specified by the standard
+	 * is not exactly LL(1) (see SimpleStatement).
+	 */
+	[
+		READ ReadParameterList(&nd)		{ ChkRead(nd); }
+	|
+		READLN ReadParameterList(&nd)?		{ ChkReadln(nd); }
+	|
+		WRITE WriteParameterList(&nd)		{ ChkWrite(nd); }
+	|
+		WRITELN WriteParameterList(&nd)?	{ ChkWriteln(nd); }
+	]
+							{ FreeNode(nd); }
+;
+
+EmptyStatement:
+	/* empty */
+;
+
+/* ISO section 6.8.3.1, p. 128 */
+StructuredStatement:
+	CompoundStatement
+|
+	ConditionalStatement
+|
+	RepetitiveStatement
+|
+	WithStatement
+;
+
+/* ISO section 6.8.2.4, p. 127 */
+GotoStatement
+{
+	struct node *nd;
+} :
+	GOTO Label(&nd)
+					{ if( nd ) TstLabel(nd, slevel); }
+;
+
+/* ISO section 6.8.3.3, p. 128 */
+ConditionalStatement:
+	%default
+	CaseStatement
+|
+	IfStatement
+;
+
+/* ISO section 6.8.3.6, p. 129 */
+RepetitiveStatement:
+	RepeatStatement
+|
+	WhileStatement
+|
+	ForStatement
+;
+
+/* ISO section 6.8.3.10, p. 132 */
+WithStatement
+{
+	struct scopelist *Save = CurrVis;
+	struct node *nd;
+} :
+	WITH
+	RecordVariableList(&nd)
+	DO
+	Statement	{ EndWith(Save, nd);
+			  chk_labels(slevel + 1);
+			}
+;
+
+RecordVariableList(register struct node **pnd;)
+{
+	struct node *nd;
+} :
+	RecordVariable(&nd)
+				{ *pnd = nd = MkNode(Link, nd, NULLNODE, &dot);
+				  nd->nd_symb = ',';
+				}
+	[ %persistent
+		','		{ nd->nd_right = MkLeaf(Link, &dot);
+				  nd = nd->nd_right;
+				}
+		RecordVariable(&(nd->nd_left))
+	]*
+;
+
+RecordVariable(register struct node **pnd;):
+	VariableAccess(pnd)
+				{ WithStat(*pnd); }
+;
+
+/* ISO section 6.8.3.4, p. 128 */
+IfStatement
+{
+	struct node *nd;
+	label l1 = ++text_label;
+	label l2 = ++text_label;
+} :
+	IF
+	BooleanExpression(&nd)
+					{ struct desig ds;
+					
+					  ds = InitDesig;
+					  if( !err_occurred )
+						CodeExpr(nd, &ds, l1);
+					}
+	THEN
+	Statement			{ chk_labels(slevel + 1); }
+	[ %prefer	/* closest matching */
+		ELSE
+					{ C_bra(l2);
+					  C_df_ilb(l1);
+					}
+		Statement
+					{ C_df_ilb(l2);
+					  chk_labels(slevel + 1);
+					}
+	|
+		/* empty */
+					{ C_df_ilb(l1); }
+	]
+;
+
+/* ISO section 6.8.3.5, p. 128 */
+CaseStatement
+{
+	struct node *casend, *nd;
+	label exit_label;
+} :
+	/* This is a changed rule, because the grammar as specified in the
+	 * reference states that a semicolon is optional before END,
+	 * and this is not LL(1).
+	 */
+	CASE				{ casend = nd = MkLeaf(Link, &dot);
+					  casend->nd_lab = ++text_label;
+					  exit_label = ++text_label;
+					}
+	Expression(&(nd->nd_left))
+					{ CaseExpr(casend); }
+	OF
+	CaseListElement(&(nd->nd_right), exit_label)
+					{ nd = nd->nd_right; }
+	CaseListElementTail(&(nd->nd_right), exit_label)
+	END
+					{ CaseEnd(casend, exit_label); }
+;
+
+CaseListElementTail(register struct node **pnd; label exit_label;):
+	/* This is a new rule, all because of a silly semicolon
+	 */
+	/* empty */
+|
+%default
+	';'
+	[
+		/* empty */
+	|
+		CaseListElement(pnd, exit_label)
+		CaseListElementTail(&((*pnd)->nd_right), exit_label)
+	]
+;
+
+CaseListElement(register struct node **pnd; label exit_label;):
+	CaseConstantList(pnd)
+	':'
+				{ *pnd = MkNode(Link, *pnd, NULLNODE, &dot);
+				  (*pnd)->nd_lab = ++text_label;
+				  C_df_ilb(text_label);
+				}
+	Statement		{ C_bra(exit_label);
+				  chk_labels(slevel + 1);
+				}
+;
+
+/* ISO section 6.8.3.7, p. 129 */
+RepeatStatement
+{
+	struct node *nd;
+	label repeatlb = ++text_label;
+} :
+	REPEAT
+					{ C_df_ilb(repeatlb); }
+	StatementSequence
+	UNTIL
+	BooleanExpression(&nd)
+					{ struct desig ds;
+
+					  ds = InitDesig;
+					  if( !err_occurred )
+						CodeExpr(nd, &ds, repeatlb);
+					}
+;
+
+/* ISO section 6.8.3.8, p. 129 */
+WhileStatement
+{
+	struct node *nd;
+	label whilelb = ++text_label;
+	label exitlb = ++text_label;
+
+} :
+	WHILE
+					{ C_df_ilb(whilelb); }
+	BooleanExpression(&nd)
+					{ struct desig ds;
+
+					  ds = InitDesig;
+					  if( !err_occurred )
+						CodeExpr(nd, &ds, exitlb);
+					}
+	DO
+	Statement
+					{ C_bra(whilelb);
+					  C_df_ilb(exitlb);
+					  chk_labels(slevel + 1);
+					}
+;
+
+/* ISO section 6.8.3.9, p. 130 */
+ForStatement
+{
+	register struct node *nd;
+	int stepsize;
+	label l1 = ++text_label;
+	label l2 = ++text_label;
+	arith tmp1 = (arith) 0;
+	arith tmp2 = (arith) 0;
+} :
+	FOR
+	/* ControlVariable must be an EntireVariable */
+	IDENT			{ nd = MkLeaf(Name, &dot); }
+	BECOMES
+	Expression(&(nd->nd_left))
+	[
+		TO		{ stepsize = 1; }
+	|
+		DOWNTO		{ stepsize = -1; }
+	]
+	Expression(&(nd->nd_right))
+				{ ChkForStat(nd);
+				  if( !err_occurred )	{
+					tmp1 = CodeInitFor(nd->nd_left, 0);
+					tmp2 = CodeInitFor(nd->nd_right, 2);
+				  	CodeFor(nd, stepsize, l1, l2, tmp1);
+				  }
+				}
+	DO
+	Statement
+				{ if( !err_occurred )
+				       CodeEndFor(nd, stepsize, l1, l2, tmp2);
+				  chk_labels(slevel + 1);
+				  FreeNode(nd);
+				  if( tmp1 ) FreeInt(tmp1);
+				  if( tmp2 ) FreeInt(tmp2);
+				}
+;
+
+/* SPECIALSPECIALSPECIALSPECIALSPECIALSPECIALSPECIALSPECIALSPECIALSPECIAL */
+/* ISO section 6.9, p. 132-136 */
+ReadParameterList(register struct node **pnd;)
+{
+	register struct node *nd;
+} :
+	/* This is a changed rule, because the grammar as specified in the
+	 * reference is not LL(1), and this gives conflicts.
+	 */
+	'('
+		VariableAccess(pnd)	/* possibly a FileVariable */
+					{ *pnd = nd =
+					     MkNode(Link, *pnd, NULLNODE, &dot);
+					  nd->nd_symb = ',';
+					}
+		[ %persistent
+			',' 		{ nd->nd_right = MkLeaf(Link, &dot);
+					  nd = nd->nd_right;
+					}
+			VariableAccess(&(nd->nd_left))
+		]*
+	')'
+;
+
+WriteParameterList(register struct node **pnd;)
+{
+	register struct node *nd;
+} :
+	/* This is a changed rule, because the grammar as specified in the
+	 * reference is not LL(1), and this gives conflicts.
+	 */
+	'('
+		/* Only the first WriteParameter can be a FileVariable !!
+		 */
+		WriteParameter(pnd)
+					{ *pnd = nd =
+					     MkNode(Link, *pnd, NULLNODE, &dot);
+					  nd->nd_symb = ',';
+					}
+		[ %persistent
+			',' 		{ nd->nd_right = MkLeaf(Link, &dot);
+					  nd = nd->nd_right;
+					}
+			WriteParameter(&(nd->nd_left))
+		]*
+	')'
+;
+
+WriteParameter(register struct node **pnd;)
+{
+	register struct node *nd;
+} :
+	Expression(pnd)
+					{ if( !ChkExpression(*pnd) )
+						(*pnd)->nd_type = error_type;
+					  *pnd = nd =
+					     MkNode(Link, *pnd, NULLNODE, &dot);
+					  nd->nd_symb = ':';
+					}
+	[
+	/* Here the first Expression can't be a FileVariable
+	 */
+		':'			{ nd->nd_right = MkLeaf(Link, &dot);
+					  nd = nd->nd_right;
+					}
+		Expression(&(nd->nd_left))
+					{ if( !ChkExpression(nd->nd_left) )
+					      nd->nd_left->nd_type = error_type;
+					}
+		[
+			':'		{ nd->nd_right = MkLeaf(Link, &dot);
+					  nd = nd->nd_right;
+					}
+			Expression(&(nd->nd_left))
+					{ if( !ChkExpression(nd->nd_left) )
+					      nd->nd_left->nd_type = error_type;
+					}
+		]?
+	]?
+;

lang/pc/comp/tab.c

@@ -0,0 +1,295 @@
+/*	@cc tab.c -o $INSTALLDIR/tab@
+	tab - table generator 
+
+	Author: Erik Baalbergen (..tjalk!erikb)
+*/
+
+#include <stdio.h> 
+
+static char *RcsId = "$Header$";
+
+#define MAXTAB	10000
+#define MAXBUF	10000
+#define COMCOM	'-'
+#define FILECOM	'%'
+
+int InputForm = 'c';
+char OutputForm[MAXBUF] = "%s,\n";
+int TabSize = 257;
+char *Table[MAXTAB];
+char *Name;
+char *ProgCall;
+
+main(argc, argv)
+	char *argv[];
+{
+	ProgCall = *argv++;
+	argc--;
+	while (argc-- > 0) {
+		if (**argv == COMCOM) {
+			option(*argv++);
+		}
+		else {
+			process(*argv++, InputForm);
+		}
+	}
+}
+
+char *
+Salloc(s)
+	char *s;
+{
+	char *malloc();
+	char *ns = malloc(strlen(s) + 1);
+
+	if (ns) {
+		strcpy(ns, s);
+	}
+	return ns;
+}
+
+option(str)
+	char *str;
+{
+	/*	note that *str indicates the source of the option:
+		either COMCOM (from command line) or FILECOM (from a file).
+	*/
+	switch (*++str) {
+
+	case ' ':	/* command */
+	case '\t':
+	case '\0':
+		break;
+	case 'I':
+		InputForm = *++str;
+		break;
+	case 'f':
+		if (*++str == '\0') {
+			fprintf(stderr, "%s: -f: name expected\n", ProgCall);
+			exit(1);
+		}
+		DoFile(str);
+		break;
+	case 'F':
+		sprintf(OutputForm, "%s\n", ++str);
+		break;
+	case 'T':
+		printf("%s\n", ++str);
+		break;
+	case 'p':
+		PrintTable();
+		break;
+	case 'C':
+		ClearTable();
+		break;
+	case 'S':
+	{
+		register i = stoi(++str);
+
+		if (i <= 0 || i > MAXTAB) {
+			fprintf(stderr, "%s: size would exceed maximum\n",
+				ProgCall);
+		}
+		else {
+			TabSize = i;
+		}
+		break;
+	}
+	default:
+		fprintf(stderr, "%s: bad option -%s\n", ProgCall, str);
+	}
+}
+
+ClearTable()
+{
+	register i;
+
+	for (i = 0; i < MAXTAB; i++) {
+		Table[i] = 0;
+	}
+}
+
+PrintTable()
+{
+	register i;
+
+	for (i = 0; i < TabSize; i++) {
+		if (Table[i]) {
+			printf(OutputForm, Table[i]);
+		}
+		else {
+			printf(OutputForm, "0");
+		}
+	}
+}
+
+process(str, format)
+	char *str;
+{
+	char *cstr = str;
+	char *Name = cstr;	/* overwrite original string!	*/
+
+	/* strip of the entry name
+	*/
+	while (*str && *str != ':') {
+		if (*str == '\\') {
+			++str;
+		}
+		*cstr++ = *str++;
+	}
+
+	if (*str != ':') {
+		fprintf(stderr, "%s: bad specification: \"%s\", ignored\n",
+			ProgCall, Name);
+		return 0;
+	}
+	*cstr = '\0';
+	str++;
+
+	switch (format) {
+
+	case 'c':
+		return c_proc(str, Name);
+	default:
+		fprintf(stderr, "%s: bad input format\n", ProgCall);
+	}
+	return 0;
+}
+
+c_proc(str, Name)
+	char *str;
+	char *Name;
+{
+	int ch, ch2;
+	int quoted();
+
+	while (*str)	{
+		if (*str == '\\')	{
+			ch = quoted(&str);
+		}
+		else	{
+			ch = *str++;
+		}
+		if (*str == '-')	{
+			if (*++str == '\\')	{
+				ch2 = quoted(&str);
+			}
+			else	{
+				if (ch2 = *str++);
+				else str--;
+			}
+			if (ch > ch2)	{
+				fprintf(stderr, "%s: bad range\n", ProgCall);
+				return 0;
+			}
+			if (ch >= 0 && ch2 <= 255)
+				while (ch <= ch2)
+					Table[ch++] = Salloc(Name);
+		}
+		else	{
+			if (ch >= 0 && ch <= 255)
+				Table[ch] = Salloc(Name);
+		}
+	}
+	return 1;
+}
+			
+int
+quoted(pstr)
+	char **pstr;
+{
+	register int ch;
+	register int i;
+	register char *str = *pstr;
+
+	if ((*++str >= '0') && (*str <= '9'))	{
+		ch = 0;
+		for (i = 0; i < 3; i++)	{
+			ch = 8 * ch + *str - '0';
+			if (*++str < '0' || *str > '9')
+				break;
+		}
+	}
+	else	{
+		switch (*str++)	{
+
+		case 'n':
+			ch = '\n';
+			break;
+		case 't':
+			ch = '\t';
+			break;
+		case 'b':
+			ch = '\b';
+			break;
+		case 'r':
+			ch = '\r';
+			break;
+		case 'f':
+			ch = '\f';
+			break;
+		default :
+			ch = *str;
+		}
+	}
+	*pstr = str;
+	return ch & 0377;
+}
+
+int
+stoi(str)
+	char *str;
+{
+	register i = 0;
+
+	while (*str >= '0' && *str <= '9') {
+		i = i * 10 + *str++ - '0';
+	}
+	return i;
+}
+
+char *
+getline(s, n, fp)
+	char *s;
+	FILE *fp;
+{
+	register c = getc(fp);
+	char *str = s;
+
+	while (n--) {
+		if (c == EOF) {
+			return NULL;
+		}
+		else
+		if (c == '\n') {
+			*str++ = '\0';
+			return s;
+		}
+		*str++ = c;
+		c = getc(fp);
+	}
+	s[n - 1] = '\0';
+	return s;
+}
+
+#define BUFSIZE 1024
+
+DoFile(name)
+	char *name;
+{
+	char text[BUFSIZE];
+	FILE *fp;
+
+	if ((fp = fopen(name, "r")) == NULL) {
+		fprintf(stderr, "%s: cannot read file %s\n", ProgCall, name);
+		exit(1);
+	}
+	while (getline(text, BUFSIZE, fp) != NULL) {
+		if (text[0] == FILECOM) {
+			option(text);
+		}
+		else {
+			process(text, InputForm);
+		}
+	}
+}

lang/pc/comp/tmpvar.C

@@ -0,0 +1,127 @@
+/* T E M P O R A R Y   V A R I A B L E S */
+
+/*	Code for the allocation and de-allocation of temporary variables,
+	allowing re-use.
+	The routines use "ProcScope" instead of "CurrentScope", because
+	"CurrentScope" also reflects WITH statements, and these scopes do not
+	have local variables.
+*/
+
+#include	"debug.h"
+
+#include	<alloc.h>
+#include	<em_arith.h>
+#include	<em_label.h>
+#include	<em_reg.h>
+
+#include	"def.h"
+#include	"main.h"
+#include	"scope.h"
+#include	"type.h"
+
+struct tmpvar	{
+	struct tmpvar	*next;
+	arith		t_offset;	/* offset from LocalBase */
+};
+
+/* ALLOCDEF "tmpvar" 10 */
+
+static struct tmpvar	*TmpInts,	/* for integer temporaries */
+			*TmpPtrs;	/* for pointer temporaries */
+static struct scope	*ProcScope;	/* scope of procedure in which the
+					   temporaries are allocated
+					*/
+
+TmpOpen(sc)
+	struct scope *sc;
+{
+	/*	Initialize for temporaries in scope "sc".
+	*/
+	ProcScope = sc;
+}
+
+arith
+TmpSpace(sz, al)
+	arith sz;
+{
+	register struct scope *sc = ProcScope;
+
+	sc->sc_off = - WA(align(sz - sc->sc_off, al));
+	return sc->sc_off;
+}
+
+STATIC arith
+NewTmp(plist, sz, al, regtype, priority)
+	struct tmpvar **plist;
+	arith sz;
+{
+	register arith offset;
+	register struct tmpvar *tmp;
+
+	if( !*plist )	{
+		offset = TmpSpace(sz, al);
+		if( !options['n'] ) C_ms_reg(offset, sz, regtype, priority);
+	}
+	else	{
+		tmp = *plist;
+		offset = tmp->t_offset;
+		*plist = tmp->next;
+		free_tmpvar(tmp);
+	}
+	return offset;
+}
+
+arith
+NewInt(reg_prior)
+{
+	return NewTmp(&TmpInts, int_size, int_align, reg_any, reg_prior);
+}
+
+arith
+NewPtr(reg_prior)
+{
+   return NewTmp(&TmpPtrs, pointer_size, pointer_align, reg_pointer, reg_prior);
+}
+
+STATIC
+FreeTmp(plist, off)
+	struct tmpvar **plist;
+	arith off;
+{
+	register struct tmpvar *tmp = new_tmpvar();
+
+	tmp->next = *plist;
+	tmp->t_offset = off;
+	*plist = tmp;
+}
+
+FreeInt(off)
+	arith off;
+{
+	FreeTmp(&TmpInts, off);
+}
+
+FreePtr(off)
+	arith off;
+{
+	FreeTmp(&TmpPtrs, off);
+}
+
+TmpClose()
+{
+	register struct tmpvar *tmp, *tmp1;
+
+	tmp = TmpInts;
+	while( tmp )	{
+		tmp1 = tmp;
+		tmp = tmp->next;
+		free_tmpvar(tmp1);
+	}
+	tmp = TmpPtrs;
+	while( tmp )	{
+		tmp1 = tmp;
+		tmp = tmp->next;
+		free_tmpvar(tmp1);
+	}
+	TmpInts = TmpPtrs = 0;
+}

lang/pc/comp/tokenname.c

@@ -0,0 +1,98 @@
+/* T O K E N   D E F I N I T I O N S */
+
+#include	"Lpars.h"
+#include	"idf.h"
+#include	"tokenname.h"
+
+/*	To centralize the declaration of %tokens, their presence in this
+	file is taken as their declaration. The Makefile will produce
+	a grammar file (tokenfile.g) from this file. This scheme ensures
+	that all tokens have a printable name.
+	Also, the "symbol2str.c" file is produced from this file.
+*/
+
+struct tokenname tkspec[] =	{	/* the names of the special tokens */
+	{IDENT, "identifier"},
+	{STRING, "string"},
+	{INTEGER, "integer"},
+	{REAL, "real"},
+	{0, ""}
+};
+
+struct tokenname tkcomp[] =	{	/* names of the composite tokens */
+	{LESSEQUAL, "<="},
+	{GREATEREQUAL, ">="},
+	{NOTEQUAL, "<>"},
+	{UPTO, ".."},
+	{BECOMES, ":="},
+	{0, ""}
+};
+
+struct tokenname tkidf[] =	{	/* names of the identifier tokens */
+	{AND, "and"},
+	{ARRAY, "array"},
+	{BEGIN, "begin"},
+	{CASE, "case"},
+	{CONST, "const"},
+	{DIV, "div"},
+	{DO, "do"},
+	{DOWNTO, "downto"},
+	{ELSE, "else"},
+	{END, "end"},
+	{FILE, "file"},
+	{FOR, "for"},
+	{FUNCTION, "function"},
+	{GOTO, "goto"},
+	{IF, "if"},
+	{IN, "in"},
+	{LABEL, "label"},
+	{MOD, "mod"},
+	{NIL, "nil"},
+	{NOT, "not"},
+	{OF, "of"},
+	{OR, "or"},
+	{PACKED, "packed"},
+	{PROCEDURE, "procedure"},
+	{PROGRAM, "program"},
+	{RECORD, "record"},
+	{REPEAT, "repeat"},
+	{SET, "set"},
+	{THEN, "then"},
+	{TO, "to"},
+	{TYPE, "type"},
+	{UNTIL, "until"},
+	{VAR, "var"},
+	{WHILE, "while"},
+	{WITH, "with"},
+	{0, ""}
+};
+
+struct tokenname tkstandard[] =	{	/* standard identifiers */
+	/* These are the only standard identifiers entered here, because
+	 * they can get a variable number of arguments, and there are
+	 * special syntaxrules in the grammar for them
+	 */
+	{READ, "read"},
+	{READLN, "readln"},
+	{WRITE, "write"},
+	{WRITELN, "writeln"},
+	{0, ""}
+};
+
+/* Some routines to handle tokennames */
+
+reserve(resv)
+	register struct tokenname *resv;
+{
+	/*	The names of the tokens described in resv are entered
+		as reserved words.
+	*/
+	register struct idf *p;
+
+	while( resv->tn_symbol )	{
+		p = str2idf(resv->tn_name, 0);
+		if( !p ) fatal("out of Memory");
+		p->id_reserved = resv->tn_symbol;
+		resv++;
+	}
+}

lang/pc/comp/tokenname.h

@@ -0,0 +1,8 @@
+/* T O K E N N A M E   S T R U C T U R E */
+
+struct tokenname	{	/*	Used for defining the name of a
+					token as identified by its symbol
+				*/
+	int tn_symbol;
+	char *tn_name;
+};

lang/pc/comp/type.H

@@ -0,0 +1,166 @@
+/* T Y P E   D E S C R I P T O R   S T R U C T U R E */
+
+struct paramlist {		/* structure for parameterlist of a PROCEDURE */
+	struct paramlist *next;
+	struct def *par_def;	/* "df" of parameter */
+#define	IsVarParam(xpar)	((xpar)->par_def->df_flags & D_VARPAR)
+#define TypeOfParam(xpar)	((xpar)->par_def->df_type)
+};
+
+/* ALLOCDEF "paramlist" 50 */
+
+struct enume	{
+	unsigned int en_ncst;	/* number of constants */
+	label en_rck;		/* label of range check descriptor */
+#define enm_ncst	tp_value.tp_enum.en_ncst
+#define enm_rck		tp_value.tp_enum.en_rck
+};
+
+struct subrange	{
+	arith su_lb, su_ub;	/* lower bound and upper bound */
+	label su_rck;		/* label of range check descriptor */
+#define sub_lb		tp_value.tp_subrange.su_lb
+#define sub_ub		tp_value.tp_subrange.su_ub
+#define sub_rck		tp_value.tp_subrange.su_rck
+};
+
+struct array	{
+	struct type *ar_elem;	/* type of elements */
+	union	{
+		struct	{	/* normal array */
+			arith ar_elsize;	/* size of elements */
+			label ar_descr;		/* label of array descriptor */
+		} norm_arr;
+		struct	{	/* conformant array */
+			int cf_sclevel;		/* scope level of declaration */
+			arith cf_descr;		/* offset array descriptor */
+		} conf_arr;
+	} ar_type;
+#define arr_elem	tp_value.tp_arr.ar_elem
+#define arr_elsize	tp_value.tp_arr.ar_type.norm_arr.ar_elsize
+#define arr_ardescr	tp_value.tp_arr.ar_type.norm_arr.ar_descr
+#define arr_cfdescr	tp_value.tp_arr.ar_type.conf_arr.cf_descr
+#define arr_sclevel	tp_value.tp_arr.ar_type.conf_arr.cf_sclevel
+};
+
+struct selector	{
+	struct type *sel_type;		/* type of the selector of a variant */
+	arith sel_ncst;			/* number of values of selector type */
+	arith sel_lb;			/* lower bound of selector type */
+	struct selector **sel_ptrs;	/* tagvalue table with pointers to
+					   nested variant-selectors */
+};
+
+struct record	{
+	struct scope *rc_scope;		/* scope of this record */
+					/* members are in the symbol table */
+	struct selector *rc_selector;	/* selector of variant (if present) */
+#define rec_scope	tp_value.tp_record.rc_scope
+#define rec_sel		tp_value.tp_record.rc_selector
+};
+
+struct proc	{
+	struct paramlist *pr_params;
+	arith pr_nbpar;
+#define prc_params	tp_value.tp_proc.pr_params
+#define prc_nbpar	tp_value.tp_proc.pr_nbpar
+};
+
+struct type	{
+	struct type *next;	/* used with ARRAY, PROCEDURE, FILE, SET,
+				   POINTER, SUBRANGE */
+	int tp_fund;		/* fundamental type  or constructor */
+#define	T_ENUMERATION	0x0001
+#define	T_INTEGER	0x0002
+#define T_REAL		0x0004
+#define T_CHAR		0x0008
+#define T_PROCEDURE	0x0010
+#define T_FUNCTION	0x0020
+#define T_FILE		0x0040
+#define T_STRING	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_ROUTINE	(T_FUNCTION | T_PROCEDURE)
+	unsigned short tp_flags;
+#define T_HASFILE	0x1	/* set if type has a filecomponent */
+#define T_PACKED	0x2	/* set if type is packed */
+#define T_CHECKED	0x4	/* set if array has been checked */
+	int tp_align;		/* alignment requirement of this type */
+	int tp_palign;		/* in packed structures */
+	arith tp_size;		/* size of this type */
+	arith tp_psize;		/* in packed structures */
+	union {
+	    struct enume tp_enum;
+	    struct subrange tp_subrange;
+	    struct array tp_arr;
+	    struct record tp_record;
+	    struct proc tp_proc;
+	} tp_value;
+};
+
+/* ALLOCDEF "type" 50 */
+
+extern struct type
+	*bool_type,
+	*char_type,
+	*int_type,
+	*real_type,
+	*std_type,
+	*text_type,
+	*nil_type,
+	*emptyset_type,
+	*error_type;		/* All from type.c */
+
+extern int
+	word_align,
+	int_align,
+	pointer_align,
+	real_align,
+	struct_align;		/* All from type.c */
+
+extern arith
+	word_size,
+	int_size,
+	pointer_size,
+	real_size;		/* All from type.c */
+
+extern arith
+	align();
+
+struct type
+	*construct_type(),
+	*standard_type(),
+	*proc_type(),
+	*func_type(),
+	*set_type(),
+	*subr_type();		/* All from type.c */
+
+#define NULLTYPE ((struct type *) 0)
+
+#define bounded(tpx)		((tpx)->tp_fund & T_INDEX)
+#define WA(sz)			(align(sz, (int) word_size))
+#define ResultType(tpx)		(assert((tpx)->tp_fund & T_ROUTINE),(tpx)->next)
+#define ElementType(tpx)	(assert((tpx)->tp_fund & T_SET), (tpx)->next)
+#define BaseType(tpx)		((tpx)->tp_fund & T_SUBRANGE ? (tpx)->next :\
+									(tpx))
+#define IndexType(tpx)		(assert((tpx)->tp_fund == T_ARRAY), (tpx)->next)
+#define	IsConstructed(tpx)	((tpx)->tp_fund & T_CONSTRUCTED)
+#define IsConformantArray(tpx)	((tpx)->tp_fund & T_ARRAY &&\
+							(tpx)->tp_size == 0)
+#define IsPacked(tpx)		((tpx)->tp_flags & T_PACKED)
+#define PointedtoType(tpx)	(assert((tpx)->tp_fund == T_POINTER ||\
+					(tpx)->tp_fund == T_FILE), (tpx)->next)
+#define ParamList(tpx)		(assert((tpx)->tp_fund & T_ROUTINE),\
+					(tpx)->prc_params)
+
+extern long full_mask[];
+
+#define ufit(n, i)	(((n) & ~full_mask[(i)]) == 0)

lang/pc/comp/type.c

@@ -0,0 +1,599 @@
+/*	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>
+#include	<em.h>
+
+#include	<pc_file.h>
+
+#include	"LLlex.h"
+#include	"const.h"
+#include	"def.h"
+#include	"idf.h"
+#include	"main.h"
+#include	"node.h"
+#include	"scope.h"
+#include	"type.h"
+
+int
+	word_align	= AL_WORD,
+	int_align	= AL_INT,
+	pointer_align	= AL_POINTER,
+	real_align	= AL_REAL,
+	struct_align	= AL_STRUCT;
+
+arith
+	word_size	= SZ_WORD,
+	int_size	= SZ_INT,
+	pointer_size	= SZ_POINTER,
+	real_size	= SZ_REAL;
+
+struct type
+	*bool_type,
+	*char_type,
+	*int_type,
+	*real_type,
+	*std_type,
+	*text_type,
+	*nil_type,
+	*emptyset_type,
+	*error_type;
+
+InitTypes()
+{
+	/*	Initialize the predefined types
+	*/
+
+	/* first, do some checking
+	*/
+	if( int_size != word_size )
+		fatal("integer size not equal to word size");
+
+	/* character type
+	*/
+	char_type = standard_type(T_CHAR, 1, (arith) 1);
+	char_type->enm_ncst = 128;	/* only 7 bits ASCII characters */
+	
+	/* boolean type
+	*/
+	bool_type = standard_type(T_ENUMERATION, 1, (arith) 1);
+	bool_type->enm_ncst = 2;
+
+	/* integer type
+	*/
+	int_type = standard_type(T_INTEGER, int_align, int_size);
+
+	/* real type
+	*/
+	real_type = standard_type(T_REAL, real_align, real_size);
+
+	/* an unique type for standard procedures and functions
+	*/
+	std_type = construct_type(T_PROCEDURE, NULLTYPE);
+
+	/* text (file of char) type
+	*/
+	text_type = construct_type(T_FILE, char_type);
+	text_type->tp_flags |= T_HASFILE;
+
+	/* an unique type indicating an error
+	*/
+	error_type = standard_type(T_ERROR, 1, (arith) 1);
+
+	/* the nilvalue has an unique type
+	*/
+	nil_type = construct_type(T_POINTER, error_type);
+
+	/* the type of an empty set is generic
+	*/
+	emptyset_type = construct_type(T_SET, error_type);
+	emptyset_type->tp_size = word_size;
+	emptyset_type->tp_align = word_align;
+}
+
+struct type *
+standard_type(fund, algn, size)
+	arith size;
+{
+	register struct type *tp = new_type();
+
+	tp->tp_fund = fund;
+	tp->tp_palign = algn ? algn : 1;
+	tp->tp_psize = size;
+	tp->tp_align = word_align;
+	tp->tp_size = WA(size);
+
+	return tp;
+}
+
+struct type *
+construct_type(fund, tp)
+	register struct type *tp;
+{
+	/*	fund must be a type constructor.
+	 *	The pointer to the constructed type is returned.
+	 */
+	register struct type *dtp = new_type();
+
+	switch( dtp->tp_fund = fund )	{
+		case T_PROCEDURE:
+		case T_FUNCTION:
+			dtp->tp_align = pointer_align;
+			dtp->tp_size = 2 * pointer_size;
+			break;
+
+		case T_POINTER:
+			dtp->tp_align = dtp->tp_palign = pointer_align;
+			dtp->tp_size = dtp->tp_psize = pointer_size;
+			break;
+
+		case T_SET:
+		case T_ARRAY:
+			break;
+
+		case T_FILE:
+			dtp->tp_align = dtp->tp_palign = word_align;
+			dtp->tp_size = dtp->tp_psize = sizeof(struct file);
+			break;
+
+		case T_SUBRANGE:
+			assert(tp != 0);
+			dtp->tp_align = tp->tp_align;
+			dtp->tp_size = tp->tp_size;
+			dtp->tp_palign = tp->tp_palign;
+			dtp->tp_psize = tp->tp_psize;
+			break;
+
+		default:
+			crash("funny type constructor");
+	}
+
+	dtp->next = tp;
+	return dtp;
+}
+
+struct type *
+proc_type(parameters, n_bytes_params)
+	struct paramlist *parameters;
+	arith n_bytes_params;
+{
+	register struct type *tp = construct_type(T_PROCEDURE, NULLTYPE);
+
+	tp->prc_params = parameters;
+	tp->prc_nbpar = n_bytes_params;
+	return tp;
+}
+
+struct type *
+func_type(parameters, n_bytes_params, resulttype)
+	struct paramlist *parameters;
+	arith n_bytes_params;
+	struct type *resulttype;
+{
+	register struct type *tp = construct_type(T_FUNCTION, resulttype);
+
+	tp->prc_params = parameters;
+	tp->prc_nbpar = n_bytes_params;
+	return tp;
+}
+
+chk_type_id(ptp, nd)
+	register struct type **ptp;
+	register struct node *nd;
+{
+	*ptp = error_type;
+	if( ChkLinkOrName(nd) )	{
+		if( nd->nd_class != Def )
+			node_error(nd, "type expected");
+		else	{
+			register struct def *df = nd->nd_def;
+
+			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);
+		}
+	}
+}
+
+struct type *
+subr_type(lb, ub)
+	register struct node *lb, *ub;
+{
+	/*	Construct a subrange type from the constant expressions
+		indicated by "lb" and "ub", but first perform some checks
+	*/
+
+	register struct type *tp = lb->nd_type, *res;
+
+	if( !TstTypeEquiv(lb->nd_type, ub->nd_type) )	{
+		node_error(ub, "types of subrange bounds not equal");
+		return error_type;
+	}
+
+	/* Check base type
+	*/
+	if( !(tp->tp_fund & T_ORDINAL) )	{
+		node_error(ub, "illegal base type for subrange");
+		return error_type;
+	}
+
+	/* Check bounds
+	*/
+	if( lb->nd_INT > ub->nd_INT )
+		node_error(ub, "lower bound exceeds upper bound");
+
+	/* Now construct resulting type
+	*/
+	res = construct_type(T_SUBRANGE, tp);
+	res->sub_lb = lb->nd_INT;
+	res->sub_ub = ub->nd_INT;
+
+	return res;
+}
+
+getbounds(tp, plo, phi)
+	register struct type *tp;
+	arith *plo, *phi;
+{
+	/*	Get the bounds of a bounded type
+	*/
+
+	assert(bounded(tp));
+
+	if( tp->tp_fund & T_SUBRANGE )	{
+		*plo = tp->sub_lb;
+		*phi = tp->sub_ub;
+	}
+	else	{
+		*plo = 0;
+		*phi = tp->enm_ncst - 1;
+	}
+}
+
+struct type *
+set_type(tp, packed)
+	register struct type *tp;
+	unsigned short packed;
+{
+	/*	Construct a set type with base type "tp", but first
+		perform some checks
+	*/
+	struct type *basetype;
+	static struct type *int_set = 0;
+	arith lb, ub;
+
+	if( tp == int_type )	{
+		/* SET OF INTEGER */
+		if( !int_set )	{
+			struct node *lbn = new_node();
+			struct node *ubn = new_node();
+
+			lbn->nd_type = ubn->nd_type = int_type;
+			/* the bounds are implicit */
+			lbn->nd_INT = 0;
+			ubn->nd_INT = max_intset;
+
+			int_set = subr_type(lbn, ubn);
+		}
+		lb = 0;
+		ub = max_intset;
+		tp = int_set;
+	}
+	else	{
+		/* SET OF subrange/enumeration/char */
+		if( !bounded(tp) )	{
+			error("illegal base type of set");
+			return error_type;
+		}
+
+		basetype = BaseType(tp);
+		if( basetype == int_type )	{
+			/* subrange of integers */
+			getbounds(tp, &lb, &ub);
+			if( lb < 0 || ub > max_intset )	{
+				error("illegal integer base type of set");
+				return error_type;
+			}
+			lb = 0;
+			ub = max_intset;
+		}
+		else getbounds(basetype, &lb, &ub);
+	}
+
+	assert(lb == 0);
+	/* at this point lb and ub denote the bounds of the host-type of the
+	 * base-type of the set
+	 */
+
+	tp = construct_type(T_SET, tp);
+	tp->tp_flags |= packed;
+
+	tp->tp_psize = (ub - lb + 8) >> 3;
+	tp->tp_size = WA(tp->tp_psize);
+	tp->tp_align = word_align;
+	if( !packed || word_size % tp->tp_psize != 0 )	{
+		tp->tp_psize = tp->tp_size;
+		tp->tp_palign = word_align;
+	}
+	else tp->tp_palign = tp->tp_psize;
+
+	return tp;
+}
+
+arith
+ArrayElSize(tp, packed)
+	register struct type *tp;
+{
+	/* Align element size to alignment requirement of element type.
+	   Also make sure that its size is either a dividor of the word_size,
+	   or a multiple of it.
+	*/
+	register arith algn;
+
+	if( tp->tp_fund & T_ARRAY && !(tp->tp_flags & T_CHECKED) )
+		ArraySizes(tp);
+
+	if( !packed )
+		return tp->tp_size;
+
+	algn = align(tp->tp_psize, tp->tp_palign);
+	if( word_size % algn != 0 )	{
+		/* algn is not a dividor of the word size, so make sure it
+		   is a multiple
+		*/
+		return WA(algn);
+	}
+	return algn;
+}
+
+ArraySizes(tp)
+	register struct type *tp;
+{
+	/*	Assign sizes to an array type, and check index type
+	*/
+	register struct type *index_type = IndexType(tp);
+	register struct type *elem_type = tp->arr_elem;
+	arith lo, hi;
+
+	tp->tp_flags |= T_CHECKED;
+	tp->arr_elsize = ArrayElSize(elem_type, IsPacked(tp));
+
+	/* check index type
+	*/
+	if( !bounded(index_type) )	{
+		error("illegal index type");
+		tp->tp_psize = tp->tp_size = tp->arr_elsize;
+		tp->tp_palign = tp->tp_align = elem_type->tp_align;
+		tp->next = error_type;
+		return;
+	}
+
+	getbounds(index_type, &lo, &hi);
+
+	tp->tp_psize = (hi - lo + 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;
+
+	/* generate descriptor and remember label.
+	*/
+	tp->arr_ardescr = ++data_label;
+	C_df_dlb(data_label);
+	C_rom_cst(lo);
+	C_rom_cst(hi - lo);
+	C_rom_cst(tp->arr_elsize);
+}
+
+FreeForward(for_type)
+	register struct forwtype *for_type;
+{
+	if( !for_type ) return;
+
+	FreeForward(for_type->f_next);
+	free_node(for_type->f_node);
+	free_forwtype(for_type);
+}
+
+STATIC
+chk_forw_types()
+{
+	/* check all forward references (in pointer types) */
+
+	register struct def *df = CurrentScope->sc_def;
+	register struct def *ldf = NULLDEF;
+	struct type *tp;
+
+	while( df )	{
+		if( df->df_kind & (D_FORWTYPE | D_FTYPE) )	{
+		    register struct forwtype *fw_type = df->df_fortype;
+
+		    if( df->df_kind == D_FORWTYPE )	{
+			/* forward type not in this scope declared */
+			register struct scopelist *scl = nextvisible(CurrVis);
+			struct def *df1;
+
+			while( scl )	{
+				/* look in enclosing scopes */
+				df1 = lookup(df->df_fortype->f_node->nd_IDF,
+					     scl->sc_scope);
+				if( df1 ) break;
+				scl = nextvisible( scl );
+			}
+
+			if( !df1  || df1->df_kind != D_TYPE )
+					/* bad forward type */
+				tp = error_type;
+			else	{	/* ok */
+				tp = df1->df_type;
+
+				/* remove the def struct in the current scope */
+				if( !ldf )
+				      CurrentScope->sc_def = df->df_nextinscope;
+				else
+				      ldf->df_nextinscope = df->df_nextinscope;
+			}
+		    }
+		    else		/* forward type was resolved */
+			tp = df->df_type;
+
+		    while( fw_type )	{
+			if( tp == error_type )
+				node_error(fw_type->f_node,
+				  	   "identifier \"%s\" is not a type",
+					   df->df_idf->id_text);
+			fw_type->f_type->next = tp;
+			fw_type = fw_type->f_next;
+		    }
+
+		    FreeForward( df->df_fortype );
+		    if( tp == error_type )
+				df->df_kind = D_ERROR;
+		    else
+				df->df_kind = D_TYPE;
+		}
+		ldf = df;
+		df = df->df_nextinscope;
+	}
+}
+
+STATIC
+TstCaseConstants(nd, sel, sel1)
+	register struct node *nd;
+	register struct selector *sel, *sel1;
+{
+	/* Insert selector of nested variant (sel1) in tagvalue-table of
+	   current selector (sel).
+	*/
+	while( nd )	{
+		if( !TstCompat(nd->nd_type, sel->sel_type) )
+			node_error(nd, "type incompatibility in caselabel");
+		else if( sel->sel_ptrs )	{
+			arith i = nd->nd_INT - sel->sel_lb;
+
+			if( i < 0 || i >= sel->sel_ncst )
+				node_error(nd, "case constant: out of bounds");
+			else if( sel->sel_ptrs[i] != sel )
+				node_error(nd,
+				  "record variant: multiple defined caselabel");
+			else
+				sel->sel_ptrs[i] = sel1;
+		}
+		nd = nd->nd_next;
+	}
+}
+
+arith
+align(pos, al)
+	arith pos;
+	int al;
+{
+	arith i;
+
+	return pos + ((i = pos % al) ? al - i : 0);
+}
+
+int
+gcd(m, n)
+	register int m, n;
+{
+	/*	Greatest Common Divisor
+ 	*/
+	register int r;
+
+	while( n )	{
+		r = m % n;
+		m = n;
+		n = r;
+	}
+	return m;
+}
+
+int
+lcm(m, n)
+	int m, n;
+{
+	/*	Least Common Multiple
+ 	*/
+	return m * (n / gcd(m, n));
+}
+
+#ifdef DEBUG
+DumpType(tp)
+	register struct type *tp;
+{
+	if( !tp ) return;
+
+	print("align:%d; size:%ld;", tp->tp_align, (long) tp->tp_size);
+
+	print(" fund:");
+	switch( tp->tp_fund )	{
+	case T_ENUMERATION:
+		print("ENUMERATION; ncst:%d", tp->enm_ncst); break;
+	case T_INTEGER:
+		print("INTEGER"); break;
+	case T_REAL:
+		print("REAL"); break;
+	case T_CHAR:
+		print("CHAR"); break;
+	case T_PROCEDURE:
+	case T_FUNCTION:
+		{
+		register struct paramlist *par = ParamList(tp);
+
+		if( tp->tp_fund == T_PROCEDURE )
+			print("PROCEDURE");
+		else
+			print("FUNCTION");
+		if( par )	{
+			print("(");
+			while( par )	{
+				if( IsVarParam(par) ) print("VAR ");
+				DumpType(TypeOfParam(par));
+				par = par->next;
+			}
+		}
+		break;
+		}
+	case T_FILE:
+		print("FILE"); break;
+	case T_STRING:
+		print("STRING"); break;
+	case T_SUBRANGE:
+		print("SUBRANGE %ld-%ld", (long) tp->sub_lb, (long) tp->sub_ub);
+		break;
+	case T_SET:
+		print("SET"); break;
+	case T_ARRAY:
+		print("ARRAY");
+		print("; element:");
+		DumpType(tp->arr_elem);
+		print("; index:");
+		DumpType(tp->next);
+		print(";");
+		return;
+	case T_RECORD:
+		print("RECORD"); break;
+	case T_POINTER:
+		print("POINTER"); break;
+	default:
+		crash("DumpType");
+	}
+	if( tp->next && tp->tp_fund != T_POINTER )	{
+		/* Avoid printing recursive types!
+		*/
+		print(" next:(");
+		DumpType(tp->next);
+		print(")");
+	}
+	print(";");
+}
+#endif

lang/pc/comp/typequiv.c

@@ -0,0 +1,291 @@
+/* T Y P E   E Q U I V A L E N C E */
+
+/*	Routines for testing type equivalence & type compatibility.
+*/
+
+#include	"debug.h"
+
+#include	<assert.h>
+#include	<em_arith.h>
+#include	<em_label.h>
+
+#include	"LLlex.h"
+#include	"def.h"
+#include	"node.h"
+#include	"type.h"
+
+
+int
+TstTypeEquiv(tp1, tp2)
+	register struct type *tp1, *tp2;
+{
+	/*	test if two types are equivalent.
+	*/
+
+	return tp1 == tp2 || tp1 == error_type || tp2 == error_type;
+}
+
+arith
+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( IsConformantArray(tp) ) return 0;
+
+	if( tp->tp_fund & T_ARRAY && IsPacked(tp) &&
+					tp->arr_elem == char_type )	{
+		arith lb, ub;
+
+		if( BaseType(IndexType(tp)) != int_type ) return 0;
+		getbounds(IndexType(tp), &lb, &ub);
+		return (lb == 1 && ub > 1) ? ub : (arith) 0;
+	}
+	return (arith) 0;
+}
+
+int
+TstStrCompat(tp1, tp2)
+	register struct type *tp1, *tp2;
+{
+	/*	test if two types are compatible string-types.
+	*/
+
+	arith ub1, ub2;
+
+	ub1 = IsString(tp1);
+	ub2 = IsString(tp2);
+
+	if( !ub1 || !ub2 ) return 0;
+	else
+		return ub1 == ub2;
+}
+
+int
+TstCompat(tp1, tp2)
+	register struct type *tp1, *tp2;
+{
+	/*	test if two types are compatible. ISO 6.4.5
+	*/
+
+	/* clause a */
+	if( TstTypeEquiv(tp1, tp2) ) return 1;
+
+	/* clause d */
+	if( TstStrCompat(tp1, tp2) ) return 1;
+
+	/* type of NIL is compatible with every pointertype */
+	if( tp1->tp_fund & T_POINTER && tp2->tp_fund & T_POINTER )
+		return tp1 == tp2 || tp1 == nil_type || tp2 == nil_type;
+
+	/* clause c */
+	/* if both types are sets then both must be packed or not */
+	if( tp1->tp_fund & T_SET && tp2->tp_fund & T_SET )	{
+		if( tp1 == emptyset_type || tp2 == emptyset_type )
+			return 1;
+		if( IsPacked(tp1) != IsPacked(tp2) )
+			return 0;
+		if( TstCompat(ElementType(tp1), ElementType(tp2)) )	{
+			if( ElementType(tp1) != ElementType(tp2) )
+				warning("base-types of sets not equal");
+			return 1;
+		}
+		else return 0;
+	}
+
+	/* clause b */
+	tp1 = BaseType(tp1);
+	tp2 = BaseType(tp2);
+
+	return tp1 == tp2;
+}
+
+int
+TstAssCompat(tp1, tp2)
+	register struct type *tp1, *tp2;
+{
+	/*	test if two types are assignment compatible. ISO 6.4.6
+	*/
+
+	/* clauses a, c, d and e */
+	if( TstCompat(tp1, tp2) )
+		return !(tp1->tp_flags & T_HASFILE);
+
+	/* clause b */
+	if( tp1 == real_type )
+		return BaseType(tp2) == int_type;
+
+	return 0;
+}
+
+int
+TstParEquiv(tp1, tp2)
+	register struct type *tp1, *tp2;
+{
+	/*	Test if two parameter types are equivalent.  ISO 6.6.3.6
+	*/
+	
+	return
+		   TstTypeEquiv(tp1, tp2)
+		||
+		   (
+		     IsConformantArray(tp1)
+		   &&
+		     IsConformantArray(tp2)
+		   &&
+		     IsPacked(tp1) == IsPacked(tp2)
+		   &&
+		     TstParEquiv(tp1->arr_elem, tp2->arr_elem)
+		   )
+		||
+		   (
+		     (
+		      tp1->tp_fund == T_PROCEDURE && tp2->tp_fund == T_PROCEDURE
+		     ||
+		      tp1->tp_fund == T_FUNCTION && tp2->tp_fund == T_FUNCTION
+		     )
+		   &&
+		     TstProcEquiv(tp1, tp2)
+		   );
+}
+
+int
+TstProcEquiv(tp1, tp2)
+	register struct type *tp1, *tp2;
+{
+	/*	Test if two procedure types are equivalent. ISO 6.6.3.6
+	*/
+	register struct paramlist *p1, *p2;
+
+	/* First check if the result types are equivalent
+	*/
+	if( !TstTypeEquiv(ResultType(tp1), ResultType(tp2)) )
+		return 0;
+
+	p1 = ParamList(tp1);
+	p2 = ParamList(tp2);
+
+	/* Now check the parameters
+	*/
+	while( p1 && p2 )	{
+		if( IsVarParam(p1) != IsVarParam(p2) ||
+		    !TstParEquiv(TypeOfParam(p1), TypeOfParam(p2)) ) return 0;
+		p1 = p1->next;
+		p2 = p2->next;
+	}
+
+	/* Here, at least one of the parameterlists is exhausted.
+	   Check that they are both.
+	*/
+	return p1 == p2;
+}
+
+int
+TstParCompat(formaltype, actualtype, VARflag, nd, new_par_section)
+	register struct type *formaltype, *actualtype;
+	struct node *nd;
+{
+	/*	Check type compatibility for a parameter in a procedure call.
+	*/
+
+	if(
+		TstTypeEquiv(formaltype, actualtype)
+	    ||
+		( !VARflag && TstAssCompat(formaltype, actualtype) )
+	    ||
+		(  formaltype->tp_fund == T_FUNCTION
+		 &&
+		   actualtype->tp_fund == T_FUNCTION
+		 &&
+		   TstProcEquiv(formaltype, actualtype)
+		)
+	    ||
+		(  formaltype->tp_fund == T_PROCEDURE
+		 &&
+		   actualtype->tp_fund == T_PROCEDURE
+		 &&
+		   TstProcEquiv(formaltype, actualtype)
+		)
+	    ||
+		(  IsConformantArray(formaltype)
+		&&
+		   TstConform(formaltype, actualtype, new_par_section)
+		)
+	) {
+		if( !VARflag && IsConformantArray(actualtype) )	{
+			node_warning(nd,
+				"conformant array used as value parameter");
+		}
+		return 1;
+	}
+	else return 0;
+}
+
+int
+TstConform(formaltype, actualtype, new_par_section)
+	register struct type *formaltype, *actualtype;
+{
+	/*	Check conformability.
+		
+		DEVIATION FROM STANDARD (ISO 6.6.3.7.2):
+		Allow with value parameters also conformant arrays as actual
+		type.(ISO only with var. parameters)
+
+		Do as much checking on indextypes as possible.
+	*/
+
+	struct type *formalindextp, *actualindextp;
+	arith flb, fub, alb, aub;
+	static struct type *lastactual;
+
+	if( !new_par_section )
+		/* actualparameters of one conformant-array-specification
+		   must be equal
+		*/
+		return TstTypeEquiv(actualtype, lastactual);
+
+	lastactual = actualtype;
+
+	if( actualtype->tp_fund == T_STRING )	{
+		actualindextp = int_type;
+		alb = 1;
+		aub = actualtype->tp_psize;
+	}
+	else if( actualtype->tp_fund == T_ARRAY )	{
+		actualindextp = IndexType(actualtype);
+		if( bounded(actualindextp) )
+			getbounds(actualindextp, &alb, &aub);
+	}
+	else
+		return 0;
+
+	/* clause (d) */
+	if( IsPacked(actualtype) != IsPacked(formaltype) )
+		return 0;
+
+	formalindextp = IndexType(formaltype);
+
+	/* clause (a) */
+	if( !TstCompat(actualindextp, formalindextp) )
+		return 0;
+
+	/* clause (b) */
+	if( bounded(actualindextp) || actualindextp->tp_fund == T_STRING ) {
+		/* test was necessary because the actual type could be confor-
+		   mant !!
+		*/
+		if( bounded(formalindextp) )	{
+			getbounds(formalindextp, &flb, &fub);
+			if( alb < flb || aub > fub )
+				return 0;
+		}
+	}
+
+	/* clause (c) */
+	if( !IsConformantArray(formaltype->arr_elem) )
+		return TstTypeEquiv(actualtype->arr_elem, formaltype->arr_elem);
+	else
+		return TstConform(formaltype->arr_elem, actualtype->arr_elem,
+							       new_par_section);
+}