/*
 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.

*/

/*
	typespec.c

	type specifier routines
*/

#define NEED_MP_H
#include "include.h"

object sLkeyword;

enum type t_vtype;
int vtypep_fn(object x) {return type_of(x)==t_vtype;}

LFD(Ltype_of)(void)
{
	int i;

	check_arg(1);

	switch (type_of(vs_base[0])) {
	case t_fixnum:
		vs_base[0] = sLfixnum;
		break;

	case t_bignum:
		vs_base[0] = sLbignum;
		break;

	case t_ratio:
		vs_base[0] = sLratio;
		break;

	case t_shortfloat:
		vs_base[0] = sLshort_float;
		break;

	case t_longfloat:
		vs_base[0] = sLlong_float;
		break;

	case t_complex:
		vs_base[0] = sLcomplex;
		break;

	case t_character:
		if (char_font(vs_base[0]) != 0
		 || char_bits(vs_base[0]) != 0)
			vs_base[0] = sLcharacter;
		else {
			i = char_code(vs_base[0]);
			if ((' ' <= i && i < '\177') || i == '\n')
				vs_base[0] = sLstandard_char;
			else
				vs_base[0] = sLcharacter;
		}
		break;

	case t_symbol:
		if (vs_base[0]->s.s_hpack == keyword_package)
			vs_base[0] = sLkeyword;
		else
			vs_base[0] = sLsymbol;
		break;

	case t_package:
		vs_base[0] = sLpackage;
		break;

	case t_cons:
		vs_base[0] = sLcons;
		break;

	case t_hashtable:
		vs_base[0] = sLhash_table;
		break;

	case t_array:
		if (vs_base[0]->a.a_adjustable ||
		    vs_base[0]->a.a_displaced->c.c_car == Cnil)
			vs_base[0] = sLarray;
		else
			vs_base[0] = sLsimple_array;
		break;

	case t_vector:
		if (vs_base[0]->v.v_adjustable ||
		    vs_base[0]->v.v_hasfillp ||
		    vs_base[0]->v.v_displaced->c.c_car == Cnil ||
		    (enum aelttype)vs_base[0]->v.v_elttype != aet_object)
			vs_base[0] = sLvector;
		else
			vs_base[0] = sLsimple_vector;
		break;

	case t_string:
		if (vs_base[0]->st.st_adjustable ||
		    vs_base[0]->st.st_hasfillp ||
		    vs_base[0]->st.st_displaced->c.c_car == Cnil)
			vs_base[0] = sLstring;
		else
			vs_base[0] = sLsimple_string;
		break;

	case t_bitvector:
		if (vs_base[0]->bv.bv_adjustable ||
		    vs_base[0]->bv.bv_hasfillp ||
		    vs_base[0]->bv.bv_displaced->c.c_car == Cnil)
			vs_base[0] = sLbit_vector;
		else
			vs_base[0] = sLsimple_bit_vector;
		break;

	case t_structure:
		
		vs_base[0] = S_DATA(vs_base[0]->str.str_def)->name;
		break;

	case t_stream:
#ifdef USER_DEFINED_STREAMS
		if (vs_base[0]->sm.sm_mode == (int)smm_user_defined)
		   vs_base[0]= vs_base[0]->sm.sm_object1->str.str_self[8];
		else
#endif
		vs_base[0] = sLstream;
		break;

	case t_readtable:
		vs_base[0] = sLreadtable;
		break;

	case t_pathname:
		vs_base[0] = sLpathname;
		break;

	case t_random:
		vs_base[0] = sLrandom_state;
		break;

	case t_sfun:
	case t_gfun:	
	case t_cfun:
        case t_vfun:
	case t_afun:
	case t_cclosure:
        case t_closure:
		vs_base[0] = sLcompiled_function;
		break;

	default:
		error("not a lisp data object");
	}
}

DEF_ORDINARY("PROCLAIMED-ARG-TYPES",sSproclaimed_arg_types,SI,"");
DEF_ORDINARY("PROCLAIMED-RETURN-TYPE",sSproclaimed_return_type,SI,"");
DEF_ORDINARY("PROCLAIMED-FUNCTION",sSproclaimed_function,SI,"");
DEF_ORDINARY("NULL",sLnull,LISP,"");
DEF_ORDINARY("CONS",sLcons,LISP,"");
DEF_ORDINARY("LIST",sLlist,LISP,"");
DEF_ORDINARY("SYMBOL",sLsymbol,LISP,"");
DEF_ORDINARY("ARRAY",sLarray,LISP,"");
DEF_ORDINARY("VECTOR",sLvector,LISP,"");
DEF_ORDINARY("BIT-VECTOR",sLbit_vector,LISP,"");
DEF_ORDINARY("STRING",sLstring,LISP,"");
DEF_ORDINARY("SEQUENCE",sLsequence,LISP,"");
DEF_ORDINARY("SIMPLE-ARRAY",sLsimple_array,LISP,"");
DEF_ORDINARY("SIMPLE-VECTOR",sLsimple_vector,LISP,"");
DEF_ORDINARY("SIMPLE-BIT-VECTOR",sLsimple_bit_vector,LISP,"");
DEF_ORDINARY("SIMPLE-STRING",sLsimple_string,LISP,"");
DEF_ORDINARY("FUNCTION",sLfunction,LISP,"");
DEF_ORDINARY("COMPILED-FUNCTION",sLcompiled_function,LISP,"");
DEF_ORDINARY("PATHNAME",sLpathname,LISP,"");
DEF_ORDINARY("CHARACTER",sLcharacter,LISP,"");
DEF_ORDINARY("NUMBER",sLnumber,LISP,"");
DEF_ORDINARY("RATIONAL",sLrational,LISP,"");
DEF_ORDINARY("FLOAT",sLfloat,LISP,"");
DEF_ORDINARY("REAL",sLreal,LISP,"");
DEF_ORDINARY("INTEGER",sLinteger,LISP,"");
DEF_ORDINARY("RATIO",sLratio,LISP,"");
DEF_ORDINARY("SHORT-FLOAT",sLshort_float,LISP,"");
DEF_ORDINARY("STANDARD-CHAR",sLstandard_char,LISP,"");
DEF_ORDINARY("BOOLEAN",sLboolean,LISP,"");
DEF_ORDINARY("FIXNUM",sLfixnum,LISP,"");
DEF_ORDINARY("COMPLEX",sLcomplex,LISP,"");
DEF_ORDINARY("SINGLE-FLOAT",sLsingle_float,LISP,"");
DEF_ORDINARY("PACKAGE",sLpackage,LISP,"");
DEF_ORDINARY("BIGNUM",sLbignum,LISP,"");
DEF_ORDINARY("RANDOM-STATE",sLrandom_state,LISP,"");
DEF_ORDINARY("DOUBLE-FLOAT",sLdouble_float,LISP,"");
DEF_ORDINARY("STREAM",sLstream,LISP,"");
DEF_ORDINARY("BIT",sLbit,LISP,"");
DEF_ORDINARY("READTABLE",sLreadtable,LISP,"");
DEF_ORDINARY("LONG-FLOAT",sLlong_float,LISP,"");
DEF_ORDINARY("HASH-TABLE",sLhash_table,LISP,"");
DEF_ORDINARY("KEYWORD",sLkeyword,LISP,"");
DEF_ORDINARY("STRUCTURE",sLstructure,LISP,"");
DEF_ORDINARY("SATISFIES",sLsatisfies,LISP,"");
DEF_ORDINARY("MEMBER",sLmember,LISP,"");
DEF_ORDINARY("NOT",sLnot,LISP,"");
DEF_ORDINARY("OR",sLor,LISP,"");
DEF_ORDINARY("AND",sLand,LISP,"");
DEF_ORDINARY("VALUES",sLvalues,LISP,"");
DEF_ORDINARY("MOD",sLmod,LISP,"");
DEF_ORDINARY("SIGNED-BYTE",sLsigned_byte,LISP,"");
DEF_ORDINARY("UNSIGNED-BYTE",sLunsigned_byte,LISP,"");
DEF_ORDINARY("SIGNED-CHAR",sSsigned_char,SI,"");
DEF_ORDINARY("UNSIGNED-CHAR",sSunsigned_char,SI,"");
DEF_ORDINARY("SIGNED-SHORT",sSsigned_short,SI,"");
DEF_ORDINARY("UNSIGNED-SHORT",sSunsigned_short,SI,"");
DEF_ORDINARY("*",sLA,LISP,"");
DEF_ORDINARY("PLUSP",sLplusp,LISP,"");

DEF_ORDINARY("METHOD-COMBINATION",sLmethod_combination,LISP,"");
DEF_ORDINARY("BASE-CHAR",sLbase_char,LISP,"");
DEF_ORDINARY("BASE-STRING",sLbase_string,LISP,"");
DEF_ORDINARY("BROADCAST-STREAM",sLbroadcast_stream,LISP,"");
DEF_ORDINARY("BUILT-IN-CLASS",sLbuilt_in_class,LISP,"");
DEF_ORDINARY("CLASS",sLclass,LISP,"");
DEF_ORDINARY("CONCATENATED-STREAM",sLconcatenated_stream,LISP,"");
DEF_ORDINARY("ECHO-STREAM",sLecho_stream,LISP,"");
DEF_ORDINARY("EXTENDED-CHAR",sLextended_char,LISP,"");
DEF_ORDINARY("FILE-STREAM",sLfile_stream,LISP,"");
DEF_ORDINARY("GENERIC-FUNCTION",sLgeneric_function,LISP,"");
DEF_ORDINARY("LOGICAL-PATHNAME",sLlogical_pathname,LISP,"");
DEF_ORDINARY("METHOD",sLmethod,LISP,"");
/* FIXME -- need this for types in predlib.lsp, why can't we use the keyword sKpackage_error ? */
DEF_ORDINARY("SIMPLE-BASE-STRING",sLsimple_base_string,LISP,"");
DEF_ORDINARY("STANDARD-CLASS",sLstandard_class,LISP,"");
DEF_ORDINARY("STANDARD-GENERIC-FUNCTION",sLstandard_generic_function,LISP,"");
DEF_ORDINARY("STANDARD-METHOD",sLstandard_method,LISP,"");
DEF_ORDINARY("STANDARD-OBJECT",sLstandard_object,LISP,"");
DEF_ORDINARY("STRING-STREAM",sLstring_stream,LISP,"");
DEF_ORDINARY("STRUCTURE-CLASS",sLstructure_class,LISP,"");
DEF_ORDINARY("STRUCTURE-OBJECT",sLstructure_object,LISP,"");
DEF_ORDINARY("SYNONYM-STREAM",sLsynonym_stream,LISP,"");
DEF_ORDINARY("TWO-WAY-STREAM",sLtwo_way_stream,LISP,"");

DEFCONST("CHAR-SIZE",sSchar_size,SI,small_fixnum(CHAR_SIZE),"Size in bits of a character");
DEFCONST("SHORT-SIZE",sSshort_size,SI,small_fixnum(CHAR_SIZE*sizeof(short)),"Size in bits of a short integer");

void     
gcl_init_typespec(void) {
}

void
gcl_init_typespec_function(void) {

  TSor_symbol_string=make_cons(sLor, make_cons(sLsymbol, make_cons(sLstring, Cnil)));
  enter_mark_origin(&TSor_symbol_string);

  TSor_string_symbol=make_cons(sLor, make_cons(sLstring, make_cons(sLsymbol, Cnil)));
  enter_mark_origin(&TSor_string_symbol);

  TSor_symbol_string_package=make_cons(sLor,make_cons(sLsymbol,make_cons(sLstring,make_cons(sLpackage, Cnil))));
  enter_mark_origin(&TSor_symbol_string_package);

  TSnon_negative_integer= make_cons(sLinteger,make_cons(make_fixnum(0), make_cons(sLA, Cnil)));
  enter_mark_origin(&TSnon_negative_integer);

  TSpositive_number=make_cons(sLsatisfies, make_cons(sLplusp, Cnil));
  enter_mark_origin(&TSpositive_number);

  TSor_integer_float=make_cons(sLor, make_cons(sLinteger, make_cons(sLfloat, Cnil)));
  enter_mark_origin(&TSor_integer_float);

  TSor_rational_float=make_cons(sLor, make_cons(sLrational, make_cons(sLfloat, Cnil)));
  enter_mark_origin(&TSor_rational_float);

#ifdef UNIX
  TSor_pathname_string_symbol=make_cons(sLor,make_cons(sLpathname,make_cons(sLstring,make_cons(sLsymbol,Cnil))));
  enter_mark_origin(&TSor_pathname_string_symbol);
#endif

  TSor_pathname_string_symbol_stream=make_cons(sLor,make_cons(sLpathname,make_cons(sLstring,make_cons(sLsymbol,make_cons(sLstream,Cnil)))));
  enter_mark_origin(&TSor_pathname_string_symbol_stream);

  make_function("TYPE-OF", Ltype_of);

}