From f802bec44ae857656efc8fc62ed867173ba5bd04 Mon Sep 17 00:00:00 2001 From: hyung-hwan Date: Tue, 13 Feb 2018 16:10:41 +0000 Subject: [PATCH] integrated bigint cleaned up code --- lib/bigint.c | 32 +++----- lib/hcl-prv.h | 135 ++++------------------------------ lib/hcl.h | 71 +++--------------- lib/obj.c | 183 +-------------------------------------------- lib/prim.c | 200 ++++++++++++++++---------------------------------- lib/print.c | 29 ++++++-- lib/proc.c | 54 -------------- lib/read.c | 57 ++++++++++---- 8 files changed, 168 insertions(+), 593 deletions(-) delete mode 100644 lib/proc.c diff --git a/lib/bigint.c b/lib/bigint.c index 1c5c8e2..62b2399 100644 --- a/lib/bigint.c +++ b/lib/bigint.c @@ -169,19 +169,12 @@ static HCL_INLINE int liw_mul_overflow (hcl_liw_t a, hcl_liw_t b, hcl_liw_t* c) static int is_normalized_integer (hcl_t* hcl, hcl_oop_t oop) { if (HCL_OOP_IS_SMOOI(oop)) return 1; - if (HCL_OOP_IS_POINTER(oop)) + if (HCL_IS_BIGINT(hcl,oop)) { - hcl_oop_class_t c; - - if (HCL_IS_BIGINT(hcl,c)) - { - hcl_oow_t sz; - - sz = HCL_OBJ_GET_SIZE(oop); - HCL_ASSERT (hcl, sz >= 1); - - return ((hcl_oop_liword_t)oop)->slot[sz - 1] == 0? 0: 1; - } + hcl_oow_t sz; + sz = HCL_OBJ_GET_SIZE(oop); + HCL_ASSERT (hcl, sz >= 1); + return ((hcl_oop_liword_t)oop)->slot[sz - 1] != 0; } return 0; @@ -194,8 +187,7 @@ HCL_INLINE static int is_bigint (hcl_t* hcl, hcl_oop_t x) HCL_INLINE int hcl_isint (hcl_t* hcl, hcl_oop_t x) { - if (HCL_OOP_IS_SMOOI(x)) return 1; - return HCL_IS_BIGINT(hcl, x); + return HCL_OOP_IS_SMOOI(x) || HCL_IS_BIGINT(hcl, x); } static HCL_INLINE int bigint_to_oow (hcl_t* hcl, hcl_oop_t num, hcl_oow_t* w) @@ -280,7 +272,7 @@ int hcl_inttooow (hcl_t* hcl, hcl_oop_t x, hcl_oow_t* w) if (is_bigint(hcl, x)) return bigint_to_oow (hcl, x, w); - hcl_seterrnum (hcl, HCL_EINVAL); + hcl_seterrbfmt (hcl, HCL_EINVAL, "not an integer - %O", x); return 0; /* not convertable - too big, too small, or not an integer */ } @@ -3946,7 +3938,7 @@ oops_einval: return HCL_NULL; } -hcl_oop_t hcl_inttostr (hcl_t* hcl, hcl_oop_t num, int radix) +hcl_oop_t hcl_inttostr (hcl_t* hcl, hcl_oop_t num, int radix, int ngc) { hcl_ooi_t v = 0; hcl_oow_t w; @@ -3983,7 +3975,7 @@ hcl_oop_t hcl_inttostr (hcl_t* hcl, hcl_oop_t num, int radix) if (v < 0) buf[len++] = '-'; reverse_string (buf, len); - return hcl_makestring(hcl, buf, len); + return hcl_makestring(hcl, buf, len, ngc); } as = HCL_OBJ_GET_SIZE(num); @@ -4031,7 +4023,7 @@ hcl_oop_t hcl_inttostr (hcl_t* hcl, hcl_oop_t num, int radix) HCL_ASSERT (hcl, xpos >= 1); if (HCL_IS_NBIGINT(hcl, num)) xbuf[--xpos] = '-'; - s = hcl_makestring (hcl, &xbuf[xpos], xlen - xpos); + s = hcl_makestring(hcl, &xbuf[xpos], xlen - xpos, ngc); hcl_freemem (hcl, xbuf); return s; } @@ -4118,9 +4110,9 @@ hcl_oop_t hcl_inttostr (hcl_t* hcl, hcl_oop_t num, int radix) } while (1); - if (HCL_IS_NBIGINT(hcl,num)) xbuf[xlen++] = '-'; + if (HCL_IS_NBIGINT(hcl, num)) xbuf[xlen++] = '-'; reverse_string (xbuf, xlen); - s = hcl_makestring (hcl, xbuf, xlen); + s = hcl_makestring(hcl, xbuf, xlen, ngc); hcl_freemem (hcl, t); hcl_freemem (hcl, xbuf); diff --git a/lib/hcl-prv.h b/lib/hcl-prv.h index 0b10b80..45a3b57 100644 --- a/lib/hcl-prv.h +++ b/lib/hcl-prv.h @@ -118,114 +118,6 @@ #define HCL_ALIGN(x,y) ((((x) + (y) - 1) / (y)) * (y)) -/* ========================================================================= */ -/* CLASS SPEC ENCODING */ -/* ========================================================================= */ - -/* - * The spec field of a class object encodes the number of the fixed part - * and the type of the indexed part. The fixed part is the number of - * named instance variables. If the spec of a class is indexed, the object - * of the class can be i nstantiated with the size of the indexed part. - * - * For example, on a platform where sizeof(hcl_oow_t) is 4, - * the layout of the spec field of a class as an OOP value looks like this: - * - * 31 10 9 8 7 6 5 4 3 2 1 0 - * |number of named instance variables|indexed-type|indexability|oop-tag| - * - * the number of named instance variables is stored in high 23 bits. - * the indexed type takes up bit 3 to bit 8 (assuming HCL_OBJ_TYPE_BITS is 6. - * HCL_OBJ_TYPE_XXX enumerators are used to represent actual values). - * and the indexability is stored in bit 2. - * - * The maximum number of named(fixed) instance variables for a class is: - * 2 ^ ((BITS-IN-OOW - HCL_OOP_TAG_BITS) - HCL_OBJ_TYPE_BITS - 1) - 1 - * - * HCL_OOP_TAG_BITS are decremented from the number of bits in OOW because - * the spec field is always encoded as a small integer. - * - * The number of named instance variables can be greater than 0 if the - * class spec is not indexed or if it's a pointer indexed class - * (indexed_type == HCL_OBJ_TYPE_OOP) - * - * indexed_type is one of the #hcl_obj_type_t enumerators. - */ - -/* - * The HCL_CLASS_SPEC_MAKE() macro creates a class spec value. - * _class->spec = HCL_SMOOI_TO_OOP(HCL_CLASS_SPEC_MAKE(0, 1, HCL_OBJ_TYPE_CHAR)); - */ -#define HCL_CLASS_SPEC_MAKE(named_instvar,is_indexed,indexed_type) ( \ - (((hcl_oow_t)(named_instvar)) << (HCL_OBJ_FLAGS_TYPE_BITS + 1)) | \ - (((hcl_oow_t)(indexed_type)) << 1) | (((hcl_oow_t)is_indexed) & 1) ) - -/* what is the number of named instance variables? - * HCL_CLASS_SPEC_NAMED_INSTVAR(HCL_OOP_TO_SMOOI(_class->spec)) - */ -#define HCL_CLASS_SPEC_NAMED_INSTVAR(spec) \ - (((hcl_oow_t)(spec)) >> (HCL_OBJ_FLAGS_TYPE_BITS + 1)) - -/* is it a user-indexable class? - * all objects can be indexed with basicAt:. - * this indicates if an object can be instantiated with a dynamic size - * (new: size) and and can be indexed with at:. - */ -#define HCL_CLASS_SPEC_IS_INDEXED(spec) (((hcl_oow_t)(spec)) & 1) - -/* if so, what is the indexing type? character? pointer? etc? */ -#define HCL_CLASS_SPEC_INDEXED_TYPE(spec) \ - ((((hcl_oow_t)(spec)) >> 1) & HCL_LBMASK(hcl_oow_t, HCL_OBJ_FLAGS_TYPE_BITS)) - -/* What is the maximum number of named instance variables? - * This limit is set so because the number must be encoded into the spec field - * of the class with limited number of bits assigned to the number of - * named instance variables. the trailing -1 in the calculation of number of - * bits is to consider the sign bit of a small-integer which is a typical - * type of the spec field in the class object. - */ -/* -#define HCL_MAX_NAMED_INSTVARS \ - HCL_BITS_MAX(hcl_oow_t, HCL_OOW_BITS - HCL_OOP_TAG_BITS - (HCL_OBJ_FLAGS_TYPE_BITS + 1) - 1) -*/ -#define HCL_MAX_NAMED_INSTVARS \ - HCL_BITS_MAX(hcl_oow_t, HCL_SMOOI_ABS_BITS - (HCL_OBJ_FLAGS_TYPE_BITS + 1)) - -/* Given the number of named instance variables, what is the maximum number - * of indexed instance variables? The number of indexed instance variables - * is not stored in the spec field of the class. It only affects the actual - * size of an object(obj->_size) selectively combined with the number of - * named instance variables. So it's the maximum value of obj->_size minus - * the number of named instance variables. - */ -#define HCL_MAX_INDEXED_INSTVARS(named_instvar) (HCL_OBJ_SIZE_MAX - named_instvar) - -/* -#define HCL_CLASS_SELFSPEC_MAKE(class_var,classinst_var) \ - (((hcl_oow_t)class_var) << ((HCL_OOW_BITS - HCL_OOP_TAG_BITS) / 2)) | ((hcl_oow_t)classinst_var) -*/ -#define HCL_CLASS_SELFSPEC_MAKE(class_var,classinst_var) \ - (((hcl_oow_t)class_var) << (HCL_SMOOI_BITS / 2)) | ((hcl_oow_t)classinst_var) - -/* -#define HCL_CLASS_SELFSPEC_CLASSVAR(spec) ((hcl_oow_t)spec >> ((HCL_OOW_BITS - HCL_OOP_TAG_BITS) / 2)) -#define HCL_CLASS_SELFSPEC_CLASSINSTVAR(spec) (((hcl_oow_t)spec) & HCL_LBMASK(hcl_oow_t, (HCL_OOW_BITS - HCL_OOP_TAG_BITS) / 2)) -*/ -#define HCL_CLASS_SELFSPEC_CLASSVAR(spec) ((hcl_oow_t)spec >> (HCL_SMOOI_BITS / 2)) -#define HCL_CLASS_SELFSPEC_CLASSINSTVAR(spec) (((hcl_oow_t)spec) & HCL_LBMASK(hcl_oow_t, (HCL_SMOOI_BITS / 2))) - -/* - * yet another -1 in the calculation of the bit numbers for signed nature of - * a small-integer - */ -/* -#define HCL_MAX_CLASSVARS HCL_BITS_MAX(hcl_oow_t, (HCL_OOW_BITS - HCL_OOP_TAG_BITS - 1) / 2) -#define HCL_MAX_CLASSINSTVARS HCL_BITS_MAX(hcl_oow_t, (HCL_OOW_BITS - HCL_OOP_TAG_BITS - 1) / 2) -*/ -#define HCL_MAX_CLASSVARS HCL_BITS_MAX(hcl_oow_t, HCL_SMOOI_ABS_BITS / 2) -#define HCL_MAX_CLASSINSTVARS HCL_BITS_MAX(hcl_oow_t, HCL_SMOOI_ABS_BITS / 2) - - #if defined(HCL_LIMIT_OBJ_SIZE) /* limit the maximum object size such that: * 1. an index to an object field can be represented in a small integer. @@ -239,8 +131,6 @@ #endif -typedef hcl_ooi_t (*hcl_outbfmt_t) (hcl_t* hcl, hcl_oow_t mask, const hcl_bch_t* fmt, ...); - #if defined(HCL_INCLUDE_COMPILER) /* ========================================================================= */ @@ -741,6 +631,16 @@ enum hcl_bcode_t HCL_CODE_NOOP = 0xFF /* 255 */ }; + + +typedef hcl_ooi_t (*hcl_outbfmt_t) ( + hcl_t* hcl, + hcl_oow_t mask, + const hcl_bch_t* fmt, + ... +); + + #if defined(__cplusplus) extern "C" { #endif @@ -862,16 +762,6 @@ hcl_oop_t hcl_allocwordobj ( hcl_oow_t len ); -#if defined(HCL_USE_OBJECT_TRAILER) -hcl_oop_t hcl_instantiatewithtrailer ( - hcl_t* hcl, - hcl_oop_t _class, - hcl_oow_t vlen, - const hcl_oob_t* tptr, - hcl_oow_t tlen -); -#endif - /* ========================================================================= */ /* sym.c */ /* ========================================================================= */ @@ -1077,13 +967,14 @@ hcl_oop_t hcl_strtoint ( hcl_t* hcl, const hcl_ooch_t* str, hcl_oow_t len, - int radix + int radix ); hcl_oop_t hcl_inttostr ( hcl_t* hcl, hcl_oop_t num, - int radix + int radix, + int ngc ); diff --git a/lib/hcl.h b/lib/hcl.h index ca99f20..a93010b 100644 --- a/lib/hcl.h +++ b/lib/hcl.h @@ -495,41 +495,6 @@ struct hcl_dic_t hcl_oop_oop_t bucket; /* Array */ }; -#define HCL_CLASS_NAMED_INSTVARS 11 -typedef struct hcl_class_t hcl_class_t; -typedef struct hcl_class_t* hcl_oop_class_t; -struct hcl_class_t -{ - HCL_OBJ_HEADER; - - hcl_oop_t spec; /* SmallInteger. instance specification */ - hcl_oop_t selfspec; /* SmallInteger. specification of the class object itself */ - - hcl_oop_t superclass; /* Another class */ - hcl_oop_t subclasses; /* Array of subclasses */ - - hcl_oop_char_t name; /* Symbol */ - - /* == NEVER CHANGE THIS ORDER OF 3 ITEMS BELOW == */ - hcl_oop_char_t instvars; /* String */ - hcl_oop_char_t classvars; /* String */ - hcl_oop_char_t classinstvars; /* String */ - /* == NEVER CHANGE THE ORDER OF 3 ITEMS ABOVE == */ - - hcl_oop_char_t pooldics; /* String */ - - /* [0] - instance methods, MethodDictionary - * [1] - class methods, MethodDictionary */ - hcl_oop_dic_t mthdic[2]; - - /* indexed part afterwards */ - hcl_oop_t slot[1]; /* class instance variables and class variables. */ -}; -#define HCL_CLASS_MTHDIC_INSTANCE 0 -#define HCL_CLASS_MTHDIC_CLASS 1 - - - #define HCL_CONTEXT_NAMED_INSTVARS 8 typedef struct hcl_context_t hcl_context_t; typedef struct hcl_context_t* hcl_oop_context_t; @@ -651,7 +616,7 @@ struct hcl_process_scheduler_t * object encoded into a pointer. */ #define HCL_BRANDOF(hcl,oop) ( \ - HCL_OOP_IS_SMOOI(oop)? HCL_BRAND_INTEGER: \ + HCL_OOP_IS_SMOOI(oop)? HCL_BRAND_SMOOI: \ HCL_OOP_IS_CHAR(oop)? HCL_BRAND_CHARACTER: HCL_OBJ_GET_FLAGS_BRAND(oop) \ ) @@ -706,17 +671,17 @@ struct hcl_vmprim_t { hcl_vmprim_dlopen_t dl_open; hcl_vmprim_dlclose_t dl_close; - hcl_vmprim_dlgetsym_t dl_getsym; + hcl_vmprim_dlgetsym_t dl_getsym; hcl_log_write_t log_write; hcl_syserrstrb_t syserrstrb; hcl_syserrstru_t syserrstru; - hcl_vmprim_startup_t vm_startup; - hcl_vmprim_cleanup_t vm_cleanup; - hcl_vmprim_gettime_t vm_gettime; + hcl_vmprim_startup_t vm_startup; + hcl_vmprim_cleanup_t vm_cleanup; + hcl_vmprim_gettime_t vm_gettime; - hcl_vmprim_sleep_t vm_sleep; + hcl_vmprim_sleep_t vm_sleep; }; typedef struct hcl_vmprim_t hcl_vmprim_t; @@ -1206,7 +1171,9 @@ enum HCL_BRAND_TRUE, HCL_BRAND_FALSE, HCL_BRAND_CHARACTER, - HCL_BRAND_INTEGER, + 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, HCL_BRAND_ARRAY, HCL_BRAND_BYTE_ARRAY, @@ -1214,8 +1181,6 @@ enum HCL_BRAND_SYMBOL, HCL_BRAND_STRING, HCL_BRAND_DIC, - HCL_BRAND_PBIGINT, /* positive big integer */ - HCL_BRAND_NBIGINT, /* negative big integer */ HCL_BRAND_CFRAME,/* compiler frame */ HCL_BRAND_PRIM, @@ -1256,7 +1221,6 @@ enum #define HCL_IS_NIL(hcl,v) (v == (hcl)->_nil) #define HCL_IS_TRUE(hcl,v) (v == (hcl)->_true) #define HCL_IS_FALSE(hcl,v) (v == (hcl)->_false) -#define HCL_IS_INTEGER(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_INTEGER) #define HCL_IS_SYMBOL(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_SYMBOL) #define HCL_IS_SYMBOL_ARRAY(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_SYMBOL_ARRAY) #define HCL_IS_CONTEXT(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_CONTEXT) @@ -1268,7 +1232,7 @@ enum #define HCL_IS_PRIM(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_PRIM) #define HCL_IS_PBIGINT(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_PBIGINT) #define HCL_IS_NBIGINT(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_NBIGINT) -#define HCL_IS_BIGINT(hcl,v) (HCL_OOP_IS_POINTER(v) && (HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_NBIGINT || HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_NBIGINT)) +#define HCL_IS_BIGINT(hcl,v) (HCL_OOP_IS_POINTER(v) && (HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_PBIGINT || HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_NBIGINT)) #define HCL_CONS_CAR(v) (((hcl_cons_t*)(v))->car) #define HCL_CONS_CDR(v) (((hcl_cons_t*)(v))->cdr) @@ -1409,13 +1373,6 @@ HCL_EXPORT hcl_oow_t hcl_getpayloadbytes ( hcl_oop_t oop ); -HCL_EXPORT hcl_oop_t hcl_instantiate ( - hcl_t* hcl, - hcl_oop_t _class, - const void* vptr, - hcl_oow_t vlen -); - HCL_EXPORT hcl_oop_t hcl_shallowcopy ( hcl_t* hcl, hcl_oop_t oop @@ -1611,11 +1568,6 @@ HCL_EXPORT hcl_oop_t hcl_makefalse ( hcl_t* hcl ); -HCL_EXPORT hcl_oop_t hcl_makeinteger ( - hcl_t* hcl, - hcl_ooi_t v -); - HCL_EXPORT hcl_oop_t hcl_makebigint ( hcl_t* hcl, int brand, @@ -1643,7 +1595,8 @@ HCL_EXPORT hcl_oop_t hcl_makebytearray ( HCL_EXPORT hcl_oop_t hcl_makestring ( hcl_t* hcl, const hcl_ooch_t* ptr, - hcl_oow_t len + hcl_oow_t len, + int ngc ); HCL_EXPORT hcl_oop_t hcl_makedic ( diff --git a/lib/obj.c b/lib/obj.c index 4ceb721..9fa39be 100644 --- a/lib/obj.c +++ b/lib/obj.c @@ -182,175 +182,6 @@ hcl_oop_t hcl_allocwordobj (hcl_t* hcl, int brand, const hcl_oow_t* ptr, hcl_oow } -static HCL_INLINE int decode_spec (hcl_t* hcl, hcl_oop_t _class, hcl_oow_t vlen, hcl_obj_type_t* type, hcl_oow_t* outlen) -{ - hcl_oow_t spec; - hcl_oow_t named_instvar; - hcl_obj_type_t indexed_type; - - HCL_ASSERT (hcl, HCL_OOP_IS_POINTER(_class)); - HCL_ASSERT (hcl, HCL_CLASSOF(hcl, _class) == hcl->_class); - - HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(((hcl_oop_class_t)_class)->spec)); - spec = HCL_OOP_TO_SMOOI(((hcl_oop_class_t)_class)->spec); - - named_instvar = HCL_CLASS_SPEC_NAMED_INSTVAR(spec); /* size of the named_instvar part */ - - if (HCL_CLASS_SPEC_IS_INDEXED(spec)) - { - indexed_type = HCL_CLASS_SPEC_INDEXED_TYPE(spec); - - if (indexed_type == HCL_OBJ_TYPE_OOP) - { - if (named_instvar > HCL_MAX_NAMED_INSTVARS || - vlen > HCL_MAX_INDEXED_INSTVARS(named_instvar)) - { - return -1; - } - - HCL_ASSERT (hcl, named_instvar + vlen <= HCL_OBJ_SIZE_MAX); - } - else - { - /* a non-pointer indexed class can't have named instance variables */ - if (named_instvar > 0) return -1; - if (vlen > HCL_OBJ_SIZE_MAX) return -1; - } - } - else - { - /* named instance variables only. treat it as if it is an - * indexable class with no variable data */ - indexed_type = HCL_OBJ_TYPE_OOP; - vlen = 0; /* vlen is not used */ - - if (named_instvar > HCL_MAX_NAMED_INSTVARS) return -1; - HCL_ASSERT (hcl, named_instvar <= HCL_OBJ_SIZE_MAX); - } - - *type = indexed_type; - *outlen = named_instvar + vlen; - return 0; -} - -hcl_oop_t hcl_instantiate (hcl_t* hcl, hcl_oop_t _class, const void* vptr, hcl_oow_t vlen) -{ -#if 0 - hcl_oop_t oop; - hcl_obj_type_t type; - hcl_oow_t alloclen; - hcl_oow_t tmp_count = 0; - - HCL_ASSERT (hcl, hcl->_nil != HCL_NULL); - - if (decode_spec (hcl, _class, vlen, &type, &alloclen) <= -1) - { - hcl_seterrnum (hcl, HCL_EINVAL); - return HCL_NULL; - } - - hcl_pushtmp (hcl, &_class); tmp_count++; - - switch (type) - { - case HCL_OBJ_TYPE_OOP: - /* both the fixed part(named instance variables) and - * the variable part(indexed instance variables) are allowed. */ - oop = hcl_allocoopobj (hcl, alloclen); - - HCL_ASSERT (hcl, vptr == HCL_NULL); - /* - This function is not GC-safe. so i don't want to initialize - the payload of a pointer object. The caller can call this - function and initialize payloads then. - if (oop && vptr && vlen > 0) - { - hcl_oop_oop_t hdr = (hcl_oop_oop_t)oop; - HCL_MEMCPY (&hdr->slot[named_instvar], vptr, vlen * HCL_SIZEOF(hcl_oop_t)); - } - - For the above code to work, it should protect the elements of - the vptr array with hcl_pushtmp(). So it might be better - to disallow a non-NULL vptr when indexed_type is OOP. See - the assertion above this comment block. - */ - break; - - case HCL_OBJ_TYPE_CHAR: - oop = hcl_alloccharobj (hcl, vptr, alloclen); - break; - - case HCL_OBJ_TYPE_BYTE: - oop = hcl_allocbyteobj (hcl, vptr, alloclen); - break; - - case HCL_OBJ_TYPE_HALFWORD: - oop = hcl_allochalfwordobj (hcl, vptr, alloclen); - break; - - case HCL_OBJ_TYPE_WORD: - oop = hcl_allocwordobj (hcl, vptr, alloclen); - break; - - default: - hcl_seterrnum (hcl, HCL_EINTERN); - oop = HCL_NULL; - break; - } - - if (oop) HCL_OBJ_SET_CLASS (oop, _class); - hcl_poptmps (hcl, tmp_count); - return oop; -#endif - - hcl_seterrnum (hcl, HCL_ENOIMPL); - return HCL_NULL; -} - -#if defined(HCL_USE_OBJECT_TRAILER) - -hcl_oop_t hcl_instantiatewithtrailer (hcl_t* hcl, hcl_oop_t _class, hcl_oow_t vlen, const hcl_oob_t* tptr, hcl_oow_t tlen) -{ -#if 0 - hcl_oop_t oop; - hcl_obj_type_t type; - hcl_oow_t alloclen; - hcl_oow_t tmp_count = 0; - - HCL_ASSERT (hcl, hcl->_nil != HCL_NULL); - - if (decode_spec (hcl, _class, vlen, &type, &alloclen) <= -1) - { - hcl_seterrnum (hcl, HCL_EINVAL); - return HCL_NULL; - } - - hcl_pushtmp (hcl, &_class); tmp_count++; - - switch (type) - { - case HCL_OBJ_TYPE_OOP: - /* NOTE: vptr is not used for GC unsafety */ - oop = hcl_allocoopobjwithtrailer(hcl, alloclen, tptr, tlen); - break; - - default: - hcl_seterrnum (hcl, HCL_EINTERN); - oop = HCL_NULL; - break; - } - - if (oop) HCL_OBJ_SET_CLASS (oop, _class); - hcl_poptmps (hcl, tmp_count); - return oop; -#endif - - hcl_seterrnum (hcl, HCL_ENOIMPL); - return HCL_NULL; -} -#endif - - /* ------------------------------------------------------------------------ * * COMMON OBJECTS * ------------------------------------------------------------------------ */ @@ -371,12 +202,6 @@ hcl_oop_t hcl_makefalse (hcl_t* hcl) return hcl_allocoopobj (hcl, HCL_BRAND_FALSE, 0); } -hcl_oop_t hcl_makeinteger (hcl_t* hcl, hcl_ooi_t v) -{ - if (HCL_IN_SMOOI_RANGE(v)) return HCL_SMOOI_TO_OOP(v); - return hcl_allocwordobj (hcl, HCL_BRAND_INTEGER, (hcl_oow_t*)&v, 1); -} - hcl_oop_t hcl_makebigint (hcl_t* hcl, int brand, const hcl_liw_t* ptr, hcl_oow_t len) { hcl_oop_t oop; @@ -425,15 +250,13 @@ hcl_oop_t hcl_makebytearray (hcl_t* hcl, const hcl_oob_t* ptr, hcl_oow_t size) return hcl_allocbyteobj (hcl, HCL_BRAND_BYTE_ARRAY, ptr, size); } -hcl_oop_t hcl_makestring (hcl_t* hcl, const hcl_ooch_t* ptr, hcl_oow_t len) +hcl_oop_t hcl_makestring (hcl_t* hcl, const hcl_ooch_t* ptr, hcl_oow_t len, int ngc) { - return hcl_alloccharobj (hcl, HCL_BRAND_STRING, ptr, len); + /*return hcl_alloccharobj (hcl, HCL_BRAND_STRING, ptr, len);*/ + return alloc_numeric_array (hcl, HCL_BRAND_STRING, ptr, len, HCL_OBJ_TYPE_CHAR, HCL_SIZEOF(hcl_ooch_t), 1, ngc); } - - - /* ------------------------------------------------------------------------ * * NGC HANDLING * ------------------------------------------------------------------------ */ diff --git a/lib/prim.c b/lib/prim.c index 552fe5b..40261c8 100644 --- a/lib/prim.c +++ b/lib/prim.c @@ -26,7 +26,7 @@ #include "hcl-prv.h" -struct prim_t +struct pf_t { hcl_oow_t minargs; hcl_oow_t maxargs; @@ -36,7 +36,7 @@ struct prim_t hcl_ooch_t name[10]; }; -typedef struct prim_t prim_t; +typedef struct pf_t pf_t; /* ------------------------------------------------------------------------- */ @@ -95,7 +95,7 @@ start_over: } } -static hcl_pfrc_t prim_log (hcl_t* hcl, hcl_ooi_t nargs) +static hcl_pfrc_t pf_log (hcl_t* hcl, hcl_ooi_t nargs) { /* TODO: accept log level */ hcl_oop_t msg, level; @@ -124,13 +124,12 @@ static hcl_pfrc_t prim_log (hcl_t* hcl, hcl_ooi_t nargs) else if (HCL_OBJ_GET_FLAGS_TYPE(msg) == HCL_OBJ_TYPE_OOP) { /* visit only 1-level down into an array-like object */ - hcl_oop_t inner, _class; - hcl_oow_t i, spec; + hcl_oop_t inner; + hcl_oow_t i; + int brand; - _class = HCL_CLASSOF(hcl, msg); - - spec = HCL_OOP_TO_SMOOI(((hcl_oop_class_t)_class)->spec); - if (HCL_CLASS_SPEC_NAMED_INSTVAR(spec) > 0 || !HCL_CLASS_SPEC_IS_INDEXED(spec)) goto dump_object; + brand = HCL_OBJ_GET_FLAGS_BRAND(msg); + if (brand != HCL_BRAND_ARRAY) goto dump_object; for (i = 0; i < HCL_OBJ_GET_SIZE(msg); i++) { @@ -162,7 +161,7 @@ static hcl_pfrc_t prim_log (hcl_t* hcl, hcl_ooi_t nargs) } /* ------------------------------------------------------------------------- */ -static hcl_pfrc_t prim_eqv (hcl_t* hcl, hcl_ooi_t nargs) +static hcl_pfrc_t pf_eqv (hcl_t* hcl, hcl_ooi_t nargs) { hcl_oop_t a0, a1, rv; @@ -175,7 +174,7 @@ static hcl_pfrc_t prim_eqv (hcl_t* hcl, hcl_ooi_t nargs) return HCL_PF_SUCCESS; } -static hcl_pfrc_t prim_eql (hcl_t* hcl, hcl_ooi_t nargs) +static hcl_pfrc_t pf_eql (hcl_t* hcl, hcl_ooi_t nargs) { int n; n = hcl_equalobjs(hcl, HCL_STACK_GETARG(hcl, nargs, 0), HCL_STACK_GETARG(hcl, nargs, 1)); @@ -185,7 +184,7 @@ static hcl_pfrc_t prim_eql (hcl_t* hcl, hcl_ooi_t nargs) return HCL_PF_SUCCESS; } -static hcl_pfrc_t prim_not (hcl_t* hcl, hcl_ooi_t nargs) +static hcl_pfrc_t pf_not (hcl_t* hcl, hcl_ooi_t nargs) { hcl_oop_t arg, rv; @@ -202,7 +201,7 @@ static hcl_pfrc_t prim_not (hcl_t* hcl, hcl_ooi_t nargs) return HCL_PF_SUCCESS; } -static hcl_pfrc_t prim_and (hcl_t* hcl, hcl_ooi_t nargs) +static hcl_pfrc_t pf_and (hcl_t* hcl, hcl_ooi_t nargs) { hcl_oop_t arg, rv; hcl_oow_t i; @@ -232,7 +231,7 @@ static hcl_pfrc_t prim_and (hcl_t* hcl, hcl_ooi_t nargs) return HCL_PF_SUCCESS; } -static hcl_pfrc_t prim_or (hcl_t* hcl, hcl_ooi_t nargs) +static hcl_pfrc_t pf_or (hcl_t* hcl, hcl_ooi_t nargs) { hcl_oop_t arg, rv; hcl_oow_t i; @@ -263,207 +262,132 @@ static hcl_pfrc_t prim_or (hcl_t* hcl, hcl_ooi_t nargs) /* ------------------------------------------------------------------------- */ -static hcl_pfrc_t oop_to_ooi (hcl_t* hcl, hcl_oop_t iv, hcl_ooi_t* ov) +static hcl_pfrc_t pf_integer_add (hcl_t* hcl, hcl_ooi_t nargs) { - if (HCL_OOP_IS_SMOOI(iv)) - { - *ov = HCL_OOP_TO_SMOOI(iv); - return 0; - } - else if (HCL_IS_INTEGER(hcl, iv)) - { - *ov = (hcl_ooi_t)((hcl_oop_word_t)iv)->slot[0]; - return 0; - } - else - { - hcl_seterrbfmt (hcl, HCL_EINVAL, "not a numeric object - %O", iv); - return -1; - } -} - -static hcl_pfrc_t prim_plus (hcl_t* hcl, hcl_ooi_t nargs) -{ - hcl_ooi_t x; hcl_oow_t i; hcl_oop_t arg, ret; - arg = HCL_STACK_GETARG(hcl, nargs, 0); - if (oop_to_ooi(hcl, arg, &x) <= -1) return HCL_PF_FAILURE; + ret = HCL_STACK_GETARG(hcl, nargs, 0); for (i = 1; i < nargs; i++) { - hcl_ooi_t v; arg = HCL_STACK_GETARG(hcl, nargs, i); - if (oop_to_ooi(hcl, arg, &v) <= -1) return HCL_PF_FAILURE; - x += v; + ret = hcl_addints(hcl, ret, arg); + if (!ret) return HCL_PF_FAILURE; } - ret = hcl_makeinteger (hcl, x); - if (!ret) return HCL_PF_FAILURE; - HCL_STACK_SETRET (hcl, nargs, ret); return HCL_PF_SUCCESS; } -static hcl_pfrc_t prim_minus (hcl_t* hcl, hcl_ooi_t nargs) +static hcl_pfrc_t pf_integer_sub (hcl_t* hcl, hcl_ooi_t nargs) { - hcl_ooi_t x; hcl_oow_t i; hcl_oop_t arg, ret; - arg = HCL_STACK_GETARG(hcl, nargs, 0); - if (oop_to_ooi(hcl, arg, &x) <= -1) return HCL_PF_FAILURE; + ret = HCL_STACK_GETARG(hcl, nargs, 0); for (i = 1; i < nargs; i++) { - hcl_ooi_t v; arg = HCL_STACK_GETARG(hcl, nargs, i); - if (oop_to_ooi(hcl, arg, &v) <= -1) return HCL_PF_FAILURE; - x -= v; + ret = hcl_subints(hcl, ret, arg); + if (!ret) return HCL_PF_FAILURE; } - ret = hcl_makeinteger (hcl, x); - if (!ret) return HCL_PF_FAILURE; - HCL_STACK_SETRET (hcl, nargs, ret); return HCL_PF_SUCCESS; } -static hcl_pfrc_t prim_mul (hcl_t* hcl, hcl_ooi_t nargs) +static hcl_pfrc_t pf_integer_mul (hcl_t* hcl, hcl_ooi_t nargs) { - hcl_ooi_t x; hcl_oow_t i; hcl_oop_t arg, ret; - arg = HCL_STACK_GETARG(hcl, nargs, 0); - if (oop_to_ooi(hcl, arg, &x) <= -1) return HCL_PF_FAILURE; + ret = HCL_STACK_GETARG(hcl, nargs, 0); for (i = 1; i < nargs; i++) { - hcl_ooi_t v; arg = HCL_STACK_GETARG(hcl, nargs, i); - if (oop_to_ooi(hcl, arg, &v) <= -1) return HCL_PF_FAILURE; - x *= v; + ret = hcl_mulints(hcl, ret, arg); + if (!ret) return HCL_PF_FAILURE; } - ret = hcl_makeinteger (hcl, x); - if (!ret) return HCL_PF_FAILURE; - HCL_STACK_SETRET (hcl, nargs, ret); return HCL_PF_SUCCESS; } -static hcl_pfrc_t prim_div (hcl_t* hcl, hcl_ooi_t nargs) + +static hcl_pfrc_t pf_integer_quo (hcl_t* hcl, hcl_ooi_t nargs) { - hcl_ooi_t x; hcl_oow_t i; hcl_oop_t arg, ret; - arg = HCL_STACK_GETARG(hcl, nargs, 0); - if (oop_to_ooi(hcl, arg, &x) <= -1) return HCL_PF_FAILURE; + ret = HCL_STACK_GETARG(hcl, nargs, 0); for (i = 1; i < nargs; i++) { - hcl_ooi_t v; arg = HCL_STACK_GETARG(hcl, nargs, i); - if (oop_to_ooi(hcl, arg, &v) <= -1) return HCL_PF_FAILURE; - if (v == 0) - { - hcl_seterrnum (hcl, HCL_EDIVBY0); - return HCL_PF_FAILURE; - } - x /= v; + ret = hcl_divints(hcl, ret, arg, 0, HCL_NULL); + if (!ret) return HCL_PF_FAILURE; } - ret = hcl_makeinteger (hcl, x); - if (!ret) return HCL_PF_FAILURE; - HCL_STACK_SETRET (hcl, nargs, ret); return HCL_PF_SUCCESS; } -static hcl_pfrc_t prim_mod (hcl_t* hcl, hcl_ooi_t nargs) +static hcl_pfrc_t pf_integer_rem (hcl_t* hcl, hcl_ooi_t nargs) { - hcl_ooi_t x = 0; hcl_oow_t i; - hcl_oop_t arg, ret; + hcl_oop_t arg, ret, rem; - arg = HCL_STACK_GETARG(hcl, nargs, 0); - if (oop_to_ooi(hcl, arg, &x) <= -1) return HCL_PF_FAILURE; + ret = HCL_STACK_GETARG(hcl, nargs, 0); for (i = 1; i < nargs; i++) { - hcl_ooi_t v; arg = HCL_STACK_GETARG(hcl, nargs, i); - if (oop_to_ooi(hcl, arg, &v) <= -1) return HCL_PF_FAILURE; - if (v == 0) - { - hcl_seterrnum (hcl, HCL_EDIVBY0); - return HCL_PF_FAILURE; - } - x %= v; + ret = hcl_divints(hcl, ret, arg, 0, &rem); + if (!ret) return HCL_PF_FAILURE; + ret = rem; } - ret = hcl_makeinteger (hcl, x); - if (!ret) return HCL_PF_FAILURE; - HCL_STACK_SETRET (hcl, nargs, ret); return HCL_PF_SUCCESS; } -static hcl_pfrc_t prim_printf (hcl_t* hcl, hcl_ooi_t nargs) +static hcl_pfrc_t pf_printf (hcl_t* hcl, hcl_ooi_t nargs) { - hcl_ooi_t x = 0; - hcl_oow_t i; - hcl_oop_t arg, ret; - - if (nargs > 0) - { - arg = HCL_STACK_GETARG(hcl, nargs, 0); - if (oop_to_ooi(hcl, arg, &x) <= -1) return HCL_PF_FAILURE; - for (i = 1; i < nargs; i++) - { - hcl_ooi_t v; - arg = HCL_STACK_GETARG(hcl, nargs, i); - if (oop_to_ooi(hcl, arg, &v) <= -1) return HCL_PF_FAILURE; - x -= v; - } - } - - ret = hcl_makeinteger (hcl, x); - if (!ret) return HCL_PF_FAILURE; - - HCL_STACK_SETRET (hcl, nargs, ret); +/* TODO: */ + HCL_STACK_SETRET (hcl, nargs, hcl->_false); return HCL_PF_SUCCESS; } + /* ------------------------------------------------------------------------- */ -static prim_t builtin_prims[] = +static pf_t builtin_prims[] = { - { 0, HCL_TYPE_MAX(hcl_oow_t), prim_log, 3, { 'l','o','g' } }, + { 0, HCL_TYPE_MAX(hcl_oow_t), pf_log, 3, { 'l','o','g' } }, - { 1, 1, prim_not, 3, { 'n','o','t' } }, - { 2, HCL_TYPE_MAX(hcl_oow_t), prim_and, 3, { 'a','n','d' } }, - { 2, HCL_TYPE_MAX(hcl_oow_t), prim_or, 2, { 'o','r' } }, + { 1, 1, pf_not, 3, { 'n','o','t' } }, + { 2, HCL_TYPE_MAX(hcl_oow_t), pf_and, 3, { 'a','n','d' } }, + { 2, HCL_TYPE_MAX(hcl_oow_t), pf_or, 2, { 'o','r' } }, - { 2, 2, prim_eqv, 4, { 'e','q','v','?' } }, - { 2, 2, prim_eql, 4, { 'e','q','l','?' } }, + { 2, 2, pf_eqv, 4, { 'e','q','v','?' } }, + { 2, 2, pf_eql, 4, { 'e','q','l','?' } }, /* - { 2, 2, prim_gt, 1, { '>' } }, - { 2, 2, prim_ge, 2, { '>','=' } }, - { 2, 2, prim_lt, 1, { '<' } }, - { 2, 2, prim_le, 2, { '<','=' } }, - { 2, 2, prim_eq, 1, { '=' } }, - { 2, 2, prim_ne, 2, { '/','=' } }, + { 2, 2, pf_gt, 1, { '>' } }, + { 2, 2, pf_ge, 2, { '>','=' } }, + { 2, 2, pf_lt, 1, { '<' } }, + { 2, 2, pf_le, 2, { '<','=' } }, + { 2, 2, pf_eq, 1, { '=' } }, + { 2, 2, pf_ne, 2, { '/','=' } }, - { 2, 2, prim_max, 3, { 'm','a','x' } }, - { 2, 2, prim_min, 3, { 'm','i','n' } }, + { 2, 2, pf_max, 3, { 'm','a','x' } }, + { 2, 2, pf_min, 3, { 'm','i','n' } }, */ - { 1, HCL_TYPE_MAX(hcl_oow_t), prim_plus, 1, { '+' } }, - { 1, HCL_TYPE_MAX(hcl_oow_t), prim_minus, 1, { '-' } }, - { 1, HCL_TYPE_MAX(hcl_oow_t), prim_mul, 1, { '*' } }, - { 1, HCL_TYPE_MAX(hcl_oow_t), prim_div, 1, { '/' } }, - { 2, HCL_TYPE_MAX(hcl_oow_t), prim_mod, 3, { 'm','o','d' } }, + { 1, HCL_TYPE_MAX(hcl_oow_t), pf_integer_add, 1, { '+' } }, + { 1, HCL_TYPE_MAX(hcl_oow_t), pf_integer_sub, 1, { '-' } }, + { 1, HCL_TYPE_MAX(hcl_oow_t), pf_integer_mul, 1, { '*' } }, + { 1, HCL_TYPE_MAX(hcl_oow_t), pf_integer_quo, 1, { '/' } }, + { 2, HCL_TYPE_MAX(hcl_oow_t), pf_integer_rem, 3, { 'm','o','d' } }, - { 0, HCL_TYPE_MAX(hcl_oow_t), prim_printf, 6, { 'p','r','i','n','t','f' } }, + { 0, HCL_TYPE_MAX(hcl_oow_t), pf_printf, 6, { 'p','r','i','n','t','f' } }, }; @@ -494,7 +418,7 @@ int hcl_addbuiltinprims (hcl_t* hcl) static hcl_pfrc_t pf_hello (hcl_t* hcl, hcl_ooi_t nargs) { - return prim_log(hcl, nargs); + return pf_log(hcl, nargs); } static int walker (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_cons_t pair, void* ctx) diff --git a/lib/print.c b/lib/print.c index 7ecb1e7..f9bac36 100644 --- a/lib/print.c +++ b/lib/print.c @@ -132,7 +132,7 @@ next: if (outbfmt(hcl, mask, "$%.1jc", HCL_OOP_TO_CHAR(obj)) <= -1) return -1; goto done; } - + switch ((brand = HCL_OBJ_GET_FLAGS_BRAND(obj))) { case HCL_BRAND_NIL: @@ -147,12 +147,29 @@ 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_INTEGER: -/* TODO: print properly... print big int */ - HCL_ASSERT (hcl, HCL_OBJ_GET_SIZE(obj) == 1); - if (outbfmt(hcl, mask, "%zu", ((hcl_oop_word_t)obj)->slot[0]) <= -1) return -1; + case HCL_BRAND_PBIGINT: + case HCL_BRAND_NBIGINT: + { + hcl_oop_t str; + + /* TODO: can i do this without memory allocation? */ + str = hcl_inttostr(hcl, obj, 10, 1); /* inttostr with ngc on. not using object memory */ + if (!str) return -1; + + if (outbfmt(hcl, mask, "%.*js", HCL_OBJ_GET_SIZE(str), HCL_OBJ_GET_CHAR_SLOT(str)) <= -1) + { + hcl_freengcobj (hcl, str); + return -1; + } + hcl_freengcobj (hcl, str); break; + } #if 0 case HCL_BRAND_REAL: @@ -590,7 +607,7 @@ done: default: HCL_DEBUG3 (hcl, "Internal error - unknown print stack type %d at %s:%d\n", (int)ps.type, __FILE__, __LINE__); - hcl_seterrbfmt (hcl, HCL_EINTERN, "unknown print stack type %d", (int)ps.type); + hcl_seterrbfmt (hcl, HCL_EINTERN, "internal error - unknown print stack type %d", (int)ps.type); return -1; } } diff --git a/lib/proc.c b/lib/proc.c deleted file mode 100644 index a3c1410..0000000 --- a/lib/proc.c +++ /dev/null @@ -1,54 +0,0 @@ -/* - * $Id$ - * - Copyright (c) 2016-2018 Chung, Hyung-Hwan. All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - - THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR - IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES - OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. - IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, - INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT - NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, - DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY - THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF - THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - */ - - -#include "hcl-prv.h" - - - -hcl_oop_process_t hcl_addnewproc (hcl_t* hcl) -{ - hcl_oop_process_t proc; - - proc = (hcl_oop_process_t)hcl_instantiate (hcl, hcl->_process, HCL_NULL, hcl->option.dfl_procstk_size); - if (!proc) return HCL_NULL; - - proc->state = HCL_SMOOI_TO_OOP(0); - - HCL_ASSERT (HCL_OBJ_GET_SIZE(proc) == HCL_PROCESS_NAMED_INSTVARS + hcl->option.dfl_procstk_size); - return proc; -} - -void hcl_schedproc (hcl_t* hcl, hcl_oop_process_t proc) -{ - /* TODO: if scheduled, don't add */ - /*proc->next = hcl->_active_process; - proc->_active_process = proc;*/ -} - -void hcl_unschedproc (hcl_t* hcl, hcl_oop_process_t proc) -{ -} diff --git a/lib/read.c b/lib/read.c index 480ff92..862774f 100644 --- a/lib/read.c +++ b/lib/read.c @@ -178,6 +178,43 @@ static int string_to_ooi (hcl_t* hcl, hcl_oocs_t* str, int radixed, hcl_ooi_t* n return 0; } +static hcl_oop_t string_to_num (hcl_t* hcl, hcl_oocs_t* str, int radixed) +{ + int negsign, base; + const hcl_ooch_t* ptr, * end; + + negsign = 0; + ptr = str->ptr, + end = str->ptr + str->len; + + HCL_ASSERT (hcl, ptr < end); + + if (*ptr == '+' || *ptr == '-') + { + negsign = *ptr - '+'; + ptr++; + } + + if (radixed) + { + HCL_ASSERT (hcl, ptr < end); + + base = 0; + do + { + base = base * 10 + CHAR_TO_NUM(*ptr, 10); + ptr++; + } + while (*ptr != 'r'); + + ptr++; + } + else base = 10; + +/* TODO: handle floating point numbers ... etc */ + if (negsign) base = -base; + return hcl_strtoint (hcl, ptr, end - ptr, base); +} static HCL_INLINE int is_spacechar (hcl_ooci_t c) { /* TODO: handle other space unicode characters */ @@ -1855,33 +1892,25 @@ static int read_object (hcl_t* hcl) case HCL_IOTOK_NUMLIT: case HCL_IOTOK_RADNUMLIT: - { - hcl_ooi_t v; - if (string_to_ooi (hcl, TOKEN_NAME(hcl), TOKEN_TYPE(hcl) == HCL_IOTOK_RADNUMLIT, &v) <= -1) - { - if (hcl->errnum == HCL_ERANGE) hcl_setsynerr (hcl, HCL_SYNERR_INTRANGE, TOKEN_LOC(hcl), TOKEN_NAME(hcl)); - return -1; - } - obj = hcl_makeinteger (hcl, v); - break; - } + obj = string_to_num(hcl, TOKEN_NAME(hcl), TOKEN_TYPE(hcl) == HCL_IOTOK_RADNUMLIT); + break; /* case HCL_IOTOK_REAL: - obj = hcl_makerealent (hcl, HCL_IOTOK_RVAL(hcl)); + obj = hcl_makerealnum (hcl, HCL_IOTOK_RVAL(hcl)); break; */ case HCL_IOTOK_STRLIT: - obj = hcl_makestring (hcl, TOKEN_NAME_PTR(hcl), TOKEN_NAME_LEN(hcl)); + obj = hcl_makestring(hcl, TOKEN_NAME_PTR(hcl), TOKEN_NAME_LEN(hcl), 0); break; case HCL_IOTOK_IDENT: - obj = hcl_makesymbol (hcl, TOKEN_NAME_PTR(hcl), TOKEN_NAME_LEN(hcl)); + obj = hcl_makesymbol(hcl, TOKEN_NAME_PTR(hcl), TOKEN_NAME_LEN(hcl)); break; case HCL_IOTOK_IDENT_DOTTED: - obj = hcl_makesymbol (hcl, TOKEN_NAME_PTR(hcl), TOKEN_NAME_LEN(hcl)); + obj = hcl_makesymbol(hcl, TOKEN_NAME_PTR(hcl), TOKEN_NAME_LEN(hcl)); if (obj) { hcl_pfbase_t* pfbase;