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

/*
    character.d -- Character routines.
*/
/*
    Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
    Copyright (c) 1990, Giuseppe Attardi.
    Copyright (c) 2015, Daniel Kochmański.

    ECL is free software; you can redistribute it and/or
    modify it under the 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 <stdio.h>
#include <ecl/ecl.h>

#include "char_ctype.d"

ecl_character
ecl_char_code(cl_object c)
{
        if (ecl_unlikely(!ECL_CHARACTERP(c)))
                FEwrong_type_only_arg(ecl_make_fixnum(/*CHAR-CODE*/204), c, ecl_make_fixnum(/*CHARACTER*/222));
        return ECL_CHAR_CODE(c);
}

ecl_base_char
ecl_base_char_code(cl_object c)
{
#ifdef ECL_UNICODE
        if (ECL_CHARACTERP(c)) {
                cl_fixnum code = ECL_CHAR_CODE(c);
                if (code <= 255) {
                        return (int)code;
                }
        }
        FEwrong_type_only_arg(ecl_make_fixnum(/*CHAR-CODE*/204), c, ecl_make_fixnum(/*BASE-CHAR*/120));
#else
        return ecl_char_code(c);
#endif
}

cl_object
cl_standard_char_p(cl_object c)
{
        /* INV: ecl_char_code() checks the type */
        cl_fixnum i = ecl_char_code(c);
        {
#line 54
	const cl_env_ptr the_env = ecl_process_env();
#line 54
	#line 54
	cl_object __value0 = (ecl_standard_char_p(i)? ECL_T : ECL_NIL);
#line 54
	the_env->nvalues = 1;
#line 54
	return __value0;
#line 54
}

}

bool
ecl_standard_char_p(ecl_character code)
{
        return ((' ' <= code) && (code < '\177')) || (code == '\n');
}

bool
ecl_base_char_p(ecl_character c)
{
        return c <= 255;
}

cl_object
cl_graphic_char_p(cl_object c)
{
        /* INV: ecl_char_code() checks the type */
        {
#line 73
	const cl_env_ptr the_env = ecl_process_env();
#line 73
	#line 73
	cl_object __value0 = (ecl_graphic_char_p(ecl_char_code(c))? ECL_T : ECL_NIL);
#line 73
	the_env->nvalues = 1;
#line 73
	return __value0;
#line 73
}

}

cl_object
cl_alpha_char_p(cl_object c)
{
        /* INV: ecl_char_code() checks the type */
        {
#line 80
	const cl_env_ptr the_env = ecl_process_env();
#line 80
	#line 80
	cl_object __value0 = (ecl_alpha_char_p(ecl_char_code(c))? ECL_T : ECL_NIL);
#line 80
	the_env->nvalues = 1;
#line 80
	return __value0;
#line 80
}

}

cl_object
cl_upper_case_p(cl_object c)
{
        /* INV: ecl_char_code() checks the type */
        {
#line 87
	const cl_env_ptr the_env = ecl_process_env();
#line 87
	#line 87
	cl_object __value0 = (ecl_upper_case_p(ecl_char_code(c))? ECL_T : ECL_NIL);
#line 87
	the_env->nvalues = 1;
#line 87
	return __value0;
#line 87
}

}

cl_object
cl_lower_case_p(cl_object c)
{
        /* INV: ecl_char_code() checks the type */
        {
#line 94
	const cl_env_ptr the_env = ecl_process_env();
#line 94
	#line 94
	cl_object __value0 = (ecl_lower_case_p(ecl_char_code(c))? ECL_T : ECL_NIL);
#line 94
	the_env->nvalues = 1;
#line 94
	return __value0;
#line 94
}

}

cl_object
cl_both_case_p(cl_object c)
{
        /* INV: ecl_char_code() checks the type */
        {
#line 101
	const cl_env_ptr the_env = ecl_process_env();
#line 101
	#line 101
	cl_object __value0 = (ecl_both_case_p(ecl_char_code(c))? ECL_T : ECL_NIL);
#line 101
	the_env->nvalues = 1;
#line 101
	return __value0;
#line 101
}

}

int
ecl_string_case(cl_object s)
{
        int upcase;
        cl_index i;
        ecl_base_char *text;
        
        switch (ecl_t_of(s)) {
#ifdef ECL_UNICODE
        case t_string:
                s = si_coerce_to_base_string(s);
#endif
        case t_base_string:
                text = (ecl_base_char*)s->base_string.self;
                for (i = 0, upcase = 0; i < s->base_string.dim; i++) {
                        if (ecl_upper_case_p(text[i])) {
                                if (upcase < 0)
                                        return 0;
                                upcase = +1;
                        } else if (ecl_lower_case_p(text[i])) {
                                if (upcase > 0)
                                        return 0;
                                upcase = -1;
                        }
                }
                break;
        default:
                FEwrong_type_argument(ecl_make_fixnum(/*STRING*/805), s);
        }
        return upcase;
}

#line 136
cl_object cl_digit_char_p(cl_narg narg, cl_object c, ...)
{
#line 136

#line 137
	const cl_env_ptr the_env = ecl_process_env();
#line 137
	cl_object radix;
#line 137
	va_list ARGS;
	va_start(ARGS, c);
#line 137
	if (ecl_unlikely(narg < 1|| narg > 2)) FEwrong_num_arguments(ecl_make_fixnum(302));
#line 137
	if (narg > 1) {
#line 137
		radix = va_arg(ARGS,cl_object);
#line 137
	} else {
#line 137
		radix = ecl_make_fixnum(10);
#line 137
	}
#line 137
{
        cl_fixnum basis, value;
        if (ecl_unlikely(!ECL_FIXNUMP(radix) ||
                         ecl_fixnum_lower(radix, ecl_make_fixnum(2)) ||
                         ecl_fixnum_greater(radix, ecl_make_fixnum(36)))) {
                FEwrong_type_nth_arg(ecl_make_fixnum(/*DIGIT-CHAR-P*/302), 2, radix,
                                     ecl_make_integer_type(ecl_make_fixnum(2),
                                                           ecl_make_fixnum(36)));
        }
        basis = ecl_fixnum(radix);
        value = ecl_digitp(ecl_char_code(c), basis);
        {
#line 148
	#line 148
	cl_object __value0 = ((value < 0)? ECL_NIL: ecl_make_fixnum(value));
#line 148
	the_env->nvalues = 1;
#line 148
	return __value0;
#line 148
}
;
} }

/*
        Ecl_Digitp(i, r) returns the weight of code i
        as a digit of radix r, which must be 1 < r <= 36.
        If i is not a digit, -1 is returned.
*/
int
ecl_digitp(ecl_character i, int r)
{
        if (('0' <= i) && (i <= '9') && (i < '0' + r))
                return i - '0';
        if (('A' <= i) && (10 < r) && (i < 'A' + (r - 10)))
                return i - 'A' + 10;
        if (('a' <= i) && (10 < r) && (i < 'a' + (r - 10)))
                return i - 'a' + 10;
#ifdef ECL_UNICODE
        if (i > 255) {
                int number = ucd_decimal_digit(i);
                if (number < r)
                        return number;
        }
#endif
        return -1;
}

cl_object
cl_alphanumericp(cl_object c)
{
        /* INV: ecl_char_code() checks type of `c' */
        cl_fixnum i = ecl_char_code(c);
        {
#line 180
	const cl_env_ptr the_env = ecl_process_env();
#line 180
	#line 180
	cl_object __value0 = (ecl_alphanumericp(i)? ECL_T : ECL_NIL);
#line 180
	the_env->nvalues = 1;
#line 180
	return __value0;
#line 180
}

}

#line 183
cl_object cl_charE(cl_narg narg, cl_object c, ...)
{
#line 183

#line 185
	const cl_env_ptr the_env = ecl_process_env();
#line 185
	ecl_va_list cs;
	ecl_va_start(cs, c, narg, 1);
#line 185
	if (ecl_unlikely(narg < 1)) FEwrong_num_arguments(ecl_make_fixnum(219));
#line 185
        /* INV: ecl_char_eq() checks types of `c' and `cs' */
        while (--narg)
                if (!ecl_char_eq(c, ecl_va_arg(cs)))
                        {
#line 188
	#line 188
	cl_object __value0 = ECL_NIL;
#line 188
	the_env->nvalues = 1;
#line 188
	return __value0;
#line 188
}

        {
#line 189
	#line 189
	cl_object __value0 = ECL_T;
#line 189
	the_env->nvalues = 1;
#line 189
	return __value0;
#line 189
}

}

bool
ecl_char_eq(cl_object x, cl_object y)
{
        return ecl_char_code(x) == ecl_char_code(y);
}

#line 198
cl_object cl_charNE(cl_narg narg, ...)
{
#line 198

        int i, j;
        cl_object c;
#line 202
	const cl_env_ptr the_env = ecl_process_env();
#line 202
	ecl_va_list cs;
	ecl_va_start(cs, narg, narg, 0);
#line 202
	if (ecl_unlikely(narg < 0)) FEwrong_num_arguments(ecl_make_fixnum(216));
#line 202
        /* INV: ecl_char_eq() checks types of its arguments */
        if (narg == 0)
                FEwrong_num_arguments(ecl_make_fixnum(/*CHAR/=*/216));
        c = ecl_va_arg(cs);
        for (i = 2; i<=narg; i++) {
                ecl_va_list ds;
                ecl_va_start(ds, narg, narg, 0);
                c = ecl_va_arg(cs);
                for (j = 1; j<i; j++)
                        if (ecl_char_eq(ecl_va_arg(ds), c))
                                {
#line 212
	#line 212
	cl_object __value0 = ECL_NIL;
#line 212
	the_env->nvalues = 1;
#line 212
	return __value0;
#line 212
}

        }
        {
#line 214
	#line 214
	cl_object __value0 = ECL_T;
#line 214
	the_env->nvalues = 1;
#line 214
	return __value0;
#line 214
}

}

static cl_object
Lchar_cmp(cl_env_ptr env, cl_narg narg, int s, int t, ecl_va_list args)
{
        cl_object c, d;

        if (narg == 0)
                FEwrong_num_arguments_anonym();
        c = ecl_va_arg(args);
        for (; --narg; c = d) {
                d = ecl_va_arg(args);
                if (s*ecl_char_cmp(d, c) < t)
                        ecl_return1(env, ECL_NIL);
        }
        ecl_return1(env, ECL_T);
}

int
ecl_char_cmp(cl_object x, cl_object y)
{
        /* ecl_char_code(x) returns an integer which is well in the range
         * of positive fixnums. Therefore, this subtraction never
         * oveflows. */
        return ecl_char_code(x) - ecl_char_code(y);
}

#line 242
cl_object cl_charL(cl_narg narg, ...)
{
#line 242

#line 244
	const cl_env_ptr the_env = ecl_process_env();
#line 244
	ecl_va_list args;
	ecl_va_start(args, narg, narg, 0);
#line 244
	if (ecl_unlikely(narg < 0)) FEwrong_num_arguments(ecl_make_fixnum(217));
#line 244
        return Lchar_cmp(the_env, narg, 1, 1, args);
}

#line 247
cl_object cl_charG(cl_narg narg, ...)
{
#line 247

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

#line 252
cl_object cl_charLE(cl_narg narg, ...)
{
#line 252

#line 254
	const cl_env_ptr the_env = ecl_process_env();
#line 254
	ecl_va_list args;
	ecl_va_start(args, narg, narg, 0);
#line 254
	if (ecl_unlikely(narg < 0)) FEwrong_num_arguments(ecl_make_fixnum(218));
#line 254
        return Lchar_cmp(the_env, narg, 1, 0, args);
}

#line 257
cl_object cl_charGE(cl_narg narg, ...)
{
#line 257

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

#line 262
cl_object cl_char_equal(cl_narg narg, cl_object c, ...)
{
#line 262

        int i;
#line 265
	const cl_env_ptr the_env = ecl_process_env();
#line 265
	ecl_va_list cs;
	ecl_va_start(cs, c, narg, 1);
#line 265
	if (ecl_unlikely(narg < 1)) FEwrong_num_arguments(ecl_make_fixnum(207));
#line 265
        /* INV: ecl_char_equal() checks the type of its arguments */
        for (narg--, i = 0;  i < narg;  i++) {
                if (!ecl_char_equal(c, ecl_va_arg(cs)))
                        {
#line 268
	#line 268
	cl_object __value0 = ECL_NIL;
#line 268
	the_env->nvalues = 1;
#line 268
	return __value0;
#line 268
}

        }
        {
#line 270
	#line 270
	cl_object __value0 = ECL_T;
#line 270
	the_env->nvalues = 1;
#line 270
	return __value0;
#line 270
}

}

#define char_equal_code(x) ecl_char_upcase(ecl_char_code(x))

bool
ecl_char_equal(cl_object x, cl_object y)
{
        return char_equal_code(x) == char_equal_code(y);
}

#line 281
cl_object cl_char_not_equal(cl_narg narg, ...)
{
#line 281

        int i, j;
        cl_object c;
#line 285
	const cl_env_ptr the_env = ecl_process_env();
#line 285
	ecl_va_list cs;
	ecl_va_start(cs, narg, narg, 0);
#line 285
	if (ecl_unlikely(narg < 0)) FEwrong_num_arguments(ecl_make_fixnum(212));
#line 285
        /* INV: ecl_char_equal() checks the type of its arguments */
        if (narg == 0)
                FEwrong_num_arguments(ecl_make_fixnum(/*CHAR-NOT-EQUAL*/212));
        c = ecl_va_arg(cs);
        for (i = 2;  i<=narg;  i++) {
                ecl_va_list ds;
                ecl_va_start(ds, narg, narg, 0);
                c = ecl_va_arg(cs);
                for (j=1;  j<i;  j++)
                        if (ecl_char_equal(c, ecl_va_arg(ds)))
                                {
#line 295
	#line 295
	cl_object __value0 = ECL_NIL;
#line 295
	the_env->nvalues = 1;
#line 295
	return __value0;
#line 295
}

        }
        {
#line 297
	#line 297
	cl_object __value0 = ECL_T;
#line 297
	the_env->nvalues = 1;
#line 297
	return __value0;
#line 297
}

}

static cl_object
Lchar_compare(cl_env_ptr env, cl_narg narg, int s, int t, ecl_va_list args)
{
        cl_object c, d;

        /* INV: ecl_char_compare() checks the types of its arguments */
        if (narg == 0)
                FEwrong_num_arguments_anonym();
        c = ecl_va_arg(args);
        for (; --narg; c = d) {
                d = ecl_va_arg(args);
                if (s*ecl_char_compare(d, c) < t)
                        ecl_return1(env, ECL_NIL);
        }
        ecl_return1(env, ECL_T);
}

int
ecl_char_compare(cl_object x, cl_object y)
{
        cl_fixnum i = char_equal_code(x);
        cl_fixnum j = char_equal_code(y);

        if (i < j)
                return(-1);
        else if (i == j)
                return(0);
        else
                return(1);
}

#line 331
cl_object cl_char_lessp(cl_narg narg, ...)
{
#line 331

#line 333
	const cl_env_ptr the_env = ecl_process_env();
#line 333
	ecl_va_list args;
	ecl_va_start(args, narg, narg, 0);
#line 333
	if (ecl_unlikely(narg < 0)) FEwrong_num_arguments(ecl_make_fixnum(210));
#line 333
        return Lchar_compare(the_env, narg, 1, 1, args);
}

#line 336
cl_object cl_char_greaterp(cl_narg narg, ...)
{
#line 336

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

#line 341
cl_object cl_char_not_greaterp(cl_narg narg, ...)
{
#line 341

#line 343
	const cl_env_ptr the_env = ecl_process_env();
#line 343
	ecl_va_list args;
	ecl_va_start(args, narg, narg, 0);
#line 343
	if (ecl_unlikely(narg < 0)) FEwrong_num_arguments(ecl_make_fixnum(213));
#line 343
        return Lchar_compare(the_env, narg, 1, 0, args);
}

#line 346
cl_object cl_char_not_lessp(cl_narg narg, ...)
{
#line 346

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


cl_object
cl_character(cl_object x)
{
        switch (ecl_t_of(x)) {
        case t_character:
                break;
        case t_symbol:
                return cl_character(x->symbol.name);
#ifdef ECL_UNICODE
        case t_string:
                if (x->string.fillp == 1) {
                        x = ECL_CODE_CHAR(x->string.self[0]);
                        break;
                }
                goto ERROR;
#endif
        case t_base_string:
                if (x->base_string.fillp == 1) {
                        x = ECL_CODE_CHAR(x->base_string.self[0]);
                        break;
                }
        default: ERROR:
                FEwrong_type_nth_arg(ecl_make_fixnum(/*CHARACTER*/222), 1, x, ecl_read_from_cstring("(OR CHARACTER SYMBOL (ARRAY CHARACTER (1)) (ARRAY BASE-CHAR (1)))"));
        }
        {
#line 376
	const cl_env_ptr the_env = ecl_process_env();
#line 376
	#line 376
	cl_object __value0 = x;
#line 376
	the_env->nvalues = 1;
#line 376
	return __value0;
#line 376
}

}

cl_object
cl_char_code(cl_object c)
{
        /* INV: ecl_char_code() checks the type of `c' */
        {
#line 383
	const cl_env_ptr the_env = ecl_process_env();
#line 383
	#line 383
	cl_object __value0 = ecl_make_fixnum(ecl_char_code(c));
#line 383
	the_env->nvalues = 1;
#line 383
	return __value0;
#line 383
}

}

cl_object
cl_code_char(cl_object c)
{
        cl_fixnum fc;

        switch (ecl_t_of(c)) {
        case t_fixnum:
                fc = ecl_fixnum(c);
                if (fc < ECL_CHAR_CODE_LIMIT && fc >= 0) {
                        c = ECL_CODE_CHAR(fc);
                        break;
                }
        case t_bignum:
                c = ECL_NIL;
                break;
        default:
                FEwrong_type_only_arg(ecl_make_fixnum(/*CODE-CHAR*/230), c, ecl_make_fixnum(/*INTEGER*/437));
        }
        {
#line 404
	const cl_env_ptr the_env = ecl_process_env();
#line 404
	#line 404
	cl_object __value0 = c;
#line 404
	the_env->nvalues = 1;
#line 404
	return __value0;
#line 404
}

}

cl_object
cl_char_upcase(cl_object c)
{
        /* INV: ecl_char_code() checks the type of `c' */
        cl_fixnum code = ecl_char_code(c);
        {
#line 412
	const cl_env_ptr the_env = ecl_process_env();
#line 412
	#line 412
	cl_object __value0 = ECL_CODE_CHAR(ecl_char_upcase(code));
#line 412
	the_env->nvalues = 1;
#line 412
	return __value0;
#line 412
}

}

cl_object
cl_char_downcase(cl_object c)
{
        /* INV: ecl_char_code() checks the type of `c' */
        cl_fixnum code = ecl_char_code(c);
        {
#line 420
	const cl_env_ptr the_env = ecl_process_env();
#line 420
	#line 420
	cl_object __value0 = ECL_CODE_CHAR(ecl_char_downcase(code));
#line 420
	the_env->nvalues = 1;
#line 420
	return __value0;
#line 420
}

}

#line 423
cl_object cl_digit_char(cl_narg narg, cl_object weight, ...)
{
#line 423

#line 424
	const cl_env_ptr the_env = ecl_process_env();
#line 424
	cl_object radix;
#line 424
	va_list ARGS;
	va_start(ARGS, weight);
#line 424
	if (ecl_unlikely(narg < 1|| narg > 2)) FEwrong_num_arguments(ecl_make_fixnum(301));
#line 424
	if (narg > 1) {
#line 424
		radix = va_arg(ARGS,cl_object);
#line 424
	} else {
#line 424
		radix = ecl_make_fixnum(10);
#line 424
	}
#line 424
{
        cl_fixnum basis;
        cl_object output = ECL_NIL;
        if (ecl_unlikely(!ECL_FIXNUMP(radix) ||
                         ecl_fixnum_lower(radix, ecl_make_fixnum(2)) ||
                         ecl_fixnum_greater(radix, ecl_make_fixnum(36)))) {
                FEwrong_type_nth_arg(ecl_make_fixnum(/*DIGIT-CHAR*/301), 2, radix,
                                     ecl_make_integer_type(ecl_make_fixnum(2),
                                                           ecl_make_fixnum(36)));
        }
        basis = ecl_fixnum(radix);
        switch (ecl_t_of(weight)) {
        case t_fixnum: {
                cl_fixnum value = ecl_fixnum(weight);
                if (value >= 0) {
                        int dw = ecl_digit_char(value, basis);
                        if (dw >= 0) {
                                output = ECL_CODE_CHAR(dw);
                        }
                }
                break;
        }
        case t_bignum:
                break;
        default:
                FEwrong_type_nth_arg(ecl_make_fixnum(/*DIGIT-CHAR*/301),1,weight,ecl_make_fixnum(/*INTEGER*/437));
        }
        {
#line 451
	#line 451
	cl_object __value0 = output;
#line 451
	the_env->nvalues = 1;
#line 451
	return __value0;
#line 451
}

} }

short
ecl_digit_char(cl_fixnum w, cl_fixnum r)
{
        if (r < 2 || r > 36 || w < 0 || w >= r)
                return(-1);
        if (w < 10)
                return(w + '0');
        else
                return(w - 10 + 'A');
}

cl_object
cl_char_int(cl_object c)
{
        const cl_env_ptr the_env = ecl_process_env();
        /* INV: ecl_char_code() checks the type of `c' */
        ecl_return1(the_env, ecl_make_fixnum(ecl_char_code(c)));
}

/* here we give every character an implicit name of the form 'u#' where # is a hexadecimal number,
   corresponding to a unicode code point.
   #\u14ea should work, for example
*/

cl_object
cl_char_name(cl_object c)
{
        ecl_character code = ecl_char_code(c);
        cl_object output;
        if (code <= 127) {
                output = ecl_gethash_safe(ecl_make_fixnum(code), cl_core.char_names, ECL_NIL);
        }
#ifdef ECL_UNICODE_NAMES
        else if (!Null(output = _ecl_ucd_code_to_name(code))) {
                (void)0;
        }
#endif
        else {
                ecl_base_char name[8];
                ecl_base_char *start;
                name[7] = 0;
                name[6] = ecl_digit_char(code & 0xF, 16); code >>= 4;
                name[5] = ecl_digit_char(code & 0xF, 16); code >>= 4;
                name[4] = ecl_digit_char(code & 0xF, 16); code >>= 4;
                name[3] = ecl_digit_char(code & 0xF, 16); code >>= 4;
                if (code == 0) {
                        start = name + 2;
                } else {
                        name[2] = ecl_digit_char(code & 0xF, 16); code >>= 4;
                        name[1] = ecl_digit_char(code & 0xF, 16);
                        start = name;
                }
                start[0] = 'U';
                output = make_base_string_copy((const char*)start);
        }
        {
#line 509
	const cl_env_ptr the_env = ecl_process_env();
#line 509
	#line 509
	cl_object __value0 = output;
#line 509
	the_env->nvalues = 1;
#line 509
	return __value0;
#line 509
}
;
}

cl_object
cl_name_char(cl_object name)
{
        const cl_env_ptr the_env = ecl_process_env();
        cl_object c;
        cl_index l;
        name = cl_string(name);
        c = ecl_gethash_safe(name, cl_core.char_names, ECL_NIL);
        if (c != ECL_NIL) {
                ecl_return1(the_env, ECL_CODE_CHAR(ecl_fixnum(c)));
        }
#ifdef ECL_UNICODE_NAMES
        c = _ecl_ucd_name_to_code(name);
        if (c != ECL_NIL) {
                ecl_return1(the_env, cl_code_char(c));
        }
#endif
        if (ecl_stringp(name) && (l = ecl_length(name))) {
                c = cl_char(name, ecl_make_fixnum(0));
                if (l == 1) {
                        (void)0;
                } else if (c != ECL_CODE_CHAR('u') && c != ECL_CODE_CHAR('U')) {
                        c = ECL_NIL;
                } else {
                        cl_index used_l;
                        cl_index end = name->base_string.fillp;
                        cl_index real_end = end;
                        c = ecl_parse_integer(name, 1, end, &real_end, 16);
                        used_l = real_end;
                        if (!ECL_FIXNUMP(c) || (used_l == (l - 1))) {
                                c = ECL_NIL;
                        } else {
                                c = ECL_CODE_CHAR(ecl_fixnum(c));
                        }
                }
        }
        ecl_return1(the_env, c);
}
