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.

File:
1 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)
Note: See TracChangeset for help on using the changeset viewer.