[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.2 %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 ( cgenflg )
	    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 ( cgenflg )
	    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 ( cgenflg )
	    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 | %d	" 
			       , 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 | %d	" 
			       , 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 | %d\n" , rval , type );
		    }
#		endif
		break;
	}
    }

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

	if ( cgenflg )
	    return;
	if ( ( level <= 1 ) && ( name != 0 ) ) {
	    if ( name[0] != '_' ) {
		    sprintf( extname , EXTFORMAT , name );
		    printname = extname;
	    } else {
		    printname = name;
	    }
	    putleaf( P2NAME , offset , 0 , type , printname );
	    return;
	}
	putLV( name , level , offset , 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.
     *	    negative offsets, that are offsets from the frame pointer.
     *	    positive offsets, that are offsets from argument pointer.
     */
putLV( name , level , offset , type )
    char	*name;
    int		level;
    int		offset;
    int		type;
    {
	char		extname[ BUFSIZ ];
	char		*printname;

	if ( cgenflg )
	    return;
	if ( ( level <= 1 ) && ( name != 0 ) ) {
	    if ( name[0] != '_' ) {
		    sprintf( extname , EXTFORMAT , name );
		    printname = extname;
	    } else {
		    printname = name;
	    }
	    putleaf( P2ICON , offset , 0 , ADDTYPE( type , P2PTR )
		    , printname );
	    return;
	}
	if ( level == cbn ) {
		if ( offset < 0 ) {
		    putleaf( P2REG , 0 , P2FP , ADDTYPE( type , P2PTR ) , 0 );
		} else {
		    putleaf( P2REG , 0 , P2AP , ADDTYPE( type , P2PTR ) , 0 );
		}
	} else {
		if ( offset < 0 ) {
			putleaf( P2NAME
			    , ( level * sizeof(struct dispsave) ) + FP_OFFSET
			    , 0 , P2PTR | P2CHAR , DISPLAYNAME );
		} else {
			putleaf( P2NAME
			    , ( level * sizeof(struct dispsave) ) + AP_OFFSET
			    , 0 , P2PTR | P2CHAR , DISPLAYNAME );
		}
	}
	if ( offset < 0 ) {
		putleaf( P2ICON , -offset , 0 , P2INT , 0 );
		putop( P2MINUS , P2PTR | P2CHAR );
	} else {
		putleaf( P2ICON , offset , 0 , P2INT , 0 );
		putop( P2PLUS , P2PTR | P2CHAR );
	}
	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( value )
    double	value;
    {
	int	label;
	char	name[ BUFSIZ ];

	if ( cgenflg )
	    return;
	putprintf( "	.data" , 0 );
	putprintf( "	.align 2" , 0 );
	label = getlab();
	putlab( label );
	putprintf( "	.double 0d%.20e" , 0 , value );
	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 ( cgenflg )
	    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
     */
int
p2type( np )
    struct nl *np;
    {
	
	if ( np == NIL )
	    return P2UNDEFINED;
	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 );
		/*
		return P2STRTY;
		*/
	    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 | P2UNDEFINED );
		    case TSTR :
			return ( P2ARY | P2CHAR );
			/*
			return P2STRTY;
			*/
		    case TSET :
			return P2STRTY;
		    default :
			return ( p2type( np -> type ) );
		}
	    case REF:
	    case WITHPTR:
	    case PTR :
		return ADDTYPE( p2type( np -> type ) , P2PTR );
	    case ARRAY :
		return ADDTYPE( p2type( np -> type ) , P2ARY );
		/*
		return P2STRTY;
		*/
	    case FUNC :
		    /*
		     * functions are really pointers to functions
		     * which return their underlying type.
		     */
		return ADDTYPE( ADDTYPE( p2type( np -> type ) , 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 ADDTYPE( P2PTR , P2STRTY );
	    default :
		fprintf( stderr , "[p2type] np -> class %d\n" , np -> class );
		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 ( cgenflg )
	    return;
	p2word( TOF77( op , 0 , type ) );
#	ifdef DEBUG
	    if ( opt( 'k' ) ) {
		fprintf( stdout , "%s (%d) |   0 | %d\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 ( cgenflg )
	    return;
	p2word( TOF77( op , 0 , type ) );
	p2word( size );
	p2word( alignment );
#	ifdef DEBUG
	    if ( opt( 'k' ) ) {
		fprintf( stdout , "%s (%d) |   0 | %d	%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
c4e911b6	3	static char sccsid[] = "@(#)p2put.c 1.2 %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
	33	if ( cgenflg )
	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
	66	if ( cgenflg )
	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	{
166	if ( cgenflg )
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' ) ) {
176	fprintf( stdout , "P2ICON \| %3d \| %d "
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' ) ) {
190	fprintf( stdout , "P2NAME \| %3d \| %d "
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' ) ) {
202	fprintf( stdout , "P2REG \| %3d \| %d\n" , rval , type );
203	}
204	# endif
205	break;
206	}
207	}
208
209	/*
210	* rvalues are just lvalues with indirection, except
211	* special case for named globals, whose names are their rvalues
212	*/
213	putRV( name , level , offset , type )
214	char *name;
215	int level;
216	int offset;
217	int type;
218	{
219	char extname[ BUFSIZ ];
220	char *printname;
221
222	if ( cgenflg )
223	return;
224	if ( ( level <= 1 ) && ( name != 0 ) ) {
225	if ( name[0] != '_' ) {
226	sprintf( extname , EXTFORMAT , name );
227	printname = extname;
228	} else {
229	printname = name;
230	}
231	putleaf( P2NAME , offset , 0 , type , printname );
232	return;
233	}
234	putLV( name , level , offset , type );
235	putop( P2UNARY P2MUL , type );
236	}
237
238	/*
239	* put out an lvalue
240	* given a level and offset
241	* special case for
242	* named globals, whose lvalues are just their names as constants.
243	* negative offsets, that are offsets from the frame pointer.
244	* positive offsets, that are offsets from argument pointer.
245	*/
246	putLV( name , level , offset , type )
247	char *name;
248	int level;
249	int offset;
250	int type;
251	{
252	char extname[ BUFSIZ ];
253	char *printname;
254
255	if ( cgenflg )
256	return;
257	if ( ( level <= 1 ) && ( name != 0 ) ) {
258	if ( name[0] != '_' ) {
259	sprintf( extname , EXTFORMAT , name );
260	printname = extname;
261	} else {
262	printname = name;
263	}
264	putleaf( P2ICON , offset , 0 , ADDTYPE( type , P2PTR )
265	, printname );
266	return;
267	}
268	if ( level == cbn ) {
269	if ( offset < 0 ) {
270	putleaf( P2REG , 0 , P2FP , ADDTYPE( type , P2PTR ) , 0 );
271	} else {
272	putleaf( P2REG , 0 , P2AP , ADDTYPE( type , P2PTR ) , 0 );
273	}
274	} else {
275	if ( offset < 0 ) {
276	putleaf( P2NAME
277	, ( level * sizeof(struct dispsave) ) + FP_OFFSET
278	, 0 , P2PTR \| P2CHAR , DISPLAYNAME );
279	} else {
280	putleaf( P2NAME
281	, ( level * sizeof(struct dispsave) ) + AP_OFFSET
282	, 0 , P2PTR \| P2CHAR , DISPLAYNAME );
283	}
284	}
285	if ( offset < 0 ) {
286	putleaf( P2ICON , -offset , 0 , P2INT , 0 );
287	putop( P2MINUS , P2PTR \| P2CHAR );
288	} else {
289	putleaf( P2ICON , offset , 0 , P2INT , 0 );
290	putop( P2PLUS , P2PTR \| P2CHAR );
291	}
292	return;
293	}
294
295	/*
296	* put out a floating point constant leaf node
297	* the constant is declared in aligned data space
298	* and a P2NAME leaf put out for it
299	*/
300	putCON8( value )
301	double value;
302	{
303	int label;
304	char name[ BUFSIZ ];
305
306	if ( cgenflg )
307	return;
308	putprintf( " .data" , 0 );
309	putprintf( " .align 2" , 0 );
310	label = getlab();
311	putlab( label );
312	putprintf( " .double 0d%.20e" , 0 , value );
313	putprintf( " .text" , 0 );
314	sprintf( name , PREFIXFORMAT , LABELPREFIX , label );
315	putleaf( P2NAME , 0 , 0 , P2DOUBLE , name );
316	}
317
318	/*
319	* put out either an lvalue or an rvalue for a constant string.
320	* an lvalue (for assignment rhs's) is the name as a constant,
321	* an rvalue (for parameters) is just the name.
322	*/
323	putCONG( string , length , required )
324	char *string;
325	int length;
326	int required;
327	{
328	char name[ BUFSIZ ];
329	int label;
330	char *cp;
331	int pad;
332	int others;
333
334	if ( cgenflg )
335	return;
336	putprintf( " .data" , 0 );
337	label = getlab();
338	putlab( label );
339	cp = string;
340	while ( *cp ) {
341	putprintf( " .byte 0%o" , 1 , *cp ++ );
342	for ( others = 2 ; ( others <= 8 ) && *cp ; others ++ ) {
343	putprintf( ",0%o" , 1 , *cp++ );
344	}
345	putprintf( "" , 0 );
346	}
347	pad = length - strlen( string );
348	while ( pad-- > 0 ) {
349	putprintf( " .byte 0%o" , 1 , ' ' );
350	for ( others = 2 ; ( others <= 8 ) && ( pad-- > 0 ) ; others++ ) {
351	putprintf( ",0%o" , 1 , ' ' );
352	}
353	putprintf( "" , 0 );
354	}
355	putprintf( " .byte 0" , 0 );
356	putprintf( " .text" , 0 );
357	sprintf( name , PREFIXFORMAT , LABELPREFIX , label );
358	if ( required == RREQ ) {
359	putleaf( P2NAME , 0 , 0 , P2ARY \| P2CHAR , name );
360	} else {
361	putleaf( P2ICON , 0 , 0 , P2PTR \| P2CHAR , name );
362	}
363	}
364
365	/*
366	* map a pascal type to a c type
367	* this would be tail recursive, but i unfolded it into a for (;;).
368	* this is sort of like isa and lwidth
369	* a note on the types used by the portable c compiler:
370	* they are divided into a basic type (char, short, int, long, etc.)
371	* and qualifications on those basic types (pointer, function, array).
372	* the basic type is kept in the low 4 bits of the type descriptor,
373	* and the qualifications are arranged in two bit chunks, with the
374	* most significant on the right,
375	* and the least significant on the left
376	* e.g. int *foo();
377	* (a function returning a pointer to an integer)
378	* is stored as
379	* <ptr><ftn><int>
380	* so, we build types recursively
381	*/
382	int
383	p2type( np )
384	struct nl *np;
385	{
386
387	if ( np == NIL )
388	return P2UNDEFINED;
389	switch ( np -> class ) {
390	case SCAL :
391	case RANGE :
392	if ( np -> type == ( nl + TDOUBLE ) ) {
393	return P2DOUBLE;
394	}
395	switch ( bytes( np -> range[0] , np -> range[1] ) ) {
396	case 1:
397	return P2CHAR;
398	case 2:
399	return P2SHORT;
400	case 4:
401	return P2INT;
402	default:
403	panic( "p2type int" );
404	}
405	case STR :
406	return ( P2ARY \| P2CHAR );
407	/*
408	return P2STRTY;
409	*/
410	case RECORD :
411	case SET :
412	return P2STRTY;
413	case FILET :
414	return ( P2PTR \| P2STRTY );
415	case CONST :
416	case VAR :
417	case FIELD :
418	return p2type( np -> type );
419	case TYPE :
420	switch ( nloff( np ) ) {
421	case TNIL :
422	return ( P2PTR \| P2UNDEFINED );
423	case TSTR :
424	return ( P2ARY \| P2CHAR );
425	/*
426	return P2STRTY;
427	*/
428	case TSET :
429	return P2STRTY;
430	default :
431	return ( p2type( np -> type ) );
432	}
433	case REF:
434	case WITHPTR:
435	case PTR :
436	return ADDTYPE( p2type( np -> type ) , P2PTR );
437	case ARRAY :
438	return ADDTYPE( p2type( np -> type ) , P2ARY );
439	/*
440	return P2STRTY;
441	*/
442	case FUNC :
443	/*
444	* functions are really pointers to functions
445	* which return their underlying type.
446	*/
447	return ADDTYPE( ADDTYPE( p2type( np -> type ) , P2FTN )
448	, P2PTR );
449	case PROC :
450	/*
451	* procedures are pointers to functions
452	* which return integers (whether you look at them or not)
453	*/
454	return ADDTYPE( ADDTYPE( P2INT , P2FTN ) , P2PTR );
c4e911b6 PK	455	case FFUNC :
	456	case FPROC :
	457	/*
	458	* formal procedures and functions are pointers
	459	* to structures which describe their environment.
	460	*/
	461	return ADDTYPE( P2PTR , P2STRTY );
b6a29e28 PK	462	default :
	463	fprintf( stderr , "[p2type] np -> class %d\n" , np -> class );
	464	panic( "p2type" );
	465	}
	466	}
	467
	468	/*
	469	* add a most significant type modifier to a type
	470	*/
	471	long
	472	addtype( underlying , mtype )
	473	long underlying;
	474	long mtype;
	475	{
	476	return ( ( ( underlying & ~P2BASETYPE ) << P2TYPESHIFT )
	477	\| mtype
	478	\| ( underlying & P2BASETYPE ) );
	479	}
	480	\f
	481	/*
	482	* put a typed operator to the pcstream
	483	*/
	484	putop( op , type )
	485	int op;
	486	int type;
	487	{
	488	extern char *p2opnames[];
	489
	490	if ( cgenflg )
	491	return;
	492	p2word( TOF77( op , 0 , type ) );
	493	# ifdef DEBUG
	494	if ( opt( 'k' ) ) {
	495	fprintf( stdout , "%s (%d) \| 0 \| %d\n"
	496	, p2opnames[ op ] , op , type );
	497	}
	498	# endif
	499	}
	500
	501	/*
	502	* put out a structure operator (STASG, STARG, STCALL, UNARY STCALL )
	503	* which looks just like a regular operator, only the size and
	504	* alignment go in the next consecutive words
	505	*/
	506	putstrop( op , type , size , alignment )
	507	int op;
	508	int type;
	509	int size;
	510	int alignment;
	511	{
	512	extern char *p2opnames[];
	513
	514	if ( cgenflg )
	515	return;
	516	p2word( TOF77( op , 0 , type ) );
	517	p2word( size );
	518	p2word( alignment );
	519	# ifdef DEBUG
	520	if ( opt( 'k' ) ) {
	521	fprintf( stdout , "%s (%d) \| 0 \| %d %d %d\n"
	522	, p2opnames[ op ] , op , type , size , alignment );
	523	}
	524	# endif
	525	}
526
527	/*
528	* the string names of p2ops
529	*/
530	char *p2opnames[] = {
531	"",
532	"P2UNDEFINED", /* 1 */
533	"P2NAME", /* 2 */
534	"P2STRING", /* 3 */
535	"P2ICON", /* 4 */
536	"P2FCON", /* 5 */
537	"P2PLUS", /* 6 */
538	"",
539	"P2MINUS", /* 8 also unary == P2NEG */
540	"",
541	"P2NEG",
542	"P2MUL", /* 11 also unary == P2INDIRECT */
543	"",
544	"P2INDIRECT",
545	"P2AND", /* 14 also unary == P2ADDROF */
546	"",
547	"P2ADDROF",
548	"P2OR", /* 17 */
549	"",
550	"P2ER", /* 19 */
551	"",
552	"P2QUEST", /* 21 */
553	"P2COLON", /* 22 */
554	"P2ANDAND", /* 23 */
555	"P2OROR", /* 24 */
556	"", /* 25 */
557	"", /* 26 */
558	"", /* 27 */
559	"", /* 28 */
560	"", /* 29 */
561	"", /* 30 */
562	"", /* 31 */
563	"", /* 32 */
564	"", /* 33 */
565	"", /* 34 */
566	"", /* 35 */
567	"", /* 36 */
568	"", /* 37 */
569	"", /* 38 */
570	"", /* 39 */
571	"", /* 40 */
572	"", /* 41 */
573	"", /* 42 */
574	"", /* 43 */
575	"", /* 44 */
576	"", /* 45 */
577	"", /* 46 */
578	"", /* 47 */
579	"", /* 48 */
580	"", /* 49 */
581	"", /* 50 */
582	"", /* 51 */
583	"", /* 52 */
584	"", /* 53 */
585	"", /* 54 */
586	"", /* 55 */
587	"P2LISTOP", /* 56 */
588	"",
589	"P2ASSIGN", /* 58 */
590	"P2COMOP", /* 59 */
591	"P2DIV", /* 60 */
592	"",
593	"P2MOD", /* 62 */
594	"",
595	"P2LS", /* 64 */
596	"",
597	"P2RS", /* 66 */
598	"",
599	"P2DOT", /* 68 */
600	"P2STREF", /* 69 */
601	"P2CALL", /* 70 also unary */
602	"",
603	"P2UNARYCALL",
604	"P2FORTCALL", /* 73 also unary */
605	"",
606	"P2UNARYFORTCALL",
607	"P2NOT", /* 76 */
608	"P2COMPL", /* 77 */
609	"P2INCR", /* 78 */
610	"P2DECR", /* 79 */
611	"P2EQ", /* 80 */
612	"P2NE", /* 81 */
613	"P2LE", /* 82 */
614	"P2LT", /* 83 */
615	"P2GE", /* 84 */
616	"P2GT", /* 85 */
617	"P2ULE", /* 86 */
618	"P2ULT", /* 87 */
619	"P2UGE", /* 88 */
620	"P2UGT", /* 89 */
621	"P2SETBIT", /* 90 */
622	"P2TESTBIT", /* 91 */
623	"P2RESETBIT", /* 92 */
624	"P2ARS", /* 93 */
625	"P2REG", /* 94 */
626	"P2OREG", /* 95 */
627	"P2CCODES", /* 96 */
628	"P2FREE", /* 97 */
629	"P2STASG", /* 98 */
630	"P2STARG", /* 99 */
631	"P2STCALL", /* 100 also unary */
632	"",
633	"P2UNARYSTCALL",
634	"P2FLD", /* 103 */
635	"P2SCONV", /* 104 */
636	"P2PCONV", /* 105 */
637	"P2PMCONV", /* 106 */
638	"P2PVCONV", /* 107 */
639	"P2FORCE", /* 108 */
640	"P2CBRANCH", /* 109 */
641	"P2INIT", /* 110 */
642	"P2CAST", /* 111 */
643	};
644	\f
645	/*
646	* low level routines
647	*/
648
649	/*
650	* puts a long word on the pcstream
651	*/
652	p2word( word )
653	long word;
654	{
655
656	putw( word , pcstream );
657	}
658
659	/*
660	* put a length 0 mod 4 null padded string onto the pcstream
661	*/
662	p2string( string )
663	char *string;
664	{
665	int slen = strlen( string );
666	int wlen = ( slen + 3 ) / 4;
667	int plen = ( wlen * 4 ) - slen;
668	char *cp;
669	int p;
670
671	for ( cp = string ; *cp ; cp++ )
672	putc( *cp , pcstream );
673	for ( p = 1 ; p <= plen ; p++ )
674	putc( '\0' , pcstream );
675	# ifdef DEBUG
676	if ( opt( 'k' ) ) {
677	fprintf( stdout , "\"%s" , string );
678	for ( p = 1 ; p <= plen ; p++ )
679	fprintf( stdout , "\\0" );
680	fprintf( stdout , "\"\n" );
681	}
682	# endif
683	}
684
685	/*
686	* puts a name on the pcstream
687	*/
688	p2name( name )
689	char *name;
690	{
691	int pad;
692
693	fprintf( pcstream , NAMEFORMAT , name );
694	pad = strlen( name ) % sizeof (long);
695	for ( ; pad < sizeof (long) ; pad++ ) {
696	putc( '\0' , pcstream );
697	}
698	# ifdef DEBUG
699	if ( opt( 'k' ) ) {
700	fprintf( stdout , NAMEFORMAT , name );
701	pad = strlen( name ) % sizeof (long);
702	for ( ; pad < sizeof (long) ; pad++ ) {
703	fprintf( stdout , "\\0" );
704	}
705	fprintf( stdout , "\n" );
706	}
707	# endif
708	}
709
710	/*
711	* put out a jump to a label
712	*/
713	putjbr( label )
714	long label;
715	{
716
717	printjbr( LABELPREFIX , label );
718	}
719
720	/*
721	* put out a jump to any kind of label
722	*/
723	printjbr( prefix , label )
724	char *prefix;
725	long label;
726	{
727
728	putprintf( " jbr " , 1 );
729	putprintf( PREFIXFORMAT , 0 , prefix , label );
730	}
731
732	/*
733	* another version of put to catch calls to put
734	*/
735	put( arg1 , arg2 )
736	{
737
738	putprintf( "# PUT CALLED!: arg1 = %d arg2 = 0%o" , 0 , arg1 , arg2 );
739	}
740
741	#endif PC