1;; Scheme side of the gdb module.
2;;
3;; Copyright (C) 2014-2023 Free Software Foundation, Inc.
4;;
5;; This file is part of GDB.
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 3 of the License, or
10;; (at your option) any later version.
11;;
12;; This program is distributed in the hope that it will be useful,
13;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15;; GNU 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, see <http://www.gnu.org/licenses/>.
19
20;; This file is included by (gdb).
21
22;; The original i/o ports.  In case the user wants them back.
23(define %orig-input-port #f)
24(define %orig-output-port #f)
25(define %orig-error-port #f)
26
27;; Keys for GDB-generated exceptions.
28;; gdb:with-stack is handled separately.
29
30(define %exception-keys '(gdb:error
31			  gdb:invalid-object-error
32			  gdb:memory-error
33			  gdb:pp-type-error
34			  gdb:user-error))
35
36;; Printer for gdb exceptions, used when Scheme tries to print them directly.
37
38(define (%exception-printer port key args default-printer)
39  (apply (case-lambda
40	  ((subr msg args . rest)
41	   (if subr
42	       (format port "In procedure ~a: " subr))
43	   (apply format port msg (or args '())))
44	  (_ (default-printer)))
45	 args))
46
47;; Print the message part of a gdb:with-stack exception.
48;; The arg list is the way it is because it's passed to set-exception-printer!.
49;; We don't print a backtrace here because Guile will have already printed a
50;; backtrace.
51
52(define (%with-stack-exception-printer port key args default-printer)
53  (let ((real-key (car args))
54	(real-args (cddr args)))
55    (%exception-printer port real-key real-args default-printer)))
56
57;; Copy of Guile's print-exception that tweaks the output for our purposes.
58;; TODO: It's not clear the tweaking is still necessary.
59
60(define (%print-exception-message-worker port key args)
61  (define (default-printer)
62    (format port "Throw to key `~a' with args `~s'." key args))
63  (format port "ERROR: ")
64  ;; Pass #t for tag to catch all errors.
65  (catch #t
66	 (lambda ()
67	   (%exception-printer port key args default-printer))
68	 (lambda (k . args)
69	   (format port "Error while printing gdb exception: ~a ~s."
70		   k args)))
71  (newline port)
72  (force-output port))
73
74;; Called from the C code to print an exception.
75;; Guile prints them a little differently than we want.
76;; See boot-9.scm:print-exception.
77
78(define (%print-exception-message port frame key args)
79  (cond ((memq key %exception-keys)
80	 (%print-exception-message-worker port key args))
81	(else
82	 (print-exception port frame key args)))
83  *unspecified*)
84
85;; Called from the C code to print an exception according to the setting
86;; of "guile print-stack".
87;;
88;; If PORT is #f, use the standard error port.
89;; If STACK is #f, never print the stack, regardless of whether printing it
90;; is enabled.  If STACK is #t, then print it if it is contained in ARGS
91;; (i.e., KEY is gdb:with-stack).  Otherwise STACK is the result of calling
92;; scm_make_stack (which will be ignored in favor of the stack in ARGS if
93;; KEY is gdb:with-stack).
94;; KEY, ARGS are the standard arguments to scm_throw, et.al.
95
96(define (%print-exception-with-stack port stack key args)
97  (let ((style (%exception-print-style)))
98    (if (not (eq? style 'none))
99	(let ((error-port (current-error-port))
100	      (frame #f))
101	  (if (not port)
102	      (set! port error-port))
103	  (if (eq? port error-port)
104	      (begin
105		(force-output (current-output-port))
106		;; In case the current output port is not gdb's output port.
107		(force-output (output-port))))
108
109	  ;; If the exception is gdb:with-stack, unwrap it to get the stack and
110	  ;; underlying exception.  If the caller happens to pass in a stack,
111	  ;; we ignore it and use the one in ARGS instead.
112	  (if (eq? key 'gdb:with-stack)
113	      (begin
114		(set! key (car args))
115		(if stack
116		    (set! stack (cadr args)))
117		(set! args (cddr args))))
118
119	  ;; If caller wanted a stack and there isn't one, disable backtracing.
120	  (if (eq? stack #t)
121	      (set! stack #f))
122	  ;; At this point if stack is true, then it is assumed to be a stack.
123	  (if stack
124	      (set! frame (stack-ref stack 0)))
125
126	  (if (and (eq? style 'full) stack)
127	      (begin
128		;; This is derived from libguile/throw.c:handler_message.
129		;; We include "Guile" in "Guile Backtrace" whereas the Guile
130		;; version does not so that tests can know it's us printing
131		;; the backtrace.  Plus it could help beginners.
132		(display "Guile Backtrace:\n" port)
133		(display-backtrace stack port #f #f '())
134		(newline port)))
135
136	  (%print-exception-message port frame key args)))))
137
138;; Internal utility called during startup to initialize the Scheme side of
139;; GDB+Guile.
140
141(define (%initialize!)
142  (for-each (lambda (key)
143	      (set-exception-printer! key %exception-printer))
144	    %exception-keys)
145  (set-exception-printer! 'gdb:with-stack %with-stack-exception-printer)
146
147  (set! %orig-input-port (set-current-input-port (input-port)))
148  (set! %orig-output-port (set-current-output-port (output-port)))
149  (set! %orig-error-port (set-current-error-port (error-port))))
150
151;; Dummy routine to silence "possibly unused local top-level variable"
152;; warnings from the compiler.
153
154(define-public (%silence-compiler-warnings%)
155  (list %print-exception-with-stack %initialize!))
156
157;; Public routines.
158
159(define-public (orig-input-port) %orig-input-port)
160(define-public (orig-output-port) %orig-output-port)
161(define-public (orig-error-port) %orig-error-port)
162
163;; Utility to throw gdb:user-error for use in writing gdb commands.
164;; The requirements for the arguments to "throw" are a bit obscure,
165;; so give the user something simpler.
166
167(define-public (throw-user-error message . args)
168  (throw 'gdb:user-error #f message args))
169