Changeset 8866


Ignore:
Timestamp:
Mar 22, 2008, 4:57:04 AM (11 years ago)
Author:
gb
Message:

RECORD-FUNCTION-INFO here.

Use it in DEFGENERIC/DEFMETHOD, DEFCLASS accessor methods.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/lib/macros.lisp

    r8764 r8866  
    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 name (defenv.defined definition-env))))
     623        (if already
     624          (if info (%rplacd already info))
     625          (push (cons name info) (defenv.defined definition-env)))
     626        info))))
     627
    619628;; ---- allow inlining setf functions
    620629(defmacro defun (spec args &body body &environment env &aux global-name inline-spec)
     
    16941703      (append ll '(&allow-other-keys)))))
    16951704
     1705(defun encode-gf-lambda-list (lambda-list)
     1706  (let* ((bits (encode-lambda-list lambda-list)))
     1707    (declare (fixnum bits))
     1708    (if (logbitp $lfbits-keys-bit bits)
     1709      (logior bits (ash 1 $lfbits-aok-bit))
     1710      bits)))
     1711
    16961712(defmacro defmethod (name &rest args &environment env)
    16971713  (multiple-value-bind (function-form specializers-form qualifiers lambda-list documentation specializers)
     
    16991715    `(progn
    17001716       (eval-when (:compile-toplevel)
    1701          (note-function-info ',name '(lambda ,(adjust-defmethod-lambda-list lambda-list)) ,env))
     1717         (record-function-info ',(maybe-setf-function-name name)
     1718                              ',(list (list (encode-gf-lambda-list
     1719                                             lambda-list)))
     1720                              ,env))
    17021721       (compiler-let ((*nx-method-warning-name*
    17031722                       (list ',name
     
    18701889                      (documentation nil)
    18711890                      (documentation-p nil)
    1872                       (readers nil)
    1873                       (writers nil))
     1891                      (readers nil)
     1892                      (writers nil)
     1893                      (reader-info (list (cons (dpb 1 $lfbits-numreq 0) nil)))
     1894                      (writer-info (list (cons (dpb 2 $lfbits-numreq 0) nil))))
    18741895                 (when (memq slot-name slot-names)
    18751896                   (SIGNAL-PROGRAM-error "Multiple slots named ~S in DEFCLASS ~S" slot-name class-name))
     
    18821903                     (:reader
    18831904                      (setq name (cadr options))
    1884                       (push name signatures)
     1905                      (push (cons name reader-info) signatures)
    18851906                      (push name readers))
    18861907                     (:writer                     
    18871908                      (setq name (cadr options))
    1888                       (push name signatures)
     1909                      (push (cons name writer-info) signatures)
    18891910                      (push name writers))
    18901911                     (:accessor
    18911912                      (setq name (cadr options))
    1892                       (push name signatures)
     1913                      (push (cons name reader-info) signatures)
    18931914                      (push name readers)
    1894                       (push `(setf ,name) signatures)
     1915                      (push (cons (setf-function-name name) writer-info) signatures)
    18951916                      (push `(setf ,name) writers))
    18961917                     (:initarg
     
    19461967              (%compile-time-defclass ',class-name ,env)
    19471968              (progn
    1948                 ,@(mapcar #'(lambda (s) `(note-function-info ',s nil ,env))
     1969                ,@(mapcar #'(lambda (sig) `(record-function-info ',(car sig) ',(cdr sig) ,env))
    19491970                          signatures)))
    19501971              (ensure-class-for-defclass ',class-name
     
    19641985
    19651986(defmacro defgeneric (function-name lambda-list &rest options-and-methods &environment env)
    1966   (fboundp function-name)             ; type-check
     1987  (fboundp function-name)               ; type-check
    19671988  (multiple-value-bind (method-combination generic-function-class options methods)
    1968                        (parse-defgeneric function-name t lambda-list options-and-methods)
     1989      (parse-defgeneric function-name t lambda-list options-and-methods)
    19691990    (let ((gf (gensym)))
    19701991      `(progn
    1971          (eval-when (:compile-toplevel)
    1972            (note-function-info ',function-name '(lambda ,lambda-list nil) ,env))
    1973          (let ((,gf (%defgeneric
    1974                      ',function-name ',lambda-list ',method-combination ',generic-function-class
    1975                      ',(apply #'append options))))
    1976            (%set-defgeneric-methods ,gf ,@methods)
    1977            ,gf)))))
     1992        (eval-when (:compile-toplevel)
     1993          (record-function-info ',(maybe-setf-function-name function-name)
     1994                                 ',(list (list (encode-gf-lambda-list lambda-list)))
     1995                                 ,env))
     1996        (let ((,gf (%defgeneric
     1997                    ',function-name ',lambda-list ',method-combination ',generic-function-class
     1998                    ',(apply #'append options))))
     1999          (%set-defgeneric-methods ,gf ,@methods)
     2000          ,gf)))))
    19782001
    19792002
Note: See TracChangeset for help on using the changeset viewer.