[unix-history] / usr / src / usr.bin / pascal / src / p2put.c

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

static	char sccsid[] = "@(#)p2put.c 1.10 %G%";

    /*
     *	functions to help pi put out
     *	polish postfix binary portable c compiler intermediate code
     *	thereby becoming the portable pascal compiler
     */

#include	"whoami.h"
#ifdef PC
#include	"0.h"
#include	"pcops.h"
#include	"pc.h"

    /*
     *	mash into f77's format
     *	lovely, isn't it?
     */
#define		TOF77( fop,val,rest )	( ( ( (rest) & 0177777 ) << 16 ) \
					| ( ( (val) & 0377 ) << 8 )	 \
					| ( (fop) & 0377 ) )
\f
    /*
     *	emits an ftext operator and a string to the pcstream
     */
puttext( string )
    char	*string;
    {
	int	length = str4len( string );

	if ( !CGENNING )
	    return;
	p2word( TOF77( P2FTEXT , length , 0 ) );
#	ifdef DEBUG
	    if ( opt( 'k' ) ) {
		fprintf( stdout , "P2FTEXT | %3d | 0	" , length );
	    }
#	endif
	p2string( string );
    }

int
str4len( string )
    char	*string;
    {
	
	return ( ( strlen( string ) + 3 ) / 4 );
    }

    /*
     *	put formatted text into a buffer for printing to the pcstream.
     *	a call to putpflush actually puts out the text.
     *	none of arg1 .. arg5 need be present.
     *	and you can add more if you need them.
     */
    /* VARARGS */
putprintf( format , incomplete , arg1 , arg2 , arg3 , arg4 , arg5 )
    char	*format;
    int		incomplete;
    {
	static char	ppbuffer[ BUFSIZ ];
	static char	*ppbufp = ppbuffer;

	if ( !CGENNING )
	    return;
	sprintf( ppbufp , format , arg1 , arg2 , arg3 , arg4 , arg5 );
	ppbufp = &( ppbuffer[ strlen( ppbuffer ) ] );
	if ( ppbufp >= &( ppbuffer[ BUFSIZ ] ) )
	    panic( "putprintf" );
	if ( ! incomplete ) {
	    puttext( ppbuffer );
	    ppbufp = ppbuffer;
	}
    }

    /*
     *	emit a left bracket operator to pcstream
     *	with function number, the maximum temp register, and total local bytes
     *	until i figure out how to use them, regs 0 .. 11 are free.
     *	one idea for one reg is to save the display pointer on block entry
     */
putlbracket( ftnno , localbytes )
    int	ftnno;
    int	localbytes;
    {
#	define	MAXTP2REG	11

	p2word( TOF77( P2FLBRAC , MAXTP2REG , ftnno ) );
	p2word( BITSPERBYTE * localbytes );
#	ifdef DEBUG
	    if ( opt( 'k' ) ) {
		fprintf( stdout
			, "P2FLBRAC | %3d | %d	" , MAXTP2REG , ftnno );
		fprintf( stdout , "%d\n"
			, BITSPERBYTE * localbytes );
	    }
#	endif
    }

    /*
     *	emit a right bracket operator
     *	which for the binary (fortran) interface
     *	forces the stack allocate and register mask
     */
putrbracket( ftnno )
    int	ftnno;
    {

	p2word( TOF77( P2FRBRAC , 0 , ftnno ) );
#	ifdef DEBUG
	    if ( opt( 'k' ) ) {
		fprintf( stdout , "P2FRBRAC |   0 | %d\n" , ftnno );
	    }
#	endif
    }

    /*
     *	emit an eof operator
     */
puteof()
    {
	
	p2word( P2FEOF );
#	ifdef DEBUG
	    if ( opt( 'k' ) ) {
		fprintf( stdout , "P2FEOF\n" );
	    }
#	endif
    }

    /*
     *	emit a dot operator,
     *	with a source file line number and name
     *	if line is negative, there was an error on that line, but who cares?
     */
putdot( filename , line )
    char	*filename;
    int		line;
    {
	int	length = str4len( filename );

	if ( line < 0 ) {
	    line = -line;
	}
	p2word( TOF77( P2FEXPR , length , line ) );
#	ifdef DEBUG
	    if ( opt( 'k' ) ) {
		fprintf( stdout , "P2FEXPR | %3d | %d	" , length , line );
	    }
#	endif
	p2string( filename );
    }

    /*
     *	put out a leaf node
     */
putleaf( op , lval , rval , type , name )
    int		op;
    int		lval;
    int		rval;
    int		type;
    char	*name;
    {
	if ( !CGENNING )
	    return;
	switch ( op ) {
	    default:
		panic( "[putleaf]" );
	    case P2ICON:
		p2word( TOF77( P2ICON , name != NIL , type ) );
		p2word( lval );
#		ifdef DEBUG
		    if ( opt( 'k' ) ) {
			fprintf( stdout , "P2ICON | %3d | 0x%x	" 
			       , name != NIL , type );
			fprintf( stdout , "%d\n" , lval );
		    }
#		endif
		if ( name )
		    p2name( name );
		break;
	    case P2NAME:
		p2word( TOF77( P2NAME , lval != 0 , type ) );
		if ( lval ) 
		    p2word( lval );
#		ifdef DEBUG
		    if ( opt( 'k' ) ) {
			fprintf( stdout , "P2NAME | %3d | 0x%x	" 
			       , lval != 0 , type );
			if ( lval )
			    fprintf( stdout , "%d	" , lval );
		    }
#		endif
		p2name( name );
		break;
	    case P2REG:
		p2word( TOF77( P2REG , rval , type ) );
#		ifdef DEBUG
		    if ( opt( 'k' ) ) {
			fprintf( stdout , "P2REG | %3d | 0x%x\n" ,
				rval , type );
		    }
#		endif
		break;
	}
    }

    /*
     *	rvalues are just lvalues with indirection, except
     *	special cases for registers and for named globals,
     *	whose names are their rvalues.
     */
putRV( name , level , offset , other_flags , type )
    char	*name;
    int		level;
    int		offset;
    char	other_flags;
    int		type;
    {
	char	extname[ BUFSIZ ];
	char	*printname;
	int	regnumber;

	if ( !CGENNING )
	    return;
	if ( other_flags & NREGVAR ) {
	    if ( ( offset < 0 ) || ( offset > P2FP ) ) {
		panic( "putRV regvar" );
	    }
	    putleaf( P2REG , 0 , offset , type , 0 );
	    return;
	}
	if ( whereis( level , offset , other_flags ) == GLOBALVAR ) {
	    if ( name != 0 ) {
		if ( name[0] != '_' ) {
			sprintf( extname , EXTFORMAT , name );
			printname = extname;
		} else {
			printname = name;
		}
		putleaf( P2NAME , offset , 0 , type , printname );
		return;
	    } else {
		panic( "putRV no name" );
	    }
	}
	putLV( name , level , offset , other_flags , type );
	putop( P2UNARY P2MUL , type );
    }

    /*
     *	put out an lvalue 
     *	given a level and offset
     *	special case for
     *	    named globals, whose lvalues are just their names as constants.
     */
putLV( name , level , offset , other_flags , type )
    char	*name;
    int		level;
    int		offset;
    char	other_flags;
    int		type;
{
    char		extname[ BUFSIZ ];
    char		*printname;

    if ( !CGENNING )
	return;
    if ( other_flags & NREGVAR ) {
	panic( "putLV regvar" );
    }
    switch ( whereis( level , offset , other_flags ) ) {
	case GLOBALVAR:
	    if ( ( name != 0 ) ) {
		if ( name[0] != '_' ) {
			sprintf( extname , EXTFORMAT , name );
			printname = extname;
		} else {
			printname = name;
		}
		putleaf( P2ICON , offset , 0 , ADDTYPE( type , P2PTR )
			, printname );
		return;
	    } else {
		panic( "putLV no name" );
	    }
	case PARAMVAR:
	    if ( level == cbn ) {
		putleaf( P2REG , 0 , P2AP , ADDTYPE( type , P2PTR ) , 0 );
	    } else {
		putleaf( P2NAME , (level * sizeof(struct dispsave)) + AP_OFFSET
		    , 0 , P2PTR | P2CHAR , DISPLAYNAME );
	    }
	    putleaf( P2ICON , offset , 0 , P2INT , 0 );
	    putop( P2PLUS , P2PTR | P2CHAR );
	    break;
	case LOCALVAR:
	    if ( level == cbn ) {
		putleaf( P2REG , 0 , P2FP , ADDTYPE( type , P2PTR ) , 0 );
	    } else {
		putleaf( P2NAME , (level * sizeof(struct dispsave)) + FP_OFFSET
		    , 0 , P2PTR | P2CHAR , DISPLAYNAME );
	    }
	    putleaf( P2ICON , -offset , 0 , P2INT , 0 );
	    putop( P2MINUS , P2PTR | P2CHAR );
	    break;
    }
    return;
}

    /*
     *	put out a floating point constant leaf node
     *	the constant is declared in aligned data space
     *	and a P2NAME leaf put out for it
     */
putCON8( val )
    double	val;
    {
	int	label;
	char	name[ BUFSIZ ];

	if ( !CGENNING )
	    return;
	putprintf( "	.data" , 0 );
	putprintf( "	.align 2" , 0 );
	label = getlab();
	putlab( label );
	putprintf( "	.double 0d%.20e" , 0 , val );
	putprintf( "	.text" , 0 );
	sprintf( name , PREFIXFORMAT , LABELPREFIX , label );
	putleaf( P2NAME , 0 , 0 , P2DOUBLE , name );
    }

	/*
	 * put out either an lvalue or an rvalue for a constant string.
	 * an lvalue (for assignment rhs's) is the name as a constant, 
	 * an rvalue (for parameters) is just the name.
	 */
putCONG( string , length , required )
    char	*string;
    int		length;
    int		required;
    {
	char	name[ BUFSIZ ];
	int	label;
	char	*cp;
	int	pad;
	int	others;

	if ( !CGENNING )
	    return;
	putprintf( "	.data" , 0 );
	label = getlab();
	putlab( label );
	cp = string;
	while ( *cp ) {
	    putprintf( "	.byte	0%o" , 1 , *cp ++ );
	    for ( others = 2 ; ( others <= 8 ) && *cp ; others ++ ) {
		putprintf( ",0%o" , 1 , *cp++ );
	    }
	    putprintf( "" , 0 );
	}
	pad = length - strlen( string );
	while ( pad-- > 0 ) {
	    putprintf( "	.byte	0%o" , 1 , ' ' );
	    for ( others = 2 ; ( others <= 8 ) && ( pad-- > 0 ) ; others++ ) {
		putprintf( ",0%o" , 1 , ' ' );
	    }
	    putprintf( "" , 0 );
	}
	putprintf( "	.byte	0" , 0 );
	putprintf( "	.text"  , 0 );
	sprintf( name , PREFIXFORMAT , LABELPREFIX , label );
	if ( required == RREQ ) {
	    putleaf( P2NAME , 0 , 0 , P2ARY | P2CHAR , name );
	} else {
	    putleaf( P2ICON , 0 , 0 , P2PTR | P2CHAR , name );
	}
    }

    /*
     *	map a pascal type to a c type
     *	this would be tail recursive, but i unfolded it into a for (;;).
     *	this is sort of like isa and lwidth
     *	a note on the types used by the portable c compiler:
     *	    they are divided into a basic type (char, short, int, long, etc.)
     *	    and qualifications on those basic types (pointer, function, array).
     *	    the basic type is kept in the low 4 bits of the type descriptor,
     *	    and the qualifications are arranged in two bit chunks, with the
     *	    most significant on the right,
     *	    and the least significant on the left
     *		e.g. int *foo();
     *			(a function returning a pointer to an integer)
     *		is stored as
     *		    <ptr><ftn><int>
     *	so, we build types recursively
     *	also, we know that /lib/f1 can only deal with 6 qualifications
     *	so we stop the recursion there.  this stops infinite type recursion
     *	through mutually recursive pointer types.
     */
#define	MAXQUALS	6
int
p2type( np )
{

    return typerecur( np , 0 );
}
typerecur( np , quals )
    struct nl	*np;
    int		quals;
    {
	
	if ( np == NIL || quals > MAXQUALS ) {
	    return P2UNDEF;
	}
	switch ( np -> class ) {
	    case SCAL :
	    case RANGE :
		if ( np -> type == ( nl + TDOUBLE ) ) {
		    return P2DOUBLE;
		}
		switch ( bytes( np -> range[0] , np -> range[1] ) ) {
		    case 1:
			return P2CHAR;
		    case 2:
			return P2SHORT;
		    case 4:
			return P2INT;
		    default:
			panic( "p2type int" );
		}
	    case STR :
		return ( P2ARY | P2CHAR );
	    case RECORD :
	    case SET :
		return P2STRTY;
	    case FILET :
		return ( P2PTR | P2STRTY );
	    case CONST :
	    case VAR :
	    case FIELD :
		return p2type( np -> type );
	    case TYPE :
		switch ( nloff( np ) ) {
		    case TNIL :
			return ( P2PTR | P2UNDEF );
		    case TSTR :
			return ( P2ARY | P2CHAR );
		    case TSET :
			return P2STRTY;
		    default :
			return ( p2type( np -> type ) );
		}
	    case REF:
	    case WITHPTR:
	    case PTR :
		return ADDTYPE( typerecur( np -> type , quals + 1 ) , P2PTR );
	    case ARRAY :
		return ADDTYPE( typerecur( np -> type , quals + 1 ) , P2ARY );
	    case FUNC :
		    /*
		     * functions are really pointers to functions
		     * which return their underlying type.
		     */
		return ADDTYPE( ADDTYPE( typerecur( np -> type , quals + 2 ) ,
					P2FTN ) , P2PTR );
	    case PROC :
		    /*
		     * procedures are pointers to functions 
		     * which return integers (whether you look at them or not)
		     */
		return ADDTYPE( ADDTYPE( P2INT , P2FTN ) , P2PTR );
	    case FFUNC :
	    case FPROC :
		    /*
		     *	formal procedures and functions are pointers
		     *	to structures which describe their environment.
		     */
		return ( P2PTR | P2STRTY );
	    default :
		panic( "p2type" );
	}
    }

    /*
     *	add a most significant type modifier to a type
     */
long
addtype( underlying , mtype )
    long	underlying;
    long	mtype;
    {
	return ( ( ( underlying & ~P2BASETYPE ) << P2TYPESHIFT )
	       | mtype
	       | ( underlying & P2BASETYPE ) );
    }
\f
    /*
     *	put a typed operator to the pcstream
     */
putop( op , type )
    int		op;
    int		type;
    {
	extern char	*p2opnames[];
	
	if ( !CGENNING )
	    return;
	p2word( TOF77( op , 0 , type ) );
#	ifdef DEBUG
	    if ( opt( 'k' ) ) {
		fprintf( stdout , "%s (%d) |   0 | 0x%x\n"
			, p2opnames[ op ] , op , type );
	    }
#	endif
    }

    /*
     *	put out a structure operator (STASG, STARG, STCALL, UNARY STCALL )
     *	which looks just like a regular operator, only the size and
     *	alignment go in the next consecutive words
     */
putstrop( op , type , size , alignment )
    int	op;
    int	type;
    int	size;
    int	alignment;
    {
	extern char	*p2opnames[];
	
	if ( !CGENNING )
	    return;
	p2word( TOF77( op , 0 , type ) );
	p2word( size );
	p2word( alignment );
#	ifdef DEBUG
	    if ( opt( 'k' ) ) {
		fprintf( stdout , "%s (%d) |   0 | 0x%x	%d %d\n"
			, p2opnames[ op ] , op , type , size , alignment );
	    }
#	endif
    }

    /*
     *	the string names of p2ops
     */
char	*p2opnames[] = {
	"",
	"P2UNDEFINED",		/* 1 */
	"P2NAME",		/* 2 */
	"P2STRING",		/* 3 */
	"P2ICON",		/* 4 */
	"P2FCON",		/* 5 */
	"P2PLUS",		/* 6 */
	"",
	"P2MINUS",		/* 8		also unary == P2NEG */
	"",
	"P2NEG",
	"P2MUL",		/* 11		also unary == P2INDIRECT */
	"",
	"P2INDIRECT",
	"P2AND",		/* 14		also unary == P2ADDROF */
	"",
	"P2ADDROF",
	"P2OR",			/* 17 */
	"",
	"P2ER",			/* 19 */
	"",
	"P2QUEST",		/* 21 */
	"P2COLON",		/* 22 */
	"P2ANDAND",		/* 23 */
	"P2OROR",		/* 24 */
	"",			/* 25 */
	"",			/* 26 */
	"",			/* 27 */
	"",			/* 28 */
	"",			/* 29 */
	"",			/* 30 */
	"",			/* 31 */
	"",			/* 32 */
	"",			/* 33 */
	"",			/* 34 */
	"",			/* 35 */
	"",			/* 36 */
	"",			/* 37 */
	"",			/* 38 */
	"",			/* 39 */
	"",			/* 40 */
	"",			/* 41 */
	"",			/* 42 */
	"",			/* 43 */
	"",			/* 44 */
	"",			/* 45 */
	"",			/* 46 */
	"",			/* 47 */
	"",			/* 48 */
	"",			/* 49 */
	"",			/* 50 */
	"",			/* 51 */
	"",			/* 52 */
	"",			/* 53 */
	"",			/* 54 */
	"",			/* 55 */
	"P2LISTOP",		/* 56 */
	"",
	"P2ASSIGN",		/* 58 */
	"P2COMOP",		/* 59 */
	"P2DIV",		/* 60 */
	"",
	"P2MOD",		/* 62 */
	"",
	"P2LS",			/* 64 */
	"",
	"P2RS",			/* 66 */
	"",
	"P2DOT",		/* 68 */
	"P2STREF",		/* 69 */
	"P2CALL",		/* 70		also unary */
	"",
	"P2UNARYCALL",
	"P2FORTCALL",		/* 73		also unary */
	"",
	"P2UNARYFORTCALL",
	"P2NOT",		/* 76 */
	"P2COMPL",		/* 77 */
	"P2INCR",		/* 78 */
	"P2DECR",		/* 79 */
	"P2EQ",			/* 80 */
	"P2NE",			/* 81 */
	"P2LE",			/* 82 */
	"P2LT",			/* 83 */
	"P2GE",			/* 84 */
	"P2GT",			/* 85 */
	"P2ULE",		/* 86 */
	"P2ULT",		/* 87 */
	"P2UGE",		/* 88 */
	"P2UGT",		/* 89 */
	"P2SETBIT",		/* 90 */
	"P2TESTBIT",		/* 91 */
	"P2RESETBIT",		/* 92 */
	"P2ARS",		/* 93 */
	"P2REG",		/* 94 */
	"P2OREG",		/* 95 */
	"P2CCODES",		/* 96 */
	"P2FREE",		/* 97 */
	"P2STASG",		/* 98 */
	"P2STARG",		/* 99 */
	"P2STCALL",		/* 100		also unary */
	"",
	"P2UNARYSTCALL",
	"P2FLD",		/* 103 */
	"P2SCONV",		/* 104 */
	"P2PCONV",		/* 105 */
	"P2PMCONV",		/* 106 */
	"P2PVCONV",		/* 107 */
	"P2FORCE",		/* 108 */
	"P2CBRANCH",		/* 109 */
	"P2INIT",		/* 110 */
	"P2CAST",		/* 111 */
    };
\f
    /*
     *	low level routines
     */

    /*
     *	puts a long word on the pcstream
     */
p2word( word )
    long	word;
    {

	putw( word , pcstream );
    }

    /*
     *	put a length 0 mod 4 null padded string onto the pcstream
     */
p2string( string )
    char	*string;
    {
	int	slen = strlen( string );
	int	wlen = ( slen + 3 ) / 4;
	int	plen = ( wlen * 4 ) - slen;
	char	*cp;
	int	p;

	for ( cp = string ; *cp ; cp++ )
	    putc( *cp , pcstream );
	for ( p = 1 ; p <= plen ; p++ )
	    putc( '\0' , pcstream );
#	ifdef DEBUG
	    if ( opt( 'k' ) ) {
		fprintf( stdout , "\"%s" , string );
		for ( p = 1 ; p <= plen ; p++ )
		    fprintf( stdout , "\\0" );
		fprintf( stdout , "\"\n" );
	    }
#	endif
    }

    /*
     *	puts a name on the pcstream
     */
p2name( name )
    char	*name;
    {
	int	pad;

	fprintf( pcstream , NAMEFORMAT , name );
	pad = strlen( name ) % sizeof (long);
	for ( ; pad < sizeof (long) ; pad++ ) {
	    putc( '\0' , pcstream );
	}
#	ifdef DEBUG
	    if ( opt( 'k' ) ) {
		fprintf( stdout , NAMEFORMAT , name );
		pad = strlen( name ) % sizeof (long);
		for ( ; pad < sizeof (long) ; pad++ ) {
		    fprintf( stdout , "\\0" );
		}
		fprintf( stdout , "\n" );
	    }
#	endif
    }
    
    /*
     *	put out a jump to a label
     */
putjbr( label )
    long	label;
    {

	printjbr( LABELPREFIX , label );
    }

    /*
     *	put out a jump to any kind of label
     */
printjbr( prefix , label )
    char	*prefix;
    long	label;
    {

	putprintf( "	jbr	" , 1 );
	putprintf( PREFIXFORMAT , 0 , prefix , label );
    }

    /*
     *	another version of put to catch calls to put
     */
put( arg1 , arg2 )
    {

	putprintf( "#	PUT CALLED!: arg1 = %d arg2 = 0%o" , 0 , arg1 , arg2 );
    }

#endif PC
Commit	Line	Data
b6a29e28 PK	1	/* Copyright (c) 1979 Regents of the University of California */
b6a29e28 PK	2
270467f1	3	static char sccsid[] = "@(#)p2put.c 1.10 %G%";
b6a29e28 PK	4
	5	/*
	6	* functions to help pi put out
	7	* polish postfix binary portable c compiler intermediate code
	8	* thereby becoming the portable pascal compiler
	9	*/
	10
	11	#include "whoami.h"
	12	#ifdef PC
	13	#include "0.h"
	14	#include "pcops.h"
	15	#include "pc.h"
	16
	17	/*
	18	* mash into f77's format
	19	* lovely, isn't it?
	20	*/
	21	#define TOF77( fop,val,rest ) ( ( ( (rest) & 0177777 ) << 16 ) \
	22	\| ( ( (val) & 0377 ) << 8 ) \
	23	\| ( (fop) & 0377 ) )
	24	\f
	25	/*
	26	* emits an ftext operator and a string to the pcstream
	27	*/
	28	puttext( string )
	29	char *string;
	30	{
	31	int length = str4len( string );
	32
f3434f0c	33	if ( !CGENNING )
b6a29e28 PK	34	return;
	35	p2word( TOF77( P2FTEXT , length , 0 ) );
	36	# ifdef DEBUG
	37	if ( opt( 'k' ) ) {
	38	fprintf( stdout , "P2FTEXT \| %3d \| 0 " , length );
	39	}
	40	# endif
	41	p2string( string );
	42	}
	43
	44	int
	45	str4len( string )
	46	char *string;
	47	{
	48
	49	return ( ( strlen( string ) + 3 ) / 4 );
	50	}
	51
	52	/*
	53	* put formatted text into a buffer for printing to the pcstream.
	54	* a call to putpflush actually puts out the text.
	55	* none of arg1 .. arg5 need be present.
	56	* and you can add more if you need them.
	57	*/
	58	/* VARARGS */
	59	putprintf( format , incomplete , arg1 , arg2 , arg3 , arg4 , arg5 )
	60	char *format;
	61	int incomplete;
	62	{
	63	static char ppbuffer[ BUFSIZ ];
	64	static char *ppbufp = ppbuffer;
	65
f3434f0c	66	if ( !CGENNING )
b6a29e28 PK	67	return;
	68	sprintf( ppbufp , format , arg1 , arg2 , arg3 , arg4 , arg5 );
	69	ppbufp = &( ppbuffer[ strlen( ppbuffer ) ] );
	70	if ( ppbufp >= &( ppbuffer[ BUFSIZ ] ) )
	71	panic( "putprintf" );
	72	if ( ! incomplete ) {
	73	puttext( ppbuffer );
	74	ppbufp = ppbuffer;
	75	}
	76	}
	77
	78	/*
	79	* emit a left bracket operator to pcstream
	80	* with function number, the maximum temp register, and total local bytes
	81	* until i figure out how to use them, regs 0 .. 11 are free.
	82	* one idea for one reg is to save the display pointer on block entry
	83	*/
	84	putlbracket( ftnno , localbytes )
	85	int ftnno;
	86	int localbytes;
	87	{
	88	# define MAXTP2REG 11
	89
	90	p2word( TOF77( P2FLBRAC , MAXTP2REG , ftnno ) );
	91	p2word( BITSPERBYTE * localbytes );
	92	# ifdef DEBUG
	93	if ( opt( 'k' ) ) {
	94	fprintf( stdout
	95	, "P2FLBRAC \| %3d \| %d " , MAXTP2REG , ftnno );
	96	fprintf( stdout , "%d\n"
	97	, BITSPERBYTE * localbytes );
	98	}
	99	# endif
	100	}
	101
	102	/*
	103	* emit a right bracket operator
	104	* which for the binary (fortran) interface
	105	* forces the stack allocate and register mask
	106	*/
	107	putrbracket( ftnno )
	108	int ftnno;
	109	{
	110
	111	p2word( TOF77( P2FRBRAC , 0 , ftnno ) );
	112	# ifdef DEBUG
	113	if ( opt( 'k' ) ) {
	114	fprintf( stdout , "P2FRBRAC \| 0 \| %d\n" , ftnno );
	115	}
	116	# endif
	117	}
	118
	119	/*
	120	* emit an eof operator
	121	*/
	122	puteof()
	123	{
	124
	125	p2word( P2FEOF );
	126	# ifdef DEBUG
	127	if ( opt( 'k' ) ) {
	128	fprintf( stdout , "P2FEOF\n" );
	129	}
	130	# endif
131	}
132
133	/*
134	* emit a dot operator,
135	* with a source file line number and name
136	* if line is negative, there was an error on that line, but who cares?
137	*/
138	putdot( filename , line )
139	char *filename;
140	int line;
141	{
142	int length = str4len( filename );
143
144	if ( line < 0 ) {
145	line = -line;
146	}
147	p2word( TOF77( P2FEXPR , length , line ) );
148	# ifdef DEBUG
149	if ( opt( 'k' ) ) {
150	fprintf( stdout , "P2FEXPR \| %3d \| %d " , length , line );
151	}
152	# endif
153	p2string( filename );
154	}
155
156	/*
157	* put out a leaf node
158	*/
159	putleaf( op , lval , rval , type , name )
160	int op;
161	int lval;
162	int rval;
163	int type;
164	char *name;
165	{
f3434f0c	166	if ( !CGENNING )
b6a29e28 PK	167	return;
	168	switch ( op ) {
	169	default:
	170	panic( "[putleaf]" );
	171	case P2ICON:
	172	p2word( TOF77( P2ICON , name != NIL , type ) );
	173	p2word( lval );
	174	# ifdef DEBUG
	175	if ( opt( 'k' ) ) {
d7dc4314	176	fprintf( stdout , "P2ICON \| %3d \| 0x%x "
b6a29e28 PK	177	, name != NIL , type );
	178	fprintf( stdout , "%d\n" , lval );
	179	}
	180	# endif
	181	if ( name )
	182	p2name( name );
	183	break;
	184	case P2NAME:
	185	p2word( TOF77( P2NAME , lval != 0 , type ) );
	186	if ( lval )
	187	p2word( lval );
	188	# ifdef DEBUG
	189	if ( opt( 'k' ) ) {
d7dc4314	190	fprintf( stdout , "P2NAME \| %3d \| 0x%x "
b6a29e28 PK	191	, lval != 0 , type );
	192	if ( lval )
	193	fprintf( stdout , "%d " , lval );
	194	}
	195	# endif
	196	p2name( name );
	197	break;
	198	case P2REG:
	199	p2word( TOF77( P2REG , rval , type ) );
	200	# ifdef DEBUG
	201	if ( opt( 'k' ) ) {
d7dc4314 PK	202	fprintf( stdout , "P2REG \| %3d \| 0x%x\n" ,
d7dc4314 PK	203	rval , type );
b6a29e28 PK	204	}
	205	# endif
	206	break;
	207	}
	208	}
	209
	210	/*
	211	* rvalues are just lvalues with indirection, except
1f43951f PK	212	* special cases for registers and for named globals,
1f43951f PK	213	* whose names are their rvalues.
b6a29e28	214	*/
270467f1	215	putRV( name , level , offset , other_flags , type )
b6a29e28 PK	216	char *name;
	217	int level;
	218	int offset;
270467f1	219	char other_flags;
b6a29e28 PK	220	int type;
	221	{
	222	char extname[ BUFSIZ ];
	223	char *printname;
b401cf0d	224	int regnumber;
b6a29e28	225
f3434f0c	226	if ( !CGENNING )
b6a29e28	227	return;
270467f1	228	if ( other_flags & NREGVAR ) {
1f43951f PK	229	if ( ( offset < 0 ) \|\| ( offset > P2FP ) ) {
1f43951f PK	230	panic( "putRV regvar" );
b401cf0d	231	}
1f43951f	232	putleaf( P2REG , 0 , offset , type , 0 );
4cadac06 KM	233	return;
4cadac06 KM	234	}
270467f1	235	if ( whereis( level , offset , other_flags ) == GLOBALVAR ) {
1f43951f PK	236	if ( name != 0 ) {
	237	if ( name[0] != '_' ) {
	238	sprintf( extname , EXTFORMAT , name );
	239	printname = extname;
	240	} else {
	241	printname = name;
	242	}
	243	putleaf( P2NAME , offset , 0 , type , printname );
	244	return;
b6a29e28	245	} else {
1f43951f	246	panic( "putRV no name" );
b6a29e28	247	}
b6a29e28	248	}
270467f1	249	putLV( name , level , offset , other_flags , type );
b6a29e28 PK	250	putop( P2UNARY P2MUL , type );
	251	}
	252
	253	/*
	254	* put out an lvalue
	255	* given a level and offset
	256	* special case for
	257	* named globals, whose lvalues are just their names as constants.
b6a29e28	258	*/
270467f1	259	putLV( name , level , offset , other_flags , type )
b6a29e28 PK	260	char *name;
	261	int level;
	262	int offset;
270467f1	263	char other_flags;
b6a29e28	264	int type;
4cadac06 KM	265	{
	266	char extname[ BUFSIZ ];
	267	char *printname;
b6a29e28	268
f3434f0c	269	if ( !CGENNING )
4cadac06	270	return;
270467f1	271	if ( other_flags & NREGVAR ) {
1f43951f	272	panic( "putLV regvar" );
b6a29e28	273	}
270467f1	274	switch ( whereis( level , offset , other_flags ) ) {
1f43951f PK	275	case GLOBALVAR:
	276	if ( ( name != 0 ) ) {
	277	if ( name[0] != '_' ) {
	278	sprintf( extname , EXTFORMAT , name );
	279	printname = extname;
	280	} else {
	281	printname = name;
	282	}
	283	putleaf( P2ICON , offset , 0 , ADDTYPE( type , P2PTR )
	284	, printname );
	285	return;
	286	} else {
	287	panic( "putLV no name" );
	288	}
4cadac06 KM	289	case PARAMVAR:
	290	if ( level == cbn ) {
	291	putleaf( P2REG , 0 , P2AP , ADDTYPE( type , P2PTR ) , 0 );
	292	} else {
	293	putleaf( P2NAME , (level * sizeof(struct dispsave)) + AP_OFFSET
	294	, 0 , P2PTR \| P2CHAR , DISPLAYNAME );
	295	}
	296	putleaf( P2ICON , offset , 0 , P2INT , 0 );
	297	putop( P2PLUS , P2PTR \| P2CHAR );
	298	break;
	299	case LOCALVAR:
	300	if ( level == cbn ) {
	301	putleaf( P2REG , 0 , P2FP , ADDTYPE( type , P2PTR ) , 0 );
	302	} else {
	303	putleaf( P2NAME , (level * sizeof(struct dispsave)) + FP_OFFSET
	304	, 0 , P2PTR \| P2CHAR , DISPLAYNAME );
	305	}
	306	putleaf( P2ICON , -offset , 0 , P2INT , 0 );
	307	putop( P2MINUS , P2PTR \| P2CHAR );
	308	break;
4cadac06 KM	309	}
	310	return;
	311	}
b6a29e28 PK	312
	313	/*
	314	* put out a floating point constant leaf node
	315	* the constant is declared in aligned data space
	316	* and a P2NAME leaf put out for it
	317	*/
270467f1 KM	318	putCON8( val )
270467f1 KM	319	double val;
b6a29e28 PK	320	{
	321	int label;
	322	char name[ BUFSIZ ];
	323
f3434f0c	324	if ( !CGENNING )
b6a29e28 PK	325	return;
	326	putprintf( " .data" , 0 );
	327	putprintf( " .align 2" , 0 );
	328	label = getlab();
	329	putlab( label );
270467f1	330	putprintf( " .double 0d%.20e" , 0 , val );
b6a29e28 PK	331	putprintf( " .text" , 0 );
	332	sprintf( name , PREFIXFORMAT , LABELPREFIX , label );
	333	putleaf( P2NAME , 0 , 0 , P2DOUBLE , name );
	334	}
	335
	336	/*
	337	* put out either an lvalue or an rvalue for a constant string.
	338	* an lvalue (for assignment rhs's) is the name as a constant,
	339	* an rvalue (for parameters) is just the name.
	340	*/
	341	putCONG( string , length , required )
	342	char *string;
	343	int length;
	344	int required;
	345	{
	346	char name[ BUFSIZ ];
	347	int label;
	348	char *cp;
	349	int pad;
	350	int others;
	351
f3434f0c	352	if ( !CGENNING )
b6a29e28 PK	353	return;
	354	putprintf( " .data" , 0 );
	355	label = getlab();
	356	putlab( label );
	357	cp = string;
	358	while ( *cp ) {
	359	putprintf( " .byte 0%o" , 1 , *cp ++ );
	360	for ( others = 2 ; ( others <= 8 ) && *cp ; others ++ ) {
	361	putprintf( ",0%o" , 1 , *cp++ );
	362	}
	363	putprintf( "" , 0 );
	364	}
	365	pad = length - strlen( string );
	366	while ( pad-- > 0 ) {
	367	putprintf( " .byte 0%o" , 1 , ' ' );
	368	for ( others = 2 ; ( others <= 8 ) && ( pad-- > 0 ) ; others++ ) {
	369	putprintf( ",0%o" , 1 , ' ' );
	370	}
	371	putprintf( "" , 0 );
	372	}
	373	putprintf( " .byte 0" , 0 );
	374	putprintf( " .text" , 0 );
	375	sprintf( name , PREFIXFORMAT , LABELPREFIX , label );
	376	if ( required == RREQ ) {
	377	putleaf( P2NAME , 0 , 0 , P2ARY \| P2CHAR , name );
	378	} else {
	379	putleaf( P2ICON , 0 , 0 , P2PTR \| P2CHAR , name );
	380	}
	381	}
	382
	383	/*
	384	* map a pascal type to a c type
	385	* this would be tail recursive, but i unfolded it into a for (;;).
	386	* this is sort of like isa and lwidth
	387	* a note on the types used by the portable c compiler:
	388	* they are divided into a basic type (char, short, int, long, etc.)
	389	* and qualifications on those basic types (pointer, function, array).
	390	* the basic type is kept in the low 4 bits of the type descriptor,
	391	* and the qualifications are arranged in two bit chunks, with the
	392	* most significant on the right,
	393	* and the least significant on the left
	394	* e.g. int *foo();
	395	* (a function returning a pointer to an integer)
	396	* is stored as
	397	* <ptr><ftn><int>
	398	* so, we build types recursively
542a2aa0 PK	399	* also, we know that /lib/f1 can only deal with 6 qualifications
	400	* so we stop the recursion there. this stops infinite type recursion
	401	* through mutually recursive pointer types.
b6a29e28	402	*/
542a2aa0	403	#define MAXQUALS 6
b6a29e28 PK	404	int
b6a29e28 PK	405	p2type( np )
542a2aa0 PK	406	{
	407
	408	return typerecur( np , 0 );
	409	}
	410	typerecur( np , quals )
	411	struct nl *np;
	412	int quals;
b6a29e28 PK	413	{
b6a29e28 PK	414
542a2aa0 PK	415	if ( np == NIL \|\| quals > MAXQUALS ) {
	416	return P2UNDEF;
	417	}
b6a29e28 PK	418	switch ( np -> class ) {
	419	case SCAL :
	420	case RANGE :
	421	if ( np -> type == ( nl + TDOUBLE ) ) {
	422	return P2DOUBLE;
	423	}
	424	switch ( bytes( np -> range[0] , np -> range[1] ) ) {
	425	case 1:
	426	return P2CHAR;
	427	case 2:
	428	return P2SHORT;
	429	case 4:
	430	return P2INT;
	431	default:
	432	panic( "p2type int" );
	433	}
	434	case STR :
	435	return ( P2ARY \| P2CHAR );
b6a29e28 PK	436	case RECORD :
	437	case SET :
	438	return P2STRTY;
	439	case FILET :
	440	return ( P2PTR \| P2STRTY );
	441	case CONST :
	442	case VAR :
	443	case FIELD :
	444	return p2type( np -> type );
	445	case TYPE :
	446	switch ( nloff( np ) ) {
	447	case TNIL :
542a2aa0	448	return ( P2PTR \| P2UNDEF );
b6a29e28 PK	449	case TSTR :
b6a29e28 PK	450	return ( P2ARY \| P2CHAR );
b6a29e28 PK	451	case TSET :
	452	return P2STRTY;
	453	default :
	454	return ( p2type( np -> type ) );
	455	}
	456	case REF:
	457	case WITHPTR:
	458	case PTR :
542a2aa0	459	return ADDTYPE( typerecur( np -> type , quals + 1 ) , P2PTR );
b6a29e28	460	case ARRAY :
542a2aa0	461	return ADDTYPE( typerecur( np -> type , quals + 1 ) , P2ARY );
b6a29e28 PK	462	case FUNC :
	463	/*
	464	* functions are really pointers to functions
	465	* which return their underlying type.
	466	*/
542a2aa0 PK	467	return ADDTYPE( ADDTYPE( typerecur( np -> type , quals + 2 ) ,
542a2aa0 PK	468	P2FTN ) , P2PTR );
b6a29e28 PK	469	case PROC :
	470	/*
	471	* procedures are pointers to functions
	472	* which return integers (whether you look at them or not)
	473	*/
	474	return ADDTYPE( ADDTYPE( P2INT , P2FTN ) , P2PTR );
c4e911b6 PK	475	case FFUNC :
	476	case FPROC :
	477	/*
	478	* formal procedures and functions are pointers
	479	* to structures which describe their environment.
	480	*/
d7dc4314	481	return ( P2PTR \| P2STRTY );
b6a29e28	482	default :
b6a29e28 PK	483	panic( "p2type" );
	484	}
	485	}
	486
	487	/*
	488	* add a most significant type modifier to a type
	489	*/
	490	long
	491	addtype( underlying , mtype )
	492	long underlying;
	493	long mtype;
	494	{
	495	return ( ( ( underlying & ~P2BASETYPE ) << P2TYPESHIFT )
	496	\| mtype
	497	\| ( underlying & P2BASETYPE ) );
	498	}
	499	\f
	500	/*
	501	* put a typed operator to the pcstream
	502	*/
	503	putop( op , type )
	504	int op;
	505	int type;
	506	{
	507	extern char *p2opnames[];
	508
f3434f0c	509	if ( !CGENNING )
b6a29e28 PK	510	return;
	511	p2word( TOF77( op , 0 , type ) );
	512	# ifdef DEBUG
	513	if ( opt( 'k' ) ) {
d7dc4314	514	fprintf( stdout , "%s (%d) \| 0 \| 0x%x\n"
b6a29e28 PK	515	, p2opnames[ op ] , op , type );
	516	}
	517	# endif
	518	}
	519
	520	/*
	521	* put out a structure operator (STASG, STARG, STCALL, UNARY STCALL )
	522	* which looks just like a regular operator, only the size and
	523	* alignment go in the next consecutive words
	524	*/
	525	putstrop( op , type , size , alignment )
	526	int op;
	527	int type;
	528	int size;
	529	int alignment;
	530	{
	531	extern char *p2opnames[];
	532
f3434f0c	533	if ( !CGENNING )
b6a29e28 PK	534	return;
	535	p2word( TOF77( op , 0 , type ) );
	536	p2word( size );
	537	p2word( alignment );
	538	# ifdef DEBUG
	539	if ( opt( 'k' ) ) {
d7dc4314	540	fprintf( stdout , "%s (%d) \| 0 \| 0x%x %d %d\n"
b6a29e28 PK	541	, p2opnames[ op ] , op , type , size , alignment );
	542	}
	543	# endif
	544	}
	545
	546	/*
	547	* the string names of p2ops
	548	*/
	549	char *p2opnames[] = {
	550	"",
	551	"P2UNDEFINED", /* 1 */
	552	"P2NAME", /* 2 */
	553	"P2STRING", /* 3 */
	554	"P2ICON", /* 4 */
	555	"P2FCON", /* 5 */
	556	"P2PLUS", /* 6 */
	557	"",
	558	"P2MINUS", /* 8 also unary == P2NEG */
	559	"",
	560	"P2NEG",
	561	"P2MUL", /* 11 also unary == P2INDIRECT */
	562	"",
	563	"P2INDIRECT",
	564	"P2AND", /* 14 also unary == P2ADDROF */
	565	"",
	566	"P2ADDROF",
	567	"P2OR", /* 17 */
	568	"",
	569	"P2ER", /* 19 */
	570	"",
	571	"P2QUEST", /* 21 */
	572	"P2COLON", /* 22 */
	573	"P2ANDAND", /* 23 */
	574	"P2OROR", /* 24 */
	575	"", /* 25 */
	576	"", /* 26 */
	577	"", /* 27 */
	578	"", /* 28 */
	579	"", /* 29 */
	580	"", /* 30 */
	581	"", /* 31 */
	582	"", /* 32 */
	583	"", /* 33 */
	584	"", /* 34 */
	585	"", /* 35 */
	586	"", /* 36 */
	587	"", /* 37 */
	588	"", /* 38 */
	589	"", /* 39 */
	590	"", /* 40 */
	591	"", /* 41 */
	592	"", /* 42 */
	593	"", /* 43 */
	594	"", /* 44 */
	595	"", /* 45 */
	596	"", /* 46 */
	597	"", /* 47 */
	598	"", /* 48 */
	599	"", /* 49 */
	600	"", /* 50 */
	601	"", /* 51 */
	602	"", /* 52 */
	603	"", /* 53 */
	604	"", /* 54 */
605	"", /* 55 */
606	"P2LISTOP", /* 56 */
607	"",
608	"P2ASSIGN", /* 58 */
609	"P2COMOP", /* 59 */
610	"P2DIV", /* 60 */
611	"",
612	"P2MOD", /* 62 */
613	"",
614	"P2LS", /* 64 */
615	"",
616	"P2RS", /* 66 */
617	"",
618	"P2DOT", /* 68 */
619	"P2STREF", /* 69 */
620	"P2CALL", /* 70 also unary */
621	"",
622	"P2UNARYCALL",
623	"P2FORTCALL", /* 73 also unary */
624	"",
625	"P2UNARYFORTCALL",
626	"P2NOT", /* 76 */
627	"P2COMPL", /* 77 */
628	"P2INCR", /* 78 */
629	"P2DECR", /* 79 */
630	"P2EQ", /* 80 */
631	"P2NE", /* 81 */
632	"P2LE", /* 82 */
633	"P2LT", /* 83 */
634	"P2GE", /* 84 */
635	"P2GT", /* 85 */
636	"P2ULE", /* 86 */
637	"P2ULT", /* 87 */
638	"P2UGE", /* 88 */
639	"P2UGT", /* 89 */
640	"P2SETBIT", /* 90 */
641	"P2TESTBIT", /* 91 */
642	"P2RESETBIT", /* 92 */
643	"P2ARS", /* 93 */
644	"P2REG", /* 94 */
645	"P2OREG", /* 95 */
646	"P2CCODES", /* 96 */
647	"P2FREE", /* 97 */
648	"P2STASG", /* 98 */
649	"P2STARG", /* 99 */
650	"P2STCALL", /* 100 also unary */
651	"",
652	"P2UNARYSTCALL",
653	"P2FLD", /* 103 */
654	"P2SCONV", /* 104 */
655	"P2PCONV", /* 105 */
656	"P2PMCONV", /* 106 */
657	"P2PVCONV", /* 107 */
658	"P2FORCE", /* 108 */
659	"P2CBRANCH", /* 109 */
660	"P2INIT", /* 110 */
661	"P2CAST", /* 111 */
662	};
663	\f
664	/*
665	* low level routines
666	*/
667
668	/*
669	* puts a long word on the pcstream
670	*/
671	p2word( word )
672	long word;
673	{
674
675	putw( word , pcstream );
676	}
677
678	/*
679	* put a length 0 mod 4 null padded string onto the pcstream
680	*/
681	p2string( string )
682	char *string;
683	{
684	int slen = strlen( string );
685	int wlen = ( slen + 3 ) / 4;
686	int plen = ( wlen * 4 ) - slen;
687	char *cp;
688	int p;
689
690	for ( cp = string ; *cp ; cp++ )
691	putc( *cp , pcstream );
692	for ( p = 1 ; p <= plen ; p++ )
693	putc( '\0' , pcstream );
694	# ifdef DEBUG
695	if ( opt( 'k' ) ) {
696	fprintf( stdout , "\"%s" , string );
697	for ( p = 1 ; p <= plen ; p++ )
698	fprintf( stdout , "\\0" );
699	fprintf( stdout , "\"\n" );
700	}
701	# endif
702	}
703
704	/*
705	* puts a name on the pcstream
706	*/
707	p2name( name )
708	char *name;
709	{
710	int pad;
711
712	fprintf( pcstream , NAMEFORMAT , name );
713	pad = strlen( name ) % sizeof (long);
714	for ( ; pad < sizeof (long) ; pad++ ) {
715	putc( '\0' , pcstream );
716	}
717	# ifdef DEBUG
718	if ( opt( 'k' ) ) {
719	fprintf( stdout , NAMEFORMAT , name );
720	pad = strlen( name ) % sizeof (long);
721	for ( ; pad < sizeof (long) ; pad++ ) {
722	fprintf( stdout , "\\0" );
723	}
724	fprintf( stdout , "\n" );
725	}
726	# endif
727	}
728
729	/*
730	* put out a jump to a label
731	*/
732	putjbr( label )
733	long label;
734	{
735
736	printjbr( LABELPREFIX , label );
737	}
738
739	/*
740	* put out a jump to any kind of label
741	*/
742	printjbr( prefix , label )
743	char *prefix;
744	long label;
745	{
746
747	putprintf( " jbr " , 1 );
748	putprintf( PREFIXFORMAT , 0 , prefix , label );
749	}
750
751	/*
752	* another version of put to catch calls to put
753	*/
754	put( arg1 , arg2 )
755	{
756
757	putprintf( "# PUT CALLED!: arg1 = %d arg2 = 0%o" , 0 , arg1 , arg2 );
758	}
759
760	#endif PC