d0p1/ack
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages 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

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

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

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

@ -28,7 +28,7 @@ struct token {
#define TOK_REL tk_data.tk_real #define TOK_REL tk_data.tk_real
extern struct token dot, aside; extern struct token dot, aside;
extern struct type *numtype; extern struct type *toktype;
#define DOT dot.tk_symb #define DOT dot.tk_symb
#define ASIDE aside.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; return 1;
default: default:
assert(0); crash("(chk_expr(Value))");
} }
break; break;
@ -78,7 +78,7 @@ chk_expr(expp)
return chk_designator(expp, DESIGNATOR|VALUE, D_USED|D_NOREG); return chk_designator(expp, DESIGNATOR|VALUE, D_USED|D_NOREG);
default: default:
assert(0); crash("(chk_expr)");
} }
/*NOTREACHED*/ /*NOTREACHED*/
} }
@ -90,9 +90,9 @@ chk_set(expp)
/* Check the legality of a SET aggregate, and try to evaluate it /* Check the legality of a SET aggregate, and try to evaluate it
compile time. Unfortunately this is all rather complicated. compile time. Unfortunately this is all rather complicated.
*/ */
struct type *tp; register struct type *tp;
struct def *df;
register struct node *nd; register struct node *nd;
register struct def *df;
arith *set; arith *set;
unsigned size; unsigned size;
@ -110,7 +110,7 @@ chk_set(expp)
if (!(df->df_kind & (D_TYPE|D_ERROR)) || if (!(df->df_kind & (D_TYPE|D_ERROR)) ||
(df->df_type->tp_fund != T_SET)) { (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; return 0;
} }
tp = df->df_type; tp = df->df_type;
@ -163,16 +163,16 @@ chk_set(expp)
int int
chk_el(expp, tp, set) chk_el(expp, tp, set)
register struct node *expp; register struct node *expp;
struct type *tp; register struct type *tp;
arith **set; arith **set;
{ {
/* Check elements of a set. This routine may call itself /* Check elements of a set. This routine may call itself
recursively. recursively.
Also try to compute the set! Also try to compute the set!
*/ */
register int i;
register struct node *left = expp->nd_left; register struct node *left = expp->nd_left;
register struct node *right = expp->nd_right; register struct node *right = expp->nd_right;
register int i;
if (expp->nd_class == Link && expp->nd_symb == UPTO) { if (expp->nd_class == Link && expp->nd_symb == UPTO) {
/* { ... , expr1 .. expr2, ... } /* { ... , expr1 .. expr2, ... }
@ -370,7 +370,9 @@ chk_proccall(expp)
while (param) { while (param) {
if (!(left = getarg(&arg, 0, IsVarParam(param)))) return 0; if (!(left = getarg(&arg, 0, IsVarParam(param)))) return 0;
if (left->nd_symb == STRING) {
TryToString(left, TypeOfParam(param));
}
if (! TstParCompat(TypeOfParam(param), if (! TstParCompat(TypeOfParam(param),
left->nd_type, left->nd_type,
IsVarParam(param), IsVarParam(param),
@ -734,6 +736,7 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
} }
return 1; return 1;
case T_HIDDEN:
case T_POINTER: case T_POINTER:
if (chk_address(tpl, tpr) || if (chk_address(tpl, tpr) ||
expp->nd_symb == '=' || expp->nd_symb == '=' ||
@ -812,16 +815,13 @@ chk_uoper(expp)
return 1; return 1;
} }
else if (tpr->tp_fund == T_REAL) { else if (tpr->tp_fund == T_REAL) {
expp->nd_type = tpr;
if (right->nd_class == Value) { 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; expp->nd_class = Value;
if (*(expp->nd_REL) == '-') { expp->nd_symb = REAL;
expp->nd_REL++; expp->nd_REL = right->nd_REL;
}
else {
expp->nd_REL--;
*(expp->nd_REL) = '-';
}
FreeNode(right); FreeNode(right);
expp->nd_right = 0; 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: case S_ABS:
if (!(left = getarg(&arg, T_NUMERIC, 0))) return 0; if (!(left = getarg(&arg, T_NUMERIC, 0))) return 0;
expp->nd_type = left->nd_type; 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; break;
case S_CAP: case S_CAP:
@ -1085,3 +1088,20 @@ node_error(expp, "only one parameter expected in type cast");
return 1; 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;
}
}

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

@ -50,25 +50,49 @@ CodeConst(cst, size)
} }
CodeString(nd) CodeString(nd)
struct node *nd; register struct node *nd;
{ {
label lab; label lab;
if (nd->nd_type == charc_type) { if (nd->nd_type == char_type) {
C_loc(nd->nd_INT); C_loc(nd->nd_INT);
return;
} }
else {
C_df_dlb(lab = data_label()); C_df_dlb(lab = data_label());
C_rom_scon(nd->nd_STR, nd->nd_SLE); C_rom_scon(nd->nd_STR, align(nd->nd_SLE + 1, word_size));
C_lae_dlb(lab, (arith) 0); 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) CodeReal(nd)
struct node *nd; register struct node *nd;
{ {
label lab; label lab = data_label();
C_df_dlb(lab = data_label()); C_df_dlb(lab);
C_rom_fcon(nd->nd_REL, nd->nd_type->tp_size); C_rom_fcon(nd->nd_REL, nd->nd_type->tp_size);
C_lae_dlb(lab, (arith) 0); C_lae_dlb(lab, (arith) 0);
C_loi(nd->nd_type->tp_size); C_loi(nd->nd_type->tp_size);
@ -83,10 +107,13 @@ CodeExpr(nd, ds, true_label, false_label)
switch(nd->nd_class) { switch(nd->nd_class) {
case Def: case Def:
if (nd->nd_def->df_kind == D_PROCEDURE) { 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; ds->dsg_kind = DSG_LOADED;
break; break;
} }
/* Fall through */
case Link:
CodeDesig(nd, ds); CodeDesig(nd, ds);
break; break;
@ -97,10 +124,8 @@ CodeExpr(nd, ds, true_label, false_label)
} }
CodeOper(nd, true_label, false_label); CodeOper(nd, true_label, false_label);
if (true_label == 0) ds->dsg_kind = DSG_LOADED; if (true_label == 0) ds->dsg_kind = DSG_LOADED;
else { else ds->dsg_kind = DSG_INIT;
*ds = InitDesig;
true_label = 0; true_label = 0;
}
break; break;
case Uoper: case Uoper:
@ -130,10 +155,6 @@ CodeExpr(nd, ds, true_label, false_label)
ds->dsg_kind = DSG_LOADED; ds->dsg_kind = DSG_LOADED;
break; break;
case Link:
CodeDesig(nd, ds);
break;
case Call: case Call:
CodeCall(nd); CodeCall(nd);
ds->dsg_kind = DSG_LOADED; ds->dsg_kind = DSG_LOADED;
@ -177,7 +198,7 @@ CodeExpr(nd, ds, true_label, false_label)
CodeCoercion(t1, t2) CodeCoercion(t1, t2)
register struct type *t1, *t2; register struct type *t1, *t2;
{ {
int fund1, fund2; register int fund1, fund2;
if (t1 == t2) return; if (t1 == t2) return;
if (t1->tp_fund == T_SUBRANGE) t1 = t1->next; if (t1->tp_fund == T_SUBRANGE) t1 = t1->next;
@ -285,7 +306,6 @@ CodeCall(nd)
CodeStd(nd); CodeStd(nd);
return; return;
} }
tp = left->nd_type;
if (IsCast(left)) { if (IsCast(left)) {
/* it was just a cast. Simply ignore it /* it was just a cast. Simply ignore it
@ -299,18 +319,42 @@ CodeCall(nd)
assert(IsProcCall(left)); assert(IsProcCall(left));
for (param = left->nd_type->prc_params; param; param = param->next) { for (param = left->nd_type->prc_params; param; param = param->next) {
tp = TypeOfParam(param);
arg = arg->nd_right; arg = arg->nd_right;
assert(arg != 0); 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); CodeDAddress(arg->nd_left);
pushed += pointer_size; pushed += pointer_size;
} }
else { else {
CodePExpr(arg->nd_left); if (arg->nd_left->nd_type->tp_fund == T_STRING) {
CheckAssign(arg->nd_left->nd_type, TypeOfParam(param)); CodePadString(arg->nd_left,
pushed += align(arg->nd_left->nd_type->tp_size, word_align); 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) { 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); C_lxl((arith) proclevel - left->nd_def->df_scope->sc_level);
pushed += pointer_size; 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) { else if (left->nd_class == Def && left->nd_def->df_kind == D_PROCHEAD) {
C_cal(left->nd_def->for_name); C_cal(left->nd_def->for_name);
@ -327,9 +371,9 @@ CodeCall(nd)
CodePExpr(left); CodePExpr(left);
C_cai(); C_cai();
} }
C_asp(pushed); if (pushed) C_asp(pushed);
if (tp->next) { if (left->nd_type->next) {
C_lfr(align(tp->next->tp_size, word_align)); C_lfr(align(left->nd_type->next->tp_size, word_align));
} }
} }
@ -385,7 +429,7 @@ CodeStd(nd)
case S_HIGH: case S_HIGH:
assert(IsConformantArray(tp)); assert(IsConformantArray(tp));
/* ??? */ DoHIGH(left);
break; break;
case S_ODD: case S_ODD:
@ -480,15 +524,24 @@ CodeAssign(nd, dss, dst)
/* Generate code for an assignment. Testing of type /* Generate code for an assignment. Testing of type
compatibility and the like is already done. 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 (dss->dsg_kind == DSG_LOADED) {
CodeStore(dst, nd->nd_left->nd_type->tp_size); 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(dss);
CodeAddress(dst); CodeAddress(dst);
C_blm(nd->nd_left->nd_type->tp_size); C_blm(nd->nd_left->nd_type->tp_size);
}
} }
CheckAssign(tpl, tpr) CheckAssign(tpl, tpr)
@ -683,6 +736,7 @@ CodeOper(expr, true_label, false_label)
case T_INTEGER: case T_INTEGER:
C_cmi(tp->tp_size); C_cmi(tp->tp_size);
break; break;
case T_HIDDEN:
case T_POINTER: case T_POINTER:
C_cmp(); C_cmp();
break; break;
@ -904,12 +958,16 @@ CodeSet(nd)
CodeEl(nd, tp) CodeEl(nd, tp)
register struct node *nd; register struct node *nd;
struct type *tp; register struct type *tp;
{ {
if (nd->nd_class == Link && nd->nd_symb == UPTO) { if (nd->nd_class == Link && nd->nd_symb == UPTO) {
C_zer(tp->tp_size); /* empty set */ C_zer(tp->tp_size); /* empty set */
C_lor((arith) 1); /* SP: address of 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); Operands(nd->nd_left, nd->nd_right);
C_cal("_LtoUset"); /* library routine to fill set */ C_cal("_LtoUset"); /* library routine to fill set */
C_asp(2 * word_size + pointer_size); C_asp(2 * word_size + pointer_size);
@ -960,3 +1018,23 @@ CodeDStore(nd)
CodeDesig(nd, &designator); CodeDesig(nd, &designator);
CodeStore(&designator, nd->nd_type->tp_size); 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; expp->nd_symb = INTEGER;
switch(call) { switch(call) {
case S_ABS: 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; if (expr->nd_INT < 0) expp->nd_INT = - expr->nd_INT;
else expp->nd_INT = expr->nd_INT; else expp->nd_INT = expr->nd_INT;
CutSize(expp); CutSize(expp);

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

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

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

@ -30,7 +30,7 @@ struct def *ill_df;
struct def * struct def *
MkDef(id, scope, kind) MkDef(id, scope, kind)
struct idf *id; struct idf *id;
struct scope *scope; register struct scope *scope;
{ {
/* Create a new definition structure in scope "scope", with /* Create a new definition structure in scope "scope", with
id "id" and kind "kind". id "id" and kind "kind".
@ -55,7 +55,7 @@ MkDef(id, scope, kind)
InitDef() InitDef()
{ {
/* Initialize this module. Easy, the only thing to be initialized /* Initialize this module. Easy, the only thing to be initialized
is "illegal_def". is "ill_df".
*/ */
struct idf *gen_anon_idf(); struct idf *gen_anon_idf();
@ -83,6 +83,9 @@ define(id, scope, kind)
) { ) {
switch(df->df_kind) { switch(df->df_kind) {
case D_HIDDEN: case D_HIDDEN:
/* An opaque type. We may now have found the
definition of this type.
*/
if (kind == D_TYPE && !DefinitionModule) { if (kind == D_TYPE && !DefinitionModule) {
df->df_kind = D_TYPE; df->df_kind = D_TYPE;
return df; return df;
@ -90,6 +93,10 @@ define(id, scope, kind)
break; break;
case D_FORWMODULE: 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) { if (kind == D_FORWMODULE) {
return df; return df;
} }
@ -104,19 +111,27 @@ define(id, scope, kind)
break; break;
case D_FORWARD: case D_FORWARD:
/* A forward reference, for which we may now have
found a definition.
*/
if (kind != D_FORWARD) { if (kind != D_FORWARD) {
FreeNode(df->for_node); FreeNode(df->for_node);
} }
df->df_kind = kind; /* Fall through */
return df;
case D_ERROR: 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; df->df_kind = kind;
return df; return df;
} }
if (kind != D_ERROR) { if (kind != D_ERROR) {
/* Avoid spurious error messages
*/
error("identifier \"%s\" already declared", id->id_text); error("identifier \"%s\" already declared", id->id_text);
} }
@ -149,6 +164,8 @@ lookup(id, scope)
assert(retval != 0); assert(retval != 0);
} }
if (df1) { if (df1) {
/* Put the definition now found in front
*/
df1->next = df->next; df1->next = df->next;
df->next = id->id_def; df->next = id->id_def;
id->id_def = df; id->id_def = df;
@ -162,30 +179,34 @@ lookup(id, scope)
} }
DoImport(df, scope) DoImport(df, scope)
struct def *df; register struct def *df;
struct scope *scope; 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) { if (df->df_kind == D_TYPE && df->df_type->tp_fund == T_ENUMERATION) {
/* Also import all enumeration literals /* Also import all enumeration literals
*/ */
df1 = df->df_type->enm_enums; df = df->df_type->enm_enums;
while (df1) { while (df) {
define(df1->df_idf, scope, D_IMPORT)->imp_def = df1; define(df->df_idf, scope, D_IMPORT)->imp_def = df;
df1 = df1->enm_next; df = df->enm_next;
} }
} }
else if (df->df_kind == D_MODULE) { else if (df->df_kind == D_MODULE) {
/* Also import all definitions that are exported from this /* Also import all definitions that are exported from this
module module
*/ */
df1 = df->mod_vis->sc_scope->sc_def; df = df->mod_vis->sc_scope->sc_def;
while (df1) { while (df) {
if (df1->df_flags & D_EXPORTED) { if (df->df_flags & D_EXPORTED) {
define(df1->df_idf, scope, D_IMPORT)->imp_def = df1; 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)) { 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); df->df_idf->id_text);
} }
@ -225,6 +246,8 @@ df->df_idf->id_text);
Find all imports of the module in which this export Find all imports of the module in which this export
occurs, and export the current definition to it occurs, and export the current definition to it
*/ */
df->df_flags |= D_EXPORTED;
impmod = moddef->df_idf->id_def; impmod = moddef->df_idf->id_def;
while (impmod) { while (impmod) {
if (impmod->df_kind == D_IMPORT && if (impmod->df_kind == D_IMPORT &&
@ -234,7 +257,6 @@ df->df_idf->id_text);
impmod = impmod->next; impmod = impmod->next;
} }
df->df_flags |= D_EXPORTED;
df1 = lookup(ids->nd_IDF, enclosing(CurrVis)->sc_scope); df1 = lookup(ids->nd_IDF, enclosing(CurrVis)->sc_scope);
if (df1 && df1->df_kind == D_PROCHEAD) { if (df1 && df1->df_kind == D_PROCHEAD) {
if (df->df_kind == D_PROCEDURE) { 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); DoImport(df, enclosing(CurrVis)->sc_scope);
} }
} }
@ -283,7 +301,7 @@ ForwModule(df, idn)
closing this one closing this one
*/ */
df->for_vis = vis; 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); close_scope(0);
vis->sc_encl = enclosing(CurrVis); vis->sc_encl = enclosing(CurrVis);
/* Here ! */ /* Here ! */
@ -302,7 +320,7 @@ ForwDef(ids, scope)
if (!(df = lookup(ids->nd_IDF, scope))) { if (!(df = lookup(ids->nd_IDF, scope))) {
df = define(ids->nd_IDF, scope, D_FORWARD); 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; return df;
} }
@ -384,7 +402,6 @@ ids->nd_IDF->id_text);
else df = GetDefinitionModule(ids->nd_IDF); else df = GetDefinitionModule(ids->nd_IDF);
} }
define(ids->nd_IDF,CurrentScope,D_IMPORT)->imp_def = df;
DoImport(df, CurrentScope); DoImport(df, CurrentScope);
ids = ids->next; ids = ids->next;
@ -393,7 +410,7 @@ ids->nd_IDF->id_text);
FreeNode(idn); FreeNode(idn);
} }
RemImports(pdf) RemoveImports(pdf)
struct def **pdf; struct def **pdf;
{ {
/* Remove all imports from a definition module. This is /* Remove all imports from a definition module. This is
@ -404,7 +421,7 @@ RemImports(pdf)
while (df) { while (df) {
if (df->df_kind == D_IMPORT) { if (df->df_kind == D_IMPORT) {
RemFromId(df); RemoveFromIdList(df);
*pdf = df->df_nextinscope; *pdf = df->df_nextinscope;
free_def(df); free_def(df);
} }
@ -415,7 +432,7 @@ RemImports(pdf)
} }
} }
RemFromId(df) RemoveFromIdList(df)
struct def *df; struct def *df;
{ {
/* Remove definition "df" from the definition list /* Remove definition "df" from the definition list
@ -438,11 +455,11 @@ struct def *
DeclProc(type) DeclProc(type)
{ {
/* A procedure is declared, either in a definition or a program /* 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; register struct def *df;
static int nmcount = 0; static int nmcount = 0;
extern char *Malloc();
extern char *strcpy(); extern char *strcpy();
extern char *sprint(); extern char *sprint();
char buf[256]; char buf[256];
@ -453,7 +470,7 @@ DeclProc(type)
/* In a definition module /* In a definition module
*/ */
df = define(dot.TOK_IDF, CurrentScope, type); 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); sprint(buf,"%s_%s",CurrentScope->sc_name,df->df_idf->id_text);
df->for_name = Malloc((unsigned) (strlen(buf)+1)); df->for_name = Malloc((unsigned) (strlen(buf)+1));
strcpy(df->for_name, buf); strcpy(df->for_name, buf);
@ -512,12 +529,12 @@ AddModule(id)
register struct node *n; register struct node *n;
extern struct node *Modules; extern struct node *Modules;
n = MkNode(Name, NULLNODE, NULLNODE, &dot); n = MkLeaf(Name, &dot);
n->nd_IDF = id; n->nd_IDF = id;
n->nd_symb = IDENT; n->nd_symb = IDENT;
if (nd_end) nd_end->next = n; if (nd_end) nd_end->next = n;
else Modules = n;
nd_end = n; nd_end = n;
if (!Modules) Modules = n;
} }
DefInFront(df) DefInFront(df)
@ -528,14 +545,24 @@ DefInFront(df)
This is neccessary because in some cases the order in this This is neccessary because in some cases the order in this
list is important. list is important.
*/ */
register struct def *df1; register struct def *df1 = df->df_scope->sc_def;
if (df->df_scope->sc_def != df) { if (df1 != df) {
df1 = df->df_scope->sc_def; /* Definition "df" is not in front of the list
*/
while (df1 && df1->df_nextinscope != df) { while (df1 && df1->df_nextinscope != df) {
/* Find definition "df"
*/
df1 = df1->df_nextinscope; 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_nextinscope = df->df_scope->sc_def;
df->df_scope->sc_def = df; 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 /* value or var parameter
*/ */
C_lxa((arith) (proclevel - sc->sc_level)); 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 /* var parameter
*/ */
C_adp(df->var_off); C_adp(df->var_off);
@ -287,7 +288,7 @@ CodeVarDesig(df, ds)
/* Now, finally, we have a local variable or a local parameter /* 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. /* a var parameter; address directly accessible.
*/ */
ds->dsg_kind = DSG_PFIXED; ds->dsg_kind = DSG_PFIXED;
@ -303,10 +304,11 @@ CodeDesig(nd, ds)
/* Generate code for a designator. Use divide and conquer /* Generate code for a designator. Use divide and conquer
principle principle
*/ */
register struct def *df;
switch(nd->nd_class) { /* Divide */ switch(nd->nd_class) { /* Divide */
case Def: { case Def:
register struct def *df = nd->nd_def; df = nd->nd_def;
df->df_flags |= D_USED; df->df_flags |= D_USED;
switch(df->df_kind) { switch(df->df_kind) {
@ -321,7 +323,6 @@ CodeDesig(nd, ds)
default: default:
crash("(CodeDesig) Def"); crash("(CodeDesig) Def");
} }
}
break; break;
case Link: case Link:
@ -336,18 +337,24 @@ CodeDesig(nd, ds)
CodeDesig(nd->nd_left, ds); CodeDesig(nd->nd_left, ds);
CodeAddress(ds); CodeAddress(ds);
*ds = InitDesig; CodePExpr(nd->nd_right);
CodeExpr(nd->nd_right, ds, NO_LABEL, NO_LABEL);
CodeValue(ds, nd->nd_right->nd_type->tp_size);
if (nd->nd_right->nd_type->tp_size > word_size) { if (nd->nd_right->nd_type->tp_size > word_size) {
CodeCoercion(nd->nd_right->nd_type, int_type); CodeCoercion(nd->nd_right->nd_type, int_type);
} }
/* Now load address of descriptor
*/
if (IsConformantArray(nd->nd_left->nd_type)) { 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 { else {
/* load address of descriptor
*/
C_lae_dlb(nd->nd_left->nd_type->arr_descr, (arith) 0); C_lae_dlb(nd->nd_left->nd_type->arr_descr, (arith) 0);
} }
ds->dsg_kind = DSG_INDEXED; ds->dsg_kind = DSG_INDEXED;

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

@ -26,21 +26,24 @@ number(struct node **p;)
} : } :
[ [
%default %default
INTEGER { tp = numtype; } INTEGER { tp = toktype; }
| |
REAL { tp = real_type; } REAL { tp = real_type; }
] { *p = MkNode(Value, NULLNODE, NULLNODE, &dot); ] { *p = MkLeaf(Value, &dot);
(*p)->nd_type = tp; (*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; register struct def *df;
struct node *nd; struct node *nd;
} : } :
IDENT { nd = MkNode(Name, NULLNODE, NULLNODE, &dot); IDENT { nd = MkLeaf(Name, &dot); }
}
[ [
selector(&nd) selector(&nd)
]* ]*
@ -84,7 +87,7 @@ ExpList(struct node **pnd;)
nd = &((*pnd)->nd_right); nd = &((*pnd)->nd_right);
} }
[ [
',' { *nd = MkNode(Link, NULLNODE, NULLNODE, &dot); ',' { *nd = MkLeaf(Link, &dot);
} }
expression(&(*nd)->nd_left) expression(&(*nd)->nd_left)
{ nd = &((*nd)->nd_right); } { 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); pnd = &((*pnd)->nd_right);
} }
]? ]?
@ -191,23 +194,13 @@ factor(struct node **p;)
number(p) number(p)
| |
STRING { STRING {
*p = MkNode(Value, NULLNODE, NULLNODE, &dot); *p = MkLeaf(Value, &dot);
if (dot.TOK_SLE == 1) { (*p)->nd_type = toktype;
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;
} }
| |
'(' expression(p) ')' '(' expression(p) ')'
| |
NOT { *p = MkNode(Uoper, NULLNODE, NULLNODE, &dot); } NOT { *p = MkLeaf(Uoper, &dot); }
factor(&((*p)->nd_right)) factor(&((*p)->nd_right))
; ;
@ -217,7 +210,7 @@ bare_set(struct node **pnd;)
} : } :
'{' { '{' {
dot.tk_symb = SET; dot.tk_symb = SET;
*pnd = nd = MkNode(Xset, NULLNODE, NULLNODE, &dot); *pnd = nd = MkLeaf(Xset, &dot);
nd->nd_type = bitset_type; nd->nd_type = bitset_type;
} }
[ [

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

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

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

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

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

@ -39,6 +39,19 @@ MkNode(class, left, right, token)
return nd; 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) FreeNode(nd)
register struct node *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 "type.h"
#include "node.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 The grammar as given by Wirth is already almost LL(1); the
@ -132,7 +127,7 @@ import(int local;)
struct node *id = 0; struct node *id = 0;
} : } :
[ FROM [ FROM
IDENT { id = MkNode(Value, NULLNODE, NULLNODE, &dot); } IDENT { id = MkLeaf(Value, &dot); }
]? ]?
IMPORT IdentList(&ImportList) ';' IMPORT IdentList(&ImportList) ';'
/* /*
@ -176,12 +171,6 @@ DefinitionModule
*/ */
definition* END IDENT definition* END IDENT
{ {
if (DEFofIMPL) {
/* Just read the definition module of the
implementation module being compiled
*/
RemImports(&(CurrentScope->sc_def));
}
df = CurrentScope->sc_def; df = CurrentScope->sc_def;
while (df) { while (df) {
/* Make all definitions "QUALIFIED EXPORT" */ /* Make all definitions "QUALIFIED EXPORT" */
@ -211,7 +200,7 @@ definition
It is restricted to pointer types. It is restricted to pointer types.
*/ */
{ df->df_kind = D_HIDDEN; { df->df_kind = D_HIDDEN;
df->df_type = construct_type(T_POINTER, NULLTYPE); df->df_type = construct_type(T_HIDDEN, NULLTYPE);
} }
] ]
Semicolon Semicolon
@ -239,11 +228,10 @@ ProgramModule
IDENT { IDENT {
id = dot.TOK_IDF; id = dot.TOK_IDF;
if (state == IMPLEMENTATION) { if (state == IMPLEMENTATION) {
DEFofIMPL = 1;
df = GetDefinitionModule(id); df = GetDefinitionModule(id);
CurrVis = df->mod_vis; CurrVis = df->mod_vis;
CurrentScope = CurrVis->sc_scope; CurrentScope = CurrVis->sc_scope;
DEFofIMPL = 0; RemoveImports(&(CurrentScope->sc_def));
} }
else { else {
df = define(id, CurrentScope, D_MODULE); 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 */ static int loopcount = 0; /* Count nested loops */
} }
statement(struct node **pnd;) statement(register struct node **pnd;)
{ {
register struct node *nd; register struct node *nd;
} : } :
{ *pnd = 0; }
[ [
/* /*
* This part is not in the reference grammar. The reference grammar * This part is not in the reference grammar. The reference grammar
@ -61,11 +60,13 @@ statement(struct node **pnd;)
| |
EXIT EXIT
{ if (!loopcount) error("EXIT not in a LOOP"); { if (!loopcount) error("EXIT not in a LOOP");
*pnd = MkNode(Stat, NULLNODE, NULLNODE, &dot); *pnd = MkLeaf(Stat, &dot);
} }
| |
ReturnStatement(pnd) ReturnStatement(pnd)
]? |
/* empty */ { *pnd = 0; }
]
; ;
/* /*
@ -80,7 +81,9 @@ ProcedureCall:
; ;
*/ */
StatementSequence(struct node **pnd;): StatementSequence(register struct node **pnd;)
{
} :
statement(pnd) statement(pnd)
[ [
';' { *pnd = MkNode(Link, *pnd, NULLNODE, &dot); ';' { *pnd = MkNode(Link, *pnd, NULLNODE, &dot);
@ -94,21 +97,21 @@ IfStatement(struct node **pnd;)
{ {
register struct node *nd; register struct node *nd;
} : } :
IF { nd = MkNode(Stat, NULLNODE, NULLNODE, &dot); IF { nd = MkLeaf(Stat, &dot);
*pnd = nd; *pnd = nd;
} }
expression(&(nd->nd_left)) expression(&(nd->nd_left))
THEN { nd = MkNode(Link, NULLNODE, NULLNODE, &dot); THEN { nd->nd_right = MkLeaf(Link, &dot);
(*pnd)->nd_right = nd; nd = nd->nd_right;
} }
StatementSequence(&(nd->nd_left)) 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->nd_right;
nd->nd_symb = IF; nd->nd_symb = IF;
} }
expression(&(nd->nd_left)) expression(&(nd->nd_left))
THEN { nd->nd_right = MkNode(Link,NULLNODE,NULLNODE,&dot); THEN { nd->nd_right = MkLeaf(Link, &dot);
nd = nd->nd_right; nd = nd->nd_right;
} }
StatementSequence(&(nd->nd_left)) StatementSequence(&(nd->nd_left))
@ -125,7 +128,7 @@ CaseStatement(struct node **pnd;)
register struct node *nd; register struct node *nd;
struct type *tp = 0; struct type *tp = 0;
} : } :
CASE { *pnd = nd = MkNode(Stat, NULLNODE, NULLNODE, &dot); } CASE { *pnd = nd = MkLeaf(Stat, &dot); }
expression(&(nd->nd_left)) expression(&(nd->nd_left))
OF OF
case(&(nd->nd_right), &tp) case(&(nd->nd_right), &tp)
@ -140,12 +143,10 @@ CaseStatement(struct node **pnd;)
; ;
case(struct node **pnd; struct type **ptp;) : case(struct node **pnd; struct type **ptp;) :
{ *pnd = 0; }
[ CaseLabelList(ptp, pnd) [ CaseLabelList(ptp, pnd)
':' { *pnd = MkNode(Link, *pnd, NULLNODE, &dot); } ':' { *pnd = MkNode(Link, *pnd, NULLNODE, &dot); }
StatementSequence(&((*pnd)->nd_right)) StatementSequence(&((*pnd)->nd_right))
]? ]?
/* This rule is changed in new modula-2 */
{ *pnd = MkNode(Link, *pnd, NULLNODE, &dot); { *pnd = MkNode(Link, *pnd, NULLNODE, &dot);
(*pnd)->nd_symb = '|'; (*pnd)->nd_symb = '|';
} }
@ -155,7 +156,7 @@ WhileStatement(struct node **pnd;)
{ {
register struct node *nd; register struct node *nd;
}: }:
WHILE { *pnd = nd = MkNode(Stat, NULLNODE, NULLNODE, &dot); } WHILE { *pnd = nd = MkLeaf(Stat, &dot); }
expression(&(nd->nd_left)) expression(&(nd->nd_left))
DO DO
StatementSequence(&(nd->nd_right)) StatementSequence(&(nd->nd_right))
@ -166,7 +167,7 @@ RepeatStatement(struct node **pnd;)
{ {
register struct node *nd; register struct node *nd;
}: }:
REPEAT { *pnd = nd = MkNode(Stat, NULLNODE, NULLNODE, &dot); } REPEAT { *pnd = nd = MkLeaf(Stat, &dot); }
StatementSequence(&(nd->nd_left)) StatementSequence(&(nd->nd_left))
UNTIL UNTIL
expression(&(nd->nd_right)) expression(&(nd->nd_right))
@ -177,10 +178,10 @@ ForStatement(struct node **pnd;)
register struct node *nd; register struct node *nd;
struct node *dummy; struct node *dummy;
}: }:
FOR { *pnd = MkNode(Stat, NULLNODE, NULLNODE, &dot); } FOR { *pnd = nd = MkLeaf(Stat, &dot); }
IDENT { (*pnd)->nd_IDF = dot.TOK_IDF; } IDENT { nd->nd_IDF = dot.TOK_IDF; }
BECOMES { nd = MkNode(Stat, NULLNODE, NULLNODE, &dot); BECOMES { nd->nd_left = MkLeaf(Stat, &dot);
(*pnd)->nd_left = nd; nd = nd->nd_left;
} }
expression(&(nd->nd_left)) expression(&(nd->nd_left))
TO TO
@ -204,7 +205,7 @@ ForStatement(struct node **pnd;)
; ;
LoopStatement(struct node **pnd;): LoopStatement(struct node **pnd;):
LOOP { *pnd = MkNode(Stat, NULLNODE, NULLNODE, &dot); } LOOP { *pnd = MkLeaf(Stat, &dot); }
StatementSequence(&((*pnd)->nd_right)) StatementSequence(&((*pnd)->nd_right))
END END
; ;
@ -213,7 +214,7 @@ WithStatement(struct node **pnd;)
{ {
register struct node *nd; register struct node *nd;
}: }:
WITH { *pnd = nd = MkNode(Stat, NULLNODE, NULLNODE, &dot); } WITH { *pnd = nd = MkLeaf(Stat, &dot); }
designator(&(nd->nd_left)) designator(&(nd->nd_left))
DO DO
StatementSequence(&(nd->nd_right)) StatementSequence(&(nd->nd_right))
@ -226,7 +227,7 @@ ReturnStatement(struct node **pnd;)
register struct node *nd; register struct node *nd;
} : } :
RETURN { *pnd = nd = MkNode(Stat, NULLNODE, NULLNODE, &dot); } RETURN { *pnd = nd = MkLeaf(Stat, &dot); }
[ [
expression(&(nd->nd_right)) expression(&(nd->nd_right))
{ if (scopeclosed(CurrentScope)) { { if (scopeclosed(CurrentScope)) {

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

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

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

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

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

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