/[slime]/slime/swank-lispworks.lisp
ViewVC logotype

Diff of /slime/swank-lispworks.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.137 by sboukarev, Thu Jul 22 13:45:46 2010 UTC revision 1.138 by msimmons, Tue Nov 2 12:32:10 2010 UTC
# Line 697  function names like \(SETF GET)." Line 697  function names like \(SETF GET)."
697  (defxref who-macroexpands hcl:who-calls) ; macros are in the calls table too  (defxref who-macroexpands hcl:who-calls) ; macros are in the calls table too
698  (defxref calls-who      hcl:calls-who)  (defxref calls-who      hcl:calls-who)
699  (defxref list-callers   list-callers-internal)  (defxref list-callers   list-callers-internal)
 #+lispworks6  
700  (defxref list-callees   list-callees-internal)  (defxref list-callees   list-callees-internal)
701    
 #-lispworks6  
702  (defun list-callers-internal (name)  (defun list-callers-internal (name)
703    (let ((callers (make-array 100    (let ((callers (make-array 100
704                               :fill-pointer 0                               :fill-pointer 0
# Line 708  function names like \(SETF GET)." Line 706  function names like \(SETF GET)."
706      (hcl:sweep-all-objects      (hcl:sweep-all-objects
707       #'(lambda (object)       #'(lambda (object)
708           (when (and #+Harlequin-PC-Lisp (low:compiled-code-p object)           (when (and #+Harlequin-PC-Lisp (low:compiled-code-p object)
709                      #-Harlequin-PC-Lisp (sys::callablep object)                      #+Harlequin-Unix-Lisp (sys:callablep object)
710                        #-(or Harlequin-PC-Lisp Harlequin-Unix-Lisp) (sys:compiled-code-p object)
711                      (system::find-constant$funcallable name object))                      (system::find-constant$funcallable name object))
712             (vector-push-extend object callers))))             (vector-push-extend object callers))))
713      ;; Delay dspec:object-dspec until after sweep-all-objects      ;; Delay dspec:object-dspec until after sweep-all-objects
# Line 718  function names like \(SETF GET)." Line 717  function names like \(SETF GET)."
717                        (list 'function object)                        (list 'function object)
718                        (or (dspec:object-dspec object) object)))))                        (or (dspec:object-dspec object) object)))))
719    
 #+lispworks6  
 (defun list-callers-internal (name)  
     ;; Delay dspec:object-dspec until after sweep-all-objects  
     ;; to reduce allocation problems.  
     (loop for object in (hcl::who-calls name)  
           collect (if (symbolp object)  
                       (list 'function object)  
                       (or (dspec:object-dspec object) object))))  
   
 #+lispworks6  
720  (defun list-callees-internal (name)  (defun list-callees-internal (name)
721      ;; Delay dspec:object-dspec until after sweep-all-objects    (let ((callees '()))
722      ;; to reduce allocation problems.      (system::find-constant$funcallable
723      (loop for object in (hcl::calls-who name)       'junk name
724            collect (if (symbolp object)       :test #'(lambda (junk constant)
725                        (list 'function object)                 (declare (ignore junk))
726                        (or (dspec:object-dspec object) object))))                 (when (and (symbolp constant)
727                              (fboundp constant))
728                     (pushnew (list 'function constant) callees :test 'equal))
729                   ;; Return nil so we iterate over all constants.
730                   nil))
731        callees))
732    
733  ;; only for lispworks 4.2 and above  ;; only for lispworks 4.2 and above
734  #-lispworks4.1  #-lispworks4.1

Legend:
Removed from v.1.137  
changed lines
  Added in v.1.138

  ViewVC Help
Powered by ViewVC 1.1.5