Mercurial > hg > xemacs-beta

comparison src/eval.c @ 5178:97eb4942aec8

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
merge
author Ben Wing <ben@xemacs.org>
date Mon, 29 Mar 2010 21:28:13 -0500
parents 88bd4f3ef8e4
children 1096ef427b56
comparison
equal deleted inserted replaced
5177:b785049378e3 5178:97eb4942aec8
416 416
417 static int warning_will_be_discarded (Lisp_Object level); 417 static int warning_will_be_discarded (Lisp_Object level);
418 static Lisp_Object maybe_get_trapping_problems_backtrace (void); 418 static Lisp_Object maybe_get_trapping_problems_backtrace (void);
419 419
420 420
421
422 /* When parsing keyword arguments; is some element of NARGS
423 :allow-other-keys, and is that element followed by a non-nil Lisp
424 object? */
425
426 Boolint
427 non_nil_allow_other_keys_p (Elemcount offset, int nargs, Lisp_Object *args)
428 {
429 Lisp_Object key, value;
430 while (offset + 1 < nargs)
431 {
432 key = args[offset++];
433 value = args[offset++];
434 if (EQ (key, Q_allow_other_keys))
435 {
436 /* The ANSI Common Lisp standard says the first value for a given
437 keyword overrides. */
438 return !NILP (value);
439 }
440 }
441 return 0;
442 }
443
421 /************************************************************************/ 444 /************************************************************************/
422 /* The subr object type */ 445 /* The subr object type */
423 /************************************************************************/ 446 /************************************************************************/
424 447
425 static void 448 static void
430 (subr->max_args == UNEVALLED) ? "#<special-operator " : "#<subr "; 453 (subr->max_args == UNEVALLED) ? "#<special-operator " : "#<subr ";
431 const Ascbyte *name = subr_name (subr); 454 const Ascbyte *name = subr_name (subr);
432 const Ascbyte *trailer = subr->prompt ? " (interactive)>" : ">"; 455 const Ascbyte *trailer = subr->prompt ? " (interactive)>" : ">";
433 456
434 if (print_readably) 457 if (print_readably)
435 printing_unreadable_object ("%s%s%s", header, name, trailer); 458 printing_unreadable_object_fmt ("%s%s%s", header, name, trailer);
436 459
437 write_ascstring (printcharfun, header); 460 write_ascstring (printcharfun, header);
438 write_ascstring (printcharfun, name); 461 write_ascstring (printcharfun, name);
439 write_ascstring (printcharfun, trailer); 462 write_ascstring (printcharfun, trailer);
440 } 463 }
442 static const struct memory_description subr_description[] = { 465 static const struct memory_description subr_description[] = {
443 { XD_DOC_STRING, offsetof (Lisp_Subr, doc), 0, { 0 }, XD_FLAG_NO_KKCC }, 466 { XD_DOC_STRING, offsetof (Lisp_Subr, doc), 0, { 0 }, XD_FLAG_NO_KKCC },
444 { XD_END } 467 { XD_END }
445 }; 468 };
446 469
447 DEFINE_BASIC_LRECORD_IMPLEMENTATION ("subr", subr, 470 DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT ("subr", subr,
448 1, /*dumpable-flag*/ 471 0, print_subr, 0, 0, 0,
449 0, print_subr, 0, 0, 0, 472 subr_description,
450 subr_description, 473 Lisp_Subr);
451 Lisp_Subr);
452 474
453 /************************************************************************/ 475 /************************************************************************/
454 /* Entering the debugger */ 476 /* Entering the debugger */
455 /************************************************************************/ 477 /************************************************************************/
456 478
3048 { 3070 {
3049 maybe_signal_error (Qinvalid_argument, reason, frob, class_, errb); 3071 maybe_signal_error (Qinvalid_argument, reason, frob, class_, errb);
3050 } 3072 }
3051 3073
3052 DOESNT_RETURN 3074 DOESNT_RETURN
3075 invalid_keyword_argument (Lisp_Object function, Lisp_Object keyword)
3076 {
3077 signal_error_1 (Qinvalid_keyword_argument, list2 (function, keyword));
3078 }
3079
3080 DOESNT_RETURN
3053 invalid_constant (const Ascbyte *reason, Lisp_Object frob) 3081 invalid_constant (const Ascbyte *reason, Lisp_Object frob)
3054 { 3082 {
3055 signal_error (Qinvalid_constant, reason, frob); 3083 signal_error (Qinvalid_constant, reason, frob);
3056 } 3084 }
3057 3085
4489 Elemcount first_desired, Elemcount upper_limit) 4517 Elemcount first_desired, Elemcount upper_limit)
4490 { 4518 {
4491 Bytecount sizem; 4519 Bytecount sizem;
4492 struct multiple_value *mv; 4520 struct multiple_value *mv;
4493 Elemcount i, allocated_count; 4521 Elemcount i, allocated_count;
4522 Lisp_Object mvobj;
4494 4523
4495 assert (count != 1); 4524 assert (count != 1);
4496 4525
4497 if (1 != upper_limit && (0 == first_desired)) 4526 if (1 != upper_limit && (0 == first_desired))
4498 { 4527 {
4514 } 4543 }
4515 4544
4516 sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (multiple_value, 4545 sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (multiple_value,
4517 Lisp_Object, 4546 Lisp_Object,
4518 contents, allocated_count); 4547 contents, allocated_count);
4519 mv = (multiple_value *) BASIC_ALLOC_LCRECORD (sizem, 4548 mvobj = ALLOC_SIZED_LISP_OBJECT (sizem, multiple_value);
4520 &lrecord_multiple_value); 4549 mv = XMULTIPLE_VALUE (mvobj);
4521 4550
4522 mv->count = count; 4551 mv->count = count;
4523 mv->first_desired = first_desired; 4552 mv->first_desired = first_desired;
4524 mv->allocated_count = allocated_count; 4553 mv->allocated_count = allocated_count;
4525 mv->contents[0] = first_value; 4554 mv->contents[0] = first_value;
4527 for (i = first_desired; i < upper_limit && i < count; ++i) 4556 for (i = first_desired; i < upper_limit && i < count; ++i)
4528 { 4557 {
4529 mv->contents[1 + (i - first_desired)] = Qunbound; 4558 mv->contents[1 + (i - first_desired)] = Qunbound;
4530 } 4559 }
4531 4560
4532 return wrap_multiple_value (mv); 4561 return mvobj;
4533 } 4562 }
4534 4563
4535 void 4564 void
4536 multiple_value_aset (Lisp_Object obj, Elemcount index, Lisp_Object value) 4565 multiple_value_aset (Lisp_Object obj, Elemcount index, Lisp_Object value)
4537 { 4566 {
4574 Elemcount allocated_count = mv->allocated_count; 4603 Elemcount allocated_count = mv->allocated_count;
4575 Elemcount count = mv->count, index; 4604 Elemcount count = mv->count, index;
4576 4605
4577 if (print_readably) 4606 if (print_readably)
4578 { 4607 {
4579 printing_unreadable_object ("multiple values"); 4608 printing_unreadable_object_fmt ("#<multiple values 0x%x>",
4580 } 4609 LISP_OBJECT_UID (obj));
4581 4610 }
4582 if (0 == count) 4611
4583 { 4612 write_fmt_string (printcharfun,
4584 write_msg_string (printcharfun, "#<zero-length multiple value>"); 4613 "#<INTERNAL OBJECT (XEmacs bug?) %d multiple values,"
4585 } 4614 " data (", count);
4586 4615
4587 for (index = 0; index < count;) 4616 for (index = 0; index < count;)
4588 { 4617 {
4589 if (index != 0 && 4618 if (index != 0 &&
4590 (index < first_desired || 4619 (index < first_desired ||
4601 4630
4602 ++index; 4631 ++index;
4603 4632
4604 if (count > 1 && index < count) 4633 if (count > 1 && index < count)
4605 { 4634 {
4606 write_ascstring (printcharfun, " ;\n"); 4635 write_ascstring (printcharfun, " ");
4607 } 4636 }
4608 } 4637 }
4638
4639 write_fmt_string (printcharfun, ") 0x%x>", LISP_OBJECT_UID (obj));
4609 } 4640 }
4610 4641
4611 static Lisp_Object 4642 static Lisp_Object
4612 mark_multiple_value (Lisp_Object obj) 4643 mark_multiple_value (Lisp_Object obj)
4613 { 4644 {
4621 4652
4622 return Qnil; 4653 return Qnil;
4623 } 4654 }
4624 4655
4625 static Bytecount 4656 static Bytecount
4626 size_multiple_value (const void *lheader) 4657 size_multiple_value (Lisp_Object obj)
4627 { 4658 {
4628 return FLEXIBLE_ARRAY_STRUCT_SIZEOF (struct multiple_value, 4659 return FLEXIBLE_ARRAY_STRUCT_SIZEOF (struct multiple_value,
4629 Lisp_Object, contents, 4660 Lisp_Object, contents,
4630 ((struct multiple_value *) lheader)-> 4661 XMULTIPLE_VALUE (obj)->allocated_count);
4631 allocated_count);
4632 } 4662 }
4633 4663
4634 static const struct memory_description multiple_value_description[] = { 4664 static const struct memory_description multiple_value_description[] = {
4635 { XD_LONG, offsetof (struct multiple_value, count) }, 4665 { XD_LONG, offsetof (struct multiple_value, count) },
4636 { XD_ELEMCOUNT, offsetof (struct multiple_value, allocated_count) }, 4666 { XD_ELEMCOUNT, offsetof (struct multiple_value, allocated_count) },
4638 { XD_LISP_OBJECT_ARRAY, offsetof (struct multiple_value, contents), 4668 { XD_LISP_OBJECT_ARRAY, offsetof (struct multiple_value, contents),
4639 XD_INDIRECT (1, 0) }, 4669 XD_INDIRECT (1, 0) },
4640 { XD_END } 4670 { XD_END }
4641 }; 4671 };
4642 4672
4643 DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("multiple-value", multiple_value, 4673 DEFINE_DUMPABLE_SIZABLE_LISP_OBJECT ("multiple-value", multiple_value,
4644 1, /*dumpable-flag*/ 4674 mark_multiple_value,
4645 mark_multiple_value, 4675 print_multiple_value, 0,
4646 print_multiple_value, 0, 4676 0, /* No equal method. */
4647 0, /* No equal method. */ 4677 0, /* No hash method. */
4648 0, /* No hash method. */ 4678 multiple_value_description,
4649 multiple_value_description, 4679 size_multiple_value,
4650 size_multiple_value, 4680 struct multiple_value);
4651 struct multiple_value);
4652 4681
4653 /* Given that FIRST and UPPER are the inclusive lower and exclusive upper 4682 /* Given that FIRST and UPPER are the inclusive lower and exclusive upper
4654 bounds for the multiple values we're interested in, modify (or don't) the 4683 bounds for the multiple values we're interested in, modify (or don't) the
4655 special variables used to indicate this to #'values and #'values-list. 4684 special variables used to indicate this to #'values and #'values-list.
4656 Returns the specpdl_depth() value before any modification. */ 4685 Returns the specpdl_depth() value before any modification. */
7234 /************************************************************************/ 7263 /************************************************************************/
7235 7264
7236 void 7265 void
7237 syms_of_eval (void) 7266 syms_of_eval (void)
7238 { 7267 {
7239 INIT_LRECORD_IMPLEMENTATION (subr); 7268 INIT_LISP_OBJECT (subr);
7240 INIT_LRECORD_IMPLEMENTATION (multiple_value); 7269 INIT_LISP_OBJECT (multiple_value);
7241 7270
7242 DEFSYMBOL (Qinhibit_quit); 7271 DEFSYMBOL (Qinhibit_quit);
7243 DEFSYMBOL (Qautoload); 7272 DEFSYMBOL (Qautoload);
7244 DEFSYMBOL (Qdebug_on_error); 7273 DEFSYMBOL (Qdebug_on_error);
7245 DEFSYMBOL (Qstack_trace_on_error); 7274 DEFSYMBOL (Qstack_trace_on_error);