d0p1/ack
1
0
Fork 0
Code Issues Pull requests 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
Show stats Download patch file Download diff file Expand all files Collapse all files

1
DistrAction
View file

@ -1 +0,0 @@
exec sh TakeAction distr distr/Action

35
Makefile
View file

@ -1,35 +0,0 @@
cmp: # compile everything and compare
(cd etc ; make cmp )
(cd util ; make cmp )
(cd lang ; make cmp )
(cd mach ; make cmp )
install: # compile everything to machine code
(cd etc ; make install )
(cd util ; make install )
(cd lang/cem ; make install )
(cd mach ; make install )
(cd lang/pc ; make install )
clean: # remove all non-sources, except boot-files
(cd doc ; make clean )
(cd man ; make clean )
(cd h ; make clean )
(cd etc ; make clean )
(cd util ; make clean )
(cd lang ; make clean )
(cd mach ; make clean )
opr: # print all sources
make pr | opr
pr: # print all sources
@( pr Makefile ; \
(cd doc ; make pr ) ; \
(cd man ; make pr ) ; \
(cd h ; make pr ) ; \
(cd etc ; make pr ) ; \
(cd lang ; make pr ) ; \
(cd util ; make pr ) ; \
(cd mach ; make pr ) \
)

12
distr/Action
View file

@ -1,12 +0,0 @@
name "Installation manual"
dir doc
end
name "Pascal bootstrap files"
dir lang/pc/pem
end
name "LLgen bootstrap files"
dir util/LLgen
end
name "ego share pop_push file"
dir util/ego/share
end

9
distr/Action1
View file

@ -1,9 +0,0 @@
name "m68k2/cg bootstrap files"
dir mach/m68k2/cg
end
name "vax4/cg bootstrap files"
dir mach/vax4/cg
end
name "m68020/ncg bootstrap files"
dir mach/m68020/ncg
end

26
distr/Exceptions
View file

@ -1,26 +0,0 @@
-- ./doc/install.pr no RCS file
-- ./h/em_mnem.h no RCS file
-- ./h/em_pseu.h no RCS file
-- ./h/em_spec.h no RCS file
-- ./lang/basic/src/y.tab.c no RCS file
-- ./lang/basic/src/y.tab.h no RCS file
-- ./lang/pc/pem/pem22.m no RCS file
-- ./lang/pc/pem/pem24.m no RCS file
-- ./lang/pc/pem/pem44.m no RCS file
-- ./lib/LLgen/incl no RCS file
-- ./lib/LLgen/rec no RCS file
-- ./mach/m68k2/cg/tables1.c no RCS file
-- ./mach/m68k2/cg/tables1.h no RCS file
-- ./mach/m68020/ncg/tables1.c no RCS file
-- ./mach/m68020/ncg/tables1.h no RCS file
-- ./mach/vax4/cg/tables1.c no RCS file
-- ./mach/vax4/cg/tables1.h no RCS file
-- ./util/LLgen/src/parser no RCS file
-- ./util/LLgen/src/LLgen.c no RCS file
-- ./util/LLgen/src/Lpars.c no RCS file
-- ./util/LLgen/src/Lpars.h no RCS file
-- ./util/LLgen/src/tokens.c no RCS file
-- ./util/data/em_flag.c no RCS file
-- ./util/data/em_mnem.c no RCS file
-- ./util/data/em_pseu.c no RCS file
-- ./util/ego/share/pop_push.h no RCS file

74
distr/How_To
View file

@ -1,74 +0,0 @@
How to make a fresh distribution:
For a distribution you need ".distr" files and RCS files.
The EM home directory contains a file called ".distr". It contains
the names of all the files and directories you want to have in the distribution.
The directories should contain .distr files, the other files should
be placed under RCS.
The current RCS revision name is "distr3".
The are files that derive from other files and yet should be placed
in the distribution.
These files should not be placed under RCS.
The file "Exceptions" in this directory contains the current list of
these files.
When all this is correct, use the shell script mktree the extract
the distribution from the EM tree.
cd /usr/em ; sh distr/mktree destination_tree >distr/f.attf 2>&1
Make sure that the destination tree exists and is empty!
Failing to do that will almost certainly result in a welter of
error messages.
The file f.attf contains mktree error messages and should be compared
to Exceptions.
The actions of mktree are quite complicated. It starts in the current
directory reading the ".distr" file, after copying that file to the
destination tree.
For each file mentioned there it performes certain actions:
1- Directory Change to that directory and call yourself recursively.
2- File
a- Try to do "co -rdistr3 destination_tree/path/destination_file"
on succes "chmod +w destination_file"
else
b- Try to do "co destination_tree/destination_file"
on succes "chmod +w destination_file" and
give message that says "Missing distr3 entry" (or some such).
else
c- I Does a file LIST exist in this directory AND
is the first line of LIST equal to the name of the
destination file? If so, try to extract all the files
named in the rest of the LIST file and call the program
arch to create a library "arch cr `cat LIST`".
In this manner libraries can be distributed whose members
have their own RCS file!
else
II try to do "cp file destination_tree/path/destination_file"
on succes give message that says "Missing RCS entry"
(or some such).
else
d-
give message that says "Missing entry" (or some such).
Now you have the tree but not everything is kosher yet.
Some files derive from other files in the tree, those derivations should
be done with the use of an already installed distribution.
The files Action and Action1 in this directory contain the actions
we now take. (Confession: most of the time we use /usr/em)
After running these re-derivation programs the distrubtion tree starts
to look like the tree you need.
There are too many files there though, especially the files created by
the derivation process.
That is why we now give the command:
dtar cdf distr3 .
The file distr3 is the one you should put on tape!
But,.... before doing that: Try it out!
Repeat the process described in the installation manual.
Only if that succeeds you are sure that you included the files needed,
and gave all other files the correct "distr3" RCS id.
After you sent the tape away, forbid ANYBODY to touch the distr3 id
in your RCS files.
Good Luck,
Ed Keizer, 85/4/15.
Updated for 3rd distribution by Ceriel Jacobs, 87/3/11.
And again,
Good Luck!

25
distr/dwalk
View file

@ -1,25 +0,0 @@
: ${CDIR=.}
if test ! -r .distr
then
echo ++ no .distr in $CDIR
exit 0
fi
${DS-:} $CDIR
for i in `cat .distr`
do
if test -d $i
then
( if cd $i
then
${DD-:} $CDIR $i
CDIR=$CDIR/$i
export CDIR
exec /usr/em/distr/dwalk
else
echo ++ Could not access $CDIR/$i
fi
)
else
${DF-:} $CDIR $i
fi
done

1
distr/echod
View file

@ -1 +0,0 @@
echo $1/$2

42
distr/f.attf
View file

@ -1,42 +0,0 @@
-- ./bin/em.pascal no RCS file
-- ./doc/em.doc/doc.pr no RCS file
-- ./doc/install.pr no RCS file
-- ./h/em_mnem.h no RCS file
-- ./h/em_pseu.h no RCS file
-- ./h/em_spec.h no RCS file
-- ./lang/basic/src/y.tab.c no RCS file
-- ./lang/basic/src/y.tab.h no RCS file
-- ./lang/pc/pem/pem22.m no RCS file
-- ./lang/pc/pem/pem24.m no RCS file
-- ./lib/LLgen/incl no RCS file
-- ./lib/LLgen/rec no RCS file
-- ./lib/ix/head_em no RCS file
-- ./lib/ix/head_i no RCS file
-- ./lib/ix/tail_em no RCS file
-- ./lib/ix/tail_em.vend no RCS file
-- ./lib/ix/tail_mon no RCS file
-- ./mach/6500/libem/tail_em.ve.s.a no RCS file
-- ./mach/vax2/cg/tables1.c no RCS file
-- ./mach/vax2/cg/tables1.h no RCS file
-- ./mach/vax4/cg/tables1.c no RCS file
-- ./mach/vax4/cg/tables1.h no RCS file
-- ./mach/z80/int/libpc/pc_tail.c.a no RCS file
-- ./mkun/pubmac no distr2 yet
-- ./mkun/tmac.q no distr2 yet
-- ./mkun/tmac.q1 no distr2 yet
-- ./mkun/tmac.q2 no distr2 yet
-- ./mkun/tmac.q3 no distr2 yet
-- ./mkun/tmac.q4 no distr2 yet
-- ./mkun/tmac.q5 no distr2 yet
-- ./mkun/tmac.q6 no distr2 yet
-- ./mkun/tmac.q7 no distr2 yet
-- ./mkun/tmac.q8 no distr2 yet
-- ./util/LLgen/src/parser no RCS file
-- ./util/LLgen/src/LLgen.c no RCS file
-- ./util/LLgen/src/Lpars.c no RCS file
-- ./util/LLgen/src/Lpars.h no RCS file
-- ./util/LLgen/src/tokens.c no RCS file
-- ./util/data/em_flag.c no RCS file
-- ./util/data/em_mnem.c no RCS file
-- ./util/data/em_pseu.c no RCS file
-- ./util/data/em_ptyp.c no RCS file

10
distr/listall
View file

@ -1,10 +0,0 @@
case $# in
0) DIR=. ;;
1) DIR=$1 ;;
*) echo $0 [directory] ; exit 1 ;;
esac
DD=`pwd`/listall.d
DW=`pwd`/dwalk
export DD
cd $DIR
$DW

2
distr/listall.d
View file

@ -1,2 +0,0 @@
echo "<$1/$2>"
ls -bCdx `cat .distr`

10
distr/listdirs
View file

@ -1,10 +0,0 @@
case $# in
0) DIR=. ;;
1) DIR=$1 ;;
*) echo $0 [directory] ; exit 1 ;;
esac
DD=`pwd`/echod
DW=`pwd`/dwalk
export DD
cd $DIR
$DW

9
distr/mka
View file

@ -1,9 +0,0 @@
set -e
for i in `tail +2 $DESTDIR/$1/LIST`
do
${DF-false} $1 $i
done
cd $DESTDIR/$1
arch cr `cat LIST`
: I do not remove the files constituating the library, because
: they might be present in .distr

1
distr/mkd
View file

@ -1 +0,0 @@
mkdir $DESTDIR/$1/$2

23
distr/mkf
View file

@ -1,23 +0,0 @@
if co -q -rdistr3 $DESTDIR/$1/$2 >/dev/null 2>&1
then
chmod +w $DESTDIR/$1/$2
elif co -q $DESTDIR/$1/$2 >/dev/null 2>&1
then
chmod +w $DESTDIR/$1/$2
echo -- $1/$2 no distr3 yet
elif grep LIST .distr >/dev/null 2>&1 &&
(test "$2" = "`head -1 $DESTDIR/$1/LIST`") >/dev/null 2>&1 &&
${DA-false} "$1" "$2"
then
: Fetched library contents one by one and put them together
elif cp $2 $DESTDIR/$1/$2 >/dev/null 2>&1
then
echo -- $1/$2 no RCS file
else
echo ++ $1/$2 not present
fi
case $2 in
LIST) if (test -r $DESTDIR/$1/`head -1 $DESTDIR/$1/LIST`) >/dev/null 2>&1
then echo ++ LIST files must be in .distr before their libraries!!!
fi ;;
esac

1
distr/mks
View file

@ -1 +0,0 @@
cp .distr $DESTDIR/$1

15
distr/mktree
View file

@ -1,15 +0,0 @@
case $# in
1) ;;
*) echo $0 directory ; exit 1 ;;
esac
DDIR=/usr/em/distr
case $1 in
/*) DESTDIR=$1 ;;
*) DESTDIR=`pwd`/$1 ;;
esac
DS=$DDIR/mks
DD=$DDIR/mkd
DF=$DDIR/mkf
DA=$DDIR/mka
export DESTDIR DS DD DF DA
$DDIR/dwalk

26
distr/todistr
View file

@ -1,26 +0,0 @@
REV=
FILE=
while :
do
case $# in
0) break ;;
esac
ARG="$1"
shift
case "$ARG" in
-r*) REV=`echo "$ARG"| sed s/-r//` ;;
-*) FLAGS="$FLAGS $ARG" ;;
*) case x$FILE in
x) FILE="$ARG" ;;
*) echo todistr can only be done on one file at the time
exit 1 ;;
esac
esac
done
case x$REV in
x) REV=`rlog -h "$FILE"|sed -n -e '/head/s/^head:[ ]*//p'` ;;
esac
case x$REV in
x) exit 2 ;;
esac
rcs -ndistr3:$REV $FLAGS $FILE

2
distr/ts
View file

@ -1,2 +0,0 @@
DD=`pwd`/ts
echo OK

323
doc/cref.doc
View file

@ -1,323 +0,0 @@
.\" $Header$
.nr ID 4
.de hd
'sp 2
'tl ''-%-''
'sp 3
..
.de fo
'bp
..
.tr ~
. TITLE
.de TL
.sp 15
.ce
\\fB\\$1\\fR
..
. AUTHOR
.de AU
.sp 15
.ce
by
.sp 2
.ce
\\$1
..
. DATE
.de DA
.sp 3
.ce
( Dated \\$1 )
..
. INSTITUTE
.de VU
.sp 3
.ce 4
Wiskundig Seminarium
Vrije Universteit
De Boelelaan 1081
Amsterdam
..
. PARAGRAPH
.de PP
.sp
.ti +\n(ID
..
.nr CH 0 1
. CHAPTER
.de CH
.nr SH 0 1
.bp
.in 0
\\fB\\n+(CH.~\\$1\\fR
.PP
..
. SUBCHAPTER
.de SH
.sp 3
.in 0
\\fB\\n(CH.\\n+(SH.~\\$1\\fR
.PP
..
. INDENT START
.de IS
.sp
.in +\n(ID
..
. INDENT END
.de IE
.in -\n(ID
.sp
..
.de PT
.ti -\n(ID
.ta \n(ID
.fc " @
"\\$1@"\c
.fc
..
. DOUBLE INDENT START
.de DS
.sp
.in +\n(ID
.ll -\n(ID
..
. DOUBLE INDENT END
.de DE
.ll +\n(ID
.in -\n(ID
.sp
..
. EQUATION START
.de EQ
.sp
.nf
..
. EQUATION END
.de EN
.fi
.sp
..
. ITEM
.de IT
.sp
.in 0
\\fB~\\$1\\fR
.ti +5
..
.de CS
.br
~-~\\
..
.br
.fi
.TL "Ack-C reference manual"
.AU "Ed Keizer"
.DA "September 12, 1983"
.VU
.wh 0 hd
.wh 60 fo
.CH "Introduction"
The C frontend included in the Amsterdam Compiler Kit
translates UNIX-V7 C into compact EM code [1].
The language accepted is described in [2] and [3].
This document describes which implementation dependent choices were
made in the Ack-C frontend and
some restrictions and additions.
.CH "The language"
.PP
Under the same heading as used in [2] we describe the
properties of the Ack-C frontend.
.IT "2.2 Identifiers"
External identifiers are unique up to 7 characters and allow
both upper and lower case.
.IT "2.3 Keywords"
The word \fBvoid\fP is also reserved as a keyword.
.IT "2.4.3 Character constants"
The ASCII-mapping is used when a character is converted to an
integer.
.IT "2.4.4 Floating constants"
To prevent loss of precision the compiler does not perform
floating point constant folding.
.IT "2.6 Hardware characteristics"
The size of objects of the several arithmetic types and
pointers depend on the EM-implementation used.
The ranges of the arithmetic types depend on the size used,
the C-frontend assumes two's complement representation for the
integral types.
All sizes are multiples of bytes.
The calling program \fIack\fP[4] passes information about the
size of the types to the compiler proper.
.br
However, a few general remarks must be made:
.sp 1
.IS
.PT (a)
The size of pointers is a multiple of
(or equal to) the size of an \fIint\fP.
.PT (b)
The following relations exist for the sizes of the types
mentioned:
.br
.ti +5
\fIchar<=short<=int<=long\fP
.PT (c)
Objects of type \fIchar\fP use one 8-bit byte of storage,
although several bytes are allocated sometimes.
.PT (d)
All sizes are in multiples of bytes.
.PT (e)
Most EM implementations use 4 bytes for floats and 8 bytes
for doubles, but exceptions to this rule occur.
.IE
.IT "4 What's in a name"
The type \fIvoid\fP is added.
Objects of type void do not exist.
Functions declared as returning void, do not return a value at all.
.IT "6.1 Characters and integers"
Objects of type \fIchar\fP are unsigned and do not cause
sign-extension when converted to \fIint\fP.
The range of characters values is from 0 to 255.
.IT "6.3 Floating and integral"
Floating point numbers are truncated towards zero when
converted to the integral types.
.IT "6.4 Pointers and integers"
When a \fIlong\fP is added to or subtracted from a pointer and
longs are larger then pointers the \fIlong\fP is converted to an
\fIint\fP before the operation is performed.
.IT "7.2 Unary operators"
It is allowed to cast any expression to the type \fIvoid\fP.
.IT "8.2 Type specifiers"
One type is added to the type-specifiers:
.br
.IS
void
.IE
.IT "8.5 Structure and union declarations"
The only type allowed for fields is \fIint\fP.
Fields with exactly the size of \fIint\fP are signed,
all other fields are unsigned.
.br
The size of any single structure must be less then 4096 bytes.
.IT "8.6 Initialization"
Initialization of structures containing bit fields is not
allowed.
There is one restriction when using an 'address expression' to initialize
an integral variable.
The integral variable must have the same size as a pointer.
Conversions altering the size of the address expression are not allowed.
.IT "9.10 Return statement"
Return statements of the form:
.IS
return ;
.IE
are the only form of return statement allowed in a function of type
function returning void.
.IT "10.1 External function definitions"
The total amount for storage used for parameters
in any function must be less then 4096 bytes.
The same holds for the total amount of storage occupied by the
automatic variables declared inside any function.
.sp
Using formal parameters whose size is smaller the the size of an int
is less efficient on several machines.
At procedure entry these parameters are converted from integer to the
declared type, because the compiler doesn't know where the least
significant bytes are stored in the int.
.IT "11.2 Scope of externals"
Most C compilers are rather lax in enforcing the restriction
that only one external definition without the keyword
\fIextern\fP is allowed in a program.
The Ack-C frontend is very strict in this.
The only exception is that declarations of arrays with a
missing first array bounds expression are regarded to have an
explicit keyword \fIextern\fP.
.IT "14.4 Explicit pointer conversions"
Pointers may be larger the ints, thus assigning a pointer to an
int and back will not always result in the same pointer.
The process mentioned above works with integrals
of the same size or larger as pointers in all EM implementations
having such integrals.
When converting pointers to an integral type or vice-versa,
the pointers is seen as an unsigned int.
.br
EM guarantees that any object can be placed at a word boundary,
this allows the C-programs to use \fIint\fP pointers
as pointers to objects of any type not smaller than an \fIint\fP.
.CH "Frontend options"
The C-frontend has a few options, these are controlled
by flags:
.IS
.PT -V
This flag is followed by a sequence of letters each followed by
positive integers. Each letter indicates a
certain type, the integer following it specifies the size of
objects of that type. One letter indicates the wordsize used.
.IS
.sp 1
.TS
center tab(:);
l l16 l l.
letter:type:letter:type
w:wordsize:i:int
s:short:l:long
f:float:d:double
p:pointer::
.TE
.sp 1
All existing implementations use an integer size equal to the
wordsize.
.IE
The calling program \fIack\fP[4] provides the frontend with
this flag, with values depending on the machine used.
.sp 1
.PT -l
The frontend normally generates code to keep track of the line
number and source file name at runtime for debugging purposes.
Currently a pointer to a
string containing the filename is stored at a fixed place in
memory at each function
entry and the line number at the start of every expression.
At the return from a function these memory locations are not reset to
the values they had before the call.
Most library routines do not use this feature and thus do not
ruin the current line number and filename when called.
However, you are really unlucky when your program crashes due
to a bug in such a library function, because the line number
and filename do not indicate that something went wrong inside
the library function.
.br
Providing the flag -l to the frontend tells it not to generate
the code updating line number and file name.
This is, for example, used when translating the stdio library.
.br
When the \fIack\fP[4] is called with the -L flag it provides
the frontend with this flag.
.sp 1
.PT -Xp
When this flag is present the frontend generates a call to
the function \fBprocentry\fP at each function entry and a
call to \fBprocexit\fP at each function exit.
Both functions are provided with one parameter,
a pointer to a string containing the function name.
.br
When \fIack\fP is called with the -p flag it provides the
frontend with this flag.
.IE
.CH References
.IS
.PT [1]
A.S. Tanenbaum, Hans van Staveren, Ed Keizer and Johan
Stevenson \fIDescription of a machine architecture for use with
block structured languages\fP Informatica report IR-81.
.sp 1
.PT [2]
B.W. Kernighan and D.M. Ritchie, \fIThe C Programming
language\fP, Prentice-Hall, 1978
.PT [3]
D.M. Ritchie, \fIC Reference Manual\fP
.sp
.PT [4]
UNIX manual ack(I).

488
doc/em/app.nr
View file

@ -1,488 +0,0 @@
.BP
.AP "EM INTERPRETER"
.nf
.ta 8 16 24 32 40 48 56 64 72 80
.so em.i
.fi
.BP
.AP "EM CODE TABLES"
The following table is used by the assembler for EM machine
language.
It specifies the opcodes used for each instruction and
how arguments are mapped to machine language arguments.
The table is presented in three columns,
each line in each column contains three or four fields.
Each line describes a range of interpreter opcodes by
specifying for which instruction the range is used, the type of the
opcodes (mini, shortie, etc..) and range for the instruction
argument.
.A
The first field on each line gives the EM instruction mnemonic,
the second field gives some flags.
If the opcodes are minis or shorties the third field specifies
how many minis/shorties are used.
The last field gives the number of the (first) interpreter
opcode.
.N 1
Flags :
.IS 3
.N 1
Opcode type, only one of the following may be specified.
.PS - 5 " "
.PT -
opcode without argument
.PT m
mini
.PT s
shortie
.PT 2
opcode with 2-byte signed argument
.PT 4
opcode with 4-byte signed argument
.PT 8
opcode with 8-byte signed argument
.PE
Secondary (escaped) opcodes.
.PS - 5 " "
.PT e
The opcode thus marked is in the secondary opcode group instead
of the primary
.PE
restrictions on arguments
.PS - 5 " "
.PT N
Negative arguments only
.PT P
Positive and zero arguments only
.PE
mapping of arguments
.PS - 5 " "
.PT w
argument must be divisible by the wordsize and is divided by the
wordsize before use as opcode argument.
.PT o
argument ( possibly after division ) must be >= 1 and is
decremented before use as opcode argument
.PE
.IE
If the opcode type is 2,4 or 8 the resulting argument is used as
opcode argument (least significant byte first).
.N
If the opcode type is mini, the argument is added
to the first opcode - if in range - .
If the argument is negative, the absolute value minus one is
used in the algorithm above.
.N
For shorties with positive arguments the first opcode is used
for arguments in the range 0..255, the second for the range
256..511, etc..
For shorties with negative arguments the first opcode is used
for arguments in the range -1..-256, the second for the range
-257..-512, etc..
The byte following the opcode contains the least significant
byte of the argument.
First some examples of these specifications.
.PS - 5
.PT "aar mwPo 1 34"
Indicates that opcode 34 is used as a mini for Positive
instruction arguments only.
The w and o indicate division and decrementing of the
instruction argument.
Because the resulting argument must be zero ( only opcode 34 may be used
), this mini can only be used for instruction argument 2.
Conclusion: opcode 34 is for "AAR 2".
.PT "adp sP 1 41"
Opcode 41 is used as shortie for ADP with arguments in the range
0..255.
.PT "bra sN 2 60"
Opcode 60 is used as shortie for BRA with arguments -1..-256,
61 is used for arguments -257..-512.
.PT "zer e- 145"
Escaped opcode 145 is used for ZER.
.PE
The interpreter opcode table:
.N 1
.IS 3
.DS B
.so itables
.DE 0
.IE
.P
The table above results in the following dispatch tables.
Dispatch tables are used by interpreters to jump to the
routines implementing the EM instructions, indexed by the next opcode.
Each line of the dispatch tables gives the routine names
of eight consecutive opcodes, preceded by the first opcode number
on that line.
Routine names consist of an EM mnemonic followed by a suffix.
The suffices show the encoding used for each opcode.
.N
The following suffices exist:
.N 1
.VS 1 0
.IS 4
.PS - 11
.PT .z
no arguments
.PT .l
16-bit argument
.PT .lw
16-bit argument divided by the wordsize
.PT .p
positive 16-bit argument
.PT .pw
positive 16-bit argument divided by the wordsize
.PT .n
negative 16-bit argument
.PT .nw
negative 16-bit argument divided by the wordsize
.PT .s<num>
shortie with <num> as high order argument byte
.PT .sw<num>
shortie with argument divided by the wordsize
.PT .<num>
mini with <num> as argument
.PT .<num>W
mini with <num>*wordsize as argument
.PE 3
<num> is a possibly negative integer.
.VS 1 1
.IE
The dispatch table for the 256 primary opcodes:
.DS B
0 loc.0 loc.1 loc.2 loc.3 loc.4 loc.5 loc.6 loc.7
8 loc.8 loc.9 loc.10 loc.11 loc.12 loc.13 loc.14 loc.15
16 loc.16 loc.17 loc.18 loc.19 loc.20 loc.21 loc.22 loc.23
24 loc.24 loc.25 loc.26 loc.27 loc.28 loc.29 loc.30 loc.31
32 loc.32 loc.33 aar.1W adf.s0 adi.1W adi.2W adp.l adp.1
40 adp.2 adp.s0 adp.s-1 ads.1W and.1W asp.1W asp.2W asp.3W
48 asp.4W asp.5W asp.w0 beq.l beq.s0 bge.s0 bgt.s0 ble.s0
56 blm.s0 blt.s0 bne.s0 bra.l bra.s-1 bra.s-2 bra.s0 bra.s1
64 cal.1 cal.2 cal.3 cal.4 cal.5 cal.6 cal.7 cal.8
72 cal.9 cal.10 cal.11 cal.12 cal.13 cal.14 cal.15 cal.16
80 cal.17 cal.18 cal.19 cal.20 cal.21 cal.22 cal.23 cal.24
88 cal.25 cal.26 cal.27 cal.28 cal.s0 cff.z cif.z cii.z
96 cmf.s0 cmi.1W cmi.2W cmp.z cms.s0 csa.1W csb.1W dec.z
104 dee.w0 del.w-1 dup.1W dvf.s0 dvi.1W fil.l inc.z ine.lw
112 ine.w0 inl.-1W inl.-2W inl.-3W inl.w-1 inn.s0 ior.1W ior.s0
120 lae.l lae.w0 lae.w1 lae.w2 lae.w3 lae.w4 lae.w5 lae.w6
128 lal.p lal.n lal.0 lal.-1 lal.w0 lal.w-1 lal.w-2 lar.W
136 ldc.0 lde.lw lde.w0 ldl.0 ldl.w-1 lfr.1W lfr.2W lfr.s0
144 lil.w-1 lil.w0 lil.0 lil.1W lin.l lin.s0 lni.z loc.l
152 loc.-1 loc.s0 loc.s-1 loe.lw loe.w0 loe.w1 loe.w2 loe.w3
160 loe.w4 lof.l lof.1W lof.2W lof.3W lof.4W lof.s0 loi.l
168 loi.1 loi.1W loi.2W loi.3W loi.4W loi.s0 lol.pw lol.nw
176 lol.0 lol.1W lol.2W lol.3W lol.-1W lol.-2W lol.-3W lol.-4W
184 lol.-5W lol.-6W lol.-7W lol.-8W lol.w0 lol.w-1 lxa.1 lxl.1
192 lxl.2 mlf.s0 mli.1W mli.2W rck.1W ret.0 ret.1W ret.s0
200 rmi.1W sar.1W sbf.s0 sbi.1W sbi.2W sdl.w-1 set.s0 sil.w-1
208 sil.w0 sli.1W ste.lw ste.w0 ste.w1 ste.w2 stf.l stf.W
216 stf.2W stf.s0 sti.1 sti.1W sti.2W sti.3W sti.4W sti.s0
224 stl.pw stl.nw stl.0 stl.1W stl.-1W stl.-2W stl.-3W stl.-4W
232 stl.-5W stl.w-1 teq.z tgt.z tlt.z tne.z zeq.l zeq.s0
240 zeq.s1 zer.s0 zge.s0 zgt.s0 zle.s0 zlt.s0 zne.s0 zne.s-1
248 zre.lw zre.w0 zrl.-1W zrl.-2W zrl.w-1 zrl.nw escape1 escape2
.DE 2
The list of secondary opcodes (escape1):
.N 1
.DS B
0 aar.l aar.z adf.l adf.z adi.l adi.z ads.l ads.z
8 adu.l adu.z and.l and.z asp.lw ass.l ass.z bge.l
16 bgt.l ble.l blm.l bls.l bls.z blt.l bne.l cai.z
24 cal.l cfi.z cfu.z ciu.z cmf.l cmf.z cmi.l cmi.z
32 cms.l cms.z cmu.l cmu.z com.l com.z csa.l csa.z
40 csb.l csb.z cuf.z cui.z cuu.z dee.lw del.pw del.nw
48 dup.l dus.l dus.z dvf.l dvf.z dvi.l dvi.z dvu.l
56 dvu.z fef.l fef.z fif.l fif.z inl.pw inl.nw inn.l
64 inn.z ior.l ior.z lar.l lar.z ldc.l ldf.l ldl.pw
72 ldl.nw lfr.l lil.pw lil.nw lim.z los.l los.z lor.s0
80 lpi.l lxa.l lxl.l mlf.l mlf.z mli.l mli.z mlu.l
88 mlu.z mon.z ngf.l ngf.z ngi.l ngi.z nop.z rck.l
96 rck.z ret.l rmi.l rmi.z rmu.l rmu.z rol.l rol.z
104 ror.l ror.z rtt.z sar.l sar.z sbf.l sbf.z sbi.l
112 sbi.z sbs.l sbs.z sbu.l sbu.z sde.l sdf.l sdl.pw
120 sdl.nw set.l set.z sig.z sil.pw sil.nw sim.z sli.l
128 sli.z slu.l slu.z sri.l sri.z sru.l sru.z sti.l
136 sts.l sts.z str.s0 tge.z tle.z trp.z xor.l xor.z
144 zer.l zer.z zge.l zgt.l zle.l zlt.l zne.l zrf.l
152 zrf.z zrl.pw dch.z exg.s0 exg.l exg.z lpb.z gto.l
.DE 2
Finally, the list of opcodes with four byte arguments (escape2).
.DS
0 loc
.DE 0
.BP
.AP "AN EXAMPLE PROGRAM"
.DS B
1 program example(output);
2 {This program just demonstrates typical EM code.}
3 type rec = record r1: integer; r2:real; r3: boolean end;
4 var mi: integer; mx:real; r:rec;
5
6 function sum(a,b:integer):integer;
7 begin
8 sum := a + b
9 end;
10
11 procedure test(var r: rec);
12 label 1;
13 var i,j: integer;
14 x,y: real;
15 b: boolean;
16 c: char;
17 a: array[1..100] of integer;
18
19 begin
20 j := 1;
21 i := 3 * j + 6;
22 x := 4.8;
23 y := x/0.5;
24 b := true;
25 c := 'z';
26 for i:= 1 to 100 do a[i] := i * i;
27 r.r1 := j+27;
28 r.r3 := b;
29 r.r2 := x+y;
30 i := sum(r.r1, a[j]);
31 while i > 0 do begin j := j + r.r1; i := i - 1 end;
32 with r do begin r3 := b; r2 := x+y; r1 := 0 end;
33 goto 1;
34 1: writeln(j, i:6, x:9:3, b)
35 end; {test}
36 begin {main program}
37 mx := 15.96;
38 mi := 99;
39 test(r)
40 end.
.DE 0
.BP
The EM code as produced by the Pascal-VU compiler is given below. Comments
have been added manually. Note that this code has already been optimized.
.DS B
mes 2,2,2 ; wordsize 2, pointersize 2
.1
rom 't.p\e000' ; the name of the source file
hol 552,-32768,0 ; externals and buf occupy 552 bytes
exp $sum ; sum can be called from other modules
pro $sum,2 ; procedure sum; 2 bytes local storage
lin 8 ; code from source line 8
ldl 0 ; load two locals ( a and b )
adi 2 ; add them
ret 2 ; return the result
end 2 ; end of procedure ( still two bytes local storage )
.2
rom 1,99,2 ; descriptor of array a[]
exp $test ; the compiler exports all level 0 procedures
pro $test,226 ; procedure test, 226 bytes local storage
.3
rom 4.8F8 ; assemble Floating point 4.8 (8 bytes) in
.4 ; global storage
rom 0.5F8 ; same for 0.5
mes 3,-226,2,2 ; compiler temporary not referenced by address
mes 3,-24,2,0 ; the same is true for i, j, b and c in test
mes 3,-22,2,0
mes 3,-4,2,0
mes 3,-2,2,0
mes 3,-20,8,0 ; and for x and y
mes 3,-12,8,0
lin 20 ; maintain source line number
loc 1
stl -4 ; j := 1
lni ; lin 21 prior to optimization
lol -4
loc 3
mli 2
loc 6
adi 2
stl -2 ; i := 3 * j + 6
lni ; lin 22 prior to optimization
lae .3
loi 8
lal -12
sti 8 ; x := 4.8
lni ; lin 23 prior to optimization
lal -12
loi 8
lae .4
loi 8
dvf 8
lal -20
sti 8 ; y := x / 0.5
lni ; lin 24 prior to optimization
loc 1
stl -22 ; b := true
lni ; lin 25 prior to optimization
loc 122
stl -24 ; c := 'z'
lni ; lin 26 prior to optimization
loc 1
stl -2 ; for i:= 1
2
lol -2
dup 2
mli 2 ; i*i
lal -224
lol -2
lae .2
sar 2 ; a[i] :=
lol -2
loc 100
beq *3 ; to 100 do
inl -2 ; increment i and loop
bra *2
3
lin 27
lol -4
loc 27
adi 2 ; j + 27
sil 0 ; r.r1 :=
lni ; lin 28 prior to optimization
lol -22 ; b
lol 0
stf 10 ; r.r3 :=
lni ; lin 29 prior to optimization
lal -20
loi 16
adf 8 ; x + y
lol 0
adp 2
sti 8 ; r.r2 :=
lni ; lin 23 prior to optimization
lal -224
lol -4
lae .2
lar 2 ; a[j]
lil 0 ; r.r1
cal $sum ; call now
asp 4 ; remove parameters from stack
lfr 2 ; get function result
stl -2 ; i :=
4
lin 31
lol -2
zle *5 ; while i > 0 do
lol -4
lil 0
adi 2
stl -4 ; j := j + r.r1
del -2 ; i := i - 1
bra *4 ; loop
5
lin 32
lol 0
stl -226 ; make copy of address of r
lol -22
lol -226
stf 10 ; r3 := b
lal -20
loi 16
adf 8
lol -226
adp 2
sti 8 ; r2 := x + y
loc 0
sil -226 ; r1 := 0
lin 34 ; note the abscence of the unnecesary jump
lae 22 ; address of output structure
lol -4
cal $_wri ; write integer with default width
asp 4 ; pop parameters
lae 22
lol -2
loc 6
cal $_wsi ; write integer width 6
asp 6
lae 22
lal -12
loi 8
loc 9
loc 3
cal $_wrf ; write fixed format real, width 9, precision 3
asp 14
lae 22
lol -22
cal $_wrb ; write boolean, default width
asp 4
lae 22
cal $_wln ; writeln
asp 2
ret 0 ; return, no result
end 226
exp $_main
pro $_main,0 ; main program
.6
con 2,-1,22 ; description of external files
.5
rom 15.96F8
fil .1 ; maintain source file name
lae .6 ; description of external files
lae 0 ; base of hol area to relocate buffer addresses
cal $_ini ; initialize files, etc...
asp 4
lin 37
lae .5
loi 8
lae 2
sti 8 ; mx := 15.96
lni ; lin 38 prior to optimization
loc 99
ste 0 ; mi := 99
lni ; lin 39 prior to optimization
lae 10 ; address of r
cal $test
asp 2
loc 0 ; normal exit
cal $_hlt ; cleanup and finish
asp 2
end 0
mes 5 ; reals were used
.DE 0
The compact code corresponding to the above program is listed below.
Read it horizontally, line by line, not column by column.
Each number represents a byte of compact code, printed in decimal.
The first two bytes form the magic word.
.N 1
.IS 3
.DS B
173 0 159 122 122 122 255 242 1 161 250 124 116 46 112 0
255 156 245 40 2 245 0 128 120 155 249 123 115 117 109 160
249 123 115 117 109 122 67 128 63 120 3 122 88 122 152 122
242 2 161 121 219 122 255 155 249 124 116 101 115 116 160 249
124 116 101 115 116 245 226 0 242 3 161 253 128 123 52 46
56 255 242 4 161 253 128 123 48 46 53 255 159 123 245 30
255 122 122 255 159 123 96 122 120 255 159 123 98 122 120 255
159 123 116 122 120 255 159 123 118 122 120 255 159 123 100 128
120 255 159 123 108 128 120 255 67 140 69 121 113 116 68 73
116 69 123 81 122 69 126 3 122 113 118 68 57 242 3 72
128 58 108 112 128 68 58 108 72 128 57 242 4 72 128 44
128 58 100 112 128 68 69 121 113 98 68 69 245 122 0 113
96 68 69 121 113 118 182 73 118 42 122 81 122 58 245 32
255 73 118 57 242 2 94 122 73 118 69 220 10 123 54 118
18 122 183 67 147 73 116 69 147 3 122 104 120 68 73 98
73 120 111 130 68 58 100 72 136 2 128 73 120 4 122 112
128 68 58 245 32 255 73 116 57 242 2 59 122 65 120 20
249 123 115 117 109 8 124 64 122 113 118 184 67 151 73 118
128 125 73 116 65 120 3 122 113 116 41 118 18 124 185 67
152 73 120 113 245 30 255 73 98 73 245 30 255 111 130 58
100 72 136 2 128 73 245 30 255 4 122 112 128 69 120 104
245 30 255 67 154 57 142 73 116 20 249 124 95 119 114 105
8 124 57 142 73 118 69 126 20 249 124 95 119 115 105 8
126 57 142 58 108 72 128 69 129 69 123 20 249 124 95 119
114 102 8 134 57 142 73 98 20 249 124 95 119 114 98 8
124 57 142 20 249 124 95 119 108 110 8 122 88 120 152 245
226 0 155 249 125 95 109 97 105 110 160 249 125 95 109 97
105 110 120 242 6 151 122 119 142 255 242 5 161 253 128 125
49 53 46 57 54 255 50 242 1 57 242 6 57 120 20 249
124 95 105 110 105 8 124 67 157 57 242 5 72 128 57 122
112 128 68 69 219 110 120 68 57 130 20 249 124 116 101 115
116 8 122 69 120 20 249 124 95 104 108 116 8 122 152 120
159 124 160 255 159 125 255
.DE 0
.IE
.MS T A 0
.ME
.BP
.MS B A 0
.ME
.CT

376
doc/em/iotrap.nr
View file

@ -1,376 +0,0 @@
.SN 8
.VS 1 0
.BP
.S1 "ENVIRONMENT INTERACTIONS"
EM programs can interact with their environment in three ways.
Two, starting/stopping and monitor calls, are dealt with in this chapter.
The remaining way to interact, interrupts, will be treated
together with traps in chapter 9.
.S2 "Program starting and stopping"
EM user programs start with a call to a procedure called
m_a_i_n.
The assembler and backends look for the definition of a procedure
with this name in their input.
The call passes three parameters to the procedure.
The parameters are similar to the parameters supplied by the
UNIX
.FS
UNIX is a Trademark of Bell Laboratories.
.FE
operating system to C programs.
These parameters are often called
.BW argc ,
.B argv
and
.BW envp .
Argc is the parameter nearest to LB and is a wordsized integer.
The other two are pointers to the first element of an array of
string pointers.
.N
The
.B argv
array contains
.B argc
strings, the first of which contains the program call name.
The other strings in the
.B argv
array are the program parameters.
.P
The
.B envp
array contains strings in the form "name=string", where 'name'
is the name of an environment variable and string its value.
The
.B envp
is terminated by a zero pointer.
.P
An EM user program stops if the program returns from the first
invocation of m_a_i_n.
The contents of the function return area are used to procure a
wordsized program return code.
EM programs also stop when traps and interrupts occur that are
not caught and when the exit monitor call is executed.
.S2 "Input/Output and other monitor calls"
EM differs from most conventional machines in that it has high level i/o
instructions.
Typical instructions are OPEN FILE and READ FROM FILE instead
of low level instructions such as setting and clearing
bits in device registers.
By providing such high level i/o primitives, the task of implementing
EM on various non EM machines is made considerably easier.
.P
I/O is initiated by the MON instruction, which expects an iocode on top
of the stack.
Often there are also parameters which are pushed on the
stack in reverse order, that is: last
parameter first.
Some i/o functions also provide results, which are returned on the stack.
In the list of monitor calls we use several types of parameters and results,
these types consist of integers and unsigneds of varying sizes, but never
smaller than the wordsize, and the two pointer types.
.N 1
The names of the types used are:
.IS 4
.PS - 10
.PT int
an integer of wordsize
.PT int2
an integer whose size is the maximum of the wordsize and 2
bytes
.PT int4
an integer whose size is the maximum of the wordsize and 4
bytes
.PT intp
an integer with the size of a pointer
.PT uns2
an unsigned integer whose size is the maximum of the wordsize and 2
.PT unsp
an unsigned integer with the size of a pointer
.PT ptr
a pointer into data space
.PE 1
.IE 0
The table below lists the i/o codes with their results and
parameters.
This list is similar to the system calls of the UNIX Version 7
operating system.
.BP
.A
To execute a monitor call, proceed as follows:
.IS 2
.N 1
.PS a 4 "" )
.PT
Stack the parameters, in reverse order, last parameter first.
.PT
Push the monitor call number (iocode) onto the stack.
.PT
Execute the MON instruction.
.PE 1
.IE
An error code is present on the top of the stack after
execution of most monitor calls.
If this error code is zero, the call performed the action
requested and the results are available on top of the stack.
Non-zero error codes indicate a failure, in this case no
results are available and the error code has been pushed twice.
This construction enables programs to test for failure with a
single instruction (~TEQ or TNE~) and still find out the cause of
the failure.
The result name 'e' is reserved for the error code.
.N 1
List of monitor calls.
.DS B
number name parameters results function
1 Exit status:int Terminate this process
2 Fork e,flag,pid:int Spawn new process
3 Read fildes:int;buf:ptr;nbytes:unsp
e:int;rbytes:unsp Read from file
4 Write fildes:int;buf:ptr;nbytes:unsp
e:int;wbytes:unsp Write on a file
5 Open string:ptr;flag:int
e,fildes:int Open file for read and/or write
6 Close fildes:int e:int Close a file
7 Wait e:int;status,pid:int2
Wait for child
8 Creat string:ptr;mode:int
e,fildes:int Create a new file
9 Link string1,string2:ptr
e:int Link to a file
10 Unlink string:ptr e:int Remove directory entry
12 Chdir string:ptr e:int Change default directory
14 Mknod string:ptr;mode,addr:int2
e:int Make a special file
15 Chmod string:ptr;mode:int2
e:int Change mode of file
16 Chown string:ptr;owner,group:int2
e:int Change owner/group of a file
18 Stat string,statbuf:ptr
e:int Get file status
19 Lseek fildes:int;off:int4;whence:int
e:int;oldoff:int4 Move read/write pointer
20 Getpid pid:int2 Get process identification
21 Mount special,string:ptr;rwflag:int
e:int Mount file system
22 Umount special:ptr e:int Unmount file system
23 Setuid userid:int2 e:int Set user ID
24 Getuid e_uid,r_uid:int2 Get user ID
25 Stime time:int4 e:int Set time and date
26 Ptrace request:int;pid:int2;addr:ptr;data:int
e,value:int Process trace
27 Alarm seconds:uns2 previous:uns2 Schedule signal
28 Fstat fildes:int;statbuf:ptr
e:int Get file status
29 Pause Stop until signal
30 Utime string,timep:ptr
e:int Set file times
33 Access string,mode:int e:int Determine file accessibility
34 Nice incr:int Set program priority
35 Ftime bufp:ptr e:int Get date and time
36 Sync Update filesystem
37 Kill pid:int2;sig:int
e:int Send signal to a process
41 Dup fildes,newfildes:int
e,fildes:int Duplicate a file descriptor
42 Pipe e,w_des,r_des:int Create a pipe
43 Times buffer:ptr Get process times
44 Profil buff:ptr;bufsiz,offset,scale:intp Execution time profile
46 Setgid gid:int2 e:int Set group ID
47 Getgid e_gid,r_gid:int Get group ID
48 Sigtrp trapno,signo:int
e,prevtrap:int See below
51 Acct file:ptr e:int Turn accounting on or off
53 Lock flag:int e:int Lock a process
54 Ioctl fildes,request:int;argp:ptr
e:int Control device
56 Mpxcall cmd:int;vec:ptr e:int Multiplexed file handling
59 Exece name,argv,envp:ptr
e:int Execute a file
60 Umask complmode:int2 oldmask:int2 Set file creation mode mask
61 Chroot string:ptr e:int Change root directory
.DE 1
Codes 0, 11, 13, 17, 31, 32, 38, 39, 40, 45, 49, 50, 52,
55, 57, 58, 62, and 63 are
not used.
.P
All monitor calls, except fork and sigtrp
are the same as the UNIX version 7 system calls.
.P
The sigtrp entry maps UNIX signals onto EM interrupts.
Normally, trapno is in the range 0 to 252.
In that case it requests that signal signo
will cause trap trapno to occur.
When given trap number -2, default signal handling is reset, and when given
trap number -3, the signal is ignored.
.P
The flag returned by fork is 1 in the child process and 0 in
the parent.
The pid returned is the process-id of the other process.
.BP
.S1 "TRAPS AND INTERRUPTS"
EM provides a means for the user program to catch all traps
generated by the program itself, the hardware, or external conditions.
This mechanism uses five instructions: LIM, SIM, SIG, TRP and RTT.
This section of the manual may be omitted on the first reading since it
presupposes knowledge of the EM instruction set.
.P
The action taken when a trap occures is determined by the value
of an internal EM trap register.
This register contains a pointer to a procedure.
Initially the pointer used is zero and all traps halt the
program with, hopefully, a useful message to the outside world.
The SIG instruction can be used to alter the trap register,
it pops a procedure pointer from the
stack into the trap register.
When a trap occurs after storing a nonzero value in the trap
register, the procedure pointed to by the trap register
is called with the trap number
as the only parameter (see below).
SIG returns the previous value of the trap register on the
stack.
Two consecutive SIGs are a no-op.
When a trap occurs, the trap register is reset to its initial
condition, to prevent recursive traps from hanging the machine up,
e.g. stack overflow in the stack overflow handling procedure.
.P
The runtime systems for some languages need to ignore some EM
traps.
EM offers a feature called the ignore mask.
It contains one bit for each of the lowest 16 trap numbers.
The bits are numbered 0 to 15, with the least significant bit
having number 0.
If a certain bit is 1 the corresponding trap never
occurs and processing simply continues.
The actions performed by the offending instruction are
described by the Pascal program in appendix A.
.N
If the bit is 0, traps are not ignored.
The instructions LIM and SIM allow copying and replacement of
the ignore mask.~
.P
The TRP instruction generates a trap, the trap number being found on the
stack.
This is, among other things,
useful for library procedures and runtime systems.
It can also be used by a low level trap procedure to pass the trap to a
higher level one (see example below).
.P
The RTT instruction returns from the trap procedure and continues after the
trap.
In the list below all traps marked with an asterisk ('*') are
considered to be fatal and it is explicitly undefined what happens if
you try to restart after the trap.
.P
The way a trap procedure is called is completely compatible
with normal calling conventions. The only way a trap procedure
differs from normal procedures is the return. It has to use RTT instead
of RET. This is necessary because the complete runtime status is saved on the
stack before calling the procedure and all this status has to be reloaded.
Error numbers are in the range 0 to 252.
The trap numbers are divided into three categories:
.IS 4
.N 1
.PS - 10
.PT ~~0-~63
EM machine errors, e.g. illegal instruction.
.PS - 8
.PT ~0-15
maskable
.PT 16-63
not maskable
.PE
.PT ~64-127
Reserved for use by compilers, run time systems, etc.
.PT 128-252
Available for user programs.
.PE 1
.IE
EM machine errors are numbered as follows:
.DS I 5
.TS
tab(@);
n l l.
0@EARRAY@Array bound error
1@ERANGE@Range bound error
2@ESET@Set bound error
3@EIOVFL@Integer overflow
4@EFOVFL@Floating overflow
5@EFUNFL@Floating underflow
6@EIDIVZ@Divide by 0
7@EFDIVZ@Divide by 0.0
8@EIUND@Undefined integer
9@EFUND@Undefined float
10@ECONV@Conversion error
16*@ESTACK@Stack overflow
17*@EHEAP@Heap overflow
18*@EILLINS@Illegal instruction
19*@EODDZ@Illegal size argument
20*@ECASE@Case error
21*@EMEMFLT@Addressing non existent memory
22*@EBADPTR@Bad pointer used
23*@EBADPC@Program counter out of range
24@EBADLAE@Bad argument of LAE
25@EBADMON@Bad monitor call
26@EBADLIN@Argument of LIN too high
27@EBADGTO@GTO descriptor error
.TE
.DE 0
.P
As an example,
suppose a subprocedure has to be written to do a numeric
calculation.
When an overflow occurs the computation has to be stopped and
the higher level procedure must be resumed.
This can be programmed as follows using the mechanism described above:
.DS B
mes 2,2,2 ; set sizes
ersave
bss 2,0,0 ; Room to save previous value of trap procedure
msave
bss 2,0,0 ; Room to save previous value of trap mask
pro calcule,0 ; entry point
lxl 0 ; fill in non-local goto descriptor with LB
ste jmpbuf+4
lor 1 ; and SP
ste jmpbuf+2
lim ; get current ignore mask
ste msave ; save it
lim
loc 16 ; bit for EFOVFL
ior 2 ; set in mask
sim ; ignore EFOVFL from now on
lpi $catch ; load procedure identifier
sig ; catch wil get all traps now
ste ersave ; save previous trap procedure identifier
; perform calculation now, possibly generating overflow
1 ; label jumped to by catch procedure
loe ersave ; get old trap procedure
sig ; refer all following trap to old procedure
asp 2 ; remove result of sig
loe msave ; restore previous mask
sim ; done now
; load result of calculation
ret 2 ; return result
jmpbuf
con *1,0,0
end
.DE 0
.VS 1 1
.DS
Example of catch procedure
pro catch,0 ; Local procedure that must catch the overflow trap
lol 2 ; Load trap number
loc 4 ; check for overflow
bne *1 ; if other trap, call higher trap procedure
gto jmpbuf ; return to procedure calcule
1 ; other trap has occurred
loe ersave ; previous trap procedure
sig ; other procedure will get the traps now
asp 2 ; remove the result of sig
lol 2 ; stack trap number
trp ; call other trap procedure
rtt ; if other procedure returns, do the same
end
.DE

2922
doc/em/itables
View file

File diff suppressed because it is too large Load diff

1
emtest/last
View file

@ -1 +0,0 @@
0

28
emtest/test.e
View file

@ -1,28 +0,0 @@
#define WS EM_WSIZE
#define PS EM_PSIZE
#include "test.h"
mes 2,WS,PS
mes 1
mes 4,300
.000
con "tst000"
exp $m_a_i_n
pro $m_a_i_n,0
loc 123
loc -98
; TEST 000: empty
fil .000
loc -98
bne *1
loc 123
bne *1
lin 0
nop
loc 0
ret WS
1
lin 1
nop
loc 1
ret WS
end

3
include/.distr Normal file
View file

@ -0,0 +1,3 @@
_tail_mon
_tail_cc
occam

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))\
:'

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