source: branches/lispworks/lw-inspector.lisp@ 18

;;;-*- Mode: Lisp; Package: WOOD -*-

;; Copyright © 2006 Clozure Associates and Anvita eReference (www.Anvita.info)

(in-package :wood)


(defconstant *hex-digits* "0123456789ABCDEF")

(defun encode-hex (value string index digits-left)
  (if (eql digits-left 0)
    index
    (let* ((r (logand value #xf))
           (q (ash value -4))
           (i (encode-hex q string index (1- digits-left))))
      (setf (schar string i) (schar *hex-digits* r))
      (1+ i))))

(defun encode-hex-line (vector start)
  (let ((end (length vector))
        (value (make-string (+ 36 1 16)
                            :initial-element #\space
                            :element-type 'base-character)))
    (flet ((enc (offset value index)
             (incf offset start)
             (when (< offset end)
               (encode-hex (%%load-unsigned-word vector offset) value index 4))))
      (enc 0 value 0)
      (enc 2 value 4)
      (enc 4 value 9)
      (enc 6 value 13)
      (enc 8 value 18)
      (enc 10 value 22)
      (enc 12 value 27)
      (enc 14 value 31))
    (flet ((loadch (str i)
             (declare (type (simple-array base-char (*)) str)
                      (type fixnum i)
                      (optimize (speed 3) (safety 0)))
             (schar str i)))
      (dotimes (i 16)
        (let ((char (if (< (+ start i) end) (loadch vector (+ start i)) #\Null)))
          (setf (schar value (+ 37 i))
                (if (graphic-char-p char) char #\.)))))
    value))


  

(defparameter *disk-cache-inspector-buffer*
  (make-string 16 :element-type 'base-character))

(defmethod lw:get-inspector-values ((disk-cache disk-cache) (mode (eql 'disk-cache-data)))
  (let* ((size (disk-cache-size disk-cache))
         (line-count (ceiling size 16))
         (buffer *disk-cache-inspector-buffer*))
    (loop for address from 0 below (* line-count 16) by 16
          collect (let ((label (make-string 8 :initial-element #\space :element-type 'base-char)))
                    (encode-hex address label 0 8)
                    label) into labels
          collect (progn
                    (fill buffer #\Null)
                    (read-string disk-cache address (min 16 (- size address)) buffer)
                    (encode-hex-line buffer 0)) into values
          finally return (values labels values))))


#+debugging-wood
(defmethod lw:get-inspector-values ((vector vector) (mode (eql 'hex-data)))
  (unless (equal (array-element-type vector) '(unsigned-byte 8))
    (return-from lw:get-inspector-values nil))
  (let* ((size (length vector))
         (line-count (ceiling size 16)))
    (loop for address from 0 below (* line-count 16) by 16
          collect (let ((label (make-string 8 :initial-element #\space :element-type 'base-char)))
                    (encode-hex address label 0 8)
                    label) into labels
          collect (encode-hex-line vector address) into values
          finally return (values labels values))))