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

newer version

Browse source
This commit is contained in:
ceriel 1986-06-06 02:22:09 +00:00
parent db258b68ea
commit caf99ea472
17 changed files with 224 additions and 301 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -29,7 +29,6 @@ struct token dot, aside;
struct type *toktype; struct type *toktype;
struct string string; struct string string;
int idfsize = IDFSIZE; int idfsize = IDFSIZE;
extern label data_label();
static static
SkipComment() SkipComment()
@ -51,21 +50,15 @@ SkipComment()
if (ch == '*') { if (ch == '*') {
++NestLevel; ++NestLevel;
} }
else { else continue;
continue;
}
} }
else else
if (ch == '*') { if (ch == '*') {
LoadChar(ch); LoadChar(ch);
if (ch == ')') { if (ch == ')') {
if (NestLevel-- == 0) { if (NestLevel-- == 0) return;
return;
}
}
else {
continue;
} }
else continue;
} }
LoadChar(ch); LoadChar(ch);
} }
@ -198,7 +191,7 @@ again:
return tk->tk_symb = ch; return tk->tk_symb = ch;
default : default :
assert(0); crash("(LLlex, STCOMP)");
} }
case STIDF: case STIDF:
@ -216,7 +209,6 @@ again:
*tg++ = '\0'; *tg++ = '\0';
tk->TOK_IDF = id = str2idf(buf, 1); tk->TOK_IDF = id = str2idf(buf, 1);
if (!id) fatal("Out of memory");
return tk->tk_symb = id->id_reserved ? id->id_reserved : IDENT; return tk->tk_symb = id->id_reserved ? id->id_reserved : IDENT;
} }
@ -413,7 +405,7 @@ Sdec:
case STCHAR: case STCHAR:
default: default:
assert(0); crash("(LLlex) Impossible character class");
} }
/*NOTREACHED*/ /*NOTREACHED*/
} }

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

@ -68,15 +68,34 @@ chk_expr(expp)
case Xset: case Xset:
return chk_set(expp); return chk_set(expp);
case Link:
case Name: case Name:
return chk_designator(expp, VALUE, D_USED); if (chk_designator(expp, VALUE|DESIGNATOR, D_USED)) {
if (expp->nd_class == Def &&
expp->nd_def->df_kind == D_PROCEDURE) {
/* Check that this procedure is one that we
may take the address from.
*/
if (expp->nd_def->df_type == std_type) {
/* Standard procedure. Illegal */
node_error(expp, "address of standard procedure taken");
return 0;
}
if (expp->nd_def->df_scope->sc_level > 0) {
/* Address of nested procedure taken.
Illegal.
*/
node_error(expp, "address of a procedure local to another one taken");
return 0;
}
}
return 1;
}
return 0;
case Call: case Call:
return chk_call(expp); return chk_call(expp);
case Link:
return chk_designator(expp, DESIGNATOR|VALUE, D_USED|D_NOREG);
default: default:
crash("(chk_expr)"); crash("(chk_expr)");
} }
@ -312,7 +331,6 @@ chk_call(expp)
it may also be a cast or a standard procedure call. it may also be a cast or a standard procedure call.
*/ */
register struct node *left; register struct node *left;
register struct node *arg;
/* First, get the name of the function or procedure /* First, get the name of the function or procedure
*/ */
@ -340,7 +358,8 @@ chk_call(expp)
*/ */
return chk_proccall(expp); return chk_proccall(expp);
} }
node_error(expp->nd_left, "procedure, type, or function expected");
node_error(left, "procedure, type, or function expected");
return 0; return 0;
} }
@ -420,7 +439,7 @@ FlagCheck(expp, df, flag)
} }
if ((flag & VALUE) && if ((flag & VALUE) &&
( !(df->df_kind & (D_VARIABLE|D_FIELD|D_CONST|D_ENUM)))) { ( !(df->df_kind & (D_VARIABLE|D_FIELD|D_CONST|D_ENUM|D_PROCEDURE)))) {
node_error(expp, "value expected"); node_error(expp, "value expected");
return 0; return 0;
} }
@ -584,6 +603,62 @@ symbol2str(expp->nd_symb));
return 0; return 0;
} }
struct type *
ResultOfOperation(operator, tp)
struct type *tp;
{
switch(operator) {
case '=':
case '#':
case GREATEREQUAL:
case LESSEQUAL:
case '<':
case '>':
case IN:
return bool_type;
}
return tp;
}
int
Boolean(operator)
{
return operator == OR || operator == AND || operator == '&';
}
int
AllowedTypes(operator)
{
switch(operator) {
case '+':
case '-':
case '*':
return T_NUMERIC|T_SET;
case '/':
return T_REAL|T_SET;
case DIV:
case MOD:
return T_INTORCARD;
case OR:
case AND:
case '&':
return T_ENUMERATION;
case '=':
case '#':
return T_POINTER|T_HIDDEN|T_SET|T_NUMERIC|T_ENUMERATION|T_CHAR;
case GREATEREQUAL:
case LESSEQUAL:
return T_SET|T_NUMERIC|T_CHAR|T_ENUMERATION;
case '<':
case '>':
return T_NUMERIC|T_CHAR|T_ENUMERATION;
default:
crash("(AllowedTypes)");
}
/*NOTREACHED*/
}
int int
chk_oper(expp) chk_oper(expp)
register struct node *expp; register struct node *expp;
@ -594,7 +669,10 @@ chk_oper(expp)
register struct node *right = expp->nd_right; register struct node *right = expp->nd_right;
struct type *tpl = left->nd_type; struct type *tpl = left->nd_type;
struct type *tpr = right->nd_type; struct type *tpr = right->nd_type;
int errval = 1; int allowed;
if (tpl->tp_fund == T_SUBRANGE) tpl = tpl->next;
if (tpr->tp_fund == T_SUBRANGE) tpr = tpr->next;
if (tpl == intorcard_type) { if (tpl == intorcard_type) {
if (tpr == int_type || tpr == card_type) { if (tpr == int_type || tpr == card_type) {
@ -606,11 +684,11 @@ chk_oper(expp)
right->nd_type = tpr = tpl; right->nd_type = tpr = tpl;
} }
} }
expp->nd_type = error_type;
expp->nd_type = ResultOfOperation(expp->nd_symb, tpl);
if (expp->nd_symb == IN) { if (expp->nd_symb == IN) {
/* Handle this one specially */ /* Handle this one specially */
expp->nd_type = bool_type;
if (tpr->tp_fund != T_SET) { if (tpr->tp_fund != T_SET) {
node_error(expp, "RHS of IN operator not a SET type"); node_error(expp, "RHS of IN operator not a SET type");
return 0; return 0;
@ -630,9 +708,6 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
return 1; return 1;
} }
if (tpl->tp_fund == T_SUBRANGE) tpl = tpl->next;
expp->nd_type = tpl;
/* Operands must be compatible (distilled from Def 8.2) /* Operands must be compatible (distilled from Def 8.2)
*/ */
if (!TstCompat(tpl, tpr)) { if (!TstCompat(tpl, tpr)) {
@ -641,128 +716,28 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
return 0; return 0;
} }
switch(expp->nd_symb) { allowed = AllowedTypes(expp->nd_symb);
case '+': if (!(tpl->tp_fund & allowed) ||
case '-': (tpl != bool_type && Boolean(expp->nd_symb))) {
case '*': if (!(tpl->tp_fund == T_POINTER &&
switch(tpl->tp_fund) { (T_CARDINAL & allowed) &&
case T_POINTER: chk_address(tpl, tpr))) {
if (! chk_address(tpl, tpr)) break; node_error(expp,"operator \"%s\": illegal operand type(s)", symbol2str(expp->nd_symb));
/* Fall through */
case T_INTEGER:
case T_CARDINAL:
case T_INTORCARD:
if (left->nd_class==Value && right->nd_class==Value) {
cstbin(expp);
}
return 1;
case T_SET:
if (left->nd_class == Set && right->nd_class == Set) {
cstset(expp);
}
/* Fall through */
case T_REAL:
return 1;
}
break;
case '/':
switch(tpl->tp_fund) {
case T_SET:
if (left->nd_class == Set && right->nd_class == Set) {
cstset(expp);
}
/* Fall through */
case T_REAL:
return 1;
}
break;
case DIV:
case MOD:
switch(tpl->tp_fund) {
case T_POINTER:
if (! chk_address(tpl, tpr)) break;
/* Fall through */
case T_INTEGER:
case T_CARDINAL:
case T_INTORCARD:
if (left->nd_class==Value && right->nd_class==Value) {
cstbin(expp);
}
return 1;
}
break;
case OR:
case AND:
case '&':
if (tpl == bool_type) {
if (left->nd_class==Value && right->nd_class==Value) {
cstbin(expp);
}
return 1;
}
errval = 3;
break;
case '=':
case '#':
case GREATEREQUAL:
case LESSEQUAL:
case '<':
case '>':
expp->nd_type = bool_type;
switch(tpl->tp_fund) {
case T_SET:
if (expp->nd_symb == '<' || expp->nd_symb == '>') {
break;
}
if (left->nd_class == Set && right->nd_class == Set) {
cstset(expp);
}
return 1;
case T_INTEGER:
case T_CARDINAL:
case T_ENUMERATION: /* includes boolean */
case T_CHAR:
case T_INTORCARD:
if (left->nd_class==Value && right->nd_class==Value) {
cstbin(expp);
}
return 1;
case T_HIDDEN:
case T_POINTER:
if (chk_address(tpl, tpr) ||
expp->nd_symb == '=' ||
expp->nd_symb == '#') return 1;
break;
case T_REAL:
return 1;
}
default:
assert(0);
}
switch(errval) {
case 1:
node_error(expp,"operator \"%s\": illegal operand type(s)", symbol2str(expp->nd_symb));
break;
case 3:
node_error(expp, "BOOLEAN type(s) expected");
break;
default:
assert(0);
}
return 0; return 0;
}
}
if (tpl->tp_fund == T_SET) {
if (left->nd_class == Set && right->nd_class == Set) {
cstset(expp);
}
}
else if ( tpl->tp_fund != T_REAL &&
left->nd_class == Value && right->nd_class == Value) {
cstbin(expp);
}
return 1;
} }
int int

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

@ -27,6 +27,7 @@ extern label text_label();
extern char *long2str(); extern char *long2str();
extern char *symbol2str(); extern char *symbol2str();
extern int proclevel; extern int proclevel;
int fp_used;
CodeConst(cst, size) CodeConst(cst, size)
arith cst, size; arith cst, size;
@ -43,7 +44,7 @@ CodeConst(cst, size)
} }
else { else {
C_df_dlb(dlab = data_label()); C_df_dlb(dlab = data_label());
C_rom_icon(long2str((long) cst), 10); C_rom_icon(long2str((long) cst), size);
C_lae_dlb(dlab, (arith) 0); C_lae_dlb(dlab, (arith) 0);
C_loi(size); C_loi(size);
} }
@ -59,7 +60,7 @@ CodeString(nd)
} }
else { else {
C_df_dlb(lab = data_label()); C_df_dlb(lab = data_label());
C_rom_scon(nd->nd_STR, align(nd->nd_SLE + 1, word_size)); C_rom_scon(nd->nd_STR, align(nd->nd_SLE + 1, (int) word_size));
C_lae_dlb(lab, (arith) 0); C_lae_dlb(lab, (arith) 0);
} }
} }
@ -80,11 +81,8 @@ CodePadString(nd, sz)
assert(sizearg < sz); assert(sizearg < sz);
C_zer(sz - sizearg); C_zer(sz - sizearg);
} }
C_asp(-sizearg); /* room for string */
CodeString(nd); /* push address of string */ CodeString(nd); /* push address of string */
C_lor((arith) 1); /* load stack pointer */ C_loi(sizearg);
C_adp(pointer_size); /* and compute target address from it */
C_blm(sizearg); /* and copy */
} }
CodeReal(nd) CodeReal(nd)
@ -103,7 +101,9 @@ CodeExpr(nd, ds, true_label, false_label)
register struct desig *ds; register struct desig *ds;
label true_label, false_label; label true_label, false_label;
{ {
register struct type *tp = nd->nd_type;
if (tp->tp_fund == T_REAL) fp_used = 1;
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) {
@ -147,7 +147,7 @@ CodeExpr(nd, ds, true_label, false_label)
CodeString(nd); CodeString(nd);
break; break;
case INTEGER: case INTEGER:
CodeConst(nd->nd_INT, nd->nd_type->tp_size); CodeConst(nd->nd_INT, tp->tp_size);
break; break;
default: default:
crash("Value error"); crash("Value error");
@ -167,12 +167,10 @@ CodeExpr(nd, ds, true_label, false_label)
st = nd->nd_set; st = nd->nd_set;
ds->dsg_kind = DSG_LOADED; ds->dsg_kind = DSG_LOADED;
if (!st) { if (!st) {
C_zer(nd->nd_type->tp_size); C_zer(tp->tp_size);
break; break;
} }
for (i = nd->nd_type->tp_size / word_size, st += i; for (i = tp->tp_size / word_size, st += i; i > 0; i--) {
i > 0;
i--) {
C_loc(*--st); C_loc(*--st);
} }
} }
@ -188,7 +186,7 @@ CodeExpr(nd, ds, true_label, false_label)
} }
if (true_label != 0) { if (true_label != 0) {
CodeValue(ds, nd->nd_type->tp_size); CodeValue(ds, tp->tp_size);
*ds = InitDesig; *ds = InitDesig;
C_zne(true_label); C_zne(true_label);
C_bra(false_label); C_bra(false_label);
@ -250,12 +248,12 @@ CodeCoercion(t1, t2)
} }
break; break;
case T_INTEGER: case T_INTEGER:
C_loc(t1->tp_size); C_loc(word_size);
C_loc(t2->tp_size); C_loc(t2->tp_size);
C_cui(); C_cui();
break; break;
case T_REAL: case T_REAL:
C_loc(t1->tp_size); C_loc(word_size);
C_loc(t2->tp_size); C_loc(t2->tp_size);
C_cuf(); C_cuf();
break; break;
@ -322,41 +320,44 @@ CodeCall(nd)
tp = TypeOfParam(param); tp = TypeOfParam(param);
arg = arg->nd_right; arg = arg->nd_right;
assert(arg != 0); assert(arg != 0);
left = arg->nd_left;
if (IsConformantArray(tp)) { if (IsConformantArray(tp)) {
C_loc(tp->arr_elsize); C_loc(tp->arr_elsize);
if (IsConformantArray(arg->nd_left->nd_type)) { if (IsConformantArray(left->nd_type)) {
DoHIGH(arg->nd_left); DoHIGH(left);
} }
else if (arg->nd_left->nd_symb == STRING) { else if (left->nd_symb == STRING) {
C_loc(arg->nd_left->nd_SLE); C_loc(left->nd_SLE);
} }
else if (tp->arr_elem == word_type) { else if (tp->arr_elem == word_type) {
C_loc(arg->nd_left->nd_type->tp_size / word_size - 1); C_loc(left->nd_type->tp_size / word_size - 1);
} }
else C_loc(arg->nd_left->nd_type->tp_size / else C_loc(left->nd_type->tp_size /
tp->arr_elsize - 1); tp->arr_elsize - 1);
C_loc(0); C_loc((arith) 0);
if (arg->nd_left->nd_symb == STRING) { if (left->nd_symb == STRING) {
CodeString(arg->nd_left); CodeString(left);
} }
else CodeDAddress(arg->nd_left); else CodeDAddress(left);
pushed += pointer_size + 3 * word_size; pushed += pointer_size + 3 * word_size;
} }
else if (IsVarParam(param)) { else if (IsVarParam(param)) {
CodeDAddress(arg->nd_left); CodeDAddress(left);
pushed += pointer_size; pushed += pointer_size;
} }
else { else {
if (arg->nd_left->nd_type->tp_fund == T_STRING) { if (left->nd_type->tp_fund == T_STRING) {
CodePadString(arg->nd_left, CodePadString(left,
align(tp->tp_size, word_align)); align(tp->tp_size, word_align));
} }
else CodePExpr(arg->nd_left); else CodePExpr(left);
CheckAssign(arg->nd_left->nd_type, tp); CheckAssign(left->nd_type, tp);
pushed += align(tp->tp_size, word_align); pushed += align(tp->tp_size, word_align);
} }
} }
left = nd->nd_left;
if (left->nd_class == Def && left->nd_def->df_kind == D_PROCEDURE) { if (left->nd_class == Def && left->nd_def->df_kind == D_PROCEDURE) {
if (left->nd_def->df_scope->sc_level > 0) { if (left->nd_def->df_scope->sc_level > 0) {
C_lxl((arith) proclevel - left->nd_def->df_scope->sc_level); C_lxl((arith) proclevel - left->nd_def->df_scope->sc_level);
@ -944,15 +945,13 @@ CodeSet(nd)
{ {
struct type *tp = nd->nd_type; struct type *tp = nd->nd_type;
C_zer(nd->nd_type->tp_size); /* empty set */
nd = nd->nd_right; nd = nd->nd_right;
while (nd) { while (nd) {
assert(nd->nd_class == Link && nd->nd_symb == ','); assert(nd->nd_class == Link && nd->nd_symb == ',');
CodeEl(nd->nd_left, tp); CodeEl(nd->nd_left, tp);
nd = nd->nd_right; nd = nd->nd_right;
if (nd) {
C_ior(tp->tp_size);
}
} }
} }
@ -962,19 +961,19 @@ CodeEl(nd, 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_loc(tp->tp_size); /* push size */
C_lor((arith) 1); /* SP: address of set */
if (tp->next->tp_fund == T_SUBRANGE) { if (tp->next->tp_fund == T_SUBRANGE) {
C_loc(tp->next->sub_ub); C_loc(tp->next->sub_ub);
} }
else C_loc(tp->next->enm_ncst - 1); else C_loc((arith) (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(4 * word_size);
} }
else { else {
CodePExpr(nd); CodePExpr(nd);
C_set(tp->tp_size); C_set(tp->tp_size);
C_ior(tp->tp_size);
} }
} }

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

@ -39,6 +39,9 @@ cstunary(expp)
break; break;
case '-': case '-':
o1 = -o1; o1 = -o1;
if (expp->nd_type->tp_fund == T_INTORCARD) {
expp->nd_type = int_type;
}
break; break;
case NOT: case NOT:
case '~': case '~':
@ -149,6 +152,9 @@ cstbin(expp)
case '-': case '-':
o1 -= o2; o1 -= o2;
if (expp->nd_type->tp_fund == T_INTORCARD) {
if (o1 < 0) expp->nd_type = int_type;
}
break; break;
case '<': case '<':

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

@ -22,7 +22,6 @@ static char *RcsId = "$Header$";
#include "main.h" #include "main.h"
int proclevel = 0; /* nesting level of procedures */ int proclevel = 0; /* nesting level of procedures */
extern char *sprint();
} }
ProcedureDeclaration ProcedureDeclaration
@ -566,23 +565,22 @@ ConstantDeclaration
VariableDeclaration VariableDeclaration
{ {
struct node *VarList; struct node *VarList;
register struct node *nd;
struct type *tp; struct type *tp;
} : } :
IdentAddrList(&VarList) IdentAddr(&VarList)
{ nd = VarList; }
[
',' IdentAddr(&(nd->nd_right))
{ nd = nd->nd_right; }
]*
':' type(&tp) ':' type(&tp)
{ EnterVarList(VarList, tp, proclevel > 0); { EnterVarList(VarList, tp, proclevel > 0);
FreeNode(VarList); FreeNode(VarList);
} }
; ;
IdentAddrList(struct node **pnd;) IdentAddr(struct node **pnd;) :
{
} :
IDENT { *pnd = MkLeaf(Name, &dot); } IDENT { *pnd = MkLeaf(Name, &dot); }
ConstExpression(&(*pnd)->nd_left)? ConstExpression(&((*pnd)->nd_left))?
[ { pnd = &((*pnd)->nd_right); }
',' IDENT
{ *pnd = MkLeaf(Name, &dot); }
ConstExpression(&(*pnd)->nd_left)?
]*
; ;

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

@ -390,11 +390,12 @@ idn->nd_IDF->id_text);
else if (!(df = lookup(ids->nd_IDF, vis->sc_scope))) { else if (!(df = lookup(ids->nd_IDF, vis->sc_scope))) {
node_error(ids, "identifier \"%s\" not declared in qualifying module", node_error(ids, "identifier \"%s\" not declared in qualifying module",
ids->nd_IDF->id_text); ids->nd_IDF->id_text);
df = ill_df; df = define(ids->nd_IDF,vis->sc_scope,D_ERROR);
} }
else if (!(df->df_flags&(D_EXPORTED|D_QEXPORTED))) { else if (!(df->df_flags&(D_EXPORTED|D_QEXPORTED))) {
node_error(ids,"identifier \"%s\" not exported from qualifying module", node_error(ids,"identifier \"%s\" not exported from qualifying module",
ids->nd_IDF->id_text); ids->nd_IDF->id_text);
df->df_flags |= D_QEXPORTED;
} }
} }
else { else {
@ -459,9 +460,8 @@ DeclProc(type)
Also create a name for it. Also create a name for it.
*/ */
register struct def *df; register struct def *df;
static int nmcount = 0;
extern char *strcpy();
extern char *sprint(); extern char *sprint();
static int nmcount;
char buf[256]; char buf[256];
assert(type & (D_PROCEDURE | D_PROCHEAD)); assert(type & (D_PROCEDURE | D_PROCHEAD));
@ -472,8 +472,7 @@ DeclProc(type)
df = define(dot.TOK_IDF, CurrentScope, type); df = define(dot.TOK_IDF, CurrentScope, type);
df->for_node = MkLeaf(Name, &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 = Salloc(buf, (unsigned) (strlen(buf)+1));
strcpy(df->for_name, buf);
C_exp(df->for_name); C_exp(df->for_name);
open_scope(OPENSCOPE); open_scope(OPENSCOPE);
} }
@ -491,16 +490,11 @@ DeclProc(type)
} }
else { else {
df = define(dot.TOK_IDF, CurrentScope, type); df = define(dot.TOK_IDF, CurrentScope, type);
if (CurrVis != Defined->mod_vis) {
sprint(buf, "_%d_%s", ++nmcount,
df->df_idf->id_text);
}
else sprint(buf, "%s_%s",CurrentScope->sc_name,
df->df_idf->id_text);
open_scope(OPENSCOPE); open_scope(OPENSCOPE);
df->prc_vis = CurrVis; df->prc_vis = CurrVis;
CurrentScope->sc_name = Malloc((unsigned)(strlen(buf)+1)); sprint(buf,"_%d_%s",++nmcount,df->df_idf->id_text);
strcpy(CurrentScope->sc_name, buf); CurrentScope->sc_name =
Salloc(buf, (unsigned)(strlen(buf)+1));
C_inp(buf); C_inp(buf);
} }
} }

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

@ -31,11 +31,9 @@ GetFile(name)
char buf[256]; char buf[256];
char *strcpy(), *strcat(); char *strcpy(), *strcat();
(void) strcpy(buf, name); strcpy(buf, name);
if (strlen(buf) > 10) { buf[10] = '\0'; /* maximum length */
(void) strcpy(&buf[10], ".def"); strcat(buf, ".def");
}
else (void) strcat(buf, ".def");
if (! InsertFile(buf, DEFPATH, &(FileName))) { if (! InsertFile(buf, DEFPATH, &(FileName))) {
fatal("Could'nt find a DEFINITION MODULE for \"%s\"", name); fatal("Could'nt find a DEFINITION MODULE for \"%s\"", name);
} }
@ -80,11 +78,3 @@ GetDefinitionModule(id)
level--; level--;
return df; return df;
} }
AtEoIF()
{
/* Make the unstacking of input streams noticable by the
lexical analyzer
*/
return 1;
}

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

@ -247,19 +247,6 @@ CodeVarDesig(df, ds)
return; return;
} }
if (sc->sc_level == 0) {
/* the variable is global, but declared in a module local
to the implementation or program module.
Such variables can be accessed through an offset from
the name of the module.
*/
ds->dsg_name = &(sc->sc_name[1]);
ds->dsg_offset = df->var_off;
ds->dsg_kind = DSG_FIXED;
df->df_flags |= D_NOREG;
return;
}
if (sc->sc_level != proclevel) { if (sc->sc_level != proclevel) {
/* the variable is local to a statically enclosing procedure. /* the variable is local to a statically enclosing procedure.
*/ */
@ -349,7 +336,7 @@ CodeDesig(nd, ds)
df = nd->nd_left->nd_def; df = nd->nd_left->nd_def;
if (proclevel > df->df_scope->sc_level) { if (proclevel > df->df_scope->sc_level) {
C_lxa(proclevel - df->df_scope->sc_level); C_lxa((arith) (proclevel - df->df_scope->sc_level));
C_adp(df->var_off + pointer_size); C_adp(df->var_off + pointer_size);
} }
else C_lal(df->var_off + pointer_size); else C_lal(df->var_off + pointer_size);

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

@ -118,7 +118,7 @@ EnterVarList(IdList, type, local)
register struct def *df; register struct def *df;
register struct scopelist *sc; register struct scopelist *sc;
char buf[256]; char buf[256];
extern char *sprint(), *Malloc(), *strcpy(); extern char *sprint();
sc = CurrVis; sc = CurrVis;
@ -151,24 +151,12 @@ node_error(IdList->nd_left,"Illegal type for address");
type->tp_align); type->tp_align);
df->var_off = sc->sc_scope->sc_off; df->var_off = sc->sc_scope->sc_off;
} }
else if (!DefinitionModule && CurrVis != Defined->mod_vis) {
/* variable list belongs to an internal global
module.
Align offset and add size
*/
sc->sc_scope->sc_off =
align(sc->sc_scope->sc_off, type->tp_align);
df->var_off = sc->sc_scope->sc_off;
df->var_name = 0;
sc->sc_scope->sc_off += type->tp_size;
}
else { else {
/* Global name, possibly external /* Global name, possibly external
*/ */
sprint(buf,"%s_%s", sc->sc_scope->sc_name, sprint(buf,"%s_%s", sc->sc_scope->sc_name,
df->df_idf->id_text); df->df_idf->id_text);
df->var_name = Malloc((unsigned)(strlen(buf)+1)); df->var_name = Salloc(buf, (unsigned)(strlen(buf)+1));
strcpy(df->var_name, buf);
if (DefinitionModule) { if (DefinitionModule) {
C_exa_dnam(df->var_name); C_exa_dnam(df->var_name);

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

@ -175,7 +175,6 @@ factor(struct node **p;)
{ {
struct def *df; struct def *df;
struct node *nd; struct node *nd;
register struct type *tp;
} : } :
qualident(0, &df, (char *) 0, p) qualident(0, &df, (char *) 0, p)
[ [

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

@ -6,3 +6,18 @@
struct f_info file_info; struct f_info file_info;
#include "input.h" #include "input.h"
#include <inp_pkg.body> #include <inp_pkg.body>
AtEoIF()
{
/* Make the unstacking of input streams noticable to the
lexical analyzer
*/
return 1;
}
AtEoIT()
{
/* Make the end of the text noticable
*/
return 1;
}

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

@ -31,6 +31,7 @@ char *ProgName;
char *DEFPATH[NDIRS+1]; char *DEFPATH[NDIRS+1];
struct def *Defined; struct def *Defined;
extern int err_occurred; extern int err_occurred;
extern int fp_used; /* set if floating point used */
main(argc, argv) main(argc, argv)
char *argv[]; char *argv[];
@ -75,8 +76,8 @@ Compile(src, dst)
init_idf(); init_idf();
InitCst(); InitCst();
reserve(tkidf); reserve(tkidf);
init_scope(); InitScope();
init_types(); InitTypes();
InitDef(); InitDef();
AddStandards(); AddStandards();
#ifdef DEBUG #ifdef DEBUG
@ -94,12 +95,16 @@ Compile(src, dst)
C_magic(); C_magic();
C_ms_emx(word_size, pointer_size); C_ms_emx(word_size, pointer_size);
CompUnit(); CompUnit();
C_ms_src((arith) (LineNumber - 1), FileName);
close_scope(SC_REVERSE); close_scope(SC_REVERSE);
if (err_occurred) { if (err_occurred) {
C_close(); C_close();
return 0; return 0;
} }
WalkModule(Defined); WalkModule(Defined);
if (fp_used) {
C_ms_flt();
}
C_close(); C_close();
#ifdef DEBUG #ifdef DEBUG
if (options['m']) MemUse(); if (options['m']) MemUse();
@ -210,17 +215,9 @@ END SYSTEM.\n";
} }
SYSTEMModule = 1; SYSTEMModule = 1;
DefModule(); DefModule();
close_scope(0);
SYSTEMModule = 0; SYSTEMModule = 0;
} }
AtEoIT()
{
/* Make the end of the text noticable
*/
return 1;
}
#ifdef DEBUG #ifdef DEBUG
MemUse() MemUse()
{ {

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

@ -49,7 +49,7 @@ ModuleDeclaration
struct node *nd; struct node *nd;
struct node *exportlist = 0; struct node *exportlist = 0;
int qualified; int qualified;
extern char *sprint(), *Malloc(), *strcpy(); extern char *sprint();
} : } :
MODULE IDENT { MODULE IDENT {
id = dot.TOK_IDF; id = dot.TOK_IDF;
@ -67,10 +67,9 @@ ModuleDeclaration
df->df_type = standard_type(T_RECORD, 0, (arith) 0); df->df_type = standard_type(T_RECORD, 0, (arith) 0);
df->df_type->rec_scope = df->mod_vis->sc_scope; df->df_type->rec_scope = df->mod_vis->sc_scope;
sprint(buf, "__%d%s", ++modulecount, id->id_text); sprint(buf, "_%d%s", ++modulecount, id->id_text);
CurrentScope->sc_name = CurrentScope->sc_name =
Malloc((unsigned) (strlen(buf) + 1)); Salloc(buf, (unsigned) (strlen(buf) + 1));
strcpy(CurrentScope->sc_name, buf);
if (! proclevel) C_ina_dnam(&buf[1]); if (! proclevel) C_ina_dnam(&buf[1]);
C_inp(buf); C_inp(buf);
} }
@ -177,7 +176,7 @@ DefinitionModule
df->df_flags |= D_QEXPORTED; df->df_flags |= D_QEXPORTED;
df = df->df_nextinscope; df = df->df_nextinscope;
} }
if (!SYSTEMModule) close_scope(SC_CHKFORW); close_scope(SC_CHKFORW);
DefinitionModule--; DefinitionModule--;
match_id(id, dot.TOK_IDF); match_id(id, dot.TOK_IDF);
} }

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

@ -36,7 +36,7 @@ open_scope(scopetype)
assert(scopetype == OPENSCOPE || scopetype == CLOSEDSCOPE); assert(scopetype == OPENSCOPE || scopetype == CLOSEDSCOPE);
clear((char *) sc, sizeof (*sc)); clear((char *) sc, sizeof (struct scope));
sc->sc_scopeclosed = scopetype == CLOSEDSCOPE; sc->sc_scopeclosed = scopetype == CLOSEDSCOPE;
sc->sc_level = proclevel; sc->sc_level = proclevel;
if (scopetype == OPENSCOPE) { if (scopetype == OPENSCOPE) {
@ -48,7 +48,7 @@ open_scope(scopetype)
CurrVis = ls; CurrVis = ls;
} }
init_scope() InitScope()
{ {
register struct scope *sc = new_scope(); register struct scope *sc = new_scope();
register struct scopelist *ls = new_scopelist(); register struct scopelist *ls = new_scopelist();

8
lang/m2/comp/standards.h
View file

@ -22,7 +22,7 @@
/* Standard procedures and functions defined in the SYSTEM module ... */ /* Standard procedures and functions defined in the SYSTEM module ... */
#define S_ADR 20 #define S_ADR 50
#define S_TSIZE 21 #define S_TSIZE 51
#define S_NEWPROCESS 22 #define S_NEWPROCESS 52
#define S_TRANSFER 23 #define S_TRANSFER 53

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

@ -153,7 +153,7 @@ standard_type(fund, align, size)
return tp; return tp;
} }
init_types() InitTypes()
{ {
/* Initialize the predefined types /* Initialize the predefined types
*/ */
@ -434,7 +434,7 @@ ArrayElSize(tp)
if (tp->tp_fund == T_ARRAY) ArraySizes(tp); if (tp->tp_fund == T_ARRAY) ArraySizes(tp);
algn = align(tp->tp_size, tp->tp_align); algn = align(tp->tp_size, tp->tp_align);
if (!(algn % word_size == 0 || word_size % algn == 0)) { if (!(algn % word_size == 0 || word_size % algn == 0)) {
algn = align(algn, word_size); algn = align(algn, (int) word_size);
} }
return algn; return algn;
} }

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

@ -78,26 +78,10 @@ WalkModule(module)
CurrVis = module->mod_vis; CurrVis = module->mod_vis;
sc = CurrentScope; sc = CurrentScope;
if (!proclevel && module != Defined) { if (!proclevel) {
/* This module is a local module, but not within a /* This module is a glocal module.
procedure. Generate code to allocate storage for its Generate code to allocate storage for its variables.
variables. This is done by generating a "bss", They all have an explicit name.
with label "_<modulenumber><modulename>".
*/
arith size = align(sc->sc_off, word_align);
if (size == 0) size = word_size;
/* WHY ??? because we generated an INA for it ??? */
C_df_dnam(&(sc->sc_name[1]));
size = align(size, word_align);
C_bss_cst(size, (arith) 0, 0);
C_exp(sc->sc_name);
}
else if (CurrVis == Defined->mod_vis) {
/* This module is the module currently being compiled.
Again, generate code to allocate storage for its
variables, which all have an explicit name.
*/ */
while (df) { while (df) {
if (df->df_kind == D_VARIABLE) { if (df->df_kind == D_VARIABLE) {
@ -369,11 +353,9 @@ WalkStat(nd, lab)
struct node *fnd; struct node *fnd;
label l1 = instructionlabel++; label l1 = instructionlabel++;
label l2 = instructionlabel++; label l2 = instructionlabel++;
arith size;
if (! DoForInit(nd, left)) break; if (! DoForInit(nd, left)) break;
fnd = left->nd_right; fnd = left->nd_right;
size = fnd->nd_type->tp_size;
if (fnd->nd_class != Value) { if (fnd->nd_class != Value) {
CodePExpr(fnd); CodePExpr(fnd);
tmp = NewInt(); tmp = NewInt();
@ -513,7 +495,7 @@ DoForInit(nd, left)
if (! chk_designator(nd, VARIABLE, D_DEFINED) || if (! chk_designator(nd, VARIABLE, D_DEFINED) ||
! chk_expr(left->nd_left) || ! chk_expr(left->nd_left) ||
! chk_expr(left->nd_right)) return; ! chk_expr(left->nd_right)) return 0;
if (nd->nd_type->tp_size > word_size || if (nd->nd_type->tp_size > word_size ||
!(nd->nd_type->tp_fund & T_DISCRETE)) { !(nd->nd_type->tp_fund & T_DISCRETE)) {
@ -533,6 +515,8 @@ node_warning(nd, "old-fashioned! compatibility required in FOR statement");
CodePExpr(left->nd_left); CodePExpr(left->nd_left);
CodeDStore(nd); CodeDStore(nd);
return 1;
} }
DoAssign(nd, left, right) DoAssign(nd, left, right)