--- /dev/null
+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
--- /dev/null
+/* 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 = ˙
+ 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*/
+}
--- /dev/null
+/* 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
--- /dev/null
+/* 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 = ˙
+
+ 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));
+}
--- /dev/null
+# 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
--- /dev/null
+!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
--- /dev/null
+#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);
+}
--- /dev/null
+/* 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);
+}
--- /dev/null
+#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,
+};
--- /dev/null
+% 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};
--- /dev/null
+/* E X P R E S S I O N C H E C K I N G */
+
+/* Check expressions, and try to evaluate them as far as possible.
+*/
+
+#include "debug.h"
+
+#include <alloc.h>
+#include <assert.h>
+#include <em_arith.h>
+#include <em_label.h>
+
+#include "LLlex.h"
+#include "Lpars.h"
+#include "chk_expr.h"
+#include "const.h"
+#include "def.h"
+#include "idf.h"
+#include "main.h"
+#include "misc.h"
+#include "node.h"
+#include "required.h"
+#include "scope.h"
+#include "type.h"
+
+extern char *symbol2str();
+
+STATIC
+Xerror(nd, mess)
+ register struct node *nd;
+ char *mess;
+{
+ if( nd->nd_class == Def && nd->nd_def ) {
+ if( nd->nd_def->df_kind != D_ERROR )
+ node_error(nd,"\"%s\": %s",
+ nd->nd_def->df_idf->id_text, mess);
+ }
+ else node_error(nd, "%s", mess);
+}
+
+STATIC int
+ChkConstant(expp)
+ register struct node *expp;
+{
+ register struct node *nd;
+
+ if( !(nd = expp->nd_right) ) nd = expp;
+
+ if( nd->nd_class == Name && !ChkLinkOrName(nd) ) return 0;
+
+ if( nd->nd_class != Value || expp->nd_left ) {
+ Xerror(nd, "constant expected");
+ return 0;
+ }
+
+ if( expp->nd_class == Uoper )
+ return ChkUnOper(expp);
+ else if( nd != expp ) {
+ Xerror(expp, "constant expected");
+ return 0;
+ }
+ return 1;
+}
+
+int
+ChkVariable(expp)
+ register struct node *expp;
+{
+ /* Check that "expp" indicates an item that can be accessed */
+
+ if( !ChkLhs(expp) ) return 0;
+
+ if( expp->nd_class == Def && expp->nd_def->df_kind == D_FUNCTION ) {
+ Xerror(expp, "illegal use of function name");
+ return 0;
+ }
+ return 1;
+}
+
+int
+ChkLhs(expp)
+ register struct node *expp;
+{
+ int class;
+
+ /* Check that "expp" indicates an item that can be the lhs
+ of an assignment.
+ */
+ if( !ChkVarAccess(expp) ) return 0;
+
+ class = expp->nd_class;
+ /* a constant is replaced by it's value in ChkLinkOrName, check here !,
+ * the remaining classes are checked by ChkVarAccess
+ */
+ if( class == Value ) {
+ node_error(expp, "can't access a value");
+ return 0;
+ }
+
+ if( class == Def &&
+ !(expp->nd_def->df_kind & (D_FIELD | D_FUNCTION | D_VARIABLE)) ) {
+ Xerror(expp, "variable expected");
+ return 0;
+ }
+
+ /* assignment to function name */
+ if( class == Def && expp->nd_def->df_kind == D_FUNCTION )
+ if( expp->nd_def->prc_res )
+ expp->nd_type = ResultType(expp->nd_def->df_type);
+ else {
+ Xerror(expp, "illegal assignment to function-name");
+ return 0;
+ }
+
+ return 1;
+}
+
+#ifdef DEBUG
+STATIC int
+ChkValue(expp)
+ register struct node *expp;
+{
+ switch( expp->nd_symb ) {
+ case INTEGER:
+ case REAL:
+ case STRING:
+ case NIL:
+ return 1;
+
+ default:
+ crash("(ChkValue)");
+ }
+ /*NOTREACHED*/
+}
+#endif
+
+STATIC int
+ChkLinkOrName(expp)
+ register struct node *expp;
+{
+ register struct def *df;
+
+ expp->nd_type = error_type;
+
+ if( expp->nd_class == Name ) {
+ expp->nd_def = lookfor(expp, CurrVis, 1);
+ expp->nd_class = Def;
+ expp->nd_type = expp->nd_def->df_type;
+ }
+ else if( expp->nd_class == Link ) {
+ /* a selection from a record */
+ register struct node *left = expp->nd_left;
+
+ assert(expp->nd_symb == '.');
+
+ if( !ChkVariable(left) ) return 0;
+
+ if( left->nd_type->tp_fund != T_RECORD ) {
+ Xerror(left, "illegal selection");
+ return 0;
+ }
+
+ if( !(df = lookup(expp->nd_IDF, left->nd_type->rec_scope)) ) {
+ id_not_declared(expp);
+ return 0;
+ }
+ else {
+ expp->nd_def = df;
+ expp->nd_type = df->df_type;
+ expp->nd_class = LinkDef;
+ }
+ return 1;
+ }
+ assert(expp->nd_class == Def);
+
+ df = expp->nd_def;
+
+ if( df->df_kind & (D_ENUM | D_CONST) ) {
+ /* Replace an enum-literal or a CONST identifier by its value.
+ */
+ if( df->df_kind == D_ENUM ) {
+ expp->nd_class = Value;
+ expp->nd_INT = df->enm_val;
+ expp->nd_symb = INTEGER;
+ }
+ else {
+ unsigned int ln = expp->nd_lineno;
+
+ assert(df->df_kind == D_CONST);
+ *expp = *(df->con_const);
+ expp->nd_lineno = ln;
+ }
+ }
+ return df->df_kind != D_ERROR;
+}
+
+STATIC int
+ChkExLinkOrName(expp)
+ register struct node *expp;
+{
+ if( !ChkLinkOrName(expp) ) return 0;
+ if( expp->nd_class != Def ) return 1;
+
+ if( !(expp->nd_def->df_kind & D_VALUE) )
+ Xerror(expp, "value expected");
+
+ return 1;
+}
+
+STATIC int
+ChkUnOper(expp)
+ register struct node *expp;
+{
+ /* Check an unary operation.
+ */
+ register struct node *right = expp->nd_right;
+ register struct type *tpr;
+
+ if( !ChkExpression(right) ) return 0;
+
+ expp->nd_type = tpr = BaseType(right->nd_type);
+
+ switch( expp->nd_symb ) {
+ case '+':
+ if( tpr->tp_fund & T_NUMERIC ) {
+ *expp = *right;
+ free_node(right);
+ return 1;
+ }
+ break;
+
+ case '-':
+ if( tpr->tp_fund == T_INTEGER ) {
+ if( right->nd_class == Value )
+ cstunary(expp);
+ return 1;
+ }
+ if( tpr->tp_fund == T_REAL ) {
+ if( right->nd_class == Value ) {
+ expp->nd_token.tk_data.tk_real = right->nd_RIV;
+ expp->nd_class = Value;
+ expp->nd_symb = REAL;
+ FreeNode(right);
+ expp->nd_right = NULLNODE;
+ }
+ return 1;
+ }
+ break;
+
+ case NOT:
+ if( tpr == bool_type ) {
+ if( right->nd_class == Value )
+ cstunary(expp);
+ return 1;
+ }
+ break;
+
+ case '(':
+ return 1;
+
+ default:
+ crash("(ChkUnOper)");
+ }
+ node_error(expp, "\"%s\": illegal operand", symbol2str(expp->nd_symb));
+ return 0;
+}
+
+STATIC struct type *
+ResultOfOperation(operator, tpl, tpr)
+ struct type *tpl, *tpr;
+{
+ /* Return the result type of the binary operation "operator",
+ with operand types "tpl" and "tpr".
+ */
+
+ switch( operator ) {
+ case '=' :
+ case NOTEQUAL :
+ case '<' :
+ case '>' :
+ case LESSEQUAL :
+ case GREATEREQUAL:
+ case IN :
+ return bool_type;
+ case '+' :
+ case '-' :
+ case '*' :
+ if( tpl == real_type || tpr == real_type )
+ return real_type;
+ return tpl;
+ case '/' :
+ return real_type;
+ }
+ return tpl;
+}
+
+STATIC int
+AllowedTypes(operator)
+{
+ /* Return a bit mask indicating the allowed operand types for
+ binary operator "operator".
+ */
+
+ switch( operator ) {
+ case '+' :
+ case '-' :
+ case '*' :
+ return T_NUMERIC | T_SET;
+ case '/' :
+ return T_NUMERIC;
+ case DIV :
+ case MOD :
+ return T_INTEGER;
+ case OR :
+ case AND :
+ return T_ENUMERATION;
+ case '=' :
+ case NOTEQUAL :
+ return T_ENUMERATION | T_CHAR | T_NUMERIC |
+ T_SET | T_POINTER | T_STRING;
+ case LESSEQUAL :
+ case GREATEREQUAL:
+ return T_ENUMERATION | T_CHAR | T_NUMERIC |
+ T_SET | T_STRING;
+ case '<' :
+ case '>' :
+ return T_ENUMERATION | T_CHAR | T_NUMERIC |
+ T_STRING;
+ default :
+ crash("(AllowedTypes)");
+ }
+ /*NOTREACHED*/
+}
+
+STATIC int
+Boolean(operator)
+{
+ return operator == OR || operator == AND;
+}
+
+STATIC int
+ChkBinOper(expp)
+ register struct node *expp;
+{
+ /* Check a binary operation.
+ */
+ register struct node *left, *right;
+ struct type *tpl, *tpr;
+ int retval, allowed;
+
+ left = expp->nd_left;
+ right = expp->nd_right;
+
+ retval = ChkExpression(left) & ChkExpression(right);
+
+ tpl = BaseType(left->nd_type);
+ tpr = BaseType(right->nd_type);
+
+ expp->nd_type = ResultOfOperation(expp->nd_symb, tpl ,tpr);
+
+ /* Check that the application of the operator is allowed on the type
+ of the operands.
+ There are some needles and pins:
+ - Boolean operators are only allowed on boolean operands, but the
+ "allowed-mask" of "AllowedTyped" can only indicate an enumeration
+ type.
+ - The IN-operator has as right-hand-side operand a set.
+ - Strings and packed arrays can be equivalent.
+ - In some cases, integers must be converted to reals.
+ - If one of the operands is the empty set then the result doesn't
+ have to be the empty set.
+ */
+
+ if( expp->nd_symb == IN ) {
+ if( tpr->tp_fund != T_SET ) {
+ node_error(expp, "\"IN\": right operand must be a set");
+ return 0;
+ }
+ if( !TstAssCompat(tpl, ElementType(tpr)) ) {
+ node_error(expp, "\"IN\": incompatible types");
+ return 0;
+ }
+ if( left->nd_class == Value && right->nd_class == Set )
+ cstset(expp);
+ return retval;
+ }
+
+ if( !retval ) return 0;
+
+ allowed = AllowedTypes(expp->nd_symb);
+
+ if( !(tpr->tp_fund & allowed) || !(tpl->tp_fund & allowed) ) {
+ arith ub;
+ extern arith IsString();
+
+ if( allowed & T_STRING && (ub = IsString(tpl)) )
+ if( ub == IsString(tpr) )
+ return 1;
+ else {
+ node_error(expp, "\"%s\": incompatible types",
+ symbol2str(expp->nd_symb));
+ return 0;
+ }
+ node_error(expp, "\"%s\": illegal operand type(s)",
+ symbol2str(expp->nd_symb));
+ return 0;
+ }
+
+ if( Boolean(expp->nd_symb) && tpl != bool_type ) {
+ node_error(expp, "\"%s\": illegal operand type(s)",
+ symbol2str(expp->nd_symb));
+ return 0;
+ }
+
+ if( allowed & T_NUMERIC ) {
+ if( tpl == int_type &&
+ (tpr == real_type || expp->nd_symb == '/') ) {
+ expp->nd_left =
+ MkNode(Cast, NULLNODE, expp->nd_left, &dot);
+ expp->nd_left->nd_type = tpl = real_type;
+ }
+ if( tpl == real_type && tpr == int_type ) {
+ expp->nd_right =
+ MkNode(Cast, NULLNODE, expp->nd_right, &dot);
+ expp->nd_right->nd_type = tpr = real_type;
+ }
+ }
+
+ /* Operands must be compatible */
+ if( !TstCompat(tpl, tpr) ) {
+ node_error(expp, "\"%s\": incompatible types",
+ symbol2str(expp->nd_symb));
+ return 0;
+ }
+
+ if( tpl->tp_fund & T_SET ) {
+ if( tpl == emptyset_type )
+ left->nd_type = tpr;
+ else if( tpr == emptyset_type )
+ right->nd_type = tpl;
+
+ if( expp->nd_type == emptyset_type )
+ expp->nd_type = tpr;
+ if( left->nd_class == Set && right->nd_class == Set )
+ cstset(expp);
+ }
+ else if( tpl->tp_fund != T_REAL &&
+ left->nd_class == Value && right->nd_class == Value )
+ cstbin(expp);
+
+ return 1;
+}
+
+STATIC int
+ChkElement(expp, tp, set, cnt)
+ register struct node *expp;
+ register struct type **tp;
+ arith **set;
+ unsigned *cnt;
+{
+ /* Check elements of a set. This routine may call itself
+ recursively. Also try to compute the set!
+ */
+ register struct node *left = expp->nd_left;
+ register struct node *right = expp->nd_right;
+ register int i;
+ extern char *Malloc();
+
+ if( expp->nd_class == Link && expp->nd_symb == UPTO ) {
+ /* [ ... , expr1 .. expr2, ... ]
+ First check expr1 and expr2, and try to compute them.
+ */
+ if( !ChkElement(left, tp, set, cnt) ||
+ !ChkElement(right, tp, set, cnt) )
+ return 0;
+
+ if( left->nd_class == Value &&
+ right->nd_class == Value && *set ) {
+
+ if( left->nd_INT > right->nd_INT ) {
+ /* Remove lower and upper bound of the range.
+ */
+ *cnt -= 2;
+ (*set)[left->nd_INT/wrd_bits] &=
+ ~(1 << (left->nd_INT%wrd_bits));
+ (*set)[right->nd_INT/wrd_bits] &=
+ ~(1 << (right->nd_INT%wrd_bits));
+ }
+ else
+ /* We have a constant range. Put all elements
+ in the set.
+ */
+ for( i = left->nd_INT + 1; i < right->nd_INT; i++ )
+ (*set)[i/wrd_bits] |= ( 1 << (i%wrd_bits) );
+ }
+ return 1;
+ }
+
+ /* Here, a single element is checked
+ */
+ if( !ChkExpression(expp) ) return 0;
+
+ if( *tp == emptyset_type ) {
+ /* first element in set determines the type of the set */
+ unsigned size;
+
+ *tp = set_type(expp->nd_type, 0);
+ size = (*tp)->tp_size * (sizeof(arith) / word_size);
+ *set = (arith *) Malloc(size);
+ clear((char *) *set, size);
+ }
+ else if( !TstCompat(ElementType(*tp), expp->nd_type) ) {
+ node_error(expp, "set element has incompatible type");
+ return 0;
+ }
+
+ if( expp->nd_class == Value ) {
+ /* a constant element
+ */
+ i = expp->nd_INT;
+
+ if( expp->nd_type == int_type ) {
+ /* Check only integer base-types because they are not
+ equal to the integer host-type. The other base-types
+ are equal to their host-types.
+ */
+
+ if( i < 0 || i > max_intset ) {
+ node_error(expp, "set element out of range");
+ return 0;
+ }
+ }
+
+ if( *set ) (*set)[i/wrd_bits] |= ( 1 << (i%wrd_bits));
+ (*cnt)++;
+ }
+ else if( *set ) {
+ free((char *) *set);
+ *set = (arith *) 0;
+ }
+
+ return 1;
+}
+
+STATIC int
+ChkSet(expp)
+ register struct node *expp;
+{
+ /* Check the legality of a SET aggregate, and try to evaluate it
+ compile time. Unfortunately this is all rather complicated.
+ */
+ register struct node *nd = expp->nd_right;
+ arith *set = (arith *) 0;
+ unsigned cnt = 0;
+
+ assert(expp->nd_symb == SET);
+
+ expp->nd_type = emptyset_type;
+
+ /* Now check the elements given, and try to compute a constant set.
+ First allocate room for the set, but only if it isn't empty.
+ */
+ if( !nd ) {
+ /* The resulting set IS empty, so we just return
+ */
+ expp->nd_class = Set;
+ expp->nd_set = (arith *) 0;
+ return 1;
+ }
+
+ /* Now check the elements, one by one
+ */
+ while( nd ) {
+ assert(nd->nd_class == Link && nd->nd_symb == ',');
+
+ if( !ChkElement(nd->nd_left, &(expp->nd_type), &set, &cnt) )
+ return 0;
+ nd = nd->nd_right;
+ }
+
+ if( set ) {
+ /* Yes, it was a constant set, and we managed to compute it!
+ Notice that at the moment there is no such thing as
+ partial evaluation. Either we evaluate the set, or we
+ don't (at all). Improvement not neccesary (???)
+ ??? sets have a contant part and a variable part ???
+ */
+ expp->nd_class = Set;
+ if( !cnt ) {
+ /* after all the work we've done, the set turned out
+ out to be empty!
+ */
+ free(set);
+ set = (arith *) 0;
+ }
+ expp->nd_set = set;
+ FreeNode(expp->nd_right);
+ expp->nd_right = NULLNODE;
+ }
+
+ return 1;
+}
+
+ChkVarPar(nd, name)
+ register struct node *nd, *name;
+{
+ /* ISO 6.6.3.3 :
+ An actual variable parameter shall not denote a field
+ that is the selector of a variant-part or a component
+ of a variable where that variable possesses a type
+ that is designated packed.
+ */
+ static char var_mes[] = "can't be a variable parameter";
+ static char err_mes[64];
+ char *message = (char *) 0;
+ extern char *sprint();
+
+ if( !ChkVariable(nd) ) return 0;
+
+ switch( nd->nd_class ) {
+ case Def:
+ if( nd->nd_def->df_kind != D_FIELD ) break;
+ /* FALL THROUGH */
+
+ case LinkDef:
+ assert(nd->nd_def->df_kind == D_FIELD);
+
+ if( nd->nd_def->fld_flags & F_PACKED )
+ message = "field of packed record %s";
+ else if( nd->nd_def->fld_flags & F_SELECTOR )
+ message = "variant selector %s";
+ break;
+
+ case Arrsel:
+ if( IsPacked(nd->nd_left->nd_type) )
+ message = "component of packed array %s";
+ break;
+
+ case Arrow:
+ if( nd->nd_right->nd_type->tp_fund == T_FILE )
+ message = "filebuffer variable %s";
+ break;
+
+ default:
+ crash("(ChkVarPar)");
+ /*NOTREACHED*/
+ }
+ if( message ) {
+ sprint(err_mes, message, var_mes);
+ Xerror(name, err_mes);
+ return 0;
+ }
+ return 1;
+}
+
+STATIC struct node *
+getarg(argp, bases, varaccess, name, paramtp)
+ struct node **argp, *name;
+ struct type *paramtp;
+{
+ /* This routine is used to fetch the next argument from an
+ argument list. The argument list is indicated by "argp".
+ The parameter "bases" is a bitset indicating which types are
+ allowed at this point, and "varaccess" is a flag indicating
+ that the address from this argument is taken, so that it
+ must be a varaccess and may not be a register variable.
+ */
+ register struct node *arg = (*argp)->nd_right;
+ register struct node *left;
+
+ if( !arg ) {
+ Xerror(name, "too few arguments supplied");
+ return 0;
+ }
+
+ left = arg->nd_left;
+ *argp = arg;
+
+ if( paramtp && paramtp->tp_fund & T_ROUTINE ) {
+ /* From the context it appears that the occurrence of the
+ procedure/function-identifier is not a call.
+ */
+ if( left->nd_class != NameOrCall ) {
+ Xerror(name, "illegal proc/func parameter");
+ return 0;
+ }
+ else if( ChkLinkOrName(left->nd_left) )
+ left->nd_type = left->nd_left->nd_type;
+
+ else return 0;
+ }
+ else if( varaccess ? !ChkVarPar(left, name) : !ChkExpression(left) )
+ return 0;
+
+ if( bases && !(BaseType(left->nd_type)->tp_fund & bases) ) {
+ Xerror(name, "unexpected parameter type");
+ return 0;
+ }
+
+ return left;
+}
+
+STATIC int
+ChkProcCall(expp)
+ struct node *expp;
+{
+ /* Check a procedure call
+ */
+ register struct node *left;
+ struct node *name;
+ register struct paramlist *param;
+ char ebuf[64];
+ int retval = 1;
+ int cnt = 0;
+ int new_par_section;
+ struct type *lasttp = NULLTYPE;
+
+ name = left = expp->nd_left;
+
+ if( left->nd_type == error_type ) {
+ /* Just check parameters as if they were value parameters
+ */
+ expp->nd_type = error_type;
+ while( expp->nd_right )
+ (void) getarg(&expp, 0, 0, name, NULLTYPE);
+ return 0;
+ }
+
+ expp->nd_type = ResultType(left->nd_type);
+
+ /* Check parameter list
+ */
+ for( param = ParamList(left->nd_type); param; param = param->next ) {
+ if( !(left = getarg(&expp, 0, IsVarParam(param), name,
+ TypeOfParam(param))) )
+ return 0;
+
+ cnt++;
+
+ new_par_section = lasttp != TypeOfParam(param);
+ if( !TstParCompat(TypeOfParam(param), left->nd_type,
+ IsVarParam(param), left, new_par_section) ) {
+ sprint(ebuf, "type incompatibility in parameter %d",
+ cnt);
+ Xerror(name, ebuf);
+ retval = 0;
+ }
+ if( left->nd_type == emptyset_type )
+ /* type of emptyset determined by the context */
+ left->nd_type = TypeOfParam(param);
+
+ lasttp = TypeOfParam(param);
+ }
+
+ if( expp->nd_right ) {
+ Xerror(name, "too many arguments supplied");
+ while( expp->nd_right )
+ (void) getarg(&expp, 0, 0, name, NULLTYPE);
+ return 0;
+ }
+
+ return retval;
+}
+
+int
+ChkCall(expp)
+ register struct node *expp;
+{
+ /* Check something that looks like a procedure or function call.
+ Of course this does not have to be a call at all,
+ it may also be a standard procedure call.
+ */
+
+ /* First, get the name of the function or procedure
+ */
+ register struct node *left = expp->nd_left;
+ STATIC int ChkStandard();
+
+ expp->nd_type = error_type;
+
+ if( ChkLinkOrName(left) ) {
+
+ if( IsProcCall(left) || left->nd_type == error_type ) {
+ /* A call.
+ It may also be a call to a standard procedure
+ */
+
+ if( left->nd_type == std_type )
+ /* A standard procedure
+ */
+ return ChkStandard(expp, left);
+
+ /* Here, we have found a real procedure call.
+ */
+ }
+ else {
+ node_error(left, "procedure or function expected");
+ return 0;
+ }
+ }
+ return ChkProcCall(expp);
+}
+
+STATIC int
+ChkExCall(expp)
+ register struct node *expp;
+{
+ if( !ChkCall(expp) ) return 0;
+
+ if( !expp->nd_type ) {
+ node_error(expp, "function call expected");
+ return 0;
+ }
+ return 1;
+}
+
+STATIC int
+ChkNameOrCall(expp)
+ register struct node *expp;
+{
+ /* From the context it appears that the occurrence of the function-
+ identifier is a call to that function
+ */
+ assert(expp->nd_class == NameOrCall);
+ expp->nd_class = Call;
+
+ return ChkExCall(expp);
+}
+
+STATIC int
+ChkStandard(expp,left)
+ register struct node *expp, *left;
+{
+ /* Check a call of a standard procedure or function
+ */
+
+ struct node *arg = expp;
+ struct node *name = left;
+ int req;
+
+ assert(left->nd_class == Def);
+
+ req = left->nd_def->df_value.df_reqname;
+
+ switch( req ) {
+ case R_ABS:
+ case R_SQR:
+ if( !(left = getarg(&arg, T_NUMERIC, 0, name, NULLTYPE)) )
+ return 0;
+ expp->nd_type = left->nd_type;
+ if( left->nd_class == Value &&
+ expp->nd_type->tp_fund != T_REAL )
+ cstcall(expp, req);
+ break;
+
+ case R_SIN:
+ case R_COS:
+ case R_EXP:
+ case R_LN:
+ case R_SQRT:
+ case R_ARCTAN:
+ if( !(left = getarg(&arg, T_NUMERIC, 0, name, NULLTYPE)) )
+ return 0;
+ expp->nd_type = real_type;
+ if( BaseType(left->nd_type)->tp_fund == T_INTEGER ) {
+ arg->nd_left = MkNode(Cast,NULLNODE, arg->nd_left,&dot);
+ arg->nd_left->nd_type = real_type;
+ }
+ break;
+
+ case R_TRUNC:
+ case R_ROUND:
+ if( !(left = getarg(&arg, T_REAL, 0, name, NULLTYPE)) )
+ return 0;
+ expp->nd_type = int_type;
+ break;
+
+ case R_ORD:
+ if( !(left = getarg(&arg, T_ORDINAL, 0, name, NULLTYPE)) )
+ return 0;
+ expp->nd_type = int_type;
+ if( left->nd_class == Value )
+ cstcall(expp, R_ORD);
+ break;
+
+ case R_CHR:
+ if( !(left = getarg(&arg, T_INTEGER, 0, name, NULLTYPE)) )
+ return 0;
+ expp->nd_type = char_type;
+ if( left->nd_class == Value )
+ cstcall(expp, R_CHR);
+ break;
+
+ case R_SUCC:
+ case R_PRED:
+ if( !(left = getarg(&arg, T_ORDINAL, 0, name, NULLTYPE)) )
+ return 0;
+ expp->nd_type = left->nd_type;
+ if( left->nd_class == Value && !options['r'] )
+ cstcall(expp, req);
+ break;
+
+ case R_ODD:
+ if( !(left = getarg(&arg, T_INTEGER, 0, name, NULLTYPE)) )
+ return 0;
+ expp->nd_type = bool_type;
+ if( left->nd_class == Value )
+ cstcall(expp, R_ODD);
+ break;
+
+ case R_EOF:
+ case R_EOLN:
+ case R_PAGE: {
+ int st_out;
+
+ if( req == R_PAGE ) {
+ expp->nd_type = NULLTYPE;
+ st_out = 1;
+ }
+ else {
+ expp->nd_type = bool_type;
+ st_out = 0;
+ }
+ if( !arg->nd_right ) {
+ struct node *nd;
+
+ if( !(nd = ChkStdInOut(name, st_out)) )
+ return 0;
+
+ expp->nd_right = MkNode(Link, nd, NULLNODE, &dot);
+ expp->nd_right->nd_symb = ',';
+ arg = arg->nd_right;
+ }
+ else {
+ if( !(left = getarg(&arg, T_FILE, 1, name, NULLTYPE)) )
+ return 0;
+ if( req != R_EOF && left->nd_type != text_type ) {
+ Xerror(name, "textfile expected");
+ return 0;
+ }
+ }
+ break;
+
+ }
+ case R_REWRITE:
+ case R_PUT:
+ case R_RESET:
+ case R_GET:
+ if( !(left = getarg(&arg, T_FILE, 1, name, NULLTYPE)) )
+ return 0;
+ expp->nd_type = NULLTYPE;
+ break;
+
+ case R_PACK:
+ case R_UNPACK: {
+ struct type *tp1, *tp2, *tp3;
+
+ if( req == R_PACK ) {
+ /* pack(a, i, z) */
+ if( !(left = getarg(&arg, T_ARRAY, 1, name, NULLTYPE)) )
+ return 0;
+ tp1 = left->nd_type; /* (a) */
+ if( !(left = getarg(&arg, 0, 0, name, NULLTYPE)) )
+ return 0;
+ tp2 = left->nd_type; /* (i) */
+ if( !(left = getarg(&arg, T_ARRAY, 1, name, NULLTYPE)) )
+ return 0;
+ tp3 = left->nd_type; /* (z) */
+ }
+ else {
+ /* unpack(z, a, i) */
+ if( !(left = getarg(&arg, T_ARRAY, 1, name, NULLTYPE)) )
+ return 0;
+ tp3 = left->nd_type; /* (z) */
+ if( !(left = getarg(&arg, T_ARRAY, 1, name, NULLTYPE)) )
+ return 0;
+ tp1 = left->nd_type; /* (a) */
+ if( !(left = getarg(&arg, 0, 0, name, NULLTYPE)) )
+ return 0;
+ tp2 = left->nd_type; /* (i) */
+ }
+ if( IsConformantArray(tp1) || IsPacked(tp1) ) {
+ Xerror(name, "unpacked array expected");
+ return 0;
+ }
+ if( !TstAssCompat(IndexType(tp1), tp2) ) {
+ Xerror(name, "ordinal constant expected");
+ return 0;
+ }
+ if( IsConformantArray(tp3) || !IsPacked(tp3) ) {
+ Xerror(name, "packed array expected");
+ return 0;
+ }
+ if( !TstTypeEquiv(tp1->arr_elem, tp3->arr_elem) ) {
+ Xerror(name, "component types of arrays not equal");
+ return 0;
+ }
+ expp->nd_type = NULLTYPE;
+ break;
+ }
+
+ case R_NEW:
+ case R_DISPOSE:
+ if( !(left = getarg(&arg, T_POINTER, 1, name, NULLTYPE)) )
+ return 0;
+ if( arg->nd_right ) {
+ /* varargs new/dispose(p,c1,.....) */
+ register struct selector *sel;
+ register arith i;
+
+ if( PointedtoType(left->nd_type)->tp_fund != T_RECORD )
+ break;
+ sel = PointedtoType(left->nd_type)->rec_sel;
+ do {
+ if( !sel ) break;
+
+ arg = arg->nd_right;
+ left = arg->nd_left;
+
+ /* ISO : COMPILETIME CONSTANTS NOT PERMITTED */
+ if( !ChkConstant(left) ) return 0;
+
+ if( !TstCompat(left->nd_type, sel->sel_type) ) {
+ node_error(left,
+ "type incompatibility in caselabel");
+ return 0;
+ }
+
+ i = left->nd_INT - sel->sel_lb;
+ if( i < 0 || i >= sel->sel_ncst ) {
+ node_error(left,
+ "case constant: out of bounds");
+ return 0;
+ }
+
+ sel = sel->sel_ptrs[i];
+ } while( arg->nd_right );
+
+ FreeNode(expp->nd_right->nd_right);
+ expp->nd_right->nd_right = NULLNODE;
+ }
+ expp->nd_type = NULLTYPE;
+ break;
+
+ default:
+ crash("(ChkStandard)");
+ }
+
+ if( arg->nd_right ) {
+ Xerror(name, "too many arguments supplied");
+ return 0;
+ }
+
+ return 1;
+}
+
+STATIC int
+ChkArrow(expp)
+ register struct node *expp;
+{
+ /* Check an application of the '^' operator.
+ The operand must be a variable of a pointer-type or a
+ variable of a file-type.
+ */
+
+ register struct type *tp;
+
+ assert(expp->nd_class == Arrow);
+ assert(expp->nd_symb == '^');
+
+ expp->nd_type = error_type;
+
+ if( !ChkVariable(expp->nd_right) ) return 0;
+
+ tp = expp->nd_right->nd_type;
+
+ if( !(tp->tp_fund & (T_POINTER | T_FILE)) ) {
+ node_error(expp, "\"^\": illegal operand");
+ return 0;
+ }
+
+ expp->nd_type = PointedtoType(tp);
+ return 1;
+}
+
+STATIC int
+ChkArr(expp)
+ register struct node *expp;
+{
+ /* Check an array selection.
+ The left hand side must be a variable of an array type,
+ and the right hand side must be an expression that is
+ assignment compatible with the array-index.
+ */
+
+ register struct type *tpl, *tpr;
+ int retval;
+
+ assert(expp->nd_class == Arrsel);
+ assert(expp->nd_symb == '[');
+
+ expp->nd_type = error_type;
+
+ retval = ChkVariable(expp->nd_left) & ChkExpression(expp->nd_right);
+
+ tpl = expp->nd_left->nd_type;
+ tpr = expp->nd_right->nd_type;
+ if( tpl == error_type || tpr == error_type ) return 0;
+
+ if( tpl->tp_fund != T_ARRAY ) {
+ node_error(expp, "not indexing an ARRAY type");
+ return 0;
+ }
+
+ /* Type of the index must be assignment compatible with
+ the index type of the array.
+ */
+ if( !TstCompat(IndexType(tpl), tpr) ) {
+ node_error(expp, "incompatible index type");
+ return 0;
+ }
+
+ expp->nd_type = tpl->arr_elem;
+ return retval;
+}
+
+STATIC int
+done_before()
+{
+ return 1;
+}
+
+STATIC int
+no_var_access(expp)
+ struct node *expp;
+{
+ node_error(expp, "variable-access expected");
+ return 0;
+}
+
+extern int NodeCrash();
+
+int (*ExprChkTable[])() = {
+#ifdef DEBUG
+ ChkValue,
+#else
+ done_before,
+#endif
+ ChkExLinkOrName,
+ ChkUnOper,
+ ChkBinOper,
+ ChkSet,
+ NodeCrash,
+ ChkExCall,
+ ChkNameOrCall,
+ ChkArrow,
+ ChkArr,
+ NodeCrash,
+ ChkExLinkOrName,
+ NodeCrash,
+ NodeCrash
+};
+
+int (*VarAccChkTable[])() = {
+ no_var_access,
+ ChkLinkOrName,
+ no_var_access,
+ no_var_access,
+ no_var_access,
+ NodeCrash,
+ no_var_access,
+ no_var_access,
+ ChkArrow,
+ ChkArr,
+ done_before,
+ ChkLinkOrName,
+ done_before,
+ no_var_access
+};
--- /dev/null
+/* 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))
--- /dev/null
+/* 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[];
--- /dev/null
+/* C O D E G E N E R A T I O N R O U T I N E S */
+
+#include "debug.h"
+#include <assert.h>
+#include <em.h>
+#include <em_reg.h>
+
+#include "LLlex.h"
+#include "Lpars.h"
+#include "def.h"
+#include "desig.h"
+#include "main.h"
+#include "node.h"
+#include "required.h"
+#include "scope.h"
+#include "type.h"
+
+int fp_used;
+
+CodeFil()
+{
+ if( !options['L'] )
+ C_fil_dlb((label) 1, (arith) 0);
+}
+
+RomString(nd)
+ register struct node *nd;
+{
+ C_df_dlb(++data_label);
+ C_rom_scon(nd->nd_STR, nd->nd_SLE); /* no trailing '\0' */
+ nd->nd_SLA = data_label;
+}
+
+RomReal(nd)
+ register struct node *nd;
+{
+ C_df_dlb(++data_label);
+ C_rom_fcon(nd->nd_REL, nd->nd_type->tp_size);
+ nd->nd_RLA = nd->nd_RIV->r_lab = data_label;
+}
+
+BssVar()
+{
+ /* generate bss segments for global variables */
+ register struct def *df = GlobalScope->sc_def;
+
+ while( df ) {
+ if( df->df_kind == D_VARIABLE ) {
+ C_df_dnam(df->var_name);
+
+ /* ??? undefined value ??? */
+ C_bss_cst(df->df_type->tp_size, (arith) 0, 0);
+ }
+ df = df->df_nextinscope;
+ }
+}
+
+arith
+CodeGtoDescr(sc)
+ register struct scope *sc;
+{
+ /* Create code for goto descriptors
+ */
+
+ register struct node *lb = sc->sc_lablist;
+ int first = 1;
+
+ while( lb ) {
+ if( lb->nd_def->lab_descr ) {
+ if( first ) {
+ /* create local for target SP */
+ sc->sc_off = -WA(pointer_size - sc->sc_off);
+ C_ms_gto();
+ first = 0;
+ }
+ C_df_dlb(lb->nd_def->lab_descr);
+ C_rom_ilb(lb->nd_def->lab_no);
+ C_rom_cst(sc->sc_off);
+ }
+ lb = lb->nd_next;
+ }
+ if( !first )
+ return sc->sc_off;
+ else
+ return (arith) 0;
+}
+
+arith
+CodeBeginBlock(df)
+ register struct def *df;
+{
+ /* Generate code at the beginning of the main program,
+ procedure or function.
+ */
+
+ arith StackAdjustment = 0;
+ arith offset; /* offset to save StackPointer */
+
+ TmpOpen(df->prc_vis->sc_scope);
+
+ switch( df->df_kind ) {
+
+ case D_PROGRAM :
+ C_exp("m_a_i_n");
+ C_pro_narg("m_a_i_n");
+ C_ms_par((arith) 0);
+ offset = CodeGtoDescr(df->prc_vis->sc_scope);
+ CodeFil();
+
+ /* %%% initialiseren external files %%% */
+ make_con(); call_ini(); /* %%%TYDELIJK%%% */
+
+ break;
+
+ case D_PROCEDURE :
+ case D_FUNCTION : {
+ struct type *tp;
+ register struct paramlist *param;
+
+ C_pro_narg(df->prc_name);
+ C_ms_par(df->df_type->prc_nbpar);
+
+ offset = CodeGtoDescr(df->prc_vis->sc_scope);
+ CodeFil();
+
+ for( param = ParamList(df->df_type); param; param = param->next)
+ if( !IsVarParam(param) ) {
+ tp = TypeOfParam(param);
+
+ if( IsConformantArray(tp) ) {
+ /* Here, we have to make a copy of the
+ array. We must also remember how much
+ room is reserved for copies, because
+ we have to adjust the stack pointer
+ before we return.
+ */
+
+ if( !StackAdjustment ) {
+ /* First time we get here
+ */
+ StackAdjustment = NewInt(0);
+ C_loc((arith) 0);
+ C_stl(StackAdjustment);
+ }
+ /* Address of array */
+ C_lol(param->par_def->var_off);
+
+ /* First compute size of the array */
+ C_lol(tp->arr_cfdescr + word_size);
+ C_inc();
+ /* gives number of elements */
+ C_lol(tp->arr_cfdescr + 2 * word_size);
+ /* size of elements */
+ C_mli(word_size);
+ C_loc(word_size - 1);
+ C_adi(word_size);
+ C_loc(word_size);
+ C_dvi(word_size);
+ /* size in words */
+ C_loc(word_size);
+ C_mli(word_size);
+ /* size in bytes */
+ C_dup(word_size);
+ C_lol(StackAdjustment);
+ C_adi(word_size);
+ C_stl(StackAdjustment);
+ /* remember stack adjustments */
+
+ C_los(word_size); /* copy */
+ C_lor((arith) 1);
+ /* push new address of array
+ ... downwards ... ???
+ */
+ C_stl(param->par_def->var_off);
+ }
+ }
+ break;
+ }
+
+ default :
+ crash("(CodeBeginBlock)");
+ /*NOTREACHED*/
+ }
+
+ if( offset ) {
+ /* save SP for non-local jump */
+ C_lor((arith) 1);
+ C_stl(offset);
+ }
+ return StackAdjustment;
+}
+
+CodeEndBlock(df, StackAdjustment)
+ register struct def *df;
+ arith StackAdjustment;
+{
+ switch( df->df_kind ) {
+ case D_PROGRAM :
+ C_loc((arith) 0);
+ C_cal("_hlt");
+ break;
+
+ case D_PROCEDURE :
+ case D_FUNCTION : {
+ struct type *tp;
+
+ if( StackAdjustment ) {
+ /* remove copies of conformant arrays */
+ C_lol(StackAdjustment);
+ C_ass(word_size);
+ FreeInt(StackAdjustment);
+ }
+ if( !options['n'] )
+ RegisterMessages(df->prc_vis->sc_scope->sc_def);
+
+ if( tp = ResultType(df->df_type) ) {
+ if( tp->tp_size == real_size )
+ C_ldl(-tp->tp_size);
+ else
+ C_lol(-tp->tp_size);
+
+ C_ret(tp->tp_size);
+ }
+ else
+ C_ret((arith) 0);
+
+ break;
+ }
+
+ default :
+ crash("(CodeEndBlock)");
+ /*NOTREACHED*/
+ }
+
+ C_end(- df->prc_vis->sc_scope->sc_off);
+ TmpClose();
+}
+
+CodeExpr(nd, ds, true_label)
+ register struct node *nd;
+ register struct desig *ds;
+ label true_label;
+{
+ register struct type *tp = nd->nd_type;
+
+ if( tp->tp_fund == T_REAL ) fp_used = 1;
+
+ switch( nd->nd_class ) {
+ case Value:
+ switch( nd->nd_symb ) {
+ case INTEGER:
+ C_loc(nd->nd_INT);
+ break;
+ case REAL:
+ C_lae_dlb(nd->nd_RLA, (arith) 0);
+ C_loi(tp->tp_size);
+ if( nd->nd_RSI )
+ C_ngf(tp->tp_size);
+ break;
+ case STRING:
+ if( tp->tp_fund == T_CHAR )
+ C_loc(nd->nd_INT);
+ else
+ C_lae_dlb(nd->nd_SLA, (arith) 0);
+ break;
+ case NIL:
+ C_zer(pointer_size);
+ break;
+ default:
+ crash("(CodeExpr Value)");
+ /*NOTREACHED*/
+ }
+ ds->dsg_kind = DSG_LOADED;
+ break;
+
+ case Uoper:
+ CodeUoper(nd);
+ ds->dsg_kind = DSG_LOADED;
+ break;
+
+ case Boper:
+ CodeBoper(nd, true_label);
+ ds->dsg_kind = DSG_LOADED;
+ true_label = NO_LABEL;
+ break;
+
+ case Set: {
+ register arith *st = nd->nd_set;
+ register int i;
+
+ ds->dsg_kind = DSG_LOADED;
+ if( !st ) {
+ C_zer(tp->tp_size);
+ break;
+ }
+ for( i = tp->tp_size / word_size, st += i; i > 0; i--)
+ C_loc(*--st);
+
+ }
+ break;
+
+ case Xset:
+ CodeSet(nd);
+ ds->dsg_kind = DSG_LOADED;
+ break;
+
+ case Call:
+ CodeCall(nd);
+ ds->dsg_kind = DSG_LOADED;
+ break;
+
+ case NameOrCall: {
+ /* actual procedure/function parameter */
+ struct node *left = nd->nd_left;
+ struct def *df = left->nd_def;
+
+ if( df->df_kind & D_ROUTINE ) {
+ int level = df->df_scope->sc_level;
+
+ if( level <= 0 || (df->df_flags & D_EXTERNAL) )
+ C_zer(pointer_size);
+ else
+ C_lxl((arith) (proclevel - level));
+
+ C_lpi(df->prc_name);
+ ds->dsg_kind = DSG_LOADED;
+ break;
+ }
+ assert(df->df_kind == D_VARIABLE);
+ assert(df->df_type->tp_fund & T_ROUTINE);
+
+ CodeDesig(left, ds);
+ break;
+ }
+
+ case Arrow:
+ case Arrsel:
+ case Def:
+ case LinkDef:
+ CodeDesig(nd, ds);
+ break;
+
+ case Cast: {
+ /* convert integer to real */
+ struct node *right = nd->nd_right;
+
+ CodePExpr(right);
+ Int2Real();
+ ds->dsg_kind = DSG_LOADED;
+ break;
+ }
+
+ default:
+ crash("(CodeExpr : bad node type)");
+ /*NOTREACHED*/
+ } /* switch class */
+
+ if( true_label ) {
+ /* Only for boolean expressions
+ */
+ CodeValue(ds, tp);
+ C_zeq(true_label);
+ }
+}
+
+CodeUoper(nd)
+ register struct node *nd;
+{
+ register struct type *tp = nd->nd_type;
+
+ CodePExpr(nd->nd_right);
+
+ switch( nd->nd_symb ) {
+ case '-':
+ assert(tp->tp_fund & T_NUMERIC);
+ if( tp->tp_fund == T_INTEGER )
+ C_ngi(tp->tp_size);
+ else
+ C_ngf(tp->tp_size);
+ break;
+
+ case NOT:
+ C_teq();
+ break;
+
+ case '(':
+ break;
+
+ default:
+ crash("(CodeUoper)");
+ /*NOTREACHED*/
+ }
+}
+
+Operands(leftop, rightop)
+ register struct node *leftop, *rightop;
+{
+ CodePExpr(leftop);
+ CodePExpr(rightop);
+}
+
+CodeBoper(expr, true_label)
+ register struct node *expr; /* the expression tree itself */
+ label true_label; /* label to jump to in logical exprs */
+{
+ register struct node *leftop = expr->nd_left;
+ register struct node *rightop = expr->nd_right;
+ register struct type *tp = expr->nd_type;
+
+ switch( expr->nd_symb ) {
+ case '+':
+ Operands(leftop, rightop);
+ switch( tp->tp_fund ) {
+ case T_INTEGER:
+ C_adi(tp->tp_size);
+ break;
+ case T_REAL:
+ C_adf(tp->tp_size);
+ break;
+ case T_SET:
+ C_ior(tp->tp_size);
+ break;
+ default:
+ crash("(CodeBoper: bad type +)");
+ }
+ break;
+
+ case '-':
+ Operands(leftop, rightop);
+ switch( tp->tp_fund ) {
+ case T_INTEGER:
+ C_sbi(tp->tp_size);
+ break;
+ case T_REAL:
+ C_sbf(tp->tp_size);
+ break;
+ case T_SET:
+ C_com(tp->tp_size);
+ C_and(tp->tp_size);
+ break;
+ default:
+ crash("(CodeBoper: bad type -)");
+ }
+ break;
+
+ case '*':
+ Operands(leftop, rightop);
+ switch( tp->tp_fund ) {
+ case T_INTEGER:
+ C_mli(tp->tp_size);
+ break;
+ case T_REAL:
+ C_mlf(tp->tp_size);
+ break;
+ case T_SET:
+ C_and(tp->tp_size);
+ break;
+ default:
+ crash("(CodeBoper: bad type *)");
+ }
+ break;
+
+ case '/':
+ Operands(leftop, rightop);
+ if( tp->tp_fund == T_REAL )
+ C_dvf(tp->tp_size);
+ else
+ crash("(CodeBoper: bad type /)");
+ break;
+
+ case DIV:
+ Operands(leftop, rightop);
+ if( tp->tp_fund == T_INTEGER )
+ C_dvi(tp->tp_size);
+ else
+ crash("(CodeBoper: bad type DIV)");
+ break;
+
+ case MOD:
+ Operands(leftop, rightop);
+ if( tp->tp_fund == T_INTEGER ) {
+ C_cal("_mdi");
+ C_asp(2 * tp->tp_size);
+ C_lfr(tp->tp_size);
+ }
+ else
+ crash("(CodeBoper: bad type MOD)");
+ break;
+
+ case '<':
+ case LESSEQUAL:
+ case '>':
+ case GREATEREQUAL:
+ case '=':
+ case NOTEQUAL:
+ CodePExpr(leftop);
+ CodePExpr(rightop);
+ tp = BaseType(rightop->nd_type);
+
+ switch( tp->tp_fund ) {
+ case T_INTEGER:
+ C_cmi(tp->tp_size);
+ break;
+ case T_REAL:
+ C_cmf(tp->tp_size);
+ break;
+ case T_ENUMERATION:
+ case T_CHAR:
+ C_cmu(word_size);
+ break;
+ case T_POINTER:
+ C_cmp();
+ break;
+
+ case T_SET:
+ if( expr->nd_symb == GREATEREQUAL ) {
+ /* A >= B is the same as A equals A + B
+ */
+ C_dup(2 * tp->tp_size);
+ C_asp(tp->tp_size);
+ C_ior(tp->tp_size);
+ expr->nd_symb = '=';
+ }
+ else if( expr->nd_symb == LESSEQUAL ) {
+ /* A <= B is the same as A - B = []
+ */
+ C_com(tp->tp_size);
+ C_and(tp->tp_size);
+ C_zer(tp->tp_size);
+ expr->nd_symb = '=';
+ }
+ C_cms(tp->tp_size);
+ break;
+
+ case T_STRING:
+ case T_ARRAY:
+ C_loc(IsString(tp));
+ C_cal("_bcp");
+ C_asp(2 * pointer_size + word_size);
+ C_lfr(word_size);
+ break;
+
+ default:
+ crash("(CodeBoper : bad type COMPARE)");
+ }
+ truthvalue(expr->nd_symb);
+ if( true_label != NO_LABEL )
+ C_zeq(true_label);
+ break;
+
+ case IN:
+ /* In this case, evaluate right hand side first! The INN
+ instruction expects the bit number on top of the stack
+ */
+ CodePExpr(rightop);
+ CodePExpr(leftop);
+ if( rightop->nd_type == emptyset_type )
+ C_and(rightop->nd_type->tp_size);
+ else
+ C_inn(rightop->nd_type->tp_size);
+
+ if( true_label != NO_LABEL )
+ C_zeq(true_label);
+ break;
+
+ case AND:
+ case OR:
+ Operands(leftop, rightop);
+ if( expr->nd_symb == AND )
+ C_and(tp->tp_size);
+ else
+ C_ior(tp->tp_size);
+ if( true_label != NO_LABEL )
+ C_zeq(true_label);
+ break;
+ default:
+ crash("(CodeBoper Bad operator %s\n)",
+ symbol2str(expr->nd_symb));
+ }
+}
+
+/* truthvalue() serves as an auxiliary function of CodeBoper */
+truthvalue(relop)
+{
+ switch( relop ) {
+ case '<':
+ C_tlt();
+ break;
+ case LESSEQUAL:
+ C_tle();
+ break;
+ case '>':
+ C_tgt();
+ break;
+ case GREATEREQUAL:
+ C_tge();
+ break;
+ case '=':
+ C_teq();
+ break;
+ case NOTEQUAL:
+ C_tne();
+ break;
+ default:
+ crash("(truthvalue)");
+ /*NOTREACHED*/
+ }
+}
+
+CodeSet(nd)
+ register struct node *nd;
+{
+ register struct type *tp = nd->nd_type;
+
+ C_zer(tp->tp_size);
+ nd = nd->nd_right;
+ while( nd ) {
+ assert(nd->nd_class == Link && nd->nd_symb == ',');
+
+ CodeEl(nd->nd_left, tp);
+ nd = nd->nd_right;
+ }
+}
+
+CodeEl(nd, tp)
+ register struct node *nd;
+ register struct type *tp;
+{
+ if( nd->nd_class == Link && nd->nd_symb == UPTO ) {
+ Operands(nd->nd_left, nd->nd_right);
+ C_loc(tp->tp_size); /* push size */
+ C_cal("_bts"); /* library routine to fill set */
+ C_asp(3 * word_size);
+ }
+ else {
+ CodePExpr(nd);
+ C_set(tp->tp_size);
+ C_ior(tp->tp_size);
+ }
+}
+
+struct type *
+CodeParameters(param, arg)
+ struct paramlist *param;
+ struct node *arg;
+{
+ register struct type *tp, *left_tp, *last_tp;
+ struct node *left;
+ struct desig ds;
+
+ assert(param && arg);
+
+ if( param->next )
+ last_tp = CodeParameters(param->next, arg->nd_right);
+
+ tp = TypeOfParam(param);
+ left = arg->nd_left;
+ left_tp = left->nd_type;
+
+ if( IsConformantArray(tp) ) {
+ if( last_tp != tp )
+ /* push descriptors only once */
+ CodeConfDescr(tp, left_tp);
+
+ CodeDAddress(left);
+ return tp;
+ }
+ if( IsVarParam(param) ) {
+ CodeDAddress(left);
+ return tp;
+ }
+ if( left_tp->tp_fund == T_STRING ) {
+ CodePString(left, tp);
+ return tp;
+ }
+
+ ds = InitDesig;
+ CodeExpr(left, &ds, NO_LABEL);
+ CodeValue(&ds, left_tp);
+
+ RangeCheck(tp, left_tp);
+ if( tp == real_type && BaseType(left_tp) == int_type )
+ Int2Real();
+
+ return tp;
+}
+
+CodeConfDescr(ftp, atp)
+ register struct type *ftp, *atp;
+{
+ struct type *elemtp = ftp->arr_elem;
+
+ if( IsConformantArray(elemtp) )
+ CodeConfDescr(elemtp, atp->arr_elem);
+
+ if( atp->tp_fund == T_STRING ) {
+ C_loc((arith) 1);
+ C_loc(atp->tp_psize - 1);
+ C_loc((arith) 1);
+ }
+ else if( IsConformantArray(atp) ) {
+ if( atp->arr_sclevel < proclevel ) {
+ C_lxa((arith) proclevel - atp->arr_sclevel);
+ C_adp(atp->arr_cfdescr);
+ }
+ else
+ C_lal(atp->arr_cfdescr);
+
+ C_loi(3 * word_size);
+ }
+ else { /* normal array */
+ assert(atp->tp_fund == T_ARRAY);
+ assert(!IsConformantArray(atp));
+ C_lae_dlb(atp->arr_ardescr, (arith) 0);
+ C_loi( 3 * word_size);
+ }
+}
+
+CodePString(nd, tp)
+ struct node *nd;
+ struct type *tp;
+{
+ /* no null padding */
+ C_lae_dlb(nd->nd_SLA, (arith) 0);
+ C_loi(tp->tp_size);
+}
+
+CodeCall(nd)
+ register struct node *nd;
+{
+ /* Generate code for a procedure call. Checking of parameters
+ and result is already done.
+ */
+ register struct node *left = nd->nd_left;
+ register struct node *right = nd->nd_right;
+ register struct def *df = left->nd_def;
+ register struct type *result_tp;
+
+ assert(IsProcCall(left));
+
+ if( left->nd_type == std_type ) {
+ CodeStd(nd);
+ return;
+ }
+
+ if( right )
+ (void) CodeParameters(ParamList(left->nd_type), right);
+
+ assert(left->nd_class == Def);
+
+
+ if( df->df_kind & D_ROUTINE ) {
+ int level = df->df_scope->sc_level;
+
+ if( level > 0 && !(df->df_flags & D_EXTERNAL) )
+ C_lxl((arith) (proclevel - level));
+ C_cal(df->prc_name);
+ C_asp(left->nd_type->prc_nbpar);
+ }
+ else {
+ label l1 = ++text_label;
+ label l2 = ++text_label;
+
+ assert(df->df_kind == D_VARIABLE);
+
+ /* Push value of procedure/function parameter */
+ CodePExpr(left);
+
+ /* Test if value is a global or local procedure/function */
+ C_exg(pointer_size);
+ C_dup(pointer_size);
+ C_zer(pointer_size);
+ C_cmp();
+
+ C_zeq(l1);
+ /* At this point, on top of the stack the LB */
+ C_exg(pointer_size);
+ /* Now, the name of the procedure/function */
+ C_cai();
+ C_asp(pointer_size + left->nd_type->prc_nbpar);
+ C_bra(l2);
+
+ /* value is a global procedure/function */
+ C_df_ilb(l1);
+ C_asp(pointer_size); /* no LB needed */
+ C_cai();
+ C_asp(left->nd_type->prc_nbpar);
+ C_df_ilb(l2);
+ }
+
+ if( result_tp = ResultType(left->nd_type) )
+ C_lfr(result_tp->tp_size);
+}
+
+CodeStd(nd)
+ struct node *nd;
+{
+ register struct node *arg = nd->nd_right;
+ register struct node *left = arg->nd_left;
+ register struct type *tp = BaseType(left->nd_type);
+ int req = nd->nd_left->nd_def->df_value.df_reqname;
+
+ assert(arg->nd_class == Link && arg->nd_symb == ',');
+
+ switch( req ) {
+ case R_ABS:
+ CodePExpr(left);
+ if( tp == int_type )
+ C_cal("_abi");
+ else
+ C_cal("_abr");
+ C_asp(tp->tp_size);
+ C_lfr(tp->tp_size);
+ break;
+
+ case R_SQR:
+ CodePExpr(left);
+ C_dup(tp->tp_size);
+ if( tp == int_type )
+ C_mli(int_size);
+ else
+ C_mlf(real_size);
+ break;
+
+ case R_SIN:
+ case R_COS:
+ case R_EXP:
+ case R_LN:
+ case R_SQRT:
+ case R_ARCTAN:
+ assert(tp == real_type);
+ CodePExpr(left);
+ switch( req ) {
+ case R_SIN:
+ C_cal("_sin");
+ break;
+ case R_COS:
+ C_cal("_cos");
+ break;
+ case R_EXP:
+ C_cal("_exp");
+ break;
+ case R_LN:
+ C_cal("_log");
+ break;
+ case R_SQRT:
+ C_cal("_sqt");
+ break;
+ case R_ARCTAN:
+ C_cal("_atn");
+ break;
+ default:
+ crash("(CodeStd)");
+ /*NOTREACHED*/
+ }
+ C_asp(real_size);
+ C_lfr(real_size);
+ break;
+
+ case R_TRUNC:
+ assert(tp == real_type);
+ CodePExpr(left);
+ Real2Int();
+ break;
+
+ case R_ROUND:
+ assert(tp == real_type);
+ CodePExpr(left);
+ C_cal("_rnd");
+ C_asp(real_size);
+ C_lfr(real_size);
+ Real2Int();
+ break;
+
+ case R_ORD:
+ CodePExpr(left);
+ break;
+
+ case R_CHR:
+ CodePExpr(left);
+ genrck(char_type);
+ break;
+
+ case R_SUCC:
+ case R_PRED:
+ CodePExpr(left);
+ if( req == R_SUCC )
+ C_inc();
+ else
+ C_dec();
+ if( bounded(left->nd_type) )
+ genrck(left->nd_type);
+ break;
+
+ case R_ODD:
+ CodePExpr(left);
+ C_loc((arith) 1);
+ C_and(word_size);
+ break;
+
+ case R_EOF:
+ case R_EOLN:
+ CodeDAddress(left);
+ if( req == R_EOF )
+ C_cal("_efl");
+ else
+ C_cal("_eln");
+ C_asp(pointer_size);
+ C_lfr(word_size);
+ break;
+
+ case R_REWRITE:
+ case R_RESET:
+ CodeDAddress(left);
+ if( tp == text_type )
+ C_loc((arith) 0);
+ else
+ C_loc(tp->next->tp_psize);
+ /* ??? elements of packed size ??? */
+ if( req == R_REWRITE )
+ C_cal("_cre");
+ else
+ C_cal("_opn");
+ C_asp(pointer_size + word_size);
+ break;
+
+ case R_PUT:
+ case R_GET:
+ CodeDAddress(left);
+ if( req == R_PUT )
+ C_cal("_put");
+ else
+ C_cal("_get");
+ C_asp(pointer_size);
+ break;
+
+ case R_PAGE:
+ CodeDAddress(left);
+ C_cal("_pag");
+ C_asp(pointer_size);
+ break;
+
+ case R_PACK: {
+ label lba = tp->arr_ardescr;
+
+ CodeDAddress(left);
+ arg = arg->nd_right;
+ left = arg->nd_left;
+ CodePExpr(left);
+ arg = arg->nd_right;
+ left = arg->nd_left;
+ CodeDAddress(left);
+ C_lae_dlb(left->nd_type->arr_ardescr, (arith) 0);
+ C_lae_dlb(lba, (arith) 0);
+ C_cal("_pac");
+ C_asp(4 * pointer_size + word_size);
+ break;
+ }
+
+ case R_UNPACK: {
+ /* change sequence of arguments of the library routine
+ _unp to merge code of R_PACK and R_UNPACK.
+ */
+ label lba, lbz = tp->arr_ardescr;
+
+ CodeDAddress(left);
+ arg = arg->nd_right;
+ left = arg->nd_left;
+ CodeDAddress(left);
+ lba = left->nd_type->arr_ardescr;
+ arg = arg->nd_right;
+ left = arg->nd_left;
+ CodePExpr(left);
+ C_lae_dlb(lbz, (arith) 0);
+ C_lae_dlb(lba, (arith) 0);
+ C_cal("_unp");
+ C_asp(4 * pointer_size + word_size);
+ break;
+ }
+
+ case R_NEW:
+ case R_DISPOSE:
+ CodeDAddress(left);
+ C_loc(PointedtoType(tp)->tp_size);
+ if( req == R_NEW )
+ C_cal("_new");
+ else
+ C_cal("_dis");
+ C_asp(pointer_size + word_size);
+ break;
+
+ default:
+ crash("(CodeStd)");
+ /*NOTREACHED*/
+ }
+}
+
+Int2Real()
+{
+ /* convert integer to real */
+ C_loc(int_size);
+ C_loc(real_size);
+ C_cif();
+}
+
+Real2Int()
+{
+ /* convert real to integer */
+ C_loc(real_size);
+ C_loc(int_size);
+ C_cfi();
+}
+
+RangeCheck(tpl, tpr)
+ register struct type *tpl, *tpr;
+{
+ /* Generate a range check if neccessary
+ */
+
+ arith llo, lhi, rlo, rhi;
+
+ if( bounded(tpl) ) {
+ /* in this case we might need a range check */
+ if( !bounded(tpr) )
+ /* yes, we need one */
+ genrck(tpl);
+ else {
+ /* both types are restricted. check the bounds to see
+ whether we need a range check. We don't need one
+ if the range of values of the right hand side is a
+ subset of the range of values of the left hand side.
+ */
+ getbounds(tpl, &llo, &lhi);
+ getbounds(tpr, &rlo, &rhi);
+ if( llo > rlo || lhi < rhi )
+ genrck(tpl);
+ }
+ }
+}
+
+genrck(tp)
+ register struct type *tp;
+{
+ /* Generate a range check descriptor for type "tp" when
+ necessary. Return its label.
+ */
+
+ arith lb, ub;
+ register label o1;
+ int newlabel = 0;
+
+ if( !options['r'] ) return;
+
+ getbounds(tp, &lb, &ub);
+
+ if( tp->tp_fund == T_SUBRANGE ) {
+ if( !(o1 = tp->sub_rck) ) {
+ tp->sub_rck = o1 = ++data_label;
+ newlabel = 1;
+ }
+ }
+ else if( !(o1 = tp->enm_rck) ) {
+ tp->enm_rck = o1 = ++data_label;
+ newlabel = 1;
+ }
+ if( newlabel ) {
+ C_df_dlb(o1);
+ C_rom_cst(lb);
+ C_rom_cst(ub);
+ }
+ C_lae_dlb(o1, (arith) 0);
+ C_rck(word_size);
+}
+
+CodePExpr(nd)
+ register struct node *nd;
+{
+ /* Generate code to push the value of the expression "nd"
+ on the stack.
+ */
+
+ struct desig designator;
+ struct type *tp = BaseType(nd->nd_type);
+
+ designator = InitDesig;
+ CodeExpr(nd, &designator, NO_LABEL);
+ if( tp->tp_fund & (T_ARRAY | T_RECORD) )
+ CodeAddress(&designator);
+ else
+ CodeValue(&designator, nd->nd_type);
+}
+
+CodeDAddress(nd)
+ struct node *nd;
+{
+ /* Generate code to push the address of the designator "nd"
+ on the stack.
+ */
+
+ struct desig designator;
+
+ designator = InitDesig;
+ CodeDesig(nd, &designator);
+ CodeAddress(&designator);
+}
+
+CodeDStore(nd)
+ register struct node *nd;
+{
+ /* Generate code to store the expression on the stack
+ into the designator "nd".
+ */
+
+ struct desig designator;
+
+ designator = InitDesig;
+ CodeDesig(nd, &designator);
+ CodeStore(&designator, nd->nd_type);
+}
+
+RegisterMessages(df)
+ register struct def *df;
+{
+ register struct type *tp;
+
+ for( ; df; df = df->df_nextinscope ) {
+ if( df->df_kind == D_VARIABLE && !(df->df_flags & D_NOREG) ) {
+ /* Examine type and size
+ */
+ tp = BaseType(df->df_type);
+ if( df->df_flags & D_VARPAR || tp->tp_fund & T_POINTER )
+ C_ms_reg(df->var_off, pointer_size,
+ reg_pointer, 0);
+
+ else if( df->df_flags & D_LOOPVAR )
+ C_ms_reg(df->var_off, tp->tp_size, reg_loop,2);
+ else if( tp->tp_fund & T_NUMERIC )
+ C_ms_reg(df->var_off, tp->tp_size,
+ tp->tp_fund == T_REAL ? reg_float : reg_any, 0);
+ }
+ }
+}
--- /dev/null
+/* 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 */
--- /dev/null
+/* 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;
+}
--- /dev/null
+/* A debugging macro
+*/
+
+#include "debugcst.h"
+
+#ifdef DEBUG
+#define DO_DEBUG(x, y) ((x) && (y))
+#else
+#define DO_DEBUG(x, y)
+#endif
--- /dev/null
+/* 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;
+ }
+;
--- /dev/null
+/* 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)
--- /dev/null
+/* 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;
+}
--- /dev/null
+/* 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)
--- /dev/null
+/* 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");
+ }
+}
--- /dev/null
+.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.
--- /dev/null
+/* 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;
+}
--- /dev/null
+/* 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");
+}
--- /dev/null
+/* 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)
+;
--- /dev/null
+/* 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
--- /dev/null
+/* 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>
--- /dev/null
+/* 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>
--- /dev/null
+/* 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;
+}
--- /dev/null
+/* 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>
--- /dev/null
+/* 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);
+ }
+}
--- /dev/null
+/* 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;
+}
--- /dev/null
+/* 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 = ˙
+ 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
--- /dev/null
+/* 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;
--- /dev/null
+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))\
+:'
--- /dev/null
+: 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
--- /dev/null
+echo '#include "debug.h"'
+sed -n '
+s:^.*[ ]ALLOCDEF[ ].*"\(.*\)".*$:struct \1 *h_\1 = 0;\
+#ifdef DEBUG\
+int cnt_\1 = 0;\
+#endif:p
+' $*
--- /dev/null
+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--
--- /dev/null
+sed '
+/{[A-Z]/!d
+s/.*{//
+s/,.*//
+s/.*/%token &;/
+'
--- /dev/null
+/* 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;
+ }
+
+}
--- /dev/null
+/* 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();
--- /dev/null
+#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
--- /dev/null
+/* 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)
--- /dev/null
+/* 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
--- /dev/null
+/* 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;
+}
--- /dev/null
+/* 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); }
+;
--- /dev/null
+/* 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);
+}
--- /dev/null
+/* 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);
+}
--- /dev/null
+/* 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
--- /dev/null
+/* 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 */
--- /dev/null
+/* 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;
+ }
+}
--- /dev/null
+/* 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;
+ }
+ ]?
+ ]?
+;
--- /dev/null
+/* @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);
+ }
+ }
+}
--- /dev/null
+/* 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;
+}
--- /dev/null
+/* 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++;
+ }
+}
--- /dev/null
+/* 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;
+};
--- /dev/null
+/* 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)
--- /dev/null
+/* 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
--- /dev/null
+/* 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);
+}
public / ack.git / commitdiff