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 / debug.scm < prev    next >
Text File  |  1999-12-20  |  33KB  |  964 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: debug.scm,v 14.40 1999/12/20 23:08:22 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
  23. ;;; package: (runtime debugger)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define debugger:student-walk? false)
  28. (define debugger:print-return-values? false)
  29. (define debugger:auto-toggle? true)
  30. (define debugger:count-subproblems-limit 50)
  31. (define debugger:use-history? false)
  32. (define debugger:list-depth-limit 5)
  33. (define debugger:list-breadth-limit 5)
  34. (define debugger:string-length-limit 70)
  35.  
  36. (define (debug #!optional object)
  37.   (if (default-object? object)
  38.       (let ((condition (nearest-repl/condition)))
  39.     (if condition
  40.         (debug-internal condition)
  41.         (call-with-current-continuation debug-internal)))
  42.       (debug-internal object)))
  43.  
  44. (define (debug-internal object)
  45.   (let ((dstate (make-initial-dstate object)))
  46.     (with-simple-restart 'CONTINUE "Return from DEBUG."
  47.       (lambda ()
  48.     (letter-commands
  49.      command-set
  50.      (cmdl-message/active
  51.       (lambda (port)
  52.         (debugger-presentation port
  53.           (lambda ()
  54.         (let ((thread (dstate/other-thread dstate)))
  55.           (if thread
  56.               (begin
  57.             (write-string "This error occurred in another thread: "
  58.                       port)
  59.             (write thread port)
  60.             (newline port))))
  61.         (let ((n (count-subproblems dstate)))
  62.           (write-string "There " port)
  63.           (write-string (if (= n 1) "is" "are") port)
  64.           (write-string " " port)
  65.           (if (> n debugger:count-subproblems-limit)
  66.               (begin
  67.             (write-string "more than " port)
  68.             (write debugger:count-subproblems-limit port))
  69.               (write n port))
  70.           (write-string " subproblem" port)
  71.           (if (not (= n 1))
  72.               (write-string "s" port)))
  73.         (write-string " on the stack." port)
  74.         (newline port)
  75.         (newline port)
  76.         (print-subproblem dstate port)))
  77.         (debugger-message
  78.          port
  79.          "You are now in the debugger.  Type q to quit, ? for commands.")))
  80.      "debug>"
  81.      dstate)))))
  82.  
  83. (define (make-initial-dstate object)
  84.   (let ((make-dstate
  85.      (lambda (stack-frame condition)
  86.        (let ((dstate (allocate-dstate)))
  87.          (set-dstate/history-state!
  88.           dstate
  89.           (cond (debugger:use-history? 'ALWAYS)
  90.             (debugger:auto-toggle? 'ENABLED)
  91.             (else 'DISABLED)))
  92.          (set-dstate/condition! dstate condition)
  93.          (set-current-subproblem!
  94.           dstate
  95.           (let loop ((stack-frame stack-frame))
  96.         (let ((stack-frame
  97.                (stack-frame/skip-non-subproblems stack-frame)))
  98.           (if (not stack-frame)
  99.               (error "No frames on stack!"))
  100.           (if (stack-frame/repl-eval-boundary? stack-frame)
  101.               (loop (stack-frame/next stack-frame))
  102.               stack-frame)))
  103.           '())
  104.          dstate))))
  105.     (cond ((condition? object)
  106.        (make-dstate
  107.         (continuation->stack-frame (condition/continuation object))
  108.         object))
  109.       ((continuation? object)
  110.        (make-dstate (continuation->stack-frame object) false))
  111.       ((stack-frame? object)
  112.        (make-dstate object false))
  113.       (else
  114.        (error:wrong-type-argument object
  115.                       "condition or continuation"
  116.                       'DEBUG)))))
  117.  
  118. (define (count-subproblems dstate)
  119.   (do ((i 0 (1+ i))
  120.        (subproblem (dstate/subproblem dstate)
  121.            (next-subproblem subproblem)))
  122.       ((or (not subproblem) (> i debugger:count-subproblems-limit)) i)))
  123.  
  124. (define-structure (dstate
  125.            (conc-name dstate/)
  126.            (constructor allocate-dstate ()))
  127.   subproblem
  128.   previous-subproblems
  129.   subproblem-number
  130.   number-of-reductions
  131.   reduction-number
  132.   history-state
  133.   expression
  134.   subexpression
  135.   environment-list
  136.   condition)
  137.  
  138. (define (dstate/reduction dstate)
  139.   (nth-reduction (dstate/reductions dstate)
  140.          (dstate/reduction-number dstate)))
  141.  
  142. (define (dstate/reductions dstate)
  143.   (stack-frame/reductions (dstate/subproblem dstate)))
  144.  
  145. (define (initialize-package!)
  146.   (set!
  147.    command-set
  148.    (make-command-set
  149.     'DEBUG-COMMANDS
  150.     `((#\? ,standard-help-command
  151.        "help, list command letters")
  152.       (#\A ,command/show-all-frames
  153.        "show All bindings in current environment and its ancestors")
  154.       (#\B ,command/earlier-reduction
  155.        "move (Back) to next reduction (earlier in time)")
  156.       (#\C ,command/show-current-frame
  157.        "show bindings of identifiers in the Current environment")
  158.       (#\D ,command/later-subproblem
  159.        "move (Down) to the previous subproblem (later in time)")
  160.       (#\E ,command/enter-read-eval-print-loop
  161.        "Enter a read-eval-print loop in the current environment")
  162.       (#\F ,command/later-reduction
  163.        "move (Forward) to previous reduction (later in time)")
  164.       (#\G ,command/goto
  165.        "Go to a particular subproblem")
  166.       (#\H ,command/summarize-subproblems
  167.        "prints a summary (History) of all subproblems")
  168.       (#\I ,command/condition-report
  169.        "redisplay the error message Info")
  170.       (#\J ,command/return-to
  171.        "return TO the current subproblem with a value")
  172.       (#\K ,command/condition-restart
  173.        "continue the program using a standard restart option")
  174.       (#\L ,command/print-expression
  175.        "(List expression) pretty print the current expression")
  176.       (#\M ,command/print-frame-elements
  177.        "(Frame elements) show the contents of the stack frame, in raw form")
  178.       (#\O ,command/print-environment-procedure
  179.        "pretty print the procedure that created the current environment")
  180.       (#\P ,command/move-to-parent-environment
  181.        "move to environment that is Parent of current environment")
  182.       (#\Q ,standard-exit-command
  183.        "Quit (exit debugger)")
  184.       (#\R ,command/print-reductions
  185.        "print the execution history (Reductions) of the current subproblem level")
  186.       (#\S ,command/move-to-child-environment
  187.        "move to child of current environment (in current chain)")
  188.       (#\T ,command/print-subproblem-or-reduction
  189.        "print the current subproblem or reduction")
  190.       (#\U ,command/earlier-subproblem
  191.        "move (Up) to the next subproblem (earlier in time)")
  192.       (#\V ,command/eval-in-current-environment
  193.        "eValuate expression in current environment")
  194.       (#\W ,command/enter-where
  195.        "enter environment inspector (Where) on the current environment")
  196.       (#\X ,command/internal
  197.        "create a read eval print loop in the debugger environment")
  198.       (#\Y ,command/frame
  199.        "display the current stack frame")
  200.       (#\Z ,command/return-from
  201.        "return FROM the current subproblem with a value")
  202.       )))
  203.   (set! hook/debugger-before-return default/debugger-before-return)
  204.   unspecific)
  205.  
  206. (define command-set)
  207.  
  208. (define-macro (define-command bvl . body)
  209.   (let ((dstate (cadr bvl))
  210.     (port (caddr bvl)))
  211.     `(DEFINE (,(car bvl) #!OPTIONAL ,dstate ,port)
  212.        (LET ((,dstate (IF (DEFAULT-OBJECT? ,dstate) *DSTATE* ,dstate))
  213.          (,port (IF (DEFAULT-OBJECT? ,port) *PORT* ,port)))
  214.      ,@body))))
  215.  
  216. ;;;; Display commands
  217.  
  218. (define-command (command/print-subproblem-or-reduction dstate port)
  219.   (if (dstate/reduction-number dstate)
  220.       (command/print-reduction dstate port)
  221.       (command/print-subproblem dstate port)))
  222.  
  223. (define-command (command/print-subproblem dstate port)
  224.   (debugger-presentation port
  225.     (lambda ()
  226.       (print-subproblem dstate port))))
  227.  
  228. (define-command (command/print-reduction dstate port)
  229.   (debugger-presentation port
  230.     (lambda ()
  231.       (print-reduction (dstate/reduction dstate)
  232.                (dstate/subproblem-number dstate)
  233.                (dstate/reduction-number dstate)
  234.                port))))
  235.  
  236. (define-command (command/print-reductions dstate port)
  237.   (let ((reductions (dstate/reductions dstate))
  238.     (subproblem-level (dstate/subproblem-number dstate)))
  239.     (if (pair? reductions)
  240.     (debugger-presentation port
  241.       (lambda ()
  242.         (write-string "Execution history for this subproblem:" port)
  243.         (let loop ((reductions reductions) (number 0))
  244.           (newline port)
  245.           (write-string "----------------------------------------" port)
  246.           (newline port)
  247.           (print-reduction (car reductions) subproblem-level number port)
  248.           (if (pair? (cdr reductions))
  249.           (loop (cdr reductions) (1+ number))))))
  250.     (debugger-failure
  251.      port
  252.      "There is no execution history for this subproblem."))))
  253.  
  254. (define-command (command/print-expression dstate port)
  255.   (debugger-presentation port
  256.     (lambda ()
  257.       (let ((expression (dstate/expression dstate)))
  258.     (cond ((debugging-info/compiled-code? expression)
  259.            (write-string ";compiled code" port))
  260.           ((not (debugging-info/undefined-expression? expression))
  261.            (pretty-print expression port true 0))
  262.           ((debugging-info/noise? expression)
  263.            (write-string ";" port)
  264.            (write-string ((debugging-info/noise expression) false) port))
  265.           (else
  266.            (write-string ";undefined expression" port)))))))
  267.  
  268. (define-command (command/print-environment-procedure dstate port)
  269.   (with-current-environment dstate port
  270.     (lambda (environment)
  271.       (show-environment-procedure environment port))))
  272.  
  273. (define (print-subproblem dstate port)
  274.   (print-subproblem-identification dstate port)
  275.   (newline port)
  276.   (print-subproblem-expression dstate port)
  277.   (print-subproblem-environment dstate port)
  278.   (print-subproblem-reduction dstate port))
  279.  
  280. (define (print-subproblem-identification dstate port)
  281.   (let ((subproblem (dstate/subproblem dstate)))
  282.     (write-string "Subproblem level: " port)
  283.     (let ((level (dstate/subproblem-number dstate))
  284.       (qualify-level
  285.        (lambda (adjective)
  286.          (write-string " (this is the " port)
  287.          (write-string adjective port)
  288.          (write-string " subproblem level)" port))))
  289.       (write level port)
  290.       (cond ((not (next-subproblem subproblem))
  291.          (qualify-level (if (zero? level) "only" "highest")))
  292.         ((zero? level)
  293.          (qualify-level "lowest"))))))
  294.  
  295. (define (print-subproblem-expression dstate port)
  296.   (let ((expression (dstate/expression dstate))
  297.     (subproblem (dstate/subproblem dstate)))
  298.     (cond ((not (invalid-expression? expression))
  299.        (write-string (if (stack-frame/compiled-code? subproblem)
  300.                  "Compiled code expression (from stack):"
  301.                  "Expression (from stack):")
  302.              port)
  303.        (newline port)
  304.        (let ((subexpression (dstate/subexpression dstate)))
  305.          (if (or (debugging-info/undefined-expression? subexpression)
  306.              (debugging-info/unknown-expression? subexpression))
  307.          (debugger-pp expression expression-indentation port)
  308.          (begin
  309.            (debugger-pp
  310.             (unsyntax-with-substitutions
  311.              expression
  312.              (list (cons subexpression subexpression-marker)))
  313.             expression-indentation
  314.             port)
  315.            (newline port)
  316.            (write-string " subproblem being executed (marked by " port)
  317.            (write subexpression-marker port)
  318.            (write-string "):" port)
  319.            (newline port)
  320.            (debugger-pp subexpression expression-indentation port)))))
  321.       ((debugging-info/noise? expression)
  322.        (write-string ((debugging-info/noise expression) true) port))
  323.       (else
  324.        (write-string (if (stack-frame/compiled-code? subproblem)
  325.                  "Compiled code expression unknown"
  326.                  "Expression unknown")
  327.              port)
  328.        (newline port)
  329.        (write (stack-frame/return-address subproblem) port)))))
  330.  
  331. (define subexpression-marker
  332.   ((ucode-primitive string->symbol) "###"))
  333.  
  334. (define (print-subproblem-environment dstate port)
  335.   (let ((environment-list (dstate/environment-list dstate)))
  336.     (if (pair? environment-list)
  337.     (print-environment (car environment-list) port)
  338.     (begin
  339.       (newline port)
  340.       (write-string "There is no current environment." port)))))
  341.  
  342. (define (print-subproblem-reduction dstate port)
  343.   (let ((n-reductions (dstate/number-of-reductions dstate)))
  344.     (newline port)
  345.     (if (positive? n-reductions)
  346.     (begin
  347.       (write-string "The execution history for this subproblem contains "
  348.             port)
  349.       (write n-reductions port)
  350.       (write-string " reduction" port)
  351.       (if (> n-reductions 1)
  352.           (write-string "s" port))
  353.       (write-string "." port))
  354.     (write-string "There is no execution history for this subproblem."
  355.               port))))
  356.  
  357. (define (print-reduction reduction subproblem-number reduction-number port)
  358.   (print-reduction-identification subproblem-number reduction-number port)
  359.   (newline port)
  360.   (print-reduction-expression reduction port)
  361.   (print-reduction-environment reduction port))
  362.  
  363. (define (print-reduction-identification subproblem-number reduction-number
  364.                     port)
  365.   (write-string "Subproblem level: " port)
  366.   (write subproblem-number port)
  367.   (write-string "  Reduction number: " port)
  368.   (write reduction-number port))
  369.  
  370. (define (print-reduction-expression reduction port)
  371.   (write-string "Expression (from execution history):" port)
  372.   (newline port)
  373.   (debugger-pp (reduction-expression reduction) expression-indentation port))
  374.  
  375. (define (print-reduction-environment reduction port)
  376.   (print-environment (reduction-environment reduction) port))
  377.  
  378. (define (print-environment environment port)
  379.   (newline port)
  380.   (show-environment-name environment port)
  381.   (if (not (environment->package environment))
  382.       (begin
  383.     (newline port)
  384.     (let ((arguments (environment-arguments environment)))
  385.       (if (eq? arguments 'UNKNOWN)
  386.           (show-environment-bindings environment true port)
  387.           (begin
  388.         (write-string " applied to: " port)
  389.         (write-string
  390.          (cdr
  391.           (write-to-string
  392.            arguments
  393.            (- (output-port/x-size port) 11)))
  394.          port)))))))
  395.  
  396. ;;;; Subproblem summary
  397.  
  398. (define-command (command/summarize-subproblems dstate port)
  399.   (let ((top-subproblem
  400.      (let ((previous-subproblems (dstate/previous-subproblems dstate)))
  401.        (if (null? previous-subproblems)
  402.            (dstate/subproblem dstate)
  403.            (car (last-pair previous-subproblems))))))
  404.     (debugger-presentation port
  405.       (lambda ()
  406.     (write-string "SL#  Procedure-name          Expression" port)
  407.     (newline port)
  408.     (let loop ((frame top-subproblem) (level 0))
  409.       (if frame
  410.           (begin
  411.         (with-values (lambda () (stack-frame/debugging-info frame))
  412.           (lambda (expression environment subexpression)
  413.             subexpression
  414.             (terse-print-expression level
  415.                         expression
  416.                         environment
  417.                         port)))
  418.         (loop (next-subproblem frame) (1+ level)))))))))
  419.  
  420. (define (terse-print-expression level expression environment port)
  421.   (newline port)
  422.   (write-string (string-pad-right (number->string level) 4) port)
  423.   (write-string " " port)
  424.   (write-string
  425.    (string-pad-right
  426.     (let ((name
  427.        (and (environment? environment)
  428.         (environment-procedure-name environment))))
  429.       (if (or (not name)
  430.           (special-form-procedure-name? name))
  431.       ""
  432.       (output-to-string 20
  433.         (lambda ()
  434.           (write-dbg-name name (current-output-port))))))
  435.     20)
  436.    port)
  437.   (write-string "    " port)
  438.   (write-string
  439.    (cond ((debugging-info/compiled-code? expression)
  440.       ";compiled code")
  441.      ((not (debugging-info/undefined-expression? expression))
  442.       (output-to-string
  443.        50
  444.        (lambda ()
  445.          (fluid-let ((*unparse-primitives-by-name?* true))
  446.            (write (unsyntax expression))))))
  447.      ((debugging-info/noise? expression)
  448.       (output-to-string
  449.        50
  450.        (lambda ()
  451.          (write-string ((debugging-info/noise expression) false)))))
  452.      (else
  453.       ";undefined expression"))
  454.    port))
  455.  
  456. ;;;; Subproblem motion
  457.  
  458. (define-command (command/earlier-subproblem dstate port)
  459.   (maybe-stop-using-history! dstate port)
  460.   (earlier-subproblem dstate port false finish-move-to-subproblem!))
  461.  
  462. (define (earlier-subproblem dstate port reason if-successful)
  463.   (let ((subproblem (dstate/subproblem dstate)))
  464.     (let ((next (next-subproblem subproblem)))
  465.       (if next
  466.       (begin
  467.         (set-current-subproblem!
  468.          dstate
  469.          next
  470.          (cons subproblem (dstate/previous-subproblems dstate)))
  471.         (if-successful dstate port))
  472.       (debugger-failure
  473.        port
  474.        (reason+message (or reason "no more subproblems")
  475.                "already at highest subproblem level."))))))
  476.  
  477. (define (next-subproblem stack-frame)
  478.   (let ((next (stack-frame/next-subproblem stack-frame)))
  479.     (if (and next (stack-frame/repl-eval-boundary? next))
  480.     (next-subproblem next)
  481.     next)))
  482.  
  483. (define-command (command/later-subproblem dstate port)
  484.   (maybe-stop-using-history! dstate port)
  485.   (later-subproblem dstate port false finish-move-to-subproblem!))
  486.  
  487. (define (later-subproblem dstate port reason if-successful)
  488.   (if (null? (dstate/previous-subproblems dstate))
  489.       (debugger-failure
  490.        port
  491.        (reason+message reason "already at lowest subproblem level."))
  492.       (begin
  493.     (let ((p (dstate/previous-subproblems dstate)))
  494.       (set-current-subproblem! dstate (car p) (cdr p)))
  495.     (if-successful dstate port))))
  496.  
  497. (define-command (command/goto dstate port)
  498.   (maybe-stop-using-history! dstate port)
  499.   (let ((subproblems (select-subproblem dstate port)))
  500.     (set-current-subproblem! dstate (car subproblems) (cdr subproblems)))
  501.   (finish-move-to-subproblem! dstate port))
  502.  
  503. (define (select-subproblem dstate port)
  504.   (let top-level-loop ()
  505.     (let ((delta
  506.        (- (prompt-for-nonnegative-integer "Subproblem number" false port)
  507.           (dstate/subproblem-number dstate))))
  508.       (if (negative? delta)
  509.       (list-tail (dstate/previous-subproblems dstate) (-1+ (- delta)))
  510.       (let loop
  511.           ((subproblem (dstate/subproblem dstate))
  512.            (subproblems (dstate/previous-subproblems dstate))
  513.            (delta delta))
  514.         (if (zero? delta)
  515.         (cons subproblem subproblems)
  516.         (let ((next (next-subproblem subproblem)))
  517.           (if next
  518.               (loop next (cons subproblem subproblems) (-1+ delta))
  519.               (begin
  520.             (debugger-failure
  521.              port
  522.              "Subproblem number too large (limit is "
  523.              (length subproblems)
  524.              " inclusive).")
  525.             (top-level-loop))))))))))
  526.  
  527. ;;;; Reduction motion
  528.  
  529. (define-command (command/earlier-reduction dstate port)
  530.   (maybe-start-using-history! dstate port)
  531.   (let ((up
  532.      (lambda ()
  533.        (earlier-subproblem dstate port false finish-move-to-subproblem!))))
  534.     (if (not (dstate/using-history? dstate))
  535.     (up)
  536.     (let ((n-reductions (dstate/number-of-reductions dstate))
  537.           (reduction-number (dstate/reduction-number dstate))
  538.           (wrap
  539.            (lambda (reason)
  540.          (earlier-subproblem
  541.           dstate
  542.           port
  543.           reason
  544.           (lambda (dstate port)
  545.             (debugger-message
  546.              port
  547.              (reason+message
  548.               reason
  549.               "going to the next (less recent) subproblem."))
  550.             (finish-move-to-subproblem! dstate port))))))
  551.       (cond ((zero? n-reductions)
  552.          (up))
  553.         ((not reduction-number)
  554.          (move-to-reduction! dstate port 0))
  555.         ((and (< reduction-number (-1+ n-reductions))
  556.               (not (and debugger:student-walk?
  557.                 (positive? (dstate/subproblem-number dstate))
  558.                 (= reduction-number 0))))
  559.          (move-to-reduction! dstate port (1+ reduction-number)))
  560.         (debugger:student-walk?
  561.          (up))
  562.         (else
  563.          (wrap "no more reductions")))))))
  564.  
  565. (define-command (command/later-reduction dstate port)
  566.   (maybe-start-using-history! dstate port)
  567.   (let ((down
  568.      (lambda ()
  569.        (later-subproblem dstate port false finish-move-to-subproblem!))))
  570.     (if (not (dstate/using-history? dstate))
  571.     (later-subproblem dstate port false finish-move-to-subproblem!)
  572.     (let ((reduction-number (dstate/reduction-number dstate))
  573.           (wrap
  574.            (lambda (reason)
  575.          (later-subproblem
  576.           dstate
  577.           port
  578.           reason
  579.           (lambda (dstate port)
  580.             (debugger-message
  581.              port
  582.              (reason+message
  583.               reason
  584.               "going to the previous (more recent) subproblem."))
  585.             (let ((n (dstate/number-of-reductions dstate)))
  586.               (if (and n (positive? n))
  587.               (move-to-reduction!
  588.                dstate
  589.                port
  590.                (if (and debugger:student-walk?
  591.                     (positive?
  592.                      (dstate/subproblem-number dstate)))
  593.                    0
  594.                    (-1+ n)))
  595.               (finish-move-to-subproblem! dstate port))))))))
  596.       (cond ((zero? (dstate/number-of-reductions dstate))
  597.          (down))
  598.         ((not reduction-number)
  599.          (wrap false))
  600.         ((positive? reduction-number)
  601.          (move-to-reduction! dstate port (-1+ reduction-number)))
  602.         ((special-history-subproblem? dstate)
  603.          ;; Reset state
  604.          (set-current-subproblem! dstate
  605.                       (dstate/subproblem dstate)
  606.                       (dstate/previous-subproblems dstate))
  607.          (set-dstate/reduction-number! dstate false)
  608.          (command/print-subproblem dstate port))
  609.         (debugger:student-walk?
  610.          (down))
  611.         (else
  612.          (wrap "no more reductions")))))))
  613.  
  614. ;;;; Environment motion and display
  615.  
  616. (define-command (command/show-current-frame dstate port)
  617.   (if (pair? (dstate/environment-list dstate))
  618.       (show-current-frame dstate false port)
  619.       (undefined-environment port)))
  620.  
  621. (define-command (command/show-all-frames dstate port)
  622.   (let ((environment-list (dstate/environment-list dstate)))
  623.     (if (pair? environment-list)
  624.     (show-frames (car (last-pair environment-list)) 0 port)
  625.     (undefined-environment port))))
  626.  
  627. (define-command (command/move-to-parent-environment dstate port)
  628.   (let ((environment-list (dstate/environment-list dstate)))
  629.     (cond ((not (pair? environment-list))
  630.        (undefined-environment port))
  631.       ((eq? true (environment-has-parent? (car environment-list)))
  632.        (set-dstate/environment-list!
  633.         dstate
  634.         (cons (environment-parent (car environment-list))
  635.           environment-list))
  636.        (show-current-frame dstate true port))
  637.       (else
  638.        (debugger-failure port "The current environment has no parent.")))))
  639.  
  640. (define-command (command/move-to-child-environment dstate port)
  641.   (let ((environment-list (dstate/environment-list dstate)))
  642.     (cond ((not (pair? (dstate/environment-list dstate)))
  643.        (undefined-environment port))
  644.       ((not (pair? (cdr environment-list)))
  645.        (debugger-failure
  646.         port
  647.         "This is the initial environment; can't move to child."))
  648.       (else
  649.        (set-dstate/environment-list! dstate (cdr environment-list))
  650.        (show-current-frame dstate true port)))))
  651.  
  652. (define (show-current-frame dstate brief? port)
  653.   (debugger-presentation port
  654.     (lambda ()
  655.       (let ((environment-list (dstate/environment-list dstate)))
  656.     (show-frame (car environment-list)
  657.             (length (cdr environment-list))
  658.             brief?
  659.             port)))))
  660.  
  661. (define-command (command/enter-read-eval-print-loop dstate port)
  662.   (debug/read-eval-print (get-evaluation-environment dstate port)
  663.              "the debugger"
  664.              "the environment for this frame"))
  665.  
  666. (define-command (command/eval-in-current-environment dstate port)
  667.   (debug/read-eval-print-1 (get-evaluation-environment dstate port) port))
  668.  
  669. (define-command (command/enter-where dstate port)
  670.   port
  671.   (with-current-environment dstate port debug/where))
  672.  
  673. ;;;; Condition commands
  674.  
  675. (define-command (command/condition-report dstate port)
  676.   (let ((condition (dstate/condition dstate)))
  677.     (if condition
  678.     (debugger-presentation port
  679.       (lambda ()
  680.         (write-condition-report condition port)))
  681.     (debugger-failure port "No condition to report."))))
  682.  
  683. (define-command (command/condition-restart dstate port)
  684.   (let ((condition (dstate/condition dstate)))
  685.     (let ((restarts
  686.        (if condition
  687.            (condition/restarts condition)
  688.            (bound-restarts))))
  689.       (if (null? restarts)
  690.       (debugger-failure port "No options to choose from.")
  691.       (let ((n-restarts (length restarts))
  692.         (write-index
  693.          (lambda (index port)
  694.            (write-string (string-pad-left (number->string index) 3)
  695.                  port)
  696.            (write-string ":" port))))
  697.         (let ((invoke-option
  698.            (lambda (n)
  699.              (invoke-restart-interactively
  700.               (list-ref restarts (- n-restarts n))
  701.               condition))))
  702.           (debugger-presentation port
  703.         (lambda ()
  704.           (if (= n-restarts 1)
  705.               (begin
  706.             (write-string "There is only one option:" port)
  707.             (write-restarts restarts port write-index)
  708.             (if (prompt-for-confirmation "Use this option" port)
  709.                 (invoke-option 1)))
  710.               (begin
  711.             (write-string "Choose an option by number:" port)
  712.             (write-restarts restarts port write-index)
  713.             (invoke-option
  714.              (prompt-for-integer "Option number"
  715.                          1
  716.                          (+ n-restarts 1)
  717.                          port))))))))))))
  718.  
  719. ;;;; Advanced hacking commands
  720.  
  721. (define-command (command/return-from dstate port)
  722.   (let ((next (next-subproblem (dstate/subproblem dstate))))
  723.     (if next
  724.     (enter-subproblem dstate port next)
  725.     (debugger-failure port "Can't continue!!!"))))
  726.  
  727. (define-command (command/return-to dstate port)
  728.   (enter-subproblem dstate port (dstate/subproblem dstate)))
  729.  
  730. (define (enter-subproblem dstate port subproblem)
  731.   (let ((invalid-expression?
  732.      (invalid-expression? (dstate/expression dstate)))
  733.     (environment (get-evaluation-environment dstate port)))
  734.     (let ((value
  735.        (let ((expression
  736.           (prompt-for-expression
  737.            (string-append
  738.             "Expression to EVALUATE and CONTINUE with"
  739.             (if invalid-expression?
  740.             ""
  741.             " ($ to retry)"))
  742.            port)))
  743.          (if (and (not invalid-expression?)
  744.               (eq? expression '$))
  745.          (debug/scode-eval (dstate/expression dstate)
  746.                    environment)
  747.          (debug/eval expression environment)))))
  748.       (if (or (not debugger:print-return-values?)
  749.           (begin
  750.         (newline port)
  751.         (write-string "That evaluates to:" port)
  752.         (newline port)
  753.         (write value port)
  754.         (prompt-for-confirmation "Confirm" port)))
  755.       (begin
  756.         (hook/debugger-before-return)
  757.         (let ((thread (dstate/other-thread dstate)))
  758.           (if (not thread)
  759.           ((stack-frame->continuation subproblem) value)
  760.           (begin
  761.             (restart-thread thread 'ASK
  762.               (lambda ()
  763.             ((stack-frame->continuation subproblem) value)))
  764.             (continue-from-derived-thread-error
  765.              (dstate/condition dstate))))))))))
  766.  
  767. (define (dstate/other-thread dstate)
  768.   (let ((condition (dstate/condition dstate)))
  769.     (and condition
  770.      (condition/other-thread condition))))
  771.  
  772. (define hook/debugger-before-return)
  773. (define (default/debugger-before-return)
  774.   '())
  775.  
  776. (define *dstate*)
  777. (define *port*)
  778.  
  779. (define (command/internal dstate port)
  780.   (fluid-let ((*dstate* dstate)
  781.           (*port* port))
  782.     (debug/read-eval-print (->environment '(RUNTIME DEBUGGER))
  783.                "the debugger"
  784.                "the debugger environment")))
  785.  
  786. (define-command (command/frame dstate port)
  787.   (debugger-presentation port
  788.     (lambda ()
  789.       (write-string "Stack frame: " port)
  790.       (write (dstate/subproblem dstate) port)
  791.       (for-each (lambda (element)
  792.           (newline port)
  793.           (debugger-pp element 0 port))
  794.         (named-structure/description (dstate/subproblem dstate))))))
  795.  
  796. (define-command (command/print-frame-elements dstate port)
  797.   (debugger-presentation
  798.    port
  799.    (lambda ()
  800.      (write-string "Stack frame elements: " port)
  801.      (for-each-vector-element
  802.       (stack-frame/elements (dstate/subproblem dstate))
  803.       (lambda (element)
  804.     (newline)
  805.     (write element))))))
  806.  
  807. ;;;; Low-level Side-effects
  808.  
  809. (define (maybe-start-using-history! dstate port)
  810.   (if (eq? 'ENABLED (dstate/history-state dstate))
  811.       (begin
  812.     (set-dstate/history-state! dstate 'NOW)
  813.     (if (not (zero? (dstate/number-of-reductions dstate)))
  814.         (debugger-message
  815.          port
  816.          "Now using information from the execution history.")))))
  817.  
  818. (define (maybe-stop-using-history! dstate port)
  819.   (if (eq? 'NOW (dstate/history-state dstate))
  820.       (begin
  821.     (set-dstate/history-state! dstate 'ENABLED)
  822.     (if (not (zero? (dstate/number-of-reductions dstate)))
  823.         (debugger-message
  824.          port
  825.          "Now ignoring information from the execution history.")))))
  826.  
  827. (define (dstate/using-history? dstate)
  828.   (or (eq? 'ALWAYS (dstate/history-state dstate))
  829.       (eq? 'NOW (dstate/history-state dstate))))
  830.  
  831. (define (dstate/auto-toggle? dstate)
  832.   (not (eq? 'DISABLED (dstate/history-state dstate))))
  833.  
  834. (define (set-current-subproblem! dstate stack-frame previous-frames)
  835.   (set-dstate/subproblem! dstate stack-frame)
  836.   (set-dstate/previous-subproblems! dstate previous-frames)
  837.   (set-dstate/subproblem-number! dstate (length previous-frames))
  838.   (set-dstate/number-of-reductions!
  839.    dstate
  840.    (improper-list-length (stack-frame/reductions stack-frame)))
  841.   (with-values (lambda () (stack-frame/debugging-info stack-frame))
  842.     (lambda (expression environment subexpression)
  843.       (set-dstate/expression! dstate expression)
  844.       (set-dstate/subexpression! dstate subexpression)
  845.       (set-dstate/environment-list!
  846.        dstate
  847.        (if (debugging-info/undefined-environment? environment)
  848.        '()
  849.        (list environment))))))
  850.  
  851. (define (finish-move-to-subproblem! dstate port)
  852.   (if (and (dstate/using-history? dstate)
  853.        (positive? (dstate/number-of-reductions dstate))
  854.        (not (special-history-subproblem? dstate)))
  855.       (move-to-reduction! dstate port 0)
  856.       (begin
  857.     (set-dstate/reduction-number! dstate false)
  858.     (command/print-subproblem dstate port))))
  859.  
  860. (define (move-to-reduction! dstate port reduction-number)
  861.   (set-dstate/reduction-number! dstate reduction-number)
  862.   (set-dstate/environment-list!
  863.    dstate
  864.    (list (reduction-environment (dstate/reduction dstate))))
  865.   (command/print-reduction dstate port))
  866.  
  867. (define (special-history-subproblem? dstate)
  868.   (eq? (stack-frame/type (dstate/subproblem dstate))
  869.        stack-frame-type/compiled-return-address))
  870.  
  871. ;;;; Utilities
  872.  
  873. (define (improper-list-length l)
  874.   (let count ((n 0) (l l))
  875.     (if (pair? l)
  876.     (count (1+ n) (cdr l))
  877.     n)))
  878.  
  879. (define (nth-reduction reductions n)
  880.   (let loop ((reductions reductions) (n n))
  881.     (if (zero? n)
  882.     (car reductions)
  883.     (loop (cdr reductions) (-1+ n)))))
  884.  
  885. (define-integrable (reduction-expression reduction)
  886.   (car reduction))
  887.  
  888. (define-integrable (reduction-environment reduction)
  889.   (cadr reduction))
  890.  
  891. (define (wrap-around-in-reductions? reductions)
  892.   (or (eq? 'WRAP-AROUND reductions)
  893.       (and (pair? reductions)
  894.        (eq? 'WRAP-AROUND (cdr (last-pair reductions))))))
  895.  
  896. (define (invalid-expression? expression)
  897.   (or (debugging-info/undefined-expression? expression)
  898.       (debugging-info/compiled-code? expression)))
  899.  
  900. (define (get-evaluation-environment dstate port)
  901.   (let ((environment-list (dstate/environment-list dstate)))
  902.     (if (and (pair? environment-list)
  903.          (environment? (car environment-list)))
  904.     (car environment-list)
  905.     (begin
  906.       (debugger-message
  907.        port
  908.        "Cannot evaluate in current environment;
  909. using the read-eval-print environment instead.")
  910.       (nearest-repl/environment)))))
  911.  
  912. (define (with-current-environment dstate port receiver)
  913.   (let ((environment-list (dstate/environment-list dstate)))
  914.     (if (pair? environment-list)
  915.     (receiver (car environment-list))
  916.     (undefined-environment port))))
  917.  
  918. (define (undefined-environment port)
  919.   (debugger-failure port "There is no current environment."))
  920.  
  921. (define (reason+message reason message)
  922.   (string-capitalize (if reason (string-append reason "; " message) message)))
  923.  
  924. (define (debugger-pp expression indentation port)
  925.   (fluid-let ((*unparser-list-depth-limit* debugger:list-depth-limit)
  926.           (*unparser-list-breadth-limit* debugger:list-breadth-limit)
  927.           (*unparser-string-length-limit* debugger:string-length-limit))
  928.     (pretty-print expression port true indentation)))
  929.  
  930. (define expression-indentation 4)
  931.  
  932. (define (prompt-for-nonnegative-integer prompt limit port)
  933.   (prompt-for-integer prompt 0 limit port))
  934.  
  935. (define (prompt-for-integer prompt lower upper port)
  936.   (let loop ()
  937.     (let ((expression
  938.        (prompt-for-expression
  939.         (string-append
  940.          prompt
  941.          (if lower
  942.          (if upper
  943.              (string-append " (" (number->string lower)
  944.                     " through "
  945.                     (number->string (- upper 1))
  946.                     " inclusive)")
  947.              (string-append " (minimum " (number->string lower) ")"))
  948.          (if upper
  949.              (string-append " (maximum "
  950.                     (number->string (- upper 1))
  951.                     ")")
  952.              "")))
  953.         port)))
  954.       (cond ((not (exact-integer? expression))
  955.          (debugger-failure port prompt " must be exact integer.")
  956.          (loop))
  957.         ((and lower (< expression lower))
  958.          (debugger-failure port prompt " too small.")
  959.          (loop))
  960.         ((and upper (>= expression upper))
  961.          (debugger-failure port prompt " too large.")
  962.          (loop))
  963.         (else
  964.          expression)))))