/[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.135 by heller, Mon Mar 8 12:21:43 2010 UTC revision 1.136 by heller, Mon Mar 8 16:20:10 2010 UTC
# Line 17  Line 17 
17    (require 'lldb)    (require 'lldb)
18    )    )
19    
 ;;(declaim (optimize debug))  
   
20  (import-from :excl *gray-stream-symbols* :swank-backend)  (import-from :excl *gray-stream-symbols* :swank-backend)
21    
22  ;;; swank-mop  ;;; swank-mop
# Line 197  Line 195 
195    (let* ((frame (nth-frame index)))    (let* ((frame (nth-frame index)))
196      (multiple-value-bind (x fun xx xxx pc) (debugger::dyn-fd-analyze frame)      (multiple-value-bind (x fun xx xxx pc) (debugger::dyn-fd-analyze frame)
197        (declare (ignore x xx xxx))        (declare (ignore x xx xxx))
198        #+(version>= 8 2)        (cond (pc
199        (pc-source-location fun pc)               #+(version>= 8 2)
200        #-(version>= 8 2)               (pc-source-location fun pc)
201        (function-source-location fun)               #-(version>= 8 2)
202        )))               (function-source-location fun))
203                (t ; frames for unbound functions etc end up here
204                 (cadr (car (fspec-definition-locations
205                             (car (debugger:frame-expression frame))))))))))
206    
207  (defun function-source-location (fun)  (defun function-source-location (fun)
208    (cadr (car (fspec-definition-locations fun))))    (cadr (car (fspec-definition-locations fun))))
# Line 226  Line 227 
227  (defun ldb-code-to-src-loc (code)  (defun ldb-code-to-src-loc (code)
228    (let* ((start (excl::ldb-code-start-char code))    (let* ((start (excl::ldb-code-start-char code))
229           (func (excl::ldb-code-func code))           (func (excl::ldb-code-func code))
230           (loc (buffer-or-file-location (excl:source-file func) (or start 0))))           (src-file (excl:source-file func)))
231      (cond (start loc)      (cond (start
232               (buffer-or-file-location src-file start))
233            (t            (t
234             (let* ((debug-info (excl::function-source-debug-info func))             (let* ((debug-info (excl::function-source-debug-info func))
235                    (whole (aref debug-info 0))                    (whole (aref debug-info 0))
236                    (paths (source-paths-of (excl::ldb-code-source whole)                    (paths (source-paths-of (excl::ldb-code-source whole)
237                                            (excl::ldb-code-source code)))                                            (excl::ldb-code-source code)))
238                    (path (longest-common-prefix paths))                    (path (longest-common-prefix paths))
239                    (start (excl::ldb-code-start-char whole)))                    (start (excl::ldb-code-start-char whole))
240               (make-location (location-buffer loc)                    (probe (gethash src-file *temp-file-map*)))
241                              `(:source-path (0 . ,path) ,start)))))))               (cond ((not probe)
242                        (make-location `(:file ,(namestring (truename src-file)))
243                                       `(:source-path (0 . ,path) ,start)))
244                       (t
245                        (destructuring-bind (buffer bstart file) probe
246                          (declare (ignore file))
247                          (make-location `(:buffer ,buffer)
248                                         `(:source-path (0 . ,path)
249                                                        ,(+ bstart start)))))))))))
250    
251  (defun longest-common-prefix (sequences)  (defun longest-common-prefix (sequences)
252    (assert sequences)    (assert sequences)

Legend:
Removed from v.1.135  
changed lines
  Added in v.1.136

  ViewVC Help
Powered by ViewVC 1.1.5