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-04-15 17:51:53 +00:00
parent 7d76f2829a
commit 426c273de8
17 changed files with 648 additions and 351 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -4,13 +4,16 @@ static char *RcsId = "$Header$";
#include <alloc.h>
#include <em_arith.h>
#include <em_label.h>
#include <assert.h>
#include "input.h"
#include "f_info.h"
#include "Lpars.h"
#include "class.h"
#include "idf.h"
#include "type.h"
#include "LLlex.h"
#include "const.h"
#define IDFSIZE 256 /* Number of significant characters in an identifier */
#define NUMSIZE 256 /* maximum number of characters in a number */
@ -18,6 +21,7 @@ static char *RcsId = "$Header$";
long str2long();
struct token dot, aside;
struct type *numtype;
struct string string;
static
@ -102,6 +106,7 @@ LLlex()
char buf[(IDFSIZE > NUMSIZE ? IDFSIZE : NUMSIZE) + 1];
register int ch, nch;
numtype = error_type;
if (ASIDE) { /* a token is put aside */
*tk = aside;
ASIDE = 0;
@ -236,7 +241,7 @@ again:
switch (ch) {
case 'H':
Shex: *np++ = '\0';
/* Type is integer */
numtype = card_type;
tk->TOK_INT = str2long(&buf[1], 16);
return tk->tk_symb = INTEGER;
@ -271,10 +276,10 @@ Shex: *np++ = '\0';
PushBack(ch);
ch = *--np;
*np++ = '\0';
/*
* If (ch == 'C') type is a CHAR
* else type is an INTEGER
*/
if (ch == 'C') {
numtype = char_type;
}
else numtype = card_type;
tk->TOK_INT = str2long(&buf[1], 8);
return tk->tk_symb = INTEGER;
@ -369,8 +374,11 @@ Sreal:
PushBack(ch);
Sdec:
*np++ = '\0';
/* Type is an integer */
tk->TOK_INT = str2long(&buf[1], 10);
if (tk->TOK_INT < 0 || tk->TOK_INT > max_int) {
numtype = card_type;
}
else numtype = intorcard_type;
return tk->tk_symb = INTEGER;
}
/*NOTREACHED*/

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

@ -28,6 +28,7 @@ struct token {
#define TOK_REL tk_data.tk_real
extern struct token dot, aside;
extern struct type *numtype;
#define DOT dot.tk_symb
#define ASIDE aside.tk_symb

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

@ -266,7 +266,9 @@ node_error(expp, "Size of type in type cast does not match size of operand");
}
arg->nd_type = left->nd_type;
FreeNode(expp->nd_left);
*expp = *(arg->nd_left);
expp->nd_right->nd_left = 0;
FreeNode(expp->nd_right);
*expp = *arg;
arg->nd_left = 0;
arg->nd_right = 0;
FreeNode(arg);
@ -451,8 +453,6 @@ findname(expp)
register struct def *df;
struct def *lookfor();
register struct type *tp;
int scope;
int module;
expp->nd_type = error_type;
if (expp->nd_class == Name) {
@ -596,7 +596,7 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
if (!TstCompat(tpl, tpr)) {
node_error(expp,
"Incompatible types for operator \"%s\"",
"incompatible types for operator \"%s\"",
symbol2str(expp->nd_symb));
return 0;
}

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

@ -14,6 +14,8 @@ static char *RcsId = "$Header$";
#include "scope.h"
#include "node.h"
#include "misc.h"
static int proclevel = 0; /* nesting level of procedures */
}
ProcedureDeclaration
@ -21,10 +23,13 @@ ProcedureDeclaration
struct def *df;
} :
ProcedureHeading(&df, D_PROCEDURE)
{ df->prc_level = proclevel++;
}
';' block IDENT
{ match_id(dot.TOK_IDF, df->df_idf);
df->prc_scope = CurrentScope->sc_scope;
df->prc_scope = CurrentScope;
close_scope(SC_CHKFORW);
proclevel--;
}
;
@ -36,38 +41,38 @@ ProcedureHeading(struct def **pdf; int type;)
register struct def *df;
} :
PROCEDURE IDENT
{ assert(type & (D_PROCEDURE | D_PROCHEAD));
if (type == D_PROCHEAD) {
df = define(dot.TOK_IDF, CurrentScope, type);
df->for_node = MkNode(Name, NULLNODE, NULLNODE, &dot);
}
else {
df = lookup(dot.TOK_IDF,
CurrentScope->sc_scope);
if (df && df->df_kind == D_PROCHEAD) {
df->df_kind = type;
tp1 = df->df_type;
}
else {
df = define(dot.TOK_IDF,
CurrentScope, type);
}
open_scope(OPENSCOPE, 0);
}
{ assert(type & (D_PROCEDURE | D_PROCHEAD));
if (type == D_PROCHEAD) {
df = define(dot.TOK_IDF, CurrentScope, type);
df->for_node = MkNode(Name, NULLNODE, NULLNODE, &dot);
}
else {
df = lookup(dot.TOK_IDF, CurrentScope);
if (df && df->df_kind == D_PROCHEAD) {
df->df_kind = type;
tp1 = df->df_type;
}
FormalParameters(type == D_PROCEDURE, &params, &tp)?
{
df->df_type = tp = construct_type(T_PROCEDURE, tp);
tp->prc_params = params;
if (tp1 && !TstTypeEquiv(tp, tp1)) {
else df = define(dot.TOK_IDF, CurrentScope, type);
df->prc_nbpar = 0;
open_scope(OPENSCOPE);
}
}
FormalParameters(type == D_PROCEDURE, &params, &tp, &(df->prc_nbpar))?
{
df->df_type = tp = construct_type(T_PROCEDURE, tp);
tp->prc_params = params;
if (tp1 && !TstTypeEquiv(tp, tp1)) {
error("inconsistent procedure declaration for \"%s\"", df->df_idf->id_text);
}
*pdf = df;
}
}
*pdf = df;
}
;
block:
declaration* [ BEGIN StatementSequence ]? END
block
{
struct node *nd;
}:
declaration* [ BEGIN StatementSequence(&nd) ]? END
;
declaration:
@ -82,18 +87,21 @@ declaration:
ModuleDeclaration ';'
;
FormalParameters(int doparams; struct paramlist **pr; struct type **tp;)
FormalParameters(int doparams;
struct paramlist **pr;
struct type **tp;
arith *parmaddr;)
{
struct def *df;
register struct paramlist *pr1;
} :
'('
[
FPSection(doparams, pr)
FPSection(doparams, pr, parmaddr)
{ pr1 = *pr; }
[
{ for (; pr1->next; pr1 = pr1->next) ; }
';' FPSection(doparams, &(pr1->next))
';' FPSection(doparams, &(pr1->next), &parmaddr)
]*
]?
')'
@ -109,7 +117,7 @@ FormalParameters(int doparams; struct paramlist **pr; struct type **tp;)
because in this case we only read the header. The Implementation
might contain different identifiers representing the same paramters.
*/
FPSection(int doparams; struct paramlist **ppr;)
FPSection(int doparams; struct paramlist **ppr; arith *addr;)
{
struct node *FPList;
struct paramlist *ParamList();
@ -122,7 +130,8 @@ FPSection(int doparams; struct paramlist **ppr;)
IdentList(&FPList) ':' FormalType(&tp)
{
if (doparams) {
EnterIdList(FPList, D_VARIABLE, VARp, tp, CurrentScope);
EnterIdList(FPList, D_VARIABLE, VARp,
tp, CurrentScope, addr);
}
*ppr = ParamList(FPList, tp, VARp);
FreeNode(FPList);
@ -140,6 +149,9 @@ FormalType(struct type **tp;)
{ if (ARRAYflag) {
*tp = construct_type(T_ARRAY, NULLTYPE);
(*tp)->arr_elem = df->df_type;
(*tp)->tp_align = lcm(wrd_align, ptr_align);
(*tp)->tp_size = align(ptr_size + 3*wrd_size,
(*tp)->tp_align);
}
else *tp = df->df_type;
}
@ -209,11 +221,20 @@ enumeration(struct type **ptp;)
} :
'(' IdentList(&EnumList) ')'
{
*ptp = standard_type(T_ENUMERATION,int_align,int_size);
EnterIdList(EnumList, D_ENUM, 0, *ptp, CurrentScope);
*ptp = standard_type(T_ENUMERATION,1,1);
EnterIdList(EnumList, D_ENUM, 0, *ptp,
CurrentScope, (arith *) 0);
FreeNode(EnumList);
if ((*ptp)->enm_ncst > 256) {
if (wrd_size == 1) {
error("Too many enumeration literals");
}
else {
(*ptp)->tp_size = wrd_size;
(*ptp)->tp_align = wrd_align;
}
}
}
;
IdentList(struct node **p;)
@ -261,44 +282,52 @@ ArrayType(struct type **ptp;)
construct_type(T_ARRAY, tp);
}
]* OF type(&tp)
{ tp2->arr_elem = tp; }
{ tp2->arr_elem = tp;
ArraySizes(*ptp);
}
;
RecordType(struct type **ptp;)
{
struct scope scope;
struct scope *scope;
arith count;
int xalign = record_align;
}
:
RECORD
{ scope.sc_scope = uniq_scope();
scope.next = CurrentScope;
{ open_scope(OPENSCOPE);
scope = CurrentScope;
close_scope(0);
count = 0;
}
FieldListSequence(&scope)
FieldListSequence(scope, &count, &xalign)
{
*ptp = standard_type(T_RECORD, record_align, (arith) 0 /* ???? */);
(*ptp)->rec_scope = scope.sc_scope;
*ptp = standard_type(T_RECORD, xalign, count);
(*ptp)->rec_scope = scope;
}
END
;
FieldListSequence(struct scope *scope;):
FieldList(scope)
FieldListSequence(struct scope *scope; arith *cnt; int *palign;):
FieldList(scope, cnt, palign)
[
';' FieldList(scope)
';' FieldList(scope, cnt, palign)
]*
;
FieldList(struct scope *scope;)
FieldList(struct scope *scope; arith *cnt; int *palign;)
{
struct node *FldList;
struct idf *id;
struct def *df, *df1;
struct def *df;
struct type *tp;
struct node *nd;
arith tcnt, max;
} :
[
IdentList(&FldList) ':' type(&tp)
{ EnterIdList(FldList, D_FIELD, 0, tp, scope);
{ *palign = lcm(*palign, tp->tp_align);
EnterIdList(FldList, D_FIELD, 0, tp, scope, cnt);
FreeNode(FldList);
}
|
@ -309,8 +338,7 @@ FieldList(struct scope *scope;)
[ /* This is good, in both kinds of Modula-2, if
the first qualident is a single identifier.
*/
{
if (nd->nd_class != Name) {
{ if (nd->nd_class != Name) {
error("illegal variant tag");
id = gen_anon_idf();
}
@ -322,8 +350,7 @@ FieldList(struct scope *scope;)
/* Old fashioned! the first qualident now represents
the type
*/
{
warning("Old fashioned Modula-2 syntax!");
{ warning("Old fashioned Modula-2 syntax!");
id = gen_anon_idf();
findname(nd);
assert(nd->nd_class == Def);
@ -338,42 +365,62 @@ FieldList(struct scope *scope;)
]
|
/* Aha, third edition? */
':' qualident(D_TYPE|D_HTYPE|D_HIDDEN,
&df,
"type",
(struct node **) 0)
{
id = gen_anon_idf();
}
':' qualident(D_TYPE|D_HTYPE|D_HIDDEN, &df, "type", (struct node **) 0)
{ id = gen_anon_idf(); }
]
{
df1 = define(id, scope, D_FIELD);
df1->df_type = df->df_type;
{ tp = df->df_type;
df = define(id, scope, D_FIELD);
df->df_type = tp;
df->fld_off = align(*cnt, tp->tp_align);
*cnt = tcnt = df->fld_off + tp->tp_size;
}
OF variant(scope)
OF variant(scope, &tcnt, tp, palign)
{ max = tcnt; tcnt = *cnt; }
[
'|' variant(scope)
'|' variant(scope, &tcnt, tp, palign)
{ if (tcnt > max) max = tcnt; }
]*
[ ELSE FieldListSequence(scope)
[ ELSE FieldListSequence(scope, &tcnt, palign)
{ if (tcnt > max) max = tcnt; }
]?
END
{ *cnt = max; }
]?
;
variant(struct scope *scope;):
[ CaseLabelList ':' FieldListSequence(scope) ]?
variant(struct scope *scope; arith *cnt; struct type *tp; int *palign;)
{
struct type *tp1 = tp;
} :
[
CaseLabelList(&tp1) ':' FieldListSequence(scope, cnt, palign)
]?
/* Changed rule in new modula-2 */
;
CaseLabelList:
CaseLabels [ ',' CaseLabels ]*
CaseLabelList(struct type **ptp;):
CaseLabels(ptp) [ ',' CaseLabels(ptp) ]*
;
CaseLabels
CaseLabels(struct type **ptp;)
{
struct node *nd1, *nd2 = 0;
}:
ConstExpression(&nd1) [ UPTO ConstExpression(&nd2) ]?
ConstExpression(&nd1)
[
UPTO ConstExpression(&nd2)
{ if (!TstCompat(nd1->nd_type, nd2->nd_type)) {
node_error(nd2,"type incompatibility in case label");
}
nd1->nd_type = error_type;
}
]?
{ if (*ptp != 0 &&
!TstCompat(*ptp, nd1->nd_type)) {
node_error(nd1,"type incompatibility in case label");
}
*ptp = nd1->nd_type;
}
;
SetType(struct type **ptp;)
@ -398,7 +445,7 @@ PointerType(struct type **ptp;)
struct node *nd;
} :
POINTER TO
[ %if ( (df = lookup(dot.TOK_IDF, CurrentScope->sc_scope)))
[ %if ( (df = lookup(dot.TOK_IDF, CurrentScope)))
/* Either a Module or a Type, but in both cases defined
in this scope, so this is the correct identification
*/
@ -489,14 +536,22 @@ VariableDeclaration
{
struct node *VarList;
struct type *tp;
struct node *nd = 0;
} :
IdentList(&VarList)
[
ConstExpression(&nd)
]?
IdentAddrList(&VarList)
':' type(&tp)
{ EnterIdList(VarList, D_VARIABLE, 0, tp, CurrentScope);
{ EnterVarList(VarList, tp, proclevel > 0);
FreeNode(VarList);
}
;
IdentAddrList(struct node **pnd;)
{
} :
IDENT { *pnd = MkNode(Name, NULLNODE, NULLNODE, &dot); }
ConstExpression(&(*pnd)->nd_left)?
[ { pnd = &((*pnd)->nd_right); }
',' IDENT
{ *pnd = MkNode(Name, NULLNODE, NULLNODE, &dot); }
ConstExpression(&(*pnd)->nd_left)?
]*
;

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

@ -4,14 +4,16 @@
struct module {
int mo_priority; /* priority of a module */
int mo_scope; /* scope of this module */
struct scope *mo_scope; /* scope of this module */
#define mod_priority df_value.df_module.mo_priority
#define mod_scope df_value.df_module.mo_scope
};
struct variable {
arith va_off; /* address or offset of variable */
char va_addrgiven; /* an address was given in the program */
#define var_off df_value.df_variable.va_off
#define var_addrgiven df_value.df_variable.va_addrgiven
};
struct constant {
@ -38,8 +40,12 @@ struct field {
};
struct dfproc {
int pr_scope; /* scope number of procedure */
struct scope *pr_scope; /* scope of procedure */
int pr_level; /* depth level of this procedure */
arith pr_nbpar; /* Number of bytes parameters */
#define prc_scope df_value.df_proc.pr_scope
#define prc_level df_value.df_proc.pr_level
#define prc_nbpar df_value.df_proc.pr_nbpar
};
struct import {
@ -48,7 +54,7 @@ struct import {
};
struct dforward {
int fo_scope;
struct scope *fo_scope;
struct node *fo_node;
#define for_node df_value.df_forward.fo_node
#define for_scope df_value.df_forward.fo_scope
@ -59,7 +65,7 @@ struct def { /* list of definitions for a name */
struct def *df_nextinscope;
/* link all definitions in a scope */
struct idf *df_idf; /* link back to the name */
int df_scope; /* scope in which this definition resides */
struct scope *df_scope; /* scope in which this definition resides */
short df_kind; /* the kind of this definition: */
#define D_MODULE 0x0001 /* a module */
#define D_PROCEDURE 0x0002 /* procedure of function */

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

@ -18,7 +18,7 @@ static char *RcsId = "$Header$";
struct def *h_def; /* Pointer to free list of def structures */
static struct def illegal_def =
{0, 0, 0, -20 /* Illegal scope */, D_ERROR};
{0, 0, 0, 0, D_ERROR};
struct def *ill_df = &illegal_def;
@ -32,17 +32,17 @@ define(id, scope, kind)
*/
register struct def *df;
DO_DEBUG(5, debug("Defining identifier \"%s\" in scope %d, kind = %d",
id->id_text, scope->sc_scope, kind));
df = lookup(id, scope->sc_scope);
DO_DEBUG(5, debug("Defining identifier \"%s\", kind = %d",
id->id_text, kind));
df = lookup(id, scope);
if ( /* Already in this scope */
df
|| /* A closed scope, and id defined in the pervasive scope */
( CurrentScope == scope
&&
scopeclosed(CurrentScope)
scopeclosed(scope)
&&
(df = lookup(id, 0)))
(df = lookup(id, PervasiveScope)))
) {
switch(df->df_kind) {
case D_PROCHEAD:
@ -62,7 +62,6 @@ define(id, scope, kind)
break;
case D_FORWMODULE:
if (kind == D_FORWMODULE) {
df->df_kind = kind;
return df;
}
if (kind == D_MODULE) {
@ -89,8 +88,9 @@ error("identifier \"%s\" already declared", id->id_text);
df = new_def();
df->df_flags = 0;
df->df_idf = id;
df->df_scope = scope->sc_scope;
df->df_scope = scope;
df->df_kind = kind;
df->df_type = 0;
df->next = id->id_def;
id->id_def = df;
@ -103,6 +103,7 @@ error("identifier \"%s\" already declared", id->id_text);
struct def *
lookup(id, scope)
register struct idf *id;
struct scope *scope;
{
/* Look up a definition of an identifier in scope "scope".
Make the "def" list self-organizing.
@ -114,7 +115,6 @@ lookup(id, scope)
df1 = 0;
df = id->id_def;
DO_DEBUG(5, debug("Looking for identifier \"%s\" in scope %d", id->id_text, scope));
while (df) {
if (df->df_scope == scope) {
retval = df;
@ -148,7 +148,7 @@ Export(ids, qualified)
struct node *nd = ids;
while (ids) {
df = lookup(ids->nd_IDF, CurrentScope->sc_scope);
df = lookup(ids->nd_IDF, CurrentScope);
if (df && (df->df_flags & (D_EXPORTED|D_QEXPORTED))) {
node_error(ids, "Identifier \"%s\" occurs more than once in export list",
df->df_idf->id_text);
@ -163,8 +163,7 @@ df->df_idf->id_text);
}
else {
df->df_flags |= D_EXPORTED;
df1 = lookup(ids->nd_IDF,
enclosing(CurrentScope)->sc_scope);
df1 = lookup(ids->nd_IDF, enclosing(CurrentScope));
if (! df1 || !(df1->df_kind & (D_PROCHEAD|D_HIDDEN))) {
df1 = define(ids->nd_IDF,
enclosing(CurrentScope),
@ -185,6 +184,49 @@ df->df_idf->id_text);
FreeNode(nd);
}
static struct scope *
ForwModule(df, idn)
register struct def *df;
struct node *idn;
{
/* An import is done from a not yet defined module "idn".
Create a declaration and a scope for this module.
*/
struct scope *scope;
df->df_scope = enclosing(CurrentScope);
df->df_kind = D_FORWMODULE;
open_scope(CLOSEDSCOPE);
scope = CurrentScope; /* The new scope, but watch out, it's "next"
field is not set right. It must indicate the
enclosing scope, but this must be done AFTER
closing this one
*/
df->for_scope = scope;
df->for_node = MkNode(Name, NULLNODE, NULLNODE, &(idn->nd_token));
close_scope(0);
scope->next = df->df_scope;
/* Here ! */
return scope;
}
static struct def *
ForwDef(ids, scope)
register struct node *ids;
struct scope *scope;
{
/* Enter a forward definition of "ids" in scope "scope",
if it is not already defined.
*/
register struct def *df;
if (!(df = lookup(ids->nd_IDF, scope))) {
df = define(ids->nd_IDF, scope, D_FORWARD);
df->for_node = MkNode(Name,NULLNODE,NULLNODE,&(ids->nd_token));
}
return df;
}
Import(ids, idn, local)
register struct node *ids;
struct node *idn;
@ -203,63 +245,51 @@ Import(ids, idn, local)
identifiers defined in this module.
*/
register struct def *df;
struct def *df1 = 0;
int scope;
int kind;
int imp_kind;
struct scope *scope = enclosing(CurrentScope);
int kind = D_IMPORT;
int forwflag = 0;
#define FROM_MODULE 0
#define FROM_ENCLOSING 1
int imp_kind = FROM_ENCLOSING;
struct def *lookfor(), *GetDefinitionModule();
kind = D_IMPORT;
scope = enclosing(CurrentScope)->sc_scope;
if (! idn) imp_kind = FROM_ENCLOSING;
else {
if (idn) {
imp_kind = FROM_MODULE;
if (local) {
df = lookfor(idn, enclosing(CurrentScope), 0);
if (df->df_kind == D_ERROR) {
df = lookfor(idn, scope, 0);
switch(df->df_kind) {
case D_ERROR:
/* The module from which the import was done
is not yet declared. I'm not sure if I must
accept this, but for the time being I will.
???
*/
df->df_scope = scope;
df->df_kind = D_FORWMODULE;
open_scope(CLOSEDSCOPE, 0);
df->for_scope = CurrentScope->sc_scope;
df->for_node = MkNode(Name, NULLNODE,
NULLNODE, &(idn->nd_token));
close_scope();
df1 = df;
}
}
else df = GetDefinitionModule(idn->nd_IDF);
if (!(df->df_kind & (D_MODULE|D_FORWMODULE))) {
/* enter all "ids" with type D_ERROR */
kind = D_ERROR;
if (df->df_kind != D_ERROR) {
scope = ForwModule(df, idn);
forwflag = 1;
break;
case D_FORWMODULE:
scope = df->for_scope;
break;
case D_MODULE:
scope = df->mod_scope;
break;
default:
kind = D_ERROR;
node_error(idn, "identifier \"%s\" does not represent a module",
idn->nd_IDF->id_text);
break;
}
}
else scope = df->mod_scope;
else scope = GetDefinitionModule(idn->nd_IDF)->mod_scope;
FreeNode(idn);
}
idn = ids;
while (ids) {
if (imp_kind == FROM_MODULE) {
if (df1 != 0) {
open_scope(CLOSEDSCOPE, df1->mod_scope);
df = define(ids->nd_IDF,
CurrentScope,
D_FORWARD);
df->for_node = MkNode(Name, NULLNODE,
NULLNODE, &(ids->nd_token));
close_scope(0);
if (forwflag) {
df = ForwDef(ids, scope);
}
else if (!(df = lookup(ids->nd_IDF, scope))) {
node_error(ids, "identifier \"%s\" not declared in qualifying module",
@ -272,29 +302,22 @@ ids->nd_IDF->id_text);
}
}
else {
if (local) {
df = lookfor(ids, enclosing(CurrentScope), 0);
} else df = GetDefinitionModule(ids->nd_IDF);
if (df->df_kind == D_ERROR) {
/* It was not yet defined in the enclosing
scope.
*/
df->df_kind = D_FORWARD;
df->for_node = MkNode(Name, NULLNODE, NULLNODE,
&(ids->nd_token));
}
if (local) df = ForwDef(ids, scope);
else df = GetDefinitionModule(ids->nd_IDF);
}
DO_DEBUG(2, debug("importing \"%s\", kind %d", ids->nd_IDF->id_text,
df->df_kind));
define(ids->nd_IDF, CurrentScope, kind)->imp_def = df;
if (df->df_kind == D_TYPE &&
df->df_type->tp_fund == T_ENUMERATION) {
/* Also import all enumeration literals */
exprt_literals(df->df_type->enm_enums,
CurrentScope);
/* Also import all enumeration literals
*/
exprt_literals(df->df_type->enm_enums, CurrentScope);
}
ids = ids->next;
}
FreeNode(idn);
}
@ -305,9 +328,9 @@ exprt_literals(df, toscope)
/* A list of enumeration literals is exported. This is implemented
as an import from the scope "toscope".
*/
DO_DEBUG(2, debug("enumeration import:"));
DO_DEBUG(3, debug("enumeration import:"));
while (df) {
DO_DEBUG(2, debug(df->df_idf->id_text));
DO_DEBUG(3, debug(df->df_idf->id_text));
define(df->df_idf, toscope, D_IMPORT)->imp_def = df;
df = df->enm_next;
}
@ -353,3 +376,11 @@ RemFromId(df)
df1->next = df->next;
}
}
#ifdef DEBUG
PrDef(df)
register struct def *df;
{
debug("name: %s, kind: %d", df->df_idf->id_text, df->df_kind);
}
#endif DEBUG

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

@ -49,7 +49,7 @@ GetDefinitionModule(id)
*/
struct def *df;
df = lookup(id, GlobalScope->sc_scope);
df = lookup(id, GlobalScope);
if (!df) {
/* Read definition module. Make an exception for SYSTEM.
*/
@ -60,7 +60,7 @@ GetDefinitionModule(id)
GetFile(id->id_text);
DefModule();
}
df = lookup(id, GlobalScope->sc_scope);
df = lookup(id, GlobalScope);
}
assert(df != 0 && df->df_kind == D_MODULE);
return df;

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

@ -35,10 +35,11 @@ Enter(name, kind, type, pnam)
return df;
}
EnterIdList(idlist, kind, flags, type, scope)
EnterIdList(idlist, kind, flags, type, scope, addr)
register struct node *idlist;
struct type *type;
struct scope *scope;
arith *addr;
{
/* Put a list of identifiers in the symbol table.
They all have kind "kind", and type "type", and are put
@ -50,11 +51,29 @@ EnterIdList(idlist, kind, flags, type, scope)
register struct def *df;
struct def *first = 0, *last = 0;
int assval = 0;
arith off;
while (idlist) {
df = define(idlist->nd_IDF, scope, kind);
df->df_type = type;
df->df_flags |= flags;
if (addr) {
if (*addr >= 0) {
off = align(*addr, type->tp_align);
*addr = off + type->tp_size;
}
else {
off = -align(-*addr, type->tp_align);
*addr = off - type->tp_size;
}
if (kind == D_VARIABLE) {
df->var_off = off;
}
else {
assert(kind == D_FIELD);
df->fld_off = off;
}
}
if (kind == D_ENUM) {
if (!first) first = df;
df->enm_val = assval++;
@ -72,6 +91,45 @@ EnterIdList(idlist, kind, flags, type, scope)
}
}
EnterVarList(IdList, type, local)
register struct node *IdList;
struct type *type;
{
register struct def *df;
struct scope *scope;
if (local) {
/* Find the closest enclosing open scope. This
is the procedure that we are dealing with
*/
scope = CurrentScope;
while (scope->sc_scopeclosed) scope = scope->next;
}
while (IdList) {
df = define(IdList->nd_IDF, CurrentScope, D_VARIABLE);
df->df_type = type;
if (IdList->nd_left) {
df->var_addrgiven = 1;
if (IdList->nd_left->nd_type != card_type) {
node_error(IdList->nd_left,"Illegal type for address");
}
df->var_off = IdList->nd_left->nd_INT;
}
else if (local) {
arith off;
/* add aligned size of variable to the offset
*/
off = scope->sc_off - type->tp_size;
off = -align(-off, type->tp_align);
df->var_off = off;
scope->sc_off = off;
}
IdList = IdList->nd_right;
}
}
struct def *
lookfor(id, scope, give_error)
struct node *id;
@ -86,7 +144,7 @@ lookfor(id, scope, give_error)
register struct scope *sc = scope;
while (sc) {
df = lookup(id->nd_IDF, sc->sc_scope);
df = lookup(id->nd_IDF, sc);
if (df) return df;
sc = nextvisible(sc);
}

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

@ -22,9 +22,7 @@ number(struct node **p;)
struct type *tp;
} :
[
INTEGER { tp = dot.TOK_INT <= max_int ?
intorcard_type : card_type;
}
INTEGER { tp = numtype; }
|
REAL { tp = real_type; }
] { *p = MkNode(Value, NULLNODE, NULLNODE, &dot);

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

@ -74,7 +74,7 @@ Compile(src)
if (options['L']) LexScan();
else {
#endif DEBUG
(void) open_scope(CLOSEDSCOPE, 0);
(void) open_scope(CLOSEDSCOPE);
GlobalScope = CurrentScope;
CompUnit();
#ifdef DEBUG
@ -192,7 +192,7 @@ PROCEDURE NEWPROCESS(P:PROC; A:ADDRESS; n:CARDINAL; VAR p1:ADDRESS);\n\
PROCEDURE TRANSFER(VAR p1,p2:ADDRESS);\n\
END SYSTEM.\n";
open_scope(CLOSEDSCOPE, 0);
open_scope(CLOSEDSCOPE);
(void) Enter("WORD", D_TYPE, word_type, 0);
(void) Enter("ADDRESS", D_TYPE, address_type, 0);
(void) Enter("ADR", D_PROCEDURE, std_type, S_ADR);
@ -202,7 +202,7 @@ END SYSTEM.\n";
}
SYSTEMModule = 1;
DefModule();
close_scope();
close_scope(0);
SYSTEMModule = 0;
}

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

@ -20,7 +20,6 @@ static int DEFofIMPL = 0; /* Flag indicating that we are currently
implementation module currently being
compiled
*/
static struct def *impl_df;
}
/*
The grammar as given by Wirth is already almost LL(1); the
@ -50,10 +49,10 @@ ModuleDeclaration
id = dot.TOK_IDF;
df = define(id, CurrentScope, D_MODULE);
if (!df->mod_scope) {
open_scope(CLOSEDSCOPE, 0);
df->mod_scope = CurrentScope->sc_scope;
open_scope(CLOSEDSCOPE);
df->mod_scope = CurrentScope;
}
else open_scope(CLOSEDSCOPE, df->mod_scope);
else CurrentScope = df->mod_scope;
df->df_type =
standard_type(T_RECORD, 0, (arith) 0);
df->df_type->rec_scope = df->mod_scope;
@ -123,8 +122,8 @@ DefinitionModule
DEFINITION
MODULE IDENT { id = dot.TOK_IDF;
df = define(id, GlobalScope, D_MODULE);
if (!SYSTEMModule) open_scope(CLOSEDSCOPE, 0);
df->mod_scope = CurrentScope->sc_scope;
if (!SYSTEMModule) open_scope(CLOSEDSCOPE);
df->mod_scope = CurrentScope;
df->df_type = standard_type(T_RECORD, 0, (arith) 0);
df->df_type->rec_scope = df->mod_scope;
DefinitionModule = 1;
@ -144,7 +143,6 @@ DefinitionModule
implementation module being compiled
*/
RemImports(&(CurrentScope->sc_def));
impl_df = CurrentScope->sc_def;
}
df = CurrentScope->sc_def;
while (df) {
@ -174,7 +172,8 @@ definition
The export is said to be opaque.
It is restricted to pointer types.
*/
{ df->df_kind = D_HIDDEN; }
{ df->df_kind = D_HIDDEN;
}
]
';'
]*
@ -188,20 +187,19 @@ ProgramModule(int state;)
{
struct idf *id;
struct def *df, *GetDefinitionModule();
int scope = 0;
struct scope *scope = 0;
} :
MODULE
IDENT {
id = dot.TOK_IDF;
if (state == IMPLEMENTATION) {
DEFofIMPL = 1;
df = GetDefinitionModule(id);
scope = df->mod_scope;
DEFofIMPL = 0;
DEFofIMPL = 1;
df = GetDefinitionModule(id);
CurrentScope = df->mod_scope;
DEFofIMPL = 0;
DefinitionModule = 0;
}
DefinitionModule = 0;
open_scope(CLOSEDSCOPE, scope);
CurrentScope->sc_def = impl_df;
else open_scope(CLOSEDSCOPE);
}
priority?
';' import(0)*

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

@ -14,40 +14,28 @@ static char *RcsId = "$Header$";
#include "node.h"
#include "debug.h"
static int maxscope; /* maximum assigned scope number */
struct scope *CurrentScope, *GlobalScope;
struct scope *CurrentScope, *PervasiveScope, *GlobalScope;
/* STATICALLOCDEF "scope" */
open_scope(scopetype, scope)
open_scope(scopetype)
{
/* Open a scope that is either open (automatic imports) or closed.
A closed scope is handled by adding an extra entry to the list
with scope number 0. This has two purposes: it makes scope 0
visible, and it marks the end of a visibility list.
Scope 0 is the pervasive scope, the one that is always visible.
A disadvantage of this method is that we cannot open scope 0
explicitly.
*/
register struct scope *sc = new_scope();
register struct scope *sc1;
sc->sc_scope = scope == 0 ? ++maxscope : scope;
assert(scopetype == OPENSCOPE || scopetype == CLOSEDSCOPE);
sc->sc_scopeclosed = scopetype == CLOSEDSCOPE;
sc->sc_forw = 0;
sc->sc_def = 0;
assert(scopetype == OPENSCOPE || scopetype == CLOSEDSCOPE);
sc->sc_off = 0;
sc->next = 0;
DO_DEBUG(1, debug("Opening a %s scope",
scopetype == OPENSCOPE ? "open" : "closed"));
sc1 = CurrentScope;
if (scopetype == CLOSEDSCOPE) {
sc1 = new_scope();
sc1->sc_scope = 0; /* Pervasive scope nr */
sc1->sc_forw = 0;
sc1->sc_def = 0;
sc1->next = CurrentScope;
if (CurrentScope != PervasiveScope) {
sc->next = CurrentScope;
}
sc->next = sc1;
CurrentScope = sc;
}
@ -55,18 +43,14 @@ init_scope()
{
register struct scope *sc = new_scope();
sc->sc_scope = 0;
sc->sc_scopeclosed = 0;
sc->sc_forw = 0;
sc->sc_def = 0;
sc->next = 0;
PervasiveScope = sc;
CurrentScope = sc;
}
int
uniq_scope()
{
return ++maxscope;
}
struct forwards {
struct forwards *next;
struct node fo_tok;
@ -92,73 +76,67 @@ Forward(tk, ptp)
CurrentScope->sc_forw = f;
}
close_scope(flag)
static
chk_proc(df)
register struct def *df;
{
/* Close a scope. If "flag" is set, check for forward declarations,
either POINTER declarations, or EXPORTs, or forward references
to MODULES
/* Called at scope closing. Check all definitions, and if one
is a D_PROCHEAD, the procedure was not defined
*/
register struct scope *sc = CurrentScope;
register struct def *df, *dfback = 0;
assert(sc != 0);
DO_DEBUG(1, debug("Closing a scope"));
if (flag) {
if (sc->sc_forw) rem_forwards(sc->sc_forw);
df = sc->sc_def;
while(df) {
if (flag & SC_CHKPROC) {
if (df->df_kind == D_PROCHEAD) {
/* A not defined procedure
*/
while (df) {
if (df->df_kind == D_PROCHEAD) {
/* A not defined procedure
*/
node_error(df->for_node, "procedure \"%s\" not defined", df->df_idf->id_text);
FreeNode(df->for_node);
}
}
if ((flag & SC_CHKFORW) &&
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!
FreeNode(df->for_node);
}
df = df->df_nextinscope;
}
}
static
chk_forw(pdf)
register struct def **pdf;
{
/* Called at scope close. Look for all forward definitions and
if the scope was a closed scope, give an error message for
them, and otherwise move them to the enclosing scope.
*/
while (*pdf) {
if ((*pdf)->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!
*/
struct def *df1 = (*pdf)->df_nextinscope;
if (scopeclosed(CurrentScope)) {
/* Indeed, the scope was a closed
scope, so give error message
*/
struct def *df1 = df->df_nextinscope;
if (scopeclosed(CurrentScope)) {
/* Indeed, the scope was a closed
scope, so give error message
*/
node_error(df->for_node, "identifier \"%s\" not declared", df->df_idf->id_text);
FreeNode(df->for_node);
dfback = df;
}
else {
/* This scope was an open scope.
Maybe the definitions are in the
enclosing scope?
*/
struct scope *sc;
sc = enclosing(CurrentScope);
df->df_nextinscope = sc->sc_def;
sc->sc_def = df;
df->df_scope = sc->sc_scope;
if (dfback) dfback->df_nextinscope = df1;
else sc->sc_def = df1;
}
df = df1;
node_error((*pdf)->for_node, "identifier \"%s\" has not been declared",
(*pdf)->df_idf->id_text);
FreeNode((*pdf)->for_node);
pdf = &(*pdf)->df_nextinscope;
}
else {
dfback = df;
df = df->df_nextinscope;
else { /* This scope was an open scope.
Maybe the definitions are in the
enclosing scope?
*/
struct scope *sc;
sc = enclosing(CurrentScope);
if ((*pdf)->df_kind == D_FORWMODULE) {
(*pdf)->for_scope->next = sc;
}
(*pdf)->df_nextinscope = sc->sc_def;
sc->sc_def = *pdf;
(*pdf)->df_scope = sc;
*pdf = df1;
}
}
else pdf = &(*pdf)->df_nextinscope;
}
if (sc->next && (sc->next->sc_scope == 0)) {
sc = sc->next;
}
CurrentScope = sc->next;
}
static
@ -182,3 +160,35 @@ rem_forwards(fo)
free_forwards(f);
}
}
close_scope(flag)
{
/* Close a scope. If "flag" is set, check for forward declarations,
either POINTER declarations, or EXPORTs, or forward references
to MODULES
*/
register struct scope *sc = CurrentScope;
assert(sc != 0);
DO_DEBUG(1, debug("Closing a scope"));
if (flag) {
if (sc->sc_forw) rem_forwards(sc->sc_forw);
DO_DEBUG(2, PrScopeDef(sc->sc_def));
if (flag & SC_CHKPROC) chk_proc(sc->sc_def);
if (flag & SC_CHKFORW) chk_forw(&(sc->sc_def));
}
CurrentScope = sc->next;
}
#ifdef DEBUG
PrScopeDef(df)
register struct def *df;
{
debug("List of definitions in currently ended scope:");
while (df) {
PrDef(df);
df = df->df_nextinscope;
}
}
#endif

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

@ -16,16 +16,15 @@ struct scope {
struct scope *next;
struct forwards *sc_forw;
struct def *sc_def; /* list of definitions in this scope */
int sc_scope; /* The scope number. Scope number 0 indicates
both the pervasive scope and the end of a
visibility range
*/
arith sc_off; /* offsets of variables in this scope */
char sc_scopeclosed; /* flag indicating closed or open scope */
};
extern struct scope
*CurrentScope,
*PervasiveScope,
*GlobalScope;
#define nextvisible(x) ((x)->sc_scope ? (x)->next : (struct scope *) 0)
#define scopeclosed(x) ((x)->next->sc_scope == 0)
#define enclosing(x) (scopeclosed(x) ? (x)->next->next : (x)->next)
#define enclosing(x) ((x)->next)
#define scopeclosed(x) ((x)->sc_scopeclosed)
#define nextvisible(x) (scopeclosed(x) ? PervasiveScope : enclosing(x))

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

@ -6,12 +6,15 @@ static char *RcsId = "$Header$";
#include <em_arith.h>
#include "LLlex.h"
#include "node.h"
static int loopcount = 0; /* Count nested loops */
}
statement
statement(struct node **pnd;)
{
struct node *nd1, *nd2 = 0;
struct node *nd1;
} :
{ *pnd = 0; }
[
/*
* This part is not in the reference grammar. The reference grammar
@ -19,38 +22,45 @@ statement
* but this gives LL(1) conflicts
*/
designator(&nd1)
[
ActualParameters(&nd2)?
{ nd1 = MkNode(Call, nd1, nd2, &dot);
[ { nd1 = MkNode(Call, nd1, NULLNODE, &dot);
nd1->nd_symb = '(';
}
ActualParameters(&(nd1->nd_right))?
|
BECOMES { nd1 = MkNode(Stat, nd1, NULLNODE, &dot); }
expression(&(nd1->nd_right))
]
{ *pnd = nd1; }
/*
* end of changed part
*/
|
IfStatement
IfStatement(pnd)
|
CaseStatement
CaseStatement(pnd)
|
WhileStatement
WhileStatement(pnd)
|
RepeatStatement
RepeatStatement(pnd)
|
LoopStatement
{ loopcount++; }
LoopStatement(pnd)
{ loopcount--; }
|
ForStatement
ForStatement(pnd)
|
WithStatement
WithStatement(pnd)
|
EXIT
{ if (!loopcount) {
error("EXIT not in a LOOP");
}
*pnd = MkNode(Stat, NULLNODE, NULLNODE, &dot);
}
|
RETURN
RETURN { *pnd = MkNode(Stat, NULLNODE, NULLNODE, &dot); }
[
expression(&nd1)
expression(&((*pnd)->nd_right))
]?
]?
;
@ -67,66 +77,132 @@ ProcedureCall:
;
*/
StatementSequence:
statement [ ';' statement ]*
StatementSequence(struct node **pnd;):
statement(pnd)
[
';' { *pnd = MkNode(Link, *pnd, NULLNODE, &dot);
pnd = &((*pnd)->nd_right);
}
statement(pnd)
]*
;
IfStatement
IfStatement(struct node **pnd;)
{
struct node *nd1;
register struct node *nd;
} :
IF expression(&nd1) THEN StatementSequence
[ ELSIF expression(&nd1) THEN StatementSequence ]*
[ ELSE StatementSequence ]?
IF { nd = MkNode(Stat, NULLNODE, NULLNODE, &dot);
*pnd = nd;
}
expression(&(nd->nd_left))
THEN { nd = MkNode(Link, NULLNODE, NULLNODE, &dot);
(*pnd)->nd_right = nd;
}
StatementSequence(&(nd->nd_left))
[
ELSIF { nd->nd_right = MkNode(Stat,NULLNODE,NULLNODE,&dot);
nd = nd->nd_right;
nd->nd_symb = IF;
}
expression(&(nd->nd_left))
THEN { nd->nd_right = MkNode(Link,NULLNODE,NULLNODE,&dot);
nd = nd->nd_right;
}
StatementSequence(&(nd->nd_left))
]*
[
ELSE
StatementSequence(&(nd->nd_right))
]?
END
;
CaseStatement
CaseStatement(struct node **pnd;)
{
struct node *nd;
register struct node *nd;
struct type *tp = 0;
} :
CASE expression(&nd) OF case [ '|' case ]*
[ ELSE StatementSequence ]?
CASE { *pnd = nd = MkNode(Stat, NULLNODE, NULLNODE, &dot); }
expression(&(nd->nd_left))
OF
case(&(nd->nd_right), &tp)
{ nd = nd->nd_right; }
[
'|'
case(&(nd->nd_right), &tp)
{ nd = nd->nd_right; }
]*
[ ELSE StatementSequence(&(nd->nd_right)) ]?
END
;
case:
[ CaseLabelList ':' StatementSequence ]?
case(struct node **pnd; struct type **ptp;) :
{ *pnd = 0; }
[ CaseLabelList(ptp/*,pnd*/)
':' { *pnd = MkNode(Link, *pnd, NULLNODE, &dot); }
StatementSequence(&((*pnd)->nd_right))
]?
/* This rule is changed in new modula-2 */
{ *pnd = MkNode(Link, *pnd, NULLNODE, &dot);
(*pnd)->nd_symb = '|';
}
;
WhileStatement
WhileStatement(struct node **pnd;)
{
struct node *nd;
register struct node *nd;
}:
WHILE expression(&nd) DO StatementSequence END
WHILE { *pnd = nd = MkNode(Stat, NULLNODE, NULLNODE, &dot); }
expression(&(nd->nd_left))
DO
StatementSequence(&(nd->nd_right))
END
;
RepeatStatement
RepeatStatement(struct node **pnd;)
{
struct node *nd;
register struct node *nd;
}:
REPEAT StatementSequence UNTIL expression(&nd)
REPEAT { *pnd = nd = MkNode(Stat, NULLNODE, NULLNODE, &dot); }
StatementSequence(&(nd->nd_left))
UNTIL
expression(&(nd->nd_right))
;
ForStatement
ForStatement(struct node **pnd;)
{
struct node *nd1, *nd2, *nd3;
register struct node *nd;
}:
FOR IDENT
BECOMES expression(&nd1)
TO expression(&nd2)
[ BY ConstExpression(&nd3) ]?
DO StatementSequence END
FOR { *pnd = MkNode(Stat, NULLNODE, NULLNODE, &dot); }
IDENT { nd = MkNode(Name, NULLNODE, NULLNODE, &dot); }
BECOMES { nd = MkNode(BECOMES, nd, NULLNODE, &dot); }
expression(&(nd->nd_right))
TO { (*pnd)->nd_left=nd=MkNode(Link,nd,NULLNODE,&dot); }
expression(&(nd->nd_right))
[
BY { nd->nd_right=MkNode(Link,NULLNODE,nd->nd_right,&dot);
}
ConstExpression(&(nd->nd_right->nd_left))
|
]
DO
StatementSequence(&((*pnd)->nd_right))
END
;
LoopStatement:
LOOP StatementSequence END
LoopStatement(struct node **pnd;):
LOOP { *pnd = MkNode(Stat, NULLNODE, NULLNODE, &dot); }
StatementSequence(&((*pnd)->nd_right))
END
;
WithStatement
WithStatement(struct node **pnd;)
{
struct node *nd;
register struct node *nd;
}:
WITH designator(&nd) DO StatementSequence END
WITH { *pnd = nd = MkNode(Stat, NULLNODE, NULLNODE, &dot); }
designator(&(nd->nd_left))
DO
StatementSequence(&(nd->nd_right))
END
;

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

@ -38,8 +38,8 @@ struct array {
};
struct record {
int rc_scope; /* Scope number of this record */
/* Members are in the symbol table */
struct scope *rc_scope; /* scope of this record */
/* members are in the symbol table */
#define rec_scope tp_value.tp_record.rc_scope
};
@ -71,6 +71,7 @@ struct type {
#define T_INTORCARD (T_INTEGER|T_CARDINAL)
#define T_DISCRETE (T_ENUMERATION|T_INTORCARD|T_CHAR)
#define T_NUMERIC (T_INTORCARD|T_REAL)
#define T_INDEX (T_ENUMERATION|T_CHAR|T_SUBRANGE)
int tp_align; /* alignment requirement of this type */
arith tp_size; /* size of this type */
union {

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

@ -151,24 +151,6 @@ init_types()
error_type = standard_type(T_CHAR, 1, (arith) 1);
}
int
has_selectors(df)
register struct def *df;
{
switch(df->df_kind) {
case D_MODULE:
return df->df_value.df_module.mo_scope;
case D_VARIABLE:
if (df->df_type->tp_fund == T_RECORD) {
return df->df_type->rec_scope;
}
break;
}
error("no selectors for \"%s\"", df->df_idf->id_text);
return 0;
}
/* Create a parameterlist of a procedure and return a pointer to it.
"ids" indicates the list of identifiers, "tp" their type, and
"VARp" is set when the parameters are VAR-parameters.
@ -226,6 +208,8 @@ chk_basesubrange(tp, base)
error("Specified base does not conform");
}
tp->next = base;
tp->tp_size = base->tp_size;
tp->tp_align = base->tp_align;
}
struct type *
@ -236,7 +220,7 @@ subr_type(lb, ub)
indicated by "lb" and "ub", but first perform some
checks
*/
register struct type *tp = lb->nd_type;
register struct type *tp = lb->nd_type, *res;
if (!TstCompat(lb->nd_type, ub->nd_type)) {
node_error(ub, "Types of subrange bounds not compatible");
@ -264,11 +248,13 @@ subr_type(lb, ub)
/* Now construct resulting type
*/
tp = construct_type(T_SUBRANGE, tp);
tp->sub_lb = lb->nd_INT;
tp->sub_ub = ub->nd_INT;
res = construct_type(T_SUBRANGE, tp);
res->sub_lb = lb->nd_INT;
res->sub_ub = ub->nd_INT;
res->tp_size = tp->tp_size;
res->tp_align = tp->tp_align;
DO_DEBUG(2,debug("Creating subrange type %ld-%ld", (long)lb->nd_INT,(long)ub->nd_INT));
return tp;
return res;
}
#define MAX_SET 1024 /* ??? Maximum number of elements in a set */
@ -302,3 +288,71 @@ set_type(tp)
tp->tp_size = align(((ub - lb) + 7)/8, wrd_align);
return tp;
}
ArraySizes(tp)
register struct type *tp;
{
/* Assign sizes to an array type
*/
arith elem_size;
register struct type *itype = tp->next; /* the index type */
if (tp->arr_elem->tp_fund == T_ARRAY) {
ArraySizes(tp->arr_elem);
}
elem_size = align(tp->arr_elem->tp_size, tp->arr_elem->tp_align);
tp->tp_align = tp->arr_elem->tp_align;
if (! (itype->tp_fund & T_INDEX)) {
error("Illegal index type");
tp->tp_size = 0;
return;
}
switch(itype->tp_fund) {
case T_SUBRANGE:
tp->arr_lb = itype->sub_lb;
tp->arr_ub = itype->sub_ub;
tp->tp_size = elem_size * (itype->sub_ub - itype->sub_lb + 1);
break;
case T_CHAR:
case T_ENUMERATION:
tp->arr_lb = 0;
tp->arr_ub = itype->enm_ncst - 1;
tp->tp_size = elem_size * itype->enm_ncst;
break;
default:
assert(0);
}
/* ??? overflow checking ??? */
}
int
gcd(m, n)
register int m, n;
{
/* Greatest Common Divisor
*/
register int r;
while (n) {
r = m % n;
m = n;
n = r;
}
return m;
}
int
lcm(m, n)
register int m, n;
{
/* Least Common Multiple
*/
while (m != n) {
if (m < n) m = m + m;
else n = n + n;
}
return n; /* or m */
}

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

@ -2,6 +2,9 @@
static char *RcsId = "$Header$";
/* Routines for testing type equivalence, type compatibility, and
assignment compatibility
*/
#include <em_arith.h>
#include <em_label.h>
#include "type.h"
@ -15,8 +18,8 @@ TstTypeEquiv(tp1, tp2)
from the fact that for some procedures two declarations may
be given: one in the specification module and one in the
definition module.
A related problem is that two dynamic arrays with the
same base type are also equivalent.
A related problem is that two dynamic arrays with
equivalent base types are also equivalent.
*/
return tp1 == tp2
@ -66,8 +69,7 @@ TstProcEquiv(tp1, tp2)
p1 = p1->next;
p2 = p2->next;
}
if (p1 != p2) return 0;
return 1;
return p1 == p2;
}
int