diff options
Diffstat (limited to 'lisp/string.c')
| -rw-r--r-- | lisp/string.c | 1383 |
1 files changed, 1383 insertions, 0 deletions
diff --git a/lisp/string.c b/lisp/string.c new file mode 100644 index 0000000..95952bd --- /dev/null +++ b/lisp/string.c @@ -0,0 +1,1383 @@ +/* + * Copyright (c) 2001 by The XFree86 Project, Inc. + * + * Permission is hereby granted, free of charge, to any person obtaining a + * copy of this software and associated documentation files (the "Software"), + * to deal in the Software without restriction, including without limitation + * the rights to use, copy, modify, merge, publish, distribute, sublicense, + * and/or sell copies of the Software, and to permit persons to whom the + * Software is furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL + * THE XFREE86 PROJECT BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, + * WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF + * OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + * + * Except as contained in this notice, the name of the XFree86 Project shall + * not be used in advertising or otherwise to promote the sale, use or other + * dealings in this Software without prior written authorization from the + * XFree86 Project. + * + * Author: Paulo César Pereira de Andrade + */ + +/* $XFree86: xc/programs/xedit/lisp/string.c,v 1.22 2002/12/04 05:27:58 paulo Exp $ */ + +#include "helper.h" +#include "read.h" +#include "string.h" +#include "private.h" +#include <ctype.h> + +#define CHAR_LESS 1 +#define CHAR_LESS_EQUAL 2 +#define CHAR_EQUAL 3 +#define CHAR_GREATER_EQUAL 4 +#define CHAR_GREATER 5 +#define CHAR_NOT_EQUAL 6 + +#define CHAR_ALPHAP 1 +#define CHAR_DOWNCASE 2 +#define CHAR_UPCASE 3 +#define CHAR_INT 4 +#define CHAR_BOTHP 5 +#define CHAR_UPPERP 6 +#define CHAR_LOWERP 7 +#define CHAR_GRAPHICP 8 + +#ifndef MIN +#define MIN(a, b) ((a) < (b) ? (a) : (b)) +#endif + +/* + * Prototypes + */ +static LispObj *LispCharCompare(LispBuiltin*, int, int); +static LispObj *LispStringCompare(LispBuiltin*, int, int); +static LispObj *LispCharOp(LispBuiltin*, int); +static LispObj *LispStringTrim(LispBuiltin*, int, int, int); +static LispObj *LispStringUpcase(LispBuiltin*, int); +static LispObj *LispStringDowncase(LispBuiltin*, int); +static LispObj *LispStringCapitalize(LispBuiltin*, int); + +/* + * Implementation + */ +static LispObj * +LispCharCompare(LispBuiltin *builtin, int operation, int ignore_case) +{ + LispObj *object; + int cmp, value, next_value; + + LispObj *character, *more_characters; + + more_characters = ARGUMENT(1); + character = ARGUMENT(0); + + CHECK_SCHAR(character); + value = SCHAR_VALUE(character); + if (ignore_case && islower(value)) + value = toupper(value); + + if (!CONSP(more_characters)) + return (T); + + /* First check if all parameters are characters */ + for (object = more_characters; CONSP(object); object = CDR(object)) + CHECK_SCHAR(CAR(object)); + + /* All characters in list must be different */ + if (operation == CHAR_NOT_EQUAL) { + /* Compare all characters */ + do { + for (object = more_characters; CONSP(object); object = CDR(object)) { + character = CAR(object); + next_value = SCHAR_VALUE(character); + if (ignore_case && islower(next_value)) + next_value = toupper(next_value); + if (value == next_value) + return (NIL); + } + value = SCHAR_VALUE(CAR(more_characters)); + if (ignore_case && islower(value)) + value = toupper(value); + more_characters = CDR(more_characters); + } while (CONSP(more_characters)); + + return (T); + } + + /* Linearly compare characters */ + for (; CONSP(more_characters); more_characters = CDR(more_characters)) { + character = CAR(more_characters); + next_value = SCHAR_VALUE(character); + if (ignore_case && islower(next_value)) + next_value = toupper(next_value); + + switch (operation) { + case CHAR_LESS: cmp = value < next_value; break; + case CHAR_LESS_EQUAL: cmp = value <= next_value; break; + case CHAR_EQUAL: cmp = value == next_value; break; + case CHAR_GREATER_EQUAL: cmp = value >= next_value; break; + case CHAR_GREATER: cmp = value > next_value; break; + default: cmp = 0; break; + } + + if (!cmp) + return (NIL); + value = next_value; + } + + return (T); +} + +LispObj * +Lisp_CharLess(LispBuiltin *builtin) +/* + char< character &rest more-characters + */ +{ + return (LispCharCompare(builtin, CHAR_LESS, 0)); +} + +LispObj * +Lisp_CharLessEqual(LispBuiltin *builtin) +/* + char<= character &rest more-characters + */ +{ + return (LispCharCompare(builtin, CHAR_LESS_EQUAL, 0)); +} + +LispObj * +Lisp_CharEqual_(LispBuiltin *builtin) +/* + char= character &rest more-characters + */ +{ + return (LispCharCompare(builtin, CHAR_EQUAL, 0)); +} + +LispObj * +Lisp_CharGreater(LispBuiltin *builtin) +/* + char> character &rest more-characters + */ +{ + return (LispCharCompare(builtin, CHAR_GREATER, 0)); +} + +LispObj * +Lisp_CharGreaterEqual(LispBuiltin *builtin) +/* + char>= character &rest more-characters + */ +{ + return (LispCharCompare(builtin, CHAR_GREATER_EQUAL, 0)); +} + +LispObj * +Lisp_CharNotEqual_(LispBuiltin *builtin) +/* + char/= character &rest more-characters + */ +{ + return (LispCharCompare(builtin, CHAR_NOT_EQUAL, 0)); +} + +LispObj * +Lisp_CharLessp(LispBuiltin *builtin) +/* + char-lessp character &rest more-characters + */ +{ + return (LispCharCompare(builtin, CHAR_LESS, 1)); +} + +LispObj * +Lisp_CharNotGreaterp(LispBuiltin *builtin) +/* + char-not-greaterp character &rest more-characters + */ +{ + return (LispCharCompare(builtin, CHAR_LESS_EQUAL, 1)); +} + +LispObj * +Lisp_CharEqual(LispBuiltin *builtin) +/* + char-equalp character &rest more-characters + */ +{ + return (LispCharCompare(builtin, CHAR_EQUAL, 1)); +} + +LispObj * +Lisp_CharGreaterp(LispBuiltin *builtin) +/* + char-greaterp character &rest more-characters + */ +{ + return (LispCharCompare(builtin, CHAR_GREATER, 1)); +} + +LispObj * +Lisp_CharNotLessp(LispBuiltin *builtin) +/* + char-not-lessp &rest more-characters + */ +{ + return (LispCharCompare(builtin, CHAR_GREATER_EQUAL, 1)); +} + +LispObj * +Lisp_CharNotEqual(LispBuiltin *builtin) +/* + char-not-equal character &rest more-characters + */ +{ + return (LispCharCompare(builtin, CHAR_NOT_EQUAL, 1)); +} + +static LispObj * +LispCharOp(LispBuiltin *builtin, int operation) +{ + int value; + LispObj *result, *character; + + character = ARGUMENT(0); + CHECK_SCHAR(character); + value = (int)SCHAR_VALUE(character); + + switch (operation) { + case CHAR_ALPHAP: + result = isalpha(value) ? T : NIL; + break; + case CHAR_DOWNCASE: + result = SCHAR(tolower(value)); + break; + case CHAR_UPCASE: + result = SCHAR(toupper(value)); + break; + case CHAR_INT: + result = FIXNUM(value); + break; + case CHAR_BOTHP: + result = isupper(value) || islower(value) ? T : NIL; + break; + case CHAR_UPPERP: + result = isupper(value) ? T : NIL; + break; + case CHAR_LOWERP: + result = islower(value) ? T : NIL; + break; + case CHAR_GRAPHICP: + result = value == ' ' || isgraph(value) ? T : NIL; + break; + default: + result = NIL; + break; + } + + return (result); +} + +LispObj * +Lisp_AlphaCharP(LispBuiltin *builtin) +/* + alpha-char-p char + */ +{ + return (LispCharOp(builtin, CHAR_ALPHAP)); +} + +LispObj * +Lisp_CharDowncase(LispBuiltin *builtin) +/* + char-downcase character + */ +{ + return (LispCharOp(builtin, CHAR_DOWNCASE)); +} + +LispObj * +Lisp_CharInt(LispBuiltin *builtin) +/* + char-int character + char-code character + */ +{ + return (LispCharOp(builtin, CHAR_INT)); +} + +LispObj * +Lisp_CharUpcase(LispBuiltin *builtin) +/* + char-upcase character + */ +{ + return (LispCharOp(builtin, CHAR_UPCASE)); +} + +LispObj * +Lisp_BothCaseP(LispBuiltin *builtin) +/* + both-case-p character + */ +{ + return (LispCharOp(builtin, CHAR_BOTHP)); +} + +LispObj * +Lisp_UpperCaseP(LispBuiltin *builtin) +/* + upper-case-p character + */ +{ + return (LispCharOp(builtin, CHAR_UPPERP)); +} + +LispObj * +Lisp_LowerCaseP(LispBuiltin *builtin) +/* + upper-case-p character + */ +{ + return (LispCharOp(builtin, CHAR_LOWERP)); +} + +LispObj * +Lisp_GraphicCharP(LispBuiltin *builtin) +/* + graphic-char-p char + */ +{ + return (LispCharOp(builtin, CHAR_GRAPHICP)); +} + +LispObj * +Lisp_Char(LispBuiltin *builtin) +/* + char string index + schar simple-string index + */ +{ + char *string; + long offset, length; + + LispObj *ostring, *oindex; + + oindex = ARGUMENT(1); + ostring = ARGUMENT(0); + + CHECK_STRING(ostring); + CHECK_INDEX(oindex); + offset = FIXNUM_VALUE(oindex); + string = THESTR(ostring); + length = STRLEN(ostring); + + if (offset >= length) + LispDestroy("%s: index %ld too large for string length %ld", + STRFUN(builtin), offset, length); + + return (SCHAR(string[offset])); +} + +/* helper function for setf + * DONT explicitly call. Non standard function + */ +LispObj * +Lisp_XeditCharStore(LispBuiltin *builtin) +/* + xedit::char-store string index value + */ +{ + int character; + long offset, length; + LispObj *ostring, *oindex, *ovalue; + + ovalue = ARGUMENT(2); + oindex = ARGUMENT(1); + ostring = ARGUMENT(0); + + CHECK_STRING(ostring); + CHECK_INDEX(oindex); + length = STRLEN(ostring); + offset = FIXNUM_VALUE(oindex); + if (offset >= length) + LispDestroy("%s: index %ld too large for string length %ld", + STRFUN(builtin), offset, length); + CHECK_SCHAR(ovalue); + CHECK_STRING_WRITABLE(ostring); + + character = SCHAR_VALUE(ovalue); + + if (character < 0 || character > 255) + LispDestroy("%s: cannot represent character %d", + STRFUN(builtin), character); + + THESTR(ostring)[offset] = character; + + return (ovalue); +} + +LispObj * +Lisp_Character(LispBuiltin *builtin) +/* + character object + */ +{ + LispObj *object; + + object = ARGUMENT(0); + + return (LispCharacterCoerce(builtin, object)); +} + +LispObj * +Lisp_Characterp(LispBuiltin *builtin) +/* + characterp object + */ +{ + LispObj *object; + + object = ARGUMENT(0); + + return (SCHARP(object) ? T : NIL); +} + +LispObj * +Lisp_DigitChar(LispBuiltin *builtin) +/* + digit-char weight &optional radix + */ +{ + long radix = 10, weight; + LispObj *oweight, *oradix, *result = NIL; + + oradix = ARGUMENT(1); + oweight = ARGUMENT(0); + + CHECK_FIXNUM(oweight); + weight = FIXNUM_VALUE(oweight); + + if (oradix != UNSPEC) { + CHECK_INDEX(oradix); + radix = FIXNUM_VALUE(oradix); + } + if (radix < 2 || radix > 36) + LispDestroy("%s: radix must be >= 2 and <= 36, not %ld", + STRFUN(builtin), radix); + + if (weight >= 0 && weight < radix) { + if (weight < 9) + weight += '0'; + else + weight += 'A' - 10; + result = SCHAR(weight); + } + + return (result); +} + +LispObj * +Lisp_DigitCharP(LispBuiltin *builtin) +/* + digit-char-p character &optional radix + */ +{ + long radix = 10, character; + LispObj *ochar, *oradix, *result = NIL; + + oradix = ARGUMENT(1); + ochar = ARGUMENT(0); + + CHECK_SCHAR(ochar); + character = SCHAR_VALUE(ochar); + if (oradix != UNSPEC) { + CHECK_INDEX(oradix); + radix = FIXNUM_VALUE(oradix); + } + if (radix < 2 || radix > 36) + LispDestroy("%s: radix must be >= 2 and <= 36, not %ld", + STRFUN(builtin), radix); + + if (character >= '0' && character <= '9') + character -= '0'; + else if (character >= 'A' && character <= 'Z') + character -= 'A' - 10; + else if (character >= 'a' && character <= 'z') + character -= 'a' - 10; + if (character < radix) + result = FIXNUM(character); + + return (result); +} + +LispObj * +Lisp_IntChar(LispBuiltin *builtin) +/* + int-char integer + code-char integer + */ +{ + long character = 0; + LispObj *integer; + + integer = ARGUMENT(0); + + CHECK_FIXNUM(integer); + character = FIXNUM_VALUE(integer); + + return (character >= 0 && character < 0xff ? SCHAR(character) : NIL); +} + +/* XXX ignoring element-type */ +LispObj * +Lisp_MakeString(LispBuiltin *builtin) +/* + make-string size &key initial-element element-type + */ +{ + long length; + char *string, initial; + + LispObj *size, *initial_element, *element_type; + + element_type = ARGUMENT(2); + initial_element = ARGUMENT(1); + size = ARGUMENT(0); + + CHECK_INDEX(size); + length = FIXNUM_VALUE(size); + if (initial_element != UNSPEC) { + CHECK_SCHAR(initial_element); + initial = SCHAR_VALUE(initial_element); + } + else + initial = 0; + + string = LispMalloc(length + 1); + memset(string, initial, length); + string[length] = '\0'; + + return (LSTRING2(string, length)); +} + +LispObj * +Lisp_ParseInteger(LispBuiltin *builtin) +/* + parse-integer string &key start end radix junk-allowed + */ +{ + GC_ENTER(); + char *ptr, *string; + int character, junk, sign, overflow; + long i, start, end, radix, length, integer, check; + LispObj *result; + + LispObj *ostring, *ostart, *oend, *oradix, *junk_allowed; + + junk_allowed = ARGUMENT(4); + oradix = ARGUMENT(3); + oend = ARGUMENT(2); + ostart = ARGUMENT(1); + ostring = ARGUMENT(0); + + start = end = radix = 0; + result = NIL; + + CHECK_STRING(ostring); + LispCheckSequenceStartEnd(builtin, ostring, ostart, oend, + &start, &end, &length); + string = THESTR(ostring); + if (radix < 2 || radix > 36) + LispDestroy("%s: :RADIX %ld must be in the range 2 to 36", + STRFUN(builtin), radix); + + integer = check = 0; + ptr = string + start; + sign = overflow = 0; + + /* Skip leading white spaces */ + for (i = start; i < end && *ptr && isspace(*ptr); ptr++, i++) + ; + + /* Check for sign specification */ + if (i < end && (*ptr == '-' || *ptr == '+')) { + sign = *ptr == '-'; + ++ptr; + ++i; + } + + for (junk = 0; i < end; i++, ptr++) { + character = *ptr; + if (islower(character)) + character = toupper(character); + if (character >= '0' && character <= '9') { + if (character - '0' >= radix) + junk = 1; + else { + check = integer; + integer = integer * radix + character - '0'; + } + } + else if (character >= 'A' && character <= 'Z') { + if (character - 'A' + 10 >= radix) + junk = 1; + else { + check = integer; + integer = integer * radix + character - 'A' + 10; + } + } + else { + if (isspace(character)) + break; + junk = 1; + } + + if (junk) + break; + + if (!overflow && check > integer) + overflow = 1; + /* keep looping just to count read bytes */ + } + + if (!junk) + /* Skip white spaces */ + for (; i < end && *ptr && isspace(*ptr); ptr++, i++) + ; + + if ((junk || ptr == string) && + (junk_allowed == UNSPEC || junk_allowed == NIL)) + LispDestroy("%s: %s has a bad integer representation", + STRFUN(builtin), STROBJ(ostring)); + else if (ptr == string) + result = NIL; + else if (overflow) { + mpi *bigi = LispMalloc(sizeof(mpi)); + char *str; + + length = end - start + sign; + str = LispMalloc(length + 1); + + strncpy(str, string - sign, length + sign); + str[length + sign] = '\0'; + mpi_init(bigi); + mpi_setstr(bigi, str, radix); + LispFree(str); + result = BIGNUM(bigi); + } + else + result = INTEGER(sign ? -integer : integer); + + GC_PROTECT(result); + RETURN(0) = FIXNUM(i); + RETURN_COUNT = 1; + GC_LEAVE(); + + return (result); +} + +LispObj * +Lisp_String(LispBuiltin *builtin) +/* + string object + */ +{ + LispObj *object; + + object = ARGUMENT(0); + + return (LispStringCoerce(builtin, object)); +} + +LispObj * +Lisp_Stringp(LispBuiltin *builtin) +/* + stringp object + */ +{ + LispObj *object; + + object = ARGUMENT(0); + + return (STRINGP(object) ? T : NIL); +} + +/* XXX preserve-whitespace is being ignored */ +LispObj * +Lisp_ReadFromString(LispBuiltin *builtin) +/* + read-from-string string &optional eof-error-p eof-value &key start end preserve-whitespace + */ +{ + GC_ENTER(); + char *string; + LispObj *stream, *result; + long length, start, end, bytes_read; + + LispObj *ostring, *eof_error_p, *eof_value, + *ostart, *oend, *preserve_white_space; + + preserve_white_space = ARGUMENT(5); + oend = ARGUMENT(4); + ostart = ARGUMENT(3); + eof_value = ARGUMENT(2); + eof_error_p = ARGUMENT(1); + ostring = ARGUMENT(0); + + CHECK_STRING(ostring); + string = THESTR(ostring); + LispCheckSequenceStartEnd(builtin, ostring, ostart, oend, + &start, &end, &length); + + if (start > 0 || end < length) + length = end - start; + stream = LSTRINGSTREAM(string + start, STREAM_READ, length); + + if (eof_value == UNSPEC) + eof_value = NIL; + + LispPushInput(stream); + result = LispRead(); + /* stream->data.stream.source.string->input is + * the offset of the last byte read in string */ + bytes_read = stream->data.stream.source.string->input; + LispPopInput(stream); + + if (result == NULL) { + if (eof_error_p == NIL) + result = eof_value; + else + LispDestroy("%s: unexpected end of input", STRFUN(builtin)); + } + + GC_PROTECT(result); + RETURN(0) = FIXNUM(start + bytes_read); + RETURN_COUNT = 1; + GC_LEAVE(); + + return (result); +} + +static LispObj * +LispStringTrim(LispBuiltin *builtin, int left, int right, int inplace) +/* + string-{,left-,right-}trim character-bag string +*/ +{ + unsigned char *string; + long start, end, length; + + LispObj *ochars, *ostring; + + ostring = ARGUMENT(1); + ochars = ARGUMENT(0); + + if (!POINTERP(ochars) || !(XSTRINGP(ochars) || XCONSP(ochars))) { + if (ARRAYP(ochars) && ochars->data.array.rank == 1) + ochars = ochars->data.array.list; + else + LispDestroy("%s: %s is not a sequence", + STRFUN(builtin), STROBJ(ochars)); + } + CHECK_STRING(ostring); + + string = (unsigned char*)THESTR(ostring); + length = STRLEN(ostring); + + start = 0; + end = length; + + if (XSTRINGP(ochars)) { + unsigned char *chars = (unsigned char*)THESTR(ochars); + long i, clength = STRLEN(ochars); + + if (left) { + for (; start < end; start++) { + for (i = 0; i < clength; i++) + if (string[start] == chars[i]) + break; + if (i >= clength) + break; + } + } + if (right) { + for (--end; end >= 0; end--) { + for (i = 0; i < clength; i++) + if (string[end] == chars[i]) + break; + if (i >= clength) + break; + } + ++end; + } + } + else { + LispObj *ochar, *list; + + if (left) { + for (; start < end; start++) { + for (list = ochars; CONSP(list); list = CDR(list)) { + ochar = CAR(list); + if (SCHARP(ochar) && string[start] == SCHAR_VALUE(ochar)) + break; + } + if (!CONSP(list)) + break; + } + } + if (right) { + for (--end; end >= 0; end--) { + for (list = ochars; CONSP(list); list = CDR(list)) { + ochar = CAR(list); + if (SCHARP(ochar) && string[end] == SCHAR_VALUE(ochar)) + break; + } + if (!CONSP(list)) + break; + } + ++end; + } + } + + if (start == 0 && end == length) + return (ostring); + + length = end - start; + + if (inplace) { + CHECK_STRING_WRITABLE(ostring); + memmove(string, string + start, length); + string[length] = '\0'; + STRLEN(ostring) = length; + } + else { + string = LispMalloc(length + 1); + memcpy(string, THESTR(ostring) + start, length); + string[length] = '\0'; + ostring = LSTRING2((char*)string, length); + } + + return (ostring); +} + +LispObj * +Lisp_StringTrim(LispBuiltin *builtin) +/* + string-trim character-bag string + */ +{ + return (LispStringTrim(builtin, 1, 1, 0)); +} + +LispObj * +Lisp_NstringTrim(LispBuiltin *builtin) +/* + ext::nstring-trim character-bag string + */ +{ + return (LispStringTrim(builtin, 1, 1, 1)); +} + +LispObj * +Lisp_StringLeftTrim(LispBuiltin *builtin) +/* + string-left-trim character-bag string + */ +{ + return (LispStringTrim(builtin, 1, 0, 0)); +} + +LispObj * +Lisp_NstringLeftTrim(LispBuiltin *builtin) +/* + ext::nstring-left-trim character-bag string + */ +{ + return (LispStringTrim(builtin, 1, 0, 1)); +} + +LispObj * +Lisp_StringRightTrim(LispBuiltin *builtin) +/* + string-right-trim character-bag string + */ +{ + return (LispStringTrim(builtin, 0, 1, 0)); +} + +LispObj * +Lisp_NstringRightTrim(LispBuiltin *builtin) +/* + ext::nstring-right-trim character-bag string + */ +{ + return (LispStringTrim(builtin, 0, 1, 1)); +} + +static LispObj * +LispStringCompare(LispBuiltin *builtin, int function, int ignore_case) +{ + int cmp1, cmp2; + LispObj *fixnum; + unsigned char *string1, *string2; + long start1, end1, start2, end2, offset, length; + + LispGetStringArgs(builtin, (char**)&string1, (char**)&string2, + &start1, &end1, &start2, &end2); + + string1 += start1; + string2 += start2; + + if (function == CHAR_EQUAL) { + length = end1 - start1; + + if (length != (end2 - start2)) + return (NIL); + + if (!ignore_case) + return (memcmp(string1, string2, length) ? NIL : T); + + for (; length; length--, string1++, string2++) + if (toupper(*string1) != toupper(*string2)) + return (NIL); + return (T); + } + + end1 -= start1; + end2 -= start2; + length = MIN(end1, end2); + for (offset = 0; + offset < length; + string1++, string2++, offset++, start1++, start2++) { + cmp1 = *string1; + cmp2 = *string2; + if (ignore_case) { + cmp1 = toupper(cmp1); + cmp2 = toupper(cmp2); + } + if (cmp1 != cmp2) { + fixnum = FIXNUM(start1); + switch (function) { + case CHAR_LESS: + return ((cmp1 < cmp2) ? fixnum : NIL); + case CHAR_LESS_EQUAL: + return ((cmp1 <= cmp2) ? fixnum : NIL); + case CHAR_NOT_EQUAL: + return (fixnum); + case CHAR_GREATER_EQUAL: + return ((cmp1 >= cmp2) ? fixnum : NIL); + case CHAR_GREATER: + return ((cmp1 > cmp2) ? fixnum : NIL); + } + } + } + + fixnum = FIXNUM(start1); + switch (function) { + case CHAR_LESS: + return (start1 >= end1 && start2 < end2 ? fixnum : NIL); + case CHAR_LESS_EQUAL: + return (start1 >= end1 ? fixnum : NIL); + case CHAR_NOT_EQUAL: + return (start1 >= end1 && start2 >= end2 ? NIL : fixnum); + case CHAR_GREATER_EQUAL: + return (start2 >= end2 ? fixnum : NIL); + case CHAR_GREATER: + return (start2 >= end2 && start1 < end1 ? fixnum : NIL); + } + + return (NIL); +} + +LispObj * +Lisp_StringEqual_(LispBuiltin *builtin) +/* + string= string1 string2 &key start1 end1 start2 end2 + */ +{ + return (LispStringCompare(builtin, CHAR_EQUAL, 0)); +} + +LispObj * +Lisp_StringLess(LispBuiltin *builtin) +/* + string< string1 string2 &key start1 end1 start2 end2 + */ +{ + return (LispStringCompare(builtin, CHAR_LESS, 0)); +} + +LispObj * +Lisp_StringGreater(LispBuiltin *builtin) +/* + string> string1 string2 &key start1 end1 start2 end2 + */ +{ + return (LispStringCompare(builtin, CHAR_GREATER, 0)); +} + +LispObj * +Lisp_StringLessEqual(LispBuiltin *builtin) +/* + string<= string1 string2 &key start1 end1 start2 end2 + */ +{ + return (LispStringCompare(builtin, CHAR_LESS_EQUAL, 0)); +} + +LispObj * +Lisp_StringGreaterEqual(LispBuiltin *builtin) +/* + string>= string1 string2 &key start1 end1 start2 end2 + */ +{ + return (LispStringCompare(builtin, CHAR_GREATER_EQUAL, 0)); +} + +LispObj * +Lisp_StringNotEqual_(LispBuiltin *builtin) +/* + string/= string1 string2 &key start1 end1 start2 end2 + */ +{ + return (LispStringCompare(builtin, CHAR_NOT_EQUAL, 0)); +} + +LispObj * +Lisp_StringEqual(LispBuiltin *builtin) +/* + string-equal string1 string2 &key start1 end1 start2 end2 + */ +{ + return (LispStringCompare(builtin, CHAR_EQUAL, 1)); +} + +LispObj * +Lisp_StringLessp(LispBuiltin *builtin) +/* + string-lessp string1 string2 &key start1 end1 start2 end2 + */ +{ + return (LispStringCompare(builtin, CHAR_LESS, 1)); +} + +LispObj * +Lisp_StringGreaterp(LispBuiltin *builtin) +/* + string-greaterp string1 string2 &key start1 end1 start2 end2 + */ +{ + return (LispStringCompare(builtin, CHAR_GREATER, 1)); +} + +LispObj * +Lisp_StringNotGreaterp(LispBuiltin *builtin) +/* + string-not-greaterp string1 string2 &key start1 end1 start2 end2 + */ +{ + return (LispStringCompare(builtin, CHAR_LESS_EQUAL, 1)); +} + +LispObj * +Lisp_StringNotLessp(LispBuiltin *builtin) +/* + string-not-lessp string1 string2 &key start1 end1 start2 end2 + */ +{ + return (LispStringCompare(builtin, CHAR_GREATER_EQUAL, 1)); +} + +LispObj * +Lisp_StringNotEqual(LispBuiltin *builtin) +/* + string-not-equal string1 string2 &key start1 end1 start2 end2 + */ +{ + return (LispStringCompare(builtin, CHAR_NOT_EQUAL, 1)); +} + +LispObj * +LispStringUpcase(LispBuiltin *builtin, int inplace) +/* + string-upcase string &key start end + nstring-upcase string &key start end + */ +{ + LispObj *result; + char *string, *newstring; + long start, end, length, offset; + + LispObj *ostring, *ostart, *oend; + + oend = ARGUMENT(2); + ostart = ARGUMENT(1); + ostring = ARGUMENT(0); + CHECK_STRING(ostring); + LispCheckSequenceStartEnd(builtin, ostring, ostart, oend, + &start, &end, &offset); + result = ostring; + string = THESTR(ostring); + length = STRLEN(ostring); + + /* first check if something need to be done */ + for (offset = start; offset < end; offset++) + if (string[offset] != toupper(string[offset])) + break; + + if (offset >= end) + return (result); + + if (inplace) { + CHECK_STRING_WRITABLE(ostring); + newstring = string; + } + else { + /* upcase a copy of argument */ + newstring = LispMalloc(length + 1); + if (offset) + memcpy(newstring, string, offset); + if (length > end) + memcpy(newstring + end, string + end, length - end); + newstring[length] = '\0'; + } + + for (; offset < end; offset++) + newstring[offset] = toupper(string[offset]); + + if (!inplace) + result = LSTRING2(newstring, length); + + return (result); +} + +LispObj * +Lisp_StringUpcase(LispBuiltin *builtin) +/* + string-upcase string &key start end + */ +{ + return (LispStringUpcase(builtin, 0)); +} + +LispObj * +Lisp_NstringUpcase(LispBuiltin *builtin) +/* + nstring-upcase string &key start end + */ +{ + return (LispStringUpcase(builtin, 1)); +} + +LispObj * +LispStringDowncase(LispBuiltin *builtin, int inplace) +/* + string-downcase string &key start end + nstring-downcase string &key start end + */ +{ + LispObj *result; + char *string, *newstring; + long start, end, length, offset; + + LispObj *ostring, *ostart, *oend; + + oend = ARGUMENT(2); + ostart = ARGUMENT(1); + ostring = ARGUMENT(0); + CHECK_STRING(ostring); + LispCheckSequenceStartEnd(builtin, ostring, ostart, oend, + &start, &end, &offset); + result = ostring; + string = THESTR(ostring); + length = STRLEN(ostring); + + /* first check if something need to be done */ + for (offset = start; offset < end; offset++) + if (string[offset] != tolower(string[offset])) + break; + + if (offset >= end) + return (result); + + if (inplace) { + CHECK_STRING_WRITABLE(ostring); + newstring = string; + } + else { + /* downcase a copy of argument */ + newstring = LispMalloc(length + 1); + if (offset) + memcpy(newstring, string, offset); + if (length > end) + memcpy(newstring + end, string + end, length - end); + newstring[length] = '\0'; + } + for (; offset < end; offset++) + newstring[offset] = tolower(string[offset]); + + if (!inplace) + result = LSTRING2(newstring, length); + + return (result); +} + +LispObj * +Lisp_StringDowncase(LispBuiltin *builtin) +/* + string-downcase string &key start end + */ +{ + return (LispStringDowncase(builtin, 0)); +} + +LispObj * +Lisp_NstringDowncase(LispBuiltin *builtin) +/* + nstring-downcase string &key start end + */ +{ + return (LispStringDowncase(builtin, 1)); +} + +LispObj * +LispStringCapitalize(LispBuiltin *builtin, int inplace) +/* + string-capitalize string &key start end + nstring-capitalize string &key start end + */ +{ + LispObj *result; + char *string, *newstring; + long start, end, length, offset, upcase; + + LispObj *ostring, *ostart, *oend; + + oend = ARGUMENT(2); + ostart = ARGUMENT(1); + ostring = ARGUMENT(0); + CHECK_STRING(ostring); + LispCheckSequenceStartEnd(builtin, ostring, ostart, oend, + &start, &end, &offset); + result = ostring; + string = THESTR(ostring); + length = STRLEN(ostring); + + /* first check if something need to be done */ + for (upcase = 1, offset = start; offset < end; offset++) { + if (upcase) { + if (!isalnum(string[offset])) + continue; + if (string[offset] != toupper(string[offset])) + break; + upcase = 0; + } + else { + if (isalnum(string[offset])) { + if (string[offset] != tolower(string[offset])) + break; + } + else + upcase = 1; + } + } + + if (offset >= end) + return (result); + + if (inplace) { + CHECK_STRING_WRITABLE(ostring); + newstring = string; + } + else { + /* capitalize a copy of argument */ + newstring = LispMalloc(length + 1); + memcpy(newstring, string, length); + newstring[length] = '\0'; + } + for (; offset < end; offset++) { + if (upcase) { + if (!isalnum(string[offset])) + continue; + newstring[offset] = toupper(string[offset]); + upcase = 0; + } + else { + if (isalnum(newstring[offset])) + newstring[offset] = tolower(string[offset]); + else + upcase = 1; + } + } + + if (!inplace) + result = LSTRING2(newstring, length); + + return (result); +} + +LispObj * +Lisp_StringCapitalize(LispBuiltin *builtin) +/* + string-capitalize string &key start end + */ +{ + return (LispStringCapitalize(builtin, 0)); +} + +LispObj * +Lisp_NstringCapitalize(LispBuiltin *builtin) +/* + nstring-capitalize string &key start end + */ +{ + return (LispStringCapitalize(builtin, 1)); +} + +LispObj * +Lisp_StringConcat(LispBuiltin *builtin) +/* + string-concat &rest strings + */ +{ + char *buffer; + long size, length; + LispObj *object, *string; + + LispObj *strings; + + strings = ARGUMENT(0); + + if (strings == NIL) + return (STRING("")); + + for (length = 1, object = strings; CONSP(object); object = CDR(object)) { + string = CAR(object); + CHECK_STRING(string); + length += STRLEN(string); + } + + buffer = LispMalloc(length); + + for (length = 0, object = strings; CONSP(object); object = CDR(object)) { + string = CAR(object); + size = STRLEN(string); + memcpy(buffer + length, THESTR(string), size); + length += size; + } + buffer[length] = '\0'; + object = LSTRING2(buffer, length); + + return (object); +} |