ftp.nice.ch/pub/next/developer/languages/lisp/AKCL.1.599.s.tar.gz#/akcl-1-599/c/bind.c

This is bind.c in view mode; [Download] [Up]

/*
(c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
Copying of this file is authorized to users who have executed the true and
proper "License Agreement for Kyoto Common LISP" with SIGLISP.
*/

/*
	bind.c
*/

#include "include.h"
#include "varargs.h"

struct nil3 { object nil3_self[3]; } three_nils;
struct nil6 { object nil6_self[6]; } six_nils;

struct required {
	object	req_var;
	object	req_spp;
};

struct optional {
	object	opt_var;
	object	opt_spp;
	object	opt_init;
	object	opt_svar;
	object	opt_svar_spp;
};

struct rest {
	object	rest_var;
	object	rest_spp;
};

struct keyword {
	object	key_word;
	object	key_var;
	object	key_spp;
	object	key_init;
	object	key_svar;
	object	key_svar_spp;
	object	key_val;
	object	key_svar_val;
};

struct aux {
	object	aux_var;
	object	aux_spp;
	object	aux_init;
};



static object temporary;

#define	isdeclare(x)	((x) == Sdeclare)

lambda_bind(arg_top)
object *arg_top;
{
	object lambda, lambda_list, body, form, x, ds, vs, v;
	int narg, i, j;
	object *base = vs_base;
	struct required *required;
	int nreq;
	struct optional *optional;
	int nopt;
	struct rest *rest;
	bool rest_flag;
	struct keyword *keyword;
	bool key_flag;
	bool allow_other_keys_flag, other_keys_appeared;
	int nkey;
	struct aux *aux;
	int naux;
	bool special_processed;
	vs_mark;

	bds_check;
	lambda = vs_head;
	if (type_of(lambda) != t_cons)
		FEerror("No lambda list.", 0);
	lambda_list = lambda->c.c_car;
	body = lambda->c.c_cdr;

	required = (struct required *)vs_top;
	nreq = 0;
	for (;;) {
		if (endp(lambda_list))
			goto REQUIRED_ONLY;
		x = lambda_list->c.c_car;
		lambda_list = lambda_list->c.c_cdr;
		check_symbol(x);
		if (x == ANDallow_other_keys)
			illegal_lambda();
		if (x == ANDoptional) {
			nopt = nkey = naux = 0;
			rest_flag = key_flag = allow_other_keys_flag
			= FALSE;
			goto OPTIONAL;
		}
		if (x == ANDrest) {
			nopt = nkey = naux = 0;
			key_flag = allow_other_keys_flag
			= FALSE;
			goto REST;
		}
		if (x == ANDkey) {
			nopt = nkey = naux = 0;
			rest_flag = allow_other_keys_flag
			= FALSE;
			goto KEYWORD;
		}
		if (x == ANDaux) {
			nopt = nkey = naux = 0;
			rest_flag = key_flag = allow_other_keys_flag
			= FALSE;
			goto AUX;
		}
		if ((enum stype)x->s.s_stype == stp_constant)
			FEerror("~S is not a variable.", 1, x);
		vs_push(x);
		vs_push(Cnil);
		nreq++;
	}

OPTIONAL:
	optional = (struct optional *)vs_top;
	for (;;  nopt++) {
		if (endp(lambda_list))
			goto SEARCH_DECLARE;
		x = lambda_list->c.c_car;
		lambda_list = lambda_list->c.c_cdr;
		if (type_of(x) == t_cons) {
			check_symbol(x->c.c_car);
			check_var(x->c.c_car);
			vs_push(x->c.c_car);
			x = x->c.c_cdr;
			vs_push(Cnil);
			if (endp(x)) {
				*(struct nil3 *)vs_top = three_nils;
				vs_top += 3;
				continue;
			}
			vs_push(x->c.c_car);
			x = x->c.c_cdr;
			if (endp(x)) {
				vs_push(Cnil);
				vs_push(Cnil);
				continue;
			}
			check_symbol(x->c.c_car);
			check_var(x->c.c_car);
			vs_push(x->c.c_car);
			vs_push(Cnil);
			if (!endp(x->c.c_cdr))
				illegal_lambda();
		} else {
			check_symbol(x);
			if (x == ANDoptional ||
			    x == ANDallow_other_keys)
				illegal_lambda();
			if (x == ANDrest)
				goto REST;
			if (x == ANDkey)
				goto KEYWORD;
			if (x == ANDaux)
				goto AUX;
			check_var(x);
			vs_push(x);
			*(struct nil6 *)vs_top = six_nils;
			vs_top += 4;
		}
	}

REST:
	rest = (struct rest *)vs_top;
	if (endp(lambda_list))
		illegal_lambda();
	check_symbol(lambda_list->c.c_car);
	check_var(lambda_list->c.c_car);
	rest_flag = TRUE;
	vs_push(lambda_list->c.c_car);
	vs_push(Cnil);
	lambda_list = lambda_list->c.c_cdr;
	if (endp(lambda_list))
		goto SEARCH_DECLARE;
	x = lambda_list->c.c_car;
	lambda_list = lambda_list->c.c_cdr;
	check_symbol(x);
	if (x == ANDoptional || x == ANDrest ||
	    x == ANDallow_other_keys)
		illegal_lambda();
	if (x == ANDkey)
		goto KEYWORD;
	if (x == ANDaux)
		goto AUX;
	illegal_lambda();

KEYWORD:
	keyword = (struct keyword *)vs_top;
	key_flag = TRUE;
	for (;;  nkey++) {
		if (endp(lambda_list))
			goto SEARCH_DECLARE;
		x = lambda_list->c.c_car;
		lambda_list = lambda_list->c.c_cdr;
		if (type_of(x) == t_cons) {
			if (type_of(x->c.c_car) == t_cons) {
				if (!keywordp(x->c.c_car->c.c_car))
					FEerror("~S is not a keyword.",
						1, x->c.c_car->c.c_car);
				vs_push(x->c.c_car->c.c_car);
				if (endp(x->c.c_car->c.c_cdr))
					illegal_lambda();
				check_symbol(x->c.c_car
					      ->c.c_cdr->c.c_car);
				vs_push(x->c.c_car->c.c_cdr->c.c_car);
				if (!endp(x->c.c_car->c.c_cdr->c.c_cdr))
					illegal_lambda();
			} else {
				check_symbol(x->c.c_car);
				check_var(x->c.c_car);
				vs_push(intern(x->c.c_car, keyword_package));
				vs_push(x->c.c_car);
			}
			vs_push(Cnil);
			x = x->c.c_cdr;
			if (endp(x)) {
				*(struct nil6 *)vs_top = six_nils;
				vs_top += 5;
				continue;
			}
			vs_push(x->c.c_car);
			x = x->c.c_cdr;
			if (endp(x)) {
				*(struct nil6 *)vs_top = six_nils;
				vs_top += 4;
				continue;
			}
			check_symbol(x->c.c_car);
			check_var(x->c.c_car);
			vs_push(x->c.c_car);
			vs_push(Cnil);
			if (!endp(x->c.c_cdr))
				illegal_lambda();
			vs_push(Cnil);
			vs_push(Cnil);
		} else {
			check_symbol(x);
			if (x == ANDallow_other_keys) {
				allow_other_keys_flag = TRUE;
				if (endp(lambda_list))
					goto SEARCH_DECLARE;
				x = lambda_list->c.c_car;
				lambda_list = lambda_list->c.c_cdr;
			}
			if (x == ANDoptional || x == ANDrest ||
			    x == ANDkey || x == ANDallow_other_keys)
				illegal_lambda();
			if (x == ANDaux)
				goto AUX;
			check_var(x);
			vs_push(intern(x, keyword_package));
			vs_push(x);
			*(struct nil6 *)vs_top = six_nils;
			vs_top += 6;
		}
	}

AUX:
	aux = (struct aux *)vs_top;
	for (;;  naux++) {
		if (endp(lambda_list))
			goto SEARCH_DECLARE;
		x = lambda_list->c.c_car;
		lambda_list = lambda_list->c.c_cdr;
		if (type_of(x) == t_cons) {
			check_symbol(x->c.c_car);
			check_var(x->c.c_car);
			vs_push(x->c.c_car);
			vs_push(Cnil);
			x = x->c.c_cdr;
			if (endp(x)) {
				vs_push(Cnil);
				continue;
			}
			vs_push(x->c.c_car);
			if (!endp(x->c.c_cdr))
				illegal_lambda();
		} else {
			check_symbol(x);
			if (x == ANDoptional || x == ANDrest ||
			    x == ANDkey || x == ANDallow_other_keys ||
	    		    x == ANDaux)
				illegal_lambda();
			check_var(x);
			vs_push(x);
			vs_push(Cnil);
			vs_push(Cnil);
		}
	}

SEARCH_DECLARE:
	vs_push(Cnil);
	for (;  !endp(body);  body = body->c.c_cdr) {
		form = body->c.c_car;

		/*  MACRO EXPANSION  */
		form = macro_expand(form);
		vs_head = form;

		if (type_of(form) == t_string) {
			if (endp(body->c.c_cdr))
				break;
			continue;
		}
		if (type_of(form)!=t_cons || !isdeclare(form->c.c_car))
			break;
		for (ds = form->c.c_cdr; !endp(ds); ds = ds->c.c_cdr) {
			if (type_of(ds->c.c_car) != t_cons)
				illegal_declare(form);
			if (ds->c.c_car->c.c_car == Sspecial) {
				vs = ds->c.c_car->c.c_cdr;
				for (;  !endp(vs);  vs = vs->c.c_cdr) {
					v = vs->c.c_car;
					check_symbol(v);
/**/

	special_processed = FALSE;
	for (i = 0;  i < nreq;  i++)
		if (required[i].req_var == v) {
			required[i].req_spp = Ct;
			special_processed = TRUE;
		}
	for (i = 0;  i < nopt;  i++)
		if (optional[i].opt_var == v) {
			optional[i].opt_spp = Ct;
			special_processed = TRUE;
		} else if (optional[i].opt_svar == v) {
			optional[i].opt_svar_spp = Ct;
			special_processed = TRUE;
		}
	if (rest_flag && rest->rest_var == v) {
		rest->rest_spp = Ct;
		special_processed = TRUE;
	}
	for (i = 0;  i < nkey;  i++)
		if (keyword[i].key_var == v) {
			keyword[i].key_spp = Ct;
			special_processed = TRUE;
		} else if (keyword[i].key_svar == v) {
			keyword[i].key_svar_spp = Ct;
			special_processed = TRUE;
		}
	for (i = 0;  i < naux;  i++)
		if (aux[i].aux_var == v) {
			aux[i].aux_spp = Ct;
			special_processed = TRUE;
		}
	if (special_processed)
		continue;
	/*  lex_special_bind(v);  */
	temporary = MMcons(v, Cnil);
	lex_env[0] = MMcons(temporary, lex_env[0]);

/**/
				}
			}
		}
	}

	narg = arg_top - base;
	if (narg < nreq) {
		if (nopt == 0 && !rest_flag && !key_flag) {
			vs_base = base;
			vs_top = arg_top;
			check_arg_failed(nreq);
		}
		FEtoo_few_arguments(base, arg_top);
	}
	if (!rest_flag && !key_flag && narg > nreq+nopt) {
		if (nopt == 0) {
			vs_base = base;
			vs_top = arg_top;
			check_arg_failed(nreq);
		}
		FEtoo_many_arguments(base, arg_top);
	}
	for (i = 0;  i < nreq;  i++)
		bind_var(required[i].req_var,
			 base[i],
			 required[i].req_spp);
	for (i = 0;  i < nopt;  i++)
		if (nreq+i < narg) {
			bind_var(optional[i].opt_var,
				 base[nreq+i],
				 optional[i].opt_spp);
			if (optional[i].opt_svar != Cnil)
				bind_var(optional[i].opt_svar,
					 Ct,
					 optional[i].opt_svar_spp);
		} else {
			eval_assign(temporary, optional[i].opt_init);
			bind_var(optional[i].opt_var,
				 temporary,
				 optional[i].opt_spp);
			if (optional[i].opt_svar != Cnil)
				bind_var(optional[i].opt_svar,
					 Cnil,
					 optional[i].opt_svar_spp);
		}
	if (rest_flag) {
		vs_push(Cnil);
		for (i = narg, j = nreq+nopt;  --i >= j;  )
			vs_head = make_cons(base[i], vs_head);
		bind_var(rest->rest_var, vs_head, rest->rest_spp);
	}
	if (key_flag) {
		i = narg - nreq - nopt;
		if (i >= 0 && i%2 != 0)
			FEerror("Keyword values are missing.", 0);
		other_keys_appeared = FALSE;
		for (i = nreq + nopt;  i < narg;  i += 2) {
			if (!keywordp(base[i]))
				FEerror("~S is not a keyword.",
					1, base[i]);
			if (base[i] == Kallow_other_keys &&
			    base[i+1] != Cnil)
				allow_other_keys_flag = TRUE;
			for (j = 0;  j < nkey;  j++) {
				if (keyword[j].key_word == base[i]) {
					if (keyword[j].key_svar_val
					    != Cnil)
						goto NEXT_ARG;
					keyword[j].key_val
					= base[i+1];
					keyword[j].key_svar_val
					= Ct;
					goto NEXT_ARG;
				}
			}
			other_keys_appeared = TRUE;

		NEXT_ARG:
			continue;
		}
		if (other_keys_appeared && !allow_other_keys_flag)
			FEerror("Other-keys are not allowed.", 0);
	}
	for (i = 0;  i < nkey;  i++)
		if (keyword[i].key_svar_val != Cnil) {
			bind_var(keyword[i].key_var,
				 keyword[i].key_val,
				 keyword[i].key_spp);
			if (keyword[i].key_svar != Cnil)
				bind_var(keyword[i].key_svar,
					 keyword[i].key_svar_val,
					 keyword[i].key_svar_spp);
		} else {
			eval_assign(temporary, keyword[i].key_init);
			bind_var(keyword[i].key_var,
				 temporary,
				 keyword[i].key_spp);
			if (keyword[i].key_svar != Cnil)
				bind_var(keyword[i].key_svar,
					 keyword[i].key_svar_val,
					 keyword[i].key_svar_spp);
		}
	for (i = 0;  i < naux;  i++) {
		eval_assign(temporary, aux[i].aux_init);
		bind_var(aux[i].aux_var, temporary, aux[i].aux_spp);
	}
	if (type_of(body) != t_cons || body->c.c_car == form) {
		vs_reset;
		vs_head = body;
	} else {
		body = make_cons(form, body->c.c_cdr);
		vs_reset;
		vs_head = body;
	}
	return;

REQUIRED_ONLY:
	vs_push(Cnil);
	for (;  !endp(body);  body = body->c.c_cdr) {
		form = body->c.c_car;

		/*  MACRO EXPANSION  */
		vs_head = form = macro_expand(form);

		if (type_of(form) == t_string) {
			if (endp(body->c.c_cdr))
				break;
			continue;
		}
		if (type_of(form)!=t_cons || !isdeclare(form->c.c_car))
			break;
		for (ds = form->c.c_cdr; !endp(ds); ds = ds->c.c_cdr) {
			if (type_of(ds->c.c_car) != t_cons)
				illegal_declare(form);
			if (ds->c.c_car->c.c_car == Sspecial) {
				vs = ds->c.c_car->c.c_cdr;
				for (;  !endp(vs);  vs = vs->c.c_cdr) {
					v = vs->c.c_car;
					check_symbol(v);
/**/

	special_processed = FALSE;
	for (i = 0;  i < nreq;  i++)
		if (required[i].req_var == v) {
			required[i].req_spp = Ct;
			special_processed = TRUE;
		}
	if (special_processed)
		continue;
	/*  lex_special_bind(v);  */
	temporary = MMcons(v, Cnil);
	lex_env[0] = MMcons(temporary, lex_env[0]);

/**/
				}
			}
		}
	}

	narg = arg_top - base;
	if (narg != nreq) {
		vs_base = base;
		vs_top = arg_top;
		check_arg_failed(nreq);
	}
	for (i = 0;  i < nreq;  i++)
		bind_var(required[i].req_var,
			 base[i],
			 required[i].req_spp);
	if (type_of(body) != t_cons || body->c.c_car == form) {
		vs_reset;
		vs_head = body;
	} else {
		body = make_cons(form, body->c.c_cdr);
		vs_reset;
		vs_head = body;
	}
}

bind_var(var, val, spp)
object var, val, spp;
{
	vs_mark;

	switch (var->s.s_stype) {
	case stp_constant:
		FEerror("Cannot bind the constant ~S.", 1, var);

	case stp_special:
		bds_bind(var, val);
		break;

	default:
		if (spp != Cnil) {
			/*  lex_special_bind(var);  */
			temporary = MMcons(var, Cnil);
			lex_env[0] = MMcons(temporary, lex_env[0]);
			bds_bind(var, val);
		} else {
			/*  lex_local_bind(var, val);  */
			temporary = MMcons(val, Cnil);
			temporary = MMcons(var, temporary);
			lex_env[0] = MMcons(temporary, lex_env[0]);
		}
		break;
	}
	vs_reset;
}

illegal_lambda()
{
	FEerror("Illegal lambda expression.", 0);
}

/*
struct bind_temp {
	object	bt_var;
	object	bt_spp;
	object	bt_init;
	object	bt_aux;
};
*/

object
find_special(body, start, end)
object body;
struct bind_temp *start, *end;
{
	object form;
	object ds, vs, v;
	struct bind_temp *bt;
	bool special_processed;
	vs_mark;

	vs_push(Cnil);
	for (;  !endp(body);  body = body->c.c_cdr) {
		form = body->c.c_car;

		/*  MACRO EXPANSION  */
		form = macro_expand(form);
		vs_head = form;

		if (type_of(form) == t_string) {
			if (endp(body->c.c_cdr))
				break;
			continue;
		}
		if (type_of(form)!=t_cons || !isdeclare(form->c.c_car))
			break;
		for (ds = form->c.c_cdr; !endp(ds); ds = ds->c.c_cdr) {
			if (type_of(ds->c.c_car) != t_cons)
				illegal_declare(form);
			if (ds->c.c_car->c.c_car == Sspecial) {
				vs = ds->c.c_car->c.c_cdr;
				for (;  !endp(vs);  vs = vs->c.c_cdr) {
					v = vs->c.c_car;
					check_symbol(v);
/**/
	special_processed = FALSE;
	for (bt = start;  bt < end;  bt++)
		if (bt->bt_var == v) {
			bt->bt_spp = Ct;
			special_processed = TRUE;
		}
	if (special_processed)
		continue;
	/*  lex_special_bind(v);  */
	temporary = MMcons(v, Cnil);
	lex_env[0] = MMcons(temporary, lex_env[0]);
/**/
				}
			}
		}
	}

	if (body != Cnil && body->c.c_car != form)
		body = make_cons(form, body->c.c_cdr);
	vs_reset;
	return(body);
}

object
let_bind(body, start, end)
object body;
struct bind_temp *start, *end;
{
	struct bind_temp *bt;

	bds_check;
	vs_push(find_special(body, start, end));
	for (bt = start;  bt < end;  bt++) {
		eval_assign(bt->bt_init, bt->bt_init);
	}
	for (bt = start;  bt < end;  bt++) {
		bind_var(bt->bt_var, bt->bt_init, bt->bt_spp);
	}
	return(vs_pop);
}

object
letA_bind(body, start, end)
object body;
struct bind_temp *start, *end;
{
	struct bind_temp *bt;
	
	bds_check;
	vs_push(find_special(body, start, end));
	for (bt = start;  bt < end;  bt++) {
		eval_assign(bt->bt_init, bt->bt_init);
		bind_var(bt->bt_var, bt->bt_init, bt->bt_spp);
	}
	return(vs_pop);
}


#ifdef MV

#endif

#define	NOT_YET		10
#define	FOUND		11
#define	NOT_KEYWORD	1

parse_key(base, rest, allow_other_keys, n, va_alist)
object *base;
bool rest, allow_other_keys;
register int n;
va_dcl
{       va_list ap;
	object other_key = OBJNULL;
	int narg, error_flag = 0;
	object *v, k, *top;
	register int i;

	narg = vs_top - base;
	if (narg <= 0) {
		if (rest) {
			base[0] = Cnil;
			base++;
		}
		top = base + n;
		for (i = 0;  i < n;  i++) {
			base[i] = Cnil;
			top[i] = Cnil;
		}
		return;
	}
	if (narg%2 != 0)
		FEerror("Odd number of arguments for keywords.", 0);
	if (narg == 2) {
		k = base[0];
		if (!keywordp(k))
			FEerror("~S is not a keyword.", 1, k);
		if (k == Kallow_other_keys && base[1] != Cnil)
			allow_other_keys = TRUE;
		temporary = base[1];
		if (rest)
			base++;
		top = base + n;
		other_key = k;
		va_start(ap);
		for (i = 0;  i < n;  i++) {
		    
			if (va_arg(ap,object) == k) {
				base[i] = temporary;
				top[i] = Ct;
				other_key = OBJNULL;
			} else {
				base[i] = Cnil;
				top[i] = Cnil;
			}
		}
		va_end(ap);
		if (rest) {
			temporary = make_cons(temporary, Cnil);
			base[-1] = make_cons(k, temporary);
		}
		if (other_key != OBJNULL && !allow_other_keys)
			FEerror("The keyword ~S is not allowed.",1,other_key);
		return;
	}
	va_start(ap);
	for (i = 0;  i < n;  i++) {
		k = va_arg(ap,object);
		k->s.s_stype = NOT_YET;
		k->s.s_dbind = Cnil;
	}
	va_end(ap);
	for (v = base;  v < vs_top;  v += 2) {
		k = v[0];
		if (!keywordp(k)) {
			error_flag = NOT_KEYWORD;
			other_key = k;
			continue;
		}
		if (k->s.s_stype == NOT_YET) {
			k->s.s_dbind = v[1];
			k->s.s_stype = FOUND;
		} else if (k->s.s_stype == FOUND) {
			;
		} else if (other_key == OBJNULL)
			other_key = k;
		if (k == Kallow_other_keys && v[1] != Cnil)
			allow_other_keys = TRUE;
	}
	if (rest) {
		top = vs_top;
		vs_push(Cnil);
		base++;
		while (base < vs_top)
			stack_cons();
		vs_top = top;
	}
	top = base + n;
	va_start(ap);
	for (i = 0;  i < n;  i++) {
		k = va_arg(ap,object);
		base[i] = k->s.s_dbind;
		top[i] = k->s.s_stype == FOUND ? Ct : Cnil;
		k->s.s_dbind = k;
		k->s.s_stype = (short)stp_constant;
	}
	va_end(ap);
	if (error_flag == NOT_KEYWORD)
		FEerror("~S is not a keyword.", 1, other_key);
	if (other_key != OBJNULL && !allow_other_keys)
		FEerror("The keyword ~S is not allowed.", 1, other_key);
}

check_other_key(l, n, va_alist)
object l;
int n;
va_dcl
{
	va_list ap;
	object other_key = OBJNULL;
	object k;
	int i;
	bool allow_other_keys = FALSE;

	for (;  !endp(l);  l = l->c.c_cdr->c.c_cdr) {
		k = l->c.c_car;
		if (!keywordp(k))
			FEerror("~S is not a keyword.", 1, k);
		if (endp(l->c.c_cdr))
			FEerror("Odd number of arguments for keywords.", 0);
		if (k == Kallow_other_keys && l->c.c_cdr->c.c_car != Cnil) {
			allow_other_keys = TRUE;
		} else {register object *loc;
			char buf [100];
			bzero(buf,n);
			va_start(ap);
			for (i = 0;  i < n;  i++)
			  { if (va_arg(ap,object) == k &&
				buf[i] ==0) {buf[i]=1; break;}}
			va_end(ap);
			if (i >= n) other_key = k;
		}
	}
	if (other_key != OBJNULL && !allow_other_keys)
		FEerror("The keyword ~S is not allowed or is duplicated.",
			1, other_key);
}


struct key {short n,allow_other_keys;
	    iobject *defaults;
	    iobject keys[1];
	   };


object Cstd_key_defaults[15]={Cnil,Cnil,Cnil,Cnil,Cnil,Cnil,Cnil,
				Cnil,Cnil,Cnil,Cnil,Cnil,Cnil,Cnil,Cnil};

parse_key_new(n,base,keys,ap)
     int n;
     object *base;
     struct key *keys;
     va_list ap;
{object *new;
 COERCE_VA_LIST(new,ap,n);

 /* from here down identical to parse_key_rest */
 new = new + n ;
  {int j=keys->n;
   object *p= (object *)(keys->defaults);
   while (--j >=0) base[j]=p[j];
 }
 {if (n==0){ return;}
 {int allow = keys->allow_other_keys;
  object k;
 top:
  while (n>=2)
    {int i= keys->n;
     iobject *ke=keys->keys ;
     new = new -2;
     k = *new;
     while(--i >= 0)
       {if ((*(ke++)).o == k)
	  {base[i]= new[1];
	   n=n-2;
	   goto top;
	 }}
     /* the key is a new one */
     if (allow  )
       {
	 n=n-2;
      }
     else
       {int m = n -2;
	object *p = new;
	while (m >= 0)
	  {if (*p == Kallow_other_keys)
	     { allow = (p[1] !=Cnil) ; break;}
	   p -= 2;
	   m -= 2;}
	if (allow) n = n -2 ; else goto error;}
   }
  if (n!=0) FEerror("Odd number of keys");
  return 0;
 error:
  FEerror("Unrecognized key ~a",1,k);
}}}

parse_key_rest(rest,n,base,keys,ap)
     int n;
     object *base;
     struct key *keys;
     va_list ap;
     object rest;
{object *new;
 COERCE_VA_LIST(new,ap,n);

 /* copy the rest arg */
 {object *p = new;
  int m = n;
  while (--m >= 0)
    {rest->c.c_car = *p++;
     rest = rest->c.c_cdr;}}
    
 new = new + n ;
  {int j=keys->n;
   object *p= (object *)(keys->defaults);
   while (--j >=0) base[j]=p[j];
 }
 {if (n==0){ return;}
 {int allow = keys->allow_other_keys;
  object k;
 top:
  while (n>=2)
    {int i= keys->n;
     iobject *ke=keys->keys ;
     new = new -2;
     k = *new;
     while(--i >= 0)
       {if ((*(ke++)).o == k)
	  {base[i]= new[1];
	   n=n-2;
	   goto top;
	 }}
     /* the key is a new one */
     if (allow)
       {
	 n=n-2;
      }
     else
       {int m = n -2;
	object *p = new;
	while (m >= 0)
	  {if (*p == Kallow_other_keys)
	     { allow = (p[1] !=Cnil) ; break;}
	   p -= 2;
	   m -= 2;}
	if (allow) n = n -2 ; else goto error;}

   }
  if (n!=0) FEerror("Odd number of keys");
  return 0;
 error:
  FEerror("Unrecognized key ~a",1,k);
}}}

  
set_key_struct(ks,data)
     object data;
     struct key *ks;
{int i=ks->n;
 while (--i >=0)
   {ks->keys[i].o =   data->cfd.cfd_self[ ks->keys[i].i ];
    if (ks->defaults != (iobject *)Cstd_key_defaults)
     {int m=ks->defaults[i].i;
        ks->defaults[i].o=
	  (m==-2 ? Cnil :
	   m==-1 ? (object)0 :
	   data->cfd.cfd_self[m]);}
}}


init_bind()
{
	ANDoptional = make_ordinary("&OPTIONAL");
	enter_mark_origin(&ANDoptional);
	ANDrest = make_ordinary("&REST");
	enter_mark_origin(&ANDrest);
	ANDkey = make_ordinary("&KEY");
	enter_mark_origin(&ANDkey);
	ANDallow_other_keys = make_ordinary("&ALLOW-OTHER-KEYS");
	enter_mark_origin(&ANDallow_other_keys);
	ANDaux = make_ordinary("&AUX");
	enter_mark_origin(&ANDaux);

	make_constant("LAMBDA-LIST-KEYWORDS",
	make_cons(ANDoptional,
	make_cons(ANDrest,
	make_cons(ANDkey,
	make_cons(ANDallow_other_keys,
	make_cons(ANDaux,
	make_cons(make_ordinary("&WHOLE"),
	make_cons(make_ordinary("&ENVIRONMENT"),
	make_cons(make_ordinary("&BODY"), Cnil)))))))));

	make_constant("LAMBDA-PARAMETERS-LIMIT",
		      make_fixnum(64));

	Kallow_other_keys = make_keyword("ALLOW-OTHER-KEYS");

	temporary = Cnil;
	enter_mark_origin(&temporary);

	three_nils.nil3_self[0] = Cnil;
	three_nils.nil3_self[1] = Cnil;
	three_nils.nil3_self[2] = Cnil;

	six_nils.nil6_self[0] = Cnil;
	six_nils.nil6_self[1] = Cnil;
	six_nils.nil6_self[2] = Cnil;
	six_nils.nil6_self[3] = Cnil;
	six_nils.nil6_self[4] = Cnil;
	six_nils.nil6_self[5] = Cnil;
}

These are the contents of the former NiCE NeXT User Group NeXTSTEP/OpenStep software archive, currently hosted by Netfuture.ch.