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