Changeset 11126


Ignore:
Timestamp:
Oct 17, 2008, 1:02:35 PM (11 years ago)
Author:
gz
Message:

From working-0711: new fn CALLER-FUNCTIONS, like CALLERS but returns the actual function objects rather than names

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/lib/edit-callers.lisp

    r9844 r11126  
    6161
    6262  (let ((*function-parent-table* nil))
    63     (if (and (symbolp function) (fboundp function))
    64       (setq cfun (symbol-function function)))
    65     (if (and (consp function)(eq (car function) 'setf))
     63    (if (setf-function-name-p function)
    6664      (let ((nm (cadr function)))
    6765        (setq function  (or (%setf-method nm)
     
    7068                                 (fboundp nm)
    7169                                 nm)
    72                             function)))) 
     70                            function))))
     71    (if (and (symbolp function) (fboundp function))
     72      (setq cfun (symbol-function function)))
    7373    (when (copying-gc-p) (setq gccount (full-gccount)))
    7474    (flet ((do-it (fun)
    75                                         ;(declare (special fun))
    7675             (when (and gccount (neq gccount (full-gccount)))
    7776               (throw 'losing :lost))
    78              (let ((bits (lfun-bits fun)))
    79                (declare (fixnum bits))
    80                (unless (or (and (logbitp $lfbits-cm-bit bits)(not (logbitp $lfbits-method-bit bits))) ; combined method
    81                            (and (logbitp $lfbits-trampoline-bit bits)(lfun-closure-p fun)
    82                                 (not (global-function-p fun)))) ; closure (interp or compiled)
    83                  (let* ((nm (ignore-errors (lfun-name fun)))
    84                             (globalp (if nm (global-function-p fun nm))))
    85                        (flet ((do-imm (im)
    86                                 (when (and (or (eq function im)
    87                                                (and cfun (eq cfun im)))
    88                                            (neq im nm))                             
    89                                   (push fun callers))
    90                                 (when (functionp im) ; was (or (functionp im)(eq imtype $sym.fapply))
    91                                   (if globalp
    92                                     (setf (gethash im *function-parent-table*) fun)
    93                                     (let ((ht (gethash im *function-parent-table*)))
    94                                       (if (not ht)
    95                                         (setf (gethash im *function-parent-table*) fun)
    96                                         (unless (eq ht fun)
    97                                           (if (consp ht)
    98                                             (when (not (memq fun ht))(nconc ht (list fun)))
    99                                             (if (not (global-function-p ht))
    100                                               (setf (gethash im *function-parent-table*)
    101                                                     (list ht fun)))))))))))
    102                          (declare (dynamic-extent #'do-imm))                               
    103                          (%map-lfimms fun #'do-imm )))))))
     77             (when (possible-caller-function-p fun)
     78               (let* ((nm (ignore-errors (lfun-name fun)))
     79                      (globalp (if nm (global-function-p fun nm))))
     80                 (flet ((do-imm (im)
     81                          (when (and (or (eq function im)
     82                                         (and cfun (eq cfun im)))
     83                                     (neq im nm))                             
     84                            (push fun callers))
     85                          (when (functionp im) ; was (or (functionp im)(eq imtype $sym.fapply))
     86                            (if globalp
     87                              (setf (gethash im *function-parent-table*) fun)
     88                              (let ((ht (gethash im *function-parent-table*)))
     89                                (if (not ht)
     90                                  (setf (gethash im *function-parent-table*) fun)
     91                                  (unless (eq ht fun)
     92                                    (if (consp ht)
     93                                      (when (not (memq fun ht))(nconc ht (list fun)))
     94                                      (if (not (global-function-p ht))
     95                                        (setf (gethash im *function-parent-table*)
     96                                              (list ht fun)))))))))))
     97                   (declare (dynamic-extent #'do-imm))                               
     98                   (%map-lfimms fun #'do-imm ))))))
    10499      (declare (dynamic-extent #'do-it))
    105100      (unwind-protect
     
    130125
    131126
    132 
    133127(defun top-level-caller (function &optional the-list)
    134128  (or (global-function-p function)
     
    157151      function))
    158152
     153(defun possible-caller-function-p (fun)
     154  (let ((bits (lfun-bits fun)))
     155    (declare (fixnum bits))
     156    (not (or (and (logbitp $lfbits-cm-bit bits)
     157                  (not (logbitp $lfbits-method-bit bits))) ; combined method
     158             (and (logbitp $lfbits-trampoline-bit bits)
     159                  (lfun-closure-p fun)
     160                  (not (global-function-p fun))))))) ; closure (interp or compiled)
     161
     162 
     163(defun caller-functions (function &aux cfun callers gccount retry)
     164  "Returns a list of all functions (actual function objects, not names) that reference FUNCTION"
     165  (declare (optimize (speed 3)(safety 0)))
     166  (when (setf-function-name-p function)
     167    (let ((nm (cadr function)))
     168      (setq function  (or (%setf-method nm)
     169                          (and (setq nm (setf-function-name nm))
     170                               (fboundp nm)
     171                               nm)
     172                          function))))
     173  (when (and (symbolp function) (fboundp function))
     174    (setq cfun (symbol-function function)))
     175  (when (copying-gc-p) (setq gccount (full-gccount)))
     176  (flet ((do-it (fun)
     177           (when (and gccount (neq gccount (full-gccount)))
     178             (throw 'losing :lost))
     179           (when (and (neq fun cfun)
     180                      (possible-caller-function-p fun))
     181             (lfunloop for im in fun
     182               when (or (eq function im)
     183                        (and cfun (eq cfun im)))
     184               do (return (pushnew (if (%method-function-p fun)
     185                                     (%method-function-method fun)
     186                                     fun)
     187                                   callers))))))
     188    (declare (dynamic-extent #'do-it))
     189    (loop while (eq :lost (catch 'losing     
     190                            (%map-lfuns #'do-it)))
     191          do (when retry (cerror "Try again" "Callers is losing"))
     192          do (setq callers nil)
     193          do (setq retry t))
     194    callers))
     195
    159196; in 3.x the function in pascal-functions calls the actual function
    160197(defun pascal-function-p (function)
     
    174211
    175212
    176 
    177 
    178 
    179                  
    180 
    181 
    182 
    183 
    184 
    185 
    186 
    187 
    188 
    189213;;; Calls function f with args (imm) on each immediate in lfv.
    190214
Note: See TracChangeset for help on using the changeset viewer.