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

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

@ -28,6 +28,7 @@ struct token {
#define TOK_REL tk_data.tk_real #define TOK_REL tk_data.tk_real
extern struct token dot, aside; extern struct token dot, aside;
extern struct type *numtype;
#define DOT dot.tk_symb #define DOT dot.tk_symb
#define ASIDE aside.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; arg->nd_type = left->nd_type;
FreeNode(expp->nd_left); 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_left = 0;
arg->nd_right = 0; arg->nd_right = 0;
FreeNode(arg); FreeNode(arg);
@ -451,8 +453,6 @@ findname(expp)
register struct def *df; register struct def *df;
struct def *lookfor(); struct def *lookfor();
register struct type *tp; register struct type *tp;
int scope;
int module;
expp->nd_type = error_type; expp->nd_type = error_type;
if (expp->nd_class == Name) { 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)) { if (!TstCompat(tpl, tpr)) {
node_error(expp, node_error(expp,
"Incompatible types for operator \"%s\"", "incompatible types for operator \"%s\"",
symbol2str(expp->nd_symb)); symbol2str(expp->nd_symb));
return 0; return 0;
} }

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

@ -14,6 +14,8 @@ static char *RcsId = "$Header$";
#include "scope.h" #include "scope.h"
#include "node.h" #include "node.h"
#include "misc.h" #include "misc.h"
static int proclevel = 0; /* nesting level of procedures */
} }
ProcedureDeclaration ProcedureDeclaration
@ -21,10 +23,13 @@ ProcedureDeclaration
struct def *df; struct def *df;
} : } :
ProcedureHeading(&df, D_PROCEDURE) ProcedureHeading(&df, D_PROCEDURE)
{ df->prc_level = proclevel++;
}
';' block IDENT ';' block IDENT
{ match_id(dot.TOK_IDF, df->df_idf); { match_id(dot.TOK_IDF, df->df_idf);
df->prc_scope = CurrentScope->sc_scope; df->prc_scope = CurrentScope;
close_scope(SC_CHKFORW); close_scope(SC_CHKFORW);
proclevel--;
} }
; ;
@ -36,38 +41,38 @@ ProcedureHeading(struct def **pdf; int type;)
register struct def *df; register struct def *df;
} : } :
PROCEDURE IDENT PROCEDURE IDENT
{ assert(type & (D_PROCEDURE | D_PROCHEAD)); { assert(type & (D_PROCEDURE | D_PROCHEAD));
if (type == D_PROCHEAD) { if (type == D_PROCHEAD) {
df = define(dot.TOK_IDF, CurrentScope, type); df = define(dot.TOK_IDF, CurrentScope, type);
df->for_node = MkNode(Name, NULLNODE, NULLNODE, &dot); df->for_node = MkNode(Name, NULLNODE, NULLNODE, &dot);
} }
else { else {
df = lookup(dot.TOK_IDF, df = lookup(dot.TOK_IDF, CurrentScope);
CurrentScope->sc_scope); if (df && df->df_kind == D_PROCHEAD) {
if (df && df->df_kind == D_PROCHEAD) { df->df_kind = type;
df->df_kind = type; tp1 = df->df_type;
tp1 = df->df_type;
}
else {
df = define(dot.TOK_IDF,
CurrentScope, type);
}
open_scope(OPENSCOPE, 0);
}
} }
FormalParameters(type == D_PROCEDURE, &params, &tp)? else df = define(dot.TOK_IDF, CurrentScope, type);
{ df->prc_nbpar = 0;
df->df_type = tp = construct_type(T_PROCEDURE, tp); open_scope(OPENSCOPE);
tp->prc_params = params; }
if (tp1 && !TstTypeEquiv(tp, tp1)) { }
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); error("inconsistent procedure declaration for \"%s\"", df->df_idf->id_text);
} }
*pdf = df; *pdf = df;
} }
; ;
block: block
declaration* [ BEGIN StatementSequence ]? END {
struct node *nd;
}:
declaration* [ BEGIN StatementSequence(&nd) ]? END
; ;
declaration: declaration:
@ -82,18 +87,21 @@ declaration:
ModuleDeclaration ';' ModuleDeclaration ';'
; ;
FormalParameters(int doparams; struct paramlist **pr; struct type **tp;) FormalParameters(int doparams;
struct paramlist **pr;
struct type **tp;
arith *parmaddr;)
{ {
struct def *df; struct def *df;
register struct paramlist *pr1; register struct paramlist *pr1;
} : } :
'(' '('
[ [
FPSection(doparams, pr) FPSection(doparams, pr, parmaddr)
{ pr1 = *pr; } { pr1 = *pr; }
[ [
{ for (; pr1->next; pr1 = pr1->next) ; } { 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 because in this case we only read the header. The Implementation
might contain different identifiers representing the same paramters. 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 node *FPList;
struct paramlist *ParamList(); struct paramlist *ParamList();
@ -122,7 +130,8 @@ FPSection(int doparams; struct paramlist **ppr;)
IdentList(&FPList) ':' FormalType(&tp) IdentList(&FPList) ':' FormalType(&tp)
{ {
if (doparams) { if (doparams) {
EnterIdList(FPList, D_VARIABLE, VARp, tp, CurrentScope); EnterIdList(FPList, D_VARIABLE, VARp,
tp, CurrentScope, addr);
} }
*ppr = ParamList(FPList, tp, VARp); *ppr = ParamList(FPList, tp, VARp);
FreeNode(FPList); FreeNode(FPList);
@ -140,6 +149,9 @@ FormalType(struct type **tp;)
{ if (ARRAYflag) { { if (ARRAYflag) {
*tp = construct_type(T_ARRAY, NULLTYPE); *tp = construct_type(T_ARRAY, NULLTYPE);
(*tp)->arr_elem = df->df_type; (*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; else *tp = df->df_type;
} }
@ -209,11 +221,20 @@ enumeration(struct type **ptp;)
} : } :
'(' IdentList(&EnumList) ')' '(' IdentList(&EnumList) ')'
{ {
*ptp = standard_type(T_ENUMERATION,int_align,int_size); *ptp = standard_type(T_ENUMERATION,1,1);
EnterIdList(EnumList, D_ENUM, 0, *ptp, CurrentScope); EnterIdList(EnumList, D_ENUM, 0, *ptp,
CurrentScope, (arith *) 0);
FreeNode(EnumList); 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;) IdentList(struct node **p;)
@ -261,44 +282,52 @@ ArrayType(struct type **ptp;)
construct_type(T_ARRAY, tp); construct_type(T_ARRAY, tp);
} }
]* OF type(&tp) ]* OF type(&tp)
{ tp2->arr_elem = tp; } { tp2->arr_elem = tp;
ArraySizes(*ptp);
}
; ;
RecordType(struct type **ptp;) RecordType(struct type **ptp;)
{ {
struct scope scope; struct scope *scope;
arith count;
int xalign = record_align;
} }
: :
RECORD RECORD
{ scope.sc_scope = uniq_scope(); { open_scope(OPENSCOPE);
scope.next = CurrentScope; scope = CurrentScope;
close_scope(0);
count = 0;
} }
FieldListSequence(&scope) FieldListSequence(scope, &count, &xalign)
{ {
*ptp = standard_type(T_RECORD, record_align, (arith) 0 /* ???? */); *ptp = standard_type(T_RECORD, xalign, count);
(*ptp)->rec_scope = scope.sc_scope; (*ptp)->rec_scope = scope;
} }
END END
; ;
FieldListSequence(struct scope *scope;): FieldListSequence(struct scope *scope; arith *cnt; int *palign;):
FieldList(scope) 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 node *FldList;
struct idf *id; struct idf *id;
struct def *df, *df1; struct def *df;
struct type *tp; struct type *tp;
struct node *nd; struct node *nd;
arith tcnt, max;
} : } :
[ [
IdentList(&FldList) ':' type(&tp) 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); FreeNode(FldList);
} }
| |
@ -309,8 +338,7 @@ FieldList(struct scope *scope;)
[ /* This is good, in both kinds of Modula-2, if [ /* This is good, in both kinds of Modula-2, if
the first qualident is a single identifier. the first qualident is a single identifier.
*/ */
{ { if (nd->nd_class != Name) {
if (nd->nd_class != Name) {
error("illegal variant tag"); error("illegal variant tag");
id = gen_anon_idf(); id = gen_anon_idf();
} }
@ -322,8 +350,7 @@ FieldList(struct scope *scope;)
/* Old fashioned! the first qualident now represents /* Old fashioned! the first qualident now represents
the type the type
*/ */
{ { warning("Old fashioned Modula-2 syntax!");
warning("Old fashioned Modula-2 syntax!");
id = gen_anon_idf(); id = gen_anon_idf();
findname(nd); findname(nd);
assert(nd->nd_class == Def); assert(nd->nd_class == Def);
@ -338,42 +365,62 @@ FieldList(struct scope *scope;)
] ]
| |
/* Aha, third edition? */ /* Aha, third edition? */
':' qualident(D_TYPE|D_HTYPE|D_HIDDEN, ':' qualident(D_TYPE|D_HTYPE|D_HIDDEN, &df, "type", (struct node **) 0)
&df, { id = gen_anon_idf(); }
"type",
(struct node **) 0)
{
id = gen_anon_idf();
}
] ]
{ { tp = df->df_type;
df1 = define(id, scope, D_FIELD); df = define(id, scope, D_FIELD);
df1->df_type = df->df_type; 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 END
{ *cnt = max; }
]? ]?
; ;
variant(struct scope *scope;): variant(struct scope *scope; arith *cnt; struct type *tp; int *palign;)
[ CaseLabelList ':' FieldListSequence(scope) ]? {
struct type *tp1 = tp;
} :
[
CaseLabelList(&tp1) ':' FieldListSequence(scope, cnt, palign)
]?
/* Changed rule in new modula-2 */ /* Changed rule in new modula-2 */
; ;
CaseLabelList: CaseLabelList(struct type **ptp;):
CaseLabels [ ',' CaseLabels ]* CaseLabels(ptp) [ ',' CaseLabels(ptp) ]*
; ;
CaseLabels CaseLabels(struct type **ptp;)
{ {
struct node *nd1, *nd2 = 0; 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;) SetType(struct type **ptp;)
@ -398,7 +445,7 @@ PointerType(struct type **ptp;)
struct node *nd; struct node *nd;
} : } :
POINTER TO 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 /* Either a Module or a Type, but in both cases defined
in this scope, so this is the correct identification in this scope, so this is the correct identification
*/ */
@ -489,14 +536,22 @@ VariableDeclaration
{ {
struct node *VarList; struct node *VarList;
struct type *tp; struct type *tp;
struct node *nd = 0;
} : } :
IdentList(&VarList) IdentAddrList(&VarList)
[
ConstExpression(&nd)
]?
':' type(&tp) ':' type(&tp)
{ EnterIdList(VarList, D_VARIABLE, 0, tp, CurrentScope); { EnterVarList(VarList, tp, proclevel > 0);
FreeNode(VarList); 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 { struct module {
int mo_priority; /* priority of a 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_priority df_value.df_module.mo_priority
#define mod_scope df_value.df_module.mo_scope #define mod_scope df_value.df_module.mo_scope
}; };
struct variable { struct variable {
arith va_off; /* address or offset of 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_off df_value.df_variable.va_off
#define var_addrgiven df_value.df_variable.va_addrgiven
}; };
struct constant { struct constant {
@ -38,8 +40,12 @@ struct field {
}; };
struct dfproc { 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_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 { struct import {
@ -48,7 +54,7 @@ struct import {
}; };
struct dforward { struct dforward {
int fo_scope; struct scope *fo_scope;
struct node *fo_node; struct node *fo_node;
#define for_node df_value.df_forward.fo_node #define for_node df_value.df_forward.fo_node
#define for_scope df_value.df_forward.fo_scope #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; struct def *df_nextinscope;
/* link all definitions in a scope */ /* link all definitions in a scope */
struct idf *df_idf; /* link back to the name */ 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: */ short df_kind; /* the kind of this definition: */
#define D_MODULE 0x0001 /* a module */ #define D_MODULE 0x0001 /* a module */
#define D_PROCEDURE 0x0002 /* procedure of function */ #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 */ struct def *h_def; /* Pointer to free list of def structures */
static struct def illegal_def = 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; struct def *ill_df = &illegal_def;
@ -32,17 +32,17 @@ define(id, scope, kind)
*/ */
register struct def *df; register struct def *df;
DO_DEBUG(5, debug("Defining identifier \"%s\" in scope %d, kind = %d", DO_DEBUG(5, debug("Defining identifier \"%s\", kind = %d",
id->id_text, scope->sc_scope, kind)); id->id_text, kind));
df = lookup(id, scope->sc_scope); df = lookup(id, scope);
if ( /* Already in this scope */ if ( /* Already in this scope */
df df
|| /* A closed scope, and id defined in the pervasive scope */ || /* A closed scope, and id defined in the pervasive scope */
( CurrentScope == scope ( CurrentScope == scope
&& &&
scopeclosed(CurrentScope) scopeclosed(scope)
&& &&
(df = lookup(id, 0))) (df = lookup(id, PervasiveScope)))
) { ) {
switch(df->df_kind) { switch(df->df_kind) {
case D_PROCHEAD: case D_PROCHEAD:
@ -62,7 +62,6 @@ define(id, scope, kind)
break; break;
case D_FORWMODULE: case D_FORWMODULE:
if (kind == D_FORWMODULE) { if (kind == D_FORWMODULE) {
df->df_kind = kind;
return df; return df;
} }
if (kind == D_MODULE) { if (kind == D_MODULE) {
@ -89,8 +88,9 @@ error("identifier \"%s\" already declared", id->id_text);
df = new_def(); df = new_def();
df->df_flags = 0; df->df_flags = 0;
df->df_idf = id; df->df_idf = id;
df->df_scope = scope->sc_scope; df->df_scope = scope;
df->df_kind = kind; df->df_kind = kind;
df->df_type = 0;
df->next = id->id_def; df->next = id->id_def;
id->id_def = df; id->id_def = df;
@ -103,6 +103,7 @@ error("identifier \"%s\" already declared", id->id_text);
struct def * struct def *
lookup(id, scope) lookup(id, scope)
register struct idf *id; register struct idf *id;
struct scope *scope;
{ {
/* Look up a definition of an identifier in scope "scope". /* Look up a definition of an identifier in scope "scope".
Make the "def" list self-organizing. Make the "def" list self-organizing.
@ -114,7 +115,6 @@ lookup(id, scope)
df1 = 0; df1 = 0;
df = id->id_def; df = id->id_def;
DO_DEBUG(5, debug("Looking for identifier \"%s\" in scope %d", id->id_text, scope));
while (df) { while (df) {
if (df->df_scope == scope) { if (df->df_scope == scope) {
retval = df; retval = df;
@ -148,7 +148,7 @@ Export(ids, qualified)
struct node *nd = ids; struct node *nd = ids;
while (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))) { if (df && (df->df_flags & (D_EXPORTED|D_QEXPORTED))) {
node_error(ids, "Identifier \"%s\" occurs more than once in export list", node_error(ids, "Identifier \"%s\" occurs more than once in export list",
df->df_idf->id_text); df->df_idf->id_text);
@ -163,8 +163,7 @@ df->df_idf->id_text);
} }
else { else {
df->df_flags |= D_EXPORTED; df->df_flags |= D_EXPORTED;
df1 = lookup(ids->nd_IDF, df1 = lookup(ids->nd_IDF, enclosing(CurrentScope));
enclosing(CurrentScope)->sc_scope);
if (! df1 || !(df1->df_kind & (D_PROCHEAD|D_HIDDEN))) { if (! df1 || !(df1->df_kind & (D_PROCHEAD|D_HIDDEN))) {
df1 = define(ids->nd_IDF, df1 = define(ids->nd_IDF,
enclosing(CurrentScope), enclosing(CurrentScope),
@ -185,6 +184,49 @@ df->df_idf->id_text);
FreeNode(nd); 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) Import(ids, idn, local)
register struct node *ids; register struct node *ids;
struct node *idn; struct node *idn;
@ -203,63 +245,51 @@ Import(ids, idn, local)
identifiers defined in this module. identifiers defined in this module.
*/ */
register struct def *df; register struct def *df;
struct def *df1 = 0; struct scope *scope = enclosing(CurrentScope);
int scope; int kind = D_IMPORT;
int kind; int forwflag = 0;
int imp_kind;
#define FROM_MODULE 0 #define FROM_MODULE 0
#define FROM_ENCLOSING 1 #define FROM_ENCLOSING 1
int imp_kind = FROM_ENCLOSING;
struct def *lookfor(), *GetDefinitionModule(); struct def *lookfor(), *GetDefinitionModule();
kind = D_IMPORT; if (idn) {
scope = enclosing(CurrentScope)->sc_scope;
if (! idn) imp_kind = FROM_ENCLOSING;
else {
imp_kind = FROM_MODULE; imp_kind = FROM_MODULE;
if (local) { if (local) {
df = lookfor(idn, enclosing(CurrentScope), 0); df = lookfor(idn, scope, 0);
if (df->df_kind == D_ERROR) { switch(df->df_kind) {
case D_ERROR:
/* The module from which the import was done /* The module from which the import was done
is not yet declared. I'm not sure if I must is not yet declared. I'm not sure if I must
accept this, but for the time being I will. accept this, but for the time being I will.
??? ???
*/ */
df->df_scope = scope; scope = ForwModule(df, idn);
df->df_kind = D_FORWMODULE; forwflag = 1;
open_scope(CLOSEDSCOPE, 0); break;
df->for_scope = CurrentScope->sc_scope; case D_FORWMODULE:
df->for_node = MkNode(Name, NULLNODE, scope = df->for_scope;
NULLNODE, &(idn->nd_token)); break;
close_scope(); case D_MODULE:
df1 = df; scope = df->mod_scope;
} break;
} default:
else df = GetDefinitionModule(idn->nd_IDF); kind = D_ERROR;
if (!(df->df_kind & (D_MODULE|D_FORWMODULE))) {
/* enter all "ids" with type D_ERROR */
kind = D_ERROR;
if (df->df_kind != D_ERROR) {
node_error(idn, "identifier \"%s\" does not represent a module", node_error(idn, "identifier \"%s\" does not represent a module",
idn->nd_IDF->id_text); idn->nd_IDF->id_text);
break;
} }
} }
else scope = df->mod_scope; else scope = GetDefinitionModule(idn->nd_IDF)->mod_scope;
FreeNode(idn); FreeNode(idn);
} }
idn = ids; idn = ids;
while (ids) { while (ids) {
if (imp_kind == FROM_MODULE) { if (imp_kind == FROM_MODULE) {
if (df1 != 0) { if (forwflag) {
open_scope(CLOSEDSCOPE, df1->mod_scope); df = ForwDef(ids, scope);
df = define(ids->nd_IDF,
CurrentScope,
D_FORWARD);
df->for_node = MkNode(Name, NULLNODE,
NULLNODE, &(ids->nd_token));
close_scope(0);
} }
else if (!(df = lookup(ids->nd_IDF, scope))) { else if (!(df = lookup(ids->nd_IDF, scope))) {
node_error(ids, "identifier \"%s\" not declared in qualifying module", node_error(ids, "identifier \"%s\" not declared in qualifying module",
@ -272,29 +302,22 @@ ids->nd_IDF->id_text);
} }
} }
else { else {
if (local) { if (local) df = ForwDef(ids, scope);
df = lookfor(ids, enclosing(CurrentScope), 0); else df = GetDefinitionModule(ids->nd_IDF);
} 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));
}
} }
DO_DEBUG(2, debug("importing \"%s\", kind %d", ids->nd_IDF->id_text, DO_DEBUG(2, debug("importing \"%s\", kind %d", ids->nd_IDF->id_text,
df->df_kind)); df->df_kind));
define(ids->nd_IDF, CurrentScope, kind)->imp_def = df; define(ids->nd_IDF, CurrentScope, kind)->imp_def = df;
if (df->df_kind == D_TYPE && if (df->df_kind == D_TYPE &&
df->df_type->tp_fund == T_ENUMERATION) { df->df_type->tp_fund == T_ENUMERATION) {
/* Also import all enumeration literals */ /* Also import all enumeration literals
exprt_literals(df->df_type->enm_enums, */
CurrentScope); exprt_literals(df->df_type->enm_enums, CurrentScope);
} }
ids = ids->next; ids = ids->next;
} }
FreeNode(idn); FreeNode(idn);
} }
@ -305,9 +328,9 @@ exprt_literals(df, toscope)
/* A list of enumeration literals is exported. This is implemented /* A list of enumeration literals is exported. This is implemented
as an import from the scope "toscope". as an import from the scope "toscope".
*/ */
DO_DEBUG(2, debug("enumeration import:")); DO_DEBUG(3, debug("enumeration import:"));
while (df) { 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; define(df->df_idf, toscope, D_IMPORT)->imp_def = df;
df = df->enm_next; df = df->enm_next;
} }
@ -353,3 +376,11 @@ RemFromId(df)
df1->next = df->next; 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; struct def *df;
df = lookup(id, GlobalScope->sc_scope); df = lookup(id, GlobalScope);
if (!df) { if (!df) {
/* Read definition module. Make an exception for SYSTEM. /* Read definition module. Make an exception for SYSTEM.
*/ */
@ -60,7 +60,7 @@ GetDefinitionModule(id)
GetFile(id->id_text); GetFile(id->id_text);
DefModule(); DefModule();
} }
df = lookup(id, GlobalScope->sc_scope); df = lookup(id, GlobalScope);
} }
assert(df != 0 && df->df_kind == D_MODULE); assert(df != 0 && df->df_kind == D_MODULE);
return df; return df;

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

@ -35,10 +35,11 @@ Enter(name, kind, type, pnam)
return df; return df;
} }
EnterIdList(idlist, kind, flags, type, scope) EnterIdList(idlist, kind, flags, type, scope, addr)
register struct node *idlist; register struct node *idlist;
struct type *type; struct type *type;
struct scope *scope; struct scope *scope;
arith *addr;
{ {
/* Put a list of identifiers in the symbol table. /* Put a list of identifiers in the symbol table.
They all have kind "kind", and type "type", and are put 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; register struct def *df;
struct def *first = 0, *last = 0; struct def *first = 0, *last = 0;
int assval = 0; int assval = 0;
arith off;
while (idlist) { while (idlist) {
df = define(idlist->nd_IDF, scope, kind); df = define(idlist->nd_IDF, scope, kind);
df->df_type = type; df->df_type = type;
df->df_flags |= flags; 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 (kind == D_ENUM) {
if (!first) first = df; if (!first) first = df;
df->enm_val = assval++; 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 * struct def *
lookfor(id, scope, give_error) lookfor(id, scope, give_error)
struct node *id; struct node *id;
@ -86,7 +144,7 @@ lookfor(id, scope, give_error)
register struct scope *sc = scope; register struct scope *sc = scope;
while (sc) { while (sc) {
df = lookup(id->nd_IDF, sc->sc_scope); df = lookup(id->nd_IDF, sc);
if (df) return df; if (df) return df;
sc = nextvisible(sc); sc = nextvisible(sc);
} }

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

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

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

@ -74,7 +74,7 @@ Compile(src)
if (options['L']) LexScan(); if (options['L']) LexScan();
else { else {
#endif DEBUG #endif DEBUG
(void) open_scope(CLOSEDSCOPE, 0); (void) open_scope(CLOSEDSCOPE);
GlobalScope = CurrentScope; GlobalScope = CurrentScope;
CompUnit(); CompUnit();
#ifdef DEBUG #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\ PROCEDURE TRANSFER(VAR p1,p2:ADDRESS);\n\
END SYSTEM.\n"; END SYSTEM.\n";
open_scope(CLOSEDSCOPE, 0); open_scope(CLOSEDSCOPE);
(void) Enter("WORD", D_TYPE, word_type, 0); (void) Enter("WORD", D_TYPE, word_type, 0);
(void) Enter("ADDRESS", D_TYPE, address_type, 0); (void) Enter("ADDRESS", D_TYPE, address_type, 0);
(void) Enter("ADR", D_PROCEDURE, std_type, S_ADR); (void) Enter("ADR", D_PROCEDURE, std_type, S_ADR);
@ -202,7 +202,7 @@ END SYSTEM.\n";
} }
SYSTEMModule = 1; SYSTEMModule = 1;
DefModule(); DefModule();
close_scope(); close_scope(0);
SYSTEMModule = 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 implementation module currently being
compiled compiled
*/ */
static struct def *impl_df;
} }
/* /*
The grammar as given by Wirth is already almost LL(1); the The grammar as given by Wirth is already almost LL(1); the
@ -50,10 +49,10 @@ ModuleDeclaration
id = dot.TOK_IDF; id = dot.TOK_IDF;
df = define(id, CurrentScope, D_MODULE); df = define(id, CurrentScope, D_MODULE);
if (!df->mod_scope) { if (!df->mod_scope) {
open_scope(CLOSEDSCOPE, 0); open_scope(CLOSEDSCOPE);
df->mod_scope = CurrentScope->sc_scope; df->mod_scope = CurrentScope;
} }
else open_scope(CLOSEDSCOPE, df->mod_scope); else CurrentScope = df->mod_scope;
df->df_type = df->df_type =
standard_type(T_RECORD, 0, (arith) 0); standard_type(T_RECORD, 0, (arith) 0);
df->df_type->rec_scope = df->mod_scope; df->df_type->rec_scope = df->mod_scope;
@ -123,8 +122,8 @@ DefinitionModule
DEFINITION DEFINITION
MODULE IDENT { id = dot.TOK_IDF; MODULE IDENT { id = dot.TOK_IDF;
df = define(id, GlobalScope, D_MODULE); df = define(id, GlobalScope, D_MODULE);
if (!SYSTEMModule) open_scope(CLOSEDSCOPE, 0); if (!SYSTEMModule) open_scope(CLOSEDSCOPE);
df->mod_scope = CurrentScope->sc_scope; df->mod_scope = CurrentScope;
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_scope; df->df_type->rec_scope = df->mod_scope;
DefinitionModule = 1; DefinitionModule = 1;
@ -144,7 +143,6 @@ DefinitionModule
implementation module being compiled implementation module being compiled
*/ */
RemImports(&(CurrentScope->sc_def)); RemImports(&(CurrentScope->sc_def));
impl_df = CurrentScope->sc_def;
} }
df = CurrentScope->sc_def; df = CurrentScope->sc_def;
while (df) { while (df) {
@ -174,7 +172,8 @@ definition
The export is said to be opaque. The export is said to be opaque.
It is restricted to pointer types. 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 idf *id;
struct def *df, *GetDefinitionModule(); struct def *df, *GetDefinitionModule();
int scope = 0; struct scope *scope = 0;
} : } :
MODULE MODULE
IDENT { IDENT {
id = dot.TOK_IDF; id = dot.TOK_IDF;
if (state == IMPLEMENTATION) { if (state == IMPLEMENTATION) {
DEFofIMPL = 1; DEFofIMPL = 1;
df = GetDefinitionModule(id); df = GetDefinitionModule(id);
scope = df->mod_scope; CurrentScope = df->mod_scope;
DEFofIMPL = 0; DEFofIMPL = 0;
DefinitionModule = 0;
} }
DefinitionModule = 0; else open_scope(CLOSEDSCOPE);
open_scope(CLOSEDSCOPE, scope);
CurrentScope->sc_def = impl_df;
} }
priority? priority?
';' import(0)* ';' import(0)*

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

@ -14,40 +14,28 @@ static char *RcsId = "$Header$";
#include "node.h" #include "node.h"
#include "debug.h" #include "debug.h"
static int maxscope; /* maximum assigned scope number */ struct scope *CurrentScope, *PervasiveScope, *GlobalScope;
struct scope *CurrentScope, *GlobalScope;
/* STATICALLOCDEF "scope" */ /* STATICALLOCDEF "scope" */
open_scope(scopetype, scope) open_scope(scopetype)
{ {
/* Open a scope that is either open (automatic imports) or closed. /* 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 *sc = new_scope();
register struct scope *sc1; 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_forw = 0;
sc->sc_def = 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", DO_DEBUG(1, debug("Opening a %s scope",
scopetype == OPENSCOPE ? "open" : "closed")); scopetype == OPENSCOPE ? "open" : "closed"));
sc1 = CurrentScope; if (CurrentScope != PervasiveScope) {
if (scopetype == CLOSEDSCOPE) { sc->next = CurrentScope;
sc1 = new_scope();
sc1->sc_scope = 0; /* Pervasive scope nr */
sc1->sc_forw = 0;
sc1->sc_def = 0;
sc1->next = CurrentScope;
} }
sc->next = sc1;
CurrentScope = sc; CurrentScope = sc;
} }
@ -55,18 +43,14 @@ init_scope()
{ {
register struct scope *sc = new_scope(); register struct scope *sc = new_scope();
sc->sc_scope = 0; sc->sc_scopeclosed = 0;
sc->sc_forw = 0; sc->sc_forw = 0;
sc->sc_def = 0; sc->sc_def = 0;
sc->next = 0;
PervasiveScope = sc;
CurrentScope = sc; CurrentScope = sc;
} }
int
uniq_scope()
{
return ++maxscope;
}
struct forwards { struct forwards {
struct forwards *next; struct forwards *next;
struct node fo_tok; struct node fo_tok;
@ -92,73 +76,67 @@ Forward(tk, ptp)
CurrentScope->sc_forw = f; 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, /* Called at scope closing. Check all definitions, and if one
either POINTER declarations, or EXPORTs, or forward references is a D_PROCHEAD, the procedure was not defined
to MODULES
*/ */
register struct scope *sc = CurrentScope; while (df) {
register struct def *df, *dfback = 0; if (df->df_kind == D_PROCHEAD) {
/* A not defined procedure
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
*/
node_error(df->for_node, "procedure \"%s\" not defined", df->df_idf->id_text); node_error(df->for_node, "procedure \"%s\" not defined", df->df_idf->id_text);
FreeNode(df->for_node); FreeNode(df->for_node);
} }
} df = df->df_nextinscope;
if ((flag & SC_CHKFORW) && }
df->df_kind & (D_FORWARD|D_FORWMODULE)) { }
/* These definitions must be found in
the enclosing closed scope, which of course static
may be the scope that is now closed! 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; node_error((*pdf)->for_node, "identifier \"%s\" has not been declared",
(*pdf)->df_idf->id_text);
if (scopeclosed(CurrentScope)) { FreeNode((*pdf)->for_node);
/* Indeed, the scope was a closed pdf = &(*pdf)->df_nextinscope;
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;
} }
else { else { /* This scope was an open scope.
dfback = df; Maybe the definitions are in the
df = df->df_nextinscope; 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 static
@ -182,3 +160,35 @@ rem_forwards(fo)
free_forwards(f); 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 scope *next;
struct forwards *sc_forw; struct forwards *sc_forw;
struct def *sc_def; /* list of definitions in this scope */ struct def *sc_def; /* list of definitions in this scope */
int sc_scope; /* The scope number. Scope number 0 indicates arith sc_off; /* offsets of variables in this scope */
both the pervasive scope and the end of a char sc_scopeclosed; /* flag indicating closed or open scope */
visibility range
*/
}; };
extern struct scope extern struct scope
*CurrentScope, *CurrentScope,
*PervasiveScope,
*GlobalScope; *GlobalScope;
#define nextvisible(x) ((x)->sc_scope ? (x)->next : (struct scope *) 0) #define enclosing(x) ((x)->next)
#define scopeclosed(x) ((x)->next->sc_scope == 0) #define scopeclosed(x) ((x)->sc_scopeclosed)
#define enclosing(x) (scopeclosed(x) ? (x)->next->next : (x)->next) #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 <em_arith.h>
#include "LLlex.h" #include "LLlex.h"
#include "node.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 * This part is not in the reference grammar. The reference grammar
@ -19,38 +22,45 @@ statement
* but this gives LL(1) conflicts * but this gives LL(1) conflicts
*/ */
designator(&nd1) designator(&nd1)
[ [ { nd1 = MkNode(Call, nd1, NULLNODE, &dot);
ActualParameters(&nd2)?
{ nd1 = MkNode(Call, nd1, nd2, &dot);
nd1->nd_symb = '('; nd1->nd_symb = '(';
} }
ActualParameters(&(nd1->nd_right))?
| |
BECOMES { nd1 = MkNode(Stat, nd1, NULLNODE, &dot); } BECOMES { nd1 = MkNode(Stat, nd1, NULLNODE, &dot); }
expression(&(nd1->nd_right)) expression(&(nd1->nd_right))
] ]
{ *pnd = nd1; }
/* /*
* end of changed part * 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 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: StatementSequence(struct node **pnd;):
statement [ ';' statement ]* 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 IF { nd = MkNode(Stat, NULLNODE, NULLNODE, &dot);
[ ELSIF expression(&nd1) THEN StatementSequence ]* *pnd = nd;
[ ELSE StatementSequence ]? }
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 END
; ;
CaseStatement CaseStatement(struct node **pnd;)
{ {
struct node *nd; register struct node *nd;
struct type *tp = 0;
} : } :
CASE expression(&nd) OF case [ '|' case ]* CASE { *pnd = nd = MkNode(Stat, NULLNODE, NULLNODE, &dot); }
[ ELSE StatementSequence ]? 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 END
; ;
case: case(struct node **pnd; struct type **ptp;) :
[ CaseLabelList ':' StatementSequence ]? { *pnd = 0; }
[ CaseLabelList(ptp/*,pnd*/)
':' { *pnd = MkNode(Link, *pnd, NULLNODE, &dot); }
StatementSequence(&((*pnd)->nd_right))
]?
/* This rule is changed in new modula-2 */ /* 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 FOR { *pnd = MkNode(Stat, NULLNODE, NULLNODE, &dot); }
BECOMES expression(&nd1) IDENT { nd = MkNode(Name, NULLNODE, NULLNODE, &dot); }
TO expression(&nd2) BECOMES { nd = MkNode(BECOMES, nd, NULLNODE, &dot); }
[ BY ConstExpression(&nd3) ]? expression(&(nd->nd_right))
DO StatementSequence END 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: LoopStatement(struct node **pnd;):
LOOP StatementSequence END 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 { struct record {
int rc_scope; /* Scope number of this record */ struct scope *rc_scope; /* scope of this record */
/* Members are in the symbol table */ /* members are in the symbol table */
#define rec_scope tp_value.tp_record.rc_scope #define rec_scope tp_value.tp_record.rc_scope
}; };
@ -71,6 +71,7 @@ struct type {
#define T_INTORCARD (T_INTEGER|T_CARDINAL) #define T_INTORCARD (T_INTEGER|T_CARDINAL)
#define T_DISCRETE (T_ENUMERATION|T_INTORCARD|T_CHAR) #define T_DISCRETE (T_ENUMERATION|T_INTORCARD|T_CHAR)
#define T_NUMERIC (T_INTORCARD|T_REAL) #define T_NUMERIC (T_INTORCARD|T_REAL)
#define T_INDEX (T_ENUMERATION|T_CHAR|T_SUBRANGE)
int tp_align; /* alignment requirement of this type */ int tp_align; /* alignment requirement of this type */
arith tp_size; /* size of this type */ arith tp_size; /* size of this type */
union { union {

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

@ -151,24 +151,6 @@ init_types()
error_type = standard_type(T_CHAR, 1, (arith) 1); 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. /* Create a parameterlist of a procedure and return a pointer to it.
"ids" indicates the list of identifiers, "tp" their type, and "ids" indicates the list of identifiers, "tp" their type, and
"VARp" is set when the parameters are VAR-parameters. "VARp" is set when the parameters are VAR-parameters.
@ -226,6 +208,8 @@ chk_basesubrange(tp, base)
error("Specified base does not conform"); error("Specified base does not conform");
} }
tp->next = base; tp->next = base;
tp->tp_size = base->tp_size;
tp->tp_align = base->tp_align;
} }
struct type * struct type *
@ -236,7 +220,7 @@ subr_type(lb, ub)
indicated by "lb" and "ub", but first perform some indicated by "lb" and "ub", but first perform some
checks checks
*/ */
register struct type *tp = lb->nd_type; register struct type *tp = lb->nd_type, *res;
if (!TstCompat(lb->nd_type, ub->nd_type)) { if (!TstCompat(lb->nd_type, ub->nd_type)) {
node_error(ub, "Types of subrange bounds not compatible"); node_error(ub, "Types of subrange bounds not compatible");
@ -264,11 +248,13 @@ subr_type(lb, ub)
/* Now construct resulting type /* Now construct resulting type
*/ */
tp = construct_type(T_SUBRANGE, tp); res = construct_type(T_SUBRANGE, tp);
tp->sub_lb = lb->nd_INT; res->sub_lb = lb->nd_INT;
tp->sub_ub = ub->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)); 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 */ #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); tp->tp_size = align(((ub - lb) + 7)/8, wrd_align);
return tp; 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$"; static char *RcsId = "$Header$";
/* Routines for testing type equivalence, type compatibility, and
assignment compatibility
*/
#include <em_arith.h> #include <em_arith.h>
#include <em_label.h> #include <em_label.h>
#include "type.h" #include "type.h"
@ -15,8 +18,8 @@ TstTypeEquiv(tp1, tp2)
from the fact that for some procedures two declarations may from the fact that for some procedures two declarations may
be given: one in the specification module and one in the be given: one in the specification module and one in the
definition module. definition module.
A related problem is that two dynamic arrays with the A related problem is that two dynamic arrays with
same base type are also equivalent. equivalent base types are also equivalent.
*/ */
return tp1 == tp2 return tp1 == tp2
@ -66,8 +69,7 @@ TstProcEquiv(tp1, tp2)
p1 = p1->next; p1 = p1->next;
p2 = p2->next; p2 = p2->next;
} }
if (p1 != p2) return 0; return p1 == p2;
return 1;
} }
int int