Changeset 12395


Ignore:
Timestamp:
01/24/10 15:24:18 (11 years ago)
Author:
vvoutilainen
Message:

Some patches to improve arglist display in Slime.
Patch by Matthias Hölzl.

Location:
trunk/abcl
Files:
2 added
3 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/autoloads.lisp

    r12230 r12395  
    208208
    209209(in-package "MOP")
    210 (export '(class-precedence-list class-slots slot-definition-name))
    211 (autoload '(class-precedence-list class-slots slot-definition-name) "clos")
     210(export '(class-precedence-list class-slots slot-definition-allocation
     211    slot-definition-initargs slot-definition-initform
     212    slot-definition-initfunction slot-definition-name
     213    compute-applicable-methods
     214    compute-applicable-methods-using-classes))
     215(autoload '(class-precedence-list class-slots) "clos")
    212216
    213217
  • trunk/abcl/src/org/armedbear/lisp/clos.lisp

    r12391 r12395  
    5252(in-package #:mop)
    5353
    54 (export '(class-precedence-list class-slots slot-definition-name))
     54(export '(class-precedence-list class-slots))
    5555
    5656(defun class-slots (class)
    5757  (%class-slots class))
    58 
    59 (defun slot-definition-name (slot-definition)
    60   (%slot-definition-name slot-definition))
    6158
    6259(defmacro push-on-end (value location)
     
    13191316    code))
    13201317
     1318(defun sort-methods (methods gf required-classes)
     1319  (if (or (null methods) (null (%cdr methods)))
     1320      methods
     1321      (sort methods
     1322      (if (eq (class-of gf) (find-class 'standard-generic-function))
     1323    #'(lambda (m1 m2)
     1324        (std-method-more-specific-p m1 m2 required-classes
     1325            (generic-function-argument-precedence-order gf)))
     1326    #'(lambda (m1 m2)
     1327        (method-more-specific-p gf m1 m2 required-classes))))))
     1328
    13211329(defun method-applicable-p (method args)
    13221330  (do* ((specializers (%method-specializers method) (cdr specializers))
     
    13361344      (when (method-applicable-p method args)
    13371345        (push method methods)))
    1338     (if (or (null methods) (null (%cdr methods)))
    1339         methods
    1340         (sort methods
    1341               (if (eq (class-of gf) (find-class 'standard-generic-function))
    1342                   #'(lambda (m1 m2)
    1343                      (std-method-more-specific-p m1 m2 required-classes
    1344                                                  (generic-function-argument-precedence-order gf)))
    1345                   #'(lambda (m1 m2)
    1346                      (method-more-specific-p gf m1 m2 required-classes)))))))
    1347 
    1348 (defun method-applicable-p-using-classes (method classes)
     1346    (sort-methods methods gf required-classes)))
     1347
     1348;;; METHOD-APPLICABLE-USING-CLASSES-P
     1349;;;
     1350;;; If the first return value is T, METHOD is definitely applicable to
     1351;;; arguments that are instances of CLASSES.  If the first value is
     1352;;; NIL and the second value is T, METHOD is definitely not applicable
     1353;;; to arguments that are instances of CLASSES; if the second value is
     1354;;; NIL the applicability of METHOD cannot be determined by inspecting
     1355;;; the classes of its arguments only.
     1356;;;
     1357(defun method-applicable-using-classes-p (method classes)
    13491358  (do* ((specializers (%method-specializers method) (cdr specializers))
    1350         (classes classes (cdr classes)))
    1351        ((null specializers) t)
     1359  (classes classes (cdr classes))
     1360  (knownp t))
     1361       ((null specializers)
     1362  (if knownp (values t t) (values nil nil)))
    13521363    (let ((specializer (car specializers)))
    1353       (unless (subclassp (car classes) specializer)
    1354         (return nil)))))
     1364      (if (typep specializer 'eql-specializer)
     1365    (if (eql (class-of (eql-specializer-object specializer))
     1366       (car classes))
     1367        (setf knownp nil)
     1368        (return (values nil t)))
     1369    (unless (subclassp (car classes) specializer)
     1370      (return (values nil t)))))))
    13551371
    13561372(defun slow-method-lookup (gf args)
     
    18801896  (%set-documentation x doc-type new-value))
    18811897
     1898;;; Applicable methods
     1899
     1900(defgeneric compute-applicable-methods (gf args)
     1901  (:method ((gf standard-generic-function) args)
     1902    (%compute-applicable-methods gf args)))
     1903
     1904(defgeneric compute-applicable-methods-using-classes (gf classes)
     1905  (:method ((gf standard-generic-function) classes)
     1906    (let ((methods '()))
     1907      (dolist (method (generic-function-methods gf))
     1908  (multiple-value-bind (applicable knownp)
     1909      (method-applicable-using-classes-p method classes)
     1910    (cond (applicable
     1911     (push method methods))
     1912    ((not knownp)
     1913     (return-from compute-applicable-methods-using-classes
     1914       (values nil nil))))))
     1915      (values (sort-methods methods gf classes)
     1916        t))))
     1917
     1918(export '(compute-applicable-methods
     1919    compute-applicable-methods-using-classes))
     1920
     1921
    18821922;;; Slot access
    18831923
     
    21972237(defmethod compute-applicable-methods ((gf standard-generic-function) args)
    21982238  (%compute-applicable-methods gf args))
     2239
     2240;;; Slot definition accessors
     2241
     2242(export '(slot-definition-allocation
     2243    slot-definition-initargs
     2244    slot-definition-initform
     2245    slot-definition-initfunction
     2246    slot-definition-name))
     2247
     2248(defgeneric slot-definition-allocation (slot-definition)
     2249  (:method ((slot-definition slot-definition))
     2250    (%slot-definition-allocation slot-definition)))
     2251
     2252(defgeneric slot-definition-initargs (slot-definition)
     2253  (:method ((slot-definition slot-definition))
     2254    (%slot-definition-initargs slot-definition)))
     2255
     2256(defgeneric slot-definition-initform (slot-definition)
     2257  (:method ((slot-definition slot-definition))
     2258    (%slot-definition-initform slot-definition)))
     2259
     2260(defgeneric slot-definition-initfunction (slot-definition)
     2261  (:method ((slot-definition slot-definition))
     2262    (%slot-definition-initfunction slot-definition)))
     2263
     2264(defgeneric slot-definition-name (slot-definition)
     2265  (:method ((slot-definition slot-definition))
     2266    (%slot-definition-name slot-definition)))
     2267
     2268;;; No %slot-definition-type.
     2269
    21992270
    22002271;;; Conditions.
  • trunk/abcl/test/lisp/abcl/package.lisp

    r12301 r12395  
    1919    (load "compiler-tests.lisp")
    2020    (load "condition-tests.lisp")
     21    (load "mop-tests.lisp")
    2122    (load "file-system-tests.lisp")
    2223    (load "java-tests.lisp")
Note: See TracChangeset for help on using the changeset viewer.