In destructuring lambda lists, &WHOLE may be accompanied by a

destructuring form.

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:
 =====
 

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

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

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

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

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

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