Changeset 8770


Ignore:
Timestamp:
Mar 13, 2008, 10:43:37 AM (12 years ago)
Author:
gb
Message:

RECORD-FUNCTION-INFO: takes encoded info and sticks it in the environment.
Use it to note compile-time arg info for DEFGENERIC, DEFMETOD, accessors
generated in DEFCLASS expansion.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/lib/macros.lisp

    r8705 r8770  
    617617      (%define-symbol-macro ',name ',expansion))))
    618618
     619(defun record-function-info (name info env)
     620  (let ((definition-env (definition-environment env)))
     621    (if definition-env
     622      (let* ((already (assq (maybe-setf-function-name name)
     623                            (defenv.defined definition-env))))
     624        (if already
     625          (if info (%rplacd already info))
     626          (push (cons name info) (defenv.defined definition-env))))))
     627  name)
     628
     629
    619630;; ---- allow inlining setf functions
    620631(defmacro defun (spec args &body body &environment env &aux global-name inline-spec)
     
    16991710    `(progn
    17001711      (eval-when (:compile-toplevel)
    1701         (note-function-info ',name '(lambda ,(adjust-defmethod-lambda-list lambda-list)) ,env))
     1712        (record-function-info ',name
     1713                              ',(multiple-value-bind (bits keys)
     1714                                                     (encode-lambda-list
     1715                                                      (adjust-defmethod-lambda-list lambda-list))
     1716                                                     (list (cons bits keys) nil))
     1717                              ,env))
    17021718      (compiler-let ((*nx-method-warning-name*
    17031719                      (list ',name
     
    18231839                 (t
    18241840                  `(function (lambda () ,form))))))
    1825     (setq class-name (require-type class-name '(and symbol (not null))))
    1826     (setq superclasses (mapcar #'(lambda (s) (require-type s 'symbol)) superclasses))
    1827     (let* ((options-seen ())
    1828            (signatures ())
    1829            (slot-names))
    1830       (flet ((canonicalize-defclass-option (option)
    1831                (let* ((option-name (car option)))
    1832                  (if (member option-name options-seen :test #'eq)
    1833                    (duplicate-options class-options)
    1834                    (push option-name options-seen))
    1835                  (case option-name
    1836                    (:default-initargs
    1837                        (let ((canonical ())
    1838                              (initargs-seen ()))
    1839                          (let (key val (tail (cdr option)))
    1840                            (loop (when (null tail) (return nil))
    1841                               (setq key (pop tail)
    1842                                     val (pop tail))
    1843                               (when (memq key initargs-seen)
    1844                                 (SIGNAL-PROGRAM-error "Duplicate initialization argument name ~S in :DEFAULT-INITARGS of DEFCLASS ~S" key class-name))
    1845                               (push key initargs-seen)
    1846                               (push ``(,',key ,',val  ,,(make-initfunction val)) canonical))
    1847                            `(':direct-default-initargs (list ,@(nreverse canonical))))))
    1848                    (:metaclass
    1849                     (unless (and (cadr option)
    1850                                  (typep (cadr option) 'symbol))
    1851                       (illegal-option option))
    1852                     `(:metaclass  ',(cadr option)))
    1853                    (:documentation
    1854                     `(:documentation ',(cadr option)))
    1855                    (t
    1856                      (list `',option-name `',(cdr option))))))
    1857              (canonicalize-slot-spec (slot)
    1858                (if (null slot) (signal-program-error "Illegal slot NIL"))
    1859                (if (not (listp slot)) (setq slot (list slot)))
    1860                (let* ((slot-name (require-type (car slot) 'symbol))
    1861                       (initargs nil)
    1862                       (other-options ())
    1863                       (initform nil)
    1864                       (initform-p nil)
    1865                       (initfunction nil)
    1866                       (type nil)
    1867                       (type-p nil)
    1868                       (allocation nil)
    1869                       (allocation-p nil)
    1870                       (documentation nil)
    1871                       (documentation-p nil)
    1872                       (readers nil)
    1873                       (writers nil))
    1874                  (when (memq slot-name slot-names)
    1875                    (SIGNAL-PROGRAM-error "Multiple slots named ~S in DEFCLASS ~S" slot-name class-name))
    1876                  (push slot-name slot-names)
    1877                  (do ((options (cdr slot) (cddr options))
    1878                       name)
    1879                      ((null options))
    1880                    (when (null (cdr options)) (signal-program-error "Illegal slot spec ~S" slot))
    1881                    (case (car options)
    1882                      (:reader
    1883                       (setq name (cadr options))
    1884                       (push name signatures)
    1885                       (push name readers))
    1886                      (:writer                     
    1887                       (setq name (cadr options))
    1888                       (push name signatures)
    1889                       (push name writers))
    1890                      (:accessor
    1891                       (setq name (cadr options))
    1892                       (push name signatures)
    1893                       (push name readers)
    1894                       (push `(setf ,name) signatures)
    1895                       (push `(setf ,name) writers))
    1896                      (:initarg
    1897                       (push (require-type (cadr options) 'symbol) initargs))
    1898                      (:type
    1899                       (if type-p
    1900                         (duplicate-options slot)
    1901                         (setq type-p t))
    1902                       ;(when (null (cadr options)) (signal-program-error "Illegal options ~S" options))
    1903                       (setq type (cadr options)))
    1904                      (:initform
    1905                       (if initform-p
    1906                         (duplicate-options slot)
    1907                         (setq initform-p t))
    1908                       (let ((option (cadr options)))
    1909                         (setq initform `',option
    1910                               initfunction
    1911                               (if (constantp option)
    1912                                 `(constantly ,option)
    1913                                 `#'(lambda () ,option)))))
    1914                      (:allocation
    1915                       (if allocation-p
    1916                         (duplicate-options slot)
    1917                         (setq allocation-p t))
    1918                       (setq allocation (cadr options)))
     1841    (let* ((readers ())
     1842           (writers ()))
     1843      (setq class-name (require-type class-name '(and symbol (not null))))
     1844      (setq superclasses (mapcar #'(lambda (s) (require-type s 'symbol)) superclasses))
     1845      (let* ((options-seen ())
     1846             (slot-names))
     1847        (flet ((canonicalize-defclass-option (option)
     1848                 (let* ((option-name (car option)))
     1849                   (if (member option-name options-seen :test #'eq)
     1850                     (duplicate-options class-options)
     1851                     (push option-name options-seen))
     1852                   (case option-name
     1853                     (:default-initargs
     1854                         (let ((canonical ())
     1855                               (initargs-seen ()))
     1856                           (let (key val (tail (cdr option)))
     1857                             (loop (when (null tail) (return nil))
     1858                                   (setq key (pop tail)
     1859                                         val (pop tail))
     1860                                   (when (memq key initargs-seen)
     1861                                     (SIGNAL-PROGRAM-error "Duplicate initialization argument name ~S in :DEFAULT-INITARGS of DEFCLASS ~S" key class-name))
     1862                                   (push key initargs-seen)
     1863                                   (push ``(,',key ,',val  ,,(make-initfunction val)) canonical))
     1864                             `(':direct-default-initargs (list ,@(nreverse canonical))))))
     1865                     (:metaclass
     1866                      (unless (and (cadr option)
     1867                                   (typep (cadr option) 'symbol))
     1868                        (illegal-option option))
     1869                      `(:metaclass  ',(cadr option)))
    19191870                     (:documentation
    1920                       (if documentation-p
    1921                         (duplicate-options slot)
    1922                         (setq documentation-p t))
    1923                       (setq documentation (cadr options)))
     1871                      `(:documentation ',(cadr option)))
    19241872                     (t
    1925                       (let* ((pair (or (assq (car options) other-options)
    1926                                        (car (push (list (car options)) other-options)))))
    1927                         (push (cadr options) (cdr pair))))))
    1928                  `(list :name ',slot-name
    1929                    ,@(when allocation `(:allocation ',allocation))
    1930                    ,@(when initform-p `(:initform ,initform
    1931                                         :initfunction ,initfunction))
    1932                    ,@(when initargs `(:initargs ',initargs))
    1933                    ,@(when readers `(:readers ',readers))
    1934                    ,@(when writers `(:writers ',writers))
    1935                    ,@(when type-p `(:type ',type))
    1936                    ,@(when documentation-p `(:documentation ,documentation))
    1937                    ,@(mapcan #'(lambda (opt)
    1938                                  `(',(car opt) ',(if (null (cddr opt))
    1939                                                      (cadr opt)
    1940                                                      (cdr opt)))) other-options)))))
    1941         (let* ((direct-superclasses superclasses)
    1942                (direct-slot-specs (mapcar #'canonicalize-slot-spec slots))
    1943                (other-options (apply #'append (mapcar #'canonicalize-defclass-option class-options ))))
    1944           `(progn
    1945             (eval-when (:compile-toplevel)
    1946               (%compile-time-defclass ',class-name ,env)
    1947               (progn
    1948                 ,@(mapcar #'(lambda (s) `(note-function-info ',s nil ,env))
    1949                           signatures)))
     1873                      (list `',option-name `',(cdr option))))))
     1874               (canonicalize-slot-spec (slot)
     1875                 (if (null slot) (signal-program-error "Illegal slot NIL"))
     1876                 (if (not (listp slot)) (setq slot (list slot)))
     1877                 (let* ((slot-name (require-type (car slot) 'symbol))
     1878                        (initargs nil)
     1879                        (other-options ())
     1880                        (initform nil)
     1881                        (initform-p nil)
     1882                        (initfunction nil)
     1883                        (type nil)
     1884                        (type-p nil)
     1885                        (allocation nil)
     1886                        (allocation-p nil)
     1887                        (documentation nil)
     1888                        (documentation-p nil))
     1889                   (when (memq slot-name slot-names)
     1890                     (SIGNAL-PROGRAM-error "Multiple slots named ~S in DEFCLASS ~S" slot-name class-name))
     1891                   (push slot-name slot-names)
     1892                   (do ((options (cdr slot) (cddr options))
     1893                        name)
     1894                       ((null options))
     1895                     (when (null (cdr options)) (signal-program-error "Illegal slot spec ~S" slot))
     1896                     (case (car options)
     1897                       (:reader
     1898                        (setq name (cadr options))
     1899                        (push name readers))
     1900                       (:writer                     
     1901                        (setq name (cadr options))
     1902                        (push name writers))
     1903                       (:accessor
     1904                        (setq name (cadr options))
     1905                        (push name readers)
     1906                        (push `(setf ,name) writers))
     1907                       (:initarg
     1908                        (push (require-type (cadr options) 'symbol) initargs))
     1909                       (:type
     1910                        (if type-p
     1911                          (duplicate-options slot)
     1912                          (setq type-p t))
     1913                                        ;(when (null (cadr options)) (signal-program-error "Illegal options ~S" options))
     1914                        (setq type (cadr options)))
     1915                       (:initform
     1916                        (if initform-p
     1917                          (duplicate-options slot)
     1918                          (setq initform-p t))
     1919                        (let ((option (cadr options)))
     1920                          (setq initform `',option
     1921                                initfunction
     1922                                (if (constantp option)
     1923                                  `(constantly ,option)
     1924                                  `#'(lambda () ,option)))))
     1925                       (:allocation
     1926                        (if allocation-p
     1927                          (duplicate-options slot)
     1928                          (setq allocation-p t))
     1929                        (setq allocation (cadr options)))
     1930                       (:documentation
     1931                        (if documentation-p
     1932                          (duplicate-options slot)
     1933                          (setq documentation-p t))
     1934                        (setq documentation (cadr options)))
     1935                       (t
     1936                        (let* ((pair (or (assq (car options) other-options)
     1937                                         (car (push (list (car options)) other-options)))))
     1938                          (push (cadr options) (cdr pair))))))
     1939                   `(list :name ',slot-name
     1940                     ,@(when allocation `(:allocation ',allocation))
     1941                     ,@(when initform-p `(:initform ,initform
     1942                                          :initfunction ,initfunction))
     1943                     ,@(when initargs `(:initargs ',initargs))
     1944                     ,@(when readers `(:readers ',readers))
     1945                     ,@(when writers `(:writers ',writers))
     1946                     ,@(when type-p `(:type ',type))
     1947                     ,@(when documentation-p `(:documentation ,documentation))
     1948                     ,@(mapcan #'(lambda (opt)
     1949                                   `(',(car opt) ',(if (null (cddr opt))
     1950                                                       (cadr opt)
     1951                                                       (cdr opt)))) other-options)))))
     1952          (let* ((direct-superclasses superclasses)
     1953                 (direct-slot-specs (mapcar #'canonicalize-slot-spec slots))
     1954                 (other-options (apply #'append (mapcar #'canonicalize-defclass-option class-options )))
     1955                 (reader-args '((#.(encode-lambda-list '(x))) nil))
     1956                 (writer-args '((#.(encode-lambda-list '(x y))) nil)))
     1957            `(progn
     1958              (eval-when (:compile-toplevel)
     1959                (%compile-time-defclass ',class-name ,env)
     1960                (progn                  ,@(mapcar #'(lambda (r) `(record-function-info ',r ',reader-args ,env))
     1961                                                  readers)
     1962                                        ,@(mapcar #'(lambda (w) `(record-function-info ',w ',writer-args ,env))
     1963                                                  writers)))
    19501964              (ensure-class-for-defclass ',class-name
    1951                             :direct-superclasses ',direct-superclasses
    1952                             :direct-slots ,`(list ,@direct-slot-specs)
    1953                             ,@other-options)))))))
     1965               :direct-superclasses ',direct-superclasses
     1966               :direct-slots ,`(list ,@direct-slot-specs)
     1967               ,@other-options))))))))
    19541968
    19551969(defmacro define-method-combination (name &rest rest &environment env)
     
    19701984      `(progn
    19711985         (eval-when (:compile-toplevel)
    1972            (note-function-info ',function-name '(lambda ,lambda-list nil) ,env))
     1986           (record-function-info ',function-name '((,(encode-lambda-list lambda-list)) nil) ,env))
    19731987         (let ((,gf (%defgeneric
    19741988                     ',function-name ',lambda-list ',method-combination ',generic-function-class
Note: See TracChangeset for help on using the changeset viewer.