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

Changes to make node structure smaller, and cleaned up a bit

Browse source
This commit is contained in:
ceriel 1991-03-12 16:52:00 +00:00
parent 20b17c3eb2
commit 0a517b9256
25 changed files with 950 additions and 817 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
lang/m2/comp/.distr
View file

@ -13,7 +13,6 @@ chk_expr.c
chk_expr.h
class.h
code.c
const.h
cstoper.c
debug.h
declar.g

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

@ -27,7 +27,6 @@
#include "idf.h"
#include "def.h"
#include "type.h"
#include "const.h"
#include "warning.h"
extern long str2long();

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

@ -18,31 +18,47 @@ struct string {
char *s_str; /* the string itself */
};
union tk_attr {
struct string *tk_str;
arith tk_int;
struct real *tk_real;
struct {
union {
arith *tky_set;
struct idf *tky_idf;
struct def *tky_def;
} tk_yy;
struct node *tky_next;
} tk_y;
struct {
struct node *tkx_left, *tkx_right;
} tk_x;
};
#define tk_left tk_x.tkx_left
#define tk_right tk_x.tkx_right
#define tk_next tk_y.tky_next
#define tk_idf tk_y.tk_yy.tky_idf
#define tk_def tk_y.tk_yy.tky_def
#define tk_set tk_y.tk_yy.tky_set
/* Token structure. Keep it small, as it is part of a parse-tree node
*/
struct token {
short tk_symb; /* token itself */
unsigned short tk_lineno; /* linenumber on which it occurred */
union {
struct idf *tk_idf; /* IDENT */
struct string *tk_str; /* STRING */
arith tk_int; /* INTEGER */
struct real *tk_real; /* REAL */
arith *tk_set; /* only used in parse tree node */
struct def *tk_def; /* only used in parse tree node */
} tk_data;
union tk_attr tk_data;
};
typedef struct token t_token;
#define TOK_IDF tk_data.tk_idf
#define TOK_SSTR tk_data.tk_str
#define TOK_STR tk_data.tk_str->s_str
#define TOK_SLE tk_data.tk_str->s_length
#define TOK_INT tk_data.tk_int
#define TOK_REAL tk_data.tk_real
#define TOK_RSTR tk_data.tk_real->r_real
#define TOK_RVAL tk_data.tk_real->r_val
#define TOK_IDF tk_data.tk_idf
#define TOK_SSTR tk_data.tk_str
#define TOK_STR tk_data.tk_str->s_str
#define TOK_SLE tk_data.tk_str->s_length
#define TOK_INT tk_data.tk_int
#define TOK_REAL tk_data.tk_real
#define TOK_RSTR tk_data.tk_real->r_real
#define TOK_RVAL tk_data.tk_real->r_val
extern t_token dot, aside;
extern struct type *toktype;

8
lang/m2/comp/Makefile
View file

@ -79,7 +79,7 @@ GENH = errout.h \
def.h debugcst.h type.h Lpars.h node.h desig.h strict3rd.h real.h \
use_insert.h dbsymtab.h
HFILES =LLlex.h \
chk_expr.h class.h const.h debug.h f_info.h idf.h \
chk_expr.h class.h debug.h f_info.h idf.h \
input.h main.h misc.h scope.h standards.h tokenname.h \
walk.h warning.h SYSTEM.h $(GENH)
#
@ -212,7 +212,6 @@ LLlex.o: LLlex.h
LLlex.o: Lpars.h
LLlex.o: bigparam.h
LLlex.o: class.h
LLlex.o: const.h
LLlex.o: dbsymtab.h
LLlex.o: debug.h
LLlex.o: debugcst.h
@ -278,7 +277,6 @@ input.o: inputtype.h
type.o: LLlex.h
type.o: bigparam.h
type.o: chk_expr.h
type.o: const.h
type.o: dbsymtab.h
type.o: debug.h
type.o: debugcst.h
@ -381,7 +379,6 @@ node.o: type.h
cstoper.o: LLlex.h
cstoper.o: Lpars.h
cstoper.o: bigparam.h
cstoper.o: const.h
cstoper.o: dbsymtab.h
cstoper.o: debug.h
cstoper.o: debugcst.h
@ -397,7 +394,6 @@ chk_expr.o: LLlex.h
chk_expr.o: Lpars.h
chk_expr.o: bigparam.h
chk_expr.o: chk_expr.h
chk_expr.o: const.h
chk_expr.o: dbsymtab.h
chk_expr.o: debug.h
chk_expr.o: debugcst.h
@ -502,7 +498,6 @@ lookup.o: target_sizes.h
lookup.o: type.h
stab.o: LLlex.h
stab.o: bigparam.h
stab.o: const.h
stab.o: dbsymtab.h
stab.o: def.h
stab.o: idf.h
@ -556,7 +551,6 @@ expression.o: LLlex.h
expression.o: Lpars.h
expression.o: bigparam.h
expression.o: chk_expr.h
expression.o: const.h
expression.o: dbsymtab.h
expression.o: debug.h
expression.o: debugcst.h

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

@ -97,25 +97,25 @@ CaseCode(nd, exitlabel, end_reached)
assert(pnode->nd_class == Stat && pnode->nd_symb == CASE);
if (ChkExpression(pnode->nd_left)) {
MkCoercion(&(pnode->nd_left),BaseType(pnode->nd_left->nd_type));
CodePExpr(pnode->nd_left);
if (ChkExpression(&(pnode->nd_LEFT))) {
MkCoercion(&(pnode->nd_LEFT),BaseType(pnode->nd_LEFT->nd_type));
CodePExpr(pnode->nd_LEFT);
}
sh->sh_type = pnode->nd_left->nd_type;
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 = pnode->nd_RIGHT) {
if (pnode->nd_class == Link && pnode->nd_symb == '|') {
if (pnode->nd_left) {
if (pnode->nd_LEFT) {
/* non-empty case
*/
pnode->nd_left->nd_lab = ++text_label;
pnode->nd_LEFT->nd_lab = ++text_label;
AddCases(sh, /* to descriptor */
pnode->nd_left->nd_left,
pnode->nd_LEFT->nd_LEFT,
/* of case labels */
(label) pnode->nd_left->nd_lab
(label) pnode->nd_LEFT->nd_lab
/* and code label */
);
}
@ -192,11 +192,11 @@ CaseCode(nd, exitlabel, end_reached)
*/
pnode = nd;
rval = 0;
while (pnode = pnode->nd_right) {
while (pnode = pnode->nd_RIGHT) {
if (pnode->nd_class == Link && pnode->nd_symb == '|') {
if (pnode->nd_left) {
rval |= LblWalkNode((label) pnode->nd_left->nd_lab,
pnode->nd_left->nd_right,
if (pnode->nd_LEFT) {
rval |= LblWalkNode((label) pnode->nd_LEFT->nd_lab,
pnode->nd_LEFT->nd_RIGHT,
exitlabel, end_reached);
C_bra(sh->sh_break);
}
@ -245,16 +245,16 @@ AddCases(sh, node, lbl)
if (node->nd_class == Link) {
if (node->nd_symb == UPTO) {
assert(node->nd_left->nd_class == Value);
assert(node->nd_right->nd_class == Value);
assert(node->nd_LEFT->nd_class == Value);
assert(node->nd_RIGHT->nd_class == Value);
AddOneCase(sh, node->nd_left, node->nd_right, lbl);
AddOneCase(sh, node->nd_LEFT, node->nd_RIGHT, lbl);
return;
}
assert(node->nd_symb == ',');
AddCases(sh, node->nd_left, lbl);
AddCases(sh, node->nd_right, lbl);
AddCases(sh, node->nd_LEFT, lbl);
AddCases(sh, node->nd_RIGHT, lbl);
return;
}

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

File diff suppressed because it is too large Load diff

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

@ -16,9 +16,8 @@ extern int (*DesigChkTable[])(); /* table of designator checking
functions, indexed by node class
*/
#define ChkExpression(expp) ((*ExprChkTable[(expp)->nd_class])(expp,D_USED))
#define ChkDesignator(expp) ((*DesigChkTable[(expp)->nd_class])(expp,0))
#define ChkDesig(expp, flags) ((*DesigChkTable[(expp)->nd_class])(expp,flags))
#define ChkExpression(expp) ((*ExprChkTable[(*expp)->nd_class])(expp,D_USED))
#define ChkDesig(expp, flags) ((*DesigChkTable[(*expp)->nd_class])(expp,flags))
/* handle reference counts for sets */
#define inc_refcount(s) (*((int *)(s) - 1) += 1)

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

@ -38,19 +38,6 @@ extern int proclevel;
extern char options[];
int fp_used;
STATIC char *
NameOfProc(df)
register t_def *df;
{
assert(df->df_kind & (D_PROCHEAD|D_PROCEDURE));
if (df->df_kind == D_PROCEDURE) {
return df->prc_vis->sc_scope->sc_name;
}
return df->for_name;
}
CodeConst(cst, size)
arith cst;
int size;
@ -100,7 +87,7 @@ CodeExpr(nd, ds, true_label, false_label)
switch(nd->nd_class) {
case Def:
if (nd->nd_def->df_kind & (D_PROCEDURE|D_PROCHEAD)) {
C_lpi(NameOfProc(nd->nd_def));
C_lpi(nd->nd_def->prc_name);
ds->dsg_kind = DSG_LOADED;
break;
}
@ -317,7 +304,7 @@ CodeCall(nd)
/* Generate code for a procedure call. Checking of parameters
and result is already done.
*/
register t_node *left = nd->nd_left;
register t_node *left = nd->nd_LEFT;
t_type *result_tp;
int needs_fn;
@ -335,8 +322,8 @@ CodeCall(nd)
}
#endif
if (nd->nd_right) {
CodeParameters(ParamList(left->nd_type), nd->nd_right);
if (nd->nd_RIGHT) {
CodeParameters(ParamList(left->nd_type), nd->nd_RIGHT);
}
switch(left->nd_class) {
@ -353,7 +340,7 @@ CodeCall(nd)
C_lxl((arith) (proclevel - level));
}
needs_fn = df->df_scope->sc_defmodule;
C_cal(NameOfProc(df));
C_cal(df->prc_name);
break;
}}
/* Fall through */
@ -379,32 +366,31 @@ CodeCall(nd)
CodeParameters(param, arg)
t_param *param;
t_node *arg;
register t_node *arg;
{
register t_type *tp;
register t_node *left;
register t_type *left_type;
register t_type *arg_type;
assert(param != 0 && arg != 0);
if (param->par_next) {
CodeParameters(param->par_next, arg->nd_right);
CodeParameters(param->par_next, arg->nd_RIGHT);
}
tp = TypeOfParam(param);
left = arg->nd_left;
left_type = left->nd_type;
arg = arg->nd_LEFT;
arg_type = arg->nd_type;
if (IsConformantArray(tp)) {
register t_type *elem = tp->arr_elem;
C_loc(tp->arr_elsize);
if (IsConformantArray(left_type)) {
DoHIGH(left->nd_def);
if (elem->tp_size != left_type->arr_elem->tp_size) {
if (IsConformantArray(arg_type)) {
DoHIGH(arg->nd_def);
if (elem->tp_size != arg_type->arr_elem->tp_size) {
/* This can only happen if the formal type is
ARRAY OF (WORD|BYTE)
*/
C_loc(left_type->arr_elem->tp_size);
C_loc(arg_type->arr_elem->tp_size);
C_mli(word_size);
if (elem == word_type) {
c_loc((int) word_size - 1);
@ -417,47 +403,47 @@ CodeParameters(param, arg)
}
}
}
else if (left->nd_symb == STRING) {
C_loc((arith)(left->nd_SLE - 1));
else if (arg->nd_symb == STRING) {
C_loc((arith)(arg->nd_SLE - 1));
}
else if (elem == word_type) {
C_loc((left_type->tp_size+word_size-1) / word_size - 1);
C_loc((arg_type->tp_size+word_size-1) / word_size - 1);
}
else if (elem == byte_type) {
C_loc(left_type->tp_size - 1);
C_loc(arg_type->tp_size - 1);
}
else {
C_loc(left_type->arr_high - left_type->arr_low);
C_loc(arg_type->arr_high - arg_type->arr_low);
}
c_loc(0);
}
if (IsConformantArray(tp) || IsVarParam(param) || IsBigParamTp(tp)) {
if (left->nd_symb == STRING) {
CodeString(left);
if (arg->nd_symb == STRING) {
CodeString(arg);
}
else switch(left->nd_class) {
else switch(arg->nd_class) {
case Arrsel:
case Arrow:
case Def:
CodeDAddress(left, IsVarParam(param));
CodeDAddress(arg, IsVarParam(param));
break;
default:{
arith tmp, TmpSpace();
CodePExpr(left);
tmp = TmpSpace(left->nd_type->tp_size, left->nd_type->tp_align);
STL(tmp, WA(left->nd_type->tp_size));
CodePExpr(arg);
tmp = TmpSpace(arg->nd_type->tp_size, arg->nd_type->tp_align);
STL(tmp, WA(arg->nd_type->tp_size));
C_lal(tmp);
}
break;
}
return;
}
if (left_type->tp_fund == T_STRING) {
CodePString(left, tp);
if (arg_type->tp_fund == T_STRING) {
CodePString(arg, tp);
return;
}
CodePExpr(left);
CodePExpr(arg);
}
CodePString(nd, tp)
@ -499,15 +485,15 @@ addu(sz)
CodeStd(nd)
t_node *nd;
{
register t_node *arg = nd->nd_right;
register t_node *arg = nd->nd_RIGHT;
register t_node *left = 0;
register t_type *tp = 0;
int std = nd->nd_left->nd_def->df_value.df_stdname;
int std = nd->nd_LEFT->nd_def->df_value.df_stdname;
if (arg) {
left = arg->nd_left;
left = arg->nd_LEFT;
tp = BaseType(left->nd_type);
arg = arg->nd_right;
arg = arg->nd_RIGHT;
}
switch(std) {
@ -573,8 +559,8 @@ CodeStd(nd)
CodePExpr(left);
CodeCoercion(left->nd_type, tp);
if (arg) {
CodePExpr(arg->nd_left);
CodeCoercion(arg->nd_left->nd_type, tp);
CodePExpr(arg->nd_LEFT);
CodeCoercion(arg->nd_LEFT->nd_type, tp);
}
else {
c_loc(1);
@ -603,7 +589,7 @@ CodeStd(nd)
case S_INCL:
case S_EXCL:
CodePExpr(left);
CodePExpr(arg->nd_left);
CodePExpr(arg->nd_LEFT);
C_loc(tp->set_low);
C_sbi(word_size);
C_set(tp->tp_size);
@ -668,8 +654,8 @@ Operands(nd)
register t_node *nd;
{
CodePExpr(nd->nd_left);
CodePExpr(nd->nd_right);
CodePExpr(nd->nd_LEFT);
CodePExpr(nd->nd_RIGHT);
DoLineno(nd);
}
@ -678,8 +664,8 @@ CodeOper(expr, true_label, false_label)
label true_label;
label false_label; /* labels to jump to in logical expr's */
{
register t_node *leftop = expr->nd_left;
register t_node *rightop = expr->nd_right;
register t_node *leftop = expr->nd_LEFT;
register t_node *rightop = expr->nd_RIGHT;
register t_type *tp = expr->nd_type;
switch (expr->nd_symb) {
@ -991,7 +977,7 @@ CodeUoper(nd)
{
register t_type *tp = nd->nd_type;
CodePExpr(nd->nd_right);
CodePExpr(nd->nd_RIGHT);
switch(nd->nd_symb) {
case NOT:
C_teq();
@ -1010,8 +996,8 @@ CodeUoper(nd)
}
break;
case COERCION:
CodeCoercion(nd->nd_right->nd_type, tp);
RangeCheck(tp, nd->nd_right->nd_type);
CodeCoercion(nd->nd_RIGHT->nd_type, tp);
RangeCheck(tp, nd->nd_RIGHT->nd_type);
break;
case CAST:
break;
@ -1025,12 +1011,12 @@ CodeSet(nd)
{
register t_type *tp = nd->nd_type;
nd = nd->nd_right;
nd = nd->nd_NEXT;
while (nd) {
assert(nd->nd_class == Link && nd->nd_symb == ',');
if (nd->nd_left) CodeEl(nd->nd_left, tp);
nd = nd->nd_right;
if (nd->nd_LEFT) CodeEl(nd->nd_LEFT, tp);
nd = nd->nd_RIGHT;
}
}

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

@ -24,16 +24,19 @@
#include "Lpars.h"
#include "standards.h"
#include "warning.h"
#include "const.h"
extern char *symbol2str();
#define arith_sign ((arith) (1L << (sizeof(arith) * 8 - 1)))
arith full_mask[MAXSIZE];/* full_mask[1] == 0xFF, full_mask[2] == 0xFFFF, .. */
arith max_int[MAXSIZE]; /* max_int[1] == 0x7F, max_int[2] == 0x7FFF, .. */
arith min_int[MAXSIZE]; /* min_int[1] == 0xFFFFFF80, min_int[2] = 0xFFFF8000,
...
*/
#ifndef NOCROSS
unsigned int wrd_bits; /* number of bits in a word */
#endif
extern char options[];
@ -55,24 +58,28 @@ underflow(expp)
STATIC
commonbin(expp)
register t_node *expp;
register t_node **expp;
{
expp->nd_class = Value;
expp->nd_token = expp->nd_right->nd_token;
CutSize(expp);
FreeLR(expp);
register t_type *tp = (*expp)->nd_type;
register t_node *right = (*expp)->nd_RIGHT;
(*expp)->nd_RIGHT = 0;
FreeNode(*expp);
*expp = right;
right->nd_type = tp;
}
cstunary(expp)
register t_node *expp;
t_node **expp;
{
/* The unary operation in "expp" is performed on the constant
expression below it, and the result restored in expp.
*/
register t_node *right = expp->nd_right;
register t_node *exp = *expp;
register t_node *right = exp->nd_RIGHT;
register arith o1 = right->nd_INT;
switch(expp->nd_symb) {
switch(exp->nd_symb) {
/* Should not get here
case '+':
break;
@ -80,7 +87,7 @@ cstunary(expp)
case '-':
if (o1 == min_int[(int)(right->nd_type->tp_size)]) {
overflow(expp);
overflow(exp);
}
o1 = -o1;
break;
@ -95,7 +102,8 @@ cstunary(expp)
}
commonbin(expp);
expp->nd_INT = o1;
(*expp)->nd_INT = o1;
CutSize(*expp);
}
STATIC
@ -149,41 +157,42 @@ divide(pdiv, prem)
}
cstibin(expp)
register t_node *expp;
t_node **expp;
{
/* The binary operation in "expp" is performed on the constant
expressions below it, and the result restored in expp.
This version is for INTEGER expressions.
*/
register arith o1 = expp->nd_left->nd_INT;
register arith o2 = expp->nd_right->nd_INT;
register int sz = expp->nd_type->tp_size;
register t_node *exp = *expp;
register arith o1 = exp->nd_LEFT->nd_INT;
register arith o2 = exp->nd_RIGHT->nd_INT;
register int sz = exp->nd_type->tp_size;
assert(expp->nd_class == Oper);
assert(expp->nd_left->nd_class == Value);
assert(expp->nd_right->nd_class == Value);
assert(exp->nd_class == Oper);
assert(exp->nd_LEFT->nd_class == Value);
assert(exp->nd_RIGHT->nd_class == Value);
switch (expp->nd_symb) {
switch (exp->nd_symb) {
case '*':
if (o1 > 0 && o2 > 0) {
if (max_int[sz] / o1 < o2) overflow(expp);
if (max_int[sz] / o1 < o2) overflow(exp);
}
else if (o1 < 0 && o2 < 0) {
if (o1 == min_int[sz] || o2 == min_int[sz] ||
max_int[sz] / (-o1) < (-o2)) overflow(expp);
max_int[sz] / (-o1) < (-o2)) overflow(exp);
}
else if (o1 > 0) {
if (min_int[sz] / o1 > o2) overflow(expp);
if (min_int[sz] / o1 > o2) overflow(exp);
}
else if (o2 > 0) {
if (min_int[sz] / o2 > o1) overflow(expp);
if (min_int[sz] / o2 > o1) overflow(exp);
}
o1 *= o2;
break;
case DIV:
if (o2 == 0) {
node_error(expp, "division by 0");
node_error(exp, "division by 0");
return;
}
if ((o1 < 0) != (o2 < 0)) {
@ -197,7 +206,7 @@ cstibin(expp)
break;
case MOD:
if (o2 == 0) {
node_error(expp, "modulo by 0");
node_error(exp, "modulo by 0");
return;
}
if ((o1 < 0) != (o2 < 0)) {
@ -212,20 +221,20 @@ cstibin(expp)
case '+':
if (o1 > 0 && o2 > 0) {
if (max_int[sz] - o1 < o2) overflow(expp);
if (max_int[sz] - o1 < o2) overflow(exp);
}
else if (o1 < 0 && o2 < 0) {
if (min_int[sz] - o1 > o2) overflow(expp);
if (min_int[sz] - o1 > o2) overflow(exp);
}
o1 += o2;
break;
case '-':
if (o1 >= 0 && o2 < 0) {
if (max_int[sz] + o2 < o1) overflow(expp);
if (max_int[sz] + o2 < o1) overflow(exp);
}
else if (o1 < 0 && o2 >= 0) {
if (min_int[sz] + o2 > o1) overflow(expp);
if (min_int[sz] + o2 > o1) overflow(exp);
}
o1 -= o2;
break;
@ -259,27 +268,29 @@ cstibin(expp)
}
commonbin(expp);
expp->nd_INT = o1;
(*expp)->nd_INT = o1;
CutSize(*expp);
}
cstfbin(expp)
register t_node *expp;
t_node **expp;
{
/* The binary operation in "expp" is performed on the constant
expressions below it, and the result restored in expp.
This version is for REAL expressions.
*/
register struct real *p = expp->nd_left->nd_REAL;
register t_node *exp = *expp;
register struct real *p = exp->nd_LEFT->nd_REAL;
register flt_arith *o1 = &p->r_val;
register flt_arith *o2 = &expp->nd_right->nd_RVAL;
register flt_arith *o2 = &exp->nd_RIGHT->nd_RVAL;
int compar = 0;
int cmpval = 0;
assert(expp->nd_class == Oper);
assert(expp->nd_left->nd_class == Value);
assert(expp->nd_right->nd_class == Value);
assert(exp->nd_class == Oper);
assert(exp->nd_LEFT->nd_class == Value);
assert(exp->nd_RIGHT->nd_class == Value);
switch (expp->nd_symb) {
switch (exp->nd_symb) {
case '*':
flt_mul(o1, o2, o1);
break;
@ -304,7 +315,7 @@ cstfbin(expp)
case '#':
compar++;
cmpval = flt_cmp(o1, o2);
switch(expp->nd_symb) {
switch(exp->nd_symb) {
case '<': cmpval = (cmpval < 0); break;
case '>': cmpval = (cmpval > 0); break;
case LESSEQUAL: cmpval = (cmpval <= 0); break;
@ -312,8 +323,8 @@ cstfbin(expp)
case '=': cmpval = (cmpval == 0); break;
case '#': cmpval = (cmpval != 0); break;
}
if (expp->nd_right->nd_RSTR) free(expp->nd_right->nd_RSTR);
free_real(expp->nd_right->nd_REAL);
if (exp->nd_RIGHT->nd_RSTR) free(exp->nd_RIGHT->nd_RSTR);
free_real(exp->nd_RIGHT->nd_REAL);
break;
default:
@ -322,11 +333,11 @@ cstfbin(expp)
switch(flt_status) {
case FLT_OVFL:
node_warning(expp, "floating point overflow on %s",
symbol2str(expp->nd_symb));
node_warning(exp, "floating point overflow on %s",
symbol2str(exp->nd_symb));
break;
case FLT_DIV0:
node_error(expp, "division by 0.0");
node_error(exp, "division by 0.0");
break;
}
@ -338,32 +349,35 @@ cstfbin(expp)
free_real(p);
}
commonbin(expp);
exp = *expp;
if (compar) {
expp->nd_symb = INTEGER;
expp->nd_INT = cmpval;
exp->nd_symb = INTEGER;
exp->nd_INT = cmpval;
}
else {
expp->nd_REAL = p;
exp->nd_REAL = p;
}
CutSize(exp);
}
cstubin(expp)
register t_node *expp;
t_node **expp;
{
/* The binary operation in "expp" is performed on the constant
expressions below it, and the result restored in
expp.
*/
arith o1 = expp->nd_left->nd_INT;
arith o2 = expp->nd_right->nd_INT;
register int sz = expp->nd_type->tp_size;
register t_node *exp = *expp;
arith o1 = exp->nd_LEFT->nd_INT;
arith o2 = exp->nd_RIGHT->nd_INT;
register int sz = exp->nd_type->tp_size;
arith tmp1, tmp2;
assert(expp->nd_class == Oper);
assert(expp->nd_left->nd_class == Value);
assert(expp->nd_right->nd_class == Value);
assert(exp->nd_class == Oper);
assert(exp->nd_LEFT->nd_class == Value);
assert(exp->nd_RIGHT->nd_class == Value);
switch (expp->nd_symb) {
switch (exp->nd_symb) {
case '*':
if (o1 == 0 || o2 == 0) {
o1 = 0;
@ -372,13 +386,13 @@ cstubin(expp)
tmp1 = full_mask[sz];
tmp2 = o2;
divide(&tmp1, &tmp2);
if (! chk_bounds(o1, tmp1, T_CARDINAL)) overflow(expp);
if (! chk_bounds(o1, tmp1, T_CARDINAL)) overflow(exp);
o1 *= o2;
break;
case DIV:
if (o2 == 0) {
node_error(expp, "division by 0");
node_error(exp, "division by 0");
return;
}
divide(&o1, &o2);
@ -386,7 +400,7 @@ cstubin(expp)
case MOD:
if (o2 == 0) {
node_error(expp, "modulo by 0");
node_error(exp, "modulo by 0");
return;
}
divide(&o1, &o2);
@ -395,20 +409,20 @@ cstubin(expp)
case '+':
if (! chk_bounds(o2, full_mask[sz] - o1, T_CARDINAL)) {
overflow(expp);
overflow(exp);
}
o1 += o2;
break;
case '-':
if (! chk_bounds(o2, o1, T_CARDINAL)) {
if (expp->nd_type->tp_fund == T_INTORCARD) {
expp->nd_type = int_type;
if (exp->nd_type->tp_fund == T_INTORCARD) {
exp->nd_type = int_type;
if (! chk_bounds(min_int[sz], o1 - o2, T_CARDINAL)) {
underflow(expp);
underflow(exp);
}
}
else underflow(expp);
else underflow(exp);
}
o1 -= o2;
break;
@ -451,75 +465,81 @@ cstubin(expp)
}
commonbin(expp);
expp->nd_INT = o1;
if (expp->nd_type == bool_type) expp->nd_symb = INTEGER;
exp = *expp;
exp->nd_INT = o1;
if (exp->nd_type == bool_type) exp->nd_symb = INTEGER;
CutSize(exp);
}
cstset(expp)
register t_node *expp;
t_node **expp;
{
extern arith *MkSet();
register arith *set1, *set2;
register arith *resultset;
register t_node *exp = *expp;
register arith *set1, *set2, *set3;
register unsigned int setsize;
register int j;
assert(expp->nd_right->nd_class == Set);
assert(expp->nd_symb == IN || expp->nd_left->nd_class == Set);
assert(exp->nd_RIGHT->nd_class == Set);
assert(exp->nd_symb == IN || exp->nd_LEFT->nd_class == Set);
set2 = expp->nd_right->nd_set;
setsize = (unsigned) (expp->nd_right->nd_type->tp_size) / (unsigned) word_size;
set2 = exp->nd_RIGHT->nd_set;
setsize = (unsigned) (exp->nd_RIGHT->nd_type->tp_size) / (unsigned) word_size;
if (expp->nd_symb == IN) {
if (exp->nd_symb == IN) {
/* The setsize must fit in an unsigned, as it is
allocated with Malloc, so we can do the arithmetic
in an unsigned too.
*/
unsigned i;
assert(expp->nd_left->nd_class == Value);
assert(exp->nd_LEFT->nd_class == Value);
expp->nd_left->nd_INT -= expp->nd_right->nd_type->set_low;
i = expp->nd_left->nd_INT;
expp->nd_class = Value;
/* Careful here; use expp->nd_left->nd_INT to see if
exp->nd_LEFT->nd_INT -= exp->nd_RIGHT->nd_type->set_low;
i = exp->nd_LEFT->nd_INT;
/* Careful here; use exp->nd_LEFT->nd_INT to see if
it falls in the range of the set. Do not use i
for this, as i may be truncated.
*/
expp->nd_INT = (expp->nd_left->nd_INT >= 0 &&
expp->nd_left->nd_INT < setsize * wrd_bits &&
i = (exp->nd_LEFT->nd_INT >= 0 &&
exp->nd_LEFT->nd_INT < setsize * wrd_bits &&
(set2[i / wrd_bits] & (1 << (i % wrd_bits))));
FreeSet(set2);
expp->nd_symb = INTEGER;
FreeLR(expp);
exp = getnode(Value);
exp->nd_symb = INTEGER;
exp->nd_lineno = (*expp)->nd_lineno;
exp->nd_INT = i;
exp->nd_type = bool_type;
FreeNode(*expp);
*expp = exp;
return;
}
set1 = expp->nd_left->nd_set;
switch(expp->nd_symb) {
set1 = exp->nd_LEFT->nd_set;
*expp = MkLeaf(Set, &(exp->nd_RIGHT->nd_token));
(*expp)->nd_type = exp->nd_type;
switch(exp->nd_symb) {
case '+': /* Set union */
case '-': /* Set difference */
case '*': /* Set intersection */
case '/': /* Symmetric set difference */
expp->nd_set = resultset = MkSet(expp->nd_type->set_sz);
(*expp)->nd_set = set3 = MkSet(exp->nd_type->set_sz);
for (j = 0; j < setsize; j++) {
switch(expp->nd_symb) {
switch(exp->nd_symb) {
case '+':
*resultset = *set1++ | *set2++;
*set3++ = *set1++ | *set2++;
break;
case '-':
*resultset = *set1++ & ~*set2++;
*set3++ = *set1++ & ~*set2++;
break;
case '*':
*resultset = *set1++ & *set2++;
*set3++ = *set1++ & *set2++;
break;
case '/':
*resultset = *set1++ ^ *set2++;
*set3++ = *set1++ ^ *set2++;
break;
}
resultset++;
}
expp->nd_class = Set;
break;
case GREATEREQUAL:
@ -529,7 +549,7 @@ cstset(expp)
/* Constant set comparisons
*/
for (j = 0; j < setsize; j++) {
switch(expp->nd_symb) {
switch(exp->nd_symb) {
case GREATEREQUAL:
if ((*set1 | *set2++) != *set1) break;
set1++;
@ -546,24 +566,27 @@ cstset(expp)
break;
}
if (j < setsize) {
expp->nd_INT = expp->nd_symb == '#';
j = exp->nd_symb == '#';
}
else {
expp->nd_INT = expp->nd_symb != '#';
j = exp->nd_symb != '#';
}
expp->nd_class = Value;
expp->nd_symb = INTEGER;
*expp = getnode(Value);
(*expp)->nd_symb = INTEGER;
(*expp)->nd_INT = j;
(*expp)->nd_type = bool_type;
(*expp)->nd_lineno = (*expp)->nd_lineno;
break;
default:
crash("(cstset)");
}
FreeSet(expp->nd_left->nd_set);
FreeSet(expp->nd_right->nd_set);
FreeLR(expp);
FreeSet(exp->nd_LEFT->nd_set);
FreeSet(exp->nd_RIGHT->nd_set);
FreeNode(exp);
}
cstcall(expp, call)
register t_node *expp;
t_node **expp;
{
/* a standard procedure call is found that can be evaluated
compile time, so do so.
@ -571,69 +594,69 @@ cstcall(expp, call)
register t_node *expr;
register t_type *tp;
assert(expp->nd_class == Call);
expr = expp->nd_right->nd_left;
assert((*expp)->nd_class == Call);
expr = (*expp)->nd_RIGHT->nd_LEFT;
tp = expr->nd_type;
expr->nd_type = (*expp)->nd_type;
expp->nd_class = Value;
expp->nd_symb = INTEGER;
expp->nd_INT = expr->nd_INT;
(*expp)->nd_RIGHT->nd_LEFT = 0;
FreeNode(*expp);
*expp = expr;
expr->nd_symb = INTEGER;
expr->nd_class = Value;
switch(call) {
case S_ABS:
if (expp->nd_INT < 0) {
if (expp->nd_INT <= min_int[(int)(tp->tp_size)]) {
if (expr->nd_INT < 0) {
if (expr->nd_INT <= min_int[(int)(tp->tp_size)]) {
overflow(expr);
}
expp->nd_INT = - expp->nd_INT;
expr->nd_INT = - expr->nd_INT;
}
CutSize(expp);
CutSize(expr);
break;
case S_CAP:
if (expp->nd_INT >= 'a' && expp->nd_INT <= 'z') {
expp->nd_INT += ('A' - 'a');
if (expr->nd_INT >= 'a' && expr->nd_INT <= 'z') {
expr->nd_INT += ('A' - 'a');
}
break;
case S_HIGH:
case S_MAX:
if (tp->tp_fund == T_INTEGER) {
expp->nd_INT = max_int[(int)(tp->tp_size)];
expr->nd_INT = max_int[(int)(tp->tp_size)];
}
else if (tp == card_type) {
expp->nd_INT = full_mask[(int)(int_size)];
expr->nd_INT = full_mask[(int)(int_size)];
}
else if (tp->tp_fund == T_SUBRANGE) {
expp->nd_INT = tp->sub_ub;
expr->nd_INT = tp->sub_ub;
}
else expp->nd_INT = tp->enm_ncst - 1;
else expr->nd_INT = tp->enm_ncst - 1;
break;
case S_MIN:
if (tp->tp_fund == T_INTEGER) {
expp->nd_INT = min_int[(int)(tp->tp_size)];
expr->nd_INT = min_int[(int)(tp->tp_size)];
}
else if (tp->tp_fund == T_SUBRANGE) {
expp->nd_INT = tp->sub_lb;
expr->nd_INT = tp->sub_lb;
}
else expp->nd_INT = 0;
else expr->nd_INT = 0;
break;
case S_ODD:
expp->nd_INT &= 1;
expr->nd_INT &= 1;
break;
case S_TSIZE:
case S_SIZE:
expp->nd_INT = tp->tp_size;
expr->nd_INT = tp->tp_size;
break;
default:
crash("(cstcall)");
}
expp->nd_right = 0; /* don't deallocate, for further
argument checking
*/
FreeLR(expp);
}
CutSize(expr)
@ -675,5 +698,7 @@ InitCst()
fatal("sizeof (arith) insufficient on this machine");
}
#ifndef NOCROSS
wrd_bits = 8 * (int) word_size;
#endif
}

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

@ -236,14 +236,13 @@ IdentList(t_node **p;)
{
register t_node *q;
} :
IDENT { *p = q = dot2leaf(Value); }
IDENT { *p = q = dot2leaf(Select); }
[ %persistent
',' IDENT
{ q->nd_left = dot2leaf(Value);
q = q->nd_left;
{ q->nd_NEXT = dot2leaf(Select);
q = q->nd_NEXT;
}
]*
{ q->nd_left = 0; }
;
SubrangeType(t_type **ptp;)
@ -360,7 +359,7 @@ FieldList(t_scope *scope; arith *cnt; int *palign;)
else
#endif
error("':' missing");
tp = qualified_type(nd);
tp = qualified_type(&nd);
}
]
| ':' qualtype(&tp)
@ -405,8 +404,8 @@ CaseLabelList(t_type **ptp; t_node **pnd;):
CaseLabels(ptp, pnd)
[
{ *pnd = dot2node(Link, *pnd, NULLNODE); }
',' CaseLabels(ptp, &((*pnd)->nd_right))
{ pnd = &((*pnd)->nd_right); }
',' CaseLabels(ptp, &((*pnd)->nd_RIGHT))
{ pnd = &((*pnd)->nd_RIGHT); }
]*
;
@ -431,15 +430,15 @@ CaseLabels(t_type **ptp; register t_node **pnd;)
}
[
UPTO { *pnd = nd = dot2node(Link,nd,NULLNODE);
nd->nd_type = nd->nd_left->nd_type;
nd->nd_type = nd->nd_LEFT->nd_type;
}
ConstExpression(&(*pnd)->nd_right)
{ if (!ChkCompat(&((*pnd)->nd_right), nd->nd_type,
ConstExpression(&(*pnd)->nd_RIGHT)
{ if (!ChkCompat(&((*pnd)->nd_RIGHT), nd->nd_type,
"case label")) {
nd->nd_type = error_type;
}
else if (! chk_bounds(nd->nd_left->nd_INT,
nd->nd_right->nd_INT,
else if (! chk_bounds(nd->nd_LEFT->nd_INT,
nd->nd_RIGHT->nd_INT,
nd->nd_type->tp_fund)) {
node_error(nd,
"lower bound exceeds upper bound in case label range");
@ -482,7 +481,7 @@ qualtype(t_type **ptp;)
t_node *nd;
} :
qualident(&nd)
{ *ptp = qualified_type(nd); }
{ *ptp = qualified_type(&nd); }
;
ProcedureType(t_type **ptp;)
@ -559,8 +558,8 @@ VariableDeclaration
IdentAddr(&VarList)
{ nd = VarList; }
[ %persistent
',' IdentAddr(&(nd->nd_right))
{ nd = nd->nd_right; }
',' IdentAddr(&(nd->nd_RIGHT))
{ nd = nd->nd_RIGHT; }
]*
':' type(&tp)
{ EnterVarList(VarList, tp, proclevel > 0); }
@ -570,11 +569,12 @@ IdentAddr(t_node **pnd;)
{
register t_node *nd;
} :
IDENT { nd = dot2leaf(Name); }
IDENT { nd = dot2leaf(Name);
*pnd = dot2node(Link, nd, NULLNODE);
}
[ '['
ConstExpression(&(nd->nd_left))
ConstExpression(&(nd->nd_NEXT))
']'
|
]
{ *pnd = nd; }
;

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

@ -48,13 +48,6 @@ struct field {
#define fld_variant df_value.df_field.fd_variant
};
struct dfproc {
struct scopelist *pr_vis; /* scope of procedure */
struct node *pr_body; /* body of this procedure */
#define prc_vis df_value.df_proc.pr_vis
#define prc_body df_value.df_proc.pr_body
};
struct import {
struct def *im_def; /* imported definition */
#define imp_def df_value.df_import.im_def
@ -66,7 +59,9 @@ struct dforward {
char *fo_name;
#define for_node df_value.df_forward.fo_node
#define for_vis df_value.df_forward.fo_vis
#define for_name df_value.df_forward.fo_name
#define prc_vis df_value.df_forward.fo_vis
#define prc_body df_value.df_forward.fo_node
#define prc_name df_value.df_forward.fo_name
};
struct forwtype {
@ -128,8 +123,7 @@ struct def { /* list of definitions for a name */
struct enumval df_enum;
struct field df_field;
struct import df_import;
struct dfproc df_proc;
struct dforward df_forward;
struct dforward df_forward; /* also used for proc */
struct forwtype df_fortype;
int df_stdname; /* define for standard name */
} df_value;

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

@ -259,40 +259,37 @@ DeclProc(type, id)
df->for_node = dot2leaf(Name);
df->df_flags |= D_USED | D_DEFINED;
if (CurrentScope->sc_definedby->df_flags & D_FOREIGN) {
df->for_name = id->id_text;
df->prc_name = id->id_text;
}
else {
sprint(buf,"%s_%s",CurrentScope->sc_name,id->id_text);
df->for_name = Salloc(buf, (unsigned) (strlen(buf)+1));
df->prc_name = Salloc(buf, (unsigned) (strlen(buf)+1));
}
if (CurrVis == Defined->mod_vis) {
/* The current module will define this routine.
make sure the name is exported.
*/
C_exp(df->for_name);
C_exp(df->prc_name);
}
}
else {
char *name;
df = lookup(id, CurrentScope, D_IMPORTED, 0);
if (df && df->df_kind == D_PROCHEAD) {
/* C_exp already generated when we saw the definition
in the definition module
*/
name = df->for_name;
DefInFront(df);
}
else {
df = define(id, CurrentScope, type);
sprint(buf,"_%d_%s",++nmcount,id->id_text);
name = Salloc(buf, (unsigned)(strlen(buf)+1));
df->prc_name = Salloc(buf, (unsigned)(strlen(buf)+1));
internal(buf);
df->df_flags |= D_DEFINED;
}
open_scope(OPENSCOPE);
scope = CurrentScope;
scope->sc_name = name;
scope->sc_name = df->prc_name;
scope->sc_definedby = df;
}
df->prc_vis = CurrVis;

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

@ -131,7 +131,7 @@ GetDefinitionModule(id, incr)
n = dot2leaf(Def);
n->nd_def = newsc->sc_definedby;
if (nd_end) nd_end->nd_left = n;
if (nd_end) nd_end->nd_NEXT = n;
else Modules = n;
nd_end = n;
}

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

@ -629,7 +629,7 @@ CodeDesig(nd, ds)
switch(nd->nd_class) { /* Divide */
case Def:
df = nd->nd_def;
if (nd->nd_left) CodeDesig(nd->nd_left, ds);
if (nd->nd_NEXT) CodeDesig(nd->nd_NEXT, ds);
switch(df->df_kind) {
case D_FIELD:
@ -648,10 +648,10 @@ CodeDesig(nd, ds)
case Arrsel:
assert(nd->nd_symb == '[' || nd->nd_symb == ',');
CodeDesig(nd->nd_left, ds);
CodeDesig(nd->nd_LEFT, ds);
CodeAddress(ds);
CodePExpr(nd->nd_right);
nd = nd->nd_left;
CodePExpr(nd->nd_RIGHT);
nd = nd->nd_LEFT;
/* Now load address of descriptor
*/
@ -681,7 +681,7 @@ CodeDesig(nd, ds)
case Arrow:
assert(nd->nd_symb == '^');
nd = nd->nd_right;
nd = nd->nd_RIGHT;
CodeDesig(nd, ds);
switch(ds->dsg_kind) {
case DSG_LOADED:

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

@ -75,7 +75,7 @@ EnterEnumList(Idlist, type)
register t_node *idlist = Idlist;
type->enm_ncst = 0;
for (; idlist; idlist = idlist->nd_left) {
for (; idlist; idlist = idlist->nd_NEXT) {
df = define(idlist->nd_IDF, CurrentScope, D_ENUM);
df->df_type = type;
df->enm_val = (type->enm_ncst)++;
@ -102,7 +102,7 @@ EnterFieldList(Idlist, type, scope, addr)
register t_def *df;
register t_node *idlist = Idlist;
for (; idlist; idlist = idlist->nd_left) {
for (; idlist; idlist = idlist->nd_NEXT) {
df = define(idlist->nd_IDF, scope, D_FIELD);
df->df_type = type;
df->df_flags |= D_QEXPORTED;
@ -134,20 +134,20 @@ EnterVarList(Idlist, type, local)
while (sc->sc_scope->sc_scopeclosed) sc = enclosing(sc);
}
for (; idlist; idlist = idlist->nd_right) {
df = define(idlist->nd_IDF, CurrentScope, D_VARIABLE);
for (; idlist; idlist = idlist->nd_RIGHT) {
df = define(idlist->nd_LEFT->nd_IDF, CurrentScope, D_VARIABLE);
df->df_type = type;
if (idlist->nd_left) {
if (idlist->nd_LEFT->nd_NEXT) {
/* An address was supplied
*/
register t_type *tp = idlist->nd_left->nd_type;
register t_type *tp = idlist->nd_LEFT->nd_NEXT->nd_type;
df->df_flags |= D_ADDRGIVEN | D_NOREG;
if (tp != error_type && !(tp->tp_fund & T_CARDINAL)){
node_error(idlist->nd_left,
node_error(idlist->nd_LEFT->nd_NEXT,
"illegal type for address");
}
df->var_off = idlist->nd_left->nd_INT;
df->var_off = idlist->nd_LEFT->nd_NEXT->nd_INT;
}
else if (local) {
/* subtract aligned size of variable to the offset,
@ -211,7 +211,7 @@ EnterParamList(ppr, Idlist, type, VARp, off)
/* Can only happen when a procedure type is defined */
dummy = Idlist = idlist = dot2leaf(Name);
}
for ( ; idlist; idlist = idlist->nd_left) {
for ( ; idlist; idlist = idlist->nd_NEXT) {
pr = new_paramlist();
pr->par_next = 0;
if (!*ppr) *ppr = pr;
@ -378,7 +378,7 @@ EnterExportList(Idlist, qualified)
register t_node *idlist = Idlist;
register t_def *df, *df1;
for (;idlist; idlist = idlist->nd_left) {
for (;idlist; idlist = idlist->nd_NEXT) {
df = lookup(idlist->nd_IDF, CurrentScope, 0, 0);
if (!df) {
@ -508,7 +508,7 @@ node_error(FromId,"identifier \"%s\" does not represent a module",module_name);
return;
}
for (; idlist; idlist = idlist->nd_left) {
for (; idlist; idlist = idlist->nd_NEXT) {
if (! (df = lookup(idlist->nd_IDF, sc, 0, 0))) {
if (! is_anon_idf(idlist->nd_IDF)) {
node_error(idlist,
@ -544,7 +544,7 @@ EnterImportList(idlist, local, sc)
f = file_info;
for (; idlist; idlist = idlist->nd_left) {
for (; idlist; idlist = idlist->nd_NEXT) {
if (! DoImport(local ?
ForwDef(idlist, sc) :
GetDefinitionModule(idlist->nd_IDF, 1),

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

@ -21,7 +21,6 @@
#include "idf.h"
#include "def.h"
#include "node.h"
#include "const.h"
#include "type.h"
#include "chk_expr.h"
#include "warning.h"
@ -51,8 +50,10 @@ qualident(t_node **p;)
]*
;
selector(register t_node **pnd;):
'.' { *pnd = dot2node(Link,*pnd,NULLNODE); }
selector(register t_node **pnd;)
{ t_node *nd;
} :
'.' { nd = dot2leaf(Select); nd->nd_NEXT = *pnd; *pnd = nd; }
IDENT { (*pnd)->nd_IDF = dot.TOK_IDF; }
;
@ -64,35 +65,34 @@ ExpList(t_node **pnd;)
nd->nd_symb = ',';
}
[
',' { nd->nd_right = dot2leaf(Link);
nd = nd->nd_right;
',' { nd->nd_RIGHT = dot2leaf(Link);
nd = nd->nd_RIGHT;
}
expression(&(nd->nd_left))
expression(&(nd->nd_LEFT))
]*
;
ConstExpression(t_node **pnd;)
ConstExpression(register t_node **pnd;)
{
register t_node *nd;
}:
expression(pnd)
/*
* Changed rule in new Modula-2.
* Check that the expression is a constant expression and evaluate!
*/
{ nd = *pnd;
{
DO_DEBUG(options['C'], print("CONSTANT EXPRESSION\n"));
DO_DEBUG(options['C'], PrNode(nd, 0));
DO_DEBUG(options['C'], PrNode(*pnd, 0));
if (ChkExpression(nd) &&
nd->nd_class != Set &&
nd->nd_class != Value &&
! (options['l'] && nd->nd_class == Def && IsProc(nd))) {
if (ChkExpression(pnd) &&
(*pnd)->nd_class != Set &&
(*pnd)->nd_class != Value &&
! (options['l'] && (*pnd)->nd_class == Def && IsProc((*pnd)))) {
error("constant expression expected");
}
DO_DEBUG(options['C'], print("RESULTS IN\n"));
DO_DEBUG(options['C'], PrNode(nd, 0));
DO_DEBUG(options['C'], PrNode(*pnd, 0));
}
;
@ -104,7 +104,7 @@ expression(register t_node **pnd;)
/* relation */
[ '=' | '#' | '<' | LESSEQUAL | '>' | GREATEREQUAL | IN ]
{ *pnd = dot2node(Oper, *pnd, NULLNODE); }
SimpleExpression(&((*pnd)->nd_right))
SimpleExpression(&((*pnd)->nd_RIGHT))
|
]
;
@ -128,7 +128,7 @@ SimpleExpression(register t_node **pnd;)
]
term(pnd)
{ if (nd) {
nd->nd_right = *pnd;
nd->nd_RIGHT = *pnd;
*pnd = nd;
}
nd = *pnd;
@ -137,7 +137,7 @@ SimpleExpression(register t_node **pnd;)
/* AddOperator */
[ '+' | '-' | OR ]
{ nd = dot2node(Oper, nd, NULLNODE); }
term(&(nd->nd_right))
term(&(nd->nd_RIGHT))
]*
{ *pnd = nd; }
;
@ -157,7 +157,7 @@ term(t_node **pnd;)
/* MulOperator */
[ '*' | '/' | DIV | MOD | AND ]
{ nd = dot2node(Oper, nd, NULLNODE); }
factor(&(nd->nd_right))
factor(&(nd->nd_RIGHT))
]*
{ *pnd = nd; }
;
@ -178,12 +178,12 @@ factor(register t_node **p;)
designator_tail(p)
[
{ *p = dot2node(Call, *p, NULLNODE); }
ActualParameters(&((*p)->nd_right))
ActualParameters(&((*p)->nd_RIGHT))
|
]
|
bare_set(&nd1)
{ nd = nd1; nd->nd_left = *p; *p = nd; }
{ nd = nd1; nd->nd_LEFT = *p; *p = nd; }
]
|
bare_set(p)
@ -210,8 +210,8 @@ factor(register t_node **p;)
if (class == Arrsel ||
class == Arrow ||
class == Name ||
class == Link) {
nd->nd_right = *p;
class == Select) {
nd->nd_RIGHT = *p;
*p = nd;
}
else FreeNode(nd);
@ -219,20 +219,20 @@ factor(register t_node **p;)
')'
|
NOT { *p = dot2leaf(Uoper); }
factor(&((*p)->nd_right))
factor(&((*p)->nd_RIGHT))
;
bare_set(t_node **pnd;)
{
register t_node *nd;
} :
'{' { dot.tk_symb = SET;
'{' { DOT = SET;
*pnd = nd = dot2leaf(Xset);
nd->nd_type = bitset_type;
}
[
element(nd)
[ { nd = nd->nd_right; }
[ { nd = nd->nd_RIGHT; }
',' element(nd)
]*
|
@ -245,15 +245,15 @@ ActualParameters(t_node **pnd;):
;
element(register t_node *nd;) :
expression(&(nd->nd_right))
expression(&(nd->nd_RIGHT))
[
UPTO
{ nd->nd_right = dot2node(Link, nd->nd_right, NULLNODE);}
expression(&(nd->nd_right->nd_right))
{ nd->nd_RIGHT = dot2node(Link, nd->nd_RIGHT, NULLNODE);}
expression(&(nd->nd_RIGHT->nd_RIGHT))
|
]
{ nd->nd_right = dot2node(Link, nd->nd_right, NULLNODE);
nd->nd_right->nd_symb = ',';
{ nd->nd_RIGHT = dot2node(Link, nd->nd_RIGHT, NULLNODE);
nd->nd_RIGHT->nd_symb = ',';
}
;
@ -279,12 +279,12 @@ visible_designator_tail(t_node **pnd;)
register t_node *nd = *pnd;
}:
'[' { nd = dot2node(Arrsel, nd, NULLNODE); }
expression(&(nd->nd_right))
expression(&(nd->nd_RIGHT))
[
','
{ nd = dot2node(Arrsel, nd, NULLNODE);
}
expression(&(nd->nd_right))
expression(&(nd->nd_RIGHT))
]*
']'
{ *pnd = nd; }

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

@ -45,7 +45,7 @@ int pass_1 = 1;
t_def *Defined;
extern int err_occurred;
extern int fp_used; /* set if floating point used */
static t_node _emptystat = { NULLNODE, NULLNODE, Stat, 0, NULLTYPE, { ';' }};
static t_node _emptystat = { Stat, 0, NULLTYPE, { ';' }};
t_node *EmptyStatement = &_emptystat;
main(argc, argv)
@ -66,9 +66,9 @@ main(argc, argv)
Nargv[Nargc] = 0; /* terminate the arg vector */
if (Nargc < 2) {
fprint(STDERR, "%s: Use a file argument\n", ProgName);
exit(1);
sys_stop(S_EXIT);
}
exit(!Compile(Nargv[1], Nargv[2]));
sys_stop(Compile(Nargv[1], Nargv[2]) ? S_END : S_EXIT);
/*NOTREACHED*/
}

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

@ -10,8 +10,6 @@
/* $Header$ */
struct node {
struct node *nd_left;
struct node *nd_right;
char nd_class; /* kind of node */
#define Value 0 /* constant */
#define Arrsel 1 /* array selection */
@ -24,7 +22,8 @@ struct node {
#define Xset 8 /* a set */
#define Def 9 /* an identified name */
#define Stat 10 /* a statement */
#define Link 11
#define Select 11 /* a '.' selection */
#define Link 12
/* do NOT change the order or the numbers!!! */
char nd_flags; /* options */
#define ROPTION 1
@ -33,6 +32,9 @@ struct node {
struct token nd_token;
#define nd_set nd_token.tk_data.tk_set
#define nd_def nd_token.tk_data.tk_def
#define nd_LEFT nd_token.tk_data.tk_left
#define nd_RIGHT nd_token.tk_data.tk_right
#define nd_NEXT nd_token.tk_data.tk_next
#define nd_symb nd_token.tk_symb
#define nd_lineno nd_token.tk_lineno
#define nd_IDF nd_token.TOK_IDF
@ -49,7 +51,7 @@ typedef struct node t_node;
/* ALLOCDEF "node" 50 */
extern t_node *MkNode(), *MkLeaf(), *dot2node(), *dot2leaf();
extern t_node *MkNode(), *MkLeaf(), *dot2node(), *dot2leaf(), *getnode();
#define NULLNODE ((t_node *) 0)

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

@ -22,6 +22,33 @@
#include "node.h"
#include "main.h"
static int nsubnodes[] = {
0,
2,
2,
2,
2,
2,
1,
1,
2,
1,
2,
1,
2
};
t_node *
getnode(class)
{
register t_node *nd = new_node();
if (options['R']) nd->nd_flags |= ROPTION;
if (options['A']) nd->nd_flags |= AOPTION;
nd->nd_class = class;
return nd;
}
t_node *
MkNode(class, left, right, token)
t_node *left, *right;
@ -29,14 +56,11 @@ MkNode(class, left, right, token)
{
/* Create a node and initialize it with the given parameters
*/
register t_node *nd = new_node();
register t_node *nd = getnode(class);
nd->nd_left = left;
nd->nd_right = right;
nd->nd_token = *token;
nd->nd_class = class;
if (options['R']) nd->nd_flags |= ROPTION;
if (options['A']) nd->nd_flags |= AOPTION;
nd->nd_LEFT = left;
nd->nd_RIGHT = right;
return nd;
}
@ -51,21 +75,40 @@ t_node *
MkLeaf(class, token)
t_token *token;
{
return MkNode(class, NULLNODE, NULLNODE, token);
register t_node *nd = getnode(class);
nd->nd_token = *token;
switch(nsubnodes[class]) {
case 1:
nd->nd_NEXT = 0;
break;
case 2:
nd->nd_LEFT = 0;
nd->nd_RIGHT = 0;
break;
}
return nd;
}
t_node *
dot2leaf(class)
{
return MkNode(class, NULLNODE, NULLNODE, &dot);
return MkLeaf(class, &dot);
}
FreeLR(nd)
register t_node *nd;
{
FreeNode(nd->nd_left);
FreeNode(nd->nd_right);
nd->nd_left = nd->nd_right = 0;
switch(nsubnodes[nd->nd_class]) {
case 2:
FreeNode(nd->nd_LEFT);
FreeNode(nd->nd_RIGHT);
nd->nd_LEFT = nd->nd_RIGHT = 0;
break;
case 1:
FreeNode(nd->nd_NEXT);
nd->nd_NEXT = 0;
break;
}
}
FreeNode(nd)
@ -85,6 +128,12 @@ NodeCrash(expp)
crash("Illegal node %d", expp->nd_class);
}
PNodeCrash(expp)
t_node **expp;
{
crash("Illegal node %d", (*expp)->nd_class);
}
#ifdef DEBUG
extern char *symbol2str();
@ -117,7 +166,14 @@ PrNode(nd, lvl)
return;
}
printnode(nd, lvl);
PrNode(nd->nd_left, lvl + 1);
PrNode(nd->nd_right, lvl + 1);
switch(nsubnodes[nd->nd_class]) {
case 1:
PrNode(nd->nd_LEFT, lvl + 1);
PrNode(nd->nd_RIGHT, lvl + 1);
break;
case 2:
PrNode(nd->nd_NEXT, lvl + 1);
break;
}
}
#endif DEBUG

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

@ -191,7 +191,7 @@ node_warning(exportlist, W_OLDFASHIONED, "export list in definition module ignor
definition* END IDENT
{ end_definition_list(&(currscope->sc_def));
DefinitionModule--;
match_id(df->df_idf, dot.TOK_IDF);
match_id(dot.TOK_IDF, df->df_idf);
df->df_flags &= ~D_BUSY;
}
'.'

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

@ -24,13 +24,13 @@
#include "def.h"
#include "type.h"
#include "idf.h"
#include "const.h"
#include "scope.h"
#include "main.h"
#define INCR_SIZE 64
extern int proclevel;
extern char *sprint();
static struct db_str {
unsigned sz;
@ -276,11 +276,11 @@ stb_string(df, kind)
break;
case D_END:
adds_db_str(sprint(buf, "E%d;", df->mod_vis->sc_count));
C_ms_stb_cst(db_str.base, N_SCOPE, proclevel, 0);
C_ms_stb_cst(db_str.base, N_SCOPE, proclevel, (arith) 0);
break;
case D_PEND:
adds_db_str(sprint(buf, "E%d;", df->prc_vis->sc_count));
C_ms_stb_cst(db_str.base, N_SCOPE, proclevel, 0);
C_ms_stb_cst(db_str.base, N_SCOPE, proclevel, (arith) 0);
break;
case D_VARIABLE:
if (DefinitionModule && CurrVis != Defined->mod_vis) break;

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

@ -40,7 +40,7 @@ statement(register t_node **pnd;)
nd->nd_symb = '(';
nd->nd_lineno = (*pnd)->nd_lineno;
}
ActualParameters(&(nd->nd_right))?
ActualParameters(&(nd->nd_RIGHT))?
|
[ BECOMES
| '=' { error("':=' expected instead of '='");
@ -48,7 +48,7 @@ statement(register t_node **pnd;)
}
]
{ nd = dot2node(Stat, *pnd, NULLNODE); }
expression(&(nd->nd_right))
expression(&(nd->nd_RIGHT))
]
{ *pnd = nd; }
/*
@ -60,19 +60,19 @@ statement(register t_node **pnd;)
CaseStatement(pnd)
|
WHILE { *pnd = nd = dot2leaf(Stat); }
expression(&(nd->nd_left))
expression(&(nd->nd_LEFT))
DO
StatementSequence(&(nd->nd_right))
StatementSequence(&(nd->nd_RIGHT))
END
|
REPEAT { *pnd = nd = dot2leaf(Stat); }
StatementSequence(&(nd->nd_left))
StatementSequence(&(nd->nd_LEFT))
UNTIL
expression(&(nd->nd_right))
expression(&(nd->nd_RIGHT))
|
{ loopcount++; }
LOOP { *pnd = nd = dot2leaf(Stat); }
StatementSequence(&((*pnd)->nd_right))
StatementSequence(&((*pnd)->nd_RIGHT))
END
{ loopcount--; }
|
@ -116,7 +116,7 @@ StatementSequence(register t_node **pnd;)
nd1 = dot2node(Link, *pnd, nd);
*pnd = nd1;
nd1->nd_symb = ';';
pnd = &(nd1->nd_right);
pnd = &(nd1->nd_RIGHT);
}
}
]*
@ -129,25 +129,25 @@ IfStatement(t_node **pnd;)
IF { nd = dot2leaf(Stat);
*pnd = nd;
}
expression(&(nd->nd_left))
THEN { nd->nd_right = dot2leaf(Link);
nd = nd->nd_right;
expression(&(nd->nd_LEFT))
THEN { nd->nd_RIGHT = dot2leaf(Link);
nd = nd->nd_RIGHT;
}
StatementSequence(&(nd->nd_left))
StatementSequence(&(nd->nd_LEFT))
[
ELSIF { nd->nd_right = dot2leaf(Stat);
nd = nd->nd_right;
ELSIF { nd->nd_RIGHT = dot2leaf(Stat);
nd = nd->nd_RIGHT;
nd->nd_symb = IF;
}
expression(&(nd->nd_left))
THEN { nd->nd_right = dot2leaf(Link);
nd = nd->nd_right;
expression(&(nd->nd_LEFT))
THEN { nd->nd_RIGHT = dot2leaf(Link);
nd = nd->nd_RIGHT;
}
StatementSequence(&(nd->nd_left))
StatementSequence(&(nd->nd_LEFT))
]*
[
ELSE
StatementSequence(&(nd->nd_right))
StatementSequence(&(nd->nd_RIGHT))
|
]
END
@ -159,16 +159,16 @@ CaseStatement(t_node **pnd;)
t_type *tp = 0;
} :
CASE { *pnd = nd = dot2leaf(Stat); }
expression(&(nd->nd_left))
expression(&(nd->nd_LEFT))
OF
case(&(nd->nd_right), &tp)
{ nd = nd->nd_right; }
case(&(nd->nd_RIGHT), &tp)
{ nd = nd->nd_RIGHT; }
[
'|'
case(&(nd->nd_right), &tp)
{ nd = nd->nd_right; }
case(&(nd->nd_RIGHT), &tp)
{ nd = nd->nd_RIGHT; }
]*
[ ELSE StatementSequence(&(nd->nd_right))
[ ELSE StatementSequence(&(nd->nd_RIGHT))
|
]
END
@ -177,7 +177,7 @@ CaseStatement(t_node **pnd;)
case(t_node **pnd; t_type **ptp;) :
[ CaseLabelList(ptp, pnd)
':' { *pnd = dot2node(Link, *pnd, NULLNODE); }
StatementSequence(&((*pnd)->nd_right))
StatementSequence(&((*pnd)->nd_RIGHT))
|
]
{ *pnd = dot2node(Link, *pnd, NULLNODE);
@ -191,9 +191,9 @@ WhileStatement(t_node **pnd;)
register t_node *nd;
}:
WHILE { *pnd = nd = dot2leaf(Stat); }
expression(&(nd->nd_left))
expression(&(nd->nd_LEFT))
DO
StatementSequence(&(nd->nd_right))
StatementSequence(&(nd->nd_RIGHT))
END
;
@ -202,44 +202,49 @@ RepeatStatement(t_node **pnd;)
register t_node *nd;
}:
REPEAT { *pnd = nd = dot2leaf(Stat); }
StatementSequence(&(nd->nd_left))
StatementSequence(&(nd->nd_LEFT))
UNTIL
expression(&(nd->nd_right))
expression(&(nd->nd_RIGHT))
;
*/
ForStatement(t_node **pnd;)
{
register t_node *nd, *nd1;
t_node *dummy;
}:
FOR { *pnd = nd = dot2leaf(Stat); }
IDENT { nd->nd_IDF = dot.TOK_IDF; }
BECOMES { nd->nd_left = nd1 = dot2leaf(Stat); }
expression(&(nd1->nd_left))
IDENT { nd1 = dot2leaf(Name); }
BECOMES { nd->nd_LEFT = dot2node(Stat, nd1, dot2leaf(Link));
nd1 = nd->nd_LEFT->nd_RIGHT;
nd1->nd_symb = TO;
}
expression(&(nd1->nd_LEFT))
TO
expression(&(nd1->nd_right))
expression(&(nd1->nd_RIGHT))
{ nd->nd_RIGHT = nd1 = dot2leaf(Link);
nd1->nd_symb = BY;
}
[
BY
ConstExpression(&dummy)
{ if (!(dummy->nd_type->tp_fund & T_INTORCARD)) {
ConstExpression(&(nd1->nd_LEFT))
{ if (!(nd1->nd_LEFT->nd_type->tp_fund & T_INTORCARD)) {
error("illegal type in BY clause");
}
nd1->nd_INT = dummy->nd_INT;
FreeNode(dummy);
}
|
{ nd1->nd_INT = 1; }
{ nd1->nd_LEFT = dot2leaf(Value);
nd1->nd_LEFT->nd_INT = 1;
}
]
DO
StatementSequence(&(nd->nd_right))
StatementSequence(&(nd1->nd_RIGHT))
END
;
/* inline in Statement; lack of space
LoopStatement(t_node **pnd;):
LOOP { *pnd = dot2leaf(Stat); }
StatementSequence(&((*pnd)->nd_right))
StatementSequence(&((*pnd)->nd_RIGHT))
END
;
*/
@ -249,9 +254,9 @@ WithStatement(t_node **pnd;)
register t_node *nd;
}:
WITH { *pnd = nd = dot2leaf(Stat); }
designator(&(nd->nd_left))
designator(&(nd->nd_LEFT))
DO
StatementSequence(&(nd->nd_right))
StatementSequence(&(nd->nd_RIGHT))
END
;
@ -264,7 +269,7 @@ ReturnStatement(t_node **pnd;)
RETURN { *pnd = nd = dot2leaf(Stat); }
[
expression(&(nd->nd_right))
expression(&(nd->nd_RIGHT))
{ if (scopeclosed(CurrentScope)) {
error("a module body cannot return a value");
}

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

@ -161,6 +161,8 @@ extern t_type
#define float_size (SZ_FLOAT)
#define double_size (SZ_DOUBLE)
#define pointer_size (SZ_POINTER)
#define wrd_bits (8*(int)word_size)
#else NOCROSS
extern int
@ -182,6 +184,9 @@ extern arith
float_size,
double_size,
pointer_size; /* All from type.c */
extern unsigned int
wrd_bits; /* from cstoper.c */
#endif NOCROSS
extern arith

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

@ -23,7 +23,6 @@
#include "type.h"
#include "idf.h"
#include "node.h"
#include "const.h"
#include "scope.h"
#include "walk.h"
#include "chk_expr.h"
@ -52,6 +51,8 @@ arith
pointer_size = SZ_POINTER;
#endif
#define arith_sign ((arith) (1L << (sizeof(arith) * 8 - 1)))
arith ret_area_size;
t_type
@ -255,12 +256,13 @@ enum_type(EnumList)
}
t_type *
qualified_type(nd)
register t_node *nd;
qualified_type(pnd)
t_node **pnd;
{
register t_def *df;
if (ChkDesig(nd, D_USED)) {
if (ChkDesig(pnd, D_USED)) {
register t_node *nd = *pnd;
if (nd->nd_class != Def) {
node_error(nd, "type expected");
FreeNode(nd);
@ -284,9 +286,9 @@ node_error(nd,"type \"%s\" not (yet) declared", df->df_idf->id_text);
}
return df->df_type;
}
node_error(nd,"identifier \"%s\" is not a type", df->df_idf->id_text);
node_error(nd, "identifier \"%s\" is not a type", df->df_idf->id_text);
}
FreeNode(nd);
FreeNode(*pnd);
return error_type;
}
@ -681,7 +683,7 @@ SolveForwardTypeRefs(df)
df->df_kind = D_TYPE;
while (nd) {
nd->nd_type->tp_next = df->df_type;
nd = nd->nd_right;
nd = nd->nd_RIGHT;
}
FreeNode(df->df_forw_node);
}
@ -750,7 +752,7 @@ type_or_forward(tp)
df1->df_forw_node = 0;
/* Fall through */
case D_FORWTYPE:
nd = dot2node(0, NULLNODE, df1->df_forw_node);
nd = dot2node(Link, NULLNODE, df1->df_forw_node);
df1->df_forw_node = nd;
nd->nd_type = tp;
return 0;
@ -758,7 +760,7 @@ type_or_forward(tp)
return 1;
}
}
nd = dot2leaf(0);
nd = dot2leaf(Name);
if ((df1 = lookfor(nd, CurrVis, 0, D_USED))->df_kind == D_MODULE) {
/* A Modulename in one of the enclosing scopes.
It is not clear from the language definition that

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

@ -72,7 +72,7 @@ static int UseWarnings();
int
LblWalkNode(lbl, nd, exit, reach)
label lbl, exit;
register t_node *nd;
t_node *nd;
{
/* Generate code for node "nd", after generating instruction
label "lbl". "exit" is the exit label for the closest
@ -134,8 +134,8 @@ DoLineno(nd)
static int ms_lineno;
if (ms_lineno != nd->nd_lineno) {
C_ms_std((char *) 0, N_SLINE, nd->nd_lineno);
ms_lineno = nd->nd_lineno;
C_ms_std((char *) 0, N_SLINE, ms_lineno);
}
}
#endif /* DBSYMTAB */
@ -218,7 +218,7 @@ WalkModule(module)
C_cal("killbss");
}
for (; nd; nd = nd->nd_left) {
for (; nd; nd = nd->nd_NEXT) {
C_cal(nd->nd_def->mod_vis->sc_scope->sc_name);
}
DoFilename(1);
@ -578,8 +578,8 @@ WalkLink(nd, exit_label, end_reached)
*/
while (nd && nd->nd_class == Link) { /* statement list */
end_reached = WalkNode(nd->nd_left, exit_label, end_reached);
nd = nd->nd_right;
end_reached = WalkNode(nd->nd_LEFT, exit_label, end_reached);
nd = nd->nd_RIGHT;
}
return WalkNode(nd, exit_label, end_reached);
@ -602,8 +602,8 @@ WalkStat(nd, exit_label, end_reached)
{
/* Walk through a statement, generating code for it.
*/
register t_node *left = nd->nd_left;
register t_node *right = nd->nd_right;
register t_node *left = nd->nd_LEFT;
register t_node *right = nd->nd_RIGHT;
assert(nd->nd_class == Stat);
@ -620,33 +620,36 @@ WalkStat(nd, exit_label, end_reached)
options['R'] = (nd->nd_flags & ROPTION);
options['A'] = (nd->nd_flags & AOPTION);
switch(nd->nd_symb) {
case '(':
if (ChkCall(nd)) {
case '(': {
t_node *nd1 = nd;
if (ChkCall(&nd1)) {
assert(nd == nd1);
if (nd->nd_type != 0) {
node_error(nd, "procedure call expected instead of function call");
break;
}
CodeCall(nd);
}
}
break;
case BECOMES:
DoAssign(left, right);
DoAssign(nd);
break;
case IF:
{ label l1 = ++text_label, l3 = ++text_label;
int end_r;
ExpectBool(left, l3, l1);
ExpectBool(&(nd->nd_LEFT), l3, l1);
assert(right->nd_symb == THEN);
end_r = LblWalkNode(l3, right->nd_left, exit_label, end_reached);
end_r = LblWalkNode(l3, right->nd_LEFT, exit_label, end_reached);
if (right->nd_right) { /* ELSE part */
if (right->nd_RIGHT) { /* ELSE part */
label l2 = ++text_label;
C_bra(l2);
end_reached = end_r | LblWalkNode(l1, right->nd_right, exit_label, end_reached);
end_reached = end_r | LblWalkNode(l1, right->nd_RIGHT, exit_label, end_reached);
l1 = l2;
}
else end_reached |= end_r;
@ -666,7 +669,7 @@ WalkStat(nd, exit_label, end_reached)
C_bra(dummy);
end_reached |= LblWalkNode(loop, right, exit_label, end_reached);
def_ilb(dummy);
ExpectBool(left, loop, exit);
ExpectBool(&(nd->nd_LEFT), loop, exit);
def_ilb(exit);
break;
}
@ -675,7 +678,7 @@ WalkStat(nd, exit_label, end_reached)
{ label loop = ++text_label, exit = ++text_label;
end_reached = LblWalkNode(loop, left, exit_label, end_reached);
ExpectBool(right, exit, loop);
ExpectBool(&(nd->nd_RIGHT), exit, loop);
def_ilb(exit);
break;
}
@ -696,44 +699,45 @@ WalkStat(nd, exit_label, end_reached)
{
arith tmp = NewInt();
arith tmp2 = NewInt();
register t_node *fnd;
int good_forvar;
label l1 = ++text_label;
label l2 = ++text_label;
int uns = 0;
arith stepsize;
t_type *bstp;
t_node *loopid;
good_forvar = DoForInit(nd);
if ((stepsize = left->nd_INT) == 0) {
node_warning(left,
good_forvar = DoForInit(left);
loopid = left->nd_LEFT;
if ((stepsize = right->nd_LEFT->nd_INT) == 0) {
node_warning(right->nd_LEFT,
W_ORDINARY,
"zero stepsize in FOR loop");
}
fnd = left->nd_right;
if (good_forvar) {
bstp = BaseType(nd->nd_type);
bstp = BaseType(loopid->nd_type);
uns = bstp->tp_fund != T_INTEGER;
CodePExpr(fnd);
CodePExpr(left->nd_RIGHT->nd_RIGHT);
C_stl(tmp);
CodePExpr(left->nd_left);
CodePExpr(left->nd_RIGHT->nd_LEFT);
C_dup(int_size);
C_stl(tmp2);
C_lol(tmp);
if (uns) C_cmu(int_size);
else C_cmi(int_size);
if (left->nd_INT >= 0) C_zgt(l2);
if (stepsize >= 0) C_zgt(l2);
else C_zlt(l2);
C_lol(tmp2);
RangeCheck(nd->nd_type, left->nd_left->nd_type);
CodeDStore(nd);
if (left->nd_INT >= 0) {
RangeCheck(loopid->nd_type,
left->nd_RIGHT->nd_LEFT->nd_type);
CodeDStore(loopid);
if (stepsize >= 0) {
C_lol(tmp);
ForLoopVarExpr(nd);
ForLoopVarExpr(loopid);
}
else {
stepsize = -stepsize;
ForLoopVarExpr(nd);
ForLoopVarExpr(loopid);
C_lol(tmp);
}
C_sbu(int_size);
@ -742,23 +746,23 @@ WalkStat(nd, exit_label, end_reached)
C_dvu(int_size);
}
C_stl(tmp);
nd->nd_def->df_flags |= D_FORLOOP;
loopid->nd_def->df_flags |= D_FORLOOP;
def_ilb(l1);
if (! options['R']) {
label x = ++text_label;
ForLoopVarExpr(nd);
ForLoopVarExpr(loopid);
C_stl(tmp2);
end_reached |= WalkNode(right, exit_label, end_reached);
end_reached |= WalkNode(right->nd_RIGHT, exit_label, end_reached);
C_lol(tmp2);
ForLoopVarExpr(nd);
ForLoopVarExpr(loopid);
C_beq(x);
c_loc(M2_FORCH);
C_trp();
def_ilb(x);
}
else end_reached |= WalkNode(right, exit_label, end_reached);
nd->nd_def->df_flags &= ~D_FORLOOP;
else end_reached |= WalkNode(right->nd_RIGHT, exit_label, end_reached);
loopid->nd_def->df_flags &= ~D_FORLOOP;
FreeInt(tmp2);
if (stepsize) {
C_lol(tmp);
@ -767,24 +771,20 @@ WalkStat(nd, exit_label, end_reached)
c_loc(1);
C_sbu(int_size);
C_stl(tmp);
C_loc(left->nd_INT);
ForLoopVarExpr(nd);
C_loc(right->nd_LEFT->nd_INT);
ForLoopVarExpr(loopid);
C_adu(int_size);
RangeCheck(nd->nd_type, bstp);
CodeDStore(nd);
RangeCheck(loopid->nd_type, bstp);
CodeDStore(loopid);
}
}
else {
end_reached |= WalkNode(right, exit_label, end_reached);
nd->nd_def->df_flags &= ~D_FORLOOP;
end_reached |= WalkNode(right->nd_RIGHT, exit_label, end_reached);
loopid->nd_def->df_flags &= ~D_FORLOOP;
}
C_bra(l1);
def_ilb(l2);
FreeInt(tmp);
#ifdef DEBUG
nd->nd_left = left;
nd->nd_right = right;
#endif
}
break;
@ -794,7 +794,8 @@ WalkStat(nd, exit_label, end_reached)
struct withdesig wds;
t_desig ds;
if (! WalkDesignator(left, &ds, D_USED)) break;
if (! WalkDesignator(&(nd->nd_LEFT), &ds, D_USED)) break;
left = nd->nd_LEFT;
if (left->nd_type->tp_fund != T_RECORD) {
node_error(left, "record variable expected");
break;
@ -821,7 +822,7 @@ WalkStat(nd, exit_label, end_reached)
CurrVis = link.sc_next;
WithDesigs = wds.w_next;
FreePtr(ds.dsg_offset);
ChkDesig(left, wds.w_flags & (D_USED|D_DEFINED));
ChkDesig(&(nd->nd_LEFT), wds.w_flags & (D_USED|D_DEFINED));
break;
}
@ -835,15 +836,15 @@ WalkStat(nd, exit_label, end_reached)
case RETURN:
end_reached &= ~REACH_FLAG;
if (right) {
if (! ChkExpression(right)) break;
if (! ChkExpression(&(nd->nd_RIGHT))) break;
/* The type of the return-expression must be
assignment compatible with the result type of the
function procedure (See Rep. 9.11).
*/
if (!ChkAssCompat(&(nd->nd_right), func_type, "RETURN")) {
if (!ChkAssCompat(&(nd->nd_RIGHT), func_type, "RETURN")) {
break;
}
right = nd->nd_right;
right = nd->nd_RIGHT;
if (right->nd_type->tp_fund == T_STRING) {
CodePString(right, func_type);
}
@ -872,60 +873,58 @@ int (*WalkTable[])() = {
NodeCrash,
NodeCrash,
WalkStat,
NodeCrash,
WalkLink,
};
ExpectBool(nd, true_label, false_label)
register t_node *nd;
ExpectBool(pnd, true_label, false_label)
register t_node **pnd;
label true_label, false_label;
{
/* "nd" must indicate a boolean expression. Check this and
/* "pnd" must indicate a boolean expression. Check this and
generate code to evaluate the expression.
*/
register t_desig *ds = new_desig();
if (ChkExpression(nd)) {
if (nd->nd_type != bool_type && nd->nd_type != error_type) {
node_error(nd, "boolean expression expected");
if (ChkExpression(pnd)) {
if ((*pnd)->nd_type != bool_type &&
(*pnd)->nd_type != error_type) {
node_error(*pnd, "boolean expression expected");
}
CodeExpr(nd, ds, true_label, false_label);
CodeExpr(*pnd, ds, true_label, false_label);
}
free_desig(ds);
}
int
WalkDesignator(nd, ds, flags)
t_node *nd;
WalkDesignator(pnd, ds, flags)
t_node **pnd;
t_desig *ds;
{
/* Check designator and generate code for it
*/
if (! ChkVariable(nd, flags)) return 0;
if (! ChkVariable(pnd, flags)) return 0;
clear((char *) ds, sizeof(t_desig));
CodeDesig(nd, ds);
CodeDesig(*pnd, ds);
return 1;
}
DoForInit(nd)
register t_node *nd;
t_node *nd;
{
register t_node *left = nd->nd_left;
register t_node *right = nd->nd_RIGHT;
register t_def *df;
register t_type *base_tp;
t_type *base_tp;
t_type *tpl, *tpr;
nd->nd_left = nd->nd_right = 0;
nd->nd_class = Name;
nd->nd_symb = IDENT;
if (!( ChkVariable(&(nd->nd_LEFT), D_USED|D_DEFINED) &
ChkExpression(&(right->nd_LEFT)) &
ChkExpression(&(right->nd_RIGHT)))) return 0;
if (!( ChkVariable(nd, D_USED|D_DEFINED) &
ChkExpression(left->nd_left) &
ChkExpression(left->nd_right))) return 0;
df = nd->nd_def;
df = nd->nd_LEFT->nd_def;
if (df->df_kind == D_FIELD) {
node_error(nd,
"FOR-loop variable may not be a field of a record");
@ -958,12 +957,12 @@ DoForInit(nd)
}
base_tp = BaseType(df->df_type);
tpl = left->nd_left->nd_type;
tpr = left->nd_right->nd_type;
tpl = right->nd_LEFT->nd_type;
tpr = right->nd_RIGHT->nd_type;
#ifndef STRICT_3RD_ED
if (! options['3']) {
if (!ChkAssCompat(&(left->nd_left), base_tp, "FOR statement") ||
!ChkAssCompat(&(left->nd_right), base_tp, "FOR statement")) {
if (!ChkAssCompat(&(right->nd_LEFT), base_tp, "FOR statement") ||
!ChkAssCompat(&(right->nd_RIGHT), base_tp, "FOR statement")) {
return 1;
}
if (!TstCompat(df->df_type, tpl) ||
@ -972,17 +971,16 @@ node_warning(nd, W_OLDFASHIONED, "compatibility required in FOR statement");
}
} else
#endif
if (!ChkCompat(&(left->nd_left), base_tp, "FOR statement") ||
!ChkCompat(&(left->nd_right), base_tp, "FOR statement")) {
if (!ChkCompat(&(right->nd_LEFT), base_tp, "FOR statement") ||
!ChkCompat(&(right->nd_RIGHT), base_tp, "FOR statement")) {
return 1;
}
return 1;
}
DoAssign(left, right)
register t_node *left;
t_node *right;
DoAssign(nd)
register t_node *nd;
{
/* May we do it in this order (expression first) ???
The reference manual sais nothing about it, but the book does:
@ -992,27 +990,28 @@ DoAssign(left, right)
register t_desig *dsr;
register t_type *tp;
if (! (ChkExpression(right) & ChkVariable(left, D_DEFINED))) return;
tp = left->nd_type;
if (! (ChkExpression(&(nd->nd_RIGHT)) &
ChkVariable(&(nd->nd_LEFT), D_DEFINED))) return;
tp = nd->nd_LEFT->nd_type;
if (right->nd_symb == STRING) TryToString(right, tp);
if (nd->nd_RIGHT->nd_symb == STRING) TryToString(nd->nd_RIGHT, tp);
if (! ChkAssCompat(&right, tp, "assignment")) {
if (! ChkAssCompat(&(nd->nd_RIGHT), tp, "assignment")) {
return;
}
dsr = new_desig();
#define StackNeededFor(ds) ((ds)->dsg_kind == DSG_PLOADED \
|| (ds)->dsg_kind == DSG_INDEXED)
CodeExpr(right, dsr, NO_LABEL, NO_LABEL);
tp = right->nd_type;
CodeExpr(nd->nd_RIGHT, dsr, NO_LABEL, NO_LABEL);
tp = nd->nd_RIGHT->nd_type;
if (complex(tp)) {
if (StackNeededFor(dsr)) CodeAddress(dsr);
}
else {
CodeValue(dsr, tp);
}
CodeMove(dsr, left, tp);
CodeMove(dsr, nd->nd_LEFT, tp);
free_desig(dsr);
}