diff --git a/lang/pc/comp/.distr b/lang/pc/comp/.distr new file mode 100644 index 000000000..5cd8e7635 --- /dev/null +++ b/lang/pc/comp/.distr @@ -0,0 +1,59 @@ +LLlex.c +LLlex.h +LLmessage.c +Makefile +Parameters +body.c +casestat.C +char.c +char.tab +chk_expr.c +chk_expr.h +class.h +code.c +const.h +cstoper.c +debug.h +declar.g +def.H +def.c +desig.H +desig.c +em_pc.6 +enter.c +error.c +expression.g +f_info.h +idf.c +idf.h +input.c +input.h +label.c +lookup.c +main.c +main.h +make.allocd +make.hfiles +make.next +make.tokcase +make.tokfile +misc.c +misc.h +next.c +node.H +node.c +options.c +program.g +progs.c +readwrite.c +required.h +scope.H +scope.c +statement.g +tab.c +tmpvar.C +tokenname.c +tokenname.h +type.H +type.c +typequiv.c diff --git a/lang/pc/comp/LLlex.c b/lang/pc/comp/LLlex.c new file mode 100644 index 000000000..f8b29f289 --- /dev/null +++ b/lang/pc/comp/LLlex.c @@ -0,0 +1,411 @@ +/* L E X I C A L A N A L Y S E R F O R I S O - P A S C A L */ + +#include "debug.h" +#include "idfsize.h" +#include "numsize.h" +#include "strsize.h" + +#include +#include +#include + +#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*/ +} diff --git a/lang/pc/comp/LLlex.h b/lang/pc/comp/LLlex.h new file mode 100644 index 000000000..adc50fa9b --- /dev/null +++ b/lang/pc/comp/LLlex.h @@ -0,0 +1,49 @@ +/* T O K E N D E S C R I P T O R D E F I N I T I O N */ + +/* Structure to store a string constant +*/ +struct string { + arith s_length; /* length of a string */ + char *s_str; /* the string itself */ + label s_lab; /* data label of string */ +}; + +/* Structure to store a real constant +*/ +struct real { + char *r_real; /* string representation of real */ + struct real *r_inverse; /* the inverse of this real */ + label r_lab; /* data label of real */ + int r_sign; /* positive or negative */ +}; + +/* Token structure. Keep it small, as it is part of a parse-tree node +*/ +struct token { + short tk_symb; /* token itself */ + unsigned short tk_lineno; /* linenumber on which it occurred */ + union { + struct idf *tk_idf; /* IDENT */ + struct string *tk_str; /* STRING */ + arith tk_int; /* INTEGER */ + struct real *tk_real; /* REAL */ + struct def *tk_def; /* only used in parse tree node */ + arith *tk_set; /* only used in parse tree node */ + label tk_lab; /* only used in parse tree node */ + } tk_data; +}; + +#define TOK_IDF tk_data.tk_idf +#define TOK_STR tk_data.tk_str->s_str +#define TOK_SLE tk_data.tk_str->s_length +#define TOK_SLA tk_data.tk_str->s_lab +#define TOK_INT tk_data.tk_int +#define TOK_REL tk_data.tk_real->r_real +#define TOK_RIV tk_data.tk_real->r_inverse +#define TOK_RLA tk_data.tk_real->r_lab +#define TOK_RSI tk_data.tk_real->r_sign + +extern struct token dot, aside; +extern struct type *toktype, *asidetype; + +#define ASIDE aside.tk_symb diff --git a/lang/pc/comp/LLmessage.c b/lang/pc/comp/LLmessage.c new file mode 100644 index 000000000..79636a95b --- /dev/null +++ b/lang/pc/comp/LLmessage.c @@ -0,0 +1,72 @@ +/* S Y N T A X E R R O R R E P O R T I N G */ + +/* Defines the LLmessage routine. LLgen-generated parsers require the + existence of a routine of that name. + The routine must do syntax-error reporting and must be able to + insert tokens in the token stream. +*/ + +#include +#include +#include + +#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)); +} diff --git a/lang/pc/comp/Makefile b/lang/pc/comp/Makefile new file mode 100644 index 000000000..e0a190b7f --- /dev/null +++ b/lang/pc/comp/Makefile @@ -0,0 +1,376 @@ +# make iso-pascal "compiler" +EMHOME = ../../.. +MHDIR = $(EMHOME)/modules/h +PKGDIR = $(EMHOME)/modules/pkg +LIBDIR = $(EMHOME)/modules/lib +OBJECTCODE = $(LIBDIR)/libemk.a $(EMHOME)/lib/em_data.a +LLGEN = $(EMHOME)/bin/LLgen +MKDEP = $(EMHOME)/bin/mkdep +CURRDIR = . +CC = fcc +PRINTER = vu45 + +INCLUDES = -I$(MHDIR) -I$(EMHOME)/h -I$(PKGDIR) + +GFILES = tokenfile.g declar.g expression.g program.g statement.g +LLGENOPTIONS = +PROFILE = +CFLAGS = $(PROFILE) $(INCLUDES) -DSTATIC= +LINTFLAGS = -DSTATIC= +MALLOC = $(LIBDIR)/malloc.o +LFLAGS = $(PROFILE) +LSRC = declar.c expression.c program.c statement.c tokenfile.c +LOBJ = declar.o expression.o program.o statement.o tokenfile.o +CSRC = LLlex.c LLmessage.c body.c char.c chk_expr.c code.c\ + cstoper.c def.c desig.c enter.c error.c idf.c input.c label.c\ + lookup.c main.c misc.c next.c node.c options.c readwrite.c\ + scope.c symbol2str.c tokenname.c type.c typequiv.c progs.c +COBJ = LLlex.o LLmessage.o body.o casestat.o char.o chk_expr.o code.o\ + cstoper.o def.o desig.o enter.o error.o idf.o input.o label.o\ + lookup.o main.o misc.o next.o node.o options.o readwrite.o\ + scope.o symbol2str.o tmpvar.o tokenname.o type.o typequiv.o progs.o +OBJ = Lpars.o $(COBJ) $(LOBJ) + +# Keep the next entries up to date! +GENCFILES= Lpars.c declar.c expression.c program.c statement.c\ + tokenfile.c symbol2str.c casestat.c tmpvar.c +SRC = Lpars.c $(CSRC) $(GENCFILES) +GENGFILES= tokenfile.g +GENHFILES= Lpars.h debugcst.h density.h errout.h idfsize.h inputtype.h\ + numsize.h strsize.h def.h type.h desig.h scope.h node.h\ + target_sizes.h +HFILES= LLlex.h chk_expr.h class.h const.h debug.h def.h desig.h\ + f_info.h idf.h input.h main.h misc.h node.h required.h scope.h\ + tokenname.h type.h $(GENHFILES) +# +GENFILES = $(GENGFILES) $(GENCFILES) $(GENHFILES) +NEXTFILES = def.H desig.H node.H scope.H type.H casestat.C tmpvar.C + +#EXCLEXCLEXCLEXCL + +all: Cfiles + make $(CURRDIR)/main + +clean: + rm -f *.o main $(GENFILES) hfiles Cfiles LLfiles + +# entry points not to be used directly + +Cfiles: hfiles LLfiles $(GENCFILES) $(GENHFILES) Makefile + echo $(SRC) $(HFILES) > Cfiles + +LLfiles: $(GFILES) + $(LLGEN) $(LLGENOPTIONS) $(GFILES) + @touch LLfiles + +hfiles: Parameters make.hfiles + make.hfiles Parameters + touch hfiles + +lint: Cfiles + lint $(INCLUDES) $(LINTFLAGS) $(SRC) + +tokenfile.g: tokenname.c make.tokfile + make.tokfile < tokenname.c > tokenfile.g + +symbol2str.c: tokenname.c make.tokcase + make.tokcase < tokenname.c > symbol2str.c + +.SUFFIXES: .H .h +.H.h: + ./make.allocd < $*.H > $*.h + +.SUFFIXES: .C .c +.C.c: + ./make.allocd < $*.C > $*.c + +def.h: make.allocd +type.h: make.allocd +node.h: make.allocd +scope.h: make.allocd +desig.h: make.allocd +casestat.c: make.allocd +tmpvar.c: make.allocd + +next.c: $(NEXTFILES) ./make.next + ./make.next $(NEXTFILES) > next.c + +char.c: char.tab tab + tab -fchar.tab > char.c + +tab: + $(CC) tab.c -o tab +depend: + sed '/^#AUTOAUTO/,$$d' Makefile > Makefile.new + echo '#AUTOAUTOAUTOAUTOAUTOAUTOAUTOAUTO' >> Makefile.new + $(MKDEP) $(SRC) |\ + sed 's/\.c:/\.o:/' >> Makefile.new + mv Makefile Makefile.old + mv Makefile.new Makefile + +print: $(CSRC) $(GFILES) $(HFILES) # print recently changed files + pr -t $? | rpr $(PRINTER) + @touch print + +xref: + ctags -x $(CSRC) $(HFILES) | sed "s/).*/)/">Xref + +#INCLINCLINCLINCL + +$(CURRDIR)/main: $(OBJ) + -mv main main.old + $(CC) $(LFLAGS) $(OBJ) $(LIBDIR)/libem_mes.a $(OBJECTCODE) $(LIBDIR)/libinput.a $(LIBDIR)/liballoc.a $(MALLOC) $(LIBDIR)/libassert.a $(LIBDIR)/libprint.a $(LIBDIR)/libstring.a $(LIBDIR)/libsystem.a -o $(CURRDIR)/main + size $(CURRDIR)/main.old + size $(CURRDIR)/main + +#AUTOAUTOAUTOAUTOAUTOAUTOAUTOAUTO +Lpars.o: Lpars.h +LLlex.o: LLlex.h +LLlex.o: Lpars.h +LLlex.o: class.h +LLlex.o: const.h +LLlex.o: debug.h +LLlex.o: debugcst.h +LLlex.o: f_info.h +LLlex.o: idf.h +LLlex.o: idfsize.h +LLlex.o: input.h +LLlex.o: inputtype.h +LLlex.o: main.h +LLlex.o: numsize.h +LLlex.o: strsize.h +LLlex.o: type.h +LLmessage.o: LLlex.h +LLmessage.o: Lpars.h +LLmessage.o: idf.h +LLmessage.o: type.h +body.o: LLlex.h +body.o: chk_expr.h +body.o: debug.h +body.o: debugcst.h +body.o: def.h +body.o: desig.h +body.o: idf.h +body.o: main.h +body.o: node.h +body.o: scope.h +body.o: type.h +casestat.o: LLlex.h +casestat.o: Lpars.h +casestat.o: chk_expr.h +casestat.o: debug.h +casestat.o: debugcst.h +casestat.o: density.h +casestat.o: main.h +casestat.o: node.h +casestat.o: type.h +char.o: class.h +chk_expr.o: LLlex.h +chk_expr.o: Lpars.h +chk_expr.o: chk_expr.h +chk_expr.o: const.h +chk_expr.o: debug.h +chk_expr.o: debugcst.h +chk_expr.o: def.h +chk_expr.o: idf.h +chk_expr.o: main.h +chk_expr.o: misc.h +chk_expr.o: node.h +chk_expr.o: required.h +chk_expr.o: scope.h +chk_expr.o: type.h +code.o: LLlex.h +code.o: Lpars.h +code.o: debug.h +code.o: debugcst.h +code.o: def.h +code.o: desig.h +code.o: main.h +code.o: node.h +code.o: required.h +code.o: scope.h +code.o: type.h +cstoper.o: LLlex.h +cstoper.o: Lpars.h +cstoper.o: const.h +cstoper.o: debug.h +cstoper.o: debugcst.h +cstoper.o: node.h +cstoper.o: required.h +cstoper.o: target_sizes.h +cstoper.o: type.h +def.o: LLlex.h +def.o: debug.h +def.o: debugcst.h +def.o: def.h +def.o: idf.h +def.o: main.h +def.o: misc.h +def.o: node.h +def.o: scope.h +def.o: type.h +desig.o: LLlex.h +desig.o: debug.h +desig.o: debugcst.h +desig.o: def.h +desig.o: desig.h +desig.o: main.h +desig.o: node.h +desig.o: scope.h +desig.o: type.h +enter.o: LLlex.h +enter.o: def.h +enter.o: idf.h +enter.o: main.h +enter.o: node.h +enter.o: scope.h +enter.o: type.h +error.o: LLlex.h +error.o: debug.h +error.o: debugcst.h +error.o: errout.h +error.o: f_info.h +error.o: input.h +error.o: inputtype.h +error.o: main.h +error.o: node.h +idf.o: idf.h +input.o: f_info.h +input.o: idf.h +input.o: input.h +input.o: inputtype.h +label.o: LLlex.h +label.o: def.h +label.o: idf.h +label.o: main.h +label.o: node.h +label.o: scope.h +label.o: type.h +lookup.o: LLlex.h +lookup.o: def.h +lookup.o: idf.h +lookup.o: misc.h +lookup.o: node.h +lookup.o: scope.h +lookup.o: type.h +main.o: LLlex.h +main.o: Lpars.h +main.o: const.h +main.o: debug.h +main.o: debugcst.h +main.o: def.h +main.o: f_info.h +main.o: idf.h +main.o: input.h +main.o: inputtype.h +main.o: main.h +main.o: node.h +main.o: required.h +main.o: tokenname.h +main.o: type.h +misc.o: LLlex.h +misc.o: f_info.h +misc.o: idf.h +misc.o: main.h +misc.o: misc.h +misc.o: node.h +next.o: debug.h +next.o: debugcst.h +node.o: LLlex.h +node.o: debug.h +node.o: debugcst.h +node.o: node.h +node.o: type.h +options.o: class.h +options.o: const.h +options.o: idfsize.h +options.o: main.h +options.o: type.h +readwrite.o: LLlex.h +readwrite.o: debug.h +readwrite.o: debugcst.h +readwrite.o: def.h +readwrite.o: main.h +readwrite.o: node.h +readwrite.o: scope.h +readwrite.o: type.h +scope.o: LLlex.h +scope.o: debug.h +scope.o: debugcst.h +scope.o: def.h +scope.o: idf.h +scope.o: misc.h +scope.o: node.h +scope.o: scope.h +scope.o: type.h +symbol2str.o: Lpars.h +tmpvar.o: debug.h +tmpvar.o: debugcst.h +tmpvar.o: def.h +tmpvar.o: main.h +tmpvar.o: scope.h +tmpvar.o: type.h +tokenname.o: Lpars.h +tokenname.o: idf.h +tokenname.o: tokenname.h +type.o: LLlex.h +type.o: const.h +type.o: debug.h +type.o: debugcst.h +type.o: def.h +type.o: idf.h +type.o: main.h +type.o: node.h +type.o: scope.h +type.o: target_sizes.h +type.o: type.h +typequiv.o: LLlex.h +typequiv.o: debug.h +typequiv.o: debugcst.h +typequiv.o: def.h +typequiv.o: node.h +typequiv.o: type.h +progs.o: LLlex.h +progs.o: debug.h +progs.o: debugcst.h +progs.o: def.h +progs.o: main.h +progs.o: scope.h +progs.o: type.h +declar.o: LLlex.h +declar.o: Lpars.h +declar.o: chk_expr.h +declar.o: def.h +declar.o: idf.h +declar.o: main.h +declar.o: misc.h +declar.o: node.h +declar.o: scope.h +declar.o: type.h +expression.o: LLlex.h +expression.o: Lpars.h +expression.o: chk_expr.h +expression.o: debug.h +expression.o: debugcst.h +expression.o: def.h +expression.o: main.h +expression.o: node.h +expression.o: scope.h +expression.o: type.h +program.o: LLlex.h +program.o: Lpars.h +program.o: def.h +program.o: main.h +program.o: node.h +program.o: scope.h +statement.o: LLlex.h +statement.o: Lpars.h +statement.o: chk_expr.h +statement.o: def.h +statement.o: desig.h +statement.o: idf.h +statement.o: main.h +statement.o: node.h +statement.o: scope.h +statement.o: type.h +tokenfile.o: Lpars.h diff --git a/lang/pc/comp/Parameters b/lang/pc/comp/Parameters new file mode 100644 index 000000000..7dc87b376 --- /dev/null +++ b/lang/pc/comp/Parameters @@ -0,0 +1,51 @@ +!File: debugcst.h +#define DEBUG 1 /* perform various self-tests */ + + +!File: density.h +#define DENSITY 3 /* to determine, if a csa or csb + instruction must be generated */ + + +!File: errout.h +#define ERROUT STDERR /* file pointer for writing messages */ +#define MAXERR_LINE 5 /* maximum number of error messages given + on the same input line. */ + + +!File: idfsize.h +#define IDFSIZE 128 /* max. significant length of an identifier */ + + +!File: inputtype.h +#define INP_READ_IN_ONE 1 /* read input file in one */ + + +!File: numsize.h +#define NUMSIZE 256 /* maximum length of a numeric constant */ + + +!File: strsize.h +#define ISTRSIZE 32 /* minimum number of bytes allocated for + storing a string */ +#define RSTRSIZE 8 /* step size in enlarging the memory for + the storage of a string */ + + +!File: target_sizes.h +#define MAXSIZE 8 /* the maximum of the SZ_* constants */ + +/* target machine sizes */ +#define SZ_CHAR (arith)1 +#define SZ_WORD (arith)4 +#define SZ_INT (arith)4 +#define SZ_POINTER (arith)4 +#define SZ_REAL (arith)8 + +/* target machine alignment requirements */ +#define AL_CHAR 1 +#define AL_WORD (int)SZ_WORD +#define AL_INT (int)SZ_WORD +#define AL_POINTER (int)SZ_WORD +#define AL_REAL (int)SZ_WORD +#define AL_STRUCT 1 diff --git a/lang/pc/comp/body.c b/lang/pc/comp/body.c new file mode 100644 index 000000000..486e4bf11 --- /dev/null +++ b/lang/pc/comp/body.c @@ -0,0 +1,247 @@ +#include "debug.h" + +#include +#include +#include + +#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); +} diff --git a/lang/pc/comp/casestat.C b/lang/pc/comp/casestat.C new file mode 100644 index 000000000..e9e9c3a73 --- /dev/null +++ b/lang/pc/comp/casestat.C @@ -0,0 +1,254 @@ +/* C A S E S T A T E M E N T C O D E G E N E R A T I O N */ +#include "debug.h" + +#include +#include +#include + +#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); +} diff --git a/lang/pc/comp/char.c b/lang/pc/comp/char.c new file mode 100644 index 000000000..ee457314b --- /dev/null +++ b/lang/pc/comp/char.c @@ -0,0 +1,394 @@ +#include "class.h" +char tkclass[] = { + STGARB, + STGARB, + STGARB, + STGARB, + STGARB, + STGARB, + STGARB, + STGARB, + STGARB, + STSKIP, + STNL, + STNL, + STNL, + STSKIP, + STGARB, + STGARB, + STGARB, + STGARB, + STGARB, + STGARB, + STGARB, + STGARB, + STGARB, + STGARB, + STGARB, + STGARB, + STGARB, + STGARB, + STGARB, + STGARB, + STGARB, + STGARB, + STSKIP, + STGARB, + STGARB, + STGARB, + STGARB, + STGARB, + STGARB, + STSTR, + STSIMP, + STSIMP, + STSIMP, + STSIMP, + STSIMP, + STSIMP, + STCOMP, + STSIMP, + STNUM, + STNUM, + STNUM, + STNUM, + STNUM, + STNUM, + STNUM, + STNUM, + STNUM, + STNUM, + STCOMP, + STSIMP, + STCOMP, + STSIMP, + STCOMP, + STGARB, + STSIMP, + STIDF, + STIDF, + STIDF, + STIDF, + STIDF, + STIDF, + STIDF, + STIDF, + STIDF, + STIDF, + STIDF, + STIDF, + STIDF, + STIDF, + STIDF, + STIDF, + STIDF, + STIDF, + STIDF, + STIDF, + STIDF, + STIDF, + STIDF, + STIDF, + STIDF, + STIDF, + STSIMP, + STGARB, + STSIMP, + STSIMP, + STGARB, + STGARB, + STIDF, + STIDF, + STIDF, + STIDF, + STIDF, + STIDF, + STIDF, + STIDF, + STIDF, + STIDF, + STIDF, + STIDF, + STIDF, + STIDF, + STIDF, + STIDF, + STIDF, + STIDF, + STIDF, + STIDF, + STIDF, + STIDF, + STIDF, + STIDF, + STIDF, + STIDF, + STSIMP, + STGARB, + STSIMP, + STGARB, + STGARB, + STEOI, +}; +char inidf[] = { + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 0, + 0, + 0, + 0, + 0, + 0, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 0, + 0, + 0, + 0, + 0, + 0, +}; +char isdig[] = { + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 1, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, + 0, +}; diff --git a/lang/pc/comp/char.tab b/lang/pc/comp/char.tab new file mode 100644 index 000000000..0e485107b --- /dev/null +++ b/lang/pc/comp/char.tab @@ -0,0 +1,37 @@ +% character tables for ISO-PASCAL compiler +%S129 +%F %s, +% +% CHARACTER CLASSES +% +%C +STGARB:\000-\200 +STSKIP: \r\t +STNL:\012\013\014 +STSIMP:()*+,-/;=@[]^{} +STCOMP:.:<> +STIDF:a-zA-Z +STSTR:' +STNUM:0-9 +STEOI:\200 +%T#include "class.h" +%Tchar tkclass[] = { +%p +%T}; +% +% INIDF +% +%C +1:a-zA-Z0-9 +%Tchar inidf[] = { +%F %s, +%p +%T}; +% +% ISDIG +% +%C +1:0-9 +%Tchar isdig[] = { +%p +%T}; diff --git a/lang/pc/comp/chk_expr.c b/lang/pc/comp/chk_expr.c new file mode 100644 index 000000000..be1651a5c --- /dev/null +++ b/lang/pc/comp/chk_expr.c @@ -0,0 +1,1179 @@ +/* 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 +#include +#include +#include + +#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 +}; diff --git a/lang/pc/comp/chk_expr.h b/lang/pc/comp/chk_expr.h new file mode 100644 index 000000000..7357155b1 --- /dev/null +++ b/lang/pc/comp/chk_expr.h @@ -0,0 +1,12 @@ +/* E X P R E S S I O N C H E C K I N G */ + +extern int (*ExprChkTable[])(); /* table of expression checking + functions, indexed by node class + */ + +extern int (*VarAccChkTable[])(); /* table of variable-access checking + functions, indexed by node class + */ + +#define ChkExpression(expp) ((*ExprChkTable[(expp)->nd_class])(expp)) +#define ChkVarAccess(expp) ((*VarAccChkTable[(expp)->nd_class])(expp)) diff --git a/lang/pc/comp/class.h b/lang/pc/comp/class.h new file mode 100644 index 000000000..18f6a95b9 --- /dev/null +++ b/lang/pc/comp/class.h @@ -0,0 +1,34 @@ +/* U S E O F C H A R A C T E R C L A S S E S */ + +/* As a starter, chars are divided into classes, according to which + token they can be the start of. + At present such a class number is supposed to fit in 4 bits. +*/ + +#define class(ch) (tkclass[ch]) + +/* Being the start of a token is, fortunately, a mutual exclusive + property, so, as there are less than 16 classes they can be + packed in 4 bits. +*/ + +#define STSKIP 0 /* spaces and so on: skipped characters */ +#define STNL 1 /* newline character(s): update linenumber etc. */ +#define STGARB 2 /* garbage ascii character: not allowed */ +#define STSIMP 3 /* this character can occur as token */ +#define STCOMP 4 /* this one can start a compound token */ +#define STIDF 5 /* being the initial character of an identifier */ +#define STCHAR 6 /* the starter of a character constant */ +#define STSTR 7 /* the starter of a string */ +#define STNUM 8 /* the starter of a numeric constant */ +#define STEOI 9 /* End-Of-Information mark */ + +/* But occurring inside a token is not, so we need 1 bit for each + class. This is implemented as a collection of tables to speed up + the decision whether a character has a special meaning. +*/ +#define in_idf(ch) ((unsigned)ch < 0177 && inidf[ch]) +#define is_dig(ch) ((unsigned)ch < 0177 && isdig[ch]) + +extern char tkclass[]; +extern char inidf[], isdig[]; diff --git a/lang/pc/comp/code.c b/lang/pc/comp/code.c new file mode 100644 index 000000000..4b614f49a --- /dev/null +++ b/lang/pc/comp/code.c @@ -0,0 +1,1142 @@ +/* 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 +#include +#include + +#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); + } + } +} diff --git a/lang/pc/comp/const.h b/lang/pc/comp/const.h new file mode 100644 index 000000000..0e40f064d --- /dev/null +++ b/lang/pc/comp/const.h @@ -0,0 +1,12 @@ +/* C O N S T A N T S F O R E X P R E S S I O N H A N D L I N G */ + +extern long + mach_long_sign; /* sign bit of the machine long */ +extern int + mach_long_size; /* size of long on this machine == sizeof(long) */ +extern arith + max_int, /* maximum integer on target machine */ + wrd_bits, /* number of bits in a word */ + max_intset; /* largest value of set of integer */ +extern char + *maxint_str; /* string representation of maximum integer */ diff --git a/lang/pc/comp/cstoper.c b/lang/pc/comp/cstoper.c new file mode 100644 index 000000000..d6615ab4c --- /dev/null +++ b/lang/pc/comp/cstoper.c @@ -0,0 +1,448 @@ +/* C O N S T A N T E X P R E S S I O N H A N D L I N G */ + +#include "debug.h" +#include "target_sizes.h" + +#include +#include +#include +#include + +#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; +} diff --git a/lang/pc/comp/debug.h b/lang/pc/comp/debug.h new file mode 100644 index 000000000..670c29d18 --- /dev/null +++ b/lang/pc/comp/debug.h @@ -0,0 +1,10 @@ +/* A debugging macro +*/ + +#include "debugcst.h" + +#ifdef DEBUG +#define DO_DEBUG(x, y) ((x) && (y)) +#else +#define DO_DEBUG(x, y) +#endif diff --git a/lang/pc/comp/declar.g b/lang/pc/comp/declar.g new file mode 100644 index 000000000..e080c2f35 --- /dev/null +++ b/lang/pc/comp/declar.g @@ -0,0 +1,942 @@ +/* D E C L A R A T I O N S */ + +{ +#include +#include +#include +#include + +#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; + } +; diff --git a/lang/pc/comp/def.H b/lang/pc/comp/def.H new file mode 100644 index 000000000..078b96de8 --- /dev/null +++ b/lang/pc/comp/def.H @@ -0,0 +1,134 @@ +/* I D E N T I F I E R D E S C R I P T O R S T R U C T U R E */ + +struct constant { + struct node *co_const; /* result of a constant expression */ +#define con_const df_value.df_constant.co_const +}; + +struct variable { + arith va_off; /* address of variable */ + char *va_name; /* name of variable if given */ +#define var_off df_value.df_variable.va_off +#define var_name df_value.df_variable.va_name +}; + +struct bound { + struct type *bo_type; /* type of conformant array */ +#define bnd_type df_value.df_bound.bo_type +}; + +struct enumval { + unsigned int en_val; /* value of this enumeration literal */ + struct def *en_next; /* next enumeration literal */ +#define enm_val df_value.df_enum.en_val +#define enm_next df_value.df_enum.en_next +}; + +struct field { + arith fd_off; + unsigned short fd_flags; +#define F_SELECTOR 0x1 /* set if field is a variant selector */ +#define F_PACKED 0x2 /* set if record is packed */ + +#define fld_off df_value.df_field.fd_off +#define fld_flags df_value.df_field.fd_flags +}; + +struct lab { + struct lab *lb_next; /* list of goto statements to this label */ + int lb_level; /* level of nesting */ + label lb_no; /* instruction label */ + label lb_descr; /* label of goto descriptor */ +#define lab_next df_value.df_label.lb_next +#define lab_level df_value.df_label.lb_level +#define lab_no df_value.df_label.lb_no +#define lab_descr df_value.df_label.lb_descr +}; + +/* ALLOCDEF "lab" 10 */ + +struct forwtype { + struct forwtype *f_next; + struct node *f_node; + struct type *f_type; +}; + +/* ALLOCDEF "forwtype" 50 */ + +struct dfproc { /* used for procedures and functions */ + struct scopelist *pc_vis; /* scope of this procedure/function */ + char *pc_name; /* internal name */ + arith pc_res; /* offset of function result */ +#define prc_vis df_value.df_proc.pc_vis +#define prc_name df_value.df_proc.pc_name +#define prc_res df_value.df_proc.pc_res +}; + +struct def { /* list of definitions for a name */ + struct def *df_next; /* next definition in definitions chain */ + struct def *df_nextinscope; + /* link all definitions in a scope */ + struct idf *df_idf; /* link back to the name */ + struct scope *df_scope; /* scope in which this definition resides */ + unsigned int df_kind; /* the kind of this definition: */ +#define D_PROCEDURE 0x00001 /* procedure */ +#define D_FUNCTION 0x00002 /* function */ +#define D_TYPE 0x00004 /* a type */ +#define D_CONST 0x00008 /* a constant */ +#define D_ENUM 0x00010 /* an enumeration literal */ +#define D_FIELD 0x00020 /* a field in a record */ +#define D_PROGRAM 0x00040 /* the program */ +#define D_VARIABLE 0x00080 /* a variable */ +#define D_PARAMETER 0x00100 /* program parameter */ +#define D_FORWTYPE 0x00200 /* forward type */ +#define D_FTYPE 0x00400 /* resolved forward type */ +#define D_FWPROCEDURE 0x00800 /* forward procedure */ +#define D_FWFUNCTION 0x01000 /* forward function */ +#define D_LABEL 0x02000 /* a label */ +#define D_LBOUND 0x04000 /* lower bound identifier in conformant array */ +#define D_UBOUND 0x08000 /* upper bound identifier in conformant array */ +#define D_FORWARD 0x10000 /* directive "forward" */ +#define D_EXTERN 0x20000 /* directive "extern" */ +#define D_ERROR 0x40000 /* a compiler generated definition for an + * undefined variable + */ +#define D_VALUE (D_FUNCTION | D_CONST | D_ENUM | D_FIELD | D_VARIABLE\ + | D_FWFUNCTION | D_LBOUND | D_UBOUND) +#define D_ROUTINE (D_FUNCTION | D_FWFUNCTION | D_PROCEDURE | D_FWPROCEDURE) + unsigned short df_flags; +#define D_NOREG 0x01 /* set if it may not reside in a register */ +#define D_VALPAR 0x02 /* set if it is a value parameter */ +#define D_VARPAR 0x04 /* set if it is a var parameter */ +#define D_LOOPVAR 0x08 /* set if it is a contol-variable */ +#define D_EXTERNAL 0x10 /* set if proc/func is external declared */ +#define D_PROGPAR 0x20 /* set if input/output was mentioned in + * the program-heading + */ + struct type *df_type; + union { + struct constant df_constant; + struct variable df_variable; + struct bound df_bound; + struct enumval df_enum; + struct field df_field; + struct lab df_label; + struct forwtype *df_fwtype; + struct dfproc df_proc; + int df_reqname; /* define for required name */ + } df_value; +#define df_fortype df_value.df_fwtype +}; + +/* ALLOCDEF "def" 50 */ + +extern struct def + *define(), + *MkDef(), + *DeclProc(), + *DeclFunc(); + +extern struct def + *lookup(), + *lookfor(); + +#define NULLDEF ((struct def *) 0) diff --git a/lang/pc/comp/def.c b/lang/pc/comp/def.c new file mode 100644 index 000000000..124ab7d24 --- /dev/null +++ b/lang/pc/comp/def.c @@ -0,0 +1,226 @@ +/* D E F I N I T I O N M E C H A N I S M */ + +#include "debug.h" + +#include +#include +#include +#include + +#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; +} diff --git a/lang/pc/comp/desig.H b/lang/pc/comp/desig.H new file mode 100644 index 000000000..ff4849dcd --- /dev/null +++ b/lang/pc/comp/desig.H @@ -0,0 +1,59 @@ +/* D E S I G N A T O R D E S C R I P T I O N S */ + +/* Generating code for designators is not particularly easy, especially if + you don't know whether you want the address or the value. + The next structure is used to generate code for designators. + It contains information on how to find the designator, after generation + of the code that is common to both address and value computations. +*/ + +struct desig { + int dsg_kind; +#define DSG_INIT 0 /* don't know anything yet */ +#define DSG_LOADED 1 /* designator loaded on top of the stack */ +#define DSG_PLOADED 2 /* designator accessible through pointer on + stack, possibly with an offset + */ +#define DSG_FIXED 3 /* designator directly accessible */ +#define DSG_PFIXED 4 /* designator accessible through directly + accessible pointer + */ +#define DSG_INDEXED 5 /* designator accessible through array + operation. Address of array descriptor on + top of the stack, index beneath that, and + base address beneath that + */ + arith dsg_offset; /* contains an offset for PLOADED, + or for FIXED or PFIXED it contains an + offset from dsg_name, if it exists, + or from the current Local Base + */ + char *dsg_name; /* name of global variable, used for + FIXED and PFIXED + */ + struct def *dsg_def; /* def structure associated with this + designator, or 0 + */ + int dsg_packed; /* designator is packed or not */ +}; + +/* The next structure describes the designator in a with-statement. + We have a linked list of them, as with-statements may be nested. +*/ + +struct withdesig { + struct withdesig *w_next; + struct scope *w_scope; /* scope in which fields of this record + reside + */ + struct desig w_desig; /* a desig structure for this particular + designator + */ +}; + +/* ALLOCDEF "withdesig" 5 */ + +extern struct withdesig *WithDesigs; +extern struct desig InitDesig; + +#define NO_LABEL ((label) 0) diff --git a/lang/pc/comp/desig.c b/lang/pc/comp/desig.c new file mode 100644 index 000000000..639a85063 --- /dev/null +++ b/lang/pc/comp/desig.c @@ -0,0 +1,565 @@ +/* D E S I G N A T O R E V A L U A T I O N */ + +/* Code generation for designators. + This file contains some routines that generate code common to address + as well as value computations, and leave a description in a "desig" + structure. It also contains routines to load an address, load a value + or perform a store. +*/ + +#include "debug.h" + +#include +#include + +#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"); + } +} diff --git a/lang/pc/comp/em_pc.6 b/lang/pc/comp/em_pc.6 new file mode 100644 index 000000000..59bb7b894 --- /dev/null +++ b/lang/pc/comp/em_pc.6 @@ -0,0 +1,61 @@ +.TH EM_PC ACK +.ad +.SH NAME +em_pc \- Pascal compiler +.SH SYNOPSIS +.B em_pc +.RI [ option ] +.I source +.I destination +.SH DESCRIPTION +.I Em_pc +is a compiler that translates Pascal programs into EM code. +The input is taken from +.IR source , +while the EM code is written on +.IR destination . +.br +.I Option +is a, possibly empty, sequence of the following combinations: +.IP \fB\-M\fP\fIn\fP +set maximum identifier length to \fIn\fP. +The minimum value for \fIn\fR is 9, because the keyword +"PROCEDURE" is that long. +.IP \fB\-n\fR +do not generate EM register messages. +The user-declared variables will not be stored into registers on the target +machine. +.IP \fB\-L\fR +do not generate the EM \fBfil\fR and \fBlin\fR instructions that enable +an interpreter to keep track of the current location in the source code. +.IP \fB\-V\fIcm\fR.\fIn\fR,\ \fB\-V\fIcm\fR.\fIncm\fR.\fIn\fR\ ... +.br +set the size and alignment requirements. +The letter \fIc\fR indicates the simple type, which is one of +\fBw\fR(word size), \fBi\fR(INTEGER), \fBf\fR(REAL), or \fBp\fR(POINTER). +It may also be the letter \fBS\fR, indicating that an initial +record alignment follows. +The \fIm\fR parameter can be used to specify the length of the type (in bytes) +and the \fIn\fR parameter for the alignment of that type. +Absence of \fIm\fR or \fIn\fR causes a default value to be retained. +.IP \fB\-w\fR +suppress warning messages. +.IP \fB\-u\fR +The character '_' is treated like a letter, so it is allowed to use the +underscore in identifiers. +.IP \fB\-i\fR\fInum\fR +maximum number of bits in a set. When not used, a default value is +retained. +.IP \fB\-C\fR +The lower case and upper case letters are treated different. +.IP \fB\-r\fR +The rangechecks are generated where necessary. +.LP +.SH FILES +.IR ~em/lib/em_pc : +binary of the Pascal compiler. +.SH DIAGNOSTICS +All warning and error messages are written on standard error output. +.SH REMARKS +Debugging and profiling facilities may be present during the development +of \fIem_pc\fP. diff --git a/lang/pc/comp/enter.c b/lang/pc/comp/enter.c new file mode 100644 index 000000000..2691a1ebd --- /dev/null +++ b/lang/pc/comp/enter.c @@ -0,0 +1,227 @@ +/* H I G H L E V E L S Y M B O L E N T R Y */ + +#include +#include +#include +#include + +#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; +} diff --git a/lang/pc/comp/error.c b/lang/pc/comp/error.c new file mode 100644 index 000000000..340786e80 --- /dev/null +++ b/lang/pc/comp/error.c @@ -0,0 +1,214 @@ +/* E R R O R A N D D I A G N O S T I C R O U T I N E S */ + +/* This file contains the (non-portable) error-message and diagnostic + giving functions. Be aware that they are called with a variable + number of arguments! +*/ + +#include "debug.h" +#include "errout.h" + +#include +#include +#include +#include + +#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"); +} diff --git a/lang/pc/comp/expression.g b/lang/pc/comp/expression.g new file mode 100644 index 000000000..0dfe6808a --- /dev/null +++ b/lang/pc/comp/expression.g @@ -0,0 +1,290 @@ +/* EXPRESSIONS */ + +{ +#include "debug.h" + +#include +#include +#include + +#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) +; diff --git a/lang/pc/comp/f_info.h b/lang/pc/comp/f_info.h new file mode 100644 index 000000000..7efbec727 --- /dev/null +++ b/lang/pc/comp/f_info.h @@ -0,0 +1,11 @@ +/* F I L E D E S C R I P T O R S T R U C T U R E */ + +struct f_info { + unsigned short f_lineno; + char *f_filename; + char *f_workingdir; +}; + +extern struct f_info file_info; +#define LineNumber file_info.f_lineno +#define FileName file_info.f_filename diff --git a/lang/pc/comp/idf.c b/lang/pc/comp/idf.c new file mode 100644 index 000000000..6fc41b525 --- /dev/null +++ b/lang/pc/comp/idf.c @@ -0,0 +1,4 @@ +/* I N S T A N T I A T I O N O F I D F P A C K A G E */ + +#include "idf.h" +#include diff --git a/lang/pc/comp/idf.h b/lang/pc/comp/idf.h new file mode 100644 index 000000000..62e72bb57 --- /dev/null +++ b/lang/pc/comp/idf.h @@ -0,0 +1,12 @@ +/* U S E R D E C L A R E D P A R T O F I D F */ + +struct id_u { + int id_res; + struct def *id_df; +}; + +#define IDF_TYPE struct id_u +#define id_reserved id_user.id_res +#define id_def id_user.id_df + +#include diff --git a/lang/pc/comp/input.c b/lang/pc/comp/input.c new file mode 100644 index 000000000..44759fc20 --- /dev/null +++ b/lang/pc/comp/input.c @@ -0,0 +1,17 @@ +/* I N S T A N T I A T I O N O F I N P U T P A C K A G E */ + +#include "f_info.h" +struct f_info file_info; +#include "input.h" +#include +#include "idf.h" +#include + + +AtEoIF() +{ + /* Make the unstacking of input streams noticable to the + lexical analyzer + */ + return 1; +} diff --git a/lang/pc/comp/input.h b/lang/pc/comp/input.h new file mode 100644 index 000000000..fcdeb21cb --- /dev/null +++ b/lang/pc/comp/input.h @@ -0,0 +1,9 @@ +/* I N S T A N T I A T I O N O F I N P U T M O D U L E */ + +#include "inputtype.h" + +#define INP_NPUSHBACK 3 +#define INP_TYPE struct f_info +#define INP_VAR file_info + +#include diff --git a/lang/pc/comp/label.c b/lang/pc/comp/label.c new file mode 100644 index 000000000..db2d8f660 --- /dev/null +++ b/lang/pc/comp/label.c @@ -0,0 +1,165 @@ +/* L A B E L H A N D L I N G */ + +#include +#include + +#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); + } +} diff --git a/lang/pc/comp/lookup.c b/lang/pc/comp/lookup.c new file mode 100644 index 000000000..0b21704d5 --- /dev/null +++ b/lang/pc/comp/lookup.c @@ -0,0 +1,65 @@ +/* L O O K U P R O U T I N E S */ + +#include +#include + +#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; +} diff --git a/lang/pc/comp/main.c b/lang/pc/comp/main.c new file mode 100644 index 000000000..76da21697 --- /dev/null +++ b/lang/pc/comp/main.c @@ -0,0 +1,224 @@ +/* M A I N P R O G R A M */ + +#include "debug.h" + +#include +#include +#include + +#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 diff --git a/lang/pc/comp/main.h b/lang/pc/comp/main.h new file mode 100644 index 000000000..3b5d0849b --- /dev/null +++ b/lang/pc/comp/main.h @@ -0,0 +1,13 @@ +/* S O M E G L O B A L V A R I A B L E S */ + +extern char options[]; /* indicating which options were given */ +extern char *input; /* name of required filevariable */ +extern char *output; /* name of required filevariable */ + +extern struct def *program; /* definition of the program compiled */ + +extern int proclevel; /* nesting level of procedures */ +extern int err_occurred; + +extern label data_label; +extern label text_label; diff --git a/lang/pc/comp/make.allocd b/lang/pc/comp/make.allocd new file mode 100755 index 000000000..c4dd3e17c --- /dev/null +++ b/lang/pc/comp/make.allocd @@ -0,0 +1,26 @@ +sed -e ' +s:^.*[ ]ALLOCDEF[ ].*"\(.*\)"[ ]*\([0-9][0-9]*\).*$:\ +/* allocation definitions of struct \1 */\ +extern char *st_alloc();\ +extern struct \1 *h_\1;\ +#ifdef DEBUG\ +extern int cnt_\1;\ +extern char *std_alloc();\ +#define new_\1() ((struct \1 *) std_alloc((char **)\&h_\1, sizeof(struct \1), \2, \&cnt_\1))\ +#else\ +#define new_\1() ((struct \1 *) st_alloc((char **)\&h_\1, sizeof(struct \1), \2))\ +#endif\ +#define free_\1(p) st_free(p, \&h_\1, sizeof(struct \1))\ +:' -e ' +s:^.*[ ]STATICALLOCDEF[ ].*"\(.*\)"[ ]*\([0-9][0-9]*\).*$:\ +/* allocation definitions of struct \1 */\ +extern char *st_alloc();\ +struct \1 *h_\1;\ +#ifdef DEBUG\ +int cnt_\1;\ +#define new_\1() ((struct \1 *) std_alloc((char **)\&h_\1, sizeof(struct \1), \2, \&cnt_\1))\ +#else\ +#define new_\1() ((struct \1 *) st_alloc((char **)\&h_\1, sizeof(struct \1), \2))\ +#endif\ +#define free_\1(p) st_free(p, \&h_\1, sizeof(struct \1))\ +:' diff --git a/lang/pc/comp/make.hfiles b/lang/pc/comp/make.hfiles new file mode 100755 index 000000000..2132dd618 --- /dev/null +++ b/lang/pc/comp/make.hfiles @@ -0,0 +1,35 @@ +: Update Files from database + +PATH=/bin:/usr/bin + +case $# in +1) ;; +*) echo use: $0 file >&2 + exit 1 +esac + +( +IFCOMMAND="if (<\$FN) 2>/dev/null;\ + then if cmp -s \$FN \$TMP;\ + then rm \$TMP;\ + else mv \$TMP \$FN;\ + echo update \$FN;\ + fi;\ + else mv \$TMP \$FN;\ + echo create \$FN;\ + fi" +echo 'TMP=.uf$$' +echo 'FN=$TMP' +echo 'cat >$TMP <<\!EOF!' +sed -n '/^!File:/,${ +/^$/d +/^!File:[ ]*\(.*\)$/s@@!EOF!\ +'"$IFCOMMAND"'\ +FN=\1\ +cat >$TMP <<\\!EOF!@ +p +}' $1 +echo '!EOF!' +echo $IFCOMMAND +) | +sh diff --git a/lang/pc/comp/make.next b/lang/pc/comp/make.next new file mode 100755 index 000000000..727867594 --- /dev/null +++ b/lang/pc/comp/make.next @@ -0,0 +1,7 @@ +echo '#include "debug.h"' +sed -n ' +s:^.*[ ]ALLOCDEF[ ].*"\(.*\)".*$:struct \1 *h_\1 = 0;\ +#ifdef DEBUG\ +int cnt_\1 = 0;\ +#endif:p +' $* diff --git a/lang/pc/comp/make.tokcase b/lang/pc/comp/make.tokcase new file mode 100755 index 000000000..ef32292f9 --- /dev/null +++ b/lang/pc/comp/make.tokcase @@ -0,0 +1,34 @@ +cat <<'--EOT--' +#include "Lpars.h" + +char * +symbol2str(tok) + int tok; +{ + static char buf[2] = { '\0', '\0' }; + + if (040 <= tok && tok < 0177) { + buf[0] = tok; + buf[1] = '\0'; + return buf; + } + switch (tok) { +--EOT-- +sed ' +/{[A-Z]/!d +s/.*{\(.*\),.*\(".*"\).*$/ case \1 :\ + return \2;/ +' +cat <<'--EOT--' + case '\n': + case '\f': + case '\v': + case '\r': + case '\t': + buf[0] = tok; + return buf; + default: + return "bad token"; + } +} +--EOT-- diff --git a/lang/pc/comp/make.tokfile b/lang/pc/comp/make.tokfile new file mode 100755 index 000000000..494b7e3cc --- /dev/null +++ b/lang/pc/comp/make.tokfile @@ -0,0 +1,6 @@ +sed ' +/{[A-Z]/!d +s/.*{// +s/,.*// +s/.*/%token &;/ +' diff --git a/lang/pc/comp/misc.c b/lang/pc/comp/misc.c new file mode 100644 index 000000000..9e4f871e3 --- /dev/null +++ b/lang/pc/comp/misc.c @@ -0,0 +1,60 @@ +/* M I S C E L L A N E O U S R O U T I N E S */ + +#include +#include + +#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; + } + +} diff --git a/lang/pc/comp/misc.h b/lang/pc/comp/misc.h new file mode 100644 index 000000000..cb9c9b274 --- /dev/null +++ b/lang/pc/comp/misc.h @@ -0,0 +1,10 @@ +/* M I S C E L L A N E O U S */ + +#define is_anon_idf(x) ((x)->id_text[0] == '#') +#define id_not_declared(x) (not_declared("identifier", (x), "")) + +extern struct idf + *gen_anon_idf(); + +extern char + *gen_proc_name(); diff --git a/lang/pc/comp/next.c b/lang/pc/comp/next.c new file mode 100644 index 000000000..dc5064a03 --- /dev/null +++ b/lang/pc/comp/next.c @@ -0,0 +1,49 @@ +#include "debug.h" +struct lab *h_lab = 0; +#ifdef DEBUG +int cnt_lab = 0; +#endif +struct forwtype *h_forwtype = 0; +#ifdef DEBUG +int cnt_forwtype = 0; +#endif +struct def *h_def = 0; +#ifdef DEBUG +int cnt_def = 0; +#endif +struct withdesig *h_withdesig = 0; +#ifdef DEBUG +int cnt_withdesig = 0; +#endif +struct node *h_node = 0; +#ifdef DEBUG +int cnt_node = 0; +#endif +struct scope *h_scope = 0; +#ifdef DEBUG +int cnt_scope = 0; +#endif +struct scopelist *h_scopelist = 0; +#ifdef DEBUG +int cnt_scopelist = 0; +#endif +struct paramlist *h_paramlist = 0; +#ifdef DEBUG +int cnt_paramlist = 0; +#endif +struct type *h_type = 0; +#ifdef DEBUG +int cnt_type = 0; +#endif +struct case_hdr *h_case_hdr = 0; +#ifdef DEBUG +int cnt_case_hdr = 0; +#endif +struct case_entry *h_case_entry = 0; +#ifdef DEBUG +int cnt_case_entry = 0; +#endif +struct tmpvar *h_tmpvar = 0; +#ifdef DEBUG +int cnt_tmpvar = 0; +#endif diff --git a/lang/pc/comp/node.H b/lang/pc/comp/node.H new file mode 100644 index 000000000..b51476ade --- /dev/null +++ b/lang/pc/comp/node.H @@ -0,0 +1,47 @@ +/* N O D E O F A N A B S T R A C T P A R S E T R E E */ + +struct node { + struct node *nd_left; +#define nd_next nd_left + struct node *nd_right; + int nd_class; /* kind of node */ +#define Value 0 /* constant */ +#define Name 1 /* an identifier */ +#define Uoper 2 /* unary operator */ +#define Boper 3 /* binary operator */ +#define Xset 4 /* a set */ +#define Set 5 /* a set constant */ +#define Call 6 /* a function call */ +#define NameOrCall 7 /* call or name of function */ +#define Arrow 8 /* ^ construction */ +#define Arrsel 9 /* array selection */ +#define Def 10 /* an identified name */ +#define Link 11 +#define LinkDef 12 +#define Cast 13 /* convert integer to real */ + /* do NOT change the order or the numbers!!! */ + struct type *nd_type; /* type of this node */ + struct token nd_token; +#define nd_def nd_token.tk_data.tk_def +#define nd_set nd_token.tk_data.tk_set +#define nd_lab nd_token.tk_data.tk_lab +#define nd_symb nd_token.tk_symb +#define nd_lineno nd_token.tk_lineno +#define nd_IDF nd_token.TOK_IDF +#define nd_STR nd_token.TOK_STR +#define nd_SLE nd_token.TOK_SLE +#define nd_SLA nd_token.TOK_SLA +#define nd_INT nd_token.TOK_INT +#define nd_REL nd_token.TOK_REL +#define nd_RLA nd_token.TOK_RLA +#define nd_RIV nd_token.TOK_RIV +#define nd_RSI nd_token.TOK_RSI +}; + +/* ALLOCDEF "node" 50 */ + +extern struct node *MkNode(), *MkLeaf(), *ChkStdInOut(); + +#define IsProcCall(lnd) ((lnd)->nd_type->tp_fund & T_ROUTINE) + +#define NULLNODE ((struct node *) 0) diff --git a/lang/pc/comp/node.c b/lang/pc/comp/node.c new file mode 100644 index 000000000..bdb1804cb --- /dev/null +++ b/lang/pc/comp/node.c @@ -0,0 +1,95 @@ +/* N O D E O F A N A B S T R A C T P A R S E T R E E */ + +#include "debug.h" + +#include +#include +#include +#include + +#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("\n"); + return; + } + PrNode(nd->nd_left, lvl + 1); + printnode(nd, lvl); + PrNode(nd->nd_right, lvl + 1); +} +#endif diff --git a/lang/pc/comp/options.c b/lang/pc/comp/options.c new file mode 100644 index 000000000..18753db0d --- /dev/null +++ b/lang/pc/comp/options.c @@ -0,0 +1,151 @@ +/* U S E R O P T I O N - H A N D L I N G */ + +#include +#include + +#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"); + 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; +} diff --git a/lang/pc/comp/program.g b/lang/pc/comp/program.g new file mode 100644 index 000000000..faa1d50b2 --- /dev/null +++ b/lang/pc/comp/program.g @@ -0,0 +1,49 @@ +/* The grammar of ISO-Pascal as given by the specification, BS6192: 1982. */ + +{ +#include +#include +#include + +#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); } +; diff --git a/lang/pc/comp/progs.c b/lang/pc/comp/progs.c new file mode 100644 index 000000000..31f8230f6 --- /dev/null +++ b/lang/pc/comp/progs.c @@ -0,0 +1,71 @@ +/* TYDELYK !!!!!! */ + +#include "debug.h" + +#include +#include + +#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); +} diff --git a/lang/pc/comp/readwrite.c b/lang/pc/comp/readwrite.c new file mode 100644 index 000000000..4afb2c513 --- /dev/null +++ b/lang/pc/comp/readwrite.c @@ -0,0 +1,421 @@ +/* R E A D ( L N ) & W R I T E ( L N ) */ + +#include "debug.h" + +#include +#include + +#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); +} diff --git a/lang/pc/comp/required.h b/lang/pc/comp/required.h new file mode 100644 index 000000000..1a0bb669a --- /dev/null +++ b/lang/pc/comp/required.h @@ -0,0 +1,43 @@ +/* REQUIRED PROCEDURES AND FUNCTIONS */ + +/* PROCEDURES */ +/* FILE HANDLING */ +#define R_REWRITE 1 +#define R_PUT 2 +#define R_RESET 3 +#define R_GET 4 +#define R_PAGE 5 + +/* DYNAMIC ALLOCATION */ +#define R_NEW 6 +#define R_DISPOSE 7 + +/* TRANSFER */ +#define R_PACK 8 +#define R_UNPACK 9 + +/* FUNCTIONS */ +/* ARITHMETIC */ +#define R_ABS 10 +#define R_SQR 11 +#define R_SIN 12 +#define R_COS 13 +#define R_EXP 14 +#define R_LN 15 +#define R_SQRT 16 +#define R_ARCTAN 17 + +/* TRANSFER */ +#define R_TRUNC 18 +#define R_ROUND 19 + +/* ORDINAL */ +#define R_ORD 20 +#define R_CHR 21 +#define R_SUCC 22 +#define R_PRED 23 + +/* BOOLEAN */ +#define R_ODD 24 +#define R_EOF 25 +#define R_EOLN 26 diff --git a/lang/pc/comp/scope.H b/lang/pc/comp/scope.H new file mode 100644 index 000000000..791922f66 --- /dev/null +++ b/lang/pc/comp/scope.H @@ -0,0 +1,31 @@ +/* S C O P E M E C H A N I S M */ + +struct scope { + struct scope *next; + struct def *sc_def; /* list of definitions in this scope */ + int sc_level; /* level of this scope */ + arith sc_off; /* offsets of variables in this scope */ + struct node *sc_lablist;/* list of labels in this scope, to speed + up label handling + */ +}; + +/* ALLOCDEF "scope" 10 */ + +struct scopelist { + struct scopelist *next; + struct scope *sc_scope; +}; + +/* ALLOCDEF "scopelist" 10 */ + +extern struct scope + *GlobalScope, + *PervasiveScope, + *BlockScope; + +extern struct scopelist + *CurrVis; + +#define CurrentScope (CurrVis->sc_scope) +#define nextvisible(x) ((x)->next) /* use with scopelists */ diff --git a/lang/pc/comp/scope.c b/lang/pc/comp/scope.c new file mode 100644 index 000000000..3f4f70f7a --- /dev/null +++ b/lang/pc/comp/scope.c @@ -0,0 +1,111 @@ +/* S C O P E M E C H A N I S M */ + +#include "debug.h" + +#include +#include +#include +#include + +#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; + } +} diff --git a/lang/pc/comp/statement.g b/lang/pc/comp/statement.g new file mode 100644 index 000000000..c4a326d64 --- /dev/null +++ b/lang/pc/comp/statement.g @@ -0,0 +1,442 @@ +/* S T A T E M E N T S */ +{ +#include +#include + +#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; + } + ]? + ]? +; diff --git a/lang/pc/comp/tab.c b/lang/pc/comp/tab.c new file mode 100644 index 000000000..17065cf9b --- /dev/null +++ b/lang/pc/comp/tab.c @@ -0,0 +1,295 @@ +/* @cc tab.c -o $INSTALLDIR/tab@ + tab - table generator + + Author: Erik Baalbergen (..tjalk!erikb) +*/ + +#include + +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); + } + } +} diff --git a/lang/pc/comp/tmpvar.C b/lang/pc/comp/tmpvar.C new file mode 100644 index 000000000..fbf76de69 --- /dev/null +++ b/lang/pc/comp/tmpvar.C @@ -0,0 +1,127 @@ +/* T E M P O R A R Y V A R I A B L E S */ + +/* Code for the allocation and de-allocation of temporary variables, + allowing re-use. + The routines use "ProcScope" instead of "CurrentScope", because + "CurrentScope" also reflects WITH statements, and these scopes do not + have local variables. +*/ + +#include "debug.h" + +#include +#include +#include +#include + +#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; +} diff --git a/lang/pc/comp/tokenname.c b/lang/pc/comp/tokenname.c new file mode 100644 index 000000000..4c9d6baa7 --- /dev/null +++ b/lang/pc/comp/tokenname.c @@ -0,0 +1,98 @@ +/* T O K E N D E F I N I T I O N S */ + +#include "Lpars.h" +#include "idf.h" +#include "tokenname.h" + +/* To centralize the declaration of %tokens, their presence in this + file is taken as their declaration. The Makefile will produce + a grammar file (tokenfile.g) from this file. This scheme ensures + that all tokens have a printable name. + Also, the "symbol2str.c" file is produced from this file. +*/ + +struct tokenname tkspec[] = { /* the names of the special tokens */ + {IDENT, "identifier"}, + {STRING, "string"}, + {INTEGER, "integer"}, + {REAL, "real"}, + {0, ""} +}; + +struct tokenname tkcomp[] = { /* names of the composite tokens */ + {LESSEQUAL, "<="}, + {GREATEREQUAL, ">="}, + {NOTEQUAL, "<>"}, + {UPTO, ".."}, + {BECOMES, ":="}, + {0, ""} +}; + +struct tokenname tkidf[] = { /* names of the identifier tokens */ + {AND, "and"}, + {ARRAY, "array"}, + {BEGIN, "begin"}, + {CASE, "case"}, + {CONST, "const"}, + {DIV, "div"}, + {DO, "do"}, + {DOWNTO, "downto"}, + {ELSE, "else"}, + {END, "end"}, + {FILE, "file"}, + {FOR, "for"}, + {FUNCTION, "function"}, + {GOTO, "goto"}, + {IF, "if"}, + {IN, "in"}, + {LABEL, "label"}, + {MOD, "mod"}, + {NIL, "nil"}, + {NOT, "not"}, + {OF, "of"}, + {OR, "or"}, + {PACKED, "packed"}, + {PROCEDURE, "procedure"}, + {PROGRAM, "program"}, + {RECORD, "record"}, + {REPEAT, "repeat"}, + {SET, "set"}, + {THEN, "then"}, + {TO, "to"}, + {TYPE, "type"}, + {UNTIL, "until"}, + {VAR, "var"}, + {WHILE, "while"}, + {WITH, "with"}, + {0, ""} +}; + +struct tokenname tkstandard[] = { /* standard identifiers */ + /* These are the only standard identifiers entered here, because + * they can get a variable number of arguments, and there are + * special syntaxrules in the grammar for them + */ + {READ, "read"}, + {READLN, "readln"}, + {WRITE, "write"}, + {WRITELN, "writeln"}, + {0, ""} +}; + +/* Some routines to handle tokennames */ + +reserve(resv) + register struct tokenname *resv; +{ + /* The names of the tokens described in resv are entered + as reserved words. + */ + register struct idf *p; + + while( resv->tn_symbol ) { + p = str2idf(resv->tn_name, 0); + if( !p ) fatal("out of Memory"); + p->id_reserved = resv->tn_symbol; + resv++; + } +} diff --git a/lang/pc/comp/tokenname.h b/lang/pc/comp/tokenname.h new file mode 100644 index 000000000..79ccdc4cd --- /dev/null +++ b/lang/pc/comp/tokenname.h @@ -0,0 +1,8 @@ +/* T O K E N N A M E S T R U C T U R E */ + +struct tokenname { /* Used for defining the name of a + token as identified by its symbol + */ + int tn_symbol; + char *tn_name; +}; diff --git a/lang/pc/comp/type.H b/lang/pc/comp/type.H new file mode 100644 index 000000000..117c062b1 --- /dev/null +++ b/lang/pc/comp/type.H @@ -0,0 +1,166 @@ +/* T Y P E D E S C R I P T O R S T R U C T U R E */ + +struct paramlist { /* structure for parameterlist of a PROCEDURE */ + struct paramlist *next; + struct def *par_def; /* "df" of parameter */ +#define IsVarParam(xpar) ((xpar)->par_def->df_flags & D_VARPAR) +#define TypeOfParam(xpar) ((xpar)->par_def->df_type) +}; + +/* ALLOCDEF "paramlist" 50 */ + +struct enume { + unsigned int en_ncst; /* number of constants */ + label en_rck; /* label of range check descriptor */ +#define enm_ncst tp_value.tp_enum.en_ncst +#define enm_rck tp_value.tp_enum.en_rck +}; + +struct subrange { + arith su_lb, su_ub; /* lower bound and upper bound */ + label su_rck; /* label of range check descriptor */ +#define sub_lb tp_value.tp_subrange.su_lb +#define sub_ub tp_value.tp_subrange.su_ub +#define sub_rck tp_value.tp_subrange.su_rck +}; + +struct array { + struct type *ar_elem; /* type of elements */ + union { + struct { /* normal array */ + arith ar_elsize; /* size of elements */ + label ar_descr; /* label of array descriptor */ + } norm_arr; + struct { /* conformant array */ + int cf_sclevel; /* scope level of declaration */ + arith cf_descr; /* offset array descriptor */ + } conf_arr; + } ar_type; +#define arr_elem tp_value.tp_arr.ar_elem +#define arr_elsize tp_value.tp_arr.ar_type.norm_arr.ar_elsize +#define arr_ardescr tp_value.tp_arr.ar_type.norm_arr.ar_descr +#define arr_cfdescr tp_value.tp_arr.ar_type.conf_arr.cf_descr +#define arr_sclevel tp_value.tp_arr.ar_type.conf_arr.cf_sclevel +}; + +struct selector { + struct type *sel_type; /* type of the selector of a variant */ + arith sel_ncst; /* number of values of selector type */ + arith sel_lb; /* lower bound of selector type */ + struct selector **sel_ptrs; /* tagvalue table with pointers to + nested variant-selectors */ +}; + +struct record { + struct scope *rc_scope; /* scope of this record */ + /* members are in the symbol table */ + struct selector *rc_selector; /* selector of variant (if present) */ +#define rec_scope tp_value.tp_record.rc_scope +#define rec_sel tp_value.tp_record.rc_selector +}; + +struct proc { + struct paramlist *pr_params; + arith pr_nbpar; +#define prc_params tp_value.tp_proc.pr_params +#define prc_nbpar tp_value.tp_proc.pr_nbpar +}; + +struct type { + struct type *next; /* used with ARRAY, PROCEDURE, FILE, SET, + POINTER, SUBRANGE */ + int tp_fund; /* fundamental type or constructor */ +#define T_ENUMERATION 0x0001 +#define T_INTEGER 0x0002 +#define T_REAL 0x0004 +#define T_CHAR 0x0008 +#define T_PROCEDURE 0x0010 +#define T_FUNCTION 0x0020 +#define T_FILE 0x0040 +#define T_STRING 0x0080 +#define T_SUBRANGE 0x0100 +#define T_SET 0x0200 +#define T_ARRAY 0x0400 +#define T_RECORD 0x0800 +#define T_POINTER 0x1000 +#define T_ERROR 0x2000 /* bad type */ +#define T_NUMERIC (T_INTEGER | T_REAL) +#define T_INDEX (T_SUBRANGE | T_ENUMERATION | T_CHAR) +#define T_ORDINAL (T_INTEGER | T_INDEX) +#define T_CONSTRUCTED (T_ARRAY | T_SET | T_RECORD | T_FILE | T_STRING) +#define T_ROUTINE (T_FUNCTION | T_PROCEDURE) + unsigned short tp_flags; +#define T_HASFILE 0x1 /* set if type has a filecomponent */ +#define T_PACKED 0x2 /* set if type is packed */ +#define T_CHECKED 0x4 /* set if array has been checked */ + int tp_align; /* alignment requirement of this type */ + int tp_palign; /* in packed structures */ + arith tp_size; /* size of this type */ + arith tp_psize; /* in packed structures */ + union { + struct enume tp_enum; + struct subrange tp_subrange; + struct array tp_arr; + struct record tp_record; + struct proc tp_proc; + } tp_value; +}; + +/* ALLOCDEF "type" 50 */ + +extern struct type + *bool_type, + *char_type, + *int_type, + *real_type, + *std_type, + *text_type, + *nil_type, + *emptyset_type, + *error_type; /* All from type.c */ + +extern int + word_align, + int_align, + pointer_align, + real_align, + struct_align; /* All from type.c */ + +extern arith + word_size, + int_size, + pointer_size, + real_size; /* All from type.c */ + +extern arith + align(); + +struct type + *construct_type(), + *standard_type(), + *proc_type(), + *func_type(), + *set_type(), + *subr_type(); /* All from type.c */ + +#define NULLTYPE ((struct type *) 0) + +#define bounded(tpx) ((tpx)->tp_fund & T_INDEX) +#define WA(sz) (align(sz, (int) word_size)) +#define ResultType(tpx) (assert((tpx)->tp_fund & T_ROUTINE),(tpx)->next) +#define ElementType(tpx) (assert((tpx)->tp_fund & T_SET), (tpx)->next) +#define BaseType(tpx) ((tpx)->tp_fund & T_SUBRANGE ? (tpx)->next :\ + (tpx)) +#define IndexType(tpx) (assert((tpx)->tp_fund == T_ARRAY), (tpx)->next) +#define IsConstructed(tpx) ((tpx)->tp_fund & T_CONSTRUCTED) +#define IsConformantArray(tpx) ((tpx)->tp_fund & T_ARRAY &&\ + (tpx)->tp_size == 0) +#define IsPacked(tpx) ((tpx)->tp_flags & T_PACKED) +#define PointedtoType(tpx) (assert((tpx)->tp_fund == T_POINTER ||\ + (tpx)->tp_fund == T_FILE), (tpx)->next) +#define ParamList(tpx) (assert((tpx)->tp_fund & T_ROUTINE),\ + (tpx)->prc_params) + +extern long full_mask[]; + +#define ufit(n, i) (((n) & ~full_mask[(i)]) == 0) diff --git a/lang/pc/comp/type.c b/lang/pc/comp/type.c new file mode 100644 index 000000000..c9c8128e1 --- /dev/null +++ b/lang/pc/comp/type.c @@ -0,0 +1,599 @@ +/* T Y P E D E F I N I T I O N M E C H A N I S M */ + +#include "debug.h" +#include "target_sizes.h" + +#include +#include +#include + +#include + +#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 diff --git a/lang/pc/comp/typequiv.c b/lang/pc/comp/typequiv.c new file mode 100644 index 000000000..860a4de10 --- /dev/null +++ b/lang/pc/comp/typequiv.c @@ -0,0 +1,291 @@ +/* T Y P E E Q U I V A L E N C E */ + +/* Routines for testing type equivalence & type compatibility. +*/ + +#include "debug.h" + +#include +#include +#include + +#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); +}