Mercurial > hg > xemacs-beta

comparison src/objects.c @ 5133:444a448b2f53

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Merge branch ben-lisp-object into default branch
author Ben Wing <ben@xemacs.org>
date Sun, 07 Mar 2010 06:47:37 -0600
parents 7be849cb8828
children f965e31a35f0
comparison
equal deleted inserted replaced
5113:b2dcf6a6d8ab 5133:444a448b2f53
112 (c, printcharfun, escapeflag)); 112 (c, printcharfun, escapeflag));
113 write_fmt_string (printcharfun, " 0x%x>", c->header.uid); 113 write_fmt_string (printcharfun, " 0x%x>", c->header.uid);
114 } 114 }
115 115
116 static void 116 static void
117 finalize_color_instance (void *header, int for_disksave) 117 finalize_color_instance (Lisp_Object obj)
118 { 118 {
119 Lisp_Color_Instance *c = (Lisp_Color_Instance *) header; 119 Lisp_Color_Instance *c = XCOLOR_INSTANCE (obj);
120 120
121 if (!NILP (c->device)) 121 if (!NILP (c->device))
122 { 122 MAYBE_DEVMETH (XDEVICE (c->device), finalize_color_instance, (c));
123 if (for_disksave) finalose (c);
124 MAYBE_DEVMETH (XDEVICE (c->device), finalize_color_instance, (c));
125 }
126 } 123 }
127 124
128 static int 125 static int
129 color_instance_equal (Lisp_Object obj1, Lisp_Object obj2, int depth, 126 color_instance_equal (Lisp_Object obj1, Lisp_Object obj2, int depth,
130 int UNUSED (foldcase)) 127 int UNUSED (foldcase))
149 !d ? LISP_HASH (obj) 146 !d ? LISP_HASH (obj)
150 : DEVMETH_OR_GIVEN (d, color_instance_hash, (c, depth), 147 : DEVMETH_OR_GIVEN (d, color_instance_hash, (c, depth),
151 LISP_HASH (obj))); 148 LISP_HASH (obj)));
152 } 149 }
153 150
154 DEFINE_LRECORD_IMPLEMENTATION ("color-instance", color_instance, 151 DEFINE_NODUMP_LISP_OBJECT ("color-instance", color_instance,
155 0, /*dumpable-flag*/ 152 mark_color_instance, print_color_instance,
156 mark_color_instance, print_color_instance, 153 finalize_color_instance, color_instance_equal,
157 finalize_color_instance, color_instance_equal, 154 color_instance_hash,
158 color_instance_hash, 155 color_instance_description,
159 color_instance_description, 156 Lisp_Color_Instance);
160 Lisp_Color_Instance);
161 157
162 DEFUN ("make-color-instance", Fmake_color_instance, 1, 3, 0, /* 158 DEFUN ("make-color-instance", Fmake_color_instance, 1, 3, 0, /*
163 Return a new `color-instance' object named NAME (a string). 159 Return a new `color-instance' object named NAME (a string).
164 160
165 Optional argument DEVICE specifies the device this object applies to 161 Optional argument DEVICE specifies the device this object applies to
176 these objects are GCed, the underlying window-system data (e.g. X object) 172 these objects are GCed, the underlying window-system data (e.g. X object)
177 is deallocated as well. 173 is deallocated as well.
178 */ 174 */
179 (name, device, noerror)) 175 (name, device, noerror))
180 { 176 {
177 Lisp_Object obj;
181 Lisp_Color_Instance *c; 178 Lisp_Color_Instance *c;
182 int retval; 179 int retval;
183 180
184 CHECK_STRING (name); 181 CHECK_STRING (name);
185 device = wrap_device (decode_device (device)); 182 device = wrap_device (decode_device (device));
186 183
187 c = ALLOC_LCRECORD_TYPE (Lisp_Color_Instance, &lrecord_color_instance); 184 obj = ALLOC_NORMAL_LISP_OBJECT (color_instance);
185 c = XCOLOR_INSTANCE (obj);
188 c->name = name; 186 c->name = name;
189 c->device = device; 187 c->device = device;
190 c->data = 0; 188 c->data = 0;
191 c->color_instance_type = get_console_variant (XDEVICE_TYPE (c->device)); 189 c->color_instance_type = get_console_variant (XDEVICE_TYPE (c->device));
192 190
194 (c, name, device, 192 (c, name, device,
195 decode_error_behavior_flag (noerror))); 193 decode_error_behavior_flag (noerror)));
196 if (!retval) 194 if (!retval)
197 return Qnil; 195 return Qnil;
198 196
199 return wrap_color_instance (c); 197 return obj;
200 } 198 }
201 199
202 DEFUN ("color-instance-p", Fcolor_instance_p, 1, 1, 0, /* 200 DEFUN ("color-instance-p", Fcolor_instance_p, 1, 1, 0, /*
203 Return non-nil if OBJECT is a color instance. 201 Return non-nil if OBJECT is a color instance.
204 */ 202 */
332 } 330 }
333 write_fmt_string (printcharfun, " 0x%x>", f->header.uid); 331 write_fmt_string (printcharfun, " 0x%x>", f->header.uid);
334 } 332 }
335 333
336 static void 334 static void
337 finalize_font_instance (void *header, int for_disksave) 335 finalize_font_instance (Lisp_Object obj)
338 { 336 {
339 Lisp_Font_Instance *f = (Lisp_Font_Instance *) header; 337 Lisp_Font_Instance *f = XFONT_INSTANCE (obj);
340 338
341 if (!NILP (f->device)) 339 if (!NILP (f->device))
342 { 340 {
343 if (for_disksave) finalose (f);
344 MAYBE_DEVMETH (XDEVICE (f->device), finalize_font_instance, (f)); 341 MAYBE_DEVMETH (XDEVICE (f->device), finalize_font_instance, (f));
345 } 342 }
346 } 343 }
347 344
348 /* Fonts are equal if they resolve to the same name. 345 /* Fonts are equal if they resolve to the same name.
367 return internal_hash (font_instance_truename_internal 364 return internal_hash (font_instance_truename_internal
368 (obj, ERROR_ME_DEBUG_WARN), 365 (obj, ERROR_ME_DEBUG_WARN),
369 depth + 1); 366 depth + 1);
370 } 367 }
371 368
372 DEFINE_LRECORD_IMPLEMENTATION ("font-instance", font_instance, 369 DEFINE_NODUMP_LISP_OBJECT ("font-instance", font_instance,
373 0, /*dumpable-flag*/ 370 mark_font_instance, print_font_instance,
374 mark_font_instance, print_font_instance, 371 finalize_font_instance, font_instance_equal,
375 finalize_font_instance, font_instance_equal, 372 font_instance_hash, font_instance_description,
376 font_instance_hash, font_instance_description, 373 Lisp_Font_Instance);
377 Lisp_Font_Instance);
378 374
379 375
380 /* #### Why is this exposed to Lisp? Used in: 376 /* #### Why is this exposed to Lisp? Used in:
381 x-frob-font-size, gtk-font-menu-load-font, x-font-menu-load-font-xft, 377 x-frob-font-size, gtk-font-menu-load-font, x-font-menu-load-font-xft,
382 x-font-menu-load-font-core, mswindows-font-menu-load-font, 378 x-font-menu-load-font-core, mswindows-font-menu-load-font,
393 you drop all pointers to it and allow it to be garbage collected. When 389 you drop all pointers to it and allow it to be garbage collected. When
394 these objects are GCed, the underlying GUI data is deallocated as well. 390 these objects are GCed, the underlying GUI data is deallocated as well.
395 */ 391 */
396 (name, device, noerror, charset)) 392 (name, device, noerror, charset))
397 { 393 {
394 Lisp_Object obj;
398 Lisp_Font_Instance *f; 395 Lisp_Font_Instance *f;
399 int retval = 0; 396 int retval = 0;
400 Error_Behavior errb = decode_error_behavior_flag (noerror); 397 Error_Behavior errb = decode_error_behavior_flag (noerror);
401 398
402 if (ERRB_EQ (errb, ERROR_ME)) 399 if (ERRB_EQ (errb, ERROR_ME))
404 else if (!STRINGP (name)) 401 else if (!STRINGP (name))
405 return Qnil; 402 return Qnil;
406 403
407 device = wrap_device (decode_device (device)); 404 device = wrap_device (decode_device (device));
408 405
409 f = ALLOC_LCRECORD_TYPE (Lisp_Font_Instance, &lrecord_font_instance); 406 obj = ALLOC_NORMAL_LISP_OBJECT (font_instance);
407 f = XFONT_INSTANCE (obj);
410 f->name = name; 408 f->name = name;
411 f->truename = Qnil; 409 f->truename = Qnil;
412 f->device = device; 410 f->device = device;
413 411
414 f->data = 0; 412 f->data = 0;
425 (f, name, device, errb)); 423 (f, name, device, errb));
426 424
427 if (!retval) 425 if (!retval)
428 return Qnil; 426 return Qnil;
429 427
430 return wrap_font_instance (f); 428 return obj;
431 } 429 }
432 430
433 DEFUN ("font-instance-p", Ffont_instance_p, 1, 1, 0, /* 431 DEFUN ("font-instance-p", Ffont_instance_p, 1, 1, 0, /*
434 Return non-nil if OBJECT is a font instance. 432 Return non-nil if OBJECT is a font instance.
435 */ 433 */
1342 /************************************************************************/ 1340 /************************************************************************/
1343 1341
1344 void 1342 void
1345 syms_of_objects (void) 1343 syms_of_objects (void)
1346 { 1344 {
1347 INIT_LRECORD_IMPLEMENTATION (color_instance); 1345 INIT_LISP_OBJECT (color_instance);
1348 INIT_LRECORD_IMPLEMENTATION (font_instance); 1346 INIT_LISP_OBJECT (font_instance);
1349 1347
1350 DEFSUBR (Fcolor_specifier_p); 1348 DEFSUBR (Fcolor_specifier_p);
1351 DEFSUBR (Ffont_specifier_p); 1349 DEFSUBR (Ffont_specifier_p);
1352 DEFSUBR (Fface_boolean_specifier_p); 1350 DEFSUBR (Fface_boolean_specifier_p);
1353 DEFSUBR (Fface_background_placement_specifier_p); 1351 DEFSUBR (Fface_background_placement_specifier_p);
1433 } 1431 }
1434 1432
1435 void 1433 void
1436 reinit_vars_of_objects (void) 1434 reinit_vars_of_objects (void)
1437 { 1435 {
1438 staticpro_nodump (&Vthe_null_color_instance);
1439 { 1436 {
1440 Lisp_Color_Instance *c = 1437 Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (color_instance);
1441 ALLOC_LCRECORD_TYPE (Lisp_Color_Instance, &lrecord_color_instance); 1438 Lisp_Color_Instance *c = XCOLOR_INSTANCE (obj);
1442 c->name = Qnil; 1439 c->name = Qnil;
1443 c->device = Qnil; 1440 c->device = Qnil;
1444 c->data = 0; 1441 c->data = 0;
1445 1442
1446 Vthe_null_color_instance = wrap_color_instance (c); 1443 Vthe_null_color_instance = obj;
1444 staticpro_nodump (&Vthe_null_color_instance);
1447 } 1445 }
1448 1446
1449 staticpro_nodump (&Vthe_null_font_instance);
1450 { 1447 {
1451 Lisp_Font_Instance *f = 1448 Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (font_instance);
1452 ALLOC_LCRECORD_TYPE (Lisp_Font_Instance, &lrecord_font_instance); 1449 Lisp_Font_Instance *f = XFONT_INSTANCE (obj);
1453 f->name = Qnil; 1450 f->name = Qnil;
1454 f->truename = Qnil; 1451 f->truename = Qnil;
1455 f->device = Qnil; 1452 f->device = Qnil;
1456 f->data = 0; 1453 f->data = 0;
1457 1454
1458 f->ascent = f->height = 0; 1455 f->ascent = f->height = 0;
1459 f->descent = 0; 1456 f->descent = 0;
1460 f->width = 0; 1457 f->width = 0;
1461 f->proportional_p = 0; 1458 f->proportional_p = 0;
1462 1459
1463 Vthe_null_font_instance = wrap_font_instance (f); 1460 Vthe_null_font_instance = obj;
1461 staticpro_nodump (&Vthe_null_font_instance);
1464 } 1462 }
1465 } 1463 }
1466 1464
1467 void 1465 void
1468 vars_of_objects (void) 1466 vars_of_objects (void)