// ### 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; }