blob: 8951793da5de558aaf2e446aefc13338d40a83e6 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
|
;;; Lisparuga
;;; Copyright © 2020 David Thompson <dthompson2@worcester.edu>
;;;
;;; Lisparuga is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published
;;; by the Free Software Foundation, either version 3 of the License,
;;; or (at your option) any later version.
;;;
;;; Lisparuga is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Lisparuga. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;
;; REPL for live hacking and debugging.
;;
;;; Code:
(define-module (lisparuga repl)
#:use-module (oop goops)
#:use-module (ice-9 match)
#:use-module (lisparuga node)
#:use-module (system repl coop-server)
#:use-module (system repl debug)
#:use-module (system repl repl)
#:export (<repl>
repl-server
repl-debug
repl-debugging?
on-error
debugger))
(define-class <repl> (<node>)
(repl-server #:accessor repl-server)
(repl-debug #:accessor repl-debug #:init-form #f)
(repl-debugging? #:accessor repl-debugging? #:init-form #f))
(define-method (on-boot (repl <repl>))
(set! (repl-server repl) (spawn-coop-repl-server)))
(define-method (on-error (repl <repl>) stack key args)
;; Display backtrace.
(let ((port (current-error-port)))
(display "an error has occurred!\n\n" port)
(display "Backtrace:\n" port)
(display-backtrace stack port)
(newline port)
(match args
((subr message . args)
(display-error (stack-ref stack 0) port subr message args '())))
(newline port))
;; Setup the REPL debug object.
(let* ((tag (and (pair? (fluid-ref %stacks))
(cdr (fluid-ref %stacks))))
(stack (narrow-stack->vector
stack
;; Take the stack from the given frame, cutting 0
;; frames.
0
;; Narrow the end of the stack to the most recent
;; start-stack.
;;tag
;; And one more frame, because %start-stack
;; invoking the start-stack thunk has its own frame
;; too.
;;0 (and tag 1)
))
(error-string (call-with-output-string
(lambda (port)
(let ((frame (and (< 0 (vector-length stack))
(vector-ref stack 0))))
(print-exception port frame key args))))))
(set! (repl-debug repl) (make-debug stack 0 error-string))
(set! (repl-debugging? repl) #t)
;; Wait for the user to exit the debugger.
(display "waiting for developer to debug..." (current-error-port))
(while (repl-debugging? repl)
(poll-coop-repl-server (repl-server repl))
(usleep 160000)
#t)
(set! (repl-debug repl) #f)
(display " done!\n")))
(define-method (update (repl <repl>) dt)
(poll-coop-repl-server (repl-server repl)))
(define-method (debugger (repl <repl>))
(if (repl-debug repl)
(begin
(format #t "~a~%" (debug-error-message (repl-debug repl)))
(format #t "Entering a new prompt. ")
(format #t "Type `,bt' for a backtrace or `,q' to resume the game loop.\n")
(start-repl #:debug (repl-debug repl))
(set! (repl-debugging? repl) #f))
(display "nothing to debug!\n")))
|
