enhanced HCL_BRANDOF() to avoid multiple comparisons.

added the eqk? builtin primitive
removed unnecessary lines

lib/comp.c

@@ -1380,7 +1380,7 @@ static int compile_cons_xlist_expression (hcl_t* hcl, hcl_oop_t obj)
 		{
 			hcl_oop_cons_t sdc;
 
-			if (HCL_BRANDOF(hcl, cdr) != HCL_BRAND_CONS)
+			if (!HCL_IS_CONS(hcl, cdr))
 			{
 				/* (funname . 10) */
 				hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL, "redundant cdr in function call - %O", obj); /* TODO: error location */
@@ -1465,7 +1465,7 @@ static HCL_INLINE int compile_symbol (hcl_t* hcl, hcl_oop_t obj)
 {
 	hcl_oow_t index;
 
-	HCL_ASSERT (hcl, HCL_BRANDOF(hcl,obj) == HCL_BRAND_SYMBOL);
+	HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl, obj));
 
 	if (HCL_OBJ_GET_FLAGS_SYNCODE(obj))
 	{

lib/gc.c

@@ -93,7 +93,7 @@ static void compact_symbol_table (hcl_t* hcl, hcl_oop_t _nil)
 			 * at the current hash index */
 			symbol = (hcl_oop_char_t)hcl->symtab->bucket->slot[y];
 
-			HCL_ASSERT (hcl, HCL_BRANDOF(hcl,symbol) == HCL_BRAND_SYMBOL);
+			HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl, symbol));
 
 			z = hcl_hashoochars(symbol->slot, HCL_OBJ_GET_SIZE(symbol)) % bucket_size;
 

lib/hcl.c

@@ -129,6 +129,11 @@ int hcl_init (hcl_t* hcl, hcl_mmgr_t* mmgr, hcl_oow_t heapsz, const hcl_vmprim_t
 
 	fill_bigint_tables (hcl);
 
+	hcl->tagged_brands[HCL_OOP_TAG_SMOOI] = HCL_BRAND_SMOOI;
+	hcl->tagged_brands[HCL_OOP_TAG_SMPTR] = HCL_BRAND_SMPTR;
+	hcl->tagged_brands[HCL_OOP_TAG_CHAR] = HCL_BRAND_CHARACTER;
+	hcl->tagged_brands[HCL_OOP_TAG_ERROR] = HCL_BRAND_ERROR;
+
 	hcl->proc_map_free_first = -1;
 	hcl->proc_map_free_last = -1;
 

lib/hcl.h

@@ -648,23 +648,12 @@ struct hcl_process_scheduler_t
 	hcl_oop_process_t runnable_tail; /* runnable process list */
 };
 
-/**
- * The HCL_CLASSOF() macro return the class of an object including a numeric
- * object encoded into a pointer.
- */
-#define HCL_CLASSOF(hcl,oop) ( \
-	HCL_OOP_IS_SMOOI(oop)? (hcl)->_small_integer: \
-	HCL_OOP_IS_CHAR(oop)? (hcl)->_character: HCL_OBJ_GET_CLASS(oop) \
-)
-
 /**
  * The HCL_BRANDOF() macro return the brand of an object including a numeric
  * object encoded into a pointer.
  */
-#define HCL_BRANDOF(hcl,oop) ( \
+#define HCL_BRANDOF(moo,oop) \
-	HCL_OOP_IS_SMOOI(oop)? HCL_BRAND_SMOOI: \
+	(HCL_OOP_GET_TAG(oop)? ((hcl)->tagged_brands[HCL_OOP_GET_TAG(oop)]): HCL_OBJ_GET_FLAGS_BRAND(oop))
-	HCL_OOP_IS_CHAR(oop)? HCL_BRAND_CHARACTER: HCL_OBJ_GET_FLAGS_BRAND(oop) \
-)
 
 /**
  * The HCL_BYTESOF() macro returns the size of the payload of
@@ -674,6 +663,7 @@ struct hcl_process_scheduler_t
 #define HCL_BYTESOF(hcl,oop) \
 	(HCL_OOP_IS_NUMERIC(oop)? HCL_SIZEOF(hcl_oow_t): HCL_OBJ_BYTESOF(oop))
 
+
 /**
  * The HCL_ISTYPEOF() macro is a safe replacement for HCL_OBJ_GET_FLAGS_TYPE()
  */
@@ -1030,6 +1020,11 @@ struct hcl_t
 	hcl_ooi_t proc_map_free_first;
 	hcl_ooi_t proc_map_free_last;
 
+	/* 2 tag bits(lo) + 2 extended tag bits(hi). not all slots are used
+	 * because the 2 high extended bits are used only if the low tag bits
+	 * are 3 */
+	int tagged_brands[16];
+
 	/* == EXECUTION REGISTERS == */
 	hcl_oop_context_t initial_context; /* fake initial context */
 	hcl_oop_context_t active_context;
@@ -1222,11 +1217,15 @@ typedef enum hcl_log_mask_t hcl_log_mask_t;
  * ========================================================================= */
 enum hcl_brand_t
 {
-	HCL_BRAND_NIL = 1,
+	HCL_BRAND_SMOOI = 1, /* never used as a small integer is encoded in an object pointer */
+	HCL_BRAND_SMPTR,
+	HCL_BRAND_ERROR,
+	HCL_BRAND_CHARACTER,
+
+	HCL_BRAND_NIL,
 	HCL_BRAND_TRUE,
 	HCL_BRAND_FALSE,
-	HCL_BRAND_CHARACTER,
+
-	HCL_BRAND_SMOOI, /* never used as a small integer is encoded in an object pointer */
 	HCL_BRAND_PBIGINT, /* positive big integer */
 	HCL_BRAND_NBIGINT, /* negative big integer */
 	HCL_BRAND_CONS,

lib/obj.c

@@ -341,11 +341,11 @@ hcl_oow_t hcl_countcons (hcl_t* hcl, hcl_oop_t cons)
 	/* this function ignores the last cdr */
 	hcl_oow_t count = 1;
 
-	HCL_ASSERT (hcl, HCL_BRANDOF(hcl, cons));
+	HCL_ASSERT (hcl, HCL_IS_CONS(hcl, cons));
 	do
 	{
 		cons = HCL_CONS_CDR(cons);
-		if (HCL_BRANDOF(hcl, cons) != HCL_BRAND_CONS) break;
+		if (!HCL_IS_CONS(hcl, cons)) break;
 		count++;
 	}
 	while (1);
@@ -355,11 +355,11 @@ hcl_oow_t hcl_countcons (hcl_t* hcl, hcl_oop_t cons)
 
 hcl_oop_t hcl_getlastconscdr (hcl_t* hcl, hcl_oop_t cons)
 {
-	HCL_ASSERT (hcl, HCL_BRANDOF(hcl, cons));
+	HCL_ASSERT (hcl, HCL_IS_CONS(hcl, cons));
 	do
 	{
 		cons = HCL_CONS_CDR(cons);
-		if (HCL_BRANDOF(hcl, cons) != HCL_BRAND_CONS) break;
+		if (!HCL_IS_CONS(hcl, cons)) break;
 	}
 	while (1);
 
@@ -373,7 +373,7 @@ hcl_oop_t hcl_reversecons (hcl_t* hcl, hcl_oop_t cons)
 	/* Note: The non-nil cdr in the last cons cell gets lost.
 	 *  e.g.) Reversing (1 2 3 . 4) results in (3 2 1) */
 
-	HCL_ASSERT (hcl, HCL_BRANDOF(hcl, cons));
+	HCL_ASSERT (hcl, HCL_IS_CONS(hcl, cons));
 
 	prev = hcl->_nil;
 	ptr = cons;
@@ -383,7 +383,7 @@ hcl_oop_t hcl_reversecons (hcl_t* hcl, hcl_oop_t cons)
 		next = HCL_CONS_CDR(ptr);
 		HCL_CONS_CDR(ptr) = prev;
 		prev = ptr;
-		if (HCL_BRANDOF(hcl,next) != HCL_BRAND_CONS) break;
+		if (!HCL_IS_CONS(hcl, next)) break;
 		ptr = next;
 	}
 	while (1);

lib/prim.c

@@ -196,6 +196,21 @@ static hcl_pfrc_t pf_eql (hcl_t* hcl, hcl_ooi_t nargs)
 	return HCL_PF_SUCCESS;
 }
 
+static hcl_pfrc_t pf_eqk (hcl_t* hcl, hcl_ooi_t nargs)
+{
+	/* equal kind? */
+	hcl_oop_t a0, a1, rv;
+
+	a0 = HCL_STACK_GETARG(hcl, nargs, 0);
+	a1 = HCL_STACK_GETARG(hcl, nargs, 1);
+
+	rv = (HCL_BRANDOF(hcl, a0) == HCL_BRANDOF(hcl, a1)? hcl->_true: hcl->_false);
+
+	HCL_STACK_SETRET (hcl, nargs, rv);
+	return HCL_PF_SUCCESS;
+}
+
+
 static hcl_pfrc_t pf_not (hcl_t* hcl, hcl_ooi_t nargs)
 {
 	hcl_oop_t arg, rv;
@@ -381,6 +396,7 @@ static pf_t builtin_prims[] =
 
 	{ 2, 2,                       pf_eqv,   4,  { 'e','q','v','?' } },
 	{ 2, 2,                       pf_eql,   4,  { 'e','q','l','?' } },
+	{ 2, 2,                       pf_eqk,   4,  { 'e','q','k','?' } },
 
 	/*
 	{ 2, 2,                       pf_gt,    1,  { '>' } },

lib/print.c

@@ -176,32 +176,29 @@ int hcl_outfmtobj (hcl_t* hcl, hcl_oow_t mask, hcl_oop_t obj, hcl_outbfmt_t outb
 	int word_index;
 
 next:
-	if (HCL_OOP_IS_SMOOI(obj))
+	switch ((brand = HCL_BRANDOF(hcl, obj))) 
 	{
-		if (outbfmt(hcl, mask, "%zd", HCL_OOP_TO_SMOOI(obj)) <= -1) return -1;
+		case HCL_BRAND_SMOOI:
-		goto done;
+			if (outbfmt(hcl, mask, "%zd", HCL_OOP_TO_SMOOI(obj)) <= -1) return -1;
-	}
+			goto done;
-	else if (HCL_OOP_IS_SMPTR(obj))
+
-	{
+		case HCL_BRAND_SMPTR:
-		if (outbfmt(hcl, mask, "#\\p%zX", (hcl_oow_t)HCL_OOP_TO_SMPTR(obj)) <= -1) return -1;
+			if (outbfmt(hcl, mask, "#\\p%zX", (hcl_oow_t)HCL_OOP_TO_SMPTR(obj)) <= -1) return -1;
-		goto done;
+			goto done;
-	}
+
-	else if (HCL_OOP_IS_CHAR(obj))
+		case HCL_BRAND_ERROR:
-	{
+			if (outbfmt(hcl, mask, "#\\e%zd", (hcl_ooi_t)HCL_OOP_TO_ERROR(obj)) <= -1) return -1;
-		hcl_ooch_t ch = HCL_OOP_TO_CHAR(obj);
+			goto done;
-		if (outbfmt(hcl, mask, "\'") <= -1 ||
+
-		    print_single_char(hcl, mask, ch, outbfmt) <= -1 ||
+		case HCL_BRAND_CHARACTER:
-		    outbfmt(hcl, mask, "\'") <= -1) return -1;
+		{
-		goto done;
+			hcl_ooch_t ch = HCL_OOP_TO_CHAR(obj);
-	}
+			if (outbfmt(hcl, mask, "\'") <= -1 ||
-	else if (HCL_OOP_IS_ERROR(obj))
+			    print_single_char(hcl, mask, ch, outbfmt) <= -1 ||
-	{
+			    outbfmt(hcl, mask, "\'") <= -1) return -1;
-		if (outbfmt(hcl, mask, "#\\e%zd", (hcl_ooi_t)HCL_OOP_TO_ERROR(obj)) <= -1) return -1;
+			goto done;
-		goto done;
+		}
-	}
 
-	switch ((brand = HCL_OBJ_GET_FLAGS_BRAND(obj))) 
-	{
 		case HCL_BRAND_NIL:
 			word_index = WORD_NIL;
 			goto print_word;
@@ -214,12 +211,6 @@ next:
 			word_index = WORD_FALSE;
 			goto print_word;
 
-		case HCL_BRAND_SMOOI:
-			/* this type should not appear here as the actual small integer is 
-			 * encoded in an object pointer */
-			hcl_seterrbfmt (hcl, HCL_EINTERN, "internal error - unexpected object type %d", (int)brand);
-			return -1;
-
 		case HCL_BRAND_PBIGINT:
 		case HCL_BRAND_NBIGINT:
 		{

lib/sym.c

@@ -70,7 +70,7 @@ static hcl_oop_oop_t expand_bucket (hcl_t* hcl, hcl_oop_oop_t oldbuc)
 		symbol = (hcl_oop_char_t)oldbuc->slot[--oldsz];
 		if ((hcl_oop_t)symbol != hcl->_nil)
 		{
-			HCL_ASSERT (hcl, HCL_BRANDOF(hcl,symbol) == HCL_BRAND_SYMBOL);
+			HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl, symbol));
 			/*HCL_ASSERT (hcl, sym->size > 0);*/
 
 			index = hcl_hashoochars(symbol->slot, HCL_OBJ_GET_SIZE(symbol)) % newsz;
@@ -96,14 +96,14 @@ static hcl_oop_t find_or_make_symbol (hcl_t* hcl, const hcl_ooch_t* ptr, hcl_oow
 		return HCL_NULL;
 	}
 
-	HCL_ASSERT (hcl, HCL_BRANDOF(hcl,hcl->symtab->bucket) == HCL_BRAND_ARRAY);
+	HCL_ASSERT (hcl, HCL_IS_ARRAY(hcl, hcl->symtab->bucket));
 	index = hcl_hashoochars(ptr, len) % HCL_OBJ_GET_SIZE(hcl->symtab->bucket);
 
 	/* find a matching symbol in the open-addressed symbol table */
 	while (hcl->symtab->bucket->slot[index] != hcl->_nil) 
 	{
 		symbol = (hcl_oop_char_t)hcl->symtab->bucket->slot[index];
-		HCL_ASSERT (hcl, HCL_BRANDOF(hcl,symbol) == HCL_BRAND_SYMBOL);
+		HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl, symbol));
 
 		if (len == HCL_OBJ_GET_SIZE(symbol) &&
 		    hcl_equaloochars (ptr, symbol->slot, len))
@@ -140,8 +140,8 @@ static hcl_oop_t find_or_make_symbol (hcl_t* hcl, const hcl_ooch_t* ptr, hcl_oow
 		hcl_oop_oop_t bucket;
 
 		/* TODO: make the growth policy configurable instead of growing
-			     it just before it gets full. The polcy can be grow it
+		         it just before it gets full. The polcy can be grow it
-			     if it's 70% full */
+		         if it's 70% full */
 
 		/* enlarge the symbol table before it gets full to
 		 * make sure that it has at least one free slot left