xref: /csrg-svn/usr.bin/pascal/src/put.c (revision 3317)

/* Copyright (c) 1979 Regents of the University of California */

static char sccsid[] = "@(#)put.c 1.13 03/20/81";

#include "whoami.h"
#include "opcode.h"
#include "0.h"
#include "objfmt.h"
#ifdef PC
#   include	"pc.h"
#endif PC

short	*obufp	= obuf;

/*
 * If DEBUG is defined, include the table
 * of the printing opcode names.
 */
#ifdef DEBUG
#include "OPnames.h"
#endif

#ifdef OBJ
/*
 * Put is responsible for the interpreter equivalent of code
 * generation.  Since the interpreter is specifically designed
 * for Pascal, little work is required here.
 */
put(a)
{
	register int *p, i;
	register char *cp;
	register short *sp;
	register long *lp;
	int n, subop, suboppr, op, oldlc, w;
	char *string;
	static int casewrd;

	/*
	 * It would be nice to do some more
	 * optimizations here.  The work
	 * done to collapse offsets in lval
	 * should be done here, the IFEQ etc
	 * relational operators could be used
	 * etc.
	 */
	oldlc = lc;
	if ( !CGENNING )
		/*
		 * code disabled - do nothing
		 */
		return (oldlc);
	p = &a;
	n = *p++;
	suboppr = subop = (*p >> 8) & 0377;
	op = *p & 0377;
	string = 0;
#ifdef DEBUG
	if ((cp = otext[op]) == NIL) {
		printf("op= %o\n", op);
		panic("put");
	}
#endif
	switch (op) {
		case O_ABORT:
			cp = "*";
			break;
		case O_AS:
			switch(p[1]) {
			case 2:
				op = O_AS2;
				break;
			case 4:
				op = O_AS4;
				break;
			case 8:
				op = O_AS8;
				break;
			default:
				goto pack;
			}
			n = 1;
#			ifdef DEBUG
				cp = otext[op];
#			endif DEBUG
			break;
		case O_CONG:
		case O_LVCON:
		case O_CON:
		case O_LINO:
		case O_NEW:
		case O_DISPOSE:
		case O_IND:
		case O_OFF:
		case O_INX2:
		case O_INX4:
		case O_CARD:
		case O_ADDT:
		case O_SUBT:
		case O_MULT:
		case O_IN:
		case O_CASE1OP:
		case O_CASE2OP:
		case O_CASE4OP:
		case O_FRTN:
		case O_WRITES:
		case O_WRITEC:
		case O_WRITEF:
		case O_MAX:
		case O_MIN:
		case O_ARGV:
		case O_CTTOT:
		case O_INCT:
		case O_RANG2:
		case O_RSNG2:
		case O_RANG42:
		case O_RSNG42:
		case O_SUCC2:
		case O_SUCC24:
		case O_PRED2:
		case O_PRED24:
			if (p[1] == 0)
				break;
		case O_CON2:
		case O_CON24:
		pack:
			if (p[1] < 128 && p[1] >= -128) {
				suboppr = subop = p[1];
				p++;
				n--;
				if (op == O_CON2) {
					op = O_CON1;
#					ifdef DEBUG
						cp = otext[O_CON1];
#					endif DEBUG
				}
				if (op == O_CON24) {
					op = O_CON14;
#					ifdef DEBUG
						cp = otext[O_CON14];
#					endif DEBUG
				}
			}
			break;
		case O_CON8:
		    {
			short	*sp = &p[1];

#ifdef	DEBUG
			if ( opt( 'k' ) )
			    printf ( "%5d\tCON8\t%22.14e\n" ,
					lc - HEADER_BYTES ,
					* ( ( double * ) &p[1] ) );
#endif
#			ifdef DEC11
			    word(op);
#			else
			    word(op << 8);
#			endif DEC11
			for ( i = 1 ; i <= 4 ; i ++ )
			    word ( *sp ++ );
			return ( oldlc );
		    }
		default:
			if (op >= O_REL2 && op <= O_REL84) {
				if ((i = (subop >> INDX) * 5 ) >= 30)
					i -= 30;
				else
					i += 2;
#ifdef DEBUG
				string = &"IFEQ\0IFNE\0IFLT\0IFGT\0IFLE\0IFGE"[i];
#endif
				suboppr = 0;
			}
			break;
		case O_IF:
		case O_TRA:
/*****
			codeline = 0;
*****/
			/* relative addressing */
			p[1] -= ( unsigned ) lc + sizeof(short);
			break;
		case O_FOR1U:
		case O_FOR2U:
		case O_FOR1D:
		case O_FOR2D:
			/* relative addressing */
			p[3] -= ( unsigned ) lc + 3 * sizeof(short);
			break;
		case O_CONC:
#ifdef DEBUG
			(string = "'x'")[1] = p[1];
#endif
			suboppr = 0;
			op = O_CON1;
#			ifdef DEBUG
				cp = otext[O_CON1];
#			endif DEBUG
			subop = p[1];
			goto around;
		case O_CONC4:
#ifdef DEBUG
			(string = "'x'")[1] = p[1];
#endif
			suboppr = 0;
			op = O_CON14;
			subop = p[1];
			goto around;
		case O_CON1:
		case O_CON14:
			suboppr = subop = p[1];
around:
			n--;
			break;
		case O_CASEBEG:
			casewrd = 0;
			return (oldlc);
		case O_CASEEND:
			if ((unsigned) lc & 1) {
				lc--;
				word(casewrd);
			}
			return (oldlc);
		case O_CASE1:
#ifdef DEBUG
			if (opt('k'))
				printf("%5d\tCASE1\t%d\n"
					, lc - HEADER_BYTES, p[1]);
#endif
			/*
			 * this to build a byte size case table
			 * saving bytes across calls in casewrd
			 * so they can be put out by word()
			 */
			lc++;
			if ((unsigned) lc & 1)
#				ifdef DEC11
				    casewrd = p[1] & 0377;
#				else
				    casewrd = (p[1] & 0377) << 8;
#				endif DEC11
			else {
				lc -= 2;
#				ifdef DEC11
				    word(((p[1] & 0377) << 8) | casewrd);
#				else
				    word((p[1] & 0377) | casewrd);
#				endif DEC11
			}
			return (oldlc);
		case O_CASE2:
#ifdef DEBUG
			if (opt('k'))
				printf("%5d\tCASE2\t%d\n"
					, lc - HEADER_BYTES , p[1]);
#endif
			word(p[1]);
			return (oldlc);
		case O_PUSH:
			lp = (long *)&p[1];
			if (*lp == 0)
				return (oldlc);
			if (*lp < 128 && *lp >= -128) {
				suboppr = subop = *lp;
				p++;
				n--;
				break;
			}
			goto longgen;
		case O_FOR4U:
		case O_FOR4D:
			/* relative addressing */
			p[1 + 2 * (sizeof(long) / sizeof(int))] -=
			    (unsigned)lc + (sizeof(short) + 2 * sizeof(long));
			goto longgen;
		case O_TRA4:
		case O_CALL:
		case O_FSAV:
		case O_GOTO:
		case O_NAM:
		case O_READE:
			/* absolute long addressing */
			lp = (long *)&p[1];
			*lp -= HEADER_BYTES;
			goto longgen;
		case O_RV1:
		case O_RV14:
		case O_RV2:
		case O_RV24:
		case O_RV4:
		case O_RV8:
		case O_RV:
		case O_LV:
			/*
			 * positive offsets represent arguments
			 * and must use "ap" display entry rather
			 * than the "fp" entry
			 */
			if (p[1] >= 0) {
				subop++;
				suboppr++;
			}
#			ifdef PDP11
			    break;
#			else
			    /*
			     * offsets out of range of word addressing
			     * must use long offset opcodes
			     */
			    if (p[1] < SHORTADDR && p[1] >= -SHORTADDR)
				    break;
			    else {
				op += O_LRV - O_RV;
#				ifdef DEBUG
				    cp = otext[op];
#				endif DEBUG
			    }
			    /* and fall through */
#			endif PDP11
		case O_BEG:
		case O_NODUMP:
		case O_CON4:
		case O_CASE4:
		case O_RANG4:
		case O_RANG24:
		case O_RSNG4:
		case O_RSNG24:
		case O_SUCC4:
		case O_PRED4:
		longgen:
			n = (n << 1) - 1;
			if ( op == O_LRV || op == O_FOR4U || op == O_FOR4D)
				n--;
#ifdef DEBUG
			if (opt('k')) {
				printf("%5d\t%s", lc - HEADER_BYTES, cp+1);
				if (suboppr)
					printf(":%d", suboppr);
				for ( i = 2, lp = (long *)&p[1]; i < n
				    ; i += sizeof ( long )/sizeof ( short ) )
					printf( "\t%D " , *lp ++ );
				if (i == n)
					printf( "\t%d ", p[i - 1] );
				pchr ( '\n' );
			}
#endif
			if ( op != O_CASE4 )
#				ifdef DEC11
			    	    word((op & 0377) | subop << 8);
#				else
				    word(op << 8 | (subop & 0377));
#				endif DEC11
			for ( i = 1, sp = (short *)&p[1]; i < n; i++)
				word ( *sp ++ );
			return ( oldlc );
	}
#ifdef DEBUG
	if (opt('k')) {
		printf("%5d\t%s", lc - HEADER_BYTES, cp+1);
		if (suboppr)
			printf(":%d", suboppr);
		if (string)
			printf("\t%s",string);
		if (n > 1)
			pchr('\t');
		for (i=1; i<n; i++)
			printf("%d ", p[i]);
		pchr('\n');
	}
#endif
	if (op != NIL)
#		ifdef DEC11
		    word((op & 0377) | subop << 8);
#		else
		    word(op << 8 | (subop & 0377));
#		endif DEC11
	for (i=1; i<n; i++)
		word(p[i]);
	return (oldlc);
}
#endif OBJ

/*
 * listnames outputs a list of enumerated type names which
 * can then be selected from to output a TSCAL
 * a pointer to the address in the code of the namelist
 * is kept in value[ NL_ELABEL ].
 */
listnames(ap)

	register struct nl *ap;
{
	struct nl *next;
	register int oldlc, len;
	register unsigned w;
	register char *strptr;

	if ( !CGENNING )
		/* code is off - do nothing */
		return(NIL);
	if (ap->class != TYPE)
		ap = ap->type;
	if (ap->value[ NL_ELABEL ] != 0) {
		/* the list already exists */
		return( ap -> value[ NL_ELABEL ] );
	}
#	ifdef OBJ
	    oldlc = lc;
	    put(2, O_TRA, lc);
	    ap->value[ NL_ELABEL ] = lc;
#	endif OBJ
#	ifdef PC
	    putprintf( "	.data" , 0 );
	    putprintf( "	.align 1" , 0 );
	    ap -> value[ NL_ELABEL ] = getlab();
	    putlab( ap -> value[ NL_ELABEL ] );
#	endif PC
	/* number of scalars */
	next = ap->type;
	len = next->range[1]-next->range[0]+1;
#	ifdef OBJ
	    put(2, O_CASE2, len);
#	endif OBJ
#	ifdef PC
	    putprintf( "	.word %d" , 0 , len );
#	endif PC
	/* offsets of each scalar name */
	len = (len+1)*sizeof(short);
#	ifdef OBJ
	    put(2, O_CASE2, len);
#	endif OBJ
#	ifdef PC
	    putprintf( "	.word %d" , 0 , len );
#	endif PC
	next = ap->chain;
	do	{
		for(strptr = next->symbol;  *strptr++;  len++)
			continue;
		len++;
#		ifdef OBJ
		    put(2, O_CASE2, len);
#		endif OBJ
#		ifdef PC
		    putprintf( "	.word %d" , 0 , len );
#		endif PC
	} while (next = next->chain);
	/* list of scalar names */
	strptr = getnext(ap, &next);
#	ifdef OBJ
	    do	{
#		    ifdef DEC11
			w = (unsigned) *strptr;
#		    else
			w = *strptr << 8;
#		    endif DEC11
		    if (!*strptr++)
			    strptr = getnext(next, &next);
#		    ifdef DEC11
			w |= *strptr << 8;
#		    else
			w |= (unsigned) *strptr;
#		    endif DEC11
		    if (!*strptr++)
			    strptr = getnext(next, &next);
		    word(w);
	    } while (next);
	    /* jump over the mess */
	    patch(oldlc);
#	endif OBJ
#	ifdef PC
	    while ( next ) {
		while ( *strptr ) {
		    putprintf( "	.byte	0%o" , 1 , *strptr++ );
		    for ( w = 2 ; ( w <= 8 ) && *strptr ; w ++ ) {
			putprintf( ",0%o" , 1 , *strptr++ );
		    }
		    putprintf( "" , 0 );
		}
		putprintf( "	.byte	0" , 0 );
		strptr = getnext( next , &next );
	    }
	    putprintf( "	.text" , 0 );
#	endif PC
	return( ap -> value[ NL_ELABEL ] );
}

getnext(next, new)

	struct nl *next, **new;
{
	if (next != NIL) {
		next = next->chain;
		*new = next;
	}
	if (next == NIL)
		return("");
#ifdef OBJ
	if (opt('k') && CGENNING )
		printf("%5d\t\t\"%s\"\n", lc-HEADER_BYTES, next->symbol);
#endif OBJ
	return(next->symbol);
}

#ifdef OBJ
/*
 * Putspace puts out a table
 * of nothing to leave space
 * for the case branch table e.g.
 */
putspace(n)
	int n;
{
	register i;

	if ( !CGENNING )
		/*
		 * code disabled - do nothing
		 */
		return(lc);
#ifdef DEBUG
	if (opt('k'))
		printf("%5d\t.=.+%d\n", lc - HEADER_BYTES, n);
#endif
	for (i = even(n); i > 0; i -= 2)
		word(0);
}

putstr(sptr, padding)

	char *sptr;
	int padding;
{
	register unsigned short w;
	register char *strptr = sptr;
	register int pad = padding;

	if ( !CGENNING )
		/*
		 * code disabled - do nothing
		 */
		return(lc);
#ifdef DEBUG
	if (opt('k'))
		printf("%5d\t\t\"%s\"\n", lc-HEADER_BYTES, strptr);
#endif
	if (pad == 0) {
		do	{
#			ifdef DEC11
			    w = (unsigned short) * strptr;
#			else
			    w = (unsigned short)*strptr<<8;
#			endif DEC11
			if (w)
#				ifdef DEC11
				    w |= *++strptr << 8;
#				else
				    w |= *++strptr;
#				endif DEC11
			word(w);
		} while (*strptr++);
	} else {
#		ifdef DEC11
		    do 	{
			    w = (unsigned short) * strptr;
			    if (w) {
				    if (*++strptr)
					    w |= *strptr << 8;
				    else {
					    w |= ' \0';
					    pad--;
				    }
				    word(w);
			    }
		    } while (*strptr++);
#		else
		    do 	{
			    w = (unsigned short)*strptr<<8;
			    if (w) {
				    if (*++strptr)
					    w |= *strptr;
				    else {
					    w |= ' ';
					    pad--;
				    }
				    word(w);
			    }
		    } while (*strptr++);
#		endif DEC11
		while (pad > 1) {
			word('  ');
			pad -= 2;
		}
		if (pad == 1)
#			ifdef DEC11
			    word(' ');
#			else
			    word(' \0');
#			endif DEC11
		else
			word(0);
	}
}
#endif OBJ

lenstr(sptr, padding)

	char *sptr;
	int padding;

{
	register int cnt;
	register char *strptr = sptr;

	cnt = padding;
	do	{
		cnt++;
	} while (*strptr++);
	return((++cnt) & ~1);
}

/*
 * Patch repairs the branch
 * at location loc to come
 * to the current location.
 *	for PC, this puts down the label
 *	and the branch just references that label.
 *	lets here it for two pass assemblers.
 */
patch(loc)
{

#	ifdef OBJ
	    patchfil(loc, (long)(lc-loc-2), 1);
#	endif OBJ
#	ifdef PC
	    putlab( loc );
#	endif PC
}

#ifdef OBJ
patch4(loc)
{
	patchfil(loc, (long)(lc - HEADER_BYTES), 2);
}

/*
 * Patchfil makes loc+2 have value
 * as its contents.
 */
patchfil(loc, value, words)
	PTR_DCL loc;
	long value;
	int words;
{
	register i;
	int val;

	if ( !CGENNING )
		return;
	if (loc > (unsigned) lc)
		panic("patchfil");
#ifdef DEBUG
	if (opt('k'))
		printf("\tpatch %u %D\n", loc - HEADER_BYTES, value);
#endif
	val = value;
	do {
#		ifndef DEC11
		    if (words > 1)
			    val = value >> 16;
		    else
			    val = value;
#		endif DEC11
		i = ((unsigned) loc + 2 - ((unsigned) lc & ~01777))/2;
		if (i >= 0 && i < 1024)
			obuf[i] = val;
		else {
			lseek(ofil, (long) loc+2, 0);
			write(ofil, &val, 2);
			lseek(ofil, (long) 0, 2);
		}
		loc += 2;
#		ifdef DEC11
		    val = value >> 16;
#		endif DEC11
	} while (--words);
}

/*
 * Put the word o into the code
 */
word(o)
	int o;
{

	*obufp = o;
	obufp++;
	lc += 2;
	if (obufp >= obuf+512)
		pflush();
}

extern char	*obj;
/*
 * Flush the code buffer
 */
pflush()
{
	register i;

	i = (obufp - ( ( short * ) obuf ) ) * 2;
	if (i != 0 && write(ofil, obuf, i) != i)
		perror(obj), pexit(DIED);
	obufp = obuf;
}
#endif OBJ

/*
 * Getlab - returns the location counter.
 * included here for the eventual code generator.
 *	for PC, thank you!
 */
getlab()
{
#	ifdef OBJ

	    return (lc);
#	endif OBJ
#	ifdef PC
	    static long	lastlabel;

	    return ( ++lastlabel );
#	endif PC
}

/*
 * Putlab - lay down a label.
 *	for PC, just print the label name with a colon after it.
 */
putlab(l)
	int l;
{

#	ifdef PC
	    putprintf( PREFIXFORMAT , 1 , LABELPREFIX , l );
	    putprintf( ":" , 0 );
#	endif PC
	return (l);
}