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

Minor adaptions in order to reduce the size

Browse source
This commit is contained in:
ceriel 1987-09-23 16:39:43 +00:00
parent 1eda133f01
commit fd817d4dbc
34 changed files with 790 additions and 746 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -32,9 +32,9 @@
long str2long();
struct token dot,
t_token dot,
aside;
struct type *toktype;
t_type *toktype;
int idfsize = IDFSIZE;
int ForeignFlag;
#ifdef DEBUG
@ -236,7 +236,7 @@ LLlex()
/* LLlex() is the Lexical Analyzer.
The putting aside of tokens is taken into account.
*/
register struct token *tk = ˙
register t_token *tk = ˙
char buf[(IDFSIZE > NUMSIZE ? IDFSIZE : NUMSIZE) + 2];
register int ch, nch;
@ -339,7 +339,7 @@ again:
case STIDF:
{
register char *tag = &buf[0];
register struct idf *id;
register t_idf *id;
do {
if (tag - buf < idfsize) *tag++ = ch;

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

@ -32,13 +32,15 @@ struct token {
} tk_data;
};
typedef struct token t_token;
#define TOK_IDF tk_data.tk_idf
#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_REL tk_data.tk_real
extern struct token dot, aside;
extern t_token dot, aside;
extern struct type *toktype;
#define DOT dot.tk_symb

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

@ -24,7 +24,7 @@
#include "Lpars.h"
extern char *symbol2str();
extern struct idf *gen_anon_idf();
extern t_idf *gen_anon_idf();
LLmessage(tk)
register int tk;
@ -32,7 +32,7 @@ LLmessage(tk)
if (tk > 0) {
/* if (tk > 0), it represents the token to be inserted.
*/
register struct token *dotp = &dot;
register t_token *dotp = &dot;
error("%s missing", symbol2str(tk));

2
lang/m2/comp/Makefile
View file

@ -39,7 +39,7 @@ OBJ = $(COBJ) $(LOBJ) Lpars.o
GENH= errout.h\
idfsize.h numsize.h strsize.h target_sizes.h \
inputtype.h maxset.h density.h\
inputtype.h maxset.h density.h squeeze.h \
def.h debugcst.h type.h Lpars.h node.h desig.h
HFILES= LLlex.h\
chk_expr.h class.h const.h debug.h f_info.h idf.h\

6
lang/m2/comp/Parameters
View file

@ -59,3 +59,9 @@
!File: density.h
#define DENSITY 3 /* see casestat.C for an explanation */
!File: squeeze.h
#undef SQUEEZE 1 /* define on "small" machines */

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

@ -24,6 +24,7 @@
#include <alloc.h>
#include <assert.h>
#include "squeeze.h"
#include "Lpars.h"
#include "type.h"
#include "LLlex.h"
@ -38,7 +39,7 @@ struct switch_hdr {
label sh_break; /* label of statement after this one */
label sh_default; /* label of ELSE part, or 0 */
int sh_nrofentries; /* number of cases */
struct type *sh_type; /* type of case expression */
t_type *sh_type; /* type of case expression */
arith sh_lowerbd; /* lowest case label */
arith sh_upperbd; /* highest case label */
struct case_entry *sh_entries; /* the cases with their generated
@ -65,7 +66,7 @@ struct case_entry {
#define compact(nr, low, up) (nr != 0 && (up - low) / nr <= DENSITY)
CaseCode(nd, exitlabel)
struct node *nd;
t_node *nd;
label exitlabel;
{
/* Check the expression, stack a new case header and
@ -74,7 +75,7 @@ CaseCode(nd, exitlabel)
LOOP-statement, or 0.
*/
register struct switch_hdr *sh = new_switch_hdr();
register struct node *pnode = nd;
register t_node *pnode = nd;
register struct case_entry *ce;
register arith val;
label CaseDescrLab;
@ -151,7 +152,7 @@ CaseCode(nd, exitlabel)
else if (sh->sh_default) C_rom_ilb(sh->sh_default);
else C_rom_ucon("0", pointer_size);
}
C_lae_dlb(CaseDescrLab, (arith)0); /* perform the switch */
c_lae_dlb(CaseDescrLab); /* perform the switch */
C_csa(word_size);
}
else {
@ -164,7 +165,7 @@ CaseCode(nd, exitlabel)
C_rom_cst(ce->ce_value);
C_rom_ilb(ce->ce_label);
}
C_lae_dlb(CaseDescrLab, (arith)0); /* perform the switch */
c_lae_dlb(CaseDescrLab); /* perform the switch */
C_csb(word_size);
}
@ -174,8 +175,9 @@ CaseCode(nd, exitlabel)
while (pnode = pnode->nd_right) {
if (pnode->nd_class == Link && pnode->nd_symb == '|') {
if (pnode->nd_left) {
C_df_ilb(pnode->nd_lab);
WalkNode(pnode->nd_left->nd_right, exitlabel);
LblWalkNode(pnode->nd_lab,
pnode->nd_left->nd_right,
exitlabel);
C_bra(sh->sh_break);
}
}
@ -184,8 +186,7 @@ CaseCode(nd, exitlabel)
*/
assert(sh->sh_default != 0);
C_df_ilb(sh->sh_default);
WalkNode(pnode, exitlabel);
LblWalkNode(sh->sh_default, pnode, exitlabel);
break;
}
}
@ -214,7 +215,7 @@ FreeSh(sh)
AddCases(sh, node, lbl)
struct switch_hdr *sh;
register struct node *node;
register t_node *node;
label lbl;
{
/* Add case labels to the case label list
@ -246,7 +247,7 @@ AddCases(sh, node, lbl)
AddOneCase(sh, node, lbl)
register struct switch_hdr *sh;
struct node *node;
t_node *node;
label lbl;
{
register struct case_entry *ce = new_case_entry();

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

@ -36,34 +36,37 @@ extern char *symbol2str();
extern char *sprint();
STATIC int
Xerror(nd, mess, edf)
struct node *nd;
char *mess;
register struct def *edf;
df_error(nd, mess, edf)
t_node *nd; /* node on which error occurred */
char *mess; /* error message */
register t_def *edf; /* do we have a name? */
{
if (edf) {
if (edf->df_kind != D_ERROR) {
node_error(nd,"\"%s\": %s", edf->df_idf->id_text, mess);
}
}
else node_error(nd, "%s", mess);
else node_error(nd, mess);
return 0;
}
MkCoercion(pnd, tp)
struct node **pnd;
register struct type *tp;
t_node **pnd;
register t_type *tp;
{
register struct node *nd = *pnd;
register struct type *nd_tp = nd->nd_type;
extern int pass_1;
int w = 0;
/* Make a coercion from the node indicated by *pnd to the
type indicated by tp.
*/
register t_node *nd = *pnd;
register t_type *nd_tp = nd->nd_type;
extern int pass_1;
int w = 0;
if (nd_tp == tp) return;
if (nd_tp->tp_fund == T_STRING) return;
if (nd_tp == tp || nd_tp->tp_fund == T_STRING /* Why ??? */) return;
nd_tp = BaseType(nd_tp);
if (nd->nd_class == Value &&
(nd_tp->tp_fund != T_REAL && tp->tp_fund != T_REAL)) {
nd_tp->tp_fund != T_REAL &&
tp->tp_fund != T_REAL) {
switch(tp->tp_fund) {
case T_SUBRANGE:
if (! chk_bounds(tp->sub_lb, nd->nd_INT,
@ -123,7 +126,7 @@ MkCoercion(pnd, tp)
int
ChkVariable(expp)
register struct node *expp;
register t_node *expp;
{
/* Check that "expp" indicates an item that can be
assigned to.
@ -132,17 +135,17 @@ ChkVariable(expp)
return ChkDesignator(expp) &&
( expp->nd_class != Def ||
( expp->nd_def->df_kind & (D_FIELD|D_VARIABLE)) ||
Xerror(expp, "variable expected", expp->nd_def));
df_error(expp, "variable expected", expp->nd_def));
}
STATIC int
ChkArrow(expp)
register struct node *expp;
register t_node *expp;
{
/* Check an application of the '^' operator.
The operand must be a variable of a pointer type.
*/
register struct type *tp;
register t_type *tp;
assert(expp->nd_class == Arrow);
assert(expp->nd_symb == '^');
@ -164,7 +167,7 @@ ChkArrow(expp)
STATIC int
ChkArr(expp)
register struct node *expp;
register t_node *expp;
{
/* Check an array selection.
The left hand side must be a variable of an array type,
@ -172,7 +175,7 @@ ChkArr(expp)
assignment compatible with the array-index.
*/
register struct type *tpl;
register t_type *tpl;
assert(expp->nd_class == Arrsel);
assert(expp->nd_symb == '[');
@ -180,6 +183,8 @@ ChkArr(expp)
expp->nd_type = error_type;
if (! (ChkVariable(expp->nd_left) & ChkExpression(expp->nd_right))) {
/* Bitwise and, because we want them both evaluated.
*/
return 0;
}
@ -204,7 +209,7 @@ ChkArr(expp)
#ifdef DEBUG
STATIC int
ChkValue(expp)
struct node *expp;
t_node *expp;
{
switch(expp->nd_symb) {
case REAL:
@ -221,12 +226,12 @@ ChkValue(expp)
STATIC int
ChkLinkOrName(expp)
register struct node *expp;
register t_node *expp;
{
/* Check either an ID or a construction of the form
ID.ID [ .ID ]*
*/
register struct def *df;
register t_def *df;
expp->nd_type = error_type;
@ -239,7 +244,7 @@ ChkLinkOrName(expp)
/* A selection from a record or a module.
Modules also have a record type.
*/
register struct node *left = expp->nd_left;
register t_node *left = expp->nd_left;
assert(expp->nd_symb == '.');
@ -250,7 +255,7 @@ ChkLinkOrName(expp)
!(left->nd_def->df_kind & (D_MODULE|D_VARIABLE|D_FIELD))
)
) {
return Xerror(left, "illegal selection", left->nd_def);
return df_error(left, "illegal selection", left->nd_def);
}
if (left->nd_type->tp_fund != T_RECORD) {
node_error(left, "illegal selection");
@ -268,7 +273,9 @@ ChkLinkOrName(expp)
/* Fields of a record are always D_QEXPORTED,
so ...
*/
Xerror(expp, "not exported from qualifying module", df);
df_error(expp,
"not exported from qualifying module",
df);
}
if (!(left->nd_class == Def &&
@ -286,12 +293,12 @@ Xerror(expp, "not exported from qualifying module", df);
STATIC int
ChkExLinkOrName(expp)
register struct node *expp;
register t_node *expp;
{
/* Check either an ID or an ID.ID [.ID]* occurring in an
expression.
*/
register struct def *df;
register t_def *df;
if (! ChkLinkOrName(expp)) return 0;
@ -302,6 +309,7 @@ ChkExLinkOrName(expp)
*/
if (df->df_type->tp_fund == T_SET) {
expp->nd_class = Set;
inc_refcount(expp->nd_set);
}
else expp->nd_class = Value;
if (df->df_kind == D_ENUM) {
@ -314,23 +322,11 @@ ChkExLinkOrName(expp)
assert(df->df_kind == D_CONST);
expp->nd_token = df->con_const;
expp->nd_lineno = ln;
if (expp->nd_class == Set) {
register int i =
(unsigned) expp->nd_type->tp_size /
(unsigned) word_size;
register arith *p, *q;
p = expp->nd_set;
q = (arith *) Malloc((unsigned) i * sizeof(arith));
expp->nd_set = q;
while (i--) *q++ = *p++;
}
}
}
if (!(df->df_kind & D_VALUE)) {
Xerror(expp, "value expected", df);
return 0;
return df_error(expp, "value expected", df);
}
if (df->df_kind == D_PROCEDURE) {
@ -341,7 +337,8 @@ ChkExLinkOrName(expp)
/* Address of standard or nested procedure
taken.
*/
node_error(expp, "standard or local procedures may not be assigned");
node_error(expp,
"standard or local procedures may not be assigned");
return 0;
}
}
@ -351,8 +348,8 @@ node_error(expp, "standard or local procedures may not be assigned");
STATIC int
ChkEl(expr, tp)
register struct node **expr;
struct type *tp;
register t_node **expr;
t_type *tp;
{
return ChkExpression(*expr) && ChkCompat(expr, tp, "set element");
@ -360,15 +357,15 @@ ChkEl(expr, tp)
STATIC int
ChkElement(expp, tp, set)
struct node **expp;
struct type *tp;
t_node **expp;
t_type *tp;
arith *set;
{
/* Check elements of a set. This routine may call itself
recursively.
Also try to compute the set!
*/
register struct node *expr = *expp;
register t_node *expr = *expp;
register unsigned int i;
arith lo, hi, low, high;
@ -419,17 +416,38 @@ ChkElement(expp, tp, set)
return 1;
}
arith *
MkSet(size)
unsigned size;
{
register arith *s;
size += sizeof(arith);
s = (arith *) Malloc(size);
clear((char *) s , size);
s++;
inc_refcount(s);
return s;
}
FreeSet(s)
register arith *s;
{
if (refcount(s) <= 0) {
free((char *) (s-1));
}
}
STATIC int
ChkSet(expp)
register struct node *expp;
register t_node *expp;
{
/* Check the legality of a SET aggregate, and try to evaluate it
compile time. Unfortunately this is all rather complicated.
*/
register struct type *tp;
register struct node *nd;
register struct def *df;
unsigned size;
register t_type *tp;
register t_node *nd;
register t_def *df;
int retval = 1;
int SetIsConstant = 1;
@ -449,10 +467,7 @@ ChkSet(expp)
if (!is_type(df) ||
(df->df_type->tp_fund != T_SET)) {
if (df->df_kind != D_ERROR) {
Xerror(nd, "not a SET type", df);
}
return 0;
return df_error(nd, "not a SET type", df);
}
tp = df->df_type;
FreeNode(nd);
@ -466,9 +481,8 @@ ChkSet(expp)
/* Now check the elements given, and try to compute a constant set.
First allocate room for the set.
*/
size = tp->tp_size * (sizeof(arith) / word_size);
expp->nd_set = (arith *) Malloc(size);
clear((char *) (expp->nd_set) , size);
expp->nd_set = MkSet((unsigned)(tp->tp_size) * (sizeof(arith) / (int) word_size));
/* Now check the elements, one by one
*/
@ -490,25 +504,26 @@ ChkSet(expp)
return retval;
}
STATIC struct node *
STATIC t_node *
nextarg(argp, edf)
struct node **argp;
struct def *edf;
t_node **argp;
t_def *edf;
{
register struct node *arg = (*argp)->nd_right;
register t_node *arg = (*argp)->nd_right;
if (! arg) {
return (struct node *)Xerror(*argp, "too few arguments supplied", edf);
return (t_node *)
df_error(*argp, "too few arguments supplied", edf);
}
*argp = arg;
return arg->nd_left;
}
STATIC struct node *
STATIC t_node *
getarg(argp, bases, designator, edf)
struct node **argp;
struct def *edf;
t_node **argp;
t_def *edf;
{
/* This routine is used to fetch the next argument from an
argument list. The argument list is indicated by "argp".
@ -518,9 +533,10 @@ getarg(argp, bases, designator, edf)
that it must be a designator and may not be a register
variable.
*/
register struct node *left = nextarg(argp, edf);
register t_node *left = nextarg(argp, edf);
if (!left || (designator ? !ChkVariable(left) : !ChkExpression(left))) {
if (! left ||
! (designator ? ChkVariable(left) : ChkExpression(left))) {
return 0;
}
@ -529,38 +545,40 @@ getarg(argp, bases, designator, edf)
}
if (bases) {
struct type *tp = BaseType(left->nd_type);
t_type *tp = BaseType(left->nd_type);
MkCoercion(&((*argp)->nd_left), tp);
if (! designator) MkCoercion(&((*argp)->nd_left), tp);
left = (*argp)->nd_left;
if (!(tp->tp_fund & bases)) {
return (struct node *)Xerror(left, "unexpected parameter type", edf);
return (t_node *)
df_error(left, "unexpected parameter type", edf);
}
}
return left;
}
STATIC struct node *
STATIC t_node *
getname(argp, kinds, bases, edf)
struct node **argp;
struct def *edf;
t_node **argp;
t_def *edf;
{
/* Get the next argument from argument list "argp".
The argument must indicate a definition, and the
definition kind must be one of "kinds".
*/
register struct node *left = nextarg(argp, edf);
register t_node *left = nextarg(argp, edf);
if (!left || ! ChkDesignator(left)) return 0;
if (left->nd_class != Def) {
return (struct node *)Xerror(left, "identifier expected", edf);
return (t_node *)df_error(left, "identifier expected", edf);
}
if (!(left->nd_def->df_kind & kinds) ||
(bases && !(left->nd_type->tp_fund & bases))) {
return (struct node *)Xerror(left, "unexpected parameter type", edf);
return (t_node *)
df_error(left, "unexpected parameter type", edf);
}
return left;
@ -568,12 +586,12 @@ getname(argp, kinds, bases, edf)
STATIC int
ChkProcCall(expp)
struct node *expp;
t_node *expp;
{
/* Check a procedure call
*/
register struct node *left;
struct def *edf = 0;
register t_node *left;
t_def *edf = 0;
register struct paramlist *param;
int retval = 1;
int cnt = 0;
@ -613,7 +631,7 @@ ChkProcCall(expp)
}
if (expp->nd_right) {
Xerror(expp->nd_right, "too many parameters supplied", edf);
df_error(expp->nd_right, "too many parameters supplied", edf);
while (expp->nd_right) {
getarg(&expp, 0, 0, edf);
}
@ -625,7 +643,7 @@ ChkProcCall(expp)
int
ChkFunCall(expp)
register struct node *expp;
register t_node *expp;
{
/* Check a call that must have a result
*/
@ -642,13 +660,13 @@ ChkFunCall(expp)
int
ChkCall(expp)
register struct node *expp;
register 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 struct node *left = expp->nd_left;
register t_node *left = expp->nd_left;
STATIC int ChkStandard();
STATIC int ChkCast();
@ -683,9 +701,9 @@ ChkCall(expp)
return ChkProcCall(expp);
}
STATIC struct type *
STATIC t_type *
ResultOfOperation(operator, tp)
struct type *tp;
t_type *tp;
{
/* Return the result type of the binary operation "operator",
with operand type "tp".
@ -744,7 +762,7 @@ AllowedTypes(operator)
STATIC int
ChkAddress(tpl, tpr)
register struct type *tpl, *tpr;
register t_type *tpl, *tpr;
{
/* Check that either "tpl" or "tpr" are both of type
address_type, or that one of them is, but the other is
@ -764,12 +782,12 @@ ChkAddress(tpl, tpr)
STATIC int
ChkBinOper(expp)
register struct node *expp;
register t_node *expp;
{
/* Check a binary operation.
*/
register struct node *left, *right;
register struct type *tpl, *tpr;
register t_node *left, *right;
register t_type *tpl, *tpr;
int allowed;
int retval;
@ -873,12 +891,12 @@ ChkBinOper(expp)
STATIC int
ChkUnOper(expp)
register struct node *expp;
register t_node *expp;
{
/* Check an unary operation.
*/
register struct node *right = expp->nd_right;
register struct type *tpr;
register t_node *right = expp->nd_right;
register t_type *tpr;
if (expp->nd_symb == '(') {
*expp = *right;
@ -896,7 +914,9 @@ ChkUnOper(expp)
switch(expp->nd_symb) {
case '+':
if (!(tpr->tp_fund & T_NUMERIC)) break;
/* fall through */
*expp = *right;
free_node(right);
return 1;
case '-':
if (tpr->tp_fund & T_INTORCARD) {
@ -935,15 +955,15 @@ ChkUnOper(expp)
return 0;
}
STATIC struct node *
STATIC t_node *
getvariable(argp, edf)
struct node **argp;
struct def *edf;
t_node **argp;
t_def *edf;
{
/* Get the next argument from argument list "argp".
It must obey the rules of "ChkVariable".
*/
register struct node *left = nextarg(argp, edf);
register t_node *left = nextarg(argp, edf);
if (!left || !ChkVariable(left)) return 0;
@ -952,14 +972,14 @@ getvariable(argp, edf)
STATIC int
ChkStandard(expp)
register struct node *expp;
register t_node *expp;
{
/* Check a call of a standard procedure or function
*/
struct node *arg = expp;
register struct node *left = expp->nd_left;
register struct def *edf = left->nd_def;
struct type *basetype;
t_node *arg = expp;
register t_node *left = expp->nd_left;
register t_def *edf = left->nd_def;
t_type *basetype;
int free_it = 0;
assert(left->nd_class == Def);
@ -1010,8 +1030,8 @@ ChkStandard(expp)
case S_SHORT:
case S_LONG: {
struct type *tp;
struct type *s1, *s2, *d1, *d2;
t_type *tp;
t_type *s1, *s2, *d1, *d2;
if (edf->df_value.df_stdname == S_SHORT) {
s1 = longint_type;
@ -1037,7 +1057,7 @@ ChkStandard(expp)
MkCoercion(&(arg->nd_left), d2);
}
else {
Xerror(left, "unexpected parameter type", edf);
df_error(left, "unexpected parameter type", edf);
break;
}
free_it = 1;
@ -1056,7 +1076,7 @@ ChkStandard(expp)
break;
}
if (left->nd_symb != STRING) {
return Xerror(left,"array parameter expected", edf);
return df_error(left,"array parameter expected", edf);
}
expp->nd_type = card_type;
expp->nd_class = Value;
@ -1105,12 +1125,12 @@ ChkStandard(expp)
expp->nd_type = 0;
if (! (left = getvariable(&arg, edf))) return 0;
if (! (left->nd_type->tp_fund == T_POINTER)) {
return Xerror(left, "pointer variable expected", edf);
return df_error(left, "pointer variable expected", edf);
}
/* Now, make it look like a call to ALLOCATE or DEALLOCATE */
{
struct token dt;
struct node *nd;
t_token dt;
t_node *nd;
dt.TOK_INT = PointedtoType(left->nd_type)->tp_size;
dt.tk_symb = INTEGER;
@ -1121,9 +1141,9 @@ ChkStandard(expp)
arg->nd_right = MkNode(Link, nd, NULLNODE, &dt);
/* Ignore other arguments to NEW and/or DISPOSE ??? */
FreeNode(expp->nd_left);
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 ?
"ALLOCATE" : "DEALLOCATE", 0);
expp->nd_left = MkLeaf(Name, &dt);
@ -1178,7 +1198,7 @@ ChkStandard(expp)
expp->nd_type = 0;
if (! (left = getvariable(&arg, edf))) return 0;
if (! (left->nd_type->tp_fund & T_DISCRETE)) {
return Xerror(left,"illegal parameter type", edf);
return df_error(left,"illegal parameter type", edf);
}
if (arg->nd_right) {
if (! getarg(&arg, T_INTORCARD, 0, edf)) return 0;
@ -1192,14 +1212,14 @@ ChkStandard(expp)
case S_EXCL:
case S_INCL:
{
register struct type *tp;
struct node *dummy;
register t_type *tp;
t_node *dummy;
expp->nd_type = 0;
if (!(left = getvariable(&arg, edf))) return 0;
tp = left->nd_type;
if (tp->tp_fund != T_SET) {
return Xerror(arg, "SET parameter expected", edf);
return df_error(arg, "SET parameter expected", edf);
}
if (!(dummy = getarg(&arg, 0, 0, edf))) return 0;
if (!ChkAssCompat(&dummy, ElementType(tp), "EXCL/INCL")) {
@ -1220,7 +1240,7 @@ ChkStandard(expp)
}
if (arg->nd_right) {
return Xerror(arg->nd_right, "too many parameters supplied", edf);
return df_error(arg->nd_right, "too many parameters supplied", edf);
}
if (free_it) {
@ -1235,7 +1255,7 @@ ChkStandard(expp)
STATIC int
ChkCast(expp)
register struct node *expp;
register 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
@ -1244,12 +1264,12 @@ ChkCast(expp)
is no problem as such values take a word on the EM stack
anyway.
*/
register struct node *left = expp->nd_left;
register struct node *arg = expp->nd_right;
register struct type *lefttype = left->nd_type;
register t_node *left = expp->nd_left;
register t_node *arg = expp->nd_right;
register t_type *lefttype = left->nd_type;
if ((! arg) || arg->nd_right) {
return Xerror(expp, "type cast must have 1 parameter", left->nd_def);
return df_error(expp, "type cast must have 1 parameter", left->nd_def);
}
if (! ChkExpression(arg->nd_left)) return 0;
@ -1260,7 +1280,7 @@ ChkCast(expp)
if (arg->nd_type->tp_size != lefttype->tp_size &&
(arg->nd_type->tp_size > word_size ||
lefttype->tp_size > word_size)) {
Xerror(expp, "unequal sizes in type cast", left->nd_def);
df_error(expp, "unequal sizes in type cast", left->nd_def);
}
if (arg->nd_class == Value) {
@ -1275,8 +1295,8 @@ ChkCast(expp)
}
TryToString(nd, tp)
register struct node *nd;
struct type *tp;
register t_node *nd;
t_type *tp;
{
/* Try a coercion from character constant to string.
*/
@ -1296,7 +1316,7 @@ TryToString(nd, tp)
STATIC int
no_desig(expp)
struct node *expp;
t_node *expp;
{
node_error(expp, "designator expected");
return 0;

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

@ -18,3 +18,6 @@ extern int (*DesigChkTable[])(); /* table of designator checking
#define ChkExpression(expp) ((*ExprChkTable[(expp)->nd_class])(expp))
#define ChkDesignator(expp) ((*DesigChkTable[(expp)->nd_class])(expp))
#define inc_refcount(s) (*((s) - 1) += 1)
#define refcount(s) (*((s) - 1))

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

@ -21,6 +21,7 @@
#include <assert.h>
#include <alloc.h>
#include "squeeze.h"
#include "type.h"
#include "LLlex.h"
#include "def.h"
@ -39,7 +40,7 @@ int fp_used;
STATIC char *
NameOfProc(df)
register struct def *df;
register t_def *df;
{
assert(df->df_kind & (D_PROCHEAD|D_PROCEDURE));
@ -68,14 +69,14 @@ CodeConst(cst, size)
/*
C_df_dlb(++data_label);
C_rom_icon(long2str((long) cst), (arith) size);
C_lae_dlb(data_label, (arith) 0);
c_lae_dlb(data_label);
C_loi((arith) size);
*/
}
}
CodeString(nd)
register struct node *nd;
register t_node *nd;
{
if (nd->nd_type->tp_fund != T_STRING) {
/* Character constant */
@ -84,15 +85,15 @@ CodeString(nd)
}
C_df_dlb(++data_label);
C_rom_scon(nd->nd_STR, WA(nd->nd_SLE + 1));
C_lae_dlb(data_label, (arith) 0);
c_lae_dlb(data_label);
}
CodeExpr(nd, ds, true_label, false_label)
register struct node *nd;
register struct desig *ds;
register t_node *nd;
register t_desig *ds;
label true_label, false_label;
{
register struct type *tp = nd->nd_type;
register t_type *tp = nd->nd_type;
if (tp->tp_fund == T_REAL) fp_used = 1;
switch(nd->nd_class) {
@ -126,7 +127,7 @@ CodeExpr(nd, ds, true_label, false_label)
case REAL:
C_df_dlb(++data_label);
C_rom_fcon(nd->nd_REL, tp->tp_size);
C_lae_dlb(data_label, (arith) 0);
c_lae_dlb(data_label);
C_loi(tp->tp_size);
break;
case STRING:
@ -154,8 +155,7 @@ CodeExpr(nd, ds, true_label, false_label)
for (; i; i--) {
C_loc(*--st);
}
free((char *) nd->nd_set);
nd->nd_set = 0;
FreeSet(nd->nd_set);
CodeSet(nd);
}
break;
@ -174,7 +174,7 @@ CodeExpr(nd, ds, true_label, false_label)
}
CodeCoercion(t1, t2)
register struct type *t1, *t2;
register t_type *t1, *t2;
{
register int fund1, fund2;
arith sz1 = t1->tp_size;
@ -208,7 +208,7 @@ CodeCoercion(t1, t2)
case T_INTEGER:
if (sz1 < word_size) {
C_loc(sz1);
C_loc(word_size);
c_loc((int) word_size);
C_cii();
}
switch(fund2) {
@ -222,7 +222,7 @@ CodeCoercion(t1, t2)
case T_CARDINAL:
if (t1->tp_size != word_size) {
C_loc(t1->tp_size);
C_loc(word_size);
c_loc((int) word_size);
C_ciu();
}
break;
@ -242,20 +242,20 @@ CodeCoercion(t1, t2)
case T_CARDINAL:
case T_INTORCARD:
if (t2->tp_size > word_size) {
C_loc(word_size);
c_loc((int) word_size);
C_loc(t2->tp_size);
C_cuu();
}
break;
case T_INTEGER:
if (fund1 == T_CARDINAL || t2->tp_size != word_size) {
C_loc(word_size);
c_loc((int) word_size);
C_loc(t2->tp_size);
C_cui();
}
break;
case T_REAL:
C_loc(word_size);
c_loc((int) word_size);
C_loc(t2->tp_size);
C_cuf();
break;
@ -286,7 +286,7 @@ CodeCoercion(t1, t2)
C_zrf(t1->tp_size);
C_cmf(t1->tp_size);
C_zge(lb);
C_loc((arith) ECONV);
c_loc(ECONV);
C_trp();
C_df_ilb(lb);
}
@ -302,14 +302,14 @@ CodeCoercion(t1, t2)
}
CodeCall(nd)
register struct node *nd;
register t_node *nd;
{
/* Generate code for a procedure call. Checking of parameters
and result is already done.
*/
register struct node *left = nd->nd_left;
register struct node *right = nd->nd_right;
register struct type *result_tp;
register t_node *left = nd->nd_left;
register t_node *right = nd->nd_right;
register t_type *result_tp;
if (left->nd_type == std_type) {
CodeStd(nd);
@ -360,11 +360,11 @@ CodeCall(nd)
CodeParameters(param, arg)
struct paramlist *param;
struct node *arg;
t_node *arg;
{
register struct type *tp;
register struct node *left;
register struct type *left_type;
register t_type *tp;
register t_node *left;
register t_type *left_type;
assert(param != 0 && arg != 0);
@ -376,7 +376,7 @@ CodeParameters(param, arg)
left = arg->nd_left;
left_type = left->nd_type;
if (IsConformantArray(tp)) {
register struct type *elem = tp->arr_elem;
register t_type *elem = tp->arr_elem;
C_loc(tp->arr_elsize);
if (IsConformantArray(left_type)) {
@ -388,9 +388,9 @@ CodeParameters(param, arg)
C_loc(left_type->arr_elem->tp_size);
C_mli(word_size);
if (elem == word_type) {
C_loc(word_size - 1);
c_loc((int) word_size - 1);
C_adi(word_size);
C_loc(word_size);
c_loc((int) word_size);
C_dvi(word_size);
}
else {
@ -412,7 +412,7 @@ CodeParameters(param, arg)
getbounds(IndexType(left_type), &lb, &ub);
C_loc(ub - lb);
}
C_loc((arith) 0);
c_loc(0);
if (left->nd_symb == STRING) {
CodeString(left);
}
@ -447,8 +447,8 @@ CodeParameters(param, arg)
}
CodePString(nd, tp)
struct node *nd;
struct type *tp;
t_node *nd;
t_type *tp;
{
arith szarg = WA(nd->nd_type->tp_size);
register arith zersz = WA(tp->tp_size) - szarg;
@ -463,11 +463,11 @@ CodePString(nd, tp)
}
CodeStd(nd)
struct node *nd;
t_node *nd;
{
register struct node *arg = nd->nd_right;
register struct node *left = 0;
register struct type *tp;
register t_node *arg = nd->nd_right;
register t_node *left = 0;
register t_type *tp;
int std = nd->nd_left->nd_def->df_value.df_stdname;
if (arg) {
@ -493,7 +493,7 @@ CodeStd(nd)
case S_CAP:
CodePExpr(left);
C_loc((arith) 0137); /* ASCII assumed */
c_loc(0137); /* ASCII assumed */
C_and(word_size);
break;
@ -514,7 +514,7 @@ CodeStd(nd)
case S_ODD:
CodePExpr(left);
if (tp->tp_size == word_size) {
C_loc((arith) 1);
c_loc(1);
C_and(word_size);
}
else {
@ -541,7 +541,7 @@ CodeStd(nd)
CodeCoercion(arg->nd_left->nd_type, tp);
}
else {
C_loc((arith) 1);
c_loc(1);
CodeCoercion(intorcard_type, tp);
}
if (std == S_DEC) {
@ -585,7 +585,7 @@ CodeStd(nd)
}
RangeCheck(tpl, tpr)
register struct type *tpl, *tpr;
register t_type *tpl, *tpr;
{
/* Generate a range check if neccessary
*/
@ -621,14 +621,14 @@ RangeCheck(tpl, tpr)
C_dup(word_size);
C_zge(lb);
C_loc((arith) ECONV);
c_loc(ECONV);
C_trp();
C_df_ilb(lb);
}
}
Operands(leftop, rightop)
register struct node *leftop, *rightop;
register t_node *leftop, *rightop;
{
CodePExpr(leftop);
@ -636,13 +636,13 @@ Operands(leftop, rightop)
}
CodeOper(expr, true_label, false_label)
register struct node *expr; /* the expression tree itself */
register t_node *expr; /* the expression tree itself */
label true_label;
label false_label; /* labels to jump to in logical expr's */
{
register struct node *leftop = expr->nd_left;
register struct node *rightop = expr->nd_right;
register struct type *tp = expr->nd_type;
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) {
case '+':
@ -830,7 +830,7 @@ CodeOper(expr, true_label, false_label)
case OR:
case AND: {
label l_maybe = ++text_label, l_end;
struct desig *Des = new_desig();
t_desig *Des = new_desig();
int genlabels = 0;
if (true_label == NO_LABEL) {
@ -850,10 +850,10 @@ CodeOper(expr, true_label, false_label)
CodeExpr(rightop, Des, true_label, false_label);
if (genlabels) {
C_df_ilb(true_label);
C_loc((arith)1);
c_loc(1);
C_bra(l_end);
C_df_ilb(false_label);
C_loc((arith)0);
c_loc(0);
C_df_ilb(l_end);
}
free_desig(Des);
@ -922,9 +922,9 @@ truthvalue(relop)
}
CodeUoper(nd)
register struct node *nd;
register t_node *nd;
{
register struct type *tp = nd->nd_type;
register t_type *tp = nd->nd_type;
CodePExpr(nd->nd_right);
switch(nd->nd_symb) {
@ -954,9 +954,9 @@ CodeUoper(nd)
}
CodeSet(nd)
register struct node *nd;
register t_node *nd;
{
register struct type *tp = nd->nd_type;
register t_type *tp = nd->nd_type;
nd = nd->nd_right;
while (nd) {
@ -968,10 +968,10 @@ CodeSet(nd)
}
CodeEl(nd, tp)
register struct node *nd;
register struct type *tp;
register t_node *nd;
register t_type *tp;
{
register struct type *eltype = ElementType(tp);
register t_type *eltype = ElementType(tp);
if (nd->nd_class == Link && nd->nd_symb == UPTO) {
C_loc(tp->tp_size); /* push size */
@ -991,12 +991,12 @@ CodeEl(nd, tp)
}
CodePExpr(nd)
register struct node *nd;
register t_node *nd;
{
/* Generate code to push the value of the expression "nd"
on the stack.
*/
register struct desig *designator = new_desig();
register t_desig *designator = new_desig();
CodeExpr(nd, designator, NO_LABEL, NO_LABEL);
CodeValue(designator, nd->nd_type);
@ -1004,13 +1004,13 @@ CodePExpr(nd)
}
CodeDAddress(nd)
struct node *nd;
t_node *nd;
{
/* Generate code to push the address of the designator "nd"
on the stack.
*/
register struct desig *designator = new_desig();
register t_desig *designator = new_desig();
ChkForFOR(nd);
CodeDesig(nd, designator);
@ -1019,13 +1019,13 @@ CodeDAddress(nd)
}
CodeDStore(nd)
register struct node *nd;
register t_node *nd;
{
/* Generate code to store the expression on the stack into the
designator "nd".
*/
register struct desig *designator = new_desig();
register t_desig *designator = new_desig();
ChkForFOR(nd);
CodeDesig(nd, designator);
@ -1034,7 +1034,7 @@ CodeDStore(nd)
}
DoHIGH(df)
register struct def *df;
register t_def *df;
{
/* Get the high index of a conformant array, indicated by "nd".
The high index is the second field in the descriptor of
@ -1055,3 +1055,16 @@ DoHIGH(df)
}
else C_lol(highoff);
}
#ifdef SQUEEZE
c_loc(n)
{
C_loc((arith) n);
}
c_lae_dlb(l)
label l;
{
C_lae_dlb(l, (arith) 0);
}
#endif

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

@ -38,12 +38,12 @@ extern char options[];
static char ovflow[] = "overflow in constant expression";
cstunary(expp)
register struct node *expp;
register t_node *expp;
{
/* The unary operation in "expp" is performed on the constant
expression below it, and the result restored in expp.
*/
register struct node *right = expp->nd_right;
register t_node *right = expp->nd_right;
switch(expp->nd_symb) {
/* Should not get here
@ -75,7 +75,7 @@ cstunary(expp)
}
cstbin(expp)
register struct node *expp;
register t_node *expp;
{
/* The binary operation in "expp" is performed on the constant
expressions below it, and the result restored in
@ -236,10 +236,11 @@ cstbin(expp)
}
cstset(expp)
register struct node *expp;
register t_node *expp;
{
extern arith *MkSet();
register arith *set1, *set2;
arith *resultset = 0;
register arith *resultset;
register unsigned int setsize;
register int j;
@ -259,114 +260,90 @@ cstset(expp)
expp->nd_INT = (expp->nd_left->nd_INT >= 0 &&
expp->nd_left->nd_INT < setsize * wrd_bits &&
(set2[i / wrd_bits] & (1 << (i % wrd_bits))));
free((char *) set2);
FreeSet(set2);
expp->nd_symb = INTEGER;
}
else {
set1 = expp->nd_left->nd_set;
resultset = set1;
expp->nd_left->nd_set = 0;
switch(expp->nd_symb) {
case '+':
/* Set union
*/
for (j = 0; j < setsize; j++) {
*set1++ |= *set2++;
}
break;
case '-':
/* Set difference
*/
for (j = 0; j < setsize; j++) {
*set1++ &= ~*set2++;
}
break;
case '*':
/* Set intersection
*/
for (j = 0; j < setsize; j++) {
*set1++ &= *set2++;
}
break;
case '/':
/* Symmetric set difference
*/
for (j = 0; j < setsize; j++) {
*set1++ ^= *set2++;
}
break;
case GREATEREQUAL:
case LESSEQUAL:
case '=':
case '#':
/* Constant set comparisons
*/
expp->nd_left->nd_set = set1; /* may be disposed of */
for (j = 0; j < setsize; j++) {
switch(expp->nd_symb) {
case GREATEREQUAL:
if ((*set1 | *set2++) != *set1) break;
set1++;
continue;
case LESSEQUAL:
if ((*set2 | *set1++) != *set2) break;
set2++;
continue;
case '=':
case '#':
if (*set1++ != *set2++) break;
continue;
}
break;
}
if (j < setsize) {
expp->nd_INT = expp->nd_symb == '#';
}
else {
expp->nd_INT = expp->nd_symb != '#';
}
expp->nd_class = Value;
expp->nd_symb = INTEGER;
freesets(expp);
return;
default:
crash("(cstset)");
}
freesets(expp);
expp->nd_class = Set;
expp->nd_set = resultset;
FreeNode(expp->nd_left);
FreeNode(expp->nd_right);
expp->nd_left = expp->nd_right = 0;
return;
}
FreeNode(expp->nd_left);
FreeNode(expp->nd_right);
expp->nd_left = expp->nd_right = 0;
}
freesets(expp)
register struct node *expp;
{
if (expp->nd_right->nd_set) {
free((char *) expp->nd_right->nd_set);
}
if (expp->nd_left->nd_set) {
free((char *) expp->nd_left->nd_set);
set1 = expp->nd_left->nd_set;
switch(expp->nd_symb) {
case '+': /* Set union */
case '-': /* Set difference */
case '*': /* Set intersection */
case '/': /* Symmetric set difference */
expp->nd_set = resultset = MkSet(setsize * (unsigned) word_size);
for (j = 0; j < setsize; j++) {
switch(expp->nd_symb) {
case '+':
*resultset = *set1++ | *set2++;
break;
case '-':
*resultset = *set1++ & ~*set2++;
break;
case '*':
*resultset = *set1++ & *set2++;
break;
case '/':
*resultset = *set1++ ^ *set2++;
break;
}
resultset++;
}
expp->nd_class = Set;
break;
case GREATEREQUAL:
case LESSEQUAL:
case '=':
case '#':
/* Constant set comparisons
*/
for (j = 0; j < setsize; j++) {
switch(expp->nd_symb) {
case GREATEREQUAL:
if ((*set1 | *set2++) != *set1) break;
set1++;
continue;
case LESSEQUAL:
if ((*set2 | *set1++) != *set2) break;
set2++;
continue;
case '=':
case '#':
if (*set1++ != *set2++) break;
continue;
}
break;
}
if (j < setsize) {
expp->nd_INT = expp->nd_symb == '#';
}
else {
expp->nd_INT = expp->nd_symb != '#';
}
expp->nd_class = Value;
expp->nd_symb = INTEGER;
break;
default:
crash("(cstset)");
}
FreeSet(expp->nd_left->nd_set);
FreeSet(expp->nd_right->nd_set);
FreeNode(expp->nd_left);
FreeNode(expp->nd_right);
expp->nd_left = expp->nd_right = 0;
}
cstcall(expp, call)
register struct node *expp;
register t_node *expp;
{
/* a standard procedure call is found that can be evaluated
compile time, so do so.
*/
register struct node *expr = 0;
register t_node *expr = 0;
assert(expp->nd_class == Call);
@ -440,13 +417,13 @@ cstcall(expp, call)
}
CutSize(expr)
register struct node *expr;
register t_node *expr;
{
/* The constant value of the expression expr is made to
conform to the size of the type of the expression.
*/
register arith o1 = expr->nd_INT;
register struct type *tp = BaseType(expr->nd_type);
register t_type *tp = BaseType(expr->nd_type);
int uns;
int size = tp->tp_size;

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

@ -32,13 +32,13 @@ int proclevel = 0; /* nesting level of procedures */
int return_occurred; /* set if a return occurs in a block */
#define needs_static_link() (proclevel > 1)
extern struct node *EmptyStatement;
extern t_node *EmptyStatement;
}
/* inline in declaration: need space
ProcedureDeclaration
{
struct def *df;
t_def *df;
} :
{ ++proclevel; }
ProcedureHeading(&df, D_PROCEDURE)
@ -50,9 +50,9 @@ ProcedureDeclaration
;
*/
ProcedureHeading(struct def **pdf; int type;)
ProcedureHeading(t_def **pdf; int type;)
{
struct type *tp = 0;
t_type *tp = 0;
arith parmaddr = needs_static_link() ? pointer_size : 0;
struct paramlist *pr = 0;
} :
@ -78,7 +78,7 @@ warning(W_STRICT, "procedure \"%s\" has a constructed result type",
}
;
block(struct node **pnd;) :
block(t_node **pnd;) :
[ %persistent
declaration
]*
@ -94,7 +94,7 @@ block(struct node **pnd;) :
declaration
{
struct def *df;
t_def *df;
} :
CONST [ ConstantDeclaration ';' ]*
|
@ -116,7 +116,7 @@ declaration
;
/* inline in procedureheading: need space
FormalParameters(struct paramlist **ppr; arith *parmaddr; struct type **ptp;):
FormalParameters(struct paramlist **ppr; arith *parmaddr; t_type **ptp;):
'('
[
FPSection(ppr, parmaddr)
@ -132,15 +132,15 @@ FormalParameters(struct paramlist **ppr; arith *parmaddr; struct type **ptp;):
FPSection(struct paramlist **ppr; arith *parmaddr;)
{
struct node *FPList;
struct type *tp;
t_node *FPList;
t_type *tp;
int VARp;
} :
var(&VARp) IdentList(&FPList) ':' FormalType(&tp)
{ EnterParamList(ppr, FPList, tp, VARp, parmaddr); }
;
FormalType(struct type **ptp;)
FormalType(t_type **ptp;)
{
extern arith ArrayElSize();
} :
@ -148,7 +148,7 @@ FormalType(struct type **ptp;)
{ /* index type of conformant array is "CARDINAL".
Recognize a conformant array by size 0.
*/
register struct type *tp = construct_type(T_ARRAY, card_type);
register t_type *tp = construct_type(T_ARRAY, card_type);
tp->arr_elem = *ptp;
*ptp = tp;
@ -161,20 +161,20 @@ FormalType(struct type **ptp;)
TypeDeclaration
{
struct def *df;
struct type *tp;
register struct node *nd;
t_def *df;
t_type *tp;
register t_node *nd;
}:
IDENT { df = define(dot.TOK_IDF, CurrentScope, D_TYPE);
nd = dot2leaf(Name);
}
'=' type(&tp)
{ DeclareType(nd, df, tp);
free_node(nd);
FreeNode(nd);
}
;
type(register struct type **ptp;):
type(register t_type **ptp;):
%default SimpleType(ptp)
|
ArrayType(ptp)
@ -188,9 +188,9 @@ type(register struct type **ptp;):
ProcedureType(ptp)
;
SimpleType(register struct type **ptp;)
SimpleType(register t_type **ptp;)
{
struct type *tp;
t_type *tp;
} :
qualtype(ptp)
[
@ -208,17 +208,17 @@ SimpleType(register struct type **ptp;)
SubrangeType(ptp)
;
enumeration(struct type **ptp;)
enumeration(t_type **ptp;)
{
struct node *EnumList;
t_node *EnumList;
} :
'(' IdentList(&EnumList) ')'
{ *ptp = enum_type(EnumList); }
;
IdentList(struct node **p;)
IdentList(t_node **p;)
{
register struct node *q;
register t_node *q;
} :
IDENT { *p = q = dot2leaf(Value); }
[ %persistent
@ -230,9 +230,9 @@ IdentList(struct node **p;)
{ q->nd_left = 0; }
;
SubrangeType(struct type **ptp;)
SubrangeType(t_type **ptp;)
{
struct node *nd1, *nd2;
t_node *nd1, *nd2;
}:
/*
This is not exactly the rule in the new report, but see
@ -242,15 +242,15 @@ SubrangeType(struct type **ptp;)
UPTO ConstExpression(&nd2)
']'
{ *ptp = subr_type(nd1, nd2);
free_node(nd1);
free_node(nd2);
FreeNode(nd1);
FreeNode(nd2);
}
;
ArrayType(struct type **ptp;)
ArrayType(t_type **ptp;)
{
struct type *tp;
register struct type *tp2;
t_type *tp;
register t_type *tp2;
} :
ARRAY SimpleType(&tp)
{ *ptp = tp2 = construct_type(T_ARRAY, tp); }
@ -265,7 +265,7 @@ ArrayType(struct type **ptp;)
}
;
RecordType(struct type **ptp;)
RecordType(t_type **ptp;)
{
register struct scope *scope;
arith size = 0;
@ -294,10 +294,10 @@ FieldListSequence(struct scope *scope; arith *cnt; int *palign;):
FieldList(struct scope *scope; arith *cnt; int *palign;)
{
struct node *FldList;
struct type *tp;
struct node *nd;
register struct def *df;
t_node *FldList;
t_type *tp;
t_node *nd;
register t_def *df;
arith tcnt, max;
} :
[
@ -358,9 +358,9 @@ FieldList(struct scope *scope; arith *cnt; int *palign;)
]?
;
variant(struct scope *scope; arith *cnt; struct type *tp; int *palign;)
variant(struct scope *scope; arith *cnt; t_type *tp; int *palign;)
{
struct node *nd;
t_node *nd;
} :
[
CaseLabelList(&tp, &nd)
@ -375,7 +375,7 @@ variant(struct scope *scope; arith *cnt; struct type *tp; int *palign;)
/* Changed rule in new modula-2 */
;
CaseLabelList(struct type **ptp; struct node **pnd;):
CaseLabelList(t_type **ptp; t_node **pnd;):
CaseLabels(ptp, pnd)
[
{ *pnd = dot2node(Link, *pnd, NULLNODE); }
@ -384,9 +384,9 @@ CaseLabelList(struct type **ptp; struct node **pnd;):
]*
;
CaseLabels(struct type **ptp; register struct node **pnd;)
CaseLabels(t_type **ptp; register t_node **pnd;)
{
register struct node *nd;
register t_node *nd;
}:
ConstExpression(pnd)
{
@ -409,7 +409,7 @@ CaseLabels(struct type **ptp; register struct node **pnd;)
}
;
SetType(struct type **ptp;) :
SetType(t_type **ptp;) :
SET OF SimpleType(ptp)
{ *ptp = set_type(*ptp); }
;
@ -418,7 +418,7 @@ SetType(struct type **ptp;) :
have to be declared yet, so be careful about identifying
type-identifiers
*/
PointerType(register struct type **ptp;) :
PointerType(register t_type **ptp;) :
{ *ptp = construct_type(T_POINTER, NULLTYPE); }
POINTER TO
[ %if (type_or_forward(ptp))
@ -428,27 +428,27 @@ PointerType(register struct type **ptp;) :
]
;
qualtype(struct type **ptp;)
qualtype(t_type **ptp;)
{
struct node *nd;
t_node *nd;
} :
qualident(&nd)
{ *ptp = qualified_type(nd); }
;
ProcedureType(struct type **ptp;) :
ProcedureType(t_type **ptp;) :
PROCEDURE
[
FormalTypeList(ptp)
|
{ *ptp = proc_type((struct type *) 0,
{ *ptp = proc_type((t_type *) 0,
(struct paramlist *) 0,
(arith) 0);
}
]
;
FormalTypeList(struct type **ptp;)
FormalTypeList(t_type **ptp;)
{
struct paramlist *pr = 0;
arith parmaddr = 0;
@ -469,7 +469,7 @@ FormalTypeList(struct type **ptp;)
VarFormalType(struct paramlist **ppr; arith *parmaddr;)
{
struct type *tp;
t_type *tp;
int isvar;
} :
var(&isvar)
@ -487,9 +487,9 @@ var(int *VARp;) :
ConstantDeclaration
{
struct idf *id;
struct node *nd;
register struct def *df;
t_idf *id;
t_node *nd;
register t_def *df;
}:
IDENT { id = dot.TOK_IDF; }
'=' ConstExpression(&nd)
@ -502,9 +502,9 @@ ConstantDeclaration
VariableDeclaration
{
struct node *VarList;
register struct node *nd;
struct type *tp;
t_node *VarList;
register t_node *nd;
t_type *tp;
} :
IdentAddr(&VarList)
{ nd = VarList; }
@ -516,9 +516,9 @@ VariableDeclaration
{ EnterVarList(VarList, tp, proclevel > 0); }
;
IdentAddr(struct node **pnd;)
IdentAddr(t_node **pnd;)
{
register struct node *nd;
register t_node *nd;
} :
IDENT { nd = dot2leaf(Name); }
[ '['

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

@ -128,15 +128,15 @@ struct def { /* list of definitions for a name */
} df_value;
};
typedef struct def t_def;
/* ALLOCDEF "def" 50 */
extern struct def
extern t_def
*define(),
*DefineLocalModule(),
*MkDef(),
*DeclProc();
extern struct def
*DeclProc(),
*lookup(),
*lookfor();
#define NULLDEF ((struct def *) 0)
#define NULLDEF ((t_def *) 0)

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

@ -27,14 +27,14 @@
STATIC
DefInFront(df)
register struct def *df;
register t_def *df;
{
/* Put definition "df" in front of the list of definitions
in its scope.
This is neccessary because in some cases the order in this
list is important.
*/
register struct def *df1 = df->df_scope->sc_def;
register t_def *df1 = df->df_scope->sc_def;
if (df1 != df) {
/* Definition "df" is not in front of the list
@ -58,15 +58,15 @@ DefInFront(df)
}
}
struct def *
t_def *
MkDef(id, scope, kind)
register struct idf *id;
register t_idf *id;
register struct scope *scope;
{
/* Create a new definition structure in scope "scope", with
id "id" and kind "kind".
*/
register struct def *df;
register t_def *df;
df = new_def();
df->df_idf = id;
@ -82,9 +82,9 @@ MkDef(id, scope, kind)
return df;
}
struct def *
t_def *
define(id, scope, kind)
register struct idf *id;
register t_idf *id;
register struct scope *scope;
int kind;
{
@ -93,7 +93,7 @@ define(id, scope, kind)
If so, then check for the cases in which this is legal,
and otherwise give an error message.
*/
register struct def *df;
register t_def *df;
df = lookup(id, scope, 1);
if ( /* Already in this scope */
@ -180,13 +180,13 @@ define(id, scope, kind)
}
RemoveImports(pdf)
register struct def **pdf;
register t_def **pdf;
{
/* Remove all imports from a definition module. This is
neccesary because the implementation module might import
them again.
*/
register struct def *df = *pdf;
register t_def *df = *pdf;
while (df) {
if (df->df_kind == D_IMPORT) {
@ -202,12 +202,12 @@ RemoveImports(pdf)
}
RemoveFromIdList(df)
register struct def *df;
register t_def *df;
{
/* Remove definition "df" from the definition list
*/
register struct idf *id = df->df_idf;
register struct def *df1;
register t_idf *id = df->df_idf;
register t_def *df1;
if ((df1 = id->id_def) == df) id->id_def = df->df_next;
else {
@ -219,15 +219,15 @@ RemoveFromIdList(df)
}
}
struct def *
t_def *
DeclProc(type, id)
register struct idf *id;
register t_idf *id;
{
/* A procedure is declared, either in a definition or a program
module. Create a def structure for it (if neccessary).
Also create a name for it.
*/
register struct def *df;
register t_def *df;
register struct scope *scope;
extern char *sprint();
static int nmcount;
@ -286,8 +286,8 @@ DeclProc(type, id)
}
EndProc(df, id)
register struct def *df;
struct idf *id;
register t_def *df;
t_idf *id;
{
/* The end of a procedure declaration.
Check that the closing identifier matches the name of the
@ -304,14 +304,14 @@ EndProc(df, id)
}
}
struct def *
t_def *
DefineLocalModule(id)
struct idf *id;
t_idf *id;
{
/* Create a definition for a local module. Also give it
a name to be used for code generation.
*/
register struct def *df = define(id, CurrentScope, D_MODULE);
register t_def *df = define(id, CurrentScope, D_MODULE);
register struct scope *sc;
static int modulecount = 0;
char buf[256];
@ -352,8 +352,8 @@ DefineLocalModule(id)
}
CheckWithDef(df, tp)
register struct def *df;
struct type *tp;
register t_def *df;
t_type *tp;
{
/* Check the header of a procedure declaration against a
possible earlier definition in the definition module.
@ -374,7 +374,7 @@ CheckWithDef(df, tp)
#ifdef DEBUG
PrDef(df)
register struct def *df;
register t_def *df;
{
print("n: %s, k: %d\n", df->df_idf->id_text, df->df_kind);
}

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

@ -32,7 +32,7 @@
long sys_filesize();
#endif
struct idf *DefId;
t_idf *DefId;
char *
getwdir(fn)
@ -80,16 +80,16 @@ GetFile(name)
return 1;
}
struct def *
t_def *
GetDefinitionModule(id, incr)
register struct idf *id;
register t_idf *id;
{
/* Return a pointer to the "def" structure of the definition
module indicated by "id".
We may have to read the definition module itself.
Also increment level by "incr".
*/
register struct def *df;
register t_def *df;
static int level;
struct scopelist *vis;
char *fn = FileName;
@ -124,9 +124,9 @@ GetDefinitionModule(id, incr)
remember its name because we have
to call its initialization routine
*/
static struct node *nd_end;
register struct node *n;
extern struct node *Modules;
static t_node *nd_end;
register t_node *n;
extern t_node *Modules;
n = dot2leaf(Name);
n->nd_IDF = id;

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

@ -45,6 +45,8 @@ struct desig {
*/
};
typedef struct desig t_desig;
/* ALLOCDEF "desig" 5 */
/* The next structure describes the designator in a with-statement.
@ -56,7 +58,7 @@ struct withdesig {
struct scope *w_scope; /* scope in which fields of this record
reside
*/
struct desig w_desig; /* a desig structure for this particular
t_desig w_desig; /* a desig structure for this particular
designator
*/
};

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

@ -24,6 +24,7 @@
#include <assert.h>
#include <alloc.h>
#include "squeeze.h"
#include "type.h"
#include "LLlex.h"
#include "def.h"
@ -31,65 +32,74 @@
#include "desig.h"
#include "node.h"
#include "warning.h"
#include "walk.h"
extern int proclevel;
int
WordOrDouble(ds, size)
register struct desig *ds;
register t_desig *ds;
arith size;
{
return ((int) (ds->dsg_offset) % (int) word_size == 0 &&
( (int) size == (int) word_size ||
(int) size == (int) dword_size));
if ((int) (ds->dsg_offset) % (int) word_size == 0) {
if (size == word_size) return 1;
if (size == dword_size) return 2;
}
return 0;
}
int
DoLoad(ds, size)
register struct desig *ds;
register t_desig *ds;
arith size;
{
if (! WordOrDouble(ds, size)) return 0;
if (ds->dsg_name) {
if ((int) size == (int) word_size) {
switch (WordOrDouble(ds, size)) {
default:
return 0;
case 1:
if (ds->dsg_name) {
C_loe_dnam(ds->dsg_name, ds->dsg_offset);
}
else C_lde_dnam(ds->dsg_name, ds->dsg_offset);
}
else {
if ((int) size == (int) word_size) {
C_lol(ds->dsg_offset);
else C_lol(ds->dsg_offset);
break;
case 2:
if (ds->dsg_name) {
C_lde_dnam(ds->dsg_name, ds->dsg_offset);
}
else C_ldl(ds->dsg_offset);
break;
}
return 1;
}
int
DoStore(ds, size)
register struct desig *ds;
register t_desig *ds;
arith size;
{
if (! WordOrDouble(ds, size)) return 0;
if (ds->dsg_name) {
if ((int) size == (int) word_size) {
switch (WordOrDouble(ds, size)) {
default:
return 0;
case 1:
if (ds->dsg_name) {
C_ste_dnam(ds->dsg_name, ds->dsg_offset);
}
else C_sde_dnam(ds->dsg_name, ds->dsg_offset);
}
else {
if ((int) size == (int) word_size) {
C_stl(ds->dsg_offset);
else C_stl(ds->dsg_offset);
break;
case 2:
if (ds->dsg_name) {
C_sde_dnam(ds->dsg_name, ds->dsg_offset);
}
else C_sdl(ds->dsg_offset);
break;
}
return 1;
}
STATIC int
properly(ds, tp)
register struct desig *ds;
register struct type *tp;
register t_desig *ds;
register t_type *tp;
{
/* Check if it is allowed to load or store the value indicated
by "ds" with LOI/STI.
@ -115,8 +125,8 @@ properly(ds, tp)
}
CodeValue(ds, tp)
register struct desig *ds;
register struct type *tp;
register t_desig *ds;
register t_type *tp;
{
/* Generate code to load the value of the designator described
in "ds"
@ -167,10 +177,10 @@ CodeValue(ds, tp)
}
ChkForFOR(nd)
struct node *nd;
t_node *nd;
{
if (nd->nd_class == Def) {
register struct def *df = nd->nd_def;
register t_def *df = nd->nd_def;
if (df->df_flags & D_FORLOOP) {
node_warning(nd,
@ -182,13 +192,13 @@ ChkForFOR(nd)
}
CodeStore(ds, tp)
register struct desig *ds;
register struct type *tp;
register t_desig *ds;
register t_type *tp;
{
/* Generate code to store the value on the stack in the designator
described in "ds"
*/
struct desig save;
t_desig save;
save = *ds;
@ -220,10 +230,10 @@ CodeStore(ds, tp)
}
CodeCopy(lhs, rhs, sz, psize)
register struct desig *lhs, *rhs;
register t_desig *lhs, *rhs;
arith sz, *psize;
{
struct desig l, r;
t_desig l, r;
l = *lhs; r = *rhs;
*psize -= sz;
@ -236,12 +246,12 @@ CodeCopy(lhs, rhs, sz, psize)
}
CodeMove(rhs, left, rtp)
register struct desig *rhs;
register struct node *left;
struct type *rtp;
register t_desig *rhs;
register t_node *left;
t_type *rtp;
{
register struct desig *lhs = new_desig();
register struct type *tp = left->nd_type;
register t_desig *lhs = new_desig();
register t_type *tp = left->nd_type;
int loadedflag = 0;
/* Generate code for an assignment. Testing of type
@ -297,7 +307,7 @@ CodeMove(rhs, left, rtp)
if (size > 3*dword_size) {
/* Do a block move
*/
struct desig l, r;
t_desig l, r;
arith sz;
sz = (size / word_size) * word_size;
@ -365,7 +375,7 @@ CodeMove(rhs, left, rtp)
}
CodeAddress(ds)
register struct desig *ds;
register t_desig *ds;
{
/* Generate code to load the address of the designator described
in "ds"
@ -404,8 +414,8 @@ CodeAddress(ds)
}
CodeFieldDesig(df, ds)
register struct def *df;
register struct desig *ds;
register t_def *df;
register t_desig *ds;
{
/* Generate code for a field designator. Only the code common for
address as well as value computation is generated, and the
@ -455,8 +465,8 @@ CodeFieldDesig(df, ds)
}
CodeVarDesig(df, ds)
register struct def *df;
register struct desig *ds;
register t_def *df;
register t_desig *ds;
{
/* Generate code for a variable represented by a "def" structure.
Of course, there are numerous cases: the variable is local,
@ -532,13 +542,13 @@ CodeVarDesig(df, ds)
}
CodeDesig(nd, ds)
register struct node *nd;
register struct desig *ds;
register t_node *nd;
register t_desig *ds;
{
/* Generate code for a designator. Use divide and conquer
principle
*/
register struct def *df;
register t_def *df;
switch(nd->nd_class) { /* Divide */
case Def:
@ -579,7 +589,7 @@ CodeDesig(nd, ds)
else C_lal(df->var_off + pointer_size);
}
else {
C_lae_dlb(nd->nd_left->nd_type->arr_descr, (arith) 0);
c_lae_dlb(nd->nd_left->nd_type->arr_descr);
}
ds->dsg_kind = DSG_INDEXED;
break;

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

@ -27,16 +27,16 @@
#include "misc.h"
#include "f_info.h"
struct def *
t_def *
Enter(name, kind, type, pnam)
char *name;
struct type *type;
t_type *type;
{
/* Enter a definition for "name" with kind "kind" and type
"type" in the Current Scope. If it is a standard name, also
put its number in the definition structure.
*/
register struct def *df;
register t_def *df;
df = define(str2idf(name, 0), CurrentScope, kind);
df->df_type = type;
@ -46,7 +46,7 @@ Enter(name, kind, type, pnam)
EnterType(name, type)
char *name;
struct type *type;
t_type *type;
{
/* Enter a type definition for "name" and type
"type" in the Current Scope.
@ -56,8 +56,8 @@ EnterType(name, type)
}
EnterEnumList(Idlist, type)
struct node *Idlist;
register struct type *type;
t_node *Idlist;
register t_type *type;
{
/* Put a list of enumeration literals in the symbol table.
They all have type "type".
@ -66,8 +66,8 @@ EnterEnumList(Idlist, type)
be exported, in which case its literals must also be exported.
Thus, we need an easy way to get to them.
*/
register struct def *df;
register struct node *idlist = Idlist;
register t_def *df;
register t_node *idlist = Idlist;
type->enm_ncst = 0;
for (; idlist; idlist = idlist->nd_left) {
@ -81,8 +81,8 @@ EnterEnumList(Idlist, type)
}
EnterFieldList(Idlist, type, scope, addr)
struct node *Idlist;
register struct type *type;
t_node *Idlist;
register t_type *type;
struct scope *scope;
arith *addr;
{
@ -91,8 +91,8 @@ EnterFieldList(Idlist, type, scope, addr)
Mark them as QUALIFIED EXPORT, because that's exactly what
fields are, you can get to them by qualifying them.
*/
register struct def *df;
register struct node *idlist = Idlist;
register t_def *df;
register t_node *idlist = Idlist;
for (; idlist; idlist = idlist->nd_left) {
df = define(idlist->nd_IDF, scope, D_FIELD);
@ -105,16 +105,16 @@ EnterFieldList(Idlist, type, scope, addr)
}
EnterVarList(Idlist, type, local)
struct node *Idlist;
struct type *type;
t_node *Idlist;
t_type *type;
{
/* Enter a list of identifiers representing variables into the
name list. "type" represents the type of the variables.
"local" is set if the variables are declared local to a
procedure.
*/
register struct def *df;
register struct node *idlist = Idlist;
register t_def *df;
register t_node *idlist = Idlist;
register struct scopelist *sc = CurrVis;
char buf[256];
extern char *sprint();
@ -132,7 +132,7 @@ EnterVarList(Idlist, type, local)
if (idlist->nd_left) {
/* An address was supplied
*/
register struct type *tp = idlist->nd_left->nd_type;
register t_type *tp = idlist->nd_left->nd_type;
df->df_flags |= D_ADDRGIVEN | D_NOREG;
if (tp != error_type && !(tp->tp_fund & T_CARDINAL)){
@ -180,8 +180,8 @@ EnterVarList(Idlist, type, local)
EnterParamList(ppr, Idlist, type, VARp, off)
struct paramlist **ppr;
struct node *Idlist;
struct type *type;
t_node *Idlist;
t_type *type;
int VARp;
arith *off;
{
@ -190,9 +190,9 @@ EnterParamList(ppr, Idlist, type, VARp, off)
"VARp" indicates D_VARPAR or D_VALPAR.
*/
register struct paramlist *pr;
register struct def *df;
register struct node *idlist = Idlist;
struct node *dummy = 0;
register t_def *df;
register t_node *idlist = Idlist;
t_node *dummy = 0;
static struct paramlist *last;
if (! idlist) {
@ -231,7 +231,7 @@ EnterParamList(ppr, Idlist, type, VARp, off)
STATIC
DoImport(df, scope)
register struct def *df;
register t_def *df;
struct scope *scope;
{
/* Definition "df" is imported to scope "scope".
@ -268,8 +268,8 @@ DoImport(df, scope)
STATIC struct scopelist *
ForwModule(df, nd)
register struct def *df;
struct node *nd;
register t_def *df;
t_node *nd;
{
/* An import is done from a not yet defined module "df".
We could also end up here for not found DEFINITION MODULES.
@ -295,15 +295,15 @@ ForwModule(df, nd)
return vis;
}
STATIC struct def *
STATIC t_def *
ForwDef(ids, scope)
register struct node *ids;
register t_node *ids;
struct scope *scope;
{
/* Enter a forward definition of "ids" in scope "scope",
if it is not already defined.
*/
register struct def *df;
register t_def *df;
if (!(df = lookup(ids->nd_IDF, scope, 1))) {
df = define(ids->nd_IDF, scope, D_FORWARD);
@ -313,15 +313,15 @@ ForwDef(ids, scope)
}
EnterExportList(Idlist, qualified)
struct node *Idlist;
t_node *Idlist;
{
/* From the current scope, the list of identifiers "ids" is
exported. Note this fact. If the export is not qualified, make
all the "ids" visible in the enclosing scope by defining them
in this scope as "imported".
*/
register struct node *idlist = Idlist;
register struct def *df, *df1;
register t_node *idlist = Idlist;
register t_def *df, *df1;
for (;idlist; idlist = idlist->nd_left) {
df = lookup(idlist->nd_IDF, CurrentScope, 0);
@ -389,15 +389,15 @@ EnterExportList(Idlist, qualified)
}
EnterFromImportList(Idlist, FromDef, FromId)
struct node *Idlist;
register struct def *FromDef;
struct node *FromId;
t_node *Idlist;
register t_def *FromDef;
t_node *FromId;
{
/* Import the list Idlist from the module indicated by Fromdef.
*/
register struct node *idlist = Idlist;
register t_node *idlist = Idlist;
register struct scopelist *vis;
register struct def *df;
register t_def *df;
char *module_name = FromDef->df_idf->id_text;
int forwflag = 0;
@ -454,16 +454,16 @@ node_error(FromId,"identifier \"%s\" does not represent a module",module_name);
}
EnterImportList(Idlist, local)
struct node *Idlist;
t_node *Idlist;
{
/* Import "Idlist" from the enclosing scope.
An exception must be made for imports of the compilation unit.
In this case, definition modules must be read for "Idlist".
This case is indicated by the value 0 of the "local" flag.
*/
register struct node *idlist = Idlist;
register t_node *idlist = Idlist;
struct scope *sc = enclosing(CurrVis)->sc_scope;
extern struct def *GetDefinitionModule();
extern t_def *GetDefinitionModule();
struct f_info f;
f = file_info;

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

@ -73,7 +73,7 @@ error(fmt, args)
/*VARARGS2*/
node_error(node, fmt, args)
struct node *node;
t_node *node;
char *fmt;
{
_error(ERROR, node, fmt, &args);
@ -89,7 +89,7 @@ warning(class, fmt, args)
/*VARARGS2*/
node_warning(node, class, fmt, args)
struct node *node;
t_node *node;
char *fmt;
{
warn_class = class;
@ -137,7 +137,7 @@ crash(fmt, args)
_error(class, node, fmt, argv)
int class;
struct node *node;
t_node *node;
char *fmt;
int argv[];
{

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

@ -30,7 +30,7 @@ extern char options[];
}
/* inline, we need room for pdp/11
number(struct node **p;) :
number(t_node **p;) :
[
%default
INTEGER
@ -42,7 +42,7 @@ number(struct node **p;) :
;
*/
qualident(struct node **p;)
qualident(t_node **p;)
{
} :
IDENT { *p = dot2leaf(Name); }
@ -51,14 +51,14 @@ qualident(struct node **p;)
]*
;
selector(struct node **pnd;):
selector(t_node **pnd;):
'.' { *pnd = dot2node(Link,*pnd,NULLNODE); }
IDENT { (*pnd)->nd_IDF = dot.TOK_IDF; }
;
ExpList(struct node **pnd;)
ExpList(t_node **pnd;)
{
register struct node *nd;
register t_node *nd;
} :
expression(pnd) { *pnd = nd = dot2node(Link,*pnd,NULLNODE);
nd->nd_symb = ',';
@ -71,9 +71,9 @@ ExpList(struct node **pnd;)
]*
;
ConstExpression(struct node **pnd;)
ConstExpression(t_node **pnd;)
{
register struct node *nd;
register t_node *nd;
}:
expression(pnd)
/*
@ -94,7 +94,7 @@ ConstExpression(struct node **pnd;)
}
;
expression(struct node **pnd;)
expression(t_node **pnd;)
{
} :
SimpleExpression(pnd)
@ -112,9 +112,9 @@ relation:
;
*/
SimpleExpression(struct node **pnd;)
SimpleExpression(t_node **pnd;)
{
register struct node *nd = 0;
register t_node *nd = 0;
} :
[
[ '+' | '-' ]
@ -144,9 +144,9 @@ AddOperator:
;
*/
term(struct node **pnd;)
term(t_node **pnd;)
{
register struct node *nd;
register t_node *nd;
}:
factor(pnd) { nd = *pnd; }
[
@ -164,9 +164,9 @@ MulOperator:
;
*/
factor(register struct node **p;)
factor(register t_node **p;)
{
struct node *nd;
t_node *nd;
} :
qualident(p)
[
@ -208,7 +208,7 @@ factor(register struct node **p;)
nd->nd_right = *p;
*p = nd;
}
else free_node(nd);
else FreeNode(nd);
}
')'
|
@ -216,9 +216,9 @@ factor(register struct node **p;)
factor(&((*p)->nd_right))
;
bare_set(struct node **pnd;)
bare_set(t_node **pnd;)
{
register struct node *nd;
register t_node *nd;
} :
'{' { dot.tk_symb = SET;
*pnd = nd = dot2leaf(Xset);
@ -233,13 +233,13 @@ bare_set(struct node **pnd;)
'}'
;
ActualParameters(struct node **pnd;):
ActualParameters(t_node **pnd;):
'(' ExpList(pnd)? ')'
;
element(register struct node *nd;)
element(register t_node *nd;)
{
struct node *nd1;
t_node *nd1;
} :
expression(&nd1)
[
@ -252,13 +252,13 @@ element(register struct node *nd;)
}
;
designator(struct node **pnd;)
designator(t_node **pnd;)
:
qualident(pnd)
designator_tail(pnd)?
;
designator_tail(struct node **pnd;):
designator_tail(t_node **pnd;):
visible_designator_tail(pnd)
[ %persistent
%default
@ -268,9 +268,9 @@ designator_tail(struct node **pnd;):
]*
;
visible_designator_tail(struct node **pnd;)
visible_designator_tail(t_node **pnd;)
{
register struct node *nd = *pnd;
register t_node *nd = *pnd;
}:
[
'[' { nd = dot2node(Arrsel, nd, NULLNODE); }

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

@ -19,3 +19,5 @@ struct id_u {
#define id_def id_user.id_df
#include <idf_pkg.spec>
typedef struct idf t_idf;

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

@ -23,9 +23,9 @@
#include "type.h"
#include "misc.h"
struct def *
t_def *
lookup(id, scope, import)
register struct idf *id;
register t_idf *id;
struct scope *scope;
{
/* Look up a definition of an identifier in scope "scope".
@ -33,7 +33,7 @@ lookup(id, scope, import)
Return a pointer to its "def" structure if it exists,
otherwise return 0.
*/
register struct def *df, *df1;
register t_def *df, *df1;
/* Look in the chain of definitions of this "id" for one with scope
"scope".
@ -62,16 +62,16 @@ lookup(id, scope, import)
return df;
}
struct def *
t_def *
lookfor(id, vis, give_error)
register struct node *id;
register t_node *id;
struct scopelist *vis;
{
/* Look for an identifier in the visibility range started by "vis".
If it is not defined create a dummy definition and,
if "give_error" is set, give an error message.
*/
register struct def *df;
register t_def *df;
register struct scopelist *sc = vis;
while (sc) {

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

@ -37,11 +37,12 @@ char *ProgName;
char **DEFPATH;
int nDEF, mDEF;
int pass_1;
struct def *Defined;
t_def *Defined;
extern int err_occurred;
extern int Roption;
extern int fp_used; /* set if floating point used */
struct node *EmptyStatement;
static t_node _emptystat = { NULLNODE, NULLNODE, Stat, NULLTYPE, { ';' }};
t_node *EmptyStatement = &_emptystat;
main(argc, argv)
register char **argv;
@ -88,8 +89,6 @@ Compile(src, dst)
InitScope();
InitTypes();
AddStandards();
EmptyStatement = dot2leaf(Stat);
EmptyStatement->nd_symb = ';';
Roption = options['R'];
#ifdef DEBUG
if (options['l']) {
@ -124,7 +123,7 @@ Compile(src, dst)
#ifdef DEBUG
LexScan()
{
register struct token *tkp = &dot;
register t_token *tkp = &dot;
extern char *symbol2str();
while (LLlex() > 0) {
@ -184,13 +183,13 @@ static struct stdproc {
{ 0, 0 }
};
extern struct def *Enter();
extern t_def *Enter();
AddStandards()
{
register struct def *df;
register t_def *df;
register struct stdproc *p;
static struct token nilconst = { INTEGER, 0};
static t_token nilconst = { INTEGER, 0};
for (p = stdproc; p->st_nam != 0; p++) {
Enter(p->st_nam, D_PROCEDURE, std_type, p->st_con);

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

@ -20,7 +20,7 @@
#include "node.h"
match_id(id1, id2)
register struct idf *id1, *id2;
register t_idf *id1, *id2;
{
/* Check that identifiers id1 and id2 are equal. If they
are not, check that we did'nt generate them in the
@ -34,14 +34,14 @@ match_id(id1, id2)
}
}
struct idf *
t_idf *
gen_anon_idf()
{
/* A new idf is created out of nowhere, to serve as an
anonymous name.
*/
static int name_cnt;
char buff[100];
char buff[512];
char *sprint();
sprint(buff, "#%d in %s, line %u",
@ -51,7 +51,7 @@ gen_anon_idf()
not_declared(what, id, where)
char *what, *where;
register struct node *id;
register t_node *id;
{
/* The identifier "id" is not declared. If it is not generated,
give an error message

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

@ -41,11 +41,13 @@ struct node {
#define nd_REL nd_token.TOK_REL
};
typedef struct node t_node;
/* ALLOCDEF "node" 50 */
extern struct node *MkNode(), *MkLeaf(), *dot2node(), *dot2leaf();
extern t_node *MkNode(), *MkLeaf(), *dot2node(), *dot2leaf();
#define NULLNODE ((struct node *) 0)
#define NULLNODE ((t_node *) 0)
#define HASSELECTORS 002
#define VARIABLE 004

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

@ -21,14 +21,14 @@
#include "type.h"
#include "node.h"
struct node *
t_node *
MkNode(class, left, right, token)
struct node *left, *right;
struct token *token;
t_node *left, *right;
t_token *token;
{
/* Create a node and initialize it with the given parameters
*/
register struct node *nd = new_node();
register t_node *nd = new_node();
nd->nd_left = left;
nd->nd_right = right;
@ -37,32 +37,32 @@ MkNode(class, left, right, token)
return nd;
}
struct node *
t_node *
dot2node(class, left, right)
struct node *left, *right;
t_node *left, *right;
{
return MkNode(class, left, right, &dot);
}
struct node *
t_node *
MkLeaf(class, token)
struct token *token;
t_token *token;
{
register struct node *nd = new_node();
register t_node *nd = new_node();
nd->nd_token = *token;
nd->nd_class = class;
return nd;
}
struct node *
t_node *
dot2leaf(class)
{
return MkLeaf(class, &dot);
}
FreeNode(nd)
register struct node *nd;
register t_node *nd;
{
/* Put nodes that are no longer needed back onto the free
list
@ -74,7 +74,7 @@ FreeNode(nd)
}
NodeCrash(expp)
struct node *expp;
t_node *expp;
{
crash("Illegal node %d", expp->nd_class);
}
@ -91,7 +91,7 @@ indnt(lvl)
}
printnode(nd, lvl)
register struct node *nd;
register t_node *nd;
{
indnt(lvl);
print("Class: %d; Symbol: %s\n", nd->nd_class, symbol2str(nd->nd_symb));
@ -104,7 +104,7 @@ printnode(nd, lvl)
}
PrNode(nd, lvl)
register struct node *nd;
register t_node *nd;
{
if (! nd) {
indnt(lvl); print("<nilnode>\n");

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

@ -48,8 +48,8 @@
ModuleDeclaration
{
register struct def *df;
struct node *exportlist = 0;
register t_def *df;
t_node *exportlist = 0;
int qualified;
} :
MODULE IDENT { df = DefineLocalModule(dot.TOK_IDF); }
@ -66,7 +66,7 @@ ModuleDeclaration
}
;
priority(register struct def *df;):
priority(register t_def *df;):
[
'[' ConstExpression(&(df->mod_priority)) ']'
{ if (!(df->mod_priority->nd_type->tp_fund &
@ -80,7 +80,7 @@ priority(register struct def *df;):
]
;
export(int *QUALflag; struct node **ExportList;):
export(int *QUALflag; t_node **ExportList;):
EXPORT
[
QUALIFIED
@ -93,10 +93,10 @@ export(int *QUALflag; struct node **ExportList;):
import(int local;)
{
struct node *ImportList;
register struct node *FromId = 0;
register struct def *df;
extern struct def *GetDefinitionModule();
t_node *ImportList;
register t_node *FromId = 0;
register t_def *df;
extern t_def *GetDefinitionModule();
} :
[ FROM
IDENT { FromId = dot2leaf(Name);
@ -120,10 +120,10 @@ import(int local;)
DefinitionModule
{
register struct def *df;
struct node *exportlist;
register t_def *df;
t_node *exportlist;
int dummy;
extern struct idf *DefId;
extern t_idf *DefId;
extern int ForeignFlag;
} :
DEFINITION
@ -157,7 +157,7 @@ node_warning(exportlist, W_OLDFASHIONED, "export list in definition module ignor
/* empty */
]
definition* END IDENT
{ register struct def *df1 = CurrentScope->sc_def;
{ register t_def *df1 = CurrentScope->sc_def;
while (df1) {
/* Make all definitions "QUALIFIED EXPORT" */
df1->df_flags |= D_QEXPORTED;
@ -172,8 +172,8 @@ node_warning(exportlist, W_OLDFASHIONED, "export list in definition module ignor
definition
{
register struct def *df;
struct def *dummy;
register t_def *df;
t_def *dummy;
} :
CONST [ %persistent ConstantDeclaration ';' ]*
|
@ -202,8 +202,8 @@ definition
ProgramModule
{
extern struct def *GetDefinitionModule();
register struct def *df;
extern t_def *GetDefinitionModule();
register t_def *df;
} :
MODULE
IDENT { if (state == IMPLEMENTATION) {

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

@ -82,7 +82,7 @@ InitScope()
STATIC
chk_proc(df)
register struct def *df;
register t_def *df;
{
/* Called at scope closing. Check all definitions, and if one
is a D_PROCHEAD, the procedure was not defined.
@ -106,18 +106,18 @@ chk_proc(df)
STATIC
chk_forw(pdf)
struct def **pdf;
t_def **pdf;
{
/* Called at scope close. Look for all forward definitions and
if the scope was a closed scope, give an error message for
them, and otherwise move them to the enclosing scope.
*/
register struct def *df;
register t_def *df;
while (df = *pdf) {
if (df->df_kind == D_FORWTYPE) {
register struct def *df1 = df;
register struct node *nd = df->df_forw_node;
register t_def *df1 = df;
register t_node *nd = df->df_forw_node;
*pdf = df->df_nextinscope;
RemoveFromIdList(df);
@ -134,7 +134,7 @@ node_error(nd, "\"%s\" is not a type", df1->df_idf->id_text);
continue;
}
else if (df->df_kind == D_FTYPE) {
register struct node *nd = df->df_forw_node;
register t_node *nd = df->df_forw_node;
df->df_kind = D_TYPE;
while (nd) {
@ -163,7 +163,7 @@ df->df_idf->id_text);
*/
register struct scopelist *ls =
nextvisible(CurrVis);
struct def *df1 = df->df_nextinscope;
t_def *df1 = df->df_nextinscope;
if (df->df_kind == D_FORWMODULE) {
df->for_vis->sc_next = ls;
@ -180,14 +180,14 @@ df->df_idf->id_text);
}
Reverse(pdf)
struct def **pdf;
t_def **pdf;
{
/* Reverse the order in the list of definitions in a scope.
This is neccesary because this list is built in reverse.
Also, while we're at it, remove uninteresting definitions
from this list.
*/
register struct def *df, *df1;
register t_def *df, *df1;
#define INTERESTING D_MODULE|D_PROCEDURE|D_PROCHEAD|D_VARIABLE
df = 0;
@ -195,7 +195,7 @@ Reverse(pdf)
while (df1) {
if (df1->df_kind & INTERESTING) {
struct def *prev = df;
t_def *prev = df;
df = df1;
df1 = df1->df_nextinscope;
@ -228,7 +228,7 @@ close_scope(flag)
#ifdef DEBUG
DumpScope(df)
register struct def *df;
register t_def *df;
{
while (df) {
PrDef(df);

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

@ -24,12 +24,12 @@
static int loopcount = 0; /* Count nested loops */
int Roption;
extern char options[];
extern struct node *EmptyStatement;
extern t_node *EmptyStatement;
}
statement(register struct node **pnd;)
statement(register t_node **pnd;)
{
register struct node *nd;
register t_node *nd;
extern int return_occurred;
} :
/* We need some method for making sure lookahead is done, so ...
@ -56,7 +56,7 @@ statement(register struct node **pnd;)
* but this gives LL(1) conflicts
*/
designator(pnd)
[ { nd = dot2node(Call, *pnd, NULLNODE);
[ { nd = dot2node(Stat, *pnd, NULLNODE);
nd->nd_symb = '(';
}
ActualParameters(&(nd->nd_right))?
@ -123,10 +123,10 @@ ProcedureCall:
;
*/
StatementSequence(register struct node **pnd;)
StatementSequence(register t_node **pnd;)
{
struct node *nd;
register struct node *nd1;
t_node *nd;
register t_node *nd1;
} :
statement(pnd)
[ %persistent
@ -140,9 +140,9 @@ StatementSequence(register struct node **pnd;)
]*
;
IfStatement(struct node **pnd;)
IfStatement(t_node **pnd;)
{
register struct node *nd;
register t_node *nd;
} :
IF { nd = dot2leaf(Stat);
*pnd = nd;
@ -170,10 +170,10 @@ IfStatement(struct node **pnd;)
END
;
CaseStatement(struct node **pnd;)
CaseStatement(t_node **pnd;)
{
register struct node *nd;
struct type *tp = 0;
register t_node *nd;
t_type *tp = 0;
} :
CASE { *pnd = nd = dot2leaf(Stat); }
expression(&(nd->nd_left))
@ -190,7 +190,7 @@ CaseStatement(struct node **pnd;)
END
;
case(struct node **pnd; struct type **ptp;) :
case(t_node **pnd; t_type **ptp;) :
[ CaseLabelList(ptp, pnd)
':' { *pnd = dot2node(Link, *pnd, NULLNODE); }
StatementSequence(&((*pnd)->nd_right))
@ -201,9 +201,9 @@ case(struct node **pnd; struct type **ptp;) :
;
/* inline in statement; lack of space
WhileStatement(struct node **pnd;)
WhileStatement(t_node **pnd;)
{
register struct node *nd;
register t_node *nd;
}:
WHILE { *pnd = nd = dot2leaf(Stat); }
expression(&(nd->nd_left))
@ -212,9 +212,9 @@ WhileStatement(struct node **pnd;)
END
;
RepeatStatement(struct node **pnd;)
RepeatStatement(t_node **pnd;)
{
register struct node *nd;
register t_node *nd;
}:
REPEAT { *pnd = nd = dot2leaf(Stat); }
StatementSequence(&(nd->nd_left))
@ -223,10 +223,10 @@ RepeatStatement(struct node **pnd;)
;
*/
ForStatement(struct node **pnd;)
ForStatement(t_node **pnd;)
{
register struct node *nd, *nd1;
struct node *dummy;
register t_node *nd, *nd1;
t_node *dummy;
}:
FOR { *pnd = nd = dot2leaf(Stat); }
IDENT { nd->nd_IDF = dot.TOK_IDF; }
@ -252,16 +252,16 @@ ForStatement(struct node **pnd;)
;
/* inline in Statement; lack of space
LoopStatement(struct node **pnd;):
LoopStatement(t_node **pnd;):
LOOP { *pnd = dot2leaf(Stat); }
StatementSequence(&((*pnd)->nd_right))
END
;
*/
WithStatement(struct node **pnd;)
WithStatement(t_node **pnd;)
{
register struct node *nd;
register t_node *nd;
}:
WITH { *pnd = nd = dot2leaf(Stat); }
designator(&(nd->nd_left))
@ -270,10 +270,10 @@ WithStatement(struct node **pnd;)
END
;
ReturnStatement(struct node **pnd;)
ReturnStatement(t_node **pnd;)
{
register struct def *df = CurrentScope->sc_definedby;
register struct node *nd;
register t_def *df = CurrentScope->sc_definedby;
register t_node *nd;
} :
RETURN { *pnd = nd = dot2leaf(Stat); }

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

@ -102,7 +102,7 @@ reserve(resv)
/* The names of the tokens described in resv are entered
as reserved words.
*/
register struct idf *p;
register t_idf *p;
while (resv->tn_symbol) {
p = str2idf(resv->tn_name, 0);

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

@ -99,9 +99,11 @@ struct type {
} tp_value;
};
typedef struct type t_type;
/* ALLOCDEF "type" 50 */
extern struct type
extern t_type
*bool_type,
*char_type,
*int_type,
@ -140,7 +142,7 @@ extern arith
extern arith
align(); /* type.c */
struct type
extern t_type
*construct_type(),
*standard_type(),
*set_type(),
@ -150,7 +152,7 @@ struct type
*qualified_type(),
*RemoveEqual(); /* All from type.c */
#define NULLTYPE ((struct type *) 0)
#define NULLTYPE ((t_type *) 0)
#define IsConformantArray(tpx) ((tpx)->tp_fund==T_ARRAY && (tpx)->tp_size==0)
#define bounded(tpx) ((tpx)->tp_fund & T_INDEX)

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

@ -19,6 +19,7 @@
#include <em_label.h>
#include <em_code.h>
#include "squeeze.h"
#include "LLlex.h"
#include "def.h"
#include "type.h"
@ -52,7 +53,7 @@ arith
double_size = SZ_DOUBLE,
pointer_size = SZ_POINTER;
struct type
t_type
*bool_type,
*char_type,
*int_type,
@ -68,15 +69,15 @@ struct type
*std_type,
*error_type;
struct type *
t_type *
construct_type(fund, tp)
int fund;
register struct type *tp;
register t_type *tp;
{
/* fund must be a type constructor.
The pointer to the constructed type is returned.
*/
register struct type *dtp = new_type();
register t_type *dtp = new_type();
switch (dtp->tp_fund = fund) {
case T_PROCEDURE:
@ -121,13 +122,13 @@ align(pos, al)
return pos;
}
struct type *
t_type *
standard_type(fund, align, size)
int fund;
int align;
arith size;
{
register struct type *tp = new_type();
register t_type *tp = new_type();
tp->tp_fund = fund;
tp->tp_align = align;
@ -143,7 +144,7 @@ InitTypes()
{
/* Initialize the predefined types
*/
register struct type *tp;
register t_type *tp;
/* first, do some checking
*/
@ -215,7 +216,7 @@ InitTypes()
STATIC
u_small(tp, n)
register struct type *tp;
register t_type *tp;
arith n;
{
if (ufit(n, 1)) {
@ -228,11 +229,11 @@ u_small(tp, n)
}
}
struct type *
t_type *
enum_type(EnumList)
struct node *EnumList;
t_node *EnumList;
{
register struct type *tp =
register t_type *tp =
standard_type(T_ENUMERATION, int_align, int_size);
EnterEnumList(EnumList, tp);
@ -243,11 +244,11 @@ enum_type(EnumList)
return tp;
}
struct type *
t_type *
qualified_type(nd)
register struct node *nd;
register t_node *nd;
{
register struct def *df;
register t_def *df;
if (ChkDesignator(nd)) {
if (nd->nd_class != Def) {
@ -276,7 +277,7 @@ node_error(nd,"identifier \"%s\" is not a type", df->df_idf->id_text);
}
chk_basesubrange(tp, base)
register struct type *tp, *base;
register t_type *tp, *base;
{
/* A subrange had a specified base. Check that the bases conform.
*/
@ -330,17 +331,17 @@ chk_bounds(l1, l2, fund)
);
}
struct type *
t_type *
subr_type(lb, ub)
register struct node *lb;
struct node *ub;
register t_node *lb;
t_node *ub;
{
/* Construct a subrange type from the constant expressions
indicated by "lb" and "ub", but first perform some
checks
*/
register struct type *tp = BaseType(lb->nd_type);
register struct type *res;
register t_type *tp = BaseType(lb->nd_type);
register t_type *res;
if (tp == intorcard_type) {
/* Lower bound >= 0; in this case, the base type is CARDINAL,
@ -389,13 +390,13 @@ subr_type(lb, ub)
return res;
}
struct type *
t_type *
proc_type(result_type, parameters, n_bytes_params)
struct type *result_type;
t_type *result_type;
struct paramlist *parameters;
arith n_bytes_params;
{
register struct type *tp = construct_type(T_PROCEDURE, result_type);
register t_type *tp = construct_type(T_PROCEDURE, result_type);
tp->prc_params = parameters;
tp->prc_nbpar = n_bytes_params;
@ -403,7 +404,7 @@ proc_type(result_type, parameters, n_bytes_params)
}
genrck(tp)
register struct type *tp;
register t_type *tp;
{
/* generate a range check descriptor for type "tp" when
neccessary. Return its label.
@ -426,12 +427,12 @@ genrck(tp)
C_rom_cst(lb);
C_rom_cst(ub);
}
C_lae_dlb(ol, (arith) 0);
c_lae_dlb(ol);
C_rck(word_size);
}
getbounds(tp, plo, phi)
register struct type *tp;
register t_type *tp;
arith *plo, *phi;
{
/* Get the bounds of a bounded type
@ -449,9 +450,9 @@ getbounds(tp, plo, phi)
}
}
struct type *
t_type *
set_type(tp)
register struct type *tp;
register t_type *tp;
{
/* Construct a set type with base type "tp", but first
perform some checks
@ -477,7 +478,7 @@ set_type(tp)
arith
ArrayElSize(tp)
register struct type *tp;
register t_type *tp;
{
/* Align element size to alignment requirement of element type.
Also make sure that its size is either a dividor of the word_size,
@ -497,12 +498,12 @@ ArrayElSize(tp)
}
ArraySizes(tp)
register struct type *tp;
register t_type *tp;
{
/* Assign sizes to an array type, and check index type
*/
register struct type *index_type = IndexType(tp);
register struct type *elem_type = tp->arr_elem;
register t_type *index_type = IndexType(tp);
register t_type *elem_type = tp->arr_elem;
arith lo, hi, diff;
tp->arr_elsize = ArrayElSize(elem_type);
@ -531,7 +532,7 @@ ArraySizes(tp)
}
FreeType(tp)
register struct type *tp;
register t_type *tp;
{
/* Release type structures indicated by "tp".
This procedure is only called for types, constructed with
@ -553,9 +554,9 @@ FreeType(tp)
}
DeclareType(nd, df, tp)
register struct def *df;
register struct type *tp;
struct node *nd;
register t_def *df;
register t_type *tp;
t_node *nd;
{
/* A type with type-description "tp" is declared and must
be bound to definition "df".
@ -563,7 +564,7 @@ DeclareType(nd, df, tp)
"df" is already bound. In that case, it is either an opaque
type, or an error message was given when "df" was created.
*/
register struct type *df_tp = df->df_type;
register t_type *df_tp = df->df_type;
if (df_tp && df_tp->tp_fund == T_HIDDEN) {
if (! (tp->tp_fund & (T_POINTER|T_HIDDEN|T_EQUAL))) {
@ -586,9 +587,9 @@ DeclareType(nd, df, tp)
else df->df_type = tp;
}
struct type *
t_type *
RemoveEqual(tpx)
register struct type *tpx;
register t_type *tpx;
{
if (tpx) while (tpx->tp_fund == T_EQUAL) tpx = tpx->tp_next;
@ -597,29 +598,26 @@ RemoveEqual(tpx)
int
type_or_forward(ptp)
struct type **ptp;
t_type **ptp;
{
/* POINTER TO IDENTIFIER construction. The IDENTIFIER resides
in "dot". This routine handles the different cases.
*/
register struct node *nd;
register struct def *df, *df1;
register t_node *nd;
register t_def *df, *df1;
if ((df1 = lookup(dot.TOK_IDF, CurrentScope, 1))) {
/* Either a Module or a Type, but in both cases defined
in this scope, so this is the correct identification
*/
if (df1->df_kind == D_FORWTYPE) {
nd = new_node();
nd->nd_token = dot;
nd->nd_right = df1->df_forw_node;
nd = dot2node(NULLNODE, df1->df_forw_node, 0);
df1->df_forw_node = nd;
nd->nd_type = *ptp;
}
return 1;
}
nd = new_node();
nd->nd_token = dot;
nd = dot2leaf(0);
if ((df1 = lookfor(nd, CurrVis, 0))->df_kind == D_MODULE) {
/* A Modulename in one of the enclosing scopes.
It is not clear from the language definition that
@ -629,7 +627,7 @@ type_or_forward(ptp)
one token.
???
*/
free_node(nd);
FreeNode(nd);
return 1;
}
/* Enter a forward reference into a list belonging to the
@ -641,7 +639,7 @@ type_or_forward(ptp)
if (df->df_kind == D_TYPE) {
(*ptp)->tp_next = df->df_type;
free_node(nd);
FreeNode(nd);
return 0;
}
nd->nd_type = *ptp;
@ -679,7 +677,7 @@ lcm(m, n)
#ifdef DEBUG
DumpType(tp)
register struct type *tp;
register t_type *tp;
{
if (!tp) return;

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

@ -29,7 +29,7 @@ extern char *sprint();
int
TstTypeEquiv(tp1, tp2)
struct type *tp1, *tp2;
t_type *tp1, *tp2;
{
/* test if two types are equivalent.
*/
@ -43,7 +43,7 @@ TstTypeEquiv(tp1, tp2)
int
TstParEquiv(tp1, tp2)
register struct type *tp1, *tp2;
register t_type *tp1, *tp2;
{
/* test if two parameter types are equivalent. This routine
is used to check if two different procedure declarations
@ -66,7 +66,7 @@ TstParEquiv(tp1, tp2)
int
TstProcEquiv(tp1, tp2)
struct type *tp1, *tp2;
t_type *tp1, *tp2;
{
/* Test if two procedure types are equivalent. This routine
may also be used for the testing of assignment compatibility
@ -98,7 +98,7 @@ TstProcEquiv(tp1, tp2)
int
TstCompat(tp1, tp2)
register struct type *tp1, *tp2;
register t_type *tp1, *tp2;
{
/* test if two types are compatible. See section 6.3 of the
Modula-2 Report for a definition of "compatible".
@ -110,7 +110,7 @@ TstCompat(tp1, tp2)
tp2 = BaseType(tp2);
if (tp2 != intorcard_type &&
(tp1 == intorcard_type || tp1 == address_type)) {
struct type *tmp = tp2;
t_type *tmp = tp2;
tp2 = tp1;
tp1 = tmp;
@ -132,12 +132,12 @@ TstCompat(tp1, tp2)
int
TstAssCompat(tp1, tp2)
register struct type *tp1, *tp2;
register t_type *tp1, *tp2;
{
/* Test if two types are assignment compatible.
See Def 9.1.
*/
register struct type *tp;
register t_type *tp;
if (TstCompat(tp1, tp2)) return 1;
@ -179,9 +179,9 @@ TstAssCompat(tp1, tp2)
int
TstParCompat(parno, formaltype, VARflag, nd, edf)
register struct type *formaltype;
struct node **nd;
struct def *edf;
register t_type *formaltype;
t_node **nd;
t_def *edf;
{
/* Check type compatibility for a parameter in a procedure call.
Assignment compatibility may do if the parameter is
@ -190,7 +190,7 @@ TstParCompat(parno, formaltype, VARflag, nd, edf)
may do too.
Or: a WORD may do.
*/
register struct type *actualtype = (*nd)->nd_type;
register t_type *actualtype = (*nd)->nd_type;
char ebuf[256];
char ebuf1[256];
@ -258,8 +258,8 @@ TstParCompat(parno, formaltype, VARflag, nd, edf)
}
CompatCheck(nd, tp, message, fc)
struct node **nd;
struct type *tp;
t_node **nd;
t_type *tp;
char *message;
int (*fc)();
{
@ -274,8 +274,8 @@ CompatCheck(nd, tp, message, fc)
}
ChkAssCompat(nd, tp, message)
struct node **nd;
struct type *tp;
t_node **nd;
t_type *tp;
char *message;
{
/* Check assignment compatibility of node "nd" with type "tp".
@ -286,8 +286,8 @@ ChkAssCompat(nd, tp, message)
}
ChkCompat(nd, tp, message)
struct node **nd;
struct type *tp;
t_node **nd;
t_type *tp;
char *message;
{
/* Check compatibility of node "nd" with type "tp".

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

@ -23,6 +23,7 @@
#include <assert.h>
#include <alloc.h>
#include "squeeze.h"
#include "LLlex.h"
#include "def.h"
#include "type.h"
@ -37,19 +38,32 @@
#include "walk.h"
#include "warning.h"
extern arith NewPtr();
extern arith NewInt();
extern int proclevel;
label text_label;
label data_label = 1;
static struct type *func_type;
struct withdesig *WithDesigs;
struct node *Modules;
static struct node *priority;
extern arith NewPtr();
extern arith NewInt();
extern int proclevel;
label text_label;
label data_label = 1;
static t_type *func_type;
struct withdesig *WithDesigs;
t_node *Modules;
static arith priority;
#define NO_EXIT_LABEL ((label) 0)
#define RETURN_LABEL ((label) 1)
LblWalkNode(lbl, nd, exit)
label lbl, exit;
register t_node *nd;
{
/* Generate code for node "nd", after generating instruction
label "lbl". "exit" is the exit label for the closest
enclosing LOOP.
*/
C_df_ilb(lbl);
WalkNode(nd, exit);
}
STATIC
DoPriority()
{
@ -57,10 +71,8 @@ DoPriority()
the runtime system
*/
register struct node *p;
if (p = priority) {
C_loc(p->nd_INT);
if (priority) {
C_loc(priority);
C_cal("_stackprio");
C_asp(word_size);
}
@ -92,7 +104,7 @@ DoProfil()
}
WalkModule(module)
register struct def *module;
register t_def *module;
{
/* Walk through a module, and all its local definitions.
Also generate code for its body.
@ -102,7 +114,7 @@ WalkModule(module)
struct scopelist *savevis = CurrVis;
CurrVis = module->mod_vis;
priority = module->mod_priority;
priority = module->mod_priority ? module->mod_priority->nd_INT : 0;
sc = CurrentScope;
/* Walk through it's local definitions
@ -124,7 +136,7 @@ WalkModule(module)
Call initialization routines of imported modules.
Also prevent recursive calls of this one.
*/
register struct node *nd = Modules;
register t_node *nd = Modules;
if (state == IMPLEMENTATION) {
/* We don't actually prevent recursive calls,
@ -159,14 +171,14 @@ WalkModule(module)
}
WalkProcedure(procedure)
register struct def *procedure;
register t_def *procedure;
{
/* Walk through the definition of a procedure and all its
local definitions, checking and generating code.
*/
struct scopelist *savevis = CurrVis;
register struct scope *sc = procedure->prc_vis->sc_scope;
register struct type *tp;
register t_type *tp;
register struct paramlist *param;
label func_res_label = 0;
arith StackAdjustment = 0;
@ -276,7 +288,7 @@ WalkProcedure(procedure)
WalkNode(procedure->prc_body, NO_EXIT_LABEL);
DO_DEBUG(options['X'], PrNode(procedure->prc_body, 0));
if (func_res_size) {
C_loc((arith) M2_NORESULT);
c_loc(M2_NORESULT);
C_trp();
C_asp(-func_res_size);
}
@ -285,7 +297,7 @@ WalkProcedure(procedure)
/* Fill the data area reserved for the function result
with the result
*/
C_lae_dlb(func_res_label, (arith) 0);
c_lae_dlb(func_res_label);
C_sti(func_res_size);
if (StackAdjustment) {
/* Remove copies of conformant arrays
@ -293,7 +305,7 @@ WalkProcedure(procedure)
C_lol(StackAdjustment);
C_str((arith) 1);
}
C_lae_dlb(func_res_label, (arith) 0);
c_lae_dlb(func_res_label);
func_res_size = pointer_size;
}
else if (StackAdjustment) {
@ -323,7 +335,7 @@ WalkProcedure(procedure)
}
WalkDef(df)
register struct def *df;
register t_def *df;
{
/* Walk through a list of definitions
*/
@ -352,7 +364,7 @@ WalkDef(df)
}
MkCalls(df)
register struct def *df;
register t_def *df;
{
/* Generate calls to initialization routines of modules
*/
@ -367,7 +379,7 @@ MkCalls(df)
}
WalkLink(nd, exit_label)
register struct node *nd;
register t_node *nd;
label exit_label;
{
/* Walk node "nd", which is a link.
@ -381,44 +393,39 @@ WalkLink(nd, exit_label)
WalkNode(nd, exit_label);
}
WalkCall(nd)
register struct node *nd;
{
assert(nd->nd_class == Call);
if (! options['L']) C_lin((arith) nd->nd_lineno);
if (ChkCall(nd)) {
if (nd->nd_type != 0) {
node_error(nd, "procedure call expected");
return;
}
CodeCall(nd);
}
}
STATIC
ForLoopVarExpr(nd)
register struct node *nd;
register t_node *nd;
{
register struct type *tp = nd->nd_type;
register t_type *tp = nd->nd_type;
CodePExpr(nd);
CodeCoercion(tp, BaseType(tp));
}
WalkStat(nd, exit_label)
register struct node *nd;
register t_node *nd;
label exit_label;
{
/* Walk through a statement, generating code for it.
*/
register struct node *left = nd->nd_left;
register struct node *right = nd->nd_right;
register t_node *left = nd->nd_left;
register t_node *right = nd->nd_right;
assert(nd->nd_class == Stat);
if (! options['L'] && nd->nd_lineno) C_lin((arith) nd->nd_lineno);
switch(nd->nd_symb) {
case '(':
if (ChkCall(nd)) {
if (nd->nd_type != 0) {
node_error(nd, "procedure call expected");
break;
}
CodeCall(nd);
}
break;
case ';':
break;
@ -431,15 +438,13 @@ WalkStat(nd, exit_label)
ExpectBool(left, l3, l1);
assert(right->nd_symb == THEN);
C_df_ilb(l3);
WalkNode(right->nd_left, exit_label);
LblWalkNode(l3, right->nd_left, exit_label);
if (right->nd_right) { /* ELSE part */
label l2 = ++text_label;
C_bra(l2);
C_df_ilb(l1);
WalkNode(right->nd_right, exit_label);
LblWalkNode(l1, right->nd_right, exit_label);
l1 = l2;
}
C_df_ilb(l1);
@ -457,8 +462,7 @@ WalkStat(nd, exit_label)
C_df_ilb(loop);
ExpectBool(left, dummy, exit);
C_df_ilb(dummy);
WalkNode(right, exit_label);
LblWalkNode(dummy, right, exit_label);
C_bra(loop);
C_df_ilb(exit);
break;
@ -467,8 +471,7 @@ WalkStat(nd, exit_label)
case REPEAT:
{ label loop = ++text_label, exit = ++text_label;
C_df_ilb(loop);
WalkNode(left, exit_label);
LblWalkNode(loop, left, exit_label);
ExpectBool(right, exit, loop);
C_df_ilb(exit);
break;
@ -477,8 +480,7 @@ WalkStat(nd, exit_label)
case LOOP:
{ label loop = ++text_label, exit = ++text_label;
C_df_ilb(loop);
WalkNode(right, exit);
LblWalkNode(loop, right, exit);
C_bra(loop);
C_df_ilb(exit);
break;
@ -488,13 +490,13 @@ WalkStat(nd, exit_label)
{
arith tmp = NewInt();
arith tmp2;
register struct node *fnd;
register t_node *fnd;
int good_forvar;
label l1 = ++text_label;
label l2 = ++text_label;
int uns = 0;
arith stepsize;
struct type *bstp;
t_type *bstp;
good_forvar = DoForInit(nd);
if ((stepsize = left->nd_INT) == 0) {
@ -551,7 +553,7 @@ WalkStat(nd, exit_label)
C_lol(tmp);
C_zeq(l2);
C_lol(tmp);
C_loc((arith) 1);
c_loc(1);
C_sbu(int_size);
C_stl(tmp);
C_loc(left->nd_INT);
@ -575,7 +577,7 @@ WalkStat(nd, exit_label)
{
struct scopelist link;
struct withdesig wds;
struct desig ds;
t_desig ds;
if (! WalkDesignator(left, &ds)) break;
if (left->nd_type->tp_fund != T_RECORD) {
@ -640,7 +642,7 @@ extern int NodeCrash();
STATIC
WalkOption(nd)
struct node *nd;
t_node *nd;
{
/* Set option indicated by node "nd"
*/
@ -654,7 +656,7 @@ int (*WalkTable[])() = {
NodeCrash,
NodeCrash,
NodeCrash,
WalkCall,
NodeCrash,
NodeCrash,
NodeCrash,
NodeCrash,
@ -665,13 +667,13 @@ int (*WalkTable[])() = {
};
ExpectBool(nd, true_label, false_label)
register struct node *nd;
register t_node *nd;
label true_label, false_label;
{
/* "nd" must indicate a boolean expression. Check this and
generate code to evaluate the expression.
*/
register struct desig *ds = new_desig();
register t_desig *ds = new_desig();
if (ChkExpression(nd)) {
if (nd->nd_type != bool_type && nd->nd_type != error_type) {
@ -685,25 +687,25 @@ ExpectBool(nd, true_label, false_label)
int
WalkDesignator(nd, ds)
struct node *nd;
struct desig *ds;
t_node *nd;
t_desig *ds;
{
/* Check designator and generate code for it
*/
if (! ChkVariable(nd)) return 0;
clear((char *) ds, sizeof(struct desig));
clear((char *) ds, sizeof(t_desig));
CodeDesig(nd, ds);
return 1;
}
DoForInit(nd)
register struct node *nd;
register t_node *nd;
{
register struct node *left = nd->nd_left;
register struct def *df;
struct type *tpl, *tpr;
register t_node *left = nd->nd_left;
register t_def *df;
t_type *tpl, *tpr;
nd->nd_left = nd->nd_right = 0;
nd->nd_class = Name;
@ -761,16 +763,16 @@ node_warning(nd, W_OLDFASHIONED, "compatibility required in FOR statement");
}
DoAssign(left, right)
register struct node *left;
struct node *right;
register t_node *left;
t_node *right;
{
/* May we do it in this order (expression first) ???
The reference manual sais nothing about it, but the book does:
it sais that the left hand side is evaluated first.
DAMN THE BOOK!
*/
register struct desig *dsr;
register struct type *tp;
register t_desig *dsr;
register t_type *tp;
if (! (ChkExpression(right) & ChkVariable(left))) return;
tp = left->nd_type;
@ -797,9 +799,9 @@ DoAssign(left, right)
}
RegisterMessages(df)
register struct def *df;
register t_def *df;
{
register struct type *tp;
register t_type *tp;
arith sz;
int regtype = -1;

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

@ -18,3 +18,8 @@ extern int (*WalkTable[])();
extern label text_label;
extern label data_label;
#ifndef SQUEEZE
#define c_loc(x) C_loc((arith) (x))
#define c_lae_dlb(x) C_lae_dlb(x,(arith) 0)
#endif