[armedbear-cvs] r12395 - in trunk/abcl: src/org/armedbear/lisp test/lisp/abcl
Ville Voutilainen
vvoutilainen at common-lisp.net
Sun Jan 24 15:24:21 UTC 2010
Author: vvoutilainen
Date: Sun Jan 24 10:24:18 2010
New Revision: 12395
Log:
Some patches to improve arglist display in Slime.
Patch by Matthias Hölzl.
Added:
trunk/abcl/test/lisp/abcl/mop-tests-setup.lisp
trunk/abcl/test/lisp/abcl/mop-tests.lisp
Modified:
trunk/abcl/src/org/armedbear/lisp/autoloads.lisp
trunk/abcl/src/org/armedbear/lisp/clos.lisp
trunk/abcl/test/lisp/abcl/package.lisp
Modified: trunk/abcl/src/org/armedbear/lisp/autoloads.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/autoloads.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/autoloads.lisp Sun Jan 24 10:24:18 2010
@@ -207,8 +207,12 @@
(autoload 'disassemble)
(in-package "MOP")
-(export '(class-precedence-list class-slots slot-definition-name))
-(autoload '(class-precedence-list class-slots slot-definition-name) "clos")
+(export '(class-precedence-list class-slots slot-definition-allocation
+ slot-definition-initargs slot-definition-initform
+ slot-definition-initfunction slot-definition-name
+ compute-applicable-methods
+ compute-applicable-methods-using-classes))
+(autoload '(class-precedence-list class-slots) "clos")
;; Java interface.
Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/clos.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/clos.lisp Sun Jan 24 10:24:18 2010
@@ -51,14 +51,11 @@
(in-package #:mop)
-(export '(class-precedence-list class-slots slot-definition-name))
+(export '(class-precedence-list class-slots))
(defun class-slots (class)
(%class-slots class))
-(defun slot-definition-name (slot-definition)
- (%slot-definition-name slot-definition))
-
(defmacro push-on-end (value location)
`(setf ,location (nconc ,location (list ,value))))
@@ -1318,6 +1315,17 @@
code))
+(defun sort-methods (methods gf required-classes)
+ (if (or (null methods) (null (%cdr methods)))
+ methods
+ (sort methods
+ (if (eq (class-of gf) (find-class 'standard-generic-function))
+ #'(lambda (m1 m2)
+ (std-method-more-specific-p m1 m2 required-classes
+ (generic-function-argument-precedence-order gf)))
+ #'(lambda (m1 m2)
+ (method-more-specific-p gf m1 m2 required-classes))))))
+
(defun method-applicable-p (method args)
(do* ((specializers (%method-specializers method) (cdr specializers))
(args args (cdr args)))
@@ -1335,23 +1343,31 @@
(dolist (method (generic-function-methods gf))
(when (method-applicable-p method args)
(push method methods)))
- (if (or (null methods) (null (%cdr methods)))
- methods
- (sort methods
- (if (eq (class-of gf) (find-class 'standard-generic-function))
- #'(lambda (m1 m2)
- (std-method-more-specific-p m1 m2 required-classes
- (generic-function-argument-precedence-order gf)))
- #'(lambda (m1 m2)
- (method-more-specific-p gf m1 m2 required-classes)))))))
+ (sort-methods methods gf required-classes)))
-(defun method-applicable-p-using-classes (method classes)
+;;; METHOD-APPLICABLE-USING-CLASSES-P
+;;;
+;;; If the first return value is T, METHOD is definitely applicable to
+;;; arguments that are instances of CLASSES. If the first value is
+;;; NIL and the second value is T, METHOD is definitely not applicable
+;;; to arguments that are instances of CLASSES; if the second value is
+;;; NIL the applicability of METHOD cannot be determined by inspecting
+;;; the classes of its arguments only.
+;;;
+(defun method-applicable-using-classes-p (method classes)
(do* ((specializers (%method-specializers method) (cdr specializers))
- (classes classes (cdr classes)))
- ((null specializers) t)
+ (classes classes (cdr classes))
+ (knownp t))
+ ((null specializers)
+ (if knownp (values t t) (values nil nil)))
(let ((specializer (car specializers)))
- (unless (subclassp (car classes) specializer)
- (return nil)))))
+ (if (typep specializer 'eql-specializer)
+ (if (eql (class-of (eql-specializer-object specializer))
+ (car classes))
+ (setf knownp nil)
+ (return (values nil t)))
+ (unless (subclassp (car classes) specializer)
+ (return (values nil t)))))))
(defun slow-method-lookup (gf args)
(let ((applicable-methods (%compute-applicable-methods gf args)))
@@ -1879,6 +1895,30 @@
(defmethod (setf documentation) (new-value (x package) (doc-type (eql 't)))
(%set-documentation x doc-type new-value))
+;;; Applicable methods
+
+(defgeneric compute-applicable-methods (gf args)
+ (:method ((gf standard-generic-function) args)
+ (%compute-applicable-methods gf args)))
+
+(defgeneric compute-applicable-methods-using-classes (gf classes)
+ (:method ((gf standard-generic-function) classes)
+ (let ((methods '()))
+ (dolist (method (generic-function-methods gf))
+ (multiple-value-bind (applicable knownp)
+ (method-applicable-using-classes-p method classes)
+ (cond (applicable
+ (push method methods))
+ ((not knownp)
+ (return-from compute-applicable-methods-using-classes
+ (values nil nil))))))
+ (values (sort-methods methods gf classes)
+ t))))
+
+(export '(compute-applicable-methods
+ compute-applicable-methods-using-classes))
+
+
;;; Slot access
(defun set-slot-value-using-class (new-value class instance slot-name)
@@ -2197,6 +2237,37 @@
(defmethod compute-applicable-methods ((gf standard-generic-function) args)
(%compute-applicable-methods gf args))
+;;; Slot definition accessors
+
+(export '(slot-definition-allocation
+ slot-definition-initargs
+ slot-definition-initform
+ slot-definition-initfunction
+ slot-definition-name))
+
+(defgeneric slot-definition-allocation (slot-definition)
+ (:method ((slot-definition slot-definition))
+ (%slot-definition-allocation slot-definition)))
+
+(defgeneric slot-definition-initargs (slot-definition)
+ (:method ((slot-definition slot-definition))
+ (%slot-definition-initargs slot-definition)))
+
+(defgeneric slot-definition-initform (slot-definition)
+ (:method ((slot-definition slot-definition))
+ (%slot-definition-initform slot-definition)))
+
+(defgeneric slot-definition-initfunction (slot-definition)
+ (:method ((slot-definition slot-definition))
+ (%slot-definition-initfunction slot-definition)))
+
+(defgeneric slot-definition-name (slot-definition)
+ (:method ((slot-definition slot-definition))
+ (%slot-definition-name slot-definition)))
+
+;;; No %slot-definition-type.
+
+
;;; Conditions.
(defmacro define-condition (name (&rest parent-types) (&rest slot-specs) &body options)
Added: trunk/abcl/test/lisp/abcl/mop-tests-setup.lisp
==============================================================================
--- (empty file)
+++ trunk/abcl/test/lisp/abcl/mop-tests-setup.lisp Sun Jan 24 10:24:18 2010
@@ -0,0 +1,82 @@
+;;; mop-tests-setup.lisp
+;;;
+;;; Copyright (C) 2010 Matthias Hölzl
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License
+;;; as published by the Free Software Foundation; either version 2
+;;; of the License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+;;; Definitions used by mop-tests.lisp. Split into a separate file to
+;;; avoid problems with the functions not being available during test
+;;; runs.
+
+(in-package #:abcl.test.lisp)
+
+(defun find-classes (&rest args)
+ (mapcar #'find-class args))
+
+(defgeneric mop-test.foo (x y)
+ (:method (x y)
+ (list :object x :object y))
+ (:method ((x fixnum) y)
+ (list :fixnum x :object y))
+ (:method ((x fixnum) (y fixnum))
+ (list :fixnum x :fixnum y)))
+
+(defun find-foo (&rest specializers)
+ (find-method #'mop-test.foo nil
+ (mapcar #'find-class specializers)))
+
+(defgeneric mop-test.bar (x y)
+ (:method (x y)
+ (list :object x :object y))
+ (:method ((x fixnum) y)
+ (list :fixnum x :object y))
+ (:method ((x fixnum) (y fixnum))
+ (list :fixnum x :fixnum y))
+ (:method ((x fixnum) (y string))
+ (list :fixnum x :fixnum y))
+ (:method ((x fixnum) (y (eql 123)))
+ (list :fixnum x :123 y)))
+
+(defun find-bar (&rest specializers)
+ (find-method #'mop-test.bar nil
+ (mapcar #'find-class specializers)))
+
+(defgeneric mop-test.baz (x y)
+ (:method (x y)
+ (list :object x :object y))
+ (:method ((x fixnum) y)
+ (list :fixnum x :object y))
+ (:method ((x fixnum) (y fixnum))
+ (list :fixnum x :fixnum y))
+ (:method ((x (eql 234)) (y fixnum))
+ (list :234 x :fixnum y)))
+
+(defun find-baz (&rest specializers)
+ (find-method #'mop-test.baz nil
+ (mapcar #'find-class specializers)))
+
+(defgeneric mop-test.quux (x y)
+ (:method (x y)
+ (list :object x :object y))
+ (:method ((x fixnum) y)
+ (list :fixnum x :object y))
+ (:method ((x fixnum) (y fixnum))
+ (list :fixnum x :fixnum y))
+ (:method ((x (eql :foo)) (y fixnum))
+ (list :foo x :fixnum y)))
+
+(defun find-quux (&rest specializers)
+ (find-method #'mop-test.quux nil
+ (mapcar #'find-class specializers)))
Added: trunk/abcl/test/lisp/abcl/mop-tests.lisp
==============================================================================
--- (empty file)
+++ trunk/abcl/test/lisp/abcl/mop-tests.lisp Sun Jan 24 10:24:18 2010
@@ -0,0 +1,307 @@
+;;; mop-tests.lisp
+;;;
+;;; Copyright (C) 2010 Matthias Hölzl
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License
+;;; as published by the Free Software Foundation; either version 2
+;;; of the License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+
+(load (merge-pathnames "test-utilities.lisp" *load-truename*))
+(compile-file (merge-pathnames "mop-tests-setup.lisp" *load-truename*))
+(load (merge-pathnames "mop-tests-setup" *load-truename*))
+
+(in-package #:abcl.test.lisp)
+
+(deftest compute-applicable-methods.foo.1
+ (equalp
+ (mop:compute-applicable-methods #'mop-test.foo '(111 222))
+ (mop:compute-applicable-methods-using-classes
+ #'mop-test.foo (find-classes 'fixnum 'fixnum)))
+ t)
+
+(deftest compute-applicable-methods.foo.2
+ (equalp
+ (mop:compute-applicable-methods #'mop-test.foo '(x y))
+ (mop:compute-applicable-methods-using-classes
+ #'mop-test.foo (find-classes 'symbol 'symbol)))
+ t)
+
+(deftest compute-applicable-methods.foo.3
+ (equalp
+ (mop:compute-applicable-methods #'mop-test.foo '(111 y))
+ (mop:compute-applicable-methods-using-classes
+ #'mop-test.foo (find-classes 'fixnum 'symbol)))
+ t)
+
+(deftest compute-applicable-methods.foo.4
+ (equalp
+ (mop:compute-applicable-methods #'mop-test.foo '(x 111))
+ (mop:compute-applicable-methods-using-classes
+ #'mop-test.foo (find-classes 'symbol 'fixnum)))
+ t)
+
+(deftest compute-applicable-methods.foo.5
+ (equalp
+ (mop:compute-applicable-methods #'mop-test.foo '(111 "asdf"))
+ (mop:compute-applicable-methods-using-classes
+ #'mop-test.foo (find-classes 'fixnum 'simple-base-string)))
+ t)
+
+(deftest compute-applicable-methods.foo.6
+ (equalp (mop:compute-applicable-methods #'mop-test.foo '(111 222))
+ (list (find-foo 'fixnum 'fixnum)
+ (find-foo 'fixnum t)
+ (find-foo t t)))
+ t)
+
+(deftest compute-applicable-methods.foo.7
+ (equalp (mop:compute-applicable-methods #'mop-test.foo '(111 x))
+ (list (find-foo 'fixnum t)
+ (find-foo t t)))
+ t)
+
+(deftest compute-applicable-methods.foo.8
+ (equalp (mop:compute-applicable-methods #'mop-test.foo '(x 222))
+ (list (find-foo t t)))
+ t)
+
+
+(deftest compute-applicable-methods.bar.1
+ (equalp
+ (mop:compute-applicable-methods #'mop-test.bar '(111 222))
+ (mop:compute-applicable-methods-using-classes
+ #'mop-test.bar (find-classes 'fixnum 'fixnum)))
+ ;;; Bar with two fixnums might select EQL specializer for second
+ ;;; argument.
+ nil)
+
+(deftest compute-applicable-methods.bar.1a
+ (equalp
+ (mop:compute-applicable-methods #'mop-test.bar '(111 222))
+ (list (find-bar 'fixnum 'fixnum)
+ (find-bar 'fixnum t)
+ (find-bar t t)))
+ t)
+
+(deftest compute-applicable-methods.bar.1b
+ (equalp
+ (mop:compute-applicable-methods #'mop-test.bar '(111 123))
+ (list (find-method #'mop-test.bar nil (list (find-class 'fixnum) '(eql 123)))
+ (find-bar 'fixnum 'fixnum)
+ (find-bar 'fixnum t)
+ (find-bar t t)))
+ t)
+
+(deftest compute-applicable-methods.bar.1c
+ (mop:compute-applicable-methods-using-classes
+ #'mop-test.bar (find-classes 'fixnum 'fixnum))
+ nil
+ nil)
+
+(deftest compute-applicable-methods.bar.2
+ (equalp
+ (mop:compute-applicable-methods #'mop-test.bar '(x y))
+ (mop:compute-applicable-methods-using-classes
+ #'mop-test.bar (find-classes 'symbol 'symbol)))
+ t)
+
+(deftest compute-applicable-methods.bar.2a
+ (equalp
+ (mop:compute-applicable-methods #'mop-test.bar '(x y))
+ (list (find-bar t t)))
+ t)
+
+(deftest compute-applicable-methods.bar.3
+ (equalp
+ (mop:compute-applicable-methods #'mop-test.bar '(111 y))
+ (mop:compute-applicable-methods-using-classes
+ #'mop-test.bar (find-classes 'fixnum 'symbol)))
+ t)
+
+(deftest compute-applicable-methods.bar.3a
+ (equalp
+ (mop:compute-applicable-methods #'mop-test.bar '(111 y))
+ (list (find-bar 'fixnum t)
+ (find-bar t t)))
+ t)
+
+(deftest compute-applicable-methods.bar.4
+ (equalp
+ (mop:compute-applicable-methods #'mop-test.bar '(x 111))
+ (mop:compute-applicable-methods-using-classes
+ #'mop-test.bar (find-classes 'symbol 'fixnum)))
+ t)
+
+(deftest compute-applicable-methods.bar.4a
+ (equalp
+ (mop:compute-applicable-methods #'mop-test.bar '(x 111))
+ (list (find-bar t t)))
+ t)
+
+(deftest compute-applicable-methods.bar.5
+ (equalp
+ (mop:compute-applicable-methods #'mop-test.bar '(111 "asdf"))
+ (mop:compute-applicable-methods-using-classes
+ #'mop-test.bar (find-classes 'fixnum 'simple-base-string)))
+ t)
+
+(deftest compute-applicable-methods.bar.5a
+ (equalp
+ (mop:compute-applicable-methods #'mop-test.bar '(111 "asdf"))
+ (list (find-bar 'fixnum 'string)
+ (find-bar 'fixnum t)
+ (find-bar t t)))
+ t)
+
+
+(deftest compute-applicable-methods.baz.1
+ (equalp
+ (mop:compute-applicable-methods #'mop-test.baz '(111 222))
+ (mop:compute-applicable-methods-using-classes
+ #'mop-test.baz (find-classes 'fixnum 'fixnum)))
+ ;; Two fixnum arguments might select EQL specializer for first
+ ;; argument.
+ nil)
+
+(deftest compute-applicable-methods.baz.1a
+ (equalp
+ (mop:compute-applicable-methods #'mop-test.baz '(111 222))
+ (list (find-baz 'fixnum 'fixnum)
+ (find-baz 'fixnum t)
+ (find-baz t t)))
+ t)
+
+(deftest compute-applicable-methods.baz.1b
+ (equalp
+ (mop:compute-applicable-methods #'mop-test.baz '(234 222))
+ (list (find-method #'mop-test.baz nil (list '(eql 234) (find-class 'fixnum)))
+ (find-baz 'fixnum 'fixnum)
+ (find-baz 'fixnum t)
+ (find-baz t t)))
+ t)
+
+(deftest compute-applicable-methods.baz.1c
+ (mop:compute-applicable-methods-using-classes
+ #'mop-test.baz (find-classes 'fixnum 'fixnum))
+ nil
+ nil)
+
+(deftest compute-applicable-methods.baz.2
+ (equalp
+ (mop:compute-applicable-methods #'mop-test.baz '(x y))
+ (mop:compute-applicable-methods-using-classes
+ #'mop-test.baz (find-classes 'symbol 'symbol)))
+ t)
+
+(deftest compute-applicable-methods.baz.3
+ (equalp
+ (mop:compute-applicable-methods #'mop-test.baz '(111 y))
+ (mop:compute-applicable-methods-using-classes
+ #'mop-test.baz (find-classes 'fixnum 'symbol)))
+ t)
+
+(deftest compute-applicable-methods.baz.4
+ (equalp
+ (mop:compute-applicable-methods #'mop-test.baz '(x 111))
+ (mop:compute-applicable-methods-using-classes
+ #'mop-test.baz (find-classes 'symbol 'fixnum)))
+ t)
+
+(deftest compute-applicable-methods.baz.5
+ (equalp
+ (mop:compute-applicable-methods #'mop-test.baz '(111 "asdf"))
+ (mop:compute-applicable-methods-using-classes
+ #'mop-test.baz (find-classes 'fixnum 'simple-base-string)))
+ t)
+
+
+(deftest compute-applicable-methods.quux.1
+ (equalp
+ (mop:compute-applicable-methods #'mop-test.quux '(111 222))
+ (mop:compute-applicable-methods-using-classes
+ #'mop-test.quux (find-classes 'fixnum 'fixnum)))
+ t)
+
+(deftest compute-applicable-methods.quux.1a
+ (equalp
+ (mop:compute-applicable-methods #'mop-test.quux '(111 222))
+ (list (find-quux 'fixnum 'fixnum)
+ (find-quux 'fixnum t)
+ (find-quux t t)))
+ t)
+
+(deftest compute-applicable-methods.quux.2
+ (equalp
+ (mop:compute-applicable-methods #'mop-test.quux '(x y))
+ (mop:compute-applicable-methods-using-classes
+ #'mop-test.quux (find-classes 'symbol 'symbol)))
+ t)
+
+(deftest compute-applicable-methods.quux.2a
+ (equalp
+ (mop:compute-applicable-methods #'mop-test.quux '(x y))
+ (list (find-quux t t)))
+ t)
+
+(deftest compute-applicable-methods.quux.3
+ (equalp
+ (mop:compute-applicable-methods #'mop-test.quux '(111 y))
+ (mop:compute-applicable-methods-using-classes
+ #'mop-test.quux (find-classes 'fixnum 'symbol)))
+ t)
+
+(deftest compute-applicable-methods.quux.3a
+ (equalp
+ (mop:compute-applicable-methods #'mop-test.quux '(111 y))
+ (list (find-quux 'fixnum t)
+ (find-quux t t)))
+ t)
+
+(deftest compute-applicable-methods.quux.4
+ (equalp
+ (mop:compute-applicable-methods #'mop-test.quux '(x 111))
+ (mop:compute-applicable-methods-using-classes
+ #'mop-test.quux (find-classes 'symbol 'fixnum)))
+ ;; Symbol/fixnum might trigger EQL spezializer
+ nil)
+
+(deftest compute-applicable-methods.quux.4a
+ (equalp
+ (mop:compute-applicable-methods #'mop-test.quux '(x 111))
+ (list (find-quux t t)))
+ t)
+
+(deftest compute-applicable-methods.quux.4b
+ (equalp
+ (mop:compute-applicable-methods #'mop-test.quux '(:foo 111))
+ (list (find-method #'mop-test.quux nil
+ (list '(eql :foo) (find-class 'fixnum)))
+
+ (find-quux t t)))
+ t)
+
+(deftest compute-applicable-methods.quux.4c
+ (mop:compute-applicable-methods-using-classes
+ #'mop-test.quux (find-classes 'symbol 'fixnum))
+ nil
+ nil)
+
+(deftest compute-applicable-methods.quux.5
+ (equalp
+ (mop:compute-applicable-methods #'mop-test.quux '(111 "asdf"))
+ (mop:compute-applicable-methods-using-classes
+ #'mop-test.quux (find-classes 'fixnum 'simple-base-string)))
+ t)
+
+
Modified: trunk/abcl/test/lisp/abcl/package.lisp
==============================================================================
--- trunk/abcl/test/lisp/abcl/package.lisp (original)
+++ trunk/abcl/test/lisp/abcl/package.lisp Sun Jan 24 10:24:18 2010
@@ -18,6 +18,7 @@
(load "compiler-tests.lisp")
(load "condition-tests.lisp")
+ (load "mop-tests.lisp")
(load "file-system-tests.lisp")
(load "java-tests.lisp")
(load "math-tests.lisp")
More information about the armedbear-cvs
mailing list