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-06-17 12:04:05 +00:00
parent f1a0c90fb1
commit a9dfdc494b
21 changed files with 573 additions and 516 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -33,7 +33,7 @@ int idfsize = IDFSIZE;
extern int cntlines;
#endif
static
STATIC
SkipComment()
{
/* Skip Modula-2 comments (* ... *).
@ -50,16 +50,12 @@ SkipComment()
cntlines++;
#endif
}
else
if (ch == '(') {
else if (ch == '(') {
LoadChar(ch);
if (ch == '*') {
++NestLevel;
}
if (ch == '*') ++NestLevel;
else continue;
}
else
if (ch == '*') {
else if (ch == '*') {
LoadChar(ch);
if (ch == ')') {
if (NestLevel-- == 0) return;
@ -70,7 +66,7 @@ SkipComment()
}
}
static
STATIC
GetString(upto)
{
/* Read a Modula-2 string, delimited by the character "upto".
@ -118,11 +114,13 @@ LLlex()
register int ch, nch;
toktype = error_type;
if (ASIDE) { /* a token is put aside */
*tk = aside;
ASIDE = 0;
return tk->tk_symb;
}
tk->tk_lineno = LineNumber;
again:
@ -216,8 +214,7 @@ again:
LoadChar(ch);
} while(in_idf(ch));
if (ch != EOI)
PushBack(ch);
if (ch != EOI) PushBack(ch);
*tg++ = '\0';
tk->TOK_IDF = id = str2idf(buf, 1);
@ -396,6 +393,7 @@ Sreal:
lexerror("floating constant too long");
}
else tk->TOK_REL = Salloc(buf, np - buf) + 1;
toktype = real_type;
return tk->tk_symb = REAL;
default:

18
lang/m2/comp/Makefile
View file

@ -9,10 +9,11 @@ INCLUDES = -I$(HDIR) -I/usr/em/h -I$(PKGDIR) -I/user1/erikb/em/h
LSRC = tokenfile.g program.g declar.g expression.g statement.g
CC = cc
GEN = LLgen
GENOPTIONS =
PROFILE =
CFLAGS = $(PROFILE) $(INCLUDES)
GEN = /usr/em/util/LLgen/src/LLgen
GENOPTIONS = -d
PROFILE = -p
CFLAGS = $(PROFILE) $(INCLUDES) -DSTATIC=
LINTFLAGS = -DSTATIC= -DNORCSID
LFLAGS = $(PROFILE)
LOBJ = tokenfile.o program.o declar.o expression.o statement.o
COBJ = LLlex.o LLmessage.o char.o error.o main.o \
@ -46,7 +47,7 @@ clean:
rm -f $(OBJ) $(GENFILES) LLfiles
lint: LLfiles hfiles
lint $(INCLUDES) -DNORCSID `sources $(OBJ)`
lint $(INCLUDES) $(LINTFLAGS) `sources $(OBJ)`
tokenfile.g: tokenname.c make.tokfile
make.tokfile <tokenname.c >tokenfile.g
@ -98,16 +99,17 @@ defmodule.o: LLlex.h debug.h def.h f_info.h idf.h input.h inputtype.h main.h sco
typequiv.o: LLlex.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
chk_expr.o: LLlex.h Lpars.h const.h debug.h def.h idf.h node.h scope.h standards.h type.h
chk_expr.o: LLlex.h Lpars.h chk_expr.h const.h debug.h def.h idf.h node.h scope.h standards.h type.h
options.o: idfsize.h main.h ndir.h type.h
walk.o: LLlex.h Lpars.h debug.h def.h desig.h f_info.h idf.h main.h node.h scope.h type.h
walk.o: LLlex.h Lpars.h chk_expr.h debug.h def.h desig.h f_info.h idf.h main.h node.h scope.h type.h
casestat.o: LLlex.h Lpars.h debug.h density.h desig.h node.h type.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
tmpvar.o: debug.h def.h scope.h type.h
lookup.o: LLlex.h debug.h def.h idf.h node.h scope.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 debug.h def.h idf.h main.h misc.h node.h scope.h type.h
expression.o: LLlex.h Lpars.h const.h debug.h def.h idf.h node.h type.h
expression.o: LLlex.h Lpars.h chk_expr.h const.h debug.h def.h idf.h node.h type.h
statement.o: LLlex.h Lpars.h def.h idf.h node.h scope.h type.h
Lpars.o: Lpars.h

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

@ -23,81 +23,150 @@ static char *RcsId = "$Header$";
#include "scope.h"
#include "const.h"
#include "standards.h"
#include "chk_expr.h"
extern char *symbol2str();
int
chk_expr(expp)
register struct node *expp;
STATIC int
chk_arr(expp)
struct node *expp;
{
/* Check the expression indicated by expp for semantic errors,
identify identifiers used in it, replace constants by
their value, and try to evaluate the expression.
*/
return chk_designator(expp, DESIGNATOR|VARIABLE, D_USED);
}
switch(expp->nd_class) {
case Arrsel:
return chk_designator(expp, DESIGNATOR|VARIABLE, D_USED);
case Oper:
return chk_oper(expp);
case Arrow:
return chk_designator(expp, DESIGNATOR|VARIABLE, D_USED);
case Uoper:
return chk_uoper(expp);
case Value:
switch(expp->nd_symb) {
case REAL:
case STRING:
case INTEGER:
return 1;
default:
crash("(chk_expr(Value))");
}
break;
case Xset:
return chk_set(expp);
case Link:
case Name:
if (chk_designator(expp, VALUE|DESIGNATOR, D_USED)) {
if (expp->nd_class == Def &&
expp->nd_def->df_kind == D_PROCEDURE) {
/* Check that this procedure is one that we
may take the address from.
*/
if (expp->nd_def->df_type == std_type) {
/* Standard procedure. Illegal */
node_error(expp, "address of standard procedure taken");
return 0;
}
if (expp->nd_def->df_scope->sc_level > 0) {
/* Address of nested procedure taken.
Illegal.
*/
node_error(expp, "address of a procedure local to another one taken");
return 0;
}
}
return 1;
}
return 0;
case Call:
return chk_call(expp);
STATIC int
chk_value(expp)
struct node *expp;
{
switch(expp->nd_symb) {
case REAL:
case STRING:
case INTEGER:
return 1;
default:
crash("(chk_expr)");
crash("(chk_value)");
}
/*NOTREACHED*/
}
int
STATIC int
chk_linkorname(expp)
register struct node *expp;
{
if (chk_designator(expp, VALUE|DESIGNATOR, D_USED)) {
if (expp->nd_class == Def &&
expp->nd_def->df_kind == D_PROCEDURE) {
/* Check that this procedure is one that we
may take the address from.
*/
if (expp->nd_def->df_type == std_type ||
expp->nd_def->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");
return 0;
}
}
return 1;
}
return 0;
}
STATIC int
RemoveSet(set)
arith **set;
{
/* This routine is only used for error exits of chk_el.
It frees the set indicated by "set", and returns 0.
*/
if (*set) {
free((char *) *set);
*set = 0;
}
return 0;
}
STATIC int
chk_el(expp, tp, set)
register struct node *expp;
register struct type *tp;
arith **set;
{
/* Check elements of a set. This routine may call itself
recursively.
Also try to compute the set!
*/
register struct node *left = expp->nd_left;
register struct node *right = expp->nd_right;
register int i;
if (expp->nd_class == Link && expp->nd_symb == UPTO) {
/* { ... , expr1 .. expr2, ... }
First check expr1 and expr2, and try to compute them.
*/
if (!chk_el(left, tp, set) || !chk_el(right, tp, set)) {
return 0;
}
if (left->nd_class == Value && right->nd_class == Value) {
/* We have a constant range. Put all elements in the
set
*/
if (left->nd_INT > right->nd_INT) {
node_error(expp, "lower bound exceeds upper bound in range");
return RemoveSet(set);
}
if (*set) {
for (i=left->nd_INT+1; i<right->nd_INT; i++) {
(*set)[i/wrd_bits] |= (1<<(i%wrd_bits));
}
}
}
else if (*set) {
free((char *) *set);
*set = 0;
}
return 1;
}
/* Here, a single element is checked
*/
if (!chk_expr(expp)) {
return RemoveSet(set);
}
if (!TstCompat(tp, expp->nd_type)) {
node_error(expp, "set element has incompatible type");
return RemoveSet(set);
}
if (expp->nd_class == Value) {
/* a constant element
*/
i = expp->nd_INT;
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))
) {
node_error(expp, "set element out of range");
return RemoveSet(set);
}
if (*set) (*set)[i/wrd_bits] |= (1 << (i%wrd_bits));
}
return 1;
}
STATIC int
chk_set(expp)
register struct node *expp;
{
@ -174,126 +243,49 @@ node_error(expp, "specifier does not represent a set type");
return 1;
}
int
chk_el(expp, tp, set)
register struct node *expp;
register struct type *tp;
arith **set;
{
/* Check elements of a set. This routine may call itself
recursively.
Also try to compute the set!
*/
register struct node *left = expp->nd_left;
register struct node *right = expp->nd_right;
register int i;
if (expp->nd_class == Link && expp->nd_symb == UPTO) {
/* { ... , expr1 .. expr2, ... }
First check expr1 and expr2, and try to compute them.
*/
if (!chk_el(left, tp, set) || !chk_el(right, tp, set)) {
return 0;
}
if (left->nd_class == Value && right->nd_class == Value) {
/* We have a constant range. Put all elements in the
set
*/
if (left->nd_INT > right->nd_INT) {
node_error(expp, "lower bound exceeds upper bound in range");
return rem_set(set);
}
if (*set) {
for (i=left->nd_INT+1; i<right->nd_INT; i++) {
(*set)[i/wrd_bits] |= (1<<(i%wrd_bits));
}
}
}
else if (*set) {
free((char *) *set);
*set = 0;
}
return 1;
}
/* Here, a single element is checked
*/
if (!chk_expr(expp)) {
return rem_set(set);
}
if (!TstCompat(tp, expp->nd_type)) {
node_error(expp, "set element has incompatible type");
return rem_set(set);
}
if (expp->nd_class == Value) {
/* a constant element
*/
i = expp->nd_INT;
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))
) {
node_error(expp, "set element out of range");
return rem_set(set);
}
if (*set) (*set)[i/wrd_bits] |= (1 << (i%wrd_bits));
}
return 1;
}
int
rem_set(set)
arith **set;
{
/* This routine is only used for error exits of chk_el.
It frees the set indicated by "set", and returns 0.
*/
if (*set) {
free((char *) *set);
*set = 0;
}
return 0;
}
struct node *
STATIC struct node *
getarg(argp, bases, designator)
struct node **argp;
{
/* This routine is used to fetch the next argument from an
argument list. The argument list is indicated by "argp".
The parameter "bases" is a bitset indicating which types
are allowed at this point, and "designator" is a flag
indicating that the address from this argument is taken, so
that it must be a designator and may not be a register
variable.
*/
struct type *tp;
register struct node *arg = *argp;
register struct node *left;
if (!arg->nd_right) {
if (! arg->nd_right) {
node_error(arg, "too few arguments supplied");
return 0;
}
arg = arg->nd_right;
if ((!designator && !chk_expr(arg->nd_left)) ||
(designator && !chk_designator(arg->nd_left, DESIGNATOR, D_REFERRED))) {
left = arg->nd_left;
if ((!designator && !chk_expr(left)) ||
(designator &&
!chk_designator(left, DESIGNATOR|VARIABLE, D_USED|D_NOREG))) {
return 0;
}
tp = arg->nd_left->nd_type;
tp = left->nd_type;
if (tp->tp_fund == T_SUBRANGE) tp = tp->next;
if (bases && !(tp->tp_fund & bases)) {
node_error(arg, "unexpected type");
return 0;
}
*argp = arg;
return arg->nd_left;
return left;
}
struct node *
STATIC struct node *
getname(argp, kinds)
struct node **argp;
{
@ -303,10 +295,11 @@ getname(argp, kinds)
node_error(arg, "too few arguments supplied");
return 0;
}
arg = arg->nd_right;
if (! chk_designator(arg->nd_left, 0, D_REFERRED)) return 0;
assert(arg->nd_left->nd_class == Def);
if (arg->nd_left->nd_class != Def);
if (!(arg->nd_left->nd_def->df_kind & kinds)) {
node_error(arg, "unexpected type");
@ -317,6 +310,42 @@ getname(argp, kinds)
return arg->nd_left;
}
STATIC int
chk_proccall(expp)
register struct node *expp;
{
/* Check a procedure call
*/
register struct node *left;
struct node *arg;
register struct paramlist *param;
left = expp->nd_left;
arg = expp;
expp->nd_type = left->nd_type->next;
for (param = left->nd_type->prc_params; param; param = param->next) {
if (!(left = getarg(&arg, 0, IsVarParam(param)))) return 0;
if (left->nd_symb == STRING) {
TryToString(left, TypeOfParam(param));
}
if (! TstParCompat(TypeOfParam(param),
left->nd_type,
IsVarParam(param),
left)) {
node_error(left, "type incompatibility in parameter");
return 0;
}
}
if (arg->nd_right) {
node_error(arg->nd_right, "too many parameters supplied");
return 0;
}
return 1;
}
int
chk_call(expp)
register struct node *expp;
@ -358,58 +387,7 @@ chk_call(expp)
return 0;
}
chk_proccall(expp)
register struct node *expp;
{
/* Check a procedure call
*/
register struct node *left;
struct node *arg;
register struct paramlist *param;
left = 0;
arg = expp->nd_right;
/* First, reverse the order in the argument list */
while (arg) {
expp->nd_right = arg;
arg = arg->nd_right;
expp->nd_right->nd_right = left;
left = expp->nd_right;
}
left = expp->nd_left;
arg = expp;
expp->nd_type = left->nd_type->next;
param = left->nd_type->prc_params;
while (param) {
if (!(left = getarg(&arg, 0, IsVarParam(param)))) return 0;
if (left->nd_symb == STRING) {
TryToString(left, TypeOfParam(param));
}
if (! TstParCompat(TypeOfParam(param),
left->nd_type,
IsVarParam(param),
left)) {
node_error(left, "type incompatibility in parameter");
return 0;
}
if (IsVarParam(param) && left->nd_class == Def) {
left->nd_def->df_flags |= D_NOREG;
}
param = param->next;
}
if (arg->nd_right) {
node_error(arg->nd_right, "too many parameters supplied");
return 0;
}
return 1;
}
static int
STATIC int
FlagCheck(expp, df, flag)
struct node *expp;
struct def *df;
@ -461,7 +439,6 @@ chk_designator(expp, flag, dflags)
*/
register struct def *df;
register struct type *tp;
struct def *lookfor();
expp->nd_type = error_type;
@ -469,23 +446,20 @@ chk_designator(expp, flag, dflags)
expp->nd_def = lookfor(expp, CurrVis, 1);
expp->nd_class = Def;
expp->nd_type = expp->nd_def->df_type;
if (expp->nd_type == error_type) return 0;
}
else if (expp->nd_class == Link) {
register struct node *left = expp->nd_left;
if (expp->nd_class == Link) {
assert(expp->nd_symb == '.');
if (! chk_designator(expp->nd_left,
flag|HASSELECTORS,
dflags|D_NOREG)) return 0;
tp = expp->nd_left->nd_type;
if (! chk_designator(left,
(flag&DESIGNATOR)|HASSELECTORS,
dflags)) return 0;
tp = left->nd_type;
assert(tp->tp_fund == T_RECORD);
df = lookup(expp->nd_IDF, tp->rec_scope);
if (!df) {
if (!(df = lookup(expp->nd_IDF, tp->rec_scope))) {
id_not_declared(expp);
return 0;
}
@ -493,17 +467,19 @@ chk_designator(expp, flag, dflags)
expp->nd_def = df;
expp->nd_type = df->df_type;
if (!(df->df_flags & (D_EXPORTED|D_QEXPORTED))) {
/* Fields of a record are always D_QEXPORTED,
so ...
*/
node_error(expp, "identifier \"%s\" not exported from qualifying module",
df->df_idf->id_text);
return 0;
}
}
if (expp->nd_left->nd_class == Def &&
expp->nd_left->nd_def->df_kind == D_MODULE) {
if (left->nd_class == Def &&
left->nd_def->df_kind == D_MODULE) {
expp->nd_class = Def;
expp->nd_def = df;
FreeNode(expp->nd_left);
FreeNode(left);
expp->nd_left = 0;
}
else {
@ -548,12 +524,12 @@ df->df_idf->id_text);
assert(expp->nd_symb == '[');
if (
!chk_designator(expp->nd_left, DESIGNATOR|VARIABLE, dflags|D_NOREG)
!chk_designator(expp->nd_left, DESIGNATOR|VARIABLE, dflags)
||
!chk_expr(expp->nd_right)
!chk_expr(expp->nd_right)
||
expp->nd_left->nd_type == error_type
) return 0;
expp->nd_left->nd_type == error_type
) return 0;
tpr = expp->nd_right->nd_type;
tpl = expp->nd_left->nd_type;
@ -598,7 +574,7 @@ symbol2str(expp->nd_symb));
return 0;
}
struct type *
STATIC struct type *
ResultOfOperation(operator, tp)
struct type *tp;
{
@ -616,13 +592,13 @@ ResultOfOperation(operator, tp)
return tp;
}
int
STATIC int
Boolean(operator)
{
return operator == OR || operator == AND || operator == '&';
}
int
STATIC int
AllowedTypes(operator)
{
switch(operator) {
@ -654,7 +630,23 @@ AllowedTypes(operator)
/*NOTREACHED*/
}
int
STATIC int
chk_address(tpl, tpr)
register struct type *tpl, *tpr;
{
if (tpl == address_type) {
return tpr == address_type || tpr->tp_fund != T_POINTER;
}
if (tpr == address_type) {
return tpl->tp_fund != T_POINTER;
}
return 0;
}
STATIC int
chk_oper(expp)
register struct node *expp;
{
@ -741,23 +733,7 @@ node_error(expp,"operator \"%s\": illegal operand type(s)", symbol2str(expp->nd_
return 1;
}
int
chk_address(tpl, tpr)
register struct type *tpl, *tpr;
{
if (tpl == address_type) {
return tpr == address_type || tpr->tp_fund != T_POINTER;
}
if (tpr == address_type) {
return tpl->tp_fund != T_POINTER;
}
return 0;
}
int
STATIC int
chk_uoper(expp)
register struct node *expp;
{
@ -826,7 +802,7 @@ chk_uoper(expp)
return 0;
}
struct node *
STATIC struct node *
getvariable(argp)
struct node **argp;
{
@ -916,7 +892,11 @@ DO_DEBUG(3,debug("standard name \"%s\", %d",left->nd_def->df_idf->id_text,std));
case S_MAX:
case S_MIN:
if (!(left = getarg(&arg, T_DISCRETE, 0))) return 0;
if (!(left = getname(&arg, D_ISTYPE))) return 0;
if (!(left->nd_type->tp_fund & (T_DISCRETE))) {
node_error(left, "illegal type in MIN or MAX");
return 0;
}
expp->nd_type = left->nd_type;
cstcall(expp,std);
break;
@ -1072,7 +1052,8 @@ TryToString(nd, tp)
struct node *nd;
struct type *tp;
{
/* Try a coercion from character constant to string */
/* Try a coercion from character constant to string.
*/
if (tp->tp_fund == T_ARRAY && nd->nd_type == char_type) {
int ch = nd->nd_INT;
@ -1084,3 +1065,20 @@ TryToString(nd, tp)
nd->nd_SLE = 1;
}
}
extern int NodeCrash();
int (*ChkTable[])() = {
chk_value,
chk_arr,
chk_oper,
chk_uoper,
chk_arr,
chk_call,
chk_linkorname,
NodeCrash,
chk_set,
NodeCrash,
NodeCrash,
chk_linkorname
};

9
lang/m2/comp/chk_expr.h Normal file
View file

@ -0,0 +1,9 @@
/* E X P R E S S I O N C H E C K I N G */
/* $Header$ */
extern int (*ChkTable[])(); /* table of expression checking
functions, indexed by node class
*/
#define chk_expr(expp) ((*ChkTable[(expp)->nd_class])(expp))

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

@ -129,7 +129,6 @@ CodeExpr(nd, ds, true_label, false_label)
break;
case Uoper:
CodePExpr(nd->nd_right);
CodeUoper(nd);
ds->dsg_kind = DSG_LOADED;
break;
@ -194,9 +193,9 @@ CodeCoercion(t1, t2)
{
register int fund1, fund2;
if (t1 == t2) return;
if (t1->tp_fund == T_SUBRANGE) t1 = t1->next;
if (t2->tp_fund == T_SUBRANGE) t2 = t2->next;
if (t1 == t2) return;
if ((fund1 = t1->tp_fund) == T_WORD) fund1 = T_INTEGER;
if ((fund2 = t2->tp_fund) == T_WORD) fund2 = T_INTEGER;
switch(fund1) {
@ -291,9 +290,6 @@ CodeCall(nd)
and result is already done.
*/
register struct node *left = nd->nd_left;
register struct node *arg = nd;
register struct paramlist *param;
struct type *tp;
if (left->nd_type == std_type) {
CodeStd(nd);
@ -311,49 +307,10 @@ CodeCall(nd)
assert(IsProcCall(left));
for (param = left->nd_type->prc_params; param; param = param->next) {
tp = TypeOfParam(param);
arg = arg->nd_right;
assert(arg != 0);
left = arg->nd_left;
if (IsConformantArray(tp)) {
C_loc(tp->arr_elsize);
if (IsConformantArray(left->nd_type)) {
DoHIGH(left);
}
else if (left->nd_symb == STRING) {
C_loc(left->nd_SLE);
}
else if (tp->arr_elem == word_type) {
C_loc(left->nd_type->tp_size / word_size - 1);
}
else {
tp = left->nd_type->next;
if (tp->tp_fund == T_SUBRANGE) {
C_loc(tp->sub_ub - tp->sub_lb);
}
else C_loc((arith) (tp->enm_ncst - 1));
}
C_loc((arith) 0);
if (left->nd_symb == STRING) {
CodeString(left);
}
else CodeDAddress(left);
}
else if (IsVarParam(param)) {
CodeDAddress(left);
}
else {
if (left->nd_type->tp_fund == T_STRING) {
CodePadString(left, tp->tp_size);
}
else CodePExpr(left);
CheckAssign(left->nd_type, tp);
}
if (nd->nd_right) {
CodeParameters(left->nd_type->prc_params, nd->nd_right);
}
left = nd->nd_left;
if (left->nd_class == Def && left->nd_def->df_kind == D_PROCEDURE) {
if (left->nd_def->df_scope->sc_level > 0) {
C_lxl((arith) proclevel - left->nd_def->df_scope->sc_level);
@ -373,6 +330,63 @@ CodeCall(nd)
}
}
CodeParameters(param, arg)
struct paramlist *param;
struct node *arg;
{
register struct type *tp;
register struct node *left;
assert(param != 0 && arg != 0);
if (param->next) {
CodeParameters(param->next, arg->nd_right);
}
tp = TypeOfParam(param);
left = arg->nd_left;
if (IsConformantArray(tp)) {
C_loc(tp->arr_elsize);
if (IsConformantArray(left->nd_type)) {
DoHIGH(left);
if (tp->arr_elem->tp_size != left->nd_type->arr_elem->tp_size) {
/* This can only happen if the formal type is
ARRAY OF WORD
*/
/* ??? */
}
}
else if (left->nd_symb == STRING) {
C_loc(left->nd_SLE);
}
else if (tp->arr_elem == word_type) {
C_loc(left->nd_type->tp_size / word_size - 1);
}
else {
tp = left->nd_type->next;
if (tp->tp_fund == T_SUBRANGE) {
C_loc(tp->sub_ub - tp->sub_lb);
}
else C_loc((arith) (tp->enm_ncst - 1));
}
C_loc((arith) 0);
if (left->nd_symb == STRING) {
CodeString(left);
}
else CodeDAddress(left);
}
else if (IsVarParam(param)) {
CodeDAddress(left);
}
else {
if (left->nd_type->tp_fund == T_STRING) {
CodePadString(left, tp->tp_size);
}
else CodePExpr(left);
CheckAssign(left->nd_type, tp);
}
}
CodeStd(nd)
struct node *nd;
{
@ -387,7 +401,6 @@ CodeStd(nd)
if (tp->tp_fund == T_SUBRANGE) tp = tp->next;
arg = arg->nd_right;
}
Desig = InitDesig;
switch(std = nd->nd_left->nd_def->df_value.df_stdname) {
case S_ABS:
@ -546,14 +559,12 @@ CheckAssign(tpl, tpr)
*/
arith llo, lhi, rlo, rhi;
label l = 0;
extern label getrck();
if (bounded(tpl)) {
/* in this case we might need a range check */
if (!bounded(tpr)) {
/* yes, we need one */
l = getrck(tpl);
genrck(tpl);
}
else {
/* both types are restricted. check the bounds
@ -562,14 +573,9 @@ CheckAssign(tpl, tpr)
getbounds(tpl, &llo, &lhi);
getbounds(tpr, &rlo, &rhi);
if (llo > rlo || lhi < rhi) {
l = getrck(tpl);
genrck(tpl);
}
}
if (l) {
C_lae_dlb(l, (arith) 0);
C_rck(word_size);
}
}
}
@ -916,6 +922,7 @@ CodeUoper(nd)
{
register struct type *tp = nd->nd_type;
CodePExpr(nd->nd_right);
switch(nd->nd_symb) {
case '~':
case NOT:

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

@ -461,7 +461,6 @@ PointerType(struct type **ptp;)
{
struct type *tp;
struct def *df;
struct def *lookfor();
struct node *nd;
} :
POINTER TO

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

@ -117,7 +117,11 @@ struct def { /* list of definitions for a name */
extern struct def
*define(),
*lookup(),
*DefineLocalModule(),
*MkDef(),
*ill_df;
extern struct def
*lookup(),
*lookfor();
#define NULLDEF ((struct def *) 0)

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

@ -203,7 +203,7 @@ DeclProc(type)
df->for_node = MkLeaf(Name, &dot);
sprint(buf,"%s_%s",CurrentScope->sc_name,df->df_idf->id_text);
df->for_name = Salloc(buf, (unsigned) (strlen(buf)+1));
C_exp(df->for_name);
if (CurrVis == Defined->mod_vis) C_exp(df->for_name);
open_scope(OPENSCOPE);
}
else {
@ -292,6 +292,51 @@ DefInFront(df)
}
}
struct def *
DefineLocalModule(id)
struct idf *id;
{
/* Create a definition for a local module. Also give it
a name to be used for code generation.
*/
register struct def *df = define(id, CurrentScope, D_MODULE);
register struct type *tp;
register struct scope *sc;
static int modulecount = 0;
char buf[256];
extern char *sprint();
extern int proclevel;
sprint(buf, "_%d%s", ++modulecount, id->id_text);
if (!df->mod_vis) {
/* We never saw the name of this module before. Create a
scope for it.
*/
open_scope(CLOSEDSCOPE);
df->mod_vis = CurrVis;
}
CurrVis = df->mod_vis;
sc = CurrentScope;
sc->sc_level = proclevel;
sc->sc_definedby = df;
sc->sc_name = Salloc(buf, (unsigned) (strlen(buf) + 1));
/* Create a type for it
*/
df->df_type = tp = standard_type(T_RECORD, 0, (arith) 0);
tp->rec_scope = sc;
/* Generate code that indicates that the initialization procedure
for this module is local.
*/
C_inp(buf);
return df;
}
#ifdef DEBUG
PrDef(df)
register struct def *df;

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

@ -25,7 +25,6 @@ static char *RcsId = "$Header$";
#include "node.h"
extern int proclevel;
struct desig Desig;
struct desig InitDesig = {DSG_INIT, 0, 0};
CodeValue(ds, size)
@ -225,6 +224,7 @@ CodeVarDesig(df, ds)
*/
assert(ds->dsg_kind == DSG_INIT);
df->df_flags |= D_USED;
if (df->var_addrgiven) {
/* the programmer specified an address in the declaration of
the variable. Generate code to push the address.
@ -232,7 +232,6 @@ CodeVarDesig(df, ds)
CodeConst(df->var_off, pointer_size);
ds->dsg_kind = DSG_PLOADED;
ds->dsg_offset = 0;
df->df_flags |= D_NOREG;
return;
}
@ -243,7 +242,6 @@ CodeVarDesig(df, ds)
ds->dsg_name = df->var_name;
ds->dsg_offset = 0;
ds->dsg_kind = DSG_FIXED;
df->df_flags |= D_NOREG;
return;
}
@ -251,6 +249,8 @@ CodeVarDesig(df, ds)
/* the variable is local to a statically enclosing procedure.
*/
assert(proclevel > sc->sc_level);
df->df_flags |= D_NOREG;
if (df->df_flags & (D_VARPAR|D_VALPAR)) {
/* value or var parameter
*/
@ -269,7 +269,6 @@ CodeVarDesig(df, ds)
else C_lxl((arith) (proclevel - sc->sc_level));
ds->dsg_kind = DSG_PLOADED;
ds->dsg_offset = df->var_off;
df->df_flags |= D_NOREG;
return;
}

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

@ -50,6 +50,6 @@ struct withdesig {
};
extern struct withdesig *WithDesigs;
extern struct desig Desig, InitDesig;
extern struct desig InitDesig;
#define NO_LABEL ((label) 0)

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

@ -116,6 +116,7 @@ EnterVarList(Idlist, type, local)
/* An address was supplied
*/
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");
}
@ -137,9 +138,12 @@ node_error(idlist->nd_left,"Illegal type for address");
sprint(buf,"%s_%s", sc->sc_scope->sc_name,
df->df_idf->id_text);
df->var_name = Salloc(buf, (unsigned)(strlen(buf)+1));
df->df_flags |= D_NOREG;
if (DefinitionModule) {
C_exa_dnam(df->var_name);
if (sc == Defined->mod_vis) {
C_exa_dnam(df->var_name);
}
}
else {
C_ina_dnam(df->var_name);
@ -163,11 +167,16 @@ EnterParamList(ppr, Idlist, type, VARp, off)
register struct paramlist *pr;
register struct def *df;
register struct node *idlist = Idlist;
static struct paramlist *last;
for ( ; idlist; idlist = idlist->next) {
pr = new_paramlist();
pr->next = *ppr;
*ppr = pr;
pr->next = 0;
if (!*ppr) {
*ppr = pr;
}
else last->next = pr;
last = pr;
df = define(idlist->nd_IDF, CurrentScope, D_VARIABLE);
pr->par_def = df;
df->df_type = type;
@ -188,7 +197,7 @@ EnterParamList(ppr, Idlist, type, VARp, off)
FreeNode(Idlist);
}
static
STATIC
DoImport(df, scope)
register struct def *df;
struct scope *scope;
@ -222,7 +231,7 @@ DoImport(df, scope)
}
}
static struct scopelist *
STATIC struct scopelist *
ForwModule(df, idn)
register struct def *df;
struct node *idn;
@ -248,7 +257,7 @@ ForwModule(df, idn)
return vis;
}
static struct def *
STATIC struct def *
ForwDef(ids, scope)
register struct node *ids;
struct scope *scope;
@ -351,7 +360,7 @@ EnterFromImportList(Idlist, Fromid, local)
register struct def *df;
struct scopelist *vis = enclosing(CurrVis);
int forwflag = 0;
extern struct def *lookfor(), *GetDefinitionModule();
extern struct def *GetDefinitionModule();
if (local) {
df = lookfor(Fromid, vis, 0);
@ -412,7 +421,7 @@ EnterImportList(Idlist, local)
register struct node *idlist = Idlist;
register struct def *df;
struct scopelist *vis = enclosing(CurrVis);
extern struct def *lookfor(), *GetDefinitionModule();
extern struct def *GetDefinitionModule();
for (; idlist; idlist = idlist->next) {
if (local) df = ForwDef(idlist, vis->sc_scope);

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

@ -18,19 +18,17 @@ static char *RcsId = "$Header$";
#include "node.h"
#include "const.h"
#include "type.h"
#include "chk_expr.h"
}
number(struct node **p;)
{
struct type *tp;
} :
number(struct node **p;) :
[
%default
INTEGER { tp = toktype; }
INTEGER
|
REAL { tp = real_type; }
REAL
] { *p = MkLeaf(Value, &dot);
(*p)->nd_type = tp;
(*p)->nd_type = toktype;
}
;

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

@ -16,8 +16,6 @@ static char *RcsId = "$Header$";
#include "LLlex.h"
#include "node.h"
extern struct def *MkDef();
struct def *
lookup(id, scope)
register struct idf *id;

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

@ -15,7 +15,7 @@ static char *RcsId = "$Header$";
#include "node.h"
match_id(id1, id2)
struct idf *id1, *id2;
register struct idf *id1, *id2;
{
/* Check that identifiers id1 and id2 are equal. If they
are not, check that we did'nt generate them in the
@ -45,7 +45,7 @@ gen_anon_idf()
}
id_not_declared(id)
struct node *id;
register struct node *id;
{
/* The identifier "id" is not declared. If it is not generated,
give an error message

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

@ -19,6 +19,7 @@ struct node {
#define Def 9 /* an identified name */
#define Stat 10 /* a statement */
#define Link 11
/* do NOT change the order or the numbers!!! */
struct type *nd_type; /* type of this node */
struct token nd_token;
#define nd_set nd_token.tk_data.tk_set

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

@ -64,11 +64,17 @@ FreeNode(nd)
free_node(nd);
}
NodeCrash(expp)
struct node *expp;
{
crash("Illegal node %d", expp->nd_class);
}
#ifdef DEBUG
extern char *symbol2str();
static
STATIC
printnode(nd)
register struct node *nd;
{

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

@ -42,36 +42,13 @@ static char *RcsId = "$Header$";
ModuleDeclaration
{
struct idf *id;
register struct def *df;
extern int proclevel;
static int modulecount = 0;
char buf[256];
struct def *df;
struct node *nd;
struct node *exportlist = 0;
int qualified;
extern char *sprint();
} :
MODULE IDENT {
id = dot.TOK_IDF;
df = define(id, CurrentScope, D_MODULE);
if (!df->mod_vis) {
open_scope(CLOSEDSCOPE);
df->mod_vis = CurrVis;
}
else {
CurrVis = df->mod_vis;
CurrentScope->sc_level = proclevel;
}
CurrentScope->sc_definedby = df;
df->df_type = standard_type(T_RECORD, 0, (arith) 0);
df->df_type->rec_scope = df->mod_vis->sc_scope;
sprint(buf, "_%d%s", ++modulecount, id->id_text);
CurrentScope->sc_name =
Salloc(buf, (unsigned) (strlen(buf) + 1));
if (! proclevel) C_ina_dnam(&buf[1]);
C_inp(buf);
MODULE IDENT { id = dot.TOK_IDF;
df = DefineLocalModule(id);
}
priority(&(df->mod_priority))?
';'
@ -92,7 +69,7 @@ priority(arith *pprio;)
struct node *nd;
} :
'[' ConstExpression(&nd) ']'
{ if (!(nd->nd_type->tp_fund & T_INTORCARD)) {
{ if (!(nd->nd_type->tp_fund & T_CARDINAL)) {
node_error(nd, "Illegal priority");
}
*pprio = nd->nd_INT;
@ -141,13 +118,12 @@ DefinitionModule
int dummy;
} :
DEFINITION
MODULE IDENT {
id = dot.TOK_IDF;
MODULE IDENT { id = dot.TOK_IDF;
df = define(id, GlobalScope, D_MODULE);
if (!SYSTEMModule) open_scope(CLOSEDSCOPE);
if (!Defined) Defined = df;
df->mod_vis = CurrVis;
if (!SYSTEMModule) open_scope(CLOSEDSCOPE);
CurrentScope->sc_name = id->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;
DefinitionModule++;
@ -222,8 +198,7 @@ ProgramModule
struct node *nd;
} :
MODULE
IDENT {
id = dot.TOK_IDF;
IDENT { id = dot.TOK_IDF;
if (state == IMPLEMENTATION) {
df = GetDefinitionModule(id);
CurrVis = df->mod_vis;
@ -232,11 +207,11 @@ ProgramModule
}
else {
df = define(id, CurrentScope, D_MODULE);
Defined = df;
open_scope(CLOSEDSCOPE);
df->mod_vis = CurrVis;
CurrentScope->sc_name = id->id_text;
}
Defined = df;
CurrentScope->sc_definedby = df;
}
priority(&(df->mod_priority))?

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

@ -90,7 +90,7 @@ Forward(tk, ptp)
CurrentScope->sc_forw = f;
}
static
STATIC
chk_proc(df)
register struct def *df;
{
@ -108,7 +108,7 @@ node_error(df->for_node, "procedure \"%s\" not defined", df->df_idf->id_text);
}
}
static
STATIC
chk_forw(pdf)
register struct def **pdf;
{
@ -153,7 +153,7 @@ node_error((*pdf)->for_node, "identifier \"%s\" has not been declared",
}
}
static
STATIC
rem_forwards(fo)
struct forwards *fo;
{
@ -161,7 +161,6 @@ rem_forwards(fo)
*/
register struct forwards *f;
register struct def *df;
struct def *lookfor();
while (f = fo) {
df = lookfor(&(f->fo_tok), CurrVis, 1);
@ -181,11 +180,10 @@ Reverse(pdf)
/* Reverse the order in the list of definitions in a scope.
This is neccesary because this list is built in reverse.
Also, while we're at it, remove uninteresting definitions
from this list. The only interesting definitions are:
D_MODULE, D_PROCEDURE, and D_PROCHEAD.
from this list.
*/
register struct def *df, *df1;
#define INTERESTING D_MODULE|D_PROCEDURE|D_PROCHEAD
#define INTERESTING D_MODULE|D_PROCEDURE|D_PROCHEAD|D_VARIABLE
df = 0;
df1 = *pdf;
@ -217,7 +215,6 @@ close_scope(flag)
register struct scope *sc = CurrentScope;
assert(sc != 0);
DO_DEBUG(1, debug("Closing a scope"));
if (flag) {
if (sc->sc_forw) rem_forwards(sc->sc_forw);

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

@ -83,13 +83,17 @@ ProcedureCall:
StatementSequence(register struct node **pnd;)
{
struct node *nd;
} :
statement(pnd)
[
';' { *pnd = MkNode(Link, *pnd, NULLNODE, &dot);
pnd = &((*pnd)->nd_right);
';' statement(&nd)
{ if (nd) {
*pnd = MkNode(Link, *pnd, nd, &dot);
(*pnd)->nd_symb = ';';
pnd = &((*pnd)->nd_right);
}
}
statement(pnd)
]*
;

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

@ -21,9 +21,6 @@ static char *RcsId = "$Header$";
#include "const.h"
#include "scope.h"
/* To be created dynamically in main() from defaults or from command
line parameters.
*/
int
word_align = AL_WORD,
int_align = AL_INT,
@ -96,38 +93,34 @@ construct_type(fund, tp)
switch (fund) {
case T_PROCEDURE:
if (tp && !returntype(tp)) {
error("illegal procedure result type");
}
/* Fall through */
case T_POINTER:
case T_HIDDEN:
dtp->tp_align = pointer_align;
dtp->tp_size = pointer_size;
dtp->next = tp;
if (fund == T_PROCEDURE && tp) {
if (! returntype(tp)) {
error("illegal procedure result type");
}
}
break;
case T_SET:
dtp->tp_align = word_align;
dtp->next = tp;
break;
case T_ARRAY:
dtp->tp_align = tp->tp_align;
dtp->next = tp;
break;
case T_SUBRANGE:
dtp->tp_align = tp->tp_align;
dtp->tp_size = tp->tp_size;
dtp->next = tp;
break;
default:
crash("funny type constructor");
}
dtp->next = tp;
return dtp;
}
@ -206,8 +199,11 @@ InitTypes()
address_type = construct_type(T_POINTER, word_type);
/* create BITSET type
TYPE BITSET = SET OF [0..W-1];
The subrange is a subrange of type cardinal, because the lower bound
is a non-negative integer (See Rep. 6.3)
*/
tp = construct_type(T_SUBRANGE, int_type);
tp = construct_type(T_SUBRANGE, card_type);
tp->sub_lb = 0;
tp->sub_ub = word_size * 8 - 1;
bitset_type = set_type(tp);
@ -229,7 +225,7 @@ chk_basesubrange(tp, base)
if (base->tp_fund == T_SUBRANGE) {
/* Check that the bounds of "tp" fall within the range
of "base"
of "base".
*/
if (base->sub_lb > tp->sub_lb || base->sub_ub < tp->sub_ub) {
error("Base type has insufficient range");
@ -246,7 +242,7 @@ chk_basesubrange(tp, base)
error("Illegal base for a subrange");
}
else if (base == int_type && tp->next == card_type &&
(tp->sub_ub > max_int || tp->sub_ub)) {
(tp->sub_ub > max_int || tp->sub_ub < 0)) {
error("Upperbound to large for type INTEGER");
}
else if (base != tp->next && base != int_type) {
@ -269,7 +265,7 @@ subr_type(lb, ub)
register struct type *tp = lb->nd_type, *res;
if (!TstCompat(lb->nd_type, ub->nd_type)) {
node_error(ub, "Types of subrange bounds not compatible");
node_error(ub, "Types of subrange bounds not equal");
return error_type;
}
@ -306,32 +302,33 @@ subr_type(lb, ub)
return res;
}
label
getrck(tp)
genrck(tp)
register struct type *tp;
{
/* generate a range check descriptor for type "tp" when
neccessary. Return its label
neccessary. Return its label.
*/
arith lb, ub;
label ol, l;
assert(bounded(tp));
getbounds(tp, &lb, &ub);
if (tp->tp_fund == T_SUBRANGE) {
if (tp->sub_rck == (label) 0) {
tp->sub_rck = data_label();
C_df_dlb(tp->sub_rck);
C_rom_cst(tp->sub_lb);
C_rom_cst(tp->sub_ub);
if (!(ol = tp->sub_rck)) {
tp->sub_rck = l = data_label();
}
return tp->sub_rck;
}
if (tp->enm_rck == (label) 0) {
tp->enm_rck = data_label();
C_df_dlb(tp->enm_rck);
C_rom_cst((arith) 0);
C_rom_cst((arith) (tp->enm_ncst - 1));
else if (!(ol = tp->enm_rck)) {
tp->enm_rck = l = data_label();
}
return tp->enm_rck;
if (!ol) {
ol = l;
C_df_dlb(ol);
C_rom_cst(lb);
C_rom_cst(ub);
}
C_lae_dlb(ol, (arith) 0);
C_rck(word_size);
}
getbounds(tp, plo, phi)
@ -352,6 +349,7 @@ getbounds(tp, plo, phi)
*phi = tp->enm_ncst - 1;
}
}
struct type *
set_type(tp)
register struct type *tp;
@ -361,26 +359,20 @@ set_type(tp)
*/
arith lb, ub;
if (tp->tp_fund == T_SUBRANGE) {
if ((lb = tp->sub_lb) < 0 || (ub = tp->sub_ub) > MAXSET - 1) {
error("Set type limits exceeded");
return error_type;
}
}
else if (tp->tp_fund == T_ENUMERATION || tp == char_type) {
lb = 0;
if ((ub = tp->enm_ncst - 1) > MAXSET - 1) {
error("Set type limits exceeded");
return error_type;
}
}
else {
if (! bounded(tp)) {
error("illegal base type for set");
return error_type;
}
getbounds(tp, &lb, &ub);
if (lb < 0 || ub > MAXSET-1) {
error("Set type limits exceeded");
return error_type;
}
tp = construct_type(T_SET, tp);
tp->tp_size = WA(((ub - lb) + 7)/8);
tp->tp_size = WA(((ub - lb) + 8)/8);
return tp;
}
@ -412,47 +404,30 @@ ArraySizes(tp)
*/
register struct type *index_type = tp->next;
register struct type *elem_type = tp->arr_elem;
arith lo, hi;
tp->arr_elsize = ArrayElSize(elem_type);
tp->tp_align = elem_type->tp_align;
/* check index type
*/
if (! (index_type->tp_fund & T_INDEX)) {
if (! bounded(index_type)) {
error("Illegal index type");
tp->tp_size = 0;
return;
}
/* find out HIGH, LOW and size of ARRAY
getbounds(index_type, &lo, &hi);
tp->tp_size = WA((hi - lo + 1) * tp->arr_elsize);
/* generate descriptor and remember label.
*/
tp->arr_descr = data_label();
C_df_dlb(tp->arr_descr);
switch(index_type->tp_fund) {
case T_SUBRANGE:
tp->tp_size = tp->arr_elsize *
(index_type->sub_ub - index_type->sub_lb + 1);
C_rom_cst(index_type->sub_lb);
C_rom_cst(index_type->sub_ub - index_type->sub_lb);
break;
case T_CHAR:
case T_ENUMERATION:
tp->tp_size = tp->arr_elsize * index_type->enm_ncst;
C_rom_cst((arith) 0);
C_rom_cst((arith) (index_type->enm_ncst - 1));
break;
default:
crash("Funny index type");
}
C_rom_cst(lo);
C_rom_cst(hi - lo);
C_rom_cst(tp->arr_elsize);
tp->tp_size = WA(tp->tp_size);
/* ??? overflow checking ???
*/
}
FreeType(tp)

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

@ -12,6 +12,7 @@ static char *RcsId = "$Header$";
#include <em_arith.h>
#include <em_label.h>
#include <em_reg.h>
#include <assert.h>
#include "def.h"
@ -24,6 +25,7 @@ static char *RcsId = "$Header$";
#include "desig.h"
#include "f_info.h"
#include "idf.h"
#include "chk_expr.h"
extern arith NewPtr();
extern arith NewInt();
@ -49,7 +51,7 @@ data_label()
return ++datalabel;
}
static
STATIC
DoProfil()
{
static label filename_label = 0;
@ -119,16 +121,14 @@ WalkModule(module)
struct node *nd;
if (state == IMPLEMENTATION) {
label l1 = data_label(), l2 = text_label();
label l1 = data_label();
/* we don't actually prevent recursive calls,
but do nothing if called recursively
*/
C_df_dlb(l1);
C_bss_cst(word_size, (arith) 0, 1);
C_loe_dlb(l1, (arith) 0);
C_zeq(l2);
C_ret((arith) 0);
C_df_ilb(l2);
C_zne((label) 1);
C_loc((arith) 1);
C_ste_dlb(l1, (arith) 0);
}
@ -159,7 +159,8 @@ WalkProcedure(procedure)
*/
struct scopelist *vis = CurrVis;
register struct scope *sc;
register struct type *res_type;
register struct type *tp;
register struct paramlist *param;
proclevel++;
CurrVis = procedure->prc_vis;
@ -177,19 +178,20 @@ WalkProcedure(procedure)
MkCalls(sc->sc_def);
return_expr_occurred = 0;
instructionlabel = 2;
func_type = res_type = procedure->df_type->next;
if (! returntype(res_type)) {
func_type = tp = procedure->df_type->next;
if (! returntype(tp)) {
node_error(procedure->prc_body, "illegal result type");
}
WalkNode(procedure->prc_body, (label) 0);
C_df_ilb((label) 1);
if (res_type) {
if (tp) {
if (! return_expr_occurred) {
node_error(procedure->prc_body,"function procedure does not return a value");
}
C_ret(WA(res_type->tp_size));
C_ret(WA(tp->tp_size));
}
else C_ret((arith) 0);
RegisterMessages(sc->sc_def);
C_end(-sc->sc_off);
TmpClose();
CurrVis = vis;
@ -257,7 +259,6 @@ WalkStat(nd, lab)
*/
register struct node *left = nd->nd_left;
register struct node *right = nd->nd_right;
register struct desig *pds = &Desig;
if (!nd) {
/* Empty statement
@ -385,9 +386,10 @@ WalkStat(nd, lab)
{
struct scopelist link;
struct withdesig wds;
struct desig ds;
arith tmp = 0;
WalkDesignator(left);
WalkDesignator(left, &ds);
if (left->nd_type->tp_fund != T_RECORD) {
node_error(left, "record variable expected");
break;
@ -396,19 +398,21 @@ WalkStat(nd, lab)
wds.w_next = WithDesigs;
WithDesigs = &wds;
wds.w_scope = left->nd_type->rec_scope;
if (pds->dsg_kind != DSG_PFIXED) {
if (ds.dsg_kind != DSG_PFIXED) {
/* In this case, we use a temporary variable
*/
CodeAddress(pds);
pds->dsg_kind = DSG_FIXED;
/* Only for the store ... */
pds->dsg_offset = tmp = NewPtr();
pds->dsg_name = 0;
CodeStore(pds, pointer_size);
pds->dsg_kind = DSG_PFIXED;
CodeAddress(&ds);
ds.dsg_kind = DSG_FIXED;
/* Create a designator structure for the
temporary.
*/
ds.dsg_offset = tmp = NewPtr();
ds.dsg_name = 0;
CodeStore(&ds, pointer_size);
ds.dsg_kind = DSG_PFIXED;
/* the record is indirectly available */
}
wds.w_desig = *pds;
wds.w_desig = ds;
link.sc_scope = wds.w_scope;
link.next = CurrVis;
CurrVis = &link;
@ -439,7 +443,7 @@ node_error(right, "type incompatibility in RETURN statement");
break;
default:
assert(0);
crash("(WalkStat)");
}
}
@ -450,6 +454,7 @@ ExpectBool(nd, true_label, false_label)
/* "nd" must indicate a boolean expression. Check this and
generate code to evaluate the expression.
*/
struct desig ds;
if (!chk_expr(nd)) return;
@ -457,8 +462,8 @@ ExpectBool(nd, true_label, false_label)
node_error(nd, "boolean expression expected");
}
Desig = InitDesig;
CodeExpr(nd, &Desig, true_label, false_label);
ds = InitDesig;
CodeExpr(nd, &ds, true_label, false_label);
}
WalkExpr(nd)
@ -474,8 +479,9 @@ WalkExpr(nd)
CodePExpr(nd);
}
WalkDesignator(nd)
WalkDesignator(nd, ds)
struct node *nd;
struct desig *ds;
{
/* Check designator and generate code for it
*/
@ -484,8 +490,8 @@ WalkDesignator(nd)
if (! chk_designator(nd, DESIGNATOR|VARIABLE, D_DEFINED)) return;
Desig = InitDesig;
CodeDesig(nd, &Desig);
*ds = InitDesig;
CodeDesig(nd, ds);
}
DoForInit(nd, left)
@ -527,13 +533,13 @@ DoAssign(nd, left, right)
register struct node *left, *right;
{
/* May we do it in this order (expression first) ??? */
struct desig ds;
struct desig dsl, dsr;
if (!chk_expr(right)) return;
if (! chk_designator(left, DESIGNATOR|VARIABLE, D_DEFINED)) return;
TryToString(right, left->nd_type);
Desig = InitDesig;
CodeExpr(right, &Desig, NO_LABEL, NO_LABEL);
dsr = InitDesig;
CodeExpr(right, &dsr, NO_LABEL, NO_LABEL);
if (! TstAssCompat(left->nd_type, right->nd_type)) {
node_error(nd, "type incompatibility in assignment");
@ -541,17 +547,44 @@ DoAssign(nd, left, right)
}
if (complex(right->nd_type)) {
CodeAddress(&Desig);
CodeAddress(&dsr);
}
else {
CodeValue(&Desig, right->nd_type->tp_size);
CodeValue(&dsr, right->nd_type->tp_size);
CheckAssign(left->nd_type, right->nd_type);
}
ds = Desig;
Desig = InitDesig;
CodeDesig(left, &Desig);
dsl = InitDesig;
CodeDesig(left, &dsl);
CodeAssign(nd, &ds, &Desig);
CodeAssign(nd, &dsr, &dsl);
}
RegisterMessages(df)
register struct def *df;
{
struct type *tp;
for (; df; df = df->df_nextinscope) {
if (df->df_kind == D_VARIABLE && !(df->df_flags & D_NOREG)) {
/* Examine type and size
*/
tp = df->df_type;
if (tp->tp_fund == T_SUBRANGE) tp = tp->next;
if ((tp->tp_fund & T_NUMERIC) &&
tp->tp_size <= dword_size) {
C_ms_reg(df->var_off,
tp->tp_size,
tp->tp_fund == T_REAL ?
reg_float : reg_any,
0);
}
else if ((df->df_flags & D_VARPAR) ||
tp->tp_fund == T_POINTER) {
C_ms_reg(df->var_off, pointer_size,
reg_pointer, 0);
}
}
}
}
#ifdef DEBUG