/*
 Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa

This file is part of GNU Common Lisp, herein referred to as GCL

GCL is free software; you can redistribute it and/or modify it under
the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.

GCL is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
License for more details.

You should have received a copy of the GNU Library General Public License 
along with GCL; see the file COPYING.  If not, write to the Free Software
Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.

*/

/*
	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;
};





#define	isdeclare(x)	((x) == sLdeclare)

lambda_bind(arg_top)
object *arg_top;
{
  
 	object endp_temp,temporary;
	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_L;
		}
		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_L;
			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_L;
	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_L;
			check_var(x);
			vs_push(intern(x, keyword_package));
			vs_push(x);
			*(struct nil6 *)vs_top = six_nils;
			vs_top += 6;
		}
	}

AUX_L:
	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 == sLspecial) {
				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);  */
	lex_env[0] = MMcons(MMcons(v, Cnil), 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] == sKallow_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 == sLspecial) {
				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;
{ 
        object temporary;
	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 temporary;
 	object endp_temp;
	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 == sLspecial) {
				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
{ 
        object temporary;
	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 == sKallow_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 == sKallow_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
{
 	object endp_temp;
	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 == sKallow_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 == sKallow_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",0);
  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 == sKallow_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",0);
  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]);}
}}

#undef AUX

DEF_ORDINARY("ALLOW-OTHER-KEYS",sKallow_other_keys,KEYWORD,"");



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));



	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;
}
