Changeset 13776
 Timestamp:
 01/15/12 07:24:34 (10 years ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

trunk/abcl/src/org/armedbear/lisp/clos.lisp
r13775 r13776 1841 1841 1842 1842 (defun stdcomputediscriminatingfunction (gf) 1843 (let ((code 1844 (cond 1845 ((and (= (length (genericfunctionmethods gf)) 1) 1846 (typep (car (genericfunctionmethods gf)) 'standardreadermethod)) 1847 ;; (sys::%format t "standard reader function ~S~%" (genericfunctionname gf)) 1848 1849 (let* ((method (%car (genericfunctionmethods gf))) 1850 (class (car (%methodspecializers method))) 1851 (slotname (readermethodslotname method))) 1852 #'(lambda (arg) 1843 (cond 1844 ((and (= (length (genericfunctionmethods gf)) 1) 1845 (typep (car (genericfunctionmethods gf)) 'standardreadermethod)) 1846 ;; (sys::%format t "standard reader function ~S~%" (genericfunctionname gf)) 1847 1848 (let* ((method (%car (genericfunctionmethods gf))) 1849 (class (car (%methodspecializers method))) 1850 (slotname (readermethodslotname method))) 1851 #'(lambda (arg) 1852 (declare (optimize speed)) 1853 (let* ((layout (stdinstancelayout arg)) 1854 (location (getcachedslotlocation gf layout))) 1855 (unless location 1856 (unless (simpletypep arg class) 1857 ;; FIXME no applicable method 1858 (error 'simpletypeerror 1859 :datum arg 1860 :expectedtype class)) 1861 (setf location (slowreaderlookup gf layout slotname))) 1862 (if (consp location) 1863 ;; Shared slot. 1864 (cdr location) 1865 (standardinstanceaccess arg location)))))) 1866 1867 (t 1868 (let* ((emftable (classestoemftable gf)) 1869 (numberrequired (length (gfrequiredargs gf))) 1870 (lambdalist (%genericfunctionlambdalist gf)) 1871 (exact (null (intersection lambdalist 1872 '(&rest &optional &key 1873 &allowotherkeys &aux))))) 1874 (if exact 1875 (cond 1876 ((= numberrequired 1) 1877 (cond 1878 ((and (eq (genericfunctionmethodcombination gf) 'standard) 1879 (= (length (genericfunctionmethods gf)) 1)) 1880 (let* ((method (%car (genericfunctionmethods gf))) 1881 (specializer (car (%methodspecializers method))) 1882 (function (or (%methodfastfunction method) 1883 (%methodfunction method)))) 1884 (if (typep specializer 'eqlspecializer) 1885 (let ((specializerobject (eqlspecializerobject specializer))) 1886 #'(lambda (arg) 1887 (declare (optimize speed)) 1888 (if (eql arg specializerobject) 1889 (funcall function arg) 1890 (noapplicablemethod gf (list arg))))) 1891 #'(lambda (arg) 1892 (declare (optimize speed)) 1893 (unless (simpletypep arg specializer) 1894 ;; FIXME no applicable method 1895 (error 'simpletypeerror 1896 :datum arg 1897 :expectedtype specializer)) 1898 (funcall function arg))))) 1899 (t 1900 #'(lambda (arg) 1901 (declare (optimize speed)) 1902 (let* ((specialization 1903 (%getargspecialization gf arg)) 1904 (emfun (or (gethash1 specialization 1905 emftable) 1906 (slowmethodlookup1 1907 gf arg specialization)))) 1908 (if emfun 1909 (funcall emfun (list arg)) 1910 (apply #'noapplicablemethod gf (list arg)))))))) 1911 ((= numberrequired 2) 1912 #'(lambda (arg1 arg2) 1853 1913 (declare (optimize speed)) 1854 (let* ((layout (stdinstancelayout arg)) 1855 (location (getcachedslotlocation gf layout))) 1856 (unless location 1857 (unless (simpletypep arg class) 1858 ;; FIXME no applicable method 1859 (error 'simpletypeerror 1860 :datum arg 1861 :expectedtype class)) 1862 (setf location (slowreaderlookup gf layout slotname))) 1863 (if (consp location) 1864 ;; Shared slot. 1865 (cdr location) 1866 (standardinstanceaccess arg location)))))) 1867 1868 (t 1869 (let* ((emftable (classestoemftable gf)) 1870 (numberrequired (length (gfrequiredargs gf))) 1871 (lambdalist (%genericfunctionlambdalist gf)) 1872 (exact (null (intersection lambdalist 1873 '(&rest &optional &key 1874 &allowotherkeys &aux))))) 1875 (if exact 1876 (cond 1877 ((= numberrequired 1) 1878 (cond 1879 ((and (eq (genericfunctionmethodcombination gf) 'standard) 1880 (= (length (genericfunctionmethods gf)) 1)) 1881 (let* ((method (%car (genericfunctionmethods gf))) 1882 (specializer (car (%methodspecializers method))) 1883 (function (or (%methodfastfunction method) 1884 (%methodfunction method)))) 1885 (if (typep specializer 'eqlspecializer) 1886 (let ((specializerobject (eqlspecializerobject specializer))) 1887 #'(lambda (arg) 1888 (declare (optimize speed)) 1889 (if (eql arg specializerobject) 1890 (funcall function arg) 1891 (noapplicablemethod gf (list arg))))) 1892 #'(lambda (arg) 1893 (declare (optimize speed)) 1894 (unless (simpletypep arg specializer) 1895 ;; FIXME no applicable method 1896 (error 'simpletypeerror 1897 :datum arg 1898 :expectedtype specializer)) 1899 (funcall function arg))))) 1900 (t 1901 #'(lambda (arg) 1902 (declare (optimize speed)) 1903 (let* ((specialization 1904 (%getargspecialization gf arg)) 1905 (emfun (or (gethash1 specialization 1906 emftable) 1907 (slowmethodlookup1 1908 gf arg specialization)))) 1909 (if emfun 1910 (funcall emfun (list arg)) 1911 (apply #'noapplicablemethod gf (list arg)))))))) 1912 ((= numberrequired 2) 1913 #'(lambda (arg1 arg2) 1914 (declare (optimize speed)) 1915 (let* ((args (list arg1 arg2)) 1916 (emfun (getcachedemf gf args))) 1917 (if emfun 1918 (funcall emfun args) 1919 (slowmethodlookup gf args))))) 1920 ((= numberrequired 3) 1921 #'(lambda (arg1 arg2 arg3) 1922 (declare (optimize speed)) 1923 (let* ((args (list arg1 arg2 arg3)) 1924 (emfun (getcachedemf gf args))) 1925 (if emfun 1926 (funcall emfun args) 1927 (slowmethodlookup gf args))))) 1928 (t 1929 #'(lambda (&rest args) 1930 (declare (optimize speed)) 1931 (let ((len (length args))) 1932 (unless (= len numberrequired) 1933 (error 'programerror 1934 :formatcontrol "Not enough arguments for generic function ~S." 1935 :formatarguments (list (%genericfunctionname gf))))) 1936 (let ((emfun (getcachedemf gf args))) 1937 (if emfun 1938 (funcall emfun args) 1939 (slowmethodlookup gf args)))))) 1940 #'(lambda (&rest args) 1941 (declare (optimize speed)) 1942 (let ((len (length args))) 1943 (unless (>= len numberrequired) 1944 (error 'programerror 1945 :formatcontrol "Not enough arguments for generic function ~S." 1946 :formatarguments (list (%genericfunctionname gf))))) 1947 (let ((emfun (getcachedemf gf args))) 1948 (if emfun 1949 (funcall emfun args) 1950 (slowmethodlookup gf args)))))))))) 1951 1952 code)) 1914 (let* ((args (list arg1 arg2)) 1915 (emfun (getcachedemf gf args))) 1916 (if emfun 1917 (funcall emfun args) 1918 (slowmethodlookup gf args))))) 1919 ((= numberrequired 3) 1920 #'(lambda (arg1 arg2 arg3) 1921 (declare (optimize speed)) 1922 (let* ((args (list arg1 arg2 arg3)) 1923 (emfun (getcachedemf gf args))) 1924 (if emfun 1925 (funcall emfun args) 1926 (slowmethodlookup gf args))))) 1927 (t 1928 #'(lambda (&rest args) 1929 (declare (optimize speed)) 1930 (let ((len (length args))) 1931 (unless (= len numberrequired) 1932 (error 'programerror 1933 :formatcontrol "Not enough arguments for generic function ~S." 1934 :formatarguments (list (%genericfunctionname gf))))) 1935 (let ((emfun (getcachedemf gf args))) 1936 (if emfun 1937 (funcall emfun args) 1938 (slowmethodlookup gf args)))))) 1939 #'(lambda (&rest args) 1940 (declare (optimize speed)) 1941 (let ((len (length args))) 1942 (unless (>= len numberrequired) 1943 (error 'programerror 1944 :formatcontrol "Not enough arguments for generic function ~S." 1945 :formatarguments (list (%genericfunctionname gf))))) 1946 (let ((emfun (getcachedemf gf args))) 1947 (if emfun 1948 (funcall emfun args) 1949 (slowmethodlookup gf args))))))))) 1953 1950 1954 1951 (defun sortmethods (methods gf requiredclasses)
Note: See TracChangeset
for help on using the changeset viewer.