chk_expr.h
class.h
code.c
-const.h
cstoper.c
debug.h
declar.g
#include "idf.h"
#include "def.h"
#include "type.h"
-#include "const.h"
#include "warning.h"
extern long str2long();
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;
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)
#
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
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
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
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
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
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
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 */
);
}
*/
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);
}
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;
}
#include "def.h"
#include "node.h"
#include "scope.h"
-#include "const.h"
#include "standards.h"
#include "chk_expr.h"
#include "misc.h"
extern char *sprint();
extern arith flt_flt2arith();
-STATIC int
+STATIC
df_error(nd, mess, edf)
t_node *nd; /* node on which error occurred */
char *mess; /* error message */
}
}
else node_error(nd, mess);
- return 0;
}
STATIC int
int
ChkVariable(expp, flags)
- register t_node *expp;
+ register t_node **expp;
{
/* Check that "expp" indicates an item that can be
assigned to.
*/
+ register t_node *exp;
- return ChkDesig(expp, flags) &&
- ( expp->nd_class != Def ||
- ( expp->nd_def->df_kind & (D_FIELD|D_VARIABLE)) ||
- df_error(expp, "variable expected", expp->nd_def));
+ if (! ChkDesig(expp, flags)) return 0;
+
+ exp = *expp;
+ if (exp->nd_class == Def &&
+ ! (exp->nd_def->df_kind & (D_FIELD|D_VARIABLE))) {
+ df_error(exp, "variable expected", exp->nd_def);
+ return 0;
+ }
+ return 1;
}
STATIC int
ChkArrow(expp)
- register t_node *expp;
+ t_node **expp;
{
/* Check an application of the '^' operator.
The operand must be a variable of a pointer type.
*/
register t_type *tp;
+ register t_node *exp = *expp;
- assert(expp->nd_class == Arrow);
- assert(expp->nd_symb == '^');
+ assert(exp->nd_class == Arrow);
+ assert(exp->nd_symb == '^');
- expp->nd_type = error_type;
+ exp->nd_type = error_type;
- if (! ChkVariable(expp->nd_right, D_USED)) return 0;
+ if (! ChkVariable(&(exp->nd_RIGHT), D_USED)) return 0;
- tp = expp->nd_right->nd_type;
+ tp = exp->nd_RIGHT->nd_type;
if (tp->tp_fund != T_POINTER) {
- return ex_error(expp, "illegal operand type");
+ return ex_error(exp, "illegal operand type");
}
if ((tp = RemoveEqual(PointedtoType(tp))) == 0) tp = error_type;
- expp->nd_type = tp;
+ exp->nd_type = tp;
return 1;
}
STATIC int
ChkArr(expp, flags)
- register t_node *expp;
+ t_node **expp;
{
/* Check an array selection.
The left hand side must be a variable of an array type,
*/
register t_type *tpl;
+ register t_node *exp = *expp;
- assert(expp->nd_class == Arrsel);
- assert(expp->nd_symb == '[' || expp->nd_symb == ',');
+ assert(exp->nd_class == Arrsel);
+ assert(exp->nd_symb == '[' || exp->nd_symb == ',');
- expp->nd_type = error_type;
+ exp->nd_type = error_type;
- if (! (ChkVariable(expp->nd_left, flags) & ChkExpression(expp->nd_right))) {
+ if (! (ChkVariable(&(exp->nd_LEFT), flags) &
+ ChkExpression(&(exp->nd_RIGHT)))) {
/* Bitwise and, because we want them both evaluated.
*/
return 0;
}
- tpl = expp->nd_left->nd_type;
+ tpl = exp->nd_LEFT->nd_type;
if (tpl->tp_fund != T_ARRAY) {
- node_error(expp, "not indexing an ARRAY type");
+ node_error(exp, "not indexing an ARRAY type");
return 0;
}
- expp->nd_type = RemoveEqual(tpl->arr_elem);
+ exp->nd_type = RemoveEqual(tpl->arr_elem);
/* Type of the index must be assignment compatible with
the index type of the array (Def 8.1).
However, the index type of a conformant array is not specified.
In our implementation it is CARDINAL.
*/
- return ChkAssCompat(&(expp->nd_right),
+ return ChkAssCompat(&(exp->nd_RIGHT),
BaseType(IndexType(tpl)),
"index type");
}
/*ARGSUSED*/
STATIC int
ChkValue(expp)
- t_node *expp;
+ t_node **expp;
{
#ifdef DEBUG
- switch(expp->nd_symb) {
+ switch((*expp)->nd_symb) {
case REAL:
case STRING:
case INTEGER:
}
STATIC int
-ChkLinkOrName(expp, flags)
- register t_node *expp;
+ChkSelOrName(expp, flags)
+ t_node **expp;
{
/* Check either an ID or a construction of the form
ID.ID [ .ID ]*
*/
register t_def *df;
-
- expp->nd_type = error_type;
-
- if (expp->nd_class == Name) {
- df = lookfor(expp, CurrVis, 1, flags);
- expp->nd_def = df;
- expp->nd_class = Def;
- expp->nd_type = RemoveEqual(df->df_type);
+ register t_node *exp = *expp;
+
+ exp->nd_type = error_type;
+
+ if (exp->nd_class == Name) {
+ df = lookfor(exp, CurrVis, 1, flags);
+ exp = getnode(Def);
+ exp->nd_def = df;
+ exp->nd_lineno = (*expp)->nd_lineno;
+ exp->nd_type = RemoveEqual(df->df_type);
+ FreeNode(*expp);
+ *expp = exp;
}
- else if (expp->nd_class == Link) {
+ else if (exp->nd_class == Select) {
/* A selection from a record or a module.
Modules also have a record type.
*/
- register t_node *left = expp->nd_left;
+ register t_node *left;
- assert(expp->nd_symb == '.');
+ assert(exp->nd_symb == '.');
- if (! ChkDesig(left, flags)) return 0;
+ if (! ChkDesig(&(exp->nd_NEXT), flags)) return 0;
+ left = exp->nd_NEXT;
if (left->nd_class==Def &&
(left->nd_type->tp_fund != T_RECORD ||
!(left->nd_def->df_kind & (D_MODULE|D_VARIABLE|D_FIELD))
)
) {
- return df_error(left, "illegal selection", left->nd_def);
+ df_error(left, "illegal selection", left->nd_def);
+ return 0;
}
if (left->nd_type->tp_fund != T_RECORD) {
node_error(left, "illegal selection");
return 0;
}
- if (!(df = lookup(expp->nd_IDF, left->nd_type->rec_scope, D_IMPORTED, flags))) {
- id_not_declared(expp);
+ if (!(df = lookup(exp->nd_IDF, left->nd_type->rec_scope, D_IMPORTED, flags))) {
+ id_not_declared(exp);
return 0;
}
- expp->nd_def = df;
- expp->nd_type = RemoveEqual(df->df_type);
- expp->nd_class = Def;
+ exp = getnode(Def);
+ exp->nd_def = df;
+ exp->nd_type = RemoveEqual(df->df_type);
+ exp->nd_lineno = (*expp)->nd_lineno;
+ free_node(*expp);
+ *expp = exp;
if (!(df->df_flags & (D_EXPORTED|D_QEXPORTED))) {
/* Fields of a record are always D_QEXPORTED,
so ...
*/
- if (df_error(expp,
- "not exported from qualifying module",
- df)) assert(0);
+ df_error(exp, "not exported from qualifying module", df);
}
if (!(left->nd_class == Def &&
left->nd_def->df_kind == D_MODULE)) {
+ exp->nd_NEXT = left;
return 1;
}
FreeNode(left);
- expp->nd_left = 0;
}
- assert(expp->nd_class == Def);
+ assert(exp->nd_class == Def);
- return expp->nd_def->df_kind != D_ERROR;
+ return exp->nd_def->df_kind != D_ERROR;
}
STATIC int
-ChkExLinkOrName(expp)
- register t_node *expp;
+ChkExSelOrName(expp)
+ t_node **expp;
{
/* Check either an ID or an ID.ID [.ID]* occurring in an
expression.
*/
register t_def *df;
+ register t_node *exp;
+
+ if (! ChkSelOrName(expp, D_USED)) return 0;
- if (! ChkLinkOrName(expp, D_USED)) return 0;
+ exp = *expp;
- df = expp->nd_def;
+ df = exp->nd_def;
if (df->df_kind & (D_ENUM | D_CONST)) {
/* Replace an enum-literal or a CONST identifier by its value.
*/
+ exp = getnode(Value);
+ exp->nd_type = df->df_type;
if (df->df_kind == D_ENUM) {
- expp->nd_INT = df->enm_val;
- expp->nd_symb = INTEGER;
+ exp->nd_INT = df->enm_val;
+ exp->nd_symb = INTEGER;
}
else {
- unsigned int ln = expp->nd_lineno;
-
assert(df->df_kind == D_CONST);
- expp->nd_token = df->con_const;
- expp->nd_lineno = ln;
+ exp->nd_token = df->con_const;
}
+ exp->nd_lineno = (*expp)->nd_lineno;
if (df->df_type->tp_fund == T_SET) {
- expp->nd_class = Set;
- inc_refcount(expp->nd_set);
+ exp->nd_class = Set;
+ inc_refcount(exp->nd_set);
}
else if (df->df_type->tp_fund == T_PROCEDURE) {
/* for procedure constants */
- expp->nd_class = Def;
+ exp->nd_class = Def;
}
- else expp->nd_class = Value;
if (df->df_type->tp_fund == T_REAL) {
- struct real *p = expp->nd_REAL;
+ struct real *p = exp->nd_REAL;
- expp->nd_REAL = new_real();
- *(expp->nd_REAL) = *p;
+ exp->nd_REAL = new_real();
+ *(exp->nd_REAL) = *p;
if (p->r_real) {
p->r_real = Salloc(p->r_real,
(unsigned)(strlen(p->r_real)+1));
}
}
+ FreeNode(*expp);
+ *expp = exp;
}
if (!(df->df_kind & D_VALUE)) {
- return df_error(expp, "value expected", df);
+ df_error(exp, "value expected", df);
+ return 0;
}
if (df->df_kind == D_PROCEDURE) {
/* Address of standard or nested procedure
taken.
*/
- node_error(expp,
+ node_error(exp,
"standard or local procedures may not be assigned");
return 0;
}
}
STATIC int
-ChkEl(expr, tp)
- register t_node **expr;
+ChkEl(expp, tp)
+ register t_node **expp;
t_type *tp;
{
- return ChkExpression(*expr) && ChkCompat(expr, tp, "set element");
+ return ChkExpression(expp) && ChkCompat(expp, tp, "set element");
}
STATIC int
/* { ... , expr1 .. expr2, ... }
First check expr1 and expr2, and try to compute them.
*/
- if (! (ChkEl(&(expr->nd_left), el_type) &
- ChkEl(&(expr->nd_right), el_type))) {
+ if (! (ChkEl(&(expr->nd_LEFT), el_type) &
+ ChkEl(&(expr->nd_RIGHT), el_type))) {
return 0;
}
- if (!(expr->nd_left->nd_class == Value &&
- expr->nd_right->nd_class == Value)) {
+ if (!(expr->nd_LEFT->nd_class == Value &&
+ expr->nd_RIGHT->nd_class == Value)) {
return 1;
}
/* We have a constant range. Put all elements in the
set
*/
- low = expr->nd_left->nd_INT;
- high = expr->nd_right->nd_INT;
+ low = expr->nd_LEFT->nd_INT;
+ high = expr->nd_RIGHT->nd_INT;
}
else {
if (! ChkEl(expp, el_type)) return 0;
STATIC int
ChkSet(expp)
- register t_node *expp;
+ t_node **expp;
{
/* Check the legality of a SET aggregate, and try to evaluate it
compile time. Unfortunately this is all rather complicated.
*/
register t_type *tp;
+ register t_node *exp = *expp;
register t_node *nd;
register t_def *df;
int retval = 1;
int SetIsConstant = 1;
- assert(expp->nd_symb == SET);
+ assert(exp->nd_symb == SET);
- expp->nd_type = error_type;
- expp->nd_class = Set;
+ *expp = getnode(Set);
+ (*expp)->nd_type = error_type;
+ (*expp)->nd_lineno = exp->nd_lineno;
/* First determine the type of the set
*/
- if (nd = expp->nd_left) {
+ if (exp->nd_LEFT) {
/* A type was given. Check it out
*/
- if (! ChkDesig(nd, D_USED)) return 0;
+ if (! ChkDesig(&(exp->nd_LEFT), D_USED)) return 0;
+ nd = exp->nd_LEFT;
assert(nd->nd_class == Def);
df = nd->nd_def;
if (!is_type(df) ||
(df->df_type->tp_fund != T_SET)) {
- return df_error(nd, "not a SET type", df);
+ df_error(nd, "not a SET type", df);
+ return 0;
}
tp = df->df_type;
- FreeNode(nd);
- expp->nd_left = 0;
}
else tp = bitset_type;
- expp->nd_type = tp;
+ (*expp)->nd_type = tp;
- nd = expp->nd_right;
+ nd = exp->nd_RIGHT;
/* Now check the elements given, and try to compute a constant set.
First allocate room for the set.
*/
- expp->nd_set = MkSet(tp->set_sz);
+ (*expp)->nd_set = MkSet(tp->set_sz);
/* Now check the elements, one by one
*/
while (nd) {
assert(nd->nd_class == Link && nd->nd_symb == ',');
- if (!ChkElement(&(nd->nd_left), tp, expp->nd_set)) {
+ if (!ChkElement(&(nd->nd_LEFT), tp, (*expp)->nd_set)) {
retval = 0;
}
- if (nd->nd_left) SetIsConstant = 0;
- nd = nd->nd_right;
+ if (nd->nd_LEFT) SetIsConstant = 0;
+ nd = nd->nd_RIGHT;
}
- if (SetIsConstant) {
- FreeNode(expp->nd_right);
- expp->nd_right = 0;
+ if (! SetIsConstant) {
+ (*expp)->nd_NEXT = exp->nd_RIGHT;
+ exp->nd_RIGHT = 0;
}
+ FreeNode(exp);
return retval;
}
t_node **argp;
t_def *edf;
{
- register t_node *arg = (*argp)->nd_right;
+ register t_node *arg = (*argp)->nd_RIGHT;
if (! arg) {
- return (t_node *)
- df_error(*argp, "too few arguments supplied", edf);
+ df_error(*argp, "too few arguments supplied", edf);
+ return 0;
}
*argp = arg;
- return arg->nd_left;
+ return arg;
}
STATIC t_node *
that it must be a designator and may not be a register
variable.
*/
- register t_node *left = nextarg(argp, edf);
+ register t_node *arg = nextarg(argp, edf);
+ register t_node *left;
- if (! left ||
- ! (designator ? ChkVariable(left, D_USED|D_DEFINED) : ChkExpression(left))) {
+ if (! arg->nd_LEFT ||
+ ! (designator ? ChkVariable(&(arg->nd_LEFT), D_USED|D_DEFINED) : ChkExpression(&(arg->nd_LEFT)))) {
return 0;
}
+ left = arg->nd_LEFT;
if (designator && left->nd_class==Def) {
left->nd_def->df_flags |= D_NOREG;
if (bases) {
t_type *tp = BaseType(left->nd_type);
- if (! designator) MkCoercion(&((*argp)->nd_left), tp);
- left = (*argp)->nd_left;
+ if (! designator) MkCoercion(&(arg->nd_LEFT), tp);
+ left = arg->nd_LEFT;
if (!(tp->tp_fund & bases)) {
- return (t_node *)
- df_error(left, "unexpected parameter type", edf);
+ df_error(left, "unexpected parameter type", edf);
+ return 0;
}
}
The argument must indicate a definition, and the
definition kind must be one of "kinds".
*/
- register t_node *left = nextarg(argp, edf);
+ register t_node *arg = nextarg(argp, edf);
+ register t_node *left;
- if (!left || ! ChkDesig(left, D_USED)) return 0;
+ if (!arg->nd_LEFT || ! ChkDesig(&(arg->nd_LEFT), D_USED)) return 0;
+ left = arg->nd_LEFT;
if (left->nd_class != Def) {
- return (t_node *)df_error(left, "identifier expected", edf);
+ df_error(left, "identifier expected", edf);
+ return 0;
}
if (!(left->nd_def->df_kind & kinds) ||
(bases && !(left->nd_type->tp_fund & bases))) {
- return (t_node *)
- df_error(left, "unexpected parameter type", edf);
+ df_error(left, "unexpected parameter type", edf);
+ return 0;
}
return left;
}
STATIC int
-ChkProcCall(expp)
- t_node *expp;
+ChkProcCall(exp)
+ register t_node *exp;
{
/* Check a procedure call
*/
register t_node *left;
+ t_node *argp;
t_def *edf = 0;
register t_param *param;
int retval = 1;
int cnt = 0;
- left = expp->nd_left;
+ left = exp->nd_LEFT;
if (left->nd_class == Def) {
edf = left->nd_def;
}
if (left->nd_type == error_type) {
/* Just check parameters as if they were value parameters
*/
- while (expp->nd_right) {
- if (getarg(&expp, 0, 0, edf)) { }
+ argp = exp;
+ while (argp->nd_RIGHT) {
+ if (getarg(&argp, 0, 0, edf)) { }
}
return 0;
}
- expp->nd_type = RemoveEqual(ResultType(left->nd_type));
+ exp->nd_type = RemoveEqual(ResultType(left->nd_type));
/* Check parameter list
*/
+ argp = exp;
for (param = ParamList(left->nd_type); param; param = param->par_next) {
- if (!(left = getarg(&expp, 0, IsVarParam(param), edf))) {
+ if (!(left = getarg(&argp, 0, IsVarParam(param), edf))) {
retval = 0;
cnt++;
continue;
if (! TstParCompat(cnt,
RemoveEqual(TypeOfParam(param)),
IsVarParam(param),
- &(expp->nd_left),
+ &(argp->nd_LEFT),
edf)) {
retval = 0;
}
}
- if (expp->nd_right) {
- if (df_error(expp->nd_right,"too many parameters supplied",edf)){
- assert(0);
- }
- while (expp->nd_right) {
- if (getarg(&expp, 0, 0, edf)) { }
+ exp = argp;
+ if (exp->nd_RIGHT) {
+ df_error(exp->nd_RIGHT,"too many parameters supplied",edf);
+ while (argp->nd_RIGHT) {
+ if (getarg(&argp, 0, 0, edf)) { }
}
return 0;
}
return retval;
}
-int
+STATIC int
ChkFunCall(expp)
- register t_node *expp;
+ register t_node **expp;
{
/* Check a call that must have a result
*/
if (ChkCall(expp)) {
- if (expp->nd_type != 0) return 1;
- node_error(expp, "function call expected");
+ if ((*expp)->nd_type != 0) return 1;
+ node_error(*expp, "function call expected");
}
- expp->nd_type = error_type;
+ (*expp)->nd_type = error_type;
return 0;
}
int
ChkCall(expp)
- register t_node *expp;
+ t_node **expp;
{
/* Check something that looks like a procedure or function call.
Of course this does not have to be a call at all,
it may also be a cast or a standard procedure call.
*/
- register t_node *left = expp->nd_left;
/* First, get the name of the function or procedure
*/
- if (ChkDesig(left, D_USED)) {
+ if (ChkDesig(&((*expp)->nd_LEFT), D_USED)) {
+ register t_node *left = (*expp)->nd_LEFT;
+
if (IsCast(left)) {
/* It was a type cast.
*/
left->nd_type = error_type;
}
}
- return ChkProcCall(expp);
+ return ChkProcCall(*expp);
}
STATIC t_type *
if (tpr == address_type && expp->nd_symb == '+') {
/* use the fact that '+' is a commutative operator */
t_type *tmptype = tpr;
- t_node *tmpnode = expp->nd_right;
+ t_node *tmpnode = expp->nd_RIGHT;
tpr = tpl;
- expp->nd_right = expp->nd_left;
+ expp->nd_RIGHT = expp->nd_LEFT;
tpl = tmptype;
- expp->nd_left = tmpnode;
+ expp->nd_LEFT = tmpnode;
}
if (tpl == address_type) {
return 1;
}
if (tpr->tp_fund & T_CARDINAL) {
- MkCoercion(&(expp->nd_right),
+ MkCoercion(&(expp->nd_RIGHT),
expp->nd_symb=='+' || expp->nd_symb=='-' ?
tpr :
address_type);
if (tpr == address_type && tpl->tp_fund & T_CARDINAL) {
expp->nd_type = address_type;
- MkCoercion(&(expp->nd_left), address_type);
+ MkCoercion(&(expp->nd_LEFT), address_type);
return 1;
}
STATIC int
ChkBinOper(expp)
- register t_node *expp;
+ t_node **expp;
{
/* Check a binary operation.
*/
+ register t_node *exp = *expp;
register t_type *tpl, *tpr;
t_type *result_type;
int allowed;
/* First, check BOTH operands */
- retval = ChkExpression(expp->nd_left) & ChkExpression(expp->nd_right);
+ retval = ChkExpression(&(exp->nd_LEFT)) & ChkExpression(&(exp->nd_RIGHT));
- tpl = BaseType(expp->nd_left->nd_type);
- tpr = BaseType(expp->nd_right->nd_type);
+ tpl = BaseType(exp->nd_LEFT->nd_type);
+ tpr = BaseType(exp->nd_RIGHT->nd_type);
if (intorcard(tpl, tpr) != 0) {
if (tpl == intorcard_type) {
- expp->nd_left->nd_type = tpl = tpr;
+ exp->nd_LEFT->nd_type = tpl = tpr;
}
if (tpr == intorcard_type) {
- expp->nd_right->nd_type = tpr = tpl;
+ exp->nd_RIGHT->nd_type = tpr = tpl;
}
}
- expp->nd_type = result_type = ResultOfOperation(expp->nd_symb, tpr);
+ exp->nd_type = result_type = ResultOfOperation(exp->nd_symb, tpr);
/* Check that the application of the operator is allowed on the type
of the operands.
on ADDRESS.
- The IN-operator has as right-hand-size operand a set.
*/
- if (expp->nd_symb == IN) {
+ if (exp->nd_symb == IN) {
if (tpr->tp_fund != T_SET) {
- return ex_error(expp, "right operand must be a set");
+ return ex_error(exp, "right operand must be a set");
}
if (!TstAssCompat(ElementType(tpr), tpl)) {
/* Assignment compatible ???
I don't know! Should we be allowed to check
if a INTEGER is a member of a BITSET???
*/
- node_error(expp->nd_left, "type incompatibility in IN");
+ node_error(exp->nd_LEFT, "type incompatibility in IN");
return 0;
}
- MkCoercion(&(expp->nd_left), word_type);
- if (expp->nd_left->nd_class == Value && expp->nd_right->nd_class == Set) {
+ MkCoercion(&(exp->nd_LEFT), word_type);
+ if (exp->nd_LEFT->nd_class == Value &&
+ exp->nd_RIGHT->nd_class == Set &&
+ ! exp->nd_RIGHT->nd_NEXT) {
cstset(expp);
}
return retval;
if (!retval) return 0;
- allowed = AllowedTypes(expp->nd_symb);
+ allowed = AllowedTypes(exp->nd_symb);
if (!(tpr->tp_fund & allowed) || !(tpl->tp_fund & allowed)) {
if (!((T_CARDINAL & allowed) &&
- ChkAddressOper(tpl, tpr, expp))) {
- return ex_error(expp, "illegal operand type(s)");
+ ChkAddressOper(tpl, tpr, exp))) {
+ return ex_error(exp, "illegal operand type(s)");
}
- if (result_type == bool_type) expp->nd_type = bool_type;
+ if (result_type == bool_type) exp->nd_type = bool_type;
}
else {
- if (Boolean(expp->nd_symb) && tpl != bool_type) {
- return ex_error(expp, "illegal operand type(s)");
+ if (Boolean(exp->nd_symb) && tpl != bool_type) {
+ return ex_error(exp, "illegal operand type(s)");
}
/* Operands must be compatible (distilled from Def 8.2)
char buf[128];
sprint(buf, "%s in operand(s)", incompat(tpl, tpr));
- return ex_error(expp, buf);
+ return ex_error(exp, buf);
}
- MkCoercion(&(expp->nd_left), tpl);
- MkCoercion(&(expp->nd_right), tpr);
+ MkCoercion(&(exp->nd_LEFT), tpl);
+ MkCoercion(&(exp->nd_RIGHT), tpr);
}
if (tpl->tp_fund == T_SET) {
- if (expp->nd_left->nd_class == Set &&
- expp->nd_right->nd_class == Set) {
+ if (exp->nd_LEFT->nd_class == Set &&
+ ! exp->nd_LEFT->nd_NEXT &&
+ exp->nd_RIGHT->nd_class == Set &&
+ ! exp->nd_RIGHT->nd_NEXT) {
cstset(expp);
}
}
- else if ( expp->nd_left->nd_class == Value &&
- expp->nd_right->nd_class == Value) {
- if (expp->nd_left->nd_type->tp_fund == T_INTEGER) {
+ else if ( exp->nd_LEFT->nd_class == Value &&
+ exp->nd_RIGHT->nd_class == Value) {
+ if (tpl->tp_fund == T_INTEGER) {
cstibin(expp);
}
else if (tpl->tp_fund == T_REAL) {
STATIC int
ChkUnOper(expp)
- register t_node *expp;
+ t_node **expp;
{
/* Check an unary operation.
*/
- register t_node *right = expp->nd_right;
+ register t_node *exp = *expp;
+ register t_node *right = exp->nd_RIGHT;
register t_type *tpr;
- if (expp->nd_symb == COERCION) return 1;
- if (expp->nd_symb == '(') {
- *expp = *right;
- free_node(right);
+ if (exp->nd_symb == COERCION) return 1;
+ if (exp->nd_symb == '(') {
+ *expp = right;
+ free_node(exp);
return ChkExpression(expp);
}
- expp->nd_type = error_type;
- if (! ChkExpression(right)) return 0;
- expp->nd_type = tpr = BaseType(right->nd_type);
- MkCoercion(&(expp->nd_right), tpr);
- right = expp->nd_right;
+ exp->nd_type = error_type;
+ if (! ChkExpression(&(exp->nd_RIGHT))) return 0;
+ exp->nd_type = tpr = BaseType(exp->nd_RIGHT->nd_type);
+ MkCoercion(&(exp->nd_RIGHT), tpr);
+ right = exp->nd_RIGHT;
if (tpr == address_type) tpr = card_type;
- switch(expp->nd_symb) {
+ switch(exp->nd_symb) {
case '+':
if (!(tpr->tp_fund & T_NUMERIC)) break;
- *expp = *right;
- free_node(right);
+ *expp = right;
+ free_node(exp);
return 1;
case '-':
if (tpr->tp_fund == T_INTORCARD || tpr->tp_fund == T_INTEGER) {
if (tpr == intorcard_type) {
- expp->nd_type = int_type;
+ exp->nd_type = int_type;
}
if (right->nd_class == Value) {
cstunary(expp);
}
else if (tpr->tp_fund == T_REAL) {
if (right->nd_class == Value) {
- *expp = *right;
- flt_umin(&(expp->nd_RVAL));
- if (expp->nd_RSTR) {
- free(expp->nd_RSTR);
- expp->nd_RSTR = 0;
+ *expp = right;
+ flt_umin(&(right->nd_RVAL));
+ if (right->nd_RSTR) {
+ free(right->nd_RSTR);
+ right->nd_RSTR = 0;
}
- FreeNode(right);
+ free_node(exp);
}
return 1;
}
default:
crash("ChkUnOper");
}
- return ex_error(expp, "illegal operand type");
+ return ex_error(exp, "illegal operand type");
}
STATIC t_node *
/* Get the next argument from argument list "argp".
It must obey the rules of "ChkVariable".
*/
- register t_node *left = nextarg(argp, edf);
+ register t_node *arg = nextarg(argp, edf);
- if (!left || !ChkVariable(left, flags)) return 0;
+ if (! arg ||
+ ! arg->nd_LEFT ||
+ ! ChkVariable(&(arg->nd_LEFT), flags)) return 0;
- return left;
+ return arg->nd_LEFT;
}
STATIC int
ChkStandard(expp)
- register t_node *expp;
+ t_node **expp;
{
/* Check a call of a standard procedure or function
*/
- t_node *arg = expp;
- register t_node *left = expp->nd_left;
- register t_def *edf = left->nd_def;
+ register t_node *exp = *expp;
+ t_node *arg = exp;
+ register t_node *left;
+ register t_def *edf = exp->nd_LEFT->nd_def;
int free_it = 0;
+ int isconstant = 0;
- assert(left->nd_class == Def);
+ assert(exp->nd_LEFT->nd_class == Def);
- expp->nd_type = error_type;
+ exp->nd_type = error_type;
switch(edf->df_value.df_stdname) {
case S_ABS:
if (!(left = getarg(&arg, T_NUMERIC, 0, edf))) return 0;
- expp->nd_type = BaseType(left->nd_type);
- MkCoercion(&(arg->nd_left), expp->nd_type);
- switch(expp->nd_type->tp_fund) {
- case T_REAL:
- if (arg->nd_left->nd_class == Value) {
- arg->nd_left->nd_RVAL.flt_sign = 0;
+ exp->nd_type = BaseType(left->nd_type);
+ MkCoercion(&(arg->nd_LEFT), exp->nd_type);
+ left = arg->nd_LEFT;
+ if (! (exp->nd_type->tp_fund & (T_INTEGER|T_REAL))) {
+ free_it = 1;
+ }
+ if (left->nd_class == Value) {
+ switch(exp->nd_type->tp_fund) {
+ case T_REAL:
+ left->nd_RVAL.flt_sign = 0;
free_it = 1;
+ break;
+ case T_INTEGER:
+ isconstant = 1;
+ break;
}
- break;
- case T_INTEGER:
- if (arg->nd_left->nd_class == Value) {
- cstcall(expp,S_ABS);
- }
- break;
- default:
- free_it = 1;
- break;
}
break;
case S_CAP:
- expp->nd_type = char_type;
+ exp->nd_type = char_type;
if (!(left = getarg(&arg, T_CHAR, 0, edf))) return 0;
- if (left->nd_class == Value) cstcall(expp, S_CAP);
+ if (left->nd_class == Value) isconstant = 1;
break;
case S_FLOATD:
case S_FLOAT:
if (! getarg(&arg, T_INTORCARD, 0, edf)) return 0;
if (edf->df_value.df_stdname == S_FLOAT) {
- MkCoercion(&(arg->nd_left), card_type);
+ MkCoercion(&(arg->nd_LEFT), card_type);
}
- MkCoercion(&(arg->nd_left),
+ MkCoercion(&(arg->nd_LEFT),
edf->df_value.df_stdname == S_FLOATD ?
longreal_type :
real_type);
t_type *tp;
t_type *s1, *s2, *d1, *d2;
+ if (!(left = getarg(&arg, 0, 0, edf))) {
+ return 0;
+ }
+ tp = BaseType(left->nd_type);
+
if (edf->df_value.df_stdname == S_SHORT) {
s1 = longint_type;
d1 = int_type;
s2 = real_type;
}
- if (!(left = getarg(&arg, 0, 0, edf))) {
- return 0;
- }
- tp = BaseType(left->nd_type);
if (tp == s1) {
- MkCoercion(&(arg->nd_left), d1);
+ MkCoercion(&(arg->nd_LEFT), d1);
}
else if (tp == s2) {
- MkCoercion(&(arg->nd_left), d2);
+ MkCoercion(&(arg->nd_LEFT), d2);
}
else {
- if (df_error(left, "unexpected parameter type", edf)) {
- assert(0);
- }
+ df_error(left, "unexpected parameter type", edf);
break;
}
free_it = 1;
return 0;
}
if (left->nd_type->tp_fund == T_ARRAY) {
- expp->nd_type = IndexType(left->nd_type);
+ exp->nd_type = IndexType(left->nd_type);
if (! IsConformantArray(left->nd_type)) {
- left->nd_type = expp->nd_type;
- cstcall(expp, S_MAX);
+ left->nd_type = exp->nd_type;
+ isconstant = 1;
}
break;
}
if (left->nd_symb != STRING) {
- return df_error(left,"array parameter expected", edf);
+ df_error(left,"array parameter expected", edf);
+ return 0;
}
- expp->nd_type = card_type;
- expp->nd_class = Value;
+ exp = getnode(Value);
+ exp->nd_type = card_type;
/* Notice that we could disallow HIGH("") here by checking
that left->nd_type->tp_fund != T_CHAR || left->nd_INT != 0.
??? For the time being, we don't. !!!
Maybe the empty string should not be allowed at all.
*/
- expp->nd_INT = left->nd_type->tp_fund == T_CHAR ? 0 :
+ exp->nd_INT = left->nd_type->tp_fund == T_CHAR ? 0 :
left->nd_SLE - 1;
- expp->nd_symb = INTEGER;
+ exp->nd_symb = INTEGER;
+ exp->nd_lineno = (*expp)->nd_lineno;
+ (*expp)->nd_RIGHT = 0;
+ FreeNode(*expp);
+ *expp = exp;
break;
case S_MAX:
if (!(left = getname(&arg, D_ISTYPE, T_DISCRETE, edf))) {
return 0;
}
- expp->nd_type = left->nd_type;
- cstcall(expp,edf->df_value.df_stdname);
+ exp->nd_type = left->nd_type;
+ isconstant = 1;
break;
case S_ODD:
if (! (left = getarg(&arg, T_INTORCARD, 0, edf))) return 0;
- MkCoercion(&(arg->nd_left), BaseType(left->nd_type));
- expp->nd_type = bool_type;
- if (arg->nd_left->nd_class == Value) cstcall(expp, S_ODD);
+ MkCoercion(&(arg->nd_LEFT), BaseType(left->nd_type));
+ exp->nd_type = bool_type;
+ if (arg->nd_LEFT->nd_class == Value) isconstant = 1;
break;
case S_ORD:
if (! (left = getarg(&arg, T_NOSUB, 0, edf))) return 0;
- expp->nd_type = card_type;
- if (arg->nd_left->nd_class == Value) {
- arg->nd_left->nd_type = card_type;
+ exp->nd_type = card_type;
+ if (arg->nd_LEFT->nd_class == Value) {
+ arg->nd_LEFT->nd_type = card_type;
free_it = 1;
}
break;
if (!warning_given) {
warning_given = 1;
if (! options['3'])
- node_warning(expp, W_OLDFASHIONED, "NEW and DISPOSE are obsolete");
+ node_warning(exp, W_OLDFASHIONED, "NEW and DISPOSE are obsolete");
else
- node_error(expp, "NEW and DISPOSE are obsolete");
+ node_error(exp, "NEW and DISPOSE are obsolete");
}
}
- left = getvariable(&arg,
- edf,
- D_USED|D_DEFINED);
- expp->nd_type = 0;
+ left = getvariable(&arg, edf, D_USED|D_DEFINED);
+ exp->nd_type = 0;
if (! left) return 0;
if (! (left->nd_type->tp_fund == T_POINTER)) {
- return df_error(left, "pointer variable expected", edf);
+ df_error(left, "pointer variable expected", edf);
+ return 0;
}
/* Now, make it look like a call to ALLOCATE or DEALLOCATE */
{
- t_token dt;
- t_node *nd;
-
- dt.TOK_INT = PointedtoType(left->nd_type)->tp_size;
- dt.tk_symb = INTEGER;
- dt.tk_lineno = left->nd_lineno;
- nd = MkLeaf(Value, &dt);
- nd->nd_type = card_type;
- dt.tk_symb = ',';
- arg->nd_right = MkNode(Link, nd, NULLNODE, &dt);
+ left = getnode(Value);
+
+ left->nd_INT = PointedtoType(arg->nd_LEFT->nd_type)->tp_size;
+ left->nd_symb = INTEGER;
+ left->nd_lineno = exp->nd_lineno;
+ left->nd_type = card_type;
+ arg->nd_RIGHT = MkNode(Link, left, NULLNODE, &(left->nd_token));
+ arg->nd_RIGHT->nd_symb = ',';
/* Ignore other arguments to NEW and/or DISPOSE ??? */
- dt.tk_symb = IDENT;
- dt.tk_lineno = expp->nd_left->nd_lineno;
- FreeNode(expp->nd_left);
- dt.TOK_IDF = str2idf(edf->df_value.df_stdname==S_NEW ?
+ FreeNode(exp->nd_LEFT);
+ exp->nd_LEFT = left = getnode(Name);
+ left->nd_symb = IDENT;
+ left->nd_lineno = exp->nd_lineno;
+ left->nd_IDF = str2idf(edf->df_value.df_stdname==S_NEW ?
"ALLOCATE" : "DEALLOCATE", 0);
- expp->nd_left = MkLeaf(Name, &dt);
}
return ChkCall(expp);
#endif
case S_TSIZE: /* ??? */
case S_SIZE:
- expp->nd_type = intorcard_type;
+ exp->nd_type = intorcard_type;
if (!(left = getname(&arg,D_FIELD|D_VARIABLE|D_ISTYPE,0,edf))) {
return 0;
}
- if (! IsConformantArray(left->nd_type)) cstcall(expp, S_SIZE);
+ if (! IsConformantArray(left->nd_type)) isconstant = 1;
#ifndef NOSTRICT
- else node_warning(expp,
+ else node_warning(exp,
W_STRICT,
"%s on conformant array",
- expp->nd_left->nd_def->df_idf->id_text);
+ exp->nd_LEFT->nd_def->df_idf->id_text);
#endif
#ifndef STRICT_3RD_ED
if (! options['3'] && edf->df_value.df_stdname == S_TSIZE) {
- if (arg->nd_right) {
- node_warning(arg->nd_right,
+ if (arg->nd_RIGHT) {
+ node_warning(arg->nd_RIGHT,
W_OLDFASHIONED,
"TSIZE with multiple parameters, only first parameter used");
- FreeNode(arg->nd_right);
- arg->nd_right = 0;
+ FreeNode(arg->nd_RIGHT);
+ arg->nd_RIGHT = 0;
}
}
#endif
case S_TRUNCD:
case S_TRUNC:
if (! getarg(&arg, T_REAL, 0, edf)) return 0;
- MkCoercion(&(arg->nd_left),
+ MkCoercion(&(arg->nd_LEFT),
edf->df_value.df_stdname == S_TRUNCD ?
longint_type : card_type);
free_it = 1;
if (!(left = getname(&arg, D_ISTYPE, T_NOSUB, edf))) {
return 0;
}
- expp->nd_type = left->nd_def->df_type;
- expp->nd_right = arg->nd_right;
- arg->nd_right = 0;
+ exp->nd_type = left->nd_def->df_type;
+ exp->nd_RIGHT = arg->nd_RIGHT;
+ arg->nd_RIGHT = 0;
FreeNode(arg);
- arg = expp;
+ arg = exp;
/* fall through */
case S_CHR:
if (! getarg(&arg, T_CARDINAL, 0, edf)) return 0;
if (edf->df_value.df_stdname == S_CHR) {
- expp->nd_type = char_type;
+ exp->nd_type = char_type;
}
- if (expp->nd_type != int_type) {
- MkCoercion(&(arg->nd_left), expp->nd_type);
+ if (exp->nd_type != int_type) {
+ MkCoercion(&(arg->nd_LEFT), exp->nd_type);
free_it = 1;
}
break;
case S_ADR:
- expp->nd_type = address_type;
+ exp->nd_type = address_type;
if (! getarg(&arg, 0, 1, edf)) return 0;
break;
case S_DEC:
case S_INC:
- expp->nd_type = 0;
+ exp->nd_type = 0;
if (! (left = getvariable(&arg, edf, D_USED|D_DEFINED))) return 0;
if (! (left->nd_type->tp_fund & T_DISCRETE)) {
- return df_error(left,"illegal parameter type", edf);
+ df_error(left,"illegal parameter type", edf);
+ return 0;
}
- if (arg->nd_right) {
+ if (arg->nd_RIGHT) {
if (! getarg(&arg, T_INTORCARD, 0, edf)) return 0;
}
break;
case S_HALT:
- expp->nd_type = 0;
+ exp->nd_type = 0;
break;
case S_EXCL:
register t_type *tp;
t_node *dummy;
- expp->nd_type = 0;
+ exp->nd_type = 0;
if (!(left = getvariable(&arg, edf, D_USED|D_DEFINED))) return 0;
tp = left->nd_type;
if (tp->tp_fund != T_SET) {
- return df_error(arg, "SET parameter expected", edf);
+ df_error(arg, "SET parameter expected", edf);
+ return 0;
}
if (!(dummy = getarg(&arg, 0, 0, edf))) return 0;
if (!ChkAssCompat(&dummy, ElementType(tp), "EXCL/INCL")) {
*/
return 0;
}
- MkCoercion(&(arg->nd_left), word_type);
+ MkCoercion(&(arg->nd_LEFT), word_type);
break;
}
crash("(ChkStandard)");
}
- if (arg->nd_right) {
- return df_error(arg->nd_right, "too many parameters supplied", edf);
+ if (arg->nd_RIGHT) {
+ df_error(arg->nd_RIGHT, "too many parameters supplied", edf);
+ return 0;
}
+ if (isconstant) {
+ cstcall(expp, edf->df_value.df_stdname);
+ return 1;
+ }
if (free_it) {
- FreeNode(expp->nd_left);
- *expp = *(arg->nd_left);
- arg->nd_left = 0;
- FreeNode(arg);
+ *expp = arg->nd_LEFT;
+ exp->nd_RIGHT = arg;
+ arg->nd_LEFT = 0;
+ FreeNode(exp);
}
return 1;
STATIC int
ChkCast(expp)
- register t_node *expp;
+ t_node **expp;
{
/* Check a cast and perform it if the argument is constant.
If the sizes don't match, only complain if at least one of them
is no problem as such values take a word on the EM stack
anyway.
*/
- register t_node *arg = expp->nd_right;
- register t_type *lefttype = expp->nd_left->nd_type;
- t_def *df = expp->nd_left->nd_def;
+ register t_node *exp = *expp;
+ register t_node *arg = exp->nd_RIGHT;
+ register t_type *lefttype = exp->nd_LEFT->nd_type;
+ t_def *df = exp->nd_LEFT->nd_def;
- if ((! arg) || arg->nd_right) {
- return df_error(expp, "type cast must have 1 parameter", df);
+ if ((! arg) || arg->nd_RIGHT) {
+ df_error(exp, "type cast must have 1 parameter", df);
+ return 0;
}
- if (! ChkExpression(arg->nd_left)) return 0;
+ if (! ChkExpression(&(arg->nd_LEFT))) return 0;
- MkCoercion(&(arg->nd_left), BaseType(arg->nd_left->nd_type));
+ MkCoercion(&(arg->nd_LEFT), BaseType(arg->nd_LEFT->nd_type));
- arg = arg->nd_left;
+ arg = arg->nd_LEFT;
if (arg->nd_type->tp_size != lefttype->tp_size &&
(arg->nd_type->tp_size > word_size ||
lefttype->tp_size > word_size)) {
- return df_error(expp, "unequal sizes in type cast", df);
+ df_error(exp, "unequal sizes in type cast", df);
+ return 0;
}
if (IsConformantArray(arg->nd_type)) {
- return df_error(expp,
+ df_error(exp,
"type transfer function on conformant array not supported",
df);
+ return 0;
}
- expp->nd_right->nd_left = 0;
- FreeLR(expp);
+ exp->nd_RIGHT->nd_LEFT = 0;
+ FreeNode(exp);
if (arg->nd_class == Value) {
- *expp = *arg;
- free_node(arg);
+ exp = arg;
if (lefttype->tp_fund == T_SET) {
/* User deserves what he gets here ... */
- arith val = expp->nd_INT;
-
- expp->nd_set = MkSet((unsigned)(lefttype->tp_size));
- expp->nd_set[0] = val;
+ exp = getnode(Set);
+ exp->nd_set = MkSet((unsigned)(lefttype->set_sz));
+ exp->nd_set[0] = arg->nd_INT;
+ exp->nd_lineno = arg->nd_lineno;
+ FreeNode(arg);
}
}
else {
- expp->nd_symb = CAST;
- expp->nd_class = Uoper;
- expp->nd_right = arg;
+ exp = getnode(Uoper);
+ exp->nd_symb = CAST;
+ exp->nd_lineno = arg->nd_lineno;
+ exp->nd_RIGHT = arg;
}
- expp->nd_type = lefttype;
+ *expp = exp;
+ exp->nd_type = lefttype;
return 1;
}
{
/* Try a coercion from character constant to string.
*/
- static char buf[2];
+ static char buf[8];
assert(nd->nd_symb == STRING);
nd->nd_type = standard_type(T_STRING, 1, (arith) 2);
nd->nd_SSTR =
(struct string *) Malloc(sizeof(struct string));
- nd->nd_STR = Salloc(buf, 2);
+ nd->nd_STR = Salloc(buf, (unsigned) word_size);
nd->nd_SLE = 1;
}
}
STATIC int
no_desig(expp)
- t_node *expp;
+ t_node **expp;
{
- node_error(expp, "designator expected");
+ node_error(*expp, "designator expected");
return 0;
}
STATIC int
add_flags(expp, flags)
- t_node *expp;
+ t_node **expp;
{
- expp->nd_def->df_flags |= flags;
+ (*expp)->nd_def->df_flags |= flags;
return 1;
}
-extern int NodeCrash();
+extern int PNodeCrash();
int (*ExprChkTable[])() = {
ChkValue,
ChkUnOper,
ChkArrow,
ChkFunCall,
- ChkExLinkOrName,
- NodeCrash,
+ ChkExSelOrName,
+ PNodeCrash,
ChkSet,
add_flags,
- NodeCrash,
- ChkExLinkOrName,
+ PNodeCrash,
+ ChkExSelOrName,
+ PNodeCrash,
};
int (*DesigChkTable[])() = {
no_desig,
ChkArrow,
no_desig,
- ChkLinkOrName,
- NodeCrash,
+ ChkSelOrName,
+ PNodeCrash,
no_desig,
add_flags,
- NodeCrash,
- ChkLinkOrName,
+ PNodeCrash,
+ ChkSelOrName,
+ PNodeCrash,
};
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)
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;
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;
}
/* 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;
}
#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) {
C_lxl((arith) (proclevel - level));
}
needs_fn = df->df_scope->sc_defmodule;
- C_cal(NameOfProc(df));
+ C_cal(df->prc_name);
break;
}}
/* Fall through */
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);
}
}
}
- 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)
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) {
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);
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);
register t_node *nd;
{
- CodePExpr(nd->nd_left);
- CodePExpr(nd->nd_right);
+ CodePExpr(nd->nd_LEFT);
+ CodePExpr(nd->nd_RIGHT);
DoLineno(nd);
}
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) {
{
register t_type *tp = nd->nd_type;
- CodePExpr(nd->nd_right);
+ CodePExpr(nd->nd_RIGHT);
switch(nd->nd_symb) {
case NOT:
C_teq();
}
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;
{
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;
}
}
#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[];
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;
case '-':
if (o1 == min_int[(int)(right->nd_type->tp_size)]) {
- overflow(expp);
+ overflow(exp);
}
o1 = -o1;
break;
}
commonbin(expp);
- expp->nd_INT = o1;
+ (*expp)->nd_INT = o1;
+ CutSize(*expp);
}
STATIC
}
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)) {
break;
case MOD:
if (o2 == 0) {
- node_error(expp, "modulo by 0");
+ node_error(exp, "modulo by 0");
return;
}
if ((o1 < 0) != (o2 < 0)) {
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;
}
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;
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;
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:
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;
}
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;
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);
case MOD:
if (o2 == 0) {
- node_error(expp, "modulo by 0");
+ node_error(exp, "modulo by 0");
return;
}
divide(&o1, &o2);
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;
}
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:
/* 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++;
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.
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)
fatal("sizeof (arith) insufficient on this machine");
}
+#ifndef NOCROSS
wrd_bits = 8 * (int) word_size;
+#endif
}
{
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;)
else
#endif
error("':' missing");
- tp = qualified_type(nd);
+ tp = qualified_type(&nd);
}
]
| ':' qualtype(&tp)
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); }
]*
;
}
[
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");
t_node *nd;
} :
qualident(&nd)
- { *ptp = qualified_type(nd); }
+ { *ptp = qualified_type(&nd); }
;
ProcedureType(t_type **ptp;)
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); }
{
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; }
;
#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
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 {
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;
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;
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;
}
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:
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
*/
case Arrow:
assert(nd->nd_symb == '^');
- nd = nd->nd_right;
+ nd = nd->nd_RIGHT;
CodeDesig(nd, ds);
switch(ds->dsg_kind) {
case DSG_LOADED:
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)++;
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;
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,
/* 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;
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) {
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,
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),
#include "idf.h"
#include "def.h"
#include "node.h"
-#include "const.h"
#include "type.h"
#include "chk_expr.h"
#include "warning.h"
]*
;
-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; }
;
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));
}
;
/* relation */
[ '=' | '#' | '<' | LESSEQUAL | '>' | GREATEREQUAL | IN ]
{ *pnd = dot2node(Oper, *pnd, NULLNODE); }
- SimpleExpression(&((*pnd)->nd_right))
+ SimpleExpression(&((*pnd)->nd_RIGHT))
|
]
;
]
term(pnd)
{ if (nd) {
- nd->nd_right = *pnd;
+ nd->nd_RIGHT = *pnd;
*pnd = nd;
}
nd = *pnd;
/* AddOperator */
[ '+' | '-' | OR ]
{ nd = dot2node(Oper, nd, NULLNODE); }
- term(&(nd->nd_right))
+ term(&(nd->nd_RIGHT))
]*
{ *pnd = nd; }
;
/* MulOperator */
[ '*' | '/' | DIV | MOD | AND ]
{ nd = dot2node(Oper, nd, NULLNODE); }
- factor(&(nd->nd_right))
+ factor(&(nd->nd_RIGHT))
]*
{ *pnd = nd; }
;
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)
if (class == Arrsel ||
class == Arrow ||
class == Name ||
- class == Link) {
- nd->nd_right = *p;
+ class == Select) {
+ nd->nd_RIGHT = *p;
*p = nd;
}
else FreeNode(nd);
')'
|
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)
]*
|
;
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 = ',';
}
;
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; }
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)
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*/
}
/* $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 */
#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
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
/* ALLOCDEF "node" 50 */
-extern t_node *MkNode(), *MkLeaf(), *dot2node(), *dot2leaf();
+extern t_node *MkNode(), *MkLeaf(), *dot2node(), *dot2leaf(), *getnode();
#define NULLNODE ((t_node *) 0)
#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;
{
/* 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;
}
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)
crash("Illegal node %d", expp->nd_class);
}
+PNodeCrash(expp)
+ t_node **expp;
+{
+ crash("Illegal node %d", (*expp)->nd_class);
+}
+
#ifdef DEBUG
extern char *symbol2str();
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
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;
}
'.'
#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;
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;
nd->nd_symb = '(';
nd->nd_lineno = (*pnd)->nd_lineno;
}
- ActualParameters(&(nd->nd_right))?
+ ActualParameters(&(nd->nd_RIGHT))?
|
[ BECOMES
| '=' { error("':=' expected instead of '='");
}
]
{ nd = dot2node(Stat, *pnd, NULLNODE); }
- expression(&(nd->nd_right))
+ expression(&(nd->nd_RIGHT))
]
{ *pnd = nd; }
/*
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--; }
|
nd1 = dot2node(Link, *pnd, nd);
*pnd = nd1;
nd1->nd_symb = ';';
- pnd = &(nd1->nd_right);
+ pnd = &(nd1->nd_RIGHT);
}
}
]*
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
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
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);
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
;
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
;
*/
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
;
RETURN { *pnd = nd = dot2leaf(Stat); }
[
- expression(&(nd->nd_right))
+ expression(&(nd->nd_RIGHT))
{ if (scopeclosed(CurrentScope)) {
error("a module body cannot return a value");
}
#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
float_size,
double_size,
pointer_size; /* All from type.c */
+
+extern unsigned int
+ wrd_bits; /* from cstoper.c */
#endif NOCROSS
extern arith
#include "type.h"
#include "idf.h"
#include "node.h"
-#include "const.h"
#include "scope.h"
#include "walk.h"
#include "chk_expr.h"
pointer_size = SZ_POINTER;
#endif
+#define arith_sign ((arith) (1L << (sizeof(arith) * 8 - 1)))
+
arith ret_area_size;
t_type
}
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);
}
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;
}
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);
}
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;
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
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
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 */
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);
*/
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);
{
/* 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);
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;
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;
}
{ 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;
}
{
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);
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);
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;
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;
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;
}
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);
}
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");
}
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) ||
}
} 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:
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);
}
public / ack.git / commitdiff