d0p1/ack
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

+ M2 Compiler ISO C90 compatibility

Browse source 
* Fixing of potential crash issue with function tables in compiler.
+ SYSTEM.h is now renamed to SYSTEMM2.h to avoid conflicts on non case sensitive filesystems.
This commit is contained in:
carl 2019-03-02 01:39:25 +08:00
parent 5f9a199257
commit 3867cfdaca
51 changed files with 1368 additions and 1203 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
lang/m2/comp/BigPars
View file

@ -45,7 +45,7 @@
!File: debugcst.h
/*#define DEBUG 1 /* perform various self-tests */
/*#define DEBUG 1 *//* perform various self-tests */
#define NDEBUG 1 /* disable assertions */
!File: inputtype.h
@ -57,22 +57,22 @@
!File: squeeze.h
/*#define SQUEEZE 1 /* define on "small" machines */
/*#define SQUEEZE 1 *//* define on "small" machines */
!File: strict3rd.h
/*#define STRICT_3RD_ED 1 /* define on "small" machines, and if you want
/*#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 */
/*#define NOCROSS 1 *//* define when cross-compiler not needed */
!File: nostrict.h
/*#define NOSTRICT 1 /* define when STRICT warnings disabled
/*#define NOSTRICT 1 *//* define when STRICT warnings disabled
(yet another squeezing method)
*/

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

@ -26,6 +26,7 @@
#include "f_info.h"
#include "Lpars.h"
#include "class.h"
#include "error.h"
#include "idf.h"
#include "def.h"
#include "type.h"
@ -48,8 +49,7 @@ int tk_nmb_at_last_syn_err = -ERR_SHADOW;
extern char options[];
extern int flt_status;
STATIC
SkipComment()
static void SkipComment(void)
{
/* Skip Modula-2 comments (* ... *).
Note that comments may be nested (par. 3.5).
@ -122,8 +122,7 @@ SkipComment()
}
}
STATIC struct string *
GetString(upto)
static struct string *GetString(int upto)
{
/* Read a Modula-2 string, delimited by the character "upto".
*/
@ -169,8 +168,7 @@ GetString(upto)
static char *s_error = "illegal line directive";
STATIC int
getch()
static int getch(void)
{
register int ch;
@ -180,8 +178,7 @@ getch()
return ch;
}
void
CheckForLineDirective()
void CheckForLineDirective(void)
{
register int ch = getch();
register int i = 0;
@ -242,8 +239,7 @@ CheckForLineDirective()
}
}
STATIC
CheckForLet()
static void CheckForLet()
{
register int ch;
@ -256,8 +252,7 @@ CheckForLet()
}
}
int
LLlex()
int LLlex(void)
{
/* LLlex() is the Lexical Analyzer.
The putting aside of tokens is taken into account.

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

@ -68,3 +68,5 @@ extern struct type *toktype;
extern int token_nmb;
extern int tk_nmb_at_last_syn_err;
void CheckForLineDirective(void);

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

@ -19,16 +19,17 @@
#include <em_arith.h>
#include <em_label.h>
#include "parameters.h"
#include "parameters.h"
#include "idf.h"
#include "error.h"
#include "LLlex.h"
#include "Lpars.h"
#include "misc.h"
extern char *symbol2str();
extern t_idf *gen_anon_idf();
LLmessage(tk)
register int tk;
void LLmessage(register int tk)
{
if (tk > 0) {
/* if (tk > 0), it represents the token to be inserted.

0
lang/m2/comp/SYSTEM.h → lang/m2/comp/SYSTEMM2.h
View file

401
lang/m2/comp/casestat.xc
View file

@ -16,21 +16,25 @@
cases themselves.
*/
#include "parameters.h"
#include "parameters.h"
#include "debug.h"
#include <em_label.h>
#include <em_arith.h>
#include <em_code.h>
#include <alloc.h>
#include <assert.h>
#include "em_label.h"
#include "em_arith.h"
#include "em_code.h"
#include "alloc.h"
#include "Lpars.h"
#include "type.h"
#include "error.h"
#include "LLlex.h"
#include "node.h"
#include "desig.h"
#include "walk.h"
#include "code.h"
#include "typequiv.h"
#include "chk_expr.h"
#include "def.h"
@ -54,11 +58,12 @@ struct case_entry {
arith ce_low, ce_up; /* lower and upper bound of range */
};
void AddCases();
void AddOneCase();
/* 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
@ -66,8 +71,7 @@ void AddOneCase();
may be lower.
*/
compact(nr, low, up)
arith low, up;
static int compact(int nr, arith low, arith up)
{
/* Careful! up - low might not fit in an arith. And then,
the test "up-low < 0" might also not work to detect this
@ -80,199 +84,7 @@ compact(nr, low, up)
}
#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);
}
void
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);
}
void
AddOneCase(sh, lnode, rnode, lbl)
register struct switch_hdr *sh;
t_node *lnode, *rnode;
label lbl;
static void AddOneCase(struct switch_hdr *sh, t_node *lnode, t_node *rnode, label lbl)
{
register struct case_entry *ce = new_case_entry();
register struct case_entry *c1 = sh->sh_entries, *c2 = 0;
@ -387,3 +199,188 @@ node_error(rnode, "multiple case entry for value %ld", (long)(ce->ce_up));
}
if (ce->ce_label) sh->sh_nrofentries += ce->ce_up - ce->ce_low + 1;
}
static void AddCases(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);
}
static void FreeSh(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);
}
int CaseCode(t_node *nd, label exitlabel, int end_reached)
{
/* 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;
}

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

@ -12,15 +12,17 @@
/* Check expressions, and try to evaluate them as far as possible.
*/
#include <stdlib.h>
#include <string.h>
#include "parameters.h"
#include <stdlib.h>
#include <string.h>
#include "parameters.h"
#include "debug.h"
#include <em_arith.h>
#include <em_label.h>
#include <assert.h>
#include <alloc.h>
#include <flt_arith.h>
#include <system.h>
#include "Lpars.h"
#include "idf.h"
@ -29,21 +31,30 @@
#include "def.h"
#include "node.h"
#include "scope.h"
#include "error.h"
#include "standards.h"
#include "chk_expr.h"
#include "cstoper.h"
#include "typequiv.h"
#include "misc.h"
#include "lookup.h"
#include "print.h"
#include "warning.h"
#include "main.h"
extern char *symbol2str();
extern char *sprint();
extern arith flt_flt2arith();
STATIC
df_error(nd, mess, edf)
t_node *nd; /* node on which error occurred */
char *mess; /* error message */
register t_def *edf; /* do we have a name? */
/* Forward file declarations */
static int ChkStandard(t_node **);
static int ChkCast(t_node **);
static void df_error(
t_node *nd, /* node on which error occurred */
char *mess, /* error message */
register t_def *edf) /* do we have a name? */
{
if (edf) {
if (edf->df_kind != D_ERROR) {
@ -53,10 +64,7 @@ df_error(nd, mess, edf)
else node_error(nd, mess);
}
void
MkCoercion(pnd, tp)
t_node **pnd;
register t_type *tp;
void MkCoercion(t_node **pnd, register t_type *tp)
{
/* Make a coercion from the node indicated by *pnd to the
type indicated by tp. If the node indicated by *pnd
@ -162,9 +170,7 @@ MkCoercion(pnd, tp)
*pnd = nd;
}
int
ChkVariable(expp, flags)
register t_node **expp;
int ChkVariable(register t_node **expp, int flags)
{
/* Check that "expp" indicates an item that can be
assigned to.
@ -182,9 +188,7 @@ ChkVariable(expp, flags)
return 1;
}
STATIC int
ChkArrow(expp)
t_node **expp;
static int ChkArrow(t_node **expp, int flags)
{
/* Check an application of the '^' operator.
The operand must be a variable of a pointer type.
@ -211,9 +215,7 @@ ChkArrow(expp)
return 1;
}
STATIC int
ChkArr(expp, flags)
t_node **expp;
static int ChkArr(t_node **expp, int flags)
{
/* Check an array selection.
The left hand side must be a variable of an array type,
@ -255,9 +257,7 @@ ChkArr(expp, flags)
}
/*ARGSUSED*/
STATIC int
ChkValue(expp)
t_node **expp;
static int ChkValue(t_node **expp, int flags)
{
#ifdef DEBUG
switch((*expp)->nd_symb) {
@ -273,9 +273,7 @@ ChkValue(expp)
return 1;
}
STATIC int
ChkSelOrName(expp, flags)
t_node **expp;
static int ChkSelOrName(t_node **expp, int flags)
{
/* Check either an ID or a construction of the form
ID.ID [ .ID ]*
@ -348,9 +346,7 @@ ChkSelOrName(expp, flags)
return exp->nd_def->df_kind != D_ERROR;
}
STATIC int
ChkExSelOrName(expp)
t_node **expp;
static int ChkExSelOrName(t_node **expp, int flags)
{
/* Check either an ID or an ID.ID [.ID]* occurring in an
expression.
@ -422,20 +418,13 @@ ChkExSelOrName(expp)
return 1;
}
STATIC int
ChkEl(expp, tp)
register t_node **expp;
t_type *tp;
static int ChkEl(register t_node **expp, t_type *tp)
{
return ChkExpression(expp) && ChkCompat(expp, tp, "set element");
}
STATIC int
ChkElement(expp, tp, set)
t_node **expp;
t_type *tp;
arith *set;
static int ChkElement(t_node **expp, t_type *tp, arith *set)
{
/* Check elements of a set. This routine may call itself
recursively.
@ -494,9 +483,7 @@ ChkElement(expp, tp, set)
return 1;
}
arith *
MkSet(size)
unsigned size;
arith *MkSet(unsigned int size)
{
register arith *s, *t;
@ -508,8 +495,7 @@ MkSet(size)
return s;
}
FreeSet(s)
register arith *s;
void FreeSet(register arith *s)
{
dec_refcount(s);
if (refcount(s) <= 0) {
@ -518,9 +504,7 @@ FreeSet(s)
}
}
STATIC int
ChkSet(expp)
t_node **expp;
static int ChkSet(t_node **expp, int flags)
{
/* Check the legality of a SET aggregate, and try to evaluate it
compile time. Unfortunately this is all rather complicated.
@ -586,10 +570,7 @@ ChkSet(expp)
return retval;
}
STATIC t_node *
nextarg(argp, edf)
t_node **argp;
t_def *edf;
static t_node *nextarg(t_node **argp, t_def *edf)
{
register t_node *arg = (*argp)->nd_RIGHT;
@ -602,10 +583,7 @@ nextarg(argp, edf)
return arg;
}
STATIC t_node *
getarg(argp, bases, designator, edf)
t_node **argp;
t_def *edf;
static t_node *getarg(t_node **argp, int bases, int designator, t_def *edf)
{
/* This routine is used to fetch the next argument from an
argument list. The argument list is indicated by "argp".
@ -643,10 +621,7 @@ getarg(argp, bases, designator, edf)
return left;
}
STATIC t_node *
getname(argp, kinds, bases, edf)
t_node **argp;
t_def *edf;
static t_node *getname(t_node **argp, int kinds, int bases, t_def *edf)
{
/* Get the next argument from argument list "argp".
The argument must indicate a definition, and the
@ -672,9 +647,7 @@ getname(argp, kinds, bases, edf)
return left;
}
STATIC int
ChkProcCall(exp)
register t_node *exp;
static int ChkProcCall(register t_node *exp)
{
/* Check a procedure call
*/
@ -735,9 +708,7 @@ ChkProcCall(exp)
return retval;
}
STATIC int
ChkFunCall(expp)
register t_node **expp;
static int ChkFunCall(register t_node **expp, int flags)
{
/* Check a call that must have a result
*/
@ -750,12 +721,9 @@ ChkFunCall(expp)
return 0;
}
STATIC int ChkStandard();
STATIC int ChkCast();
int
ChkCall(expp)
t_node **expp;
int ChkCall(t_node **expp)
{
/* Check something that looks like a procedure or function call.
Of course this does not have to be a call at all,
@ -795,9 +763,7 @@ ChkCall(expp)
return ChkProcCall(*expp);
}
STATIC t_type *
ResultOfOperation(operator, tp)
t_type *tp;
static t_type *ResultOfOperation(int operator, t_type *tp)
{
/* Return the result type of the binary operation "operator",
with operand type "tp".
@ -819,8 +785,7 @@ ResultOfOperation(operator, tp)
#define Boolean(operator) (operator == OR || operator == AND)
STATIC int
AllowedTypes(operator)
static int AllowedTypes(int operator)
{
/* Return a bit mask indicating the allowed operand types
for binary operator "operator".
@ -854,10 +819,10 @@ AllowedTypes(operator)
/*NOTREACHED*/
}
STATIC int
ChkAddressOper(tpl, tpr, expp)
register t_type *tpl, *tpr;
register t_node *expp;
static int ChkAddressOper(
register t_type *tpl,
register t_type *tpr,
register t_node *expp)
{
/* Check that either "tpl" or "tpr" are both of type
address_type, or that one of them is, but the other is
@ -901,9 +866,7 @@ ChkAddressOper(tpl, tpr, expp)
return 0;
}
STATIC int
ChkBinOper(expp)
t_node **expp;
static int ChkBinOper(t_node **expp, int flags)
{
/* Check a binary operation.
*/
@ -1018,9 +981,7 @@ ChkBinOper(expp)
return 1;
}
STATIC int
ChkUnOper(expp)
t_node **expp;
static int ChkUnOper(t_node **expp, int flags)
{
/* Check an unary operation.
*/
@ -1093,10 +1054,7 @@ ChkUnOper(expp)
return 0;
}
STATIC t_node *
getvariable(argp, edf, flags)
t_node **argp;
t_def *edf;
static t_node *getvariable(t_node **argp, t_def *edf, int flags)
{
/* Get the next argument from argument list "argp".
It must obey the rules of "ChkVariable".
@ -1110,9 +1068,7 @@ getvariable(argp, edf, flags)
return arg->nd_LEFT;
}
STATIC int
ChkStandard(expp)
t_node **expp;
static int ChkStandard(t_node **expp)
{
/* Check a call of a standard procedure or function
*/
@ -1326,7 +1282,7 @@ ChkStandard(expp)
#endif
#ifndef STRICT_3RD_ED
if (! options['3'] && edf->df_value.df_stdname == S_TSIZE) {
if (arg = arglink->nd_RIGHT) {
if ( (arg = arglink->nd_RIGHT) ) {
node_warning(arg,
W_OLDFASHIONED,
"TSIZE with multiple parameters, only first parameter used");
@ -1442,9 +1398,7 @@ ChkStandard(expp)
return 1;
}
STATIC int
ChkCast(expp)
t_node **expp;
static int ChkCast(t_node **expp)
{
/* Check a cast and perform it if the argument is constant.
If the sizes don't match, only complain if at least one of them
@ -1507,9 +1461,7 @@ ChkCast(expp)
return 1;
}
TryToString(nd, tp)
register t_node *nd;
t_type *tp;
void TryToString(register t_node *nd, t_type *tp)
{
/* Try a coercion from character constant to string.
*/
@ -1527,25 +1479,20 @@ TryToString(nd, tp)
}
}
STATIC int
no_desig(expp)
t_node **expp;
static int no_desig(t_node **expp, int flags)
{
node_error(*expp, "designator expected");
return 0;
}
STATIC int
add_flags(expp, flags)
t_node **expp;
static int add_flags(t_node **expp, int flags)
{
(*expp)->nd_def->df_flags |= flags;
return 1;
}
extern int PNodeCrash();
int (*ExprChkTable[])() = {
int (*ExprChkTable[])(t_node **, int) = {
ChkValue,
ChkArr,
ChkBinOper,
@ -1561,7 +1508,7 @@ int (*ExprChkTable[])() = {
PNodeCrash,
};
int (*DesigChkTable[])() = {
int (*DesigChkTable[])(t_node **, int) = {
no_desig,
ChkArr,
no_desig,

24
lang/m2/comp/chk_expr.h
View file

@ -4,22 +4,38 @@
*
* Author: Ceriel J.H. Jacobs
*/
#ifndef CHK_EXPR_H_
#define CHK_EXPR_H_
/* 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
extern int (*ExprChkTable[])(t_node **, int); /* table of expression checking
functions, indexed by node class
*/
extern int (*DesigChkTable[])(); /* table of designator checking
extern int (*DesigChkTable[])(t_node **, int); /* 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))
#define ChkExpression(expp) ((*ExprChkTable[(unsigned int)((*expp)->nd_class)])(expp,D_USED))
#define ChkDesig(expp, flags) ((*DesigChkTable[(unsigned int)((*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))
void MkCoercion(t_node **pnd, register t_type *tp);
int ChkVariable(register t_node **expp, int flags);
int ChkCall(t_node **expp);
void TryToString(register t_node *nd, t_type *tp);
/* Generates a set of "size" bytes and increments its reference count. */
arith *MkSet(unsigned int size);
/* Decrements the reference counter of set "s" and if reference count
* is zero, then it frees the memory associated with the set.
*/
void FreeSet(register arith *s);
#endif /* CHK_EXPR_H_ */

162
lang/m2/comp/code.c
View file

@ -12,23 +12,27 @@
/* Code generation for expressions and coercions
*/
#include "parameters.h"
#include "parameters.h"
#include "debug.h"
#include <em_arith.h>
#include <em_label.h>
#include <em_code.h>
#include <em_abs.h>
#include <assert.h>
#include <alloc.h>
#include "em_arith.h"
#include "em_label.h"
#include "em_code.h"
#include "em_abs.h"
#include "alloc.h"
#include "code.h"
#include "type.h"
#include "error.h"
#include "LLlex.h"
#include "def.h"
#include "scope.h"
#include "desig.h"
#include "chk_expr.h"
#include "node.h"
#include "Lpars.h"
#include "tmpvar.h"
#include "standards.h"
#include "walk.h"
@ -37,17 +41,19 @@ extern char options[];
extern t_desig null_desig;
int fp_used;
void RangeCheck();
void CodeParameters();
void CodeCall();
/* Forward declarations */
static void CodeParameters(t_param *, register t_node *);
static void CodeStd(t_node *);
static void compare(int, label);
static void truthvalue(int);
static void CodeUoper(register t_node *);
static void CodeSet(register t_node *, int);
static void CodeEl(register t_node *, register t_type *, int);
static void CodeDAddress(t_node *, int);
static void DoHIGH(register t_def *);
CodeConst(cst, size)
arith cst;
int size;
void CodeConst(arith cst, int size)
{
/* Generate code to push constant "cst" with size "size"
*/
if (size <= (int) word_size) {
C_loc(cst);
}
@ -59,9 +65,7 @@ CodeConst(cst, size)
}
}
void
CodeString(nd)
register t_node *nd;
void CodeString(register t_node *nd)
{
if (nd->nd_type->tp_fund != T_STRING) {
/* Character constant */
@ -73,10 +77,7 @@ CodeString(nd)
c_lae_dlb(data_label);
}
CodeExpr(nd, ds, true_label, false_label)
register t_node *nd;
register t_desig *ds;
label true_label, false_label;
void CodeExpr(t_node *nd, t_desig *ds, label true_label, label false_label)
{
register t_type *tp = nd->nd_type;
@ -173,8 +174,7 @@ CodeExpr(nd, ds, true_label, false_label)
}
}
CodeCoercion(t1, t2)
t_type *t1, *t2;
void CodeCoercion(t_type *t1, t_type *t2)
{
int fund1, fund2;
int sz1 = t1->tp_size;
@ -293,13 +293,9 @@ CodeCoercion(t1, t2)
}
}
void
CodeCall(nd)
register t_node *nd;
void CodeCall(t_node *nd)
{
/* Generate code for a procedure call. Checking of parameters
and result is already done.
*/
register t_node *left = nd->nd_LEFT;
t_type *result_tp;
int needs_fn;
@ -361,10 +357,8 @@ CodeCall(nd)
DoLineno(nd);
}
void
CodeParameters(param, arg)
t_param *param;
register t_node *arg;
/* Generates code to setup the parameters of a procedure call. */
static void CodeParameters(t_param *param, register t_node *arg)
{
register t_type *tp;
register t_type *arg_type;
@ -445,9 +439,7 @@ CodeParameters(param, arg)
CodePExpr(arg);
}
CodePString(nd, tp)
t_node *nd;
t_type *tp;
void CodePString(t_node *nd, t_type *tp)
{
arith szarg = WA(nd->nd_type->tp_size);
register arith zersz = WA(tp->tp_size) - szarg;
@ -461,9 +453,9 @@ CodePString(nd, tp)
C_loi(szarg);
}
static
subu(sz)
int sz;
static void subu(int sz)
{
if (! options['R']) {
C_cal(sz == (int) word_size ? "subuchk" : "subulchk");
@ -471,9 +463,7 @@ subu(sz)
C_sbu((arith) sz);
}
static
addu(sz)
int sz;
static void addu(int sz)
{
if (! options['R']) {
C_cal(sz == (int) word_size ? "adduchk" : "addulchk");
@ -481,9 +471,7 @@ addu(sz)
C_adu((arith)sz);
}
static int
complex_lhs(nd)
register t_node *nd;
static int complex_lhs(register t_node *nd)
{
switch(nd->nd_class) {
case Value:
@ -498,8 +486,8 @@ complex_lhs(nd)
}
}
CodeStd(nd)
t_node *nd;
/* Generate code for internal procedures */
static void CodeStd(t_node *nd)
{
register t_node *arg = nd->nd_RIGHT;
register t_node *left = 0;
@ -654,9 +642,7 @@ CodeStd(nd)
}
}
int
needs_rangecheck(tpl, tpr)
register t_type *tpl, *tpr;
static int needs_rangecheck(register t_type *tpl, t_type *tpr)
{
arith rlo, rhi;
@ -679,13 +665,8 @@ needs_rangecheck(tpl, tpr)
return 0;
}
void
RangeCheck(tpl, tpr)
register t_type *tpl, *tpr;
void RangeCheck(register t_type *tpl, t_type *tpr)
{
/* Generate a range check if neccessary
*/
arith rlo, rhi;
if (options['R']) return;
@ -709,8 +690,7 @@ RangeCheck(tpl, tpr)
}
}
Operands(nd)
register t_node *nd;
void Operands(register t_node *nd)
{
CodePExpr(nd->nd_LEFT);
@ -718,10 +698,11 @@ Operands(nd)
DoLineno(nd);
}
CodeOper(expr, true_label, false_label)
register t_node *expr; /* the expression tree itself */
label true_label;
label false_label; /* labels to jump to in logical expr's */
void CodeOper(
register t_node *expr, /* the expression tree itself */
label true_label,
label false_label /* labels to jump to in logical expr's */
)
{
register t_node *leftop = expr->nd_LEFT;
register t_node *rightop = expr->nd_RIGHT;
@ -1019,10 +1000,8 @@ CodeOper(expr, true_label, false_label)
}
}
/* compare() serves as an auxiliary function of CodeOper */
compare(relop, lbl)
int relop;
register label lbl;
/* Serves as an auxiliary function of CodeOper */
static void compare(int relop, label lbl)
{
switch (relop) {
case '<':
@ -1048,9 +1027,8 @@ compare(relop, lbl)
}
}
/* truthvalue() serves as an auxiliary function of CodeOper */
truthvalue(relop)
int relop;
/* Serves as an auxiliary function of CodeOper */
static void truthvalue(int relop)
{
switch (relop) {
case '<':
@ -1076,8 +1054,9 @@ truthvalue(relop)
}
}
CodeUoper(nd)
register t_node *nd;
/* Generates code for an unary expression */
void CodeUoper(register t_node *nd)
{
register t_type *tp = nd->nd_type;
@ -1110,8 +1089,7 @@ CodeUoper(nd)
}
}
CodeSet(nd, null_set)
register t_node *nd;
static void CodeSet(register t_node *nd, int null_set)
{
register t_type *tp = nd->nd_type;
@ -1128,9 +1106,7 @@ CodeSet(nd, null_set)
if (null_set) C_zer(tp->tp_size);
}
CodeEl(nd, tp, null_set)
register t_node *nd;
register t_type *tp;
static void CodeEl(register t_node *nd, register t_type *tp, int null_set)
{
register t_type *eltype = ElementType(tp);
@ -1155,12 +1131,9 @@ CodeEl(nd, tp, null_set)
}
}
CodePExpr(nd)
register t_node *nd;
void CodePExpr(register t_node *nd)
{
/* Generate code to push the value of the expression "nd"
on the stack.
*/
t_desig designator;
designator = null_desig;
@ -1168,8 +1141,7 @@ CodePExpr(nd)
CodeValue(&designator, nd->nd_type);
}
CodeDAddress(nd, chk_controlvar)
t_node *nd;
static void CodeDAddress(t_node *nd, int chk_controlvar)
{
/* Generate code to push the address of the designator "nd"
on the stack.
@ -1195,12 +1167,9 @@ CodeDAddress(nd, chk_controlvar)
}
}
CodeDStore(nd)
register t_node *nd;
void CodeDStore(register t_node *nd)
{
/* Generate code to store the expression on the stack into the
designator "nd".
*/
t_desig designator;
@ -1210,8 +1179,7 @@ CodeDStore(nd)
CodeStore(&designator, nd->nd_type);
}
DoHIGH(df)
register t_def *df;
static void DoHIGH(register t_def *df)
{
/* Get the high index of a conformant array, indicated by "nd".
The high index is the second field in the descriptor of
@ -1235,26 +1203,22 @@ DoHIGH(df)
}
#ifdef SQUEEZE
c_bra(l)
label l;
void c_bra(label l)
{
C_bra((label) l);
}
c_loc(n)
void c_loc(int n)
{
C_loc((arith) n);
}
c_lae_dlb(l)
label l;
void c_lae_dlb(label l)
{
C_lae_dlb(l, (arith) 0);
}
CAL(name, ssp)
char *name;
int ssp;
void CAL(char *name, int ssp)
{
C_cal(name);
C_asp((arith) ssp);

53
lang/m2/comp/code.h Normal file
View file

@ -0,0 +1,53 @@
/* Copyright (c) 2019 ACK Project.
* See the copyright notice in the ACK home directory,
* in the file "Copyright".
*
* Created on: 2019-02-26
*
*/
#ifndef CODE_H_
#define CODE_H_
#include "parameters.h"
#include <em_arith.h>
#include <em_label.h>
/* Forward declarations. */
typedef struct node t_node;
typedef struct desig t_desig;
typedef struct type t_type;
/* Generate code to push constant "cst" with size "size" bytes. */
void CodeConst(arith cst, int size);
/* Generate constant character or string. */
void CodeString(register t_node *nd);
/* Generate code for an expression contained in "nd". */
void CodeExpr(t_node *nd, t_desig *ds, label true_label, label false_label);
/* Generate implicit type conversion code. */
void CodeCoercion(t_type *t1, t_type *t2);
/* Generate code for a procedure call including parameter setup. Checking of parameters
and result is already done. */
void CodeCall(t_node *nd);
void CodePString(t_node *nd, t_type *tp);
/* Generate a range check if necessary */
void RangeCheck(register t_type *tpl, t_type *tpr);
void CodeOper(register t_node *expr, label true_label, label false_label);
/* Generate code to push the value of the expression "nd"
on the stack. */
void CodePExpr(register t_node *nd);
/* Generate code to store the expression on the stack into the
designator "nd".
*/
void CodeDStore(register t_node *nd);
#ifdef SQUEEZE
void c_bra(label l);
void c_loc(int n);
void c_lae_dlb(label l);
void CAL(char *name, int ssp);
#endif
#endif /* CODE_H_ */

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

@ -9,8 +9,8 @@
/* $Id$ */
#include <stdlib.h>
#include "parameters.h"
#include <stdlib.h>
#include "parameters.h"
#include "debug.h"
#include <em_arith.h>
@ -24,7 +24,10 @@
#include "node.h"
#include "Lpars.h"
#include "standards.h"
#include "cstoper.h"
#include "chk_expr.h"
#include "warning.h"
#include "error.h"
extern char *symbol2str();
@ -45,19 +48,17 @@ arith min_int[] = { 0L, -128L, -32768L, 0L, -2147483647L-1 };
extern char options[];
void CutSize();
static void CutSize(register t_node *);
overflow(expp)
t_node *expp;
static void overflow(t_node *expp)
{
if (expp->nd_type != address_type) {
node_warning(expp, W_ORDINARY, "overflow in constant expression");
}
}
STATIC
commonbin(expp)
t_node **expp;
static void commonbin(t_node **expp)
{
register t_node *exp = *expp;
t_type *tp = exp->nd_type;
@ -69,11 +70,10 @@ commonbin(expp)
right->nd_type = tp;
}
cstunary(expp)
t_node **expp;
void cstunary(t_node **expp)
{
/* The unary operation in "expp" is performed on the constant
expression below it, and the result restored in expp.
expression below it, and the result stored in expp.
*/
register t_node *exp = *expp;
register t_node *right = exp->nd_RIGHT;
@ -107,9 +107,7 @@ cstunary(expp)
CutSize(*expp);
}
STATIC
divide(pdiv, prem)
arith *pdiv, *prem;
static void divide(arith *pdiv, arith *prem)
{
/* Unsigned divide *pdiv by *prem, and store result in *pdiv,
remainder in *prem
@ -121,9 +119,7 @@ divide(pdiv, prem)
*prem = (unsigned arith) o1 % (unsigned arith) o2;
}
void
cstibin(expp)
t_node **expp;
void cstibin(t_node **expp)
{
/* The binary operation in "expp" is performed on the constant
expressions below it, and the result restored in expp.
@ -232,8 +228,7 @@ cstibin(expp)
CutSize(*expp);
}
cstfbin(expp)
t_node **expp;
void cstfbin(t_node **expp)
{
/* The binary operation in "expp" is performed on the constant
expressions below it, and the result restored in expp.
@ -320,9 +315,7 @@ cstfbin(expp)
CutSize(exp);
}
void
cstubin(expp)
t_node **expp;
void cstubin(t_node **expp)
{
/* The binary operation in "expp" is performed on the constant
expressions below it, and the result restored in
@ -427,9 +420,7 @@ cstubin(expp)
CutSize(exp);
}
void
cstset(expp)
t_node **expp;
void cstset(t_node **expp)
{
extern arith *MkSet();
register t_node *exp = *expp;
@ -544,8 +535,7 @@ cstset(expp)
FreeNode(exp);
}
cstcall(expp, call)
t_node **expp;
void cstcall(t_node **expp, int call)
{
/* a standard procedure call is found that can be evaluated
compile time, so do so.
@ -619,9 +609,7 @@ cstcall(expp, call)
}
}
void
CutSize(expr)
register t_node *expr;
static void CutSize(register t_node *expr)
{
/* The constant value of the expression expr is made to
conform to the size of the type of the expression.
@ -640,7 +628,7 @@ CutSize(expr)
}
}
InitCst()
void InitCst(void)
{
register int i = 0;
#ifndef NOCROSS

29
lang/m2/comp/cstoper.h Normal file
View file

@ -0,0 +1,29 @@
/* Copyright (c) 2019 ACK Project.
* See the copyright notice in the ACK home directory,
* in the file "Copyright".
*
* Created on: 2019-02-25
*
*/
#ifndef CSTOPER_H_
#define CSTOPER_H_
/* Compile time constant evaluations */
void cstunary(t_node **expp);
void cstibin(t_node **expp);
void cstfbin(t_node **expp);
void cstubin(t_node **expp);
/** Evaluates the constant set operators at compile time
* and returns the result in "expp".
*/
void cstset(t_node **expp);
/* Evaluates the result of internal procedures on constants
* at compile time, and returns the result in "expp".
*/
void cstcall(t_node **expp, int call);
/* Compile time constant evaluator system initialization. */
void InitCst(void);
#endif /* CSTOPER_H_ */

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

@ -10,13 +10,13 @@
/* $Id$ */
{
#include "parameters.h"
#include "parameters.h"
#include "debug.h"
#include <em_arith.h>
#include <em_label.h>
#include <alloc.h>
#include <assert.h>
#include "em_arith.h"
#include "em_label.h"
#include "alloc.h"
#include "idf.h"
#include "LLlex.h"
@ -24,8 +24,11 @@
#include "type.h"
#include "scope.h"
#include "node.h"
#include "enter.h"
#include "error.h"
#include "misc.h"
#include "main.h"
#include "typequiv.h"
#include "chk_expr.h"
#include "warning.h"

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

@ -11,57 +11,64 @@
#include <stdlib.h>
#include <string.h>
#include "parameters.h"
#include "parameters.h"
#include "debug.h"
#include <alloc.h>
#include <em_arith.h>
#include <em_label.h>
#include <em_code.h>
#include <assert.h>
#include "alloc.h"
#include "em_arith.h"
#include "em_label.h"
#include "em_code.h"
#include "typequiv.h"
#include "LLlex.h"
#include "main.h"
#include "def.h"
#include "type.h"
#include "idf.h"
#include "print.h"
#include "scope.h"
#include "lookup.h"
#include "node.h"
#include "misc.h"
#include "Lpars.h"
#include "warning.h"
#include "error.h"
extern char *sprint();
STATIC
internal(c)
register char *c;
static void internal(register char *c)
{
if (options['x']) {
if (options['x'])
{
C_exp(c);
}
else C_inp(c);
else
C_inp(c);
}
STATIC
DefInFront(df)
register t_def *df;
static void DefInFront(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.
*/
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) {
if (df1 != df)
{
/* Definition "df" is not in front of the list
*/
while (df1) {
*/
while (df1)
{
/* Find definition "df"
*/
if (df1->df_nextinscope == df) {
*/
if (df1->df_nextinscope == df)
{
/* It already was in the list. Remove it
*/
*/
df1->df_nextinscope = df->df_nextinscope;
break;
}
@ -69,20 +76,17 @@ DefInFront(df)
}
/* 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;
t_def *MkDef(register t_idf *id, register t_scope *scope, int kind)
{
/* Create a new definition structure in scope "scope", with
id "id" and kind "kind".
*/
id "id" and kind "kind".
*/
register t_def *df;
df = new_def();
@ -91,40 +95,42 @@ MkDef(id, scope, kind)
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)) {
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;
t_def *define(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.
*/
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) {
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);
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;
}
@ -132,10 +138,11 @@ define(id, scope, kind)
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) {
definition of this type.
*/
if (kind == D_TYPE && df->df_scope == CurrentScope
&& !DefinitionModule)
{
df->df_kind = D_TYPE;
return df;
}
@ -143,14 +150,16 @@ define(id, scope, kind)
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)) {
another one, or we may have found the definition
for this module.
*/
if (kind & (D_FORWMODULE | D_FORWARD))
{
return df;
}
if (kind == D_MODULE) {
if (kind == D_MODULE)
{
FreeNode(df->for_node);
df->mod_vis = df->for_vis;
df->df_kind = kind;
@ -160,33 +169,38 @@ define(id, scope, kind)
break;
case D_TYPE:
if (kind == D_FORWTYPE) return df;
if (kind == D_FORWTYPE)
return df;
break;
case D_FORWTYPE:
if (kind & (D_FORWTYPE|D_TYPE)) return df;
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))) {
found a definition.
*/
if (!(kind & (D_FORWARD | D_FORWMODULE)))
{
FreeNode(df->for_node);
}
df->df_kind = D_ERROR; /* avoiding error message */
df->df_kind = D_ERROR; /* avoiding error message */
break;
}
if (kind != D_ERROR && df->df_kind != D_ERROR) {
if (kind != D_ERROR && df->df_kind != D_ERROR)
{
/* Avoid spurious error messages
*/
error("identifier \"%s\" already declared",
id->id_text);
*/
error("identifier \"%s\" already declared", id->id_text);
}
if (df->df_scope == scope || df->df_kind == D_ERROR) {
if (df->df_scope == scope || df->df_kind == D_ERROR)
{
df->df_kind = kind;
if (kind & (D_TYPE|D_PROCEDURE|D_CONST)) {
if (kind & (D_TYPE | D_PROCEDURE | D_CONST))
{
df->df_flags = D_DEFINED;
}
@ -197,43 +211,49 @@ define(id, scope, kind)
return MkDef(id, scope, kind);
}
end_definition_list(pdf)
register t_def **pdf;
void end_definition_list(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".
*/
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);
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 {
else
{
df->df_flags |= D_QEXPORTED;
pdf = &(df->df_nextinscope);
}
}
}
RemoveFromIdList(df)
register t_def *df;
void RemoveFromIdList(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) {
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;
}
@ -241,14 +261,12 @@ RemoveFromIdList(df)
}
}
t_def *
DeclProc(type, id)
register t_idf *id;
t_def * DeclProc(int type, 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.
*/
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;
@ -256,38 +274,45 @@ DeclProc(type, id)
assert(type & (D_PROCEDURE | D_PROCHEAD));
if (type == 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) {
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));
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) {
if (CurrVis == Defined->mod_vis)
{
/* The current module will define this routine.
make sure the name is exported.
*/
make sure the name is exported.
*/
C_exp(df->prc_name);
}
}
else {
else
{
df = lookup(id, CurrentScope, D_IMPORTED, 0);
if (df && df->df_kind == D_PROCHEAD) {
if (df && df->df_kind == D_PROCHEAD)
{
/* C_exp already generated when we saw the definition
in the definition module
*/
in the definition module
*/
DefInFront(df);
}
else {
else
{
df = define(id, CurrentScope, type);
sprint(buf,"_%d_%s",++nmcount,id->id_text);
df->prc_name = Salloc(buf, (unsigned)(strlen(buf)+1));
sprint(buf, "_%d_%s", ++nmcount, id->id_text);
df->prc_name = Salloc(buf, (unsigned) (strlen(buf) + 1));
internal(buf);
df->df_flags |= D_DEFINED;
}
@ -301,32 +326,29 @@ DeclProc(type, id)
return df;
}
EndProc(df, id)
register t_def *df;
t_idf *id;
void EndProc(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.
*/
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)) {
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);
df->df_idf->id_text);
}
}
t_def *
DefineLocalModule(id)
t_idf *id;
t_def * DefineLocalModule(t_idf *id)
{
/* Create a definition for a local module. Also give it
a name to be used for code generation.
*/
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;
@ -335,12 +357,13 @@ DefineLocalModule(id)
sprint(buf, "_%d%s_", ++modulecount, id->id_text);
if (!df->mod_vis) {
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;
scope for it.
*/
open_scope(CLOSEDSCOPE);
df->mod_vis = CurrVis;
}
CurrVis = df->mod_vis;
@ -351,35 +374,33 @@ DefineLocalModule(id)
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.
*/
for this module is local.
*/
internal(buf);
return df;
}
CheckWithDef(df, tp)
register t_def *df;
t_type *tp;
void CheckWithDef(register t_def *df, t_type *tp)
{
/* Check the header of a procedure declaration against a
possible earlier definition in the definition module.
*/
possible earlier definition in the definition module.
*/
if (df->df_kind == D_PROCHEAD &&
df->df_type &&
df->df_type != error_type) {
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.
*/
in the definition module.
*/
if (!TstProcEquiv(tp, df->df_type)) {
if (!TstProcEquiv(tp, df->df_type))
{
error("inconsistent procedure declaration for \"%s\"",
df->df_idf->id_text);
df->df_idf->id_text);
}
FreeType(df->df_type);
df->df_kind = D_PROCEDURE;
@ -388,8 +409,7 @@ CheckWithDef(df, tp)
}
#ifdef DEBUG
PrDef(df)
register t_def *df;
void PrDef(register t_def *df)
{
print("n: %s, k: %d\n", df->df_idf->id_text, df->df_kind);
}

24
lang/m2/comp/def.xh
View file

@ -4,6 +4,8 @@
*
* Author: Ceriel J.H. Jacobs
*/
#ifndef DEF_H_
#define DEF_H_
/* 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 */
@ -132,12 +134,20 @@ struct def { /* list of definitions for a name */
typedef struct def t_def;
/* ALLOCDEF "def" 50 */
extern t_def
*define(),
*DefineLocalModule(),
*MkDef(),
*DeclProc(),
*lookup(),
*lookfor();
#define NULLDEF ((t_def *) 0)
typedef struct scope t_scope;
typedef struct idf t_idf;
typedef struct type t_type;
t_def *MkDef(register t_idf *id, register t_scope *scope, int kind);
t_def *define(register t_idf *id, register t_scope *scope, int kind);
void RemoveFromIdList(register t_def *df);
t_def * DeclProc(int type, register t_idf *id);
void EndProc(register t_def *df, t_idf *id);
t_def * DefineLocalModule(t_idf *id);
void CheckWithDef(register t_def *df, t_type *tp);
void end_definition_list(register t_def **pdf);
#endif /* DEF_H_ */

15
lang/m2/comp/defmodule.c
View file

@ -26,9 +26,12 @@
#include "f_info.h"
#include "idf.h"
#include "input.h"
#include "error.h"
#include "main.h"
#include "misc.h"
#include "node.h"
#include "lookup.h"
#include "main.h"
#include "scope.h"
#include "type.h"
@ -36,13 +39,13 @@
size_t sys_filesize();
#endif
extern void DefModule(void); /* Lpars */
t_idf* DefId;
char*
getwdir(fn) register char* fn;
char* getwdir(register char *fn)
{
register char* p;
char* strrchr();
while ((p = strrchr(fn, '/')) && *(p + 1) == '\0')
{
@ -60,8 +63,7 @@ char*
return "";
}
STATIC int
GetFile(name) char* name;
static int GetFile(char *name)
{
/* Try to find a file with basename "name" and extension ".def",
in the directories mentioned in "DEFPATH".
@ -88,8 +90,7 @@ GetFile(name) char* name;
return 1;
}
t_def*
GetDefinitionModule(id, incr) register t_idf* id;
t_def* GetDefinitionModule(register t_idf* id, int incr)
{
/* Return a pointer to the "def" structure of the definition
module indicated by "id".

75
lang/m2/comp/desig.c
View file

@ -16,14 +16,14 @@
or perform a store.
*/
#include "parameters.h"
#include "parameters.h"
#include "debug.h"
#include <em_arith.h>
#include <em_label.h>
#include <em_code.h>
#include <assert.h>
#include <alloc.h>
#include "em_arith.h"
#include "em_label.h"
#include "em_code.h"
#include "alloc.h"
#include "type.h"
#include "LLlex.h"
@ -32,16 +32,15 @@
#include "desig.h"
#include "node.h"
#include "warning.h"
#include "error.h"
#include "code.h"
#include "tmpvar.h"
#include "walk.h"
extern int proclevel;
extern arith NewPtr();
extern char options[];
int
WordOrDouble(ds, size)
t_desig *ds;
arith size;
static int WordOrDouble(t_desig *ds, arith size)
{
/* Check if designator is suitable for word or double-word
operation
@ -53,8 +52,7 @@ WordOrDouble(ds, size)
return 0;
}
LOL(offset, size)
arith offset, size;
void LOL(arith offset, arith size)
{
if (size == word_size) {
C_lol(offset);
@ -68,8 +66,7 @@ LOL(offset, size)
}
}
STL(offset, size)
arith offset, size;
void STL(arith offset, arith size)
{
if (size == word_size) {
C_stl(offset);
@ -83,10 +80,7 @@ STL(offset, size)
}
}
int
DoLoad(ds, size)
register t_desig *ds;
arith size;
int DoLoad(register t_desig *ds, arith size)
{
/* Try to load designator with word or double-word operation.
Return 0 if not done
@ -110,10 +104,7 @@ DoLoad(ds, size)
return 1;
}
int
DoStore(ds, size)
register t_desig *ds;
arith size;
int DoStore(register t_desig *ds, arith size)
{
/* Try to store designator with word or double-word operation.
Return 0 if not done
@ -161,9 +152,7 @@ DoStore(ds, size)
multiple of word_size only
*/
STATIC int
suitable_move(tp)
register t_type *tp;
static int suitable_move(register t_type *tp)
{
/* Find out how to load or store the value indicated by "ds".
There are four ways:
@ -181,9 +170,7 @@ suitable_move(tp)
return USE_BLM;
}
CodeValue(ds, tp)
register t_desig *ds;
register t_type *tp;
void CodeValue(register t_desig *ds, register t_type *tp)
{
/* Generate code to load the value of the designator described
in "ds".
@ -246,8 +233,7 @@ CodeValue(ds, tp)
ds->dsg_kind = DSG_LOADED;
}
ChkForFOR(nd)
register t_node *nd;
void ChkForFOR(register t_node *nd)
{
/* Check for an assignment to a FOR-loop control variable
*/
@ -264,9 +250,7 @@ ChkForFOR(nd)
}
}
CodeStore(ds, tp)
register t_desig *ds;
register t_type *tp;
void CodeStore(register t_desig *ds, register t_type *tp)
{
/* Generate code to store the value on the stack in the designator
described in "ds"
@ -311,9 +295,7 @@ CodeStore(ds, tp)
ds->dsg_kind = DSG_INIT;
}
CodeCopy(lhs, rhs, sz, psize)
register t_desig *lhs, *rhs;
arith sz, *psize;
void CodeCopy(register t_desig *lhs, register t_desig *rhs, arith sz, arith *psize)
{
/* Do part of a copy, which is assumed to be "reasonable",
so that it can be done with LOI/STI or BLM.
@ -338,10 +320,7 @@ CodeCopy(lhs, rhs, sz, psize)
t_desig null_desig;
CodeMove(rhs, left, rtp)
register t_desig *rhs;
register t_node *left;
t_type *rtp;
void CodeMove(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.
@ -440,8 +419,7 @@ CodeMove(rhs, left, rtp)
}
}
CodeAddress(ds)
register t_desig *ds;
void CodeAddress(register t_desig *ds)
{
/* Generate code to load the address of the designator described
in "ds"
@ -481,9 +459,7 @@ CodeAddress(ds)
ds->dsg_kind = DSG_PLOADED;
}
CodeFieldDesig(df, ds)
register t_def *df;
register t_desig *ds;
void CodeFieldDesig(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
@ -533,10 +509,7 @@ CodeFieldDesig(df, ds)
}
}
void
CodeVarDesig(df, ds)
register t_def *df;
register t_desig *ds;
void CodeVarDesig(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,
@ -612,9 +585,7 @@ CodeVarDesig(df, ds)
ds->dsg_def = df;
}
CodeDesig(nd, ds)
register t_node *nd;
register t_desig *ds;
void CodeDesig(register t_node *nd, register t_desig *ds)
{
/* Generate code for a designator. Use divide and conquer
principle

22
lang/m2/comp/desig.h
View file

@ -4,11 +4,15 @@
*
* Author: Ceriel J.H. Jacobs
*/
#ifndef DESIG_H_
#define DESIG_H_
/* D E S I G N A T O R D E S C R I P T I O N S */
/* $Id$ */
#include <em_arith.h>
/* 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.
@ -65,3 +69,21 @@ struct withdesig {
extern struct withdesig *WithDesigs;
#define NO_LABEL ((label) 0)
typedef struct type t_type;
typedef struct node t_node;
void LOL(arith offset, arith size);
void STL(arith offset, arith size);
void CodeValue(register t_desig *ds, register t_type *tp);
void ChkForFOR(register t_node *nd);
void CodeStore(register t_desig *ds, register t_type *tp);
void CodeCopy(register t_desig *lhs, register t_desig *rhs, arith sz, arith *psize);
void CodeMove(register t_desig *rhs, register t_node *left, t_type *rtp);
void CodeAddress(register t_desig *ds);
void CodeFieldDesig(register t_def *df, register t_desig *ds);
void CodeVarDesig(register t_def *df, register t_desig *ds);
void CodeDesig(register t_node *nd, register t_desig *ds);
#endif /* DESIG_H_ */

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

@ -22,20 +22,24 @@
#include "em_code.h"
#include "assert.h"
#include "enter.h"
#include "idf.h"
#include "LLlex.h"
#include "def.h"
#include "type.h"
#include "error.h"
#include "scope.h"
#include "node.h"
#include "stab.h"
#include "main.h"
#include "lookup.h"
#include "misc.h"
#include "f_info.h"
t_def *
Enter(name, kind, type, pnam)
char *name;
t_type *type;
static t_def *DoImport(register t_def *, t_scope *, int);
t_def *Enter(char *name, int kind, t_type *type, int pnam)
{
/* Enter a definition for "name" with kind "kind" and type
"type" in the Current Scope. If it is a standard name, also
@ -52,10 +56,7 @@ Enter(name, kind, type, pnam)
return df;
}
t_def *
EnterType(name, type)
char *name;
t_type *type;
t_def *EnterType(char *name, t_type *type)
{
/* Enter a type definition for "name" and type
"type" in the Current Scope.
@ -64,9 +65,7 @@ EnterType(name, type)
return Enter(name, D_TYPE, type, 0);
}
EnterEnumList(Idlist, type)
t_node *Idlist;
register t_type *type;
void EnterEnumList(t_node *Idlist, register t_type *type)
{
/* Put a list of enumeration literals in the symbol table.
They all have type "type".
@ -92,11 +91,8 @@ EnterEnumList(Idlist, type)
FreeNode(Idlist);
}
EnterFieldList(Idlist, type, scope, addr)
t_node *Idlist;
register t_type *type;
t_scope *scope;
arith *addr;
void EnterFieldList(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".
@ -116,15 +112,8 @@ EnterFieldList(Idlist, type, scope, addr)
FreeNode(Idlist);
}
EnterVarList(Idlist, type, local)
t_node *Idlist;
t_type *type;
void EnterVarList(t_node *Idlist, t_type *type, int local)
{
/* 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;
@ -191,17 +180,12 @@ EnterVarList(Idlist, type, local)
FreeNode(Idlist);
}
EnterParamList(ppr, Idlist, type, VARp, off)
t_param **ppr;
t_node *Idlist;
t_type *type;
int VARp;
arith *off;
void EnterParamList(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;
@ -245,12 +229,8 @@ EnterParamList(ppr, Idlist, type, VARp, off)
FreeNode(Idlist);
}
STATIC t_def *DoImport();
void
ImportEffects(idef, scope, flag)
register t_def *idef;
t_scope *scope;
static void ImportEffects(register t_def *idef, t_scope *scope, int flag)
{
/* Handle side effects of an import:
- a module could have unqualified exports ???
@ -316,10 +296,7 @@ ImportEffects(idef, scope, flag)
}
}
STATIC t_def *
DoImport(df, scope, flag)
register t_def *df;
t_scope *scope;
static t_def *DoImport(register t_def *df, t_scope *scope, int flag)
{
/* Definition "df" is imported to scope "scope".
*/
@ -332,10 +309,7 @@ DoImport(df, scope, flag)
}
STATIC
ForwModule(df, nd)
register t_def *df;
t_node *nd;
static void ForwModule(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.
@ -360,10 +334,7 @@ ForwModule(df, nd)
df->for_node = nd;
}
STATIC t_def *
ForwDef(ids, scope)
register t_node *ids;
t_scope *scope;
static t_def *ForwDef(register t_node *ids, t_scope *scope)
{
/* Enter a forward definition of "ids" in scope "scope",
if it is not already defined.
@ -379,14 +350,8 @@ ForwDef(ids, scope)
return df;
}
EnterExportList(Idlist, qualified)
t_node *Idlist;
void EnterExportList(t_node *Idlist, int qualified)
{
/* 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;
@ -461,8 +426,7 @@ EnterExportList(Idlist, qualified)
FreeNode(Idlist);
}
CheckForImports(df)
t_def *df;
void CheckForImports(t_def *df)
{
/* We have a definition for "df"; check all imports of
it for side-effects
@ -482,11 +446,7 @@ CheckForImports(df)
}
}
void
EnterFromImportList(idlist, FromDef, FromId)
register t_node *idlist;
register t_def *FromDef;
t_node *FromId;
void EnterFromImportList(t_node *idlist, t_def *FromDef, t_node *FromId)
{
/* Import the list Idlist from the module indicated by Fromdef.
*/
@ -544,9 +504,7 @@ node_error(FromId,"identifier \"%s\" does not represent a module",module_name);
FreeNode(FromId);
}
EnterImportList(idlist, local, sc)
register t_node *idlist;
t_scope *sc;
void EnterImportList(t_node *idlist, int local, t_scope *sc)
{
/* Import "idlist" from scope "sc".
If the import is not local, definition modules must be read

46
lang/m2/comp/enter.h Normal file
View file

@ -0,0 +1,46 @@
/* Copyright (c) 2019 ACK Project.
* See the copyright notice in the ACK home directory,
* in the file "Copyright".
*
* Created on: 2019-02-27
*
*/
#ifndef ENTER_H_
#define ENTER_H_
/* Forward declarations. */
typedef struct type t_type;
typedef struct def t_def;
typedef struct node t_node;
typedef struct scope t_scope;
typedef struct paramlist t_param;
t_def *Enter(char *name, int kind, t_type *type, int pnam);
t_def *EnterType(char *name, t_type *type);
void EnterEnumList(t_node *Idlist, register t_type *type);
void EnterFieldList(t_node *Idlist, register t_type *type, t_scope *scope,
arith *addr);
/* 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.
*/
void EnterVarList(t_node *Idlist, t_type *type, int local);
/* 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.
*/
void EnterParamList(t_param **ppr, t_node *Idlist, t_type *type,
int VARp, arith *off);
/* 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".
*/
void EnterExportList(t_node *Idlist, int qualified);
void CheckForImports(t_def *df);
void EnterFromImportList(t_node *idlist, t_def *FromDef, t_node *FromId);
void EnterImportList(t_node *idlist, int local, t_scope *sc);
#endif /* ENTER_H_ */

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

@ -30,10 +30,12 @@
#include "input.h"
#include "f_info.h"
#include "print.h"
#include "LLlex.h"
#include "main.h"
#include "node.h"
#include "warning.h"
#include "error.h"
/* error classes */
#define ERROR 1
@ -60,13 +62,12 @@ extern char *symbol2str();
FileName, node errors get their information from the
node, whereas other errors use the information in the token.
*/
void _error();
static void _error(int, t_node *, char *, register va_list, int);
#if __STDC__
#ifdef DEBUG
/*VARARGS*/
debug(char *fmt, ...)
void debug(char *fmt, ...)
{
va_list ap;
@ -79,7 +80,7 @@ debug(char *fmt, ...)
#endif /* DEBUG */
/*VARARGS*/
error(char *fmt, ...)
void error(char *fmt, ...)
{
va_list ap;
@ -91,7 +92,7 @@ error(char *fmt, ...)
}
/*VARARGS*/
node_error(t_node *node, char *fmt, ...)
void node_error(t_node *node, char *fmt, ...)
{
va_list ap;
@ -103,7 +104,7 @@ node_error(t_node *node, char *fmt, ...)
}
/*VARARGS*/
warning(int class, char *fmt, ...)
void warning(int class, char *fmt, ...)
{
va_list ap;
@ -115,7 +116,7 @@ warning(int class, char *fmt, ...)
}
/*VARARGS*/
node_warning(t_node *node, int class, char *fmt, ...)
void node_warning(t_node *node, int class, char *fmt, ...)
{
va_list ap;
@ -127,7 +128,7 @@ node_warning(t_node *node, int class, char *fmt, ...)
}
/*VARARGS*/
lexerror(char *fmt, ...)
void lexerror(char *fmt, ...)
{
va_list ap;
@ -139,7 +140,7 @@ lexerror(char *fmt, ...)
}
/*VARARGS*/
lexwarning(int class, char *fmt, ...)
void lexwarning(int class, char *fmt, ...)
{
va_list ap;
@ -151,7 +152,7 @@ lexwarning(int class, char *fmt, ...)
}
/*VARARGS*/
fatal(char *fmt, ...)
void fatal(char *fmt, ...)
{
va_list ap;
@ -164,7 +165,7 @@ fatal(char *fmt, ...)
}
/*VARARGS*/
crash(char *fmt, ...)
void crash(char *fmt, ...)
{
va_list ap;
@ -182,7 +183,7 @@ crash(char *fmt, ...)
#else
#ifdef DEBUG
/*VARARGS*/
debug(va_alist)
void debug(va_alist)
va_dcl
{
va_list ap;
@ -197,7 +198,7 @@ debug(va_alist)
#endif /* DEBUG */
/*VARARGS*/
error(va_alist)
void error(va_alist)
va_dcl
{
va_list ap;
@ -211,7 +212,7 @@ error(va_alist)
}
/*VARARGS*/
node_error(va_alist)
void node_error(va_alist)
va_dcl
{
va_list ap;
@ -226,7 +227,7 @@ node_error(va_alist)
}
/*VARARGS*/
warning(va_alist)
void warning(va_alist)
va_dcl
{
va_list ap;
@ -241,7 +242,7 @@ warning(va_alist)
}
/*VARARGS*/
node_warning(va_alist)
void node_warning(va_alist)
va_dcl
{
va_list ap;
@ -257,7 +258,7 @@ node_warning(va_alist)
}
/*VARARGS*/
lexerror(va_alist)
void lexerror(va_alist)
va_dcl
{
va_list ap;
@ -271,7 +272,7 @@ lexerror(va_alist)
}
/*VARARGS*/
lexwarning(va_alist)
void lexwarning(va_alist)
va_dcl
{
va_list ap;
@ -286,7 +287,7 @@ lexwarning(va_alist)
}
/*VARARGS*/
fatal(va_alist)
void fatal(va_alist)
va_dcl
{
va_list ap;
@ -301,7 +302,7 @@ fatal(va_alist)
}
/*VARARGS*/
crash(va_alist)
void crash(va_alist)
va_dcl
{
va_list ap;
@ -320,13 +321,7 @@ crash(va_alist)
}
#endif
void
_error(class, node, fmt, ap, warn_class)
int class;
t_node *node;
char *fmt;
register va_list ap;
int warn_class;
static void _error(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.

60
lang/m2/comp/error.h Normal file
View file

@ -0,0 +1,60 @@
/* Copyright (c) 2019 ACK Project.
* See the copyright notice in the ACK home directory,
* in the file "Copyright".
*
* Created on: 2019-02-26
*
*/
#ifndef ERROR_H_
#define ERROR_H_
typedef struct node t_node;
#if __STDC__
#ifdef DEBUG
/*VARARGS*/
void debug(char *fmt, ...);
#endif /* DEBUG */
/*VARARGS*/
void error(char *fmt, ...);
/*VARARGS*/
void node_error(t_node *node, char *fmt, ...);
/*VARARGS*/
void warning(int class, char *fmt, ...);
/*VARARGS*/
void node_warning(t_node *node, int class, char *fmt, ...);
/*VARARGS*/
void lexerror(char *fmt, ...);
/*VARARGS*/
void lexwarning(int class, char *fmt, ...);
/*VARARGS*/
void fatal(char *fmt, ...);
/*VARARGS*/
void crash(char *fmt, ...);
#else
#ifdef DEBUG
/*VARARGS*/
void debug(va_alist);
#endif /* DEBUG */
/*VARARGS*/
void error(va_alist);
/*VARARGS*/
void node_error(va_alist);
/*VARARGS*/
void warning(va_alist);
/*VARARGS*/
void node_warning(va_alist);
/*VARARGS*/
void lexerror(va_alist);
/*VARARGS*/
void lexwarning(va_alist);
/*VARARGS*/
void fatal(va_alist);
/*VARARGS*/
void crash(va_alist);
#endif
#endif /* ERROR_H_ */

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

@ -10,12 +10,12 @@
/* $Id$ */
{
#include "parameters.h"
#include "parameters.h"
#include "debug.h"
#include <alloc.h>
#include <em_arith.h>
#include <em_label.h>
#include "alloc.h"
#include "em_arith.h"
#include "em_label.h"
#include <assert.h>
#include "LLlex.h"
@ -23,6 +23,7 @@
#include "def.h"
#include "node.h"
#include "type.h"
#include "error.h"
#include "chk_expr.h"
#include "warning.h"

2
lang/m2/comp/idf.c
View file

@ -9,6 +9,6 @@
/* $Id$ */
#include "parameters.h"
#include "parameters.h"
#include "idf.h"
#include <idf_pkg.body>

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

@ -13,10 +13,10 @@
#include <stdio.h>
#include <string.h>
#include "parameters.h"
#include "f_info.h"
#include "f_info.h"
struct f_info file_info;
#include "input.h"
#include <inp_pkg.body>
#include "input.h"
#include <inp_pkg.body>
int AtEoIF(void)

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

@ -9,13 +9,14 @@
/* $Id$ */
#include "parameters.h"
#include "parameters.h"
#include "debug.h"
#include <em_arith.h>
#include <em_label.h>
#include <assert.h>
#include "lookup.h"
#include "LLlex.h"
#include "def.h"
#include "idf.h"
@ -29,10 +30,7 @@ extern int pass_1;
extern char options[];
#endif
t_def *
lookup(id, scope, import, flags)
register t_idf *id;
t_scope *scope;
t_def *lookup(register t_idf *id, t_scope *scope, int import, int flags)
{
/* Look up a definition of an identifier in scope "scope".
Make the "def" list self-organizing.
@ -74,10 +72,7 @@ lookup(id, scope, import, flags)
return df;
}
t_def *
lookfor(id, vis, message, flags)
register t_node *id;
register t_scopelist *vis;
t_def *lookfor(register t_node *id, register t_scopelist *vis, int message, int flags)
{
/* Look for an identifier in the visibility range started by "vis".
If it is not defined create a dummy definition and,

21
lang/m2/comp/lookup.h Normal file
View file

@ -0,0 +1,21 @@
/* Copyright (c) 2019 ACK Project.
* See the copyright notice in the ACK home directory,
* in the file "Copyright".
*
* Created on: 2019-02-27
*
*/
#ifndef LOOKUP_H_
#define LOOKUP_H_
/* Forward declarations. */
typedef struct idf t_idf;
typedef struct scope t_scope;
typedef struct node t_node;
typedef struct def t_def;
typedef struct scopelist t_scopelist;
t_def *lookup(register t_idf *id, t_scope *scope, int import, int flags);
t_def *lookfor(register t_node *id, register t_scopelist *vis, int message, int flags);
#endif /* LOOKUP_H_ */

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

@ -9,15 +9,17 @@
/* $Id$ */
#include "parameters.h"
#include "parameters.h"
#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 "system.h"
#include "em_arith.h"
#include "em_label.h"
#include "em_code.h"
#include "print.h"
#include "alloc.h"
#include <stb.h>
#include "input.h"
@ -31,24 +33,39 @@
#include "standards.h"
#include "tokenname.h"
#include "node.h"
#include "walk.h"
#include "cstoper.h"
#include "error.h"
#include "options.h"
#include "warning.h"
#include "SYSTEM.h"
#include "SYSTEMM2.h"
int state; /* either IMPLEMENTATION or PROGRAM */
char options[128];
char options[128];
int DefinitionModule;
char *ProgName;
char **DEFPATH;
char *ProgName;
char **DEFPATH;
int nDEF = 2, mDEF = 10;
int pass_1 = 1;
t_def *Defined;
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;
/* Forward declarations. */
struct stdproc;
int Compile(char *, char *);
static void AddProcs(register struct stdproc *);
static void AddStandards(void);
/* External function declarations */
extern void CompUnit(void);
extern void DefModule(void); /* Lpars */
extern void reserve(register struct tokenname *); /* tokenname */
char* getwdir(register char *); /* defmodule */
int main(int argc, char **argv)
{
register int Nargc = 1;
register char **Nargv = &argv[0];
@ -72,11 +89,9 @@ main(argc, argv)
/*NOTREACHED*/
}
Compile(src, dst)
char *src, *dst;
int Compile(char *src, char *dst)
{
extern struct tokenname tkidf[];
extern char *getwdir();
if (! InsertFile(src, (char **) 0, &src)) {
fprint(STDERR,"%s: cannot open %s\n", ProgName, src);
@ -126,7 +141,7 @@ Compile(src, dst)
}
#ifdef DEBUG
LexScan()
void LexScan(void)
{
register t_token *tkp = &dot;
extern char *symbol2str();
@ -198,8 +213,7 @@ static struct stdproc sysprocs[] = {
extern t_def *Enter(), *EnterType();
AddProcs(p)
register struct stdproc *p;
static void AddProcs(register struct stdproc *p)
{
for (; p->st_nam != 0; p++) {
if (! Enter(p->st_nam, D_PROCEDURE, std_type, p->st_con)) {
@ -208,7 +222,7 @@ AddProcs(p)
}
}
AddStandards()
static void AddStandards(void)
{
register t_def *df;
static t_token nilconst = { INTEGER, 0};
@ -238,7 +252,7 @@ AddStandards()
EnterType("BOOLEAN", bool_type);
}
do_SYSTEM()
void do_SYSTEM(void)
{
/* Simulate the reading of the SYSTEM definition module
*/
@ -258,7 +272,7 @@ do_SYSTEM()
int cntlines;
Info()
void Info(void)
{
extern int cnt_def, cnt_node, cnt_paramlist, cnt_type,
cnt_switch_hdr, cnt_case_entry,
@ -274,14 +288,12 @@ print("\nNumber of lines read: %d\n", cntlines);
}
#endif
void
No_Mem()
void No_Mem(void)
{
fatal("out of memory");
}
void
C_failed()
void C_failed(void)
{
fatal("write failed");
}

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

@ -6,8 +6,8 @@
*/
/* S O M E G L O B A L V A R I A B L E S */
/* $Id$ */
#ifndef MAIN_H_
#define MAIN_H_
extern char options[]; /* indicating which options were given */
@ -23,3 +23,7 @@ extern struct def *Defined;
extern char **DEFPATH; /* search path for DEFINITION MODULE's */
extern int mDEF, nDEF;
extern int state; /* either IMPLEMENTATION or PROGRAM */
void do_SYSTEM(void);
#endif /* MAIN_H_ */

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

@ -17,15 +17,15 @@
#include "em_arith.h"
#include "em_label.h"
#include "parameters.h"
#include "parameters.h"
#include "f_info.h"
#include "misc.h"
#include "LLlex.h"
#include "idf.h"
#include "node.h"
#include "error.h"
match_id(id1, id2)
register t_idf *id1, *id2;
void match_id(register t_idf *id1, t_idf *id2)
{
/* Check that identifiers id1 and id2 are equal. If they
are not, check that we did'nt generate them in the
@ -39,8 +39,7 @@ match_id(id1, id2)
}
}
t_idf *
gen_anon_idf()
t_idf *gen_anon_idf(void)
{
/* A new idf is created out of nowhere, to serve as an
anonymous name.
@ -55,9 +54,7 @@ gen_anon_idf()
return str2idf(s, 0);
}
not_declared(what, id, where)
char *what, *where;
register t_node *id;
void not_declared(char *what, t_node *id, char *where)
{
/* The identifier "id" is not declared. If it is not generated,
give an error message

9
lang/m2/comp/misc.h
View file

@ -12,5 +12,10 @@
#define is_anon_idf(x) ((x)->id_text[0] == '#')
#define id_not_declared(x) (not_declared("identifier", (x), ""))
extern struct idf
*gen_anon_idf();
/* Forward declarations. */
typedef struct idf t_idf;
typedef struct node t_node;
void match_id(register t_idf *id1, t_idf *id2);
t_idf *gen_anon_idf(void);
void not_declared(char *what, t_node *id, char *where);

1
lang/m2/comp/next.in Normal file
View file

@ -0,0 +1 @@
#include "parameters.h"

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

@ -22,6 +22,7 @@
#include "type.h"
#include "node.h"
#include "main.h"
#include "error.h"
static int nsubnodes[] = {
0,
@ -39,8 +40,7 @@ static int nsubnodes[] = {
2
};
t_node *
getnode(class)
t_node *getnode(int class)
{
register t_node *nd = new_node();
@ -50,9 +50,7 @@ getnode(class)
return nd;
}
t_node *
dot2node(class, left, right)
t_node *left, *right;
t_node *dot2node(int class, t_node *left, t_node *right)
{
register t_node *nd = getnode(class);
@ -63,8 +61,7 @@ dot2node(class, left, right)
return nd;
}
t_node *
dot2leaf(class)
t_node *dot2leaf(int class)
{
register t_node *nd = getnode(class);
@ -81,15 +78,13 @@ dot2leaf(class)
return nd;
}
void
FreeNode(nd)
register t_node *nd;
void FreeNode(register t_node *nd)
{
/* Put nodes that are no longer needed back onto the free
list
*/
if (!nd) return;
switch(nsubnodes[nd->nd_class]) {
switch(nsubnodes[(unsigned int)nd->nd_class]) {
case 2:
FreeNode(nd->nd_LEFT);
FreeNode(nd->nd_RIGHT);
@ -102,15 +97,13 @@ FreeNode(nd)
}
/*ARGSUSED*/
NodeCrash(expp)
t_node *expp;
int NodeCrash(register t_node* expp, label exit_label, int end_reached)
{
crash("(NodeCrash) Illegal node");
}
/*ARGSUSED*/
PNodeCrash(expp)
t_node **expp;
int PNodeCrash(t_node **expp, int flags)
{
crash("(PNodeCrash) Illegal node");
}
@ -119,15 +112,14 @@ PNodeCrash(expp)
extern char *symbol2str();
indnt(lvl)
void indnt(int lvl)
{
while (lvl--) {
print(" ");
}
}
printnode(nd, lvl)
register t_node *nd;
void printnode(register t_node *nd, int lvl)
{
indnt(lvl);
print("Class: %d; Symbol: %s; Flags: %d\n", nd->nd_class, symbol2str(nd->nd_symb), nd->nd_flags);
@ -139,8 +131,7 @@ printnode(nd, lvl)
}
}
PrNode(nd, lvl)
register t_node *nd;
void PrNode(register t_node *nd, int lvl)
{
if (! nd) {
indnt(lvl); print("<nilnode>\n");

10
lang/m2/comp/node.xh
View file

@ -61,3 +61,13 @@ extern t_node *dot2node(), *dot2leaf(), *getnode();
#define IsCast(lnd) ((lnd)->nd_class == Def && is_type((lnd)->nd_def))
#define IsProc(lnd) ((lnd)->nd_type->tp_fund == T_PROCEDURE)
t_node *getnode(int class);
t_node *dot2node(int class, t_node *left, t_node *right);
t_node *dot2leaf(int class);
void FreeNode(register t_node *nd);
int NodeCrash(register t_node* expp, label exit_label, int end_reached);
int PNodeCrash(t_node **expp, int flags);

46
lang/m2/comp/options.c
View file

@ -19,6 +19,7 @@
#include "main.h"
#include "warning.h"
#include "class.h"
#include "error.h"
#define MINIDFSIZE 14
@ -32,13 +33,30 @@ static int ndirs = 1;
int warning_classes = W_INITIAL;
int gdb_flag;
DoOption(text)
register char *text;
#if (!SQUEEZE) | (!NOCROSS)
static int txt2int(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
void DoOption(register char *text)
{
switch(*text++) {
case '-':
options[*text]++; /* debug options etc. */
options[(unsigned int)*text]++; /* debug options etc. */
break;
case 'U': /* allow underscores in identifiers */
@ -54,7 +72,7 @@ DoOption(text)
case 's': /* symmetric: MIN(INTEGER) = -MAX(INTEGER) */
case '3': /* strict 3rd edition Modula-2 */
case 'l': /* local additions enabled */
options[text[-1]]++;
options[(unsigned int)text[-1]]++;
break;
#ifdef DBSYMTAB
@ -162,7 +180,7 @@ DoOption(text)
char c;
char *t;
while (c = *text++) {
while ( (c = *text++) != 0) {
char *strchr();
t = text;
@ -235,21 +253,3 @@ DoOption(text)
}
}
#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

13
lang/m2/comp/options.h Normal file
View file

@ -0,0 +1,13 @@
/* Copyright (c) 2019 ACK Project.
* See the copyright notice in the ACK home directory,
* in the file "Copyright".
*
* Created on: 2019-02-27
*
*/
#ifndef OPTIONS_H_
#define OPTIONS_H_
void DoOption(register char *text);
#endif /* OPTIONS_H_ */

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

@ -12,14 +12,14 @@
{
#include <stdlib.h>
#include <string.h>
#include "parameters.h"
#include "parameters.h"
#include "debug.h"
#include <alloc.h>
#include <em_arith.h>
#include <em_label.h>
#include <em_code.h>
#include <stb.h>
#include "alloc.h"
#include "em_arith.h"
#include "em_label.h"
#include "em_code.h"
#include "stb.h"
#include "main.h"
#include "idf.h"
@ -27,6 +27,10 @@
#include "scope.h"
#include "def.h"
#include "type.h"
#include "lookup.h"
#include "error.h"
#include "stab.h"
#include "enter.h"
#include "node.h"
#include "f_info.h"
#include "warning.h"

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

@ -6,8 +6,10 @@
*/
/* S C O P E M E C H A N I S M */
#ifndef SCOPE_H_
#define SCOPE_H_
/* $Id$ */
#define OPENSCOPE 0 /* Indicating an open scope */
#define CLOSEDSCOPE 1 /* Indicating a closed scope (module) */
@ -58,4 +60,17 @@ extern t_scopelist
#define scopeclosed(x) ((x)->sc_scopeclosed)
#define nextvisible(x) ((x)->sc_next) /* use with scopelists */
t_scope *open_and_close_scope();
typedef struct def t_def;
void Reverse(t_def **pdf);
void open_scope(int scopetype);
t_scope * open_and_close_scope(int scopetype);
void InitScope(void);
void close_scope(int flag);
#ifdef DEBUG
void DumpScope(register t_def *df);
#endif
#endif /* SCOPE_H_ */

36
lang/m2/comp/scope.xc
View file

@ -9,13 +9,13 @@
/* $Id$ */
#include "parameters.h"
#include "parameters.h"
#include "debug.h"
#include <assert.h>
#include <alloc.h>
#include <em_arith.h>
#include <em_label.h>
#include "alloc.h"
#include "em_arith.h"
#include "em_label.h"
#include "LLlex.h"
#include "idf.h"
@ -23,6 +23,8 @@
#include "type.h"
#include "def.h"
#include "node.h"
#include "lookup.h"
#include "error.h"
t_scope *PervasiveScope;
t_scopelist *CurrVis, *GlobalVis;
@ -35,7 +37,7 @@ extern char options[];
static int sc_count;
open_scope(scopetype)
void open_scope(int scopetype)
{
/* Open a scope that is either open (automatic imports) or closed.
*/
@ -55,8 +57,7 @@ open_scope(scopetype)
CurrVis = ls;
}
t_scope *
open_and_close_scope(scopetype)
t_scope * open_and_close_scope(int scopetype)
{
t_scope *sc;
@ -66,7 +67,7 @@ open_and_close_scope(scopetype)
return sc;
}
InitScope()
void InitScope(void)
{
register t_scope *sc = new_scope();
register t_scopelist *ls = new_scopelist();
@ -77,9 +78,7 @@ InitScope()
CurrVis = ls;
}
STATIC
chk_proc(df)
register t_def *df;
static void chk_proc(register t_def *df)
{
/* Called at scope closing. Check all definitions, and if one
is a D_PROCHEAD, the procedure was not defined.
@ -101,9 +100,7 @@ chk_proc(df)
}
}
STATIC
chk_forw(pdf)
t_def **pdf;
static void chk_forw(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
@ -111,7 +108,7 @@ chk_forw(pdf)
*/
register t_def *df;
while (df = *pdf) {
while ( (df = *pdf) ) {
if (df->df_kind == D_FORWTYPE) {
pdf = &df->df_nextinscope;
ForceForwardTypeDef(df); /* removes df */
@ -157,8 +154,7 @@ df->df_idf->id_text);
}
}
Reverse(pdf)
t_def **pdf;
void Reverse(t_def **pdf)
{
/* Reverse the order in the list of definitions in a scope.
This is neccesary because this list is built in reverse.
@ -184,8 +180,7 @@ Reverse(pdf)
*pdf = df;
}
close_scope(flag)
register int flag;
void close_scope(int flag)
{
/* Close a scope. If "flag" is set, check for forward declarations,
either POINTER declarations, or EXPORTs, or forward references
@ -208,8 +203,7 @@ close_scope(flag)
}
#ifdef DEBUG
DumpScope(df)
register t_def *df;
void DumpScope(register t_def *df)
{
while (df) {
PrDef(df);

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

@ -25,6 +25,8 @@
#include "type.h"
#include "idf.h"
#include "scope.h"
#include "error.h"
#include "stab.h"
#include "main.h"
extern int gdb_flag;
@ -40,8 +42,7 @@ static struct db_str {
char *currpos;
} db_str;
static
create_db_str()
static void create_db_str(void)
{
if (! db_str.base) {
db_str.base = Malloc(INCR_SIZE);
@ -50,9 +51,7 @@ create_db_str()
db_str.currpos = db_str.base;
}
static
addc_db_str(c)
int c;
static void addc_db_str(int c)
{
int df = db_str.currpos - db_str.base;
if (df >= db_str.sz-1) {
@ -64,16 +63,12 @@ addc_db_str(c)
*db_str.currpos = '\0';
}
static
adds_db_str(s)
char *s;
static void adds_db_str(char *s)
{
while (*s) addc_db_str(*s++);
}
static void
stb_type(tp, assign_num)
register t_type *tp;
static void stb_type(register t_type *tp, int assign_num)
{
char buf[128];
static int stb_count;
@ -254,9 +249,7 @@ stb_type(tp, assign_num)
}
}
stb_addtp(s, tp)
char *s;
t_type *tp;
void stb_addtp(char *s, t_type *tp)
{
create_db_str();
adds_db_str(s);
@ -272,8 +265,7 @@ stb_addtp(s, tp)
(arith) 0);
}
stb_string(df, kind)
register t_def *df;
void stb_string(register t_def *df, int kind)
{
register t_type *tp = df->df_type;
char buf[64];

19
lang/m2/comp/stab.h Normal file
View file

@ -0,0 +1,19 @@
/* Copyright (c) 2019 ACK Project.
* See the copyright notice in the ACK home directory,
* in the file "Copyright".
*
* Created on: 2019-02-27
*
*/
#ifndef STAB_H_
#define STAB_H_
/* D E B U G G E R S Y M B O L T A B L E */
typedef struct type t_type;
typedef struct def t_def;
void stb_addtp(char *s, t_type *tp);
void stb_string(register t_def *df, int kind);
#endif /* STAB_H_ */

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

@ -11,15 +11,16 @@
{
#include <assert.h>
#include <em_arith.h>
#include <em_label.h>
#include "em_arith.h"
#include "em_label.h"
#include "parameters.h"
#include "parameters.h"
#include "idf.h"
#include "LLlex.h"
#include "scope.h"
#include "def.h"
#include "type.h"
#include "error.h"
#include "node.h"
static int loopcount = 0; /* Count nested loops */

26
lang/m2/comp/tmpvar.h Normal file
View file

@ -0,0 +1,26 @@
/* Copyright (c) 2019 ACK Project.
* See the copyright notice in the ACK home directory,
* in the file "Copyright".
*
* Created on: 2019-02-27
*
*/
/* T E M P O R A R Y V A R I A B L E S */
#ifndef TMPVAR_H_
#define TMPVAR_H_
#include "em_arith.h"
typedef struct scope t_scope;
void TmpOpen(t_scope *sc);
arith TmpSpace(arith sz, int al);
arith NewInt(void);
arith NewPtr(void);
void FreeInt(arith off);
void FreePtr(arith off);
void TmpClose(void);
#endif /* TMPVAR_H_ */

34
lang/m2/comp/tmpvar.xc
View file

@ -16,7 +16,7 @@
have local variabes.
*/
#include "parameters.h"
#include "parameters.h"
#include "debug.h"
#include <em_arith.h>
@ -30,6 +30,7 @@
#include "def.h"
#include "type.h"
#include "scope.h"
#include "tmpvar.h"
#include "main.h"
struct tmpvar {
@ -45,16 +46,14 @@ static t_scope *ProcScope; /* scope of procedure in which the
temporaries are allocated
*/
TmpOpen(sc) t_scope *sc;
void TmpOpen(t_scope *sc)
{
/* Initialize for temporaries in scope "sc".
*/
ProcScope = sc;
}
arith
TmpSpace(sz, al)
arith sz;
arith TmpSpace(arith sz, int al)
{
register t_scope *sc = ProcScope;
@ -62,10 +61,7 @@ TmpSpace(sz, al)
return sc->sc_off;
}
STATIC arith
NewTmp(plist, sz, al, regtype)
register struct tmpvar **plist;
arith sz;
static arith NewTmp(struct tmpvar **plist, arith sz, int al, int regtype)
{
register arith offset;
register struct tmpvar *tmp;
@ -83,22 +79,18 @@ NewTmp(plist, sz, al, regtype)
return offset;
}
arith
NewInt()
arith NewInt(void)
{
return NewTmp(&TmpInts, int_size, int_align, reg_any);
}
arith
NewPtr()
arith NewPtr(void)
{
return NewTmp(&TmpPtrs, pointer_size, pointer_align, reg_pointer);
}
STATIC
FreeTmp(plist, off)
struct tmpvar **plist;
arith off;
static void FreeTmp(struct tmpvar **plist, arith off)
{
register struct tmpvar *tmp = new_tmpvar();
@ -107,19 +99,17 @@ FreeTmp(plist, off)
*plist = tmp;
}
FreeInt(off)
arith off;
void FreeInt(arith off)
{
FreeTmp(&TmpInts, off);
}
FreePtr(off)
arith off;
void FreePtr(arith off)
{
FreeTmp(&TmpPtrs, off);
}
TmpClose()
void TmpClose(void)
{
register struct tmpvar *tmp, *tmp1;

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

@ -9,10 +9,11 @@
/* $Id$ */
#include "parameters.h"
#include "parameters.h"
#include "tokenname.h"
#include "Lpars.h"
#include "idf.h"
#include "error.h"
/* To centralize the declaration of %tokens, their presence in this
file is taken as their declaration. The Makefile will produce
@ -98,8 +99,7 @@ struct tokenname tkstandard[] = { /* standard identifiers */
/* Some routines to handle tokennames */
reserve(resv)
register struct tokenname *resv;
void reserve(register struct tokenname *resv)
{
/* The names of the tokens described in resv are entered
as reserved words.

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

@ -9,7 +9,7 @@
/* $Id$ */
#include "parameters.h"
#include "parameters.h"
#include "debug.h"
#include <assert.h>
@ -25,7 +25,12 @@
#include "idf.h"
#include "node.h"
#include "scope.h"
#include "error.h"
#include "walk.h"
#include "lookup.h"
#include "stab.h"
#include "enter.h"
#include "typequiv.h"
#include "main.h"
#include "chk_expr.h"
#include "warning.h"
@ -73,12 +78,8 @@ t_type
*std_type,
*error_type;
void ArraySizes();
t_type *
construct_type(fund, tp)
int fund;
register t_type *tp;
t_type *construct_type(int fund, register t_type *tp)
{
/* fund must be a type constructor.
The pointer to the constructed type is returned.
@ -117,10 +118,10 @@ construct_type(fund, tp)
return dtp;
}
arith
align(pos, al)
arith pos;
int al;
/* Aligns "pos" to the specified alignment "al"
* and returns the aligned "pos".
*/
arith align(arith pos, int al)
{
int i = pos % al;
@ -128,11 +129,7 @@ align(pos, al)
return pos;
}
t_type *
standard_type(fund, algn, size)
int fund;
int algn;
arith size;
t_type *standard_type(int fund, int algn, arith size)
{
register t_type *tp = new_type();
@ -146,10 +143,8 @@ standard_type(fund, algn, size)
return tp;
}
InitTypes()
void InitTypes(void)
{
/* Initialize the predefined types
*/
register t_type *tp;
/* first, do some checking
@ -221,17 +216,12 @@ InitTypes()
void_type = error_type;
}
int
fit(sz, nbytes)
arith sz;
int fit(arith sz, int nbytes)
{
return ((sz) + ((arith)0x80<<(((nbytes)-1)*8)) & ~full_mask[(nbytes)]) == 0;
}
STATIC
u_small(tp, n)
register t_type *tp;
arith n;
static void u_small(register t_type *tp, arith n)
{
if (ufit(n, 1)) {
tp->tp_size = 1;
@ -243,9 +233,7 @@ u_small(tp, n)
}
}
t_type *
enum_type(EnumList)
t_node *EnumList;
t_type *enum_type(t_node *EnumList)
{
register t_type *tp =
standard_type(T_ENUMERATION, int_align, int_size);
@ -258,9 +246,7 @@ enum_type(EnumList)
return tp;
}
t_type *
qualified_type(pnd)
t_node **pnd;
t_type *qualified_type(t_node **pnd)
{
register t_def *df;
@ -296,26 +282,18 @@ node_error(nd, "identifier \"%s\" is not a type", df->df_idf->id_text);
}
int
chk_bounds(l1, l2, fund)
arith l1, l2;
int chk_bounds(arith l1, arith l2, int fund)
{
/* compare to arith's, but be careful. They might be unsigned
*/
if (fund == T_INTEGER) {
return l2 >= l1;
}
return (unsigned arith) l2 >= (unsigned arith) l1;
}
int
in_range(i, tp)
arith i;
register t_type *tp;
int in_range(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:
@ -330,16 +308,8 @@ in_range(i, tp)
/*NOTREACHED*/
}
t_type *
subr_type(lb, ub, base)
register t_node *lb;
t_node *ub;
t_type *base;
t_type *subr_type(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;
@ -428,11 +398,7 @@ subr_type(lb, ub, base)
return res;
}
t_type *
proc_type(result_type, parameters, n_bytes_params)
t_type *result_type;
t_param *parameters;
arith n_bytes_params;
t_type *proc_type(t_type *result_type, t_param *parameters, arith n_bytes_params)
{
register t_type *tp = construct_type(T_PROCEDURE, result_type);
@ -447,8 +413,7 @@ proc_type(result_type, parameters, n_bytes_params)
return tp;
}
genrck(tp)
register t_type *tp;
void genrck(register t_type *tp)
{
/* generate a range check descriptor for type "tp" when
neccessary. Return its label.
@ -483,13 +448,8 @@ genrck(tp)
}
}
getbounds(tp, plo, phi)
register t_type *tp;
arith *plo, *phi;
void getbounds(register t_type *tp, arith *plo, arith *phi)
{
/* Get the bounds of a bounded type
*/
assert(bounded(tp));
if (tp->tp_fund == T_SUBRANGE) {
@ -502,13 +462,9 @@ getbounds(tp, plo, phi)
}
}
t_type *
set_type(tp)
register t_type *tp;
t_type *set_type(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) {
@ -542,8 +498,7 @@ set_type(tp)
return tp;
}
ArrayElSize(tp)
register t_type *tp;
void ArrayElSize(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,
@ -569,9 +524,7 @@ ArrayElSize(tp)
}
}
void
ArraySizes(tp)
register t_type *tp;
void ArraySizes(register t_type *tp)
{
/* Assign sizes to an array type, and check index type
*/
@ -610,8 +563,7 @@ ArraySizes(tp)
C_rom_cst(tp->arr_elsize);
}
FreeType(tp)
register t_type *tp;
void FreeType(register t_type *tp)
{
/* Release type structures indicated by "tp".
This procedure is only called for types, constructed with
@ -632,10 +584,7 @@ FreeType(tp)
free_type(tp);
}
DeclareType(nd, df, tp)
register t_def *df;
register t_type *tp;
t_node *nd;
void DeclareType(t_node *nd, register t_def *df, register t_type *tp)
{
/* A type with type-description "tp" is declared and must
be bound to definition "df".
@ -677,8 +626,7 @@ DeclareType(nd, df, tp)
SolveForwardTypeRefs(df);
}
SolveForwardTypeRefs(df)
register t_def *df;
void SolveForwardTypeRefs(register t_def *df)
{
register t_node *nd;
@ -700,8 +648,7 @@ SolveForwardTypeRefs(df)
}
ForceForwardTypeDef(df)
register t_def *df;
void ForceForwardTypeDef(register t_def *df)
{
register t_def *df1 = df, *df2;
register t_node *nd = df->df_forw_node;
@ -735,18 +682,14 @@ ForceForwardTypeDef(df)
}
}
t_type *
RemoveEqual(tpx)
register t_type *tpx;
t_type *RemoveEqual(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;
int type_or_forward(t_type *tp)
{
/* POINTER TO IDENTIFIER construction. The IDENTIFIER resides
in "dot". This routine handles the different cases.
@ -809,9 +752,7 @@ type_or_forward(tp)
return 0;
}
int
gcd(m, n)
register int m, n;
int gcd(int m, int n)
{
/* Greatest Common Divisor
*/
@ -825,18 +766,14 @@ gcd(m, n)
return m;
}
int
lcm(m, n)
int m, n;
int lcm(int m, int n)
{
/* Least Common Multiple
*/
return m * (n / gcd(m, n));
}
t_type *
intorcard(left, right)
register t_type *left, *right;
t_type *intorcard(register t_type *left, register t_type *right)
{
if (left->tp_fund == T_INTORCARD) {
t_type *tmp = left;
@ -852,8 +789,7 @@ intorcard(left, right)
}
#ifdef DEBUG
DumpType(tp)
register t_type *tp;
void DumpType(register t_type *tp)
{
if (!tp) return;

77
lang/m2/comp/type.xh
View file

@ -4,10 +4,17 @@
*
* Author: Ceriel J.H. Jacobs
*/
#ifndef TYPE_H_
#define TYPE_H_
/* 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 "em_arith.h"
typedef struct def t_def;
typedef struct node t_node;
struct paramlist { /* structure for parameterlist of a PROCEDURE */
struct paramlist *par_next;
@ -189,19 +196,7 @@ extern unsigned int
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)
@ -240,3 +235,59 @@ extern arith max_int[];
extern arith min_int[];
#define ufit(n, i) (((n) & ~full_mask[(i)]) == 0)
/* Forward declarations. */
/* Initialize predefined types. */
void InitTypes(void);
/* Compare arith's, and return 1 if "l2" is
* greater or equal than "l1", otherwise returns 0.
* Takes into account that arith might be unsigned. */
int chk_bounds(arith l1, arith l2, int fund);
/* Aligns "pos" to the specified alignment "al" and returns the
aligned "pos".
*/
arith align(arith pos, int al);
/* Create a new standard type "fund" with specified
alignment "algn" and "size" bytes. */
t_type *standard_type(int fund, int algn, arith size);
t_type *enum_type(t_node *EnumList);
t_type *construct_type(int fund, register t_type *tp);
t_type *qualified_type(t_node **pnd);
/* Check that the value "i" fits in the subrange or enumeration
type "tp". Return 1 if so, 0 otherwise
*/
int in_range(arith i, register t_type *tp);
/* 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.
*/
t_type *subr_type(t_node *lb, t_node *ub, t_type *base);
t_type *proc_type(t_type *result_type, t_param *parameters, arith n_bytes_params);
void genrck(register t_type *tp);
/* Get the bounds of a bounded type. */
void getbounds(register t_type *tp, arith *plo, arith *phi);
/* Construct a set type with base type "tp", but first
* perform some checks */
t_type *set_type(register t_type *tp);
void ArrayElSize(register t_type *tp);
void ArraySizes(register t_type *tp);
void FreeType(register t_type *tp);
void DeclareType(t_node *nd, register t_def *df, register t_type *tp);
void SolveForwardTypeRefs(register t_def *df);
void ForceForwardTypeDef(register t_def *df);
t_type *RemoveEqual(register t_type *tpx);
int type_or_forward(t_type *tp);
t_type *intorcard(register t_type *left, register t_type *right);
#ifdef DEBUG
void DumpType(register t_type *tp);
#endif
int fit(arith sz, int nbytes);
/* Greatest common divisotr. */
int gcd(int m, int n);
/* Least common multiple. */
int lcm(int m, int n);
#endif /* TYPE_H_ */

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

@ -12,41 +12,40 @@
/* Routines for testing type equivalence, type compatibility, and
assignment compatibility
*/
#include "parameters.h"
#include "parameters.h"
#include "debug.h"
#include <em_arith.h>
#include <em_label.h>
#include <assert.h>
#include "type.h"
#include "LLlex.h"
#include "idf.h"
#include "def.h"
#include "node.h"
#include "error.h"
#include "typequiv.h"
#include "warning.h"
#include "main.h"
#include "stab.h"
#include "Lpars.h"
#include "print.h"
#include "chk_expr.h"
extern char *sprint();
int
TstTypeEquiv(tp1, tp2)
t_type *tp1, *tp2;
static int TstTypeEquiv(t_type *tp1, t_type *tp2)
{
/* test if two types are equivalent.
*/
return tp1 == tp2
||
tp1 == error_type
||
tp2 == error_type;
return (tp1 == tp2) ||
(tp1 == error_type) ||
(tp2 == error_type);
}
int
TstParEquiv(tp1, tp2)
register t_type *tp1, *tp2;
static int TstParEquiv(register t_type *tp1, register t_type *tp2)
{
/* test if two parameter types are equivalent. This routine
is used to check if two different procedure declarations
@ -67,9 +66,7 @@ TstParEquiv(tp1, tp2)
);
}
int
TstProcEquiv(tp1, tp2)
t_type *tp1, *tp2;
int TstProcEquiv(t_type *tp1, t_type *tp2)
{
/* Test if two procedure types are equivalent. This routine
may also be used for the testing of assignment compatibility
@ -99,9 +96,7 @@ TstProcEquiv(tp1, tp2)
return p1 == p2;
}
int
TstCompat(tp1, tp2)
register t_type *tp1, *tp2;
int TstCompat(register t_type *tp1, register t_type *tp2)
{
/* test if two types are compatible. See section 6.3 of the
Modula-2 Report for a definition of "compatible".
@ -138,9 +133,7 @@ TstCompat(tp1, tp2)
;
}
int
TstAssCompat(tp1, tp2)
register t_type *tp1, *tp2;
int TstAssCompat(register t_type *tp1, register t_type *tp2)
{
/* Test if two types are assignment compatible.
See Def 9.1.
@ -177,9 +170,7 @@ TstAssCompat(tp1, tp2)
return 0;
}
char *
incompat(tp1, tp2)
register t_type *tp1, *tp2;
char *incompat(register t_type *tp1, register t_type *tp2)
{
if (tp1->tp_fund == T_HIDDEN || tp2->tp_fund == T_HIDDEN) {
@ -188,11 +179,7 @@ incompat(tp1, tp2)
return "type incompatibility";
}
int
TstParCompat(parno, formaltype, VARflag, nd, edf)
register t_type *formaltype;
t_node **nd;
t_def *edf;
int TstParCompat(int parno, register t_type *formaltype, int VARflag, t_node **nd, t_def *edf)
{
/* Check type compatibility for a parameter in a procedure call.
Assignment compatibility may do if the parameter is
@ -268,11 +255,7 @@ TstParCompat(parno, formaltype, VARflag, nd, edf)
return 0;
}
CompatCheck(nd, tp, message, fc)
register t_node **nd;
t_type *tp;
char *message;
int (*fc)();
int CompatCheck(register t_node **nd, t_type *tp, char *message, int (*fc)())
{
if (! (*fc)(tp, (*nd)->nd_type)) {
if (message) {
@ -286,10 +269,7 @@ CompatCheck(nd, tp, message, fc)
return 1;
}
ChkAssCompat(nd, tp, message)
t_node **nd;
t_type *tp;
char *message;
int ChkAssCompat(t_node **nd, t_type *tp, char *message)
{
/* Check assignment compatibility of node "nd" with type "tp".
Give an error message when it fails
@ -301,10 +281,7 @@ ChkAssCompat(nd, tp, message)
return CompatCheck(nd, tp, message, TstAssCompat);
}
ChkCompat(nd, tp, message)
t_node **nd;
t_type *tp;
char *message;
int ChkCompat(t_node **nd, t_type *tp, char *message)
{
/* Check compatibility of node "nd" with type "tp".
Give an error message when it fails

25
lang/m2/comp/typequiv.h Normal file
View file

@ -0,0 +1,25 @@
/* Copyright (c) 2019 ACK Project.
* See the copyright notice in the ACK home directory,
* in the file "Copyright".
*
* Created on: 2019-02-25
*
*/
#ifndef TYPEQUIV_H_
#define TYPEQUIV_H_
typedef struct type t_type;
typedef struct node t_node;
typedef struct def t_def;
int TstProcEquiv(t_type *tp1, t_type *tp2);
int TstCompat(register t_type *tp1, register t_type *tp2);
int TstAssCompat(register t_type *tp1, register t_type *tp2);
int TstParCompat(int parno, register t_type *formaltype, int VARflag, t_node **nd, t_def *edf);
int ChkCompat(t_node **nd, t_type *tp, char *message);
int ChkAssCompat(t_node **nd, t_type *tp, char *message);
char *incompat(register t_type *tp1, register t_type *tp2);
#endif /* TYPEQUIV_H_ */

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

@ -35,16 +35,19 @@
#include "node.h"
#include "Lpars.h"
#include "desig.h"
#include "typequiv.h"
#include "f_info.h"
#include "idf.h"
#include "chk_expr.h"
#include "walk.h"
#include "misc.h"
#include "error.h"
#include "tmpvar.h"
#include "stab.h"
#include "code.h"
#include "warning.h"
extern arith NewPtr();
extern arith NewInt();
extern arith TmpSpace();
int CaseCode(t_node *, label, int);
extern int proclevel;
extern int gdb_flag;
@ -58,13 +61,8 @@ static t_type* func_type;
static t_node* priority;
static int oldlineno;
static int RegisterMessage();
static int WalkDef();
#ifdef DBSYMTAB
static int stabdef();
#endif
static int MkCalls();
static void UseWarnings();
#define NO_EXIT_LABEL ((label)0)
#define RETURN_LABEL ((label)1)
@ -72,13 +70,18 @@ static void UseWarnings();
#define REACH_FLAG 1
#define EXIT_FLAG 2
void DoAssign();
/* Forward declarations. */
static void WalkDef(register t_def*);
static void MkCalls(register t_def*);
static void UseWarnings(register t_def*);
static void RegisterMessage(register t_def*);
static void WalkDefList(register t_def*, void (*proc)(t_def*));
#ifdef DBSYMTAB
static void stabdef(t_def*);
#endif
int
LblWalkNode(lbl, nd, exit, reach)
label lbl,
exit;
t_node* nd;
int LblWalkNode(label lbl, t_node *nd, int exit, int reach)
{
/* Generate code for node "nd", after generating instruction
label "lbl". "exit" is the exit label for the closest
@ -91,8 +94,7 @@ t_node* nd;
static arith tmpprio;
STATIC
DoPriority()
static void DoPriority(void)
{
/* For the time being (???), handle priorities by calls to
the runtime system
@ -107,8 +109,7 @@ DoPriority()
}
}
STATIC
EndPriority()
static void EndPriority(void)
{
if (priority)
{
@ -118,8 +119,7 @@ EndPriority()
}
}
def_ilb(l)
label l;
void def_ilb(label l)
{
/* Instruction label definition. Forget about line number.
*/
@ -127,10 +127,8 @@ def_ilb(l)
oldlineno = 0;
}
DoLineno(nd) register t_node* nd;
void DoLineno(register t_node* nd)
{
/* Generate line number information, if necessary.
*/
if ((!options['L']
#ifdef DBSYMTAB
|| options['g']
@ -156,13 +154,8 @@ DoLineno(nd) register t_node* nd;
}
}
DoFilename(needed)
void DoFilename(int needed)
{
/* Generate filename information, when needed.
This routine is called at the generation of a
procedure entry, and after generating a call to
another procedure.
*/
static label filename_label = 0;
oldlineno = 0; /* always invalidate remembered line number */
@ -180,12 +173,8 @@ DoFilename(needed)
}
}
WalkModule(module) register t_def* module;
void WalkModule(register t_def* module)
{
/* Walk through a module, and all its local definitions.
Also generate code for its body.
This code is collected in an initialization routine.
*/
register t_scope* sc;
t_scopelist* savevis = CurrVis;
@ -284,11 +273,9 @@ WalkModule(module) register t_def* module;
WalkDefList(sc->sc_def, UseWarnings);
}
WalkProcedure(procedure) register t_def* procedure;
void WalkProcedure(register t_def* procedure)
{
/* Walk through the definition of a procedure and all its
local definitions, checking and generating code.
*/
t_scopelist* savevis = CurrVis;
register t_type* tp;
register t_param* param;
@ -574,10 +561,10 @@ WalkProcedure(procedure) register t_def* procedure;
WalkDefList(procscope->sc_def, UseWarnings);
}
static WalkDef(df) register t_def* df;
/* Walk through a list of definitions */
static void WalkDef(register t_def* df)
{
/* Walk through a list of definitions
*/
switch (df->df_kind)
{
@ -602,10 +589,10 @@ static WalkDef(df) register t_def* df;
}
}
static MkCalls(df) register t_def* df;
/* Generate calls to initialization routines of modules */
static void MkCalls(register t_def* df)
{
/* Generate calls to initialization routines of modules
*/
if (df->df_kind == D_MODULE)
{
@ -614,14 +601,8 @@ static MkCalls(df) register t_def* df;
}
}
WalkLink(nd, exit_label, end_reached) register t_node* nd;
label exit_label;
int WalkLink(register t_node* nd, label exit_label, int end_reached)
{
/* Walk node "nd", which is a link.
"exit_label" is set to a label number when inside a LOOP.
"end_reached" maintains info about reachability (REACH_FLAG),
and whether an EXIT statement was seen (EXIT_FLAG).
*/
while (nd && nd->nd_class == Link)
{ /* statement list */
@ -632,8 +613,7 @@ label exit_label;
return WalkNode(nd, exit_label, end_reached);
}
STATIC
ForLoopVarExpr(nd) register t_node* nd;
static void ForLoopVarExpr(register t_node* nd)
{
register t_type* tp = nd->nd_type;
@ -641,12 +621,9 @@ ForLoopVarExpr(nd) register t_node* nd;
CodeCoercion(tp, BaseType(tp));
}
int
WalkStat(nd, exit_label, end_reached) register t_node* nd;
label exit_label;
int WalkStat(register t_node* nd, label exit_label, int end_reached)
{
/* Walk through a statement, generating code for it.
*/
register t_node* left = nd->nd_LEFT;
register t_node* right = nd->nd_RIGHT;
@ -940,9 +917,8 @@ label exit_label;
return end_reached;
}
extern int NodeCrash();
int (*WalkTable[])() = {
int (*WalkTable[])(t_node*, label, int) = {
NodeCrash,
NodeCrash,
NodeCrash,
@ -960,12 +936,9 @@ int (*WalkTable[])() = {
extern t_desig null_desig;
ExpectBool(pnd, true_label, false_label) register t_node** pnd;
label true_label, false_label;
void ExpectBool(register t_node** pnd, label true_label, label false_label)
{
/* "pnd" must indicate a boolean expression. Check this and
generate code to evaluate the expression.
*/
t_desig ds;
ds = null_desig;
@ -980,13 +953,8 @@ label true_label, false_label;
}
}
int
WalkDesignator(pnd, ds, flags)
t_node** pnd;
t_desig* ds;
int WalkDesignator(t_node** pnd, t_desig* ds, int flags)
{
/* Check designator and generate code for it
*/
if (!ChkVariable(pnd, flags))
return 0;
@ -996,8 +964,7 @@ t_desig* ds;
return 1;
}
DoForInit(nd)
t_node* nd;
int DoForInit(t_node* nd)
{
register t_node* right = nd->nd_RIGHT;
register t_def* df;
@ -1074,8 +1041,8 @@ DoForInit(nd)
return 1;
}
void
DoAssign(nd) register t_node* nd;
void DoAssign(register t_node* nd)
{
/* May we do it in this order (expression first) ???
The reference manual sais nothing about it, but the book does:
@ -1111,7 +1078,7 @@ void
CodeMove(&dsr, nd->nd_LEFT, tp);
}
static RegisterMessage(df) register t_def* df;
static void RegisterMessage(register t_def* df)
{
register t_type* tp;
@ -1140,11 +1107,7 @@ static RegisterMessage(df) register t_def* df;
}
}
static void
df_warning(nd, df, warning)
t_node* nd;
t_def* df;
char* warning;
static void df_warning(t_node* nd, t_def* df, char* warning)
{
if (!(df->df_kind & (D_VARIABLE | D_PROCEDURE | D_TYPE | D_CONST | D_PROCHEAD)))
{
@ -1160,8 +1123,7 @@ char* warning;
}
}
static void
UseWarnings(df) register t_def* df;
static void UseWarnings(register t_def* df)
{
t_node* nd = df->df_scope->sc_end;
@ -1208,8 +1170,7 @@ static void
}
}
WalkDefList(df, proc) register t_def* df;
int (*proc)();
static void WalkDefList(register t_def* df, void (*proc)(t_def*))
{
for (; df; df = df->df_nextinscope)
{
@ -1218,9 +1179,7 @@ int (*proc)();
}
#ifdef DBSYMTAB
static int
stabdef(df)
t_def* df;
static void stabdef(t_def* df)
{
switch (df->df_kind)
{

58
lang/m2/comp/walk.h
View file

@ -4,17 +4,22 @@
*
* Author: Ceriel J.H. Jacobs
*/
/* P A R S E T R E E W A L K E R */
#ifndef WALK_H_
#define WALK_H_
/* $Id$ */
#include "em_label.h"
/* Forward type declarations. */
typedef struct node t_node;
typedef struct def t_def;
typedef struct desig t_desig;
/* Definition of WalkNode macro
*/
extern int (*WalkTable[])(t_node*, label, int);
extern int (*WalkTable[])();
#define WalkNode(xnd, xlab, rch) (*WalkTable[(xnd)->nd_class])((xnd), (xlab),(rch))
#define WalkNode(xnd, xlab, rch) (*WalkTable[(unsigned int)((xnd)->nd_class)])((xnd), (xlab),(rch))
extern label text_label;
extern label data_label;
@ -25,3 +30,46 @@ extern label data_label;
#define CAL(nm, sz) (C_cal(nm), C_asp((arith)(sz)))
#define c_bra(x) C_bra((label) (x))
#endif
int LblWalkNode(label lbl, t_node *nd, int exit, int reach);
void def_ilb(label l);
/* Generate line information as necessary for "nd". */
void DoLineno(register t_node* nd);
/* Generate filename information, when needed.
This routine is called at the generation of a
procedure entry, and after generating a call to
another procedure. The current active filename
is used.
*/
void DoFilename(int needed);
/* Walk through a module, and all its local definitions.
Also generate code for its body.
This code is collected in an initialization routine.
*/
void WalkModule(register t_def* module);
/* Walk through the definition of a procedure and all its
local definitions, checking and generating code.
*/
void WalkProcedure(register t_def* procedure);
/* Walk node "nd", which is a link.
"exit_label" is set to a label number when inside a LOOP.
"end_reached" maintains info about reachability (REACH_FLAG),
and whether an EXIT statement was seen (EXIT_FLAG).
*/
int WalkLink(register t_node* nd, label exit_label, int end_reached);
/* Walk through a statement node "nd", generating code for it. */
int WalkStat(register t_node* nd, label exit_label, int end_reached);
/* Generate code to evaluate a boolean expression "pnd" */
void ExpectBool(register t_node** pnd, label true_label, label false_label);
/* Check designator and generate code for it */
int WalkDesignator(t_node** pnd, t_desig* ds, int flags);
void DoAssign(register t_node* nd);
int DoForInit(t_node* nd);
#endif /* WALK_H_ */