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

made to fit on PDP-11 again

Browse source
This commit is contained in:
ceriel 1988-03-22 17:54:01 +00:00
parent fba9192bbc
commit e71df15045
12 changed files with 180 additions and 182 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -1 +1 @@
static char Version[] = "ACK Modula-2 compiler Version 0.35";
static char Version[] = "ACK Modula-2 compiler Version 0.36";

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

@ -20,6 +20,7 @@ extern int (*DesigChkTable[])(); /* table of designator checking
#define ChkDesignator(expp) ((*DesigChkTable[(expp)->nd_class])(expp,0))
#define ChkDesig(expp, flags) ((*DesigChkTable[(expp)->nd_class])(expp,flags))
#define inc_refcount(s) (*((s) - 1) += 1)
#define dec_refcount(s) (*((s) - 1) -= 1)
#define refcount(s) (*((s) - 1))
/* 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))

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

@ -429,8 +429,7 @@ CodeParameters(param, arg)
CodePExpr(left);
tmp = TmpSpace(left->nd_type->tp_size, left->nd_type->tp_align);
C_lal(tmp);
C_sti(WA(left->nd_type->tp_size));
STL(tmp, WA(left->nd_type->tp_size));
C_lal(tmp);
}
break;
@ -892,8 +891,7 @@ CodeOper(expr, true_label, false_label)
}
else CodeExpr(leftop, Des, l_maybe, false_label);
def_ilb(l_maybe);
free_desig(Des);
Des = new_desig();
clear((char *) Des, sizeof(t_desig));
CodeExpr(rightop, Des, true_label, false_label);
if (genlabels) {
def_ilb(true_label);

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

@ -32,6 +32,7 @@
#include "node.h"
#include "warning.h"
#include "walk.h"
#include "squeeze.h"
extern int proclevel;
extern arith NewPtr();
@ -52,6 +53,36 @@ WordOrDouble(ds, size)
return 0;
}
LOL(offset, size)
arith offset, size;
{
if (size == word_size) {
C_lol(offset);
}
else if (size == dword_size) {
C_ldl(offset);
}
else {
C_lal(offset);
C_loi(size);
}
}
STL(offset, size)
arith offset, size;
{
if (size == word_size) {
C_stl(offset);
}
else if (size == dword_size) {
C_sdl(offset);
}
else {
C_lal(offset);
C_sti(size);
}
}
int
DoLoad(ds, size)
register t_desig *ds;
@ -106,30 +137,22 @@ DoStore(ds, size)
return 1;
}
int
word_multiple(tp)
register t_type *tp;
{
/* Return 1 if the type indicated by tp has a size that is a
multiple of the word_size and is also word_aligned
*/
return (int)(tp->tp_size) % (int)word_size == 0 &&
tp->tp_align >= word_align;
}
#define word_multiple(tp) \
( (int)(tp->tp_size) % (int)word_size == 0 && \
tp->tp_align >= word_align)
int
word_dividor(tp)
register t_type *tp;
{
/* Return 1 if the type indicated by tp has a size that is a proper
dividor of the word_size, and has alignment >= size or
alignment >= word_align
*/
return tp->tp_size < word_size &&
(int)word_size % (int)(tp->tp_size) == 0 &&
(tp->tp_align >= word_align ||
tp->tp_align >= (int)(tp->tp_size));
}
#define word_dividor(tp) \
( tp->tp_size < word_size && \
(int)word_size % (int)(tp->tp_size) == 0 && \
(tp->tp_align >= word_align || \
tp->tp_align >= (int)(tp->tp_size)))
#define USE_LOI_STI 0
#define USE_LOS_STS 1
@ -139,14 +162,15 @@ word_dividor(tp)
*/
STATIC int
type_to_stack(tp)
suitable_move(tp)
register t_type *tp;
{
/* Find out how to load or store the value indicated by "ds".
There are three ways:
- with LOI/STI
- with LOS/STS
- with calls to _load/_store
- suitable for BLM/LOI/STI
- suitable for LOI/STI
- suitable for LOS/STS/BLS
- suitable for calls to load/store/blockmove
*/
if (! word_multiple(tp)) {
@ -175,12 +199,14 @@ CodeValue(ds, tp)
/* Fall through */
case DSG_PLOADED:
case DSG_PFIXED:
switch (type_to_stack(tp)) {
switch (suitable_move(tp)) {
case USE_BLM:
case USE_LOI_STI:
#ifndef SQUEEZE
CodeAddress(ds);
C_loi(tp->tp_size);
break;
#endif
case USE_LOS_STS:
CodeAddress(ds);
CodeConst(tp->tp_size, (int)pointer_size);
@ -188,16 +214,14 @@ CodeValue(ds, tp)
break;
case USE_LOAD_STORE:
sz = WA(tp->tp_size);
if (ds->dsg_kind == DSG_PLOADED) {
if (ds->dsg_kind != DSG_PFIXED) {
arith tmp = NewPtr();
CodeAddress(ds);
C_lal(tmp);
C_sti(pointer_size);
STL(tmp, pointer_size);
CodeConst(-sz, (int) pointer_size);
C_ass(pointer_size);
C_lal(tmp);
C_loi(pointer_size);
LOL(tmp, pointer_size);
FreePtr(tmp);
}
else {
@ -224,7 +248,7 @@ CodeValue(ds, tp)
}
ChkForFOR(nd)
t_node *nd;
register t_node *nd;
{
/* Check for an assignment to a FOR-loop control variable
*/
@ -248,9 +272,6 @@ CodeStore(ds, tp)
/* Generate code to store the value on the stack in the designator
described in "ds"
*/
t_desig save;
save = *ds;
switch(ds->dsg_kind) {
case DSG_FIXED:
@ -258,12 +279,14 @@ CodeStore(ds, tp)
/* Fall through */
case DSG_PLOADED:
case DSG_PFIXED:
CodeAddress(&save);
switch (type_to_stack(tp)) {
CodeAddress(ds);
switch (suitable_move(tp)) {
case USE_BLM:
case USE_LOI_STI:
#ifndef SQUEEZE
C_sti(tp->tp_size);
break;
#endif
case USE_LOS_STS:
CodeConst(tp->tp_size, (int) pointer_size);
C_sts(pointer_size);
@ -326,6 +349,7 @@ CodeMove(rhs, left, rtp)
*/
register t_desig *lhs = new_desig();
register t_type *tp = left->nd_type;
int loadedflag = 0;
ChkForFOR(left);
switch(rhs->dsg_kind) {
@ -345,61 +369,60 @@ CodeMove(rhs, left, rtp)
CodeStore(lhs, tp);
break;
case DSG_FIXED:
CodeDesig(left, lhs);
if (lhs->dsg_kind == DSG_FIXED &&
fit(tp->tp_size, (int) word_size) &&
(int) (lhs->dsg_offset) % (int) word_size ==
(int) (rhs->dsg_offset) % (int) word_size) {
register int sz;
(int) (lhs->dsg_offset) % word_align ==
(int) (rhs->dsg_offset) % word_align) {
register int sz = 1;
arith size = tp->tp_size;
CodeDesig(left, lhs);
while (size &&
(sz = ((int)(lhs->dsg_offset)%(int)word_size))) {
while (size && sz < word_align) {
/* First copy up to word-aligned
boundaries
*/
if (sz < 0) sz = -sz; /* bloody '%' */
while ((int) word_size % sz) sz--;
CodeCopy(lhs, rhs, (arith) sz, &size);
}
if (size > 3*dword_size) {
/* Do a block move
*/
arith sz;
sz = size - size % word_size;
CodeCopy(lhs, rhs, sz, &size);
}
else for (sz = (int) dword_size;
sz; sz -= (int) word_size) {
while (size >= sz) {
/* Then copy dwords, words.
Depend on peephole optimizer
*/
CodeCopy(lhs, rhs, (arith) sz, &size);
if (!((int)(lhs->dsg_offset)%(sz+sz))) {
sz += sz;
}
else CodeCopy(lhs, rhs, (arith) sz, &size);
}
/* Now copy the bulk
*/
sz = (int) size % (int) word_size;
size -= sz;
CodeCopy(lhs, rhs, size, &size);
size = sz;
sz = word_size;
while (size && --sz) {
while (size) {
/* And then copy remaining parts
*/
while ((int) word_size % sz) sz--;
while (size >= sz) {
sz >>= 1;
if (size >= sz) {
CodeCopy(lhs, rhs, (arith) sz, &size);
}
}
break;
}
CodeAddress(lhs);
loadedflag = 1;
/* Fall through */
case DSG_PLOADED:
case DSG_PFIXED:
assert(! loadedflag || rhs->dsg_kind == DSG_FIXED);
CodeAddress(rhs);
CodeDesig(left, lhs);
CodeAddress(lhs);
switch (type_to_stack(tp)) {
if (loadedflag) {
C_exg(pointer_size);
}
else {
CodeDesig(left, lhs);
CodeAddress(lhs);
}
switch (suitable_move(tp)) {
case USE_BLM:
#ifndef SQUEEZE
C_blm(tp->tp_size);
break;
#endif
case USE_LOS_STS:
CodeConst(tp->tp_size, (int) pointer_size);
C_bls(pointer_size);

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

@ -42,9 +42,8 @@ int nDEF, mDEF;
int pass_1;
t_def *Defined;
extern int err_occurred;
extern int Roption;
extern int fp_used; /* set if floating point used */
static t_node _emptystat = { NULLNODE, NULLNODE, Stat, NULLTYPE, { ';' }};
static t_node _emptystat = { NULLNODE, NULLNODE, Stat, 0, NULLTYPE, { ';' }};
t_node *EmptyStatement = &_emptystat;
main(argc, argv)
@ -92,7 +91,6 @@ Compile(src, dst)
InitScope();
InitTypes();
AddStandards();
Roption = options['R'];
#ifdef DEBUG
if (options['l']) {
LexScan();
@ -159,7 +157,7 @@ LexScan()
static struct stdproc {
char *st_nam;
int st_con;
} stdproc[] = {
} stdprocs[] = {
{ "ABS", S_ABS },
{ "CAP", S_CAP },
{ "CHR", S_CHR },
@ -188,20 +186,30 @@ static struct stdproc {
{ 0, 0 }
};
static struct stdproc sysprocs[] = {
{ "TSIZE", S_TSIZE },
{ "ADR", S_ADR },
{ 0, 0 }
};
extern t_def *Enter();
AddStandards()
{
register t_def *df;
AddProcs(p)
register struct stdproc *p;
static t_token nilconst = { INTEGER, 0};
for (p = stdproc; p->st_nam != 0; p++) {
{
for (; p->st_nam != 0; p++) {
if (! Enter(p->st_nam, D_PROCEDURE, std_type, p->st_con)) {
assert(0);
}
}
}
AddStandards()
{
register t_def *df;
static t_token nilconst = { INTEGER, 0};
AddProcs(stdprocs);
EnterType("CHAR", char_type);
EnterType("INTEGER", int_type);
EnterType("LONGINT", longint_type);
@ -232,12 +240,7 @@ do_SYSTEM()
EnterType("WORD", word_type);
EnterType("BYTE", byte_type);
EnterType("ADDRESS",address_type);
if (! Enter("ADR", D_PROCEDURE, std_type, S_ADR)) {
assert(0);
}
if (! Enter("TSIZE", D_PROCEDURE, std_type, S_TSIZE)) {
assert(0);
}
AddProcs(sysprocs);
if (!InsertText(systemtext, sizeof(systemtext) - 1)) {
fatal("could not insert text");
}

6
lang/m2/comp/node.H
View file

@ -12,7 +12,7 @@
struct node {
struct node *nd_left;
struct node *nd_right;
int nd_class; /* kind of node */
char nd_class; /* kind of node */
#define Value 0 /* constant */
#define Arrsel 1 /* array selection */
#define Oper 2 /* binary operator */
@ -25,8 +25,10 @@ struct node {
#define Def 9 /* an identified name */
#define Stat 10 /* a statement */
#define Link 11
#define Option 12
/* do NOT change the order or the numbers!!! */
char nd_flags; /* options */
#define ROPTION 1
#define AOPTION 2
struct type *nd_type; /* type of this node */
struct token nd_token;
#define nd_set nd_token.tk_data.tk_set

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

@ -20,6 +20,7 @@
#include "def.h"
#include "type.h"
#include "node.h"
#include "main.h"
t_node *
MkNode(class, left, right, token)
@ -34,6 +35,8 @@ MkNode(class, left, right, token)
nd->nd_right = right;
nd->nd_token = *token;
nd->nd_class = class;
if (options['R']) nd->nd_flags |= ROPTION;
if (options['A']) nd->nd_flags |= AOPTION;
return nd;
}
@ -48,17 +51,13 @@ t_node *
MkLeaf(class, token)
t_token *token;
{
register t_node *nd = new_node();
nd->nd_token = *token;
nd->nd_class = class;
return nd;
return MkNode(class, NULLNODE, NULLNODE, token);
}
t_node *
dot2leaf(class)
{
return MkLeaf(class, &dot);
return MkNode(class, NULLNODE, NULLNODE, &dot);
}
FreeLR(nd)

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

@ -46,7 +46,7 @@ open_scope(scopetype)
sc->sc_level = proclevel;
ls->sc_scope = sc;
ls->sc_encl = CurrVis;
if (scopetype == OPENSCOPE) {
if (! sc->sc_scopeclosed) {
ls->sc_next = ls->sc_encl;
}
CurrVis = ls;
@ -68,12 +68,8 @@ InitScope()
register t_scope *sc = new_scope();
register t_scopelist *ls = new_scopelist();
sc->sc_scopeclosed = 0;
sc->sc_def = 0;
sc->sc_level = proclevel;
PervasiveScope = sc;
ls->sc_next = 0;
ls->sc_encl = 0;
ls->sc_scope = PervasiveScope;
PervVis = ls;
CurrVis = ls;

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

@ -22,8 +22,6 @@
#include "node.h"
static int loopcount = 0; /* Count nested loops */
int Roption;
extern char options[];
extern t_node *EmptyStatement;
}
@ -32,24 +30,6 @@ statement(register t_node **pnd;)
register t_node *nd;
extern int return_occurred;
} :
/* We need some method for making sure lookahead is done, so ...
*/
[ PROGRAM
/* LLlex never returns this */
| %default
{ if (options['R'] != Roption) {
Roption = options['R'];
nd = dot2leaf(Option);
nd->nd_symb = 'R';
nd->nd_INT = Roption;
*pnd = nd =
dot2node(Link, nd, NULLNODE);
nd->nd_symb = ';';
pnd = &(nd->nd_right);
}
}
]
[
/*
* This part is not in the reference grammar. The reference grammar
* states : assignment | ProcedureCall | ...
@ -108,7 +88,6 @@ statement(register t_node **pnd;)
{ return_occurred = 1; }
|
/* empty */ { *pnd = EmptyStatement; }
]
;
/*

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

@ -220,5 +220,4 @@ extern long full_mask[];
extern long max_int[];
extern long min_int[];
#define fit(n, i) (((n) + ((arith)0x80<<(((i)-1)*8)) & ~full_mask[(i)]) == 0)
#define ufit(n, i) (((n) & ~full_mask[(i)]) == 0)

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

@ -210,6 +210,13 @@ InitTypes()
*error_type = *char_type;
}
int
fit(sz, nbytes)
arith sz;
{
return ((sz) + ((arith)0x80<<(((nbytes)-1)*8)) & ~full_mask[(nbytes)]) == 0;
}
STATIC
u_small(tp, n)
register t_type *tp;

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

@ -268,8 +268,7 @@ WalkProcedure(procedure)
if (tp->tp_size < word_size &&
(int) word_size % (int) tp->tp_size == 0) {
C_lol(param->par_def->var_off);
C_lal(param->par_def->var_off);
C_sti(tp->tp_size);
STL(param->par_def->var_off, tp->tp_size);
}
}
else {
@ -297,8 +296,7 @@ WalkProcedure(procedure)
}
StackAdjustment = NewPtr();
C_lor((arith) 1);
C_lal(StackAdjustment);
C_sti(pointer_size);
STL(StackAdjustment, pointer_size);
}
/* First compute new stackpointer */
C_lal(param->par_def->var_off);
@ -307,8 +305,7 @@ WalkProcedure(procedure)
C_lfr(pointer_size);
C_str((arith) 1);
/* adjusted stack pointer */
C_lal(param->par_def->var_off);
C_loi(pointer_size);
LOL(param->par_def->var_off, pointer_size);
/* push source address */
C_cal("_copy_array");
/* copy */
@ -336,8 +333,7 @@ WalkProcedure(procedure)
if (StackAdjustment) {
/* Remove copies of conformant arrays
*/
C_lal(StackAdjustment);
C_loi(pointer_size);
LOL(StackAdjustment, pointer_size);
C_str((arith) 1);
}
c_lae_dlb(func_res_label);
@ -349,17 +345,13 @@ WalkProcedure(procedure)
and put function result back on the stack
*/
if (func_type) {
C_lal(retsav);
C_sti(func_res_size);
STL(retsav, func_res_size);
}
C_lal(StackAdjustment);
C_loi(pointer_size);
LOL(StackAdjustment, pointer_size);
C_str((arith) 1);
if (func_type) {
C_lal(retsav);
C_loi(func_res_size);
LOL(retsav, func_res_size);
}
FreePtr(StackAdjustment);
}
EndPriority();
C_ret(func_res_size);
@ -453,6 +445,8 @@ WalkStat(nd, exit_label)
assert(nd->nd_class == Stat);
DoLineno(nd);
if (nd->nd_flags & ROPTION) options['R'] = 1;
if (nd->nd_flags & AOPTION) options['A'] = 1;
switch(nd->nd_symb) {
case '(':
if (ChkCall(nd)) {
@ -682,16 +676,6 @@ WalkStat(nd, exit_label)
extern int NodeCrash();
STATIC
WalkOption(nd)
t_node *nd;
{
/* Set option indicated by node "nd"
*/
options[nd->nd_symb] = nd->nd_INT;
}
int (*WalkTable[])() = {
NodeCrash,
NodeCrash,
@ -705,7 +689,6 @@ int (*WalkTable[])() = {
NodeCrash,
WalkStat,
WalkLink,
WalkOption
};
ExpectBool(nd, true_label, false_label)
@ -883,45 +866,53 @@ static int
UseWarnings(df)
register t_def *df;
{
if (is_anon_idf(df->df_idf)) return;
if (df->df_kind & (D_IMPORTED | D_VARIABLE | D_PROCEDURE | D_CONST | D_TYPE)) {
struct node *nd;
char *warning = 0;
if (df->df_flags & (D_EXPORTED | D_QEXPORTED)) return;
if (df->df_kind & D_IMPORTED) {
register t_def *df1 = df->imp_def;
if (is_anon_idf(df->df_idf) ||
!(df->df_kind&(D_IMPORTED|D_VARIABLE|D_PROCEDURE|D_CONST|D_TYPE)) ||
(df->df_flags&(D_EXPORTED|D_QEXPORTED))) {
return;
}
df1->df_flags |= df->df_flags & (D_USED|D_DEFINED);
if (df->df_kind == D_INUSE) return;
if ( !(df->df_flags & D_IMP_BY_EXP)) {
if (! (df->df_flags & (D_USED | D_DEFINED))) {
node_warning(
df->df_scope->sc_end,
W_ORDINARY,
"identifier \"%s\" imported but not %s",
df->df_idf->id_text,
df1->df_kind == D_VARIABLE ?
"used/assigned" :
"used");
if (df->df_kind & D_IMPORTED) {
register t_def *df1 = df->imp_def;
df1->df_flags |= df->df_flags & (D_USED|D_DEFINED);
if (df->df_kind == D_INUSE) return;
if ( !(df->df_flags & D_IMP_BY_EXP)) {
if (! (df->df_flags & (D_USED | D_DEFINED))) {
if (df1->df_kind == D_VARIABLE) {
warning = "imported but not used/assigned";
}
return;
else warning = "imported but not used";
goto warn;
}
df = df1;
}
if (! (df->df_kind & (D_VARIABLE|D_PROCEDURE|D_TYPE|D_CONST))) return;
nd = df->df_scope->sc_end;
if (! (df->df_flags & D_DEFINED)) {
node_warning(nd,
W_ORDINARY,
"identifier \"%s\" never assigned",
df->df_idf->id_text);
}
if (! (df->df_flags & D_USED)) {
node_warning(nd,
W_ORDINARY,
"identifier \"%s\" never used",
df->df_idf->id_text);
return;
}
df = df1;
}
if (! (df->df_kind & (D_VARIABLE|D_PROCEDURE|D_TYPE|D_CONST))) {
return;
}
switch(df->df_flags & (D_USED|D_DEFINED)) {
case 0:
warning = "never used/assigned";
break;
case D_USED:
warning = "never assigned";
break;
case D_DEFINED:
warning = "never used";
break;
case D_USED|D_DEFINED:
return;
}
warn:
if (warning) {
node_warning(df->df_scope->sc_end,
W_ORDINARY,
"identifier \"%s\" %s",
df->df_idf->id_text, warning);
}
}