browser.lisp

   1 ;;;;------------------------------------------------------------------
   2 ;;;;
   3 ;;;;    Copyright (C) 2001-2002, 2004,
   4 ;;;;    Department of Computer Science, University of Tromso, Norway.
   5 ;;;;
   6 ;;;;    For distribution policy, see the accompanying file COPYING.
   7 ;;;;
   8 ;;;; Filename:      browser.lisp
   9 ;;;; Description:   A CLIM browser/inspector of Movitz images.
  10 ;;;; Author:        Frode Vatvedt Fjeld <frodef@acm.org>
  11 ;;;; Created at:    Thu Jun 14 15:14:35 2001
  12 ;;;;
  13 ;;;; $Id: browser.lisp,v 1.2 2004/01/19 11:23:41 ffjeld Exp $
  14 ;;;;
  15 ;;;;------------------------------------------------------------------
  16
  17 (eval-when (:compile-toplevel :load-toplevel)
  18   #+allegro (require :climxm))
  19
  20 (defpackage movitz-browser
  21   (:use clim clim-lisp movitz binary-types)
  22   (:export browse-file
  23            browse-pid
  24            browse-word
  25            browser))
  26
  27 (in-package movitz-browser)
  28
  29 (define-command-table browser-file-commands
  30     :menu (("Print" :command print-graph)
  31            ("Print preview" :command print-graph-preview)
  32            ("" :divider :line)
  33            ("Quit" :command quit)))
  34
  35 (define-command-table browser-tree-commands
  36     :menu (("Set NIL as root" :command (read-and-set-root nil))
  37            ("Enter word" :command set-root-word)))
  38
  39 (define-command quit ()
  40   (frame-exit *application-frame*))
  41
  42 (define-command print-graph ()
  43   (multiple-value-call #'warn
  44     "print!: ~S :"
  45     (select-file *application-frame*)))
  46
  47 (define-command print-graph-preview ()
  48   (let ((temp-name (sys:make-temp-file-name "browser-graph-preview")))
  49     (with-open-file (temp-file temp-name :direction :output)
  50       (with-output-to-postscript-stream (ps-stream temp-file)
  51         (display-graph *application-frame* ps-stream)))
  52     (excl:run-shell-command (format nil "gv -resize ~S; rm ~S" temp-name temp-name) :wait nil)))
  53
  54 (define-application-frame browser ()
  55   ((root-tuple
  56     :initarg :root-tuple
  57     :accessor browser-root-tuple))
  58   (:menu-bar t)
  59   (:pointer-documentation t)
  60   (:command-table (browser
  61                    :menu (("File" :menu browser-file-commands)
  62                           ("Tree" :menu browser-tree-commands))
  63                    :inherit-from (browser-file-commands browser-tree-commands)))
  64   (:panes
  65    (graph
  66     :application
  67     ;; :label "Object Graph"
  68     ;; :scroll-bars nil
  69     :initial-cursor-visibility nil
  70     :display-function 'display-graph))
  71   (:layouts
  72    (default (horizontally ()
  73               graph))))
  74
  75
  76 (defstruct graph-tuple
  77   tree
  78   object
  79   parent
  80   slot-name)
  81
  82 (define-presentation-type graph-tuple () :inherit-from t)
  83
  84 (defun display-graph (browser *standard-output*)
  85   (format-graph-from-root (browser-root-tuple browser)
  86                           ;; printer
  87                           #'(lambda (tuple *standard-output*)
  88                               (with-output-as-presentation (t tuple 'graph-tuple)
  89                                 (with-slots (object slot-name) tuple
  90                                   (formatting-table ()
  91                                     (formatting-column ()
  92                                       (when slot-name
  93                                         (formatting-cell (t :align-x :center)
  94                                           (display-child-spec slot-name)))
  95                                       (formatting-cell (t :align-x :center)
  96                                         (present object)))))))
  97                           ;; child-producer
  98                           #'(lambda (tuple)
  99                               (with-slots (tree object parent slot-name) tuple
 100                                 ;; (warn "child-of: ~S" (type-of object))
 101                                 (mapcar #'(lambda (child-slot-name)
 102                                             (make-graph-tuple
 103                                              :tree tree
 104                                              :object (browser-child object child-slot-name)
 105                                              :parent object
 106                                              :slot-name child-slot-name))
 107                                         (browser-open-slots tree object parent slot-name))))
 108                           :graph-type :digraph
 109                           :within-generation-separation 2
 110                           :maximize-generations nil
 111                           :generation-separation 60
 112                           :store-objects t
 113                           :center-nodes nil
 114                           :orientation :horizontal ;; :vertical
 115                           ;; :duplicate-key #'cdr
 116                           ;; :duplicate-test #'equalp
 117                           :merge-duplicates t
 118                           :cutoff-depth 50))
 119
 120
 121 (defun display-child-spec (spec)
 122   (case (first spec)
 123     (slot-value
 124      (with-drawing-options (t :ink +green+ :size :small)
 125        (princ (string-downcase (format nil "~A" (second spec))))))
 126     (otherwise
 127      (princ spec))))
 128
 129 (defmethod movitz-object-browser-properties ((object t)) nil)
 130
 131 (defmethod browser-child ((object movitz-heap-object) child-spec)
 132   (ecase (car child-spec)
 133     (slot-value
 134      (slot-value object (second child-spec)))))
 135
 136 (defclass browser-array ()
 137   ((type
 138     :initarg :type
 139     :reader browser-array-type)
 140    (elements
 141     :initarg :elements
 142     :reader browser-array-elements)))
 143
 144 (define-presentation-type browser-array ())
 145
 146 (defmethod browser-child ((object movitz-vector) child-spec)
 147   (destructuring-bind (operator &rest operands)
 148       child-spec
 149     (case operator
 150       (aref
 151        (nth (first operands)
 152             (movitz-vector-symbolic-data object)))
 153       (array
 154        (make-instance 'browser-array
 155          :type (movitz-vector-element-type object)
 156          :elements (movitz-vector-symbolic-data object)))
 157       (t (call-next-method object child-spec)))))
 158
 159 (defmethod browser-child ((object movitz-struct) child-spec)
 160   (destructuring-bind (operator &rest operands)
 161       child-spec
 162     (case operator
 163       (struct-ref
 164        (nth (first operands)
 165             (movitz-struct-slot-values object)))
 166       (t (call-next-method)))))
 167
 168
 169 (defun browser-slot-value (object slot-name)
 170   (case (binary-slot-type (type-of object) slot-name)
 171     (word (movitz-word (binary-slot-value object slot-name)))
 172     (t (if (slot-boundp object slot-name)
 173            (slot-value object slot-name)
 174          (make-symbol "[UNBOUND]")))))
 175
 176 (defun browser-all-slots (object)
 177   (mapcar #'(lambda (slot-name) (list 'slot-value slot-name))
 178           (binary-record-slot-names (type-of object))))
 179
 180 (defmethod browser-default-open-slots ((object movitz-heap-object))
 181   (reverse (set-difference (browser-all-slots object)
 182                            '((slot-value movitz::type))
 183                            :key #'second)))
 184
 185 (defmethod browser-default-open-slots ((object movitz-vector))
 186   (assert (= (length (movitz-vector-symbolic-data object))
 187              (movitz-vector-num-elements object)))
 188   (append (remove 'movitz::data (call-next-method object) :key #'second)
 189           (case (movitz-vector-element-type object)
 190             (:any-t
 191              ;; merge EQ elements..
 192              (loop for (value next-value) on (movitz-vector-symbolic-data object)
 193                  as i upfrom 0
 194                  with start-index = 0
 195                  unless (and next-value
 196                              (= (movitz-intern value)
 197                                 (movitz-intern next-value)))
 198                  collect `(aref ,start-index ,@(unless (= i start-index) (list i)))
 199                  and do (setf start-index (1+ i))))
 200             (t (list `(array ,(movitz-vector-num-elements object)))))))
 201
 202 (defmethod browser-default-open-slots ((object movitz-struct))
 203   (append (remove 'movitz::slot0 (call-next-method object) :key #'second)
 204           (loop for x from 0 below (movitz-struct-length object)
 205               collect `(struct-ref ,x))))
 206
 207 (defun browse-image (*image* &key (root (make-graph-tuple
 208                                          :object (movitz-word (movitz-read-and-intern nil 'word))
 209                                          :tree (gensym))))
 210   (let ((*endian* :little-endian)
 211         (*print-radix* t)
 212         (*print-base* 16))
 213     (run-frame-top-level
 214      (make-application-frame 'browser
 215                              :width 700
 216                              :height 700
 217                              :root-tuple root))))
 218
 219 (defun browse-word (word)
 220   (browse-image movitz::*image*
 221                 :root (make-graph-tuple :object (movitz-word word)
 222                                         :tree (gensym))))
 223
 224 (defun browser ()
 225   (multiprocessing:process-run-function "browser" #'browse-image *i*))
 226
 227 (defun browse-pid (pid)
 228   (flet ((do-browse-pid (pid)
 229            (with-procfs-image (pid)
 230              (browse-image *image*))))
 231     (multiprocessing:process-run-function
 232      `(:name "browser")
 233      #'do-browse-pid
 234      pid)))
 235
 236 (defun browse-file (&key (threadp t) (path *default-image-file*)
 237                          (offset (- 512 #x100000)) (direction :input))
 238   (flet ((do-browse-path (path offset direction)
 239            (with-binary-file (stream path :direction direction)
 240              (browse-image (make-instance 'stream-image
 241                              :stream stream
 242                              :offset offset)))))
 243     (if threadp
 244         (multiprocessing:process-run-function "browser" #'do-browse-path
 245                                               path offset direction)
 246       (do-browse-path path offset direction))))
 247
 248
 249 (define-presentation-type movitz-object ())
 250
 251 (define-presentation-method present (object (type movitz-object)
 252                                             *standard-output*
 253                                             (view textual-view) &key)
 254   (formatting-table ()
 255     (formatting-column ()
 256       (formatting-cell (t :align-x :center)
 257         (with-drawing-options (t :size :small)
 258           (browser-print-safely object)))
 259       (formatting-cell (t :align-x :center)
 260         (format t "#x~8,'0X" (movitz-intern object))))))
 261
 262 (define-presentation-method present
 263     (object (type movitz-object) *standard-output* (view textual-menu-view) &key)
 264   (format t "#x~8,'0X" (movitz-intern object)))
 265
 266 (define-presentation-method present
 267     (object (type graph-tuple) *standard-output* (view textual-menu-view) &key)
 268   (format t "#x~8,'0X" (movitz-intern (graph-tuple-object object))))
 269
 270 (define-presentation-method present (object (type movitz-character)
 271                                             *standard-output*
 272                                             (view textual-view) &key)
 273   (write (movitz-char object)))
 274
 275 (define-presentation-method present
 276     (object (type movitz-symbol) *standard-output* (view textual-view) &key)
 277   (format t "#x~8,'0X: |~A|" (movitz-intern object) (browser-print-safely object)))
 278
 279 (define-presentation-method present
 280     (object (type movitz-vector) *standard-output* (view textual-view) &key)
 281   (if (not (eq :character (movitz-vector-element-type object)))
 282       (call-next-method)
 283     (format t "#x~8,'0X: \"~A\"" (movitz-intern object) (browser-print-safely object))))
 284
 285 (defun browser-print-safely (object)
 286   (handler-case
 287       (movitz::movitz-print object)
 288     (error ()
 289       (write-string (string-downcase (symbol-name (type-of object)))))))
 290
 291 (define-presentation-method present (object (type browser-array)
 292                                             *standard-output*
 293                                             (view textual-view) &key)
 294   (let ((rows-per-col (typecase (length (browser-array-elements object))
 295                         ((integer 0 15) 1)
 296                         ((integer 16 47) 2)
 297                         ((integer 48 127) 4)
 298                         (t 8))))
 299     (formatting-table ()
 300       (loop for row on (browser-array-elements object) by #'(lambda (x) (nthcdr rows-per-col x))
 301           as i upfrom 0 by rows-per-col
 302           do (formatting-row ()
 303                (formatting-cell (t :align-x :right)
 304                  (format t "~D:" i))
 305                (loop for r from 1 to rows-per-col
 306                    as element in row
 307                    do (formatting-cell ()
 308                         (case (browser-array-type object)
 309                           (:u32 (format t "#x~8,'0X" element))
 310                           ((:u8 :code)  (format t "#x~2,'0X" element))
 311                           (t #+ignore(warn "unk: ~S" (browser-array-type object))
 312                              (write element))))))))))
 313
 314 (define-browser-command read-and-set-root ((object 't))
 315   (set-root (movitz-word (movitz-read-and-intern object 'word))))
 316
 317 (define-browser-command toggle ((tuple 'graph-tuple))
 318   (with-slots (tree object parent slot-name) tuple
 319     (cond
 320      ((null (browser-open-slots tree object parent slot-name))
 321       (setf (browser-open-slots tree object parent slot-name)
 322         (browser-default-open-slots object)))
 323       ;; (warn "now open: ~S" (browser-open-slots tree object parent slot-name)))
 324      (t
 325       (setf (browser-open-slots tree object parent slot-name)
 326         nil)))))
 327
 328 (define-presentation-to-command-translator toggle
 329     (graph-tuple
 330      toggle
 331      browser
 332      :gesture :select
 333      :tester ((object)
 334               (typep (graph-tuple-object object) 'movitz-heap-object)))
 335   (object)
 336   (list object))
 337
 338 (define-browser-command set-root ((object 'movitz-object))
 339   (setf (browser-root-tuple *application-frame*)
 340     (make-graph-tuple :tree (gensym) :object object)))
 341
 342 (define-presentation-to-command-translator set-root-tuple
 343     (graph-tuple set-root browser)
 344   (object)
 345   (list (graph-tuple-object object)))
 346
 347 (define-browser-command new-browser ((object 'movitz-object))
 348   (browse-image *image* :root (make-graph-tuple :tree (gensym)
 349                                                 :object object)))
 350
 351 (define-presentation-to-command-translator new-browser-tuple
 352     (graph-tuple new-browser browser)
 353   (object)
 354   (list (graph-tuple-object object)))
 355
 356 (defun (setf browser-open-slots) (value tree object parent slot-name)
 357   (let ((old-slot (assoc-if #'(lambda (x) (and (eq (car x) parent) (eq (cdr x) slot-name)))
 358                             (getf (movitz-object-browser-properties object) tree))))
 359     (if old-slot
 360         (setf (cdr old-slot) value)
 361       (setf (getf (movitz-object-browser-properties object) tree)
 362         (acons (cons parent slot-name)
 363                value
 364                (getf (movitz-object-browser-properties object) tree)))))
 365   value)
 366
 367 (defun browser-open-slots (tree object parent slot-name)
 368   (cdr (assoc-if #'(lambda (x) (and (eq (car x) parent) (eq (cdr x) slot-name)))
 369                  (getf (movitz-object-browser-properties object) tree))))
 370
 371
 372 (define-browser-command set-root-word ()
 373   (let ((word (accepting-values (t :own-window t)
 374                 (accept '((integer 0 #xffffffff) :base 16)))))
 375     (when word
 376       (set-root (movitz-word word)))))