From: William Harold Newman Date: Sun, 13 Jan 2002 23:33:01 +0000 (+0000) Subject: 0.pre7.128: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=a92c91a4fdcdcf1c96b33339c1ef077243183187;p=sbcl.git 0.pre7.128: MNA "patch for bug 105 and some other cleanups" (sbcl-devel 2002-01-13)... ...fixed bug 105: made (DESCRIBE 'STREAM-READ-CHAR) work right even when there're no methods on the GF yet ...tweaked format of DESCRIBE of methods, simplifying GENERIC-FUNCTION-PRETTY-ARGLIST stuff ...tidied up tests/ stuff, deleting temporary files after use ...deleted BUGS entries (105 entry, and stale 99 entry too) tweaked MNA patch... ...explicitly saying "It has no methods." for bare GF --- diff --git a/BUGS b/BUGS index e5fb392..51b93a6 100644 --- a/BUGS +++ b/BUGS @@ -751,18 +751,6 @@ Error in function C::GET-LAMBDA-TO-COMPILE: ;; no problem, can just use the ordinary expansion `(function (setf ,place-function-name)))) -99: - DESCRIBE interacts poorly with *PRINT-CIRCLE*, e.g. the output from - (let ((*print-circle* t)) (describe (make-hash-table))) - is weird, - # is an . (EQL) - Its SIZE is 16. - Its REHASH-SIZE is 1.5. Its REHASH-THRESHOLD is . (1.0) - It holds 0 key/value pairs. - where the ". (EQL)" and ". (1.0)" substrings are screwups. - (This is likely a pretty-printer problem which happens to - be exercised by DESCRIBE, not actually a DESCRIBE problem.) - 100: There's apparently a bug in CEILING optimization which caused Douglas Crosher to patch the CMU CL version. Martin Atzmueller @@ -793,9 +781,6 @@ Error in function C::GET-LAMBDA-TO-COMPILE: /usr/stuff/sbcl/src/code/host-alieneval.lisp Created: Monday, March 12, 2001 07:47:43 AM CST -105: - (DESCRIBE 'STREAM-READ-BYTE) - 106: (reported by Eric Marsden on cmucl-imp 2001-06-15) (and APD pointed out on sbcl-devel 2001-12-29 that it's the same diff --git a/CREDITS b/CREDITS index 61c2aa4..f4e5aa0 100644 --- a/CREDITS +++ b/CREDITS @@ -580,5 +580,6 @@ DTC Douglas Crosher APD Alexey Dejneka NJF Nathan Froyd RAM Robert MacLachlan -WHN William Newman +WHN William ("Bill") Newman +CSR Christopher Rhodes PVE Peter Van Eynde diff --git a/TODO b/TODO index a314c89..2eb9781 100644 --- a/TODO +++ b/TODO @@ -16,7 +16,7 @@ for 0.7.0: for early 0.7.x: * patches postponed until after 0.7.0: - ** Christophe Rhodes "rough patch to fix bug 106" 2001-10-28 + ** CSR "rough patch to fix bug 106" 2001-10-28 ** Alexey Dejneka "bug 111" 2001-12-30 * building with CLISP (or explaining why not). This will likely involve a rearrangement of the build system so that it never renames diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index 4388d94..831d8a5 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -803,10 +803,7 @@ :reader gf-arg-info) (dfun-state :initform () - :accessor gf-dfun-state) - (pretty-arglist - :initform () - :accessor gf-pretty-arglist)) + :accessor gf-dfun-state)) (:metaclass funcallable-standard-class) (:default-initargs :method-class *the-class-standard-method* :method-combination *standard-method-combination*)) diff --git a/src/pcl/describe.lisp b/src/pcl/describe.lisp index b02ccb0..6efcba5 100644 --- a/src/pcl/describe.lisp +++ b/src/pcl/describe.lisp @@ -88,17 +88,22 @@ (defvar *describe-metaobjects-as-objects-p* nil) (defmethod describe-object ((fun standard-generic-function) stream) - (format stream "~A is a generic function.~%" fun) + (format stream "~&~A is a generic function.~%" fun) (format stream "Its arguments are:~% ~S~%" (generic-function-pretty-arglist fun)) - (format stream "Its methods are:") - (dolist (method (generic-function-methods fun)) - (format stream "~2% ~{~S ~}~:S =>~%" - (method-qualifiers method) - (unparse-specializers method)) - (describe-object (or (method-fast-function method) - (method-function method)) - stream)) + (let ((methods (generic-function-methods fun))) + (if (null methods) + (format stream "It has no methods.~%") + (let ((gf-name (generic-function-name fun))) + (format stream "Its methods are:") + (dolist (method methods) + (format stream "~2% (~A ~{~S ~}~:S) =>~%" + gf-name + (method-qualifiers method) + (unparse-specializers method)) + (describe-object (or (method-fast-function method) + (method-function method)) + stream))))) (when *describe-metaobjects-as-objects-p* (call-next-method))) diff --git a/src/pcl/generic-functions.lisp b/src/pcl/generic-functions.lisp index 59330a5..433e8a4 100644 --- a/src/pcl/generic-functions.lisp +++ b/src/pcl/generic-functions.lisp @@ -96,8 +96,6 @@ (defgeneric gf-dfun-state (standard-generic-function)) -(defgeneric gf-pretty-arglist (standard-generic-function)) - (defgeneric long-method-combination-function (long-method-combination)) (defgeneric method-combination-documentation (standard-method-combination)) @@ -183,8 +181,6 @@ (defgeneric (setf gf-dfun-state) (new-value standard-generic-function)) -(defgeneric (setf gf-pretty-arglist) (new-value standard-generic-function)) - (defgeneric (setf method-generic-function) (new-value standard-method)) (defgeneric (setf object-plist) (new-value plist-mixin)) diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index 40d501e..9f04af7 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -1462,31 +1462,37 @@ ;;; into account at all yet. (defmethod generic-function-pretty-arglist ((generic-function standard-generic-function)) - (let ((methods (generic-function-methods generic-function)) - (arglist ())) - (when methods - (multiple-value-bind (required optional rest key allow-other-keys) - (method-pretty-arglist (car methods)) - (dolist (m (cdr methods)) - (multiple-value-bind (method-key-keywords - method-allow-other-keys - method-key) - (function-keywords m) - ;; we've modified function-keywords to return what we want as - ;; the third value, no other change here. - (declare (ignore method-key-keywords)) - (setq key (union key method-key)) - (setq allow-other-keys (or allow-other-keys - method-allow-other-keys)))) - (when allow-other-keys - (setq arglist '(&allow-other-keys))) - (when key - (setq arglist (nconc (list '&key) key arglist))) - (when rest - (setq arglist (nconc (list '&rest rest) arglist))) - (when optional - (setq arglist (nconc (list '&optional) optional arglist))) - (nconc required arglist))))) + (let ((methods (generic-function-methods generic-function))) + (if methods + (let ((arglist ())) + ;; arglist is constructed from the GF's methods - maybe with + ;; keys and rest stuff added + (multiple-value-bind (required optional rest key allow-other-keys) + (method-pretty-arglist (car methods)) + (dolist (m (cdr methods)) + (multiple-value-bind (method-key-keywords + method-allow-other-keys + method-key) + (function-keywords m) + ;; we've modified function-keywords to return what we want as + ;; the third value, no other change here. + (declare (ignore method-key-keywords)) + (setq key (union key method-key)) + (setq allow-other-keys (or allow-other-keys + method-allow-other-keys)))) + (when allow-other-keys + (setq arglist '(&allow-other-keys))) + (when key + (setq arglist (nconc (list '&key) key arglist))) + (when rest + (setq arglist (nconc (list '&rest rest) arglist))) + (when optional + (setq arglist (nconc (list '&optional) optional arglist))) + (nconc required arglist))) + ;; otherwise we take the lambda-list from the GF directly, with no + ;; other 'keys' added ... + (let ((lambda-list (generic-function-lambda-list generic-function))) + lambda-list)))) (defmethod method-pretty-arglist ((method standard-method)) (let ((required ()) diff --git a/tests/clos.test.sh b/tests/clos.test.sh index 407088e..41d7f88 100644 --- a/tests/clos.test.sh +++ b/tests/clos.test.sh @@ -45,7 +45,9 @@ EOF fi } -tmpfilename="clos-test-$$-tmp.lisp" +base_tmpfilename="clos-test-$$-tmp" +tmpfilename="$base_tmpfilename.lisp" +compiled_tmpfilename="$base_tmpfilename.fasl" # This should fail, but didn't until sbcl-0.6.12.7, with Martin # Atzmueller's port of Pierre Mai's fixes. @@ -83,6 +85,7 @@ EOF expect_load_error $tmpfilename rm $tmpfilename +rm $compiled_tmpfilename # success exit 104 diff --git a/tests/run-tests.sh b/tests/run-tests.sh index 6fe86dd..a4eacb6 100644 --- a/tests/run-tests.sh +++ b/tests/run-tests.sh @@ -99,7 +99,11 @@ for f in *.pure-cload.lisp; do echo //running $f test $SBCL <