home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / where.scm < prev    next >
Text File  |  1999-01-02  |  4KB  |  131 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: where.scm,v 14.11 1999/01/02 06:19:10 cph Exp $
  4.  
  5. Copyright (c) 1988-1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Environment Inspector
  23. ;;; package: (runtime environment-inspector)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define (where #!optional environment)
  28.   (with-simple-restart 'CONTINUE "Return from WHERE."
  29.     (lambda ()
  30.       (let ((wstate
  31.          (make-wstate
  32.           (list
  33.            (if (default-object? environment)
  34.            (nearest-repl/environment)
  35.            (->environment environment))))))
  36.     (letter-commands
  37.      command-set
  38.      (cmdl-message/active
  39.       (lambda (port)
  40.         (show-current-frame wstate true port)
  41.         (debugger-message
  42.          port
  43.          "You are now in the environment inspector.  Type q to quit, ? for commands.")))
  44.      "where>"
  45.      wstate)))))
  46.  
  47. (define-structure (wstate
  48.            (conc-name wstate/))
  49.   frame-list)
  50.  
  51. (define (initialize-package!)
  52.   (set!
  53.    command-set
  54.    (make-command-set
  55.     'WHERE-COMMANDS
  56.     `((#\? ,standard-help-command
  57.        "help, list command letters")
  58.       (#\A ,show-all
  59.        "show All bindings in current environment and its ancestors")
  60.       (#\C ,show
  61.        "show bindings of identifiers in the Current environment")
  62.       (#\E ,enter
  63.        "Enter a read-eval-print loop in the current environment")
  64.       (#\O ,command/print-environment-procedure
  65.        "pretty print the procedure that created the current environment")
  66.       (#\P ,parent
  67.        "move to environment that is Parent of current environment")
  68.       (#\Q ,standard-exit-command
  69.        "Quit (exit environment inspector)")
  70.       (#\S ,son
  71.        "move to child of current environment (in current chain)")
  72.       (#\V ,show-object
  73.        "eValuate expression in current environment")
  74.       (#\W ,recursive-where
  75.        "enter environment inspector (Where) on the current environment")
  76.       )))
  77.   unspecific)
  78.  
  79. (define command-set)
  80.  
  81. (define (show wstate port)
  82.   (show-current-frame wstate false port))
  83.  
  84. (define (show-current-frame wstate brief? port)
  85.   (debugger-presentation port
  86.     (lambda ()
  87.       (let ((frame-list (wstate/frame-list wstate)))
  88.     (show-frame (car frame-list)
  89.             (length (cdr frame-list))
  90.             brief?
  91.             port)))))
  92.  
  93. (define (show-all wstate port)
  94.   (show-frames (car (last-pair (wstate/frame-list wstate))) 0 port))
  95.  
  96. (define (parent wstate port)
  97.   (let ((frame-list (wstate/frame-list wstate)))
  98.     (if (eq? true (environment-has-parent? (car frame-list)))
  99.     (begin
  100.       (set-wstate/frame-list! wstate
  101.                   (cons (environment-parent (car frame-list))
  102.                     frame-list))
  103.       (show-current-frame wstate true port))
  104.     (debugger-failure port "The current frame has no parent"))))
  105.  
  106. (define (son wstate port)
  107.   (let ((frames (wstate/frame-list wstate)))
  108.     (if (null? (cdr frames))
  109.     (debugger-failure
  110.      port
  111.      "This is the original frame; its children cannot be found")
  112.     (begin
  113.       (set-wstate/frame-list! wstate (cdr frames))
  114.       (show-current-frame wstate true port)))))
  115.  
  116. (define (command/print-environment-procedure wstate port)
  117.   (show-environment-procedure (car (wstate/frame-list wstate)) port))
  118.  
  119. (define (recursive-where wstate port)
  120.   (let ((inp (prompt-for-expression "Object to evaluate and examine" port)))
  121.     (debugger-message port "New where!")
  122.     (debug/where (debug/eval inp (car (wstate/frame-list wstate))))))
  123.  
  124. (define (enter wstate port)
  125.   port
  126.   (debug/read-eval-print (car (wstate/frame-list wstate))
  127.              "the environment inspector"
  128.              "the environment for this frame"))
  129.  
  130. (define (show-object wstate port)
  131.   (debug/read-eval-print-1 (car (wstate/frame-list wstate)) port))