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-07 17:40:38 +00:00
parent 376c47c98f
commit f2b68c8261
15 changed files with 438 additions and 81 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
lang/m2/comp/Makefile
View file

@ -17,7 +17,8 @@ LFLAGS = $(PROFILE)
LOBJ = tokenfile.o program.o declar.o expression.o statement.o
COBJ = LLlex.o LLmessage.o char.o error.o main.o \
symbol2str.o tokenname.o idf.o input.o type.o def.o \
scope.o misc.o enter.o defmodule.o typequiv.o node.o
scope.o misc.o enter.o defmodule.o typequiv.o node.o \
cstoper.o
OBJ = $(COBJ) $(LOBJ) Lpars.o
GENFILES= tokenfile.c \
program.c declar.c expression.c statement.c \
@ -80,15 +81,16 @@ idf.o: idf.h
input.o: f_info.h input.h
type.o: LLlex.h Lpars.h def.h def_sizes.h idf.h node.h type.h
def.o: LLlex.h Lpars.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 scope.h type.h
scope.o: LLlex.h debug.h def.h idf.h main.h scope.h type.h
misc.o: LLlex.h f_info.h idf.h misc.h
enter.o: LLlex.h def.h idf.h node.h scope.h type.h
defmodule.o: LLlex.h def.h f_info.h idf.h input.h scope.h
typequiv.o: Lpars.h def.h type.h
node.o: LLlex.h def.h node.h type.h
node.o: LLlex.h debug.h def.h main.h node.h type.h
cstoper.o: Lpars.h def_sizes.h idf.h node.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 misc.h node.h scope.h type.h
expression.o: LLlex.h Lpars.h def.h idf.h node.h scope.h
statement.o: Lpars.h
expression.o: LLlex.h Lpars.h debug.h def.h idf.h main.h node.h scope.h
statement.o: LLlex.h Lpars.h node.h
Lpars.o: Lpars.h

12
lang/m2/comp/const.h Normal file
View file

@ -0,0 +1,12 @@
/* C O N S T A N T S F O R E X P R E S S I O N H A N D L I N G */
/* $Header$ */
extern long
mach_long_sign; /* sign bit of the machine long */
extern int
mach_long_size; /* size of long on this machine == sizeof(long) */
extern arith
max_int, /* maximum integer on target machine */
max_unsigned, /* maximum unsigned on target machine */
max_longint; /* maximum longint on target machine */

238
lang/m2/comp/cstoper.c Normal file
View file

@ -0,0 +1,238 @@
/* C O N S T A N T E X P R E S S I O N H A N D L I N G */
static char *RcsId = "$Header$";
#include <em_arith.h>
#include <em_label.h>
#include <assert.h>
#include "def_sizes.h"
#include "idf.h"
#include "type.h"
#include "LLlex.h"
#include "node.h"
#include "Lpars.h"
long mach_long_sign; /* sign bit of the machine long */
int mach_long_size; /* size of long on this machine == sizeof(long) */
long full_mask[MAXSIZE];/* full_mask[1] == 0XFF, full_mask[2] == 0XFFFF, .. */
arith max_int; /* maximum integer on target machine */
arith max_unsigned; /* maximum unsigned on target machine */
arith max_longint; /* maximum longint on target machine */
#if 0
cstbin(expp, oper, expr)
struct expr **expp, *expr;
{
/* The operation oper is performed on the constant
expressions *expp(ld) and expr(ct), and the result restored in
*expp.
*/
arith o1 = (*expp)->VL_VALUE;
arith o2 = expr->VL_VALUE;
int uns = (*expp)->ex_type->tp_unsigned;
ASSERT(is_ld_cst(*expp) && is_cp_cst(expr));
switch (oper) {
case '*':
o1 *= o2;
break;
case '/':
if (o2 == 0) {
expr_error(expr, "division by 0");
break;
}
if (uns) {
/* this is more of a problem than you might
think on C compilers which do not have
unsigned long.
*/
if (o2 & mach_long_sign) {/* o2 > max_long */
o1 = ! (o1 >= 0 || o1 < o2);
/* this is the unsigned test
o1 < o2 for o2 > max_long
*/
}
else { /* o2 <= max_long */
long half, bit, hdiv, hrem, rem;
half = (o1 >> 1) & ~mach_long_sign;
bit = o1 & 01;
/* now o1 == 2 * half + bit
and half <= max_long
and bit <= max_long
*/
hdiv = half / o2;
hrem = half % o2;
rem = 2 * hrem + bit;
o1 = 2 * hdiv + (rem < 0 || rem >= o2);
/* that is the unsigned compare
rem >= o2 for o2 <= max_long
*/
}
}
else
o1 /= o2;
break;
case '%':
if (o2 == 0) {
expr_error(expr, "modulo by 0");
break;
}
if (uns) {
if (o2 & mach_long_sign) {/* o2 > max_long */
o1 = (o1 >= 0 || o1 < o2) ? o1 : o1 - o2;
/* this is the unsigned test
o1 < o2 for o2 > max_long
*/
}
else { /* o2 <= max_long */
long half, bit, hrem, rem;
half = (o1 >> 1) & ~mach_long_sign;
bit = o1 & 01;
/* now o1 == 2 * half + bit
and half <= max_long
and bit <= max_long
*/
hrem = half % o2;
rem = 2 * hrem + bit;
o1 = (rem < 0 || rem >= o2) ? rem - o2 : rem;
}
}
else
o1 %= o2;
break;
case '+':
o1 += o2;
break;
case '-':
o1 -= o2;
break;
case LEFT:
o1 <<= o2;
break;
case RIGHT:
if (o2 == 0)
break;
if (uns) {
o1 >>= 1;
o1 & = ~mach_long_sign;
o1 >>= (o2-1);
}
else
o1 >>= o2;
break;
case '<':
if (uns) {
o1 = (o1 & mach_long_sign ?
(o2 & mach_long_sign ? o1 < o2 : 0) :
(o2 & mach_long_sign ? 1 : o1 < o2)
);
}
else
o1 = o1 < o2;
break;
case '>':
if (uns) {
o1 = (o1 & mach_long_sign ?
(o2 & mach_long_sign ? o1 > o2 : 1) :
(o2 & mach_long_sign ? 0 : o1 > o2)
);
}
else
o1 = o1 > o2;
break;
case LESSEQ:
if (uns) {
o1 = (o1 & mach_long_sign ?
(o2 & mach_long_sign ? o1 <= o2 : 0) :
(o2 & mach_long_sign ? 1 : o1 <= o2)
);
}
else
o1 = o1 <= o2;
break;
case GREATEREQ:
if (uns) {
o1 = (o1 & mach_long_sign ?
(o2 & mach_long_sign ? o1 >= o2 : 1) :
(o2 & mach_long_sign ? 0 : o1 >= o2)
);
}
else
o1 = o1 >= o2;
break;
case EQUAL:
o1 = o1 == o2;
break;
case NOTEQUAL:
o1 = o1 != o2;
break;
case '&':
o1 &= o2;
break;
case '|':
o1 |= o2;
break;
case '^':
o1 ^= o2;
break;
}
(*expp)->VL_VALUE = o1;
cut_size(*expp);
(*expp)->ex_flags |= expr->ex_flags;
(*expp)->ex_flags &= ~EX_PARENS;
}
cut_size(expr)
struct expr *expr;
{
/* The constant value of the expression expr is made to
conform to the size of the type of the expression.
*/
arith o1 = expr->VL_VALUE;
int uns = expr->ex_type->tp_unsigned;
int size = (int) expr->ex_type->tp_size;
ASSERT(expr->ex_class == Value);
if (uns) {
if (o1 & ~full_mask[size])
expr_warning(expr,
"overflow in unsigned constant expression");
o1 &= full_mask[size];
}
else {
int nbits = (int) (mach_long_size - size) * 8;
long remainder = o1 & ~full_mask[size];
if (remainder != 0 && remainder != ~full_mask[size])
expr_warning(expr, "overflow in constant expression");
o1 <<= nbits; /* ??? */
o1 >>= nbits;
}
expr->VL_VALUE = o1;
}
# endif
init_cst()
{
int i = 0;
arith bt = (arith)0;
while (!(bt < 0)) {
bt = (bt << 8) + 0377, i++;
if (i == MAXSIZE)
fatal("array full_mask too small for this machine");
full_mask[i] = bt;
}
mach_long_size = i;
mach_long_sign = 1 << (mach_long_size * 8 - 1);
if (sizeof(long) < mach_long_size)
fatal("sizeof (long) insufficient on this machine");
max_int = full_mask[int_size] & ~(1 << (int_size * 8 - 1));
max_longint = full_mask[lint_size] & ~(1 << (lint_size * 8 - 1));
max_unsigned = full_mask[int_size];
}

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

@ -34,7 +34,7 @@ define(id, scope, kind)
register struct def *df;
register struct scope *sc;
DO_DEBUG(debug(4,"Defining identifier %s in scope %d", id->id_text, scope->sc_scope));
DO_DEBUG(5, debug("Defining identifier \"%s\" in scope %d", id->id_text, scope->sc_scope));
df = lookup(id, scope->sc_scope);
if ( /* Already in this scope */
df
@ -94,7 +94,7 @@ lookup(id, scope)
df1 = 0;
df = id->id_def;
DO_DEBUG(debug(4,"Looking for identifier %s in scope %d", id->id_text, scope));
DO_DEBUG(5, debug("Looking for identifier \"%s\" in scope %d", id->id_text, scope));
while (df) {
if (df->df_scope == scope) {
if (df->df_kind == D_IMPORT) {

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

@ -5,6 +5,7 @@ static char *RcsId = "$Header$";
#include <alloc.h>
#include <em_arith.h>
#include <em_label.h>
#include <assert.h>
#include "idf.h"
#include "def.h"
#include "type.h"
@ -17,6 +18,10 @@ Enter(name, kind, type, pnam)
char *name;
struct type *type;
{
/* Enter a definition for "name" with kind "kind" and type
"type" in the Current Scope. If it is a standard name, also
put its number in the definition structure.
*/
struct idf *id;
struct def *df;
@ -35,6 +40,13 @@ EnterIdList(idlist, kind, flags, type, scope)
struct type *type;
struct scope *scope;
{
/* Put a list of identifiers in the symbol table.
They all have kind "kind", and type "type", and are put
in scope "scope". "flags" initializes the "df_flags" field
of the definition structure.
Also assign numbers to enumeration literals, and link
them together.
*/
register struct def *df;
struct def *first = 0, *last = 0;
int assval = 0;
@ -45,15 +57,16 @@ EnterIdList(idlist, kind, flags, type, scope)
df->df_flags = flags;
if (kind == D_ENUM) {
if (!first) first = df;
df->df_value.df_enum.en_val = assval++;
if (last) last->df_value.df_enum.en_next = df;
df->enm_val = assval++;
if (last) last->enm_next = df;
last = df;
}
idlist = idlist->next;
}
if (last) {
/* Also meaning : enumeration */
last->df_value.df_enum.en_next = 0;
/* Also meaning : kind == D_ENUM */
assert(kind == D_ENUM);
last->enm_next = 0;
type->enm_enums = first;
type->enm_ncst = assval;
}

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

@ -46,10 +46,10 @@ extern char *symbol2str();
#ifdef DEBUG
/*VARARGS2*/
debug(level, fmt, args)
debug(fmt, args)
char *fmt;
{
if (level <= options['D']) _error(VDEBUG, NULLNODE, fmt, &args);
_error(VDEBUG, NULLNODE, fmt, &args);
}
#endif DEBUG

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

@ -6,19 +6,30 @@ static char *RcsId = "$Header$";
#include <alloc.h>
#include <em_arith.h>
#include <em_label.h>
#include "main.h"
#include "LLlex.h"
#include "idf.h"
#include "def.h"
#include "scope.h"
#include "node.h"
#include "const.h"
#include "type.h"
#include "debug.h"
}
number(struct node **p;):
number(struct node **p;)
{
struct type *tp;
} :
[
INTEGER
INTEGER { tp = dot.TOK_INT <= max_int ?
intorcard_type : card_type;
}
|
REAL
] { *p = MkNode(Value, NULLNODE, NULLNODE, dot); }
REAL { tp = real_type; }
] { *p = MkNode(Value, NULLNODE, NULLNODE, &dot);
(*p)->nd_type = tp;
}
;
qualident(int types; struct def **pdf; char *str; struct node **p;)
@ -27,15 +38,16 @@ qualident(int types; struct def **pdf; char *str; struct node **p;)
int module;
register struct def *df;
struct def *lookfor();
register struct node **pnd;
struct node *nd;
} :
IDENT { if (types) {
df = lookfor(dot.TOK_IDF, CurrentScope, 1);
*pdf = df;
if (df->df_kind == D_ERROR) types = 0;
}
if (p) {
*p = MkNode(Value, NULLNODE, NULLNODE,&dot);
}
nd = MkNode(Value, NULLNODE, NULLNODE, &dot);
pnd = &nd;
}
[
{ if (types &&!(scope = has_selectors(df))) {
@ -44,12 +56,11 @@ qualident(int types; struct def **pdf; char *str; struct node **p;)
}
}
/* selector */
'.' { if (p) *p = MkNode(Link, *p, NULLNODE, &dot); }
'.' { *pnd = MkNode(Link,*pnd,NULLNODE,&dot);
pnd = &(*pnd)->nd_right;
}
IDENT
{ if (p) {
p = &((*p)->nd_right);
*p = MkNode(Value, NULLNODE, NULLNODE,&dot);
}
{ *pnd = MkNode(Value,NULLNODE,NULLNODE,&dot);
if (types) {
module = (df->df_kind == D_MODULE);
df = lookup(dot.TOK_IDF, scope);
@ -70,6 +81,8 @@ qualident(int types; struct def **pdf; char *str; struct node **p;)
error("identifier \"%s\" is not a %s",
df->df_idf->id_text, str);
}
if (!p) FreeNode(nd);
else *p = nd;
}
;
@ -98,22 +111,24 @@ ConstExpression(struct node **pnd;):
* Changed rule in new Modula-2.
* Check that the expression is a constant expression and evaluate!
*/
{ DO_DEBUG(3,
( debug("Constant expression:"),
PrNode(*pnd)));
}
;
expression(struct node **pnd;)
{
struct node *nd;
} :
SimpleExpression(&nd)
SimpleExpression(pnd)
[
/* relation */
[ '=' | '#' | UNEQUAL | '<' | LESSEQUAL | '>' |
GREATEREQUAL | IN
]
{ nd = MkNode(Oper, nd, NULLNODE, &dot); }
SimpleExpression(&(nd->nd_right))
{ *pnd = MkNode(Oper, *pnd, NULLNODE, &dot); }
SimpleExpression(&((*pnd)->nd_right))
]?
{ *pnd = nd; }
;
/* Inline in expression
@ -124,15 +139,19 @@ relation:
SimpleExpression(struct node **pnd;)
{
register struct node *nd;
} :
[ '+' | '-' ]?
term(pnd) { nd = *pnd; }
[
[ '+' | '-' ]
{ *pnd = MkNode(Uoper, NULLNODE, NULLNODE, &dot);
pnd = &((*pnd)->nd_right);
}
]?
term(pnd)
[
/* AddOperator */
[ '+' | '-' | OR ]
{ *pnd = nd = MkNode(Oper, nd, NULLNODE, &dot); }
term(&(nd->nd_right))
{ *pnd = MkNode(Oper, *pnd, NULLNODE, &dot); }
term(&((*pnd)->nd_right))
]*
;
@ -144,14 +163,13 @@ AddOperator:
term(struct node **pnd;)
{
register struct node *nd;
}:
factor(pnd) { nd = *pnd; }
factor(pnd)
[
/* MulOperator */
[ '*' | '/' | DIV | MOD | AND | '&' ]
{ *pnd = nd = MkNode(Oper, nd, NULLNODE, &dot); }
factor(&(nd->nd_right))
{ *pnd = MkNode(Oper, *pnd, NULLNODE, &dot); }
factor(&((*pnd)->nd_right))
]*
;
@ -164,23 +182,29 @@ MulOperator:
factor(struct node **p;)
{
struct def *df;
struct node *nd;
} :
qualident(0, &df, (char *) 0, p)
[
designator_tail(p)?
[
{ *p = MkNode(Call, p, NULLNODE, &dot); }
{ *p = MkNode(Call, *p, NULLNODE, &dot); }
ActualParameters(&((*p)->nd_right))
]?
| { *p = MkNode(Call, p, NULLNODE, &dot); }
bare_set(&((*p)->nd_right))
|
bare_set(&nd)
{ nd->nd_left = *p;
*p = nd;
}
]
|
bare_set(p)
| %default
number(p)
|
STRING { *p = MkNode(Value, NULLNODE, NULLNODE, &dot); }
STRING { *p = MkNode(Value, NULLNODE, NULLNODE, &dot);
(*p)->nd_type = string_type;
}
|
'(' expression(p) ')'
|
@ -190,20 +214,17 @@ factor(struct node **p;)
bare_set(struct node **pnd;)
{
struct node **nd;
register struct node *nd;
} :
'{' {
dot.tk_symb = SET;
*pnd = MkNode(Link, NULLNODE, NULLNODE, &dot);
nd = &((*pnd)->nd_left);
*pnd = nd = MkNode(Link, NULLNODE, NULLNODE, &dot);
nd->nd_type = bitset_type;
}
[
element(nd)
[
',' { *nd = MkNode(Link, *nd, NULLNODE, &dot);
nd = &((*nd)->nd_right);
}
element(nd)
[ { nd = nd->nd_right; }
',' element(nd)
]*
]?
'}'
@ -213,12 +234,19 @@ ActualParameters(struct node **pnd;):
'(' ExpList(pnd)? ')'
;
element(struct node **pnd;):
expression(pnd)
element(struct node *nd;)
{
struct node *nd1;
} :
expression(&nd1)
[
UPTO { *pnd = MkNode(Link, *pnd, NULLNODE, &dot);}
expression(&((*pnd)->nd_right))
UPTO
{ nd1 = MkNode(Link, nd1, NULLNODE, &dot);}
expression(&(nd1->nd_right))
]?
{ nd->nd_right = MkNode(Link, nd1, NULLNODE, &dot);
nd->nd_right->nd_symb = ',';
}
;
designator(struct node **pnd;)

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

@ -47,7 +47,7 @@ main(argc, argv)
#ifdef DEBUG
print("Mod2 compiler -- Debug version\n");
#endif DEBUG
DO_DEBUG(debug(1,"Debugging level: %d", options['D']));
DO_DEBUG(1, debug("Debugging level: %d", options['D']));
return !Compile(Nargv[1]);
}
@ -56,7 +56,7 @@ Compile(src)
{
extern struct tokenname tkidf[];
DO_DEBUG(debug(1,"Filename : %s", src));
DO_DEBUG(1, debug("Filename : %s", src));
if (! InsertFile(src, (char **) 0, &src)) {
fprint(STDERR,"%s: cannot open %s\n", ProgName, src);
return 0;
@ -65,15 +65,13 @@ Compile(src)
FileName = src;
init_DEFPATH();
init_idf();
init_cst();
reserve(tkidf);
init_scope();
init_types();
add_standards();
#ifdef DEBUG
if (options['L'])
LexScan();
else if (options['T'])
TimeScan();
if (options['L']) LexScan();
else {
#endif DEBUG
(void) open_scope(CLOSEDSCOPE, 0);
@ -92,7 +90,7 @@ LexScan()
{
register int symb;
while ((symb = LLlex()) != EOI) {
while ((symb = LLlex()) > 0) {
print(">>> %s ", symbol2str(symb));
switch(symb) {
@ -113,14 +111,10 @@ LexScan()
break;
default:
putchar('\n');
print("\n");
}
}
}
TimeScan() {
while (LLlex() != -1) /* nothing */;
}
#endif
Option(str)
@ -165,11 +159,7 @@ add_standards()
D_TYPE,
construct_type(PROCEDURE, NULLTYPE),
0);
tp = construct_type(SUBRANGE, int_type);
tp->sub_lb = 0;
tp->sub_ub = wrd_size * 8 - 1;
df = Enter("BITSET", D_TYPE, construct_type(SET, tp), 0);
df->df_type->tp_size = wrd_size;
df = Enter("BITSET", D_TYPE, bitset_type, 0);
df = Enter("FALSE", D_ENUM, bool_type, 0);
df->df_value.df_enum.en_val = 0;
df->df_value.df_enum.en_next = Enter("TRUE", D_ENUM, bool_type, 0);

29
lang/m2/comp/node.c
View file

@ -5,10 +5,13 @@ static char *RcsId = "$Header$";
#include <em_label.h>
#include <em_arith.h>
#include <alloc.h>
#include <system.h>
#include "main.h"
#include "def.h"
#include "type.h"
#include "LLlex.h"
#include "node.h"
#include "debug.h"
struct node *h_node; /* header of free list */
@ -26,6 +29,7 @@ MkNode(class, left, right, token)
nd->nd_token = *token;
nd->nd_class = class;
nd->nd_type = NULLTYPE;
DO_DEBUG(4,(debug("Create node:"), PrNode(nd)));
return nd;
}
@ -39,3 +43,28 @@ FreeNode(nd)
if (nd->nd_right) FreeNode(nd->nd_right);
free_node(nd);
}
#ifdef DEBUG
extern char *symbol2str();
static
printnode(nd)
register struct node *nd;
{
fprint(STDERR, "(");
if (nd) {
printnode(nd->nd_left);
fprint(STDERR, " %s ", symbol2str(nd->nd_symb));
printnode(nd->nd_right);
}
fprint(STDERR, ")");
}
PrNode(nd)
struct node *nd;
{
printnode(nd);
fprint(STDERR, "\n");
}
#endif DEBUG

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

@ -114,7 +114,7 @@ DefinitionModule
if (!SYSTEMModule) open_scope(CLOSEDSCOPE, 0);
df->mod_scope = CurrentScope->sc_scope;
DefinitionModule = 1;
DO_DEBUG(debug(1, "Definition module \"%s\"", id->id_text));
DO_DEBUG(1, debug("Definition module \"%s\"", id->id_text));
}
';'
import(0)*

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

@ -11,6 +11,7 @@ static char *RcsId = "$Header$";
#include "scope.h"
#include "type.h"
#include "def.h"
#include "main.h"
#include "debug.h"
static int maxscope; /* maximum assigned scope number */
@ -35,7 +36,7 @@ open_scope(scopetype, scope)
sc->sc_scope = scope == 0 ? ++maxscope : scope;
sc->sc_forw = 0; sc->sc_def = 0;
assert(scopetype == OPENSCOPE || scopetype == CLOSEDSCOPE);
DO_DEBUG(debug(1, "Opening a %s scope",
DO_DEBUG(1, debug("Opening a %s scope",
scopetype == OPENSCOPE ? "open" : "closed"));
sc1 = CurrentScope;
if (scopetype == CLOSEDSCOPE) {
@ -55,7 +56,7 @@ close_scope()
register struct scope *sc = CurrentScope;
assert(sc != 0);
DO_DEBUG(debug(1, "Closing a scope"));
DO_DEBUG(1, debug("Closing a scope"));
if (sc->sc_forw) rem_forwards(sc->sc_forw);
if (sc->next && (sc->next->sc_scope == 0)) {
struct scope *sc1 = sc;

1
lang/m2/comp/tokenname.c
View file

@ -80,6 +80,7 @@ struct tokenname tkinternal[] = { /* internal keywords */
{ENUMERATION, ""},
{ERRONEOUS, ""},
{PROCVAR, ""},
{INTORCARD, ""},
{0, "0"}
};

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

@ -77,7 +77,10 @@ extern struct type
*longreal_type,
*word_type,
*address_type,
*error_type;
*intorcard_type,
*string_type,
*bitset_type,
*error_type; /* All from type.c */
extern int
wrd_align,
@ -86,7 +89,7 @@ extern int
real_align,
lreal_align,
ptr_align,
record_align;
record_align; /* All from type.c */
extern arith
wrd_size,
@ -94,14 +97,14 @@ extern arith
lint_size,
real_size,
lreal_size,
ptr_size;
ptr_size; /* All from type.c */
extern arith
align();
align(); /* type.c */
struct type
*create_type(),
*construct_type(),
*standard_type();
*standard_type(); /* All from type.c */
#define NULLTYPE ((struct type *) 0)

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

@ -44,6 +44,9 @@ struct type
*longreal_type,
*word_type,
*address_type,
*intorcard_type,
*string_type,
*bitset_type,
*error_type;
struct paramlist *h_paramlist;
@ -123,6 +126,8 @@ standard_type(fund, align, size)
init_types()
{
register struct type *tp;
char_type = standard_type(CHAR, 1, (arith) 1);
bool_type = standard_type(BOOLEAN, 1, (arith) 1);
int_type = standard_type(INTEGER, int_align, int_size);
@ -131,9 +136,15 @@ init_types()
real_type = standard_type(REAL, real_align, real_size);
longreal_type = standard_type(LONGREAL, lreal_align, lreal_size);
word_type = standard_type(WORD, wrd_align, wrd_size);
intorcard_type = standard_type(INTORCARD, int_align, int_size);
string_type = standard_type(STRING, 1, (arith) -1);
address_type = construct_type(POINTER, word_type);
tp = construct_type(SUBRANGE, int_type);
tp->sub_lb = 0;
tp->sub_ub = wrd_size * 8 - 1;
bitset_type = construct_type(SET, tp);
bitset_type->tp_size = wrd_size;
error_type = standard_type(ERRONEOUS, 1, (arith) 1);
}
int

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

@ -52,3 +52,32 @@ TstProcEquiv(tp1, tp2)
if (p1 != p2) return 0;
return 1;
}
int
TstCompat(tp1, tp2)
register struct type *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 (tp2->tp_fund == SUBRANGE) tp1 = tp1->next;
if (tp2->tp_fund == SUBRANGE) tp1 = tp1->next;
return tp1 == tp2
||
( tp1 == address_type
&&
( tp2 == card_type
|| tp2 == intorcard_type
|| tp2->tp_fund == POINTER
)
)
||
( tp2 == address_type
&&
( tp1 == card_type
|| tp1 == intorcard_type
|| tp1->tp_fund == POINTER
)
);
}