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

newer version

Browse source
This commit is contained in:
ceriel 1986-11-26 16:40:45 +00:00
parent 552f5a3f61
commit da54801353
19 changed files with 264 additions and 205 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -106,9 +106,8 @@ GetString(upto)
}
str->s_length = p - str->s_str;
while (p - str->s_str < len) *p++ = '\0';
if (str->s_length == 0) str->s_length = 1; /* ??? string length
at least 1 ???
*/
if (str->s_length == 0) str->s_length = 1;
/* ??? string length at least 1 ??? */
return str;
}
@ -239,12 +238,10 @@ again1:
goto again;
case STGARB:
if (040 < ch && ch < 0177) {
if ((unsigned) ch - 040 < 0137) {
lexerror("garbage char %c", ch);
}
else {
lexerror("garbage char \\%03o", ch);
}
else lexerror("garbage char \\%03o", ch);
goto again;
case STSIMP:

14
lang/m2/comp/Makefile
View file

@ -5,11 +5,11 @@ PKGDIR = $(EMDIR)/modules/pkg
LIBDIR = $(EMDIR)/modules/lib
OBJECTCODE = $(LIBDIR)/libemk.a
LLGEN = $(EMDIR)/bin/LLgen
CURRDIR = .
INCLUDES = -I$(MHDIR) -I$(EMDIR)/h -I$(PKGDIR)
GFILES = tokenfile.g program.g declar.g expression.g statement.g
CC = cc
LLGENOPTIONS =
PROFILE =
CFLAGS = $(PROFILE) $(INCLUDES) -DSTATIC=
@ -50,14 +50,14 @@ GENFILES = $(GENGFILES) $(GENCFILES) $(GENHFILES)
#EXCLEXCLEXCLEXCL
all: Cfiles
sh -c 'if $(CC) nmclash.c > /dev/null 2>&1 ; then make ../comp/main ; else sh Resolve ../comp/main ; fi'
sh -c 'if $(CC) nmclash.c > /dev/null 2>&1 ; then make $(CURRDIR)/main ; else sh Resolve main ; fi'
@rm -f nmclash.o a.out
install: all
cp main $(EMDIR)/lib/em_m2
cp $(CURRDIR)/main $(EMDIR)/lib/em_m2
clean:
rm -f $(OBJ) $(GENFILES) LLfiles hfiles Cfiles tab clashes main
rm -f $(OBJ) $(GENFILES) LLfiles hfiles Cfiles tab clashes $(CURRDIR)/main
(cd .. ; rm -rf Xsrc)
lint: Cfiles
@ -123,9 +123,9 @@ depend:
Xlint:
lint $(INCLUDES) $(LINTFLAGS) $(SRC)
../comp/main: $(OBJ) ../comp/Makefile
$(CC) $(LFLAGS) $(OBJ) $(LIBDIR)/libem_mes.a $(OBJECTCODE) $(LIBDIR)/libinput.a $(LIBDIR)/libassert.a $(LIBDIR)/liballoc.a $(MALLOC) $(LIBDIR)/libprint.a $(LIBDIR)/libstring.a $(LIBDIR)/libsystem.a -o ../comp/main
size ../comp/main
$(CURRDIR)/main: $(OBJ)
$(CC) $(LFLAGS) $(OBJ) $(LIBDIR)/libem_mes.a $(OBJECTCODE) $(LIBDIR)/libinput.a $(LIBDIR)/libassert.a $(LIBDIR)/liballoc.a $(MALLOC) $(LIBDIR)/libprint.a $(LIBDIR)/libstring.a $(LIBDIR)/libsystem.a -o $(CURRDIR)/main
size $(CURRDIR)/main
#AUTOAUTOAUTOAUTOAUTOAUTOAUTOAUTO
LLlex.o: LLlex.h Lpars.h class.h const.h debug.h debugcst.h f_info.h idf.h idfsize.h input.h inputtype.h numsize.h strsize.h type.h warning.h

7
lang/m2/comp/Resolve
View file

@ -8,8 +8,11 @@ case $# in
exit 1
;;
esac
currdir=`pwd`
case $1 in
../comp/main|Xlint)
main) target=$currdir/$1
;;
Xlint) target=$1
;;
*) echo "$0: $1: Illegal argument" 1>&2
exit 1
@ -48,4 +51,4 @@ $i: clashes $PW/$i
cid -Fclashes < $PW/$i > $i
EOF
done
make $1
make CURRDIR=$currdir $target

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

@ -438,6 +438,7 @@ getarg(argp, bases, designator, edf)
}
left = arg->nd_left;
*argp = arg;
if (designator ? !ChkVariable(left) : !ChkExpression(left)) {
return 0;
@ -454,7 +455,6 @@ getarg(argp, bases, designator, edf)
}
}
*argp = arg;
return left;
}
@ -470,6 +470,8 @@ getname(argp, kinds, bases, edf)
register struct node *arg = *argp;
register struct node *left;
*argp = arg->nd_right;
if (!arg->nd_right) {
Xerror(arg, "too few arguments supplied", edf);
return 0;
@ -496,7 +498,6 @@ getname(argp, kinds, bases, edf)
}
}
*argp = arg;
return left;
}
@ -539,7 +540,7 @@ ChkProcCall(expp)
if (left->nd_symb == STRING) {
TryToString(left, TypeOfParam(param));
}
if (! TstParCompat(RemoveEqual(TypeOfParam(param)),
else if (! TstParCompat(RemoveEqual(TypeOfParam(param)),
left->nd_type,
IsVarParam(param),
left)) {
@ -552,6 +553,9 @@ ChkProcCall(expp)
if (expp->nd_right) {
Xerror(expp->nd_right, "too many parameters supplied", edf);
while (expp->nd_right) {
getarg(&expp, 0, 0, edf);
}
return 0;
}
@ -581,7 +585,7 @@ ChkCall(expp)
return ChkCast(expp, left);
}
if (IsProcCall(left)) {
if (IsProcCall(left) || left->nd_type == error_type) {
/* A procedure call.
It may also be a call to a standard procedure
*/

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

@ -86,7 +86,6 @@ CodePadString(nd, sz)
C_loi(sizearg);
}
CodeExpr(nd, ds, true_label, false_label)
register struct node *nd;
register struct desig *ds;
@ -365,27 +364,37 @@ CodeParameters(param, arg)
left = arg->nd_left;
left_type = left->nd_type;
if (IsConformantArray(tp)) {
register struct type *elem = tp->arr_elem;
C_loc(tp->arr_elsize);
if (IsConformantArray(left_type)) {
DoHIGH(left);
if (tp->arr_elem->tp_size !=
left_type->arr_elem->tp_size) {
if (elem->tp_size != left_type->arr_elem->tp_size) {
/* This can only happen if the formal type is
ARRAY OF WORD
ARRAY OF (WORD|BYTE)
*/
assert(tp->arr_elem == word_type);
C_loc(left_type->arr_elem->tp_size);
C_cal("_wa");
C_asp(dword_size);
C_lfr(word_size);
C_mli(word_size);
if (elem == word_type) {
C_loc(word_size - 1);
C_adi(word_size);
C_loc(word_size);
C_dvi(word_size);
}
else {
assert(elem == byte_type);
}
}
}
else if (left->nd_symb == STRING) {
C_loc(left->nd_SLE);
C_loc(left->nd_SLE - 1);
}
else if (tp->arr_elem == word_type) {
else if (elem == word_type) {
C_loc((left_type->tp_size+word_size-1) / word_size - 1);
}
else if (elem == byte_type) {
C_loc(left_type->tp_size - 1);
}
else {
arith lb, ub;
getbounds(IndexType(left_type), &lb, &ub);
@ -395,20 +404,30 @@ CodeParameters(param, arg)
if (left->nd_symb == STRING) {
CodeString(left);
}
else CodeDAddress(left);
}
else if (IsVarParam(param)) {
CodeDAddress(left);
}
else {
if (left_type->tp_fund == T_STRING) {
CodePadString(left, tp->tp_size);
}
else {
else if (left->nd_class == Call) {
/* ouch! forgot about this one! */
arith tmp, TmpSpace();
CodePExpr(left);
RangeCheck(left_type, tp);
tmp = TmpSpace(left->nd_type->tp_size, left->nd_type->tp_align);
C_lal(tmp);
C_sti(WA(left->nd_type->tp_size));
C_lal(tmp);
}
else CodeDAddress(left);
return;
}
if (IsVarParam(param)) {
CodeDAddress(left);
return;
}
if (left_type->tp_fund == T_STRING) {
CodePadString(left, tp->tp_size);
return;
}
CodePExpr(left);
RangeCheck(tp, left_type);
CodeCoercion(left_type, tp);
}
CodeStd(nd)
@ -538,33 +557,6 @@ CodeStd(nd)
}
}
CodeAssign(nd, dss, dst)
register struct node *nd;
struct desig *dst, *dss;
{
/* Generate code for an assignment. Testing of type
compatibility and the like is already done.
*/
register struct type *tp = nd->nd_right->nd_type;
arith size = nd->nd_left->nd_type->tp_size;
if (dss->dsg_kind == DSG_LOADED) {
if (tp->tp_fund == T_STRING) {
CodeAddress(dst);
C_loc(tp->tp_size);
C_loc(size);
C_cal("_StringAssign");
C_asp((int_size << 1) + (pointer_size << 1));
return;
}
CodeStore(dst, size);
return;
}
CodeAddress(dss);
CodeAddress(dst);
C_blm(size);
}
RangeCheck(tpl, tpr)
register struct type *tpl, *tpr;
{
@ -800,32 +792,30 @@ CodeOper(expr, true_label, false_label)
case OR:
case AND:
case '&': {
label l_true, l_false, l_maybe = ++text_label, l_end;
label l_maybe = ++text_label, l_end;
struct desig Des;
int genlabels = 0;
if (true_label == 0) {
l_true = ++text_label;
l_false = ++text_label;
genlabels = 1;
true_label = ++text_label;
false_label = ++text_label;
l_end = ++text_label;
}
else {
l_true = true_label;
l_false = false_label;
}
Des = InitDesig;
if (expr->nd_symb == OR) {
CodeExpr(leftop, &Des, l_true, l_maybe);
CodeExpr(leftop, &Des, true_label, l_maybe);
}
else CodeExpr(leftop, &Des, l_maybe, l_false);
else CodeExpr(leftop, &Des, l_maybe, false_label);
C_df_ilb(l_maybe);
Des = InitDesig;
CodeExpr(rightop, &Des, l_true, l_false);
if (true_label == 0) {
C_df_ilb(l_true);
CodeExpr(rightop, &Des, true_label, false_label);
if (genlabels) {
C_df_ilb(true_label);
C_loc((arith)1);
C_bra(l_end);
C_df_ilb(l_false);
C_df_ilb(false_label);
C_loc((arith)0);
C_df_ilb(l_end);
}

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

@ -102,10 +102,11 @@ FormalType(struct type **ptp;)
} :
ARRAY OF qualtype(ptp)
{ register struct type *tp = construct_type(T_ARRAY, NULLTYPE);
tp->arr_elem = *ptp;
*ptp = tp;
tp->arr_elsize = ArrayElSize(tp->arr_elem);
tp->tp_align = lcm(word_align, pointer_align);
tp->tp_align = tp->arr_elem->tp_align;
}
|
qualtype(ptp)
@ -160,16 +161,18 @@ enumeration(struct type **ptp;)
struct node *EnumList;
} :
'(' IdentList(&EnumList) ')'
{
*ptp = standard_type(T_ENUMERATION, int_align, int_size);
EnterEnumList(EnumList, *ptp);
if (ufit((*ptp)->enm_ncst-1, 1)) {
(*ptp)->tp_size = 1;
(*ptp)->tp_align = 1;
{ register struct type *tp =
standard_type(T_ENUMERATION, int_align, int_size);
*ptp = tp;
EnterEnumList(EnumList, tp);
if (ufit(tp->enm_ncst-1, 1)) {
tp->tp_size = 1;
tp->tp_align = 1;
}
else if (ufit((*ptp)->enm_ncst-1, short_size)) {
(*ptp)->tp_size = short_size;
(*ptp)->tp_align = short_align;
else if (ufit(tp->enm_ncst-1, short_size)) {
tp->tp_size = short_size;
tp->tp_align = short_align;
}
}
;
@ -234,7 +237,6 @@ RecordType(struct type **ptp;)
{ open_scope(OPENSCOPE); /* scope for fields of record */
scope = CurrentScope;
close_scope(0);
size = 0;
}
FieldListSequence(scope, &size, &xalign)
{ *ptp = standard_type(T_RECORD, xalign, WA(size));

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

@ -63,13 +63,20 @@ struct dforward {
#define for_name df_value.df_forward.fo_name
};
struct forwtype {
struct node *f_node;
struct type *f_type;
#define df_forw_type df_value.df_fortype.f_type
#define df_forw_node df_value.df_fortype.f_node
};
struct def { /* list of definitions for a name */
struct def *next; /* next definition in definitions chain */
struct def *df_nextinscope;
/* link all definitions in a scope */
struct idf *df_idf; /* link back to the name */
struct scope *df_scope; /* scope in which this definition resides */
short df_kind; /* the kind of this definition: */
unsigned short df_kind; /* the kind of this definition: */
#define D_MODULE 0x0001 /* a module */
#define D_PROCEDURE 0x0002 /* procedure of function */
#define D_VARIABLE 0x0004 /* a variable */
@ -82,20 +89,22 @@ struct def { /* list of definitions for a name */
#define D_HIDDEN 0x0200 /* a hidden type */
#define D_FORWARD 0x0400 /* not yet defined */
#define D_FORWMODULE 0x0800 /* module must be declared later */
#define D_ERROR 0x1000 /* a compiler generated definition for an
#define D_FORWTYPE 0x1000 /* forward type */
#define D_FTYPE 0x2000 /* resolved forward type */
#define D_ERROR 0x4000 /* a compiler generated definition for an
undefined variable
*/
#define D_VALUE (D_PROCEDURE|D_VARIABLE|D_FIELD|D_ENUM|D_CONST|D_PROCHEAD)
#define D_ISTYPE (D_HIDDEN|D_TYPE)
#define D_ISTYPE (D_HIDDEN|D_TYPE|D_FTYPE)
#define is_type(dfx) ((dfx)->df_kind & D_ISTYPE)
char df_flags;
#define D_NOREG 0x01 /* set if it may not reside in a register */
#define D_USED 0x02 /* set if used (future use ???) */
#define D_DEFINED 0x04 /* set if it is assigned a value (future use ???) */
#define D_VARPAR 0x10 /* set if it is a VAR parameter */
#define D_VALPAR 0x20 /* set if it is a value parameter */
#define D_EXPORTED 0x40 /* set if exported */
#define D_QEXPORTED 0x80 /* set if qualified exported */
#define D_VARPAR 0x08 /* set if it is a VAR parameter */
#define D_VALPAR 0x10 /* set if it is a value parameter */
#define D_EXPORTED 0x20 /* set if exported */
#define D_QEXPORTED 0x40 /* set if qualified exported */
struct type *df_type;
union {
struct module df_module;
@ -106,6 +115,7 @@ struct def { /* list of definitions for a name */
struct import df_import;
struct dfproc df_proc;
struct dforward df_forward;
struct forwtype df_fortype;
int df_stdname; /* define for standard name */
} df_value;
};

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

@ -21,6 +21,8 @@ struct def *h_def; /* pointer to free list of def structures */
int cnt_def; /* count number of allocated ones */
#endif
extern int (*c_inp)();
STATIC
DefInFront(df)
register struct def *df;
@ -129,6 +131,18 @@ define(id, scope, kind)
}
break;
case D_FORWTYPE:
if (kind == D_FORWTYPE) return df;
if (kind == D_TYPE) {
df->df_kind = D_FTYPE;
FreeNode(df->df_forw_node);
}
else {
error("identifier \"%s\" must be a type",
id->id_text);
}
return df;
case D_FORWARD:
/* A forward reference, for which we may now have
found a definition.
@ -247,7 +261,7 @@ DeclProc(type, id)
df = define(id, CurrentScope, type);
sprint(buf,"_%d_%s",++nmcount,id->id_text);
name = Salloc(buf, (unsigned)(strlen(buf)+1));
C_inp(buf);
(*c_inp)(buf);
}
open_scope(OPENSCOPE);
scope = CurrentScope;
@ -311,13 +325,13 @@ DefineLocalModule(id)
/* Create a type for it
*/
df->df_type = standard_type(T_RECORD, 0, (arith) 0);
df->df_type = standard_type(T_RECORD, 1, (arith) 0);
df->df_type->rec_scope = sc;
/* Generate code that indicates that the initialization procedure
for this module is local.
*/
C_inp(buf);
(*c_inp)(buf);
return df;
}

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

@ -36,7 +36,7 @@ GetFile(name)
buf[10] = '\0'; /* maximum length */
strcat(buf, ".def");
if (! InsertFile(buf, DEFPATH, &(FileName))) {
error("could'nt find a DEFINITION MODULE for \"%s\"", name);
error("could not find a DEFINITION MODULE for \"%s\"", name);
return 0;
}
LineNumber = 1;
@ -56,6 +56,7 @@ GetDefinitionModule(id, incr)
struct def *df;
static int level;
struct scopelist *vis;
int didread = 0;
level += incr;
df = lookup(id, GlobalScope, 1);
@ -68,6 +69,7 @@ GetDefinitionModule(id, incr)
else {
open_scope(CLOSEDSCOPE);
if (!is_anon_idf(id) && GetFile(id->id_text)) {
didread = 1;
DefModule();
if (level == 1) {
/* The module is directly imported by
@ -93,6 +95,9 @@ GetDefinitionModule(id, incr)
}
df = lookup(id, GlobalScope, 1);
if (! df) {
if (didread) {
error("did not read a DEFINITION MODULE for \"%s\"", id->id_text);
}
df = MkDef(id, GlobalScope, D_ERROR);
df->df_type = error_type;
df->mod_vis = vis;

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

@ -50,7 +50,7 @@ ExpList(struct node **pnd;)
register struct node *nd;
} :
expression(pnd) { *pnd = nd = MkNode(Link,*pnd,NULLNODE,&dot);
(*pnd)->nd_symb = ',';
nd->nd_symb = ',';
}
[
',' { nd->nd_right = MkLeaf(Link, &dot);
@ -60,20 +60,26 @@ ExpList(struct node **pnd;)
]*
;
ConstExpression(struct node **pnd;):
ConstExpression(struct node **pnd;)
{
register struct node *nd;
}:
expression(pnd)
/*
* Changed rule in new Modula-2.
* Check that the expression is a constant expression and evaluate!
*/
{ DO_DEBUG(options['X'], print("CONSTANT EXPRESSION\n"));
DO_DEBUG(options['X'], PrNode(*pnd, 0));
if (ChkExpression(*pnd) &&
((*pnd)->nd_class != Set && (*pnd)->nd_class != Value)) {
{ nd = *pnd;
DO_DEBUG(options['X'], print("CONSTANT EXPRESSION\n"));
DO_DEBUG(options['X'], PrNode(nd, 0));
if (ChkExpression(nd) &&
((nd)->nd_class != Set && (nd)->nd_class != Value)) {
error("constant expression expected");
}
DO_DEBUG(options['X'], print("RESULTS IN\n"));
DO_DEBUG(options['X'], PrNode(*pnd, 0));
DO_DEBUG(options['X'], PrNode(nd, 0));
}
;
@ -102,6 +108,7 @@ SimpleExpression(struct node **pnd;)
[ '+' | '-' ]
{ *pnd = MkLeaf(Uoper, &dot);
pnd = &((*pnd)->nd_right);
/* priority of unary operator ??? */
}
]?
term(pnd)

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

@ -29,6 +29,9 @@ struct def *Defined;
extern int err_occurred;
extern int fp_used; /* set if floating point used */
extern C_inp(), C_exp();
int (*c_inp)() = C_inp;
main(argc, argv)
register char **argv;
{
@ -49,6 +52,7 @@ main(argc, argv)
fprint(STDERR, "%s: Use a file argument\n", ProgName);
return 1;
}
if (options['x']) c_inp = C_exp;
return !Compile(Nargv[1], Nargv[2]);
}
@ -197,6 +201,7 @@ do_SYSTEM()
*/
open_scope(CLOSEDSCOPE);
(void) Enter("WORD", D_TYPE, word_type, 0);
(void) Enter("BYTE", D_TYPE, byte_type, 0);
(void) Enter("ADDRESS", D_TYPE, address_type, 0);
(void) Enter("ADR", D_PROCEDURE, std_type, S_ADR);
(void) Enter("TSIZE", D_PROCEDURE, std_type, S_TSIZE);
@ -215,14 +220,14 @@ Info()
{
extern int cnt_def, cnt_node, cnt_paramlist, cnt_type,
cnt_switch_hdr, cnt_case_entry,
cnt_scope, cnt_scopelist, cnt_forwards, cnt_tmpvar;
cnt_scope, cnt_scopelist, cnt_tmpvar;
print("\
%6d def\n%6d node\n%6d paramlist\n%6d type\n%6d switch_hdr\n\
%6d case_entry\n%6d scope\n%6d scopelist\n%6d forwards\n%6d tmpvar\n",
%6d case_entry\n%6d scope\n%6d scopelist\n%6d tmpvar\n",
cnt_def, cnt_node, cnt_paramlist, cnt_type,
cnt_switch_hdr, cnt_case_entry,
cnt_scope, cnt_scopelist, cnt_forwards, cnt_tmpvar);
cnt_scope, cnt_scopelist, cnt_tmpvar);
print("\nNumber of lines read: %d\n", cntlines);
}
#endif

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

@ -59,10 +59,12 @@ ModuleDeclaration
priority(arith *pprio;)
{
struct node *nd;
register struct node *nd;
struct node *nd1; /* &nd is illegal */
} :
'[' ConstExpression(&nd) ']'
{ if (!(nd->nd_type->tp_fund & T_CARDINAL)) {
'[' ConstExpression(&nd1) ']'
{ nd = nd1;
if (!(nd->nd_type->tp_fund & T_CARDINAL)) {
node_error(nd, "illegal priority");
}
*pprio = nd->nd_INT;
@ -70,9 +72,7 @@ priority(arith *pprio;)
}
;
export(int *QUALflag; struct node **ExportList;)
{
} :
export(int *QUALflag; struct node **ExportList;):
EXPORT
[
QUALIFIED
@ -86,7 +86,7 @@ export(int *QUALflag; struct node **ExportList;)
import(int local;)
{
struct node *ImportList;
struct node *FromId = 0;
register struct node *FromId = 0;
register struct def *df;
extern struct def *GetDefinitionModule();
} :
@ -121,7 +121,7 @@ DefinitionModule
if (!Defined) Defined = df;
CurrentScope->sc_name = df->df_idf->id_text;
df->mod_vis = CurrVis;
df->df_type = standard_type(T_RECORD, 0, (arith) 0);
df->df_type = standard_type(T_RECORD, 1, (arith) 0);
df->df_type->rec_scope = df->mod_vis->sc_scope;
DefinitionModule++;
}
@ -210,12 +210,9 @@ ProgramModule
;
Module:
{ open_scope(CLOSEDSCOPE);
warning(W_ORDINARY, "Compiling a definition module");
}
DefinitionModule
{ close_scope(SC_CHKFORW); }
|
DEFINITION
{ fatal("Compiling a definition module"); }
| %default
[
IMPLEMENTATION { state = IMPLEMENTATION; }
|

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

@ -50,7 +50,6 @@ InitScope()
register struct scopelist *ls = new_scopelist();
sc->sc_scopeclosed = 0;
sc->sc_forw = 0;
sc->sc_def = 0;
sc->sc_level = proclevel;
PervasiveScope = sc;
@ -61,14 +60,6 @@ InitScope()
CurrVis = ls;
}
struct forwards {
struct forwards *next;
struct node *fo_tok;
struct type *fo_ptyp;
};
/* STATICALLOCDEF "forwards" 5 */
Forward(tk, ptp)
struct node *tk;
struct type *ptp;
@ -78,13 +69,10 @@ Forward(tk, ptp)
may have forward references that must howewer be declared in the
same scope.
*/
register struct forwards *f = new_forwards();
register struct scope *sc = CurrentScope;
register struct def *df = define(tk->nd_IDF, CurrentScope, D_FORWTYPE);
f->fo_tok = tk;
f->fo_ptyp = ptp;
f->next = sc->sc_forw;
sc->sc_forw = f;
df->df_forw_type = ptp;
df->df_forw_node = tk;
}
STATIC
@ -117,7 +105,15 @@ chk_forw(pdf)
register struct def *df;
while (df = *pdf) {
if (df->df_kind & (D_FORWARD|D_FORWMODULE)) {
if (df->df_kind == D_FORWTYPE) {
node_error(df->df_forw_node, "type \"%s\" not declared", df->df_idf->id_text);
FreeNode(df->df_forw_node);
}
else if (df->df_kind == D_FTYPE) {
df->df_kind = D_TYPE;
df->df_forw_type->next = df->df_type;
}
else if (df->df_kind & (D_FORWARD|D_FORWMODULE)) {
/* These definitions must be found in
the enclosing closed scope, which of course
may be the scope that is now closed!
@ -126,7 +122,7 @@ chk_forw(pdf)
/* Indeed, the scope was a closed
scope, so give error message
*/
node_error(df->for_node, "identifier \"%s\" has not been declared",
node_error(df->for_node, "identifier \"%s\" not declared",
df->df_idf->id_text);
FreeNode(df->for_node);
}
@ -153,25 +149,6 @@ df->df_idf->id_text);
}
}
STATIC
rem_forwards(fo)
register struct forwards *fo;
{
/* When closing a scope, all forward references must be resolved
*/
register struct def *df;
if (fo->next) rem_forwards(fo->next);
df = lookfor(fo->fo_tok, CurrVis, 0);
if (! is_type(df)) {
node_error(fo->fo_tok,
"identifier \"%s\" does not represent a type",
df->df_idf->id_text);
}
fo->fo_ptyp->next = df->df_type;
free_forwards(fo);
}
Reverse(pdf)
struct def **pdf;
{
@ -210,7 +187,6 @@ close_scope(flag)
assert(sc != 0);
if (flag) {
if (sc->sc_forw) rem_forwards(sc->sc_forw);
DO_DEBUG(options['S'], PrScopeDef(sc->sc_def));
if (flag & SC_CHKPROC) chk_proc(sc->sc_def);
if (flag & SC_CHKFORW) chk_forw(&(sc->sc_def));

1
lang/m2/comp/scope.h
View file

@ -15,7 +15,6 @@
struct scope {
struct scope *next;
struct forwards *sc_forw;
char *sc_name; /* name of this scope */
struct def *sc_def; /* list of definitions in this scope */
arith sc_off; /* offsets of variables in this scope */

16
lang/m2/comp/tmpvar.C
View file

@ -40,6 +40,16 @@ TmpOpen(sc) struct scope *sc;
ProcScope = sc;
}
arith
TmpSpace(sz, al)
arith sz;
{
register struct scope *sc = ProcScope;
sc->sc_off = - WA(align(sz - sc->sc_off, al));
return sc->sc_off;
}
arith
NewInt()
{
@ -47,8 +57,7 @@ NewInt()
register struct tmpvar *tmp;
if (!TmpInts) {
offset = - WA(align(int_size - ProcScope->sc_off, int_align));
ProcScope->sc_off = offset;
offset = TmpSpace(int_size, int_align);
if (! options['n']) C_ms_reg(offset, int_size, reg_any, 0);
}
else {
@ -67,8 +76,7 @@ NewPtr()
register struct tmpvar *tmp;
if (!TmpPtrs) {
offset = - WA(align(pointer_size - ProcScope->sc_off, pointer_align));
ProcScope->sc_off = offset;
offset = TmpSpace(pointer_size, pointer_align);
if (! options['n']) C_ms_reg(offset, pointer_size, reg_pointer, 0);
}
else {

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

@ -95,6 +95,7 @@ extern struct type
*real_type,
*longreal_type,
*word_type,
*byte_type,
*address_type,
*intorcard_type,
*bitset_type,

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

@ -48,6 +48,7 @@ struct type
*real_type,
*longreal_type,
*word_type,
*byte_type,
*address_type,
*intorcard_type,
*bitset_type,
@ -123,7 +124,7 @@ standard_type(fund, align, size)
register struct type *tp = new_type();
tp->tp_fund = fund;
tp->tp_align = align;
tp->tp_align = align ? align : 1;
tp->tp_size = size;
return tp;
@ -179,6 +180,7 @@ InitTypes()
/* SYSTEM types
*/
word_type = standard_type(T_WORD, word_align, word_size);
byte_type = standard_type(T_WORD, 1, (arith) 1);
address_type = construct_type(T_POINTER, word_type);
/* create BITSET type
@ -407,11 +409,11 @@ ArrayElSize(tp)
if (tp->tp_fund == T_ARRAY) ArraySizes(tp);
algn = align(tp->tp_size, tp->tp_align);
if (algn && word_size % algn != 0) {
if (word_size % algn != 0) {
/* algn is not a dividor of the word size, so make sure it
is a multiple
*/
algn = WA(algn);
return WA(algn);
}
return algn;
}
@ -432,13 +434,13 @@ ArraySizes(tp)
*/
if (! bounded(index_type)) {
error("illegal index type");
tp->tp_size = 0;
tp->tp_size = tp->arr_elsize;
return;
}
getbounds(index_type, &lo, &hi);
tp->tp_size = WA((hi - lo + 1) * tp->arr_elsize);
tp->tp_size = (hi - lo + 1) * tp->arr_elsize;
/* generate descriptor and remember label.
*/

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

@ -177,7 +177,7 @@ TstParCompat(formaltype, actualtype, VARflag, nd)
/* Check type compatibility for a parameter in a procedure call.
Assignment compatibility may do if the parameter is
a value parameter.
Otherwise, a conformant array may do, or an ARRAY OF WORD
Otherwise, a conformant array may do, or an ARRAY OF (WORD|BYTE)
may do too.
Or: a WORD may do.
*/
@ -201,10 +201,15 @@ TstParCompat(formaltype, actualtype, VARflag, nd)
)
)
)
||
( formaltype == byte_type
&& actualtype->tp_size == (arith) 1
)
||
( IsConformantArray(formaltype)
&&
( formaltype->arr_elem == word_type
|| formaltype->arr_elem == byte_type
||
( actualtype->tp_fund == T_ARRAY
&& TstTypeEquiv(formaltype->arr_elem,actualtype->arr_elem)

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

@ -44,13 +44,15 @@ DoProfil()
static label filename_label = 0;
if (! options['L']) {
if (!filename_label) {
filename_label = ++data_label;
C_df_dlb(filename_label);
register label fn_label = filename_label;
if (!fn_label) {
filename_label = fn_label = ++data_label;
C_df_dlb(fn_label);
C_rom_scon(FileName, (arith) (strlen(FileName) + 1));
}
C_fil_dlb(filename_label, (arith) 0);
C_fil_dlb(fn_label, (arith) 0);
}
}
@ -126,7 +128,7 @@ WalkProcedure(procedure)
local definitions, checking and generating code.
*/
struct scopelist *savevis = CurrVis;
register struct scope *sc;
register struct scope *sc = procedure->prc_vis->sc_scope;
register struct type *tp;
register struct paramlist *param;
label func_res_label = 0;
@ -136,7 +138,6 @@ WalkProcedure(procedure)
proclevel++;
CurrVis = procedure->prc_vis;
sc = CurrentScope;
/* Generate code for all local modules and procedures
*/
@ -390,7 +391,7 @@ WalkCall(nd)
}
WalkStat(nd, exit_label)
struct node *nd;
register struct node *nd;
label exit_label;
{
/* Walk through a statement, generating code for it.
@ -468,10 +469,11 @@ WalkStat(nd, exit_label)
{
arith tmp = 0;
register struct node *fnd;
int good_forvar;
label l1 = ++text_label;
label l2 = ++text_label;
if (! DoForInit(nd, left)) break;
good_forvar = DoForInit(nd, left);
fnd = left->nd_right;
if (fnd->nd_class != Value) {
/* Upperbound not constant.
@ -489,15 +491,19 @@ WalkStat(nd, exit_label)
C_bgt(l2);
}
else C_blt(l2);
RangeCheck(nd->nd_type, int_type);
CodeDStore(nd);
if (good_forvar) {
RangeCheck(nd->nd_type, int_type);
CodeDStore(nd);
}
WalkNode(right, exit_label);
CodePExpr(nd);
C_loc(left->nd_INT);
C_adi(int_size);
C_bra(l1);
C_df_ilb(l2);
C_asp(int_size);
if (good_forvar) {
CodePExpr(nd);
C_loc(left->nd_INT);
C_adi(int_size);
C_bra(l1);
C_df_ilb(l2);
C_asp(int_size);
}
if (tmp) FreeInt(tmp);
}
break;
@ -545,14 +551,23 @@ WalkStat(nd, exit_label)
case RETURN:
if (right) {
if (! WalkExpr(right)) break;
if (! ChkExpression(right)) break;
/* The type of the return-expression must be
assignment compatible with the result type of the
function procedure (See Rep. 9.11).
*/
if (!TstAssCompat(func_type, right->nd_type)) {
node_error(right, "type incompatibility in RETURN statement");
break;
}
if (right->nd_type->tp_fund == T_STRING) {
arith strsize = WA(right->nd_type->tp_size);
C_zer(WA(func_type->tp_size) - strsize);
CodePExpr(right);
C_loi(strsize);
}
else CodePExpr(right);
}
C_bra(RETURN_LABEL);
break;
@ -644,12 +659,12 @@ DoForInit(nd, left)
if (df->df_kind == D_FIELD) {
node_error(nd,
"FOR-loop variable may not be a field of a record");
return 0;
return 1;
}
if (!df->var_name && df->var_off >= 0) {
node_error(nd, "FOR-loop variable may not be a parameter");
return 0;
return 1;
}
if (df->df_scope != CurrentScope) {
@ -659,7 +674,7 @@ DoForInit(nd, left)
if (!sc) {
node_error(nd,
"FOR-loop variable may not be imported");
return 0;
return 1;
}
if (sc->sc_scope == df->df_scope) break;
sc = nextvisible(sc);
@ -669,7 +684,7 @@ DoForInit(nd, left)
if (df->df_type->tp_size > word_size ||
!(df->df_type->tp_fund & T_DISCRETE)) {
node_error(nd, "illegal type of FOR loop variable");
return 0;
return 1;
}
if (!TstCompat(df->df_type, left->nd_left->nd_type) ||
@ -677,7 +692,7 @@ DoForInit(nd, left)
if (!TstAssCompat(df->df_type, left->nd_left->nd_type) ||
!TstAssCompat(df->df_type, left->nd_right->nd_type)) {
node_error(nd, "type incompatibility in FOR statement");
return 0;
return 1;
}
node_warning(nd, W_OLDFASHIONED, "compatibility required in FOR statement");
}
@ -695,29 +710,48 @@ DoAssign(nd, left, right)
DAMN THE BOOK!
*/
struct desig dsl, dsr;
register struct type *rtp, *ltp;
if (! (ChkExpression(right) & ChkVariable(left))) return;
rtp = right->nd_type;
ltp = left->nd_type;
if (right->nd_symb == STRING) TryToString(right, left->nd_type);
if (right->nd_symb == STRING) TryToString(right, ltp);
dsr = InitDesig;
if (! TstAssCompat(left->nd_type, right->nd_type)) {
if (! TstAssCompat(ltp, rtp)) {
node_error(nd, "type incompatibility in assignment");
return;
}
CodeExpr(right, &dsr, NO_LABEL, NO_LABEL);
if (complex(right->nd_type)) {
CodeAddress(&dsr);
}
if (complex(rtp)) CodeAddress(&dsr);
else {
CodeValue(&dsr, right->nd_type->tp_size);
RangeCheck(left->nd_type, right->nd_type);
CodeValue(&dsr, rtp->tp_size);
RangeCheck(ltp, rtp);
CodeCoercion(rtp, ltp);
}
dsl = InitDesig;
CodeDesig(left, &dsl);
CodeAssign(nd, &dsr, &dsl);
/* Generate code for an assignment. Testing of type
compatibility and the like is already done.
*/
if (dsr.dsg_kind == DSG_LOADED) {
if (rtp->tp_fund == T_STRING) {
CodeAddress(&dsl);
C_loc(rtp->tp_size);
C_loc(ltp->tp_size);
C_cal("_StringAssign");
C_asp((int_size << 1) + (pointer_size << 1));
return;
}
CodeStore(&dsl, ltp->tp_size);
return;
}
CodeAddress(&dsl);
C_blm(ltp->tp_size);
}
RegisterMessages(df)