1 /* GDB/Scheme pretty-printing.
3 Copyright (C) 2008-2014 Free Software Foundation, Inc.
5 This file is part of GDB.
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.
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.
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/>. */
20 /* See README file in this directory for implementation notes, coding
21 conventions, et.al. */
25 #include "gdb_assert.h"
26 #include "symtab.h" /* Needed by language.h. */
31 #include "guile-internal.h"
33 /* Return type of print_string_repr. */
35 enum string_repr_result
37 /* The string method returned None. */
39 /* The string method had an error. */
49 /* No display hint. */
51 /* The display hint has a bad value. */
53 /* Print as an array. */
57 /* Print as a string. */
61 /* The <gdb:pretty-printer> smob. */
65 /* This must appear first. */
68 /* A string representing the name of the printer. */
71 /* A boolean indicating whether the printer is enabled. */
74 /* A procedure called to look up the printer for the given value.
75 The procedure is called as (lookup gdb:pretty-printer value).
76 The result should either be a gdb:pretty-printer object that will print
77 the value, or #f if the value is not recognized. */
80 /* Note: Attaching subprinters to this smob is left to Scheme. */
81 } pretty_printer_smob
;
83 /* The <gdb:pretty-printer-worker> smob. */
87 /* This must appear first. */
90 /* Either #f or one of the supported display hints: map, array, string.
91 If neither of those then the display hint is ignored (treated as #f). */
94 /* A procedure called to pretty-print the value.
95 (lambda (printer) ...) -> string | <gdb:lazy-string> | <gdb:value> */
98 /* A procedure called to print children of the value.
99 (lambda (printer) ...) -> <gdb:iterator>
100 The iterator returns a pair for each iteration: (name . value),
101 where "value" can have the same types as to_string. */
103 } pretty_printer_worker_smob
;
105 static const char pretty_printer_smob_name
[] =
106 "gdb:pretty-printer";
107 static const char pretty_printer_worker_smob_name
[] =
108 "gdb:pretty-printer-worker";
110 /* The tag Guile knows the pretty-printer smobs by. */
111 static scm_t_bits pretty_printer_smob_tag
;
112 static scm_t_bits pretty_printer_worker_smob_tag
;
114 /* Global list of pretty-printers. */
115 static const char pretty_printer_list_name
[] = "*pretty-printers*";
117 /* The *pretty-printer* variable. */
118 static SCM pretty_printer_list_var
;
120 /* gdb:pp-type-error. */
121 static SCM pp_type_error_symbol
;
123 /* Pretty-printer display hints are specified by strings. */
124 static SCM ppscm_map_string
;
125 static SCM ppscm_array_string
;
126 static SCM ppscm_string_string
;
128 /* Administrivia for pretty-printer matcher smobs. */
130 /* The smob "print" function for <gdb:pretty-printer>. */
133 ppscm_print_pretty_printer_smob (SCM self
, SCM port
, scm_print_state
*pstate
)
135 pretty_printer_smob
*pp_smob
= (pretty_printer_smob
*) SCM_SMOB_DATA (self
);
137 gdbscm_printf (port
, "#<%s ", pretty_printer_smob_name
);
138 scm_write (pp_smob
->name
, port
);
139 scm_puts (gdbscm_is_true (pp_smob
->enabled
) ? " enabled" : " disabled",
141 scm_puts (">", port
);
143 scm_remember_upto_here_1 (self
);
145 /* Non-zero means success. */
149 /* (make-pretty-printer string procedure) -> <gdb:pretty-printer> */
152 gdbscm_make_pretty_printer (SCM name
, SCM lookup
)
154 pretty_printer_smob
*pp_smob
= (pretty_printer_smob
*)
155 scm_gc_malloc (sizeof (pretty_printer_smob
),
156 pretty_printer_smob_name
);
159 SCM_ASSERT_TYPE (scm_is_string (name
), name
, SCM_ARG1
, FUNC_NAME
,
161 SCM_ASSERT_TYPE (gdbscm_is_procedure (lookup
), lookup
, SCM_ARG2
, FUNC_NAME
,
164 pp_smob
->name
= name
;
165 pp_smob
->lookup
= lookup
;
166 pp_smob
->enabled
= SCM_BOOL_T
;
167 smob
= scm_new_smob (pretty_printer_smob_tag
, (scm_t_bits
) pp_smob
);
168 gdbscm_init_gsmob (&pp_smob
->base
);
173 /* Return non-zero if SCM is a <gdb:pretty-printer> object. */
176 ppscm_is_pretty_printer (SCM scm
)
178 return SCM_SMOB_PREDICATE (pretty_printer_smob_tag
, scm
);
181 /* (pretty-printer? object) -> boolean */
184 gdbscm_pretty_printer_p (SCM scm
)
186 return scm_from_bool (ppscm_is_pretty_printer (scm
));
189 /* Returns the <gdb:pretty-printer> object in SELF.
190 Throws an exception if SELF is not a <gdb:pretty-printer> object. */
193 ppscm_get_pretty_printer_arg_unsafe (SCM self
, int arg_pos
,
194 const char *func_name
)
196 SCM_ASSERT_TYPE (ppscm_is_pretty_printer (self
), self
, arg_pos
, func_name
,
197 pretty_printer_smob_name
);
202 /* Returns a pointer to the pretty-printer smob of SELF.
203 Throws an exception if SELF is not a <gdb:pretty-printer> object. */
205 static pretty_printer_smob
*
206 ppscm_get_pretty_printer_smob_arg_unsafe (SCM self
, int arg_pos
,
207 const char *func_name
)
209 SCM pp_scm
= ppscm_get_pretty_printer_arg_unsafe (self
, arg_pos
, func_name
);
210 pretty_printer_smob
*pp_smob
211 = (pretty_printer_smob
*) SCM_SMOB_DATA (pp_scm
);
216 /* Pretty-printer methods. */
218 /* (pretty-printer-enabled? <gdb:pretty-printer>) -> boolean */
221 gdbscm_pretty_printer_enabled_p (SCM self
)
223 pretty_printer_smob
*pp_smob
224 = ppscm_get_pretty_printer_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
226 return pp_smob
->enabled
;
229 /* (set-pretty-printer-enabled! <gdb:pretty-printer> boolean)
233 gdbscm_set_pretty_printer_enabled_x (SCM self
, SCM enabled
)
235 pretty_printer_smob
*pp_smob
236 = ppscm_get_pretty_printer_smob_arg_unsafe (self
, SCM_ARG1
, FUNC_NAME
);
238 pp_smob
->enabled
= scm_from_bool (gdbscm_is_true (enabled
));
240 return SCM_UNSPECIFIED
;
243 /* Administrivia for pretty-printer-worker smobs.
244 These are created when a matcher recognizes a value. */
246 /* The smob "print" function for <gdb:pretty-printer-worker>. */
249 ppscm_print_pretty_printer_worker_smob (SCM self
, SCM port
,
250 scm_print_state
*pstate
)
252 pretty_printer_worker_smob
*w_smob
253 = (pretty_printer_worker_smob
*) SCM_SMOB_DATA (self
);
255 gdbscm_printf (port
, "#<%s ", pretty_printer_worker_smob_name
);
256 scm_write (w_smob
->display_hint
, port
);
257 scm_puts (" ", port
);
258 scm_write (w_smob
->to_string
, port
);
259 scm_puts (" ", port
);
260 scm_write (w_smob
->children
, port
);
261 scm_puts (">", port
);
263 scm_remember_upto_here_1 (self
);
265 /* Non-zero means success. */
269 /* (make-pretty-printer-worker string procedure procedure)
270 -> <gdb:pretty-printer-worker> */
273 gdbscm_make_pretty_printer_worker (SCM display_hint
, SCM to_string
,
276 pretty_printer_worker_smob
*w_smob
= (pretty_printer_worker_smob
*)
277 scm_gc_malloc (sizeof (pretty_printer_worker_smob
),
278 pretty_printer_worker_smob_name
);
281 w_smob
->display_hint
= display_hint
;
282 w_smob
->to_string
= to_string
;
283 w_smob
->children
= children
;
284 w_scm
= scm_new_smob (pretty_printer_worker_smob_tag
, (scm_t_bits
) w_smob
);
285 gdbscm_init_gsmob (&w_smob
->base
);
289 /* Return non-zero if SCM is a <gdb:pretty-printer-worker> object. */
292 ppscm_is_pretty_printer_worker (SCM scm
)
294 return SCM_SMOB_PREDICATE (pretty_printer_worker_smob_tag
, scm
);
297 /* (pretty-printer-worker? object) -> boolean */
300 gdbscm_pretty_printer_worker_p (SCM scm
)
302 return scm_from_bool (ppscm_is_pretty_printer_worker (scm
));
305 /* Helper function to create a <gdb:exception> object indicating that the
306 type of some value returned from a pretty-printer is invalid. */
309 ppscm_make_pp_type_error_exception (const char *message
, SCM object
)
311 char *msg
= xstrprintf ("%s: ~S", message
);
312 struct cleanup
*cleanup
= make_cleanup (xfree
, msg
);
314 = gdbscm_make_error (pp_type_error_symbol
,
315 NULL
/* func */, msg
,
316 scm_list_1 (object
), scm_list_1 (object
));
318 do_cleanups (cleanup
);
323 /* Print MESSAGE as an exception (meaning it is controlled by
324 "guile print-stack").
325 Called from the printer code when the Scheme code returns an invalid type
329 ppscm_print_pp_type_error (const char *message
, SCM object
)
331 SCM exception
= ppscm_make_pp_type_error_exception (message
, object
);
333 gdbscm_print_gdb_exception (SCM_BOOL_F
, exception
);
336 /* Helper function for find_pretty_printer which iterates over a list,
337 calls each function and inspects output. This will return a
338 <gdb:pretty-printer> object if one recognizes VALUE. If no printer is
339 found, it will return #f. On error, it will return a <gdb:exception>
342 Note: This has to be efficient and careful.
343 We don't want to excessively slow down printing of values, but any kind of
344 random crud can appear in the pretty-printer list, and we can't crash
348 ppscm_search_pp_list (SCM list
, SCM value
)
350 SCM orig_list
= list
;
352 if (scm_is_null (list
))
354 if (gdbscm_is_false (scm_list_p (list
))) /* scm_is_pair? */
356 return ppscm_make_pp_type_error_exception
357 (_("pretty-printer list is not a list"), list
);
360 for ( ; scm_is_pair (list
); list
= scm_cdr (list
))
362 SCM matcher
= scm_car (list
);
364 pretty_printer_smob
*pp_smob
;
367 if (!ppscm_is_pretty_printer (matcher
))
369 return ppscm_make_pp_type_error_exception
370 (_("pretty-printer list contains non-pretty-printer object"),
374 pp_smob
= (pretty_printer_smob
*) SCM_SMOB_DATA (matcher
);
376 /* Skip if disabled. */
377 if (gdbscm_is_false (pp_smob
->enabled
))
380 if (!gdbscm_is_procedure (pp_smob
->lookup
))
382 return ppscm_make_pp_type_error_exception
383 (_("invalid lookup object in pretty-printer matcher"),
387 worker
= gdbscm_safe_call_2 (pp_smob
->lookup
, matcher
,
388 value
, gdbscm_memory_error_p
);
389 if (!gdbscm_is_false (worker
))
391 if (gdbscm_is_exception (worker
))
393 if (ppscm_is_pretty_printer_worker (worker
))
395 return ppscm_make_pp_type_error_exception
396 (_("invalid result from pretty-printer lookup"), worker
);
400 if (!scm_is_null (list
))
402 return ppscm_make_pp_type_error_exception
403 (_("pretty-printer list is not a list"), orig_list
);
409 /* Subroutine of find_pretty_printer to simplify it.
410 Look for a pretty-printer to print VALUE in all objfiles.
411 If there's an error an exception smob is returned.
412 The result is #f, if no pretty-printer was found.
413 Otherwise the result is the pretty-printer smob. */
416 ppscm_find_pretty_printer_from_objfiles (SCM value
)
418 struct objfile
*objfile
;
420 ALL_OBJFILES (objfile
)
422 objfile_smob
*o_smob
= ofscm_objfile_smob_from_objfile (objfile
);
423 SCM pp
= ppscm_search_pp_list (ofscm_objfile_smob_pretty_printers (o_smob
),
426 /* Note: This will return if pp is a <gdb:exception> object,
427 which is what we want. */
428 if (gdbscm_is_true (pp
))
435 /* Subroutine of find_pretty_printer to simplify it.
436 Look for a pretty-printer to print VALUE in the current program space.
437 If there's an error an exception smob is returned.
438 The result is #f, if no pretty-printer was found.
439 Otherwise the result is the pretty-printer smob. */
442 ppscm_find_pretty_printer_from_progspace (SCM value
)
444 pspace_smob
*p_smob
= psscm_pspace_smob_from_pspace (current_program_space
);
446 = ppscm_search_pp_list (psscm_pspace_smob_pretty_printers (p_smob
), value
);
451 /* Subroutine of find_pretty_printer to simplify it.
452 Look for a pretty-printer to print VALUE in the gdb module.
453 If there's an error a Scheme exception is returned.
454 The result is #f, if no pretty-printer was found.
455 Otherwise the result is the pretty-printer smob. */
458 ppscm_find_pretty_printer_from_gdb (SCM value
)
462 /* Fetch the global pretty printer list. */
463 pp_list
= scm_variable_ref (pretty_printer_list_var
);
464 pp
= ppscm_search_pp_list (pp_list
, value
);
468 /* Find the pretty-printing constructor function for VALUE. If no
469 pretty-printer exists, return #f. If one exists, return the
470 gdb:pretty-printer smob that implements it. On error, an exception smob
473 Note: In the end it may be better to call out to Scheme once, and then
474 do all of the lookup from Scheme. TBD. */
477 ppscm_find_pretty_printer (SCM value
)
481 /* Look at the pretty-printer list for each objfile
482 in the current program-space. */
483 pp
= ppscm_find_pretty_printer_from_objfiles (value
);
484 /* Note: This will return if function is a <gdb:exception> object,
485 which is what we want. */
486 if (gdbscm_is_true (pp
))
489 /* Look at the pretty-printer list for the current program-space. */
490 pp
= ppscm_find_pretty_printer_from_progspace (value
);
491 /* Note: This will return if function is a <gdb:exception> object,
492 which is what we want. */
493 if (gdbscm_is_true (pp
))
496 /* Look at the pretty-printer list in the gdb module. */
497 pp
= ppscm_find_pretty_printer_from_gdb (value
);
501 /* Pretty-print a single value, via the PRINTER, which must be a
502 <gdb:pretty-printer-worker> object.
503 The caller is responsible for ensuring PRINTER is valid.
504 If the function returns a string, an SCM containing the string
505 is returned. If the function returns #f that means the pretty
506 printer returned #f as a value. Otherwise, if the function returns a
507 <gdb:value> object, *OUT_VALUE is set to the value and #t is returned.
508 It is an error if the printer returns #t.
509 On error, an exception smob is returned. */
512 ppscm_pretty_print_one_value (SCM printer
, struct value
**out_value
,
513 struct gdbarch
*gdbarch
,
514 const struct language_defn
*language
)
516 volatile struct gdb_exception except
;
517 SCM result
= SCM_BOOL_F
;
520 TRY_CATCH (except
, RETURN_MASK_ALL
)
523 pretty_printer_worker_smob
*w_smob
524 = (pretty_printer_worker_smob
*) SCM_SMOB_DATA (printer
);
526 result
= gdbscm_safe_call_1 (w_smob
->to_string
, printer
,
527 gdbscm_memory_error_p
);
528 if (gdbscm_is_false (result
))
530 else if (scm_is_string (result
)
531 || lsscm_is_lazy_string (result
))
533 else if (vlscm_is_value (result
))
538 = vlscm_convert_value_from_scheme (FUNC_NAME
, GDBSCM_ARG_NONE
,
541 if (*out_value
!= NULL
)
546 else if (gdbscm_is_exception (result
))
550 /* Invalid result from to-string. */
551 result
= ppscm_make_pp_type_error_exception
552 (_("invalid result from pretty-printer to-string"), result
);
559 /* Return the display hint for PRINTER as a Scheme object.
560 The caller is responsible for ensuring PRINTER is a
561 <gdb:pretty-printer-worker> object. */
564 ppscm_get_display_hint_scm (SCM printer
)
566 pretty_printer_worker_smob
*w_smob
567 = (pretty_printer_worker_smob
*) SCM_SMOB_DATA (printer
);
569 return w_smob
->display_hint
;
572 /* Return the display hint for the pretty-printer PRINTER.
573 The caller is responsible for ensuring PRINTER is a
574 <gdb:pretty-printer-worker> object.
575 Returns the display hint or #f if the hint is not a string. */
577 static enum display_hint
578 ppscm_get_display_hint_enum (SCM printer
)
580 SCM hint
= ppscm_get_display_hint_scm (printer
);
582 if (gdbscm_is_false (hint
))
584 if (scm_is_string (hint
))
586 if (gdbscm_is_true (scm_string_equal_p (hint
, ppscm_array_string
)))
588 if (gdbscm_is_true (scm_string_equal_p (hint
, ppscm_map_string
)))
590 if (gdbscm_is_true (scm_string_equal_p (hint
, ppscm_string_string
)))
597 /* A wrapper for gdbscm_print_gdb_exception that ignores memory errors.
598 EXCEPTION is a <gdb:exception> object. */
601 ppscm_print_exception_unless_memory_error (SCM exception
,
602 struct ui_file
*stream
)
604 if (gdbscm_memory_error_p (gdbscm_exception_key (exception
)))
606 char *msg
= gdbscm_exception_message_to_string (exception
);
607 struct cleanup
*cleanup
= make_cleanup (xfree
, msg
);
609 /* This "shouldn't happen", but play it safe. */
610 if (msg
== NULL
|| *msg
== '\0')
611 fprintf_filtered (stream
, _("<error reading variable>"));
614 /* Remove the trailing newline. We could instead call a special
615 routine for printing memory error messages, but this is easy
617 size_t len
= strlen (msg
);
619 if (msg
[len
- 1] == '\n')
621 fprintf_filtered (stream
, _("<error reading variable: %s>"), msg
);
624 do_cleanups (cleanup
);
627 gdbscm_print_gdb_exception (SCM_BOOL_F
, exception
);
630 /* Helper for gdbscm_apply_val_pretty_printer which calls to_string and
631 formats the result. */
633 static enum string_repr_result
634 ppscm_print_string_repr (SCM printer
, enum display_hint hint
,
635 struct ui_file
*stream
, int recurse
,
636 const struct value_print_options
*options
,
637 struct gdbarch
*gdbarch
,
638 const struct language_defn
*language
)
640 struct value
*replacement
= NULL
;
642 enum string_repr_result result
= STRING_REPR_ERROR
;
644 str_scm
= ppscm_pretty_print_one_value (printer
, &replacement
,
646 if (gdbscm_is_false (str_scm
))
648 result
= STRING_REPR_NONE
;
650 else if (scm_is_eq (str_scm
, SCM_BOOL_T
))
652 struct value_print_options opts
= *options
;
654 gdb_assert (replacement
!= NULL
);
655 opts
.addressprint
= 0;
656 common_val_print (replacement
, stream
, recurse
, &opts
, language
);
657 result
= STRING_REPR_OK
;
659 else if (scm_is_string (str_scm
))
661 struct cleanup
*cleanup
;
664 = gdbscm_scm_to_string (str_scm
, &length
,
665 target_charset (gdbarch
), 0 /*!strict*/, NULL
);
667 cleanup
= make_cleanup (xfree
, string
);
668 if (hint
== HINT_STRING
)
670 struct type
*type
= builtin_type (gdbarch
)->builtin_char
;
672 LA_PRINT_STRING (stream
, type
, (gdb_byte
*) string
,
673 length
, NULL
, 0, options
);
677 /* Alas scm_to_stringn doesn't nul-terminate the string if we
678 ask for the length. */
681 for (i
= 0; i
< length
; ++i
)
683 if (string
[i
] == '\0')
684 fputs_filtered ("\\000", stream
);
686 fputc_filtered (string
[i
], stream
);
689 result
= STRING_REPR_OK
;
690 do_cleanups (cleanup
);
692 else if (lsscm_is_lazy_string (str_scm
))
694 struct value_print_options local_opts
= *options
;
696 local_opts
.addressprint
= 0;
697 lsscm_val_print_lazy_string (str_scm
, stream
, &local_opts
);
698 result
= STRING_REPR_OK
;
702 gdb_assert (gdbscm_is_exception (str_scm
));
703 ppscm_print_exception_unless_memory_error (str_scm
, stream
);
704 result
= STRING_REPR_ERROR
;
710 /* Helper for gdbscm_apply_val_pretty_printer that formats children of the
711 printer, if any exist.
712 The caller is responsible for ensuring PRINTER is a printer smob.
713 If PRINTED_NOTHING is true, then nothing has been printed by to_string,
714 and format output accordingly. */
717 ppscm_print_children (SCM printer
, enum display_hint hint
,
718 struct ui_file
*stream
, int recurse
,
719 const struct value_print_options
*options
,
720 struct gdbarch
*gdbarch
,
721 const struct language_defn
*language
,
724 pretty_printer_worker_smob
*w_smob
725 = (pretty_printer_worker_smob
*) SCM_SMOB_DATA (printer
);
726 int is_map
, is_array
, done_flag
, pretty
;
728 SCM children
, status
;
729 SCM iter
= SCM_BOOL_F
; /* -Wall */
730 struct cleanup
*cleanups
;
732 if (gdbscm_is_false (w_smob
->children
))
734 if (!gdbscm_is_procedure (w_smob
->children
))
736 ppscm_print_pp_type_error
737 (_("pretty-printer \"children\" object is not a procedure or #f"),
742 cleanups
= make_cleanup (null_cleanup
, NULL
);
744 /* If we are printing a map or an array, we want special formatting. */
745 is_map
= hint
== HINT_MAP
;
746 is_array
= hint
== HINT_ARRAY
;
748 children
= gdbscm_safe_call_1 (w_smob
->children
, printer
,
749 gdbscm_memory_error_p
);
750 if (gdbscm_is_exception (children
))
752 ppscm_print_exception_unless_memory_error (children
, stream
);
755 /* We combine two steps here: get children, make an iterator out of them.
756 This simplifies things because there's no language means of creating
757 iterators, and it's the printer object that knows how it will want its
758 children iterated over. */
759 if (!itscm_is_iterator (children
))
761 ppscm_print_pp_type_error
762 (_("result of pretty-printer \"children\" procedure is not"
763 " a <gdb:iterator> object"), children
);
768 /* Use the prettyformat_arrays option if we are printing an array,
769 and the pretty option otherwise. */
771 pretty
= options
->prettyformat_arrays
;
774 if (options
->prettyformat
== Val_prettyformat
)
777 pretty
= options
->prettyformat_structs
;
781 for (i
= 0; i
< options
->print_max
; ++i
)
786 SCM item
= itscm_safe_call_next_x (iter
, gdbscm_memory_error_p
);
787 struct cleanup
*inner_cleanup
= make_cleanup (null_cleanup
, NULL
);
789 if (gdbscm_is_exception (item
))
791 ppscm_print_exception_unless_memory_error (item
, stream
);
794 if (itscm_is_end_of_iteration (item
))
796 /* Set a flag so we can know whether we printed all the
797 available elements. */
802 if (! scm_is_pair (item
))
804 ppscm_print_pp_type_error
805 (_("result of pretty-printer children iterator is not a pair"
806 " or (end-of-iteration)"),
810 scm_name
= scm_car (item
);
811 v_scm
= scm_cdr (item
);
812 if (!scm_is_string (scm_name
))
814 ppscm_print_pp_type_error
815 (_("first element of pretty-printer children iterator is not"
819 name
= gdbscm_scm_to_c_string (scm_name
);
820 make_cleanup (xfree
, name
);
822 /* Print initial "{". For other elements, there are three cases:
823 1. Maps. Print a "," after each value element.
824 2. Arrays. Always print a ",".
825 3. Other. Always print a ",". */
829 fputs_filtered ("{", stream
);
831 fputs_filtered (" = {", stream
);
834 else if (! is_map
|| i
% 2 == 0)
835 fputs_filtered (pretty
? "," : ", ", stream
);
837 /* In summary mode, we just want to print "= {...}" if there is
839 if (options
->summary
)
841 /* This increment tricks the post-loop logic to print what
849 if (! is_map
|| i
% 2 == 0)
853 fputs_filtered ("\n", stream
);
854 print_spaces_filtered (2 + 2 * recurse
, stream
);
857 wrap_here (n_spaces (2 + 2 *recurse
));
860 if (is_map
&& i
% 2 == 0)
861 fputs_filtered ("[", stream
);
864 /* We print the index, not whatever the child method
865 returned as the name. */
866 if (options
->print_array_indexes
)
867 fprintf_filtered (stream
, "[%d] = ", i
);
871 fputs_filtered (name
, stream
);
872 fputs_filtered (" = ", stream
);
875 if (lsscm_is_lazy_string (v_scm
))
877 struct value_print_options local_opts
= *options
;
879 local_opts
.addressprint
= 0;
880 lsscm_val_print_lazy_string (v_scm
, stream
, &local_opts
);
882 else if (scm_is_string (v_scm
))
884 char *output
= gdbscm_scm_to_c_string (v_scm
);
886 fputs_filtered (output
, stream
);
893 = vlscm_convert_value_from_scheme (FUNC_NAME
, GDBSCM_ARG_NONE
,
899 ppscm_print_exception_unless_memory_error (except_scm
, stream
);
902 common_val_print (value
, stream
, recurse
+ 1, options
, language
);
905 if (is_map
&& i
% 2 == 0)
906 fputs_filtered ("] = ", stream
);
908 do_cleanups (inner_cleanup
);
917 fputs_filtered ("\n", stream
);
918 print_spaces_filtered (2 + 2 * recurse
, stream
);
920 fputs_filtered ("...", stream
);
924 fputs_filtered ("\n", stream
);
925 print_spaces_filtered (2 * recurse
, stream
);
927 fputs_filtered ("}", stream
);
931 do_cleanups (cleanups
);
933 /* Play it safe, make sure ITER doesn't get GC'd. */
934 scm_remember_upto_here_1 (iter
);
937 /* This is the extension_language_ops.apply_val_pretty_printer "method". */
940 gdbscm_apply_val_pretty_printer (const struct extension_language_defn
*extlang
,
941 struct type
*type
, const gdb_byte
*valaddr
,
942 int embedded_offset
, CORE_ADDR address
,
943 struct ui_file
*stream
, int recurse
,
944 const struct value
*val
,
945 const struct value_print_options
*options
,
946 const struct language_defn
*language
)
948 struct gdbarch
*gdbarch
= get_type_arch (type
);
949 SCM exception
= SCM_BOOL_F
;
950 SCM printer
= SCM_BOOL_F
;
951 SCM val_obj
= SCM_BOOL_F
;
953 enum display_hint hint
;
954 struct cleanup
*cleanups
;
955 int result
= EXT_LANG_RC_NOP
;
956 enum string_repr_result print_result
;
958 /* No pretty-printer support for unavailable values. */
959 if (!value_bytes_available (val
, embedded_offset
, TYPE_LENGTH (type
)))
960 return EXT_LANG_RC_NOP
;
962 if (!gdb_scheme_initialized
)
963 return EXT_LANG_RC_NOP
;
965 cleanups
= make_cleanup (null_cleanup
, NULL
);
967 /* Instantiate the printer. */
969 valaddr
+= embedded_offset
;
970 value
= value_from_contents_and_address (type
, valaddr
,
971 address
+ embedded_offset
);
973 set_value_component_location (value
, val
);
974 /* set_value_component_location resets the address, so we may
975 need to set it again. */
976 if (VALUE_LVAL (value
) != lval_internalvar
977 && VALUE_LVAL (value
) != lval_internalvar_component
978 && VALUE_LVAL (value
) != lval_computed
)
979 set_value_address (value
, address
+ embedded_offset
);
981 val_obj
= vlscm_scm_from_value (value
);
982 if (gdbscm_is_exception (val_obj
))
985 result
= EXT_LANG_RC_ERROR
;
989 printer
= ppscm_find_pretty_printer (val_obj
);
991 if (gdbscm_is_exception (printer
))
994 result
= EXT_LANG_RC_ERROR
;
997 if (gdbscm_is_false (printer
))
999 result
= EXT_LANG_RC_NOP
;
1002 gdb_assert (ppscm_is_pretty_printer_worker (printer
));
1004 /* If we are printing a map, we want some special formatting. */
1005 hint
= ppscm_get_display_hint_enum (printer
);
1006 if (hint
== HINT_ERROR
)
1008 /* Print the error as an exception for consistency. */
1009 SCM hint_scm
= ppscm_get_display_hint_scm (printer
);
1011 ppscm_print_pp_type_error ("Invalid display hint", hint_scm
);
1012 /* Fall through. A bad hint doesn't stop pretty-printing. */
1016 /* Print the section. */
1017 print_result
= ppscm_print_string_repr (printer
, hint
, stream
, recurse
,
1018 options
, gdbarch
, language
);
1019 if (print_result
!= STRING_REPR_ERROR
)
1021 ppscm_print_children (printer
, hint
, stream
, recurse
, options
,
1023 print_result
== STRING_REPR_NONE
);
1026 result
= EXT_LANG_RC_OK
;
1029 if (gdbscm_is_exception (exception
))
1030 ppscm_print_exception_unless_memory_error (exception
, stream
);
1031 do_cleanups (cleanups
);
1035 /* Initialize the Scheme pretty-printer code. */
1037 static const scheme_function pretty_printer_functions
[] =
1039 { "make-pretty-printer", 2, 0, 0, gdbscm_make_pretty_printer
,
1041 Create a <gdb:pretty-printer> object.\n\
1043 Arguments: name lookup\n\
1044 name: a string naming the matcher\n\
1045 lookup: a procedure:\n\
1046 (pretty-printer <gdb:value>) -> <gdb:pretty-printer-worker> | #f." },
1048 { "pretty-printer?", 1, 0, 0, gdbscm_pretty_printer_p
,
1050 Return #t if the object is a <gdb:pretty-printer> object." },
1052 { "pretty-printer-enabled?", 1, 0, 0, gdbscm_pretty_printer_enabled_p
,
1054 Return #t if the pretty-printer is enabled." },
1056 { "set-pretty-printer-enabled!", 2, 0, 0,
1057 gdbscm_set_pretty_printer_enabled_x
,
1059 Set the enabled flag of the pretty-printer.\n\
1060 Returns \"unspecified\"." },
1062 { "make-pretty-printer-worker", 3, 0, 0, gdbscm_make_pretty_printer_worker
,
1064 Create a <gdb:pretty-printer-worker> object.\n\
1066 Arguments: display-hint to-string children\n\
1067 display-hint: either #f or one of \"array\", \"map\", or \"string\"\n\
1068 to-string: a procedure:\n\
1069 (pretty-printer) -> string | #f | <gdb:value>\n\
1070 children: either #f or a procedure:\n\
1071 (pretty-printer) -> <gdb:iterator>" },
1073 { "pretty-printer-worker?", 1, 0, 0, gdbscm_pretty_printer_worker_p
,
1075 Return #t if the object is a <gdb:pretty-printer-worker> object." },
1081 gdbscm_initialize_pretty_printers (void)
1083 pretty_printer_smob_tag
1084 = gdbscm_make_smob_type (pretty_printer_smob_name
,
1085 sizeof (pretty_printer_smob
));
1086 scm_set_smob_print (pretty_printer_smob_tag
,
1087 ppscm_print_pretty_printer_smob
);
1089 pretty_printer_worker_smob_tag
1090 = gdbscm_make_smob_type (pretty_printer_worker_smob_name
,
1091 sizeof (pretty_printer_worker_smob
));
1092 scm_set_smob_print (pretty_printer_worker_smob_tag
,
1093 ppscm_print_pretty_printer_worker_smob
);
1095 gdbscm_define_functions (pretty_printer_functions
, 1);
1097 scm_c_define (pretty_printer_list_name
, SCM_EOL
);
1099 pretty_printer_list_var
1100 = scm_c_private_variable (gdbscm_module_name
,
1101 pretty_printer_list_name
);
1102 gdb_assert (!gdbscm_is_false (pretty_printer_list_var
));
1104 pp_type_error_symbol
= scm_from_latin1_symbol ("gdb:pp-type-error");
1106 ppscm_map_string
= scm_from_latin1_string ("map");
1107 ppscm_array_string
= scm_from_latin1_string ("array");
1108 ppscm_string_string
= scm_from_latin1_string ("string");