diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi
index e53f0e9f60..2a24576620 100644
--- a/doc/lispref/display.texi
+++ b/doc/lispref/display.texi
@@ -27,6 +27,7 @@ Display
* Window Dividers:: Separating windows visually.
* Display Property:: Images, margins, text size, etc.
* Images:: Displaying images in Emacs buffers.
+* Canvases:: Drawing areas inside Emacs buffers.
* Xwidgets:: Displaying native widgets in Emacs buffers.
* Buttons:: Adding clickable buttons to Emacs buffers.
* Abstract Display:: Emacs's Widget for Object Collections.
@@ -6509,6 +6510,152 @@ Image Cache
debugging.
@end defvar
+@node Canvases
+@cindex drawing canvases
+@cindex drawing areas
+@cindex canvases
+@section Canvases
+
+This chapter describes canvases, objects that can store drawing operations
+which are then displayed inside buffer text.
+
+@menu
+* Creating Canvases:: How canvases can be created
+* Operating on Canvases:: How canvases can be used
+* Displaying Canvases:: How canvases can be displayed
+@end menu
+
+@node Creating Canvases
+@cindex creating Canvases
+@pindex make-canvas
+
+ This section describes how canvases can be created.
+To create a canvas, call the function @code{make-canvas}.
+
+@defun make-canvas width height
+This function takes 2 arguments @code{width}, and @code{height},
+and creates a canvas @code{width} wide and @code{height} tall.
+@end defun
+
+@defun canvas-from-image image &optional width height
+This function creates a canvas from the image descriptor
+@code{image}. The created canvas will be @code{width} wide,
+and @code{height} tall, if specified.
+@end defun
+
+@node Operating on Canvases
+@cindex operating on Canvases
+@pindex canvas-rectangle
+
+ This section describes how canvases can be drawn to,
+and manipulated.
+
+@defun canvasp canvas
+Return whether @code{canvas} is a canvas or not.
+@end defun
+
+@defun canvas-dimensions canvas
+Return the dimensions of @code{canvas} as a pair.
+@end defun
+
+@defun canvas-ellipse canvas x y width height &optional color
+ hollow opacity
+Draw an ellipse centred upon @code{x}, @code{y} onto the canvas
+@code{canvas}. The drawn ellipse will be colored @code{color},
+or the current frame's foreground color if @code{color} is not
+specified or nil. The opacity of the drawn item will be
+@code{opacity}, and the item will be hollow if @code{hollow} is
+non-nil.
+@end defun
+
+@defun canvas-rectangle canvas x y width height &optional color
+ hollow opacity
+Draw a rectangle at @code{x}, and @code{y} onto the canvas
+@code{canvas}. The rectangle will be colored @code{color},
+or the current frame's foreground color if @code{color} is nil.
+The opacity of the drawn item will be @code{opacity}, and the item
+will be hollow if @code{hollow} is non-nil.
+@end defun
+
+@defun canvas-fill-pixel canvas x y color opacity
+Fill the pixel at @code{x}, @code{y} inside @code{canvas}
+to @code{color}, with the opacity @code{opacity}.
+@end defun
+
+@defun canvas-draw-string canvas x y string
+ &optional color opacity family size
+Draw the string @code{string} to @code{x}, @code{y}
+inside the canvas @code{canvas}. The font family used
+will be @code{family}, the color @code{color}, the opacity
+@code{opacity}, and the size @code{size}.
+
+@code{family} can either be a string, or a list in which
+the first element should be the family as a string, the
+second element should be whether the font should be italic,
+and an optional third argument describing whether or not
+the font should be bold.
+@end defun
+
+@defun canvas-draw-image canvas image-spec x y
+ &optional width height frame opacity
+Paint @code{image-spec} into @code{canvas} at @code{x},
+@code{y}. If @code{width} or @code{height}
+is set and the image is wider than @code{width} or @code{height} respectively,
+the image will be cropped to fit. The alpha channel of @code{image-spec}
+will be set to @code{opacity}.
+@end defun
+
+@defun canvas-measure-string canvas string &optional family size
+Return a cons pair containing the width and height of @code{string},
+when rendered onto @code{canvas}, with the font @code{family} at
+@code{size}.
+@end defun
+
+@defun canvas-rounded-rectangle canvas x y width height radius
+ &optional color hollow opacity
+Draw a rounded rectangle at @code{x}, @code{y} onto @code{canvas}.
+The opacity of the rectangle will be @code{opacity}.
+The radius of the rectangle will be @code{radius}.
+@end defun
+
+@defun canvas-pixel-at canvas x y
+Return the pixel at @code{x}, @code{y} inside @code{canvas},
+as an ARGB list.
+@end defun
+
+@defun canvas-draw-canvas canvas canvas2 x y &optional width height opacity
+Draw @code{canvas2} onto @code{canvas} at @code{x}, @code{y}.
+@code{canvas2}'s alpha channel will be set to @code{opacity},
+if specified.
+@code{canvas2} will not be taller than @code{height} or wider than
+@code{width}, if specified.
+@end defun
+
+@defun canvas-width canvas
+Return the width of @code{canvas}.
+@end defun
+
+@defun canvas-height canvas
+Return the height of @code{canvas}.
+@end defun
+
+@defun canvas-region canvas x y width height
+Return a subsection of @code{canvas} at @code{x},
+@code{y}, that is @code{width} wide and @code{height} tall.
+@end defun
+
+@defun canvas-arc canvas x y radius angle1 angle2 &optional color opacity
+Draw an arc at @code{x}, @code{y}, with a radius of @code{radius},
+and the angles @code{angle1}, @code{angle2}.
+@end defun
+
+@node Displaying Canvases
+@cindex displaying Canvases
+
+ Canvases can be displayed by setting them as the
+@code{display} property of a string.
+
+
@node Xwidgets
@section Embedded Native Widgets
@cindex xwidget
diff --git a/doc/lispref/elisp.texi b/doc/lispref/elisp.texi
index bba1b63115..d995ec4606 100644
--- a/doc/lispref/elisp.texi
+++ b/doc/lispref/elisp.texi
@@ -1430,6 +1430,7 @@ Top
* Window Dividers:: Separating windows visually.
* Display Property:: Enabling special display features.
* Images:: Displaying images in Emacs buffers.
+* Canvases:: Drawing areas inside Emacs buffers.
* Buttons:: Adding clickable buttons to Emacs buffers.
* Abstract Display:: Emacs's Widget for Object Collections.
* Blinking:: How Emacs shows the matching open parenthesis.
diff --git a/lisp/canvas.el b/lisp/canvas.el
new file mode 100644
index 0000000000..d60d3efa4f
--- /dev/null
+++ b/lisp/canvas.el
@@ -0,0 +1,49 @@
+;;; canvas.el --- Canvas support for GNU Emacs
+
+;; Copyright (C) 2020 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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.
+
+;; GNU Emacs 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 GNU Emacs. If not, see .
+
+;;; Commentary:
+
+;;; These are several utlity functions for canvas operations that can
+;;; be implemented in Lisp code.
+
+
+;;; Code:
+
+(defun canvas-fill-pixel (canvas x y color opacity)
+ "Set the pixel at X, Y inside CANVAS to COLOR, with the opacity OPACITY."
+ (canvas-rectangle canvas x y 1 1 color opacity))
+
+(defun canvas-from-image (image &optional width height)
+ "Create a canvas from IMAGE.
+The canvas will be no wider than WIDTH (if specified),
+and no taller than HEIGHT (if specified)."
+ (let ((canvas (make-canvas (or width (car (image-size image t)))
+ (or height (cdr (image-size image t))))))
+ (prog1 canvas (canvas-draw-image canvas image 0 0))))
+
+(defun canvas-width (canvas)
+ "Return the width of CANVAS."
+ (car (canvas-dimensions canvas)))
+
+(defun canvas-height (canvas)
+ "Return the height of CANVAS."
+ (cdr (canvas-dimensions canvas)))
+
+(provide 'canvas)
+;;; canvas.el ends here
diff --git a/lisp/loadup.el b/lisp/loadup.el
index 97525b2708..1a9b1c7410 100644
--- a/lisp/loadup.el
+++ b/lisp/loadup.el
@@ -285,6 +285,8 @@
(load "emacs-lisp/tabulated-list")
(load "buff-menu")
+(load "canvas")
+
(if (fboundp 'x-create-frame)
(progn
(load "fringe")
diff --git a/src/Makefile.in b/src/Makefile.in
index 552dd2e50a..0d70c68b04 100644
--- a/src/Makefile.in
+++ b/src/Makefile.in
@@ -407,6 +407,7 @@ .m.o:
## be dumped as pure by dump-emacs.
base_obj = dispnew.o frame.o scroll.o xdisp.o menu.o $(XMENU_OBJ) window.o \
charset.o coding.o category.o ccl.o character.o chartab.o bidi.o \
+ common-canvas.o \
$(CM_OBJ) term.o terminal.o xfaces.o $(XOBJ) $(GTK_OBJ) $(DBUS_OBJ) \
emacs.o keyboard.o macros.o keymap.o sysdep.o \
bignum.o buffer.o filelock.o insdel.o marker.o \
diff --git a/src/alloc.c b/src/alloc.c
index cc9ba8dbf5..acce0109e1 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -47,6 +47,7 @@ Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2020 Free Software
#include "blockinput.h"
#include "pdumper.h"
#include "termhooks.h" /* For struct terminal. */
+#include "canvas.h"
#ifdef HAVE_WINDOW_SYSTEM
#include TERM_HEADER
#endif /* HAVE_WINDOW_SYSTEM */
@@ -3114,6 +3115,11 @@ cleanup_vector (struct Lisp_Vector *vector)
module_finalize_function (function);
}
#endif
+ else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_CANVAS))
+ {
+ struct canvas *cnvs = (struct canvas *) vector;
+ destroy_canvas_contents (cnvs->canvas);
+ }
}
/* Reclaim space used by unmarked vectors. */
diff --git a/src/canvas.h b/src/canvas.h
new file mode 100644
index 0000000000..036f2bf499
--- /dev/null
+++ b/src/canvas.h
@@ -0,0 +1,83 @@
+/* Canvas support for GNU Emacs.
+ Copyright (C) 2020 Free Software Foundation, Inc.
+
+This file is part of GNU Emacs.
+
+GNU Emacs 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.
+
+GNU Emacs 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 GNU Emacs. If not, see . */
+
+#include
+
+#include "lisp.h"
+#include "frame.h"
+#include "window.h"
+
+#ifdef USE_CAIRO
+#include
+typedef cairo_surface_t *canvas_contents_t;
+#else
+typedef void *canvas_contents_t;
+#endif
+
+struct canvas
+{
+ union vectorlike_header header;
+ Lisp_Object cnvs_objects;
+ Lisp_Object window;
+ Lisp_Object object;
+
+ canvas_contents_t canvas;
+ int width, height;
+ bool multiple_objects_seen;
+ bool changed_since_last_redisplay;
+} GCALIGNED_STRUCT;
+
+/* Test for canvas pseudovector. */
+#define CANVASP(x) PSEUDOVECTORP (x, PVEC_CANVAS)
+#define XCANVAS(a) \
+ (eassert (CANVASP (a)), XUNTAG (a, Lisp_Vectorlike, struct canvas))
+
+#define CHECK_CANVAS(x) CHECK_TYPE (CANVASP (x), Qcanvasp, x)
+
+#define MARK_CANVAS_CHANGED(x) \
+ (((x)->changed_since_last_redisplay = true), \
+ (windows_or_buffers_changed = 2), (redisplay ())); \
+ do \
+ { \
+ if ((x)->multiple_objects_seen || !EQ (selected_window, (x)->window)) \
+ { \
+ Lisp_Object tail, head; \
+ FOR_EACH_FRAME (tail, head) \
+ { \
+ struct frame *f = XFRAME (head); \
+ SET_FRAME_GARBAGED (f); \
+ } \
+ } \
+ } \
+ while (false)
+
+extern Lisp_Object
+make_canvas (int width, int height);
+
+extern canvas_contents_t
+make_canvas_contents (int width, int height);
+
+extern void
+destroy_canvas_contents (canvas_contents_t contents);
+
+extern void
+syms_of_canvas (void);
+
+extern void
+canvas_end_redisplay (struct window *w,
+ struct glyph_matrix *matrix);
diff --git a/src/common-canvas.c b/src/common-canvas.c
new file mode 100644
index 0000000000..329c37daad
--- /dev/null
+++ b/src/common-canvas.c
@@ -0,0 +1,868 @@
+/* Canvas support for GNU Emacs.
+ Copyright (C) 2020 Free Software Foundation, Inc.
+
+This file is part of GNU Emacs.
+
+GNU Emacs 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.
+
+GNU Emacs 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 GNU Emacs. If not, see . */
+
+#include "canvas.h"
+#include "coding.h"
+
+#include
+
+Lisp_Object
+make_canvas (int width, int height)
+{
+#ifndef USE_CAIRO
+ error ("Canvases are not supported without cairo.")
+#endif
+ struct canvas *canvas = ALLOCATE_PSEUDOVECTOR
+ (struct canvas, object, PVEC_CANVAS);
+ canvas->width = width;
+ canvas->height = height;
+ canvas->object = Qnil;
+ canvas->multiple_objects_seen = false;
+ canvas->canvas = make_canvas_contents (width, height);
+ canvas->changed_since_last_redisplay = true;
+
+ Lisp_Object cnvs;
+ XSETCANVAS (cnvs, canvas);
+ return cnvs;
+}
+
+void
+destroy_canvas_contents (canvas_contents_t contents)
+{
+#ifdef USE_CAIRO
+ cairo_surface_destroy (contents);
+#else
+ error ("Not implemented");
+#endif
+}
+
+canvas_contents_t
+make_canvas_contents (int width, int height)
+{
+#ifdef USE_CAIRO
+ cairo_surface_t *crs =
+ cairo_image_surface_create (CAIRO_FORMAT_ARGB32, width, height);
+ return crs;
+#else
+ error ("Not implemented");
+#endif
+}
+
+void
+canvas_end_redisplay (struct window *w,
+ struct glyph_matrix *matrix)
+{
+ int i;
+ int area;
+
+ struct canvas **unmark_canvases;
+ ptrdiff_t unmark_size = 0;
+ unmark_canvases = xmalloc (sizeof *unmark_canvases * unmark_size);
+
+ for (i = 0; i < matrix->nrows; ++i)
+ {
+ struct glyph_row *row;
+ row = MATRIX_ROW (matrix, i);
+ if (row->enabled_p)
+ for (area = LEFT_MARGIN_AREA; area < LAST_AREA; ++area)
+ {
+ struct glyph *glyph = row->glyphs[area];
+ struct glyph *glyph_end = glyph + row->used[area];
+ for (; glyph < glyph_end; ++glyph)
+ if (glyph->type == CANVAS_GLYPH &&
+ glyph->u.canvas->changed_since_last_redisplay)
+ {
+ ++unmark_size;
+ unmark_canvases
+ = xrealloc (unmark_canvases,
+ (sizeof *unmark_canvases * unmark_size));
+ unmark_canvases[unmark_size - 1] = glyph->u.canvas;
+ canvas_update_glyph
+ (w, i, row, area, row->glyphs[area] -
+ glyph, 1 + row->glyphs[area] - glyph,
+ glyph);
+ }
+ }
+ }
+ for (; unmark_size; unmark_size--)
+ unmark_canvases[unmark_size - 1]->changed_since_last_redisplay = false;
+ xfree (unmark_canvases);
+}
+
+DEFUN ("make-canvas", Fmake_canvas, Smake_canvas, 2, 2, 0,
+ doc: /* Create a canvas, WIDTH pixels wide, and HEIGHT pixels tall. */)
+ (Lisp_Object width, Lisp_Object height)
+{
+ check_integer_range (height, 0, INT_MAX);
+ check_integer_range (width, 0, INT_MAX);
+
+ return make_canvas (XFIXNUM (width), XFIXNUM (height));
+}
+
+DEFUN ("canvas-ellipse", Fcanvas_ellipse, Scanvas_ellipse, 5, 8, 0,
+ doc: /* Draw a WIDTH wide and HEIGHT tall ellipse centred at X, Y in CANVAS.
+The color of the ellipse will be COLOR (or the foreground color of COLOR is nil).
+The ellipse will be hollow if HOLLOW is non-nil.
+The opacity of the circle will be OPACITY, which should be a floating-point
+number between 1 and 0. */)
+ (Lisp_Object canvas, Lisp_Object x, Lisp_Object y,
+ Lisp_Object width, Lisp_Object height, Lisp_Object color,
+ Lisp_Object hollow, Lisp_Object opacity)
+{
+ if (NILP (opacity))
+ opacity = make_float (1.0);
+ CHECK_CANVAS (canvas);
+ check_integer_range (x, 0, INT_MAX);
+ check_integer_range (y, 0, INT_MAX);
+ check_integer_range (width, 0, INT_MAX);
+ check_integer_range (height, 0, INT_MAX);
+ CHECK_NUMBER (opacity);
+#ifdef USE_CAIRO
+ if (NILP (color))
+ color = Qunspecified;
+ Lisp_Object color_values = call1 (Qcolor_values, color);
+ if (!NILP (color_values))
+ CHECK_LIST (color_values);
+ double r, g, b;
+ if (NILP (color_values))
+ {
+ Emacs_Color col;
+ col.pixel = FRAME_FOREGROUND_PIXEL (XFRAME (selected_frame));
+ FRAME_TERMINAL (XFRAME (selected_frame))->query_colors
+ (XFRAME (selected_frame), &col, 1);
+ r = col.red / 65535.0;
+ g = col.green / 65535.0;
+ b = col.blue / 65535.0;
+ }
+ else
+ {
+ Lisp_Object lr = Fnth (make_fixnum (0), color_values),
+ lg = Fnth (make_fixnum (1), color_values),
+ lb = Fnth (make_fixnum (2), color_values);
+
+ check_integer_range (lr, 0, 65535);
+ check_integer_range (lg, 0, 65535);
+ check_integer_range (lb, 0, 65535);
+
+ r = XFIXNUM (lr) / 65535.0;
+ g = XFIXNUM (lg) / 65535.0;
+ b = XFIXNUM (lb) / 65535.0;
+ }
+ struct canvas *cv = XCANVAS (canvas);
+ cairo_t *cr = cairo_create (cv->canvas);
+ cairo_set_source_rgba (cr, r, g, b, XFLOATINT (opacity));
+ cairo_matrix_t save_matrix;
+ cairo_get_matrix (cr, &save_matrix);
+ cairo_translate (cr, XFIXNUM (x), XFIXNUM (y));
+ cairo_scale (cr, 1, 1);
+ cairo_new_path (cr);
+ cairo_arc (cr, 0, 0,
+ XFIXNUM (width) / 2.0, 0, 2 * M_PI);
+ cairo_set_matrix (cr, &save_matrix);
+
+ cairo_set_line_width (cr, canvas_stroke_width);
+ if (!NILP (hollow))
+ cairo_stroke (cr);
+ else
+ cairo_fill (cr);
+
+ cairo_destroy (cr);
+ MARK_CANVAS_CHANGED (cv);
+#endif
+ return Qnil;
+}
+
+DEFUN ("canvasp", Fcanvasp, Scanvasp, 1, 1, 0,
+ doc: /* Return t if CANVAS is a canvas, else nil. */)
+ (Lisp_Object canvas)
+{
+ return CANVASP (canvas) ? Qt : Qnil;
+}
+
+DEFUN ("canvas-rectangle", Fcanvas_rectangle, Scanvas_rectangle, 5, 8, 0,
+ doc: /* Draw a WIDTH wide and HEIGHT tall rectangle at X, Y in CANVAS.
+The color of the rectangle will be COLOR (or the foreground color of COLOR is nil).
+The rectangle will be hollow if HOLLOW is non-nil.
+The opacity of the circle will be OPACITY, which should be a floating-point
+number between 1 and 0. */)
+ (Lisp_Object canvas, Lisp_Object x, Lisp_Object y,
+ Lisp_Object width, Lisp_Object height, Lisp_Object color,
+ Lisp_Object hollow, Lisp_Object opacity)
+{
+ if (NILP (opacity))
+ opacity = make_float (1.0);
+ CHECK_CANVAS (canvas);
+ check_integer_range (x, 0, INT_MAX);
+ check_integer_range (y, 0, INT_MAX);
+ check_integer_range (width, 0, INT_MAX);
+ check_integer_range (height, 0, INT_MAX);
+ CHECK_NUMBER (opacity);
+#ifdef USE_CAIRO
+ if (NILP (color))
+ color = Qunspecified;
+ Lisp_Object color_values = call1 (Qcolor_values, color);
+ if (!NILP (color_values))
+ CHECK_LIST (color_values);
+ double r, g, b;
+ if (NILP (color_values))
+ {
+ Emacs_Color col;
+ col.pixel = FRAME_FOREGROUND_PIXEL (XFRAME (selected_frame));
+ FRAME_TERMINAL (XFRAME (selected_frame))->query_colors
+ (XFRAME (selected_frame), &col, 1);
+ r = col.red / 65535.0;
+ g = col.green / 65535.0;
+ b = col.blue / 65535.0;
+ }
+ else
+ {
+ Lisp_Object lr = Fnth (make_fixnum (0), color_values),
+ lg = Fnth (make_fixnum (1), color_values),
+ lb = Fnth (make_fixnum (2), color_values);
+
+ check_integer_range (lr, 0, 65535);
+ check_integer_range (lg, 0, 65535);
+ check_integer_range (lb, 0, 65535);
+
+ r = XFIXNUM (lr) / 65535.0;
+ g = XFIXNUM (lg) / 65535.0;
+ b = XFIXNUM (lb) / 65535.0;
+ }
+ struct canvas *cv = XCANVAS (canvas);
+ cairo_t *cr = cairo_create (cv->canvas);
+ cairo_set_source_rgba (cr, r, g, b, XFLOATINT (opacity));
+ if (NILP (hollow))
+ {
+ cairo_rectangle (cr, XFIXNUM (x), XFIXNUM (y), XFIXNUM (width),
+ XFIXNUM (height));
+ cairo_fill (cr);
+ }
+ else
+ {
+ cairo_rectangle (cr, XFIXNUM (x), XFIXNUM (y), XFIXNUM (width),
+ XFIXNUM (height));
+ cairo_stroke (cr);
+ }
+ cairo_destroy (cr);
+ MARK_CANVAS_CHANGED (cv);
+ return Qnil;
+#else
+ error ("Not implemented");
+#endif
+}
+
+DEFUN ("canvas-rounded-rectangle", Fcanvas_rounded_rectangle, Scanvas_rounded_rectangle, 6, MANY, 0,
+ doc: /* Draw a WIDTH wide and HEIGHT tall rectangle at X, Y in CANVAS.
+The color of the rectangle will be COLOR (or the foreground color of COLOR is nil).
+The rectangle will be hollow if HOLLOW is non-nil.
+The opacity of the circle will be OPACITY, which should be a floating-point
+number between 1 and 0.
+usage: (canvas-rounded-rectangle canvas x y width height radius &optional color hollow opacity) */)
+ (ptrdiff_t nargs, Lisp_Object *args)
+{
+ Lisp_Object canvas, x, y, width, height, radius, color, hollow, opacity;
+ canvas = args[0];
+ x = args[1];
+ y = args[2];
+ width = args[3];
+ height = args[4];
+ radius = args[5];
+ color = Qnil;
+ hollow = Qnil;
+ opacity = Qnil;
+
+ if (nargs > 6)
+ color = args[6];
+ if (nargs > 7)
+ hollow = args[7];
+ if (nargs > 8)
+ opacity = args[8];
+ if (nargs > 9)
+ xsignal2 (Qwrong_number_of_arguments,
+ Qcanvas_rounded_rectangle,
+ make_fixnum (nargs));
+ if (NILP (opacity))
+ opacity = make_float (1.0);
+ CHECK_CANVAS (canvas);
+ check_integer_range (x, 0, INT_MAX);
+ check_integer_range (y, 0, INT_MAX);
+ check_integer_range (width, 0, INT_MAX);
+ check_integer_range (height, 0, INT_MAX);
+ CHECK_NUMBER (opacity);
+#ifdef USE_CAIRO
+ if (NILP (color))
+ color = Qunspecified;
+ Lisp_Object color_values = call1 (Qcolor_values, color);
+ if (!NILP (color_values))
+ CHECK_LIST (color_values);
+ double r, g, b;
+ if (NILP (color_values))
+ {
+ Emacs_Color col;
+ col.pixel = FRAME_FOREGROUND_PIXEL (XFRAME (selected_frame));
+ FRAME_TERMINAL (XFRAME (selected_frame))->query_colors
+ (XFRAME (selected_frame), &col, 1);
+ r = col.red / 65535.0;
+ g = col.green / 65535.0;
+ b = col.blue / 65535.0;
+ }
+ else
+ {
+ Lisp_Object lr = Fnth (make_fixnum (0), color_values),
+ lg = Fnth (make_fixnum (1), color_values),
+ lb = Fnth (make_fixnum (2), color_values);
+
+ check_integer_range (lr, 0, 65535);
+ check_integer_range (lg, 0, 65535);
+ check_integer_range (lb, 0, 65535);
+
+ r = XFIXNUM (lr) / 65535.0;
+ g = XFIXNUM (lg) / 65535.0;
+ b = XFIXNUM (lb) / 65535.0;
+ }
+ struct canvas *cv = XCANVAS (canvas);
+ cairo_t *cr = cairo_create (cv->canvas);
+ cairo_set_source_rgba (cr, r, g, b, XFLOATINT (opacity));
+ {
+#define radius XFLOATINT (radius)
+ double degrees = M_PI / 180.0;
+#define width XFIXNUM (width)
+#define height XFIXNUM (height)
+#define x XFIXNUM (x)
+#define y XFIXNUM (y)
+ cairo_new_sub_path (cr);
+ cairo_arc (cr, x + width - radius, y + radius, radius, -90 * degrees, 0 * degrees);
+ cairo_arc (cr, x + width - radius, y + height - radius, radius, 0 * degrees, 90 * degrees);
+ cairo_arc (cr, x + radius, y + height - radius, radius, 90 * degrees, 180 * degrees);
+ cairo_arc (cr, x + radius, y + radius, radius, 180 * degrees, 270 * degrees);
+ cairo_close_path (cr);
+#undef radius
+#undef y
+#undef x
+#undef height
+#undef width
+ }
+#undef radius
+ cairo_set_line_width (cr, canvas_stroke_width);
+ if (NILP (hollow))
+ cairo_fill (cr);
+ else
+ cairo_stroke (cr);
+ cairo_destroy (cr);
+ MARK_CANVAS_CHANGED (cv);
+ return Qnil;
+#else
+ error ("Not implemented");
+#endif
+}
+
+DEFUN ("canvas-draw-string", Fcanvas_draw_string, Scanvas_draw_string, 4, 8, 0,
+ doc: /* Draw the string STRING onto the canvas CANVAS at X, Y.
+The opacity of the drawn text will be OPACITY, and the color of the drawn text will be COLOR.
+The font-family used will be FAMILY, which can be a string or a list of
+the font-family as a string, whether or not the the text should be italic,
+and whether or not the text should be bold.
+The size of the text will be SIZE, or the default text size if nil. */)
+ (Lisp_Object canvas, Lisp_Object x, Lisp_Object y, Lisp_Object string,
+ Lisp_Object color, Lisp_Object opacity, Lisp_Object family, Lisp_Object size)
+{
+ if (noninteractive)
+ error ("`canvas-draw-string' cannot be called when running in batch mode.");
+ if (NILP (opacity))
+ opacity = make_float (1.0);
+ if (NILP (size))
+ size = make_fixnum (FRAME_TEXT_HEIGHT (XFRAME (selected_frame)));
+ if (NILP (family))
+ family = build_string ("monospace");
+ CHECK_CANVAS (canvas);
+ check_integer_range (x, 0, INT_MAX);
+ check_integer_range (y, 0, INT_MAX);
+ CHECK_NUMBER (opacity);
+ if (!Flistp (family))
+ CHECK_STRING (family);
+ CHECK_STRING (string);
+#ifdef USE_CAIRO
+ if (NILP (color))
+ color = Qunspecified;
+ Lisp_Object color_values = call1 (Qcolor_values, color);
+ if (!NILP (color_values))
+ CHECK_LIST (color_values);
+ double r, g, b;
+ if (NILP (color_values))
+ {
+ Emacs_Color col;
+ col.pixel = FRAME_FOREGROUND_PIXEL (XFRAME (selected_frame));
+ FRAME_TERMINAL (XFRAME (selected_frame))->query_colors
+ (XFRAME (selected_frame), &col, 1);
+ r = col.red / 65535.0;
+ g = col.green / 65535.0;
+ b = col.blue / 65535.0;
+ }
+ else
+ {
+ Lisp_Object lr = Fnth (make_fixnum (0), color_values),
+ lg = Fnth (make_fixnum (1), color_values),
+ lb = Fnth (make_fixnum (2), color_values);
+
+ check_integer_range (lr, 0, 65535);
+ check_integer_range (lg, 0, 65535);
+ check_integer_range (lb, 0, 65535);
+
+ r = XFIXNUM (lr) / 65535.0;
+ g = XFIXNUM (lg) / 65535.0;
+ b = XFIXNUM (lb) / 65535.0;
+ }
+ struct canvas *c = XCANVAS (canvas);
+ cairo_t *cr = cairo_create (c->canvas);
+ cairo_font_slant_t slant_flags = CAIRO_FONT_SLANT_NORMAL;
+ cairo_font_weight_t weight_flags = CAIRO_FONT_WEIGHT_NORMAL;
+ const char *family_utf8;
+ if (!NILP (Flistp (family)))
+ {
+ if (!NILP (CALLN (Flss, Flength (family), make_fixnum (2))))
+ error ("Invalid font spec");
+ else
+ {
+ int length = XFIXNUM (Flength (family));
+ if (length > 3)
+ error ("Invalid font spec");
+ Lisp_Object italic, bold;
+ CHECK_STRING_CAR (family);
+ family_utf8 = SSDATA (ENCODE_UTF_8 (XCAR (family)));
+ if (length == 3)
+ bold = XCAR (XCDR (XCDR (family)));
+ else
+ bold = Qnil;
+ italic = XCAR (XCDR (family));
+ if (!NILP (italic))
+ slant_flags = CAIRO_FONT_SLANT_ITALIC;
+ if (!NILP (bold))
+ weight_flags = CAIRO_FONT_WEIGHT_BOLD;
+ }
+ }
+ else
+ {
+ family_utf8 = SSDATA (ENCODE_UTF_8 (family));
+ }
+ cairo_set_source_rgba (cr, r, g, b, XFLOATINT (opacity));
+ cairo_select_font_face (cr, family_utf8,
+ slant_flags,
+ weight_flags);
+ cairo_set_font_size (cr, XFIXNUM (size));
+ cairo_move_to (cr, XFIXNUM (x), XFIXNUM (y) + XFIXNUM (size));
+ cairo_show_text (cr, SSDATA (ENCODE_UTF_8 (string)));
+ cairo_destroy (cr);
+ MARK_CANVAS_CHANGED (c);
+ return Qnil;
+#else
+ return Qnil;
+#endif
+}
+
+DEFUN ("canvas-measure-string", Fcanvas_measure_string, Scanvas_measure_string, 2, 4, 0,
+ doc: /* Return a pair containing the width and height of STRING,
+if drawn on CANVAS with the family FAMILY at SIZE. */)
+(Lisp_Object canvas, Lisp_Object string, Lisp_Object family, Lisp_Object size)
+{
+ if (noninteractive)
+ error ("`canvas-draw-string' cannot be called when running in batch mode.");
+ if (NILP (size))
+ size = make_fixnum (FRAME_TEXT_HEIGHT (XFRAME (selected_frame)));
+ if (NILP (family))
+ family = build_string ("cairo:monospace");
+ CHECK_CANVAS (canvas);
+
+ if (!Flistp (family))
+ CHECK_STRING (family);
+ CHECK_STRING (string);
+#ifdef USE_CAIRO
+ struct canvas *c = XCANVAS (canvas);
+ cairo_t *cr = cairo_create (c->canvas);
+ cairo_font_slant_t slant_flags = CAIRO_FONT_SLANT_NORMAL;
+ cairo_font_weight_t weight_flags = CAIRO_FONT_WEIGHT_NORMAL;
+ const char *family_utf8;
+ if (!NILP (Flistp (family)))
+ {
+ if (!NILP (CALLN (Flss, Flength (family), make_fixnum (2))))
+ error ("Invalid font spec");
+ else
+ {
+ int length = XFIXNUM (Flength (family));
+ if (length > 3)
+ error ("Invalid font spec");
+ Lisp_Object italic, bold;
+ CHECK_STRING_CAR (family);
+ family_utf8 = SSDATA (ENCODE_UTF_8 (XCAR (family)));
+ if (length == 3)
+ bold = XCAR (XCDR (XCDR (family)));
+ else
+ bold = Qnil;
+ italic = XCAR (XCDR (family));
+ if (!NILP (italic))
+ slant_flags = CAIRO_FONT_SLANT_ITALIC;
+ if (!NILP (bold))
+ weight_flags = CAIRO_FONT_WEIGHT_BOLD;
+ }
+ }
+ else
+ {
+ family_utf8 = SSDATA (ENCODE_UTF_8 (family));
+ }
+ cairo_select_font_face (cr, family_utf8,
+ slant_flags,
+ weight_flags);
+ cairo_set_font_size (cr, XFIXNUM (size));
+ cairo_text_extents_t extents;
+ cairo_text_extents (cr, SSDATA (ENCODE_UTF_8 (string)), &extents);
+ cairo_destroy (cr);
+ return Fcons (make_fixnum (extents.width),
+ make_fixnum (extents.height));
+#else
+ return Qnil;
+#endif
+}
+
+DEFUN ("canvas-draw-image", Fcanvas_draw_image, Scanvas_draw_image, 4, 8,
+ 0, doc: /* Paint IMAGE_SPEC onto CANVAS, at X, Y.
+If WIDTH or HEIGHT is set, and IMAGE is wider than WIDTH or taller than HEIGHT,
+IMAGE_SPEC will be cropped to fit WIDTH and/or HEIGHT respectively.
+FRAME should be a live frame.
+The opacity of the drawn image will be OPACITY. */)
+ (Lisp_Object canvas, Lisp_Object image_spec,
+ Lisp_Object x, Lisp_Object y,
+ Lisp_Object width, Lisp_Object height,
+ Lisp_Object frame, Lisp_Object opacity)
+{
+ if (valid_image_p (image_spec))
+ {
+ if (NILP (frame))
+ frame = selected_frame;
+ struct frame *f = decode_window_system_frame (frame);
+ ptrdiff_t id = lookup_image (f, image_spec);
+ struct image *img = IMAGE_FROM_ID (f, id);
+ if (!img)
+ return Qnil;
+ if (img->load_failed_p)
+ return Qnil;
+ int iwidth = img->width + 2 * img->hmargin;
+ int iheight = img->height + 2 * img->vmargin;
+ CHECK_CANVAS (canvas);
+ check_integer_range (x, 0, INT_MAX);
+ check_integer_range (y, 0, INT_MAX);
+ if (NILP (width))
+ width = make_fixnum (iwidth);
+ check_integer_range (width, 0, INT_MAX);
+ if (NILP (height))
+ height = make_fixnum (iheight);
+ check_integer_range (height, 0, INT_MAX);
+ if (NILP (width))
+ width = make_fixnum (iwidth);
+ if (NILP (opacity))
+ opacity = make_fixnum (1);
+ CHECK_NUMBER (opacity);
+#ifdef USE_CAIRO
+ cairo_surface_t *crs
+ = cairo_image_surface_create_for_data ((unsigned char *)
+ img->pixmap->data,
+ (img->pixmap->bits_per_pixel
+ == 32
+ ? CAIRO_FORMAT_RGB24
+ : CAIRO_FORMAT_A8),
+ img->pixmap->width,
+ img->pixmap->height,
+ img->pixmap->bytes_per_line);
+ struct canvas *cv = XCANVAS (canvas);
+ cairo_t *cr = cairo_create (cv->canvas);
+ cairo_save (cr);
+ cairo_translate (cr, XFIXNUM (x), XFIXNUM (y));
+ cairo_rectangle (cr, 0, 0,
+ XFIXNUM (width), XFIXNUM (height));
+ cairo_clip (cr);
+ cairo_set_source_surface (cr, crs, 0, 0);
+ cairo_paint_with_alpha (cr, XFLOATINT (opacity));
+ cairo_restore (cr);
+ cairo_destroy (cr);
+ cairo_surface_destroy (crs);
+ MARK_CANVAS_CHANGED (cv);
+#endif
+ }
+ else
+ error ("Invalid image specification");
+ return Qnil;
+}
+
+DEFUN ("canvas-arc", Fcanvas_arc, Scanvas_arc, 6, 8, 0,
+ doc: /* Draw an arc on CANVAS starting from XC, YC,
+with a radius of RADIUS and 2 angles angle1 and angle2.
+Use the color COLOR with the alpha channel set to OPACITY, if specified. */)
+ (Lisp_Object canvas, Lisp_Object x, Lisp_Object y, Lisp_Object radius,
+ Lisp_Object angle1, Lisp_Object angle2, Lisp_Object color, Lisp_Object opacity)
+{
+ CHECK_CANVAS (canvas);
+ check_integer_range (x, 0, INT_MAX);
+ check_integer_range (y, 0, INT_MAX);
+ CHECK_NUMBER (angle1);
+ CHECK_NUMBER (angle2);
+ CHECK_NUMBER (radius);
+
+ if (NILP (opacity))
+ opacity = make_fixnum (1.0);
+ CHECK_NUMBER (opacity);
+
+#ifdef USE_CAIRO
+ if (NILP (color))
+ color = Qunspecified;
+ Lisp_Object color_values = call1 (Qcolor_values, color);
+ if (!NILP (color_values))
+ CHECK_LIST (color_values);
+ double r, g, b;
+ if (NILP (color_values))
+ {
+ Emacs_Color col;
+ col.pixel = FRAME_FOREGROUND_PIXEL (XFRAME (selected_frame));
+ FRAME_TERMINAL (XFRAME (selected_frame))
+ ->query_colors (XFRAME (selected_frame), &col, 1);
+ r = col.red / 65535.0;
+ g = col.green / 65535.0;
+ b = col.blue / 65535.0;
+ }
+ else
+ {
+ Lisp_Object lr = Fnth (make_fixnum (0), color_values),
+ lg = Fnth (make_fixnum (1), color_values),
+ lb = Fnth (make_fixnum (2), color_values);
+
+ check_integer_range (lr, 0, 65535);
+ check_integer_range (lg, 0, 65535);
+ check_integer_range (lb, 0, 65535);
+
+ r = XFIXNUM (lr) / 65535.0;
+ g = XFIXNUM (lg) / 65535.0;
+ b = XFIXNUM (lb) / 65535.0;
+ }
+ cairo_t *cr = cairo_create (XCANVAS (canvas)->canvas);
+ cairo_set_source_rgba (cr, r, g, b, XFLOATINT (opacity));
+ cairo_arc (cr, XFLOATINT (x), XFLOATINT (y), XFLOATINT (radius),
+ XFLOATINT (angle1), XFLOATINT (angle2));
+ cairo_stroke (cr);
+ cairo_destroy (cr);
+ MARK_CANVAS_CHANGED (XCANVAS (canvas));
+#else
+#endif
+ return Qnil;
+}
+
+DEFUN ("canvas-filled-arc", Fcanvas_filled_arc, Scanvas_filled_arc, 6, 8, 0,
+ doc: /* Draw a filled arc on CANVAS starting from XC, YC,
+with a radius of RADIUS and 2 angles angle1 and angle2.
+Use the color COLOR with the alpha channel set to OPACITY, if specified. */)
+ (Lisp_Object canvas, Lisp_Object x, Lisp_Object y, Lisp_Object radius,
+ Lisp_Object angle1, Lisp_Object angle2, Lisp_Object color, Lisp_Object opacity)
+{
+ CHECK_CANVAS (canvas);
+ check_integer_range (x, 0, INT_MAX);
+ check_integer_range (y, 0, INT_MAX);
+ CHECK_NUMBER (angle1);
+ CHECK_NUMBER (angle2);
+ CHECK_NUMBER (radius);
+
+ if (NILP (opacity))
+ opacity = make_fixnum (1.0);
+ CHECK_NUMBER (opacity);
+
+#ifdef USE_CAIRO
+ if (NILP (color))
+ color = Qunspecified;
+ Lisp_Object color_values = call1 (Qcolor_values, color);
+ if (!NILP (color_values))
+ CHECK_LIST (color_values);
+ double r, g, b;
+ if (NILP (color_values))
+ {
+ Emacs_Color col;
+ col.pixel = FRAME_FOREGROUND_PIXEL (XFRAME (selected_frame));
+ FRAME_TERMINAL (XFRAME (selected_frame))
+ ->query_colors (XFRAME (selected_frame), &col, 1);
+ r = col.red / 65535.0;
+ g = col.green / 65535.0;
+ b = col.blue / 65535.0;
+ }
+ else
+ {
+ Lisp_Object lr = Fnth (make_fixnum (0), color_values),
+ lg = Fnth (make_fixnum (1), color_values),
+ lb = Fnth (make_fixnum (2), color_values);
+
+ check_integer_range (lr, 0, 65535);
+ check_integer_range (lg, 0, 65535);
+ check_integer_range (lb, 0, 65535);
+
+ r = XFIXNUM (lr) / 65535.0;
+ g = XFIXNUM (lg) / 65535.0;
+ b = XFIXNUM (lb) / 65535.0;
+ }
+ cairo_t *cr = cairo_create (XCANVAS (canvas)->canvas);
+ cairo_set_source_rgba (cr, r, g, b, XFLOATINT (opacity));
+ cairo_arc (cr, XFLOATINT (x), XFLOATINT (y), XFLOATINT (radius),
+ XFLOATINT (angle1), XFLOATINT (angle2));
+ cairo_fill (cr);
+ cairo_destroy (cr);
+ MARK_CANVAS_CHANGED (XCANVAS (canvas));
+#else
+#endif
+ return Qnil;
+}
+
+DEFUN ("canvas-region", Fcanvas_region, Scanvas_region, 5, 5, 0,
+ doc: /* Return a canvas containing a WIDTH wide and HEIGHT tall
+subsection of CANVAS at X, Y */)
+ (Lisp_Object canvas, Lisp_Object x,
+ Lisp_Object y, Lisp_Object width, Lisp_Object height)
+{
+ CHECK_CANVAS (canvas);
+ check_integer_range (x, 0, INT_MAX);
+ check_integer_range (y, 0, INT_MAX);
+ check_integer_range (width, 0, INT_MAX);
+ check_integer_range (height, 0, INT_MAX);
+
+#ifdef USE_CAIRO
+ int ix = XFIXNUM (x),
+ iy = XFIXNUM (y),
+ iw = XFIXNUM (width),
+ ih = XFIXNUM (height);
+ cairo_surface_t *s = cairo_surface_create_for_rectangle
+ (XCANVAS (canvas)->canvas, ix, iy, iw, ih);
+ Lisp_Object newcvs = make_canvas (iw, ih);
+ struct canvas *target = XCANVAS (newcvs);
+ cairo_t *t = cairo_create (target->canvas);
+ cairo_set_source_surface (t, s, 0, 0);
+ cairo_paint (t);
+ cairo_destroy (t);
+ cairo_surface_destroy (s);
+ return newcvs;
+#else
+ error ("Not implemented.")
+#endif
+}
+
+
+DEFUN ("canvas-draw-canvas", Fcanvas_draw_canvas, Scanvas_draw_canvas, 4, 7,
+ 0, doc: /* Paint CANVAS2 onto CANVAS, at X, Y.
+If WIDTH or HEIGHT is set, and IMAGE is wider than WIDTH or taller than HEIGHT,
+IMAGE_SPEC will be cropped to fit WIDTH and/or HEIGHT respectively.
+The opacity of the drawn image will be OPACITY. */)
+ (Lisp_Object canvas, Lisp_Object canvas2,
+ Lisp_Object x, Lisp_Object y,
+ Lisp_Object width, Lisp_Object height, Lisp_Object opacity)
+{
+ CHECK_CANVAS (canvas);
+ CHECK_CANVAS (canvas2);
+ int iwidth = XCANVAS (canvas2)->width;
+ int iheight = XCANVAS (canvas2)->height;
+ check_integer_range (x, 0, INT_MAX);
+ check_integer_range (y, 0, INT_MAX);
+ if (NILP (width))
+ width = make_fixnum (iwidth);
+ check_integer_range (width, 0, INT_MAX);
+ if (NILP (height))
+ height = make_fixnum (iheight);
+ check_integer_range (height, 0, INT_MAX);
+ if (NILP (width))
+ width = make_fixnum (iwidth);
+ if (NILP (opacity))
+ opacity = make_fixnum (1);
+ CHECK_NUMBER (opacity);
+
+#ifdef USE_CAIRO
+ cairo_surface_t *crs = XCANVAS (canvas2)->canvas;
+ struct canvas *cv = XCANVAS (canvas);
+ cairo_t *cr = cairo_create (cv->canvas);
+ cairo_save (cr);
+ cairo_translate (cr, XFIXNUM (x), XFIXNUM (y));
+ cairo_rectangle (cr, 0, 0, XFIXNUM (width), XFIXNUM (height));
+ cairo_clip (cr);
+ cairo_set_source_surface (cr, crs, 0, 0);
+ cairo_paint_with_alpha (cr, XFLOATINT (opacity));
+ cairo_restore (cr);
+ cairo_destroy (cr);
+ MARK_CANVAS_CHANGED (cv);
+#endif
+ return Qnil;
+}
+
+DEFUN ("canvas-pixel-at", Fcanvas_pixel_at, Scanvas_pixel_at, 3, 3, 0,
+ doc: /* Return the color of the pixel at X, Y inside CANVAS as an ARGB list. */)
+ (Lisp_Object canvas, Lisp_Object x, Lisp_Object y)
+{
+#ifndef USE_CAIRO
+ error ("Not implemented.");
+#else
+ CHECK_CANVAS (canvas);
+ check_integer_range (x, 0, XCANVAS (canvas)->width);
+ check_integer_range (y, 0, XCANVAS (canvas)->height);
+ struct {
+#ifdef WORDS_BIGENDIAN
+ uint8_t a, r, g, b;
+#else
+ uint8_t b, g, r, a;
+#endif
+ } *argb32 =
+ (void *) cairo_image_surface_get_data (XCANVAS (canvas)->canvas);
+ typeof (*argb32) res = argb32 [XFIXNUM (y) * XCANVAS (canvas)->width +
+ XFIXNUM (x)];
+ return CALLN (Flist, make_fixnum (res.a),
+ make_fixnum (res.r),
+ make_fixnum (res.g),
+ make_fixnum (res.b));
+#endif
+}
+
+DEFUN ("canvas-dimensions", Fcanvas_dimensions, Scanvas_dimensions, 1, 1, 0,
+ doc: /* Return a cons pair containing the width and height of CANVAS. */)
+ (Lisp_Object canvas)
+{
+ CHECK_CANVAS (canvas);
+ return Fcons (make_fixnum (XCANVAS (canvas)->width),
+ make_fixnum (XCANVAS (canvas)->height));
+}
+
+void
+syms_of_canvas (void)
+{
+ defsubr (&Smake_canvas);
+ defsubr (&Scanvas_rectangle);
+ defsubr (&Scanvas_ellipse);
+ defsubr (&Scanvas_rectangle);
+ defsubr (&Scanvas_draw_string);
+ defsubr (&Scanvas_draw_image);
+ defsubr (&Scanvas_draw_canvas);
+ defsubr (&Scanvas_measure_string);
+ defsubr (&Scanvas_dimensions);
+ defsubr (&Scanvas_region);
+ defsubr (&Scanvas_pixel_at);
+ defsubr (&Scanvas_arc);
+ defsubr (&Scanvasp);
+ defsubr (&Scanvas_filled_arc);
+ defsubr (&Scanvas_rounded_rectangle);
+ DEFSYM (Qcanvas_rounded_rectangle, "canvas-rounded-rectangle");
+ DEFSYM (Qcanvasp, "canvasp");
+ DEFSYM (Qcolor_values, "color-values");
+ DEFVAR_INT ("canvas-stroke-width", canvas_stroke_width,
+ doc: /* The stroke width to be used in canvases. */);
+ canvas_stroke_width = 4;
+}
diff --git a/src/data.c b/src/data.c
index bce2e53cfb..aefd6d7e70 100644
--- a/src/data.c
+++ b/src/data.c
@@ -263,6 +263,8 @@ DEFUN ("type-of", Ftype_of, Stype_of, 1, 1, 0,
return Qxwidget;
case PVEC_XWIDGET_VIEW:
return Qxwidget_view;
+ case PVEC_CANVAS:
+ return Qcanvas;
/* "Impossible" cases. */
case PVEC_MISC_PTR:
case PVEC_OTHER:
@@ -3859,6 +3861,7 @@ #define PUT_ERROR(sym, tail, msg) \
DEFSYM (Qchar_table, "char-table");
DEFSYM (Qbool_vector, "bool-vector");
DEFSYM (Qhash_table, "hash-table");
+ DEFSYM (Qcanvas, "canvas");
DEFSYM (Qthread, "thread");
DEFSYM (Qmutex, "mutex");
DEFSYM (Qcondition_variable, "condition-variable");
diff --git a/src/dispextern.h b/src/dispextern.h
index 0b1f3d14ae..d33b87c3df 100644
--- a/src/dispextern.h
+++ b/src/dispextern.h
@@ -382,7 +382,10 @@ #define SET_GLYPH_FROM_GLYPH_CODE(glyph, gc) \
STRETCH_GLYPH,
/* Glyph is an external widget drawn by the GUI toolkit. */
- XWIDGET_GLYPH
+ XWIDGET_GLYPH,
+
+ /* Glyph is a canvas. */
+ CANVAS_GLYPH
};
@@ -540,6 +543,9 @@ #define FACE_ID_BITS 20
struct xwidget *xwidget;
#endif
+ /* Canvas reference (type == CANVAS_GLYPH). */
+ struct canvas *canvas;
+
/* Sub-structure for type == STRETCH_GLYPH. */
struct
{
@@ -1405,6 +1411,9 @@ #define OVERLAPS_ERASED_CURSOR (1 << 2)
/* Xwidget. */
struct xwidget *xwidget;
+ /* Canvas. */
+ struct canvas *canvas;
+
/* Slice */
struct glyph_slice slice;
@@ -2158,7 +2167,10 @@ #define MAX_FRINGE_BITMAPS (1<current_matrix);
+ canvas_end_redisplay (w, w->current_matrix);
clear_glyph_matrix (desired_matrix);
return paused_p;
@@ -3782,6 +3784,7 @@ gui_update_window_end (struct window *w, bool cursor_on_p,
FRAME_RIF (f)->update_window_end_hook (w,
cursor_on_p,
mouse_face_overwritten_p);
+ canvas_end_redisplay (w, w->current_matrix);
}
#endif /* HAVE_WINDOW_SYSTEM */
@@ -4371,6 +4374,11 @@ scrolling_window (struct window *w, int tab_line_p)
return 0;
#endif
+ /* We need this to fix canvas movement detection in a reliable way.
+ FIXME. */
+ if (w->have_canvas_p)
+ return 0;
+
/* Give up if some rows in the desired matrix are not enabled. */
if (! MATRIX_ROW_ENABLED_P (desired_matrix, i))
return -1;
@@ -5462,6 +5470,10 @@ buffer_posn_from_coords (struct window *w, int *x, int *y, struct display_pos *p
if (img && !NILP (img->spec))
*object = img->spec;
}
+ else if (it.what == IT_CANVAS)
+ {
+ XSETCANVAS (*object, it.canvas);
+ }
#endif
/* IT's vpos counts from the glyph row that includes the window's
@@ -5565,6 +5577,10 @@ mode_line_string (struct window *w, enum window_part part,
y0 -= row->ascent - glyph->ascent;
}
#endif
+ if (glyph->type == CANVAS_GLYPH)
+ {
+ y0 -= row->ascent - glyph->ascent;
+ }
}
else
{
@@ -5654,6 +5670,10 @@ marginal_area_string (struct window *w, enum window_part part,
y0 += glyph->slice.img.y;
}
#endif
+ if (glyph->type == CANVAS_GLYPH)
+ {
+ y0 -= row->ascent - glyph->ascent;
+ }
}
else
{
diff --git a/src/emacs.c b/src/emacs.c
index ea9c4cd79d..c16af2c14c 100644
--- a/src/emacs.c
+++ b/src/emacs.c
@@ -94,6 +94,8 @@ #define MAIN_PROGRAM
#include "getpagesize.h"
#include "gnutls.h"
+#include "canvas.h"
+
#ifdef PROFILING
# include
extern void moncontrol (int mode);
@@ -1567,6 +1569,8 @@ main (int argc, char **argv)
/* Before init_window_once, because it sets up the
Vcoding_system_hash_table. */
syms_of_coding (); /* This should be after syms_of_fileio. */
+
+ syms_of_canvas ();
init_frame_once (); /* Before init_window_once. */
init_window_once (); /* Init the window system. */
#ifdef HAVE_WINDOW_SYSTEM
diff --git a/src/lisp.h b/src/lisp.h
index b4ac017dcf..f463399dad 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -1103,6 +1103,7 @@ DEFINE_GDB_SYMBOL_END (PSEUDOVECTOR_FLAG)
PVEC_MUTEX,
PVEC_CONDVAR,
PVEC_MODULE_FUNCTION,
+ PVEC_CANVAS,
/* These should be last, for internal_equal and sxhash_obj. */
PVEC_COMPILED,
@@ -1349,6 +1350,7 @@ #define XSETSUB_CHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_SUB_CHAR_TABLE))
#define XSETTHREAD(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_THREAD))
#define XSETMUTEX(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_MUTEX))
#define XSETCONDVAR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CONDVAR))
+#define XSETCANVAS(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CANVAS))
/* Efficiently convert a pointer to a Lisp object and back. The
pointer is represented as a fixnum, so the garbage collector
diff --git a/src/pdumper.c b/src/pdumper.c
index 63424c5734..33c527c7d8 100644
--- a/src/pdumper.c
+++ b/src/pdumper.c
@@ -3036,6 +3036,8 @@ dump_vectorlike (struct dump_context *ctx,
error_unsupported_dump_object (ctx, lv, "condvar");
case PVEC_MODULE_FUNCTION:
error_unsupported_dump_object (ctx, lv, "module function");
+ case PVEC_CANVAS:
+ error_unsupported_dump_object (ctx, lv, "canvas");
default:
error_unsupported_dump_object(ctx, lv, "weird pseudovector");
}
diff --git a/src/print.c b/src/print.c
index bd1769144e..28a620fd20 100644
--- a/src/print.c
+++ b/src/print.c
@@ -34,6 +34,7 @@ Copyright (C) 1985-1986, 1988, 1993-1995, 1997-2020 Free Software
#include "blockinput.h"
#include "xwidget.h"
#include "dynlib.h"
+#include "canvas.h"
#include
#include
@@ -1833,6 +1834,16 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
}
break;
#endif
+ case PVEC_CANVAS:
+ {
+ print_c_string ("#