1 /* 2 * Copyright (c) 2001 by The XFree86 Project, Inc. 3 * 4 * Permission is hereby granted, free of charge, to any person obtaining a 5 * copy of this software and associated documentation files (the "Software"), 6 * to deal in the Software without restriction, including without limitation 7 * the rights to use, copy, modify, merge, publish, distribute, sublicense, 8 * and/or sell copies of the Software, and to permit persons to whom the 9 * Software is furnished to do so, subject to the following conditions: 10 * 11 * The above copyright notice and this permission notice shall be included in 12 * all copies or substantial portions of the Software. 13 * 14 * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15 * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 17 * THE XFREE86 PROJECT BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 18 * WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF 19 * OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 20 * SOFTWARE. 21 * 22 * Except as contained in this notice, the name of the XFree86 Project shall 23 * not be used in advertising or otherwise to promote the sale, use or other 24 * dealings in this Software without prior written authorization from the 25 * XFree86 Project. 26 * 27 * Author: Paulo Csar Pereira de Andrade 28 */ 29 30 /* $XdotOrg: xc/programs/xedit/lisp/string.c,v 1.2 2004/04/23 19:54:44 eich Exp $ */ 31 /* $XFree86: xc/programs/xedit/lisp/string.c,v 1.24tsi Exp $ */ 32 33 #include "lisp/helper.h" 34 #include "lisp/read.h" 35 #include "lisp/string.h" 36 #include "lisp/private.h" 37 #include <ctype.h> 38 39 #define CHAR_LESS 1 40 #define CHAR_LESS_EQUAL 2 41 #define CHAR_EQUAL 3 42 #define CHAR_GREATER_EQUAL 4 43 #define CHAR_GREATER 5 44 #define CHAR_NOT_EQUAL 6 45 46 #define CHAR_ALPHAP 1 47 #define CHAR_DOWNCASE 2 48 #define CHAR_UPCASE 3 49 #define CHAR_INT 4 50 #define CHAR_BOTHP 5 51 #define CHAR_UPPERP 6 52 #define CHAR_LOWERP 7 53 #define CHAR_GRAPHICP 8 54 55 #ifndef MIN 56 #define MIN(a, b) ((a) < (b) ? (a) : (b)) 57 #endif 58 59 /* 60 * Prototypes 61 */ 62 static LispObj *LispCharCompare(LispBuiltin*, int, int); 63 static LispObj *LispStringCompare(LispBuiltin*, int, int); 64 static LispObj *LispCharOp(LispBuiltin*, int); 65 static LispObj *LispStringTrim(LispBuiltin*, int, int, int); 66 static LispObj *LispStringUpcase(LispBuiltin*, int); 67 static LispObj *LispStringDowncase(LispBuiltin*, int); 68 static LispObj *LispStringCapitalize(LispBuiltin*, int); 69 70 /* 71 * Implementation 72 */ 73 static LispObj * 74 LispCharCompare(LispBuiltin *builtin, int operation, int ignore_case) 75 { 76 LispObj *object; 77 int cmp, value, next_value; 78 79 LispObj *character, *more_characters; 80 81 more_characters = ARGUMENT(1); 82 character = ARGUMENT(0); 83 84 CHECK_SCHAR(character); 85 value = SCHAR_VALUE(character); 86 if (ignore_case && islower(value)) 87 value = toupper(value); 88 89 if (!CONSP(more_characters)) 90 return (T); 91 92 /* First check if all parameters are characters */ 93 for (object = more_characters; CONSP(object); object = CDR(object)) 94 CHECK_SCHAR(CAR(object)); 95 96 /* All characters in list must be different */ 97 if (operation == CHAR_NOT_EQUAL) { 98 /* Compare all characters */ 99 do { 100 for (object = more_characters; CONSP(object); object = CDR(object)) { 101 character = CAR(object); 102 next_value = SCHAR_VALUE(character); 103 if (ignore_case && islower(next_value)) 104 next_value = toupper(next_value); 105 if (value == next_value) 106 return (NIL); 107 } 108 value = SCHAR_VALUE(CAR(more_characters)); 109 if (ignore_case && islower(value)) 110 value = toupper(value); 111 more_characters = CDR(more_characters); 112 } while (CONSP(more_characters)); 113 114 return (T); 115 } 116 117 /* Linearly compare characters */ 118 for (; CONSP(more_characters); more_characters = CDR(more_characters)) { 119 character = CAR(more_characters); 120 next_value = SCHAR_VALUE(character); 121 if (ignore_case && islower(next_value)) 122 next_value = toupper(next_value); 123 124 switch (operation) { 125 case CHAR_LESS: cmp = value < next_value; break; 126 case CHAR_LESS_EQUAL: cmp = value <= next_value; break; 127 case CHAR_EQUAL: cmp = value == next_value; break; 128 case CHAR_GREATER_EQUAL: cmp = value >= next_value; break; 129 case CHAR_GREATER: cmp = value > next_value; break; 130 default: cmp = 0; break; 131 } 132 133 if (!cmp) 134 return (NIL); 135 value = next_value; 136 } 137 138 return (T); 139 } 140 141 LispObj * 142 Lisp_CharLess(LispBuiltin *builtin) 143 /* 144 char< character &rest more-characters 145 */ 146 { 147 return (LispCharCompare(builtin, CHAR_LESS, 0)); 148 } 149 150 LispObj * 151 Lisp_CharLessEqual(LispBuiltin *builtin) 152 /* 153 char<= character &rest more-characters 154 */ 155 { 156 return (LispCharCompare(builtin, CHAR_LESS_EQUAL, 0)); 157 } 158 159 LispObj * 160 Lisp_CharEqual_(LispBuiltin *builtin) 161 /* 162 char= character &rest more-characters 163 */ 164 { 165 return (LispCharCompare(builtin, CHAR_EQUAL, 0)); 166 } 167 168 LispObj * 169 Lisp_CharGreater(LispBuiltin *builtin) 170 /* 171 char> character &rest more-characters 172 */ 173 { 174 return (LispCharCompare(builtin, CHAR_GREATER, 0)); 175 } 176 177 LispObj * 178 Lisp_CharGreaterEqual(LispBuiltin *builtin) 179 /* 180 char>= character &rest more-characters 181 */ 182 { 183 return (LispCharCompare(builtin, CHAR_GREATER_EQUAL, 0)); 184 } 185 186 LispObj * 187 Lisp_CharNotEqual_(LispBuiltin *builtin) 188 /* 189 char/= character &rest more-characters 190 */ 191 { 192 return (LispCharCompare(builtin, CHAR_NOT_EQUAL, 0)); 193 } 194 195 LispObj * 196 Lisp_CharLessp(LispBuiltin *builtin) 197 /* 198 char-lessp character &rest more-characters 199 */ 200 { 201 return (LispCharCompare(builtin, CHAR_LESS, 1)); 202 } 203 204 LispObj * 205 Lisp_CharNotGreaterp(LispBuiltin *builtin) 206 /* 207 char-not-greaterp character &rest more-characters 208 */ 209 { 210 return (LispCharCompare(builtin, CHAR_LESS_EQUAL, 1)); 211 } 212 213 LispObj * 214 Lisp_CharEqual(LispBuiltin *builtin) 215 /* 216 char-equalp character &rest more-characters 217 */ 218 { 219 return (LispCharCompare(builtin, CHAR_EQUAL, 1)); 220 } 221 222 LispObj * 223 Lisp_CharGreaterp(LispBuiltin *builtin) 224 /* 225 char-greaterp character &rest more-characters 226 */ 227 { 228 return (LispCharCompare(builtin, CHAR_GREATER, 1)); 229 } 230 231 LispObj * 232 Lisp_CharNotLessp(LispBuiltin *builtin) 233 /* 234 char-not-lessp &rest more-characters 235 */ 236 { 237 return (LispCharCompare(builtin, CHAR_GREATER_EQUAL, 1)); 238 } 239 240 LispObj * 241 Lisp_CharNotEqual(LispBuiltin *builtin) 242 /* 243 char-not-equal character &rest more-characters 244 */ 245 { 246 return (LispCharCompare(builtin, CHAR_NOT_EQUAL, 1)); 247 } 248 249 static LispObj * 250 LispCharOp(LispBuiltin *builtin, int operation) 251 { 252 int value; 253 LispObj *result, *character; 254 255 character = ARGUMENT(0); 256 CHECK_SCHAR(character); 257 value = (int)SCHAR_VALUE(character); 258 259 switch (operation) { 260 case CHAR_ALPHAP: 261 result = isalpha(value) ? T : NIL; 262 break; 263 case CHAR_DOWNCASE: 264 result = SCHAR(tolower(value)); 265 break; 266 case CHAR_UPCASE: 267 result = SCHAR(toupper(value)); 268 break; 269 case CHAR_INT: 270 result = FIXNUM(value); 271 break; 272 case CHAR_BOTHP: 273 result = isupper(value) || islower(value) ? T : NIL; 274 break; 275 case CHAR_UPPERP: 276 result = isupper(value) ? T : NIL; 277 break; 278 case CHAR_LOWERP: 279 result = islower(value) ? T : NIL; 280 break; 281 case CHAR_GRAPHICP: 282 result = value == ' ' || isgraph(value) ? T : NIL; 283 break; 284 default: 285 result = NIL; 286 break; 287 } 288 289 return (result); 290 } 291 292 LispObj * 293 Lisp_AlphaCharP(LispBuiltin *builtin) 294 /* 295 alpha-char-p char 296 */ 297 { 298 return (LispCharOp(builtin, CHAR_ALPHAP)); 299 } 300 301 LispObj * 302 Lisp_CharDowncase(LispBuiltin *builtin) 303 /* 304 char-downcase character 305 */ 306 { 307 return (LispCharOp(builtin, CHAR_DOWNCASE)); 308 } 309 310 LispObj * 311 Lisp_CharInt(LispBuiltin *builtin) 312 /* 313 char-int character 314 char-code character 315 */ 316 { 317 return (LispCharOp(builtin, CHAR_INT)); 318 } 319 320 LispObj * 321 Lisp_CharUpcase(LispBuiltin *builtin) 322 /* 323 char-upcase character 324 */ 325 { 326 return (LispCharOp(builtin, CHAR_UPCASE)); 327 } 328 329 LispObj * 330 Lisp_BothCaseP(LispBuiltin *builtin) 331 /* 332 both-case-p character 333 */ 334 { 335 return (LispCharOp(builtin, CHAR_BOTHP)); 336 } 337 338 LispObj * 339 Lisp_UpperCaseP(LispBuiltin *builtin) 340 /* 341 upper-case-p character 342 */ 343 { 344 return (LispCharOp(builtin, CHAR_UPPERP)); 345 } 346 347 LispObj * 348 Lisp_LowerCaseP(LispBuiltin *builtin) 349 /* 350 upper-case-p character 351 */ 352 { 353 return (LispCharOp(builtin, CHAR_LOWERP)); 354 } 355 356 LispObj * 357 Lisp_GraphicCharP(LispBuiltin *builtin) 358 /* 359 graphic-char-p char 360 */ 361 { 362 return (LispCharOp(builtin, CHAR_GRAPHICP)); 363 } 364 365 LispObj * 366 Lisp_Char(LispBuiltin *builtin) 367 /* 368 char string index 369 schar simple-string index 370 */ 371 { 372 unsigned char *string; 373 long offset, length; 374 375 LispObj *ostring, *oindex; 376 377 oindex = ARGUMENT(1); 378 ostring = ARGUMENT(0); 379 380 CHECK_STRING(ostring); 381 CHECK_INDEX(oindex); 382 offset = FIXNUM_VALUE(oindex); 383 string = (unsigned char*)THESTR(ostring); 384 length = STRLEN(ostring); 385 386 if (offset >= length) 387 LispDestroy("%s: index %ld too large for string length %ld", 388 STRFUN(builtin), offset, length); 389 390 return (SCHAR(string[offset])); 391 } 392 393 /* helper function for setf 394 * DONT explicitly call. Non standard function 395 */ 396 LispObj * 397 Lisp_XeditCharStore(LispBuiltin *builtin) 398 /* 399 xedit::char-store string index value 400 */ 401 { 402 int character; 403 long offset, length; 404 LispObj *ostring, *oindex, *ovalue; 405 406 ovalue = ARGUMENT(2); 407 oindex = ARGUMENT(1); 408 ostring = ARGUMENT(0); 409 410 CHECK_STRING(ostring); 411 CHECK_INDEX(oindex); 412 length = STRLEN(ostring); 413 offset = FIXNUM_VALUE(oindex); 414 if (offset >= length) 415 LispDestroy("%s: index %ld too large for string length %ld", 416 STRFUN(builtin), offset, length); 417 CHECK_SCHAR(ovalue); 418 CHECK_STRING_WRITABLE(ostring); 419 420 character = SCHAR_VALUE(ovalue); 421 422 if (character < 0 || character > 255) 423 LispDestroy("%s: cannot represent character %d", 424 STRFUN(builtin), character); 425 426 THESTR(ostring)[offset] = character; 427 428 return (ovalue); 429 } 430 431 LispObj * 432 Lisp_Character(LispBuiltin *builtin) 433 /* 434 character object 435 */ 436 { 437 LispObj *object; 438 439 object = ARGUMENT(0); 440 441 return (LispCharacterCoerce(builtin, object)); 442 } 443 444 LispObj * 445 Lisp_Characterp(LispBuiltin *builtin) 446 /* 447 characterp object 448 */ 449 { 450 LispObj *object; 451 452 object = ARGUMENT(0); 453 454 return (SCHARP(object) ? T : NIL); 455 } 456 457 LispObj * 458 Lisp_DigitChar(LispBuiltin *builtin) 459 /* 460 digit-char weight &optional radix 461 */ 462 { 463 long radix = 10, weight; 464 LispObj *oweight, *oradix, *result = NIL; 465 466 oradix = ARGUMENT(1); 467 oweight = ARGUMENT(0); 468 469 CHECK_FIXNUM(oweight); 470 weight = FIXNUM_VALUE(oweight); 471 472 if (oradix != UNSPEC) { 473 CHECK_INDEX(oradix); 474 radix = FIXNUM_VALUE(oradix); 475 } 476 if (radix < 2 || radix > 36) 477 LispDestroy("%s: radix must be >= 2 and <= 36, not %ld", 478 STRFUN(builtin), radix); 479 480 if (weight >= 0 && weight < radix) { 481 if (weight < 9) 482 weight += '0'; 483 else 484 weight += 'A' - 10; 485 result = SCHAR(weight); 486 } 487 488 return (result); 489 } 490 491 LispObj * 492 Lisp_DigitCharP(LispBuiltin *builtin) 493 /* 494 digit-char-p character &optional radix 495 */ 496 { 497 long radix = 10, character; 498 LispObj *ochar, *oradix, *result = NIL; 499 500 oradix = ARGUMENT(1); 501 ochar = ARGUMENT(0); 502 503 CHECK_SCHAR(ochar); 504 character = SCHAR_VALUE(ochar); 505 if (oradix != UNSPEC) { 506 CHECK_INDEX(oradix); 507 radix = FIXNUM_VALUE(oradix); 508 } 509 if (radix < 2 || radix > 36) 510 LispDestroy("%s: radix must be >= 2 and <= 36, not %ld", 511 STRFUN(builtin), radix); 512 513 if (character >= '0' && character <= '9') 514 character -= '0'; 515 else if (character >= 'A' && character <= 'Z') 516 character -= 'A' - 10; 517 else if (character >= 'a' && character <= 'z') 518 character -= 'a' - 10; 519 if (character < radix) 520 result = FIXNUM(character); 521 522 return (result); 523 } 524 525 LispObj * 526 Lisp_IntChar(LispBuiltin *builtin) 527 /* 528 int-char integer 529 code-char integer 530 */ 531 { 532 long character = 0; 533 LispObj *integer; 534 535 integer = ARGUMENT(0); 536 537 CHECK_FIXNUM(integer); 538 character = FIXNUM_VALUE(integer); 539 540 return (character >= 0 && character < 0xff ? SCHAR(character) : NIL); 541 } 542 543 /* XXX ignoring element-type */ 544 LispObj * 545 Lisp_MakeString(LispBuiltin *builtin) 546 /* 547 make-string size &key initial-element element-type 548 */ 549 { 550 long length; 551 char *string, initial; 552 553 LispObj *size, *initial_element; 554 555 initial_element = ARGUMENT(1); 556 size = ARGUMENT(0); 557 558 CHECK_INDEX(size); 559 length = FIXNUM_VALUE(size); 560 if (initial_element != UNSPEC) { 561 CHECK_SCHAR(initial_element); 562 initial = SCHAR_VALUE(initial_element); 563 } 564 else 565 initial = 0; 566 567 string = LispMalloc(length + 1); 568 memset(string, initial, length); 569 string[length] = '\0'; 570 571 return (LSTRING2(string, length)); 572 } 573 574 LispObj * 575 Lisp_ParseInteger(LispBuiltin *builtin) 576 /* 577 parse-integer string &key start end radix junk-allowed 578 */ 579 { 580 GC_ENTER(); 581 char *ptr, *string; 582 int character, junk, sign, overflow; 583 long i, start, end, radix, length, integer, check; 584 LispObj *result; 585 586 LispObj *ostring, *ostart, *oend, *oradix, *junk_allowed; 587 588 junk_allowed = ARGUMENT(4); 589 oradix = ARGUMENT(3); 590 oend = ARGUMENT(2); 591 ostart = ARGUMENT(1); 592 ostring = ARGUMENT(0); 593 594 start = end = radix = 0; 595 result = NIL; 596 597 CHECK_STRING(ostring); 598 LispCheckSequenceStartEnd(builtin, ostring, ostart, oend, 599 &start, &end, &length); 600 string = THESTR(ostring); 601 if (oradix == UNSPEC) 602 radix = 10; 603 else { 604 CHECK_INDEX(oradix); 605 radix = FIXNUM_VALUE(oradix); 606 } 607 if (radix < 2 || radix > 36) 608 LispDestroy("%s: :RADIX %ld must be in the range 2 to 36", 609 STRFUN(builtin), radix); 610 611 integer = check = 0; 612 ptr = string + start; 613 sign = overflow = 0; 614 615 /* Skip leading white spaces */ 616 for (i = start; i < end && *ptr && isspace(*ptr); ptr++, i++) 617 ; 618 619 /* Check for sign specification */ 620 if (i < end && (*ptr == '-' || *ptr == '+')) { 621 sign = *ptr == '-'; 622 ++ptr; 623 ++i; 624 } 625 626 for (junk = 0; i < end; i++, ptr++) { 627 character = *ptr; 628 if (islower(character)) 629 character = toupper(character); 630 if (character >= '0' && character <= '9') { 631 if (character - '0' >= radix) 632 junk = 1; 633 else { 634 check = integer; 635 integer = integer * radix + character - '0'; 636 } 637 } 638 else if (character >= 'A' && character <= 'Z') { 639 if (character - 'A' + 10 >= radix) 640 junk = 1; 641 else { 642 check = integer; 643 integer = integer * radix + character - 'A' + 10; 644 } 645 } 646 else { 647 if (isspace(character)) 648 break; 649 junk = 1; 650 } 651 652 if (junk) 653 break; 654 655 if (!overflow && check > integer) 656 overflow = 1; 657 /* keep looping just to count read bytes */ 658 } 659 660 if (!junk) 661 /* Skip white spaces */ 662 for (; i < end && *ptr && isspace(*ptr); ptr++, i++) 663 ; 664 665 if ((junk || ptr == string) && 666 (junk_allowed == UNSPEC || junk_allowed == NIL)) 667 LispDestroy("%s: %s has a bad integer representation", 668 STRFUN(builtin), STROBJ(ostring)); 669 else if (ptr == string) 670 result = NIL; 671 else if (overflow) { 672 mpi *bigi = LispMalloc(sizeof(mpi)); 673 char *str; 674 675 length = end - start + sign; 676 str = LispMalloc(length + 1); 677 678 strncpy(str, string - sign, length + sign); 679 str[length + sign] = '\0'; 680 mpi_init(bigi); 681 mpi_setstr(bigi, str, radix); 682 LispFree(str); 683 result = BIGNUM(bigi); 684 } 685 else 686 result = INTEGER(sign ? -integer : integer); 687 688 GC_PROTECT(result); 689 RETURN(0) = FIXNUM(i); 690 RETURN_COUNT = 1; 691 GC_LEAVE(); 692 693 return (result); 694 } 695 696 LispObj * 697 Lisp_String(LispBuiltin *builtin) 698 /* 699 string object 700 */ 701 { 702 LispObj *object; 703 704 object = ARGUMENT(0); 705 706 return (LispStringCoerce(builtin, object)); 707 } 708 709 LispObj * 710 Lisp_Stringp(LispBuiltin *builtin) 711 /* 712 stringp object 713 */ 714 { 715 LispObj *object; 716 717 object = ARGUMENT(0); 718 719 return (STRINGP(object) ? T : NIL); 720 } 721 722 /* XXX preserve-whitespace is being ignored */ 723 LispObj * 724 Lisp_ReadFromString(LispBuiltin *builtin) 725 /* 726 read-from-string string &optional eof-error-p eof-value &key start end preserve-whitespace 727 */ 728 { 729 GC_ENTER(); 730 char *string; 731 LispObj *stream, *result; 732 long length, start, end, bytes_read; 733 734 LispObj *ostring, *eof_error_p, *eof_value, *ostart, *oend; 735 736 oend = ARGUMENT(4); 737 ostart = ARGUMENT(3); 738 eof_value = ARGUMENT(2); 739 eof_error_p = ARGUMENT(1); 740 ostring = ARGUMENT(0); 741 742 CHECK_STRING(ostring); 743 string = THESTR(ostring); 744 LispCheckSequenceStartEnd(builtin, ostring, ostart, oend, 745 &start, &end, &length); 746 747 if (start > 0 || end < length) 748 length = end - start; 749 stream = LSTRINGSTREAM(string + start, STREAM_READ, length); 750 751 if (eof_value == UNSPEC) 752 eof_value = NIL; 753 754 LispPushInput(stream); 755 result = LispRead(); 756 /* stream->data.stream.source.string->input is 757 * the offset of the last byte read in string */ 758 bytes_read = stream->data.stream.source.string->input; 759 LispPopInput(stream); 760 761 if (result == NULL) { 762 if (eof_error_p == NIL) 763 result = eof_value; 764 else 765 LispDestroy("%s: unexpected end of input", STRFUN(builtin)); 766 } 767 768 GC_PROTECT(result); 769 RETURN(0) = FIXNUM(start + bytes_read); 770 RETURN_COUNT = 1; 771 GC_LEAVE(); 772 773 return (result); 774 } 775 776 static LispObj * 777 LispStringTrim(LispBuiltin *builtin, int left, int right, int inplace) 778 /* 779 string-{,left-,right-}trim character-bag string 780 */ 781 { 782 unsigned char *string; 783 long start, end, length; 784 785 LispObj *ochars, *ostring; 786 787 ostring = ARGUMENT(1); 788 ochars = ARGUMENT(0); 789 790 if (!POINTERP(ochars) || !(XSTRINGP(ochars) || XCONSP(ochars))) { 791 if (ARRAYP(ochars) && ochars->data.array.rank == 1) 792 ochars = ochars->data.array.list; 793 else 794 LispDestroy("%s: %s is not a sequence", 795 STRFUN(builtin), STROBJ(ochars)); 796 } 797 CHECK_STRING(ostring); 798 799 string = (unsigned char*)THESTR(ostring); 800 length = STRLEN(ostring); 801 802 start = 0; 803 end = length; 804 805 if (XSTRINGP(ochars)) { 806 unsigned char *chars = (unsigned char*)THESTR(ochars); 807 long i, clength = STRLEN(ochars); 808 809 if (left) { 810 for (; start < end; start++) { 811 for (i = 0; i < clength; i++) 812 if (string[start] == chars[i]) 813 break; 814 if (i >= clength) 815 break; 816 } 817 } 818 if (right) { 819 for (--end; end >= 0; end--) { 820 for (i = 0; i < clength; i++) 821 if (string[end] == chars[i]) 822 break; 823 if (i >= clength) 824 break; 825 } 826 ++end; 827 } 828 } 829 else { 830 LispObj *ochar, *list; 831 832 if (left) { 833 for (; start < end; start++) { 834 for (list = ochars; CONSP(list); list = CDR(list)) { 835 ochar = CAR(list); 836 if (SCHARP(ochar) && string[start] == SCHAR_VALUE(ochar)) 837 break; 838 } 839 if (!CONSP(list)) 840 break; 841 } 842 } 843 if (right) { 844 for (--end; end >= 0; end--) { 845 for (list = ochars; CONSP(list); list = CDR(list)) { 846 ochar = CAR(list); 847 if (SCHARP(ochar) && string[end] == SCHAR_VALUE(ochar)) 848 break; 849 } 850 if (!CONSP(list)) 851 break; 852 } 853 ++end; 854 } 855 } 856 857 if (start == 0 && end == length) 858 return (ostring); 859 860 length = end - start; 861 862 if (inplace) { 863 CHECK_STRING_WRITABLE(ostring); 864 memmove(string, string + start, length); 865 string[length] = '\0'; 866 STRLEN(ostring) = length; 867 } 868 else { 869 string = LispMalloc(length + 1); 870 memcpy(string, THESTR(ostring) + start, length); 871 string[length] = '\0'; 872 ostring = LSTRING2((char*)string, length); 873 } 874 875 return (ostring); 876 } 877 878 LispObj * 879 Lisp_StringTrim(LispBuiltin *builtin) 880 /* 881 string-trim character-bag string 882 */ 883 { 884 return (LispStringTrim(builtin, 1, 1, 0)); 885 } 886 887 LispObj * 888 Lisp_NstringTrim(LispBuiltin *builtin) 889 /* 890 ext::nstring-trim character-bag string 891 */ 892 { 893 return (LispStringTrim(builtin, 1, 1, 1)); 894 } 895 896 LispObj * 897 Lisp_StringLeftTrim(LispBuiltin *builtin) 898 /* 899 string-left-trim character-bag string 900 */ 901 { 902 return (LispStringTrim(builtin, 1, 0, 0)); 903 } 904 905 LispObj * 906 Lisp_NstringLeftTrim(LispBuiltin *builtin) 907 /* 908 ext::nstring-left-trim character-bag string 909 */ 910 { 911 return (LispStringTrim(builtin, 1, 0, 1)); 912 } 913 914 LispObj * 915 Lisp_StringRightTrim(LispBuiltin *builtin) 916 /* 917 string-right-trim character-bag string 918 */ 919 { 920 return (LispStringTrim(builtin, 0, 1, 0)); 921 } 922 923 LispObj * 924 Lisp_NstringRightTrim(LispBuiltin *builtin) 925 /* 926 ext::nstring-right-trim character-bag string 927 */ 928 { 929 return (LispStringTrim(builtin, 0, 1, 1)); 930 } 931 932 static LispObj * 933 LispStringCompare(LispBuiltin *builtin, int function, int ignore_case) 934 { 935 int cmp1, cmp2; 936 LispObj *fixnum; 937 unsigned char *string1, *string2; 938 long start1, end1, start2, end2, offset, length; 939 940 LispGetStringArgs(builtin, (char**)&string1, (char**)&string2, 941 &start1, &end1, &start2, &end2); 942 943 string1 += start1; 944 string2 += start2; 945 946 if (function == CHAR_EQUAL) { 947 length = end1 - start1; 948 949 if (length != (end2 - start2)) 950 return (NIL); 951 952 if (!ignore_case) 953 return (memcmp(string1, string2, length) ? NIL : T); 954 955 for (; length; length--, string1++, string2++) 956 if (toupper(*string1) != toupper(*string2)) 957 return (NIL); 958 return (T); 959 } 960 961 end1 -= start1; 962 end2 -= start2; 963 length = MIN(end1, end2); 964 for (offset = 0; 965 offset < length; 966 string1++, string2++, offset++, start1++, start2++) { 967 cmp1 = *string1; 968 cmp2 = *string2; 969 if (ignore_case) { 970 cmp1 = toupper(cmp1); 971 cmp2 = toupper(cmp2); 972 } 973 if (cmp1 != cmp2) { 974 fixnum = FIXNUM(start1); 975 switch (function) { 976 case CHAR_LESS: 977 return ((cmp1 < cmp2) ? fixnum : NIL); 978 case CHAR_LESS_EQUAL: 979 return ((cmp1 <= cmp2) ? fixnum : NIL); 980 case CHAR_NOT_EQUAL: 981 return (fixnum); 982 case CHAR_GREATER_EQUAL: 983 return ((cmp1 >= cmp2) ? fixnum : NIL); 984 case CHAR_GREATER: 985 return ((cmp1 > cmp2) ? fixnum : NIL); 986 } 987 } 988 } 989 990 fixnum = FIXNUM(start1); 991 switch (function) { 992 case CHAR_LESS: 993 return (start1 >= end1 && start2 < end2 ? fixnum : NIL); 994 case CHAR_LESS_EQUAL: 995 return (start1 >= end1 ? fixnum : NIL); 996 case CHAR_NOT_EQUAL: 997 return (start1 >= end1 && start2 >= end2 ? NIL : fixnum); 998 case CHAR_GREATER_EQUAL: 999 return (start2 >= end2 ? fixnum : NIL); 1000 case CHAR_GREATER: 1001 return (start2 >= end2 && start1 < end1 ? fixnum : NIL); 1002 } 1003 1004 return (NIL); 1005 } 1006 1007 LispObj * 1008 Lisp_StringEqual_(LispBuiltin *builtin) 1009 /* 1010 string= string1 string2 &key start1 end1 start2 end2 1011 */ 1012 { 1013 return (LispStringCompare(builtin, CHAR_EQUAL, 0)); 1014 } 1015 1016 LispObj * 1017 Lisp_StringLess(LispBuiltin *builtin) 1018 /* 1019 string< string1 string2 &key start1 end1 start2 end2 1020 */ 1021 { 1022 return (LispStringCompare(builtin, CHAR_LESS, 0)); 1023 } 1024 1025 LispObj * 1026 Lisp_StringGreater(LispBuiltin *builtin) 1027 /* 1028 string> string1 string2 &key start1 end1 start2 end2 1029 */ 1030 { 1031 return (LispStringCompare(builtin, CHAR_GREATER, 0)); 1032 } 1033 1034 LispObj * 1035 Lisp_StringLessEqual(LispBuiltin *builtin) 1036 /* 1037 string<= string1 string2 &key start1 end1 start2 end2 1038 */ 1039 { 1040 return (LispStringCompare(builtin, CHAR_LESS_EQUAL, 0)); 1041 } 1042 1043 LispObj * 1044 Lisp_StringGreaterEqual(LispBuiltin *builtin) 1045 /* 1046 string>= string1 string2 &key start1 end1 start2 end2 1047 */ 1048 { 1049 return (LispStringCompare(builtin, CHAR_GREATER_EQUAL, 0)); 1050 } 1051 1052 LispObj * 1053 Lisp_StringNotEqual_(LispBuiltin *builtin) 1054 /* 1055 string/= string1 string2 &key start1 end1 start2 end2 1056 */ 1057 { 1058 return (LispStringCompare(builtin, CHAR_NOT_EQUAL, 0)); 1059 } 1060 1061 LispObj * 1062 Lisp_StringEqual(LispBuiltin *builtin) 1063 /* 1064 string-equal string1 string2 &key start1 end1 start2 end2 1065 */ 1066 { 1067 return (LispStringCompare(builtin, CHAR_EQUAL, 1)); 1068 } 1069 1070 LispObj * 1071 Lisp_StringLessp(LispBuiltin *builtin) 1072 /* 1073 string-lessp string1 string2 &key start1 end1 start2 end2 1074 */ 1075 { 1076 return (LispStringCompare(builtin, CHAR_LESS, 1)); 1077 } 1078 1079 LispObj * 1080 Lisp_StringGreaterp(LispBuiltin *builtin) 1081 /* 1082 string-greaterp string1 string2 &key start1 end1 start2 end2 1083 */ 1084 { 1085 return (LispStringCompare(builtin, CHAR_GREATER, 1)); 1086 } 1087 1088 LispObj * 1089 Lisp_StringNotGreaterp(LispBuiltin *builtin) 1090 /* 1091 string-not-greaterp string1 string2 &key start1 end1 start2 end2 1092 */ 1093 { 1094 return (LispStringCompare(builtin, CHAR_LESS_EQUAL, 1)); 1095 } 1096 1097 LispObj * 1098 Lisp_StringNotLessp(LispBuiltin *builtin) 1099 /* 1100 string-not-lessp string1 string2 &key start1 end1 start2 end2 1101 */ 1102 { 1103 return (LispStringCompare(builtin, CHAR_GREATER_EQUAL, 1)); 1104 } 1105 1106 LispObj * 1107 Lisp_StringNotEqual(LispBuiltin *builtin) 1108 /* 1109 string-not-equal string1 string2 &key start1 end1 start2 end2 1110 */ 1111 { 1112 return (LispStringCompare(builtin, CHAR_NOT_EQUAL, 1)); 1113 } 1114 1115 LispObj * 1116 LispStringUpcase(LispBuiltin *builtin, int inplace) 1117 /* 1118 string-upcase string &key start end 1119 nstring-upcase string &key start end 1120 */ 1121 { 1122 LispObj *result; 1123 char *string, *newstring; 1124 long start, end, length, offset; 1125 1126 LispObj *ostring, *ostart, *oend; 1127 1128 oend = ARGUMENT(2); 1129 ostart = ARGUMENT(1); 1130 ostring = ARGUMENT(0); 1131 CHECK_STRING(ostring); 1132 LispCheckSequenceStartEnd(builtin, ostring, ostart, oend, 1133 &start, &end, &offset); 1134 result = ostring; 1135 string = THESTR(ostring); 1136 length = STRLEN(ostring); 1137 1138 /* first check if something need to be done */ 1139 for (offset = start; offset < end; offset++) 1140 if (string[offset] != toupper(string[offset])) 1141 break; 1142 1143 if (offset >= end) 1144 return (result); 1145 1146 if (inplace) { 1147 CHECK_STRING_WRITABLE(ostring); 1148 newstring = string; 1149 } 1150 else { 1151 /* upcase a copy of argument */ 1152 newstring = LispMalloc(length + 1); 1153 if (offset) 1154 memcpy(newstring, string, offset); 1155 if (length > end) 1156 memcpy(newstring + end, string + end, length - end); 1157 newstring[length] = '\0'; 1158 } 1159 1160 for (; offset < end; offset++) 1161 newstring[offset] = toupper(string[offset]); 1162 1163 if (!inplace) 1164 result = LSTRING2(newstring, length); 1165 1166 return (result); 1167 } 1168 1169 LispObj * 1170 Lisp_StringUpcase(LispBuiltin *builtin) 1171 /* 1172 string-upcase string &key start end 1173 */ 1174 { 1175 return (LispStringUpcase(builtin, 0)); 1176 } 1177 1178 LispObj * 1179 Lisp_NstringUpcase(LispBuiltin *builtin) 1180 /* 1181 nstring-upcase string &key start end 1182 */ 1183 { 1184 return (LispStringUpcase(builtin, 1)); 1185 } 1186 1187 LispObj * 1188 LispStringDowncase(LispBuiltin *builtin, int inplace) 1189 /* 1190 string-downcase string &key start end 1191 nstring-downcase string &key start end 1192 */ 1193 { 1194 LispObj *result; 1195 char *string, *newstring; 1196 long start, end, length, offset; 1197 1198 LispObj *ostring, *ostart, *oend; 1199 1200 oend = ARGUMENT(2); 1201 ostart = ARGUMENT(1); 1202 ostring = ARGUMENT(0); 1203 CHECK_STRING(ostring); 1204 LispCheckSequenceStartEnd(builtin, ostring, ostart, oend, 1205 &start, &end, &offset); 1206 result = ostring; 1207 string = THESTR(ostring); 1208 length = STRLEN(ostring); 1209 1210 /* first check if something need to be done */ 1211 for (offset = start; offset < end; offset++) 1212 if (string[offset] != tolower(string[offset])) 1213 break; 1214 1215 if (offset >= end) 1216 return (result); 1217 1218 if (inplace) { 1219 CHECK_STRING_WRITABLE(ostring); 1220 newstring = string; 1221 } 1222 else { 1223 /* downcase a copy of argument */ 1224 newstring = LispMalloc(length + 1); 1225 if (offset) 1226 memcpy(newstring, string, offset); 1227 if (length > end) 1228 memcpy(newstring + end, string + end, length - end); 1229 newstring[length] = '\0'; 1230 } 1231 for (; offset < end; offset++) 1232 newstring[offset] = tolower(string[offset]); 1233 1234 if (!inplace) 1235 result = LSTRING2(newstring, length); 1236 1237 return (result); 1238 } 1239 1240 LispObj * 1241 Lisp_StringDowncase(LispBuiltin *builtin) 1242 /* 1243 string-downcase string &key start end 1244 */ 1245 { 1246 return (LispStringDowncase(builtin, 0)); 1247 } 1248 1249 LispObj * 1250 Lisp_NstringDowncase(LispBuiltin *builtin) 1251 /* 1252 nstring-downcase string &key start end 1253 */ 1254 { 1255 return (LispStringDowncase(builtin, 1)); 1256 } 1257 1258 LispObj * 1259 LispStringCapitalize(LispBuiltin *builtin, int inplace) 1260 /* 1261 string-capitalize string &key start end 1262 nstring-capitalize string &key start end 1263 */ 1264 { 1265 LispObj *result; 1266 char *string, *newstring; 1267 long start, end, length, offset, upcase; 1268 1269 LispObj *ostring, *ostart, *oend; 1270 1271 oend = ARGUMENT(2); 1272 ostart = ARGUMENT(1); 1273 ostring = ARGUMENT(0); 1274 CHECK_STRING(ostring); 1275 LispCheckSequenceStartEnd(builtin, ostring, ostart, oend, 1276 &start, &end, &offset); 1277 result = ostring; 1278 string = THESTR(ostring); 1279 length = STRLEN(ostring); 1280 1281 /* first check if something need to be done */ 1282 for (upcase = 1, offset = start; offset < end; offset++) { 1283 if (upcase) { 1284 if (!isalnum(string[offset])) 1285 continue; 1286 if (string[offset] != toupper(string[offset])) 1287 break; 1288 upcase = 0; 1289 } 1290 else { 1291 if (isalnum(string[offset])) { 1292 if (string[offset] != tolower(string[offset])) 1293 break; 1294 } 1295 else 1296 upcase = 1; 1297 } 1298 } 1299 1300 if (offset >= end) 1301 return (result); 1302 1303 if (inplace) { 1304 CHECK_STRING_WRITABLE(ostring); 1305 newstring = string; 1306 } 1307 else { 1308 /* capitalize a copy of argument */ 1309 newstring = LispMalloc(length + 1); 1310 memcpy(newstring, string, length); 1311 newstring[length] = '\0'; 1312 } 1313 for (; offset < end; offset++) { 1314 if (upcase) { 1315 if (!isalnum(string[offset])) 1316 continue; 1317 newstring[offset] = toupper(string[offset]); 1318 upcase = 0; 1319 } 1320 else { 1321 if (isalnum(newstring[offset])) 1322 newstring[offset] = tolower(string[offset]); 1323 else 1324 upcase = 1; 1325 } 1326 } 1327 1328 if (!inplace) 1329 result = LSTRING2(newstring, length); 1330 1331 return (result); 1332 } 1333 1334 LispObj * 1335 Lisp_StringCapitalize(LispBuiltin *builtin) 1336 /* 1337 string-capitalize string &key start end 1338 */ 1339 { 1340 return (LispStringCapitalize(builtin, 0)); 1341 } 1342 1343 LispObj * 1344 Lisp_NstringCapitalize(LispBuiltin *builtin) 1345 /* 1346 nstring-capitalize string &key start end 1347 */ 1348 { 1349 return (LispStringCapitalize(builtin, 1)); 1350 } 1351 1352 LispObj * 1353 Lisp_StringConcat(LispBuiltin *builtin) 1354 /* 1355 string-concat &rest strings 1356 */ 1357 { 1358 char *buffer; 1359 long size, length; 1360 LispObj *object, *string; 1361 1362 LispObj *strings; 1363 1364 strings = ARGUMENT(0); 1365 1366 if (strings == NIL) 1367 return (STRING("")); 1368 1369 for (length = 1, object = strings; CONSP(object); object = CDR(object)) { 1370 string = CAR(object); 1371 CHECK_STRING(string); 1372 length += STRLEN(string); 1373 } 1374 1375 buffer = LispMalloc(length); 1376 1377 for (length = 0, object = strings; CONSP(object); object = CDR(object)) { 1378 string = CAR(object); 1379 size = STRLEN(string); 1380 memcpy(buffer + length, THESTR(string), size); 1381 length += size; 1382 } 1383 buffer[length] = '\0'; 1384 object = LSTRING2(buffer, length); 1385 1386 return (object); 1387 } 1388
Indexes created Wed Jul 01 00:25:26 UTC 2026