hyung-hwan/hcl
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

integrated bigint

Browse Source 
cleaned up code
This commit is contained in:
hyung-hwan 2018-02-13 16:10:41 +00:00
parent eff0957fbb
commit f802bec44a
8 changed files with 168 additions and 593 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
lib/bigint.c
View File

@ -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) static int is_normalized_integer (hcl_t* hcl, hcl_oop_t oop)
{ {
if (HCL_OOP_IS_SMOOI(oop)) return 1; 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; hcl_oow_t sz;
sz = HCL_OBJ_GET_SIZE(oop);
if (HCL_IS_BIGINT(hcl,c)) HCL_ASSERT (hcl, sz >= 1);
{ return ((hcl_oop_liword_t)oop)->slot[sz - 1] != 0;
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;
}
} }
return 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) HCL_INLINE int hcl_isint (hcl_t* hcl, hcl_oop_t x)
{ {
if (HCL_OOP_IS_SMOOI(x)) return 1; return HCL_OOP_IS_SMOOI(x) || HCL_IS_BIGINT(hcl, x);
return HCL_IS_BIGINT(hcl, x);
} }
static HCL_INLINE int bigint_to_oow (hcl_t* hcl, hcl_oop_t num, hcl_oow_t* w) 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); 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 */ return 0; /* not convertable - too big, too small, or not an integer */
} }
@ -3946,7 +3938,7 @@ oops_einval:
return HCL_NULL; 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_ooi_t v = 0;
hcl_oow_t w; 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++] = '-'; if (v < 0) buf[len++] = '-';
reverse_string (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); 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); HCL_ASSERT (hcl, xpos >= 1);
if (HCL_IS_NBIGINT(hcl, num)) xbuf[--xpos] = '-'; 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); hcl_freemem (hcl, xbuf);
return s; return s;
} }
@ -4118,9 +4110,9 @@ hcl_oop_t hcl_inttostr (hcl_t* hcl, hcl_oop_t num, int radix)
} }
while (1); while (1);
if (HCL_IS_NBIGINT(hcl,num)) xbuf[xlen++] = '-'; if (HCL_IS_NBIGINT(hcl, num)) xbuf[xlen++] = '-';
reverse_string (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, t);
hcl_freemem (hcl, xbuf); hcl_freemem (hcl, xbuf);

135
lib/hcl-prv.h
View File

@ -118,114 +118,6 @@
#define HCL_ALIGN(x,y) ((((x) + (y) - 1) / (y)) * (y)) #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) #if defined(HCL_LIMIT_OBJ_SIZE)
/* limit the maximum object size such that: /* limit the maximum object size such that:
* 1. an index to an object field can be represented in a small integer. * 1. an index to an object field can be represented in a small integer.
@ -239,8 +131,6 @@
#endif #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) #if defined(HCL_INCLUDE_COMPILER)
/* ========================================================================= */ /* ========================================================================= */
@ -741,6 +631,16 @@ enum hcl_bcode_t
HCL_CODE_NOOP = 0xFF /* 255 */ 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) #if defined(__cplusplus)
extern "C" { extern "C" {
#endif #endif
@ -862,16 +762,6 @@ hcl_oop_t hcl_allocwordobj (
hcl_oow_t len 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 */ /* sym.c */
/* ========================================================================= */ /* ========================================================================= */
@ -1077,13 +967,14 @@ hcl_oop_t hcl_strtoint (
hcl_t* hcl, hcl_t* hcl,
const hcl_ooch_t* str, const hcl_ooch_t* str,
hcl_oow_t len, hcl_oow_t len,
int radix int radix
); );
hcl_oop_t hcl_inttostr ( hcl_oop_t hcl_inttostr (
hcl_t* hcl, hcl_t* hcl,
hcl_oop_t num, hcl_oop_t num,
int radix int radix,
int ngc
); );

71
lib/hcl.h
View File

@ -495,41 +495,6 @@ struct hcl_dic_t
hcl_oop_oop_t bucket; /* Array */ 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 #define HCL_CONTEXT_NAMED_INSTVARS 8
typedef struct hcl_context_t hcl_context_t; typedef struct hcl_context_t hcl_context_t;
typedef struct hcl_context_t* hcl_oop_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. * object encoded into a pointer.
*/ */
#define HCL_BRANDOF(hcl,oop) ( \ #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) \ 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_dlopen_t dl_open;
hcl_vmprim_dlclose_t dl_close; 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_log_write_t log_write;
hcl_syserrstrb_t syserrstrb; hcl_syserrstrb_t syserrstrb;
hcl_syserrstru_t syserrstru; hcl_syserrstru_t syserrstru;
hcl_vmprim_startup_t vm_startup; hcl_vmprim_startup_t vm_startup;
hcl_vmprim_cleanup_t vm_cleanup; hcl_vmprim_cleanup_t vm_cleanup;
hcl_vmprim_gettime_t vm_gettime; 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; typedef struct hcl_vmprim_t hcl_vmprim_t;
@ -1206,7 +1171,9 @@ enum
HCL_BRAND_TRUE, HCL_BRAND_TRUE,
HCL_BRAND_FALSE, HCL_BRAND_FALSE,
HCL_BRAND_CHARACTER, 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_CONS,
HCL_BRAND_ARRAY, HCL_BRAND_ARRAY,
HCL_BRAND_BYTE_ARRAY, HCL_BRAND_BYTE_ARRAY,
@ -1214,8 +1181,6 @@ enum
HCL_BRAND_SYMBOL, HCL_BRAND_SYMBOL,
HCL_BRAND_STRING, HCL_BRAND_STRING,
HCL_BRAND_DIC, HCL_BRAND_DIC,
HCL_BRAND_PBIGINT, /* positive big integer */
HCL_BRAND_NBIGINT, /* negative big integer */
HCL_BRAND_CFRAME,/* compiler frame */ HCL_BRAND_CFRAME,/* compiler frame */
HCL_BRAND_PRIM, HCL_BRAND_PRIM,
@ -1256,7 +1221,6 @@ enum
#define HCL_IS_NIL(hcl,v) (v == (hcl)->_nil) #define HCL_IS_NIL(hcl,v) (v == (hcl)->_nil)
#define HCL_IS_TRUE(hcl,v) (v == (hcl)->_true) #define HCL_IS_TRUE(hcl,v) (v == (hcl)->_true)
#define HCL_IS_FALSE(hcl,v) (v == (hcl)->_false) #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(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_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) #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_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_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_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_CAR(v) (((hcl_cons_t*)(v))->car)
#define HCL_CONS_CDR(v) (((hcl_cons_t*)(v))->cdr) #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_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_EXPORT hcl_oop_t hcl_shallowcopy (
hcl_t* hcl, hcl_t* hcl,
hcl_oop_t oop hcl_oop_t oop
@ -1611,11 +1568,6 @@ HCL_EXPORT hcl_oop_t hcl_makefalse (
hcl_t* hcl 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_EXPORT hcl_oop_t hcl_makebigint (
hcl_t* hcl, hcl_t* hcl,
int brand, int brand,
@ -1643,7 +1595,8 @@ HCL_EXPORT hcl_oop_t hcl_makebytearray (
HCL_EXPORT hcl_oop_t hcl_makestring ( HCL_EXPORT hcl_oop_t hcl_makestring (
hcl_t* hcl, hcl_t* hcl,
const hcl_ooch_t* ptr, const hcl_ooch_t* ptr,
hcl_oow_t len hcl_oow_t len,
int ngc
); );
HCL_EXPORT hcl_oop_t hcl_makedic ( HCL_EXPORT hcl_oop_t hcl_makedic (

183
lib/obj.c
View File

@ -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 * COMMON OBJECTS
* ------------------------------------------------------------------------ */ * ------------------------------------------------------------------------ */
@ -371,12 +202,6 @@ hcl_oop_t hcl_makefalse (hcl_t* hcl)
return hcl_allocoopobj (hcl, HCL_BRAND_FALSE, 0); 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 hcl_makebigint (hcl_t* hcl, int brand, const hcl_liw_t* ptr, hcl_oow_t len)
{ {
hcl_oop_t oop; 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); 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 * NGC HANDLING
* ------------------------------------------------------------------------ */ * ------------------------------------------------------------------------ */

200
lib/prim.c
View File

@ -26,7 +26,7 @@
#include "hcl-prv.h" #include "hcl-prv.h"
struct prim_t struct pf_t
{ {
hcl_oow_t minargs; hcl_oow_t minargs;
hcl_oow_t maxargs; hcl_oow_t maxargs;
@ -36,7 +36,7 @@ struct prim_t
hcl_ooch_t name[10]; 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 */ /* TODO: accept log level */
hcl_oop_t msg, 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) else if (HCL_OBJ_GET_FLAGS_TYPE(msg) == HCL_OBJ_TYPE_OOP)
{ {
/* visit only 1-level down into an array-like object */ /* visit only 1-level down into an array-like object */
hcl_oop_t inner, _class; hcl_oop_t inner;
hcl_oow_t i, spec; hcl_oow_t i;
int brand;
_class = HCL_CLASSOF(hcl, msg); brand = HCL_OBJ_GET_FLAGS_BRAND(msg);
if (brand != HCL_BRAND_ARRAY) goto dump_object;
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;
for (i = 0; i < HCL_OBJ_GET_SIZE(msg); i++) 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; 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; 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; int n;
n = hcl_equalobjs(hcl, HCL_STACK_GETARG(hcl, nargs, 0), HCL_STACK_GETARG(hcl, nargs, 1)); 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; 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; 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; 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_oop_t arg, rv;
hcl_oow_t i; 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; 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_oop_t arg, rv;
hcl_oow_t i; 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_oow_t i;
hcl_oop_t arg, ret; hcl_oop_t arg, ret;
arg = HCL_STACK_GETARG(hcl, nargs, 0); ret = HCL_STACK_GETARG(hcl, nargs, 0);
if (oop_to_ooi(hcl, arg, &x) <= -1) return HCL_PF_FAILURE;
for (i = 1; i < nargs; i++) for (i = 1; i < nargs; i++)
{ {
hcl_ooi_t v;
arg = HCL_STACK_GETARG(hcl, nargs, i); arg = HCL_STACK_GETARG(hcl, nargs, i);
if (oop_to_ooi(hcl, arg, &v) <= -1) return HCL_PF_FAILURE; ret = hcl_addints(hcl, ret, arg);
x += v; if (!ret) return HCL_PF_FAILURE;
} }
ret = hcl_makeinteger (hcl, x);
if (!ret) return HCL_PF_FAILURE;
HCL_STACK_SETRET (hcl, nargs, ret); HCL_STACK_SETRET (hcl, nargs, ret);
return HCL_PF_SUCCESS; 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_oow_t i;
hcl_oop_t arg, ret; hcl_oop_t arg, ret;
arg = HCL_STACK_GETARG(hcl, nargs, 0); ret = HCL_STACK_GETARG(hcl, nargs, 0);
if (oop_to_ooi(hcl, arg, &x) <= -1) return HCL_PF_FAILURE;
for (i = 1; i < nargs; i++) for (i = 1; i < nargs; i++)
{ {
hcl_ooi_t v;
arg = HCL_STACK_GETARG(hcl, nargs, i); arg = HCL_STACK_GETARG(hcl, nargs, i);
if (oop_to_ooi(hcl, arg, &v) <= -1) return HCL_PF_FAILURE; ret = hcl_subints(hcl, ret, arg);
x -= v; if (!ret) return HCL_PF_FAILURE;
} }
ret = hcl_makeinteger (hcl, x);
if (!ret) return HCL_PF_FAILURE;
HCL_STACK_SETRET (hcl, nargs, ret); HCL_STACK_SETRET (hcl, nargs, ret);
return HCL_PF_SUCCESS; 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_oow_t i;
hcl_oop_t arg, ret; hcl_oop_t arg, ret;
arg = HCL_STACK_GETARG(hcl, nargs, 0); ret = HCL_STACK_GETARG(hcl, nargs, 0);
if (oop_to_ooi(hcl, arg, &x) <= -1) return HCL_PF_FAILURE;
for (i = 1; i < nargs; i++) for (i = 1; i < nargs; i++)
{ {
hcl_ooi_t v;
arg = HCL_STACK_GETARG(hcl, nargs, i); arg = HCL_STACK_GETARG(hcl, nargs, i);
if (oop_to_ooi(hcl, arg, &v) <= -1) return HCL_PF_FAILURE; ret = hcl_mulints(hcl, ret, arg);
x *= v; if (!ret) return HCL_PF_FAILURE;
} }
ret = hcl_makeinteger (hcl, x);
if (!ret) return HCL_PF_FAILURE;
HCL_STACK_SETRET (hcl, nargs, ret); HCL_STACK_SETRET (hcl, nargs, ret);
return HCL_PF_SUCCESS; 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_oow_t i;
hcl_oop_t arg, ret; hcl_oop_t arg, ret;
arg = HCL_STACK_GETARG(hcl, nargs, 0); ret = HCL_STACK_GETARG(hcl, nargs, 0);
if (oop_to_ooi(hcl, arg, &x) <= -1) return HCL_PF_FAILURE;
for (i = 1; i < nargs; i++) for (i = 1; i < nargs; i++)
{ {
hcl_ooi_t v;
arg = HCL_STACK_GETARG(hcl, nargs, i); arg = HCL_STACK_GETARG(hcl, nargs, i);
if (oop_to_ooi(hcl, arg, &v) <= -1) return HCL_PF_FAILURE; ret = hcl_divints(hcl, ret, arg, 0, HCL_NULL);
if (v == 0) if (!ret) return HCL_PF_FAILURE;
{
hcl_seterrnum (hcl, HCL_EDIVBY0);
return HCL_PF_FAILURE;
}
x /= v;
} }
ret = hcl_makeinteger (hcl, x);
if (!ret) return HCL_PF_FAILURE;
HCL_STACK_SETRET (hcl, nargs, ret); HCL_STACK_SETRET (hcl, nargs, ret);
return HCL_PF_SUCCESS; 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_oow_t i;
hcl_oop_t arg, ret; hcl_oop_t arg, ret, rem;
arg = HCL_STACK_GETARG(hcl, nargs, 0); ret = HCL_STACK_GETARG(hcl, nargs, 0);
if (oop_to_ooi(hcl, arg, &x) <= -1) return HCL_PF_FAILURE;
for (i = 1; i < nargs; i++) for (i = 1; i < nargs; i++)
{ {
hcl_ooi_t v;
arg = HCL_STACK_GETARG(hcl, nargs, i); arg = HCL_STACK_GETARG(hcl, nargs, i);
if (oop_to_ooi(hcl, arg, &v) <= -1) return HCL_PF_FAILURE; ret = hcl_divints(hcl, ret, arg, 0, &rem);
if (v == 0) if (!ret) return HCL_PF_FAILURE;
{ ret = rem;
hcl_seterrnum (hcl, HCL_EDIVBY0);
return HCL_PF_FAILURE;
}
x %= v;
} }
ret = hcl_makeinteger (hcl, x);
if (!ret) return HCL_PF_FAILURE;
HCL_STACK_SETRET (hcl, nargs, ret); HCL_STACK_SETRET (hcl, nargs, ret);
return HCL_PF_SUCCESS; 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; /* TODO: */
hcl_oow_t i; HCL_STACK_SETRET (hcl, nargs, hcl->_false);
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);
return HCL_PF_SUCCESS; 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' } }, { 1, 1, pf_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), pf_and, 3, { 'a','n','d' } },
{ 2, HCL_TYPE_MAX(hcl_oow_t), prim_or, 2, { 'o','r' } }, { 2, HCL_TYPE_MAX(hcl_oow_t), pf_or, 2, { 'o','r' } },
{ 2, 2, prim_eqv, 4, { 'e','q','v','?' } }, { 2, 2, pf_eqv, 4, { 'e','q','v','?' } },
{ 2, 2, prim_eql, 4, { 'e','q','l','?' } }, { 2, 2, pf_eql, 4, { 'e','q','l','?' } },
/* /*
{ 2, 2, prim_gt, 1, { '>' } }, { 2, 2, pf_gt, 1, { '>' } },
{ 2, 2, prim_ge, 2, { '>','=' } }, { 2, 2, pf_ge, 2, { '>','=' } },
{ 2, 2, prim_lt, 1, { '<' } }, { 2, 2, pf_lt, 1, { '<' } },
{ 2, 2, prim_le, 2, { '<','=' } }, { 2, 2, pf_le, 2, { '<','=' } },
{ 2, 2, prim_eq, 1, { '=' } }, { 2, 2, pf_eq, 1, { '=' } },
{ 2, 2, prim_ne, 2, { '/','=' } }, { 2, 2, pf_ne, 2, { '/','=' } },
{ 2, 2, prim_max, 3, { 'm','a','x' } }, { 2, 2, pf_max, 3, { 'm','a','x' } },
{ 2, 2, prim_min, 3, { 'm','i','n' } }, { 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), pf_integer_add, 1, { '+' } },
{ 1, HCL_TYPE_MAX(hcl_oow_t), prim_minus, 1, { '-' } }, { 1, HCL_TYPE_MAX(hcl_oow_t), pf_integer_sub, 1, { '-' } },
{ 1, HCL_TYPE_MAX(hcl_oow_t), prim_mul, 1, { '*' } }, { 1, HCL_TYPE_MAX(hcl_oow_t), pf_integer_mul, 1, { '*' } },
{ 1, HCL_TYPE_MAX(hcl_oow_t), prim_div, 1, { '/' } }, { 1, HCL_TYPE_MAX(hcl_oow_t), pf_integer_quo, 1, { '/' } },
{ 2, HCL_TYPE_MAX(hcl_oow_t), prim_mod, 3, { 'm','o','d' } }, { 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) 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) static int walker (hcl_t* hcl, hcl_oop_dic_t dic, hcl_oop_cons_t pair, void* ctx)

27
lib/print.c
View File

@ -147,12 +147,29 @@ next:
word_index = WORD_FALSE; word_index = WORD_FALSE;
goto print_word; 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: case HCL_BRAND_PBIGINT:
/* TODO: print properly... print big int */ case HCL_BRAND_NBIGINT:
HCL_ASSERT (hcl, HCL_OBJ_GET_SIZE(obj) == 1); {
if (outbfmt(hcl, mask, "%zu", ((hcl_oop_word_t)obj)->slot[0]) <= -1) return -1; 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; break;
}
#if 0 #if 0
case HCL_BRAND_REAL: case HCL_BRAND_REAL:
@ -590,7 +607,7 @@ done:
default: default:
HCL_DEBUG3 (hcl, "Internal error - unknown print stack type %d at %s:%d\n", (int)ps.type, __FILE__, __LINE__); 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; return -1;
} }
} }

54
lib/proc.c
View File

@ -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)
{
}

57
lib/read.c
View File

@ -178,6 +178,43 @@ static int string_to_ooi (hcl_t* hcl, hcl_oocs_t* str, int radixed, hcl_ooi_t* n
return 0; 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) static HCL_INLINE int is_spacechar (hcl_ooci_t c)
{ {
/* TODO: handle other space unicode characters */ /* TODO: handle other space unicode characters */
@ -1855,33 +1892,25 @@ static int read_object (hcl_t* hcl)
case HCL_IOTOK_NUMLIT: case HCL_IOTOK_NUMLIT:
case HCL_IOTOK_RADNUMLIT: case HCL_IOTOK_RADNUMLIT:
{ obj = string_to_num(hcl, TOKEN_NAME(hcl), TOKEN_TYPE(hcl) == HCL_IOTOK_RADNUMLIT);
hcl_ooi_t v; break;
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;
}
/* /*
case HCL_IOTOK_REAL: case HCL_IOTOK_REAL:
obj = hcl_makerealent (hcl, HCL_IOTOK_RVAL(hcl)); obj = hcl_makerealnum (hcl, HCL_IOTOK_RVAL(hcl));
break; break;
*/ */
case HCL_IOTOK_STRLIT: 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; break;
case HCL_IOTOK_IDENT: 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; break;
case HCL_IOTOK_IDENT_DOTTED: 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) if (obj)
{ {
hcl_pfbase_t* pfbase; hcl_pfbase_t* pfbase;