/*
 Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa

This file is part of GNU Common Lisp, herein referred to as GCL

GCL 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, or (at your option)
any later version.

GCL is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
License for more details.

You should have received a copy of the GNU Library General Public License 
along with GCL; see the file COPYING.  If not, write to the Free Software
Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
*/

/*
	character.d

	character routines
*/

#include "include.h"

@(defun standard_char_p (c)
	int i;
@
	check_type_character(&c);
	if (char_font(c) != 0 || char_bits(c) != 0)
		@(return Cnil)
	i = char_code(c);
	if (' ' <= i && i < '\177' || i == '\n')
		@(return Ct)
	@(return Cnil)
@)

@(defun graphic_char_p (c)
	int i;
@
	check_type_character(&c);
	if (char_font(c) != 0 || char_bits(c) != 0)
		@(return Cnil)
	i = char_code(c);
	if (' ' <= i && ' ' < '\177')
		@(return Ct)
	@(return Cnil)
@)

@(defun string_char_p (c)
@
	check_type_character(&c);
	if (char_font(c) != 0 || char_bits(c) != 0)
		@(return Cnil)
	@(return Ct)
@)

@(defun alpha_char_p (c)
	int i;
@
	check_type_character(&c);
	if (char_font(c) != 0 || char_bits(c) != 0)
		@(return Cnil)
	i = char_code(c);
	if (isalpha(i))
		@(return Ct)
	else
		@(return Cnil)
@)

@(defun upper_case_p (c)
@
	check_type_character(&c);
	if (char_font(c) != 0 || char_bits(c) != 0)
		@(return Cnil)
	if (isUpper(char_code(c)))
		@(return Ct)
	@(return Cnil)
@)

@(defun lower_case_p (c)
@
	check_type_character(&c);
	if (char_font(c) != 0 || char_bits(c) != 0)
		@(return Cnil)
	if (isLower(char_code(c)))
		@(return Ct)
	@(return Cnil)
@)

@(defun both_case_p (c)
@
	check_type_character(&c);
	if (char_font(c) != 0 || char_bits(c) != 0)
		@(return Cnil)
	if (isUpper(char_code(c)) || isLower(char_code(c)))
		@(return Ct)
	else
		@(return Cnil)
@)

/*
	Digitp(i, r) returns the weight of code i
	as a digit of radix r.
	If r > 36 or i is not a digit, -1 is returned.
*/
digitp(i, r)
int i, r;
{
	if ('0' <= i && i <= '9' && 1 < r && i < '0' + r)
		return(i - '0');
	if ('A' <= i && 10 < r && r <= 36 && i < 'A' + (r - 10))
		return(i - 'A' + 10);
	if ('a' <= i && 10 < r && r <= 36 && i < 'a' + (r - 10))
		return(i - 'a' + 10);
	return(-1);
}

@(defun digit_char_p (c &optional (r `make_fixnum(10)`))
	int d;
@
	check_type_character(&c);
	check_type_non_negative_integer(&r);
	if (type_of(r) == t_bignum)
		@(return Cnil)
	if (char_font(c) != 0 || char_bits(c) != 0)
		@(return Cnil)
	d = digitp(char_code(c), fix(r));
	if (d < 0)
		@(return Cnil)
	@(return `make_fixnum(d)`)
@)

@(defun alphanumericp (c)
	int i;
@
	check_type_character(&c);
	if (char_font(c) != 0 || char_bits(c) != 0)
		@(return Cnil)
	i = char_code(c);
	if (isalphanum(i))
		@(return Ct)
	else
		@(return Cnil)
@)

bool
char_eq(x, y)
object x, y;
{
	return(char_code(x) == char_code(y)
	    && char_bits(x) == char_bits(y)
	    && char_font(x) == char_font(y));
}

@(defun char_eq (c &rest)
	int i;
@
	for (i = 0;  i < narg;  i++)
		check_type_character(&vs_base[i]);
	for (i = 1;  i < narg;  i++)
		if (!char_eq(vs_base[i-1], vs_base[i]))
			@(return Cnil)
	@(return Ct)
@)

@(defun char_neq (c &rest)
	int i, j;
@
	for (i = 0;  i < narg;  i++)
		check_type_character(&vs_base[i]);
	if (narg == 0)
		@(return Ct)
	for (i = 1;  i < narg;  i++)
		for (j = 0;  j < i;  j++)
			if (char_eq(vs_base[j], vs_base[i]))
				@(return Cnil)
	@(return Ct)
@)


int
char_cmp(x, y)
object x, y;
{
	if (char_font(x) < char_font(y))
		return(-1);
	if (char_font(x) > char_font(y))
		return(1);
	if (char_bits(x) < char_bits(y))
		return(-1);
	if (char_bits(x) > char_bits(y))
		return(1);
	if (char_code(x) < char_code(y))
		return(-1);
	if (char_code(x) > char_code(y))
		return(1);
	return(0);
}

Lchar_cmp(s, t)
int s, t;
{
	int narg, i;

	narg = vs_top - vs_base;
	if (narg == 0)
		too_few_arguments();
	for (i = 0; i < narg; i++)
		check_type_character(&vs_base[i]);
	for (i = 1; i < narg; i++)
		if (s*char_cmp(vs_base[i], vs_base[i-1]) < t) {
			vs_top = vs_base+1;
			vs_base[0] = Cnil;
			return;
		}
	vs_top = vs_base+1;
	vs_base[0] = Ct;
}

Lchar_l()  { Lchar_cmp( 1, 1); }
Lchar_g()  { Lchar_cmp(-1, 1); }
Lchar_le() { Lchar_cmp( 1, 0); }
Lchar_ge() { Lchar_cmp(-1, 0); }


bool
char_equal(x, y)
object x, y;
{
	int i, j;

	i = char_code(x);
	j = char_code(y);
	if (isLower(i))
		i -= 'a' - 'A';
	if (isLower(j))
		j -= 'a' - 'A';
	return(i == j);
}

@(defun char_equal (c &rest)
	int i;
@
	for (i = 0;  i < narg;  i++)
		check_type_character(&vs_base[i]);
	for (i = 1;  i < narg;  i++)
		if (!char_equal(vs_base[i-1], vs_base[i]))
			@(return Cnil)
	@(return Ct)
@)

@(defun char_not_equal (c &rest)
	int i, j;
@
	for (i = 0;  i < narg;  i++)
		check_type_character(&vs_base[i]);
	for (i = 1;  i < narg;  i++)
		for (j = 0;  j < i;  j++)
			if (char_equal(vs_base[j], vs_base[i]))
				@(return Cnil)
	@(return Ct)
@)


int
char_compare(x, y)
object x, y;
{
	int i, j;

	i = char_code(x);
	j = char_code(y);
	if (isLower(i))
		i -= 'a' - 'A';
	if (isLower(j))
		j -= 'a' - 'A';
	if (i < j)
		return(-1);
	else if (i == j)
		return(0);
	else
		return(1);
}

Lchar_compare(s, t)
int s, t;
{
	int narg, i;

	narg = vs_top - vs_base;
	if (narg == 0)
		too_few_arguments();
	for (i = 0; i < narg; i++)
		check_type_character(&vs_base[i]);
	for (i = 1; i < narg; i++)
		if (s*char_compare(vs_base[i], vs_base[i-1]) < t) {
			vs_top = vs_base+1;
			vs_base[0] = Cnil;
			return;
		}
	vs_top = vs_base+1;
	vs_base[0] = Ct;
}

Lchar_lessp()        { Lchar_compare( 1, 1); }
Lchar_greaterp()     { Lchar_compare(-1, 1); }
Lchar_not_greaterp() { Lchar_compare( 1, 0); }
Lchar_not_lessp()    { Lchar_compare(-1, 0); }


object
coerce_to_character(x)
object x;
{
BEGIN:
	switch (type_of(x)) {
	case t_fixnum:
		if (0 <= fix(x) && fix(x) < CHCODELIM)
			return(code_char(fix(x)));
		break;

	case t_character:
		return(x);

	case t_symbol:
	case t_string:
		if (x->st.st_fillp == 1)
			return(code_char(x->ust.ust_self[0]));
		break;
	}
	vs_push(x);
	x = wrong_type_argument(sLcharacter, x);
	vs_pop;
	goto BEGIN;
}

@(defun character (x)
@
	@(return `coerce_to_character(x)`)
@)

@(defun char_code (c)
@
	check_type_character(&c);
	@(return `make_fixnum(char_code(c))`)
@)

@(defun char_bits (c)
@
	check_type_character(&c);
	@(return `make_fixnum(char_bits(c))`)
@)

@(defun char_font (c)
@
	check_type_character(&c);
	@(return `make_fixnum(char_font(c))`)
@)

@(defun code_char (c &o (b `make_fixnum(0)`) (f `make_fixnum(0)`))
	object x;
@
	check_type_non_negative_integer(&c);
	check_type_non_negative_integer(&b);
	check_type_non_negative_integer(&f);
	if (type_of(c) == t_bignum)
		@(return Cnil)
	if (type_of(b) == t_bignum)
		@(return Cnil)
	if (type_of(f) == t_bignum)
		@(return Cnil)
	if (fix(c)>=CHCODELIM || fix(b)>=CHBITSLIM || fix(f)>=CHFONTLIM)
		@(return Cnil)
	if (fix(b) == 0 && fix(f) == 0)
		@(return `code_char(fix(c))`)
	x = alloc_object(t_character);
	char_code(x) = fix(c);
	char_bits(x) = fix(b);
	char_font(x) = fix(f);
	@(return x)
@)

@(defun make_char (c &o (b `make_fixnum(0)`) (f `make_fixnum(0)`))
	object x;
	int code;
@
	check_type_character(&c);
	code = char_code(c);
	check_type_non_negative_integer(&b);
	check_type_non_negative_integer(&f);
	if (type_of(b) == t_bignum)
		@(return Cnil)
	if (type_of(f) == t_bignum)
		@(return Cnil)
	if (fix(b)>=CHBITSLIM || fix(f)>=CHFONTLIM)
		@(return Cnil)
	if (fix(b) == 0 && fix(f) == 0)
		@(return `code_char(code)`)
	x = alloc_object(t_character);
	char_code(x) = code;
	char_bits(x) = fix(b);
	char_font(x) = fix(f);
	@(return x)
@)

@(defun char_upcase (c)
@
	check_type_character(&c);
	if (char_font(c) != 0 || char_bits(c) != 0)
		@(return c)
	if (isLower(char_code(c)))
		@(return `code_char(char_code(c) - ('a' - 'A'))`)
	else
		@(return c)
@)

@(defun char_downcase (c)
@
	check_type_character(&c);
	if (char_font(c) != 0 || char_bits(c) != 0)
		@(return Cnil)
	if (isUpper(char_code(c)))
		@(return `code_char(char_code(c) + ('a' - 'A'))`)
	else
		@(return c)
@)

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

@(defun digit_char (w
		    &optional
		    (r `make_fixnum(10)`)
		    (f `make_fixnum(0)`))
	object x;
	int dw;
@
	check_type_non_negative_integer(&w);
	check_type_non_negative_integer(&r);
	check_type_non_negative_integer(&f);
	if (type_of(w) == t_bignum)
		@(return Cnil)
	if (type_of(r) == t_bignum)
		@(return Cnil)
	if (type_of(f) == t_bignum)
		@(return Cnil)
	dw = digit_weight(fix(w), fix(r));
	if (dw < 0)
		@(return Cnil)
	if (fix(f) >= CHFONTLIM)
		@(return Cnil)
	if (fix(f) == 0)
		@(return `code_char(dw)`)
	x = alloc_object(t_character);
	char_code(x) = dw;
	char_bits(x) = 0;
	char_font(x) = fix(f);
	@(return x)
@)

@(defun char_int (c)
	int i;
@
	check_type_character(&c);
	i = (char_font(c)*CHBITSLIM + char_bits(c))*CHCODELIM
	  + char_code(c);
	@(return `make_fixnum(i)`)
@)

@(defun int_char (x)
	int i, c, b, f;
@
	check_type_non_negative_integer(&x);
	if (type_of(x) == t_bignum)
		@(return Cnil)
	i = fix(x);
	c = i % CHCODELIM;
	i /= CHCODELIM;
	b = i % CHBITSLIM;
	i /= CHBITSLIM;
	f = i % CHFONTLIM;
	i /= CHFONTLIM;
	if (i > 0)
		@(return Cnil)
	if (b == 0 && f == 0)
		@(return `code_char(c)`)
	x = alloc_object(t_character);
	char_code(x) = c;
	char_bits(x) = b;
	char_font(x) = f;
	@(return x)
@)

@(defun char_name (c)
@
	check_type_character(&c);
	if (char_bits(c) != 0 || char_font(c) != 0)
		@(return Cnil)
	switch (char_code(c)) {
	case '\r':
		@(return STreturn)

	case ' ':
		@(return STspace)

	case '\177':
		@(return STrubout)
	
	case '\f':
		@(return STpage)

	case '\t':
		@(return STtab)

	case '\b':
		@(return STbackspace)

	case '\n':
		@(return STnewline)
	}
	@(return Cnil)
@)

@(defun name_char (s)
@
	s = coerce_to_string(s);
	if (string_equal(s, STreturn))
		@(return `code_char('\r')`)
	if (string_equal(s, STspace))
		@(return `code_char(' ')`)
	if (string_equal(s, STrubout))
		@(return `code_char('\177')`)
	if (string_equal(s, STpage))
		@(return `code_char('\f')`)
	if (string_equal(s, STtab))
		@(return `code_char('\t')`)
	if (string_equal(s, STbackspace))
		@(return `code_char('\b')`)
	if (string_equal(s, STlinefeed) || string_equal(s, STnewline))
		@(return `code_char('\n')`)
	@(return Cnil)
@)

@(defun char_bit (c n)
@
	check_type_character(&c);
	FEerror("Cannot get char-bit of ~S.", 1, c);
@)

@(defun set_char_bit (c n v)
@
	check_type_character(&c);
	FEerror("Cannot set char-bit of ~S.", 1, c);
@)

init_character()
{
	object ch;
	int i;

	for (i = 0;  i < CHCODELIM;  i++) {
		character_table[i].t = (short)t_character;
		character_table[i].ch_code = i;
		character_table[i].ch_font = 0;
		character_table[i].ch_bits = 0;
	}
#ifdef AV
	for (i = -128;  i < 0;  i++) {
		character_table[i].t = (short)t_character;
		character_table[i].ch_code = i+CHCODELIM;
		character_table[i].ch_font = 0;
		character_table[i].ch_bits = 0;
	}
#endif

 	make_constant("CHAR-CODE-LIMIT", make_fixnum(CHCODELIM));
 	make_constant("CHAR-FONT-LIMIT", make_fixnum(CHFONTLIM));
 	make_constant("CHAR-BITS-LIMIT", make_fixnum(CHBITSLIM));

	STreturn = make_simple_string("RETURN");
	enter_mark_origin(&STreturn);
	STspace = make_simple_string("SPACE");
	enter_mark_origin(&STspace);
	STrubout = make_simple_string("RUBOUT");
	enter_mark_origin(&STrubout);
	STpage = make_simple_string("PAGE");
	enter_mark_origin(&STpage);
	STtab = make_simple_string("TAB");
	enter_mark_origin(&STtab);
	STbackspace = make_simple_string("BACKSPACE");
	enter_mark_origin(&STbackspace);
	STlinefeed = make_simple_string("LINEFEED");
	enter_mark_origin(&STlinefeed);

	STnewline = make_simple_string("NEWLINE");
	enter_mark_origin(&STnewline);

	make_constant("CHAR-CONTROL-BIT", make_fixnum(0));
	make_constant("CHAR-META-BIT", make_fixnum(0));
	make_constant("CHAR-SUPER-BIT", make_fixnum(0));
	make_constant("CHAR-HYPER-BIT", make_fixnum(0));
}

init_character_function()
{
	make_function("STANDARD-CHAR-P", Lstandard_char_p);
	make_function("GRAPHIC-CHAR-P", Lgraphic_char_p);
	make_function("STRING-CHAR-P", Lstring_char_p);
	make_function("ALPHA-CHAR-P", Lalpha_char_p);
	make_function("UPPER-CASE-P", Lupper_case_p);
	make_function("LOWER-CASE-P", Llower_case_p);
	make_function("BOTH-CASE-P", Lboth_case_p);
	make_function("DIGIT-CHAR-P", Ldigit_char_p);
	make_function("ALPHANUMERICP", Lalphanumericp);
	make_function("CHAR=", Lchar_eq);
	make_function("CHAR/=", Lchar_neq);
	make_function("CHAR<", Lchar_l);
	make_function("CHAR>", Lchar_g);
	make_function("CHAR<=", Lchar_le);
	make_function("CHAR>=", Lchar_ge);
	make_function("CHAR-EQUAL", Lchar_equal);
	make_function("CHAR-NOT-EQUAL", Lchar_not_equal);
	make_function("CHAR-LESSP", Lchar_lessp);
	make_function("CHAR-GREATERP", Lchar_greaterp);
	make_function("CHAR-NOT-GREATERP", Lchar_not_greaterp);
	make_function("CHAR-NOT-LESSP", Lchar_not_lessp);
	make_function("CHARACTER", Lcharacter);
	make_function("CHAR-CODE", Lchar_code);
	make_function("CHAR-BITS", Lchar_bits);
	make_function("CHAR-FONT", Lchar_font);
	make_function("CODE-CHAR", Lcode_char);
	make_function("MAKE-CHAR", Lmake_char);
	make_function("CHAR-UPCASE", Lchar_upcase);
	make_function("CHAR-DOWNCASE", Lchar_downcase);
	make_function("DIGIT-CHAR", Ldigit_char);
	make_function("CHAR-INT", Lchar_int);
	make_function("INT-CHAR", Lint_char);
	make_function("CHAR-NAME", Lchar_name);
	make_function("NAME-CHAR", Lname_char);
	make_function("CHAR-BIT", Lchar_bit);
	make_function("SET-CHAR-BIT", Lset_char_bit);
}