proc.c

早期freebsd实现

				}
				convert(nl+T4INT, INT_TYP);
				stkcnt += sizeof(int);
			}
			/*
			 * Generate the format string
			 */
			switch (fmtspec) {
			default:
				panic("fmt2");
			case SKIP:
				break;
			case NIL:
				sprintf(&format[1], "%%%c", fmt);
				goto fmtgen;
			case CONWIDTH:
				sprintf(&format[1], "%%%d%c", field, fmt);
				goto fmtgen;
			case VARWIDTH:
				sprintf(&format[1], "%%*%c", fmt);
				goto fmtgen;
			case CONWIDTH + CONPREC:
				sprintf(&format[1], "%%%d.%d%c", field, prec, fmt);
				goto fmtgen;
			case CONWIDTH + VARPREC:
				sprintf(&format[1], "%%%d.*%c", field, fmt);
				goto fmtgen;
			case VARWIDTH + CONPREC:
				sprintf(&format[1], "%%*.%d%c", prec, fmt);
				goto fmtgen;
			case VARWIDTH + VARPREC:
				sprintf(&format[1], "%%*.*%c", fmt);
			fmtgen:
				fmtlen = lenstr(&format[fmtstart], 0);
				(void) put(2, O_LVCON, fmtlen);
				putstr(&format[fmtstart], 0);
				(void) put(1, O_FILE);
				stkcnt += 2 * sizeof(char *);
				(void) put(2, O_WRITEF, stkcnt);
			}
			/*
			 * Write the string after its blank padding
			 */
			if (typ == TSTR) {
				(void) put(1, O_FILE);
				(void) put(2, CON_INT, 1);
				if (strfmt & VARWIDTH) {
					(void) put(2, O_RV4 | cbn << 8 + INDX , 
					    tempnlp -> value[ NL_OFFS ] );
					(void) put(2, O_MIN, strnglen);
					convert(nl+T4INT, INT_TYP);
					tmpfree(&soffset);
				} else {
					if ((fmtspec & SKIP) &&
					   (strfmt & CONWIDTH)) {
						strnglen = field;
					}
					(void) put(2, CON_INT, strnglen);
				}
				ap = stkrval(alv, NLNIL , (long) RREQ );
				(void) put(2, O_WRITES,
					2 * sizeof(char *) + 2 * sizeof(int));
			}
		}
		/*
		 * Done with arguments.
		 * Handle writeln and
		 * insufficent number of args.
		 */
		switch (p->value[0] &~ NSTAND) {
			case O_WRITEF:
				if (argc == 0)
					error("Write requires an argument");
				break;
			case O_MESSAGE:
				if (argc == 0)
					error("Message requires an argument");
			case O_WRITLN:
				if (filetype != nl+T1CHAR)
					error("Can't 'writeln' a non text file");
				(void) put(1, O_WRITLN);
				break;
		}
		return;

	case O_READ4:
	case O_READLN:
		/*
		 * Set up default
		 * file "input".
		 */
		file = NIL;
		filetype = nl+T1CHAR;
		/*
		 * Determine the file implied
		 * for the read and generate
		 * code to make it the active file.
		 */
		if (argv != TR_NIL) {
			codeoff();
			ap = stkrval(argv->list_node.list, NLNIL, (long) RREQ );
			codeon();
			if (ap == NLNIL)
				argv = argv->list_node.next;
			if (ap != NLNIL && ap->class == FILET) {
				/*
				 * Got "read(f, ...", make
				 * f the active file, and save
				 * it and its type for use in
				 * processing the rest of the
				 * arguments to read.
				 */
				file = argv->list_node.list;
				filetype = ap->type;
				(void) stklval(argv->list_node.list, NIL );
				(void) put(1, O_UNIT);
				argv = argv->list_node.next;
				argc--;
			} else {
				/*
				 * Default is read from
				 * standard input.
				 */
				(void) put(1, O_UNITINP);
				input->nl_flags |= NUSED;
			}
		} else {
			(void) put(1, O_UNITINP);
			input->nl_flags |= NUSED;
		}
		/*
		 * Loop and process each
		 * of the arguments.
		 */
		for (; argv != TR_NIL; argv = argv->list_node.next) {
			/*
			 * Get the address of the target
			 * on the stack.
			 */
			al = argv->list_node.list;
			if (al == TR_NIL)
				continue;
			if (al->tag != T_VAR) {
				error("Arguments to %s must be variables, not expressions", p->symbol);
				continue;
			}
			ap = stklval(al, MOD|ASGN|NOUSE);
			if (ap == NLNIL)
				continue;
			if (filetype != nl+T1CHAR) {
				/*
				 * Generalized read, i.e.
				 * from a non-textfile.
				 */
				if (incompat(filetype, ap,
					argv->list_node.list )) {
					error("Type mismatch in read from non-text file");
					continue;
				}
				/*
				 * var := file ^;
				 */
				if (file != NIL)
				    (void) stklval(file, NIL);
				else /* Magic */
				    (void) put(2, PTR_RV, (int)input->value[0]);
				(void) put(1, O_FNIL);
				if (isa(filetype, "bcsi")) {
				    int filewidth = width(filetype);

				    switch (filewidth) {
					case 4:
					    (void) put(1, O_IND4);
					    break;
					case 2:
					    (void) put(1, O_IND2);
					    break;
					case 1:
					    (void) put(1, O_IND1);
					    break;
					default:
					    (void) put(2, O_IND, filewidth);
				    }
				    convert(filetype, ap);
				    rangechk(ap, ap);
				    (void) gen(O_AS2, O_AS2,
					    filewidth, width(ap));
				} else {
				    (void) put(2, O_IND, width(filetype));
				    convert(filetype, ap);
				    (void) put(2, O_AS, width(ap));
				}
				/*
				 * get(file);
				 */
				(void) put(1, O_GET);
				continue;
			}
			typ = classify(ap);
			op = rdops(typ);
			if (op == NIL) {
				error("Can't read %ss from a text file", clnames[typ]);
				continue;
			}
			if (op != O_READE)
				(void) put(1, op);
			else {
				(void) put(2, op, (long)listnames(ap));
				warning();
				if (opt('s')) {
					standard();
				}
				error("Reading scalars from text files is non-standard");
			}
			/*
			 * Data read is on the stack.
			 * Assign it.
			 */
			if (op != O_READ8 && op != O_READE)
				rangechk(ap, op == O_READC ? ap : nl+T4INT);
			(void) gen(O_AS2, O_AS2, width(ap),
				op == O_READ8 ? 8 : op == O_READ4 ? 4 : 2);
		}
		/*
		 * 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");
			(void) put(1, O_READLN);
		}
		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;
		}
		ap = stklval(argv->list_node.list, NIL );
		if (ap == NLNIL)
			return;
		if (ap->class != FILET) {
			error("Argument to %s must be a file, not %s", p->symbol, nameof(ap));
			return;
		}
		(void) put(1, O_UNIT);
		(void) put(1, op);
		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");
		}
		codeoff();
		ap = stklval(argv->list_node.list, MOD|NOUSE);
		codeon();
		if (ap == NLNIL)
			return;
		if (ap->class != FILET) {
			error("First argument to %s must be a file, not %s", p->symbol, nameof(ap));
			return;
		}
		(void) put(2, O_CON24, text(ap) ? 0: width(ap->type));
		if (argc == 2) {
			/*
			 * Optional second argument
			 * is a string name of a
			 * UNIX (R) file to be associated.
			 */
			al = argv->list_node.next;
			codeoff();
			al = (struct tnode *) stkrval(al->list_node.list,
					(struct nl *) NOFLAGS , (long) RREQ );
			codeon();
			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;
			}
			(void) put(2, O_CON24, width((struct nl *) al));
			al = argv->list_node.next;
			al = (struct tnode *) stkrval(al->list_node.list,
					(struct nl *) NOFLAGS , (long) RREQ );
		} else {
			(void) put(2, O_CON24, 0);
			(void) put(2, PTR_CON, NIL);
		}
		ap = stklval(argv->list_node.list, MOD|NOUSE);
		(void) put(1, op);
		return;

	case O_NEW:
	case O_DISPOSE:
		if (argc == 0) {
			error("%s expects at least one argument", p->symbol);
			return;
		}
		ap = stklval(argv->list_node.list,
				op == O_NEW ? ( MOD | NOUSE ) : MOD );
		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 == NIL)
			return;
		if ((ap->nl_flags & NFILES) && op == O_DISPOSE)
			op = O_DFDISP;
		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];
			}
		}
		(void) put(2, op, width(ap));
		return;

	case O_DATE:
	case O_TIME:
		if (argc != 1) {
			error("%s expects one argument", p->symbol);
			return;
		}
		ap = stklval(argv->list_node.list, MOD|NOUSE);
		if (ap == NLNIL)
			return;
		if (classify(ap) != TSTR || width(ap) != 10) {
			error("Argument to %s must be a alfa, not %s", p->symbol, nameof(ap));
			return;
		}
		(void) put(1, op);
		return;

	case O_HALT:
		if (argc != 0) {
			error("halt takes no arguments");
			return;
		}
		(void) put(1, op);
		noreach = TRUE; /* used to be 1 */
		return;

	case O_ARGV:
		if (argc != 2) {
			error("argv takes two arguments");
			return;
		}
		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;
		}
		(void) put(2, op, width(ap));
		return;

	case O_STLIM:
		if (argc != 1) {
			error("stlimit requires one argument");
			return;
		}
		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;
		}
		if (width(ap) != 4)
			(void) put(1, O_STOI);
		(void) put(1, op);
		return;

	case O_REMOVE:
		if (argc != 1) {
			error("remove expects one argument");
			return;
		}
		codeoff();
		ap = stkrval(argv->list_node.list, (struct nl *) NOFLAGS,
				(long) RREQ );
		codeon();
		if (ap == NLNIL)
			return;
		if (classify(ap) != TSTR) {
			error("remove's argument must be a string, not %s", nameof(ap));
			return;
		}
		(void) put(2, O_CON24, width(ap));
		ap = stkrval(argv->list_node.list, (struct nl *) NOFLAGS,
				(long) RREQ );
		(void) put(1, op);
		return;

	case O_LLIMIT:
		if (argc != 2) {
			error("linelimit expects two arguments");
			return;
		}
		al = argv->list_node.next;
		ap = stkrval(al->list_node.list, NLNIL , (long) RREQ );
		if (ap == NIL)
			return;
		if (isnta(ap, "i")) {
			error("linelimit's second argument must be an integer, not %s", nameof(ap));
			return;
		}
		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;
		}
		(void) put(1, op);
		return;
	case O_PAGE:
		if (argc != 1) {
			error("page expects one argument");
			return;
		}
		ap = stklval(argv->list_node.list, NIL );
		if (ap == NLNIL)
			return;
		if (!text(ap)) {
			error("Argument to page must be a text file, not %s", nameof(ap));
			return;
		}
		(void) put(1, O_UNIT);
		(void) put(1, op);
		return;

	case O_ASRT:
		if (!opt('t'))
			return;
		if (argc == 0 || argc > 2) {
			error("Assert expects one or two arguments");
			return;
		}
		if (argc == 2) {
			/*
			 * Optional second argument is a string specifying
			 * why the assertion failed.
			 */
			al = argv->list_node.next;
			al1 =  stkrval(al->list_node.list, NLNIL , (long) RREQ );
			if (al1 == NIL)
				return;
			if (classify(al1) != TSTR) {
				error("Second argument to assert must be a string, not %s", nameof(al1));
				return;
			}
		} else {
			(void) put(2, PTR_CON, NIL);
		}
		ap = stkrval(argv->list_node.list, NLNIL , (long) RREQ );
		if (ap == NIL)
			return;
		if (isnta(ap, "b"))
			error("Assert expression must be Boolean, not %ss", nameof(ap));
		(void) put(1, O_ASRT);
		return;

	case O_PACK:
		if (argc != 3) {
			error("pack expects three arguments");
			return;
		}
		pu = "pack(a,i,z)";
		pua = argv->list_node.list;
		al = argv->list_node.next;
		pui = al->list_node.list;
		alv = al->list_node.next;
		puz = alv->list_node.list;
		goto packunp;
	case O_UNPACK:
		if (argc != 3) {
			error("unpack expects three arguments");
			return;
		}
		pu = "unpack(z,a,i)";
		puz = argv->list_node.list;
		al = argv->list_node.next;
		pua = al->list_node.list;
		alv = al->list_node.next;
		pui = alv->list_node.list;
packunp:
		codeoff();
		ap = stklval(pua, op == O_PACK ? NOFLAGS : MOD|NOUSE);
		al1 = stklval(puz, op == O_UNPACK ? NOFLAGS : MOD|NOUSE);
		codeon();
		if (ap == NIL)
			return;
		if (ap->class != ARRAY) {
			error("%s requires a to be an unpacked array, not %s", pu, nameof(ap));
			return;
		}
		if (al1->class != ARRAY) {
			error("%s requires z to be a packed array, not %s", pu, nameof(ap));
			return;
		}
		if (al1->type == NIL || ap->type == NIL)
			return;
		if (al1->type != ap->type) {
			error("%s requires a and z to be arrays of the same type", pu, nameof(ap));
			return;
		}
		k = width(al1);
		itemwidth = width(ap->type);
		ap = ap->chain;
		al1 = al1->chain;
		if (ap->chain != NIL || al1->chain != NIL) {
			error("%s requires a and z to be single dimension arrays", pu);
			return;
		}
		if (ap == NIL || al1 == NIL)
			return;
		/*
		 * al1 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 = al1->range[1] - al1->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];
		(void) put(2, O_CON24, k);
		(void) put(2, O_CON24, i);
		(void) put(2, O_CON24, j);
		(void) put(2, O_CON24, itemwidth);
		al1 = stklval(puz, op == O_UNPACK ? NOFLAGS : MOD|NOUSE);
		ap = stklval(pua, op == O_PACK ? NOFLAGS : MOD|NOUSE);
		ap = stkrval(pui, NLNIL , (long) RREQ );
		if (ap == NIL)
			return;
		(void) put(1, op);
		return;
	case 0:
		error("%s is an unimplemented extension", p->symbol);
		return;

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