Changeset 8783


Ignore:
Timestamp:
Mar 14, 2008, 11:16:46 AM (12 years ago)
Author:
gb
Message:

Lower-level-part of NOTE-FUNCTION-INFO (RECORD-FUNXTION-INFO) implemented
here. Use it to record compile-time info about GFs and methods, slot
accessors.

File:
1 edited

Legend:

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

    r8771 r8783  
    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)
     
    16801689(defsetf type-predicate set-type-predicate)
    16811690
    1682 (defun adjust-defmethod-lambda-list (ll)
    1683   ;; If the lambda list contains &key, ensure that it also contains
    1684   ;; &allow-other-keys
    1685   (if (or (not (memq '&key ll))
    1686           (memq '&allow-other-keys ll))
    1687     ll
    1688     (if (memq '&aux ll)
    1689       (let* ((ll (copy-list ll))
    1690              (aux (memq '&aux ll)))
    1691         (setf (car aux) '&allow-other-keys
    1692               (cdr aux) (cons '&aux (cdr aux)))
    1693         ll)
    1694       (append ll '(&allow-other-keys)))))
     1691(defun encode-gf-lambda-list (lambda-list)
     1692  (let* ((bits (encode-lambda-list lambda-list)))
     1693    (declare (fixnum bits))
     1694    (if (logbitp $lfbits-keys-bit bits)
     1695      (logior bits (ash 1 $lfbits-aok-bit))
     1696      bits)))
    16951697       
    16961698(defmacro defmethod (name &rest args &environment env)
     
    16991701    `(progn
    17001702      (eval-when (:compile-toplevel)
    1701         (note-function-info ',name '(lambda ,(adjust-defmethod-lambda-list lambda-list)) ,env))
     1703        (record-function-info ',(maybe-setf-function-name name)
     1704                              ',(list (list (encode-gf-lambda-list
     1705                                             lambda-list)))
     1706                              ,env))
    17021707      (compiler-let ((*nx-method-warning-name*
    17031708                      (list ',name
     
    18701875                      (documentation nil)
    18711876                      (documentation-p nil)
    1872                       (readers nil)
    1873                       (writers nil))
     1877                      (readers nil)
     1878                      (writers nil)
     1879                      (reader-info (list (cons (dpb 1 $lfbits-numreq 0) nil)))
     1880                      (writer-info (list (cons (dpb 2 $lfbits-numreq 0) nil))))
    18741881                 (when (memq slot-name slot-names)
    18751882                   (SIGNAL-PROGRAM-error "Multiple slots named ~S in DEFCLASS ~S" slot-name class-name))
     
    18821889                     (:reader
    18831890                      (setq name (cadr options))
    1884                       (push name signatures)
     1891                      (push (cons name reader-info) signatures)
    18851892                      (push name readers))
    18861893                     (:writer                     
    18871894                      (setq name (cadr options))
    1888                       (push name signatures)
     1895                      (push (cons name writer-info) signatures)
    18891896                      (push name writers))
    18901897                     (:accessor
    18911898                      (setq name (cadr options))
    1892                       (push name signatures)
     1899                      (push (cons name reader-info) signatures)
    18931900                      (push name readers)
    1894                       (push `(setf ,name) signatures)
     1901                      (push (cons (setf-function-name name) writer-info) signatures)
    18951902                      (push `(setf ,name) writers))
    18961903                     (:initarg
     
    19461953              (%compile-time-defclass ',class-name ,env)
    19471954              (progn
    1948                 ,@(mapcar #'(lambda (s) `(note-function-info ',s nil ,env))
     1955                ,@(mapcar #'(lambda (sig) `(record-function-info ',(car sig) ',(cdr sig) ,env))
    19491956                          signatures)))
    19501957              (ensure-class-for-defclass ',class-name
     
    19701977      `(progn
    19711978         (eval-when (:compile-toplevel)
    1972            (note-function-info ',function-name '(lambda ,lambda-list nil) ,env))
     1979           (record-function-info ',(maybe-setf-function-name function-name)
     1980                                 ',(list (list (encode-gf-lambda-list lambda-list)))
     1981                                 ,env))
    19731982         (let ((,gf (%defgeneric
    19741983                     ',function-name ',lambda-list ',method-combination ',generic-function-class
Note: See TracChangeset for help on using the changeset viewer.