[unix-history] / usr / src / cmd / pi / func.c

/* Copyright (c) 1979 Regents of the University of California */

static	char sccsid[] = "@(#)func.c 1.3 10/19/80";

#include "whoami.h"
#ifdef OBJ
    /*
     *	the rest of the file
     */
#include "0.h"
#include "tree.h"
#include "opcode.h"

/*
 * Funccod generates code for
 * built in function calls and calls
 * call to generate calls to user
 * defined functions and procedures.
 */
funccod(r)
	int *r;
{
	struct nl *p;
	register struct nl *p1;
	register int *al;
	register op;
	int argc, *argv;
	int tr[2], tr2[4];

	/*
	 * Verify that the given name
	 * is defined and the name of
	 * a function.
	 */
	p = lookup(r[2]);
	if (p == NIL) {
		rvlist(r[3]);
		return (NIL);
	}
	if (p->class != FUNC && p->class != FFUNC) {
		error("%s is not a function", p->symbol);
		rvlist(r[3]);
		return (NIL);
	}
	argv = r[3];
	/*
	 * Call handles user defined
	 * procedures and functions
	 */
	if (bn != 0)
		return (call(p, argv, FUNC, bn));
	/*
	 * Count the arguments
	 */
	argc = 0;
	for (al = argv; al != NIL; al = al[2])
		argc++;
	/*
	 * Built-in functions have
	 * their interpreter opcode
	 * associated with them.
	 */
	op = p->value[0] &~ NSTAND;
	if (opt('s') && (p->value[0] & NSTAND)) {
		standard();
		error("%s is a nonstandard function", p->symbol);
	}
	switch (op) {
		/*
		 * Parameterless functions
		 */
		case O_CLCK:
		case O_SCLCK:
		case O_WCLCK:
		case O_ARGC:
			if (argc != 0) {
				error("%s takes no arguments", p->symbol);
				rvlist(argv);
				return (NIL);
			}
			put1(op);
			return (nl+T4INT);
		case O_EOF:
		case O_EOLN:
			if (argc == 0) {
				argv = tr;
				tr[1] = tr2;
				tr2[0] = T_VAR;
				tr2[2] = input->symbol;
				tr2[1] = tr2[3] = NIL;
				argc = 1;
			} else if (argc != 1) {
				error("%s takes either zero or one argument", p->symbol);
				rvlist(argv);
				return (NIL);
			}
		}
	/*
	 * All other functions take
	 * exactly one argument.
	 */
	if (argc != 1) {
		error("%s takes exactly one argument", p->symbol);
		rvlist(argv);
		return (NIL);
	}
	/*
	 * Evaluate the argmument
	 */
	p1 = stkrval((int *) argv[1], NLNIL , RREQ );
	if (p1 == NIL)
		return (NIL);
	switch (op) {
		case O_EXP:
		case O_SIN:
		case O_COS:
		case O_ATAN:
		case O_LN:
		case O_SQRT:
		case O_RANDOM:
		case O_EXPO:
		case O_UNDEF:
			if (isa(p1, "i"))
				convert(p1, nl+TDOUBLE);
			else if (isnta(p1, "d")) {
				error("%s's argument must be integer or real, not %s", p->symbol, nameof(p1));
				return (NIL);
			}
			put1(op);
			if (op == O_UNDEF)
				return (nl+TBOOL);
			else if (op == O_EXPO)
				return (nl+T4INT);
			else
				return (nl+TDOUBLE);
		case O_SEED:
			if (isnta(p1, "i")) {
				error("seed's argument must be an integer, not %s", nameof(p1));
				return (NIL);
			}
			put1(op);
			return (nl+T4INT);
		case O_ROUND:
		case O_TRUNC:
			if (isnta(p1, "d"))  {
				error("%s's argument must be a real, not %s", p->symbol, nameof(p1));
				return (NIL);
			}
			put1(op);
			return (nl+T4INT);
		case O_ABS2:
		case O_SQR2:
			if (isa(p1, "d")) {
				put1(op + O_ABS8-O_ABS2);
				return (nl+TDOUBLE);
			}
			if (isa(p1, "i")) {
				put1(op + (width(p1) >> 2));
				return (nl+T4INT);
			}
			error("%s's argument must be an integer or real, not %s", p->symbol, nameof(p1));
			return (NIL);
		case O_ORD2:
			if (isa(p1, "bcis") || classify(p1) == TPTR) {
				return (nl+T4INT);
			}
			error("ord's argument must be of scalar type or a pointer, not %s", nameof(p1));
			return (NIL);
		case O_SUCC2:
		case O_PRED2:
			if (isa(p1, "bcs")) {
				put1(op);
				return (p1);
			}
			if (isa(p1, "i")) {
				if (width(p1) <= 2)
					op += O_PRED24-O_PRED2;
				else
					op++;
				put1(op);
				return (nl+T4INT);
			}
			if (isa(p1, "id")) {
				error("%s is forbidden for reals", p->symbol);
				return (NIL);
			}
			error("%s's argument must be of scalar type, not %s", p->symbol, nameof(p1));
			return (NIL);
		case O_ODD2:
			if (isnta(p1, "i")) {
				error("odd's argument must be an integer, not %s", nameof(p1));
				return (NIL);
			}
			put1(op + (width(p1) >> 2));
			return (nl+TBOOL);
		case O_CHR2:
			if (isnta(p1, "i")) {
				error("chr's argument must be an integer, not %s", nameof(p1));
				return (NIL);
			}
			put1(op + (width(p1) >> 2));
			return (nl+TCHAR);
		case O_CARD:
			if (isnta(p1, "t")) {
			    error("Argument to card must be a set, not %s", nameof(p1));
			    return (NIL);
			}
			put2(O_CARD, width(p1));
			return (nl+T2INT);
		case O_EOLN:
			if (!text(p1)) {
				error("Argument to eoln must be a text file, not %s", nameof(p1));
				return (NIL);
			}
			put1(op);
			return (nl+TBOOL);
		case O_EOF:
			if (p1->class != FILET) {
				error("Argument to eof must be file, not %s", nameof(p1));
				return (NIL);
			}
			put1(op);
			return (nl+TBOOL);
		case 0:
			error("%s is an unimplemented 6000-3.4 extension", p->symbol);
		default:
			panic("func1");
	}
}
#endif OBJ
Commit	Line	Data
ff12ff13 PK	1	/* Copyright (c) 1979 Regents of the University of California */
ff12ff13 PK	2
31cef89c	3	static char sccsid[] = "@(#)func.c 1.3 10/19/80";
ff12ff13 PK	4
	5	#include "whoami.h"
	6	#ifdef OBJ
	7	/*
	8	* the rest of the file
	9	*/
	10	#include "0.h"
	11	#include "tree.h"
	12	#include "opcode.h"
	13
ff12ff13 PK	14	/*
	15	* Funccod generates code for
	16	* built in function calls and calls
	17	* call to generate calls to user
	18	* defined functions and procedures.
	19	*/
	20	funccod(r)
	21	int *r;
	22	{
	23	struct nl *p;
	24	register struct nl *p1;
	25	register int *al;
	26	register op;
	27	int argc, *argv;
	28	int tr[2], tr2[4];
	29
	30	/*
	31	* Verify that the given name
	32	* is defined and the name of
	33	* a function.
	34	*/
	35	p = lookup(r[2]);
	36	if (p == NIL) {
	37	rvlist(r[3]);
	38	return (NIL);
	39	}
c4e911b6	40	if (p->class != FUNC && p->class != FFUNC) {
ff12ff13 PK	41	error("%s is not a function", p->symbol);
	42	rvlist(r[3]);
	43	return (NIL);
	44	}
	45	argv = r[3];
	46	/*
	47	* Call handles user defined
	48	* procedures and functions
	49	*/
	50	if (bn != 0)
	51	return (call(p, argv, FUNC, bn));
	52	/*
	53	* Count the arguments
	54	*/
	55	argc = 0;
	56	for (al = argv; al != NIL; al = al[2])
	57	argc++;
	58	/*
	59	* Built-in functions have
	60	* their interpreter opcode
	61	* associated with them.
	62	*/
	63	op = p->value[0] &~ NSTAND;
	64	if (opt('s') && (p->value[0] & NSTAND)) {
	65	standard();
	66	error("%s is a nonstandard function", p->symbol);
	67	}
	68	switch (op) {
	69	/*
	70	* Parameterless functions
	71	*/
	72	case O_CLCK:
	73	case O_SCLCK:
	74	case O_WCLCK:
	75	case O_ARGC:
	76	if (argc != 0) {
	77	error("%s takes no arguments", p->symbol);
	78	rvlist(argv);
	79	return (NIL);
	80	}
	81	put1(op);
	82	return (nl+T4INT);
	83	case O_EOF:
	84	case O_EOLN:
	85	if (argc == 0) {
	86	argv = tr;
	87	tr[1] = tr2;
	88	tr2[0] = T_VAR;
	89	tr2[2] = input->symbol;
	90	tr2[1] = tr2[3] = NIL;
	91	argc = 1;
	92	} else if (argc != 1) {
	93	error("%s takes either zero or one argument", p->symbol);
	94	rvlist(argv);
	95	return (NIL);
	96	}
	97	}
	98	/*
	99	* All other functions take
	100	* exactly one argument.
	101	*/
	102	if (argc != 1) {
	103	error("%s takes exactly one argument", p->symbol);
	104	rvlist(argv);
105	return (NIL);
106	}
107	/*
108	* Evaluate the argmument
109	*/
110	p1 = stkrval((int *) argv[1], NLNIL , RREQ );
111	if (p1 == NIL)
112	return (NIL);
113	switch (op) {
114	case O_EXP:
115	case O_SIN:
116	case O_COS:
117	case O_ATAN:
118	case O_LN:
119	case O_SQRT:
120	case O_RANDOM:
121	case O_EXPO:
122	case O_UNDEF:
123	if (isa(p1, "i"))
124	convert(p1, nl+TDOUBLE);
125	else if (isnta(p1, "d")) {
126	error("%s's argument must be integer or real, not %s", p->symbol, nameof(p1));
127	return (NIL);
128	}
129	put1(op);
130	if (op == O_UNDEF)
131	return (nl+TBOOL);
132	else if (op == O_EXPO)
133	return (nl+T4INT);
134	else
135	return (nl+TDOUBLE);
136	case O_SEED:
137	if (isnta(p1, "i")) {
138	error("seed's argument must be an integer, not %s", nameof(p1));
139	return (NIL);
140	}
141	put1(op);
142	return (nl+T4INT);
143	case O_ROUND:
144	case O_TRUNC:
145	if (isnta(p1, "d")) {
146	error("%s's argument must be a real, not %s", p->symbol, nameof(p1));
147	return (NIL);
148	}
149	put1(op);
150	return (nl+T4INT);
151	case O_ABS2:
152	case O_SQR2:
153	if (isa(p1, "d")) {
154	put1(op + O_ABS8-O_ABS2);
155	return (nl+TDOUBLE);
156	}
157	if (isa(p1, "i")) {
158	put1(op + (width(p1) >> 2));
159	return (nl+T4INT);
160	}
161	error("%s's argument must be an integer or real, not %s", p->symbol, nameof(p1));
162	return (NIL);
163	case O_ORD2:
164	if (isa(p1, "bcis") \|\| classify(p1) == TPTR) {
165	return (nl+T4INT);
166	}
167	error("ord's argument must be of scalar type or a pointer, not %s", nameof(p1));
168	return (NIL);
169	case O_SUCC2:
170	case O_PRED2:
171	if (isa(p1, "bcs")) {
172	put1(op);
173	return (p1);
174	}
175	if (isa(p1, "i")) {
176	if (width(p1) <= 2)
177	op += O_PRED24-O_PRED2;
178	else
179	op++;
180	put1(op);
181	return (nl+T4INT);
182	}
183	if (isa(p1, "id")) {
184	error("%s is forbidden for reals", p->symbol);
185	return (NIL);
186	}
187	error("%s's argument must be of scalar type, not %s", p->symbol, nameof(p1));
188	return (NIL);
189	case O_ODD2:
190	if (isnta(p1, "i")) {
191	error("odd's argument must be an integer, not %s", nameof(p1));
192	return (NIL);
193	}
194	put1(op + (width(p1) >> 2));
195	return (nl+TBOOL);
196	case O_CHR2:
197	if (isnta(p1, "i")) {
198	error("chr's argument must be an integer, not %s", nameof(p1));
199	return (NIL);
200	}
201	put1(op + (width(p1) >> 2));
202	return (nl+TCHAR);
203	case O_CARD:
70de7f21 PK	204	if (isnta(p1, "t")) {
	205	error("Argument to card must be a set, not %s", nameof(p1));
	206	return (NIL);
ff12ff13	207	}
70de7f21	208	put2(O_CARD, width(p1));
ff12ff13 PK	209	return (nl+T2INT);
	210	case O_EOLN:
	211	if (!text(p1)) {
	212	error("Argument to eoln must be a text file, not %s", nameof(p1));
	213	return (NIL);
	214	}
	215	put1(op);
	216	return (nl+TBOOL);
	217	case O_EOF:
	218	if (p1->class != FILET) {
	219	error("Argument to eof must be file, not %s", nameof(p1));
	220	return (NIL);
	221	}
	222	put1(op);
	223	return (nl+TBOOL);
	224	case 0:
	225	error("%s is an unimplemented 6000-3.4 extension", p->symbol);
	226	default:
	227	panic("func1");
	228	}
	229	}
	230	#endif OBJ