Changeset 13776 for trunk/abcl/src/org/armedbear/lisp/clos.lisp
- Timestamp:
- 01/15/12 07:24:34 (11 years ago)
- File:
-
- 1 edited
-
trunk/abcl/src/org/armedbear/lisp/clos.lisp (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
trunk/abcl/src/org/armedbear/lisp/clos.lisp
r13775 r13776 1841 1841 1842 1842 (defun std-compute-discriminating-function (gf) 1843 (let ((code 1844 (cond 1845 ((and (= (length (generic-function-methods gf)) 1) 1846 (typep (car (generic-function-methods gf)) 'standard-reader-method)) 1847 ;; (sys::%format t "standard reader function ~S~%" (generic-function-name gf)) 1848 1849 (let* ((method (%car (generic-function-methods gf))) 1850 (class (car (%method-specializers method))) 1851 (slot-name (reader-method-slot-name method))) 1852 #'(lambda (arg) 1843 (cond 1844 ((and (= (length (generic-function-methods gf)) 1) 1845 (typep (car (generic-function-methods gf)) 'standard-reader-method)) 1846 ;; (sys::%format t "standard reader function ~S~%" (generic-function-name gf)) 1847 1848 (let* ((method (%car (generic-function-methods gf))) 1849 (class (car (%method-specializers method))) 1850 (slot-name (reader-method-slot-name method))) 1851 #'(lambda (arg) 1852 (declare (optimize speed)) 1853 (let* ((layout (std-instance-layout arg)) 1854 (location (get-cached-slot-location gf layout))) 1855 (unless location 1856 (unless (simple-typep arg class) 1857 ;; FIXME no applicable method 1858 (error 'simple-type-error 1859 :datum arg 1860 :expected-type class)) 1861 (setf location (slow-reader-lookup gf layout slot-name))) 1862 (if (consp location) 1863 ;; Shared slot. 1864 (cdr location) 1865 (standard-instance-access arg location)))))) 1866 1867 (t 1868 (let* ((emf-table (classes-to-emf-table gf)) 1869 (number-required (length (gf-required-args gf))) 1870 (lambda-list (%generic-function-lambda-list gf)) 1871 (exact (null (intersection lambda-list 1872 '(&rest &optional &key 1873 &allow-other-keys &aux))))) 1874 (if exact 1875 (cond 1876 ((= number-required 1) 1877 (cond 1878 ((and (eq (generic-function-method-combination gf) 'standard) 1879 (= (length (generic-function-methods gf)) 1)) 1880 (let* ((method (%car (generic-function-methods gf))) 1881 (specializer (car (%method-specializers method))) 1882 (function (or (%method-fast-function method) 1883 (%method-function method)))) 1884 (if (typep specializer 'eql-specializer) 1885 (let ((specializer-object (eql-specializer-object specializer))) 1886 #'(lambda (arg) 1887 (declare (optimize speed)) 1888 (if (eql arg specializer-object) 1889 (funcall function arg) 1890 (no-applicable-method gf (list arg))))) 1891 #'(lambda (arg) 1892 (declare (optimize speed)) 1893 (unless (simple-typep arg specializer) 1894 ;; FIXME no applicable method 1895 (error 'simple-type-error 1896 :datum arg 1897 :expected-type specializer)) 1898 (funcall function arg))))) 1899 (t 1900 #'(lambda (arg) 1901 (declare (optimize speed)) 1902 (let* ((specialization 1903 (%get-arg-specialization gf arg)) 1904 (emfun (or (gethash1 specialization 1905 emf-table) 1906 (slow-method-lookup-1 1907 gf arg specialization)))) 1908 (if emfun 1909 (funcall emfun (list arg)) 1910 (apply #'no-applicable-method gf (list arg)))))))) 1911 ((= number-required 2) 1912 #'(lambda (arg1 arg2) 1853 1913 (declare (optimize speed)) 1854 (let* ((layout (std-instance-layout arg)) 1855 (location (get-cached-slot-location gf layout))) 1856 (unless location 1857 (unless (simple-typep arg class) 1858 ;; FIXME no applicable method 1859 (error 'simple-type-error 1860 :datum arg 1861 :expected-type class)) 1862 (setf location (slow-reader-lookup gf layout slot-name))) 1863 (if (consp location) 1864 ;; Shared slot. 1865 (cdr location) 1866 (standard-instance-access arg location)))))) 1867 1868 (t 1869 (let* ((emf-table (classes-to-emf-table gf)) 1870 (number-required (length (gf-required-args gf))) 1871 (lambda-list (%generic-function-lambda-list gf)) 1872 (exact (null (intersection lambda-list 1873 '(&rest &optional &key 1874 &allow-other-keys &aux))))) 1875 (if exact 1876 (cond 1877 ((= number-required 1) 1878 (cond 1879 ((and (eq (generic-function-method-combination gf) 'standard) 1880 (= (length (generic-function-methods gf)) 1)) 1881 (let* ((method (%car (generic-function-methods gf))) 1882 (specializer (car (%method-specializers method))) 1883 (function (or (%method-fast-function method) 1884 (%method-function method)))) 1885 (if (typep specializer 'eql-specializer) 1886 (let ((specializer-object (eql-specializer-object specializer))) 1887 #'(lambda (arg) 1888 (declare (optimize speed)) 1889 (if (eql arg specializer-object) 1890 (funcall function arg) 1891 (no-applicable-method gf (list arg))))) 1892 #'(lambda (arg) 1893 (declare (optimize speed)) 1894 (unless (simple-typep arg specializer) 1895 ;; FIXME no applicable method 1896 (error 'simple-type-error 1897 :datum arg 1898 :expected-type specializer)) 1899 (funcall function arg))))) 1900 (t 1901 #'(lambda (arg) 1902 (declare (optimize speed)) 1903 (let* ((specialization 1904 (%get-arg-specialization gf arg)) 1905 (emfun (or (gethash1 specialization 1906 emf-table) 1907 (slow-method-lookup-1 1908 gf arg specialization)))) 1909 (if emfun 1910 (funcall emfun (list arg)) 1911 (apply #'no-applicable-method gf (list arg)))))))) 1912 ((= number-required 2) 1913 #'(lambda (arg1 arg2) 1914 (declare (optimize speed)) 1915 (let* ((args (list arg1 arg2)) 1916 (emfun (get-cached-emf gf args))) 1917 (if emfun 1918 (funcall emfun args) 1919 (slow-method-lookup gf args))))) 1920 ((= number-required 3) 1921 #'(lambda (arg1 arg2 arg3) 1922 (declare (optimize speed)) 1923 (let* ((args (list arg1 arg2 arg3)) 1924 (emfun (get-cached-emf gf args))) 1925 (if emfun 1926 (funcall emfun args) 1927 (slow-method-lookup gf args))))) 1928 (t 1929 #'(lambda (&rest args) 1930 (declare (optimize speed)) 1931 (let ((len (length args))) 1932 (unless (= len number-required) 1933 (error 'program-error 1934 :format-control "Not enough arguments for generic function ~S." 1935 :format-arguments (list (%generic-function-name gf))))) 1936 (let ((emfun (get-cached-emf gf args))) 1937 (if emfun 1938 (funcall emfun args) 1939 (slow-method-lookup gf args)))))) 1940 #'(lambda (&rest args) 1941 (declare (optimize speed)) 1942 (let ((len (length args))) 1943 (unless (>= len number-required) 1944 (error 'program-error 1945 :format-control "Not enough arguments for generic function ~S." 1946 :format-arguments (list (%generic-function-name gf))))) 1947 (let ((emfun (get-cached-emf gf args))) 1948 (if emfun 1949 (funcall emfun args) 1950 (slow-method-lookup gf args)))))))))) 1951 1952 code)) 1914 (let* ((args (list arg1 arg2)) 1915 (emfun (get-cached-emf gf args))) 1916 (if emfun 1917 (funcall emfun args) 1918 (slow-method-lookup gf args))))) 1919 ((= number-required 3) 1920 #'(lambda (arg1 arg2 arg3) 1921 (declare (optimize speed)) 1922 (let* ((args (list arg1 arg2 arg3)) 1923 (emfun (get-cached-emf gf args))) 1924 (if emfun 1925 (funcall emfun args) 1926 (slow-method-lookup gf args))))) 1927 (t 1928 #'(lambda (&rest args) 1929 (declare (optimize speed)) 1930 (let ((len (length args))) 1931 (unless (= len number-required) 1932 (error 'program-error 1933 :format-control "Not enough arguments for generic function ~S." 1934 :format-arguments (list (%generic-function-name gf))))) 1935 (let ((emfun (get-cached-emf gf args))) 1936 (if emfun 1937 (funcall emfun args) 1938 (slow-method-lookup gf args)))))) 1939 #'(lambda (&rest args) 1940 (declare (optimize speed)) 1941 (let ((len (length args))) 1942 (unless (>= len number-required) 1943 (error 'program-error 1944 :format-control "Not enough arguments for generic function ~S." 1945 :format-arguments (list (%generic-function-name gf))))) 1946 (let ((emfun (get-cached-emf gf args))) 1947 (if emfun 1948 (funcall emfun args) 1949 (slow-method-lookup gf args))))))))) 1953 1950 1954 1951 (defun sort-methods (methods gf required-classes)
Note: See TracChangeset
for help on using the changeset viewer.
