--- /dev/null
+# define FORT
+# include "order.c"
--- /dev/null
+# define FORT
+/* this forces larger trees, etc. */
+# include "mfile2"
+# include "fort.h"
+
+/* masks for unpacking longs */
+
+# ifndef FOP
+# define FOP(x) (int)((x)&0377)
+# endif
+
+# ifndef VAL
+# define VAL(x) (int)(((x)>>8)&0377)
+# endif
+
+# ifndef REST
+# define REST(x) (((x)>>16)&0177777)
+# endif
+
+FILE * lrd; /* for default reading routines */
+# ifndef NOLREAD
+long lread(){
+ static long x;
+ if( fread( (char *) &x, 4, 1, lrd ) <= 0 ) cerror( "intermediate file read error" );
+ return( x );
+ }
+# endif
+
+# ifndef NOLOPEN
+lopen( s ) char *s; {
+ /* if null, opens the standard input */
+ if( *s ){
+ lrd = fopen( s, "r" );
+ if( lrd == NULL ) cerror( "cannot open intermediate file %s", s );
+ }
+ else lrd = stdin;
+ }
+# endif
+
+# ifndef NOLCREAD
+lcread( cp, n ) char *cp; {
+ if( n > 0 ){
+ if( fread( cp, 4, n, lrd ) != n ) cerror( "intermediate file read error" );
+ }
+ }
+# endif
+
+# ifndef NOLCCOPY
+lccopy( n ) register n; {
+ register i;
+ static char fbuf[128];
+ if( n > 0 ){
+ if( n > 32 ) cerror( "lccopy asked to copy too much" );
+ if( fread( fbuf, 4, n, lrd ) != n ) cerror( "intermediate file read error" );
+ for( i=4*n; fbuf[i-1] == '\0' && i>0; --i ) { /* VOID */ }
+ if( i ) {
+ if( fwrite( fbuf, 1, i, stdout ) != i ) cerror( "output file error" );
+ }
+ }
+ }
+# endif
+
+/* new opcode definitions */
+
+# define FORTOPS 200
+# define FTEXT 200
+# define FEXPR 201
+# define FSWITCH 202
+# define FLBRAC 203
+# define FRBRAC 204
+# define FEOF 205
+# define FARIF 206
+# define LABEL 207
+
+/* stack for reading nodes in postfix form */
+
+# define NSTACKSZ 250
+
+NODE * fstack[NSTACKSZ];
+NODE ** fsp; /* points to next free position on the stack */
+
+mainp2( argc, argv ) char *argv[]; {
+ int files;
+ register long x;
+ register NODE *p;
+
+ files = p2init( argc, argv );
+ tinit();
+
+
+ if( files ){
+ while( files < argc && argv[files][0] == '-' ) {
+ ++files;
+ }
+ if( files > argc ) return( nerrors );
+ lopen( argv[files] );
+ }
+ else lopen( "" );
+
+ fsp = fstack;
+
+ for(;;){
+ /* read nodes, and go to work... */
+ x = lread();
+
+ if( xdebug ) fprintf( stderr, "op=%d, val = %d, rest = 0%o\n", FOP(x), VAL(x), (int)REST(x) );
+ switch( (int)FOP(x) ){ /* switch on opcode */
+
+ case 0:
+ fprintf( stderr, "null opcode ignored\n" );
+ continue;
+ case FTEXT:
+ lccopy( VAL(x) );
+ printf( "\n" );
+ continue;
+
+ case FLBRAC:
+ tmpoff = baseoff = lread();
+ maxtreg = VAL(x);
+ if( ftnno != REST(x) ){
+ /* beginning of function */
+ maxoff = baseoff;
+ ftnno = REST(x);
+ maxtemp = 0;
+ }
+ else {
+ if( baseoff > maxoff ) maxoff = baseoff;
+ /* maxoff at end of ftn is max of autos and temps
+ over all blocks in the function */
+ }
+ setregs();
+ continue;
+
+ case FRBRAC:
+ SETOFF( maxoff, ALSTACK );
+ eobl2();
+ continue;
+
+ case FEOF:
+ return( nerrors );
+
+ case FSWITCH:
+ uerror( "switch not yet done" );
+ for( x=VAL(x); x>0; --x ) lread();
+ continue;
+
+ case ICON:
+ p = talloc();
+ p->op = ICON;
+ p->type = REST(x);
+ p->rval = 0;
+ p->lval = lread();
+ if( VAL(x) ){
+ lcread( p->name, 2 );
+ }
+ else p->name[0] = '\0';
+
+ bump:
+ p->su = 0;
+ p->rall = NOPREF;
+ *fsp++ = p;
+ if( fsp >= &fstack[NSTACKSZ] ) uerror( "expression depth exceeded" );
+ continue;
+
+ case NAME:
+ p = talloc();
+ p->op = NAME;
+ p->type = REST(x);
+ p->rval = 0;
+ if( VAL(x) ) p->lval = lread();
+ else p->lval = 0;
+ lcread( p->name, 2 );
+ goto bump;
+
+ case OREG:
+ p = talloc();
+ p->op = OREG;
+ p->type = REST(x);
+ p->rval = VAL(x);
+ p->lval = lread();
+ lcread( p->name, 2 );
+ goto bump;
+
+ case REG:
+ p = talloc();
+ p->op = REG;
+ p->type = REST(x);
+ p->rval = VAL(x);
+ rbusy( p->rval, p->type );
+ p->lval = 0;
+ p->name[0] = '\0';
+ goto bump;
+
+ case FEXPR:
+ lineno = REST(x);
+ if( VAL(x) ) lcread( filename, VAL(x) );
+ if( fsp == fstack ) continue; /* filename only */
+ if( --fsp != fstack ) uerror( "expression poorly formed" );
+ if( lflag ) lineid( lineno, filename );
+ tmpoff = baseoff;
+ p = fstack[0];
+ if( edebug ) fwalk( p, eprint, 0 );
+# ifdef MYREADER
+ MYREADER(p);
+# endif
+
+ nrecur = 0;
+ delay( p );
+ reclaim( p, RNULL, 0 );
+
+ allchk();
+ tcheck();
+ continue;
+
+ case LABEL:
+ if( VAL(x) ){
+ tlabel();
+ }
+ else {
+ label( (int) REST(x) );
+ }
+ continue;
+
+ case GOTO:
+ if( VAL(x) ) {
+ cbgen( 0, (int) REST(x), 'I' ); /* unconditional branch */
+ continue;
+ }
+ /* otherwise, treat as unary */
+ goto def;
+
+ default:
+ def:
+ p = talloc();
+ p->op = FOP(x);
+ p->type = REST(x);
+
+ switch( optype( p->op ) ){
+
+ case BITYPE:
+ p->right = *--fsp;
+ p->left = *--fsp;
+ goto bump;
+
+ case UTYPE:
+ p->left = *--fsp;
+ p->rval = 0;
+ goto bump;
+
+ case LTYPE:
+ uerror( "illegal leaf node: %d", p->op );
+ exit( 1 );
+ }
+ }
+ }
+ }
--- /dev/null
+# define FORT
+# define NOMAIN
+# include "reader.c"
--- /dev/null
+# define FORT
+# include "table.c"
--- /dev/null
+
+# include <stdio.h>
+/* manifest constant file for the lex/yacc interface */
+
+# define ERROR 1
+# define NAME 2
+# define STRING 3
+# define ICON 4
+# define FCON 5
+# define PLUS 6
+# define MINUS 8
+# define MUL 11
+# define AND 14
+# define OR 17
+# define ER 19
+# define QUEST 21
+# define COLON 22
+# define ANDAND 23
+# define OROR 24
+
+/* special interfaces for yacc alone */
+/* These serve as abbreviations of 2 or more ops:
+ ASOP =, = ops
+ RELOP LE,LT,GE,GT
+ EQUOP EQ,NE
+ DIVOP DIV,MOD
+ SHIFTOP LS,RS
+ ICOP ICR,DECR
+ UNOP NOT,COMPL
+ STROP DOT,STREF
+
+ */
+# define ASOP 25
+# define RELOP 26
+# define EQUOP 27
+# define DIVOP 28
+# define SHIFTOP 29
+# define INCOP 30
+# define UNOP 31
+# define STROP 32
+
+/* reserved words, etc */
+# define TYPE 33
+# define CLASS 34
+# define STRUCT 35
+# define RETURN 36
+# define GOTO 37
+# define IF 38
+# define ELSE 39
+# define SWITCH 40
+# define BREAK 41
+# define CONTINUE 42
+# define WHILE 43
+# define DO 44
+# define FOR 45
+# define DEFAULT 46
+# define CASE 47
+# define SIZEOF 48
+# define ENUM 49
+
+
+/* little symbols, etc. */
+/* namely,
+
+ LP (
+ RP )
+
+ LC {
+ RC }
+
+ LB [
+ RB ]
+
+ CM ,
+ SM ;
+
+ */
+
+# define LP 50
+# define RP 51
+# define LC 52
+# define RC 53
+# define LB 54
+# define RB 55
+# define CM 56
+# define SM 57
+# define ASSIGN 58
+
+/* END OF YACC */
+
+/* left over tree building operators */
+# define COMOP 59
+# define DIV 60
+# define MOD 62
+# define LS 64
+# define RS 66
+# define DOT 68
+# define STREF 69
+# define CALL 70
+# define FORTCALL 73
+# define NOT 76
+# define COMPL 77
+# define INCR 78
+# define DECR 79
+# define EQ 80
+# define NE 81
+# define LE 82
+# define LT 83
+# define GE 84
+# define GT 85
+# define ULE 86
+# define ULT 87
+# define UGE 88
+# define UGT 89
+# define SETBIT 90
+# define TESTBIT 91
+# define RESETBIT 92
+# define ARS 93
+# define REG 94
+# define OREG 95
+# define CCODES 96
+# define FREE 97
+# define STASG 98
+# define STARG 99
+# define STCALL 100
+
+/* some conversion operators */
+# define FLD 103
+# define SCONV 104
+# define PCONV 105
+# define PMCONV 106
+# define PVCONV 107
+
+/* special node operators, used for special contexts */
+# define FORCE 108
+# define CBRANCH 109
+# define INIT 110
+# define CAST 111
+
+/* node types */
+# define LTYPE 02
+# define UTYPE 04
+# define BITYPE 010
+
+ /* DSIZE is the size of the dope array */
+# define DSIZE CAST+1
+
+/* type names, used in symbol table building */
+# define TNULL PTR /* pointer to UNDEF */
+# define UNDEF 0
+# define FARG 1
+# define CHAR 2
+# define SHORT 3
+# define INT 4
+# define LONG 5
+# define FLOAT 6
+# define DOUBLE 7
+# define STRTY 8
+# define UNIONTY 9
+# define ENUMTY 10
+# define MOETY 11
+# define UCHAR 12
+# define USHORT 13
+# define UNSIGNED 14
+# define ULONG 15
+
+# define ASG 1+
+# define UNARY 2+
+# define NOASG (-1)+
+# define NOUNARY (-2)+
+
+/* various flags */
+# define NOLAB (-1)
+
+/* type modifiers */
+
+# define PTR 020
+# define FTN 040
+# define ARY 060
+
+/* type packing constants */
+
+# define TMASK 060
+# define TMASK1 0300
+# define TMASK2 0360
+# define BTMASK 017
+# define BTSHIFT 4
+# define TSHIFT 2
+
+/* macros */
+
+# define MODTYPE(x,y) x = (x&(~BTMASK))|y /* set basic type of x to y */
+# define BTYPE(x) (x&BTMASK) /* basic type of x */
+# define ISUNSIGNED(x) ((x)<=ULONG&&(x)>=UCHAR)
+# define UNSIGNABLE(x) ((x)<=LONG&&(x)>=CHAR)
+# define ENUNSIGN(x) ((x)+(UNSIGNED-INT))
+# define DEUNSIGN(x) ((x)+(INT-UNSIGNED))
+# define ISPTR(x) ((x&TMASK)==PTR)
+# define ISFTN(x) ((x&TMASK)==FTN) /* is x a function type */
+# define ISARY(x) ((x&TMASK)==ARY) /* is x an array type */
+# define INCREF(x) (((x&~BTMASK)<<TSHIFT)|PTR|(x&BTMASK))
+# define DECREF(x) (((x>>TSHIFT)&~BTMASK)|(x&BTMASK))
+# define SETOFF(x,y) if( x%y != 0 ) x = ( (x/y + 1) * y)
+ /* advance x to a multiple of y */
+# define NOFIT(x,y,z) ( (x%z + y) > z )
+ /* can y bits be added to x without overflowing z */
+ /* pack and unpack field descriptors (size and offset) */
+# define PKFIELD(s,o) ((o<<6)|s)
+# define UPKFSZ(v) (v&077)
+# define UPKFOFF(v) (v>>6)
+
+/* operator information */
+
+# define TYFLG 016
+# define ASGFLG 01
+# define LOGFLG 020
+
+# define SIMPFLG 040
+# define COMMFLG 0100
+# define DIVFLG 0200
+# define FLOFLG 0400
+# define LTYFLG 01000
+# define CALLFLG 02000
+# define MULFLG 04000
+# define SHFFLG 010000
+# define ASGOPFLG 020000
+
+# define SPFLG 040000
+
+#define optype(o) (dope[o]&TYFLG)
+#define asgop(o) (dope[o]&ASGFLG)
+#define logop(o) (dope[o]&LOGFLG)
+#define callop(o) (dope[o]&CALLFLG)
+
+/* table sizes */
+
+# define BCSZ 100 /* size of the table to save break and continue labels */
+# define SYMTSZ 450 /* size of the symbol table */
+# define DIMTABSZ 750 /* size of the dimension/size table */
+# define PARAMSZ 100 /* size of the parameter stack */
+# ifndef FORT
+# define TREESZ 350 /* space for building parse tree */
+# else
+# define TREESZ 1000
+# endif
+# define SWITSZ 250 /* size of switch table */
+
+# define NCHNAM 8 /* number of characters in a name */
+
+/* common defined variables */
+
+extern int nerrors; /* number of errors seen so far */
+
+typedef union ndu NODE;
+typedef unsigned int TWORD;
+extern NODE *NIL; /* a pointer which will always have 0 in it */
+extern int dope[]; /* a vector containing operator information */
+extern char *opst[]; /* a vector containing names for ops */
+
+# ifdef ONEPASS
+ /* in one-pass operation, define the tree nodes */
+
+union ndu {
+
+ struct {
+ int op;
+ int rall;
+ TWORD type;
+ int su;
+ char name[NCHNAM];
+ NODE *left;
+ NODE *right;
+ };
+
+ struct {
+ int op;
+ int rall;
+ TWORD type;
+ int su;
+ char name[NCHNAM];
+ CONSZ lval;
+ int rval;
+ };
+
+ struct {
+ int op, rall;
+ TWORD type;
+ int su;
+ int label; /* for use with branching */
+ };
+
+ struct {
+ int op, rall;
+ TWORD type;
+ int su;
+ int stsize; /* sizes of structure objects */
+ int stalign; /* alignment of structure objects */
+ };
+
+ struct {
+ int op;
+ int cdim;
+ TWORD type;
+ int csiz;
+ };
+
+ struct {
+ /* this structure is used when a floating point constant
+ is being computed */
+ int op;
+ int cdim;
+ TWORD type;
+ int csiz;
+ double dval;
+ };
+
+ };
+# endif
--- /dev/null
+# include "mfile1"
+
+# define SWAP(p,q) {sp=p; p=q; q=sp;}
+# define RCON(p) (p->right->op==ICON)
+# define RO(p) p->right->op
+# define RV(p) p->right->lval
+# define LCON(p) (p->left->op==ICON)
+# define LO(p) p->left->op
+# define LV(p) p->left->lval
+
+int oflag = 0;
+
+NODE *
+fortarg( p ) NODE *p; {
+ /* fortran function arguments */
+
+ if( p->op == CM ){
+ p->left = fortarg( p->left );
+ p->right = fortarg( p->right );
+ return(p);
+ }
+
+ while( ISPTR(p->type) ){
+ p = buildtree( UNARY MUL, p, NIL );
+ }
+ return( optim(p) );
+ }
+
+ /* mapping relationals when the sides are reversed */
+short revrel[] ={ EQ, NE, GE, GT, LE, LT, UGE, UGT, ULE, ULT };
+NODE *
+optim(p) register NODE *p; {
+ /* local optimizations, most of which are probably machine independent */
+
+ register o, ty;
+ NODE *sp;
+ int i;
+ TWORD t;
+
+ if( (t=BTYPE(p->type))==ENUMTY || t==MOETY ) econvert(p);
+ if( oflag ) return(p);
+ ty = optype( o=p->op);
+ if( ty == LTYPE ) return(p);
+
+ if( ty == BITYPE ) p->right = optim(p->right);
+ p->left = optim(p->left);
+
+ /* collect constants */
+
+ switch(o){
+
+ case SCONV:
+ case PCONV:
+ return( clocal(p) );
+
+ case FORTCALL:
+ p->right = fortarg( p->right );
+ break;
+
+ case UNARY AND:
+ if( LO(p) != NAME ) cerror( "& error" );
+
+ if( !andable(p->left) ) return(p);
+
+ LO(p) = ICON;
+
+ setuleft:
+ /* paint over the type of the left hand side with the type of the top */
+ p->left->type = p->type;
+ p->left->cdim = p->cdim;
+ p->left->csiz = p->csiz;
+ p->op = FREE;
+ return( p->left );
+
+ case UNARY MUL:
+ if( LO(p) != ICON ) break;
+ LO(p) = NAME;
+ goto setuleft;
+
+ case MINUS:
+ if( !nncon(p->right) ) break;
+ RV(p) = -RV(p);
+ o = p->op = PLUS;
+
+ case MUL:
+ case PLUS:
+ case AND:
+ case OR:
+ case ER:
+ /* commutative ops; for now, just collect constants */
+ /* someday, do it right */
+ if( nncon(p->left) || ( LCON(p) && !RCON(p) ) ) SWAP( p->left, p->right );
+ /* make ops tower to the left, not the right */
+ if( RO(p) == o ){
+ NODE *t1, *t2, *t3;
+ t1 = p->left;
+ sp = p->right;
+ t2 = sp->left;
+ t3 = sp->right;
+ /* now, put together again */
+ p->left = sp;
+ sp->left = t1;
+ sp->right = t2;
+ p->right = t3;
+ }
+ if(o == PLUS && LO(p) == MINUS && RCON(p) && RCON(p->left) &&
+ conval(p->right, MINUS, p->left->right)){
+ zapleft:
+ RO(p->left) = FREE;
+ LO(p) = FREE;
+ p->left = p->left->left;
+ }
+ if( RCON(p) && LO(p)==o && RCON(p->left) && conval( p->right, o, p->left->right ) ){
+ goto zapleft;
+ }
+ else if( LCON(p) && RCON(p) && conval( p->left, o, p->right ) ){
+ zapright:
+ RO(p) = FREE;
+ p->left = makety( p->left, p->type, p->cdim, p->csiz );
+ p->op = FREE;
+ return( clocal( p->left ) );
+ }
+
+ /* change muls to shifts */
+
+ if( o==MUL && nncon(p->right) && (i=ispow2(RV(p)))>=0){
+ if( i == 0 ){ /* multiplication by 1 */
+ goto zapright;
+ }
+ o = p->op = LS;
+ p->right->type = p->right->csiz = INT;
+ RV(p) = i;
+ }
+
+ /* change +'s of negative consts back to - */
+ if( o==PLUS && nncon(p->right) && RV(p)<0 ){
+ RV(p) = -RV(p);
+ o = p->op = MINUS;
+ }
+ break;
+
+ case DIV:
+ if( nncon( p->right ) && p->right->lval == 1 ) goto zapright;
+ break;
+
+ case EQ:
+ case NE:
+ case LT:
+ case LE:
+ case GT:
+ case GE:
+ case ULT:
+ case ULE:
+ case UGT:
+ case UGE:
+ if( !LCON(p) ) break;
+
+ /* exchange operands */
+
+ sp = p->left;
+ p->left = p->right;
+ p->right = sp;
+ p->op = revrel[p->op - EQ ];
+ break;
+
+ }
+
+ return(p);
+ }
+
+ispow2( c ) CONSZ c; {
+ register i;
+ if( c <= 0 || (c&(c-1)) ) return(-1);
+ for( i=0; c>1; ++i) c >>= 1;
+ return(i);
+ }
+
+nncon( p ) NODE *p; {
+ /* is p a constant without a name */
+ return( p->op == ICON && p->rval == NONAME );
+ }