From ab7288bca0d536585fbf2c13f7434e253d39a894 Mon Sep 17 00:00:00 2001
From: Mikael Djurfeldt <djurfeldt@nada.kth.se>
Date: Thu, 11 Mar 1999 11:46:45 +0000
Subject: [PATCH] * objects.c (scm_class_of): Use SCM_OBJ_CLASS_REDEF. *
 objects.c, objects.h (scm_class_of, scm_class_procedure_with_setter): Added.
 * objects.c, objects.h (SCM_CLASS_REDEF): Renamed from CLASS_REDEF.

---
 libguile/objects.c | 123 +++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 123 insertions(+)

diff --git a/libguile/objects.c b/libguile/objects.c
index cbb6b4ca9..f66b47ded 100644
--- a/libguile/objects.c
+++ b/libguile/objects.c
@@ -49,6 +49,8 @@
 
 #include "struct.h"
 #include "procprop.h"
+#include "chars.h"
+#include "kw.h"
 
 #include "objects.h"
 
@@ -56,6 +58,127 @@
 SCM scm_metaclass_standard;
 SCM scm_metaclass_operator;
 
+/* These variables are filled in by the object system when loaded. */
+SCM scm_class_boolean, scm_class_char, scm_class_pair;
+SCM scm_class_procedure, scm_class_string, scm_class_symbol;
+SCM scm_class_procedure_with_setter;
+SCM scm_class_vector, scm_class_null;
+SCM scm_class_real, scm_class_complex, scm_class_integer;
+SCM scm_class_keyword, scm_class_unknown;
+
+void (*scm_change_object_class) (SCM, SCM, SCM);
+
+/* This function is used for efficient type dispatch.  */
+SCM
+scm_class_of (SCM x)
+{
+  switch (SCM_ITAG3 (x))
+    {
+    case scm_tc3_int_1:
+    case scm_tc3_int_2:
+      return scm_class_integer;
+
+    case scm_tc3_imm24:
+      if (SCM_ICHRP (x))
+	return scm_class_char;
+      else
+	{
+	  switch (SCM_ISYMNUM (x))
+	    {
+	    case SCM_ISYMNUM (SCM_BOOL_F):
+	    case SCM_ISYMNUM (SCM_BOOL_T):
+	      return scm_class_boolean;
+	    case SCM_ISYMNUM (SCM_EOL):
+	      return scm_class_null;
+	    default:
+	      return scm_class_unknown;
+	    }
+	}
+
+    case scm_tc3_cons:
+      switch (SCM_TYP7 (x))
+	{
+	case scm_tcs_cons_nimcar:
+	  return scm_class_pair;
+	case scm_tcs_closures:
+	  return scm_class_procedure;
+	case scm_tcs_symbols:
+	  return scm_class_symbol;
+	case scm_tc7_vector:
+	case scm_tc7_wvect:
+	case scm_tc7_bvect:
+	case scm_tc7_byvect:
+	case scm_tc7_svect:
+	case scm_tc7_ivect:
+	case scm_tc7_uvect:
+	case scm_tc7_fvect:
+	case scm_tc7_dvect:
+	case scm_tc7_cvect:
+	  return scm_class_vector;
+	case scm_tc7_string:
+	case scm_tc7_substring:
+	  return scm_class_string;
+	case scm_tc7_asubr:
+	case scm_tc7_subr_0:
+	case scm_tc7_subr_1:
+	case scm_tc7_cxr:
+	case scm_tc7_subr_3:
+	case scm_tc7_subr_2:
+	case scm_tc7_rpsubr:
+	case scm_tc7_subr_1o:
+	case scm_tc7_subr_2o:
+	case scm_tc7_lsubr_2:
+	case scm_tc7_lsubr:
+	  return scm_class_procedure;
+	case scm_tc7_pws:
+	  return scm_class_procedure_with_setter;
+
+	case scm_tc7_port:
+	  return scm_class_unknown;
+	case scm_tc7_smob:
+	  {
+	    SCM type = SCM_TYP16 (x);
+	    if (type == scm_tc16_flo)
+	      {
+		if (SCM_CAR (x) & SCM_IMAG_PART)
+		  return scm_class_complex;
+		else
+		  return scm_class_real;
+	      }
+	    else if (type == scm_tc16_bigpos || type == scm_tc16_bigneg)
+	      return scm_class_integer;
+	    else if (type == scm_tc16_kw)
+	      return scm_class_keyword;
+	    else
+	      return scm_class_unknown;
+	  }
+	case scm_tcs_cons_gloc:
+	  /* must be a struct */
+	  if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS)
+	  {
+	    if (SCM_OBJ_CLASS_REDEF (x) != SCM_BOOL_F)
+	      scm_change_object_class (x,
+				       SCM_CLASS_OF (x),         /* old */
+				       SCM_OBJ_CLASS_REDEF (x)); /* new */
+	    return SCM_CLASS_OF (x);
+	  }
+	default:
+	  if (SCM_CONSP (x))
+	    return scm_class_pair;
+	  else
+	    return scm_class_unknown;
+	}
+
+    case scm_tc3_cons_gloc:
+    case scm_tc3_tc7_1:
+    case scm_tc3_tc7_2:
+    case scm_tc3_closure:
+      /* Never reached */
+      break;
+    }
+  return scm_class_unknown;
+}
+
 SCM_PROC (s_entity_p, "entity?", 1, 0, 0, scm_entity_p);
 
 SCM