added hcl_getip(), hcl_getbclen(), hcl_getlflen()

renamed vm_checkpoint to vm_checkbc while adding a new parameter

lib/comp.c

@@ -2452,7 +2452,7 @@ static HCL_INLINE int emit_lambda (hcl_t* hcl)
 {
 	hcl_cframe_t* cf;
 	hcl_oow_t block_code_size;
-	hcl_oow_t jip;
+	hcl_ooi_t jip;
 
 	cf = GET_TOP_CFRAME(hcl);
 	HCL_ASSERT (hcl, cf->opcode == COP_EMIT_LAMBDA);

lib/decode.c

@@ -55,7 +55,7 @@
 #endif
 
 /* TODO: check if ip shoots beyond the maximum length in fetching code and parameters */
-int hcl_decode (hcl_t* hcl, hcl_ooi_t start, hcl_ooi_t end)
+int hcl_decode (hcl_t* hcl, hcl_oow_t start, hcl_oow_t end)
 {
 	hcl_oob_t bcode, * cdptr;
 	hcl_ooi_t ip = start, fetched_instruction_pointer;
@@ -67,6 +67,12 @@ int hcl_decode (hcl_t* hcl, hcl_ooi_t start, hcl_ooi_t end)
 	HCL_ASSERT (hcl, start >= 0 && end >= 0);
 	HCL_ASSERT (hcl, hcl->code.bc.len < HCL_SMOOI_MAX); /* asserted by the compiler */
 	HCL_ASSERT (hcl, end <= hcl->code.bc.len); /* not harmful though this fails */
+	if (start >= hcl->code.bc.len)
+	{
+		hcl_seterrnum (hcl, HCL_EINVAL);
+		return -1;
+	}
+	if (end > hcl->code.bc.len) end = hcl->code.bc.len;
 
 	ip = start;
 	cdptr = ((hcl_oop_byte_t)hcl->code.bc.arr)->slot;

lib/exec.c

@@ -148,12 +148,12 @@ static void vm_cleanup (hcl_t* hcl)
 	HCL_DEBUG1 (hcl, "VM cleaned up at IP %zd\n", hcl->ip);
 }
 
-static void vm_checkpoint (hcl_t* hcl)
+static void vm_checkbc (hcl_t* hcl, hcl_oob_t bcode)
 {
 	hcl_cb_t* cb;
 	for (cb = hcl->cblist; cb; cb = cb->next)
 	{
-		if (cb->vm_checkpoint) cb->vm_checkpoint(hcl);
+		if (cb->vm_checkbc) cb->vm_checkbc(hcl, bcode);
 	}
 }
 /* ------------------------------------------------------------------------- */
@@ -1213,11 +1213,11 @@ static int execute (hcl_t* hcl)
 		FETCH_BYTE_CODE_TO (hcl, bcode);
 		/*while (bcode == HCL_CODE_NOOP) FETCH_BYTE_CODE_TO (hcl, bcode);*/
 
-		if (hcl->vm_checkpoint_cb_count) vm_checkpoint (hcl);
+		if (hcl->vm_checkbc_cb_count) vm_checkbc (hcl, bcode);
 		
 		if (HCL_UNLIKELY(hcl->abort_req))
 		{
-			/* place the abortion check after vm_checkpoint
+			/* i place this abortion check after vm_checkbc()
 			 * to honor hcl_abort() if called in the callback, */
 			HCL_DEBUG0 (hcl, "Stopping execution for abortion request\n");
 			return_value = hcl->_nil;
@@ -2241,10 +2241,18 @@ oops:
 	return -1;
 }
 
-hcl_oop_t hcl_executefromip (hcl_t* hcl, hcl_ooi_t initial_ip)
+hcl_oop_t hcl_executefromip (hcl_t* hcl, hcl_oow_t initial_ip)
 {
 	int n, log_default_type_mask;
 
+	HCL_ASSERT (hcl, hcl->code.bc.len < HCL_SMOOI_MAX); /* asserted by the compiler */
+	HCL_ASSERT (hcl, initial_ip < hcl->code.bc.len);
+	if (initial_ip >= hcl->code.bc.len)
+	{
+		hcl_seterrnum (hcl, HCL_EINVAL);
+		return HCL_NULL;
+	}
+
 	log_default_type_mask = hcl->log.default_type_mask;
 	hcl->log.default_type_mask |= HCL_LOG_VM;
 

lib/hcl.c

@@ -416,11 +416,11 @@ hcl_cb_t* hcl_regcb (hcl_t* hcl, hcl_cb_t* tmpl)
 	actual->prev = HCL_NULL;
 	hcl->cblist = actual;
 	
-	/* vm_checkpoint is invoked very frequently.
+	/* vm_checkbc is invoked very frequently.
-	 * and there might be multiple vm_checkpoint callbacks registered.
+	 * and there might be multiple vm_checkbc callbacks registered.
-	 * keeping the count of vm_checkpoint callbacks registered
+	 * keeping the count of vm_checkbc callbacks registered
 	 * speeds up the check */
-	if (actual->vm_checkpoint) hcl->vm_checkpoint_cb_count++;
+	if (actual->vm_checkbc) hcl->vm_checkbc_cb_count++;
 
 	return actual;
 }
@@ -438,10 +438,10 @@ void hcl_deregcb (hcl_t* hcl, hcl_cb_t* cb)
 		if (cb->prev) cb->prev->next = cb->next;
 	}
 
-	if (cb->vm_checkpoint) 
+	if (cb->vm_checkbc) 
 	{
-		HCL_ASSERT (hcl, hcl->vm_checkpoint_cb_count > 0);
+		HCL_ASSERT (hcl, hcl->vm_checkbc_cb_count > 0);
-		hcl->vm_checkpoint_cb_count--;
+		hcl->vm_checkbc_cb_count--;
 	}
 	hcl_freemem (hcl, cb);
 }

lib/hcl.h

@@ -863,7 +863,7 @@ typedef void (*hcl_cb_fini_t) (hcl_t* hcl);
 typedef void (*hcl_cb_gc_t) (hcl_t* hcl);
 typedef int (*hcl_cb_vm_startup_t) (hcl_t* hcl);
 typedef void (*hcl_cb_vm_cleanup_t) (hcl_t* hcl);
-typedef void (*hcl_cb_vm_checkpoint_t) (hcl_t* hcl);
+typedef void (*hcl_cb_vm_checkbc_t) (hcl_t* hcl, hcl_oob_t bcode);
 
 typedef struct hcl_cb_t hcl_cb_t;
 struct hcl_cb_t
@@ -873,7 +873,7 @@ struct hcl_cb_t
 	
 	hcl_cb_vm_startup_t vm_startup;
 	hcl_cb_vm_cleanup_t vm_cleanup;
-	hcl_cb_vm_checkpoint_t vm_checkpoint;
+	hcl_cb_vm_checkbc_t vm_checkbc;
 
 	/* private below */
 	hcl_cb_t*     prev;
@@ -1027,7 +1027,7 @@ struct hcl_t
 
 	hcl_vmprim_t vmprim;
 
-	hcl_oow_t vm_checkpoint_cb_count;
+	hcl_oow_t vm_checkbc_cb_count;
 	hcl_cb_t* cblist;
 	hcl_rbt_t modtab; /* primitive module table */
 
@@ -1560,7 +1560,7 @@ HCL_EXPORT hcl_oop_t hcl_execute (
 
 HCL_EXPORT hcl_oop_t hcl_executefromip (
 	hcl_t*    hcl,
-	hcl_ooi_t initial_ip
+	hcl_oow_t initial_ip
 );
 
 HCL_EXPORT void hcl_abort (
@@ -1593,12 +1593,27 @@ HCL_EXPORT int hcl_compile (
 	hcl_oop_t    obj
 );
 
+/**
+ * The hcl_decode() function decodes instructions from the position 
+ * \a start to the position \a end - 1, and prints the decoded instructions
+ * in the textual form. 
+ */
 HCL_EXPORT int hcl_decode (
 	hcl_t*       hcl,
-	hcl_ooi_t         start,
+	hcl_oow_t    start,
-	hcl_ooi_t         end
+	hcl_oow_t    end
 );
 
+#if defined(HCL_HAVE_INLINE)
+	static HCL_INLINE hcl_oow_t hcl_getbclen (hcl_t* hcl) { return hcl->code.bc.len; }
+	static HCL_INLINE hcl_oow_t hcl_getlflen (hcl_t* hcl) { return hcl->code.lit.len; }
+	static HCL_INLINE hcl_ooi_t hcl_getip (hcl_t* hcl) { return hcl->ip; }
+#else
+#	define hcl_getbclen(hcl) ((hcl)->code.bc.len)
+#	define hcl_getlflen(hcl) ((hcl)->code.lit.len)
+#	define hcl_getip(hcl) ((hcl)->ip)
+#endif
+
 
 /* if you should read charcters from the input stream before hcl_read(), 
  * you can call hcl_readchar() */

lib/main.c

@@ -1220,6 +1220,12 @@ static void vm_cleanup (hcl_t* hcl)
 #endif
 }
 
+/*
+static void vm_checkbc (hcl_t* hcl, hcl_oob_t bcode)
+{
+}
+*/
+
 static void gc_hcl (hcl_t* hcl)
 {
 	xtn_t* xtn = (xtn_t*)hcl_getxtn(hcl);
@@ -1398,6 +1404,7 @@ static void arrange_process_switching (int sig)
 }
 #endif
 
+#if 0
 static void setup_tick (void)
 {
 #if defined(__MSDOS__) && defined(_INTELC32_)
@@ -1463,6 +1470,7 @@ static void cancel_tick (void)
 #	error UNSUPPORTED
 #endif
 }
+#endif
 
 /* ========================================================================= */
 
@@ -1698,7 +1706,7 @@ int main (int argc, char* argv[])
 	hclcb.gc = gc_hcl;
 	hclcb.vm_startup =  vm_startup;
 	hclcb.vm_cleanup = vm_cleanup;
-	/*hclcb.vm_checkpoint = vm_checkpoint;*/
+	/*hclcb.vm_checkbc = vm_checkbc;*/
 	hcl_regcb (hcl, &hclcb);
 
 	if (logopt)
@@ -1802,7 +1810,7 @@ count++;
 		{
 			hcl_oow_t code_offset;
 
-			code_offset = hcl->code.bc.len;
+			code_offset = hcl_getbclen(hcl);
 
 			hcl_proutbfmt (hcl, 0, "\n");
 			if (hcl_compile(hcl, obj) <= -1)
@@ -1823,7 +1831,7 @@ count++;
 			{
 				hcl_oop_t retv;
 
-				hcl_decode (hcl, code_offset, hcl->code.bc.len);
+				hcl_decode (hcl, code_offset, hcl_getbclen(hcl));
 				HCL_LOG0 (hcl, HCL_LOG_MNEMONIC, "------------------------------------------\n");
 				g_hcl = hcl;
 				//setup_tick ();
@@ -1858,11 +1866,10 @@ count++;
 	{
 		hcl_oop_t retv;
 
-		hcl_decode (hcl, 0, hcl->code.bc.len);
+		hcl_decode (hcl, 0, hcl_getbclen(hcl));
-		HCL_LOG2 (hcl, HCL_LOG_MNEMONIC, "BYTECODES hcl->code.bc.len = > %lu hcl->code.lit.len => %lu\n", 
+		HCL_LOG2 (hcl, HCL_LOG_MNEMONIC, "BYTECODES bclen = > %zu lflen => %zu\n", hcl_getbclen(hcl), hcl_getlflen(hcl));
-			(unsigned long int)hcl->code.bc.len, (unsigned long int)hcl->code.lit.len);
 		g_hcl = hcl;
-		//setup_tick ();
+		/*setup_tick ();*/
 
 		retv = hcl_execute(hcl);
 		if (!retv)
@@ -1874,8 +1881,7 @@ count++;
 			hcl_logbfmt (hcl, HCL_LOG_STDERR, "EXECUTION OK - EXITED WITH %O\n", retv);
 		}
 
-
+		/*cancel_tick();*/
-		//cancel_tick();
 		g_hcl = HCL_NULL;
 		/*hcl_dumpsymtab (hcl);*/
 	}