Changeset 11039


Ignore:
Timestamp:
Oct 10, 2008, 8:54:17 PM (11 years ago)
Author:
gz
Message:

Moved record-source-file from l1-utils to lib;source-files.

From the working-0711 branch: make the definition types used in record
source file be instances so they can specialize behaviors. Modified to
have a simplier api, to have more internal functionality go through
definition-type gf's, and to not require definition types to be
pre-defined.

While in there, made it issue load-time redefinition warnings for
methods as well as functions, and added a mechanism to get rid of
many of the duplicate conses that record-source-file used to create.

Note that this doesn't change the 'file' part of record-source-file,
just the behind-the-scenes handling of the definition-type arg.

Location:
trunk/source
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-1/l1-utils.lisp

    r10942 r11039  
    4040(%fhave 'full-pathname (qlfun bootstrapping-full-pathname (name) name))
    4141
    42 (%fhave '%source-files (qlfun bootstrapping-%source-files (name)
    43                          (get name 'bootstrapping-source-files)))
    44 (%fhave '%set-source-files (qlfun bootstrapping-%set-source-files (name value)
    45                              (put name 'bootstrapping-source-files value)))
    46 
    47 
    48 
    49 
    5042
    5143; real one is  in setf.lisp
     
    5345                                   spec nil))
    5446
    55 ; this new thing breaks for case of a function being defined in non-file place
    56 ; use some euphemism for that such as t or "{No file}"
    57 ; something is broken (probably) here calling assq with garbage
    58 
    59 
    60 (defun source-file-or-files (symbol type setf-p method)
    61   (let ((source-files-info (%source-files symbol))   
    62         assoc-pair files)
    63     (cond ((null (consp source-files-info))
    64            (values source-files-info
    65                    nil
    66                    (if (and source-files-info (eq type 'function)(not setf-p)) source-files-info)))
    67           (t (setq assoc-pair (assq type (if setf-p
    68                                            (cdr (assq 'setf source-files-info))
    69                                            source-files-info)))
    70              (if (neq type 'method)
    71                (setq files assoc-pair)
    72                (setq files
    73                      (do* ((lst (cdr assoc-pair) (cdr lst))
    74                            (clst (car lst)(car lst)))
    75                           ((null lst) nil)
    76                        (when (consp clst)
    77                          (when (or (eq method (car clst))  ; method is a place holder for q's and s's
    78                                    (and (methods-congruent-p method (car clst))
    79                                         ; below avoids clutter
    80                                         (rplaca clst method)))
    81                            (return clst))))))
    82              (values source-files-info assoc-pair files)))))
    83 
    84 
    85 ;;; warn if defining in no file iff previously defined in a file
    86 ;;; (i.e. dont warn every time something gets redefined in the
    87 ;;; listener) fix to not to bitch if file is anywhere in list name is
    88 ;;; function-name or (method-name (class-names)) or ((setf
    89 ;;; method-name) (class-names)) store('method (method file file)
    90 ;;; (method file file) ...)  if type is 'method we expect name to be
    91 ;;; an actual method Remember to smash old methods with newer methods
    92 ;;; to avoid clutter - done
    93 
    9447(fset 'physical-pathname-p (lambda (file)(declare (ignore file)) nil)) ; redefined later
    9548
     
    9750;(%defvar *enqueued-window-title* nil)
    9851
    99 (fset 'booted-probe-file (lambda (file) (declare (ignore file)) nil))
    100 
    101 (queue-fixup
    102  (defun booted-probe-file (file)
    103    (probe-file file)))
    104 
    105 (defun record-source-file (name def-type
    106                                 &optional (file-name *loading-file-source-file*)) 
    107   (let (symbol setf-p method old-file)
    108     (flet ((same-file (x y)
    109              (or (eq x y)
    110                  ;; funny because equal not defined before us
    111                  (and x
    112                       y
    113                       (or (equal x y)
    114                           (equal
    115                            (or (booted-probe-file x) (full-pathname x))
    116                            (or (booted-probe-file y) (full-pathname y))))))))
    117       (when (and *record-source-file* ) ;file-name)
    118         (when (and file-name (physical-pathname-p file-name))
    119           (setq file-name (namestring (back-translate-pathname file-name)))
    120           (cond ((equalp file-name *last-back-translated-name*)
    121                  (setq file-name *last-back-translated-name*))
    122                 (t (setq *last-back-translated-name* file-name))))
    123         (when (eq t def-type) (report-bad-arg def-type '(not (eql t))))
    124         (cond ((eq def-type 'method)
    125                (setq method name symbol (%method-name name) name nil))
    126               ((consp name)
    127                (cond ((neq (car name) 'setf)
    128                       (warn "record-source-file hates ~s" name))
    129                      (t (setq symbol name))))
    130               ((symbolp name) (setq symbol name)))
    131         (cond ((and (consp symbol)(eq (car symbol) 'setf))
    132                (let ((tem (%setf-method (cadr symbol))))
    133                  (if tem
    134                    (setq symbol tem)
    135                    (progn (setq symbol (cadr symbol))
    136                           (setq setf-p t))))))
    137         ;; assoc-pair is e.g. (function file1 ...)  or (class . file)
    138         ;; or (method (method-object file1 ...) ...) or (method
    139         ;; (method-object . file) ...)
    140         (when (symbolp symbol)          ; avoid boot problems - you thought
    141           (multiple-value-bind (source-files-info assoc-pair files)
    142               (source-file-or-files symbol def-type setf-p method)
    143             (setq old-file
    144                   (cond ((consp files)
    145                          (if (consp (cdr files)) (cadr files) (cdr files)))
    146                         (t files)))
    147             (unless
    148                 (if (or (not (consp files))(not (consp (cdr files))))
    149                   (same-file old-file file-name)
    150                   (do ((lst (cdr files)(cdr lst)))
    151                       ((null (consp lst)) nil)
    152                     (when (same-file file-name (car lst))
    153                       (rplaca lst (cadr files))
    154                       (rplaca (cdr files) file-name)
    155                       (return t))))
    156               (when (and *warn-if-redefine*
    157                          (neq def-type 'method) ; This should be more specific
    158                          (cond ((eq def-type 'function)
    159                                 (and (fboundp name) old-file))
    160                                (t old-file)))
    161                 (warn " ~S ~S previously defined in: ~A
    162          is now being redefined in: ~A~%"
    163                       def-type
    164                       name
    165                       (or old-file "{Not Recorded}")
    166                       (or file-name "{No file}")))
    167               (if (consp files)
    168                 (%rplacd files (cons file-name
    169                                      (if (consp (cdr files))(cdr files)(list (cdr files)))))
    170                
    171                 (if assoc-pair
    172                   (%rplacd assoc-pair (cons (if (eq def-type 'method)
    173                                               `(,method . , file-name)
    174                                               file-name)
    175                                             (if (consp (%cdr assoc-pair))
    176                                               (%cdr assoc-pair)
    177                                               (list (%cdr assoc-pair)))))
    178                   (%set-source-files
    179                    symbol
    180                    (cond ((and (eq def-type 'function)
    181                                (null setf-p)
    182                                (not (consp  source-files-info)))
    183                           (if (null old-file)
    184                             file-name
    185                             `((function ,file-name ,old-file))))
    186                          (t
    187                           (when (and source-files-info
    188                                      (not (consp source-files-info)))
    189                             (setq source-files-info `((function . , source-files-info))))
    190                           (let ((thing (if (neq def-type 'method)
    191                                          `(,def-type . ,file-name)
    192                                          `(,def-type (,method . ,file-name)))))
    193                             (cons (if setf-p `(setf ,thing) thing) source-files-info))))))))
    194             ))))))
    195 
    196 (record-source-file 'record-source-file 'function)
    197 
     52(fset 'level-1-record-source-file
     53      (qlfun level-1-record-source-file (name def-type &optional (file-name *loading-file-source-file*))
     54        ;; Level-0 puts stuff on plist of name.  Once we're in level-1, names can
     55        ;; be more complicated than just a symbol, so just collect all calls until
     56        ;; the real record-source-file is loaded.
     57        (when *record-source-file*
     58          (unless (listp *record-source-file*)
     59            (setq *record-source-file* nil))
     60          (push (list name def-type file-name) *record-source-file*))))
     61
     62(fset 'record-source-file #'level-1-record-source-file)
    19863
    19964(defun inherit-from-p (ob parent)
  • trunk/source/lib/source-files.lisp

    r6922 r11039  
    1717(in-package "CCL")
    1818
    19 (defvar %source-files% (let ((a (make-hash-table :test #'eq
    20                                                  :weak t
    21                                                  :size 7000
    22                                                  :rehash-threshold .9)))
    23                          (do-all-symbols (s)
    24                            (let ((f (get s 'bootstrapping-source-files)))
    25                              (when f
    26                                (setf (gethash s a) f)
    27                                (remprop s 'bootstrapping-source-files))))
    28                          a))
    29 
    30 (%fhave '%source-files (qlfun %source-files (name)
    31                          (gethash name %source-files%)))
    32 (%fhave '%set-source-files (qlfun %set-source-files (name value)
    33                              (puthash name %source-files% value)))
     19#-BOOTSTRAPPED (unless (fboundp 'level-1-record-source-file)
     20                 ;; We're in a lisp image with old rsf.
     21                 (fset 'level-1-record-source-file (lambda (&rest args) args))
     22                 (when (boundp '%source-files%)
     23                   (clrhash %source-files%)))
     24
     25;; If we're reloading this file, don't want to be calling functions from here with
     26;; only some of them redefined.  So revert to the bootstrapping version until the end.
     27(fset 'record-source-file #'level-1-record-source-file)
     28
     29(defvar *source-files-lock* (make-lock "Source Files Lock"))
     30
     31(defvar *unique-setf-names* (make-hash-table :test #'eq))
     32
     33(defun canonical-maybe-setf-name (name)
     34  (if (setf-function-name-p name)
     35    (let ((tem (%setf-method (%cadr name))))
     36      (if (non-nil-symbol-p tem) ;; e.g. (setf car) => set-car
     37        tem
     38        (or (gethash (%cadr name) *unique-setf-names*)
     39            (setf (gethash (%cadr name) *unique-setf-names*) (list 'setf (%cadr name))))))
     40    name))
     41
     42(defgeneric name-of (thing)
     43  (:method ((thing t)) thing)
     44  (:method ((thing function)) (name-of (function-name thing)))
     45  (:method ((thing method)) (method-name thing))
     46  (:method ((thing class)) (class-name thing))
     47  (:method ((thing method-combination)) (method-combination-name thing))
     48  (:method ((thing package)) (package-name thing)))
     49
     50;; This used to be weak, but the keys are symbols-with-definitions, so why bother.
     51;; Set a high rehash threshold because space matters more than speed here.
     52(defvar %source-files% (make-hash-table :test #'eq
     53                                        :size 13000
     54                                        :rehash-threshold .95))
     55
     56;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     57;;
     58;; Definition types
     59;;
     60;; Definition types are uniquely identified by a symbol, but are implemented as
     61;; classes so they can inherit/customize behavior.  They have no instances other
     62;; than the class prototype, which is used to invoke methods.
     63;;
     64
     65(defgeneric definition-type-name (def-type)
     66  (:documentation "The preferred user-visible name of the def-type.  Used for
     67error messages etc.  The default method returns the name specified in
     68define-definition-type."))
     69
     70(defclass definition-type ()
     71  ((name :allocation :class :reader definition-type-name))
     72  (:documentation "Superclass of all definition types"))
     73
     74(defgeneric definition-base-name (def-type def)
     75  ;; Note that a def can have multiple base names, but each one needs a different def-type
     76  (:documentation "Return the name that, when the user asks for all definitions of that
     77name, this def should be included.  Typically this is a symbol.  It's used as a key in
     78an EQ hash table, so must return EQ values for equivalent definitions.
     79The default method returns the rightmost atom in name")
     80  (:method ((dt definition-type) name)
     81    (while (consp name)
     82      (let ((x (last name)))
     83        (setq name (or (cdr x) (car x)))))
     84    name))
     85
     86(defgeneric definition-same-p (def-type def1 def2)
     87  (:documentation "Returns true if the two definitions are equivalent, i.e. one should
     88replace the other.  The default method calls EQUAL.")
     89  (:method ((dt definition-type) name1 name2)
     90    (equal name1 name2)))
     91
     92(defgeneric definition-bound-p (def-type def)
     93  (:documentation "Returns true if def is currently defined.  Used to decide whether to issue
     94redefinition warnings.  The default method returns T.")
     95  (:method ((dt definition-type) name)
     96    (declare (ignore name))
     97    t))
     98
     99;;;;;;;;;;
     100
     101(defvar *definition-types* ()
     102  "alist of all known definition type names and their class prototypes")
     103
     104(defmethod print-object ((dt definition-type) stream)
     105  (if *print-escape*
     106    (let ((definedp (class-name (class-of dt))))
     107      (print-unreadable-object (dt stream :type definedp :identity t)
     108        (unless definedp
     109          (format stream "#:~s " 'definition-type)) ;; subtly indicate it's a subclass...
     110        (format stream "~s" (definition-type-name dt))))
     111    (format stream "~s" (definition-type-name dt))))
     112
     113(defmethod name-of ((thing definition-type))
     114  (definition-type-name thing))
     115
     116(defmacro define-definition-type (name supers &rest options)
     117  "Defines a class named name-DEFINITION-TYPE and registers it as the class of
     118definition type NAME"
     119  (loop with known-keys = '( ;; Backward compatibility
     120                            #+ccl-0711 :default-name-function)
     121        for (key . nil) in options
     122        unless (memq key known-keys)
     123          do (signal-program-error "Unknown option ~s" key))
     124  (let ((class-name (intern (%str-cat (symbol-name name) "-DEFINITION-TYPE"))))
     125    `(progn
     126       (defclass ,class-name ,(or supers '(definition-type))
     127         ((name :allocation :class :initform ',name)))
     128       (record-source-file ',name 'definition-type)
     129       (register-definition-type (find-class ',class-name) '(,name)))))
     130
     131(defun register-definition-type (class names)
     132  (let ((instance (class-prototype class)))
     133    (with-lock-grabbed (*source-files-lock*)
     134      ;; If had a previous definition, the defclass will signal any duplicate
     135      ;; definition warnings, so here just silently replace previous one.
     136      (without-interrupts
     137        (setq *definition-types*
     138              (remove instance *definition-types* :key #'cdr)))
     139      (loop for name in names
     140            unless (without-interrupts
     141                     (unless (assq name *definition-types*)
     142                       (push (cons name instance) *definition-types*)))
     143              do (error "There is already a different definition type ~s named ~s"
     144                        (cdr (assq name *definition-types*))
     145                        name)))
     146    ;; Return instance for use in make-load-form
     147    instance))
     148
     149(defun auto-create-definition-type (name)
     150  ;; Use an anonymous class, so this means can't write methods on it.
     151  ;; If you want to write methods on it, use define-definition-type first.
     152  (let* ((super (find-class 'definition-type))
     153         (new-class (make-instance (class-of super)
     154                      :direct-superclasses (list super)
     155                      :direct-slots `((:name name
     156                                       :allocation :class
     157                                       :initform ',name
     158                                       :initfunction ,(constantly name))))))
     159    (register-definition-type new-class (list name))
     160    (class-prototype new-class)))
     161
     162(defmethod definition-type-instance ((dt definition-type) &key (if-does-not-exist :error))
     163  (if (rassoc dt *definition-types* :test #'eq)
     164    dt
     165    (ecase if-does-not-exist
     166      ((nil) nil)
     167      ((:error) (error "~s is not a known definition-type" dt)))))
     168
     169(defmethod definition-type-instance ((name symbol) &key (if-does-not-exist :error))
     170  (or (cdr (assq name *definition-types*))
     171      (ecase if-does-not-exist
     172        ((nil) nil)
     173        ((:error) (error "~s is not a known definition-type" name))
     174        ((:create) (auto-create-definition-type name)))))
     175
     176(defmethod definition-type-instance ((class class) &key (if-does-not-exist :error))
     177  (definition-type-instance (class-prototype class) :if-does-not-exist if-does-not-exist))
     178
     179(defmethod make-load-form ((dt definition-type) &optional env)
     180  (declare (ignore env))
     181  (let ((names (loop for (name . instance) in *definition-types*
     182                     when (eq dt instance) collect name)))
     183    `(register-definition-type ',(class-of dt) ',names)))
     184
     185
     186(register-definition-type (find-class 'definition-type) '(t))
     187
     188(defparameter *t-definition-type* (definition-type-instance 't))
     189
     190(define-definition-type function ())
     191
     192(defparameter *function-definition-type* (definition-type-instance 'function))
     193
     194;; TODO: what about (:internal .... (method-name quals specs)) ?
     195(defmethod definition-base-name ((dt function-definition-type) name)
     196  (while (consp name)
     197    (if (setf-function-name-p name)
     198      (return-from definition-base-name (canonical-maybe-setf-name name))
     199      (let ((x (last name)))
     200        (setq name (or (cdr x) (car x))))))
     201  name)
     202
     203(defmethod definition-bound-p ((dt function-definition-type) name)
     204  (and (or (symbolp name) (setf-function-name-p name))
     205       (or (fboundp name)
     206           ;; treat long-form setf expanders like macros.
     207           (and (consp name) (functionp (%setf-method (cadr name)))))))
     208
     209(define-definition-type macro (function-definition-type))
     210
     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))
     216
     217(define-definition-type generic-function (function-definition-type))
     218
     219(define-definition-type method ())
     220
     221(defparameter *method-definition-type* (definition-type-instance 'method))
     222
     223(defmethod definition-base-name ((dt method-definition-type) (name cons))
     224  (if (setf-function-name-p name)
     225    name
     226    (definition-base-name *function-definition-type* (car name))))
     227
     228;; defmethod passes the actual method into record-source-file
     229(defmethod definition-base-name ((dt method-definition-type) (method method))
     230  (definition-base-name dt (method-name method)))
     231
     232(defmethod definition-same-p ((dt method-definition-type) m1 m2)
     233  (multiple-value-bind (n1 q1 s1) (method-def-parameters m1)
     234    (multiple-value-bind (n2 q2 s2) (method-def-parameters m2)
     235      (and (definition-same-p *function-definition-type* n1 n2)
     236           (equal q1 q2)
     237           (eql (length s1) (length s2))
     238           (every #'(lambda (s1 s2)
     239                      (or (equal s1 s2)
     240                          (progn
     241                            (when (symbolp s2) (rotatef s1 s2))
     242                            (and (symbolp s1)
     243                                 (classp s2)
     244                                 (or (eq (find-class s1 nil) s2)
     245                                     (eq s1 (class-name s2)))))))
     246                  s1 s2)))))
     247
     248(defmethod definition-bound-p ((dt method-definition-type) meth &aux fn)
     249  (when (setq fn (method-def-parameters meth))
     250    (loop for m in (and (setq fn (fboundp fn))
     251                        (typep fn 'generic-function)
     252                        (generic-function-methods fn))
     253          thereis (definition-same-p dt meth m))))
     254
     255(define-definition-type reader-method (method-definition-type))
     256
     257(define-definition-type writer-method (method-definition-type))
     258
     259(define-definition-type callback (function-definition-type))
     260
     261(define-definition-type structure-accessor (function-definition-type))
     262
     263(define-definition-type type ())
     264
     265(define-definition-type class ())
     266
     267(defmethod definition-bound-p ((dt class-definition-type) name)
     268  (and (non-nil-symbol-p name) (find-class name nil)))
     269
     270(define-definition-type condition (class-definition-type))
     271
     272(define-definition-type structure ())
     273
     274(define-definition-type definition-type ())
     275
     276(defmethod definition-bound-p ((dt definition-type-definition-type) name)
     277  (definition-type-instance name :if-does-not-exist nil))
     278
     279(define-definition-type method-combination ())
     280
     281(define-definition-type variable ())
     282
     283(defmethod definition-bound-p ((dt variable-definition-type) name)
     284  (and (non-nil-symbol-p name) (boundp name)))
     285
     286(define-definition-type constant (variable-definition-type))
     287
     288(define-definition-type package ())
     289
     290(defmethod definition-base-name ((dt package-definition-type) name)
     291  (if (or (stringp name) (non-nil-symbol-p name))
     292    (intern (string name) :keyword)
     293    name))
     294
     295(defmethod definition-bound-p ((dt package-definition-type) name)
     296  (and (or (stringp name) (symbolp name))
     297       (find-package (string name))))
     298
     299(defmethod definition-same-p ((dt package-definition-type) d1 d2)
     300  (and (or (stringp d1) (symbolp d1))
     301       (or (stringp d2) (symbolp d2))
     302       (equal (string d1) (string d2))))
     303
     304
     305;;;;;;;;;;;
     306
     307(declaim (inline default-definition-type))
     308
     309(defun default-definition-type (name)
     310  (if (typep name 'method)
     311    *method-definition-type*
     312    *function-definition-type*))
     313
     314;; remember & reuse last few (TYPE . file) entries
     315(let ((cache (make-list 10 :initial-element nil)))
     316  (defun type-file-cons (type files)
     317    (loop for prev = nil then p for p = cache then (cdr p)
     318          do (when (or (and (eq type (caar p)) (equal files (cdar p)))
     319                       (and (null (cdr p))
     320                            (setf (car p) (cons type files))))
     321               (when prev ;; move to front unless already there
     322                 (setf (cdr prev) (cdr p))
     323                 (setf (cdr p) cache)
     324                 (setq cache p))
     325               (return (car p))))))
     326
     327(defun %source-file-entries (key)
     328  (let ((data (gethash key %source-files%)))
     329    (if (and (listp data)
     330             (listp (%cdr data)))
     331      data
     332      (list data))))
     333
     334(defun %set-source-file-entries (key list &aux data)
     335  (setf (gethash key %source-files%)
     336        (if (and list
     337                 (null (cdr list))
     338                 ;; One element, but make sure can recognize it.
     339                 (not (and (listp (%car list))
     340                           (listp (%cdar data)))))
     341          (car list)
     342          list)))
     343
     344(defun make-def-source-entry (key type name files)
     345  (setq files (if (or (%cdr files) (listp (%car files))) files (%car files)))
     346  (cond ((eq type (default-definition-type name))
     347         (if (and (eq name key) (atom files))
     348           files
     349           (cons name files)))
     350        ((eq name key)
     351         (type-file-cons type files))
     352        (t
     353         (cons (cons type name) files))))
     354
     355(defun decode-def-source-entry (key entry)
     356  (if (atom entry)
     357    (and entry (values (default-definition-type key) key (list entry)))
     358    (let* ((file-or-files (%cdr entry))
     359           (files (if (consp file-or-files) file-or-files (list file-or-files))))
     360      (cond ((typep (%car entry) 'definition-type)
     361             (values (%car entry) key files))
     362            ((and (consp (%car entry)) (typep (%caar entry) 'definition-type))
     363             (values (%caar entry) (%cdar entry) files))
     364            (t
     365             (values (default-definition-type (%car entry)) (%car entry) files))))))
     366
     367(defun def-source-entry.name (key entry)
     368  (assert (not (null entry)))
     369  (cond ((atom entry) key)
     370        ((typep (%car entry) 'definition-type) key)
     371        ((and (consp (%car entry)) (typep (%caar entry) 'definition-type))
     372         (%cdar entry))
     373        (t
     374         (%car entry))))
     375
     376(defun def-source-entry.type (key entry)
     377  (cond ((atom entry) (default-definition-type key))
     378        ((typep (%car entry) 'definition-type) (%car entry))
     379        ((and (consp (%car entry)) (typep (%caar entry) 'definition-type))
     380         (%caar entry))
     381        (t
     382         (default-definition-type (%car entry)))))
     383
     384(defun def-source-entry.files (key entry)
     385  (declare (ignore key))
     386  (cond ((consp entry)
     387         (if (consp (%cdr entry)) (%cdr entry) (list (%cdr entry))))
     388        (entry (list entry))
     389        (t nil)))
     390
     391
     392;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     393;;;
     394
     395
     396(defun find-definition-sources (name &optional (type t))
     397  "Returns a list of entries ((a-type . a-name) source . previous-sources), where
     398a-type is a subtype of TYPE, and a-name is either NAME or it's a special case of
     399NAME (e.g. if NAME is the name of generic function, a-name could be a method of NAME).
     400The list is guaranteed freshly consed (ie suitable for nconc'ing)."
     401  (let* ((dt (definition-type-instance type))
     402         (dt-class (class-of dt))
     403         (seen-dts nil)
     404         (matches nil))
     405    (with-lock-grabbed (*source-files-lock*)
     406      (loop for (nil . dt) in *definition-types*
     407            when (and (typep dt dt-class) (not (memq dt seen-dts)))
     408              do (let* ((key (definition-base-name dt name))
     409                        (all (%source-file-entries key)))
     410                   (push dt seen-dts)
     411                   (loop for entry in all
     412                         when (and (eq dt (def-source-entry.type key entry))
     413                                   (or (eq name key) ;; e.g. all methods on a gf
     414                                       (definition-same-p dt name (def-source-entry.name key entry))))
     415                           do (multiple-value-bind (type name files)
     416                                  (decode-def-source-entry key entry)
     417                                (push (cons (cons type name) files) matches))))))
     418    matches))
     419
     420
     421;;; backward compatibility
     422
    34423
    35424;;; modified version of %method-applicable-p - args are class names
     
    179568    (values type name classes qualifiers)))
    180569
    181 (defun edit-definition-p (name &optional (type t) &aux specializers qualifiers the-method)
    182   (when (consp name)
    183     (multiple-value-setq (type name specializers qualifiers)
    184       (parse-definition-spec name)))
    185   (when (and specializers (consp specializers)) (setq type 'method))
    186   ; might be a method-function whose name is the method
    187   (when (typep name 'function)(setq name (function-name name)))
    188   (when (typep name 'method)
    189      (setq qualifiers (%method-qualifiers name)
    190            specializers (mapcar #'(lambda (s)
    191                                     (if (typep s 'class)
    192                                       (class-name s)
    193                                       s))
    194                                 (%method-specializers name))
    195            the-method name
    196            name (%method-name name)
    197            type 'method))
    198   (let (files str newname)   
    199     (setq files (or (get-source-files-with-types&classes name type specializers qualifiers the-method)
    200                     (and
    201                      (not the-method)
    202                      (symbolp name)
    203                      (or (and
    204                           (setq str (symbol-name name))
    205                           (memq (schar str (1- (length str))) '(#\.  #\, #\:))
    206                           (setq newname
    207                                 (find-symbol (%substr str 0 (1- (length str)))
    208                                              (symbol-package name)))
    209                           (get-source-files-with-types&classes newname type specializers qualifiers))
    210 ))))         
    211   (when (and files newname) (setq name newname))
    212   (values files name type specializers qualifiers)))
    213 
    214 
    215 
    216 ;;; sym can be (setf blah)
     570
     571
     572(defun edit-definition-p (name &optional (type t)) ;exported
     573  (let ((specs (get-source-files-with-types name type)))
     574    (when (and (null specs)
     575               (symbolp name))
     576      (let* ((str (symbol-name name))
     577             (len (length str)))
     578        (when (and (> len 0) (memq (char str (1- len)) '(#\. #\, #\:)))
     579          (let ((newsym (find-symbol (%substr str 0 (1- len)) (symbol-package name))))
     580            (when newsym
     581              (setq specs (get-source-files-with-types newsym type)))))))
     582    specs))
     583
     584(defun get-source-files-with-types (name &optional (type t))
     585  (let ((list (find-definition-sources name type)))
     586    (declare (special *direct-methods-only*))
     587    ;; include indirect applicable methods.  Who uses this case?
     588    (when (and (eq type 'method)
     589               (not (typep name 'method))
     590               (not *direct-methods-only*))
     591      (multiple-value-bind (sym qualifiers specializers) (method-def-parameters name)
     592        (when sym
     593          (loop for m in (find-applicable-methods sym specializers qualifiers)
     594                unless (definition-same-p *method-definition-type* m name)
     595                  do (setq list (nconc (find-definition-sources m 'method) list))))))
     596    ;; Convert to old format, (type-or-name . file)
     597    (loop for ((dt . full-name) . files) in list
     598          as spec = (if (eq full-name name) (definition-type-name dt) full-name)
     599          nconc (mapcan (lambda (file) (when file (list (cons spec file)))) files))))
     600
     601
    217602(defun get-source-files-with-types&classes (sym &optional (type t) classes qualifiers the-method)
    218   (labels
    219     ((merge-types (l)
    220        (let ((ftype (car l)))
    221          (cond
    222           ((eq ftype 'setf) ; it's (setf (function . file))
    223            (let ((res (mapcan #'merge-types (cdr l))))
    224              (if (typep (caar res) 'method)
    225                res
    226                (mapcar #'(lambda (x)(cons 'setf (cdr x))) res))))
    227           ((or (eq type t)(eq ftype type))
    228            (let* ((foo #'(lambda (x)
    229                            (when x
    230                              ; if x is consp it's (<method> file file ..)
    231                              (cond
    232                               ((consp x)
    233                                (when (or (not (or classes qualifiers))
    234                                          (if the-method
    235                                            (methods-match-p (car x) the-method)
    236                                            (source-files-like-em classes qualifiers
    237                                                                  (car x))))
    238                                  (merge-class x)))
    239                               (t (list (cons ftype x))))))))
    240              (declare (dynamic-extent foo))
    241              (mapcan foo (if (consp (cdr l)) (cdr l)(list (cdr l)))))))))
    242      (merge-class (l)
    243        (if (consp (cdr l))
    244          (mapcan
    245           #'(lambda (x)
    246               (when x (list (cons (car l) x))))
    247           (cdr l))
    248          (list l))))
    249     (declare (dynamic-extent #'merge-types)(special *direct-methods-only*))
    250     (let (files)
    251       (when (and (not the-method)(eq type 'method) classes (not *direct-methods-only*))
    252         (let ((methods (find-applicable-methods sym classes qualifiers)))         
    253           (when methods           
    254             (setq files (mapcan
    255                          #'(lambda (m)
    256                              (or (edit-definition-p m)(list (list m))))
    257                          methods)))))
    258       (if files files
    259           (let (setf-p result)
    260             (if (and (consp sym)(eq (car sym) 'setf))
    261               (setq sym (cadr sym) setf-p t))
    262             (setq result (%source-files sym))
    263             (if (not (consp result))
    264               (setq result
    265                     (if (not setf-p)
    266                       (if (or (eq type t)(eq type 'function))
    267                         `((function . ,result)))))
    268               (if setf-p (setq result (list (assq 'setf result)))))
    269             (mapcan #'merge-types result))))))
     603  (let* ((name (or the-method
     604                   (and (or (eq type 'method) classes qualifiers)
     605                        `(sym ,@qualifiers ,classes))
     606                   sym)))
     607    (get-source-files-with-types name type)))
     608
     609
     610;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     611;;; record-source-file
     612
     613;; Returns nil if not a method/method name
     614(defun method-def-parameters (m)
     615  (if (typep m 'method)
     616    (values (method-name m)
     617            (method-qualifiers m)
     618            (method-specializers m))
     619    (let (name quals specs data last)
     620      (when (consp m)
     621        ;; (name spec1 .. specn) or (name qual1 .. qualn (spec1 ... specn))
     622        (setq data (cdr m) last (last data))
     623        (when (null (cdr last))
     624          (setq last (car last))
     625          (if (and (listp last) (neq (car last) 'eql))
     626            (setq quals (butlast data) specs last)
     627            (setq specs data))
     628          (setq name (car m))
     629          (when (and (or (non-nil-symbol-p name) (setf-function-name-p name))
     630                     (every #'(lambda (q) (not (listp q))) quals)
     631                     (every #'(lambda (s)
     632                                (or (non-nil-symbol-p s)
     633                                    (classp s)
     634                                    (and (consp s)
     635                                         (consp (cdr s))
     636                                        (null (cddr s))
     637                                         (eq (car s) 'eql))))
     638                            specs))
     639            (values name quals specs)))))))
     640
     641(defmethod record-definition-source ((dt definition-type) name file-name)
     642  (let* ((key (definition-base-name dt name))
     643         (all (%source-file-entries key))
     644         (e-loc nil)
     645         (e-files nil))
     646    (loop for ptr on all as entry = (car ptr)
     647          do (when (and (eq dt (def-source-entry.type key entry))
     648                        (definition-same-p dt name (def-source-entry.name key entry)))
     649               (setq e-files (def-source-entry.files key entry))
     650               (let ((old (flet ((same-file (x y)
     651                                   (or (equal x y)
     652                                       (and x
     653                                            y
     654                                            (equal
     655                                             (or (probe-file x) (full-pathname x))
     656                                             (or (probe-file y) (full-pathname y)))))))
     657                            (member file-name e-files :test #'same-file))))
     658                 (when (and old (neq file-name (car e-files))) ;; move to front
     659                   (setq e-files (cons file-name (remove (car old) e-files :test #'eq)))))
     660               (return (setq e-loc ptr))))
     661    (unless (and e-files (eq file-name (car e-files)))
     662      ;; Never previously defined in this file
     663      (when (and (car e-files)            ; don't warn if last defined interactively
     664                 *warn-if-redefine*
     665                 (definition-bound-p dt name))
     666        (warn "~A ~S previously defined in: ~A is now being redefined in: ~A~%"
     667              (definition-type-name dt)
     668              name
     669              (car e-files)
     670              (if (eq file-name :interactive) "{No file}" file-name)))
     671      (setq e-files (cons file-name e-files)))
     672    (let ((entry (make-def-source-entry key dt name e-files)))
     673      (if e-loc
     674        (setf (car e-loc) entry)
     675        (push entry all))
     676      (%set-source-file-entries key all))
     677    name))
     678
     679;; Define the real record-source-file, which will be the last defn handled by the
     680;; bootstrapping record-source-file, so convert all queued up data right afterwards.
     681(progn
     682
     683(defun record-source-file (name def-type &optional (file-name *loading-file-source-file*))
     684  (when *record-source-file*
     685    (with-lock-grabbed (*source-files-lock*)
     686      (when (and file-name (physical-pathname-p file-name))
     687        (setq file-name (namestring (back-translate-pathname file-name)))
     688        (cond ((equalp file-name *last-back-translated-name*)
     689               (setq file-name *last-back-translated-name*))
     690              (t (setq *last-back-translated-name* file-name))))
     691      (when (eq def-type 't) (report-bad-arg def-type '(not (eql t))))
     692      (record-definition-source (definition-type-instance def-type
     693                                    :if-does-not-exist :create)
     694                                name
     695                                file-name))))
     696
     697;; Collect level-0 source file info
     698(do-all-symbols (s)
     699  (let ((f (get s 'bootstrapping-source-files)))
     700    (when f
     701      (setf (gethash s %source-files%) f)
     702      (remprop s 'bootstrapping-source-files))))
     703;; Collect level-1 source file info
     704(when (consp *record-source-file*)
     705  (let ((list (nreverse (shiftf *record-source-file* t))))
     706    (while list
     707      (apply #'record-source-file (pop list)))))
     708)
Note: See TracChangeset for help on using the changeset viewer.