d0p1/ack
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

Many improvements by Hans van Eck

Browse source
This commit is contained in:
ceriel 1989-05-03 10:30:22 +00:00
parent 19638876a1
commit a94dec52d8
37 changed files with 1743 additions and 381 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
lang/pc/comp/.distr
View file

@ -3,6 +3,7 @@ LLlex.h
LLmessage.c
Makefile
Parameters
Resolve
body.c
casestat.C
char.tab
@ -38,6 +39,7 @@ make.tokcase
make.tokfile
misc.c
misc.h
nmclash.c
node.H
node.c
options.c

192
lang/pc/comp/LLlex.c
View file

@ -36,6 +36,89 @@ struct type *toktype,
*asidetype;
static int eofseen;
extern int in_compound;
int tokenseen = 0; /* Some comment-options must precede any program text */
/* Warning: The options specified inside comments take precedence over
* the ones on the command line.
*/
CommentOptions()
{
register int ch, ci;
/* Parse options inside comments */
do {
LoadChar(ch);
ci = ch;
switch ( ci ) {
case 'c': /* for strings */
case 'd': /* for longs */
case 's': /* check for standard */
case 'u': /* for underscores */
case 'C': /* for different cases */
case 'U': /* for underscores */
if( tokenseen ) {
lexwarning("the '%c' option must precede any program text", ci);
break;
}
LoadChar(ch);
if( ci == 's' && options[ci] && ch == '-')
lexwarning("option '%c-' overrides previous one", ci);
if( ch == '-' ) options[ci] = 0;
else if( ch == '+' ) options[ci] = 1;
else PushBack();
break;
case 'l': ci = 'L' ; /* for indexing */
/* fall through */
case 'a': /* assertions */
case 't': /* tracing */
case 'A': /* extra array range-checks */
case 'L': /* FIL & LIN instructions */
case 'R': /* range checks */
{
int on_on_minus = (ci == 'L' || ci == 'R');
LoadChar(ch);
if( ch == '-' ) options[ci] = on_on_minus;
else if( ch == '+' ) options[ci] = !on_on_minus;
else PushBack();
break;
}
case 'i':
{
register int i=0;
LoadChar(ch);
while( ch >= '0' && ch <= '9' ) {
i = 10 * i + (ch - '0');
LoadChar(ch);
}
PushBack();
if( tokenseen ) {
lexwarning("the '%c' option must precede any program text", ci);
break;
}
if( i <= 0 ) {
lexwarning("bad '%c' option", ci);
break;
}
max_intset = i;
break;
}
default:
break;
}
LoadChar(ch);
} while (ch == ',' );
PushBack();
}
STATIC
SkipComment()
@ -48,6 +131,7 @@ SkipComment()
register int ch;
LoadChar(ch);
if (ch == '$') CommentOptions();
for (;;) {
if( class(ch) == STNL ) {
LineNumber++;
@ -70,9 +154,10 @@ SkipComment()
}
STATIC struct string *
GetString()
GetString( delim )
register int delim;
{
/* Read a Pascal string, delimited by the character "'".
/* Read a Pascal string, delimited by the character ' or ".
*/
register int ch;
register struct string *str = (struct string *)
@ -83,9 +168,10 @@ GetString()
str->s_str = p = Malloc((unsigned int) ISTRSIZE);
for( ; ; ) {
LoadChar(ch);
if( ch & 0200 )
if( ch & 0200 ) {
fatal("non-ascii '\\%03o' read", ch & 0377);
/*NOTREACHED*/
}
if( class(ch) == STNL ) {
lexerror("newline in string");
LineNumber++;
@ -98,9 +184,9 @@ GetString()
lexerror("end-of-file in string");
break;
}
if( ch == '\'' ) {
if( ch == delim ) {
LoadChar(ch);
if( ch != '\'' )
if( ch != delim )
break;
}
*p++ = ch;
@ -128,6 +214,71 @@ GetString()
return str;
}
static char *s_error = "illegal line directive";
CheckForLineDirective()
{
register int ch;
register int i = 0;
char buf[IDFSIZE + 2];
register char *c = buf;
LoadChar(ch);
if( ch != '#' ) {
PushBack();
return;
}
do { /*
* Skip to next digit. Do not skip newlines.
*/
LoadChar(ch);
if( class(ch) == STNL ) {
LineNumber++;
lexerror(s_error);
return;
}
else if( ch == EOI ) {
eofseen = 1;
break;
}
} while( class(ch) != STNUM );
while( class(ch) == STNUM ) {
i = i * 10 + (ch - '0');
LoadChar(ch);
}
if( ch == EOI ) {
eofseen = 1;
}
while( ch != '"' && ch != EOI && class(ch) != STNL) LoadChar(ch);
if( ch == '"' ) {
do {
LoadChar(ch);
*c++ = ch;
if( class(ch) == STNL ) {
LineNumber++;
error(s_error);
return;
}
} while( ch != '"' );
*--c = '\0';
do {
LoadChar(ch);
} while( class(ch) != STNL );
/*
* Remember the filename
*/
if( !eofseen && strcmp(FileName, buf) ) {
FileName = Salloc(buf,(unsigned) strlen(buf) + 1);
}
}
if( eofseen ) {
error(s_error);
return;
}
LineNumber = i;
}
int
LLlex()
{
@ -148,6 +299,7 @@ LLlex()
tk->tk_lineno = LineNumber;
again1:
if( eofseen ) {
eofseen = 0;
ch = EOI;
@ -158,9 +310,10 @@ again:
if( !options['C'] ) /* -C : cases are different */
TO_LOWER(ch);
if( (ch & 0200) && ch != EOI )
if( (ch & 0200) && ch != EOI ) {
fatal("non-ascii '\\%03o' read", ch & 0377);
/*NOTREACHED*/
}
}
switch( class(ch) ) {
@ -171,12 +324,16 @@ again:
#ifdef DEBUG
cntlines++;
#endif
goto again;
CheckForLineDirective();
goto again1;
case STSKIP:
goto again;
case STGARB:
if( !tokenseen && (ch == '"' || ch == '_') ) {
return tk->tk_symb = ch;
}
if( (unsigned) ch < 0177 )
lexerror("garbage char %c", ch);
else
@ -189,7 +346,7 @@ again:
if( nch == '*' ) { /* (* */
SkipComment();
tk->tk_lineno = LineNumber;
goto again;
goto again1;
}
if( nch == '.' ) /* (. is [ */
return tk->tk_symb = '[';
@ -199,7 +356,7 @@ again:
else if( ch == '{' ) {
SkipComment();
tk->tk_lineno = LineNumber;
goto again;
goto again1;
}
else if( ch == '@' ) ch = '^'; /* @ is ^ */
@ -259,14 +416,15 @@ again:
if( ch == EOI ) eofseen = 1;
else PushBack();
if( buf[0] == '_' ) lexerror("underscore starts identifier");
tk->TOK_IDF = id = str2idf(buf, 1);
return tk->tk_symb = id->id_reserved ? id->id_reserved : IDENT;
}
case STSTR: {
register struct string *str = GetString();
register struct string *str = GetString(ch);
if( str->s_length == 1 ) {
if( str->s_length == 1 && ch == '\'') {
#ifdef DEBUG
if( options['l'] ) {
/* to prevent LexScan from crashing */
@ -280,8 +438,14 @@ again:
free((char *) str);
}
else {
tk->tk_data.tk_str = str;
toktype = standard_type(T_STRING, 1, str->s_length);
if( ch == '\'' ) {
tk->tk_data.tk_str = str;
toktype = standard_type(T_STRINGCONST, 1, str->s_length);
}
else {
tk->tk_data.tk_str = str;
toktype = string_type;
}
}
return tk->tk_symb = STRING;
}
@ -391,7 +555,7 @@ again:
tk->TOK_REL = Salloc("0.0", 4);
lexerror("floating constant too long");
}
else tk->TOK_REL = Salloc(buf, np - buf);
else tk->TOK_REL = Salloc(buf,(unsigned) (np - buf));
toktype = real_type;
return tk->tk_symb = REAL;

1
lang/pc/comp/LLlex.h
View file

@ -45,5 +45,6 @@ struct token {
extern struct token dot, aside;
extern struct type *toktype, *asidetype;
extern int tokenseen;
#define ASIDE aside.tk_symb

8
lang/pc/comp/LLmessage.c
View file

@ -18,6 +18,7 @@
extern char *symbol2str();
extern char *Malloc(), *Salloc();
extern struct idf *gen_anon_idf();
extern int expect_label;
LLmessage(tk)
register int tk;
@ -44,11 +45,14 @@ LLmessage(tk)
Malloc(sizeof (struct string));
dotp->TOK_SLE = 1;
dotp->TOK_STR = Salloc("", 1);
toktype = standard_type(T_STRING, 1, (arith) 1);
toktype = standard_type(T_STRINGCONST, 1, (arith) 1);
break;
case INTEGER:
dotp->TOK_INT = 1;
toktype = int_type;
if( !expect_label )
dotp->TOK_INT = 1;
else
dotp->TOK_INT = -1;
break;
case REAL:
dotp->tk_data.tk_real = (struct real *)

211
lang/pc/comp/Makefile
View file

@ -1,24 +1,33 @@
# make iso-pascal "compiler"
EMHOME = ../../..
MHDIR = $(EMHOME)/modules/h
PKGDIR = $(EMHOME)/modules/pkg
LIBDIR = $(EMHOME)/modules/lib
OBJECTCODE = $(LIBDIR)/libemk.a $(EMHOME)/lib/em_data.a
MDIR = $(EMHOME)/modules
MHDIR = $(MDIR)/h
PKGDIR = $(MDIR)/pkg
LIBDIR = $(MDIR)/lib
OBJECTCODE = $(LIBDIR)/libemk.a
LLGEN = $(EMHOME)/bin/LLgen
MKDEP = $(EMHOME)/bin/mkdep
CURRDIR = .
PRID = $(EMHOME)/bin/prid
CID = $(EMHOME)/bin/cid
CURRDIR =
CC = fcc
CC = cc
PRINTER = vu45
LINT = lint
INCLUDES = -I$(MHDIR) -I$(EMHOME)/h -I$(PKGDIR)
OLIBS = $(LIBDIR)/libem_mes.a $(OBJECTCODE) $(LIBDIR)/libinput.a $(LIBDIR)/libassert.a $(LIBDIR)/liballoc.a $(MALLOC) $(LIBDIR)/libprint.a $(LIBDIR)/libstring.a $(LIBDIR)/libsystem.a
GFILES = tokenfile.g declar.g expression.g program.g statement.g
LLGENOPTIONS =
PROFILE =
CFLAGS = $(PROFILE) $(INCLUDES) -DSTATIC=
LINTFLAGS = -DSTATIC=
COPTIONS =
OPTIM= -O
CFLAGS = $(PROFILE) $(INCLUDES) $(OPTIM) $(COPTIONS) -DSTATIC=
LINTFLAGS = -DSTATIC= -DNORCSID
MALLOC = $(LIBDIR)/malloc.o
LFLAGS = $(PROFILE)
LDFLAGS = -i $(PROFILE)
LSRC = declar.c expression.c program.c statement.c tokenfile.c
LOBJ = declar.o expression.o program.o statement.o tokenfile.o
CSRC = LLlex.c LLmessage.c body.c chk_expr.c code.c\
@ -32,13 +41,12 @@ COBJ = LLlex.o LLmessage.o body.o casestat.o char.o chk_expr.o code.o\
OBJ = Lpars.o $(COBJ) $(LOBJ)
# Keep the next entries up to date!
GENCFILES= Lpars.c declar.c expression.c program.c statement.c\
tokenfile.c symbol2str.c casestat.c tmpvar.c char.c next.c
SRC = Lpars.c $(CSRC) $(GENCFILES)
GENCFILES= $(LSRC) Lpars.c symbol2str.c casestat.c tmpvar.c char.c next.c
SRC = $(CSRC) $(GENCFILES)
GENGFILES= tokenfile.g
GENHFILES= Lpars.h debugcst.h density.h errout.h idfsize.h inputtype.h\
numsize.h strsize.h def.h type.h desig.h scope.h node.h\
target_sizes.h
target_sizes.h nocross.h
HFILES= LLlex.h chk_expr.h class.h const.h debug.h def.h desig.h\
f_info.h idf.h input.h main.h misc.h node.h required.h scope.h\
tokenname.h type.h $(GENHFILES)
@ -49,27 +57,58 @@ NEXTFILES = def.H desig.H node.H scope.H type.H casestat.C tmpvar.C
#EXCLEXCLEXCLEXCL
all: Cfiles
make $(CURRDIR)/main
sh -c 'if $(CC) nmclash.c > /dev/null 2>&1 ; then make "EMHOME="$(EMHOME) $(CURRDIR)main ; else EMHOME=$(EMHOME); export EMHOME; sh Resolve main ; fi'
@rm -f nmclash.o a.out
Omain: Cfiles
rm -f *.o
sh -c 'if $(CC) nmclash.c > /dev/null 2>&1 ; then make "EMHOME="$(EMHOME) "COPTIONS="-DPEEPHOLE $(CURRDIR)omain ; else EMHOME=$(EMHOME); export EMHOME; ./Resolve omain ; fi'
@rm -f nmclash.o a.out
mv *.o PEEPHOLE
CEmain: Cfiles
rm -f *.o
sh -c 'if $(CC) nmclash.c > /dev/null 2>&1 ; then make "EMHOME="$(EMHOME) "COPTIONS="-DCODE_EXPANDER $(CURRDIR)cemain ; else EMHOME=$(EMHOME); export EMHOME; ./Resolve cemain ; fi'
@rm -f nmclash.o a.out
mv *.o CODE_EXPANDER
install: all
cp $(CURRDIR)main $(EMHOME)/lib/em_pc
cmp: all
-cmp $(CURRDIR)main $(EMHOME)/lib/em_pc
opr:
make pr | opr
pr:
@pr Makefile Resolve Parameters $(GFILES) *.H $(HFILES) *.C $(CSRC)
clean:
rm -f *.o main $(GENFILES) hfiles Cfiles LLfiles
rm -f $(OBJ) $(CURRDIR)main $(GENFILES) hfiles Cfiles LLfiles clashes \
LL.output
(cd .. ; rm -rf Xsrc)
lint: Cfiles
sh -c 'if $(CC) nmclash.c > /dev/null 2>&1 ; then make "EMHOME="$(EMHOME) Xlint ; else EMHOME=$(EMHOME); export EMHOME; sh Resolve Xlint ; fi'
@rm -f nmclash.o a.out
longnames: $(SRC) $(HFILES)
sh -c 'if test -f longnames ; then $(PRID) -l7 longnames $? > Xlongnames ; mv Xlongnames longnames ; else $(PRID) -l7 $? > longnames ; fi'
# entry points not to be used directly
Cfiles: hfiles LLfiles $(GENCFILES) $(GENHFILES) Makefile
Cfiles: hfiles LLfiles $(GENCFILES) $(GENHFILES) Makefile
echo $(SRC) $(HFILES) > Cfiles
LLfiles: $(GFILES)
$(LLGEN) $(LLGENOPTIONS) $(GFILES)
@touch LLfiles
hfiles: Parameters make.hfiles
hfiles: Parameters make.hfiles
make.hfiles Parameters
touch hfiles
lint: Cfiles
lint $(INCLUDES) $(LINTFLAGS) $(SRC)
tokenfile.g: tokenname.c make.tokfile
make.tokfile < tokenname.c > tokenfile.g
@ -95,10 +134,10 @@ tmpvar.c: make.allocd
next.c: $(NEXTFILES) ./make.next
./make.next $(NEXTFILES) > next.c
char.c: char.tab
char.c: char.tab
$(EMHOME)/bin/tabgen -fchar.tab > char.c
depend:
depend: Cfiles
sed '/^#AUTOAUTO/,$$d' Makefile > Makefile.new
echo '#AUTOAUTOAUTOAUTOAUTOAUTOAUTOAUTO' >> Makefile.new
$(MKDEP) $(SRC) |\
@ -110,19 +149,37 @@ print: $(CSRC) $(GFILES) $(HFILES) # print recently changed files
pr -t $? | rpr $(PRINTER)
@touch print
xref:
xref:
ctags -x $(CSRC) $(HFILES) | sed "s/).*/)/">Xref
#INCLINCLINCLINCL
$(CURRDIR)/main: $(OBJ)
-mv main main.old
$(CC) $(LFLAGS) $(OBJ) $(LIBDIR)/libem_mes.a $(OBJECTCODE) $(LIBDIR)/libinput.a $(LIBDIR)/liballoc.a $(MALLOC) $(LIBDIR)/libassert.a $(LIBDIR)/libprint.a $(LIBDIR)/libstring.a $(LIBDIR)/libsystem.a -o $(CURRDIR)/main
size $(CURRDIR)/main.old
size $(CURRDIR)/main
Xlint:
$(LINT) $(INCLUDES) $(LINTFLAGS) $(SRC) \
$(LIBDIR)/llib-lem_mes.ln \
$(LIBDIR)/llib-lemk.ln \
$(LIBDIR)/llib-linput.ln \
$(LIBDIR)/llib-lassert.ln \
$(LIBDIR)/llib-lalloc.ln \
$(LIBDIR)/llib-lprint.ln \
$(LIBDIR)/llib-lstring.ln \
$(LIBDIR)/llib-lsystem.ln
$(CURRDIR)main: $(OBJ) $(CURRDIR)Makefile
-mv $(CURRDIR)main $(CURRDIR)main.old
$(CC) $(LDFLAGS) $(OBJ) $(OLIBS) -o $(CURRDIR)main
size $(CURRDIR)main.old
size $(CURRDIR)main
$(CURRDIR)omain: $(OBJ) #$(CURRDIR)Makefile
# #$(CC) $(LDFLAGS) $(OBJ) $(OLIBS) -o $(CURRDIR)omain
# #size $(CURRDIR)omain
$(CURRDIR)cemain: $(OBJ) #$(CURRDIR)Makefile
# #$(CC) $(LDFLAGS) $(OBJ) $(OLIBS) -o $(CURRDIR)cemain
# # #size $(CURRDIR)cemain
#AUTOAUTOAUTOAUTOAUTOAUTOAUTOAUTO
Lpars.o: Lpars.h
LLlex.o: LLlex.h
LLlex.o: Lpars.h
LLlex.o: class.h
@ -135,12 +192,16 @@ LLlex.o: idfsize.h
LLlex.o: input.h
LLlex.o: inputtype.h
LLlex.o: main.h
LLlex.o: nocross.h
LLlex.o: numsize.h
LLlex.o: strsize.h
LLlex.o: target_sizes.h
LLlex.o: type.h
LLmessage.o: LLlex.h
LLmessage.o: Lpars.h
LLmessage.o: idf.h
LLmessage.o: nocross.h
LLmessage.o: target_sizes.h
LLmessage.o: type.h
body.o: LLlex.h
body.o: chk_expr.h
@ -150,19 +211,12 @@ body.o: def.h
body.o: desig.h
body.o: idf.h
body.o: main.h
body.o: misc.h
body.o: nocross.h
body.o: node.h
body.o: scope.h
body.o: target_sizes.h
body.o: type.h
casestat.o: LLlex.h
casestat.o: Lpars.h
casestat.o: chk_expr.h
casestat.o: debug.h
casestat.o: debugcst.h
casestat.o: density.h
casestat.o: main.h
casestat.o: node.h
casestat.o: type.h
char.o: class.h
chk_expr.o: LLlex.h
chk_expr.o: Lpars.h
chk_expr.o: chk_expr.h
@ -173,9 +227,11 @@ chk_expr.o: def.h
chk_expr.o: idf.h
chk_expr.o: main.h
chk_expr.o: misc.h
chk_expr.o: nocross.h
chk_expr.o: node.h
chk_expr.o: required.h
chk_expr.o: scope.h
chk_expr.o: target_sizes.h
chk_expr.o: type.h
code.o: LLlex.h
code.o: Lpars.h
@ -184,15 +240,19 @@ code.o: debugcst.h
code.o: def.h
code.o: desig.h
code.o: main.h
code.o: misc.h
code.o: nocross.h
code.o: node.h
code.o: required.h
code.o: scope.h
code.o: target_sizes.h
code.o: type.h
cstoper.o: LLlex.h
cstoper.o: Lpars.h
cstoper.o: const.h
cstoper.o: debug.h
cstoper.o: debugcst.h
cstoper.o: nocross.h
cstoper.o: node.h
cstoper.o: required.h
cstoper.o: target_sizes.h
@ -204,24 +264,31 @@ def.o: def.h
def.o: idf.h
def.o: main.h
def.o: misc.h
def.o: nocross.h
def.o: node.h
def.o: scope.h
def.o: target_sizes.h
def.o: type.h
desig.o: LLlex.h
desig.o: debug.h
desig.o: debugcst.h
desig.o: def.h
desig.o: desig.h
desig.o: idf.h
desig.o: main.h
desig.o: nocross.h
desig.o: node.h
desig.o: scope.h
desig.o: target_sizes.h
desig.o: type.h
enter.o: LLlex.h
enter.o: def.h
enter.o: idf.h
enter.o: main.h
enter.o: nocross.h
enter.o: node.h
enter.o: scope.h
enter.o: target_sizes.h
enter.o: type.h
error.o: LLlex.h
error.o: debug.h
@ -241,18 +308,23 @@ label.o: LLlex.h
label.o: def.h
label.o: idf.h
label.o: main.h
label.o: nocross.h
label.o: node.h
label.o: scope.h
label.o: target_sizes.h
label.o: type.h
lookup.o: LLlex.h
lookup.o: def.h
lookup.o: idf.h
lookup.o: misc.h
lookup.o: nocross.h
lookup.o: node.h
lookup.o: scope.h
lookup.o: target_sizes.h
lookup.o: type.h
main.o: LLlex.h
main.o: Lpars.h
main.o: class.h
main.o: const.h
main.o: debug.h
main.o: debugcst.h
@ -262,8 +334,10 @@ main.o: idf.h
main.o: input.h
main.o: inputtype.h
main.o: main.h
main.o: nocross.h
main.o: node.h
main.o: required.h
main.o: target_sizes.h
main.o: tokenname.h
main.o: type.h
misc.o: LLlex.h
@ -272,25 +346,31 @@ misc.o: idf.h
misc.o: main.h
misc.o: misc.h
misc.o: node.h
next.o: debug.h
next.o: debugcst.h
node.o: LLlex.h
node.o: debug.h
node.o: debugcst.h
node.o: nocross.h
node.o: node.h
node.o: target_sizes.h
node.o: type.h
options.o: class.h
options.o: const.h
options.o: idfsize.h
options.o: main.h
options.o: nocross.h
options.o: target_sizes.h
options.o: type.h
readwrite.o: LLlex.h
readwrite.o: debug.h
readwrite.o: debugcst.h
readwrite.o: def.h
readwrite.o: idf.h
readwrite.o: main.h
readwrite.o: misc.h
readwrite.o: nocross.h
readwrite.o: node.h
readwrite.o: scope.h
readwrite.o: target_sizes.h
readwrite.o: type.h
scope.o: LLlex.h
scope.o: debug.h
@ -298,16 +378,12 @@ scope.o: debugcst.h
scope.o: def.h
scope.o: idf.h
scope.o: misc.h
scope.o: nocross.h
scope.o: node.h
scope.o: scope.h
scope.o: target_sizes.h
scope.o: type.h
symbol2str.o: Lpars.h
tmpvar.o: debug.h
tmpvar.o: debugcst.h
tmpvar.o: def.h
tmpvar.o: main.h
tmpvar.o: scope.h
tmpvar.o: type.h
tokenname.o: Lpars.h
tokenname.o: idf.h
tokenname.o: tokenname.h
@ -318,6 +394,7 @@ type.o: debugcst.h
type.o: def.h
type.o: idf.h
type.o: main.h
type.o: nocross.h
type.o: node.h
type.o: scope.h
type.o: target_sizes.h
@ -326,24 +403,32 @@ typequiv.o: LLlex.h
typequiv.o: debug.h
typequiv.o: debugcst.h
typequiv.o: def.h
typequiv.o: nocross.h
typequiv.o: node.h
typequiv.o: target_sizes.h
typequiv.o: type.h
progs.o: LLlex.h
progs.o: debug.h
progs.o: debugcst.h
progs.o: def.h
progs.o: main.h
progs.o: nocross.h
progs.o: scope.h
progs.o: target_sizes.h
progs.o: type.h
declar.o: LLlex.h
declar.o: Lpars.h
declar.o: chk_expr.h
declar.o: debug.h
declar.o: debugcst.h
declar.o: def.h
declar.o: idf.h
declar.o: main.h
declar.o: misc.h
declar.o: nocross.h
declar.o: node.h
declar.o: scope.h
declar.o: target_sizes.h
declar.o: type.h
expression.o: LLlex.h
expression.o: Lpars.h
@ -351,13 +436,19 @@ expression.o: chk_expr.h
expression.o: debug.h
expression.o: debugcst.h
expression.o: def.h
expression.o: idf.h
expression.o: main.h
expression.o: misc.h
expression.o: nocross.h
expression.o: node.h
expression.o: scope.h
expression.o: target_sizes.h
expression.o: type.h
program.o: LLlex.h
program.o: Lpars.h
program.o: def.h
program.o: f_info.h
program.o: idf.h
program.o: main.h
program.o: node.h
program.o: scope.h
@ -366,9 +457,37 @@ statement.o: Lpars.h
statement.o: chk_expr.h
statement.o: def.h
statement.o: desig.h
statement.o: f_info.h
statement.o: idf.h
statement.o: main.h
statement.o: misc.h
statement.o: nocross.h
statement.o: node.h
statement.o: scope.h
statement.o: target_sizes.h
statement.o: type.h
tokenfile.o: Lpars.h
Lpars.o: Lpars.h
symbol2str.o: Lpars.h
casestat.o: LLlex.h
casestat.o: Lpars.h
casestat.o: chk_expr.h
casestat.o: debug.h
casestat.o: debugcst.h
casestat.o: density.h
casestat.o: main.h
casestat.o: nocross.h
casestat.o: node.h
casestat.o: target_sizes.h
casestat.o: type.h
tmpvar.o: debug.h
tmpvar.o: debugcst.h
tmpvar.o: def.h
tmpvar.o: main.h
tmpvar.o: nocross.h
tmpvar.o: scope.h
tmpvar.o: target_sizes.h
tmpvar.o: type.h
char.o: class.h
next.o: debug.h
next.o: debugcst.h

18
lang/pc/comp/Parameters
View file

@ -1,5 +1,5 @@
!File: debugcst.h
#define DEBUG 1 /* perform various self-tests */
#undef DEBUG 1 /* perform various self-tests */
!File: density.h
@ -39,13 +39,19 @@
#define SZ_CHAR (arith)1
#define SZ_WORD (arith)4
#define SZ_INT (arith)4
#define SZ_LONG (arith)4
#define SZ_POINTER (arith)4
#define SZ_REAL (arith)8
/* target machine alignment requirements */
#define AL_CHAR 1
#define AL_WORD (int)SZ_WORD
#define AL_INT (int)SZ_WORD
#define AL_POINTER (int)SZ_WORD
#define AL_REAL (int)SZ_WORD
#define AL_STRUCT 1
#define AL_WORD ((int)SZ_WORD)
#define AL_INT ((int)SZ_WORD)
#define AL_LONG ((int)SZ_WORD)
#define AL_POINTER ((int)SZ_WORD)
#define AL_REAL ((int)SZ_WORD)
#define AL_STRUCT ((int)SZ_WORD)
!File: nocross.h
#undef NOCROSS 1 /* define when cross compiler not needed */

60
lang/pc/comp/Resolve Executable file
View file

@ -0,0 +1,60 @@
: create a directory Xsrc with name clashes resolved
: and run make in that directory
case $# in
1)
;;
*) echo "$0: one argument expected" 1>&2
exit 1
;;
esac
currdir=`pwd`
case $1 in
main) target=$currdir/$1
;;
omain) target=$currdir/$1
options=-DPEEPHOLE
;;
cemain) target=$currdir/$1
options=-DCODE_EXPANDER
;;
Xlint) target=$1
;;
*) echo "$0: $1: Illegal argument" 1>&2
exit 1
;;
esac
if test -d ../Xsrc
then
:
else mkdir ../Xsrc
fi
make EMHOME=$EMHOME longnames
: remove code generating routines from the clashes list as they are defines.
: code generating routine names start with C_
sed '/^C_/d' < longnames > tmp$$
cclash -c -l7 tmp$$ > ../Xsrc/Xclashes
rm -f tmp$$
PW=`pwd`
cd ../Xsrc
if cmp -s Xclashes clashes
then
:
else
mv Xclashes clashes
fi
rm -f Makefile
ed - $PW/Makefile <<'EOF'
/^#EXCLEXCL/,/^#INCLINCL/d
w Makefile
q
EOF
for i in `cat $PW/Cfiles`
do
cat >> Makefile <<EOF
$i: clashes $PW/$i
\$(CID) -Fclashes < $PW/$i > $i
EOF
done
make EMHOME=$EMHOME CURRDIR=$currdir/ COPTIONS=$options $target

1
lang/pc/comp/Version.c Normal file
View file

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

156
lang/pc/comp/body.c
View file

@ -10,28 +10,100 @@
#include "desig.h"
#include "idf.h"
#include "main.h"
#include "misc.h"
#include "node.h"
#include "scope.h"
#include "type.h"
MarkDef(nd, flags, on)
register struct node *nd;
unsigned short flags;
{
while( nd && nd->nd_class != Def ) {
if( (nd->nd_class == Arrsel) ||
(nd->nd_class == LinkDef) )
nd = nd->nd_left;
else if( nd->nd_class == Arrow )
nd = nd->nd_right;
else break;
}
if( nd && (nd->nd_class == Def) ) {
if( (flags & D_SET) && on &&
BlockScope != nd->nd_def->df_scope )
nd->nd_def->df_flags |= D_SETINHIGH;
if( on ) {
if( (flags & D_SET) &&
(nd->nd_def->df_flags & D_WITH) )
node_warning(nd,
"variable \"%s\" already referenced in with",
nd->nd_def->df_idf->id_text);
nd->nd_def->df_flags |= flags;
}
else
nd->nd_def->df_flags &= ~flags;
}
}
AssertStat(expp, line)
register struct node *expp;
unsigned short line;
{
struct desig dsr;
if( !ChkExpression(expp) )
return;
if( expp->nd_type != bool_type ) {
node_error(expp, "type of assertion should be boolean");
return;
}
if( options['a'] && !err_occurred ) {
dsr = InitDesig;
CodeExpr(expp, &dsr, NO_LABEL);
C_loc((arith)line);
C_cal("_ass");
}
}
AssignStat(left, right)
register struct node *left, *right;
{
register struct type *ltp, *rtp;
int retval = 0;
struct desig dsr;
if( !(ChkExpression(right) && ChkLhs(left)) )
return;
retval = ChkExpression(right);
MarkUsed(right);
retval &= ChkLhs(left);
ltp = left->nd_type;
rtp = right->nd_type;
MarkDef(left, (unsigned short)D_SET, 1);
if( !retval ) return;
if( ltp == int_type && rtp == long_type ) {
right = MkNode(IntReduc, NULLNODE, right, &dot);
right->nd_type = int_type;
}
else if( ltp == long_type && rtp == int_type ) {
right = MkNode(IntCoerc, NULLNODE, right, &dot);
right->nd_type = long_type;
}
if( !TstAssCompat(ltp, rtp) ) {
node_error(left, "type incompatibility in assignment");
return;
}
if( left->nd_class == Def &&
(left->nd_def->df_flags & D_INLOOP) ) {
node_error(left, "assignment to a control variable");
return;
}
if( rtp == emptyset_type )
right->nd_type = ltp;
@ -45,7 +117,7 @@ AssignStat(left, right)
CodeValue(&dsr, rtp);
if( ltp == real_type && BaseType(rtp) == int_type )
Int2Real();
Int2Real(rtp->tp_size);
RangeCheck(ltp, rtp);
}
@ -71,11 +143,15 @@ ChkForStat(nd)
register struct node *nd;
{
register struct def *df;
int retvar = 0;
retvar = ChkVariable(nd);
retvar &= ChkExpression(nd->nd_left);
MarkUsed(nd->nd_left);
retvar &= ChkExpression(nd->nd_right);
MarkUsed(nd->nd_right);
if( !retvar ) return;
if( !(ChkVariable(nd) && ChkExpression(nd->nd_left) &&
ChkExpression(nd->nd_right)) )
return;
assert(nd->nd_class == Def);
df = nd->nd_def;
@ -88,12 +164,15 @@ ChkForStat(nd)
assert(df->df_kind == D_VARIABLE);
if( df->df_scope != GlobalScope && df->var_off >= 0 ) {
node_error(nd,"for loop: control variable can't be a parameter");
return;
node_error(nd,
"for loop: control variable can't be a parameter");
MarkDef(nd,(unsigned short)(D_LOOPVAR | D_SET | D_USED), 1);
return;
}
if( !(df->df_type->tp_fund & T_ORDINAL) ) {
node_error(nd, "for loop: control variable must be ordinal");
MarkDef(nd,(unsigned short)(D_LOOPVAR | D_SET | D_USED), 1);
return;
}
@ -105,11 +184,37 @@ ChkForStat(nd)
node_error(nd,
"for loop: final value incompatible with control variable");
df->df_flags |= D_LOOPVAR;
if( df->df_type == long_type )
node_error(nd, "for loop: control variable can not be a long");
if( df->df_flags & D_INLOOP )
node_error(nd, "for loop: control variable already used");
if( df->df_flags & D_SETINHIGH )
node_error(nd,
"for loop: control variable already set in block");
MarkDef(nd,(unsigned short) (D_LOOPVAR | D_INLOOP | D_SET | D_USED), 1);
return;
}
EndForStat(nd)
register struct node *nd;
{
register struct def *df;
df = nd->nd_def;
if( (df->df_scope != BlockScope) ||
(df->df_scope != GlobalScope && df->var_off >= 0) ||
!(df->df_type->tp_fund & T_ORDINAL)
)
return;
MarkDef(nd,(unsigned short) (D_INLOOP | D_SET), 0);
}
arith
CodeInitFor(nd, priority)
register struct node *nd;
@ -123,8 +228,10 @@ CodeInitFor(nd, priority)
CodePExpr(nd);
if( nd->nd_class != Value ) {
tmp = NewInt(priority);
C_dup(int_size);
C_stl(tmp);
return tmp;
}
return (arith) 0;
@ -191,6 +298,19 @@ WithStat(nd)
return;
}
MarkDef(nd, (unsigned short)(D_USED | D_SET | D_WITH), 1);
/*
if( (nd->nd_class == Arrow) &&
(nd->nd_right->nd_type->tp_fund & T_FILE) ) {
nd->nd_right->nd_def->df_flags |= D_WITH;
}
*/
scl = new_scopelist();
scl->sc_scope = nd->nd_type->rec_scope;
scl->next = CurrVis;
CurrVis = scl;
if( err_occurred ) return;
/* Generate code */
@ -200,7 +320,7 @@ WithStat(nd)
wds = new_withdesig();
wds->w_next = WithDesigs;
WithDesigs = wds;
wds->w_scope = nd->nd_type->rec_scope;
wds->w_scope = scl->sc_scope;
/* create a desig structure for the temporary */
ds.dsg_kind = DSG_FIXED;
@ -213,11 +333,6 @@ WithStat(nd)
/* record is indirectly available */
ds.dsg_kind = DSG_PFIXED;
wds->w_desig = ds;
scl = new_scopelist();
scl->sc_scope = wds->w_scope;
scl->next = CurrVis;
CurrVis = scl;
}
EndWith(saved_scl, nd)
@ -227,6 +342,7 @@ EndWith(saved_scl, nd)
/* restore scope, and release structures */
struct scopelist *scl;
struct withdesig *wds;
struct node *nd1;
while( CurrVis != saved_scl ) {
@ -235,6 +351,9 @@ EndWith(saved_scl, nd)
CurrVis = CurrVis->next;
free_scopelist(scl);
if( WithDesigs == 0 )
continue; /* we didn't generate any code */
/* release temporary */
FreePtr(WithDesigs->w_desig.dsg_offset);
@ -243,5 +362,10 @@ EndWith(saved_scl, nd)
WithDesigs = WithDesigs->w_next;
free_withdesig(wds);
}
for( nd1 = nd; nd1 != NULLNODE; nd1 = nd1->nd_right ) {
MarkDef(nd1->nd_left, (unsigned short)(D_WITH), 0);
}
FreeNode(nd);
}

1
lang/pc/comp/casestat.C
View file

@ -49,6 +49,7 @@ CaseExpr(nd)
register struct node *expp = nd->nd_left;
if( !ChkExpression(expp) ) return;
MarkUsed(expp);
if( !(expp->nd_type->tp_fund & T_ORDINAL) ) {
node_error(expp, "case-expression must be ordinal");

272
lang/pc/comp/chk_expr.c
View file

@ -33,11 +33,51 @@ Xerror(nd, mess)
if( nd->nd_class == Def && nd->nd_def ) {
if( nd->nd_def->df_kind != D_ERROR )
node_error(nd,"\"%s\": %s",
nd->nd_def->df_idf->id_text, mess);
nd->nd_def->df_idf->id_text, mess);
}
else node_error(nd, "%s", mess);
}
struct node *
ZeroParam()
{
register struct node *nd;
nd = MkLeaf(Value, &dot);
nd->nd_type = int_type;
nd->nd_symb = INTEGER;
nd->nd_INT = (arith) 0;
nd = MkNode(Link, nd, NULLNODE, &dot);
nd->nd_symb = ',';
return nd;
}
MarkUsed(nd)
register struct node *nd;
{
while( nd && nd->nd_class != Def ) {
if( (nd->nd_class == Arrsel) || (nd->nd_class == LinkDef) )
nd = nd->nd_left;
else if( nd->nd_class == Arrow)
nd = nd->nd_right;
else break;
}
if( nd && nd->nd_class == Def ) {
if( !((nd->nd_def->df_flags & D_VARPAR) ||
(nd->nd_def->df_kind == D_FIELD)) ) {
if( !(nd->nd_def->df_flags & D_SET) &&
(nd->nd_def->df_scope == CurrentScope) )
if( !is_anon_idf(nd->nd_def->df_idf) ) {
warning("\"%s\" used before set",
nd->nd_def->df_idf->id_text);
}
nd->nd_def->df_flags |= (D_USED | D_SET);
}
}
}
STATIC int
ChkConstant(expp)
register struct node *expp;
@ -89,6 +129,7 @@ ChkLhs(expp)
if( !ChkVarAccess(expp) ) return 0;
class = expp->nd_class;
/* a constant is replaced by it's value in ChkLinkOrName, check here !,
* the remaining classes are checked by ChkVarAccess
*/
@ -160,7 +201,7 @@ ChkLinkOrName(expp)
return 0;
}
if( !(df = lookup(expp->nd_IDF, left->nd_type->rec_scope)) ) {
if( !(df = lookup(expp->nd_IDF, left->nd_type->rec_scope, D_INUSE)) ) {
id_not_declared(expp);
return 0;
}
@ -176,6 +217,7 @@ ChkLinkOrName(expp)
df = expp->nd_def;
if( df->df_kind & (D_ENUM | D_CONST) ) {
MarkUsed(expp);
/* Replace an enum-literal or a CONST identifier by its value.
*/
if( df->df_kind == D_ENUM ) {
@ -201,8 +243,9 @@ ChkExLinkOrName(expp)
if( !ChkLinkOrName(expp) ) return 0;
if( expp->nd_class != Def ) return 1;
if( !(expp->nd_def->df_kind & D_VALUE) )
if( !(expp->nd_def->df_kind & D_VALUE) ) {
Xerror(expp, "value expected");
}
return 1;
}
@ -218,6 +261,8 @@ ChkUnOper(expp)
if( !ChkExpression(right) ) return 0;
MarkUsed(right);
expp->nd_type = tpr = BaseType(right->nd_type);
switch( expp->nd_symb ) {
@ -230,7 +275,7 @@ ChkUnOper(expp)
break;
case '-':
if( tpr->tp_fund == T_INTEGER ) {
if( tpr->tp_fund == T_INTEGER || tpr->tp_fund == T_LONG ) {
if( right->nd_class == Value )
cstunary(expp);
return 1;
@ -256,6 +301,9 @@ ChkUnOper(expp)
break;
case '(':
/* Delete the brackets */
*expp = *right;
free_node(right);
return 1;
default:
@ -287,10 +335,13 @@ ResultOfOperation(operator, tpl, tpr)
case '*' :
if( tpl == real_type || tpr == real_type )
return real_type;
if( tpl == long_type || tpr == long_type)
return long_type;
return tpl;
case '/' :
return real_type;
}
if (tpr == long_type && tpl == int_type) return tpr;
return tpl;
}
@ -310,22 +361,23 @@ AllowedTypes(operator)
return T_NUMERIC;
case DIV :
case MOD :
return T_INTEGER;
return T_INTEGER | T_LONG;
case OR :
case AND :
return T_ENUMERATION;
case '=' :
case NOTEQUAL :
return T_ENUMERATION | T_CHAR | T_NUMERIC |
T_SET | T_POINTER | T_STRING;
T_SET | T_POINTER | T_STRINGCONST |
T_STRING;
case LESSEQUAL :
case GREATEREQUAL:
return T_ENUMERATION | T_CHAR | T_NUMERIC |
T_SET | T_STRING;
T_SET | T_STRINGCONST;
case '<' :
case '>' :
return T_ENUMERATION | T_CHAR | T_NUMERIC |
T_STRING;
T_STRINGCONST;
default :
crash("(AllowedTypes)");
}
@ -353,6 +405,9 @@ ChkBinOper(expp)
retval = ChkExpression(left) & ChkExpression(right);
MarkUsed(left);
MarkUsed(right);
tpl = BaseType(left->nd_type);
tpr = BaseType(right->nd_type);
@ -362,7 +417,7 @@ ChkBinOper(expp)
of the operands.
There are some needles and pins:
- Boolean operators are only allowed on boolean operands, but the
"allowed-mask" of "AllowedTyped" can only indicate an enumeration
"allowed-mask" of "AllowedTypes" can only indicate an enumeration
type.
- The IN-operator has as right-hand-side operand a set.
- Strings and packed arrays can be equivalent.
@ -393,7 +448,7 @@ ChkBinOper(expp)
arith ub;
extern arith IsString();
if( allowed & T_STRING && (ub = IsString(tpl)) )
if( allowed & T_STRINGCONST && (ub = IsString(tpl)) ) {
if( ub == IsString(tpr) )
return 1;
else {
@ -401,6 +456,10 @@ ChkBinOper(expp)
symbol2str(expp->nd_symb));
return 0;
}
}
else if( allowed & T_STRING && tpl->tp_fund == T_STRING )
return 1;
node_error(expp, "\"%s\": illegal operand type(s)",
symbol2str(expp->nd_symb));
return 0;
@ -413,17 +472,28 @@ ChkBinOper(expp)
}
if( allowed & T_NUMERIC ) {
if( tpl == int_type &&
if( (tpl == int_type || tpl == long_type) &&
(tpr == real_type || expp->nd_symb == '/') ) {
expp->nd_left =
MkNode(Cast, NULLNODE, expp->nd_left, &dot);
expp->nd_left->nd_type = tpl = real_type;
}
if( tpl == real_type && tpr == int_type ) {
if( tpl == real_type &&
(tpr == int_type || tpr == long_type)) {
expp->nd_right =
MkNode(Cast, NULLNODE, expp->nd_right, &dot);
expp->nd_right->nd_type = tpr = real_type;
}
if( tpl == int_type && tpr == long_type) {
expp->nd_left =
MkNode(IntCoerc, NULLNODE, expp->nd_left, &dot);
expp->nd_left->nd_type = long_type;
}
else if( tpl == long_type && tpr == int_type) {
expp->nd_right =
MkNode(IntCoerc, NULLNODE, expp->nd_right, &dot);
expp->nd_right->nd_type = long_type;
}
}
/* Operands must be compatible */
@ -499,6 +569,7 @@ ChkElement(expp, tp, set, cnt)
/* Here, a single element is checked
*/
if( !ChkExpression(expp) ) return 0;
MarkUsed(expp);
if( *tp == emptyset_type ) {
/* first element in set determines the type of the set */
@ -590,7 +661,7 @@ ChkSet(expp)
/* after all the work we've done, the set turned out
out to be empty!
*/
free(set);
free((char *) set);
set = (arith *) 0;
}
expp->nd_set = set;
@ -601,6 +672,49 @@ ChkSet(expp)
return 1;
}
char *
ChkAllowedVar(nd, reading) /* reading indicates read or readln */
register struct node *nd;
{
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 */
case LinkDef:
assert(nd->nd_def->df_kind == D_FIELD);
if( nd->nd_def->fld_flags & F_PACKED )
message = "field of packed record";
else if( nd->nd_def->fld_flags & F_SELECTOR )
message = "variant selector";
break;
case Arrsel:
if( IsPacked(nd->nd_left->nd_type) )
if( !reading ) message = "component of packed array";
break;
case Arrow:
if( nd->nd_right->nd_type->tp_fund == T_FILE )
message = "filebuffer variable";
break;
default:
crash("(ChkAllowedVar)");
/*NOTREACHED*/
}
MarkDef(nd, D_SET, 1);
return message;
}
int
ChkVarPar(nd, name)
register struct node *nd, *name;
{
@ -610,43 +724,16 @@ ChkVarPar(nd, name)
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];
static char err_mes[80];
char *message = (char *) 0;
extern char *sprint();
if( !ChkVariable(nd) ) return 0;
switch( nd->nd_class ) {
case Def:
if( nd->nd_def->df_kind != D_FIELD ) break;
/* FALL THROUGH */
message = ChkAllowedVar(nd, 0);
case LinkDef:
assert(nd->nd_def->df_kind == D_FIELD);
if( nd->nd_def->fld_flags & F_PACKED )
message = "field of packed record %s";
else if( nd->nd_def->fld_flags & F_SELECTOR )
message = "variant selector %s";
break;
case Arrsel:
if( IsPacked(nd->nd_left->nd_type) )
message = "component of packed array %s";
break;
case Arrow:
if( nd->nd_right->nd_type->tp_fund == T_FILE )
message = "filebuffer variable %s";
break;
default:
crash("(ChkVarPar)");
/*NOTREACHED*/
}
if( message ) {
sprint(err_mes, message, var_mes);
sprint(err_mes, "%s can't be a variable parameter", message);
Xerror(name, err_mes);
return 0;
}
@ -684,13 +771,29 @@ getarg(argp, bases, varaccess, name, paramtp)
Xerror(name, "illegal proc/func parameter");
return 0;
}
else if( ChkLinkOrName(left->nd_left) )
else if( ChkLinkOrName(left->nd_left) ) {
left->nd_type = left->nd_left->nd_type;
MarkUsed(left->nd_left);
}
else return 0;
}
else if( varaccess ? !ChkVarPar(left, name) : !ChkExpression(left) )
return 0;
else if( varaccess ) {
if( !ChkVarPar(left, name) )
return 0;
}
else if( !ChkExpression(left) ) {
MarkUsed(left);
return 0;
}
if( !varaccess ) MarkUsed(left);
if( !varaccess && bases == T_INTEGER &&
BaseType(left->nd_type)->tp_fund == T_LONG) {
arg->nd_left = MkNode(IntReduc, NULLNODE, left, &dot);
arg->nd_left->nd_type = int_type;
left = arg->nd_left;
}
if( bases && !(BaseType(left->nd_type)->tp_fund & bases) ) {
Xerror(name, "unexpected parameter type");
@ -709,7 +812,7 @@ ChkProcCall(expp)
register struct node *left;
struct node *name;
register struct paramlist *param;
char ebuf[64];
char ebuf[80];
int retval = 1;
int cnt = 0;
int new_par_section;
@ -731,20 +834,39 @@ ChkProcCall(expp)
/* Check parameter list
*/
for( param = ParamList(left->nd_type); param; param = param->next ) {
if( !(left = getarg(&expp, 0, IsVarParam(param), name,
if( !(left = getarg(&expp, 0, (int) IsVarParam(param), name,
TypeOfParam(param))) )
return 0;
cnt++;
new_par_section = lasttp != TypeOfParam(param);
if( !TstParCompat(TypeOfParam(param), left->nd_type,
IsVarParam(param), left, new_par_section) ) {
(int) IsVarParam(param), left, new_par_section) ) {
sprint(ebuf, "type incompatibility in parameter %d",
cnt);
Xerror(name, ebuf);
retval = 0;
}
/* Convert between integers and longs.
*/
if( !IsVarParam(param) && options['d'] ) {
if( left->nd_type->tp_fund == T_INTEGER &&
TypeOfParam(param)->tp_fund == T_LONG) {
expp->nd_left =
MkNode(IntCoerc, NULLNODE, left, &dot);
expp->nd_left->nd_type = long_type;
left = expp->nd_left;
}
else if( left->nd_type->tp_fund == T_LONG &&
TypeOfParam(param)->tp_fund == T_INTEGER) {
expp->nd_left =
MkNode(IntReduc, NULLNODE, left, &dot);
expp->nd_left->nd_type = int_type;
left = expp->nd_left;
}
}
if( left->nd_type == emptyset_type )
/* type of emptyset determined by the context */
left->nd_type = TypeOfParam(param);
@ -780,6 +902,7 @@ ChkCall(expp)
if( ChkLinkOrName(left) ) {
MarkUsed(left);
if( IsProcCall(left) || left->nd_type == error_type ) {
/* A call.
It may also be a call to a standard procedure
@ -862,7 +985,8 @@ ChkStandard(expp,left)
if( !(left = getarg(&arg, T_NUMERIC, 0, name, NULLTYPE)) )
return 0;
expp->nd_type = real_type;
if( BaseType(left->nd_type)->tp_fund == T_INTEGER ) {
if( BaseType(left->nd_type)->tp_fund == T_INTEGER ||
BaseType(left->nd_type)->tp_fund == T_LONG) {
arg->nd_left = MkNode(Cast,NULLNODE, arg->nd_left,&dot);
arg->nd_left->nd_type = real_type;
}
@ -878,6 +1002,10 @@ ChkStandard(expp,left)
case R_ORD:
if( !(left = getarg(&arg, T_ORDINAL, 0, name, NULLTYPE)) )
return 0;
if( BaseType(left->nd_type)->tp_fund == T_LONG ) {
arg->nd_left = MkNode(IntReduc, NULLNODE, arg->nd_left, &dot);
arg->nd_left->nd_type = int_type;
}
expp->nd_type = int_type;
if( left->nd_class == Value )
cstcall(expp, R_ORD);
@ -896,12 +1024,12 @@ ChkStandard(expp,left)
if( !(left = getarg(&arg, T_ORDINAL, 0, name, NULLTYPE)) )
return 0;
expp->nd_type = left->nd_type;
if( left->nd_class == Value && !options['r'] )
if( left->nd_class == Value && options['R'] )
cstcall(expp, req);
break;
case R_ODD:
if( !(left = getarg(&arg, T_INTEGER, 0, name, NULLTYPE)) )
if( !(left = getarg(&arg, T_INTEGER | T_LONG , 0, name, NULLTYPE)) )
return 0;
expp->nd_type = bool_type;
if( left->nd_class == Value )
@ -924,7 +1052,7 @@ ChkStandard(expp,left)
if( !arg->nd_right ) {
struct node *nd;
if( !(nd = ChkStdInOut(name, st_out)) )
if( !(nd = ChkStdInOut(name->nd_IDF->id_text, st_out)) )
return 0;
expp->nd_right = MkNode(Link, nd, NULLNODE, &dot);
@ -1042,6 +1170,21 @@ ChkStandard(expp,left)
expp->nd_type = NULLTYPE;
break;
case R_MARK:
case R_RELEASE:
if( !(left = getarg(&arg, T_POINTER, 1, name, NULLTYPE)) )
return 0;
expp->nd_type = NULLTYPE;
break;
case R_HALT:
if( !arg->nd_right ) /* insert 0 parameter */
arg->nd_right = ZeroParam();
if( !(left = getarg(&arg, T_INTEGER, 0, name, NULLTYPE)) )
return 0;
expp->nd_type = NULLTYPE;
break;
default:
crash("(ChkStandard)");
}
@ -1072,6 +1215,8 @@ ChkArrow(expp)
if( !ChkVariable(expp->nd_right) ) return 0;
MarkUsed(expp->nd_right);
tp = expp->nd_right->nd_type;
if( !(tp->tp_fund & (T_POINTER | T_FILE)) ) {
@ -1101,7 +1246,13 @@ ChkArr(expp)
expp->nd_type = error_type;
retval = ChkVariable(expp->nd_left) & ChkExpression(expp->nd_right);
/* Check the index first, so a[a[j]] is checked in order of
* evaluation. This to make sure that warnings are generated
* in the right order.
*/
retval = ChkExpression(expp->nd_right);
MarkUsed(expp->nd_right);
retval &= ChkVariable(expp->nd_left);
tpl = expp->nd_left->nd_type;
tpr = expp->nd_right->nd_type;
@ -1120,6 +1271,11 @@ ChkArr(expp)
return 0;
}
if( tpr == long_type ) {
expp->nd_right = MkNode(IntReduc, NULLNODE, expp->nd_right, &dot);
expp->nd_right->nd_type = int_type;
}
expp->nd_type = tpl->arr_elem;
return retval;
}
@ -1158,6 +1314,8 @@ int (*ExprChkTable[])() = {
NodeCrash,
ChkExLinkOrName,
NodeCrash,
NodeCrash,
NodeCrash,
NodeCrash
};
@ -1175,5 +1333,7 @@ int (*VarAccChkTable[])() = {
done_before,
ChkLinkOrName,
done_before,
no_var_access,
no_var_access,
no_var_access
};

173
lang/pc/comp/code.c
View file

@ -4,12 +4,16 @@
#include <assert.h>
#include <em.h>
#include <em_reg.h>
#include <em_abs.h>
#include "LLlex.h"
#include "Lpars.h"
#include "def.h"
#include "desig.h"
#include "f_info.h"
#include "idf.h"
#include "main.h"
#include "misc.h"
#include "node.h"
#include "required.h"
#include "scope.h"
@ -23,11 +27,25 @@ CodeFil()
C_fil_dlb((label) 1, (arith) 0);
}
routine_label(df)
register struct def * df;
{
df->prc_label = ++data_label;
C_df_dlb(df->prc_label);
C_rom_scon(df->df_idf->id_text, strlen(df->df_idf->id_text) + 1);
}
RomString(nd)
register struct node *nd;
{
C_df_dlb(++data_label);
C_rom_scon(nd->nd_STR, nd->nd_SLE); /* no trailing '\0' */
/* A string of the string_type is null-terminated. */
if( nd->nd_type == string_type )
C_rom_scon(nd->nd_STR, nd->nd_SLE + 1); /* with trailing '\0' */
else
C_rom_scon(nd->nd_STR, nd->nd_SLE); /* no trailing '\0' */
nd->nd_SLA = data_label;
}
@ -94,12 +112,13 @@ CodeBeginBlock(df)
*/
arith StackAdjustment = 0;
arith offset; /* offset to save StackPointer */
arith offset = 0; /* offset to save StackPointer */
TmpOpen(df->prc_vis->sc_scope);
switch( df->df_kind ) {
case D_MODULE : break; /* nothing */
case D_PROGRAM :
C_exp("m_a_i_n");
C_pro_narg("m_a_i_n");
@ -108,8 +127,13 @@ CodeBeginBlock(df)
CodeFil();
/* initialize external files */
make_extfl();
call_ini();
/* ignore floating point underflow */
C_lim();
C_loc((arith) (1 << EFUNFL));
C_ior(int_size);
C_sim();
break;
case D_PROCEDURE :
@ -123,6 +147,21 @@ CodeBeginBlock(df)
offset = CodeGtoDescr(df->prc_vis->sc_scope);
CodeFil();
if( options['t'] ) {
C_lae_dlb(df->prc_label,(arith)0);
C_cal("procentry");
C_asp(pointer_size);
}
/* prc_bool is the local variable that indicates if the
* function result is assigned. This and can be disabled
* with the -R option. The variable, however, is always
* allocated and initialized.
*/
if( df->prc_res ) {
C_zer((arith) int_size);
C_stl(df->prc_bool);
}
for( param = ParamList(df->df_type); param; param = param->next)
if( !IsVarParam(param) ) {
tp = TypeOfParam(param);
@ -213,8 +252,19 @@ CodeEndBlock(df, StackAdjustment)
if( !options['n'] )
RegisterMessages(df->prc_vis->sc_scope->sc_def);
if( options['t'] ) {
C_lae_dlb(df->prc_label,(arith)0);
C_cal("procexit");
C_asp(pointer_size);
}
if( tp = ResultType(df->df_type) ) {
if( tp->tp_size == real_size )
if( !options['R'] ) {
C_lin(LineNumber);
C_lol(df->prc_bool);
C_cal("_nfa");
C_asp(word_size);
}
if( tp->tp_size == 2 * word_size )
C_ldl(-tp->tp_size);
else
C_lol(-tp->tp_size);
@ -345,11 +395,28 @@ CodeExpr(nd, ds, true_label)
struct node *right = nd->nd_right;
CodePExpr(right);
Int2Real();
Int2Real(right->nd_type->tp_size);
ds->dsg_kind = DSG_LOADED;
break;
}
case IntCoerc: {
/* convert integer to long integer */
struct node *right = nd->nd_right;
CodePExpr(right);
Int2Long();
ds->dsg_kind = DSG_LOADED;
break;
}
case IntReduc: {
/* convert a long to an integer */
struct node *right = nd->nd_right;
CodePExpr(right);
Long2Int();
ds->dsg_kind = DSG_LOADED;
break;
}
default:
crash("(CodeExpr : bad node type)");
/*NOTREACHED*/
@ -373,7 +440,7 @@ CodeUoper(nd)
switch( nd->nd_symb ) {
case '-':
assert(tp->tp_fund & T_NUMERIC);
if( tp->tp_fund == T_INTEGER )
if( tp->tp_fund == T_INTEGER || tp->tp_fund == T_LONG )
C_ngi(tp->tp_size);
else
C_ngf(tp->tp_size);
@ -412,6 +479,7 @@ CodeBoper(expr, true_label)
Operands(leftop, rightop);
switch( tp->tp_fund ) {
case T_INTEGER:
case T_LONG:
C_adi(tp->tp_size);
break;
case T_REAL:
@ -429,6 +497,7 @@ CodeBoper(expr, true_label)
Operands(leftop, rightop);
switch( tp->tp_fund ) {
case T_INTEGER:
case T_LONG:
C_sbi(tp->tp_size);
break;
case T_REAL:
@ -447,6 +516,7 @@ CodeBoper(expr, true_label)
Operands(leftop, rightop);
switch( tp->tp_fund ) {
case T_INTEGER:
case T_LONG:
C_mli(tp->tp_size);
break;
case T_REAL:
@ -470,7 +540,7 @@ CodeBoper(expr, true_label)
case DIV:
Operands(leftop, rightop);
if( tp->tp_fund == T_INTEGER )
if( tp->tp_fund == T_INTEGER || tp->tp_fund == T_LONG)
C_dvi(tp->tp_size);
else
crash("(CodeBoper: bad type DIV)");
@ -478,11 +548,16 @@ CodeBoper(expr, true_label)
case MOD:
Operands(leftop, rightop);
if( tp->tp_fund == T_INTEGER ) {
if( tp->tp_fund == T_INTEGER ) {
C_cal("_mdi");
C_asp(2 * tp->tp_size);
C_lfr(tp->tp_size);
}
else if( tp->tp_fund == T_LONG) {
C_cal("_mdil");
C_asp(2 * tp->tp_size);
C_lfr(tp->tp_size);
}
else
crash("(CodeBoper: bad type MOD)");
break;
@ -499,6 +574,7 @@ CodeBoper(expr, true_label)
switch( tp->tp_fund ) {
case T_INTEGER:
case T_LONG:
C_cmi(tp->tp_size);
break;
case T_REAL:
@ -532,14 +608,18 @@ CodeBoper(expr, true_label)
C_cms(tp->tp_size);
break;
case T_STRING:
case T_STRINGCONST:
case T_ARRAY:
C_loc(IsString(tp));
C_loc((arith) IsString(tp));
C_cal("_bcp");
C_asp(2 * pointer_size + word_size);
C_lfr(word_size);
break;
case T_STRING:
C_cmp();
break;
default:
crash("(CodeBoper : bad type COMPARE)");
}
@ -644,7 +724,7 @@ CodeParameters(param, arg)
struct paramlist *param;
struct node *arg;
{
register struct type *tp, *left_tp, *last_tp;
register struct type *tp, *left_tp, *last_tp = (struct type *) 0;
struct node *left;
struct desig ds;
@ -669,7 +749,7 @@ CodeParameters(param, arg)
CodeDAddress(left);
return tp;
}
if( left_tp->tp_fund == T_STRING ) {
if( left_tp->tp_fund == T_STRINGCONST ) {
CodePString(left, tp);
return tp;
}
@ -680,7 +760,7 @@ CodeParameters(param, arg)
RangeCheck(tp, left_tp);
if( tp == real_type && BaseType(left_tp) == int_type )
Int2Real();
Int2Real(int_size);
return tp;
}
@ -693,7 +773,7 @@ CodeConfDescr(ftp, atp)
if( IsConformantArray(elemtp) )
CodeConfDescr(elemtp, atp->arr_elem);
if( atp->tp_fund == T_STRING ) {
if( atp->tp_fund == T_STRINGCONST ) {
C_loc((arith) 1);
C_loc(atp->tp_psize - 1);
C_loc((arith) 1);
@ -807,6 +887,8 @@ CodeStd(nd)
CodePExpr(left);
if( tp == int_type )
C_cal("_abi");
else if ( tp == long_type )
C_cal("_abl");
else
C_cal("_abr");
C_asp(tp->tp_size);
@ -816,8 +898,8 @@ CodeStd(nd)
case R_SQR:
CodePExpr(left);
C_dup(tp->tp_size);
if( tp == int_type )
C_mli(int_size);
if( tp == int_type || tp == long_type )
C_mli(tp->tp_size);
else
C_mlf(real_size);
break;
@ -884,10 +966,14 @@ CodeStd(nd)
case R_SUCC:
case R_PRED:
CodePExpr(left);
C_loc((arith)1);
if( tp == long_type) Int2Long();
if( req == R_SUCC )
C_inc();
C_adi(tp->tp_size);
else
C_dec();
C_sbi(tp->tp_size);
if( bounded(left->nd_type) )
genrck(left->nd_type);
break;
@ -895,7 +981,9 @@ CodeStd(nd)
case R_ODD:
CodePExpr(left);
C_loc((arith) 1);
C_and(word_size);
if( tp == long_type ) Int2Long();
C_and(tp->tp_size);
if( tp == long_type ) Long2Int(); /* bool_size == int_size */
break;
case R_EOF:
@ -989,16 +1077,57 @@ CodeStd(nd)
C_asp(pointer_size + word_size);
break;
case R_MARK:
case R_RELEASE:
CodeDAddress(left);
if( req == R_MARK )
C_cal("_sav");
else
C_cal("_rst");
C_asp(pointer_size);
break;
case R_HALT:
if( left )
CodePExpr(left);
else
C_zer(int_size);
C_cal("_hlt"); /* can't return */
C_asp(int_size); /* help the optimizer(s) */
break;
default:
crash("(CodeStd)");
/*NOTREACHED*/
}
}
Int2Real()
Long2Int()
{
/* convert 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(int_size);
C_loc(size);
C_loc(real_size);
C_cif();
}
@ -1049,7 +1178,7 @@ genrck(tp)
register label o1;
int newlabel = 0;
if( !options['r'] ) return;
if( options['R'] ) return;
getbounds(tp, &lb, &ub);

59
lang/pc/comp/cstoper.c
View file

@ -18,11 +18,18 @@
long mach_long_sign; /* sign bit of the machine long */
int mach_long_size; /* size of long on this machine == sizeof(long) */
long full_mask[MAXSIZE+1];/* full_mask[1] == 0xFF, full_mask[2] == 0xFFFF, .. */
arith max_int; /* maximum integer on target machine */
arith max_int; /* maximum integer on the target machine */
arith min_int; /* mimimum integer on the target machin */
char *maxint_str; /* string representation of maximum integer */
arith wrd_bits; /* number of bits in a word */
arith max_intset; /* largest value of set of integer */
overflow(expp)
struct node *expp;
{
node_warning(expp, "overflow in constant expression");
}
cstunary(expp)
register struct node *expp;
{
@ -66,13 +73,15 @@ cstbin(expp)
*/
register arith o1, o2;
register char *s1, *s2;
int str = expp->nd_left->nd_type->tp_fund & T_STRING;
int str = expp->nd_left->nd_type->tp_fund & T_STRINGCONST;
if( str ) {
o1 = o2 = 0; /* so LINT won't complain */
s1 = expp->nd_left->nd_STR;
s2 = expp->nd_right->nd_STR;
}
else {
s1 = s2 = (char *) 0; /* so LINT won't complain */
o1 = expp->nd_left->nd_INT;
o2 = expp->nd_right->nd_INT;
}
@ -83,14 +92,39 @@ cstbin(expp)
switch( expp->nd_symb ) {
case '+':
if (o1 > 0 && o2 > 0) {
if (max_int - o1 < o2) overflow(expp);
}
else if (o1 < 0 && o2 < 0) {
if (min_int - o1 > o2) overflow(expp);
}
o1 += o2;
break;
case '-':
if ( o1 >= 0 && o2 < 0) {
if (max_int + o2 < o1) overflow(expp);
}
else if (o1 < 0 && o2 >= 0) {
if (min_int + o2 > o1) overflow(expp);
}
o1 -= o2;
break;
case '*':
if (o1 > 0 && o2 > 0) {
if (max_int / o1 < o2) overflow(expp);
}
else if (o1 < 0 && o2 < 0) {
if (o1 == min_int || o2 == min_int ||
max_int / (-o1) < (-o2)) overflow(expp);
}
else if (o1 > 0) {
if (min_int / o1 > o2) overflow(expp);
}
else if (o2 > 0) {
if (min_int / o2 > o1) overflow(expp);
}
o1 *= o2;
break;
@ -171,7 +205,7 @@ cstset(expp)
assert(expp->nd_right->nd_class == Set);
assert(expp->nd_symb == IN || expp->nd_left->nd_class == Set);
set2 = expp->nd_right->nd_set;
setsize = expp->nd_right->nd_type->tp_size / word_size;
setsize = (unsigned) (expp->nd_right->nd_type->tp_size) / (unsigned) word_size;
if( expp->nd_symb == IN ) {
arith i;
@ -331,12 +365,26 @@ cstcall(expp, req)
expp->nd_symb = INTEGER;
switch( req ) {
case R_ABS:
if( expr->nd_INT < 0 ) expp->nd_INT = - expr->nd_INT;
if( expr->nd_INT < 0 ) {
if (expr->nd_INT <= min_int) {
overflow(expr);
}
expp->nd_INT = - expr->nd_INT;
}
else expp->nd_INT = expr->nd_INT;
CutSize(expp);
break;
case R_SQR:
if (expr->nd_INT < 0) {
if ( expr->nd_INT == min_int ||
max_int / expr->nd_INT > expr->nd_INT) {
overflow(expr);
}
}
else if (max_int / expr->nd_INT < expr->nd_INT) {
overflow(expr);
}
expp->nd_INT = expr->nd_INT * expr->nd_INT;
CutSize(expp);
break;
@ -413,7 +461,7 @@ CutSize(expr)
/* integers in [-maxint .. maxint] */
int nbits = (int) (mach_long_size - size) * 8;
node_warning(expr, "overflow in constant expression");
/* overflow(expr); */
/* sign bit of o1 in sign bit of mach_long */
o1 <<= nbits;
/* shift back to get sign extension */
@ -441,6 +489,7 @@ InitCst()
fatal("sizeof (long) insufficient on this machine");
max_int = full_mask[int_size] & ~(1 << (int_size * 8 - 1));
min_int = - max_int;
maxint_str = long2str(max_int, 10);
maxint_str = Salloc(maxint_str, (unsigned int) strlen(maxint_str));
wrd_bits = 8 * word_size;

148
lang/pc/comp/declar.g
View file

@ -1,10 +1,14 @@
/* D E C L A R A T I O N S */
{
/* next line DEBUG */
#include "debug.h"
#include <alloc.h>
#include <assert.h>
#include <em_arith.h>
#include <em_label.h>
#include <pc_file.h>
#include "LLlex.h"
#include "chk_expr.h"
@ -16,8 +20,12 @@
#include "scope.h"
#include "type.h"
#define offsetof(type, field) (int) &(((type *)0)->field)
#define PC_BUFSIZ (sizeof(struct file) - (int)((struct file *)0)->bufadr)
int proclevel = 0; /* nesting level of procedures */
int parlevel = 0; /* nesting level of parametersections */
int expect_label = 0; /* so the parser knows that we expect a label */
static int in_type_defs; /* in type definition part or not */
}
@ -25,42 +33,14 @@ static int in_type_defs; /* in type definition part or not */
Block(struct def *df;)
{
arith i;
label save_label;
} :
{ text_label = (label) 0; }
LabelDeclarationPart
ConstantDefinitionPart
{ in_type_defs = 1; }
TypeDefinitionPart
{ in_type_defs = 0;
/* resolve forward references */
chk_forw_types();
}
VariableDeclarationPart
{ if( !proclevel ) {
chk_prog_params();
BssVar();
}
proclevel++;
save_label = text_label;
}
ProcedureAndFunctionDeclarationPart
{ text_label = save_label;
proclevel--;
chk_directives();
/* needed with labeldefinitions
and for-statement
*/
BlockScope = CurrentScope;
if( !err_occurred )
i = CodeBeginBlock( df );
}
Module(df, &i)
CompoundStatement
{ if( !err_occurred )
CodeEndBlock(df, i);
if( df ) EndBlock(df);
FreeNode(BlockScope->sc_lablist);
}
;
@ -90,6 +70,44 @@ LabelDeclarationPart
]?
;
Module(struct def *df; arith *i;)
{
label save_label;
} :
ConstantDefinitionPart
{ in_type_defs = 1; }
TypeDefinitionPart
{ in_type_defs = 0;
/* resolve forward references */
chk_forw_types();
}
VariableDeclarationPart
{ if( !proclevel ) {
chk_prog_params();
BssVar();
}
proclevel++;
save_label = text_label;
}
ProcedureAndFunctionDeclarationPart
{ text_label = save_label;
proclevel--;
chk_directives();
/* needed with labeldefinitions
and for-statement
*/
BlockScope = CurrentScope;
if( !err_occurred )
*i = CodeBeginBlock( df );
}
;
ConstantDefinitionPart:
[
CONST
@ -132,10 +150,11 @@ Label(struct node **pnd;)
{
char lab[5];
extern char *sprint();
} :
} : { expect_label = 1; }
INTEGER /* not really an integer, in [0..9999] */
{ if( dot.TOK_INT < 0 || dot.TOK_INT > 9999 ) {
error("label must lie in closed interval [0..9999]");
if( dot.TOK_INT != -1 ) /* This means insertion */
error("label must lie in closed interval [0..9999]");
*pnd = NULLNODE;
}
else {
@ -143,6 +162,7 @@ Label(struct node **pnd;)
*pnd = MkLeaf(Name, &dot);
(*pnd)->nd_IDF = str2idf(lab, 1);
}
expect_label = 0;
}
;
@ -159,6 +179,7 @@ ConstantDefinition
{ if( df = define(id,CurrentScope,D_CONST) ) {
df->con_const = nd;
df->df_type = nd->nd_type;
df->df_flags |= D_SET;
}
}
;
@ -172,8 +193,10 @@ TypeDefinition
} :
IDENT { id = dot.TOK_IDF; }
'=' TypeDenoter(&tp)
{ if( df = define(id, CurrentScope, D_TYPE) )
{ if( df = define(id, CurrentScope, D_TYPE) ) {
df->df_type = tp;
df->df_flags |= D_SET;
}
}
;
@ -276,7 +299,9 @@ ProcedureHeading(register struct node **pnd; register struct type **ptp;)
struct node *fpl;
} :
PROCEDURE
IDENT { *pnd = MkLeaf(Name, &dot); }
IDENT {
*pnd = MkLeaf(Name, &dot);
}
[
FormalParameterList(&fpl)
{ arith nb_pars = 0;
@ -287,14 +312,16 @@ ProcedureHeading(register struct node **pnd; register struct type **ptp;)
nb_pars = EnterParamList(fpl, &pr);
else
/* procedure parameter */
EnterParTypes(fpl, &pr);
nb_pars = EnterParTypes(fpl, &pr);
*ptp = proc_type(pr, nb_pars);
FreeNode(fpl);
}
|
/* empty */
{ *ptp = proc_type(0, 0); }
{ *ptp =
proc_type((struct paramlist *)0, (arith) 0);
}
]
;
@ -329,16 +356,18 @@ FunctionDeclaration
else DoDirective(dot.TOK_IDF, nd, tp, scl, 1);
}
|
{ if( df = DeclFunc(nd, tp, scl) )
df->prc_res = CurrentScope->sc_off =
{ if( df = DeclFunc(nd, tp, scl) ) {
df->prc_res =
- ResultType(df->df_type)->tp_size;
df->prc_bool =
CurrentScope->sc_off =
df->prc_res - int_size;
}
}
Block(df)
{ if( df )
/* assignment to functionname is illegal
outside the functionblock
*/
df->prc_res = 0;
{ if( df ) {
EndFunc(df);
}
/* open_scope() is simulated in DeclFunc() */
close_scope();
@ -368,7 +397,7 @@ FunctionHeading(register struct node **pnd; register struct type **ptp;)
nb_pars = EnterParamList(fpl, &pr);
else
/* function parameter */
EnterParTypes(fpl, &pr);
nb_pars = EnterParTypes(fpl, &pr);
}
|
/* empty */
@ -627,7 +656,7 @@ VariantPart(struct scope *scope; arith *cnt; int *palign;
/* initialize selector */
(*sel)->sel_ptrs = (struct selector **)
Malloc(ncst * sizeof(struct selector *));
Malloc((unsigned)ncst * sizeof(struct selector *));
(*sel)->sel_ncst = ncst;
(*sel)->sel_lb = lb;
@ -758,6 +787,12 @@ FileType(register struct type **ptp;):
error("file type has an illegal component type");
(*ptp)->next = error_type;
}
else {
if( (*ptp)->next->tp_size > PC_BUFSIZ )
(*ptp)->tp_size = (*ptp)->tp_psize =
(*ptp)->next->tp_size +
sizeof(struct file) - PC_BUFSIZ;
}
}
;
@ -771,7 +806,10 @@ PointerType(register struct type **ptp;)
{ *ptp = construct_type(T_POINTER, NULLTYPE); }
IDENT
{ nd = MkLeaf(Name, &dot);
df = lookup(nd->nd_IDF, CurrentScope);
df = lookup(nd->nd_IDF, CurrentScope, D_INUSE);
/* if( !df && CurrentScope == GlobalScope)
df = lookup(nd->nd_IDF, PervasiveScope, D_INUSE);
*/
if( in_type_defs &&
(!df || (df->df_kind & (D_ERROR | D_FORWTYPE)))
)
@ -814,11 +852,11 @@ FormalParameterSection(struct node *nd;):
[
/* ValueParameterSpecification */
/* empty */
{ nd->nd_INT = D_VALPAR; }
{ nd->nd_INT = (D_VALPAR | D_SET); }
|
/* VariableParameterSpecification */
VAR
{ nd->nd_INT = D_VARPAR; }
{ nd->nd_INT = (D_VARPAR | D_USED); }
]
IdentifierList(&(nd->nd_left)) ':'
[
@ -829,15 +867,17 @@ FormalParameterSection(struct node *nd;):
TypeIdentifier(&(nd->nd_type))
]
{ if( nd->nd_type->tp_flags & T_HASFILE &&
nd->nd_INT == D_VALPAR ) {
(nd->nd_INT & D_VALPAR) ) {
error("value parameter can't have a filecomponent");
nd->nd_type = error_type;
}
}
|
ProceduralParameterSpecification(&(nd->nd_left), &(nd->nd_type))
{ nd->nd_INT = (D_VALPAR | D_SET); }
|
FunctionalParameterSpecification(&(nd->nd_left), &(nd->nd_type))
{ nd->nd_INT = (D_VALPAR | D_SET); }
]
;
@ -923,13 +963,19 @@ Index_TypeSpecification(register struct type **ptp, *tp;)
register struct def *df1, *df2;
} :
IDENT
{ if( df1 = define(dot.TOK_IDF, CurrentScope, D_LBOUND))
{ if( df1 =
define(dot.TOK_IDF, CurrentScope, D_LBOUND)) {
df1->bnd_type = tp; /* type conf. array */
df1->df_flags |= D_SET;
}
}
UPTO
IDENT
{ if( df2 = define(dot.TOK_IDF, CurrentScope, D_UBOUND))
{ if( df2 =
define(dot.TOK_IDF, CurrentScope, D_UBOUND)) {
df2->bnd_type = tp; /* type conf. array */
df2->df_flags |= D_SET;
}
}
':' TypeIdentifier(ptp)
{ if( !bounded(*ptp) &&

75
lang/pc/comp/def.H
View file

@ -47,6 +47,11 @@ struct lab {
/* ALLOCDEF "lab" 10 */
struct used {
struct def *us_def; /* used definition */
#define usd_def df_value.df_used.us_def
};
struct forwtype {
struct forwtype *f_next;
struct node *f_node;
@ -58,10 +63,14 @@ struct forwtype {
struct dfproc { /* used for procedures and functions */
struct scopelist *pc_vis; /* scope of this procedure/function */
char *pc_name; /* internal name */
label pc_label; /* label of name (for tracing) */
arith pc_res; /* offset of function result */
arith pc_bool; /* offset of run-time boolean */
#define prc_vis df_value.df_proc.pc_vis
#define prc_name df_value.df_proc.pc_name
#define prc_label df_value.df_proc.pc_label
#define prc_res df_value.df_proc.pc_res
#define prc_bool df_value.df_proc.pc_bool
};
struct def { /* list of definitions for a name */
@ -71,39 +80,46 @@ struct def { /* list of definitions for a name */
struct idf *df_idf; /* link back to the name */
struct scope *df_scope; /* scope in which this definition resides */
long df_kind; /* the kind of this definition: */
#define D_PROCEDURE 0x00001 /* procedure */
#define D_FUNCTION 0x00002 /* function */
#define D_TYPE 0x00004 /* a type */
#define D_CONST 0x00008 /* a constant */
#define D_ENUM 0x00010 /* an enumeration literal */
#define D_FIELD 0x00020 /* a field in a record */
#define D_PROGRAM 0x00040 /* the program */
#define D_VARIABLE 0x00080 /* a variable */
#define D_PARAMETER 0x00100 /* program parameter */
#define D_FORWTYPE 0x00200 /* forward type */
#define D_FTYPE 0x00400 /* resolved forward type */
#define D_FWPROCEDURE 0x00800 /* forward procedure */
#define D_FWFUNCTION 0x01000 /* forward function */
#define D_LABEL 0x02000 /* a label */
#define D_LBOUND 0x04000 /* lower bound identifier in conformant array */
#define D_UBOUND 0x08000 /* upper bound identifier in conformant array */
#define D_FORWARD 0x10000 /* directive "forward" */
#define D_EXTERN 0x20000 /* directive "extern" */
#define D_ERROR 0x40000 /* a compiler generated definition for an
* undefined variable
*/
#define D_PROCEDURE 0x000001 /* procedure */
#define D_FUNCTION 0x000002 /* function */
#define D_TYPE 0x000004 /* a type */
#define D_CONST 0x000008 /* a constant */
#define D_ENUM 0x000010 /* an enumeration literal */
#define D_FIELD 0x000020 /* a field in a record */
#define D_PROGRAM 0x000040 /* the program */
#define D_VARIABLE 0x000080 /* a variable */
#define D_PARAMETER 0x000100 /* program parameter */
#define D_FORWTYPE 0x000200 /* forward type */
#define D_FTYPE 0x000400 /* resolved forward type */
#define D_FWPROCEDURE 0x000800 /* forward procedure */
#define D_FWFUNCTION 0x001000 /* forward function */
#define D_LABEL 0x002000 /* a label */
#define D_LBOUND 0x004000 /* lower bound id. in conform. array */
#define D_UBOUND 0x008000 /* upper bound id. in conform. array */
#define D_FORWARD 0x010000 /* directive "forward" */
#define D_EXTERN 0x020000 /* directive "extern" */
#define D_ERROR 0x040000 /* a compiler generated definition
* for an undefined variable */
#define D_MODULE 0x080000 /* the module */
#define D_INUSE 0x100000 /* variable is in use */
#define D_VALUE (D_FUNCTION | D_CONST | D_ENUM | D_FIELD | D_VARIABLE\
| D_FWFUNCTION | D_LBOUND | D_UBOUND)
#define D_ROUTINE (D_FUNCTION | D_FWFUNCTION | D_PROCEDURE | D_FWPROCEDURE)
unsigned short df_flags;
#define D_NOREG 0x01 /* set if it may not reside in a register */
#define D_VALPAR 0x02 /* set if it is a value parameter */
#define D_VARPAR 0x04 /* set if it is a var parameter */
#define D_LOOPVAR 0x08 /* set if it is a contol-variable */
#define D_EXTERNAL 0x10 /* set if proc/func is external declared */
#define D_PROGPAR 0x20 /* set if input/output was mentioned in
* the program-heading
*/
#define D_NOREG 0x001 /* set if it may not reside in a register */
#define D_VALPAR 0x002 /* set if it is a value parameter */
#define D_VARPAR 0x004 /* set if it is a var parameter */
#define D_LOOPVAR 0x008 /* set if it is a control-variable */
#define D_EXTERNAL 0x010 /* set if proc/func is external declared */
#define D_PROGPAR 0x020 /* set if input/output was mentioned in
* the program-heading */
#define D_USED 0x040 /* set when the variable is used */
#define D_SET 0x080 /* set when the variable is set */
#define D_INLOOP 0x100 /* set when we are inside a loop */
#define D_WITH 0x200 /* set inside a with statement */
#define D_SETINHIGH 0x400 /* set in a higher scope level (for loops) */
struct type *df_type;
union {
struct constant df_constant;
@ -112,6 +128,7 @@ struct def { /* list of definitions for a name */
struct enumval df_enum;
struct field df_field;
struct lab df_label;
struct used df_used;
struct forwtype *df_fwtype;
struct dfproc df_proc;
int df_reqname; /* define for required name */

79
lang/pc/comp/def.c
View file

@ -52,9 +52,16 @@ define(id, scope, kind)
*/
register struct def *df;
if( df = lookup(id, scope) ) {
if( df = lookup(id, scope, 0) ) {
switch( df->df_kind ) {
case D_INUSE :
if( kind != D_INUSE ) {
error("\"%s\" already used in this block",
id->id_text);
}
return MkDef(id, scope, kind);
case D_LABEL :
/* generate error message somewhere else */
return NULLDEF;
@ -113,7 +120,7 @@ DoDirective(directive, nd, tp, scl, function)
int kind; /* kind of directive */
int inp; /* internal or external name */
int ext = 0; /* directive = EXTERN */
struct def *df = lookup(directive, PervasiveScope);
struct def *df = lookup(directive, PervasiveScope, D_INUSE);
if( !df ) {
if( !is_anon_idf(directive) )
@ -136,6 +143,7 @@ DoDirective(directive, nd, tp, scl, function)
default:
crash("(DoDirective)");
/* NOTREACHED */
}
if( df = define(nd->nd_IDF, CurrentScope, kind) ) {
@ -150,9 +158,10 @@ DoDirective(directive, nd, tp, scl, function)
df->prc_vis = scl;
df->prc_name = gen_proc_name(nd->nd_IDF, inp);
if( ext ) df->df_flags |= D_EXTERNAL;
df->df_flags |= D_SET;
}
}
struct def *
DeclProc(nd, tp, scl)
register struct node *nd;
@ -162,6 +171,7 @@ DeclProc(nd, tp, scl)
register struct def *df;
if( df = define(nd->nd_IDF, CurrentScope, D_PROCEDURE) ) {
df->df_flags |= D_SET;
if( df->df_kind == D_FWPROCEDURE ) {
df->df_kind = D_PROCEDURE; /* identification */
@ -172,7 +182,7 @@ DeclProc(nd, tp, scl)
if( tp->prc_params )
node_error(nd,
"procedure identification \"%s\" expected",
"\"%s\" already declared",
nd->nd_IDF->id_text);
}
else { /* normal declaration */
@ -181,6 +191,7 @@ DeclProc(nd, tp, scl)
/* simulate open_scope() */
CurrVis = df->prc_vis = scl;
}
routine_label(df);
}
else CurrVis = scl; /* simulate open_scope() */
@ -196,11 +207,12 @@ DeclFunc(nd, tp, scl)
register struct def *df;
if( df = define(nd->nd_IDF, CurrentScope, D_FUNCTION) ) {
df->df_flags &= ~D_SET;
if( df->df_kind == D_FUNCTION ) { /* declaration */
if( !tp ) {
node_error(nd, "\"%s\" illegal function declaration",
nd->nd_IDF->id_text);
tp = error_type;
tp = construct_type(T_FUNCTION, error_type);
}
/* simulate open_scope() */
CurrVis = df->prc_vis = scl;
@ -215,12 +227,67 @@ DeclFunc(nd, tp, scl)
if( tp )
node_error(nd,
"function identification \"%s\" expected",
"\"%s\" already declared",
nd->nd_IDF->id_text);
}
routine_label(df);
}
else CurrVis = scl; /* simulate open_scope() */
return df;
}
EndFunc(df)
register struct def *df;
{
/* assignment to functionname is illegal outside the functionblock */
df->prc_res = 0;
/* Give the error about assignment as soon as possible. The
* |= assignment inhibits a warning in the main procedure.
*/
if( !(df->df_flags & D_SET) ) {
error("function \"%s\" not assigned",df->df_idf->id_text);
df->df_flags |= D_SET;
}
}
EndBlock(block_df)
register struct def *block_df;
{
register struct def *tmp_def = CurrentScope->sc_def;
register struct def *df;
while( tmp_def ) {
df = tmp_def;
/* The length of a usd_def chain is at most 1.
* The while is just defensive programming.
*/
while( df->df_kind & D_INUSE )
df = df->usd_def;
if( !is_anon_idf(df->df_idf)
&& (df->df_scope == CurrentScope) ) {
if( !(df->df_kind & (D_ENUM|D_LABEL|D_ERROR)) ) {
if( !(df->df_flags & D_USED) ) {
if( !(df->df_flags & D_SET) ) {
warning("\"%s\" neither set nor used in \"%s\"",
df->df_idf->id_text, block_df->df_idf->id_text);
}
else {
warning("\"%s\" unused in \"%s\"",
df->df_idf->id_text, block_df->df_idf->id_text);
}
}
else if( !(df->df_flags & D_SET) ) {
if( !(df->df_flags & D_LOOPVAR) )
warning("\"%s\" not set in \"%s\"",
df->df_idf->id_text, block_df->df_idf->id_text);
}
}
}
tmp_def = tmp_def->df_nextinscope;
}
}

19
lang/pc/comp/desig.c
View file

@ -16,6 +16,8 @@
#include "def.h"
#include "desig.h"
#include "main.h"
/* next line DEBUG */
#include "idf.h"
#include "node.h"
#include "scope.h"
#include "type.h"
@ -87,7 +89,7 @@ CodeMove(rhs, left, rtp)
switch( rhs->dsg_kind ) {
case DSG_LOADED:
CodeDesig(left, lhs);
if( rtp->tp_fund == T_STRING ) {
if( rtp->tp_fund == T_STRINGCONST ) {
CodeAddress(lhs);
C_blm(lhs->dsg_packed ? ltp->tp_psize : ltp->tp_size);
return;
@ -439,6 +441,13 @@ CodeFuncDesig(df, ds)
the function (i.e. in the statement-part of a nested function
or procedure).
*/
if( !options['R'] ) {
C_loc((arith)1);
C_lxl((arith) (proclevel - df->df_scope->sc_level - 1));
C_adp(df->prc_bool);
C_sti(int_size);
}
C_lxl((arith) (proclevel - df->df_scope->sc_level - 1));
ds->dsg_kind = DSG_PLOADED;
}
@ -446,6 +455,11 @@ CodeFuncDesig(df, ds)
/* Assignment to function-identifier in the statement-part of
the function.
*/
if( !options['R'] ) {
C_loc((arith)1);
C_stl(df->prc_bool);
}
ds->dsg_kind = DSG_FIXED;
}
assert(df->prc_res < 0);
@ -518,6 +532,9 @@ CodeDesig(nd, ds)
else
C_lae_dlb(tp->arr_ardescr, (arith) 0);
if( options['A'] ) {
C_cal("_rcka");
}
ds->dsg_kind = DSG_INDEXED;
ds->dsg_packed = IsPacked(tp);
break;

54
lang/pc/comp/em_pc.6
View file

@ -4,15 +4,18 @@
em_pc \- Pascal compiler
.SH SYNOPSIS
.B em_pc
.RI [ option ]
.RI [ option ]
.I source
.I destination
.SH DESCRIPTION
.I Em_pc
is a compiler that translates Pascal programs into EM code.
Normally the compiler is called by means of the user interface program
\fIack\fR(I).
.PP
The input is taken from
.IR source ,
while the EM code is written on
while the EM code is written on
.IR destination .
.br
.I Option
@ -21,6 +24,7 @@ is a, possibly empty, sequence of the following combinations:
set maximum identifier length to \fIn\fP.
The minimum value for \fIn\fR is 9, because the keyword
"PROCEDURE" is that long.
.IR n
.IP \fB\-n\fR
do not generate EM register messages.
The user-declared variables will not be stored into registers on the target
@ -32,7 +36,8 @@ an interpreter to keep track of the current location in the source code.
.br
set the size and alignment requirements.
The letter \fIc\fR indicates the simple type, which is one of
\fBw\fR(word size), \fBi\fR(INTEGER), \fBf\fR(REAL), or \fBp\fR(POINTER).
\fBw\fR(word size), \fBi\fR(INTEGER), \fBl\fR(LONG), \fBr\fR(REAL),
\fBp\fR(POINTER).
It may also be the letter \fBS\fR, indicating that an initial
record alignment follows.
The \fIm\fR parameter can be used to specify the length of the type (in bytes)
@ -40,22 +45,39 @@ and the \fIn\fR parameter for the alignment of that type.
Absence of \fIm\fR or \fIn\fR causes a default value to be retained.
.IP \fB\-w\fR
suppress warning messages.
.IP \fB\-u\fR
The character '_' is treated like a letter, so it is allowed to use the
underscore in identifiers.
.IP \fB\-i\fR\fInum\fR
maximum number of bits in a set. When not used, a default value is
retained.
.IP
.IP \fB\-R\fR
disable range checks. Additionally, the run-time tests to see if
a function is assigned, are skipped.
.IP \fB\-A\fR
enable extra array bound checks, for machines that do not implement the
EM ones.
.IP \fB\-C\fR
The lower case and upper case letters are treated different.
.IP \fB\-r\fR
The rangechecks are generated where necessary.
.LP
the lower case and upper case letters are treated differently.
.IP "\fB\-u\fR, \fB\-U\fR"
allow underscores in identifiers. It is not allowed to start an identifier
with an underscore.
.IP \fB\-a\fR
don't generate code for assertions.
.IP \fB\-c\fR
allow C-like strings. This option is mainly intended for usage with
C-functions. This option will cause the type 'string' to be known.
.IP \fB\-d\fR
allow the type 'long'.
.IP \fB\-i\fR\fIn\fR
set the size of integer sets to \fIn\fR. When not used, a default value is
retained.
.IP \fB\-s\fR
allow only standard Pascal. This disables the \fB\-c\fR, \fB\-d\fR, \fB\-u\fR,
\fB\-U\fR and \fB\-C\fR
options. Furthermore, assertions are not recognized at all (instead of just
being skipped).
.IP \fB\-t\fR
trace calls and exits of procedures and functions.
.PP
.SH FILES
.IR ~em/lib/em_pc :
binary of the Pascal compiler.
.SH DIAGNOSTICS
All warning and error messages are written on standard error output.
.SH REMARKS
Debugging and profiling facilities may be present during the development
of \fIem_pc\fP.
Descriptions of run-time errors are read from ~em/etc/pc_rt_errors.

37
lang/pc/comp/enter.c
View file

@ -23,13 +23,17 @@ Enter(name, kind, type, pnam)
{
/* Enter a definition for "name" with kind "kind" and type
"type" in the Current Scope. If it is a standard name, also
put its number in the definition structure.
put its number in the definition structure, and mark the
name as set, to inhibit warnings about used before set.
*/
register struct def *df;
df = define(str2idf(name, 0), CurrentScope, kind);
df->df_type = type;
if( pnam ) df->df_value.df_reqname = pnam;
if( pnam ) {
df->df_value.df_reqname = pnam;
df->df_flags |= D_SET;
}
return df;
}
@ -45,13 +49,13 @@ EnterProgList(Idlist)
!strcmp(output, idlist->nd_IDF->id_text)
) {
/* the occurence of input or output as program-
* parameter is their declartion as a GLOBAL variable
* of type text
* parameter is their declaration as a GLOBAL
* variable of type text
*/
if( df = define(idlist->nd_IDF, CurrentScope,
D_VARIABLE) ) {
df->df_type = text_type;
df->df_flags |= (D_PROGPAR | D_NOREG);
df->df_flags |= (D_SET | D_PROGPAR | D_NOREG);
if( !strcmp(input, idlist->nd_IDF->id_text) ) {
df->var_name = input;
set_inp();
@ -67,6 +71,7 @@ EnterProgList(Idlist)
D_PARAMETER) ) {
df->df_type = error_type;
df->df_flags |= D_PROGPAR;
df->var_name = idlist->nd_IDF->id_text;
}
}
@ -88,6 +93,7 @@ EnterEnumList(Idlist, type)
if( df = define(idlist->nd_IDF, CurrentScope, D_ENUM) ) {
df->df_type = type;
df->enm_val = (type->enm_ncst)++;
df->df_flags |= D_SET;
}
FreeNode(Idlist);
}
@ -171,7 +177,7 @@ EnterParamList(fpl, parlist)
for( id = fpl->nd_left; id; id = id->nd_next )
if( df = define(id->nd_IDF, CurrentScope, D_VARIABLE) ) {
df->var_off = nb_pars;
if( fpl->nd_INT == D_VARPAR || IsConformantArray(tp) )
if( fpl->nd_INT & D_VARPAR || IsConformantArray(tp) )
nb_pars += pointer_size;
else
nb_pars += tp->tp_size;
@ -192,6 +198,7 @@ EnterParamList(fpl, parlist)
return nb_pars;
}
arith
EnterParTypes(fpl, parlist)
register struct node *fpl;
struct paramlist **parlist;
@ -199,16 +206,30 @@ EnterParTypes(fpl, parlist)
/* Parameters in heading of procedural and functional
parameters (only types are important, not the names).
*/
register arith nb_pars = 0;
register struct node *id;
struct type *tp;
struct def *df;
for( ; fpl; fpl = fpl->nd_right )
for( ; fpl; fpl = fpl->nd_right ) {
tp = fpl->nd_type;
for( id = fpl->nd_left; id; id = id->nd_next )
if( df = new_def() ) {
if( fpl->nd_INT & D_VARPAR ||
IsConformantArray(tp) )
nb_pars += pointer_size;
else
nb_pars += tp->tp_size;
LinkParam(parlist, df);
df->df_type = fpl->nd_type;
df->df_type = tp;
df->df_flags |= fpl->nd_INT;
}
while( IsConformantArray(tp) ) {
nb_pars += 3 * word_size;
tp = tp->arr_elem;
}
}
return nb_pars;
}
LinkParam(parlist, df)

22
lang/pc/comp/error.c
View file

@ -130,7 +130,7 @@ _error(class, node, fmt, argv)
static unsigned int last_ln = 0;
unsigned int ln = 0;
static char * last_fn = 0;
static int e_seen = 0;
static int e_seen = 0, w_seen = 0;
register char *remark = 0;
/* Since name and number are gathered from different places
@ -189,17 +189,25 @@ _error(class, node, fmt, argv)
#endif
if( FileName == last_fn && ln == last_ln ) {
/* we've seen this place before */
e_seen++;
if( e_seen == MAXERR_LINE ) fmt = "etc ...";
else if( e_seen > MAXERR_LINE )
/* and too often, I'd say ! */
return;
if( class != WARNING && class != LEXWARNING ) {
e_seen++;
if( e_seen == MAXERR_LINE ) fmt = "etc ...";
else if( e_seen > MAXERR_LINE )
/* and too often, I'd say ! */
return;
}
else {
w_seen++;
if( w_seen == MAXERR_LINE ) fmt = "etc ...";
else if( w_seen > MAXERR_LINE )
return;
}
}
else {
/* brand new place */
last_ln = ln;
last_fn = FileName;
e_seen = 0;
e_seen = w_seen = 0;
}
#ifdef DEBUG
}

12
lang/pc/comp/expression.g
View file

@ -11,6 +11,8 @@
#include "chk_expr.h"
#include "def.h"
#include "main.h"
#include "misc.h"
#include "idf.h"
#include "node.h"
#include "scope.h"
#include "type.h"
@ -49,7 +51,8 @@ UnsignedNumber(register struct node **pnd;):
;
ConstantIdentifier(register struct node **pnd;):
IDENT { *pnd = MkLeaf(Name, &dot); }
IDENT { *pnd = MkLeaf(Name, &dot);
}
;
/* ISO section 6.7.1, p. 121 */
@ -98,13 +101,16 @@ Factor(register struct node **pnd;)
/* This is a changed rule, because the grammar as specified in the
* reference is not LL(1), and this gives conflicts.
*/
%default
%prefer /* solve conflicts on IDENT and UnsignedConstant */
IDENT { *pnd = MkLeaf(Name, &dot); }
[
/* ISO section 6.7.3, p. 126
* IDENT is a FunctionIdentifier
*/
{ *pnd = MkNode(Call, *pnd, NULLNODE, &dot); }
{
*pnd = MkNode(Call, *pnd, NULLNODE, &dot);
}
ActualParameterList(&((*pnd)->nd_right))
|
/* IDENT can be a BoundIdentifier or a ConstantIdentifier or
@ -116,6 +122,7 @@ Factor(register struct node **pnd;)
{ int class;
df = lookfor(*pnd, CurrVis, 1);
/* df->df_flags |= D_USED; */
if( df->df_type->tp_fund & T_ROUTINE ) {
/* This part is context-sensitive:
is the occurence of the proc/func name
@ -200,6 +207,7 @@ BooleanExpression(register struct node **pnd;):
{ if( ChkExpression(*pnd) &&
(*pnd)->nd_type != bool_type )
node_error(*pnd, "boolean expression expected");
MarkUsed(*pnd);
}
;

7
lang/pc/comp/label.c
View file

@ -17,8 +17,9 @@ DeclLabel(nd)
{
struct def *df;
if( !(df = define(nd->nd_IDF, CurrentScope, D_LABEL)) )
if( !(df = define(nd->nd_IDF, CurrentScope, D_LABEL)) ) {
node_error(nd, "label %s redeclared", nd->nd_IDF->id_text);
}
else {
df->lab_no = ++text_label;
nd->nd_def = df;
@ -74,6 +75,7 @@ TstLabel(nd, Slevel)
else
FreeNode(nd);
df->df_flags = D_USED;
if( !df->lab_level ) {
/* forward jump */
register struct lab *labelptr;
@ -105,7 +107,7 @@ DefLabel(nd, Slevel)
{
register struct def *df;
if( !(df = lookup(nd->nd_IDF, BlockScope)) ) {
if( !(df = lookup(nd->nd_IDF, BlockScope, D_INUSE)) ) {
node_error(nd, "label %s must be declared in same block"
, nd->nd_IDF->id_text);
df = define(nd->nd_IDF, BlockScope, D_LABEL);
@ -116,6 +118,7 @@ DefLabel(nd, Slevel)
}
else FreeNode(nd);
df->df_flags |= D_SET;
if( df->lab_level)
node_error(nd, "label %s already defined", nd->nd_IDF->id_text);
else {

64
lang/pc/comp/lookup.c
View file

@ -1,7 +1,9 @@
/* L O O K U P R O U T I N E S */
#include <alloc.h>
#include <em_arith.h>
#include <em_label.h>
#include <assert.h>
#include "LLlex.h"
#include "def.h"
@ -11,8 +13,22 @@
#include "scope.h"
#include "type.h"
remove_def(df)
register struct def *df;
{
struct idf *id= df->df_idf;
struct def *df1 = id->id_def;
if( df1 == df ) id->id_def = df->df_next;
else {
while( df1 && df1->df_next != df ) df1 = df1->df_next;
df1->df_next = df->df_next;
free_def(df);
}
}
struct def *
lookup(id, scope)
lookup(id, scope, inuse)
register struct idf *id;
struct scope *scope;
{
@ -30,13 +46,22 @@ lookup(id, scope)
df && df->df_scope != scope;
df1 = df, df = df->df_next ) { /* nothing */ }
if( df && df1 ) {
/* Put the definition in front
if( df ) {
/* Found it
*/
df1->df_next = df->df_next;
df->df_next = id->id_def;
id->id_def = df;
if( df1) {
/* Put the definition in front
*/
df1->df_next = df->df_next;
df->df_next = id->id_def;
id->id_def = df;
}
while( df->df_kind & inuse ) {
assert(df->usd_def != 0);
df=df->usd_def;
}
}
return df;
}
@ -49,12 +74,33 @@ lookfor(id, vis, give_error)
If it is not defined create a dummy definition and
if give_error is set, give an error message.
*/
register struct def *df;
register struct def *df, *tmp_df;
register struct scopelist *sc = vis;
while( sc ) {
df = lookup(id->nd_IDF, sc->sc_scope);
if( df ) return df;
df = lookup(id->nd_IDF, sc->sc_scope, D_INUSE);
if( df ) {
while( vis->sc_scope->sc_level >
sc->sc_scope->sc_level ) {
if( tmp_df = define(id->nd_IDF, vis->sc_scope,
D_INUSE))
tmp_df->usd_def = df;
vis = nextvisible(vis);
}
/* Since the scope-level of standard procedures is the
* same as for the user-defined procedures, the procedure
* must be marked as used. Not doing so would mean that
* such a procedure could redefined after usage.
*/
if( (vis->sc_scope == GlobalScope) &&
!lookup(id->nd_IDF, GlobalScope, D_INUSE) ) {
if( tmp_df = define(id->nd_IDF, vis->sc_scope,
D_INUSE))
tmp_df->usd_def = df;
}
return df;
}
sc = nextvisible(sc);
}

46
lang/pc/comp/main.c
View file

@ -8,6 +8,7 @@
#include "LLlex.h"
#include "Lpars.h"
#include "class.h"
#include "const.h"
#include "def.h"
#include "f_info.h"
@ -48,9 +49,10 @@ main(argc, argv)
Nargv[Nargc] = 0; /* terminate the arg vector */
if( Nargc < 2 ) {
fprint(STDERR, "%s: Use a file argument\n", ProgName);
exit(1);
sys_stop(S_EXIT);
}
exit(!Compile(Nargv[1], Nargv[2]));
if(!Compile(Nargv[1], Nargv[2])) sys_stop(S_EXIT);
sys_stop(S_END);
}
Compile(src, dst)
@ -58,6 +60,7 @@ Compile(src, dst)
{
extern struct tokenname tkidf[];
extern struct tokenname tkstandard[];
int tk;
if( !InsertFile(src, (char **) 0, &src) ) {
fprint(STDERR, "%s: cannot open %s\n", ProgName, src);
@ -69,13 +72,32 @@ Compile(src, dst)
InitCst();
reserve(tkidf);
reserve(tkstandard);
CheckForLineDirective();
tk = LLlex(); /* Read the first token and put */
aside = dot; /* it aside. In this way, options */
asidetype = toktype; /* inside comments will be seen */
dot.tk_symb = tk; /* before the program starts. */
tokenseen = 1;
InitScope();
InitTypes();
AddRequired();
if( options['c'] ) tkclass['"'] = STSTR;
if( options['u'] || options['U'] ) {
class('_') = STIDF;
inidf['_'] = 1;
}
if( tk == '"' || tk == '_' ) {
PushBack();
ASIDE = 0;
}
#ifdef DEBUG
if( options['l'] ) {
LexScan();
return 1;
return 0; /* running the optimizer is not very useful */
}
#endif DEBUG
C_init(word_size, pointer_size);
@ -84,7 +106,7 @@ Compile(src, dst)
C_magic();
C_ms_emx(word_size, pointer_size);
C_df_dlb(++data_label);
C_rom_scon(FileName, strlen(FileName) + 1);
C_rom_scon(FileName,(arith) strlen(FileName) + 1);
LLparse();
C_ms_src((arith) (LineNumber - 1), FileName);
if( fp_used ) C_ms_flt();
@ -148,6 +170,14 @@ AddRequired()
/* DYNAMIC ALLOCATION PROCEDURES */
(void) Enter("new", D_PROCEDURE, std_type, R_NEW);
(void) Enter("dispose", D_PROCEDURE, std_type, R_DISPOSE);
if( !options['s'] ) {
(void) Enter("mark", D_PROCEDURE, std_type, R_MARK);
(void) Enter("release", D_PROCEDURE, std_type, R_RELEASE);
}
/* MISCELLANEOUS PROCEDURE(S) */
if( !options['s'] )
(void) Enter("halt", D_PROCEDURE, std_type, R_HALT);
/* TRANSFER PROCEDURES */
(void) Enter("pack", D_PROCEDURE, std_type, R_PACK);
@ -187,6 +217,11 @@ AddRequired()
(void) Enter("boolean", D_TYPE, bool_type, 0);
(void) Enter("text", D_TYPE, text_type, 0);
if( options['d'] )
(void) Enter("long", D_TYPE, long_type, 0);
if( options['c'] )
(void) Enter("string", D_TYPE, string_type, 0);
/* DIRECTIVES */
(void) Enter("forward", D_FORWARD, NULLTYPE, 0);
(void) Enter("extern", D_EXTERN, NULLTYPE, 0);
@ -196,13 +231,16 @@ AddRequired()
df = Enter("maxint", D_CONST, int_type, 0);
df->con_const = &maxintnode;
df->df_flags |= D_SET;
maxintnode.nd_type = int_type;
maxintnode.nd_INT = max_int; /* defined in cstoper.c */
df = Enter("true", D_ENUM, bool_type, 0);
df->enm_val = 1;
df->df_flags |= D_SET;
df->enm_next = Enter("false", D_ENUM, bool_type, 0);
df = df->enm_next;
df->enm_val = 0;
df->df_flags |= D_SET;
df->enm_next = NULLDEF;
}

9
lang/pc/comp/misc.h
View file

@ -8,3 +8,12 @@ extern struct idf
extern char
*gen_proc_name();
extern char *symbol2str();
extern arith NewInt();
extern arith NewPtr();
extern arith CodeBeginBlock();
extern arith EnterParamList();
extern arith EnterParTypes();
extern arith CodeInitFor();
extern arith IsString();

4
lang/pc/comp/nmclash.c Normal file
View file

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

2
lang/pc/comp/node.H
View file

@ -19,6 +19,8 @@ struct node {
#define Link 11
#define LinkDef 12
#define Cast 13 /* convert integer to real */
#define IntCoerc 14 /* coercion of integers to longs */
#define IntReduc 15 /* reduction of longs to integers */
/* do NOT change the order or the numbers!!! */
struct type *nd_type; /* type of this node */
struct token nd_token;

30
lang/pc/comp/options.c
View file

@ -8,6 +8,7 @@
#include "idfsize.h"
#include "main.h"
#include "type.h"
#include "nocross.h"
#define MINIDFSIZE 9
@ -28,8 +29,10 @@ DoOption(text)
break;
/* recognized flags:
-i: largest value of set of integer
-u: allow underscore in identifier
-u, -U: allow underscore in identifier
-w: no warnings
-R: no range checks
-A: range checks for array references
and many more if DEBUG
*/
@ -51,9 +54,10 @@ DoOption(text)
idfsize = txt2int(&t);
text = t;
if( idfsize <= 0 || *t )
if( idfsize <= 0 || *t ) {
fatal("malformed -M option");
/*NOTREACHED*/
}
if( idfsize > IDFSIZE ) {
idfsize = IDFSIZE;
warning("maximum identifier length is %d", IDFSIZE);
@ -65,14 +69,15 @@ DoOption(text)
break;
}
case 'u': /* underscore allowed in identifiers */
class('_') = STIDF;
inidf['_'] = 1;
break;
/* case 'u': /* underscore allowed in identifiers */
/* class('_') = STIDF;
/* inidf['_'] = 1;
/* break;
*/
case 'V' : { /* set object sizes and alignment requirements */
/* syntax : -V[ [w|i|f|p] size? [.alignment]? ]* */
/* syntax : -V[ [w|i|l|f|p] size? [.alignment]? ]* */
#ifndef NOCROSS
register arith size;
register int align;
char c, *t;
@ -88,7 +93,7 @@ DoOption(text)
align = txt2int(&t);
text = t;
}
if( !strindex("wifpS", c) )
if( !strindex("wilfpS", c) )
error("-V: bad type indicator %c\n", c);
if( size )
switch( c ) {
@ -98,6 +103,9 @@ DoOption(text)
case 'i': /* int */
int_size = size;
break;
case 'l': /* long */
long_size = size;
break;
case 'f': /* real */
real_size = size;
break;
@ -117,6 +125,9 @@ DoOption(text)
case 'i': /* int */
int_align = align;
break;
case 'l': /* long */
long_align = align;
break;
case 'f': /* real */
real_align = align;
break;
@ -129,6 +140,7 @@ DoOption(text)
}
}
break;
#endif NOCROSS
}
}
}

13
lang/pc/comp/program.g
View file

@ -7,6 +7,8 @@
#include "LLlex.h"
#include "def.h"
#include "f_info.h"
#include "idf.h"
#include "main.h"
#include "node.h"
#include "scope.h"
@ -20,8 +22,18 @@
Program
{
struct def *df;
arith dummy;
}:
ProgramHeading(&df) ';' Block(df) '.'
| { df = new_def();
df->df_idf = str2idf(FileName, 1);
df->df_kind = D_MODULE;
open_scope();
GlobalScope = CurrentScope;
df->prc_vis = CurrVis;
}
Module(df, &dummy)
;
ProgramHeading(register struct def **df;):
@ -37,6 +49,7 @@ ProgramHeading(register struct def **df;):
'('
ProgramParameters
')'
{ make_extfl(); }
]?
;

39
lang/pc/comp/progs.c
View file

@ -1,6 +1,7 @@
#include "debug.h"
#include <em.h>
#include <assert.h>
#include "LLlex.h"
#include "def.h"
@ -25,35 +26,53 @@ set_outp()
make_extfl()
{
register struct def *df;
if( err_occurred ) return;
extfl_label = ++data_label;
C_df_dlb(extfl_label);
if( inpflag )
if( inpflag ) {
C_ina_dnam(input);
C_con_dnam(input, (arith) 0);
}
else
C_con_ucon("0", pointer_size);
if( outpflag )
if( outpflag ) {
C_ina_dnam(output);
C_con_dnam(output, (arith) 0);
}
else
C_con_ucon("0", pointer_size);
extflc = 2;
for( df = GlobalScope->sc_def; df; df = df->df_nextinscope )
if( (df->df_flags & D_PROGPAR) &&
df->var_name != input && df->var_name != output) {
C_con_dnam(df->var_name, (arith) 0);
extflc++;
}
/* Process the identifiers in the global scope (at this point only
* the program parameters) in order of specification.
*/
make_extfl_args( GlobalScope->sc_def );
}
make_extfl_args(df)
register struct def *df;
{
if( !df ) return;
make_extfl_args(df->df_nextinscope);
assert(df->df_flags & D_PROGPAR);
if( df->var_name != input && df->var_name != output ) {
C_ina_dnam(df->var_name);
C_con_dnam(df->var_name, (arith) 0);
extflc++;
}
}
call_ini()
{
C_lxl((arith) 0);
C_lae_dlb(extfl_label, (arith) 0);
if( extflc )
C_lae_dlb(extfl_label, (arith) 0);
else
C_zer(pointer_size);
C_loc((arith) extflc);
C_lxa((arith) 0);
C_cal("_ini");

77
lang/pc/comp/readwrite.c
View file

@ -8,15 +8,21 @@
#include "LLlex.h"
#include "def.h"
#include "main.h"
#include "misc.h"
#include "node.h"
#include "scope.h"
#include "type.h"
/* DEBUG */
#include "idf.h"
ChkRead(arg)
register struct node *arg;
{
struct node *file;
char *name = "read";
char *message, buff[80];
extern char *ChkAllowedVar();
assert(arg);
assert(arg->nd_symb == ',');
@ -43,6 +49,19 @@ ChkRead(arg)
"\"%s\": illegal parameter type",name);
return;
}
else if( (BaseType(file->nd_type->next) == long_type
&& arg->nd_left->nd_type == int_type)
||
(BaseType(file->nd_type->next) == int_type
&& arg->nd_left->nd_type == long_type) ) {
if( int_size != long_size ) {
node_error(arg->nd_left,
"\"%s\": longs and integers have different sizes",name);
return;
}
else node_warning(arg->nd_left,
"\"%s\": mixture of longs and integers", name);
}
}
else if( !(BaseType(arg->nd_left->nd_type)->tp_fund &
( T_CHAR | T_NUMERIC )) ) {
@ -50,6 +69,14 @@ ChkRead(arg)
"\"%s\": illegal parameter type",name);
return;
}
message = ChkAllowedVar(arg->nd_left, 1);
if( message ) {
sprint(buff,"\"%%s\": %s can't be a variable parameter",
message);
node_error(arg->nd_left, buff, name);
return;
}
CodeRead(file, arg->nd_left);
arg = arg->nd_right;
}
@ -60,6 +87,8 @@ ChkReadln(arg)
{
struct node *file;
char *name = "readln";
char *message, buff[80];
extern char *ChkAllowedVar();
if( !arg ) {
if( !(file = ChkStdInOut(name, 0)) )
@ -95,6 +124,13 @@ ChkReadln(arg)
"\"%s\": illegal parameter type",name);
return;
}
message = ChkAllowedVar(arg->nd_left, 1);
if( message ) {
sprint(buff,"\"%%s\": %s can't be a variable parameter",
message);
node_error(arg->nd_left, buff, name);
return;
}
CodeRead(file, arg->nd_left);
arg = arg->nd_right;
}
@ -203,8 +239,9 @@ ChkWriteParameter(filetype, arg, name)
tp = BaseType(arg->nd_left->nd_type);
if( filetype == text_type ) {
if( !(tp == bool_type || tp->tp_fund & (T_CHAR | T_NUMERIC) ||
IsString(tp)) ) {
if( !(tp == bool_type ||
tp->tp_fund & (T_CHAR | T_NUMERIC | T_STRING) ||
IsString(tp)) ) {
node_error(arg->nd_left, "\"%s\": %s", name, mess);
return 0;
}
@ -259,8 +296,9 @@ ChkStdInOut(name, st_out)
register struct def *df;
register struct node *nd;
if( !(df = lookup(str2idf(st_out ? output : input, 0), GlobalScope)) ||
!(df->df_flags & D_PROGPAR) ) {
if( !(df = lookup(str2idf(st_out ? output : input, 0),
GlobalScope, D_INUSE)) ||
!(df->df_flags & D_PROGPAR) ) {
error("\"%s\": standard input/output not defined", name);
return NULLNODE;
}
@ -268,6 +306,7 @@ ChkStdInOut(name, st_out)
nd = MkLeaf(Def, &dot);
nd->nd_def = df;
nd->nd_type = df->df_type;
df->df_flags |= D_USED;
return nd;
}
@ -291,6 +330,10 @@ CodeRead(file, arg)
C_cal("_rdi");
break;
case T_LONG:
C_cal("_rdl");
break;
case T_REAL:
C_cal("_rdr");
break;
@ -314,9 +357,11 @@ CodeRead(file, arg)
RangeCheck(arg->nd_type, file->nd_type->next);
C_loi(file->nd_type->next->tp_psize);
if( BaseType(file->nd_type->next) == int_type &&
tp == real_type )
Int2Real();
if( tp == real_type ) {
if( BaseType(file->nd_type->next) == int_type ||
BaseType(file->nd_type->next) == long_type )
Int2Real(file->nd_type->next->tp_psize);
}
CodeDStore(arg);
C_cal("_get");
@ -349,7 +394,7 @@ CodeWrite(file, arg)
CodePExpr(expp);
if( file->nd_type == text_type ) {
if( tp->tp_fund & (T_ARRAY | T_STRING) ) {
if( tp->tp_fund & (T_ARRAY | T_STRINGCONST) ) {
C_loc(IsString(tp));
nbpars += pointer_size + int_size;
}
@ -375,6 +420,10 @@ CodeWrite(file, arg)
C_cal(width ? "_wsi" : "_wri");
break;
case T_LONG:
C_cal(width ? "_wsl" : "_wrl");
break;
case T_REAL:
if( right ) {
CodePExpr(right->nd_left);
@ -385,19 +434,25 @@ CodeWrite(file, arg)
break;
case T_ARRAY:
case T_STRING:
case T_STRINGCONST:
C_cal(width ? "_wss" : "_wrs");
break;
case T_STRING:
C_cal(width ? "_wsz" : "_wrz");
break;
default:
crash("CodeWrite)");
crash("(CodeWrite)");
/*NOTREACHED*/
}
C_asp(nbpars);
}
else {
if( file->nd_type->next == real_type && tp == int_type )
Int2Real();
Int2Real(int_size);
else if( file->nd_type->next == real_type && tp == long_type )
Int2Real(long_size);
CodeDAddress(file);
C_cal("_wdw");

43
lang/pc/comp/required.h
View file

@ -11,33 +11,38 @@
/* DYNAMIC ALLOCATION */
#define R_NEW 6
#define R_DISPOSE 7
#define R_MARK 8
#define R_RELEASE 9
/* MISCELLANEOUS PROCEDURE(S) */
#define R_HALT 10
/* TRANSFER */
#define R_PACK 8
#define R_UNPACK 9
#define R_PACK 11
#define R_UNPACK 12
/* FUNCTIONS */
/* ARITHMETIC */
#define R_ABS 10
#define R_SQR 11
#define R_SIN 12
#define R_COS 13
#define R_EXP 14
#define R_LN 15
#define R_SQRT 16
#define R_ARCTAN 17
#define R_ABS 13
#define R_SQR 14
#define R_SIN 15
#define R_COS 16
#define R_EXP 17
#define R_LN 18
#define R_SQRT 19
#define R_ARCTAN 20
/* TRANSFER */
#define R_TRUNC 18
#define R_ROUND 19
#define R_TRUNC 21
#define R_ROUND 22
/* ORDINAL */
#define R_ORD 20
#define R_CHR 21
#define R_SUCC 22
#define R_PRED 23
#define R_ORD 23
#define R_CHR 24
#define R_SUCC 25
#define R_PRED 26
/* BOOLEAN */
#define R_ODD 24
#define R_EOF 25
#define R_EOLN 26
#define R_ODD 27
#define R_EOF 28
#define R_EOLN 29

2
lang/pc/comp/scope.c
View file

@ -80,7 +80,7 @@ chk_prog_params()
if( df->df_kind & D_PARAMETER ) {
if( !is_anon_idf(df->df_idf) ) {
if( df->df_type == error_type )
error("program parameter \"%s\" must be a global variable",
error("program parameter \"%s\" must be a global variable",
df->df_idf->id_text);
else if( df->df_type->tp_fund != T_FILE )
error("program parameter \"%s\" must have a file type",

19
lang/pc/comp/statement.g
View file

@ -7,8 +7,10 @@
#include "chk_expr.h"
#include "def.h"
#include "desig.h"
#include "f_info.h"
#include "idf.h"
#include "main.h"
#include "misc.h"
#include "node.h"
#include "scope.h"
#include "type.h"
@ -57,11 +59,14 @@ Statement
SimpleStatement
{
struct node *pnd, *expp;
unsigned short line;
} :
/* This is a changed rule, because the grammar as specified in the
* reference is not LL(1), and this gives conflicts.
* Note : the grammar states : AssignmentStatement |
* ProcedureStatement | ...
* In order to add assertions, there is an extra entry, which gives
* a conflict. This conflict is then resolved using an %if clause.
*/
EmptyStatement
|
@ -69,13 +74,20 @@ SimpleStatement
|
/* Evidently this is the beginning of the changed part
*/
%if( !options['s'] && !strcmp(dot.TOK_IDF->id_text, "assert") )
IDENT { line = LineNumber; }
Expression(&expp)
{ AssertStat(expp, line); }
|
IDENT { pnd = MkLeaf(Name, &dot); }
[
[ %default
/* At this point the IDENT can be a FunctionIdentifier in
* which case the VariableAccessTail must be empty.
*/
VariableAccessTail(&pnd)
[
%default
BECOMES
|
'=' { error("':=' expected instead of '='"); }
@ -92,6 +104,7 @@ SimpleStatement
FreeNode(pnd);
}
]
|
InputOutputStatement
@ -353,6 +366,7 @@ ForStatement
Statement
{ if( !err_occurred )
CodeEndFor(nd, stepsize, l1, l2, tmp2);
EndForStat(nd);
chk_labels(slevel + 1);
FreeNode(nd);
if( tmp1 ) FreeInt(tmp1);
@ -415,6 +429,7 @@ WriteParameter(register struct node **pnd;)
Expression(pnd)
{ if( !ChkExpression(*pnd) )
(*pnd)->nd_type = error_type;
MarkUsed(*pnd);
*pnd = nd =
MkNode(Link, *pnd, NULLNODE, &dot);
nd->nd_symb = ':';
@ -428,6 +443,7 @@ WriteParameter(register struct node **pnd;)
Expression(&(nd->nd_left))
{ if( !ChkExpression(nd->nd_left) )
nd->nd_left->nd_type = error_type;
MarkUsed(nd->nd_left);
}
[
':' { nd->nd_right = MkLeaf(Link, &dot);
@ -436,6 +452,7 @@ WriteParameter(register struct node **pnd;)
Expression(&(nd->nd_left))
{ if( !ChkExpression(nd->nd_left) )
nd->nd_left->nd_type = error_type;
MarkUsed(nd->nd_left);
}
]?
]?

35
lang/pc/comp/type.H
View file

@ -77,17 +77,19 @@ struct type {
#define T_PROCEDURE 0x0010
#define T_FUNCTION 0x0020
#define T_FILE 0x0040
#define T_STRING 0x0080
#define T_STRINGCONST 0x0080
#define T_SUBRANGE 0x0100
#define T_SET 0x0200
#define T_ARRAY 0x0400
#define T_RECORD 0x0800
#define T_POINTER 0x1000
#define T_ERROR 0x2000 /* bad type */
#define T_NUMERIC (T_INTEGER | T_REAL)
#define T_INDEX (T_SUBRANGE | T_ENUMERATION | T_CHAR)
#define T_ORDINAL (T_INTEGER | T_INDEX)
#define T_CONSTRUCTED (T_ARRAY | T_SET | T_RECORD | T_FILE | T_STRING)
#define T_LONG 0x2000
#define T_STRING 0x4000
#define T_ERROR 0x8000 /* bad type */
#define T_NUMERIC (T_INTEGER | T_REAL | T_LONG)
#define T_INDEX (T_SUBRANGE | T_ENUMERATION | T_CHAR | T_INTEGER )
#define T_ORDINAL (T_INDEX | T_LONG)
#define T_CONSTRUCTED (T_ARRAY | T_SET | T_RECORD | T_FILE | T_STRINGCONST)
#define T_ROUTINE (T_FUNCTION | T_PROCEDURE)
unsigned short tp_flags;
#define T_HASFILE 0x1 /* set if type has a filecomponent */
@ -112,16 +114,35 @@ extern struct type
*bool_type,
*char_type,
*int_type,
*long_type,
*real_type,
*string_type,
*std_type,
*text_type,
*nil_type,
*emptyset_type,
*error_type; /* All from type.c */
#include "nocross.h"
#ifdef NOCROSS
#include "target_sizes.h"
#define word_align (AL_WORD)
#define int_align (AL_INT)
#define long_align (AL_LONG)
#define pointer_align (AL_POINTER)
#define real_align (AL_REAL)
#define struct_align (AL_STRUCT)
#define word_size (SZ_WORD)
#define int_size (SZ_INT)
#define long_size (SZ_LONG)
#define pointer_size (SZ_POINTER)
#define real_size (SZ_REAL)
#else NOCROSS
extern int
word_align,
int_align,
long_align,
pointer_align,
real_align,
struct_align; /* All from type.c */
@ -129,8 +150,10 @@ extern int
extern arith
word_size,
int_size,
long_size,
pointer_size,
real_size; /* All from type.c */
#endif NOCROSS
extern arith
align();

117
lang/pc/comp/type.c
View file

@ -1,7 +1,6 @@
/* T Y P E D E F I N I T I O N M E C H A N I S M */
#include "debug.h"
#include "target_sizes.h"
#include <alloc.h>
#include <assert.h>
@ -18,9 +17,12 @@
#include "scope.h"
#include "type.h"
#ifndef NOCROSS
#include "target_sizes.h"
int
word_align = AL_WORD,
int_align = AL_INT,
long_align = AL_LONG,
pointer_align = AL_POINTER,
real_align = AL_REAL,
struct_align = AL_STRUCT;
@ -28,29 +30,63 @@ int
arith
word_size = SZ_WORD,
int_size = SZ_INT,
long_size = SZ_LONG,
pointer_size = SZ_POINTER,
real_size = SZ_REAL;
#endif NOCROSS
extern arith max_int;
struct type
*bool_type,
*char_type,
*int_type,
*long_type,
*real_type,
*string_type,
*std_type,
*text_type,
*nil_type,
*emptyset_type,
*error_type;
InitTypes()
CheckTypeSizes()
{
/* Initialize the predefined types
*/
/* first, do some checking
*/
if( int_size != word_size )
fatal("integer size not equal to word size");
if( word_size != 2 && word_size != 4 )
fatal("illegal wordsize");
if( pointer_size != 2 && pointer_size != 4 )
fatal("illegal pointersize");
if( options['d'] ) {
if( long_size < int_size )
fatal("longsize should be at least the integersize");
if( long_size > 2 * int_size)
fatal("longsize should be at most twice the integersize");
}
if( pointer_size < word_size )
fatal("pointersize should be at least the wordsize");
if( real_size != 4 && real_size != 8 )
fatal("illegal realsize");
}
InitTypes()
{
/* First check the sizes of some basic EM-types
*/
CheckTypeSizes();
if( options['s'] ) {
options['c'] = 0;
options['d'] = 0;
options['u'] = 0;
options['C'] = 0;
options['U'] = 0;
}
/* Initialize the predefined types
*/
/* character type
*/
@ -70,6 +106,16 @@ InitTypes()
*/
real_type = standard_type(T_REAL, real_align, real_size);
/* long type
*/
if( options['d'] )
long_type = standard_type(T_LONG, long_align, long_size);
/* string type
*/
if( options['c'] )
string_type = standard_type(T_STRING, pointer_align, pointer_size);
/* an unique type for standard procedures and functions
*/
std_type = construct_type(T_PROCEDURE, NULLTYPE);
@ -94,6 +140,13 @@ InitTypes()
emptyset_type->tp_align = word_align;
}
int
fit(sz, nbytes)
arith sz;
{
return ((sz) + ((arith)0x80<<(((nbytes)-1)*8)) & ~full_mask[(nbytes)]) == 0;
}
struct type *
standard_type(fund, algn, size)
arith size;
@ -184,19 +237,24 @@ chk_type_id(ptp, nd)
register struct type **ptp;
register struct node *nd;
{
register struct def *df;
*ptp = error_type;
if( ChkLinkOrName(nd) ) {
if( nd->nd_class != Def )
node_error(nd, "type expected");
else {
register struct def *df = nd->nd_def;
/* register struct def *df = nd->nd_def; */
df = nd->nd_def;
if( df->df_kind & (D_TYPE | D_FTYPE | D_ERROR) )
df->df_flags |= D_USED;
if( df->df_kind & (D_TYPE | D_FTYPE | D_ERROR) ) {
if( !df->df_type )
node_error(nd, "type \"%s\" not declared",
df->df_idf->id_text);
else
*ptp = df->df_type;
}
else
node_error(nd,"identifier \"%s\" is not a type",
df->df_idf->id_text);
@ -253,7 +311,11 @@ getbounds(tp, plo, phi)
*plo = tp->sub_lb;
*phi = tp->sub_ub;
}
else {
else if( tp->tp_fund & T_INTEGER ) {
*plo = -max_int;
*phi = max_int;
}
else {
*plo = 0;
*phi = tp->enm_ncst - 1;
}
@ -350,7 +412,10 @@ ArrayElSize(tp, packed)
/* algn is not a dividor of the word size, so make sure it
is a multiple
*/
return WA(algn);
algn = WA(algn);
}
if( !fit(algn, (int) word_size) ) {
error("element of array too large");
}
return algn;
}
@ -362,10 +427,10 @@ ArraySizes(tp)
*/
register struct type *index_type = IndexType(tp);
register struct type *elem_type = tp->arr_elem;
arith lo, hi;
arith lo, hi, diff;
tp->tp_flags |= T_CHECKED;
tp->arr_elsize = ArrayElSize(elem_type, IsPacked(tp));
tp->arr_elsize = ArrayElSize(elem_type,(int) IsPacked(tp));
/* check index type
*/
@ -378,8 +443,17 @@ ArraySizes(tp)
}
getbounds(index_type, &lo, &hi);
diff = hi - lo;
tp->tp_psize = (hi - lo + 1) * tp->arr_elsize;
if( diff < 0 || !fit(diff, (int) word_size) ) {
error("too many elements in array");
}
if( (unsigned long)full_mask[(int) pointer_size]/(diff + 1) <
tp->arr_elsize ) {
error("array too large");
}
tp->tp_psize = (diff + 1) * tp->arr_elsize;
tp->tp_palign = (word_size % tp->tp_psize) ? word_align : tp->tp_psize;
tp->tp_size = WA(tp->tp_psize);
tp->tp_align = word_align;
@ -389,7 +463,7 @@ ArraySizes(tp)
tp->arr_ardescr = ++data_label;
C_df_dlb(data_label);
C_rom_cst(lo);
C_rom_cst(hi - lo);
C_rom_cst(diff);
C_rom_cst(tp->arr_elsize);
}
@ -424,14 +498,15 @@ chk_forw_types()
while( scl ) {
/* look in enclosing scopes */
df1 = lookup(df->df_fortype->f_node->nd_IDF,
scl->sc_scope);
scl->sc_scope, D_INUSE);
if( df1 ) break;
scl = nextvisible( scl );
}
if( !df1 || df1->df_kind != D_TYPE )
if( !df1 || df1->df_kind != D_TYPE ) {
/* bad forward type */
tp = error_type;
}
else { /* ok */
tp = df1->df_type;
@ -440,6 +515,9 @@ chk_forw_types()
CurrentScope->sc_def = df->df_nextinscope;
else
ldf->df_nextinscope = df->df_nextinscope;
/* remove the def struct from symbol-table */
remove_def(df);
}
}
else /* forward type was resolved */
@ -455,6 +533,7 @@ chk_forw_types()
}
FreeForward( df->df_fortype );
df->df_flags |= D_USED;
if( tp == error_type )
df->df_kind = D_ERROR;
else
@ -540,10 +619,14 @@ DumpType(tp)
print("ENUMERATION; ncst:%d", tp->enm_ncst); break;
case T_INTEGER:
print("INTEGER"); break;
case T_LONG:
print("LONG"); break;
case T_REAL:
print("REAL"); break;
case T_CHAR:
print("CHAR"); break;
case T_STRING:
print("STRING"); break;
case T_PROCEDURE:
case T_FUNCTION:
{
@ -565,8 +648,8 @@ DumpType(tp)
}
case T_FILE:
print("FILE"); break;
case T_STRING:
print("STRING"); break;
case T_STRINGCONST:
print("STRINGCONST"); break;
case T_SUBRANGE:
print("SUBRANGE %ld-%ld", (long) tp->sub_lb, (long) tp->sub_ub);
break;

17
lang/pc/comp/typequiv.c
View file

@ -21,7 +21,6 @@ TstTypeEquiv(tp1, tp2)
{
/* test if two types are equivalent.
*/
return tp1 == tp2 || tp1 == error_type || tp2 == error_type;
}
@ -30,7 +29,7 @@ IsString(tp)
register struct type *tp;
{
/* string = packed array[1..ub] of char and ub > 1 */
if( tp->tp_fund & T_STRING ) return tp->tp_psize;
if( tp->tp_fund & T_STRINGCONST ) return tp->tp_psize;
if( IsConformantArray(tp) ) return 0;
@ -94,6 +93,13 @@ TstCompat(tp1, tp2)
else return 0;
}
/* no clause, just check for longs and ints */
/* BaseType is used in case of array indexing */
if ((BaseType(tp1) == int_type && tp2 == long_type) ||
(tp1 == long_type && tp2 == int_type))
return 1;
/* clause b */
tp1 = BaseType(tp1);
tp2 = BaseType(tp2);
@ -114,7 +120,7 @@ TstAssCompat(tp1, tp2)
/* clause b */
if( tp1 == real_type )
return BaseType(tp2) == int_type;
return BaseType(tp2) == int_type || BaseType(tp2) == long_type;
return 0;
}
@ -247,7 +253,7 @@ TstConform(formaltype, actualtype, new_par_section)
lastactual = actualtype;
if( actualtype->tp_fund == T_STRING ) {
if( actualtype->tp_fund == T_STRINGCONST ) {
actualindextp = int_type;
alb = 1;
aub = actualtype->tp_psize;
@ -271,7 +277,8 @@ TstConform(formaltype, actualtype, new_par_section)
return 0;
/* clause (b) */
if( bounded(actualindextp) || actualindextp->tp_fund == T_STRING ) {
if( bounded(actualindextp) ||
actualindextp->tp_fund == T_STRINGCONST ) {
/* test was necessary because the actual type could be confor-
mant !!
*/