Mercurial > hg > xemacs-beta

comparison src/fns.c @ 5273:799742b751c8

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Accept circular lists where that is useful in #'mapcar*, #'map* and friends. src/ChangeLog addition: 2010-09-16 Aidan Kehoe <kehoea@parhasard.net> * fns.c (Flist_length): New, moved here from cl-extra.el, needed by the next function. (shortest_length_among_sequences): New. (Fmapconcat, FmapcarX, Fmapvector, Fmapcan, Fmapc, Fmap) (Fmap_into, Fsome, Fevery): Use shortest_length_among_sequences() when working out how many iterations to do, only giving circular list errors if all arguments are circular.
author Aidan Kehoe <kehoea@parhasard.net>
date Thu, 16 Sep 2010 20:34:49 +0100
parents 66dbef5f8076
children 5a9aa6c40c9b
comparison
equal deleted inserted replaced
5272:66dbef5f8076 5273:799742b751c8
335 if (len & 1) 335 if (len & 1)
336 tortoise = XCDR (tortoise); 336 tortoise = XCDR (tortoise);
337 } 337 }
338 338
339 return make_int (len); 339 return make_int (len);
340 }
341
342 /* This is almost the above, but is defined by Common Lisp. We need it in C
343 for shortest_length_among_sequences(), below, for the various sequence
344 functions that can usefully operate on circular lists. */
345
346 DEFUN ("list-length", Flist_length, 1, 1, 0, /*
347 Return the length of LIST. Return nil if LIST is circular.
348 */
349 (list))
350 {
351 Lisp_Object hare, tortoise;
352 Elemcount len;
353
354 for (hare = tortoise = list, len = 0;
355 CONSP (hare) && (! EQ (hare, tortoise) || len == 0);
356 hare = XCDR (hare), len++)
357 {
358 if (len & 1)
359 tortoise = XCDR (tortoise);
360 }
361
362 return EQ (hare, tortoise) && len != 0 ? Qnil : make_int (len);
340 } 363 }
341 364
342 /*** string functions. ***/ 365 /*** string functions. ***/
343 366
344 DEFUN ("string-equal", Fstring_equal, 2, 2, 0, /* 367 DEFUN ("string-equal", Fstring_equal, 2, 2, 0, /*
4456 } 4479 }
4457 4480
4458 UNGCPRO; 4481 UNGCPRO;
4459 } 4482 }
4460 4483
4484 /* Given NSEQUENCES objects at the address pointed to by SEQUENCES, return
4485 the length of the shortest sequence. Error if all are circular, or if any
4486 one of them is not a sequence. */
4487 static Elemcount
4488 shortest_length_among_sequences (int nsequences, Lisp_Object *sequences)
4489 {
4490 Elemcount len = EMACS_INT_MAX;
4491 Lisp_Object length;
4492 int i;
4493
4494 for (i = 0; i < nsequences; ++i)
4495 {
4496 if (CONSP (sequences[i]))
4497 {
4498 length = Flist_length (sequences[i]);
4499 if (!NILP (length))
4500 {
4501 len = min (len, XINT (length));
4502 }
4503 }
4504 else
4505 {
4506 CHECK_SEQUENCE (sequences[i]);
4507 length = Flength (sequences[i]);
4508 len = min (len, XINT (length));
4509 }
4510 }
4511
4512 if (NILP (length))
4513 {
4514 signal_circular_list_error (sequences[0]);
4515 }
4516
4517 return len;
4518 }
4519
4461 DEFUN ("mapconcat", Fmapconcat, 3, MANY, 0, /* 4520 DEFUN ("mapconcat", Fmapconcat, 3, MANY, 0, /*
4462 Call FUNCTION on each element of SEQUENCE, and concat results to a string. 4521 Call FUNCTION on each element of SEQUENCE, and concat results to a string.
4463 Between each pair of results, insert SEPARATOR. 4522 Between each pair of results, insert SEPARATOR.
4464 4523
4465 Each result, and SEPARATOR, should be strings. Thus, using " " as SEPARATOR 4524 Each result, and SEPARATOR, should be strings. Thus, using " " as SEPARATOR
4483 EMACS_INT i, nargs0; 4542 EMACS_INT i, nargs0;
4484 4543
4485 args[2] = sequence; 4544 args[2] = sequence;
4486 args[1] = separator; 4545 args[1] = separator;
4487 4546
4488 for (i = 2; i < nargs; ++i) 4547 len = shortest_length_among_sequences (nargs - 2, args + 2);
4489 {
4490 CHECK_SEQUENCE (args[i]);
4491 len = min (len, XINT (Flength (args[i])));
4492 }
4493 4548
4494 if (len == 0) return build_ascstring (""); 4549 if (len == 0) return build_ascstring ("");
4495 4550
4496 nargs0 = len + len - 1; 4551 nargs0 = len + len - 1;
4497 args0 = alloca_array (Lisp_Object, nargs0); 4552 args0 = alloca_array (Lisp_Object, nargs0);
4534 arguments: (FUNCTION SEQUENCE &rest SEQUENCES) 4589 arguments: (FUNCTION SEQUENCE &rest SEQUENCES)
4535 */ 4590 */
4536 (int nargs, Lisp_Object *args)) 4591 (int nargs, Lisp_Object *args))
4537 { 4592 {
4538 Lisp_Object function = args[0]; 4593 Lisp_Object function = args[0];
4539 Elemcount len = EMACS_INT_MAX; 4594 Elemcount len = shortest_length_among_sequences (nargs - 1, args + 1);
4540 Lisp_Object *args0; 4595 Lisp_Object *args0;
4541 int i;
4542
4543 for (i = 1; i < nargs; ++i)
4544 {
4545 CHECK_SEQUENCE (args[i]);
4546 len = min (len, XINT (Flength (args[i])));
4547 }
4548 4596
4549 args0 = alloca_array (Lisp_Object, len); 4597 args0 = alloca_array (Lisp_Object, len);
4550 mapcarX (len, args0, Qnil, function, nargs - 1, args + 1, QmapcarX); 4598 mapcarX (len, args0, Qnil, function, nargs - 1, args + 1, QmapcarX);
4551 4599
4552 return Flist ((int) len, args0); 4600 return Flist ((int) len, args0);
4565 arguments: (FUNCTION SEQUENCE &rest SEQUENCES) 4613 arguments: (FUNCTION SEQUENCE &rest SEQUENCES)
4566 */ 4614 */
4567 (int nargs, Lisp_Object *args)) 4615 (int nargs, Lisp_Object *args))
4568 { 4616 {
4569 Lisp_Object function = args[0]; 4617 Lisp_Object function = args[0];
4570 Elemcount len = EMACS_INT_MAX; 4618 Elemcount len = shortest_length_among_sequences (nargs - 1, args + 1);
4571 Lisp_Object result; 4619 Lisp_Object result = make_vector (len, Qnil);
4620
4572 struct gcpro gcpro1; 4621 struct gcpro gcpro1;
4573 int i;
4574
4575 for (i = 1; i < nargs; ++i)
4576 {
4577 CHECK_SEQUENCE (args[i]);
4578 len = min (len, XINT (Flength (args[i])));
4579 }
4580
4581 result = make_vector (len, Qnil);
4582 GCPRO1 (result); 4622 GCPRO1 (result);
4583 /* Don't pass result as the lisp_object argument, we want mapcarX to protect 4623 /* Don't pass result as the lisp_object argument, we want mapcarX to protect
4584 a single list argument's elements from being garbage-collected. */ 4624 a single list argument's elements from being garbage-collected. */
4585 mapcarX (len, XVECTOR_DATA (result), Qnil, function, nargs - 1, args +1, 4625 mapcarX (len, XVECTOR_DATA (result), Qnil, function, nargs - 1, args +1,
4586 Qmapvector); 4626 Qmapvector);
4600 4640
4601 arguments: (FUNCTION SEQUENCE &rest SEQUENCES) 4641 arguments: (FUNCTION SEQUENCE &rest SEQUENCES)
4602 */ 4642 */
4603 (int nargs, Lisp_Object *args)) 4643 (int nargs, Lisp_Object *args))
4604 { 4644 {
4605 Lisp_Object function = args[0], *result; 4645 Elemcount len = shortest_length_among_sequences (nargs - 1, args + 1);
4606 Elemcount result_len = EMACS_INT_MAX; 4646 Lisp_Object function = args[0], *result = alloca_array (Lisp_Object, len);
4607 int i; 4647
4608 4648 mapcarX (len, result, Qnil, function, nargs - 1, args + 1, Qmapcan);
4609 for (i = 1; i < nargs; ++i)
4610 {
4611 CHECK_SEQUENCE (args[i]);
4612 result_len = min (result_len, XINT (Flength (args[i])));
4613 }
4614
4615 result = alloca_array (Lisp_Object, result_len);
4616 mapcarX (result_len, result, Qnil, function, nargs - 1, args + 1, Qmapcan);
4617 4649
4618 /* #'nconc GCPROs its args in case of signals and error. */ 4650 /* #'nconc GCPROs its args in case of signals and error. */
4619 return Fnconc (result_len, result); 4651 return Fnconc (len, result);
4620 } 4652 }
4621 4653
4622 DEFUN ("mapc", Fmapc, 2, MANY, 0, /* 4654 DEFUN ("mapc", Fmapc, 2, MANY, 0, /*
4623 Call FUNCTION on each element of SEQUENCE. 4655 Call FUNCTION on each element of SEQUENCE.
4624 4656
4635 4667
4636 arguments: (FUNCTION SEQUENCE &rest SEQUENCES) 4668 arguments: (FUNCTION SEQUENCE &rest SEQUENCES)
4637 */ 4669 */
4638 (int nargs, Lisp_Object *args)) 4670 (int nargs, Lisp_Object *args))
4639 { 4671 {
4640 Elemcount len = EMACS_INT_MAX; 4672 Elemcount len = shortest_length_among_sequences (nargs - 1, args + 1);
4641 Lisp_Object sequence = args[1]; 4673 Lisp_Object sequence = args[1];
4642 struct gcpro gcpro1; 4674 struct gcpro gcpro1;
4643 int i;
4644
4645 for (i = 1; i < nargs; ++i)
4646 {
4647 CHECK_SEQUENCE (args[i]);
4648 len = min (len, XINT (Flength (args[i])));
4649 }
4650
4651 /* We need to GCPRO sequence, because mapcarX will modify the 4675 /* We need to GCPRO sequence, because mapcarX will modify the
4652 elements of the args array handed to it, and this may involve 4676 elements of the args array handed to it, and this may involve
4653 elements of sequence getting garbage collected. */ 4677 elements of sequence getting garbage collected. */
4654 GCPRO1 (sequence); 4678 GCPRO1 (sequence);
4655 mapcarX (len, NULL, Qnil, args[0], nargs - 1, args + 1, Qmapc); 4679 mapcarX (len, NULL, Qnil, args[0], nargs - 1, args + 1, Qmapc);
4675 { 4699 {
4676 Lisp_Object type = args[0]; 4700 Lisp_Object type = args[0];
4677 Lisp_Object function = args[1]; 4701 Lisp_Object function = args[1];
4678 Lisp_Object result = Qnil; 4702 Lisp_Object result = Qnil;
4679 Lisp_Object *args0 = NULL; 4703 Lisp_Object *args0 = NULL;
4680 Elemcount len = EMACS_INT_MAX; 4704 Elemcount len = shortest_length_among_sequences (nargs - 2, args + 2);
4681 int i;
4682 struct gcpro gcpro1; 4705 struct gcpro gcpro1;
4683
4684 for (i = 2; i < nargs; ++i)
4685 {
4686 CHECK_SEQUENCE (args[i]);
4687 len = min (len, XINT (Flength (args[i])));
4688 }
4689 4706
4690 if (!NILP (type)) 4707 if (!NILP (type))
4691 { 4708 {
4692 args0 = alloca_array (Lisp_Object, len); 4709 args0 = alloca_array (Lisp_Object, len);
4693 } 4710 }
4740 4757
4741 arguments: (RESULT-SEQUENCE FUNCTION &rest SEQUENCES) 4758 arguments: (RESULT-SEQUENCE FUNCTION &rest SEQUENCES)
4742 */ 4759 */
4743 (int nargs, Lisp_Object *args)) 4760 (int nargs, Lisp_Object *args))
4744 { 4761 {
4745 Elemcount len = EMACS_INT_MAX; 4762 Elemcount len;
4746 Lisp_Object result_sequence = args[0]; 4763 Lisp_Object result_sequence = args[0];
4747 Lisp_Object function = args[1]; 4764 Lisp_Object function = args[1];
4748 int i;
4749 4765
4750 args[0] = function; 4766 args[0] = function;
4751 args[1] = result_sequence; 4767 args[1] = result_sequence;
4752 4768
4753 for (i = 1; i < nargs; ++i) 4769 len = shortest_length_among_sequences (nargs - 1, args + 1);
4754 {
4755 CHECK_SEQUENCE (args[i]);
4756 len = min (len, XINT (Flength (args[i])));
4757 }
4758 4770
4759 mapcarX (len, NULL, result_sequence, function, nargs - 2, args + 2, 4771 mapcarX (len, NULL, result_sequence, function, nargs - 2, args + 2,
4760 Qmap_into); 4772 Qmap_into);
4761 4773
4762 return result_sequence; 4774 return result_sequence;
4774 */ 4786 */
4775 (int nargs, Lisp_Object *args)) 4787 (int nargs, Lisp_Object *args))
4776 { 4788 {
4777 Lisp_Object result = Qnil, 4789 Lisp_Object result = Qnil,
4778 result_ptr = STORE_VOID_IN_LISP ((void *) &result); 4790 result_ptr = STORE_VOID_IN_LISP ((void *) &result);
4779 Elemcount len = EMACS_INT_MAX; 4791 Elemcount len = shortest_length_among_sequences (nargs - 1, args + 1);
4780 int i;
4781
4782 for (i = 1; i < nargs; ++i)
4783 {
4784 CHECK_SEQUENCE (args[i]);
4785 len = min (len, XINT (Flength (args[i])));
4786 }
4787 4792
4788 mapcarX (len, NULL, result_ptr, args[0], nargs - 1, args +1, Qsome); 4793 mapcarX (len, NULL, result_ptr, args[0], nargs - 1, args +1, Qsome);
4789 4794
4790 return result; 4795 return result;
4791 } 4796 }
4801 arguments: (PREDICATE SEQUENCE &rest SEQUENCES) 4806 arguments: (PREDICATE SEQUENCE &rest SEQUENCES)
4802 */ 4807 */
4803 (int nargs, Lisp_Object *args)) 4808 (int nargs, Lisp_Object *args))
4804 { 4809 {
4805 Lisp_Object result = Qt, result_ptr = STORE_VOID_IN_LISP ((void *) &result); 4810 Lisp_Object result = Qt, result_ptr = STORE_VOID_IN_LISP ((void *) &result);
4806 Elemcount len = EMACS_INT_MAX; 4811 Elemcount len = shortest_length_among_sequences (nargs - 1, args + 1);
4807 int i;
4808
4809 for (i = 1; i < nargs; ++i)
4810 {
4811 CHECK_SEQUENCE (args[i]);
4812 len = min (len, XINT (Flength (args[i])));
4813 }
4814 4812
4815 mapcarX (len, NULL, result_ptr, args[0], nargs - 1, args +1, Qevery); 4813 mapcarX (len, NULL, result_ptr, args[0], nargs - 1, args +1, Qevery);
4816 4814
4817 return result; 4815 return result;
4818 } 4816 }
6681 6679
6682 DEFSUBR (Fidentity); 6680 DEFSUBR (Fidentity);
6683 DEFSUBR (Frandom); 6681 DEFSUBR (Frandom);
6684 DEFSUBR (Flength); 6682 DEFSUBR (Flength);
6685 DEFSUBR (Fsafe_length); 6683 DEFSUBR (Fsafe_length);
6684 DEFSUBR (Flist_length);
6686 DEFSUBR (Fstring_equal); 6685 DEFSUBR (Fstring_equal);
6687 DEFSUBR (Fcompare_strings); 6686 DEFSUBR (Fcompare_strings);
6688 DEFSUBR (Fstring_lessp); 6687 DEFSUBR (Fstring_lessp);
6689 DEFSUBR (Fstring_modified_tick); 6688 DEFSUBR (Fstring_modified_tick);
6690 DEFSUBR (Fappend); 6689 DEFSUBR (Fappend);