From 950d9f014706440acb3f5b455bed89c07bdbbbe9 Mon Sep 17 00:00:00 2001
From: rtoy <rtoy>
Date: Thu, 18 Aug 2005 16:55:01 +0000
Subject: [PATCH] Signal a program-error instead of error when the number of
 arguments to a methood is wrong.  Bug found by ansi-tests.

---
 pcl/boot.lisp | 14 +++++++-------
 pcl/dfun.lisp |  7 ++++++-
 pcl/low.lisp  |  7 ++++++-
 3 files changed, 19 insertions(+), 9 deletions(-)

diff --git a/pcl/boot.lisp b/pcl/boot.lisp
index 4cf83757b..970b315f7 100644
--- a/pcl/boot.lisp
+++ b/pcl/boot.lisp
@@ -25,7 +25,7 @@
 ;;; *************************************************************************
 
 (file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/boot.lisp,v 1.72 2004/04/06 20:44:02 rtoy Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/boot.lisp,v 1.73 2005/08/18 16:55:00 rtoy Rel $")
 
 (in-package :pcl)
 
@@ -910,15 +910,15 @@ work during bootstrapping.
 	   (cond ((null args)
 		  (if (eql nreq 0) 
 		      (invoke-fast-method-call emf)
-		      (internal-error "Wrong number of args.")))
+		      (internal-program-error emf "Wrong number of args.")))
 		 ((null (cdr args))
 		  (if (eql nreq 1) 
 		      (invoke-fast-method-call emf (car args))
-		      (internal-error "Wrong number of args.")))
+		      (internal-program-error emf "Wrong number of args.")))
 		 ((null (cddr args))
 		  (if (eql nreq 2) 
 		      (invoke-fast-method-call emf (car args) (cadr args))
-		      (internal-error "Wrong number of args.")))
+		      (internal-program-error emf "Wrong number of args.")))
 		 (t
 		  (apply (fast-method-call-function emf)
 			 (fast-method-call-pv-cell emf)
@@ -930,7 +930,7 @@ work during bootstrapping.
 	    (method-call-call-method-args emf)))
     (fixnum 
      (cond ((null args)
-	    (internal-error "1 or 2 args expected."))
+	    (internal-program-error emf "1 or 2 args expected."))
 	   ((null (cdr args))
 	    (let ((value (%slot-ref (get-slots (car args)) emf)))
 	      (if (eq value +slot-unbound+)
@@ -940,10 +940,10 @@ work during bootstrapping.
 	    (setf (%slot-ref (get-slots (cadr args)) emf)
 		  (car args)))
 	   (t
-	    (internal-error "1 or 2 args expected."))))
+	    (internal-program-error emf "1 or 2 args expected."))))
     (fast-instance-boundp
      (if (or (null args) (cdr args))
-	 (internal-error "1 arg expected.")
+	 (internal-program-error emf "1 arg expected.")
 	 (not (eq (%slot-ref (get-slots (car args)) 
 			     (fast-instance-boundp-index emf))
 		  +slot-unbound+))))
diff --git a/pcl/dfun.lisp b/pcl/dfun.lisp
index 33097e7c3..cc7ec2c0e 100644
--- a/pcl/dfun.lisp
+++ b/pcl/dfun.lisp
@@ -25,7 +25,7 @@
 ;;; *************************************************************************
 
 (file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dfun.lisp,v 1.37 2005/06/15 17:30:59 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dfun.lisp,v 1.38 2005/08/18 16:55:00 rtoy Exp $")
 
 (in-package :pcl)
 
@@ -1127,8 +1127,13 @@ And so, we are saved.
     (declare (ignore nreq applyp nkeys))
     (with-dfun-wrappers (args metatypes)
       (dfun-wrappers invalid-wrapper-p wrappers classes types)
+      #+nil
       (error "~@<The function ~S requires at least ~D arguments.~@:>"
 	     gf (length metatypes))
+      (error 'kernel:simple-program-error
+	     :name gf
+	     :format-control "~<The function ~S requires at least ~D arguments.~@:>"
+	     :format-arguments (list gf (length metatypes)))
       (multiple-value-bind (emf methods accessor-type index)
 	  (cache-miss-values-internal gf arg-info wrappers classes types state)
 	(values emf methods
diff --git a/pcl/low.lisp b/pcl/low.lisp
index e743b216c..0126029be 100644
--- a/pcl/low.lisp
+++ b/pcl/low.lisp
@@ -26,7 +26,7 @@
 ;;;
 
 (file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/low.lisp,v 1.32 2003/05/26 16:03:08 gerd Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/low.lisp,v 1.33 2005/08/18 16:55:01 rtoy Exp $")
 
 ;;; 
 ;;; This file contains optimized low-level constructs for PCL.
@@ -420,6 +420,11 @@ the compiler as completely as possible.  Currently this means that
   (error (format nil "~~@<Internal error: ~?~~@:>"
 		 format-control format-args)))
 
+(defun internal-program-error (name &rest args)
+  (error 'kernel:simple-program-error
+	 :function-name name
+	 :format-control (car args)
+	 :format-arguments (list (cdr args))))
 
 ;;;; Structure-instance stuff:
 
-- 
GitLab