blob: 994ddbca42505a3129f7961dcb720532dcb490a9 (
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
|
;;; Starling Game Engine
;;; Copyright © 2018 David Thompson <davet@gnu.org>
;;;
;;; This program 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.
;;;
;;; This program 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 Starling. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;
;; REPL for live hacking and debugging.
;;
;;; Code:
(define-module (starling repl)
#:use-module (oop goops)
#:use-module (starling 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)
(apply display-error (stack-ref stack 0) port 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))
#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")))
|