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

newer version

Browse source
This commit is contained in:
ceriel 1986-04-17 09:28:09 +00:00
parent 426c273de8
commit d3d6e637d6
18 changed files with 427 additions and 151 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -6,6 +6,11 @@ static char *RcsId = "$Header$";
#include <em_arith.h> #include <em_arith.h>
#include <em_label.h> #include <em_label.h>
#include <assert.h> #include <assert.h>
#include "idfsize.h"
#include "numsize.h"
#include "strsize.h"
#include "input.h" #include "input.h"
#include "f_info.h" #include "f_info.h"
#include "Lpars.h" #include "Lpars.h"
@ -15,14 +20,12 @@ static char *RcsId = "$Header$";
#include "LLlex.h" #include "LLlex.h"
#include "const.h" #include "const.h"
#define IDFSIZE 256 /* Number of significant characters in an identifier */
#define NUMSIZE 256 /* maximum number of characters in a number */
long str2long(); long str2long();
struct token dot, aside; struct token dot, aside;
struct type *numtype; struct type *numtype;
struct string string; struct string string;
int idfsize = IDFSIZE;
static static
SkipComment() SkipComment()
@ -73,7 +76,7 @@ GetString(upto)
register struct string *str = &string; register struct string *str = &string;
register char *p; register char *p;
str->s_str = p = Malloc(str->s_length = 32); str->s_str = p = Malloc((unsigned) (str->s_length = ISTRSIZE));
LoadChar(ch); LoadChar(ch);
while (ch != upto) { while (ch != upto) {
if (class(ch) == STNL) { if (class(ch) == STNL) {
@ -87,8 +90,10 @@ GetString(upto)
} }
*p++ = ch; *p++ = ch;
if (p - str->s_str == str->s_length) { if (p - str->s_str == str->s_length) {
str->s_str = Srealloc(str->s_str, str->s_length += 8); str->s_str = Srealloc(str->s_str,
p = str->s_str + (str->s_length - 8); str->s_length + RSTRSIZE);
p = str->s_str + str->s_length;
str->s_length += RSTRSIZE;
} }
LoadChar(ch); LoadChar(ch);
} }
@ -99,7 +104,7 @@ GetString(upto)
int int
LLlex() LLlex()
{ {
/* LLlex() plays the role of Lexical Analyzer for the parser. /* LLlex() is the Lexical Analyzer.
The putting aside of tokens is taken into account. The putting aside of tokens is taken into account.
*/ */
register struct token *tk = &dot; register struct token *tk = &dot;
@ -199,7 +204,7 @@ again:
register struct idf *id; register struct idf *id;
do { do {
if (tg - buf < IDFSIZE) *tg++ = ch; if (tg - buf < idfsize) *tg++ = ch;
LoadChar(ch); LoadChar(ch);
} while(in_idf(ch)); } while(in_idf(ch));

2
lang/m2/comp/LLlex.h
View file

@ -3,7 +3,7 @@
/* $Header$ */ /* $Header$ */
struct string { struct string {
int s_length; /* length of a string */ unsigned int s_length; /* length of a string */
char *s_str; /* the string itself */ char *s_str; /* the string itself */
}; };

25
lang/m2/comp/Makefile
View file

@ -12,19 +12,20 @@ CC = cc
GEN = LLgen GEN = LLgen
GENOPTIONS = GENOPTIONS =
PROFILE = PROFILE =
CFLAGS = -DDEBUG $(PROFILE) $(INCLUDES) CFLAGS = $(PROFILE) $(INCLUDES)
LFLAGS = $(PROFILE) LFLAGS = $(PROFILE)
LOBJ = tokenfile.o program.o declar.o expression.o statement.o LOBJ = tokenfile.o program.o declar.o expression.o statement.o
COBJ = LLlex.o LLmessage.o char.o error.o main.o \ COBJ = LLlex.o LLmessage.o char.o error.o main.o \
symbol2str.o tokenname.o idf.o input.o type.o def.o \ symbol2str.o tokenname.o idf.o input.o type.o def.o \
scope.o misc.o enter.o defmodule.o typequiv.o node.o \ scope.o misc.o enter.o defmodule.o typequiv.o node.o \
cstoper.o chk_expr.o cstoper.o chk_expr.o options.o
OBJ = $(COBJ) $(LOBJ) Lpars.o OBJ = $(COBJ) $(LOBJ) Lpars.o
GENFILES= tokenfile.c \ GENFILES= tokenfile.c \
program.c declar.c expression.c statement.c \ program.c declar.c expression.c statement.c \
tokenfile.g symbol2str.c char.c Lpars.c Lpars.h tokenfile.g symbol2str.c char.c Lpars.c Lpars.h
all: all:
make hfiles
make LLfiles make LLfiles
make main make main
@ -32,6 +33,10 @@ LLfiles: $(LSRC)
$(GEN) $(GENOPTIONS) $(LSRC) $(GEN) $(GENOPTIONS) $(LSRC)
@touch LLfiles @touch LLfiles
hfiles: Parameters make.hfiles
make.hfiles Parameters
touch hfiles
main: $(OBJ) Makefile main: $(OBJ) Makefile
$(CC) $(LFLAGS) $(OBJ) $(LIBDIR)/libcomp.a $(LIBDIR)/malloc.o /user1/erikb/em/lib/libprint.a /user1/erikb/em/lib/libstr.a /user1/erikb/em/lib/libsystem.a -o main $(CC) $(LFLAGS) $(OBJ) $(LIBDIR)/libcomp.a $(LIBDIR)/malloc.o /user1/erikb/em/lib/libprint.a /user1/erikb/em/lib/libstr.a /user1/erikb/em/lib/libsystem.a -o main
size main size main
@ -73,28 +78,28 @@ depend:
make.allocd < $< > $@ make.allocd < $< > $@
#AUTOAUTOAUTOAUTOAUTOAUTOAUTOAUTO #AUTOAUTOAUTOAUTOAUTOAUTOAUTOAUTO
LLlex.o: LLlex.h Lpars.h class.h f_info.h idf.h input.h LLlex.o: LLlex.h Lpars.h class.h const.h f_info.h idf.h idfsize.h input.h inputtype.h numsize.h strsize.h type.h
LLmessage.o: LLlex.h Lpars.h idf.h LLmessage.o: LLlex.h Lpars.h idf.h
char.o: class.h char.o: class.h
error.o: LLlex.h f_info.h input.h main.h node.h error.o: LLlex.h errout.h f_info.h input.h inputtype.h main.h node.h
main.o: LLlex.h Lpars.h debug.h def.h f_info.h idf.h input.h scope.h standards.h tokenname.h type.h main.o: LLlex.h Lpars.h debug.h def.h f_info.h idf.h input.h inputtype.h scope.h standards.h tokenname.h type.h
symbol2str.o: Lpars.h symbol2str.o: Lpars.h
tokenname.o: Lpars.h idf.h tokenname.h tokenname.o: Lpars.h idf.h tokenname.h
idf.o: idf.h idf.o: idf.h
input.o: f_info.h input.h input.o: f_info.h input.h inputtype.h
type.o: LLlex.h const.h debug.h def.h def_sizes.h idf.h node.h type.h type.o: LLlex.h const.h debug.h def.h idf.h node.h target_sizes.h type.h
def.o: LLlex.h debug.h def.h idf.h main.h node.h scope.h type.h def.o: LLlex.h debug.h def.h idf.h main.h node.h scope.h type.h
scope.o: LLlex.h debug.h def.h idf.h node.h scope.h type.h scope.o: LLlex.h debug.h def.h idf.h node.h scope.h type.h
misc.o: LLlex.h f_info.h idf.h misc.h node.h misc.o: LLlex.h f_info.h idf.h misc.h node.h
enter.o: LLlex.h def.h idf.h node.h scope.h type.h enter.o: LLlex.h def.h idf.h node.h scope.h type.h
defmodule.o: LLlex.h debug.h def.h f_info.h idf.h input.h scope.h defmodule.o: LLlex.h debug.h def.h f_info.h idf.h input.h inputtype.h scope.h
typequiv.o: def.h type.h typequiv.o: def.h type.h
node.o: LLlex.h debug.h def.h node.h type.h node.o: LLlex.h debug.h def.h node.h type.h
cstoper.o: LLlex.h Lpars.h def_sizes.h idf.h node.h standards.h type.h cstoper.o: LLlex.h Lpars.h idf.h node.h standards.h target_sizes.h type.h
chk_expr.o: LLlex.h Lpars.h const.h debug.h def.h idf.h node.h scope.h standards.h type.h chk_expr.o: LLlex.h Lpars.h const.h debug.h def.h idf.h node.h scope.h standards.h type.h
tokenfile.o: Lpars.h tokenfile.o: Lpars.h
program.o: LLlex.h Lpars.h debug.h def.h idf.h main.h node.h scope.h type.h program.o: LLlex.h Lpars.h debug.h def.h idf.h main.h node.h scope.h type.h
declar.o: LLlex.h Lpars.h def.h idf.h misc.h node.h scope.h type.h declar.o: LLlex.h Lpars.h def.h idf.h misc.h node.h scope.h type.h
expression.o: LLlex.h Lpars.h const.h debug.h def.h idf.h node.h scope.h type.h expression.o: LLlex.h Lpars.h const.h debug.h def.h idf.h node.h scope.h type.h
statement.o: LLlex.h Lpars.h node.h statement.o: LLlex.h Lpars.h node.h type.h
Lpars.o: Lpars.h Lpars.o: Lpars.h

60
lang/m2/comp/Parameters Normal file
View file

@ -0,0 +1,60 @@
!File: errout.h
#define ERROUT STDERR /* file pointer for writing messages */
#define MAXERR_LINE 5 /* maximum number of error messages given
on the same input line. */
!File: idfsize.h
#define IDFSIZE 30 /* maximum significant length of an identifier */
!File: numsize.h
#define NUMSIZE 256 /* maximum length of a numeric constant */
!File: strsize.h
#define ISTRSIZE 32 /* minimum number of bytes allocated for
storing a string */
#define RSTRSIZE 8 /* step size in enlarging the memory for
the storage of a string */
!File: target_sizes.h
#define MAXSIZE 8 /* the maximum of the SZ_* constants */
/* target machine sizes */
#define SZ_CHAR (arith)1
#define SZ_SHORT (arith)2
#define SZ_WORD (arith)4
#define SZ_INT (arith)4
#define SZ_LONG (arith)4
#define SZ_FLOAT (arith)4
#define SZ_DOUBLE (arith)8
#define SZ_POINTER (arith)4
/* target machine alignment requirements */
#define AL_CHAR 1
#define AL_SHORT SZ_SHORT
#define AL_WORD SZ_WORD
#define AL_INT SZ_WORD
#define AL_LONG SZ_WORD
#define AL_FLOAT SZ_WORD
#define AL_DOUBLE SZ_WORD
#define AL_POINTER SZ_WORD
#define AL_STRUCT 1
#define AL_UNION 1
!File: debug.h
#define DEBUG 1 /* perform various self-tests */
extern char options[];
#ifdef DEBUG
#define DO_DEBUG(n, x) ((n) <= options['D'] && (x))
#else
#define DO_DEBUG(n, x)
#endif DEBUG
!File: inputtype.h
#undef INP_READ_IN_ONE 1 /* read input file in one */

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

@ -79,7 +79,7 @@ chk_set(expp)
if (expp->nd_left) { if (expp->nd_left) {
/* A type was given. Check it out /* A type was given. Check it out
*/ */
(void) findname(expp->nd_left); findname(expp->nd_left);
assert(expp->nd_left->nd_class == Def); assert(expp->nd_left->nd_class == Def);
df = expp->nd_left->nd_def; df = expp->nd_left->nd_def;
if ((df->df_kind != D_TYPE && df->df_kind != D_ERROR) || if ((df->df_kind != D_TYPE && df->df_kind != D_ERROR) ||
@ -93,7 +93,7 @@ chk_set(expp)
/* Now check the elements given, and try to compute a constant set. /* Now check the elements given, and try to compute a constant set.
*/ */
set = (arith *) Malloc(tp->tp_size * sizeof(arith) / wrd_size); set = (arith *) Malloc(tp->tp_size * sizeof(arith) / word_size);
nd = expp->nd_right; nd = expp->nd_right;
while (nd) { while (nd) {
assert(nd->nd_class == Link && nd->nd_symb == ','); assert(nd->nd_class == Link && nd->nd_symb == ',');
@ -149,7 +149,7 @@ node_error(expp, "Lower bound exceeds upper bound in range");
} }
} }
else if (*set) { else if (*set) {
free(*set); free((char *) *set);
*set = 0; *set = 0;
} }
return 1; return 1;
@ -223,7 +223,7 @@ getname(argp, kinds)
return 0; return 0;
} }
argp = argp->nd_right; argp = argp->nd_right;
if (!findname(argp->nd_left)) return 0; findname(argp->nd_left);
assert(argp->nd_left->nd_class == Def); assert(argp->nd_left->nd_class == Def);
if (!(argp->nd_left->nd_def->df_kind & kinds)) { if (!(argp->nd_left->nd_def->df_kind & kinds)) {
node_error(argp, "Unexpected type"); node_error(argp, "Unexpected type");
@ -244,8 +244,8 @@ chk_call(expp)
register struct node *arg; register struct node *arg;
expp->nd_type = error_type; expp->nd_type = error_type;
(void) findname(expp->nd_left); /* parser made sure it is a name */
left = expp->nd_left; left = expp->nd_left;
findname(left);
if (left->nd_type == error_type) return 0; if (left->nd_type == error_type) return 0;
if (left->nd_class == Def && if (left->nd_class == Def &&
@ -451,8 +451,8 @@ findname(expp)
scope. scope.
*/ */
register struct def *df; register struct def *df;
struct def *lookfor();
register struct type *tp; register struct type *tp;
struct def *lookfor();
expp->nd_type = error_type; expp->nd_type = error_type;
if (expp->nd_class == Name) { if (expp->nd_class == Name) {
@ -498,18 +498,18 @@ df->df_idf->id_text);
} }
if (expp->nd_class == Oper) { if (expp->nd_class == Oper) {
assert(expp->nd_symb == '['); assert(expp->nd_symb == '[');
(void) findname(expp->nd_left); findname(expp->nd_left);
if (chk_expr(expp->nd_right, 0) && if (chk_expr(expp->nd_right) &&
expp->nd_left->nd_type != error_type && expp->nd_left->nd_type != error_type &&
chk_oper(expp)) /* ??? */ ; chk_oper(expp)) /* ??? */ ;
return 1; return;
} }
if (expp->nd_class == Uoper && expp->nd_symb == '^') { if (expp->nd_class == Uoper && expp->nd_symb == '^') {
(void) findname(expp->nd_right); findname(expp->nd_right);
if (expp->nd_right->nd_type != error_type && if (expp->nd_right->nd_type != error_type &&
chk_uoper(expp)) /* ??? */ ; chk_uoper(expp)) /* ??? */ ;
} }
return 0; return;
} }
int int
@ -518,7 +518,7 @@ chk_name(expp)
{ {
register struct def *df; register struct def *df;
(void) findname(expp); findname(expp);
assert(expp->nd_class == Def); assert(expp->nd_class == Def);
df = expp->nd_def; df = expp->nd_def;
if (df->df_kind == D_ERROR) return 0; if (df->df_kind == D_ERROR) return 0;

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

@ -5,7 +5,9 @@ static char *RcsId = "$Header$";
#include <em_arith.h> #include <em_arith.h>
#include <em_label.h> #include <em_label.h>
#include <assert.h> #include <assert.h>
#include "def_sizes.h"
#include "target_sizes.h"
#include "idf.h" #include "idf.h"
#include "type.h" #include "type.h"
#include "LLlex.h" #include "LLlex.h"
@ -211,7 +213,7 @@ cstset(expp)
assert(expp->nd_right->nd_class == Set); assert(expp->nd_right->nd_class == Set);
assert(expp->nd_symb == IN || expp->nd_left->nd_class == Set); assert(expp->nd_symb == IN || expp->nd_left->nd_class == Set);
set2 = expp->nd_right->nd_set; set2 = expp->nd_right->nd_set;
setsize = expp->nd_right->nd_type->tp_size / wrd_size; setsize = expp->nd_right->nd_type->tp_size / word_size;
if (expp->nd_symb == IN) { if (expp->nd_symb == IN) {
arith i; arith i;
@ -359,7 +361,8 @@ cstcall(expp, call)
cut_size(expp); cut_size(expp);
break; break;
case S_SIZE: case S_SIZE:
expp->nd_INT = align(expr->nd_type->tp_size, wrd_size)/wrd_size; expp->nd_INT = align(expr->nd_type->tp_size, (int) word_size) /
word_size;
break; break;
case S_VAL: case S_VAL:
expp->nd_INT = expr->nd_INT; expp->nd_INT = expr->nd_INT;
@ -435,12 +438,12 @@ init_cst()
} }
mach_long_size = i; mach_long_size = i;
mach_long_sign = 1 << (mach_long_size * 8 - 1); mach_long_sign = 1 << (mach_long_size * 8 - 1);
if (lint_size > mach_long_size) { if (long_size > mach_long_size) {
fatal("sizeof (long) insufficient on this machine"); fatal("sizeof (long) insufficient on this machine");
} }
max_int = full_mask[int_size] & ~(1 << (int_size * 8 - 1)); max_int = full_mask[int_size] & ~(1 << (int_size * 8 - 1));
max_unsigned = full_mask[int_size]; max_unsigned = full_mask[int_size];
max_longint = full_mask[lint_size] & ~(1 << (lint_size * 8 - 1)); max_longint = full_mask[long_size] & ~(1 << (long_size * 8 - 1));
wrd_bits = 8 * wrd_size; wrd_bits = 8 * word_size;
} }

57
lang/m2/comp/declar.g
View file

@ -25,7 +25,7 @@ ProcedureDeclaration
ProcedureHeading(&df, D_PROCEDURE) ProcedureHeading(&df, D_PROCEDURE)
{ df->prc_level = proclevel++; { df->prc_level = proclevel++;
} }
';' block IDENT ';' block(&(df->prc_body)) IDENT
{ match_id(dot.TOK_IDF, df->df_idf); { match_id(dot.TOK_IDF, df->df_idf);
df->prc_scope = CurrentScope; df->prc_scope = CurrentScope;
close_scope(SC_CHKFORW); close_scope(SC_CHKFORW);
@ -68,11 +68,17 @@ error("inconsistent procedure declaration for \"%s\"", df->df_idf->id_text);
} }
; ;
block block(struct node **pnd;)
{ {
struct node *nd;
}: }:
declaration* [ BEGIN StatementSequence(&nd) ]? END declaration*
[
BEGIN
StatementSequence(pnd)
|
{ *pnd = 0; }
]
END
; ;
declaration: declaration:
@ -101,7 +107,7 @@ FormalParameters(int doparams;
{ pr1 = *pr; } { pr1 = *pr; }
[ [
{ for (; pr1->next; pr1 = pr1->next) ; } { for (; pr1->next; pr1 = pr1->next) ; }
';' FPSection(doparams, &(pr1->next), &parmaddr) ';' FPSection(doparams, &(pr1->next), parmaddr)
]* ]*
]? ]?
')' ')'
@ -149,8 +155,8 @@ FormalType(struct type **tp;)
{ if (ARRAYflag) { { if (ARRAYflag) {
*tp = construct_type(T_ARRAY, NULLTYPE); *tp = construct_type(T_ARRAY, NULLTYPE);
(*tp)->arr_elem = df->df_type; (*tp)->arr_elem = df->df_type;
(*tp)->tp_align = lcm(wrd_align, ptr_align); (*tp)->tp_align = lcm(word_align, pointer_align);
(*tp)->tp_size = align(ptr_size + 3*wrd_size, (*tp)->tp_size = align(pointer_size + 3*word_size,
(*tp)->tp_align); (*tp)->tp_align);
} }
else *tp = df->df_type; else *tp = df->df_type;
@ -221,17 +227,17 @@ enumeration(struct type **ptp;)
} : } :
'(' IdentList(&EnumList) ')' '(' IdentList(&EnumList) ')'
{ {
*ptp = standard_type(T_ENUMERATION,1,1); *ptp = standard_type(T_ENUMERATION, 1, (arith) 1);
EnterIdList(EnumList, D_ENUM, 0, *ptp, EnterIdList(EnumList, D_ENUM, 0, *ptp,
CurrentScope, (arith *) 0); CurrentScope, (arith *) 0);
FreeNode(EnumList); FreeNode(EnumList);
if ((*ptp)->enm_ncst > 256) { if ((*ptp)->enm_ncst > 256) {
if (wrd_size == 1) { if (word_size == 1) {
error("Too many enumeration literals"); error("Too many enumeration literals");
} }
else { else {
(*ptp)->tp_size = wrd_size; (*ptp)->tp_size = word_size;
(*ptp)->tp_align = wrd_align; (*ptp)->tp_align = word_align;
} }
} }
} }
@ -291,7 +297,7 @@ RecordType(struct type **ptp;)
{ {
struct scope *scope; struct scope *scope;
arith count; arith count;
int xalign = record_align; int xalign = struct_align;
} }
: :
RECORD RECORD
@ -391,28 +397,43 @@ FieldList(struct scope *scope; arith *cnt; int *palign;)
variant(struct scope *scope; arith *cnt; struct type *tp; int *palign;) variant(struct scope *scope; arith *cnt; struct type *tp; int *palign;)
{ {
struct type *tp1 = tp; struct type *tp1 = tp;
struct node *nd;
} : } :
[ [
CaseLabelList(&tp1) ':' FieldListSequence(scope, cnt, palign) CaseLabelList(&tp1, &nd)
{ /* Ignore the cases for the time being.
Maybe a checking version will be supplied
later ???
*/
FreeNode(nd);
}
':' FieldListSequence(scope, cnt, palign)
]? ]?
/* Changed rule in new modula-2 */ /* Changed rule in new modula-2 */
; ;
CaseLabelList(struct type **ptp;): CaseLabelList(struct type **ptp; struct node **pnd;):
CaseLabels(ptp) [ ',' CaseLabels(ptp) ]* CaseLabels(ptp, pnd)
[
{ *pnd = MkNode(Link, *pnd, NULLNODE, &dot); }
',' CaseLabels(ptp, &((*pnd)->nd_right))
{ pnd = &((*pnd)->nd_right); }
]*
; ;
CaseLabels(struct type **ptp;) CaseLabels(struct type **ptp; struct node **pnd;)
{ {
struct node *nd1, *nd2 = 0; struct node *nd1, *nd2 = 0;
}: }:
ConstExpression(&nd1) ConstExpression(&nd1) { *pnd = nd1; }
[ [
UPTO ConstExpression(&nd2) UPTO { *pnd = MkNode(Link,nd1,NULLNODE,&dot); }
ConstExpression(&nd2)
{ if (!TstCompat(nd1->nd_type, nd2->nd_type)) { { if (!TstCompat(nd1->nd_type, nd2->nd_type)) {
node_error(nd2,"type incompatibility in case label"); node_error(nd2,"type incompatibility in case label");
} }
nd1->nd_type = error_type; nd1->nd_type = error_type;
(*pnd)->nd_right = nd2;
} }
]? ]?
{ if (*ptp != 0 && { if (*ptp != 0 &&

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

@ -3,10 +3,12 @@
/* $Header$ */ /* $Header$ */
struct module { struct module {
int mo_priority; /* priority of a module */ arith mo_priority; /* priority of a module */
struct scope *mo_scope; /* scope of this module */ struct scope *mo_scope; /* scope of this module */
struct node *mo_body; /* body of this module */
#define mod_priority df_value.df_module.mo_priority #define mod_priority df_value.df_module.mo_priority
#define mod_scope df_value.df_module.mo_scope #define mod_scope df_value.df_module.mo_scope
#define mod_body df_value.df_module.mo_body
}; };
struct variable { struct variable {
@ -43,9 +45,11 @@ struct dfproc {
struct scope *pr_scope; /* scope of procedure */ struct scope *pr_scope; /* scope of procedure */
int pr_level; /* depth level of this procedure */ int pr_level; /* depth level of this procedure */
arith pr_nbpar; /* Number of bytes parameters */ arith pr_nbpar; /* Number of bytes parameters */
struct node *pr_body; /* body of this procedure */
#define prc_scope df_value.df_proc.pr_scope #define prc_scope df_value.df_proc.pr_scope
#define prc_level df_value.df_proc.pr_level #define prc_level df_value.df_proc.pr_level
#define prc_nbpar df_value.df_proc.pr_nbpar #define prc_nbpar df_value.df_proc.pr_nbpar
#define prc_body df_value.df_proc.pr_body
}; };
struct import { struct import {

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

@ -9,15 +9,15 @@ static char *RcsId = "$Header$";
#include <system.h> #include <system.h>
#include <em_arith.h> #include <em_arith.h>
#include "errout.h"
#include "input.h" #include "input.h"
#include "f_info.h" #include "f_info.h"
#include "LLlex.h" #include "LLlex.h"
#include "main.h" #include "main.h"
#include "node.h" #include "node.h"
#define MAXERR_LINE 5 /* Number of error messages on one line ... */
#define ERROUT STDERR
/* error classes */ /* error classes */
#define ERROR 1 #define ERROR 1
#define WARNING 2 #define WARNING 2

2
lang/m2/comp/input.h
View file

@ -2,6 +2,8 @@
/* $Header$ */ /* $Header$ */
#include "inputtype.h"
#define INP_NPUSHBACK 2 #define INP_NPUSHBACK 2
#define INP_TYPE struct f_info #define INP_TYPE struct f_info
#define INP_VAR file_info #define INP_VAR file_info

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

@ -28,14 +28,14 @@ char *getenv();
main(argc, argv) main(argc, argv)
char *argv[]; char *argv[];
{ {
register Nargc = 1; register int Nargc = 1;
register char **Nargv = &argv[0]; register char **Nargv = &argv[0];
ProgName = *argv++; ProgName = *argv++;
while (--argc > 0) { while (--argc > 0) {
if (**argv == '-') if (**argv == '-')
Option(*argv++); do_option((*argv++) + 1);
else else
Nargv[Nargc++] = *argv++; Nargv[Nargc++] = *argv++;
} }
@ -71,16 +71,14 @@ Compile(src)
init_types(); init_types();
add_standards(); add_standards();
#ifdef DEBUG #ifdef DEBUG
if (options['L']) LexScan(); if (options['l']) LexScan();
else { else
#endif DEBUG #endif DEBUG
{
(void) open_scope(CLOSEDSCOPE); (void) open_scope(CLOSEDSCOPE);
GlobalScope = CurrentScope; GlobalScope = CurrentScope;
CompUnit(); CompUnit();
#ifdef DEBUG
} }
if (options['h']) hash_stat();
#endif DEBUG
if (err_occurred) return 0; if (err_occurred) return 0;
return 1; return 1;
} }
@ -117,12 +115,6 @@ LexScan()
} }
#endif #endif
Option(str)
char *str;
{
options[str[1]]++; /* switch option on */
}
add_standards() add_standards()
{ {
register struct def *df; register struct def *df;

35
lang/m2/comp/make.hfiles Executable file
View file

@ -0,0 +1,35 @@
: Update Files from database
PATH=/bin:/usr/bin
case $# in
1) ;;
*) echo use: $0 file >&2
exit 1
esac
(
IFCOMMAND="if (<\$FN) 2>/dev/null;\
then if cmp -s \$FN \$TMP;\
then rm \$TMP;\
else mv \$TMP \$FN;\
echo update \$FN;\
fi;\
else mv \$TMP \$FN;\
echo create \$FN;\
fi"
echo 'TMP=.uf$$'
echo 'FN=$TMP'
echo 'cat >$TMP <<\!EOF!'
sed -n '/^!File:/,${
/^$/d
/^!File:[ ]*\(.*\)$/s@@!EOF!\
'"$IFCOMMAND"'\
FN=\1\
cat >$TMP <<\\!EOF!@
p
}' $1
echo '!EOF!'
echo $IFCOMMAND
) |
sh

114
lang/m2/comp/options.c Normal file
View file

@ -0,0 +1,114 @@
/* U S E R O P T I O N - H A N D L I N G */
static char *RcsId = "$Header$";
#include <em_arith.h>
#include <em_label.h>
#include "idfsize.h"
#include "type.h"
extern char options[];
extern int idfsize;
do_option(text)
char *text;
{
switch(*text++) {
default:
options[text[-1]] = 1; /* flags, debug options etc. */
break;
case 'L' :
warning("-L: default no EM profiling; use -p for EM profiling");
break;
case 'M': /* maximum identifier length */
idfsize = txt2int(&text);
if (*text || idfsize <= 0)
fatal("malformed -M option");
if (idfsize > IDFSIZE)
fatal("maximum identifier length is %d", IDFSIZE);
break;
case 'p' : /* generate profiling code (fil/lin) */
options['p'] = 1;
break;
case 'V' : /* set object sizes and alignment requirements */
{
arith size;
int align;
char c;
while (c = *text++) {
size = txt2int(&text);
align = 0;
if (*text == '.') {
text++;
align = txt2int(&text);
}
switch (c) {
case 'w': /* word */
if (size != (arith)0) word_size = size;
if (align != 0) word_align = align;
break;
case 'i': /* int */
if (size != (arith)0) int_size = size;
if (align != 0) int_align = align;
break;
case 'l': /* longint */
if (size != (arith)0) long_size = size;
if (align != 0) long_align = align;
break;
case 'f': /* real */
if (size != (arith)0) float_size = size;
if (align != 0) float_align = align;
break;
case 'd': /* longreal */
if (size != (arith)0) double_size = size;
if (align != 0) double_align = align;
break;
case 'p': /* pointer */
if (size != (arith)0) pointer_size = size;
if (align != 0) pointer_align = align;
break;
case 'S': /* initial record alignment */
if (align != (arith)0) struct_align = align;
break;
default:
error("-V: bad type indicator %c\n", c);
}
}
break;
}
case 'n':
options['n'] = 1; /* use no registers */
break;
case 'w':
options['w'] = 1; /* no warnings will be given */
break;
}
}
int
txt2int(tp)
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;
}

71
lang/m2/comp/program.g
View file

@ -43,7 +43,7 @@ static int DEFofIMPL = 0; /* Flag indicating that we are currently
ModuleDeclaration ModuleDeclaration
{ {
struct idf *id; struct idf *id;
struct def *df; register struct def *df;
} : } :
MODULE IDENT { MODULE IDENT {
id = dot.TOK_IDF; id = dot.TOK_IDF;
@ -57,20 +57,27 @@ ModuleDeclaration
standard_type(T_RECORD, 0, (arith) 0); standard_type(T_RECORD, 0, (arith) 0);
df->df_type->rec_scope = df->mod_scope; df->df_type->rec_scope = df->mod_scope;
} }
priority? ';' priority(&(df->mod_priority))?
';'
import(1)* import(1)*
export(0)? export(0)?
block block(&(df->mod_body))
IDENT { close_scope(SC_CHKFORW|SC_CHKPROC); IDENT { close_scope(SC_CHKFORW|SC_CHKPROC);
match_id(id, dot.TOK_IDF); match_id(id, dot.TOK_IDF);
} }
; ;
priority priority(arith *pprio;)
{ {
struct node *nd; struct node *nd;
}: } :
'[' ConstExpression(&nd) ']' '[' ConstExpression(&nd) ']'
{ if (!(nd->nd_type->tp_fund & T_INTORCARD)) {
node_error(nd, "Illegal priority");
}
*pprio = nd->nd_INT;
FreeNode(nd);
}
; ;
export(int def;) export(int def;)
@ -161,7 +168,7 @@ definition
{ {
struct def *df; struct def *df;
} : } :
CONST [ ConstantDeclaration ';' ]* CONST [ ConstantDeclaration Semicolon ]*
| |
TYPE TYPE
[ IDENT { df = define(dot.TOK_IDF, CurrentScope, D_TYPE); } [ IDENT { df = define(dot.TOK_IDF, CurrentScope, D_TYPE); }
@ -175,38 +182,48 @@ definition
{ df->df_kind = D_HIDDEN; { df->df_kind = D_HIDDEN;
} }
] ]
';' Semicolon
]* ]*
| |
VAR [ VariableDeclaration ';' ]* VAR [ VariableDeclaration Semicolon ]*
| |
ProcedureHeading(&df, D_PROCHEAD) ';' ProcedureHeading(&df, D_PROCHEAD) Semicolon
;
Semicolon:
';'
|
{ warning("; expected"); }
; ;
ProgramModule(int state;) ProgramModule(int state;)
{ {
struct idf *id; struct idf *id;
struct def *df, *GetDefinitionModule(); struct def *GetDefinitionModule();
struct scope *scope = 0; register struct def *df;
} : } :
MODULE MODULE
IDENT { IDENT {
id = dot.TOK_IDF; id = dot.TOK_IDF;
if (state == IMPLEMENTATION) { if (state == IMPLEMENTATION) {
DEFofIMPL = 1; DEFofIMPL = 1;
df = GetDefinitionModule(id); df = GetDefinitionModule(id);
CurrentScope = df->mod_scope; CurrentScope = df->mod_scope;
DEFofIMPL = 0; DEFofIMPL = 0;
DefinitionModule = 0; DefinitionModule = 0;
} }
else open_scope(CLOSEDSCOPE); else {
} df = define(id, CurrentScope, D_MODULE);
priority? open_scope(CLOSEDSCOPE);
df->mod_scope = CurrentScope;
}
}
priority(&(df->mod_priority))?
';' import(0)* ';' import(0)*
block IDENT block(&(df->mod_body)) IDENT
{ close_scope(SC_CHKFORW|SC_CHKPROC); { close_scope(SC_CHKFORW|SC_CHKPROC);
match_id(id, dot.TOK_IDF); match_id(id, dot.TOK_IDF);
} }
'.' '.'
; ;

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

@ -23,7 +23,6 @@ open_scope(scopetype)
/* Open a scope that is either open (automatic imports) or closed. /* Open a scope that is either open (automatic imports) or closed.
*/ */
register struct scope *sc = new_scope(); register struct scope *sc = new_scope();
register struct scope *sc1;
assert(scopetype == OPENSCOPE || scopetype == CLOSEDSCOPE); assert(scopetype == OPENSCOPE || scopetype == CLOSEDSCOPE);
sc->sc_scopeclosed = scopetype == CLOSEDSCOPE; sc->sc_scopeclosed = scopetype == CLOSEDSCOPE;
@ -161,6 +160,24 @@ rem_forwards(fo)
} }
} }
Reverse(pdf)
register struct def **pdf;
{
/* Reverse the order in the list of definitions in a scope.
This is neccesary because this list is built in reverse.
*/
register struct def *df, *df1;
df = 0;
df1 = *pdf;
while (df1) {
df1 = df1->df_nextinscope;
(*pdf)->df_nextinscope = df;
df = *pdf;
*pdf = df1;
}
}
close_scope(flag) close_scope(flag)
{ {
/* Close a scope. If "flag" is set, check for forward declarations, /* Close a scope. If "flag" is set, check for forward declarations,
@ -177,6 +194,7 @@ close_scope(flag)
DO_DEBUG(2, PrScopeDef(sc->sc_def)); DO_DEBUG(2, PrScopeDef(sc->sc_def));
if (flag & SC_CHKPROC) chk_proc(sc->sc_def); if (flag & SC_CHKPROC) chk_proc(sc->sc_def);
if (flag & SC_CHKFORW) chk_forw(&(sc->sc_def)); if (flag & SC_CHKFORW) chk_forw(&(sc->sc_def));
Reverse(&(sc->sc_def));
} }
CurrentScope = sc->next; CurrentScope = sc->next;
} }

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

@ -4,7 +4,9 @@
static char *RcsId = "$Header$"; static char *RcsId = "$Header$";
#include <em_arith.h> #include <em_arith.h>
#include <em_label.h>
#include "LLlex.h" #include "LLlex.h"
#include "type.h"
#include "node.h" #include "node.h"
static int loopcount = 0; /* Count nested loops */ static int loopcount = 0; /* Count nested loops */
@ -12,7 +14,7 @@ static int loopcount = 0; /* Count nested loops */
statement(struct node **pnd;) statement(struct node **pnd;)
{ {
struct node *nd1; register struct node *nd;
} : } :
{ *pnd = 0; } { *pnd = 0; }
[ [
@ -21,16 +23,16 @@ statement(struct node **pnd;)
* states : assignment | ProcedureCall | ... * states : assignment | ProcedureCall | ...
* but this gives LL(1) conflicts * but this gives LL(1) conflicts
*/ */
designator(&nd1) designator(pnd)
[ { nd1 = MkNode(Call, nd1, NULLNODE, &dot); [ { nd = MkNode(Call, *pnd, NULLNODE, &dot);
nd1->nd_symb = '('; nd->nd_symb = '(';
} }
ActualParameters(&(nd1->nd_right))? ActualParameters(&(nd->nd_right))?
| |
BECOMES { nd1 = MkNode(Stat, nd1, NULLNODE, &dot); } BECOMES { nd = MkNode(Stat, *pnd, NULLNODE, &dot); }
expression(&(nd1->nd_right)) expression(&(nd->nd_right))
] ]
{ *pnd = nd1; } { *pnd = nd; }
/* /*
* end of changed part * end of changed part
*/ */
@ -58,9 +60,9 @@ statement(struct node **pnd;)
*pnd = MkNode(Stat, NULLNODE, NULLNODE, &dot); *pnd = MkNode(Stat, NULLNODE, NULLNODE, &dot);
} }
| |
RETURN { *pnd = MkNode(Stat, NULLNODE, NULLNODE, &dot); } RETURN { *pnd = nd = MkNode(Stat, NULLNODE, NULLNODE, &dot); }
[ [
expression(&((*pnd)->nd_right)) expression(&(nd->nd_right))
]? ]?
]? ]?
; ;
@ -138,7 +140,7 @@ CaseStatement(struct node **pnd;)
case(struct node **pnd; struct type **ptp;) : case(struct node **pnd; struct type **ptp;) :
{ *pnd = 0; } { *pnd = 0; }
[ CaseLabelList(ptp/*,pnd*/) [ CaseLabelList(ptp, pnd)
':' { *pnd = MkNode(Link, *pnd, NULLNODE, &dot); } ':' { *pnd = MkNode(Link, *pnd, NULLNODE, &dot); }
StatementSequence(&((*pnd)->nd_right)) StatementSequence(&((*pnd)->nd_right))
]? ]?

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

@ -102,21 +102,21 @@ extern struct type
*error_type; /* All from type.c */ *error_type; /* All from type.c */
extern int extern int
wrd_align, word_align,
int_align, int_align,
lint_align, long_align,
real_align, float_align,
lreal_align, double_align,
ptr_align, pointer_align,
record_align; /* All from type.c */ struct_align; /* All from type.c */
extern arith extern arith
wrd_size, word_size,
int_size, int_size,
lint_size, long_size,
real_size, float_size,
lreal_size, double_size,
ptr_size; /* All from type.c */ pointer_size; /* All from type.c */
extern arith extern arith
align(); /* type.c */ align(); /* type.c */

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

@ -6,34 +6,36 @@ static char *RcsId = "$Header$";
#include <alloc.h> #include <alloc.h>
#include <em_arith.h> #include <em_arith.h>
#include <em_label.h> #include <em_label.h>
#include "def_sizes.h"
#include "target_sizes.h"
#include "debug.h"
#include "def.h" #include "def.h"
#include "type.h" #include "type.h"
#include "idf.h" #include "idf.h"
#include "LLlex.h" #include "LLlex.h"
#include "node.h" #include "node.h"
#include "const.h" #include "const.h"
#include "debug.h"
/* To be created dynamically in main() from defaults or from command /* To be created dynamically in main() from defaults or from command
line parameters. line parameters.
*/ */
int int
wrd_align = AL_WORD, word_align = AL_WORD,
int_align = AL_INT, int_align = AL_INT,
lint_align = AL_LONG, long_align = AL_LONG,
real_align = AL_FLOAT, float_align = AL_FLOAT,
lreal_align = AL_DOUBLE, double_align = AL_DOUBLE,
ptr_align = AL_POINTER, pointer_align = AL_POINTER,
record_align = AL_STRUCT; struct_align = AL_STRUCT;
arith arith
wrd_size = SZ_WORD, word_size = SZ_WORD,
int_size = SZ_INT, int_size = SZ_INT,
lint_size = SZ_LONG, long_size = SZ_LONG,
real_size = SZ_FLOAT, float_size = SZ_FLOAT,
lreal_size = SZ_DOUBLE, double_size = SZ_DOUBLE,
ptr_size = SZ_POINTER; pointer_size = SZ_POINTER;
struct type struct type
*bool_type, *bool_type,
@ -83,12 +85,12 @@ construct_type(fund, tp)
switch (fund) { switch (fund) {
case T_PROCEDURE: case T_PROCEDURE:
case T_POINTER: case T_POINTER:
dtp->tp_align = ptr_align; dtp->tp_align = pointer_align;
dtp->tp_size = ptr_size; dtp->tp_size = pointer_size;
dtp->next = tp; dtp->next = tp;
break; break;
case T_SET: case T_SET:
dtp->tp_align = wrd_align; dtp->tp_align = word_align;
dtp->next = tp; dtp->next = tp;
break; break;
case T_ARRAY: case T_ARRAY:
@ -135,17 +137,17 @@ init_types()
bool_type = standard_type(T_ENUMERATION, 1, (arith) 1); bool_type = standard_type(T_ENUMERATION, 1, (arith) 1);
bool_type->enm_ncst = 2; bool_type->enm_ncst = 2;
int_type = standard_type(T_INTEGER, int_align, int_size); int_type = standard_type(T_INTEGER, int_align, int_size);
longint_type = standard_type(T_INTEGER, lint_align, lint_size); longint_type = standard_type(T_INTEGER, long_align, long_size);
card_type = standard_type(T_CARDINAL, int_align, int_size); card_type = standard_type(T_CARDINAL, int_align, int_size);
real_type = standard_type(T_REAL, real_align, real_size); real_type = standard_type(T_REAL, float_align, float_size);
longreal_type = standard_type(T_REAL, lreal_align, lreal_size); longreal_type = standard_type(T_REAL, double_align, double_size);
word_type = standard_type(T_WORD, wrd_align, wrd_size); word_type = standard_type(T_WORD, word_align, word_size);
intorcard_type = standard_type(T_INTORCARD, int_align, int_size); intorcard_type = standard_type(T_INTORCARD, int_align, int_size);
string_type = standard_type(T_STRING, 1, (arith) -1); string_type = standard_type(T_STRING, 1, (arith) -1);
address_type = construct_type(T_POINTER, word_type); address_type = construct_type(T_POINTER, word_type);
tp = construct_type(T_SUBRANGE, int_type); tp = construct_type(T_SUBRANGE, int_type);
tp->sub_lb = 0; tp->sub_lb = 0;
tp->sub_ub = wrd_size * 8 - 1; tp->sub_ub = word_size * 8 - 1;
bitset_type = set_type(tp); bitset_type = set_type(tp);
std_type = construct_type(T_PROCEDURE, NULLTYPE); std_type = construct_type(T_PROCEDURE, NULLTYPE);
error_type = standard_type(T_CHAR, 1, (arith) 1); error_type = standard_type(T_CHAR, 1, (arith) 1);
@ -265,7 +267,7 @@ set_type(tp)
/* Construct a set type with base type "tp", but first /* Construct a set type with base type "tp", but first
perform some checks perform some checks
*/ */
int lb, ub; arith lb, ub;
if (tp->tp_fund == T_SUBRANGE) { if (tp->tp_fund == T_SUBRANGE) {
if ((lb = tp->sub_lb) < 0 || (ub = tp->sub_ub) > MAX_SET - 1) { if ((lb = tp->sub_lb) < 0 || (ub = tp->sub_ub) > MAX_SET - 1) {
@ -285,7 +287,7 @@ set_type(tp)
return error_type; return error_type;
} }
tp = construct_type(T_SET, tp); tp = construct_type(T_SET, tp);
tp->tp_size = align(((ub - lb) + 7)/8, wrd_align); tp->tp_size = align(((ub - lb) + 7)/8, word_align);
return tp; return tp;
} }
@ -346,13 +348,9 @@ gcd(m, n)
int int
lcm(m, n) lcm(m, n)
register int m, n; int m, n;
{ {
/* Least Common Multiple /* Least Common Multiple
*/ */
while (m != n) { return m * (n / gcd(m, n));
if (m < n) m = m + m;
else n = n + n;
}
return n; /* or m */
} }