Mercurial > hg > xemacs-beta

comparison src/objects.c @ 272:c5d627a313b1 r21-0b34

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-0b34
author cvs
date Mon, 13 Aug 2007 10:28:48 +0200
parents 0e522484dd2a
children 8bec6624d99b
comparison
equal deleted inserted replaced
271:c7b7086b0a39 272:c5d627a313b1
53 /**************************************************************************** 53 /****************************************************************************
54 * Color-Instance Object * 54 * Color-Instance Object *
55 ****************************************************************************/ 55 ****************************************************************************/
56 56
57 Lisp_Object Qcolor_instancep; 57 Lisp_Object Qcolor_instancep;
58 static Lisp_Object mark_color_instance (Lisp_Object, void (*) (Lisp_Object));
59 static void print_color_instance (Lisp_Object, Lisp_Object, int);
60 static void finalize_color_instance (void *, int);
61 static int color_instance_equal (Lisp_Object, Lisp_Object, int depth);
62 static unsigned long color_instance_hash (Lisp_Object obj, int depth);
63 DEFINE_LRECORD_IMPLEMENTATION ("color-instance", color_instance,
64 mark_color_instance, print_color_instance,
65 finalize_color_instance, color_instance_equal,
66 color_instance_hash,
67 struct Lisp_Color_Instance);
68 58
69 static Lisp_Object 59 static Lisp_Object
70 mark_color_instance (Lisp_Object obj, void (*markobj) (Lisp_Object)) 60 mark_color_instance (Lisp_Object obj, void (*markobj) (Lisp_Object))
71 { 61 {
72 struct Lisp_Color_Instance *c = XCOLOR_INSTANCE (obj); 62 struct Lisp_Color_Instance *c = XCOLOR_INSTANCE (obj);
134 !d ? LISP_HASH (obj) 124 !d ? LISP_HASH (obj)
135 : DEVMETH_OR_GIVEN (d, color_instance_hash, (c, depth), 125 : DEVMETH_OR_GIVEN (d, color_instance_hash, (c, depth),
136 LISP_HASH (obj))); 126 LISP_HASH (obj)));
137 } 127 }
138 128
129 DEFINE_LRECORD_IMPLEMENTATION ("color-instance", color_instance,
130 mark_color_instance, print_color_instance,
131 finalize_color_instance, color_instance_equal,
132 color_instance_hash,
133 struct Lisp_Color_Instance);
134
139 DEFUN ("make-color-instance", Fmake_color_instance, 1, 3, 0, /* 135 DEFUN ("make-color-instance", Fmake_color_instance, 1, 3, 0, /*
140 Creates a new `color-instance' object of the specified color. 136 Return a new `color-instance' object named NAME (a string).
141 DEVICE specifies the device this object applies to and defaults to the 137
142 selected device. An error is signalled if the color is unknown or cannot 138 Optional argument DEVICE specifies the device this object applies to
143 be allocated; however, if NOERROR is non-nil, nil is simply returned in 139 and defaults to the selected device.
144 this case. (And if NOERROR is other than t, a warning may be issued.) 140
141 An error is signaled if the color is unknown or cannot be allocated;
142 however, if optional argument NO-ERROR is non-nil, nil is simply
143 returned in this case. (And if NO-ERROR is other than t, a warning may
144 be issued.)
145 145
146 The returned object is a normal, first-class lisp object. The way you 146 The returned object is a normal, first-class lisp object. The way you
147 `deallocate' the color is the way you deallocate any other lisp object: 147 `deallocate' the color is the way you deallocate any other lisp object:
148 you drop all pointers to it and allow it to be garbage collected. When 148 you drop all pointers to it and allow it to be garbage collected. When
149 these objects are GCed, the underlying window-system data (e.g. X object) 149 these objects are GCed, the underlying window-system data (e.g. X object)
151 */ 151 */
152 (name, device, no_error)) 152 (name, device, no_error))
153 { 153 {
154 struct Lisp_Color_Instance *c; 154 struct Lisp_Color_Instance *c;
155 Lisp_Object val; 155 Lisp_Object val;
156 int retval = 0; 156 int retval;
157 157
158 CHECK_STRING (name); 158 CHECK_STRING (name);
159 XSETDEVICE (device, decode_device (device)); 159 XSETDEVICE (device, decode_device (device));
160 160
161 c = alloc_lcrecord_type (struct Lisp_Color_Instance, lrecord_color_instance); 161 c = alloc_lcrecord_type (struct Lisp_Color_Instance, lrecord_color_instance);
162 c->name = name; 162 c->name = name;
163 c->device = device; 163 c->device = device;
164
165 c->data = 0; 164 c->data = 0;
166 165
167 retval = MAYBE_INT_DEVMETH (XDEVICE (device), initialize_color_instance, 166 retval = MAYBE_INT_DEVMETH (XDEVICE (device), initialize_color_instance,
168 (c, name, device, 167 (c, name, device,
169 decode_error_behavior_flag (no_error))); 168 decode_error_behavior_flag (no_error)));
170
171 if (!retval) 169 if (!retval)
172 return Qnil; 170 return Qnil;
173 171
174 XSETCOLOR_INSTANCE (val, c); 172 XSETCOLOR_INSTANCE (val, c);
175 return val; 173 return val;
193 } 191 }
194 192
195 DEFUN ("color-instance-rgb-components", Fcolor_instance_rgb_components, 1, 1, 0, /* 193 DEFUN ("color-instance-rgb-components", Fcolor_instance_rgb_components, 1, 1, 0, /*
196 Return a three element list containing the red, green, and blue 194 Return a three element list containing the red, green, and blue
197 color components of COLOR-INSTANCE, or nil if unknown. 195 color components of COLOR-INSTANCE, or nil if unknown.
198 Component values range from 0-65535. 196 Component values range from 0 to 65535.
199 */ 197 */
200 (color_instance)) 198 (color_instance))
201 { 199 {
202 struct Lisp_Color_Instance *c; 200 struct Lisp_Color_Instance *c;
203 201
204 CHECK_COLOR_INSTANCE (color_instance); 202 CHECK_COLOR_INSTANCE (color_instance);
205 c = XCOLOR_INSTANCE (color_instance); 203 c = XCOLOR_INSTANCE (color_instance);
206 204
207 if (NILP (c->device)) 205 if (NILP (c->device))
208 return Qnil; 206 return Qnil;
209 else 207
210 return MAYBE_LISP_DEVMETH (XDEVICE (c->device), 208 return MAYBE_LISP_DEVMETH (XDEVICE (c->device),
211 color_instance_rgb_components, 209 color_instance_rgb_components,
212 (c)); 210 (c));
213 } 211 }
214 212
215 DEFUN ("valid-color-name-p", Fvalid_color_name_p, 1, 2, 0, /* 213 DEFUN ("valid-color-name-p", Fvalid_color_name_p, 1, 2, 0, /*
216 Return true if COLOR names a valid color for the current device. 214 Return true if COLOR names a valid color for the current device.
217 215
234 /*************************************************************************** 232 /***************************************************************************
235 * Font-Instance Object * 233 * Font-Instance Object *
236 ***************************************************************************/ 234 ***************************************************************************/
237 235
238 Lisp_Object Qfont_instancep; 236 Lisp_Object Qfont_instancep;
239 static Lisp_Object mark_font_instance (Lisp_Object, void (*) (Lisp_Object));
240 static void print_font_instance (Lisp_Object, Lisp_Object, int);
241 static void finalize_font_instance (void *, int);
242 static int font_instance_equal (Lisp_Object o1, Lisp_Object o2, int depth);
243 static unsigned long font_instance_hash (Lisp_Object obj, int depth);
244 DEFINE_LRECORD_IMPLEMENTATION ("font-instance", font_instance,
245 mark_font_instance, print_font_instance,
246 finalize_font_instance, font_instance_equal,
247 font_instance_hash, struct Lisp_Font_Instance);
248 237
249 static Lisp_Object font_instance_truename_internal (Lisp_Object xfont, 238 static Lisp_Object font_instance_truename_internal (Lisp_Object xfont,
250 Error_behavior errb); 239 Error_behavior errb);
251 240
252 static Lisp_Object 241 static Lisp_Object
308 { 297 {
309 return internal_hash (font_instance_truename_internal (obj, ERROR_ME_NOT), 298 return internal_hash (font_instance_truename_internal (obj, ERROR_ME_NOT),
310 depth + 1); 299 depth + 1);
311 } 300 }
312 301
302 DEFINE_LRECORD_IMPLEMENTATION ("font-instance", font_instance,
303 mark_font_instance, print_font_instance,
304 finalize_font_instance, font_instance_equal,
305 font_instance_hash, struct Lisp_Font_Instance);
306
313 DEFUN ("make-font-instance", Fmake_font_instance, 1, 3, 0, /* 307 DEFUN ("make-font-instance", Fmake_font_instance, 1, 3, 0, /*
314 Creates a new `font-instance' object of the specified name. 308 Return a new `font-instance' object named NAME.
315 DEVICE specifies the device this object applies to and defaults to the 309 DEVICE specifies the device this object applies to and defaults to the
316 selected device. An error is signalled if the font is unknown or cannot 310 selected device. An error is signalled if the font is unknown or cannot
317 be allocated; however, if NOERROR is non-nil, nil is simply returned in 311 be allocated; however, if NOERROR is non-nil, nil is simply returned in
318 this case. 312 this case.
319 313
389 383
390 DEFUN ("font-instance-descent", Ffont_instance_descent, 1, 1, 0, /* 384 DEFUN ("font-instance-descent", Ffont_instance_descent, 1, 1, 0, /*
391 Return the descent in pixels of FONT-INSTANCE. 385 Return the descent in pixels of FONT-INSTANCE.
392 The returned value is the maximum descent for all characters in the font, 386 The returned value is the maximum descent for all characters in the font,
393 where a character's descent is the number of pixels below the baseline. 387 where a character's descent is the number of pixels below the baseline.
394 (Many characters to do not have any descent. Typical characters with a 388 \(Many characters to do not have any descent. Typical characters with a
395 descent are lowercase p and lowercase g.) 389 descent are lowercase p and lowercase g.)
396 */ 390 */
397 (font_instance)) 391 (font_instance))
398 { 392 {
399 CHECK_FONT_INSTANCE (font_instance); 393 CHECK_FONT_INSTANCE (font_instance);
423 static Lisp_Object 417 static Lisp_Object
424 font_instance_truename_internal (Lisp_Object font_instance, 418 font_instance_truename_internal (Lisp_Object font_instance,
425 Error_behavior errb) 419 Error_behavior errb)
426 { 420 {
427 struct Lisp_Font_Instance *f = XFONT_INSTANCE (font_instance); 421 struct Lisp_Font_Instance *f = XFONT_INSTANCE (font_instance);
428 return DEVMETH_OR_GIVEN (XDEVICE (f->device), font_instance_truename, 422 struct device *d = XDEVICE (f->device);
429 (f, errb), f->name); 423 return DEVMETH_OR_GIVEN (d, font_instance_truename, (f, errb), f->name);
430 } 424 }
431 425
432 DEFUN ("font-instance-truename", Ffont_instance_truename, 1, 1, 0, /* 426 DEFUN ("font-instance-truename", Ffont_instance_truename, 1, 1, 0, /*
433 Return the canonical name of FONT-INSTANCE. 427 Return the canonical name of FONT-INSTANCE.
434 Font names are patterns which may match any number of fonts, of which 428 Font names are patterns which may match any number of fonts, of which
435 the first found is used. This returns an unambiguous name for that font 429 the first found is used. This returns an unambiguous name for that font
436 (but not necessarily its only unambiguous name). 430 \(but not necessarily its only unambiguous name).
437 */ 431 */
438 (font_instance)) 432 (font_instance))
439 { 433 {
440 CHECK_FONT_INSTANCE (font_instance); 434 CHECK_FONT_INSTANCE (font_instance);
441 return font_instance_truename_internal (font_instance, ERROR_ME); 435 return font_instance_truename_internal (font_instance, ERROR_ME);
623 COLOR_SPECIFIER_FACE (color) = face; 617 COLOR_SPECIFIER_FACE (color) = face;
624 COLOR_SPECIFIER_FACE_PROPERTY (color) = property; 618 COLOR_SPECIFIER_FACE_PROPERTY (color) = property;
625 } 619 }
626 620
627 DEFUN ("color-specifier-p", Fcolor_specifier_p, 1, 1, 0, /* 621 DEFUN ("color-specifier-p", Fcolor_specifier_p, 1, 1, 0, /*
628 Return non-nil if OBJECT is a color specifier. 622 Return t if OBJECT is a color specifier.
629 623
630 Valid instantiators for color specifiers are: 624 Valid instantiators for color specifiers are:
631 625
632 -- a string naming a color (e.g. under X this might be "lightseagreen2" 626 -- a string naming a color (e.g. under X this might be "lightseagreen2"
633 or "#F534B2") 627 or "#F534B2")