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

first, almost complete, version

Browse source
This commit is contained in:
ceriel 1986-06-04 09:01:48 +00:00
parent db795bc07a
commit 9e0ab0029b
19 changed files with 458 additions and 309 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -26,9 +26,10 @@ static char *RcsId = "$Header$";
long str2long();
struct token dot, aside;
struct type *numtype;
struct type *toktype;
struct string string;
int idfsize = IDFSIZE;
extern label data_label();
static
SkipComment()
@ -111,10 +112,10 @@ LLlex()
The putting aside of tokens is taken into account.
*/
register struct token *tk = ˙
char buf[(IDFSIZE > NUMSIZE ? IDFSIZE : NUMSIZE) + 1];
char buf[(IDFSIZE > NUMSIZE ? IDFSIZE : NUMSIZE) + 2];
register int ch, nch;
numtype = error_type;
toktype = error_type;
if (ASIDE) { /* a token is put aside */
*tk = aside;
ASIDE = 0;
@ -221,9 +222,16 @@ again:
case STSTR:
GetString(ch);
tk->tk_data.tk_str = (struct string *)
if (string.s_length == 1) {
tk->TOK_INT = *(string.s_str) & 0377;
toktype = char_type;
}
else {
tk->tk_data.tk_str = (struct string *)
Malloc(sizeof (struct string));
*(tk->tk_data.tk_str) = string;
*(tk->tk_data.tk_str) = string;
toktype = standard_type(T_STRING, 1, string.s_length);
}
return tk->tk_symb = STRING;
case STNUM:
@ -252,9 +260,9 @@ again:
Shex: *np++ = '\0';
tk->TOK_INT = str2long(&buf[1], 16);
if (tk->TOK_INT >= 0 && tk->TOK_INT <= max_int) {
numtype = intorcard_type;
toktype = intorcard_type;
}
else numtype = card_type;
else toktype = card_type;
return tk->tk_symb = INTEGER;
case '8':
@ -290,15 +298,15 @@ Shex: *np++ = '\0';
*np++ = '\0';
tk->TOK_INT = str2long(&buf[1], 8);
if (ch == 'C') {
numtype = char_type;
toktype = char_type;
if (tk->TOK_INT < 0 || tk->TOK_INT > 255) {
lexwarning("Character constant out of range");
}
}
else if (tk->TOK_INT >= 0 && tk->TOK_INT <= max_int) {
numtype = intorcard_type;
toktype = intorcard_type;
}
else numtype = card_type;
else toktype = card_type;
return tk->tk_symb = INTEGER;
case 'A':
@ -380,12 +388,10 @@ Sreal:
PushBack(ch);
if (np == &buf[NUMSIZE + 1]) {
lexerror("floating constant too long");
tk->TOK_REL = Salloc("0.0", 5);
lexerror("floating constant too long");
}
else {
tk->TOK_REL = Salloc(buf, np - buf) + 1;
}
else tk->TOK_REL = Salloc(buf, np - buf) + 1;
return tk->tk_symb = REAL;
default:
@ -394,9 +400,9 @@ Sdec:
*np++ = '\0';
tk->TOK_INT = str2long(&buf[1], 10);
if (tk->TOK_INT < 0 || tk->TOK_INT > max_int) {
numtype = card_type;
toktype = card_type;
}
else numtype = intorcard_type;
else toktype = intorcard_type;
return tk->tk_symb = INTEGER;
}
/*NOTREACHED*/

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

@ -25,10 +25,10 @@ struct token {
#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
#define TOK_REL tk_data.tk_real
extern struct token dot, aside;
extern struct type *numtype;
extern struct type *toktype;
#define DOT dot.tk_symb
#define ASIDE aside.tk_symb

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

@ -61,7 +61,7 @@ chk_expr(expp)
return 1;
default:
assert(0);
crash("(chk_expr(Value))");
}
break;
@ -78,7 +78,7 @@ chk_expr(expp)
return chk_designator(expp, DESIGNATOR|VALUE, D_USED|D_NOREG);
default:
assert(0);
crash("(chk_expr)");
}
/*NOTREACHED*/
}
@ -90,9 +90,9 @@ chk_set(expp)
/* Check the legality of a SET aggregate, and try to evaluate it
compile time. Unfortunately this is all rather complicated.
*/
struct type *tp;
struct def *df;
register struct type *tp;
register struct node *nd;
register struct def *df;
arith *set;
unsigned size;
@ -110,7 +110,7 @@ chk_set(expp)
if (!(df->df_kind & (D_TYPE|D_ERROR)) ||
(df->df_type->tp_fund != T_SET)) {
node_error(expp, "specifier does not represent a set type");
node_error(expp, "specifier does not represent a set type");
return 0;
}
tp = df->df_type;
@ -163,16 +163,16 @@ chk_set(expp)
int
chk_el(expp, tp, set)
register struct node *expp;
struct type *tp;
register struct type *tp;
arith **set;
{
/* Check elements of a set. This routine may call itself
recursively.
Also try to compute the set!
*/
register int i;
register struct node *left = expp->nd_left;
register struct node *right = expp->nd_right;
register int i;
if (expp->nd_class == Link && expp->nd_symb == UPTO) {
/* { ... , expr1 .. expr2, ... }
@ -370,7 +370,9 @@ chk_proccall(expp)
while (param) {
if (!(left = getarg(&arg, 0, IsVarParam(param)))) return 0;
if (left->nd_symb == STRING) {
TryToString(left, TypeOfParam(param));
}
if (! TstParCompat(TypeOfParam(param),
left->nd_type,
IsVarParam(param),
@ -734,6 +736,7 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
}
return 1;
case T_HIDDEN:
case T_POINTER:
if (chk_address(tpl, tpr) ||
expp->nd_symb == '=' ||
@ -812,16 +815,13 @@ chk_uoper(expp)
return 1;
}
else if (tpr->tp_fund == T_REAL) {
expp->nd_type = tpr;
if (right->nd_class == Value) {
expp->nd_token = right->nd_token;
if (*(right->nd_REL) == '-') (right->nd_REL)++;
else (right->nd_REL)--;
expp->nd_class = Value;
if (*(expp->nd_REL) == '-') {
expp->nd_REL++;
}
else {
expp->nd_REL--;
*(expp->nd_REL) = '-';
}
expp->nd_symb = REAL;
expp->nd_REL = right->nd_REL;
FreeNode(right);
expp->nd_right = 0;
}
@ -901,7 +901,10 @@ DO_DEBUG(3,debug("standard name \"%s\", %d",left->nd_def->df_idf->id_text,std));
case S_ABS:
if (!(left = getarg(&arg, T_NUMERIC, 0))) return 0;
expp->nd_type = left->nd_type;
if (left->nd_class == Value) cstcall(expp, S_ABS);
if (left->nd_class == Value &&
expp->nd_type->tp_fund != T_REAL) {
cstcall(expp, S_ABS);
}
break;
case S_CAP:
@ -1085,3 +1088,20 @@ node_error(expp, "only one parameter expected in type cast");
return 1;
}
TryToString(nd, tp)
struct node *nd;
struct type *tp;
{
/* Try a coercion from character constant to string */
if (tp->tp_fund == T_ARRAY && nd->nd_type == char_type) {
int ch = nd->nd_INT;
nd->nd_type = standard_type(T_STRING, 1, (arith) 2);
nd->nd_token.tk_data.tk_str =
(struct string *) Malloc(sizeof(struct string));
nd->nd_STR = Salloc("X", 2);
*(nd->nd_STR) = ch;
nd->nd_SLE = 1;
}
}

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

@ -50,25 +50,49 @@ CodeConst(cst, size)
}
CodeString(nd)
struct node *nd;
register struct node *nd;
{
label lab;
if (nd->nd_type == charc_type) {
if (nd->nd_type == char_type) {
C_loc(nd->nd_INT);
return;
}
C_df_dlb(lab = data_label());
C_rom_scon(nd->nd_STR, nd->nd_SLE);
C_lae_dlb(lab, (arith) 0);
else {
C_df_dlb(lab = data_label());
C_rom_scon(nd->nd_STR, align(nd->nd_SLE + 1, word_size));
C_lae_dlb(lab, (arith) 0);
}
}
CodePadString(nd, sz)
register struct node *nd;
arith sz;
{
/* Generate code to push the string indicated by "nd".
Make it null-padded to "sz" bytes
*/
register arith sizearg = align(nd->nd_type->tp_size, word_align);
assert(nd->nd_type->tp_fund == T_STRING);
if (sizearg != sz) {
/* null padding required */
assert(sizearg < sz);
C_zer(sz - sizearg);
}
C_asp(-sizearg); /* room for string */
CodeString(nd); /* push address of string */
C_lor((arith) 1); /* load stack pointer */
C_adp(pointer_size); /* and compute target address from it */
C_blm(sizearg); /* and copy */
}
CodeReal(nd)
struct node *nd;
register struct node *nd;
{
label lab;
C_df_dlb(lab = data_label());
label lab = data_label();
C_df_dlb(lab);
C_rom_fcon(nd->nd_REL, nd->nd_type->tp_size);
C_lae_dlb(lab, (arith) 0);
C_loi(nd->nd_type->tp_size);
@ -83,10 +107,13 @@ CodeExpr(nd, ds, true_label, false_label)
switch(nd->nd_class) {
case Def:
if (nd->nd_def->df_kind == D_PROCEDURE) {
C_lpi(nd->nd_def->prc_vis->sc_scope->sc_name);
C_lpi(NameOfProc(nd->nd_def));
ds->dsg_kind = DSG_LOADED;
break;
}
/* Fall through */
case Link:
CodeDesig(nd, ds);
break;
@ -97,10 +124,8 @@ CodeExpr(nd, ds, true_label, false_label)
}
CodeOper(nd, true_label, false_label);
if (true_label == 0) ds->dsg_kind = DSG_LOADED;
else {
*ds = InitDesig;
true_label = 0;
}
else ds->dsg_kind = DSG_INIT;
true_label = 0;
break;
case Uoper:
@ -130,10 +155,6 @@ CodeExpr(nd, ds, true_label, false_label)
ds->dsg_kind = DSG_LOADED;
break;
case Link:
CodeDesig(nd, ds);
break;
case Call:
CodeCall(nd);
ds->dsg_kind = DSG_LOADED;
@ -177,7 +198,7 @@ CodeExpr(nd, ds, true_label, false_label)
CodeCoercion(t1, t2)
register struct type *t1, *t2;
{
int fund1, fund2;
register int fund1, fund2;
if (t1 == t2) return;
if (t1->tp_fund == T_SUBRANGE) t1 = t1->next;
@ -285,7 +306,6 @@ CodeCall(nd)
CodeStd(nd);
return;
}
tp = left->nd_type;
if (IsCast(left)) {
/* it was just a cast. Simply ignore it
@ -299,18 +319,42 @@ CodeCall(nd)
assert(IsProcCall(left));
for (param = left->nd_type->prc_params; param; param = param->next) {
tp = TypeOfParam(param);
arg = arg->nd_right;
assert(arg != 0);
if (IsVarParam(param)) {
if (IsConformantArray(tp)) {
C_loc(tp->arr_elsize);
if (IsConformantArray(arg->nd_left->nd_type)) {
DoHIGH(arg->nd_left);
}
else if (arg->nd_left->nd_symb == STRING) {
C_loc(arg->nd_left->nd_SLE);
}
else if (tp->arr_elem == word_type) {
C_loc(arg->nd_left->nd_type->tp_size / word_size - 1);
}
else C_loc(arg->nd_left->nd_type->tp_size /
tp->arr_elsize - 1);
C_loc(0);
if (arg->nd_left->nd_symb == STRING) {
CodeString(arg->nd_left);
}
else CodeDAddress(arg->nd_left);
pushed += pointer_size + 3 * word_size;
}
else if (IsVarParam(param)) {
CodeDAddress(arg->nd_left);
pushed += pointer_size;
}
else {
CodePExpr(arg->nd_left);
CheckAssign(arg->nd_left->nd_type, TypeOfParam(param));
pushed += align(arg->nd_left->nd_type->tp_size, word_align);
if (arg->nd_left->nd_type->tp_fund == T_STRING) {
CodePadString(arg->nd_left,
align(tp->tp_size, word_align));
}
else CodePExpr(arg->nd_left);
CheckAssign(arg->nd_left->nd_type, tp);
pushed += align(tp->tp_size, word_align);
}
/* ??? Conformant arrays */
}
if (left->nd_class == Def && left->nd_def->df_kind == D_PROCEDURE) {
@ -318,7 +362,7 @@ CodeCall(nd)
C_lxl((arith) proclevel - left->nd_def->df_scope->sc_level);
pushed += pointer_size;
}
C_cal(left->nd_def->prc_vis->sc_scope->sc_name);
C_cal(NameOfProc(left->nd_def));
}
else if (left->nd_class == Def && left->nd_def->df_kind == D_PROCHEAD) {
C_cal(left->nd_def->for_name);
@ -327,9 +371,9 @@ CodeCall(nd)
CodePExpr(left);
C_cai();
}
C_asp(pushed);
if (tp->next) {
C_lfr(align(tp->next->tp_size, word_align));
if (pushed) C_asp(pushed);
if (left->nd_type->next) {
C_lfr(align(left->nd_type->next->tp_size, word_align));
}
}
@ -385,7 +429,7 @@ CodeStd(nd)
case S_HIGH:
assert(IsConformantArray(tp));
/* ??? */
DoHIGH(left);
break;
case S_ODD:
@ -480,15 +524,24 @@ CodeAssign(nd, dss, dst)
/* Generate code for an assignment. Testing of type
compatibility and the like is already done.
*/
register struct type *tp = nd->nd_right->nd_type;
extern arith align();
if (dss->dsg_kind == DSG_LOADED) {
if (tp->tp_fund == T_STRING) {
CodeAddress(dst);
C_loc(tp->tp_size);
C_loc(nd->nd_left->nd_type->tp_size);
C_cal("_StringAssign");
C_asp((int_size << 1) + (pointer_size << 1));
return;
}
CodeStore(dst, nd->nd_left->nd_type->tp_size);
return;
}
else {
CodeAddress(dss);
CodeAddress(dst);
C_blm(nd->nd_left->nd_type->tp_size);
}
CodeAddress(dss);
CodeAddress(dst);
C_blm(nd->nd_left->nd_type->tp_size);
}
CheckAssign(tpl, tpr)
@ -683,6 +736,7 @@ CodeOper(expr, true_label, false_label)
case T_INTEGER:
C_cmi(tp->tp_size);
break;
case T_HIDDEN:
case T_POINTER:
C_cmp();
break;
@ -904,12 +958,16 @@ CodeSet(nd)
CodeEl(nd, tp)
register struct node *nd;
struct type *tp;
register struct type *tp;
{
if (nd->nd_class == Link && nd->nd_symb == UPTO) {
C_zer(tp->tp_size); /* empty set */
C_lor((arith) 1); /* SP: address of set */
if (tp->next->tp_fund == T_SUBRANGE) {
C_loc(tp->next->sub_ub);
}
else C_loc(tp->next->enm_ncst - 1);
Operands(nd->nd_left, nd->nd_right);
C_cal("_LtoUset"); /* library routine to fill set */
C_asp(2 * word_size + pointer_size);
@ -960,3 +1018,23 @@ CodeDStore(nd)
CodeDesig(nd, &designator);
CodeStore(&designator, nd->nd_type->tp_size);
}
DoHIGH(nd)
struct node *nd;
{
register struct def *df;
arith highoff;
assert(nd->nd_class == Def);
df = nd->nd_def;
assert(df->df_kind == D_VARIABLE);
highoff = df->var_off + pointer_size + word_size;
if (df->df_scope->sc_level < proclevel) {
C_lxa(proclevel - df->df_scope->sc_level);
C_lof(highoff);
}
else C_lol(highoff);
}

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

@ -374,12 +374,6 @@ cstcall(expp, call)
expp->nd_symb = INTEGER;
switch(call) {
case S_ABS:
if (expr->nd_type->tp_fund == T_REAL) {
expp->nd_symb = REAL;
expp->nd_REL = expr->nd_REL;
if (*(expr->nd_REL) == '-') (expp->nd_REL)++;
break;
}
if (expr->nd_INT < 0) expp->nd_INT = - expr->nd_INT;
else expp->nd_INT = expr->nd_INT;
CutSize(expp);

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

@ -54,7 +54,7 @@ ProcedureHeading(struct def **pdf; int type;)
{
df = DeclProc(type);
tp = construct_type(T_PROCEDURE, tp);
if (proclevel) {
if (proclevel > 1) {
/* Room for static link
*/
tp->prc_nbpar = pointer_size;
@ -134,10 +134,10 @@ FPSection(struct paramlist **ppr; arith *parmaddr;)
{
struct node *FPList;
struct type *tp;
int VARp = 0;
int VARp = D_VALPAR;
} :
[
VAR { VARp = 1; }
VAR { VARp = D_VARPAR; }
]?
IdentList(&FPList) ':' FormalType(&tp)
{
@ -146,43 +146,48 @@ FPSection(struct paramlist **ppr; arith *parmaddr;)
}
;
FormalType(struct type **tp;)
FormalType(struct type **ptp;)
{
struct def *df;
int ARRAYflag = 0;
register struct type *tp;
extern arith ArrayElSize();
} :
[ ARRAY OF { ARRAYflag = 1; }
]?
qualident(D_ISTYPE, &df, "type", (struct node **) 0)
{ if (ARRAYflag) {
*tp = construct_type(T_ARRAY, NULLTYPE);
(*tp)->arr_elem = df->df_type;
(*tp)->tp_align = lcm(word_align, pointer_align);
(*tp)->tp_size = align(pointer_size + word_size,
(*tp)->tp_align);
*ptp = tp = construct_type(T_ARRAY, NULLTYPE);
tp->arr_elem = df->df_type;
tp->arr_elsize = ArrayElSize(df->df_type);
tp->tp_align = lcm(word_align, pointer_align);
}
else *tp = df->df_type;
else *ptp = df->df_type;
}
;
TypeDeclaration
{
struct def *df;
register struct def *df;
struct type *tp;
}:
IDENT { df = lookup(dot.TOK_IDF, CurrentScope);
if (!df) df = define( dot.TOK_IDF,
CurrentScope,
D_TYPE);
if (!df) df = define(dot.TOK_IDF,CurrentScope,D_TYPE);
}
'=' type(&tp)
{ if (df->df_type) free_type(df->df_type); /* ??? */
df->df_type = tp;
if (df->df_kind == D_HIDDEN &&
tp->tp_fund != T_POINTER) {
{
if (df->df_kind == D_HIDDEN) {
if (tp->tp_fund != T_POINTER) {
error("opaque type \"%s\" is not a pointer type", df->df_idf->id_text);
}
df->df_kind = D_TYPE;
*(df->df_type) = *tp;
free_type(tp);
}
else {
df->df_type = tp;
df->df_kind = D_TYPE;
}
df->df_kind = D_TYPE;
}
;
@ -235,6 +240,7 @@ enumeration(struct type **ptp;)
CurrentScope, (arith *) 0);
FreeNode(EnumList);
if (tp->enm_ncst > 256) {
/* ??? is this reasonable ??? */
error("Too many enumeration literals");
}
}
@ -244,12 +250,12 @@ IdentList(struct node **p;)
{
register struct node *q;
} :
IDENT { q = MkNode(Value, NULLNODE, NULLNODE, &dot);
IDENT { q = MkLeaf(Value, &dot);
*p = q;
}
[
',' IDENT
{ q->next = MkNode(Value,NULLNODE,NULLNODE,&dot);
{ q->next = MkLeaf(Value, &dot);
q = q->next;
}
]*
@ -572,11 +578,11 @@ VariableDeclaration
IdentAddrList(struct node **pnd;)
{
} :
IDENT { *pnd = MkNode(Name, NULLNODE, NULLNODE, &dot); }
IDENT { *pnd = MkLeaf(Name, &dot); }
ConstExpression(&(*pnd)->nd_left)?
[ { pnd = &((*pnd)->nd_right); }
',' IDENT
{ *pnd = MkNode(Name, NULLNODE, NULLNODE, &dot); }
{ *pnd = MkLeaf(Name, &dot); }
ConstExpression(&(*pnd)->nd_left)?
]*
;

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

@ -48,6 +48,7 @@ struct dfproc {
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
#define NameOfProc(xdf) ((xdf)->prc_vis->sc_scope->sc_name)
};
struct import {

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

@ -30,7 +30,7 @@ struct def *ill_df;
struct def *
MkDef(id, scope, kind)
struct idf *id;
struct scope *scope;
register struct scope *scope;
{
/* Create a new definition structure in scope "scope", with
id "id" and kind "kind".
@ -55,7 +55,7 @@ MkDef(id, scope, kind)
InitDef()
{
/* Initialize this module. Easy, the only thing to be initialized
is "illegal_def".
is "ill_df".
*/
struct idf *gen_anon_idf();
@ -83,6 +83,9 @@ define(id, scope, kind)
) {
switch(df->df_kind) {
case D_HIDDEN:
/* An opaque type. We may now have found the
definition of this type.
*/
if (kind == D_TYPE && !DefinitionModule) {
df->df_kind = D_TYPE;
return df;
@ -90,6 +93,10 @@ define(id, scope, kind)
break;
case D_FORWMODULE:
/* A forward reference to a module. We may have found
another one, or we may have found the definition
for this module.
*/
if (kind == D_FORWMODULE) {
return df;
}
@ -104,19 +111,27 @@ define(id, scope, kind)
break;
case D_FORWARD:
/* A forward reference, for which we may now have
found a definition.
*/
if (kind != D_FORWARD) {
FreeNode(df->for_node);
}
df->df_kind = kind;
return df;
/* Fall through */
case D_ERROR:
/* A definition generated by the compiler, because
it found an error. Maybe, the user gives a
definition after all.
*/
df->df_kind = kind;
return df;
}
if (kind != D_ERROR) {
/* Avoid spurious error messages
*/
error("identifier \"%s\" already declared", id->id_text);
}
@ -149,6 +164,8 @@ lookup(id, scope)
assert(retval != 0);
}
if (df1) {
/* Put the definition now found in front
*/
df1->next = df->next;
df->next = id->id_def;
id->id_def = df;
@ -162,30 +179,34 @@ lookup(id, scope)
}
DoImport(df, scope)
struct def *df;
register struct def *df;
struct scope *scope;
{
register struct def *df1;
/* Definition "df" is imported to scope "scope".
Handle the case that it is an enumeration type or a module.
*/
define(df->df_idf, scope, D_IMPORT)->imp_def = df;
if (df->df_kind == D_TYPE && df->df_type->tp_fund == T_ENUMERATION) {
/* Also import all enumeration literals
*/
df1 = df->df_type->enm_enums;
while (df1) {
define(df1->df_idf, scope, D_IMPORT)->imp_def = df1;
df1 = df1->enm_next;
df = df->df_type->enm_enums;
while (df) {
define(df->df_idf, scope, D_IMPORT)->imp_def = df;
df = df->enm_next;
}
}
else if (df->df_kind == D_MODULE) {
/* Also import all definitions that are exported from this
module
*/
df1 = df->mod_vis->sc_scope->sc_def;
while (df1) {
if (df1->df_flags & D_EXPORTED) {
define(df1->df_idf, scope, D_IMPORT)->imp_def = df1;
df = df->mod_vis->sc_scope->sc_def;
while (df) {
if (df->df_flags & D_EXPORTED) {
define(df->df_idf,scope,D_IMPORT)->imp_def = df;
}
df1 = df1->df_nextinscope;
df = df->df_nextinscope;
}
}
}
@ -213,7 +234,7 @@ node_error(ids, "identifier \"%s\" not defined", ids->nd_IDF->id_text);
}
if (df->df_flags & (D_EXPORTED|D_QEXPORTED)) {
node_error(ids, "Identifier \"%s\" occurs more than once in export list",
node_error(ids, "identifier \"%s\" occurs more than once in export list",
df->df_idf->id_text);
}
@ -225,6 +246,8 @@ df->df_idf->id_text);
Find all imports of the module in which this export
occurs, and export the current definition to it
*/
df->df_flags |= D_EXPORTED;
impmod = moddef->df_idf->id_def;
while (impmod) {
if (impmod->df_kind == D_IMPORT &&
@ -234,7 +257,6 @@ df->df_idf->id_text);
impmod = impmod->next;
}
df->df_flags |= D_EXPORTED;
df1 = lookup(ids->nd_IDF, enclosing(CurrVis)->sc_scope);
if (df1 && df1->df_kind == D_PROCHEAD) {
if (df->df_kind == D_PROCEDURE) {
@ -255,10 +277,6 @@ error("opaque type \"%s\" is not a pointer type", df->df_idf->id_text);
}
}
df1 = define(ids->nd_IDF,
enclosing(CurrVis)->sc_scope,
D_IMPORT);
df1->imp_def = df;
DoImport(df, enclosing(CurrVis)->sc_scope);
}
}
@ -283,7 +301,7 @@ ForwModule(df, idn)
closing this one
*/
df->for_vis = vis;
df->for_node = MkNode(Name, NULLNODE, NULLNODE, &(idn->nd_token));
df->for_node = MkLeaf(Name, &(idn->nd_token));
close_scope(0);
vis->sc_encl = enclosing(CurrVis);
/* Here ! */
@ -302,7 +320,7 @@ ForwDef(ids, scope)
if (!(df = lookup(ids->nd_IDF, scope))) {
df = define(ids->nd_IDF, scope, D_FORWARD);
df->for_node = MkNode(Name,NULLNODE,NULLNODE,&(ids->nd_token));
df->for_node = MkLeaf(Name, &(ids->nd_token));
}
return df;
}
@ -384,7 +402,6 @@ ids->nd_IDF->id_text);
else df = GetDefinitionModule(ids->nd_IDF);
}
define(ids->nd_IDF,CurrentScope,D_IMPORT)->imp_def = df;
DoImport(df, CurrentScope);
ids = ids->next;
@ -393,7 +410,7 @@ ids->nd_IDF->id_text);
FreeNode(idn);
}
RemImports(pdf)
RemoveImports(pdf)
struct def **pdf;
{
/* Remove all imports from a definition module. This is
@ -404,7 +421,7 @@ RemImports(pdf)
while (df) {
if (df->df_kind == D_IMPORT) {
RemFromId(df);
RemoveFromIdList(df);
*pdf = df->df_nextinscope;
free_def(df);
}
@ -415,7 +432,7 @@ RemImports(pdf)
}
}
RemFromId(df)
RemoveFromIdList(df)
struct def *df;
{
/* Remove definition "df" from the definition list
@ -438,11 +455,11 @@ struct def *
DeclProc(type)
{
/* A procedure is declared, either in a definition or a program
module. Create a def structure for it (if neccessary)
module. Create a def structure for it (if neccessary).
Also create a name for it.
*/
register struct def *df;
static int nmcount = 0;
extern char *Malloc();
extern char *strcpy();
extern char *sprint();
char buf[256];
@ -453,7 +470,7 @@ DeclProc(type)
/* In a definition module
*/
df = define(dot.TOK_IDF, CurrentScope, type);
df->for_node = MkNode(Name, NULLNODE, NULLNODE, &dot);
df->for_node = MkLeaf(Name, &dot);
sprint(buf,"%s_%s",CurrentScope->sc_name,df->df_idf->id_text);
df->for_name = Malloc((unsigned) (strlen(buf)+1));
strcpy(df->for_name, buf);
@ -512,12 +529,12 @@ AddModule(id)
register struct node *n;
extern struct node *Modules;
n = MkNode(Name, NULLNODE, NULLNODE, &dot);
n = MkLeaf(Name, &dot);
n->nd_IDF = id;
n->nd_symb = IDENT;
if (nd_end) nd_end->next = n;
else Modules = n;
nd_end = n;
if (!Modules) Modules = n;
}
DefInFront(df)
@ -528,14 +545,24 @@ DefInFront(df)
This is neccessary because in some cases the order in this
list is important.
*/
register struct def *df1;
register struct def *df1 = df->df_scope->sc_def;
if (df->df_scope->sc_def != df) {
df1 = df->df_scope->sc_def;
if (df1 != df) {
/* Definition "df" is not in front of the list
*/
while (df1 && df1->df_nextinscope != df) {
/* Find definition "df"
*/
df1 = df1->df_nextinscope;
}
if (df1) df1->df_nextinscope = df->df_nextinscope;
if (df1) {
/* It already was in the list. Remove it
*/
df1->df_nextinscope = df->df_nextinscope;
}
/* Now put it in front
*/
df->df_nextinscope = df->df_scope->sc_def;
df->df_scope->sc_def = df;
}

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

@ -268,7 +268,8 @@ CodeVarDesig(df, ds)
/* value or var parameter
*/
C_lxa((arith) (proclevel - sc->sc_level));
if (df->df_flags & D_VARPAR) {
if ((df->df_flags & D_VARPAR) ||
IsConformantArray(df->df_type)) {
/* var parameter
*/
C_adp(df->var_off);
@ -287,7 +288,7 @@ CodeVarDesig(df, ds)
/* Now, finally, we have a local variable or a local parameter
*/
if (df->df_flags & D_VARPAR) {
if ((df->df_flags & D_VARPAR) || IsConformantArray(df->df_type)) {
/* a var parameter; address directly accessible.
*/
ds->dsg_kind = DSG_PFIXED;
@ -303,10 +304,11 @@ CodeDesig(nd, ds)
/* Generate code for a designator. Use divide and conquer
principle
*/
register struct def *df;
switch(nd->nd_class) { /* Divide */
case Def: {
register struct def *df = nd->nd_def;
case Def:
df = nd->nd_def;
df->df_flags |= D_USED;
switch(df->df_kind) {
@ -321,7 +323,6 @@ CodeDesig(nd, ds)
default:
crash("(CodeDesig) Def");
}
}
break;
case Link:
@ -336,18 +337,24 @@ CodeDesig(nd, ds)
CodeDesig(nd->nd_left, ds);
CodeAddress(ds);
*ds = InitDesig;
CodeExpr(nd->nd_right, ds, NO_LABEL, NO_LABEL);
CodeValue(ds, nd->nd_right->nd_type->tp_size);
CodePExpr(nd->nd_right);
if (nd->nd_right->nd_type->tp_size > word_size) {
CodeCoercion(nd->nd_right->nd_type, int_type);
}
/* Now load address of descriptor
*/
if (IsConformantArray(nd->nd_left->nd_type)) {
/* ??? */
assert(nd->nd_left->nd_class == Def);
df = nd->nd_left->nd_def;
if (proclevel > df->df_scope->sc_level) {
C_lxa(proclevel - df->df_scope->sc_level);
C_adp(df->var_off + pointer_size);
}
else C_lal(df->var_off + pointer_size);
}
else {
/* load address of descriptor
*/
C_lae_dlb(nd->nd_left->nd_type->arr_descr, (arith) 0);
}
ds->dsg_kind = DSG_INDEXED;

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

@ -26,48 +26,51 @@ number(struct node **p;)
} :
[
%default
INTEGER { tp = numtype; }
INTEGER { tp = toktype; }
|
REAL { tp = real_type; }
] { *p = MkNode(Value, NULLNODE, NULLNODE, &dot);
] { *p = MkLeaf(Value, &dot);
(*p)->nd_type = tp;
}
;
qualident(int types; struct def **pdf; char *str; struct node **p;)
qualident(int types;
struct def **pdf;
char *str;
struct node **p;
)
{
register struct def *df;
struct node *nd;
} :
IDENT { nd = MkNode(Name, NULLNODE, NULLNODE, &dot);
}
IDENT { nd = MkLeaf(Name, &dot); }
[
selector(&nd)
]*
{ if (types) {
df = ill_df;
{ if (types) {
df = ill_df;
if (chk_designator(nd, 0, D_REFERRED)) {
if (nd->nd_class != Def) {
node_error(nd, "%s expected", str);
if (chk_designator(nd, 0, D_REFERRED)) {
if (nd->nd_class != Def) {
node_error(nd, "%s expected", str);
}
else {
df = nd->nd_def;
if ( !((types|D_ERROR) & df->df_kind)) {
if (df->df_kind == D_FORWARD) {
node_error(nd,"%s \"%s\" not declared", str, df->df_idf->id_text);
}
else {
df = nd->nd_def;
if ( !((types|D_ERROR) & df->df_kind)) {
if (df->df_kind == D_FORWARD) {
node_error(nd,"%s \"%s\" not declared", str, df->df_idf->id_text);
}
else {
node_error(nd,"identifier \"%s\" is not a %s", df->df_idf->id_text, str);
}
}
}
}
*pdf = df;
}
if (!p) FreeNode(nd);
else *p = nd;
}
}
*pdf = df;
}
if (!p) FreeNode(nd);
else *p = nd;
}
;
selector(struct node **pnd;):
@ -84,7 +87,7 @@ ExpList(struct node **pnd;)
nd = &((*pnd)->nd_right);
}
[
',' { *nd = MkNode(Link, NULLNODE, NULLNODE, &dot);
',' { *nd = MkLeaf(Link, &dot);
}
expression(&(*nd)->nd_left)
{ nd = &((*nd)->nd_right); }
@ -131,7 +134,7 @@ SimpleExpression(struct node **pnd;)
} :
[
[ '+' | '-' ]
{ *pnd = MkNode(Uoper, NULLNODE, NULLNODE, &dot);
{ *pnd = MkLeaf(Uoper, &dot);
pnd = &((*pnd)->nd_right);
}
]?
@ -191,23 +194,13 @@ factor(struct node **p;)
number(p)
|
STRING {
*p = MkNode(Value, NULLNODE, NULLNODE, &dot);
if (dot.TOK_SLE == 1) {
int i;
tp = charc_type;
i = *(dot.TOK_STR) & 0377;
free(dot.TOK_STR);
free((char *) dot.tk_data.tk_str);
(*p)->nd_INT = i;
}
else tp = standard_type(T_STRING, 1, dot.TOK_SLE);
(*p)->nd_type = tp;
*p = MkLeaf(Value, &dot);
(*p)->nd_type = toktype;
}
|
'(' expression(p) ')'
|
NOT { *p = MkNode(Uoper, NULLNODE, NULLNODE, &dot); }
NOT { *p = MkLeaf(Uoper, &dot); }
factor(&((*p)->nd_right))
;
@ -217,7 +210,7 @@ bare_set(struct node **pnd;)
} :
'{' {
dot.tk_symb = SET;
*pnd = nd = MkNode(Xset, NULLNODE, NULLNODE, &dot);
*pnd = nd = MkLeaf(Xset, &dot);
nd->nd_type = bitset_type;
}
[

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

@ -111,27 +111,27 @@ Compile(src, dst)
#ifdef DEBUG
LexScan()
{
register int symb;
char *symbol2str();
register struct token *tkp = &dot;
extern char *symbol2str();
while ((symb = LLlex()) > 0) {
print(">>> %s ", symbol2str(symb));
switch(symb) {
while (LLlex() > 0) {
print(">>> %s ", symbol2str(tkp->tk_symb));
switch(tkp->tk_symb) {
case IDENT:
print("%s\n", dot.TOK_IDF->id_text);
print("%s\n", tkp->TOK_IDF->id_text);
break;
case INTEGER:
print("%ld\n", dot.TOK_INT);
print("%ld\n", tkp->TOK_INT);
break;
case REAL:
print("%s\n", dot.TOK_REL);
print("%s\n", tkp->TOK_REL);
break;
case STRING:
print("\"%s\"\n", dot.TOK_STR);
print("\"%s\"\n", tkp->TOK_STR);
break;
default:

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

@ -33,7 +33,7 @@ struct node {
/* ALLOCDEF "node" */
extern struct node *MkNode();
extern struct node *MkNode(), *MkLeaf();
#define NULLNODE ((struct node *) 0)

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

@ -39,6 +39,19 @@ MkNode(class, left, right, token)
return nd;
}
struct node *
MkLeaf(class, token)
struct token *token;
{
register struct node *nd = new_node();
nd->nd_left = nd->nd_right = 0;
nd->nd_token = *token;
nd->nd_type = error_type;
nd->nd_class = class;
return nd;
}
FreeNode(nd)
register struct node *nd;
{

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

@ -19,11 +19,6 @@ static char *RcsId = "$Header$";
#include "type.h"
#include "node.h"
static int DEFofIMPL = 0; /* Flag indicating that we are currently
parsing the definition module of the
implementation module currently being
compiled
*/
}
/*
The grammar as given by Wirth is already almost LL(1); the
@ -132,7 +127,7 @@ import(int local;)
struct node *id = 0;
} :
[ FROM
IDENT { id = MkNode(Value, NULLNODE, NULLNODE, &dot); }
IDENT { id = MkLeaf(Value, &dot); }
]?
IMPORT IdentList(&ImportList) ';'
/*
@ -176,12 +171,6 @@ DefinitionModule
*/
definition* END IDENT
{
if (DEFofIMPL) {
/* Just read the definition module of the
implementation module being compiled
*/
RemImports(&(CurrentScope->sc_def));
}
df = CurrentScope->sc_def;
while (df) {
/* Make all definitions "QUALIFIED EXPORT" */
@ -211,7 +200,7 @@ definition
It is restricted to pointer types.
*/
{ df->df_kind = D_HIDDEN;
df->df_type = construct_type(T_POINTER, NULLTYPE);
df->df_type = construct_type(T_HIDDEN, NULLTYPE);
}
]
Semicolon
@ -239,11 +228,10 @@ ProgramModule
IDENT {
id = dot.TOK_IDF;
if (state == IMPLEMENTATION) {
DEFofIMPL = 1;
df = GetDefinitionModule(id);
CurrVis = df->mod_vis;
CurrentScope = CurrVis->sc_scope;
DEFofIMPL = 0;
RemoveImports(&(CurrentScope->sc_def));
}
else {
df = define(id, CurrentScope, D_MODULE);

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

@ -18,11 +18,10 @@ static char *RcsId = "$Header$";
static int loopcount = 0; /* Count nested loops */
}
statement(struct node **pnd;)
statement(register struct node **pnd;)
{
register struct node *nd;
} :
{ *pnd = 0; }
[
/*
* This part is not in the reference grammar. The reference grammar
@ -61,11 +60,13 @@ statement(struct node **pnd;)
|
EXIT
{ if (!loopcount) error("EXIT not in a LOOP");
*pnd = MkNode(Stat, NULLNODE, NULLNODE, &dot);
*pnd = MkLeaf(Stat, &dot);
}
|
ReturnStatement(pnd)
]?
|
/* empty */ { *pnd = 0; }
]
;
/*
@ -80,7 +81,9 @@ ProcedureCall:
;
*/
StatementSequence(struct node **pnd;):
StatementSequence(register struct node **pnd;)
{
} :
statement(pnd)
[
';' { *pnd = MkNode(Link, *pnd, NULLNODE, &dot);
@ -94,21 +97,21 @@ IfStatement(struct node **pnd;)
{
register struct node *nd;
} :
IF { nd = MkNode(Stat, NULLNODE, NULLNODE, &dot);
IF { nd = MkLeaf(Stat, &dot);
*pnd = nd;
}
expression(&(nd->nd_left))
THEN { nd = MkNode(Link, NULLNODE, NULLNODE, &dot);
(*pnd)->nd_right = nd;
THEN { nd->nd_right = MkLeaf(Link, &dot);
nd = nd->nd_right;
}
StatementSequence(&(nd->nd_left))
[
ELSIF { nd->nd_right = MkNode(Stat,NULLNODE,NULLNODE,&dot);
ELSIF { nd->nd_right = MkLeaf(Stat, &dot);
nd = nd->nd_right;
nd->nd_symb = IF;
}
expression(&(nd->nd_left))
THEN { nd->nd_right = MkNode(Link,NULLNODE,NULLNODE,&dot);
THEN { nd->nd_right = MkLeaf(Link, &dot);
nd = nd->nd_right;
}
StatementSequence(&(nd->nd_left))
@ -125,7 +128,7 @@ CaseStatement(struct node **pnd;)
register struct node *nd;
struct type *tp = 0;
} :
CASE { *pnd = nd = MkNode(Stat, NULLNODE, NULLNODE, &dot); }
CASE { *pnd = nd = MkLeaf(Stat, &dot); }
expression(&(nd->nd_left))
OF
case(&(nd->nd_right), &tp)
@ -140,12 +143,10 @@ CaseStatement(struct node **pnd;)
;
case(struct node **pnd; struct type **ptp;) :
{ *pnd = 0; }
[ CaseLabelList(ptp, pnd)
':' { *pnd = MkNode(Link, *pnd, NULLNODE, &dot); }
StatementSequence(&((*pnd)->nd_right))
]?
/* This rule is changed in new modula-2 */
{ *pnd = MkNode(Link, *pnd, NULLNODE, &dot);
(*pnd)->nd_symb = '|';
}
@ -155,7 +156,7 @@ WhileStatement(struct node **pnd;)
{
register struct node *nd;
}:
WHILE { *pnd = nd = MkNode(Stat, NULLNODE, NULLNODE, &dot); }
WHILE { *pnd = nd = MkLeaf(Stat, &dot); }
expression(&(nd->nd_left))
DO
StatementSequence(&(nd->nd_right))
@ -166,7 +167,7 @@ RepeatStatement(struct node **pnd;)
{
register struct node *nd;
}:
REPEAT { *pnd = nd = MkNode(Stat, NULLNODE, NULLNODE, &dot); }
REPEAT { *pnd = nd = MkLeaf(Stat, &dot); }
StatementSequence(&(nd->nd_left))
UNTIL
expression(&(nd->nd_right))
@ -177,10 +178,10 @@ ForStatement(struct node **pnd;)
register struct node *nd;
struct node *dummy;
}:
FOR { *pnd = MkNode(Stat, NULLNODE, NULLNODE, &dot); }
IDENT { (*pnd)->nd_IDF = dot.TOK_IDF; }
BECOMES { nd = MkNode(Stat, NULLNODE, NULLNODE, &dot);
(*pnd)->nd_left = nd;
FOR { *pnd = nd = MkLeaf(Stat, &dot); }
IDENT { nd->nd_IDF = dot.TOK_IDF; }
BECOMES { nd->nd_left = MkLeaf(Stat, &dot);
nd = nd->nd_left;
}
expression(&(nd->nd_left))
TO
@ -204,7 +205,7 @@ ForStatement(struct node **pnd;)
;
LoopStatement(struct node **pnd;):
LOOP { *pnd = MkNode(Stat, NULLNODE, NULLNODE, &dot); }
LOOP { *pnd = MkLeaf(Stat, &dot); }
StatementSequence(&((*pnd)->nd_right))
END
;
@ -213,7 +214,7 @@ WithStatement(struct node **pnd;)
{
register struct node *nd;
}:
WITH { *pnd = nd = MkNode(Stat, NULLNODE, NULLNODE, &dot); }
WITH { *pnd = nd = MkLeaf(Stat, &dot); }
designator(&(nd->nd_left))
DO
StatementSequence(&(nd->nd_right))
@ -226,7 +227,7 @@ ReturnStatement(struct node **pnd;)
register struct node *nd;
} :
RETURN { *pnd = nd = MkNode(Stat, NULLNODE, NULLNODE, &dot); }
RETURN { *pnd = nd = MkLeaf(Stat, &dot); }
[
expression(&(nd->nd_right))
{ if (scopeclosed(CurrentScope)) {

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

@ -21,18 +21,20 @@ struct enume {
};
struct subrange {
arith su_lb, su_ub; /* Lower bound and upper bound */
label su_rck; /* Label of range check descriptor */
arith su_lb, su_ub; /* lower bound and upper bound */
label su_rck; /* label of range check descriptor */
#define sub_lb tp_value.tp_subrange.su_lb
#define sub_ub tp_value.tp_subrange.su_ub
#define sub_rck tp_value.tp_subrange.su_rck
};
struct array {
struct type *ar_elem; /* Type of elements */
label ar_descr; /* Label of array descriptor */
struct type *ar_elem; /* type of elements */
label ar_descr; /* label of array descriptor */
arith ar_elsize; /* size of elements */
#define arr_elem tp_value.tp_arr.ar_elem
#define arr_descr tp_value.tp_arr.ar_descr
#define arr_elsize tp_value.tp_arr.ar_elsize
};
struct record {
@ -59,7 +61,7 @@ struct type {
#define T_CARDINAL 0x0008
/* #define T_LONGINT 0x0010 */
#define T_REAL 0x0020
/* #define T_LONGREAL 0x0040 */
#define T_HIDDEN 0x0040
#define T_POINTER 0x0080
#define T_CHAR 0x0100
#define T_WORD 0x0200
@ -89,7 +91,6 @@ struct type {
extern struct type
*bool_type,
*char_type,
*charc_type,
*int_type,
*card_type,
*longint_type,
@ -132,7 +133,7 @@ struct type
#define NULLTYPE ((struct type *) 0)
#define IsConformantArray(tpx) ((tpx)->tp_fund == T_ARRAY && (tpx)->next == 0)
#define IsConformantArray(tpx) ((tpx)->tp_fund==T_ARRAY && (tpx)->next==0)
#define bounded(tpx) ((tpx)->tp_fund & T_INDEX)
#define complex(tpx) ((tpx)->tp_fund & (T_RECORD|T_ARRAY))
#define returntype(tpx) (((tpx)->tp_fund & T_PRCRESULT) ||\

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

@ -45,7 +45,6 @@ arith
struct type
*bool_type,
*char_type,
*charc_type,
*int_type,
*card_type,
*longint_type,
@ -72,7 +71,7 @@ extern label data_label();
struct type *
create_type(fund)
register int fund;
int fund;
{
/* A brand new struct type is created, and its tp_fund set
to fund.
@ -81,29 +80,29 @@ create_type(fund)
clear((char *)ntp, sizeof(struct type));
ntp->tp_fund = fund;
ntp->tp_size = (arith)-1;
return ntp;
}
struct type *
construct_type(fund, tp)
struct type *tp;
int fund;
register struct type *tp;
{
/* fund must be a type constructor.
The pointer to the constructed type is returned.
*/
struct type *dtp = create_type(fund);
register struct type *dtp = create_type(fund);
switch (fund) {
case T_PROCEDURE:
case T_POINTER:
case T_HIDDEN:
dtp->tp_align = pointer_align;
dtp->tp_size = pointer_size;
dtp->next = tp;
if (fund == T_PROCEDURE && tp) {
if (tp != bitset_type &&
!(tp->tp_fund&(T_NUMERIC|T_INDEX|T_WORD|T_POINTER))) {
if (! returntype(tp)) {
error("illegal procedure result type");
}
}
@ -142,7 +141,9 @@ align(pos, al)
struct type *
standard_type(fund, align, size)
int align; arith size;
int fund;
int align;
arith size;
{
register struct type *tp = create_type(fund);
@ -161,15 +162,19 @@ init_types()
/* first, do some checking
*/
if (int_size != word_size) {
fatal("Integer size not equal to word size");
fatal("integer size not equal to word size");
}
if (long_size < int_size) {
fatal("Long integer size smaller than integer size");
if (long_size < int_size || long_size % word_size != 0) {
fatal("illegal long integer size");
}
if (double_size < float_size) {
fatal("Long real size smaller than real size");
fatal("long real size smaller than real size");
}
if (!pointer_size || pointer_size % word_size != 0) {
fatal("illegal pointer size");
}
/* character type
@ -177,12 +182,6 @@ init_types()
char_type = standard_type(T_CHAR, 1, (arith) 1);
char_type->enm_ncst = 256;
/* character constant type, different from character type because
of compatibility with character array's
*/
charc_type = standard_type(T_CHAR, 1, (arith) 1);
charc_type->enm_ncst = 256;
/* boolean type
*/
bool_type = standard_type(T_ENUMERATION, 1, (arith) 1);
@ -226,28 +225,36 @@ ParamList(ppr, ids, tp, VARp, off)
register struct node *ids;
struct paramlist **ppr;
struct type *tp;
int VARp;
arith *off;
{
/* Create (part of) a parameterlist of a procedure.
"ids" indicates the list of identifiers, "tp" their type, and
"VARp" is set when the parameters are VAR-parameters.
*/
"VARp" indicates D_VARPAR or D_VALPAR.
*/
register struct paramlist *pr;
register struct def *df;
struct paramlist *pstart;
while (ids) {
for ( ; ids; ids = ids->next) {
pr = new_paramlist();
pr->next = *ppr;
*ppr = pr;
df = define(ids->nd_IDF, CurrentScope, D_VARIABLE);
pr->par_def = df;
df->df_type = tp;
if (VARp) df->df_flags = D_VARPAR;
else df->df_flags = D_VALPAR;
df->var_off = align(*off, word_align);
*off = df->var_off + tp->tp_size;
ids = ids->next;
df->df_flags = VARp;
if (IsConformantArray(tp)) {
/* we need room for the base address and a descriptor
*/
*off = df->var_off + pointer_size + 3 * word_size;
}
else if (VARp == D_VARPAR) {
*off = df->var_off + pointer_size;
}
else {
*off = df->var_off + tp->tp_size;
}
}
}
@ -267,7 +274,7 @@ chk_basesubrange(tp, base)
base = base->next;
}
if (base->tp_fund == T_ENUMERATION || base->tp_fund == T_CHAR) {
if (base->tp_fund & (T_ENUMERATION|T_CHAR)) {
if (tp->next != base) {
error("Specified base does not conform");
}
@ -384,7 +391,7 @@ getbounds(tp, plo, phi)
}
struct type *
set_type(tp)
struct type *tp;
register struct type *tp;
{
/* Construct a set type with base type "tp", but first
perform some checks
@ -414,22 +421,33 @@ set_type(tp)
return tp;
}
arith
ArrayElSize(tp)
register struct 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,
or a multiple of it.
*/
arith algn;
if (tp->tp_fund == T_ARRAY) ArraySizes(tp);
algn = align(tp->tp_size, tp->tp_align);
if (!(algn % word_size == 0 || word_size % algn == 0)) {
algn = align(algn, word_size);
}
return algn;
}
ArraySizes(tp)
register struct type *tp;
{
/* Assign sizes to an array type, and check index type
*/
arith elem_size;
register struct type *index_type = tp->next;
register struct type *elem_type = tp->arr_elem;
if (elem_type->tp_fund == T_ARRAY) {
ArraySizes(elem_type);
}
/* align element size to alignment requirement of element type
*/
elem_size = align(elem_type->tp_size, elem_type->tp_align);
tp->arr_elsize = ArrayElSize(elem_type);
tp->tp_align = elem_type->tp_align;
/* check index type
@ -447,7 +465,7 @@ ArraySizes(tp)
switch(index_type->tp_fund) {
case T_SUBRANGE:
tp->tp_size = elem_size *
tp->tp_size = tp->arr_elsize *
(index_type->sub_ub - index_type->sub_lb + 1);
C_rom_cst(index_type->sub_lb);
C_rom_cst(index_type->sub_ub - index_type->sub_lb);
@ -455,7 +473,7 @@ ArraySizes(tp)
case T_CHAR:
case T_ENUMERATION:
tp->tp_size = elem_size * index_type->enm_ncst;
tp->tp_size = tp->arr_elsize * index_type->enm_ncst;
C_rom_cst((arith) 0);
C_rom_cst((arith) (index_type->enm_ncst - 1));
break;
@ -464,7 +482,7 @@ ArraySizes(tp)
crash("Funny index type");
}
C_rom_cst(elem_size);
C_rom_cst(tp->arr_elsize);
/* ??? overflow checking ???
*/
@ -473,7 +491,9 @@ ArraySizes(tp)
FreeType(tp)
struct type *tp;
{
/* Release type structures indicated by "tp"
/* Release type structures indicated by "tp".
This procedure is only called for types, constructed with
T_PROCEDURE.
*/
register struct paramlist *pr, *pr1;

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

@ -105,10 +105,6 @@ TstCompat(tp1, tp2)
&&
(tp1 == int_type || tp1 == card_type)
)
||
(tp1 == char_type && tp2 == charc_type)
||
(tp2 == char_type && tp1 == charc_type)
||
( tp1 == address_type
&&
@ -145,8 +141,6 @@ TstAssCompat(tp1, tp2)
if ((tp1->tp_fund & T_INTORCARD) &&
(tp2->tp_fund & T_INTORCARD)) return 1;
if (tp1 == char_type && tp2 == charc_type) return 1;
if (tp1->tp_fund == T_ARRAY) {
/* check for string
*/
@ -162,12 +156,8 @@ TstAssCompat(tp1, tp2)
if (tp1->tp_fund == T_SUBRANGE) tp1 = tp1->next;
return
tp1 == char_type
&&
(
tp2 == charc_type
||
(tp2->tp_fund == T_STRING && size >= tp2->tp_size)
);
&& (tp2->tp_fund == T_STRING && size >= tp2->tp_size)
;
}
return 0;

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

@ -25,7 +25,6 @@ static char *RcsId = "$Header$";
#include "f_info.h"
#include "idf.h"
extern arith align();
extern arith NewPtr();
extern arith NewInt();
extern int proclevel;
@ -58,7 +57,7 @@ DoProfil()
if (!filename_label) {
filename_label = data_label();
C_df_dlb(filename_label);
C_rom_scon(FileName, (arith) strlen(FileName));
C_rom_scon(FileName, (arith) (strlen(FileName) + 1));
}
C_fil_dlb(filename_label, (arith) 0);
@ -131,20 +130,22 @@ WalkModule(module)
Call initialization routines of imported modules.
Also prevent recursive calls of this one.
*/
label l1 = data_label(), l2 = text_label();
struct node *nd;
/* we don't actually prevent recursive calls, but do nothing
if called recursively
*/
C_df_dlb(l1);
C_bss_cst(word_size, (arith) 0, 1);
C_loe_dlb(l1, (arith) 0);
C_zeq(l2);
C_ret((arith) 0);
C_df_ilb(l2);
C_loc((arith) 1);
C_ste_dlb(l1, (arith) 0);
if (state == IMPLEMENTATION) {
label l1 = data_label(), l2 = text_label();
/* we don't actually prevent recursive calls,
but do nothing if called recursively
*/
C_df_dlb(l1);
C_bss_cst(word_size, (arith) 0, 1);
C_loe_dlb(l1, (arith) 0);
C_zeq(l2);
C_ret((arith) 0);
C_df_ilb(l2);
C_loc((arith) 1);
C_ste_dlb(l1, (arith) 0);
}
nd = Modules;
while (nd) {
@ -278,7 +279,7 @@ WalkStat(nd, lab)
return;
}
if (options['L']) C_lin((arith) nd->nd_lineno);
if (! options['L']) C_lin((arith) nd->nd_lineno);
if (nd->nd_class == Call) {
if (chk_call(nd)) {
@ -541,8 +542,11 @@ DoAssign(nd, left, right)
/* May we do it in this order (expression first) ??? */
struct desig ds;
WalkExpr(right, NO_LABEL, NO_LABEL);
if (!chk_expr(right)) return;
if (! chk_designator(left, DESIGNATOR|VARIABLE, D_DEFINED)) return;
TryToString(right, left->nd_type);
Desig = InitDesig;
CodeExpr(right, &Desig, NO_LABEL, NO_LABEL);
if (! TstAssCompat(left->nd_type, right->nd_type)) {
node_error(nd, "type incompatibility in assignment");