#include "input.h"
#include "main.h"
#include "type.h"
+#include "error.h"
+#include "ack_string.h"
+
-extern long str2long();
-extern char *Malloc();
#define TO_LOWER(ch) (ch |= ( ch>='A' && ch<='Z' ) ? 0x0020 : 0)
/* Warning: The options specified inside comments take precedence over
* the ones on the command line.
*/
-CommentOptions()
+void CommentOptions(void)
{
register int ch, ci;
int on_on_minus = 0;
}
-STATIC void
-SkipComment()
+static void SkipComment(void)
{
/* Skip ISO-Pascal comments (* ... *) or { ... }.
Note :
}
}
-STATIC struct string *
-GetString( delim )
-register int delim;
+static struct string *GetString(register int delim)
{
/* Read a Pascal string, delimited by the character ' or ".
*/
static char *s_error = "illegal line directive";
-void
-CheckForLineDirective()
+void CheckForLineDirective(void)
{
register int ch;
register int i = 0;
LineNumber = i;
}
-int
-LLlex()
+int LLlex(void)
{
/* LLlex() is the Lexical Analyzer.
The putting aside of tokens is taken into account.
while (*np == '0') /* skip leading zeros */
np++;
tk->TOK_INT = str2long(np, 10);
- if( tk->TOK_INT < 0 ||
- strlen(np) > strlen(maxint_str) ||
- strlen(np) == strlen(maxint_str) &&
- strcmp(np, maxint_str) > 0 )
+ if( (tk->TOK_INT < 0) ||
+ (strlen(np) > strlen(maxint_str)) ||
+ (strlen(np) == strlen(maxint_str) &&
+ strcmp(np, maxint_str) > 0) )
lexwarning("overflow in constant");
}
toktype = int_type;
/* T O K E N D E S C R I P T O R D E F I N I T I O N */
+#ifndef LLLEX_H_
+#define LLLEX_H_
+
+#include "em_label.h"
+#include "em_arith.h"
/* Structure to store a string constant
*/
extern int tokenseen;
#define ASIDE aside.tk_symb
+
+void CheckForLineDirective(void);
+int LLlex(void);
+
+#endif
#include "LLlex.h"
#include "Lpars.h"
#include "idf.h"
+#include "node.h"
#include "type.h"
+#include "misc.h"
+#include "error.h"
-extern char *symbol2str();
-extern char *Malloc(), *Salloc();
-extern struct idf *gen_anon_idf();
extern int expect_label;
-LLmessage(tk)
- register int tk;
+void LLmessage(register int tk)
{
if( tk > 0 ) {
/* if( tk > 0 ), it represents the token to be inserted.
!File: debugcst.h
-/*#define DEBUG 1 /* perform various self-tests */
+/*#define DEBUG 1 *//* perform various self-tests */
#define NDEBUG 1 /* disable assertions */
!File: nocross.h
-/*#define NOCROSS 1 /* define when cross compiler not needed */
+/*#define NOCROSS 1 *//* define when cross compiler not needed */
!File: dbsymtab.h
#include "node.h"
#include "scope.h"
#include "type.h"
+#include "code.h"
+#include "chk_expr.h"
+#include "tmpvar.h"
+#include "typequiv.h"
+#include "error.h"
-MarkDef(nd, flags, on)
- register struct node *nd;
- unsigned short flags;
+void MarkDef(register struct node *nd, unsigned short flags, int on)
{
- while( nd && nd->nd_class != Def ) {
- if( (nd->nd_class == Arrsel) ||
- (nd->nd_class == LinkDef) )
+ while (nd && nd->nd_class != Def)
+ {
+ if ((nd->nd_class == Arrsel) || (nd->nd_class == LinkDef))
nd = nd->nd_left;
- else if( nd->nd_class == Arrow )
+ else if (nd->nd_class == Arrow)
nd = nd->nd_right;
- else break;
+ else
+ break;
}
- if( nd && (nd->nd_class == Def) ) {
- if( (flags & D_SET) && on &&
- BlockScope != nd->nd_def->df_scope )
+ if (nd && (nd->nd_class == Def))
+ {
+ if ((flags & D_SET) && on && BlockScope != nd->nd_def->df_scope)
nd->nd_def->df_flags |= D_SETINHIGH;
- if( on ) {
+ if (on)
+ {
/*
- if( (flags & D_SET) &&
- (nd->nd_def->df_flags & D_WITH) )
- node_warning(nd,
- "variable \"%s\" already referenced in with",
- nd->nd_def->df_idf->id_text);
- */
+ if( (flags & D_SET) &&
+ (nd->nd_def->df_flags & D_WITH) )
+ node_warning(nd,
+ "variable \"%s\" already referenced in with",
+ nd->nd_def->df_idf->id_text);
+ */
nd->nd_def->df_flags |= flags;
}
else
}
}
-void
-AssertStat(expp, line)
- register struct node *expp;
- unsigned short line;
+void AssertStat(register struct node *expp, unsigned short line)
{
struct desig dsr;
- if( !ChkExpression(expp) )
- return;
+ if (!ChkExpression(expp))
+ return;
- if( expp->nd_type != bool_type ) {
+ if (expp->nd_type != bool_type)
+ {
node_error(expp, "type of assertion should be boolean");
return;
}
- if( !options['a'] && !err_occurred ) {
+ if (!options['a'] && !err_occurred)
+ {
dsr = InitDesig;
CodeExpr(expp, &dsr, NO_LABEL);
- C_loc((arith)line);
+ C_loc((arith) line);
C_cal("_ass");
}
}
-void
-AssignStat(left, right)
- register struct node *left, *right;
+void AssignStat(register struct node *left, register struct node *right)
{
register struct type *ltp, *rtp;
int retval = 0;
ltp = left->nd_type;
rtp = right->nd_type;
- MarkDef(left, (unsigned short)D_SET, 1);
+ MarkDef(left, (unsigned short) D_SET, 1);
- if( !retval ) return;
+ if (!retval)
+ return;
- if( ltp == int_type && rtp == long_type ) {
+ if (ltp == int_type && rtp == long_type)
+ {
right = MkNode(IntReduc, NULLNODE, right, &dot);
right->nd_type = int_type;
}
- else if( ltp == long_type && rtp == int_type ) {
+ else if (ltp == long_type && rtp == int_type)
+ {
right = MkNode(IntCoerc, NULLNODE, right, &dot);
right->nd_type = long_type;
}
- if( !TstAssCompat(ltp, rtp) ) {
+ if (!TstAssCompat(ltp, rtp))
+ {
node_error(left, "type incompatibility in assignment");
return;
}
- if( left->nd_class == Def &&
- (left->nd_def->df_flags & D_INLOOP) ) {
+ if (left->nd_class == Def && (left->nd_def->df_flags & D_INLOOP))
+ {
node_error(left, "assignment to a control variable");
return;
}
- if( rtp == emptyset_type )
+ if (rtp == emptyset_type)
right->nd_type = ltp;
- if( !err_occurred ) {
+ if (!err_occurred)
+ {
dsr = InitDesig;
CodeExpr(right, &dsr, NO_LABEL);
- if( rtp->tp_fund & (T_ARRAY | T_RECORD) )
+ if (rtp->tp_fund & (T_ARRAY | T_RECORD))
CodeAddress(&dsr);
- else {
+ else
+ {
CodeValue(&dsr, rtp);
- if( ltp == real_type && BaseType(rtp) == int_type )
+ if (ltp == real_type && BaseType(rtp) == int_type)
Int2Real(rtp->tp_size);
RangeCheck(ltp, rtp);
FreeNode(right);
}
-void
-ProcStat(nd)
- register struct node *nd;
+void ProcStat(register struct node *nd)
{
- if( !ChkCall(nd) ) return;
+ if (!ChkCall(nd))
+ return;
- if( nd->nd_type ) {
+ if (nd->nd_type)
+ {
node_error(nd, "procedure call expected");
return;
}
}
-void
-ChkForStat(nd)
- register struct node *nd;
+void ChkForStat(register struct node *nd)
{
register struct def *df;
int retvar = 0;
MarkUsed(nd->nd_left);
retvar &= ChkExpression(nd->nd_right);
MarkUsed(nd->nd_right);
- if( !retvar ) return;
+ if (!retvar)
+ return;
assert(nd->nd_class == Def);
df = nd->nd_def;
- if( df->df_scope != BlockScope ) {
+ if (df->df_scope != BlockScope)
+ {
node_error(nd, "for loop: control variable must be local");
return;
}
assert(df->df_kind == D_VARIABLE);
- if( df->df_scope != GlobalScope && df->var_off >= 0 ) {
- node_error(nd,
- "for loop: control variable can't be a parameter");
- MarkDef(nd,(unsigned short)(D_LOOPVAR | D_SET | D_USED), 1);
+ if (df->df_scope != GlobalScope && df->var_off >= 0)
+ {
+ node_error(nd, "for loop: control variable can't be a parameter");
+ MarkDef(nd, (unsigned short) (D_LOOPVAR | D_SET | D_USED), 1);
return;
}
- if( !(df->df_type->tp_fund & T_ORDINAL) ) {
+ if (!(df->df_type->tp_fund & T_ORDINAL))
+ {
node_error(nd, "for loop: control variable must be ordinal");
- MarkDef(nd,(unsigned short)(D_LOOPVAR | D_SET | D_USED), 1);
+ MarkDef(nd, (unsigned short) (D_LOOPVAR | D_SET | D_USED), 1);
return;
}
- if( !TstCompat(df->df_type, nd->nd_left->nd_type) )
+ if (!TstCompat(df->df_type, nd->nd_left->nd_type))
node_error(nd,
- "for loop: initial value incompatible with control variable");
+ "for loop: initial value incompatible with control variable");
- if( !TstCompat(df->df_type, nd->nd_right->nd_type) )
+ if (!TstCompat(df->df_type, nd->nd_right->nd_type))
node_error(nd,
- "for loop: final value incompatible with control variable");
-
- if( df->df_type == long_type )
+ "for loop: final value incompatible with control variable");
+
+ if (df->df_type == long_type)
node_error(nd, "for loop: control variable can not be a long");
- if( df->df_flags & D_INLOOP )
+ if (df->df_flags & D_INLOOP)
node_error(nd, "for loop: control variable already used");
- if( df->df_flags & D_SETINHIGH )
- node_error(nd,
- "for loop: control variable already set in block");
+ if (df->df_flags & D_SETINHIGH)
+ node_error(nd, "for loop: control variable already set in block");
- MarkDef(nd,(unsigned short) (D_LOOPVAR | D_INLOOP | D_SET | D_USED), 1);
+ MarkDef(nd, (unsigned short) (D_LOOPVAR | D_INLOOP | D_SET | D_USED), 1);
return;
}
-void
-EndForStat(nd)
- register struct node *nd;
+void EndForStat(register struct node *nd)
{
register struct def *df;
df = nd->nd_def;
- if( (df->df_scope != BlockScope) ||
- (df->df_scope != GlobalScope && df->var_off >= 0) ||
- !(df->df_type->tp_fund & T_ORDINAL)
- )
+ if ((df->df_scope != BlockScope)
+ || (df->df_scope != GlobalScope && df->var_off >= 0)
+ || !(df->df_type->tp_fund & T_ORDINAL))
return;
- MarkDef(nd,(unsigned short) (D_INLOOP | D_SET), 0);
+ MarkDef(nd, (unsigned short) (D_INLOOP | D_SET), 0);
}
-arith
-CodeInitFor(nd, priority)
- register struct node *nd;
+arith CodeInitFor(register struct node *nd, int priority)
{
/* Push final-value, the value may only be evaluated
- once, so generate a temporary for it, when not a constant.
- */
+ once, so generate a temporary for it, when not a constant.
+ */
arith tmp;
CodePExpr(nd);
- if( nd->nd_class != Value ) {
+ if (nd->nd_class != Value)
+ {
tmp = NewInt(priority);
C_dup(int_size);
return (arith) 0;
}
-CodeFor(nd, stepsize, l1, l2)
- struct node *nd;
- label l1, l2;
+void CodeFor(struct node *nd, int stepsize, label l1, label l2)
{
/* Test if loop has to be done */
- if( stepsize == 1 ) /* TO */
+ if (stepsize == 1) /* TO */
C_bgt(l2);
- else /* DOWNTO */
+ else
+ /* DOWNTO */
C_blt(l2);
/* Label at begin of the body */
CodeDStore(nd);
}
-CodeEndFor(nd, stepsize, l1, l2, tmp2)
- struct node *nd;
- label l1, l2;
- arith tmp2;
+void CodeEndFor(struct node *nd, int stepsize, label l1, label l2, arith tmp2)
{
/* Test if loop has to be done once more */
CodePExpr(nd);
C_dup(int_size);
- if( tmp2 )
+ if (tmp2)
C_lol(tmp2);
else
CodePExpr(nd->nd_right);
C_beq(l2);
/* Increment/decrement the control-variable */
- if( stepsize == 1 ) /* TO */
+ if (stepsize == 1) /* TO */
C_inc();
- else /* DOWNTO */
+ else
+ /* DOWNTO */
C_dec();
C_bra(l1);
C_asp(int_size);
}
-void
-WithStat(nd)
- struct node *nd;
+void WithStat(struct node *nd)
{
struct withdesig *wds;
struct desig ds;
struct scopelist *scl;
- if( nd->nd_type->tp_fund != T_RECORD ) {
+ if (nd->nd_type->tp_fund != T_RECORD)
+ {
node_error(nd, "record variable expected");
return;
}
- MarkDef(nd, (unsigned short)(D_USED | D_SET | D_WITH), 1);
+ MarkDef(nd, (unsigned short) (D_USED | D_SET | D_WITH), 1);
/*
- if( (nd->nd_class == Arrow) &&
- (nd->nd_right->nd_type->tp_fund & T_FILE) ) {
- nd->nd_right->nd_def->df_flags |= D_WITH;
- }
- */
+ if( (nd->nd_class == Arrow) &&
+ (nd->nd_right->nd_type->tp_fund & T_FILE) ) {
+ nd->nd_right->nd_def->df_flags |= D_WITH;
+ }
+ */
scl = new_scopelist();
scl->sc_scope = nd->nd_type->rec_scope;
scl->next = CurrVis;
CurrVis = scl;
- if( err_occurred ) return;
+ if (err_occurred)
+ return;
/* Generate code */
wds->w_desig = ds;
}
-EndWith(saved_scl, nd)
- struct scopelist *saved_scl;
- struct node *nd;
+void EndWith(struct scopelist *saved_scl, struct node *nd)
{
/* restore scope, and release structures */
struct scopelist *scl;
struct withdesig *wds;
struct node *nd1;
- while( CurrVis != saved_scl ) {
+ while (CurrVis != saved_scl)
+ {
/* release scopelist */
scl = CurrVis;
CurrVis = CurrVis->next;
free_scopelist(scl);
- if( WithDesigs == 0 )
- continue; /* we didn't generate any code */
+ if (WithDesigs == 0)
+ continue; /* we didn't generate any code */
/* release temporary */
FreePtr(WithDesigs->w_desig.dsg_offset);
free_withdesig(wds);
}
- for( nd1 = nd; nd1 != NULLNODE; nd1 = nd1->nd_right ) {
- MarkDef(nd1->nd_left, (unsigned short)(D_WITH), 0);
+ for (nd1 = nd; nd1 != NULLNODE; nd1 = nd1->nd_right)
+ {
+ MarkDef(nd1->nd_left, (unsigned short) (D_WITH), 0);
}
FreeNode(nd);
--- /dev/null
+/* Copyright (c) 2019 ACK Project.
+ * See the copyright notice in the ACK home directory,
+ * in the file "Copyright".
+ *
+ */
+#ifndef BODY_H_
+#define BODY_H_
+
+#include "em_arith.h"
+#include "em_label.h"
+
+
+struct node;
+struct scopelist;
+
+
+void MarkDef(register struct node *nd, unsigned short flags, int on);
+
+/* Assert statement */
+void AssertStat(register struct node *expp, unsigned short line);
+/** Assign statement */
+void AssignStat(register struct node *left, register struct node *right);
+/** Procedure call statement */
+void ProcStat(register struct node *nd);
+
+/** ??? */
+void ChkForStat(register struct node *nd);
+/** ??? */
+void EndForStat(register struct node *nd);
+arith CodeInitFor(register struct node *nd, int priority);
+void CodeFor(struct node *nd, int stepsize, label l1, label l2);
+void CodeEndFor(struct node *nd, int stepsize, label l1, label l2, arith tmp2);
+
+/* With statement */
+void WithStat(struct node *nd);
+void EndWith(struct scopelist *saved_scl, struct node *nd);
+
+#endif /* BODY_H_ */
"modules/src/string+lib",
"modules/src/system+lib",
},
- vars = {
- ["+cflags"] = "-DSTATIC=static"
- }
}
installable {
--- /dev/null
+/* Copyright (c) 2019 ACK Project.
+ * See the copyright notice in the ACK home directory,
+ * in the file "Copyright".
+ *
+ */
+#ifndef CASESTAT_H_
+#define CASESTAT_H_
+
+#include <em_label.h>
+
+struct node;
+
+void CaseExpr(struct node *nd);
+void CaseEnd(struct node *nd, label exit_label);
+
+
+
+
+#endif /* CASESTAT_H_ */
#include "main.h"
#include "node.h"
#include "type.h"
+#include "code.h"
+#include "error.h"
+#include "typequiv.h"
+#include "casestat.h"
struct case_hdr {
struct case_hdr *ch_next; /* in the free list */
*/
#define compact(nr, low, up) (nr != 0 && (up - low) / nr <= DENSITY)
+static void FreeCh(register struct case_hdr *);
+static int AddCases(register struct case_hdr *, register struct node *, label);
+static int AddOneCase(register struct case_hdr *, register struct node *, label);
+static void CaseCode(label, struct case_hdr *, label);
+
+
void
-CaseExpr(nd)
- struct node *nd;
+CaseExpr(struct node *nd)
{
/* Check the expression and generate code for it
*/
}
void
-CaseEnd(nd, exit_label)
- struct node *nd;
- label exit_label;
+CaseEnd(
+ struct node *nd,
+ label exit_label)
{
/* Stack a new case header and fill in the necessary fields.
*/
FreeNode(nd);
}
-FreeCh(ch)
- register struct case_hdr *ch;
+static void FreeCh(register struct case_hdr *ch)
{
/* free the allocated case structure
*/
free_case_hdr(ch);
}
-AddCases(ch, nd, CaseLabel)
- register struct case_hdr *ch;
- register struct node *nd;
- label CaseLabel;
+static int AddCases(
+ register struct case_hdr *ch,
+ register struct node *nd,
+ label CaseLabel)
{
while( nd ) {
if( !AddOneCase(ch, nd, CaseLabel) )
return 1;
}
-AddOneCase(ch, nd, lbl)
- register struct case_hdr *ch;
- register struct node *nd;
- label lbl;
+static int AddOneCase(
+ register struct case_hdr *ch,
+ register struct node *nd,
+ label lbl)
{
register struct case_entry *ce = new_case_entry();
register struct case_entry *c1 = ch->ch_entries, *c2 = 0;
return 1;
}
-CaseCode(lbl, ch, exit_label)
- label lbl;
- struct case_hdr *ch;
- label exit_label;
+static void CaseCode(
+ label lbl,
+ struct case_hdr *ch,
+ label exit_label)
{
label CaseDescrLab = ++data_label; /* rom must have a label */
/* E X P R E S S I O N C H E C K I N G */
/* Check expressions, and try to evaluate them as far as possible.
-*/
+ */
#include "parameters.h"
#include "debug.h"
#include <assert.h>
#include <em_arith.h>
#include <em_label.h>
-#include <system.h>
-#include <print.h>
+#include "print.h"
#include "LLlex.h"
#include "Lpars.h"
#include "required.h"
#include "scope.h"
#include "type.h"
+#include "typequiv.h"
+#include "readwrite.h"
+#include "body.h"
+#include "cstoper.h"
+#include "error.h"
-extern char *symbol2str();
-STATIC int ChkUnOper();
+static int ChkValue(register struct node *);
+static int ChkUnOper(register struct node *);
+static int ChkStandard(register struct node *, register struct node *);
-STATIC
-Xerror(nd, mess)
- register struct node *nd;
- char *mess;
+
+static void Xerror(register struct node *nd, char *mess)
{
- if( nd->nd_class == Def && nd->nd_def ) {
- if( nd->nd_def->df_kind != D_ERROR )
- node_error(nd,"\"%s\": %s",
- nd->nd_def->df_idf->id_text, mess);
+ if (nd->nd_class == Def && nd->nd_def)
+ {
+ if (nd->nd_def->df_kind != D_ERROR)
+ node_error(nd, "\"%s\": %s", nd->nd_def->df_idf->id_text, mess);
}
- else node_error(nd, "%s", mess);
+ else
+ node_error(nd, "%s", mess);
}
-struct node *
-ZeroParam()
+struct node *ZeroParam(void)
{
register struct node *nd;
return nd;
}
-MarkUsed(nd)
- register struct node *nd;
+void MarkUsed(register struct node *nd)
{
- while( nd && nd->nd_class != Def ) {
- if( (nd->nd_class == Arrsel) || (nd->nd_class == LinkDef) )
+ while (nd && nd->nd_class != Def)
+ {
+ if ((nd->nd_class == Arrsel) || (nd->nd_class == LinkDef))
nd = nd->nd_left;
- else if( nd->nd_class == Arrow)
+ else if (nd->nd_class == Arrow)
nd = nd->nd_right;
- else break;
+ else
+ break;
}
- if( nd && nd->nd_class == Def ) {
+ if (nd && nd->nd_class == Def)
+ {
register struct def *df = nd->nd_def;
- if( df->df_kind != D_FIELD ) {
- if( !(df->df_flags & (D_SET|D_VARPAR)) &&
- (df->df_scope == CurrentScope) )
- if( !is_anon_idf(df->df_idf) ) {
- warning("\"%s\" used before set",
- df->df_idf->id_text);
+ if (df->df_kind != D_FIELD)
+ {
+ if (!(df->df_flags & (D_SET | D_VARPAR))
+ && (df->df_scope == CurrentScope))
+ if (!is_anon_idf(df->df_idf))
+ {
+ warning("\"%s\" used before set", df->df_idf->id_text);
}
df->df_flags |= (D_USED | D_SET);
}
}
}
-int
-ChkConstant(expp)
- register struct node *expp;
+int ChkConstant(register struct node *expp)
{
register struct node *nd;
- if( !(nd = expp->nd_right) ) nd = expp;
+ if (!(nd = expp->nd_right))
+ nd = expp;
- if( nd->nd_class == Name && !ChkLinkOrName(nd) ) return 0;
+ if (nd->nd_class == Name && !ChkLinkOrName(nd))
+ return 0;
- if( nd->nd_class != Value || expp->nd_left ) {
+ if (nd->nd_class != Value || expp->nd_left)
+ {
Xerror(nd, "constant expected");
return 0;
}
- if( expp->nd_class == Uoper )
+ if (expp->nd_class == Uoper)
return ChkUnOper(expp);
- else if( nd != expp ) {
+ else if (nd != expp)
+ {
Xerror(expp, "constant expected");
return 0;
}
return 1;
}
-int
-ChkVariable(expp)
- register struct node *expp;
+int ChkVariable(register struct node *expp)
{
/* Check that "expp" indicates an item that can be accessed */
- if( !ChkLhs(expp) ) return 0;
+ if (!ChkLhs(expp))
+ return 0;
- if( expp->nd_class == Def && expp->nd_def->df_kind == D_FUNCTION ) {
+ if (expp->nd_class == Def && expp->nd_def->df_kind == D_FUNCTION)
+ {
Xerror(expp, "illegal use of function name");
return 0;
}
return 1;
}
-int
-ChkLhs(expp)
- register struct node *expp;
+int ChkLhs(register struct node *expp)
{
int class;
- /* Check that "expp" indicates an item that can be the lhs
- of an assignment.
- */
- if( !ChkVarAccess(expp) ) return 0;
+
+ if (!ChkVarAccess(expp)) return 0;
class = expp->nd_class;
/* a constant is replaced by it's value in ChkLinkOrName, check here !,
* the remaining classes are checked by ChkVarAccess
*/
- if( class == Value ) {
+ if (class == Value)
+ {
node_error(expp, "can't access a value");
return 0;
}
- if( class == Def &&
- !(expp->nd_def->df_kind & (D_FIELD | D_FUNCTION | D_VARIABLE)) ) {
+ if (class == Def
+ && !(expp->nd_def->df_kind & (D_FIELD | D_FUNCTION | D_VARIABLE)))
+ {
Xerror(expp, "variable expected");
return 0;
}
/* assignment to function name */
- if( class == Def && expp->nd_def->df_kind == D_FUNCTION )
- if( expp->nd_def->prc_res )
+ if (class == Def && expp->nd_def->df_kind == D_FUNCTION)
+ if (expp->nd_def->prc_res)
expp->nd_type = ResultType(expp->nd_def->df_type);
- else {
+ else
+ {
Xerror(expp, "illegal assignment to function-name");
return 0;
}
}
#ifdef DEBUG
-STATIC int
-ChkValue(expp)
- register struct node *expp;
+static int ChkValue(register struct node *expp)
{
- switch( expp->nd_symb ) {
+ switch( expp->nd_symb )
+ {
case INTEGER:
case REAL:
case STRING:
case NIL:
- return 1;
+ return 1;
default:
- crash("(ChkValue)");
+ crash("(ChkValue)");
}
/*NOTREACHED*/
}
#endif
-int
-ChkLinkOrName(expp)
- register struct node *expp;
+int ChkLinkOrName(register struct node *expp)
{
register struct def *df;
expp->nd_type = error_type;
- if( expp->nd_class == Name ) {
+ if (expp->nd_class == Name)
+ {
expp->nd_def = lookfor(expp, CurrVis, 1);
expp->nd_class = Def;
expp->nd_type = expp->nd_def->df_type;
}
- else if( expp->nd_class == Link ) {
+ else if (expp->nd_class == Link)
+ {
/* a selection from a record */
register struct node *left = expp->nd_left;
assert(expp->nd_symb == '.');
- if( !ChkVariable(left) ) return 0;
+ if (!ChkVariable(left))
+ return 0;
- if( left->nd_type->tp_fund != T_RECORD ) {
+ if (left->nd_type->tp_fund != T_RECORD)
+ {
Xerror(left, "illegal selection");
return 0;
}
- if( !(df = lookup(expp->nd_IDF, left->nd_type->rec_scope, D_INUSE)) ) {
+ if (!(df = lookup(expp->nd_IDF, left->nd_type->rec_scope, D_INUSE)))
+ {
id_not_declared(expp);
return 0;
}
- else {
+ else
+ {
expp->nd_def = df;
expp->nd_type = df->df_type;
expp->nd_class = LinkDef;
df = expp->nd_def;
- if( df->df_kind & (D_ENUM | D_CONST) ) {
+ if (df->df_kind & (D_ENUM | D_CONST))
+ {
MarkUsed(expp);
/* Replace an enum-literal or a CONST identifier by its value.
- */
- if( df->df_kind == D_ENUM ) {
+ */
+ if (df->df_kind == D_ENUM)
+ {
expp->nd_class = Value;
expp->nd_INT = df->enm_val;
expp->nd_symb = INTEGER;
}
- else {
+ else
+ {
unsigned int ln = expp->nd_lineno;
assert(df->df_kind == D_CONST);
return df->df_kind != D_ERROR;
}
-STATIC int
-ChkExLinkOrName(expp)
- register struct node *expp;
+static int ChkExLinkOrName(register struct node *expp)
{
- if( !ChkLinkOrName(expp) ) return 0;
- if( expp->nd_class != Def ) return 1;
+ if (!ChkLinkOrName(expp))
+ return 0;
+ if (expp->nd_class != Def)
+ return 1;
- if( !(expp->nd_def->df_kind & D_VALUE) ) {
+ if (!(expp->nd_def->df_kind & D_VALUE))
+ {
Xerror(expp, "value expected");
}
return 1;
}
-STATIC int
-ChkUnOper(expp)
- register struct node *expp;
+static int ChkUnOper(register struct node *expp)
{
/* Check an unary operation.
- */
+ */
register struct node *right = expp->nd_right;
register struct type *tpr;
- if( !ChkExpression(right) ) return 0;
+ if (!ChkExpression(right)) return 0;
MarkUsed(right);
expp->nd_type = tpr = BaseType(right->nd_type);
- switch( expp->nd_symb ) {
+ switch (expp->nd_symb)
+ {
case '+':
- if( tpr->tp_fund & T_NUMERIC ) {
+ if (tpr->tp_fund & T_NUMERIC)
+ {
*expp = *right;
free_node(right);
return 1;
break;
case '-':
- if( tpr->tp_fund == T_INTEGER || tpr->tp_fund == T_LONG ) {
- if( right->nd_class == Value )
+ if (tpr->tp_fund == T_INTEGER || tpr->tp_fund == T_LONG)
+ {
+ if (right->nd_class == Value)
cstunary(expp);
return 1;
}
- if( tpr->tp_fund == T_REAL ) {
- if( right->nd_class == Value ) {
+ if (tpr->tp_fund == T_REAL)
+ {
+ if (right->nd_class == Value)
+ {
expp->nd_token.tk_data.tk_real = right->nd_RIV;
expp->nd_class = Value;
expp->nd_symb = REAL;
break;
case NOT:
- if( tpr == bool_type ) {
- if( right->nd_class == Value )
+ if (tpr == bool_type)
+ {
+ if (right->nd_class == Value)
cstunary(expp);
return 1;
}
return 0;
}
-STATIC struct type *
-ResultOfOperation(operator, tpl, tpr)
- struct type *tpl, *tpr;
+static struct type *
+ResultOfOperation(int operator, struct type *tpl, struct type *tpr)
{
/* Return the result type of the binary operation "operator",
- with operand types "tpl" and "tpr".
+ with operand types "tpl" and "tpr".
*/
- switch( operator ) {
- case '=' :
- case NOTEQUAL :
- case '<' :
- case '>' :
- case LESSEQUAL :
- case GREATEREQUAL:
- case IN :
- return bool_type;
- case '+' :
- case '-' :
- case '*' :
- if( tpl == real_type || tpr == real_type )
- return real_type;
- if( tpl == long_type || tpr == long_type)
- return long_type;
- return tpl;
- case '/' :
- return real_type;
+ switch (operator)
+ {
+ case '=':
+ case NOTEQUAL:
+ case '<':
+ case '>':
+ case LESSEQUAL:
+ case GREATEREQUAL:
+ case IN:
+ return bool_type;
+ case '+':
+ case '-':
+ case '*':
+ if (tpl == real_type || tpr == real_type)
+ return real_type;
+ if (tpl == long_type || tpr == long_type)
+ return long_type;
+ return tpl;
+ case '/':
+ return real_type;
}
- if (tpr == long_type && tpl == int_type) return tpr;
+ if (tpr == long_type && tpl == int_type)
+ return tpr;
return tpl;
}
-STATIC int
-AllowedTypes(operator)
+static int AllowedTypes(int operator)
{
/* Return a bit mask indicating the allowed operand types for
- binary operator "operator".
+ binary operator "operator".
*/
- switch( operator ) {
- case '+' :
- case '-' :
- case '*' :
- return T_NUMERIC | T_SET;
- case '/' :
- return T_NUMERIC;
- case DIV :
- case MOD :
- return T_INTEGER | T_LONG;
- case OR :
- case AND :
- return T_ENUMERATION;
- case '=' :
- case NOTEQUAL :
- return T_ENUMERATION | T_CHAR | T_NUMERIC |
- T_SET | T_POINTER | T_STRINGCONST |
- T_STRING;
- case LESSEQUAL :
- case GREATEREQUAL:
- return T_ENUMERATION | T_CHAR | T_NUMERIC |
- T_SET | T_STRINGCONST;
- case '<' :
- case '>' :
- return T_ENUMERATION | T_CHAR | T_NUMERIC |
- T_STRINGCONST;
- default :
- crash("(AllowedTypes)");
+ switch (operator)
+ {
+ case '+':
+ case '-':
+ case '*':
+ return T_NUMERIC | T_SET;
+ case '/':
+ return T_NUMERIC;
+ case DIV:
+ case MOD:
+ return T_INTEGER | T_LONG;
+ case OR:
+ case AND:
+ return T_ENUMERATION;
+ case '=':
+ case NOTEQUAL:
+ return T_ENUMERATION | T_CHAR | T_NUMERIC | T_SET | T_POINTER
+ | T_STRINGCONST | T_STRING;
+ case LESSEQUAL:
+ case GREATEREQUAL:
+ return T_ENUMERATION | T_CHAR | T_NUMERIC | T_SET | T_STRINGCONST;
+ case '<':
+ case '>':
+ return T_ENUMERATION | T_CHAR | T_NUMERIC | T_STRINGCONST;
+ default:
+ crash("(AllowedTypes)");
}
/*NOTREACHED*/
}
-STATIC int
-Boolean(operator)
+static int Boolean(int operator)
{
return operator == OR || operator == AND;
}
-STATIC int
-ChkBinOper(expp)
- register struct node *expp;
+static int ChkBinOper(register struct node *expp)
{
/* Check a binary operation.
*/
tpl = BaseType(left->nd_type);
tpr = BaseType(right->nd_type);
- expp->nd_type = ResultOfOperation(expp->nd_symb, tpl ,tpr);
+ expp->nd_type = ResultOfOperation(expp->nd_symb, tpl, tpr);
/* Check that the application of the operator is allowed on the type
- of the operands.
- There are some needles and pins:
- - Boolean operators are only allowed on boolean operands, but the
- "allowed-mask" of "AllowedTypes" can only indicate an enumeration
- type.
- - The IN-operator has as right-hand-side operand a set.
- - Strings and packed arrays can be equivalent.
- - In some cases, integers must be converted to reals.
- - If one of the operands is the empty set then the result doesn't
- have to be the empty set.
- */
-
- if( expp->nd_symb == IN ) {
- if( tpr->tp_fund != T_SET ) {
+ of the operands.
+ There are some needles and pins:
+ - Boolean operators are only allowed on boolean operands, but the
+ "allowed-mask" of "AllowedTypes" can only indicate an enumeration
+ type.
+ - The IN-operator has as right-hand-side operand a set.
+ - Strings and packed arrays can be equivalent.
+ - In some cases, integers must be converted to reals.
+ - If one of the operands is the empty set then the result doesn't
+ have to be the empty set.
+ */
+
+ if (expp->nd_symb == IN)
+ {
+ if (tpr->tp_fund != T_SET)
+ {
node_error(expp, "\"IN\": right operand must be a set");
return 0;
}
- if( !TstAssCompat(tpl, ElementType(tpr)) ) {
+ if (!TstAssCompat(tpl, ElementType(tpr) ))
+ {
node_error(expp, "\"IN\": incompatible types");
return 0;
}
- if( left->nd_class == Value && right->nd_class == Set )
+ if (left->nd_class == Value && right->nd_class == Set)
cstset(expp);
return retval;
}
- if( !retval ) return 0;
+ if (!retval)
+ return 0;
allowed = AllowedTypes(expp->nd_symb);
- if( !(tpr->tp_fund & allowed) || !(tpl->tp_fund & allowed) ) {
+ if (!(tpr->tp_fund & allowed) || !(tpl->tp_fund & allowed))
+ {
arith ub;
extern arith IsString();
- if( allowed & T_STRINGCONST && (ub = IsString(tpl)) ) {
- if( ub == IsString(tpr) )
+ if (allowed & T_STRINGCONST && (ub = IsString(tpl)))
+ {
+ if (ub == IsString(tpr))
return 1;
- else {
+ else
+ {
node_error(expp, "\"%s\": incompatible types",
symbol2str(expp->nd_symb));
return 0;
}
}
- else if( allowed & T_STRING && tpl->tp_fund == T_STRING )
- return 1;
+ else if (allowed & T_STRING && tpl->tp_fund == T_STRING)
+ return 1;
node_error(expp, "\"%s\": illegal operand type(s)",
- symbol2str(expp->nd_symb));
+ symbol2str(expp->nd_symb));
return 0;
}
- if( Boolean(expp->nd_symb) && tpl != bool_type ) {
+ if (Boolean(expp->nd_symb) && tpl != bool_type)
+ {
node_error(expp, "\"%s\": illegal operand type(s)",
- symbol2str(expp->nd_symb));
+ symbol2str(expp->nd_symb));
return 0;
}
- if( allowed & T_NUMERIC ) {
- if( (tpl == int_type || tpl == long_type) &&
- (tpr == real_type || expp->nd_symb == '/') ) {
- expp->nd_left =
- MkNode(Cast, NULLNODE, expp->nd_left, &dot);
+ if (allowed & T_NUMERIC)
+ {
+ if ((tpl == int_type || tpl == long_type)
+ && (tpr == real_type || expp->nd_symb == '/'))
+ {
+ expp->nd_left = MkNode(Cast, NULLNODE, expp->nd_left, &dot);
expp->nd_left->nd_type = tpl = real_type;
}
- if( tpl == real_type &&
- (tpr == int_type || tpr == long_type)) {
- expp->nd_right =
- MkNode(Cast, NULLNODE, expp->nd_right, &dot);
+ if (tpl == real_type && (tpr == int_type || tpr == long_type))
+ {
+ expp->nd_right = MkNode(Cast, NULLNODE, expp->nd_right, &dot);
expp->nd_right->nd_type = tpr = real_type;
}
- if( tpl == int_type && tpr == long_type) {
- expp->nd_left =
- MkNode(IntCoerc, NULLNODE, expp->nd_left, &dot);
+ if (tpl == int_type && tpr == long_type)
+ {
+ expp->nd_left = MkNode(IntCoerc, NULLNODE, expp->nd_left, &dot);
expp->nd_left->nd_type = long_type;
}
- else if( tpl == long_type && tpr == int_type) {
- expp->nd_right =
- MkNode(IntCoerc, NULLNODE, expp->nd_right, &dot);
+ else if (tpl == long_type && tpr == int_type)
+ {
+ expp->nd_right = MkNode(IntCoerc, NULLNODE, expp->nd_right, &dot);
expp->nd_right->nd_type = long_type;
}
}
/* Operands must be compatible */
- if( !TstCompat(tpl, tpr) ) {
+ if (!TstCompat(tpl, tpr))
+ {
node_error(expp, "\"%s\": incompatible types",
- symbol2str(expp->nd_symb));
+ symbol2str(expp->nd_symb));
return 0;
}
- if( tpl->tp_fund & T_SET ) {
- if( tpl == emptyset_type )
+ if (tpl->tp_fund & T_SET)
+ {
+ if (tpl == emptyset_type)
left->nd_type = tpr;
- else if( tpr == emptyset_type )
+ else if (tpr == emptyset_type)
right->nd_type = tpl;
- if( expp->nd_type == emptyset_type )
+ if (expp->nd_type == emptyset_type)
expp->nd_type = tpr;
- if( left->nd_class == Set && right->nd_class == Set )
+ if (left->nd_class == Set && right->nd_class == Set)
cstset(expp);
}
- else if( tpl->tp_fund != T_REAL &&
- left->nd_class == Value && right->nd_class == Value )
- cstbin(expp);
+ else if (tpl->tp_fund != T_REAL && left->nd_class == Value
+ && right->nd_class == Value)
+ cstbin(expp);
return 1;
}
-STATIC int
-ChkElement(expp, tp, set, cnt)
- register struct node *expp;
- register struct type **tp;
- arith **set;
- unsigned *cnt;
+static int ChkElement(register struct node *expp, register struct type **tp,
+ arith **set, unsigned *cnt)
{
/* Check elements of a set. This routine may call itself
- recursively. Also try to compute the set!
- */
+ recursively. Also try to compute the set!
+ */
register struct node *left = expp->nd_left;
register struct node *right = expp->nd_right;
register int i;
extern char *Malloc();
- if( expp->nd_class == Link && expp->nd_symb == UPTO ) {
+ if (expp->nd_class == Link && expp->nd_symb == UPTO)
+ {
/* [ ... , expr1 .. expr2, ... ]
- First check expr1 and expr2, and try to compute them.
- */
- if( !ChkElement(left, tp, set, cnt) ||
- !ChkElement(right, tp, set, cnt) )
+ First check expr1 and expr2, and try to compute them.
+ */
+ if (!ChkElement(left, tp, set, cnt) || !ChkElement(right, tp, set, cnt))
return 0;
- if( left->nd_class == Value &&
- right->nd_class == Value && *set ) {
+ if (left->nd_class == Value && right->nd_class == Value && *set)
+ {
- if( left->nd_INT > right->nd_INT ) {
+ if (left->nd_INT > right->nd_INT)
+ {
/* Remove lower and upper bound of the range.
- */
+ */
*cnt -= 2;
- (*set)[left->nd_INT/wrd_bits] &=
- ~(1 << (left->nd_INT%wrd_bits));
- (*set)[right->nd_INT/wrd_bits] &=
- ~(1 << (right->nd_INT%wrd_bits));
+ (*set)[left->nd_INT / wrd_bits] &= ~(1
+ << (left->nd_INT % wrd_bits));
+ (*set)[right->nd_INT / wrd_bits] &= ~(1
+ << (right->nd_INT % wrd_bits));
}
else
/* We have a constant range. Put all elements
- in the set.
- */
- for( i = left->nd_INT + 1; i < right->nd_INT; i++ )
- (*set)[i/wrd_bits] |= ( 1 << (i%wrd_bits) );
+ in the set.
+ */
+ for (i = left->nd_INT + 1; i < right->nd_INT; i++)
+ (*set)[i / wrd_bits] |= (1 << (i % wrd_bits));
}
return 1;
}
/* Here, a single element is checked
- */
- if( !ChkExpression(expp) ) return 0;
+ */
+ if (!ChkExpression(expp)) return 0;
MarkUsed(expp);
- if( *tp == emptyset_type ) {
+ if (*tp == emptyset_type)
+ {
/* first element in set determines the type of the set */
unsigned size;
*set = (arith *) Malloc(size);
clear((char *) *set, size);
}
- else if( !TstCompat(ElementType(*tp), expp->nd_type) ) {
+ else if (!TstCompat(ElementType(*tp), expp->nd_type))
+ {
node_error(expp, "set element has incompatible type");
return 0;
}
- if( expp->nd_class == Value ) {
+ if (expp->nd_class == Value)
+ {
/* a constant element
- */
+ */
i = expp->nd_INT;
- if( expp->nd_type == int_type ) {
+ if (expp->nd_type == int_type)
+ {
/* Check only integer base-types because they are not
- equal to the integer host-type. The other base-types
- are equal to their host-types.
- */
+ equal to the integer host-type. The other base-types
+ are equal to their host-types.
+ */
- if( i < 0 || i > max_intset ) {
+ if (i < 0 || i > max_intset)
+ {
node_error(expp, "set element out of range");
return 0;
}
}
- if( *set ) (*set)[i/wrd_bits] |= ( 1 << (i%wrd_bits));
+ if (*set)
+ (*set)[i / wrd_bits] |= (1 << (i % wrd_bits));
(*cnt)++;
}
- else if( *set ) {
+ else if (*set)
+ {
free((char *) *set);
*set = (arith *) 0;
}
return 1;
}
-STATIC int
-ChkSet(expp)
- register struct node *expp;
+static int ChkSet(register struct node *expp)
{
/* Check the legality of a SET aggregate, and try to evaluate it
- compile time. Unfortunately this is all rather complicated.
- */
+ compile time. Unfortunately this is all rather complicated.
+ */
register struct node *nd = expp->nd_right;
arith *set = (arith *) 0;
unsigned cnt = 0;
expp->nd_type = emptyset_type;
/* Now check the elements given, and try to compute a constant set.
- First allocate room for the set, but only if it isn't empty.
- */
- if( !nd ) {
+ First allocate room for the set, but only if it isn't empty.
+ */
+ if (!nd)
+ {
/* The resulting set IS empty, so we just return
- */
+ */
expp->nd_class = Set;
expp->nd_set = (arith *) 0;
return 1;
}
/* Now check the elements, one by one
- */
- while( nd ) {
+ */
+ while (nd)
+ {
assert(nd->nd_class == Link && nd->nd_symb == ',');
- if( !ChkElement(nd->nd_left, &(expp->nd_type), &set, &cnt) )
+ if (!ChkElement(nd->nd_left, &(expp->nd_type), &set, &cnt))
return 0;
nd = nd->nd_right;
}
- if( set ) {
+ if (set)
+ {
/* Yes, it was a constant set, and we managed to compute it!
- Notice that at the moment there is no such thing as
- partial evaluation. Either we evaluate the set, or we
- don't (at all). Improvement not neccesary (???)
- ??? sets have a contant part and a variable part ???
- */
+ Notice that at the moment there is no such thing as
+ partial evaluation. Either we evaluate the set, or we
+ don't (at all). Improvement not neccesary (???)
+ ??? sets have a contant part and a variable part ???
+ */
expp->nd_class = Set;
- if( !cnt ) {
+ if (!cnt)
+ {
/* after all the work we've done, the set turned out
- out to be empty!
- */
+ out to be empty!
+ */
free((char *) set);
set = (arith *) 0;
}
return 1;
}
-char *
-ChkAllowedVar(nd, reading) /* reading indicates read or readln */
- register struct node *nd;
+char *ChkAllowedVar(register struct node *nd, int reading)
+/* reading indicates read or readln */
+
{
char *message = 0;
- switch( nd->nd_class ) {
+ switch (nd->nd_class)
+ {
case Def:
- if( nd->nd_def->df_flags & D_INLOOP ) {
+ if (nd->nd_def->df_flags & D_INLOOP)
+ {
message = "control variable";
break;
}
- if( nd->nd_def->df_kind != D_FIELD ) break;
+ if (nd->nd_def->df_kind != D_FIELD)
+ break;
/* FALL THROUGH */
case LinkDef:
assert(nd->nd_def->df_kind == D_FIELD);
- if( nd->nd_def->fld_flags & F_PACKED )
+ if (nd->nd_def->fld_flags & F_PACKED)
message = "field of packed record";
- else if( nd->nd_def->fld_flags & F_SELECTOR )
+ else if (nd->nd_def->fld_flags & F_SELECTOR)
message = "variant selector";
break;
case Arrsel:
- if( IsPacked(nd->nd_left->nd_type) )
- if( !reading ) message = "component of packed array";
+ if (IsPacked(nd->nd_left->nd_type))
+ if (!reading)
+ message = "component of packed array";
break;
case Arrow:
- if( nd->nd_right->nd_type->tp_fund == T_FILE )
+ if (nd->nd_right->nd_type->tp_fund == T_FILE)
message = "filebuffer variable";
break;
return message;
}
-int
-ChkVarPar(nd, name)
- register struct node *nd, *name;
+static int ChkVarPar(register struct node *nd, register struct node *name)
{
/* ISO 6.6.3.3 :
- An actual variable parameter shall not denote a field
- that is the selector of a variant-part or a component
- of a variable where that variable possesses a type
- that is designated packed.
- */
+ An actual variable parameter shall not denote a field
+ that is the selector of a variant-part or a component
+ of a variable where that variable possesses a type
+ that is designated packed.
+ */
static char err_mes[80];
char *message = (char *) 0;
- if( !ChkVariable(nd) ) return 0;
+ if (!ChkVariable(nd))
+ return 0;
message = ChkAllowedVar(nd, 0);
- if( message ) {
+ if (message)
+ {
sprint(err_mes, "%s can't be a variable parameter", message);
Xerror(name, err_mes);
return 0;
return 1;
}
-STATIC struct node *
-getarg(argp, bases, varaccess, name, paramtp)
- struct node **argp, *name;
- struct type *paramtp;
+static struct node *
+getarg(struct node **argp, int bases, int varaccess, struct node *name,
+ struct type *paramtp)
{
/* This routine is used to fetch the next argument from an
- argument list. The argument list is indicated by "argp".
- The parameter "bases" is a bitset indicating which types are
- allowed at this point, and "varaccess" is a flag indicating
- that the address from this argument is taken, so that it
- must be a varaccess and may not be a register variable.
- */
+ argument list. The argument list is indicated by "argp".
+ The parameter "bases" is a bitset indicating which types are
+ allowed at this point, and "varaccess" is a flag indicating
+ that the address from this argument is taken, so that it
+ must be a varaccess and may not be a register variable.
+ */
register struct node *arg = (*argp)->nd_right;
register struct node *left;
- if( !arg ) {
+ if (!arg)
+ {
Xerror(name, "too few arguments supplied");
return 0;
}
left = arg->nd_left;
*argp = arg;
- if( paramtp && paramtp->tp_fund & T_ROUTINE ) {
+ if (paramtp && paramtp->tp_fund & T_ROUTINE)
+ {
/* From the context it appears that the occurrence of the
- procedure/function-identifier is not a call.
- */
- if( left->nd_class != NameOrCall ) {
+ procedure/function-identifier is not a call.
+ */
+ if (left->nd_class != NameOrCall)
+ {
Xerror(name, "illegal proc/func parameter");
return 0;
}
- else if( ChkLinkOrName(left->nd_left) ) {
+ else if (ChkLinkOrName(left->nd_left))
+ {
left->nd_type = left->nd_left->nd_type;
MarkUsed(left->nd_left);
}
- else return 0;
+ else
+ return 0;
}
- else if( varaccess ) {
- if( !ChkVarPar(left, name) ) {
- MarkUsed(left);
- return 0;
- }
+ else if (varaccess)
+ {
+ if (!ChkVarPar(left, name))
+ {
+ MarkUsed(left);
+ return 0;
+ }
}
- else if( !ChkExpression(left) ) {
+ else if (!ChkExpression(left))
+ {
MarkUsed(left);
return 0;
}
MarkUsed(left);
- if( !varaccess && bases == T_INTEGER &&
- BaseType(left->nd_type)->tp_fund == T_LONG) {
+ if (!varaccess && bases == T_INTEGER
+ && BaseType(left->nd_type)->tp_fund == T_LONG)
+ {
arg->nd_left = MkNode(IntReduc, NULLNODE, left, &dot);
arg->nd_left->nd_type = int_type;
left = arg->nd_left;
}
- if( bases && !(BaseType(left->nd_type)->tp_fund & bases) ) {
+ if (bases && !(BaseType(left->nd_type)->tp_fund & bases))
+ {
Xerror(name, "unexpected parameter type");
return 0;
}
return left;
}
-STATIC int
-ChkProcCall(expp)
- struct node *expp;
+static int ChkProcCall(struct node *expp)
{
/* Check a procedure call
- */
+ */
register struct node *left;
struct node *name;
register struct paramlist *param;
name = left = expp->nd_left;
- if( left->nd_type == error_type ) {
+ if (left->nd_type == error_type)
+ {
/* Just check parameters as if they were value parameters
- */
+ */
expp->nd_type = error_type;
- while( expp->nd_right )
- (void) getarg(&expp, 0, 0, name, NULLTYPE);
+ while (expp->nd_right)
+ (void) getarg(&expp, 0, 0, name, NULLTYPE );
return 0;
}
expp->nd_type = ResultType(left->nd_type);
/* Check parameter list
- */
- for( param = ParamList(left->nd_type); param; param = param->next ) {
- if( !(left = getarg(&expp, 0, (int) IsVarParam(param), name,
- TypeOfParam(param))) )
+ */
+ for (param = ParamList(left->nd_type) ; param; param = param->next)
+ {
+ if (!(left = getarg(&expp, 0, (int) IsVarParam(param), name,
+ TypeOfParam(param))))
return 0;
cnt++;
new_par_section = lasttp != TypeOfParam(param);
- if( !TstParCompat(TypeOfParam(param), left->nd_type,
- (int) IsVarParam(param), left, new_par_section) ) {
- sprint(ebuf, "type incompatibility in parameter %d",
- cnt);
+ if (!TstParCompat(TypeOfParam(param), left->nd_type,
+ (int) IsVarParam(param), left, new_par_section))
+ {
+ sprint(ebuf, "type incompatibility in parameter %d", cnt);
Xerror(name, ebuf);
retval = 0;
}
/* Convert between integers and longs.
*/
- if( !IsVarParam(param) && options['d'] ) {
- if( left->nd_type->tp_fund == T_INTEGER &&
- TypeOfParam(param)->tp_fund == T_LONG) {
- expp->nd_left =
- MkNode(IntCoerc, NULLNODE, left, &dot);
+ if (!IsVarParam(param) && options['d'])
+ {
+ if (left->nd_type->tp_fund == T_INTEGER
+ && TypeOfParam(param)->tp_fund == T_LONG)
+ {
+ expp->nd_left = MkNode(IntCoerc, NULLNODE, left, &dot);
expp->nd_left->nd_type = long_type;
left = expp->nd_left;
}
- else if( left->nd_type->tp_fund == T_LONG &&
- TypeOfParam(param)->tp_fund == T_INTEGER) {
- expp->nd_left =
- MkNode(IntReduc, NULLNODE, left, &dot);
+ else if (left->nd_type->tp_fund == T_LONG
+ && TypeOfParam(param)->tp_fund == T_INTEGER)
+ {
+ expp->nd_left = MkNode(IntReduc, NULLNODE, left, &dot);
expp->nd_left->nd_type = int_type;
left = expp->nd_left;
}
}
- if( left->nd_type == emptyset_type )
+ if (left->nd_type == emptyset_type)
/* type of emptyset determined by the context */
left->nd_type = TypeOfParam(param);
lasttp = TypeOfParam(param);
}
- if( expp->nd_right ) {
+ if (expp->nd_right)
+ {
Xerror(name, "too many arguments supplied");
- while( expp->nd_right )
- (void) getarg(&expp, 0, 0, name, NULLTYPE);
+ while (expp->nd_right)
+ (void) getarg(&expp, 0, 0, name, NULLTYPE );
return 0;
}
return retval;
}
-STATIC int ChkStandard();
-
-int
-ChkCall(expp)
- register struct node *expp;
+int ChkCall(register struct node *expp)
{
/* Check something that looks like a procedure or function call.
- Of course this does not have to be a call at all,
- it may also be a standard procedure call.
- */
+ Of course this does not have to be a call at all,
+ it may also be a standard procedure call.
+ */
/* First, get the name of the function or procedure
- */
+ */
register struct node *left = expp->nd_left;
expp->nd_type = error_type;
- if( ChkLinkOrName(left) ) {
+ if (ChkLinkOrName(left))
+ {
MarkUsed(left);
- if( IsProcCall(left) || left->nd_type == error_type ) {
+ if (IsProcCall(left) || left->nd_type == error_type)
+ {
/* A call.
- It may also be a call to a standard procedure
- */
+ It may also be a call to a standard procedure
+ */
- if( left->nd_type == std_type )
+ if (left->nd_type == std_type)
/* A standard procedure
- */
+ */
return ChkStandard(expp, left);
/* Here, we have found a real procedure call.
- */
+ */
}
- else {
+ else
+ {
node_error(left, "procedure or function expected");
return 0;
}
return ChkProcCall(expp);
}
-STATIC int
-ChkExCall(expp)
- register struct node *expp;
+static int ChkExCall(register struct node *expp)
{
- if( !ChkCall(expp) ) return 0;
+ if (!ChkCall(expp))
+ return 0;
- if( !expp->nd_type ) {
+ if (!expp->nd_type)
+ {
node_error(expp, "function call expected");
return 0;
}
return 1;
}
-STATIC int
-ChkNameOrCall(expp)
- register struct node *expp;
+static int ChkNameOrCall(register struct node *expp)
{
/* From the context it appears that the occurrence of the function-
- identifier is a call to that function
- */
+ identifier is a call to that function
+ */
assert(expp->nd_class == NameOrCall);
expp->nd_class = Call;
return ChkExCall(expp);
}
-STATIC int
-ChkStandard(expp,left)
- register struct node *expp, *left;
+static int ChkStandard(register struct node *expp, register struct node *left)
{
/* Check a call of a standard procedure or function
- */
+ */
struct node *arg = expp;
struct node *name = left;
req = left->nd_def->df_value.df_reqname;
- switch( req ) {
- case R_ABS:
- case R_SQR:
- if( !(left = getarg(&arg, T_NUMERIC, 0, name, NULLTYPE)) )
+ switch (req)
+ {
+ case R_ABS:
+ case R_SQR:
+ if (!(left = getarg(&arg, T_NUMERIC, 0, name, NULLTYPE )))
return 0;
expp->nd_type = left->nd_type;
- if( left->nd_class == Value &&
- expp->nd_type->tp_fund != T_REAL )
+ if (left->nd_class == Value && expp->nd_type->tp_fund != T_REAL)
cstcall(expp, req);
break;
- case R_SIN:
- case R_COS:
- case R_EXP:
- case R_LN:
- case R_SQRT:
- case R_ARCTAN:
- if( !(left = getarg(&arg, T_NUMERIC, 0, name, NULLTYPE)) )
+ case R_SIN:
+ case R_COS:
+ case R_EXP:
+ case R_LN:
+ case R_SQRT:
+ case R_ARCTAN:
+ if (!(left = getarg(&arg, T_NUMERIC, 0, name, NULLTYPE )))
return 0;
expp->nd_type = real_type;
- if( BaseType(left->nd_type)->tp_fund == T_INTEGER ||
- BaseType(left->nd_type)->tp_fund == T_LONG) {
- arg->nd_left = MkNode(Cast,NULLNODE, arg->nd_left,&dot);
+ if (BaseType(left->nd_type)->tp_fund == T_INTEGER
+ || BaseType(left->nd_type)->tp_fund == T_LONG)
+ {
+ arg->nd_left = MkNode(Cast, NULLNODE, arg->nd_left, &dot);
arg->nd_left->nd_type = real_type;
}
break;
- case R_TRUNC:
- case R_ROUND:
- if( !(left = getarg(&arg, T_REAL, 0, name, NULLTYPE)) )
+ case R_TRUNC:
+ case R_ROUND:
+ if (!(left = getarg(&arg, T_REAL, 0, name, NULLTYPE )))
return 0;
expp->nd_type = int_type;
break;
- case R_ORD:
- if( !(left = getarg(&arg, T_ORDINAL, 0, name, NULLTYPE)) )
+ case R_ORD:
+ if (!(left = getarg(&arg, T_ORDINAL, 0, name, NULLTYPE )))
return 0;
- if( BaseType(left->nd_type)->tp_fund == T_LONG ) {
+ if (BaseType(left->nd_type)->tp_fund == T_LONG)
+ {
arg->nd_left = MkNode(IntReduc, NULLNODE, arg->nd_left, &dot);
arg->nd_left->nd_type = int_type;
}
expp->nd_type = int_type;
- if( left->nd_class == Value )
+ if (left->nd_class == Value)
cstcall(expp, R_ORD);
break;
- case R_CHR:
- if( !(left = getarg(&arg, T_INTEGER, 0, name, NULLTYPE)) )
+ case R_CHR:
+ if (!(left = getarg(&arg, T_INTEGER, 0, name, NULLTYPE )))
return 0;
expp->nd_type = char_type;
- if( left->nd_class == Value )
+ if (left->nd_class == Value)
cstcall(expp, R_CHR);
break;
- case R_SUCC:
- case R_PRED:
- if( !(left = getarg(&arg, T_ORDINAL, 0, name, NULLTYPE)) )
+ case R_SUCC:
+ case R_PRED:
+ if (!(left = getarg(&arg, T_ORDINAL, 0, name, NULLTYPE )))
return 0;
expp->nd_type = left->nd_type;
- if( left->nd_class == Value && options['R'] )
+ if (left->nd_class == Value && options['R'])
cstcall(expp, req);
break;
- case R_ODD:
- if( !(left = getarg(&arg, T_INTEGER | T_LONG , 0, name, NULLTYPE)) )
+ case R_ODD:
+ if (!(left = getarg(&arg, T_INTEGER | T_LONG, 0, name, NULLTYPE )))
return 0;
expp->nd_type = bool_type;
- if( left->nd_class == Value )
+ if (left->nd_class == Value)
cstcall(expp, R_ODD);
break;
- case R_EOF:
- case R_EOLN:
- case R_GET:
- case R_PAGE: {
+ case R_EOF:
+ case R_EOLN:
+ case R_GET:
+ case R_PAGE:
+ {
int st_out;
- if( req == R_PAGE ) {
+ if (req == R_PAGE)
+ {
expp->nd_type = NULLTYPE;
st_out = 1;
}
- else {
+ else
+ {
st_out = 0;
- if (req == R_GET) {
+ if (req == R_GET)
+ {
expp->nd_type = NULLTYPE;
}
- else expp->nd_type = bool_type;
+ else
+ expp->nd_type = bool_type;
}
- if( !arg->nd_right ) {
+ if (!arg->nd_right)
+ {
struct node *nd;
- if( !(nd = ChkStdInOut(name->nd_IDF->id_text, st_out)) )
+ if (!(nd = ChkStdInOut(name->nd_IDF->id_text, st_out)))
return 0;
expp->nd_right = MkNode(Link, nd, NULLNODE, &dot);
expp->nd_right->nd_symb = ',';
arg = arg->nd_right;
}
- else {
- if( !(left = getarg(&arg, T_FILE, 1, name, NULLTYPE)) )
+ else
+ {
+ if (!(left = getarg(&arg, T_FILE, 1, name, NULLTYPE )))
return 0;
- if( (req == R_PAGE || req == R_EOLN)
- && left->nd_type != text_type ) {
+ if ((req == R_PAGE || req == R_EOLN) && left->nd_type != text_type)
+ {
Xerror(name, "textfile expected");
return 0;
}
}
break;
- }
- case R_REWRITE:
- case R_PUT:
- case R_RESET:
- if( !(left = getarg(&arg, T_FILE, 1, name, NULLTYPE)) )
+ }
+ case R_REWRITE:
+ case R_PUT:
+ case R_RESET:
+ if (!(left = getarg(&arg, T_FILE, 1, name, NULLTYPE )))
return 0;
expp->nd_type = NULLTYPE;
break;
- case R_PACK:
- case R_UNPACK: {
+ case R_PACK:
+ case R_UNPACK:
+ {
struct type *tp1, *tp2, *tp3;
- if( req == R_PACK ) {
+ if (req == R_PACK)
+ {
/* pack(a, i, z) */
- if( !(left = getarg(&arg, T_ARRAY, 1, name, NULLTYPE)) )
+ if (!(left = getarg(&arg, T_ARRAY, 1, name, NULLTYPE )))
return 0;
- tp1 = left->nd_type; /* (a) */
- if( !(left = getarg(&arg, 0, 0, name, NULLTYPE)) )
+ tp1 = left->nd_type; /* (a) */
+ if (!(left = getarg(&arg, 0, 0, name, NULLTYPE )))
return 0;
- tp2 = left->nd_type; /* (i) */
- if( !(left = getarg(&arg, T_ARRAY, 1, name, NULLTYPE)) )
+ tp2 = left->nd_type; /* (i) */
+ if (!(left = getarg(&arg, T_ARRAY, 1, name, NULLTYPE )))
return 0;
- tp3 = left->nd_type; /* (z) */
+ tp3 = left->nd_type; /* (z) */
}
- else {
+ else
+ {
/* unpack(z, a, i) */
- if( !(left = getarg(&arg, T_ARRAY, 1, name, NULLTYPE)) )
+ if (!(left = getarg(&arg, T_ARRAY, 1, name, NULLTYPE )))
return 0;
- tp3 = left->nd_type; /* (z) */
- if( !(left = getarg(&arg, T_ARRAY, 1, name, NULLTYPE)) )
+ tp3 = left->nd_type; /* (z) */
+ if (!(left = getarg(&arg, T_ARRAY, 1, name, NULLTYPE )))
return 0;
- tp1 = left->nd_type; /* (a) */
- if( !(left = getarg(&arg, 0, 0, name, NULLTYPE)) )
+ tp1 = left->nd_type; /* (a) */
+ if (!(left = getarg(&arg, 0, 0, name, NULLTYPE )))
return 0;
- tp2 = left->nd_type; /* (i) */
+ tp2 = left->nd_type; /* (i) */
}
- if( IsConformantArray(tp1) || IsPacked(tp1) ) {
+ if (IsConformantArray(tp1) || IsPacked(tp1))
+ {
Xerror(name, "unpacked array expected");
return 0;
}
- if( !TstAssCompat(IndexType(tp1), tp2) ) {
+ if (!TstAssCompat(IndexType(tp1), tp2))
+ {
Xerror(name, "ordinal constant expected");
return 0;
}
- if( IsConformantArray(tp3) || !IsPacked(tp3) ) {
+ if (IsConformantArray(tp3) || !IsPacked(tp3))
+ {
Xerror(name, "packed array expected");
return 0;
}
- if( !TstTypeEquiv(tp1->arr_elem, tp3->arr_elem) ) {
+ if (!TstTypeEquiv(tp1->arr_elem, tp3->arr_elem))
+ {
Xerror(name, "component types of arrays not equal");
return 0;
}
expp->nd_type = NULLTYPE;
break;
- }
+ }
- case R_NEW:
- case R_DISPOSE:
- if( !(left = getarg(&arg, T_POINTER, 1, name, NULLTYPE)) )
+ case R_NEW:
+ case R_DISPOSE:
+ if (!(left = getarg(&arg, T_POINTER, 1, name, NULLTYPE )))
return 0;
- if( arg->nd_right ) {
+ if (arg->nd_right)
+ {
/* varargs new/dispose(p,c1,.....) */
register struct selector *sel;
register arith i;
- if( PointedtoType(left->nd_type)->tp_fund != T_RECORD )
+ if (PointedtoType(left->nd_type) ->tp_fund != T_RECORD)
break;
- sel = PointedtoType(left->nd_type)->rec_sel;
- do {
- if( !sel ) break;
+ sel = PointedtoType(left->nd_type) ->rec_sel;
+ do
+ {
+ if (!sel)
+ break;
arg = arg->nd_right;
left = arg->nd_left;
/* ISO : COMPILETIME CONSTANTS NOT PERMITTED */
- if( !ChkConstant(left) ) return 0;
+ if (!ChkConstant(left))
+ return 0;
- if( !TstCompat(left->nd_type, sel->sel_type) ) {
- node_error(left,
- "type incompatibility in caselabel");
+ if (!TstCompat(left->nd_type, sel->sel_type))
+ {
+ node_error(left, "type incompatibility in caselabel");
return 0;
}
i = left->nd_INT - sel->sel_lb;
- if( i < 0 || i >= sel->sel_ncst ) {
- node_error(left,
- "case constant: out of bounds");
+ if (i < 0 || i >= sel->sel_ncst)
+ {
+ node_error(left, "case constant: out of bounds");
return 0;
}
sel = sel->sel_ptrs[i];
- } while( arg->nd_right );
+ } while (arg->nd_right);
FreeNode(expp->nd_right->nd_right);
expp->nd_right->nd_right = NULLNODE;
expp->nd_type = NULLTYPE;
break;
- case R_HALT:
- if( !arg->nd_right ) /* insert 0 parameter */
+ case R_HALT:
+ if (!arg->nd_right) /* insert 0 parameter */
arg->nd_right = ZeroParam();
- if( !(left = getarg(&arg, T_INTEGER, 0, name, NULLTYPE)) )
+ if (!(left = getarg(&arg, T_INTEGER, 0, name, NULLTYPE )))
return 0;
expp->nd_type = NULLTYPE;
break;
- default:
+ default:
crash("(ChkStandard)");
}
-
- if( arg->nd_right ) {
+
+ if (arg->nd_right)
+ {
Xerror(name, "too many arguments supplied");
return 0;
}
return 1;
}
-STATIC int
-ChkArrow(expp)
- register struct node *expp;
+static int ChkArrow(register struct node *expp)
{
/* Check an application of the '^' operator.
- The operand must be a variable of a pointer-type or a
- variable of a file-type.
- */
+ The operand must be a variable of a pointer-type or a
+ variable of a file-type.
+ */
register struct type *tp;
expp->nd_type = error_type;
- if( !ChkVariable(expp->nd_right) ) return 0;
+ if (!ChkVariable(expp->nd_right))
+ return 0;
MarkUsed(expp->nd_right);
tp = expp->nd_right->nd_type;
- if( !(tp->tp_fund & (T_POINTER | T_FILE)) ) {
+ if (!(tp->tp_fund & (T_POINTER | T_FILE)))
+ {
node_error(expp, "\"^\": illegal operand");
return 0;
}
return 1;
}
-STATIC int
-ChkArr(expp)
- register struct node *expp;
+static int ChkArr(register struct node *expp)
{
/* Check an array selection.
- The left hand side must be a variable of an array type,
- and the right hand side must be an expression that is
- assignment compatible with the array-index.
- */
+ The left hand side must be a variable of an array type,
+ and the right hand side must be an expression that is
+ assignment compatible with the array-index.
+ */
register struct type *tpl, *tpr;
int retval;
tpl = expp->nd_left->nd_type;
tpr = expp->nd_right->nd_type;
- if( tpl == error_type || tpr == error_type ) return 0;
+ if (tpl == error_type || tpr == error_type)
+ return 0;
- if( tpl->tp_fund != T_ARRAY ) {
+ if (tpl->tp_fund != T_ARRAY)
+ {
node_error(expp, "not indexing an ARRAY type");
return 0;
}
/* Type of the index must be assignment compatible with
- the index type of the array.
- */
- if( !TstCompat(IndexType(tpl), tpr) ) {
+ the index type of the array.
+ */
+ if (!TstCompat(IndexType(tpl), tpr))
+ {
node_error(expp, "incompatible index type");
return 0;
}
- if( tpr == long_type ) {
+ if (tpr == long_type)
+ {
expp->nd_right = MkNode(IntReduc, NULLNODE, expp->nd_right, &dot);
expp->nd_right->nd_type = int_type;
}
return retval;
}
-STATIC int
-done_before()
+static int done_before(struct node *expp)
{
return 1;
}
-STATIC int
-no_var_access(expp)
- struct node *expp;
+static int no_var_access(struct node *expp)
{
node_error(expp, "variable-access expected");
return 0;
}
-extern int NodeCrash();
-
-int (*ExprChkTable[])() = {
+int (*ExprChkTable[])(struct node*) =
+{
#ifdef DEBUG
ChkValue,
#else
NodeCrash,
NodeCrash,
NodeCrash
-};
-
-int (*VarAccChkTable[])() = {
- no_var_access,
- ChkLinkOrName,
- no_var_access,
- no_var_access,
- no_var_access,
- NodeCrash,
- no_var_access,
- no_var_access,
- ChkArrow,
- ChkArr,
- done_before,
- ChkLinkOrName,
- done_before,
- no_var_access,
- no_var_access,
- no_var_access
-};
+ };
+
+ int (*VarAccChkTable[])() =
+ {
+ no_var_access,
+ ChkLinkOrName,
+ no_var_access,
+ no_var_access,
+ no_var_access,
+ NodeCrash,
+ no_var_access,
+ no_var_access,
+ ChkArrow,
+ ChkArr,
+ done_before,
+ ChkLinkOrName,
+ done_before,
+ no_var_access,
+ no_var_access,
+ no_var_access
+ };
/* E X P R E S S I O N C H E C K I N G */
+struct node;
+
extern int (*ExprChkTable[])(); /* table of expression checking
functions, indexed by node class
*/
#define ChkExpression(expp) ((*ExprChkTable[(expp)->nd_class])(expp))
#define ChkVarAccess(expp) ((*VarAccChkTable[(expp)->nd_class])(expp))
+
+int ChkConstant(register struct node *expp);
+int ChkVariable(register struct node *expp);
+/* Check that "expp" indicates an item that can be the lhs
+ of an assignment, return 1 if possible, on return 0.
+ */
+int ChkLhs(register struct node *expp);
+int ChkLinkOrName(register struct node *expp);
+char *ChkAllowedVar(register struct node *nd, int reading);
+int ChkCall(register struct node *expp);
+void MarkUsed(register struct node *nd);
#include "required.h"
#include "scope.h"
#include "type.h"
+#include "code.h"
+#include "tmpvar.h"
+#include "typequiv.h"
+#include "error.h"
-int fp_used;
+int fp_used;
-void Long2Int();
-void Int2Long();
-void genrck();
-void CodeCall();
+static void CodeUoper(register struct node *);
+static void CodeBoper(register struct node *, /* the expression tree itself */
+label);
+static void CodeSet(register struct node *);
+static void CodeEl(register struct node *, register struct type *);
+static void CodePString(struct node *, struct type *);
+/* General internal system API calls */
+static void CodeStd(struct node *);
-CodeFil()
+static void genrck(register struct type *);
+static void RegisterMessages(register struct def *);
+static void CodeConfDescr(register struct type *, register struct type *);
+
+extern void call_ini(void);
+
+
+
+static void CodeFil(void)
{
- if ( !options['L'] )
- C_fil_dlb((label) 1, (arith) 0);
+ if (!options['L'])
+ C_fil_dlb((label ) 1, (arith) 0);
}
-routine_label(df)
- register struct def * df;
+void routine_label(register struct def * df)
{
df->prc_label = ++data_label;
C_df_dlb(df->prc_label);
C_rom_scon(df->df_idf->id_text, (arith)(strlen(df->df_idf->id_text) + 1));
}
-RomString(nd)
- register struct node *nd;
+void RomString(register struct node *nd)
{
C_df_dlb(++data_label);
/* A string of the string_type is null-terminated. */
- if( nd->nd_type == string_type )
- C_rom_scon(nd->nd_STR, nd->nd_SLE + 1); /* with trailing '\0' */
+ if (nd->nd_type == string_type)
+ C_rom_scon(nd->nd_STR, nd->nd_SLE + 1); /* with trailing '\0' */
else
- C_rom_scon(nd->nd_STR, nd->nd_SLE); /* no trailing '\0' */
+ C_rom_scon(nd->nd_STR, nd->nd_SLE); /* no trailing '\0' */
nd->nd_SLA = data_label;
}
-RomReal(nd)
- register struct node *nd;
+void RomReal(register struct node *nd)
{
- if (! nd->nd_RLA) {
+ if (!nd->nd_RLA)
+ {
C_df_dlb(++data_label);
nd->nd_RLA = data_label;
C_rom_fcon(nd->nd_REL, nd->nd_type->tp_size);
}
}
-BssVar()
+void BssVar(void)
{
/* generate bss segments for global variables */
register struct def *df = GlobalScope->sc_def;
- while( df ) {
- if( df->df_kind == D_VARIABLE ) {
+ while (df)
+ {
+ if (df->df_kind == D_VARIABLE)
+ {
C_df_dnam(df->var_name);
/* ??? undefined value ??? */
}
}
-arith
-CodeGtoDescr(sc)
- register struct scope *sc;
+static arith CodeGtoDescr(register struct scope *sc)
{
/* Create code for goto descriptors
- */
+ */
register struct node *lb = sc->sc_lablist;
int first = 1;
- while( lb ) {
- if( lb->nd_def->lab_descr ) {
- if( first ) {
+ while (lb)
+ {
+ if (lb->nd_def->lab_descr)
+ {
+ if (first)
+ {
/* create local for target SP */
sc->sc_off = -WA(pointer_size - sc->sc_off);
C_ms_gto();
}
lb = lb->nd_next;
}
- if( !first )
+ if (!first)
return sc->sc_off;
else
return (arith) 0;
}
-arith
-CodeBeginBlock(df)
- register struct def *df;
+arith CodeBeginBlock(register struct def *df)
{
/* Generate code at the beginning of the main program,
- procedure or function.
- */
+ procedure or function.
+ */
arith StackAdjustment = 0;
- arith offset = 0; /* offset to save StackPointer */
+ arith offset = 0; /* offset to save StackPointer */
TmpOpen(df->prc_vis->sc_scope);
- if ( df->df_kind == D_MODULE) /* nothing */ ;
- else if (df->df_kind == D_PROGRAM ) {
+ if (df->df_kind == D_MODULE) /* nothing */
+ ;
+ else if (df->df_kind == D_PROGRAM)
+ {
C_exp("_m_a_i_n");
C_pro_narg("_m_a_i_n");
C_ms_par((arith) 0);
/* initialize external files */
call_ini();
- /* ignore floating point underflow */
- C_lim();
- C_loc((arith) (1 << EFUNFL));
+ /* ignore floating point underflow */C_lim();
+ C_loc((arith)(1 << EFUNFL));
C_ior(int_size);
C_sim();
}
- else if (df->df_kind & (D_PROCEDURE | D_FUNCTION)) {
+ else if (df->df_kind & (D_PROCEDURE | D_FUNCTION))
+ {
struct type *tp;
register struct paramlist *param;
offset = CodeGtoDescr(df->prc_vis->sc_scope);
CodeFil();
- if( options['t'] ) {
- C_lae_dlb(df->prc_label,(arith)0);
+ if (options['t'])
+ {
+ C_lae_dlb(df->prc_label, (arith) 0);
C_cal("procentry");
C_asp(pointer_size);
}
* with the -R option. The variable, however, is always
* allocated and initialized.
*/
- if( df->prc_res ) {
+ if (df->prc_res)
+ {
C_zer((arith) int_size);
C_stl(df->prc_bool);
}
- for( param = ParamList(df->df_type); param; param = param->next) {
- if( !IsVarParam(param) ) {
+ for (param = ParamList(df->df_type) ; param; param = param->next)
+ {
+ if (!IsVarParam(param))
+ {
tp = TypeOfParam(param);
- if( IsConformantArray(tp) ) {
+ if (IsConformantArray(tp))
+ {
/* Here, we have to make a copy of the
- array. We must also remember how much
- room is reserved for copies, because
- we have to adjust the stack pointer
- before we return.
- */
-
- if( !StackAdjustment ) {
+ array. We must also remember how much
+ room is reserved for copies, because
+ we have to adjust the stack pointer
+ before we return.
+ */
+
+ if (!StackAdjustment)
+ {
/* First time we get here
- */
+ */
StackAdjustment = NewInt(0);
C_loc((arith) 0);
C_stl(StackAdjustment);
/* First compute size of the array */
C_lol(tp->arr_cfdescr + word_size);
C_inc();
- /* gives number of elements */
+ /* gives number of elements */
C_lol(tp->arr_cfdescr + 2 * word_size);
- /* size of elements */
+ /* size of elements */
C_mli(word_size);
C_loc(word_size - 1);
C_adi(word_size);
C_lol(StackAdjustment);
C_adi(word_size);
C_stl(StackAdjustment);
- /* remember stack adjustments */
+ /* remember stack adjustments */
- C_los(word_size); /* copy */
- C_lor((arith) 1);
- /* push new address of array
- ... downwards ... ???
- */
+ C_los(word_size); /* copy */
+ C_lor((arith) 1);
+ /* push new address of array
+ ... downwards ... ???
+ */
C_stl(param->par_def->var_off);
}
}
}
}
- else {
+ else
+ {
crash("(CodeBeginBlock)");
/*NOTREACHED*/
}
- if( offset ) {
+ if (offset)
+ {
/* save SP for non-local jump */
C_lor((arith) 1);
C_stl(offset);
return StackAdjustment;
}
-CodeEndBlock(df, StackAdjustment)
- register struct def *df;
- arith StackAdjustment;
+void CodeEndBlock(register struct def *df, arith StackAdjustment)
{
- if( df->df_kind == D_PROGRAM) {
+ if (df->df_kind == D_PROGRAM)
+ {
C_loc((arith) 0);
C_cal("_hlt");
}
- else if (df->df_kind & (D_PROCEDURE | D_FUNCTION)) {
+ else if (df->df_kind & (D_PROCEDURE | D_FUNCTION))
+ {
struct type *tp;
- if( StackAdjustment ) {
+ if (StackAdjustment)
+ {
/* remove copies of conformant arrays */
C_lol(StackAdjustment);
C_ass(word_size);
FreeInt(StackAdjustment);
}
- if( !options['n'] )
+ if (!options['n'])
RegisterMessages(df->prc_vis->sc_scope->sc_def);
- if( options['t'] ) {
- C_lae_dlb(df->prc_label,(arith)0);
+ if (options['t'])
+ {
+ C_lae_dlb(df->prc_label, (arith) 0);
C_cal("procexit");
C_asp(pointer_size);
}
- if( tp = ResultType(df->df_type) ) {
- if( !options['R'] ) {
- C_lin((arith)LineNumber);
+ if ( (tp = ResultType(df->df_type)) )
+ {
+ if (!options['R'])
+ {
+ C_lin((arith) LineNumber);
C_lol(df->prc_bool);
C_cal("_nfa");
C_asp(word_size);
}
- if( tp->tp_size == word_size )
+ if (tp->tp_size == word_size)
C_lol(-tp->tp_size);
- else if( tp->tp_size == 2 * word_size )
+ else if (tp->tp_size == 2 * word_size)
C_ldl(-tp->tp_size);
- else {
+ else
+ {
C_lal(-tp->tp_size);
C_loi(tp->tp_size);
}
else
C_ret((arith) 0);
}
- else {
+ else
+ {
crash("(CodeEndBlock)");
/*NOTREACHED*/
}
- C_end(- df->prc_vis->sc_scope->sc_off);
+ C_end(-df->prc_vis->sc_scope->sc_off);
TmpClose();
}
-CodeExpr(nd, ds, true_label)
- register struct node *nd;
- register struct desig *ds;
- label true_label;
+void CodeExpr(register struct node *nd, register struct desig *ds,
+ label true_label)
{
register struct type *tp = nd->nd_type;
- if( tp->tp_fund == T_REAL ) fp_used = 1;
+ if (tp->tp_fund == T_REAL)
+ fp_used = 1;
- switch( nd->nd_class ) {
+ switch (nd->nd_class)
+ {
case Value:
- switch( nd->nd_symb ) {
+ switch (nd->nd_symb)
+ {
case INTEGER:
C_loc(nd->nd_INT);
break;
C_loi(tp->tp_size);
break;
case STRING:
- if( tp->tp_fund == T_CHAR )
+ if (tp->tp_fund == T_CHAR)
C_loc(nd->nd_INT);
else
C_lae_dlb(nd->nd_SLA, (arith) 0);
true_label = NO_LABEL;
break;
- case Set: {
+ case Set:
+ {
register arith *st = nd->nd_set;
register int i;
ds->dsg_kind = DSG_LOADED;
- if( !st ) {
+ if (!st)
+ {
C_zer(tp->tp_size);
break;
}
- for( i = tp->tp_size / word_size, st += i; i > 0; i--)
+ for (i = tp->tp_size / word_size, st += i; i > 0; i--)
C_loc(*--st);
- }
+ }
break;
case Xset:
ds->dsg_kind = DSG_LOADED;
break;
- case NameOrCall: {
+ case NameOrCall:
+ {
/* actual procedure/function parameter */
struct node *left = nd->nd_left;
struct def *df = left->nd_def;
- if( df->df_kind & D_ROUTINE ) {
+ if (df->df_kind & D_ROUTINE)
+ {
int level = df->df_scope->sc_level;
- if( level <= 0 || (df->df_flags & D_EXTERNAL) )
+ if (level <= 0 || (df->df_flags & D_EXTERNAL))
C_zer(pointer_size);
else
- C_lxl((arith) (proclevel - level));
+ C_lxl((arith)(proclevel - level));
C_lpi(df->prc_name);
ds->dsg_kind = DSG_LOADED;
CodeDesig(nd, ds);
break;
- case Cast: {
+ case Cast:
+ {
/* convert integer to real */
struct node *right = nd->nd_right;
ds->dsg_kind = DSG_LOADED;
break;
}
- case IntCoerc: {
+ case IntCoerc:
+ {
/* convert integer to long integer */
struct node *right = nd->nd_right;
ds->dsg_kind = DSG_LOADED;
break;
}
- case IntReduc: {
+ case IntReduc:
+ {
/* convert a long to an integer */
struct node *right = nd->nd_right;
/*NOTREACHED*/
} /* switch class */
- if( true_label ) {
+ if (true_label)
+ {
/* Only for boolean expressions
- */
+ */
CodeValue(ds, tp);
C_zeq(true_label);
}
}
-CodeUoper(nd)
- register struct node *nd;
+static void CodeUoper(register struct node *nd)
{
register struct type *tp = nd->nd_type;
CodePExpr(nd->nd_right);
- switch( nd->nd_symb ) {
- case '-':
- assert(tp->tp_fund & T_NUMERIC);
- if( tp->tp_fund == T_INTEGER || tp->tp_fund == T_LONG )
- C_ngi(tp->tp_size);
- else
- C_ngf(tp->tp_size);
- break;
+ switch (nd->nd_symb)
+ {
+ case '-':
+ assert(tp->tp_fund & T_NUMERIC);
+ if (tp->tp_fund == T_INTEGER || tp->tp_fund == T_LONG)
+ C_ngi(tp->tp_size);
+ else
+ C_ngf(tp->tp_size);
+ break;
- case NOT:
- C_teq();
- break;
+ case NOT:
+ C_teq();
+ break;
- case '(':
- break;
+ case '(':
+ break;
- default:
- crash("(CodeUoper)");
- /*NOTREACHED*/
+ default:
+ crash("(CodeUoper)");
+ /*NOTREACHED*/
+ }
+}
+
+/* truthvalue() serves as an auxiliary function of CodeBoper */
+static void truthvalue(int relop)
+{
+ switch (relop)
+ {
+ case '<':
+ C_tlt();
+ break;
+ case LESSEQUAL:
+ C_tle();
+ break;
+ case '>':
+ C_tgt();
+ break;
+ case GREATEREQUAL:
+ C_tge();
+ break;
+ case '=':
+ C_teq();
+ break;
+ case NOTEQUAL:
+ C_tne();
+ break;
+ default:
+ crash("(truthvalue)");
+ /*NOTREACHED*/
}
}
-Operands(leftop, rightop)
- register struct node *leftop, *rightop;
+
+
+static void Operands(register struct node *leftop, register struct node *rightop)
{
CodePExpr(leftop);
CodePExpr(rightop);
}
-CodeBoper(expr, true_label)
- register struct node *expr; /* the expression tree itself */
- label true_label; /* label to jump to in logical exprs */
+static void CodeBoper(register struct node *expr, /* the expression tree itself */
+label true_label) /* label to jump to in logical exprs */
{
register struct node *leftop = expr->nd_left;
register struct node *rightop = expr->nd_right;
register struct type *tp = expr->nd_type;
- switch( expr->nd_symb ) {
- case '+':
- Operands(leftop, rightop);
- switch( tp->tp_fund ) {
- case T_INTEGER:
- case T_LONG:
- C_adi(tp->tp_size);
- break;
- case T_REAL:
- C_adf(tp->tp_size);
- break;
- case T_SET:
- C_ior(tp->tp_size);
- break;
- default:
- crash("(CodeBoper: bad type +)");
- }
+ switch (expr->nd_symb)
+ {
+ case '+':
+ Operands(leftop, rightop);
+ switch (tp->tp_fund)
+ {
+ case T_INTEGER:
+ case T_LONG:
+ C_adi(tp->tp_size);
break;
-
- case '-':
- Operands(leftop, rightop);
- switch( tp->tp_fund ) {
- case T_INTEGER:
- case T_LONG:
- C_sbi(tp->tp_size);
- break;
- case T_REAL:
- C_sbf(tp->tp_size);
- break;
- case T_SET:
- C_com(tp->tp_size);
- C_and(tp->tp_size);
- break;
- default:
- crash("(CodeBoper: bad type -)");
- }
+ case T_REAL:
+ C_adf(tp->tp_size);
break;
-
- case '*':
- Operands(leftop, rightop);
- switch( tp->tp_fund ) {
- case T_INTEGER:
- case T_LONG:
- C_mli(tp->tp_size);
- break;
- case T_REAL:
- C_mlf(tp->tp_size);
- break;
- case T_SET:
- C_and(tp->tp_size);
- break;
- default:
- crash("(CodeBoper: bad type *)");
- }
+ case T_SET:
+ C_ior(tp->tp_size);
break;
+ default:
+ crash("(CodeBoper: bad type +)");
+ }
+ break;
- case '/':
- Operands(leftop, rightop);
- if( tp->tp_fund == T_REAL )
- C_dvf(tp->tp_size);
- else
- crash("(CodeBoper: bad type /)");
+ case '-':
+ Operands(leftop, rightop);
+ switch (tp->tp_fund)
+ {
+ case T_INTEGER:
+ case T_LONG:
+ C_sbi(tp->tp_size);
break;
-
- case DIV:
- case MOD:
- Operands(leftop, rightop);
- if( tp->tp_fund == T_INTEGER ) {
- C_cal(expr->nd_symb == MOD ? "_mdi" : "_dvi");
- C_asp(2 * tp->tp_size);
- C_lfr(tp->tp_size);
- }
- else if( tp->tp_fund == T_LONG) {
- C_cal(expr->nd_symb == MOD ? "_mdil" : "_dvil");
- C_asp(2 * tp->tp_size);
- C_lfr(tp->tp_size);
- }
- else
- crash("(CodeBoper: bad type MOD)");
+ case T_REAL:
+ C_sbf(tp->tp_size);
break;
-
- case '<':
- case LESSEQUAL:
- case '>':
- case GREATEREQUAL:
- case '=':
- case NOTEQUAL:
- CodePExpr(leftop);
- CodePExpr(rightop);
- tp = BaseType(rightop->nd_type);
-
- switch( tp->tp_fund ) {
- case T_INTEGER:
- case T_LONG:
- C_cmi(tp->tp_size);
- break;
- case T_REAL:
- C_cmf(tp->tp_size);
- break;
- case T_ENUMERATION:
- case T_CHAR:
- C_cmu(word_size);
- break;
- case T_POINTER:
- C_cmp();
- break;
-
- case T_SET:
- if( expr->nd_symb == GREATEREQUAL ) {
- /* A >= B is the same as A equals A + B
- */
- C_dup(2 * tp->tp_size);
- C_asp(tp->tp_size);
- C_ior(tp->tp_size);
- expr->nd_symb = '=';
- }
- else if( expr->nd_symb == LESSEQUAL ) {
- /* A <= B is the same as A - B = []
- */
- C_com(tp->tp_size);
- C_and(tp->tp_size);
- C_zer(tp->tp_size);
- expr->nd_symb = '=';
- }
- C_cms(tp->tp_size);
- break;
-
- case T_STRINGCONST:
- case T_ARRAY:
- C_loc((arith) IsString(tp));
- C_cal("_bcp");
- C_asp(2 * pointer_size + word_size);
- C_lfr(word_size);
- break;
-
- case T_STRING:
- C_cmp();
- break;
-
- default:
- crash("(CodeBoper : bad type COMPARE)");
- }
- truthvalue(expr->nd_symb);
- if( true_label != NO_LABEL )
- C_zeq(true_label);
+ case T_SET:
+ C_com(tp->tp_size);
+ C_and(tp->tp_size);
break;
+ default:
+ crash("(CodeBoper: bad type -)");
+ }
+ break;
- case IN:
- /* In this case, evaluate right hand side first! The INN
- instruction expects the bit number on top of the stack
- */
- CodePExpr(rightop);
- CodePExpr(leftop);
- if( rightop->nd_type == emptyset_type )
- C_and(rightop->nd_type->tp_size);
- else
- C_inn(rightop->nd_type->tp_size);
-
- if( true_label != NO_LABEL )
- C_zeq(true_label);
+ case '*':
+ Operands(leftop, rightop);
+ switch (tp->tp_fund)
+ {
+ case T_INTEGER:
+ case T_LONG:
+ C_mli(tp->tp_size);
break;
-
- case AND:
- case OR:
- Operands(leftop, rightop);
- if( expr->nd_symb == AND )
- C_and(tp->tp_size);
- else
- C_ior(tp->tp_size);
- if( true_label != NO_LABEL )
- C_zeq(true_label);
+ case T_REAL:
+ C_mlf(tp->tp_size);
+ break;
+ case T_SET:
+ C_and(tp->tp_size);
break;
default:
- crash("(CodeBoper Bad operator %s\n)",
- symbol2str(expr->nd_symb));
- }
-}
+ crash("(CodeBoper: bad type *)");
+ }
+ break;
-/* truthvalue() serves as an auxiliary function of CodeBoper */
-truthvalue(relop)
-{
- switch( relop ) {
- case '<':
- C_tlt();
+ case '/':
+ Operands(leftop, rightop);
+ if (tp->tp_fund == T_REAL)
+ C_dvf(tp->tp_size);
+ else
+ crash("(CodeBoper: bad type /)");
+ break;
+
+ case DIV:
+ case MOD:
+ Operands(leftop, rightop);
+ if (tp->tp_fund == T_INTEGER)
+ {
+ C_cal(expr->nd_symb == MOD ? "_mdi" : "_dvi");
+ C_asp(2 * tp->tp_size);
+ C_lfr(tp->tp_size);
+ }
+ else if (tp->tp_fund == T_LONG)
+ {
+ C_cal(expr->nd_symb == MOD ? "_mdil" : "_dvil");
+ C_asp(2 * tp->tp_size);
+ C_lfr(tp->tp_size);
+ }
+ else
+ crash("(CodeBoper: bad type MOD)");
+ break;
+
+ case '<':
+ case LESSEQUAL:
+ case '>':
+ case GREATEREQUAL:
+ case '=':
+ case NOTEQUAL:
+ CodePExpr(leftop);
+ CodePExpr(rightop);
+ tp = BaseType(rightop->nd_type);
+
+ switch (tp->tp_fund)
+ {
+ case T_INTEGER:
+ case T_LONG:
+ C_cmi(tp->tp_size);
+ break;
+ case T_REAL:
+ C_cmf(tp->tp_size);
break;
- case LESSEQUAL:
- C_tle();
+ case T_ENUMERATION:
+ case T_CHAR:
+ C_cmu(word_size);
break;
- case '>':
- C_tgt();
+ case T_POINTER:
+ C_cmp();
break;
- case GREATEREQUAL:
- C_tge();
+
+ case T_SET:
+ if (expr->nd_symb == GREATEREQUAL)
+ {
+ /* A >= B is the same as A equals A + B
+ */
+ C_dup(2 * tp->tp_size);
+ C_asp(tp->tp_size);
+ C_ior(tp->tp_size);
+ expr->nd_symb = '=';
+ }
+ else if (expr->nd_symb == LESSEQUAL)
+ {
+ /* A <= B is the same as A - B = []
+ */
+ C_com(tp->tp_size);
+ C_and(tp->tp_size);
+ C_zer(tp->tp_size);
+ expr->nd_symb = '=';
+ }
+ C_cms(tp->tp_size);
break;
- case '=':
- C_teq();
+
+ case T_STRINGCONST:
+ case T_ARRAY:
+ C_loc((arith) IsString(tp));
+ C_cal("_bcp");
+ C_asp(2 * pointer_size + word_size);
+ C_lfr(word_size);
break;
- case NOTEQUAL:
- C_tne();
+
+ case T_STRING:
+ C_cmp();
break;
+
default:
- crash("(truthvalue)");
- /*NOTREACHED*/
+ crash("(CodeBoper : bad type COMPARE)");
+ }
+ truthvalue(expr->nd_symb);
+ if (true_label != NO_LABEL )
+ C_zeq(true_label);
+ break;
+
+ case IN:
+ /* In this case, evaluate right hand side first! The INN
+ instruction expects the bit number on top of the stack
+ */
+ CodePExpr(rightop);
+ CodePExpr(leftop);
+ if (rightop->nd_type == emptyset_type)
+ C_and(rightop->nd_type->tp_size);
+ else
+ C_inn(rightop->nd_type->tp_size);
+
+ if (true_label != NO_LABEL )
+ C_zeq(true_label);
+ break;
+
+ case AND:
+ case OR:
+ Operands(leftop, rightop);
+ if (expr->nd_symb == AND)
+ C_and(tp->tp_size);
+ else
+ C_ior(tp->tp_size);
+ if (true_label != NO_LABEL )
+ C_zeq(true_label);
+ break;
+ default:
+ crash("(CodeBoper Bad operator %s\n)", symbol2str(expr->nd_symb));
}
}
-CodeSet(nd)
- register struct node *nd;
+
+static void CodeSet(register struct node *nd)
{
register struct type *tp = nd->nd_type;
C_zer(tp->tp_size);
nd = nd->nd_right;
- while( nd ) {
+ while (nd)
+ {
assert(nd->nd_class == Link && nd->nd_symb == ',');
CodeEl(nd->nd_left, tp);
}
}
-CodeEl(nd, tp)
- register struct node *nd;
- register struct type *tp;
+static void CodeEl(register struct node *nd, register struct type *tp)
{
- if( nd->nd_class == Link && nd->nd_symb == UPTO ) {
+ if (nd->nd_class == Link && nd->nd_symb == UPTO)
+ {
Operands(nd->nd_left, nd->nd_right);
- C_loc(tp->tp_size); /* push size */
- C_cal("_bts"); /* library routine to fill set */
+ C_loc(tp->tp_size); /* push size */
+ C_cal("_bts"); /* library routine to fill set */
C_asp(3 * word_size);
}
- else {
+ else
+ {
CodePExpr(nd);
C_set(tp->tp_size);
C_ior(tp->tp_size);
}
}
-struct type *
-CodeParameters(param, arg)
- struct paramlist *param;
- struct node *arg;
+static struct type * CodeParameters(struct paramlist *param, struct node *arg)
{
register struct type *tp, *left_tp, *last_tp = (struct type *) 0;
struct node *left;
assert(param && arg);
- if( param->next )
+ if (param->next)
last_tp = CodeParameters(param->next, arg->nd_right);
tp = TypeOfParam(param);
left = arg->nd_left;
left_tp = left->nd_type;
- if( IsConformantArray(tp) ) {
- if( last_tp != tp )
+ if (IsConformantArray(tp))
+ {
+ if (last_tp != tp)
/* push descriptors only once */
CodeConfDescr(tp, left_tp);
CodeDAddress(left);
return tp;
}
- if( IsVarParam(param) ) {
+ if (IsVarParam(param))
+ {
CodeDAddress(left);
return tp;
}
- if( left_tp->tp_fund == T_STRINGCONST ) {
+ if (left_tp->tp_fund == T_STRINGCONST)
+ {
CodePString(left, tp);
return tp;
}
ds = InitDesig;
- CodeExpr(left, &ds, NO_LABEL);
+ CodeExpr(left, &ds, NO_LABEL );
CodeValue(&ds, left_tp);
RangeCheck(tp, left_tp);
- if( tp == real_type && BaseType(left_tp) == int_type )
+ if (tp == real_type && BaseType(left_tp) == int_type)
Int2Real(int_size);
return tp;
}
-CodeConfDescr(ftp, atp)
- register struct type *ftp, *atp;
+static void CodeConfDescr(register struct type *ftp, register struct type *atp)
{
struct type *elemtp = ftp->arr_elem;
- if( IsConformantArray(elemtp) )
+ if (IsConformantArray(elemtp))
CodeConfDescr(elemtp, atp->arr_elem);
- if( atp->tp_fund == T_STRINGCONST ) {
+ if (atp->tp_fund == T_STRINGCONST)
+ {
C_loc((arith) 1);
C_loc(atp->tp_psize - 1);
C_loc((arith) 1);
}
- else if( IsConformantArray(atp) ) {
- if( atp->arr_sclevel < proclevel ) {
+ else if (IsConformantArray(atp))
+ {
+ if (atp->arr_sclevel < proclevel)
+ {
C_lxa((arith) proclevel - atp->arr_sclevel);
C_adp(atp->arr_cfdescr);
}
C_loi(3 * word_size);
}
- else { /* normal array */
+ else
+ { /* normal array */
assert(atp->tp_fund == T_ARRAY);
assert(!IsConformantArray(atp));
C_lae_dlb(atp->arr_ardescr, (arith) 0);
- C_loi( 3 * word_size);
+ C_loi(3 * word_size);
}
}
-CodePString(nd, tp)
- struct node *nd;
- struct type *tp;
+static void CodePString(struct node *nd, struct type *tp)
{
/* no null padding */
C_lae_dlb(nd->nd_SLA, (arith) 0);
C_loi(tp->tp_size);
}
-void
-CodeCall(nd)
- register struct node *nd;
+void CodeCall(register struct node *nd)
{
/* Generate code for a procedure call. Checking of parameters
- and result is already done.
- */
+ and result is already done.
+ */
register struct node *left = nd->nd_left;
register struct node *right = nd->nd_right;
register struct def *df = left->nd_def;
assert(IsProcCall(left));
- if( left->nd_type == std_type ) {
+ if (left->nd_type == std_type)
+ {
CodeStd(nd);
return;
- }
+ }
- if( right )
+ if (right)
(void) CodeParameters(ParamList(left->nd_type), right);
assert(left->nd_class == Def);
-
- if( df->df_kind & D_ROUTINE ) {
+ if (df->df_kind & D_ROUTINE)
+ {
int level = df->df_scope->sc_level;
- if( level > 0 && !(df->df_flags & D_EXTERNAL) )
- C_lxl((arith) (proclevel - level));
+ if (level > 0 && !(df->df_flags & D_EXTERNAL))
+ C_lxl((arith)(proclevel - level));
C_cal(df->prc_name);
C_asp(left->nd_type->prc_nbpar);
}
- else {
+ else
+ {
label l1 = ++text_label;
label l2 = ++text_label;
C_cmp();
C_zeq(l1);
- /* At this point, on top of the stack the LB */
+ /* At this point, on top of the stack the LB */
C_exg(pointer_size);
- /* Now, the name of the procedure/function */
- C_cai();
+ /* Now, the name of the procedure/function */C_cai();
C_asp(pointer_size + left->nd_type->prc_nbpar);
C_bra(l2);
/* value is a global procedure/function */
C_df_ilb(l1);
- C_asp(pointer_size); /* no LB needed */
+ C_asp(pointer_size); /* no LB needed */
C_cai();
C_asp(left->nd_type->prc_nbpar);
C_df_ilb(l2);
}
- if( result_tp = ResultType(left->nd_type) )
+ if ( (result_tp = ResultType(left->nd_type)) )
C_lfr(result_tp->tp_size);
}
-CodeStd(nd)
- struct node *nd;
+static void CodeStd(struct node *nd)
{
register struct node *arg = nd->nd_right;
register struct node *left = arg->nd_left;
assert(arg->nd_class == Link && arg->nd_symb == ',');
- switch( req ) {
- case R_ABS:
- CodePExpr(left);
- if( tp == int_type )
- C_cal("_abi");
- else if ( tp == long_type )
- C_cal("_abl");
- else
- C_cal("_abr");
- C_asp(tp->tp_size);
- C_lfr(tp->tp_size);
- break;
+ switch (req)
+ {
+ case R_ABS:
+ CodePExpr(left);
+ if (tp == int_type)
+ C_cal("_abi");
+ else if (tp == long_type)
+ C_cal("_abl");
+ else
+ C_cal("_abr");
+ C_asp(tp->tp_size);
+ C_lfr(tp->tp_size);
+ break;
- case R_SQR:
- CodePExpr(left);
- C_dup(tp->tp_size);
- if( tp == int_type || tp == long_type )
- C_mli(tp->tp_size);
- else
- C_mlf(real_size);
- break;
+ case R_SQR:
+ CodePExpr(left);
+ C_dup(tp->tp_size);
+ if (tp == int_type || tp == long_type)
+ C_mli(tp->tp_size);
+ else
+ C_mlf(real_size);
+ break;
+ case R_SIN:
+ case R_COS:
+ case R_EXP:
+ case R_LN:
+ case R_SQRT:
+ case R_ARCTAN:
+ assert(tp == real_type);
+ CodePExpr(left);
+ switch (req)
+ {
case R_SIN:
+ C_cal("_sin");
+ break;
case R_COS:
+ C_cal("_cos");
+ break;
case R_EXP:
+ C_cal("_exp");
+ break;
case R_LN:
+ C_cal("_log");
+ break;
case R_SQRT:
- case R_ARCTAN:
- assert(tp == real_type);
- CodePExpr(left);
- switch( req ) {
- case R_SIN:
- C_cal("_sin");
- break;
- case R_COS:
- C_cal("_cos");
- break;
- case R_EXP:
- C_cal("_exp");
- break;
- case R_LN:
- C_cal("_log");
- break;
- case R_SQRT:
- C_cal("_sqt");
- break;
- case R_ARCTAN:
- C_cal("_atn");
- break;
- default:
- crash("(CodeStd)");
- /*NOTREACHED*/
- }
- C_asp(real_size);
- C_lfr(real_size);
+ C_cal("_sqt");
break;
-
- case R_TRUNC:
- assert(tp == real_type);
- CodePExpr(left);
- Real2Int();
+ case R_ARCTAN:
+ C_cal("_atn");
break;
+ default:
+ crash("(CodeStd)");
+ /*NOTREACHED*/
+ }
+ C_asp(real_size);
+ C_lfr(real_size);
+ break;
- case R_ROUND:
- assert(tp == real_type);
- CodePExpr(left);
- C_cal("_rnd");
- C_asp(real_size);
- C_lfr(real_size);
- Real2Int();
- break;
+ case R_TRUNC:
+ assert(tp == real_type);
+ CodePExpr(left);
+ Real2Int();
+ break;
- case R_ORD:
- CodePExpr(left);
- break;
+ case R_ROUND:
+ assert(tp == real_type);
+ CodePExpr(left);
+ C_cal("_rnd");
+ C_asp(real_size);
+ C_lfr(real_size);
+ Real2Int();
+ break;
- case R_CHR:
- CodePExpr(left);
- genrck(char_type);
- break;
+ case R_ORD:
+ CodePExpr(left);
+ break;
- case R_SUCC:
- case R_PRED:
- CodePExpr(left);
- C_loc((arith)1);
- if( tp == long_type) Int2Long();
+ case R_CHR:
+ CodePExpr(left);
+ genrck(char_type);
+ break;
- if( req == R_SUCC )
- C_adi(tp->tp_size);
- else
- C_sbi(tp->tp_size);
+ case R_SUCC:
+ case R_PRED:
+ CodePExpr(left);
+ C_loc((arith) 1);
+ if (tp == long_type)
+ Int2Long();
- if( bounded(left->nd_type) )
- genrck(left->nd_type);
- break;
+ if (req == R_SUCC)
+ C_adi(tp->tp_size);
+ else
+ C_sbi(tp->tp_size);
- case R_ODD:
- CodePExpr(left);
- C_loc((arith) 1);
- if( tp == long_type ) Int2Long();
- C_and(tp->tp_size);
- if( tp == long_type ) Long2Int(); /* bool_size == int_size */
- break;
+ if (bounded(left->nd_type))
+ genrck(left->nd_type);
+ break;
- case R_EOF:
- case R_EOLN:
- CodeDAddress(left);
- if( req == R_EOF )
- C_cal("_efl");
- else
- C_cal("_eln");
- C_asp(pointer_size);
- C_lfr(word_size);
- break;
+ case R_ODD:
+ CodePExpr(left);
+ C_loc((arith) 1);
+ if (tp == long_type)
+ Int2Long();
+ C_and(tp->tp_size);
+ if (tp == long_type)
+ Long2Int(); /* bool_size == int_size */
+ break;
- case R_REWRITE:
- case R_RESET:
- CodeDAddress(left);
- if( tp == text_type )
- C_loc((arith) 0);
- else
- C_loc(tp->next->tp_psize);
- /* ??? elements of packed size ??? */
- if( req == R_REWRITE )
- C_cal("_cre");
- else
- C_cal("_opn");
- C_asp(pointer_size + word_size);
- break;
+ case R_EOF:
+ case R_EOLN:
+ CodeDAddress(left);
+ if (req == R_EOF)
+ C_cal("_efl");
+ else
+ C_cal("_eln");
+ C_asp(pointer_size);
+ C_lfr(word_size);
+ break;
- case R_PUT:
- case R_GET:
- CodeDAddress(left);
- if( req == R_PUT )
- C_cal("_put");
- else
- C_cal("_get");
- C_asp(pointer_size);
- break;
+ case R_REWRITE:
+ case R_RESET:
+ CodeDAddress(left);
+ if (tp == text_type)
+ C_loc((arith) 0);
+ else
+ C_loc(tp->next->tp_psize);
+ /* ??? elements of packed size ??? */
+ if (req == R_REWRITE)
+ C_cal("_cre");
+ else
+ C_cal("_opn");
+ C_asp(pointer_size + word_size);
+ break;
- case R_PAGE:
- CodeDAddress(left);
- C_cal("_pag");
- C_asp(pointer_size);
- break;
+ case R_PUT:
+ case R_GET:
+ CodeDAddress(left);
+ if (req == R_PUT)
+ C_cal("_put");
+ else
+ C_cal("_get");
+ C_asp(pointer_size);
+ break;
- case R_PACK: {
- label lba = tp->arr_ardescr;
+ case R_PAGE:
+ CodeDAddress(left);
+ C_cal("_pag");
+ C_asp(pointer_size);
+ break;
+ case R_PACK:
+ {
+ label lba = tp->arr_ardescr;
- CodeDAddress(left);
- arg = arg->nd_right;
- left = arg->nd_left;
- CodePExpr(left);
- arg = arg->nd_right;
- left = arg->nd_left;
- CodeDAddress(left);
- C_lae_dlb(left->nd_type->arr_ardescr, (arith) 0);
- C_lae_dlb(lba, (arith) 0);
- C_cal("_pac");
- C_asp(4 * pointer_size + word_size);
- break;
- }
+ CodeDAddress(left);
+ arg = arg->nd_right;
+ left = arg->nd_left;
+ CodePExpr(left);
+ arg = arg->nd_right;
+ left = arg->nd_left;
+ CodeDAddress(left);
+ C_lae_dlb(left->nd_type->arr_ardescr, (arith) 0);
+ C_lae_dlb(lba, (arith) 0);
+ C_cal("_pac");
+ C_asp(4 * pointer_size + word_size);
+ break;
+ }
- case R_UNPACK: {
- /* change sequence of arguments of the library routine
- _unp to merge code of R_PACK and R_UNPACK.
- */
- label lba, lbz = tp->arr_ardescr;
+ case R_UNPACK:
+ {
+ /* change sequence of arguments of the library routine
+ _unp to merge code of R_PACK and R_UNPACK.
+ */
+ label lba, lbz = tp->arr_ardescr;
- tp = tp->arr_elem;
- if (tp->tp_fund == T_SUBRANGE &&
- tp->sub_lb >= 0) {
- C_loc((arith) 1);
- }
- else C_loc((arith) 0);
- CodeDAddress(left);
- arg = arg->nd_right;
- left = arg->nd_left;
- CodeDAddress(left);
- lba = left->nd_type->arr_ardescr;
- arg = arg->nd_right;
- left = arg->nd_left;
- CodePExpr(left);
- C_lae_dlb(lbz, (arith) 0);
- C_lae_dlb(lba, (arith) 0);
- C_cal("_unp");
- C_asp(4 * pointer_size + 2 * word_size);
- break;
+ tp = tp->arr_elem;
+ if (tp->tp_fund == T_SUBRANGE && tp->sub_lb >= 0)
+ {
+ C_loc((arith) 1);
}
+ else
+ C_loc((arith) 0);
+ CodeDAddress(left);
+ arg = arg->nd_right;
+ left = arg->nd_left;
+ CodeDAddress(left);
+ lba = left->nd_type->arr_ardescr;
+ arg = arg->nd_right;
+ left = arg->nd_left;
+ CodePExpr(left);
+ C_lae_dlb(lbz, (arith) 0);
+ C_lae_dlb(lba, (arith) 0);
+ C_cal("_unp");
+ C_asp(4 * pointer_size + 2 * word_size);
+ break;
+ }
- case R_NEW:
- case R_DISPOSE:
- CodeDAddress(left);
- C_loc(PointedtoType(tp)->tp_size);
- if( req == R_NEW )
- C_cal("_new");
- else
- C_cal("_dis");
- C_asp(pointer_size + word_size);
- break;
+ case R_NEW:
+ case R_DISPOSE:
+ CodeDAddress(left);
+ C_loc(PointedtoType(tp)->tp_size);
+ if (req == R_NEW)
+ C_cal("_new");
+ else
+ C_cal("_dis");
+ C_asp(pointer_size + word_size);
+ break;
- case R_HALT:
- if( left )
- CodePExpr(left);
- else
- C_zer(int_size);
- C_cal("_hlt"); /* can't return */
- C_asp(int_size); /* help the optimizer(s) */
- break;
+ case R_HALT:
+ if (left)
+ CodePExpr(left);
+ else
+ C_zer(int_size);
+ C_cal("_hlt"); /* can't return */
+ C_asp(int_size); /* help the optimizer(s) */
+ break;
- default:
- crash("(CodeStd)");
- /*NOTREACHED*/
+ default:
+ crash("(CodeStd)");
+ /*NOTREACHED*/
}
}
-void
-Long2Int()
+void Long2Int(void)
{
/* convert a long to integer */
- if (int_size == long_size) return;
+ if (int_size == long_size)
+ return;
C_loc(long_size);
C_loc(int_size);
C_cii();
}
-void
-Int2Long()
+void Int2Long(void)
{
/* convert integer to long */
- if (int_size == long_size) return;
+ if (int_size == long_size)
+ return;
C_loc(int_size);
C_loc(long_size);
C_cii();
}
-Int2Real(size) /* size is different for integers and longs */
-arith size;
+void Int2Real(arith size)
+/* size is different for integers and longs */
{
/* convert integer to real */
C_loc(size);
C_cif();
}
-Real2Int()
+void Real2Int(void)
{
/* convert real to integer */
C_loc(real_size);
C_cfi();
}
-RangeCheck(tpl, tpr)
- register struct type *tpl, *tpr;
+void RangeCheck(register struct type *tpl, register struct type *tpr)
{
/* Generate a range check if neccessary
- */
+ */
arith llo, lhi, rlo, rhi;
- if( bounded(tpl) ) {
+ if (bounded(tpl))
+ {
/* in this case we might need a range check */
- if( !bounded(tpr) )
+ if (!bounded(tpr))
/* yes, we need one */
genrck(tpl);
- else {
+ else
+ {
/* both types are restricted. check the bounds to see
- whether we need a range check. We don't need one
- if the range of values of the right hand side is a
- subset of the range of values of the left hand side.
- */
+ whether we need a range check. We don't need one
+ if the range of values of the right hand side is a
+ subset of the range of values of the left hand side.
+ */
getbounds(tpl, &llo, &lhi);
getbounds(tpr, &rlo, &rhi);
- if( llo > rlo || lhi < rhi )
+ if (llo > rlo || lhi < rhi)
genrck(tpl);
}
}
}
-void
-genrck(tp)
- register struct type *tp;
+static void genrck(register struct type *tp)
{
/* Generate a range check descriptor for type "tp" when
- necessary. Return its label.
- */
+ necessary. Return its label.
+ */
arith lb, ub;
register label o1;
int newlabel = 0;
- if( options['R'] ) return;
+ if (options['R'])
+ return;
getbounds(tp, &lb, &ub);
- if( tp->tp_fund == T_SUBRANGE ) {
- if( !(o1 = tp->sub_rck) ) {
+ if (tp->tp_fund == T_SUBRANGE)
+ {
+ if (!(o1 = tp->sub_rck))
+ {
tp->sub_rck = o1 = ++data_label;
newlabel = 1;
}
}
- else if( !(o1 = tp->enm_rck) ) {
+ else if (!(o1 = tp->enm_rck))
+ {
tp->enm_rck = o1 = ++data_label;
newlabel = 1;
}
- if( newlabel ) {
+ if (newlabel)
+ {
C_df_dlb(o1);
C_rom_cst(lb);
C_rom_cst(ub);
C_rck(word_size);
}
-CodePExpr(nd)
- register struct node *nd;
+void CodePExpr(register struct node *nd)
{
/* Generate code to push the value of the expression "nd"
- on the stack.
- */
+ on the stack.
+ */
struct desig designator;
struct type *tp = BaseType(nd->nd_type);
-
+
designator = InitDesig;
- CodeExpr(nd, &designator, NO_LABEL);
- if( tp->tp_fund & (T_ARRAY | T_RECORD) )
+ CodeExpr(nd, &designator, NO_LABEL );
+ if (tp->tp_fund & (T_ARRAY | T_RECORD))
CodeAddress(&designator);
else
CodeValue(&designator, nd->nd_type);
}
-CodeDAddress(nd)
- struct node *nd;
+void CodeDAddress(struct node *nd)
{
/* Generate code to push the address of the designator "nd"
- on the stack.
- */
+ on the stack.
+ */
struct desig designator;
-
+
designator = InitDesig;
CodeDesig(nd, &designator);
CodeAddress(&designator);
}
-CodeDStore(nd)
- register struct node *nd;
+void CodeDStore(register struct node *nd)
{
/* Generate code to store the expression on the stack
- into the designator "nd".
- */
+ into the designator "nd".
+ */
struct desig designator;
-
+
designator = InitDesig;
CodeDesig(nd, &designator);
CodeStore(&designator, nd->nd_type);
}
-RegisterMessages(df)
- register struct def *df;
+static void RegisterMessages(register struct def *df)
{
register struct type *tp;
- for( ; df; df = df->df_nextinscope ) {
- if( df->df_kind == D_VARIABLE && !(df->df_flags & D_NOREG) ) {
+ for (; df; df = df->df_nextinscope)
+ {
+ if (df->df_kind == D_VARIABLE && !(df->df_flags & D_NOREG))
+ {
/* Examine type and size
- */
+ */
tp = BaseType(df->df_type);
- if( df->df_flags & D_VARPAR || tp->tp_fund & T_POINTER )
- C_ms_reg(df->var_off, pointer_size,
- reg_pointer, 0);
+ if (df->df_flags & D_VARPAR || tp->tp_fund & T_POINTER)
+ C_ms_reg(df->var_off, pointer_size, reg_pointer, 0);
- else if( df->df_flags & D_LOOPVAR )
- C_ms_reg(df->var_off, tp->tp_size, reg_loop,2);
- else if( tp->tp_fund & T_NUMERIC )
+ else if (df->df_flags & D_LOOPVAR)
+ C_ms_reg(df->var_off, tp->tp_size, reg_loop, 2);
+ else if (tp->tp_fund & T_NUMERIC)
C_ms_reg(df->var_off, tp->tp_size,
- tp->tp_fund == T_REAL ? reg_float : reg_any, 0);
+ tp->tp_fund == T_REAL ? reg_float : reg_any, 0);
}
}
}
--- /dev/null
+/* Copyright (c) 2019 ACK Project.
+ * See the copyright notice in the ACK home directory,
+ * in the file "Copyright".
+ *
+ */
+#ifndef CODE_H_
+#define CODE_H_
+
+#include "em_arith.h"
+#include "em_label.h"
+
+struct def;
+struct node;
+struct type;
+struct desig;
+
+void routine_label(register struct def * df);
+void RomString(register struct node *nd);
+void RomReal(register struct node *nd);
+void BssVar(void);
+arith CodeBeginBlock(register struct def *df);
+void CodeEndBlock(register struct def *df, arith StackAdjustment);
+void CodeExpr(register struct node *nd, register struct desig *ds,
+ label true_label);
+void CodeCall(register struct node *nd);
+void RangeCheck(register struct type *tpl, register struct type *tpr);
+
+/* Generate code to push the value of the expression "nd"
+ on the stack.
+*/
+void CodePExpr(register struct node *nd);
+
+/* Generate code to push the address of the designator "nd"
+ on the stack.
+ */
+void CodeDAddress(struct node *nd);
+
+/* Generate code to store the expression on the stack
+ into the designator "nd".
+ */
+void CodeDStore(register struct node *nd);
+
+/* Generate code to convert long to int */
+void Long2Int(void);
+/* Generate code to convert int to long */
+void Int2Long(void);
+/* Generate code to convert int to real */
+void Int2Real(arith size);
+/* Generate code to convert real to int */
+void Real2Int(void);
+
+
+
+
+
+#endif /* CODE_H_ */
#include "node.h"
#include "required.h"
#include "type.h"
+#include "cstoper.h"
+#include "error.h"
long mach_long_sign; /* sign bit of the machine long */
long full_mask[MAXSIZE+1];/* full_mask[1] == 0xFF, full_mask[2] == 0xFFFF, .. */
arith wrd_bits; /* number of bits in a word */
arith max_intset; /* largest value of set of integer */
-overflow(expp)
- struct node *expp;
+void CutSize(register struct node *expr);
+
+void overflow(struct node *expp)
{
node_warning(expp, "overflow in constant expression");
}
-cstunary(expp)
- register struct node *expp;
+void cstunary(register struct node *expp)
{
- /* The unary operation in "expp" is performed on the constant
- expression below it, and the result restored in expp.
- */
register arith o1 = expp->nd_right->nd_INT;
switch( expp->nd_symb ) {
expp->nd_right = NULLNODE;
}
-void
-cstbin(expp)
- register struct node *expp;
+void cstbin(register struct node *expp)
{
/* The binary operation in "expp" is performed on the constant
expressions below it, and the result restored in expp.
expp->nd_left = expp->nd_right = NULLNODE;
}
-void
-cstset(expp)
- register struct node *expp;
+void cstset(register struct node *expp)
{
register arith *set1, *set2;
arith *resultset = (arith *) 0;
expp->nd_left = expp->nd_right = NULLNODE;
}
-cstcall(expp, req)
- register struct node *expp;
+void cstcall(register struct node *expp, int req)
{
/* a standard procedure call is found that can be evaluated
compile time, so do so.
expp->nd_right = expp->nd_left = NULLNODE;
}
-CutSize(expr)
- register struct node *expr;
+void CutSize(register struct node *expr)
{
/* The constant value of the expression expr is made to conform
* to the size of the type of the expression
o1 &= 0177;
}
}
- else if( remainder != 0 && remainder != ~full_mask[size] ||
- (o1 & full_mask[size]) == 1 << (size * 8 - 1) ) {
+ else if( (remainder != 0 && remainder != ~full_mask[size]) ||
+ ((o1 & full_mask[size]) == 1 << (size * 8 - 1)) ) {
/* integers in [-maxint .. maxint] */
int nbits = (int) (sizeof(long) - size) * 8;
expr->nd_INT = o1;
}
-InitCst()
+void InitCst(void)
{
- extern char *Salloc();
register int i = 0;
register arith bt = (arith)0;
--- /dev/null
+/* Copyright (c) 2019 ACK Project.
+ * See the copyright notice in the ACK home directory,
+ * in the file "Copyright".
+ *
+ */
+#ifndef CSTOPER_H_
+#define CSTOPER_H_
+
+/* Forward struct declarations. */
+struct node;
+
+/* The unary operation in "expp" is performed on the constant
+ expression below it, and the result restored in expp.
+*/
+void cstunary(register struct node *expp);
+
+/* The binary operation in "expp" is performed on the constant
+ expressions below it, and the result restored in expp.
+*/
+void cstbin(register struct node *expp);
+void cstset(register struct node *expp);
+
+/* Standard system function call that can be evaluated
+ * a compile time.
+ */
+void cstcall(register struct node *expp, int req);
+
+/* The constant value of the expression expr is made to conform
+ * to the size of the type of the expression
+ */
+void CutSize(register struct node *expr);
+void InitCst(void);
+
+
+
+#endif /* CSTOPER_H_ */
#include "node.h"
#include "scope.h"
#include "type.h"
+#include "code.h"
+#include "error.h"
+#include "label.h"
+#include "enter.h"
+#ifdef DBSYMTAB
+#include "stab.h"
+#endif
+
#define PC_BUFSIZ (sizeof(struct file) - offsetof(struct file, bufadr))
} :
IDENT { id = dot.TOK_IDF; }
'=' Constant(&nd)
- { if( df = define(id,CurrentScope,D_CONST) ) {
+ { if (( df = define(id,CurrentScope,D_CONST))) {
df->con_const = nd;
df->df_type = nd->nd_type;
df->df_flags |= D_SET;
} :
IDENT { id = dot.TOK_IDF; }
'=' TypeDenoter(&tp)
- { if( df = define(id, CurrentScope, D_TYPE) ) {
+ { if ((df = define(id, CurrentScope, D_TYPE)) ) {
df->df_type = tp;
df->df_flags |= D_SET;
#ifdef DBSYMTAB
else DoDirective(dot.TOK_IDF, nd, tp, scl, 1);
}
|
- { if( df = DeclFunc(nd, tp, scl) ) {
+ { if ((df = DeclFunc(nd, tp, scl) )) {
df->prc_res =
- ResultType(df->df_type)->tp_size;
df->prc_bool =
{ max = tcnt; }
VariantTail(scope, &tcnt, &max, cnt, palign, packed, *sel)
{ *cnt = max;
- if( sp = (*sel)->sel_ptrs ) {
+ if ( (sp = (*sel)->sel_ptrs) ) {
int errflag = 0;
ncst = (*sel)->sel_ncst;
register struct def *df1, *df2;
} :
IDENT
- { if( df1 =
- define(dot.TOK_IDF, CurrentScope, D_LBOUND)) {
+ { if( (df1 =
+ define(dot.TOK_IDF, CurrentScope, D_LBOUND)) ) {
df1->bnd_type = tp; /* type conf. array */
df1->df_flags |= D_SET;
}
}
UPTO
IDENT
- { if( df2 =
- define(dot.TOK_IDF, CurrentScope, D_UBOUND)) {
+ { if( (df2 =
+ define(dot.TOK_IDF, CurrentScope, D_UBOUND)) ) {
df2->bnd_type = tp; /* type conf. array */
df2->df_flags |= D_SET;
}
#include "misc.h"
#include "node.h"
#include "scope.h"
+#include "code.h"
#include "type.h"
+#include "lookup.h"
+#include "error.h"
-struct def *
-MkDef(id, scope, kind)
- register struct idf *id;
- register struct scope *scope;
- long kind;
+struct def *MkDef(register struct idf *id, register struct scope *scope,
+ long kind)
{
/* Create a new definition structure in scope "scope", with
* id "id" and kind "kind".
id->id_def = df;
/* enter the definition in the list of definitions in this scope
- */
+ */
df->df_nextinscope = scope->sc_def;
scope->sc_def = df;
return df;
}
-struct def *
-define(id, scope, kind)
- register struct idf *id;
- register struct scope *scope;
- long kind;
+struct def *define(register struct idf *id, register struct scope *scope,
+ long 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 struct def *df;
- if( df = lookup(id, scope, 0L) ) {
- if (df->df_kind == D_INUSE) {
- if( kind != D_INUSE ) {
- error("\"%s\" already used in this block",
- id->id_text);
+ if ( (df = lookup(id, scope, 0L)) )
+ {
+ if (df->df_kind == D_INUSE)
+ {
+ if (kind != D_INUSE)
+ {
+ error("\"%s\" already used in this block", id->id_text);
}
return MkDef(id, scope, kind);
}
- if (df->df_kind == D_ERROR ) {
+ if (df->df_kind == D_ERROR)
+ {
/* used in forward references */
df->df_kind = kind;
return df;
}
/* other cases fit in an int (assume at least 2 bytes) */
- switch((int) df->df_kind ) {
+ switch ((int) df->df_kind)
+ {
- case D_LABEL :
+ case D_LABEL:
/* generate error message somewhere else */
return NULLDEF;
- case D_PARAMETER :
- if( kind == D_VARIABLE )
- /* program parameter declared as variable */
+ case D_PARAMETER:
+ if (kind == D_VARIABLE)
+ /* program parameter declared as variable */
return df;
break;
- case D_FORWTYPE :
- if( kind == D_FORWTYPE ) return df;
- if( kind == D_TYPE ) {
- /* forward reference resolved */
+ case D_FORWTYPE:
+ if (kind == D_FORWTYPE)
+ return df;
+ if (kind == D_TYPE)
+ {
+ /* forward reference resolved */
df->df_kind = D_FTYPE;
return df;
}
else
- error("identifier \"%s\" must be a type",
- id->id_text);
+ error("identifier \"%s\" must be a type", id->id_text);
return NULLDEF;
- case D_FWPROCEDURE :
- if( kind == D_PROCEDURE ) return df;
- error("procedure identification \"%s\" expected",
- id->id_text);
+ case D_FWPROCEDURE:
+ if (kind == D_PROCEDURE)
+ return df;
+ error("procedure identification \"%s\" expected", id->id_text);
return NULLDEF;
- case D_FWFUNCTION :
- if( kind == D_FUNCTION ) return df;
- error("function identification \"%s\" expected",
- id->id_text);
+ case D_FWFUNCTION:
+ if (kind == D_FUNCTION)
+ return df;
+ error("function identification \"%s\" expected", id->id_text);
return NULLDEF;
}
- if( kind != D_ERROR )
+ if (kind != D_ERROR)
/* avoid spurious error messages */
- error("identifier \"%s\" already declared",id->id_text);
+ error("identifier \"%s\" already declared", id->id_text);
return NULLDEF;
}
return MkDef(id, scope, kind);
}
-void
-DoDirective(directive, nd, tp, scl, function)
- struct idf *directive;
- struct node *nd;
- struct type *tp;
- struct scopelist *scl;
+void DoDirective(struct idf *directive, struct node *nd, struct type *tp,
+ struct scopelist *scl, int function)
{
- long kind; /* kind of directive */
- int inp; /* internal or external name */
- int ext = 0; /* directive = EXTERN */
+ long kind; /* kind of directive */
+ int inp; /* internal or external name */
+ int ext = 0; /* directive = EXTERN */
struct def *df = lookup(directive, PervasiveScope, D_INUSE);
- if( !df ) {
- if( !is_anon_idf(directive) )
- node_error(nd, "\"%s\" unknown directive",
- directive->id_text);
+ if (!df)
+ {
+ if (!is_anon_idf(directive))
+ node_error(nd, "\"%s\" unknown directive", directive->id_text);
return;
}
- if (df->df_kind == D_FORWARD) {
+ if (df->df_kind == D_FORWARD)
+ {
kind = function ? D_FWFUNCTION : D_FWPROCEDURE;
inp = (proclevel > 1);
}
- else if (df->df_kind == D_EXTERN) {
+ else if (df->df_kind == D_EXTERN)
+ {
kind = function ? D_FUNCTION : D_PROCEDURE;
inp = 0;
ext = 1;
}
- else {
- node_error(nd, "\"%s\" unknown directive",
- directive->id_text);
+ else
+ {
+ node_error(nd, "\"%s\" unknown directive", directive->id_text);
return;
}
- if( df = define(nd->nd_IDF, CurrentScope, kind) ) {
- if( df->df_kind != kind ) {
+ if ( (df = define(nd->nd_IDF, CurrentScope, kind)) )
+ {
+ if (df->df_kind != kind)
+ {
/* identifier already forward declared */
node_error(nd, "\"%s\" already forward declared",
- nd->nd_IDF->id_text);
+ nd->nd_IDF->id_text);
return;
}
df->df_type = tp;
df->prc_vis = scl;
df->prc_name = gen_proc_name(nd->nd_IDF, inp);
- if( ext ) {
+ if (ext)
+ {
if (!(df->df_flags & D_EXTERNAL) && proclevel > 1)
tp->prc_nbpar -= pointer_size;
/* was added for static link which is not needed now.
- But make sure this is done only once (look at the
- D_EXTERNAL flag).
- */
+ But make sure this is done only once (look at the
+ D_EXTERNAL flag).
+ */
df->df_flags |= D_EXTERNAL;
}
df->df_flags |= D_SET;
}
}
-struct def *
-DeclProc(nd, tp, scl)
- register struct node *nd;
- struct type *tp;
- register struct scopelist *scl;
+struct def *DeclProc(register struct node *nd, struct type *tp,
+ register struct scopelist *scl)
{
register struct def *df;
- if( df = define(nd->nd_IDF, CurrentScope, D_PROCEDURE) ) {
+ if ( (df = define(nd->nd_IDF, CurrentScope, D_PROCEDURE)) )
+ {
df->df_flags |= D_SET;
- if( df->df_kind == D_FWPROCEDURE ) {
- df->df_kind = D_PROCEDURE; /* identification */
+ if (df->df_kind == D_FWPROCEDURE)
+ {
+ df->df_kind = D_PROCEDURE; /* identification */
/* Simulate a call to open_scope(), which has already
* been performed in the forward declaration.
*/
CurrVis = df->prc_vis;
- if( tp->prc_params )
- node_error(nd,
- "\"%s\" already declared",
- nd->nd_IDF->id_text);
+ if (tp->prc_params)
+ node_error(nd, "\"%s\" already declared", nd->nd_IDF->id_text);
}
- else { /* normal declaration */
+ else
+ { /* normal declaration */
df->df_type = tp;
- df->prc_name = gen_proc_name(nd->nd_IDF, (proclevel>1));
+ df->prc_name = gen_proc_name(nd->nd_IDF, (proclevel > 1));
/* simulate open_scope() */
CurrVis = df->prc_vis = scl;
}
routine_label(df);
}
- else CurrVis = scl; /* simulate open_scope() */
+ else
+ CurrVis = scl; /* simulate open_scope() */
return df;
}
struct def *
-DeclFunc(nd, tp, scl)
- register struct node *nd;
- struct type *tp;
- register struct scopelist *scl;
+DeclFunc(register struct node *nd, struct type *tp,
+ register struct scopelist *scl)
{
register struct def *df;
- if( df = define(nd->nd_IDF, CurrentScope, D_FUNCTION) ) {
- df->df_flags &= ~D_SET;
- if( df->df_kind == D_FUNCTION ) { /* declaration */
- if( !tp ) {
- node_error(nd, "\"%s\" illegal function declaration",
- nd->nd_IDF->id_text);
- tp = construct_type(T_FUNCTION, error_type);
+ if ( (df = define(nd->nd_IDF, CurrentScope, D_FUNCTION)) )
+ {
+ df->df_flags &= ~D_SET;
+ if (df->df_kind == D_FUNCTION)
+ { /* declaration */
+ if (!tp)
+ {
+ node_error(nd, "\"%s\" illegal function declaration",
+ nd->nd_IDF->id_text);
+ tp = construct_type(T_FUNCTION, error_type);
+ }
+ /* simulate open_scope() */
+ CurrVis = df->prc_vis = scl;
+ df->df_type = tp;
+ df->prc_name = gen_proc_name(nd->nd_IDF, (proclevel > 1));
}
- /* simulate open_scope() */
- CurrVis = df->prc_vis = scl;
- df->df_type = tp;
- df->prc_name = gen_proc_name(nd->nd_IDF, (proclevel > 1));
- }
- else { /* identification */
- assert(df->df_kind == D_FWFUNCTION);
+ else
+ { /* identification */
+ assert(df->df_kind == D_FWFUNCTION);
- df->df_kind = D_FUNCTION;
- CurrVis = df->prc_vis;
+ df->df_kind = D_FUNCTION;
+ CurrVis = df->prc_vis;
- if( tp )
- node_error(nd,
- "\"%s\" already declared",
- nd->nd_IDF->id_text);
+ if (tp)
+ node_error(nd, "\"%s\" already declared", nd->nd_IDF->id_text);
- }
- routine_label(df);
+ }
+ routine_label(df);
}
- else CurrVis = scl; /* simulate open_scope() */
+ else
+ CurrVis = scl; /* simulate open_scope() */
return df;
}
-EndFunc(df)
- register struct def *df;
+void EndFunc(register struct def *df)
{
/* assignment to functionname is illegal outside the functionblock */
df->prc_res = 0;
/* Give the error about assignment as soon as possible. The
* |= assignment inhibits a warning in the main procedure.
*/
- if( !(df->df_flags & D_SET) ) {
- error("function \"%s\" not assigned",df->df_idf->id_text);
+ if (!(df->df_flags & D_SET))
+ {
+ error("function \"%s\" not assigned", df->df_idf->id_text);
df->df_flags |= D_SET;
}
}
-EndBlock(block_df)
- register struct def *block_df;
+void EndBlock(register struct def *block_df)
{
register struct def *tmp_def = CurrentScope->sc_def;
register struct def *df;
- while( tmp_def ) {
- df = tmp_def;
- /* The length of a usd_def chain is at most 1.
+ while (tmp_def)
+ {
+ df = tmp_def;
+ /* The length of a usd_def chain is at most 1.
* The while is just defensive programming.
*/
- while( df->df_kind & D_INUSE )
- df = df->usd_def;
-
- if( !is_anon_idf(df->df_idf)
- && (df->df_scope == CurrentScope) ) {
- if( !(df->df_kind & (D_ENUM|D_LABEL|D_ERROR)) ) {
- if( !(df->df_flags & D_USED) ) {
- if( !(df->df_flags & D_SET) ) {
- warning("\"%s\" neither set nor used in \"%s\"",
- df->df_idf->id_text, block_df->df_idf->id_text);
- }
- else {
- warning("\"%s\" unused in \"%s\"",
- df->df_idf->id_text, block_df->df_idf->id_text);
+ while (df->df_kind & D_INUSE)
+ df = df->usd_def;
+
+ if (!is_anon_idf(df->df_idf) && (df->df_scope == CurrentScope))
+ {
+ if (!(df->df_kind & (D_ENUM | D_LABEL | D_ERROR)))
+ {
+ if (!(df->df_flags & D_USED))
+ {
+ if (!(df->df_flags & D_SET))
+ {
+ warning("\"%s\" neither set nor used in \"%s\"",
+ df->df_idf->id_text, block_df->df_idf->id_text);
+ }
+ else
+ {
+ warning("\"%s\" unused in \"%s\"", df->df_idf->id_text,
+ block_df->df_idf->id_text);
+ }
+ }
+ else if (!(df->df_flags & D_SET))
+ {
+ if (!(df->df_flags & D_LOOPVAR))
+ warning("\"%s\" not set in \"%s\"", df->df_idf->id_text,
+ block_df->df_idf->id_text);
+ }
}
- }
- else if( !(df->df_flags & D_SET) ) {
- if( !(df->df_flags & D_LOOPVAR) )
- warning("\"%s\" not set in \"%s\"",
- df->df_idf->id_text, block_df->df_idf->id_text);
- }
- }
- }
- tmp_def = tmp_def->df_nextinscope;
+ }
+ tmp_def = tmp_def->df_nextinscope;
}
}
/* 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 */
+#ifndef DEF_H_
+#define DEF_H_
+
struct constant {
struct node *co_const; /* result of a constant expression */
#define con_const df_value.df_constant.co_const
*lookfor();
#define NULLDEF ((struct def *) 0)
+
+
+struct def *MkDef(register struct idf *id, register struct scope *scope,
+ long kind);
+struct def *define(register struct idf *id, register struct scope *scope,
+ long kind);
+void DoDirective(struct idf *directive, struct node *nd, struct type *tp,
+ struct scopelist *scl, int function);
+struct def *DeclProc(register struct node *nd, struct type *tp,
+ register struct scopelist *scl);
+struct def *
+DeclFunc(register struct node *nd, struct type *tp,
+ register struct scopelist *scl);
+void EndFunc(register struct def *df);
+void EndBlock(register struct def *block_df);
+
+#endif
#include "node.h"
#include "scope.h"
#include "type.h"
+#include "code.h"
+#include "error.h"
struct desig InitDesig = {DSG_INIT, 0, 0, NULLDEF, 0};
struct withdesig *WithDesigs;
-void CodeValue();
-STATIC int
-properly(ds, size, al)
- register struct desig *ds;
- arith size;
+
+static int properly(register struct desig *ds, arith size, int al)
{
/* Check if it is allowed to load or store the value indicated
by "ds" with LOI/STI.
(! wordmodsz && ds->dsg_offset % size == 0));
}
-CodeCopy(lhs, rhs, sz, psize)
- register struct desig *lhs, *rhs;
- arith sz, *psize;
+void CodeCopy(register struct desig *lhs, register struct desig *rhs, arith sz, arith *psize)
{
struct desig l, r;
C_sti(sz);
}
-void
-CodeMove(rhs, left, rtp)
- register struct desig *rhs;
- register struct node *left;
- struct type *rtp;
+void CodeMove(register struct desig *rhs, register struct node *left, struct type *rtp)
{
struct desig dsl;
register struct desig *lhs = &dsl;
}
}
-void
-CodeValue(ds, tp)
- register struct desig *ds;
- register struct type *tp;
+void CodeValue(register struct desig *ds, register struct type *tp)
{
/* Generate code to load the value of the designator described
in "ds"
ds->dsg_kind = DSG_LOADED;
}
-CodeStore(ds, tp)
- register struct desig *ds;
- register struct type *tp;
+void CodeStore(register struct desig *ds, register struct type *tp)
{
/* Generate code to store the value on the stack in the designator
described in "ds"
ds->dsg_kind = DSG_INIT;
}
-CodeAddress(ds)
- register struct desig *ds;
+void CodeAddress(register struct desig *ds)
{
/* Generate code to load the address of the designator described
in "ds"
ds->dsg_kind = DSG_PLOADED;
}
-CodeFieldDesig(df, ds)
- register struct def *df;
- register struct desig *ds;
+void CodeFieldDesig(register struct def *df, register struct desig *ds)
{
/* Generate code for a field designator. Only the code common for
address as well as value computation is generated, and the
ds->dsg_packed = df->fld_flags & F_PACKED;
}
-void
-CodeVarDesig(df, ds)
- register struct def *df;
- register struct desig *ds;
+void CodeVarDesig(register struct def *df, register struct desig *ds)
{
/* Generate code for a variable represented by a "def" structure.
Of course, there are numerous cases: the variable is local,
ds->dsg_def = df;
}
-CodeBoundDesig(df, ds)
- register struct def *df;
- register struct desig *ds;
+void CodeBoundDesig(register struct def *df, register struct desig *ds)
{
/* Generate code for the lower- and upperbound of a conformant array */
ds->dsg_kind = DSG_LOADED;
}
-CodeFuncDesig(df, ds)
- register struct def *df;
- register struct desig *ds;
+void CodeFuncDesig(register struct def *df, register struct desig *ds)
{
/* generate code to store the function result */
ds->dsg_offset = df->prc_res;
}
-CodeDesig(nd, ds)
- register struct node *nd;
- register struct desig *ds;
+void CodeDesig(register struct node *nd, register struct desig *ds)
{
/* Generate code for a designator. Use divide and conquer
principle
+#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 */
/* Generating code for designators is not particularly easy, especially if
extern struct desig InitDesig;
#define NO_LABEL ((label) 0)
+
+
+
+/* Copies psize bytes from "rhs" to "lhs" */
+void CodeCopy(register struct desig *lhs, register struct desig *rhs, arith sz, arith *psize);
+/* Generate code for an assignment. */
+void CodeMove(register struct desig *rhs, register struct node *left, struct type *rtp);
+/* Generate code to load the value of the designator described
+ in "ds" onto the operand stack. */
+void CodeValue(register struct desig *ds, register struct type *tp);
+/* Generate code to store the value on the stack in the designator
+ described in "ds" */
+void CodeStore(register struct desig *ds, register struct type *tp);
+/* Generate code to load the address of the designator described
+ in "ds" unto the operand stack */
+void CodeAddress(register struct desig *ds);
+/* Generate code for a field designator. */
+void CodeFieldDesig(register struct def *df, register struct desig *ds);
+/* Generate code for a variable represented by a "def" structure.*/
+void CodeVarDesig(register struct def *df, register struct desig *ds);
+/* Generate code for the lower- and upperbound of a conformant array */
+void CodeBoundDesig(register struct def *df, register struct desig *ds);
+/* generate code to store the function result */
+void CodeFuncDesig(register struct def *df, register struct desig *ds);
+/* Generate code for a designator. Use divide and conquer
+ principle */
+void CodeDesig(register struct node *nd, register struct desig *ds);
+
+#endif
#include "node.h"
#include "scope.h"
#include "type.h"
+#include "progs.h"
+#include "enter.h"
+#ifdef DBSYMTAB
+#include "stab.h"
+#endif
+
+extern int proclevel;
+extern int parlevel;
+
-extern int proclevel;
-extern int parlevel;
-struct def *
-Enter(name, kind, type, pnam)
- char *name;
- register struct type *type;
- long kind;
+struct def *Enter(char *name, long kind, register struct 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
- put its number in the definition structure, and mark the
- name as set, to inhibit warnings about used before set.
- */
+ "type" in the Current Scope. If it is a standard name, also
+ put its number in the definition structure, and mark the
+ name as set, to inhibit warnings about used before set.
+ */
register struct def *df;
df = define(str2idf(name, 0), CurrentScope, kind);
df->df_type = type;
- if( pnam ) {
+ if (pnam)
+ {
df->df_value.df_reqname = pnam;
df->df_flags |= D_SET;
}
#ifdef DBSYMTAB
- else if (options['g']) stb_string(df, kind);
+ else if (options['g'])
+ stb_string(df, kind);
#endif /* DBSYMTAB */
return df;
}
-EnterProgList(Idlist)
- register struct node *Idlist;
+void EnterProgList(register struct node *Idlist)
{
register struct node *idlist = Idlist;
register struct def *df;
- for( ; idlist; idlist = idlist->nd_next )
- if ( !strcmp(input, idlist->nd_IDF->id_text)
- ||
- !strcmp(output, idlist->nd_IDF->id_text)
- ) {
+ for (; idlist; idlist = idlist->nd_next)
+ if (!strcmp(input, idlist->nd_IDF->id_text)
+ || !strcmp(output, idlist->nd_IDF->id_text))
+ {
/* the occurence of input or output as program-
* parameter is their declaration as a GLOBAL
* variable of type text
*/
- if( df = define(idlist->nd_IDF, CurrentScope,
- D_VARIABLE) ) {
+ if ( (df = define(idlist->nd_IDF, CurrentScope,
+ D_VARIABLE)) )
+ {
df->df_type = text_type;
df->df_flags |= (D_SET | D_PROGPAR | D_NOREG);
- if( !strcmp(input, idlist->nd_IDF->id_text) ) {
+ if (!strcmp(input, idlist->nd_IDF->id_text))
+ {
df->var_name = input;
set_inp();
}
- else {
+ else
+ {
df->var_name = output;
set_outp();
}
#ifdef DBSYMTAB
- if (options['g']) stb_string(df, D_VARIABLE);
+ if (options['g'])
+ stb_string(df, D_VARIABLE);
#endif /* DBSYMTAB */
}
}
- else {
- if( df = define(idlist->nd_IDF, CurrentScope,
- D_PARAMETER) ) {
+ else
+ {
+ if ( (df = define(idlist->nd_IDF, CurrentScope,
+ D_PARAMETER)) )
+ {
df->df_type = error_type;
df->df_flags |= D_PROGPAR;
df->var_name = idlist->nd_IDF->id_text;
}
}
-
+
FreeNode(Idlist);
}
-EnterEnumList(Idlist, type)
- struct node *Idlist;
- register struct type *type;
+void EnterEnumList(struct node *Idlist, register struct type *type)
{
/* Put a list of enumeration literals in the symbol table.
- They all have type "type". Also assign numbers to them.
- */
+ They all have type "type". Also assign numbers to them.
+ */
register struct def *df, *df1 = 0;
register struct node *idlist = Idlist;
type->enm_ncst = 0;
- for( ; idlist; idlist = idlist->nd_next )
- if( df = define(idlist->nd_IDF, CurrentScope, D_ENUM) ) {
+ for (; idlist; idlist = idlist->nd_next)
+ if ( (df = define(idlist->nd_IDF, CurrentScope, D_ENUM)) )
+ {
df->df_type = type;
df->enm_val = (type->enm_ncst)++;
df->df_flags |= D_SET;
- if (! df1) {
+ if (!df1)
+ {
type->enm_enums = df;
}
- else df1->enm_next = df;
+ else
+ df1->enm_next = df;
df1 = df;
}
FreeNode(Idlist);
}
-EnterFieldList(Idlist, type, scope, addr, packed)
- struct node *Idlist;
- register struct type *type;
- struct scope *scope;
- arith *addr;
- unsigned short packed;
+void EnterFieldList(struct node *Idlist, register struct type *type,
+ struct scope *scope, arith *addr, unsigned short packed)
{
/* Put a list of fields in the symbol table.
- They all have type "type", and are put in scope "scope".
- */
+ They all have type "type", and are put in scope "scope".
+ */
register struct def *df;
register struct node *idlist = Idlist;
- for( ; idlist; idlist = idlist->nd_next )
- if( df = define(idlist->nd_IDF, scope, D_FIELD) ) {
+ for (; idlist; idlist = idlist->nd_next)
+ if ( (df = define(idlist->nd_IDF, scope, D_FIELD)) )
+ {
df->df_type = type;
- if( packed ) {
+ if (packed)
+ {
df->fld_flags |= F_PACKED;
df->fld_off = align(*addr, type->tp_palign);
*addr = df->fld_off + type->tp_psize;
}
- else {
+ else
+ {
df->fld_off = align(*addr, type->tp_align);
*addr = df->fld_off + type->tp_size;
}
FreeNode(Idlist);
}
-EnterVarList(Idlist, type, local)
- struct node *Idlist;
- struct type *type;
+void EnterVarList(struct node *Idlist, struct 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.
- */
+ name list. "type" represents the type of the variables.
+ "local" is set if the variables are declared local to a
+ procedure.
+ */
register struct def *df;
register struct node *idlist = Idlist;
register struct scopelist *sc = CurrVis;
- for( ; idlist; idlist = idlist->nd_next ) {
- if( !(df = define(idlist->nd_IDF, CurrentScope, D_VARIABLE)) )
- continue; /* skip this identifier */
+ for (; idlist; idlist = idlist->nd_next)
+ {
+ if (!(df = define(idlist->nd_IDF, CurrentScope, D_VARIABLE)))
+ continue; /* skip this identifier */
df->df_type = type;
- if( local ) {
+ if (local)
+ {
/* subtract size, which is already aligned, of
* variable to the offset, as the variable list
* exists only local to a procedure
sc->sc_scope->sc_off -= type->tp_size;
df->var_off = sc->sc_scope->sc_off;
}
- else { /* Global name */
+ else
+ { /* Global name */
df->var_name = df->df_idf->id_text;
df->df_flags |= D_NOREG;
}
#ifdef DBSYMTAB
- if (options['g']) stb_string(df, D_VARIABLE);
+ if (options['g'])
+ stb_string(df, D_VARIABLE);
#endif /* DBSYMTAB */
}
FreeNode(Idlist);
}
-arith
-EnterParamList(fpl, parlist)
- register struct node *fpl;
- struct paramlist **parlist;
+
+static void LinkParam(struct paramlist **parlist, struct def *df)
+{
+ static struct paramlist *pr;
+
+ if (!*parlist)
+ *parlist = pr = new_paramlist();
+ else
+ {
+ pr->next = new_paramlist();
+ pr = pr->next;
+ }
+ pr->par_def = df;
+}
+
+
+arith EnterParamList(register struct node *fpl, struct paramlist **parlist)
{
register arith nb_pars = (proclevel > 1) ? pointer_size : 0;
register struct node *id;
struct type *tp;
struct def *df;
- for( ; fpl; fpl = fpl->nd_right ) {
+ for (; fpl; fpl = fpl->nd_right)
+ {
assert(fpl->nd_class == Link);
tp = fpl->nd_type;
- for( id = fpl->nd_left; id; id = id->nd_next )
- if( df = define(id->nd_IDF, CurrentScope, D_VARIABLE) ) {
- df->var_off = nb_pars;
- if( fpl->nd_INT & D_VARPAR || IsConformantArray(tp) )
- nb_pars += pointer_size;
- else
- nb_pars += tp->tp_size;
- LinkParam(parlist, df);
- df->df_type = tp;
- df->df_flags |= fpl->nd_INT;
- }
+ for (id = fpl->nd_left; id; id = id->nd_next)
+ if ( (df = define(id->nd_IDF, CurrentScope, D_VARIABLE)) )
+ {
+ df->var_off = nb_pars;
+ if (fpl->nd_INT & D_VARPAR || IsConformantArray(tp))
+ nb_pars += pointer_size;
+ else
+ nb_pars += tp->tp_size;
+ LinkParam(parlist, df);
+ df->df_type = tp;
+ df->df_flags |= fpl->nd_INT;
+ }
- while( IsConformantArray(tp) ) {
+ while (IsConformantArray(tp))
+ {
/* we need room for the descriptors */
tp->arr_sclevel = CurrentScope->sc_level;
tp->arr_cfdescr = nb_pars;
nb_pars += 3 * word_size;
tp = tp->arr_elem;
- }
+ }
}
return nb_pars;
}
-arith
-EnterParTypes(fpl, parlist)
- register struct node *fpl;
- struct paramlist **parlist;
+arith EnterParTypes(register struct node *fpl, struct paramlist **parlist)
{
/* parameters.h in heading of procedural and functional
- parameters (only types are important, not the names).
- */
+ parameters (only types are important, not the names).
+ */
register arith nb_pars = 0;
register struct node *id;
struct type *tp;
struct def *df;
- for( ; fpl; fpl = fpl->nd_right ) {
+ for (; fpl; fpl = fpl->nd_right)
+ {
tp = fpl->nd_type;
- for( id = fpl->nd_left; id; id = id->nd_next )
- if( df = new_def() ) {
- if( fpl->nd_INT & D_VARPAR ||
- IsConformantArray(tp) )
+ for (id = fpl->nd_left; id; id = id->nd_next)
+ if ( (df = new_def()) )
+ {
+ if (fpl->nd_INT & D_VARPAR || IsConformantArray(tp))
nb_pars += pointer_size;
else
nb_pars += tp->tp_size;
df->df_type = tp;
df->df_flags |= fpl->nd_INT;
}
- while( IsConformantArray(tp) ) {
+ while (IsConformantArray(tp))
+ {
nb_pars += 3 * word_size;
tp = tp->arr_elem;
}
return nb_pars;
}
-LinkParam(parlist, df)
- struct paramlist **parlist;
- struct def *df;
-{
- static struct paramlist *pr;
-
- if( !*parlist )
- *parlist = pr = new_paramlist();
- else {
- pr->next = new_paramlist();
- pr = pr->next;
- }
- pr->par_def = df;
-}
--- /dev/null
+/* Copyright (c) 2019 ACK Project.
+ * See the copyright notice in the ACK home directory,
+ * in the file "Copyright".
+ *
+ */
+#ifndef ENTER_H_
+#define ENTER_H_
+
+#include "em_arith.h"
+
+/* Forward structure declarations. */
+struct type;
+struct node;
+struct paramlist;
+
+
+struct def *Enter(char *name, long kind, register struct type *type, int pnam);
+void EnterProgList(register struct node *Idlist);
+void EnterEnumList(struct node *Idlist, register struct type *type);
+void EnterFieldList(struct node *Idlist, register struct type *type,
+ struct scope *scope, arith *addr, unsigned short packed);
+void EnterVarList(struct node *Idlist, struct type *type, int local);
+arith EnterParamList(register struct node *fpl, struct paramlist **parlist);
+arith EnterParTypes(register struct node *fpl, struct paramlist **parlist);
+
+#endif /* ENTER_H_ */
#include <em_arith.h>
#include <em_label.h>
#include <em_code.h>
-#include <system.h>
+#include <stdlib.h>
+#include <stdio.h>
+#include "print.h"
+#include "system.h"
#include "LLlex.h"
#include "f_info.h"
int err_occurred;
-extern char *symbol2str();
-
-void _error();
+static void _error(int, struct node *, char *, register va_list);
/* There are three general error-message functions:
lexerror() lexical and pre-processor error messages
#if __STDC__
#ifdef DEBUG
/*VARARGS*/
-debug(char *fmt, ...)
+void debug(char *fmt, ...)
{
va_list ap;
#endif /* DEBUG */
/*VARARGS*/
-error(char *fmt, ...)
+void error(char *fmt, ...)
{
va_list ap;
}
/*VARARGS*/
-node_error(struct node *node, char *fmt, ...)
+void node_error(struct node *node, char *fmt, ...)
{
va_list ap;
}
/*VARARGS*/
-warning(char *fmt, ...)
+void warning(char *fmt, ...)
{
va_list ap;
}
/*VARARGS*/
-node_warning(struct node *node, char *fmt, ...)
+void node_warning(struct node *node, char *fmt, ...)
{
va_list ap;
}
/*VARARGS*/
-lexerror(char *fmt, ...)
+void lexerror(char *fmt, ...)
{
va_list ap;
}
/*VARARGS*/
-lexwarning(char *fmt, ...)
+void lexwarning(char *fmt, ...)
{
va_list ap;
}
/*VARARGS*/
-fatal(char *fmt, ...)
+void fatal(char *fmt, ...)
{
va_list ap;
_error(FATAL, NULLNODE, fmt, ap);
}
va_end(ap);
- sys_stop(S_EXIT);
+ exit(EXIT_FAILURE);
}
/*VARARGS*/
-crash(char *fmt, ...)
+void crash(char *fmt, ...)
{
va_list ap;
}
va_end(ap);
#ifdef DEBUG
- sys_stop(S_ABORT);
+ abort();
#else
- sys_stop(S_EXIT);
+ exit(EXIT_FAILURE);
#endif
}
#else
#ifdef DEBUG
/*VARARGS*/
-debug(va_alist)
+void debug(va_alist)
va_dcl
{
va_list ap;
#endif /* DEBUG */
/*VARARGS*/
-error(va_alist)
+void error(va_alist)
va_dcl
{
va_list ap;
}
/*VARARGS*/
-node_error(va_alist)
+void node_error(va_alist)
va_dcl
{
va_list ap;
}
/*VARARGS*/
-warning(va_alist)
+void warning(va_alist)
va_dcl
{
va_list ap;
}
/*VARARGS*/
-node_warning(va_alist)
+void node_warning(va_alist)
va_dcl
{
va_list ap;
}
/*VARARGS*/
-lexerror(va_alist)
+void lexerror(va_alist)
va_dcl
{
va_list ap;
}
/*VARARGS*/
-lexwarning(va_alist)
+void lexwarning(va_alist)
va_dcl
{
va_list ap;
}
/*VARARGS*/
-fatal(va_alist)
+void fatal(va_alist)
va_dcl
{
va_list ap;
_error(FATAL, NULLNODE, fmt, ap);
}
va_end(ap);
- sys_stop(S_EXIT);
+ exit(EXIT_FAILURE);
}
/*VARARGS*/
-crash(va_alist)
+void crash(va_alist)
va_dcl
{
va_list ap;
}
va_end(ap);
#ifdef DEBUG
- sys_stop(S_ABORT);
+ abort();
#else
- sys_stop(S_EXIT);
+ exit(EXIT_FAILURE);
#endif
}
#endif
-void
-_error(class, node, fmt, ap)
- int class;
- struct node *node;
- char *fmt;
- register va_list ap;
+static void _error(int class, struct node *node, char *fmt, register va_list ap)
{
/* _error attempts to limit the number of error messages
for a given line to MAXERR_LINE.
--- /dev/null
+/* Copyright (c) 2019 ACK Project.
+ * See the copyright notice in the ACK home directory,
+ * in the file "Copyright".
+ *
+ */
+#ifndef ERROR_H_
+#define ERROR_H_
+
+/* Forward struct declarations */
+struct node;
+
+#ifdef DEBUG
+void debug(char *fmt, ...);
+#endif /* DEBUG */
+
+void error(char *fmt, ...);
+void node_error(struct node *node, char *fmt, ...);
+void warning(char *fmt, ...);
+void node_warning(struct node *node, char *fmt, ...);
+void lexerror(char *fmt, ...);
+void lexwarning(char *fmt, ...);
+void fatal(char *fmt, ...);
+void crash(char *fmt, ...);
+
+#endif /* ERROR_H_ */
#include "node.h"
#include "scope.h"
#include "type.h"
+#include "code.h"
+#include "error.h"
}
Constant(register struct node **pnd;)
/* U S E R D E C L A R E D P A R T O F I D F */
+#ifndef IDF_H_
+#define IDF_H_
struct id_u {
int id_res;
#define id_def id_user.id_df
#include <idf_pkg.spec>
+
+#endif
#include <inp_pkg.body>
-AtEoIF()
+int AtEoIF(void)
{
/* Make the unstacking of input streams noticable to the
lexical analyzer
*/
return 1;
}
+
+int
+AtEoIT(void)
+{
+ return 0;
+}
#include "node.h"
#include "scope.h"
#include "type.h"
+#include "label.h"
+#include "error.h"
-void CodeLabel();
+static void CodeLabel(register struct def *df, int local);
-DeclLabel(nd)
- struct node *nd;
+void DeclLabel(struct node *nd)
{
struct def *df;
}
}
-chk_labels(Slevel)
+void chk_labels(int Slevel)
{
register struct node *labnd = BlockScope->sc_lablist;
register struct def *df;
}
}
-TstLabel(nd, Slevel)
- register struct node *nd;
+void TstLabel(register struct node *nd, int Slevel)
{
register struct def *df;
CodeLabel(df, 1);
}
-void
-DefLabel(nd, Slevel)
- register struct node *nd;
+void DefLabel(register struct node *nd, int Slevel)
{
register struct def *df;
}
}
-void
-CodeLabel(df, local)
- register struct def *df;
+static void CodeLabel(register struct def *df, int local)
{
if( err_occurred ) return;
--- /dev/null
+/* Copyright (c) 2019 ACK Project.
+ * See the copyright notice in the ACK home directory,
+ * in the file "Copyright".
+ *
+ */
+#ifndef LABEL_H_
+#define LABEL_H_
+
+struct node;
+
+void DeclLabel(struct node *nd);
+void chk_labels(int Slevel);
+void TstLabel(register struct node *nd, int Slevel);
+void DefLabel(register struct node *nd, int Slevel);
+
+
+#endif /* LABEL_H_ */
#include "node.h"
#include "scope.h"
#include "type.h"
+#include "lookup.h"
-remove_def(df)
- register struct def *df;
+void remove_def(register struct def *df)
{
struct idf *id= df->df_idf;
struct def *df1 = id->id_def;
free_def(df);
}
-struct def *
-lookup(id, scope, inuse)
- register struct idf *id;
- struct scope *scope;
- long inuse;
+struct def *lookup(register struct idf *id, struct scope *scope, long inuse)
{
- /* Look up a definition of an identifier in scope "scope".
- Make the "def" list self-organizing.
- Return a pointer to its "def" structure if it exists,
- otherwise return 0.
- */
+
register struct def *df, *df1;
/* Look in the chain of definitions of this "id" for one with scope
return df;
}
-struct def *
-lookfor(id, vis, give_error)
- register struct node *id;
- struct scopelist *vis;
+
+struct def *lookfor(register struct node *id, struct scopelist *vis, int give_error)
{
- /* Look for an identifier in the visibility range started by "vis".
- If it is not defined create a dummy definition and
- if give_error is set, give an error message.
- */
+
register struct def *df, *tmp_df;
register struct scopelist *sc = vis;
if( df ) {
while( vis->sc_scope->sc_level >
sc->sc_scope->sc_level ) {
- if( tmp_df = define(id->nd_IDF, vis->sc_scope,
- D_INUSE))
+ if( (tmp_df = define(id->nd_IDF, vis->sc_scope,
+ D_INUSE)) )
tmp_df->usd_def = df;
vis = nextvisible(vis);
}
*/
if( (vis->sc_scope == GlobalScope) &&
!lookup(id->nd_IDF, GlobalScope, D_INUSE) ) {
- if( tmp_df = define(id->nd_IDF, vis->sc_scope,
- D_INUSE))
+ if( (tmp_df = define(id->nd_IDF, vis->sc_scope,
+ D_INUSE)) )
tmp_df->usd_def = df;
}
--- /dev/null
+/* Copyright (c) 2019 ACK Project.
+ * See the copyright notice in the ACK home directory,
+ * in the file "Copyright".
+ *
+ */
+#ifndef LOOKUP_H_
+#define LOOKUP_H_
+
+struct def;
+struct idf;
+struct scope;
+struct node;
+
+void remove_def(register struct def *df);
+
+/* Look up a definition of an identifier in scope "scope".
+ Make the "def" list self-organizing.
+ Return a pointer to its "def" structure if it exists,
+ otherwise return NULL.
+*/
+struct def *lookup(register struct idf *id, struct scope *scope, long inuse);
+
+/* Look for an identifier in the visibility range started by "vis".
+ If it is not defined create a dummy definition and
+ if give_error is set, give an error message.
+*/
+struct def *lookfor(register struct node *id, struct scopelist *vis, int give_error);
+
+#endif /* LOOKUP_H_ */
#include <system.h>
#include <stb.h>
+#include "print.h"
#include "LLlex.h"
#include "Lpars.h"
#include "class.h"
#include "tokenname.h"
#include "type.h"
#include "scope.h"
+#include "cstoper.h"
+#include "stab.h"
+#include "options.h"
+#include "error.h"
char options[128];
char *ProgName;
struct def *program;
extern int fp_used; /* set if floating point used */
+extern void LLparse(void);
-main(argc, argv)
- register char **argv;
+int Compile(char *src, char *dst);
+void AddRequired(void);
+#ifdef DEBUG
+void LexScan(void);
+void Info(void);
+#endif
+
+int main(int argc, register char **argv)
{
register int Nargc = 1;
register char **Nargv = &argv[0];
Nargv[Nargc] = 0; /* terminate the arg vector */
if( Nargc < 2 ) {
fprint(STDERR, "%s: Use a file argument\n", ProgName);
- sys_stop(S_EXIT);
+ return EXIT_FAILURE;
}
- if(!Compile(Nargv[1], Nargv[2])) sys_stop(S_EXIT);
- sys_stop(S_END);
+ if(!Compile(Nargv[1], Nargv[2]))
+ return EXIT_FAILURE;
+ return EXIT_SUCCESS;
}
-Compile(src, dst)
- char *src, *dst;
+int Compile(char *src, char *dst)
{
extern struct tokenname tkidf[];
extern struct tokenname tkstandard[];
}
#ifdef DEBUG
-LexScan()
+void LexScan(void)
{
register struct token *tkp = ˙
- extern char *symbol2str();
+
while( LLlex() > 0 ) {
print(">>> %s ", symbol2str(tkp->tk_symb));
}
#endif
-AddRequired()
+void AddRequired(void)
{
register struct def *df;
extern struct def *Enter();
#ifdef DEBUG
int cntlines;
-Info()
+void Info(void)
{
extern int cnt_def, cnt_node, cnt_paramlist, cnt_type, cnt_scope,
cnt_scopelist, cnt_tmpvar, cnt_withdesig,
#include "main.h"
#include "misc.h"
#include "node.h"
+#include "print.h"
+#include "error.h"
-struct idf *
-gen_anon_idf()
+struct idf *gen_anon_idf(void)
{
/* A new idf is created out of nowhere, to serve as an
anonymous name.
*/
static int name_cnt;
char *s = Malloc(strlen(FileName) + 50);
- char *sprint();
sprint(s, "#%d in %s, line %u", ++name_cnt, FileName, LineNumber);
s = Realloc(s, strlen(s)+1);
return str2idf(s, 0);
}
-not_declared(what, id, where)
- char *what, *where;
- register struct node *id;
+void not_declared(char *what, register struct node *id, char *where)
{
/* The identifier "id" is not declared. If it is not generated,
give an error message
}
}
-char *
-gen_proc_name(id, inp)
- register struct idf *id;
+char *gen_proc_name(register struct idf *id, int inp)
{
/* generate pseudo and internal name for procedure or function */
static int name_cnt;
static char buf[256];
- char *sprint(), *Salloc();
+
if( inp ) {
sprint(buf, "_%d%s", ++name_cnt, id->id_text);
/* M I S C E L L A N E O U S */
+struct node;
+
#define is_anon_idf(x) ((x)->id_text[0] == '#')
#define id_not_declared(x) (not_declared("identifier", (x), ""))
extern char
*gen_proc_name();
+void not_declared(char *what, register struct node *id, char *where);
+
extern char *symbol2str();
-extern arith NewInt();
-extern arith NewPtr();
-extern arith CodeBeginBlock();
-extern arith EnterParamList();
-extern arith EnterParTypes();
-extern arith CodeInitFor();
-extern arith IsString();
+
--- /dev/null
+#include "parameters.h"
+#include "debug.h"
#include <alloc.h>
#include <em_arith.h>
#include <em_label.h>
-#include <system.h>
+#include "print.h"
#include "LLlex.h"
#include "node.h"
#include "type.h"
+#include "error.h"
-struct node *
-MkNode(class, left, right, token)
- struct node *left, *right;
- struct token *token;
+struct node *MkNode(int class, struct node *left, struct node *right, struct token *token)
{
/* Create a node and initialize it with the given parameters
*/
return nd;
}
-struct node *
-MkLeaf(class, token)
- struct token *token;
+struct node *MkLeaf(int class, struct token *token)
{
register struct node *nd = new_node();
return nd;
}
-void
-FreeNode(nd)
- register struct node *nd;
+void FreeNode(register struct node *nd)
{
/* Put nodes that are no longer needed back onto the free list
*/
free_node(nd);
}
-NodeCrash(expp)
- struct node *expp;
+int NodeCrash(struct node *expp)
{
crash("Illegal node %d", expp->nd_class);
}
extern char *symbol2str();
-indnt(lvl)
+void indnt(int lvl)
{
while( lvl-- )
print(" ");
}
-printnode(nd, lvl)
- register struct node *nd;
+void printnode(register struct node *nd, int lvl)
{
indnt(lvl);
print("Class: %d; Symbol: %s\n", nd->nd_class, symbol2str(nd->nd_symb));
}
}
-PrNode(nd, lvl)
- register struct node *nd;
+void PrNode(register struct node *nd, int lvl)
{
if( !nd ) {
indnt(lvl); print("<nilnode>\n");
/* N O D E O F A N A B S T R A C T P A R S E T R E E */
+#ifndef NODE_H_
+#define NODE_H_
+
struct node {
struct node *nd_left;
#define nd_REL nd_token.TOK_REL
#define nd_RLA nd_token.TOK_RLA
#define nd_RIV nd_token.TOK_RIV
+
+
+
};
/* ALLOCDEF "node" 50 */
-extern struct node *MkNode(), *MkLeaf(), *ChkStdInOut();
+struct node *MkNode(int class, struct node *left, struct node *right, struct token *token);
+struct node *MkLeaf(int class, struct token *token);
+void FreeNode(register struct node *nd);
+int NodeCrash(struct node *expp);
+
+
#define IsProcCall(lnd) ((lnd)->nd_type->tp_fund & T_ROUTINE)
#define NULLNODE ((struct node *) 0)
+
+#endif
#include "class.h"
#include "const.h"
#include "main.h"
+#include "LLlex.h"
+#include "node.h"
#include "type.h"
+#include "options.h"
+#include "error.h"
+
#define MINIDFSIZE 9
extern int idfsize;
-DoOption(text)
- register char *text;
+
+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;
+}
+
+void DoOption(register char *text)
{
switch( *text++ ) {
default:
- options[text[-1]]++; /* flags, debug options etc. */
+ options[(int)text[-1]]++; /* flags, debug options etc. */
break;
/* recognized flags:
-i: largest value of set of integer
break;
}
- /* case 'u': /* underscore allowed in identifiers */
- /* class('_') = STIDF;
- /* inidf['_'] = 1;
- /* break;
- */
+ /* case 'u': *//* underscore allowed in identifiers */
+ /* class('_') = STIDF;*/
+ /* inidf['_'] = 1;*/
+ /* break;*/
+
case 'V' : { /* set object sizes and alignment requirements */
/* syntax : -V[ [w|i|l|f|p] size? [.alignment]? ]* */
register int align;
char c, *t;
- while( c = *text++ ) {
+ while( (c = *text++) !=0 ) {
char *strchr();
t = text;
}
}
-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;
-}
+
--- /dev/null
+/* Copyright (c) 2019 ACK Project.
+ * See the copyright notice in the ACK home directory,
+ * in the file "Copyright".
+ *
+ */
+#ifndef OPTIONS_H_
+#define OPTIONS_H_
+
+/* Parse command line options */
+void DoOption(register char *text);
+
+#endif /* OPTIONS_H_ */
#include "main.h"
#include "node.h"
#include "scope.h"
+#include "enter.h"
+#include "progs.h"
+#ifdef DBSYMTAB
+#include "stab.h"
+#endif
}
%lexical LLlex;
#include <em.h>
#include <assert.h>
+#include "progs.h"
#include "LLlex.h"
#include "def.h"
#include "main.h"
static int outpflag = 0; /* output mentioned in heading ? */
static label extfl_label; /* label of array of file pointers */
-void make_extfl_args();
+static void make_extfl_args();
-set_inp()
+void set_inp(void)
{
inpflag = 1;
}
-set_outp()
+void set_outp(void)
{
outpflag = 1;
}
-void
-make_extfl()
+void make_extfl(void)
{
if( err_occurred ) return;
make_extfl_args( GlobalScope->sc_def );
}
-void
-make_extfl_args(df)
- register struct def *df;
+static void make_extfl_args(register struct def *df)
{
if( !df ) return;
make_extfl_args(df->df_nextinscope);
}
}
-call_ini()
+void call_ini(void)
{
C_lxl((arith) 0);
if( extflc )
--- /dev/null
+/* Copyright (c) 2019 ACK Project.
+ * See the copyright notice in the ACK home directory,
+ * in the file "Copyright".
+ *
+ * Created on: 2019-02-23
+ *
+ */
+#ifndef PROGS_H_
+#define PROGS_H_
+
+void set_inp(void);
+void set_outp(void);
+void make_extfl(void);
+
+#endif /* PROGS_H_ */
#include <assert.h>
#include <em.h>
+#include "print.h"
#include "LLlex.h"
#include "def.h"
#include "main.h"
#include "node.h"
#include "scope.h"
#include "type.h"
+#include "code.h"
+#include "chk_expr.h"
+#include "typequiv.h"
+#include "error.h"
+#include "readwrite.h"
+
/* DEBUG */
#include "idf.h"
-extern char *sprint();
-void CodeRead();
-void CodeReadln();
-void CodeWrite();
-void CodeWriteln();
-void
-ChkRead(arg)
- register struct node *arg;
+
+/* Internal function prototypes */
+static int ChkWriteParameter(struct type *, struct node *, char *);
+static void CodeRead(register struct node *, register struct node *);
+static void CodeRead(register struct node *, register struct node *);
+static void CodeReadln(struct node *);
+static void CodeWrite(register struct node *, register struct node *);
+static void CodeWriteln(register struct node *);
+
+void ChkRead(register struct node *arg)
{
struct node *file;
char *name = "read";
char *message, buff[80];
- extern char *ChkAllowedVar();
+
assert(arg);
assert(arg->nd_symb == ',');
}
}
-void
-ChkReadln(arg)
- register struct node *arg;
+void ChkReadln(register struct node *arg)
{
struct node *file;
char *name = "readln";
char *message, buff[80];
- extern char *ChkAllowedVar();
+
if( !arg ) {
if( !(file = ChkStdInOut(name, 0)) )
CodeReadln(file);
}
-void
-ChkWrite(arg)
- register struct node *arg;
+void ChkWrite(register struct node *arg)
{
struct node *left, *expp, *file;
char *name = "write";
}
}
-void
-ChkWriteln(arg)
- register struct node *arg;
+void ChkWriteln(register struct node *arg)
{
struct node *left, *expp, *file;
char *name = "writeln";
CodeWriteln(file);
}
-ChkWriteParameter(filetype, arg, name)
- struct type *filetype;
- struct node *arg;
- char *name;
+static int ChkWriteParameter(struct type *filetype, struct node *arg, char *name)
{
struct type *tp;
char *mess = "illegal write parameter";
/* Here we have a text-file */
- if( arg = arg->nd_right ) {
+ if( (arg = arg->nd_right) !=0 ) {
/* Total width */
assert(arg->nd_symb == ':');
else
return 1;
- if( arg = arg->nd_right ) {
+ if( (arg = arg->nd_right)!=0 ) {
/* Fractional Part */
assert(arg->nd_symb == ':');
return 1;
}
-struct node *
-ChkStdInOut(name, st_out)
- char *name;
+struct node *ChkStdInOut(char *name, int st_out)
{
register struct def *df;
register struct node *nd;
return nd;
}
-void
-CodeRead(file, arg)
- register struct node *file, *arg;
+static void CodeRead(register struct node *file, register struct node *arg)
{
struct type *tp = BaseType(arg->nd_type);
}
}
-void
-CodeReadln(file)
- struct node *file;
+static void CodeReadln(struct node *file)
{
if( err_occurred ) return;
C_asp(pointer_size);
}
-void
-CodeWrite(file, arg)
- register struct node *file, *arg;
+static void CodeWrite(register struct node *file, register struct node *arg)
{
int width = 0;
register arith nbpars = pointer_size;
}
}
-void
-CodeWriteln(file)
- register struct node *file;
+static void CodeWriteln(register struct node *file)
{
if( err_occurred ) return;
--- /dev/null
+/* Copyright (c) 2019 ACK Project.
+ * See the copyright notice in the ACK home directory,
+ * in the file "Copyright".
+ *
+ */
+#ifndef READWRITE_H_
+#define READWRITE_H_
+
+/* Forward structure declarations */
+struct node;
+
+struct node *ChkStdInOut(char *name, int st_out);
+void ChkRead(register struct node *arg);
+void ChkReadln(register struct node *arg);
+void ChkWrite(register struct node *arg);
+void ChkWriteln(register struct node *arg);
+
+#endif /* READWRITE_H_ */
#include "node.h"
#include "scope.h"
#include "type.h"
+#include "lookup.h"
+#include "error.h"
struct scope *GlobalScope, *PervasiveScope, *BlockScope;
struct scopelist *CurrVis;
extern int proclevel; /* declared in declar.g */
static int sccount;
-InitScope()
+void InitScope(void)
{
register struct scope *sc = new_scope();
register struct scopelist *ls = new_scopelist();
CurrVis = ls;
}
-open_scope()
+void open_scope(void)
{
register struct scope *sc = new_scope();
register struct scopelist *ls = new_scopelist();
CurrVis = ls;
}
-close_scope(doclean)
+void close_scope(int doclean)
{
/* When this procedure is called, the next visible scope is equal to
the statically enclosing scope
CurrVis = CurrVis->next;
}
-Forward(nd, tp)
- register struct node *nd;
- register struct type *tp;
+void Forward(register struct node *nd, register struct type *tp)
{
/* Enter a forward reference into the current scope. This is
* used in pointertypes.
fw_type->f_type = tp;
}
-chk_prog_params()
+void chk_prog_params(void)
{
/* the program parameters must be global variables of some file type */
register struct def *df = CurrentScope->sc_def;
}
}
-chk_directives()
+void chk_directives(void)
{
/* check if all forward declarations are defined */
register struct def *df = CurrentScope->sc_def;
/* S C O P E M E C H A N I S M */
+#ifndef SCOPE_H_
+#define SCOPE_H_
struct scope {
struct scope *next;
#define CurrentScope (CurrVis->sc_scope)
#define nextvisible(x) ((x)->next) /* use with scopelists */
+
+
+void InitScope(void);
+void open_scope(void);
+void close_scope(int doclean);
+void Forward(register struct node *nd, register struct type *tp);
+void chk_prog_params(void);
+void chk_directives(void);
+
+
+#endif
char *currpos;
} db_str;
-static
-create_db_str()
+static void create_db_str(void)
{
if (! db_str.base) {
db_str.base = Malloc(INCR_SIZE);
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) {
*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 struct type *tp;
+static void stb_type(register struct type *tp, int assign_num)
{
char buf[128];
static int stb_count;
}
}
-stb_addtp(s, tp)
- char *s;
- struct type *tp;
+void stb_addtp(char *s, struct type *tp)
{
create_db_str();
adds_db_str(s);
(arith) 0);
}
-void
-stb_string(df, kind)
- register struct def *df;
- long kind;
+void stb_string(register struct def *df, long kind)
{
register struct type *tp = df->df_type;
char buf[64];
--- /dev/null
+/* Copyright (c) 2019 ACK Project.
+ * See the copyright notice in the ACK home directory,
+ * in the file "Copyright".
+ *
+ * Created on: 2019-02-22
+ *
+ */
+#ifndef STAB_H_
+#define STAB_H_
+
+struct def;
+struct type;
+
+void stb_string(register struct def *df, long kind);
+void stb_addtp(char *s, struct type *tp);
+
+#endif /* STAB_H_ */
#include "node.h"
#include "scope.h"
#include "type.h"
+#include "body.h"
+#include "code.h"
+#include "error.h"
+#include "readwrite.h"
+#include "casestat.h"
+#include "tmpvar.h"
+#include "label.h"
int slevel = 0; /* nesting level of statements */
}
--- /dev/null
+/* Copyright (c) 2019 ACK Project.
+ * See the copyright notice in the ACK home directory,
+ * in the file "Copyright".
+ *
+ */
+#ifndef TMPVAR_H_
+#define TMPVAR_H_
+
+#include "em_arith.h"
+
+
+struct scope;
+
+void TmpOpen(struct scope *sc);
+arith TmpSpace(arith sz, int al);
+arith NewInt(int reg_prior);
+arith NewPtr(int reg_prior);
+void FreeInt(arith off);
+void FreePtr(arith off);
+void TmpClose(void);
+
+
+#endif /* TMPVAR_H_ */
#include <em_arith.h>
#include <em_label.h>
#include <em_reg.h>
+#include <em_code.h>
#include "def.h"
#include "main.h"
temporaries are allocated
*/
-TmpOpen(sc)
- struct scope *sc;
+void TmpOpen(struct scope *sc)
{
/* Initialize for temporaries in scope "sc".
*/
ProcScope = sc;
}
-arith
-TmpSpace(sz, al)
- arith sz;
+arith TmpSpace(arith sz, int al)
{
register struct scope *sc = ProcScope;
return sc->sc_off;
}
-STATIC arith
-NewTmp(plist, sz, al, regtype, priority)
- struct tmpvar **plist;
- arith sz;
+static arith NewTmp(struct tmpvar **plist, arith sz, int al, int regtype, int priority)
{
register arith offset;
register struct tmpvar *tmp;
return offset;
}
-arith
-NewInt(reg_prior)
+arith NewInt(int reg_prior)
{
return NewTmp(&TmpInts, int_size, int_align, reg_any, reg_prior);
}
-arith
-NewPtr(reg_prior)
+arith NewPtr(int reg_prior)
{
return NewTmp(&TmpPtrs, pointer_size, pointer_align, reg_pointer, reg_prior);
}
-STATIC
-FreeTmp(plist, off)
- struct tmpvar **plist;
- arith off;
+static void FreeTmp(struct tmpvar **plist, arith off)
{
register struct tmpvar *tmp = new_tmpvar();
*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;
#include "parameters.h"
#include "Lpars.h"
+#include "LLlex.h"
#include "idf.h"
#include "tokenname.h"
+#include "error.h"
/* To centralize the declaration of %tokens, their presence in this
file is taken as their declaration. The Makefile will produce
/* 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.
int tn_symbol;
char *tn_name;
};
+
+
+void reserve(register struct tokenname *resv);
#include "LLlex.h"
#include "const.h"
+#include "chk_expr.h"
#include "def.h"
#include "idf.h"
#include "main.h"
#include "node.h"
#include "scope.h"
+#include "lookup.h"
#include "type.h"
+#include "typequiv.h"
+#include "error.h"
+#ifdef DBSYMTAB
+#include "stab.h"
+#endif
#ifndef NOCROSS
int
*void_type,
*error_type;
-void ArraySizes();
-CheckTypeSizes()
+/* Local forward declarations */
+static arith ArrayElSize(register struct type *, int);
+static void FreeForward(register struct forwtype *);
+static int gcd(int, int);
+
+
+
+static void CheckTypeSizes(void)
{
/* first, do some checking
*/
fatal("illegal realsize");
}
-InitTypes()
+void InitTypes(void)
{
/* First check the sizes of some basic EM-types
*/
emptyset_type->tp_align = word_align;
}
-int
-fit(sz, nbytes)
- arith sz;
+static int fit(arith sz, int nbytes)
{
return ((sz) + ((arith)0x80<<(((nbytes)-1)*8)) & ~full_mask[(nbytes)]) == 0;
}
-struct type *
-standard_type(fund, algn, size)
- arith size;
+struct type *standard_type(int fund, int algn, arith size)
{
register struct type *tp = new_type();
return tp;
}
-struct type *
-construct_type(fund, tp)
- register struct type *tp;
+struct type *construct_type(int fund, register struct type *tp)
{
/* fund must be a type constructor.
* The pointer to the constructed type is returned.
return dtp;
}
-struct type *
-proc_type(parameters, n_bytes_params)
- struct paramlist *parameters;
- arith n_bytes_params;
+struct type *proc_type(struct paramlist *parameters, arith n_bytes_params)
{
register struct type *tp = construct_type(T_PROCEDURE, NULLTYPE);
return tp;
}
-struct type *
-func_type(parameters, n_bytes_params, resulttype)
- struct paramlist *parameters;
- arith n_bytes_params;
- struct type *resulttype;
+struct type *func_type(struct paramlist * parameters, arith n_bytes_params, struct type *resulttype)
{
register struct type *tp = construct_type(T_FUNCTION, resulttype);
return tp;
}
-chk_type_id(ptp, nd)
- register struct type **ptp;
- register struct node *nd;
+void chk_type_id(register struct type **ptp, register struct node *nd)
{
register struct def *df;
}
}
-struct type *
-subr_type(lb, ub)
- register struct node *lb, *ub;
+struct type *subr_type(register struct node *lb, register struct node *ub)
{
/* Construct a subrange type from the constant expressions
indicated by "lb" and "ub", but first perform some checks
return res;
}
-getbounds(tp, plo, phi)
- register struct type *tp;
- arith *plo, *phi;
+void getbounds(register struct type *tp, arith *plo, arith *phi)
{
/* Get the bounds of a bounded type
*/
}
}
-struct type *
-set_type(tp, packed)
- register struct type *tp;
- unsigned short packed;
+struct type *set_type(register struct type *tp, unsigned short packed)
{
/* Construct a set type with base type "tp", but first
perform some checks
return tp;
}
-arith
-ArrayElSize(tp, packed)
- register struct type *tp;
+static arith ArrayElSize(register struct type *tp, int packed)
{
/* Align element size to alignment requirement of element type.
Also make sure that its size is either a dividor of the word_size,
return algn;
}
-void
-ArraySizes(tp)
- register struct type *tp;
+void ArraySizes(register struct type *tp)
{
/* Assign sizes to an array type, and check index type
*/
C_rom_cst(tp->arr_elsize);
}
-void
-FreeForward(for_type)
- register struct forwtype *for_type;
+static void FreeForward(register struct forwtype *for_type)
{
if( !for_type ) return;
free_forwtype(for_type);
}
-chk_forw_types()
+void chk_forw_types(void)
{
/* check all forward references (in pointer types) */
}
}
-TstCaseConstants(nd, sel, sel1)
- register struct node *nd;
- register struct selector *sel, *sel1;
+void TstCaseConstants(register struct node *nd, register struct selector *sel,
+ register struct selector *sel1)
{
/* Insert selector of nested variant (sel1) in tagvalue-table of
current selector (sel).
}
}
-arith
-align(pos, al)
- arith pos;
- int al;
+arith align(arith pos, int al)
{
arith i;
return pos + ((i = pos % al) ? al - i : 0);
}
-int
-gcd(m, n)
- register int m, n;
+static int gcd(int m, int n)
{
/* Greatest Common Divisor
*/
return m;
}
-int
-lcm(m, n)
- int m, n;
+int lcm(int m, int n)
{
/* Least Common Multiple
*/
}
#ifdef DEBUG
-DumpType(tp)
- register struct type *tp;
+void DumpType(register struct type *tp)
{
if( !tp ) return;
/* T Y P E D E S C R I P T O R S T R U C T U R E */
+#ifndef TYPE_H_
+#define TYPE_H_
+
+
struct paramlist { /* structure for parameterlist of a PROCEDURE */
struct paramlist *next;
real_size; /* All from type.c */
#endif /* NOCROSS */
-extern arith
- align();
-
-struct type
- *construct_type(),
- *standard_type(),
- *proc_type(),
- *func_type(),
- *set_type(),
- *subr_type(); /* All from type.c */
#define NULLTYPE ((struct type *) 0)
extern long full_mask[];
#define ufit(n, i) (((n) & ~full_mask[(i)]) == 0)
+
+struct node;
+
+/* Initialize internal types */
+void InitTypes(void);
+/* Construct a standard type with specified size in bytes
+ and specified alignment. */
+struct type *standard_type(int fund, int algn, arith size);
+/* Construct a user defined type. */
+struct type *construct_type(int fund, register struct type *tp);
+/* Constructs a new procedure type with the specified parameters. */
+struct type *proc_type(struct paramlist *parameters, arith n_bytes_params);
+/* Constructs a new function type with the specified parameters and result type. */
+struct type *func_type(struct paramlist * parameters, arith n_bytes_params, struct type *resulttype);
+void chk_type_id(register struct type **ptp, register struct node *nd);
+/* Construct a new subrange type from a lower bound "lb" to an upper bound "ub" */
+struct type *subr_type(register struct node *lb, register struct node *ub);
+/* Return the bounds of the specified type "tp", assert if this is not a bounded type. */
+void getbounds(register struct type *tp, arith *plo, arith *phi);
+/* Construct a new set type. */
+struct type *set_type(register struct type *tp, unsigned short packed);
+/* Assign sizes to an array type, and check index type and generate array descriptor */
+void ArraySizes(register struct type *tp);
+/* Check all forward declaration */
+void chk_forw_types(void);
+/* Insert selector of nested variant (sel1) in tagvalue-table of
+ current selector (sel).
+*/
+void TstCaseConstants(register struct node *nd, register struct selector *sel,
+ register struct selector *sel1);
+/* Return the "pos" aligned to "al". */
+arith align(arith pos, int al);
+/* Print type information for "tp". */
+void DumpType(register struct type *tp);
+/* Least Common Multiple */
+int lcm(int m, int n);
+
+
+
+
+
+#endif
#include "def.h"
#include "node.h"
#include "type.h"
+#include "error.h"
+#include "typequiv.h"
-
-int
-TstTypeEquiv(tp1, tp2)
- register struct type *tp1, *tp2;
+int TstTypeEquiv(register struct type *tp1, register struct type *tp2)
{
/* test if two types are equivalent.
*/
return tp1 == tp2 || tp1 == error_type || tp2 == error_type;
}
-arith
-IsString(tp)
- register struct type *tp;
+arith IsString(register struct type *tp)
{
/* string = packed array[1..ub] of char and ub > 1 */
if( tp->tp_fund & T_STRINGCONST ) return tp->tp_psize;
return (arith) 0;
}
-int
-TstStrCompat(tp1, tp2)
- register struct type *tp1, *tp2;
+int TstStrCompat(register struct type *tp1, register struct type *tp2)
{
/* test if two types are compatible string-types.
*/
return ub1 == ub2;
}
-int
-TstCompat(tp1, tp2)
- register struct type *tp1, *tp2;
+int TstCompat(register struct type *tp1,register struct type *tp2)
{
/* test if two types are compatible. ISO 6.4.5
*/
return tp1 == tp2;
}
-int
-TstAssCompat(tp1, tp2)
- register struct type *tp1, *tp2;
+int TstAssCompat(register struct type *tp1,register struct type *tp2)
{
/* test if two types are assignment compatible. ISO 6.4.6
*/
return 0;
}
-int
-TstParEquiv(tp1, tp2)
- register struct type *tp1, *tp2;
+int TstParEquiv(register struct type *tp1, register struct type *tp2)
{
/* Test if two parameter types are equivalent. ISO 6.6.3.6
*/
||
(
(
- tp1->tp_fund == T_PROCEDURE && tp2->tp_fund == T_PROCEDURE
+ (tp1->tp_fund == T_PROCEDURE && tp2->tp_fund == T_PROCEDURE)
||
- tp1->tp_fund == T_FUNCTION && tp2->tp_fund == T_FUNCTION
+ (tp1->tp_fund == T_FUNCTION && tp2->tp_fund == T_FUNCTION)
)
&&
TstProcEquiv(tp1, tp2)
);
}
-int
-TstProcEquiv(tp1, tp2)
- register struct type *tp1, *tp2;
+int TstProcEquiv(register struct type *tp1, register struct type *tp2)
{
/* Test if two procedure types are equivalent. ISO 6.6.3.6
*/
return p1 == p2;
}
-int
-TstParCompat(formaltype, actualtype, VARflag, nd, new_par_section)
- register struct type *formaltype, *actualtype;
- struct node *nd;
+int TstParCompat(register struct type *formaltype, register struct type *actualtype,
+ int VARflag, struct node *nd, int new_par_section)
{
/* Check type compatibility for a parameter in a procedure call.
*/
else return 0;
}
-int
-TstConform(formaltype, actualtype, new_par_section)
- register struct type *formaltype, *actualtype;
+int TstConform(register struct type *formaltype, register struct type * actualtype, int new_par_section)
{
/* Check conformability.
--- /dev/null
+/* Copyright (c) 2019 ACK Project.
+ * See the copyright notice in the ACK home directory,
+ * in the file "Copyright".
+ *
+ */
+#ifndef TYPEQUIV_H_
+#define TYPEQUIV_H_
+
+#include "em_arith.h"
+
+
+struct type;
+struct node;
+
+/* test if two types are equivalent. */
+int TstTypeEquiv(register struct type *tp1, register struct type *tp2);
+arith IsString(register struct type *tp);
+/* test if two types are compatible string-types. */
+int TstStrCompat(register struct type *tp1, register struct type *tp2);
+/* test if two types are compatible. ISO 6.4.5 */
+int TstCompat(register struct type *tp1,register struct type *tp2);
+/* test if two types are assignment compatible. ISO 6.4.6 */
+int TstAssCompat(register struct type *tp1,register struct type *tp2);
+/* Test if two parameter types are equivalent. ISO 6.6.3.6 */
+int TstParEquiv(register struct type *tp1, register struct type *tp2);
+/* Test if two procedure types are equivalent. ISO 6.6.3.6 */
+int TstProcEquiv(register struct type *tp1, register struct type *tp2);
+/* Check type compatibility for a parameter in a procedure call. */
+int TstParCompat(register struct type *formaltype, register struct type *actualtype,
+ int VARflag, struct node *nd, int new_par_section);
+/* Check conformability.
+
+ DEVIATION FROM STANDARD (ISO 6.6.3.7.2):
+ Allow with value parameters also conformant arrays as actual
+ type.(ISO only with var. parameters)
+
+ Do as much checking on indextypes as possible.
+*/
+int TstConform(register struct type *formaltype, register struct type * actualtype, int new_par_section);
+
+
+#endif /* TYPEQUIV_H_ */
public / ack.git / commitdiff