godzil/tack
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fixup commit for tag 'llgen-1-0'

Browse Source
This commit is contained in:
cvs2hg
2006-02-04 00:57:05 +00:00
parent 84701a5c29
commit 22d8b82972
7762 changed files with 0 additions and 664261 deletions
Download Patch File Download Diff File Expand all files Collapse all files

62
lang/m2/comp/.distr
View File

@@ -1,62 +0,0 @@
LLlex.c
LLlex.h
LLmessage.c
proto.make
proto.main
BigPars
SmallPars
SYSTEM.h
casestat.C
char.tab
chk_expr.c
chk_expr.h
class.h
code.c
cstoper.c
debug.h
declar.g
def.H
def.c
defmodule.c
desig.c
desig.h
em_m2.6
enter.c
error.c
expression.g
f_info.h
idf.c
idf.h
input.c
input.h
lookup.c
main.c
main.h
make.allocd
make.hfiles
make.next
make.tokcase
make.tokfile
misc.c
misc.h
modula-2.1
node.H
node.c
options.c
options
program.g
real.H
scope.C
scope.h
stab.c
standards.h
statement.g
tmpvar.C
tokenname.c
tokenname.h
type.H
type.c
typequiv.c
walk.c
walk.h
warning.h

100
lang/m2/comp/BigPars
View File

@@ -1,100 +0,0 @@
!File: errout.h
#define ERROUT STDERR /* file pointer for writing messages */
#define ERR_SHADOW 5 /* a syntax error overshadows error messages
until ERR_SHADOW symbols have been
accepted without syntax error */
!File: idfsize.h
#define IDFSIZE 128 /* maximum significant length of an identifier */
!File: numsize.h
#define NUMSIZE 256 /* maximum length of a numeric constant */
!File: strsize.h
#define ISTRSIZE 32 /* minimum number of bytes allocated for
storing a string */
#define RSTRSIZE 8 /* step size in enlarging the memory for
the storage of a string */
!File: target_sizes.h
#define MAXSIZE 8 /* the maximum of the SZ_* constants */
/* target machine sizes */
#define SZ_CHAR ((arith)1)
#define SZ_SHORT ((arith)2)
#define SZ_WORD ((arith)4)
#define SZ_INT ((arith)4)
#define SZ_LONG ((arith)4)
#define SZ_FLOAT ((arith)4)
#define SZ_DOUBLE ((arith)8)
#define SZ_POINTER ((arith)4)
/* target machine alignment requirements */
#define AL_CHAR 1
#define AL_SHORT ((int)SZ_SHORT)
#define AL_WORD ((int)SZ_WORD)
#define AL_INT ((int)SZ_WORD)
#define AL_LONG ((int)SZ_WORD)
#define AL_FLOAT ((int)SZ_WORD)
#define AL_DOUBLE ((int)SZ_WORD)
#define AL_POINTER ((int)SZ_WORD)
#define AL_STRUCT ((int)SZ_WORD)
!File: debugcst.h
/*#define DEBUG 1 /* perform various self-tests */
#define NDEBUG 1 /* disable assertions */
!File: inputtype.h
#define INP_READ_IN_ONE 1 /* read input file in one */
!File: density.h
#define DENSITY 3 /* see casestat.C for an explanation */
!File: squeeze.h
/*#define SQUEEZE 1 /* define on "small" machines */
!File: strict3rd.h
/*#define STRICT_3RD_ED 1 /* define on "small" machines, and if you want
a compiler that only implements "3rd edition"
Modula-2
*/
!File: nocross.h
/*#define NOCROSS 1 /* define when cross-compiler not needed */
!File: nostrict.h
/*#define NOSTRICT 1 /* define when STRICT warnings disabled
(yet another squeezing method)
*/
!File: bigresult.h
#define BIG_RESULT_ON_STACK 1 /* define when function results must be
put on the stack; in this case, caller
reserves space for it. When not defined,
callee puts result in global data area and
returns a pointer to it
*/
!File: dbsymtab.h
#define DBSYMTAB 1 /* ability to produce symbol table for debugger */
!File: use_insert.h
#define USE_INSERT 1 /* use C_insertpart mechanism */
!File: uns_arith.h
/*#define UNSIGNED_ARITH unsigned arith /* when it is supported */

671
lang/m2/comp/LLlex.c
View File

@@ -1,671 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* L E X I C A L A N A L Y S E R F O R M O D U L A - 2 */
/* $Id$ */
#include "debug.h"
#include "idfsize.h"
#include "numsize.h"
#include "strsize.h"
#include <alloc.h>
#include <em_arith.h>
#include <em_label.h>
#include <assert.h>
#include "LLlex.h"
#include "input.h"
#include "f_info.h"
#include "Lpars.h"
#include "class.h"
#include "idf.h"
#include "def.h"
#include "type.h"
#include "warning.h"
#include "errout.h"
extern char *getwdir();
t_token dot,
aside;
t_type *toktype;
int idfsize = IDFSIZE;
int ForeignFlag;
#ifdef DEBUG
extern int cntlines;
#endif
int token_nmb = 0;
int tk_nmb_at_last_syn_err = -ERR_SHADOW;
extern char options[];
extern int flt_status;
STATIC
SkipComment()
{
/* Skip Modula-2 comments (* ... *).
Note that comments may be nested (par. 3.5).
*/
register int ch, c;
register int CommentLevel = 0;
LoadChar(ch);
if (ch == '$') {
LoadChar(ch);
switch(ch) {
case 'F':
/* Foreign; This definition module has an
implementation in another language.
In this case, don't generate prefixes in front
of the names. Also, don't generate call to
initialization routine.
*/
ForeignFlag = D_FOREIGN;
break;
case 'U':
inidf['_'] = 1;
break;
case 'A': /* Extra array bound checks, on or off */
case 'R': /* Range checks, on or off */
{
int on_on_minus = ch == 'R';
LoadChar(c);
if (c == '-') {
options[ch] = on_on_minus;
break;
}
if (c == '+') {
options[ch] = !on_on_minus;
break;
}
ch = c;
}
/* fall through */
default:
break;
}
}
for (;;) {
if (!(ch & 0200) && class(ch) == STNL) {
LineNumber++;
#ifdef DEBUG
cntlines++;
#endif
}
else if (ch == '(') {
LoadChar(ch);
if (ch == '*') CommentLevel++;
else continue;
}
else if (ch == '*') {
LoadChar(ch);
if (ch == ')') {
CommentLevel--;
if (CommentLevel < 0) break;
}
else continue;
}
else if (ch == EOI) {
lexerror("unterminated comment");
PushBack();
break;
}
LoadChar(ch);
}
}
STATIC struct string *
GetString(upto)
{
/* Read a Modula-2 string, delimited by the character "upto".
*/
register int ch;
register struct string *str = (struct string *)
Malloc((unsigned) sizeof(struct string));
register char *p;
register int len;
len = ISTRSIZE;
str->s_str = p = Malloc((unsigned int) ISTRSIZE);
while (LoadChar(ch), ch != upto) {
if (!(ch & 0200) && class(ch) == STNL) {
lexerror("newline in string");
LineNumber++;
#ifdef DEBUG
cntlines++;
#endif
break;
}
if (ch == EOI) {
lexerror("end-of-file in string");
break;
}
*p++ = ch;
if (p - str->s_str == len) {
str->s_str = Realloc(str->s_str,
(unsigned int) len + RSTRSIZE);
p = str->s_str + len;
len += RSTRSIZE;
}
}
str->s_length = p - str->s_str;
len = (str->s_length+(int)word_size) & ~((int)word_size-1);
while (p - str->s_str < len) {
*p++ = '\0';
}
str->s_str = Realloc(str->s_str, (unsigned) len);
if (str->s_length == 0) str->s_length = 1;
/* ??? string length at least 1 ??? */
return str;
}
static char *s_error = "illegal line directive";
STATIC int
getch()
{
register int ch;
while (LoadChar(ch), (ch & 0200) && ch != EOI) {
error("non-ascii '\\%03o' read", ch & 0377);
}
return ch;
}
CheckForLineDirective()
{
register int ch = getch();
register int i = 0;
char buf[IDFSIZE];
register char *c = buf;
if (ch != '#') {
PushBack();
return;
}
do { /*
* Skip to next digit
* Do not skip newlines
*/
ch = getch();
if (class(ch) == STNL || class(ch) == STEOI) {
LineNumber++;
error(s_error);
return;
}
} while (class(ch) != STNUM);
while (class(ch) == STNUM) {
i = i*10 + (ch - '0');
ch = getch();
}
while (ch != '"' && class(ch) != STNL && class(ch) != STEOI)
ch = getch();
if (ch == '"') {
c = buf;
do {
ch = getch();
if (c < &buf[IDFSIZE]) *c++ = ch;
if (class(ch) == STNL || class(ch) == STEOI) {
LineNumber++;
error(s_error);
return;
}
} while (ch != '"');
*--c = '\0';
do {
ch = getch();
} while (class(ch) != STNL && class(ch) != STEOI);
/*
* Remember the file name
*/
if (class(ch) == STNL && strcmp(FileName,buf)) {
FileName = Salloc(buf,(unsigned) strlen(buf) + 1);
WorkingDir = getwdir(FileName);
}
}
if (class(ch) == STEOI) {
error(s_error);
return;
}
LineNumber = i;
}
STATIC
CheckForLet()
{
register int ch;
LoadChar(ch);
if (ch != EOI) {
if (class(ch) == STIDF) {
lexerror("token separator required between identifier and number");
}
PushBack();
}
}
int
LLlex()
{
/* LLlex() is the Lexical Analyzer.
The putting aside of tokens is taken into account.
*/
register t_token *tk = &dot;
char buf[(IDFSIZE > NUMSIZE ? IDFSIZE : NUMSIZE) + 2];
register int ch, nch;
toktype = error_type;
if (ASIDE) { /* a token is put aside */
*tk = aside;
ASIDE = 0;
return tk->tk_symb;
}
token_nmb++;
again:
ch = getch();
tk->tk_lineno = LineNumber;
switch (class(ch)) {
case STNL:
LineNumber++;
#ifdef DEBUG
cntlines++;
#endif
CheckForLineDirective();
goto again;
case STSKIP:
goto again;
case STGARB:
if ((unsigned) ch - 040 < 0137) {
lexerror("garbage char %c", ch);
}
else lexerror("garbage char \\%03o", ch);
goto again;
case STSIMP:
if (ch == '(') {
LoadChar(nch);
if (nch == '*') {
SkipComment();
goto again;
}
PushBack();
}
if (ch == '&') return tk->tk_symb = AND;
if (ch == '~') return tk->tk_symb = NOT;
return tk->tk_symb = ch;
case STCOMP:
LoadChar(nch);
switch (ch) {
case '.':
if (nch == '.') {
return tk->tk_symb = UPTO;
}
break;
case ':':
if (nch == '=') {
return tk->tk_symb = BECOMES;
}
break;
case '<':
if (nch == '=') {
return tk->tk_symb = LESSEQUAL;
}
if (nch == '>') {
return tk->tk_symb = '#';
}
break;
case '>':
if (nch == '=') {
return tk->tk_symb = GREATEREQUAL;
}
break;
default :
crash("(LLlex, STCOMP)");
}
PushBack();
return tk->tk_symb = ch;
case STIDF:
{
register char *tag = &buf[0];
register t_idf *id;
do {
if (tag - buf < idfsize) *tag++ = ch;
LoadChar(ch);
if (ch == '_' && *(tag-1) == '_') {
lexerror("an identifier may not contain two consecutive underscores");
}
} while(in_idf(ch));
PushBack();
*tag = '\0';
if (*(tag - 1) == '_') {
lexerror("last character of an identifier may not be an underscore");
}
tk->TOK_IDF = id = str2idf(buf, 1);
return tk->tk_symb = id->id_reserved ? id->id_reserved : IDENT;
}
case STSTR: {
register struct string *str = GetString(ch);
if (str->s_length == 1) {
tk->TOK_INT = *(str->s_str) & 0377;
toktype = char_type;
free(str->s_str);
free((char *) str);
}
else {
tk->tk_data.tk_str = str;
if (! fit((arith)(str->s_length), (int) word_size)) {
lexerror("string too long");
}
toktype = standard_type(T_STRING, 1, (arith)(str->s_length));
}
return tk->tk_symb = STRING;
}
case STNUM:
{
/* The problem arising with the "parsing" of a number
is that we don't know the base in advance so we
have to read the number with the help of a rather
complex finite automaton.
*/
enum statetp {Oct,OptHex,Hex,Dec,OctEndOrHex,End,OptReal,Real};
register enum statetp state;
register int base = 8;
register char *np = &buf[0];
*np++ = ch;
state = is_oct(ch) ? Oct : Dec;
LoadChar(ch);
for (;;) {
switch(state) {
case Oct:
while (is_oct(ch)) {
if (np < &buf[NUMSIZE]) *np++ = ch;
LoadChar(ch);
}
if (ch == 'B' || ch == 'C') {
state = OctEndOrHex;
break;
}
/* Fall Through */
case Dec:
base = 10;
while (is_dig(ch)) {
if (np < &buf[NUMSIZE]) {
*np++ = ch;
}
LoadChar(ch);
}
if (ch == 'D') state = OptHex;
else if (is_hex(ch)) state = Hex;
else if (ch == '.') state = OptReal;
else {
state = End;
if (ch == 'H') base = 16;
else PushBack();
}
break;
case OptHex:
LoadChar(ch);
if (is_hex(ch)) {
if (np < &buf[NUMSIZE]) *np++ = 'D';
state = Hex;
}
else {
state = End;
ch = 'D';
PushBack();
}
break;
case Hex:
while (is_hex(ch)) {
if (np < &buf[NUMSIZE]) *np++ = ch;
LoadChar(ch);
}
base = 16;
state = End;
if (ch != 'H') {
lexerror("H expected after hex number");
PushBack();
}
break;
case OctEndOrHex:
if (np < &buf[NUMSIZE]) *np++ = ch;
LoadChar(ch);
if (ch == 'H') {
base = 16;
state = End;
break;
}
if (is_hex(ch)) {
state = Hex;
break;
}
PushBack();
ch = *--np;
*np++ = '\0';
/* Fall through */
case End: {
int ovfl = 0;
*np = '\0';
if (np >= &buf[NUMSIZE]) {
tk->TOK_INT = 1;
lexerror("constant too long");
}
else {
/* The upperbound will be the same as
when computed with something like
max(unsigned long) / base (when base
is even). The problem is that
unsigned long or unsigned arith is
not accepted by all compilers
*/
arith ubound = max_int[sizeof(arith)]
/ (base >> 1);
np = &buf[0];
while (*np == '0') np++;
tk->TOK_INT = 0;
while (*np) {
int c;
if (is_dig(*np)) {
c = *np++ - '0';
}
else {
assert(is_hex(*np));
c = *np++ - 'A' + 10;
}
if (tk->TOK_INT < 0 ||
tk->TOK_INT > ubound) {
ovfl++;
}
tk->TOK_INT = tk->TOK_INT*base;
if (tk->TOK_INT < 0 &&
tk->TOK_INT + c >= 0) {
ovfl++;
}
tk->TOK_INT += c;
}
}
toktype = card_type;
if (ch == 'C' && base == 8) {
toktype = char_type;
if (ovfl != 0 || tk->TOK_INT>255 ||
tk->TOK_INT < 0) {
lexwarning(W_ORDINARY, "character constant out of range");
}
CheckForLet();
return tk->tk_symb = INTEGER;
}
if (options['l']) {
if (base != 10) {
LoadChar(ch);
if (ch != 'D') {
PushBack();
}
}
}
if (ch == 'D' && (options['l'] || base == 10)) {
if (options['l']) {
/* Local extension: LONGCARD exists,
so internally also longintorcard_type
exists.
*/
toktype = longcard_type;
if (ovfl == 0 && tk->TOK_INT >= 0 &&
tk->TOK_INT<=max_int[(int)long_size]) {
toktype = longintorcard_type;
}
else if (! chk_bounds(tk->TOK_INT,
full_mask[(int)long_size],
T_CARDINAL)) {
ovfl = 1;
}
}
else {
if (ovfl != 0 ||
tk->TOK_INT > max_int[(int)long_size] ||
tk->TOK_INT < 0) {
ovfl = 1;
}
toktype = longint_type;
}
}
else if (ovfl == 0 && tk->TOK_INT >= 0 &&
tk->TOK_INT<=max_int[(int)int_size]) {
toktype = intorcard_type;
}
else if (! chk_bounds(tk->TOK_INT,
full_mask[(int)int_size],
T_CARDINAL)) {
ovfl = 1;
}
if (ovfl)
lexwarning(W_ORDINARY, "overflow in constant");
CheckForLet();
return tk->tk_symb = INTEGER;
}
case OptReal:
/* The '.' could be the first of the '..'
token. At this point, we need a
look-ahead of two characters.
*/
LoadChar(ch);
if (ch == '.') {
/* Indeed the '..' token
*/
PushBack();
PushBack();
state = End;
base = 10;
break;
}
state = Real;
break;
}
if (state == Real) break;
}
/* a real real constant */
if (np < &buf[NUMSIZE]) *np++ = '.';
toktype = real_type;
while (is_dig(ch)) {
/* Fractional part
*/
if (np < &buf[NUMSIZE]) *np++ = ch;
LoadChar(ch);
}
if (ch == 'D') {
toktype = longreal_type;
LoadChar(ch);
if (ch == '+' || ch == '-' || is_dig(ch)) {
ch = 'E';
PushBack();
}
}
if (ch == 'E') {
/* Scale factor
*/
if (np < &buf[NUMSIZE]) *np++ = ch;
LoadChar(ch);
if (ch == '+' || ch == '-') {
/* Signed scalefactor
*/
if (np < &buf[NUMSIZE]) *np++ = ch;
LoadChar(ch);
}
if (is_dig(ch)) {
do {
if (np < &buf[NUMSIZE]) *np++ = ch;
LoadChar(ch);
} while (is_dig(ch));
}
else {
lexerror("bad scale factor");
}
}
*np++ = '\0';
PushBack();
tk->tk_data.tk_real = new_real();
if (np >= &buf[NUMSIZE]) {
tk->TOK_RSTR = Salloc("0.0", 4);
lexerror("real constant too long");
}
else tk->TOK_RSTR = Salloc(buf, (unsigned) (np - buf));
CheckForLet();
flt_str2flt(tk->TOK_RSTR, &(tk->TOK_RVAL));
if (flt_status == FLT_OVFL) {
lexwarning(W_ORDINARY, "overflow in floating point constant");
}
return tk->tk_symb = REAL;
/*NOTREACHED*/
}
case STEOI:
return tk->tk_symb = -1;
case STCHAR:
default:
crash("(LLlex) Impossible character class");
/*NOTREACHED*/
}
/*NOTREACHED*/
}

70
lang/m2/comp/LLlex.h
View File

@@ -1,70 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* T O K E N D E S C R I P T O R D E F I N I T I O N */
/* $Id$ */
#include "real.h"
/* Structure to store a string constant
*/
struct string {
unsigned s_length; /* length of a string */
char *s_str; /* the string itself */
};
union tk_attr {
struct string *tk_str;
arith tk_int;
struct real *tk_real;
struct {
union {
arith *tky_set;
struct idf *tky_idf;
struct def *tky_def;
} tk_yy;
struct node *tky_next;
} tk_y;
struct {
struct node *tkx_left, *tkx_right;
} tk_x;
};
#define tk_left tk_x.tkx_left
#define tk_right tk_x.tkx_right
#define tk_next tk_y.tky_next
#define tk_idf tk_y.tk_yy.tky_idf
#define tk_def tk_y.tk_yy.tky_def
#define tk_set tk_y.tk_yy.tky_set
/* Token structure. Keep it small, as it is part of a parse-tree node
*/
struct token {
short tk_symb; /* token itself */
unsigned short tk_lineno; /* linenumber on which it occurred */
union tk_attr tk_data;
};
typedef struct token t_token;
#define TOK_IDF tk_data.tk_idf
#define TOK_SSTR tk_data.tk_str
#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_REAL tk_data.tk_real
#define TOK_RSTR tk_data.tk_real->r_real
#define TOK_RVAL tk_data.tk_real->r_val
extern t_token dot, aside;
extern struct type *toktype;
#define DOT dot.tk_symb
#define ASIDE aside.tk_symb
extern int token_nmb;
extern int tk_nmb_at_last_syn_err;

78
lang/m2/comp/LLmessage.c
View File

@@ -1,78 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* S Y N T A X E R R O R R E P O R T I N G */
/* $Id$ */
/* Defines the LLmessage routine. LLgen-generated parsers require the
existence of a routine of that name.
The routine must do syntax-error reporting and must be able to
insert tokens in the token stream.
*/
#include <alloc.h>
#include <em_arith.h>
#include <em_label.h>
#include "idf.h"
#include "LLlex.h"
#include "Lpars.h"
extern char *symbol2str();
extern t_idf *gen_anon_idf();
LLmessage(tk)
register int tk;
{
if (tk > 0) {
/* if (tk > 0), it represents the token to be inserted.
*/
register t_token *dotp = &dot;
#ifndef LLNONCORR
error("%s missing before %s", symbol2str(tk), symbol2str(dotp->tk_symb));
#endif
aside = *dotp;
dotp->tk_symb = tk;
switch (tk) {
/* The operands need some body */
case IDENT:
dotp->TOK_IDF = gen_anon_idf();
break;
case STRING:
dotp->tk_data.tk_str = (struct string *)
Malloc(sizeof (struct string));
dotp->TOK_SLE = 1;
dotp->TOK_STR = Salloc("", 1);
break;
case INTEGER:
dotp->TOK_INT = 1;
break;
case REAL:
dotp->tk_data.tk_real = new_real();
dotp->TOK_RSTR = Salloc("0.0", 4);
flt_str2flt(dotp->TOK_RSTR, &dotp->TOK_RVAL);
break;
}
}
else if (tk < 0) {
error("end of file expected");
}
else {
#ifndef LLNONCORR
error("%s deleted", symbol2str(dot.tk_symb));
#else
error("%s not expected", symbol2str(dot.tk_symb));
#endif
}
tk_nmb_at_last_syn_err = token_nmb;
}

78
lang/m2/comp/Parameters
View File

@@ -1,78 +0,0 @@
!File: errout.h
#define ERROUT STDERR /* file pointer for writing messages */
#define MAXERR_LINE 100 /* maximum number of error messages given
on the same input line. */
!File: idfsize.h
#define IDFSIZE 128 /* maximum significant length of an identifier */
!File: numsize.h
#define NUMSIZE 256 /* maximum length of a numeric constant */
!File: strsize.h
#define ISTRSIZE 32 /* minimum number of bytes allocated for
storing a string */
#define RSTRSIZE 8 /* step size in enlarging the memory for
the storage of a string */
!File: target_sizes.h
#define MAXSIZE 8 /* the maximum of the SZ_* constants */
/* target machine sizes */
#define SZ_CHAR ((arith)1)
#define SZ_SHORT ((arith)2)
#define SZ_WORD ((arith)4)
#define SZ_INT ((arith)4)
#define SZ_LONG ((arith)4)
#define SZ_FLOAT ((arith)4)
#define SZ_DOUBLE ((arith)8)
#define SZ_POINTER ((arith)4)
/* target machine alignment requirements */
#define AL_CHAR 1
#define AL_SHORT ((int)SZ_SHORT)
#define AL_WORD ((int)SZ_WORD)
#define AL_INT ((int)SZ_WORD)
#define AL_LONG ((int)SZ_WORD)
#define AL_FLOAT ((int)SZ_WORD)
#define AL_DOUBLE ((int)SZ_WORD)
#define AL_POINTER ((int)SZ_WORD)
#define AL_STRUCT ((int)SZ_WORD)
!File: debugcst.h
#define DEBUG 1 /* perform various self-tests */
!File: inputtype.h
#define INP_READ_IN_ONE 1 /* read input file in one */
!File: density.h
#define DENSITY 3 /* see casestat.C for an explanation */
!File: squeeze.h
#undef SQUEEZE 1 /* define on "small" machines */
!File: strict3rd.h
#undef STRICT_3RD_ED 1 /* define on "small" machines, and if you want
a compiler that only implements "3rd edition"
Modula-2
*/
!File: nocross.h
#undef NOCROSS 1 /* define when cross-compiler not needed */
!File: nostrict.h
#undef NOSTRICT 1 /* define when STRICT warnings disabled
(yet another squeezing method)
*/

60
lang/m2/comp/Resolve
View File

@@ -1,60 +0,0 @@
: create a directory Xsrc with name clashes resolved
: and run make in that directory
: '$Header$'
case $# in
1)
;;
*) echo "$0: one argument expected" 1>&2
exit 1
;;
esac
PW=`pwd`
case $1 in
main) target=$PW/$1
;;
omain) target=$PW/$1
options=-DPEEPHOLE
;;
cemain) target=$PW/$1
options=-DCODE_EXPANDER
;;
Xlint) target=$1
;;
*) echo "$0: $1: Illegal argument" 1>&2
exit 1
;;
esac
if test -d ../Xsrc
then
:
else mkdir ../Xsrc
fi
make EMHOME=$EMHOME longnames
: remove code generating routines from the clashes list as they are defines.
: code generating routine names start with C_
sed '/^C_/d' < longnames > tmp$$
cclash -c -l7 tmp$$ > ../Xsrc/Xclashes
rm -f tmp$$
cd ../Xsrc
if cmp -s Xclashes clashes
then
:
else
mv Xclashes clashes
fi
rm -f Makefile
ed - $PW/Makefile <<'EOF'
/^#EXCLEXCL/,/^#INCLINCL/d
w Makefile
q
EOF
for i in `cat $PW/Cfiles`
do
cat >> Makefile <<EOF
$i: clashes $PW/$i
\$(CID) -Fclashes < $PW/$i > $i
EOF
done
make EMHOME=$EMHOME COPTIONS=$options MACH=$MACH CURRDIR=$PW/ $target

25
lang/m2/comp/SYSTEM.h
View File

@@ -1,25 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* S Y S T E M M O D U L E T E X T */
/* $Id$ */
/* Text of SYSTEM module, for as far as it can be expressed in Modula-2 */
#ifndef STRICT_3RD_ED
#define SYSTEMTEXT "DEFINITION MODULE SYSTEM;\n\
TYPE PROCESS = ADDRESS;\n\
PROCEDURE NEWPROCESS(P:PROC; A:ADDRESS; n:CARDINAL; VAR p1:ADDRESS);\n\
PROCEDURE TRANSFER(VAR p1,p2:ADDRESS);\n\
END SYSTEM.\n"
#else
#define SYSTEMTEXT "DEFINITION MODULE SYSTEM;\n\
PROCEDURE NEWPROCESS(P:PROC; A:ADDRESS; n:CARDINAL; VAR p1:ADDRESS);\n\
PROCEDURE TRANSFER(VAR p1,p2:ADDRESS);\n\
END SYSTEM.\n"
#endif

100
lang/m2/comp/SmallPars
View File

@@ -1,100 +0,0 @@
!File: errout.h
#define ERROUT STDERR /* file pointer for writing messages */
#define ERR_SHADOW 5 /* a syntax error overshadows error messages
until ERR_SHADOW symbols have been
accepted without syntax error */
!File: idfsize.h
#define IDFSIZE 128 /* maximum significant length of an identifier */
!File: numsize.h
#define NUMSIZE 256 /* maximum length of a numeric constant */
!File: strsize.h
#define ISTRSIZE 32 /* minimum number of bytes allocated for
storing a string */
#define RSTRSIZE 8 /* step size in enlarging the memory for
the storage of a string */
!File: target_sizes.h
#define MAXSIZE 8 /* the maximum of the SZ_* constants */
/* target machine sizes */
#define SZ_CHAR ((arith)1)
#define SZ_SHORT ((arith)2)
#define SZ_WORD ((arith)2)
#define SZ_INT ((arith)2)
#define SZ_LONG ((arith)4)
#define SZ_FLOAT ((arith)4)
#define SZ_DOUBLE ((arith)8)
#define SZ_POINTER ((arith)2)
/* target machine alignment requirements */
#define AL_CHAR 1
#define AL_SHORT ((int)SZ_SHORT)
#define AL_WORD ((int)SZ_WORD)
#define AL_INT ((int)SZ_WORD)
#define AL_LONG ((int)SZ_WORD)
#define AL_FLOAT ((int)SZ_WORD)
#define AL_DOUBLE ((int)SZ_WORD)
#define AL_POINTER ((int)SZ_WORD)
#define AL_STRUCT ((int)SZ_WORD)
!File: debugcst.h
/*#define DEBUG 1 /* perform various self-tests */
#define NDEBUG 1 /* disable assertions */
!File: inputtype.h
/*#define INP_READ_IN_ONE 1 /* read input file in one */
!File: density.h
#define DENSITY 3 /* see casestat.C for an explanation */
!File: squeeze.h
#define SQUEEZE 1 /* define on "small" machines */
!File: strict3rd.h
#define STRICT_3RD_ED 1 /* define on "small" machines, and if you want
a compiler that only implements "3rd edition"
Modula-2
*/
!File: nocross.h
#define NOCROSS 1 /* define when cross-compiler not needed */
!File: nostrict.h
#define NOSTRICT 1 /* define when STRICT warnings disabled
(yet another squeezing method)
*/
!File: bigresult.h
#define BIG_RESULT_ON_STACK 1 /* define when function results must be
put on the stack; in this case, caller
reserves space for it. When not defined,
callee puts result in global data area and
returns a pointer to it
*/
!File: dbsymtab.h
/*#define DBSYMTAB 1 /* ability to produce symbol table for debugger */
!File: use_insert.h
/*#define USE_INSERT 1 /* use C_insertpart mechanism */
!File: uns_arith.h
/*#define UNSIGNED_ARITH unsigned arith /* when it is supported */

1
lang/m2/comp/Version.c
View File

@@ -1 +0,0 @@
static char Version[] = "ACK Modula-2 compiler Version 0.50";

385
lang/m2/comp/casestat.C
View File

@@ -1,385 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* C A S E S T A T E M E N T C O D E G E N E R A T I O N */
/* $Id$ */
/* Generation of case statements is done by first creating a
description structure for the statement, build a list of the
case-labels, then generating a case description in the code,
and generating either CSA or CSB, and then generating code for the
cases themselves.
*/
#include "debug.h"
#include <em_label.h>
#include <em_arith.h>
#include <em_code.h>
#include <alloc.h>
#include <assert.h>
#include "Lpars.h"
#include "type.h"
#include "LLlex.h"
#include "node.h"
#include "desig.h"
#include "walk.h"
#include "chk_expr.h"
#include "def.h"
#include "density.h"
struct switch_hdr {
label sh_break; /* label of statement after this one */
label sh_default; /* label of ELSE part, or 0 */
int sh_nrofentries; /* number of cases */
t_type *sh_type; /* type of case expression */
arith sh_lowerbd; /* lowest case label */
arith sh_upperbd; /* highest case label */
struct case_entry *sh_entries; /* the cases with their generated
labels
*/
};
/* STATICALLOCDEF "switch_hdr" 5 */
struct case_entry {
struct case_entry *ce_next; /* next in list */
label ce_label; /* generated label */
arith ce_low, ce_up; /* lower and upper bound of range */
};
/* STATICALLOCDEF "case_entry" 20 */
/* The constant DENSITY determines when CSA and when CSB instructions
are generated. Reasonable values are: 2, 3, 4.
On machines that have lots of address space and memory, higher values
might also be reasonable. On these machines the density of jump tables
may be lower.
*/
compact(nr, low, up)
arith low, up;
{
/* Careful! up - low might not fit in an arith. And then,
the test "up-low < 0" might also not work to detect this
situation! Or is this just a bug in the M68020/M68000?
*/
arith diff = up - low;
return (nr != 0 && diff >= 0 && fit(diff, (int) word_size) &&
diff / nr <= (DENSITY - 1));
}
#define nd_lab nd_symb
int
CaseCode(nd, exitlabel, end_reached)
t_node *nd;
label exitlabel;
{
/* Check the expression, stack a new case header and
fill in the necessary fields.
"exitlabel" is the exit-label of the closest enclosing
LOOP-statement, or 0.
*/
register struct switch_hdr *sh = new_switch_hdr();
register t_node *pnode = nd;
register struct case_entry *ce;
register arith val;
label CaseDescrLab;
int rval;
assert(pnode->nd_class == Stat && pnode->nd_symb == CASE);
if (ChkExpression(&(pnode->nd_LEFT))) {
MkCoercion(&(pnode->nd_LEFT),BaseType(pnode->nd_LEFT->nd_type));
CodePExpr(pnode->nd_LEFT);
}
sh->sh_type = pnode->nd_LEFT->nd_type;
sh->sh_break = ++text_label;
/* Now, create case label list
*/
while (pnode = pnode->nd_RIGHT) {
if (pnode->nd_class == Link && pnode->nd_symb == '|') {
if (pnode->nd_LEFT) {
/* non-empty case
*/
pnode->nd_LEFT->nd_lab = ++text_label;
AddCases(sh, /* to descriptor */
pnode->nd_LEFT->nd_LEFT,
/* of case labels */
(label) pnode->nd_LEFT->nd_lab
/* and code label */
);
}
}
else {
/* Else part
*/
sh->sh_default = ++text_label;
break;
}
}
if (!sh->sh_nrofentries) {
/* There were no cases, so we have to check the case-expression
here
*/
if (! (sh->sh_type->tp_fund & T_DISCRETE)) {
node_error(nd, "illegal type in CASE-expression");
}
}
/* Now generate code for the switch itself
First the part that CSA and CSB descriptions have in common.
*/
CaseDescrLab = ++data_label; /* the rom must have a label */
C_df_dlb(CaseDescrLab);
if (sh->sh_default) C_rom_ilb(sh->sh_default);
else C_rom_ucon("0", pointer_size);
if (compact(sh->sh_nrofentries, sh->sh_lowerbd, sh->sh_upperbd)) {
/* CSA
*/
int gen = 1;
ce = sh->sh_entries;
while (! ce->ce_label) ce = ce->ce_next;
C_rom_cst((arith) 0);
C_rom_cst(sh->sh_upperbd - sh->sh_lowerbd);
for (val = sh->sh_lowerbd; val <= sh->sh_upperbd; val++) {
assert(ce);
if (gen || val == ce->ce_low) {
gen = 1;
C_rom_ilb(ce->ce_label);
if (val == ce->ce_up) {
gen = 0;
ce = ce->ce_next;
while (ce && ! ce->ce_label) ce = ce->ce_next;
}
}
else if (sh->sh_default) C_rom_ilb(sh->sh_default);
else C_rom_ucon("0", pointer_size);
}
C_loc(sh->sh_lowerbd);
C_sbu(word_size);
c_lae_dlb(CaseDescrLab); /* perform the switch */
C_csa(word_size);
}
else {
/* CSB
*/
C_rom_cst((arith)sh->sh_nrofentries);
for (ce = sh->sh_entries; ce; ce = ce->ce_next) {
/* generate the entries: value + prog.label
*/
if (! ce->ce_label) continue;
val = ce->ce_low;
do {
C_rom_cst(val);
C_rom_ilb(ce->ce_label);
} while (val++ != ce->ce_up);
}
c_lae_dlb(CaseDescrLab); /* perform the switch */
C_csb(word_size);
}
/* Now generate code for the cases
*/
pnode = nd;
rval = 0;
while (pnode = pnode->nd_RIGHT) {
if (pnode->nd_class == Link && pnode->nd_symb == '|') {
if (pnode->nd_LEFT) {
rval |= LblWalkNode((label) pnode->nd_LEFT->nd_lab,
pnode->nd_LEFT->nd_RIGHT,
exitlabel, end_reached);
c_bra(sh->sh_break);
}
}
else {
/* Else part
*/
assert(sh->sh_default != 0);
rval |= LblWalkNode(sh->sh_default,
pnode, exitlabel, end_reached);
break;
}
}
def_ilb(sh->sh_break);
FreeSh(sh);
return rval;
}
FreeSh(sh)
register struct switch_hdr *sh;
{
/* free the allocated switch structure
*/
register struct case_entry *ce;
ce = sh->sh_entries;
while (ce) {
struct case_entry *tmp = ce->ce_next;
free_case_entry(ce);
ce = tmp;
}
free_switch_hdr(sh);
}
AddCases(sh, node, lbl)
struct switch_hdr *sh;
register t_node *node;
label lbl;
{
/* Add case labels to the case label list
*/
if (node->nd_class == Link) {
if (node->nd_symb == UPTO) {
assert(node->nd_LEFT->nd_class == Value);
assert(node->nd_RIGHT->nd_class == Value);
AddOneCase(sh, node->nd_LEFT, node->nd_RIGHT, lbl);
return;
}
assert(node->nd_symb == ',');
AddCases(sh, node->nd_LEFT, lbl);
AddCases(sh, node->nd_RIGHT, lbl);
return;
}
assert(node->nd_class == Value);
AddOneCase(sh, node, node, lbl);
}
AddOneCase(sh, lnode, rnode, lbl)
register struct switch_hdr *sh;
t_node *lnode, *rnode;
label lbl;
{
register struct case_entry *ce = new_case_entry();
register struct case_entry *c1 = sh->sh_entries, *c2 = 0;
int fund = sh->sh_type->tp_fund;
arith diff;
if (! ChkCompat(&lnode, sh->sh_type, "case") ||
! ChkCompat(&rnode, sh->sh_type, "case")) {
}
ce->ce_label = lbl;
ce->ce_low = lnode->nd_INT;
ce->ce_up = rnode->nd_INT;
diff = rnode->nd_INT - lnode->nd_INT;
#define MAXRANGE 100
if (diff < 0 || diff > MAXRANGE) {
/* This is a bit of a hack, but it prevents the compiler
from crashing on things like
CASE a OF
10 .. MAX(CARDINAL): ....
If the range covers more than MAXRANGE cases, this case
is dealt with separately.
*/
label cont = ++text_label;
C_dup(int_size);
C_loc(lnode->nd_INT);
if (fund == T_INTEGER) {
C_blt(cont);
}
else {
C_cmu(int_size);
C_zlt(cont);
}
C_dup(int_size);
C_loc(rnode->nd_INT);
if (fund == T_INTEGER) {
C_bgt(cont);
}
else {
C_cmu(int_size);
C_zgt(cont);
}
C_asp(int_size);
c_bra(lbl);
C_df_ilb(cont);
ce->ce_label = 0;
}
if (sh->sh_entries == 0) {
/* first case entry
*/
sh->sh_entries = ce;
if (ce->ce_label) {
sh->sh_lowerbd = ce->ce_low;
sh->sh_upperbd = ce->ce_up;
}
}
else {
/* second etc. case entry
find the proper place to put ce into the list
*/
while (c1 && chk_bounds(c1->ce_low, ce->ce_low, fund)) {
c2 = c1;
c1 = c1->ce_next;
}
/* At this point three cases are possible:
1: c1 != 0 && c2 != 0:
insert ce somewhere in the middle
2: c1 != 0 && c2 == 0:
insert ce right after the head
3: c1 == 0 && c2 != 0:
append ce to last element
The case c1 == 0 && c2 == 0 cannot occur, since
the list is guaranteed not to be empty.
*/
if (c2) {
if ( chk_bounds(ce->ce_low, c2->ce_up, fund)) {
node_error(rnode, "multiple case entry for value %ld", (long)(ce->ce_low));
free_case_entry(ce);
return;
}
}
if (c1) {
if ( chk_bounds(c1->ce_low, ce->ce_up, fund)) {
node_error(rnode, "multiple case entry for value %ld", (long)(ce->ce_up));
free_case_entry(ce);
return;
}
if (c2) {
ce->ce_next = c2->ce_next;
c2->ce_next = ce;
}
else {
ce->ce_next = sh->sh_entries;
sh->sh_entries = ce;
}
}
else {
assert(c2);
c2->ce_next = ce;
}
if (ce->ce_label) {
if (! chk_bounds(sh->sh_lowerbd, ce->ce_low, fund)) {
sh->sh_lowerbd = ce->ce_low;
}
if (! chk_bounds(ce->ce_up, sh->sh_upperbd, fund)) {
sh->sh_upperbd = ce->ce_up;
}
}
}
if (ce->ce_label) sh->sh_nrofentries += ce->ce_up - ce->ce_low + 1;
}

53
lang/m2/comp/char.tab
View File

@@ -1,53 +0,0 @@
% character tables for mod2 compiler
% $Id$
%S129
%F %s,
%
% CHARACTER CLASSES
%
%iSTGARB
STSKIP: \t\013\014\015
STNL:\012
STSIMP:-#&()*+,/;=[]^{|}~
STCOMP:.:<>
STIDF:a-zA-Z
STSTR:"'
STNUM:0-9
STEOI:\200
%T#include "class.h"
%Tchar tkclass[] = {
%p
%T};
%
% INIDF
%
%C
1:a-zA-Z0-9
%Tchar inidf[] = {
%F %s,
%p
%T};
%
% ISDIG
%
%C
1:0-9
%Tchar isdig[] = {
%p
%T};
%
% ISHEX
%
%C
1:A-F0-9
%Tchar ishex[] = {
%p
%T};
%
% ISOCT
%
%C
1:0-7
%Tchar isoct[] = {
%p
%T};

1576
lang/m2/comp/chk_expr.c
View File

File diff suppressed because it is too large Load Diff

25
lang/m2/comp/chk_expr.h
View File

@@ -1,25 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* E X P R E S S I O N C H E C K I N G */
/* $Id$ */
extern int (*ExprChkTable[])(); /* table of expression checking
functions, indexed by node class
*/
extern int (*DesigChkTable[])(); /* table of designator checking
functions, indexed by node class
*/
#define ChkExpression(expp) ((*ExprChkTable[(*expp)->nd_class])(expp,D_USED))
#define ChkDesig(expp, flags) ((*DesigChkTable[(*expp)->nd_class])(expp,flags))
/* handle reference counts for sets */
#define inc_refcount(s) (*((int *)(s) - 1) += 1)
#define dec_refcount(s) (*((int *)(s) - 1) -= 1)
#define refcount(s) (*((int *)(s) - 1))

45
lang/m2/comp/class.h
View File

@@ -1,45 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* U S E O F C H A R A C T E R C L A S S E S */
/* $Id$ */
/* As a starter, chars are divided into classes, according to which
token they can be the start of.
At present such a class number is supposed to fit in 4 bits.
*/
#define class(ch) (tkclass[ch])
/* Being the start of a token is, fortunately, a mutual exclusive
property, so, as there are less than 16 classes they can be
packed in 4 bits.
*/
#define STSKIP 0 /* spaces and so on: skipped characters */
#define STNL 1 /* newline character(s): update linenumber etc. */
#define STGARB 2 /* garbage ascii character: not allowed */
#define STSIMP 3 /* this character can occur as token */
#define STCOMP 4 /* this one can start a compound token */
#define STIDF 5 /* being the initial character of an identifier */
#define STCHAR 6 /* the starter of a character constant */
#define STSTR 7 /* the starter of a string */
#define STNUM 8 /* the starter of a numeric constant */
#define STEOI 9 /* End-Of-Information mark */
/* But occurring inside a token is not, so we need 1 bit for each
class. This is implemented as a collection of tables to speed up
the decision whether a character has a special meaning.
*/
#define in_idf(ch) ((unsigned)ch < 0177 && inidf[ch])
#define is_oct(ch) ((unsigned)ch < 0177 && isoct[ch])
#define is_dig(ch) ((unsigned)ch < 0177 && isdig[ch])
#define is_hex(ch) ((unsigned)ch < 0177 && ishex[ch])
extern char tkclass[];
extern char inidf[], isoct[], isdig[], ishex[];

1254
lang/m2/comp/code.c
View File

File diff suppressed because it is too large Load Diff

15
lang/m2/comp/const.h
View File

@@ -1,15 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* 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$ */
#define arith_sign ((arith) (1L << (sizeof(arith) * 8 - 1)))
extern unsigned int
wrd_bits; /* Number of bits in a word */

697
lang/m2/comp/cstoper.c
View File

@@ -1,697 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* 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 */
/* $Id$ */
#include "debug.h"
#include "target_sizes.h"
#include "uns_arith.h"
#include <em_arith.h>
#include <em_label.h>
#include <assert.h>
#include <alloc.h>
#include "idf.h"
#include "type.h"
#include "LLlex.h"
#include "node.h"
#include "Lpars.h"
#include "standards.h"
#include "warning.h"
extern char *symbol2str();
#define arith_sign ((arith) (1L << (sizeof(arith) * 8 - 1)))
#ifndef NOCROSS
arith full_mask[MAXSIZE+1];/* full_mask[1] == 0xFF, full_mask[2] == 0xFFFF, .. */
arith max_int[MAXSIZE+1]; /* max_int[1] == 0x7F, max_int[2] == 0x7FFF, .. */
arith min_int[MAXSIZE+1]; /* min_int[1] == 0xFFFFFF80, min_int[2] = 0xFFFF8000,
...
*/
unsigned int wrd_bits; /* number of bits in a word */
#else
arith full_mask[] = { 0L, 0xFFL, 0xFFFFL, 0L, 0xFFFFFFFFL };
arith max_int[] = { 0L, 0x7FL, 0x7FFFL, 0L, 0x7FFFFFFFL };
arith min_int[] = { 0L, -128L, -32768L, 0L, -2147483647L-1 };
#endif
extern char options[];
overflow(expp)
t_node *expp;
{
if (expp->nd_type != address_type) {
node_warning(expp, W_ORDINARY, "overflow in constant expression");
}
}
STATIC
commonbin(expp)
t_node **expp;
{
register t_node *exp = *expp;
t_type *tp = exp->nd_type;
register t_node *right = exp->nd_RIGHT;
exp->nd_RIGHT = 0;
FreeNode(exp);
*expp = right;
right->nd_type = tp;
}
cstunary(expp)
t_node **expp;
{
/* The unary operation in "expp" is performed on the constant
expression below it, and the result restored in expp.
*/
register t_node *exp = *expp;
register t_node *right = exp->nd_RIGHT;
register arith o1 = right->nd_INT;
switch(exp->nd_symb) {
/* Should not get here
case '+':
break;
*/
case '-':
if (! options['s'] &&
o1 == min_int[(int)(right->nd_type->tp_size)]) {
overflow(exp);
}
o1 = -o1;
break;
case NOT:
case '~':
o1 = !o1;
break;
default:
crash("(cstunary)");
}
commonbin(expp);
(*expp)->nd_INT = o1;
CutSize(*expp);
}
STATIC
divide(pdiv, prem)
arith *pdiv, *prem;
{
/* Unsigned divide *pdiv by *prem, and store result in *pdiv,
remainder in *prem
*/
register arith o1 = *pdiv;
register arith o2 = *prem;
#ifndef UNSIGNED_ARITH
/* this is more of a problem than you might
think on C compilers which do not have
unsigned long.
*/
if (o2 & arith_sign) {/* o2 > max_arith */
if (! (o1 >= 0 || o1 < o2)) {
/* this is the unsigned test
o1 < o2 for o2 > max_arith
*/
*prem = o2 - o1;
*pdiv = 1;
}
else {
*pdiv = 0;
}
}
else { /* o2 <= max_arith */
arith half, bit, hdiv, hrem, rem;
half = (o1 >> 1) & ~arith_sign;
bit = o1 & 01;
/* now o1 == 2 * half + bit
and half <= max_arith
and bit <= max_arith
*/
hdiv = half / o2;
hrem = half % o2;
rem = 2 * hrem + bit;
*pdiv = 2*hdiv;
*prem = rem;
if (rem < 0 || rem >= o2) {
/* that is the unsigned compare
rem >= o2 for o2 <= max_arith
*/
*pdiv += 1;
*prem -= o2;
}
}
#else
*pdiv = (UNSIGNED_ARITH) o1 / (UNSIGNED_ARITH) o2;
*prem = (UNSIGNED_ARITH) o1 % (UNSIGNED_ARITH) o2;
#endif
}
cstibin(expp)
t_node **expp;
{
/* The binary operation in "expp" is performed on the constant
expressions below it, and the result restored in expp.
This version is for INTEGER expressions.
*/
register t_node *exp = *expp;
register arith o1 = exp->nd_LEFT->nd_INT;
register arith o2 = exp->nd_RIGHT->nd_INT;
register int sz = exp->nd_type->tp_size;
assert(exp->nd_class == Oper);
assert(exp->nd_LEFT->nd_class == Value);
assert(exp->nd_RIGHT->nd_class == Value);
switch (exp->nd_symb) {
case '*':
if (o1 > 0) {
if (o2 > 0) {
if (max_int[sz] / o1 < o2) overflow(exp);
}
else if (min_int[sz] / o1 > o2) overflow(exp);
}
else if (o1 < 0) {
if (o2 < 0) {
if (o1 == min_int[sz] || o2 == min_int[sz] ||
max_int[sz] / (-o1) < (-o2)) overflow(exp);
}
else if (o2 > 0) {
if (min_int[sz] / o2 > o1) overflow(exp);
}
}
o1 *= o2;
break;
case DIV:
case MOD:
if (o2 == 0) {
node_error(exp, exp->nd_symb == DIV ?
"division by 0" :
"modulo by 0");
return;
}
if ((o1 < 0) != (o2 < 0)) {
if (o1 < 0) o1 = -o1;
else o2 = -o2;
if (exp->nd_symb == DIV) o1 = -((o1+o2-1)/o2);
else o1 = ((o1+o2-1)/o2) * o2 - o1;
}
else {
if (exp->nd_symb == DIV) o1 /= o2;
else o1 %= o2;
}
break;
case '+':
if ( (o1 > 0 && o2 > 0 && max_int[sz] - o1 < o2)
|| (o1 < 0 && o2 < 0 && min_int[sz] - o1 > o2)
) overflow(exp);
o1 += o2;
break;
case '-':
if ( (o1 >= 0 && o2 < 0 && max_int[sz] + o2 < o1)
|| (o1 < 0 && o2 >= 0 && min_int[sz] + o2 > o1)
) overflow(exp);
o1 -= o2;
break;
case '<':
o1 = (o1 < o2);
break;
case '>':
o1 = (o1 > o2);
break;
case LESSEQUAL:
o1 = (o1 <= o2);
break;
case GREATEREQUAL:
o1 = (o1 >= o2);
break;
case '=':
o1 = (o1 == o2);
break;
case '#':
o1 = (o1 != o2);
break;
default:
crash("(cstibin)");
}
commonbin(expp);
(*expp)->nd_INT = o1;
CutSize(*expp);
}
cstfbin(expp)
t_node **expp;
{
/* The binary operation in "expp" is performed on the constant
expressions below it, and the result restored in expp.
This version is for REAL expressions.
*/
register t_node *exp = *expp;
register struct real *p = exp->nd_LEFT->nd_REAL;
register flt_arith *o1 = &p->r_val;
register flt_arith *o2 = &exp->nd_RIGHT->nd_RVAL;
int compar = 0;
int cmpval = 0;
assert(exp->nd_class == Oper);
assert(exp->nd_LEFT->nd_class == Value);
assert(exp->nd_RIGHT->nd_class == Value);
switch (exp->nd_symb) {
case '*':
flt_mul(o1, o2, o1);
break;
case '/':
flt_div(o1, o2, o1);
break;
case '+':
flt_add(o1, o2, o1);
break;
case '-':
flt_sub(o1, o2, o1);
break;
case '<':
case '>':
case LESSEQUAL:
case GREATEREQUAL:
case '=':
case '#':
compar++;
cmpval = flt_cmp(o1, o2);
switch(exp->nd_symb) {
case '<': cmpval = (cmpval < 0); break;
case '>': cmpval = (cmpval > 0); break;
case LESSEQUAL: cmpval = (cmpval <= 0); break;
case GREATEREQUAL: cmpval = (cmpval >= 0); break;
case '=': cmpval = (cmpval == 0); break;
case '#': cmpval = (cmpval != 0); break;
}
if (exp->nd_RIGHT->nd_RSTR) free(exp->nd_RIGHT->nd_RSTR);
free_real(exp->nd_RIGHT->nd_REAL);
break;
default:
crash("(cstfbin)");
}
switch(flt_status) {
case FLT_OVFL:
node_warning(exp, "floating point overflow on %s",
symbol2str(exp->nd_symb));
break;
case FLT_DIV0:
node_error(exp, "division by 0.0");
break;
}
if (p->r_real) {
free(p->r_real);
p->r_real = 0;
}
if (compar) {
free_real(p);
}
commonbin(expp);
exp = *expp;
if (compar) {
exp->nd_symb = INTEGER;
exp->nd_INT = cmpval;
}
else {
exp->nd_REAL = p;
}
CutSize(exp);
}
cstubin(expp)
t_node **expp;
{
/* The binary operation in "expp" is performed on the constant
expressions below it, and the result restored in
expp.
*/
register t_node *exp = *expp;
arith o1 = exp->nd_LEFT->nd_INT;
arith o2 = exp->nd_RIGHT->nd_INT;
register int sz = exp->nd_type->tp_size;
arith tmp1, tmp2;
assert(exp->nd_class == Oper);
assert(exp->nd_LEFT->nd_class == Value);
assert(exp->nd_RIGHT->nd_class == Value);
switch (exp->nd_symb) {
case '*':
if (o1 == 0 || o2 == 0) {
o1 = 0;
break;
}
tmp1 = full_mask[sz];
tmp2 = o2;
divide(&tmp1, &tmp2);
if (! chk_bounds(o1, tmp1, T_CARDINAL)) overflow(exp);
o1 *= o2;
break;
case DIV:
case MOD:
if (o2 == 0) {
node_error(exp, exp->nd_symb == DIV ?
"division by 0" :
"modulo by 0");
return;
}
divide(&o1, &o2);
if (exp->nd_symb == MOD) o1 = o2;
break;
case '+':
if (! chk_bounds(o2, full_mask[sz] - o1, T_CARDINAL)) {
overflow(exp);
}
o1 += o2;
break;
case '-':
if ( exp->nd_type != address_type
&& !chk_bounds(o2, o1, T_CARDINAL)
&& ( exp->nd_type->tp_fund != T_INTORCARD
|| ( exp->nd_type = int_type
, !chk_bounds(min_int[sz], o1 - o2, T_CARDINAL) ) )
) {
node_warning(exp, W_ORDINARY,
"underflow in constant expression");
}
o1 -= o2;
break;
case '<':
o1 = ! chk_bounds(o2, o1, T_CARDINAL);
break;
case '>':
o1 = ! chk_bounds(o1, o2, T_CARDINAL);
break;
case LESSEQUAL:
o1 = chk_bounds(o1, o2, T_CARDINAL);
break;
case GREATEREQUAL:
o1 = chk_bounds(o2, o1, T_CARDINAL);
break;
case '=':
o1 = (o1 == o2);
break;
case '#':
o1 = (o1 != o2);
break;
case AND:
case '&':
o1 = (o1 && o2);
break;
case OR:
o1 = (o1 || o2);
break;
default:
crash("(cstubin)");
}
commonbin(expp);
exp = *expp;
exp->nd_INT = o1;
if (exp->nd_type == bool_type) exp->nd_symb = INTEGER;
CutSize(exp);
}
cstset(expp)
t_node **expp;
{
extern arith *MkSet();
register t_node *exp = *expp;
register arith *set1, *set2, *set3;
register unsigned int setsize;
register int j;
assert(exp->nd_RIGHT->nd_class == Set);
assert(exp->nd_symb == IN || exp->nd_LEFT->nd_class == Set);
set2 = exp->nd_RIGHT->nd_set;
setsize = (unsigned) (exp->nd_RIGHT->nd_type->tp_size) / (unsigned) word_size;
if (exp->nd_symb == IN) {
/* The setsize must fit in an unsigned, as it is
allocated with Malloc, so we can do the arithmetic
in an unsigned too.
*/
unsigned i;
assert(exp->nd_LEFT->nd_class == Value);
exp->nd_LEFT->nd_INT -= exp->nd_RIGHT->nd_type->set_low;
exp = exp->nd_LEFT;
i = exp->nd_INT;
/* Careful here; use exp->nd_LEFT->nd_INT to see if
it falls in the range of the set. Do not use i
for this, as i may be truncated.
*/
i = (exp->nd_INT >= 0 &&
exp->nd_INT < setsize * wrd_bits &&
(set2[i / wrd_bits] & (1 << (i % wrd_bits))));
FreeSet(set2);
exp = getnode(Value);
exp->nd_symb = INTEGER;
exp->nd_lineno = (*expp)->nd_lineno;
exp->nd_INT = i;
exp->nd_type = bool_type;
FreeNode(*expp);
*expp = exp;
return;
}
set1 = exp->nd_LEFT->nd_set;
*expp = getnode(Set);
(*expp)->nd_type = exp->nd_type;
(*expp)->nd_lineno = exp->nd_lineno;
switch(exp->nd_symb) {
case '+': /* Set union */
case '-': /* Set difference */
case '*': /* Set intersection */
case '/': /* Symmetric set difference */
(*expp)->nd_set = set3 = MkSet(exp->nd_type->set_sz);
for (j = 0; j < setsize; j++) {
switch(exp->nd_symb) {
case '+':
*set3++ = *set1++ | *set2++;
break;
case '-':
*set3++ = *set1++ & ~*set2++;
break;
case '*':
*set3++ = *set1++ & *set2++;
break;
case '/':
*set3++ = *set1++ ^ *set2++;
break;
}
}
break;
case GREATEREQUAL:
case LESSEQUAL:
case '=':
case '#':
/* Constant set comparisons
*/
for (j = 0; j < setsize; j++) {
switch(exp->nd_symb) {
case GREATEREQUAL:
if ((*set1 | *set2++) != *set1) break;
set1++;
continue;
case LESSEQUAL:
if ((*set2 | *set1++) != *set2) break;
set2++;
continue;
case '=':
case '#':
if (*set1++ != *set2++) break;
continue;
}
break;
}
if (j < setsize) {
j = exp->nd_symb == '#';
}
else {
j = exp->nd_symb != '#';
}
*expp = getnode(Value);
(*expp)->nd_symb = INTEGER;
(*expp)->nd_INT = j;
(*expp)->nd_type = bool_type;
(*expp)->nd_lineno = (*expp)->nd_lineno;
break;
default:
crash("(cstset)");
}
FreeSet(exp->nd_LEFT->nd_set);
FreeSet(exp->nd_RIGHT->nd_set);
FreeNode(exp);
}
cstcall(expp, call)
t_node **expp;
{
/* a standard procedure call is found that can be evaluated
compile time, so do so.
*/
register t_node *expr;
register t_type *tp;
assert((*expp)->nd_class == Call);
expr = (*expp)->nd_RIGHT->nd_LEFT;
tp = expr->nd_type;
expr->nd_type = (*expp)->nd_type;
(*expp)->nd_RIGHT->nd_LEFT = 0;
FreeNode(*expp);
*expp = expr;
expr->nd_symb = INTEGER;
expr->nd_class = Value;
switch(call) {
case S_ABS:
if (expr->nd_INT < 0) {
if (! options['s'] &&
expr->nd_INT <= min_int[(int)(tp->tp_size)]) {
overflow(expr);
}
expr->nd_INT = - expr->nd_INT;
}
CutSize(expr);
break;
case S_CAP:
if (expr->nd_INT >= 'a' && expr->nd_INT <= 'z') {
expr->nd_INT += ('A' - 'a');
}
break;
case S_HIGH:
case S_MAX:
if (tp->tp_fund == T_INTEGER) {
expr->nd_INT = max_int[(int)(tp->tp_size)];
}
else if (tp->tp_fund == T_CARDINAL) {
expr->nd_INT = full_mask[(int)(tp->tp_size)];
}
else if (tp->tp_fund == T_SUBRANGE) {
expr->nd_INT = tp->sub_ub;
}
else expr->nd_INT = tp->enm_ncst - 1;
break;
case S_MIN:
if (tp->tp_fund == T_INTEGER) {
expr->nd_INT = min_int[(int)(tp->tp_size)];
}
else if (tp->tp_fund == T_SUBRANGE) {
expr->nd_INT = tp->sub_lb;
}
else expr->nd_INT = 0;
break;
case S_ODD:
expr->nd_INT &= 1;
break;
case S_TSIZE:
case S_SIZE:
expr->nd_INT = tp->tp_size;
break;
default:
crash("(cstcall)");
}
}
CutSize(expr)
register t_node *expr;
{
/* The constant value of the expression expr is made to
conform to the size of the type of the expression.
*/
register t_type *tp = BaseType(expr->nd_type);
assert(expr->nd_class == Value);
if (tp->tp_fund == T_REAL) return;
if (tp->tp_fund != T_INTEGER) {
expr->nd_INT &= full_mask[(int)(tp->tp_size)];
}
else {
int nbits = (int) (sizeof(arith) - tp->tp_size) * 8;
expr->nd_INT = (expr->nd_INT << nbits) >> nbits;
}
}
InitCst()
{
register int i = 0;
#ifndef NOCROSS
register arith bt = (arith)0;
while (!(bt < 0)) {
i++;
bt = (bt << 8) + 0377;
if (i == MAXSIZE+1)
fatal("array full_mask too small for this machine");
full_mask[i] = bt;
max_int[i] = bt & ~(1L << ((8 * i) - 1));
min_int[i] = - max_int[i];
if (! options['s']) min_int[i]--;
}
if ((int)long_size > sizeof(arith)) {
fatal("sizeof (arith) insufficient on this machine");
}
wrd_bits = 8 * (int) word_size;
#else
if (options['s']) {
for (i = 0; i < sizeof(long); i++) min_int[i] = - max_int[i];
}
#endif
}

20
lang/m2/comp/debug.h
View File

@@ -1,20 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* D E B U G G I N G M A C R O */
/* $Id$ */
#include "debugcst.h"
#ifdef DEBUG
#define DO_DEBUG(x, y) ((x) && (y))
#define STATIC
#else
#define DO_DEBUG(x, y)
#define STATIC static
#endif

567
lang/m2/comp/declar.g
View File

@@ -1,567 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* D E C L A R A T I O N S */
/* $Id$ */
{
#include "debug.h"
#include <em_arith.h>
#include <em_label.h>
#include <alloc.h>
#include <assert.h>
#include "strict3rd.h"
#include "idf.h"
#include "LLlex.h"
#include "def.h"
#include "type.h"
#include "scope.h"
#include "node.h"
#include "misc.h"
#include "main.h"
#include "chk_expr.h"
#include "warning.h"
#include "nostrict.h"
int proclevel = 0; /* nesting level of procedures */
int return_occurred; /* set if a return occurs in a block */
extern t_node *EmptyStatement;
#define needs_static_link() (proclevel > 1)
}
/* inline in declaration: need space
* ProcedureDeclaration
* {
* t_def *df;
* } :
* { ++proclevel; }
* ProcedureHeading(&df, D_PROCEDURE)
* ';' block(&(df->prc_body))
* IDENT
* { EndProc(df, dot.TOK_IDF);
* --proclevel;
* }
* ;
*/
ProcedureHeading(t_def **pdf; int type;)
{
t_type *tp = 0;
arith parmaddr = needs_static_link() ? pointer_size : 0;
t_param *pr = 0;
} :
PROCEDURE IDENT
{ *pdf = DeclProc(type, dot.TOK_IDF); }
[
'('
[
FPSection(&pr, &parmaddr)
[
';' FPSection(&pr, &parmaddr)
]*
|
]
')'
[ ':' qualtype(&tp)
|
]
|
]
{ CheckWithDef(*pdf, proc_type(tp, pr, parmaddr));
#ifndef NOSTRICT
if (tp && IsConstructed(tp)) {
warning(W_STRICT, "procedure \"%s\" has a constructed result type",
(*pdf)->df_idf->id_text);
}
#endif
}
;
block(t_node **pnd;) :
[ %persistent
declaration
]*
{ return_occurred = 0; }
[ %default
BEGIN
StatementSequence(pnd)
|
{ *pnd = EmptyStatement; }
]
END
;
declaration
{
t_def *df;
} :
CONST [ ConstantDeclaration ';' ]*
|
TYPE [ TypeDeclaration ';' ]*
|
VAR [ VariableDeclaration ';' ]*
|
{ ++proclevel; }
ProcedureHeading(&df, D_PROCEDURE)
{
}
';'
block(&(df->prc_body))
IDENT
{
EndProc(df, dot.TOK_IDF);
--proclevel;
}
';'
|
ModuleDeclaration ';'
;
/* inline in procedureheading: need space
* FormalParameters(t_param **ppr; arith *parmaddr; t_type **ptp;):
* '('
* [
* FPSection(ppr, parmaddr)
* [
* ';' FPSection(ppr, parmaddr)
* ]*
* |
* ]
* ')'
* [ ':' qualtype(ptp)
* |
* ]
* ;
*/
FPSection(t_param **ppr; arith *parmaddr;)
{
t_node *FPList;
t_type *tp;
int VARp;
} :
var(&VARp) IdentList(&FPList) ':' FormalType(&tp)
{ EnterParamList(ppr, FPList, tp, VARp, parmaddr); }
;
FormalType(t_type **ptp;)
/* index type of conformant array is "CARDINAL".
Recognize a conformant array by size 0.
*/
{ register t_type *tp;
} :
ARRAY OF
{ tp = construct_type(T_ARRAY, card_type); }
qualtype(&(tp->arr_elem))
{ ArrayElSize(tp);
*ptp = tp;
}
|
qualtype(ptp)
;
TypeDeclaration
{
t_def *df;
t_type *tp;
register t_node *nd;
}:
IDENT { df = define(dot.TOK_IDF, CurrentScope, D_TYPE);
nd = dot2leaf(Name);
}
'=' type(&tp)
{ DeclareType(nd, df, tp);
FreeNode(nd);
}
;
type(register t_type **ptp;):
%default SimpleType(ptp)
|
ArrayType(ptp)
|
RecordType(ptp)
|
SetType(ptp)
|
PointerType(ptp)
|
ProcedureType(ptp)
;
SimpleType(register t_type **ptp;) :
qualtype(ptp)
[
/* nothing */
|
SubrangeType(ptp)
/* The subrange type is given a base type by the
qualident (this is new modula-2).
*/
]
|
enumeration(ptp)
| { *ptp = 0; /* no qualification */ }
SubrangeType(ptp)
;
enumeration(t_type **ptp;)
{
t_node *EnumList;
} :
'(' IdentList(&EnumList) ')'
{ *ptp = enum_type(EnumList); }
;
IdentList(t_node **p;)
{
register t_node *q;
} :
IDENT { *p = q = dot2leaf(Select); }
[ %persistent
',' IDENT
{ q->nd_NEXT = dot2leaf(Select);
q = q->nd_NEXT;
}
]*
;
SubrangeType(t_type **ptp;)
{
t_node *nd1, *nd2;
}:
/*
This is not exactly the rule in the new report, but see
the rule for "SimpleType".
*/
'[' ConstExpression(&nd1)
UPTO ConstExpression(&nd2)
']'
{ *ptp = subr_type(nd1, nd2, *ptp);
FreeNode(nd1);
FreeNode(nd2);
}
;
ArrayType(t_type **ptp;)
{
t_type *tp;
register t_type *tp1, *tp2;
} :
ARRAY SimpleType(&tp)
{ tp1 = tp2 = construct_type(T_ARRAY, tp); }
[
',' SimpleType(&tp)
{ tp2->arr_elem = construct_type(T_ARRAY, tp);
tp2 = tp2->arr_elem;
}
]* OF type(&tp)
{ tp2->arr_elem = tp;
ArraySizes(tp1);
*ptp = tp1;
}
;
RecordType(t_type **ptp;)
{
register t_scope *scope;
arith size = 0;
int xalign = struct_align;
}
:
RECORD
{ scope = open_and_close_scope(OPENSCOPE); }
FieldListSequence(scope, &size, &xalign)
{ if (size == 0) {
warning(W_ORDINARY, "empty record declaration");
size = 1;
}
*ptp = standard_type(T_RECORD, xalign, align(size, xalign));
(*ptp)->rec_scope = scope;
Reverse(&(scope->sc_def));
}
END
;
FieldListSequence(t_scope *scope; arith *cnt; int *palign;):
FieldList(scope, cnt, palign)
[
';' FieldList(scope, cnt, palign)
]*
;
FieldList(t_scope *scope; arith *cnt; int *palign;)
{
t_node *FldList;
t_type *tp;
t_node *nd;
register t_def *df;
arith tcnt, max;
} :
[
IdentList(&FldList) ':' type(&tp)
{
*palign = lcm(*palign, tp->tp_align);
EnterFieldList(FldList, tp, scope, cnt);
}
|
CASE
/* Also accept old fashioned Modula-2 syntax, but give a warning.
Sorry for the complicated code.
*/
[ qualident(&nd)
[ ':' qualtype(&tp)
/* This is correct, in both kinds of Modula-2, if
the first qualident is a single identifier.
*/
{ if (nd->nd_class != Name) {
error("illegal variant tag");
}
else {
df = define(nd->nd_IDF, scope, D_FIELD);
*palign = lcm(*palign, tp->tp_align);
if (!(tp->tp_fund & T_DISCRETE)) {
error("illegal type in variant");
}
df->df_type = tp;
df->fld_off = align(*cnt, tp->tp_align);
*cnt = df->fld_off + tp->tp_size;
df->df_flags |= D_QEXPORTED;
}
FreeNode(nd);
}
| /* Old fashioned! the first qualident now represents
the type
*/
{
#ifndef STRICT_3RD_ED
if (! options['3']) warning(W_OLDFASHIONED,
"old fashioned Modula-2 syntax; ':' missing");
else
#endif
error("':' missing");
tp = qualified_type(&nd);
}
]
| ':' qualtype(&tp)
/* Aha, third edition. Well done! */
]
{ tcnt = *cnt; }
OF variant(scope, &tcnt, tp, palign)
{ max = tcnt; tcnt = *cnt; }
[
'|' variant(scope, &tcnt, tp, palign)
{ if (tcnt > max) max = tcnt; tcnt = *cnt; }
]*
[ ELSE FieldListSequence(scope, &tcnt, palign)
{ if (tcnt > max) max = tcnt; }
|
]
END
{ *cnt = max; }
|
]
;
variant(t_scope *scope; arith *cnt; t_type *tp; int *palign;)
{
t_node *nd;
} :
[
CaseLabelList(&tp, &nd)
{ /* Ignore the cases for the time being.
Maybe a checking version will be supplied
later ???
*/
FreeNode(nd);
}
':' FieldListSequence(scope, cnt, palign)
|
]
/* Changed rule in new modula-2 */
;
CaseLabelList(t_type **ptp; t_node **pnd;):
CaseLabels(ptp, pnd)
[
{ *pnd = dot2node(Link, *pnd, NULLNODE); }
',' CaseLabels(ptp, &((*pnd)->nd_RIGHT))
{ pnd = &((*pnd)->nd_RIGHT); }
]*
;
CaseLabels(t_type **ptp; register t_node **pnd;)
{
register t_node *nd;
}:
ConstExpression(pnd)
{
if (*ptp != 0) {
t_type *tp = intorcard(*ptp,
BaseType((*pnd)->nd_type));
if (tp) *ptp = tp;
ChkCompat(pnd, *ptp, "case label");
}
nd = *pnd;
nd->nd_type = BaseType(nd->nd_type); /* ??? */
if (! (nd->nd_type->tp_fund & T_DISCRETE) ||
nd->nd_type->tp_size > word_size) {
node_error(nd, "illegal type in case label");
}
}
[
UPTO { *pnd = nd = dot2node(Link,nd,NULLNODE);
nd->nd_type = nd->nd_LEFT->nd_type;
}
ConstExpression(&(*pnd)->nd_RIGHT)
{ if (!ChkCompat(&((*pnd)->nd_RIGHT), nd->nd_type,
"case label")) {
nd->nd_type = error_type;
}
else if (! chk_bounds(nd->nd_LEFT->nd_INT,
nd->nd_RIGHT->nd_INT,
nd->nd_type->tp_fund)) {
node_error(nd,
"lower bound exceeds upper bound in case label range");
}
}
|
]
{
*ptp = nd->nd_type;
}
;
SetType(t_type **ptp;)
{ t_type *tp;
} :
SET OF SimpleType(&tp)
{ *ptp = set_type(tp); }
;
/* In a pointer type definition, the type pointed at does not
have to be declared yet, so be careful about identifying
type-identifiers.
*/
PointerType(register t_type **ptp;)
{ register t_type *tp;
} :
{ tp = construct_type(T_POINTER, NULLTYPE); }
POINTER TO
[ %if (type_or_forward(tp))
type(&(tp->tp_next))
|
IDENT
]
{ *ptp = tp; }
;
qualtype(t_type **ptp;)
{
t_node *nd;
} :
qualident(&nd)
{ *ptp = qualified_type(&nd); }
;
ProcedureType(t_type **ptp;)
{
t_param *pr = 0;
arith parmaddr = 0;
t_type *tp = 0;
} :
PROCEDURE
[
FormalTypeList(&pr, &parmaddr, &tp)
|
]
{ *ptp = proc_type(tp, pr, parmaddr); }
;
FormalTypeList(t_param **ppr; arith *pparmaddr; t_type **ptp;) :
'('
[
VarFormalType(ppr, pparmaddr)
[
',' VarFormalType(ppr, pparmaddr)
]*
|
]
')'
[ ':' qualtype(ptp)
|
]
;
VarFormalType(t_param **ppr; arith *pparmaddr;)
{
t_type *tp;
int isvar;
} :
var(&isvar)
FormalType(&tp)
{ EnterParamList(ppr,NULLNODE,tp,isvar,pparmaddr); }
;
var(int *VARp;) :
[
VAR { *VARp = D_VARPAR; }
|
/* empty */ { *VARp = D_VALPAR; }
]
;
ConstantDeclaration
{
t_idf *id;
t_node *nd;
register t_def *df;
}:
IDENT { id = dot.TOK_IDF; }
'=' ConstExpression(&nd)
{ df = define(id,CurrentScope,D_CONST);
df->con_const = nd->nd_token;
df->df_type = nd->nd_type;
FreeNode(nd);
}
;
VariableDeclaration
{
t_node *VarList;
register t_node *nd;
t_type *tp;
} :
IdentAddr(&VarList)
{ nd = VarList; }
[ %persistent
',' IdentAddr(&(nd->nd_RIGHT))
{ nd = nd->nd_RIGHT; }
]*
':' type(&tp)
{ EnterVarList(VarList, tp, proclevel > 0); }
;
IdentAddr(t_node **pnd;)
{
register t_node *nd;
} :
IDENT { nd = dot2leaf(Name);
*pnd = dot2node(Link, nd, NULLNODE);
}
[ '['
ConstExpression(&(nd->nd_NEXT))
']'
|
]
;

143
lang/m2/comp/def.H
View File

@@ -1,143 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* I D E N T I F I E R D E S C R I P T O R S T R U C T U R E */
/* $Id$ */
struct module {
struct node *mo_priority;/* priority of a module */
struct scopelist *mo_vis;/* scope of this module */
struct node *mo_body; /* body of this module */
#define mod_priority df_value.df_module.mo_priority
#define mod_vis df_value.df_module.mo_vis
#define mod_body df_value.df_module.mo_body
};
struct variable {
arith va_off; /* address or offset of variable */
char *va_name; /* name of variable if given */
#define var_off df_value.df_variable.va_off
#define var_name df_value.df_variable.va_name
};
struct constant {
struct token co_const; /* result of a constant expression */
#define con_const df_value.df_constant.co_const
};
struct enumval {
arith en_val; /* value of this enumeration literal */
struct def *en_next; /* next enumeration literal */
#define enm_val df_value.df_enum.en_val
#define enm_next df_value.df_enum.en_next
};
struct field {
arith fd_off;
struct variant {
struct caselabellist *v_cases;
label v_casedescr;
struct def *v_varianttag;
} *fd_variant;
#define fld_off df_value.df_field.fd_off
#define fld_variant df_value.df_field.fd_variant
};
struct import {
struct def *im_def; /* imported definition */
#define imp_def df_value.df_import.im_def
};
struct dforward {
struct scopelist *fo_vis;
struct node *fo_node;
char *fo_name;
#define for_node df_value.df_forward.fo_node
#define for_vis df_value.df_forward.fo_vis
#define prc_vis df_value.df_forward.fo_vis
#define prc_body df_value.df_forward.fo_node
#define prc_name df_value.df_forward.fo_name
};
struct forwtype {
struct node *f_node;
struct def *f_def;
#define df_forw_node df_value.df_fortype.f_node
#define df_forw_def df_value.df_fortype.f_def
};
struct def { /* list of definitions for a name */
struct def *df_next; /* next definition in definitions chain */
struct def *df_nextinscope;
/* link all definitions in a scope */
struct idf *df_idf; /* link back to the name */
struct scope *df_scope; /* scope in which this definition resides */
unsigned short df_kind; /* the kind of this definition: */
#define D_MODULE 0x0001 /* a module */
#define D_PROCEDURE 0x0002 /* procedure of function */
#define D_VARIABLE 0x0004 /* a variable */
#define D_FIELD 0x0008 /* a field in a record */
#define D_TYPE 0x0010 /* a type */
#define D_ENUM 0x0020 /* an enumeration literal */
#define D_CONST 0x0040 /* a constant */
#define D_IMPORT 0x0080 /* an imported definition */
#define D_PROCHEAD 0x0100 /* a procedure heading in a definition module */
#define D_HIDDEN 0x0200 /* a hidden type */
#define D_FORWARD 0x0400 /* not yet defined */
#define D_FORWMODULE 0x0800 /* module must be declared later */
#define D_FORWTYPE 0x1000 /* forward type */
#define D_ERROR 0x4000 /* a compiler generated definition for an
undefined variable
*/
#define D_INUSE 0x8000 /* identification in this scope (like D_IMPORT)
*/
#define D_END (D_MODULE|D_PROCEDURE) /* special value for stab.c */
#define D_PEND (D_MODULE|D_PROCEDURE|D_VARIABLE) /* special value for stab.c */
#define D_VALUE (D_PROCEDURE|D_VARIABLE|D_FIELD|D_ENUM|D_CONST|D_PROCHEAD)
#define D_ISTYPE (D_HIDDEN|D_TYPE)
#define D_IMPORTED (D_IMPORT|D_INUSE)
#define is_type(dfx) ((dfx)->df_kind & D_ISTYPE)
unsigned short df_flags;
#define D_NOREG 0x01 /* set if it may not reside in a register */
#define D_USED 0x02 /* set if used */
#define D_DEFINED 0x04 /* set if it is assigned a value */
#define D_VARPAR 0x08 /* set if it is a VAR parameter */
#define D_VALPAR 0x10 /* set if it is a value parameter */
#define D_EXPORTED 0x20 /* set if exported */
#define D_QEXPORTED 0x40 /* set if qualified exported */
#define D_BUSY 0x80 /* set if busy reading this definition module */
#define D_FOREIGN 0x100 /* set for foreign language modules */
#define D_ADDRGIVEN 0x200 /* set if address given for variable */
#define D_FORLOOP 0x400 /* set if busy in for-loop */
#define D_IMP_BY_EXP 0x800 /* imported definition by export */
struct type *df_type;
union {
struct module df_module;
struct variable df_variable;
struct constant df_constant;
struct enumval df_enum;
struct field df_field;
struct import df_import;
struct dforward df_forward; /* also used for proc */
struct forwtype df_fortype;
int df_stdname; /* define for standard name */
} df_value;
};
typedef struct def t_def;
/* ALLOCDEF "def" 50 */
extern t_def
*define(),
*DefineLocalModule(),
*MkDef(),
*DeclProc(),
*lookup(),
*lookfor();
#define NULLDEF ((t_def *) 0)

393
lang/m2/comp/def.c
View File

@@ -1,393 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* D E F I N I T I O N M E C H A N I S M */
/* $Id$ */
#include "debug.h"
#include <alloc.h>
#include <em_arith.h>
#include <em_label.h>
#include <em_code.h>
#include <assert.h>
#include "LLlex.h"
#include "main.h"
#include "def.h"
#include "type.h"
#include "idf.h"
#include "scope.h"
#include "node.h"
#include "Lpars.h"
#include "warning.h"
extern char *sprint();
STATIC
internal(c)
register char *c;
{
if (options['x']) {
C_exp(c);
}
else C_inp(c);
}
STATIC
DefInFront(df)
register t_def *df;
{
/* Put definition "df" in front of the list of definitions
in its scope.
This is neccessary because in some cases the order in this
list is important.
*/
register t_def *df1 = df->df_scope->sc_def;
if (df1 != df) {
/* Definition "df" is not in front of the list
*/
while (df1) {
/* Find definition "df"
*/
if (df1->df_nextinscope == df) {
/* It already was in the list. Remove it
*/
df1->df_nextinscope = df->df_nextinscope;
break;
}
df1 = df1->df_nextinscope;
}
/* Now put it in front
*/
df->df_nextinscope = df->df_scope->sc_def;
df->df_scope->sc_def = df;
}
}
t_def *
MkDef(id, scope, kind)
register t_idf *id;
register t_scope *scope;
{
/* Create a new definition structure in scope "scope", with
id "id" and kind "kind".
*/
register t_def *df;
df = new_def();
df->df_idf = id;
df->df_scope = scope;
df->df_kind = kind;
df->df_next = id->id_def;
id->id_def = df;
if (kind == D_ERROR || kind == D_FORWARD) df->df_type = error_type;
if (kind & (D_TYPE|D_PROCEDURE|D_CONST)) {
df->df_flags = D_DEFINED;
}
/* enter the definition in the list of definitions in this scope
*/
df->df_nextinscope = scope->sc_def;
scope->sc_def = df;
return df;
}
t_def *
define(id, scope, kind)
register t_idf *id;
register t_scope *scope;
int kind;
{
/* Declare an identifier in a scope, but first check if it
already has been defined.
If so, then check for the cases in which this is legal,
and otherwise give an error message.
*/
register t_def *df;
DO_DEBUG(options['S'], print("define %s, %x\n", id->id_text, kind));
df = lookup(id, scope, D_IMPORT, 0);
if ( /* Already in this scope */
df
) {
switch(df->df_kind) {
case D_INUSE:
if (kind != D_INUSE && kind != D_ERROR) {
error("identifier \"%s\" already used; may not be redefined in this scope", df->df_idf->id_text);
df->df_kind = D_ERROR;
break;
}
return df;
case D_HIDDEN:
/* An opaque type. We may now have found the
definition of this type.
*/
if (kind == D_TYPE && df->df_scope == CurrentScope &&
!DefinitionModule) {
df->df_kind = D_TYPE;
return df;
}
break;
case D_FORWMODULE:
/* A forward reference to a module. We may have found
another one, or we may have found the definition
for this module.
*/
if (kind & (D_FORWMODULE|D_FORWARD)) {
return df;
}
if (kind == D_MODULE) {
FreeNode(df->for_node);
df->mod_vis = df->for_vis;
df->df_kind = kind;
DefInFront(df);
return df;
}
break;
case D_TYPE:
if (kind == D_FORWTYPE) return df;
break;
case D_FORWTYPE:
if (kind & (D_FORWTYPE|D_TYPE)) return df;
error("identifier \"%s\" must be a type", id->id_text);
df->df_kind = D_ERROR;
break;
case D_FORWARD:
/* A forward reference, for which we may now have
found a definition.
*/
if (! (kind & (D_FORWARD | D_FORWMODULE))) {
FreeNode(df->for_node);
}
df->df_kind = D_ERROR; /* avoiding error message */
break;
}
if (kind != D_ERROR && df->df_kind != D_ERROR) {
/* Avoid spurious error messages
*/
error("identifier \"%s\" already declared",
id->id_text);
}
if (df->df_scope == scope || df->df_kind == D_ERROR) {
df->df_kind = kind;
if (kind & (D_TYPE|D_PROCEDURE|D_CONST)) {
df->df_flags = D_DEFINED;
}
return df;
}
}
return MkDef(id, scope, kind);
}
end_definition_list(pdf)
register t_def **pdf;
{
/* Remove all imports from a definition module. This is
neccesary because the implementation module might import
them again.
Also, mark all other definitions "QUALIFIED EXPORT".
*/
register t_def *df;
while (df = *pdf) {
if (df->df_kind & D_IMPORTED) {
if (! (df->df_flags & D_USED)) {
warning(W_ORDINARY, "identifier \"%s\" imported but not used", df->df_idf->id_text);
}
RemoveFromIdList(df);
*pdf = df->df_nextinscope;
free_def(df);
}
else {
df->df_flags |= D_QEXPORTED;
pdf = &(df->df_nextinscope);
}
}
}
RemoveFromIdList(df)
register t_def *df;
{
/* Remove definition "df" from the definition list
*/
register t_idf *id = df->df_idf;
register t_def *df1;
if ((df1 = id->id_def) == df) id->id_def = df->df_next;
else {
while (df1->df_next != df) {
assert(df1->df_next != 0);
df1 = df1->df_next;
}
df1->df_next = df->df_next;
}
}
t_def *
DeclProc(type, id)
register t_idf *id;
{
/* A procedure is declared, either in a definition or a program
module. Create a def structure for it (if neccessary).
Also create a name for it.
*/
register t_def *df;
register t_scope *scope;
static int nmcount;
char buf[256];
assert(type & (D_PROCEDURE | D_PROCHEAD));
if (type == D_PROCHEAD) {
/* In a definition module
*/
df = define(id, CurrentScope, type);
df->for_node = dot2leaf(Name);
df->df_flags |= D_USED | D_DEFINED;
if (CurrentScope->sc_definedby->df_flags & D_FOREIGN) {
df->prc_name = id->id_text;
}
else {
sprint(buf,"%s_%s",CurrentScope->sc_name,id->id_text);
df->prc_name = Salloc(buf, (unsigned) (strlen(buf)+1));
}
if (CurrVis == Defined->mod_vis) {
/* The current module will define this routine.
make sure the name is exported.
*/
C_exp(df->prc_name);
}
}
else {
df = lookup(id, CurrentScope, D_IMPORTED, 0);
if (df && df->df_kind == D_PROCHEAD) {
/* C_exp already generated when we saw the definition
in the definition module
*/
DefInFront(df);
}
else {
df = define(id, CurrentScope, type);
sprint(buf,"_%d_%s",++nmcount,id->id_text);
df->prc_name = Salloc(buf, (unsigned)(strlen(buf)+1));
internal(buf);
df->df_flags |= D_DEFINED;
}
open_scope(OPENSCOPE);
scope = CurrentScope;
scope->sc_name = df->prc_name;
scope->sc_definedby = df;
}
df->prc_vis = CurrVis;
return df;
}
EndProc(df, id)
register t_def *df;
t_idf *id;
{
/* The end of a procedure declaration.
Check that the closing identifier matches the name of the
procedure, close the scope, and check that a function
procedure has at least one RETURN statement.
*/
extern int return_occurred;
match_id(id, df->df_idf);
close_scope(SC_CHKFORW|SC_REVERSE);
if (! return_occurred && ResultType(df->df_type)) {
error("function procedure %s does not return a value",
df->df_idf->id_text);
}
}
t_def *
DefineLocalModule(id)
t_idf *id;
{
/* Create a definition for a local module. Also give it
a name to be used for code generation.
*/
register t_def *df = define(id, CurrentScope, D_MODULE);
register t_scope *sc;
static int modulecount = 0;
char buf[256];
extern int proclevel;
sprint(buf, "_%d%s_", ++modulecount, id->id_text);
if (!df->mod_vis) {
/* We never saw the name of this module before. Create a
scope for it.
*/
open_scope(CLOSEDSCOPE);
df->mod_vis = CurrVis;
}
CurrVis = df->mod_vis;
sc = CurrentScope;
sc->sc_level = proclevel;
sc->sc_definedby = df;
sc->sc_name = Salloc(buf, (unsigned) (strlen(buf) + 1));
/* Create a type for it
*/
df->df_type = standard_type(T_RECORD, 1, (arith) 0);
df->df_type->rec_scope = sc;
/* Generate code that indicates that the initialization procedure
for this module is local.
*/
internal(buf);
return df;
}
CheckWithDef(df, tp)
register t_def *df;
t_type *tp;
{
/* Check the header of a procedure declaration against a
possible earlier definition in the definition module.
*/
if (df->df_kind == D_PROCHEAD &&
df->df_type &&
df->df_type != error_type) {
/* We already saw a definition of this type
in the definition module.
*/
if (!TstProcEquiv(tp, df->df_type)) {
error("inconsistent procedure declaration for \"%s\"",
df->df_idf->id_text);
}
FreeType(df->df_type);
df->df_kind = D_PROCEDURE;
}
df->df_type = tp;
}
#ifdef DEBUG
PrDef(df)
register t_def *df;
{
print("n: %s, k: %d\n", df->df_idf->id_text, df->df_kind);
}
#endif /* DEBUG */

22
lang/m2/comp/def_sizes.h
View File

@@ -1,22 +0,0 @@
/* D E F A U L T S I Z E S A N D A L I G N M E N T S */
/* $Header$ */
#define MAXSIZE 8 /* the maximum of the SZ_* constants */
/* target machine sizes */
#define SZ_CHAR (arith)1
#define SZ_WORD (arith)4
#define SZ_INT (arith)4
#define SZ_LONG (arith)4
#define SZ_FLOAT (arith)4
#define SZ_DOUBLE (arith)8
#define SZ_POINTER (arith)4
/* target machine alignment requirements */
#define AL_CHAR 1
#define AL_WORD (int) SZ_WORD
#define AL_INT (int) SZ_WORD
#define AL_LONG (int) SZ_WORD
#define AL_FLOAT (int) SZ_WORD
#define AL_DOUBLE (int) SZ_WORD
#define AL_POINTER (int) SZ_WORD
#define AL_STRUCT 1

166
lang/m2/comp/defmodule.c
View File

@@ -1,166 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* D E F I N I T I O N M O D U L E S */
/* $Id$ */
#include "debug.h"
#include <assert.h>
#include <em_arith.h>
#include <em_label.h>
#include <alloc.h>
#include "idf.h"
#include "input.h"
#include "scope.h"
#include "LLlex.h"
#include "def.h"
#include "Lpars.h"
#include "f_info.h"
#include "main.h"
#include "node.h"
#include "type.h"
#include "misc.h"
#ifdef DEBUG
long sys_filesize();
#endif
t_idf *DefId;
char *
getwdir(fn)
register char *fn;
{
register char *p;
char *strrindex();
while ((p = strrindex(fn,'/')) && *(p + 1) == '\0') {
/* remove trailing /'s */
*p = '\0';
}
if (p) {
*p = '\0';
fn = Salloc(fn, (unsigned) (p - &fn[0] + 1));
*p = '/';
return fn;
}
return "";
}
STATIC
GetFile(name)
char *name;
{
/* Try to find a file with basename "name" and extension ".def",
in the directories mentioned in "DEFPATH".
*/
char buf[15];
char *strncpy(), *strcat();
strncpy(buf, name, 10);
buf[10] = '\0'; /* maximum length */
strcat(buf, ".def");
DEFPATH[0] = WorkingDir;
if (! InsertFile(buf, DEFPATH, &(FileName))) {
error("could not find a DEFINITION MODULE for \"%s\"", name);
return 0;
}
WorkingDir = getwdir(FileName);
LineNumber = 1;
DO_DEBUG(options['F'], debug("File %s : %ld characters", FileName, sys_filesize(FileName)));
return 1;
}
t_def *
GetDefinitionModule(id, incr)
register t_idf *id;
{
/* Return a pointer to the "def" structure of the definition
module indicated by "id".
We may have to read the definition module itself.
Also increment level by "incr".
*/
register t_def *df;
static int level;
t_scopelist *vis;
char *fn = FileName;
int ln = LineNumber;
t_scope *newsc;
level += incr;
df = lookup(id, GlobalScope, D_IMPORTED, 0);
if (!df) {
/* Read definition module. Make an exception for SYSTEM.
*/
extern int ForeignFlag;
ForeignFlag = 0;
DefId = id;
open_scope(CLOSEDSCOPE);
newsc = CurrentScope;
vis = CurrVis;
newsc->sc_defmodule = incr;
if (!strcmp(id->id_text, "SYSTEM")) {
do_SYSTEM();
df = lookup(id, GlobalScope, D_IMPORTED, 0);
}
else {
if (!is_anon_idf(id) && GetFile(id->id_text)) {
char *f = FileName;
DefModule();
df = lookup(id, GlobalScope, D_IMPORTED, 0);
if (level == 1 &&
(df && !(df->df_flags & D_FOREIGN))) {
/* The module is directly imported by
the currently defined module, and
is not foreign, so we have to
remember its name because we have
to call its initialization routine
*/
static t_node *nd_end;
register t_node *n;
extern t_node *Modules;
n = dot2leaf(Def);
n->nd_def = newsc->sc_definedby;
if (nd_end) nd_end->nd_NEXT = n;
else Modules = n;
nd_end = n;
}
free(f);
}
else {
df = lookup(id, GlobalScope, D_IMPORTED, 0);
newsc->sc_name = id->id_text;
}
}
close_scope(SC_CHKFORW);
if (! df) {
df = MkDef(id, GlobalScope, D_ERROR);
df->mod_vis = vis;
newsc->sc_definedby = df;
}
}
else if (df->df_flags & D_BUSY) {
error("definition module \"%s\" depends on itself",
id->id_text);
}
else if (df == Defined && level == 1) {
error("cannot import from current module \"%s\"", id->id_text);
df->df_kind = D_ERROR;
}
FileName = fn;
LineNumber = ln;
assert(df);
level -= incr;
return df;
}

67
lang/m2/comp/desig.H
View File

@@ -1,67 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* D E S I G N A T O R D E S C R I P T I O N S */
/* $Id$ */
/* Generating code for designators is not particularly easy, especially if
you don't know wether you want the address or the value.
The next structure is used to generate code for designators.
It contains information on how to find the designator, after generation
of the code that is common to both address and value computations.
*/
struct desig {
short dsg_kind;
#define DSG_INIT 0 /* don't know anything yet */
#define DSG_LOADED 1 /* designator loaded on top of the stack */
#define DSG_PLOADED 2 /* designator accessible through pointer on
stack, possibly with an offset
*/
#define DSG_FIXED 3 /* designator directly accessible */
#define DSG_PFIXED 4 /* designator accessible through directly
accessible pointer
*/
#define DSG_INDEXED 5 /* designator accessible through array
operation. Address of array descriptor on
top of the stack, index beneath that, and
base address beneath that
*/
arith dsg_offset; /* contains an offset for PLOADED,
or for FIXED or PFIXED it contains an
offset from dsg_name, if it exists,
or from the current Local Base
*/
char *dsg_name; /* name of global variable, used for
FIXED and PFIXED
*/
struct def *dsg_def; /* def structure associated with this
designator, or 0
*/
};
typedef struct desig t_desig;
/* The next structure describes the designator in a with-statement.
We have a linked list of them, as with-statements may be nested.
*/
struct withdesig {
struct withdesig *w_next;
int w_flags; /* D_USED|D_DEFINED */
struct scope *w_scope; /* scope in which fields of this record
reside
*/
t_desig w_desig; /* a desig structure for this particular
designator
*/
};
extern struct withdesig *WithDesigs;
#define NO_LABEL ((label) 0)

705
lang/m2/comp/desig.c
View File

@@ -1,705 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* D E S I G N A T O R E V A L U A T I O N */
/* $Id$ */
/* Code generation for designators.
This file contains some routines that generate code common to address
as well as value computations, and leave a description in a "desig"
structure. It also contains routines to load an address, load a value
or perform a store.
*/
#include "debug.h"
#include <em_arith.h>
#include <em_label.h>
#include <em_code.h>
#include <assert.h>
#include <alloc.h>
#include "type.h"
#include "LLlex.h"
#include "def.h"
#include "scope.h"
#include "desig.h"
#include "node.h"
#include "warning.h"
#include "walk.h"
#include "squeeze.h"
extern int proclevel;
extern arith NewPtr();
extern char options[];
int
WordOrDouble(ds, size)
t_desig *ds;
arith size;
{
/* Check if designator is suitable for word or double-word
operation
*/
if ((int) (ds->dsg_offset) % word_align == 0) {
if (size == word_size) return 1;
if (size == dword_size) return 2;
}
return 0;
}
LOL(offset, size)
arith offset, size;
{
if (size == word_size) {
C_lol(offset);
}
else if (size == dword_size) {
C_ldl(offset);
}
else {
C_lal(offset);
C_loi(size);
}
}
STL(offset, size)
arith offset, size;
{
if (size == word_size) {
C_stl(offset);
}
else if (size == dword_size) {
C_sdl(offset);
}
else {
C_lal(offset);
C_sti(size);
}
}
int
DoLoad(ds, size)
register t_desig *ds;
arith size;
{
/* Try to load designator with word or double-word operation.
Return 0 if not done
*/
switch (WordOrDouble(ds, size)) {
default:
return 0;
case 1:
if (ds->dsg_name) {
C_loe_dnam(ds->dsg_name, ds->dsg_offset);
}
else C_lol(ds->dsg_offset);
break;
case 2:
if (ds->dsg_name) {
C_lde_dnam(ds->dsg_name, ds->dsg_offset);
}
else C_ldl(ds->dsg_offset);
break;
}
return 1;
}
int
DoStore(ds, size)
register t_desig *ds;
arith size;
{
/* Try to store designator with word or double-word operation.
Return 0 if not done
*/
switch (WordOrDouble(ds, size)) {
default:
return 0;
case 1:
if (ds->dsg_name) {
C_ste_dnam(ds->dsg_name, ds->dsg_offset);
}
else C_stl(ds->dsg_offset);
break;
case 2:
if (ds->dsg_name) {
C_sde_dnam(ds->dsg_name, ds->dsg_offset);
}
else C_sdl(ds->dsg_offset);
break;
}
return 1;
}
/* Return 1 if the type indicated by tp has a size that is a
multiple of the word_size and is also word_aligned
*/
#define word_multiple(tp) \
( (int)(tp->tp_size) % (int)word_size == 0 && \
tp->tp_align >= word_align)
/* Return 1 if the type indicated by tp has a size that is a proper
dividor of the word_size, and has alignment >= size or
alignment >= word_align
*/
#define word_dividor(tp) \
( tp->tp_size < word_size && \
(int)word_size % (int)(tp->tp_size) == 0 && \
(tp->tp_align >= word_align || \
tp->tp_align >= (int)(tp->tp_size)))
#define USE_LOI_STI 0
#define USE_LOS_STS 1
#define USE_LOAD_STORE 2
#define USE_BLM 3 /* like USE_LOI_STI, but more restricted:
multiple of word_size only
*/
STATIC int
suitable_move(tp)
register t_type *tp;
{
/* Find out how to load or store the value indicated by "ds".
There are four ways:
- suitable for BLM/LOI/STI
- suitable for LOI/STI
- suitable for LOS/STS/BLS
- suitable for calls to load/store/blockmove
*/
if (! word_multiple(tp)) {
if (word_dividor(tp)) return USE_LOI_STI;
return USE_LOAD_STORE;
}
if (! fit(tp->tp_size, (int) word_size)) return USE_LOS_STS;
return USE_BLM;
}
CodeValue(ds, tp)
register t_desig *ds;
register t_type *tp;
{
/* Generate code to load the value of the designator described
in "ds".
*/
arith sz;
switch(ds->dsg_kind) {
case DSG_LOADED:
break;
case DSG_FIXED:
if (DoLoad(ds, tp->tp_size)) break;
/* Fall through */
case DSG_PLOADED:
case DSG_PFIXED:
switch (suitable_move(tp)) {
case USE_BLM:
case USE_LOI_STI:
#ifndef SQUEEZE
CodeAddress(ds);
C_loi(tp->tp_size);
break;
#endif
case USE_LOS_STS:
CodeAddress(ds);
CodeConst(tp->tp_size, (int)pointer_size);
C_los(pointer_size);
break;
case USE_LOAD_STORE:
sz = WA(tp->tp_size);
if (ds->dsg_kind != DSG_PFIXED) {
arith tmp = NewPtr();
CodeAddress(ds);
STL(tmp, pointer_size);
CodeConst(-sz, (int) pointer_size);
C_ass(pointer_size);
LOL(tmp, pointer_size);
FreePtr(tmp);
}
else {
CodeConst(-sz, (int) pointer_size);
C_ass(pointer_size);
CodeAddress(ds);
}
CodeConst(tp->tp_size, (int) pointer_size);
CAL("load", (int)pointer_size + (int)pointer_size);
break;
}
break;
case DSG_INDEXED:
C_lar(word_size);
break;
default:
crash("(CodeValue)");
}
ds->dsg_kind = DSG_LOADED;
}
ChkForFOR(nd)
register t_node *nd;
{
/* Check for an assignment to a FOR-loop control variable
*/
if (nd->nd_class == Def) {
register t_def *df = nd->nd_def;
if (df->df_flags & D_FORLOOP) {
node_warning(nd,
W_ORDINARY,
"assignment to FOR-loop control variable");
df->df_flags &= ~D_FORLOOP;
/* only procude warning once */
}
}
}
CodeStore(ds, tp)
register t_desig *ds;
register t_type *tp;
{
/* Generate code to store the value on the stack in the designator
described in "ds"
*/
switch(ds->dsg_kind) {
case DSG_FIXED:
if (DoStore(ds, tp->tp_size)) break;
/* Fall through */
case DSG_PLOADED:
case DSG_PFIXED:
CodeAddress(ds);
switch (suitable_move(tp)) {
case USE_BLM:
case USE_LOI_STI:
#ifndef SQUEEZE
C_sti(tp->tp_size);
break;
#endif
case USE_LOS_STS:
CodeConst(tp->tp_size, (int) pointer_size);
C_sts(pointer_size);
break;
case USE_LOAD_STORE:
CodeConst(tp->tp_size, (int) pointer_size);
C_cal("store");
CodeConst(pointer_size + pointer_size + WA(tp->tp_size),
(int) pointer_size);
C_ass(pointer_size);
break;
}
break;
case DSG_INDEXED:
C_sar(word_size);
break;
default:
crash("(CodeStore)");
}
ds->dsg_kind = DSG_INIT;
}
CodeCopy(lhs, rhs, sz, psize)
register t_desig *lhs, *rhs;
arith sz, *psize;
{
/* Do part of a copy, which is assumed to be "reasonable",
so that it can be done with LOI/STI or BLM.
*/
t_desig l, r;
l = *lhs; r = *rhs;
*psize -= sz;
lhs->dsg_offset += sz;
rhs->dsg_offset += sz;
CodeAddress(&r);
if (sz <= dword_size) {
C_loi(sz);
CodeAddress(&l);
C_sti(sz);
}
else {
CodeAddress(&l);
C_blm(sz);
}
}
t_desig null_desig;
CodeMove(rhs, left, rtp)
register t_desig *rhs;
register t_node *left;
t_type *rtp;
{
/* Generate code for an assignment. Testing of type
compatibility and the like is already done.
Go through some (considerable) trouble to see if a BLM can be
generated.
*/
t_desig lhs;
register t_type *tp = left->nd_type;
int loadedflag = 0;
lhs = null_desig;
ChkForFOR(left);
switch(rhs->dsg_kind) {
case DSG_LOADED:
CodeDesig(left, &lhs);
if (rtp->tp_fund == T_STRING) {
/* size of a string literal fits in an
int of size word_size
*/
CodeAddress(&lhs);
C_loc(rtp->tp_size);
C_loc(tp->tp_size);
CAL("StringAssign", (int)pointer_size + (int)pointer_size + (int)dword_size);
break;
}
CodeStore(&lhs, tp);
break;
case DSG_FIXED:
CodeDesig(left, &lhs);
if (lhs.dsg_kind == DSG_FIXED &&
fit(tp->tp_size, (int) word_size) &&
(int) (lhs.dsg_offset) % word_align ==
(int) (rhs->dsg_offset) % word_align) {
register int sz = 1;
arith size = tp->tp_size;
while (size && sz < word_align) {
/* First copy up to word-aligned
boundaries
*/
if (!((int)(lhs.dsg_offset)%(sz+sz))) {
sz += sz;
}
else CodeCopy(&lhs, rhs, (arith) sz, &size);
}
/* Now copy the bulk
*/
sz = (int) size % (int) word_size;
size -= sz;
CodeCopy(&lhs, rhs, size, &size);
size = sz;
sz = word_size;
while (size) {
/* And then copy remaining parts
*/
sz >>= 1;
if (size >= sz) {
CodeCopy(&lhs, rhs, (arith) sz, &size);
}
}
break;
}
CodeAddress(&lhs);
loadedflag = 1;
/* Fall through */
case DSG_PLOADED:
case DSG_PFIXED:
assert(! loadedflag || rhs->dsg_kind == DSG_FIXED);
CodeAddress(rhs);
if (loadedflag) {
C_exg(pointer_size);
}
else {
CodeDesig(left, &lhs);
CodeAddress(&lhs);
}
switch (suitable_move(tp)) {
case USE_BLM:
#ifndef SQUEEZE
C_blm(tp->tp_size);
break;
#endif
case USE_LOS_STS:
CodeConst(tp->tp_size, (int) pointer_size);
C_bls(pointer_size);
break;
case USE_LOAD_STORE:
case USE_LOI_STI:
CodeConst(tp->tp_size, (int) pointer_size);
CAL("blockmove", 3 * (int)pointer_size);
break;
}
break;
default:
crash("CodeMove");
}
}
CodeAddress(ds)
register t_desig *ds;
{
/* Generate code to load the address of the designator described
in "ds"
*/
switch(ds->dsg_kind) {
case DSG_PLOADED:
if (ds->dsg_offset) {
C_adp(ds->dsg_offset);
}
break;
case DSG_FIXED:
if (ds->dsg_name) {
C_lae_dnam(ds->dsg_name, ds->dsg_offset);
break;
}
C_lal(ds->dsg_offset);
if (ds->dsg_def) ds->dsg_def->df_flags |= D_NOREG;
break;
case DSG_PFIXED:
if (! DoLoad(ds, pointer_size)) {
assert(0);
}
break;
case DSG_INDEXED:
C_aar(word_size);
break;
default:
crash("(CodeAddress)");
}
ds->dsg_offset = 0;
ds->dsg_kind = DSG_PLOADED;
}
CodeFieldDesig(df, ds)
register t_def *df;
register t_desig *ds;
{
/* Generate code for a field designator. Only the code common for
address as well as value computation is generated, and the
resulting information on where to find the designator is placed
in "ds". "df" indicates the definition of the field.
*/
if (ds->dsg_kind == DSG_INIT) {
/* In a WITH statement. We must find the designator in the
WITH statement, and act as if the field is a selection
of this designator.
So, first find the right WITH statement, which is the
first one of the proper record type, which is
recognized by its scope indication.
*/
register struct withdesig *wds = WithDesigs;
assert(wds != 0);
while (wds->w_scope != df->df_scope) {
wds = wds->w_next;
assert(wds != 0);
}
/* Found it. Now, act like it was a selection.
*/
*ds = wds->w_desig;
wds->w_flags |= df->df_flags;
assert(ds->dsg_kind == DSG_PFIXED);
}
switch(ds->dsg_kind) {
case DSG_PLOADED:
case DSG_FIXED:
ds->dsg_offset += df->fld_off;
break;
case DSG_PFIXED:
case DSG_INDEXED:
CodeAddress(ds);
ds->dsg_kind = DSG_PLOADED;
ds->dsg_offset = df->fld_off;
break;
default:
crash("(CodeFieldDesig)");
}
}
CodeVarDesig(df, ds)
register t_def *df;
register t_desig *ds;
{
/* Generate code for a variable represented by a "def" structure.
Of course, there are numerous cases: the variable is local,
it is a value parameter, it is a var parameter, it is one of
those of an enclosing procedure, or it is global.
*/
register t_scope *sc = df->df_scope;
int difflevel;
/* Selections from a module are handled earlier, when identifying
the variable, so ...
*/
assert(ds->dsg_kind == DSG_INIT);
if (df->df_flags & D_ADDRGIVEN) {
/* the programmer specified an address in the declaration of
the variable. Generate code to push the address.
*/
CodeConst(df->var_off, (int) pointer_size);
ds->dsg_kind = DSG_PLOADED;
ds->dsg_offset = 0;
return;
}
if (df->var_name) {
/* this variable has been given a name, so it is global.
It is directly accessible.
*/
ds->dsg_name = df->var_name;
ds->dsg_offset = 0;
ds->dsg_kind = DSG_FIXED;
return;
}
if ((difflevel = proclevel - sc->sc_level) != 0) {
/* the variable is local to a statically enclosing procedure.
*/
assert(difflevel > 0);
df->df_flags |= D_NOREG;
if (df->df_flags & (D_VARPAR|D_VALPAR)) {
/* value or var parameter
*/
C_lxa((arith) difflevel);
if ((df->df_flags & D_VARPAR) ||
IsConformantArray(df->df_type)) {
/* var parameter or conformant array.
The address is passed.
*/
C_adp(df->var_off);
C_loi(pointer_size);
ds->dsg_offset = 0;
ds->dsg_kind = DSG_PLOADED;
return;
}
}
else C_lxl((arith) difflevel);
ds->dsg_kind = DSG_PLOADED;
ds->dsg_offset = df->var_off;
return;
}
/* Now, finally, we have a local variable or a local parameter
*/
if ((df->df_flags & D_VARPAR) ||
IsConformantArray(df->df_type)) {
/* a var parameter; address directly accessible.
*/
ds->dsg_kind = DSG_PFIXED;
}
else ds->dsg_kind = DSG_FIXED;
ds->dsg_offset = df->var_off;
ds->dsg_def = df;
}
CodeDesig(nd, ds)
register t_node *nd;
register t_desig *ds;
{
/* Generate code for a designator. Use divide and conquer
principle
*/
register t_def *df;
switch(nd->nd_class) { /* Divide */
case Def:
df = nd->nd_def;
if (nd->nd_NEXT) CodeDesig(nd->nd_NEXT, ds);
switch(df->df_kind) {
case D_FIELD:
CodeFieldDesig(df, ds);
break;
case D_VARIABLE:
CodeVarDesig(df, ds);
break;
default:
crash("(CodeDesig) Def");
}
break;
case Arrsel:
assert(nd->nd_symb == '[' || nd->nd_symb == ',');
CodeDesig(nd->nd_LEFT, ds);
CodeAddress(ds);
CodePExpr(nd->nd_RIGHT);
nd = nd->nd_LEFT;
/* Now load address of descriptor
*/
if (IsConformantArray(nd->nd_type)) {
arith off;
assert(nd->nd_class == Def);
df = nd->nd_def;
off = df->var_off + pointer_size;
if (proclevel > df->df_scope->sc_level) {
C_lxa((arith) (proclevel - df->df_scope->sc_level));
C_adp(off);
}
else C_lal(off);
}
else {
C_loc(nd->nd_type->arr_low);
C_sbu(int_size);
c_lae_dlb(nd->nd_type->arr_descr);
}
if (options['A']) {
C_cal("rcka");
}
ds->dsg_kind = DSG_INDEXED;
break;
case Arrow:
assert(nd->nd_symb == '^');
nd = nd->nd_RIGHT;
CodeDesig(nd, ds);
switch(ds->dsg_kind) {
case DSG_LOADED:
ds->dsg_kind = DSG_PLOADED;
break;
case DSG_INDEXED:
case DSG_PLOADED:
case DSG_PFIXED:
CodeValue(ds, nd->nd_type);
ds->dsg_kind = DSG_PLOADED;
ds->dsg_offset = 0;
break;
case DSG_FIXED:
ds->dsg_kind = DSG_PFIXED;
break;
default:
crash("(CodeDesig) Uoper");
}
break;
default:
crash("(CodeDesig) class");
}
}

93
lang/m2/comp/em_m2.6
View File

@@ -1,93 +0,0 @@
.TH EM_M2 6 "$Revision$"
.ad
.SH NAME
em_m2 \- ACK Modula\-2 compiler
.SH SYNOPSIS
.B ~em/lib.bin/em_m2
.RI [ option ]
.I source
.I destination
.SH DESCRIPTION
.I Em_m2
is a
compiler, part of the Amsterdam Compiler Kit, that translates Modula-2 programs
into EM code.
The input is taken from
.IR source ,
while the
EM code is written on
.IR destination .
.br
.I Option
is a, possibly empty, sequence of the following combinations:
.IP \fB\-I\fIdirname\fR
.br
append \fIdirname\fR to the list of directories where definition modules
are looked for.
.PP
When the compiler needs a definition module, it is first searched for
in the current directory, and then in the directories given to it by the
\-\fBI\fR flag
in the order given.
.IP \fB\-M\fP\fIn\fP
set maximum identifier length to \fIn\fP.
The minimum value for \fIn\fR is 14, because the keyword
"IMPLEMENTATION" is that long.
.IP \fB\-n\fR
do not generate EM register messages.
The user-declared variables will not be stored into registers on the target
machine.
.IP \fB\-L\fR
do not generate the EM \fBfil\fR and \fBlin\fR instructions that enable
an interpreter to keep track of the current location in the source code.
.IP \fB\-V\fIcm\fR.\fIn\fR,\ \fB\-V\fIcm\fR.\fIncm\fR.\fIn\fR\ ...
.br
set the size and alignment requirements.
The letter \fIc\fR indicates the simple type, which is one of
\fBw\fR(word size), \fBi\fR(INTEGER), \fBl\fR(LONGINT), \fBf\fR(REAL),
\fBd\fR(LONGREAL), or \fBp\fR(POINTER).
It may also be the letter \fBS\fR, indicating that an initial
record alignment follows.
The \fIm\fR parameter can be used to specify the length of the type (in bytes)
and the \fIn\fR parameter for the alignment of that type.
Absence of \fIm\fR or \fIn\fR causes a default value to be retained.
.IP \fB\-w\fR\fIclasses\fR
suppress warning messages whose class is a member of \fIclasses\fR.
Currently, there are three classes: \fBO\fR, indicating old-flashioned use,
\fBW\fR, indicating "ordinary" warnings, and \fBR\fR, indicating
restricted Modula-2.
If no \fIclasses\fR are given, all warnings are suppressed.
By default, warnings in class \fBO\fR and \fBW\fR are given.
.IP \fB\-W\fR\fIclasses\fR
allow for warning messages whose class is a member of \fIclasses\fR.
.IP \fB\-x\fR
make all procedure names global, so that \fIadb\fR(1) understands them.
.IP \fB\-g\fR
produce a DBX-style symbol table.
.IP \fB\-l\fR
enable local extensions. Currently, there are two local extensions:
procedure constants, and the type LONGCARD.
.IP \fB\-s\fR
make INTEGER ranges symmetric, t.i., MIN(INTEGER) = - MAX(INTEGER).
This is useful for interpreters that use the "real" MIN(INTEGER) to
indicate "undefined".
.IP \fB-R\fR
disable all range checks.
.IP \fB-A\fR
enable extra array bound checks, for machines that do not implement the
EM ones.
.IP \fB-U\fR
allow for underscores within identifiers. Identifiers may not start with
an underscore, even if this flag is given.
.IP \fB-3\fR
only accept Modula-2 programs that strictly conform to [1].
.LP
.SH SEE ALSO
\fIack\fR(1), \fImodula-2\fR(1)
.IP [1]
N. Wirth, \fIProgramming in Modula-2\fP, 3rd edition, Springer Verlag.
.SH DIAGNOSTICS
All warning and error messages are written on standard error output.
.SH REMARKS
Debugging and profiling facilities may be present during the development
of \fIem_m2\fP.

561
lang/m2/comp/enter.c
View File

@@ -1,561 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* H I G H L E V E L S Y M B O L E N T R Y */
/* $Id$ */
#include "debug.h"
#include <alloc.h>
#include <em_arith.h>
#include <em_label.h>
#include <em_code.h>
#include <assert.h>
#include "dbsymtab.h"
#include "idf.h"
#include "LLlex.h"
#include "def.h"
#include "type.h"
#include "scope.h"
#include "node.h"
#include "main.h"
#include "misc.h"
#include "f_info.h"
t_def *
Enter(name, kind, type, pnam)
char *name;
t_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.
*/
register t_def *df;
df = define(str2idf(name, 0), CurrentScope, kind);
df->df_type = type;
if (pnam) df->df_value.df_stdname = pnam;
#ifdef DBSYMTAB
else if (options['g']) stb_string(df, kind);
#endif /* DBSYMTAB */
return df;
}
t_def *
EnterType(name, type)
char *name;
t_type *type;
{
/* Enter a type definition for "name" and type
"type" in the Current Scope.
*/
return Enter(name, D_TYPE, type, 0);
}
EnterEnumList(Idlist, type)
t_node *Idlist;
register t_type *type;
{
/* Put a list of enumeration literals in the symbol table.
They all have type "type".
Also assign numbers to them, and link them together.
We must link them together because an enumeration type may
be exported, in which case its literals must also be exported.
Thus, we need an easy way to get to them.
*/
register t_def *df, *df1 = 0;
register t_node *idlist = Idlist;
type->enm_ncst = 0;
for (; idlist; idlist = idlist->nd_NEXT) {
df = define(idlist->nd_IDF, CurrentScope, D_ENUM);
df->df_type = type;
df->enm_val = (type->enm_ncst)++;
if (! df1) {
type->enm_enums = df;
}
else df1->enm_next = df;
df1 = df;
}
FreeNode(Idlist);
}
EnterFieldList(Idlist, type, scope, addr)
t_node *Idlist;
register t_type *type;
t_scope *scope;
arith *addr;
{
/* Put a list of fields in the symbol table.
They all have type "type", and are put in scope "scope".
Mark them as QUALIFIED EXPORT, because that's exactly what
fields are, you can get to them by qualifying them.
*/
register t_def *df;
register t_node *idlist = Idlist;
for (; idlist; idlist = idlist->nd_NEXT) {
df = define(idlist->nd_IDF, scope, D_FIELD);
df->df_type = type;
df->df_flags |= D_QEXPORTED;
df->fld_off = align(*addr, type->tp_align);
*addr = df->fld_off + type->tp_size;
}
FreeNode(Idlist);
}
EnterVarList(Idlist, type, local)
t_node *Idlist;
t_type *type;
{
/* Enter a list of identifiers representing variables into the
name list. "type" represents the type of the variables.
"local" is set if the variables are declared local to a
procedure.
*/
register t_def *df;
register t_node *idlist = Idlist;
register t_scopelist *sc = CurrVis;
char buf[256];
extern char *sprint();
if (local) {
/* Find the closest enclosing open scope. This
is the procedure that we are dealing with
*/
while (sc->sc_scope->sc_scopeclosed) sc = enclosing(sc);
}
for (; idlist; idlist = idlist->nd_RIGHT) {
df = define(idlist->nd_LEFT->nd_IDF, CurrentScope, D_VARIABLE);
df->df_type = type;
if (idlist->nd_LEFT->nd_NEXT) {
/* An address was supplied
*/
register t_type *tp = idlist->nd_LEFT->nd_NEXT->nd_type;
df->df_flags |= D_ADDRGIVEN | D_NOREG;
if (tp != error_type && !(tp->tp_fund & T_CARDINAL)){
node_error(idlist->nd_LEFT->nd_NEXT,
"illegal type for address");
}
df->var_off = idlist->nd_LEFT->nd_NEXT->nd_INT;
}
else if (local) {
/* subtract aligned size of variable to the offset,
as the variable list exists only local to a
procedure
*/
sc->sc_scope->sc_off =
-WA(align(type->tp_size - sc->sc_scope->sc_off,
type->tp_align));
df->var_off = sc->sc_scope->sc_off;
}
else {
/* Global name, possibly external
*/
if (sc->sc_scope->sc_definedby->df_flags & D_FOREIGN) {
df->var_name = df->df_idf->id_text;
}
else {
sprint(buf,"%s_%s", sc->sc_scope->sc_name,
df->df_idf->id_text);
df->var_name = Salloc(buf,
(unsigned)(strlen(buf)+1));
}
df->df_flags |= D_NOREG;
if (DefinitionModule) {
df->df_flags |= D_USED | D_DEFINED;
if (sc == Defined->mod_vis) {
C_exa_dnam(df->var_name);
}
}
else {
C_ina_dnam(df->var_name);
}
}
}
FreeNode(Idlist);
}
EnterParamList(ppr, Idlist, type, VARp, off)
t_param **ppr;
t_node *Idlist;
t_type *type;
int VARp;
arith *off;
{
/* Create (part of) a parameterlist of a procedure.
"ids" indicates the list of identifiers, "tp" their type, and
"VARp" indicates D_VARPAR or D_VALPAR.
*/
register t_param *pr;
register t_def *df;
register t_node *idlist = Idlist;
t_node *dummy = 0;
static t_param *last;
if (! idlist) {
/* Can only happen when a procedure type is defined */
dummy = Idlist = idlist = dot2leaf(Name);
}
for ( ; idlist; idlist = idlist->nd_NEXT) {
pr = new_paramlist();
pr->par_next = 0;
if (!*ppr) *ppr = pr;
else last->par_next = pr;
last = pr;
if (!DefinitionModule && idlist != dummy) {
df = define(idlist->nd_IDF, CurrentScope, D_VARIABLE);
df->var_off = *off;
}
else df = new_def();
pr->par_def = df;
df->df_type = type;
df->df_flags |= VARp;
if (IsConformantArray(type)) {
/* we need room for the base address and a descriptor:
arr_low and arr_high are set to their offset
*/
type->arr_low = *off + pointer_size;
type->arr_high = *off + pointer_size + word_size;
*off += pointer_size + word_size + dword_size;
}
else if (VARp == D_VARPAR) {
*off += pointer_size;
}
else {
*off += WA(type->tp_size);
}
}
FreeNode(Idlist);
}
STATIC t_def *DoImport();
ImportEffects(idef, scope, flag)
register t_def *idef;
t_scope *scope;
{
/* Handle side effects of an import:
- a module could have unqualified exports ???
- importing an enumeration type also imports literals
*/
register t_def *df = idef;
register t_type *tp;
while ((df->df_kind & D_IMPORTED) && df->imp_def != df) {
/* The second condition could occur on some (erroneous and
obscure) input such as:
IMPLEMENTATION MODULE Test;
FROM X IMPORT XType, XType;
END Test.
when X does not exist.
*/
df = df->imp_def;
}
tp = BaseType(df->df_type);
if (df->df_kind == D_TYPE && tp->tp_fund == T_ENUMERATION) {
/* Also import all enumeration literals
*/
for (df = tp->enm_enums; df; df = df->enm_next) {
/* But be careful; we could have a situation where f.i.
different subrange types of the enumeration type
are imported. If the literal is already imported
in some way, don't do it again; we don't want
a multiple defined error message here.
*/
t_def *df1;
df->df_flags |= D_QEXPORTED;
if ((!(df1 = lookup(df->df_idf, scope, D_IMPORT, 0)) ||
df1 != df) &&
! DoImport(df, scope, flag|D_USED)) assert(0);
/* don't complain when not used ... */
}
idef->df_flags |= D_USED; /* don't complain ... */
}
else if (df->df_kind == D_MODULE) {
if (df->mod_vis == CurrVis) {
error("cannot import current module \"%s\"",
df->df_idf->id_text);
return;
}
if (df->df_scope == GlobalScope) return;
/* Also import all definitions that are exported from this
module
*/
for (df = df->mod_vis->sc_scope->sc_def;
df;
df = df->df_nextinscope) {
if (df->df_flags & D_EXPORTED) {
if (!DoImport(df, scope, D_IMP_BY_EXP|D_USED)){
assert(0);
}
/* don't complain when these are not used */
}
}
idef->df_flags |= D_USED; /* don't complain ... */
}
}
STATIC t_def *
DoImport(df, scope, flag)
register t_def *df;
t_scope *scope;
{
/* Definition "df" is imported to scope "scope".
*/
register t_def *idef = define(df->df_idf, scope, D_IMPORT);
idef->imp_def = df;
idef->df_flags |= flag;
ImportEffects(idef, scope, flag);
return idef;
}
STATIC
ForwModule(df, nd)
register t_def *df;
t_node *nd;
{
/* An import is done from a not yet defined module "df".
We could also end up here for not found DEFINITION MODULES.
Create a declaration and a scope for this module.
*/
register t_scopelist *vis;
if (df->df_scope != GlobalScope) {
df->df_scope = enclosing(CurrVis)->sc_scope;
df->df_kind = D_FORWMODULE;
}
open_scope(CLOSEDSCOPE);
vis = CurrVis; /* The new scope, but watch out, it's "sc_encl"
field is not set right. It must indicate the
enclosing scope, but this must be done AFTER
closing this one
*/
close_scope(0);
vis->sc_encl = enclosing(CurrVis);
/* Here ! */
df->for_vis = vis;
df->for_node = nd;
}
STATIC t_def *
ForwDef(ids, scope)
register t_node *ids;
t_scope *scope;
{
/* Enter a forward definition of "ids" in scope "scope",
if it is not already defined.
*/
register t_def *df;
if (!(df = lookup(ids->nd_IDF, scope, 0, 0))) {
df = define(ids->nd_IDF, scope, D_FORWARD);
df->for_node = new_node();
*(df->for_node) = *ids;
df->for_node->nd_NEXT = 0;
}
return df;
}
EnterExportList(Idlist, qualified)
t_node *Idlist;
{
/* From the current scope, the list of identifiers "ids" is
exported. Note this fact. If the export is not qualified, make
all the "ids" visible in the enclosing scope by defining them
in this scope as "imported".
*/
register t_node *idlist = Idlist;
register t_def *df, *df1;
for (;idlist; idlist = idlist->nd_NEXT) {
df = lookup(idlist->nd_IDF, CurrentScope, 0, 0);
if (!df) {
/* undefined item in export list
*/
node_error(idlist,
"identifier \"%s\" not defined",
idlist->nd_IDF->id_text);
continue;
}
if (df->df_flags & (D_EXPORTED|D_QEXPORTED)) {
node_error(idlist,
"multiple occurrences of \"%s\" in export list",
idlist->nd_IDF->id_text);
continue;
}
df->df_flags |= qualified;
if (qualified == D_EXPORTED) {
/* Export, but not qualified.
Find all imports of the module in which this export
occurs, and export the current definition to it
*/
df1 = CurrentScope->sc_definedby->df_idf->id_def;
while (df1) {
if ((df1->df_kind & D_IMPORTED) &&
df1->imp_def == CurrentScope->sc_definedby) {
if (! DoImport(df, df1->df_scope, D_IMP_BY_EXP)) assert(0);
}
df1 = df1->df_next;
}
/* Also handle the definition as if the enclosing
scope imports it.
*/
df1 = lookup(idlist->nd_IDF,
enclosing(CurrVis)->sc_scope,
D_IMPORTED,
0);
if (df1) {
/* It was already defined in the enclosing
scope. There are two legal possibilities,
which are examined below.
*/
t_def *df2 = df;
while (df2->df_kind & D_IMPORTED) {
df2 = df2->imp_def;
}
if (df1->df_kind == D_PROCHEAD &&
df2->df_kind == D_PROCEDURE) {
df1->df_kind = D_IMPORT;
df1->df_flags |= D_IMP_BY_EXP;
df1->imp_def = df;
continue;
}
if (df1->df_kind == D_HIDDEN &&
df2->df_kind == D_TYPE) {
DeclareType(idlist, df1, df2->df_type);
df1->df_kind = D_TYPE;
continue;
}
}
if (! DoImport(df,enclosing(CurrVis)->sc_scope,D_IMP_BY_EXP)) assert(0);
}
}
FreeNode(Idlist);
}
CheckForImports(df)
t_def *df;
{
/* We have a definition for "df"; check all imports of
it for side-effects
*/
register t_def *df1 = df->df_idf->id_def;
while (df1) {
if (df1->df_kind & D_IMPORTED) {
register t_def *df2 = df1->imp_def;
while (df2->df_kind & D_IMPORTED) df2 = df2->imp_def;
if (df2 == df) {
ImportEffects(df1, df1->df_scope, 0);
}
}
df1 = df1->df_next;
}
}
EnterFromImportList(idlist, FromDef, FromId)
register t_node *idlist;
register t_def *FromDef;
t_node *FromId;
{
/* Import the list Idlist from the module indicated by Fromdef.
*/
t_scope *sc;
register t_def *df;
char *module_name = FromDef->df_idf->id_text;
switch(FromDef->df_kind) {
case D_ERROR:
case D_FORWARD:
/* The module from which the import was done
is not yet declared. I'm not sure if I must
accept this, but for the time being I will.
We also end up here if some definition module could not
be found.
???
*/
ForwModule(FromDef, FromId);
/* Fall through */
case D_FORWMODULE:
EnterImportList(idlist, 1, FromDef->for_vis->sc_scope);
return;
case D_MODULE:
sc = FromDef->mod_vis->sc_scope;
if (sc == CurrentScope) {
node_error(FromId, "cannot import from current module \"%s\"", module_name);
return;
}
break;
default:
node_error(FromId,"identifier \"%s\" does not represent a module",module_name);
return;
}
for (; idlist; idlist = idlist->nd_NEXT) {
if (! (df = lookup(idlist->nd_IDF, sc, 0, 0))) {
if (! is_anon_idf(idlist->nd_IDF)) {
node_error(idlist,
"identifier \"%s\" not declared in module \"%s\"",
idlist->nd_IDF->id_text,
module_name);
}
df = define(idlist->nd_IDF,sc,D_ERROR);
}
else if (! (df->df_flags & (D_EXPORTED|D_QEXPORTED))) {
node_error(idlist,
"identifier \"%s\" not exported from module \"%s\"",
idlist->nd_IDF->id_text,
module_name);
df->df_flags |= D_QEXPORTED;
}
if (! DoImport(df, CurrentScope, 0)) assert(0);
}
FreeNode(FromId);
}
EnterImportList(idlist, local, sc)
register t_node *idlist;
t_scope *sc;
{
/* Import "idlist" from scope "sc".
If the import is not local, definition modules must be read
for "idlist".
*/
extern t_def *GetDefinitionModule();
struct f_info f;
f = file_info;
for (; idlist; idlist = idlist->nd_NEXT) {
if (! DoImport(local ?
ForwDef(idlist, sc) :
GetDefinitionModule(idlist->nd_IDF, 1),
CurrentScope, 0)) assert(0);
file_info = f;
}
}

414
lang/m2/comp/error.c
View File

@@ -1,414 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* E R R O R A N D D I A G N O S T I C R O U T I N E S */
/* $Id$ */
/* This file contains the (non-portable) error-message and diagnostic
giving functions. Be aware that they are called with a variable
number of arguments!
*/
#include "errout.h"
#include "debug.h"
#if __STDC__
#include <stdarg.h>
#else
#include <varargs.h>
#endif
#include <system.h>
#include <em_arith.h>
#include <em_label.h>
#include <em_code.h>
#include "strict3rd.h"
#include "input.h"
#include "f_info.h"
#include "LLlex.h"
#include "main.h"
#include "node.h"
#include "warning.h"
#include "nostrict.h"
/* error classes */
#define ERROR 1
#define WARNING 2
#define LEXERROR 3
#define LEXWARNING 4
#define CRASH 5
#define FATAL 6
#ifdef DEBUG
#define VDEBUG 7
#endif
int err_occurred;
extern char *symbol2str();
/* There are three general error-message functions:
lexerror() lexical and pre-processor error messages
error() syntactic and semantic error messages
node_error() errors in nodes
The difference lies in the place where the file name and line
number come from.
Lexical errors report from the global variables LineNumber and
FileName, node errors get their information from the
node, whereas other errors use the information in the token.
*/
#if __STDC__
#ifdef DEBUG
/*VARARGS*/
debug(char *fmt, ...)
{
va_list ap;
va_start(ap, fmt);
{
_error(VDEBUG, NULLNODE, ap, 0);
}
va_end(ap);
}
#endif /* DEBUG */
/*VARARGS*/
error(char *fmt, ...)
{
va_list ap;
va_start(ap, fmt);
{
_error(ERROR, NULLNODE, fmt, ap, 0);
}
va_end(ap);
}
/*VARARGS*/
node_error(t_node *node, char *fmt, ...)
{
va_list ap;
va_start(ap, fmt);
{
_error(ERROR, node, fmt, ap, 0);
}
va_end(ap);
}
/*VARARGS*/
warning(int class, char *fmt, ...)
{
va_list ap;
va_start(ap, fmt);
{
_error(WARNING, NULLNODE, fmt, ap, class);
}
va_end(ap);
}
/*VARARGS*/
node_warning(t_node *node, int class, char *fmt, ...)
{
va_list ap;
va_start(ap, fmt);
{
_error(WARNING, node, fmt, ap, class);
}
va_end(ap);
}
/*VARARGS*/
lexerror(char *fmt, ...)
{
va_list ap;
va_start(ap, fmt);
{
_error(LEXERROR, NULLNODE, fmt, ap, 0);
}
va_end(ap);
}
/*VARARGS*/
lexwarning(int class, char *fmt, ...)
{
va_list ap;
va_start(ap, fmt);
{
_error(LEXWARNING, NULLNODE, fmt, ap, class);
}
va_end(ap);
}
/*VARARGS*/
fatal(char *fmt, ...)
{
va_list ap;
va_start(ap, fmt);
{
_error(FATAL, NULLNODE, fmt, ap, 0);
}
va_end(ap);
sys_stop(S_EXIT);
}
/*VARARGS*/
crash(char *fmt, ...)
{
va_list ap;
va_start(ap, fmt);
{
_error(CRASH, NULLNODE, fmt, ap, 0);
}
va_end(ap);
#ifdef DEBUG
sys_stop(S_ABORT);
#else
sys_stop(S_EXIT);
#endif
}
#else
#ifdef DEBUG
/*VARARGS*/
debug(va_alist)
va_dcl
{
va_list ap;
va_start(ap);
{
char *fmt = va_arg(ap, char *);
_error(VDEBUG, NULLNODE, fmt, ap, 0);
}
va_end(ap);
}
#endif /* DEBUG */
/*VARARGS*/
error(va_alist)
va_dcl
{
va_list ap;
va_start(ap);
{
char *fmt = va_arg(ap, char *);
_error(ERROR, NULLNODE, fmt, ap, 0);
}
va_end(ap);
}
/*VARARGS*/
node_error(va_alist)
va_dcl
{
va_list ap;
va_start(ap);
{
t_node *node = va_arg(ap, t_node *);
char *fmt = va_arg(ap, char *);
_error(ERROR, node, fmt, ap, 0);
}
va_end(ap);
}
/*VARARGS*/
warning(va_alist)
va_dcl
{
va_list ap;
va_start(ap);
{
int class = va_arg(ap, int);
char *fmt = va_arg(ap, char *);
_error(WARNING, NULLNODE, fmt, ap, class);
}
va_end(ap);
}
/*VARARGS*/
node_warning(va_alist)
va_dcl
{
va_list ap;
va_start(ap);
{
t_node *nd = va_arg(ap, t_node *);
int class = va_arg(ap, int);
char *fmt = va_arg(ap, char *);
_error(WARNING, nd, fmt, ap, class);
}
va_end(ap);
}
/*VARARGS*/
lexerror(va_alist)
va_dcl
{
va_list ap;
va_start(ap);
{
char *fmt = va_arg(ap, char *);
_error(LEXERROR, NULLNODE, fmt, ap, 0);
}
va_end(ap);
}
/*VARARGS*/
lexwarning(va_alist)
va_dcl
{
va_list ap;
va_start(ap);
{
int class = va_arg(ap, int);
char *fmt = va_arg(ap, char *);
_error(LEXWARNING, NULLNODE, fmt, ap, class);
}
va_end(ap);
}
/*VARARGS*/
fatal(va_alist)
va_dcl
{
va_list ap;
va_start(ap);
{
char *fmt = va_arg(ap, char *);
_error(FATAL, NULLNODE, fmt, ap, 0);
}
va_end(ap);
sys_stop(S_EXIT);
}
/*VARARGS*/
crash(va_alist)
va_dcl
{
va_list ap;
va_start(ap);
{
char *fmt = va_arg(ap, char *);
_error(CRASH, NULLNODE, fmt, ap, 0);
}
va_end(ap);
#ifdef DEBUG
sys_stop(S_ABORT);
#else
sys_stop(S_EXIT);
#endif
}
#endif
_error(class, node, fmt, ap, warn_class)
int class;
t_node *node;
char *fmt;
register va_list ap;
int warn_class;
{
/* _error attempts to limit the number of error messages
for a given line to MAXERR_LINE.
*/
unsigned int ln = 0;
register char *remark = 0;
/* check visibility of message */
if (class == ERROR || class == WARNING) {
if (token_nmb < tk_nmb_at_last_syn_err + ERR_SHADOW)
/* warning or error message overshadowed */
return;
}
/* Since name and number are gathered from different places
depending on the class, we first collect the relevant
values and then decide what to print.
*/
/* preliminaries */
switch (class) {
case ERROR:
case LEXERROR:
case CRASH:
case FATAL:
if (C_busy()) C_ms_err();
err_occurred = 1;
break;
}
/* the remark */
switch (class) {
case WARNING:
case LEXWARNING:
if (! (warn_class & warning_classes)) return;
switch(warn_class) {
#ifndef STRICT_3RD_ED
case W_OLDFASHIONED:
remark = "(old-fashioned use)";
break;
#endif
#ifndef NOSTRICT
case W_STRICT:
remark = "(strict)";
break;
#endif
default:
remark = "(warning)";
break;
}
break;
case CRASH:
remark = "CRASH\007";
break;
case FATAL:
remark = "fatal error --";
break;
#ifdef DEBUG
case VDEBUG:
remark = "(debug)";
break;
#endif /* DEBUG */
}
/* the place */
switch (class) {
case WARNING:
case ERROR:
ln = node ? node->nd_lineno : dot.tk_lineno;
break;
case LEXWARNING:
case LEXERROR:
case CRASH:
case FATAL:
#ifdef DEBUG
case VDEBUG:
#endif /* DEBUG */
ln = LineNumber;
break;
}
if (FileName) fprint(ERROUT, "\"%s\", line %u: ", FileName, ln);
if (remark) fprint(ERROUT, "%s ", remark);
doprnt(ERROUT, fmt, ap); /* contents of error */
fprint(ERROUT, "\n");
}

293
lang/m2/comp/expression.g
View File

@@ -1,293 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* E X P R E S S I O N S */
/* $Id$ */
{
#include "debug.h"
#include <alloc.h>
#include <em_arith.h>
#include <em_label.h>
#include <assert.h>
#include "LLlex.h"
#include "idf.h"
#include "def.h"
#include "node.h"
#include "type.h"
#include "chk_expr.h"
#include "warning.h"
extern char options[];
}
/* inline, we need room for pdp/11
number(t_node **p;) :
[
%default
INTEGER
|
REAL
] { *p = dot2leaf(Value);
(*p)->nd_type = toktype;
}
;
*/
qualident(t_node **p;)
{
} :
IDENT { *p = dot2leaf(Name); }
[
selector(p)
]*
;
selector(register t_node **pnd;)
{ t_node *nd;
} :
'.' { nd = dot2leaf(Select); nd->nd_NEXT = *pnd; *pnd = nd; }
IDENT { (*pnd)->nd_IDF = dot.TOK_IDF; }
;
ExpList(t_node **pnd;)
{
register t_node *nd;
} :
expression(pnd) { *pnd = nd = dot2node(Link,*pnd,NULLNODE);
nd->nd_symb = ',';
}
[
',' { nd->nd_RIGHT = dot2leaf(Link);
nd = nd->nd_RIGHT;
}
expression(&(nd->nd_LEFT))
]*
;
ConstExpression(register t_node **pnd;)
{
}:
expression(pnd)
/*
* Changed rule in new Modula-2.
* Check that the expression is a constant expression and evaluate!
*/
{
DO_DEBUG(options['C'], print("CONSTANT EXPRESSION\n"));
DO_DEBUG(options['C'], PrNode(*pnd, 0));
if (ChkExpression(pnd) &&
(*pnd)->nd_class != Set &&
(*pnd)->nd_class != Value &&
! (options['l'] && (*pnd)->nd_class == Def && IsProc((*pnd)))) {
error("constant expression expected");
}
DO_DEBUG(options['C'], print("RESULTS IN\n"));
DO_DEBUG(options['C'], PrNode(*pnd, 0));
}
;
expression(register t_node **pnd;)
{
} :
SimpleExpression(pnd)
[
/* relation */
[ '=' | '#' | '<' | LESSEQUAL | '>' | GREATEREQUAL | IN ]
{ *pnd = dot2node(Oper, *pnd, NULLNODE); }
SimpleExpression(&((*pnd)->nd_RIGHT))
|
]
;
/* Inline in expression
relation:
'=' | '#' | '<' | LESSEQUAL | '>' | GREATEREQUAL | IN
;
*/
SimpleExpression(register t_node **pnd;)
{
register t_node *nd = 0;
} :
[
[ '+' | '-' ]
{ nd = dot2leaf(Uoper);
/* priority of unary operator ??? */
}
|
]
term(pnd)
{ if (nd) {
nd->nd_RIGHT = *pnd;
*pnd = nd;
}
nd = *pnd;
}
[
/* AddOperator */
[ '+' | '-' | OR ]
{ nd = dot2node(Oper, nd, NULLNODE); }
term(&(nd->nd_RIGHT))
]*
{ *pnd = nd; }
;
/* Inline in "SimpleExpression"
AddOperator:
'+' | '-' | OR
;
*/
term(t_node **pnd;)
{
register t_node *nd;
}:
factor(pnd) { nd = *pnd; }
[
/* MulOperator */
[ '*' | '/' | DIV | MOD | AND ]
{ nd = dot2node(Oper, nd, NULLNODE); }
factor(&(nd->nd_RIGHT))
]*
{ *pnd = nd; }
;
/* inline in "term"
MulOperator:
'*' | '/' | DIV | MOD | AND
;
*/
factor(register t_node **p;)
{
register t_node *nd;
t_node *nd1;
} :
qualident(p)
[
designator_tail(p)
[
{ *p = dot2node(Call, *p, NULLNODE); }
ActualParameters(&((*p)->nd_RIGHT))
|
]
|
bare_set(&nd1)
{ nd = nd1; nd->nd_LEFT = *p; *p = nd; }
]
|
bare_set(p)
| %default
[
%default
INTEGER
|
REAL
|
STRING
] { *p = dot2leaf(Value);
(*p)->nd_type = toktype;
}
|
'(' { nd = dot2leaf(Uoper); }
expression(p)
{ /* In some cases we must leave the '(' as an unary
operator, because otherwise we cannot see that the
factor was not a designator
*/
register int class = (*p)->nd_class;
if (class == Arrsel ||
class == Arrow ||
class == Name ||
class == Select) {
nd->nd_RIGHT = *p;
*p = nd;
}
else FreeNode(nd);
}
')'
|
NOT { *p = dot2leaf(Uoper); }
factor(&((*p)->nd_RIGHT))
;
bare_set(t_node **pnd;)
{
register t_node *nd;
} :
'{' { DOT = SET;
*pnd = nd = dot2leaf(Xset);
nd->nd_type = bitset_type;
}
[
element(nd)
[ { nd = nd->nd_RIGHT; }
',' element(nd)
]*
|
]
'}'
;
ActualParameters(t_node **pnd;):
'(' ExpList(pnd)? ')'
;
element(register t_node *nd;) :
expression(&(nd->nd_RIGHT))
[
UPTO
{ nd->nd_RIGHT = dot2node(Link, nd->nd_RIGHT, NULLNODE);}
expression(&(nd->nd_RIGHT->nd_RIGHT))
|
]
{ nd->nd_RIGHT = dot2node(Link, nd->nd_RIGHT, NULLNODE);
nd->nd_RIGHT->nd_symb = ',';
}
;
designator(t_node **pnd;)
:
qualident(pnd)
designator_tail(pnd)
;
designator_tail(register t_node **pnd;):
visible_designator_tail(pnd)
[ %persistent
%default
selector(pnd)
|
visible_designator_tail(pnd)
]*
|
;
visible_designator_tail(t_node **pnd;)
{
register t_node *nd = *pnd;
}:
'[' { nd = dot2node(Arrsel, nd, NULLNODE); }
expression(&(nd->nd_RIGHT))
[
','
{ nd = dot2node(Arrsel, nd, NULLNODE);
}
expression(&(nd->nd_RIGHT))
]*
']'
{ *pnd = nd; }
|
'^' { *pnd = dot2node(Arrow, NULLNODE, nd); }
;

21
lang/m2/comp/f_info.h
View File

@@ -1,21 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* F I L E D E S C R I P T O R S T R U C T U R E */
/* $Id$ */
struct f_info {
unsigned short f_lineno;
char *f_filename;
char *f_workingdir;
};
extern struct f_info file_info;
#define LineNumber file_info.f_lineno
#define FileName file_info.f_filename
#define WorkingDir file_info.f_workingdir

13
lang/m2/comp/idf.c
View File

@@ -1,13 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* I N S T A N T I A T I O N O F I D F P A C K A G E */
/* $Id$ */
#include "idf.h"
#include <idf_pkg.body>

23
lang/m2/comp/idf.h
View File

@@ -1,23 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* U S E R D E C L A R E D P A R T O F I D F */
/* $Id$ */
struct id_u {
int id_res;
struct def *id_df;
};
#define IDF_TYPE struct id_u
#define id_reserved id_user.id_res
#define id_def id_user.id_df
#include <idf_pkg.spec>
typedef struct idf t_idf;

12
lang/m2/comp/idlist.H
View File

@@ -1,12 +0,0 @@
/* $Header$ */
#include <alloc.h>
/* Structure to link idf structures together
*/
struct id_list {
struct id_list *next;
struct idf *id_ptr;
};
/* ALLOCDEF "id_list" */

20
lang/m2/comp/idlist.c
View File

@@ -1,20 +0,0 @@
static char *RcsId = "$Header$";
#include "idf.h"
#include "idlist.h"
struct id_list *h_id_list; /* Header of free list */
/* FreeIdList: take a list of id_list structures and put them
on the free list of id_list structures
*/
FreeIdList(p)
struct id_list *p;
{
register struct id_list *q;
while (q = p) {
p = p->next;
free_id_list(q);
}
}

32
lang/m2/comp/input.c
View File

@@ -1,32 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* I N S T A N T I A T I O N O F I N P U T P A C K A G E */
/* $Id$ */
#include "f_info.h"
struct f_info file_info;
#include "input.h"
#include <inp_pkg.body>
AtEoIF()
{
/* Make the unstacking of input streams noticable to the
lexical analyzer
*/
if (WorkingDir[0] != '\0') free(WorkingDir);
return 1;
}
AtEoIT()
{
/* Make the end of the text noticable
*/
return 1;
}

18
lang/m2/comp/input.h
View File

@@ -1,18 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* I N S T A N T I A T I O N O F I N P U T M O D U L E */
/* $Id$ */
#include "inputtype.h"
#define INP_NPUSHBACK 2
#define INP_TYPE struct f_info
#define INP_VAR file_info
#include <inp_pkg.spec>

120
lang/m2/comp/lookup.c
View File

@@ -1,120 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* L O O K U P R O U T I N E S */
/* $Id$ */
#include "debug.h"
#include <em_arith.h>
#include <em_label.h>
#include <assert.h>
#include "LLlex.h"
#include "def.h"
#include "idf.h"
#include "scope.h"
#include "node.h"
#include "type.h"
#include "misc.h"
extern int pass_1;
#ifdef DEBUG
extern char options[];
#endif
t_def *
lookup(id, scope, import, flags)
register t_idf *id;
t_scope *scope;
{
/* Look up a definition of an identifier in scope "scope".
Make the "def" list self-organizing.
Return a pointer to its "def" structure if it exists,
otherwise return 0.
*/
register t_def *df, *df1;
/* Look in the chain of definitions of this "id" for one with scope
"scope".
*/
for (df = id->id_def, df1 = 0;
df && df->df_scope != scope;
df1 = df, df = df->df_next) { /* nothing */ }
if (! df && import && scopeclosed(scope)) {
for (df = id->id_def, df1 = 0;
df && df->df_scope != PervasiveScope;
df1 = df, df = df->df_next) { /* nothing */ }
}
if (df) {
/* Found it
*/
if (df1) {
/* Put the definition in front
*/
df1->df_next = df->df_next;
df->df_next = id->id_def;
id->id_def = df;
}
df->df_flags |= flags;
while (df->df_kind & import) {
assert(df->imp_def != 0);
df = df->imp_def;
}
DO_DEBUG(options['S'], print("lookup %s, %x\n", id->id_text, df->df_kind));
}
return df;
}
t_def *
lookfor(id, vis, message, flags)
register t_node *id;
register t_scopelist *vis;
{
/* Look for an identifier in the visibility range started by "vis".
If it is not defined create a dummy definition and,
if message is set, give an error message
*/
register t_scopelist *sc;
t_scopelist *sc1 = 0;
t_def *df;
for (sc = vis; sc; sc = nextvisible(sc)) {
df = lookup(id->nd_IDF, sc->sc_scope, D_IMPORTED, flags);
if (df) {
if (message && df->df_kind == D_FORWARD) {
if (! sc1) sc1 = sc;
while (sc && sc->sc_scope != df->df_scope) {
sc = enclosing(sc);
}
if (sc) continue;
break;
}
if (pass_1 && message) {
if (sc1) sc = sc1;
while (vis->sc_scope->sc_level >
sc->sc_scope->sc_level ||
(sc1 &&
vis->sc_scope->sc_level >=
sc->sc_scope->sc_level)) {
define( id->nd_IDF,
vis->sc_scope,
D_INUSE)-> imp_def = df;
vis = enclosing(vis);
}
}
return df;
}
}
if (message) id_not_declared(id);
return MkDef(id->nd_IDF, vis->sc_scope, D_ERROR);
}

288
lang/m2/comp/main.c
View File

@@ -1,288 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* M A I N P R O G R A M */
/* $Id$ */
#include "debug.h"
#include <system.h>
#include <em_arith.h>
#include <em_label.h>
#include <em_code.h>
#include <alloc.h>
#include <assert.h>
#include <stb.h>
#include "strict3rd.h"
#include "dbsymtab.h"
#include "input.h"
#include "f_info.h"
#include "idf.h"
#include "LLlex.h"
#include "Lpars.h"
#include "type.h"
#include "def.h"
#include "scope.h"
#include "standards.h"
#include "tokenname.h"
#include "node.h"
#include "warning.h"
#include "SYSTEM.h"
int state; /* either IMPLEMENTATION or PROGRAM */
char options[128];
int DefinitionModule;
char *ProgName;
char **DEFPATH;
int nDEF = 2, mDEF = 10;
int pass_1 = 1;
t_def *Defined;
extern int err_occurred;
extern int fp_used; /* set if floating point used */
static t_node _emptystat = { Stat, 0, NULLTYPE, { ';' }};
t_node *EmptyStatement = &_emptystat;
main(argc, argv)
register char **argv;
{
register int Nargc = 1;
register char **Nargv = &argv[0];
ProgName = *argv++;
DEFPATH = (char **) Malloc((unsigned)mDEF * sizeof(char *));
DEFPATH[1] = 0;
while (--argc > 0) {
if (**argv == '-')
DoOption((*argv++) + 1);
else
Nargv[Nargc++] = *argv++;
}
Nargv[Nargc] = 0; /* terminate the arg vector */
if (Nargc < 2) {
fprint(STDERR, "%s: Use a file argument\n", ProgName);
sys_stop(S_EXIT);
}
sys_stop(Compile(Nargv[1], Nargv[2]) ? S_END : S_EXIT);
/*NOTREACHED*/
}
Compile(src, dst)
char *src, *dst;
{
extern struct tokenname tkidf[];
extern char *getwdir();
if (! InsertFile(src, (char **) 0, &src)) {
fprint(STDERR,"%s: cannot open %s\n", ProgName, src);
return 0;
}
LineNumber = 1;
FileName = src;
WorkingDir = getwdir(src);
C_init(word_size, pointer_size);
if (! C_open(dst)) fatal("could not open output file");
C_magic();
C_ms_emx(word_size, pointer_size);
#ifdef DBSYMTAB
if (options['g']) {
C_ms_std(FileName, N_SO, 0);
}
#endif /* DBSYMTAB */
init_idf();
InitCst();
reserve(tkidf);
InitScope();
InitTypes();
AddStandards();
#ifdef DEBUG
if (options['t']) {
LexScan();
return 1;
}
#endif /* DEBUG */
open_scope(OPENSCOPE);
GlobalVis = CurrVis;
close_scope(0);
CheckForLineDirective();
CompUnit();
C_ms_src((int)LineNumber - 1, FileName);
if (!err_occurred) {
pass_1 = 0;
C_exp(Defined->mod_vis->sc_scope->sc_name);
WalkModule(Defined);
if (fp_used) C_ms_flt();
}
C_close();
#ifdef DEBUG
if (options['i']) Info();
#endif
return ! err_occurred;
}
#ifdef DEBUG
LexScan()
{
register t_token *tkp = &dot;
extern char *symbol2str();
while (LLlex() > 0) {
print(">>> %s ", symbol2str(tkp->tk_symb));
switch(tkp->tk_symb) {
case IDENT:
print("%s\n", tkp->TOK_IDF->id_text);
break;
case INTEGER:
print("%ld\n", tkp->TOK_INT);
break;
case REAL:
print("%s\n", tkp->TOK_RSTR);
break;
case STRING:
print("\"%s\"\n", tkp->TOK_STR);
break;
default:
print("\n");
}
}
}
#endif
static struct stdproc {
char *st_nam;
int st_con;
} stdprocs[] = {
{ "ABS", S_ABS },
{ "CAP", S_CAP },
{ "CHR", S_CHR },
{ "FLOAT", S_FLOAT },
{ "HIGH", S_HIGH },
{ "HALT", S_HALT },
{ "EXCL", S_EXCL },
{ "DEC", S_DEC },
{ "INC", S_INC },
{ "VAL", S_VAL },
#ifndef STRICT_3RD_ED
{ "NEW", S_NEW },
{ "DISPOSE", S_DISPOSE },
#endif
{ "TRUNC", S_TRUNC },
{ "SIZE", S_SIZE },
{ "ORD", S_ORD },
{ "ODD", S_ODD },
{ "MAX", S_MAX },
{ "MIN", S_MIN },
{ "INCL", S_INCL },
{ "LONG", S_LONG },
{ "SHORT", S_SHORT },
{ "TRUNCD", S_TRUNCD },
{ "FLOATD", S_FLOATD },
{ 0, 0 }
};
static struct stdproc sysprocs[] = {
{ "TSIZE", S_TSIZE },
{ "ADR", S_ADR },
{ 0, 0 }
};
extern t_def *Enter(), *EnterType();
AddProcs(p)
register struct stdproc *p;
{
for (; p->st_nam != 0; p++) {
if (! Enter(p->st_nam, D_PROCEDURE, std_type, p->st_con)) {
assert(0);
}
}
}
AddStandards()
{
register t_def *df;
static t_token nilconst = { INTEGER, 0};
AddProcs(stdprocs);
EnterType("CHAR", char_type);
EnterType("INTEGER", int_type);
EnterType("LONGINT", longint_type);
EnterType("REAL", real_type);
EnterType("LONGREAL", longreal_type);
EnterType("CARDINAL", card_type);
if (options['l']) {
/* local extension: LONGCARD. */
EnterType("LONGCARD", longcard_type);
}
EnterType("(void)", void_type);
df = Enter("NIL", D_CONST, address_type, 0);
df->con_const = nilconst;
EnterType("PROC", construct_type(T_PROCEDURE, NULLTYPE));
EnterType("BITSET", bitset_type);
df = Enter("FALSE", D_ENUM, bool_type, 0);
bool_type->enm_enums = df;
df->enm_next = Enter("TRUE", D_ENUM, bool_type, 0);
df->enm_next->enm_val = 1;
assert(df->enm_val == 0 && df->enm_next->enm_next == 0);
EnterType("BOOLEAN", bool_type);
}
do_SYSTEM()
{
/* Simulate the reading of the SYSTEM definition module
*/
static char systemtext[] = SYSTEMTEXT;
EnterType("WORD", word_type);
EnterType("BYTE", byte_type);
EnterType("ADDRESS",address_type);
AddProcs(sysprocs);
if (!InsertText(systemtext, sizeof(systemtext) - 1)) {
fatal("could not insert text");
}
DefModule();
}
#ifdef DEBUG
int cntlines;
Info()
{
extern int cnt_def, cnt_node, cnt_paramlist, cnt_type,
cnt_switch_hdr, cnt_case_entry,
cnt_scope, cnt_scopelist, cnt_tmpvar;
print("\
%6d def\n%6d node\n%6d paramlist\n%6d type\n%6d switch_hdr\n\
%6d case_entry\n%6d scope\n%6d scopelist\n%6d tmpvar\n",
cnt_def, cnt_node, cnt_paramlist, cnt_type,
cnt_switch_hdr, cnt_case_entry,
cnt_scope, cnt_scopelist, cnt_tmpvar);
print("\nNumber of lines read: %d\n", cntlines);
}
#endif
void
No_Mem()
{
fatal("out of memory");
}
void
C_failed()
{
fatal("write failed");
}

25
lang/m2/comp/main.h
View File

@@ -1,25 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* S O M E G L O B A L V A R I A B L E S */
/* $Id$ */
extern char options[]; /* indicating which options were given */
extern int DefinitionModule;
/* flag indicating that we are reading a definition
module
*/
extern struct def *Defined;
/* definition structure of module defined in this
compilation
*/
extern char **DEFPATH; /* search path for DEFINITION MODULE's */
extern int mDEF, nDEF;
extern int state; /* either IMPLEMENTATION or PROGRAM */

26
lang/m2/comp/make.allocd
View File

@@ -1,26 +0,0 @@
sed -e '
s:^.*[ ]ALLOCDEF[ ].*"\(.*\)"[ ]*\([0-9][0-9]*\).*$:\
/* allocation definitions of struct \1 */\
extern char *st_alloc();\
extern struct \1 *h_\1;\
#ifdef DEBUG\
extern int cnt_\1;\
extern char *std_alloc();\
#define new_\1() ((struct \1 *) std_alloc((char **)\&h_\1, sizeof(struct \1), \2, \&cnt_\1))\
#else\
#define new_\1() ((struct \1 *) st_alloc((char **)\&h_\1, sizeof(struct \1), \2))\
#endif\
#define free_\1(p) st_free(p, \&h_\1, sizeof(struct \1))\
:' -e '
s:^.*[ ]STATICALLOCDEF[ ].*"\(.*\)"[ ]*\([0-9][0-9]*\).*$:\
/* allocation definitions of struct \1 */\
extern char *st_alloc();\
struct \1 *h_\1;\
#ifdef DEBUG\
int cnt_\1;\
#define new_\1() ((struct \1 *) std_alloc((char **)\&h_\1, sizeof(struct \1), \2, \&cnt_\1))\
#else\
#define new_\1() ((struct \1 *) st_alloc((char **)\&h_\1, sizeof(struct \1), \2))\
#endif\
#define free_\1(p) st_free(p, \&h_\1, sizeof(struct \1))\
:'

35
lang/m2/comp/make.hfiles
View File

@@ -1,35 +0,0 @@
: Update Files from database
PATH=/bin:/usr/bin
case $# in
1) ;;
*) echo use: $0 file >&2
exit 1
esac
(
IFCOMMAND="if [ -r \$FN ] ;\
then if cmp -s \$FN \$TMP;\
then rm \$TMP;\
else mv \$TMP \$FN;\
echo update \$FN;\
fi;\
else mv \$TMP \$FN;\
echo create \$FN;\
fi"
echo 'TMP=.uf$$'
echo 'FN=$TMP'
echo 'cat >$TMP <<\!EOF!'
sed -n '/^!File:/,${
/^$/d
/^!File:[ ]*\(.*\)$/s@@!EOF!\
'"$IFCOMMAND"'\
FN=\1\
cat >$TMP <<\\!EOF!@
p
}' $1
echo '!EOF!'
echo $IFCOMMAND
) |
sh

7
lang/m2/comp/make.next
View File

@@ -1,7 +0,0 @@
echo '#include "debug.h"'
sed -n '
s:^.*[ ]ALLOCDEF[ ].*"\(.*\)".*$:struct \1 *h_\1 = 0;\
#ifdef DEBUG\
int cnt_\1 = 0;\
#endif:p
' $*

35
lang/m2/comp/make.tokcase
View File

@@ -1,35 +0,0 @@
cat <<'--EOT--'
/* Generated by make.tokcase */
/* $Id$ */
#include "Lpars.h"
char *
symbol2str(tok)
int tok;
{
#define SIZBUF 8
/* allow for a few invocations in f.i. an argument list */
static char buf[SIZBUF] = { '\'', 0, '\'', 0, '\'', 0, '\'', 0};
static int index = 1;
switch (tok) {
--EOT--
sed '
/{[A-Z]/!d
s/.*{\(.*\),.*\(".*"\).*$/ case \1 :\
return \2;/
'
cat <<'--EOT--'
default:
if (tok <= 0) return "end of file";
if (tok < 040 || tok >= 0177) {
return "bad token";
}
index = (index+4) & (SIZBUF-1);
buf[index] = tok;
return &buf[index-1];
}
}
--EOT--

6
lang/m2/comp/make.tokfile
View File

@@ -1,6 +0,0 @@
sed '
/{[A-Z]/!d
s/.*{//
s/,.*//
s/.*/%token &;/
'

16
lang/m2/comp/misc.H
View File

@@ -1,16 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* M I S C E L L A N E O U S */
/* $Id$ */
#define is_anon_idf(x) ((x)->id_text[0] == '#')
#define id_not_declared(x) (not_declared("identifier", (x), ""))
extern struct idf
*gen_anon_idf();

67
lang/m2/comp/misc.c
View File

@@ -1,67 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* M I S C E L L A N E O U S R O U T I N E S */
/* $Id$ */
#include <alloc.h>
#include <em_arith.h>
#include <em_label.h>
#include "f_info.h"
#include "misc.h"
#include "LLlex.h"
#include "idf.h"
#include "node.h"
match_id(id1, id2)
register t_idf *id1, *id2;
{
/* Check that identifiers id1 and id2 are equal. If they
are not, check that we did'nt generate them in the
first place, and if not, give an error message
*/
if (id1 != id2 && !is_anon_idf(id1) && !is_anon_idf(id2)) {
error("name \"%s\" does not match block name \"%s\"",
id1->id_text,
id2->id_text
);
}
}
t_idf *
gen_anon_idf()
{
/* A new idf is created out of nowhere, to serve as an
anonymous name.
*/
static int name_cnt;
char *s = Malloc(strlen(FileName)+50);
char *sprint();
sprint(s, "#%d in %s, line %u",
++name_cnt, FileName, LineNumber);
s = Realloc(s, strlen(s)+1);
return str2idf(s, 0);
}
not_declared(what, id, where)
char *what, *where;
register t_node *id;
{
/* The identifier "id" is not declared. If it is not generated,
give an error message
*/
if (!is_anon_idf(id->nd_IDF)) {
node_error(id,
"%s \"%s\" not declared%s",
what,
id->nd_IDF->id_text,
where);
}
}

99
lang/m2/comp/modula-2.1
View File

@@ -1,99 +0,0 @@
.TH MODULA\-2 1 "$Revision$"
.ad
.SH NAME
Modula-2 \- ACK Modula-2 compiler
.SH SYNOPSIS
\fBack\fR \-m\fImach\fR files
.br
\fImach\fR files
.SH INTRODUCTION
This document provides a short introduction to the use of the ACK Modula-2
compiler. It also
mentions the location of definition modules for "standard" modules.
.SH FILENAMES
Usually, a Modula-2 program consists of several definition and implementation
modules, and one program module.
Definition modules must reside in files with names having a ".def" extension.
Implementation modules and program modules must reside in files having a
".mod" extension.
.PP
The name of the file in which a definition module is stored must be the same as
the module-name, apart from the extension.
Also, in most Unix systems filenames are only 14 characters long.
So, given an IMPORT declaration for a module called "LongModulName",
the compiler will try to open a file called "LongModulN.def".
The requirement does not hold for implementation or program modules,
but is certainly recommended.
.SH CALLING THE COMPILER
The easiest way to do this is to let the \fIack\fR(1) program do it.
So, to compile a program module "prog.mod", just call
.nf
\fBack\fR \-m\fImach\fR prog.mod [ objects of implementation modules ]
or
\fImach\fR prog.mod [ objects of implementation modules ]
.fi
where \fImach\fR is one of the target machines of ACK.
.PP
To compile an implementation module, use the \-\fBc\fR flag
to produce a ".o" file.
Definition modules can not be compiled; the compiler reads them when they are
needed.
.PP
For more details on the \fIack\fR program see \fIack\fR(1).
.SH DEFINITION MODULES
"Standard" definition modules can be found in
the directory \fB~em/lib/m2\fR.
.PP
When the compiler needs a definition module, it is first searched for
in the current directory, then in the directories given to it by the
\-\fBI\fR flag
in the order given,
and then in the directory mentioned above.
.SH FLAGS
The \fIack\fR(1) program recognizes (among others) the following
flags, that are passed to the Modula-2 compiler:
.IP \fB\-I\fIdirname\fR
.br
append \fIdirname\fR to the list of directories where definition modules
are looked for.
.IP \fB\-I\fP
don't look in
the directory \fB~em/lib/m2\fR.
.IP \fB\-M\fP\fIn\fP
set maximum identifier length to \fIn\fR. The minimum value of \fIn\fR
is 14, because the keyword "IMPLEMENTATION" is that long.
.IP \fB\-n\fR
do not generate EM register messages.
The user-declared variables will not be stored into registers on the target
machine.
.IP \fB\-L\fR
do not generate the EM \fBfil\fR and \fBlin\fR instructions that enable
an interpreter to keep track of the current location in the source code.
.IP \fB\-w\fR\fIclasses\fR
suppress warning messages whose class is a member of \fIclasses\fR.
Currently, there are three classes: \fBO\fR, indicating old-flashioned use,
\fBW\fR, indicating "ordinary" warnings, and \fBR\fR, indicating
restricted Modula-2.
If no \fIclasses\fR are given, all warnings are suppressed.
By default, warnings in class \fBO\fR and \fBW\fR are given.
.IP \fB\-W\fR\fIclasses\fR
allow for warning messages whose class is a member of \fIclasses\fR.
.IP \fB\-g\fR
produce a DBX-style symbol table.
.IP \fB\-x\fR
make all procedure names global, so that \fIadb\fR(1) understands them.
.IP \fB\-Xs\fR
make INTEGER ranges symmetric, t.i., MIN(INTEGER) = - MAX(INTEGER).
This is useful for interpreters that use the "real" MIN(INTEGER) to
indicate "undefined".
.LP
.SH SEE ALSO
\fIack\fR(1), \fIem_m2\fR(6), \fIm2mm(1)\fR
.SH FILES
.IR ~em/lib/em_m2 :
binary of the Modula-2 compiler.
.SH DIAGNOSTICS
All warning and error messages are written on standard error output.
.SH REMARKS
Debugging and profiling facilities may be present during the development
of \fIem_m2\fP.

4
lang/m2/comp/nmclash.c
View File

@@ -1,4 +0,0 @@
/* Accepted if many characters of long names are significant */
abcdefghijklmnopr() { }
abcdefghijklmnopq() { }
main() { }

63
lang/m2/comp/node.H
View File

@@ -1,63 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* N O D E O F A N A B S T R A C T P A R S E T R E E */
/* $Id$ */
struct node {
char nd_class; /* kind of node */
#define Value 0 /* constant */
#define Arrsel 1 /* array selection */
#define Oper 2 /* binary operator */
#define Uoper 3 /* unary operator */
#define Arrow 4 /* ^ construction */
#define Call 5 /* cast or procedure - or function call */
#define Name 6 /* an identifier */
#define Set 7 /* a set constant */
#define Xset 8 /* a set */
#define Def 9 /* an identified name */
#define Stat 10 /* a statement */
#define Select 11 /* a '.' selection */
#define Link 12
/* do NOT change the order or the numbers!!! */
char nd_flags; /* options */
#define ROPTION 1
#define AOPTION 2
struct type *nd_type; /* type of this node */
struct token nd_token;
#define nd_set nd_token.tk_data.tk_set
#define nd_def nd_token.tk_data.tk_def
#define nd_LEFT nd_token.tk_data.tk_left
#define nd_RIGHT nd_token.tk_data.tk_right
#define nd_NEXT nd_token.tk_data.tk_next
#define nd_symb nd_token.tk_symb
#define nd_lineno nd_token.tk_lineno
#define nd_IDF nd_token.TOK_IDF
#define nd_SSTR nd_token.TOK_SSTR
#define nd_STR nd_token.TOK_STR
#define nd_SLE nd_token.TOK_SLE
#define nd_INT nd_token.TOK_INT
#define nd_REAL nd_token.TOK_REAL
#define nd_RSTR nd_token.TOK_RSTR
#define nd_RVAL nd_token.TOK_RVAL
};
typedef struct node t_node;
/* ALLOCDEF "node" 50 */
extern t_node *dot2node(), *dot2leaf(), *getnode();
#define NULLNODE ((t_node *) 0)
#define HASSELECTORS 002
#define VARIABLE 004
#define VALUE 010
#define IsCast(lnd) ((lnd)->nd_class == Def && is_type((lnd)->nd_def))
#define IsProc(lnd) ((lnd)->nd_type->tp_fund == T_PROCEDURE)

158
lang/m2/comp/node.c
View File

@@ -1,158 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* N O D E O F A N A B S T R A C T P A R S E T R E E */
/* $Id$ */
#include "debug.h"
#include <em_label.h>
#include <em_arith.h>
#include <alloc.h>
#include <system.h>
#include "LLlex.h"
#include "def.h"
#include "type.h"
#include "node.h"
#include "main.h"
static int nsubnodes[] = {
0,
2,
2,
2,
2,
2,
1,
1,
2,
1,
2,
1,
2
};
t_node *
getnode(class)
{
register t_node *nd = new_node();
if (options['R']) nd->nd_flags |= ROPTION;
if (options['A']) nd->nd_flags |= AOPTION;
nd->nd_class = class;
return nd;
}
t_node *
dot2node(class, left, right)
t_node *left, *right;
{
register t_node *nd = getnode(class);
nd->nd_symb = dot.tk_symb;
nd->nd_lineno = dot.tk_lineno;
nd->nd_LEFT = left;
nd->nd_RIGHT = right;
return nd;
}
t_node *
dot2leaf(class)
{
register t_node *nd = getnode(class);
nd->nd_token = dot;
switch(nsubnodes[class]) {
case 1:
nd->nd_NEXT = 0;
break;
case 2:
nd->nd_LEFT = 0;
nd->nd_RIGHT = 0;
break;
}
return nd;
}
FreeNode(nd)
register t_node *nd;
{
/* Put nodes that are no longer needed back onto the free
list
*/
if (!nd) return;
switch(nsubnodes[nd->nd_class]) {
case 2:
FreeNode(nd->nd_LEFT);
FreeNode(nd->nd_RIGHT);
break;
case 1:
FreeNode(nd->nd_NEXT);
break;
}
free_node(nd);
}
/*ARGSUSED*/
NodeCrash(expp)
t_node *expp;
{
crash("(NodeCrash) Illegal node");
}
/*ARGSUSED*/
PNodeCrash(expp)
t_node **expp;
{
crash("(PNodeCrash) Illegal node");
}
#ifdef DEBUG
extern char *symbol2str();
indnt(lvl)
{
while (lvl--) {
print(" ");
}
}
printnode(nd, lvl)
register t_node *nd;
{
indnt(lvl);
print("Class: %d; Symbol: %s; Flags: %d\n", nd->nd_class, symbol2str(nd->nd_symb), nd->nd_flags);
if (nd->nd_type) {
indnt(lvl);
print("Type: ");
DumpType(nd->nd_type);
print("\n");
}
}
PrNode(nd, lvl)
register t_node *nd;
{
if (! nd) {
indnt(lvl); print("<nilnode>\n");
return;
}
printnode(nd, lvl);
switch(nsubnodes[nd->nd_class]) {
case 1:
PrNode(nd->nd_LEFT, lvl + 1);
PrNode(nd->nd_RIGHT, lvl + 1);
break;
case 2:
PrNode(nd->nd_NEXT, lvl + 1);
break;
}
}
#endif /* DEBUG */

28
lang/m2/comp/options
View File

@@ -1,28 +0,0 @@
options:
g: symbol table for debugger
l: local extensions enabled
n: no register messages
s: symmetric range for integers: MIN(INTEGER) = -MAX(INTEGER)
w: disable warnings
x: make every name global (for ADB)
A: extra array bound checks
I: look in directory for definition modules
L: no FIL/LIN instructions
M: maximum identifier length
R: runtime checks
U: allow underscores in identifiers
V: object sizes and alignments
W: enable warnings
3: strict 3rd edition Modula-2
-: to pass debugging options
Debugging options:
i: display number of structures allocated and number of lines read
t: run lexical analyzer only
C: dump of constant expressions
F: display size of every file read.
S: define/lookup symbol table access dump
X: parse-tree dump

260
lang/m2/comp/options.c
View File

@@ -1,260 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* U S E R O P T I O N - H A N D L I N G */
/* $Id$ */
#include "idfsize.h"
#include <em_arith.h>
#include <em_label.h>
#include <alloc.h>
#include "strict3rd.h"
#include "dbsymtab.h"
#include "type.h"
#include "main.h"
#include "warning.h"
#include "nostrict.h"
#include "nocross.h"
#include "class.h"
#include "squeeze.h"
#define MINIDFSIZE 14
#if MINIDFSIZE < 14
You fouled up! MINIDFSIZE has to be at least 14 or the compiler will not
recognize some keywords!
#endif
extern int idfsize;
static int ndirs = 1;
int warning_classes = W_INITIAL;
int gdb_flag;
DoOption(text)
register char *text;
{
switch(*text++) {
case '-':
options[*text]++; /* debug options etc. */
break;
case 'U': /* allow underscores in identifiers */
inidf['_'] = 1;
break;
case 'L': /* no fil/lin */
case 'R': /* no range checks */
case 'A': /* extra array bound checks, for machines that do not
implement it in AAR/LAR/SAR
*/
case 'n': /* no register messages */
case 'x': /* every name global */
case 's': /* symmetric: MIN(INTEGER) = -MAX(INTEGER) */
case '3': /* strict 3rd edition Modula-2 */
case 'l': /* local additions enabled */
options[text[-1]]++;
break;
#ifdef DBSYMTAB
case 'g': /* generate symbol table for debugger */
options['g']++;
if (*text == 'd') {
/* Assume -gdb. */
gdb_flag = 1;
}
options['n']++; /* no register vars ??? */
break;
#endif /* DBSYMTAB */
case 'w':
if (*text) {
while (*text) {
switch(*text++) {
#ifndef STRICT_3RD_ED
case 'O':
warning_classes &= ~W_OLDFASHIONED;
break;
#endif
#ifndef NOSTRICT
case 'R':
warning_classes &= ~W_STRICT;
break;
#endif
case 'W':
warning_classes &= ~W_ORDINARY;
break;
}
}
}
else warning_classes = W_ALWAYS;
break;
case 'W':
if (*text) {
while (*text) {
switch(*text++) {
#ifndef STRICT_3RD_ED
case 'O':
warning_classes |= W_OLDFASHIONED;
break;
#endif
#ifndef NOSTRICT
case 'R':
warning_classes |= W_STRICT;
break;
#endif
case 'W':
warning_classes |= W_ORDINARY;
break;
}
}
}
else warning_classes = W_ALL;
break;
case 'M': { /* maximum identifier length */
#ifndef SQUEEZE
char *t = text; /* because &text is illegal */
idfsize = txt2int(&t);
if (*t || idfsize <= 0)
fatal("malformed -M option");
if (idfsize > IDFSIZE) {
idfsize = IDFSIZE;
warning(W_ORDINARY,"maximum identifier length is %d", IDFSIZE);
}
if (idfsize < MINIDFSIZE) {
warning(W_ORDINARY, "minimum identifier length is %d", MINIDFSIZE);
idfsize = MINIDFSIZE;
}
#endif
}
break;
case 'I' :
if (*text) {
register int i;
register char *new = text;
if (nDEF > mDEF) {
DEFPATH = (char **)
Realloc((char *)DEFPATH,(unsigned)(mDEF+=10)*sizeof(char *));
}
for (i = ndirs++; i < nDEF; i++) {
char *tmp = DEFPATH[i];
DEFPATH[i] = new;
new = tmp;
}
++nDEF;
}
else DEFPATH[ndirs] = 0;
break;
case 'V' : /* set object sizes and alignment requirements */
#ifndef NOCROSS
{
register int size;
register int algn;
char c;
char *t;
while (c = *text++) {
char *strindex();
t = text;
size = txt2int(&t);
algn = 0;
if (*(text = t) == '.') {
t = text + 1;
algn = txt2int(&t);
text = t;
}
if (! strindex("wislfdpS", c)) {
error("-V: bad type indicator %c\n", c);
}
if (size != 0) switch (c) {
case 'w': /* word */
word_size = size;
dword_size = 2 * size;
break;
case 'i': /* int */
int_size = size;
break;
case 's': /* short (subranges) */
short_size = size;
break;
case 'l': /* longint */
long_size = size;
break;
case 'f': /* real */
float_size = size;
break;
case 'd': /* longreal */
double_size = size;
break;
case 'p': /* pointer */
pointer_size = size;
break;
}
if (algn != 0) switch (c) {
case 'w': /* word */
word_align = algn;
break;
case 'i': /* int */
int_align = algn;
break;
case 's': /* short (subranges) */
short_align = algn;
break;
case 'l': /* longint */
long_align = algn;
break;
case 'f': /* real */
float_align = algn;
break;
case 'd': /* longreal */
double_align = algn;
break;
case 'p': /* pointer */
pointer_align = algn;
break;
case 'S': /* initial record alignment */
struct_align = algn;
break;
}
}
}
#endif /* NOCROSS */
break;
}
}
#if (!SQUEEZE) | (!NOCROSS)
int
txt2int(tp)
register char **tp;
{
/* the integer pointed to by *tp is read, while increasing
*tp; the resulting value is yielded.
*/
register int val = 0;
register int ch;
while (ch = **tp, ch >= '0' && ch <= '9') {
val = val * 10 + ch - '0';
(*tp)++;
}
return val;
}
#endif

4
lang/m2/comp/param.h
View File

@@ -1,4 +0,0 @@
/* $Header$ */
#define IDFSIZE 256
#define NUMSIZE 256

144
lang/m2/comp/print.c
View File

@@ -1,144 +0,0 @@
/* P R I N T R O U T I N E S */
#include <system.h>
#include <em_arith.h>
#define SSIZE 1024 /* string-buffer size for print routines */
char *long2str();
doprnt(fp, fmt, argp)
File *fp;
char *fmt;
int argp[];
{
char buf[SSIZE];
sys_write(fp, buf, format(buf, fmt, (char *)argp));
}
/*VARARGS1*/
printf(fmt, args)
char *fmt;
char args;
{
char buf[SSIZE];
sys_write(STDOUT, buf, format(buf, fmt, &args));
}
/*VARARGS1*/
fprintf(fp, fmt, args)
File *fp;
char *fmt;
char args;
{
char buf[SSIZE];
sys_write(fp, buf, format(buf, fmt, &args));
}
/*VARARGS1*/
char *
sprintf(buf, fmt, args)
char *buf, *fmt;
char args;
{
buf[format(buf, fmt, &args)] = '\0';
return buf;
}
int
format(buf, fmt, argp)
char *buf, *fmt;
char *argp;
{
register char *pf = fmt, *pa = argp;
register char *pb = buf;
while (*pf) {
if (*pf == '%') {
register int width, base, pad, npad;
char *arg;
char cbuf[2];
char *badformat = "<bad format>";
/* get padder */
if (*++pf == '0') {
pad = '0';
++pf;
}
else
pad = ' ';
/* get width */
width = 0;
while (*pf >= '0' && *pf <= '9')
width = 10 * width + *pf++ - '0';
/* get text and move pa */
if (*pf == 's') {
arg = *(char **)pa;
pa += sizeof(char *);
}
else
if (*pf == 'c') {
cbuf[0] = * (char *) pa;
cbuf[1] = '\0';
pa += sizeof(int);
arg = &cbuf[0];
}
else
if (*pf == 'l') {
/* alignment ??? */
if (base = integral(*++pf)) {
arg = long2str(*(long *)pa, base);
pa += sizeof(long);
}
else {
pf--;
arg = badformat;
}
}
else
if (base = integral(*pf)) {
arg = long2str((long)*(int *)pa, base);
pa += sizeof(int);
}
else
if (*pf == '%')
arg = "%";
else
arg = badformat;
npad = width - strlen(arg);
while (npad-- > 0)
*pb++ = pad;
while (*pb++ = *arg++);
pb--;
pf++;
}
else
*pb++ = *pf++;
}
return pb - buf;
}
integral(c)
{
switch (c) {
case 'b':
return -2;
case 'd':
return 10;
case 'o':
return -8;
case 'u':
return -10;
case 'x':
return -16;
}
return 0;
}

279
lang/m2/comp/program.g
View File

@@ -1,279 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* O V E R A L L S T R U C T U R E */
/* $Id$ */
{
#include "debug.h"
#include <alloc.h>
#include <em_arith.h>
#include <em_label.h>
#include <em_code.h>
#include <stb.h>
#include "dbsymtab.h"
#include "strict3rd.h"
#include "main.h"
#include "idf.h"
#include "LLlex.h"
#include "scope.h"
#include "def.h"
#include "type.h"
#include "node.h"
#include "f_info.h"
#include "warning.h"
#include "misc.h"
extern t_def *GetDefinitionModule();
}
/*
The grammar as given by Wirth is already almost LL(1); the
main problem is that the full form of a qualified designator
may be:
[ module_ident '.' ]* IDENT [ '.' field_ident ]*
which is quite confusing to an LL(1) parser. Rather than
resorting to context-sensitive techniques, I have decided
to render this as:
IDENT [ '.' IDENT ]*
on the grounds that it is quite natural to consider the first
IDENT to be the name of the object and regard the others as
field identifiers.
*/
%lexical LLlex;
%start CompUnit, CompilationUnit;
%start DefModule, DefinitionModule;
ModuleDeclaration
{
register t_def *df;
t_node *exportlist;
int qualified;
} :
MODULE IDENT { df = DefineLocalModule(dot.TOK_IDF); }
priority(&(df->mod_priority))
';'
import(1)*
export(&qualified, &exportlist)
block(&(df->mod_body))
IDENT { EnterExportList(exportlist, qualified);
close_scope(SC_CHKFORW|SC_CHKPROC|SC_REVERSE);
match_id(df->df_idf, dot.TOK_IDF);
}
;
priority(register t_node **prio;):
[
'[' ConstExpression(prio) ']'
{ if (! ((*prio)->nd_type->tp_fund & T_CARDINAL)) {
node_error(*prio, "illegal priority");
}
}
|
]
;
export(int *QUALflag; t_node **ExportList;):
{ *ExportList = 0; *QUALflag = D_EXPORTED; }
[
EXPORT
[
QUALIFIED
{ *QUALflag = D_QEXPORTED; }
|
]
IdentList(ExportList) ';'
|
]
;
import(int local;)
{
t_node *ImportList;
register t_node *FromId = 0;
register t_def *df;
} :
/*
When parsing a global module, this is the place where we must
read already compiled definition modules.
If the FROM clause is present, the identifier in it is a module
name, otherwise the names in the import list are module names.
*/
[ FROM
IDENT
%substart DefinitionModule;
{ FromId = dot2leaf(Name);
if (local) {
df = lookfor(FromId,enclosing(CurrVis),0,D_USED);
}
else df = GetDefinitionModule(dot.TOK_IDF, 1);
}
]?
IMPORT IdentList(&ImportList) ';'
%substart DefinitionModule;
{ if (FromId) {
EnterFromImportList(ImportList, df, FromId);
}
else {
EnterImportList(ImportList,
local,
enclosing(CurrVis)->sc_scope);
}
FreeNode(ImportList);
}
;
DefinitionModule
{
register t_def *df;
t_node *exportlist;
int dummy;
extern t_idf *DefId;
extern int ForeignFlag;
extern char *sprint();
register t_scope *currscope = CurrentScope;
char buf[512];
} :
DEFINITION
MODULE IDENT { df = define(dot.TOK_IDF, GlobalScope, D_MODULE);
df->df_flags |= D_BUSY | ForeignFlag;
currscope->sc_definedby = df;
if (DefId &&
df->df_idf != DefId &&
!is_anon_idf(df->df_idf)) {
error("DEFINITION MODULE name is \"%s\", not \"%s\"",
df->df_idf->id_text, DefId->id_text);
}
sprint(buf, "_%s_", df->df_idf->id_text);
currscope->sc_name = Salloc(buf, (unsigned) strlen(buf) + 1);
df->mod_vis = CurrVis;
df->df_type = standard_type(T_RECORD, 1, (arith) 1);
df->df_type->rec_scope = currscope;
DefinitionModule++;
if (!Defined) {
Defined = df;
}
}
';'
import(0)*
export(&dummy, &exportlist)
/* New Modula-2 does not have export lists in definition
modules. Issue a warning.
*/
{
if (exportlist) {
#ifndef STRICT_3RD_ED
if (! options['3'])
node_warning(exportlist, W_OLDFASHIONED, "export list in definition module ignored");
else
#endif
error("export list not allowed in definition module");
FreeNode(exportlist);
}
}
definition* END IDENT
{ end_definition_list(&(currscope->sc_def));
DefinitionModule--;
match_id(dot.TOK_IDF, df->df_idf);
df->df_flags &= ~D_BUSY;
}
'.'
;
definition
{
register t_def *df;
t_def *dummy;
} :
CONST [ %persistent ConstantDeclaration ';' ]*
|
TYPE
[ %persistent
IDENT { df = define(dot.TOK_IDF, CurrentScope, D_TYPE); }
[ '=' type(&(df->df_type))
{ SolveForwardTypeRefs(df); }
| /* empty */
/*
Here, the exported type has a hidden implementation.
The export is said to be opaque.
It is restricted to pointer types.
*/
{ df->df_kind = D_HIDDEN;
df->df_type = construct_type(T_HIDDEN, NULLTYPE);
}
]
{
#ifdef DBSYMTAB
if (options['g']) stb_string(df, D_TYPE);
#endif
}
';'
]*
|
VAR [ %persistent VariableDeclaration ';' ]*
|
ProcedureHeading(&dummy, D_PROCHEAD) ';'
;
ProgramModule
{
register t_def *df;
} :
MODULE
IDENT
%substart DefinitionModule;
{
if (state == IMPLEMENTATION) {
int len = strlen(dot.TOK_IDF->id_text);
if (len > 10) len = 10;
if (strncmp(FileName, dot.TOK_IDF->id_text, len)) {
warning(W_ORDINARY, "modulename %s does not match filename %s", dot.TOK_IDF->id_text, FileName);
}
df = GetDefinitionModule(dot.TOK_IDF, 0);
CurrVis = df->mod_vis;
}
else {
Defined = df = define(dot.TOK_IDF, GlobalScope, D_MODULE);
open_scope(CLOSEDSCOPE);
df->mod_vis = CurrVis;
CurrentScope->sc_name = "__M2M_";
CurrentScope->sc_definedby = df;
}
}
priority(&(df->mod_priority))
';' import(0)*
block(&(df->mod_body)) IDENT
{
close_scope(SC_CHKFORW|SC_CHKPROC|SC_REVERSE);
match_id(df->df_idf, dot.TOK_IDF);
}
'.'
;
CompilationUnit:
{ error("Compiling a definition module");
open_scope(CLOSEDSCOPE);
state = DEFINITION;
}
DefinitionModule
{ close_scope(SC_CHKFORW); }
| %default
[
IMPLEMENTATION
{ state = IMPLEMENTATION; }
|
/* empty */
{ state = PROGRAM; }
]
ProgramModule
;

65
lang/m2/comp/proto.main
View File

@@ -1,65 +0,0 @@
# $Id$
# C compilation part. Not to be called directly.
# Instead, it is to be called by the Makefile.
# SRC_DIR, UTIL_HOME, TARGET_HOME, CC, COPTIONS, LINT, LINTOPTIONS, LDOPTIONS,
# CC_AND_MKDEP, SUF, LIBSUF should be set here.
#PARAMS do not remove this line!
# PRODUCE is either e (readable EM) or k (compact EM)
PRODUCE = k
MDIR = $(TARGET_HOME)/modules
LIBDIR = $(MDIR)/lib
LINTLIBDIR = $(UTIL_HOME)/modules/lib
MALLOC = $(LIBDIR)/malloc.$(SUF)
EMLIB = $(LIBDIR)/libem_mes.$(LIBSUF) \
$(LIBDIR)/libem$(PRODUCE).$(LIBSUF) \
$(TARGET_HOME)/lib.bin/em_data.$(LIBSUF)
MODLIB = $(LIBDIR)/libinput.$(LIBSUF) \
$(LIBDIR)/libassert.$(LIBSUF) \
$(LIBDIR)/liballoc.$(LIBSUF) \
$(MALLOC) \
$(LIBDIR)/libflt.$(LIBSUF) \
$(LIBDIR)/libprint.$(LIBSUF) \
$(LIBDIR)/libstring.$(LIBSUF) \
$(LIBDIR)/libsystem.$(LIBSUF)
LIBS = $(EMLIB) $(MODLIB)
LINTLIBS = $(LINTLIBDIR)/$(LINTPREF)em_mes.$(LINTSUF) \
$(LINTLIBDIR)/$(LINTPREF)emk.$(LINTSUF) \
$(LINTLIBDIR)/$(LINTPREF)input.$(LINTSUF) \
$(LINTLIBDIR)/$(LINTPREF)assert.$(LINTSUF) \
$(LINTLIBDIR)/$(LINTPREF)alloc.$(LINTSUF) \
$(LINTLIBDIR)/$(LINTPREF)flt.$(LINTSUF) \
$(LINTLIBDIR)/$(LINTPREF)print.$(LINTSUF) \
$(LINTLIBDIR)/$(LINTPREF)string.$(LINTSUF) \
$(LINTLIBDIR)/$(LINTPREF)system.$(LINTSUF)
PROFILE =
INCLUDES = -I. -I$(SRC_DIR) -I$(TARGET_HOME)/modules/h -I$(TARGET_HOME)/h -I$(TARGET_HOME)/modules/pkg
CFLAGS = $(PROFILE) $(INCLUDES) $(COPTIONS)
LINTFLAGS = $(INCLUDES) $(LINTOPTIONS)
LDFLAGS = $(PROFILE) $(LDOPTIONS)
# C_SRC and OBJ should be set here.
#LISTS do not remove this line!
all: main
clean:
rm -f *.$(SUF) main
lint:
$(LINT) $(LINTFLAGS) $(C_SRC) $(LINTLIBS)
main: $(OBJ)
$(CC) $(LDFLAGS) $(OBJ) $(LIBS) -o main
# do not remove the next line; it is used for generating dependencies
#DEPENDENCIES

158
lang/m2/comp/proto.make
View File

@@ -1,158 +0,0 @@
# $Id$
# make Modula-2 compiler
#PARAMS do not remove this line!
UTIL_BIN = \
$(UTIL_HOME)/bin
SRC_DIR = \
$(SRC_HOME)/lang/m2/comp
TABGEN= $(UTIL_BIN)/tabgen
LLGEN = $(UTIL_BIN)/LLgen
LLGENOPTIONS = \
-n
SRC_G = $(SRC_DIR)/program.g $(SRC_DIR)/declar.g \
$(SRC_DIR)/expression.g $(SRC_DIR)/statement.g
GEN_G = tokenfile.g
GFILES= $(GEN_G) $(SRC_G)
SRC_C = $(SRC_DIR)/LLlex.c $(SRC_DIR)/LLmessage.c $(SRC_DIR)/error.c \
$(SRC_DIR)/main.c $(SRC_DIR)/tokenname.c $(SRC_DIR)/idf.c \
$(SRC_DIR)/input.c $(SRC_DIR)/type.c $(SRC_DIR)/def.c \
$(SRC_DIR)/misc.c $(SRC_DIR)/enter.c $(SRC_DIR)/defmodule.c \
$(SRC_DIR)/typequiv.c $(SRC_DIR)/node.c $(SRC_DIR)/cstoper.c \
$(SRC_DIR)/chk_expr.c $(SRC_DIR)/options.c $(SRC_DIR)/walk.c \
$(SRC_DIR)/desig.c $(SRC_DIR)/code.c $(SRC_DIR)/lookup.c \
$(SRC_DIR)/stab.c
GEN_C = tokenfile.c program.c declar.c expression.c statement.c \
symbol2str.c char.c Lpars.c Lncor.c casestat.c tmpvar.c scope.c next.c
CFILES= $(SRC_C) $(GEN_C)
SRC_H = $(SRC_DIR)/LLlex.h $(SRC_DIR)/chk_expr.h $(SRC_DIR)/class.h \
$(SRC_DIR)/debug.h $(SRC_DIR)/desig.h $(SRC_DIR)/f_info.h \
$(SRC_DIR)/idf.h $(SRC_DIR)/input.h $(SRC_DIR)/main.h \
$(SRC_DIR)/misc.h $(SRC_DIR)/scope.h $(SRC_DIR)/standards.h \
$(SRC_DIR)/tokenname.h $(SRC_DIR)/walk.h $(SRC_DIR)/warning.h \
$(SRC_DIR)/SYSTEM.h
GEN_H = errout.h idfsize.h numsize.h strsize.h target_sizes.h bigresult.h \
inputtype.h density.h squeeze.h nocross.h nostrict.h def.h debugcst.h \
type.h Lpars.h node.h strict3rd.h real.h use_insert.h dbsymtab.h \
uns_arith.h def.h type.h node.h real.h
HFILES= $(GEN_H) $(SRC_H)
NEXTFILES = \
$(SRC_DIR)/def.H $(SRC_DIR)/type.H $(SRC_DIR)/node.H $(SRC_DIR)/real.H \
$(SRC_DIR)/scope.C $(SRC_DIR)/tmpvar.C $(SRC_DIR)/casestat.C
all: make.main
make -f make.main main
install: all
cp main $(TARGET_HOME)/lib.bin/em_m2
if [ $(DO_MACHINE_INDEP) = y ] ; \
then mk_manpage $(SRC_DIR)/em_m2.6 $(TARGET_HOME) ; \
mk_manpage $(SRC_DIR)/modula-2.1 $(TARGET_HOME) ; \
fi
cmp: all
-cmp main $(TARGET_HOME)/lib.bin/em_m2
opr:
make pr | opr
pr:
@pr $(SRC_DIR)/proto.make $(SRC_DIR)/proto.main Parameters \
$(SRC_DIR)/char.tab $(SRC_G) $(SRC_H) $(NEXTFILES) $(SRC_C)
lint: make.main
make -f make.main lint
Cfiles: hfiles LLfiles $(GEN_C) $(GEN_H) Makefile
echo $(CFILES) | tr ' ' '\012' > Cfiles
echo $(HFILES) | tr ' ' '\012' >> Cfiles
resolved: Cfiles
CC="$(CC)" UTIL_HOME="$(UTIL_HOME)" do_resolve `cat Cfiles` > Cfiles.new
-if cmp -s Cfiles Cfiles.new ; then rm -f Cfiles.new ; else mv Cfiles.new Cfiles ; fi
touch resolved
# there is no file called "dependencies"; we want dependencies checked
# every time. This means that make.main is made every time. Oh well ...
# it does not take much time.
dependencies: resolved
do_deps `grep '.c$$' Cfiles`
make.main: dependencies make_macros lists $(SRC_DIR)/proto.main
rm_deps $(SRC_DIR)/proto.main | sed -e '/^.PARAMS/r make_macros' -e '/^.LISTS/r lists' > make.main
cat *.dep >> make.main
make_macros: Makefile
echo 'SRC_DIR=$(SRC_DIR)' > make_macros
echo 'UTIL_HOME=$(UTIL_HOME)' >> make_macros
echo 'TARGET_HOME=$(TARGET_HOME)' >> make_macros
echo 'CC=$(CC)' >> make_macros
echo 'COPTIONS=$(COPTIONS)' >> make_macros
echo 'LDOPTIONS=$(LDOPTIONS)' >> make_macros
echo 'LINT=$(LINT)' >> make_macros
echo 'LINTSUF=$(LINTSUF)' >> make_macros
echo 'LINTPREF=$(LINTPREF)' >> make_macros
echo 'LINTOPTIONS=$(LINTOPTIONS)' >> make_macros
echo 'SUF=$(SUF)' >> make_macros
echo 'LIBSUF=$(LIBSUF)' >> make_macros
echo 'CC_AND_MKDEP=$(CC_AND_MKDEP)' >> make_macros
lists: Cfiles
echo "C_SRC = \\" > lists
echo $(CFILES) >> lists
echo "OBJ = \\" >> lists
echo $(CFILES) | sed -e 's|[^ ]*/||g' -e 's/\.c/.$$(SUF)/g' >> lists
clean:
-make -f make.main clean
rm -f $(GEN_C) $(GEN_G) $(GEN_H) hfiles LLfiles Cfiles LL.output
rm -f resolved *.dep lists make.main make_macros
LLfiles: $(GFILES)
$(LLGEN) $(LLGENOPTIONS) $(GFILES)
@touch LLfiles
@if [ -f Lncor.c ] ; then : ; else touch Lncor.c ; fi
hfiles: Parameters $(SRC_DIR)/make.hfiles
$(SRC_DIR)/make.hfiles Parameters
touch hfiles
tokenfile.g: $(SRC_DIR)/tokenname.c $(SRC_DIR)/make.tokfile
$(SRC_DIR)/make.tokfile <$(SRC_DIR)/tokenname.c >tokenfile.g
symbol2str.c: $(SRC_DIR)/tokenname.c $(SRC_DIR)/make.tokcase
$(SRC_DIR)/make.tokcase <$(SRC_DIR)/tokenname.c >symbol2str.c
def.h: $(SRC_DIR)/make.allocd $(SRC_DIR)/def.H
$(SRC_DIR)/make.allocd < $(SRC_DIR)/def.H > def.h
type.h: $(SRC_DIR)/make.allocd $(SRC_DIR)/type.H
$(SRC_DIR)/make.allocd < $(SRC_DIR)/type.H > type.h
real.h: $(SRC_DIR)/make.allocd $(SRC_DIR)/real.H
$(SRC_DIR)/make.allocd < $(SRC_DIR)/real.H > real.h
node.h: $(SRC_DIR)/make.allocd $(SRC_DIR)/node.H
$(SRC_DIR)/make.allocd < $(SRC_DIR)/node.H > node.h
scope.c: $(SRC_DIR)/make.allocd $(SRC_DIR)/scope.C
$(SRC_DIR)/make.allocd < $(SRC_DIR)/scope.C > scope.c
tmpvar.c: $(SRC_DIR)/make.allocd $(SRC_DIR)/tmpvar.C
$(SRC_DIR)/make.allocd < $(SRC_DIR)/tmpvar.C > tmpvar.c
casestat.c: $(SRC_DIR)/make.allocd $(SRC_DIR)/casestat.C
$(SRC_DIR)/make.allocd < $(SRC_DIR)/casestat.C > casestat.c
next.c: $(NEXTFILES) $(SRC_DIR)/make.next
$(SRC_DIR)/make.next $(NEXTFILES) > next.c
char.c: $(SRC_DIR)/char.tab
$(TABGEN) -f$(SRC_DIR)/char.tab >char.c

19
lang/m2/comp/real.H
View File

@@ -1,19 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* R E A L C O N S T A N T D E S C R I P T O R D E F I N I T I O N */
/* $Id$ */
#include <flt_arith.h>
struct real {
char *r_real;
flt_arith r_val;
};
/* ALLOCDEF "real" 20 */

218
lang/m2/comp/scope.C
View File

@@ -1,218 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* S C O P E M E C H A N I S M */
/* $Id$ */
#include "debug.h"
#include <assert.h>
#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"
t_scope *PervasiveScope;
t_scopelist *CurrVis, *GlobalVis;
extern int proclevel;
extern char options[];
/* STATICALLOCDEF "scope" 10 */
/* STATICALLOCDEF "scopelist" 10 */
static int sc_count;
open_scope(scopetype)
{
/* Open a scope that is either open (automatic imports) or closed.
*/
register t_scope *sc = new_scope();
register t_scopelist *ls = new_scopelist();
assert(scopetype == OPENSCOPE || scopetype == CLOSEDSCOPE);
sc->sc_scopeclosed = scopetype == CLOSEDSCOPE;
sc->sc_level = proclevel;
ls->sc_scope = sc;
ls->sc_encl = CurrVis;
if (! sc->sc_scopeclosed) {
ls->sc_next = ls->sc_encl;
}
ls->sc_count = sc_count++;
CurrVis = ls;
}
t_scope *
open_and_close_scope(scopetype)
{
t_scope *sc;
open_scope(scopetype);
sc = CurrentScope;
close_scope(0);
return sc;
}
InitScope()
{
register t_scope *sc = new_scope();
register t_scopelist *ls = new_scopelist();
sc->sc_level = proclevel;
PervasiveScope = sc;
ls->sc_scope = PervasiveScope;
CurrVis = ls;
}
STATIC
chk_proc(df)
register t_def *df;
{
/* Called at scope closing. Check all definitions, and if one
is a D_PROCHEAD, the procedure was not defined.
Also check that hidden types are defined.
*/
while (df) {
if (df->df_kind == D_HIDDEN) {
error("hidden type \"%s\" not declared",
df->df_idf->id_text);
}
else if (df->df_kind == D_PROCHEAD) {
/* A not defined procedure
*/
error("procedure \"%s\" not defined",
df->df_idf->id_text);
FreeNode(df->for_node);
}
df = df->df_nextinscope;
}
}
STATIC
chk_forw(pdf)
t_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.
*/
register t_def *df;
while (df = *pdf) {
if (df->df_kind == D_FORWTYPE) {
pdf = &df->df_nextinscope;
ForceForwardTypeDef(df); /* removes df */
continue;
}
if (df->df_kind & (D_FORWARD|D_FORWMODULE)) {
/* These definitions must be found in
the enclosing closed scope, which of course
may be the scope that is now closed!
*/
if (scopeclosed(CurrentScope)) {
/* Indeed, the scope was a closed
scope, so give error message
*/
node_error(df->for_node, "identifier \"%s\" not declared",
df->df_idf->id_text);
}
else {
/* This scope was an open scope.
Maybe the definitions are in the
enclosing scope?
*/
register t_scopelist *ls =
nextvisible(CurrVis);
register t_def *df1 = lookup(df->df_idf, ls->sc_scope, 0, 0);
*pdf = df->df_nextinscope;
if (! df1) {
if (df->df_kind == D_FORWMODULE) {
df->for_vis->sc_next = ls;
}
df->df_nextinscope = ls->sc_scope->sc_def;
ls->sc_scope->sc_def = df;
df->df_scope = ls->sc_scope;
continue;
}
/* leave it like this ??? */
}
FreeNode(df->for_node);
}
pdf = &df->df_nextinscope;
}
}
Reverse(pdf)
t_def **pdf;
{
/* Reverse the order in the list of definitions in a scope.
This is neccesary because this list is built in reverse.
Also, while we're at it, remove uninteresting definitions
from this list.
*/
register t_def *df, *df1;
#define INTERESTING (D_MODULE|D_PROCEDURE|D_PROCHEAD|D_VARIABLE|D_IMPORTED|D_TYPE|D_CONST|D_FIELD)
df = 0;
df1 = *pdf;
while (df1) {
if (df1->df_kind & INTERESTING) {
t_def *prev = df;
df = df1;
df1 = df1->df_nextinscope;
df->df_nextinscope = prev;
}
else df1 = df1->df_nextinscope;
}
*pdf = df;
}
close_scope(flag)
register int flag;
{
/* Close a scope. If "flag" is set, check for forward declarations,
either POINTER declarations, or EXPORTs, or forward references
to MODULES
*/
register t_scope *sc = CurrentScope;
assert(sc != 0);
FreeNode(sc->sc_end);
sc->sc_end = dot2leaf(Link);
if (flag) {
DO_DEBUG(options['S'],(print("List of definitions in currently ended scope:\n"), DumpScope(sc->sc_def)));
if (flag & SC_CHKPROC) chk_proc(sc->sc_def);
if (flag & SC_CHKFORW) chk_forw(&(sc->sc_def));
if (flag & SC_REVERSE) Reverse(&(sc->sc_def));
}
CurrVis = enclosing(CurrVis);
}
#ifdef DEBUG
DumpScope(df)
register t_def *df;
{
while (df) {
PrDef(df);
df = df->df_nextinscope;
}
}
#endif

61
lang/m2/comp/scope.h
View File

@@ -1,61 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* S C O P E M E C H A N I S M */
/* $Id$ */
#define OPENSCOPE 0 /* Indicating an open scope */
#define CLOSEDSCOPE 1 /* Indicating a closed scope (module) */
#define SC_CHKFORW 1 /* Check for forward definitions when closing
a scope
*/
#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; */
char *sc_name; /* name of this scope */
struct def *sc_def; /* list of definitions in this scope */
arith sc_off; /* offsets of variables in this scope */
char sc_scopeclosed; /* flag indicating closed or open scope */
char sc_defmodule; /* flag set is this scope is from a separate
definition module
*/
int sc_level; /* level of this scope */
struct def *sc_definedby; /* The def structure defining this scope */
struct node *sc_end; /* node to remember line number of end of scope */
};
struct scopelist {
struct scopelist *sc_next;
struct scope *sc_scope;
struct scopelist *sc_encl;
int sc_count;
};
typedef struct scope t_scope;
typedef struct scopelist t_scopelist;
extern t_scope
*PervasiveScope;
extern t_scopelist
*CurrVis, *GlobalVis;
#define CurrentScope (CurrVis->sc_scope)
#define GlobalScope (GlobalVis->sc_scope)
#define enclosing(x) ((x)->sc_encl)
#define scopeclosed(x) ((x)->sc_scopeclosed)
#define nextvisible(x) ((x)->sc_next) /* use with scopelists */
t_scope *open_and_close_scope();

447
lang/m2/comp/stab.c
View File

@@ -1,447 +0,0 @@
/*
* (c) copyright 1990 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* D E B U G G E R S Y M B O L T A B L E */
/* $Id$ */
#include "dbsymtab.h"
#ifdef DBSYMTAB
#include <alloc.h>
#include <em_arith.h>
#include <em_label.h>
#include <em_code.h>
#include <flt_arith.h>
#include <stb.h>
#include "LLlex.h"
#include "def.h"
#include "type.h"
#include "idf.h"
#include "scope.h"
#include "main.h"
extern int gdb_flag;
#define INCR_SIZE 64
extern int proclevel;
extern char *sprint();
static struct db_str {
unsigned sz;
char *base;
char *currpos;
} db_str;
static
create_db_str()
{
if (! db_str.base) {
db_str.base = Malloc(INCR_SIZE);
db_str.sz = INCR_SIZE;
}
db_str.currpos = db_str.base;
}
static
addc_db_str(c)
int c;
{
int df = db_str.currpos - db_str.base;
if (df >= db_str.sz-1) {
db_str.sz += INCR_SIZE;
db_str.base = Realloc(db_str.base, db_str.sz);
db_str.currpos = db_str.base + df;
}
*db_str.currpos++ = c;
*db_str.currpos = '\0';
}
static
adds_db_str(s)
char *s;
{
while (*s) addc_db_str(*s++);
}
static
stb_type(tp, assign_num)
register t_type *tp;
{
char buf[128];
static int stb_count;
if (tp->tp_dbindex > 0) {
adds_db_str(sprint(buf, "%d", tp->tp_dbindex));
return;
}
if (tp->tp_dbindex < 0) {
if (tp->tp_next == 0) {
adds_db_str(sprint(buf, "%d", -tp->tp_dbindex));
return;
}
tp->tp_dbindex = -tp->tp_dbindex;
}
if (tp->tp_dbindex == 0 && assign_num) {
tp->tp_dbindex = ++stb_count;
}
if (tp->tp_dbindex > 0) {
adds_db_str(sprint(buf, "%d=", tp->tp_dbindex));
}
if (tp == void_type) {
adds_db_str(sprint(buf, "%d", tp->tp_dbindex));
return;
}
switch(tp->tp_fund) {
/* simple types ... */
case T_INTEGER:
adds_db_str(sprint(buf,
"r%d;%ld;%ld",
tp->tp_dbindex,
(long) min_int[(int)tp->tp_size],
(long) max_int[(int)tp->tp_size]));
break;
case T_CARDINAL:
adds_db_str(sprint(buf,
"r%d;0;-1",
tp->tp_dbindex));
break;
case T_REAL:
adds_db_str(sprint(buf,
"r%d;%ld;0",
tp->tp_dbindex,
(long)tp->tp_size));
break;
case T_CHAR:
adds_db_str(sprint(buf,
"r%d;0;255",
tp->tp_dbindex));
break;
case T_WORD:
if (tp->tp_size == word_size) {
adds_db_str(sprint(buf,
"r%d;0;-1",
tp->tp_dbindex));
}
else {
adds_db_str(sprint(buf,
"r%d;0;255",
tp->tp_dbindex));
}
break;
/* constructed types ... */
case T_SUBRANGE:
adds_db_str(sprint(buf,
"r%d;%ld;%ld",
tp->tp_next->tp_dbindex,
(long) tp->sub_lb,
(long) tp->sub_ub));
break;
case T_EQUAL:
stb_type(tp->tp_next, 0);
if (tp->tp_dbindex < 0) tp->tp_dbindex = -tp->tp_dbindex;
break;
case T_HIDDEN:
if (DefinitionModule && CurrVis == Defined->mod_vis) {
tp->tp_dbindex = - ++stb_count;
adds_db_str(sprint(buf, "%d", -tp->tp_dbindex));
}
else {
/* ??? what to do here??? */
addc_db_str('*');
stb_type(void_type, 0);
/* ??? this certainly is not correct */
}
break;
case T_POINTER:
if (tp->tp_next) {
addc_db_str('*');
stb_type(tp->tp_next, 0);
if (tp->tp_dbindex < 0) tp->tp_dbindex = -tp->tp_dbindex;
}
else {
tp->tp_dbindex = - ++stb_count;
adds_db_str(sprint(buf, "%d", -tp->tp_dbindex));
}
break;
case T_SET:
addc_db_str('S');
stb_type(tp->tp_next, 0);
adds_db_str(sprint(buf, ";%ld;%ld;", tp->tp_size, tp->set_low));
break;
case T_ARRAY:
addc_db_str('a');
if (IsConformantArray(tp)) {
addc_db_str('r');
stb_type(tp->tp_next, 0);
adds_db_str(sprint(buf, ";0;A%ld", tp->arr_high));
}
else {
stb_type(tp->tp_next, 0);
}
addc_db_str(';');
stb_type(tp->arr_elem, 0);
break;
case T_ENUMERATION:
addc_db_str('e');
{
register struct def *edef = tp->enm_enums;
while (edef) {
adds_db_str(sprint(buf, "%s:%ld,",
edef->df_idf->id_text,
edef->enm_val));
edef = edef->enm_next;
}
}
addc_db_str(';');
break;
case T_RECORD:
adds_db_str(sprint(buf, "s%ld", tp->tp_size));
{
register struct def *sdef = tp->rec_scope->sc_def;
while (sdef) {
adds_db_str(sdef->df_idf->id_text);
addc_db_str(':');
stb_type(sdef->df_type, 0);
adds_db_str(sprint(buf,
",%ld,%ld;",
sdef->fld_off*8,
sdef->df_type->tp_size*8));
sdef = sdef->df_nextinscope;
}
}
addc_db_str(';');
break;
case T_PROCEDURE:
if (gdb_flag) {
addc_db_str('f');
stb_type(tp->tp_next ? tp->tp_next : void_type, 0);
break;
}
addc_db_str('Q');
stb_type(tp->tp_next ? tp->tp_next : void_type, 0);
{
register struct paramlist *p = tp->prc_params;
int paramcount = 0;
while (p) {
paramcount++;
p = p->par_next;
}
adds_db_str(sprint(buf, ",%d;", paramcount));
p = tp->prc_params;
while (p) {
addc_db_str(IsVarParam(p)
? 'v'
: IsConformantArray(TypeOfParam(p))
? 'i'
: 'p');
stb_type(TypeOfParam(p), 0);
addc_db_str(';');
p = p->par_next;
}
}
}
}
stb_addtp(s, tp)
char *s;
t_type *tp;
{
create_db_str();
adds_db_str(s);
addc_db_str(':');
addc_db_str('t');
stb_type(tp, 1);
addc_db_str(';');
C_ms_stb_cst(db_str.base,
N_LSYM,
tp == void_type || tp->tp_size >= max_int[2]
? 0
: (int)tp->tp_size,
(arith) 0);
}
stb_string(df, kind)
register t_def *df;
{
register t_type *tp = df->df_type;
char buf[64];
create_db_str();
adds_db_str(df->df_idf->id_text);
addc_db_str(':');
switch(kind) {
case D_MODULE:
if (gdb_flag) {
addc_db_str('F');
stb_type(void_type, 0);
}
else {
adds_db_str(sprint(buf, "M%d;", df->mod_vis->sc_count));
}
C_ms_stb_pnam(db_str.base, N_FUN, gdb_flag ? 0 : proclevel, df->mod_vis->sc_scope->sc_name);
break;
case D_PROCEDURE:
if (gdb_flag) {
addc_db_str('f');
}
else adds_db_str(sprint(buf, "Q%d;", df->prc_vis->sc_count));
stb_type(tp->tp_next ? tp->tp_next : void_type, 0);
if (gdb_flag) {
t_scopelist *sc = df->prc_vis;
sc = enclosing(sc);
while (sc) {
t_def *d = sc->sc_scope->sc_definedby;
if (d && d->df_kind == D_PROCEDURE) {
adds_db_str(sprint(buf, ",%s", d->df_idf->id_text));
break;
}
sc = enclosing(sc);
}
}
else addc_db_str(';');
C_ms_stb_pnam(db_str.base, N_FUN, gdb_flag ? 0 : proclevel, df->prc_vis->sc_scope->sc_name);
break;
case D_END:
if (gdb_flag) break;
adds_db_str(sprint(buf, "E%d;", df->mod_vis->sc_count));
C_ms_stb_cst(db_str.base, N_SCOPE, proclevel, (arith) 0);
break;
case D_PEND:
if (gdb_flag) break;
adds_db_str(sprint(buf, "E%d;", df->prc_vis->sc_count));
C_ms_stb_cst(db_str.base, N_SCOPE, proclevel, (arith) 0);
break;
case D_VARIABLE:
if (DefinitionModule && CurrVis != Defined->mod_vis) break;
if (df->df_flags & D_VARPAR) { /* VAR parameter */
addc_db_str('v');
stb_type(tp, 0);
addc_db_str(';');
C_ms_stb_cst(db_str.base, N_PSYM, 0, df->var_off);
}
else if (df->df_flags & D_VALPAR) { /* value parameter */
addc_db_str(IsConformantArray(tp)
? 'i'
: 'p');
stb_type(tp, 0);
addc_db_str(';');
C_ms_stb_cst(db_str.base, N_PSYM, 0, df->var_off);
}
else if (!proclevel ||
(df->df_flags & D_ADDRGIVEN)) { /* global */
int knd = N_LCSYM;
if (df->df_flags & D_EXPORTED) {
knd = N_GSYM;
addc_db_str('G');
}
else {
addc_db_str('S');
}
stb_type(tp, 0);
addc_db_str(';');
if (df->df_flags & D_ADDRGIVEN) {
C_ms_stb_cst(db_str.base, knd, 0, df->var_off);
}
else {
C_ms_stb_dnam(db_str.base, knd, 0, df->var_name, (arith) 0);
}
}
else { /* local variable */
stb_type(tp, 1); /* assign type num to avoid
difficult to parse string */
addc_db_str(';');
C_ms_stb_cst(db_str.base, N_LSYM, 0, df->var_off);
}
break;
case D_TYPE:
addc_db_str('t');
stb_type(tp, 1);
addc_db_str(';');
C_ms_stb_cst(db_str.base,
N_LSYM,
tp == void_type || tp->tp_size >= max_int[2]
? 0
: (int)tp->tp_size,
(arith) 0);
break;
case D_CONST:
if (DefinitionModule && CurrVis != Defined->mod_vis) break;
addc_db_str('c');
addc_db_str('=');
tp = BaseType(tp);
switch(tp->tp_fund) {
case T_INTEGER:
case T_INTORCARD:
case T_CARDINAL:
case T_WORD:
case T_POINTER:
case T_PROCEDURE:
adds_db_str(sprint(buf, "i%ld;", df->con_const.TOK_INT));
break;
case T_CHAR:
adds_db_str(sprint(buf, "c%ld;", df->con_const.TOK_INT));
break;
case T_REAL:
addc_db_str('r');
if (! df->con_const.TOK_RSTR) {
char buf2[FLT_STRLEN];
flt_flt2str(&df->con_const.TOK_RVAL, buf2, FLT_STRLEN);
adds_db_str(buf2);
}
else adds_db_str(df->con_const.TOK_RSTR);
addc_db_str(';');
break;
case T_STRING: {
register char *p = df->con_const.TOK_STR;
adds_db_str("s'");
while (*p) {
if (*p == '\'' || *p == '\\') {
addc_db_str('\\');
}
addc_db_str(*p++);
}
adds_db_str("';");
}
break;
case T_ENUMERATION:
addc_db_str('e');
stb_type(tp, 0);
adds_db_str(sprint(buf, ",%ld;", df->con_const.TOK_INT));
break;
case T_SET: {
register int i;
addc_db_str('S');
stb_type(tp, 0);
for (i = 0; i < tp->tp_size; i++) {
adds_db_str(sprint(buf, ",%ld",
(df->con_const.tk_data.tk_set[i/(int) word_size] >> (8*(i%(int)word_size)))&0377));
}
addc_db_str(';');
}
break;
}
C_ms_stb_cst(db_str.base,
N_LSYM,
tp->tp_size < max_int[2] ? (int)tp->tp_size : 0,
(arith) 0);
break;
}
}
#endif /* DBSYMTAB */

41
lang/m2/comp/standards.h
View File

@@ -1,41 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* S T A N D A R D P R O C E D U R E S A N D F U N C T I O N S */
/* $Id$ */
#define S_ABS 1
#define S_CAP 2
#define S_CHR 3
#define S_DEC 4
#define S_EXCL 5
#define S_FLOAT 6
#define S_HALT 7
#define S_HIGH 8
#define S_INC 9
#define S_INCL 10
#define S_MAX 11
#define S_MIN 12
#define S_ODD 13
#define S_ORD 14
#define S_SIZE 15
#define S_TRUNC 16
#define S_VAL 17
#define S_NEW 18
#define S_DISPOSE 19
#define S_LONG 20
#define S_SHORT 21
#define S_TRUNCD 22
#define S_FLOATD 23
/* Standard procedures and functions defined in the SYSTEM module ... */
#define S_ADR 50
#define S_TSIZE 51
#define S_NEWPROCESS 52
#define S_TRANSFER 53

291
lang/m2/comp/statement.g
View File

@@ -1,291 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* S T A T E M E N T S */
/* $Id$ */
{
#include <assert.h>
#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 t_node *EmptyStatement;
}
statement(register t_node **pnd;)
{
register t_node *nd;
extern int return_occurred;
} :
/*
* This part is not in the reference grammar. The reference grammar
* states : assignment | ProcedureCall | ...
* but this gives LL(1) conflicts
*/
designator(pnd)
[ { nd = dot2node(Stat, *pnd, NULLNODE);
nd->nd_symb = '(';
nd->nd_lineno = (*pnd)->nd_lineno;
}
ActualParameters(&(nd->nd_RIGHT))?
|
[ BECOMES
| %erroneous '='
{ error("':=' expected instead of '='");
DOT = BECOMES;
}
]
{ nd = dot2node(Stat, *pnd, NULLNODE); }
expression(&(nd->nd_RIGHT))
]
{ *pnd = nd; }
/*
* end of changed part
*/
|
IfStatement(pnd)
|
CaseStatement(pnd)
|
WHILE { *pnd = nd = dot2leaf(Stat); }
expression(&(nd->nd_LEFT))
DO
StatementSequence(&(nd->nd_RIGHT))
END
|
REPEAT { *pnd = nd = dot2leaf(Stat); }
StatementSequence(&(nd->nd_LEFT))
UNTIL
expression(&(nd->nd_RIGHT))
|
{ loopcount++; }
LOOP { *pnd = nd = dot2leaf(Stat); }
StatementSequence(&((*pnd)->nd_RIGHT))
END
{ loopcount--; }
|
ForStatement(pnd)
|
WITH { *pnd = nd = dot2leaf(Stat); }
designator(&(nd->nd_LEFT))
DO
StatementSequence(&(nd->nd_RIGHT))
END
|
EXIT
{ if (!loopcount) error("EXIT not in a LOOP");
*pnd = dot2leaf(Stat);
}
|
ReturnStatement(pnd)
{ return_occurred = 1; }
|
/* empty */ { *pnd = EmptyStatement; }
;
/*
* The next two rules in-line in "Statement", because of an LL(1) conflict
assignment:
designator BECOMES expression
;
ProcedureCall:
designator ActualParameters?
;
*/
StatementSequence(register t_node **pnd;)
{
t_node *nd;
register t_node *nd1;
} :
statement(pnd)
[ %persistent
';'
statement(&nd)
{ if (nd != EmptyStatement) {
nd1 = dot2node(Link, *pnd, nd);
*pnd = nd1;
nd1->nd_symb = ';';
pnd = &(nd1->nd_RIGHT);
}
}
]*
;
IfStatement(t_node **pnd;)
{
register t_node *nd;
} :
IF { nd = dot2leaf(Stat);
*pnd = nd;
}
expression(&(nd->nd_LEFT))
THEN { nd->nd_RIGHT = dot2leaf(Link);
nd = nd->nd_RIGHT;
}
StatementSequence(&(nd->nd_LEFT))
[
ELSIF { nd->nd_RIGHT = dot2leaf(Stat);
nd = nd->nd_RIGHT;
nd->nd_symb = IF;
}
expression(&(nd->nd_LEFT))
THEN { nd->nd_RIGHT = dot2leaf(Link);
nd = nd->nd_RIGHT;
}
StatementSequence(&(nd->nd_LEFT))
]*
[
ELSE
StatementSequence(&(nd->nd_RIGHT))
|
]
END
;
CaseStatement(t_node **pnd;)
{
register t_node *nd;
t_type *tp = 0;
} :
CASE { *pnd = nd = dot2leaf(Stat); }
expression(&(nd->nd_LEFT))
OF
case(&(nd->nd_RIGHT), &tp)
{ nd = nd->nd_RIGHT; }
[
'|'
case(&(nd->nd_RIGHT), &tp)
{ nd = nd->nd_RIGHT; }
]*
[ ELSE StatementSequence(&(nd->nd_RIGHT))
|
]
END
;
case(t_node **pnd; t_type **ptp;) :
[ CaseLabelList(ptp, pnd)
':' { *pnd = dot2node(Link, *pnd, NULLNODE); }
StatementSequence(&((*pnd)->nd_RIGHT))
|
]
{ *pnd = dot2node(Link, *pnd, NULLNODE);
(*pnd)->nd_symb = '|';
}
;
/* inline in statement; lack of space
WhileStatement(t_node **pnd;)
{
register t_node *nd;
}:
WHILE { *pnd = nd = dot2leaf(Stat); }
expression(&(nd->nd_LEFT))
DO
StatementSequence(&(nd->nd_RIGHT))
END
;
RepeatStatement(t_node **pnd;)
{
register t_node *nd;
}:
REPEAT { *pnd = nd = dot2leaf(Stat); }
StatementSequence(&(nd->nd_LEFT))
UNTIL
expression(&(nd->nd_RIGHT))
;
*/
ForStatement(t_node **pnd;)
{
register t_node *nd, *nd1;
}:
FOR { *pnd = nd = dot2leaf(Stat); }
IDENT { nd1 = dot2leaf(Name); }
BECOMES { nd->nd_LEFT = dot2node(Stat, nd1, dot2leaf(Link));
nd1 = nd->nd_LEFT->nd_RIGHT;
nd1->nd_symb = TO;
}
expression(&(nd1->nd_LEFT))
TO
expression(&(nd1->nd_RIGHT))
{ nd->nd_RIGHT = nd1 = dot2leaf(Link);
nd1->nd_symb = BY;
}
[
BY
ConstExpression(&(nd1->nd_LEFT))
{ if (!(nd1->nd_LEFT->nd_type->tp_fund & T_INTORCARD)) {
error("illegal type in BY clause");
}
}
|
{ nd1->nd_LEFT = dot2leaf(Value);
nd1->nd_LEFT->nd_INT = 1;
}
]
DO
StatementSequence(&(nd1->nd_RIGHT))
END
;
/* inline in Statement; lack of space
LoopStatement(t_node **pnd;):
LOOP { *pnd = dot2leaf(Stat); }
StatementSequence(&((*pnd)->nd_RIGHT))
END
;
WithStatement(t_node **pnd;)
{
register t_node *nd;
}:
WITH { *pnd = nd = dot2leaf(Stat); }
designator(&(nd->nd_LEFT))
DO
StatementSequence(&(nd->nd_RIGHT))
END
;
*/
ReturnStatement(t_node **pnd;)
{
register t_def *df = CurrentScope->sc_definedby;
register t_type *tp = df->df_type ? ResultType(df->df_type) : 0;
register t_node *nd;
} :
RETURN { *pnd = nd = dot2leaf(Stat); }
[
expression(&(nd->nd_RIGHT))
{ if (scopeclosed(CurrentScope)) {
error("a module body cannot return a value");
}
else if (! tp) {
error("procedure \"%s\" is not a function, so cannot return a value", df->df_idf->id_text);
}
}
|
{ if (tp) {
error("function procedure \"%s\" must return a value", df->df_idf->id_text);
}
}
]
;

295
lang/m2/comp/tab.c
View File

@@ -1,295 +0,0 @@
/* @cc tab.c -o $INSTALLDIR/tab@
tab - table generator
Author: Erik Baalbergen (..tjalk!erikb)
*/
#include <stdio.h>
static char *RcsId = "$Header$";
#define MAXTAB 10000
#define MAXBUF 10000
#define COMCOM '-'
#define FILECOM '%'
int InputForm = 'c';
char OutputForm[MAXBUF] = "%s,\n";
int TabSize = 257;
char *Table[MAXTAB];
char *Name;
char *ProgCall;
main(argc, argv)
char *argv[];
{
ProgCall = *argv++;
argc--;
while (argc-- > 0) {
if (**argv == COMCOM) {
option(*argv++);
}
else {
process(*argv++, InputForm);
}
}
}
char *
Salloc(s)
char *s;
{
char *malloc();
char *ns = malloc(strlen(s) + 1);
if (ns) {
strcpy(ns, s);
}
return ns;
}
option(str)
char *str;
{
/* note that *str indicates the source of the option:
either COMCOM (from command line) or FILECOM (from a file).
*/
switch (*++str) {
case ' ': /* command */
case '\t':
case '\0':
break;
case 'I':
InputForm = *++str;
break;
case 'f':
if (*++str == '\0') {
fprintf(stderr, "%s: -f: name expected\n", ProgCall);
exit(1);
}
DoFile(str);
break;
case 'F':
sprintf(OutputForm, "%s\n", ++str);
break;
case 'T':
printf("%s\n", ++str);
break;
case 'p':
PrintTable();
break;
case 'C':
ClearTable();
break;
case 'S':
{
register i = stoi(++str);
if (i <= 0 || i > MAXTAB) {
fprintf(stderr, "%s: size would exceed maximum\n",
ProgCall);
}
else {
TabSize = i;
}
break;
}
default:
fprintf(stderr, "%s: bad option -%s\n", ProgCall, str);
}
}
ClearTable()
{
register i;
for (i = 0; i < MAXTAB; i++) {
Table[i] = 0;
}
}
PrintTable()
{
register i;
for (i = 0; i < TabSize; i++) {
if (Table[i]) {
printf(OutputForm, Table[i]);
}
else {
printf(OutputForm, "0");
}
}
}
process(str, format)
char *str;
{
char *cstr = str;
char *Name = cstr; /* overwrite original string! */
/* strip of the entry name
*/
while (*str && *str != ':') {
if (*str == '\\') {
++str;
}
*cstr++ = *str++;
}
if (*str != ':') {
fprintf(stderr, "%s: bad specification: \"%s\", ignored\n",
ProgCall, Name);
return 0;
}
*cstr = '\0';
str++;
switch (format) {
case 'c':
return c_proc(str, Name);
default:
fprintf(stderr, "%s: bad input format\n", ProgCall);
}
return 0;
}
c_proc(str, Name)
char *str;
char *Name;
{
int ch, ch2;
int quoted();
while (*str) {
if (*str == '\\') {
ch = quoted(&str);
}
else {
ch = *str++;
}
if (*str == '-') {
if (*++str == '\\') {
ch2 = quoted(&str);
}
else {
if (ch2 = *str++);
else str--;
}
if (ch > ch2) {
fprintf(stderr, "%s: bad range\n", ProgCall);
return 0;
}
if (ch >= 0 && ch2 <= 255)
while (ch <= ch2)
Table[ch++] = Salloc(Name);
}
else {
if (ch >= 0 && ch <= 255)
Table[ch] = Salloc(Name);
}
}
return 1;
}
int
quoted(pstr)
char **pstr;
{
register int ch;
register int i;
register char *str = *pstr;
if ((*++str >= '0') && (*str <= '9')) {
ch = 0;
for (i = 0; i < 3; i++) {
ch = 8 * ch + *str - '0';
if (*++str < '0' || *str > '9')
break;
}
}
else {
switch (*str++) {
case 'n':
ch = '\n';
break;
case 't':
ch = '\t';
break;
case 'b':
ch = '\b';
break;
case 'r':
ch = '\r';
break;
case 'f':
ch = '\f';
break;
default :
ch = *str;
}
}
*pstr = str;
return ch & 0377;
}
int
stoi(str)
char *str;
{
register i = 0;
while (*str >= '0' && *str <= '9') {
i = i * 10 + *str++ - '0';
}
return i;
}
char *
getline(s, n, fp)
char *s;
FILE *fp;
{
register c = getc(fp);
char *str = s;
while (n--) {
if (c == EOF) {
return NULL;
}
else
if (c == '\n') {
*str++ = '\0';
return s;
}
*str++ = c;
c = getc(fp);
}
s[n - 1] = '\0';
return s;
}
#define BUFSIZE 1024
DoFile(name)
char *name;
{
char text[BUFSIZE];
FILE *fp;
if ((fp = fopen(name, "r")) == NULL) {
fprintf(stderr, "%s: cannot read file %s\n", ProgCall, name);
exit(1);
}
while (getline(text, BUFSIZE, fp) != NULL) {
if (text[0] == FILECOM) {
option(text);
}
else {
process(text, InputForm);
}
}
}

138
lang/m2/comp/tmpvar.C
View File

@@ -1,138 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* T E M P O R A R Y V A R I A B L E S */
/* $Id$ */
/* Code for the allocation and de-allocation of temporary variables,
allowing re-use.
The routines use "ProcScope" instead of "CurrentScope", because
"CurrentScope" also reflects WITH statements, and these scopes do not
have local variabes.
*/
#include "debug.h"
#include <em_arith.h>
#include <em_label.h>
#include <em_code.h>
#include <em_reg.h>
#include <alloc.h>
#include <assert.h>
#include "LLlex.h"
#include "def.h"
#include "type.h"
#include "scope.h"
#include "main.h"
struct tmpvar {
struct tmpvar *t_next;
arith t_offset; /* offset from LocalBase */
};
/* STATICALLOCDEF "tmpvar" 10 */
static struct tmpvar *TmpInts, /* for integer temporaries */
*TmpPtrs; /* for pointer temporaries */
static t_scope *ProcScope; /* scope of procedure in which the
temporaries are allocated
*/
TmpOpen(sc) t_scope *sc;
{
/* Initialize for temporaries in scope "sc".
*/
ProcScope = sc;
}
arith
TmpSpace(sz, al)
arith sz;
{
register t_scope *sc = ProcScope;
sc->sc_off = - WA(align(sz - sc->sc_off, al));
return sc->sc_off;
}
STATIC arith
NewTmp(plist, sz, al, regtype)
register struct tmpvar **plist;
arith sz;
{
register arith offset;
register struct tmpvar *tmp;
if (!*plist) {
offset = TmpSpace(sz, al);
if (! options['n']) C_ms_reg(offset, sz, regtype, 0);
}
else {
tmp = *plist;
offset = tmp->t_offset;
*plist = tmp->t_next;
free_tmpvar(tmp);
}
return offset;
}
arith
NewInt()
{
return NewTmp(&TmpInts, int_size, int_align, reg_any);
}
arith
NewPtr()
{
return NewTmp(&TmpPtrs, pointer_size, pointer_align, reg_pointer);
}
STATIC
FreeTmp(plist, off)
struct tmpvar **plist;
arith off;
{
register struct tmpvar *tmp = new_tmpvar();
tmp->t_next = *plist;
tmp->t_offset = off;
*plist = tmp;
}
FreeInt(off)
arith off;
{
FreeTmp(&TmpInts, off);
}
FreePtr(off)
arith off;
{
FreeTmp(&TmpPtrs, off);
}
TmpClose()
{
register struct tmpvar *tmp, *tmp1;
tmp = TmpInts;
while (tmp) {
tmp1 = tmp;
tmp = tmp->t_next;
free_tmpvar(tmp1);
}
tmp = TmpPtrs;
while (tmp) {
tmp1 = tmp;
tmp = tmp->t_next;
free_tmpvar(tmp1);
}
TmpInts = TmpPtrs = 0;
}

114
lang/m2/comp/tokenname.c
View File

@@ -1,114 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* T O K E N D E F I N I T I O N S */
/* $Id$ */
#include "tokenname.h"
#include "Lpars.h"
#include "idf.h"
/* To centralize the declaration of %tokens, their presence in this
file is taken as their declaration. The Makefile will produce
a grammar file (tokenfile.g) from this file. This scheme ensures
that all tokens have a printable name.
Also, the "token2str.c" file is produced from this file.
*/
#ifdef ___XXX___
struct tokenname tkspec[] = { /* the names of the special tokens */
{IDENT, "identifier"},
{STRING, "string"},
{INTEGER, "number"},
{REAL, "real"},
{0, ""}
};
struct tokenname tkcomp[] = { /* names of the composite tokens */
{LESSEQUAL, "<="},
{GREATEREQUAL, ">="},
{UPTO, ".."},
{BECOMES, ":="},
{0, ""}
};
#endif
struct tokenname tkidf[] = { /* names of the identifier tokens */
{AND, "AND"},
{ARRAY, "ARRAY"},
{BEGIN, "BEGIN"},
{BY, "BY"},
{CASE, "CASE"},
{CONST, "CONST"},
{DEFINITION, "DEFINITION"},
{DIV, "DIV"},
{DO, "DO"},
{ELSE, "ELSE"},
{ELSIF, "ELSIF"},
{END, "END"},
{EXIT, "EXIT"},
{EXPORT, "EXPORT"},
{FOR, "FOR"},
{FROM, "FROM"},
{IF, "IF"},
{IMPLEMENTATION, "IMPLEMENTATION"},
{IMPORT, "IMPORT"},
{IN, "IN"},
{LOOP, "LOOP"},
{MOD, "MOD"},
{MODULE, "MODULE"},
{NOT, "NOT"},
{OF, "OF"},
{OR, "OR"},
{POINTER, "POINTER"},
{PROCEDURE, "PROCEDURE"},
{QUALIFIED, "QUALIFIED"},
{RECORD, "RECORD"},
{REPEAT, "REPEAT"},
{RETURN, "RETURN"},
{SET, "SET"},
{THEN, "THEN"},
{TO, "TO"},
{TYPE, "TYPE"},
{UNTIL, "UNTIL"},
{VAR, "VAR"},
{WHILE, "WHILE"},
{WITH, "WITH"},
{0, ""}
};
#ifdef ___XXX___
struct tokenname tkinternal[] = { /* internal keywords */
{PROGRAM, ""},
{COERCION, ""},
{CAST, ""},
{0, "0"}
};
struct tokenname tkstandard[] = { /* standard identifiers */
{0, ""}
};
#endif
/* Some routines to handle tokennames */
reserve(resv)
register struct tokenname *resv;
{
/* The names of the tokens described in resv are entered
as reserved words.
*/
register t_idf *p;
while (resv->tn_symbol) {
p = str2idf(resv->tn_name, 0);
if (!p) fatal("out of Memory");
p->id_reserved = resv->tn_symbol;
resv++;
}
}

17
lang/m2/comp/tokenname.h
View File

@@ -1,17 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* T O K E N N A M E S T R U C T U R E */
/* $Id$ */
struct tokenname { /* Used for defining the name of a
token as identified by its symbol
*/
int tn_symbol;
char *tn_name;
};

246
lang/m2/comp/type.H
View File

@@ -1,246 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* T Y P E D E S C R I P T O R S T R U C T U R E */
/* $Id$ */
#include "dbsymtab.h"
struct paramlist { /* structure for parameterlist of a PROCEDURE */
struct paramlist *par_next;
struct def *par_def; /* "df" of parameter */
#define IsVarParam(xpar) ((int) ((xpar)->par_def->df_flags & D_VARPAR))
#define TypeOfParam(xpar) ((xpar)->par_def->df_type)
};
typedef struct paramlist t_param;
/* ALLOCDEF "paramlist" 20 */
struct enume {
struct def *en_enums; /* Definitions of enumeration literals */
arith en_ncst; /* Number of constants */
label en_rck; /* Label of range check descriptor */
#define enm_enums tp_value.tp_enum->en_enums
#define enm_ncst tp_value.tp_enum->en_ncst
#define enm_rck tp_value.tp_enum->en_rck
};
/* ALLOCDEF "enume" 5 */
struct subrange {
arith su_lb, su_ub; /* lower bound and upper bound */
label su_rck; /* label of range check descriptor */
#define sub_lb tp_value.tp_subrange->su_lb
#define sub_ub tp_value.tp_subrange->su_ub
#define sub_rck tp_value.tp_subrange->su_rck
};
/* ALLOCDEF "subrange" 5 */
struct array {
struct type *ar_elem; /* type of elements */
label ar_descr; /* label of array descriptor */
arith ar_elsize; /* size of elements */
arith ar_low; /* lower bound of index */
arith ar_high; /* upper bound of index */
#define arr_elem tp_value.tp_arr->ar_elem
#define arr_descr tp_value.tp_arr->ar_descr
#define arr_elsize tp_value.tp_arr->ar_elsize
#define arr_low tp_value.tp_arr->ar_low
#define arr_high tp_value.tp_arr->ar_high
};
/* ALLOCDEF "array" 5 */
struct record {
struct scope *rc_scope; /* scope of this record */
/* members are in the symbol table */
#define rec_scope tp_value.tp_record.rc_scope
};
struct proc {
struct paramlist *pr_params;
arith pr_nbpar; /* number of bytes parameters accessed */
#define prc_params tp_value.tp_proc.pr_params
#define prc_nbpar tp_value.tp_proc.pr_nbpar
};
struct set {
arith st_low; /* lowerbound of subrange type of set */
unsigned st_sz; /* size of constant set in compiler */
#define set_low tp_value.tp_set.st_low
#define set_sz tp_value.tp_set.st_sz
};
struct type {
struct type *tp_next; /* used with ARRAY, PROCEDURE, POINTER, SET,
SUBRANGE, EQUAL
*/
short tp_fund; /* fundamental type or constructor */
#define T_RECORD 0x0001
#define T_ENUMERATION 0x0002
#define T_INTEGER 0x0004
#define T_CARDINAL 0x0008
#define T_EQUAL 0x0010
#define T_REAL 0x0020
#define T_HIDDEN 0x0040
#define T_POINTER 0x0080
#define T_CHAR 0x0100
#define T_WORD 0x0200
#define T_SET 0x0400
#define T_SUBRANGE 0x0800
#define T_PROCEDURE 0x1000
#define T_ARRAY 0x2000
#define T_STRING 0x4000
#define T_INTORCARD (T_INTEGER|T_CARDINAL)
#define T_NOSUB (T_INTORCARD|T_ENUMERATION|T_CHAR)
#define T_NUMERIC (T_INTORCARD|T_REAL)
#define T_INDEX (T_ENUMERATION|T_CHAR|T_SUBRANGE)
#define T_DISCRETE (T_INDEX|T_INTORCARD)
#define T_CONSTRUCTED (T_ARRAY|T_SET|T_RECORD)
#ifdef DBSYMTAB
short tp_dbindex; /* index in debugger symbol table */
#endif
int tp_align; /* alignment requirement of this type */
arith tp_size; /* size of this type */
union {
struct enume *tp_enum;
struct subrange *tp_subrange;
struct array *tp_arr;
struct record tp_record;
struct proc tp_proc;
struct set tp_set;
} tp_value;
};
typedef struct type t_type;
/* ALLOCDEF "type" 50 */
extern t_type
*bool_type,
*char_type,
*int_type,
*card_type,
*longint_type,
*longcard_type,
*real_type,
*longreal_type,
*word_type,
*byte_type,
*address_type,
*intorcard_type,
*longintorcard_type,
*bitset_type,
*void_type,
*std_type,
*error_type; /* All from type.c */
#include "nocross.h"
#ifdef NOCROSS
#include "target_sizes.h"
#define word_align (AL_WORD)
#define short_align (AL_SHORT)
#define int_align (AL_INT)
#define long_align (AL_LONG)
#define float_align (AL_FLOAT)
#define double_align (AL_DOUBLE)
#define pointer_align (AL_POINTER)
#define struct_align (AL_STRUCT)
#define word_size (SZ_WORD)
#define dword_size (2 * SZ_WORD)
#define int_size (SZ_INT)
#define short_size (SZ_SHORT)
#define long_size (SZ_LONG)
#define float_size (SZ_FLOAT)
#define double_size (SZ_DOUBLE)
#define pointer_size (SZ_POINTER)
#define wrd_bits (8*(int)word_size)
#else /* NOCROSS */
extern int
word_align,
short_align,
int_align,
long_align,
float_align,
double_align,
pointer_align,
struct_align; /* All from type.c */
extern arith
word_size,
dword_size,
short_size,
int_size,
long_size,
float_size,
double_size,
pointer_size; /* All from type.c */
extern unsigned int
wrd_bits; /* from cstoper.c */
#endif /* NOCROSS */
extern arith
ret_area_size;
extern arith
align(); /* type.c */
extern t_type
*construct_type(),
*standard_type(),
*set_type(),
*subr_type(),
*proc_type(),
*enum_type(),
*qualified_type(),
*intorcard(),
*RemoveEqual(); /* All from type.c */
#define NULLTYPE ((t_type *) 0)
#define IsConformantArray(tpx) ((tpx)->tp_fund==T_ARRAY && (tpx)->tp_size==0)
#define bounded(tpx) ((tpx)->tp_fund & T_INDEX)
#define complex(tpx) ((tpx)->tp_fund & (T_RECORD|T_ARRAY))
#define WA(sz) (align(sz, (int) word_size))
#ifdef DEBUG
#define ResultType(tpx) (assert((tpx)->tp_fund == T_PROCEDURE),\
(tpx)->tp_next)
#define ParamList(tpx) (assert((tpx)->tp_fund == T_PROCEDURE),\
(tpx)->prc_params)
#define IndexType(tpx) (assert((tpx)->tp_fund == T_ARRAY),\
(tpx)->tp_next)
#define ElementType(tpx) (assert((tpx)->tp_fund == T_SET),\
(tpx)->tp_next)
#define PointedtoType(tpx) (assert((tpx)->tp_fund == T_POINTER),\
(tpx)->tp_next)
#define SubBaseType(tpx) (assert((tpx)->tp_fund == T_SUBRANGE), \
(tpx)->tp_next)
#else /* DEBUG */
#define ResultType(tpx) ((tpx)->tp_next)
#define ParamList(tpx) ((tpx)->prc_params)
#define IndexType(tpx) ((tpx)->tp_next)
#define ElementType(tpx) ((tpx)->tp_next)
#define PointedtoType(tpx) ((tpx)->tp_next)
#define SubBaseType(tpx) ((tpx)->tp_next)
#endif /* DEBUG */
#define BaseType(tpx) ((tpx)->tp_fund == T_SUBRANGE ? (tpx)->tp_next : \
(tpx))
#define IsConstructed(tpx) ((tpx)->tp_fund & T_CONSTRUCTED)
#define TooBigForReturnArea(tpx) ((tpx)->tp_size > ret_area_size)
extern arith full_mask[];
extern arith max_int[];
extern arith min_int[];
#define ufit(n, i) (((n) & ~full_mask[(i)]) == 0)

937
lang/m2/comp/type.c
View File

@@ -1,937 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* T Y P E D E F I N I T I O N M E C H A N I S M */
/* $Id$ */
#include "debug.h"
#include <assert.h>
#include <alloc.h>
#include <em_arith.h>
#include <em_label.h>
#include <em_code.h>
#include "nostrict.h"
#include "LLlex.h"
#include "def.h"
#include "type.h"
#include "idf.h"
#include "node.h"
#include "scope.h"
#include "walk.h"
#include "main.h"
#include "chk_expr.h"
#include "warning.h"
#include "uns_arith.h"
#ifndef NOCROSS
#include "target_sizes.h"
int
word_align = AL_WORD,
short_align = AL_SHORT,
int_align = AL_INT,
long_align = AL_LONG,
float_align = AL_FLOAT,
double_align = AL_DOUBLE,
pointer_align = AL_POINTER,
struct_align = AL_STRUCT;
arith
word_size = SZ_WORD,
dword_size = 2 * SZ_WORD,
int_size = SZ_INT,
short_size = SZ_SHORT,
long_size = SZ_LONG,
float_size = SZ_FLOAT,
double_size = SZ_DOUBLE,
pointer_size = SZ_POINTER;
#endif
#define arith_sign ((arith) (1L << (sizeof(arith) * 8 - 1)))
arith ret_area_size;
t_type
*bool_type,
*char_type,
*int_type,
*card_type,
*longint_type,
*longcard_type,
*real_type,
*longreal_type,
*word_type,
*byte_type,
*address_type,
*intorcard_type,
*longintorcard_type,
*bitset_type,
*void_type,
*std_type,
*error_type;
t_type *
construct_type(fund, tp)
int fund;
register t_type *tp;
{
/* fund must be a type constructor.
The pointer to the constructed type is returned.
*/
register t_type *dtp = new_type();
switch (dtp->tp_fund = fund) {
case T_PROCEDURE:
case T_POINTER:
case T_HIDDEN:
dtp->tp_align = pointer_align;
dtp->tp_size = pointer_size;
break;
case T_SET:
dtp->tp_align = word_align;
break;
case T_ARRAY:
dtp->tp_value.tp_arr = new_array();
dtp->tp_align = struct_align;
break;
case T_SUBRANGE:
assert(tp != 0);
dtp->tp_value.tp_subrange = new_subrange();
dtp->tp_align = tp->tp_align;
dtp->tp_size = tp->tp_size;
break;
default:
crash("funny type constructor");
}
dtp->tp_next = tp;
return dtp;
}
arith
align(pos, al)
arith pos;
int al;
{
int i = pos % al;
if (i) return pos + (al - i);
return pos;
}
t_type *
standard_type(fund, algn, size)
int fund;
int algn;
arith size;
{
register t_type *tp = new_type();
tp->tp_fund = fund;
tp->tp_align = algn;
tp->tp_size = size;
if (fund == T_ENUMERATION || fund == T_CHAR) {
tp->tp_value.tp_enum = new_enume();
}
return tp;
}
InitTypes()
{
/* Initialize the predefined types
*/
register t_type *tp;
/* first, do some checking
*/
if ((int) int_size != (int) word_size) {
fatal("integer size not equal to word size");
}
if ((int) long_size < (int) int_size) {
fatal("long integer size smaller than integer size");
}
if ((int) double_size < (int) float_size) {
fatal("long real size smaller than real size");
}
ret_area_size = (int) double_size > ((int) pointer_size << 1) ?
double_size : (pointer_size << 1);
/* character type
*/
char_type = standard_type(T_CHAR, 1, (arith) 1);
char_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);
longcard_type = standard_type(T_CARDINAL, long_align, long_size);
card_type = standard_type(T_CARDINAL, int_align, int_size);
intorcard_type = standard_type(T_INTORCARD, int_align, int_size);
longintorcard_type = standard_type(T_INTORCARD, long_align, long_size);
/* floating types
*/
real_type = standard_type(T_REAL, float_align, float_size);
longreal_type = standard_type(T_REAL, double_align, double_size);
/* SYSTEM types
*/
word_type = standard_type(T_WORD, word_align, word_size);
byte_type = standard_type(T_WORD, 1, (arith) 1);
address_type = construct_type(T_POINTER, word_type);
/* create BITSET type
TYPE BITSET = SET OF [0..W-1];
The subrange is a subrange of type cardinal, because the lower bound
is a non-negative integer (See Rep. 6.3)
*/
tp = construct_type(T_SUBRANGE, card_type);
tp->sub_lb = 0;
tp->sub_ub = (int) 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 = new_type();
*error_type = *char_type;
void_type = error_type;
}
int
fit(sz, nbytes)
arith sz;
{
return ((sz) + ((arith)0x80<<(((nbytes)-1)*8)) & ~full_mask[(nbytes)]) == 0;
}
STATIC
u_small(tp, n)
register t_type *tp;
arith n;
{
if (ufit(n, 1)) {
tp->tp_size = 1;
tp->tp_align = 1;
}
else if (ufit(n, (int)short_size)) {
tp->tp_size = short_size;
tp->tp_align = short_align;
}
}
t_type *
enum_type(EnumList)
t_node *EnumList;
{
register t_type *tp =
standard_type(T_ENUMERATION, int_align, int_size);
EnterEnumList(EnumList, tp);
if (! fit(tp->enm_ncst, (int) int_size)) {
node_error(EnumList, "too many enumeration literals");
}
u_small(tp, (arith) (tp->enm_ncst-1));
return tp;
}
t_type *
qualified_type(pnd)
t_node **pnd;
{
register t_def *df;
if (ChkDesig(pnd, D_USED)) {
register t_node *nd = *pnd;
if (nd->nd_class != Def) {
node_error(nd, "type expected");
FreeNode(nd);
return error_type;
}
df = nd->nd_def;
if (df->df_kind&(D_ISTYPE|D_FORWARD|D_FORWTYPE|D_ERROR)) {
if (! df->df_type) {
node_error(nd,"type \"%s\" not (yet) declared", df->df_idf->id_text);
FreeNode(nd);
return error_type;
}
FreeNode(nd);
if (df->df_kind == D_FORWTYPE) {
/* Here, df->df_type was already set,
so there is an actual definition in the
surrounding scope, which is now used.
*/
ForceForwardTypeDef(df);
}
return df->df_type;
}
node_error(nd, "identifier \"%s\" is not a type", df->df_idf->id_text);
}
FreeNode(*pnd);
return error_type;
}
int
chk_bounds(l1, l2, fund)
arith l1, l2;
{
/* compare to arith's, but be careful. They might be unsigned
*/
if (fund == T_INTEGER) {
return l2 >= l1;
}
#ifdef UNSIGNED_ARITH
return (UNSIGNED_ARITH) l2 >= (UNSIGNED_ARITH) l1;
#else
return (l2 & arith_sign ?
(l1 & arith_sign ? l2 >= l1 : 1) :
(l1 & arith_sign ? 0 : l2 >= l1)
);
#endif
}
int
in_range(i, tp)
arith i;
register t_type *tp;
{
/* Check that the value i fits in the subrange or enumeration
type tp. Return 1 if so, 0 otherwise
*/
switch(tp->tp_fund) {
case T_ENUMERATION:
case T_CHAR:
return i >= 0 && i < tp->enm_ncst;
case T_SUBRANGE:
return chk_bounds(i, tp->sub_ub, SubBaseType(tp)->tp_fund) &&
chk_bounds(tp->sub_lb, i, SubBaseType(tp)->tp_fund);
}
assert(0);
/*NOTREACHED*/
}
t_type *
subr_type(lb, ub, base)
register t_node *lb;
t_node *ub;
t_type *base;
{
/* Construct a subrange type from the constant expressions
indicated by "lb" and "ub", but first perform some
checks. "base" is either a user-specified base-type, or NULL.
*/
register t_type *tp = BaseType(lb->nd_type);
register t_type *res;
if (tp == intorcard_type) {
/* Lower bound >= 0; in this case, the base type is CARDINAL,
according to the language definition, par. 6.3.
But what if the upper-bound is of type INTEGER (f.i.
MAX(INTEGER)? The Report does not answer this. Fix this
for the time being, by making it an INTEGER subrange.
???
*/
assert(lb->nd_INT >= 0);
if (BaseType(ub->nd_type) == int_type ||
(base && BaseType(base) == int_type)) tp = int_type;
else tp = card_type;
}
if (!ChkCompat(&ub, tp, "subrange bounds")) {
return error_type;
}
/* Check base type
*/
if (! (tp->tp_fund & T_DISCRETE)) {
node_error(lb, "illegal base type for subrange");
return error_type;
}
/* Now construct resulting type
*/
res = construct_type(T_SUBRANGE, tp);
res->sub_lb = lb->nd_INT;
res->sub_ub = ub->nd_INT;
/* Check bounds
*/
if (! chk_bounds(lb->nd_INT, ub->nd_INT, tp->tp_fund)) {
node_error(lb, "lower bound exceeds upper bound");
ub->nd_INT = lb->nd_INT;
res->sub_ub = res->sub_lb;
}
if (tp == card_type) {
u_small(res, res->sub_ub);
}
else if (tp == int_type) {
if (fit(res->sub_lb, 1) && fit(res->sub_ub, 1)) {
res->tp_size = 1;
res->tp_align = 1;
}
else if (fit(res->sub_lb, (int)short_size) &&
fit(res->sub_ub, (int)short_size)) {
res->tp_size = short_size;
res->tp_align = short_align;
}
}
if (base) {
if (base->tp_fund == T_SUBRANGE) {
/* Check that the bounds of "res" fall within the range
of "base".
*/
if (! in_range(res->sub_lb, base) ||
! in_range(res->sub_ub, base)) {
error("base type has insufficient range");
}
base = base->tp_next;
}
if ((base->tp_fund & (T_ENUMERATION|T_CHAR)) ||
base == card_type) {
if (res->tp_next != base) {
error("specified basetype for subrange not compatible with bounds");
}
}
else if (base == int_type) {
if (res->tp_next == card_type &&
! chk_bounds(res->sub_ub,
max_int[(int)int_size],
T_CARDINAL)){
error("upperbound too large for type INTEGER");
}
}
else error("illegal base for a subrange");
res->tp_next = base;
}
return res;
}
t_type *
proc_type(result_type, parameters, n_bytes_params)
t_type *result_type;
t_param *parameters;
arith n_bytes_params;
{
register t_type *tp = construct_type(T_PROCEDURE, result_type);
tp->prc_params = parameters;
tp->prc_nbpar = n_bytes_params;
if (! fit(n_bytes_params, (int) word_size)) {
error("maximum parameter byte count exceeded");
}
if (result_type && ! fit(WA(result_type->tp_size), (int) word_size)) {
error("maximum return value size exceeded");
}
return tp;
}
genrck(tp)
register t_type *tp;
{
/* generate a range check descriptor for type "tp" when
neccessary. Return its label.
*/
arith lb, ub;
register label ol;
arith size = tp->tp_size;
extern char *long2str();
register t_type *btp = BaseType(tp);
if (size < word_size) size = word_size;
getbounds(tp, &lb, &ub);
if (tp->tp_fund == T_SUBRANGE) {
if (!(ol = tp->sub_rck)) {
tp->sub_rck = ++data_label;
}
}
else if (!(ol = tp->enm_rck)) {
tp->enm_rck = ++data_label;
}
if (!ol) {
C_df_dlb(ol = data_label);
C_rom_icon(long2str((long)lb,10), size);
C_rom_icon(long2str((long)ub,10), size);
}
c_lae_dlb(ol);
if (size <= word_size) {
CAL(btp->tp_fund == T_INTEGER ? "rcki" : "rcku", (int) pointer_size);
}
else {
CAL(btp->tp_fund == T_INTEGER ? "rckil" : "rckul", (int) pointer_size);
}
}
getbounds(tp, plo, phi)
register t_type *tp;
arith *plo, *phi;
{
/* Get the bounds of a bounded type
*/
assert(bounded(tp));
if (tp->tp_fund == T_SUBRANGE) {
*plo = tp->sub_lb;
*phi = tp->sub_ub;
}
else {
*plo = 0;
*phi = tp->enm_ncst - 1;
}
}
t_type *
set_type(tp)
register t_type *tp;
{
/* Construct a set type with base type "tp", but first
perform some checks
*/
arith lb, ub, diff, alloc_size;
if (! bounded(tp) || tp->tp_size > word_size) {
error("illegal base type for set");
return error_type;
}
getbounds(tp, &lb, &ub);
#ifndef NOSTRICT
if (lb < 0) {
warning(W_STRICT, "base type of set has negative lower bound");
}
#endif
diff = ub - lb + 1;
if (diff < 0) {
error("set type limits exceeded");
return error_type;
}
tp = construct_type(T_SET, tp);
tp->tp_size = WA((diff + 7) >> 3);
alloc_size = (tp->tp_size / word_size + 1) * sizeof(arith);
tp->set_sz = alloc_size;
if (tp->set_sz != alloc_size) {
error("set size too large");
return error_type;
}
tp->set_low = lb;
return tp;
}
ArrayElSize(tp)
register t_type *tp;
{
/* Align element size to alignment requirement of element type.
Also make sure that its size is either a dividor of the word_size,
or a multiple of it.
*/
register arith algn;
register t_type *elem_type = tp->arr_elem;
if (elem_type->tp_fund == T_ARRAY) ArraySizes(elem_type);
algn = align(elem_type->tp_size, elem_type->tp_align);
if (word_size % algn != 0) {
/* algn is not a dividor of the word size, so make sure it
is a multiple
*/
algn = WA(algn);
}
if (! fit(algn, (int) word_size)) {
error("element size of array too large");
}
tp->arr_elsize = algn;
if (tp->tp_align < elem_type->tp_align) {
tp->tp_align = elem_type->tp_align;
}
}
ArraySizes(tp)
register t_type *tp;
{
/* Assign sizes to an array type, and check index type
*/
register t_type *index_type = IndexType(tp);
arith diff;
ArrayElSize(tp);
/* check index type
*/
if (index_type->tp_size > word_size || ! bounded(index_type)) {
error("illegal index type");
tp->tp_size = tp->arr_elsize;
return;
}
getbounds(index_type, &(tp->arr_low), &(tp->arr_high));
diff = tp->arr_high - tp->arr_low;
if (diff < 0 || ! fit(diff, (int) int_size)) {
error("too many elements in array");
}
tp->tp_size = align((diff + 1) * tp->arr_elsize, tp->tp_align);
/* ??? check overflow ??? */
if (! ufit(tp->tp_size, (int) pointer_size)) {
error("array too large");
}
/* generate descriptor and remember label.
*/
tp->arr_descr = ++data_label;
C_df_dlb(tp->arr_descr);
C_rom_cst((arith) 0);
C_rom_cst(diff);
C_rom_cst(tp->arr_elsize);
}
FreeType(tp)
register t_type *tp;
{
/* Release type structures indicated by "tp".
This procedure is only called for types, constructed with
T_PROCEDURE.
*/
register t_param *pr, *pr1;
assert(tp->tp_fund == T_PROCEDURE);
pr = ParamList(tp);
while (pr) {
pr1 = pr;
pr = pr->par_next;
free_def(pr1->par_def);
free_paramlist(pr1);
}
free_type(tp);
}
DeclareType(nd, df, tp)
register t_def *df;
register t_type *tp;
t_node *nd;
{
/* A type with type-description "tp" is declared and must
be bound to definition "df".
This routine also handles the case that the type-field of
"df" is already bound. In that case, it is either an opaque
type, or an error message was given when "df" was created.
*/
register t_type *df_tp = df->df_type;
if (df_tp && df_tp->tp_fund == T_HIDDEN) {
if (! (tp->tp_fund & (T_POINTER|T_HIDDEN|T_EQUAL))) {
node_error(nd,
"opaque type \"%s\" is not a pointer type",
df->df_idf->id_text);
}
df_tp->tp_next = tp;
df_tp->tp_fund = T_EQUAL;
while (tp != df_tp && tp->tp_fund == T_EQUAL) {
tp = tp->tp_next;
}
if (tp == df_tp) {
/* Circular definition! */
node_error(nd,
"opaque type \"%s\" has a circular definition",
df->df_idf->id_text);
tp->tp_next = error_type;
}
}
else {
df->df_type = tp;
if (BaseType(tp)->tp_fund == T_ENUMERATION) {
CheckForImports(df);
}
}
#ifdef DBSYMTAB
if (options['g']) stb_string(df, D_TYPE);
#endif
SolveForwardTypeRefs(df);
}
SolveForwardTypeRefs(df)
register t_def *df;
{
register t_node *nd;
if (df->df_kind == D_FORWTYPE) {
nd = df->df_forw_node;
df->df_kind = D_TYPE;
while (nd) {
nd->nd_type->tp_next = df->df_type;
#ifdef DBSYMTAB
if (options['g'] && nd->nd_type->tp_dbindex < 0) {
stb_addtp("(forward_type)", nd->nd_type);
}
#endif
nd = nd->nd_RIGHT;
}
FreeNode(df->df_forw_node);
}
}
ForceForwardTypeDef(df)
register t_def *df;
{
register t_def *df1 = df, *df2;
register t_node *nd = df->df_forw_node;
while (df && df->df_kind == D_FORWTYPE) {
RemoveFromIdList(df);
if ((df2 = df->df_scope->sc_def) == df) {
df->df_scope->sc_def = df->df_nextinscope;
}
else {
while (df2->df_nextinscope != df) {
df2 = df2->df_nextinscope;
}
df2->df_nextinscope = df->df_nextinscope;
}
df = df->df_forw_def;
}
while (nd->nd_class == Link) {
nd = nd->nd_RIGHT;
}
df = lookfor(nd, CurrVis, 1, 0);
if (! df->df_kind & (D_ERROR|D_TYPE)) {
node_error(nd, "\"%s\" is not a type", df1->df_idf->id_text);
}
while (df1 && df1->df_kind == D_FORWTYPE) {
df2 = df1->df_forw_def;
df1->df_type = df->df_type;
SolveForwardTypeRefs(df1);
free_def(df1);
df1 = df2;
}
}
t_type *
RemoveEqual(tpx)
register t_type *tpx;
{
if (tpx) while (tpx->tp_fund == T_EQUAL) tpx = tpx->tp_next;
return tpx;
}
int
type_or_forward(tp)
t_type *tp;
{
/* POINTER TO IDENTIFIER construction. The IDENTIFIER resides
in "dot". This routine handles the different cases.
*/
register t_node *nd;
register t_def *df, *df1;
if ((df1 = lookup(dot.TOK_IDF, CurrentScope, D_IMPORTED, D_USED))) {
/* Either a Module or a Type, but in both cases defined
in this scope, so this is the correct identification
*/
switch(df1->df_kind) {
case D_FORWARD:
FreeNode(df1->for_node);
df1->df_kind = D_FORWTYPE;
df1->df_forw_node = 0;
/* Fall through */
case D_FORWTYPE:
nd = dot2node(Link, NULLNODE, df1->df_forw_node);
df1->df_forw_node = nd;
nd->nd_type = tp;
return 0;
default:
return 1;
}
}
nd = dot2leaf(Name);
if ((df1 = lookfor(nd, CurrVis, 0, D_USED))->df_kind == D_MODULE) {
/* A Modulename in one of the enclosing scopes.
It is not clear from the language definition that
it is correct to handle these like this, but
existing compilers do it like this, and the
alternative is difficult with a lookahead of only
one token.
This path should actually only be taken if the next token
is a '.'.
???
*/
FreeNode(nd);
return 1;
}
/* Enter a forward reference into a list belonging to the
current scope. This is used for POINTER declarations, which
may have forward references that must howewer be declared in the
same scope.
*/
df = define(nd->nd_IDF, CurrentScope, D_FORWTYPE);
assert(df->df_kind == D_FORWTYPE);
df->df_flags |= D_USED | D_DEFINED;
nd->nd_type = tp;
df->df_forw_node = nd;
if (df != df1 && (df1->df_kind & (D_TYPE | D_FORWTYPE))) {
/* "df1" refers to a possible identification, but
we cannot be sure at this point. For the time
being, however, we use this one.
*/
df->df_type = df1->df_type;
df->df_forw_def = df1;
}
return 0;
}
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)
int m, n;
{
/* Least Common Multiple
*/
return m * (n / gcd(m, n));
}
t_type *
intorcard(left, right)
register t_type *left, *right;
{
if (left->tp_fund == T_INTORCARD) {
t_type *tmp = left;
left = right;
right = tmp;
}
if (right->tp_fund == T_INTORCARD) {
if (left->tp_fund == T_INTEGER || left->tp_fund == T_CARDINAL) {
return left;
}
}
return 0;
}
#ifdef DEBUG
DumpType(tp)
register t_type *tp;
{
if (!tp) return;
print("align:%d; size:%ld;", tp->tp_align, (long) tp->tp_size);
print(" fund:");
switch(tp->tp_fund) {
case T_RECORD:
print("RECORD");
break;
case T_ENUMERATION:
print("ENUMERATION; ncst:%d", tp->enm_ncst); break;
case T_INTEGER:
print("INTEGER"); break;
case T_CARDINAL:
print("CARDINAL"); break;
case T_REAL:
print("REAL"); break;
case T_HIDDEN:
print("HIDDEN"); break;
case T_EQUAL:
print("EQUAL"); break;
case T_POINTER:
print("POINTER"); break;
case T_CHAR:
print("CHAR"); break;
case T_WORD:
print("WORD"); break;
case T_SET:
print("SET"); break;
case T_SUBRANGE:
print("SUBRANGE %ld-%ld", (long) tp->sub_lb, (long) tp->sub_ub);
break;
case T_PROCEDURE:
{
register t_param *par = ParamList(tp);
print("PROCEDURE");
if (par) {
print("(");
while(par) {
if (IsVarParam(par)) print("VAR ");
DumpType(TypeOfParam(par));
par = par->par_next;
}
}
break;
}
case T_ARRAY:
print("ARRAY");
print("; element:");
DumpType(tp->arr_elem);
print("; index:");
DumpType(tp->tp_next);
print(";");
return;
case T_STRING:
print("STRING"); break;
case T_INTORCARD:
print("INTORCARD"); break;
default:
crash("DumpType");
}
if (tp->tp_next && tp->tp_fund != T_POINTER) {
/* Avoid printing recursive types!
*/
print(" next:(");
DumpType(tp->tp_next);
print(")");
}
print(";");
}
#endif

314
lang/m2/comp/typequiv.c
View File

@@ -1,314 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* T Y P E E Q U I V A L E N C E */
/* $Id$ */
/* Routines for testing type equivalence, type compatibility, and
assignment compatibility
*/
#include "debug.h"
#include <em_arith.h>
#include <em_label.h>
#include <assert.h>
#include "strict3rd.h"
#include "type.h"
#include "LLlex.h"
#include "idf.h"
#include "def.h"
#include "node.h"
#include "warning.h"
#include "main.h"
#include "Lpars.h"
extern char *sprint();
int
TstTypeEquiv(tp1, tp2)
t_type *tp1, *tp2;
{
/* test if two types are equivalent.
*/
return tp1 == tp2
||
tp1 == error_type
||
tp2 == error_type;
}
int
TstParEquiv(tp1, tp2)
register t_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)
||
(
IsConformantArray(tp1)
&&
IsConformantArray(tp2)
&&
TstTypeEquiv(tp1->arr_elem, tp2->arr_elem)
);
}
int
TstProcEquiv(tp1, tp2)
t_type *tp1, *tp2;
{
/* Test if two procedure types are equivalent. This routine
may also be used for the testing of assignment compatibility
between procedure variables and procedures.
*/
register t_param *p1, *p2;
/* First check if the result types are equivalent
*/
if (! TstTypeEquiv(ResultType(tp1), ResultType(tp2))) return 0;
p1 = ParamList(tp1);
p2 = ParamList(tp2);
/* Now check the parameters
*/
while (p1 && p2) {
if (IsVarParam(p1) != IsVarParam(p2) ||
!TstParEquiv(TypeOfParam(p1), TypeOfParam(p2))) return 0;
p1 = p1->par_next;
p2 = p2->par_next;
}
/* Here, at least one of the parameterlists is exhausted.
Check that they are both.
*/
return p1 == p2;
}
int
TstCompat(tp1, tp2)
register t_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;
tp1 = BaseType(tp1);
tp2 = BaseType(tp2);
if (tp2->tp_fund != T_INTORCARD &&
(tp1->tp_fund == T_INTORCARD || tp1 == address_type)) {
t_type *tmp = tp2;
tp2 = tp1;
tp1 = tmp;
}
return tp1 == tp2
||
( tp2 == intorcard_type
&&
(tp1 == int_type || tp1 == card_type || tp1 == address_type)
)
||
( tp2 == longintorcard_type
&&
(tp1 == longint_type || tp1 == longcard_type || tp1 == address_type)
)
||
( tp2 == address_type
&&
( tp1->tp_fund == T_CARDINAL || tp1->tp_fund == T_POINTER)
)
;
}
int
TstAssCompat(tp1, tp2)
register t_type *tp1, *tp2;
{
/* Test if two types are assignment compatible.
See Def 9.1.
*/
if (TstCompat(tp1, tp2)) return 1;
tp1 = BaseType(tp1);
tp2 = BaseType(tp2);
if (((tp1->tp_fund & T_INTORCARD) || tp1 == address_type) &&
((tp2->tp_fund & T_INTORCARD) || tp2 == address_type)) return 1;
if ((tp1->tp_fund == T_REAL) &&
(tp2->tp_fund == T_REAL)) return 1;
if (tp1->tp_fund == T_PROCEDURE &&
tp2->tp_fund == T_PROCEDURE) {
return TstProcEquiv(tp1, tp2);
}
if (tp1->tp_fund == T_ARRAY) {
/* check for string
*/
if (IsConformantArray(tp1)) return 0;
return
BaseType(tp1->arr_elem) == char_type
&& tp2->tp_fund == T_STRING
&& (tp1->arr_high - tp1->arr_low + 1) >= tp2->tp_size
;
}
return 0;
}
char *
incompat(tp1, tp2)
register t_type *tp1, *tp2;
{
if (tp1->tp_fund == T_HIDDEN || tp2->tp_fund == T_HIDDEN) {
return "properties of opaque type are hidden; illegal use";
}
return "type incompatibility";
}
int
TstParCompat(parno, formaltype, VARflag, nd, edf)
register t_type *formaltype;
t_node **nd;
t_def *edf;
{
/* Check type compatibility for a parameter in a procedure call.
Assignment compatibility may do if the parameter is
a value parameter.
Otherwise, a conformant array may do, or an ARRAY OF (WORD|BYTE)
may do too.
Or: a WORD may do.
*/
register t_type *actualtype = (*nd)->nd_type;
char ebuf[256];
if (edf) {
sprint(ebuf, "\"%s\", parameter %d: %%s", edf->df_idf->id_text, parno);
}
else sprint(ebuf, "parameter %d: %%s", parno);
if (
TstTypeEquiv(formaltype, actualtype)
||
( !VARflag && ChkAssCompat(nd, formaltype, (char *) 0))
||
( formaltype == address_type
&& actualtype->tp_fund == T_POINTER
)
||
( formaltype == word_type
&&
( actualtype->tp_size == word_size
||
( !VARflag
&&
actualtype->tp_size <= word_size
&&
! IsConformantArray(actualtype)
)
)
)
||
( formaltype == byte_type
&& actualtype->tp_size == (arith) 1
)
||
( IsConformantArray(formaltype)
&&
( formaltype->arr_elem == word_type
|| formaltype->arr_elem == byte_type
||
( actualtype->tp_fund == T_ARRAY
&& TstTypeEquiv(formaltype->arr_elem,actualtype->arr_elem)
)
||
( actualtype->tp_fund == T_STRING
&& TstTypeEquiv(formaltype->arr_elem, char_type)
)
)
)
)
return 1;
#ifndef STRICT_3RD_ED
if (! options['3'] && VARflag && TstCompat(formaltype, actualtype)) {
if (formaltype->tp_size == actualtype->tp_size) {
node_warning(*nd,
W_OLDFASHIONED,
ebuf,
"identical types required");
return 1;
}
node_error(*nd, ebuf, "equal sized types required");
return 0;
}
#endif
node_error(*nd, ebuf, incompat(formaltype, actualtype));
return 0;
}
CompatCheck(nd, tp, message, fc)
register t_node **nd;
t_type *tp;
char *message;
int (*fc)();
{
if (! (*fc)(tp, (*nd)->nd_type)) {
if (message) {
node_error(*nd, "%s in %s",
incompat(tp, (*nd)->nd_type),
message);
}
return 0;
}
MkCoercion(nd, tp);
return 1;
}
ChkAssCompat(nd, tp, message)
t_node **nd;
t_type *tp;
char *message;
{
/* Check assignment compatibility of node "nd" with type "tp".
Give an error message when it fails
*/
if ((*nd)->nd_symb == STRING) {
TryToString((*nd), tp);
}
return CompatCheck(nd, tp, message, TstAssCompat);
}
ChkCompat(nd, tp, message)
t_node **nd;
t_type *tp;
char *message;
{
/* Check compatibility of node "nd" with type "tp".
Give an error message when it fails
*/
return CompatCheck(nd, tp, message, TstCompat);
}

1152
lang/m2/comp/walk.c
View File

File diff suppressed because it is too large Load Diff

29
lang/m2/comp/walk.h
View File

@@ -1,29 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* P A R S E T R E E W A L K E R */
/* $Id$ */
/* Definition of WalkNode macro
*/
extern int (*WalkTable[])();
#define WalkNode(xnd, xlab, rch) (*WalkTable[(xnd)->nd_class])((xnd), (xlab),(rch))
extern label text_label;
extern label data_label;
#include "squeeze.h"
#ifndef SQUEEZE
#define c_loc(x) C_loc((arith) (x))
#define c_lae_dlb(x) C_lae_dlb(x,(arith) 0)
#define CAL(nm, sz) (C_cal(nm), C_asp((arith)(sz)))
#define c_bra(x) C_bra((label) (x))
#endif

30
lang/m2/comp/warning.h
View File

@@ -1,30 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* W A R N I N G C L A S S E S */
/* $Id$ */
/* Warning classes, at the moment three of them:
Strict (R)
Ordinary (W)
Old-fashioned(O)
*/
/* Bits for a bit mask: */
#define W_ORDINARY 1
#define W_STRICT 2
#define W_OLDFASHIONED 4
#define W_ALWAYS 010 /* always given */
#define W_ALL (W_ORDINARY|W_STRICT|W_OLDFASHIONED|W_ALWAYS)
#define W_INITIAL (W_ORDINARY | W_OLDFASHIONED | W_ALWAYS)
/* The bit mask itself: */
extern int warning_classes;