// ### char=
Value CL_char_e(unsigned int numargs, Value args[])
{
switch (numargs)
{
case 0:
return wrong_number_of_arguments(S_char_e, numargs, 1, MANY);
case 1:
if (characterp(args[0]))
return T;
else
return signal_type_error(args[0], S_character);
case 2:
if (!characterp(args[0]))
return signal_type_error(args[0], S_character);
if (args[0] == args[1])
return T;
if (!characterp(args[1]))
return signal_type_error(args[1], S_character);
return NIL;
default:
{
BASE_CHAR c0 = char_value(args[0]);
for (unsigned int i = 1; i < numargs; i++)
{
if (c0 != char_value(args[i]))
return NIL;
}
return T;
}
}
}
// ### char/=
Value CL_char_ne(unsigned int numargs, Value args[])
{
switch (numargs)
{
case 0:
return wrong_number_of_arguments(S_char_ne, numargs, 1, MANY);
case 1:
if (characterp(args[0]))
return T;
else
return signal_type_error(args[0], S_character);
case 2:
if (!characterp(args[0]))
return signal_type_error(args[0], S_character);
if (!characterp(args[1]))
return signal_type_error(args[1], S_character);
return args[0] != args[1] ? T : NIL;
default:
{
for (unsigned int i = 0; i < numargs - 1; i++)
{
unsigned char c = char_value(args[i]);
for (unsigned int j = i + 1; j < numargs; j++)
{
if (char_value(args[j]) == c)
return NIL;
}
}
return T;
}
}
}
// ### two-arg-char=
Value SYS_two_arg_char_e(Value arg1, Value arg2)
{
if (!characterp(arg1))
return signal_type_error(arg1, S_character);
if (arg1 == arg2)
return T;
if (!characterp(arg2))
return signal_type_error(arg2, S_character);
return NIL;
}
// ### two-arg-char-equal
Value SYS_two_arg_char_equal(Value arg1, Value arg2)
{
if (!characterp(arg1))
return signal_type_error(arg1, S_character);
if (arg1 == arg2)
return T;
if (!characterp(arg2))
return signal_type_error(arg2, S_character);
BASE_CHAR c1 = xchar(arg1);
BASE_CHAR c2 = xchar(arg2);
if (toupper(c1) == toupper(c2))
return T;
return NIL;
}
// ### char-not-equal
Value CL_char_not_equal(unsigned int numargs, Value args[])
{
switch (numargs)
{
case 0:
return wrong_number_of_arguments(S_char_ne, numargs, 1, MANY);
case 1:
if (characterp(args[0]))
return T;
else
return signal_type_error(args[0], S_character);
case 2:
{
unsigned char c0 = char_value(args[0]);
unsigned char c1 = char_value(args[1]);
return (c0 == c1 || toupper(c0) == toupper(c1)) ? NIL : T;
}
default:
{
for (unsigned int i = 0; i < numargs; i++)
args[i] = toupper(char_value(args[i]));
for (unsigned int i = 0; i < numargs - 1; i++)
{
unsigned char c = args[i];
for (unsigned int j = i + 1; j < numargs; j++)
{
if (args[j] == c)
return NIL;
}
}
return T;
}
}
}
// ### standard-char-p character => generalized-boolean
// must signal an error of type TYPE-ERROR if arg is not a character
Value CL_standard_char_p(Value arg)
{
if (standard_char_p(arg))
return T;
if (characterp(arg))
return NIL;
return signal_type_error(arg, S_character);
}
/*FUNCTION*/
LVAL c_char_code(tpLspObject pLSP,
LVAL p
){
/*noverbatim
CUT*/
LVAL q;
if( null(p) || !characterp(p) )return NIL;
q = newint();
setint(q,(int)getchr(p));
return q;
}
/*FUNCTION*/
LVAL c_char_upcase(tpLspObject pLSP,
LVAL p
){
/*noverbatim
CUT*/
LVAL q;
if( null(p) || !characterp(p) )return NIL;
q = newchar();
setchar(q, (isalpha(getchr(p)) && islower(getchr(p))) ?
toupper((int) getchr(p)) : getchr(p));
return q;
}
// ### char-equal
Value CL_char_equal(unsigned int numargs, Value args[])
{
switch (numargs)
{
case 0:
return wrong_number_of_arguments(S_char_equal, numargs, 1, MANY);
case 1:
if (characterp(args[0]))
return T;
else
return signal_type_error(args[0], S_character);
case 2:
{
if (!characterp(args[0]))
return signal_type_error(args[0], S_character);
if (args[0] == args[1])
return T;
if (!characterp(args[1]))
return signal_type_error(args[1], S_character);
BASE_CHAR c1 = xchar(args[0]);
BASE_CHAR c2 = xchar(args[1]);
if (toupper(c1) == toupper(c2))
return T;
return NIL;
}
default:
{
BASE_CHAR c0 = char_value(args[0]);
for (INDEX i = 1; i < numargs; i++)
{
BASE_CHAR c1 = char_value(args[i]);
if (c0 != c1 && toupper(c0) != toupper(c1))
return NIL;
}
return T;
}
}
}
// ### character
Value CL_character(Value arg)
{
if (characterp(arg))
return arg;
else if (stringp(arg))
{
AbstractString * s = the_string(arg);
if (s->length() == 1)
return make_character(s->fast_char_at(0));
}
else if (symbolp(arg))
{
SimpleString * s = the_symbol(arg)->name();
if (s && s->length() == 1)
return make_character(s->fast_char_at(0));
}
return signal_type_error(arg, S_character_designator);
}
atom_t
brz_deriv( atom_t atom, int c )
{
if( characterp(atom) )
return PREDICATE( equalp(atom, ULISP_CHAR(c)) );
if( re_is_seq(atom) )
return re_alt(
re_seq( brz_deriv(cadr(atom), c), caddr(atom) ),
re_seq( PREDICATE(brz_is_nullable(cadr(atom))), brz_deriv(caddr(atom), c) ));
if( re_is_alt(atom) )
return re_alt( brz_deriv(cadr(atom), c), brz_deriv(caddr(atom), c) );
if( re_is_rep(atom) )
return re_seq( brz_deriv(cadr(atom), c), re_rep(cadr(atom)) );
return PREDICATE( re_is_any(atom) );
}
// ### char-not-lessp
Value CL_char_not_lessp(unsigned int numargs, Value args[])
{
switch (numargs)
{
case 0:
return wrong_number_of_arguments(S_char_not_lessp, numargs, 1, MANY);
case 1:
if (characterp(args[0]))
return T;
else
return signal_type_error(args[0], S_character);
case 2:
return toupper(char_value(args[0])) >= toupper(char_value(args[1])) ? T : NIL;
default:
{
for (unsigned int i = 1; i < numargs; i++)
{
if (toupper(char_value(args[i - 1])) < toupper(char_value(args[i])))
return NIL;
}
return T;
}
}
}
// ### characterp
Value CL_characterp(Value arg)
{
return characterp(arg) ? T : NIL;
}
