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

added the make_charaarray instruction and pop_into_chararray insruction
All checks were successful
continuous-integration/drone/push Build is passing
Details

Browse Source
This commit is contained in:
hyung-hwan 2024-09-15 11:51:11 +09:00
parent ed33ca2196
commit a3e2b589be
10 changed files with 229 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

74
lib/comp.c
View File

@ -716,8 +716,10 @@ static int emit_single_param_instruction (hcl_t* hcl, int cmd, hcl_oow_t param_1
case HCL_CODE_MAKE_DIC: /* TODO: don't these need write_long2? */ case HCL_CODE_MAKE_DIC: /* TODO: don't these need write_long2? */
case HCL_CODE_MAKE_ARRAY: case HCL_CODE_MAKE_ARRAY:
case HCL_CODE_MAKE_BYTEARRAY: case HCL_CODE_MAKE_BYTEARRAY:
case HCL_CODE_MAKE_CHARARRAY:
case HCL_CODE_POP_INTO_ARRAY: case HCL_CODE_POP_INTO_ARRAY:
case HCL_CODE_POP_INTO_BYTEARRAY: case HCL_CODE_POP_INTO_BYTEARRAY:
case HCL_CODE_POP_INTO_CHARARRAY:
bc = cmd; bc = cmd;
goto write_long; goto write_long;
} }
@ -1650,7 +1652,7 @@ enum
COP_COMPILE_TRY_OBJECT_LIST_TAIL, COP_COMPILE_TRY_OBJECT_LIST_TAIL,
COP_COMPILE_ARRAY_LIST, COP_COMPILE_ARRAY_LIST,
COP_COMPILE_BYTEARRAY_LIST, COP_COMPILE_PURE_ARRAY_LIST,
COP_COMPILE_DIC_LIST, COP_COMPILE_DIC_LIST,
COP_COMPILE_QLIST, /* compile data list */ COP_COMPILE_QLIST, /* compile data list */
@ -1678,11 +1680,11 @@ enum
COP_EMIT_SEND, COP_EMIT_SEND,
COP_EMIT_MAKE_ARRAY, COP_EMIT_MAKE_ARRAY,
COP_EMIT_MAKE_BYTEARRAY, COP_EMIT_MAKE_PURE_ARRAY,
COP_EMIT_MAKE_DIC, COP_EMIT_MAKE_DIC,
COP_EMIT_MAKE_CONS, COP_EMIT_MAKE_CONS,
COP_EMIT_POP_INTO_ARRAY, COP_EMIT_POP_INTO_ARRAY,
COP_EMIT_POP_INTO_BYTEARRAY, COP_EMIT_POP_INTO_PURE_ARRAY,
COP_EMIT_POP_INTO_DIC, COP_EMIT_POP_INTO_DIC,
COP_EMIT_POP_INTO_CONS, COP_EMIT_POP_INTO_CONS,
COP_EMIT_POP_INTO_CONS_END, COP_EMIT_POP_INTO_CONS_END,
@ -3844,16 +3846,16 @@ static int compile_cons_bytearray_expression (hcl_t* hcl, hcl_cnode_t* obj, int
return -1; return -1;
} }
SWITCH_TOP_CFRAME (hcl, COP_EMIT_MAKE_BYTEARRAY, obj); SWITCH_TOP_CFRAME (hcl, COP_EMIT_MAKE_PURE_ARRAY, obj);
cf = GET_TOP_CFRAME(hcl); cf = GET_TOP_CFRAME(hcl);
cf->u.bytearray_list.elem_type = concode; cf->u.pure_array_list.elem_type = concode;
cf->u.bytearray_list.index = nargs; cf->u.pure_array_list.index = nargs;
/* redundant cdr check is performed inside compile_object_list() */ /* redundant cdr check is performed inside compile_object_list() */
PUSH_SUBCFRAME (hcl, COP_COMPILE_BYTEARRAY_LIST, obj); PUSH_SUBCFRAME (hcl, COP_COMPILE_PURE_ARRAY_LIST, obj);
cf = GET_SUBCFRAME(hcl); cf = GET_SUBCFRAME(hcl);
cf->u.bytearray_list.elem_type = concode; cf->u.pure_array_list.elem_type = concode;
cf->u.bytearray_list.index = 0; cf->u.pure_array_list.index = 0;
return 0; return 0;
} }
@ -5001,6 +5003,10 @@ redo:
if (emit_single_param_instruction(hcl, HCL_CODE_MAKE_BYTEARRAY, 0, HCL_CNODE_GET_LOC(oprnd)) <= -1) return -1; if (emit_single_param_instruction(hcl, HCL_CODE_MAKE_BYTEARRAY, 0, HCL_CNODE_GET_LOC(oprnd)) <= -1) return -1;
goto done; goto done;
case HCL_CONCODE_CHARARRAY:
if (emit_single_param_instruction(hcl, HCL_CODE_MAKE_CHARARRAY, 0, HCL_CNODE_GET_LOC(oprnd)) <= -1) return -1;
goto done;
case HCL_CONCODE_DIC: case HCL_CONCODE_DIC:
if (emit_single_param_instruction(hcl, HCL_CODE_MAKE_DIC, 16, HCL_CNODE_GET_LOC(oprnd)) <= -1) return -1; if (emit_single_param_instruction(hcl, HCL_CODE_MAKE_DIC, 16, HCL_CNODE_GET_LOC(oprnd)) <= -1) return -1;
goto done; goto done;
@ -5282,13 +5288,13 @@ static int compile_array_list (hcl_t* hcl)
return 0; return 0;
} }
static int compile_bytearray_list (hcl_t* hcl) static int compile_pure_array_list (hcl_t* hcl)
{ {
hcl_cframe_t* cf; hcl_cframe_t* cf;
hcl_cnode_t* oprnd; hcl_cnode_t* oprnd;
cf = GET_TOP_CFRAME(hcl); cf = GET_TOP_CFRAME(hcl);
HCL_ASSERT (hcl, cf->opcode == COP_COMPILE_BYTEARRAY_LIST); HCL_ASSERT (hcl, cf->opcode == COP_COMPILE_PURE_ARRAY_LIST);
oprnd = cf->operand; oprnd = cf->operand;
@ -5311,8 +5317,8 @@ static int compile_bytearray_list (hcl_t* hcl)
car = HCL_CNODE_CONS_CAR(oprnd); car = HCL_CNODE_CONS_CAR(oprnd);
cdr = HCL_CNODE_CONS_CDR(oprnd); cdr = HCL_CNODE_CONS_CDR(oprnd);
oldidx = cf->u.bytearray_list.index; oldidx = cf->u.pure_array_list.index;
elem_type = cf->u.bytearray_list.index; elem_type = cf->u.pure_array_list.elem_type;
/* TODO: compile type check if the data element is literal... /* TODO: compile type check if the data element is literal...
runtime check if the data is a variable or something... */ runtime check if the data is a variable or something... */
@ -5320,16 +5326,16 @@ static int compile_bytearray_list (hcl_t* hcl)
SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, car); SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, car);
if (cdr) if (cdr)
{ {
PUSH_SUBCFRAME (hcl, COP_COMPILE_BYTEARRAY_LIST, cdr); PUSH_SUBCFRAME (hcl, COP_COMPILE_PURE_ARRAY_LIST, cdr);
cf = GET_SUBCFRAME(hcl); cf = GET_SUBCFRAME(hcl);
cf->u.bytearray_list.elem_type = elem_type; cf->u.pure_array_list.elem_type = elem_type;
cf->u.bytearray_list.index = oldidx + 1; cf->u.pure_array_list.index = oldidx + 1;
} }
PUSH_SUBCFRAME (hcl, COP_EMIT_POP_INTO_BYTEARRAY, car); PUSH_SUBCFRAME (hcl, COP_EMIT_POP_INTO_PURE_ARRAY, car);
cf = GET_SUBCFRAME(hcl); cf = GET_SUBCFRAME(hcl);
cf->u.bytearray_list.elem_type = elem_type; cf->u.pure_array_list.elem_type = elem_type;
cf->u.bytearray_list.index = oldidx; cf->u.pure_array_list.index = oldidx;
} }
return 0; return 0;
@ -5714,16 +5720,17 @@ static HCL_INLINE int emit_make_array (hcl_t* hcl)
return n; return n;
} }
static HCL_INLINE int emit_make_bytearray (hcl_t* hcl) static HCL_INLINE int emit_make_pure_array (hcl_t* hcl)
{ {
hcl_cframe_t* cf; hcl_cframe_t* cf;
int n; int n, inst;
cf = GET_TOP_CFRAME(hcl); cf = GET_TOP_CFRAME(hcl);
HCL_ASSERT (hcl, cf->opcode == COP_EMIT_MAKE_BYTEARRAY); HCL_ASSERT (hcl, cf->opcode == COP_EMIT_MAKE_PURE_ARRAY);
HCL_ASSERT (hcl, cf->operand != HCL_NULL); HCL_ASSERT (hcl, cf->operand != HCL_NULL);
n = emit_single_param_instruction(hcl, HCL_CODE_MAKE_BYTEARRAY, cf->u.bytearray_list.index, HCL_CNODE_GET_LOC(cf->operand)); inst = (cf->u.pure_array_list.elem_type == HCL_CONCODE_BYTEARRAY)? HCL_CODE_MAKE_BYTEARRAY: HCL_CODE_MAKE_CHARARRAY;
n = emit_single_param_instruction(hcl, inst, cf->u.pure_array_list.index, HCL_CNODE_GET_LOC(cf->operand));
POP_CFRAME (hcl); POP_CFRAME (hcl);
return n; return n;
@ -5774,16 +5781,17 @@ static HCL_INLINE int emit_pop_into_array (hcl_t* hcl)
return n; return n;
} }
static HCL_INLINE int emit_pop_into_bytearray (hcl_t* hcl) static HCL_INLINE int emit_pop_into_pure_array (hcl_t* hcl)
{ {
hcl_cframe_t* cf; hcl_cframe_t* cf;
int n; int n, inst;
cf = GET_TOP_CFRAME(hcl); cf = GET_TOP_CFRAME(hcl);
HCL_ASSERT (hcl, cf->opcode == COP_EMIT_POP_INTO_BYTEARRAY); HCL_ASSERT (hcl, cf->opcode == COP_EMIT_POP_INTO_PURE_ARRAY);
HCL_ASSERT (hcl, cf->operand != HCL_NULL); HCL_ASSERT (hcl, cf->operand != HCL_NULL);
n = emit_single_param_instruction(hcl, HCL_CODE_POP_INTO_BYTEARRAY, cf->u.bytearray_list.index, HCL_CNODE_GET_LOC(cf->operand)); inst = (cf->u.pure_array_list.elem_type == HCL_CONCODE_BYTEARRAY)? HCL_CODE_POP_INTO_BYTEARRAY: HCL_CODE_POP_INTO_CHARARRAY;
n = emit_single_param_instruction(hcl, inst, cf->u.pure_array_list.index, HCL_CNODE_GET_LOC(cf->operand));
POP_CFRAME (hcl); POP_CFRAME (hcl);
return n; return n;
@ -6368,8 +6376,8 @@ int hcl_compile (hcl_t* hcl, hcl_cnode_t* obj, int flags)
if (compile_array_list(hcl) <= -1) goto oops; if (compile_array_list(hcl) <= -1) goto oops;
break; break;
case COP_COMPILE_BYTEARRAY_LIST: case COP_COMPILE_PURE_ARRAY_LIST:
if (compile_bytearray_list(hcl) <= -1) goto oops; if (compile_pure_array_list(hcl) <= -1) goto oops;
break; break;
case COP_COMPILE_DIC_LIST: case COP_COMPILE_DIC_LIST:
@ -6448,8 +6456,8 @@ int hcl_compile (hcl_t* hcl, hcl_cnode_t* obj, int flags)
if (emit_make_array(hcl) <= -1) goto oops; if (emit_make_array(hcl) <= -1) goto oops;
break; break;
case COP_EMIT_MAKE_BYTEARRAY: case COP_EMIT_MAKE_PURE_ARRAY:
if (emit_make_bytearray(hcl) <= -1) goto oops; if (emit_make_pure_array(hcl) <= -1) goto oops;
break; break;
case COP_EMIT_MAKE_DIC: case COP_EMIT_MAKE_DIC:
@ -6464,8 +6472,8 @@ int hcl_compile (hcl_t* hcl, hcl_cnode_t* obj, int flags)
if (emit_pop_into_array(hcl) <= -1) goto oops; if (emit_pop_into_array(hcl) <= -1) goto oops;
break; break;
case COP_EMIT_POP_INTO_BYTEARRAY: case COP_EMIT_POP_INTO_PURE_ARRAY:
if (emit_pop_into_bytearray(hcl) <= -1) goto oops; if (emit_pop_into_pure_array(hcl) <= -1) goto oops;
break; break;
case COP_EMIT_POP_INTO_DIC: case COP_EMIT_POP_INTO_DIC:

10
lib/decode.c
View File

@ -645,6 +645,16 @@ int hcl_decode (hcl_t* hcl, const hcl_code_t* code, hcl_oow_t start, hcl_oow_t e
LOG_INST_1 (hcl, "pop_into_bytearray %zu", b1); LOG_INST_1 (hcl, "pop_into_bytearray %zu", b1);
break; break;
case HCL_CODE_MAKE_CHARARRAY:
FETCH_PARAM_CODE_TO (hcl, b1);
LOG_INST_1 (hcl, "make_chararray %zu", b1);
break;
case HCL_CODE_POP_INTO_CHARARRAY:
FETCH_PARAM_CODE_TO (hcl, b1);
LOG_INST_1 (hcl, "pop_into_chararray %zu", b1);
break;
case HCL_CODE_MAKE_DIC: case HCL_CODE_MAKE_DIC:
FETCH_PARAM_CODE_TO (hcl, b1); FETCH_PARAM_CODE_TO (hcl, b1);
LOG_INST_1 (hcl, "make_dic %zu", b1); LOG_INST_1 (hcl, "make_dic %zu", b1);

43
lib/exec.c
View File

@ -4638,6 +4638,49 @@ hcl_logbfmt (hcl, HCL_LOG_STDERR, ">>>%O c->sc=%O sc=%O b2=%d b3=%d nivars=%d nc
break; break;
} }
case HCL_CODE_MAKE_CHARARRAY:
{
hcl_oop_t t;
FETCH_PARAM_CODE_TO (hcl, b1);
LOG_INST_1 (hcl, "make_chararray %zu", b1);
/* create an empty array */
t = hcl_makechararray(hcl, HCL_NULL, b1);
if (HCL_UNLIKELY(!t)) goto oops_with_errmsg_supplement;
HCL_STACK_PUSH (hcl, t); /* push the char array created */
break;
}
case HCL_CODE_POP_INTO_CHARARRAY:
{
hcl_oop_t t1, t2;
hcl_ooi_t bv;
FETCH_PARAM_CODE_TO (hcl, b1);
LOG_INST_1 (hcl, "pop_into_chararray %zu", b1);
t1 = HCL_STACK_GETTOP(hcl); /* value to store */
if (!HCL_OOP_IS_CHAR(t1) || (bv = HCL_OOP_TO_CHAR(t1)) < 0 || bv > 255)
{
hcl_seterrbfmt (hcl, HCL_ERANGE, "not a character or out of character range - %O", t1);
if (do_throw_with_internal_errmsg(hcl, fetched_instruction_pointer) >= 0) break;
goto oops_with_errmsg_supplement;
}
HCL_STACK_POP (hcl);
t2 = HCL_STACK_GETTOP(hcl); /* char array */
if (HCL_UNLIKELY(b1 >= HCL_OBJ_GET_SIZE(t2)))
{
hcl_seterrbfmt (hcl, HCL_ECALL, "character array index %zu out of upper bound %zd ", b1, (hcl_oow_t)HCL_OBJ_GET_SIZE(t2));
if (do_throw_with_internal_errmsg(hcl, fetched_instruction_pointer) >= 0) break;
goto oops_with_errmsg_supplement;
}
((hcl_oop_char_t)t2)->slot[b1] = bv;
break;
}
case HCL_CODE_MAKE_DIC: case HCL_CODE_MAKE_DIC:
{ {
hcl_oop_t t; hcl_oop_t t;

13
lib/gc.c
View File

@ -135,6 +135,7 @@ enum {
KCI_BYTE_STRING, KCI_BYTE_STRING,
KCI_SYMBOL, KCI_SYMBOL,
KCI_ARRAY, KCI_ARRAY,
KCI_CHARACTER_ARRAY,
KCI_BYTE_ARRAY, KCI_BYTE_ARRAY,
KCI_SYMBOL_TABLE, KCI_SYMBOL_TABLE,
KCI_DICTIONARY, KCI_DICTIONARY,
@ -335,6 +336,18 @@ static kernel_class_info_t kernel_classes[__KCI_MAX__] =
HCL_OFFSETOF(hcl_t, c_array) HCL_OFFSETOF(hcl_t, c_array)
}, },
KCI(KCI_CHARACTER_ARRAY) {
"CharacterArray",
KCI_FIXED_SIZED_COLLECTION,
HCL_BRAND_CHARACTER_ARRAY,
0,
0,
0,
HCL_CLASS_SPEC_FLAG_INDEXED,
HCL_OBJ_TYPE_CHAR,
HCL_OFFSETOF(hcl_t, c_character_array)
},
KCI(KCI_BYTE_ARRAY) { KCI(KCI_BYTE_ARRAY) {
"ByteArray", "ByteArray",
KCI_FIXED_SIZED_COLLECTION, KCI_FIXED_SIZED_COLLECTION,

8
lib/hcl-prv.h
View File

@ -624,12 +624,12 @@ struct hcl_cframe_t
hcl_ooi_t index; hcl_ooi_t index;
} array_list; } array_list;
/* COP_COMPILE_BYTEARRAY_LIST, COP_POP_INTO_BYTEARRAY, COP_EMIT_MAKE_BYTEARRAY */ /* COP_COMPILE_PURE_ARRAY_LIST, COP_POP_INTO_PURE_ARRAY, COP_EMIT_MAKE_PURE_ARRAY */
struct struct
{ {
int elem_type; int elem_type;
hcl_ooi_t index; hcl_ooi_t index;
} bytearray_list; } pure_array_list;
/* COP_EMIT_MAKE_DIC */ /* COP_EMIT_MAKE_DIC */
struct struct
@ -1376,8 +1376,8 @@ enum hcl_bcode_t
HCL_CODE_POP_INTO_CTXTEMPVAR_X = 0xDC, /* 220 ## */ HCL_CODE_POP_INTO_CTXTEMPVAR_X = 0xDC, /* 220 ## */
HCL_CODE_CLASS_LOAD = 0xDD, /* 221 ## */ HCL_CODE_CLASS_LOAD = 0xDD, /* 221 ## */
HCL_CODE_MAKE_CHARARRAY = 0xDE, /* 222 ## */
/* UNUSED - 0xDE - 0xDF */ HCL_CODE_POP_INTO_CHARARRAY = 0xDF, /* 223 ## */
HCL_CODE_PUSH_CTXTEMPVAR_X = 0xE0, /* 224 ## */ HCL_CODE_PUSH_CTXTEMPVAR_X = 0xE0, /* 224 ## */
HCL_CODE_CLASS_ENTER = 0xE1, /* 225 ## */ HCL_CODE_CLASS_ENTER = 0xE1, /* 225 ## */

8
lib/hcl.h
View File

@ -1721,6 +1721,7 @@ struct hcl_t
hcl_oop_class_t c_byte_string; /* String */ hcl_oop_class_t c_byte_string; /* String */
hcl_oop_class_t c_symbol; /* Symbol */ hcl_oop_class_t c_symbol; /* Symbol */
hcl_oop_class_t c_array; /* Array */ hcl_oop_class_t c_array; /* Array */
hcl_oop_class_t c_character_array; /* CharacterArray */
hcl_oop_class_t c_byte_array; /* ByteArray */ hcl_oop_class_t c_byte_array; /* ByteArray */
hcl_oop_class_t c_symtab; /* SymbolTable */ hcl_oop_class_t c_symtab; /* SymbolTable */
hcl_oop_class_t c_dictionary; hcl_oop_class_t c_dictionary;
@ -2010,6 +2011,7 @@ enum hcl_brand_t
HCL_BRAND_CONS, HCL_BRAND_CONS,
HCL_BRAND_ARRAY, HCL_BRAND_ARRAY,
HCL_BRAND_BYTE_ARRAY, HCL_BRAND_BYTE_ARRAY,
HCL_BRAND_CHARACTER_ARRAY,
HCL_BRAND_SYMBOL, HCL_BRAND_SYMBOL,
HCL_BRAND_STRING, HCL_BRAND_STRING,
HCL_BRAND_BYTE_STRING, HCL_BRAND_BYTE_STRING,
@ -2897,6 +2899,12 @@ HCL_EXPORT hcl_oop_t hcl_makearray (
hcl_oow_t len hcl_oow_t len
); );
HCL_EXPORT hcl_oop_t hcl_makechararray (
hcl_t* hcl,
const hcl_ooch_t* ptr,
hcl_oow_t len
);
HCL_EXPORT hcl_oop_t hcl_makebytearray ( HCL_EXPORT hcl_oop_t hcl_makebytearray (
hcl_t* hcl, hcl_t* hcl,
const hcl_oob_t* ptr, const hcl_oob_t* ptr,

12
lib/obj.c
View File

@ -345,6 +345,18 @@ hcl_oop_t hcl_makearray (hcl_t* hcl, hcl_oow_t len)
#endif #endif
} }
hcl_oop_t hcl_makechararray (hcl_t* hcl, const hcl_ooch_t* ptr, hcl_oow_t len)
{
hcl_oop_t v;
v = hcl_instantiate(hcl, hcl->c_character_array, ptr, len);
if (HCL_UNLIKELY(!v))
{
const hcl_ooch_t* orgmsg = hcl_backuperrmsg(hcl);
hcl_seterrbfmt (hcl, HCL_ERRNUM(hcl), "unable to make char-array - %js", orgmsg);
}
return v;
}
hcl_oop_t hcl_makebytearray (hcl_t* hcl, const hcl_oob_t* ptr, hcl_oow_t len) hcl_oop_t hcl_makebytearray (hcl_t* hcl, const hcl_oob_t* ptr, hcl_oow_t len)
{ {
#if 0 #if 0

20
lib/read.c
View File

@ -846,7 +846,8 @@ static HCL_INLINE int can_comma_list (hcl_t* hcl)
{ {
if (rstl->count & 1) return 0; if (rstl->count & 1) return 0;
} }
else if (cc != HCL_CONCODE_ARRAY && cc != HCL_CONCODE_BYTEARRAY && cc != HCL_CONCODE_TUPLE) else if (cc != HCL_CONCODE_ARRAY && cc != HCL_CONCODE_BYTEARRAY &&
cc != HCL_CONCODE_CHARARRAY && cc != HCL_CONCODE_TUPLE)
{ {
return 0; return 0;
} }
@ -2469,16 +2470,18 @@ static int flx_hmarked_token (hcl_t* hcl, hcl_ooci_t c)
/* --------------------------- */ /* --------------------------- */
case 'x': case 'x': /* hexadecimal number */
init_flx_hn (FLX_HN(hcl), HCL_TOK_RADNUMLIT, HCL_SYNERR_NUMLIT, 16); init_flx_hn (FLX_HN(hcl), HCL_TOK_RADNUMLIT, HCL_SYNERR_NUMLIT, 16);
goto radixed_number; goto radixed_number;
case 'o': case 'o': /* octal number */
init_flx_hn (FLX_HN(hcl), HCL_TOK_RADNUMLIT, HCL_SYNERR_NUMLIT, 8); init_flx_hn (FLX_HN(hcl), HCL_TOK_RADNUMLIT, HCL_SYNERR_NUMLIT, 8);
goto radixed_number; goto radixed_number;
case 'b': case 'b': /* binary number or byte array */
case 'c': case 'B':
case 'c': /* character array */
case 'C':
#if 0 #if 0
init_flx_hn (FLX_HN(hcl), HCL_TOK_RADNUMLIT, HCL_SYNERR_NUMLIT, 2); init_flx_hn (FLX_HN(hcl), HCL_TOK_RADNUMLIT, HCL_SYNERR_NUMLIT, 2);
goto radixed_number; goto radixed_number;
@ -2489,12 +2492,11 @@ static int flx_hmarked_token (hcl_t* hcl, hcl_ooci_t c)
break; break;
#endif #endif
case 'e': /* #eXXX - error literal */
case 'e':
init_flx_hn (FLX_HN(hcl), HCL_TOK_ERRLIT, HCL_SYNERR_ERRLIT, 10); init_flx_hn (FLX_HN(hcl), HCL_TOK_ERRLIT, HCL_SYNERR_ERRLIT, 10);
goto radixed_number; goto radixed_number;
case 'p': case 'p': /* #pXXX - small pointer */
init_flx_hn (FLX_HN(hcl), HCL_TOK_SMPTRLIT, HCL_SYNERR_SMPTRLIT, 16); init_flx_hn (FLX_HN(hcl), HCL_TOK_SMPTRLIT, HCL_SYNERR_SMPTRLIT, 16);
radixed_number: radixed_number:
FEED_CONTINUE_WITH_CHAR (hcl, c, HCL_FLX_HMARKED_NUMBER); FEED_CONTINUE_WITH_CHAR (hcl, c, HCL_FLX_HMARKED_NUMBER);
@ -2518,7 +2520,7 @@ static int flx_hmarked_token (hcl_t* hcl, hcl_ooci_t c)
FEED_WRAP_UP_WITH_CHAR (hcl, c, HCL_TOK_DLPAREN); FEED_WRAP_UP_WITH_CHAR (hcl, c, HCL_TOK_DLPAREN);
goto consumed; goto consumed;
case '"': /* #" */ case '"': /* #" - double-quoted symbol */
reset_flx_token (hcl); reset_flx_token (hcl);
init_flx_qt (FLX_QT(hcl), HCL_TOK_SYMLIT, HCL_SYNERR_SYMLIT, c, '\\', 0, HCL_TYPE_MAX(hcl_oow_t), 0); init_flx_qt (FLX_QT(hcl), HCL_TOK_SYMLIT, HCL_SYNERR_SYMLIT, c, '\\', 0, HCL_TYPE_MAX(hcl_oow_t), 0);
FEED_CONTINUE (hcl, HCL_FLX_QUOTED_TOKEN); /* discard prefix, quote and move on */ FEED_CONTINUE (hcl, HCL_FLX_QUOTED_TOKEN); /* discard prefix, quote and move on */

39
mod/core.c
View File

@ -446,6 +446,41 @@ static hcl_pfrc_t pf_core_slice (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t nargs)
return HCL_PF_SUCCESS; return HCL_PF_SUCCESS;
} }
static hcl_pfrc_t pf_core_char_to_smooi (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t nargs)
{
hcl_oop_t rcv, out;
hcl_ooi_t code;
rcv = HCL_STACK_GETARG(hcl, nargs, 0);
if (!HCL_OOP_IS_CHAR(rcv))
{
hcl_seterrbfmt (hcl, HCL_EINVAL, "receiver not Character - %O", rcv);
return HCL_PF_FAILURE;
}
code = HCL_OOP_TO_CHAR(rcv);
out = HCL_SMOOI_TO_OOP(code);
HCL_STACK_SETRET (hcl, nargs, out);
return HCL_PF_SUCCESS;
}
static hcl_pfrc_t pf_core_smooi_to_char (hcl_t* hcl, hcl_mod_t* mod, hcl_ooi_t nargs)
{
hcl_oop_t rcv, out;
hcl_ooi_t code;
rcv = HCL_STACK_GETARG(hcl, nargs, 0);
if (!HCL_OOP_IS_SMOOI(rcv))
{
hcl_seterrbfmt (hcl, HCL_EINVAL, "receiver not SmallInteger - %O", rcv);
return HCL_PF_FAILURE;
}
code = HCL_OOP_TO_SMOOI(rcv);
out = HCL_CHAR_TO_OOP(code);
HCL_STACK_SETRET (hcl, nargs, out);
return HCL_PF_SUCCESS;
}
static hcl_pfinfo_t pfinfos[] = static hcl_pfinfo_t pfinfos[] =
{ {
@ -453,12 +488,14 @@ static hcl_pfinfo_t pfinfos[] =
{ "basicAtPut", { HCL_PFBASE_FUNC, pf_core_basic_at_put, 3, 3 } }, { "basicAtPut", { HCL_PFBASE_FUNC, pf_core_basic_at_put, 3, 3 } },
{ "basicNew", { HCL_PFBASE_FUNC, pf_core_basic_new, 2, 2 } }, { "basicNew", { HCL_PFBASE_FUNC, pf_core_basic_new, 2, 2 } },
{ "basicSize", { HCL_PFBASE_FUNC, pf_core_basic_size, 1, 1 } }, { "basicSize", { HCL_PFBASE_FUNC, pf_core_basic_size, 1, 1 } },
{ "charToSmooi", { HCL_PFBASE_FUNC, pf_core_char_to_smooi, 1, 1 } },
{ "className", { HCL_PFBASE_FUNC, pf_core_class_name, 1, 1 } }, { "className", { HCL_PFBASE_FUNC, pf_core_class_name, 1, 1 } },
{ "classRespondsTo", { HCL_PFBASE_FUNC, pf_core_class_responds_to, 2, 2 } }, { "classRespondsTo", { HCL_PFBASE_FUNC, pf_core_class_responds_to, 2, 2 } },
{ "instRespondsTo", { HCL_PFBASE_FUNC, pf_core_inst_responds_to, 2, 2 } }, { "instRespondsTo", { HCL_PFBASE_FUNC, pf_core_inst_responds_to, 2, 2 } },
{ "primAt", { HCL_PFBASE_FUNC, pf_core_prim_at, 2, 2 } }, { "primAt", { HCL_PFBASE_FUNC, pf_core_prim_at, 2, 2 } },
{ "primAtPut", { HCL_PFBASE_FUNC, pf_core_prim_at_put, 3, 3 } }, { "primAtPut", { HCL_PFBASE_FUNC, pf_core_prim_at_put, 3, 3 } },
{ "slice", { HCL_PFBASE_FUNC, pf_core_slice, 3, 3 } } { "slice", { HCL_PFBASE_FUNC, pf_core_slice, 3, 3 } },
{ "smooiToChar", { HCL_PFBASE_FUNC, pf_core_smooi_to_char, 1, 1 } },
}; };
/* ------------------------------------------------------------------------ */ /* ------------------------------------------------------------------------ */

49
t/feed-01.hcl
View File

@ -54,4 +54,53 @@ if { q := 10; < k q } { ## a block expression is a normal expression. so it can
printf "OK: k is less than q\n" printf "OK: k is less than q\n"
} else (printf "BAD: k is not less than q\n") } else (printf "BAD: k is not less than q\n")
fun ByteArray:at(pos) {
return (core.basicAt self pos)
}
fun CharacterArray:at(pos) {
return (core.basicAt self pos)
}
fun SmallInteger:toCharacter() {
return (core.smooiToChar self)
}
fun Character:toCode() {
return (core.charToSmooi self)
}
ba := #B[1 2 3 4 5 6 7 8 9 10 11 12 13 14 15]
i := 0
while (< i 15) {
x := (+ i 1)
if (== (ba:at i) x) { printf "OK: (ba:at %d) is %O\n" i (ba:at i) } \
else { printf "ERROR: (ba:at %d) is not %d\n" i x }
i := x
}
ca := #C[
'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm',
'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', 'y', 'z',
'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M',
'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z'
]
i := 0
while (< i 26) {
x := ((+ i ('a':toCode)):toCharacter)
if (eqv? (ca:at i) x) { printf "OK: (ca:at %d) is %O\n" i x } \
else { printf "ERROR: (ca:at %d) is not %O\n" i x}
i := (+ i 1)
}
i := 26
while (< i 52) {
x := ((+ (- i 26) ('A':toCode)):toCharacter)
if (eqv? (ca:at i) x) { printf "OK: (ca:at %d) is %O\n" i x } \
else { printf "ERROR: (ca:at %d) is not %O\n" i x}
i := (+ i 1)
}
} ## END } ## END