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

fixes, added some standard functions to handle LONGREAL, LONGINT

Browse source
This commit is contained in:
ceriel 1987-05-27 10:16:03 +00:00
parent 86c5c56a38
commit bb9b16ab50
17 changed files with 210 additions and 48 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

62
lang/m2/comp/.distr Normal file
View file

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

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

@ -59,7 +59,8 @@ SkipComment()
/* Foreign; This definition module has an
implementation in another language.
In this case, don't generate prefixes in front
of the names
of the names. Also, don't generate call to
initialization routine.
*/
ForeignFlag = 1;
break;
@ -359,7 +360,7 @@ again:
have to read the number with the help of a rather
complex finite automaton.
*/
enum statetp {Oct,Hex,Dec,OctEndOrHex,End,OptReal,Real};
enum statetp {Oct,OptHex,Hex,Dec,OctEndOrHex,End,OptReal,Real};
register enum statetp state;
register int base;
register char *np = &buf[1];
@ -390,7 +391,8 @@ again:
}
LoadChar(ch);
}
if (is_hex(ch)) state = Hex;
if (ch == 'D') state = OptHex;
else if (is_hex(ch)) state = Hex;
else if (ch == '.') state = OptReal;
else {
state = End;
@ -400,6 +402,15 @@ again:
}
break;
case OptHex:
LoadChar(ch);
if (is_hex(ch)) {
if (np < &buf[NUMSIZE]) *np++ = 'D';
state = Hex;
}
else state = End;
break;
case Hex:
while (is_hex(ch)) {
if (np < &buf[NUMSIZE]) *np++ = ch;
@ -454,6 +465,9 @@ lexwarning(W_ORDINARY, "overflow in constant");
lexwarning(W_ORDINARY, "character constant out of range");
}
}
else if (ch == 'D' && base == 10) {
toktype = longint_type;
}
else if (tk->TOK_INT>=0 &&
tk->TOK_INT<=max_int) {
toktype = intorcard_type;
@ -485,6 +499,8 @@ lexwarning(W_ORDINARY, "character constant out of range");
/* a real real constant */
if (np < &buf[NUMSIZE]) *np++ = '.';
toktype = real_type;
while (is_dig(ch)) {
/* Fractional part
*/
@ -492,9 +508,15 @@ lexwarning(W_ORDINARY, "character constant out of range");
LoadChar(ch);
}
if (ch == 'E') {
if (ch == 'E' || ch == 'D') {
/* Scale factor
*/
if (ch == 'D') {
toktype = longreal_type;
LoadChar(ch);
if (!(ch == '+' || ch == '-' || is_dig(ch)))
goto noscale;
}
if (np < &buf[NUMSIZE]) *np++ = 'E';
LoadChar(ch);
if (ch == '+' || ch == '-') {
@ -514,6 +536,7 @@ lexwarning(W_ORDINARY, "character constant out of range");
}
}
noscale:
*np++ = '\0';
if (ch == EOI) eofseen = 1;
else PushBack();
@ -523,7 +546,6 @@ lexwarning(W_ORDINARY, "character constant out of range");
lexerror("floating constant too long");
}
else tk->TOK_REL = Salloc(buf, (unsigned) (np - buf)) + 1;
toktype = real_type;
return tk->tk_symb = REAL;
/*NOTREACHED*/

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

@ -840,7 +840,7 @@ ChkUnOper(expp)
case '-':
if (tpr->tp_fund & T_INTORCARD) {
if (tpr == intorcard_type) {
if (tpr == intorcard_type || tpr == card_type) {
expp->nd_type = int_type;
}
if (right->nd_class == Value) {
@ -849,7 +849,6 @@ ChkUnOper(expp)
return 1;
}
else if (tpr->tp_fund == T_REAL) {
expp->nd_type = tpr;
if (right->nd_class == Value) {
if (*(right->nd_REL) == '-') (right->nd_REL)++;
else (right->nd_REL)--;
@ -939,11 +938,47 @@ ChkStandard(expp, left)
if (left->nd_class == Value) cstcall(expp, S_CHR);
break;
case S_FLOATD:
case S_FLOAT:
expp->nd_type = real_type;
if (std == S_FLOATD) expp->nd_type = longreal_type;
if (!(left = getarg(&arg, T_INTORCARD, 0, edf))) return 0;
break;
case S_LONG: {
struct type *tp;
if (!(left = getarg(&arg, 0, 0, edf))) {
return 0;
}
tp = BaseType(left->nd_type);
if (tp == int_type) expp->nd_type = longint_type;
else if (tp == real_type) expp->nd_type = longreal_type;
else {
expp->nd_type = error_type;
Xerror(left, "unexpected parameter type", edf);
}
if (left->nd_class == Value) cstcall(expp, S_LONG);
break;
}
case S_SHORT: {
struct type *tp;
if (!(left = getarg(&arg, 0, 0, edf))) {
return 0;
}
tp = BaseType(left->nd_type);
if (tp == longint_type) expp->nd_type = int_type;
else if (tp == longreal_type) expp->nd_type = real_type;
else {
expp->nd_type = error_type;
Xerror(left, "unexpected parameter type", edf);
}
if (left->nd_class == Value) cstcall(expp, S_SHORT);
break;
}
case S_HIGH:
if (!(left = getarg(&arg, T_ARRAY|T_STRING|T_CHAR, 0, edf))) {
return 0;
@ -1053,8 +1088,10 @@ ChkStandard(expp, left)
expp->nd_left->nd_def->df_idf->id_text);
break;
case S_TRUNCD:
case S_TRUNC:
expp->nd_type = card_type;
if (std == S_TRUNCD) expp->nd_type = longint_type;
if (!(left = getarg(&arg, T_REAL, 0, edf))) return 0;
break;

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

@ -456,11 +456,6 @@ CodeStd(nd)
RangeCheck(char_type, tp);
break;
case S_FLOAT:
CodePExpr(left);
CodeCoercion(tp, real_type);
break;
case S_HIGH:
assert(IsConformantArray(tp));
DoHIGH(left->nd_def);
@ -493,9 +488,14 @@ CodeStd(nd)
CodePExpr(left);
break;
case S_TRUNCD:
case S_TRUNC:
case S_FLOAT:
case S_FLOATD:
case S_LONG:
case S_SHORT:
CodePExpr(left);
CodeCoercion(tp, card_type);
CodeCoercion(tp, nd->nd_type);
break;
case S_VAL:

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

@ -386,14 +386,19 @@ cstcall(expp, call)
CutSize(expp);
break;
case S_LONG:
case S_SHORT: {
struct type *tp = expp->nd_type;
*expp = *expr;
expp->nd_type = tp;
break;
}
case S_CAP:
if (expr->nd_INT >= 'a' && expr->nd_INT <= 'z') {
expp->nd_INT = expr->nd_INT + ('A' - 'a');
expr->nd_INT = expr->nd_INT + ('A' - 'a');
}
else expp->nd_INT = expr->nd_INT;
CutSize(expp);
break;
/* fall through */
case S_CHR:
expp->nd_INT = expr->nd_INT;
CutSize(expp);

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

@ -34,7 +34,7 @@ long sys_filesize();
struct idf *DefId;
STATIC char *
char *
getwdir(fn)
register char *fn;
{
@ -65,7 +65,6 @@ GetFile(name)
*/
char buf[15];
char *strncpy(), *strcat();
static char *WorkingDir = ".";
strncpy(buf, name, 10);
buf[10] = '\0'; /* maximum length */

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

@ -31,7 +31,7 @@
#include "node.h"
extern int proclevel;
struct desig InitDesig = {DSG_INIT, 0, 0};
struct desig InitDesig = {DSG_INIT, 0, 0, 0};
int C_ste_dnam(), C_sde_dnam(), C_loe_dnam(), C_lde_dnam();
int C_stl(), C_sdl(), C_lol(), C_ldl();
@ -54,6 +54,7 @@ static int (*ext_ld_and_str[2][2])() = {
int
DoLoadOrStore(ds, size, LoadOrStoreFlag)
register struct desig *ds;
arith size;
{
int sz;
@ -223,8 +224,8 @@ CodeMove(rhs, left, rtp)
switch(rhs->dsg_kind) {
case DSG_LOADED:
CodeDesig(left, lhs);
CodeAddress(lhs);
if (rtp->tp_fund == T_STRING) {
CodeAddress(lhs);
C_loc(rtp->tp_size);
C_loc(tp->tp_size);
C_cal("_StringAssign");
@ -315,6 +316,7 @@ CodeMove(rhs, left, rtp)
lhs->dsg_offset = tmp;
lhs->dsg_name = 0;
lhs->dsg_kind = DSG_PFIXED;
lhs->dsg_def = 0;
C_stl(tmp); /* address of lhs */
}
CodeValue(rhs, tp->tp_size, tp->tp_align);
@ -347,6 +349,7 @@ CodeAddress(ds)
break;
}
C_lal(ds->dsg_offset);
if (ds->dsg_def) ds->dsg_def->df_flags |= D_NOREG;
break;
case DSG_PFIXED:
@ -489,7 +492,8 @@ CodeVarDesig(df, ds)
ds->dsg_kind = DSG_PFIXED;
}
else ds->dsg_kind = DSG_FIXED;
ds->dsg_offset =df->var_off;
ds->dsg_offset = df->var_off;
ds->dsg_def = df;
}
CodeDesig(nd, ds)

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

@ -40,6 +40,9 @@ struct desig {
char *dsg_name; /* name of global variable, used for
FIXED and PFIXED
*/
struct def *dsg_def; /* def structure associated with this
designator, or 0
*/
};
/* The next structure describes the designator in a with-statement.

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

@ -79,16 +79,16 @@ ConstExpression(struct node **pnd;)
* Check that the expression is a constant expression and evaluate!
*/
{ nd = *pnd;
DO_DEBUG(options['X'], print("CONSTANT EXPRESSION\n"));
DO_DEBUG(options['X'], PrNode(nd, 0));
DO_DEBUG(options['C'], print("CONSTANT EXPRESSION\n"));
DO_DEBUG(options['C'], PrNode(nd, 0));
if (ChkExpression(nd) &&
((nd)->nd_class != Set && (nd)->nd_class != Value)) {
error("constant expression expected");
}
DO_DEBUG(options['X'], print("RESULTS IN\n"));
DO_DEBUG(options['X'], PrNode(nd, 0));
DO_DEBUG(options['C'], print("RESULTS IN\n"));
DO_DEBUG(options['C'], PrNode(nd, 0));
}
;

1
lang/m2/comp/f_info.h
View file

@ -18,3 +18,4 @@ struct f_info {
extern struct f_info file_info;
#define LineNumber file_info.f_lineno
#define FileName file_info.f_filename
#define WorkingDir file_info.f_workingdir

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

@ -74,6 +74,7 @@ Compile(src, dst)
char *src, *dst;
{
extern struct tokenname tkidf[];
extern char *getwdir();
if (! InsertFile(src, (char **) 0, &src)) {
fprint(STDERR,"%s: cannot open %s\n", ProgName, src);
@ -81,6 +82,7 @@ Compile(src, dst)
}
LineNumber = 1;
FileName = src;
WorkingDir = getwdir(src);
init_idf();
InitCst();
reserve(tkidf);
@ -171,6 +173,10 @@ static struct stdproc {
{ "MAX", S_MAX },
{ "MIN", S_MIN },
{ "INCL", S_INCL },
{ "LONG", S_LONG },
{ "SHORT", S_SHORT },
{ "TRUNCD", S_TRUNCD },
{ "FLOATD", S_FLOATD },
{ 0, 0 }
};
@ -246,3 +252,13 @@ cnt_scope, cnt_scopelist, cnt_tmpvar);
print("\nNumber of lines read: %d\n", cntlines);
}
#endif
No_Mem()
{
fatal("out of memory");
}
C_failed()
{
fatal("write failed");
}

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

@ -84,7 +84,13 @@ printnode(nd, lvl)
register struct node *nd;
{
indnt(lvl);
print("C: %d; T: %s\n", nd->nd_class, symbol2str(nd->nd_symb));
print("Class: %d; Symbol: %s\n", nd->nd_class, symbol2str(nd->nd_symb));
if (nd->nd_type) {
indnt(lvl);
print("Type: ");
DumpType(nd->nd_type);
print("\n");
}
}
PrNode(nd, lvl)

4
lang/m2/comp/standards.h
View file

@ -28,6 +28,10 @@
#define S_VAL 17
#define S_NEW 18
#define S_DISPOSE 19
#define S_LONG 20
#define S_SHORT 21
#define S_TRUNCD 22
#define S_FLOATD 23
/* Standard procedures and functions defined in the SYSTEM module ... */

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

@ -150,6 +150,7 @@ struct type
#define bounded(tpx) ((tpx)->tp_fund & T_INDEX)
#define complex(tpx) ((tpx)->tp_fund & (T_RECORD|T_ARRAY))
#define WA(sz) (align(sz, (int) word_size))
#ifdef DEBUG
#define ResultType(tpx) (assert((tpx)->tp_fund == T_PROCEDURE),\
(tpx)->next)
#define ParamList(tpx) (assert((tpx)->tp_fund == T_PROCEDURE),\
@ -160,6 +161,13 @@ struct type
(tpx)->next)
#define PointedtoType(tpx) (assert((tpx)->tp_fund == T_POINTER),\
(tpx)->next)
#else DEBUG
#define ResultType(tpx) ((tpx)->next)
#define ParamList(tpx) ((tpx)->prc_params)
#define IndexType(tpx) ((tpx)->next)
#define ElementType(tpx) ((tpx)->next)
#define PointedtoType(tpx) ((tpx)->next)
#endif DEBUG
#define BaseType(tpx) ((tpx)->tp_fund == T_SUBRANGE ? (tpx)->next : \
(tpx))
#define IsConstructed(tpx) ((tpx)->tp_fund & T_CONSTRUCTED)

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

@ -652,8 +652,7 @@ DumpType(tp)
print(" fund:");
switch(tp->tp_fund) {
case T_RECORD:
print("RECORD\n");
DumpScope(tp->rec_scope->sc_def);
print("RECORD");
break;
case T_ENUMERATION:
print("ENUMERATION; ncst:%d", tp->enm_ncst); break;

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

@ -63,7 +63,7 @@ TstParEquiv(tp1, tp2)
int
TstProcEquiv(tp1, tp2)
register struct type *tp1, *tp2;
struct type *tp1, *tp2;
{
/* Test if two procedure types are equivalent. This routine
may also be used for the testing of assignment compatibility
@ -105,31 +105,24 @@ TstCompat(tp1, tp2)
tp1 = BaseType(tp1);
tp2 = BaseType(tp2);
if (tp2 != intorcard_type &&
(tp1 == intorcard_type || tp1 == address_type)) {
struct type *tmp = tp2;
tp2 = tp1;
tp1 = tmp;
}
return tp1 == tp2
||
( tp1 == intorcard_type
&&
(tp2 == int_type || tp2 == card_type || tp2 == address_type)
)
||
( tp2 == intorcard_type
&&
(tp1 == int_type || tp1 == card_type || tp1 == address_type)
)
||
( tp1 == address_type
&&
( tp2 == card_type
|| tp2->tp_fund == T_POINTER
)
)
||
( tp2 == address_type
&&
( tp1 == card_type
|| tp1->tp_fund == T_POINTER
)
( tp1 == card_type || tp1->tp_fund == T_POINTER)
)
;
}
@ -151,6 +144,9 @@ TstAssCompat(tp1, tp2)
if ((tp1->tp_fund & T_INTORCARD) &&
(tp2->tp_fund & T_INTORCARD)) return 1;
if ((tp1->tp_fund == T_REAL) &&
(tp2->tp_fund == T_REAL)) return 1;
if (tp1->tp_fund == T_PROCEDURE &&
tp2->tp_fund == T_PROCEDURE) {
return TstProcEquiv(tp1, tp2);

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

@ -141,8 +141,8 @@ WalkModule(module)
}
MkCalls(sc->sc_def);
proclevel++;
DO_DEBUG(options['X'], PrNode(module->mod_body, 0));
WalkNode(module->mod_body, NO_EXIT_LABEL);
DO_DEBUG(options['X'], PrNode(module->mod_body, 0));
C_df_ilb(RETURN_LABEL);
EndPriority();
C_ret((arith) 0);
@ -293,8 +293,8 @@ WalkProcedure(procedure)
text_label = 1; /* label at end of procedure */
DO_DEBUG(options['X'], PrNode(procedure->prc_body, 0));
WalkNode(procedure->prc_body, NO_EXIT_LABEL);
DO_DEBUG(options['X'], PrNode(procedure->prc_body, 0));
C_df_ilb(RETURN_LABEL); /* label at end */
tp = func_type;
if (func_res_label) {