diff --git a/src/CHANGELOG b/src/CHANGELOG index a8af39cd1..2362e6029 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -1237,6 +1237,8 @@ ECLS 0.9 - The expansion of DO/DO* would not enclose the body in a TAGBODY. + - SLOT-EXISTS-P outputted OBJNULL when the slot did not exist. + * Errors of the interpreter: - CASE should use EQL to compare objects, not EQ. @@ -1409,6 +1411,9 @@ ECLS 0.9 a symbol with the name "SETF fname", the function definition is stored directly as a property list. + - In destructuring lambda lists, &WHOLE may be accompanied by a + destructuring form. + TODO: ===== diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 878a7b640..b73ae43f5 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -233,8 +233,6 @@ lambda_bind(int narg, cl_object lambda_list, cl_index sp) cl_object specials = lambda_list->bytecodes.specials; int i, n; bool check_remaining = TRUE; - bool allow_other_keys = FALSE; - bool allow_other_keys_found = FALSE; /* 1) REQUIRED ARGUMENTS: N var1 ... varN */ n = fix(next_code(data)); @@ -274,14 +272,18 @@ lambda_bind(int narg, cl_object lambda_list, cl_index sp) /* 4) ALLOW-OTHER-KEYS: { T | NIL | 0} */ if (data[0] == MAKE_FIXNUM(0)) { - data++; allow_other_keys = 0; - goto NO_KEYS; - } - allow_other_keys = allow_other_keys_found = !Null(next_code(data)); - - /* 5) KEYWORDS: N key1 var1 value1 flag1 ... keyN varN valueN flagN */ - n = fix(next_code(data)); - if (n != 0 || allow_other_keys) { + data++; + if (narg && check_remaining) + FEprogram_error("LAMBDA: Too many arguments to function ~S.", 1, + lambda_list->bytecodes.name); + } else { + /* + * Only when ALLOW-OTHER-KEYS /= 0, we process this: + * 5) KEYWORDS: N key1 var1 value1 flag1 ... keyN varN valueN flagN + */ + bool allow_other_keys = !Null(next_code(data)); + bool allow_other_keys_found = allow_other_keys; + int n = fix(next_code(data)); cl_object *keys; cl_object spp[n]; bool other_found = FALSE; @@ -329,11 +331,6 @@ lambda_bind(int narg, cl_object lambda_list, cl_index sp) lambda_bind_var(data[3],(spp[i] != OBJNULL)? Ct : Cnil,specials); } } - NO_KEYS: - if (narg && !allow_other_keys && check_remaining) - FEprogram_error("LAMBDA: Too many arguments to function ~S.", 1, - lambda_list->bytecodes.name); - /* Skip documentation and declarations */ return data; } diff --git a/src/clos/standard.lsp b/src/clos/standard.lsp index c53f20d6a..48bafbdaa 100644 --- a/src/clos/standard.lsp +++ b/src/clos/standard.lsp @@ -138,7 +138,7 @@ (defmethod slot-exists-p ((instance standard-object) slot-name) (let ((class (si:instance-class instance))) (declare (type standard-class class)) - (slot-index slot-name (slot-index-table class)))) + (gethash slot-name (slot-index-table class) nil))) (defmethod slot-makunbound ((instance standard-object) slot-name) (let* ((class (si:instance-class instance)) diff --git a/src/cmp/cmpdefs.lsp b/src/cmp/cmpdefs.lsp index 25d521a97..c08fe693e 100644 --- a/src/cmp/cmpdefs.lsp +++ b/src/cmp/cmpdefs.lsp @@ -113,6 +113,7 @@ (env 0) ;;; Size of env of closure. closure ;;; During Pass2, T if env is used inside the function var ;;; the variable holding the funob + description ;;; Text for the object, in case NAME == NIL. ) ;(deftype fun () '(satisfies fun-p)) diff --git a/src/cmp/cmpspecial.lsp b/src/cmp/cmpspecial.lsp index 575044c48..ce6c5280e 100644 --- a/src/cmp/cmpspecial.lsp +++ b/src/cmp/cmpspecial.lsp @@ -111,6 +111,7 @@ (info (second funob)) (closure (closure-p funob)) (fun (make-fun :name NIL + :description name :cfun (next-cfun) :closure closure))) (if closure diff --git a/src/cmp/cmptop.lsp b/src/cmp/cmptop.lsp index a8dfeac6e..75b8d0b83 100644 --- a/src/cmp/cmptop.lsp +++ b/src/cmp/cmptop.lsp @@ -757,7 +757,7 @@ (fourth lambda-list)))) (declare (fixnum level nenvs)) (wt-comment (if (fun-closure fun) "closure " "local function ") - (or (fun-name fun) 'CLOSURE)) + (or (fun-name fun) (fun-description fun) 'CLOSURE)) (wt-h "static cl_object LC" (fun-cfun fun) "(") (wt-nl1 "static cl_object LC" (fun-cfun fun) "(") (wt-h1 "int") diff --git a/src/lsp/defmacro.lsp b/src/lsp/defmacro.lsp index d381ec04c..ebe4185d5 100644 --- a/src/lsp/defmacro.lsp +++ b/src/lsp/defmacro.lsp @@ -152,10 +152,15 @@ (push (if init (list v init) v) *dl*)) ((atom v) (error "destructure: ~A is not a list nor a symbol" v)) - ((eq (car v) '&whole) - (let ((temp (cadr v))) - (push (if init (list temp init) temp) *dl*) - (dm-vl (cddr v) temp nil))) + ((eq (first v) '&whole) + (let ((whole-var (second v))) + (if (listp whole-var) + (let ((new-whole (gensym))) + (dm-v new-whole init) + (dm-vl whole-var new-whole nil) + (setq whole-var new-whole)) + (dm-v whole-var init)) + (dm-vl (cddr v) whole-var nil))) (t (let ((temp (gensym))) (push (if init (list temp init) temp) *dl*) @@ -183,19 +188,22 @@ (3 (list 'CDDDR v)) )))) - (let ((whole nil)) + (let* ((whole nil) + (*dl* nil) + (*key-check* nil) + (*arg-check* nil)) (cond ((listp vl) (when (eq (first vl) '&whole) - (setq whole (second vl) vl (cddr vl)))) - ((symbolp vl) (setq vl (list '&rest vl))) + (setq whole (second vl) vl (cddr vl)) + (when (listp whole) + (let ((new-whole (gensym))) + (dm-vl whole new-whole nil) + (setq whole new-whole))))) + ((symbolp vl) + (setq vl (list '&rest vl))) (t (error "The destructuring-lambda-list ~s is not a list." vl))) - (when (not whole) - (setq whole (gensym))) - (let* ((*dl* nil) - (*key-check* nil) - (*arg-check* nil) - (ppn (dm-vl vl whole macro))) - (values ppn whole (nreverse *dl*) *key-check* *arg-check*))))) + (if (null whole) (setq whole (gensym))) + (values (dm-vl vl whole macro) whole (nreverse *dl*) *key-check* *arg-check*)))) ;;; valid lambda-list to DEFMACRO is: ;;;