aboutsummaryrefslogtreecommitdiff
path: root/gdb/guile/scm-safe-call.c
blob: 15bab27008d15d06fdbcf0d8008a5af36a6b62fa (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
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
/* GDB/Scheme support for safe calls into the Guile interpreter.

   Copyright (C) 2014-2017 Free Software Foundation, Inc.

   This file is part of GDB.

   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 this program.  If not, see <http://www.gnu.org/licenses/>.  */

/* See README file in this directory for implementation notes, coding
   conventions, et.al.  */

#include "defs.h"
#include "filenames.h"
#include "guile-internal.h"

/* Struct to marshall args to scscm_safe_call_body.  */

struct c_data
{
  const char *(*func) (void *);
  void *data;
  /* An error message or NULL for success.  */
  const char *result;
};

/* Struct to marshall args through gdbscm_with_catch.  */

struct with_catch_data
{
  scm_t_catch_body func;
  void *data;
  scm_t_catch_handler unwind_handler;
  scm_t_catch_handler pre_unwind_handler;

  /* If EXCP_MATCHER is non-NULL, it is an excp_matcher_func function.
     If the exception is recognized by it, the exception is recorded as is,
     without wrapping it in gdb:with-stack.  */
  excp_matcher_func *excp_matcher;

  SCM stack;
  SCM catch_result;
};

/* The "body" argument to scm_i_with_continuation_barrier.
   Invoke the user-supplied function.  */

static SCM
scscm_safe_call_body (void *d)
{
  struct c_data *data = (struct c_data *) d;

  data->result = data->func (data->data);

  return SCM_UNSPECIFIED;
}

/* A "pre-unwind handler" to scm_c_catch that prints the exception
   according to "set guile print-stack".  */

static SCM
scscm_printing_pre_unwind_handler (void *data, SCM key, SCM args)
{
  SCM stack = scm_make_stack (SCM_BOOL_T, scm_list_1 (scm_from_int (2)));

  gdbscm_print_exception_with_stack (SCM_BOOL_F, stack, key, args);

  return SCM_UNSPECIFIED;
}

/* A no-op unwind handler.  */

static SCM
scscm_nop_unwind_handler (void *data, SCM key, SCM args)
{
  return SCM_UNSPECIFIED;
}

/* The "pre-unwind handler" to scm_c_catch that records the exception
   for possible later printing.  We do this in the pre-unwind handler because
   we want the stack to include point where the exception occurred.

   If DATA is non-NULL, it is an excp_matcher_func function.
   If the exception is recognized by it, the exception is recorded as is,
   without wrapping it in gdb:with-stack.  */

static SCM
scscm_recording_pre_unwind_handler (void *datap, SCM key, SCM args)
{
  struct with_catch_data *data = (struct with_catch_data *) datap;
  excp_matcher_func *matcher = data->excp_matcher;

  if (matcher != NULL && matcher (key))
    return SCM_UNSPECIFIED;

  /* There's no need to record the whole stack if we're not going to print it.
     However, convention is to still print the stack frame in which the
     exception occurred, even if we're not going to print a full backtrace.
     For now, keep it simple.  */

  data->stack = scm_make_stack (SCM_BOOL_T, scm_list_1 (scm_from_int (2)));

  /* IWBN if we could return the <gdb:exception> here and skip the unwind
     handler, but it doesn't work that way.  If we want to return a
     <gdb:exception> object from the catch it needs to come from the unwind
     handler.  So what we do is save the stack for later use by the unwind
     handler.  */

  return SCM_UNSPECIFIED;
}

/* Part two of the recording unwind handler.
   Here we take the stack saved from the pre-unwind handler and create
   the <gdb:exception> object.  */

static SCM
scscm_recording_unwind_handler (void *datap, SCM key, SCM args)
{
  struct with_catch_data *data = (struct with_catch_data *) datap;

  /* We need to record the stack in the exception since we're about to
     throw and lose the location that got the exception.  We do this by
     wrapping the exception + stack in a new exception.  */

  if (gdbscm_is_true (data->stack))
    return gdbscm_make_exception_with_stack (key, args, data->stack);

  return gdbscm_make_exception (key, args);
}

/* Ugh. :-(
   Guile doesn't export scm_i_with_continuation_barrier which is exactly
   what we need.  To cope, have our own wrapper around scm_c_catch and
   pass this as the "body" argument to scm_c_with_continuation_barrier.
   Darn darn darn.  */

static void *
gdbscm_with_catch (void *data)
{
  struct with_catch_data *d = (struct with_catch_data *) data;

  d->catch_result
    = scm_c_catch (SCM_BOOL_T,
		   d->func, d->data,
		   d->unwind_handler, d,
		   d->pre_unwind_handler, d);

#if HAVE_GUILE_MANUAL_FINALIZATION
  scm_run_finalizers ();
#endif

  return NULL;
}

/* A wrapper around scm_with_guile that prints backtraces and exceptions
   according to "set guile print-stack".
   The result if NULL if no exception occurred, otherwise it is a statically
   allocated error message (caller must *not* free).  */

const char *
gdbscm_with_guile (const char *(*func) (void *), void *data)
{
  struct c_data c_data;
  struct with_catch_data catch_data;

  c_data.func = func;
  c_data.data = data;
  /* Set this now in case an exception is thrown.  */
  c_data.result = _("Error while executing Scheme code.");

  catch_data.func = scscm_safe_call_body;
  catch_data.data = &c_data;
  catch_data.unwind_handler = scscm_nop_unwind_handler;
  catch_data.pre_unwind_handler = scscm_printing_pre_unwind_handler;
  catch_data.excp_matcher = NULL;
  catch_data.stack = SCM_BOOL_F;
  catch_data.catch_result = SCM_UNSPECIFIED;

  scm_with_guile (gdbscm_with_catch, &catch_data);

  return c_data.result;
}

/* Another wrapper of scm_with_guile for use by the safe call/apply routines
   in this file, as well as for general purpose calling other functions safely.
   For these we want to record the exception, but leave the possible printing
   of it to later.  */

SCM
gdbscm_call_guile (SCM (*func) (void *), void *data,
		   excp_matcher_func *ok_excps)
{
  struct with_catch_data catch_data;

  catch_data.func = func;
  catch_data.data = data;
  catch_data.unwind_handler = scscm_recording_unwind_handler;
  catch_data.pre_unwind_handler = scscm_recording_pre_unwind_handler;
  catch_data.excp_matcher = ok_excps;
  catch_data.stack = SCM_BOOL_F;
  catch_data.catch_result = SCM_UNSPECIFIED;

#if 0
  scm_c_with_continuation_barrier (gdbscm_with_catch, &catch_data);
#else
  scm_with_guile (gdbscm_with_catch, &catch_data);
#endif

  return catch_data.catch_result;
}

/* Utilities to safely call Scheme code, catching all exceptions, and
   preventing continuation capture.
   The result is the result of calling the function, or if an exception occurs
   then the result is a <gdb:exception> smob, which can be tested for with
   gdbscm_is_exception.  */

/* Helper for gdbscm_safe_call_0.  */

static SCM
scscm_call_0_body (void *argsp)
{
  SCM *args = (SCM *) argsp;

  return scm_call_0 (args[0]);
}

SCM
gdbscm_safe_call_0 (SCM proc, excp_matcher_func *ok_excps)
{
  SCM args[] = { proc };

  return gdbscm_call_guile (scscm_call_0_body, args, ok_excps);
}

/* Helper for gdbscm_safe_call_1.  */

static SCM
scscm_call_1_body (void *argsp)
{
  SCM *args = (SCM *) argsp;

  return scm_call_1 (args[0], args[1]);
}

SCM
gdbscm_safe_call_1 (SCM proc, SCM arg0, excp_matcher_func *ok_excps)
{
  SCM args[] = { proc, arg0 };

  return gdbscm_call_guile (scscm_call_1_body, args, ok_excps);
}

/* Helper for gdbscm_safe_call_2.  */

static SCM
scscm_call_2_body (void *argsp)
{
  SCM *args = (SCM *) argsp;

  return scm_call_2 (args[0], args[1], args[2]);
}

SCM
gdbscm_safe_call_2 (SCM proc, SCM arg0, SCM arg1, excp_matcher_func *ok_excps)
{
  SCM args[] = { proc, arg0, arg1 };

  return gdbscm_call_guile (scscm_call_2_body, args, ok_excps);
}

/* Helper for gdbscm_safe_call_3.  */

static SCM
scscm_call_3_body (void *argsp)
{
  SCM *args = (SCM *) argsp;

  return scm_call_3 (args[0], args[1], args[2], args[3]);
}

SCM
gdbscm_safe_call_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3,
		    excp_matcher_func *ok_excps)
{
  SCM args[] = { proc, arg1, arg2, arg3 };

  return gdbscm_call_guile (scscm_call_3_body, args, ok_excps);
}

/* Helper for gdbscm_safe_call_4.  */

static SCM
scscm_call_4_body (void *argsp)
{
  SCM *args = (SCM *) argsp;

  return scm_call_4 (args[0], args[1], args[2], args[3], args[4]);
}

SCM
gdbscm_safe_call_4 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4,
		    excp_matcher_func *ok_excps)
{
  SCM args[] = { proc, arg1, arg2, arg3, arg4 };

  return gdbscm_call_guile (scscm_call_4_body, args, ok_excps);
}

/* Helper for gdbscm_safe_apply_1.  */

static SCM
scscm_apply_1_body (void *argsp)
{
  SCM *args = (SCM *) argsp;

  return scm_apply_1 (args[0], args[1], args[2]);
}

SCM
gdbscm_safe_apply_1 (SCM proc, SCM arg0, SCM rest, excp_matcher_func *ok_excps)
{
  SCM args[] = { proc, arg0, rest };

  return gdbscm_call_guile (scscm_apply_1_body, args, ok_excps);
}

/* Utilities to call Scheme code, not catching exceptions, and
   not preventing continuation capture.
   The result is the result of calling the function.
   If an exception occurs then Guile is left to handle the exception,
   unwinding the stack as appropriate.

   USE THESE WITH CARE.
   Typically these are called from functions that implement Scheme procedures,
   and we don't want to catch the exception; otherwise it will get printed
   twice: once when first caught and once if it ends up being rethrown and the
   rethrow reaches the top repl, which will confuse the user.

   While these calls just pass the call off to the corresponding Guile
   procedure, all such calls are routed through these ones to:
   a) provide a place to put hooks or whatnot in if we need to,
   b) add "unsafe" to the name to alert the reader.  */

SCM
gdbscm_unsafe_call_1 (SCM proc, SCM arg0)
{
  return scm_call_1 (proc, arg0);
}

/* Utilities for safely evaluating a Scheme expression string.  */

struct eval_scheme_string_data
{
  const char *string;
  int display_result;
};

/* Wrapper to eval a C string in the Guile interpreter.
   This is passed to gdbscm_with_guile.  */

static const char *
scscm_eval_scheme_string (void *datap)
{
  struct eval_scheme_string_data *data
    = (struct eval_scheme_string_data *) datap;
  SCM result = scm_c_eval_string (data->string);

  if (data->display_result && !scm_is_eq (result, SCM_UNSPECIFIED))
    {
      SCM port = scm_current_output_port ();

      scm_write (result, port);
      scm_newline (port);
    }

  /* If we get here the eval succeeded.  */
  return NULL;
}

/* Evaluate EXPR in the Guile interpreter, catching all exceptions
   and preventing continuation capture.
   The result is NULL if no exception occurred.  Otherwise, the exception is
   printed according to "set guile print-stack" and the result is an error
   message allocated with malloc, caller must free.  */

char *
gdbscm_safe_eval_string (const char *string, int display_result)
{
  struct eval_scheme_string_data data = { string, display_result };
  const char *result;

  result = gdbscm_with_guile (scscm_eval_scheme_string, (void *) &data);

  if (result != NULL)
    return xstrdup (result);
  return NULL;
}

/* Utilities for safely loading Scheme scripts.  */

/* Helper function for gdbscm_safe_source_scheme_script.  */

static const char *
scscm_source_scheme_script (void *data)
{
  const char *filename = (const char *) data;

  /* The Guile docs don't specify what the result is.
     Maybe it's SCM_UNSPECIFIED, but the docs should specify that. :-) */
  scm_c_primitive_load_path (filename);

  /* If we get here the load succeeded.  */
  return NULL;
}

/* Try to load a script, catching all exceptions,
   and preventing continuation capture.
   The result is NULL if the load succeeded.  Otherwise, the exception is
   printed according to "set guile print-stack" and the result is an error
   message allocated with malloc, caller must free.  */

char *
gdbscm_safe_source_script (const char *filename)
{
  /* scm_c_primitive_load_path only looks in %load-path for files with
     relative paths.  An alternative could be to temporarily add "." to
     %load-path, but we don't want %load-path to be searched.  At least not
     by default.  This function is invoked by the "source" GDB command which
     already has its own path search support.  */
  gdb::unique_xmalloc_ptr<char> abs_filename;
  const char *result;

  if (!IS_ABSOLUTE_PATH (filename))
    {
      abs_filename = gdb_realpath (filename);
      filename = abs_filename.get ();
    }

  result = gdbscm_with_guile (scscm_source_scheme_script,
			      (void *) filename);

  if (result != NULL)
    return xstrdup (result);
  return NULL;
}

/* Utility for entering an interactive Guile repl.  */

void
gdbscm_enter_repl (void)
{
  /* It's unfortunate to have to resort to something like this, but
     scm_shell doesn't return.  :-(  I found this code on guile-user@.  */
  gdbscm_safe_call_1 (scm_c_public_ref ("system repl repl", "start-repl"),
		      scm_from_latin1_symbol ("scheme"), NULL);
}