register struct string *str = &string;
register char *p;
- str->s_str = p = Malloc((unsigned) (str->s_length = ISTRSIZE));
+ str->s_str = p = Malloc(str->s_length = ISTRSIZE);
LoadChar(ch);
while (ch != upto) {
if (class(ch) == STNL) {
touch hfiles
main: $(OBJ) Makefile
- $(CC) $(LFLAGS) $(OBJ) $(LIBDIR)/libcomp.a $(LIBDIR)/malloc.o /user1/erikb/em/lib/libprint.a /user1/erikb/em/lib/libstr.a /user1/erikb/em/lib/libsystem.a -o main
+ $(CC) $(LFLAGS) $(OBJ) /user1/erikb/em/lib/libem_mes.a /user1/erikb/em/lib/libeme.a $(LIBDIR)/libcomp.a $(LIBDIR)/malloc.o /user1/erikb/em/lib/libprint.a /user1/erikb/em/lib/libstr.a /user1/erikb/em/lib/libsystem.a -o main
size main
clean:
def.o: LLlex.h debug.h def.h idf.h main.h node.h scope.h type.h
scope.o: LLlex.h debug.h def.h idf.h node.h scope.h type.h
misc.o: LLlex.h f_info.h idf.h misc.h node.h
-enter.o: LLlex.h def.h idf.h node.h scope.h type.h
+enter.o: LLlex.h def.h idf.h main.h node.h scope.h type.h
defmodule.o: LLlex.h debug.h def.h f_info.h idf.h input.h inputtype.h scope.h
typequiv.o: def.h type.h
node.o: LLlex.h debug.h def.h node.h type.h
cstoper.o: LLlex.h Lpars.h idf.h node.h standards.h target_sizes.h type.h
chk_expr.o: LLlex.h Lpars.h const.h debug.h def.h idf.h node.h scope.h standards.h type.h
+options.o: idfsize.h type.h
tokenfile.o: Lpars.h
program.o: LLlex.h Lpars.h debug.h def.h idf.h main.h node.h scope.h type.h
declar.o: LLlex.h Lpars.h def.h idf.h misc.h node.h scope.h type.h
% INIDF
%
%C
-1:a-zA-Z_0-9
+1:a-zA-Z0-9
%Tchar inidf[] = {
%F %s,
%p
#include <em_label.h>
#include <assert.h>
#include <alloc.h>
+
#include "Lpars.h"
#include "idf.h"
#include "type.h"
#include "scope.h"
#include "const.h"
#include "standards.h"
+
#include "debug.h"
int
{
/* Check the expression indicated by expp for semantic errors,
identify identifiers used in it, replace constants by
- their value.
+ their value, and try to evaluate the expression.
*/
switch(expp->nd_class) {
return chk_expr(expp->nd_left) &&
chk_expr(expp->nd_right) &&
chk_oper(expp);
+
case Uoper:
return chk_expr(expp->nd_right) &&
chk_uoper(expp);
+
case Value:
switch(expp->nd_symb) {
case REAL:
case STRING:
case INTEGER:
return 1;
+
default:
assert(0);
}
break;
+
case Xset:
return chk_set(expp);
+
case Name:
return chk_name(expp);
+
case Call:
return chk_call(expp);
+
case Link:
return chk_name(expp);
default:
findname(expp->nd_left);
assert(expp->nd_left->nd_class == Def);
df = expp->nd_left->nd_def;
- if ((df->df_kind != D_TYPE && df->df_kind != D_ERROR) ||
+ if (!(df->df_kind & (D_TYPE|D_ERROR)) ||
(df->df_type->tp_fund != T_SET)) {
- node_error(expp, "Illegal set type");
+ node_error(expp, "illegal set type");
return 0;
}
tp = df->df_type;
/* Now check the elements given, and try to compute a constant set.
*/
- set = (arith *) Malloc(tp->tp_size * sizeof(arith) / word_size);
+ set = (arith *)
+ Malloc((unsigned) (tp->tp_size * sizeof(arith) / word_size));
nd = expp->nd_right;
while (nd) {
assert(nd->nd_class == Link && nd->nd_symb == ',');
}
expp->nd_type = tp;
if (set) {
- /* Yes, in was a constant set, and we managed to compute it!
+ /* Yes, it was a constant set, and we managed to compute it!
+ Notice that at the moment there is no such thing as
+ partial evaluation. Either we evaluate the set, or we
+ don't (at all). Improvement not neccesary. (???)
*/
expp->nd_class = Set;
expp->nd_set = set;
recursively.
Also try to compute the set!
*/
+ register int i;
+
if (expp->nd_class == Link && expp->nd_symb == UPTO) {
/* { ... , expr1 .. expr2, ... }
First check expr1 and expr2, and try to compute them.
/* We have a constant range. Put all elements in the
set
*/
- register int i;
if (expp->nd_left->nd_INT > expp->nd_right->nd_INT) {
-node_error(expp, "Lower bound exceeds upper bound in range");
+node_error(expp, "lower bound exceeds upper bound in range");
return rem_set(set);
}
return rem_set(set);
}
if (!TstCompat(tp, expp->nd_type)) {
- node_error(expp, "Set element has incompatible type");
+ node_error(expp, "set element has incompatible type");
return rem_set(set);
}
if (expp->nd_class == Value) {
+ i = expp->nd_INT;
if ((tp->tp_fund != T_ENUMERATION &&
- (expp->nd_INT < tp->sub_lb || expp->nd_INT > tp->sub_ub))
+ (i < tp->sub_lb || i > tp->sub_ub))
||
(tp->tp_fund == T_ENUMERATION &&
- (expp->nd_INT < 0 || expp->nd_INT > tp->enm_ncst))
+ (i < 0 || i > tp->enm_ncst))
) {
- node_error(expp, "Set element out of range");
+ node_error(expp, "set element out of range");
return rem_set(set);
}
- if (*set) (*set)[expp->nd_INT/wrd_bits] |= (1 << (expp->nd_INT%wrd_bits));
+ if (*set) (*set)[i/wrd_bits] |= (1 << (i%wrd_bits));
}
return 1;
}
if (!chk_expr(argp->nd_left)) return 0;
tp = argp->nd_left->nd_type;
if (tp->tp_fund == T_SUBRANGE) tp = tp->next;
- if (!(tp->tp_fund & bases)) {
- node_error(argp, "Unexpected type");
+ if (bases && !(tp->tp_fund & bases)) {
+ node_error(argp, "unexpected type");
return 0;
}
return argp;
findname(argp->nd_left);
assert(argp->nd_left->nd_class == Def);
if (!(argp->nd_left->nd_def->df_kind & kinds)) {
- node_error(argp, "Unexpected type");
+ node_error(argp, "unexpected type");
return 0;
}
return argp;
register struct node *left;
register struct node *arg;
+ /* First, get the name of the function or procedure
+ */
expp->nd_type = error_type;
left = expp->nd_left;
findname(left);
if (left->nd_type == error_type) return 0;
if (left->nd_class == Def &&
(left->nd_def->df_kind & (D_HTYPE|D_TYPE|D_HIDDEN))) {
- /* A type cast. This is of course not portable.
+ /* It was a type cast. This is of course not portable.
No runtime action. Remove it.
*/
arg = expp->nd_right;
if ((! arg) || arg->nd_right) {
-node_error(expp, "Only one parameter expected in type cast");
+node_error(expp, "only one parameter expected in type cast");
return 0;
}
arg = arg->nd_left;
if (! chk_expr(arg)) return 0;
if (arg->nd_type->tp_size != left->nd_type->tp_size) {
-node_error(expp, "Size of type in type cast does not match size of operand");
+node_error(expp, "size of type in type cast does not match size of operand");
return 0;
}
arg->nd_type = left->nd_type;
/* A standard procedure
*/
assert(left->nd_class == Def);
-DO_DEBUG(3, debug("Standard name \"%s\", %d",
+DO_DEBUG(3, debug("standard name \"%s\", %d",
left->nd_def->df_idf->id_text, left->nd_def->df_value.df_stdname));
switch(left->nd_def->df_value.df_stdname) {
case S_ABS:
cstcall(expp, S_ABS);
}
break;
+
case S_CAP:
arg = getarg(arg, T_CHAR);
expp->nd_type = char_type;
cstcall(expp, S_CAP);
}
break;
+
case S_CHR:
arg = getarg(arg, T_INTORCARD);
expp->nd_type = char_type;
cstcall(expp, S_CHR);
}
break;
+
case S_FLOAT:
arg = getarg(arg, T_INTORCARD);
expp->nd_type = real_type;
if (!arg) return 0;
break;
+
case S_HIGH:
arg = getarg(arg, T_ARRAY);
if (!arg) return 0;
}
else cstcall(expp, S_MAX);
break;
+
case S_MAX:
case S_MIN:
arg = getarg(arg, T_DISCRETE);
expp->nd_type = arg->nd_left->nd_type;
cstcall(expp,left->nd_def->df_value.df_stdname);
break;
+
case S_ODD:
arg = getarg(arg, T_INTORCARD);
if (!arg) return 0;
cstcall(expp, S_ODD);
}
break;
+
case S_ORD:
arg = getarg(arg, T_DISCRETE);
if (!arg) return 0;
cstcall(expp, S_ORD);
}
break;
+
case S_TSIZE: /* ??? */
case S_SIZE:
arg = getname(arg, D_FIELD|D_VARIABLE|D_TYPE|D_HIDDEN|D_HTYPE);
if (!arg) return 0;
cstcall(expp, S_SIZE);
break;
+
case S_TRUNC:
arg = getarg(arg, T_REAL);
if (!arg) return 0;
expp->nd_type = card_type;
break;
+
case S_VAL: {
struct type *tp;
}
break;
}
+
case S_ADR:
arg = getname(arg, D_VARIABLE|D_FIELD|D_PROCEDURE);
expp->nd_type = address_type;
if (!arg) return 0;
break;
+
case S_DEC:
case S_INC:
expp->nd_type = 0;
if (!arg) return 0;
}
break;
+
case S_HALT:
expp->nd_type = 0;
break;
+
case S_EXCL:
case S_INCL: {
struct type *tp;
arg = getarg(arg, T_DISCRETE);
if (!arg) return 0;
if (!TstCompat(tp->next, arg->nd_left->nd_type)) {
- node_error(arg, "Unexpected type");
+ node_error(arg, "unexpected type");
return 0;
}
break;
}
+
default:
assert(0);
}
}
return 1;
}
- /* Here, we have found a real procedure call
+ /* Here, we have found a real procedure call. The left hand
+ side may also represent a procedure variable.
*/
- return 1;
+ return chk_proccall(expp);
}
node_error(expp->nd_left, "procedure, type, or function expected");
return 0;
}
+chk_proccall(expp)
+ struct node *expp;
+{
+ /* Check a procedure call
+ */
+ register struct node *left = expp->nd_left;
+ register struct node *arg;
+ register struct paramlist *param;
+
+ expp->nd_type = left->nd_type->next;
+ param = left->nd_type->prc_params;
+ arg = expp;
+
+ while (param) {
+ arg = getarg(arg, 0);
+ if (!arg) return 0;
+ if (param->par_var &&
+ ! TstCompat(param->par_type, arg->nd_left->nd_type)) {
+node_error(arg->nd_left, "type incompatibility in var parameter");
+ return 0;
+ }
+ else
+ if (!param->par_var &&
+ !TstAssCompat(param->par_type, arg->nd_left->nd_type)) {
+node_error(arg->nd_left, "type incompatibility in value parameter");
+ return 0;
+ }
+ param = param->next;
+ }
+ if (arg->nd_right) {
+ node_error(arg->nd_right, "too many parameters supplied");
+ return 0;
+ }
+ return 1;
+}
+
findname(expp)
register struct node *expp;
{
}
else if (tp->tp_fund != T_RECORD) {
/* This is also true for modules */
- node_error(expp,"Illegal selection");
+ node_error(expp,"illegal selection");
df = ill_df;
}
else df = lookup(expp->nd_right->nd_IDF, tp->rec_scope);
cstbin(expp);
}
return 1;
+
case T_SET:
if (expp->nd_left->nd_class == Set &&
expp->nd_right->nd_class == Set) {
cstset(expp);
}
/* Fall through */
+
case T_REAL:
return 1;
}
break;
+
case '/':
switch(tpl->tp_fund) {
case T_SET:
cstset(expp);
}
/* Fall through */
+
case T_REAL:
return 1;
}
break;
+
case DIV:
case MOD:
if (tpl->tp_fund & T_INTORCARD) {
return 1;
}
break;
+
case OR:
case AND:
if (tpl == bool_type) {
}
errval = 3;
break;
+
case '=':
case '#':
case GREATEREQUAL:
cstset(expp);
}
return 1;
+
case T_INTEGER:
case T_CARDINAL:
case T_ENUMERATION: /* includes boolean */
cstbin(expp);
}
return 1;
+
case T_POINTER:
if (!(expp->nd_symb == '=' || expp->nd_symb == '#')) {
break;
}
/* Fall through */
+
case T_REAL:
return 1;
}
+
default:
assert(0);
}
switch(errval) {
case 1:
- node_error(expp,"Operator \"%s\": illegal operand type(s)", symbol2str(expp->nd_symb));
+ node_error(expp,"operator \"%s\": illegal operand type(s)", symbol2str(expp->nd_symb));
break;
+
case 3:
node_error(expp, "BOOLEAN type(s) expected");
break;
+
default:
assert(0);
}
return 1;
}
break;
+
case '-':
if (tpr->tp_fund & T_INTORCARD) {
if (expp->nd_right->nd_class == Value) {
return 1;
}
break;
+
case NOT:
if (tpr == bool_type) {
if (expp->nd_right->nd_class == Value) {
return 1;
}
break;
+
case '^':
if (tpr->tp_fund != T_POINTER) break;
expp->nd_type = tpr->next;
return 1;
+
default:
assert(0);
}
#include "scope.h"
#include "node.h"
#include "misc.h"
+#include "main.h"
static int proclevel = 0; /* nesting level of procedures */
+char * sprint();
}
ProcedureDeclaration
{
struct def *df;
+ char buf[256];
} :
ProcedureHeading(&df, D_PROCEDURE)
{ df->prc_level = proclevel++;
+ if (DefinitionModule) {
+ C_exp(sprint(buf, "%s_%s",
+ df->df_scope->sc_name,
+ df->df_idf->id_text));
+ }
}
';' block(&(df->prc_body)) IDENT
{ match_id(dot.TOK_IDF, df->df_idf);
struct variable {
arith va_off; /* address or offset of variable */
char va_addrgiven; /* an address was given in the program */
+ char va_noreg; /* may not be in a register */
+ short va_number; /* number of this variable in definition module
+ */
#define var_off df_value.df_variable.va_off
#define var_addrgiven df_value.df_variable.va_addrgiven
+#define var_noreg df_value.df_variable.va_noreg
+#define var_number df_value.df_variable.va_number
};
struct constant {
struct dfproc {
struct scope *pr_scope; /* scope of procedure */
- int pr_level; /* depth level of this procedure */
- arith pr_nbpar; /* Number of bytes parameters */
+ short pr_level; /* depth level of this procedure */
+ short pr_number; /* number of this procedure in definition module
+ */
+ arith pr_nbpar; /* number of bytes parameters */
struct node *pr_body; /* body of this procedure */
#define prc_scope df_value.df_proc.pr_scope
#define prc_level df_value.df_proc.pr_level
#define prc_nbpar df_value.df_proc.pr_nbpar
#define prc_body df_value.df_proc.pr_body
+#define prc_number df_value.df_proc.pr_number
};
struct import {
struct def *ill_df = &illegal_def;
+struct def *
+MkDef(id, scope, kind)
+ struct idf *id;
+ struct scope *scope;
+{
+ /* Create a new definition structure in scope "scope", with
+ id "id" and kind "kind".
+ */
+ register struct def *df;
+
+ df = new_def();
+ df->df_flags = 0;
+ df->df_idf = id;
+ df->df_scope = scope;
+ df->df_kind = kind;
+ df->df_type = 0;
+ df->next = id->id_def;
+ id->id_def = df;
+
+ /* enter the definition in the list of definitions in this scope
+ */
+ df->df_nextinscope = scope->sc_def;
+ scope->sc_def = df;
+ return df;
+}
+
struct def *
define(id, scope, kind)
register struct idf *id;
}
return df;
}
- df = new_def();
- df->df_flags = 0;
- df->df_idf = id;
- df->df_scope = scope;
- df->df_kind = kind;
- df->df_type = 0;
- df->next = id->id_def;
- id->id_def = df;
-
- /* enter the definition in the list of definitions in this scope */
- df->df_nextinscope = scope->sc_def;
- scope->sc_def = df;
- return df;
+ return MkDef(id, scope, kind);
}
struct def *
#include "scope.h"
#include "LLlex.h"
#include "node.h"
+#include "main.h"
struct def *
Enter(name, kind, type, pnam)
df->var_off = off;
scope->sc_off = off;
}
+ else if (DefinitionModule) {
+ char buf[256];
+ char *sprint();
+
+ C_exa_dnam(sprint(buf,"%s_%s",df->df_scope->sc_name,
+ df->df_idf->id_text));
+ }
IdList = IdList->nd_right;
}
}
{
/* Look for an identifier in the visibility range started by
"scope".
- If it is not defined, give an error message, and
+ If it is not defined, maybe give an error message, and
create a dummy definition.
*/
struct def *df;
register struct scope *sc = scope;
+ struct def *MkDef();
while (sc) {
df = lookup(id->nd_IDF, sc);
if (df) return df;
sc = nextvisible(sc);
}
+
if (give_error) id_not_declared(id);
- return define(id->nd_IDF, scope, D_ERROR);
+
+ return MkDef(id->nd_IDF, scope, D_ERROR);
}
#include <em_arith.h>
#include "errout.h"
+#include "debug.h"
#include "input.h"
#include "f_info.h"
| %default
number(p)
|
- STRING { *p = MkNode(Value, NULLNODE, NULLNODE, &dot);
+ STRING {
+ *p = MkNode(Value, NULLNODE, NULLNODE, &dot);
if (dot.TOK_SLE == 1) {
- dot.TOK_INT = *(dot.TOK_STR);
- (*p)->nd_type = char_type;
+ int i;
+
+ i = *(dot.TOK_STR) & 0377;
+ (*p)->nd_type = charc_type;
+ free(dot.TOK_STR);
+ dot.TOK_INT = i;
}
else (*p)->nd_type = string_type;
}
Nargv[Nargc++] = *argv++;
}
Nargv[Nargc] = 0; /* terminate the arg vector */
- if (Nargc != 2) {
- fprint(STDERR, "%s: Use one file argument\n", ProgName);
+ if (Nargc < 2) {
+ fprint(STDERR, "%s: Use a file argument\n", ProgName);
return 1;
}
#ifdef DEBUG
- print("Mod2 compiler -- Debug version\n");
-#endif DEBUG
+ print("MODULA-2 compiler -- Debug version\n");
DO_DEBUG(1, debug("Debugging level: %d", options['D']));
- return !Compile(Nargv[1]);
+#endif DEBUG
+ return !Compile(Nargv[1], Nargv[2]);
}
-Compile(src)
- char *src;
+Compile(src, dst)
+ char *src, *dst;
{
extern struct tokenname tkidf[];
DO_DEBUG(1, debug("Filename : %s", src));
+ DO_DEBUG(1, (!dst || debug("Targetfile: %s", dst)));
if (! InsertFile(src, (char **) 0, &src)) {
fprint(STDERR,"%s: cannot open %s\n", ProgName, src);
return 0;
{
(void) open_scope(CLOSEDSCOPE);
GlobalScope = CurrentScope;
+ 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);
CompUnit();
}
+ C_close();
if (err_occurred) return 0;
return 1;
}
LexScan()
{
register int symb;
+ char *symbol2str();
while ((symb = LLlex()) > 0) {
print(">>> %s ", symbol2str(symb));
if (*p) *p++ = '\0';
}
}
+ else DEFPATH[i++] = "";
+
DEFPATH[i] = 0;
}
implementation module currently being
compiled
*/
+short nmcount = 0; /* count names in definition modules in order
+ to create suitable names in the object code
+ */
}
/*
The grammar as given by Wirth is already almost LL(1); the
Export(ExportList, QUALflag);
}
else {
- warning("export list in definition module ignored");
+node_warning(ExportList, "export list in definition module ignored");
FreeNode(ExportList);
}
}
{
register struct def *df;
struct idf *id;
+ int savnmcount = nmcount;
} :
DEFINITION
MODULE IDENT { id = dot.TOK_IDF;
df = define(id, GlobalScope, D_MODULE);
if (!SYSTEMModule) open_scope(CLOSEDSCOPE);
df->mod_scope = CurrentScope;
+ CurrentScope->sc_name = id->id_text;
df->df_type = standard_type(T_RECORD, 0, (arith) 0);
df->df_type->rec_scope = df->mod_scope;
- DefinitionModule = 1;
- DO_DEBUG(1, debug("Definition module \"%s\"", id->id_text));
+ DefinitionModule++;
+ nmcount = 0;
+ DO_DEBUG(1, debug("Definition module \"%s\" %d",
+ id->id_text, DefinitionModule));
}
';'
import(0)*
df = df->df_nextinscope;
}
if (!SYSTEMModule) close_scope(SC_CHKFORW);
- DefinitionModule = 0;
+ DefinitionModule--;
match_id(id, dot.TOK_IDF);
+ nmcount = savnmcount;
}
'.'
;
df = GetDefinitionModule(id);
CurrentScope = df->mod_scope;
DEFofIMPL = 0;
- DefinitionModule = 0;
}
else {
df = define(id, CurrentScope, D_MODULE);
#include "debug.h"
struct scope *CurrentScope, *PervasiveScope, *GlobalScope;
+static int scp_level;
/* STATICALLOCDEF "scope" */
assert(scopetype == OPENSCOPE || scopetype == CLOSEDSCOPE);
sc->sc_scopeclosed = scopetype == CLOSEDSCOPE;
+ sc->sc_level = scp_level++;
sc->sc_forw = 0;
sc->sc_def = 0;
sc->sc_off = 0;
sc->sc_scopeclosed = 0;
sc->sc_forw = 0;
sc->sc_def = 0;
+ sc->sc_level = scp_level++;
sc->next = 0;
PervasiveScope = sc;
CurrentScope = sc;
Reverse(&(sc->sc_def));
}
CurrentScope = sc->next;
+ scp_level = CurrentScope->sc_level;
}
#ifdef DEBUG
struct scope {
struct scope *next;
struct forwards *sc_forw;
+ 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 */
+ int sc_level; /* level of this scope */
};
extern struct scope
extern struct type
*bool_type,
*char_type,
+ *charc_type,
*int_type,
*card_type,
*longint_type,
struct type
*bool_type,
*char_type,
+ *charc_type,
*int_type,
*card_type,
*longint_type,
char_type = standard_type(T_CHAR, 1, (arith) 1);
char_type->enm_ncst = 256;
+ charc_type = standard_type(T_CHAR, 1, (arith) 1);
+ charc_type->enm_ncst = 256;
bool_type = standard_type(T_ENUMERATION, 1, (arith) 1);
bool_type->enm_ncst = 2;
int_type = standard_type(T_INTEGER, int_align, int_size);
)
;
}
+
+int TstAssCompat(tp1, tp2)
+ struct type *tp1, *tp2;
+{
+ /* Test if two types are assignment compatible.
+ */
+ if (TstCompat(tp1, tp2)) return 1;
+
+ if (tp1->tp_fund == T_SUBRANGE) tp1 = tp1->next;
+ if (tp2->tp_fund == T_SUBRANGE) tp2 = tp2->next;
+ if ((tp1->tp_fund & (T_INTEGER|T_CARDINAL)) &&
+ (tp2->tp_fund & (T_INTEGER|T_CARDINAL))) return 1;
+ if (tp1 == char_type && tp2 == charc_type) return 1;
+ if (tp1->tp_fund == T_ARRAY &&
+ (tp2 == charc_type || tp2 == string_type)) {
+ /* Unfortunately the length of the string is not
+ available here, so this must be tested somewhere else (???)
+ */
+ tp1 = tp1->arr_elem;
+ if (tp1->tp_fund == T_SUBRANGE) tp1 = tp1->next;
+ return tp1 == char_type;
+ }
+ return 0;
+}
public / ack.git / commitdiff