3
$Id: debug.scm,v 14.43 2002/02/03 03:38:55 cph Exp $
5
Copyright (c) 1988-1999, 2001, 2002 Massachusetts Institute of Technology
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.
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.
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., 59 Temple Place - Suite 330, Boston, MA
24
;;; package: (runtime debugger)
26
(declare (usual-integrations))
28
(define debugger:student-walk? false)
29
(define debugger:print-return-values? false)
30
(define debugger:auto-toggle? true)
31
(define debugger:count-subproblems-limit 50)
32
(define debugger:use-history? false)
33
(define debugger:list-depth-limit 5)
34
(define debugger:list-breadth-limit 5)
35
(define debugger:string-length-limit 70)
37
(define (debug #!optional object)
38
(if (default-object? object)
39
(let ((condition (nearest-repl/condition)))
41
(debug-internal condition)
42
(call-with-current-continuation debug-internal)))
43
(debug-internal object)))
45
(define (debug-internal object)
46
(let ((dstate (make-initial-dstate object)))
47
(with-simple-restart 'CONTINUE "Return from DEBUG."
53
(debugger-presentation port
55
(let ((thread (dstate/other-thread dstate)))
58
(write-string "This error occurred in another thread: "
62
(let ((n (count-subproblems dstate)))
63
(write-string "There " port)
64
(write-string (if (= n 1) "is" "are") port)
65
(write-string " " port)
66
(if (> n debugger:count-subproblems-limit)
68
(write-string "more than " port)
69
(write debugger:count-subproblems-limit port))
71
(write-string " subproblem" port)
73
(write-string "s" port)))
74
(write-string " on the stack." port)
77
(print-subproblem dstate port)))
80
"You are now in the debugger. Type q to quit, ? for commands.")))
84
(define (make-initial-dstate object)
86
(lambda (stack-frame condition)
87
(let ((dstate (allocate-dstate)))
88
(set-dstate/history-state!
90
(cond (debugger:use-history? 'ALWAYS)
91
(debugger:auto-toggle? 'ENABLED)
93
(set-dstate/condition! dstate condition)
94
(set-current-subproblem!
96
(let loop ((stack-frame stack-frame))
98
(stack-frame/skip-non-subproblems stack-frame)))
100
(error "No frames on stack!"))
101
(if (stack-frame/repl-eval-boundary? stack-frame)
102
(loop (stack-frame/next stack-frame))
106
(cond ((condition? object)
108
(continuation->stack-frame (condition/continuation object))
110
((continuation? object)
111
(make-dstate (continuation->stack-frame object) false))
112
((stack-frame? object)
113
(make-dstate object false))
115
(error:wrong-type-argument object
116
"condition or continuation"
119
(define (count-subproblems dstate)
121
(subproblem (dstate/subproblem dstate)
122
(next-subproblem subproblem)))
123
((or (not subproblem) (> i debugger:count-subproblems-limit)) i)))
125
(define-structure (dstate
127
(constructor allocate-dstate ()))
139
(define (dstate/reduction dstate)
140
(nth-reduction (dstate/reductions dstate)
141
(dstate/reduction-number dstate)))
143
(define (dstate/reductions dstate)
144
(stack-frame/reductions (dstate/subproblem dstate)))
146
(define (initialize-package!)
151
`((#\? ,standard-help-command
152
"help, list command letters")
153
(#\A ,command/show-all-frames
154
"show All bindings in current environment and its ancestors")
155
(#\B ,command/earlier-reduction
156
"move (Back) to next reduction (earlier in time)")
157
(#\C ,command/show-current-frame
158
"show bindings of identifiers in the Current environment")
159
(#\D ,command/later-subproblem
160
"move (Down) to the previous subproblem (later in time)")
161
(#\E ,command/enter-read-eval-print-loop
162
"Enter a read-eval-print loop in the current environment")
163
(#\F ,command/later-reduction
164
"move (Forward) to previous reduction (later in time)")
166
"Go to a particular subproblem")
167
(#\H ,command/summarize-subproblems
168
"prints a summary (History) of all subproblems")
169
(#\I ,command/condition-report
170
"redisplay the error message Info")
171
(#\J ,command/return-to
172
"return TO the current subproblem with a value")
173
(#\K ,command/condition-restart
174
"continue the program using a standard restart option")
175
(#\L ,command/print-expression
176
"(List expression) pretty print the current expression")
177
(#\M ,command/print-frame-elements
178
"(Frame elements) show the contents of the stack frame, in raw form")
179
(#\O ,command/print-environment-procedure
180
"pretty print the procedure that created the current environment")
181
(#\P ,command/move-to-parent-environment
182
"move to environment that is Parent of current environment")
183
(#\Q ,standard-exit-command
184
"Quit (exit debugger)")
185
(#\R ,command/print-reductions
186
"print the execution history (Reductions) of the current subproblem level")
187
(#\S ,command/move-to-child-environment
188
"move to child of current environment (in current chain)")
189
(#\T ,command/print-subproblem-or-reduction
190
"print the current subproblem or reduction")
191
(#\U ,command/earlier-subproblem
192
"move (Up) to the next subproblem (earlier in time)")
193
(#\V ,command/eval-in-current-environment
194
"eValuate expression in current environment")
195
(#\W ,command/enter-where
196
"enter environment inspector (Where) on the current environment")
197
(#\X ,command/internal
198
"create a read eval print loop in the debugger environment")
200
"display the current stack frame")
201
(#\Z ,command/return-from
202
"return FROM the current subproblem with a value")
204
(set! hook/debugger-before-return default/debugger-before-return)
209
(define-syntax define-command
210
(sc-macro-transformer
211
(lambda (form environment)
212
(if (syntax-match? '((IDENTIFIER IDENTIFIER IDENTIFIER) + EXPRESSION)
214
(let ((dstate (cadr (cadr form)))
215
(port (caddr (cadr form))))
216
`(DEFINE (,(car (cadr form)) #!OPTIONAL ,dstate ,port)
217
(LET ((,dstate (IF (DEFAULT-OBJECT? ,dstate) *DSTATE* ,dstate))
218
(,port (IF (DEFAULT-OBJECT? ,port) *PORT* ,port)))
219
,@(map (let ((free (list dstate port)))
221
(make-syntactic-closure environment free
224
(ill-formed-syntax form)))))
226
;;;; Display commands
228
(define-command (command/print-subproblem-or-reduction dstate port)
229
(if (dstate/reduction-number dstate)
230
(command/print-reduction dstate port)
231
(command/print-subproblem dstate port)))
233
(define-command (command/print-subproblem dstate port)
234
(debugger-presentation port
236
(print-subproblem dstate port))))
238
(define-command (command/print-reduction dstate port)
239
(debugger-presentation port
241
(print-reduction (dstate/reduction dstate)
242
(dstate/subproblem-number dstate)
243
(dstate/reduction-number dstate)
246
(define-command (command/print-reductions dstate port)
247
(let ((reductions (dstate/reductions dstate))
248
(subproblem-level (dstate/subproblem-number dstate)))
249
(if (pair? reductions)
250
(debugger-presentation port
252
(write-string "Execution history for this subproblem:" port)
253
(let loop ((reductions reductions) (number 0))
255
(write-string "----------------------------------------" port)
257
(print-reduction (car reductions) subproblem-level number port)
258
(if (pair? (cdr reductions))
259
(loop (cdr reductions) (1+ number))))))
262
"There is no execution history for this subproblem."))))
264
(define-command (command/print-expression dstate port)
265
(debugger-presentation port
267
(let ((expression (dstate/expression dstate)))
268
(cond ((debugging-info/compiled-code? expression)
269
(write-string ";compiled code" port))
270
((not (debugging-info/undefined-expression? expression))
271
(pretty-print expression port true 0))
272
((debugging-info/noise? expression)
273
(write-string ";" port)
274
(write-string ((debugging-info/noise expression) false) port))
276
(write-string ";undefined expression" port)))))))
278
(define-command (command/print-environment-procedure dstate port)
279
(with-current-environment dstate port
280
(lambda (environment)
281
(show-environment-procedure environment port))))
283
(define (print-subproblem dstate port)
284
(print-subproblem-identification dstate port)
286
(print-subproblem-expression dstate port)
287
(print-subproblem-environment dstate port)
288
(print-subproblem-reduction dstate port))
290
(define (print-subproblem-identification dstate port)
291
(let ((subproblem (dstate/subproblem dstate)))
292
(write-string "Subproblem level: " port)
293
(let ((level (dstate/subproblem-number dstate))
296
(write-string " (this is the " port)
297
(write-string adjective port)
298
(write-string " subproblem level)" port))))
300
(cond ((not (next-subproblem subproblem))
301
(qualify-level (if (zero? level) "only" "highest")))
303
(qualify-level "lowest"))))))
305
(define (print-subproblem-expression dstate port)
306
(let ((expression (dstate/expression dstate))
307
(subproblem (dstate/subproblem dstate)))
308
(cond ((not (invalid-expression? expression))
309
(write-string (if (stack-frame/compiled-code? subproblem)
310
"Compiled code expression (from stack):"
311
"Expression (from stack):")
314
(let ((subexpression (dstate/subexpression dstate)))
315
(if (or (debugging-info/undefined-expression? subexpression)
316
(debugging-info/unknown-expression? subexpression))
317
(debugger-pp expression expression-indentation port)
320
(unsyntax-with-substitutions
322
(list (cons subexpression subexpression-marker)))
323
expression-indentation
326
(write-string " subproblem being executed (marked by " port)
327
(write subexpression-marker port)
328
(write-string "):" port)
330
(debugger-pp subexpression expression-indentation port)))))
331
((debugging-info/noise? expression)
332
(write-string ((debugging-info/noise expression) true) port))
334
(write-string (if (stack-frame/compiled-code? subproblem)
335
"Compiled code expression unknown"
336
"Expression unknown")
339
(write (stack-frame/return-address subproblem) port)))))
341
(define subexpression-marker
342
((ucode-primitive string->symbol) "###"))
344
(define (print-subproblem-environment dstate port)
345
(let ((environment-list (dstate/environment-list dstate)))
346
(if (pair? environment-list)
347
(print-environment (car environment-list) port)
350
(write-string "There is no current environment." port)))))
352
(define (print-subproblem-reduction dstate port)
353
(let ((n-reductions (dstate/number-of-reductions dstate)))
355
(if (positive? n-reductions)
357
(write-string "The execution history for this subproblem contains "
359
(write n-reductions port)
360
(write-string " reduction" port)
361
(if (> n-reductions 1)
362
(write-string "s" port))
363
(write-string "." port))
364
(write-string "There is no execution history for this subproblem."
367
(define (print-reduction reduction subproblem-number reduction-number port)
368
(print-reduction-identification subproblem-number reduction-number port)
370
(print-reduction-expression reduction port)
371
(print-reduction-environment reduction port))
373
(define (print-reduction-identification subproblem-number reduction-number
375
(write-string "Subproblem level: " port)
376
(write subproblem-number port)
377
(write-string " Reduction number: " port)
378
(write reduction-number port))
380
(define (print-reduction-expression reduction port)
381
(write-string "Expression (from execution history):" port)
383
(debugger-pp (reduction-expression reduction) expression-indentation port))
385
(define (print-reduction-environment reduction port)
386
(print-environment (reduction-environment reduction) port))
388
(define (print-environment environment port)
390
(show-environment-name environment port)
391
(if (not (environment->package environment))
394
(let ((arguments (environment-arguments environment)))
395
(if (eq? arguments 'UNKNOWN)
396
(show-environment-bindings environment true port)
398
(write-string " applied to: " port)
403
(- (output-port/x-size port) 11)))
406
;;;; Subproblem summary
408
(define-command (command/summarize-subproblems dstate port)
409
(let ((top-subproblem
410
(let ((previous-subproblems (dstate/previous-subproblems dstate)))
411
(if (null? previous-subproblems)
412
(dstate/subproblem dstate)
413
(car (last-pair previous-subproblems))))))
414
(debugger-presentation port
416
(write-string "SL# Procedure-name Expression" port)
418
(let loop ((frame top-subproblem) (level 0))
421
(with-values (lambda () (stack-frame/debugging-info frame))
422
(lambda (expression environment subexpression)
424
(terse-print-expression level
428
(loop (next-subproblem frame) (1+ level)))))))))
430
(define (terse-print-expression level expression environment port)
432
(write-string (string-pad-right (number->string level) 4) port)
433
(write-string " " port)
437
(and (environment? environment)
438
(environment-procedure-name environment))))
440
(special-form-procedure-name? name))
444
(write-dbg-name name (current-output-port))))))
447
(write-string " " port)
449
(cond ((debugging-info/compiled-code? expression)
451
((not (debugging-info/undefined-expression? expression))
455
(fluid-let ((*unparse-primitives-by-name?* true))
456
(write (unsyntax expression))))))
457
((debugging-info/noise? expression)
461
(write-string ((debugging-info/noise expression) false)))))
463
";undefined expression"))
466
;;;; Subproblem motion
468
(define-command (command/earlier-subproblem dstate port)
469
(maybe-stop-using-history! dstate port)
470
(earlier-subproblem dstate port false finish-move-to-subproblem!))
472
(define (earlier-subproblem dstate port reason if-successful)
473
(let ((subproblem (dstate/subproblem dstate)))
474
(let ((next (next-subproblem subproblem)))
477
(set-current-subproblem!
480
(cons subproblem (dstate/previous-subproblems dstate)))
481
(if-successful dstate port))
484
(reason+message (or reason "no more subproblems")
485
"already at highest subproblem level."))))))
487
(define (next-subproblem stack-frame)
488
(let ((next (stack-frame/next-subproblem stack-frame)))
489
(if (and next (stack-frame/repl-eval-boundary? next))
490
(next-subproblem next)
493
(define-command (command/later-subproblem dstate port)
494
(maybe-stop-using-history! dstate port)
495
(later-subproblem dstate port false finish-move-to-subproblem!))
497
(define (later-subproblem dstate port reason if-successful)
498
(if (null? (dstate/previous-subproblems dstate))
501
(reason+message reason "already at lowest subproblem level."))
503
(let ((p (dstate/previous-subproblems dstate)))
504
(set-current-subproblem! dstate (car p) (cdr p)))
505
(if-successful dstate port))))
507
(define-command (command/goto dstate port)
508
(maybe-stop-using-history! dstate port)
509
(let ((subproblems (select-subproblem dstate port)))
510
(set-current-subproblem! dstate (car subproblems) (cdr subproblems)))
511
(finish-move-to-subproblem! dstate port))
513
(define (select-subproblem dstate port)
514
(let top-level-loop ()
516
(- (prompt-for-nonnegative-integer "Subproblem number" false port)
517
(dstate/subproblem-number dstate))))
518
(if (negative? delta)
519
(list-tail (dstate/previous-subproblems dstate) (-1+ (- delta)))
521
((subproblem (dstate/subproblem dstate))
522
(subproblems (dstate/previous-subproblems dstate))
525
(cons subproblem subproblems)
526
(let ((next (next-subproblem subproblem)))
528
(loop next (cons subproblem subproblems) (-1+ delta))
532
"Subproblem number too large (limit is "
535
(top-level-loop))))))))))
537
;;;; Reduction motion
539
(define-command (command/earlier-reduction dstate port)
540
(maybe-start-using-history! dstate port)
543
(earlier-subproblem dstate port false finish-move-to-subproblem!))))
544
(if (not (dstate/using-history? dstate))
546
(let ((n-reductions (dstate/number-of-reductions dstate))
547
(reduction-number (dstate/reduction-number dstate))
554
(lambda (dstate port)
559
"going to the next (less recent) subproblem."))
560
(finish-move-to-subproblem! dstate port))))))
561
(cond ((zero? n-reductions)
563
((not reduction-number)
564
(move-to-reduction! dstate port 0))
565
((and (< reduction-number (-1+ n-reductions))
566
(not (and debugger:student-walk?
567
(positive? (dstate/subproblem-number dstate))
568
(= reduction-number 0))))
569
(move-to-reduction! dstate port (1+ reduction-number)))
570
(debugger:student-walk?
573
(wrap "no more reductions")))))))
575
(define-command (command/later-reduction dstate port)
576
(maybe-start-using-history! dstate port)
579
(later-subproblem dstate port false finish-move-to-subproblem!))))
580
(if (not (dstate/using-history? dstate))
581
(later-subproblem dstate port false finish-move-to-subproblem!)
582
(let ((reduction-number (dstate/reduction-number dstate))
589
(lambda (dstate port)
594
"going to the previous (more recent) subproblem."))
595
(let ((n (dstate/number-of-reductions dstate)))
596
(if (and n (positive? n))
600
(if (and debugger:student-walk?
602
(dstate/subproblem-number dstate)))
605
(finish-move-to-subproblem! dstate port))))))))
606
(cond ((zero? (dstate/number-of-reductions dstate))
608
((not reduction-number)
610
((positive? reduction-number)
611
(move-to-reduction! dstate port (-1+ reduction-number)))
612
((special-history-subproblem? dstate)
614
(set-current-subproblem! dstate
615
(dstate/subproblem dstate)
616
(dstate/previous-subproblems dstate))
617
(set-dstate/reduction-number! dstate false)
618
(command/print-subproblem dstate port))
619
(debugger:student-walk?
622
(wrap "no more reductions")))))))
624
;;;; Environment motion and display
626
(define-command (command/show-current-frame dstate port)
627
(if (pair? (dstate/environment-list dstate))
628
(show-current-frame dstate false port)
629
(undefined-environment port)))
631
(define-command (command/show-all-frames dstate port)
632
(let ((environment-list (dstate/environment-list dstate)))
633
(if (pair? environment-list)
634
(show-frames (car (last-pair environment-list)) 0 port)
635
(undefined-environment port))))
637
(define-command (command/move-to-parent-environment dstate port)
638
(let ((environment-list (dstate/environment-list dstate)))
639
(cond ((not (pair? environment-list))
640
(undefined-environment port))
641
((eq? true (environment-has-parent? (car environment-list)))
642
(set-dstate/environment-list!
644
(cons (environment-parent (car environment-list))
646
(show-current-frame dstate true port))
648
(debugger-failure port "The current environment has no parent.")))))
650
(define-command (command/move-to-child-environment dstate port)
651
(let ((environment-list (dstate/environment-list dstate)))
652
(cond ((not (pair? (dstate/environment-list dstate)))
653
(undefined-environment port))
654
((not (pair? (cdr environment-list)))
657
"This is the initial environment; can't move to child."))
659
(set-dstate/environment-list! dstate (cdr environment-list))
660
(show-current-frame dstate true port)))))
662
(define (show-current-frame dstate brief? port)
663
(debugger-presentation port
665
(let ((environment-list (dstate/environment-list dstate)))
666
(show-frame (car environment-list)
667
(length (cdr environment-list))
671
(define-command (command/enter-read-eval-print-loop dstate port)
672
(debug/read-eval-print (get-evaluation-environment dstate port)
674
"the environment for this frame"))
676
(define-command (command/eval-in-current-environment dstate port)
677
(debug/read-eval-print-1 (get-evaluation-environment dstate port) port))
679
(define-command (command/enter-where dstate port)
681
(with-current-environment dstate port debug/where))
683
;;;; Condition commands
685
(define-command (command/condition-report dstate port)
686
(let ((condition (dstate/condition dstate)))
688
(debugger-presentation port
690
(write-condition-report condition port)))
691
(debugger-failure port "No condition to report."))))
693
(define-command (command/condition-restart dstate port)
694
(let ((condition (dstate/condition dstate)))
697
(condition/restarts condition)
700
(debugger-failure port "No options to choose from.")
701
(let ((n-restarts (length restarts))
704
(write-string (string-pad-left (number->string index) 3)
706
(write-string ":" port))))
709
(invoke-restart-interactively
710
(list-ref restarts (- n-restarts n))
712
(debugger-presentation port
716
(write-string "There is only one option:" port)
717
(write-restarts restarts port write-index)
718
(if (prompt-for-confirmation "Use this option" port)
721
(write-string "Choose an option by number:" port)
722
(write-restarts restarts port write-index)
724
(prompt-for-integer "Option number"
729
;;;; Advanced hacking commands
731
(define-command (command/return-from dstate port)
732
(let ((next (next-subproblem (dstate/subproblem dstate))))
734
(enter-subproblem dstate port next)
735
(debugger-failure port "Can't continue!!!"))))
737
(define-command (command/return-to dstate port)
738
(enter-subproblem dstate port (dstate/subproblem dstate)))
740
(define (enter-subproblem dstate port subproblem)
741
(let ((invalid-expression?
742
(invalid-expression? (dstate/expression dstate)))
743
(environment (get-evaluation-environment dstate port)))
746
(prompt-for-expression
748
"Expression to EVALUATE and CONTINUE with"
749
(if invalid-expression?
753
(if (and (not invalid-expression?)
755
(debug/scode-eval (dstate/expression dstate)
757
(debug/eval expression environment)))))
758
(if (or (not debugger:print-return-values?)
761
(write-string "That evaluates to:" port)
764
(prompt-for-confirmation "Confirm" port)))
766
(hook/debugger-before-return)
767
(let ((thread (dstate/other-thread dstate)))
769
((stack-frame->continuation subproblem) value)
771
(restart-thread thread 'ASK
773
((stack-frame->continuation subproblem) value)))
774
(continue-from-derived-thread-error
775
(dstate/condition dstate))))))))))
777
(define (dstate/other-thread dstate)
778
(let ((condition (dstate/condition dstate)))
780
(condition/other-thread condition))))
782
(define hook/debugger-before-return)
783
(define (default/debugger-before-return)
789
(define (command/internal dstate port)
790
(fluid-let ((*dstate* dstate)
792
(debug/read-eval-print (->environment '(RUNTIME DEBUGGER))
794
"the debugger environment")))
796
(define-command (command/frame dstate port)
797
(debugger-presentation port
799
(write-string "Stack frame: " port)
800
(write (dstate/subproblem dstate) port)
801
(for-each (lambda (element)
803
(debugger-pp element 0 port))
804
(named-structure/description (dstate/subproblem dstate))))))
806
(define-command (command/print-frame-elements dstate port)
807
(debugger-presentation
810
(write-string "Stack frame elements: " port)
811
(for-each-vector-element
812
(stack-frame/elements (dstate/subproblem dstate))
817
;;;; Low-level Side-effects
819
(define (maybe-start-using-history! dstate port)
820
(if (eq? 'ENABLED (dstate/history-state dstate))
822
(set-dstate/history-state! dstate 'NOW)
823
(if (not (zero? (dstate/number-of-reductions dstate)))
826
"Now using information from the execution history.")))))
828
(define (maybe-stop-using-history! dstate port)
829
(if (eq? 'NOW (dstate/history-state dstate))
831
(set-dstate/history-state! dstate 'ENABLED)
832
(if (not (zero? (dstate/number-of-reductions dstate)))
835
"Now ignoring information from the execution history.")))))
837
(define (dstate/using-history? dstate)
838
(or (eq? 'ALWAYS (dstate/history-state dstate))
839
(eq? 'NOW (dstate/history-state dstate))))
841
(define (dstate/auto-toggle? dstate)
842
(not (eq? 'DISABLED (dstate/history-state dstate))))
844
(define (set-current-subproblem! dstate stack-frame previous-frames)
845
(set-dstate/subproblem! dstate stack-frame)
846
(set-dstate/previous-subproblems! dstate previous-frames)
847
(set-dstate/subproblem-number! dstate (length previous-frames))
848
(set-dstate/number-of-reductions!
850
(improper-list-length (stack-frame/reductions stack-frame)))
851
(with-values (lambda () (stack-frame/debugging-info stack-frame))
852
(lambda (expression environment subexpression)
853
(set-dstate/expression! dstate expression)
854
(set-dstate/subexpression! dstate subexpression)
855
(set-dstate/environment-list!
857
(if (debugging-info/undefined-environment? environment)
859
(list environment))))))
861
(define (finish-move-to-subproblem! dstate port)
862
(if (and (dstate/using-history? dstate)
863
(positive? (dstate/number-of-reductions dstate))
864
(not (special-history-subproblem? dstate)))
865
(move-to-reduction! dstate port 0)
867
(set-dstate/reduction-number! dstate false)
868
(command/print-subproblem dstate port))))
870
(define (move-to-reduction! dstate port reduction-number)
871
(set-dstate/reduction-number! dstate reduction-number)
872
(set-dstate/environment-list!
874
(list (reduction-environment (dstate/reduction dstate))))
875
(command/print-reduction dstate port))
877
(define (special-history-subproblem? dstate)
878
(eq? (stack-frame/type (dstate/subproblem dstate))
879
stack-frame-type/compiled-return-address))
883
(define (improper-list-length l)
884
(let count ((n 0) (l l))
886
(count (1+ n) (cdr l))
889
(define (nth-reduction reductions n)
890
(let loop ((reductions reductions) (n n))
893
(loop (cdr reductions) (-1+ n)))))
895
(define-integrable (reduction-expression reduction)
898
(define-integrable (reduction-environment reduction)
901
(define (wrap-around-in-reductions? reductions)
902
(or (eq? 'WRAP-AROUND reductions)
903
(and (pair? reductions)
904
(eq? 'WRAP-AROUND (cdr (last-pair reductions))))))
906
(define (invalid-expression? expression)
907
(or (debugging-info/undefined-expression? expression)
908
(debugging-info/compiled-code? expression)))
910
(define (get-evaluation-environment dstate port)
911
(let ((environment-list (dstate/environment-list dstate)))
912
(if (and (pair? environment-list)
913
(environment? (car environment-list)))
914
(car environment-list)
918
"Cannot evaluate in current environment;
919
using the read-eval-print environment instead.")
920
(nearest-repl/environment)))))
922
(define (with-current-environment dstate port receiver)
923
(let ((environment-list (dstate/environment-list dstate)))
924
(if (pair? environment-list)
925
(receiver (car environment-list))
926
(undefined-environment port))))
928
(define (undefined-environment port)
929
(debugger-failure port "There is no current environment."))
931
(define (reason+message reason message)
932
(string-capitalize (if reason (string-append reason "; " message) message)))
934
(define (debugger-pp expression indentation port)
935
(fluid-let ((*unparser-list-depth-limit* debugger:list-depth-limit)
936
(*unparser-list-breadth-limit* debugger:list-breadth-limit)
937
(*unparser-string-length-limit* debugger:string-length-limit))
938
(pretty-print expression port true indentation)))
940
(define expression-indentation 4)
942
(define (prompt-for-nonnegative-integer prompt limit port)
943
(prompt-for-integer prompt 0 limit port))
945
(define (prompt-for-integer prompt lower upper port)
948
(prompt-for-expression
953
(string-append " (" (number->string lower)
955
(number->string (- upper 1))
957
(string-append " (minimum " (number->string lower) ")"))
959
(string-append " (maximum "
960
(number->string (- upper 1))
964
(cond ((not (exact-integer? expression))
965
(debugger-failure port prompt " must be exact integer.")
967
((and lower (< expression lower))
968
(debugger-failure port prompt " too small.")
970
((and upper (>= expression upper))
971
(debugger-failure port prompt " too large.")
b'\\ No newline at end of file'
added
removed
src/runtime/debug.scm
