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

Diff of /slime/swank-clisp.lisp

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

revision 1.67 by heller, Sat Feb 9 18:47:05 2008 UTC revision 1.68 by heller, Fri Feb 22 14:11:52 2008 UTC
# Line 1  Line 1 
1  ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-  ;;;; -*- indent-tabs-mode: nil -*-
2    
3  ;;;; SWANK support for CLISP.  ;;;; SWANK support for CLISP.
4    
# Line 249  Return NIL if the symbol is unbound." Line 249  Return NIL if the symbol is unbound."
249    
250  (defvar *sldb-backtrace*)  (defvar *sldb-backtrace*)
251    
252    (eval-when (:compile-toplevel :load-toplevel :execute)
253      (when (string< "2.44" (lisp-implementation-version))
254        (pushnew :clisp-2.44+ *features*)))
255    
256    (defun sldb-backtrace ()
257      "Return a list ((ADDRESS . DESCRIPTION) ...) of frames."
258      (do ((frames '())
259           (last nil frame)
260           (frame (sys::the-frame)
261                  #+clisp-2.44+ (sys::frame-up 1 frame 1)
262                  #-clisp-2.44+ (sys::frame-up-1 frame 1))) ; 1 = "all frames"
263          ((eq frame last) (nreverse frames))
264        (unless (boring-frame-p frame)
265          (push frame frames))))
266    
267  (defimplementation call-with-debugging-environment (debugger-loop-fn)  (defimplementation call-with-debugging-environment (debugger-loop-fn)
268    (let* (;;(sys::*break-count* (1+ sys::*break-count*))    (let* (;;(sys::*break-count* (1+ sys::*break-count*))
269           ;;(sys::*driver* debugger-loop-fn)           ;;(sys::*driver* debugger-loop-fn)
# Line 260  Return NIL if the symbol is unbound." Line 275  Return NIL if the symbol is unbound."
275  (defun nth-frame (index)  (defun nth-frame (index)
276    (nth index *sldb-backtrace*))    (nth index *sldb-backtrace*))
277    
 (defun sldb-backtrace ()  
   "Return a list ((ADDRESS . DESCRIPTION) ...) of frames."  
   (do ((frames '())  
        (last nil frame)  
        (frame (sys::the-frame) (sys::frame-up-1 frame 1))) ; 1 = "all frames"  
       ((eq frame last) (nreverse frames))  
     (unless (boring-frame-p frame)  
       (push frame frames))))  
   
278  (defun boring-frame-p (frame)  (defun boring-frame-p (frame)
279    (member (frame-type frame) '(stack-value bind-var bind-env)))    (member (frame-type frame) '(stack-value bind-var bind-env)))
280    
# Line 276  Return NIL if the symbol is unbound." Line 282  Return NIL if the symbol is unbound."
282    (with-output-to-string (s)    (with-output-to-string (s)
283      (sys::describe-frame s frame)))      (sys::describe-frame s frame)))
284    
285    ;; FIXME: they changed the layout in 2.44 so the frame-to-string &
286    ;; string-matching silliness no longer works.
287  (defun frame-type (frame)  (defun frame-type (frame)
288    ;; FIXME: should bind *print-length* etc. to small values.    ;; FIXME: should bind *print-length* etc. to small values.
289    (frame-string-type (frame-to-string frame)))    (frame-string-type (frame-to-string frame)))
# Line 418  Return two values: NAME and VALUE" Line 426  Return two values: NAME and VALUE"
426          (venv-ref (next-venv env) (- i (/ (1- (length env)) 2))))))          (venv-ref (next-venv env) (- i (/ (1- (length env)) 2))))))
427    
428  (defun %parse-stack-values (frame)  (defun %parse-stack-values (frame)
429    (labels ((next (fp) (sys::frame-down-1 fp 1))    (labels ((next (fp)
430                 #+clisp-2.44+ (sys::frame-down 1 fp 1)
431                 #-clisp-2.44+ (sys::frame-down-1 fp 1))
432             (parse (fp accu)             (parse (fp accu)
433               (let ((str (frame-to-string fp)))               (let ((str (frame-to-string fp)))
434                 (cond ((is-prefix-p "- " str)                 (cond ((is-prefix-p "- " str)
# Line 433  Return two values: NAME and VALUE" Line 443  Return two values: NAME and VALUE"
443                       (t (parse (next fp) accu))))))                       (t (parse (next fp) accu))))))
444      (parse (next frame) '())))      (parse (next frame) '())))
445    
446    (setq *features* (remove :clisp-2.44+ *features*))
447    
448  (defun is-prefix-p (pattern string)  (defun is-prefix-p (pattern string)
449    (not (mismatch pattern string :end2 (min (length pattern)    (not (mismatch pattern string :end2 (min (length pattern)
450                                             (length string)))))                                             (length string)))))

Legend:
Removed from v.1.67  
changed lines
  Added in v.1.68

  ViewVC Help
Powered by ViewVC 1.1.5