// ### 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;
}
}
}
// ### 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;
}
}
}
// ### 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;
}
}
}
void aes128_string_parse(const char *string, uint8_t *data) {
assert(strlen(string) == 32);
int i;
for (i = 0; i < 16; i++)
data[i] = char_value(string[i * 2]) * 16 + char_value(string[i * 2 + 1]);
}
Value SimpleString::aset(unsigned long i, Value new_value)
{
if (i >= _capacity)
return bad_index(i);
_chars[i] = char_value(new_value);
return new_value;
}
// ### upper-case-p character => generalized-boolean
Value CL_upper_case_p(Value arg)
{
char c = char_value(arg);
if ('A' <= c && c <= 'Z')
return T;
return NIL;
}
// ### digit-char-p char &optional radix => weight
Value CL_digit_char_p(unsigned int numargs, Value args[])
{
if (numargs < 1 || numargs > 2)
return wrong_number_of_arguments(S_digit_char_p, numargs, 1, 2);
BASE_CHAR c = char_value(args[0]);
int radix;
if (numargs == 2)
radix = check_index(args[1], 2, 36);
else
radix = 10;
if (c >= '0')
{
int n = c - '0';
if (radix <= 10)
return (n < radix) ? make_fixnum(n) : NIL;
if (n < 10)
return make_fixnum(n);
if (c >= 'A')
{
// A-Z
n -= 7;
if (n >= 10 && n < radix)
return make_fixnum(n);
if (c >= 'a')
{
// a-z
n -= 32;
if (n >= 10 && n < radix)
return make_fixnum(n);
}
}
}
return NIL;
}
// ### lower-case-p character => generalized-boolean
Value CL_lower_case_p(Value arg)
{
char c = char_value(arg);
if ('a' <= c && c <= 'z')
return T;
return NIL;
}
AbstractVector * SimpleString::adjust_vector(INDEX new_capacity,
Value initial_element,
Value initial_contents)
{
if (initial_contents != NIL)
{
BASE_CHAR * new_chars = (BASE_CHAR *) GC_malloc_atomic(new_capacity + 1);
if (listp(initial_contents))
{
Value list = initial_contents;
for (unsigned long i = 0; i < new_capacity; i++)
{
new_chars[i] = char_value(car(list));
list = xcdr(list);
}
}
else if (vectorp(initial_contents))
{
AbstractVector * v = the_vector(initial_contents);
for (unsigned long i = 0; i < new_capacity; i++)
new_chars[i] = char_value(v->aref(i));
}
else
signal_type_error(initial_contents, S_sequence);
new_chars[new_capacity] = 0;
return new_simple_string(new_capacity, new_chars);
}
if (_capacity != new_capacity)
{
BASE_CHAR * new_chars = (BASE_CHAR *) GC_malloc_atomic(new_capacity + 1);
unsigned long limit = (_capacity < new_capacity) ? _capacity : new_capacity;
for (unsigned long i = 0; i < limit; i++)
new_chars[i] = _chars[i];
if (_capacity < new_capacity)
{
BASE_CHAR c = char_value(initial_element);
for (unsigned long i = _capacity; i < new_capacity; i++)
new_chars[i] = c;
}
new_chars[new_capacity] = 0;
return new_simple_string(new_capacity, new_chars);
}
// No change.
return this;
}
// ### both-case-p character => generalized-boolean
Value CL_both_case_p(Value arg)
{
char c = char_value(arg);
if ('A' <= c && c <= 'Z')
return T;
if ('a' <= c && c <= 'z')
return T;
return NIL;
}
// ### graphic-char-p character => generalized-boolean
Value CL_graphic_char_p(Value arg)
{
BASE_CHAR c = char_value(arg);
if (c >= 32 && c < 127)
return T;
if (c >= 160)
return T;
return NIL;
}
cell pp_curs_mvinsch(cell x) {
char name[] = "curs:mvinsch";
if (!Running) return UNSPECIFIC;
mvinsch(integer_value(name, car(x)),
integer_value(name, cadr(x)),
char_value(caddr(x)));
return UNSPECIFIC;
}
// ### alpha-char-p character => generalized-boolean
Value CL_alpha_char_p(Value character)
{
char c = char_value(character);
if ('A' <= c && c <= 'Z')
return T;
if ('a' <= c && c <= 'z')
return T;
return NIL;
}
// ### alphanumericp character => generalized-boolean
Value CL_alphanumericp(Value character)
{
char c = char_value(character);
if ('A' <= c && c <= 'Z')
return T;
if ('a' <= c && c <= 'z')
return T;
if ('0' <= c && c <= '9')
return T;
return NIL;
}
// ### fasl-sharp-illegal stream sub-char numarg => value
Value SYS_fasl_sharp_illegal(Value streamarg, Value subchar, Value numarg)
{
Stream * stream = check_ansi_stream(streamarg);
String * s = new String("Illegal # macro character: #\\");
Value name = CL_char_name(subchar);
if (stringp(name))
s->append(the_string(name));
else
s->append_char(char_value(subchar));
return signal_lisp_error(new ReaderError(stream, s));
}
// ### 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;
}
}
}
// FIXME check the character's syntax type in *READTABLE*
// ### whitespacep character => T or NIL
Value SYS_whitespacep(Value arg)
{
switch (char_value(arg))
{
case 9: // tab
case 10: // linefeed
case 12: // form feed
case 13: // return
case ' ': // space
return T;
default:
return NIL;
}
}
// ### 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;
}
}
}
void display(LISP_OBJ_PTR objp) {
switch (objp->form) {
case INT_FORM:
fprintf(out_stream, "%d", int_value(objp));
break;
case FLOAT_FORM:
fprintf(out_stream, "%g", float_value(objp));
break;
case CHAR_FORM:
fprintf(out_stream, "%c", char_value(objp));
break;
case STRING_FORM:
fprintf(out_stream, "%s", string_value(objp));
break;
case SYMBOL_FORM:
fprintf(out_stream, "%s", symbol_value(objp));
break;
case PROCEDURE_FORM:
fprintf(out_stream, "<PROCEDURE>");
break;
case BOOLEAN_FORM:
fprintf(out_stream, "#%c", bool_value(objp) ? 't' : 'f');
break;
case CONS_FORM:
fprintf(out_stream, "(");
while (TRUE) {
print_lispobj(car(objp));
objp = cdr(objp);
if (objp == nil_ptr)
break;
if (!(is_pair(objp))) {
printf(" . ");
print_lispobj(objp);
break;
}
fprintf(out_stream, " ");
}
fprintf(out_stream, ")");
break;
case NO_FORM:
fprintf(out_stream, "no form, boss");
break;
default:
fprintf(out_stream, "dunno that form %d", form(objp));
}
}
int get_roman_int(const char *rom)
{
int previous = 0;
int total = 0;
// Checking if i != 0 is faster than a lt/gt comparison, and we wanted
// a reversed iteration anyway
for (int i = strnlen(rom,MAX_STRLEN); i != 0; i--)
{
int conv = char_value(rom[i-1]);
// If the previous reading was lesser, it's a newer, larger number to add
// Else, it's a subtraction (e.g. IV == 5 - 1 == 4)
total += ((previous <= conv) ? (conv) : (conv * -1));
// Record the previous
previous = conv;
}
return total;
}
// ### char-name character => name
Value CL_char_name(Value arg)
{
const char * s = NULL;
BASE_CHAR c = char_value(arg);
switch (c)
{
case 0:
s = "Null";
break;
case 7:
s = "Bell";
break;
case '\b':
s = "Backspace";
break;
case '\t':
s = "Tab";
break;
case '\n':
s = "Newline";
break;
case '\f':
s = "Page";
break;
case '\r':
s = "Return";
break;
case ' ':
s = "Space";
break;
case 127:
s = "Rubout";
break;
}
return s ? make_simple_string(s) : NIL;
}
unsigned long int
strtoul(const char *nptr, char **endptr, int base)
{
/*
Decompose input into threee parts:
- initial list of whitespace (as per isspace)
- subject sequence
- final string one or more unrecognized
*/
const char *ptr = nptr;
bool negative = false;
unsigned int value;
long int return_value = 0;
/* Remove spaces */
while(*ptr != '\0') {
if (! isspace(*ptr)) {
break;
}
ptr++;
}
if (*ptr == '\0')
goto fail;
/* check [+|-] */
if (*ptr == '+') {
ptr++;
} else if (*ptr == '-') {
negative = true;
ptr++;
}
if (*ptr == '\0')
goto fail;
if (base == 16) {
/* _May_ have 0x prefix */
if (*ptr == '0') {
ptr++;
if (*ptr == 'x' || *ptr == 'X') {
ptr++;
}
}
}
/* [0(x|X)+] */
if (base == 0) {
/* Could be hex or octal or decimal */
if (*ptr != '0') {
base = 10;
} else {
ptr++;
if (ptr == '\0')
goto fail;
if (*ptr == 'x' || *ptr == 'X') {
base = 16;
ptr++;
} else {
base = 8;
}
}
}
if (*ptr == '\0')
goto fail;
/* Ok, here we have a base, and we might have a valid number */
value = char_value(*ptr);
if (value >= base) {
goto fail;
} else {
return_value = value;
ptr++;
}
while (*ptr != '\0' && (value = char_value(*ptr)) < base) {
return_value = return_value * base + value;
ptr++;
}
if (endptr != NULL)
*endptr = (char*) ptr;
if (negative) {
return_value *= -1;
}
return return_value;
/*
if base is 0, then we work it out based on a couple
of things
*/
/*
[+|-][0(x|X)+][0-9A-Za-z] not LL *
*/
/* endptr == final string */
fail:
if (endptr != NULL)
*endptr = (char*) nptr;
return 0;
}
long_double_t
__strtold(char **endptr, int size, char *(*get_next_char)(const void**),
void (*inc_next_char)(const void**), const void *func_data)
{
char buf[50];
unsigned int pos, mant_start, mant_end;
char *s;
int base = 10;
int sign = 0;
int exp = 0;
int exp_sign = 0;
int mant_size = 0;
int has_point = 0;
int possible_underflow = 0;
buf[0] = '\0';
pos = 0;
mant_start = 0;
mant_end = 0;
long_double_t result = 0.0;
long_double_t old_res;
if (size <= 0) {
size = 10000;
}
s = get_next_char(&func_data);
if (s == NULL || *s == '\0') {
goto fail;
}
/* Ignore blank spaces */
while (isspace(*s)) {
inc_next_char(&func_data);
s = get_next_char(&func_data);
if (s == NULL || *s == '\0') {
goto fail;
}
}
/* Check for sign */
if (*s == '-') {
sign = 1;
inc_next_char(&func_data);
if (--size <= 0) {
goto end_ret;
}
s = get_next_char(&func_data);
} else if (*s == '+') {
sign = 0;
inc_next_char(&func_data);
if (--size <= 0) {
goto end_ret;
}
s = get_next_char(&func_data);
}
if (s == NULL || *s == '\0') {
goto fail;
}
if (*s == '0') {
inc_next_char(&func_data);
if (--size <= 0) {
goto end_ret;
}
s = get_next_char(&func_data);
if (s == NULL || *s == '\0') { /* input = "(+|-)0" = 0 */
return 0;
}
if (*s == 'x' || *s == 'X') {
base = 16;
inc_next_char(&func_data);
if (--size <= 0) {
goto end_ret;
}
s = get_next_char(&func_data);
}
}
mant_start = pos = 0;
while (s && *s != '\0' && (isdigit(*s) || *s == '.')) {
if (*s == '.') {
if (has_point) {
break;
} else {
has_point = 1;
}
} else {
buf[pos] = *s;
if (!has_point) {
mant_size++;
}
pos++;
}
inc_next_char(&func_data);
if (--size <= 0) {
goto end_ret;
}
s = get_next_char(&func_data);
}
if (s && (*s == 'e' || *s == 'E' || *s == 'p' || *s == 'P')) {
inc_next_char(&func_data);
if (--size <= 0) {
goto end_ret;
}
s = get_next_char(&func_data);
if (s == NULL || *s == '\0') {
goto end_ret;
}
if (*s == '+' || *s == '-') {
if (*s == '-') {
exp_sign = 1;
} else {
exp_sign = 0;
}
inc_next_char(&func_data);
if (--size <= 0) {
goto end_ret;
}
s = get_next_char(&func_data);
}
while (s && *s != '\0' && isdigit(*s)) {
exp *= 10;
exp += (*s - '0');
inc_next_char(&func_data);
if (--size <= 0) {
goto end_ret;
}
s = get_next_char(&func_data);
}
}
if(exp_sign && exp != 0) {
possible_underflow = 1;
}
end_ret:
if (base == 10) {
if (exp_sign) {
exp = exp - (mant_size - 1);
} else {
exp = exp + (mant_size - 1);
}
} else if (base == 16) {
if (exp_sign) {
exp = exp - ((mant_size - 1) * 4);
} else {
exp = exp + ((mant_size - 1) * 4);
}
}
if (exp < 0) {
exp *= -1;
if (exp_sign) {
exp_sign = 0;
} else {
exp_sign = 1;
}
}
mant_end = pos-1;
if (base == 10) {
pos = mant_start;
for (; pos <= mant_end; pos++) {
old_res = result;
if (exp_sign) {
result = result +
(long_double_t)((long_double_t)char_value(buf[pos]) /
(long_double_t)get_power_of_10(exp));
} else {
result = result +
(long_double_t)((long_double_t)char_value(buf[pos]) *
(long_double_t)get_power_of_10(exp));
}
if (exp_sign) {
exp++;
} else {
exp--;
if (exp < 0) {
exp *= -1;
if (exp_sign) {
exp_sign = 0;
} else {
exp_sign = 1;
}
}
}
if (result != old_res && result == (result/2)) {
errno = ERANGE;
return result;
}
}
} else if (base == 16) {
pos = mant_start;
for (; pos <= mant_end; pos++) {
old_res = result;
if (exp_sign) {
result = result +
(long_double_t)((long_double_t)char_value(buf[pos]) /
(long_double_t)(1 << exp));
} else {
result = result +
(long_double_t)((long_double_t)(char_value(buf[pos]) *
(long_double_t)(1 << exp)));
}
if (exp_sign) {
exp += 4;
} else {
exp -= 4;
if (exp < 0) {
exp *= -1;
if (exp_sign) {
exp_sign = 0;
} else {
exp_sign = 1;
}
}
}
if (result != old_res && result == (result/2)) {
errno = ERANGE;
return result;
}
}
}
if (possible_underflow && result == (result/2)) {
errno = ERANGE;
}
return result;
fail:
errno = EINVAL;
return 0;
}
// ### fasl-read-string stream character => value
Value SYS_fasl_read_string(Value streamarg, Value character)
{
return stream_read_string(streamarg, char_value(character), FASL_READTABLE);
}
// ### fasl-read-dispatch-char stream character => value
Value SYS_fasl_read_dispatch_char(Value streamarg, Value character)
{
return stream_read_dispatch_char(streamarg, char_value(character), current_thread(), FASL_READTABLE);
}
// ### two-arg-char<
Value SYS_two_arg_char_lt(Value arg1, Value arg2)
{
return char_value(arg1) < char_value(arg2) ? T : NIL;
}
// ### char-upcase
Value CL_char_upcase(Value arg)
{
return make_character(toupper(char_value(arg)));
}
// ### char-downcase
Value CL_char_downcase(Value arg)
{
return make_character(tolower(char_value(arg)));
}
// ### two-arg-char>=
Value SYS_two_arg_char_ge(Value arg1, Value arg2)
{
return char_value(arg1) >= char_value(arg2) ? T : NIL;
}
// ### char-int character => integer
Value CL_char_int(Value arg)
{
return make_fixnum(char_value(arg));
}