blob: 2229c29ba059815f438f6b78b6e513be6bc5c060 (
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
100
|
;;; 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 server for live hacking and debugging from Emacs or whatever.
;;
;;; Code:
(define-module (starling repl-server)
#:use-module (oop goops)
#:use-module (ice-9 exceptions)
#:use-module (ice-9 match)
#:use-module (starling node)
#:use-module (system repl coop-server)
#:use-module (system repl debug)
#:use-module (system repl repl)
#:export (<repl-server>
repl-server
repl-debug
repl-debugging?
on-error
debugger))
(define-class <repl-server> (<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-server>))
(set! (repl-server repl) (spawn-coop-repl-server)))
(define-method (on-error (repl <repl-server>) e stack)
;; Setup the REPL debug object.
(let* ((frame (stack-ref stack 0))
(error-string
(format #f "~a: In procedure: ~a:~%In procedure: ~a: ~a~%"
(match (frame-source frame)
((_ file-name line . column)
(format #f "~a:~a:~a"
(if file-name
(basename file-name)
"unknown file")
line column))
(_ "unknown"))
(or (frame-procedure-name frame)
"unknown")
(or (and (exception-with-origin? e)
(exception-origin e))
"unknown")
(if (and (exception-with-message? e)
(exception-with-irritants? e))
(apply format #f (exception-message e)
(exception-irritants e))
""))))
;; 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)
(display error-string port)
(newline port))
(set! (repl-debug repl)
(make-debug (narrow-stack->vector stack 0) 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-server>) dt)
(poll-coop-repl-server (repl-server repl)))
(define-method (debugger (repl <repl-server>))
(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")))
|
