pcproc.c

早期freebsd实现

				 */
				putleaf( PCC_ICON , 0 , 0 
					, PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
					, "_GET" );
				putRV((char *) 0 , cbn , CURFILEOFFSET , NLOCAL ,
					PCCTM_PTR|PCCT_STRTY );
				putop( PCC_CALL , PCCT_INT );
				putdot( filename , line );
				continue;
			}
			    /*
			     *	if you get to here, you are reading from
			     *	a text file.  only possiblities are:
			     *	character, integer, real, or scalar.
			     *	read( f , foo , ... ) is done as
			     *	foo := read( f ) with rangechecking
			     *	if appropriate.
			     */
			typ = classify(ap);
			op = rdops(typ);
			if (op == NIL) {
				error("Can't read %ss from a text file", clnames[typ]);
				continue;
			}
			    /*
			     *	left hand side of foo := read( f )
			     */
			ap = lvalue( al , MOD|ASGN|NOUSE , RREQ );
			if ( isa( ap , "bsci" ) ) {
			    precheck( ap , "_RANG4" , "_RSNG4" );
			}
			switch ( op ) {
			    case O_READC:
				readname = "_READC";
				readtype = PCCT_INT;
				break;
			    case O_READ4:
				readname = "_READ4";
				readtype = PCCT_INT;
				break;
			    case O_READ8:
				readname = "_READ8";
				readtype = PCCT_DOUBLE;
				break;
			    case O_READE:
				readname = "_READE";
				readtype = PCCT_INT;
				break;
			}
			putleaf( PCC_ICON , 0 , 0
				, (int) PCCM_ADDTYPE( PCCTM_FTN | readtype , PCCTM_PTR )
				, readname );
			putRV((char *) 0 , cbn , CURFILEOFFSET , NLOCAL ,
				PCCTM_PTR|PCCT_STRTY );
			if ( op == O_READE ) {
				sprintf( format , PREFIXFORMAT , LABELPREFIX
					, listnames( ap ) );
				putleaf( PCC_ICON , 0, 0, (int) (PCCTM_PTR | PCCT_CHAR),
					format );
				putop( PCC_CM , PCCT_INT );
				warning();
				if (opt('s')) {
					standard();
				}
				error("Reading scalars from text files is non-standard");
			}
			putop( PCC_CALL , (int) readtype );
			if ( isa( ap , "bcsi" ) ) {
			    postcheck(ap, readtype==PCCT_INT?nl+T4INT:nl+TDOUBLE);
			}
			sconv((int) readtype, p2type(ap));
			putop( PCC_ASSIGN , p2type( ap ) );
			putdot( filename , line );
		}
		/*
		 * Done with arguments.
		 * Handle readln and
		 * insufficient number of args.
		 */
		if (p->value[0] == O_READLN) {
			if (filetype != nl+T1CHAR)
				error("Can't 'readln' a non text file");
			putleaf( PCC_ICON , 0 , 0 
				, (int) PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
				, "_READLN" );
			putRV((char *) 0 , cbn , CURFILEOFFSET , NLOCAL ,
				PCCTM_PTR|PCCT_STRTY );
			putop( PCC_CALL , PCCT_INT );
			putdot( filename , line );
		} else if (argc == 0)
			error("read requires an argument");
		return;

	case O_GET:
	case O_PUT:
		if (argc != 1) {
			error("%s expects one argument", p->symbol);
			return;
		}
		putRV((char *) 0 , cbn , CURFILEOFFSET , NLOCAL , PCCTM_PTR|PCCT_STRTY );
		putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
			, "_UNIT" );
		ap = stklval(argv->list_node.list, NOFLAGS);
		if (ap == NLNIL)
			return;
		if (ap->class != FILET) {
			error("Argument to %s must be a file, not %s", p->symbol, nameof(ap));
			return;
		}
		putop( PCC_CALL , PCCT_INT );
		putop( PCC_ASSIGN , PCCTM_PTR|PCCT_STRTY );
		putdot( filename , line );
		putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
			, op == O_GET ? "_GET" : "_PUT" );
		putRV((char *) 0 , cbn , CURFILEOFFSET , NLOCAL , PCCTM_PTR|PCCT_STRTY );
		putop( PCC_CALL , PCCT_INT );
		putdot( filename , line );
		return;

	case O_RESET:
	case O_REWRITE:
		if (argc == 0 || argc > 2) {
			error("%s expects one or two arguments", p->symbol);
			return;
		}
		if (opt('s') && argc == 2) {
			standard();
			error("Two argument forms of reset and rewrite are non-standard");
		}
		putleaf( PCC_ICON , 0 , 0 , PCCT_INT
			, op == O_RESET ? "_RESET" : "_REWRITE" );
		ap = stklval(argv->list_node.list, MOD|NOUSE);
		if (ap == NLNIL)
			return;
		if (ap->class != FILET) {
			error("First argument to %s must be a file, not %s", p->symbol, nameof(ap));
			return;
		}
		if (argc == 2) {
			/*
			 * Optional second argument
			 * is a string name of a
			 * UNIX (R) file to be associated.
			 */
			al = argv->list_node.next;
			al = (struct tnode *) stkrval(al->list_node.list,
					NLNIL , (long) RREQ );
			if (al == TR_NIL)
				return;
			if (classify((struct nl *) al) != TSTR) {
				error("Second argument to %s must be a string, not %s", p->symbol, nameof((struct nl *) al));
				return;
			}
			strnglen = width((struct nl *) al);
		} else {
			putleaf( PCC_ICON , 0 , 0 , PCCT_INT , (char *) 0 );
			strnglen = 0;
		}
		putop( PCC_CM , PCCT_INT );
		putleaf( PCC_ICON , strnglen , 0 , PCCT_INT , (char *) 0 );
		putop( PCC_CM , PCCT_INT );
		putleaf( PCC_ICON , text(ap) ? 0: width(ap->type) , 0 , PCCT_INT , (char *) 0 );
		putop( PCC_CM , PCCT_INT );
		putop( PCC_CALL , PCCT_INT );
		putdot( filename , line );
		return;

	case O_NEW:
	case O_DISPOSE:
		if (argc == 0) {
			error("%s expects at least one argument", p->symbol);
			return;
		}
		alv = argv->list_node.list;
		codeoff();
		ap = stklval(alv, op == O_NEW ? ( MOD | NOUSE ) : MOD );
		codeon();
		if (ap == NLNIL)
			return;
		if (ap->class != PTR) {
			error("(First) argument to %s must be a pointer, not %s", p->symbol, nameof(ap));
			return;
		}
		ap = ap->type;
		if (ap == NLNIL)
			return;
		if (op == O_NEW)
			cmd = "_NEW";
		else /* op == O_DISPOSE */
			if ((ap->nl_flags & NFILES) != 0)
				cmd = "_DFDISPOSE";
			else
				cmd = "_DISPOSE";
		putleaf( PCC_ICON, 0, 0, PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ), cmd);
		(void) stklval(alv, op == O_NEW ? ( MOD | NOUSE ) : MOD );
		argv = argv->list_node.next;
		if (argv != TR_NIL) {
			if (ap->class != RECORD) {
				error("Record required when specifying variant tags");
				return;
			}
			for (; argv != TR_NIL; argv = argv->list_node.next) {
				if (ap->ptr[NL_VARNT] == NIL) {
					error("Too many tag fields");
					return;
				}
				if (!isconst(argv->list_node.list)) {
					error("Second and successive arguments to %s must be constants", p->symbol);
					return;
				}
				gconst(argv->list_node.list);
				if (con.ctype == NIL)
					return;
				if (incompat(con.ctype, (ap->ptr[NL_TAG])->type , TR_NIL )) {
					cerror("Specified tag constant type clashed with variant case selector type");
					return;
				}
				for (ap = ap->ptr[NL_VARNT]; ap != NIL; ap = ap->chain)
					if (ap->range[0] == con.crval)
						break;
				if (ap == NIL) {
					error("No variant case label value equals specified constant value");
					return;
				}
				ap = ap->ptr[NL_VTOREC];
			}
		}
		putleaf( PCC_ICON , width( ap ) , 0 , PCCT_INT , (char *) 0 );
		putop( PCC_CM , PCCT_INT );
		putop( PCC_CALL , PCCT_INT );
		putdot( filename , line );
		if (opt('t') && op == O_NEW) {
		    putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
			    , "_blkclr" );
		    (void) stkrval(alv, NLNIL , (long) RREQ );
		    putleaf( PCC_ICON , width( ap ) , 0 , PCCT_INT , (char *) 0 );
		    putop( PCC_CM , PCCT_INT );
		    putop( PCC_CALL , PCCT_INT );
		    putdot( filename , line );
		}
		return;

	case O_DATE:
	case O_TIME:
		if (argc != 1) {
			error("%s expects one argument", p->symbol);
			return;
		}
		putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
			, op == O_DATE ? "_DATE" : "_TIME" );
		ap = stklval(argv->list_node.list, MOD|NOUSE);
		if (ap == NIL)
			return;
		if (classify(ap) != TSTR || width(ap) != 10) {
			error("Argument to %s must be a alfa, not %s", p->symbol, nameof(ap));
			return;
		}
		putop( PCC_CALL , PCCT_INT );
		putdot( filename , line );
		return;

	case O_HALT:
		if (argc != 0) {
			error("halt takes no arguments");
			return;
		}
		putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
			, "_HALT" );

		putop( PCCOM_UNARY PCC_CALL , PCCT_INT );
		putdot( filename , line );
		noreach = TRUE;
		return;

	case O_ARGV:
		if (argc != 2) {
			error("argv takes two arguments");
			return;
		}
		putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
			, "_ARGV" );
		ap = stkrval(argv->list_node.list, NLNIL , (long) RREQ );
		if (ap == NLNIL)
			return;
		if (isnta(ap, "i")) {
			error("argv's first argument must be an integer, not %s", nameof(ap));
			return;
		}
		al = argv->list_node.next;
		ap = stklval(al->list_node.list, MOD|NOUSE);
		if (ap == NLNIL)
			return;
		if (classify(ap) != TSTR) {
			error("argv's second argument must be a string, not %s", nameof(ap));
			return;
		}
		putop( PCC_CM , PCCT_INT );
		putleaf( PCC_ICON , width( ap ) , 0 , PCCT_INT , (char *) 0 );
		putop( PCC_CM , PCCT_INT );
		putop( PCC_CALL , PCCT_INT );
		putdot( filename , line );
		return;

	case O_STLIM:
		if (argc != 1) {
			error("stlimit requires one argument");
			return;
		}
		putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
			, "_STLIM" );
		ap = stkrval(argv->list_node.list, NLNIL , (long) RREQ );
		if (ap == NLNIL)
			return;
		if (isnta(ap, "i")) {
			error("stlimit's argument must be an integer, not %s", nameof(ap));
			return;
		}
		putop( PCC_CALL , PCCT_INT );
		putdot( filename , line );
		return;

	case O_REMOVE:
		if (argc != 1) {
			error("remove expects one argument");
			return;
		}
		putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
			, "_REMOVE" );
		ap = stkrval(argv->list_node.list, NLNIL, (long) RREQ );
		if (ap == NLNIL)
			return;
		if (classify(ap) != TSTR) {
			error("remove's argument must be a string, not %s", nameof(ap));
			return;
		}
		putleaf( PCC_ICON , width( ap ) , 0 , PCCT_INT , (char *) 0 );
		putop( PCC_CM , PCCT_INT );
		putop( PCC_CALL , PCCT_INT );
		putdot( filename , line );
		return;

	case O_LLIMIT:
		if (argc != 2) {
			error("linelimit expects two arguments");
			return;
		}
		putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
			, "_LLIMIT" );
		ap = stklval(argv->list_node.list, NOFLAGS|NOUSE);
		if (ap == NLNIL)
			return;
		if (!text(ap)) {
			error("linelimit's first argument must be a text file, not %s", nameof(ap));
			return;
		}
		al = argv->list_node.next;
		ap = stkrval(al->list_node.list, NLNIL , (long) RREQ );
		if (ap == NLNIL)
			return;
		if (isnta(ap, "i")) {
			error("linelimit's second argument must be an integer, not %s", nameof(ap));
			return;
		}
		putop( PCC_CM , PCCT_INT );
		putop( PCC_CALL , PCCT_INT );
		putdot( filename , line );
		return;
	case O_PAGE:
		if (argc != 1) {
			error("page expects one argument");
			return;
		}
		putRV((char *) 0 , cbn , CURFILEOFFSET , NLOCAL , PCCTM_PTR|PCCT_STRTY );
		putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
			, "_UNIT" );
		ap = stklval(argv->list_node.list, NOFLAGS);
		if (ap == NLNIL)
			return;
		if (!text(ap)) {
			error("Argument to page must be a text file, not %s", nameof(ap));
			return;
		}
		putop( PCC_CALL , PCCT_INT );
		putop( PCC_ASSIGN , PCCTM_PTR|PCCT_STRTY );
		putdot( filename , line );
		if ( opt( 't' ) ) {
		    putleaf( PCC_ICON , 0 , 0
			, PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
			, "_PAGE" );
		    putRV((char *) 0 , cbn , CURFILEOFFSET , NLOCAL , PCCTM_PTR|PCCT_STRTY );
		} else {
		    putleaf( PCC_ICON , 0 , 0
			, PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
			, "_fputc" );
		    putleaf( PCC_ICON , '\f' , 0 , (int) PCCT_CHAR , (char *) 0 );
		    putleaf( PCC_ICON , 0 , 0
			, PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
			, "_ACTFILE" );
		    putRV((char *) 0 , cbn , CURFILEOFFSET , NLOCAL , PCCTM_PTR|PCCT_STRTY );
		    putop( PCC_CALL , PCCT_INT );
		    putop( PCC_CM , PCCT_INT );
		}
		putop( PCC_CALL , PCCT_INT );
		putdot( filename , line );
		return;

	case O_ASRT:
		if (!opt('t'))
			return;
		if (argc == 0 || argc > 2) {
			error("Assert expects one or two arguments");
			return;
		}
		if (argc == 2)
			cmd = "_ASRTS";
		else
			cmd = "_ASRT";
		putleaf( PCC_ICON , 0 , 0
		    , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) , cmd );
		ap = stkrval(argv->list_node.list, NLNIL , (long) RREQ );
		if (ap == NLNIL)
			return;
		if (isnta(ap, "b"))
			error("Assert expression must be Boolean, not %ss", nameof(ap));
		if (argc == 2) {
			/*
			 * Optional second argument is a string specifying
			 * why the assertion failed.
			 */
			al = argv->list_node.next;
			al = (struct tnode *) stkrval(al->list_node.list, NLNIL , (long) RREQ );
			if (al == TR_NIL)
				return;
			if (classify((struct nl *) al) != TSTR) {
				error("Second argument to assert must be a string, not %s", nameof((struct nl *) al));
				return;
			}
			putop( PCC_CM , PCCT_INT );
		}
		putop( PCC_CALL , PCCT_INT );
		putdot( filename , line );
		return;

	case O_PACK:
		if (argc != 3) {
			error("pack expects three arguments");
			return;
		}
		putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
			, "_PACK" );
		pu = "pack(a,i,z)";
		pua = (al = argv)->list_node.list;
		pui = (al = al->list_node.next)->list_node.list;
		puz = (al = al->list_node.next)->list_node.list;
		goto packunp;
	case O_UNPACK:
		if (argc != 3) {
			error("unpack expects three arguments");
			return;
		}
		putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
			, "_UNPACK" );
		pu = "unpack(z,a,i)";
		puz = (al = argv)->list_node.list;
		pua = (al = al->list_node.next)->list_node.list;
		pui = (al = al->list_node.next)->list_node.list;
packunp:
		ap = stkrval(pui, NLNIL , (long) RREQ );
		if (ap == NIL)
			return;
		ap = stklval(pua, op == O_PACK ? NOFLAGS : MOD|NOUSE);
		if (ap == NIL)
			return;
		if (ap->class != ARRAY) {
			error("%s requires a to be an unpacked array, not %s", pu, nameof(ap));
			return;
		}
		putop( PCC_CM , PCCT_INT );
		al = (struct tnode *) stklval(puz, op == O_UNPACK ? NOFLAGS : MOD|NOUSE);
		if (((struct nl *) al)->class != ARRAY) {
			error("%s requires z to be a packed array, not %s", pu, nameof(ap));
			return;
		}
		if (((struct nl *) al)->type == NIL || 
			((struct nl *) ap)->type == NIL)
			return;
		if (((struct nl *) al)->type != ((struct nl *) ap)->type) {
			error("%s requires a and z to be arrays of the same type", pu, nameof(ap));
			return;
		}
		putop( PCC_CM , PCCT_INT );
		k = width((struct nl *) al);
		itemwidth = width(ap->type);
		ap = ap->chain;
		al = ((struct tnode *) ((struct nl *) al)->chain);
		if (ap->chain != NIL || ((struct nl *) al)->chain != NIL) {
			error("%s requires a and z to be single dimension arrays", pu);
			return;
		}
		if (ap == NIL || al == NIL)
			return;
		/*
		 * al is the range for z i.e. u..v
		 * ap is the range for a i.e. m..n
		 * i will be n-m+1
		 * j will be v-u+1
		 */
		i = ap->range[1] - ap->range[0] + 1;
		j = ((struct nl *) al)->range[1] - 
			((struct nl *) al)->range[0] + 1;
		if (i < j) {
			error("%s cannot have more elements in a (%d) than in z (%d)", pu, (char *) j, (char *) i);
			return;
		}
		/*
		 * get n-m-(v-u) and m for the interpreter
		 */
		i -= j;
		j = ap->range[0];
		putleaf( PCC_ICON , itemwidth , 0 , PCCT_INT , (char *) 0 );
		putop( PCC_CM , PCCT_INT );
		putleaf( PCC_ICON , j , 0 , PCCT_INT , (char *) 0 );
		putop( PCC_CM , PCCT_INT );
		putleaf( PCC_ICON , i , 0 , PCCT_INT , (char *) 0 );
		putop( PCC_CM , PCCT_INT );
		putleaf( PCC_ICON , k , 0 , PCCT_INT , (char *) 0 );
		putop( PCC_CM , PCCT_INT );
		putop( PCC_CALL , PCCT_INT );
		putdot( filename , line );
		return;
	case 0:
		error("%s is an unimplemented extension", p->symbol);
		return;

	default:
		panic("proc case");
	}
}
#endif PC