godzil/ack
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fixup commit for tag 'distr3'

Browse Source
This commit is contained in:
cvs2hg
1989-10-04 10:56:17 +00:00
parent 81b1d21c35
commit 42e84d8dd2
230 changed files with 71 additions and 31971 deletions
Download Patch File Download Diff File Expand all files Collapse all files

3
lang/cem/.distr Normal file
View File

@@ -0,0 +1,3 @@
cemcom
ctest
libcc

88
lang/cem/cemcom/Files
View File

@@ -1,88 +0,0 @@
Files
cem.1
cem.c
cemcom.1
Parameters
Makefile
LLlex.c
LLlex.h
LLmessage.c
align.h
alloc.c
alloc.h
arith.c
arith.h
asm.c
assert.h
atw.h
blocks.c
char.tab
ch7.c
ch7bin.c
ch7mon.c
class.h
code.c
code.str
conversion.c
cstoper.c
dataflow.c
declar.g
declarator.c
declar.str
decspecs.c
decspecs.str
def.str
domacro.c
dumpidf.c
error.c
eval.c
expr.c
expr.str
expression.g
faulty.h
field.c
field.str
file_info.h
idf.c
idf.str
init.c
input.c
input.h
interface.h
ival.c
label.c
label.h
level.h
macro.str
main.c
make.allocd
make.hfiles
make.next
make.tokcase
make.tokfile
mcomm.c
mes.h
options
options.c
program.g
replace.c
scan.c
sizes.h
skip.c
specials.h
stack.c
stack.str
statement.g
stb.c
storage.c
storage.h
stmt.str
struct.c
struct.str
switch.c
switch.str
tab.c
tokenname.c
tokenname.h
type.c
type.str

799
lang/cem/cemcom/Makefile.erik
View File

@@ -1,799 +0,0 @@
# $Header$
# M A K E F I L E F O R A C K C - C O M P I L E R
# Machine and environ dependent definitions
EMHOME = /usr/em# # ACK tree on this machine
DESTINATION = /user1/$$USER/bin# # where to put the stuff
MKDEP = $(EMHOME)/bin/mkdep# # dependency generator
MAP =
#MAP = -DInsertFile=ins_file -DInsertText=ins_text# bug in m68k2 back end
SIM = /user1/dick/bin/sim# # Dicks sim program
LINT = /usr/new/lint
# Libraries and EM interface definitions
SYSLIB = $(EMHOME)/modules/lib/libsystem.a
EMKLIB = $(EMHOME)/modules/lib/libemk.a
EMELIB = $(EMHOME)/modules/lib/libeme.a
STRLIB = $(EMHOME)/modules/lib/libstring.a
PRTLIB = $(EMHOME)/modules/lib/libprint.a
EMMESLIB = $(EMHOME)/modules/lib/libem_mes.a
INPLIB = $(EMHOME)/modules/lib/libinput.a
ALLOCLIB = $(EMHOME)/modules/lib/liballoc.a
MALLOC = $(EMHOME)/modules/lib/malloc.o
#CH3LIB = $(EMHOME)/modules/lib/libch3.a
CH3LIB =
LIBS = $(INPLIB) $(CH3LIB) $(EMMESLIB) $(EMKLIB) \
$(PRTLIB) $(STRLIB) $(ALLOCLIB) $(MALLOC) $(SYSLIB)
ELIBS = $(INPLIB) $(CH3LIB) $(EMMESLIB) $(EMELIB) \
$(PRTLIB) $(STRLIB) $(ALLOCLIB) $(MALLOC) $(SYSLIB)
LIB_INCLUDES = -I$(EMHOME)/modules/h -I$(EMHOME)/modules/pkg
EM_INCLUDES = -I$(EMHOME)/h
SYSLLIB = $(EMHOME)/modules/lib/llib-lsys.ln
EMKLLIB = $(EMHOME)/modules/lib/llib-lemk.ln
EMELLIB = $(EMHOME)/modules/lib/llib-leme.ln
STRLLIB = $(EMHOME)/modules/lib/llib-lstr.ln
PRTLLIB = $(EMHOME)/modules/lib/llib-lprint.ln
EMMESLLIB = $(EMHOME)/modules/lib/llib-lmes.ln
INPLLIB = $(EMHOME)/modules/lib/llib-linput.ln
CH3LLIB = $(EMHOME)/modules/lib/llib-lch3.ln
ALLOCLLIB = $(EMHOME)/modules/lib/llib-alloc.ln
LINTLIBS =
#LINTLIBS = $(CH3LLIB) $(INPLLIB) $(EMMESLLIB) $(EMKLLIB) \
# $(PRTLLIB) $(STRLLIB) $(SYSLLIB) $(ALLOCLLIB)
# Where to install the compiler and its driver
CEMCOM = $(DESTINATION)/cemcom
DRIVER = $(DESTINATION)/cem
# What C compiler to use and how
# CC = $(ACK) -.c
# CC = CC
# CC = /bin/cc
COPTIONS =
# What parser generator to use and how
GEN = $(EMHOME)/bin/LLgen
GENOPTIONS = -vv
# Special #defines during compilation
CDEFS = $(MAP) $(EM_INCLUDES) $(LIB_INCLUDES)
CFLAGS = $(CDEFS) $(COPTIONS) -O# we cannot pass the COPTIONS to lint!
# Grammar files and their objects
LSRC = tokenfile.g declar.g statement.g expression.g program.g ival.g
GLCSRC = tokenfile.c declar.c statement.c expression.c program.c ival.c
LOBJ = tokenfile.o declar.o statement.o expression.o program.o Lpars.o ival.o
# Objects of hand-written C files
COBJ = main.o idf.o declarator.o decspecs.o struct.o \
expr.o ch7.o ch7bin.o cstoper.o arith.o \
asm.o code.o dumpidf.o error.o field.o\
tokenname.o LLlex.o LLmessage.o \
input.o domacro.o replace.o init.o options.o \
scan.o skip.o stack.o type.o ch7mon.o label.o eval.o \
switch.o conversion.o \
blocks.o dataflow.o Version.o
# Objects of other generated C files
GOBJ = char.o symbol2str.o next.o
# generated source files
GSRC = char.c symbol2str.c next.c \
code.h declar.h decspecs.h def.h expr.h field.h estack.h \
idf.h macro.h stack.h stmt.h struct.h switch.h type.h
# .h files generated by `make hfiles'; PLEASE KEEP THIS UP-TO-DATE!
GHSRC = botch_free.h dataflow.h debug.h density.h errout.h \
idfsize.h ifdepth.h inputtype.h inumlength.h lapbuf.h \
maxincl.h nobitfield.h nofloat.h nopp.h noRoption.h nocross.h \
nparams.h numsize.h parbufsize.h pathlength.h \
strsize.h target_sizes.h textsize.h use_tmp.h spec_arith.h static.h
# Other generated files, for 'make clean' only
GENERATED = tab tokenfile.g Lpars.h LLfiles LL.output lint.out \
print Xref lxref hfiles cfiles $(GLCSRC)
# include files containing ALLOCDEF specifications
NEXTFILES = code.str declar.str decspecs.str def.str expr.str field.str \
estack.str \
idf.str macro.str stack.str stmt.str struct.str switch.str type.str
.SUFFIXES: .str .h
.str.h:
./make.allocd <$*.str >$*.h
all: cc
cc:
make "CC=$(CC)" hfiles
make "CC=$(CC)" LLfiles
make "CC=$(CC)" main
cem: cem.c
$(CC) -O cem.c $(SYSLIB) -o cem
lint.cem: cem.c
$(LINT) -bx cem.c
hfiles: ./make.hfiles Parameters
./make.hfiles Parameters
@touch hfiles
LLfiles: $(LSRC)
$(GEN) $(GENOPTIONS) $(LSRC)
@touch LLfiles
tokenfile.g: tokenname.c make.tokfile
<tokenname.c ./make.tokfile >tokenfile.g
symbol2str.c: tokenname.c make.tokcase
<tokenname.c ./make.tokcase >symbol2str.c
char.c: tab char.tab
tab -fchar.tab >char.c
next.c: make.next $(NEXTFILES)
./make.next $(NEXTFILES) >next.c
code.h: make.allocd
declar.h: make.allocd
decspecs.h: make.allocd
def.h: make.allocd
estack.h: make.allocd
expr.h: make.allocd
field.h: make.allocd
idf.h: make.allocd
macro.h: make.allocd
stack.h: make.allocd
stmt.h: make.allocd
struct.h: make.allocd
switch.h: make.allocd
type.h: make.allocd
# Objects needed for 'main'
OBJ = $(COBJ) $(LOBJ) $(GOBJ)
main: $(OBJ) Makefile
$(CC) $(COPTIONS) $(LFLAGS) $(OBJ) $(LIBS) -o main
size main
emain: $(OBJ) Makefile
$(CC) $(COPTIONS) $(LFLAGS) $(OBJ) $(ELIBS) -o emain
size emain
cfiles: hfiles LLfiles $(GSRC)
@touch cfiles
install: main cem
cp main $(CEMCOM)
cp cem $(DRIVER)
print: files
pr `cat files` > print
tags: cfiles
ctags `sources $(OBJ)`
shar: files
shar `cat files`
listcfiles:
@echo `sources $(OBJ)`
listobjects:
@echo $(OBJ)
depend: cfiles
sed '/^#AUTOAUTO/,$$d' Makefile >Makefile.new
echo '#AUTOAUTOAUTOAUTOAUTOAUTOAUTOAUTOAUTOAUTO' >>Makefile.new
$(MKDEP) `sources $(OBJ)` | sed 's/\.c:/.o:/' >>Makefile.new
mv Makefile Makefile.old
mv Makefile.new Makefile
xref:
ctags -x `grep "\.[ch]" files`|sed "s/).*/)/">Xref
lxref:
lxref $(OBJ) -lc >lxref
lint: lint.main lint.cem lint.tab
lint.main: cfiles
$(LINT) -bx $(CDEFS) `sources $(OBJ)` $(LINTLIBS) >lint.out
cchk:
cchk `sources $(COBJ)`
clean:
rm -f `sources $(LOBJ)` $(OBJ) $(GENERATED) $(GSRC) $(GHSRC)
tab:
$(CC) tab.c -o tab
lint.tab:
$(LINT) -abx tab.c
sim: cfiles
$(SIM) $(SIMFLAGS) `sources $(COBJ)` $(GSRC) $(LSRC)
#AUTOAUTOAUTOAUTOAUTOAUTOAUTOAUTOAUTOAUTO
main.o: LLlex.h
main.o: Lpars.h
main.o: align.h
main.o: arith.h
main.o: debug.h
main.o: declar.h
main.o: file_info.h
main.o: idf.h
main.o: input.h
main.o: inputtype.h
main.o: level.h
main.o: maxincl.h
main.o: noRoption.h
main.o: nobitfield.h
main.o: nocross.h
main.o: nofloat.h
main.o: nopp.h
main.o: sizes.h
main.o: spec_arith.h
main.o: specials.h
main.o: target_sizes.h
main.o: tokenname.h
main.o: type.h
main.o: use_tmp.h
idf.o: LLlex.h
idf.o: Lpars.h
idf.o: align.h
idf.o: arith.h
idf.o: assert.h
idf.o: botch_free.h
idf.o: debug.h
idf.o: declar.h
idf.o: decspecs.h
idf.o: def.h
idf.o: file_info.h
idf.o: idf.h
idf.o: idfsize.h
idf.o: label.h
idf.o: level.h
idf.o: noRoption.h
idf.o: nobitfield.h
idf.o: nocross.h
idf.o: nofloat.h
idf.o: nopp.h
idf.o: sizes.h
idf.o: spec_arith.h
idf.o: specials.h
idf.o: stack.h
idf.o: struct.h
idf.o: target_sizes.h
idf.o: type.h
declarator.o: Lpars.h
declarator.o: arith.h
declarator.o: botch_free.h
declarator.o: declar.h
declarator.o: expr.h
declarator.o: idf.h
declarator.o: label.h
declarator.o: nobitfield.h
declarator.o: nocross.h
declarator.o: nofloat.h
declarator.o: nopp.h
declarator.o: sizes.h
declarator.o: spec_arith.h
declarator.o: target_sizes.h
declarator.o: type.h
decspecs.o: Lpars.h
decspecs.o: arith.h
decspecs.o: decspecs.h
decspecs.o: def.h
decspecs.o: level.h
decspecs.o: noRoption.h
decspecs.o: nobitfield.h
decspecs.o: nofloat.h
decspecs.o: spec_arith.h
decspecs.o: type.h
struct.o: LLlex.h
struct.o: Lpars.h
struct.o: align.h
struct.o: arith.h
struct.o: assert.h
struct.o: botch_free.h
struct.o: debug.h
struct.o: def.h
struct.o: field.h
struct.o: file_info.h
struct.o: idf.h
struct.o: level.h
struct.o: noRoption.h
struct.o: nobitfield.h
struct.o: nocross.h
struct.o: nofloat.h
struct.o: nopp.h
struct.o: sizes.h
struct.o: spec_arith.h
struct.o: stack.h
struct.o: struct.h
struct.o: target_sizes.h
struct.o: type.h
expr.o: LLlex.h
expr.o: Lpars.h
expr.o: arith.h
expr.o: botch_free.h
expr.o: declar.h
expr.o: decspecs.h
expr.o: def.h
expr.o: expr.h
expr.o: file_info.h
expr.o: idf.h
expr.o: label.h
expr.o: level.h
expr.o: noRoption.h
expr.o: nobitfield.h
expr.o: nocross.h
expr.o: nofloat.h
expr.o: nopp.h
expr.o: sizes.h
expr.o: spec_arith.h
expr.o: target_sizes.h
expr.o: type.h
ch7.o: Lpars.h
ch7.o: arith.h
ch7.o: assert.h
ch7.o: debug.h
ch7.o: def.h
ch7.o: expr.h
ch7.o: idf.h
ch7.o: label.h
ch7.o: nobitfield.h
ch7.o: nofloat.h
ch7.o: nopp.h
ch7.o: spec_arith.h
ch7.o: struct.h
ch7.o: type.h
ch7bin.o: Lpars.h
ch7bin.o: arith.h
ch7bin.o: botch_free.h
ch7bin.o: expr.h
ch7bin.o: idf.h
ch7bin.o: label.h
ch7bin.o: noRoption.h
ch7bin.o: nobitfield.h
ch7bin.o: nofloat.h
ch7bin.o: nopp.h
ch7bin.o: spec_arith.h
ch7bin.o: struct.h
ch7bin.o: type.h
cstoper.o: Lpars.h
cstoper.o: arith.h
cstoper.o: assert.h
cstoper.o: debug.h
cstoper.o: expr.h
cstoper.o: idf.h
cstoper.o: label.h
cstoper.o: nobitfield.h
cstoper.o: nocross.h
cstoper.o: nofloat.h
cstoper.o: nopp.h
cstoper.o: sizes.h
cstoper.o: spec_arith.h
cstoper.o: target_sizes.h
cstoper.o: type.h
arith.o: Lpars.h
arith.o: arith.h
arith.o: botch_free.h
arith.o: expr.h
arith.o: field.h
arith.o: idf.h
arith.o: label.h
arith.o: mes.h
arith.o: noRoption.h
arith.o: nobitfield.h
arith.o: nofloat.h
arith.o: nopp.h
arith.o: spec_arith.h
arith.o: type.h
code.o: LLlex.h
code.o: Lpars.h
code.o: align.h
code.o: arith.h
code.o: assert.h
code.o: atw.h
code.o: botch_free.h
code.o: code.h
code.o: dataflow.h
code.o: debug.h
code.o: declar.h
code.o: decspecs.h
code.o: def.h
code.o: expr.h
code.o: file_info.h
code.o: idf.h
code.o: label.h
code.o: level.h
code.o: mes.h
code.o: noRoption.h
code.o: nobitfield.h
code.o: nocross.h
code.o: nofloat.h
code.o: nopp.h
code.o: sizes.h
code.o: spec_arith.h
code.o: specials.h
code.o: stack.h
code.o: stmt.h
code.o: target_sizes.h
code.o: type.h
code.o: use_tmp.h
dumpidf.o: Lpars.h
dumpidf.o: arith.h
dumpidf.o: debug.h
dumpidf.o: def.h
dumpidf.o: expr.h
dumpidf.o: field.h
dumpidf.o: idf.h
dumpidf.o: label.h
dumpidf.o: nobitfield.h
dumpidf.o: nofloat.h
dumpidf.o: nopp.h
dumpidf.o: spec_arith.h
dumpidf.o: stack.h
dumpidf.o: static.h
dumpidf.o: struct.h
dumpidf.o: type.h
error.o: LLlex.h
error.o: arith.h
error.o: debug.h
error.o: errout.h
error.o: expr.h
error.o: file_info.h
error.o: label.h
error.o: nofloat.h
error.o: nopp.h
error.o: spec_arith.h
error.o: tokenname.h
error.o: use_tmp.h
field.o: Lpars.h
field.o: arith.h
field.o: assert.h
field.o: code.h
field.o: debug.h
field.o: expr.h
field.o: field.h
field.o: idf.h
field.o: label.h
field.o: nobitfield.h
field.o: nocross.h
field.o: nofloat.h
field.o: nopp.h
field.o: sizes.h
field.o: spec_arith.h
field.o: target_sizes.h
field.o: type.h
tokenname.o: LLlex.h
tokenname.o: Lpars.h
tokenname.o: arith.h
tokenname.o: file_info.h
tokenname.o: idf.h
tokenname.o: nofloat.h
tokenname.o: nopp.h
tokenname.o: spec_arith.h
tokenname.o: tokenname.h
LLlex.o: LLlex.h
LLlex.o: Lpars.h
LLlex.o: arith.h
LLlex.o: assert.h
LLlex.o: class.h
LLlex.o: debug.h
LLlex.o: def.h
LLlex.o: file_info.h
LLlex.o: idf.h
LLlex.o: idfsize.h
LLlex.o: input.h
LLlex.o: nocross.h
LLlex.o: nofloat.h
LLlex.o: nopp.h
LLlex.o: numsize.h
LLlex.o: sizes.h
LLlex.o: spec_arith.h
LLlex.o: strsize.h
LLlex.o: target_sizes.h
LLmessage.o: LLlex.h
LLmessage.o: Lpars.h
LLmessage.o: arith.h
LLmessage.o: file_info.h
LLmessage.o: idf.h
LLmessage.o: nofloat.h
LLmessage.o: nopp.h
LLmessage.o: spec_arith.h
input.o: file_info.h
input.o: input.h
input.o: inputtype.h
input.o: nopp.h
domacro.o: LLlex.h
domacro.o: Lpars.h
domacro.o: arith.h
domacro.o: assert.h
domacro.o: botch_free.h
domacro.o: class.h
domacro.o: debug.h
domacro.o: file_info.h
domacro.o: idf.h
domacro.o: idfsize.h
domacro.o: ifdepth.h
domacro.o: input.h
domacro.o: interface.h
domacro.o: macro.h
domacro.o: nofloat.h
domacro.o: nopp.h
domacro.o: nparams.h
domacro.o: parbufsize.h
domacro.o: spec_arith.h
domacro.o: textsize.h
replace.o: LLlex.h
replace.o: arith.h
replace.o: assert.h
replace.o: class.h
replace.o: debug.h
replace.o: file_info.h
replace.o: idf.h
replace.o: input.h
replace.o: interface.h
replace.o: macro.h
replace.o: nofloat.h
replace.o: nopp.h
replace.o: pathlength.h
replace.o: spec_arith.h
replace.o: static.h
replace.o: strsize.h
init.o: class.h
init.o: idf.h
init.o: interface.h
init.o: macro.h
init.o: nopp.h
options.o: align.h
options.o: arith.h
options.o: botch_free.h
options.o: class.h
options.o: dataflow.h
options.o: idf.h
options.o: idfsize.h
options.o: macro.h
options.o: maxincl.h
options.o: noRoption.h
options.o: nobitfield.h
options.o: nocross.h
options.o: nofloat.h
options.o: nopp.h
options.o: sizes.h
options.o: spec_arith.h
options.o: target_sizes.h
options.o: use_tmp.h
scan.o: class.h
scan.o: idf.h
scan.o: input.h
scan.o: interface.h
scan.o: lapbuf.h
scan.o: macro.h
scan.o: nopp.h
scan.o: nparams.h
skip.o: LLlex.h
skip.o: arith.h
skip.o: class.h
skip.o: file_info.h
skip.o: input.h
skip.o: interface.h
skip.o: nofloat.h
skip.o: nopp.h
skip.o: spec_arith.h
stack.o: Lpars.h
stack.o: arith.h
stack.o: botch_free.h
stack.o: debug.h
stack.o: def.h
stack.o: idf.h
stack.o: level.h
stack.o: mes.h
stack.o: noRoption.h
stack.o: nobitfield.h
stack.o: nofloat.h
stack.o: nopp.h
stack.o: spec_arith.h
stack.o: stack.h
stack.o: struct.h
stack.o: type.h
type.o: Lpars.h
type.o: align.h
type.o: arith.h
type.o: botch_free.h
type.o: def.h
type.o: idf.h
type.o: nobitfield.h
type.o: nocross.h
type.o: nofloat.h
type.o: nopp.h
type.o: sizes.h
type.o: spec_arith.h
type.o: target_sizes.h
type.o: type.h
ch7mon.o: Lpars.h
ch7mon.o: arith.h
ch7mon.o: botch_free.h
ch7mon.o: def.h
ch7mon.o: expr.h
ch7mon.o: idf.h
ch7mon.o: label.h
ch7mon.o: nobitfield.h
ch7mon.o: nofloat.h
ch7mon.o: nopp.h
ch7mon.o: spec_arith.h
ch7mon.o: type.h
label.o: Lpars.h
label.o: arith.h
label.o: def.h
label.o: idf.h
label.o: label.h
label.o: level.h
label.o: noRoption.h
label.o: nobitfield.h
label.o: nofloat.h
label.o: nopp.h
label.o: spec_arith.h
label.o: type.h
eval.o: Lpars.h
eval.o: align.h
eval.o: arith.h
eval.o: assert.h
eval.o: atw.h
eval.o: code.h
eval.o: dataflow.h
eval.o: debug.h
eval.o: def.h
eval.o: expr.h
eval.o: idf.h
eval.o: label.h
eval.o: level.h
eval.o: mes.h
eval.o: nobitfield.h
eval.o: nocross.h
eval.o: nofloat.h
eval.o: nopp.h
eval.o: sizes.h
eval.o: spec_arith.h
eval.o: stack.h
eval.o: target_sizes.h
eval.o: type.h
switch.o: Lpars.h
switch.o: arith.h
switch.o: assert.h
switch.o: botch_free.h
switch.o: code.h
switch.o: debug.h
switch.o: density.h
switch.o: expr.h
switch.o: idf.h
switch.o: label.h
switch.o: noRoption.h
switch.o: nobitfield.h
switch.o: nofloat.h
switch.o: nopp.h
switch.o: spec_arith.h
switch.o: switch.h
switch.o: type.h
conversion.o: Lpars.h
conversion.o: arith.h
conversion.o: nobitfield.h
conversion.o: nocross.h
conversion.o: nofloat.h
conversion.o: sizes.h
conversion.o: spec_arith.h
conversion.o: target_sizes.h
conversion.o: type.h
blocks.o: align.h
blocks.o: arith.h
blocks.o: atw.h
blocks.o: label.h
blocks.o: nocross.h
blocks.o: nofloat.h
blocks.o: sizes.h
blocks.o: spec_arith.h
blocks.o: stack.h
blocks.o: target_sizes.h
dataflow.o: dataflow.h
tokenfile.o: Lpars.h
declar.o: LLlex.h
declar.o: Lpars.h
declar.o: arith.h
declar.o: debug.h
declar.o: declar.h
declar.o: decspecs.h
declar.o: def.h
declar.o: expr.h
declar.o: field.h
declar.o: file_info.h
declar.o: idf.h
declar.o: label.h
declar.o: level.h
declar.o: nobitfield.h
declar.o: nocross.h
declar.o: nofloat.h
declar.o: nopp.h
declar.o: sizes.h
declar.o: spec_arith.h
declar.o: struct.h
declar.o: target_sizes.h
declar.o: type.h
statement.o: LLlex.h
statement.o: Lpars.h
statement.o: arith.h
statement.o: botch_free.h
statement.o: code.h
statement.o: debug.h
statement.o: def.h
statement.o: expr.h
statement.o: file_info.h
statement.o: idf.h
statement.o: label.h
statement.o: nobitfield.h
statement.o: nofloat.h
statement.o: nopp.h
statement.o: spec_arith.h
statement.o: stack.h
statement.o: type.h
expression.o: LLlex.h
expression.o: Lpars.h
expression.o: arith.h
expression.o: expr.h
expression.o: file_info.h
expression.o: idf.h
expression.o: label.h
expression.o: noRoption.h
expression.o: nobitfield.h
expression.o: nofloat.h
expression.o: nopp.h
expression.o: spec_arith.h
expression.o: type.h
program.o: LLlex.h
program.o: Lpars.h
program.o: arith.h
program.o: code.h
program.o: declar.h
program.o: decspecs.h
program.o: def.h
program.o: expr.h
program.o: file_info.h
program.o: idf.h
program.o: label.h
program.o: nobitfield.h
program.o: nofloat.h
program.o: nopp.h
program.o: spec_arith.h
program.o: type.h
Lpars.o: Lpars.h
ival.o: LLlex.h
ival.o: Lpars.h
ival.o: align.h
ival.o: arith.h
ival.o: assert.h
ival.o: class.h
ival.o: debug.h
ival.o: def.h
ival.o: estack.h
ival.o: expr.h
ival.o: field.h
ival.o: file_info.h
ival.o: idf.h
ival.o: label.h
ival.o: level.h
ival.o: noRoption.h
ival.o: nobitfield.h
ival.o: nocross.h
ival.o: nofloat.h
ival.o: nopp.h
ival.o: sizes.h
ival.o: spec_arith.h
ival.o: struct.h
ival.o: target_sizes.h
ival.o: type.h
char.o: class.h
symbol2str.o: Lpars.h

135
lang/cem/cemcom/Parameters
View File

@@ -1,135 +0,0 @@
!File: pathlength.h
#define PATHLENGTH 1024 /* max. length of path to file */
!File: errout.h
#define ERROUT STDERR /* file pointer for writing messages */
#define MAXERR_LINE 5 /* maximum number of error messages given
on the same input line. */
!File: idfsize.h
#define IDFSIZE 64 /* maximum significant length of an identifier */
!File: numsize.h
#define NUMSIZE 256 /* maximum length of a numeric constant */
!File: nparams.h
#define NPARAMS 32 /* maximum number of parameters of macros */
!File: ifdepth.h
#define IFDEPTH 256 /* maximum number of nested if-constructions */
!File: maxincl.h
#define MAXINCL 12 /* maximum number of #include directories */
!File: density.h
#define DENSITY 2 /* see switch.[ch] for an explanation */
!File: lapbuf.h
#define LAPBUF 4096 /* size of macro actual parameter buffer */
!File: strsize.h
#define ISTRSIZE 32 /* minimum number of bytes allocated for
storing a string */
#define RSTRSIZE 8 /* step size in enlarging the memory for
the storage of a string */
!File: target_sizes.h
#define MAXSIZE 8 /* the maximum of the SZ_* constants */
/* target machine sizes */
#define SZ_CHAR (arith)1
#define SZ_SHORT (arith)2
#define SZ_WORD (arith)4
#define SZ_INT (arith)4
#define SZ_LONG (arith)4
#ifndef NOFLOAT
#define SZ_FLOAT (arith)4
#define SZ_DOUBLE (arith)8
#endif NOFLOAT
#define SZ_POINTER (arith)4
/* target machine alignment requirements */
#define AL_CHAR 1
#define AL_SHORT SZ_SHORT
#define AL_WORD SZ_WORD
#define AL_INT SZ_WORD
#define AL_LONG SZ_WORD
#ifndef NOFLOAT
#define AL_FLOAT SZ_WORD
#define AL_DOUBLE SZ_WORD
#endif NOFLOAT
#define AL_POINTER SZ_WORD
#define AL_STRUCT 1
#define AL_UNION 1
!File: botch_free.h
#undef BOTCH_FREE 1 /* when defined, botch freed memory, as a check */
!File: dataflow.h
#define DATAFLOW 1 /* produce some compile-time xref */
!File: debug.h
#undef DEBUG 1 /* perform various self-tests */
!File: use_tmp.h
#define USE_TMP 1 /* collect exa, exp, ina and inp commands
and let them precede the rest of
the generated compact code */
!File: parbufsize.h
#define PARBUFSIZE 1024
!File: textsize.h
#define ITEXTSIZE 8 /* 1st piece of memory for repl. text */
#define RTEXTSIZE 8 /* stepsize for enlarging repl.text */
!File: inputtype.h
#undef INP_READ_IN_ONE 1 /* read input file in one */
!File: nopp.h
#undef NOPP 1 /* if NOT defined, use built-int preprocessor */
!File: nobitfield.h
#undef NOBITFIELD 1 /* if NOT defined, implement bitfields */
!File: spec_arith.h
/* describes internal compiler arithmetics */
#undef SPECIAL_ARITHMETICS /* something different from native long */
!File: static.h
#define GSTATIC /* for large global "static" arrays */
!File: nofloat.h
#undef NOFLOAT 1 /* if NOT defined, floats are implemented */
!File: noRoption.h
#undef NOROPTION 1 /* if NOT defined, R option is implemented */
!File: nocross.h
#undef NOCROSS 1 /* if NOT defined, cross compiler */

159
lang/cem/cemcom/alloc.c
View File

@@ -1,159 +0,0 @@
/* $Header$ */
/* M E M O R Y A L L O C A T I O N R O U T I N E S */
/* The allocation of memory in this program, which plays an important
role in reading files, replacing macros and building expression
trees, is not performed by malloc etc. The reason for having own
memory allocation routines (malloc(), realloc() and free()) is
plain: the garbage collection performed by the library functions
malloc(), realloc() and free() costs a lot of time, while in most
cases (on a VAX) the freeing and reallocation of memory is not
necessary. The only reallocation done in this program is at
building strings in memory. This means that the last
(re-)allocated piece of memory can be extended.
The (basic) memory allocating routines offered by this memory
handling package are:
char *malloc(n) : allocate n bytes
char *realloc(ptr, n) : reallocate buffer to n bytes
(works only if ptr was last allocated)
free(ptr) : if ptr points to last allocated
memory, this memory is re-allocatable
Salloc(str, sz) : save string in malloc storage
*/
#include <system.h>
#include "myalloc.h" /* UF */
#include "debug.h" /* UF */
#include "alloc.h"
#include "assert.h"
#ifdef OWNALLOC
char *sys_break();
/* the following variables are used for book-keeping */
static int nfreebytes = 0; /* # free bytes in sys_break space */
static char *freeb; /* pointer to first free byte */
static char *lastalloc; /* pointer to last malloced sp */
static int lastnbytes; /* nr of bytes in last allocated */
/* space */
static char *firstfreeb = 0;
#endif OWNALLOC
char *
Salloc(str, sz)
register char str[];
register int sz;
{
/* Salloc() is not a primitive function: it just allocates a
piece of storage and copies a given string into it.
*/
char *res = Malloc(sz);
register char *m = res;
while (sz--)
*m++ = *str++;
return res;
}
#ifdef OWNALLOC
#define ALIGN(m) (ALIGNSIZE * (((m) - 1) / ALIGNSIZE + 1))
char *
malloc(n)
unsigned n;
{
/* malloc() is a very simple malloc().
*/
n = ALIGN(n);
if (nfreebytes < n) {
register nbts = (n <= ALLOCSIZ) ? ALLOCSIZ : n;
if (!nfreebytes) {
if ((freeb = sys_break(nbts)) == ILL_BREAK)
fatal("out of memory");
}
else {
if (sys_break(nbts) == ILL_BREAK)
fatal("out of memory");
}
nfreebytes += nbts;
}
lastalloc = freeb;
freeb = lastalloc + n;
lastnbytes = n;
nfreebytes -= n;
return lastalloc;
}
/*ARGSUSED*/
char *
realloc(ptr, n)
char *ptr;
unsigned n;
{
/* realloc() is designed to append more bytes to the latest
allocated piece of memory. However reallocation should be
performed, even if the mentioned memory is not the latest
allocated one, this situation will not occur. To do so,
realloc should know how many bytes are allocated the last
time for that piece of memory. ????
*/
register int nbytes = n;
ASSERT(ptr == lastalloc); /* security */
nbytes -= lastnbytes; /* # bytes required */
if (nbytes == 0) /* no extra bytes */
return lastalloc;
/* if nbytes < 0: free last allocated bytes;
if nbytes > 0: allocate more bytes
*/
if (nbytes > 0)
nbytes = ALIGN(nbytes);
if (nfreebytes < nbytes) {
register int nbts = (nbytes < ALLOCSIZ) ? ALLOCSIZ : nbytes;
if (sys_break(nbts) == ILL_BREAK)
fatal("out of memory");
nfreebytes += nbts;
}
freeb += nbytes; /* less bytes */
lastnbytes += nbytes; /* change nr of last all. bytes */
nfreebytes -= nbytes; /* less or more free bytes */
return lastalloc;
}
/* to ensure that the alloc library package will not be loaded: */
/*ARGSUSED*/
free(p)
char *p;
{}
init_mem()
{
firstfreeb = sys_break(0);
/* align the first memory unit to ALIGNSIZE ??? */
if ((long) firstfreeb % ALIGNSIZE != 0) {
register char *fb = firstfreeb;
fb = (char *)ALIGN((long)fb);
firstfreeb = sys_break(fb - firstfreeb);
firstfreeb = fb;
ASSERT((long)firstfreeb % ALIGNSIZE == 0);
}
}
#ifdef DEBUG
mem_stat()
{
extern char options[];
if (options['m'])
print("Total nr of bytes allocated: %d\n",
sys_break(0) - firstfreeb);
}
#endif DEBUG
#endif OWNALLOC

16
lang/cem/cemcom/alloc.h
View File

@@ -1,16 +0,0 @@
/* $Header$ */
/* PROGRAM'S INTERFACE TO MEMORY ALLOCATION ROUTINES */
/* This file serves as the interface between the program and the
memory allocating routines.
There are 3 memory allocation routines:
char *Malloc(n) to allocate n bytes
char *Salloc(str, n) to allocate n bytes
and fill them with string str
char *Realloc(str, n) reallocate the string at str to n bytes
*/
extern char *Salloc(), *malloc(), *realloc();
#define Malloc(n) malloc((unsigned)(n))
#define Srealloc(ptr,n) realloc(ptr, (unsigned)(n))

23
lang/cem/cemcom/code.h
View File

@@ -1,23 +0,0 @@
/* $Header$ */
/* C O D E - G E N E R A T O R D E F I N I T I O N S */
struct stat_block {
struct stat_block *next;
label st_break;
label st_continue;
};
/* allocation definitions of struct stat_block */
/* ALLOCDEF "stat_block" */
extern char *st_alloc();
extern struct stat_block *h_stat_block;
#define new_stat_block() ((struct stat_block *) \
st_alloc((char **)&h_stat_block, sizeof(struct stat_block)))
#define free_stat_block(p) st_free(p, h_stat_block, sizeof(struct stat_block))
#define LVAL 0
#define RVAL 1
#define FALSE 0
#define TRUE 1

45
lang/cem/cemcom/declarator.h
View File

@@ -1,45 +0,0 @@
/* $Header$ */
/* DEFINITION OF DECLARATOR DESCRIPTORS */
/* A 'declarator' consists of an idf and a linked list of
language-defined unary operations: *, [] and (), called
decl_unary's.
*/
struct declarator {
struct declarator *next;
struct idf *dc_idf;
struct decl_unary *dc_decl_unary;
struct idstack_item *dc_fparams; /* params for function */
};
/* allocation definitions of struct declarator */
/* ALLOCDEF "declarator" */
extern char *st_alloc();
extern struct declarator *h_declarator;
#define new_declarator() ((struct declarator *) \
st_alloc((char **)&h_declarator, sizeof(struct declarator)))
#define free_declarator(p) st_free(p, h_declarator, sizeof(struct declarator))
#define NO_PARAMS ((struct idstack_item *) 0)
struct decl_unary {
struct decl_unary *next;
int du_fund; /* POINTER, ARRAY or FUNCTION */
arith du_count; /* for ARRAYs only */
};
/* allocation definitions of struct decl_unary */
/* ALLOCDEF "decl_unary" */
extern char *st_alloc();
extern struct decl_unary *h_decl_unary;
#define new_decl_unary() ((struct decl_unary *) \
st_alloc((char **)&h_decl_unary, sizeof(struct decl_unary)))
#define free_decl_unary(p) st_free(p, h_decl_unary, sizeof(struct decl_unary))
extern struct type *declare_type();
extern struct declarator null_declarator;

23
lang/cem/cemcom/decspecs.h
View File

@@ -1,23 +0,0 @@
/* $Header$ */
/* DECLARATION SPECIFIER DEFINITION */
struct decspecs {
struct decspecs *next;
struct type *ds_type; /* single type */
int ds_sc_given; /* 1 if the st. class is explicitly given */
int ds_sc; /* storage class, given or implied */
int ds_size; /* LONG, SHORT or 0 */
int ds_unsigned; /* 0 or 1 */
};
/* allocation definitions of struct decspecs */
/* ALLOCDEF "decspecs" */
extern char *st_alloc();
extern struct decspecs *h_decspecs;
#define new_decspecs() ((struct decspecs *) \
st_alloc((char **)&h_decspecs, sizeof(struct decspecs)))
#define free_decspecs(p) st_free(p, h_decspecs, sizeof(struct decspecs))
extern struct decspecs null_decspecs;

37
lang/cem/cemcom/def.h
View File

@@ -1,37 +0,0 @@
/* $Header$ */
/* IDENTIFIER DEFINITION DESCRIPTOR */
struct def { /* for ordinary tags */
struct def *next;
int df_level;
struct type *df_type;
int df_sc; /* may be:
GLOBAL, STATIC, EXTERN, IMPLICIT,
TYPEDEF,
FORMAL, AUTO,
ENUM, LABEL
*/
int df_register; /* REG_NONE, REG_DEFAULT or REG_BONUS */
char df_initialized; /* an initialization has been generated */
char df_alloc; /* 0, ALLOC_SEEN or ALLOC_DONE */
char df_used; /* set if idf is used */
char df_formal_array; /* to warn if sizeof is taken */
arith df_address;
};
#define ALLOC_SEEN 1 /* an allocating declaration has been seen */
#define ALLOC_DONE 2 /* the allocating declaration has been done */
#define REG_NONE 0 /* no register candidate */
#define REG_DEFAULT 1 /* register candidate, not declared as such */
#define REG_BONUS 10 /* register candidate, declared as such */
/* allocation definitions of struct def */
/* ALLOCDEF "def" */
extern char *st_alloc();
extern struct def *h_def;
#define new_def() ((struct def *) \
st_alloc((char **)&h_def, sizeof(struct def)))
#define free_def(p) st_free(p, h_def, sizeof(struct def))

144
lang/cem/cemcom/doprnt.c
View File

@@ -1,144 +0,0 @@
/* $Header$ */
/* STRING MANIPULATION AND PRINT ROUTINES */
#include <system.h>
#include "ssize.h"
char *long2str();
static
integral(c)
{
switch (c) {
case 'b':
return -2;
case 'd':
return 10;
case 'o':
return -8;
case 'u':
return -10;
case 'x':
return -16;
}
return 0;
}
static int
format(buf, fmt, argp)
char *buf, *fmt;
char *argp;
{
register char *pf = fmt, *pa = argp;
register char *pb = buf;
while (*pf) {
if (*pf == '%') {
register width, base, pad, npad;
char *arg;
char cbuf[2];
char *badformat = "<bad format>";
/* get padder */
if (*++pf == '0') {
pad = '0';
++pf;
}
else
pad = ' ';
/* get width */
width = 0;
while (*pf >= '0' && *pf <= '9')
width = 10 * width + *pf++ - '0';
/* get text and move pa */
if (*pf == 's') {
arg = *(char **)pa;
pa += sizeof(char *);
}
else
if (*pf == 'c') {
cbuf[0] = * (char *) pa;
cbuf[1] = '\0';
pa += sizeof(int);
arg = &cbuf[0];
}
else
if (*pf == 'l') {
/* alignment ??? */
if (base = integral(*++pf)) {
arg = long2str(*(long *)pa, base);
pa += sizeof(long);
}
else {
pf--;
arg = badformat;
}
}
else
if (base = integral(*pf)) {
arg = long2str((long)*(int *)pa, base);
pa += sizeof(int);
}
else
if (*pf == '%')
arg = "%";
else
arg = badformat;
npad = width - strlen(arg);
while (npad-- > 0)
*pb++ = pad;
while (*pb++ = *arg++);
pb--;
pf++;
}
else
*pb++ = *pf++;
}
return pb - buf;
}
doprnt(fp, fmt, argp)
File *fp;
char *fmt;
int argp[];
{
char buf[SSIZE];
sys_write(fp, buf, format(buf, fmt, (char *)argp));
}
/*VARARGS1*/
printf(fmt, args)
char *fmt;
char args;
{
char buf[SSIZE];
sys_write(STDOUT, buf, format(buf, fmt, &args));
}
/*VARARGS1*/
fprintf(fp, fmt, args)
File *fp;
char *fmt;
char args;
{
char buf[SSIZE];
sys_write(fp, buf, format(buf, fmt, &args));
}
/*VARARGS1*/
char *
sprintf(buf, fmt, args)
char *buf, *fmt;
char args;
{
buf[format(buf, fmt, &args)] = '\0';
return buf;
}

201
lang/cem/cemcom/em.c
View File

@@ -1,201 +0,0 @@
/* $Header$ */
/* EM CODE OUTPUT ROUTINES */
#define CMODE 0644
#define MAX_ARG_CNT 32
#include "em.h"
#include <system.h>
#include "arith.h"
#include "label.h"
/*
putbyte(), C_open() and C_close() are the basic routines for
respectively write on, open and close the output file.
The put_*() functions serve as formatting functions of the
various EM language constructs.
See "Description of a Machine Architecture for use with
Block Structured Languages" par. 11.2 for the meaning of these
names.
*/
/* supply a kind of buffered output */
#define flush(x) sys_write(ofp, &obuf[0], x)
static char obuf[BUFSIZ];
static char *opp = &obuf[0];
File *ofp = 0;
putbyte(b) /* shouldn't putbyte() be a macro ??? (EB) */
int b;
{
if (opp >= &obuf[BUFSIZ]) { /* flush if buffer overflows */
if (flush(BUFSIZ) == 0)
sys_stop(S_ABORT);
opp = &obuf[0];
}
*opp++ = (char) b;
}
C_init(wsize, psize)
arith wsize, psize;
{}
C_open(nm) /* open file for compact code output */
char *nm;
{
if (nm == 0)
ofp = STDOUT; /* standard output */
else
if (sys_open(nm, OP_WRITE, &ofp) == 0)
return 0;
return 1;
}
C_close()
{
if (flush(opp - &obuf[0]) == 0)
sys_stop(S_ABORT);
opp = obuf; /* reset opp */
if (ofp != STDOUT)
sys_close(ofp);
ofp = 0;
}
C_busy()
{
return ofp != 0; /* true if code is being generated */
}
/*** the compact code generating routines ***/
#define fit16i(x) ((x) >= (long)0xFFFF8000 && (x) <= (long)0x00007FFF)
#define fit8u(x) ((x) <= 0xFF) /* x is already unsigned */
put_ilb(l)
label l;
{
if (fit8u(l)) {
put8(sp_ilb1);
put8((int)l);
}
else {
put8(sp_ilb2);
put16(l);
}
}
put_dlb(l)
label l;
{
if (fit8u(l)) {
put8(sp_dlb1);
put8((int)l);
}
else {
put8(sp_dlb2);
put16(l);
}
}
put_cst(l)
arith l;
{
if (l >= (arith) -sp_zcst0 && l < (arith) (sp_ncst0 - sp_zcst0)) {
/* we can convert 'l' to an int because its value
can be stored in a byte.
*/
put8((int) l + (sp_zcst0 + sp_fcst0));
}
else
if (fit16i(l)) { /* the cast from long to int causes no trouble here */
put8(sp_cst2);
put16((int) l);
}
else {
put8(sp_cst4);
put32(l);
}
}
put_doff(l, v)
label l;
arith v;
{
if (v == 0)
put_dlb(l);
else {
put8(sp_doff);
put_dlb(l);
put_cst(v);
}
}
put_noff(s, v)
char *s;
arith v;
{
if (v == 0)
put_dnam(s);
else {
put8(sp_doff);
put_dnam(s);
put_cst(v);
}
}
put_dnam(s)
char *s;
{
put8(sp_dnam);
put_str(s);
}
put_pnam(s)
char *s;
{
put8(sp_pnam);
put_str(s);
}
#ifdef ____
put_fcon(s, sz)
char *s;
arith sz;
{
put8(sp_fcon);
put_cst(sz);
put_str(s);
}
#endif ____
put_wcon(sp, v, sz) /* sp_icon, sp_ucon or sp_fcon with int repr */
int sp;
char *v;
arith sz;
{
/* how 'bout signextension int --> long ??? */
put8(sp);
put_cst(sz);
put_str(v);
}
put_str(s)
char *s;
{
register int len;
put_cst((arith) (len = strlen(s)));
while (--len >= 0)
put8(*s++);
}
put_cstr(s)
char *s;
{
register int len = prepare_string(s);
put8(sp_scon);
put_cst((arith) len);
while (--len >= 0)
put8(*s++);
}

42
lang/cem/cemcom/em.h
View File

@@ -1,42 +0,0 @@
/* $Header$ */
/* DESCRIPTION OF INTERFACE TO EM CODE GENERATING ROUTINES */
#include "proc_intf.h" /* use macros or functions */
/* include the EM description files */
#include <em_spec.h>
#include <em_pseu.h>
#include <em_mes.h>
#include <em_mnem.h>
#include <em_reg.h>
/* macros used in the definitions of the interface functions C_* */
#define OP(x) put_op(x)
#define CST(x) put_cst(x)
#define DCST(x) put_cst(x)
#define CSTR(x) put_cstr(x)
#define PS(x) put_ps(x)
#define DLB(x) put_dlb(x)
#define ILB(x) put_ilb(x)
#define NOFF(x,y) put_noff((x), (y))
#define DOFF(x,y) put_doff((x), (y))
#define PNAM(x) put_pnam(x)
#define DNAM(x) put_dnam(x)
#define CEND() put_cend()
#define WCON(x,y,z) put_wcon((x), (y), (z))
#define FCON(x,y) put_fcon((x), (y))
/* variants of primitive "putbyte" */
#define put8(x) putbyte(x) /* defined in "em.c" */
#define put16(x) (put8((int) x), put8((int) (x >> 8)))
#define put32(x) (put16((int) x), put16((int) (x >> 16)))
#define put_cend() put8(sp_cend)
#define put_op(x) put8(x)
#define put_ps(x) put8(x)
/* user interface */
#define C_magic() put16(sp_magic) /* EM magic word */
#ifndef PROC_INTF
#include "writeem.h"
#endif PROC_INTF

136
lang/cem/cemcom/emcode.def
View File

@@ -1,136 +0,0 @@
% emcode definitions for the CEM compiler -- intermediate code
C_adf(p) | arith p; | OP(op_adf), CST(p)
C_adi(p) | arith p; | OP(op_adi), CST(p)
C_adp(p) | arith p; | OP(op_adp), CST(p)
C_ads(p) | arith p; | OP(op_ads), CST(p)
C_adu(p) | arith p; | OP(op_adu), CST(p)
C_and(p) | arith p; | OP(op_and), CST(p)
C_asp(p) | arith p; | OP(op_asp), CST(p)
C_bra(l) | label l; | OP(op_bra), CST((arith)l)
C_cai() | | OP(op_cai)
C_cal(p) | char *p; | OP(op_cal), PNAM(p)
C_cff() | | OP(op_cff)
C_cfi() | | OP(op_cfi)
C_cfu() | | OP(op_cfu)
C_cif() | | OP(op_cif)
C_cii() | | OP(op_cii)
C_ciu() | | OP(op_ciu)
C_cmf(p) | arith p; | OP(op_cmf), CST(p)
C_cmi(p) | arith p; | OP(op_cmi), CST(p)
C_cmp() | | OP(op_cmp)
C_cmu(p) | arith p; | OP(op_cmu), CST(p)
C_com(p) | arith p; | OP(op_com), CST(p)
C_csa(p) | arith p; | OP(op_csa), CST(p)
C_csb(p) | arith p; | OP(op_csb), CST(p)
C_cuf() | | OP(op_cuf)
C_cui() | | OP(op_cui)
C_cuu() | | OP(op_cuu)
C_dup(p) | arith p; | OP(op_dup), CST(p)
C_dvf(p) | arith p; | OP(op_dvf), CST(p)
C_dvi(p) | arith p; | OP(op_dvi), CST(p)
C_dvu(p) | arith p; | OP(op_dvu), CST(p)
C_fil_dlb(l, o) | label l; arith o; | OP(op_fil), DOFF(l, o)
C_ior(p) | arith p; | OP(op_ior), CST(p)
C_lae_dnam(p, o) | char *p; arith o; | OP(op_lae), NOFF(p, o)
C_lae_dlb(l, o) | label l; arith o; | OP(op_lae), DOFF(l, o)
C_lal(p) | arith p; | OP(op_lal), CST(p)
C_ldc(p) | arith p; | OP(op_ldc), DCST(p)
C_lde_dnam(p, o) | char *p; arith o; | OP(op_lde), NOFF(p, o)
C_lde_dlb(l, o) | label l; arith o; | OP(op_lde), DOFF(l, o)
C_ldl(p) | arith p; | OP(op_ldl), CST(p)
C_lfr(p) | arith p; | OP(op_lfr), CST(p)
C_lin(p) | arith p; | OP(op_lin), CST(p)
C_loc(p) | arith p; | OP(op_loc), CST(p)
C_loe_dnam(p, o) | char *p; arith o; | OP(op_loe), NOFF(p, o)
C_loe_dlb(l, o) | label l; arith o; | OP(op_loe), DOFF(l, o)
C_loi(p) | arith p; | OP(op_loi), CST(p)
C_lol(p) | arith p; | OP(op_lol), CST(p)
C_lor(p) | arith p; | OP(op_lor), CST(p)
C_lpi(p) | char *p; | OP(op_lpi), PNAM(p)
C_mlf(p) | arith p; | OP(op_mlf), CST(p)
C_mli(p) | arith p; | OP(op_mli), CST(p)
C_mlu(p) | arith p; | OP(op_mlu), CST(p)
C_ngf(p) | arith p; | OP(op_ngf), CST(p)
C_ngi(p) | arith p; | OP(op_ngi), CST(p)
C_ret(p) | arith p; | OP(op_ret), CST(p)
C_rmi(p) | arith p; | OP(op_rmi), CST(p)
C_rmu(p) | arith p; | OP(op_rmu), CST(p)
C_sbf(p) | arith p; | OP(op_sbf), CST(p)
C_sbi(p) | arith p; | OP(op_sbi), CST(p)
C_sbs(p) | arith p; | OP(op_sbs), CST(p)
C_sbu(p) | arith p; | OP(op_sbu), CST(p)
C_sde_dnam(p, o) | char *p; arith o; | OP(op_sde), NOFF(p, o)
C_sde_dlb(l, o) | label l; arith o; | OP(op_sde), DOFF(l, o)
C_sdl(p) | arith p; | OP(op_sdl), CST(p)
C_sli(p) | arith p; | OP(op_sli), CST(p)
C_slu(p) | arith p; | OP(op_slu), CST(p)
C_sri(p) | arith p; | OP(op_sri), CST(p)
C_sru(p) | arith p; | OP(op_sru), CST(p)
C_ste_dnam(p, o) | char *p; arith o; | OP(op_ste), NOFF(p, o)
C_ste_dlb(l, o) | label l; arith o; | OP(op_ste), DOFF(l, o)
C_sti(p) | arith p; | OP(op_sti), CST(p)
C_stl(p) | arith p; | OP(op_stl), CST(p)
C_xor(p) | arith p; | OP(op_xor), CST(p)
C_zeq(l) | label l; | OP(op_zeq), CST((arith)l)
C_zge(l) | label l; | OP(op_zge), CST((arith)l)
C_zgt(l) | label l; | OP(op_zgt), CST((arith)l)
C_zle(l) | label l; | OP(op_zle), CST((arith)l)
C_zlt(l) | label l; | OP(op_zlt), CST((arith)l)
C_zne(l) | label l; | OP(op_zne), CST((arith)l)
%
C_df_dlb(l) | label l; | DLB(l)
C_df_dnam(s) | char *s; | DNAM(s)
C_df_ilb(l) | label l; | ILB(l)
%
C_bss_cst(n, w, i) | arith n, w; int i; |
PS(ps_bss), DCST(n), CST(w), CST((arith)i)
%
C_con_icon(val, siz) | char *val; arith siz; |
PS(ps_con), WCON(sp_icon, val, siz), CEND()
C_con_ucon(val, siz) | char *val; arith siz; |
PS(ps_con), WCON(sp_ucon, val, siz), CEND()
C_con_fcon(val, siz) | char *val; arith siz; |
PS(ps_con), WCON(sp_fcon, val, siz), CEND()
C_con_scon(str, siz) | char *str; arith siz; | PS(ps_con), CSTR(str), CEND()
C_con_dnam(str, val) | char *str; arith val; |
PS(ps_con), NOFF(str, val), CEND()
C_con_dlb(l, val) | label l; arith val; |
PS(ps_con), DOFF(l, val), CEND()
C_con_pnam(str) | char *str; | PS(ps_con), PNAM(str), CEND()
%
C_rom_cst(l) | arith l; | PS(ps_rom), CST(l), CEND()
C_rom_icon(val, siz) | char *val; arith siz; |
PS(ps_rom), WCON(sp_icon, val, siz), CEND()
C_rom_fcon(val, siz) | char *val; arith siz; |
PS(ps_rom), WCON(sp_fcon, val, siz), CEND()
C_rom_ilb(l) | label l; | PS(ps_rom), ILB(l), CEND()
%
C_cst(l) | arith l; | CST(l)
C_icon(val, siz) | char *val; arith siz; | WCON(sp_icon, val, siz)
C_ucon(val, siz) | char *val; arith siz; | WCON(sp_ucon, val, siz)
C_fcon(val, siz) | char *val; arith siz; | WCON(sp_fcon, val, siz)
C_scon(str, siz) | char *str; arith siz; | CSTR(str)
C_dnam(str, val) | char *str; arith val; | NOFF(str, val)
C_dlb(l, val) | label l; arith val; | DOFF(l, val)
C_pnam(str) | char *str; | PNAM(str)
C_ilb(l) | label l; | ILB(l)
%
C_pro_narg(p1) | char *p1; | PS(ps_pro), PNAM(p1), CEND()
C_end(l) | arith l; | PS(ps_end), CST(l)
%
C_exa(s) | char *s; | PS(ps_exa), DNAM(s)
C_exp(s) | char *s; | PS(ps_exp), PNAM(s)
C_ina_pt(l) | label l; | PS(ps_ina), DLB(l)
C_ina(s) | char *s; | PS(ps_ina), DNAM(s)
C_inp(s) | char *s; | PS(ps_inp), PNAM(s)
%
C_ms_err() | | PS(ps_mes), CST((arith)ms_err), CEND()
C_ms_emx(p1, p2) | arith p1, p2; |
PS(ps_mes), CST((arith)ms_emx), CST(p1), CST(p2), CEND()
C_ms_reg(a, b, c, d) | arith a, b; int c, d; |
PS(ps_mes), CST((arith)ms_reg), CST(a), CST(b), CST((arith)c), CST((arith)d), CEND()
C_ms_src(l, s) | arith l; char *s; |
PS(ps_mes), CST((arith)ms_src), CST(l), CSTR(s), CEND()
C_ms_flt() | | PS(ps_mes), CST((arith)ms_flt), CEND()
C_ms_par(l) | arith l; | PS(ps_mes), CST((arith)ms_par), CST(l), CEND()
C_ms_gto() | | PS(ps_mes), CST((arith)ms_gto), CEND()

102
lang/cem/cemcom/expr.h
View File

@@ -1,102 +0,0 @@
/* $Header$ */
/* EXPRESSION DESCRIPTOR */
/* What we want to define is the struct expr, but since it contains
a union of various goodies, we define them first; so be patient.
*/
struct value {
struct idf *vl_idf; /* idf of an external name or 0 */
arith vl_value; /* constant, or offset if idf != 0 */
};
struct string {
char *sg_value; /* string of characters repr. the constant */
label sg_datlab; /* global data-label */
};
struct floating {
char *fl_value; /* pointer to string repr. the fp const. */
label fl_datlab; /* global data_label */
};
struct oper {
struct type *op_type; /* resulting type of the operation */
struct expr *op_left;
int op_oper; /* the symbol of the operator */
struct expr *op_right;
};
/* The following constants indicate the class of the expression: */
#define Value 0 /* it is a value known at load time */
#define String 1 /* it is a string constant */
#define Float 2 /* it is a floating point constant */
#define Oper 3 /* it is a run-time expression */
#define Type 4 /* only its type is relevant */
struct expr {
struct expr *next;
char *ex_file; /* the file it (probably) comes from */
unsigned int ex_line; /* the line it (probably) comes from */
struct type *ex_type;
char ex_lvalue;
char ex_flags;
int ex_class;
int ex_depth;
union {
struct value ex_value;
struct string ex_string;
struct floating ex_float;
struct oper ex_oper;
} ex_object;
};
/* some abbreviated selections */
#define VL_VALUE ex_object.ex_value.vl_value
#define VL_IDF ex_object.ex_value.vl_idf
#define SG_VALUE ex_object.ex_string.sg_value
#define SG_DATLAB ex_object.ex_string.sg_datlab
#define FL_VALUE ex_object.ex_float.fl_value
#define FL_DATLAB ex_object.ex_float.fl_datlab
#define OP_TYPE ex_object.ex_oper.op_type
#define OP_LEFT ex_object.ex_oper.op_left
#define OP_OPER ex_object.ex_oper.op_oper
#define OP_RIGHT ex_object.ex_oper.op_right
#define EXPRTYPE(e) ((e)->ex_type->tp_fund)
/* An expression is a `load-time constant' if it is of the form
<idf> +/- <integral> or <integral>;
it is a `compile-time constant' if it is an <integral>.
*/
#define is_ld_cst(e) ((e)->ex_lvalue == 0 && (e)->ex_class == Value)
#define is_cp_cst(e) (is_ld_cst(e) && (e)->VL_IDF == 0)
/* a floating constant expression ?
*/
#define is_fp_cst(e) ((e)->ex_class == Float)
/* some bits for the ex_flag field, to keep track of various
interesting properties of an expression.
*/
#define EX_SIZEOF 001 /* contains sizeof operator */
#define EX_CAST 002 /* contains cast */
#define EX_LOGICAL 004 /* contains logical operator */
#define EX_COMMA 010 /* contains expression comma */
#define EX_PARENS 020 /* the top level is parenthesized */
#define NILEXPR ((struct expr *)0)
extern struct expr *intexpr(), *new_oper();
/* allocation definitions of struct expr */
/* ALLOCDEF "expr" */
extern char *st_alloc();
extern struct expr *h_expr;
#define new_expr() ((struct expr *) \
st_alloc((char **)&h_expr, sizeof(struct expr)))
#define free_expr(p) st_free(p, h_expr, sizeof(struct expr))
#define ISCOMMA(e) ((e)->ex_class == Oper && (e)->OP_OPER == INITCOMMA)

20
lang/cem/cemcom/field.h
View File

@@ -1,20 +0,0 @@
/* $Header$ */
/* FIELD DESCRIPTOR */
struct field { /* for field specifiers */
struct field *next;
arith fd_mask;
int fd_shift;
int fd_width;
struct sdef *fd_sdef; /* upward pointer */
};
/* allocation definitions of struct field */
/* ALLOCDEF "field" */
extern char *st_alloc();
extern struct field *h_field;
#define new_field() ((struct field *) \
st_alloc((char **)&h_field, sizeof(struct field)))
#define free_field(p) st_free(p, h_field, sizeof(struct field))

68
lang/cem/cemcom/idf.h
View File

@@ -1,68 +0,0 @@
/* $Header$ */
/* IDENTIFIER DESCRIPTOR */
#include "nopp.h"
/* Since the % operation in the calculation of the hash function
turns out to be expensive, it is replaced by the cheaper XOR (^).
Each character of the identifier is xored with an 8-bit mask which
depends on the position of the character; the sum of these results
is the hash value. The random masks are obtained from a
congruence generator in idf.c.
*/
#define HASHSIZE 256 /* must be a power of 2 */
#define HASH_X 0253 /* Knuth's X */
#define HASH_A 77 /* Knuth's a */
#define HASH_C 153 /* Knuth's c */
extern char hmask[]; /* the random masks */
#define HASHMASK (HASHSIZE-1) /* since it is a power of 2 */
#define STARTHASH() (0)
#define ENHASH(hs,ch,ps) (hs + (ch ^ hmask[ps]))
#define STOPHASH(hs) (hs & HASHMASK)
struct idstack_item { /* stack of identifiers */
struct idstack_item *next;
struct idf *is_idf;
};
/* allocation definitions of struct idstack_item */
/* ALLOCDEF "idstack_item" */
extern char *st_alloc();
extern struct idstack_item *h_idstack_item;
#define new_idstack_item() ((struct idstack_item *) \
st_alloc((char **)&h_idstack_item, sizeof(struct idstack_item)))
#define free_idstack_item(p) st_free(p, h_idstack_item, sizeof(struct idstack_item))
struct idf {
struct idf *next;
char *id_text;
#ifndef NOPP
struct macro *id_macro;
int id_resmac; /* if nonzero: keyword of macroproc. */
#endif NOPP
int id_reserved; /* non-zero for reserved words */
struct def *id_def; /* variables, typedefs, enum-constants */
struct sdef *id_sdef; /* selector tags */
struct tag *id_struct; /* struct and union tags */
struct tag *id_enum; /* enum tags */
int id_special; /* special action needed at occurrence */
};
/* allocation definitions of struct idf */
/* ALLOCDEF "idf" */
extern char *st_alloc();
extern struct idf *h_idf;
#define new_idf() ((struct idf *) \
st_alloc((char **)&h_idf, sizeof(struct idf)))
#define free_idf(p) st_free(p, h_idf, sizeof(struct idf))
extern struct idf *str2idf(), *idf_hashed();
extern int level;
extern struct idf *gen_idf();

624
lang/cem/cemcom/ival.c
View File

@@ -1,624 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*/
/* $Header$ */
/* CODE FOR THE INITIALISATION OF GLOBAL VARIABLES */
#include "nofloat.h"
#include <em.h>
#include "debug.h"
#include <alloc.h>
#include "nobitfield.h"
#include "arith.h"
#include "align.h"
#include "label.h"
#include "expr.h"
#include "type.h"
#include "struct.h"
#include "field.h"
#include "assert.h"
#include "Lpars.h"
#include "class.h"
#include "sizes.h"
#include "idf.h"
#include "level.h"
#include "def.h"
#define con_nullbyte() C_con_ucon("0", (arith)1)
char *symbol2str();
char *long2str();
char *strncpy();
struct expr *do_array(), *do_struct(), *IVAL();
extern char options[];
/* do_ival() performs the initialisation of a global variable
of type tp with the initialisation expression expr by calling IVAL().
Guided by type tp, the expression is evaluated.
*/
do_ival(tpp, ex)
struct type **tpp;
struct expr *ex;
{
if (IVAL(tpp, ex) != 0)
too_many_initialisers(ex);
}
/* IVAL() recursively guides the initialisation expression through the
different routines for the different types of initialisation:
- array initialisation
- struct initialisation
- fundamental type initialisation
Upto now, the initialisation of a union is not allowed!
An initialisation expression tree consists of normal expressions
which can be joined together by ',' nodes, which operator acts
like the lisp function "cons" to build lists.
IVAL() returns a pointer to the remaining expression tree.
*/
struct expr *
IVAL(tpp, ex)
struct type **tpp; /* type of global variable */
register struct expr *ex; /* initialiser expression */
{
register struct type *tp = *tpp;
switch (tp->tp_fund) {
case ARRAY: /* array initialisation */
if (valid_type(tp->tp_up, "array element") == 0)
return 0;
if (ISCOMMA(ex)) /* list of initialisation expressions */
return do_array(ex, tpp);
if (tp->tp_up->tp_fund == CHAR && ex->ex_class == String)
/* initialisation like char s[] = "I am a string" */
ch_array(tpp, ex);
else /* " int i[24] = 12;" */
check_and_pad(ex, tpp);
break;
case STRUCT: /* struct initialisation */
if (valid_type(tp, "struct") == 0)
return 0;
if (ISCOMMA(ex)) /* list of initialisation expressions */
return do_struct(ex, tp);
check_and_pad(ex, tpp); /* "struct foo f = 12;" */
break;
case UNION:
error("union initialisation not allowed");
break;
case ERRONEOUS:
break;
default: /* fundamental type */
if (ISCOMMA(ex)) { /* " int i = {12};" */
if (IVAL(tpp, ex->OP_LEFT) != 0)
too_many_initialisers(ex);
/* return remainings of the list for the
other members of the aggregate, if this
item belongs to an aggregate.
*/
return ex->OP_RIGHT;
}
check_ival(ex, tp); /* "int i = 12;" */
break;
}
return 0;
}
/* do_array() initialises the members of an array described
by type tp with the expressions in expr.
Two important cases:
- the number of members is known
- the number of members is not known
In the latter case, do_array() digests the whole expression
tree it is given.
In the former case, do_array() eats as many members from
the expression tree as are needed for the array.
If there are not sufficient members for the array, the remaining
members are padded with zeroes
*/
struct expr *
do_array(ex, tpp)
register struct expr *ex;
struct type **tpp;
{
register struct type *tp = *tpp;
register arith elem_count;
ASSERT(tp->tp_fund == ARRAY && ISCOMMA(ex));
/* the following test catches initialisations like
char c[] = {"just a string"};
or
char d[] = {{"just another string"}};
The use of the brackets causes this problem.
Note: although the implementation of such initialisations
is completely foolish, we did it!! (no applause, thank you)
*/
if (tp->tp_up->tp_fund == CHAR) {
register struct expr *f = ex->OP_LEFT, *g = NILEXPR;
while (ISCOMMA(f)) { /* eat the brackets!!! */
g = f;
f = f->OP_LEFT;
}
if (f->ex_class == String) { /* hallelujah, it's a string! */
ch_array(tpp, f);
return g ? g->OP_RIGHT : ex->OP_RIGHT;
}
/* else: just go on with the next part of this function */
if (g != 0)
ex = g;
}
if (tp->tp_size == (arith)-1) {
/* declared with unknown size: [] */
for (elem_count = 0; ex; elem_count++) {
/* eat whole initialisation expression */
if (ISCOMMA(ex->OP_LEFT)) { /* embraced member */
if (IVAL(&(tp->tp_up), ex->OP_LEFT) != 0)
too_many_initialisers(ex);
ex = ex->OP_RIGHT;
}
else {
if (aggregate_type(tp->tp_up))
ex = IVAL(&(tp->tp_up), ex);
else {
check_ival(ex->OP_LEFT, tp->tp_up);
ex = ex->OP_RIGHT;
}
}
}
/* set the proper size */
*tpp = construct_type(ARRAY, tp->tp_up, elem_count);
}
else { /* the number of members is already known */
arith dim = tp->tp_size / tp->tp_up->tp_size;
for (elem_count = 0; elem_count < dim && ex; elem_count++) {
if (ISCOMMA(ex->OP_LEFT)) { /* embraced member */
if (IVAL(&(tp->tp_up), ex->OP_LEFT) != 0)
too_many_initialisers(ex);
ex = ex->OP_RIGHT;
}
else {
if (aggregate_type(tp->tp_up))
ex = IVAL(&(tp->tp_up), ex);
else {
check_ival(ex->OP_LEFT, tp->tp_up);
ex = ex->OP_RIGHT;
}
}
}
if (ex && elem_count == dim)
/* all the members are initialised but there
remains a part of the expression tree which
is returned
*/
return ex;
if ((ex == 0) && elem_count < dim)
/* the expression tree is completely absorbed
but there are still members which must be
initialised with zeroes
*/
do
pad(tp->tp_up);
while (++elem_count < dim);
}
return 0;
}
/* do_struct() initialises a struct of type tp with the expression expr.
The main loop is just controlled by the definition of the selectors
during which alignment is taken care of.
*/
struct expr *
do_struct(ex, tp)
register struct expr *ex;
register struct type *tp;
{
register struct sdef *sd = tp->tp_sdef;
arith bytes_upto_here = (arith)0;
arith last_offset = (arith)-1;
ASSERT(tp->tp_fund == STRUCT && ISCOMMA(ex));
/* as long as there are selectors and there is an initialiser.. */
while (sd && ex) {
if (ISCOMMA(ex->OP_LEFT)) { /* embraced expression */
if (IVAL(&(sd->sd_type), ex->OP_LEFT) != 0)
too_many_initialisers(ex);
ex = ex->OP_RIGHT;
}
else {
if (aggregate_type(sd->sd_type))
/* selector is an aggregate itself */
ex = IVAL(&(sd->sd_type), ex);
else {
#ifdef NOBITFIELD
/* fundamental type, not embraced */
check_ival(ex->OP_LEFT, sd->sd_type);
ex = ex->OP_RIGHT;
#else
if (is_anon_idf(sd->sd_idf))
/* a hole in the struct due to
the use of ";:n;" in a struct
definition.
*/
put_bf(sd->sd_type, (arith)0);
else { /* fundamental type, not embraced */
check_ival(ex->OP_LEFT, sd->sd_type);
ex = ex->OP_RIGHT;
}
#endif NOBITFIELD
}
}
if (sd->sd_sdef) /* align upto the next selector boundary */
bytes_upto_here += zero_bytes(sd);
if (last_offset != sd->sd_offset) {
/* don't take the field-width more than once */
bytes_upto_here +=
size_of_type(sd->sd_type, "selector");
last_offset = sd->sd_offset;
}
sd = sd->sd_sdef;
}
/* perfect fit if (ex && (sd == 0)) holds */
if ((ex == 0) && (sd != 0)) {
/* there are selectors left which must be padded with zeroes */
do {
pad(sd->sd_type);
/* take care of the alignment restrictions */
if (sd->sd_sdef)
bytes_upto_here += zero_bytes(sd);
/* no field thrown-outs here */
bytes_upto_here +=
size_of_type(sd->sd_type, "selector");
} while (sd = sd->sd_sdef);
}
/* keep on aligning... */
while (bytes_upto_here++ < tp->tp_size)
con_nullbyte();
return ex;
}
/* check_and_pad() is given a simple initialisation expression
where the type can be either a simple or an aggregate type.
In the latter case, only the first member is initialised and
the rest is zeroed.
*/
check_and_pad(ex, tpp)
register struct expr *ex;
struct type **tpp;
{
/* ex is of a fundamental type */
register struct type *tp = *tpp;
if (tp->tp_fund == ARRAY) {
if (valid_type(tp->tp_up, "array element") == 0)
return;
check_and_pad(ex, &(tp->tp_up)); /* first member */
if (tp->tp_size == (arith)-1)
/* no size specified upto here: just
set it to the size of one member.
*/
tp = *tpp = construct_type(ARRAY, tp->tp_up, (arith)1);
else {
register int dim = tp->tp_size / tp->tp_up->tp_size;
/* pad remaining members with zeroes */
while (--dim > 0)
pad(tp->tp_up);
}
}
else
if (tp->tp_fund == STRUCT) {
register struct sdef *sd = tp->tp_sdef;
if (valid_type(tp, "struct") == 0)
return;
check_and_pad(ex, &(sd->sd_type));
/* next selector is aligned by adding extra zeroes */
if (sd->sd_sdef)
zero_bytes(sd);
while (sd = sd->sd_sdef) { /* pad remaining selectors */
pad(sd->sd_type);
if (sd->sd_sdef)
zero_bytes(sd);
}
}
else /* simple type */
check_ival(ex, tp);
}
/* pad() fills an element of type tp with zeroes.
If the element is an aggregate, pad() is called recursively.
*/
pad(tp)
register struct type *tp;
{
register arith sz = tp->tp_size;
switch (tp->tp_fund) {
case ARRAY:
if (valid_type(tp->tp_up, "array element") == 0)
return;
break;
case STRUCT:
if (valid_type(tp, "struct") == 0)
return;
break;
case UNION:
if (valid_type(tp, "union") == 0)
return;
if (options['R']) {
warning("initialisation of unions not allowed");
}
break;
#ifndef NOBITFIELD
case FIELD:
put_bf(tp, (arith)0);
return;
#endif NOBITFIELD
case ERRONEOUS:
return;
}
while (sz >= word_size) {
C_con_cst((arith) 0);
sz -= word_size;
}
while (sz) {
C_con_icon("0", (arith) 1);
sz--;
}
}
/* check_ival() checks whether the initialisation of an element
of a fundamental type is legal and, if so, performs the initialisation
by directly generating the necessary code.
No further comment is needed to explain the internal structure
of this straightforward function.
*/
check_ival(expr, tp)
register struct expr *expr;
register struct type *tp;
{
/* The philosophy here is that ch7cast puts an explicit
conversion node in front of the expression if the types
are not compatible. In this case, the initialisation
expression is no longer a constant.
*/
struct expr *ex = expr;
switch (tp->tp_fund) {
case CHAR:
case SHORT:
case INT:
case LONG:
case ENUM:
case POINTER:
ch7cast(&ex, '=', tp);
expr = ex;
#ifdef DEBUG
print_expr("init-expr after cast", expr);
#endif DEBUG
if (!is_ld_cst(expr))
illegal_init_cst(expr);
else
if (expr->VL_CLASS == Const)
con_int(expr);
else
if (expr->VL_CLASS == Name) {
register struct idf *idf = expr->VL_IDF;
if (idf->id_def->df_level >= L_LOCAL)
illegal_init_cst(expr);
else /* e.g., int f(); int p = f; */
if (idf->id_def->df_type->tp_fund == FUNCTION)
C_con_pnam(idf->id_text);
else /* e.g., int a; int *p = &a; */
C_con_dnam(idf->id_text, expr->VL_VALUE);
}
else {
ASSERT(expr->VL_CLASS == Label);
C_con_dlb(expr->VL_LBL, expr->VL_VALUE);
}
break;
#ifndef NOFLOAT
case FLOAT:
case DOUBLE:
ch7cast(&ex, '=', tp);
expr = ex;
#ifdef DEBUG
print_expr("init-expr after cast", expr);
#endif DEBUG
if (expr->ex_class == Float)
C_con_fcon(expr->FL_VALUE, expr->ex_type->tp_size);
else
if (expr->ex_class == Oper && expr->OP_OPER == INT2FLOAT) {
/* float f = 1; */
expr = expr->OP_RIGHT;
if (is_cp_cst(expr))
C_con_fcon(long2str((long)expr->VL_VALUE, 10),
tp->tp_size);
else
illegal_init_cst(expr);
}
else
illegal_init_cst(expr);
break;
#endif NOFLOAT
#ifndef NOBITFIELD
case FIELD:
ch7cast(&ex, '=', tp->tp_up);
expr = ex;
#ifdef DEBUG
print_expr("init-expr after cast", expr);
#endif DEBUG
if (is_cp_cst(expr))
put_bf(tp, expr->VL_VALUE);
else
illegal_init_cst(expr);
break;
#endif NOBITFIELD
case ERRONEOUS:
break;
default:
crash("check_ival");
}
}
/* ch_array() initialises an array of characters when given
a string constant.
Alignment is taken care of.
*/
ch_array(tpp, ex)
struct type **tpp; /* type tp = array of characters */
struct expr *ex;
{
register struct type *tp = *tpp;
register arith length = ex->SG_LEN;
char *s;
arith ntopad;
ASSERT(ex->ex_class == String);
if (tp->tp_size == (arith)-1) {
/* set the dimension */
tp = *tpp = construct_type(ARRAY, tp->tp_up, length);
ntopad = align(tp->tp_size, word_size) - tp->tp_size;
}
else {
arith dim = tp->tp_size / tp->tp_up->tp_size;
extern char options[];
if (length > dim) {
if (options['R'])
too_many_initialisers(ex);
else { /* don't take the null byte into account */
if (length > dim + 1)
expr_warning(ex,
"too many initialisers");
length = dim;
}
}
ntopad = align(dim, word_size) - length;
}
/* throw out the characters of the already prepared string */
s = Malloc((unsigned) (length + ntopad));
clear(s, (int) (length + ntopad));
strncpy(s, ex->SG_VALUE, (int) length);
free(ex->SG_VALUE);
str_cst(s, (int) (length + ntopad));
free(s);
}
/* As long as some parts of the pipeline cannot handle very long string
constants, string constants are written out in chunks
*/
str_cst(str, len)
register char *str;
register int len;
{
arith chunksize = ((127 + word_size) / word_size) * word_size;
while (len > chunksize) {
C_con_scon(str, chunksize);
len -= chunksize;
str += chunksize;
}
C_con_scon(str, (arith) len);
}
#ifndef NOBITFIELD
/* put_bf() takes care of the initialisation of (bit-)field
selectors of a struct: each time such an initialisation takes place,
put_bf() is called instead of the normal code generating routines.
Put_bf() stores the given integral value into "field" and
"throws" the result of "field" out if the current selector
is the last of this number of fields stored at the same address.
*/
put_bf(tp, val)
struct type *tp;
arith val;
{
static long field = (arith)0;
static arith offset = (arith)-1;
register struct field *fd = tp->tp_field;
register struct sdef *sd = fd->fd_sdef;
static struct expr exp;
ASSERT(sd);
if (offset == (arith)-1) {
/* first bitfield in this field */
offset = sd->sd_offset;
exp.ex_type = tp->tp_up;
exp.ex_class = Value;
exp.VL_CLASS = Const;
}
if (val != 0) /* insert the value into "field" */
field |= (val & fd->fd_mask) << fd->fd_shift;
if (sd->sd_sdef == 0 || sd->sd_sdef->sd_offset != offset) {
/* the selector was the last stored at this address */
exp.VL_VALUE = field;
con_int(&exp);
field = (arith)0;
offset = (arith)-1;
}
}
#endif NOBITFIELD
int
zero_bytes(sd)
register struct sdef *sd;
{
/* fills the space between a selector of a struct
and the next selector of that struct with zero-bytes.
*/
register int n = sd->sd_sdef->sd_offset - sd->sd_offset -
size_of_type(sd->sd_type, "struct member");
register int count = n;
while (n-- > 0)
con_nullbyte();
return count;
}
int
valid_type(tp, str)
struct type *tp;
char *str;
{
if (tp->tp_size < 0) {
error("size of %s unknown", str);
return 0;
}
return 1;
}
con_int(ex)
register struct expr *ex;
{
register struct type *tp = ex->ex_type;
ASSERT(is_cp_cst(ex));
if (tp->tp_unsigned)
C_con_ucon(long2str((long)ex->VL_VALUE, -10), tp->tp_size);
else
C_con_icon(long2str((long)ex->VL_VALUE, 10), tp->tp_size);
}
illegal_init_cst(ex)
struct expr *ex;
{
expr_error(ex, "illegal initialisation constant");
}
too_many_initialisers(ex)
struct expr *ex;
{
expr_error(ex, "too many initialisers");
}
aggregate_type(tp)
register struct type *tp;
{
return tp->tp_fund == ARRAY || tp->tp_fund == STRUCT;
}

52
lang/cem/cemcom/macro.h
View File

@@ -1,52 +0,0 @@
/* $Header$ */
/* PREPROCESSOR: DEFINITION OF MACRO DESCRIPTOR */
#include "nopp.h"
#ifndef NOPP
/* The flags of the mc_flag field of the macro structure. Note that
these flags can be set simultaneously.
*/
#define NOFLAG 0 /* no special flags */
#define FUNC 01 /* function attached */
#define PREDEF 02 /* predefined macro */
#define FORMALP 0200 /* mask for creating macro formal parameter */
/* The macro descriptor is very simple, except the fact that the
mc_text, which points to the replacement text, contains the
non-ascii characters \201, \202, etc, indicating the position of a
formal parameter in this text.
*/
struct macro {
struct macro *next;
char * mc_text; /* the replacement text */
int mc_nps; /* number of formal parameters */
int mc_length; /* length of replacement text */
char mc_flag; /* marking this macro */
};
/* allocation definitions of struct macro */
/* ALLOCDEF "macro" */
extern char *st_alloc();
extern struct macro *h_macro;
#define new_macro() ((struct macro *) \
st_alloc((char **)&h_macro, sizeof(struct macro)))
#define free_macro(p) st_free(p, h_macro, sizeof(struct macro))
/* `token' numbers of keywords of command-line processor
*/
#define K_UNKNOWN 0
#define K_DEFINE 1
#define K_ELIF 2
#define K_ELSE 3
#define K_ENDIF 4
#define K_IF 5
#define K_IFDEF 6
#define K_IFNDEF 7
#define K_INCLUDE 8
#define K_LINE 9
#define K_UNDEF 10
#endif NOPP

19
lang/cem/cemcom/make.emfun
View File

@@ -1,19 +0,0 @@
ed - $1 <<'--EOI--'
g/^%/d
g/^ /.-1,.j
1,$s/^\([^|]*\)|\([^|]*\)|\(.*\)$/\
\1 \2 {\
\3;\
}/
1i
/* EM COMPACT CODE -- PROCEDURAL INTERFACE (generated from emcode.def) */
#include "em.h"
#ifdef PROC_INTF
#include "label.h"
#include "arith.h"
.
$a
#endif PROC_INTF
.
1,$p
--EOI--

10
lang/cem/cemcom/make.emmac
View File

@@ -1,10 +0,0 @@
ed - $1 <<'--EOI--'
g/^%/d
g/^ /.-1,.j
1,$s/^\([^|]*\)|[^|]*|\(.*\)$/\
#define \1 (\2)/
1i
/* EM COMPACT CODE -- MACRO DEFINITIONS (generated from emcode.def) */
.
1,$p
--EOI--

46
lang/cem/cemcom/stack.h
View File

@@ -1,46 +0,0 @@
/* $Header$ */
/* IDENTIFIER STACK DEFINITIONS */
/* The identifier stack is implemented as a stack of sets.
The stack is implemented by a doubly linked list,
the sets by singly linked lists.
*/
struct stack_level {
struct stack_level *next;
struct stack_level *sl_next; /* upward link */
struct stack_level *sl_previous; /* downward link */
struct stack_entry *sl_entry; /* sideward link */
arith sl_local_offset; /* @ for first coming object */
arith sl_max_block; /* maximum size of sub-block */
int sl_level;
};
/* allocation definitions of struct stack_level */
/* ALLOCDEF "stack_level" */
extern char *st_alloc();
extern struct stack_level *h_stack_level;
#define new_stack_level() ((struct stack_level *) \
st_alloc((char **)&h_stack_level, sizeof(struct stack_level)))
#define free_stack_level(p) st_free(p, h_stack_level, sizeof(struct stack_level))
struct stack_entry {
struct stack_entry *next;
struct idf *se_idf;
};
/* allocation definitions of struct stack_entry */
/* ALLOCDEF "stack_entry" */
extern char *st_alloc();
extern struct stack_entry *h_stack_entry;
#define new_stack_entry() ((struct stack_entry *) \
st_alloc((char **)&h_stack_entry, sizeof(struct stack_entry)))
#define free_stack_entry(p) st_free(p, h_stack_entry, sizeof(struct stack_entry))
extern struct stack_level *local_level;
extern struct stack_level *stack_level_of();
extern int level;

67
lang/cem/cemcom/storage.c
View File

@@ -1,67 +0,0 @@
/* $Header$ */
/* S T R U C T U R E - S T O R A G E M A N A G E M E N T */
/* Assume that each structure contains a field "next", of pointer
type, as first tagfield.
struct xxx serves as a general structure: it just declares the
tagfield "next" as first field of a structure.
Please don't worry about any warnings when compiling this file
because some dirty tricks are performed to obtain the necessary
actions.
*/
#include "debug.h" /* UF */
#include "botch_free.h" /* UF */
#include "assert.h"
#include "alloc.h"
#include "storage.h"
struct xxx {
char *next;
};
char *
head_alloc(phead, size)
char **phead;
int size;
{
struct xxx *tmp;
if (*phead == 0) {
return Malloc(size);
}
tmp = (struct xxx *) (*phead);
*phead = (char *) tmp->next;
return (char *) tmp;
}
/* instead of Calloc: */
clear(ptr, n)
char *ptr;
int n;
{
ASSERT((long)ptr % sizeof (long) == 0);
while (n >= sizeof (long)) { /* high-speed clear loop */
*(long *)ptr = 0L;
ptr += sizeof (long), n -= sizeof (long);
}
while (n--)
*ptr++ = '\0';
}
#ifdef BOTCH_FREE
botch(ptr, n)
char *ptr;
int n;
{ /* Writes garbage over n chars starting from ptr.
Used to check if freed memory is used inappropriately.
*/
ASSERT((long)ptr % sizeof (long) == 0);
while (n >= sizeof (long)) { /* high-speed botch loop */
*(long *)ptr = 025252525252L;
ptr += sizeof (long), n -= sizeof (long);
}
while (n--)
*ptr++ = '\252';
}
#endif BOTCH_FREE

23
lang/cem/cemcom/storage.h
View File

@@ -1,23 +0,0 @@
/* $Header$ */
/* S T R U C T U R E - S T O R A G E D E F I N I T I O N S */
/* Storage allocation is one of the most expensive operations in
the compiler and consequently much thought and experimentation
has gone into it. To simplify the hooking in of new super-fancy
algorithms, all allocating and freeing of storage for structs
goes through the macros
st_alloc(&head, size)
st_free(ptr, head, size)
which, hopefully, convey enough information.
*/
extern char *head_alloc();
#define st_alloc(headp, size) head_alloc((char **)headp, size)
#ifndef BOTCH_FREE
#define st_free(ptr, head, size) (ptr->next = head, head = ptr)
#else def BOTCH_FREE
#define st_free(ptr, head, size) (botch((char *)(ptr), size), \
ptr->next = head, head = ptr)
#endif BOTCH_FREE

277
lang/cem/cemcom/string.c
View File

@@ -1,277 +0,0 @@
/* $Header$ */
/* STRING MANIPULATION AND PRINT ROUTINES */
#include <system.h>
#include "string.h"
#include "nopp.h"
#include "str_params.h"
#include "arith.h"
doprnt(fp, fmt, argp)
File *fp;
char *fmt;
int argp[];
{
char buf[SSIZE];
sys_write(fp, buf, format(buf, fmt, (char *)argp));
}
/*VARARGS1*/
printf(fmt, args)
char *fmt;
char args;
{
char buf[SSIZE];
sys_write(STDOUT, buf, format(buf, fmt, &args));
}
/*VARARGS1*/
fprintf(fp, fmt, args)
File *fp;
char *fmt;
char args;
{
char buf[SSIZE];
sys_write(fp, buf, format(buf, fmt, &args));
}
/*VARARGS1*/
char *
sprintf(buf, fmt, args)
char *buf, *fmt;
char args;
{
buf[format(buf, fmt, &args)] = '\0';
return buf;
}
int
format(buf, fmt, argp)
char *buf, *fmt;
char *argp;
{
register char *pf = fmt, *pa = argp;
register char *pb = buf;
while (*pf) {
if (*pf == '%') {
register width, base, pad, npad;
char *arg;
char cbuf[2];
char *badformat = "<bad format>";
/* get padder */
if (*++pf == '0') {
pad = '0';
++pf;
}
else
pad = ' ';
/* get width */
width = 0;
while (*pf >= '0' && *pf <= '9')
width = 10 * width + *pf++ - '0';
/* get text and move pa */
if (*pf == 's') {
arg = *(char **)pa;
pa += sizeof(char *);
}
else
if (*pf == 'c') {
cbuf[0] = * (char *) pa;
cbuf[1] = '\0';
pa += sizeof(int);
arg = &cbuf[0];
}
else
if (*pf == 'l') {
/* alignment ??? */
if (base = integral(*++pf)) {
arg = int_str(*(long *)pa, base);
pa += sizeof(long);
}
else {
pf--;
arg = badformat;
}
}
else
if (base = integral(*pf)) {
arg = int_str((long)*(int *)pa, base);
pa += sizeof(int);
}
else
if (*pf == '%')
arg = "%";
else
arg = badformat;
npad = width - strlen(arg);
while (npad-- > 0)
*pb++ = pad;
while (*pb++ = *arg++);
pb--;
pf++;
}
else
*pb++ = *pf++;
}
return pb - buf;
}
integral(c)
{
switch (c) {
case 'b':
return -2;
case 'd':
return 10;
case 'o':
return -8;
case 'u':
return -10;
case 'x':
return -16;
}
return 0;
}
/* Integer to String translator
*/
char *
int_str(val, base)
register long val;
register base;
{
/* int_str() is a very simple integer to string converter.
base < 0 : unsigned.
base must be an element of [-16,-2] V [2,16].
*/
static char numbuf[MAXWIDTH];
static char vec[] = "0123456789ABCDEF";
register char *p = &numbuf[MAXWIDTH];
int sign = (base > 0);
*--p = '\0'; /* null-terminate string */
if (val) {
if (base > 0) {
if (val < (arith)0) {
if ((val = -val) < (arith)0)
goto overflow;
}
else
sign = 0;
}
else
if (base < 0) { /* unsigned */
base = -base;
if (val < (arith)0) {
register mod, i;
overflow:
/* this takes a rainy Sunday afternoon to explain */
/* ??? */
mod = 0;
for (i = 0; i < 8 * sizeof val; i++) {
mod <<= 1;
if (val < 0)
mod++;
val <<= 1;
if (mod >= base) {
mod -= base;
val++;
}
}
*--p = vec[mod];
}
}
do {
*--p = vec[(int) (val % base)];
val /= base;
} while (val != (arith)0);
if (sign)
*--p = '-'; /* don't forget it !! */
}
else
*--p = '0'; /* just a simple 0 */
return p;
}
/* return negative, zero or positive value if
resp. s < t, s == t or s > t
*/
int
strcmp(s, t)
register char *s, *t;
{
while (*s == *t++)
if (*s++ == '\0')
return 0;
return *s - *--t;
}
/* return length of s
*/
int
strlen(s)
char *s;
{
register char *b = s;
while (*b++)
;
return b - s - 1;
}
#ifndef NOPP
/* append t to s
*/
char *
strcat(s, t)
register char *s, *t;
{
register char *b = s;
while (*s++)
;
s--;
while (*s++ = *t++)
;
return b;
}
/* Copy t into s
*/
char *
strcpy(s, t)
register char *s, *t;
{
register char *b = s;
while (*s++ = *t++)
;
return b;
}
char *
rindex(str, chr)
register char *str, chr;
{
register char *retptr = 0;
while (*str)
if (*str++ == chr)
retptr = &str[-1];
return retptr;
}
#endif NOPP

13
lang/cem/cemcom/string.h
View File

@@ -1,13 +0,0 @@
/* $Header$ */
/* STRING-ROUTINE DEFINITIONS */
#define stdin 0
#define stdout 1
#define stderr 2
#define itos(n) int_str((long)(n), 10)
char *sprintf(); /* string.h */
char *int_str(); /* string.h */
char *strcpy(), *strcat(), *rindex();

44
lang/cem/cemcom/struct.h
View File

@@ -1,44 +0,0 @@
/* $Header$ */
/* SELECTOR DESCRIPTOR */
struct sdef { /* for selectors */
struct sdef *next;
int sd_level;
struct idf *sd_idf; /* its name */
struct sdef *sd_sdef; /* the next selector */
struct type *sd_stype; /* the struct it belongs to */
struct type *sd_type; /* its type */
arith sd_offset;
};
extern char *st_alloc();
/* allocation definitions of struct sdef */
/* ALLOCDEF "sdef" */
extern char *st_alloc();
extern struct sdef *h_sdef;
#define new_sdef() ((struct sdef *) \
st_alloc((char **)&h_sdef, sizeof(struct sdef)))
#define free_sdef(p) st_free(p, h_sdef, sizeof(struct sdef))
struct tag { /* for struct-, union- and enum tags */
struct tag *next;
int tg_level;
int tg_busy; /* non-zero during declaration of struct/union pack */
struct type *tg_type;
};
/* allocation definitions of struct tag */
/* ALLOCDEF "tag" */
extern char *st_alloc();
extern struct tag *h_tag;
#define new_tag() ((struct tag *) \
st_alloc((char **)&h_tag, sizeof(struct tag)))
#define free_tag(p) st_free(p, h_tag, sizeof(struct tag))
struct sdef *idf2sdef();

40
lang/cem/cemcom/switch.h
View File

@@ -1,40 +0,0 @@
/* $Header$ */
/* S W I T C H - T A B L E - S T R U C T U R E */
struct switch_hdr {
struct switch_hdr *next;
label sh_break;
label sh_default;
label sh_table;
int sh_nrofentries;
struct type *sh_type;
arith sh_lowerbd;
arith sh_upperbd;
struct case_entry *sh_entries;
};
/* allocation definitions of struct switch_hdr */
/* ALLOCDEF "switch_hdr" */
extern char *st_alloc();
extern struct switch_hdr *h_switch_hdr;
#define new_switch_hdr() ((struct switch_hdr *) \
st_alloc((char **)&h_switch_hdr, sizeof(struct switch_hdr)))
#define free_switch_hdr(p) st_free(p, h_switch_hdr, sizeof(struct switch_hdr))
struct case_entry {
struct case_entry *next;
label ce_label;
arith ce_value;
};
/* allocation definitions of struct case_entry */
/* ALLOCDEF "case_entry" */
extern char *st_alloc();
extern struct case_entry *h_case_entry;
#define new_case_entry() ((struct case_entry *) \
st_alloc((char **)&h_case_entry, sizeof(struct case_entry)))
#define free_case_entry(p) st_free(p, h_case_entry, sizeof(struct case_entry))

72
lang/cem/cemcom/system.c
View File

@@ -1,72 +0,0 @@
/* $Header$ */
/* SYSTEM DEPENDENT ROUTINES */
#include "system.h"
#include "inputtype.h"
#include <sys/stat.h>
extern long lseek();
int
xopen(name, flag, mode)
char *name;
{
if (name[0] == '-' && name[1] == '\0')
return (flag == OP_RDONLY) ? 0 : 1;
switch (flag) {
case OP_RDONLY:
return open(name, 0);
case OP_WRONLY:
return open(name, 1);
case OP_CREAT:
return creat(name, mode);
case OP_APPEND:
{
register fd;
if ((fd = open(name, 1)) < 0)
return -1;
lseek(fd, 0L, 2);
return fd;
}
}
/*NOTREACHED*/
}
int
xclose(fildes)
{
if (fildes != 0 && fildes != 1)
return close(fildes);
return -1;
}
#ifdef READ_IN_ONE
long
xfsize(fildes)
{
struct stat stbuf;
if (fstat(fildes, &stbuf) != 0)
return -1;
return stbuf.st_size;
}
#endif READ_IN_ONE
exit(n)
{
_exit(n);
}
xstop(how, stat)
{
switch (how) {
case S_ABORT:
abort();
case S_EXIT:
exit(stat);
}
/*NOTREACHED*/
}

34
lang/cem/cemcom/system.h
View File

@@ -1,34 +0,0 @@
/* $Header$ */
/* SYSTEM DEPENDANT DEFINITIONS */
#include <sys/types.h>
#include <errno.h>
#define OP_RDONLY 0 /* open for read */
#define OP_WRONLY 1 /* open for write */
#define OP_CREAT 2 /* create and open for write */
#define OP_APPEND 3 /* open for write at end */
#define sys_open(name, flag) xopen(name, flag, 0)
#define sys_close(fildes) xclose(fildes)
#define sys_read(fildes, buffer, nbytes) read(fildes, buffer, nbytes)
#define sys_write(fildes, buffer, nbytes) write(fildes, buffer, nbytes)
#define sys_creat(name, mode) xopen(name, OP_CREAT, mode)
#define sys_remove(name) unlink(name)
#define sys_fsize(fd) xfsize(fd)
#define sys_sbrk(incr) sbrk(incr)
#define sys_stop(how, stat) xstop(how, stat)
#define S_ABORT 1
#define S_EXIT 2
char *sbrk();
long xfsize();
extern int errno;
#define sys_errno errno
#define time_type time_t
#define sys_time(tloc) time(tloc)
time_type time();

52
lang/cem/cemcom/type.h
View File

@@ -1,52 +0,0 @@
/* $Header$ */
/* TYPE DESCRIPTOR */
#include "nobitfield.h"
struct type {
struct type *next; /* used only with ARRAY */
short tp_fund; /* fundamental type */
char tp_unsigned;
int tp_align;
arith tp_size; /* -1 if declared but not defined */
struct idf *tp_idf; /* name of STRUCT, UNION or ENUM */
struct sdef *tp_sdef; /* to first selector */
struct type *tp_up; /* from FIELD, POINTER, ARRAY
or FUNCTION to fund. */
struct field *tp_field; /* field descriptor if fund == FIELD */
struct type *tp_pointer;/* to POINTER */
struct type *tp_array; /* to ARRAY */
struct type *tp_function;/* to FUNCTION */
};
extern struct type
*create_type(), *standard_type(), *construct_type(), *pointer_to(),
*array_of(), *function_of();
#ifndef NOBITFIELD
extern struct type *field_of();
#endif NOBITFIELD
extern struct type
*char_type, *uchar_type,
*short_type, *ushort_type,
*word_type, *uword_type,
*int_type, *uint_type,
*long_type, *ulong_type,
*float_type, *double_type,
*void_type, *label_type,
*string_type, *funint_type, *error_type;
extern struct type *pa_type; /* type.c */
extern arith size_of_type(), align();
/* allocation definitions of struct type */
/* ALLOCDEF "type" */
extern char *st_alloc();
extern struct type *h_type;
#define new_type() ((struct type *) \
st_alloc((char **)&h_type, sizeof(struct type)))
#define free_type(p) st_free(p, h_type, sizeof(struct type))

72
lang/cem/ctest/ctgen/id.cem.g
View File

@@ -1,72 +0,0 @@
(-40) + 300
(-40) - 300
(-40) / 300
(-40) * 300
(-40) || 300
(-40) && 300
-(-40)
!(-40)
(-40) == 300
(-40) != 300
(-40) <= 300
(-40) >= 300
(-40) < 300
(-40) > 300
(-40) ? (-40) : 300
x = (-40) -4.000000e+01
x += (-40) -3.685850e+01
x -= (-40) 4.314150e+01
x /= (-40) -7.853750e-02
x *= (-40) -1.256600e+02
x ++ 4.141500e+00
x -- 2.141500e+00
-- x 2.141500e+00
++ x 4.141500e+00
y = ( (-40) + 300 ) 17538
y = ( (-40) - 300 ) 50346
y = ( (-40) / 300 ) 0
y = ( (-40) * 300 ) -2147432645
y = ( (-40) || 300 ) 16512
y = ( (-40) && 300 ) 16512
y = ( -(-40) ) 17184
y = ( !(-40) ) 0
y = ( (-40) == 300 ) 0
y = ( (-40) != 300 ) 16512
y = ( (-40) <= 300 ) 16512
y = ( (-40) >= 300 ) 0
y = ( (-40) < 300 ) 16512
y = ( (-40) > 300 ) 0
y = ( (-40) ? (-40) : 300 ) 49952
y = ( x = (-40) ) -4.000000e+01 49952
y = ( x += (-40) ) -3.685850e+01 1864024851
y = ( x -= (-40) ) 4.314150e+01 -1864023252
y = ( x /= (-40) ) -7.853750e-02 -666583392
y = ( x *= (-40) ) -1.256600e+02 1374405627
y = ( x ++ ) 4.141500e+00 240533833
y = ( x -- ) 2.141500e+00 240533833
y = ( -- x ) 2.141500e+00 240533769
y = ( ++ x ) 4.141500e+00 -2027208316
yes if ( (-40) + 300 ) yes() ; else no()
yes if ( (-40) - 300 ) yes() ; else no()
no if ( (-40) / 300 ) yes() ; else no()
yes if ( (-40) * 300 ) yes() ; else no()
yes if ( (-40) || 300 ) yes() ; else no()
yes if ( (-40) && 300 ) yes() ; else no()
yes if ( -(-40) ) yes() ; else no()
no if ( !(-40) ) yes() ; else no()
no if ( (-40) == 300 ) yes() ; else no()
yes if ( (-40) != 300 ) yes() ; else no()
yes if ( (-40) <= 300 ) yes() ; else no()
no if ( (-40) >= 300 ) yes() ; else no()
yes if ( (-40) < 300 ) yes() ; else no()
no if ( (-40) > 300 ) yes() ; else no()
yes if ( (-40) ? (-40) : 300 ) yes() ; else no()
yes if ( x = (-40) ) yes() ; else no() -4.000000e+01
yes if ( x += (-40) ) yes() ; else no() -3.685850e+01
yes if ( x -= (-40) ) yes() ; else no() 4.314150e+01
yes if ( x /= (-40) ) yes() ; else no() -7.853750e-02
yes if ( x *= (-40) ) yes() ; else no() -1.256600e+02
yes if ( x ++ ) yes() ; else no() 4.141500e+00
yes if ( x -- ) yes() ; else no() 2.141500e+00
yes if ( -- x ) yes() ; else no() 2.141500e+00
yes if ( ++ x ) yes() ; else no() 4.141500e+00

3
lang/cem/ctest/ctill/noarg.cem.g
View File

@@ -1,3 +0,0 @@
The program whose output you are comparing this file with should
not have compiled.
It declares a function, with an argument and without a body.

152
lang/cem/ctest/ctstruct/str.pcc.r
View File

@@ -1,152 +0,0 @@
w1
st2.w1_i 506
(*st3).w1_i 506
st1.w1_i 711
st2.w1_i 711
es2[2].w1_i 711
st2.w1_i 577
st2.w1_i -577
st1.w1_i 577
w2
s2t2: .w2_i 18000 .w2_d 3.141500
s2t3->w2_d 3.141500
w3
s3t2.w3_a[ 0] a
s3t2.w3_a[ 1] b
s3t2.w3_a[ 2] c
s3t2.w3_a[ 3] d
s3t2.w3_a[ 4] e
s3t2.w3_a[ 5] f
s3t2.w3_a[ 6] g
s3t2.w3_a[ 7] h
s3t2.w3_a[ 8] i
s3t2.w3_a[ 9] j
s3t2.w3_a[10] k
s3t2.w3_a[11] l
s3t2.w3_a[12] m
s3t2.w3_a[13] n
s3t2.w3_a[14] o
s3t2.w3_a[15] p
s3t2.w3_a[16] q
s3t2.w3_a[17] r
s3t2.w3_a[18] s
s3t2.w3_a[19] t
s3t2.w3_a[20] u
s3t2.w3_a[21] v
s3t2.w3_a[22] w
s3t2.w3_a[23] x
s3t2.w3_a[24] y
s3t2.w3_a[25] z
s3t2.w3_x 1.000000
s3t1.w3_a[ 0] A
s3t1.w3_a[ 1] B
s3t1.w3_a[ 2] C
s3t1.w3_a[ 3] D
s3t1.w3_a[ 4] E
s3t1.w3_a[ 5] F
s3t1.w3_a[ 6] G
s3t1.w3_a[ 7] H
s3t1.w3_a[ 8] I
s3t1.w3_a[ 9] J
s3t1.w3_a[10] K
s3t1.w3_a[11] L
s3t1.w3_a[12] M
s3t1.w3_a[13] N
s3t1.w3_a[14] O
s3t1.w3_a[15] P
s3t1.w3_a[16] Q
s3t1.w3_a[17] R
s3t1.w3_a[18] S
s3t1.w3_a[19] T
s3t1.w3_a[20] U
s3t1.w3_a[21] V
s3t1.w3_a[22] W
s3t1.w3_a[23] X
s3t1.w3_a[24] Y
s3t1.w3_a[25] Z
s3t1.w3_x 0.318319
structure parameters
before -1
str.w3_a[ 0] 1
str.w3_a[ 1] 2
str.w3_a[ 2] 3
str.w3_a[ 3] 4
str.w3_a[ 4] 5
str.w3_a[ 5] 6
str.w3_a[ 6] 7
str.w3_a[ 7] 8
str.w3_a[ 8] 9
str.w3_a[ 9] 10
str.w3_a[10] 11
str.w3_a[11] 12
str.w3_a[12] 13
str.w3_a[13] 14
str.w3_a[14] 15
str.w3_a[15] 16
str.w3_a[16] 17
str.w3_a[17] 18
str.w3_a[18] 19
str.w3_a[19] 20
str.w3_a[20] 21
str.w3_a[21] 22
str.w3_a[22] 23
str.w3_a[23] 24
str.w3_a[24] 25
str.w3_a[25] 26
str.w3_x 2.810000
after 1000
Stucture valued functions
myp.w3_a:
0 97
1 96
2 95
3 94
4 93
5 92
6 91
7 90
8 89
9 88
10 87
11 86
12 85
13 84
14 83
15 82
16 81
17 80
18 79
19 78
20 77
21 76
22 75
23 74
24 73
25 72
0 99
1 100
2 101
3 102
4 103
5 104
6 105
7 106
8 107
9 108
10 109
11 110
12 111
13 112
14 113
15 114
16 115
17 116
18 117
19 118
20 119
21 120
22 121
23 122
24 123
25 124

174
lang/cem/ctest/out.std
View File

@@ -1,174 +0,0 @@
Tue May 22 15:12:22 MDT 1984
***** ctconv
acc conv.c
conv.c
"conv.c", line 41: warning: Overflow in constant expression
running conv.cem
comparing conv
***** ctdecl
acc decl.c
decl.c
running decl.cem
comparing decl
***** ctdivers
acc ops.c
ops.c
running ops.cem
comparing ops
***** cterr
acc bugs.c
bugs.c
"bugs.c", line 92: warning: Overflow in constant expression
running bugs.cem
comparing bugs
9,$c9,$
< compl_ind
< END
---
> END
***** ctest1
acc test.c
test.c
running test.cem
comparing test
***** ctest2
acc t7.c
t7.c
"t7.c", line 161: warning: statement not reached
"t7.c", line 178: warning: statement not reached
"t7.c", line 182: warning: statement not reached
"t7.c", line 186: warning: statement not reached
"t7.c", line 190: warning: statement not reached
"t7.c", line 194: warning: statement not reached
"t7.c", line 198: warning: statement not reached
"t7.c", line 205: warning: statement not reached
"t7.c", line 207: warning: statement not reached
"t7.c", line 211: warning: statement not reached
"t7.c", line 213: warning: statement not reached
"t7.c", line 287: warning: statement not reached
"t7.c", line 294: warning: statement not reached
"t7.c", line 300: warning: statement not reached
"t7.c", line 307: warning: statement not reached
"t7.c", line 343: warning: statement not reached
"t7.c", line 344: warning: statement not reached
"t7.c", line 345: warning: statement not reached
"t7.c", line 346: warning: statement not reached
"t7.c", line 348: warning: statement not reached
"t7.c", line 452: warning: statement not reached
"t7.c", line 561: warning: statement not reached
"t7.c", line 589: warning: statement not reached
running t7.cem
comparing t7
***** ctest3
acc test2.c
test2.c
running test2.cem
comparing test2
***** ctest5
acc test1.c
test1.c
"test1.c", line 101: warning: Illegal shift count in constant expression
"test1.c", line 370: warning: illegal pointer combination
"test1.c", line 371: warning: illegal pointer combination
"test1.c", line 372: warning: illegal pointer combination
"test1.c", line 384: warning: illegal pointer combination
"test1.c", line 407: warning: illegal pointer combination
"test1.c", line 408: warning: illegal pointer combination
"test1.c", line 409: warning: illegal pointer combination
"test1.c", line 421: warning: illegal pointer combination
running test1.cem
comparing test1
***** ctgen
`bf.c' is up to date.
acc bf.c
bf.c
running bf.cem
comparing bf
`cel.c' is up to date.
acc cel.c
cel.c
running cel.cem
comparing cel
`clu.c' is up to date.
acc clu.c
clu.c
"clu.c", line 60: warning: Overflow in constant expression
"clu.c", line 66: warning: Overflow in constant expression
running clu.cem
comparing clu
28c28
< x *= 40000 0
---
> x *= 40000 6784
65c65
< y = ( x *= 40000 ) 0 0
---
> y = ( x *= 40000 ) 6784 6784
102c102
< no if ( x *= 40000 ) yes() ; else no() 0
---
> yes if ( x *= 40000 ) yes() ; else no() 6784
`ec.c' is up to date.
acc ec.c
ec.c
"ec.c", line 58: warning: Overflow in constant expression
"ec.c", line 64: warning: Overflow in constant expression
running ec.cem
comparing ec
`ef.c' is up to date.
acc ef.c
ef.c
running ef.cem
comparing ef
`ei.c' is up to date.
acc ei.c
ei.c
"ei.c", line 22: warning: Overflow in constant expression
"ei.c", line 65: warning: Overflow in constant expression
"ei.c", line 108: warning: Overflow in constant expression
running ei.cem
comparing ei
`el.c' is up to date.
acc el.c
el.c
running el.cem
comparing el
`eu.c' is up to date.
acc eu.c
eu.c
"eu.c", line 58: warning: Overflow in constant expression
"eu.c", line 64: warning: Overflow in constant expression
running eu.cem
comparing eu
28c28
< x *= 40000 0
---
> x *= 40000 6784
65c65
< y = ( x *= 40000 ) 0 0
---
> y = ( x *= 40000 ) 6784 6784
102c102
< no if ( x *= 40000 ) yes() ; else no() 0
---
> yes if ( x *= 40000 ) yes() ; else no() 6784
`id.c' is up to date.
acc id.c
id.c
running id.cem
comparing id
`lc.c' is up to date.
acc lc.c
lc.c
"lc.c", line 60: warning: Overflow in constant expression
"lc.c", line 66: warning: Overflow in constant expression
running lc.cem
comparing lc
`ld.c' is up to date.
acc ld.c
ld.c
running ld.cem
comparing ld
`lf.c' is up to date.
acc lf.c
lf.c

3
lang/cem/libcc/.distr Normal file
View File

@@ -0,0 +1,3 @@
gen
mon
stdio

518
lang/m2/comp/LLlex.c
View File

@@ -1,518 +0,0 @@
/* L E X I C A L A N A L Y S E R F O R M O D U L A - 2 */
#include "debug.h"
#include "idfsize.h"
#include "numsize.h"
#include "strsize.h"
#include <alloc.h>
#include <em_arith.h>
#include <em_label.h>
#include <assert.h>
#include "input.h"
#include "f_info.h"
#include "Lpars.h"
#include "class.h"
#include "idf.h"
#include "type.h"
#include "LLlex.h"
#include "const.h"
#include "warning.h"
long str2long();
struct token dot,
aside;
struct type *toktype;
int idfsize = IDFSIZE;
#ifdef DEBUG
extern int cntlines;
#endif
static int eofseen;
STATIC
SkipComment()
{
/* Skip Modula-2 comments (* ... *).
Note that comments may be nested (par. 3.5).
*/
register int ch;
register int CommentLevel = 0;
LoadChar(ch);
for (;;) {
if (class(ch) == STNL) {
LineNumber++;
#ifdef DEBUG
cntlines++;
#endif
}
else if (ch == '(') {
LoadChar(ch);
if (ch == '*') CommentLevel++;
else continue;
}
else if (ch == '*') {
LoadChar(ch);
if (ch == ')') {
CommentLevel--;
if (CommentLevel < 0) break;
}
else continue;
}
else if (ch == EOI) {
lexerror("unterminated comment");
break;
}
LoadChar(ch);
}
}
STATIC struct string *
GetString(upto)
{
/* Read a Modula-2 string, delimited by the character "upto".
*/
register int ch;
register struct string *str = (struct string *)
Malloc((unsigned) sizeof(struct string));
register char *p;
register int len;
len = ISTRSIZE;
str->s_str = p = Malloc((unsigned int) ISTRSIZE);
while (LoadChar(ch), ch != upto) {
if (class(ch) == STNL) {
lexerror("newline in string");
LineNumber++;
#ifdef DEBUG
cntlines++;
#endif
break;
}
if (ch == EOI) {
lexerror("end-of-file in string");
break;
}
*p++ = ch;
if (p - str->s_str == len) {
str->s_str = Srealloc(str->s_str,
(unsigned int) len + RSTRSIZE);
p = str->s_str + len;
len += RSTRSIZE;
}
}
str->s_length = p - str->s_str;
while (p - str->s_str < len) *p++ = '\0';
if (str->s_length == 0) str->s_length = 1;
/* ??? string length at least 1 ??? */
return str;
}
static char *s_error = "illegal line directive";
STATIC int
getch()
{
register int ch;
for (;;) {
LoadChar(ch);
if ((ch & 0200) && ch != EOI) {
error("non-ascii '\\%03o' read", ch & 0377);
continue;
}
break;
}
if (ch == EOI) {
eofseen = 1;
return '\n';
}
return ch;
}
STATIC
linedirective() {
/* Read a line directive
*/
register int ch;
register int i = 0;
char buf[IDFSIZE + 2];
register char *c = buf;
do { /*
* Skip to next digit
* Do not skip newlines
*/
ch = getch();
if (class(ch) == STNL) {
LineNumber++;
error(s_error);
return;
}
} while (class(ch) != STNUM);
do {
i = i*10 + (ch - '0');
ch = getch();
} while (class(ch) == STNUM);
while (ch != '"' && class(ch) != STNL) ch = getch();
if (ch == '"') {
c = buf;
do {
*c++ = ch = getch();
if (class(ch) == STNL) {
LineNumber++;
error(s_error);
return;
}
} while (ch != '"');
*--c = '\0';
do {
ch = getch();
} while (class(ch) != STNL);
/*
* Remember the file name
*/
if (!eofseen && strcmp(FileName,buf)) {
FileName = Salloc(buf,(unsigned) strlen(buf) + 1);
}
}
if (eofseen) {
error(s_error);
return;
}
LineNumber = i;
}
int
LLlex()
{
/* LLlex() is the Lexical Analyzer.
The putting aside of tokens is taken into account.
*/
register struct token *tk = &dot;
char buf[(IDFSIZE > NUMSIZE ? IDFSIZE : NUMSIZE) + 2];
register int ch, nch;
toktype = error_type;
if (ASIDE) { /* a token is put aside */
*tk = aside;
ASIDE = 0;
return tk->tk_symb;
}
tk->tk_lineno = LineNumber;
again2:
if (eofseen) {
eofseen = 0;
ch = EOI;
}
else {
again:
LoadChar(ch);
again1:
if ((ch & 0200) && ch != EOI) {
error("non-ascii '\\%03o' read", ch & 0377);
goto again;
}
}
switch (class(ch)) {
case STNL:
LineNumber++;
#ifdef DEBUG
cntlines++;
#endif
tk->tk_lineno++;
LoadChar(ch);
if (ch != '#') goto again1;
linedirective();
goto again2;
case STSKIP:
goto again;
case STGARB:
if ((unsigned) ch - 040 < 0137) {
lexerror("garbage char %c", ch);
}
else lexerror("garbage char \\%03o", ch);
goto again;
case STSIMP:
if (ch == '(') {
LoadChar(nch);
if (nch == '*') {
SkipComment();
goto again;
}
else if (nch == EOI) eofseen = 1;
else PushBack();
}
return tk->tk_symb = ch;
case STCOMP:
LoadChar(nch);
switch (ch) {
case '.':
if (nch == '.') {
return tk->tk_symb = UPTO;
}
break;
case ':':
if (nch == '=') {
return tk->tk_symb = BECOMES;
}
break;
case '<':
if (nch == '=') {
return tk->tk_symb = LESSEQUAL;
}
if (nch == '>') {
lexwarning(W_STRICT, "'<>' is old-fashioned; use '#'");
return tk->tk_symb = '#';
}
break;
case '>':
if (nch == '=') {
return tk->tk_symb = GREATEREQUAL;
}
break;
default :
crash("(LLlex, STCOMP)");
}
if (nch == EOI) eofseen = 1;
else PushBack();
return tk->tk_symb = ch;
case STIDF:
{
register char *tag = &buf[0];
register struct idf *id;
do {
if (tag - buf < idfsize) *tag++ = ch;
LoadChar(ch);
} while(in_idf(ch));
if (ch == EOI) eofseen = 1;
else PushBack();
*tag++ = '\0';
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(ch);
if (str->s_length == 1) {
tk->TOK_INT = *(str->s_str) & 0377;
toktype = char_type;
free(str->s_str);
free((char *) str);
}
else {
tk->tk_data.tk_str = str;
toktype = standard_type(T_STRING, 1, str->s_length);
}
return tk->tk_symb = STRING;
}
case STNUM:
{
/* The problem arising with the "parsing" of a number
is that we don't know the base in advance so we
have to read the number with the help of a rather
complex finite automaton.
*/
enum statetp {Oct,Hex,Dec,OctEndOrHex,End,OptReal,Real};
register enum statetp state;
register int base;
register char *np = &buf[1];
/* allow a '-' to be added */
buf[0] = '-';
*np++ = ch;
state = is_oct(ch) ? Oct : Dec;
LoadChar(ch);
for (;;) {
switch(state) {
case Oct:
while (is_oct(ch)) {
if (np < &buf[NUMSIZE]) *np++ = ch;
LoadChar(ch);
}
if (ch == 'B' || ch == 'C') {
base = 8;
state = OctEndOrHex;
break;
}
/* Fall Through */
case Dec:
base = 10;
while (is_dig(ch)) {
if (np < &buf[NUMSIZE]) {
*np++ = ch;
}
LoadChar(ch);
}
if (is_hex(ch)) state = Hex;
else if (ch == '.') state = OptReal;
else {
state = End;
if (ch == 'H') base = 16;
else if (ch == EOI) eofseen = 1;
else PushBack();
}
break;
case Hex:
while (is_hex(ch)) {
if (np < &buf[NUMSIZE]) *np++ = ch;
LoadChar(ch);
}
base = 16;
state = End;
if (ch != 'H') {
lexerror("H expected after hex number");
if (ch == EOI) eofseen = 1;
else PushBack();
}
break;
case OctEndOrHex:
if (np < &buf[NUMSIZE]) *np++ = ch;
LoadChar(ch);
if (ch == 'H') {
base = 16;
state = End;
break;
}
if (is_hex(ch)) {
state = Hex;
break;
}
if (ch == EOI) eofseen = 1;
else PushBack();
ch = *--np;
*np++ = '\0';
base = 8;
/* Fall through */
case End:
*np = '\0';
if (np >= &buf[NUMSIZE]) {
tk->TOK_INT = 1;
lexerror("constant too long");
}
else {
np = &buf[1];
while (*np == '0') np++;
tk->TOK_INT = str2long(np, base);
if (strlen(np) > 14 /* ??? */ ||
tk->TOK_INT < 0) {
lexwarning(W_ORDINARY, "overflow in constant");
}
}
if (ch == 'C' && base == 8) {
toktype = char_type;
if (tk->TOK_INT<0 || tk->TOK_INT>255) {
lexwarning(W_ORDINARY, "character constant out of range");
}
}
else if (tk->TOK_INT>=0 &&
tk->TOK_INT<=max_int) {
toktype = intorcard_type;
}
else toktype = card_type;
return tk->tk_symb = INTEGER;
case OptReal:
/* The '.' could be the first of the '..'
token. At this point, we need a
look-ahead of two characters.
*/
LoadChar(ch);
if (ch == '.') {
/* Indeed the '..' token
*/
PushBack();
PushBack();
state = End;
base = 10;
break;
}
state = Real;
break;
}
if (state == Real) break;
}
/* a real real constant */
if (np < &buf[NUMSIZE]) *np++ = '.';
while (is_dig(ch)) {
/* Fractional part
*/
if (np < &buf[NUMSIZE]) *np++ = ch;
LoadChar(ch);
}
if (ch == 'E') {
/* Scale factor
*/
if (np < &buf[NUMSIZE]) *np++ = 'E';
LoadChar(ch);
if (ch == '+' || ch == '-') {
/* Signed scalefactor
*/
if (np < &buf[NUMSIZE]) *np++ = ch;
LoadChar(ch);
}
if (is_dig(ch)) {
do {
if (np < &buf[NUMSIZE]) *np++ = ch;
LoadChar(ch);
} while (is_dig(ch));
}
else {
lexerror("bad scale factor");
}
}
*np++ = '\0';
if (ch == EOI) eofseen = 1;
else PushBack();
if (np >= &buf[NUMSIZE]) {
tk->TOK_REL = Salloc("0.0", 5);
lexerror("floating constant too long");
}
else tk->TOK_REL = Salloc(buf, np - buf) + 1;
toktype = real_type;
return tk->tk_symb = REAL;
/*NOTREACHED*/
}
case STEOI:
return tk->tk_symb = -1;
case STCHAR:
default:
crash("(LLlex) Impossible character class");
/*NOTREACHED*/
}
/*NOTREACHED*/
}

36
lang/m2/comp/LLlex.h
View File

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

58
lang/m2/comp/LLmessage.c
View File

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

8
lang/m2/comp/MakeVersion
View File

@@ -1,8 +0,0 @@
V=`cat Version.c`
VERSION=`expr "$V" ':' '.*[0-9][0-9]*\.\([0-9][0-9]*\).*'`
NEWVERSION=`expr $VERSION + 1`
sed "s/\.$VERSION/.$NEWVERSION/" < Version.c > tmp$$
mv tmp$$ Version.c
CM "$*"
V=`cat Version.c`
SV > ../versions/V`expr "$V" ':' '.*\([0-9][0-9]*\.[0-9][0-9]*\).*'`

167
lang/m2/comp/Makefile
View File

@@ -1,167 +0,0 @@
# make modula-2 "compiler"
EMHOME = ../../..
MHDIR = $(EMHOME)/modules/h
PKGDIR = $(EMHOME)/modules/pkg
LIBDIR = $(EMHOME)/modules/lib
OBJECTCODE = $(LIBDIR)/libemk.a
LLGEN = $(EMHOME)/bin/LLgen
MKDEP = $(EMHOME)/bin/mkdep
PRID = $(EMHOME)/bin/prid
CID = $(EMHOME)/bin/cid
CURRDIR = .
INCLUDES = -I$(MHDIR) -I$(EMHOME)/h -I$(PKGDIR)
GFILES = tokenfile.g program.g declar.g expression.g statement.g
LLGENOPTIONS =
PROFILE =
CFLAGS = $(PROFILE) $(INCLUDES) -DSTATIC=
LINTFLAGS = -DSTATIC= -DNORCSID
MALLOC = $(LIBDIR)/malloc.o
LFLAGS = $(PROFILE)
LSRC = tokenfile.c program.c declar.c expression.c statement.c
LOBJ = tokenfile.o program.o declar.o expression.o statement.o
CSRC = LLlex.c LLmessage.c char.c error.c main.c \
symbol2str.c tokenname.c idf.c input.c type.c def.c \
scope.c misc.c enter.c defmodule.c typequiv.c node.c \
cstoper.c chk_expr.c options.c walk.c casestat.c desig.c \
code.c tmpvar.c lookup.c Version.c next.c
COBJ = LLlex.o LLmessage.o char.o error.o main.o \
symbol2str.o tokenname.o idf.o input.o type.o def.o \
scope.o misc.o enter.o defmodule.o typequiv.o node.o \
cstoper.o chk_expr.o options.o walk.o casestat.o desig.o \
code.o tmpvar.o lookup.o Version.o next.o
SRC = $(CSRC) $(LSRC) Lpars.c
OBJ = $(COBJ) $(LOBJ) Lpars.o
# Keep the next entries up to date!
GENCFILES= tokenfile.c \
program.c declar.c expression.c statement.c \
symbol2str.c char.c Lpars.c casestat.c tmpvar.c scope.c next.c
GENGFILES= tokenfile.g
GENHFILES= errout.h\
idfsize.h numsize.h strsize.h target_sizes.h \
inputtype.h maxset.h ndir.h density.h\
def.h debugcst.h type.h Lpars.h node.h
HFILES= LLlex.h\
chk_expr.h class.h const.h debug.h desig.h f_info.h idf.h\
input.h main.h misc.h scope.h standards.h tokenname.h\
walk.h warning.h $(GENHFILES)
#
GENFILES = $(GENGFILES) $(GENCFILES) $(GENHFILES)
NEXTFILES = def.H type.H node.H scope.C tmpvar.C casestat.C
#EXCLEXCLEXCLEXCL
all: Cfiles
sh -c 'if $(CC) nmclash.c > /dev/null 2>&1 ; then make $(CURRDIR)/main ; else sh Resolve main ; fi'
@rm -f nmclash.o a.out
install: all
cp $(CURRDIR)/main $(EMHOME)/lib/em_m2
clean:
rm -f $(OBJ) $(GENFILES) LLfiles hfiles Cfiles tab clashes $(CURRDIR)/main
(cd .. ; rm -rf Xsrc)
lint: Cfiles
sh -c 'if $(CC) nmclash.c > /dev/null 2>&1 ; then make Xlint ; else 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
echo $(SRC) $(HFILES) > Cfiles
LLfiles: $(GFILES)
$(LLGEN) $(LLGENOPTIONS) $(GFILES)
@touch LLfiles
hfiles: Parameters make.hfiles
make.hfiles Parameters
touch hfiles
tokenfile.g: tokenname.c make.tokfile
make.tokfile <tokenname.c >tokenfile.g
symbol2str.c: tokenname.c make.tokcase
make.tokcase <tokenname.c >symbol2str.c
.SUFFIXES: .H .h
.H.h:
./make.allocd < $*.H > $*.h
.SUFFIXES: .C .c
.C.c:
./make.allocd < $*.C > $*.c
def.h: make.allocd
type.h: make.allocd
node.h: make.allocd
scope.c: make.allocd
tmpvar.c: make.allocd
casestat.c: make.allocd
next.c: $(NEXTFILES) ./make.next
./make.next $(NEXTFILES) > next.c
char.c: char.tab tab
tab -fchar.tab >char.c
tab:
$(CC) tab.c -o tab
depend:
sed '/^#AUTOAUTO/,$$d' Makefile > Makefile.new
echo '#AUTOAUTOAUTOAUTOAUTOAUTOAUTOAUTO' >> Makefile.new
$(MKDEP) $(SRC) |\
sed 's/\.c:/\.o:/' >> Makefile.new
mv Makefile Makefile.old
mv Makefile.new Makefile
#INCLINCLINCLINCL
Xlint:
lint $(INCLUDES) $(LINTFLAGS) $(SRC)
$(CURRDIR)/main: $(OBJ)
$(CC) $(LFLAGS) $(OBJ) $(LIBDIR)/libem_mes.a $(OBJECTCODE) $(LIBDIR)/libinput.a $(LIBDIR)/libassert.a $(LIBDIR)/liballoc.a $(MALLOC) $(LIBDIR)/libprint.a $(LIBDIR)/libstring.a $(LIBDIR)/libsystem.a -o $(CURRDIR)/main
size $(CURRDIR)/main
#AUTOAUTOAUTOAUTOAUTOAUTOAUTOAUTO
LLlex.o: LLlex.h Lpars.h class.h const.h debug.h debugcst.h f_info.h idf.h idfsize.h input.h inputtype.h numsize.h strsize.h type.h warning.h
LLmessage.o: LLlex.h Lpars.h idf.h
char.o: class.h
error.o: LLlex.h debug.h debugcst.h errout.h f_info.h input.h inputtype.h main.h node.h warning.h
main.o: LLlex.h Lpars.h debug.h debugcst.h def.h f_info.h idf.h input.h inputtype.h ndir.h node.h scope.h standards.h tokenname.h type.h warning.h
symbol2str.o: Lpars.h
tokenname.o: Lpars.h idf.h tokenname.h
idf.o: idf.h
input.o: def.h f_info.h idf.h input.h inputtype.h scope.h
type.o: LLlex.h const.h debug.h debugcst.h def.h idf.h maxset.h node.h scope.h target_sizes.h type.h walk.h
def.o: LLlex.h Lpars.h debug.h debugcst.h def.h idf.h main.h node.h scope.h type.h
scope.o: LLlex.h debug.h debugcst.h def.h idf.h node.h scope.h type.h
misc.o: LLlex.h f_info.h idf.h misc.h node.h
enter.o: LLlex.h debug.h debugcst.h def.h idf.h main.h misc.h node.h scope.h type.h
defmodule.o: LLlex.h Lpars.h debug.h debugcst.h def.h f_info.h idf.h input.h inputtype.h main.h misc.h node.h scope.h type.h
typequiv.o: LLlex.h debug.h debugcst.h def.h node.h type.h warning.h
node.o: LLlex.h debug.h debugcst.h def.h node.h type.h
cstoper.o: LLlex.h Lpars.h debug.h debugcst.h idf.h node.h standards.h target_sizes.h type.h warning.h
chk_expr.o: LLlex.h Lpars.h chk_expr.h const.h debug.h debugcst.h def.h idf.h misc.h node.h scope.h standards.h type.h warning.h
options.o: idfsize.h main.h ndir.h type.h warning.h
walk.o: LLlex.h Lpars.h chk_expr.h debug.h debugcst.h def.h desig.h f_info.h idf.h main.h node.h scope.h type.h walk.h warning.h
casestat.o: LLlex.h Lpars.h debug.h debugcst.h density.h desig.h node.h type.h walk.h
desig.o: LLlex.h debug.h debugcst.h def.h desig.h node.h scope.h type.h
code.o: LLlex.h Lpars.h debug.h debugcst.h def.h desig.h node.h scope.h standards.h type.h walk.h
tmpvar.o: debug.h debugcst.h def.h main.h scope.h type.h
lookup.o: LLlex.h debug.h debugcst.h def.h idf.h misc.h node.h scope.h type.h
next.o: debug.h debugcst.h
tokenfile.o: Lpars.h
program.o: LLlex.h Lpars.h debug.h debugcst.h def.h f_info.h idf.h main.h node.h scope.h type.h warning.h
declar.o: LLlex.h Lpars.h chk_expr.h debug.h debugcst.h def.h idf.h main.h misc.h node.h scope.h type.h warning.h
expression.o: LLlex.h Lpars.h chk_expr.h const.h debug.h debugcst.h def.h idf.h node.h type.h warning.h
statement.o: LLlex.h Lpars.h def.h idf.h node.h scope.h type.h
Lpars.o: Lpars.h

65
lang/m2/comp/Parameters
View File

@@ -1,65 +0,0 @@
!File: errout.h
#define ERROUT STDERR /* file pointer for writing messages */
#define MAXERR_LINE 100 /* maximum number of error messages given
on the same input line. */
!File: idfsize.h
#define IDFSIZE 128 /* maximum significant length of an identifier */
!File: numsize.h
#define NUMSIZE 256 /* maximum length of a numeric constant */
!File: strsize.h
#define ISTRSIZE 32 /* minimum number of bytes allocated for
storing a string */
#define RSTRSIZE 8 /* step size in enlarging the memory for
the storage of a string */
!File: target_sizes.h
#define MAXSIZE 8 /* the maximum of the SZ_* constants */
/* target machine sizes */
#define SZ_CHAR (arith)1
#define SZ_SHORT (arith)2
#define SZ_WORD (arith)4
#define SZ_INT (arith)4
#define SZ_LONG (arith)4
#define SZ_FLOAT (arith)4
#define SZ_DOUBLE (arith)8
#define SZ_POINTER (arith)4
/* target machine alignment requirements */
#define AL_CHAR 1
#define AL_SHORT (int)SZ_SHORT
#define AL_WORD (int)SZ_WORD
#define AL_INT (int)SZ_WORD
#define AL_LONG (int)SZ_WORD
#define AL_FLOAT (int)SZ_WORD
#define AL_DOUBLE (int)SZ_WORD
#define AL_POINTER (int)SZ_WORD
#define AL_STRUCT 1
#define AL_UNION 1
!File: debugcst.h
#define DEBUG 1 /* perform various self-tests */
!File: inputtype.h
#define INP_READ_IN_ONE 1 /* read input file in one */
!File: maxset.h
#define MAXSET 1024 /* maximum number of elements in a set,
but what is a reasonable choice ???
*/
!File: ndir.h
#define NDIRS 16 /* maximum number of directories searched */
!File: density.h
#define DENSITY 3 /* see casestat.C for an explanation */

54
lang/m2/comp/Resolve
View File

@@ -1,54 +0,0 @@
: 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
;;
Xlint) target=$1
;;
*) echo "$0: $1: Illegal argument" 1>&2
exit 1
;;
esac
if test -d ../Xsrc
then
:
else mkdir ../Xsrc
fi
make 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 CURRDIR=$currdir $target

1
lang/m2/comp/Version.c
View File

@@ -1 +0,0 @@
static char Version[] = "ACK Modula-2 compiler Version 0.10";

309
lang/m2/comp/casestat.C
View File

@@ -1,309 +0,0 @@
/* C A S E S T A T E M E N T C O D E G E N E R A T I O N */
/* Generation of case statements is done by first creating a
description structure for the statement, build a list of the
case-labels, then generating a case description in the code,
and generating either CSA or CSB, and then generating code for the
cases themselves.
*/
#include "debug.h"
#include <em_label.h>
#include <em_arith.h>
#include <em_code.h>
#include <alloc.h>
#include <assert.h>
#include "Lpars.h"
#include "type.h"
#include "LLlex.h"
#include "node.h"
#include "desig.h"
#include "walk.h"
#include "density.h"
struct switch_hdr {
struct switch_hdr *next; /* in the free list */
label sh_break; /* label of statement after this one */
label sh_default; /* label of ELSE part, or 0 */
int sh_nrofentries; /* number of cases */
struct type *sh_type; /* type of case expression */
arith sh_lowerbd; /* lowest case label */
arith sh_upperbd; /* highest case label */
struct case_entry *sh_entries; /* the cases with their generated
labels
*/
};
/* STATICALLOCDEF "switch_hdr" 5 */
struct case_entry {
struct case_entry *next; /* next in list */
label ce_label; /* generated label */
arith ce_value; /* value of case label */
};
/* STATICALLOCDEF "case_entry" 20 */
/* The constant DENSITY determines when CSA and when CSB instructions
are generated. Reasonable values are: 2, 3, 4.
On machines that have lots of address space and memory, higher values
might also be reasonable. On these machines the density of jump tables
may be lower.
*/
#define compact(nr, low, up) (nr != 0 && (up - low) / nr <= DENSITY)
CaseCode(nd, exitlabel)
struct node *nd;
label exitlabel;
{
/* Check the expression, stack a new case header and
fill in the necessary fields.
"exitlabel" is the exit-label of the closest enclosing
LOOP-statement, or 0.
*/
register struct switch_hdr *sh = new_switch_hdr();
register struct node *pnode = nd;
register struct case_entry *ce;
register arith val;
label CaseDescrLab;
int casecnt = 0;
assert(pnode->nd_class == Stat && pnode->nd_symb == CASE);
WalkExpr(pnode->nd_left); /* evaluate case expression */
sh->sh_type = pnode->nd_left->nd_type;
sh->sh_break = ++text_label;
/* Now, create case label list
*/
while (pnode->nd_right) {
pnode = pnode->nd_right;
if (pnode->nd_class == Link && pnode->nd_symb == '|') {
if (pnode->nd_left) {
/* non-empty case
*/
pnode->nd_lab = ++text_label;
casecnt++;
if (! AddCases(sh, /* to descriptor */
pnode->nd_left->nd_left,
/* of case labels */
pnode->nd_lab
/* and code label */
)) {
FreeSh(sh);
return;
}
}
}
else {
/* Else part
*/
sh->sh_default = ++text_label;
break;
}
}
if (!casecnt) {
/* There were no cases, so we have to check the case-expression
here
*/
if (! (sh->sh_type->tp_fund & T_DISCRETE)) {
node_error(nd, "illegal type in CASE-expression");
FreeSh(sh);
return;
}
}
/* Now generate code for the switch itself
First the part that CSA and CSB descriptions have in common.
*/
CaseDescrLab = ++data_label; /* the rom must have a label */
C_df_dlb(CaseDescrLab);
if (sh->sh_default) C_rom_ilb(sh->sh_default);
else C_rom_ucon("0", pointer_size);
if (compact(sh->sh_nrofentries, sh->sh_lowerbd, sh->sh_upperbd)) {
/* CSA
*/
C_rom_cst(sh->sh_lowerbd);
C_rom_cst(sh->sh_upperbd - sh->sh_lowerbd);
ce = sh->sh_entries;
for (val = sh->sh_lowerbd; val <= sh->sh_upperbd; val++) {
assert(ce);
if (val == ce->ce_value) {
C_rom_ilb(ce->ce_label);
ce = ce->next;
}
else if (sh->sh_default) C_rom_ilb(sh->sh_default);
else C_rom_ucon("0", pointer_size);
}
C_lae_dlb(CaseDescrLab, (arith)0); /* perform the switch */
C_csa(word_size);
}
else {
/* CSB
*/
C_rom_cst((arith)sh->sh_nrofentries);
for (ce = sh->sh_entries; ce; ce = ce->next) {
/* generate the entries: value + prog.label
*/
C_rom_cst(ce->ce_value);
C_rom_ilb(ce->ce_label);
}
C_lae_dlb(CaseDescrLab, (arith)0); /* perform the switch */
C_csb(word_size);
}
/* Now generate code for the cases
*/
pnode = nd;
while (pnode->nd_right) {
pnode = pnode->nd_right;
if (pnode->nd_class == Link && pnode->nd_symb == '|') {
if (pnode->nd_left) {
C_df_ilb(pnode->nd_lab);
WalkNode(pnode->nd_left->nd_right, exitlabel);
C_bra(sh->sh_break);
}
}
else {
/* Else part
*/
assert(sh->sh_default != 0);
C_df_ilb(sh->sh_default);
WalkNode(pnode, exitlabel);
break;
}
}
C_df_ilb(sh->sh_break);
FreeSh(sh);
}
FreeSh(sh)
register struct switch_hdr *sh;
{
/* free the allocated switch structure
*/
register struct case_entry *ce;
ce = sh->sh_entries;
while (ce) {
struct case_entry *tmp = ce->next;
free_case_entry(ce);
ce = tmp;
}
free_switch_hdr(sh);
}
AddCases(sh, node, lbl)
struct switch_hdr *sh;
register struct node *node;
label lbl;
{
/* Add case labels to the case label list
*/
register arith v1, v2;
if (node->nd_class == Link) {
if (node->nd_symb == UPTO) {
assert(node->nd_left->nd_class == Value);
assert(node->nd_right->nd_class == Value);
v2 = node->nd_right->nd_INT;
node->nd_type = node->nd_left->nd_type;
for (v1 = node->nd_left->nd_INT; v1 <= v2; v1++) {
node->nd_INT = v1;
if (! AddOneCase(sh, node, lbl)) return 0;
}
return 1;
}
assert(node->nd_symb == ',');
return AddCases(sh, node->nd_left, lbl) &&
AddCases(sh, node->nd_right, lbl);
}
assert(node->nd_class == Value);
return AddOneCase(sh, node, lbl);
}
AddOneCase(sh, node, lbl)
register struct switch_hdr *sh;
register struct node *node;
label lbl;
{
register struct case_entry *ce = new_case_entry();
register struct case_entry *c1 = sh->sh_entries, *c2 = 0;
ce->ce_label = lbl;
ce->ce_value = node->nd_INT;
if (! TstCompat(sh->sh_type, node->nd_type)) {
node_error(node, "type incompatibility in case");
free_case_entry(ce);
return 0;
}
if (sh->sh_entries == 0) {
/* first case entry
*/
ce->next = (struct case_entry *) 0;
sh->sh_entries = ce;
sh->sh_lowerbd = sh->sh_upperbd = ce->ce_value;
sh->sh_nrofentries = 1;
}
else {
/* second etc. case entry
find the proper place to put ce into the list
*/
if (ce->ce_value < sh->sh_lowerbd) {
sh->sh_lowerbd = ce->ce_value;
}
else if (ce->ce_value > sh->sh_upperbd) {
sh->sh_upperbd = ce->ce_value;
}
while (c1 && c1->ce_value < ce->ce_value) {
c2 = c1;
c1 = c1->next;
}
/* At this point three cases are possible:
1: c1 != 0 && c2 != 0:
insert ce somewhere in the middle
2: c1 != 0 && c2 == 0:
insert ce right after the head
3: c1 == 0 && c2 != 0:
append ce to last element
The case c1 == 0 && c2 == 0 cannot occur, since
the list is guaranteed not to be empty.
*/
if (c1) {
if (c1->ce_value == ce->ce_value) {
node_error(node, "multiple case entry for value %ld", ce->ce_value);
free_case_entry(ce);
return 0;
}
if (c2) {
ce->next = c2->next;
c2->next = ce;
}
else {
ce->next = sh->sh_entries;
sh->sh_entries = ce;
}
}
else {
assert(c2);
ce->next = (struct case_entry *) 0;
c2->next = ce;
}
(sh->sh_nrofentries)++;
}
return 1;
}

54
lang/m2/comp/char.tab
View File

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

1223
lang/m2/comp/chk_expr.c
View File

File diff suppressed because it is too large Load Diff

11
lang/m2/comp/chk_expr.h
View File

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

36
lang/m2/comp/class.h
View File

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

1021
lang/m2/comp/code.c
View File

File diff suppressed because it is too large Load Diff

11
lang/m2/comp/const.h
View File

@@ -1,11 +0,0 @@
/* C O N S T A N T S F O R E X P R E S S I O N H A N D L I N G */
extern long
mach_long_sign; /* sign bit of the machine long */
extern int
mach_long_size; /* size of long on this machine == sizeof(long) */
extern arith
max_int, /* maximum integer on target machine */
max_unsigned, /* maximum unsigned on target machine */
max_longint, /* maximum longint on target machine */
wrd_bits; /* Number of bits in a word */

556
lang/m2/comp/cstoper.c
View File

@@ -1,556 +0,0 @@
/* C O N S T A N T E X P R E S S I O N H A N D L I N G */
#include "debug.h"
#include "target_sizes.h"
#include <em_arith.h>
#include <em_label.h>
#include <assert.h>
#include "idf.h"
#include "type.h"
#include "LLlex.h"
#include "node.h"
#include "Lpars.h"
#include "standards.h"
#include "warning.h"
long mach_long_sign; /* sign bit of the machine long */
int mach_long_size; /* size of long on this machine == sizeof(long) */
long full_mask[MAXSIZE];/* full_mask[1] == 0xFF, full_mask[2] == 0xFFFF, .. */
arith max_int; /* maximum integer on target machine */
arith max_unsigned; /* maximum unsigned on target machine */
arith max_longint; /* maximum longint on target machine */
arith wrd_bits; /* number of bits in a word */
static char ovflow[] = "overflow in constant expression";
cstunary(expp)
register struct node *expp;
{
/* The unary operation in "expp" is performed on the constant
expression below it, and the result restored in expp.
*/
register arith o1 = expp->nd_right->nd_INT;
switch(expp->nd_symb) {
/* Should not get here
case '+':
break;
*/
case '-':
o1 = -o1;
if (expp->nd_type->tp_fund == T_INTORCARD) {
expp->nd_type = int_type;
}
break;
case NOT:
case '~':
o1 = !o1;
break;
default:
crash("(cstunary)");
}
expp->nd_class = Value;
expp->nd_token = expp->nd_right->nd_token;
expp->nd_INT = o1;
CutSize(expp);
FreeNode(expp->nd_right);
expp->nd_right = 0;
}
cstbin(expp)
register struct node *expp;
{
/* The binary operation in "expp" is performed on the constant
expressions below it, and the result restored in
expp.
*/
register arith o1 = expp->nd_left->nd_INT;
register arith o2 = expp->nd_right->nd_INT;
register int uns = expp->nd_left->nd_type != int_type;
assert(expp->nd_class == Oper);
assert(expp->nd_left->nd_class == Value);
assert(expp->nd_right->nd_class == Value);
switch (expp->nd_symb) {
case '*':
o1 *= o2;
break;
case DIV:
if (o2 == 0) {
node_error(expp, "division by 0");
return;
}
if (uns) {
/* this is more of a problem than you might
think on C compilers which do not have
unsigned long.
*/
if (o2 & mach_long_sign) {/* o2 > max_long */
o1 = ! (o1 >= 0 || o1 < o2);
/* this is the unsigned test
o1 < o2 for o2 > max_long
*/
}
else { /* o2 <= max_long */
long half, bit, hdiv, hrem, rem;
half = (o1 >> 1) & ~mach_long_sign;
bit = o1 & 01;
/* now o1 == 2 * half + bit
and half <= max_long
and bit <= max_long
*/
hdiv = half / o2;
hrem = half % o2;
rem = 2 * hrem + bit;
o1 = 2 * hdiv + (rem < 0 || rem >= o2);
/* that is the unsigned compare
rem >= o2 for o2 <= max_long
*/
}
}
else
o1 /= o2;
break;
case MOD:
if (o2 == 0) {
node_error(expp, "modulo by 0");
return;
}
if (uns) {
if (o2 & mach_long_sign) {/* o2 > max_long */
o1 = (o1 >= 0 || o1 < o2) ? o1 : o1 - o2;
/* this is the unsigned test
o1 < o2 for o2 > max_long
*/
}
else { /* o2 <= max_long */
long half, bit, hrem, rem;
half = (o1 >> 1) & ~mach_long_sign;
bit = o1 & 01;
/* now o1 == 2 * half + bit
and half <= max_long
and bit <= max_long
*/
hrem = half % o2;
rem = 2 * hrem + bit;
o1 = (rem < 0 || rem >= o2) ? rem - o2 : rem;
}
}
else
o1 %= o2;
break;
case '+':
o1 += o2;
break;
case '-':
o1 -= o2;
if (expp->nd_type->tp_fund == T_INTORCARD) {
if (o1 < 0) expp->nd_type = int_type;
}
break;
case '<':
{ arith tmp = o1;
o1 = o2;
o2 = tmp;
}
/* Fall through */
case '>':
if (uns) {
o1 = (o1 & mach_long_sign ?
(o2 & mach_long_sign ? o1 > o2 : 1) :
(o2 & mach_long_sign ? 0 : o1 > o2)
);
}
else
o1 = (o1 > o2);
break;
case LESSEQUAL:
{ arith tmp = o1;
o1 = o2;
o2 = tmp;
}
/* Fall through */
case GREATEREQUAL:
if (uns) {
o1 = (o1 & mach_long_sign ?
(o2 & mach_long_sign ? o1 >= o2 : 1) :
(o2 & mach_long_sign ? 0 : o1 >= o2)
);
}
else
o1 = (o1 >= o2);
break;
case '=':
o1 = (o1 == o2);
break;
case '#':
o1 = (o1 != o2);
break;
case AND:
case '&':
o1 = (o1 && o2);
break;
case OR:
o1 = (o1 || o2);
break;
default:
crash("(cstbin)");
}
expp->nd_class = Value;
expp->nd_token = expp->nd_right->nd_token;
if (expp->nd_type == bool_type) expp->nd_symb = INTEGER;
expp->nd_INT = o1;
CutSize(expp);
FreeNode(expp->nd_left);
FreeNode(expp->nd_right);
expp->nd_left = expp->nd_right = 0;
}
cstset(expp)
register struct node *expp;
{
register arith *set1, *set2;
arith *resultset = 0;
register int setsize, j;
assert(expp->nd_right->nd_class == Set);
assert(expp->nd_symb == IN || expp->nd_left->nd_class == Set);
set2 = expp->nd_right->nd_set;
setsize = expp->nd_right->nd_type->tp_size / word_size;
if (expp->nd_symb == IN) {
arith i;
assert(expp->nd_left->nd_class == Value);
i = expp->nd_left->nd_INT;
expp->nd_class = Value;
expp->nd_INT = (i >= 0 && set2 != 0 &&
i < setsize * wrd_bits &&
(set2[i / wrd_bits] & (1 << (i % wrd_bits))));
if (set2) free((char *) set2);
}
else {
set1 = expp->nd_left->nd_set;
resultset = set1;
expp->nd_left->nd_set = 0;
switch(expp->nd_symb) {
case '+':
/* Set union
*/
if (!set1) {
resultset = set2;
expp->nd_right->nd_set = 0;
break;
}
if (set2) for (j = 0; j < setsize; j++) {
*set1++ |= *set2++;
}
break;
case '-':
/* Set difference
*/
if (!set1 || !set2) {
/* The set from which something is substracted
is already empty, or the set that is
substracted is empty. In either case, the
result set is set1.
*/
break;
}
for (j = 0; j < setsize; j++) {
*set1++ &= ~*set2++;
}
break;
case '*':
/* Set intersection
*/
if (!set1) {
/* set1 is empty, and so is the result set
*/
break;
}
if (!set2) {
/* set 2 is empty, so the result set must be
empty too.
*/
resultset = set2;
expp->nd_right->nd_set = 0;
break;
}
for (j = 0; j < setsize; j++) {
*set1++ &= *set2++;
}
break;
case '/':
/* Symmetric set difference
*/
if (!set1) {
resultset = set2;
expp->nd_right->nd_set = 0;
break;
}
if (set2) {
for (j = 0; j < setsize; j++) {
*set1++ ^= *set2++;
}
}
break;
case GREATEREQUAL:
case LESSEQUAL:
case '=':
case '#':
/* Constant set comparisons
*/
expp->nd_left->nd_set = set1; /* may be disposed of */
for (j = 0; j < setsize; j++) {
switch(expp->nd_symb) {
case GREATEREQUAL:
if (!set2) {j = setsize; break; }
if (!set1) break;
if ((*set1 | *set2++) != *set1) break;
set1++;
continue;
case LESSEQUAL:
if (!set1) {j = setsize; break; }
if (!set2) break;
if ((*set2 | *set1++) != *set2) break;
set2++;
continue;
case '=':
case '#':
if (!set1 && !set2) {
j = setsize; break;
}
if (!set1 || !set2) break;
if (*set1++ != *set2++) break;
continue;
}
if (j < setsize) {
expp->nd_INT = expp->nd_symb == '#';
}
else {
expp->nd_INT = expp->nd_symb != '#';
}
break;
}
expp->nd_class = Value;
expp->nd_symb = INTEGER;
if (expp->nd_left->nd_set) {
free((char *) expp->nd_left->nd_set);
}
if (expp->nd_right->nd_set) {
free((char *) expp->nd_right->nd_set);
}
FreeNode(expp->nd_left);
FreeNode(expp->nd_right);
expp->nd_left = expp->nd_right = 0;
return;
default:
crash("(cstset)");
}
if (expp->nd_right->nd_set) {
free((char *) expp->nd_right->nd_set);
}
if (expp->nd_left->nd_set) {
free((char *) expp->nd_left->nd_set);
}
expp->nd_class = Set;
expp->nd_set = resultset;
}
FreeNode(expp->nd_left);
FreeNode(expp->nd_right);
expp->nd_left = expp->nd_right = 0;
}
cstcall(expp, call)
register struct node *expp;
{
/* a standard procedure call is found that can be evaluated
compile time, so do so.
*/
register struct node *expr = 0;
assert(expp->nd_class == Call);
if (expp->nd_right) {
expr = expp->nd_right->nd_left;
expp->nd_right->nd_left = 0;
FreeNode(expp->nd_right);
}
expp->nd_class = Value;
expp->nd_symb = INTEGER;
switch(call) {
case S_ABS:
if (expr->nd_INT < 0) expp->nd_INT = - expr->nd_INT;
else expp->nd_INT = expr->nd_INT;
CutSize(expp);
break;
case S_CAP:
if (expr->nd_INT >= 'a' && expr->nd_INT <= 'z') {
expp->nd_INT = expr->nd_INT + ('A' - 'a');
}
else expp->nd_INT = expr->nd_INT;
CutSize(expp);
break;
case S_CHR:
expp->nd_INT = expr->nd_INT;
CutSize(expp);
break;
case S_MAX:
if (expp->nd_type == int_type) {
expp->nd_INT = max_int;
}
else if (expp->nd_type == longint_type) {
expp->nd_INT = max_longint;
}
else if (expp->nd_type == card_type) {
expp->nd_INT = max_unsigned;
}
else if (expp->nd_type->tp_fund == T_SUBRANGE) {
expp->nd_INT = expp->nd_type->sub_ub;
}
else expp->nd_INT = expp->nd_type->enm_ncst - 1;
break;
case S_MIN:
if (expp->nd_type == int_type) {
expp->nd_INT = (-max_int) - 1;
}
else if (expp->nd_type == longint_type) {
expp->nd_INT = (-max_longint) - 1;
}
else if (expp->nd_type->tp_fund == T_SUBRANGE) {
expp->nd_INT = expp->nd_type->sub_lb;
}
else expp->nd_INT = 0;
break;
case S_ODD:
expp->nd_INT = (expr->nd_INT & 1);
break;
case S_ORD:
expp->nd_INT = expr->nd_INT;
CutSize(expp);
break;
case S_SIZE:
expp->nd_INT = expr->nd_type->tp_size;
break;
case S_VAL:
expp->nd_INT = expr->nd_INT;
if ( /* Check overflow of subranges or enumerations */
( expp->nd_type->tp_fund == T_SUBRANGE
&&
( expp->nd_INT < expp->nd_type->sub_lb
|| expp->nd_INT > expp->nd_type->sub_ub
)
)
||
( expp->nd_type->tp_fund == T_ENUMERATION
&&
( expp->nd_INT < 0
|| expp->nd_INT >= expp->nd_type->enm_ncst
)
)
) node_warning(expp, W_ORDINARY, ovflow);
else CutSize(expp);
break;
default:
crash("(cstcall)");
}
FreeNode(expr);
FreeNode(expp->nd_left);
expp->nd_right = expp->nd_left = 0;
}
CutSize(expr)
register struct node *expr;
{
/* The constant value of the expression expr is made to
conform to the size of the type of the expression.
*/
register arith o1 = expr->nd_INT;
register struct type *tp = BaseType(expr->nd_type);
int uns;
int size = tp->tp_size;
assert(expr->nd_class == Value);
uns = (tp->tp_fund & (T_CARDINAL|T_CHAR));
if (uns) {
if (o1 & ~full_mask[size]) {
node_warning(expr, W_ORDINARY, ovflow);
o1 &= full_mask[size];
}
}
else {
int nbits = (int) (mach_long_size - size) * 8;
long remainder = o1 & ~full_mask[size];
if (remainder != 0 && remainder != ~full_mask[size]) {
node_warning(expr, W_ORDINARY, ovflow);
o1 <<= nbits;
o1 >>= nbits;
}
}
expr->nd_INT = o1;
}
InitCst()
{
register int i = 0;
register arith bt = (arith)0;
while (!(bt < 0)) {
bt = (bt << 8) + 0377, i++;
if (i == MAXSIZE)
fatal("array full_mask too small for this machine");
full_mask[i] = bt;
}
mach_long_size = i;
mach_long_sign = 1 << (mach_long_size * 8 - 1);
if (long_size > mach_long_size) {
fatal("sizeof (long) insufficient on this machine");
}
max_int = full_mask[int_size] & ~(1 << (int_size * 8 - 1));
max_unsigned = full_mask[int_size];
max_longint = full_mask[long_size] & ~(1 << (long_size * 8 - 1));
wrd_bits = 8 * word_size;
}

10
lang/m2/comp/debug.h
View File

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

546
lang/m2/comp/declar.g
View File

@@ -1,546 +0,0 @@
/* D E C L A R A T I O N S */
{
#include "debug.h"
#include <em_arith.h>
#include <em_label.h>
#include <alloc.h>
#include <assert.h>
#include "idf.h"
#include "LLlex.h"
#include "def.h"
#include "type.h"
#include "scope.h"
#include "node.h"
#include "misc.h"
#include "main.h"
#include "chk_expr.h"
#include "warning.h"
int proclevel = 0; /* nesting level of procedures */
int return_occurred; /* set if a return occurs in a block */
}
ProcedureDeclaration
{
struct def *df;
} :
{ ++proclevel; }
ProcedureHeading(&df, D_PROCEDURE)
';' block(&(df->prc_body))
IDENT
{ EndProc(df, dot.TOK_IDF);
--proclevel;
}
;
ProcedureHeading(struct def **pdf; int type;)
{
struct type *tp = 0;
#define needs_static_link() (proclevel > 1)
arith parmaddr = needs_static_link() ? pointer_size : 0;
struct paramlist *pr = 0;
} :
PROCEDURE IDENT
{ *pdf = DeclProc(type, dot.TOK_IDF); }
FormalParameters(&pr, &parmaddr, &tp)?
{ CheckWithDef(*pdf, proc_type(tp, pr, parmaddr));
if (tp && IsConstructed(tp)) {
warning(W_STRICT, "procedure \"%s\" has a constructed result type",
(*pdf)->df_idf->id_text);
}
}
;
block(struct node **pnd;) :
[ %persistent
declaration
]*
{ return_occurred = 0; *pnd = 0; }
[ %persistent
BEGIN
StatementSequence(pnd)
]?
END
;
declaration:
CONST [ %persistent ConstantDeclaration ';' ]*
|
TYPE [ %persistent TypeDeclaration ';' ]*
|
VAR [ %persistent VariableDeclaration ';' ]*
|
ProcedureDeclaration ';'
|
ModuleDeclaration ';'
;
FormalParameters(struct paramlist **ppr; arith *parmaddr; struct type **ptp;):
'('
[
FPSection(ppr, parmaddr)
[
';' FPSection(ppr, parmaddr)
]*
]?
')'
[ ':' qualtype(ptp)
]?
;
FPSection(struct paramlist **ppr; arith *parmaddr;)
{
struct node *FPList;
struct type *tp;
int VARp;
} :
var(&VARp) IdentList(&FPList) ':' FormalType(&tp)
{ EnterParamList(ppr, FPList, tp, VARp, parmaddr); }
;
FormalType(struct type **ptp;)
{
extern arith ArrayElSize();
} :
ARRAY OF qualtype(ptp)
{ register struct type *tp = construct_type(T_ARRAY, NULLTYPE);
tp->arr_elem = *ptp;
*ptp = tp;
tp->arr_elsize = ArrayElSize(tp->arr_elem);
tp->tp_align = tp->arr_elem->tp_align;
}
|
qualtype(ptp)
;
TypeDeclaration
{
struct def *df;
struct type *tp;
struct node *nd;
}:
IDENT { df = define(dot.TOK_IDF, CurrentScope, D_TYPE);
nd = MkLeaf(Name, &dot);
}
'=' type(&tp)
{ DeclareType(nd, df, tp);
free_node(nd);
}
;
type(struct type **ptp;):
%default SimpleType(ptp)
|
ArrayType(ptp)
|
RecordType(ptp)
|
SetType(ptp)
|
PointerType(ptp)
|
ProcedureType(ptp)
;
SimpleType(struct type **ptp;)
{
struct type *tp;
} :
qualtype(ptp)
[
/* nothing */
|
SubrangeType(&tp)
/* The subrange type is given a base type by the
qualident (this is new modula-2).
*/
{ chk_basesubrange(tp, *ptp); }
]
|
enumeration(ptp)
|
SubrangeType(ptp)
;
enumeration(struct type **ptp;)
{
struct node *EnumList;
} :
'(' IdentList(&EnumList) ')'
{ register struct type *tp =
standard_type(T_ENUMERATION, int_align, int_size);
*ptp = tp;
EnterEnumList(EnumList, tp);
if (ufit(tp->enm_ncst-1, 1)) {
tp->tp_size = 1;
tp->tp_align = 1;
}
else if (ufit(tp->enm_ncst-1, short_size)) {
tp->tp_size = short_size;
tp->tp_align = short_align;
}
}
;
IdentList(struct node **p;)
{
register struct node *q;
} :
IDENT { *p = q = MkLeaf(Value, &dot); }
[ %persistent
',' IDENT
{ q->next = MkLeaf(Value, &dot);
q = q->next;
}
]*
{ q->next = 0; }
;
SubrangeType(struct type **ptp;)
{
struct node *nd1, *nd2;
}:
/*
This is not exactly the rule in the new report, but see
the rule for "SimpleType".
*/
'[' ConstExpression(&nd1)
UPTO ConstExpression(&nd2)
']'
{ *ptp = subr_type(nd1, nd2);
free_node(nd1);
free_node(nd2);
}
;
ArrayType(struct type **ptp;)
{
struct type *tp;
register struct type *tp2;
} :
ARRAY SimpleType(&tp)
{ *ptp = tp2 = construct_type(T_ARRAY, tp); }
[
',' SimpleType(&tp)
{ tp2->arr_elem = construct_type(T_ARRAY, tp);
tp2 = tp2->arr_elem;
}
]* OF type(&tp)
{ tp2->arr_elem = tp;
ArraySizes(*ptp);
}
;
RecordType(struct type **ptp;)
{
register struct scope *scope;
arith size = 0;
int xalign = struct_align;
}
:
RECORD
{ open_scope(OPENSCOPE); /* scope for fields of record */
scope = CurrentScope;
close_scope(0);
}
FieldListSequence(scope, &size, &xalign)
{ if (size == 0) {
warning(W_ORDINARY, "empty record declaration");
size = 1;
}
*ptp = standard_type(T_RECORD, xalign, size);
(*ptp)->rec_scope = scope;
}
END
;
FieldListSequence(struct scope *scope; arith *cnt; int *palign;):
FieldList(scope, cnt, palign)
[
';' FieldList(scope, cnt, palign)
]*
;
FieldList(struct scope *scope; arith *cnt; int *palign;)
{
struct node *FldList;
register struct idf *id = 0;
struct type *tp;
struct node *nd1;
register struct node *nd;
arith tcnt, max;
} :
[
IdentList(&FldList) ':' type(&tp)
{ *palign = lcm(*palign, tp->tp_align);
EnterFieldList(FldList, tp, scope, cnt);
}
|
CASE
/* Also accept old fashioned Modula-2 syntax, but give a warning.
Sorry for the complicated code.
*/
[ qualident(&nd1)
{ nd = nd1; }
[ ':' qualtype(&tp)
/* This is correct, in both kinds of Modula-2, if
the first qualident is a single identifier.
*/
{ if (nd->nd_class != Name) {
error("illegal variant tag");
}
else id = nd->nd_IDF;
FreeNode(nd);
}
| /* Old fashioned! the first qualident now represents
the type
*/
{ warning(W_OLDFASHIONED, "old fashioned Modula-2 syntax; ':' missing");
if (ChkDesignator(nd) &&
(nd->nd_class != Def ||
!(nd->nd_def->df_kind&(D_ERROR|D_ISTYPE)) ||
!nd->nd_def->df_type)) {
node_error(nd, "type expected");
tp = error_type;
}
else tp = nd->nd_def->df_type;
FreeNode(nd);
}
]
| ':' qualtype(&tp)
/* Aha, third edition. Well done! */
]
{ if (id) {
register struct def *df = define(id,
scope,
D_FIELD);
if (!(tp->tp_fund & T_DISCRETE)) {
error("illegal type in variant");
}
df->df_type = tp;
df->fld_off = align(*cnt, tp->tp_align);
*cnt = df->fld_off + tp->tp_size;
df->df_flags |= D_QEXPORTED;
}
tcnt = *cnt;
}
OF variant(scope, &tcnt, tp, palign)
{ max = tcnt; tcnt = *cnt; }
[
'|' variant(scope, &tcnt, tp, palign)
{ if (tcnt > max) max = tcnt; tcnt = *cnt; }
]*
[ ELSE FieldListSequence(scope, &tcnt, palign)
{ if (tcnt > max) max = tcnt; }
]?
END
{ *cnt = max; }
]?
;
variant(struct scope *scope; arith *cnt; struct type *tp; int *palign;)
{
struct node *nd;
} :
[
CaseLabelList(&tp, &nd)
{ /* Ignore the cases for the time being.
Maybe a checking version will be supplied
later ??? (Improbable)
*/
FreeNode(nd);
}
':' FieldListSequence(scope, cnt, palign)
]?
/* Changed rule in new modula-2 */
;
CaseLabelList(struct type **ptp; struct node **pnd;):
CaseLabels(ptp, pnd)
[
{ *pnd = MkNode(Link, *pnd, NULLNODE, &dot); }
',' CaseLabels(ptp, &((*pnd)->nd_right))
{ pnd = &((*pnd)->nd_right); }
]*
;
CaseLabels(struct type **ptp; register struct node **pnd;)
{
register struct node *nd1;
}:
ConstExpression(pnd)
{ nd1 = *pnd; }
[
UPTO { *pnd = MkNode(Link,nd1,NULLNODE,&dot); }
ConstExpression(&(*pnd)->nd_right)
{ if (!TstCompat(nd1->nd_type,
(*pnd)->nd_right->nd_type)) {
node_error((*pnd)->nd_right,
"type incompatibility in case label");
nd1->nd_type = error_type;
}
}
]?
{ if (*ptp != 0 && !TstCompat(*ptp, nd1->nd_type)) {
node_error(nd1,
"type incompatibility in case label");
}
*ptp = nd1->nd_type;
}
;
SetType(struct type **ptp;) :
SET OF SimpleType(ptp)
{ *ptp = set_type(*ptp); }
;
/* In a pointer type definition, the type pointed at does not
have to be declared yet, so be careful about identifying
type-identifiers
*/
PointerType(struct type **ptp;)
{
register struct node *nd = 0;
} :
POINTER TO
{ *ptp = construct_type(T_POINTER, NULLTYPE); }
[ %if ( lookup(dot.TOK_IDF, CurrentScope, 1)
/* Either a Module or a Type, but in both cases defined
in this scope, so this is the correct identification
*/
||
( nd = new_node(),
nd->nd_token = dot,
lookfor(nd, CurrVis, 0)->df_kind == D_MODULE
)
/* A Modulename in one of the enclosing scopes.
It is not clear from the language definition that
it is correct to handle these like this, but
existing compilers do it like this, and the
alternative is difficult with a lookahead of only
one token.
???
*/
)
type(&((*ptp)->next))
{ if (nd) free_node(nd); }
|
IDENT { if (nd) {
/* nd could be a null pointer, if we had a
syntax error exactly at this alternation.
MORAL: Be careful with %if resolvers with
side effects!
*/
Forward(nd, (*ptp));
}
}
]
;
qualtype(struct type **ptp;)
{
register struct node *nd;
struct node *nd1; /* because &nd is illegal */
} :
qualident(&nd1)
{ nd = nd1;
*ptp = error_type;
if (ChkDesignator(nd)) {
if (nd->nd_class != Def) {
node_error(nd, "type expected");
}
else {
register struct def *df = nd->nd_def;
if (df->df_kind&(D_ISTYPE|D_FORWARD|D_ERROR)) {
if (! df->df_type) {
node_error(nd,"type \"%s\" not (yet) 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);
}
}
}
FreeNode(nd);
}
;
ProcedureType(struct type **ptp;)
{
struct paramlist *pr = 0;
arith parmaddr = 0;
}
:
{ *ptp = 0; }
PROCEDURE
[
FormalTypeList(&pr, &parmaddr, ptp)
]?
{ *ptp = proc_type(*ptp, pr, parmaddr); }
;
FormalTypeList(struct paramlist **ppr; arith *parmaddr; struct type **ptp;)
{
struct type *tp;
int VARp;
} :
'('
[
var(&VARp) FormalType(&tp)
{ EnterParamList(ppr,NULLNODE,tp,VARp,parmaddr); }
[
',' var(&VARp) FormalType(&tp)
{ EnterParamList(ppr,NULLNODE,tp,VARp,parmaddr); }
]*
]?
')'
[ ':' qualtype(ptp)
]?
;
var(int *VARp;):
VAR { *VARp = D_VARPAR; }
|
/* empty */ { *VARp = D_VALPAR; }
;
ConstantDeclaration
{
struct idf *id;
struct node *nd;
}:
IDENT { id = dot.TOK_IDF; }
'=' ConstExpression(&nd)
{ define(id,CurrentScope,D_CONST)->con_const = nd; }
;
VariableDeclaration
{
struct node *VarList;
register struct node *nd;
struct type *tp;
} :
IdentAddr(&VarList)
{ nd = VarList; }
[ %persistent
',' IdentAddr(&(nd->nd_right))
{ nd = nd->nd_right; }
]*
':' type(&tp)
{ EnterVarList(VarList, tp, proclevel > 0); }
;
IdentAddr(struct node **pnd;) :
IDENT { *pnd = MkLeaf(Name, &dot); }
[ '['
ConstExpression(&((*pnd)->nd_left))
']'
]?
;

135
lang/m2/comp/def.H
View File

@@ -1,135 +0,0 @@
/* I D E N T I F I E R D E S C R I P T O R S T R U C T U R E */
struct module {
struct node *mo_priority;/* priority of a module */
struct scopelist *mo_vis;/* scope of this module */
struct node *mo_body; /* body of this module */
#define mod_priority df_value.df_module.mo_priority
#define mod_vis df_value.df_module.mo_vis
#define mod_body df_value.df_module.mo_body
};
struct variable {
arith va_off; /* address or offset of variable */
char *va_name; /* name of variable if given */
char va_addrgiven; /* an address was given in the program */
#define var_off df_value.df_variable.va_off
#define var_name df_value.df_variable.va_name
#define var_addrgiven df_value.df_variable.va_addrgiven
};
struct constant {
struct node *co_const; /* result of a constant expression */
#define con_const df_value.df_constant.co_const
};
struct enumval {
unsigned int en_val; /* value of this enumeration literal */
struct def *en_next; /* next enumeration literal */
#define enm_val df_value.df_enum.en_val
#define enm_next df_value.df_enum.en_next
};
struct field {
arith fd_off;
struct variant {
struct caselabellist *v_cases;
label v_casedescr;
struct def *v_varianttag;
} *fd_variant;
#define fld_off df_value.df_field.fd_off
#define fld_variant df_value.df_field.fd_variant
};
struct dfproc {
struct scopelist *pr_vis; /* scope of procedure */
struct node *pr_body; /* body of this procedure */
#define prc_vis df_value.df_proc.pr_vis
#define prc_body df_value.df_proc.pr_body
#define NameOfProc(xdf) ((xdf)->prc_vis->sc_scope->sc_name)
};
struct import {
struct def *im_def; /* imported definition */
#define imp_def df_value.df_import.im_def
};
struct dforward {
struct scopelist *fo_vis;
struct node *fo_node;
char *fo_name;
#define for_node df_value.df_forward.fo_node
#define for_vis df_value.df_forward.fo_vis
#define for_name df_value.df_forward.fo_name
};
struct forwtype {
struct node *f_node;
struct type *f_type;
#define df_forw_type df_value.df_fortype.f_type
#define df_forw_node df_value.df_fortype.f_node
};
struct def { /* list of definitions for a name */
struct def *next; /* next definition in definitions chain */
struct def *df_nextinscope;
/* link all definitions in a scope */
struct idf *df_idf; /* link back to the name */
struct scope *df_scope; /* scope in which this definition resides */
unsigned short df_kind; /* the kind of this definition: */
#define D_MODULE 0x0001 /* a module */
#define D_PROCEDURE 0x0002 /* procedure of function */
#define D_VARIABLE 0x0004 /* a variable */
#define D_FIELD 0x0008 /* a field in a record */
#define D_TYPE 0x0010 /* a type */
#define D_ENUM 0x0020 /* an enumeration literal */
#define D_CONST 0x0040 /* a constant */
#define D_IMPORT 0x0080 /* an imported definition */
#define D_PROCHEAD 0x0100 /* a procedure heading in a definition module */
#define D_HIDDEN 0x0200 /* a hidden type */
#define D_FORWARD 0x0400 /* not yet defined */
#define D_FORWMODULE 0x0800 /* module must be declared later */
#define D_FORWTYPE 0x1000 /* forward type */
#define D_FTYPE 0x2000 /* resolved forward type */
#define D_ERROR 0x4000 /* a compiler generated definition for an
undefined variable
*/
#define D_VALUE (D_PROCEDURE|D_VARIABLE|D_FIELD|D_ENUM|D_CONST|D_PROCHEAD)
#define D_ISTYPE (D_HIDDEN|D_TYPE|D_FTYPE)
#define is_type(dfx) ((dfx)->df_kind & D_ISTYPE)
unsigned short df_flags;
#define D_NOREG 0x01 /* set if it may not reside in a register */
#define D_USED 0x02 /* set if used (future use ???) */
#define D_DEFINED 0x04 /* set if it is assigned a value (future use ???) */
#define D_VARPAR 0x08 /* set if it is a VAR parameter */
#define D_VALPAR 0x10 /* set if it is a value parameter */
#define D_EXPORTED 0x20 /* set if exported */
#define D_QEXPORTED 0x40 /* set if qualified exported */
#define D_BUSY 0x80 /* set if busy reading this definition module */
struct type *df_type;
union {
struct module df_module;
struct variable df_variable;
struct constant df_constant;
struct enumval df_enum;
struct field df_field;
struct import df_import;
struct dfproc df_proc;
struct dforward df_forward;
struct forwtype df_fortype;
int df_stdname; /* define for standard name */
} df_value;
};
/* ALLOCDEF "def" 50 */
extern struct def
*define(),
*DefineLocalModule(),
*MkDef(),
*DeclProc();
extern struct def
*lookup(),
*lookfor();
#define NULLDEF ((struct def *) 0)

364
lang/m2/comp/def.c
View File

@@ -1,364 +0,0 @@
/* D E F I N I T I O N M E C H A N I S M */
#include "debug.h"
#include <alloc.h>
#include <em_arith.h>
#include <em_label.h>
#include <assert.h>
#include "main.h"
#include "def.h"
#include "type.h"
#include "idf.h"
#include "scope.h"
#include "LLlex.h"
#include "node.h"
#include "Lpars.h"
extern int (*c_inp)();
STATIC
DefInFront(df)
register struct def *df;
{
/* Put definition "df" in front of the list of definitions
in its scope.
This is neccessary because in some cases the order in this
list is important.
*/
register struct def *df1 = df->df_scope->sc_def;
if (df1 != df) {
/* Definition "df" is not in front of the list
*/
while (df1) {
/* Find definition "df"
*/
if (df1->df_nextinscope == df) {
/* It already was in the list. Remove it
*/
df1->df_nextinscope = df->df_nextinscope;
break;
}
df1 = df1->df_nextinscope;
}
/* Now put it in front
*/
df->df_nextinscope = df->df_scope->sc_def;
df->df_scope->sc_def = df;
}
}
struct def *
MkDef(id, scope, kind)
register struct idf *id;
register struct scope *scope;
{
/* Create a new definition structure in scope "scope", with
id "id" and kind "kind".
*/
register struct def *df;
df = new_def();
df->df_idf = id;
df->df_scope = scope;
df->df_kind = kind;
df->next = id->id_def;
id->id_def = df;
/* enter the definition in the list of definitions in this scope
*/
df->df_nextinscope = scope->sc_def;
scope->sc_def = df;
return df;
}
struct def *
define(id, scope, kind)
register struct idf *id;
register struct scope *scope;
int kind;
{
/* Declare an identifier in a scope, but first check if it
already has been defined.
If so, then check for the cases in which this is legal,
and otherwise give an error message.
*/
register struct def *df;
df = lookup(id, scope, 1);
if ( /* Already in this scope */
df
|| /* A closed scope, and id defined in the pervasive scope */
(
scopeclosed(scope)
&&
(df = lookup(id, PervasiveScope, 1)))
) {
switch(df->df_kind) {
case D_HIDDEN:
/* An opaque type. We may now have found the
definition of this type.
*/
if (kind == D_TYPE && !DefinitionModule) {
df->df_kind = D_TYPE;
return df;
}
break;
case D_FORWMODULE:
/* A forward reference to a module. We may have found
another one, or we may have found the definition
for this module.
*/
if (kind == D_FORWMODULE) {
return df;
}
if (kind == D_MODULE) {
FreeNode(df->for_node);
df->mod_vis = df->for_vis;
df->df_kind = kind;
DefInFront(df);
return df;
}
break;
case D_TYPE:
if (kind == D_FORWTYPE) return df;
break;
case D_FORWTYPE:
if (kind == D_FORWTYPE) return df;
if (kind == D_TYPE) {
df->df_kind = D_FTYPE;
FreeNode(df->df_forw_node);
}
else {
error("identifier \"%s\" must be a type",
id->id_text);
}
return df;
case D_FORWARD:
/* A forward reference, for which we may now have
found a definition.
*/
if (kind != D_FORWARD) {
FreeNode(df->for_node);
}
/* Fall through */
case D_ERROR:
/* A definition generated by the compiler, because
it found an error. Maybe, the user gives a
definition after all.
*/
df->df_kind = kind;
return df;
}
if (kind != D_ERROR) {
/* Avoid spurious error messages
*/
error("identifier \"%s\" already declared",
id->id_text);
}
return df;
}
return MkDef(id, scope, kind);
}
RemoveImports(pdf)
register struct def **pdf;
{
/* Remove all imports from a definition module. This is
neccesary because the implementation module might import
them again.
*/
register struct def *df = *pdf;
while (df) {
if (df->df_kind == D_IMPORT) {
RemoveFromIdList(df);
*pdf = df->df_nextinscope;
free_def(df);
}
else {
pdf = &(df->df_nextinscope);
}
df = *pdf;
}
}
RemoveFromIdList(df)
register struct def *df;
{
/* Remove definition "df" from the definition list
*/
register struct idf *id = df->df_idf;
register struct def *df1;
if ((df1 = id->id_def) == df) id->id_def = df->next;
else {
while (df1->next != df) {
assert(df1->next != 0);
df1 = df1->next;
}
df1->next = df->next;
}
}
struct def *
DeclProc(type, id)
register struct idf *id;
{
/* A procedure is declared, either in a definition or a program
module. Create a def structure for it (if neccessary).
Also create a name for it.
*/
register struct def *df;
register struct scope *scope;
extern char *sprint();
static int nmcount;
char buf[256];
assert(type & (D_PROCEDURE | D_PROCHEAD));
if (type == D_PROCHEAD) {
/* In a definition module
*/
df = define(id, CurrentScope, type);
df->for_node = MkLeaf(Name, &dot);
sprint(buf,"%s_%s",CurrentScope->sc_name,id->id_text);
df->for_name = Salloc(buf, (unsigned) (strlen(buf)+1));
if (CurrVis == Defined->mod_vis) {
/* The current module will define this routine.
make sure the name is exported.
*/
C_exp(df->for_name);
}
}
else {
char *name;
df = lookup(id, CurrentScope, 1);
if (df && df->df_kind == D_PROCHEAD) {
/* C_exp already generated when we saw the definition
in the definition module
*/
df->df_kind = D_PROCEDURE;
name = df->for_name;
DefInFront(df);
}
else {
df = define(id, CurrentScope, type);
sprint(buf,"_%d_%s",++nmcount,id->id_text);
name = Salloc(buf, (unsigned)(strlen(buf)+1));
(*c_inp)(buf);
}
open_scope(OPENSCOPE);
scope = CurrentScope;
scope->sc_name = name;
scope->sc_definedby = df;
df->prc_vis = CurrVis;
}
return df;
}
EndProc(df, id)
register struct def *df;
struct idf *id;
{
/* The end of a procedure declaration.
Check that the closing identifier matches the name of the
procedure, close the scope, and check that a function
procedure has at least one RETURN statement.
*/
extern int return_occurred;
match_id(id, df->df_idf);
close_scope(SC_CHKFORW|SC_REVERSE);
if (! return_occurred && ResultType(df->df_type)) {
error("function procedure %s does not return a value",
df->df_idf->id_text);
}
}
struct def *
DefineLocalModule(id)
struct idf *id;
{
/* Create a definition for a local module. Also give it
a name to be used for code generation.
*/
register struct def *df = define(id, CurrentScope, D_MODULE);
register struct scope *sc;
static int modulecount = 0;
char buf[256];
extern char *sprint();
extern int proclevel;
sprint(buf, "_%d%s", ++modulecount, id->id_text);
if (!df->mod_vis) {
/* We never saw the name of this module before. Create a
scope for it.
*/
open_scope(CLOSEDSCOPE);
df->mod_vis = CurrVis;
}
CurrVis = df->mod_vis;
sc = CurrentScope;
sc->sc_level = proclevel;
sc->sc_definedby = df;
sc->sc_name = Salloc(buf, (unsigned) (strlen(buf) + 1));
/* Create a type for it
*/
df->df_type = standard_type(T_RECORD, 1, (arith) 0);
df->df_type->rec_scope = sc;
/* Generate code that indicates that the initialization procedure
for this module is local.
*/
(*c_inp)(buf);
return df;
}
CheckWithDef(df, tp)
register struct def *df;
struct type *tp;
{
/* Check the header of a procedure declaration against a
possible earlier definition in the definition module.
*/
if (df->df_type) {
/* We already saw a definition of this type
in the definition module.
*/
if (!TstProcEquiv(tp, df->df_type)) {
error("inconsistent procedure declaration for \"%s\"",
df->df_idf->id_text);
}
FreeType(df->df_type);
}
df->df_type = tp;
}
#ifdef DEBUG
PrDef(df)
register struct def *df;
{
print("n: %s, k: %d\n", df->df_idf->id_text, df->df_kind);
}
#endif DEBUG

22
lang/m2/comp/def_sizes.h
View File

@@ -1,22 +0,0 @@
/* D E F A U L T S I Z E S A N D A L I G N M E N T S */
/* $Header$ */
#define MAXSIZE 8 /* the maximum of the SZ_* constants */
/* target machine sizes */
#define SZ_CHAR (arith)1
#define SZ_WORD (arith)4
#define SZ_INT (arith)4
#define SZ_LONG (arith)4
#define SZ_FLOAT (arith)4
#define SZ_DOUBLE (arith)8
#define SZ_POINTER (arith)4
/* target machine alignment requirements */
#define AL_CHAR 1
#define AL_WORD (int) SZ_WORD
#define AL_INT (int) SZ_WORD
#define AL_LONG (int) SZ_WORD
#define AL_FLOAT (int) SZ_WORD
#define AL_DOUBLE (int) SZ_WORD
#define AL_POINTER (int) SZ_WORD
#define AL_STRUCT 1

115
lang/m2/comp/defmodule.c
View File

@@ -1,115 +0,0 @@
/* D E F I N I T I O N M O D U L E S */
#include "debug.h"
#include <assert.h>
#include <em_arith.h>
#include <em_label.h>
#include "idf.h"
#include "input.h"
#include "scope.h"
#include "def.h"
#include "LLlex.h"
#include "Lpars.h"
#include "f_info.h"
#include "main.h"
#include "node.h"
#include "type.h"
#include "misc.h"
#ifdef DEBUG
long sys_filesize();
#endif
struct idf *DefId;
STATIC
GetFile(name)
char *name;
{
/* Try to find a file with basename "name" and extension ".def",
in the directories mentioned in "DEFPATH".
*/
char buf[15];
char *strcpy(), *strcat();
strncpy(buf, name, 10);
buf[10] = '\0'; /* maximum length */
strcat(buf, ".def");
if (! InsertFile(buf, DEFPATH, &(FileName))) {
error("could not find a DEFINITION MODULE for \"%s\"", name);
return 0;
}
LineNumber = 1;
DO_DEBUG(options['F'], debug("File %s : %ld characters", FileName, sys_filesize(FileName)));
return 1;
}
struct def *
GetDefinitionModule(id, incr)
register struct idf *id;
{
/* Return a pointer to the "def" structure of the definition
module indicated by "id".
We may have to read the definition module itself.
Also increment level by "incr".
*/
register struct def *df;
static int level;
struct scopelist *vis;
level += incr;
df = lookup(id, GlobalScope, 1);
if (!df) {
/* Read definition module. Make an exception for SYSTEM.
*/
if (!strcmp(id->id_text, "SYSTEM")) {
do_SYSTEM();
}
else {
open_scope(CLOSEDSCOPE);
if (!is_anon_idf(id) && GetFile(id->id_text)) {
DefId = id;
DefModule();
if (level == 1) {
/* The module is directly imported by
the currently defined module, so we
have to remember its name because
we have to call its initialization
routine
*/
static struct node *nd_end;
register struct node *n;
extern struct node *Modules;
n = MkLeaf(Name, &dot);
n->nd_IDF = id;
n->nd_symb = IDENT;
if (nd_end) nd_end->next = n;
else Modules = n;
nd_end = n;
}
}
vis = CurrVis;
close_scope(SC_CHKFORW);
}
df = lookup(id, GlobalScope, 1);
if (! df) {
df = MkDef(id, GlobalScope, D_ERROR);
df->df_type = error_type;
df->mod_vis = vis;
}
}
else if (df->df_flags & D_BUSY) {
error("definition module \"%s\" depends on itself",
id->id_text);
}
else if (df == Defined && level == 1) {
error("cannot import from currently defined module");
df->df_kind = D_ERROR;
}
assert(df);
level -= incr;
return df;
}

572
lang/m2/comp/desig.c
View File

@@ -1,572 +0,0 @@
/* D E S I G N A T O R E V A L U A T I O N */
/* Code generation for designators.
This file contains some routines that generate code common to address
as well as value computations, and leave a description in a "desig"
structure. It also contains routines to load an address, load a value
or perform a store.
*/
#include "debug.h"
#include <em_arith.h>
#include <em_label.h>
#include <em_code.h>
#include <assert.h>
#include "type.h"
#include "def.h"
#include "scope.h"
#include "desig.h"
#include "LLlex.h"
#include "node.h"
extern int proclevel;
struct desig InitDesig = {DSG_INIT, 0, 0};
STATIC int
properly(ds, size, al)
register struct desig *ds;
arith size;
{
/* Check if it is allowed to load or store the value indicated
by "ds" with LOI/STI.
- if the size is not either a multiple or a dividor of the
wordsize, then not.
- if the alignment is at least "word" then OK.
- if size is dividor of word_size and alignment >= size then OK.
- otherwise check alignment of address. This can only be done
with DSG_FIXED.
*/
arith szmodword = size % word_size; /* 0 if multiple of wordsize */
arith wordmodsz = word_size % size; /* 0 if dividor of wordsize */
if (szmodword && wordmodsz) return 0;
if (al >= word_size) return 1;
if (szmodword && al >= szmodword) return 1;
return ds->dsg_kind == DSG_FIXED &&
((! szmodword && ds->dsg_offset % word_size == 0) ||
(! wordmodsz && ds->dsg_offset % size == 0));
}
CodeValue(ds, size, al)
register struct desig *ds;
arith size;
{
/* Generate code to load the value of the designator described
in "ds"
*/
arith tmp = 0;
switch(ds->dsg_kind) {
case DSG_LOADED:
break;
case DSG_FIXED:
if (ds->dsg_offset % word_size == 0) {
if (size == word_size) {
if (ds->dsg_name) {
C_loe_dnam(ds->dsg_name,ds->dsg_offset);
}
else C_lol(ds->dsg_offset);
break;
}
if (size == dword_size) {
if (ds->dsg_name) {
C_lde_dnam(ds->dsg_name,ds->dsg_offset);
}
else C_ldl(ds->dsg_offset);
break;
}
}
/* Fall through */
case DSG_PLOADED:
case DSG_PFIXED:
if (properly(ds, size, al)) {
CodeAddress(ds);
C_loi(size);
break;
}
if (ds->dsg_kind == DSG_PLOADED) {
tmp = NewPtr();
C_stl(tmp);
}
C_asp(-WA(size));
if (!tmp) CodeAddress(ds);
else {
C_lol(tmp);
FreePtr(tmp);
}
C_loc(size);
C_cal("_load");
C_asp(2 * word_size);
break;
case DSG_INDEXED:
C_lar(word_size);
break;
default:
crash("(CodeValue)");
}
ds->dsg_kind = DSG_LOADED;
}
CodeStore(ds, size, al)
register struct desig *ds;
arith size;
{
/* Generate code to store the value on the stack in the designator
described in "ds"
*/
struct desig save;
save = *ds;
switch(ds->dsg_kind) {
case DSG_FIXED:
if (ds->dsg_offset % word_size == 0) {
if (size == word_size) {
if (ds->dsg_name) {
C_ste_dnam(ds->dsg_name,ds->dsg_offset);
}
else C_stl(ds->dsg_offset);
break;
}
if (size == dword_size) {
if (ds->dsg_name) {
C_sde_dnam(ds->dsg_name,ds->dsg_offset);
}
else C_sdl(ds->dsg_offset);
break;
}
}
/* Fall through */
case DSG_PLOADED:
case DSG_PFIXED:
CodeAddress(&save);
if (properly(ds, size, al)) {
C_sti(size);
break;
}
C_loc(size);
C_cal("_store");
C_asp(2 * word_size + WA(size));
break;
case DSG_INDEXED:
C_sar(word_size);
break;
default:
crash("(CodeStore)");
}
ds->dsg_kind = DSG_INIT;
}
CodeCopy(lhs, rhs, sz, psize)
register struct desig *lhs, *rhs;
arith sz, *psize;
{
struct desig l, r;
l = *lhs; r = *rhs;
*psize -= sz;
lhs->dsg_offset += sz;
rhs->dsg_offset += sz;
CodeAddress(&r);
C_loi(sz);
CodeAddress(&l);
C_sti(sz);
}
CodeMove(rhs, left, rtp)
register struct desig *rhs;
register struct node *left;
struct type *rtp;
{
struct desig dsl;
register struct desig *lhs = &dsl;
register struct type *tp = left->nd_type;
int loadedflag = 0;
dsl = InitDesig;
/* Generate code for an assignment. Testing of type
compatibility and the like is already done.
Go through some (considerable) trouble to see if a BLM can be
generated.
*/
switch(rhs->dsg_kind) {
case DSG_LOADED:
CodeDesig(left, lhs);
CodeAddress(lhs);
if (rtp->tp_fund == T_STRING) {
C_loc(rtp->tp_size);
C_loc(tp->tp_size);
C_cal("_StringAssign");
C_asp(word_size << 2);
return;
}
CodeStore(lhs, tp->tp_size, tp->tp_align);
return;
case DSG_PLOADED:
case DSG_PFIXED:
CodeAddress(rhs);
if (tp->tp_size % word_size == 0 && tp->tp_align >= word_size) {
CodeDesig(left, lhs);
CodeAddress(lhs);
C_blm(tp->tp_size);
return;
}
CodeValue(rhs, tp->tp_size, tp->tp_align);
CodeDStore(left);
return;
case DSG_FIXED:
CodeDesig(left, lhs);
if (lhs->dsg_kind == DSG_FIXED &&
lhs->dsg_offset % word_size ==
rhs->dsg_offset % word_size) {
register arith sz;
arith size = tp->tp_size;
while (size && (sz = (lhs->dsg_offset % word_size))) {
/* First copy up to word-aligned
boundaries
*/
if (sz < 0) sz = -sz; /* bloody '%' */
while (word_size % sz) sz--;
CodeCopy(lhs, rhs, sz, &size);
}
if (size > 3*dword_size) {
/* Do a block move
*/
struct desig l, r;
sz = (size / word_size) * word_size;
l = *lhs; r = *rhs;
CodeAddress(&r);
CodeAddress(&l);
C_blm(sz);
rhs->dsg_offset += sz;
lhs->dsg_offset += sz;
size -= sz;
}
else for (sz = dword_size; sz; sz -= word_size) {
while (size >= sz) {
/* Then copy dwords, words.
Depend on peephole optimizer
*/
CodeCopy(lhs, rhs, sz, &size);
}
}
sz = word_size;
while (size && --sz) {
/* And then copy remaining parts
*/
while (word_size % sz) sz--;
while (size >= sz) {
CodeCopy(lhs, rhs, sz, &size);
}
}
return;
}
if (lhs->dsg_kind == DSG_PLOADED ||
lhs->dsg_kind == DSG_INDEXED) {
CodeAddress(lhs);
loadedflag = 1;
}
if (tp->tp_size % word_size == 0 && tp->tp_align >= word_size) {
CodeAddress(rhs);
if (loadedflag) C_exg(pointer_size);
else CodeAddress(lhs);
C_blm(tp->tp_size);
return;
}
{
arith tmp;
if (loadedflag) {
tmp = NewPtr();
lhs->dsg_offset = tmp;
lhs->dsg_name = 0;
lhs->dsg_kind = DSG_PFIXED;
C_stl(tmp); /* address of lhs */
}
CodeValue(rhs, tp->tp_size, tp->tp_align);
CodeStore(lhs, tp->tp_size, tp->tp_align);
if (loadedflag) FreePtr(tmp);
return;
}
default:
crash("CodeMove");
}
}
CodeAddress(ds)
register struct desig *ds;
{
/* Generate code to load the address of the designator described
in "ds"
*/
switch(ds->dsg_kind) {
case DSG_PLOADED:
if (ds->dsg_offset) {
C_adp(ds->dsg_offset);
}
break;
case DSG_FIXED:
if (ds->dsg_name) {
C_lae_dnam(ds->dsg_name, ds->dsg_offset);
break;
}
C_lal(ds->dsg_offset);
break;
case DSG_PFIXED:
if (ds->dsg_name) {
C_loe_dnam(ds->dsg_name,ds->dsg_offset);
break;
}
C_lol(ds->dsg_offset);
break;
case DSG_INDEXED:
C_aar(word_size);
break;
default:
crash("(CodeAddress)");
}
ds->dsg_offset = 0;
ds->dsg_kind = DSG_PLOADED;
}
CodeFieldDesig(df, ds)
register struct def *df;
register struct desig *ds;
{
/* Generate code for a field designator. Only the code common for
address as well as value computation is generated, and the
resulting information on where to find the designator is placed
in "ds". "df" indicates the definition of the field.
*/
if (ds->dsg_kind == DSG_INIT) {
/* In a WITH statement. We must find the designator in the
WITH statement, and act as if the field is a selection
of this designator.
So, first find the right WITH statement, which is the
first one of the proper record type, which is
recognized by its scope indication.
*/
register struct withdesig *wds = WithDesigs;
assert(wds != 0);
while (wds->w_scope != df->df_scope) {
wds = wds->w_next;
assert(wds != 0);
}
/* Found it. Now, act like it was a selection.
*/
*ds = wds->w_desig;
assert(ds->dsg_kind == DSG_PFIXED);
}
switch(ds->dsg_kind) {
case DSG_PLOADED:
case DSG_FIXED:
ds->dsg_offset += df->fld_off;
break;
case DSG_PFIXED:
case DSG_INDEXED:
CodeAddress(ds);
ds->dsg_kind = DSG_PLOADED;
ds->dsg_offset = df->fld_off;
break;
default:
crash("(CodeFieldDesig)");
}
}
CodeVarDesig(df, ds)
register struct def *df;
register struct desig *ds;
{
/* Generate code for a variable represented by a "def" structure.
Of course, there are numerous cases: the variable is local,
it is a value parameter, it is a var parameter, it is one of
those of an enclosing procedure, or it is global.
*/
register struct scope *sc = df->df_scope;
/* Selections from a module are handled earlier, when identifying
the variable, so ...
*/
assert(ds->dsg_kind == DSG_INIT);
if (df->var_addrgiven) {
/* the programmer specified an address in the declaration of
the variable. Generate code to push the address.
*/
CodeConst(df->var_off, pointer_size);
ds->dsg_kind = DSG_PLOADED;
ds->dsg_offset = 0;
return;
}
if (df->var_name) {
/* this variable has been given a name, so it is global.
It is directly accessible.
*/
ds->dsg_name = df->var_name;
ds->dsg_offset = 0;
ds->dsg_kind = DSG_FIXED;
return;
}
if (sc->sc_level != proclevel) {
/* the variable is local to a statically enclosing procedure.
*/
assert(proclevel > sc->sc_level);
df->df_flags |= D_NOREG;
if (df->df_flags & (D_VARPAR|D_VALPAR)) {
/* value or var parameter
*/
C_lxa((arith) (proclevel - sc->sc_level));
if ((df->df_flags & D_VARPAR) ||
IsConformantArray(df->df_type)) {
/* var parameter or conformant array.
For conformant array's, the address is
passed.
*/
C_adp(df->var_off);
C_loi(pointer_size);
ds->dsg_offset = 0;
ds->dsg_kind = DSG_PLOADED;
return;
}
}
else C_lxl((arith) (proclevel - sc->sc_level));
ds->dsg_kind = DSG_PLOADED;
ds->dsg_offset = df->var_off;
return;
}
/* Now, finally, we have a local variable or a local parameter
*/
if ((df->df_flags & D_VARPAR) || IsConformantArray(df->df_type)) {
/* a var parameter; address directly accessible.
*/
ds->dsg_kind = DSG_PFIXED;
}
else ds->dsg_kind = DSG_FIXED;
ds->dsg_offset =df->var_off;
}
CodeDesig(nd, ds)
register struct node *nd;
register struct desig *ds;
{
/* Generate code for a designator. Use divide and conquer
principle
*/
register struct def *df;
switch(nd->nd_class) { /* Divide */
case Def:
df = nd->nd_def;
switch(df->df_kind) {
case D_FIELD:
CodeFieldDesig(df, ds);
break;
case D_VARIABLE:
CodeVarDesig(df, ds);
break;
default:
crash("(CodeDesig) Def");
}
break;
case LinkDef:
assert(nd->nd_symb == '.');
CodeDesig(nd->nd_left, ds);
CodeFieldDesig(nd->nd_def, ds);
break;
case Arrsel:
assert(nd->nd_symb == '[');
CodeDesig(nd->nd_left, ds);
CodeAddress(ds);
CodePExpr(nd->nd_right);
if (nd->nd_right->nd_type->tp_size > word_size) {
CodeCoercion(nd->nd_right->nd_type, int_type);
}
/* Now load address of descriptor
*/
if (IsConformantArray(nd->nd_left->nd_type)) {
assert(nd->nd_left->nd_class == Def);
df = nd->nd_left->nd_def;
if (proclevel > df->df_scope->sc_level) {
C_lxa((arith) (proclevel - df->df_scope->sc_level));
C_adp(df->var_off + pointer_size);
}
else C_lal(df->var_off + pointer_size);
}
else {
C_lae_dlb(nd->nd_left->nd_type->arr_descr, (arith) 0);
}
ds->dsg_kind = DSG_INDEXED;
break;
case Arrow:
assert(nd->nd_symb == '^');
CodeDesig(nd->nd_right, ds);
switch(ds->dsg_kind) {
case DSG_LOADED:
ds->dsg_kind = DSG_PLOADED;
break;
case DSG_INDEXED:
case DSG_PLOADED:
case DSG_PFIXED:
CodeValue(ds, pointer_size, pointer_align);
ds->dsg_kind = DSG_PLOADED;
ds->dsg_offset = 0;
break;
case DSG_FIXED:
ds->dsg_kind = DSG_PFIXED;
break;
default:
crash("(CodeDesig) Uoper");
}
break;
default:
crash("(CodeDesig) class");
}
}

53
lang/m2/comp/desig.h
View File

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

451
lang/m2/comp/enter.c
View File

@@ -1,451 +0,0 @@
/* H I G H L E V E L S Y M B O L E N T R Y */
#include "debug.h"
#include <alloc.h>
#include <em_arith.h>
#include <em_label.h>
#include <em_code.h>
#include <assert.h>
#include "idf.h"
#include "def.h"
#include "type.h"
#include "scope.h"
#include "LLlex.h"
#include "node.h"
#include "main.h"
#include "misc.h"
struct def *
Enter(name, kind, type, pnam)
char *name;
struct type *type;
{
/* Enter a definition for "name" with kind "kind" and type
"type" in the Current Scope. If it is a standard name, also
put its number in the definition structure.
*/
register struct def *df;
df = define(str2idf(name, 0), CurrentScope, kind);
df->df_type = type;
if (pnam) df->df_value.df_stdname = pnam;
return df;
}
EnterEnumList(Idlist, type)
struct node *Idlist;
register struct type *type;
{
/* Put a list of enumeration literals in the symbol table.
They all have type "type".
Also assign numbers to them, and link them together.
We must link them together because an enumeration type may
be exported, in which case its literals must also be exported.
Thus, we need an easy way to get to them.
*/
register struct def *df;
register struct node *idlist = Idlist;
type->enm_ncst = 0;
for (; idlist; idlist = idlist->next) {
df = define(idlist->nd_IDF, CurrentScope, D_ENUM);
df->df_type = type;
df->enm_val = (type->enm_ncst)++;
df->enm_next = type->enm_enums;
type->enm_enums = df;
}
FreeNode(Idlist);
}
EnterFieldList(Idlist, type, scope, addr)
struct node *Idlist;
register struct type *type;
struct scope *scope;
arith *addr;
{
/* Put a list of fields in the symbol table.
They all have type "type", and are put in scope "scope".
Mark them as QUALIFIED EXPORT, because that's exactly what
fields are, you can get to them by qualifying them.
*/
register struct def *df;
register struct node *idlist = Idlist;
for (; idlist; idlist = idlist->next) {
df = define(idlist->nd_IDF, scope, D_FIELD);
df->df_type = type;
df->df_flags |= D_QEXPORTED;
df->fld_off = align(*addr, type->tp_align);
*addr = df->fld_off + type->tp_size;
}
FreeNode(Idlist);
}
EnterVarList(Idlist, type, local)
struct node *Idlist;
struct type *type;
{
/* Enter a list of identifiers representing variables into the
name list. "type" represents the type of the variables.
"local" is set if the variables are declared local to a
procedure.
*/
register struct def *df;
register struct node *idlist = Idlist;
register struct scopelist *sc;
char buf[256];
extern char *sprint();
sc = CurrVis;
if (local) {
/* Find the closest enclosing open scope. This
is the procedure that we are dealing with
*/
while (sc->sc_scope->sc_scopeclosed) sc = enclosing(sc);
}
for (; idlist; idlist = idlist->nd_right) {
df = define(idlist->nd_IDF, CurrentScope, D_VARIABLE);
df->df_type = type;
if (idlist->nd_left) {
/* An address was supplied
*/
register struct type *tp = idlist->nd_left->nd_type;
df->var_addrgiven = 1;
df->df_flags |= D_NOREG;
if (tp != error_type && !(tp->tp_fund & T_CARDINAL)){
node_error(idlist->nd_left,
"illegal type for address");
}
df->var_off = idlist->nd_left->nd_INT;
}
else if (local) {
/* subtract aligned size of variable to the offset,
as the variable list exists only local to a
procedure
*/
sc->sc_scope->sc_off =
-WA(align(type->tp_size - sc->sc_scope->sc_off,
type->tp_align));
df->var_off = sc->sc_scope->sc_off;
}
else {
/* Global name, possibly external
*/
sprint(buf,"%s_%s", sc->sc_scope->sc_name,
df->df_idf->id_text);
df->var_name = Salloc(buf, (unsigned)(strlen(buf)+1));
df->df_flags |= D_NOREG;
if (DefinitionModule) {
if (sc == Defined->mod_vis) {
C_exa_dnam(df->var_name);
}
}
else {
C_ina_dnam(df->var_name);
}
}
}
FreeNode(Idlist);
}
EnterParamList(ppr, Idlist, type, VARp, off)
struct paramlist **ppr;
struct node *Idlist;
struct type *type;
int VARp;
arith *off;
{
/* Create (part of) a parameterlist of a procedure.
"ids" indicates the list of identifiers, "tp" their type, and
"VARp" indicates D_VARPAR or D_VALPAR.
*/
register struct paramlist *pr;
register struct def *df;
register struct node *idlist = Idlist;
struct node *dummy = 0;
static struct paramlist *last;
if (! idlist) {
/* Can only happen when a procedure type is defined */
dummy = Idlist = idlist = MkLeaf(Name, &dot);
}
for ( ; idlist; idlist = idlist->next) {
pr = new_paramlist();
pr->next = 0;
if (!*ppr) *ppr = pr;
else last->next = pr;
last = pr;
if (!DefinitionModule && idlist != dummy) {
df = define(idlist->nd_IDF, CurrentScope, D_VARIABLE);
df->var_off = *off;
}
else df = new_def();
pr->par_def = df;
df->df_type = type;
df->df_flags = VARp;
if (IsConformantArray(type)) {
/* we need room for the base address and a descriptor
*/
*off += pointer_size + 3 * word_size;
}
else if (VARp == D_VARPAR) {
*off += pointer_size;
}
else {
*off += WA(type->tp_size);
}
}
FreeNode(Idlist);
}
STATIC
DoImport(df, scope)
register struct def *df;
struct scope *scope;
{
/* Definition "df" is imported to scope "scope".
Handle the case that it is an enumeration type or a module.
*/
define(df->df_idf, scope, D_IMPORT)->imp_def = df;
if (df->df_kind == D_TYPE && df->df_type->tp_fund == T_ENUMERATION) {
/* Also import all enumeration literals
*/
for (df = df->df_type->enm_enums; df; df = df->enm_next) {
define(df->df_idf, scope, D_IMPORT)->imp_def = df;
}
}
else if (df->df_kind == D_MODULE) {
/* Also import all definitions that are exported from this
module
*/
if (df->mod_vis == CurrVis) {
error("cannot import current module \"%s\"",
df->df_idf->id_text);
return;
}
for (df = df->mod_vis->sc_scope->sc_def;
df;
df = df->df_nextinscope) {
if (df->df_flags & D_EXPORTED) {
define(df->df_idf,scope,D_IMPORT)->imp_def = df;
}
}
}
}
STATIC struct scopelist *
ForwModule(df, nd)
register struct def *df;
struct node *nd;
{
/* An import is done from a not yet defined module "df".
We could also end up here for not found DEFINITION MODULES.
Create a declaration and a scope for this module.
*/
struct scopelist *vis;
if (df->df_scope != GlobalScope) {
df->df_scope = enclosing(CurrVis)->sc_scope;
df->df_kind = D_FORWMODULE;
}
open_scope(CLOSEDSCOPE);
vis = CurrVis; /* The new scope, but watch out, it's "sc_encl"
field is not set right. It must indicate the
enclosing scope, but this must be done AFTER
closing this one
*/
close_scope(0);
vis->sc_encl = enclosing(CurrVis);
/* Here ! */
df->for_vis = vis;
df->for_node = nd;
return vis;
}
STATIC struct def *
ForwDef(ids, scope)
register struct node *ids;
struct scope *scope;
{
/* Enter a forward definition of "ids" in scope "scope",
if it is not already defined.
*/
register struct def *df;
if (!(df = lookup(ids->nd_IDF, scope, 1))) {
df = define(ids->nd_IDF, scope, D_FORWARD);
df->for_node = MkLeaf(Name, &(ids->nd_token));
}
return df;
}
EnterExportList(Idlist, qualified)
struct node *Idlist;
{
/* From the current scope, the list of identifiers "ids" is
exported. Note this fact. If the export is not qualified, make
all the "ids" visible in the enclosing scope by defining them
in this scope as "imported".
*/
register struct node *idlist = Idlist;
register struct def *df, *df1;
for (;idlist; idlist = idlist->next) {
df = lookup(idlist->nd_IDF, CurrentScope, 0);
if (!df) {
/* undefined item in export list
*/
node_error(idlist,
"identifier \"%s\" not defined",
idlist->nd_IDF->id_text);
continue;
}
if (df->df_flags & (D_EXPORTED|D_QEXPORTED)) {
node_error(idlist,
"multiple occurrences of \"%s\" in export list",
idlist->nd_IDF->id_text);
}
if (df->df_kind == D_IMPORT) df = df->imp_def;
df->df_flags |= qualified;
if (qualified == D_EXPORTED) {
/* Export, but not qualified.
Find all imports of the module in which this export
occurs, and export the current definition to it
*/
df1 = CurrentScope->sc_definedby->df_idf->id_def;
while (df1) {
if (df1->df_kind == D_IMPORT &&
df1->imp_def == CurrentScope->sc_definedby) {
DoImport(df, df1->df_scope);
}
df1 = df1->next;
}
/* Also handle the definition as if the enclosing
scope imports it.
*/
df1 = lookup(idlist->nd_IDF,
enclosing(CurrVis)->sc_scope, 1);
if (df1) {
/* It was already defined in the enclosing
scope. There are two legal possibilities,
which are examined below.
*/
if (df1->df_kind == D_PROCHEAD &&
df->df_kind == D_PROCEDURE) {
df1->df_kind = D_IMPORT;
df1->imp_def = df;
continue;
}
if (df1->df_kind == D_HIDDEN &&
df->df_kind == D_TYPE) {
DeclareType(idlist, df1, df->df_type);
df1->df_kind = D_TYPE;
continue;
}
}
DoImport(df, enclosing(CurrVis)->sc_scope);
}
}
FreeNode(Idlist);
}
EnterFromImportList(Idlist, FromDef, FromId)
struct node *Idlist;
register struct def *FromDef;
struct node *FromId;
{
/* Import the list Idlist from the module indicated by Fromdef.
*/
register struct node *idlist = Idlist;
register struct scopelist *vis;
register struct def *df;
char *module_name = FromDef->df_idf->id_text;
int forwflag = 0;
switch(FromDef->df_kind) {
case D_ERROR:
/* The module from which the import was done
is not yet declared. I'm not sure if I must
accept this, but for the time being I will.
We also end up here if some definition module could not
be found.
???
*/
vis = ForwModule(FromDef, FromId);
forwflag = 1;
break;
case D_FORWMODULE:
vis = FromDef->for_vis;
break;
case D_MODULE:
vis = FromDef->mod_vis;
if (vis == CurrVis) {
node_error(FromId, "cannot import from current module \"%s\"", module_name);
return;
}
break;
default:
node_error(FromId,"identifier \"%s\" does not represent a module",module_name);
return;
}
for (; idlist; idlist = idlist->next) {
if (forwflag) df = ForwDef(idlist, vis->sc_scope);
else if (! (df = lookup(idlist->nd_IDF, vis->sc_scope, 1))) {
if (! is_anon_idf(idlist->nd_IDF)) {
node_error(idlist,
"identifier \"%s\" not declared in module \"%s\"",
idlist->nd_IDF->id_text,
module_name);
}
df = define(idlist->nd_IDF,vis->sc_scope,D_ERROR);
}
else if (! (df->df_flags & (D_EXPORTED|D_QEXPORTED))) {
node_error(idlist,
"identifier \"%s\" not exported from module \"%s\"",
idlist->nd_IDF->id_text,
module_name);
df->df_flags |= D_QEXPORTED;
}
DoImport(df, CurrentScope);
}
if (!forwflag) FreeNode(FromId);
FreeNode(Idlist);
}
EnterImportList(Idlist, local)
struct node *Idlist;
{
/* Import "Idlist" from the enclosing scope.
An exception must be made for imports of the compilation unit.
In this case, definition modules must be read for "Idlist".
This case is indicated by the value 0 of the "local" flag.
*/
register struct node *idlist = Idlist;
struct scope *sc = enclosing(CurrVis)->sc_scope;
extern struct def *GetDefinitionModule();
for (; idlist; idlist = idlist->next) {
DoImport(local ?
ForwDef(idlist, sc) :
GetDefinitionModule(idlist->nd_IDF, 1) ,
CurrentScope);
}
FreeNode(Idlist);
}

233
lang/m2/comp/error.c
View File

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

242
lang/m2/comp/expression.g
View File

@@ -1,242 +0,0 @@
/* E X P R E S S I O N S */
{
#include "debug.h"
#include <alloc.h>
#include <em_arith.h>
#include <em_label.h>
#include <assert.h>
#include "LLlex.h"
#include "idf.h"
#include "def.h"
#include "node.h"
#include "const.h"
#include "type.h"
#include "chk_expr.h"
#include "warning.h"
extern char options[];
}
number(struct node **p;) :
[
%default
INTEGER
|
REAL
] { *p = MkLeaf(Value, &dot);
(*p)->nd_type = toktype;
}
;
qualident(struct node **p;)
{
} :
IDENT { *p = MkLeaf(Name, &dot); }
[
selector(p)
]*
;
selector(struct node **pnd;):
'.' { *pnd = MkNode(Link,*pnd,NULLNODE,&dot); }
IDENT { (*pnd)->nd_IDF = dot.TOK_IDF; }
;
ExpList(struct node **pnd;)
{
register struct node *nd;
} :
expression(pnd) { *pnd = nd = MkNode(Link,*pnd,NULLNODE,&dot);
nd->nd_symb = ',';
}
[
',' { nd->nd_right = MkLeaf(Link, &dot);
nd = nd->nd_right;
}
expression(&(nd->nd_left))
]*
;
ConstExpression(struct node **pnd;)
{
register struct node *nd;
}:
expression(pnd)
/*
* Changed rule in new Modula-2.
* Check that the expression is a constant expression and evaluate!
*/
{ nd = *pnd;
DO_DEBUG(options['X'], print("CONSTANT EXPRESSION\n"));
DO_DEBUG(options['X'], PrNode(nd, 0));
if (ChkExpression(nd) &&
((nd)->nd_class != Set && (nd)->nd_class != Value)) {
error("constant expression expected");
}
DO_DEBUG(options['X'], print("RESULTS IN\n"));
DO_DEBUG(options['X'], PrNode(nd, 0));
}
;
expression(struct node **pnd;)
{
} :
SimpleExpression(pnd)
[
/* relation */
[ '=' | '#' | '<' | LESSEQUAL | '>' | GREATEREQUAL | IN ]
{ *pnd = MkNode(Oper, *pnd, NULLNODE, &dot); }
SimpleExpression(&((*pnd)->nd_right))
]?
;
/* Inline in expression
relation:
'=' | '#' | '<' | LESSEQUAL | '>' | GREATEREQUAL | IN
;
*/
SimpleExpression(struct node **pnd;)
{
} :
[
[ '+' | '-' ]
{ *pnd = MkLeaf(Uoper, &dot);
pnd = &((*pnd)->nd_right);
/* priority of unary operator ??? */
}
]?
term(pnd)
[
/* AddOperator */
[ '+' | '-' | OR ]
{ *pnd = MkNode(Oper, *pnd, NULLNODE, &dot); }
term(&((*pnd)->nd_right))
]*
;
/* Inline in "SimpleExpression"
AddOperator:
'+' | '-' | OR
;
*/
term(struct node **pnd;)
{
}:
factor(pnd)
[
/* MulOperator */
[ '*' | '/' | DIV | MOD | AND | '&' ]
{ *pnd = MkNode(Oper, *pnd, NULLNODE, &dot); }
factor(&((*pnd)->nd_right))
]*
;
/* inline in "term"
MulOperator:
'*' | '/' | DIV | MOD | AND | '&'
;
*/
factor(register struct node **p;)
{
struct node *nd;
} :
qualident(p)
[
designator_tail(p)?
[
{ *p = MkNode(Call, *p, NULLNODE, &dot); }
ActualParameters(&((*p)->nd_right))
]?
|
bare_set(&nd)
{ nd->nd_left = *p; *p = nd; }
]
|
bare_set(p)
| %default
number(p)
|
STRING { *p = MkLeaf(Value, &dot);
(*p)->nd_type = toktype;
}
|
'(' expression(p) ')'
|
NOT { *p = MkLeaf(Uoper, &dot); }
factor(&((*p)->nd_right))
;
bare_set(struct node **pnd;)
{
register struct node *nd;
} :
'{' { dot.tk_symb = SET;
*pnd = nd = MkLeaf(Xset, &dot);
nd->nd_type = bitset_type;
}
[
element(nd)
[ { nd = nd->nd_right; }
',' element(nd)
]*
]?
'}'
;
ActualParameters(struct node **pnd;):
'(' ExpList(pnd)? ')'
;
element(struct node *nd;)
{
struct node *nd1;
} :
expression(&nd1)
[
UPTO
{ nd1 = MkNode(Link, nd1, NULLNODE, &dot);}
expression(&(nd1->nd_right))
]?
{ nd->nd_right = MkNode(Link, nd1, NULLNODE, &dot);
nd->nd_right->nd_symb = ',';
}
;
designator(struct node **pnd;)
:
qualident(pnd)
designator_tail(pnd)?
;
designator_tail(struct node **pnd;):
visible_designator_tail(pnd)
[ %persistent
%default
selector(pnd)
|
visible_designator_tail(pnd)
]*
;
visible_designator_tail(register struct node **pnd;):
'[' { *pnd = MkNode(Arrsel, *pnd, NULLNODE, &dot); }
expression(&((*pnd)->nd_right))
[
','
{ *pnd = MkNode(Arrsel, *pnd, NULLNODE, &dot);
(*pnd)->nd_symb = '[';
}
expression(&((*pnd)->nd_right))
]*
']'
|
'^' { *pnd = MkNode(Arrow, NULLNODE, *pnd, &dot); }
;

11
lang/m2/comp/f_info.h
View File

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

4
lang/m2/comp/idf.c
View File

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

12
lang/m2/comp/idf.h
View File

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

12
lang/m2/comp/idlist.H
View File

@@ -1,12 +0,0 @@
/* $Header$ */
#include <alloc.h>
/* Structure to link idf structures together
*/
struct id_list {
struct id_list *next;
struct idf *id_ptr;
};
/* ALLOCDEF "id_list" */

20
lang/m2/comp/idlist.c
View File

@@ -1,20 +0,0 @@
static char *RcsId = "$Header$";
#include "idf.h"
#include "idlist.h"
struct id_list *h_id_list; /* Header of free list */
/* FreeIdList: take a list of id_list structures and put them
on the free list of id_list structures
*/
FreeIdList(p)
struct id_list *p;
{
register struct id_list *q;
while (q = p) {
p = p->next;
free_id_list(q);
}
}

27
lang/m2/comp/input.c
View File

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

9
lang/m2/comp/input.h
View File

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

77
lang/m2/comp/lookup.c
View File

@@ -1,77 +0,0 @@
/* L O O K U P R O U T I N E S */
#include "debug.h"
#include <em_arith.h>
#include <em_label.h>
#include <assert.h>
#include "def.h"
#include "idf.h"
#include "scope.h"
#include "LLlex.h"
#include "node.h"
#include "type.h"
#include "misc.h"
struct def *
lookup(id, scope, import)
register struct idf *id;
struct scope *scope;
{
/* Look up a definition of an identifier in scope "scope".
Make the "def" list self-organizing.
Return a pointer to its "def" structure if it exists,
otherwise return 0.
*/
register struct def *df, *df1;
/* Look in the chain of definitions of this "id" for one with scope
"scope".
*/
for (df = id->id_def, df1 = 0;
df && df->df_scope != scope;
df1 = df, df = df->next) { /* nothing */ }
if (df) {
/* Found it
*/
if (df1) {
/* Put the definition in front
*/
df1->next = df->next;
df->next = id->id_def;
id->id_def = df;
}
if (import && df->df_kind == D_IMPORT) {
assert(df->imp_def != 0);
return df->imp_def;
}
}
return df;
}
struct def *
lookfor(id, vis, give_error)
register struct node *id;
struct scopelist *vis;
{
/* Look for an identifier in the visibility range started by "vis".
If it is not defined create a dummy definition and,
if "give_error" is set, give an error message.
*/
register struct def *df;
register struct scopelist *sc = vis;
while (sc) {
df = lookup(id->nd_IDF, sc->sc_scope, 1);
if (df) return df;
sc = nextvisible(sc);
}
if (give_error) id_not_declared(id);
df = MkDef(id->nd_IDF, vis->sc_scope, D_ERROR);
df->df_type = error_type;
return df;
}

233
lang/m2/comp/main.c
View File

@@ -1,233 +0,0 @@
/* M A I N P R O G R A M */
#include "debug.h"
#include "ndir.h"
#include <system.h>
#include <em_arith.h>
#include <em_label.h>
#include "input.h"
#include "f_info.h"
#include "idf.h"
#include "LLlex.h"
#include "Lpars.h"
#include "type.h"
#include "def.h"
#include "scope.h"
#include "standards.h"
#include "tokenname.h"
#include "node.h"
#include "warning.h"
int state; /* either IMPLEMENTATION or PROGRAM */
char options[128];
int DefinitionModule;
char *ProgName;
char *DEFPATH[NDIRS+1];
struct def *Defined;
extern int err_occurred;
extern int fp_used; /* set if floating point used */
extern C_inp(), C_exp();
int (*c_inp)() = C_inp;
main(argc, argv)
register char **argv;
{
register int Nargc = 1;
register char **Nargv = &argv[0];
ProgName = *argv++;
warning_classes = W_INITIAL;
while (--argc > 0) {
if (**argv == '-')
DoOption((*argv++) + 1);
else
Nargv[Nargc++] = *argv++;
}
Nargv[Nargc] = 0; /* terminate the arg vector */
if (Nargc < 2) {
fprint(STDERR, "%s: Use a file argument\n", ProgName);
return 1;
}
if (options['x']) c_inp = C_exp;
return !Compile(Nargv[1], Nargv[2]);
}
Compile(src, dst)
char *src, *dst;
{
extern struct tokenname tkidf[];
if (! InsertFile(src, (char **) 0, &src)) {
fprint(STDERR,"%s: cannot open %s\n", ProgName, src);
return 0;
}
LineNumber = 1;
FileName = src;
DEFPATH[0] = ".";
DEFPATH[NDIRS] = 0;
init_idf();
InitCst();
reserve(tkidf);
InitScope();
InitTypes();
AddStandards();
#ifdef DEBUG
if (options['l']) {
LexScan();
return 1;
}
#endif DEBUG
open_scope(OPENSCOPE);
GlobalVis = CurrVis;
close_scope(0);
C_init(word_size, pointer_size);
if (! C_open(dst)) fatal("could not open output file");
C_magic();
C_ms_emx(word_size, pointer_size);
CompUnit();
C_ms_src((arith) (LineNumber - 1), FileName);
if (!err_occurred) {
C_exp(Defined->mod_vis->sc_scope->sc_name);
WalkModule(Defined);
if (fp_used) C_ms_flt();
}
C_close();
#ifdef DEBUG
if (options['i']) Info();
#endif
return ! err_occurred;
}
#ifdef DEBUG
LexScan()
{
register struct token *tkp = &dot;
extern char *symbol2str();
while (LLlex() > 0) {
print(">>> %s ", symbol2str(tkp->tk_symb));
switch(tkp->tk_symb) {
case IDENT:
print("%s\n", tkp->TOK_IDF->id_text);
break;
case INTEGER:
print("%ld\n", tkp->TOK_INT);
break;
case REAL:
print("%s\n", tkp->TOK_REL);
break;
case STRING:
print("\"%s\"\n", tkp->TOK_STR);
break;
default:
print("\n");
}
}
}
#endif
AddStandards()
{
register struct def *df;
extern struct def *Enter();
static struct node nilnode = { 0, 0, Value, 0, { INTEGER, 0}};
(void) Enter("ABS", D_PROCEDURE, std_type, S_ABS);
(void) Enter("CAP", D_PROCEDURE, std_type, S_CAP);
(void) Enter("CHR", D_PROCEDURE, std_type, S_CHR);
(void) Enter("FLOAT", D_PROCEDURE, std_type, S_FLOAT);
(void) Enter("HIGH", D_PROCEDURE, std_type, S_HIGH);
(void) Enter("HALT", D_PROCEDURE, std_type, S_HALT);
(void) Enter("EXCL", D_PROCEDURE, std_type, S_EXCL);
(void) Enter("DEC", D_PROCEDURE, std_type, S_DEC);
(void) Enter("INC", D_PROCEDURE, std_type, S_INC);
(void) Enter("VAL", D_PROCEDURE, std_type, S_VAL);
(void) Enter("NEW", D_PROCEDURE, std_type, S_NEW);
(void) Enter("DISPOSE", D_PROCEDURE, std_type, S_DISPOSE);
(void) Enter("TRUNC", D_PROCEDURE, std_type, S_TRUNC);
(void) Enter("SIZE", D_PROCEDURE, std_type, S_SIZE);
(void) Enter("ORD", D_PROCEDURE, std_type, S_ORD);
(void) Enter("ODD", D_PROCEDURE, std_type, S_ODD);
(void) Enter("MAX", D_PROCEDURE, std_type, S_MAX);
(void) Enter("MIN", D_PROCEDURE, std_type, S_MIN);
(void) Enter("INCL", D_PROCEDURE, std_type, S_INCL);
(void) Enter("CHAR", D_TYPE, char_type, 0);
(void) Enter("INTEGER", D_TYPE, int_type, 0);
(void) Enter("LONGINT", D_TYPE, longint_type, 0);
(void) Enter("REAL", D_TYPE, real_type, 0);
(void) Enter("LONGREAL", D_TYPE, longreal_type, 0);
(void) Enter("BOOLEAN", D_TYPE, bool_type, 0);
(void) Enter("CARDINAL", D_TYPE, card_type, 0);
df = Enter("NIL", D_CONST, address_type, 0);
df->con_const = &nilnode;
nilnode.nd_INT = 0;
nilnode.nd_type = address_type;
(void) Enter("PROC",
D_TYPE,
construct_type(T_PROCEDURE, NULLTYPE),
0);
df = Enter("BITSET", D_TYPE, bitset_type, 0);
df = Enter("TRUE", D_ENUM, bool_type, 0);
df->enm_val = 1;
df->enm_next = Enter("FALSE", D_ENUM, bool_type, 0);
df = df->enm_next;
df->enm_val = 0;
df->enm_next = 0;
}
/* How do you like that! Modula-2 in a C-program.
*/
char SYSTEM[] = "\
DEFINITION MODULE SYSTEM;\n\
TYPE PROCESS = ADDRESS;\n\
PROCEDURE NEWPROCESS(P:PROC; A:ADDRESS; n:CARDINAL; VAR p1:ADDRESS);\n\
PROCEDURE TRANSFER(VAR p1,p2:ADDRESS);\n\
END SYSTEM.\n";
do_SYSTEM()
{
/* Simulate the reading of the SYSTEM definition module
*/
open_scope(CLOSEDSCOPE);
(void) Enter("WORD", D_TYPE, word_type, 0);
(void) Enter("BYTE", D_TYPE, byte_type, 0);
(void) Enter("ADDRESS", D_TYPE, address_type, 0);
(void) Enter("ADR", D_PROCEDURE, std_type, S_ADR);
(void) Enter("TSIZE", D_PROCEDURE, std_type, S_TSIZE);
if (!InsertText(SYSTEM, sizeof(SYSTEM) - 1)) {
fatal("could not insert text");
}
DefModule();
close_scope(SC_CHKFORW);
}
#ifdef DEBUG
int cntlines;
Info()
{
extern int cnt_def, cnt_node, cnt_paramlist, cnt_type,
cnt_switch_hdr, cnt_case_entry,
cnt_scope, cnt_scopelist, cnt_tmpvar;
print("\
%6d def\n%6d node\n%6d paramlist\n%6d type\n%6d switch_hdr\n\
%6d case_entry\n%6d scope\n%6d scopelist\n%6d tmpvar\n",
cnt_def, cnt_node, cnt_paramlist, cnt_type,
cnt_switch_hdr, cnt_case_entry,
cnt_scope, cnt_scopelist, cnt_tmpvar);
print("\nNumber of lines read: %d\n", cntlines);
}
#endif

15
lang/m2/comp/main.h
View File

@@ -1,15 +0,0 @@
/* S O M E G L O B A L V A R I A B L E S */
extern char options[]; /* indicating which options were given */
extern int DefinitionModule;
/* flag indicating that we are reading a definition
module
*/
extern struct def *Defined;
/* definition structure of module defined in this
compilation
*/
extern char *DEFPATH[]; /* search path for DEFINITION MODULE's */
extern int state; /* either IMPLEMENTATION or PROGRAM */

26
lang/m2/comp/make.allocd
View File

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

35
lang/m2/comp/make.hfiles
View File

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

7
lang/m2/comp/make.next
View File

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

34
lang/m2/comp/make.tokcase
View File

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

6
lang/m2/comp/make.tokfile
View File

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

10
lang/m2/comp/misc.H
View File

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

57
lang/m2/comp/misc.c
View File

@@ -1,57 +0,0 @@
/* M I S C E L L A N E O U S R O U T I N E S */
#include <alloc.h>
#include <em_arith.h>
#include <em_label.h>
#include "f_info.h"
#include "misc.h"
#include "LLlex.h"
#include "idf.h"
#include "node.h"
match_id(id1, id2)
register struct idf *id1, *id2;
{
/* Check that identifiers id1 and id2 are equal. If they
are not, check that we did'nt generate them in the
first place, and if not, give an error message
*/
if (id1 != id2 && !is_anon_idf(id1) && !is_anon_idf(id2)) {
error("name \"%s\" does not match block name \"%s\"",
id1->id_text,
id2->id_text
);
}
}
struct idf *
gen_anon_idf()
{
/* A new idf is created out of nowhere, to serve as an
anonymous name.
*/
static int name_cnt;
char buff[100];
char *sprint();
sprint(buff, "#%d in %s, line %u",
++name_cnt, FileName, LineNumber);
return str2idf(buff, 1);
}
not_declared(what, id, where)
char *what, *where;
register struct node *id;
{
/* The identifier "id" is not declared. If it is not generated,
give an error message
*/
if (!is_anon_idf(id->nd_IDF)) {
node_error(id,
"%s \"%s\" not declared%s",
what,
id->nd_IDF->id_text,
where);
}
}

7
lang/m2/comp/misc.h
View File

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

4
lang/m2/comp/nmclash.c
View File

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

47
lang/m2/comp/node.H
View File

@@ -1,47 +0,0 @@
/* N O D E O F A N A B S T R A C T P A R S E T R E E */
struct node {
struct node *next;
#define nd_left next
struct node *nd_right;
int nd_class; /* kind of node */
#define Value 0 /* constant */
#define Arrsel 1 /* array selection */
#define Oper 2 /* binary operator */
#define Uoper 3 /* unary operator */
#define Arrow 4 /* ^ construction */
#define Call 5 /* cast or procedure - or function call */
#define Name 6 /* an identifier */
#define Set 7 /* a set constant */
#define Xset 8 /* a set */
#define Def 9 /* an identified name */
#define Stat 10 /* a statement */
#define Link 11
#define LinkDef 12
/* do NOT change the order or the numbers!!! */
struct type *nd_type; /* type of this node */
struct token nd_token;
#define nd_set nd_token.tk_data.tk_set
#define nd_def nd_token.tk_data.tk_def
#define nd_lab nd_token.tk_data.tk_lab
#define nd_symb nd_token.tk_symb
#define nd_lineno nd_token.tk_lineno
#define nd_IDF nd_token.TOK_IDF
#define nd_STR nd_token.TOK_STR
#define nd_SLE nd_token.TOK_SLE
#define nd_INT nd_token.TOK_INT
#define nd_REL nd_token.TOK_REL
};
/* ALLOCDEF "node" 50 */
extern struct node *MkNode(), *MkLeaf();
#define NULLNODE ((struct node *) 0)
#define HASSELECTORS 002
#define VARIABLE 004
#define VALUE 010
#define IsCast(lnd) (((lnd)->nd_class == Def || (lnd)->nd_class == LinkDef) && is_type((lnd)->nd_def))
#define IsProcCall(lnd) ((lnd)->nd_type->tp_fund == T_PROCEDURE)

92
lang/m2/comp/node.c
View File

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

185
lang/m2/comp/options.c
View File

@@ -1,185 +0,0 @@
/* U S E R O P T I O N - H A N D L I N G */
#include "idfsize.h"
#include "ndir.h"
#include <em_arith.h>
#include <em_label.h>
#include "type.h"
#include "main.h"
#include "warning.h"
#define MINIDFSIZE 14
#if MINIDFSIZE < 14
You fouled up! MINIDFSIZE has to be at least 14 or the compiler will not
recognize some keywords!
#endif
extern int idfsize;
static int ndirs;
int warning_classes;
DoOption(text)
register char *text;
{
switch(*text++) {
default:
options[text[-1]]++; /* flags, debug options etc. */
break;
/* recognized flags:
-L: don't generate fil/lin
-p: generate procentry/procexit
-w: no warnings
-n: no register messages
and many more if DEBUG
*/
case 'w':
if (*text) {
while (*text) {
switch(*text++) {
case 'O':
warning_classes &= ~W_OLDFASHIONED;
break;
case 'R':
warning_classes &= ~W_STRICT;
break;
case 'W':
warning_classes &= ~W_ORDINARY;
break;
}
}
}
else warning_classes = 0;
break;
case 'W':
while (*text) {
switch(*text++) {
case 'O':
warning_classes |= W_OLDFASHIONED;
break;
case 'R':
warning_classes |= W_STRICT;
break;
case 'W':
warning_classes |= W_ORDINARY;
break;
}
}
break;
case 'M': { /* maximum identifier length */
char *t = text; /* because &text is illegal */
idfsize = txt2int(&t);
if (*t || idfsize <= 0)
fatal("malformed -M option");
if (idfsize > IDFSIZE) {
idfsize = IDFSIZE;
warning(W_ORDINARY,"maximum identifier length is %d", IDFSIZE);
}
if (idfsize < MINIDFSIZE) {
warning(W_ORDINARY, "minimum identifier length is %d", MINIDFSIZE);
idfsize = MINIDFSIZE;
}
}
break;
case 'I' :
if (*text) {
register int i = ndirs++;
register char *new = text;
while (new) {
register char *tmp = DEFPATH[i];
if (i >= NDIRS)
fatal("too many -I options");
DEFPATH[i++] = new;
new = tmp;
}
}
else DEFPATH[ndirs] = 0;
break;
case 'V' : /* set object sizes and alignment requirements */
{
arith size;
int align;
char c;
char *t;
while (c = *text++) {
t = text;
size = txt2int(&t);
align = 0;
if (*(text = t) == '.') {
t = text + 1;
align = txt2int(&t);
text = t;
}
switch (c) {
case 'w': /* word */
if (size != (arith)0) {
word_size = size;
dword_size = 2 * size;
}
if (align != 0) word_align = align;
break;
case 'i': /* int */
if (size != (arith)0) int_size = size;
if (align != 0) int_align = align;
break;
case 's': /* short (subranges) */
if (size != 0) short_size = size;
if (align != 0) short_align = align;
break;
case 'l': /* longint */
if (size != (arith)0) long_size = size;
if (align != 0) long_align = align;
break;
case 'f': /* real */
if (size != (arith)0) float_size = size;
if (align != 0) float_align = align;
break;
case 'd': /* longreal */
if (size != (arith)0) double_size = size;
if (align != 0) double_align = align;
break;
case 'p': /* pointer */
if (size != (arith)0) pointer_size = size;
if (align != 0) pointer_align = align;
break;
case 'S': /* initial record alignment */
if (align != (arith)0) struct_align = align;
break;
default:
error("-V: bad type indicator %c\n", c);
}
}
break;
}
}
}
int
txt2int(tp)
register char **tp;
{
/* the integer pointed to by *tp is read, while increasing
*tp; the resulting value is yielded.
*/
register int val = 0;
register int ch;
while (ch = **tp, ch >= '0' && ch <= '9') {
val = val * 10 + ch - '0';
(*tp)++;
}
return val;
}

4
lang/m2/comp/param.h
View File

@@ -1,4 +0,0 @@
/* $Header$ */
#define IDFSIZE 256
#define NUMSIZE 256

144
lang/m2/comp/print.c
View File

@@ -1,144 +0,0 @@
/* P R I N T R O U T I N E S */
#include <system.h>
#include <em_arith.h>
#define SSIZE 1024 /* string-buffer size for print routines */
char *long2str();
doprnt(fp, fmt, argp)
File *fp;
char *fmt;
int argp[];
{
char buf[SSIZE];
sys_write(fp, buf, format(buf, fmt, (char *)argp));
}
/*VARARGS1*/
printf(fmt, args)
char *fmt;
char args;
{
char buf[SSIZE];
sys_write(STDOUT, buf, format(buf, fmt, &args));
}
/*VARARGS1*/
fprintf(fp, fmt, args)
File *fp;
char *fmt;
char args;
{
char buf[SSIZE];
sys_write(fp, buf, format(buf, fmt, &args));
}
/*VARARGS1*/
char *
sprintf(buf, fmt, args)
char *buf, *fmt;
char args;
{
buf[format(buf, fmt, &args)] = '\0';
return buf;
}
int
format(buf, fmt, argp)
char *buf, *fmt;
char *argp;
{
register char *pf = fmt, *pa = argp;
register char *pb = buf;
while (*pf) {
if (*pf == '%') {
register int width, base, pad, npad;
char *arg;
char cbuf[2];
char *badformat = "<bad format>";
/* get padder */
if (*++pf == '0') {
pad = '0';
++pf;
}
else
pad = ' ';
/* get width */
width = 0;
while (*pf >= '0' && *pf <= '9')
width = 10 * width + *pf++ - '0';
/* get text and move pa */
if (*pf == 's') {
arg = *(char **)pa;
pa += sizeof(char *);
}
else
if (*pf == 'c') {
cbuf[0] = * (char *) pa;
cbuf[1] = '\0';
pa += sizeof(int);
arg = &cbuf[0];
}
else
if (*pf == 'l') {
/* alignment ??? */
if (base = integral(*++pf)) {
arg = long2str(*(long *)pa, base);
pa += sizeof(long);
}
else {
pf--;
arg = badformat;
}
}
else
if (base = integral(*pf)) {
arg = long2str((long)*(int *)pa, base);
pa += sizeof(int);
}
else
if (*pf == '%')
arg = "%";
else
arg = badformat;
npad = width - strlen(arg);
while (npad-- > 0)
*pb++ = pad;
while (*pb++ = *arg++);
pb--;
pf++;
}
else
*pb++ = *pf++;
}
return pb - buf;
}
integral(c)
{
switch (c) {
case 'b':
return -2;
case 'd':
return 10;
case 'o':
return -8;
case 'u':
return -10;
case 'x':
return -16;
}
return 0;
}

236
lang/m2/comp/program.g
View File

@@ -1,236 +0,0 @@
/* O V E R A L L S T R U C T U R E */
{
#include "debug.h"
#include <alloc.h>
#include <em_arith.h>
#include <em_label.h>
#include "main.h"
#include "idf.h"
#include "LLlex.h"
#include "scope.h"
#include "def.h"
#include "type.h"
#include "node.h"
#include "f_info.h"
#include "warning.h"
}
/*
The grammar as given by Wirth is already almost LL(1); the
main problem is that the full form of a qualified designator
may be:
[ module_ident '.' ]* IDENT [ '.' field_ident ]*
which is quite confusing to an LL(1) parser. Rather than
resorting to context-sensitive techniques, I have decided
to render this as:
IDENT [ '.' IDENT ]*
on the grounds that it is quite natural to consider the first
IDENT to be the name of the object and regard the others as
field identifiers.
*/
%lexical LLlex;
%start CompUnit, CompilationUnit;
%start DefModule, DefinitionModule;
ModuleDeclaration
{
register struct def *df;
struct node *exportlist = 0;
int qualified;
} :
MODULE IDENT { df = DefineLocalModule(dot.TOK_IDF); }
priority(df)
';'
import(1)*
export(&qualified, &exportlist)?
block(&(df->mod_body))
IDENT { if (exportlist) {
EnterExportList(exportlist, qualified);
}
close_scope(SC_CHKFORW|SC_CHKPROC|SC_REVERSE);
match_id(df->df_idf, dot.TOK_IDF);
}
;
priority(register struct def *df;)
{
register struct node *nd;
} :
[
'[' ConstExpression(&(df->mod_priority)) ']'
{ if (!(df->mod_priority->nd_type->tp_fund &
T_CARDINAL)) {
node_error(df->mod_priority,
"illegal priority");
}
}
|
{ df->mod_priority = 0; }
]
;
export(int *QUALflag; struct node **ExportList;):
EXPORT
[
QUALIFIED
{ *QUALflag = D_QEXPORTED; }
|
{ *QUALflag = D_EXPORTED; }
]
IdentList(ExportList) ';'
;
import(int local;)
{
struct node *ImportList;
register struct node *FromId = 0;
register struct def *df;
extern struct def *GetDefinitionModule();
} :
[ FROM
IDENT { FromId = MkLeaf(Name, &dot);
if (local) df = lookfor(FromId,enclosing(CurrVis),0);
else df = GetDefinitionModule(dot.TOK_IDF, 1);
}
]?
IMPORT IdentList(&ImportList) ';'
/*
When parsing a global module, this is the place where we must
read already compiled definition modules.
If the FROM clause is present, the identifier in it is a module
name, otherwise the names in the import list are module names.
*/
{ if (FromId) {
EnterFromImportList(ImportList, df, FromId);
}
else EnterImportList(ImportList, local);
}
;
DefinitionModule
{
register struct def *df;
struct node *exportlist;
int dummy;
extern struct idf *DefId;
} :
DEFINITION
MODULE IDENT { df = define(dot.TOK_IDF, GlobalScope, D_MODULE);
df->df_flags |= D_BUSY;
if (!Defined) Defined = df;
if (df->df_idf != DefId) {
error("DEFINITION MODULE name is not \"%s\"",
DefId->id_text);
}
CurrentScope->sc_name = df->df_idf->id_text;
df->mod_vis = CurrVis;
df->df_type = standard_type(T_RECORD, 1, (arith) 1);
df->df_type->rec_scope = df->mod_vis->sc_scope;
DefinitionModule++;
}
';'
import(0)*
[
export(&dummy, &exportlist)
/* New Modula-2 does not have export lists in definition
modules. Issue a warning.
*/
{
node_warning(exportlist, W_OLDFASHIONED, "export list in definition module ignored");
FreeNode(exportlist);
}
|
/* empty */
]
definition* END IDENT
{ register struct def *df1 = CurrentScope->sc_def;
while (df1) {
/* Make all definitions "QUALIFIED EXPORT" */
df1->df_flags |= D_QEXPORTED;
df1 = df1->df_nextinscope;
}
DefinitionModule--;
match_id(df->df_idf, dot.TOK_IDF);
df->df_flags &= ~D_BUSY;
}
'.'
;
definition
{
register struct def *df;
struct def *dummy;
} :
CONST [ %persistent ConstantDeclaration ';' ]*
|
TYPE
[ %persistent
IDENT { df = define(dot.TOK_IDF, CurrentScope, D_TYPE); }
[ '=' type(&(df->df_type))
| /* empty */
/*
Here, the exported type has a hidden implementation.
The export is said to be opaque.
It is restricted to pointer types.
*/
{ df->df_kind = D_HIDDEN;
df->df_type = construct_type(T_HIDDEN, NULLTYPE);
}
]
';'
]*
|
VAR [ %persistent VariableDeclaration ';' ]*
|
ProcedureHeading(&dummy, D_PROCHEAD)
';'
;
ProgramModule
{
extern struct def *GetDefinitionModule();
register struct def *df;
} :
MODULE
IDENT { if (state == IMPLEMENTATION) {
df = GetDefinitionModule(dot.TOK_IDF, 0);
CurrVis = df->mod_vis;
RemoveImports(&(CurrentScope->sc_def));
}
else {
Defined = df = define(dot.TOK_IDF, GlobalScope, D_MODULE);
open_scope(CLOSEDSCOPE);
df->mod_vis = CurrVis;
CurrentScope->sc_name = "_M2M";
}
CurrentScope->sc_definedby = df;
}
priority(df)
';' import(0)*
block(&(df->mod_body)) IDENT
{ close_scope(SC_CHKFORW|SC_CHKPROC|SC_REVERSE);
match_id(df->df_idf, dot.TOK_IDF);
}
'.'
;
Module:
DEFINITION
{ fatal("Compiling a definition module"); }
| %default
[
IMPLEMENTATION { state = IMPLEMENTATION; }
|
/* empty */ { state = PROGRAM; }
]
ProgramModule
;
CompilationUnit:
Module
;

227
lang/m2/comp/scope.C
View File

@@ -1,227 +0,0 @@
/* S C O P E M E C H A N I S M */
#include "debug.h"
#include <assert.h>
#include <alloc.h>
#include <em_arith.h>
#include <em_label.h>
#include "LLlex.h"
#include "idf.h"
#include "scope.h"
#include "type.h"
#include "def.h"
#include "node.h"
struct scope *PervasiveScope;
struct scopelist *CurrVis, *GlobalVis;
extern int proclevel;
static struct scopelist *PervVis;
extern char options[];
/* STATICALLOCDEF "scope" 10 */
/* STATICALLOCDEF "scopelist" 10 */
open_scope(scopetype)
{
/* Open a scope that is either open (automatic imports) or closed.
*/
register struct scope *sc = new_scope();
register struct scopelist *ls = new_scopelist();
assert(scopetype == OPENSCOPE || scopetype == CLOSEDSCOPE);
sc->sc_scopeclosed = scopetype == CLOSEDSCOPE;
sc->sc_level = proclevel;
ls->sc_scope = sc;
ls->sc_encl = CurrVis;
if (scopetype == OPENSCOPE) {
ls->next = ls->sc_encl;
}
else ls->next = PervVis;
CurrVis = ls;
}
InitScope()
{
register struct scope *sc = new_scope();
register struct scopelist *ls = new_scopelist();
sc->sc_scopeclosed = 0;
sc->sc_def = 0;
sc->sc_level = proclevel;
PervasiveScope = sc;
ls->next = 0;
ls->sc_encl = 0;
ls->sc_scope = PervasiveScope;
PervVis = ls;
CurrVis = ls;
}
Forward(tk, ptp)
struct node *tk;
struct type *ptp;
{
/* Enter a forward reference into a list belonging to the
current scope. This is used for POINTER declarations, which
may have forward references that must howewer be declared in the
same scope.
*/
register struct def *df = define(tk->nd_IDF, CurrentScope, D_FORWTYPE);
if (df->df_kind == D_TYPE) {
ptp->next = df->df_type;
return;
}
df->df_forw_type = ptp;
df->df_forw_node = tk;
}
STATIC
chk_proc(df)
register struct def *df;
{
/* Called at scope closing. Check all definitions, and if one
is a D_PROCHEAD, the procedure was not defined.
Also check that hidden types are defined.
*/
while (df) {
if (df->df_kind == D_HIDDEN) {
error("hidden type \"%s\" not declared",
df->df_idf->id_text);
}
else if (df->df_kind == D_PROCHEAD) {
/* A not defined procedure
*/
error("procedure \"%s\" not defined",
df->df_idf->id_text);
FreeNode(df->for_node);
}
df = df->df_nextinscope;
}
}
STATIC
chk_forw(pdf)
register struct def **pdf;
{
/* Called at scope close. Look for all forward definitions and
if the scope was a closed scope, give an error message for
them, and otherwise move them to the enclosing scope.
*/
register struct def *df;
while (df = *pdf) {
if (df->df_kind == D_FORWTYPE) {
register struct def *df1 = df;
*pdf = df->df_nextinscope;
RemoveFromIdList(df);
df = lookfor(df->df_forw_node, CurrVis, 1);
if (! df->df_kind & (D_ERROR|D_FTYPE|D_TYPE)) {
node_error(df1->df_forw_node, "\"%s\" is not a type", df1->df_idf->id_text);
}
df1->df_forw_type->next = df->df_type;
FreeNode(df1->df_forw_node);
free_def(df1);
continue;
}
else if (df->df_kind == D_FTYPE) {
df->df_kind = D_TYPE;
df->df_forw_type->next = df->df_type;
}
else if (df->df_kind & (D_FORWARD|D_FORWMODULE)) {
/* These definitions must be found in
the enclosing closed scope, which of course
may be the scope that is now closed!
*/
if (scopeclosed(CurrentScope)) {
/* Indeed, the scope was a closed
scope, so give error message
*/
node_error(df->for_node, "identifier \"%s\" not declared",
df->df_idf->id_text);
FreeNode(df->for_node);
}
else {
/* This scope was an open scope.
Maybe the definitions are in the
enclosing scope?
*/
register struct scopelist *ls =
nextvisible(CurrVis);
struct def *df1 = df->df_nextinscope;
if (df->df_kind == D_FORWMODULE) {
df->for_vis->next = ls;
}
df->df_nextinscope = ls->sc_scope->sc_def;
ls->sc_scope->sc_def = df;
df->df_scope = ls->sc_scope;
*pdf = df1;
continue;
}
}
pdf = &df->df_nextinscope;
}
}
Reverse(pdf)
struct def **pdf;
{
/* Reverse the order in the list of definitions in a scope.
This is neccesary because this list is built in reverse.
Also, while we're at it, remove uninteresting definitions
from this list.
*/
register struct def *df, *df1;
#define INTERESTING D_MODULE|D_PROCEDURE|D_PROCHEAD|D_VARIABLE
df = 0;
df1 = *pdf;
while (df1) {
if (df1->df_kind & INTERESTING) {
struct def *prev = df;
df = df1;
df1 = df1->df_nextinscope;
df->df_nextinscope = prev;
}
else df1 = df1->df_nextinscope;
}
*pdf = df;
}
close_scope(flag)
{
/* Close a scope. If "flag" is set, check for forward declarations,
either POINTER declarations, or EXPORTs, or forward references
to MODULES
*/
register struct scope *sc = CurrentScope;
assert(sc != 0);
if (flag) {
DO_DEBUG(options['S'], PrScopeDef(sc->sc_def));
if (flag & SC_CHKPROC) chk_proc(sc->sc_def);
if (flag & SC_CHKFORW) chk_forw(&(sc->sc_def));
if (flag & SC_REVERSE) Reverse(&(sc->sc_def));
}
CurrVis = enclosing(CurrVis);
}
#ifdef DEBUG
PrScopeDef(df)
register struct def *df;
{
print("List of definitions in currently ended scope:\n");
while (df) {
PrDef(df);
df = df->df_nextinscope;
}
}
#endif

42
lang/m2/comp/scope.h
View File

@@ -1,42 +0,0 @@
/* S C O P E M E C H A N I S M */
#define OPENSCOPE 0 /* Indicating an open scope */
#define CLOSEDSCOPE 1 /* Indicating a closed scope (module) */
#define SC_CHKFORW 1 /* Check for forward definitions when closing
a scope
*/
#define SC_CHKPROC 2 /* Check for forward procedure definitions
when closing a scope
*/
#define SC_REVERSE 4 /* Reverse list of definitions, to get it
back into original order
*/
struct scope {
struct scope *next;
char *sc_name; /* name of this scope */
struct def *sc_def; /* list of definitions in this scope */
arith sc_off; /* offsets of variables in this scope */
char sc_scopeclosed; /* flag indicating closed or open scope */
int sc_level; /* level of this scope */
struct def *sc_definedby; /* The def structure defining this scope */
};
struct scopelist {
struct scopelist *next;
struct scope *sc_scope;
struct scopelist *sc_encl;
};
extern struct scope
*PervasiveScope;
extern struct scopelist
*CurrVis, *GlobalVis;
#define CurrentScope (CurrVis->sc_scope)
#define GlobalScope (GlobalVis->sc_scope)
#define enclosing(x) ((x)->sc_encl)
#define scopeclosed(x) ((x)->sc_scopeclosed)
#define nextvisible(x) ((x)->next) /* use with scopelists */

28
lang/m2/comp/standards.h
View File

@@ -1,28 +0,0 @@
/* S T A N D A R D P R O C E D U R E S A N D F U N C T I O N S */
#define S_ABS 1
#define S_CAP 2
#define S_CHR 3
#define S_DEC 4
#define S_EXCL 5
#define S_FLOAT 6
#define S_HALT 7
#define S_HIGH 8
#define S_INC 9
#define S_INCL 10
#define S_MAX 11
#define S_MIN 12
#define S_ODD 13
#define S_ORD 14
#define S_SIZE 15
#define S_TRUNC 16
#define S_VAL 17
#define S_NEW 18
#define S_DISPOSE 19
/* Standard procedures and functions defined in the SYSTEM module ... */
#define S_ADR 50
#define S_TSIZE 51
#define S_NEWPROCESS 52
#define S_TRANSFER 53

252
lang/m2/comp/statement.g
View File

@@ -1,252 +0,0 @@
/* S T A T E M E N T S */
{
#include <assert.h>
#include <em_arith.h>
#include <em_label.h>
#include "idf.h"
#include "LLlex.h"
#include "scope.h"
#include "def.h"
#include "type.h"
#include "node.h"
static int loopcount = 0; /* Count nested loops */
}
statement(register struct node **pnd;)
{
register struct node *nd;
extern int return_occurred;
} :
/*
* This part is not in the reference grammar. The reference grammar
* states : assignment | ProcedureCall | ...
* but this gives LL(1) conflicts
*/
designator(pnd)
[ { nd = MkNode(Call, *pnd, NULLNODE, &dot);
nd->nd_symb = '(';
}
ActualParameters(&(nd->nd_right))?
|
[ BECOMES
| '=' { error("':=' expected instead of '='");
DOT = BECOMES;
}
]
{ nd = MkNode(Stat, *pnd, NULLNODE, &dot); }
expression(&(nd->nd_right))
]
{ *pnd = nd; }
/*
* end of changed part
*/
|
IfStatement(pnd)
|
CaseStatement(pnd)
|
WhileStatement(pnd)
|
RepeatStatement(pnd)
|
{ loopcount++; }
LoopStatement(pnd)
{ loopcount--; }
|
ForStatement(pnd)
|
WithStatement(pnd)
|
EXIT
{ if (!loopcount) error("EXIT not in a LOOP");
*pnd = MkLeaf(Stat, &dot);
}
|
ReturnStatement(pnd)
{ return_occurred = 1; }
|
/* empty */ { *pnd = 0; }
;
/*
* The next two rules in-line in "Statement", because of an LL(1) conflict
assignment:
designator BECOMES expression
;
ProcedureCall:
designator ActualParameters?
;
*/
StatementSequence(register struct node **pnd;)
{
struct node *nd;
} :
statement(pnd)
[ %persistent
';' statement(&nd)
{ if (nd) {
register struct node *nd1 =
MkNode(Link, *pnd, nd, &dot);
*pnd = nd1;
nd1->nd_symb = ';';
pnd = &(nd1->nd_right);
}
}
]*
;
IfStatement(struct node **pnd;)
{
register struct node *nd;
} :
IF { nd = MkLeaf(Stat, &dot);
*pnd = nd;
}
expression(&(nd->nd_left))
THEN { nd->nd_right = MkLeaf(Link, &dot);
nd = nd->nd_right;
}
StatementSequence(&(nd->nd_left))
[
ELSIF { nd->nd_right = MkLeaf(Stat, &dot);
nd = nd->nd_right;
nd->nd_symb = IF;
}
expression(&(nd->nd_left))
THEN { nd->nd_right = MkLeaf(Link, &dot);
nd = nd->nd_right;
}
StatementSequence(&(nd->nd_left))
]*
[
ELSE
StatementSequence(&(nd->nd_right))
]?
END
;
CaseStatement(struct node **pnd;)
{
register struct node *nd;
struct type *tp = 0;
} :
CASE { *pnd = nd = MkLeaf(Stat, &dot); }
expression(&(nd->nd_left))
OF
case(&(nd->nd_right), &tp)
{ nd = nd->nd_right; }
[
'|'
case(&(nd->nd_right), &tp)
{ nd = nd->nd_right; }
]*
[ ELSE StatementSequence(&(nd->nd_right)) ]?
END
;
case(struct node **pnd; struct type **ptp;) :
[ CaseLabelList(ptp, pnd)
':' { *pnd = MkNode(Link, *pnd, NULLNODE, &dot); }
StatementSequence(&((*pnd)->nd_right))
]?
{ *pnd = MkNode(Link, *pnd, NULLNODE, &dot);
(*pnd)->nd_symb = '|';
}
;
WhileStatement(struct node **pnd;)
{
register struct node *nd;
}:
WHILE { *pnd = nd = MkLeaf(Stat, &dot); }
expression(&(nd->nd_left))
DO
StatementSequence(&(nd->nd_right))
END
;
RepeatStatement(struct node **pnd;)
{
register struct node *nd;
}:
REPEAT { *pnd = nd = MkLeaf(Stat, &dot); }
StatementSequence(&(nd->nd_left))
UNTIL
expression(&(nd->nd_right))
;
ForStatement(struct node **pnd;)
{
register struct node *nd, *nd1;
struct node *dummy;
}:
FOR { *pnd = nd = MkLeaf(Stat, &dot); }
IDENT { nd->nd_IDF = dot.TOK_IDF; }
BECOMES { nd->nd_left = nd1 = MkLeaf(Stat, &dot); }
expression(&(nd1->nd_left))
TO
expression(&(nd1->nd_right))
[
BY
ConstExpression(&dummy)
{ if (!(dummy->nd_type->tp_fund & T_INTORCARD)) {
error("illegal type in BY clause");
}
nd1->nd_INT = dummy->nd_INT;
FreeNode(dummy);
}
|
{ nd1->nd_INT = 1; }
]
DO
StatementSequence(&(nd->nd_right))
END
;
LoopStatement(struct node **pnd;):
LOOP { *pnd = MkLeaf(Stat, &dot); }
StatementSequence(&((*pnd)->nd_right))
END
;
WithStatement(struct node **pnd;)
{
register struct node *nd;
}:
WITH { *pnd = nd = MkLeaf(Stat, &dot); }
designator(&(nd->nd_left))
DO
StatementSequence(&(nd->nd_right))
END
;
ReturnStatement(struct node **pnd;)
{
register struct def *df = CurrentScope->sc_definedby;
register struct node *nd;
} :
RETURN { *pnd = nd = MkLeaf(Stat, &dot); }
[
expression(&(nd->nd_right))
{ if (scopeclosed(CurrentScope)) {
error("a module body has no result value");
}
else if (! ResultType(df->df_type)) {
error("procedure \"%s\" has no result value", df->df_idf->id_text);
}
}
|
{ if (ResultType(df->df_type)) {
error("procedure \"%s\" must return a value", df->df_idf->id_text);
}
}
]
;

295
lang/m2/comp/tab.c
View File

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

130
lang/m2/comp/tmpvar.C
View File

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

99
lang/m2/comp/tokenname.c
View File

@@ -1,99 +0,0 @@
/* T O K E N D E F I N I T I O N S */
#include "tokenname.h"
#include "Lpars.h"
#include "idf.h"
/* To centralize the declaration of %tokens, their presence in this
file is taken as their declaration. The Makefile will produce
a grammar file (tokenfile.g) from this file. This scheme ensures
that all tokens have a printable name.
Also, the "token2str.c" file is produced from this file.
*/
struct tokenname tkspec[] = { /* the names of the special tokens */
{IDENT, "identifier"},
{STRING, "string"},
{INTEGER, "number"},
{REAL, "real"},
{0, ""}
};
struct tokenname tkcomp[] = { /* names of the composite tokens */
{LESSEQUAL, "<="},
{GREATEREQUAL, ">="},
{UPTO, ".."},
{BECOMES, ":="},
{0, ""}
};
struct tokenname tkidf[] = { /* names of the identifier tokens */
{AND, "AND"},
{ARRAY, "ARRAY"},
{BEGIN, "BEGIN"},
{BY, "BY"},
{CASE, "CASE"},
{CONST, "CONST"},
{DEFINITION, "DEFINITION"},
{DIV, "DIV"},
{DO, "DO"},
{ELSE, "ELSE"},
{ELSIF, "ELSIF"},
{END, "END"},
{EXIT, "EXIT"},
{EXPORT, "EXPORT"},
{FOR, "FOR"},
{FROM, "FROM"},
{IF, "IF"},
{IMPLEMENTATION, "IMPLEMENTATION"},
{IMPORT, "IMPORT"},
{IN, "IN"},
{LOOP, "LOOP"},
{MOD, "MOD"},
{MODULE, "MODULE"},
{NOT, "NOT"},
{OF, "OF"},
{OR, "OR"},
{POINTER, "POINTER"},
{PROCEDURE, "PROCEDURE"},
{QUALIFIED, "QUALIFIED"},
{RECORD, "RECORD"},
{REPEAT, "REPEAT"},
{RETURN, "RETURN"},
{SET, "SET"},
{THEN, "THEN"},
{TO, "TO"},
{TYPE, "TYPE"},
{UNTIL, "UNTIL"},
{VAR, "VAR"},
{WHILE, "WHILE"},
{WITH, "WITH"},
{0, ""}
};
struct tokenname tkinternal[] = { /* internal keywords */
{PROGRAM, ""},
{0, "0"}
};
struct tokenname tkstandard[] = { /* standard identifiers */
{0, ""}
};
/* Some routines to handle tokennames */
reserve(resv)
register struct tokenname *resv;
{
/* The names of the tokens described in resv are entered
as reserved words.
*/
register struct idf *p;
while (resv->tn_symbol) {
p = str2idf(resv->tn_name, 0);
if (!p) fatal("out of Memory");
p->id_reserved = resv->tn_symbol;
resv++;
}
}

8
lang/m2/comp/tokenname.h
View File

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

159
lang/m2/comp/type.H
View File

@@ -1,159 +0,0 @@
/* T Y P E D E S C R I P T O R S T R U C T U R E */
struct paramlist { /* structure for parameterlist of a PROCEDURE */
struct paramlist *next;
struct def *par_def; /* "df" of parameter */
#define IsVarParam(xpar) ((xpar)->par_def->df_flags & D_VARPAR)
#define TypeOfParam(xpar) ((xpar)->par_def->df_type)
};
/* ALLOCDEF "paramlist" 20 */
struct enume {
struct def *en_enums; /* Definitions of enumeration literals */
unsigned int en_ncst; /* Number of constants */
label en_rck; /* Label of range check descriptor */
#define enm_enums tp_value.tp_enum.en_enums
#define enm_ncst tp_value.tp_enum.en_ncst
#define enm_rck tp_value.tp_enum.en_rck
};
struct subrange {
arith su_lb, su_ub; /* lower bound and upper bound */
label su_rck; /* label of range check descriptor */
#define sub_lb tp_value.tp_subrange.su_lb
#define sub_ub tp_value.tp_subrange.su_ub
#define sub_rck tp_value.tp_subrange.su_rck
};
struct array {
struct type *ar_elem; /* type of elements */
label ar_descr; /* label of array descriptor */
arith ar_elsize; /* size of elements */
#define arr_elem tp_value.tp_arr.ar_elem
#define arr_descr tp_value.tp_arr.ar_descr
#define arr_elsize tp_value.tp_arr.ar_elsize
};
struct record {
struct scope *rc_scope; /* scope of this record */
/* members are in the symbol table */
#define rec_scope tp_value.tp_record.rc_scope
};
struct proc {
struct paramlist *pr_params;
arith pr_nbpar;
#define prc_params tp_value.tp_proc.pr_params
#define prc_nbpar tp_value.tp_proc.pr_nbpar
};
struct type {
struct type *next; /* used with ARRAY, PROCEDURE, POINTER, SET,
SUBRANGE, EQUAL
*/
int tp_fund; /* fundamental type or constructor */
#define T_RECORD 0x0001
#define T_ENUMERATION 0x0002
#define T_INTEGER 0x0004
#define T_CARDINAL 0x0008
#define T_EQUAL 0x0010
#define T_REAL 0x0020
#define T_HIDDEN 0x0040
#define T_POINTER 0x0080
#define T_CHAR 0x0100
#define T_WORD 0x0200
#define T_SET 0x0400
#define T_SUBRANGE 0x0800
#define T_PROCEDURE 0x1000
#define T_ARRAY 0x2000
#define T_STRING 0x4000
#define T_INTORCARD (T_INTEGER|T_CARDINAL)
#define T_NUMERIC (T_INTORCARD|T_REAL)
#define T_INDEX (T_ENUMERATION|T_CHAR|T_SUBRANGE)
#define T_DISCRETE (T_INDEX|T_INTORCARD)
#define T_CONSTRUCTED (T_ARRAY|T_SET|T_RECORD)
int tp_align; /* alignment requirement of this type */
arith tp_size; /* size of this type */
union {
struct enume tp_enum;
struct subrange tp_subrange;
struct array tp_arr;
struct record tp_record;
struct proc tp_proc;
} tp_value;
};
/* ALLOCDEF "type" 50 */
extern struct type
*bool_type,
*char_type,
*int_type,
*card_type,
*longint_type,
*real_type,
*longreal_type,
*word_type,
*byte_type,
*address_type,
*intorcard_type,
*bitset_type,
*std_type,
*error_type; /* All from type.c */
extern int
word_align,
short_align,
int_align,
long_align,
float_align,
double_align,
pointer_align,
struct_align; /* All from type.c */
extern arith
word_size,
dword_size,
short_size,
int_size,
long_size,
float_size,
double_size,
pointer_size; /* All from type.c */
extern arith
align(); /* type.c */
struct type
*construct_type(),
*standard_type(),
*set_type(),
*subr_type(),
*proc_type(),
*RemoveEqual(); /* All from type.c */
#define NULLTYPE ((struct type *) 0)
#define IsConformantArray(tpx) ((tpx)->tp_fund==T_ARRAY && (tpx)->next==0)
#define bounded(tpx) ((tpx)->tp_fund & T_INDEX)
#define complex(tpx) ((tpx)->tp_fund & (T_RECORD|T_ARRAY))
#define WA(sz) (align(sz, (int) word_size))
#define ResultType(tpx) (assert((tpx)->tp_fund == T_PROCEDURE),\
(tpx)->next)
#define ParamList(tpx) (assert((tpx)->tp_fund == T_PROCEDURE),\
(tpx)->prc_params)
#define IndexType(tpx) (assert((tpx)->tp_fund == T_ARRAY),\
(tpx)->next)
#define ElementType(tpx) (assert((tpx)->tp_fund == T_SET),\
(tpx)->next)
#define PointedtoType(tpx) (assert((tpx)->tp_fund == T_POINTER),\
(tpx)->next)
#define BaseType(tpx) ((tpx)->tp_fund == T_SUBRANGE ? (tpx)->next : \
(tpx))
#define IsConstructed(tpx) ((tpx)->tp_fund & T_CONSTRUCTED)
extern long full_mask[];
#define fit(n, i) (((n) + (0x80<<(((i)-1)*8)) & ~full_mask[(i)]) == 0)
#define ufit(n, i) (((n) & ~full_mask[(i)]) == 0)

607
lang/m2/comp/type.c
View File

@@ -1,607 +0,0 @@
/* T Y P E D E F I N I T I O N M E C H A N I S M */
#include "target_sizes.h"
#include "debug.h"
#include "maxset.h"
#include <assert.h>
#include <alloc.h>
#include <em_arith.h>
#include <em_label.h>
#include <em_code.h>
#include "def.h"
#include "type.h"
#include "idf.h"
#include "LLlex.h"
#include "node.h"
#include "const.h"
#include "scope.h"
#include "walk.h"
int
word_align = AL_WORD,
short_align = AL_SHORT,
int_align = AL_INT,
long_align = AL_LONG,
float_align = AL_FLOAT,
double_align = AL_DOUBLE,
pointer_align = AL_POINTER,
struct_align = AL_STRUCT;
arith
word_size = SZ_WORD,
dword_size = 2 * SZ_WORD,
int_size = SZ_INT,
short_size = SZ_SHORT,
long_size = SZ_LONG,
float_size = SZ_FLOAT,
double_size = SZ_DOUBLE,
pointer_size = SZ_POINTER;
struct type
*bool_type,
*char_type,
*int_type,
*card_type,
*longint_type,
*real_type,
*longreal_type,
*word_type,
*byte_type,
*address_type,
*intorcard_type,
*bitset_type,
*std_type,
*error_type;
struct type *
construct_type(fund, tp)
int fund;
register struct type *tp;
{
/* fund must be a type constructor.
The pointer to the constructed type is returned.
*/
register struct type *dtp = new_type();
switch (dtp->tp_fund = fund) {
case T_PROCEDURE:
case T_POINTER:
case T_HIDDEN:
dtp->tp_align = pointer_align;
dtp->tp_size = pointer_size;
break;
case T_SET:
dtp->tp_align = word_align;
break;
case T_ARRAY:
if (tp) dtp->tp_align = tp->tp_align;
break;
case T_SUBRANGE:
assert(tp != 0);
dtp->tp_align = tp->tp_align;
dtp->tp_size = tp->tp_size;
break;
default:
crash("funny type constructor");
}
dtp->next = tp;
return dtp;
}
arith
align(pos, al)
arith pos;
int al;
{
arith i;
return pos + ((i = pos % al) ? al - i : 0);
}
struct type *
standard_type(fund, align, size)
int fund;
int align;
arith size;
{
register struct type *tp = new_type();
tp->tp_fund = fund;
tp->tp_align = align ? align : 1;
tp->tp_size = size;
return tp;
}
InitTypes()
{
/* Initialize the predefined types
*/
register struct type *tp;
/* first, do some checking
*/
if (int_size != word_size) {
fatal("integer size not equal to word size");
}
if (int_size != pointer_size) {
fatal("cardinal size not equal to pointer size");
}
if (long_size < int_size || long_size % word_size != 0) {
fatal("illegal long integer size");
}
if (double_size < float_size) {
fatal("long real size smaller than real size");
}
/* character type
*/
char_type = standard_type(T_CHAR, 1, (arith) 1);
char_type->enm_ncst = 256;
/* boolean type
*/
bool_type = standard_type(T_ENUMERATION, 1, (arith) 1);
bool_type->enm_ncst = 2;
/* integer types, also a "intorcard", for integer constants between
0 and MAX(INTEGER)
*/
int_type = standard_type(T_INTEGER, int_align, int_size);
longint_type = standard_type(T_INTEGER, long_align, long_size);
card_type = standard_type(T_CARDINAL, int_align, int_size);
intorcard_type = standard_type(T_INTORCARD, int_align, int_size);
/* floating types
*/
real_type = standard_type(T_REAL, float_align, float_size);
longreal_type = standard_type(T_REAL, double_align, double_size);
/* SYSTEM types
*/
word_type = standard_type(T_WORD, word_align, word_size);
byte_type = standard_type(T_WORD, 1, (arith) 1);
address_type = construct_type(T_POINTER, word_type);
/* create BITSET type
TYPE BITSET = SET OF [0..W-1];
The subrange is a subrange of type cardinal, because the lower bound
is a non-negative integer (See Rep. 6.3)
*/
tp = construct_type(T_SUBRANGE, card_type);
tp->sub_lb = 0;
tp->sub_ub = word_size * 8 - 1;
bitset_type = set_type(tp);
/* a unique type for standard procedures and functions
*/
std_type = construct_type(T_PROCEDURE, NULLTYPE);
/* a unique type indicating an error
*/
error_type = standard_type(T_CHAR, 1, (arith) 1);
}
chk_basesubrange(tp, base)
register struct type *tp, *base;
{
/* A subrange had a specified base. Check that the bases conform.
*/
assert(tp->tp_fund == T_SUBRANGE);
if (base->tp_fund == T_SUBRANGE) {
/* Check that the bounds of "tp" fall within the range
of "base".
*/
if (base->sub_lb > tp->sub_lb || base->sub_ub < tp->sub_ub) {
error("base type has insufficient range");
}
base = base->next;
}
if (base->tp_fund & (T_ENUMERATION|T_CHAR)) {
if (tp->next != base) {
error("specified base does not conform");
}
}
else if (base != card_type && base != int_type) {
error("illegal base for a subrange");
}
else if (base == int_type && tp->next == card_type &&
(tp->sub_ub > max_int || tp->sub_ub < 0)) {
error("upperbound to large for type INTEGER");
}
else if (base != tp->next && base != int_type) {
error("specified base does not conform");
}
tp->next = base;
tp->tp_size = base->tp_size;
tp->tp_align = base->tp_align;
}
struct type *
subr_type(lb, ub)
struct node *lb, *ub;
{
/* Construct a subrange type from the constant expressions
indicated by "lb" and "ub", but first perform some
checks
*/
register struct type *tp = BaseType(lb->nd_type), *res;
if (!TstCompat(lb->nd_type, ub->nd_type)) {
node_error(ub, "types of subrange bounds not equal");
return error_type;
}
if (tp == intorcard_type) {
/* Lower bound >= 0; in this case, the base type is CARDINAL,
according to the language definition, par. 6.3
*/
assert(lb->nd_INT >= 0);
tp = card_type;
}
/* Check base type
*/
if (! (tp->tp_fund & T_DISCRETE)) {
node_error(ub, "illegal base type for subrange");
return error_type;
}
/* Check bounds
*/
if (lb->nd_INT > ub->nd_INT) {
node_error(ub, "lower bound exceeds upper bound");
}
/* Now construct resulting type
*/
res = construct_type(T_SUBRANGE, tp);
res->sub_lb = lb->nd_INT;
res->sub_ub = ub->nd_INT;
res->tp_size = tp->tp_size;
res->tp_align = tp->tp_align;
if (tp == card_type) {
if (ufit(res->sub_ub, 1)) {
res->tp_size = 1;
res->tp_align = 1;
}
else if (ufit(res->sub_ub, 2)) {
res->tp_size = short_size;
res->tp_align = short_align;
}
}
else if (tp == int_type) {
if (fit(res->sub_lb, 1) && fit(res->sub_ub, 1)) {
res->tp_size = 1;
res->tp_align = 1;
}
else if (fit(res->sub_lb, short_size) &&
fit(res->sub_ub, short_size)) {
res->tp_size = short_size;
res->tp_align = short_align;
}
}
return res;
}
struct type *
proc_type(result_type, parameters, n_bytes_params)
struct type *result_type;
struct paramlist *parameters;
arith n_bytes_params;
{
register struct type *tp = construct_type(T_PROCEDURE, result_type);
tp->prc_params = parameters;
tp->prc_nbpar = n_bytes_params;
return tp;
}
genrck(tp)
register struct type *tp;
{
/* generate a range check descriptor for type "tp" when
neccessary. Return its label.
*/
arith lb, ub;
register label ol;
int newlabel = 0;
getbounds(tp, &lb, &ub);
if (tp->tp_fund == T_SUBRANGE) {
if (!(ol = tp->sub_rck)) {
tp->sub_rck = ol = ++data_label;
newlabel = 1;
}
}
else if (!(ol = tp->enm_rck)) {
tp->enm_rck = ol = ++data_label;
newlabel = 1;
}
if (newlabel) {
C_df_dlb(ol);
C_rom_cst(lb);
C_rom_cst(ub);
}
C_lae_dlb(ol, (arith) 0);
C_rck(word_size);
}
getbounds(tp, plo, phi)
register struct type *tp;
arith *plo, *phi;
{
/* Get the bounds of a bounded type
*/
assert(bounded(tp));
if (tp->tp_fund == T_SUBRANGE) {
*plo = tp->sub_lb;
*phi = tp->sub_ub;
}
else {
*plo = 0;
*phi = tp->enm_ncst - 1;
}
}
struct type *
set_type(tp)
register struct type *tp;
{
/* Construct a set type with base type "tp", but first
perform some checks
*/
arith lb, ub;
if (! bounded(tp)) {
error("illegal base type for set");
return error_type;
}
getbounds(tp, &lb, &ub);
if (lb < 0 || ub > MAXSET-1) {
error("set type limits exceeded");
return error_type;
}
tp = construct_type(T_SET, tp);
tp->tp_size = WA((ub - lb + 8) >> 3);
return tp;
}
arith
ArrayElSize(tp)
register struct type *tp;
{
/* Align element size to alignment requirement of element type.
Also make sure that its size is either a dividor of the word_size,
or a multiple of it.
*/
register arith algn;
if (tp->tp_fund == T_ARRAY) ArraySizes(tp);
algn = align(tp->tp_size, tp->tp_align);
if (word_size % algn != 0) {
/* algn is not a dividor of the word size, so make sure it
is a multiple
*/
return WA(algn);
}
return algn;
}
ArraySizes(tp)
register struct type *tp;
{
/* Assign sizes to an array type, and check index type
*/
register struct type *index_type = IndexType(tp);
register struct type *elem_type = tp->arr_elem;
arith lo, hi;
tp->arr_elsize = ArrayElSize(elem_type);
tp->tp_align = elem_type->tp_align;
/* check index type
*/
if (! bounded(index_type)) {
error("illegal index type");
tp->tp_size = tp->arr_elsize;
return;
}
getbounds(index_type, &lo, &hi);
tp->tp_size = (hi - lo + 1) * tp->arr_elsize;
/* generate descriptor and remember label.
*/
tp->arr_descr = ++data_label;
C_df_dlb(tp->arr_descr);
C_rom_cst(lo);
C_rom_cst(hi - lo);
C_rom_cst(tp->arr_elsize);
}
FreeType(tp)
struct type *tp;
{
/* Release type structures indicated by "tp".
This procedure is only called for types, constructed with
T_PROCEDURE.
*/
register struct paramlist *pr, *pr1;
assert(tp->tp_fund == T_PROCEDURE);
pr = ParamList(tp);
while (pr) {
pr1 = pr;
pr = pr->next;
free_def(pr1->par_def);
free_paramlist(pr1);
}
free_type(tp);
}
DeclareType(nd, df, tp)
register struct def *df;
register struct type *tp;
struct node *nd;
{
/* A type with type-description "tp" is declared and must
be bound to definition "df".
This routine also handles the case that the type-field of
"df" is already bound. In that case, it is either an opaque
type, or an error message was given when "df" was created.
*/
if (df->df_type && df->df_type->tp_fund == T_HIDDEN) {
if (! (tp->tp_fund & (T_POINTER|T_HIDDEN|T_EQUAL))) {
node_error(nd,
"opaque type \"%s\" is not a pointer type",
df->df_idf->id_text);
}
df->df_type->next = tp;
df->df_type->tp_fund = T_EQUAL;
while (tp != df->df_type && tp->tp_fund == T_EQUAL) {
tp = tp->next;
}
if (tp == df->df_type) {
/* Circular definition! */
node_error(nd,
"opaque type \"%s\" has a circular definition",
df->df_idf->id_text);
}
}
else df->df_type = tp;
}
struct type *
RemoveEqual(tpx)
register struct type *tpx;
{
if (tpx) while (tpx->tp_fund == T_EQUAL) tpx = tpx->next;
return tpx;
}
int
gcd(m, n)
register int m, n;
{
/* Greatest Common Divisor
*/
register int r;
while (n) {
r = m % n;
m = n;
n = r;
}
return m;
}
int
lcm(m, n)
int m, n;
{
/* Least Common Multiple
*/
return m * (n / gcd(m, n));
}
#ifdef DEBUG
DumpType(tp)
register struct type *tp;
{
if (!tp) return;
print("align:%d; size:%ld;", tp->tp_align, (long) tp->tp_size);
print(" fund:");
switch(tp->tp_fund) {
case T_RECORD:
print("RECORD"); break;
case T_ENUMERATION:
print("ENUMERATION; ncst:%d", tp->enm_ncst); break;
case T_INTEGER:
print("INTEGER"); break;
case T_CARDINAL:
print("CARDINAL"); break;
case T_REAL:
print("REAL"); break;
case T_HIDDEN:
print("HIDDEN"); break;
case T_EQUAL:
print("EQUAL"); break;
case T_POINTER:
print("POINTER"); break;
case T_CHAR:
print("CHAR"); break;
case T_WORD:
print("WORD"); break;
case T_SET:
print("SET"); break;
case T_SUBRANGE:
print("SUBRANGE %ld-%ld", (long) tp->sub_lb, (long) tp->sub_ub);
break;
case T_PROCEDURE:
{
register struct paramlist *par = ParamList(tp);
print("PROCEDURE");
if (par) {
print("(");
while(par) {
if (IsVarParam(par)) print("VAR ");
DumpType(TypeOfParam(par));
par = par->next;
}
}
break;
}
case T_ARRAY:
print("ARRAY");
print("; element:");
DumpType(tp->arr_elem);
print("; index:");
DumpType(tp->next);
print(";");
return;
case T_STRING:
print("STRING"); break;
case T_INTORCARD:
print("INTORCARD"); break;
default:
crash("DumpType");
}
if (tp->next && tp->tp_fund != T_POINTER) {
/* Avoid printing recursive types!
*/
print(" next:(");
DumpType(tp->next);
print(")");
}
print(";");
}
#endif

232
lang/m2/comp/typequiv.c
View File

@@ -1,232 +0,0 @@
/* T Y P E E Q U I V A L E N C E */
/* Routines for testing type equivalence, type compatibility, and
assignment compatibility
*/
#include "debug.h"
#include <em_arith.h>
#include <em_label.h>
#include <assert.h>
#include "type.h"
#include "def.h"
#include "LLlex.h"
#include "node.h"
#include "warning.h"
int
TstTypeEquiv(tp1, tp2)
struct type *tp1, *tp2;
{
/* test if two types are equivalent.
*/
return tp1 == tp2
||
tp1 == error_type
||
tp2 == error_type;
}
int
TstParEquiv(tp1, tp2)
register struct type *tp1, *tp2;
{
/* test if two parameter types are equivalent. This routine
is used to check if two different procedure declarations
(one in the definition module, one in the implementation
module) are equivalent. A complication comes from dynamic
arrays.
*/
return
TstTypeEquiv(tp1, tp2)
||
(
IsConformantArray(tp1)
&&
IsConformantArray(tp2)
&&
TstTypeEquiv(tp1->arr_elem, tp2->arr_elem)
);
}
int
TstProcEquiv(tp1, tp2)
register struct type *tp1, *tp2;
{
/* Test if two procedure types are equivalent. This routine
may also be used for the testing of assignment compatibility
between procedure variables and procedures.
*/
register struct paramlist *p1, *p2;
/* First check if the result types are equivalent
*/
if (! TstTypeEquiv(ResultType(tp1), ResultType(tp2))) return 0;
p1 = ParamList(tp1);
p2 = ParamList(tp2);
/* Now check the parameters
*/
while (p1 && p2) {
if (IsVarParam(p1) != IsVarParam(p2) ||
!TstParEquiv(TypeOfParam(p1), TypeOfParam(p2))) return 0;
p1 = p1->next;
p2 = p2->next;
}
/* Here, at least one of the parameterlists is exhausted.
Check that they are both.
*/
return p1 == p2;
}
int
TstCompat(tp1, tp2)
register struct type *tp1, *tp2;
{
/* test if two types are compatible. See section 6.3 of the
Modula-2 Report for a definition of "compatible".
*/
if (TstTypeEquiv(tp1, tp2)) return 1;
tp1 = BaseType(tp1);
tp2 = BaseType(tp2);
return tp1 == tp2
||
( tp1 == intorcard_type
&&
(tp2 == int_type || tp2 == card_type || tp2 == address_type)
)
||
( tp2 == intorcard_type
&&
(tp1 == int_type || tp1 == card_type || tp1 == address_type)
)
||
( tp1 == address_type
&&
( tp2 == card_type
|| tp2->tp_fund == T_POINTER
)
)
||
( tp2 == address_type
&&
( tp1 == card_type
|| tp1->tp_fund == T_POINTER
)
)
;
}
int
TstAssCompat(tp1, tp2)
register struct type *tp1, *tp2;
{
/* Test if two types are assignment compatible.
See Def 9.1.
*/
register struct type *tp;
if (TstCompat(tp1, tp2)) return 1;
tp1 = BaseType(tp1);
tp2 = BaseType(tp2);
if ((tp1->tp_fund & T_INTORCARD) &&
(tp2->tp_fund & T_INTORCARD)) return 1;
if (tp1->tp_fund == T_PROCEDURE &&
tp2->tp_fund == T_PROCEDURE) {
return TstProcEquiv(tp1, tp2);
}
if (tp1->tp_fund == T_ARRAY) {
/* check for string
*/
arith size;
if (IsConformantArray(tp1)) return 0;
tp = IndexType(tp1);
if (tp->tp_fund == T_SUBRANGE) {
size = tp->sub_ub - tp->sub_lb + 1;
}
else size = tp->enm_ncst;
tp1 = BaseType(tp1->arr_elem);
return
tp1 == char_type
&& (tp2->tp_fund == T_STRING && size >= tp2->tp_size)
;
}
return 0;
}
int
TstParCompat(formaltype, actualtype, VARflag, nd)
register struct type *formaltype, *actualtype;
struct node *nd;
{
/* Check type compatibility for a parameter in a procedure call.
Assignment compatibility may do if the parameter is
a value parameter.
Otherwise, a conformant array may do, or an ARRAY OF (WORD|BYTE)
may do too.
Or: a WORD may do.
*/
return
TstTypeEquiv(formaltype, actualtype)
||
( !VARflag && TstAssCompat(formaltype, actualtype))
||
( formaltype == address_type
&& actualtype->tp_fund == T_POINTER
)
||
( formaltype == word_type
&&
( actualtype->tp_size == word_size
||
( !VARflag
&&
actualtype->tp_size <= word_size
)
)
)
||
( formaltype == byte_type
&& actualtype->tp_size == (arith) 1
)
||
( IsConformantArray(formaltype)
&&
( formaltype->arr_elem == word_type
|| formaltype->arr_elem == byte_type
||
( actualtype->tp_fund == T_ARRAY
&& TstTypeEquiv(formaltype->arr_elem,actualtype->arr_elem)
)
||
( actualtype->tp_fund == T_STRING
&& TstTypeEquiv(formaltype->arr_elem, char_type)
)
)
)
||
( VARflag
&& ( TstCompat(formaltype, actualtype)
&&
(node_warning(nd, W_OLDFASHIONED, "types of formal and actual must be identical"),
1)
)
)
;
}

780
lang/m2/comp/walk.c
View File

@@ -1,780 +0,0 @@
/* P A R S E T R E E W A L K E R */
/* Routines to walk through parts of the parse tree, and generate
code for these parts.
*/
#include "debug.h"
#include <em_arith.h>
#include <em_label.h>
#include <em_reg.h>
#include <em_code.h>
#include <assert.h>
#include "def.h"
#include "type.h"
#include "scope.h"
#include "main.h"
#include "LLlex.h"
#include "node.h"
#include "Lpars.h"
#include "desig.h"
#include "f_info.h"
#include "idf.h"
#include "chk_expr.h"
#include "walk.h"
#include "warning.h"
extern arith NewPtr();
extern arith NewInt();
extern int proclevel;
label text_label;
label data_label;
static struct type *func_type;
struct withdesig *WithDesigs;
struct node *Modules;
static struct node *priority;
#define NO_EXIT_LABEL ((label) 0)
#define RETURN_LABEL ((label) 1)
STATIC
DoPriority()
{
if (priority) {
C_loc(priority->nd_INT);
C_cal("_stackprio");
C_asp(word_size);
}
}
STATIC
EndPriority()
{
if (priority) {
C_cal("_unstackprio");
}
}
STATIC
DoProfil()
{
static label filename_label = 0;
if (! options['L']) {
register label fn_label = filename_label;
if (!fn_label) {
filename_label = fn_label = ++data_label;
C_df_dlb(fn_label);
C_rom_scon(FileName, (arith) (strlen(FileName) + 1));
}
C_fil_dlb(fn_label, (arith) 0);
}
}
WalkModule(module)
register struct def *module;
{
/* Walk through a module, and all its local definitions.
Also generate code for its body.
This code is collected in an initialization routine.
*/
register struct scope *sc;
struct scopelist *savevis = CurrVis;
CurrVis = module->mod_vis;
priority = module->mod_priority;
sc = CurrentScope;
/* Walk through it's local definitions
*/
WalkDef(sc->sc_def);
/* Now, generate initialization code for this module.
First call initialization routines for modules defined within
this module.
*/
sc->sc_off = 0; /* no locals (yet) */
text_label = 1; /* label at end of initialization routine */
TmpOpen(sc); /* Initialize for temporaries */
C_pro_narg(sc->sc_name);
DoPriority();
DoProfil();
if (module == Defined) {
/* Body of implementation or program module.
Call initialization routines of imported modules.
Also prevent recursive calls of this one.
*/
register struct node *nd = Modules;
if (state == IMPLEMENTATION) {
label l1 = ++data_label;
/* we don't actually prevent recursive calls,
but do nothing if called recursively
*/
C_df_dlb(l1);
C_bss_cst(word_size, (arith) 0, 1);
/* if this one is set to non-zero, the initialization
was already done.
*/
C_loe_dlb(l1, (arith) 0);
C_zne(RETURN_LABEL);
C_ine_dlb(l1, (arith) 0);
}
for (; nd; nd = nd->next) {
C_cal(nd->nd_IDF->id_text);
}
}
MkCalls(sc->sc_def);
proclevel++;
DO_DEBUG(options['X'], PrNode(module->mod_body, 0));
WalkNode(module->mod_body, NO_EXIT_LABEL);
C_df_ilb(RETURN_LABEL);
EndPriority();
C_ret((arith) 0);
C_end(-sc->sc_off);
proclevel--;
TmpClose();
CurrVis = savevis;
}
WalkProcedure(procedure)
register struct def *procedure;
{
/* Walk through the definition of a procedure and all its
local definitions, checking and generating code.
*/
struct scopelist *savevis = CurrVis;
register struct scope *sc = procedure->prc_vis->sc_scope;
register struct type *tp;
register struct paramlist *param;
label func_res_label = 0;
arith StackAdjustment = 0;
arith retsav = 0;
arith func_res_size = 0;
proclevel++;
CurrVis = procedure->prc_vis;
/* Generate code for all local modules and procedures
*/
WalkDef(sc->sc_def);
/* Generate code for this procedure
*/
C_pro_narg(sc->sc_name);
DoPriority();
DoProfil();
TmpOpen(sc);
func_type = tp = RemoveEqual(ResultType(procedure->df_type));
if (tp && IsConstructed(tp)) {
/* The result type of this procedure is constructed.
The actual procedure will return a pointer to a global
data area in which the function result is stored.
Notice that this does make the code non-reentrant.
Here, we create the data area for the function result.
*/
func_res_label = ++data_label;
C_df_dlb(func_res_label);
C_bss_cst(tp->tp_size, (arith) 0, 0);
}
if (tp) func_res_size = WA(tp->tp_size);
/* Generate calls to initialization routines of modules defined within
this procedure
*/
MkCalls(sc->sc_def);
/* Make sure that arguments of size < word_size are on a
fixed place.
Also make copies of conformant arrays when neccessary.
*/
for (param = ParamList(procedure->df_type);
param;
param = param->next) {
if (! IsVarParam(param)) {
tp = TypeOfParam(param);
if (! IsConformantArray(tp)) {
if (tp->tp_size < word_size) {
C_lol(param->par_def->var_off);
C_lal(param->par_def->var_off);
C_sti(tp->tp_size);
}
}
else {
/* Here, we have to make a copy of the
array. We must also remember how much
room is reserved for copies, because
we have to adjust the stack pointer before
a RET is done. This is even more complicated
when the procedure returns a value.
Then, the value must be saved (in retval),
the stack adjusted, the return value pushed
again, and then RET
*/
arith tmpvar = NewInt();
if (! StackAdjustment) {
/* First time we get here
*/
if (tp && !func_res_label) {
/* Some local space, only
needed if the value itself
is returned
*/
sc->sc_off -= func_res_size;
retsav = sc->sc_off;
}
StackAdjustment = NewInt();
C_loc((arith) 0);
C_stl(StackAdjustment);
}
/* First compute the size of the array */
C_lol(param->par_def->var_off +
pointer_size + word_size);
/* upper - lower */
C_inc(); /* gives number of elements */
C_loc(tp->arr_elem->tp_size);
C_mli(word_size);
C_loc(word_size - 1);
C_adi(word_size);
C_loc(word_size);
C_dvi(word_size);
/* size in words */
C_loc(word_size);
C_mli(word_size);
/* size in bytes */
C_stl(tmpvar);
C_lol(tmpvar);
C_lol(tmpvar);
C_lol(StackAdjustment);
C_adi(word_size);
C_stl(StackAdjustment);
/* remember stack adjustments */
C_ngi(word_size);
/* Assumption: stack grows
downwards!! ???
*/
C_ass(word_size);
/* adjusted stack pointer */
C_lol(param->par_def->var_off);
/* push source address */
C_lol(tmpvar); /* push size */
C_cal("_load"); /* copy */
C_asp(2 * word_size);
C_lor((arith) 1);
/* push new address of array
... downwards ... ???
*/
C_stl(param->par_def->var_off);
FreeInt(tmpvar);
}
}
}
text_label = 1; /* label at end of procedure */
DO_DEBUG(options['X'], PrNode(procedure->prc_body, 0));
WalkNode(procedure->prc_body, NO_EXIT_LABEL);
C_df_ilb(RETURN_LABEL); /* label at end */
tp = func_type;
if (func_res_label) {
/* Fill the data area reserved for the function result
with the result
*/
C_lae_dlb(func_res_label, (arith) 0);
C_sti(tp->tp_size);
if (StackAdjustment) {
/* Remove copies of conformant arrays
*/
C_lol(StackAdjustment);
C_ass(word_size);
}
C_lae_dlb(func_res_label, (arith) 0);
EndPriority();
C_ret(pointer_size);
}
else if (tp) {
if (StackAdjustment) {
/* First save the function result in a safe place.
Then remove copies of conformant arrays,
and put function result back on the stack
*/
C_lal(retsav);
C_sti(func_res_size);
C_lol(StackAdjustment);
C_ass(word_size);
C_lal(retsav);
C_loi(func_res_size);
}
EndPriority();
C_ret(func_res_size);
}
else {
if (StackAdjustment) {
C_lol(StackAdjustment);
C_ass(word_size);
}
EndPriority();
C_ret((arith) 0);
}
if (StackAdjustment) FreeInt(StackAdjustment);
if (! options['n']) RegisterMessages(sc->sc_def);
C_end(-sc->sc_off);
TmpClose();
CurrVis = savevis;
proclevel--;
}
WalkDef(df)
register struct def *df;
{
/* Walk through a list of definitions
*/
for ( ; df; df = df->df_nextinscope) {
switch(df->df_kind) {
case D_MODULE:
WalkModule(df);
break;
case D_PROCEDURE:
WalkProcedure(df);
break;
case D_VARIABLE:
if (!proclevel && !df->var_addrgiven) {
C_df_dnam(df->var_name);
C_bss_cst(
WA(df->df_type->tp_size),
(arith) 0, 0);
}
break;
default:
/* nothing */
;
}
}
}
MkCalls(df)
register struct def *df;
{
/* Generate calls to initialization routines of modules
*/
for ( ; df; df = df->df_nextinscope) {
if (df->df_kind == D_MODULE) {
C_lxl((arith) 0);
C_cal(df->mod_vis->sc_scope->sc_name);
C_asp(pointer_size);
}
}
}
WalkLink(nd, exit_label)
register struct node *nd;
label exit_label;
{
/* Walk node "nd", which is a link.
*/
while (nd && nd->nd_class == Link) { /* statement list */
WalkNode(nd->nd_left, exit_label);
nd = nd->nd_right;
}
WalkNode(nd, exit_label);
}
WalkCall(nd)
register struct node *nd;
{
assert(nd->nd_class == Call);
if (! options['L']) C_lin((arith) nd->nd_lineno);
if (ChkCall(nd)) {
if (nd->nd_type != 0) {
node_error(nd, "procedure call expected");
return;
}
CodeCall(nd);
}
}
WalkStat(nd, exit_label)
register struct node *nd;
label exit_label;
{
/* Walk through a statement, generating code for it.
*/
register struct node *left = nd->nd_left;
register struct node *right = nd->nd_right;
assert(nd->nd_class == Stat);
if (! options['L']) C_lin((arith) nd->nd_lineno);
switch(nd->nd_symb) {
case BECOMES:
DoAssign(nd, left, right);
break;
case IF:
{ label l1 = ++text_label, l3 = ++text_label;
ExpectBool(left, l3, l1);
assert(right->nd_symb == THEN);
C_df_ilb(l3);
WalkNode(right->nd_left, exit_label);
if (right->nd_right) { /* ELSE part */
label l2 = ++text_label;
C_bra(l2);
C_df_ilb(l1);
WalkNode(right->nd_right, exit_label);
C_df_ilb(l2);
}
else C_df_ilb(l1);
break;
}
case CASE:
CaseCode(nd, exit_label);
break;
case WHILE:
{ label loop = ++text_label,
exit = ++text_label,
dummy = ++text_label;
C_df_ilb(loop);
ExpectBool(left, dummy, exit);
C_df_ilb(dummy);
WalkNode(right, exit_label);
C_bra(loop);
C_df_ilb(exit);
break;
}
case REPEAT:
{ label loop = ++text_label, exit = ++text_label;
C_df_ilb(loop);
WalkNode(left, exit_label);
ExpectBool(right, exit, loop);
C_df_ilb(exit);
break;
}
case LOOP:
{ label loop = ++text_label, exit = ++text_label;
C_df_ilb(loop);
WalkNode(right, exit);
C_bra(loop);
C_df_ilb(exit);
break;
}
case FOR:
{
arith tmp = 0;
register struct node *fnd;
int good_forvar;
label l1 = ++text_label;
label l2 = ++text_label;
good_forvar = DoForInit(nd, left);
fnd = left->nd_right;
if (fnd->nd_class != Value) {
/* Upperbound not constant.
The expression may only be evaluated once,
so generate a temporary for it
*/
CodePExpr(fnd);
tmp = NewInt();
C_stl(tmp);
}
C_df_ilb(l1);
C_dup(int_size);
if (tmp) C_lol(tmp); else C_loc(fnd->nd_INT);
if (left->nd_INT > 0) {
C_bgt(l2);
}
else C_blt(l2);
if (good_forvar) {
RangeCheck(nd->nd_type, int_type);
CodeDStore(nd);
}
WalkNode(right, exit_label);
if (good_forvar) {
CodePExpr(nd);
C_loc(left->nd_INT);
C_adi(int_size);
C_bra(l1);
C_df_ilb(l2);
C_asp(int_size);
}
if (tmp) FreeInt(tmp);
}
break;
case WITH:
{
struct scopelist link;
struct withdesig wds;
struct desig ds;
if (! WalkDesignator(left, &ds)) break;
if (left->nd_type->tp_fund != T_RECORD) {
node_error(left, "record variable expected");
break;
}
wds.w_next = WithDesigs;
WithDesigs = &wds;
wds.w_scope = left->nd_type->rec_scope;
CodeAddress(&ds);
ds.dsg_kind = DSG_FIXED;
/* Create a designator structure for the temporary.
*/
ds.dsg_offset = NewPtr();
ds.dsg_name = 0;
CodeStore(&ds, pointer_size, pointer_align);
ds.dsg_kind = DSG_PFIXED;
/* the record is indirectly available */
wds.w_desig = ds;
link.sc_scope = wds.w_scope;
link.next = CurrVis;
CurrVis = &link;
WalkNode(right, exit_label);
CurrVis = link.next;
WithDesigs = wds.w_next;
FreePtr(ds.dsg_offset);
break;
}
case EXIT:
assert(exit_label != 0);
C_bra(exit_label);
break;
case RETURN:
if (right) {
if (! ChkExpression(right)) break;
/* The type of the return-expression must be
assignment compatible with the result type of the
function procedure (See Rep. 9.11).
*/
if (!TstAssCompat(func_type, right->nd_type)) {
node_error(right, "type incompatibility in RETURN statement");
break;
}
if (right->nd_type->tp_fund == T_STRING) {
CodePString(right, func_type);
}
else CodePExpr(right);
}
C_bra(RETURN_LABEL);
break;
default:
crash("(WalkStat)");
}
}
extern int NodeCrash();
int (*WalkTable[])() = {
NodeCrash,
NodeCrash,
NodeCrash,
NodeCrash,
NodeCrash,
WalkCall,
NodeCrash,
NodeCrash,
NodeCrash,
NodeCrash,
WalkStat,
WalkLink,
NodeCrash
};
ExpectBool(nd, true_label, false_label)
register struct node *nd;
label true_label, false_label;
{
/* "nd" must indicate a boolean expression. Check this and
generate code to evaluate the expression.
*/
struct desig ds;
if (!ChkExpression(nd)) return;
if (nd->nd_type != bool_type && nd->nd_type != error_type) {
node_error(nd, "boolean expression expected");
}
ds = InitDesig;
CodeExpr(nd, &ds, true_label, false_label);
}
int
WalkExpr(nd)
register struct node *nd;
{
/* Check an expression and generate code for it
*/
if (! ChkExpression(nd)) return 0;
CodePExpr(nd);
return 1;
}
int
WalkDesignator(nd, ds)
struct node *nd;
struct desig *ds;
{
/* Check designator and generate code for it
*/
if (! ChkVariable(nd)) return 0;
*ds = InitDesig;
CodeDesig(nd, ds);
return 1;
}
DoForInit(nd, left)
register struct node *nd, *left;
{
register struct def *df;
nd->nd_left = nd->nd_right = 0;
nd->nd_class = Name;
nd->nd_symb = IDENT;
if (!( ChkVariable(nd) &
WalkExpr(left->nd_left) &
ChkExpression(left->nd_right))) return 0;
df = nd->nd_def;
if (df->df_kind == D_FIELD) {
node_error(nd,
"FOR-loop variable may not be a field of a record");
return 1;
}
if (!df->var_name && df->var_off >= 0) {
node_error(nd, "FOR-loop variable may not be a parameter");
return 1;
}
if (df->df_scope != CurrentScope) {
register struct scopelist *sc = CurrVis;
for (;;) {
if (!sc) {
node_error(nd,
"FOR-loop variable may not be imported");
return 1;
}
if (sc->sc_scope == df->df_scope) break;
sc = nextvisible(sc);
}
}
if (df->df_type->tp_size > word_size ||
!(df->df_type->tp_fund & T_DISCRETE)) {
node_error(nd, "illegal type of FOR loop variable");
return 1;
}
if (!TstCompat(df->df_type, left->nd_left->nd_type) ||
!TstCompat(df->df_type, left->nd_right->nd_type)) {
if (!TstAssCompat(df->df_type, left->nd_left->nd_type) ||
!TstAssCompat(df->df_type, left->nd_right->nd_type)) {
node_error(nd, "type incompatibility in FOR statement");
return 1;
}
node_warning(nd, W_OLDFASHIONED, "compatibility required in FOR statement");
}
return 1;
}
DoAssign(nd, left, right)
struct node *nd;
register struct node *left, *right;
{
/* May we do it in this order (expression first) ???
The reference manual sais nothing about it, but the book does:
it sais that the left hand side is evaluated first.
DAMN THE BOOK!
*/
struct desig dsr;
register struct type *rtp, *ltp;
if (! (ChkExpression(right) & ChkVariable(left))) return;
rtp = right->nd_type;
ltp = left->nd_type;
if (right->nd_symb == STRING) TryToString(right, ltp);
dsr = InitDesig;
if (! TstAssCompat(ltp, rtp)) {
node_error(nd, "type incompatibility in assignment");
return;
}
#define StackNeededFor(ds) ((ds)->dsg_kind == DSG_PLOADED \
|| (ds)->dsg_kind == DSG_INDEXED)
CodeExpr(right, &dsr, NO_LABEL, NO_LABEL);
if (complex(rtp)) {
if (StackNeededFor(&dsr)) CodeAddress(&dsr);
}
else {
CodeValue(&dsr, rtp->tp_size, rtp->tp_align);
CodeCoercion(rtp, ltp);
RangeCheck(ltp, rtp);
}
CodeMove(&dsr, left, rtp);
}
RegisterMessages(df)
register struct def *df;
{
register struct type *tp;
for (; df; df = df->df_nextinscope) {
if (df->df_kind == D_VARIABLE && !(df->df_flags & D_NOREG)) {
/* Examine type and size
*/
tp = BaseType(df->df_type);
if ((df->df_flags & D_VARPAR) ||
(tp->tp_fund & (T_POINTER|T_HIDDEN|T_EQUAL))) {
C_ms_reg(df->var_off, pointer_size,
reg_pointer, 0);
}
else if (tp->tp_fund & T_NUMERIC) {
C_ms_reg(df->var_off,
tp->tp_size,
tp->tp_fund == T_REAL ?
reg_float : reg_any,
0);
}
}
}
}

Some files were not shown because too many files have changed in this diff Show More