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

Diff of /slime/swank.lisp

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

revision 1.575 by heller, Fri Aug 22 21:15:19 2008 UTC revision 1.576 by heller, Fri Aug 22 21:15:24 2008 UTC
# Line 2878  DSPEC is a string and LOCATION a source Line 2878  DSPEC is a string and LOCATION a source
2878                    (print-unreadable-object ((istate.object istate)                    (print-unreadable-object ((istate.object istate)
2879                                             s :type t :identity t))))                                             s :type t :identity t))))
2880          :id (assign-index (istate.object istate) (istate.parts istate))          :id (assign-index (istate.object istate) (istate.parts istate))
2881          :content (content-range (inspector-content istate) 0 500)))          :content (prepare-range istate 0 500)))
2882    
2883  (defun inspector-content (istate)  (defun prepare-range (istate start end)
2884    (loop for part in (istate.content istate) collect    (let* ((range (content-range (istate.content istate) start end))
2885          (etypecase part           (ps (loop for part in range append (prepare-part part istate))))
2886            (string part)      (list ps
2887            (cons (destructure-case part            (if (< (length ps) (- end start))
2888                    ((:newline)                (+ start (length ps))
2889                     '#.(string #\newline))                (+ end 1000))
2890                    ((:value obj &optional str)            start end)))
2891                     (value-part obj str (istate.parts istate)))  
2892                    ((:action label lambda &key (refreshp t))  (defun prepare-part (part istate)
2893                     (action-part label lambda refreshp    (let ((newline '#.(string #\newline)))
2894                                  (istate.actions istate))))))))      (etypecase part
2895          (string (list part))
2896          (cons (destructure-case part
2897                  ((:newline) (list newline))
2898                  ((:value obj &optional str)
2899                   (list (value-part obj str (istate.parts istate))))
2900                  ((:action label lambda &key (refreshp t))
2901                   (action-part label lambda refreshp
2902                                (istate.actions istate)))
2903                  ((:line label value)
2904                   (list (princ-to-string label) ": "
2905                         (value-part value nil (istate.parts istate))
2906                         newline)))))))
2907    
2908  (defun value-part (object string parts)  (defun value-part (object string parts)
2909    (list :value    (list :value
# Line 2922  DSPEC is a string and LOCATION a source Line 2934  DSPEC is a string and LOCATION a source
2934     ".."))     ".."))
2935    
2936  (defun content-range (list start end)  (defun content-range (list start end)
2937    (let* ((len (length list)) (end (min len end)))    (typecase list
2938      (list (subseq list start end) len start end)))      (list (let ((len (length list)))
2939                (subseq list start (min len end))))
2940        (lcons (llist-range list start end))))
2941    
2942  (defslimefun inspector-nth-part (index)  (defslimefun inspector-nth-part (index)
2943    (aref (istate.parts *istate*) index))    (aref (istate.parts *istate*) index))
# Line 2933  DSPEC is a string and LOCATION a source Line 2947  DSPEC is a string and LOCATION a source
2947      (inspect-object (inspector-nth-part index))))      (inspect-object (inspector-nth-part index))))
2948    
2949  (defslimefun inspector-range (from to)  (defslimefun inspector-range (from to)
2950    (content-range (inspector-content *istate*) from to))    (prepare-range *istate* from to))
2951    
2952  (defslimefun inspector-call-nth-action (index &rest args)  (defslimefun inspector-call-nth-action (index &rest args)
2953    (destructuring-bind (fun refreshp) (aref (istate.actions *istate*) index)    (destructuring-bind (fun refreshp) (aref (istate.actions *istate*) index)
# Line 2994  Return nil if there's no previous object Line 3008  Return nil if there's no previous object
3008      (reset-inspector)      (reset-inspector)
3009      (inspect-object (frame-var-value frame var))))      (inspect-object (frame-var-value frame var))))
3010    
3011    ;;;;; Lazy lists
3012    
3013    (defstruct (lcons (:constructor %lcons (car %cdr))
3014                      (:predicate lcons?))
3015      car
3016      (%cdr nil :type (or null lcons function))
3017      (forced? nil))
3018    
3019    (defmacro lcons (car cdr)
3020      `(%lcons ,car (lambda () ,cdr)))
3021    
3022    (defmacro lcons* (car cdr &rest more)
3023      (cond ((null more) `(lcons ,car ,cdr))
3024            (t `(lcons ,car (lcons* ,cdr ,@more)))))
3025    
3026    (defun lcons-cdr (lcons)
3027      (with-struct* (lcons- @ lcons)
3028        (cond ((@ forced?)
3029               (@ %cdr))
3030              (t
3031               (let ((value (funcall (@ %cdr))))
3032                 (setf (@ forced?) t
3033                       (@ %cdr) value))))))
3034    
3035    (defun llist-range (llist start end)
3036      (llist-take (llist-skip llist start) (- end start)))
3037    
3038    (defun llist-skip (lcons index)
3039      (do ((i 0 (1+ i))
3040           (l lcons (lcons-cdr l)))
3041          ((or (= i index) (null l))
3042           l)))
3043    
3044    (defun llist-take (lcons count)
3045      (let ((result '()))
3046        (do ((i 0 (1+ i))
3047             (l lcons (lcons-cdr l)))
3048            ((or (= i count)
3049                 (null l)))
3050          (push (lcons-car l) result))
3051        (nreverse result)))
3052    
3053    (defun iline (label value)
3054      `(:line ,label ,value))
3055    
3056  ;;;;; Lists  ;;;;; Lists
3057    
3058  (defmethod emacs-inspect ((o cons))  (defmethod emacs-inspect ((o cons))
# Line 3006  Return nil if there's no previous object Line 3065  Return nil if there's no previous object
3065     ('car (car cons))     ('car (car cons))
3066     ('cdr (cdr cons))))     ('cdr (cdr cons))))
3067    
 ;; (inspect-list '#1=(a #1# . #1# ))  
 ;; (inspect-list (list* 'a 'b 'c))  
 ;; (inspect-list (make-list 10000))  
   
3068  (defun inspect-list (list)  (defun inspect-list (list)
3069    (multiple-value-bind (length tail) (safe-length list)    (multiple-value-bind (length tail) (safe-length list)
3070      (flet ((frob (title list)      (flet ((frob (title list)
# Line 3045  Return NIL if LIST is circular." Line 3100  Return NIL if LIST is circular."
3100    
3101  ;;;;; Hashtables  ;;;;; Hashtables
3102    
3103    
3104    
3105  (defmethod emacs-inspect ((ht hash-table))  (defmethod emacs-inspect ((ht hash-table))
3106    (append    (append
3107     (label-value-line*     (label-value-line*
# Line 3071  Return NIL if LIST is circular." Line 3128  Return NIL if LIST is circular."
3128  ;;;;; Arrays  ;;;;; Arrays
3129    
3130  (defmethod emacs-inspect ((array array))  (defmethod emacs-inspect ((array array))
3131    (append    (lcons*
3132     (label-value-line*     (iline "Dimensions" (array-dimensions array))
3133      ("Dimensions" (array-dimensions array))     (iline "Element type" (array-element-type array))
3134      ("Element type" (array-element-type array))     (iline "Total size" (array-total-size array))
3135      ("Total size" (array-total-size array))     (iline "Adjustable" (adjustable-array-p array))
3136      ("Adjustable" (adjustable-array-p array)))     (iline "Fill pointer" (if (array-has-fill-pointer-p array)
3137     (when (array-has-fill-pointer-p array)                               (fill-pointer array)))
3138       (label-value-line "Fill pointer" (fill-pointer array)))     "Contents:" '(:newline)
3139     '("Contents:" (:newline))     (labels ((k (i max)
3140     (loop for i below (array-total-size array)                (cond ((= i max) '())
3141           append (label-value-line i (row-major-aref array i)))))                      (t (lcons (iline i (row-major-aref array i))
3142                                  (k (1+ i) max))))))
3143         (k 0 (array-total-size array)))))
3144    
3145  ;;;;; Chars  ;;;;; Chars
3146    

Legend:
Removed from v.1.575  
changed lines
  Added in v.1.576

  ViewVC Help
Powered by ViewVC 1.1.5