#line 1 "/tmp/pkgbuild/lang/ecl/work/ecl-16.1.2/src/c/string.d"
/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */
/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */

/*
    string.d -- String routines.
*/
/*
    Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
    Copyright (c) 1990, Giuseppe Attardi.
    Copyright (c) 2001, Juan Jose Garcia Ripoll.

    ECL is free software; you can redistribute it and/or
    modify it under thep terms of the GNU Library General Public
    License as published by the Free Software Foundation; either
    version 2 of the License, or (at your option) any later version.

    See file '../Copyright' for full details.
*/


#include <ecl/ecl.h>
#include <string.h>
#include <ecl/internal.h>
#include <ecl/ecl-inl.h>

typedef ecl_character (*ecl_casefun)(ecl_character, bool *);

static cl_object
do_make_base_string(cl_index s, ecl_base_char code)
{
        cl_object x = ecl_alloc_simple_base_string(s);
        cl_index i;
        for (i = 0;  i < s;  i++)
                x->base_string.self[i] = code;
        return x;
}

#ifdef ECL_UNICODE
static cl_object
do_make_string(cl_index s, ecl_character code)
{
        cl_object x = ecl_alloc_simple_extended_string(s);
        cl_index i;
        for (i = 0;  i < s;  i++)
                x->string.self[i] = code;
        return x;
}
#else
#define do_make_string do_make_base_string
#endif

#line 53
cl_object cl_make_string(cl_narg narg, cl_object size, ...)
{
#line 53

        cl_index s;
        cl_object x;
#line 57
	const cl_env_ptr the_env = ecl_process_env();
#line 57
	static cl_object KEYS[2] = {(cl_object)(cl_symbols+1256), (cl_object)(cl_symbols+1227)};
	cl_object initial_element;
	cl_object element_type;
#line 57
	cl_object KEY_VARS[4];
#line 57
	ecl_va_list ARGS;
	ecl_va_start(ARGS, size, narg, 1);
#line 57
	if (ecl_unlikely(narg < 1)) FEwrong_num_arguments(ecl_make_fixnum(534));
#line 57
	cl_parse_key(ARGS, 2, KEYS, KEY_VARS, NULL, 0);
#line 57
	if (KEY_VARS[2]==ECL_NIL) {
#line 57
	  initial_element = ECL_CODE_CHAR(' ');
	} else {
#line 57
	  initial_element = KEY_VARS[0];
	}
#line 57
	if (KEY_VARS[3]==ECL_NIL) {
#line 57
	  element_type = ECL_SYM("CHARACTER",222);
	} else {
#line 57
	  element_type = KEY_VARS[1];
	}
#line 57
        s = ecl_to_index(size);
        /* INV: ecl_[base_]char_code() checks the type of initial_element() */
        if (element_type == ECL_SYM("BASE-CHAR",120) || element_type == ECL_SYM("STANDARD-CHAR",794)) {
                int code = ecl_base_char_code(initial_element);
                x = do_make_base_string(s, code);
        } else if (element_type == ECL_SYM("CHARACTER",222)) {
                cl_index code = ecl_char_code(initial_element);
                x = do_make_string(s, code);
        } else if (_ecl_funcall3(ECL_SYM("SUBTYPEP",837), element_type, ECL_SYM("BASE-CHAR",120)) == ECL_T) {
                int code = ecl_base_char_code(initial_element);
                x = do_make_base_string(s, code);
        } else if (_ecl_funcall3(ECL_SYM("SUBTYPEP",837), element_type, ECL_SYM("CHARACTER",222)) == ECL_T) {
                cl_index code = ecl_char_code(initial_element);
                x = do_make_string(s, code);
        } else {
                FEerror("The type ~S is not a valid string char type.",
                        1, element_type);
        }
        {
#line 75
	#line 75
	cl_object __value0 = x;
#line 75
	the_env->nvalues = 1;
#line 75
	return __value0;
#line 75
}

}

/*
        Make a string of a certain size, with some eading zeros to
        keep C happy. The string must be adjustable, to allow further
        growth. (See unixfsys.c for its use).
*/
cl_object
ecl_alloc_adjustable_base_string(cl_index l)
{
        cl_object output = ecl_alloc_object(t_base_string);
        output->base_string.self       = (ecl_base_char *)ecl_alloc_atomic(l+1);
        output->base_string.self[l]    = 0;
        output->base_string.flags      = ECL_FLAG_HAS_FILL_POINTER | ECL_FLAG_ADJUSTABLE;
        output->base_string.elttype    = ecl_aet_bc;
        output->base_string.displaced  = ECL_NIL;
        output->base_string.dim        = l;
        output->base_string.fillp      = 0;
        return output;
}

#ifdef ECL_UNICODE
cl_object
ecl_alloc_adjustable_extended_string(cl_index l)
{
        cl_index bytes = sizeof(ecl_character) * l;
        cl_object output = ecl_alloc_object(t_string);
        output->string.self       = (ecl_character *)ecl_alloc_atomic(bytes);
        output->string.flags      = ECL_FLAG_HAS_FILL_POINTER | ECL_FLAG_ADJUSTABLE;
        output->string.elttype    = ecl_aet_ch;
        output->string.displaced  = ECL_NIL;
        output->string.dim        = l;
        output->string.fillp      = 0;
        return output;
}
#endif

/*
        Make_simple_base_string(s) makes a simple-base string from C string s.
*/
cl_object
ecl_make_simple_base_string(char *s, cl_fixnum l)
{
        cl_object x = ecl_alloc_object(t_base_string);
        x->base_string.elttype = ecl_aet_bc;
        x->base_string.flags = 0; /* no fill pointer, no adjustable */
        x->base_string.displaced = ECL_NIL;
        if (l < 0) l = strlen(s);
        x->base_string.dim = (x->base_string.fillp = l);
        x->base_string.self = (ecl_base_char *)s;
        return x;
}

cl_object
make_base_string_copy(const char *s)
{
        cl_object x;
        cl_index l = strlen(s);

        x = ecl_alloc_simple_base_string(l);
        memcpy(x->base_string.self, s, l);
        return x;
}

cl_object
ecl_cstring_to_base_string_or_nil(const char *s)
{
        if (s == NULL)
                return ECL_NIL;
        else
                return make_base_string_copy(s);
}

bool
ecl_fits_in_base_string(cl_object s)
{
        switch (ecl_t_of(s)) {
#ifdef ECL_UNICODE
        case t_string: {
                cl_index i;
                for (i = 0; i < s->string.fillp; i++) {
                        if (!ECL_BASE_CHAR_CODE_P(s->string.self[i]))
                                return 0;
                }
                return 1;
        }
#endif
        case t_base_string:
                return 1;
        default:
                FEwrong_type_nth_arg(ecl_make_fixnum(/*SI::COPY-TO-SIMPLE-BASE-STRING*/1060),1,s,ecl_make_fixnum(/*STRING*/805));
        }
}

cl_object
si_copy_to_simple_base_string(cl_object x)
{
        cl_object y;
 AGAIN:
        switch(ecl_t_of(x)) {
        case t_symbol:
                x = x->symbol.name;
                goto AGAIN;
        case t_character:
                x = cl_string(x);
                goto AGAIN;
#ifdef ECL_UNICODE
        case t_string: {
                cl_index index, length = x->string.fillp;
                y = ecl_alloc_simple_base_string(length);
                for (index=0; index < length; index++) {
                        ecl_character c = x->string.self[index];
                        if (!ECL_BASE_CHAR_CODE_P(c))
                                FEerror("Cannot coerce string ~A to a base-string", 1, x);
                        y->base_string.self[index] = c;
                }
                break;
        }
#endif
        case t_base_string: {
                cl_index length = x->base_string.fillp;
                y = ecl_alloc_simple_base_string(length);
                memcpy(y->base_string.self, x->base_string.self, length);
                break;
        }
        case t_list:
                if (Null(x)) {
                        x = ECL_NIL_SYMBOL->symbol.name;
                        goto AGAIN;
                }
        default:
                FEwrong_type_nth_arg(ecl_make_fixnum(/*SI::COPY-TO-SIMPLE-BASE-STRING*/1060),1,x,ecl_make_fixnum(/*STRING*/805));
        }
        {
#line 209
	const cl_env_ptr the_env = ecl_process_env();
#line 209
	#line 209
	cl_object __value0 = y;
#line 209
	the_env->nvalues = 1;
#line 209
	return __value0;
#line 209
}

}

cl_object
cl_string(cl_object x)
{
        switch (ecl_t_of(x)) {
        case t_symbol:
                x = x->symbol.name;
                break;
        case t_character: {
                cl_object y;
                ecl_character c = ECL_CHAR_CODE(x);
#ifdef ECL_UNICODE
                if (ECL_BASE_CHAR_CODE_P(c)) {
                        y = ecl_alloc_simple_base_string(1);
                        y->base_string.self[0] = c;
                        x = y;
                } else {
                        y = ecl_alloc_simple_extended_string(1);
                        y->string.self[0] = c;
                        x = y;
                }
#else
                y = ecl_alloc_simple_base_string(1);
                y->base_string.self[0] = c;
                x = y;
                break;
#endif
        }
#ifdef ECL_UNICODE
        case t_string:
#endif
        case t_base_string:
                break;
        case t_list:
                if (Null(x)) {
                        x = ECL_NIL_SYMBOL->symbol.name;
                        break;
                }
        default:
                FEwrong_type_nth_arg(ecl_make_fixnum(/*STRING*/805),1,x,ecl_make_fixnum(/*STRING*/805));
        }
        {
#line 252
	const cl_env_ptr the_env = ecl_process_env();
#line 252
	#line 252
	cl_object __value0 = x;
#line 252
	the_env->nvalues = 1;
#line 252
	return __value0;
#line 252
}

}

#ifdef ECL_UNICODE
cl_object
si_coerce_to_base_string(cl_object x)
{
        if (!ECL_BASE_STRING_P(x)) {
                x = si_copy_to_simple_base_string(x);
        }
        {
#line 262
	const cl_env_ptr the_env = ecl_process_env();
#line 262
	#line 262
	cl_object __value0 = x;
#line 262
	the_env->nvalues = 1;
#line 262
	return __value0;
#line 262
}

}

cl_object
si_coerce_to_extended_string(cl_object x)
{
        cl_object y;
 AGAIN:
        switch (ecl_t_of(x)) {
        case t_symbol:
                x = x->symbol.name;
                goto AGAIN;
        case t_character:
                y = ecl_alloc_simple_extended_string(1);
                y->string.self[0] = ECL_CHAR_CODE(x);
                break;
        case t_base_string: {
                cl_index index, len = x->base_string.dim;
                y = ecl_alloc_simple_extended_string(x->base_string.fillp);
                for(index=0; index < len; index++) {
                        y->string.self[index] = x->base_string.self[index];
                }
                y->string.fillp = x->base_string.fillp;
        }
        case t_string:
                y = x;
                break;
        case t_list:
                if (Null(x)) {
                        x = ECL_NIL_SYMBOL->symbol.name;
                        goto AGAIN;
                }
        default:
                FEwrong_type_nth_arg(ecl_make_fixnum(/*SI::COERCE-TO-EXTENDED-STRING*/1056),1,x,ecl_make_fixnum(/*STRING*/805));
        }
        {
#line 297
	const cl_env_ptr the_env = ecl_process_env();
#line 297
	#line 297
	cl_object __value0 = y;
#line 297
	the_env->nvalues = 1;
#line 297
	return __value0;
#line 297
}

}
#endif

cl_object
cl_char(cl_object object, cl_object index)
{
        cl_index position = ecl_to_index(index);
        {
#line 305
	const cl_env_ptr the_env = ecl_process_env();
#line 305
	#line 305
	cl_object __value0 = ECL_CODE_CHAR(ecl_char(object, position));
#line 305
	the_env->nvalues = 1;
#line 305
	return __value0;
#line 305
}

}

ecl_character
ecl_char(cl_object object, cl_index index)
{
        /* CHAR bypasses fill pointers when accessing strings */
        switch(ecl_t_of(object)) {
#ifdef ECL_UNICODE
        case t_string:
                if (index >= object->string.dim)
                        FEtype_error_index(object, index);
                return object->string.self[index];
#endif
        case t_base_string:
                if (index >= object->base_string.dim)
                        FEtype_error_index(object, index);
                return object->base_string.self[index];
        default:
                FEwrong_type_nth_arg(ecl_make_fixnum(/*CHAR*/203),1,object,ecl_make_fixnum(/*STRING*/805));
        }
}

cl_object
si_char_set(cl_object object, cl_object index, cl_object value)
{
        cl_index position = ecl_to_index(index);
        cl_index c = ecl_char_code(value);
        ecl_char_set(object, position, c);
        {
#line 334
	const cl_env_ptr the_env = ecl_process_env();
#line 334
	#line 334
	cl_object __value0 = value;
#line 334
	the_env->nvalues = 1;
#line 334
	return __value0;
#line 334
}

}

ecl_character
ecl_char_set(cl_object object, cl_index index, ecl_character value)
{
        /* CHAR bypasses fill pointers when accessing strings */
        switch(ecl_t_of(object)) {
#ifdef ECL_UNICODE
        case t_string:
                if (index >= object->string.dim)
                        FEtype_error_index(object, index);
                return object->string.self[index] = value;
#endif
        case t_base_string:
                if (index >= object->base_string.dim)
                        FEtype_error_index(object, index);
                return object->base_string.self[index] = value;
        default:
                FEwrong_type_nth_arg(ecl_make_fixnum(/*SI::CHAR-SET*/1052),1,object,ecl_make_fixnum(/*STRING*/805));
        }
}

#ifdef ECL_UNICODE
static int
compare_strings(cl_object string1, cl_index s1, cl_index e1,
                cl_object string2, cl_index s2, cl_index e2,
                int case_sensitive, cl_index *m)
{
        cl_index c1, c2;
        for (; s1 < e1; s1++, s2++) {
                if (s2 >= e2) { /* s1 is longer than s2, therefore s2 < s1 */
                        *m = s1;
                        return +1;
                }
                c1 = ecl_char(string1, s1);
                c2 = ecl_char(string2, s2);
                if (!case_sensitive) {
                        c1 = ecl_char_upcase(c1);
                        c2 = ecl_char_upcase(c2);
                }
                if (c1 < c2) {
                        *m = s1;
                        return -1;
                } else if (c1 > c2) {
                        *m = s1;
                        return +1;
                }
        }
        *m = s1;
        if (s2 >= e2) {
                return 0;
        } else { /* s1 is shorter than s2, hence s1 < s2 */
                return -1;
        }
}
#endif

static int
compare_base(unsigned char *s1, cl_index l1, unsigned char *s2, cl_index l2,
             int case_sensitive, cl_index *m)
{
        cl_index l, c1, c2;
        for (l = 0; l < l1; l++, s1++, s2++) {
                if (l == l2) { /* s1 is longer than s2, therefore s2 < s1 */
                        *m = l;
                        return +1;
                }
                c1 = *s1;
                c2 = *s2;
                if (!case_sensitive) {
                        c1 = ecl_char_upcase(c1);
                        c2 = ecl_char_upcase(c2);
                }
                if (c1 < c2) {
                        *m = l;
                        return -1;
                } else if (c1 > c2) {
                        *m = l;
                        return +1;
                }
        }
        *m = l;
        if (l1 == l2) 
                return 0;
        else { /* s1 is shorter than s2, hence s1 < s2 */
                return -1;
        }
}

#line 425
cl_object cl_stringE(cl_narg narg, cl_object string1, cl_object string2, ...)
{
#line 425

        cl_index_pair p;
        cl_index s1, e1, s2, e2;
#line 429
	const cl_env_ptr the_env = ecl_process_env();
#line 429
	static cl_object KEYS[4] = {(cl_object)(cl_symbols+1316), (cl_object)(cl_symbols+1229), (cl_object)(cl_symbols+1317), (cl_object)(cl_symbols+1230)};
	cl_object start1;
	cl_object end1;
	cl_object start2;
	cl_object end2;
#line 429
	cl_object KEY_VARS[8];
#line 429
	ecl_va_list ARGS;
	ecl_va_start(ARGS, string2, narg, 2);
#line 429
	if (ecl_unlikely(narg < 2)) FEwrong_num_arguments(ecl_make_fixnum(822));
#line 429
	cl_parse_key(ARGS, 4, KEYS, KEY_VARS, NULL, 0);
#line 429
	if (KEY_VARS[4]==ECL_NIL) {
#line 429
	  start1 = ecl_make_fixnum(0);
	} else {
#line 429
	  start1 = KEY_VARS[0];
	}
#line 429
	if (KEY_VARS[5]==ECL_NIL) {
#line 429
	  end1 = ECL_NIL;
	} else {
#line 429
	  end1 = KEY_VARS[1];
	}
#line 429
	if (KEY_VARS[6]==ECL_NIL) {
#line 429
	  start2 = ecl_make_fixnum(0);
	} else {
#line 429
	  start2 = KEY_VARS[2];
	}
#line 429
	if (KEY_VARS[7]==ECL_NIL) {
#line 429
	  end2 = ECL_NIL;
	} else {
#line 429
	  end2 = KEY_VARS[3];
	}
#line 429
{
        string1 = cl_string(string1);
        string2 = cl_string(string2);
        p = ecl_vector_start_end(ecl_make_fixnum(/*STRING=*/822), string1, start1, end1);
        s1 = p.start; e1 = p.end;
        p = ecl_vector_start_end(ecl_make_fixnum(/*STRING=*/822), string2, start2, end2);
        s2 = p.start; e2 = p.end;
        if (e1 - s1 != e2 - s2)
                {
#line 437
	#line 437
	cl_object __value0 = ECL_NIL;
#line 437
	the_env->nvalues = 1;
#line 437
	return __value0;
#line 437
}
;
#ifdef ECL_UNICODE
        if (string1->string.t == t_string) {
                if (string2->string.t == t_string) {
                        while (s1 < e1)
                                if (string1->string.self[s1++] != string2->string.self[s2++])
                                        {
#line 443
	#line 443
	cl_object __value0 = ECL_NIL;
#line 443
	the_env->nvalues = 1;
#line 443
	return __value0;
#line 443
}
;
                        {
#line 444
	#line 444
	cl_object __value0 = ECL_T;
#line 444
	the_env->nvalues = 1;
#line 444
	return __value0;
#line 444
}
;
                } else {
                        while (s1 < e1)
                                if (string1->string.self[s1++] != string2->base_string.self[s2++])
                                        {
#line 448
	#line 448
	cl_object __value0 = ECL_NIL;
#line 448
	the_env->nvalues = 1;
#line 448
	return __value0;
#line 448
}
;
                        {
#line 449
	#line 449
	cl_object __value0 = ECL_T;
#line 449
	the_env->nvalues = 1;
#line 449
	return __value0;
#line 449
}
;
                }
        } else {
                if (string2->string.t == t_string) {
                        while (s1 < e1)
                                if (string1->base_string.self[s1++] != string2->string.self[s2++])
                                        {
#line 455
	#line 455
	cl_object __value0 = ECL_NIL;
#line 455
	the_env->nvalues = 1;
#line 455
	return __value0;
#line 455
}
;
                        {
#line 456
	#line 456
	cl_object __value0 = ECL_T;
#line 456
	the_env->nvalues = 1;
#line 456
	return __value0;
#line 456
}
;
                } else {
                        while (s1 < e1)
                                if (string1->base_string.self[s1++] != string2->base_string.self[s2++])
                                        {
#line 460
	#line 460
	cl_object __value0 = ECL_NIL;
#line 460
	the_env->nvalues = 1;
#line 460
	return __value0;
#line 460
}
;
                        {
#line 461
	#line 461
	cl_object __value0 = ECL_T;
#line 461
	the_env->nvalues = 1;
#line 461
	return __value0;
#line 461
}
;
                }
        }
#else
        while (s1 < e1)
                if (string1->base_string.self[s1++] != string2->base_string.self[s2++])
                        {
#line 467
	#line 467
	cl_object __value0 = ECL_NIL;
#line 467
	the_env->nvalues = 1;
#line 467
	return __value0;
#line 467
}
;
#endif
        {
#line 469
	#line 469
	cl_object __value0 = ECL_T;
#line 469
	the_env->nvalues = 1;
#line 469
	return __value0;
#line 469
}
;
}
}

/*
        This correponds to string= (just the string equality).
*/
bool
ecl_string_eq(cl_object x, cl_object y)
{
        cl_index i, j;
        i = x->base_string.fillp;
        j = y->base_string.fillp;
        if (i != j) return 0;
#ifdef ECL_UNICODE
        switch(ecl_t_of(x)) {
        case t_string:
                switch(ecl_t_of(y)) {
                case t_string:
                        return memcmp(x->string.self, y->string.self, i * sizeof *x->string.self) == 0;
                case t_base_string: {
                        cl_index index;
                        for(index=0; index<i; index++)
                                if (x->string.self[index] != y->base_string.self[index])
                                        return 0;
                        return 1;
                        }
                default:
                        FEwrong_type_nth_arg(ecl_make_fixnum(/*STRING=*/822),2,y,ecl_make_fixnum(/*STRING*/805));
                }
                break;
        case t_base_string:
                switch(ecl_t_of(y)) {
                case t_string:
                        return ecl_string_eq(y, x);
                case t_base_string:
                        return memcmp(x->base_string.self, y->base_string.self, i) == 0;
                default:
                        FEwrong_type_nth_arg(ecl_make_fixnum(/*STRING=*/822),2,y,ecl_make_fixnum(/*STRING*/805));
                }
                break;
        default:
                FEwrong_type_nth_arg(ecl_make_fixnum(/*STRING=*/822),2,x,ecl_make_fixnum(/*STRING*/805));
        }
#else
        return memcmp(x->base_string.self, y->base_string.self, i) == 0;
#endif
}


#line 520
cl_object cl_string_equal(cl_narg narg, cl_object string1, cl_object string2, ...)
{
#line 520

        cl_index s1, e1, s2, e2;
        cl_index_pair p;
        int output;
#line 525
	const cl_env_ptr the_env = ecl_process_env();
#line 525
	static cl_object KEYS[4] = {(cl_object)(cl_symbols+1316), (cl_object)(cl_symbols+1229), (cl_object)(cl_symbols+1317), (cl_object)(cl_symbols+1230)};
	cl_object start1;
	cl_object end1;
	cl_object start2;
	cl_object end2;
#line 525
	cl_object KEY_VARS[8];
#line 525
	ecl_va_list ARGS;
	ecl_va_start(ARGS, string2, narg, 2);
#line 525
	if (ecl_unlikely(narg < 2)) FEwrong_num_arguments(ecl_make_fixnum(808));
#line 525
	cl_parse_key(ARGS, 4, KEYS, KEY_VARS, NULL, 0);
#line 525
	if (KEY_VARS[4]==ECL_NIL) {
#line 525
	  start1 = ecl_make_fixnum(0);
	} else {
#line 525
	  start1 = KEY_VARS[0];
	}
#line 525
	if (KEY_VARS[5]==ECL_NIL) {
#line 525
	  end1 = ECL_NIL;
	} else {
#line 525
	  end1 = KEY_VARS[1];
	}
#line 525
	if (KEY_VARS[6]==ECL_NIL) {
#line 525
	  start2 = ecl_make_fixnum(0);
	} else {
#line 525
	  start2 = KEY_VARS[2];
	}
#line 525
	if (KEY_VARS[7]==ECL_NIL) {
#line 525
	  end2 = ECL_NIL;
	} else {
#line 525
	  end2 = KEY_VARS[3];
	}
#line 525
        string1 = cl_string(string1);
        string2 = cl_string(string2);
        p = ecl_vector_start_end(ecl_make_fixnum(/*STRING=*/822), string1, start1, end1);
        s1 = p.start; e1 = p.end;
        p = ecl_vector_start_end(ecl_make_fixnum(/*STRING=*/822), string2, start2, end2);
        s2 = p.start; e2 = p.end;
        if (e1 - s1 != e2 - s2)
                {
#line 532
	#line 532
	cl_object __value0 = ECL_NIL;
#line 532
	the_env->nvalues = 1;
#line 532
	return __value0;
#line 532
}
;
#ifdef ECL_UNICODE
        if (ECL_EXTENDED_STRING_P(string1) || ECL_EXTENDED_STRING_P(string2)) {
                output = compare_strings(string1, s1, e1, string2, s2, e2, 0, &e1);
        } else
#endif
        output = compare_base(string1->base_string.self + s1, e1 - s1,
                              string2->base_string.self + s2, e2 - s2,
                              0, &e1);
        {
#line 541
	#line 541
	cl_object __value0 = ((output == 0)? ECL_T : ECL_NIL);
#line 541
	the_env->nvalues = 1;
#line 541
	return __value0;
#line 541
}

}

static cl_object
string_compare(cl_narg narg, int sign1, int sign2, int case_sensitive, ecl_va_list ARGS)
{
        cl_object string1 = ecl_va_arg(ARGS);
        cl_object string2 = ecl_va_arg(ARGS);
        cl_index s1, e1, s2, e2;
        cl_index_pair p;
        int output;
        cl_object result;
        cl_object KEYS[4];
#define start1 KEY_VARS[0]
#define end1 KEY_VARS[1]
#define start2 KEY_VARS[2]
#define end2 KEY_VARS[3]
#define start1p KEY_VARS[4]
#define start2p KEY_VARS[6]
        cl_object KEY_VARS[8];

        if (narg < 2) FEwrong_num_arguments_anonym();
        KEYS[0]=ECL_SYM(":START1",1316);
        KEYS[1]=ECL_SYM(":END1",1229);
        KEYS[2]=ECL_SYM(":START2",1317);
        KEYS[3]=ECL_SYM(":END2",1230);
        cl_parse_key(ARGS, 4, KEYS, KEY_VARS, NULL, FALSE);

        string1 = cl_string(string1);
        string2 = cl_string(string2);
        if (start1p == ECL_NIL) start1 = ecl_make_fixnum(0);
        if (start2p == ECL_NIL) start2 = ecl_make_fixnum(0);
        p = ecl_vector_start_end(ecl_make_fixnum(/*STRING=*/822), string1, start1, end1);
        s1 = p.start; e1 = p.end;
        p = ecl_vector_start_end(ecl_make_fixnum(/*STRING=*/822), string2, start2, end2);
        s2 = p.start; e2 = p.end;
#ifdef ECL_UNICODE
        if (ECL_EXTENDED_STRING_P(string1) || ECL_EXTENDED_STRING_P(string2)) {
                output = compare_strings(string1, s1, e1, string2, s2, e2,
                                         case_sensitive, &e1);
        } else
#endif
        {
                output = compare_base(string1->base_string.self + s1, e1 - s1,
                                      string2->base_string.self + s2, e2 - s2,
                                      case_sensitive, &e1);
                e1 += s1;
        }
        if (output == sign1 || output == sign2) {
                result = ecl_make_fixnum(e1);
        } else {
                result = ECL_NIL;
        }
        {
#line 594
	const cl_env_ptr the_env = ecl_process_env();
#line 594
	#line 594
	cl_object __value0 = result;
#line 594
	the_env->nvalues = 1;
#line 594
	return __value0;
#line 594
}

#undef start1p
#undef start2p
#undef start1
#undef end1
#undef start2
#undef end2
}

#line 603
cl_object cl_stringL(cl_narg narg, ...)
{
#line 603

#line 605
	const cl_env_ptr the_env = ecl_process_env();
#line 605
	ecl_va_list args;
	ecl_va_start(args, narg, narg, 0);
#line 605
	if (ecl_unlikely(narg < 0)) FEwrong_num_arguments(ecl_make_fixnum(820));
#line 605
        return string_compare(narg, -1, -1, 1, args);
}

#line 608
cl_object cl_stringG(cl_narg narg, ...)
{
#line 608

#line 610
	const cl_env_ptr the_env = ecl_process_env();
#line 610
	ecl_va_list args;
	ecl_va_start(args, narg, narg, 0);
#line 610
	if (ecl_unlikely(narg < 0)) FEwrong_num_arguments(ecl_make_fixnum(823));
#line 610
        return string_compare(narg, +1, +1, 1, args);
}

#line 613
cl_object cl_stringLE(cl_narg narg, ...)
{
#line 613

#line 615
	const cl_env_ptr the_env = ecl_process_env();
#line 615
	ecl_va_list args;
	ecl_va_start(args, narg, narg, 0);
#line 615
	if (ecl_unlikely(narg < 0)) FEwrong_num_arguments(ecl_make_fixnum(821));
#line 615
        return string_compare(narg, -1, 0, 1, args);
}

#line 618
cl_object cl_stringGE(cl_narg narg, ...)
{
#line 618

#line 620
	const cl_env_ptr the_env = ecl_process_env();
#line 620
	ecl_va_list args;
	ecl_va_start(args, narg, narg, 0);
#line 620
	if (ecl_unlikely(narg < 0)) FEwrong_num_arguments(ecl_make_fixnum(824));
#line 620
        return string_compare(narg, 0, +1, 1, args);
}

#line 623
cl_object cl_stringNE(cl_narg narg, ...)
{
#line 623

#line 625
	const cl_env_ptr the_env = ecl_process_env();
#line 625
	ecl_va_list args;
	ecl_va_start(args, narg, narg, 0);
#line 625
	if (ecl_unlikely(narg < 0)) FEwrong_num_arguments(ecl_make_fixnum(819));
#line 625
        return string_compare(narg, -1, +1, 1, args);
}

#line 628
cl_object cl_string_lessp(cl_narg narg, ...)
{
#line 628

#line 630
	const cl_env_ptr the_env = ecl_process_env();
#line 630
	ecl_va_list args;
	ecl_va_start(args, narg, narg, 0);
#line 630
	if (ecl_unlikely(narg < 0)) FEwrong_num_arguments(ecl_make_fixnum(811));
#line 630
        return string_compare(narg, -1, -1, 0, args);
}

#line 633
cl_object cl_string_greaterp(cl_narg narg, ...)
{
#line 633

#line 635
	const cl_env_ptr the_env = ecl_process_env();
#line 635
	ecl_va_list args;
	ecl_va_start(args, narg, narg, 0);
#line 635
	if (ecl_unlikely(narg < 0)) FEwrong_num_arguments(ecl_make_fixnum(809));
#line 635
        return string_compare(narg, +1, +1, 0, args);
}

#line 638
cl_object cl_string_not_greaterp(cl_narg narg, ...)
{
#line 638

#line 640
	const cl_env_ptr the_env = ecl_process_env();
#line 640
	ecl_va_list args;
	ecl_va_start(args, narg, narg, 0);
#line 640
	if (ecl_unlikely(narg < 0)) FEwrong_num_arguments(ecl_make_fixnum(813));
#line 640
        return string_compare(narg, -1, 0, 0, args);
}

#line 643
cl_object cl_string_not_lessp(cl_narg narg, ...)
{
#line 643

#line 645
	const cl_env_ptr the_env = ecl_process_env();
#line 645
	ecl_va_list args;
	ecl_va_start(args, narg, narg, 0);
#line 645
	if (ecl_unlikely(narg < 0)) FEwrong_num_arguments(ecl_make_fixnum(814));
#line 645
        return string_compare(narg, 0, +1, 0, args);
}

#line 648
cl_object cl_string_not_equal(cl_narg narg, ...)
{
#line 648

#line 650
	const cl_env_ptr the_env = ecl_process_env();
#line 650
	ecl_va_list args;
	ecl_va_start(args, narg, narg, 0);
#line 650
	if (ecl_unlikely(narg < 0)) FEwrong_num_arguments(ecl_make_fixnum(812));
#line 650
        return string_compare(narg, -1, +1, 0, args);
}

bool
ecl_member_char(ecl_character c, cl_object char_bag)
{
        cl_index i, f;
        switch (ecl_t_of(char_bag)) {
        case t_list:
                loop_for_in(char_bag) {
                        cl_object other = CAR(char_bag);
                        if (ECL_CHARACTERP(other) && c == ECL_CHAR_CODE(other))
                                return(TRUE);
                } end_loop_for_in;
                return(FALSE);
        case t_vector:
                for (i = 0, f = char_bag->vector.fillp;  i < f;  i++) {
                        cl_object other = char_bag->vector.self.t[i];
                        if (ECL_CHARACTERP(other) && c == ECL_CHAR_CODE(other))
                                return(TRUE);
                }
                return(FALSE);
#ifdef ECL_UNICODE
        case t_string:
                for (i = 0, f = char_bag->string.fillp;  i < f;  i++) {
                        if (c == char_bag->string.self[i])
                                return(TRUE);
                }
                return(FALSE);
#endif
        case t_base_string:
                for (i = 0, f = char_bag->base_string.fillp;  i < f;  i++) {
                        if (c == char_bag->base_string.self[i])
                                return(TRUE);
                }
                return(FALSE);
        case t_bitvector:
                return(FALSE);
        default:
                FEwrong_type_nth_arg(ecl_make_fixnum(/*MEMBER*/552),2,char_bag,ecl_make_fixnum(/*SEQUENCE*/741));
        }
}

static cl_object
string_trim0(bool left_trim, bool right_trim, cl_object char_bag, cl_object strng)
{
        cl_index i, j;

        strng = cl_string(strng);
        i = 0;
        j = ecl_length(strng);
        if (left_trim) {
                for (;  i < j;  i++) {
                        cl_index c = ecl_char(strng, i);
                        if (!ecl_member_char(c, char_bag))
                                break;
                }
        }
        if (right_trim) {
                for (; j > i; j--) {
                        cl_index c = ecl_char(strng, j-1);
                        if (!ecl_member_char(c, char_bag)) {
                                break;
                        }
                }
        }
        return cl_subseq(3, strng, ecl_make_fixnum(i), ecl_make_fixnum(j));
}

cl_object
cl_string_trim(cl_object char_bag, cl_object strng)
{
        return string_trim0(TRUE, TRUE, char_bag, strng);
}

cl_object
cl_string_left_trim(cl_object char_bag, cl_object strng)
{
        return string_trim0(TRUE, FALSE, char_bag, strng);
}

cl_object
cl_string_right_trim(cl_object char_bag, cl_object strng)
{
        return string_trim0(FALSE, TRUE, char_bag, strng);
}

static cl_object
string_case(cl_narg narg, cl_object fun, ecl_casefun casefun, ecl_va_list ARGS)
{
        cl_object strng = ecl_va_arg(ARGS);
        cl_index_pair p;
        cl_index i;
        bool b;
        cl_object KEYS[2];
#define kstart KEY_VARS[0]
#define kend KEY_VARS[1]
#define kstartp KEY_VARS[2]
        cl_object KEY_VARS[4];

        if (narg < 1) FEwrong_num_arguments_anonym();
        KEYS[0]=ECL_SYM(":START",1315);
        KEYS[1]=ECL_SYM(":END",1228);
        cl_parse_key(ARGS, 2, KEYS, KEY_VARS, NULL, FALSE);

        strng = cl_string(strng);
        strng = cl_copy_seq(strng);
        if (kstartp == ECL_NIL)
                kstart = ecl_make_fixnum(0);
        p = ecl_vector_start_end(fun, strng, kstart, kend);
        b = TRUE;
#ifdef ECL_UNICODE
        if (ECL_EXTENDED_STRING_P(strng)) {
                for (i = p.start;  i < p.end;  i++)
                        strng->string.self[i] = (*casefun)(strng->string.self[i], &b);
        } else
#endif
        for (i = p.start;  i < p.end;  i++)
                strng->base_string.self[i] = (*casefun)(strng->base_string.self[i], &b);
        {
#line 769
	const cl_env_ptr the_env = ecl_process_env();
#line 769
	#line 769
	cl_object __value0 = strng;
#line 769
	the_env->nvalues = 1;
#line 769
	return __value0;
#line 769
}

#undef kstartp
#undef kstart
#undef kend
}

static ecl_character
char_upcase(ecl_character c, bool *bp)
{
        return ecl_char_upcase(c);
}

#line 781
cl_object cl_string_upcase(cl_narg narg, ...)
{
#line 781

#line 783
	const cl_env_ptr the_env = ecl_process_env();
#line 783
	ecl_va_list args;
	ecl_va_start(args, narg, narg, 0);
#line 783
	if (ecl_unlikely(narg < 0)) FEwrong_num_arguments(ecl_make_fixnum(818));
#line 783
        return string_case(narg, ecl_make_fixnum(/*STRING-UPCASE*/818), char_upcase, args);
}

static ecl_character
char_downcase(ecl_character c, bool *bp)
{
        return ecl_char_downcase(c);
}

#line 792
cl_object cl_string_downcase(cl_narg narg, ...)
{
#line 792

#line 794
	const cl_env_ptr the_env = ecl_process_env();
#line 794
	ecl_va_list args;
	ecl_va_start(args, narg, narg, 0);
#line 794
	if (ecl_unlikely(narg < 0)) FEwrong_num_arguments(ecl_make_fixnum(806));
#line 794
        return string_case(narg, ecl_make_fixnum(/*STRING-DOWNCASE*/806), char_downcase, args);
}

static ecl_character
char_capitalize(ecl_character c, bool *bp)
{
        if (ecl_lower_case_p(c)) {
                if (*bp)
                        c = ecl_char_upcase(c);
                *bp = FALSE;
        } else if (ecl_upper_case_p(c)) {
                if (!*bp)
                        c = ecl_char_downcase(c);
                *bp = FALSE;
        } else {
                *bp = !ecl_alphanumericp(c);
        }
        return c;
}

#line 814
cl_object cl_string_capitalize(cl_narg narg, ...)
{
#line 814

#line 816
	const cl_env_ptr the_env = ecl_process_env();
#line 816
	ecl_va_list args;
	ecl_va_start(args, narg, narg, 0);
#line 816
	if (ecl_unlikely(narg < 0)) FEwrong_num_arguments(ecl_make_fixnum(807));
#line 816
        return string_case(narg, ecl_make_fixnum(/*STRING-CAPITALIZE*/807), char_capitalize, args);
}


static cl_object
nstring_case(cl_narg narg, cl_object fun, ecl_casefun casefun, ecl_va_list ARGS)
{
        cl_object strng = ecl_va_arg(ARGS);
        cl_index_pair p;
        cl_index i;
        bool b;
        cl_object KEYS[2];
#define kstart KEY_VARS[0]
#define kend KEY_VARS[1]
#define kstartp KEY_VARS[2]
        cl_object KEY_VARS[4];

        if (narg < 1) FEwrong_num_arguments_anonym();
        KEYS[0]=ECL_SYM(":START",1315);
        KEYS[1]=ECL_SYM(":END",1228);
        cl_parse_key(ARGS, 2, KEYS, KEY_VARS, NULL, FALSE);

        if (ecl_unlikely(!ECL_STRINGP(strng)))
                FEwrong_type_nth_arg(fun, 1, strng, ecl_make_fixnum(/*STRING*/805));
        if (kstartp == ECL_NIL)
                kstart = ecl_make_fixnum(0);
        p = ecl_vector_start_end(fun, strng, kstart, kend);
        b = TRUE;
#ifdef ECL_UNICODE
        if (ECL_EXTENDED_STRING_P(strng)) {
                for (i = p.start;  i < p.end;  i++)
                        strng->string.self[i] = (*casefun)(strng->string.self[i], &b);
        } else
#endif
        for (i = p.start;  i < p.end;  i++)
                strng->base_string.self[i] = (*casefun)(strng->base_string.self[i], &b);
        {
#line 852
	const cl_env_ptr the_env = ecl_process_env();
#line 852
	#line 852
	cl_object __value0 = strng;
#line 852
	the_env->nvalues = 1;
#line 852
	return __value0;
#line 852
}

#undef kstartp
#undef kstart
#undef kend
}

#line 858
cl_object cl_nstring_upcase(cl_narg narg, ...)
{
#line 858

#line 860
	const cl_env_ptr the_env = ecl_process_env();
#line 860
	ecl_va_list args;
	ecl_va_start(args, narg, narg, 0);
#line 860
	if (ecl_unlikely(narg < 0)) FEwrong_num_arguments(ecl_make_fixnum(594));
#line 860
        return nstring_case(narg, ECL_SYM("NSTRING-UPCASE",594), char_upcase, args);
}

#line 863
cl_object cl_nstring_downcase(cl_narg narg, ...)
{
#line 863

#line 865
	const cl_env_ptr the_env = ecl_process_env();
#line 865
	ecl_va_list args;
	ecl_va_start(args, narg, narg, 0);
#line 865
	if (ecl_unlikely(narg < 0)) FEwrong_num_arguments(ecl_make_fixnum(593));
#line 865
        return nstring_case(narg, ECL_SYM("NSTRING-DOWNCASE",593), char_downcase, args);
}

#line 868
cl_object cl_nstring_capitalize(cl_narg narg, ...)
{
#line 868

#line 870
	const cl_env_ptr the_env = ecl_process_env();
#line 870
	ecl_va_list args;
	ecl_va_start(args, narg, narg, 0);
#line 870
	if (ecl_unlikely(narg < 0)) FEwrong_num_arguments(ecl_make_fixnum(592));
#line 870
        return nstring_case(narg, ECL_SYM("NSTRING-CAPITALIZE",592), char_capitalize, args);
}

#line 873
cl_object si_base_string_concatenate(cl_narg narg, ...)
{
#line 873

        cl_index l;
        int i;
        cl_object output;
#line 878
	const cl_env_ptr the_env = ecl_process_env();
#line 878
	ecl_va_list args;
	ecl_va_start(args, narg, narg, 0);
#line 878
	if (ecl_unlikely(narg < 0)) FEwrong_num_arguments(ecl_make_fixnum(1151));
#line 878
        /* Compute final size and store NONEMPTY coerced strings. */
        for (i = 0, l = 0; i < narg; i++) {
                cl_object s = si_coerce_to_base_string(ecl_va_arg(args));
                if (s->base_string.fillp) {
                        ECL_STACK_PUSH(the_env, s);
                        l += s->base_string.fillp;
                }
        }
        /* Do actual copying by recovering those strings */
        output = ecl_alloc_simple_base_string(l);
        while (l) {
                cl_object s = ECL_STACK_POP_UNSAFE(the_env);
                size_t bytes = s->base_string.fillp;
                l -= bytes;
                memcpy(output->base_string.self + l, s->base_string.self, bytes);
        }
        {
#line 894
	#line 894
	cl_object __value0 = output;
#line 894
	the_env->nvalues = 1;
#line 894
	return __value0;
#line 894
}
;
}
