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

Diff of /slime/swank-allegro.lisp

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

revision 1.45 by lgorrie, Sun Jul 4 00:36:14 2004 UTC revision 1.46 by heller, Sun Aug 1 06:44:46 2004 UTC
# Line 230  Line 230 
230      (let ((*buffer-name* nil))      (let ((*buffer-name* nil))
231        (compile-file *compile-filename* :load-after-compile load-p))))        (compile-file *compile-filename* :load-after-compile load-p))))
232    
233    (defun call-with-temp-file (fn)
234      (let ((tmpname (system:make-temp-file-name)))
235        (unwind-protect
236             (with-open-file (file tmpname :direction :output :if-exists :error)
237               (funcall fn file tmpname))
238          (delete-file tmpname))))
239    
240    (defun compile-from-temp-file (string)
241      (call-with-temp-file
242       (lambda (stream filename)
243           (write-string string stream)
244           (finish-output stream)
245           (let ((binary-filename (compile-file filename :load-after-compile t)))
246             (when binary-filename
247               (delete-file binary-filename))))))
248    
249  (defimplementation swank-compile-string (string &key buffer position)  (defimplementation swank-compile-string (string &key buffer position)
250      ;; We store the source buffer in excl::*source-pathname* as a string
251      ;; of the form <buffername>:<start-offset>.  Quite ugly encoding, but
252      ;; the fasl file is corrupted if we use some other datatype.
253    (with-compilation-hooks ()    (with-compilation-hooks ()
254      (let ((*buffer-name* buffer)      (let ((*buffer-name* buffer)
255            (*buffer-start-position* position)            (*buffer-start-position* position)
256            (*buffer-string* string))            (*buffer-string* string))
257        (funcall (compile nil (read-from-string        (compile-from-temp-file
258                               (format nil "(~S () ~A)" 'lambda string)))))))         (format nil "~S ~S~%~A"
259                   `(in-package ,(package-name *package*))
260                   `(eval-when (:compile-toplevel :load-toplevel)
261                     (setq excl::*source-pathname*
262                      (format nil "~A:~D" ',buffer ',position)))
263                   string)))))
264    
265  ;;;; Definition Finding  ;;;; Definition Finding
266    
# Line 257  Line 281 
281                          pos)))                          pos)))
282        ((member :top-level)        ((member :top-level)
283         (list :error (format nil "Defined at toplevel: ~A" fspec)))         (list :error (format nil "Defined at toplevel: ~A" fspec)))
284          (string
285           (let ((pos (position #\: file)))
286             (make-location
287              (list :buffer (subseq file 0 pos))
288              (list :position (parse-integer (subseq file (1+ pos)))))))
289        (null        (null
290         (list :error (format nil "Unknown source location for ~A" fspec))))))         (list :error (format nil "Unknown source location for ~A" fspec))))))
291    
# Line 285  Line 314 
314    (loop for fspec in fspecs    (loop for fspec in fspecs
315          append (fspec-definition-locations fspec)))          append (fspec-definition-locations fspec)))
316    
317    ;; list-callers implemented by groveling through all fbound symbols.
318    ;; Only symbols are considered.  Functions in the constant pool are
319    ;; searched recursevly.  Closure environments are ignored at the
320    ;; moment (constants in methods are therefore not found).
321    
322    (defun map-function-constants (function fn depth)
323      "Call FN with the elements of FUNCTION's constant pool."
324      (do ((i 0 (1+ i))
325           (max (excl::function-constant-count function)))
326          ((= i max))
327        (let ((c (excl::function-constant function i)))
328          (cond ((and (functionp c)
329                      (not (eq c function))
330                      (plusp depth))
331                 (map-function-constants c fn (1- depth)))
332                (t
333                 (funcall fn c))))))
334    
335    (defun in-constants-p (fn symbol)
336      (map-function-constants
337       fn
338       (lambda (c) (if (eq c symbol) (return-from in-constants-p t)))
339       3))
340    
341    (defun function-callers (name)
342      (let ((callers '()))
343        (do-all-symbols (sym)
344          (when (fboundp sym)
345            (let ((fn (fdefinition sym)))
346              (when (in-constants-p fn name)
347                (push sym callers)))))
348        callers))
349    
350    (defimplementation list-callers (name)
351      (xref-result (function-callers name)))
352    
353  ;;;; Inspecting  ;;;; Inspecting
354    
355  (defmethod inspected-parts (o)  (defmethod inspected-parts (o)

Legend:
Removed from v.1.45  
changed lines
  Added in v.1.46

  ViewVC Help
Powered by ViewVC 1.1.5