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 / dbgcmd.scm < prev    next >
Text File  |  1999-01-02  |  4KB  |  144 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: dbgcmd.scm,v 14.16 1999/01/02 06:11:34 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. ;;;; Debugger Command Loop Support
  23. ;;; package: (runtime debugger-command-loop)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define (make-command-set name definitions)
  28.   (let ((command-set (list name)))
  29.     (for-each (lambda (entry)
  30.         (define-letter-command command-set
  31.           (car entry)
  32.           (if (eq? standard-help-command (cadr entry))
  33.               (standard-help-command command-set)
  34.               (cadr entry))
  35.           (caddr entry)))
  36.           definitions)
  37.     command-set))
  38.  
  39. (define (define-letter-command command-set new-command function help-text)
  40.   (let ((entry (assv new-command (cdr command-set))))
  41.     (if entry
  42.     (set-cdr! entry (list function help-text))
  43.     (let loop ((command-set command-set))
  44.       (if (or (null? (cdr command-set))
  45.           (char<? new-command (caadr command-set)))
  46.           (set-cdr! command-set
  47.             (cons (list new-command function help-text)
  48.                   (cdr command-set)))
  49.           (loop (cdr command-set)))))))
  50.  
  51. (define (letter-commands command-set message prompt state)
  52.   (cmdl/start (push-cmdl letter-commands/driver
  53.              (vector command-set prompt state)
  54.              '())
  55.           message))
  56.  
  57. (define (letter-commands/driver cmdl)
  58.   (call-with-current-continuation
  59.    (lambda (continuation)
  60.      (let ((port (cmdl/port cmdl)))
  61.        (bind-condition-handler (list condition-type:error)
  62.        (lambda (condition)
  63.          (beep port)
  64.          (fresh-line port)
  65.          (write-string ";Ignoring error:\n;" port)
  66.          (write-condition-report condition port)
  67.          (continuation unspecific))
  68.      (lambda ()
  69.        (let ((state (cmdl/state cmdl)))
  70.          (let ((command-set (vector-ref state 0))
  71.            (prompt (vector-ref state 1))
  72.            (state (vector-ref state 2)))
  73.            (let loop ()
  74.          (let ((entry
  75.             (assv (char-upcase
  76.                    (prompt-for-command-char (cons 'STANDARD prompt)
  77.                             port))
  78.                   (cdr command-set))))
  79.            (if entry
  80.                ((cadr entry) state port)
  81.                (begin
  82.              (beep port)
  83.              (newline port)
  84.              (write-string "Unknown command character" port)
  85.              (loop))))))))))))
  86.   (cmdl-message/null))
  87.  
  88. (define ((standard-help-command command-set) state port)
  89.   state                    ;ignore
  90.   (for-each (lambda (entry)
  91.           (newline port)
  92.           (write-string "   " port)
  93.           (write-char (car entry) port)
  94.           (write-string "   " port)
  95.           (write-string (caddr entry) port))
  96.         (cdr command-set))
  97.   unspecific)
  98.  
  99. (define (standard-exit-command state port)
  100.   state                    ;ignore
  101.   (continue)
  102.   (debugger-failure port "Can't exit; use a restart command instead."))
  103.  
  104. (define (initialize-package!)
  105.   (set! hook/leaving-command-loop default/leaving-command-loop)
  106.   unspecific)
  107.  
  108. (define (leaving-command-loop thunk)
  109.   (hook/leaving-command-loop thunk))
  110.  
  111. (define hook/leaving-command-loop)
  112. (define (default/leaving-command-loop thunk)
  113.   (thunk))
  114.  
  115. (define (debug/read-eval-print environment from to)
  116.   (leaving-command-loop
  117.    (lambda ()
  118.      (with-simple-restart 'CONTINUE
  119.      (lambda (port)
  120.        (write-string "Return to " port)
  121.        (write-string from port)
  122.        (write-string "." port))
  123.        (lambda ()
  124.      (read-eval-print
  125.       environment
  126.       (cmdl-message/strings
  127.        (string-append "You are now in " to ".")
  128.        (string-append "Type C-c C-u to return to " from "."))
  129.       user-initial-prompt))))))
  130.  
  131. (define (debug/eval expression environment)
  132.   (leaving-command-loop
  133.    (lambda ()
  134.      (eval expression environment))))
  135.  
  136. (define (debug/scode-eval expression environment)
  137.   (leaving-command-loop
  138.    (lambda ()
  139.      (extended-scode-eval expression environment))))
  140.  
  141. (define (debug/where environment)
  142.   (leaving-command-loop
  143.    (lambda ()
  144.      (where environment))))