implemented reading and printing of fixed-point decimal number. primitives yet to be written

lib/hcl-prv.h

@@ -148,6 +148,7 @@ enum hcl_iotok_type_t
 	HCL_IOTOK_STRLIT,
 	HCL_IOTOK_NUMLIT,
 	HCL_IOTOK_RADNUMLIT,
+	HCL_IOTOK_FPDECLIT,
 	HCL_IOTOK_SMPTRLIT,
 	HCL_IOTOK_ERRORLIT,
 	HCL_IOTOK_NIL,

lib/hcl.h

@@ -101,7 +101,7 @@ enum hcl_synerrnum_t
 	HCL_SYNERR_HASHLIT,       /* wrong hashed literal */
 	HCL_SYNERR_CHARLIT,       /* wrong character literal */
 	HCL_SYNERR_RADNUMLIT ,    /* invalid numeric literal with radix */
-	HCL_SYNERR_INTRANGE,      /* integer range error */
+	HCL_SYNERR_NUMRANGE,      /* number range error */
 	HCL_SYNERR_ERRORLIT,      /* wrong error literal */
 	HCL_SYNERR_SMPTRLIT,      /* wrong smptr literal */
 
@@ -551,6 +551,16 @@ struct hcl_dic_t
 	hcl_oop_oop_t bucket; /* Array */
 };
 
+#define HCL_FPDEC_NAMED_INSTVARS 2
+typedef struct hcl_fpdec_t hcl_fpdec_t;
+typedef struct hcl_fpdec_t* hcl_oop_fpdec_t;
+struct hcl_fpdec_t
+{
+	HCL_OBJ_HEADER;
+	hcl_oop_t value; /* smooi or bigint */
+	hcl_oop_t scale; /* smooi, positive */
+};
+
 #define HCL_CONTEXT_NAMED_INSTVARS 8
 typedef struct hcl_context_t hcl_context_t;
 typedef struct hcl_context_t* hcl_oop_context_t;
@@ -693,12 +703,36 @@ struct hcl_heap_t
  * VIRTUAL MACHINE PRIMITIVES
  * ========================================================================= */
 
-typedef void* (*hcl_alloc_heap_t) (hcl_t* hcl, hcl_oow_t size);
+typedef void* (*hcl_alloc_heap_t) (
-typedef void (*hcl_free_heap_t) (hcl_t* hcl, void* ptr);
+	hcl_t*             hcl,
+	hcl_oow_t          size
+);
 
-typedef void (*hcl_log_write_t) (hcl_t* hcl, unsigned int mask, const hcl_ooch_t* msg, hcl_oow_t len);
+typedef void (*hcl_free_heap_t) (
-typedef void (*hcl_syserrstrb_t) (hcl_t* hcl, int syserr, hcl_bch_t* buf, hcl_oow_t len);
+	hcl_t*             hcl,
-typedef void (*hcl_syserrstru_t) (hcl_t* hcl, int syserr, hcl_uch_t* buf, hcl_oow_t len);
+	void*              ptr
+);
+
+typedef void (*hcl_log_write_t) (
+	hcl_t*             hcl,
+	unsigned int       mask,
+	const hcl_ooch_t*  msg,
+	hcl_oow_t          len
+);
+
+typedef void (*hcl_syserrstrb_t) (
+	hcl_t*             hcl,
+	int                syserr,
+	hcl_bch_t*         buf,
+	hcl_oow_t          len
+);
+
+typedef void (*hcl_syserrstru_t) (
+	hcl_t*             hcl,
+	int                syserr,
+	hcl_uch_t*         buf,
+	hcl_oow_t          len
+);
 
 enum hcl_vmprim_opendl_flag_t
 {
@@ -706,12 +740,31 @@ enum hcl_vmprim_opendl_flag_t
 };
 typedef enum hcl_vmprim_opendl_flag_t hcl_vmprim_opendl_flag_t;
 
-typedef void* (*hcl_vmprim_dlopen_t) (hcl_t* hcl, const hcl_ooch_t* name, int flags);
+typedef void* (*hcl_vmprim_dlopen_t) (
-typedef void (*hcl_vmprim_dlclose_t) (hcl_t* hcl, void* handle);
+	hcl_t*             hcl,
-typedef void* (*hcl_vmprim_dlgetsym_t) (hcl_t* hcl, void* handle, const hcl_ooch_t* name);
+	const hcl_ooch_t*  name,
+	int                flags
+);
 
-typedef void (*hcl_vmprim_gettime_t) (hcl_t* hcl, hcl_ntime_t* now);
+typedef void (*hcl_vmprim_dlclose_t) (
-typedef void (*hcl_vmprim_sleep_t) (hcl_t* hcl, const hcl_ntime_t* duration);
+	hcl_t*             hcl,
+	void*              handle
+);
+
+typedef void* (*hcl_vmprim_dlgetsym_t) (
+	hcl_t*             hcl,
+	void*              handle,
+	const hcl_ooch_t*  name
+);
+
+typedef void (*hcl_vmprim_gettime_t) (
+	hcl_t*             hcl,
+	hcl_ntime_t*       now
+);
+
+typedef void (*hcl_vmprim_sleep_t) (
+	hcl_t*             hcl,
+	const hcl_ntime_t* duration);
 
 struct hcl_vmprim_t
 {
@@ -1324,6 +1377,7 @@ enum hcl_brand_t
 	HCL_BRAND_SYMBOL,
 	HCL_BRAND_STRING,
 	HCL_BRAND_DIC,
+	HCL_BRAND_FPDEC, /* fixed-point decimal */
 
 	HCL_BRAND_CFRAME,/* compiler frame */
 	HCL_BRAND_PRIM,

lib/obj.c

@@ -268,6 +268,7 @@ hcl_oop_t hcl_makestring (hcl_t* hcl, const hcl_ooch_t* ptr, hcl_oow_t len, int
 	return alloc_numeric_array(hcl, HCL_BRAND_STRING, ptr, len, HCL_OBJ_TYPE_CHAR, HCL_SIZEOF(hcl_ooch_t), 1, ngc);
 }
 
+
 /* ------------------------------------------------------------------------ *
  * NGC HANDLING
  * ------------------------------------------------------------------------ */

lib/print.c

@@ -284,6 +284,22 @@ next:
 			break;
 		}
 
+		case HCL_BRAND_FPDEC:
+		{
+			hcl_oop_t tmp;
+			hcl_oop_fpdec_t f = (hcl_oop_fpdec_t)obj;
+			hcl_ooi_t scale;
+
+			scale = HCL_OOP_TO_SMOOI(f->scale);
+
+			tmp = hcl_inttostr(hcl, f->value, 10, -1);
+			if (!tmp) return -1;
+
+			HCL_ASSERT (hcl, (hcl_oop_t)tmp == hcl->_nil); 
+			if (outbfmt(hcl, mask, "%.*js.%.*js", hcl->inttostr.xbuf.len - scale, hcl->inttostr.xbuf.ptr, scale, &hcl->inttostr.xbuf.ptr[hcl->inttostr.xbuf.len - scale]) <= -1) return -1;
+			break;
+		}
+
 #if 0
 		case HCL_BRAND_REAL:
 		{

lib/read.c

@@ -126,7 +126,7 @@ static int string_to_ooi (hcl_t* hcl, hcl_oocs_t* str, int radixed, hcl_ooi_t* n
 
 		if (*ptr != '#') 
 		{
-			hcl_seterrnum (hcl, HCL_EINVAL);
+			hcl_seterrbfmt (hcl, HCL_EINVAL, "radixed number not starting with # - %*.js", str->len, str->ptr);
 			return -1;
 		}
 		ptr++; /* skip '#' */
@@ -136,7 +136,7 @@ static int string_to_ooi (hcl_t* hcl, hcl_oocs_t* str, int radixed, hcl_ooi_t* n
 		else if (*ptr == 'b') base = 2;
 		else
 		{
-			hcl_seterrnum (hcl, HCL_EINVAL);
+			hcl_seterrbfmt (hcl, HCL_EINVAL, "invalid radix specifier - %c", *ptr);
 			return -1;
 		}
 		ptr++;
@@ -152,7 +152,7 @@ static int string_to_ooi (hcl_t* hcl, hcl_oocs_t* str, int radixed, hcl_ooi_t* n
 		if (value < old_value) 
 		{
 			/* overflow must have occurred */
-			hcl_seterrnum (hcl, HCL_ERANGE);
+			hcl_seterrbfmt (hcl, HCL_ERANGE, "number too big - %.*js", str->len, str->ptr);
 			return -1;
 		}
 		old_value = value;
@@ -162,13 +162,13 @@ static int string_to_ooi (hcl_t* hcl, hcl_oocs_t* str, int radixed, hcl_ooi_t* n
 	if (ptr < end)
 	{
 		/* trailing garbage? */
-		hcl_seterrnum (hcl, HCL_EINVAL);
+		hcl_seterrbfmt (hcl, HCL_EINVAL, "trailing garbage after numeric literal - %.*js", str->len, str->ptr);
 		return -1;
 	}
 
 	if (value > HCL_TYPE_MAX(hcl_ooi_t) + (negsign? 1: 0)) /* assume 2's complement */
 	{
-		hcl_seterrnum (hcl, HCL_ERANGE);
+		hcl_seterrbfmt (hcl, HCL_ERANGE, "number too big - %.*js", str->len, str->ptr);
 		return -1;
 	}
 
@@ -218,7 +218,7 @@ static hcl_oop_t string_to_num (hcl_t* hcl, hcl_oocs_t* str, int radixed)
 
 		if (*ptr != '#') 
 		{
-			hcl_seterrnum (hcl, HCL_EINVAL);
+			hcl_seterrbfmt(hcl, HCL_EINVAL, "radixed number not starting with # - %.*js", str->len, str->ptr);
 			return HCL_NULL;
 		}
 		ptr++; /* skip '#' */
@@ -228,7 +228,7 @@ static hcl_oop_t string_to_num (hcl_t* hcl, hcl_oocs_t* str, int radixed)
 		else if (*ptr == 'b') base = 2;
 		else
 		{
-			hcl_seterrnum (hcl, HCL_EINVAL);
+			hcl_seterrbfmt (hcl, HCL_EINVAL, "invalid radix specifier - %c", *ptr);
 			return HCL_NULL;
 		}
 		ptr++;
@@ -241,6 +241,47 @@ static hcl_oop_t string_to_num (hcl_t* hcl, hcl_oocs_t* str, int radixed)
 	return hcl_strtoint(hcl, ptr, end - ptr, base);
 }
 
+static hcl_oop_t string_to_fpdec (hcl_t* hcl, hcl_oocs_t* str, const hcl_ioloc_t* loc)
+{
+	hcl_oow_t pos;
+	hcl_oow_t scale = 0;
+	hcl_oop_t v;
+	hcl_oop_fpdec_t f;
+
+	pos = str->len;
+	while (pos > 0)
+	{
+		pos--;
+		if (str->ptr[pos] == '.')
+		{
+			scale = str->len - pos - 1;
+			if (scale > HCL_SMOOI_MAX)
+			{
+				hcl_setsynerrbfmt (hcl, HCL_SYNERR_NUMRANGE, loc, str, "too many digits after decimal point");
+				return HCL_NULL;
+			}
+
+			if (scale > 0) HCL_MEMMOVE (&str->ptr[pos], &str->ptr[pos + 1], scale * HCL_SIZEOF(str->ptr[0]));
+		}
+	}
+
+	v = hcl_strtoint(hcl, str->ptr, str->len - 1, 10);
+	if (scale > 0) HCL_MEMMOVE (&str->ptr[pos + 1], &str->ptr[pos], scale * HCL_SIZEOF(str->ptr[0]));
+	if (!v) return HCL_NULL;
+
+	hcl_pushtmp (hcl, &v);
+	f = (hcl_oop_fpdec_t)hcl_makearray (hcl, HCL_FPDEC_NAMED_INSTVARS, 0);
+	hcl_poptmp (hcl);
+
+	if (!f) return HCL_NULL;
+
+	HCL_OBJ_SET_FLAGS_BRAND(f, HCL_BRAND_FPDEC);
+	f->value = v;
+	f->scale = HCL_SMOOI_TO_OOP(scale);
+
+	return f;
+}
+
 static HCL_INLINE int is_spacechar (hcl_ooci_t c)
 {
 	/* TODO: handle other space unicode characters */
@@ -352,7 +393,7 @@ static int copy_string_to (hcl_t* hcl, const hcl_oocs_t* src, hcl_oocs_t* dst, h
 #define CLEAR_TOKEN_NAME(hcl) ((hcl)->c->tok.name.len = 0)
 #define SET_TOKEN_TYPE(hcl,tv) ((hcl)->c->tok.type = (tv))
 
-#define TOKEN_TYPE(hc) ((hcl)->c->tok.type)
+#define TOKEN_TYPE(hcl) ((hcl)->c->tok.type)
 #define TOKEN_NAME(hcl) (&(hcl)->c->tok.name)
 #define TOKEN_NAME_CAPA(hcl) ((hcl)->c->tok.name_capa)
 #define TOKEN_NAME_LEN(hcl) ((hcl)->c->tok.name.len)
@@ -1114,18 +1155,25 @@ retry:
 		case '0': case '1': case '2': case '3': case '4':
 		case '5': case '6': case '7': case '8': case '9':
 		numlit:
-			/* TODO: floating-pointer number */
 			SET_TOKEN_TYPE (hcl, HCL_IOTOK_NUMLIT);
 			while (1)
 			{
 				ADD_TOKEN_CHAR (hcl, c);
 				GET_CHAR_TO (hcl, c);
+				if (TOKEN_TYPE(hcl) == HCL_IOTOK_NUMLIT && c == '.')
+				{
+					SET_TOKEN_TYPE (hcl, HCL_IOTOK_FPDECLIT);
+					ADD_TOKEN_CHAR (hcl, c);
+					GET_CHAR_TO (hcl, c);
+				}
+
 				if (!is_digitchar(c))
 				{
 					unget_char (hcl, &hcl->c->lxc);
 					break;
 				}
 			}
+
 			break;
 
 		default:
@@ -1999,7 +2047,6 @@ static int read_object (hcl_t* hcl)
 
 			case HCL_IOTOK_VBAR:
 /* TODO: think wheter to allow | | inside a quoted list... */
-
 /* TODO: revise this part ... */
 				if (array_level > 0)
 				{
@@ -2074,6 +2121,10 @@ static int read_object (hcl_t* hcl)
 				obj = string_to_num(hcl, TOKEN_NAME(hcl), TOKEN_TYPE(hcl) == HCL_IOTOK_RADNUMLIT);
 				break;
 
+			case HCL_IOTOK_FPDECLIT:
+				obj = string_to_fpdec(hcl, TOKEN_NAME(hcl), TOKEN_LOC(hcl));
+				break;
+
 			/*
 			case HCL_IOTOK_REAL:
 				obj = hcl_makerealnum(hcl, HCL_IOTOK_RVAL(hcl));
@@ -2299,7 +2350,7 @@ int hcl_attachio (hcl_t* hcl, hcl_ioimpl_t reader, hcl_ioimpl_t printer)
 
 	if (!reader || !printer)
 	{
-		hcl_seterrnum (hcl, HCL_EINVAL);
+		hcl_seterrbfmt (hcl, HCL_EINVAL, "reader and/or printer not supplied");
 		return -1;
 	}