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

newer version

Browse source
This commit is contained in:
ceriel 1986-10-06 20:36:30 +00:00
parent f3bf7cd5bc
commit 3030eb8cae
50 changed files with 839 additions and 924 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

25
lang/m2/comp/LLlex.c
View file

@ -1,9 +1,5 @@
/* 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 */
#ifndef NORCSID
static char *RcsId = "$Header$";
#endif
#include "debug.h"
#include "idfsize.h"
#include "numsize.h"
@ -40,9 +36,10 @@ SkipComment()
Note that comments may be nested (par. 3.5).
*/
register int ch;
register int CommentLevel = 0;
LoadChar(ch);
for (;;) {
LoadChar(ch);
if (class(ch) == STNL) {
LineNumber++;
#ifdef DEBUG
@ -51,12 +48,22 @@ SkipComment()
}
else if (ch == '(') {
LoadChar(ch);
if (ch == '*') SkipComment();
if (ch == '*') CommentLevel++;
else continue;
}
else if (ch == '*') {
LoadChar(ch);
if (ch == ')') break;
if (ch == ')') {
CommentLevel--;
if (CommentLevel < 0) break;
}
else continue;
}
else if (ch == EOI) {
lexerror("unterminated comment");
break;
}
LoadChar(ch);
}
}
@ -69,7 +76,8 @@ GetString(upto)
register struct string *str = (struct string *) Malloc(sizeof(struct string));
register char *p;
str->s_str = p = Malloc((unsigned int) (str->s_length = ISTRSIZE));
str->s_length = ISTRSIZE;
str->s_str = p = Malloc((unsigned int) ISTRSIZE);
while (LoadChar(ch), ch != upto) {
if (class(ch) == STNL) {
lexerror("newline in string");
@ -394,6 +402,7 @@ lexwarning("Character constant out of range");
case STCHAR:
default:
crash("(LLlex) Impossible character class");
/*NOTREACHED*/
}
/*NOTREACHED*/
}

2
lang/m2/comp/LLlex.h
View file

@ -1,7 +1,5 @@
/* 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 */
/* $Header$ */
/* Structure to store a string constant
*/
struct string {

22
lang/m2/comp/LLmessage.c
View file

@ -1,9 +1,5 @@
/* S Y N T A X E R R O R R E P O R T I N G */
#ifndef NORCSID
static char *RcsId = "$Header$";
#endif
/* 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
@ -39,24 +35,28 @@ LLmessage(tk)
insert_token(tk)
int tk;
{
aside = dot;
register struct token *dotp = &dot;
dot.tk_symb = tk;
aside = *dotp;
dotp->tk_symb = tk;
switch (tk) {
/* The operands need some body */
case IDENT:
dot.TOK_IDF = gen_anon_idf();
dotp->TOK_IDF = gen_anon_idf();
break;
case STRING:
dot.TOK_SLE = 1;
dot.TOK_STR = Salloc("", 1);
dotp->tk_data.tk_str = (struct string *)
Malloc(sizeof (struct string));
dotp->TOK_SLE = 1;
dotp->TOK_STR = Salloc("", 1);
break;
case INTEGER:
dot.TOK_INT = 1;
dotp->TOK_INT = 1;
break;
case REAL:
dot.TOK_REL = Salloc("0.0", 4);
dotp->TOK_REL = Salloc("0.0", 4);
break;
}
}

40
lang/m2/comp/Makefile
View file

@ -1,5 +1,4 @@
# make modula-2 "compiler"
# $Header$
EMDIR = /usr/ceriel/em
MHDIR = $(EMDIR)/modules/h
PKGDIR = $(EMDIR)/modules/pkg
@ -8,19 +7,26 @@ LLGEN = $(EMDIR)/bin/LLgen
INCLUDES = -I$(MHDIR) -I$(EMDIR)/h -I$(PKGDIR)
LSRC = tokenfile.g program.g declar.g expression.g statement.g
GFILES = tokenfile.g program.g declar.g expression.g statement.g
CC = cc
LLGENOPTIONS =
PROFILE =
CFLAGS = $(PROFILE) $(INCLUDES) -DSTATIC=
LINTFLAGS = -DSTATIC= -DNORCSID
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
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
code.o tmpvar.o lookup.o Version.o
SRC = $(CSRC) $(LSRC) Lpars.c
OBJ = $(COBJ) $(LOBJ) Lpars.o
# Keep the next entries up to date!
@ -44,11 +50,11 @@ all: Cfiles
@rm -f nmclash.o a.out
clean:
rm -f $(OBJ) $(GENFILES) LLfiles hfiles Cfiles tab cclash.o cid.o cclash cid
rm -f $(OBJ) $(GENFILES) LLfiles hfiles Cfiles tab cclash.o cid.o cclash cid clashes
(cd .. ; rm -rf Xsrc)
lint: Cfiles
sh -c `if $(CC) nmclash.c > /dev/null 2>&1 ; then make Xlint ; else sh Resolve Xlint ; fi'
sh -c 'if $(CC) nmclash.c > /dev/null 2>&1 ; then make Xlint ; else sh Resolve Xlint ; fi'
@rm -f nmclash.o a.out
mkdep: mkdep.o
@ -57,20 +63,22 @@ mkdep: mkdep.o
cclash: cclash.o
$(CC) $(LFLAGS) -o cclash cclash.o
clashes: $(SRC) $(HFILES)
sh -c 'if test -f clashes ; then ./cclash -l7 clashes $? > Xclashes ; mv Xclashes clashes ; else ./cclash -l7 $? > clashes ; fi'
cid: cid.o
$(CC) $(LFLAGS) -o cid cid.o
# entry points not to be used directly
Xlint:
lint $(INCLUDES) $(LINTFLAGS) `./sources $(OBJ)`
lint $(INCLUDES) $(LINTFLAGS) $(SRC)
Cfiles: hfiles LLfiles $(GENHFILES) $(GENCFILES)
./sources $(OBJ) > Cfiles
sh -c 'for i in $(HFILES) ; do echo $$i ; done >> Cfiles'
Cfiles: hfiles LLfiles $(GENCFILES) $(GENHFILES)
echo $(SRC) $(HFILES) > Cfiles
LLfiles: $(LSRC)
$(LLGEN) $(LLGENOPTIONS) $(LSRC)
LLfiles: $(GFILES)
$(LLGEN) $(LLGENOPTIONS) $(GFILES)
@touch LLfiles
hfiles: Parameters make.hfiles
@ -78,7 +86,7 @@ hfiles: Parameters make.hfiles
touch hfiles
main: $(OBJ) ../src/Makefile
$(CC) $(LFLAGS) $(OBJ) $(LIBDIR)/libem_mes.a $(LIBDIR)/libemk.a $(LIBDIR)/input.a $(LIBDIR)/assert.a $(LIBDIR)/alloc.a $(LIBDIR)/malloc.o $(LIBDIR)/libprint.a $(LIBDIR)/libstr.a $(LIBDIR)/libsystem.a -o ../src/main
$(CC) $(LFLAGS) $(OBJ) $(LIBDIR)/libem_mes.a $(LIBDIR)/libemk.a $(LIBDIR)/input.a $(LIBDIR)/assert.a $(LIBDIR)/alloc.a $(LIBDIR)/dickmalloc.o $(LIBDIR)/libprint.a $(LIBDIR)/libstr.a $(LIBDIR)/libsystem.a -o ../src/main
size ../src/main
tokenfile.g: tokenname.c make.tokfile
@ -114,7 +122,7 @@ char.c: ../src/char.tab ../src/tab
depend: mkdep
sed '/^#AUTOAUTO/,$$d' Makefile > Makefile.new
echo '#AUTOAUTOAUTOAUTOAUTOAUTOAUTOAUTO' >> Makefile.new
./mkdep `./sources $(OBJ)` |\
./mkdep $(SRC) |\
sed 's/\.c:/\.o:/' >> Makefile.new
mv Makefile Makefile.old
mv Makefile.new Makefile
@ -128,13 +136,13 @@ main.o: LLlex.h Lpars.h debug.h def.h f_info.h idf.h input.h inputtype.h ndir.h
symbol2str.o: Lpars.h
tokenname.o: Lpars.h idf.h tokenname.h
idf.o: idf.h
input.o: f_info.h input.h inputtype.h
input.o: def.h f_info.h idf.h input.h inputtype.h scope.h
type.o: LLlex.h const.h debug.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 def.h idf.h main.h node.h scope.h type.h
scope.o: LLlex.h debug.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 def.h idf.h main.h node.h scope.h type.h
defmodule.o: LLlex.h debug.h def.h f_info.h idf.h input.h inputtype.h main.h scope.h
defmodule.o: LLlex.h Lpars.h debug.h def.h f_info.h idf.h input.h inputtype.h main.h node.h scope.h
typequiv.o: LLlex.h debug.h def.h node.h type.h
node.o: LLlex.h debug.h def.h node.h type.h
cstoper.o: LLlex.h Lpars.h debug.h idf.h node.h standards.h target_sizes.h type.h
@ -145,7 +153,7 @@ casestat.o: LLlex.h Lpars.h debug.h density.h desig.h node.h type.h walk.h
desig.o: LLlex.h debug.h def.h desig.h node.h scope.h type.h
code.o: LLlex.h Lpars.h debug.h def.h desig.h node.h scope.h standards.h type.h walk.h
tmpvar.o: debug.h def.h main.h scope.h type.h
lookup.o: LLlex.h debug.h def.h idf.h node.h scope.h
lookup.o: LLlex.h debug.h def.h idf.h node.h scope.h type.h
tokenfile.o: Lpars.h
program.o: LLlex.h Lpars.h debug.h def.h f_info.h idf.h main.h node.h scope.h type.h
declar.o: LLlex.h Lpars.h chk_expr.h debug.h def.h idf.h main.h misc.h node.h scope.h type.h

16
lang/m2/comp/Parameters
View file

@ -34,13 +34,13 @@
/* 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
#define AL_FLOAT SZ_WORD
#define AL_DOUBLE SZ_WORD
#define AL_POINTER SZ_WORD
#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
@ -55,7 +55,7 @@ extern char options[];
#endif DEBUG
!File: inputtype.h
#undef INP_READ_IN_ONE 1 /* read input file in one */
#define INP_READ_IN_ONE 1 /* read input file in one */
!File: maxset.h

8
lang/m2/comp/Resolve
View file

@ -19,10 +19,10 @@ then
:
else mkdir ../Xsrc
fi
make cclash
make cid
./cclash -c -l7 `cat Cfiles` > clashes
sed '/^C_/d' < clashes > ../Xsrc/Xclashes
make cclash clashes cid
sed '/^C_/d' < clashes > tmp$$
./cclash -c -l7 tmp$$ > ../Xsrc/Xclashes
rm -f tmp$$
cd ../Xsrc
if cmp -s Xclashes clashes
then

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

@ -0,0 +1 @@
char Version[] = "Version 0.5";

97
lang/m2/comp/casestat.C
View file

@ -1,8 +1,11 @@
/* 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 */
#ifndef NORCSID
static char *RcsId = "$Header$";
#endif
/* 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"
@ -22,30 +25,32 @@ static char *RcsId = "$Header$";
#include "density.h"
struct switch_hdr {
struct switch_hdr *next;
label sh_break;
label sh_default;
int sh_nrofentries;
struct type *sh_type;
arith sh_lowerbd;
arith sh_upperbd;
struct case_entry *sh_entries;
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" */
/* STATICALLOCDEF "switch_hdr" 5 */
struct case_entry {
struct case_entry *next;
label ce_label;
arith ce_value;
struct case_entry *next; /* next in list */
label ce_label; /* generated label */
arith ce_value; /* value of case label */
};
/* STATICALLOCDEF "case_entry" */
/* 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
are also reasonable. On these machines the density of jump tables
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)
@ -56,30 +61,36 @@ CaseCode(nd, 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 tablabel;
label CaseDescrLab;
assert(pnode->nd_class == Stat && pnode->nd_symb == CASE);
clear((char *) sh, sizeof(*sh));
WalkExpr(pnode->nd_left);
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 && pnode->nd_right) {
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;
if (! AddCases(sh,
if (! AddCases(sh, /* to descriptor */
pnode->nd_left->nd_left,
pnode->nd_lab)) {
/* of case labels */
pnode->nd_lab
/* and code label */
)) {
FreeSh(sh);
return;
}
@ -90,19 +101,20 @@ CaseCode(nd, exitlabel)
*/
sh->sh_default = ++text_label;
pnode = 0;
break;
}
}
/* Now generate code for the switch itself
First the part that CSA and CSB descriptions have in common.
*/
tablabel = ++data_label; /* the rom must have a label */
C_df_dlb(tablabel);
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 */
/* CSA
*/
C_rom_cst(sh->sh_lowerbd);
C_rom_cst(sh->sh_upperbd - sh->sh_lowerbd);
ce = sh->sh_entries;
@ -115,24 +127,27 @@ CaseCode(nd, exitlabel)
else if (sh->sh_default) C_rom_ilb(sh->sh_default);
else C_rom_ucon("0", pointer_size);
}
C_lae_dlb(tablabel, (arith)0); /* perform the switch */
C_lae_dlb(CaseDescrLab, (arith)0); /* perform the switch */
C_csa(word_size);
}
else { /* CSB */
else {
/* CSB
*/
C_rom_cst((arith)sh->sh_nrofentries);
for (ce = sh->sh_entries; ce; ce = ce->next) {
/* generate the entries: value + prog.label */
/* generate the entries: value + prog.label
*/
C_rom_cst(ce->ce_value);
C_rom_ilb(ce->ce_label);
}
C_lae_dlb(tablabel, (arith)0); /* perform the switch */
C_lae_dlb(CaseDescrLab, (arith)0); /* perform the switch */
C_csb(word_size);
}
/* Now generate code for the cases
*/
pnode = nd;
while (pnode && pnode->nd_right) {
while (pnode->nd_right) {
pnode = pnode->nd_right;
if (pnode->nd_class == Link && pnode->nd_symb == '|') {
if (pnode->nd_left) {
@ -148,7 +163,7 @@ CaseCode(nd, exitlabel)
C_df_ilb(sh->sh_default);
WalkNode(pnode, exitlabel);
pnode = 0;
break;
}
}
@ -157,7 +172,7 @@ CaseCode(nd, exitlabel)
}
FreeSh(sh)
struct switch_hdr *sh;
register struct switch_hdr *sh;
{
/* free the allocated switch structure
*/
@ -176,7 +191,7 @@ FreeSh(sh)
AddCases(sh, node, lbl)
struct switch_hdr *sh;
struct node *node;
register struct node *node;
label lbl;
{
/* Add case labels to the case label list
@ -208,7 +223,7 @@ AddCases(sh, node, lbl)
AddOneCase(sh, node, lbl)
register struct switch_hdr *sh;
struct node *node;
register struct node *node;
label lbl;
{
register struct case_entry *ce = new_case_entry();
@ -222,15 +237,17 @@ AddOneCase(sh, node, lbl)
return 0;
}
if (sh->sh_entries == 0) {
/* first case entry */
/* 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 */
/* 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;

228
lang/m2/comp/chk_expr.c
View file

@ -1,9 +1,5 @@
/* E X P R E S S I O N C H E C K I N G */
#ifndef NORCSID
static char *RcsId = "$Header$";
#endif
/* Check expressions, and try to evaluate them as far as possible.
*/
@ -31,6 +27,9 @@ int
ChkVariable(expp)
register struct node *expp;
{
/* Check that "expp" indicates an item that can be
assigned to.
*/
if (! ChkDesignator(expp)) return 0;
@ -47,6 +46,9 @@ STATIC int
ChkArrow(expp)
register struct node *expp;
{
/* Check an application of the '^' operator.
The operand must be a variable of a pointer type.
*/
register struct type *tp;
assert(expp->nd_class == Arrow);
@ -59,8 +61,7 @@ ChkArrow(expp)
tp = expp->nd_right->nd_type;
if (tp->tp_fund != T_POINTER) {
node_error(expp, "illegal operand for unary operator \"%s\"",
symbol2str(expp->nd_symb));
node_error(expp, "illegal operand for unary operator \"^\"");
return 0;
}
@ -72,6 +73,12 @@ STATIC int
ChkArr(expp)
register struct node *expp;
{
/* Check an array selection.
The left hand side must be a variable of an array type,
and the right hand side must be an expression that is
assignment compatible with the array-index.
*/
register struct type *tpl, *tpr;
assert(expp->nd_class == Arrsel);
@ -91,7 +98,7 @@ ChkArr(expp)
tpr = expp->nd_right->nd_type;
if (tpl->tp_fund != T_ARRAY) {
node_error(expp, "array index not belonging to an ARRAY");
node_error(expp, "not indexing an ARRAY type");
return 0;
}
@ -110,6 +117,7 @@ ChkArr(expp)
return 1;
}
#ifdef DEBUG
STATIC int
ChkValue(expp)
struct node *expp;
@ -125,11 +133,15 @@ ChkValue(expp)
}
/*NOTREACHED*/
}
#endif
STATIC int
ChkLinkOrName(expp)
register struct node *expp;
{
/* Check either an ID or a construction of the form
ID.ID [ .ID ]*
*/
register struct def *df;
expp->nd_type = error_type;
@ -140,6 +152,9 @@ ChkLinkOrName(expp)
expp->nd_type = RemoveEqual(expp->nd_def->df_type);
}
else if (expp->nd_class == Link) {
/* A selection from a record or a module.
Modules also have a record type.
*/
register struct node *left = expp->nd_left;
assert(expp->nd_symb == '.');
@ -188,16 +203,17 @@ df->df_idf->id_text);
if (df->df_kind == D_ERROR) return 0;
if (df->df_kind & (D_ENUM | D_CONST)) {
/* Replace an enum-literal or a CONST identifier by its value.
*/
if (df->df_kind == D_ENUM) {
expp->nd_class = Value;
expp->nd_INT = df->enm_val;
expp->nd_symb = INTEGER;
}
else {
unsigned int ln;
unsigned int ln = expp->nd_lineno;
assert(df->df_kind == D_CONST);
ln = expp->nd_lineno;
*expp = *(df->con_const);
expp->nd_lineno = ln;
}
@ -210,25 +226,28 @@ STATIC int
ChkExLinkOrName(expp)
register struct node *expp;
{
/* Check either an ID or an ID.ID [.ID]* occurring in an
expression.
*/
register struct def *df;
if (! ChkLinkOrName(expp)) return 0;
if (expp->nd_class != Def) return 1;
df = expp->nd_def;
if (!(df->df_kind & (D_ENUM|D_CONST|D_PROCEDURE|D_FIELD|D_VARIABLE|D_PROCHEAD))) {
if (!(df->df_kind & D_VALUE)) {
node_error(expp, "value expected");
}
if (df->df_kind == D_PROCEDURE) {
/* Check that this procedure is one that we
may take the address from.
/* Check that this procedure is one that we may take the
address from.
*/
if (df->df_type == std_type || df->df_scope->sc_level > 0) {
/* Address of standard or nested procedure
taken.
*/
node_error(expp, "it is illegal to take the address of a standard or local procedure");
node_error(expp, "standard or local procedures may not be assigned");
return 0;
}
}
@ -236,20 +255,6 @@ node_error(expp, "it is illegal to take the address of a standard or local proce
return 1;
}
STATIC int
RemoveSet(set)
arith **set;
{
/* This routine is only used for error exits of ChkElement.
It frees the set indicated by "set", and returns 0.
*/
if (*set) {
free((char *) *set);
*set = 0;
}
return 0;
}
STATIC int
ChkElement(expp, tp, set)
register struct node *expp;
@ -279,7 +284,7 @@ ChkElement(expp, tp, set)
if (left->nd_INT > right->nd_INT) {
node_error(expp, "lower bound exceeds upper bound in range");
return RemoveSet(set);
return 0;
}
if (*set) {
@ -298,28 +303,24 @@ node_error(expp, "lower bound exceeds upper bound in range");
/* Here, a single element is checked
*/
if (!ChkExpression(expp)) {
return RemoveSet(set);
}
if (!ChkExpression(expp)) return 0;
if (!TstCompat(tp, expp->nd_type)) {
node_error(expp, "set element has incompatible type");
return RemoveSet(set);
return 0;
}
if (expp->nd_class == Value) {
/* a constant element
*/
i = expp->nd_INT;
arith low, high;
if ((tp->tp_fund != T_ENUMERATION &&
(i < tp->sub_lb || i > tp->sub_ub))
||
(tp->tp_fund == T_ENUMERATION &&
(i < 0 || i > tp->enm_ncst))
) {
i = expp->nd_INT;
getbounds(tp, &low, &high);
if (i < low || i > high) {
node_error(expp, "set element out of range");
return RemoveSet(set);
return 0;
}
if (*set) (*set)[i/wrd_bits] |= (1 << (i%wrd_bits));
@ -353,9 +354,11 @@ ChkSet(expp)
assert(nd->nd_class == Def);
df = nd->nd_def;
if (!(df->df_kind & (D_TYPE|D_ERROR)) ||
if (!is_type(df) ||
(df->df_type->tp_fund != T_SET)) {
node_error(expp, "specifier does not represent a set type");
if (df->df_kind != D_ERROR) {
node_error(expp, "type specifier does not represent a set type");
}
return 0;
}
tp = df->df_type;
@ -394,7 +397,8 @@ node_error(expp, "specifier does not represent a set type");
/* Yes, it was a constant set, and we managed to compute it!
Notice that at the moment there is no such thing as
partial evaluation. Either we evaluate the set, or we
don't (at all). Improvement not neccesary. (???)
don't (at all). Improvement not neccesary (???)
??? sets have a contant part and a variable part ???
*/
expp->nd_class = Set;
expp->nd_set = set;
@ -417,7 +421,6 @@ getarg(argp, bases, designator)
that it must be a designator and may not be a register
variable.
*/
struct type *tp;
register struct node *arg = (*argp)->nd_right;
register struct node *left;
@ -437,8 +440,7 @@ getarg(argp, bases, designator)
}
if (bases) {
tp = BaseType(left->nd_type);
if (!(tp->tp_fund & bases)) {
if (!(BaseType(left->nd_type)->tp_fund & bases)) {
node_error(arg, "unexpected type");
return 0;
}
@ -452,7 +454,12 @@ STATIC struct node *
getname(argp, kinds)
struct node **argp;
{
/* Get the next argument from argument list "argp".
The argument must indicate a definition, and the
definition kind must be one of "kinds".
*/
register struct node *arg = *argp;
register struct node *left;
if (!arg->nd_right) {
node_error(arg, "too few arguments supplied");
@ -460,25 +467,26 @@ getname(argp, kinds)
}
arg = arg->nd_right;
if (! ChkDesignator(arg->nd_left)) return 0;
left = arg->nd_left;
if (! ChkDesignator(left)) return 0;
if (arg->nd_left->nd_class != Def && arg->nd_left->nd_class != LinkDef) {
if (left->nd_class != Def && left->nd_class != LinkDef) {
node_error(arg, "identifier expected");
return 0;
}
if (!(arg->nd_left->nd_def->df_kind & kinds)) {
if (!(left->nd_def->df_kind & kinds)) {
node_error(arg, "unexpected type");
return 0;
}
*argp = arg;
return arg->nd_left;
return left;
}
STATIC int
ChkProcCall(expp)
register struct node *expp;
struct node *expp;
{
/* Check a procedure call
*/
@ -487,11 +495,12 @@ ChkProcCall(expp)
register struct paramlist *param;
left = expp->nd_left;
arg = expp;
expp->nd_type = RemoveEqual(ResultType(left->nd_type));
/* Check parameter list
*/
for (param = ParamList(left->nd_type); param; param = param->next) {
if (!(left = getarg(&arg, 0, IsVarParam(param)))) return 0;
if (!(left = getarg(&expp, 0, IsVarParam(param)))) return 0;
if (left->nd_symb == STRING) {
TryToString(left, TypeOfParam(param));
}
@ -504,8 +513,8 @@ node_error(left, "type incompatibility in parameter");
}
}
if (arg->nd_right) {
node_error(arg->nd_right, "too many parameters supplied");
if (expp->nd_right) {
node_error(expp->nd_right, "too many parameters supplied");
return 0;
}
@ -517,7 +526,7 @@ ChkCall(expp)
register struct node *expp;
{
/* Check something that looks like a procedure or function call.
Of course this does not have to be a call at all.
Of course this does not have to be a call at all,
it may also be a cast or a standard procedure call.
*/
register struct node *left;
@ -531,14 +540,14 @@ ChkCall(expp)
if (! ChkDesignator(left)) return 0;
if (IsCast(left)) {
/* It was a type cast. This is of course not portable.
/* It was a type cast.
*/
return ChkCast(expp, left);
}
if (IsProcCall(left)) {
/* A procedure call. it may also be a call to a
standard procedure
/* A procedure call.
It may also be a call to a standard procedure
*/
if (left->nd_type == std_type) {
/* A standard procedure
@ -559,6 +568,10 @@ STATIC struct type *
ResultOfOperation(operator, tp)
struct type *tp;
{
/* Return the result type of the binary operation "operator",
with operand type "tp".
*/
switch(operator) {
case '=':
case '#':
@ -582,6 +595,10 @@ Boolean(operator)
STATIC int
AllowedTypes(operator)
{
/* Return a bit mask indicating the allowed operand types
for binary operator "operator".
*/
switch(operator) {
case '+':
case '-':
@ -615,13 +632,17 @@ STATIC int
ChkAddress(tpl, tpr)
register struct type *tpl, *tpr;
{
/* Check that either "tpl" or "tpr" are both of type
address_type, or that one of them is, but the other is
of type cardinal.
*/
if (tpl == address_type) {
return tpr == address_type || tpr->tp_fund != T_POINTER;
return tpr == address_type || (tpr->tp_fund & T_CARDINAL);
}
if (tpr == address_type) {
return tpl->tp_fund != T_POINTER;
return (tpl->tp_fund & T_CARDINAL);
}
return 0;
@ -656,21 +677,26 @@ ChkBinOper(expp)
}
}
expp->nd_type = ResultOfOperation(expp->nd_symb, tpl);
expp->nd_type = ResultOfOperation(expp->nd_symb, tpr);
/* Check that the application of the operator is allowed on the type
of the operands.
There are three tricky parts:
- Boolean operators are only allowed on boolean operands, but
the "allowed-mask" of "AllowedTypes" can only indicate
an enumeration type.
- All operations that are allowed on CARDINALS are also allowed
on ADDRESS.
- The IN-operator has as right-hand-size operand a set.
*/
if (expp->nd_symb == IN) {
/* Handle this one specially */
if (tpr->tp_fund != T_SET) {
node_error(expp, "RHS of IN operator not a SET type");
return 0;
}
if (!TstAssCompat(tpl, ElementType(tpr))) {
/* Assignment compatible ???
I don't know! Should we be allowed to check
if a CARDINAL is a member of a BITSET???
*/
node_error(expp, "IN operator: type of LHS not compatible with element type of RHS");
node_error(expp, "incompatible types for operator \"IN\"");
return 0;
}
if (left->nd_class == Value && right->nd_class == Set) {
@ -679,6 +705,25 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
return 1;
}
allowed = AllowedTypes(expp->nd_symb);
if (!(tpr->tp_fund & allowed) || !(tpl->tp_fund & allowed)) {
if (!((T_CARDINAL & allowed) &&
ChkAddress(tpl, tpr))) {
node_error(expp,"operator \"%s\": illegal operand type(s)", symbol2str(expp->nd_symb));
return 0;
}
if (expp->nd_type->tp_fund & T_CARDINAL) {
expp->nd_type = address_type;
}
}
if (Boolean(expp->nd_symb) && tpl != bool_type) {
node_error(expp,"operator \"%s\": illegal operand type(s)", symbol2str(expp->nd_symb));
return 0;
}
/* Operands must be compatible (distilled from Def 8.2)
*/
if (!TstCompat(tpl, tpr)) {
@ -687,32 +732,6 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
return 0;
}
allowed = AllowedTypes(expp->nd_symb);
/* Check that the application of the operator is allowed on the type
of the operands.
There are two tricky parts:
- Boolean operators are only allowed on boolean operands, but
the "allowed-mask" of "AllowedTypes" can only indicate
an enumeration type.
- All operations that are allowed on CARDINALS are also allowed
on ADDRESS.
*/
if (Boolean(expp->nd_symb) && tpl != bool_type) {
node_error(expp,"operator \"%s\": illegal operand type(s)", symbol2str(expp->nd_symb));
return 0;
}
if (!(tpl->tp_fund & allowed)) {
if (!(tpl->tp_fund == T_POINTER &&
(T_CARDINAL & allowed) &&
ChkAddress(tpl, tpr))) {
node_error(expp,"operator \"%s\": illegal operand type(s)", symbol2str(expp->nd_symb));
return 0;
}
if (expp->nd_type == card_type) expp->nd_type = address_type;
}
if (tpl->tp_fund == T_SET) {
if (left->nd_class == Set && right->nd_class == Set) {
cstset(expp);
@ -737,9 +756,8 @@ ChkUnOper(expp)
if (! ChkExpression(right)) return 0;
tpr = BaseType(right->nd_type);
expp->nd_type = tpr = BaseType(right->nd_type);
if (tpr == address_type) tpr = card_type;
expp->nd_type = tpr;
switch(expp->nd_symb) {
case '+':
@ -799,6 +817,9 @@ STATIC struct node *
getvariable(argp)
struct node **argp;
{
/* Get the next argument from argument list "argp".
It must obey the rules of "ChkVariable".
*/
register struct node *arg = *argp;
arg = arg->nd_right;
@ -807,10 +828,11 @@ getvariable(argp)
return 0;
}
if (! ChkVariable(arg->nd_left)) return 0;
*argp = arg;
return arg->nd_left;
arg = arg->nd_left;
if (! ChkVariable(arg)) return 0;
return arg;
}
STATIC int
@ -1104,7 +1126,11 @@ done_before(expp)
extern int NodeCrash();
int (*ExprChkTable[])() = {
#ifdef DEBUG
ChkValue,
#else
done_before,
#endif
ChkArr,
ChkBinOper,
ChkUnOper,
@ -1120,7 +1146,11 @@ int (*ExprChkTable[])() = {
};
int (*DesigChkTable[])() = {
#ifdef DEBUG
ChkValue,
#else
done_before,
#endif
ChkArr,
no_desig,
no_desig,

2
lang/m2/comp/chk_expr.h
View file

@ -1,7 +1,5 @@
/* E X P R E S S I O N C H E C K I N G */
/* $Header$ */
extern int (*ExprChkTable[])(); /* table of expression checking
functions, indexed by node class
*/

2
lang/m2/comp/class.h
View file

@ -1,7 +1,5 @@
/* U S E O F C H A R A C T E R C L A S S E S */
/* $Header$ */
/* 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.

150
lang/m2/comp/code.c
View file

@ -1,9 +1,5 @@
/* C O D E G E N E R A T I O N R O U T I N E S */
#ifndef NORCSID
static char *RcsId = "$Header$";
#endif
/* Code generation for expressions and coercions
*/
@ -34,7 +30,6 @@ CodeConst(cst, size)
{
/* Generate code to push constant "cst" with size "size"
*/
label dlab;
if (size <= word_size) {
C_loc(cst);
@ -43,23 +38,28 @@ CodeConst(cst, size)
C_ldc(cst);
}
else {
C_df_dlb(dlab = ++data_label);
crash("(CodeConst)");
/*
label dlab = ++data_label;
C_df_dlb(dlab);
C_rom_icon(long2str((long) cst), size);
C_lae_dlb(dlab, (arith) 0);
C_loi(size);
*/
}
}
CodeString(nd)
register struct node *nd;
{
label lab;
if (nd->nd_type->tp_fund != T_STRING) {
C_loc(nd->nd_INT);
}
else {
C_df_dlb(lab = ++data_label);
label lab = ++data_label;
C_df_dlb(lab);
C_rom_scon(nd->nd_STR, WA(nd->nd_SLE + 1));
C_lae_dlb(lab, (arith) 0);
}
@ -85,16 +85,6 @@ CodePadString(nd, sz)
C_loi(sizearg);
}
CodeReal(nd)
register struct node *nd;
{
label lab = ++data_label;
C_df_dlb(lab);
C_rom_fcon(nd->nd_REL, nd->nd_type->tp_size);
C_lae_dlb(lab, (arith) 0);
C_loi(nd->nd_type->tp_size);
}
CodeExpr(nd, ds, true_label, false_label)
register struct node *nd;
@ -136,8 +126,14 @@ CodeExpr(nd, ds, true_label, false_label)
case Value:
switch(nd->nd_symb) {
case REAL:
CodeReal(nd);
case REAL: {
label lab = ++data_label;
C_df_dlb(lab);
C_rom_fcon(nd->nd_REL, nd->nd_type->tp_size);
C_lae_dlb(lab, (arith) 0);
C_loi(nd->nd_type->tp_size);
}
break;
case STRING:
CodeString(nd);
@ -157,8 +153,8 @@ CodeExpr(nd, ds, true_label, false_label)
break;
case Set: {
arith *st;
int i;
register arith *st = nd->nd_set;
register int i;
st = nd->nd_set;
ds->dsg_kind = DSG_LOADED;
@ -182,6 +178,8 @@ CodeExpr(nd, ds, true_label, false_label)
}
if (true_label != 0) {
/* Only for boolean expressions
*/
CodeValue(ds, tp->tp_size);
*ds = InitDesig;
C_zne(true_label);
@ -293,6 +291,7 @@ CodeCall(nd)
and result is already done.
*/
register struct node *left = nd->nd_left;
register struct node *right = nd->nd_right;
register struct type *result_tp;
if (left->nd_type == std_type) {
@ -303,16 +302,16 @@ CodeCall(nd)
if (IsCast(left)) {
/* it was just a cast. Simply ignore it
*/
CodePExpr(nd->nd_right->nd_left);
*nd = *(nd->nd_right->nd_left);
CodePExpr(right->nd_left);
*nd = *(right->nd_left);
nd->nd_type = left->nd_def->df_type;
return;
}
assert(IsProcCall(left));
if (nd->nd_right) {
CodeParameters(ParamList(left->nd_type), nd->nd_right);
if (right) {
CodeParameters(ParamList(left->nd_type), right);
}
switch(left->nd_class) {
@ -387,11 +386,9 @@ CodeParameters(param, arg)
C_loc((left_type->tp_size+word_size-1) / word_size - 1);
}
else {
tp = IndexType(left_type);
if (tp->tp_fund == T_SUBRANGE) {
C_loc(tp->sub_ub - tp->sub_lb);
}
else C_loc((arith) (tp->enm_ncst - 1));
arith lb, ub;
getbounds(IndexType(left_type), &lb, &ub);
C_loc(ub - lb);
}
C_loc((arith) 0);
if (left->nd_symb == STRING) {
@ -417,7 +414,7 @@ CodeStd(nd)
register struct node *arg = nd->nd_right;
register struct node *left = 0;
register struct type *tp = 0;
int std;
int std = nd->nd_left->nd_def->df_value.df_stdname;
if (arg) {
left = arg->nd_left;
@ -425,7 +422,7 @@ CodeStd(nd)
arg = arg->nd_right;
}
switch(std = nd->nd_left->nd_def->df_value.df_stdname) {
switch(std) {
case S_ABS:
CodePExpr(left);
if (tp->tp_fund == T_INTEGER) {
@ -446,7 +443,7 @@ CodeStd(nd)
case S_CAP:
CodePExpr(left);
C_loc((arith) 0137);
C_loc((arith) 0137); /* ASCII assumed */
C_and(word_size);
break;
@ -498,34 +495,25 @@ CodeStd(nd)
break;
case S_DEC:
case S_INC:
case S_INC: {
register arith size = tp->tp_size;
if (size < word_size) size = word_size;
CodePExpr(left);
if (arg) CodePExpr(arg->nd_left);
else C_loc((arith) 1);
if (tp->tp_size <= word_size) {
if (std == S_DEC) {
if (tp->tp_fund == T_INTEGER) C_sbi(word_size);
else C_sbu(word_size);
}
else {
if (tp->tp_fund == T_INTEGER) C_adi(word_size);
else C_adu(word_size);
}
RangeCheck(tp, int_type);
if (std == S_DEC) {
if (tp->tp_fund == T_INTEGER) C_sbi(size);
else C_sbu(size);
}
else {
CodeCoercion(int_type, tp);
if (std == S_DEC) {
if (tp->tp_fund==T_INTEGER) C_sbi(tp->tp_size);
else C_sbu(tp->tp_size);
}
else {
if (tp->tp_fund==T_INTEGER) C_adi(tp->tp_size);
else C_adu(tp->tp_size);
}
if (tp->tp_fund == T_INTEGER) C_adi(size);
else C_adu(size);
}
if (size == word_size) RangeCheck(tp, int_type);
CodeDStore(left);
break;
}
case S_HALT:
C_cal("_halt");
@ -552,29 +540,30 @@ CodeStd(nd)
}
CodeAssign(nd, dss, dst)
struct node *nd;
register struct node *nd;
struct desig *dst, *dss;
{
/* Generate code for an assignment. Testing of type
compatibility and the like is already done.
*/
register struct type *tp = nd->nd_right->nd_type;
arith size = nd->nd_left->nd_type->tp_size;
if (dss->dsg_kind == DSG_LOADED) {
if (tp->tp_fund == T_STRING) {
CodeAddress(dst);
C_loc(tp->tp_size);
C_loc(nd->nd_left->nd_type->tp_size);
C_loc(size);
C_cal("_StringAssign");
C_asp((int_size << 1) + (pointer_size << 1));
return;
}
CodeStore(dst, nd->nd_left->nd_type->tp_size);
CodeStore(dst, size);
return;
}
CodeAddress(dss);
CodeAddress(dst);
C_blm(nd->nd_left->nd_type->tp_size);
C_blm(size);
}
RangeCheck(tpl, tpr)
@ -593,7 +582,10 @@ RangeCheck(tpl, tpr)
}
else {
/* both types are restricted. check the bounds
to see wether we need a range check
to see wether we need a range check.
We don't need one if the range of values of the
right hand side is a subset of the range of values
of the left hand side.
*/
getbounds(tpl, &llo, &lhi);
getbounds(tpr, &rlo, &rhi);
@ -806,6 +798,7 @@ CodeOper(expr, true_label, false_label)
C_bra(false_label);
}
break;
case OR:
case AND:
case '&': {
label l_true, l_false, l_maybe = ++text_label, l_end;
@ -822,7 +815,10 @@ CodeOper(expr, true_label, false_label)
}
Des = InitDesig;
CodeExpr(leftop, &Des, l_maybe, l_false);
if (expr->nd_symb == OR) {
CodeExpr(leftop, &Des, l_true, l_maybe);
}
else CodeExpr(leftop, &Des, l_maybe, l_false);
C_df_ilb(l_maybe);
Des = InitDesig;
CodeExpr(rightop, &Des, l_true, l_false);
@ -836,34 +832,6 @@ CodeOper(expr, true_label, false_label)
}
break;
}
case OR: {
label l_true, l_false, l_maybe = ++text_label, l_end;
struct desig Des;
if (true_label == 0) {
l_true = ++text_label;
l_false = ++text_label;
l_end = ++text_label;
}
else {
l_true = true_label;
l_false = false_label;
}
Des = InitDesig;
CodeExpr(leftop, &Des, l_true, l_maybe);
C_df_ilb(l_maybe);
Des = InitDesig;
CodeExpr(rightop, &Des, l_true, l_false);
if (true_label == 0) {
C_df_ilb(l_false);
C_loc((arith)0);
C_bra(l_end);
C_df_ilb(l_true);
C_loc((arith)1);
C_df_ilb(l_end);
}
break;
}
default:
crash("(CodeOper) Bad operator %s\n",symbol2str(expr->nd_symb));
}
@ -958,9 +926,9 @@ CodeUoper(nd)
CodeSet(nd)
register struct node *nd;
{
struct type *tp = nd->nd_type;
register struct type *tp = nd->nd_type;
C_zer(nd->nd_type->tp_size); /* empty set */
C_zer(tp->tp_size); /* empty set */
nd = nd->nd_right;
while (nd) {
assert(nd->nd_class == Link && nd->nd_symb == ',');

2
lang/m2/comp/const.h
View file

@ -1,7 +1,5 @@
/* 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 */
/* $Header$ */
extern long
mach_long_sign; /* sign bit of the machine long */
extern int

8
lang/m2/comp/cstoper.c
View file

@ -1,9 +1,5 @@
/* 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 */
#ifndef NORCSID
static char *RcsId = "$Header$";
#endif
#include "debug.h"
#include "target_sizes.h"
@ -35,8 +31,10 @@ cstunary(expp)
register arith o1 = expp->nd_right->nd_INT;
switch(expp->nd_symb) {
/* Should not get here
case '+':
break;
*/
case '-':
o1 = -o1;
@ -71,7 +69,7 @@ cstbin(expp)
*/
register arith o1 = expp->nd_left->nd_INT;
register arith o2 = expp->nd_right->nd_INT;
int uns = expp->nd_type != int_type;
register int uns = expp->nd_type != int_type;
assert(expp->nd_class == Oper);
assert(expp->nd_left->nd_class == Value);

293
lang/m2/comp/declar.g
View file

@ -1,10 +1,6 @@
/* D E C L A R A T I O N S */
{
#ifndef NORCSID
static char *RcsId = "$Header$";
#endif
#include "debug.h"
#include <em_arith.h>
@ -23,69 +19,38 @@ static char *RcsId = "$Header$";
#include "chk_expr.h"
int proclevel = 0; /* nesting level of procedures */
int return_occurred; /* set if a return occurred in a
procedure or function
*/
int return_occurred; /* set if a return occurs in a block */
}
ProcedureDeclaration
{
register struct def *df;
struct def *df1; /* only exists because &df is illegal */
struct def *df;
} :
{ ++proclevel;
return_occurred = 0;
}
ProcedureHeading(&df1, D_PROCEDURE)
{ CurrentScope->sc_definedby = df = df1;
df->prc_vis = CurrVis;
}
';' block(&(df->prc_body)) IDENT
{ match_id(dot.TOK_IDF, 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);
}
{ ++proclevel; }
ProcedureHeading(&df, D_PROCEDURE)
';' block(&(df->prc_body))
IDENT
{ EndProc(df, dot.TOK_IDF);
--proclevel;
}
;
ProcedureHeading(struct def **pdf; int type;)
{
struct paramlist *params = 0;
register struct type *tp;
struct type *tp1 = 0;
register struct def *df;
arith NBytesParams; /* parameter offset counter */
struct type *tp = 0;
#define needs_static_link() (proclevel > 1)
arith parmaddr = needs_static_link() ? pointer_size : 0;
struct paramlist *pr = 0;
} :
PROCEDURE IDENT
{ df = DeclProc(type);
if (proclevel > 1) { /* need room for static link */
NBytesParams = pointer_size;
}
else NBytesParams = 0;
}
FormalParameters(&params, &tp1, &NBytesParams)?
{ tp = construct_type(T_PROCEDURE, tp1);
tp->prc_params = params;
tp->prc_nbpar = NBytesParams;
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;
*pdf = df;
}
{ *pdf = DeclProc(type, dot.TOK_IDF); }
FormalParameters(&pr, &parmaddr, &tp)?
{ CheckWithDef(*pdf, proc_type(tp, pr, parmaddr)); }
;
block(struct node **pnd;) :
declaration*
[
[ { return_occurred = 0; }
BEGIN
StatementSequence(pnd)
|
@ -106,15 +71,12 @@ declaration:
ModuleDeclaration ';'
;
FormalParameters(struct paramlist **pr;
struct type **ptp;
arith *parmaddr;)
:
FormalParameters(struct paramlist *ppr; arith *parmaddr; struct type **ptp;):
'('
[
FPSection(pr, parmaddr)
FPSection(ppr, parmaddr)
[
';' FPSection(pr, parmaddr)
';' FPSection(ppr, parmaddr)
]*
]?
')'
@ -134,12 +96,12 @@ FPSection(struct paramlist **ppr; arith *parmaddr;)
FormalType(struct type **ptp;)
{
register struct type *tp;
extern arith ArrayElSize();
} :
ARRAY OF qualtype(ptp)
{ tp = construct_type(T_ARRAY, NULLTYPE);
tp->arr_elem = *ptp; *ptp = tp;
{ 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 = lcm(word_align, pointer_align);
}
@ -194,12 +156,12 @@ SimpleType(struct type **ptp;)
enumeration(struct type **ptp;)
{
struct node *EnumList;
register struct type *tp;
} :
'(' IdentList(&EnumList) ')'
{ *ptp = tp = standard_type(T_ENUMERATION, 1, (arith) 1);
EnterEnumList(EnumList, tp);
if (tp->enm_ncst > 256) { /* ??? is this reasonable ??? */
{
*ptp = standard_type(T_ENUMERATION, 1, (arith) 1);
EnterEnumList(EnumList, *ptp);
if ((*ptp)->enm_ncst > 256) { /* ??? is this reasonable ??? */
error("Too many enumeration literals");
}
}
@ -230,7 +192,10 @@ SubrangeType(struct type **ptp;)
'[' ConstExpression(&nd1)
UPTO ConstExpression(&nd2)
']'
{ *ptp = subr_type(nd1, nd2); }
{ *ptp = subr_type(nd1, nd2);
free_node(nd1);
free_node(nd2);
}
;
ArrayType(struct type **ptp;)
@ -254,18 +219,18 @@ ArrayType(struct type **ptp;)
RecordType(struct type **ptp;)
{
register struct scope *scope;
arith count;
arith size;
int xalign = struct_align;
}
:
RECORD
{ open_scope(OPENSCOPE);
{ open_scope(OPENSCOPE); /* scope for fields of record */
scope = CurrentScope;
close_scope(0);
count = 0;
size = 0;
}
FieldListSequence(scope, &count, &xalign)
{ *ptp = standard_type(T_RECORD, xalign, WA(count));
FieldListSequence(scope, &size, &xalign)
{ *ptp = standard_type(T_RECORD, xalign, WA(size));
(*ptp)->rec_scope = scope;
}
END
@ -281,10 +246,10 @@ FieldListSequence(struct scope *scope; arith *cnt; int *palign;):
FieldList(struct scope *scope; arith *cnt; int *palign;)
{
struct node *FldList;
register struct idf *id = gen_anon_idf();
register struct def *df;
register struct idf *id = 0;
struct type *tp;
struct node *nd;
struct node *nd1;
register struct node *nd;
arith tcnt, max;
} :
[
@ -294,77 +259,81 @@ FieldList(struct scope *scope; arith *cnt; int *palign;)
}
|
CASE
/* Also accept old fashioned Modula-2 syntax, but give a warning
/* Also accept old fashioned Modula-2 syntax, but give a warning.
Sorry for the complicated code.
*/
[ qualident(0, (struct def **) 0, (char *) 0, &nd)
[ ':' qualtype(&tp)
[ qualident(0, (struct def **) 0, (char *) 0, &nd1)
{ nd = nd1; }
[ ':' qualtype(&tp)
/* This is correct, in both kinds of Modula-2, if
the first qualident is a single identifier.
the first qualident is a single identifier.
*/
{ if (nd->nd_class != Name) {
error("illegal variant tag");
}
else id = nd->nd_IDF;
}
|
/* Old fashioned! the first qualident now represents
{ 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("Old fashioned Modula-2 syntax!");
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);
}
]
|
/* Aha, third edition. Well done! */
':' qualtype(&tp)
{ warning("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 (!(tp->tp_fund & T_DISCRETE)) {
{ if (id) {
register struct def *df = define(id,
scope,
D_FIELD);
if (!(tp->tp_fund & T_DISCRETE)) {
error("Illegal type in variant");
}
df = define(id, scope, D_FIELD);
df->df_type = tp;
df->fld_off = align(*cnt, tp->tp_align);
*cnt = tcnt = df->fld_off + tp->tp_size;
df->df_flags |= D_QEXPORTED;
}
}
df->df_type = tp;
df->fld_off = align(*cnt, tp->tp_align);
*cnt = tcnt = df->fld_off + tp->tp_size;
df->df_flags |= D_QEXPORTED;
}
}
OF variant(scope, &tcnt, tp, palign)
{ max = tcnt; tcnt = *cnt; }
{ max = tcnt; tcnt = *cnt; }
[
'|' variant(scope, &tcnt, tp, palign)
{ if (tcnt > max) 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; }
{ if (tcnt > max) max = tcnt; }
]?
END
{ *cnt = max; }
{ *cnt = max; }
]?
;
variant(struct scope *scope; arith *cnt; struct type *tp; int *palign;)
{
struct type *tp1 = tp;
struct node *nd;
} :
[
CaseLabelList(&tp1, &nd)
{ /* Ignore the cases for the time being.
Maybe a checking version will be supplied
later ???
*/
FreeNode(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 */
/* Changed rule in new modula-2 */
;
CaseLabelList(struct type **ptp; struct node **pnd;):
@ -376,27 +345,29 @@ CaseLabelList(struct type **ptp; struct node **pnd;):
]*
;
CaseLabels(struct type **ptp; struct node **pnd;)
CaseLabels(struct type **ptp; register struct node **pnd;)
{
struct node *nd1, *nd2 = 0;
register struct node *nd1;
}:
ConstExpression(&nd1) { *pnd = nd1; }
ConstExpression(pnd)
{ nd1 = *pnd; }
[
UPTO { *pnd = MkNode(Link,nd1,NULLNODE,&dot); }
ConstExpression(&nd2)
{ if (!TstCompat(nd1->nd_type, nd2->nd_type)) {
node_error(nd2,"type incompatibility in case label");
nd1->nd_type = error_type;
}
(*pnd)->nd_right = nd2;
}
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;
}
{ if (*ptp != 0 && !TstCompat(*ptp, nd1->nd_type)) {
node_error(nd1,
"type incompatibility in case label");
}
*ptp = nd1->nd_type;
}
;
SetType(struct type **ptp;) :
@ -410,7 +381,7 @@ SetType(struct type **ptp;) :
*/
PointerType(struct type **ptp;)
{
register struct node *nd;
register struct node *nd = 0;
} :
POINTER TO
{ *ptp = construct_type(T_POINTER, NULLTYPE); }
@ -418,49 +389,51 @@ PointerType(struct type **ptp;)
/* Either a Module or a Type, but in both cases defined
in this scope, so this is the correct identification
*/
qualtype(&((*ptp)->next))
| %if ( nd = new_node(), nd->nd_token = dot,
qualtype(&((*ptp)->next))
| %if ( nd = new_node(),
nd->nd_token = dot,
lookfor(nd, CurrVis, 0)->df_kind == D_MODULE)
{ if (dot.tk_symb == IDENT) free_node(nd); }
type(&((*ptp)->next))
type(&((*ptp)->next))
{ if (nd) free_node(nd); }
|
IDENT { Forward(nd, (*ptp)); }
IDENT { Forward(nd, (*ptp)); }
]
;
qualtype(struct type **ptp;)
{
struct def *df;
struct def *df = 0;
} :
qualident(D_ISTYPE, &df, "type", (struct node **) 0)
{ if (!(*ptp = df->df_type)) {
error("type \"%s\" not declared", df->df_idf->id_text);
*ptp = error_type;
}
}
{ if (df && !(*ptp = df->df_type)) {
error("type \"%s\" not declared",
df->df_idf->id_text);
*ptp = error_type;
}
}
;
ProcedureType(struct type **ptp;)
{
struct paramlist *pr = 0;
register struct type *tp;
arith nbytes = 0;
} :
arith parmaddr = 0;
}
:
{ *ptp = 0; }
PROCEDURE FormalTypeList(&pr, ptp, &nbytes)?
{ *ptp = tp = construct_type(T_PROCEDURE, *ptp);
tp->prc_params = pr;
tp->prc_nbpar = nbytes;
}
PROCEDURE
[
FormalTypeList(&pr, &parmaddr, ptp)
]?
{ *ptp = proc_type(*ptp, pr, parmaddr); }
;
FormalTypeList(struct paramlist **ppr; struct type **ptp; arith *parmaddr;)
FormalTypeList(struct paramlist **ppr; arith *parmaddr; struct type **ptp;)
{
int VARp;
struct type *tp;
int VARp;
} :
'(' { *ppr = 0; }
'('
[
var(&VARp) FormalType(&tp)
{ EnterParamList(ppr,NULLNODE,tp,VARp,parmaddr); }

15
lang/m2/comp/def.H
View file

@ -1,7 +1,5 @@
/* 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 */
/* $Header$ */
struct module {
arith mo_priority; /* priority of a module */
struct scopelist *mo_vis;/* scope of this module */
@ -82,12 +80,12 @@ struct def { /* list of definitions for a name */
#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 0x0800 /* not yet defined */
#define D_UNDEF_IMPORT 0x1000 /* imported from an undefined name */
#define D_FORWMODULE 0x2000 /* module must be declared later */
#define D_ERROR 0x4000 /* a compiler generated definition for an
#define D_FORWARD 0x0400 /* not yet defined */
#define D_FORWMODULE 0x0800 /* module must be declared later */
#define D_ERROR 0x1000 /* 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)
#define is_type(dfx) ((dfx)->df_kind & D_ISTYPE)
char df_flags;
@ -115,14 +113,13 @@ struct def { /* list of definitions for a name */
#define SetUsed(df) ((df)->df_flags |= D_USED)
/* ALLOCDEF "def" */
/* ALLOCDEF "def" 50 */
extern struct def
*define(),
*DefineLocalModule(),
*MkDef(),
*DeclProc(),
*ill_df;
*DeclProc();
extern struct def
*lookup(),

179
lang/m2/comp/def.c
View file

@ -1,9 +1,5 @@
/* D E F I N I T I O N M E C H A N I S M */
#ifndef NORCSID
static char *RcsId = "$Header$";
#endif
#include "debug.h"
#include <alloc.h>
@ -25,11 +21,42 @@ struct def *h_def; /* pointer to free list of def structures */
int cnt_def; /* count number of allocated ones */
#endif
struct def *ill_df;
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)
struct idf *id;
register struct idf *id;
register struct scope *scope;
{
/* Create a new definition structure in scope "scope", with
@ -38,7 +65,6 @@ MkDef(id, scope, kind)
register struct def *df;
df = new_def();
clear((char *) df, sizeof (*df));
df->df_idf = id;
df->df_scope = scope;
df->df_kind = kind;
@ -52,24 +78,16 @@ MkDef(id, scope, kind)
return df;
}
InitDef()
{
/* Initialize this module. Easy, the only thing to be initialized
is "ill_df".
*/
struct idf *gen_anon_idf();
ill_df = MkDef(gen_anon_idf(), CurrentScope, D_ERROR);
ill_df->df_type = error_type;
}
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, error message.
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;
@ -133,7 +151,8 @@ define(id, scope, kind)
if (kind != D_ERROR) {
/* Avoid spurious error messages
*/
error("identifier \"%s\" already declared", id->id_text);
error("identifier \"%s\" already declared",
id->id_text);
}
return df;
@ -143,7 +162,7 @@ error("identifier \"%s\" already declared", id->id_text);
}
RemoveImports(pdf)
struct def **pdf;
register struct def **pdf;
{
/* Remove all imports from a definition module. This is
neccesary because the implementation module might import
@ -165,16 +184,15 @@ RemoveImports(pdf)
}
RemoveFromIdList(df)
struct def *df;
register struct def *df;
{
/* Remove definition "df" from the definition list
*/
register struct idf *id = df->df_idf;
register struct def *df1;
if (id->id_def == df) id->id_def = df->next;
if ((df1 = id->id_def) == df) id->id_def = df->next;
else {
df1 = id->id_def;
while (df1->next != df) {
assert(df1->next != 0);
df1 = df1->next;
@ -184,13 +202,15 @@ RemoveFromIdList(df)
}
struct def *
DeclProc(type)
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];
@ -200,85 +220,61 @@ DeclProc(type)
if (type == D_PROCHEAD) {
/* In a definition module
*/
df = define(dot.TOK_IDF, CurrentScope, type);
df = define(id, CurrentScope, type);
df->for_node = MkLeaf(Name, &dot);
sprint(buf,"%s_%s",CurrentScope->sc_name,df->df_idf->id_text);
sprint(buf,"%s_%s",CurrentScope->sc_name,id->id_text);
df->for_name = Salloc(buf, (unsigned) (strlen(buf)+1));
if (CurrVis == Defined->mod_vis) C_exp(df->for_name);
if (CurrVis == Defined->mod_vis) {
/* The current module will define this routine.
make sure the name is exported.
*/
C_exp(df->for_name);
}
}
else {
df = lookup(dot.TOK_IDF, CurrentScope);
char *name;
df = lookup(id, CurrentScope);
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;
open_scope(OPENSCOPE);
CurrentScope->sc_name = df->for_name;
df->prc_vis = CurrVis;
name = df->for_name;
DefInFront(df);
}
else {
df = define(dot.TOK_IDF, CurrentScope, type);
open_scope(OPENSCOPE);
df->prc_vis = CurrVis;
sprint(buf,"_%d_%s",++nmcount,df->df_idf->id_text);
CurrentScope->sc_name =
Salloc(buf, (unsigned)(strlen(buf)+1));
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;
}
AddModule(id)
EndProc(df, id)
register struct def *df;
struct idf *id;
{
/* Add the name of a module to the Module list. This list is
maintained to create the initialization routine of the
program/implementation module currently defined.
/* 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.
*/
static struct node *nd_end; /* to remember end of list */
register struct node *n;
extern struct node *Modules;
extern int return_occurred;
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;
}
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 && df1->df_nextinscope != df) {
/* Find definition "df"
*/
df1 = df1->df_nextinscope;
}
if (df1) {
/* It already was in the list. Remove it
*/
df1->df_nextinscope = df->df_nextinscope;
}
/* Now put it in front
*/
df->df_nextinscope = df->df_scope->sc_def;
df->df_scope->sc_def = df;
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);
}
}
@ -326,6 +322,27 @@ DefineLocalModule(id)
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;

36
lang/m2/comp/defmodule.c
View file

@ -1,9 +1,5 @@
/* D E F I N I T I O N M O D U L E S */
#ifndef NORCSID
static char *RcsId = "$Header$";
#endif
#include "debug.h"
#include <assert.h>
@ -15,23 +11,27 @@ static char *RcsId = "$Header$";
#include "scope.h"
#include "def.h"
#include "LLlex.h"
#include "Lpars.h"
#include "f_info.h"
#include "main.h"
#include "node.h"
#ifdef DEBUG
long sys_filesize();
#endif
struct idf * CurrentId;
GetFile(name)
char *name;
{
/* Try to find a file with basename "name" and extension ".def",
in the directories mentioned in "DEFPATH".
*/
char buf[256];
char buf[15];
char *strcpy(), *strcat();
strcpy(buf, name);
strncpy(buf, name, 10);
buf[10] = '\0'; /* maximum length */
strcat(buf, ".def");
if (! InsertFile(buf, DEFPATH, &(FileName))) {
@ -42,17 +42,18 @@ GetFile(name)
}
struct def *
GetDefinitionModule(id)
struct idf *id;
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".
*/
struct def *df;
static int level;
level++;
level += incr;
df = lookup(id, GlobalScope);
if (!df) {
/* Read definition module. Make an exception for SYSTEM.
@ -62,6 +63,8 @@ GetDefinitionModule(id)
}
else {
GetFile(id->id_text);
CurrentId = id;
open_scope(CLOSEDSCOPE);
DefModule();
if (level == 1) {
/* The module is directly imported by the
@ -69,12 +72,23 @@ GetDefinitionModule(id)
remember its name because we have to call
its initialization routine
*/
AddModule(id);
static struct node *nd_end; /* end of list */
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;
}
close_scope(SC_CHKFORW);
}
df = lookup(id, GlobalScope);
}
CurrentId = 0;
assert(df && df->df_kind == D_MODULE);
level--;
level -= incr;
return df;
}

5
lang/m2/comp/desig.c
View file

@ -1,9 +1,5 @@
/* D E S I G N A T O R E V A L U A T I O N */
#ifndef NORCSID
static char *RcsId = "$Header$";
#endif
/* 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"
@ -166,7 +162,6 @@ CodeFieldDesig(df, ds)
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

2
lang/m2/comp/desig.h
View file

@ -1,7 +1,5 @@
/* D E S I G N A T O R D E S C R I P T I O N S */
/* $Header$ */
/* 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.

79
lang/m2/comp/enter.c
View file

@ -1,9 +1,5 @@
/* H I G H L E V E L S Y M B O L E N T R Y */
#ifndef NORCSID
static char *RcsId = "$Header$";
#endif
#include "debug.h"
#include <alloc.h>
@ -119,7 +115,8 @@ EnterVarList(Idlist, type, local)
df->var_addrgiven = 1;
df->df_flags |= D_NOREG;
if (idlist->nd_left->nd_type != card_type) {
node_error(idlist->nd_left,"Illegal type for address");
node_error(idlist->nd_left,
"Illegal type for address");
}
df->var_off = idlist->nd_left->nd_INT;
}
@ -155,8 +152,8 @@ node_error(idlist->nd_left,"Illegal type for address");
}
EnterParamList(ppr, Idlist, type, VARp, off)
struct node *Idlist;
struct paramlist **ppr;
struct node *Idlist;
struct type *type;
int VARp;
arith *off;
@ -178,18 +175,14 @@ EnterParamList(ppr, Idlist, type, VARp, off)
for ( ; idlist; idlist = idlist->next) {
pr = new_paramlist();
pr->next = 0;
if (!*ppr) {
*ppr = pr;
}
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();
}
else df = new_def();
pr->par_def = df;
df->df_type = type;
df->df_flags = VARp;
@ -259,11 +252,11 @@ ForwModule(df, idn)
enclosing scope, but this must be done AFTER
closing this one
*/
df->for_vis = vis;
df->for_node = MkLeaf(Name, &(idn->nd_token));
close_scope(0);
vis->sc_encl = enclosing(CurrVis);
/* Here ! */
df->for_vis = vis;
df->for_node = MkLeaf(Name, &(idn->nd_token));
return vis;
}
@ -294,7 +287,6 @@ EnterExportList(Idlist, qualified)
*/
register struct node *idlist = Idlist;
register struct def *df, *df1;
register struct def *impmod;
for (;idlist; idlist = idlist->next) {
df = lookup(idlist->nd_IDF, CurrentScope);
@ -302,13 +294,16 @@ EnterExportList(Idlist, qualified)
if (!df) {
/* undefined item in export list
*/
node_error(idlist, "identifier \"%s\" not defined", idlist->nd_IDF->id_text);
node_error(idlist,
"identifier \"%s\" not defined",
idlist->nd_IDF->id_text);
continue;
}
if (df->df_flags & (D_EXPORTED|D_QEXPORTED)) {
node_error(idlist, "identifier \"%s\" occurs more than once in export list",
idlist->nd_IDF->id_text);
node_error(idlist,
"multiple occurrences of \"%s\" in export list",
idlist->nd_IDF->id_text);
}
df->df_flags |= qualified;
@ -317,13 +312,13 @@ idlist->nd_IDF->id_text);
Find all imports of the module in which this export
occurs, and export the current definition to it
*/
impmod = CurrentScope->sc_definedby->df_idf->id_def;
while (impmod) {
if (impmod->df_kind == D_IMPORT &&
impmod->imp_def == CurrentScope->sc_definedby) {
DoImport(df, impmod->df_scope);
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);
}
impmod = impmod->next;
df1 = df1->next;
}
/* Also handle the definition as if the enclosing
@ -345,7 +340,9 @@ idlist->nd_IDF->id_text);
if (df1->df_kind == D_HIDDEN &&
df->df_kind == D_TYPE) {
if (df->df_type->tp_fund != T_POINTER) {
node_error(idlist, "opaque type \"%s\" is not a pointer type", df->df_idf->id_text);
node_error(idlist,
"opaque type \"%s\" is not a pointer type",
df->df_idf->id_text);
}
assert(df1->df_type->next == NULLTYPE);
df1->df_kind = D_TYPE;
@ -388,23 +385,23 @@ EnterFromImportList(Idlist, FromDef)
vis = FromDef->mod_vis;
break;
default:
error("identifier \"%s\" does not represent a module",
FromDef->df_idf->id_text);
error("identifier \"%s\" does not represent a module",
FromDef->df_idf->id_text);
break;
}
for (; idlist; idlist = idlist->next) {
if (forwflag) {
df = ForwDef(idlist, vis->sc_scope);
}
else if (!(df = lookup(idlist->nd_IDF, vis->sc_scope))) {
node_error(idlist, "identifier \"%s\" not declared in qualifying module",
idlist->nd_IDF->id_text);
if (forwflag) df = ForwDef(idlist, vis->sc_scope);
else if (! (df = lookup(idlist->nd_IDF, vis->sc_scope))) {
node_error(idlist,
"identifier \"%s\" not declared in qualifying module",
idlist->nd_IDF->id_text);
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 qualifying module",
idlist->nd_IDF->id_text);
else if (! (df->df_flags & (D_EXPORTED|D_QEXPORTED))) {
node_error(idlist,
"identifier \"%s\" not exported from qualifying module",
idlist->nd_IDF->id_text);
df->df_flags |= D_QEXPORTED;
}
DoImport(df, CurrentScope);
@ -422,14 +419,14 @@ EnterImportList(Idlist, local)
This case is indicated by the value 0 of the "local" flag.
*/
register struct node *idlist = Idlist;
register struct def *df;
struct scopelist *vis = enclosing(CurrVis);
struct scope *sc = enclosing(CurrVis)->sc_scope;
extern struct def *GetDefinitionModule();
for (; idlist; idlist = idlist->next) {
if (local) df = ForwDef(idlist, vis->sc_scope);
else df = GetDefinitionModule(idlist->nd_IDF);
DoImport(df, CurrentScope);
DoImport(local ?
ForwDef(idlist, sc) :
GetDefinitionModule(idlist->nd_IDF) ,
CurrentScope);
}
FreeNode(Idlist);
}

4
lang/m2/comp/error.c
View file

@ -5,10 +5,6 @@
number of arguments!
*/
#ifndef NORCSID
static char *RcsId = "$Header$";
#endif
#include "errout.h"
#include "debug.h"

31
lang/m2/comp/expression.g
View file

@ -1,10 +1,6 @@
/* E X P R E S S I O N S */
{
#ifndef NORCSID
static char *RcsId = "$Header$";
#endif
#include "debug.h"
#include <alloc.h>
@ -38,22 +34,19 @@ qualident(int types;
struct node **p;
)
{
register struct def *df;
struct node *nd;
} :
IDENT { nd = MkLeaf(Name, &dot); }
[
selector(&nd)
]*
{ if (types) {
df = ill_df;
if (ChkDesignator(nd)) {
if (nd->nd_class != Def) {
{ if (types && ChkDesignator(nd)) {
if (nd->nd_class != Def) {
node_error(nd, "%s expected", str);
}
else {
df = nd->nd_def;
}
else {
register struct def *df = nd->nd_def;
if ( !((types|D_ERROR) & df->df_kind)) {
if (df->df_kind == D_FORWARD) {
node_error(nd,"%s \"%s\" not declared", str, df->df_idf->id_text);
@ -62,9 +55,8 @@ node_error(nd,"%s \"%s\" not declared", str, df->df_idf->id_text);
node_error(nd,"identifier \"%s\" is not a %s", df->df_idf->id_text, str);
}
}
}
if (pdf) *pdf = df;
}
*pdf = df;
}
if (!p) FreeNode(nd);
else *p = nd;
@ -170,10 +162,9 @@ MulOperator:
factor(register struct node **p;)
{
struct def *df;
struct node *nd;
} :
qualident(0, &df, (char *) 0, p)
qualident(0, (struct def **) 0, (char *) 0, p)
[
designator_tail(p)?
[
@ -236,10 +227,8 @@ element(struct node *nd;)
;
designator(struct node **pnd;)
{
struct def *df;
} :
qualident(0, &df, (char *) 0, pnd)
:
qualident(0, (struct def **) 0, (char *) 0, pnd)
designator_tail(pnd)?
;

2
lang/m2/comp/f_info.h
View file

@ -1,7 +1,5 @@
/* F I L E D E S C R I P T O R S T R U C T U R E */
/* $Header$ */
struct f_info {
unsigned short f_lineno;
char *f_filename;

2
lang/m2/comp/idf.c
View file

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

2
lang/m2/comp/idf.h
View file

@ -1,7 +1,5 @@
/* U S E R D E C L A R E D P A R T O F I D F */
/* $Header$ */
struct id_u {
int id_res;
struct def *id_df;

12
lang/m2/comp/input.c
View file

@ -1,17 +1,25 @@
/* 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 */
/* $Header$ */
#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>
extern struct idf *CurrentId;
AtEoIF()
{
/* Make the unstacking of input streams noticable to the
lexical analyzer
*/
if (CurrentId && ! lookup(CurrentId, GlobalScope)) {
fatal("No definition module read for \"%s\"", CurrentId->id_text);
}
return 1;
}

2
lang/m2/comp/input.h
View file

@ -1,7 +1,5 @@
/* 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 */
/* $Header$ */
#include "inputtype.h"
#define INP_NPUSHBACK 2

4
lang/m2/comp/lookup.c
View file

@ -1,9 +1,5 @@
/* L O O K U P R O U T I N E S */
#ifndef NORCSID
static char *RcsId = "$Header$";
#endif
#include "debug.h"
#include <em_arith.h>

24
lang/m2/comp/main.c
View file

@ -1,9 +1,5 @@
/* M A I N P R O G R A M */
#ifndef NORCSID
static char *RcsId = "$Header$";
#endif
#include "debug.h"
#include "ndir.h"
@ -26,7 +22,6 @@ static char *RcsId = "$Header$";
int state; /* either IMPLEMENTATION or PROGRAM */
char options[128];
int DefinitionModule;
int SYSTEMModule;
char *ProgName;
char *DEFPATH[NDIRS+1];
struct def *Defined;
@ -73,7 +68,6 @@ Compile(src, dst)
reserve(tkidf);
InitScope();
InitTypes();
InitDef();
AddStandards();
#ifdef DEBUG
if (options['l']) {
@ -186,27 +180,29 @@ AddStandards()
df->enm_next = 0;
}
do_SYSTEM()
{
/* Simulate the reading of the SYSTEM definition module
*/
char *SYSTEM = "\
/* 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("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, strlen(SYSTEM))) {
if (!InsertText(SYSTEM, sizeof(SYSTEM) - 1)) {
fatal("Could not insert text");
}
SYSTEMModule = 1;
DefModule();
SYSTEMModule = 0;
close_scope(SC_CHKFORW);
}
#ifdef DEBUG

5
lang/m2/comp/main.h
View file

@ -1,7 +1,5 @@
/* S O M E G L O B A L V A R I A B L E S */
/* $Header$ */
extern char options[]; /* indicating which options were given */
extern int DefinitionModule;
@ -9,9 +7,6 @@ extern int DefinitionModule;
module
*/
extern int SYSTEMModule;/* flag indicating that we are handling the SYSTEM
module
*/
extern struct def *Defined;
/* definition structure of module defined in this
compilation

13
lang/m2/comp/make.allocd
View file

@ -1,25 +1,26 @@
sed -e '
s:^.*[ ]ALLOCDEF[ ].*"\(.*\)".*$:\
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;\
#define new_\1() ((struct \1 *) std_alloc((char **)\&h_\1, sizeof(struct \1), \&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)))\
#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[ ].*"\(.*\)".*$:\
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), \&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)))\
#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))\
:'

4
lang/m2/comp/misc.c
View file

@ -1,9 +1,5 @@
/* M I S C E L L A N E O U S R O U T I N E S */
#ifndef NORCSID
static char *RcsId = "$Header$";
#endif
#include <alloc.h>
#include <em_arith.h>
#include <em_label.h>

2
lang/m2/comp/misc.h
View file

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

4
lang/m2/comp/node.H
View file

@ -1,7 +1,5 @@
/* N O D E O F A N A B S T R A C T P A R S E T R E E */
/* $Header$ */
struct node {
struct node *next;
#define nd_left next
@ -35,7 +33,7 @@ struct node {
#define nd_REL nd_token.TOK_REL
};
/* ALLOCDEF "node" */
/* ALLOCDEF "node" 50 */
extern struct node *MkNode(), *MkLeaf();

4
lang/m2/comp/node.c
View file

@ -1,9 +1,5 @@
/* N O D E O F A N A B S T R A C T P A R S E T R E E */
#ifndef NORCSID
static char *RcsId = "$Header$";
#endif
#include "debug.h"
#include <em_label.h>

28
lang/m2/comp/options.c
View file

@ -1,9 +1,5 @@
/* U S E R O P T I O N - H A N D L I N G */
#ifndef NORCSID
static char *RcsId = "$Header$";
#endif
#include "idfsize.h"
#include "ndir.h"
@ -17,7 +13,7 @@ extern int idfsize;
static int ndirs;
DoOption(text)
char *text;
register char *text;
{
switch(*text++) {
@ -33,12 +29,15 @@ DoOption(text)
*/
case 'M': /* maximum identifier length */
idfsize = txt2int(&text);
if (*text || idfsize <= 0)
case 'M': { /* maximum identifier length */
char *t = text; /* because &text is illegal */
idfsize = txt2int(&t);
if (*t || idfsize <= 0)
fatal("malformed -M option");
if (idfsize > IDFSIZE)
fatal("maximum identifier length is %d", IDFSIZE);
}
break;
case 'I' :
@ -53,13 +52,16 @@ DoOption(text)
arith size;
int align;
char c;
char *t;
while (c = *text++) {
size = txt2int(&text);
t = text;
size = txt2int(&t);
align = 0;
if (*text == '.') {
text++;
align = txt2int(&text);
if (*(text = t) == '.') {
t = text + 1;
align = txt2int(&t);
text = t;
}
switch (c) {
@ -104,7 +106,7 @@ DoOption(text)
int
txt2int(tp)
char **tp;
register char **tp;
{
/* the integer pointed to by *tp is read, while increasing
*tp; the resulting value is yielded.

43
lang/m2/comp/program.g
View file

@ -1,10 +1,6 @@
/* O V E R A L L S T R U C T U R E */
{
#ifndef NORCSID
static char *RcsId = "$Header$";
#endif
#include "debug.h"
#include <alloc.h>
@ -42,14 +38,11 @@ static char *RcsId = "$Header$";
ModuleDeclaration
{
struct idf *id; /* save module identifier */
register struct def *df;
struct node *exportlist = 0;
int qualified;
} :
MODULE IDENT { id = dot.TOK_IDF;
df = DefineLocalModule(id);
}
MODULE IDENT { df = DefineLocalModule(dot.TOK_IDF); }
priority(&(df->mod_priority))?
';'
import(1)*
@ -59,7 +52,7 @@ ModuleDeclaration
EnterExportList(exportlist, qualified);
}
close_scope(SC_CHKFORW|SC_CHKPROC|SC_REVERSE);
match_id(id, dot.TOK_IDF);
match_id(df->df_idf, dot.TOK_IDF);
}
;
@ -104,7 +97,7 @@ import(int local;)
df = lookfor(nd,enclosing(CurrVis),0);
FreeNode(nd);
}
else df = GetDefinitionModule(dot.TOK_IDF);
else df = GetDefinitionModule(dot.TOK_IDF, 1);
}
|
{ fromid = 0; }
@ -124,16 +117,13 @@ import(int local;)
DefinitionModule
{
register struct def *df;
struct idf *id; /* save module identifier */
struct node *exportlist;
int dummy;
} :
DEFINITION
MODULE IDENT { id = dot.TOK_IDF;
df = define(id, GlobalScope, D_MODULE);
MODULE IDENT { df = define(dot.TOK_IDF, GlobalScope, D_MODULE);
if (!Defined) Defined = df;
if (!SYSTEMModule) open_scope(CLOSEDSCOPE);
CurrentScope->sc_name = id->id_text;
CurrentScope->sc_name = df->df_idf->id_text;
df->mod_vis = CurrVis;
df->df_type = standard_type(T_RECORD, 0, (arith) 0);
df->df_type->rec_scope = df->mod_vis->sc_scope;
@ -154,15 +144,14 @@ node_warning(exportlist, "export list in definition module ignored");
/* empty */
]
definition* END IDENT
{ df = CurrentScope->sc_def;
while (df) {
{ register struct def *df1 = CurrentScope->sc_def;
while (df1) {
/* Make all definitions "QUALIFIED EXPORT" */
df->df_flags |= D_QEXPORTED;
df = df->df_nextinscope;
df1->df_flags |= D_QEXPORTED;
df1 = df1->df_nextinscope;
}
close_scope(SC_CHKFORW);
DefinitionModule--;
match_id(id, dot.TOK_IDF);
match_id(df->df_idf, dot.TOK_IDF);
}
'.'
;
@ -206,19 +195,17 @@ Semicolon:
ProgramModule
{
struct idf *id;
struct def *GetDefinitionModule();
register struct def *df;
} :
MODULE
IDENT { id = dot.TOK_IDF;
if (state == IMPLEMENTATION) {
df = GetDefinitionModule(id);
IDENT { if (state == IMPLEMENTATION) {
df = GetDefinitionModule(dot.TOK_IDF, 0);
CurrVis = df->mod_vis;
RemoveImports(&(CurrentScope->sc_def));
}
else {
Defined = df = define(id, CurrentScope, D_MODULE);
Defined = df = define(dot.TOK_IDF, CurrentScope, D_MODULE);
open_scope(CLOSEDSCOPE);
df->mod_vis = CurrVis;
CurrentScope->sc_name = "_M2M";
@ -229,13 +216,15 @@ ProgramModule
';' import(0)*
block(&(df->mod_body)) IDENT
{ close_scope(SC_CHKFORW|SC_CHKPROC|SC_REVERSE);
match_id(id, dot.TOK_IDF);
match_id(df->df_idf, dot.TOK_IDF);
}
'.'
;
Module:
{ open_scope(CLOSEDSCOPE); }
DefinitionModule
{ close_scope(SC_CHKFORW); }
|
[
IMPLEMENTATION { state = IMPLEMENTATION; }

101
lang/m2/comp/scope.C
View file

@ -1,9 +1,5 @@
/* S C O P E M E C H A N I S M */
#ifndef NORCSID
static char *RcsId = "$Header$";
#endif
#include "debug.h"
#include <assert.h>
@ -23,9 +19,9 @@ struct scopelist *CurrVis;
extern int proclevel;
static struct scopelist *PervVis;
/* STATICALLOCDEF "scope" */
/* STATICALLOCDEF "scope" 10 */
/* STATICALLOCDEF "scopelist" */
/* STATICALLOCDEF "scopelist" 10 */
open_scope(scopetype)
{
@ -36,15 +32,14 @@ open_scope(scopetype)
assert(scopetype == OPENSCOPE || scopetype == CLOSEDSCOPE);
clear((char *) sc, sizeof (struct scope));
sc->sc_scopeclosed = scopetype == CLOSEDSCOPE;
sc->sc_level = proclevel;
if (scopetype == OPENSCOPE) {
ls->next = CurrVis;
}
else ls->next = PervVis;
ls->sc_scope = sc;
ls->sc_encl = CurrVis;
if (scopetype == OPENSCOPE) {
ls->next = ls->sc_encl;
}
else ls->next = PervVis;
CurrVis = ls;
}
@ -71,7 +66,7 @@ struct forwards {
struct type *fo_ptyp;
};
/* STATICALLOCDEF "forwards" */
/* STATICALLOCDEF "forwards" 5 */
Forward(tk, ptp)
struct node *tk;
@ -83,11 +78,12 @@ Forward(tk, ptp)
same scope.
*/
register struct forwards *f = new_forwards();
register struct scope *sc = CurrentScope;
f->fo_tok = tk;
f->fo_ptyp = ptp;
f->next = CurrentScope->sc_forw;
CurrentScope->sc_forw = f;
f->next = sc->sc_forw;
sc->sc_forw = f;
}
STATIC
@ -95,13 +91,14 @@ chk_proc(df)
register struct def *df;
{
/* Called at scope closing. Check all definitions, and if one
is a D_PROCHEAD, the procedure was not defined
is a D_PROCHEAD, the procedure was not defined.
*/
while (df) {
if (df->df_kind == D_PROCHEAD) {
/* A not defined procedure
*/
error("procedure \"%s\" not defined", df->df_idf->id_text);
error("procedure \"%s\" not defined",
df->df_idf->id_text);
FreeNode(df->for_node);
}
df = df->df_nextinscope;
@ -110,46 +107,48 @@ error("procedure \"%s\" not defined", df->df_idf->id_text);
STATIC
chk_forw(pdf)
register struct def **pdf;
struct def **pdf;
{
/* Called at scope close. Look for all forward definitions and
if the scope was a closed scope, give an error message for
them, and otherwise move them to the enclosing scope.
*/
while (*pdf) {
if ((*pdf)->df_kind & (D_FORWARD|D_FORWMODULE)) {
register struct def *df;
while (df = *pdf) {
if (df->df_kind & (D_FORWARD|D_FORWMODULE)) {
/* These definitions must be found in
the enclosing closed scope, which of course
may be the scope that is now closed!
*/
struct def *df1 = (*pdf)->df_nextinscope;
if (scopeclosed(CurrentScope)) {
/* Indeed, the scope was a closed
scope, so give error message
*/
node_error((*pdf)->for_node, "identifier \"%s\" has not been declared",
(*pdf)->df_idf->id_text);
FreeNode((*pdf)->for_node);
pdf = &(*pdf)->df_nextinscope;
node_error(df->for_node, "identifier \"%s\" has not been declared",
df->df_idf->id_text);
FreeNode(df->for_node);
}
else { /* This scope was an open scope.
else {
/* This scope was an open scope.
Maybe the definitions are in the
enclosing scope?
*/
struct scopelist *ls;
ls = nextvisible(CurrVis);
if ((*pdf)->df_kind == D_FORWMODULE) {
(*pdf)->for_vis->next = ls;
register struct scopelist *ls =
nextvisible(CurrVis);
struct def *df1 = df->df_nextinscope;
if (df->df_kind == D_FORWMODULE) {
df->for_vis->next = ls;
}
(*pdf)->df_nextinscope = ls->sc_scope->sc_def;
ls->sc_scope->sc_def = *pdf;
(*pdf)->df_scope = ls->sc_scope;
df->df_nextinscope = ls->sc_scope->sc_def;
ls->sc_scope->sc_def = df;
df->df_scope = ls->sc_scope;
*pdf = df1;
continue;
}
}
else pdf = &(*pdf)->df_nextinscope;
pdf = &df->df_nextinscope;
}
}
@ -163,20 +162,17 @@ rem_forwards(fo)
if (fo->next) rem_forwards(fo->next);
df = lookfor(fo->fo_tok, CurrVis, 0);
if (df->df_kind == D_ERROR) {
node_error(fo->fo_tok, "identifier \"%s\" not declared",
df->df_idf->id_text);
}
else if (df->df_kind != D_TYPE) {
node_error(fo->fo_tok, "identifier \"%s\" not a type",
df->df_idf->id_text);
if (! is_type(df)) {
node_error(fo->fo_tok,
"identifier \"%s\" does not represent a type",
df->df_idf->id_text);
}
fo->fo_ptyp->next = df->df_type;
free_forwards(fo);
}
Reverse(pdf)
register struct def **pdf;
struct def **pdf;
{
/* Reverse the order in the list of definitions in a scope.
This is neccesary because this list is built in reverse.
@ -188,23 +184,18 @@ Reverse(pdf)
df = 0;
df1 = *pdf;
while (df1) {
if (df1->df_kind & INTERESTING) break;
df1 = df1->df_nextinscope;
}
if (!(*pdf = df1)) return;
while (df1) {
*pdf = df1;
df1 = df1->df_nextinscope;
while (df1) {
if (df1->df_kind & INTERESTING) break;
if (df1->df_kind & INTERESTING) {
struct def *prev = df;
df = df1;
df1 = df1->df_nextinscope;
df->df_nextinscope = prev;
}
(*pdf)->df_nextinscope = df;
df = *pdf;
else df1 = df1->df_nextinscope;
}
*pdf = df;
}
close_scope(flag)

2
lang/m2/comp/scope.h
View file

@ -1,7 +1,5 @@
/* S C O P E M E C H A N I S M */
/* $Header$ */
#define OPENSCOPE 0 /* Indicating an open scope */
#define CLOSEDSCOPE 1 /* Indicating a closed scope (module) */

2
lang/m2/comp/standards.h
View file

@ -1,7 +1,5 @@
/* S T A N D A R D P R O C E D U R E S A N D F U N C T I O N S */
/* $Header$ */
#define S_ABS 1
#define S_CAP 2
#define S_CHR 3

36
lang/m2/comp/statement.g
View file

@ -1,10 +1,6 @@
/* S T A T E M E N T S */
{
#ifndef NORCSID
static char *RcsId = "$Header$";
#endif
#include <assert.h>
#include <em_arith.h>
#include <em_label.h>
@ -22,6 +18,7 @@ static int loopcount = 0; /* Count nested loops */
statement(register struct node **pnd;)
{
register struct node *nd;
extern int return_occurred;
} :
/*
* This part is not in the reference grammar. The reference grammar
@ -64,6 +61,7 @@ statement(register struct node **pnd;)
}
|
ReturnStatement(pnd)
{ return_occurred = 1; }
|
/* empty */ { *pnd = 0; }
;
@ -88,9 +86,12 @@ StatementSequence(register struct node **pnd;)
[ %persistent
';' statement(&nd)
{ if (nd) {
*pnd = MkNode(Link, *pnd, nd, &dot);
(*pnd)->nd_symb = ';';
pnd = &((*pnd)->nd_right);
register struct node *nd1 =
MkNode(Link, *pnd, nd, &dot);
*pnd = nd1;
nd1->nd_symb = ';';
pnd = &(nd1->nd_right);
}
}
]*
@ -178,31 +179,29 @@ RepeatStatement(struct node **pnd;)
ForStatement(struct node **pnd;)
{
register struct node *nd;
register struct node *nd, *nd1;
struct node *dummy;
}:
FOR { *pnd = nd = MkLeaf(Stat, &dot); }
IDENT { nd->nd_IDF = dot.TOK_IDF; }
BECOMES { nd->nd_left = MkLeaf(Stat, &dot);
nd = nd->nd_left;
}
expression(&(nd->nd_left))
BECOMES { nd->nd_left = nd1 = MkLeaf(Stat, &dot); }
expression(&(nd1->nd_left))
TO
expression(&(nd->nd_right))
expression(&(nd1->nd_right))
[
BY
ConstExpression(&dummy)
{ if (!(dummy->nd_type->tp_fund & T_INTORCARD)) {
error("illegal type in BY clause");
}
nd->nd_INT = dummy->nd_INT;
nd1->nd_INT = dummy->nd_INT;
FreeNode(dummy);
}
|
{ nd->nd_INT = 1; }
{ nd1->nd_INT = 1; }
]
DO
StatementSequence(&((*pnd)->nd_right))
StatementSequence(&(nd->nd_right))
END
;
@ -227,12 +226,9 @@ ReturnStatement(struct node **pnd;)
{
register struct def *df = CurrentScope->sc_definedby;
register struct node *nd;
extern int return_occurred;
} :
RETURN { *pnd = nd = MkLeaf(Stat, &dot);
return_occurred = 1;
}
RETURN { *pnd = nd = MkLeaf(Stat, &dot); }
[
expression(&(nd->nd_right))
{ if (scopeclosed(CurrentScope)) {

10
lang/m2/comp/tmpvar.C
View file

@ -1,9 +1,5 @@
/* T E M P O R A R Y V A R I A B L E S */
#ifndef NORCSID
static char *RcsId = "$Header$";
#endif
/* Code for the allocation and de-allocation of temporary variables,
allowing re-use.
The routines use "ProcScope" instead of "CurrentScope", because
@ -29,7 +25,7 @@ struct tmpvar {
arith t_offset; /* offset from LocalBase */
};
/* STATICALLOCDEF "tmpvar" */
/* STATICALLOCDEF "tmpvar" 10 */
static struct tmpvar *TmpInts, /* for integer temporaries */
*TmpPtrs; /* for pointer temporaries */
@ -47,7 +43,7 @@ TmpOpen(sc) struct scope *sc;
arith
NewInt()
{
arith offset;
register arith offset;
register struct tmpvar *tmp;
if (!TmpInts) {
@ -67,7 +63,7 @@ NewInt()
arith
NewPtr()
{
arith offset;
register arith offset;
register struct tmpvar *tmp;
if (!TmpPtrs) {

4
lang/m2/comp/tokenname.c
View file

@ -1,9 +1,5 @@
/* T O K E N D E F I N I T I O N S */
#ifndef NORCSID
static char *RcsId = "$Header$";
#endif
#include "tokenname.h"
#include "Lpars.h"
#include "idf.h"

2
lang/m2/comp/tokenname.h
View file

@ -1,7 +1,5 @@
/* T O K E N N A M E S T R U C T U R E */
/* $Header$ */
struct tokenname { /* Used for defining the name of a
token as identified by its symbol
*/

8
lang/m2/comp/type.H
View file

@ -1,7 +1,5 @@
/* T Y P E D E S C R I P T O R S T R U C T U R E */
/* $Header$ */
struct paramlist { /* structure for parameterlist of a PROCEDURE */
struct paramlist *next;
struct def *par_def; /* "df" of parameter */
@ -9,7 +7,7 @@ struct paramlist { /* structure for parameterlist of a PROCEDURE */
#define TypeOfParam(xpar) ((xpar)->par_def->df_type)
};
/* ALLOCDEF "paramlist" */
/* ALLOCDEF "paramlist" 20 */
struct enume {
struct def *en_enums; /* Definitions of enumeration literals */
@ -86,7 +84,7 @@ struct type {
} tp_value;
};
/* ALLOCDEF "type" */
/* ALLOCDEF "type" 50 */
extern struct type
*bool_type,
@ -125,11 +123,11 @@ extern arith
align(); /* type.c */
struct type
*create_type(),
*construct_type(),
*standard_type(),
*set_type(),
*subr_type(),
*proc_type(),
*RemoveEqual(); /* All from type.c */
#define NULLTYPE ((struct type *) 0)

85
lang/m2/comp/type.c
View file

@ -1,9 +1,5 @@
/* T Y P E D E F I N I T I O N M E C H A N I S M */
#ifndef NORCSID
static char *RcsId = "$Header$";
#endif
#include "target_sizes.h"
#include "debug.h"
#include "maxset.h"
@ -66,21 +62,6 @@ struct type *h_type;
int cnt_type;
#endif
struct type *
create_type(fund)
int fund;
{
/* A brand new struct type is created, and its tp_fund set
to fund.
*/
register struct type *ntp = new_type();
clear((char *)ntp, sizeof(struct type));
ntp->tp_fund = fund;
return ntp;
}
struct type *
construct_type(fund, tp)
int fund;
@ -89,9 +70,9 @@ construct_type(fund, tp)
/* fund must be a type constructor.
The pointer to the constructed type is returned.
*/
register struct type *dtp = create_type(fund);
register struct type *dtp = new_type();
switch (fund) {
switch (dtp->tp_fund = fund) {
case T_PROCEDURE:
case T_POINTER:
case T_HIDDEN:
@ -135,8 +116,9 @@ standard_type(fund, align, size)
int align;
arith size;
{
register struct type *tp = create_type(fund);
register struct type *tp = new_type();
tp->tp_fund = fund;
tp->tp_align = align;
tp->tp_size = size;
@ -167,10 +149,6 @@ InitTypes()
fatal("long real size smaller than real size");
}
if (!pointer_size || pointer_size % word_size != 0) {
fatal("illegal pointer size");
}
/* character type
*/
char_type = standard_type(T_CHAR, 1, (arith) 1);
@ -303,6 +281,19 @@ subr_type(lb, ub)
return res;
}
struct type *
proc_type(result_type, parameters, n_bytes_params)
struct type *result_type;
struct paramlist *parameters;
arith n_bytes_params;
{
register struct type *tp = construct_type(T_PROCEDURE, result_type);
tp->prc_params = parameters;
tp->prc_nbpar = n_bytes_params;
return tp;
}
genrck(tp)
register struct type *tp;
{
@ -310,20 +301,22 @@ genrck(tp)
neccessary. Return its label.
*/
arith lb, ub;
label ol, l;
register label ol;
int newlabel = 0;
getbounds(tp, &lb, &ub);
if (tp->tp_fund == T_SUBRANGE) {
if (!(ol = tp->sub_rck)) {
tp->sub_rck = l = ++data_label;
tp->sub_rck = ol = ++data_label;
newlabel = 1;
}
}
else if (!(ol = tp->enm_rck)) {
tp->enm_rck = l = ++data_label;
tp->enm_rck = ol = ++data_label;
newlabel = 1;
}
if (!ol) {
ol = l;
if (newlabel) {
C_df_dlb(ol);
C_rom_cst(lb);
C_rom_cst(ub);
@ -385,7 +378,7 @@ ArrayElSize(tp)
Also make sure that its size is either a dividor of the word_size,
or a multiple of it.
*/
arith algn;
register arith algn;
if (tp->tp_fund == T_ARRAY) ArraySizes(tp);
algn = align(tp->tp_size, tp->tp_align);
@ -446,6 +439,7 @@ FreeType(tp)
while (pr) {
pr1 = pr;
pr = pr->next;
free_def(pr1->par_def);
free_paramlist(pr1);
}
@ -520,21 +514,14 @@ DumpType(tp)
{
if (!tp) return;
print(" a:%d; s:%ld;", tp->tp_align, (long) tp->tp_size);
if (tp->next && tp->tp_fund != T_POINTER) {
/* Avoid printing recursive types!
*/
print(" n:(");
DumpType(tp->next);
print(")");
}
print("align:%d; size:%ld;", tp->tp_align, (long) tp->tp_size);
print(" f:");
print(" fund:");
switch(tp->tp_fund) {
case T_RECORD:
print("RECORD"); break;
case T_ENUMERATION:
print("ENUMERATION; n:%d", tp->enm_ncst); break;
print("ENUMERATION; ncst:%d", tp->enm_ncst); break;
case T_INTEGER:
print("INTEGER"); break;
case T_CARDINAL:
@ -562,7 +549,7 @@ DumpType(tp)
print("PROCEDURE");
if (par) {
print("; p:");
print("(");
while(par) {
if (IsVarParam(par)) print("VAR ");
DumpType(TypeOfParam(par));
@ -573,11 +560,12 @@ DumpType(tp)
}
case T_ARRAY:
print("ARRAY");
print("; el:");
print("; element:");
DumpType(tp->arr_elem);
print("; index:");
DumpType(tp->next);
break;
print(";");
return;
case T_STRING:
print("STRING"); break;
case T_INTORCARD:
@ -585,6 +573,13 @@ DumpType(tp)
default:
crash("DumpType");
}
if (tp->next && tp->tp_fund != T_POINTER) {
/* Avoid printing recursive types!
*/
print(" next:(");
DumpType(tp->next);
print(")");
}
print(";");
}
#endif

4
lang/m2/comp/typequiv.c
View file

@ -1,9 +1,5 @@
/* T Y P E E Q U I V A L E N C E */
#ifndef NORCSID
static char *RcsId = "$Header$";
#endif
/* Routines for testing type equivalence, type compatibility, and
assignment compatibility
*/

109
lang/m2/comp/walk.c
View file

@ -1,9 +1,5 @@
/* P A R S E T R E E W A L K E R */
#ifndef NORCSID
static char *RcsId = "$Header$";
#endif
/* Routines to walk through parts of the parse tree, and generate
code for these parts.
*/
@ -103,11 +99,6 @@ WalkModule(module)
C_loe_dlb(l1, (arith) 0);
C_zne(RETURN_LABEL);
C_ine_dlb(l1, (arith) 0);
/* Prevent this module from calling its own
initialization routine
*/
assert(nd->nd_IDF == module->df_idf);
nd = nd->next;
}
for (; nd; nd = nd->next) {
@ -415,17 +406,16 @@ WalkStat(nd, exit_label)
break;
case IF:
{ label l1, l2, l3;
{ label l1 = ++text_label, l3 = ++text_label;
l1 = ++text_label;
l2 = ++text_label;
l3 = ++text_label;
ExpectBool(left, l3, l1);
assert(right->nd_symb == THEN);
C_df_ilb(l3);
WalkNode(right->nd_left, exit_label);
if (right->nd_right) { /* ELSE part */
label l2 = ++text_label;
C_bra(l2);
C_df_ilb(l1);
WalkNode(right->nd_right, exit_label);
@ -440,73 +430,72 @@ WalkStat(nd, exit_label)
break;
case WHILE:
{ label l1, l2, l3;
{ label loop = ++text_label,
exit = ++text_label,
dummy = ++text_label;
l1 = ++text_label;
l2 = ++text_label;
l3 = ++text_label;
C_df_ilb(l1);
ExpectBool(left, l3, l2);
C_df_ilb(l3);
C_df_ilb(loop);
ExpectBool(left, dummy, exit);
C_df_ilb(dummy);
WalkNode(right, exit_label);
C_bra(l1);
C_df_ilb(l2);
C_bra(loop);
C_df_ilb(exit);
break;
}
case REPEAT:
{ label l1, l2;
{ label loop = ++text_label, exit = ++text_label;
l1 = ++text_label;
l2 = ++text_label;
C_df_ilb(l1);
C_df_ilb(loop);
WalkNode(left, exit_label);
ExpectBool(right, l2, l1);
C_df_ilb(l2);
ExpectBool(right, exit, loop);
C_df_ilb(exit);
break;
}
case LOOP:
{ label l1, l2;
{ label loop = ++text_label, exit = ++text_label;
l1 = ++text_label;
l2 = ++text_label;
C_df_ilb(l1);
WalkNode(right, l2);
C_bra(l1);
C_df_ilb(l2);
C_df_ilb(loop);
WalkNode(right, exit);
C_bra(loop);
C_df_ilb(exit);
break;
}
case FOR:
{
arith tmp = 0;
struct node *fnd;
register struct node *fnd;
label l1 = ++text_label;
label l2 = ++text_label;
if (! DoForInit(nd, left)) break;
fnd = left->nd_right;
if (fnd->nd_class != Value) {
/* Upperbound not constant.
The expression may only be evaluated once,
so generate a temporary for it
*/
CodePExpr(fnd);
tmp = NewInt();
C_stl(tmp);
}
C_bra(l1);
C_df_ilb(l2);
C_df_ilb(l1);
C_dup(int_size);
if (tmp) C_lol(tmp); else C_loc(fnd->nd_INT);
if (left->nd_INT > 0) {
C_bgt(l2);
}
else C_blt(l2);
RangeCheck(nd->nd_type, int_type);
CodeDStore(nd);
WalkNode(right, exit_label);
CodePExpr(nd);
C_loc(left->nd_INT);
C_adi(int_size);
C_df_ilb(l1);
C_dup(int_size);
if (tmp) C_lol(tmp); else C_loc(fnd->nd_INT);
if (left->nd_INT > 0) {
C_ble(l2);
}
else C_bge(l2);
C_bra(l1);
C_df_ilb(l2);
C_asp(int_size);
if (tmp) FreeInt(tmp);
}
@ -517,7 +506,6 @@ WalkStat(nd, exit_label)
struct scopelist link;
struct withdesig wds;
struct desig ds;
arith tmp = 0;
if (! WalkDesignator(left, &ds)) break;
if (left->nd_type->tp_fund != T_RECORD) {
@ -532,7 +520,7 @@ WalkStat(nd, exit_label)
ds.dsg_kind = DSG_FIXED;
/* Create a designator structure for the temporary.
*/
ds.dsg_offset = tmp = NewPtr();
ds.dsg_offset = NewPtr();
ds.dsg_name = 0;
CodeStore(&ds, pointer_size);
ds.dsg_kind = DSG_PFIXED;
@ -544,7 +532,7 @@ WalkStat(nd, exit_label)
WalkNode(right, exit_label);
CurrVis = link.next;
WithDesigs = wds.w_next;
FreePtr(tmp);
FreePtr(ds.dsg_offset);
break;
}
@ -648,12 +636,13 @@ DoForInit(nd, left)
nd->nd_symb = IDENT;
if (! ChkVariable(nd) ||
! ChkExpression(left->nd_left) ||
! WalkExpr(left->nd_left) ||
! ChkExpression(left->nd_right)) return 0;
df = nd->nd_def;
if (df->df_kind == D_FIELD) {
node_error(nd, "FOR-loop variable may not be a field of a record");
node_error(nd,
"FOR-loop variable may not be a field of a record");
return 0;
}
@ -665,14 +654,15 @@ DoForInit(nd, left)
if (df->df_scope != CurrentScope) {
register struct scopelist *sc = CurrVis;
while (sc && sc->sc_scope != df->df_scope) {
for (;;) {
if (!sc) {
node_error(nd,
"FOR-loop variable may not be imported");
return 0;
}
if (sc->sc_scope == df->df_scope) break;
sc = nextvisible(sc);
}
if (!sc) {
node_error(nd, "FOR-loop variable may not be imported");
return 0;
}
}
if (df->df_type->tp_size > word_size ||
@ -691,8 +681,6 @@ DoForInit(nd, left)
node_warning(nd, "old-fashioned! compatibility required in FOR statement");
}
CodePExpr(left->nd_left);
return 1;
}
@ -703,11 +691,12 @@ DoAssign(nd, left, right)
/* May we do it in this order (expression first) ???
The reference manual sais nothing about it, but the book does:
it sais that the left hand side is evaluated first.
DAMN THE BOOK!
*/
struct desig dsl, dsr;
if (! ChkExpression(right)) return;
if (! ChkVariable(left)) return;
if (! ChkExpression(right) || ! ChkVariable(left)) return;
if (right->nd_symb == STRING) TryToString(right, left->nd_type);
dsr = InitDesig;
CodeExpr(right, &dsr, NO_LABEL, NO_LABEL);

2
lang/m2/comp/walk.h
View file

@ -1,7 +1,5 @@
/* P A R S E T R E E W A L K E R */
/* $Header$ */
/* Definition of WalkNode macro
*/