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

newer version

Browse source
This commit is contained in:
ceriel 1986-04-08 18:15:46 +00:00
parent 3de71150a6
commit 629b8fdb88
17 changed files with 543 additions and 170 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -223,6 +223,7 @@ again:
register char *np = &buf[1];
/* allow a '-' to be added */
buf[0] = '-';
*np++ = ch;
LoadChar(ch);

20
lang/m2/comp/Makefile
View file

@ -18,7 +18,7 @@ LOBJ = tokenfile.o program.o declar.o expression.o statement.o
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
cstoper.o chk_expr.o
OBJ = $(COBJ) $(LOBJ) Lpars.o
GENFILES= tokenfile.c \
program.c declar.c expression.c statement.c \
@ -39,6 +39,9 @@ main: $(OBJ) Makefile
clean:
rm -f $(OBJ) $(GENFILES) LLfiles
lint: LLfiles lintlist
lint $(INCLUDES) `cat lintlist`
tokenfile.g: tokenname.c make.tokfile
make.tokfile <tokenname.c >tokenfile.g
@ -74,23 +77,24 @@ LLlex.o: LLlex.h Lpars.h class.h f_info.h idf.h input.h
LLmessage.o: LLlex.h Lpars.h idf.h
char.o: class.h
error.o: LLlex.h f_info.h input.h main.h node.h
main.o: LLlex.h Lpars.h debug.h def.h f_info.h idf.h input.h main.h scope.h standards.h type.h
main.o: LLlex.h Lpars.h debug.h def.h f_info.h idf.h input.h scope.h standards.h tokenname.h type.h
symbol2str.o: Lpars.h
tokenname.o: Lpars.h idf.h tokenname.h
idf.o: idf.h
input.o: f_info.h input.h
type.o: LLlex.h Lpars.h def.h def_sizes.h idf.h node.h type.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 main.h scope.h type.h
misc.o: LLlex.h f_info.h idf.h misc.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 def.h idf.h node.h scope.h type.h
defmodule.o: LLlex.h def.h f_info.h idf.h input.h scope.h
defmodule.o: LLlex.h debug.h def.h f_info.h idf.h input.h scope.h
typequiv.o: Lpars.h def.h type.h
node.o: LLlex.h debug.h def.h main.h node.h type.h
cstoper.o: Lpars.h def_sizes.h idf.h node.h type.h
node.o: LLlex.h debug.h def.h node.h type.h
cstoper.o: LLlex.h Lpars.h def_sizes.h idf.h node.h type.h
chk_expr.o: LLlex.h Lpars.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 idf.h main.h node.h scope.h type.h
declar.o: LLlex.h Lpars.h def.h idf.h misc.h node.h scope.h type.h
expression.o: LLlex.h Lpars.h debug.h def.h idf.h main.h node.h scope.h
expression.o: LLlex.h Lpars.h const.h debug.h def.h idf.h node.h scope.h type.h
statement.o: LLlex.h Lpars.h node.h
Lpars.o: Lpars.h

379
lang/m2/comp/chk_expr.c Normal file
View file

@ -0,0 +1,379 @@
/* E X P R E S S I O N C H E C K I N G */
static char *RcsId = "$Header$";
/* Check expressions, and try to evaluate them as far as possible.
*/
#include <em_arith.h>
#include <em_label.h>
#include <assert.h>
#include "idf.h"
#include "type.h"
#include "def.h"
#include "LLlex.h"
#include "node.h"
#include "Lpars.h"
#include "scope.h"
int
chk_expr(expp, const)
register struct node *expp;
{
/* Check the expression indicated by expp for semantic errors,
identify identifiers used in it, replace constants by
their value.
*/
switch(expp->nd_class) {
case Oper:
return chk_expr(expp->nd_left, const) &&
chk_expr(expp->nd_right, const) &&
chk_oper(expp, const);
case Uoper:
return chk_expr(expp->nd_right, const) &&
chk_uoper(expp, const);
case Value:
switch(expp->nd_symb) {
case REAL:
case STRING:
case INTEGER:
return 1;
default:
assert(0);
}
break;
case Xset:
return chk_set(expp, const);
case Name:
return chk_name(expp, const);
case Call:
return chk_call(expp, const);
case Link:
return chk_name(expp, const);
}
/*NOTREACHED*/
}
int
chk_set(expp, const)
register struct node *expp;
{
/* ??? */
return 1;
}
int
chk_call(expp, const)
register struct node *expp;
{
/* ??? */
return 1;
}
struct def *
findname(expp)
register struct node *expp;
{
/* Find the name indicated by "expp", starting from the current
scope.
*/
register struct def *df;
struct def *lookfor();
register struct node *nd;
int scope;
int module;
if (expp->nd_class == Name) {
return lookfor(expp, CurrentScope, 1);
}
assert(expp->nd_class == Link && expp->nd_symb == '.');
assert(expp->nd_left->nd_class == Name);
df = lookfor(expp->nd_left, CurrentScope, 1);
if (df->df_kind == D_ERROR) return df;
nd = expp;
while (nd->nd_class == Link) {
struct node *nd1;
if (!(scope = has_selectors(df))) {
node_error(nd, "identifier \"%s\" has no selectors",
df->df_idf->id_text);
return ill_df;
}
nd = nd->nd_right;
if (nd->nd_class == Name) nd1 = nd;
else nd1 = nd->nd_left;
module = (df->df_kind == D_MODULE);
df = lookup(nd1->nd_IDF, scope);
if (!df) {
id_not_declared(nd1);
return ill_df;
}
if (module && !(df->df_flags&(D_EXPORTED|D_QEXPORTED))) {
node_error(nd1, "identifier \"%s\" not exprted from qualifying module",
df->df_idf->id_text);
}
}
return df;
}
int
chk_name(expp, const)
register struct node *expp;
{
register struct def *df;
int retval = 1;
df = findname(expp);
if (df->df_kind == D_ERROR) {
retval = 0;
}
expp->nd_type = df->df_type;
if (df->df_kind == D_ENUM || df->df_kind == D_CONST) {
if (expp->nd_left) FreeNode(expp->nd_left);
if (expp->nd_right) FreeNode(expp->nd_right);
if (df->df_kind == D_ENUM) {
expp->nd_left = expp->nd_right = 0;
expp->nd_class = Value;
expp->nd_INT = df->enm_val;
expp->nd_symb = INTEGER;
}
else if (df->df_kind == D_CONST) {
*expp = *(df->con_const);
}
}
else if (const) {
node_error(expp, "constant expected");
retval = 0;
}
return retval;
}
int
chk_oper(expp, const)
register struct node *expp;
{
/* Check a binary operation. If "const" is set, also check
that it is constant.
The code is ugly !
*/
register struct type *tpl = expp->nd_left->nd_type;
register struct type *tpr = expp->nd_right->nd_type;
char *symbol2str();
int errval = 1;
if (tpl == intorcard_type) {
if (tpr == int_type || tpr == card_type) {
expp->nd_left->nd_type = tpl = tpr;
}
}
if (tpr == intorcard_type) {
if (tpl == int_type || tpl == card_type) {
expp->nd_right->nd_type = tpr = tpl;
}
}
if (expp->nd_symb == IN) {
/* Handle this one specially */
expp->nd_type == bool_type;
if (tpr->tp_fund != SET) {
node_error(expp, "RHS of IN operator not a SET type");
return 0;
}
if (!TstCompat(tpl, tpr->next)) {
node_error(expp, "IN operator: type of LHS not compatible with element type of RHS");
return 0;
}
return 1;
}
if (tpl->tp_fund == SUBRANGE) tpl = tpl->next;
expp->nd_type = tpl;
if (!TstCompat(tpl, tpr)) {
node_error(expp, "Incompatible types for operator \"%s\"", symbol2str(expp->nd_symb));
return 0;
}
switch(expp->nd_symb) {
case '+':
case '-':
case '*':
switch(tpl->tp_fund) {
case INTEGER:
case INTORCARD:
case CARDINAL:
case LONGINT:
case SET:
if (expp->nd_left->nd_class == Value &&
expp->nd_right->nd_class == Value) {
cstbin(expp);
}
return 1;
case REAL:
case LONGREAL:
if (const) {
errval = 2;
break;
}
return 1;
}
break;
case '/':
switch(tpl->tp_fund) {
case SET:
if (expp->nd_left->nd_class == Value &&
expp->nd_right->nd_class == Value) {
cstbin(expp);
}
return 1;
case REAL:
case LONGREAL:
if (const) {
errval = 2;
break;
}
return 1;
}
break;
case DIV:
case MOD:
switch(tpl->tp_fund) {
case INTEGER:
case INTORCARD:
case CARDINAL:
case LONGINT:
if (expp->nd_left->nd_class == Value &&
expp->nd_right->nd_class == Value) {
cstbin(expp);
}
return 1;
}
break;
case OR:
case AND:
if (tpl == bool_type) {
if (expp->nd_left->nd_class == Value &&
expp->nd_right->nd_class == Value) {
cstbin(expp);
}
return 1;
}
errval = 3;
break;
case '=':
case '#':
case GREATEREQUAL:
case LESSEQUAL:
case '<':
case '>':
switch(tpl->tp_fund) {
case SET:
if (expp->nd_symb == '<' || expp->nd_symb == '>') {
break;
}
case INTEGER:
case INTORCARD:
case LONGINT:
case CARDINAL:
case ENUMERATION: /* includes boolean */
case CHAR:
if (expp->nd_left->nd_class == Value &&
expp->nd_right->nd_class == Value) {
cstbin(expp);
}
return 1;
case POINTER:
if (!(expp->nd_symb == '=' || expp->nd_symb == '#')) {
break;
}
/* Fall through */
case REAL:
case LONGREAL:
if (const) {
errval = 2;
break;
}
return 1;
}
default:
assert(0);
}
switch(errval) {
case 1:
node_error(expp,"Operator \"%s\": illegal operand type(s)", symbol2str(expp->nd_symb));
break;
case 2:
node_error(expp, "Expression not constant");
break;
case 3:
node_error(expp, "BOOLEAN type(s) expected");
break;
}
return 0;
}
int
chk_uoper(expp, const)
register struct node *expp;
{
/* Check an unary operation. If "const" is set, also check that
it can be evaluated compile-time.
*/
register struct type *tpr = expp->nd_right->nd_type;
if (tpr->tp_fund == SUBRANGE) tpr = tpr->next;
expp->nd_type = tpr;
switch(expp->nd_symb) {
case '+':
switch(tpr->tp_fund) {
case INTEGER:
case LONGINT:
case REAL:
case LONGREAL:
case CARDINAL:
case INTORCARD:
expp->nd_token = expp->nd_right->nd_token;
FreeNode(expp->nd_right);
expp->nd_right = 0;
return 1;
}
break;
case '-':
switch(tpr->tp_fund) {
case INTEGER:
case LONGINT:
case INTORCARD:
if (expp->nd_right->nd_class == Value) {
cstunary(expp);
}
return 1;
case REAL:
case LONGREAL:
if (expp->nd_right->nd_class == Value) {
expp->nd_token = expp->nd_right->nd_token;
if (*(expp->nd_REL) == '-') {
expp->nd_REL++;
}
else expp->nd_REL--;
FreeNode(expp->nd_right);
expp->nd_right = 0;
}
return 1;
}
break;
case NOT:
if (tpr == bool_type) {
if (expp->nd_right->nd_class == Value) {
cstunary(expp);
}
return 1;
}
break;
default:
assert(0);
}
node_error(expp, "Illegal operand for unary operator \"%s\"",
symbol2str(expp->nd_symb));
return 0;
}

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

@ -19,17 +19,17 @@ arith max_int; /* maximum integer on target machine */
arith max_unsigned; /* maximum unsigned on target machine */
arith max_longint; /* maximum longint on target machine */
cstunary(expp, oper)
cstunary(expp)
register struct node *expp;
{
/* The unary operation oper is performed on the constant
expression expp, and the result restored in expp.
/* The unary operation in "expp" is performed on the constant
expression below it, and the result restored in expp.
*/
arith o1 = expp->nd_INT;
arith o1 = expp->nd_right->nd_INT;
switch(oper) {
switch(expp->nd_symb) {
case '+':
return;
break;
case '-':
o1 = -o1;
break;
@ -39,40 +39,37 @@ cstunary(expp, oper)
default:
assert(0);
}
expp->nd_class = Value;
expp->nd_token = expp->nd_right->nd_token;
expp->nd_INT = o1;
cut_size(expp);
FreeNode(expp->nd_right);
expp->nd_right = 0;
}
cstbin(expp, oper, expr)
register struct node *expp, *expr;
cstbin(expp)
register struct node *expp;
{
/* The binary operation oper is performed on the constant
expressions expp and expr, and the result restored in
/* The binary operation in "expp" is performed on the constant
expressions below it, and the result restored in
expp.
*/
arith o1 = expp->nd_INT;
arith o2 = expr->nd_INT;
arith o1 = expp->nd_left->nd_INT;
arith o2 = expp->nd_right->nd_INT;
int uns = expp->nd_type != int_type;
assert(expp->nd_class == Value && expr->nd_class == Value);
switch (oper) {
case IN:
/* ??? */
assert(expp->nd_class == Oper);
if (expp->nd_right->nd_type->tp_fund == SET) {
cstset(expp);
return;
}
switch (expp->nd_symb) {
case '*':
if (expp->nd_type->tp_fund == SET) {
/* ??? */
return;
}
o1 *= o2;
break;
case '/':
assert(expp->nd_type->tp_fund == SET);
/* ??? */
return;
case DIV:
if (o2 == 0) {
node_error(expr, "division by 0");
node_error(expp, "division by 0");
return;
}
if (uns) {
@ -109,7 +106,7 @@ cstbin(expp, oper, expr)
break;
case MOD:
if (o2 == 0) {
node_error(expr, "modulo by 0");
node_error(expp, "modulo by 0");
return;
}
if (uns) {
@ -137,17 +134,9 @@ cstbin(expp, oper, expr)
o1 %= o2;
break;
case '+':
if (expp->nd_type->tp_fund == SET) {
/* ??? */
return;
}
o1 += o2;
break;
case '-':
if (expp->nd_type->tp_fund == SET) {
/* ??? */
return;
}
o1 -= o2;
break;
case '<':
@ -171,10 +160,6 @@ cstbin(expp, oper, expr)
o1 = o1 > o2;
break;
case LESSEQUAL:
if (expp->nd_type->tp_fund == SET) {
/* ??? */
return;
}
if (uns) {
o1 = (o1 & mach_long_sign ?
(o2 & mach_long_sign ? o1 <= o2 : 0) :
@ -185,10 +170,6 @@ cstbin(expp, oper, expr)
o1 = o1 <= o2;
break;
case GREATEREQUAL:
if (expp->nd_type->tp_fund == SET) {
/* ??? */
return;
}
if (uns) {
o1 = (o1 & mach_long_sign ?
(o2 & mach_long_sign ? o1 >= o2 : 1) :
@ -199,17 +180,9 @@ cstbin(expp, oper, expr)
o1 = o1 >= o2;
break;
case '=':
if (expp->nd_type->tp_fund == SET) {
/* ??? */
return;
}
o1 = o1 == o2;
break;
case '#':
if (expp->nd_type->tp_fund == SET) {
/* ??? */
return;
}
o1 = o1 != o2;
break;
case AND:
@ -221,8 +194,33 @@ cstbin(expp, oper, expr)
default:
assert(0);
}
expp->nd_class = Value;
expp->nd_token = expp->nd_right->nd_token;
expp->nd_INT = o1;
cut_size(expp);
FreeNode(expp->nd_left);
FreeNode(expp->nd_right);
expp->nd_left = expp->nd_right = 0;
}
cstset(expp)
register struct node *expp;
{
switch(expp->nd_symb) {
case IN:
case '+':
case '-':
case '*':
case '/':
case GREATEREQUAL:
case LESSEQUAL:
case '=':
case '#':
/* ??? */
break;
default:
assert(0);
}
}
cut_size(expr)

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

@ -5,6 +5,7 @@ static char *RcsId = "$Header$";
#include <em_arith.h>
#include <em_label.h>
#include <alloc.h>
#include <assert.h>
#include "idf.h"
#include "LLlex.h"
@ -122,7 +123,7 @@ FPSection(int doparams; struct paramlist **ppr;)
if (doparams) {
EnterIdList(FPList, D_VARIABLE, VARp, tp, CurrentScope);
}
*ppr = ParamList(FPList, tp);
*ppr = ParamList(FPList, tp, VARp);
FreeNode(FPList);
}
;
@ -160,7 +161,7 @@ TypeDeclaration
tp->tp_fund != POINTER) {
error("Opaque type \"%s\" is not a pointer type", df->df_idf->id_text);
}
}
;
@ -181,18 +182,18 @@ type(struct type **ptp;):
SimpleType(struct type **ptp;)
{
struct def *df;
struct type *tp;
} :
qualident(D_TYPE | D_HTYPE, &df, "type", (struct node **) 0)
[
/* nothing */
{ *ptp = df->df_type; }
|
SubrangeType(ptp)
/* The subrange type is given a base type by the
qualident (this is new modula-2).
*/
{
chk_basesubrange(*ptp, tp);
chk_basesubrange(*ptp, df->df_type);
}
]
|
@ -250,7 +251,7 @@ SubrangeType(struct type **ptp;)
{
/* For the time being: */
tp = int_type;
tp = construct_type(SUBRANGE, tp, (arith) 0);
tp = construct_type(SUBRANGE, tp);
*ptp = tp;
}
;
@ -352,7 +353,7 @@ SetType(struct type **ptp;)
} :
SET OF SimpleType(&tp)
{
*ptp = construct_type(SET, tp, (arith) 0 /* ???? */);
*ptp = construct_type(SET, tp);
}
;
@ -365,6 +366,7 @@ PointerType(struct type **ptp;)
struct type *tp;
struct def *df;
struct def *lookfor();
struct node *nd;
} :
POINTER TO
[ %if ( (df = lookup(dot.TOK_IDF, CurrentScope->sc_scope)))
@ -380,8 +382,9 @@ PointerType(struct type **ptp;)
}
else tp = df->df_type;
}
| %if (df = lookfor(dot.TOK_IDF, CurrentScope, 0),
df->df_kind == D_MODULE)
| %if ( nd = new_node(), nd->nd_token = dot,
df = lookfor(nd, CurrentScope, 0), free_node(nd),
df->df_kind == D_MODULE)
type(&tp)
|
IDENT
@ -449,7 +452,7 @@ ConstantDeclaration
}:
IDENT { id = dot.TOK_IDF; }
'=' ConstExpression(&nd){ df = define(id, CurrentScope, D_CONST);
/* ???? */
df->con_const = nd;
}
;

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

@ -15,8 +15,8 @@ struct variable {
};
struct constant {
arith co_const; /* result of a constant expression */
#define con_const df_value.df_variable.con_const
struct node *co_const; /* result of a constant expression */
#define con_const df_value.df_constant.co_const
};
struct enumval {

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

@ -6,11 +6,11 @@ static char *RcsId = "$Header$";
#include <em_arith.h>
#include <em_label.h>
#include <assert.h>
#include "main.h"
#include "Lpars.h"
#include "def.h"
#include "type.h"
#include "idf.h"
#include "main.h"
#include "scope.h"
#include "LLlex.h"
#include "node.h"
@ -26,13 +26,12 @@ struct def *ill_df = &illegal_def;
struct def *
define(id, scope, kind)
register struct idf *id;
struct scope *scope;
register struct scope *scope;
{
/* Declare an identifier in a scope, but first check if it
already has been defined. If so, error message.
*/
register struct def *df;
register struct scope *sc;
DO_DEBUG(5, debug("Defining identifier \"%s\" in scope %d", id->id_text, scope->sc_scope));
df = lookup(id, scope->sc_scope);
@ -157,7 +156,6 @@ Import(ids, idn, local)
identifiers defined in this module.
*/
register struct def *df;
register struct idf *id = 0;
int scope;
int kind;
int imp_kind;
@ -165,19 +163,18 @@ Import(ids, idn, local)
#define FROM_ENCLOSING 1
struct def *lookfor(), *GetDefinitionModule();
if (idn) id = idn->nd_IDF;
kind = D_IMPORT;
scope = enclosing(CurrentScope)->sc_scope;
if (!id) imp_kind = FROM_ENCLOSING;
if (!idn) imp_kind = FROM_ENCLOSING;
else {
imp_kind = FROM_MODULE;
if (local) df = lookfor(id, enclosing(CurrentScope), 1);
else df = GetDefinitionModule(id);
if (local) df = lookfor(idn, enclosing(CurrentScope), 1);
else df = GetDefinitionModule(idn->nd_IDF);
if (df->df_kind != D_MODULE) {
/* enter all "ids" with type D_ERROR */
kind = D_ERROR;
if (df->df_kind != D_ERROR) {
node_error(idn, "identifier \"%s\" does not represent a module", id->id_text);
node_error(idn, "identifier \"%s\" does not represent a module", idn->nd_IDF->id_text);
}
}
else scope = df->mod_scope;
@ -197,14 +194,14 @@ ids->nd_IDF->id_text);
}
else {
if (local) {
df = lookfor(ids->nd_IDF,
enclosing(CurrentScope), 0);
df = lookfor(ids, enclosing(CurrentScope), 0);
} else df = GetDefinitionModule(ids->nd_IDF);
if (df->df_kind == D_ERROR) {
node_error(ids, "identifier \"%s\" not visible in enclosing scope",
ids->nd_IDF->id_text);
}
}
DO_DEBUG(2, debug("importing \"%s\", kind %d", ids->nd_IDF->id_text, df->df_kind));
define(ids->nd_IDF, CurrentScope, kind)->imp_def = df;
if (df->df_kind == D_TYPE &&
df->df_type->tp_fund == ENUMERATION) {
@ -218,12 +215,14 @@ ids->nd_IDF->id_text);
exprt_literals(df, toscope)
register struct def *df;
register struct scope *toscope;
struct scope *toscope;
{
/* A list of enumeration literals is exported. This is implemented
as an import from the scope "toscope".
*/
DO_DEBUG(2, debug("enumeration import:"));
while (df) {
DO_DEBUG(2, debug(df->df_idf->id_text));
define(df->df_idf, toscope, D_IMPORT)->imp_def = df;
df = df->enm_next;
}

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

@ -11,6 +11,11 @@ static char *RcsId = "$Header$";
#include "def.h"
#include "LLlex.h"
#include "f_info.h"
#include "debug.h"
#ifdef DEBUG
long sys_filesize();
#endif
GetFile(name)
char *name;
@ -30,6 +35,7 @@ GetFile(name)
fatal("Could'nt find a DEFINITION MODULE for \"%s\"", name);
}
LineNumber = 1;
DO_DEBUG(1, debug("File %s : %ld characters", FileName, sys_filesize(FileName)));
}
struct def *

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

@ -74,7 +74,7 @@ EnterIdList(idlist, kind, flags, type, scope)
struct def *
lookfor(id, scope, give_error)
struct idf *id;
struct node *id;
struct scope *scope;
{
/* Look for an identifier in the visibility range started by
@ -86,10 +86,10 @@ lookfor(id, scope, give_error)
register struct scope *sc = scope;
while (sc) {
df = lookup(id, sc->sc_scope);
df = lookup(id->nd_IDF, sc->sc_scope);
if (df) return df;
sc = nextvisible(sc);
}
if (give_error) id_not_declared(id);
return define(id, scope, D_ERROR);
return define(id->nd_IDF, scope, D_ERROR);
}

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

@ -6,7 +6,6 @@ static char *RcsId = "$Header$";
#include <alloc.h>
#include <em_arith.h>
#include <em_label.h>
#include "main.h"
#include "LLlex.h"
#include "idf.h"
#include "def.h"
@ -34,52 +33,29 @@ number(struct node **p;)
qualident(int types; struct def **pdf; char *str; struct node **p;)
{
int scope;
int module;
register struct def *df;
struct def *lookfor();
register struct node **pnd;
struct node *nd;
struct def *findname();
} :
IDENT { if (types) {
df = lookfor(dot.TOK_IDF, CurrentScope, 1);
*pdf = df;
if (df->df_kind == D_ERROR) types = 0;
}
nd = MkNode(Value, NULLNODE, NULLNODE, &dot);
IDENT { nd = MkNode(Name, NULLNODE, NULLNODE, &dot);
pnd = &nd;
}
[
{ if (types &&!(scope = has_selectors(df))) {
types = 0;
*pdf = ill_df;
}
}
/* selector */
'.' { *pnd = MkNode(Link,*pnd,NULLNODE,&dot);
pnd = &(*pnd)->nd_right;
}
IDENT
{ *pnd = MkNode(Value,NULLNODE,NULLNODE,&dot);
if (types) {
module = (df->df_kind == D_MODULE);
df = lookup(dot.TOK_IDF, scope);
if (!df) {
types = 0;
df = ill_df;
id_not_declared(dot.TOK_IDF);
}
else
if (module &&
!(df->df_flags&(D_EXPORTED|D_QEXPORTED))) {
error("identifier \"%s\" not exported from qualifying module", dot.TOK_IDF->id_text);
}
}
}
{ *pnd = MkNode(Name,NULLNODE,NULLNODE,&dot); }
]*
{ if (types && !(types & df->df_kind)) {
error("identifier \"%s\" is not a %s",
{ if (types) {
*pdf = df = findname(nd);
if (df->df_kind != D_ERROR &&
!(types & df->df_kind)) {
error("identifier \"%s\" is not a %s",
df->df_idf->id_text, str);
}
}
if (!p) FreeNode(nd);
else *p = nd;
@ -114,6 +90,7 @@ ConstExpression(struct node **pnd;):
{ DO_DEBUG(3,
( debug("Constant expression:"),
PrNode(*pnd)));
(void) chk_expr(*pnd, 1);
}
;
@ -209,7 +186,7 @@ factor(struct node **p;)
'(' expression(p) ')'
|
NOT { *p = MkNode(Uoper, NULLNODE, NULLNODE, &dot); }
factor(&((*p)->nd_left))
factor(&((*p)->nd_right))
;
bare_set(struct node **pnd;)
@ -218,7 +195,7 @@ bare_set(struct node **pnd;)
} :
'{' {
dot.tk_symb = SET;
*pnd = nd = MkNode(Link, NULLNODE, NULLNODE, &dot);
*pnd = nd = MkNode(Xset, NULLNODE, NULLNODE, &dot);
nd->nd_type = bitset_type;
}
[
@ -261,9 +238,9 @@ designator_tail(struct node **pnd;):
visible_designator_tail(pnd)
[
/* selector */
'.' { *pnd = MkNode(Oper, *pnd, NULLNODE, &dot); }
'.' { *pnd = MkNode(Link, *pnd, NULLNODE, &dot); }
IDENT { (*pnd)->nd_right =
MkNode(Value, NULLNODE, NULLNODE, &dot);
MkNode(Name, NULLNODE, NULLNODE, &dot);
}
|
visible_designator_tail(pnd)

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

@ -10,12 +10,12 @@ static char *RcsId = "$Header$";
#include "idf.h"
#include "LLlex.h"
#include "Lpars.h"
#include "main.h"
#include "debug.h"
#include "type.h"
#include "def.h"
#include "scope.h"
#include "standards.h"
#include "tokenname.h"
char options[128];
int DefinitionModule;
@ -126,7 +126,6 @@ Option(str)
add_standards()
{
register struct def *df;
register struct type *tp;
struct def *Enter();
(void) Enter("ABS", D_STDFUNC, NULLTYPE, S_ABS);
@ -161,11 +160,11 @@ add_standards()
0);
df = Enter("BITSET", D_TYPE, bitset_type, 0);
df = Enter("FALSE", D_ENUM, bool_type, 0);
df->df_value.df_enum.en_val = 0;
df->df_value.df_enum.en_next = Enter("TRUE", D_ENUM, bool_type, 0);
df = df->df_value.df_enum.en_next;
df->df_value.df_enum.en_val = 1;
df->df_value.df_enum.en_next = 0;
df->enm_val = 0;
df->enm_next = Enter("TRUE", D_ENUM, bool_type, 0);
df = df->enm_next;
df->enm_val = 1;
df->enm_next = 0;
}
init_DEFPATH()

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

@ -8,6 +8,7 @@ static char *RcsId = "$Header$";
#include "misc.h"
#include "LLlex.h"
#include "idf.h"
#include "node.h"
match_id(id1, id2)
struct idf *id1, *id2;
@ -40,12 +41,13 @@ gen_anon_idf()
}
id_not_declared(id)
struct idf *id;
struct node *id;
{
/* The identifier "id" is not declared. If it is not generated,
give an error message
*/
if (!is_anon_idf(id)) {
error("identifier \"%s\" not declared", id->id_text);
if (!is_anon_idf(id->nd_IDF)) {
node_error(id,
"identifier \"%s\" not declared", id->nd_IDF->id_text);
}
}

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

@ -7,18 +7,28 @@ struct node {
#define nd_left next
struct node *nd_right;
int nd_class; /* kind of node */
#define Value 1 /* idf or constant */
#define Value 1 /* constant */
#define Oper 2 /* binary operator */
#define Uoper 3 /* unary operator */
#define Call 4 /* cast or procedure - or function call */
#define Link 5
#define Name 5 /* a qualident */
#define Set 6 /* a set constant */
#define Xset 7 /* a set */
#define Def 8 /* an identified name */
#define Link 11
struct type *nd_type; /* type of this node */
union {
struct token ndu_token;
char *ndu_set; /* Pointer to a set constant */
struct token ndu_token; /* (Value, Oper, Uoper, Call, Name,
Link)
*/
arith *ndu_set; /* pointer to a set constant (Set) */
struct def *ndu_def; /* pointer to definition structure for
identified name (Def)
*/
} nd_val;
#define nd_token nd_val.ndu_token
#define nd_set nd_val.ndu_set
#define nd_def nd_val.ndu_def
#define nd_symb nd_token.tk_symb
#define nd_lineno nd_token.tk_lineno
#define nd_filename nd_token.tk_filename

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

@ -6,7 +6,6 @@ static char *RcsId = "$Header$";
#include <em_arith.h>
#include <alloc.h>
#include <system.h>
#include "main.h"
#include "def.h"
#include "type.h"
#include "LLlex.h"

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

@ -6,8 +6,8 @@ static char *RcsId = "$Header$";
#include <alloc.h>
#include <em_arith.h>
#include <em_label.h>
#include "idf.h"
#include "main.h"
#include "idf.h"
#include "LLlex.h"
#include "scope.h"
#include "def.h"
@ -148,13 +148,12 @@ DefinitionModule
definition
{
struct def *df;
struct type *tp;
} :
CONST [ ConstantDeclaration ';' ]*
|
TYPE
[ IDENT { df = define(dot.TOK_IDF, CurrentScope, D_TYPE); }
[ '=' type(&tp)
[ '=' type(&(df->df_type))
| /* empty */
/*
Here, the exported type has a hidden implementation.

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

@ -11,7 +11,7 @@ static char *RcsId = "$Header$";
#include "scope.h"
#include "type.h"
#include "def.h"
#include "main.h"
#include "node.h"
#include "debug.h"
static int maxscope; /* maximum assigned scope number */
@ -34,7 +34,8 @@ open_scope(scopetype, scope)
register struct scope *sc1;
sc->sc_scope = scope == 0 ? ++maxscope : scope;
sc->sc_forw = 0; sc->sc_def = 0;
sc->sc_forw = 0;
sc->sc_def = 0;
assert(scopetype == OPENSCOPE || scopetype == CLOSEDSCOPE);
DO_DEBUG(1, debug("Opening a %s scope",
scopetype == OPENSCOPE ? "open" : "closed"));
@ -42,32 +43,14 @@ open_scope(scopetype, scope)
if (scopetype == CLOSEDSCOPE) {
sc1 = new_scope();
sc1->sc_scope = 0; /* Pervasive scope nr */
sc1->sc_forw = 0; sc1->sc_def = 0;
sc1->sc_forw = 0;
sc1->sc_def = 0;
sc1->next = CurrentScope;
}
sc->next = sc1;
CurrentScope = sc;
}
static rem_forwards();
close_scope()
{
register struct scope *sc = CurrentScope;
assert(sc != 0);
DO_DEBUG(1, debug("Closing a scope"));
if (sc->sc_forw) rem_forwards(sc->sc_forw);
if (sc->next && (sc->next->sc_scope == 0)) {
struct scope *sc1 = sc;
sc = sc->next;
free_scope(sc1);
}
CurrentScope = sc->next;
free_scope(sc);
}
init_scope()
{
register struct scope *sc = new_scope();
@ -86,7 +69,7 @@ uniq_scope()
struct forwards {
struct forwards *next;
struct token fo_tok;
struct node fo_tok;
struct type **fo_ptyp;
};
@ -103,12 +86,29 @@ Forward(tk, ptp)
*/
register struct forwards *f = new_forwards();
f->fo_tok = *tk;
f->fo_tok.nd_token = *tk;
f->fo_ptyp = ptp;
f->next = CurrentScope->sc_forw;
CurrentScope->sc_forw = f;
}
close_scope()
{
register struct scope *sc = CurrentScope;
assert(sc != 0);
DO_DEBUG(1, debug("Closing a scope"));
if (sc->sc_forw) rem_forwards(sc->sc_forw);
if (sc->next && (sc->next->sc_scope == 0)) {
struct scope *sc1 = sc;
sc = sc->next;
free_scope(sc1);
}
CurrentScope = sc->next;
free_scope(sc);
}
static
rem_forwards(fo)
struct forwards *fo;
@ -116,21 +116,17 @@ rem_forwards(fo)
/* When closing a scope, all forward references must be resolved
*/
register struct forwards *f;
struct token savetok;
register struct def *df;
struct def *lookfor();
savetok = dot;
while (f = fo) {
dot = f->fo_tok;
df = lookfor(dot.TOK_IDF, CurrentScope, 1);
df = lookfor(&(f->fo_tok), CurrentScope, 1);
if (!(df->df_kind & (D_TYPE | D_HTYPE | D_ERROR))) {
error("identifier \"%s\" not a type",
node_error(&(f->fo_tok), "identifier \"%s\" not a type",
df->df_idf->id_text);
}
*(f->fo_ptyp) = df->df_type;
fo = f->next;
free_forwards(f);
}
dot = savetok;
}

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

@ -79,5 +79,6 @@ TstCompat(tp1, tp2)
|| tp1 == intorcard_type
|| tp1->tp_fund == POINTER
)
);
)
;
}