Changeset 14498
- Timestamp:
- 05/15/13 06:42:43 (10 years ago)
- File:
-
- 1 edited
-
trunk/abcl/src/org/armedbear/lisp/clos.lisp (modified) (21 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/abcl/src/org/armedbear/lisp/clos.lisp
r14493 r14498 209 209 '(built-in-class standard-class funcallable-standard-class)))) 210 210 (fixup-standard-class-hierarchy) 211 212 (defun std-class-p (class) 213 (let ((metaclass (class-of class))) 214 (or (eq metaclass +the-standard-class+) 215 (eq metaclass +the-funcallable-standard-class+)))) 211 216 212 217 (defun no-applicable-method (generic-function &rest args) … … 526 531 (return-from std-finalize-inheritance)) 527 532 (setf (class-precedence-list class) 528 (funcall (if (eq (class-of class) +the-standard-class+)529 #'std-compute-class-precedence-list530 #'compute-class-precedence-list)531 class))533 (funcall (if (std-class-p class) 534 #'std-compute-class-precedence-list 535 #'compute-class-precedence-list) 536 class)) 532 537 (setf (class-slots class) 533 (funcall (if ( eq (class-of class) +the-standard-class+)538 (funcall (if (std-class-p class) 534 539 #'std-compute-slots 535 540 #'compute-slots) class)) … … 682 687 (mapcar #'(lambda (name) 683 688 (funcall 684 (if ( eq (class-of class) +the-standard-class+)689 (if (std-class-p class) 685 690 #'std-compute-effective-slot-definition 686 691 #'compute-effective-slot-definition) … … 773 778 774 779 (defun slot-boundp (object slot-name) 775 (let* ((class (class-of object)) 776 (metaclass (class-of class))) 777 (if (or (eq metaclass +the-standard-class+) 778 (eq metaclass +the-funcallable-standard-class+)) 780 (let ((class (class-of object))) 781 (if (std-class-p class) 779 782 (std-slot-boundp object slot-name) 780 783 (slot-boundp-using-class class object … … 792 795 793 796 (defun slot-makunbound (object slot-name) 794 (let* ((class (class-of object)) 795 (metaclass (class-of class))) 796 (if (or (eq metaclass +the-standard-class+) 797 (eq metaclass +the-funcallable-standard-class+)) 797 (let ((class (class-of object))) 798 (if (std-class-p class) 798 799 (std-slot-makunbound object slot-name) 799 800 (slot-makunbound-using-class class object … … 805 806 806 807 (defun slot-exists-p (object slot-name) 807 (if (eq (class-of (class-of object)) +the-standard-class+) 808 (std-slot-exists-p object slot-name) 809 (slot-exists-p-using-class (class-of object) object slot-name))) 808 (let ((class (class-of object))) 809 (if (std-class-p class) 810 (std-slot-exists-p object slot-name) 811 (slot-exists-p-using-class class object slot-name)))) 810 812 811 813 (defun instance-slot-p (slot) … … 967 969 (defconstant +the-forward-referenced-class+ 968 970 (find-class 'forward-referenced-class)) 971 972 (defun std-generic-function-p (gf) 973 (eq (class-of gf) +the-standard-generic-function-class+)) 969 974 970 975 (defvar *extensible-built-in-classes* … … 1798 1803 (when mc-p 1799 1804 (error "Preliminary ensure-method does not support :method-combination argument.")) 1800 (setf gf (apply (if (eq generic-function-class 1801 +the-standard-generic-function-class+) 1802 #'make-instance-standard-generic-function 1803 #'make-instance) 1804 generic-function-class 1805 :name function-name 1806 :method-class method-class 1807 :method-combination method-combination 1808 all-keys)) 1809 gf)))) 1805 (apply #'make-instance-standard-generic-function 1806 generic-function-class 1807 :name function-name 1808 :method-class method-class 1809 :method-combination method-combination 1810 all-keys))))) 1810 1811 1811 1812 (defun collect-eql-specializer-objects (generic-function) … … 1823 1824 (set-funcallable-instance-function 1824 1825 gf 1825 (if ( eq (class-of gf) +the-standard-generic-function-class+)1826 (if (std-generic-function-p gf) 1826 1827 (std-compute-discriminating-function gf) 1827 1828 (compute-discriminating-function gf))) … … 2145 2146 (if (and 2146 2147 (eq (generic-function-method-class gf) +the-standard-method-class+) 2147 ( eq (class-of gf) +the-standard-generic-function-class+))2148 (std-generic-function-p gf)) 2148 2149 (progn 2149 2150 (std-add-method gf method) … … 2199 2200 (method-specializers method) nil))) 2200 2201 (when old-method 2201 (if (and ( eq (class-of gf) +the-standard-generic-function-class+)2202 (if (and (std-generic-function-p gf) 2202 2203 (eq (class-of old-method) +the-standard-method-class+)) 2203 2204 (std-remove-method gf old-method) … … 2373 2374 methods 2374 2375 (sort methods 2375 (if ( eq (class-of gf) +the-standard-generic-function-class+)2376 (if (std-generic-function-p gf) 2376 2377 (let ((method-indices 2377 2378 (argument-precedence-order-indices … … 2474 2475 (defun slow-method-lookup (gf args) 2475 2476 (let ((applicable-methods 2476 (if ( eq (class-of gf) +the-standard-generic-function-class+)2477 (if (std-generic-function-p gf) 2477 2478 (std-compute-applicable-methods gf args) 2478 2479 (or (compute-applicable-methods-using-classes gf (mapcar #'class-of args)) 2479 2480 (compute-applicable-methods gf args))))) 2480 2481 (if applicable-methods 2481 (let* ((emfun (funcall (if (eq (class-of gf) 2482 +the-standard-generic-function-class+) 2482 (let* ((emfun (funcall (if (std-generic-function-p gf) 2483 2483 #'std-compute-effective-method 2484 2484 #'compute-effective-method) … … 2603 2603 (let ((next-emfun 2604 2604 (funcall 2605 (if ( eq (class-of gf) +the-standard-generic-function-class+)2605 (if (std-generic-function-p gf) 2606 2606 #'std-compute-effective-method 2607 2607 #'compute-effective-method) … … 2876 2876 (let* ((slot-name (slot-definition-name slot-definition)) 2877 2877 (lambda-expression 2878 (if ( eq (class-of class) +the-standard-class+)2878 (if (std-class-p class) 2879 2879 `(lambda (object) (std-slot-value object ',slot-name)) 2880 2880 `(lambda (object) (slot-value object ',slot-name)))) … … 2893 2893 (autocompile fast-function)) 2894 2894 :slot-definition ,slot-definition)) 2895 (method-class (if ( eq class +the-standard-class+)2895 (method-class (if (std-class-p class) 2896 2896 +the-standard-reader-method-class+ 2897 2897 (apply #'reader-method-class class slot-definition … … 2912 2912 :generic-function nil ; handled by add-method 2913 2913 initargs)))) 2914 (if ( eq (class-of gf) +the-standard-generic-function-class+)2914 (if (std-generic-function-p gf) 2915 2915 (progn 2916 2916 (std-add-method gf method) … … 2924 2924 (let* ((slot-name (slot-definition-name slot-definition)) 2925 2925 (lambda-expression 2926 (if ( eq (class-of class) +the-standard-class+)2926 (if (std-class-p class) 2927 2927 `(lambda (new-value object) 2928 2928 (setf (std-slot-value object ',slot-name) new-value)) … … 2943 2943 (autocompile fast-function)) 2944 2944 :slot-definition ,slot-definition)) 2945 (method-class (if ( eq class +the-standard-class+)2945 (method-class (if (std-class-p class) 2946 2946 +the-standard-writer-method-class+ 2947 2947 (apply #'writer-method-class class slot-definition … … 2962 2962 :generic-function nil ; handled by add-method 2963 2963 initargs)))) 2964 (if ( eq (class-of gf) +the-standard-generic-function-class+)2964 (if (std-generic-function-p gf) 2965 2965 (progn 2966 2966 (std-add-method gf method) … … 3482 3482 initargs)) 3483 3483 (mapcan #'(lambda (gf) 3484 (if (eq (class-of gf) 3485 +the-standard-generic-function-class+) 3484 (if (std-generic-function-p gf) 3486 3485 (std-compute-applicable-methods gf args) 3487 3486 (compute-applicable-methods gf args)))
Note: See TracChangeset
for help on using the changeset viewer.
