Changeset 11067


Ignore:
Timestamp:
Oct 12, 2008, 4:28:23 PM (11 years ago)
Author:
gz
Message:

Move parse-definition-spec to xref.lisp. Record-source-file for setf-expanders and long-form defsetf. Make compiler-macro-definition-type be a subtype of macro-definition-type, ditto for symbol-macro and setf-expander. Add find-definitions-for-name.

Location:
trunk/source/lib
Files:
3 edited

Legend:

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

    r10722 r11067  
    179179                       (parse-macro-1 access-fn lambda-list body)
    180180    `(eval-when (load compile eval)
     181       (record-source-file ',access-fn 'setf-expander)
    181182       (store-setf-method ',access-fn
    182183                          (nfunction ,access-fn ,lambda-form)
     
    237238                   (environment (gensym)))
    238239              `(eval-when (:compile-toplevel :load-toplevel :execute)
     240                 (record-source-file ',access-fn 'setf-expander)
    239241                 (store-setf-method
    240242                  ',access-fn
  • trunk/source/lib/source-files.lisp

    r11045 r11067  
    209209(define-definition-type macro (function-definition-type))
    210210
    211 (define-definition-type compiler-macro (function-definition-type))
    212 
    213 (define-definition-type symbol-macro (function-definition-type))
    214 
    215 (define-definition-type setf-expander (function-definition-type))
     211(define-definition-type compiler-macro (macro-definition-type))
     212
     213(define-definition-type symbol-macro (macro-definition-type))
     214
     215(define-definition-type setf-expander (macro-definition-type))
    216216
    217217(define-definition-type generic-function (function-definition-type))
     
    382382         (default-definition-type (%car entry)))))
    383383
    384 (defun def-source-entry.files (key entry)
     384(defun def-source-entry.sources (key entry)
    385385  (declare (ignore key))
    386386  (cond ((consp entry)
     
    526526                  (method-qualifiers y)))))
    527527
    528 (defun source-files-like-em (classes qualifiers method)
    529   (and (equal (canonicalize-specializers classes)
    530               (%method-specializers method))
    531        (or (eq qualifiers t)
    532            (equal qualifiers (%method-qualifiers method)))))
    533 
    534 (defun parse-definition-spec (form)
    535   (let ((type t)
    536         name classes qualifiers)
    537     (cond
    538      ((consp form)
    539       (cond ((eq (car form) 'setf)
    540              (setq name form))
    541             (t (setq name (car form))
    542                (let ((last (car (last (cdr form)))))
    543                  (cond ((and (listp last)(or (null last)(neq (car last) 'eql)))
    544                         (setq classes last)
    545                         (setq qualifiers (butlast (cdr form))))
    546                        (t (setq classes (cdr form)))))                   
    547                (cond ((null qualifiers)
    548                       (setq qualifiers t))
    549                      ((equal qualifiers '(:primary))
    550                       (setq qualifiers nil))))))
    551      (t (setq name form)))
    552     (when (and (consp name)(eq (car name) 'setf))
    553         (setq name (or (%setf-method (cadr name)) name))) ; e.g. rplacd
    554     (when (not (or (symbolp name)
    555                    (setf-function-name-p name)))
    556       (return-from parse-definition-spec))
    557     (when (consp qualifiers)
    558       (mapc #'(lambda (q)
    559                 (when (listp q)
    560                   (return-from parse-definition-spec)))
    561           qualifiers))
    562     (when classes
    563       (mapc #'(lambda (c)
    564                 (when (not (and c (or (symbolp c)(and (consp c)(eq (car c) 'eql)))))
    565                   (return-from parse-definition-spec)))
    566             classes))           
    567     (when (or (consp classes)(consp qualifiers))(setq type 'method))
    568     (values type name classes qualifiers)))
    569 
    570 
    571 
    572528(defun edit-definition-p (name &optional (type t)) ;exported
    573529  (let ((specs (get-source-files-with-types name type)))
     
    620576      (push (cons 'method meth-list) type-list))
    621577    type-list))
     578
     579;;; For swank.
     580
     581(defun find-definitions-for-name (name &optional (type-name t))
     582  "Returns a list of (TYPE . DEFINITION-SOURCE) for all the known definitions of NAME."
     583  (let ((definitions ()))
     584    (loop for ((dt . full-name) last-source . nil)
     585            in (find-definition-sources name type-name)
     586          do (when last-source
     587               (push (list dt full-name last-source) definitions)))
     588    definitions))
     589
     590(defun find-simple-definitions-for-name (name)
     591  (let* ((result (find-definitions-for-name name)))
     592    (dolist (pair result result)
     593      (let* ((dt (car pair)))
     594        (when (typep dt 'definition-type)
     595          (setf (car pair) (definition-type-name dt)))))))
    622596
    623597;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
    660634          do (when (and (eq dt (def-source-entry.type key entry))
    661635                        (definition-same-p dt name (def-source-entry.name key entry)))
    662                (setq e-files (def-source-entry.files key entry))
     636               (setq e-files (def-source-entry.sources key entry))
    663637               (let ((old (flet ((same-file (x y)
    664638                                   (or (equal x y)
     
    681655              name
    682656              (car e-files)
    683               (if (eq file-name :interactive) "{No file}" file-name)))
     657              (or file-name "{No file}")))
    684658      (setq e-files (cons file-name e-files)))
    685659    (let ((entry (make-def-source-entry key dt name e-files)))
  • trunk/source/lib/xref.lisp

    r6204 r11067  
    196196                            :method-qualifiers (unless (eql qualifiers t) qualifiers)
    197197                            :method-specializers specializers)))))))
     198
     199(defun parse-definition-spec (form)
     200  (let ((type t)
     201        name classes qualifiers)
     202    (cond
     203     ((consp form)
     204      (cond ((eq (car form) 'setf)
     205             (setq name form))
     206            (t (setq name (car form))
     207               (let ((last (car (last (cdr form)))))
     208                 (cond ((and (listp last)(or (null last)(neq (car last) 'eql)))
     209                        (setq classes last)
     210                        (setq qualifiers (butlast (cdr form))))
     211                       (t (setq classes (cdr form)))))                   
     212               (cond ((null qualifiers)
     213                      (setq qualifiers t))
     214                     ((equal qualifiers '(:primary))
     215                      (setq qualifiers nil))))))
     216     (t (setq name form)))
     217    (when (and (consp name)(eq (car name) 'setf))
     218        (setq name (or (%setf-method (cadr name)) name))) ; e.g. rplacd
     219    (when (not (or (symbolp name)
     220                   (setf-function-name-p name)))
     221      (return-from parse-definition-spec))
     222    (when (consp qualifiers)
     223      (mapc #'(lambda (q)
     224                (when (listp q)
     225                  (return-from parse-definition-spec)))
     226          qualifiers))
     227    (when classes
     228      (mapc #'(lambda (c)
     229                (when (not (and c (or (symbolp c)(and (consp c)(eq (car c) 'eql)))))
     230                  (return-from parse-definition-spec)))
     231            classes))           
     232    (when (or (consp classes)(consp qualifiers))(setq type 'method))
     233    (values type name classes qualifiers)))
    198234
    199235;; XREF-ENTRY-EQUAL -- external
Note: See TracChangeset for help on using the changeset viewer.