LLmessage.c
Makefile
Parameters
+Resolve
body.c
casestat.C
char.tab
make.tokfile
misc.c
misc.h
+nmclash.c
node.H
node.c
options.c
*asidetype;
static int eofseen;
+extern int in_compound;
+
+int tokenseen = 0; /* Some comment-options must precede any program text */
+
+/* Warning: The options specified inside comments take precedence over
+ * the ones on the command line.
+ */
+CommentOptions()
+{
+ register int ch, ci;
+ /* Parse options inside comments */
+
+ do {
+ LoadChar(ch);
+ ci = ch;
+ switch ( ci ) {
+ case 'c': /* for strings */
+ case 'd': /* for longs */
+ case 's': /* check for standard */
+ case 'u': /* for underscores */
+ case 'C': /* for different cases */
+ case 'U': /* for underscores */
+ if( tokenseen ) {
+ lexwarning("the '%c' option must precede any program text", ci);
+ break;
+ }
+
+ LoadChar(ch);
+ if( ci == 's' && options[ci] && ch == '-')
+ lexwarning("option '%c-' overrides previous one", ci);
+ if( ch == '-' ) options[ci] = 0;
+ else if( ch == '+' ) options[ci] = 1;
+ else PushBack();
+ break;
+
+ case 'l': ci = 'L' ; /* for indexing */
+ /* fall through */
+ case 'a': /* assertions */
+ case 't': /* tracing */
+ case 'A': /* extra array range-checks */
+ case 'L': /* FIL & LIN instructions */
+ case 'R': /* range checks */
+ {
+ int on_on_minus = (ci == 'L' || ci == 'R');
+
+ LoadChar(ch);
+ if( ch == '-' ) options[ci] = on_on_minus;
+ else if( ch == '+' ) options[ci] = !on_on_minus;
+ else PushBack();
+ break;
+ }
+
+ case 'i':
+ {
+ register int i=0;
+
+ LoadChar(ch);
+ while( ch >= '0' && ch <= '9' ) {
+ i = 10 * i + (ch - '0');
+ LoadChar(ch);
+ }
+ PushBack();
+ if( tokenseen ) {
+ lexwarning("the '%c' option must precede any program text", ci);
+ break;
+ }
+ if( i <= 0 ) {
+ lexwarning("bad '%c' option", ci);
+ break;
+ }
+ max_intset = i;
+ break;
+ }
+
+ default:
+ break;
+ }
+ LoadChar(ch);
+ } while (ch == ',' );
+
+ PushBack();
+}
+
STATIC
SkipComment()
register int ch;
LoadChar(ch);
+ if (ch == '$') CommentOptions();
for (;;) {
if( class(ch) == STNL ) {
LineNumber++;
}
STATIC struct string *
-GetString()
+GetString( delim )
+register int delim;
{
- /* Read a Pascal string, delimited by the character "'".
+ /* Read a Pascal string, delimited by the character ' or ".
*/
register int ch;
register struct string *str = (struct string *)
str->s_str = p = Malloc((unsigned int) ISTRSIZE);
for( ; ; ) {
LoadChar(ch);
- if( ch & 0200 )
+ if( ch & 0200 ) {
fatal("non-ascii '\\%03o' read", ch & 0377);
/*NOTREACHED*/
+ }
if( class(ch) == STNL ) {
lexerror("newline in string");
LineNumber++;
lexerror("end-of-file in string");
break;
}
- if( ch == '\'' ) {
+ if( ch == delim ) {
LoadChar(ch);
- if( ch != '\'' )
+ if( ch != delim )
break;
}
*p++ = ch;
return str;
}
+static char *s_error = "illegal line directive";
+
+CheckForLineDirective()
+{
+ register int ch;
+ register int i = 0;
+ char buf[IDFSIZE + 2];
+ register char *c = buf;
+
+ LoadChar(ch);
+
+ if( ch != '#' ) {
+ PushBack();
+ return;
+ }
+ do { /*
+ * Skip to next digit. Do not skip newlines.
+ */
+ LoadChar(ch);
+ if( class(ch) == STNL ) {
+ LineNumber++;
+ lexerror(s_error);
+ return;
+ }
+ else if( ch == EOI ) {
+ eofseen = 1;
+ break;
+ }
+ } while( class(ch) != STNUM );
+ while( class(ch) == STNUM ) {
+ i = i * 10 + (ch - '0');
+ LoadChar(ch);
+ }
+ if( ch == EOI ) {
+ eofseen = 1;
+ }
+ while( ch != '"' && ch != EOI && class(ch) != STNL) LoadChar(ch);
+ if( ch == '"' ) {
+ do {
+ LoadChar(ch);
+ *c++ = ch;
+ if( class(ch) == STNL ) {
+ LineNumber++;
+ error(s_error);
+ return;
+ }
+ } while( ch != '"' );
+ *--c = '\0';
+ do {
+ LoadChar(ch);
+ } while( class(ch) != STNL );
+ /*
+ * Remember the filename
+ */
+ if( !eofseen && strcmp(FileName, buf) ) {
+ FileName = Salloc(buf,(unsigned) strlen(buf) + 1);
+ }
+ }
+ if( eofseen ) {
+ error(s_error);
+ return;
+ }
+ LineNumber = i;
+}
+
int
LLlex()
{
tk->tk_lineno = LineNumber;
+again1:
if( eofseen ) {
eofseen = 0;
ch = EOI;
if( !options['C'] ) /* -C : cases are different */
TO_LOWER(ch);
- if( (ch & 0200) && ch != EOI )
+ if( (ch & 0200) && ch != EOI ) {
fatal("non-ascii '\\%03o' read", ch & 0377);
/*NOTREACHED*/
+ }
}
switch( class(ch) ) {
#ifdef DEBUG
cntlines++;
#endif
- goto again;
+ CheckForLineDirective();
+ goto again1;
case STSKIP:
goto again;
case STGARB:
+ if( !tokenseen && (ch == '"' || ch == '_') ) {
+ return tk->tk_symb = ch;
+ }
if( (unsigned) ch < 0177 )
lexerror("garbage char %c", ch);
else
if( nch == '*' ) { /* (* */
SkipComment();
tk->tk_lineno = LineNumber;
- goto again;
+ goto again1;
}
if( nch == '.' ) /* (. is [ */
return tk->tk_symb = '[';
else if( ch == '{' ) {
SkipComment();
tk->tk_lineno = LineNumber;
- goto again;
+ goto again1;
}
else if( ch == '@' ) ch = '^'; /* @ is ^ */
if( ch == EOI ) eofseen = 1;
else PushBack();
+ if( buf[0] == '_' ) lexerror("underscore starts identifier");
tk->TOK_IDF = id = str2idf(buf, 1);
return tk->tk_symb = id->id_reserved ? id->id_reserved : IDENT;
}
case STSTR: {
- register struct string *str = GetString();
+ register struct string *str = GetString(ch);
- if( str->s_length == 1 ) {
+ if( str->s_length == 1 && ch == '\'') {
#ifdef DEBUG
if( options['l'] ) {
/* to prevent LexScan from crashing */
free((char *) str);
}
else {
- tk->tk_data.tk_str = str;
- toktype = standard_type(T_STRING, 1, str->s_length);
+ if( ch == '\'' ) {
+ tk->tk_data.tk_str = str;
+ toktype = standard_type(T_STRINGCONST, 1, str->s_length);
+ }
+ else {
+ tk->tk_data.tk_str = str;
+ toktype = string_type;
+ }
}
return tk->tk_symb = STRING;
}
tk->TOK_REL = Salloc("0.0", 4);
lexerror("floating constant too long");
}
- else tk->TOK_REL = Salloc(buf, np - buf);
+ else tk->TOK_REL = Salloc(buf,(unsigned) (np - buf));
toktype = real_type;
return tk->tk_symb = REAL;
extern struct token dot, aside;
extern struct type *toktype, *asidetype;
+extern int tokenseen;
#define ASIDE aside.tk_symb
extern char *symbol2str();
extern char *Malloc(), *Salloc();
extern struct idf *gen_anon_idf();
+extern int expect_label;
LLmessage(tk)
register int tk;
Malloc(sizeof (struct string));
dotp->TOK_SLE = 1;
dotp->TOK_STR = Salloc("", 1);
- toktype = standard_type(T_STRING, 1, (arith) 1);
+ toktype = standard_type(T_STRINGCONST, 1, (arith) 1);
break;
case INTEGER:
- dotp->TOK_INT = 1;
toktype = int_type;
+ if( !expect_label )
+ dotp->TOK_INT = 1;
+ else
+ dotp->TOK_INT = -1;
break;
case REAL:
dotp->tk_data.tk_real = (struct real *)
# make iso-pascal "compiler"
EMHOME = ../../..
-MHDIR = $(EMHOME)/modules/h
-PKGDIR = $(EMHOME)/modules/pkg
-LIBDIR = $(EMHOME)/modules/lib
-OBJECTCODE = $(LIBDIR)/libemk.a $(EMHOME)/lib/em_data.a
+MDIR = $(EMHOME)/modules
+MHDIR = $(MDIR)/h
+PKGDIR = $(MDIR)/pkg
+LIBDIR = $(MDIR)/lib
+OBJECTCODE = $(LIBDIR)/libemk.a
LLGEN = $(EMHOME)/bin/LLgen
MKDEP = $(EMHOME)/bin/mkdep
-CURRDIR = .
+PRID = $(EMHOME)/bin/prid
+CID = $(EMHOME)/bin/cid
+CURRDIR =
CC = fcc
+CC = cc
PRINTER = vu45
+LINT = lint
INCLUDES = -I$(MHDIR) -I$(EMHOME)/h -I$(PKGDIR)
+OLIBS = $(LIBDIR)/libem_mes.a $(OBJECTCODE) $(LIBDIR)/libinput.a $(LIBDIR)/libassert.a $(LIBDIR)/liballoc.a $(MALLOC) $(LIBDIR)/libprint.a $(LIBDIR)/libstring.a $(LIBDIR)/libsystem.a
+
GFILES = tokenfile.g declar.g expression.g program.g statement.g
LLGENOPTIONS =
PROFILE =
-CFLAGS = $(PROFILE) $(INCLUDES) -DSTATIC=
-LINTFLAGS = -DSTATIC=
+COPTIONS =
+OPTIM= -O
+CFLAGS = $(PROFILE) $(INCLUDES) $(OPTIM) $(COPTIONS) -DSTATIC=
+LINTFLAGS = -DSTATIC= -DNORCSID
MALLOC = $(LIBDIR)/malloc.o
-LFLAGS = $(PROFILE)
+LDFLAGS = -i $(PROFILE)
LSRC = declar.c expression.c program.c statement.c tokenfile.c
LOBJ = declar.o expression.o program.o statement.o tokenfile.o
CSRC = LLlex.c LLmessage.c body.c chk_expr.c code.c\
OBJ = Lpars.o $(COBJ) $(LOBJ)
# Keep the next entries up to date!
-GENCFILES= Lpars.c declar.c expression.c program.c statement.c\
- tokenfile.c symbol2str.c casestat.c tmpvar.c char.c next.c
-SRC = Lpars.c $(CSRC) $(GENCFILES)
+GENCFILES= $(LSRC) Lpars.c symbol2str.c casestat.c tmpvar.c char.c next.c
+SRC = $(CSRC) $(GENCFILES)
GENGFILES= tokenfile.g
GENHFILES= Lpars.h debugcst.h density.h errout.h idfsize.h inputtype.h\
numsize.h strsize.h def.h type.h desig.h scope.h node.h\
- target_sizes.h
+ target_sizes.h nocross.h
HFILES= LLlex.h chk_expr.h class.h const.h debug.h def.h desig.h\
f_info.h idf.h input.h main.h misc.h node.h required.h scope.h\
tokenname.h type.h $(GENHFILES)
#EXCLEXCLEXCLEXCL
all: Cfiles
- make $(CURRDIR)/main
+ sh -c 'if $(CC) nmclash.c > /dev/null 2>&1 ; then make "EMHOME="$(EMHOME) $(CURRDIR)main ; else EMHOME=$(EMHOME); export EMHOME; sh Resolve main ; fi'
+ @rm -f nmclash.o a.out
+
+Omain: Cfiles
+ rm -f *.o
+ sh -c 'if $(CC) nmclash.c > /dev/null 2>&1 ; then make "EMHOME="$(EMHOME) "COPTIONS="-DPEEPHOLE $(CURRDIR)omain ; else EMHOME=$(EMHOME); export EMHOME; ./Resolve omain ; fi'
+ @rm -f nmclash.o a.out
+ mv *.o PEEPHOLE
+
+CEmain: Cfiles
+ rm -f *.o
+ sh -c 'if $(CC) nmclash.c > /dev/null 2>&1 ; then make "EMHOME="$(EMHOME) "COPTIONS="-DCODE_EXPANDER $(CURRDIR)cemain ; else EMHOME=$(EMHOME); export EMHOME; ./Resolve cemain ; fi'
+ @rm -f nmclash.o a.out
+ mv *.o CODE_EXPANDER
+
+install: all
+ cp $(CURRDIR)main $(EMHOME)/lib/em_pc
+
+cmp: all
+ -cmp $(CURRDIR)main $(EMHOME)/lib/em_pc
+
+opr:
+ make pr | opr
+
+pr:
+ @pr Makefile Resolve Parameters $(GFILES) *.H $(HFILES) *.C $(CSRC)
clean:
- rm -f *.o main $(GENFILES) hfiles Cfiles LLfiles
+ rm -f $(OBJ) $(CURRDIR)main $(GENFILES) hfiles Cfiles LLfiles clashes \
+ LL.output
+ (cd .. ; rm -rf Xsrc)
+
+lint: Cfiles
+ sh -c 'if $(CC) nmclash.c > /dev/null 2>&1 ; then make "EMHOME="$(EMHOME) Xlint ; else EMHOME=$(EMHOME); export EMHOME; sh Resolve Xlint ; fi'
+ @rm -f nmclash.o a.out
+
+longnames: $(SRC) $(HFILES)
+ sh -c 'if test -f longnames ; then $(PRID) -l7 longnames $? > Xlongnames ; mv Xlongnames longnames ; else $(PRID) -l7 $? > longnames ; fi'
# entry points not to be used directly
-Cfiles: hfiles LLfiles $(GENCFILES) $(GENHFILES) Makefile
+Cfiles: hfiles LLfiles $(GENCFILES) $(GENHFILES) Makefile
echo $(SRC) $(HFILES) > Cfiles
LLfiles: $(GFILES)
$(LLGEN) $(LLGENOPTIONS) $(GFILES)
@touch LLfiles
-hfiles: Parameters make.hfiles
+hfiles: Parameters make.hfiles
make.hfiles Parameters
touch hfiles
-lint: Cfiles
- lint $(INCLUDES) $(LINTFLAGS) $(SRC)
-
tokenfile.g: tokenname.c make.tokfile
make.tokfile < tokenname.c > tokenfile.g
next.c: $(NEXTFILES) ./make.next
./make.next $(NEXTFILES) > next.c
-char.c: char.tab
+char.c: char.tab
$(EMHOME)/bin/tabgen -fchar.tab > char.c
-depend:
+depend: Cfiles
sed '/^#AUTOAUTO/,$$d' Makefile > Makefile.new
echo '#AUTOAUTOAUTOAUTOAUTOAUTOAUTOAUTO' >> Makefile.new
$(MKDEP) $(SRC) |\
pr -t $? | rpr $(PRINTER)
@touch print
-xref:
+xref:
ctags -x $(CSRC) $(HFILES) | sed "s/).*/)/">Xref
#INCLINCLINCLINCL
-$(CURRDIR)/main: $(OBJ)
- -mv main main.old
- $(CC) $(LFLAGS) $(OBJ) $(LIBDIR)/libem_mes.a $(OBJECTCODE) $(LIBDIR)/libinput.a $(LIBDIR)/liballoc.a $(MALLOC) $(LIBDIR)/libassert.a $(LIBDIR)/libprint.a $(LIBDIR)/libstring.a $(LIBDIR)/libsystem.a -o $(CURRDIR)/main
- size $(CURRDIR)/main.old
- size $(CURRDIR)/main
+Xlint:
+ $(LINT) $(INCLUDES) $(LINTFLAGS) $(SRC) \
+ $(LIBDIR)/llib-lem_mes.ln \
+ $(LIBDIR)/llib-lemk.ln \
+ $(LIBDIR)/llib-linput.ln \
+ $(LIBDIR)/llib-lassert.ln \
+ $(LIBDIR)/llib-lalloc.ln \
+ $(LIBDIR)/llib-lprint.ln \
+ $(LIBDIR)/llib-lstring.ln \
+ $(LIBDIR)/llib-lsystem.ln
+
+$(CURRDIR)main: $(OBJ) $(CURRDIR)Makefile
+ -mv $(CURRDIR)main $(CURRDIR)main.old
+ $(CC) $(LDFLAGS) $(OBJ) $(OLIBS) -o $(CURRDIR)main
+ size $(CURRDIR)main.old
+ size $(CURRDIR)main
+
+$(CURRDIR)omain: $(OBJ) #$(CURRDIR)Makefile
+# #$(CC) $(LDFLAGS) $(OBJ) $(OLIBS) -o $(CURRDIR)omain
+# #size $(CURRDIR)omain
+
+$(CURRDIR)cemain: $(OBJ) #$(CURRDIR)Makefile
+# #$(CC) $(LDFLAGS) $(OBJ) $(OLIBS) -o $(CURRDIR)cemain
+# # #size $(CURRDIR)cemain
#AUTOAUTOAUTOAUTOAUTOAUTOAUTOAUTO
-Lpars.o: Lpars.h
LLlex.o: LLlex.h
LLlex.o: Lpars.h
LLlex.o: class.h
LLlex.o: input.h
LLlex.o: inputtype.h
LLlex.o: main.h
+LLlex.o: nocross.h
LLlex.o: numsize.h
LLlex.o: strsize.h
+LLlex.o: target_sizes.h
LLlex.o: type.h
LLmessage.o: LLlex.h
LLmessage.o: Lpars.h
LLmessage.o: idf.h
+LLmessage.o: nocross.h
+LLmessage.o: target_sizes.h
LLmessage.o: type.h
body.o: LLlex.h
body.o: chk_expr.h
body.o: desig.h
body.o: idf.h
body.o: main.h
+body.o: misc.h
+body.o: nocross.h
body.o: node.h
body.o: scope.h
+body.o: target_sizes.h
body.o: type.h
-casestat.o: LLlex.h
-casestat.o: Lpars.h
-casestat.o: chk_expr.h
-casestat.o: debug.h
-casestat.o: debugcst.h
-casestat.o: density.h
-casestat.o: main.h
-casestat.o: node.h
-casestat.o: type.h
-char.o: class.h
chk_expr.o: LLlex.h
chk_expr.o: Lpars.h
chk_expr.o: chk_expr.h
chk_expr.o: idf.h
chk_expr.o: main.h
chk_expr.o: misc.h
+chk_expr.o: nocross.h
chk_expr.o: node.h
chk_expr.o: required.h
chk_expr.o: scope.h
+chk_expr.o: target_sizes.h
chk_expr.o: type.h
code.o: LLlex.h
code.o: Lpars.h
code.o: def.h
code.o: desig.h
code.o: main.h
+code.o: misc.h
+code.o: nocross.h
code.o: node.h
code.o: required.h
code.o: scope.h
+code.o: target_sizes.h
code.o: type.h
cstoper.o: LLlex.h
cstoper.o: Lpars.h
cstoper.o: const.h
cstoper.o: debug.h
cstoper.o: debugcst.h
+cstoper.o: nocross.h
cstoper.o: node.h
cstoper.o: required.h
cstoper.o: target_sizes.h
def.o: idf.h
def.o: main.h
def.o: misc.h
+def.o: nocross.h
def.o: node.h
def.o: scope.h
+def.o: target_sizes.h
def.o: type.h
desig.o: LLlex.h
desig.o: debug.h
desig.o: debugcst.h
desig.o: def.h
desig.o: desig.h
+desig.o: idf.h
desig.o: main.h
+desig.o: nocross.h
desig.o: node.h
desig.o: scope.h
+desig.o: target_sizes.h
desig.o: type.h
enter.o: LLlex.h
enter.o: def.h
enter.o: idf.h
enter.o: main.h
+enter.o: nocross.h
enter.o: node.h
enter.o: scope.h
+enter.o: target_sizes.h
enter.o: type.h
error.o: LLlex.h
error.o: debug.h
label.o: def.h
label.o: idf.h
label.o: main.h
+label.o: nocross.h
label.o: node.h
label.o: scope.h
+label.o: target_sizes.h
label.o: type.h
lookup.o: LLlex.h
lookup.o: def.h
lookup.o: idf.h
lookup.o: misc.h
+lookup.o: nocross.h
lookup.o: node.h
lookup.o: scope.h
+lookup.o: target_sizes.h
lookup.o: type.h
main.o: LLlex.h
main.o: Lpars.h
+main.o: class.h
main.o: const.h
main.o: debug.h
main.o: debugcst.h
main.o: input.h
main.o: inputtype.h
main.o: main.h
+main.o: nocross.h
main.o: node.h
main.o: required.h
+main.o: target_sizes.h
main.o: tokenname.h
main.o: type.h
misc.o: LLlex.h
misc.o: main.h
misc.o: misc.h
misc.o: node.h
-next.o: debug.h
-next.o: debugcst.h
node.o: LLlex.h
node.o: debug.h
node.o: debugcst.h
+node.o: nocross.h
node.o: node.h
+node.o: target_sizes.h
node.o: type.h
options.o: class.h
options.o: const.h
options.o: idfsize.h
options.o: main.h
+options.o: nocross.h
+options.o: target_sizes.h
options.o: type.h
readwrite.o: LLlex.h
readwrite.o: debug.h
readwrite.o: debugcst.h
readwrite.o: def.h
+readwrite.o: idf.h
readwrite.o: main.h
+readwrite.o: misc.h
+readwrite.o: nocross.h
readwrite.o: node.h
readwrite.o: scope.h
+readwrite.o: target_sizes.h
readwrite.o: type.h
scope.o: LLlex.h
scope.o: debug.h
scope.o: def.h
scope.o: idf.h
scope.o: misc.h
+scope.o: nocross.h
scope.o: node.h
scope.o: scope.h
+scope.o: target_sizes.h
scope.o: type.h
symbol2str.o: Lpars.h
-tmpvar.o: debug.h
-tmpvar.o: debugcst.h
-tmpvar.o: def.h
-tmpvar.o: main.h
-tmpvar.o: scope.h
-tmpvar.o: type.h
tokenname.o: Lpars.h
tokenname.o: idf.h
tokenname.o: tokenname.h
type.o: def.h
type.o: idf.h
type.o: main.h
+type.o: nocross.h
type.o: node.h
type.o: scope.h
type.o: target_sizes.h
typequiv.o: debug.h
typequiv.o: debugcst.h
typequiv.o: def.h
+typequiv.o: nocross.h
typequiv.o: node.h
+typequiv.o: target_sizes.h
typequiv.o: type.h
progs.o: LLlex.h
progs.o: debug.h
progs.o: debugcst.h
progs.o: def.h
progs.o: main.h
+progs.o: nocross.h
progs.o: scope.h
+progs.o: target_sizes.h
progs.o: type.h
declar.o: LLlex.h
declar.o: Lpars.h
declar.o: chk_expr.h
+declar.o: debug.h
+declar.o: debugcst.h
declar.o: def.h
declar.o: idf.h
declar.o: main.h
declar.o: misc.h
+declar.o: nocross.h
declar.o: node.h
declar.o: scope.h
+declar.o: target_sizes.h
declar.o: type.h
expression.o: LLlex.h
expression.o: Lpars.h
expression.o: debug.h
expression.o: debugcst.h
expression.o: def.h
+expression.o: idf.h
expression.o: main.h
+expression.o: misc.h
+expression.o: nocross.h
expression.o: node.h
expression.o: scope.h
+expression.o: target_sizes.h
expression.o: type.h
program.o: LLlex.h
program.o: Lpars.h
program.o: def.h
+program.o: f_info.h
+program.o: idf.h
program.o: main.h
program.o: node.h
program.o: scope.h
statement.o: chk_expr.h
statement.o: def.h
statement.o: desig.h
+statement.o: f_info.h
statement.o: idf.h
statement.o: main.h
+statement.o: misc.h
+statement.o: nocross.h
statement.o: node.h
statement.o: scope.h
+statement.o: target_sizes.h
statement.o: type.h
tokenfile.o: Lpars.h
+Lpars.o: Lpars.h
+symbol2str.o: Lpars.h
+casestat.o: LLlex.h
+casestat.o: Lpars.h
+casestat.o: chk_expr.h
+casestat.o: debug.h
+casestat.o: debugcst.h
+casestat.o: density.h
+casestat.o: main.h
+casestat.o: nocross.h
+casestat.o: node.h
+casestat.o: target_sizes.h
+casestat.o: type.h
+tmpvar.o: debug.h
+tmpvar.o: debugcst.h
+tmpvar.o: def.h
+tmpvar.o: main.h
+tmpvar.o: nocross.h
+tmpvar.o: scope.h
+tmpvar.o: target_sizes.h
+tmpvar.o: type.h
+char.o: class.h
+next.o: debug.h
+next.o: debugcst.h
!File: debugcst.h
-#define DEBUG 1 /* perform various self-tests */
+#undef DEBUG 1 /* perform various self-tests */
!File: density.h
#define SZ_CHAR (arith)1
#define SZ_WORD (arith)4
#define SZ_INT (arith)4
+#define SZ_LONG (arith)4
#define SZ_POINTER (arith)4
#define SZ_REAL (arith)8
/* target machine alignment requirements */
#define AL_CHAR 1
-#define AL_WORD (int)SZ_WORD
-#define AL_INT (int)SZ_WORD
-#define AL_POINTER (int)SZ_WORD
-#define AL_REAL (int)SZ_WORD
-#define AL_STRUCT 1
+#define AL_WORD ((int)SZ_WORD)
+#define AL_INT ((int)SZ_WORD)
+#define AL_LONG ((int)SZ_WORD)
+#define AL_POINTER ((int)SZ_WORD)
+#define AL_REAL ((int)SZ_WORD)
+#define AL_STRUCT ((int)SZ_WORD)
+
+
+!File: nocross.h
+#undef NOCROSS 1 /* define when cross compiler not needed */
--- /dev/null
+: create a directory Xsrc with name clashes resolved
+: and run make in that directory
+
+case $# in
+1)
+ ;;
+*) echo "$0: one argument expected" 1>&2
+ exit 1
+ ;;
+esac
+currdir=`pwd`
+case $1 in
+main) target=$currdir/$1
+ ;;
+omain) target=$currdir/$1
+ options=-DPEEPHOLE
+ ;;
+cemain) target=$currdir/$1
+ options=-DCODE_EXPANDER
+ ;;
+Xlint) target=$1
+ ;;
+*) echo "$0: $1: Illegal argument" 1>&2
+ exit 1
+ ;;
+esac
+if test -d ../Xsrc
+then
+ :
+else mkdir ../Xsrc
+fi
+make EMHOME=$EMHOME longnames
+: remove code generating routines from the clashes list as they are defines.
+: code generating routine names start with C_
+sed '/^C_/d' < longnames > tmp$$
+cclash -c -l7 tmp$$ > ../Xsrc/Xclashes
+rm -f tmp$$
+PW=`pwd`
+cd ../Xsrc
+if cmp -s Xclashes clashes
+then
+ :
+else
+ mv Xclashes clashes
+fi
+rm -f Makefile
+ed - $PW/Makefile <<'EOF'
+/^#EXCLEXCL/,/^#INCLINCL/d
+w Makefile
+q
+EOF
+for i in `cat $PW/Cfiles`
+do
+ cat >> Makefile <<EOF
+
+$i: clashes $PW/$i
+ \$(CID) -Fclashes < $PW/$i > $i
+EOF
+done
+make EMHOME=$EMHOME CURRDIR=$currdir/ COPTIONS=$options $target
--- /dev/null
+static char Version[] = "ACK Pascal compiler Version 2.2";
#include "desig.h"
#include "idf.h"
#include "main.h"
+#include "misc.h"
#include "node.h"
#include "scope.h"
#include "type.h"
+MarkDef(nd, flags, on)
+ register struct node *nd;
+ unsigned short flags;
+{
+ while( nd && nd->nd_class != Def ) {
+ if( (nd->nd_class == Arrsel) ||
+ (nd->nd_class == LinkDef) )
+ nd = nd->nd_left;
+ else if( nd->nd_class == Arrow )
+ nd = nd->nd_right;
+ else break;
+ }
+ if( nd && (nd->nd_class == Def) ) {
+ if( (flags & D_SET) && on &&
+ BlockScope != nd->nd_def->df_scope )
+ nd->nd_def->df_flags |= D_SETINHIGH;
+ if( on ) {
+ if( (flags & D_SET) &&
+ (nd->nd_def->df_flags & D_WITH) )
+ node_warning(nd,
+ "variable \"%s\" already referenced in with",
+ nd->nd_def->df_idf->id_text);
+ nd->nd_def->df_flags |= flags;
+ }
+ else
+ nd->nd_def->df_flags &= ~flags;
+ }
+}
+
+AssertStat(expp, line)
+ register struct node *expp;
+ unsigned short line;
+{
+ struct desig dsr;
+
+ if( !ChkExpression(expp) )
+ return;
+
+ if( expp->nd_type != bool_type ) {
+ node_error(expp, "type of assertion should be boolean");
+ return;
+ }
+
+ if( options['a'] && !err_occurred ) {
+ dsr = InitDesig;
+ CodeExpr(expp, &dsr, NO_LABEL);
+ C_loc((arith)line);
+ C_cal("_ass");
+ }
+}
AssignStat(left, right)
register struct node *left, *right;
{
register struct type *ltp, *rtp;
+ int retval = 0;
struct desig dsr;
- if( !(ChkExpression(right) && ChkLhs(left)) )
- return;
+ retval = ChkExpression(right);
+ MarkUsed(right);
+ retval &= ChkLhs(left);
ltp = left->nd_type;
rtp = right->nd_type;
+ MarkDef(left, (unsigned short)D_SET, 1);
+
+ if( !retval ) return;
+
+ if( ltp == int_type && rtp == long_type ) {
+ right = MkNode(IntReduc, NULLNODE, right, &dot);
+ right->nd_type = int_type;
+ }
+ else if( ltp == long_type && rtp == int_type ) {
+ right = MkNode(IntCoerc, NULLNODE, right, &dot);
+ right->nd_type = long_type;
+ }
+
if( !TstAssCompat(ltp, rtp) ) {
node_error(left, "type incompatibility in assignment");
return;
}
+ if( left->nd_class == Def &&
+ (left->nd_def->df_flags & D_INLOOP) ) {
+ node_error(left, "assignment to a control variable");
+ return;
+ }
+
if( rtp == emptyset_type )
right->nd_type = ltp;
CodeValue(&dsr, rtp);
if( ltp == real_type && BaseType(rtp) == int_type )
- Int2Real();
+ Int2Real(rtp->tp_size);
RangeCheck(ltp, rtp);
}
register struct node *nd;
{
register struct def *df;
+ int retvar = 0;
+
+ retvar = ChkVariable(nd);
+ retvar &= ChkExpression(nd->nd_left);
+ MarkUsed(nd->nd_left);
+ retvar &= ChkExpression(nd->nd_right);
+ MarkUsed(nd->nd_right);
+ if( !retvar ) return;
- if( !(ChkVariable(nd) && ChkExpression(nd->nd_left) &&
- ChkExpression(nd->nd_right)) )
- return;
-
assert(nd->nd_class == Def);
df = nd->nd_def;
assert(df->df_kind == D_VARIABLE);
if( df->df_scope != GlobalScope && df->var_off >= 0 ) {
- node_error(nd,"for loop: control variable can't be a parameter");
- return;
+ node_error(nd,
+ "for loop: control variable can't be a parameter");
+ MarkDef(nd,(unsigned short)(D_LOOPVAR | D_SET | D_USED), 1);
+ return;
}
if( !(df->df_type->tp_fund & T_ORDINAL) ) {
node_error(nd, "for loop: control variable must be ordinal");
+ MarkDef(nd,(unsigned short)(D_LOOPVAR | D_SET | D_USED), 1);
return;
}
node_error(nd,
"for loop: final value incompatible with control variable");
- df->df_flags |= D_LOOPVAR;
+ if( df->df_type == long_type )
+ node_error(nd, "for loop: control variable can not be a long");
+
+ if( df->df_flags & D_INLOOP )
+ node_error(nd, "for loop: control variable already used");
+
+ if( df->df_flags & D_SETINHIGH )
+ node_error(nd,
+ "for loop: control variable already set in block");
+
+ MarkDef(nd,(unsigned short) (D_LOOPVAR | D_INLOOP | D_SET | D_USED), 1);
return;
}
+EndForStat(nd)
+ register struct node *nd;
+{
+ register struct def *df;
+
+ df = nd->nd_def;
+
+ if( (df->df_scope != BlockScope) ||
+ (df->df_scope != GlobalScope && df->var_off >= 0) ||
+ !(df->df_type->tp_fund & T_ORDINAL)
+ )
+ return;
+
+ MarkDef(nd,(unsigned short) (D_INLOOP | D_SET), 0);
+}
+
arith
CodeInitFor(nd, priority)
register struct node *nd;
CodePExpr(nd);
if( nd->nd_class != Value ) {
tmp = NewInt(priority);
+
C_dup(int_size);
C_stl(tmp);
+
return tmp;
}
return (arith) 0;
return;
}
+ MarkDef(nd, (unsigned short)(D_USED | D_SET | D_WITH), 1);
+ /*
+ if( (nd->nd_class == Arrow) &&
+ (nd->nd_right->nd_type->tp_fund & T_FILE) ) {
+ nd->nd_right->nd_def->df_flags |= D_WITH;
+ }
+ */
+
+ scl = new_scopelist();
+ scl->sc_scope = nd->nd_type->rec_scope;
+ scl->next = CurrVis;
+ CurrVis = scl;
+
if( err_occurred ) return;
/* Generate code */
wds = new_withdesig();
wds->w_next = WithDesigs;
WithDesigs = wds;
- wds->w_scope = nd->nd_type->rec_scope;
+ wds->w_scope = scl->sc_scope;
/* create a desig structure for the temporary */
ds.dsg_kind = DSG_FIXED;
/* 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)
/* restore scope, and release structures */
struct scopelist *scl;
struct withdesig *wds;
+ struct node *nd1;
while( CurrVis != saved_scl ) {
CurrVis = CurrVis->next;
free_scopelist(scl);
+ if( WithDesigs == 0 )
+ continue; /* we didn't generate any code */
+
/* release temporary */
FreePtr(WithDesigs->w_desig.dsg_offset);
WithDesigs = WithDesigs->w_next;
free_withdesig(wds);
}
+
+ for( nd1 = nd; nd1 != NULLNODE; nd1 = nd1->nd_right ) {
+ MarkDef(nd1->nd_left, (unsigned short)(D_WITH), 0);
+ }
+
FreeNode(nd);
}
register struct node *expp = nd->nd_left;
if( !ChkExpression(expp) ) return;
+ MarkUsed(expp);
if( !(expp->nd_type->tp_fund & T_ORDINAL) ) {
node_error(expp, "case-expression must be ordinal");
if( nd->nd_class == Def && nd->nd_def ) {
if( nd->nd_def->df_kind != D_ERROR )
node_error(nd,"\"%s\": %s",
- nd->nd_def->df_idf->id_text, mess);
+ nd->nd_def->df_idf->id_text, mess);
}
else node_error(nd, "%s", mess);
}
+struct node *
+ZeroParam()
+{
+ register struct node *nd;
+
+ nd = MkLeaf(Value, &dot);
+ nd->nd_type = int_type;
+ nd->nd_symb = INTEGER;
+ nd->nd_INT = (arith) 0;
+ nd = MkNode(Link, nd, NULLNODE, &dot);
+ nd->nd_symb = ',';
+
+ return nd;
+}
+
+MarkUsed(nd)
+ register struct node *nd;
+{
+ while( nd && nd->nd_class != Def ) {
+ if( (nd->nd_class == Arrsel) || (nd->nd_class == LinkDef) )
+ nd = nd->nd_left;
+ else if( nd->nd_class == Arrow)
+ nd = nd->nd_right;
+ else break;
+ }
+
+ if( nd && nd->nd_class == Def ) {
+ if( !((nd->nd_def->df_flags & D_VARPAR) ||
+ (nd->nd_def->df_kind == D_FIELD)) ) {
+ if( !(nd->nd_def->df_flags & D_SET) &&
+ (nd->nd_def->df_scope == CurrentScope) )
+ if( !is_anon_idf(nd->nd_def->df_idf) ) {
+ warning("\"%s\" used before set",
+ nd->nd_def->df_idf->id_text);
+ }
+ nd->nd_def->df_flags |= (D_USED | D_SET);
+ }
+ }
+}
+
STATIC int
ChkConstant(expp)
register struct node *expp;
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
*/
return 0;
}
- if( !(df = lookup(expp->nd_IDF, left->nd_type->rec_scope)) ) {
+ if( !(df = lookup(expp->nd_IDF, left->nd_type->rec_scope, D_INUSE)) ) {
id_not_declared(expp);
return 0;
}
df = expp->nd_def;
if( df->df_kind & (D_ENUM | D_CONST) ) {
+ MarkUsed(expp);
/* Replace an enum-literal or a CONST identifier by its value.
*/
if( df->df_kind == D_ENUM ) {
if( !ChkLinkOrName(expp) ) return 0;
if( expp->nd_class != Def ) return 1;
- if( !(expp->nd_def->df_kind & D_VALUE) )
+ if( !(expp->nd_def->df_kind & D_VALUE) ) {
Xerror(expp, "value expected");
+ }
return 1;
}
if( !ChkExpression(right) ) return 0;
+ MarkUsed(right);
+
expp->nd_type = tpr = BaseType(right->nd_type);
switch( expp->nd_symb ) {
break;
case '-':
- if( tpr->tp_fund == T_INTEGER ) {
+ if( tpr->tp_fund == T_INTEGER || tpr->tp_fund == T_LONG ) {
if( right->nd_class == Value )
cstunary(expp);
return 1;
break;
case '(':
+ /* Delete the brackets */
+ *expp = *right;
+ free_node(right);
return 1;
default:
case '*' :
if( tpl == real_type || tpr == real_type )
return real_type;
+ if( tpl == long_type || tpr == long_type)
+ return long_type;
return tpl;
case '/' :
return real_type;
}
+ if (tpr == long_type && tpl == int_type) return tpr;
return tpl;
}
return T_NUMERIC;
case DIV :
case MOD :
- return T_INTEGER;
+ return T_INTEGER | T_LONG;
case OR :
case AND :
return T_ENUMERATION;
case '=' :
case NOTEQUAL :
return T_ENUMERATION | T_CHAR | T_NUMERIC |
- T_SET | T_POINTER | T_STRING;
+ T_SET | T_POINTER | T_STRINGCONST |
+ T_STRING;
case LESSEQUAL :
case GREATEREQUAL:
return T_ENUMERATION | T_CHAR | T_NUMERIC |
- T_SET | T_STRING;
+ T_SET | T_STRINGCONST;
case '<' :
case '>' :
return T_ENUMERATION | T_CHAR | T_NUMERIC |
- T_STRING;
+ T_STRINGCONST;
default :
crash("(AllowedTypes)");
}
retval = ChkExpression(left) & ChkExpression(right);
+ MarkUsed(left);
+ MarkUsed(right);
+
tpl = BaseType(left->nd_type);
tpr = BaseType(right->nd_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
+ "allowed-mask" of "AllowedTypes" can only indicate an enumeration
type.
- The IN-operator has as right-hand-side operand a set.
- Strings and packed arrays can be equivalent.
arith ub;
extern arith IsString();
- if( allowed & T_STRING && (ub = IsString(tpl)) )
+ if( allowed & T_STRINGCONST && (ub = IsString(tpl)) ) {
if( ub == IsString(tpr) )
return 1;
else {
symbol2str(expp->nd_symb));
return 0;
}
+ }
+ else if( allowed & T_STRING && tpl->tp_fund == T_STRING )
+ return 1;
+
node_error(expp, "\"%s\": illegal operand type(s)",
symbol2str(expp->nd_symb));
return 0;
}
if( allowed & T_NUMERIC ) {
- if( tpl == int_type &&
+ if( (tpl == int_type || tpl == long_type) &&
(tpr == real_type || expp->nd_symb == '/') ) {
expp->nd_left =
MkNode(Cast, NULLNODE, expp->nd_left, &dot);
expp->nd_left->nd_type = tpl = real_type;
}
- if( tpl == real_type && tpr == int_type ) {
+ if( tpl == real_type &&
+ (tpr == int_type || tpr == long_type)) {
expp->nd_right =
MkNode(Cast, NULLNODE, expp->nd_right, &dot);
expp->nd_right->nd_type = tpr = real_type;
}
+ if( tpl == int_type && tpr == long_type) {
+ expp->nd_left =
+ MkNode(IntCoerc, NULLNODE, expp->nd_left, &dot);
+ expp->nd_left->nd_type = long_type;
+ }
+ else if( tpl == long_type && tpr == int_type) {
+ expp->nd_right =
+ MkNode(IntCoerc, NULLNODE, expp->nd_right, &dot);
+ expp->nd_right->nd_type = long_type;
+ }
}
/* Operands must be compatible */
/* Here, a single element is checked
*/
if( !ChkExpression(expp) ) return 0;
+ MarkUsed(expp);
if( *tp == emptyset_type ) {
/* first element in set determines the type of the set */
/* after all the work we've done, the set turned out
out to be empty!
*/
- free(set);
+ free((char *) set);
set = (arith *) 0;
}
expp->nd_set = set;
return 1;
}
-ChkVarPar(nd, name)
- register struct node *nd, *name;
+char *
+ChkAllowedVar(nd, reading) /* reading indicates read or readln */
+ register struct node *nd;
{
- /* ISO 6.6.3.3 :
- An actual variable parameter shall not denote a field
- that is the selector of a variant-part or a component
- of a variable where that variable possesses a type
- that is designated packed.
- */
- static char var_mes[] = "can't be a variable parameter";
- static char err_mes[64];
- char *message = (char *) 0;
- extern char *sprint();
-
- if( !ChkVariable(nd) ) return 0;
+ char *message = 0;
switch( nd->nd_class ) {
case Def:
+ if( nd->nd_def->df_flags & D_INLOOP ) {
+ message = "control variable";
+ break;
+ }
if( nd->nd_def->df_kind != D_FIELD ) break;
/* FALL THROUGH */
assert(nd->nd_def->df_kind == D_FIELD);
if( nd->nd_def->fld_flags & F_PACKED )
- message = "field of packed record %s";
+ message = "field of packed record";
else if( nd->nd_def->fld_flags & F_SELECTOR )
- message = "variant selector %s";
+ message = "variant selector";
break;
case Arrsel:
if( IsPacked(nd->nd_left->nd_type) )
- message = "component of packed array %s";
+ if( !reading ) message = "component of packed array";
break;
case Arrow:
if( nd->nd_right->nd_type->tp_fund == T_FILE )
- message = "filebuffer variable %s";
+ message = "filebuffer variable";
break;
default:
- crash("(ChkVarPar)");
+ crash("(ChkAllowedVar)");
/*NOTREACHED*/
}
+ MarkDef(nd, D_SET, 1);
+ return message;
+}
+
+int
+ChkVarPar(nd, name)
+ register struct node *nd, *name;
+{
+ /* ISO 6.6.3.3 :
+ An actual variable parameter shall not denote a field
+ that is the selector of a variant-part or a component
+ of a variable where that variable possesses a type
+ that is designated packed.
+ */
+ static char err_mes[80];
+ char *message = (char *) 0;
+ extern char *sprint();
+
+ if( !ChkVariable(nd) ) return 0;
+
+ message = ChkAllowedVar(nd, 0);
+
if( message ) {
- sprint(err_mes, message, var_mes);
+ sprint(err_mes, "%s can't be a variable parameter", message);
Xerror(name, err_mes);
return 0;
}
Xerror(name, "illegal proc/func parameter");
return 0;
}
- else if( ChkLinkOrName(left->nd_left) )
+ else if( ChkLinkOrName(left->nd_left) ) {
left->nd_type = left->nd_left->nd_type;
-
+ MarkUsed(left->nd_left);
+ }
else return 0;
}
- else if( varaccess ? !ChkVarPar(left, name) : !ChkExpression(left) )
- return 0;
+ else if( varaccess ) {
+ if( !ChkVarPar(left, name) )
+ return 0;
+ }
+ else if( !ChkExpression(left) ) {
+ MarkUsed(left);
+ return 0;
+ }
+
+ if( !varaccess ) MarkUsed(left);
+
+ if( !varaccess && bases == T_INTEGER &&
+ BaseType(left->nd_type)->tp_fund == T_LONG) {
+ arg->nd_left = MkNode(IntReduc, NULLNODE, left, &dot);
+ arg->nd_left->nd_type = int_type;
+ left = arg->nd_left;
+ }
if( bases && !(BaseType(left->nd_type)->tp_fund & bases) ) {
Xerror(name, "unexpected parameter type");
register struct node *left;
struct node *name;
register struct paramlist *param;
- char ebuf[64];
+ char ebuf[80];
int retval = 1;
int cnt = 0;
int new_par_section;
/* Check parameter list
*/
for( param = ParamList(left->nd_type); param; param = param->next ) {
- if( !(left = getarg(&expp, 0, IsVarParam(param), name,
+ if( !(left = getarg(&expp, 0, (int) IsVarParam(param), name,
TypeOfParam(param))) )
return 0;
cnt++;
-
new_par_section = lasttp != TypeOfParam(param);
if( !TstParCompat(TypeOfParam(param), left->nd_type,
- IsVarParam(param), left, new_par_section) ) {
+ (int) IsVarParam(param), left, new_par_section) ) {
sprint(ebuf, "type incompatibility in parameter %d",
cnt);
Xerror(name, ebuf);
retval = 0;
}
+
+ /* Convert between integers and longs.
+ */
+ if( !IsVarParam(param) && options['d'] ) {
+ if( left->nd_type->tp_fund == T_INTEGER &&
+ TypeOfParam(param)->tp_fund == T_LONG) {
+ expp->nd_left =
+ MkNode(IntCoerc, NULLNODE, left, &dot);
+ expp->nd_left->nd_type = long_type;
+ left = expp->nd_left;
+ }
+ else if( left->nd_type->tp_fund == T_LONG &&
+ TypeOfParam(param)->tp_fund == T_INTEGER) {
+ expp->nd_left =
+ MkNode(IntReduc, NULLNODE, left, &dot);
+ expp->nd_left->nd_type = int_type;
+ left = expp->nd_left;
+ }
+ }
+
if( left->nd_type == emptyset_type )
/* type of emptyset determined by the context */
left->nd_type = TypeOfParam(param);
if( ChkLinkOrName(left) ) {
+ MarkUsed(left);
if( IsProcCall(left) || left->nd_type == error_type ) {
/* A call.
It may also be a call to a standard procedure
if( !(left = getarg(&arg, T_NUMERIC, 0, name, NULLTYPE)) )
return 0;
expp->nd_type = real_type;
- if( BaseType(left->nd_type)->tp_fund == T_INTEGER ) {
+ if( BaseType(left->nd_type)->tp_fund == T_INTEGER ||
+ BaseType(left->nd_type)->tp_fund == T_LONG) {
arg->nd_left = MkNode(Cast,NULLNODE, arg->nd_left,&dot);
arg->nd_left->nd_type = real_type;
}
case R_ORD:
if( !(left = getarg(&arg, T_ORDINAL, 0, name, NULLTYPE)) )
return 0;
+ if( BaseType(left->nd_type)->tp_fund == T_LONG ) {
+ arg->nd_left = MkNode(IntReduc, NULLNODE, arg->nd_left, &dot);
+ arg->nd_left->nd_type = int_type;
+ }
expp->nd_type = int_type;
if( left->nd_class == Value )
cstcall(expp, R_ORD);
if( !(left = getarg(&arg, T_ORDINAL, 0, name, NULLTYPE)) )
return 0;
expp->nd_type = left->nd_type;
- if( left->nd_class == Value && !options['r'] )
+ if( left->nd_class == Value && options['R'] )
cstcall(expp, req);
break;
case R_ODD:
- if( !(left = getarg(&arg, T_INTEGER, 0, name, NULLTYPE)) )
+ if( !(left = getarg(&arg, T_INTEGER | T_LONG , 0, name, NULLTYPE)) )
return 0;
expp->nd_type = bool_type;
if( left->nd_class == Value )
if( !arg->nd_right ) {
struct node *nd;
- if( !(nd = ChkStdInOut(name, st_out)) )
+ if( !(nd = ChkStdInOut(name->nd_IDF->id_text, st_out)) )
return 0;
expp->nd_right = MkNode(Link, nd, NULLNODE, &dot);
expp->nd_type = NULLTYPE;
break;
+ case R_MARK:
+ case R_RELEASE:
+ if( !(left = getarg(&arg, T_POINTER, 1, name, NULLTYPE)) )
+ return 0;
+ expp->nd_type = NULLTYPE;
+ break;
+
+ case R_HALT:
+ if( !arg->nd_right ) /* insert 0 parameter */
+ arg->nd_right = ZeroParam();
+ if( !(left = getarg(&arg, T_INTEGER, 0, name, NULLTYPE)) )
+ return 0;
+ expp->nd_type = NULLTYPE;
+ break;
+
default:
crash("(ChkStandard)");
}
if( !ChkVariable(expp->nd_right) ) return 0;
+ MarkUsed(expp->nd_right);
+
tp = expp->nd_right->nd_type;
if( !(tp->tp_fund & (T_POINTER | T_FILE)) ) {
expp->nd_type = error_type;
- retval = ChkVariable(expp->nd_left) & ChkExpression(expp->nd_right);
+ /* Check the index first, so a[a[j]] is checked in order of
+ * evaluation. This to make sure that warnings are generated
+ * in the right order.
+ */
+ retval = ChkExpression(expp->nd_right);
+ MarkUsed(expp->nd_right);
+ retval &= ChkVariable(expp->nd_left);
tpl = expp->nd_left->nd_type;
tpr = expp->nd_right->nd_type;
return 0;
}
+ if( tpr == long_type ) {
+ expp->nd_right = MkNode(IntReduc, NULLNODE, expp->nd_right, &dot);
+ expp->nd_right->nd_type = int_type;
+ }
+
expp->nd_type = tpl->arr_elem;
return retval;
}
NodeCrash,
ChkExLinkOrName,
NodeCrash,
+ NodeCrash,
+ NodeCrash,
NodeCrash
};
done_before,
ChkLinkOrName,
done_before,
+ no_var_access,
+ no_var_access,
no_var_access
};
#include <assert.h>
#include <em.h>
#include <em_reg.h>
+#include <em_abs.h>
#include "LLlex.h"
#include "Lpars.h"
#include "def.h"
#include "desig.h"
+#include "f_info.h"
+#include "idf.h"
#include "main.h"
+#include "misc.h"
#include "node.h"
#include "required.h"
#include "scope.h"
C_fil_dlb((label) 1, (arith) 0);
}
+routine_label(df)
+ register struct def * df;
+{
+ df->prc_label = ++data_label;
+ C_df_dlb(df->prc_label);
+ C_rom_scon(df->df_idf->id_text, strlen(df->df_idf->id_text) + 1);
+}
+
RomString(nd)
register struct node *nd;
{
C_df_dlb(++data_label);
- C_rom_scon(nd->nd_STR, nd->nd_SLE); /* no trailing '\0' */
+
+ /* A string of the string_type is null-terminated. */
+ if( nd->nd_type == string_type )
+ C_rom_scon(nd->nd_STR, nd->nd_SLE + 1); /* with trailing '\0' */
+ else
+ C_rom_scon(nd->nd_STR, nd->nd_SLE); /* no trailing '\0' */
+
nd->nd_SLA = data_label;
}
*/
arith StackAdjustment = 0;
- arith offset; /* offset to save StackPointer */
+ arith offset = 0; /* offset to save StackPointer */
TmpOpen(df->prc_vis->sc_scope);
switch( df->df_kind ) {
+ case D_MODULE : break; /* nothing */
case D_PROGRAM :
C_exp("m_a_i_n");
C_pro_narg("m_a_i_n");
CodeFil();
/* initialize external files */
- make_extfl();
call_ini();
+ /* ignore floating point underflow */
+ C_lim();
+ C_loc((arith) (1 << EFUNFL));
+ C_ior(int_size);
+ C_sim();
+
break;
case D_PROCEDURE :
offset = CodeGtoDescr(df->prc_vis->sc_scope);
CodeFil();
+ if( options['t'] ) {
+ C_lae_dlb(df->prc_label,(arith)0);
+ C_cal("procentry");
+ C_asp(pointer_size);
+ }
+
+ /* prc_bool is the local variable that indicates if the
+ * function result is assigned. This and can be disabled
+ * with the -R option. The variable, however, is always
+ * allocated and initialized.
+ */
+ if( df->prc_res ) {
+ C_zer((arith) int_size);
+ C_stl(df->prc_bool);
+ }
for( param = ParamList(df->df_type); param; param = param->next)
if( !IsVarParam(param) ) {
tp = TypeOfParam(param);
if( !options['n'] )
RegisterMessages(df->prc_vis->sc_scope->sc_def);
+ if( options['t'] ) {
+ C_lae_dlb(df->prc_label,(arith)0);
+ C_cal("procexit");
+ C_asp(pointer_size);
+ }
if( tp = ResultType(df->df_type) ) {
- if( tp->tp_size == real_size )
+ if( !options['R'] ) {
+ C_lin(LineNumber);
+ C_lol(df->prc_bool);
+ C_cal("_nfa");
+ C_asp(word_size);
+ }
+ if( tp->tp_size == 2 * word_size )
C_ldl(-tp->tp_size);
else
C_lol(-tp->tp_size);
struct node *right = nd->nd_right;
CodePExpr(right);
- Int2Real();
+ Int2Real(right->nd_type->tp_size);
+ ds->dsg_kind = DSG_LOADED;
+ break;
+ }
+ case IntCoerc: {
+ /* convert integer to long integer */
+ struct node *right = nd->nd_right;
+
+ CodePExpr(right);
+ Int2Long();
ds->dsg_kind = DSG_LOADED;
break;
}
+ case IntReduc: {
+ /* convert a long to an integer */
+ struct node *right = nd->nd_right;
+ CodePExpr(right);
+ Long2Int();
+ ds->dsg_kind = DSG_LOADED;
+ break;
+ }
default:
crash("(CodeExpr : bad node type)");
/*NOTREACHED*/
switch( nd->nd_symb ) {
case '-':
assert(tp->tp_fund & T_NUMERIC);
- if( tp->tp_fund == T_INTEGER )
+ if( tp->tp_fund == T_INTEGER || tp->tp_fund == T_LONG )
C_ngi(tp->tp_size);
else
C_ngf(tp->tp_size);
Operands(leftop, rightop);
switch( tp->tp_fund ) {
case T_INTEGER:
+ case T_LONG:
C_adi(tp->tp_size);
break;
case T_REAL:
Operands(leftop, rightop);
switch( tp->tp_fund ) {
case T_INTEGER:
+ case T_LONG:
C_sbi(tp->tp_size);
break;
case T_REAL:
Operands(leftop, rightop);
switch( tp->tp_fund ) {
case T_INTEGER:
+ case T_LONG:
C_mli(tp->tp_size);
break;
case T_REAL:
case DIV:
Operands(leftop, rightop);
- if( tp->tp_fund == T_INTEGER )
+ if( tp->tp_fund == T_INTEGER || tp->tp_fund == T_LONG)
C_dvi(tp->tp_size);
else
crash("(CodeBoper: bad type DIV)");
case MOD:
Operands(leftop, rightop);
- if( tp->tp_fund == T_INTEGER ) {
+ if( tp->tp_fund == T_INTEGER ) {
C_cal("_mdi");
C_asp(2 * tp->tp_size);
C_lfr(tp->tp_size);
}
+ else if( tp->tp_fund == T_LONG) {
+ C_cal("_mdil");
+ C_asp(2 * tp->tp_size);
+ C_lfr(tp->tp_size);
+ }
else
crash("(CodeBoper: bad type MOD)");
break;
switch( tp->tp_fund ) {
case T_INTEGER:
+ case T_LONG:
C_cmi(tp->tp_size);
break;
case T_REAL:
C_cms(tp->tp_size);
break;
- case T_STRING:
+ case T_STRINGCONST:
case T_ARRAY:
- C_loc(IsString(tp));
+ C_loc((arith) IsString(tp));
C_cal("_bcp");
C_asp(2 * pointer_size + word_size);
C_lfr(word_size);
break;
+ case T_STRING:
+ C_cmp();
+ break;
+
default:
crash("(CodeBoper : bad type COMPARE)");
}
struct paramlist *param;
struct node *arg;
{
- register struct type *tp, *left_tp, *last_tp;
+ register struct type *tp, *left_tp, *last_tp = (struct type *) 0;
struct node *left;
struct desig ds;
CodeDAddress(left);
return tp;
}
- if( left_tp->tp_fund == T_STRING ) {
+ if( left_tp->tp_fund == T_STRINGCONST ) {
CodePString(left, tp);
return tp;
}
RangeCheck(tp, left_tp);
if( tp == real_type && BaseType(left_tp) == int_type )
- Int2Real();
+ Int2Real(int_size);
return tp;
}
if( IsConformantArray(elemtp) )
CodeConfDescr(elemtp, atp->arr_elem);
- if( atp->tp_fund == T_STRING ) {
+ if( atp->tp_fund == T_STRINGCONST ) {
C_loc((arith) 1);
C_loc(atp->tp_psize - 1);
C_loc((arith) 1);
CodePExpr(left);
if( tp == int_type )
C_cal("_abi");
+ else if ( tp == long_type )
+ C_cal("_abl");
else
C_cal("_abr");
C_asp(tp->tp_size);
case R_SQR:
CodePExpr(left);
C_dup(tp->tp_size);
- if( tp == int_type )
- C_mli(int_size);
+ if( tp == int_type || tp == long_type )
+ C_mli(tp->tp_size);
else
C_mlf(real_size);
break;
case R_SUCC:
case R_PRED:
CodePExpr(left);
+ C_loc((arith)1);
+ if( tp == long_type) Int2Long();
+
if( req == R_SUCC )
- C_inc();
+ C_adi(tp->tp_size);
else
- C_dec();
+ C_sbi(tp->tp_size);
+
if( bounded(left->nd_type) )
genrck(left->nd_type);
break;
case R_ODD:
CodePExpr(left);
C_loc((arith) 1);
- C_and(word_size);
+ if( tp == long_type ) Int2Long();
+ C_and(tp->tp_size);
+ if( tp == long_type ) Long2Int(); /* bool_size == int_size */
break;
case R_EOF:
C_asp(pointer_size + word_size);
break;
+ case R_MARK:
+ case R_RELEASE:
+ CodeDAddress(left);
+ if( req == R_MARK )
+ C_cal("_sav");
+ else
+ C_cal("_rst");
+ C_asp(pointer_size);
+ break;
+
+ case R_HALT:
+ if( left )
+ CodePExpr(left);
+ else
+ C_zer(int_size);
+ C_cal("_hlt"); /* can't return */
+ C_asp(int_size); /* help the optimizer(s) */
+ break;
+
default:
crash("(CodeStd)");
/*NOTREACHED*/
}
}
-Int2Real()
+Long2Int()
{
- /* convert integer to real */
+ /* convert a long to integer */
+
+ if (int_size == long_size) return;
+
+ C_loc(long_size);
C_loc(int_size);
+ C_cii();
+}
+
+Int2Long()
+{
+ /* convert integer to long */
+
+ if (int_size == long_size) return;
+ C_loc(int_size);
+ C_loc(long_size);
+ C_cii();
+}
+
+Int2Real(size) /* size is different for integers and longs */
+arith size;
+{
+ /* convert integer to real */
+ C_loc(size);
C_loc(real_size);
C_cif();
}
register label o1;
int newlabel = 0;
- if( !options['r'] ) return;
+ if( options['R'] ) return;
getbounds(tp, &lb, &ub);
long mach_long_sign; /* sign bit of the machine long */
int mach_long_size; /* size of long on this machine == sizeof(long) */
long full_mask[MAXSIZE+1];/* full_mask[1] == 0xFF, full_mask[2] == 0xFFFF, .. */
-arith max_int; /* maximum integer on target machine */
+arith max_int; /* maximum integer on the target machine */
+arith min_int; /* mimimum integer on the target machin */
char *maxint_str; /* string representation of maximum integer */
arith wrd_bits; /* number of bits in a word */
arith max_intset; /* largest value of set of integer */
+overflow(expp)
+ struct node *expp;
+{
+ node_warning(expp, "overflow in constant expression");
+}
+
cstunary(expp)
register struct node *expp;
{
*/
register arith o1, o2;
register char *s1, *s2;
- int str = expp->nd_left->nd_type->tp_fund & T_STRING;
+ int str = expp->nd_left->nd_type->tp_fund & T_STRINGCONST;
if( str ) {
+ o1 = o2 = 0; /* so LINT won't complain */
s1 = expp->nd_left->nd_STR;
s2 = expp->nd_right->nd_STR;
}
else {
+ s1 = s2 = (char *) 0; /* so LINT won't complain */
o1 = expp->nd_left->nd_INT;
o2 = expp->nd_right->nd_INT;
}
switch( expp->nd_symb ) {
case '+':
+ if (o1 > 0 && o2 > 0) {
+ if (max_int - o1 < o2) overflow(expp);
+ }
+ else if (o1 < 0 && o2 < 0) {
+ if (min_int - o1 > o2) overflow(expp);
+ }
o1 += o2;
break;
case '-':
+ if ( o1 >= 0 && o2 < 0) {
+ if (max_int + o2 < o1) overflow(expp);
+ }
+ else if (o1 < 0 && o2 >= 0) {
+ if (min_int + o2 > o1) overflow(expp);
+ }
o1 -= o2;
break;
case '*':
+ if (o1 > 0 && o2 > 0) {
+ if (max_int / o1 < o2) overflow(expp);
+ }
+ else if (o1 < 0 && o2 < 0) {
+ if (o1 == min_int || o2 == min_int ||
+ max_int / (-o1) < (-o2)) overflow(expp);
+ }
+ else if (o1 > 0) {
+ if (min_int / o1 > o2) overflow(expp);
+ }
+ else if (o2 > 0) {
+ if (min_int / o2 > o1) overflow(expp);
+ }
o1 *= o2;
break;
assert(expp->nd_right->nd_class == Set);
assert(expp->nd_symb == IN || expp->nd_left->nd_class == Set);
set2 = expp->nd_right->nd_set;
- setsize = expp->nd_right->nd_type->tp_size / word_size;
+ setsize = (unsigned) (expp->nd_right->nd_type->tp_size) / (unsigned) word_size;
if( expp->nd_symb == IN ) {
arith i;
expp->nd_symb = INTEGER;
switch( req ) {
case R_ABS:
- if( expr->nd_INT < 0 ) expp->nd_INT = - expr->nd_INT;
+ if( expr->nd_INT < 0 ) {
+ if (expr->nd_INT <= min_int) {
+ overflow(expr);
+ }
+ expp->nd_INT = - expr->nd_INT;
+ }
else expp->nd_INT = expr->nd_INT;
CutSize(expp);
break;
case R_SQR:
+ if (expr->nd_INT < 0) {
+ if ( expr->nd_INT == min_int ||
+ max_int / expr->nd_INT > expr->nd_INT) {
+ overflow(expr);
+ }
+ }
+ else if (max_int / expr->nd_INT < expr->nd_INT) {
+ overflow(expr);
+ }
expp->nd_INT = expr->nd_INT * expr->nd_INT;
CutSize(expp);
break;
/* integers in [-maxint .. maxint] */
int nbits = (int) (mach_long_size - size) * 8;
- node_warning(expr, "overflow in constant expression");
+ /* overflow(expr); */
/* sign bit of o1 in sign bit of mach_long */
o1 <<= nbits;
/* shift back to get sign extension */
fatal("sizeof (long) insufficient on this machine");
max_int = full_mask[int_size] & ~(1 << (int_size * 8 - 1));
+ min_int = - max_int;
maxint_str = long2str(max_int, 10);
maxint_str = Salloc(maxint_str, (unsigned int) strlen(maxint_str));
wrd_bits = 8 * word_size;
/* D E C L A R A T I O N S */
{
+/* next line DEBUG */
+#include "debug.h"
+
#include <alloc.h>
#include <assert.h>
#include <em_arith.h>
#include <em_label.h>
+#include <pc_file.h>
#include "LLlex.h"
#include "chk_expr.h"
#include "scope.h"
#include "type.h"
+#define offsetof(type, field) (int) &(((type *)0)->field)
+#define PC_BUFSIZ (sizeof(struct file) - (int)((struct file *)0)->bufadr)
+
int proclevel = 0; /* nesting level of procedures */
int parlevel = 0; /* nesting level of parametersections */
+int expect_label = 0; /* so the parser knows that we expect a label */
static int in_type_defs; /* in type definition part or not */
}
Block(struct def *df;)
{
arith i;
- label save_label;
} :
{ text_label = (label) 0; }
LabelDeclarationPart
- ConstantDefinitionPart
- { in_type_defs = 1; }
- TypeDefinitionPart
- { in_type_defs = 0;
- /* resolve forward references */
- chk_forw_types();
- }
- VariableDeclarationPart
- { if( !proclevel ) {
- chk_prog_params();
- BssVar();
- }
- proclevel++;
- save_label = text_label;
- }
- ProcedureAndFunctionDeclarationPart
- { text_label = save_label;
-
- proclevel--;
- chk_directives();
-
- /* needed with labeldefinitions
- and for-statement
- */
- BlockScope = CurrentScope;
-
- if( !err_occurred )
- i = CodeBeginBlock( df );
- }
+ Module(df, &i)
CompoundStatement
{ if( !err_occurred )
CodeEndBlock(df, i);
+ if( df ) EndBlock(df);
FreeNode(BlockScope->sc_lablist);
}
;
]?
;
+Module(struct def *df; arith *i;)
+{
+ label save_label;
+} :
+ ConstantDefinitionPart
+ { in_type_defs = 1; }
+ TypeDefinitionPart
+ { in_type_defs = 0;
+ /* resolve forward references */
+ chk_forw_types();
+ }
+ VariableDeclarationPart
+ { if( !proclevel ) {
+ chk_prog_params();
+ BssVar();
+ }
+ proclevel++;
+ save_label = text_label;
+ }
+ ProcedureAndFunctionDeclarationPart
+ { text_label = save_label;
+
+ proclevel--;
+ chk_directives();
+
+ /* needed with labeldefinitions
+ and for-statement
+ */
+ BlockScope = CurrentScope;
+
+ if( !err_occurred )
+ *i = CodeBeginBlock( df );
+ }
+;
+
+
+
+
ConstantDefinitionPart:
[
CONST
{
char lab[5];
extern char *sprint();
-} :
+} : { expect_label = 1; }
INTEGER /* not really an integer, in [0..9999] */
{ if( dot.TOK_INT < 0 || dot.TOK_INT > 9999 ) {
- error("label must lie in closed interval [0..9999]");
+ if( dot.TOK_INT != -1 ) /* This means insertion */
+ error("label must lie in closed interval [0..9999]");
*pnd = NULLNODE;
}
else {
*pnd = MkLeaf(Name, &dot);
(*pnd)->nd_IDF = str2idf(lab, 1);
}
+ expect_label = 0;
}
;
{ if( df = define(id,CurrentScope,D_CONST) ) {
df->con_const = nd;
df->df_type = nd->nd_type;
+ df->df_flags |= D_SET;
}
}
;
} :
IDENT { id = dot.TOK_IDF; }
'=' TypeDenoter(&tp)
- { if( df = define(id, CurrentScope, D_TYPE) )
+ { if( df = define(id, CurrentScope, D_TYPE) ) {
df->df_type = tp;
+ df->df_flags |= D_SET;
+ }
}
;
struct node *fpl;
} :
PROCEDURE
- IDENT { *pnd = MkLeaf(Name, &dot); }
+ IDENT {
+ *pnd = MkLeaf(Name, &dot);
+ }
[
FormalParameterList(&fpl)
{ arith nb_pars = 0;
nb_pars = EnterParamList(fpl, &pr);
else
/* procedure parameter */
- EnterParTypes(fpl, &pr);
+ nb_pars = EnterParTypes(fpl, &pr);
*ptp = proc_type(pr, nb_pars);
FreeNode(fpl);
}
|
/* empty */
- { *ptp = proc_type(0, 0); }
+ { *ptp =
+ proc_type((struct paramlist *)0, (arith) 0);
+ }
]
;
else DoDirective(dot.TOK_IDF, nd, tp, scl, 1);
}
|
- { if( df = DeclFunc(nd, tp, scl) )
- df->prc_res = CurrentScope->sc_off =
+ { if( df = DeclFunc(nd, tp, scl) ) {
+ df->prc_res =
- ResultType(df->df_type)->tp_size;
+ df->prc_bool =
+ CurrentScope->sc_off =
+ df->prc_res - int_size;
+ }
}
Block(df)
- { if( df )
- /* assignment to functionname is illegal
- outside the functionblock
- */
- df->prc_res = 0;
+ { if( df ) {
+ EndFunc(df);
+ }
/* open_scope() is simulated in DeclFunc() */
close_scope();
nb_pars = EnterParamList(fpl, &pr);
else
/* function parameter */
- EnterParTypes(fpl, &pr);
+ nb_pars = EnterParTypes(fpl, &pr);
}
|
/* empty */
/* initialize selector */
(*sel)->sel_ptrs = (struct selector **)
- Malloc(ncst * sizeof(struct selector *));
+ Malloc((unsigned)ncst * sizeof(struct selector *));
(*sel)->sel_ncst = ncst;
(*sel)->sel_lb = lb;
error("file type has an illegal component type");
(*ptp)->next = error_type;
}
+ else {
+ if( (*ptp)->next->tp_size > PC_BUFSIZ )
+ (*ptp)->tp_size = (*ptp)->tp_psize =
+ (*ptp)->next->tp_size +
+ sizeof(struct file) - PC_BUFSIZ;
+ }
}
;
{ *ptp = construct_type(T_POINTER, NULLTYPE); }
IDENT
{ nd = MkLeaf(Name, &dot);
- df = lookup(nd->nd_IDF, CurrentScope);
+ df = lookup(nd->nd_IDF, CurrentScope, D_INUSE);
+ /* if( !df && CurrentScope == GlobalScope)
+ df = lookup(nd->nd_IDF, PervasiveScope, D_INUSE);
+ */
if( in_type_defs &&
(!df || (df->df_kind & (D_ERROR | D_FORWTYPE)))
)
[
/* ValueParameterSpecification */
/* empty */
- { nd->nd_INT = D_VALPAR; }
+ { nd->nd_INT = (D_VALPAR | D_SET); }
|
/* VariableParameterSpecification */
VAR
- { nd->nd_INT = D_VARPAR; }
+ { nd->nd_INT = (D_VARPAR | D_USED); }
]
IdentifierList(&(nd->nd_left)) ':'
[
TypeIdentifier(&(nd->nd_type))
]
{ if( nd->nd_type->tp_flags & T_HASFILE &&
- nd->nd_INT == D_VALPAR ) {
+ (nd->nd_INT & D_VALPAR) ) {
error("value parameter can't have a filecomponent");
nd->nd_type = error_type;
}
}
|
ProceduralParameterSpecification(&(nd->nd_left), &(nd->nd_type))
+ { nd->nd_INT = (D_VALPAR | D_SET); }
|
FunctionalParameterSpecification(&(nd->nd_left), &(nd->nd_type))
+ { nd->nd_INT = (D_VALPAR | D_SET); }
]
;
register struct def *df1, *df2;
} :
IDENT
- { if( df1 = define(dot.TOK_IDF, CurrentScope, D_LBOUND))
+ { if( df1 =
+ define(dot.TOK_IDF, CurrentScope, D_LBOUND)) {
df1->bnd_type = tp; /* type conf. array */
+ df1->df_flags |= D_SET;
+ }
}
UPTO
IDENT
- { if( df2 = define(dot.TOK_IDF, CurrentScope, D_UBOUND))
+ { if( df2 =
+ define(dot.TOK_IDF, CurrentScope, D_UBOUND)) {
df2->bnd_type = tp; /* type conf. array */
+ df2->df_flags |= D_SET;
+ }
}
':' TypeIdentifier(ptp)
{ if( !bounded(*ptp) &&
/* ALLOCDEF "lab" 10 */
+struct used {
+ struct def *us_def; /* used definition */
+#define usd_def df_value.df_used.us_def
+};
+
struct forwtype {
struct forwtype *f_next;
struct node *f_node;
struct dfproc { /* used for procedures and functions */
struct scopelist *pc_vis; /* scope of this procedure/function */
char *pc_name; /* internal name */
+ label pc_label; /* label of name (for tracing) */
arith pc_res; /* offset of function result */
+ arith pc_bool; /* offset of run-time boolean */
#define prc_vis df_value.df_proc.pc_vis
#define prc_name df_value.df_proc.pc_name
+#define prc_label df_value.df_proc.pc_label
#define prc_res df_value.df_proc.pc_res
+#define prc_bool df_value.df_proc.pc_bool
};
struct def { /* list of definitions for a name */
struct idf *df_idf; /* link back to the name */
struct scope *df_scope; /* scope in which this definition resides */
long df_kind; /* the kind of this definition: */
-#define D_PROCEDURE 0x00001 /* procedure */
-#define D_FUNCTION 0x00002 /* function */
-#define D_TYPE 0x00004 /* a type */
-#define D_CONST 0x00008 /* a constant */
-#define D_ENUM 0x00010 /* an enumeration literal */
-#define D_FIELD 0x00020 /* a field in a record */
-#define D_PROGRAM 0x00040 /* the program */
-#define D_VARIABLE 0x00080 /* a variable */
-#define D_PARAMETER 0x00100 /* program parameter */
-#define D_FORWTYPE 0x00200 /* forward type */
-#define D_FTYPE 0x00400 /* resolved forward type */
-#define D_FWPROCEDURE 0x00800 /* forward procedure */
-#define D_FWFUNCTION 0x01000 /* forward function */
-#define D_LABEL 0x02000 /* a label */
-#define D_LBOUND 0x04000 /* lower bound identifier in conformant array */
-#define D_UBOUND 0x08000 /* upper bound identifier in conformant array */
-#define D_FORWARD 0x10000 /* directive "forward" */
-#define D_EXTERN 0x20000 /* directive "extern" */
-#define D_ERROR 0x40000 /* a compiler generated definition for an
- * undefined variable
- */
+#define D_PROCEDURE 0x000001 /* procedure */
+#define D_FUNCTION 0x000002 /* function */
+#define D_TYPE 0x000004 /* a type */
+#define D_CONST 0x000008 /* a constant */
+#define D_ENUM 0x000010 /* an enumeration literal */
+#define D_FIELD 0x000020 /* a field in a record */
+#define D_PROGRAM 0x000040 /* the program */
+#define D_VARIABLE 0x000080 /* a variable */
+#define D_PARAMETER 0x000100 /* program parameter */
+#define D_FORWTYPE 0x000200 /* forward type */
+#define D_FTYPE 0x000400 /* resolved forward type */
+#define D_FWPROCEDURE 0x000800 /* forward procedure */
+#define D_FWFUNCTION 0x001000 /* forward function */
+#define D_LABEL 0x002000 /* a label */
+#define D_LBOUND 0x004000 /* lower bound id. in conform. array */
+#define D_UBOUND 0x008000 /* upper bound id. in conform. array */
+#define D_FORWARD 0x010000 /* directive "forward" */
+#define D_EXTERN 0x020000 /* directive "extern" */
+#define D_ERROR 0x040000 /* a compiler generated definition
+ * for an undefined variable */
+#define D_MODULE 0x080000 /* the module */
+#define D_INUSE 0x100000 /* variable is in use */
+
#define D_VALUE (D_FUNCTION | D_CONST | D_ENUM | D_FIELD | D_VARIABLE\
| D_FWFUNCTION | D_LBOUND | D_UBOUND)
#define D_ROUTINE (D_FUNCTION | D_FWFUNCTION | D_PROCEDURE | D_FWPROCEDURE)
unsigned short df_flags;
-#define D_NOREG 0x01 /* set if it may not reside in a register */
-#define D_VALPAR 0x02 /* set if it is a value parameter */
-#define D_VARPAR 0x04 /* set if it is a var parameter */
-#define D_LOOPVAR 0x08 /* set if it is a contol-variable */
-#define D_EXTERNAL 0x10 /* set if proc/func is external declared */
-#define D_PROGPAR 0x20 /* set if input/output was mentioned in
- * the program-heading
- */
+#define D_NOREG 0x001 /* set if it may not reside in a register */
+#define D_VALPAR 0x002 /* set if it is a value parameter */
+#define D_VARPAR 0x004 /* set if it is a var parameter */
+#define D_LOOPVAR 0x008 /* set if it is a control-variable */
+#define D_EXTERNAL 0x010 /* set if proc/func is external declared */
+#define D_PROGPAR 0x020 /* set if input/output was mentioned in
+ * the program-heading */
+#define D_USED 0x040 /* set when the variable is used */
+#define D_SET 0x080 /* set when the variable is set */
+#define D_INLOOP 0x100 /* set when we are inside a loop */
+#define D_WITH 0x200 /* set inside a with statement */
+#define D_SETINHIGH 0x400 /* set in a higher scope level (for loops) */
+
struct type *df_type;
union {
struct constant df_constant;
struct enumval df_enum;
struct field df_field;
struct lab df_label;
+ struct used df_used;
struct forwtype *df_fwtype;
struct dfproc df_proc;
int df_reqname; /* define for required name */
*/
register struct def *df;
- if( df = lookup(id, scope) ) {
+ if( df = lookup(id, scope, 0) ) {
switch( df->df_kind ) {
+ case D_INUSE :
+ if( kind != D_INUSE ) {
+ error("\"%s\" already used in this block",
+ id->id_text);
+ }
+ return MkDef(id, scope, kind);
+
case D_LABEL :
/* generate error message somewhere else */
return NULLDEF;
int kind; /* kind of directive */
int inp; /* internal or external name */
int ext = 0; /* directive = EXTERN */
- struct def *df = lookup(directive, PervasiveScope);
+ struct def *df = lookup(directive, PervasiveScope, D_INUSE);
if( !df ) {
if( !is_anon_idf(directive) )
default:
crash("(DoDirective)");
+ /* NOTREACHED */
}
if( df = define(nd->nd_IDF, CurrentScope, kind) ) {
df->prc_vis = scl;
df->prc_name = gen_proc_name(nd->nd_IDF, inp);
if( ext ) df->df_flags |= D_EXTERNAL;
+ df->df_flags |= D_SET;
}
}
-
+
struct def *
DeclProc(nd, tp, scl)
register struct node *nd;
register struct def *df;
if( df = define(nd->nd_IDF, CurrentScope, D_PROCEDURE) ) {
+ df->df_flags |= D_SET;
if( df->df_kind == D_FWPROCEDURE ) {
df->df_kind = D_PROCEDURE; /* identification */
if( tp->prc_params )
node_error(nd,
- "procedure identification \"%s\" expected",
+ "\"%s\" already declared",
nd->nd_IDF->id_text);
}
else { /* normal declaration */
/* simulate open_scope() */
CurrVis = df->prc_vis = scl;
}
+ routine_label(df);
}
else CurrVis = scl; /* simulate open_scope() */
register struct def *df;
if( df = define(nd->nd_IDF, CurrentScope, D_FUNCTION) ) {
+ df->df_flags &= ~D_SET;
if( df->df_kind == D_FUNCTION ) { /* declaration */
if( !tp ) {
node_error(nd, "\"%s\" illegal function declaration",
nd->nd_IDF->id_text);
- tp = error_type;
+ tp = construct_type(T_FUNCTION, error_type);
}
/* simulate open_scope() */
CurrVis = df->prc_vis = scl;
if( tp )
node_error(nd,
- "function identification \"%s\" expected",
+ "\"%s\" already declared",
nd->nd_IDF->id_text);
}
+ routine_label(df);
}
else CurrVis = scl; /* simulate open_scope() */
return df;
}
+
+EndFunc(df)
+ register struct def *df;
+{
+ /* assignment to functionname is illegal outside the functionblock */
+ df->prc_res = 0;
+
+ /* Give the error about assignment as soon as possible. The
+ * |= assignment inhibits a warning in the main procedure.
+ */
+ if( !(df->df_flags & D_SET) ) {
+ error("function \"%s\" not assigned",df->df_idf->id_text);
+ df->df_flags |= D_SET;
+ }
+}
+
+EndBlock(block_df)
+ register struct def *block_df;
+{
+ register struct def *tmp_def = CurrentScope->sc_def;
+ register struct def *df;
+
+ while( tmp_def ) {
+ df = tmp_def;
+ /* The length of a usd_def chain is at most 1.
+ * The while is just defensive programming.
+ */
+ while( df->df_kind & D_INUSE )
+ df = df->usd_def;
+
+ if( !is_anon_idf(df->df_idf)
+ && (df->df_scope == CurrentScope) ) {
+ if( !(df->df_kind & (D_ENUM|D_LABEL|D_ERROR)) ) {
+ if( !(df->df_flags & D_USED) ) {
+ if( !(df->df_flags & D_SET) ) {
+ warning("\"%s\" neither set nor used in \"%s\"",
+ df->df_idf->id_text, block_df->df_idf->id_text);
+ }
+ else {
+ warning("\"%s\" unused in \"%s\"",
+ df->df_idf->id_text, block_df->df_idf->id_text);
+ }
+ }
+ else if( !(df->df_flags & D_SET) ) {
+ if( !(df->df_flags & D_LOOPVAR) )
+ warning("\"%s\" not set in \"%s\"",
+ df->df_idf->id_text, block_df->df_idf->id_text);
+ }
+ }
+
+ }
+ tmp_def = tmp_def->df_nextinscope;
+ }
+}
#include "def.h"
#include "desig.h"
#include "main.h"
+/* next line DEBUG */
+#include "idf.h"
#include "node.h"
#include "scope.h"
#include "type.h"
switch( rhs->dsg_kind ) {
case DSG_LOADED:
CodeDesig(left, lhs);
- if( rtp->tp_fund == T_STRING ) {
+ if( rtp->tp_fund == T_STRINGCONST ) {
CodeAddress(lhs);
C_blm(lhs->dsg_packed ? ltp->tp_psize : ltp->tp_size);
return;
the function (i.e. in the statement-part of a nested function
or procedure).
*/
+ if( !options['R'] ) {
+ C_loc((arith)1);
+ C_lxl((arith) (proclevel - df->df_scope->sc_level - 1));
+ C_adp(df->prc_bool);
+ C_sti(int_size);
+ }
+
C_lxl((arith) (proclevel - df->df_scope->sc_level - 1));
ds->dsg_kind = DSG_PLOADED;
}
/* Assignment to function-identifier in the statement-part of
the function.
*/
+ if( !options['R'] ) {
+ C_loc((arith)1);
+ C_stl(df->prc_bool);
+ }
+
ds->dsg_kind = DSG_FIXED;
}
assert(df->prc_res < 0);
else
C_lae_dlb(tp->arr_ardescr, (arith) 0);
+ if( options['A'] ) {
+ C_cal("_rcka");
+ }
ds->dsg_kind = DSG_INDEXED;
ds->dsg_packed = IsPacked(tp);
break;
em_pc \- Pascal compiler
.SH SYNOPSIS
.B em_pc
-.RI [ option ]
+.RI [ option ]
.I source
.I destination
.SH DESCRIPTION
.I Em_pc
is a compiler that translates Pascal programs into EM code.
+Normally the compiler is called by means of the user interface program
+\fIack\fR(I).
+.PP
The input is taken from
.IR source ,
-while the EM code is written on
+while the EM code is written on
.IR destination .
.br
.I Option
set maximum identifier length to \fIn\fP.
The minimum value for \fIn\fR is 9, because the keyword
"PROCEDURE" is that long.
+.IR n
.IP \fB\-n\fR
do not generate EM register messages.
The user-declared variables will not be stored into registers on the target
.br
set the size and alignment requirements.
The letter \fIc\fR indicates the simple type, which is one of
-\fBw\fR(word size), \fBi\fR(INTEGER), \fBf\fR(REAL), or \fBp\fR(POINTER).
+\fBw\fR(word size), \fBi\fR(INTEGER), \fBl\fR(LONG), \fBr\fR(REAL),
+\fBp\fR(POINTER).
It may also be the letter \fBS\fR, indicating that an initial
record alignment follows.
The \fIm\fR parameter can be used to specify the length of the type (in bytes)
Absence of \fIm\fR or \fIn\fR causes a default value to be retained.
.IP \fB\-w\fR
suppress warning messages.
-.IP \fB\-u\fR
-The character '_' is treated like a letter, so it is allowed to use the
-underscore in identifiers.
-.IP \fB\-i\fR\fInum\fR
-maximum number of bits in a set. When not used, a default value is
-retained.
+.IP
+.IP \fB\-R\fR
+disable range checks. Additionally, the run-time tests to see if
+a function is assigned, are skipped.
+.IP \fB\-A\fR
+enable extra array bound checks, for machines that do not implement the
+EM ones.
.IP \fB\-C\fR
-The lower case and upper case letters are treated different.
-.IP \fB\-r\fR
-The rangechecks are generated where necessary.
-.LP
+the lower case and upper case letters are treated differently.
+.IP "\fB\-u\fR, \fB\-U\fR"
+allow underscores in identifiers. It is not allowed to start an identifier
+with an underscore.
+.IP \fB\-a\fR
+don't generate code for assertions.
+.IP \fB\-c\fR
+allow C-like strings. This option is mainly intended for usage with
+C-functions. This option will cause the type 'string' to be known.
+.IP \fB\-d\fR
+allow the type 'long'.
+.IP \fB\-i\fR\fIn\fR
+set the size of integer sets to \fIn\fR. When not used, a default value is
+retained.
+.IP \fB\-s\fR
+allow only standard Pascal. This disables the \fB\-c\fR, \fB\-d\fR, \fB\-u\fR,
+\fB\-U\fR and \fB\-C\fR
+options. Furthermore, assertions are not recognized at all (instead of just
+being skipped).
+.IP \fB\-t\fR
+trace calls and exits of procedures and functions.
+.PP
.SH FILES
.IR ~em/lib/em_pc :
binary of the Pascal compiler.
.SH DIAGNOSTICS
All warning and error messages are written on standard error output.
-.SH REMARKS
-Debugging and profiling facilities may be present during the development
-of \fIem_pc\fP.
+Descriptions of run-time errors are read from ~em/etc/pc_rt_errors.
{
/* Enter a definition for "name" with kind "kind" and type
"type" in the Current Scope. If it is a standard name, also
- put its number in the definition structure.
+ put its number in the definition structure, and mark the
+ name as set, to inhibit warnings about used before set.
*/
register struct def *df;
df = define(str2idf(name, 0), CurrentScope, kind);
df->df_type = type;
- if( pnam ) df->df_value.df_reqname = pnam;
+ if( pnam ) {
+ df->df_value.df_reqname = pnam;
+ df->df_flags |= D_SET;
+ }
return df;
}
!strcmp(output, idlist->nd_IDF->id_text)
) {
/* the occurence of input or output as program-
- * parameter is their declartion as a GLOBAL variable
- * of type text
+ * parameter is their declaration as a GLOBAL
+ * variable of type text
*/
if( df = define(idlist->nd_IDF, CurrentScope,
D_VARIABLE) ) {
df->df_type = text_type;
- df->df_flags |= (D_PROGPAR | D_NOREG);
+ df->df_flags |= (D_SET | D_PROGPAR | D_NOREG);
if( !strcmp(input, idlist->nd_IDF->id_text) ) {
df->var_name = input;
set_inp();
D_PARAMETER) ) {
df->df_type = error_type;
df->df_flags |= D_PROGPAR;
+ df->var_name = idlist->nd_IDF->id_text;
}
}
if( df = define(idlist->nd_IDF, CurrentScope, D_ENUM) ) {
df->df_type = type;
df->enm_val = (type->enm_ncst)++;
+ df->df_flags |= D_SET;
}
FreeNode(Idlist);
}
for( id = fpl->nd_left; id; id = id->nd_next )
if( df = define(id->nd_IDF, CurrentScope, D_VARIABLE) ) {
df->var_off = nb_pars;
- if( fpl->nd_INT == D_VARPAR || IsConformantArray(tp) )
+ if( fpl->nd_INT & D_VARPAR || IsConformantArray(tp) )
nb_pars += pointer_size;
else
nb_pars += tp->tp_size;
return nb_pars;
}
+arith
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 arith nb_pars = 0;
register struct node *id;
+ struct type *tp;
struct def *df;
- for( ; fpl; fpl = fpl->nd_right )
+ for( ; fpl; fpl = fpl->nd_right ) {
+ tp = fpl->nd_type;
for( id = fpl->nd_left; id; id = id->nd_next )
if( df = new_def() ) {
+ if( fpl->nd_INT & D_VARPAR ||
+ IsConformantArray(tp) )
+ nb_pars += pointer_size;
+ else
+ nb_pars += tp->tp_size;
LinkParam(parlist, df);
- df->df_type = fpl->nd_type;
+ df->df_type = tp;
df->df_flags |= fpl->nd_INT;
}
+ while( IsConformantArray(tp) ) {
+ nb_pars += 3 * word_size;
+ tp = tp->arr_elem;
+ }
+ }
+ return nb_pars;
}
LinkParam(parlist, df)
static unsigned int last_ln = 0;
unsigned int ln = 0;
static char * last_fn = 0;
- static int e_seen = 0;
+ static int e_seen = 0, w_seen = 0;
register char *remark = 0;
/* Since name and number are gathered from different places
#endif
if( FileName == last_fn && ln == last_ln ) {
/* we've seen this place before */
- e_seen++;
- if( e_seen == MAXERR_LINE ) fmt = "etc ...";
- else if( e_seen > MAXERR_LINE )
- /* and too often, I'd say ! */
- return;
+ if( class != WARNING && class != LEXWARNING ) {
+ e_seen++;
+ if( e_seen == MAXERR_LINE ) fmt = "etc ...";
+ else if( e_seen > MAXERR_LINE )
+ /* and too often, I'd say ! */
+ return;
+ }
+ else {
+ w_seen++;
+ if( w_seen == MAXERR_LINE ) fmt = "etc ...";
+ else if( w_seen > MAXERR_LINE )
+ return;
+ }
}
else {
/* brand new place */
last_ln = ln;
last_fn = FileName;
- e_seen = 0;
+ e_seen = w_seen = 0;
}
#ifdef DEBUG
}
#include "chk_expr.h"
#include "def.h"
#include "main.h"
+#include "misc.h"
+#include "idf.h"
#include "node.h"
#include "scope.h"
#include "type.h"
;
ConstantIdentifier(register struct node **pnd;):
- IDENT { *pnd = MkLeaf(Name, &dot); }
+ IDENT { *pnd = MkLeaf(Name, &dot);
+ }
;
/* ISO section 6.7.1, p. 121 */
/* This is a changed rule, because the grammar as specified in the
* reference is not LL(1), and this gives conflicts.
*/
+ %default
%prefer /* solve conflicts on IDENT and UnsignedConstant */
IDENT { *pnd = MkLeaf(Name, &dot); }
[
/* ISO section 6.7.3, p. 126
* IDENT is a FunctionIdentifier
*/
- { *pnd = MkNode(Call, *pnd, NULLNODE, &dot); }
+ {
+ *pnd = MkNode(Call, *pnd, NULLNODE, &dot);
+ }
ActualParameterList(&((*pnd)->nd_right))
|
/* IDENT can be a BoundIdentifier or a ConstantIdentifier or
{ int class;
df = lookfor(*pnd, CurrVis, 1);
+ /* df->df_flags |= D_USED; */
if( df->df_type->tp_fund & T_ROUTINE ) {
/* This part is context-sensitive:
is the occurence of the proc/func name
{ if( ChkExpression(*pnd) &&
(*pnd)->nd_type != bool_type )
node_error(*pnd, "boolean expression expected");
+ MarkUsed(*pnd);
}
;
{
struct def *df;
- if( !(df = define(nd->nd_IDF, CurrentScope, D_LABEL)) )
+ if( !(df = define(nd->nd_IDF, CurrentScope, D_LABEL)) ) {
node_error(nd, "label %s redeclared", nd->nd_IDF->id_text);
+ }
else {
df->lab_no = ++text_label;
nd->nd_def = df;
else
FreeNode(nd);
+ df->df_flags = D_USED;
if( !df->lab_level ) {
/* forward jump */
register struct lab *labelptr;
{
register struct def *df;
- if( !(df = lookup(nd->nd_IDF, BlockScope)) ) {
+ if( !(df = lookup(nd->nd_IDF, BlockScope, D_INUSE)) ) {
node_error(nd, "label %s must be declared in same block"
, nd->nd_IDF->id_text);
df = define(nd->nd_IDF, BlockScope, D_LABEL);
}
else FreeNode(nd);
+ df->df_flags |= D_SET;
if( df->lab_level)
node_error(nd, "label %s already defined", nd->nd_IDF->id_text);
else {
/* L O O K U P R O U T I N E S */
+#include <alloc.h>
#include <em_arith.h>
#include <em_label.h>
+#include <assert.h>
#include "LLlex.h"
#include "def.h"
#include "scope.h"
#include "type.h"
+remove_def(df)
+ register struct def *df;
+{
+ struct idf *id= df->df_idf;
+ struct def *df1 = id->id_def;
+
+ if( df1 == df ) id->id_def = df->df_next;
+ else {
+ while( df1 && df1->df_next != df ) df1 = df1->df_next;
+ df1->df_next = df->df_next;
+ free_def(df);
+ }
+}
+
struct def *
-lookup(id, scope)
+lookup(id, scope, inuse)
register struct idf *id;
struct scope *scope;
{
df && df->df_scope != scope;
df1 = df, df = df->df_next ) { /* nothing */ }
- if( df && df1 ) {
- /* Put the definition in front
+ if( df ) {
+ /* Found it
*/
- df1->df_next = df->df_next;
- df->df_next = id->id_def;
- id->id_def = df;
+ if( df1) {
+ /* Put the definition in front
+ */
+ df1->df_next = df->df_next;
+ df->df_next = id->id_def;
+ id->id_def = df;
+ }
+ while( df->df_kind & inuse ) {
+ assert(df->usd_def != 0);
+ df=df->usd_def;
+ }
}
+
return df;
}
If it is not defined create a dummy definition and
if give_error is set, give an error message.
*/
- register struct def *df;
+ register struct def *df, *tmp_df;
register struct scopelist *sc = vis;
while( sc ) {
- df = lookup(id->nd_IDF, sc->sc_scope);
- if( df ) return df;
+ df = lookup(id->nd_IDF, sc->sc_scope, D_INUSE);
+ if( df ) {
+ while( vis->sc_scope->sc_level >
+ sc->sc_scope->sc_level ) {
+ if( tmp_df = define(id->nd_IDF, vis->sc_scope,
+ D_INUSE))
+ tmp_df->usd_def = df;
+ vis = nextvisible(vis);
+ }
+ /* Since the scope-level of standard procedures is the
+ * same as for the user-defined procedures, the procedure
+ * must be marked as used. Not doing so would mean that
+ * such a procedure could redefined after usage.
+ */
+ if( (vis->sc_scope == GlobalScope) &&
+ !lookup(id->nd_IDF, GlobalScope, D_INUSE) ) {
+ if( tmp_df = define(id->nd_IDF, vis->sc_scope,
+ D_INUSE))
+ tmp_df->usd_def = df;
+ }
+
+ return df;
+ }
sc = nextvisible(sc);
}
#include "LLlex.h"
#include "Lpars.h"
+#include "class.h"
#include "const.h"
#include "def.h"
#include "f_info.h"
Nargv[Nargc] = 0; /* terminate the arg vector */
if( Nargc < 2 ) {
fprint(STDERR, "%s: Use a file argument\n", ProgName);
- exit(1);
+ sys_stop(S_EXIT);
}
- exit(!Compile(Nargv[1], Nargv[2]));
+ if(!Compile(Nargv[1], Nargv[2])) sys_stop(S_EXIT);
+ sys_stop(S_END);
}
Compile(src, dst)
{
extern struct tokenname tkidf[];
extern struct tokenname tkstandard[];
+ int tk;
if( !InsertFile(src, (char **) 0, &src) ) {
fprint(STDERR, "%s: cannot open %s\n", ProgName, src);
InitCst();
reserve(tkidf);
reserve(tkstandard);
+
+ CheckForLineDirective();
+ tk = LLlex(); /* Read the first token and put */
+ aside = dot; /* it aside. In this way, options */
+ asidetype = toktype; /* inside comments will be seen */
+ dot.tk_symb = tk; /* before the program starts. */
+ tokenseen = 1;
+
InitScope();
InitTypes();
AddRequired();
+
+ if( options['c'] ) tkclass['"'] = STSTR;
+ if( options['u'] || options['U'] ) {
+ class('_') = STIDF;
+ inidf['_'] = 1;
+ }
+ if( tk == '"' || tk == '_' ) {
+ PushBack();
+ ASIDE = 0;
+ }
+
#ifdef DEBUG
if( options['l'] ) {
LexScan();
- return 1;
+ return 0; /* running the optimizer is not very useful */
}
#endif DEBUG
C_init(word_size, pointer_size);
C_magic();
C_ms_emx(word_size, pointer_size);
C_df_dlb(++data_label);
- C_rom_scon(FileName, strlen(FileName) + 1);
+ C_rom_scon(FileName,(arith) strlen(FileName) + 1);
LLparse();
C_ms_src((arith) (LineNumber - 1), FileName);
if( fp_used ) C_ms_flt();
/* DYNAMIC ALLOCATION PROCEDURES */
(void) Enter("new", D_PROCEDURE, std_type, R_NEW);
(void) Enter("dispose", D_PROCEDURE, std_type, R_DISPOSE);
+ if( !options['s'] ) {
+ (void) Enter("mark", D_PROCEDURE, std_type, R_MARK);
+ (void) Enter("release", D_PROCEDURE, std_type, R_RELEASE);
+ }
+
+ /* MISCELLANEOUS PROCEDURE(S) */
+ if( !options['s'] )
+ (void) Enter("halt", D_PROCEDURE, std_type, R_HALT);
/* TRANSFER PROCEDURES */
(void) Enter("pack", D_PROCEDURE, std_type, R_PACK);
(void) Enter("boolean", D_TYPE, bool_type, 0);
(void) Enter("text", D_TYPE, text_type, 0);
+ if( options['d'] )
+ (void) Enter("long", D_TYPE, long_type, 0);
+ if( options['c'] )
+ (void) Enter("string", D_TYPE, string_type, 0);
+
/* DIRECTIVES */
(void) Enter("forward", D_FORWARD, NULLTYPE, 0);
(void) Enter("extern", D_EXTERN, NULLTYPE, 0);
df = Enter("maxint", D_CONST, int_type, 0);
df->con_const = &maxintnode;
+ df->df_flags |= D_SET;
maxintnode.nd_type = int_type;
maxintnode.nd_INT = max_int; /* defined in cstoper.c */
df = Enter("true", D_ENUM, bool_type, 0);
df->enm_val = 1;
+ df->df_flags |= D_SET;
df->enm_next = Enter("false", D_ENUM, bool_type, 0);
df = df->enm_next;
df->enm_val = 0;
+ df->df_flags |= D_SET;
df->enm_next = NULLDEF;
}
extern char
*gen_proc_name();
+
+extern char *symbol2str();
+extern arith NewInt();
+extern arith NewPtr();
+extern arith CodeBeginBlock();
+extern arith EnterParamList();
+extern arith EnterParTypes();
+extern arith CodeInitFor();
+extern arith IsString();
--- /dev/null
+/* Accepted if many characters of long names are significant */
+abcdefghijklmnopr() { }
+abcdefghijklmnopq() { }
+main() { }
#define Link 11
#define LinkDef 12
#define Cast 13 /* convert integer to real */
+#define IntCoerc 14 /* coercion of integers to longs */
+#define IntReduc 15 /* reduction of longs to integers */
/* do NOT change the order or the numbers!!! */
struct type *nd_type; /* type of this node */
struct token nd_token;
#include "idfsize.h"
#include "main.h"
#include "type.h"
+#include "nocross.h"
#define MINIDFSIZE 9
break;
/* recognized flags:
-i: largest value of set of integer
- -u: allow underscore in identifier
+ -u, -U: allow underscore in identifier
-w: no warnings
+ -R: no range checks
+ -A: range checks for array references
and many more if DEBUG
*/
idfsize = txt2int(&t);
text = t;
- if( idfsize <= 0 || *t )
+ if( idfsize <= 0 || *t ) {
fatal("malformed -M option");
/*NOTREACHED*/
+ }
if( idfsize > IDFSIZE ) {
idfsize = IDFSIZE;
warning("maximum identifier length is %d", IDFSIZE);
break;
}
- case 'u': /* underscore allowed in identifiers */
- class('_') = STIDF;
- inidf['_'] = 1;
- break;
+ /* case 'u': /* underscore allowed in identifiers */
+ /* class('_') = STIDF;
+ /* inidf['_'] = 1;
+ /* break;
+ */
case 'V' : { /* set object sizes and alignment requirements */
- /* syntax : -V[ [w|i|f|p] size? [.alignment]? ]* */
-
+ /* syntax : -V[ [w|i|l|f|p] size? [.alignment]? ]* */
+#ifndef NOCROSS
register arith size;
register int align;
char c, *t;
align = txt2int(&t);
text = t;
}
- if( !strindex("wifpS", c) )
+ if( !strindex("wilfpS", c) )
error("-V: bad type indicator %c\n", c);
if( size )
switch( c ) {
case 'i': /* int */
int_size = size;
break;
+ case 'l': /* long */
+ long_size = size;
+ break;
case 'f': /* real */
real_size = size;
break;
case 'i': /* int */
int_align = align;
break;
+ case 'l': /* long */
+ long_align = align;
+ break;
case 'f': /* real */
real_align = align;
break;
}
}
break;
+#endif NOCROSS
}
}
}
#include "LLlex.h"
#include "def.h"
+#include "f_info.h"
+#include "idf.h"
#include "main.h"
#include "node.h"
#include "scope.h"
Program
{
struct def *df;
+ arith dummy;
}:
ProgramHeading(&df) ';' Block(df) '.'
+ | { df = new_def();
+ df->df_idf = str2idf(FileName, 1);
+ df->df_kind = D_MODULE;
+ open_scope();
+ GlobalScope = CurrentScope;
+ df->prc_vis = CurrVis;
+ }
+
+ Module(df, &dummy)
;
ProgramHeading(register struct def **df;):
'('
ProgramParameters
')'
+ { make_extfl(); }
]?
;
#include "debug.h"
#include <em.h>
+#include <assert.h>
#include "LLlex.h"
#include "def.h"
make_extfl()
{
- register struct def *df;
+ if( err_occurred ) return;
extfl_label = ++data_label;
C_df_dlb(extfl_label);
- if( inpflag )
+ if( inpflag ) {
+ C_ina_dnam(input);
C_con_dnam(input, (arith) 0);
+ }
else
C_con_ucon("0", pointer_size);
- if( outpflag )
+ if( outpflag ) {
+ C_ina_dnam(output);
C_con_dnam(output, (arith) 0);
+ }
else
C_con_ucon("0", pointer_size);
extflc = 2;
- for( df = GlobalScope->sc_def; df; df = df->df_nextinscope )
- if( (df->df_flags & D_PROGPAR) &&
- df->var_name != input && df->var_name != output) {
- C_con_dnam(df->var_name, (arith) 0);
- extflc++;
- }
+ /* Process the identifiers in the global scope (at this point only
+ * the program parameters) in order of specification.
+ */
+ make_extfl_args( GlobalScope->sc_def );
+}
+
+make_extfl_args(df)
+ register struct def *df;
+{
+ if( !df ) return;
+ make_extfl_args(df->df_nextinscope);
+ assert(df->df_flags & D_PROGPAR);
+ if( df->var_name != input && df->var_name != output ) {
+ C_ina_dnam(df->var_name);
+ C_con_dnam(df->var_name, (arith) 0);
+ extflc++;
+ }
}
call_ini()
{
C_lxl((arith) 0);
- C_lae_dlb(extfl_label, (arith) 0);
+ if( extflc )
+ C_lae_dlb(extfl_label, (arith) 0);
+ else
+ C_zer(pointer_size);
C_loc((arith) extflc);
C_lxa((arith) 0);
C_cal("_ini");
#include "LLlex.h"
#include "def.h"
#include "main.h"
+#include "misc.h"
#include "node.h"
#include "scope.h"
#include "type.h"
+/* DEBUG */
+#include "idf.h"
+
ChkRead(arg)
register struct node *arg;
{
struct node *file;
char *name = "read";
+ char *message, buff[80];
+ extern char *ChkAllowedVar();
assert(arg);
assert(arg->nd_symb == ',');
"\"%s\": illegal parameter type",name);
return;
}
+ else if( (BaseType(file->nd_type->next) == long_type
+ && arg->nd_left->nd_type == int_type)
+ ||
+ (BaseType(file->nd_type->next) == int_type
+ && arg->nd_left->nd_type == long_type) ) {
+ if( int_size != long_size ) {
+ node_error(arg->nd_left,
+ "\"%s\": longs and integers have different sizes",name);
+ return;
+ }
+ else node_warning(arg->nd_left,
+ "\"%s\": mixture of longs and integers", name);
+ }
}
else if( !(BaseType(arg->nd_left->nd_type)->tp_fund &
( T_CHAR | T_NUMERIC )) ) {
"\"%s\": illegal parameter type",name);
return;
}
+ message = ChkAllowedVar(arg->nd_left, 1);
+ if( message ) {
+ sprint(buff,"\"%%s\": %s can't be a variable parameter",
+ message);
+ node_error(arg->nd_left, buff, name);
+ return;
+ }
+
CodeRead(file, arg->nd_left);
arg = arg->nd_right;
}
{
struct node *file;
char *name = "readln";
+ char *message, buff[80];
+ extern char *ChkAllowedVar();
if( !arg ) {
if( !(file = ChkStdInOut(name, 0)) )
"\"%s\": illegal parameter type",name);
return;
}
+ message = ChkAllowedVar(arg->nd_left, 1);
+ if( message ) {
+ sprint(buff,"\"%%s\": %s can't be a variable parameter",
+ message);
+ node_error(arg->nd_left, buff, name);
+ return;
+ }
CodeRead(file, arg->nd_left);
arg = arg->nd_right;
}
tp = BaseType(arg->nd_left->nd_type);
if( filetype == text_type ) {
- if( !(tp == bool_type || tp->tp_fund & (T_CHAR | T_NUMERIC) ||
- IsString(tp)) ) {
+ if( !(tp == bool_type ||
+ tp->tp_fund & (T_CHAR | T_NUMERIC | T_STRING) ||
+ IsString(tp)) ) {
node_error(arg->nd_left, "\"%s\": %s", name, mess);
return 0;
}
register struct def *df;
register struct node *nd;
- if( !(df = lookup(str2idf(st_out ? output : input, 0), GlobalScope)) ||
- !(df->df_flags & D_PROGPAR) ) {
+ if( !(df = lookup(str2idf(st_out ? output : input, 0),
+ GlobalScope, D_INUSE)) ||
+ !(df->df_flags & D_PROGPAR) ) {
error("\"%s\": standard input/output not defined", name);
return NULLNODE;
}
nd = MkLeaf(Def, &dot);
nd->nd_def = df;
nd->nd_type = df->df_type;
+ df->df_flags |= D_USED;
return nd;
}
C_cal("_rdi");
break;
+ case T_LONG:
+ C_cal("_rdl");
+ break;
+
case T_REAL:
C_cal("_rdr");
break;
RangeCheck(arg->nd_type, file->nd_type->next);
C_loi(file->nd_type->next->tp_psize);
- if( BaseType(file->nd_type->next) == int_type &&
- tp == real_type )
- Int2Real();
+ if( tp == real_type ) {
+ if( BaseType(file->nd_type->next) == int_type ||
+ BaseType(file->nd_type->next) == long_type )
+ Int2Real(file->nd_type->next->tp_psize);
+ }
CodeDStore(arg);
C_cal("_get");
CodePExpr(expp);
if( file->nd_type == text_type ) {
- if( tp->tp_fund & (T_ARRAY | T_STRING) ) {
+ if( tp->tp_fund & (T_ARRAY | T_STRINGCONST) ) {
C_loc(IsString(tp));
nbpars += pointer_size + int_size;
}
C_cal(width ? "_wsi" : "_wri");
break;
+ case T_LONG:
+ C_cal(width ? "_wsl" : "_wrl");
+ break;
+
case T_REAL:
if( right ) {
CodePExpr(right->nd_left);
break;
case T_ARRAY:
- case T_STRING:
+ case T_STRINGCONST:
C_cal(width ? "_wss" : "_wrs");
break;
+ case T_STRING:
+ C_cal(width ? "_wsz" : "_wrz");
+ break;
+
default:
- crash("CodeWrite)");
+ crash("(CodeWrite)");
/*NOTREACHED*/
}
C_asp(nbpars);
}
else {
if( file->nd_type->next == real_type && tp == int_type )
- Int2Real();
+ Int2Real(int_size);
+ else if( file->nd_type->next == real_type && tp == long_type )
+ Int2Real(long_size);
CodeDAddress(file);
C_cal("_wdw");
/* DYNAMIC ALLOCATION */
#define R_NEW 6
#define R_DISPOSE 7
+#define R_MARK 8
+#define R_RELEASE 9
+
+/* MISCELLANEOUS PROCEDURE(S) */
+#define R_HALT 10
/* TRANSFER */
-#define R_PACK 8
-#define R_UNPACK 9
+#define R_PACK 11
+#define R_UNPACK 12
/* FUNCTIONS */
/* ARITHMETIC */
-#define R_ABS 10
-#define R_SQR 11
-#define R_SIN 12
-#define R_COS 13
-#define R_EXP 14
-#define R_LN 15
-#define R_SQRT 16
-#define R_ARCTAN 17
+#define R_ABS 13
+#define R_SQR 14
+#define R_SIN 15
+#define R_COS 16
+#define R_EXP 17
+#define R_LN 18
+#define R_SQRT 19
+#define R_ARCTAN 20
/* TRANSFER */
-#define R_TRUNC 18
-#define R_ROUND 19
+#define R_TRUNC 21
+#define R_ROUND 22
/* ORDINAL */
-#define R_ORD 20
-#define R_CHR 21
-#define R_SUCC 22
-#define R_PRED 23
+#define R_ORD 23
+#define R_CHR 24
+#define R_SUCC 25
+#define R_PRED 26
/* BOOLEAN */
-#define R_ODD 24
-#define R_EOF 25
-#define R_EOLN 26
+#define R_ODD 27
+#define R_EOF 28
+#define R_EOLN 29
if( df->df_kind & D_PARAMETER ) {
if( !is_anon_idf(df->df_idf) ) {
if( df->df_type == error_type )
- error("program parameter \"%s\" must be a global variable",
+ error("program parameter \"%s\" must be a global variable",
df->df_idf->id_text);
else if( df->df_type->tp_fund != T_FILE )
error("program parameter \"%s\" must have a file type",
#include "chk_expr.h"
#include "def.h"
#include "desig.h"
+#include "f_info.h"
#include "idf.h"
#include "main.h"
+#include "misc.h"
#include "node.h"
#include "scope.h"
#include "type.h"
SimpleStatement
{
struct node *pnd, *expp;
+ unsigned short line;
} :
/* This is a changed rule, because the grammar as specified in the
* reference is not LL(1), and this gives conflicts.
* Note : the grammar states : AssignmentStatement |
* ProcedureStatement | ...
+ * In order to add assertions, there is an extra entry, which gives
+ * a conflict. This conflict is then resolved using an %if clause.
*/
EmptyStatement
|
|
/* Evidently this is the beginning of the changed part
*/
+ %if( !options['s'] && !strcmp(dot.TOK_IDF->id_text, "assert") )
+ IDENT { line = LineNumber; }
+ Expression(&expp)
+ { AssertStat(expp, line); }
+|
IDENT { pnd = MkLeaf(Name, &dot); }
- [
+ [ %default
+
/* At this point the IDENT can be a FunctionIdentifier in
* which case the VariableAccessTail must be empty.
*/
VariableAccessTail(&pnd)
[
+ %default
BECOMES
|
'=' { error("':=' expected instead of '='"); }
FreeNode(pnd);
}
+
]
|
InputOutputStatement
Statement
{ if( !err_occurred )
CodeEndFor(nd, stepsize, l1, l2, tmp2);
+ EndForStat(nd);
chk_labels(slevel + 1);
FreeNode(nd);
if( tmp1 ) FreeInt(tmp1);
Expression(pnd)
{ if( !ChkExpression(*pnd) )
(*pnd)->nd_type = error_type;
+ MarkUsed(*pnd);
*pnd = nd =
MkNode(Link, *pnd, NULLNODE, &dot);
nd->nd_symb = ':';
Expression(&(nd->nd_left))
{ if( !ChkExpression(nd->nd_left) )
nd->nd_left->nd_type = error_type;
+ MarkUsed(nd->nd_left);
}
[
':' { nd->nd_right = MkLeaf(Link, &dot);
Expression(&(nd->nd_left))
{ if( !ChkExpression(nd->nd_left) )
nd->nd_left->nd_type = error_type;
+ MarkUsed(nd->nd_left);
}
]?
]?
#define T_PROCEDURE 0x0010
#define T_FUNCTION 0x0020
#define T_FILE 0x0040
-#define T_STRING 0x0080
+#define T_STRINGCONST 0x0080
#define T_SUBRANGE 0x0100
#define T_SET 0x0200
#define T_ARRAY 0x0400
#define T_RECORD 0x0800
#define T_POINTER 0x1000
-#define T_ERROR 0x2000 /* bad type */
-#define T_NUMERIC (T_INTEGER | T_REAL)
-#define T_INDEX (T_SUBRANGE | T_ENUMERATION | T_CHAR)
-#define T_ORDINAL (T_INTEGER | T_INDEX)
-#define T_CONSTRUCTED (T_ARRAY | T_SET | T_RECORD | T_FILE | T_STRING)
+#define T_LONG 0x2000
+#define T_STRING 0x4000
+#define T_ERROR 0x8000 /* bad type */
+#define T_NUMERIC (T_INTEGER | T_REAL | T_LONG)
+#define T_INDEX (T_SUBRANGE | T_ENUMERATION | T_CHAR | T_INTEGER )
+#define T_ORDINAL (T_INDEX | T_LONG)
+#define T_CONSTRUCTED (T_ARRAY | T_SET | T_RECORD | T_FILE | T_STRINGCONST)
#define T_ROUTINE (T_FUNCTION | T_PROCEDURE)
unsigned short tp_flags;
#define T_HASFILE 0x1 /* set if type has a filecomponent */
*bool_type,
*char_type,
*int_type,
+ *long_type,
*real_type,
+ *string_type,
*std_type,
*text_type,
*nil_type,
*emptyset_type,
*error_type; /* All from type.c */
+#include "nocross.h"
+#ifdef NOCROSS
+#include "target_sizes.h"
+#define word_align (AL_WORD)
+#define int_align (AL_INT)
+#define long_align (AL_LONG)
+#define pointer_align (AL_POINTER)
+#define real_align (AL_REAL)
+#define struct_align (AL_STRUCT)
+
+#define word_size (SZ_WORD)
+#define int_size (SZ_INT)
+#define long_size (SZ_LONG)
+#define pointer_size (SZ_POINTER)
+#define real_size (SZ_REAL)
+#else NOCROSS
extern int
word_align,
int_align,
+ long_align,
pointer_align,
real_align,
struct_align; /* All from type.c */
extern arith
word_size,
int_size,
+ long_size,
pointer_size,
real_size; /* All from type.c */
+#endif NOCROSS
extern arith
align();
/* T Y P E D E F I N I T I O N M E C H A N I S M */
#include "debug.h"
-#include "target_sizes.h"
#include <alloc.h>
#include <assert.h>
#include "scope.h"
#include "type.h"
+#ifndef NOCROSS
+#include "target_sizes.h"
int
word_align = AL_WORD,
int_align = AL_INT,
+ long_align = AL_LONG,
pointer_align = AL_POINTER,
real_align = AL_REAL,
struct_align = AL_STRUCT;
arith
word_size = SZ_WORD,
int_size = SZ_INT,
+ long_size = SZ_LONG,
pointer_size = SZ_POINTER,
real_size = SZ_REAL;
+#endif NOCROSS
+
+extern arith max_int;
struct type
*bool_type,
*char_type,
*int_type,
+ *long_type,
*real_type,
+ *string_type,
*std_type,
*text_type,
*nil_type,
*emptyset_type,
*error_type;
-InitTypes()
+CheckTypeSizes()
{
- /* Initialize the predefined types
- */
-
/* first, do some checking
*/
if( int_size != word_size )
fatal("integer size not equal to word size");
+ if( word_size != 2 && word_size != 4 )
+ fatal("illegal wordsize");
+ if( pointer_size != 2 && pointer_size != 4 )
+ fatal("illegal pointersize");
+ if( options['d'] ) {
+ if( long_size < int_size )
+ fatal("longsize should be at least the integersize");
+ if( long_size > 2 * int_size)
+ fatal("longsize should be at most twice the integersize");
+ }
+ if( pointer_size < word_size )
+ fatal("pointersize should be at least the wordsize");
+ if( real_size != 4 && real_size != 8 )
+ fatal("illegal realsize");
+}
+
+InitTypes()
+{
+ /* First check the sizes of some basic EM-types
+ */
+ CheckTypeSizes();
+ if( options['s'] ) {
+ options['c'] = 0;
+ options['d'] = 0;
+ options['u'] = 0;
+ options['C'] = 0;
+ options['U'] = 0;
+ }
+
+ /* Initialize the predefined types
+ */
/* character type
*/
*/
real_type = standard_type(T_REAL, real_align, real_size);
+ /* long type
+ */
+ if( options['d'] )
+ long_type = standard_type(T_LONG, long_align, long_size);
+
+ /* string type
+ */
+ if( options['c'] )
+ string_type = standard_type(T_STRING, pointer_align, pointer_size);
+
/* an unique type for standard procedures and functions
*/
std_type = construct_type(T_PROCEDURE, NULLTYPE);
emptyset_type->tp_align = word_align;
}
+int
+fit(sz, nbytes)
+ arith sz;
+{
+ return ((sz) + ((arith)0x80<<(((nbytes)-1)*8)) & ~full_mask[(nbytes)]) == 0;
+}
+
struct type *
standard_type(fund, algn, size)
arith size;
register struct type **ptp;
register struct node *nd;
{
+ register struct def *df;
+
*ptp = error_type;
if( ChkLinkOrName(nd) ) {
if( nd->nd_class != Def )
node_error(nd, "type expected");
else {
- register struct def *df = nd->nd_def;
+ /* register struct def *df = nd->nd_def; */
+ df = nd->nd_def;
- if( df->df_kind & (D_TYPE | D_FTYPE | D_ERROR) )
+ df->df_flags |= D_USED;
+ if( df->df_kind & (D_TYPE | D_FTYPE | D_ERROR) ) {
if( !df->df_type )
node_error(nd, "type \"%s\" not declared",
df->df_idf->id_text);
else
*ptp = df->df_type;
+ }
else
node_error(nd,"identifier \"%s\" is not a type",
df->df_idf->id_text);
*plo = tp->sub_lb;
*phi = tp->sub_ub;
}
- else {
+ else if( tp->tp_fund & T_INTEGER ) {
+ *plo = -max_int;
+ *phi = max_int;
+ }
+ else {
*plo = 0;
*phi = tp->enm_ncst - 1;
}
/* algn is not a dividor of the word size, so make sure it
is a multiple
*/
- return WA(algn);
+ algn = WA(algn);
+ }
+ if( !fit(algn, (int) word_size) ) {
+ error("element of array too large");
}
return algn;
}
*/
register struct type *index_type = IndexType(tp);
register struct type *elem_type = tp->arr_elem;
- arith lo, hi;
+ arith lo, hi, diff;
tp->tp_flags |= T_CHECKED;
- tp->arr_elsize = ArrayElSize(elem_type, IsPacked(tp));
+ tp->arr_elsize = ArrayElSize(elem_type,(int) IsPacked(tp));
/* check index type
*/
}
getbounds(index_type, &lo, &hi);
+ diff = hi - lo;
- tp->tp_psize = (hi - lo + 1) * tp->arr_elsize;
+ if( diff < 0 || !fit(diff, (int) word_size) ) {
+ error("too many elements in array");
+ }
+
+ if( (unsigned long)full_mask[(int) pointer_size]/(diff + 1) <
+ tp->arr_elsize ) {
+ error("array too large");
+ }
+ tp->tp_psize = (diff + 1) * tp->arr_elsize;
tp->tp_palign = (word_size % tp->tp_psize) ? word_align : tp->tp_psize;
tp->tp_size = WA(tp->tp_psize);
tp->tp_align = word_align;
tp->arr_ardescr = ++data_label;
C_df_dlb(data_label);
C_rom_cst(lo);
- C_rom_cst(hi - lo);
+ C_rom_cst(diff);
C_rom_cst(tp->arr_elsize);
}
while( scl ) {
/* look in enclosing scopes */
df1 = lookup(df->df_fortype->f_node->nd_IDF,
- scl->sc_scope);
+ scl->sc_scope, D_INUSE);
if( df1 ) break;
scl = nextvisible( scl );
}
- if( !df1 || df1->df_kind != D_TYPE )
+ if( !df1 || df1->df_kind != D_TYPE ) {
/* bad forward type */
tp = error_type;
+ }
else { /* ok */
tp = df1->df_type;
CurrentScope->sc_def = df->df_nextinscope;
else
ldf->df_nextinscope = df->df_nextinscope;
+
+ /* remove the def struct from symbol-table */
+ remove_def(df);
}
}
else /* forward type was resolved */
}
FreeForward( df->df_fortype );
+ df->df_flags |= D_USED;
if( tp == error_type )
df->df_kind = D_ERROR;
else
print("ENUMERATION; ncst:%d", tp->enm_ncst); break;
case T_INTEGER:
print("INTEGER"); break;
+ case T_LONG:
+ print("LONG"); break;
case T_REAL:
print("REAL"); break;
case T_CHAR:
print("CHAR"); break;
+ case T_STRING:
+ print("STRING"); break;
case T_PROCEDURE:
case T_FUNCTION:
{
}
case T_FILE:
print("FILE"); break;
- case T_STRING:
- print("STRING"); break;
+ case T_STRINGCONST:
+ print("STRINGCONST"); break;
case T_SUBRANGE:
print("SUBRANGE %ld-%ld", (long) tp->sub_lb, (long) tp->sub_ub);
break;
{
/* test if two types are equivalent.
*/
-
return tp1 == tp2 || tp1 == error_type || tp2 == error_type;
}
register struct type *tp;
{
/* string = packed array[1..ub] of char and ub > 1 */
- if( tp->tp_fund & T_STRING ) return tp->tp_psize;
+ if( tp->tp_fund & T_STRINGCONST ) return tp->tp_psize;
if( IsConformantArray(tp) ) return 0;
else return 0;
}
+ /* no clause, just check for longs and ints */
+ /* BaseType is used in case of array indexing */
+ if ((BaseType(tp1) == int_type && tp2 == long_type) ||
+ (tp1 == long_type && tp2 == int_type))
+ return 1;
+
+
/* clause b */
tp1 = BaseType(tp1);
tp2 = BaseType(tp2);
/* clause b */
if( tp1 == real_type )
- return BaseType(tp2) == int_type;
+ return BaseType(tp2) == int_type || BaseType(tp2) == long_type;
return 0;
}
lastactual = actualtype;
- if( actualtype->tp_fund == T_STRING ) {
+ if( actualtype->tp_fund == T_STRINGCONST ) {
actualindextp = int_type;
alb = 1;
aub = actualtype->tp_psize;
return 0;
/* clause (b) */
- if( bounded(actualindextp) || actualindextp->tp_fund == T_STRING ) {
+ if( bounded(actualindextp) ||
+ actualindextp->tp_fund == T_STRINGCONST ) {
/* test was necessary because the actual type could be confor-
mant !!
*/
public / ack.git / commitdiff