BSD 2 development

[unix-history] / src / pi / proc.c

/* Copyright (c) 1979 Regents of the University of California */
#
/*
 * pi - Pascal interpreter code translator
 *
 * Charles Haley, Bill Joy UCB
 * Version 1.2 January 1979
 */

#include "0.h"
#include "tree.h"
#include "opcode.h"

/*
 * The following arrays are used to determine which classes may be
 * read and written to/from text files.
 * They are indexed by the return types from classify.
 */
#define rdops(x) rdxxxx[(x)-(TFIRST)]
#define wrops(x) wrxxxx[(x)-(TFIRST)]

int rdxxxx[] {
	0,		/* -7  file types */
	0,		/* -6  record types */
	0,		/* -5  array types */
	0,		/* -4  scalar types */
	0,		/* -3  pointer types */
	0,		/* -2  set types */
	0,		/* -1  string types */
	0,		/*  0  nil - i.e. no type */
	0,		/*  1  booleans */
	O_READC,	/*  2  character */
	O_READ4,	/*  3  integer */
	O_READ8		/*  4  real */
};

int wrxxxx[] {
	0,		/* -7  file types */
	0,		/* -6  record types */
	0,		/* -5  array types */
	0,		/* -4  scalar types */
	0,		/* -3  pointer types */
	0,		/* -2  set types */
	O_WRITG,	/* -1  string types */
	0,		/*  0  nil - i.e. no type */
	O_WRITB,	/*  1  booleans */
	O_WRITC,	/*  2  character */
	O_WRIT4,	/*  3  integer */
	O_WRIT8,	/*  4  real */
};
\f
/*
 * 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.
 */
proc(r)
	int *r;
{
	register struct nl *p;
	register int *al, op;
	struct nl *filetype, *ap;
	int argc, *argv, c, two, oct, hex, *file;
	int pu;
	int *pua, *pui, *puz;
	int i, j, k;

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

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

	/*
	 * Call to built-in procedure.
	 * Count the arguments.
	 */
	argc = 0;
	for (al = argv; al != NIL; al = al[2])
		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_NULL:
		if (argc != 0)
			error("null takes no arguments");
		return;

	case O_FLUSH:
		if (argc == 0) {
			put1(O_MESSAGE);
			return;
		}
		if (argc != 1) {
			error("flush takes at most one argument");
			return;
		}
		ap = rvalue(argv[1], NIL);
		if (ap == NIL)
			return;
		if (ap->class != FILE) {
			error("flush's argument must be a file, not %s", nameof(ap));
			return;
		}
		put1(op);
		return;

	case O_MESSAGE:
	case O_WRIT2:
	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.
			 */
			put1(O_MESSAGE);
		} else if (argv != NIL && (al = argv[1])[0] != T_WEXP) {
			/*
			 * If there is a first argument which has
			 * no write widths, then it is potentially
			 * a file name.
			 */
			codeoff();
			ap = rvalue(argv[1], NIL);
			codeon();
			if (ap == NIL)
				argv = argv[2];
			if (ap != NIL && ap->class == FILE) {
				/*
				 * 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.
				 */
				file = argv[1];
				filetype = ap->type;
				rvalue(argv[1], NIL);
				put1(O_UNIT);
				/*
				 * Skip over the first argument
				 */
				argv = argv[2];
				argc--;
			} else
				/*
				 * Set up for writing on 
				 * standard output.
				 */
				put1(O_UNITOUT);
		} else
			put1(O_UNITOUT);
		/*
		 * Loop and process each
		 * of the arguments.
		 */
		for (; argv != NIL; argv = argv[2]) {
			al = argv[1];
			if (al == NIL)
				continue;
			/*
			 * Op will be used to
			 * accumulate width information,
			 * and two records the fact
			 * that we saw two write widths
			 */
			op = 0;
			two = 0;
			oct = 0;
			hex = 0;
			if (al[0] == T_WEXP) {
				if (filetype != nl+T1CHAR) {
					error("Write widths allowed only with text files");
					continue;
				}
				/*
				 * Handle width expressions.
				 * The basic game here is that width
				 * expressions get evaluated and left
				 * on the stack and their width's get
				 * packed into the high byte of the
				 * affected opcode (subop).
				 */
				if (al[3] == OCT) 
					oct++;
				else if (al[3] == HEX)
					hex++;
				else if (al[3] != NIL) {
					two++;
					/*
					 * Arrange for the write
					 * opcode that takes two widths
					 */
					op =| O_WRIT82-O_WRIT8;
					ap = rvalue(al[3], NIL);
					if (ap == NIL)
						continue;
					if (isnta(ap, "i")) {
						error("Second write width must be integer, not %s", nameof(ap));
						continue;
					}
					op =| even(width(ap)) << 11;
				}
				if (al[2] != NIL) {
					ap = rvalue(al[2], NIL);
					if (ap == NIL)
						continue;
					if (isnta(ap, "i")) {
						error("First write width must be integer, not %s", nameof(ap));
						continue;
					}
					op =| even(width(ap)) << 8;
				}
				al = al[1];
				if (al == NIL)
					continue;
			}
			if (filetype != nl+T1CHAR) {
				if (oct || hex) {
					error("Oct/hex allowed only on text files");
					continue;
				}
				if (op) {
					error("Write widths allowed only on text files");
					continue;
				}
				/*
				 * Generalized write, i.e.
				 * to a non-textfile.
				 */
				rvalue(file, NIL);
				put1(O_FNIL);
				/*
				 * file^ := ...
				 */
				ap = rvalue(argv[1], NIL);
				if (ap == NIL)
					continue;
				if (incompat(ap, filetype, argv[1])) {
					cerror("Type mismatch in write to non-text file");
					continue;
				}
				convert(ap, filetype);
				put2(O_AS, width(filetype));
				/*
				 * put(file)
				 */
				put1(O_PUT);
				continue;
			}
			/*
			 * Write to a textfile
			 *
			 * Evaluate the expression
			 * to be written.
			 */
			ap = rvalue(al, NIL);
			if (ap == NIL)
				continue;
			c = classify(ap);
			if (two && c != TDOUBLE) {
				if (isnta(ap, "i")) {
					error("Only reals can have two write widths");
					continue;
				}
				convert(ap, nl+TDOUBLE);
				c = TDOUBLE;
			}
			if (oct || hex) {
				if (opt('s')) {
					standard();
					error("Oct and hex are non-standard");
				}
				switch (c) {
					case TREC:
					case TARY:
					case TFILE:
					case TSTR:
					case TSET:
					case TDOUBLE:
						error("Can't write %ss with oct/hex", clnames[c]);
						continue;
				}
				put1(op | (oct ? O_WROCT2 : O_WRHEX2) | (width(ap) >> 2));
				continue;
			}
			if (wrops(c) == NIL) {
				error("Can't write %ss to a text file", clnames[c]);
				continue;
			}
			if (c == TINT && width(ap) != 4)
				op =| O_WRIT2;
			else
				op =| wrops(c);
			if (c == TSTR)
				put2(op, width(ap));
			else
				put1(op);
		}
		/*
		 * Done with arguments.
		 * Handle writeln and
		 * insufficent number of args.
		 */
		switch (p->value[0] &~ NSTAND) {
			case O_WRIT2:
				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");
				put1(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 != NIL) {
			codeoff();
			ap = rvalue(argv[1], NIL);
			codeon();
			if (ap == NIL)
				argv = argv[2];
			if (ap != NIL && ap->class == FILE) {
				/*
				 * 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[1];
				filetype = ap->type;
				rvalue(argv[1], NIL);
				put1(O_UNIT);
				argv = argv[2];
				argc--;
			} else {
				/*
				 * Default is read from
				 * standard input.
				 */
				put1(O_UNITINP);
				input->nl_flags =| NUSED;
			}
		} else {
			put1(O_UNITINP);
			input->nl_flags =| NUSED;
		}
		/*
		 * Loop and process each
		 * of the arguments.
		 */
		for (; argv != NIL; argv = argv[2]) {
			/*
			 * Get the address of the target
			 * on the stack.
			 */
			al = argv[1];
			if (al == NIL)
				continue;
			if (al[0] != T_VAR) {
				error("Arguments to %s must be variables, not expressions", p->symbol);
				continue;
			}
			ap = lvalue(al, MOD|ASGN|NOUSE);
			if (ap == NIL)
				continue;
			if (filetype != nl+T1CHAR) {
				/*
				 * Generalized read, i.e.
				 * from a non-textfile.
				 */
				if (incompat(filetype, ap, NIL)) {
					error("Type mismatch in read from non-text file");
					continue;
				}
				/*
				 * var := file ^;
				 */
				if (file != NIL)
					rvalue(file, NIL);
				else /* Magic */
					put2(O_RV2, input->value[0]);
				put1(O_FNIL);
				put2(O_IND, width(filetype));
				convert(filetype, ap);
				if (isa(ap, "bsci"))
					rangechk(ap, ap);
				put2(O_AS, width(ap));
				/*
				 * get(file);
				 */
				put1(O_GET);
				continue;
			}
			c = classify(ap);
			op = rdops(c);
			if (op == NIL) {
				error("Can't read %ss from a text file", clnames[c]);
				continue;
			}
			put1(op);
			/*
			 * Data read is on the stack.
			 * Assign it.
			 */
			if (op != O_READ8)
				rangechk(ap, op == O_READC ? ap : nl+T4INT);
			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");
			put1(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 = rvalue(argv[1], NIL);
		if (ap == NIL)
			return;
		if (ap->class != FILE) {
			error("Argument to %s must be a file, not %s", p->symbol, nameof(ap));
			return;
		}
		put1(O_UNIT);
		put1(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");
		}
		ap = lvalue(argv[1], MOD|NOUSE);
		if (ap == NIL)
			return;
		if (ap->class != FILE) {
			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[2];
			al = rvalue(al[1], NIL);
			if (al == NIL)
				return;
			if (classify(al) != TSTR) {
				error("Second argument to %s must be a string, not %s", p->symbol, nameof(al));
				return;
			}
			c = width(al);
		} else
			c = 0;
		if (c > 127) {
			error("File name too long");
			return;
		}
		put2(op | c << 8, text(ap) ? 0: width(ap->type));
		return;

	case O_NEW:
	case O_DISPOSE:
		if (argc == 0) {
			error("%s expects at least one argument", p->symbol);
			return;
		}
		ap = lvalue(argv[1], MOD|NOUSE);
		if (ap == NIL)
			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;
		argv = argv[2];
		if (argv != NIL) {
			if (ap->class != RECORD) {
				error("Record required when specifying variant tags");
				return;
			}
			for (; argv != NIL; argv = argv[2]) {
				if (ap->value[NL_VARNT] == NIL) {
					error("Too many tag fields");
					return;
				}
				if (!isconst(argv[1])) {
					error("Second and successive arguments to %s must be constants", p->symbol);
					return;
				}
				gconst(argv[1]);
				if (con.ctype == NIL)
					return;
				if (incompat(con.ctype, ap->value[NL_TAG]->type)) {
					cerror("Specified tag constant type clashed with variant case selector type");
					return;
				}
				for (ap = ap->value[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->value[NL_VTOREC];
			}
		}
		put2(op, width(ap));
		return;

	case O_DATE:
	case O_TIME:
		if (argc != 1) {
			error("%s expects one argument", p->symbol);
			return;
		}
		ap = lvalue(argv[1], 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;
		}
		put1(op);
		return;

	case O_HALT:
		if (argc != 0) {
			error("halt takes no arguments");
			return;
		}
		put1(op);
		noreach = 1;
		return;

	case O_ARGV:
		if (argc != 2) {
			error("argv takes two arguments");
			return;
		}
		ap = rvalue(argv[1], NIL);
		if (ap == NIL)
			return;
		if (isnta(ap, "i")) {
			error("argv's first argument must be an integer, not %s", nameof(ap));
			return;
		}
		convert(ap, nl+T2INT);
		al = argv[2];
		ap = lvalue(al[1], MOD|NOUSE);
		if (ap == NIL)
			return;
		if (classify(ap) != TSTR) {
			error("argv's second argument must be a string, not %s", nameof(ap));
			return;
		}
		put2(op, width(ap));
		return;

	case O_STLIM:
		if (argc != 1) {
			error("stlimit requires one argument");
			return;
		}
		ap = rvalue(argv[1], NIL);
		if (ap == NIL)
			return;
		if (isnta(ap, "i")) {
			error("stlimit's argument must be an integer, not %s", nameof(ap));
			return;
		}
		if (width(ap) != 4)
			put1(O_STOI);
		put1(op);
		return;

	case O_REMOVE:
		if (argc != 1) {
			error("remove expects one argument");
			return;
		}
		ap = rvalue(argv[1], NIL);
		if (ap == NIL)
			return;
		if (classify(ap) != TSTR) {
			error("remove's argument must be a string, not %s", nameof(ap));
			return;
		}
		put2(op, width(ap));
		return;

	case O_LLIMIT:
		if (argc != 2) {
			error("linelimit expects two arguments");
			return;
		}
		ap = lvalue(argv[1], NOMOD|NOUSE);
		if (ap == NIL)
			return;
		if (!text(ap)) {
			error("linelimit's first argument must be a text file, not %s", nameof(ap));
			return;
		}
		al = argv[2];
		ap = rvalue(al[1], NIL);
		if (ap == NIL)
			return;
		if (isnta(ap, "i")) {
			error("linelimit's second argument must be an integer, not %s", nameof(ap));
			return;
		}
		convert(ap, nl+T2INT);
		put1(op);
		return;
	case O_PAGE:
		if (argc != 1) {
			error("page expects one argument");
			return;
		}
		ap = rvalue(argv[1], NIL);
		if (ap == NIL)
			return;
		if (!text(ap)) {
			error("Argument to page must be a text file, not %s", nameof(ap));
			return;
		}
		put1(O_UNIT);
		put1(op);
		return;

	case O_PACK:
		if (argc != 3) {
			error("pack expects three arguments");
			return;
		}
		pu = "pack(a,i,z)";
		pua = (al = argv)[1];
		pui = (al = al[2])[1];
		puz = (al = al[2])[1];
		goto packunp;
	case O_UNPACK:
		if (argc != 3) {
			error("unpack expects three arguments");
			return;
		}
		pu = "unpack(z,a,i)";
		puz = (al = argv)[1];
		pua = (al = al[2])[1];
		pui = (al = al[2])[1];
packunp:
		ap = rvalue(pui, NIL);
		if (ap == NIL)
			return;
		if (width(ap) == 4)
			put1(O_ITOS);
		ap = lvalue(pua, op == O_PACK ? NOMOD : 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;
		}
		al = lvalue(puz, op == O_UNPACK ? NOMOD : MOD|NOUSE);
		if (al->class != ARRAY) {
			error("%s requires z to be a packed array, not %s", pu, nameof(ap));
			return;
		}
		if (al->type == NIL || ap->type == NIL)
			return;
		if (al->type != ap->type) {
			error("%s requires a and z to be arrays of the same type", pu, nameof(ap));
			return;
		}
		k = width(al);
		ap = ap->chain;
		al = al->chain;
		if (ap->chain != NIL || 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 = al->range[1] - al->range[0] + 1;
		if (i < j) {
			error("%s cannot have more elements in a (%d) than in z (%d)", pu, j, i);
			return;
		}
		/*
		 * get n-m-(v-u) and m for the interpreter
		 */
		i =- j;
		j = ap->range[0];
		put(5, op, width(ap), j, i, k);
		return;
	case 0:
		error("%s is an unimplemented 6400 extension", p->symbol);
		return;

	default:
		panic("proc case");
	}
}