pcproc.c

早期freebsd实现

/*-
 * Copyright (c) 1980, 1993
 *	The Regents of the University of California.  All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions
 * are met:
 * 1. Redistributions of source code must retain the above copyright
 *    notice, this list of conditions and the following disclaimer.
 * 2. Redistributions in binary form must reproduce the above copyright
 *    notice, this list of conditions and the following disclaimer in the
 *    documentation and/or other materials provided with the distribution.
 * 3. All advertising materials mentioning features or use of this software
 *    must display the following acknowledgement:
 *	This product includes software developed by the University of
 *	California, Berkeley and its contributors.
 * 4. Neither the name of the University nor the names of its contributors
 *    may be used to endorse or promote products derived from this software
 *    without specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
 * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
 * ARE DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
 * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
 * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
 * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
 * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
 * SUCH DAMAGE.
 */

#ifndef lint
static char sccsid[] = "@(#)pcproc.c	8.1 (Berkeley) 6/6/93";
#endif /* not lint */

#include "whoami.h"
#ifdef PC
    /*
     * and to the end of the file
     */
#include "0.h"
#include "tree.h"
#include "objfmt.h"
#include "opcode.h"
#include "pc.h"
#include <pcc.h>
#include "tmps.h"
#include "tree_ty.h"

/*
 * The constant EXPOSIZE specifies the number of digits in the exponent
 * of real numbers.
 *
 * The constant REALSPC defines the amount of forced padding preceeding
 * real numbers when they are printed. If REALSPC == 0, then no padding
 * is added, REALSPC == 1 adds one extra blank irregardless of the width
 * specified by the user.
 *
 * N.B. - Values greater than one require program mods.
 */
#define EXPOSIZE	2
#define	REALSPC		0

/*
 * The following array is used to determine which classes may be read
 * from textfiles. It is indexed by the return value from classify.
 */
#define rdops(x) rdxxxx[(x)-(TFIRST)]

int rdxxxx[] = {
	0,		/* -7 file types */
	0,		/* -6 record types */
	0,		/* -5 array types */
	O_READE,	/* -4 scalar types */
	0,		/* -3 pointer types */
	0,		/* -2 set types */
	0,		/* -1 string types */
	0,		/*  0 nil, no type */
	O_READE,	/*  1 boolean */
	O_READC,	/*  2 character */
	O_READ4,	/*  3 integer */
	O_READ8		/*  4 real */
};

/*
 * Proc handles procedure calls.
 * Non-builtin procedures are "buck-passed" to func (with a flag
 * indicating that they are actually procedures.
 * builtin procedures are handled here.
 */
pcproc(r)
	struct tnode *r;	/* T_PCALL */
{
	register struct nl *p;
	register struct tnode *alv, *al;
	register op;
	struct nl *filetype, *ap;
	int argc, typ, fmtspec, strfmt;
	struct tnode *argv, *file;
	char fmt, format[20], *strptr, *cmd;
	int prec, field, strnglen, fmtstart;
	char *pu;
	struct tnode *pua, *pui, *puz;
	int i, j, k;
	int itemwidth;
	char		*readname;
	struct nl	*tempnlp;
	long		readtype;
	struct tmps	soffset;
	bool		soffset_flag;

#define	CONPREC 4
#define	VARPREC 8
#define	CONWIDTH 1
#define	VARWIDTH 2
#define SKIP 16

	/*
	 * Verify that the name is
	 * defined and is that of a
	 * procedure.
	 */
	p = lookup(r->pcall_node.proc_id);
	if (p == NLNIL) {
		rvlist(r->pcall_node.arg);
		return;
	}
	if (p->class != PROC && p->class != FPROC) {
		error("Can't call %s, its %s not a procedure", p->symbol, classes[p->class]);
		rvlist(r->pcall_node.arg);
		return;
	}
	argv = r->pcall_node.arg;

	/*
	 * Call handles user defined
	 * procedures and functions.
	 */
	if (bn != 0) {
		(void) call(p, argv, PROC, bn);
		return;
	}

	/*
	 * Call to built-in procedure.
	 * Count the arguments.
	 */
	argc = 0;
	for (al = argv; al != TR_NIL; al = al->list_node.next)
		argc++;

	/*
	 * Switch on the operator
	 * associated with the built-in
	 * procedure in the namelist
	 */
	op = p->value[0] &~ NSTAND;
	if (opt('s') && (p->value[0] & NSTAND)) {
		standard();
		error("%s is a nonstandard procedure", p->symbol);
	}
	switch (op) {

	case O_ABORT:
		if (argc != 0)
			error("null takes no arguments");
		return;

	case O_FLUSH:
		if (argc == 0) {
			putleaf( PCC_ICON , 0 , 0 , PCCT_INT , "_PFLUSH" );
			putop( PCCOM_UNARY PCC_CALL , PCCT_INT );
			putdot( filename , line );
			return;
		}
		if (argc != 1) {
			error("flush takes at most one argument");
			return;
		}
		putleaf( PCC_ICON , 0 , 0
			, PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
			, "_FLUSH" );
		ap = stklval(argv->list_node.list, NOFLAGS);
		if (ap == NLNIL)
			return;
		if (ap->class != FILET) {
			error("flush's argument must be a file, not %s", nameof(ap));
			return;
		}
		putop( PCC_CALL , PCCT_INT );
		putdot( filename , line );
		return;

	case O_MESSAGE:
	case O_WRITEF:
	case O_WRITLN:
		/*
		 * Set up default file "output"'s type
		 */
		file = NIL;
		filetype = nl+T1CHAR;
		/*
		 * Determine the file implied
		 * for the write and generate
		 * code to make it the active file.
		 */
		if (op == O_MESSAGE) {
			/*
			 * For message, all that matters
			 * is that the filetype is
			 * a character file.
			 * Thus "output" will suit us fine.
			 */
			putleaf( PCC_ICON , 0 , 0 , PCCT_INT , "_PFLUSH" );
			putop( PCCOM_UNARY PCC_CALL , PCCT_INT );
			putdot( filename , line );
			putRV( (char *) 0 , cbn , CURFILEOFFSET , NLOCAL ,
				PCCTM_PTR|PCCT_STRTY );
			putLV( "__err" , 0 , 0 , NGLOBAL , PCCTM_PTR|PCCT_STRTY );
			putop( PCC_ASSIGN , PCCTM_PTR|PCCT_STRTY );
			putdot( filename , line );
		} else if (argv != TR_NIL && (al = argv->list_node.list)->tag !=
					T_WEXP) {
			/*
			 * If there is a first argument which has
			 * no write widths, then it is potentially
			 * a file name.
			 */
			codeoff();
			ap = stkrval(argv->list_node.list, NLNIL, (long) RREQ );
			codeon();
			if (ap == NLNIL)
				argv = argv->list_node.next;
			if (ap != NIL && ap->class == FILET) {
				/*
				 * Got "write(f, ...", make
				 * f the active file, and save
				 * it and its type for use in
				 * processing the rest of the
				 * arguments to write.
				 */
				putRV((char *) 0 , cbn , CURFILEOFFSET , NLOCAL ,
					PCCTM_PTR|PCCT_STRTY );
				putleaf( PCC_ICON , 0 , 0
				    , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
				    , "_UNIT" );
				file = argv->list_node.list;
				filetype = ap->type;
				(void) stklval(argv->list_node.list, NOFLAGS);
				putop( PCC_CALL , PCCT_INT );
				putop( PCC_ASSIGN , PCCTM_PTR|PCCT_STRTY );
				putdot( filename , line );
				/*
				 * Skip over the first argument
				 */
				argv = argv->list_node.next;
				argc--;
			} else {
				/*
				 * Set up for writing on 
				 * standard output.
				 */
				putRV((char *) 0, cbn , CURFILEOFFSET ,
					NLOCAL , PCCTM_PTR|PCCT_STRTY );
				putLV( "_output" , 0 , 0 , NGLOBAL ,
					PCCTM_PTR|PCCT_STRTY );
				putop( PCC_ASSIGN , PCCTM_PTR|PCCT_STRTY );
				putdot( filename , line );
				output->nl_flags |= NUSED;
			}
		} else {
			putRV((char *) 0, cbn , CURFILEOFFSET , NLOCAL ,
				PCCTM_PTR|PCCT_STRTY );
			putLV( "_output" , 0 , 0 , NGLOBAL , PCCTM_PTR|PCCT_STRTY );
			putop( PCC_ASSIGN , PCCTM_PTR|PCCT_STRTY );
			putdot( filename , line );
			output->nl_flags |= NUSED;
		}
		/*
		 * Loop and process each
		 * of the arguments.
		 */
		for (; argv != TR_NIL; argv = argv->list_node.next) {
		        soffset_flag = FALSE;
			/*
			 * fmtspec indicates the type (CONstant or VARiable)
			 *	and number (none, WIDTH, and/or PRECision)
			 *	of the fields in the printf format for this
			 *	output variable.
			 * fmt is the format output indicator (D, E, F, O, X, S)
			 * fmtstart = 0 for leading blank; = 1 for no blank
			 */
			fmtspec = NIL;
			fmt = 'D';
			fmtstart = 1;
			al = argv->list_node.list;
			if (al == NIL)
				continue;
			if (al->tag == T_WEXP)
				alv = al->wexpr_node.expr1;
			else
				alv = al;
			if (alv == TR_NIL)
				continue;
			codeoff();
			ap = stkrval(alv, NLNIL , (long) RREQ );
			codeon();
			if (ap == NLNIL)
				continue;
			typ = classify(ap);
			if (al->tag == T_WEXP) {
				/*
				 * Handle width expressions.
				 * The basic game here is that width
				 * expressions get evaluated. If they
				 * are constant, the value is placed
				 * directly in the format string.
				 * Otherwise the value is pushed onto
				 * the stack and an indirection is
				 * put into the format string.
				 */
				if (al->wexpr_node.expr3 == 
						(struct tnode *) OCT)
					fmt = 'O';
				else if (al->wexpr_node.expr3 == 
						(struct tnode *) HEX)
					fmt = 'X';
				else if (al->wexpr_node.expr3 != TR_NIL) {
					/*
					 * Evaluate second format spec
					 */
					if ( constval(al->wexpr_node.expr3)
					    && isa( con.ctype , "i" ) ) {
						fmtspec += CONPREC;
						prec = con.crval;
					} else {
						fmtspec += VARPREC;
					}
					fmt = 'f';
					switch ( typ ) {
					case TINT:
						if ( opt( 's' ) ) {
						    standard();
						    error("Writing %ss with two write widths is non-standard", clnames[typ]);
						}
						/* and fall through */
					case TDOUBLE:
						break;
					default:
						error("Cannot write %ss with two write widths", clnames[typ]);
						continue;
					}
				}
				/*
				 * Evaluate first format spec
				 */
				if (al->wexpr_node.expr2 != TR_NIL) {
					if ( constval(al->wexpr_node.expr2)
					    && isa( con.ctype , "i" ) ) {
						fmtspec += CONWIDTH;
						field = con.crval;
					} else {
						fmtspec += VARWIDTH;
					}
				}
				if ((fmtspec & CONPREC) && prec < 0 ||
				    (fmtspec & CONWIDTH) && field < 0) {
					error("Negative widths are not allowed");
					continue;
				}
				if ( opt('s') &&
				    ((fmtspec & CONPREC) && prec == 0 ||
				    (fmtspec & CONWIDTH) && field == 0)) {
					standard();
					error("Zero widths are non-standard");
				}
			}
			if (filetype != nl+T1CHAR) {
				if (fmt == 'O' || fmt == 'X') {
					error("Oct/hex allowed only on text files");
					continue;
				}
				if (fmtspec) {
					error("Write widths allowed only on text files");
					continue;
				}
				/*
				 * Generalized write, i.e.
				 * to a non-textfile.
				 */
				putleaf( PCC_ICON , 0 , 0
				    , (int) (PCCM_ADDTYPE(
					PCCM_ADDTYPE(
					    PCCM_ADDTYPE( p2type( filetype )
						    , PCCTM_PTR )
					    , PCCTM_FTN )
					, PCCTM_PTR ))
				    , "_FNIL" );
				(void) stklval(file, NOFLAGS);
				putop( PCC_CALL
				    , PCCM_ADDTYPE( p2type( filetype ) , PCCTM_PTR ) );
				putop( PCCOM_UNARY PCC_MUL , p2type( filetype ) );
				/*
				 * file^ := ...
				 */
				switch ( classify( filetype ) ) {
				    case TBOOL:
				    case TCHAR:
				    case TINT:
				    case TSCAL:
					precheck( filetype , "_RANG4"  , "_RSNG4" );
					    /* and fall through */
				    case TDOUBLE:
				    case TPTR:
					ap = rvalue( argv->list_node.list , filetype , RREQ );
					break;
				    default:
					ap = rvalue( argv->list_node.list , filetype , LREQ );
					break;
				}
				if (ap == NIL)
					continue;
				if (incompat(ap, filetype, argv->list_node.list)) {
					cerror("Type mismatch in write to non-text file");
					continue;
				}
				switch ( classify( filetype ) ) {
				    case TBOOL:
				    case TCHAR:
				    case TINT:
				    case TSCAL:
					    postcheck(filetype, ap);
					    sconv(p2type(ap), p2type(filetype));
						/* and fall through */
				    case TDOUBLE:
				    case TPTR:
					    putop( PCC_ASSIGN , p2type( filetype ) );
					    putdot( filename , line );
					    break;
				    default:
					    putstrop(PCC_STASG,
						    PCCM_ADDTYPE(p2type(filetype),
							    PCCTM_PTR),
						    (int) lwidth(filetype),
						    align(filetype));
					    putdot( filename , line );
					    break;
				}
				/*
				 * put(file)
				 */
				putleaf( PCC_ICON , 0 , 0
				    , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
				    , "_PUT" );
				putRV((char *) 0 , cbn , CURFILEOFFSET , NLOCAL ,
					PCCTM_PTR|PCCT_STRTY );
				putop( PCC_CALL , PCCT_INT );
				putdot( filename , line );
				continue;
			}
			/*
			 * Write to a textfile
			 *
			 * Evaluate the expression
			 * to be written.
			 */
			if (fmt == 'O' || fmt == 'X') {
				if (opt('s')) {
					standard();
					error("Oct and hex are non-standard");
				}
				if (typ == TSTR || typ == TDOUBLE) {
					error("Can't write %ss with oct/hex", clnames[typ]);
					continue;
				}
				if (typ == TCHAR || typ == TBOOL)
					typ = TINT;
			}
			/*
			 * If there is no format specified by the programmer,
			 * implement the default.
			 */
			switch (typ) {
			case TPTR:
				warning();
				if (opt('s')) {
					standard();
				}
				error("Writing %ss to text files is non-standard",
				    clnames[typ]);
				/* and fall through */
			case TINT:
				if (fmt == 'f') {
					typ = TDOUBLE;
					goto tdouble;
				}
				if (fmtspec == NIL) {
					if (fmt == 'D')
						field = 10;
					else if (fmt == 'X')
						field = 8;
					else if (fmt == 'O')
						field = 11;
					else
						panic("fmt1");
					fmtspec = CONWIDTH;
				}
				break;
			case TCHAR:
			     tchar:
				fmt = 'c';
				break;
			case TSCAL:
				warning();
				if (opt('s')) {
					standard();
				}
				error("Writing %ss to text files is non-standard",
				    clnames[typ]);
			case TBOOL:
				fmt = 's';
				break;
			case TDOUBLE:
			     tdouble:
				switch (fmtspec) {
				case NIL:
					field = 14 + (5 + EXPOSIZE);
				        prec = field - (5 + EXPOSIZE);
					fmt = 'e';
					fmtspec = CONWIDTH + CONPREC;
					break;
				case CONWIDTH:
					field -= REALSPC;
					if (field < 1)
						field = 1;
				        prec = field - (5 + EXPOSIZE);
					if (prec < 1)
						prec = 1;