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.