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

Pascal compiler better type checking and function declarations (Better ISO C compatibility)

Browse source
This commit is contained in:
carl 2019-02-24 00:44:50 +08:00
parent d41ba12679
commit 41cb541e7e
57 changed files with 2535 additions and 1978 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

28
lang/pc/comp/LLlex.c
View file

@ -19,9 +19,10 @@
#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)
@ -43,7 +44,7 @@ int tokenseen = 0; /* Some comment-options must precede any program text */
/* 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;
@ -120,8 +121,7 @@ CommentOptions()
}
STATIC void
SkipComment()
static void SkipComment(void)
{
/* Skip ISO-Pascal comments (* ... *) or { ... }.
Note :
@ -153,9 +153,7 @@ SkipComment()
}
}
STATIC struct string *
GetString( delim )
register int delim;
static struct string *GetString(register int delim)
{
/* Read a Pascal string, delimited by the character ' or ".
*/
@ -212,8 +210,7 @@ register int delim;
static char *s_error = "illegal line directive";
void
CheckForLineDirective()
void CheckForLineDirective(void)
{
register int ch;
register int i = 0;
@ -276,8 +273,7 @@ CheckForLineDirective()
LineNumber = i;
}
int
LLlex()
int LLlex(void)
{
/* LLlex() is the Lexical Analyzer.
The putting aside of tokens is taken into account.
@ -531,10 +527,10 @@ again:
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;

10
lang/pc/comp/LLlex.h
View file

@ -1,4 +1,9 @@
/* 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
*/
@ -46,3 +51,8 @@ extern struct type *toktype, *asidetype;
extern int tokenseen;
#define ASIDE aside.tk_symb
void CheckForLineDirective(void);
int LLlex(void);
#endif

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

@ -14,15 +14,14 @@
#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.

4
lang/pc/comp/Parameters
View file

@ -1,5 +1,5 @@
!File: debugcst.h
/*#define DEBUG 1 /* perform various self-tests */
/*#define DEBUG 1 *//* perform various self-tests */
#define NDEBUG 1 /* disable assertions */
@ -55,7 +55,7 @@
!File: nocross.h
/*#define NOCROSS 1 /* define when cross compiler not needed */
/*#define NOCROSS 1 *//* define when cross compiler not needed */
!File: dbsymtab.h

149
lang/pc/comp/body.c
View file

@ -15,24 +15,29 @@
#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)
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) )
@ -47,22 +52,21 @@ MarkDef(nd, flags, on)
}
}
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( 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);
@ -70,9 +74,7 @@ AssertStat(expp, line)
}
}
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;
@ -87,24 +89,28 @@ AssignStat(left, right)
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;
}
@ -112,13 +118,15 @@ AssignStat(left, right)
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))
CodeAddress(&dsr);
else {
else
{
CodeValue(&dsr, rtp);
if (ltp == real_type && BaseType(rtp) == int_type)
@ -133,21 +141,19 @@ AssignStat(left, right)
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;
@ -157,27 +163,30 @@ ChkForStat(nd)
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");
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);
return;
@ -198,34 +207,28 @@ ChkForStat(nd)
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");
node_error(nd, "for loop: control variable already set in block");
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);
}
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.
@ -234,7 +237,8 @@ CodeInitFor(nd, priority)
arith tmp;
CodePExpr(nd);
if( nd->nd_class != Value ) {
if (nd->nd_class != Value)
{
tmp = NewInt(priority);
C_dup(int_size);
@ -245,14 +249,13 @@ CodeInitFor(nd, priority)
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 */
C_bgt(l2);
else /* DOWNTO */
else
/* DOWNTO */
C_blt(l2);
/* Label at begin of the body */
@ -262,10 +265,7 @@ CodeFor(nd, stepsize, l1, l2)
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);
@ -279,7 +279,8 @@ CodeEndFor(nd, stepsize, l1, l2, tmp2)
/* Increment/decrement the control-variable */
if (stepsize == 1) /* TO */
C_inc();
else /* DOWNTO */
else
/* DOWNTO */
C_dec();
C_bra(l1);
@ -288,15 +289,14 @@ CodeEndFor(nd, stepsize, l1, l2, tmp2)
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;
}
@ -314,7 +314,8 @@ WithStat(nd)
scl->next = CurrVis;
CurrVis = scl;
if( err_occurred ) return;
if (err_occurred)
return;
/* Generate code */
@ -338,16 +339,15 @@ WithStat(nd)
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;
@ -366,7 +366,8 @@ EndWith(saved_scl, nd)
free_withdesig(wds);
}
for( nd1 = nd; nd1 != NULLNODE; nd1 = nd1->nd_right ) {
for (nd1 = nd; nd1 != NULLNODE; nd1 = nd1->nd_right)
{
MarkDef(nd1->nd_left, (unsigned short) (D_WITH), 0);
}

38
lang/pc/comp/body.h Normal file
View file

@ -0,0 +1,38 @@
/* 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_ */

3
lang/pc/comp/build.lua
View file

@ -124,9 +124,6 @@ cprogram {
"modules/src/string+lib",
"modules/src/system+lib",
},
vars = {
["+cflags"] = "-DSTATIC=static"
}
}
installable {

19
lang/pc/comp/casestat.h Normal file
View file

@ -0,0 +1,19 @@
/* Copyright (c) 2019 ACK Project.
* See the copyright notice in the ACK home directory,
* in the file "Copyright".
*
*/
#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_ */

46
lang/pc/comp/casestat.xc
View file

@ -12,6 +12,10 @@
#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 */
@ -40,9 +44,14 @@ struct case_entry {
*/
#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
*/
@ -64,9 +73,9 @@ CaseExpr(nd)
}
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.
*/
@ -98,8 +107,7 @@ CaseEnd(nd, exit_label)
FreeNode(nd);
}
FreeCh(ch)
register struct case_hdr *ch;
static void FreeCh(register struct case_hdr *ch)
{
/* free the allocated case structure
*/
@ -116,10 +124,10 @@ FreeCh(ch)
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) )
@ -129,10 +137,10 @@ AddCases(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;
@ -211,10 +219,10 @@ AddOneCase(ch, nd, lbl)
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 */

605
lang/pc/comp/chk_expr.c
View file

File diff suppressed because it is too large Load diff

13
lang/pc/comp/chk_expr.h
View file

@ -1,5 +1,7 @@
/* 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
*/
@ -10,3 +12,14 @@ extern int (*VarAccChkTable[])(); /* table of variable-access checking
#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);

435
lang/pc/comp/code.c
View file

@ -21,30 +21,44 @@
#include "required.h"
#include "scope.h"
#include "type.h"
#include "code.h"
#include "tmpvar.h"
#include "typequiv.h"
#include "error.h"
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);
}
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);
@ -57,23 +71,25 @@ RomString(nd)
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 ??? */
@ -83,9 +99,7 @@ BssVar()
}
}
arith
CodeGtoDescr(sc)
register struct scope *sc;
static arith CodeGtoDescr(register struct scope *sc)
{
/* Create code for goto descriptors
*/
@ -93,9 +107,12 @@ CodeGtoDescr(sc)
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();
@ -113,9 +130,7 @@ CodeGtoDescr(sc)
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.
@ -126,8 +141,10 @@ CodeBeginBlock(df)
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);
@ -136,13 +153,13 @@ CodeBeginBlock(df)
/* initialize external files */
call_ini();
/* ignore floating point underflow */
C_lim();
/* 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;
@ -152,7 +169,8 @@ CodeBeginBlock(df)
offset = CodeGtoDescr(df->prc_vis->sc_scope);
CodeFil();
if( options['t'] ) {
if (options['t'])
{
C_lae_dlb(df->prc_label, (arith) 0);
C_cal("procentry");
C_asp(pointer_size);
@ -163,15 +181,19 @@ CodeBeginBlock(df)
* 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
@ -179,7 +201,8 @@ CodeBeginBlock(df)
before we return.
*/
if( !StackAdjustment ) {
if (!StackAdjustment)
{
/* First time we get here
*/
StackAdjustment = NewInt(0);
@ -217,12 +240,14 @@ CodeBeginBlock(df)
}
}
}
else {
else
{
crash("(CodeBeginBlock)");
/*NOTREACHED*/
}
if( offset ) {
if (offset)
{
/* save SP for non-local jump */
C_lor((arith) 1);
C_stl(offset);
@ -230,18 +255,19 @@ CodeBeginBlock(df)
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);
@ -250,13 +276,16 @@ CodeEndBlock(df, StackAdjustment)
if (!options['n'])
RegisterMessages(df->prc_vis->sc_scope->sc_def);
if( options['t'] ) {
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'] ) {
if ( (tp = ResultType(df->df_type)) )
{
if (!options['R'])
{
C_lin((arith) LineNumber);
C_lol(df->prc_bool);
C_cal("_nfa");
@ -266,7 +295,8 @@ CodeEndBlock(df, StackAdjustment)
C_lol(-tp->tp_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);
}
@ -276,7 +306,8 @@ CodeEndBlock(df, StackAdjustment)
else
C_ret((arith) 0);
}
else {
else
{
crash("(CodeEndBlock)");
/*NOTREACHED*/
}
@ -285,18 +316,19 @@ CodeEndBlock(df, StackAdjustment)
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;
@ -332,12 +364,14 @@ CodeExpr(nd, ds, true_label)
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;
}
@ -357,12 +391,14 @@ CodeExpr(nd, ds, true_label)
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))
@ -388,7 +424,8 @@ CodeExpr(nd, ds, true_label)
CodeDesig(nd, ds);
break;
case Cast: {
case Cast:
{
/* convert integer to real */
struct node *right = nd->nd_right;
@ -397,7 +434,8 @@ CodeExpr(nd, ds, true_label)
ds->dsg_kind = DSG_LOADED;
break;
}
case IntCoerc: {
case IntCoerc:
{
/* convert integer to long integer */
struct node *right = nd->nd_right;
@ -406,7 +444,8 @@ CodeExpr(nd, ds, true_label)
ds->dsg_kind = DSG_LOADED;
break;
}
case IntReduc: {
case IntReduc:
{
/* convert a long to an integer */
struct node *right = nd->nd_right;
@ -420,7 +459,8 @@ CodeExpr(nd, ds, true_label)
/*NOTREACHED*/
} /* switch class */
if( true_label ) {
if (true_label)
{
/* Only for boolean expressions
*/
CodeValue(ds, tp);
@ -428,14 +468,14 @@ CodeExpr(nd, ds, 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 ) {
switch (nd->nd_symb)
{
case '-':
assert(tp->tp_fund & T_NUMERIC);
if (tp->tp_fund == T_INTEGER || tp->tp_fund == T_LONG)
@ -457,25 +497,56 @@ CodeUoper(nd)
}
}
Operands(leftop, rightop)
register struct node *leftop, *rightop;
/* 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*/
}
}
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 ) {
switch (expr->nd_symb)
{
case '+':
Operands(leftop, rightop);
switch( tp->tp_fund ) {
switch (tp->tp_fund)
{
case T_INTEGER:
case T_LONG:
C_adi(tp->tp_size);
@ -493,7 +564,8 @@ CodeBoper(expr, true_label)
case '-':
Operands(leftop, rightop);
switch( tp->tp_fund ) {
switch (tp->tp_fund)
{
case T_INTEGER:
case T_LONG:
C_sbi(tp->tp_size);
@ -512,7 +584,8 @@ CodeBoper(expr, true_label)
case '*':
Operands(leftop, rightop);
switch( tp->tp_fund ) {
switch (tp->tp_fund)
{
case T_INTEGER:
case T_LONG:
C_mli(tp->tp_size);
@ -539,12 +612,14 @@ CodeBoper(expr, true_label)
case DIV:
case MOD:
Operands(leftop, rightop);
if( tp->tp_fund == T_INTEGER ) {
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) {
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);
@ -563,7 +638,8 @@ CodeBoper(expr, true_label)
CodePExpr(rightop);
tp = BaseType(rightop->nd_type);
switch( tp->tp_fund ) {
switch (tp->tp_fund)
{
case T_INTEGER:
case T_LONG:
C_cmi(tp->tp_size);
@ -580,7 +656,8 @@ CodeBoper(expr, true_label)
break;
case T_SET:
if( expr->nd_symb == GREATEREQUAL ) {
if (expr->nd_symb == GREATEREQUAL)
{
/* A >= B is the same as A equals A + B
*/
C_dup(2 * tp->tp_size);
@ -588,7 +665,8 @@ CodeBoper(expr, true_label)
C_ior(tp->tp_size);
expr->nd_symb = '=';
}
else if( expr->nd_symb == LESSEQUAL ) {
else if (expr->nd_symb == LESSEQUAL)
{
/* A <= B is the same as A - B = []
*/
C_com(tp->tp_size);
@ -645,47 +723,19 @@ CodeBoper(expr, true_label)
C_zeq(true_label);
break;
default:
crash("(CodeBoper Bad operator %s\n)",
symbol2str(expr->nd_symb));
crash("(CodeBoper Bad operator %s\n)", symbol2str(expr->nd_symb));
}
}
/* truthvalue() serves as an auxiliary function of CodeBoper */
truthvalue(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*/
}
}
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);
@ -693,27 +743,24 @@ CodeSet(nd)
}
}
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_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;
@ -728,7 +775,8 @@ CodeParameters(param, arg)
left = arg->nd_left;
left_tp = left->nd_type;
if( IsConformantArray(tp) ) {
if (IsConformantArray(tp))
{
if (last_tp != tp)
/* push descriptors only once */
CodeConfDescr(tp, left_tp);
@ -736,11 +784,13 @@ CodeParameters(param, arg)
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;
}
@ -756,21 +806,23 @@ CodeParameters(param, arg)
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))
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);
}
@ -779,7 +831,8 @@ CodeConfDescr(ftp, atp)
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);
@ -787,18 +840,14 @@ CodeConfDescr(ftp, atp)
}
}
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.
@ -810,7 +859,8 @@ CodeCall(nd)
assert(IsProcCall(left));
if( left->nd_type == std_type ) {
if (left->nd_type == std_type)
{
CodeStd(nd);
return;
}
@ -820,8 +870,8 @@ CodeCall(nd)
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))
@ -829,7 +879,8 @@ CodeCall(nd)
C_cal(df->prc_name);
C_asp(left->nd_type->prc_nbpar);
}
else {
else
{
label l1 = ++text_label;
label l2 = ++text_label;
@ -847,8 +898,7 @@ CodeCall(nd)
C_zeq(l1);
/* 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);
@ -860,12 +910,11 @@ CodeCall(nd)
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;
@ -874,7 +923,8 @@ CodeStd(nd)
assert(arg->nd_class == Link && arg->nd_symb == ',');
switch( req ) {
switch (req)
{
case R_ABS:
CodePExpr(left);
if (tp == int_type)
@ -904,7 +954,8 @@ CodeStd(nd)
case R_ARCTAN:
assert(tp == real_type);
CodePExpr(left);
switch( req ) {
switch (req)
{
case R_SIN:
C_cal("_sin");
break;
@ -959,7 +1010,8 @@ CodeStd(nd)
case R_PRED:
CodePExpr(left);
C_loc((arith) 1);
if( tp == long_type) Int2Long();
if (tp == long_type)
Int2Long();
if (req == R_SUCC)
C_adi(tp->tp_size);
@ -973,9 +1025,11 @@ CodeStd(nd)
case R_ODD:
CodePExpr(left);
C_loc((arith) 1);
if( tp == long_type ) Int2Long();
if (tp == long_type)
Int2Long();
C_and(tp->tp_size);
if( tp == long_type ) Long2Int(); /* bool_size == int_size */
if (tp == long_type)
Long2Int(); /* bool_size == int_size */
break;
case R_EOF:
@ -1020,10 +1074,10 @@ CodeStd(nd)
C_asp(pointer_size);
break;
case R_PACK: {
case R_PACK:
{
label lba = tp->arr_ardescr;
CodeDAddress(left);
arg = arg->nd_right;
left = arg->nd_left;
@ -1038,18 +1092,20 @@ CodeStd(nd)
break;
}
case R_UNPACK: {
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) {
if (tp->tp_fund == T_SUBRANGE && tp->sub_lb >= 0)
{
C_loc((arith) 1);
}
else C_loc((arith) 0);
else
C_loc((arith) 0);
CodeDAddress(left);
arg = arg->nd_right;
left = arg->nd_left;
@ -1091,31 +1147,31 @@ CodeStd(nd)
}
}
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);
@ -1123,7 +1179,7 @@ arith size;
C_cif();
}
Real2Int()
void Real2Int(void)
{
/* convert real to integer */
C_loc(real_size);
@ -1131,20 +1187,21 @@ Real2Int()
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))
/* 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
@ -1158,9 +1215,7 @@ RangeCheck(tpl, tpr)
}
}
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.
@ -1170,21 +1225,26 @@ genrck(tp)
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);
@ -1193,8 +1253,7 @@ genrck(tp)
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.
@ -1211,8 +1270,7 @@ CodePExpr(nd)
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.
@ -1225,8 +1283,7 @@ CodeDAddress(nd)
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".
@ -1239,19 +1296,19 @@ CodeDStore(nd)
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);
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);

56
lang/pc/comp/code.h Normal file
View file

@ -0,0 +1,56 @@
/* 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_ */

34
lang/pc/comp/cstoper.c
View file

@ -17,6 +17,8 @@
#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, .. */
@ -26,18 +28,15 @@ char *maxint_str; /* string representation of maximum integer */
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 ) {
@ -67,9 +66,7 @@ cstunary(expp)
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.
@ -197,9 +194,7 @@ cstbin(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;
@ -353,8 +348,7 @@ cstset(expp)
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.
@ -441,8 +435,7 @@ cstcall(expp, req)
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
@ -460,8 +453,8 @@ CutSize(expr)
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;
@ -474,9 +467,8 @@ CutSize(expr)
expr->nd_INT = o1;
}
InitCst()
void InitCst(void)
{
extern char *Salloc();
register int i = 0;
register arith bt = (arith)0;

36
lang/pc/comp/cstoper.h Normal file
View file

@ -0,0 +1,36 @@
/* 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_ */

24
lang/pc/comp/declar.g
View file

@ -21,6 +21,14 @@
#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))
@ -177,7 +185,7 @@ ConstantDefinition
} :
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;
@ -197,7 +205,7 @@ TypeDefinition
} :
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
@ -371,7 +379,7 @@ FunctionDeclaration
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 =
@ -705,7 +713,7 @@ VariantPart(struct scope *scope; arith *cnt; int *palign;
{ 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;
@ -987,16 +995,16 @@ Index_TypeSpecification(register struct type **ptp; register struct type *tp;)
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;
}

178
lang/pc/comp/def.c
View file

@ -15,13 +15,13 @@
#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".
@ -42,11 +42,8 @@ MkDef(id, scope, kind)
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.
@ -55,21 +52,25 @@ define(id, scope, kind)
*/
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:
/* generate error message somewhere else */
@ -82,27 +83,28 @@ define(id, scope, kind)
break;
case D_FORWTYPE:
if( kind == D_FORWTYPE ) return df;
if( kind == D_TYPE ) {
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);
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);
if (kind == D_FUNCTION)
return df;
error("function identification \"%s\" expected", id->id_text);
return NULLDEF;
}
@ -116,42 +118,42 @@ define(id, scope, kind)
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 */
struct def *df = lookup(directive, PervasiveScope, D_INUSE);
if( !df ) {
if (!df)
{
if (!is_anon_idf(directive))
node_error(nd, "\"%s\" unknown directive",
directive->id_text);
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);
@ -161,7 +163,8 @@ DoDirective(directive, nd, tp, scl, function)
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.
@ -174,17 +177,16 @@ DoDirective(directive, nd, tp, scl, function)
}
}
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 ) {
if (df->df_kind == D_FWPROCEDURE)
{
df->df_kind = D_PROCEDURE; /* identification */
/* Simulate a call to open_scope(), which has already
@ -193,11 +195,10 @@ DeclProc(nd, tp, scl)
CurrVis = df->prc_vis;
if (tp->prc_params)
node_error(nd,
"\"%s\" already declared",
nd->nd_IDF->id_text);
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));
/* simulate open_scope() */
@ -205,23 +206,25 @@ DeclProc(nd, tp, 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) ) {
if ( (df = define(nd->nd_IDF, CurrentScope, D_FUNCTION)) )
{
df->df_flags &= ~D_SET;
if( df->df_kind == D_FUNCTION ) { /* declaration */
if( !tp ) {
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);
@ -231,27 +234,26 @@ DeclFunc(nd, tp, scl)
df->df_type = tp;
df->prc_name = gen_proc_name(nd->nd_IDF, (proclevel > 1));
}
else { /* identification */
else
{ /* identification */
assert(df->df_kind == D_FWFUNCTION);
df->df_kind = D_FUNCTION;
CurrVis = df->prc_vis;
if (tp)
node_error(nd,
"\"%s\" already declared",
nd->nd_IDF->id_text);
node_error(nd, "\"%s\" already declared", nd->nd_IDF->id_text);
}
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;
@ -259,19 +261,20 @@ EndFunc(df)
/* Give the error about assignment as soon as possible. The
* |= assignment inhibits a warning in the main procedure.
*/
if( !(df->df_flags & D_SET) ) {
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 ) {
while (tmp_def)
{
df = tmp_def;
/* The length of a usd_def chain is at most 1.
* The while is just defensive programming.
@ -279,23 +282,28 @@ EndBlock(block_df)
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) ) {
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
{
warning("\"%s\" unused in \"%s\"", df->df_idf->id_text,
block_df->df_idf->id_text);
}
}
else if( !(df->df_flags & D_SET) ) {
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);
warning("\"%s\" not set in \"%s\"", df->df_idf->id_text,
block_df->df_idf->id_text);
}
}

20
lang/pc/comp/def.xh
View file

@ -1,5 +1,8 @@
/* 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
@ -153,3 +156,20 @@ extern struct def
*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

52
lang/pc/comp/desig.c
View file

@ -22,16 +22,15 @@
#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.
@ -55,9 +54,7 @@ properly(ds, size, al)
(! 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;
@ -72,11 +69,7 @@ CodeCopy(lhs, rhs, sz, psize)
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;
@ -152,10 +145,7 @@ CodeMove(rhs, left, rtp)
}
}
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"
@ -212,9 +202,7 @@ CodeValue(ds, tp)
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"
@ -265,8 +253,7 @@ CodeStore(ds, tp)
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"
@ -316,9 +303,7 @@ CodeAddress(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
@ -369,10 +354,7 @@ CodeFieldDesig(df, ds)
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,
@ -436,9 +418,7 @@ CodeVarDesig(df, ds)
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 */
@ -464,9 +444,7 @@ CodeBoundDesig(df, ds)
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 */
@ -500,9 +478,7 @@ CodeFuncDesig(df, ds)
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

32
lang/pc/comp/desig.xh
View file

@ -1,3 +1,6 @@
#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
@ -57,3 +60,32 @@ extern struct withdesig *WithDesigs;
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

156
lang/pc/comp/enter.c
View file

@ -14,15 +14,18 @@
#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;
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
@ -33,51 +36,57 @@ Enter(name, kind, type, pnam)
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)
) {
|| !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;
@ -87,9 +96,7 @@ EnterProgList(Idlist)
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.
@ -99,25 +106,24 @@ EnterEnumList(Idlist, type)
type->enm_ncst = 0;
for (; idlist; idlist = idlist->nd_next)
if( df = define(idlist->nd_IDF, CurrentScope, D_ENUM) ) {
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".
@ -126,14 +132,17 @@ EnterFieldList(Idlist, type, scope, addr, packed)
register struct node *idlist = Idlist;
for (; idlist; idlist = idlist->nd_next)
if( df = define(idlist->nd_IDF, scope, D_FIELD) ) {
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;
}
@ -141,9 +150,7 @@ EnterFieldList(Idlist, type, scope, addr, packed)
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.
@ -154,11 +161,13 @@ EnterVarList(Idlist, type, local)
register struct node *idlist = Idlist;
register struct scopelist *sc = CurrVis;
for( ; idlist; idlist = idlist->nd_next ) {
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
@ -166,33 +175,50 @@ EnterVarList(Idlist, type, local)
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) ) {
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;
@ -203,7 +229,8 @@ EnterParamList(fpl, parlist)
df->df_flags |= fpl->nd_INT;
}
while( IsConformantArray(tp) ) {
while (IsConformantArray(tp))
{
/* we need room for the descriptors */
tp->arr_sclevel = CurrentScope->sc_level;
@ -215,10 +242,7 @@ EnterParamList(fpl, parlist)
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).
@ -228,12 +252,13 @@ EnterParTypes(fpl, parlist)
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) )
if ( (df = new_def()) )
{
if (fpl->nd_INT & D_VARPAR || IsConformantArray(tp))
nb_pars += pointer_size;
else
nb_pars += tp->tp_size;
@ -241,7 +266,8 @@ EnterParTypes(fpl, parlist)
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;
}
@ -249,17 +275,3 @@ EnterParTypes(fpl, parlist)
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;
}

26
lang/pc/comp/enter.h Normal file
View file

@ -0,0 +1,26 @@
/* Copyright (c) 2019 ACK Project.
* See the copyright notice in the ACK home directory,
* in the file "Copyright".
*
*/
#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_ */

64
lang/pc/comp/error.c
View file

@ -16,7 +16,10 @@
#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"
@ -37,9 +40,7 @@
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
@ -55,7 +56,7 @@ void _error();
#if __STDC__
#ifdef DEBUG
/*VARARGS*/
debug(char *fmt, ...)
void debug(char *fmt, ...)
{
va_list ap;
@ -68,7 +69,7 @@ debug(char *fmt, ...)
#endif /* DEBUG */
/*VARARGS*/
error(char *fmt, ...)
void error(char *fmt, ...)
{
va_list ap;
@ -80,7 +81,7 @@ error(char *fmt, ...)
}
/*VARARGS*/
node_error(struct node *node, char *fmt, ...)
void node_error(struct node *node, char *fmt, ...)
{
va_list ap;
@ -92,7 +93,7 @@ node_error(struct node *node, char *fmt, ...)
}
/*VARARGS*/
warning(char *fmt, ...)
void warning(char *fmt, ...)
{
va_list ap;
@ -104,7 +105,7 @@ warning(char *fmt, ...)
}
/*VARARGS*/
node_warning(struct node *node, char *fmt, ...)
void node_warning(struct node *node, char *fmt, ...)
{
va_list ap;
@ -116,7 +117,7 @@ node_warning(struct node *node, char *fmt, ...)
}
/*VARARGS*/
lexerror(char *fmt, ...)
void lexerror(char *fmt, ...)
{
va_list ap;
@ -128,7 +129,7 @@ lexerror(char *fmt, ...)
}
/*VARARGS*/
lexwarning(char *fmt, ...)
void lexwarning(char *fmt, ...)
{
va_list ap;
@ -140,7 +141,7 @@ lexwarning(char *fmt, ...)
}
/*VARARGS*/
fatal(char *fmt, ...)
void fatal(char *fmt, ...)
{
va_list ap;
@ -149,11 +150,11 @@ fatal(char *fmt, ...)
_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;
@ -163,15 +164,15 @@ crash(char *fmt, ...)
}
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;
@ -186,7 +187,7 @@ debug(va_alist)
#endif /* DEBUG */
/*VARARGS*/
error(va_alist)
void error(va_alist)
va_dcl
{
va_list ap;
@ -200,7 +201,7 @@ error(va_alist)
}
/*VARARGS*/
node_error(va_alist)
void node_error(va_alist)
va_dcl
{
va_list ap;
@ -215,7 +216,7 @@ node_error(va_alist)
}
/*VARARGS*/
warning(va_alist)
void warning(va_alist)
va_dcl
{
va_list ap;
@ -229,7 +230,7 @@ warning(va_alist)
}
/*VARARGS*/
node_warning(va_alist)
void node_warning(va_alist)
va_dcl
{
va_list ap;
@ -244,7 +245,7 @@ node_warning(va_alist)
}
/*VARARGS*/
lexerror(va_alist)
void lexerror(va_alist)
va_dcl
{
va_list ap;
@ -258,7 +259,7 @@ lexerror(va_alist)
}
/*VARARGS*/
lexwarning(va_alist)
void lexwarning(va_alist)
va_dcl
{
va_list ap;
@ -272,7 +273,7 @@ lexwarning(va_alist)
}
/*VARARGS*/
fatal(va_alist)
void fatal(va_alist)
va_dcl
{
va_list ap;
@ -283,11 +284,11 @@ fatal(va_alist)
_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;
@ -299,19 +300,14 @@ crash(va_alist)
}
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.

25
lang/pc/comp/error.h Normal file
View file

@ -0,0 +1,25 @@
/* Copyright (c) 2019 ACK Project.
* See the copyright notice in the ACK home directory,
* in the file "Copyright".
*
*/
#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_ */

2
lang/pc/comp/expression.g
View file

@ -16,6 +16,8 @@
#include "node.h"
#include "scope.h"
#include "type.h"
#include "code.h"
#include "error.h"
}
Constant(register struct node **pnd;)

4
lang/pc/comp/idf.h
View file

@ -1,4 +1,6 @@
/* 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;
@ -10,3 +12,5 @@ struct id_u {
#define id_def id_user.id_df
#include <idf_pkg.spec>
#endif

8
lang/pc/comp/input.c
View file

@ -12,10 +12,16 @@ struct f_info file_info;
#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;
}

20
lang/pc/comp/label.c
View file

@ -11,12 +11,13 @@
#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;
@ -29,7 +30,7 @@ DeclLabel(nd)
}
}
chk_labels(Slevel)
void chk_labels(int Slevel)
{
register struct node *labnd = BlockScope->sc_lablist;
register struct def *df;
@ -62,8 +63,7 @@ chk_labels(Slevel)
}
}
TstLabel(nd, Slevel)
register struct node *nd;
void TstLabel(register struct node *nd, int Slevel)
{
register struct def *df;
@ -105,9 +105,7 @@ TstLabel(nd, Slevel)
CodeLabel(df, 1);
}
void
DefLabel(nd, Slevel)
register struct node *nd;
void DefLabel(register struct node *nd, int Slevel)
{
register struct def *df;
@ -142,9 +140,7 @@ DefLabel(nd, Slevel)
}
}
void
CodeLabel(df, local)
register struct def *df;
static void CodeLabel(register struct def *df, int local)
{
if( err_occurred ) return;

17
lang/pc/comp/label.h Normal file
View file

@ -0,0 +1,17 @@
/* 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_ */

35
lang/pc/comp/lookup.c
View file

@ -13,9 +13,9 @@
#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;
@ -28,17 +28,9 @@ remove_def(df)
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
@ -67,15 +59,10 @@ lookup(id, scope, inuse)
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;
@ -84,8 +71,8 @@ lookfor(id, vis, give_error)
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);
}
@ -96,8 +83,8 @@ lookfor(id, vis, give_error)
*/
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;
}

29
lang/pc/comp/lookup.h Normal file
View file

@ -0,0 +1,29 @@
/* Copyright (c) 2019 ACK Project.
* See the copyright notice in the ACK home directory,
* in the file "Copyright".
*
*/
#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_ */

34
lang/pc/comp/main.c
View file

@ -10,6 +10,7 @@
#include <system.h>
#include <stb.h>
#include "print.h"
#include "LLlex.h"
#include "Lpars.h"
#include "class.h"
@ -24,6 +25,10 @@
#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;
@ -36,9 +41,16 @@ label text_label;
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];
@ -54,14 +66,14 @@ main(argc, argv)
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[];
@ -128,10 +140,10 @@ Compile(src, dst)
}
#ifdef DEBUG
LexScan()
void LexScan(void)
{
register struct token *tkp = &dot;
extern char *symbol2str();
while( LLlex() > 0 ) {
print(">>> %s ", symbol2str(tkp->tk_symb));
@ -159,7 +171,7 @@ LexScan()
}
#endif
AddRequired()
void AddRequired(void)
{
register struct def *df;
extern struct def *Enter();
@ -259,7 +271,7 @@ AddRequired()
#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,

16
lang/pc/comp/misc.c
View file

@ -12,25 +12,23 @@
#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
@ -41,15 +39,13 @@ not_declared(what, id, where)
}
}
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);

12
lang/pc/comp/misc.h
View file

@ -1,5 +1,7 @@
/* 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), ""))
@ -9,11 +11,7 @@ extern struct idf
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();

2
lang/pc/comp/next.in Normal file
View file

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

27
lang/pc/comp/node.c
View file

@ -6,16 +6,14 @@
#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
*/
@ -29,9 +27,7 @@ MkNode(class, left, right, token)
return nd;
}
struct node *
MkLeaf(class, token)
struct token *token;
struct node *MkLeaf(int class, struct token *token)
{
register struct node *nd = new_node();
@ -42,9 +38,7 @@ MkLeaf(class, token)
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
*/
@ -54,8 +48,7 @@ FreeNode(nd)
free_node(nd);
}
NodeCrash(expp)
struct node *expp;
int NodeCrash(struct node *expp)
{
crash("Illegal node %d", expp->nd_class);
}
@ -64,14 +57,13 @@ NodeCrash(expp)
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));
@ -83,8 +75,7 @@ printnode(nd, lvl)
}
}
PrNode(nd, lvl)
register struct node *nd;
void PrNode(register struct node *nd, int lvl)
{
if( !nd ) {
indnt(lvl); print("<nilnode>\n");

15
lang/pc/comp/node.xh
View file

@ -1,4 +1,7 @@
/* 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;
@ -37,12 +40,22 @@ struct node {
#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

53
lang/pc/comp/options.c
View file

@ -7,7 +7,12 @@
#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
@ -18,13 +23,28 @@ recognize some keywords!
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
@ -74,11 +94,11 @@ DoOption(text)
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]? ]* */
@ -87,7 +107,7 @@ DoOption(text)
register int align;
char c, *t;
while( c = *text++ ) {
while( (c = *text++) !=0 ) {
char *strchr();
t = text;
@ -150,19 +170,4 @@ DoOption(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;
}

12
lang/pc/comp/options.h Normal file
View file

@ -0,0 +1,12 @@
/* 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_ */

5
lang/pc/comp/program.g
View file

@ -15,6 +15,11 @@
#include "main.h"
#include "node.h"
#include "scope.h"
#include "enter.h"
#include "progs.h"
#ifdef DBSYMTAB
#include "stab.h"
#endif
}
%lexical LLlex;

16
lang/pc/comp/progs.c
View file

@ -4,6 +4,7 @@
#include <em.h>
#include <assert.h>
#include "progs.h"
#include "LLlex.h"
#include "def.h"
#include "main.h"
@ -15,20 +16,19 @@ static int inpflag = 0; /* input mentioned in heading ? */
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;
@ -57,9 +57,7 @@ make_extfl()
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);
@ -71,7 +69,7 @@ make_extfl_args(df)
}
}
call_ini()
void call_ini(void)
{
C_lxl((arith) 0);
if( extflc )

15
lang/pc/comp/progs.h Normal file
View file

@ -0,0 +1,15 @@
/* 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_ */

70
lang/pc/comp/readwrite.c
View file

@ -6,6 +6,7 @@
#include <assert.h>
#include <em.h>
#include "print.h"
#include "LLlex.h"
#include "def.h"
#include "main.h"
@ -13,25 +14,33 @@
#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 == ',');
@ -92,14 +101,12 @@ ChkRead(arg)
}
}
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)) )
@ -149,9 +156,7 @@ ChkReadln(arg)
CodeReadln(file);
}
void
ChkWrite(arg)
register struct node *arg;
void ChkWrite(register struct node *arg)
{
struct node *left, *expp, *file;
char *name = "write";
@ -191,9 +196,7 @@ ChkWrite(arg)
}
}
void
ChkWriteln(arg)
register struct node *arg;
void ChkWriteln(register struct node *arg)
{
struct node *left, *expp, *file;
char *name = "writeln";
@ -242,10 +245,7 @@ ChkWriteln(arg)
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";
@ -277,7 +277,7 @@ ChkWriteParameter(filetype, arg, name)
/* Here we have a text-file */
if( arg = arg->nd_right ) {
if( (arg = arg->nd_right) !=0 ) {
/* Total width */
assert(arg->nd_symb == ':');
@ -289,7 +289,7 @@ ChkWriteParameter(filetype, arg, name)
else
return 1;
if( arg = arg->nd_right ) {
if( (arg = arg->nd_right)!=0 ) {
/* Fractional Part */
assert(arg->nd_symb == ':');
@ -305,9 +305,7 @@ ChkWriteParameter(filetype, arg, name)
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;
@ -327,9 +325,7 @@ ChkStdInOut(name, st_out)
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);
@ -386,9 +382,7 @@ CodeRead(file, arg)
}
}
void
CodeReadln(file)
struct node *file;
static void CodeReadln(struct node *file)
{
if( err_occurred ) return;
@ -397,9 +391,7 @@ CodeReadln(file)
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;
@ -484,9 +476,7 @@ CodeWrite(file, arg)
}
}
void
CodeWriteln(file)
register struct node *file;
static void CodeWriteln(register struct node *file)
{
if( err_occurred ) return;

18
lang/pc/comp/readwrite.h Normal file
View file

@ -0,0 +1,18 @@
/* 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_ */

16
lang/pc/comp/scope.c
View file

@ -15,13 +15,15 @@
#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();
@ -33,7 +35,7 @@ InitScope()
CurrVis = ls;
}
open_scope()
void open_scope(void)
{
register struct scope *sc = new_scope();
register struct scopelist *ls = new_scopelist();
@ -45,7 +47,7 @@ open_scope()
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
@ -62,9 +64,7 @@ close_scope(doclean)
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.
@ -79,7 +79,7 @@ Forward(nd, tp)
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;
@ -102,7 +102,7 @@ chk_prog_params()
}
}
chk_directives()
void chk_directives(void)
{
/* check if all forward declarations are defined */
register struct def *df = CurrentScope->sc_def;

13
lang/pc/comp/scope.xh
View file

@ -1,4 +1,6 @@
/* 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;
@ -30,3 +32,14 @@ extern struct scopelist
#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

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

@ -40,8 +40,7 @@ static struct db_str {
char *currpos;
} db_str;
static
create_db_str()
static void create_db_str(void)
{
if (! db_str.base) {
db_str.base = Malloc(INCR_SIZE);
@ -50,9 +49,7 @@ create_db_str()
db_str.currpos = db_str.base;
}
static
addc_db_str(c)
int c;
static void addc_db_str(int c)
{
int df = db_str.currpos - db_str.base;
if (df >= db_str.sz-1) {
@ -64,16 +61,12 @@ addc_db_str(c)
*db_str.currpos = '\0';
}
static
adds_db_str(s)
char *s;
static void adds_db_str(char *s)
{
while (*s) addc_db_str(*s++);
}
static void
stb_type(tp, assign_num)
register struct type *tp;
static void stb_type(register struct type *tp, int assign_num)
{
char buf[128];
static int stb_count;
@ -229,9 +222,7 @@ stb_type(tp, assign_num)
}
}
stb_addtp(s, tp)
char *s;
struct type *tp;
void stb_addtp(char *s, struct type *tp)
{
create_db_str();
adds_db_str(s);
@ -247,10 +238,7 @@ stb_addtp(s, tp)
(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];

17
lang/pc/comp/stab.h Normal file
View file

@ -0,0 +1,17 @@
/* 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_ */

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

@ -17,6 +17,13 @@
#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 */
}

23
lang/pc/comp/tmpvar.h Normal file
View file

@ -0,0 +1,23 @@
/* 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_ */

32
lang/pc/comp/tmpvar.xc
View file

@ -13,6 +13,7 @@
#include <em_arith.h>
#include <em_label.h>
#include <em_reg.h>
#include <em_code.h>
#include "def.h"
#include "main.h"
@ -32,17 +33,14 @@ static struct scope *ProcScope; /* scope of procedure in which the
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;
@ -50,10 +48,7 @@ TmpSpace(sz, al)
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;
@ -71,22 +66,17 @@ NewTmp(plist, sz, al, regtype, priority)
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();
@ -95,19 +85,17 @@ FreeTmp(plist, off)
*plist = tmp;
}
FreeInt(off)
arith off;
void FreeInt(arith off)
{
FreeTmp(&TmpInts, off);
}
FreePtr(off)
arith off;
void FreePtr(arith off)
{
FreeTmp(&TmpPtrs, off);
}
TmpClose()
void TmpClose(void)
{
register struct tmpvar *tmp, *tmp1;

5
lang/pc/comp/tokenname.c
View file

@ -2,8 +2,10 @@
#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
@ -84,8 +86,7 @@ struct tokenname tkstandard[] = { /* standard identifiers */
/* Some routines to handle tokennames */
reserve(resv)
register struct tokenname *resv;
void reserve(register struct tokenname *resv)
{
/* The names of the tokens described in resv are entered
as reserved words.

3
lang/pc/comp/tokenname.h
View file

@ -6,3 +6,6 @@ struct tokenname { /* Used for defining the name of a
int tn_symbol;
char *tn_name;
};
void reserve(register struct tokenname *resv);

94
lang/pc/comp/type.c
View file

@ -11,12 +11,19 @@
#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
@ -51,9 +58,15 @@ struct type
*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
*/
@ -75,7 +88,7 @@ CheckTypeSizes()
fatal("illegal realsize");
}
InitTypes()
void InitTypes(void)
{
/* First check the sizes of some basic EM-types
*/
@ -144,16 +157,12 @@ InitTypes()
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();
@ -166,9 +175,7 @@ standard_type(fund, algn, size)
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.
@ -212,10 +219,7 @@ construct_type(fund, tp)
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);
@ -224,11 +228,7 @@ proc_type(parameters, n_bytes_params)
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);
@ -237,9 +237,7 @@ func_type(parameters, n_bytes_params, 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;
@ -266,9 +264,7 @@ chk_type_id(ptp, nd)
}
}
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
@ -322,9 +318,7 @@ subr_type(lb, ub)
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
*/
@ -345,10 +339,7 @@ getbounds(tp, plo, phi)
}
}
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
@ -415,9 +406,7 @@ set_type(tp, packed)
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,
@ -444,9 +433,7 @@ ArrayElSize(tp, packed)
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
*/
@ -492,9 +479,7 @@ ArraySizes(tp)
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;
@ -503,7 +488,7 @@ FreeForward(for_type)
free_forwtype(for_type);
}
chk_forw_types()
void chk_forw_types(void)
{
/* check all forward references (in pointer types) */
@ -574,9 +559,8 @@ chk_forw_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).
@ -599,19 +583,14 @@ TstCaseConstants(nd, sel, sel1)
}
}
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
*/
@ -625,9 +604,7 @@ gcd(m, n)
return m;
}
int
lcm(m, n)
int m, n;
int lcm(int m, int n)
{
/* Least Common Multiple
*/
@ -635,8 +612,7 @@ lcm(m, n)
}
#ifdef DEBUG
DumpType(tp)
register struct type *tp;
void DumpType(register struct type *tp)
{
if( !tp ) return;

56
lang/pc/comp/type.xh
View file

@ -1,4 +1,8 @@
/* 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;
@ -160,16 +164,6 @@ extern arith
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)
@ -192,3 +186,45 @@ struct type
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

45
lang/pc/comp/typequiv.c
View file

@ -14,20 +14,17 @@
#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;
@ -45,9 +42,7 @@ IsString(tp)
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.
*/
@ -62,9 +57,7 @@ TstStrCompat(tp1, tp2)
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
*/
@ -110,9 +103,7 @@ TstCompat(tp1, tp2)
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
*/
@ -128,9 +119,7 @@ TstAssCompat(tp1, tp2)
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
*/
@ -150,18 +139,16 @@ TstParEquiv(tp1, tp2)
||
(
(
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
*/
@ -190,10 +177,8 @@ TstProcEquiv(tp1, tp2)
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.
*/
@ -231,9 +216,7 @@ TstParCompat(formaltype, actualtype, VARflag, nd, new_par_section)
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.

42
lang/pc/comp/typequiv.h Normal file
View file

@ -0,0 +1,42 @@
/* 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_ */