[unix-history] / usr / src / usr.bin / pascal / src / func.c

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

static	char sccsid[] = "@(#)func.c 1.2 %G%";

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

bool cardempty = FALSE;

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