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-22 22:36:16 +00:00
parent de21842485
commit fef8659bf1
19 changed files with 420 additions and 121 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -182,7 +182,7 @@ again:
}
else
if (nch == '>') {
return tk->tk_symb = UNEQUAL;
return tk->tk_symb = '#';
}
PushBack(nch);
return tk->tk_symb = ch;
@ -219,7 +219,9 @@ again:
case STSTR:
GetString(ch);
tk->tk_data.tk_str = string;
tk->tk_data.tk_str = (struct string *)
Malloc(sizeof (struct string));
*(tk->tk_data.tk_str) = string;
return tk->tk_symb = STRING;
case STNUM:

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

@ -13,7 +13,7 @@ struct token {
int tk_lineno; /* linenumber on which it occurred */
union {
struct idf *tk_idf; /* IDENT */
struct string tk_str; /* STRING */
struct string *tk_str; /* STRING */
arith tk_int; /* INTEGER */
char *tk_real; /* REAL */
arith *tk_set; /* only used in parse tree node */
@ -22,8 +22,8 @@ struct token {
};
#define TOK_IDF tk_data.tk_idf
#define TOK_STR tk_data.tk_str.s_str
#define TOK_SLE tk_data.tk_str.s_length
#define TOK_STR tk_data.tk_str->s_str
#define TOK_SLE tk_data.tk_str->s_length
#define TOK_INT tk_data.tk_int
#define TOK_REL tk_data.tk_real

8
lang/m2/comp/Makefile
View file

@ -82,12 +82,12 @@ LLlex.o: LLlex.h Lpars.h class.h const.h f_info.h idf.h idfsize.h input.h inputt
LLmessage.o: LLlex.h Lpars.h idf.h
char.o: class.h
error.o: LLlex.h debug.h errout.h f_info.h input.h inputtype.h main.h node.h
main.o: LLlex.h Lpars.h debug.h def.h f_info.h idf.h input.h inputtype.h scope.h standards.h tokenname.h type.h
main.o: LLlex.h Lpars.h debug.h def.h f_info.h idf.h input.h inputtype.h node.h scope.h standards.h tokenname.h type.h
symbol2str.o: Lpars.h
tokenname.o: Lpars.h idf.h tokenname.h
idf.o: idf.h
input.o: f_info.h input.h inputtype.h
type.o: LLlex.h const.h debug.h def.h idf.h node.h target_sizes.h type.h
type.o: LLlex.h const.h debug.h def.h idf.h maxset.h node.h target_sizes.h type.h
def.o: LLlex.h debug.h def.h idf.h main.h node.h scope.h type.h
scope.o: LLlex.h debug.h def.h idf.h node.h scope.h type.h
misc.o: LLlex.h f_info.h idf.h misc.h node.h
@ -98,10 +98,10 @@ node.o: LLlex.h debug.h def.h node.h type.h
cstoper.o: LLlex.h Lpars.h idf.h node.h standards.h target_sizes.h type.h
chk_expr.o: LLlex.h Lpars.h const.h debug.h def.h idf.h node.h scope.h standards.h type.h
options.o: idfsize.h type.h
walk.o: debug.h def.h main.h scope.h type.h
walk.o: LLlex.h Lpars.h debug.h def.h main.h node.h scope.h type.h
tokenfile.o: Lpars.h
program.o: LLlex.h Lpars.h debug.h def.h idf.h main.h node.h scope.h type.h
declar.o: LLlex.h Lpars.h def.h idf.h main.h misc.h node.h scope.h type.h
expression.o: LLlex.h Lpars.h const.h debug.h def.h idf.h node.h scope.h type.h
statement.o: LLlex.h Lpars.h node.h type.h
statement.o: LLlex.h Lpars.h def.h idf.h node.h scope.h type.h
Lpars.o: Lpars.h

6
lang/m2/comp/Parameters
View file

@ -58,3 +58,9 @@ extern char options[];
#undef INP_READ_IN_ONE 1 /* read input file in one */
!File: maxset.h
#define MAXSET 1024 /* maximum number of elements in a set,
but what is a reasonable choice ???
*/

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

@ -63,6 +63,7 @@ chk_expr(expp)
case Link:
return chk_name(expp);
default:
assert(0);
}
@ -85,32 +86,42 @@ chk_set(expp)
/* First determine the type of the set
*/
if (expp->nd_left) {
if (nd = expp->nd_left) {
/* A type was given. Check it out
*/
findname(expp->nd_left);
assert(expp->nd_left->nd_class == Def);
df = expp->nd_left->nd_def;
findname(nd);
assert(nd->nd_class == Def);
df = nd->nd_def;
if (!(df->df_kind & (D_TYPE|D_ERROR)) ||
(df->df_type->tp_fund != T_SET)) {
node_error(expp, "illegal set type");
node_error(expp, "specifier does not represent a set type");
return 0;
}
tp = df->df_type;
FreeNode(expp->nd_left);
expp->nd_left = 0;
}
else tp = bitset_type;
/* Now check the elements given, and try to compute a constant set.
First allocate room for the set
*/
set = (arith *)
Malloc((unsigned) (tp->tp_size * sizeof(arith) / word_size));
/* Now check the elements, one by one
*/
nd = expp->nd_right;
while (nd) {
assert(nd->nd_class == Link && nd->nd_symb == ',');
if (!chk_el(nd->nd_left, tp->next, &set)) return 0;
nd = nd->nd_right;
}
expp->nd_type = tp;
if (set) {
/* Yes, it was a constant set, and we managed to compute it!
Notice that at the moment there is no such thing as
@ -119,10 +130,10 @@ chk_set(expp)
*/
expp->nd_class = Set;
expp->nd_set = set;
FreeNode(expp->nd_left);
FreeNode(expp->nd_right);
expp->nd_left = expp->nd_right = 0;
expp->nd_right = 0;
}
return 1;
}
@ -137,35 +148,38 @@ chk_el(expp, tp, set)
Also try to compute the set!
*/
register int i;
register struct node *left = expp->nd_left;
register struct node *right = expp->nd_right;
if (expp->nd_class == Link && expp->nd_symb == UPTO) {
/* { ... , expr1 .. expr2, ... }
First check expr1 and expr2, and try to compute them.
*/
if (!chk_el(expp->nd_left, tp, set) ||
!chk_el(expp->nd_right, tp, set)) {
if (!chk_el(left, tp, set) || !chk_el(right, tp, set)) {
return 0;
}
if (expp->nd_left->nd_class == Value &&
expp->nd_right->nd_class == Value) {
if (left->nd_class == Value && right->nd_class == Value) {
/* We have a constant range. Put all elements in the
set
*/
if (expp->nd_left->nd_INT > expp->nd_right->nd_INT) {
if (left->nd_INT > right->nd_INT) {
node_error(expp, "lower bound exceeds upper bound in range");
return rem_set(set);
}
if (*set) for (i = expp->nd_left->nd_INT + 1;
i < expp->nd_right->nd_INT; i++) {
if (*set) {
for (i=left->nd_INT+1; i<right->nd_INT; i++) {
(*set)[i/wrd_bits] |= (1<<(i%wrd_bits));
}
}
}
else if (*set) {
free((char *) *set);
*set = 0;
}
return 1;
}
@ -174,12 +188,17 @@ node_error(expp, "lower bound exceeds upper bound in range");
if (!chk_expr(expp)) {
return rem_set(set);
}
if (!TstCompat(tp, expp->nd_type)) {
node_error(expp, "set element has incompatible type");
return rem_set(set);
}
if (expp->nd_class == Value) {
/* a constant element
*/
i = expp->nd_INT;
if ((tp->tp_fund != T_ENUMERATION &&
(i < tp->sub_lb || i > tp->sub_ub))
||
@ -189,8 +208,10 @@ node_error(expp, "lower bound exceeds upper bound in range");
node_error(expp, "set element out of range");
return rem_set(set);
}
if (*set) (*set)[i/wrd_bits] |= (1 << (i%wrd_bits));
}
return 1;
}
@ -552,7 +573,7 @@ findname(expp)
expp->nd_type = df->df_type;
if (!(df->df_flags & (D_EXPORTED|D_QEXPORTED))) {
node_error(expp->nd_right,
"identifier \"%s\" not exprted from qualifying module",
"identifier \"%s\" not exported from qualifying module",
df->df_idf->id_text);
}
}
@ -723,6 +744,7 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
case OR:
case AND:
case '&':
if (tpl == bool_type) {
if (expp->nd_left->nd_class == Value &&
expp->nd_right->nd_class == Value) {
@ -735,10 +757,12 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
case '=':
case '#':
case UNEQUAL:
case GREATEREQUAL:
case LESSEQUAL:
case '<':
case '>':
expp->nd_type = bool_type;
switch(tpl->tp_fund) {
case T_SET:
if (expp->nd_symb == '<' || expp->nd_symb == '>') {
@ -762,10 +786,10 @@ node_error(expp, "IN operator: type of LHS not compatible with element type of R
return 1;
case T_POINTER:
if (!(expp->nd_symb == '=' || expp->nd_symb == '#')) {
if (expp->nd_symb == '=' ||
expp->nd_symb == UNEQUAL ||
expp->nd_symb == '#') return 1;
break;
}
/* Fall through */
case T_REAL:
return 1;
@ -832,6 +856,7 @@ chk_uoper(expp)
break;
case NOT:
case '~':
if (tpr == bool_type) {
if (expp->nd_right->nd_class == Value) {
cstunary(expp);

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

@ -38,6 +38,7 @@ cstunary(expp)
o1 = -o1;
break;
case NOT:
case '~':
o1 = !o1;
break;
default:
@ -184,9 +185,11 @@ cstbin(expp)
o1 = o1 == o2;
break;
case '#':
case UNEQUAL:
o1 = o1 != o2;
break;
case AND:
case '&':
o1 = o1 && o2;
break;
case OR:
@ -252,6 +255,7 @@ cstset(expp)
case LESSEQUAL:
case '=':
case '#':
case UNEQUAL:
/* Clumsy, but who cares? Nobody writes these things! */
for (j = 0; j < setsize; j++) {
switch(expp->nd_symb) {
@ -265,13 +269,14 @@ cstset(expp)
continue;
case '=':
case '#':
case UNEQUAL:
if (*set1++ != *set2++) break;
continue;
}
expp->nd_INT = expp->nd_symb == '#';
expp->nd_INT = expp->nd_symb != '=';
break;
}
if (j == setsize) expp->nd_INT = expp->nd_symb != '#';
if (j == setsize) expp->nd_INT = expp->nd_symb == '=';
expp->nd_class = Value;
free((char *) expp->nd_left->nd_set);
free((char *) expp->nd_right->nd_set);

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

@ -7,6 +7,7 @@ static char *RcsId = "$Header$";
#include <em_label.h>
#include <alloc.h>
#include <assert.h>
#include "idf.h"
#include "LLlex.h"
#include "def.h"
@ -18,23 +19,26 @@ static char *RcsId = "$Header$";
int proclevel = 0; /* nesting level of procedures */
extern char *sprint();
extern struct def *currentdef;
}
ProcedureDeclaration
{
struct def *df;
struct def *savecurr = currentdef;
} :
ProcedureHeading(&df, D_PROCEDURE)
{
df->prc_level = proclevel++;
currentdef = df;
}
';' block(&(df->prc_body)) IDENT
{
match_id(dot.TOK_IDF, df->df_idf);
df->prc_scope = CurrentScope;
close_scope(SC_CHKFORW);
close_scope(SC_CHKFORW|SC_REVERSE);
proclevel--;
currentdef = savecurr;
}
;
@ -53,9 +57,15 @@ ProcedureHeading(struct def **pdf; int type;)
{
tp = construct_type(T_PROCEDURE, tp);
tp->prc_params = params;
if (df->df_type && !TstTypeEquiv(tp, df->df_type)) {
if (df->df_type) {
/* We already saw a definition of this type
in the definition module.
*/
if (!TstTypeEquiv(tp, df->df_type)) {
error("inconsistent procedure declaration for \"%s\"", df->df_idf->id_text);
}
FreeType(df->df_type);
}
df->df_type = tp;
*pdf = df;
}
@ -164,7 +174,8 @@ TypeDeclaration
}:
IDENT { df = define(dot.TOK_IDF, CurrentScope, D_TYPE); }
'=' type(&tp)
{ df->df_type = tp;
{ if (df->df_type) free_type(df->df_type);
df->df_type = tp;
if ((df->df_flags&D_EXPORTED) &&
tp->tp_fund == T_ENUMERATION) {
exprt_literals(tp->enm_enums,
@ -327,7 +338,8 @@ FieldList(struct scope *scope; arith *cnt; int *palign;)
[
IdentList(&FldList) ':' type(&tp)
{ *palign = lcm(*palign, tp->tp_align);
EnterIdList(FldList, D_FIELD, 0, tp, scope, cnt);
EnterIdList(FldList, D_FIELD, D_QEXPORTED,
tp, scope, cnt);
FreeNode(FldList);
}
|
@ -373,6 +385,7 @@ FieldList(struct scope *scope; arith *cnt; int *palign;)
df->df_type = tp;
df->fld_off = align(*cnt, tp->tp_align);
*cnt = tcnt = df->fld_off + tp->tp_size;
df->df_flags |= D_QEXPORTED;
}
OF variant(scope, &tcnt, tp, palign)
{ max = tcnt; tcnt = *cnt; }

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

@ -53,14 +53,12 @@ struct field {
struct dfproc {
struct scope *pr_scope; /* scope of procedure */
short pr_level; /* depth level of this procedure */
char *pr_name; /* name of this procedure */
arith pr_nbpar; /* number of bytes parameters */
struct node *pr_body; /* body of this procedure */
#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
#define prc_body df_value.df_proc.pr_body
#define prc_name df_value.df_proc.pr_name
};
struct import {

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

@ -73,16 +73,6 @@ define(id, scope, kind)
(df = lookup(id, PervasiveScope)))
) {
switch(df->df_kind) {
case D_PROCHEAD:
if (kind == D_PROCEDURE) {
/* Definition of which the heading was
already seen in a definition module
*/
df->df_kind = kind;
df->prc_name = df->for_name;
return df;
}
break;
case D_HIDDEN:
if (kind == D_TYPE && !DefinitionModule) {
df->df_kind = D_HTYPE;
@ -192,6 +182,7 @@ df->df_idf->id_text);
exported from a local module!
*/
df->df_kind = df1->df_kind;
df->df_value.df_forward = df1->df_value.df_forward;
df1->df_kind = D_IMPORT;
}
df1->imp_def = df;
@ -423,7 +414,10 @@ DeclProc(type)
/* C_exp already generated when we saw the definition
in the definition module
*/
df->df_kind = type;
df->df_kind = D_PROCEDURE;
open_scope(OPENSCOPE);
CurrentScope->sc_name = df->for_name;
df->prc_scope = CurrentScope;
}
else {
df = define(dot.TOK_IDF, CurrentScope, type);
@ -433,12 +427,13 @@ DeclProc(type)
}
else (sprint(buf, "%s_%s",df->df_scope->sc_name,
df->df_idf->id_text));
df->prc_name = Malloc((unsigned)(strlen(buf)+1));
strcpy(df->prc_name, buf);
open_scope(OPENSCOPE);
df->prc_scope = CurrentScope;
CurrentScope->sc_name = Malloc((unsigned)(strlen(buf)+1));
strcpy(CurrentScope->sc_name, buf);
C_inp(buf);
}
df->prc_nbpar = 0;
open_scope(OPENSCOPE);
}
return df;

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

@ -72,6 +72,7 @@ EnterIdList(idlist, kind, flags, type, scope, addr)
}
else {
assert(kind == D_FIELD);
df->fld_off = off;
}
}
@ -107,6 +108,7 @@ EnterVarList(IdList, type, local)
extern char *sprint(), *Malloc(), *strcpy();
scope = CurrentScope;
if (local) {
/* Find the closest enclosing open scope. This
is the procedure that we are dealing with
@ -127,22 +129,26 @@ 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
/* subtract aligned size of variable to the offset,
as the variable list exists only local to a
procedure
*/
off = scope->sc_off - type->tp_size;
off = -align(-off, type->tp_align);
df->var_off = off;
scope->sc_off = off;
scope->sc_off = -align(type->tp_size - scope->sc_off,
type->tp_align);
df->var_off = scope->sc_off;
}
else if (!DefinitionModule &&
CurrentScope != Defined->mod_scope) {
/* variable list belongs to an internal global
module. Align offset and add size
*/
scope->sc_off = align(scope->sc_off, type->tp_align);
df->var_off = scope->sc_off;
scope->sc_off += type->tp_size;
}
else {
/* Global name, possibly external
*/
sprint(buf,"%s_%s", df->df_scope->sc_name,
df->df_idf->id_text);
df->var_name = Malloc((unsigned)(strlen(buf)+1));

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

@ -268,5 +268,5 @@ visible_designator_tail(struct node **pnd;):
]*
']'
|
'^' { *pnd = MkNode(Oper, NULLNODE, *pnd, &dot); }
'^' { *pnd = MkNode(Uoper, NULLNODE, *pnd, &dot); }
;

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

@ -16,6 +16,7 @@ static char *RcsId = "$Header$";
#include "scope.h"
#include "standards.h"
#include "tokenname.h"
#include "node.h"
#include "debug.h"
@ -135,6 +136,7 @@ add_standards()
{
register struct def *df;
struct def *Enter();
static struct node nilnode = { 0, 0, Value, 0, { INTEGER, 0, 0}};
(void) Enter("ABS", D_PROCEDURE, std_type, S_ABS);
(void) Enter("CAP", D_PROCEDURE, std_type, S_CAP);
@ -161,7 +163,11 @@ add_standards()
(void) Enter("LONGREAL", D_TYPE, longreal_type, 0);
(void) Enter("BOOLEAN", D_TYPE, bool_type, 0);
(void) Enter("CARDINAL", D_TYPE, card_type, 0);
(void) Enter("NIL", D_CONST, address_type, 0);
df = Enter("NIL", D_CONST, address_type, 0);
df->con_const = &nilnode;
nilnode.nd_INT = 0;
nilnode.nd_type = address_type;
(void) Enter("PROC",
D_TYPE,
construct_type(T_PROCEDURE, NULLTYPE),

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

@ -22,6 +22,7 @@ static int DEFofIMPL = 0; /* Flag indicating that we are currently
implementation module currently being
compiled
*/
struct def *currentdef; /* current definition of module or procedure */
}
/*
The grammar as given by Wirth is already almost LL(1); the
@ -46,6 +47,7 @@ ModuleDeclaration
{
struct idf *id;
register struct def *df;
struct def *savecurr = currentdef;
extern int proclevel;
static int modulecount = 0;
char buf[256];
@ -54,11 +56,14 @@ ModuleDeclaration
MODULE IDENT {
id = dot.TOK_IDF;
df = define(id, CurrentScope, D_MODULE);
currentdef = df;
if (!df->mod_scope) {
open_scope(CLOSEDSCOPE);
df->mod_scope = CurrentScope;
}
else CurrentScope = df->mod_scope;
df->df_type = standard_type(T_RECORD, 0, (arith) 0);
df->df_type->rec_scope = df->mod_scope;
df->mod_number = ++modulecount;
@ -74,8 +79,9 @@ ModuleDeclaration
import(1)*
export(0)?
block(&(df->mod_body))
IDENT { close_scope(SC_CHKFORW|SC_CHKPROC);
IDENT { close_scope(SC_CHKFORW|SC_CHKPROC|SC_REVERSE);
match_id(id, dot.TOK_IDF);
currentdef = savecurr;
}
;
@ -198,6 +204,7 @@ definition
It is restricted to pointer types.
*/
{ df->df_kind = D_HIDDEN;
df->df_type = construct_type(T_POINTER, NULLTYPE);
}
]
Semicolon
@ -226,6 +233,7 @@ ProgramModule(int state;)
if (state == IMPLEMENTATION) {
DEFofIMPL = 1;
df = GetDefinitionModule(id);
currentdef = df;
CurrentScope = df->mod_scope;
DEFofIMPL = 0;
}
@ -240,7 +248,7 @@ ProgramModule(int state;)
priority(&(df->mod_priority))?
';' import(0)*
block(&(df->mod_body)) IDENT
{ close_scope(SC_CHKFORW|SC_CHKPROC);
{ close_scope(SC_CHKFORW|SC_CHKPROC|SC_REVERSE);
match_id(id, dot.TOK_IDF);
}
'.'

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

@ -6,12 +6,14 @@ static char *RcsId = "$Header$";
#include <alloc.h>
#include <em_arith.h>
#include <em_label.h>
#include "LLlex.h"
#include "idf.h"
#include "scope.h"
#include "type.h"
#include "def.h"
#include "node.h"
#include "debug.h"
struct scope *CurrentScope, *PervasiveScope, *GlobalScope;
@ -212,7 +214,7 @@ close_scope(flag)
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));
Reverse(&(sc->sc_def));
if (flag & SC_REVERSE) Reverse(&(sc->sc_def));
}
CurrentScope = sc->next;
scp_level = CurrentScope->sc_level;

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

@ -11,6 +11,9 @@
#define SC_CHKPROC 2 /* Check for forward procedure definitions
when closing a scope
*/
#define SC_REVERSE 4 /* Reverse list of definitions, to get it
back into original order
*/
struct scope {
struct scope *next;

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

@ -5,11 +5,15 @@ static char *RcsId = "$Header$";
#include <em_arith.h>
#include <em_label.h>
#include "idf.h"
#include "LLlex.h"
#include "scope.h"
#include "def.h"
#include "type.h"
#include "node.h"
static int loopcount = 0; /* Count nested loops */
extern struct def *currentdef;
}
statement(struct node **pnd;)
@ -63,6 +67,13 @@ statement(struct node **pnd;)
RETURN { *pnd = nd = MkNode(Stat, NULLNODE, NULLNODE, &dot); }
[
expression(&(nd->nd_right))
{ if (scopeclosed(CurrentScope)) {
error("a module body has no result value");
}
else if (! currentdef->df_type->next) {
error("procedure \"%s\" has no result value", currentdef->df_idf->id_text);
}
}
]?
]?
;

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

@ -9,6 +9,7 @@ static char *RcsId = "$Header$";
#include "target_sizes.h"
#include "debug.h"
#include "maxset.h"
#include "def.h"
#include "type.h"
@ -131,28 +132,61 @@ standard_type(fund, align, size)
init_types()
{
/* Initialize the predefined types
*/
register struct type *tp;
/* character type
*/
char_type = standard_type(T_CHAR, 1, (arith) 1);
char_type->enm_ncst = 256;
/* character constant, different from char because of compatibility
with ARRAY OF CHAR
*/
charc_type = standard_type(T_CHAR, 1, (arith) 1);
charc_type->enm_ncst = 256;
/* boolean type
*/
bool_type = standard_type(T_ENUMERATION, 1, (arith) 1);
bool_type->enm_ncst = 2;
/* integer types, also a "intorcard", for integer constants between
0 and MAX(INTEGER)
*/
int_type = standard_type(T_INTEGER, int_align, int_size);
longint_type = standard_type(T_INTEGER, long_align, long_size);
card_type = standard_type(T_CARDINAL, int_align, int_size);
intorcard_type = standard_type(T_INTORCARD, int_align, int_size);
/* floating types
*/
real_type = standard_type(T_REAL, float_align, float_size);
longreal_type = standard_type(T_REAL, double_align, double_size);
word_type = standard_type(T_WORD, word_align, word_size);
intorcard_type = standard_type(T_INTORCARD, int_align, int_size);
/* string constant type
*/
string_type = standard_type(T_STRING, 1, (arith) -1);
/* SYSTEM types
*/
word_type = standard_type(T_WORD, word_align, word_size);
address_type = construct_type(T_POINTER, word_type);
/* create BITSET type
*/
tp = construct_type(T_SUBRANGE, int_type);
tp->sub_lb = 0;
tp->sub_ub = word_size * 8 - 1;
bitset_type = set_type(tp);
/* a unique type for standard procedures and functions
*/
std_type = construct_type(T_PROCEDURE, NULLTYPE);
/* a unique type indicating an error
*/
error_type = standard_type(T_CHAR, 1, (arith) 1);
}
@ -183,11 +217,12 @@ ParamList(ids, tp, VARp)
return pstart;
}
/* A subrange had a specified base. Check that the bases conform ...
*/
chk_basesubrange(tp, base)
register struct type *tp, *base;
{
/* A subrange had a specified base. Check that the bases conform.
*/
if (base->tp_fund == T_SUBRANGE) {
/* Check that the bounds of "tp" fall within the range
of "base"
@ -197,6 +232,7 @@ chk_basesubrange(tp, base)
}
base = base->next;
}
if (base->tp_fund == T_ENUMERATION || base->tp_fund == T_CHAR) {
if (tp->next != base) {
error("Specified base does not conform");
@ -212,6 +248,7 @@ chk_basesubrange(tp, base)
else if (base != tp->next && base != int_type) {
error("Specified base does not conform");
}
tp->next = base;
tp->tp_size = base->tp_size;
tp->tp_align = base->tp_align;
@ -233,14 +270,18 @@ subr_type(lb, ub)
}
if (tp->tp_fund == T_SUBRANGE) tp = tp->next;
if (tp == intorcard_type) tp = card_type; /* lower bound > 0 */
if (tp == intorcard_type) {
/* Lower bound >= 0; in this case, the base type is CARDINAL,
according to the language definition, par. 6.3
*/
assert(lb->nd_INT >= 0);
tp = card_type;
}
/* Check base type
*/
if (tp != int_type && tp != card_type && tp != char_type &&
tp->tp_fund != T_ENUMERATION) {
/* BOOLEAN is also an ENUMERATION type
*/
if (! (tp->tp_fund & T_DISCRETE)) {
node_error(ub, "Illegal base type for subrange");
return error_type;
}
@ -258,10 +299,8 @@ subr_type(lb, ub)
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 res;
}
#define MAX_SET 1024 /* ??? Maximum number of elements in a set */
struct type *
set_type(tp)
@ -273,14 +312,14 @@ set_type(tp)
arith lb, ub;
if (tp->tp_fund == T_SUBRANGE) {
if ((lb = tp->sub_lb) < 0 || (ub = tp->sub_ub) > MAX_SET - 1) {
if ((lb = tp->sub_lb) < 0 || (ub = tp->sub_ub) > MAXSET - 1) {
error("Set type limits exceeded");
return error_type;
}
}
else if (tp->tp_fund == T_ENUMERATION || tp == char_type) {
lb = 0;
if ((ub = tp->enm_ncst - 1) > MAX_SET - 1) {
if ((ub = tp->enm_ncst - 1) > MAXSET - 1) {
error("Set type limits exceeded");
return error_type;
}
@ -289,6 +328,7 @@ set_type(tp)
error("illegal base type for set");
return error_type;
}
tp = construct_type(T_SET, tp);
tp->tp_size = align(((ub - lb) + 7)/8, word_align);
return tp;
@ -297,40 +337,68 @@ set_type(tp)
ArraySizes(tp)
register struct type *tp;
{
/* Assign sizes to an array type
/* Assign sizes to an array type, and check index type
*/
arith elem_size;
register struct type *itype = tp->next; /* the index type */
register struct type *index_type = tp->next;
register struct type *elem_type = tp->arr_elem;
if (tp->arr_elem->tp_fund == T_ARRAY) {
ArraySizes(tp->arr_elem);
if (elem_type->tp_fund == T_ARRAY) {
ArraySizes(elem_type);
}
elem_size = align(tp->arr_elem->tp_size, tp->arr_elem->tp_align);
tp->tp_align = tp->arr_elem->tp_align;
/* align element size to alignment requirement of element type
*/
elem_size = align(elem_type->tp_size, elem_type->tp_align);
tp->tp_align = elem_type->tp_align;
if (! (itype->tp_fund & T_INDEX)) {
/* check index type
*/
if (! (index_type->tp_fund & T_INDEX)) {
error("Illegal index type");
tp->tp_size = 0;
return;
}
switch(itype->tp_fund) {
/* find out HIGH, LOW and size of ARRAY
*/
switch(index_type->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);
tp->arr_lb = index_type->sub_lb;
tp->arr_ub = index_type->sub_ub;
tp->tp_size = elem_size *
(index_type->sub_ub - index_type->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;
tp->arr_ub = index_type->enm_ncst - 1;
tp->tp_size = elem_size * index_type->enm_ncst;
break;
default:
assert(0);
}
/* ??? overflow checking ??? */
/* ??? overflow checking ???
*/
}
FreeType(tp)
struct type *tp;
{
/* Release type structures indicated by "tp"
*/
register struct paramlist *pr, *pr1;
assert(tp->tp_fund == T_PROCEDURE);
pr = tp->prc_params;
while (pr) {
pr1 = pr;
pr = pr->next;
free_paramlist(pr1);
}
free_type(tp);
}
int

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

@ -12,21 +12,31 @@ static char *RcsId = "$Header$";
int
TstTypeEquiv(tp1, tp2)
register struct type *tp1, *tp2;
struct type *tp1, *tp2;
{
/* test if two types are equivalent. A complication comes
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
equivalent base types are also equivalent.
/* test if two types are equivalent.
*/
return tp1 == tp2
||
tp1 == error_type
||
tp2 == error_type
tp2 == error_type;
}
int
TstParEquiv(tp1, tp2)
register struct type *tp1, *tp2;
{
/* test if two parameter types are equivalent. This routine
is used to check if two different procedure declarations
(one in the definition module, one in the implementation
module) are equivalent. A complication comes from dynamic
arrays.
*/
return
TstTypeEquiv(tp1, tp2)
||
(
tp1->tp_fund == T_ARRAY
@ -38,16 +48,7 @@ TstTypeEquiv(tp1, tp2)
tp2->next == 0
&&
TstTypeEquiv(tp1->arr_elem, tp2->arr_elem)
)
||
(
tp1 && tp1->tp_fund == T_PROCEDURE
&&
tp2 && tp2->tp_fund == T_PROCEDURE
&&
TstProcEquiv(tp1, tp2)
);
}
int
@ -61,14 +62,17 @@ TstProcEquiv(tp1, tp2)
register struct paramlist *p1, *p2;
if (!TstTypeEquiv(tp1->next, tp2->next)) return 0;
p1 = tp1->prc_params;
p2 = tp2->prc_params;
while (p1 && p2) {
if (p1->par_var != p2->par_var ||
!TstTypeEquiv(p1->par_type, p2->par_type)) return 0;
!TstParEquiv(p1->par_type, p2->par_type)) return 0;
p1 = p1->next;
p2 = p2->next;
}
return p1 == p2;
}
@ -79,9 +83,12 @@ TstCompat(tp1, tp2)
/* test if two types are compatible. See section 6.3 of the
Modula-2 Report for a definition of "compatible".
*/
if (TstTypeEquiv(tp1, tp2)) return 1;
if (tp1->tp_fund == T_SUBRANGE) tp1 = tp1->next;
if (tp2->tp_fund == T_SUBRANGE) tp2 = tp2->next;
return tp1 == tp2
||
( tp1 == intorcard_type
@ -117,12 +124,15 @@ int TstAssCompat(tp1, tp2)
{
/* Test if two types are assignment compatible.
*/
if (TstCompat(tp1, tp2)) return 1;
if (tp1->tp_fund == T_SUBRANGE) tp1 = tp1->next;
if (tp2->tp_fund == T_SUBRANGE) tp2 = tp2->next;
if ((tp1->tp_fund & (T_INTEGER|T_CARDINAL)) &&
(tp2->tp_fund & (T_INTEGER|T_CARDINAL))) return 1;
if ((tp1->tp_fund & T_INTORCARD) &&
(tp2->tp_fund & T_INTORCARD)) return 1;
if (tp1 == char_type && tp2 == charc_type) return 1;
if (tp1->tp_fund == T_ARRAY &&
(tp2 == charc_type || tp2 == string_type)) {
@ -133,5 +143,6 @@ int TstAssCompat(tp1, tp2)
if (tp1->tp_fund == T_SUBRANGE) tp1 = tp1->next;
return tp1 == char_type;
}
return 0;
}

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

@ -16,11 +16,14 @@ static char *RcsId = "$Header$";
#include "main.h"
#include "LLlex.h"
#include "node.h"
#include "Lpars.h"
#include "debug.h"
extern arith align();
static int prclev = 0;
static label instructionlabel = 0;
static label datalabel = 0;
WalkModule(module)
register struct def *module;
@ -33,10 +36,12 @@ WalkModule(module)
scope = CurrentScope;
CurrentScope = module->mod_scope;
if (!prclev && module->mod_number) {
/* This module is a local module, but not within a
procedure. Generate code to allocate storage for its
variables
variables. This is done by generating a "bss",
with label "_<modulenumber><modulename>".
*/
arith size = align(CurrentScope->sc_off, word_size);
@ -69,7 +74,7 @@ WalkModule(module)
CurrentScope->sc_off = 0;
C_pro_narg(CurrentScope->sc_name);
MkCalls(CurrentScope->sc_def);
WalkNode(module->mod_body);
WalkNode(module->mod_body, (label) 0);
C_end(align(-CurrentScope->sc_off, word_size));
CurrentScope = scope;
@ -91,12 +96,13 @@ WalkProcedure(procedure)
/* Generate code for this procedure
*/
C_pro_narg(procedure->prc_name);
C_pro_narg(CurrentScope->sc_name);
/* generate calls to initialization routines of modules defined within
this procedure
*/
instructionlabel = 1;
MkCalls(CurrentScope->sc_def);
WalkNode(procedure->prc_body);
WalkNode(procedure->prc_body, (label) 0);
C_end(align(-CurrentScope->sc_off, word_size));
CurrentScope = scope;
prclev--;
@ -126,17 +132,151 @@ MkCalls(df)
while (df) {
if (df->df_kind == D_MODULE) {
C_lxl((arith) 0);
C_cal(df->df_scope->sc_name);
C_cal(df->mod_scope->sc_name);
}
df = df->df_nextinscope;
}
}
WalkNode(nd)
struct node *nd;
WalkNode(nd, lab)
register struct node *nd;
label lab;
{
/* Node "nd" represents either a statement or a statement list.
Generate code for it.
Walk through it.
"lab" represents the label that must be jumped to on
encountering an EXIT statement.
*/
while (nd->nd_class == Link) { /* statement list */
WalkStat(nd->nd_left, lab);
nd = nd->nd_right;
}
WalkStat(nd, lab);
}
WalkStat(nd, lab)
register struct node *nd;
label lab;
{
/* Walk through a statement, generating code for it.
"lab" represents the label that must be jumped to on
encountering an EXIT statement.
*/
register struct node *left = nd->nd_left;
register struct node *right = nd->nd_right;
if (nd->nd_class == Call) {
/* ??? */
return;
}
assert(nd->nd_class == Stat);
switch(nd->nd_symb) {
case BECOMES:
/* ??? */
break;
case IF:
{ label l1, l2;
l1 = instructionlabel++;
l2 = instructionlabel++;
ExpectBool(left);
assert(right->nd_symb == THEN);
C_zeq(l1);
WalkNode(right->nd_left, lab);
if (right->nd_right) { /* ELSE part */
C_bra(l2);
C_df_ilb(l1);
WalkNode(right->nd_right, lab);
C_df_ilb(l2);
}
else C_df_ilb(l1);
break;
}
case CASE:
/* ??? */
break;
case WHILE:
{ label l1, l2;
l1 = instructionlabel++;
l2 = instructionlabel++;
C_df_ilb(l1);
ExpectBool(left);
C_zeq(l2);
WalkNode(right, lab);
C_bra(l1);
C_df_ilb(l2);
break;
}
case REPEAT:
{ label l1;
l1 = instructionlabel++;
C_df_ilb(l1);
WalkNode(left, lab);
ExpectBool(right);
C_zeq(l1);
break;
}
case LOOP:
{ label l1, l2;
l1 = instructionlabel++;
l2 = instructionlabel++;
C_df_ilb(l1);
WalkNode(left, l2);
C_bra(l1);
C_df_ilb(l2);
break;
}
case FOR:
/* ??? */
break;
case WITH:
/* ??? */
break;
case EXIT:
assert(lab != 0);
C_bra(lab);
break;
case RETURN:
/* ??? */
break;
default:
assert(0);
}
}
ExpectBool(nd)
struct node *nd;
{
/* "nd" must indicate a boolean expression. Check this and
generate code to evaluate the expression.
*/
chk_expr(nd);
if (nd->nd_type != bool_type) {
node_error(nd, "boolean expression expected");
}
/* generate code
*/
/* ??? */
}