gdb/guile/scm-color.c

   1 /* GDB parameters implemented in Guile.
   2
   3    Copyright (C) 2008-2024 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 #include "value.h"
  21 #include "charset.h"
  22 #include "cli/cli-decode.h"
  23 #include "completer.h"
  24 #include "language.h"
  25 #include "arch-utils.h"
  26 #include "guile-internal.h"
  27
  28 /* A GDB color.  */
  29
  30 struct color_smob
  31 {
  32   /* This always appears first.  */
  33   gdb_smob base;
  34
  35   /* Underlying value.  */
  36   ui_file_style::color color;
  37 };
  38
  39 static const char color_smob_name[] = "gdb:color";
  40
  41 /* The tag Guile knows the color smob by.  */
  42 static scm_t_bits color_smob_tag;
  43
  44 /* Keywords used by make-color.  */
  45 static SCM colorspace_keyword;
  46
  47 static const char *coscm_colorspace_name (color_space colorspace);
  48
  49 /* Administrivia for color smobs.  */
  50
  51 static int
  52 coscm_print_color_smob (SCM self, SCM port, scm_print_state *pstate)
  53 {
  54   const ui_file_style::color &color = coscm_get_color (self);
  55
  56   gdbscm_printf (port, "#<%s", color_smob_name);
  57
  58   gdbscm_printf (port, " %s", color.to_string ().c_str ());
  59   gdbscm_printf (port, " %s", coscm_colorspace_name (color.colorspace ()));
  60   scm_puts (">", port);
  61
  62   scm_remember_upto_here_1 (self);
  63
  64   /* Non-zero means success.  */
  65   return 1;
  66 }
  67
  68 /* Create an empty (uninitialized) color.  */
  69
  70 static SCM
  71 coscm_make_color_smob (void)
  72 {
  73   color_smob *c_smob = (color_smob *)
  74     scm_gc_calloc (sizeof (color_smob), color_smob_name);
  75   SCM c_scm;
  76
  77   c_smob->color = ui_file_style::color (ui_file_style::NONE);
  78   c_scm = scm_new_smob (color_smob_tag, (scm_t_bits) c_smob);
  79   gdbscm_init_gsmob (&c_smob->base);
  80
  81   return c_scm;
  82 }
  83
  84 /* Return the <gdb:color> object that encapsulates COLOR.  */
  85
  86 SCM
  87 coscm_scm_from_color (const ui_file_style::color &color)
  88 {
  89   SCM c_scm = coscm_make_color_smob ();
  90   color_smob *c_smob = (color_smob *) SCM_SMOB_DATA (c_scm);
  91   c_smob->color = color;
  92   return c_scm;
  93 }
  94
  95 /* Return the color field of color_smob.  */
  96
  97 const ui_file_style::color &
  98 coscm_get_color (SCM color_scm)
  99 {
 100   SCM_ASSERT_TYPE (coscm_is_color (color_scm), color_scm, SCM_ARG1, FUNC_NAME,
 101                    _("<gdb:color>"));
 102
 103   color_smob *c_smob = (color_smob *) SCM_SMOB_DATA (color_scm);
 104   return c_smob->color;
 105
 106 }
 107
 108 /* Returns non-zero if SCM is a <gdb:color> object.  */
 109
 110 int
 111 coscm_is_color (SCM scm)
 112 {
 113   return SCM_SMOB_PREDICATE (color_smob_tag, scm);
 114 }
 115
 116 /* (gdb:color? scm) -> boolean */
 117
 118 static SCM
 119 gdbscm_color_p (SCM scm)
 120 {
 121   return scm_from_bool (coscm_is_color (scm));
 122 }
 123
 124 static const scheme_integer_constant colorspaces[] =
 125 {
 126   { "COLORSPACE_MONOCHROME", (int) color_space::MONOCHROME },
 127   { "COLORSPACE_ANSI_8COLOR", (int) color_space::ANSI_8COLOR },
 128   { "COLORSPACE_AIXTERM_16COLOR", (int) color_space::AIXTERM_16COLOR },
 129   { "COLORSPACE_XTERM_256COLOR", (int) color_space::XTERM_256COLOR },
 130   { "COLORSPACE_RGB_24BIT", (int) color_space::RGB_24BIT },
 131
 132   END_INTEGER_CONSTANTS
 133 };
 134
 135 /* Return COLORSPACE as a string.  */
 136
 137 static const char *
 138 coscm_colorspace_name (color_space colorspace)
 139 {
 140   for (int i = 0; colorspaces[i].name != nullptr; ++i)
 141     {
 142       if (colorspaces[i].value == static_cast<int> (colorspace))
 143         return colorspaces[i].name;
 144     }
 145
 146   gdb_assert_not_reached ("bad color space");
 147 }
 148
 149 /* Free function for a color_smob.  */
 150 static size_t
 151 coscm_free_color_smob (SCM self)
 152 {
 153   (void) self;
 154   return 0;
 155 }
 156
 157 /* Color Scheme functions.  */
 158
 159 /* (make-color [value
 160      [#:color-space colorspace]]) -> <gdb:color>
 161
 162    VALUE is the value of the color.  It may be SCM_UNDEFINED, string, number
 163    or list.
 164
 165    COLORSPACE is the color space of the VALUE.  It should be one of the
 166    COLORSPACE_* constants defined in the gdb module.
 167
 168    The result is the <gdb:color> Scheme object.  */
 169
 170 static SCM
 171 gdbscm_make_color (SCM value_scm, SCM rest)
 172 {
 173   SCM colorspace_arg = SCM_UNDEFINED;
 174   color_space colorspace = color_space::MONOCHROME;
 175
 176   scm_c_bind_keyword_arguments (FUNC_NAME, rest,
 177                                 static_cast<scm_t_keyword_arguments_flags> (0),
 178                                 colorspace_keyword, &colorspace_arg,
 179                                 SCM_UNDEFINED);
 180
 181   if (!SCM_UNBNDP (colorspace_arg))
 182     {
 183       SCM_ASSERT_TYPE (scm_is_integer (colorspace_arg), colorspace_arg,
 184                        SCM_ARG2, FUNC_NAME, _("int"));
 185       int colorspace_int = scm_to_int (colorspace_arg);
 186       if (!color_space_safe_cast (&colorspace, colorspace_int))
 187         gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG2,
 188                                    scm_from_int (colorspace_int),
 189                                    _("invalid colorspace argument"));
 190     }
 191
 192   ui_file_style::color color = ui_file_style::NONE;
 193   gdbscm_gdb_exception exc {};
 194
 195   try
 196     {
 197       if (SCM_UNBNDP (value_scm) || scm_is_integer (value_scm))
 198         {
 199           int i = -1;
 200           if (scm_is_integer (value_scm))
 201             {
 202               i = scm_to_int (value_scm);
 203               if (i < 0)
 204                 gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, value_scm,
 205                                            _("negative color index"));
 206             }
 207
 208           if (SCM_UNBNDP (colorspace_arg))
 209             color = ui_file_style::color (i);
 210           else
 211             color = ui_file_style::color (colorspace, i);
 212         }
 213       else if (gdbscm_is_true (scm_list_p (value_scm)))
 214         {
 215           if (SCM_UNBNDP (colorspace_arg)
 216               || colorspace != color_space::RGB_24BIT)
 217             error (_("colorspace must be COLORSPACE_RGB_24BIT with "
 218                    "value of list type."));
 219
 220           if (scm_ilength (value_scm) != 3)
 221             error (_("List value with RGB must be of size 3."));
 222
 223           uint8_t rgb[3] = {};
 224           int i = 0;
 225           for (; i < 3 && !scm_is_eq (value_scm, SCM_EOL); ++i)
 226             {
 227               SCM item = scm_car (value_scm);
 228
 229               SCM_ASSERT_TYPE (scm_is_integer (item), item, SCM_ARG1, FUNC_NAME,
 230                                _("int"));
 231               int component = scm_to_int (item);
 232               if (component < 0 || component > UINT8_MAX)
 233                 gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, item,
 234                                            _("invalid rgb component"));
 235               rgb[i] = static_cast<uint8_t> (component);
 236
 237               value_scm = scm_cdr (value_scm);
 238             }
 239
 240           gdb_assert (i == 3);
 241
 242           color = ui_file_style::color (rgb[0], rgb[1], rgb[2]);
 243         }
 244       else if (scm_is_string (value_scm))
 245         {
 246           SCM exception;
 247
 248           gdb::unique_xmalloc_ptr<char> string
 249             = gdbscm_scm_to_host_string (value_scm, nullptr, &exception);
 250           if (string == nullptr)
 251             gdbscm_throw (exception);
 252
 253           color = parse_var_color (string.get ());
 254
 255           if (!SCM_UNBNDP (colorspace_arg) && colorspace != color.colorspace ())
 256             error (_("colorspace doesn't match to the value."));
 257
 258         }
 259       else
 260         scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, value_scm,
 261                                 "integer, string or list");
 262     }
 263   catch (const gdb_exception &except)
 264     {
 265       exc = unpack (except);
 266     }
 267
 268   GDBSCM_HANDLE_GDB_EXCEPTION (exc);
 269
 270   return coscm_scm_from_color (color);
 271 }
 272
 273 /* (color-string <gdb:color>) -> value */
 274
 275 static SCM
 276 gdbscm_color_string (SCM self)
 277 {
 278   const ui_file_style::color &color = coscm_get_color (self);
 279   std::string s = color.to_string ();
 280   return gdbscm_scm_from_host_string (s.c_str (), s.size ());
 281 }
 282
 283 /* (color-colorspace <gdb:color>) -> value */
 284
 285 static SCM
 286 gdbscm_color_colorspace (SCM self)
 287 {
 288   const ui_file_style::color &color = coscm_get_color (self);
 289   return scm_from_int (static_cast<int> (color.colorspace ()));
 290 }
 291
 292 /* (color-none? scm) -> boolean */
 293
 294 static SCM
 295 gdbscm_color_none_p (SCM self)
 296 {
 297   const ui_file_style::color &color = coscm_get_color (self);
 298   return scm_from_bool (color.is_none ());
 299 }
 300
 301 /* (color-indexed? scm) -> boolean */
 302
 303 static SCM
 304 gdbscm_color_indexed_p (SCM self)
 305 {
 306   const ui_file_style::color &color = coscm_get_color (self);
 307   return scm_from_bool (color.is_indexed ());
 308 }
 309
 310 /* (color-direct? scm) -> boolean */
 311
 312 static SCM
 313 gdbscm_color_direct_p (SCM self)
 314 {
 315   const ui_file_style::color &color = coscm_get_color (self);
 316   return scm_from_bool (color.is_direct ());
 317 }
 318
 319 /* (color-index <gdb:color>) -> value */
 320
 321 static SCM
 322 gdbscm_color_index (SCM self)
 323 {
 324   const ui_file_style::color &color = coscm_get_color (self);
 325
 326   if (!color.is_indexed ())
 327     gdbscm_misc_error (FUNC_NAME, SCM_ARG1, self, "color is not indexed");
 328   return scm_from_int (color.get_value ());
 329 }
 330
 331 /* (color-components <gdb:color>) -> value */
 332
 333 static SCM
 334 gdbscm_color_components (SCM self)
 335 {
 336   const ui_file_style::color &color = coscm_get_color (self);
 337
 338   if (!color.is_direct ())
 339     gdbscm_misc_error (FUNC_NAME, SCM_ARG1, self, "color is not direct");
 340
 341   uint8_t rgb[3] = {};
 342   color.get_rgb (rgb);
 343   SCM red = scm_from_uint8 (rgb[0]);
 344   SCM green = scm_from_uint8 (rgb[1]);
 345   SCM blue = scm_from_uint8 (rgb[2]);
 346   return scm_list_3 (red, green, blue);
 347 }
 348
 349 /* (color-escape-sequence <gdb:color> is_fg) -> value */
 350
 351 static SCM
 352 gdbscm_color_escape_sequence (SCM self, SCM is_fg_scm)
 353 {
 354   const ui_file_style::color &color = coscm_get_color (self);
 355   SCM_ASSERT_TYPE (gdbscm_is_bool (is_fg_scm), is_fg_scm, SCM_ARG2, FUNC_NAME,
 356                    _("boolean"));
 357   bool is_fg = gdbscm_is_true (is_fg_scm);
 358   std::string s = color.to_ansi (is_fg);
 359   return gdbscm_scm_from_host_string (s.c_str (), s.size ());
 360 }
 361
 362 /* Initialize the Scheme color support.  */
 363
 364 static const scheme_function color_functions[] =
 365 {
 366   { "make-color", 0, 1, 1, as_a_scm_t_subr (gdbscm_make_color),
 367     "\
 368 Make a GDB color object.\n\
 369 \n\
 370   Arguments: [value\n\
 371       [#:color-space <colorspace>]]\n\
 372     value: The name of the color.  It may be string, number with color index\n\
 373       or list with RGB components.\n\
 374     colorspace: The color space of the color, one of COLORSPACE_*." },
 375
 376   { "color?", 1, 0, 0, as_a_scm_t_subr (gdbscm_color_p),
 377     "\
 378 Return #t if the object is a <gdb:color> object." },
 379
 380   { "color-none?", 1, 0, 0, as_a_scm_t_subr (gdbscm_color_none_p),
 381     "\
 382 Return #t if the <gdb:color> object has default color." },
 383
 384   { "color-indexed?", 1, 0, 0, as_a_scm_t_subr (gdbscm_color_indexed_p),
 385     "\
 386 Return #t if the <gdb:color> object is from indexed color space." },
 387
 388   { "color-direct?", 1, 0, 0, as_a_scm_t_subr (gdbscm_color_direct_p),
 389     "\
 390 Return #t if the <gdb:color> object has direct color (e.g. RGB, CMY, CMYK)." },
 391
 392   { "color-string", 1, 0, 0, as_a_scm_t_subr (gdbscm_color_string),
 393     "\
 394 Return the textual representation of a <gdb:color> object." },
 395
 396   { "color-colorspace", 1, 0, 0, as_a_scm_t_subr (gdbscm_color_colorspace),
 397     "\
 398 Return the color space of a <gdb:color> object." },
 399
 400   { "color-index", 1, 0, 0, as_a_scm_t_subr (gdbscm_color_index),
 401     "\
 402 Return index of the color of a <gdb:color> object in a palette." },
 403
 404   { "color-components", 1, 0, 0, as_a_scm_t_subr (gdbscm_color_components),
 405     "\
 406 Return components of the direct <gdb:color> object." },
 407
 408   { "color-escape-sequence", 2, 0, 0,
 409     as_a_scm_t_subr (gdbscm_color_escape_sequence),
 410     "\
 411 Return string to change terminal's color to this." },
 412
 413   END_FUNCTIONS
 414 };
 415
 416 void
 417 gdbscm_initialize_colors (void)
 418 {
 419   color_smob_tag = gdbscm_make_smob_type (color_smob_name, sizeof (color_smob));
 420   scm_set_smob_free (color_smob_tag, coscm_free_color_smob);
 421   scm_set_smob_print (color_smob_tag, coscm_print_color_smob);
 422
 423   gdbscm_define_integer_constants (colorspaces, 1);
 424   gdbscm_define_functions (color_functions, 1);
 425
 426   colorspace_keyword = scm_from_latin1_keyword ("color-space");
 427 }