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

added some code to handle local variable declaration

Browse Source
This commit is contained in:
hyung-hwan 2016-10-01 04:36:48 +00:00
parent 55a5d2c3c6
commit bdfc72d48d
8 changed files with 374 additions and 131 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

195
lib/comp.c
View File

@ -29,7 +29,7 @@
enum
{
VAR_NAMED,
VAR_ARGUMENT
VAR_INDEXED
};
#define TV_BUFFER_ALIGN 256
@ -185,16 +185,12 @@ static int emit_single_param_instruction (hcl_t* hcl, int cmd, hcl_oow_t param_1
switch (cmd)
{
#if 0
case BCODE_PUSH_INSTVAR_0:
case BCODE_STORE_INTO_INSTVAR_0:
case BCODE_POP_INTO_INSTVAR_0:
#endif
case HCL_CODE_PUSH_TEMPVAR_0:
#if 0
case BCODE_STORE_INTO_TEMPVAR_0:
case HCL_CODE_STORE_INTO_TEMPVAR_0:
case BCODE_POP_INTO_TEMPVAR_0:
#endif
if (param_1 < 8)
{
/* low 3 bits to hold the parameter */
@ -232,10 +228,8 @@ static int emit_single_param_instruction (hcl_t* hcl, int cmd, hcl_oow_t param_1
case BCODE_POP_INTO_OBJECT_0:
case HCL_CODE_JUMP_FORWARD_0:
case HCL_CODE_JUMP_BACKWARD_0:
#if 0
case HCL_CODE_JUMP_IF_TRUE_0:
case HCL_CODE_JUMP_IF_FALSE_0:
#endif
case BCODE_JUMP_IF_TRUE_0:
case BCODE_JUMP_IF_FALSE_0:
case HCL_CODE_CALL_0:
if (param_1 < 4)
{
@ -310,15 +304,13 @@ static int emit_double_param_instruction (hcl_t* hcl, int cmd, hcl_oow_t param_1
{
case HCL_CODE_STORE_INTO_CTXTEMPVAR_0:
/*case BCODE_POP_INTO_CTXTEMPVAR_0:*/
case BCODE_POP_INTO_CTXTEMPVAR_0:
case HCL_CODE_PUSH_CTXTEMPVAR_0:
#if 0
case HCL_CODE_PUSH_OBJVAR_0:
case HCL_CODE_STORE_INTO_OBJVAR_0:
case BCODE_PUSH_OBJVAR_0:
case BCODE_STORE_INTO_OBJVAR_0:
case BCODE_POP_INTO_OBJVAR_0:
case HCL_CODE_SEND_MESSAGE_0:
case HCL_CODE_SEND_MESSAGE_TO_SUPER_0:
#endif
case BCODE_SEND_MESSAGE_0:
case BCODE_SEND_MESSAGE_TO_SUPER_0:
if (param_1 < 4 && param_2 < 0xFF)
{
/* low 2 bits of the instruction code is the first parameter */
@ -547,10 +539,10 @@ enum
static int compile_lambda (hcl_t* hcl, hcl_oop_t src)
{
hcl_cframe_t* cf;
hcl_oop_t obj, args, arg, ptr;
hcl_oop_t obj, args;
hcl_oow_t nargs, ntmprs;
hcl_oow_t jump_inst_pos;
hcl_oow_t saved_tv_count;
hcl_oow_t saved_tv_count, tv_dup_start;
HCL_ASSERT (HCL_BRANDOF(hcl,src) == HCL_BRAND_CONS);
HCL_ASSERT (HCL_CONS_CAR(src) == hcl->_lambda);
@ -579,7 +571,8 @@ static int compile_lambda (hcl_t* hcl, hcl_oop_t src)
}
else
{
hcl_oow_t tv_dup_start;
hcl_oop_t arg, ptr;
if (HCL_BRANDOF(hcl, args) != HCL_BRAND_CONS)
{
HCL_DEBUG1 (hcl, "Syntax error - not a lambda argument list - %O\n", args);
@ -607,8 +600,7 @@ static int compile_lambda (hcl_t* hcl, hcl_oop_t src)
if (hcl->errnum == HCL_EEXIST)
{
HCL_DEBUG1 (hcl, "Syntax error - lambda argument duplicate - %O\n", arg);
hcl_setsynerr (hcl, HCL_SYNERR_ARGNAME, HCL_NULL, HCL_NULL); /* TODO: error location */
return -1;
hcl_setsynerr (hcl, HCL_SYNERR_ARGNAMEDUP, HCL_NULL, HCL_NULL); /* TODO: error location */
}
return -1;
}
@ -629,9 +621,6 @@ static int compile_lambda (hcl_t* hcl, hcl_oop_t src)
while (1);
}
ntmprs = nargs;
/* TODO: handle local temporary variables */
HCL_ASSERT (nargs == hcl->c->tv.size - saved_tv_count);
if (nargs > MAX_CODE_NBLKARGS) /*TODO: change this limit to max call argument count */
{
@ -644,17 +633,49 @@ static int compile_lambda (hcl_t* hcl, hcl_oop_t src)
return -1;
}
#if 0
/* TODO: block local temporary variables... */
ntmprs = nargs;
obj = HCL_CONS_CDR(obj);
tv_dup_start = hcl->c->tv.size;
while (HCL_IS_CONS(hcl, obj))
{
hcl_oop_t dcl;
dcl = HCL_CONS_CAR(obj);
if (HCL_IS_SYMBOL_ARRAY(hcl, dcl))
{
hcl_oow_t i, sz;
sz = HCL_OBJ_GET_SIZE(dcl);
for (i = 0; i < sz; i++)
{
if (add_temporary_variable (hcl, ((hcl_oop_oop_t)dcl)->slot[i], tv_dup_start) <= -1)
{
if (hcl->errnum == HCL_EEXIST)
{
HCL_DEBUG1 (hcl, "Syntax error - local variable duplicate - %O\n", ((hcl_oop_oop_t)dcl)->slot[i]);
hcl_setsynerr (hcl, HCL_SYNERR_VARNAMEDUP, HCL_NULL, HCL_NULL); /* TODO: error location */
}
return -1;
}
ntmprs++;
}
obj = HCL_CONS_CDR(obj);
}
else break;
}
/* ntmprs: number of temporary variables including arguments */
HCL_ASSERT (ntmprs == hcl->c->tv.size - saved_tv_count);
if (ntmprs > MAX_CODE_NBLKTMPRS)
{
HCL_DEBUG1 (hcl, "Syntax error - too many local temporary variables - %O\n", args);
hcl_setsynerr (hcl, HCL_SYNERR_BLKTMPRFLOOD, HCL_NULL, HCL_NULL);
HCL_DEBUG1 (hcl, "Syntax error - too many variables - %O\n", args);
hcl_setsynerr (hcl, HCL_SYNERR_VARFLOOD, HCL_NULL, HCL_NULL);
return -1;
}
#endif
if (hcl->c->blk.depth == HCL_TYPE_MAX(hcl_ooi_t))
{
@ -672,7 +693,7 @@ static int compile_lambda (hcl_t* hcl, hcl_oop_t src)
jump_inst_pos = hcl->code.bc.len;
if (emit_single_param_instruction (hcl, HCL_CODE_JUMP_FORWARD_0, MAX_CODE_JUMP) <= -1) return -1;
SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT_LIST, HCL_CONS_CDR(obj));
SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT_LIST, obj);
PUSH_SUBCFRAME (hcl, COP_EMIT_LAMBDA, hcl->_nil); /* operand field is not used for COP_EMIT_LAMBDA */
cf = GET_SUBCFRAME (hcl); /* modify the EMIT_LAMBDA frame */
@ -687,6 +708,7 @@ static int compile_set (hcl_t* hcl, hcl_oop_t src)
{
hcl_cframe_t* cf;
hcl_oop_t obj, var, val;
hcl_oow_t index;
obj = HCL_CONS_CDR(src);
@ -740,9 +762,22 @@ static int compile_set (hcl_t* hcl, hcl_oop_t src)
}
SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, val);
PUSH_SUBCFRAME (hcl, COP_EMIT_SET, var); /* set doesn't evaluate the variable name */
cf = GET_SUBCFRAME (hcl);
cf->u.set.var_type = VAR_NAMED;
if (find_temporary_variable_backward (hcl, var, &index) <= -1)
{
PUSH_SUBCFRAME (hcl, COP_EMIT_SET, var); /* set doesn't evaluate the variable name */
cf = GET_SUBCFRAME (hcl);
cf->u.set.var_type = VAR_NAMED;
}
else
{
/* the check in compile_lambda() must ensure this condition */
HCL_ASSERT (index <= HCL_SMOOI_MAX);
PUSH_SUBCFRAME (hcl, COP_EMIT_SET, HCL_SMOOI_TO_OOP(index));
cf = GET_SUBCFRAME (hcl);
cf->u.set.var_type = VAR_INDEXED;
}
return 0;
}
@ -842,6 +877,40 @@ static int compile_cons (hcl_t* hcl, hcl_oop_t obj)
return 0;
}
static int emit_indexed_variable_access (hcl_t* hcl, hcl_oow_t index, hcl_oob_t baseinst1, hcl_oob_t baseinst2)
{
#if defined(HCL_USE_CTXTEMPVAR)
if (hcl->c->blk.depth >= 0)
{
hcl_oow_t i;
/* if a temporary variable is accessed inside a block,
* use a special instruction to indicate it */
HCL_ASSERT (index < hcl->c->blk.tmprcnt[hcl->c->blk.depth]);
for (i = hcl->c->blk.depth; i > 0; i--) /* excluded the top level -- TODO: change this code depending on global variable handling */
{
if (index >= hcl->c->blk.tmprcnt[i - 1])
{
hcl_oow_t ctx_offset, index_in_ctx;
ctx_offset = hcl->c->blk.depth - i;
index_in_ctx = index - hcl->c->blk.tmprcnt[i - 1];
/* ctx_offset 0 means the current context.
* 1 means current->home.
* 2 means current->home->home.
* index_in_ctx is a relative index within the context found.
*/
if (emit_double_param_instruction(hcl, baseinst1, ctx_offset, index_in_ctx) <= -1) return -1;
return 0;
}
}
}
#endif
/* TODO: top-level... verify this. this will vary depending on how i implement the top-level and global variables... */
if (emit_single_param_instruction (hcl, baseinst2, index) <= -1) return -1;
return 0;
}
static HCL_INLINE int compile_symbol (hcl_t* hcl, hcl_oop_t obj)
{
hcl_oow_t index;
@ -851,44 +920,17 @@ static HCL_INLINE int compile_symbol (hcl_t* hcl, hcl_oop_t obj)
/* check if a symbol is a local variable */
if (find_temporary_variable_backward (hcl, obj, &index) <= -1)
{
/* TODO: if i require all variables to be declared, this part is not needed and should handle it as an error */
/* global variable */
if (add_literal(hcl, obj, &index) <= -1 ||
emit_single_param_instruction (hcl, HCL_CODE_PUSH_OBJECT_0, index) <= -1) return -1;
return 0;
}
else
{
#if defined(HCL_USE_CTXTEMPVAR)
if (hcl->c->blk.depth >= 0)
{
hcl_oow_t i;
/* if a temporary variable is accessed inside a block,
* use a special instruction to indicate it */
HCL_ASSERT (index < hcl->c->blk.tmprcnt[hcl->c->blk.depth]);
for (i = hcl->c->blk.depth; i > 0; i--) /* excluded the top level -- TODO: change this code depending on global variable handling */
{
if (index >= hcl->c->blk.tmprcnt[i - 1])
{
hcl_oow_t ctx_offset, index_in_ctx;
ctx_offset = hcl->c->blk.depth - i;
index_in_ctx = index - hcl->c->blk.tmprcnt[i - 1];
/* ctx_offset 0 means the current context.
* 1 means current->home.
* 2 means current->home->home.
* index_in_ctx is a relative index within the context found.
*/
if (emit_double_param_instruction(hcl, HCL_CODE_PUSH_CTXTEMPVAR_0, ctx_offset, index_in_ctx) <= -1) return -1;
return 0;
}
}
}
#endif
/* TODO: top-level... verify this. this will vary depending on how i implement the top-level and global variables... */
if (emit_single_param_instruction (hcl, HCL_CODE_PUSH_TEMPVAR_0, index) <= -1) return -1;
return emit_indexed_variable_access (hcl, index, HCL_CODE_PUSH_CTXTEMPVAR_0, HCL_CODE_PUSH_TEMPVAR_0);
}
return 0;
}
static int compile_object (hcl_t* hcl)
@ -922,6 +964,11 @@ static int compile_object (hcl_t* hcl)
if (compile_cons (hcl, cf->operand) <= -1) return -1;
break;
case HCL_BRAND_SYMBOL_ARRAY:
HCL_DEBUG1 (hcl, "Syntax error - variable declartion disallowed - %O\n", cf->operand);
hcl_setsynerr (hcl, HCL_SYNERR_VARDCLBANNED, HCL_NULL, HCL_NULL); /* TODO: error location */
return -1;
default:
goto literal;
}
@ -1080,26 +1127,30 @@ static HCL_INLINE int emit_set (hcl_t* hcl)
cf = GET_TOP_CFRAME(hcl);
HCL_ASSERT (cf->opcode == COP_EMIT_SET);
HCL_ASSERT (HCL_IS_SYMBOL(hcl, cf->operand));
if (cf->u.set.var_type == VAR_NAMED)
{
hcl_oow_t index;
HCL_ASSERT (HCL_IS_SYMBOL(hcl, cf->operand));
if (add_literal(hcl, cf->operand, &index) <= -1 ||
emit_single_param_instruction(hcl, HCL_CODE_STORE_INTO_OBJECT_0, index) <= -1) return -1;
}
else
{
/* TODO: */
HCL_DEBUG0 (hcl, "EMIT SET NOT IMPLEMENTED YET\n");
hcl->errnum = HCL_ENOIMPL;
return -1;
hcl_oow_t index;
HCL_ASSERT (cf->u.set.var_type == VAR_INDEXED);
HCL_ASSERT (HCL_OOP_IS_SMOOI(cf->operand));
index = (hcl_oow_t)HCL_OOP_TO_SMOOI(cf->operand);
if (emit_indexed_variable_access (hcl, index, HCL_CODE_STORE_INTO_CTXTEMPVAR_0, HCL_CODE_STORE_INTO_TEMPVAR_0) <= -1) return -1;
}
POP_CFRAME (hcl);
return 0;
};
}
int hcl_compile (hcl_t* hcl, hcl_oop_t obj)
{
@ -1176,6 +1227,6 @@ oops:
hcl->code.lit.len = saved_lit_len;
hcl->c->tv.size = 0;
hcl->c->blk.depth = 0;
hcl->c->blk.depth = -1;
return -1;
}

2
lib/gc.c
View File

@ -34,7 +34,7 @@ static struct
hcl_oow_t offset;
} syminfo[] =
{
{ 6, { 'b', 'e', 'g', 'i', 'n' }, HCL_SYNCODE_BEGIN, HCL_OFFSETOF(hcl_t,_begin) },
{ 5, { 'b', 'e', 'g', 'i', 'n' }, HCL_SYNCODE_BEGIN, HCL_OFFSETOF(hcl_t,_begin) },
{ 5, { 'd', 'e', 'f', 'u', 'n' }, HCL_SYNCODE_DEFUN, HCL_OFFSETOF(hcl_t,_defun) },
{ 2, { 'i', 'f' }, HCL_SYNCODE_IF, HCL_OFFSETOF(hcl_t,_if) },
{ 6, { 'l', 'a', 'm', 'b', 'd', 'a' }, HCL_SYNCODE_LAMBDA, HCL_OFFSETOF(hcl_t,_lambda) },

9
lib/hcl-cmn.h
View File

@ -435,7 +435,16 @@ struct hcl_ntime_t
#define HCL_GETBITS(type,value,offset,length) \
((((type)(value)) >> (offset)) & HCL_LBMASK(type,length))
#define HCL_CLEARBITS(type,value,offset,length) \
(((type)(value)) & ~(HCL_LBMASK(type,length) << (offset)))
#define HCL_SETBITS(type,value,offset,length,bits) \
(value = (HCL_CLEARBITS(type,value,offset,length) | (((bits) & HCL_LBMASK(type,length)) << (offset))))
#define HCL_FLIPBITS(type,value,offset,length) \
(((type)(value)) ^ (HCL_LBMASK(type,length) << (offset)))
#define HCL_ORBITS(type,value,offset,length,bits) \
(value = (((type)(value)) | (((bits) & HCL_LBMASK(type,length)) << (offset))))

17
lib/hcl-prv.h
View File

@ -255,6 +255,7 @@ struct hcl_iotok_t
HCL_IOTOK_BAPAREN,
HCL_IOTOK_LBRACK,
HCL_IOTOK_RBRACK,
HCL_IOTOK_VBAR,
HCL_IOTOK_INCLUDE
} type;
@ -337,9 +338,19 @@ struct hcl_compiler_t
hcl_oop_t s; /* stack for reading */
hcl_oop_t e; /* last object read */
hcl_oow_t balit_capa;
hcl_oow_t balit_count;
hcl_oob_t* balit;
struct
{
hcl_oob_t* ptr;
hcl_oow_t size;
hcl_oow_t capa;
} balit;
struct
{
hcl_oop_t* ptr;
hcl_oow_t size;
hcl_oow_t capa;
} salit;
} r; /* reading */
/* == END READER == */

19
lib/hcl.h
View File

@ -80,21 +80,27 @@ enum hcl_synerrnum_t
HCL_SYNERR_LPAREN, /* ( expected */
HCL_SYNERR_RPAREN, /* ) expected */
HCL_SYNERR_RBRACK, /* ] expected */
HCL_SYNERR_VBAR, /* | expected */
HCL_SYNERR_STRING, /* string expected */
HCL_SYNERR_BYTERANGE, /* byte too small or too large */
HCL_SYNERR_NESTING, /* nesting level too deep */
HCL_SYNERR_VBARBANNED, /* | disallowed */
HCL_SYNERR_DOTBANNED, /* . disallowed */
HCL_SYNERR_INCLUDE, /* #include error */
HCL_SYNERR_ARGNAMELIST, /* argument name list expected */
HCL_SYNERR_ARGNAME, /* argument name expected */
HCL_SYNERR_BLKFLOOD, /* lambda block too big */
HCL_SYNERR_BLKDEPTH, /* lambda block too deep */
HCL_SYNERR_ARGNAMELIST, /* argument name list expected */
HCL_SYNERR_ARGNAME, /* argument name expected */
HCL_SYNERR_ARGNAMEDUP, /* duplicate argument name */
HCL_SYNERR_VARNAME, /* variable name expected */
HCL_SYNERR_ARGCOUNT, /* wrong number of arguments */
HCL_SYNERR_ARGFLOOD /* too many arguments defined */
HCL_SYNERR_ARGFLOOD, /* too many arguments defined */
HCL_SYNERR_VARFLOOD, /* too many variables defined */
HCL_SYNERR_VARDCLBANNED, /* variable declaration disallowed */
HCL_SYNERR_VARNAMEDUP /* duplicate variable name */
};
typedef enum hcl_synerrnum_t hcl_synerrnum_t;
@ -1038,6 +1044,7 @@ enum
HCL_BRAND_CONS,
HCL_BRAND_ARRAY,
HCL_BRAND_BYTE_ARRAY,
HCL_BRAND_SYMBOL_ARRAY, /* special. internal use only */
HCL_BRAND_SYMBOL,
HCL_BRAND_STRING,
HCL_BRAND_SET,
@ -1056,7 +1063,7 @@ enum
HCL_SYNCODE_IF,
HCL_SYNCODE_LAMBDA,
HCL_SYNCODE_QUOTE,
HCL_SYNCODE_SET,
HCL_SYNCODE_SET
};
struct hcl_cons_t
@ -1070,6 +1077,8 @@ typedef struct hcl_cons_t* hcl_oop_cons_t;
#define HCL_IS_NIL(hcl,v) (v == (hcl)->_nil)
#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_CONS(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_CONS)
#define HCL_CONS_CAR(v) (((hcl_cons_t*)(v))->car)
#define HCL_CONS_CDR(v) (((hcl_cons_t*)(v))->cdr)
@ -1274,9 +1283,7 @@ HCL_EXPORT void hcl_setsynerr (
const hcl_oocs_t* tgt
);
/* Memory allocation/deallocation functions using hcl's MMGR */
HCL_EXPORT void* hcl_allocmem (
hcl_t* hcl,
hcl_oow_t size

28
lib/main.c
View File

@ -436,21 +436,27 @@ static char* syntax_error_msg[] =
"( expected",
") expected",
"] expected",
"| expected",
"string expected",
"byte too small or too large",
"nesting level too deep",
"| disallowed",
". disallowed",
"#include error",
"argument name list expected",
"argument name expected",
"lambda block too big",
"lambda block too deep",
"argument name list expected",
"argument name expected",
"duplicate argument name",
"variable name expected",
"wrong number of arguments",
"too many arguments defined"
"too many arguments defined",
"too many variables defined",
"variable declaration disallowed",
"duplicate variable name"
};
static void print_synerr (hcl_t* hcl)
@ -499,7 +505,6 @@ hcl_ooch_t str_hcl[] = { 'S', 't', 'i', 'x' };
hcl_ooch_t str_my_object[] = { 'M', 'y', 'O', 'b','j','e','c','t' };
hcl_ooch_t str_main[] = { 'm', 'a', 'i', 'n' };
int main (int argc, char* argv[])
{
hcl_t* hcl;
@ -514,7 +519,6 @@ int main (int argc, char* argv[])
}
#endif
memset (&vmprim, 0, HCL_SIZEOF(vmprim));
vmprim.log_write = log_write;
@ -601,7 +605,19 @@ int main (int argc, char* argv[])
else
{
hcl_print (hcl, HCL_CHAR_TO_OOP('\n'));
hcl_compile (hcl, obj); /* TODO: error handling */
if (hcl_compile (hcl, obj) <= -1)
{
if (hcl->errnum == HCL_ESYNERR)
{
print_synerr (hcl);
}
else
{
printf ("ERROR: cannot compile object - %d\n", hcl_geterrnum(hcl));
}
/* carry on? */
}
}
}

81
lib/print.c
View File

@ -52,11 +52,11 @@ do { \
#define OUTPUT_CHAR(pr,ch) do { \
hcl_ooch_t tmp = ch; \
OUTPUT_STRX (pr, &tmp, 1); \
} while(0);
} while(0)
#define PRINT_STACK_ARRAY_END 0
#define PRINT_STACK_CONS 1
#define PRINT_STACK_ARRAY 2
#define PRINT_STACK_ARRAY_END 0
#define PRINT_STACK_CONS 1
#define PRINT_STACK_ARRAY 2
typedef struct print_stack_t print_stack_t;
struct print_stack_t
@ -193,6 +193,7 @@ static int print_object (printer_t* pr, hcl_oop_t obj)
hcl_t* hcl;
hcl_oop_t cur;
print_stack_t ps;
int brand;
static struct
{
@ -219,7 +220,7 @@ next:
goto done;
}
switch (HCL_OBJ_GET_FLAGS_BRAND(obj))
switch ((brand = HCL_OBJ_GET_FLAGS_BRAND(obj)))
{
case HCL_BRAND_NIL:
OUTPUT_STRX (pr, word[0].ptr, word[0].len);
@ -337,18 +338,32 @@ next:
{
hcl_oow_t arridx;
OUTPUT_CHAR (pr, '#');
OUTPUT_CHAR (pr, '(');
if (brand == HCL_BRAND_ARRAY)
{
OUTPUT_CHAR (pr, '#');
OUTPUT_CHAR (pr, '(');
}
else
{
OUTPUT_CHAR (pr, '|');
}
if (HCL_OBJ_GET_SIZE(obj) <= 0) goto done_array;
if (HCL_OBJ_GET_SIZE(obj) <= 0)
{
if (brand == HCL_BRAND_ARRAY)
OUTPUT_CHAR (pr, ')');
else
OUTPUT_CHAR (pr, '|');
break;
}
arridx = 0;
ps.type = PRINT_STACK_ARRAY;
do
{
int x;
/* Push what to print next on to the stack
* the variable p is */
/* Push what to print next on to the stack */
ps.idx = arridx + 1;
if (ps.idx >= HCL_OBJ_GET_SIZE(obj))
{
@ -356,7 +371,7 @@ next:
}
else
{
ps.type = PRINT_STACK_ARRAY;
HCL_ASSERT (ps.type == PRINT_STACK_ARRAY);
ps.obj = obj;
}
@ -368,7 +383,7 @@ next:
/* Jump to the 'next' label so that the object
* pointed to by 'obj' is printed. Once it
* ends, a jump back to the 'resume' label
* is made at the at of this function. */
* is made at the end of this function. */
goto next;
resume_array:
@ -377,9 +392,6 @@ next:
obj = ps.obj;
}
while (1);
done_array:
OUTPUT_CHAR (pr, ')');
break;
}
@ -399,6 +411,23 @@ next:
break;
}
case HCL_BRAND_SYMBOL_ARRAY:
{
hcl_oow_t i;
OUTPUT_CHAR (pr, '|');
for (i = 0; i < HCL_OBJ_GET_SIZE(obj); i++)
{
hcl_oop_t s;
s = ((hcl_oop_oop_t)obj)->slot[i];
OUTPUT_CHAR (pr, ' ');
OUTPUT_STRX (pr, ((hcl_oop_char_t)s)->slot, HCL_OBJ_GET_SIZE(s));
}
OUTPUT_CHAR (pr, ' ');
OUTPUT_CHAR (pr, '|');
break;
}
#if 0
case HCL_BRAND_PROCEDURE:
OUTPUT_STR (pr, "#<PROCEDURE>");
@ -411,7 +440,7 @@ next:
default:
HCL_ASSERT ("Unknown object type" == HCL_NULL);
HCL_DEBUG2 (hcl, "Internal error - unknown object type at %s:%d\n", __FILE__, __LINE__);
HCL_DEBUG3 (hcl, "Internal error - unknown object type %d at %s:%d\n", (int)brand, __FILE__, __LINE__);
hcl->errnum = HCL_EINTERN;
return -1;
}
@ -421,12 +450,22 @@ done:
while (hcl->p.s.size > 0)
{
pop (hcl, &ps);
if (ps.type == PRINT_STACK_CONS) goto resume_cons;
else if (ps.type == PRINT_STACK_ARRAY) goto resume_array;
else
switch (ps.type)
{
HCL_ASSERT (ps.type == PRINT_STACK_ARRAY_END);
OUTPUT_CHAR (pr, ')');
case PRINT_STACK_CONS:
goto resume_cons;
case PRINT_STACK_ARRAY:
goto resume_array;
case PRINT_STACK_ARRAY_END:
OUTPUT_CHAR (pr, ')');
break;
default:
HCL_DEBUG3 (hcl, "Internal error - unknown print stack type %d at %s:%d\n", (int)ps.type, __FILE__, __LINE__);
hcl->errnum = HCL_EINTERN;
return -1;
}
}

154
lib/read.c
View File

@ -33,6 +33,7 @@ static int end_include (hcl_t* hcl);
#define BUFFER_ALIGN 128
#define BALIT_BUFFER_ALIGN 128
#define SALIT_BUFFER_ALIGN 128
#define ARLIT_BUFFER_ALIGN 128
#define CHAR_TO_NUM(c,base) \
@ -218,7 +219,7 @@ static HCL_INLINE int is_alnumchar (hcl_ooci_t c)
static HCL_INLINE int is_delimiter (hcl_ooci_t c)
{
return c == '(' || c == ')' || c == '[' || c == ']' || c == '\"' || c == '#' || c == ';' || is_spacechar(c) || c == HCL_UCI_EOF;
return c == '(' || c == ')' || c == '[' || c == ']' || c == '\"' || c == '#' || c == ';' || c == '|' || is_spacechar(c) || c == HCL_UCI_EOF;
}
@ -908,13 +909,13 @@ retry:
}
case '(':
SET_TOKEN_TYPE (hcl, HCL_IOTOK_LPAREN);
ADD_TOKEN_CHAR(hcl, c);
SET_TOKEN_TYPE (hcl, HCL_IOTOK_LPAREN);
break;
case ')':
SET_TOKEN_TYPE (hcl, HCL_IOTOK_RPAREN);
ADD_TOKEN_CHAR(hcl, c);
SET_TOKEN_TYPE (hcl, HCL_IOTOK_RPAREN);
break;
case '[':
@ -927,6 +928,11 @@ retry:
SET_TOKEN_TYPE (hcl, HCL_IOTOK_RBRACK);
break;
case '|':
ADD_TOKEN_CHAR (hcl, c);
SET_TOKEN_TYPE(hcl, HCL_IOTOK_VBAR);
break;
case '.':
SET_TOKEN_TYPE (hcl, HCL_IOTOK_DOT);
ADD_TOKEN_CHAR(hcl, c);
@ -1204,12 +1210,14 @@ static HCL_INLINE hcl_oop_t enter_list (hcl_t* hcl, int flagv)
* nil#2 to store the last element in the list.
* both to be updated in chain_to_list() as items are added.
*/
/* TODO: change to push array of 3 cells instead? or don't use the object memory for stack. use compiler's own memory... */
return (push (hcl, HCL_SMOOI_TO_OOP(flagv)) == HCL_NULL ||
push (hcl, hcl->_nil) == HCL_NULL ||
push (hcl, hcl->_nil) == HCL_NULL)? HCL_NULL: hcl->c->r.s;
}
static HCL_INLINE hcl_oop_t leave_list (hcl_t* hcl, int* flagv)
static HCL_INLINE hcl_oop_t leave_list (hcl_t* hcl, int* flagv, int* oldflagv)
{
hcl_oop_t head;
int fv;
@ -1260,6 +1268,7 @@ static HCL_INLINE hcl_oop_t leave_list (hcl_t* hcl, int* flagv)
head = (hcl_oop_t)arr;
}
*oldflagv = fv;
if (HCL_IS_NIL(hcl,hcl->c->r.s))
{
/* the stack is empty after popping.
@ -1380,21 +1389,21 @@ static HCL_INLINE int is_list_empty (hcl_t* hcl)
static int add_to_byte_array_literal_buffer (hcl_t* hcl, hcl_oob_t b)
{
if (hcl->c->r.balit_count >= hcl->c->r.balit_capa)
if (hcl->c->r.balit.size >= hcl->c->r.balit.capa)
{
hcl_oob_t* tmp;
hcl_oow_t new_capa;
new_capa = HCL_ALIGN (hcl->c->r.balit_count + 1, BALIT_BUFFER_ALIGN);
tmp = (hcl_oob_t*)hcl_reallocmem (hcl, hcl->c->r.balit, new_capa * HCL_SIZEOF(*tmp));
new_capa = HCL_ALIGN (hcl->c->r.balit.size + 1, BALIT_BUFFER_ALIGN);
tmp = (hcl_oob_t*)hcl_reallocmem (hcl, hcl->c->r.balit.ptr, new_capa * HCL_SIZEOF(*tmp));
if (!tmp) return -1;
hcl->c->r.balit_capa = new_capa;
hcl->c->r.balit = tmp;
hcl->c->r.balit.capa = new_capa;
hcl->c->r.balit.ptr = tmp;
}
/* TODO: overflow check of hcl->c->r.balit_count itself */
hcl->c->r.balit[hcl->c->r.balit_count++] = b;
/* TODO: overflow check of hcl->c->r.balit.size itself */
hcl->c->r.balit.ptr[hcl->c->r.balit.size++] = b;
return 0;
}
@ -1403,7 +1412,7 @@ static int get_byte_array_literal (hcl_t* hcl, hcl_oop_t* xlit)
hcl_ooi_t tmp;
hcl_oop_t ba;
hcl->c->r.balit_count = 0;
HCL_ASSERT (hcl->c->r.balit.size == 0);
HCL_ASSERT (TOKEN_TYPE(hcl) == HCL_IOTOK_BAPAREN);
GET_TOKEN(hcl); /* skip #[ */
@ -1439,14 +1448,81 @@ static int get_byte_array_literal (hcl_t* hcl, hcl_oop_t* xlit)
return -1;
}
ba = hcl_makebytearray (hcl, hcl->c->r.balit, hcl->c->r.balit_count);
ba = hcl_makebytearray (hcl, hcl->c->r.balit.ptr, hcl->c->r.balit.size);
if (!ba)
{
hcl->c->r.balit_count = 0; /* reset literal count... */
hcl->c->r.balit.size = 0; /* reset literal count... */
return -1;
}
*xlit = ba;
hcl->c->r.balit.size = 0; /* reset literal count... */
return 0;
}
static int add_to_symbol_array_literal_buffer (hcl_t* hcl, hcl_oop_t b)
{
if (hcl->c->r.salit.size >= hcl->c->r.salit.capa)
{
hcl_oop_t* tmp;
hcl_oow_t new_capa;
new_capa = HCL_ALIGN (hcl->c->r.salit.size + 1, SALIT_BUFFER_ALIGN);
tmp = (hcl_oop_t*)hcl_reallocmem (hcl, hcl->c->r.salit.ptr, new_capa * HCL_SIZEOF(*tmp));
if (!tmp) return -1;
hcl->c->r.salit.capa = new_capa;
hcl->c->r.salit.ptr = tmp;
}
/* TODO: overflow check of hcl->c->r.tvlit_count itself */
hcl->c->r.salit.ptr[hcl->c->r.salit.size++] = b;
return 0;
}
static int get_symbol_array_literal (hcl_t* hcl, hcl_oop_t* xlit)
{
hcl_oop_t sa, sym;
hcl_oow_t i;
HCL_ASSERT (hcl->c->r.salit.size == 0);
HCL_ASSERT (TOKEN_TYPE(hcl) == HCL_IOTOK_VBAR);
GET_TOKEN(hcl); /* skip #[ */
while (TOKEN_TYPE(hcl) == HCL_IOTOK_IDENT)
{
sym = hcl_makesymbol (hcl, TOKEN_NAME_PTR(hcl), TOKEN_NAME_LEN(hcl));
if (!sym) return -1;
if (add_to_symbol_array_literal_buffer(hcl, sym) <= -1) return -1;
GET_TOKEN (hcl);
}
if (TOKEN_TYPE(hcl) != HCL_IOTOK_VBAR)
{
hcl_setsynerr (hcl, HCL_SYNERR_VBAR, TOKEN_LOC(hcl), TOKEN_NAME(hcl));
return -1;
}
sa = hcl_makearray (hcl, hcl->c->r.salit.size);
if (!sa)
{
hcl->c->r.salit.size = 0; /* reset literal count... */
return -1;
}
for (i = 0; i < hcl->c->r.salit.size; i++)
((hcl_oop_oop_t)sa)->slot[i] = hcl->c->r.salit.ptr[i];
/* switch array to symbol array. this is special-purpose. */
HCL_OBJ_SET_FLAGS_BRAND (sa, HCL_BRAND_SYMBOL_ARRAY);
*xlit = sa;
hcl->c->r.salit.size = 0; /* reset literal count... */
return 0;
}
@ -1455,7 +1531,7 @@ static int read_object (hcl_t* hcl)
/* this function read an s-expression non-recursively
* by manipulating its own stack. */
int level = 0, flagv = 0;
int level = 0, array_level = 0, flagv = 0;
hcl_oop_t obj;
while (1)
@ -1521,6 +1597,7 @@ static int read_object (hcl_t* hcl)
* a list literal or an array literal */
if (enter_list (hcl, flagv) == HCL_NULL) return -1;
level++;
if (flagv & ARRAY) array_level++;
/* read the next token */
GET_TOKEN (hcl);
@ -1541,6 +1618,8 @@ static int read_object (hcl_t* hcl)
goto redo;
case HCL_IOTOK_RPAREN:
{
int oldflagv;
if ((flagv & QUOTED) || level <= 0)
{
/* the right parenthesis can never appear while
@ -1564,15 +1643,27 @@ static int read_object (hcl_t* hcl)
return -1;
}
obj = leave_list (hcl, &flagv);
obj = leave_list (hcl, &flagv, &oldflagv);
level--;
if (oldflagv & ARRAY) array_level--;
break;
}
case HCL_IOTOK_BAPAREN:
if (get_byte_array_literal(hcl, &obj) <= -1) return -1;
break;
case HCL_IOTOK_VBAR:
/* TODO: think wheter to allow | | inside a quoted list... */
if (array_level > 0)
{
hcl_setsynerr (hcl, HCL_SYNERR_VBARBANNED, TOKEN_LOC(hcl), TOKEN_NAME(hcl));
return -1;
}
if (get_symbol_array_literal (hcl, &obj) <= -1) return -1;
break;
case HCL_IOTOK_NIL:
obj = hcl->_nil;
break;
@ -1622,6 +1713,8 @@ static int read_object (hcl_t* hcl)
/* check if the element is read for a quoted list */
while (flagv & QUOTED)
{
int oldflagv;
HCL_ASSERT (level > 0);
/* if so, append the element read into the quote list */
@ -1629,10 +1722,11 @@ static int read_object (hcl_t* hcl)
/* exit out of the quoted list. the quoted list can have
* one element only. */
obj = leave_list (hcl, &flagv);
obj = leave_list (hcl, &flagv, &oldflagv);
/* one level up toward the top */
level--;
if (oldflagv & ARRAY) array_level--;
}
/* check if we are at the top level */
@ -1648,6 +1742,7 @@ static int read_object (hcl_t* hcl)
/* upon exit, we must be at the top level */
HCL_ASSERT (level == 0);
HCL_ASSERT (array_level == 0);
hcl->c->r.e = obj;
return 0;
@ -1683,6 +1778,7 @@ static void gc_compiler (hcl_t* hcl)
hcl->c->r.s = hcl_moveoop (hcl, hcl->c->r.s);
hcl->c->r.e = hcl_moveoop (hcl, hcl->c->r.e);
for (i = 0; i <= hcl->c->cfs.top; i++)
{
hcl->c->cfs.ptr[i].operand = hcl_moveoop(hcl, hcl->c->cfs.ptr[i].operand);
@ -1692,6 +1788,12 @@ static void gc_compiler (hcl_t* hcl)
{
hcl->c->tv.ptr[i] = hcl_moveoop (hcl, hcl->c->tv.ptr[i]);
}
for (i = 0; i < hcl->c->r.salit.size; i++)
{
hcl->c->r.salit.ptr[i] = hcl_moveoop (hcl, hcl->c->r.salit.ptr[i]);
}
}
static void fini_compiler (hcl_t* hcl)
@ -1699,12 +1801,20 @@ static void fini_compiler (hcl_t* hcl)
/* called before the hcl object is closed */
if (hcl->c)
{
if (hcl->c->r.balit)
if (hcl->c->r.balit.ptr)
{
hcl_freemem (hcl, hcl->c->r.balit);
hcl->c->r.balit = HCL_NULL;
hcl->c->r.balit_count = 0;
hcl->c->r.balit_capa = 0;
hcl_freemem (hcl, hcl->c->r.balit.ptr);
hcl->c->r.balit.ptr = HCL_NULL;
hcl->c->r.balit.size = 0;
hcl->c->r.balit.capa = 0;
}
if (hcl->c->r.salit.ptr)
{
hcl_freemem (hcl, hcl->c->r.salit.ptr);
hcl->c->r.salit.ptr = HCL_NULL;
hcl->c->r.salit.size = 0;
hcl->c->r.salit.capa = 0;
}
if (hcl->c->cfs.ptr)