Skip to content
Snippets Groups Projects
Commit 950d9f01 authored by rtoy's avatar rtoy
Browse files

Signal a program-error instead of error when the number of arguments

to a methood is wrong.  Bug found by ansi-tests.
parent 43025687
No related branches found
No related tags found
No related merge requests found
......@@ -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+))))
......
......@@ -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
......
......@@ -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:
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment