/* Copyright (C) 1996 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2, or (at your option) * any later version. * * This program 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 General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this software; see the file COPYING. If not, write to * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. * * As a special exception, the Free Software Foundation gives permission * for additional uses of the text contained in its release of GUILE. * * The exception is that, if you link the GUILE library with other files * to produce an executable, this does not by itself cause the * resulting executable to be covered by the GNU General Public License. * Your use of that executable is in no way restricted on account of * linking the GUILE library code into it. * * This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU General Public License. * * This exception applies only to the code released by the * Free Software Foundation under the name GUILE. If you copy * code from other Free Software Foundation releases into a copy of * GUILE, as the General Public License permits, the exception does * not apply to the code that you add in this way. To avoid misleading * anyone as to the status of such modified files, you must delete * this exception notice from them. * * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ #include #include "_scm.h" #include "chars.h" #include "struct.h" #include "tag.h" SCM_CONST_LONG (scm_utag_immediate_integer, "utag_immediate_integer", 0); SCM_CONST_LONG (scm_utag_immediate_char, "utag_immediate_char", 1); SCM_CONST_LONG (scm_utag_pair, "utag_pair", 2); SCM_CONST_LONG (scm_utag_closure, "utag_closure", 3); SCM_CONST_LONG (scm_utag_symbol, "utag_symbol", 4); SCM_CONST_LONG (scm_utag_vector, "utag_vector", 5); SCM_CONST_LONG (scm_utag_wvect, "utag_wvect", 6); SCM_CONST_LONG (scm_utag_bvect, "utag_bvect", 7); SCM_CONST_LONG (scm_utag_byvect, "utag_byvect", 8); SCM_CONST_LONG (scm_utag_svect, "utag_svect", 9); SCM_CONST_LONG (scm_utag_ivect, "utag_ivect", 10); SCM_CONST_LONG (scm_utag_uvect, "utag_uvect", 11); SCM_CONST_LONG (scm_utag_fvect, "utag_fvect", 12); SCM_CONST_LONG (scm_utag_dvect, "utag_dvect", 13); SCM_CONST_LONG (scm_utag_cvect, "utag_cvect", 14); SCM_CONST_LONG (scm_utag_string, "utag_string", 15); SCM_CONST_LONG (scm_utag_mb_string, "utag_mb_string", 16); SCM_CONST_LONG (scm_utag_substring, "utag_substring", 17); SCM_CONST_LONG (scm_utag_mb_substring, "utag_mb_substring", 18); SCM_CONST_LONG (scm_utag_asubr, "utag_asubr", 19); SCM_CONST_LONG (scm_utag_subr_0, "utag_subr_0", 20); SCM_CONST_LONG (scm_utag_subr_1, "utag_subr_1", 21); SCM_CONST_LONG (scm_utag_cxr, "utag_cxr", 22); SCM_CONST_LONG (scm_utag_subr_3, "utag_subr_3", 23); SCM_CONST_LONG (scm_utag_subr_2, "utag_subr_2", 24); SCM_CONST_LONG (scm_utag_rpsubr, "utag_rpsubr", 25); SCM_CONST_LONG (scm_utag_subr_1o, "utag_subr_1o", 26); SCM_CONST_LONG (scm_utag_subr_2o, "utag_subr_2o", 27); SCM_CONST_LONG (scm_utag_lsubr_2, "utag_lsubr_2", 28); SCM_CONST_LONG (scm_utag_lsubr, "utag_lsubr", 29); SCM_CONST_LONG (scm_utag_smob_base, "utag_smob_base", 252); SCM_CONST_LONG (scm_utag_port_base, "utag_port_base", 253); SCM_CONST_LONG (scm_utag_flag_base, "utag_flag_base", 254); SCM_CONST_LONG (scm_utag_struct_base, "utag_struct_base", 255); SCM_PROC (s_tag, "tag", 1, 0, 0, scm_tag); #ifdef __STDC__ SCM scm_tag (SCM x) #else SCM scm_tag (x) SCM x; #endif { switch (SCM_ITAG3 (x)) { case scm_tc3_int_1: case scm_tc3_int_2: return SCM_CDR (scm_utag_immediate_integer) ; case scm_tc3_imm24: if (SCM_ICHRP (x)) return SCM_CDR (scm_utag_immediate_char) ; else { int tag; tag = SCM_MAKINUM ((x >> 8) & 0xff); return SCM_MAKINUM (SCM_INUM (SCM_CDR (scm_utag_flag_base) ) | (tag << 8)); } case scm_tc3_cons: switch (SCM_TYP7 (x)) { case scm_tcs_cons_nimcar: return SCM_CDR (scm_utag_pair) ; case scm_tcs_closures: return SCM_CDR (scm_utag_closure) ; case scm_tcs_symbols: return SCM_CDR (scm_utag_symbol) ; case scm_tc7_vector: return SCM_CDR (scm_utag_vector) ; case scm_tc7_wvect: return SCM_CDR (scm_utag_wvect) ; case scm_tc7_bvect: return SCM_CDR (scm_utag_bvect) ; case scm_tc7_byvect: return SCM_CDR (scm_utag_byvect) ; case scm_tc7_svect: return SCM_CDR (scm_utag_svect) ; case scm_tc7_ivect: return SCM_CDR (scm_utag_ivect) ; case scm_tc7_uvect: return SCM_CDR (scm_utag_uvect) ; case scm_tc7_fvect: return SCM_CDR (scm_utag_fvect) ; case scm_tc7_dvect: return SCM_CDR (scm_utag_dvect) ; case scm_tc7_cvect: return SCM_CDR (scm_utag_cvect) ; case scm_tc7_string: return SCM_CDR (scm_utag_string) ; case scm_tc7_mb_string: return SCM_CDR (scm_utag_mb_string) ; case scm_tc7_substring: return SCM_CDR (scm_utag_substring) ; case scm_tc7_mb_substring: return SCM_CDR (scm_utag_mb_substring) ; case scm_tc7_asubr: return SCM_CDR (scm_utag_asubr) ; case scm_tc7_subr_0: return SCM_CDR (scm_utag_subr_0) ; case scm_tc7_subr_1: return SCM_CDR (scm_utag_subr_1) ; case scm_tc7_cxr: return SCM_CDR (scm_utag_cxr) ; case scm_tc7_subr_3: return SCM_CDR (scm_utag_subr_3) ; case scm_tc7_subr_2: return SCM_CDR (scm_utag_subr_2) ; case scm_tc7_rpsubr: return SCM_CDR (scm_utag_rpsubr) ; case scm_tc7_subr_1o: return SCM_CDR (scm_utag_subr_1o) ; case scm_tc7_subr_2o: return SCM_CDR (scm_utag_subr_2o) ; case scm_tc7_lsubr_2: return SCM_CDR (scm_utag_lsubr_2) ; case scm_tc7_lsubr: return SCM_CDR (scm_utag_lsubr) ; case scm_tc7_port: { int tag; tag = (SCM_TYP16 (x) >> 8) & 0xff; return SCM_MAKINUM (SCM_INUM (SCM_CDR (scm_utag_port_base)) | (tag << 8)); } case scm_tc7_smob: { int tag; tag = (SCM_TYP16 (x) >> 8) & 0xff; return SCM_MAKINUM (SCM_INUM (SCM_CDR (scm_utag_smob_base)) | (tag << 8)); } case scm_tcs_cons_gloc: /* must be a struct */ { int tag; tag = SCM_STRUCT_VTABLE_DATA (x)[scm_struct_i_tag]; return SCM_MAKINUM (SCM_INUM (SCM_CDR (scm_utag_struct_base)) | (tag << 8)); } return SCM_CDR (scm_utag_struct_base) ; default: if (SCM_CONSP (x)) return SCM_CDR (scm_utag_pair); else return SCM_MAKINUM (-1); } case scm_tc3_cons_gloc: case scm_tc3_tc7_1: case scm_tc3_tc7_2: case scm_tc3_closure: /* Never reached */ break; } return SCM_MAKINUM (-1); } #ifdef __STDC__ void scm_init_tag (void) #else void scm_init_tag () #endif { #include "tag.x" }