home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-385-Vol-1of3.iso / s / s48.zip / MISC / INSPECT.SCM < prev    next >
Text File  |  1992-06-18  |  7KB  |  235 lines
  1. ; Copyright (c) 1992 by Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3.  
  4. ; A dirty little inspector.
  5. ; This breaks abstractions left and right.
  6. ; Look and feel shamelessly plagiarized from the Lucid Lisp inspector.
  7. ; Fortunately, I have no assets.
  8.  
  9. ; Eventually, integrate this with the command processor (maybe a
  10. ; "colon mode" or "command preferred mode").
  11.  
  12. ; If they aren't already in the system, the following incantation will
  13. ; make the :inspect <thing> and :debug commands available at the
  14. ; Scheme48 command processor:
  15. ;
  16. ;   :enable
  17. ;   :load misc/inspect.scm
  18. ;   :disable
  19.  
  20. (define *menu-limit* 15)
  21.  
  22. (define (inspect thing)
  23.   (let ((i-port (current-input-port)))
  24.     (let new ((thing thing) (stack '()))
  25.       (let-fluid $abbreviate-depth 5
  26.     (lambda ()
  27.           (print-command-result thing)))
  28.       (let ((menu (prepare-menu thing)))
  29.     (let more ((start 0))
  30.       (display-menu menu start)
  31.       (let loop ()
  32.         (display "inspect: ")
  33.         (let ((command (read-form i-port))
  34.           (lose (lambda ()
  35.               (display "?") (newline) (loop))))
  36.           (if (char=? (peek-char i-port) #\newline)
  37.           (read-char i-port))
  38.           (cond ((eof-object? command) (unspecified)) ;quit
  39.             ((symbol? command)
  40.              (case command
  41.                ((q) (unspecified))
  42.                ((u)        ;Up (pop stack)
  43.             (if (pair? stack)
  44.                 (new (car stack)
  45.                  (cdr stack))
  46.                 (lose)))
  47.                ((d)        ;Down stack
  48.             (if (continuation? thing)
  49.                 (new (next-ripe-continuation thing)
  50.                  (cons thing stack))
  51.                 (lose)))
  52.                ((m)        ;More
  53.             (if (> (length menu) (+ *menu-limit* start))
  54.                 (more (+ start *menu-limit*))
  55.                 (lose)))
  56.                ((dis)
  57.             (disassemble thing)
  58.             (loop))
  59.                ((tem)        ;Template
  60.             (cond ((closure? thing)
  61.                    (new (closure-template thing)
  62.                     (cons thing stack)))
  63.                   ((continuation? thing)
  64.                    (new (continuation-template thing)
  65.                     (cons thing stack)))
  66.                   (else (lose))))
  67.                ((?)
  68.             (inspect-help)
  69.             (loop))
  70.                (else (lose))))
  71.             ((and (integer? command)
  72.               (>= command 0)
  73.               (< command (length menu)))
  74.              (new (menu-ref menu command)
  75.               (cons thing stack)))
  76.             ((pair? command)
  77.              (let ((foo (eval command (fluid $package-for-commands))))
  78.                (if (eq? foo (unspecified))
  79.                (loop)
  80.                (new foo (cons thing stack)))))
  81.             (else (lose))))))))))
  82.  
  83. (define (inspect-help)
  84.   (for-each (lambda (s) (display s) (newline))
  85.             '("q        quit"
  86.               "u        up stack (= go to previous object)"
  87.               "d        down stack"
  88.               "dis      disassemble"
  89.               "tem      template"
  90.               "<form>   evaluate a form (## is current object)")))
  91.               
  92.  
  93. (define (menu-ref menu n)
  94.   (cadr (list-ref menu n)))
  95.  
  96. (define (prepare-menu thing)
  97.   (cond ((list? thing)
  98.          (map (lambda (x) (list #f x))
  99.               thing))
  100.  
  101.         ((pair? thing)
  102.          `((car ,(car thing)) (cdr ,(cdr thing))))
  103.  
  104.         ((vector? thing)
  105.          (prepare-menu (vector->list thing)))
  106.  
  107.         ((closure? thing)
  108.          (prepare-environment-menu
  109.               (closure-env thing)
  110.               (get-shape (template-debug-data (closure-template thing))
  111.                          0)))
  112.  
  113.         ((continuation? thing)
  114.          (prepare-continuation-menu thing))
  115.  
  116.         ((record? thing)
  117.          (prepare-record-menu thing))
  118.  
  119.         ((location? thing)
  120.          `((id ,(location-id thing))
  121.            (contents ,(contents thing))))
  122.  
  123.         (else '())))
  124.  
  125. (define (prepare-continuation-menu thing)
  126.   (let ((dd (template-debug-data (continuation-template thing)))
  127.         (next (next-ripe-continuation thing)))
  128.     (if dd
  129.         (let ((source (assoc (continuation-pc thing)
  130.                              (debug-data-source dd))))
  131.           (if source
  132.               ;; Gross.  We really shouldn't be doing output during
  133.               ;; menu preparation.
  134.               (begin (newline)
  135.                      (display "Source: ")
  136.                      (write (cdr source))))))
  137.     `(,@(let recur ((c thing))
  138.           (if (eq? c next)
  139.               '()
  140.               (let ((z (- (continuation-length c) continuation-overhead)))
  141.                 (do ((i (- z 1) (- i 1))
  142.                      (l (recur (continuation-cont c))
  143.                         (cons (list #f (continuation-arg c i)) l)))
  144.                     ((< i 0) l)))))
  145.       ,@(prepare-environment-menu
  146.          (continuation-env thing)
  147.          (get-shape dd (continuation-pc thing))))))
  148.  
  149. (define (prepare-record-menu thing)
  150.   (let ((rt (record-type thing))
  151.         (z (record-length thing)))
  152.     (if (record-type? rt)
  153.         (do ((i (- z 1) (- i 1))
  154.              (f (reverse (record-ref rt 3)) (cdr f))
  155.              (l '() (cons (list (car f) (record-ref thing i)) l)))
  156.             ((< i 1) l))
  157.         (do ((i (- z 1) (- i 1))
  158.              (l '() (cons (list #f (record-ref thing i)) l)))
  159.             ((< i 0) l)))))
  160.  
  161. (define (display-menu menu start)
  162.   (let-fluid $abbreviate-depth 5
  163.     (lambda ()
  164.       (let ((menu (list-tail menu start))
  165.         (limit (+ start *menu-limit*)))
  166.     (if (not (null? menu))
  167.         (newline))
  168.     (let loop ((i start) (menu menu))
  169.       (cond ((null? menu))
  170.         ((>= i limit) (display "[m] more...") (newline))
  171.         (else
  172.          (let ((item (car menu)))
  173.            (display "[")
  174.            (write i)
  175.            (if (car item)
  176.                (begin (display ": ")
  177.                   (write (car item))))
  178.            (display "] ")
  179.            (write (value->expression (abbreviate (cadr item))))
  180.            (newline)
  181.            (loop (+ i 1) (cdr menu))))))))))
  182.  
  183. (define-command 'inspect "<exp>" "inspector (? for help)"
  184.   '(value) inspect)
  185.  
  186. (define (debug)
  187.   (inspect (command-loop-continuation)))
  188.  
  189. (define-command 'debug "" "inspect the stack"
  190.   '() debug)
  191.  
  192.  
  193.  
  194.  
  195. (define (prepare-environment-menu env shape)
  196.   (if (vector? env)
  197.       (let ((values (reverse (cdr (vector->list env)))))
  198.         (if (pair? shape)
  199.             (append (map list (car shape) values)
  200.                     (prepare-environment-menu (vector-ref env 0)
  201.                                               (cdr shape)))
  202.             (append (map (lambda (x) (list #f x)) values)
  203.                     (prepare-environment-menu (vector-ref env 0) shape))))
  204.       '()))
  205.  
  206. ; Returns a list of proper lists describing the environment in effect
  207. ; at the given pc with the given template's code vector.
  208. ;
  209. ; Entries in the environment-maps table (one per template) have the form
  210. ;   #(parent-uid pc-in-parent (env-map ...))
  211. ;
  212. ; Each environment map (one per let or lambda-expression) has the form
  213. ;   #(pc-before pc-after (var ...) (env-map ...))
  214. ;
  215. ; Cf. procedure (note-environment vars segment) in comp.scm.
  216.  
  217. (define (get-shape dd pc)
  218.   (if dd
  219.       (let loop ((emaps (debug-data-env-maps dd))
  220.                  (shape (get-shape (get-debug-data
  221.                                     (debug-data-parent dd))
  222.                                    (debug-data-pc-in-parent dd))))
  223.         (if (null? emaps)
  224.             shape
  225.             (let ((pc-before (vector-ref (car emaps) 0))
  226.                   (pc-after  (vector-ref (car emaps) 1))
  227.                   (vars      (vector-ref (car emaps) 2))
  228.                   (more-maps (vector-ref (car emaps) 3)))
  229.               (if (and (>= pc pc-before)
  230.                        (< pc pc-after))
  231.                   (loop more-maps
  232.                         (cons (vector->list vars) shape))
  233.                   (loop (cdr emaps) shape)))))
  234.       '()))
  235.