From bb9b16ab503e06dc04177663ee2f2c9980e2cb7a Mon Sep 17 00:00:00 2001 From: ceriel Date: Wed, 27 May 1987 10:16:03 +0000 Subject: [PATCH] fixes, added some standard functions to handle LONGREAL, LONGINT --- lang/m2/comp/.distr | 62 +++++++++++++++++++++++++++++++++++++++ lang/m2/comp/LLlex.c | 32 ++++++++++++++++---- lang/m2/comp/chk_expr.c | 41 ++++++++++++++++++++++++-- lang/m2/comp/code.c | 12 ++++---- lang/m2/comp/cstoper.c | 15 ++++++---- lang/m2/comp/defmodule.c | 3 +- lang/m2/comp/desig.c | 10 +++++-- lang/m2/comp/desig.h | 3 ++ lang/m2/comp/expression.g | 8 ++--- lang/m2/comp/f_info.h | 1 + lang/m2/comp/main.c | 16 ++++++++++ lang/m2/comp/node.c | 8 ++++- lang/m2/comp/standards.h | 4 +++ lang/m2/comp/type.H | 8 +++++ lang/m2/comp/type.c | 3 +- lang/m2/comp/typequiv.c | 28 ++++++++---------- lang/m2/comp/walk.c | 4 +-- 17 files changed, 210 insertions(+), 48 deletions(-) create mode 100644 lang/m2/comp/.distr diff --git a/lang/m2/comp/.distr b/lang/m2/comp/.distr new file mode 100644 index 000000000..d5a1d5836 --- /dev/null +++ b/lang/m2/comp/.distr @@ -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 diff --git a/lang/m2/comp/LLlex.c b/lang/m2/comp/LLlex.c index 3c6a047b7..95098c97d 100644 --- a/lang/m2/comp/LLlex.c +++ b/lang/m2/comp/LLlex.c @@ -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*/ diff --git a/lang/m2/comp/chk_expr.c b/lang/m2/comp/chk_expr.c index 75e20d6a2..9da7a7132 100644 --- a/lang/m2/comp/chk_expr.c +++ b/lang/m2/comp/chk_expr.c @@ -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; diff --git a/lang/m2/comp/code.c b/lang/m2/comp/code.c index 305d2c4fc..ed6062bd1 100644 --- a/lang/m2/comp/code.c +++ b/lang/m2/comp/code.c @@ -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: diff --git a/lang/m2/comp/cstoper.c b/lang/m2/comp/cstoper.c index a02cb3896..a2f182f6b 100644 --- a/lang/m2/comp/cstoper.c +++ b/lang/m2/comp/cstoper.c @@ -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); diff --git a/lang/m2/comp/defmodule.c b/lang/m2/comp/defmodule.c index 6b913327a..0bbe2e04e 100644 --- a/lang/m2/comp/defmodule.c +++ b/lang/m2/comp/defmodule.c @@ -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 */ diff --git a/lang/m2/comp/desig.c b/lang/m2/comp/desig.c index 4d1635aae..e9d37352c 100644 --- a/lang/m2/comp/desig.c +++ b/lang/m2/comp/desig.c @@ -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) diff --git a/lang/m2/comp/desig.h b/lang/m2/comp/desig.h index 690dd9b05..6a9f67ddf 100644 --- a/lang/m2/comp/desig.h +++ b/lang/m2/comp/desig.h @@ -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. diff --git a/lang/m2/comp/expression.g b/lang/m2/comp/expression.g index ba91265be..92cc725dc 100644 --- a/lang/m2/comp/expression.g +++ b/lang/m2/comp/expression.g @@ -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)); } ; diff --git a/lang/m2/comp/f_info.h b/lang/m2/comp/f_info.h index 4d8c04020..452d8a3fe 100644 --- a/lang/m2/comp/f_info.h +++ b/lang/m2/comp/f_info.h @@ -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 diff --git a/lang/m2/comp/main.c b/lang/m2/comp/main.c index 0c76c65ed..9f5bc8ed9 100644 --- a/lang/m2/comp/main.c +++ b/lang/m2/comp/main.c @@ -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"); +} diff --git a/lang/m2/comp/node.c b/lang/m2/comp/node.c index 1aa825ddb..f0c49da5e 100644 --- a/lang/m2/comp/node.c +++ b/lang/m2/comp/node.c @@ -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) diff --git a/lang/m2/comp/standards.h b/lang/m2/comp/standards.h index e229ff759..5dd28a6f6 100644 --- a/lang/m2/comp/standards.h +++ b/lang/m2/comp/standards.h @@ -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 ... */ diff --git a/lang/m2/comp/type.H b/lang/m2/comp/type.H index 06cc533c5..da40e3b0b 100644 --- a/lang/m2/comp/type.H +++ b/lang/m2/comp/type.H @@ -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) diff --git a/lang/m2/comp/type.c b/lang/m2/comp/type.c index 9afdc889a..431218c5e 100644 --- a/lang/m2/comp/type.c +++ b/lang/m2/comp/type.c @@ -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; diff --git a/lang/m2/comp/typequiv.c b/lang/m2/comp/typequiv.c index 565fb8b12..0452b1fc8 100644 --- a/lang/m2/comp/typequiv.c +++ b/lang/m2/comp/typequiv.c @@ -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); diff --git a/lang/m2/comp/walk.c b/lang/m2/comp/walk.c index f64ac4070..ad0bae8fc 100644 --- a/lang/m2/comp/walk.c +++ b/lang/m2/comp/walk.c @@ -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) { -- 2.34.1