added some code to handle primitives and the call instruction
This commit is contained in:
3
hcl/configure
vendored
3
hcl/configure
vendored
@ -16910,7 +16910,8 @@ done
|
||||
|
||||
|
||||
|
||||
for ac_func in gettimeofday settimeofday clock_gettime clock_settime
|
||||
|
||||
for ac_func in gettimeofday settimeofday clock_gettime clock_settime getitimer setitimer
|
||||
do :
|
||||
as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh`
|
||||
ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var"
|
||||
|
||||
@ -130,7 +130,8 @@ dnl [],
|
||||
dnl [#include <stddef.h>])
|
||||
|
||||
dnl check functions
|
||||
AC_CHECK_FUNCS([gettimeofday settimeofday clock_gettime clock_settime])
|
||||
|
||||
AC_CHECK_FUNCS([gettimeofday settimeofday clock_gettime clock_settime getitimer setitimer])
|
||||
AC_CHECK_FUNCS([backtrace backtrace_symbols])
|
||||
AC_CHECK_FUNCS([makecontext swapcontext getcontext setcontext])
|
||||
AC_CHECK_FUNCS([snprintf _vsnprintf _vsnwprintf])
|
||||
|
||||
@ -40,6 +40,7 @@ libhcl_la_SOURCES = \
|
||||
heap.c \
|
||||
logfmt.c \
|
||||
obj.c \
|
||||
prim.c \
|
||||
print.c \
|
||||
rbt.c \
|
||||
read.c \
|
||||
|
||||
@ -132,8 +132,9 @@ am_libhcl_la_OBJECTS = libhcl_la-bigint.lo libhcl_la-comp.lo \
|
||||
libhcl_la-debug.lo libhcl_la-decode.lo libhcl_la-dic.lo \
|
||||
libhcl_la-exec.lo libhcl_la-gc.lo libhcl_la-hcl.lo \
|
||||
libhcl_la-heap.lo libhcl_la-logfmt.lo libhcl_la-obj.lo \
|
||||
libhcl_la-print.lo libhcl_la-rbt.lo libhcl_la-read.lo \
|
||||
libhcl_la-sym.lo libhcl_la-utf8.lo libhcl_la-utl.lo
|
||||
libhcl_la-prim.lo libhcl_la-print.lo libhcl_la-rbt.lo \
|
||||
libhcl_la-read.lo libhcl_la-sym.lo libhcl_la-utf8.lo \
|
||||
libhcl_la-utl.lo
|
||||
libhcl_la_OBJECTS = $(am_libhcl_la_OBJECTS)
|
||||
AM_V_lt = $(am__v_lt_@AM_V@)
|
||||
am__v_lt_ = $(am__v_lt_@AM_DEFAULT_V@)
|
||||
@ -392,6 +393,7 @@ libhcl_la_SOURCES = \
|
||||
heap.c \
|
||||
logfmt.c \
|
||||
obj.c \
|
||||
prim.c \
|
||||
print.c \
|
||||
rbt.c \
|
||||
read.c \
|
||||
@ -566,6 +568,7 @@ distclean-compile:
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libhcl_la-heap.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libhcl_la-logfmt.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libhcl_la-obj.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libhcl_la-prim.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libhcl_la-print.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libhcl_la-rbt.Plo@am__quote@
|
||||
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/libhcl_la-read.Plo@am__quote@
|
||||
@ -674,6 +677,13 @@ libhcl_la-obj.lo: obj.c
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
|
||||
@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libhcl_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libhcl_la-obj.lo `test -f 'obj.c' || echo '$(srcdir)/'`obj.c
|
||||
|
||||
libhcl_la-prim.lo: prim.c
|
||||
@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libhcl_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libhcl_la-prim.lo -MD -MP -MF $(DEPDIR)/libhcl_la-prim.Tpo -c -o libhcl_la-prim.lo `test -f 'prim.c' || echo '$(srcdir)/'`prim.c
|
||||
@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libhcl_la-prim.Tpo $(DEPDIR)/libhcl_la-prim.Plo
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='prim.c' object='libhcl_la-prim.lo' libtool=yes @AMDEPBACKSLASH@
|
||||
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
|
||||
@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libhcl_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o libhcl_la-prim.lo `test -f 'prim.c' || echo '$(srcdir)/'`prim.c
|
||||
|
||||
libhcl_la-print.lo: print.c
|
||||
@am__fastdepCC_TRUE@ $(AM_V_CC)$(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(libhcl_la_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT libhcl_la-print.lo -MD -MP -MF $(DEPDIR)/libhcl_la-print.Tpo -c -o libhcl_la-print.lo `test -f 'print.c' || echo '$(srcdir)/'`print.c
|
||||
@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/libhcl_la-print.Tpo $(DEPDIR)/libhcl_la-print.Plo
|
||||
|
||||
@ -65,10 +65,10 @@ static int add_literal (hcl_t* hcl, hcl_oop_t obj, hcl_oow_t* index)
|
||||
hcl_oow_t newcapa;
|
||||
|
||||
newcapa = capa + 20000; /* TODO: set a better resizing policy */
|
||||
tmp = hcl_remakengcarray (hcl, hcl->code.lit.arr, newcapa);
|
||||
tmp = hcl_remakengcarray (hcl, (hcl_oop_t)hcl->code.lit.arr, newcapa);
|
||||
if (!tmp) return -1;
|
||||
|
||||
hcl->code.lit.arr = tmp;
|
||||
hcl->code.lit.arr = (hcl_oop_oop_t)tmp;
|
||||
}
|
||||
|
||||
*index = hcl->code.lit.len;
|
||||
@ -536,7 +536,6 @@ static int push_subcframe (hcl_t* hcl, int opcode, hcl_oop_t operand)
|
||||
|
||||
enum
|
||||
{
|
||||
COP_EXIT,
|
||||
COP_COMPILE_OBJECT,
|
||||
COP_COMPILE_OBJECT_LIST,
|
||||
COP_COMPILE_ARGUMENT_LIST,
|
||||
@ -1209,9 +1208,6 @@ int hcl_compile (hcl_t* hcl, hcl_oop_t obj)
|
||||
|
||||
switch (cf->opcode)
|
||||
{
|
||||
case COP_EXIT:
|
||||
goto done;
|
||||
|
||||
case COP_COMPILE_OBJECT:
|
||||
if (compile_object (hcl) <= -1) goto oops;
|
||||
break;
|
||||
@ -1243,7 +1239,10 @@ int hcl_compile (hcl_t* hcl, hcl_oop_t obj)
|
||||
}
|
||||
}
|
||||
|
||||
done:
|
||||
/* emit the pop instruction to clear the final result */
|
||||
/* TODO: for interactive use, this value must be accessible by the executor... how to do it? */
|
||||
if (emit_byte_instruction (hcl, HCL_CODE_POP_STACKTOP) <= -1) goto oops;
|
||||
|
||||
HCL_ASSERT (GET_TOP_CFRAME_INDEX(hcl) < 0);
|
||||
HCL_ASSERT (hcl->c->tv.size == 0);
|
||||
HCL_ASSERT (hcl->c->blk.depth == 0);
|
||||
|
||||
@ -29,10 +29,10 @@
|
||||
|
||||
#define DECODE_LOG_MASK (HCL_LOG_MNEMONIC)
|
||||
|
||||
#define LOG_INST_0(hcl,fmt) HCL_LOG0(hcl, DECODE_LOG_MASK, "\t" fmt "\n")
|
||||
#define LOG_INST_1(hcl,fmt,a1) HCL_LOG1(hcl, DECODE_LOG_MASK, "\t" fmt "\n",a1)
|
||||
#define LOG_INST_2(hcl,fmt,a1,a2) HCL_LOG2(hcl, DECODE_LOG_MASK, "\t" fmt "\n", a1, a2)
|
||||
#define LOG_INST_3(hcl,fmt,a1,a2,a3) HCL_LOG3(hcl, DECODE_LOG_MASK, "\t" fmt "\n", a1, a2, a3)
|
||||
#define LOG_INST_0(hcl,fmt) HCL_LOG1(hcl, DECODE_LOG_MASK, "%010zd " fmt "\n", fetched_instruction_pointer)
|
||||
#define LOG_INST_1(hcl,fmt,a1) HCL_LOG2(hcl, DECODE_LOG_MASK, "%010zd " fmt "\n", fetched_instruction_pointer, a1)
|
||||
#define LOG_INST_2(hcl,fmt,a1,a2) HCL_LOG3(hcl, DECODE_LOG_MASK, "%010zd " fmt "\n", fetched_instruction_pointer, a1, a2)
|
||||
#define LOG_INST_3(hcl,fmt,a1,a2,a3) HCL_LOG4(hcl, DECODE_LOG_MASK, "%010zd " fmt "\n", fetched_instruction_pointer, a1, a2, a3)
|
||||
|
||||
#define FETCH_BYTE_CODE(hcl) (cdptr[ip++])
|
||||
#define FETCH_BYTE_CODE_TO(hcl,v_ooi) (v_ooi = FETCH_BYTE_CODE(hcl))
|
||||
@ -50,7 +50,7 @@
|
||||
int hcl_decode (hcl_t* hcl, hcl_ooi_t start, hcl_ooi_t end)
|
||||
{
|
||||
hcl_oob_t bcode, * cdptr;
|
||||
hcl_ooi_t ip = start;
|
||||
hcl_ooi_t ip = start, fetched_instruction_pointer;
|
||||
hcl_oow_t b1, b2;
|
||||
|
||||
/* the instruction at the offset 'end' is not decoded.
|
||||
@ -66,6 +66,7 @@ int hcl_decode (hcl_t* hcl, hcl_ooi_t start, hcl_ooi_t end)
|
||||
/* TODO: check if ip increases beyond bcode when fetching parameters too */
|
||||
while (ip < end)
|
||||
{
|
||||
fetched_instruction_pointer = ip;
|
||||
FETCH_BYTE_CODE_TO(hcl, bcode);
|
||||
|
||||
switch (bcode)
|
||||
@ -529,7 +530,7 @@ return -1;
|
||||
/* print literal frame contents */
|
||||
for (ip = 0; ip < hcl->code.lit.len; ip++)
|
||||
{
|
||||
LOG_INST_2 (hcl, " @%-3zd %O", ip, ((hcl_oop_oop_t)hcl->code.lit.arr)->slot[ip]);
|
||||
HCL_LOG2(hcl, DECODE_LOG_MASK, "@%-9zd %O\n", ip, ((hcl_oop_oop_t)hcl->code.lit.arr)->slot[ip]);
|
||||
}
|
||||
|
||||
return 0;
|
||||
|
||||
220
hcl/lib/exec.c
220
hcl/lib/exec.c
@ -110,10 +110,10 @@
|
||||
#if defined(HCL_DEBUG_VM_EXEC)
|
||||
# define LOG_MASK_INST (HCL_LOG_IC | HCL_LOG_MNEMONIC)
|
||||
|
||||
# define LOG_INST_0(hcl,fmt) HCL_LOG0(hcl, LOG_MASK_INST, "\t" fmt "\n")
|
||||
# define LOG_INST_1(hcl,fmt,a1) HCL_LOG1(hcl, LOG_MASK_INST, "\t" fmt "\n",a1)
|
||||
# define LOG_INST_2(hcl,fmt,a1,a2) HCL_LOG2(hcl, LOG_MASK_INST, "\t" fmt "\n", a1, a2)
|
||||
# define LOG_INST_3(hcl,fmt,a1,a2,a3) HCL_LOG3(hcl, LOG_MASK_INST, "\t" fmt "\n", a1, a2, a3)
|
||||
# define LOG_INST_0(hcl,fmt) HCL_LOG1(hcl, LOG_MASK_INST, "%010zd " fmt "\n", fetched_instruction_pointer)
|
||||
# define LOG_INST_1(hcl,fmt,a1) HCL_LOG2(hcl, LOG_MASK_INST, "%010zd " fmt "\n",fetched_instruction_pointer, a1)
|
||||
# define LOG_INST_2(hcl,fmt,a1,a2) HCL_LOG3(hcl, LOG_MASK_INST, "%010zd " fmt "\n", fetched_instruction_pointer, a1, a2)
|
||||
# define LOG_INST_3(hcl,fmt,a1,a2,a3) HCL_LOG4(hcl, LOG_MASK_INST, "%010zd " fmt "\n", fetched_instruction_pointer, a1, a2, a3)
|
||||
|
||||
#else
|
||||
# define LOG_INST_0(hcl,fmt)
|
||||
@ -267,7 +267,6 @@ static void vm_cleanup (hcl_t* hcl)
|
||||
|
||||
/* ------------------------------------------------------------------------- */
|
||||
|
||||
|
||||
static HCL_INLINE hcl_oop_t make_context (hcl_t* hcl, hcl_ooi_t ntmprs)
|
||||
{
|
||||
HCL_ASSERT (ntmprs >= 0);
|
||||
@ -867,6 +866,7 @@ static void update_sem_heap (hcl_t* hcl, hcl_ooi_t index, hcl_oop_semaphore_t ne
|
||||
else
|
||||
sift_down_sem_heap (hcl, index);
|
||||
}
|
||||
/* ------------------------------------------------------------------------- */
|
||||
|
||||
static int __activate_context (hcl_t* hcl, hcl_oop_context_t rcv_blkctx, hcl_ooi_t nargs, hcl_oop_context_t* pblkctx)
|
||||
{
|
||||
@ -898,18 +898,20 @@ static int __activate_context (hcl_t* hcl, hcl_oop_context_t rcv_blkctx, hcl_ooi
|
||||
* you can't send 'value' again to reactivate it.
|
||||
* For example, [thisContext value] value. */
|
||||
HCL_ASSERT (HCL_OBJ_GET_SIZE(rcv_blkctx) > HCL_CONTEXT_NAMED_INSTVARS);
|
||||
HCL_LOG1 (hcl, HCL_LOG_PRIMITIVE | HCL_LOG_ERROR,
|
||||
HCL_LOG1 (hcl, HCL_LOG_IC | HCL_LOG_ERROR,
|
||||
"Error - re-valuing of a block context - %O\n", rcv_blkctx);
|
||||
return 0;
|
||||
hcl->errnum = HCL_ERECALL;
|
||||
return -1;
|
||||
}
|
||||
HCL_ASSERT (HCL_OBJ_GET_SIZE(rcv_blkctx) == HCL_CONTEXT_NAMED_INSTVARS);
|
||||
|
||||
if (HCL_OOP_TO_SMOOI(rcv_blkctx->method_or_nargs) != nargs)
|
||||
{
|
||||
HCL_LOG3 (hcl, HCL_LOG_PRIMITIVE | HCL_LOG_ERROR,
|
||||
HCL_LOG3 (hcl, HCL_LOG_IC | HCL_LOG_ERROR,
|
||||
"Error - wrong number of arguments to a block context %O - expecting %zd, got %zd\n",
|
||||
rcv_blkctx, HCL_OOP_TO_SMOOI(rcv_blkctx->method_or_nargs), nargs);
|
||||
return 0;
|
||||
hcl->errnum = HCL_ECALLARG;
|
||||
return -1;
|
||||
}
|
||||
|
||||
/* the number of temporaries stored in the block context
|
||||
@ -917,7 +919,6 @@ static int __activate_context (hcl_t* hcl, hcl_oop_context_t rcv_blkctx, hcl_ooi
|
||||
* simple calculation is needed to find the number of local temporaries */
|
||||
local_ntmprs = HCL_OOP_TO_SMOOI(rcv_blkctx->ntmprs) -
|
||||
HCL_OOP_TO_SMOOI(((hcl_oop_context_t)rcv_blkctx->home)->ntmprs);
|
||||
printf ("%d %d\n", (int)local_ntmprs, (int)nargs);
|
||||
HCL_ASSERT (local_ntmprs >= nargs);
|
||||
|
||||
|
||||
@ -956,34 +957,46 @@ printf ("%d %d\n", (int)local_ntmprs, (int)nargs);
|
||||
blkctx->sender = hcl->active_context;
|
||||
|
||||
*pblkctx = blkctx;
|
||||
return 1;
|
||||
}
|
||||
|
||||
static int activate_context (hcl_t* hcl, hcl_ooi_t nargs)
|
||||
{
|
||||
int x;
|
||||
hcl_oop_context_t rcv_blkctx, blkctx;
|
||||
|
||||
rcv_blkctx = (hcl_oop_context_t)HCL_STACK_GETRCV(hcl, nargs);
|
||||
HCL_ASSERT (HCL_IS_CONTEXT (hcl, rcv_blkctx));
|
||||
#if 0
|
||||
if (HCL_CLASSOF(hcl, rcv_blkctx) != hcl->_block_context)
|
||||
{
|
||||
/* the receiver must be a block context */
|
||||
HCL_LOG1 (hcl, HCL_LOG_PRIMITIVE | HCL_LOG_ERROR,
|
||||
"Error - invalid receiver, not a block context - %O\n", rcv_blkctx);
|
||||
return 0;
|
||||
}
|
||||
#endif
|
||||
|
||||
x = __activate_context (hcl, rcv_blkctx, nargs, &blkctx);
|
||||
if (x <= 0) return x; /* hard failure and soft failure */
|
||||
static HCL_INLINE int activate_context (hcl_t* hcl, hcl_ooi_t nargs)
|
||||
{
|
||||
int x;
|
||||
hcl_oop_context_t rcv, blkctx;
|
||||
|
||||
rcv = (hcl_oop_context_t)HCL_STACK_GETRCV(hcl, nargs);
|
||||
HCL_ASSERT (HCL_IS_CONTEXT (hcl, rcv));
|
||||
|
||||
x = __activate_context (hcl, rcv, nargs, &blkctx);
|
||||
if (x <= -1) return -1;
|
||||
|
||||
SWITCH_ACTIVE_CONTEXT (hcl, (hcl_oop_context_t)blkctx);
|
||||
return 1;
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* ------------------------------------------------------------------------- */
|
||||
static HCL_INLINE int call_primitive (hcl_t* hcl, hcl_ooi_t nargs)
|
||||
{
|
||||
hcl_oop_word_t rcv;
|
||||
|
||||
rcv = (hcl_oop_word_t)HCL_STACK_GETRCV(hcl, nargs);
|
||||
HCL_ASSERT (HCL_IS_PRIM (hcl, rcv));
|
||||
|
||||
if (nargs < rcv->slot[1] && nargs > rcv->slot[2])
|
||||
{
|
||||
/* TODO: include a primitive name... */
|
||||
HCL_LOG3 (hcl, HCL_LOG_IC | HCL_LOG_ERROR,
|
||||
"Error - wrong number of arguments to a primitive - expecting %zd-%zd, got %zd\n",
|
||||
rcv->slot[1], rcv->slot[2], nargs);
|
||||
hcl->errnum = HCL_ECALLARG;
|
||||
return -1;
|
||||
}
|
||||
|
||||
return ((hcl_prim_impl_t)rcv->slot[0]) (hcl, nargs);
|
||||
}
|
||||
|
||||
/* ------------------------------------------------------------------------- */
|
||||
static hcl_oop_process_t start_initial_process (hcl_t* hcl, hcl_oop_context_t ctx)
|
||||
{
|
||||
hcl_oop_process_t proc;
|
||||
@ -1007,97 +1020,6 @@ static hcl_oop_process_t start_initial_process (hcl_t* hcl, hcl_oop_context_t ct
|
||||
return proc;
|
||||
}
|
||||
|
||||
static HCL_INLINE int activate_new_method (hcl_t* hcl, hcl_oop_method_t mth)
|
||||
{
|
||||
hcl_oop_context_t ctx;
|
||||
hcl_ooi_t i;
|
||||
hcl_ooi_t ntmprs, nargs;
|
||||
|
||||
ntmprs = HCL_OOP_TO_SMOOI(mth->tmpr_count);
|
||||
nargs = HCL_OOP_TO_SMOOI(mth->tmpr_nargs);
|
||||
|
||||
HCL_ASSERT (ntmprs >= 0);
|
||||
HCL_ASSERT (nargs <= ntmprs);
|
||||
|
||||
hcl_pushtmp (hcl, (hcl_oop_t*)&mth);
|
||||
ctx = (hcl_oop_context_t)make_context (hcl, ntmprs);
|
||||
hcl_poptmp (hcl);
|
||||
if (!ctx) return -1;
|
||||
|
||||
ctx->sender = hcl->active_context;
|
||||
ctx->ip = HCL_SMOOI_TO_OOP(0);
|
||||
/* ctx->sp will be set further down */
|
||||
|
||||
/* A context is compose of a fixed part and a variable part.
|
||||
* the variable part hold temporary varibles including arguments.
|
||||
*
|
||||
* Assuming a method context with 2 arguments and 3 local temporary
|
||||
* variables, the context will look like this.
|
||||
* +---------------------+
|
||||
* | fixed part |
|
||||
* | |
|
||||
* | |
|
||||
* | |
|
||||
* +---------------------+
|
||||
* | tmp1 (arg1) | slot[0]
|
||||
* | tmp2 (arg2) | slot[1]
|
||||
* | tmp3 | slot[2]
|
||||
* | tmp4 | slot[3]
|
||||
* | tmp5 | slot[4]
|
||||
* +---------------------+
|
||||
*/
|
||||
|
||||
ctx->ntmprs = HCL_SMOOI_TO_OOP(ntmprs);
|
||||
ctx->method_or_nargs = (hcl_oop_t)mth;
|
||||
/* the 'home' field of a method context is always hcl->_nil.
|
||||
ctx->home = hcl->_nil;*/
|
||||
ctx->origin = ctx; /* point to self */
|
||||
|
||||
/*
|
||||
* Assume this message sending expression:
|
||||
* obj1 do: #this with: #that with: #it
|
||||
*
|
||||
* It would be compiled to these logical byte-code sequences shown below:
|
||||
* push obj1
|
||||
* push #this
|
||||
* push #that
|
||||
* push #it
|
||||
* send #do:with:
|
||||
*
|
||||
* After three pushes, the stack looks like this.
|
||||
*
|
||||
* | #it | <- sp
|
||||
* | #that | sp - 1
|
||||
* | #this | sp - 2
|
||||
* | obj1 | sp - nargs
|
||||
*
|
||||
* Since the number of arguments is 3, stack[sp - 3] points to
|
||||
* the receiver. When the stack is empty, sp is -1.
|
||||
*/
|
||||
for (i = nargs; i > 0; )
|
||||
{
|
||||
/* copy argument */
|
||||
ctx->slot[--i] = HCL_STACK_GETTOP (hcl);
|
||||
HCL_STACK_POP (hcl);
|
||||
}
|
||||
/* copy receiver */
|
||||
ctx->receiver_or_source = HCL_STACK_GETTOP (hcl);
|
||||
HCL_STACK_POP (hcl);
|
||||
|
||||
HCL_ASSERT (hcl->sp >= -1);
|
||||
|
||||
/* the stack pointer in a context is a stack pointer of a process
|
||||
* before it is activated. this stack pointer is stored to the context
|
||||
* so that it is used to restore the process stack pointer upon returning
|
||||
* from a method context. */
|
||||
ctx->sp = HCL_SMOOI_TO_OOP(hcl->sp);
|
||||
|
||||
/* switch the active context to the newly instantiated one*/
|
||||
SWITCH_ACTIVE_CONTEXT (hcl, ctx);
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
static int start_initial_process_and_context (hcl_t* hcl)
|
||||
{
|
||||
hcl_oop_context_t ctx;
|
||||
@ -1147,25 +1069,10 @@ static int start_initial_process_and_context (hcl_t* hcl)
|
||||
hcl_poptmp (hcl);
|
||||
if (!proc) return -1;
|
||||
|
||||
|
||||
#if 0
|
||||
HCL_STACK_PUSH (hcl, ass->value); /* push the receiver - the object referenced by 'objname' */
|
||||
STORE_ACTIVE_SP (hcl); /* hcl->active_context->sp = HCL_SMOOI_TO_OOP(hcl->sp) */
|
||||
|
||||
HCL_ASSERT (hcl->processor->active == proc);
|
||||
HCL_ASSERT (hcl->processor->active->initial_context == ctx);
|
||||
HCL_ASSERT (hcl->processor->active->current_context == ctx);
|
||||
HCL_ASSERT (hcl->active_context == ctx);
|
||||
|
||||
/* emulate the message sending */
|
||||
return activate_new_method (hcl, mth);
|
||||
#else
|
||||
HCL_STACK_PUSH (hcl, (hcl_oop_t)ctx);
|
||||
STORE_ACTIVE_SP (hcl); /* hcl->active_context->sp = HCL_SMOOI_TO_OOP(hcl->sp) */
|
||||
|
||||
return activate_context (hcl, 0);
|
||||
#endif
|
||||
|
||||
}
|
||||
|
||||
/* ------------------------------------------------------------------------- */
|
||||
@ -1183,6 +1090,10 @@ static int execute (hcl_t* hcl)
|
||||
hcl_uintmax_t inst_counter = 0;
|
||||
#endif
|
||||
|
||||
#if defined(HCL_DEBUG_VM_EXEC)
|
||||
hcl_ooi_t fetched_instruction_pointer;
|
||||
#endif
|
||||
|
||||
HCL_ASSERT (hcl->active_context != HCL_NULL);
|
||||
|
||||
vm_startup (hcl);
|
||||
@ -1190,7 +1101,7 @@ static int execute (hcl_t* hcl)
|
||||
|
||||
while (1)
|
||||
{
|
||||
#if 0 /* XXX */
|
||||
|
||||
if (hcl->sem_heap_count > 0)
|
||||
{
|
||||
hcl_ntime_t ft, now;
|
||||
@ -1286,17 +1197,10 @@ if (there is semaphore awaited.... )
|
||||
#endif
|
||||
|
||||
hcl->proc_switched = 0;
|
||||
#else
|
||||
/* TODO: XXX this part is temporary. use if 0 part */
|
||||
if (hcl->processor->active == hcl->nil_process)
|
||||
{
|
||||
/* no more waiting semaphore and no more process */
|
||||
HCL_ASSERT (hcl->processor->tally = HCL_SMOOI_TO_OOP(0));
|
||||
HCL_LOG0 (hcl, HCL_LOG_IC | HCL_LOG_DEBUG, "No more runnable process\n");
|
||||
break;
|
||||
}
|
||||
#endif /* END XXX */
|
||||
|
||||
#if defined(HCL_DEBUG_VM_EXEC)
|
||||
fetched_instruction_pointer = hcl->ip;
|
||||
#endif
|
||||
FETCH_BYTE_CODE_TO (hcl, bcode);
|
||||
/*while (bcode == HCL_CODE_NOOP) FETCH_BYTE_CODE_TO (hcl, bcode);*/
|
||||
|
||||
@ -1630,11 +1534,31 @@ return -1;
|
||||
case HCL_CODE_CALL_1:
|
||||
case HCL_CODE_CALL_2:
|
||||
case HCL_CODE_CALL_3:
|
||||
{
|
||||
hcl_oop_t rcv;
|
||||
|
||||
handle_call:
|
||||
b1 = bcode & 0x3; /* low 2 bits */
|
||||
LOG_INST_1 (hcl, "call %zu", b1);
|
||||
/* TODO: CALL */
|
||||
|
||||
rcv = HCL_STACK_GETRCV (hcl, b1);
|
||||
if (HCL_IS_CONTEXT(hcl, rcv))
|
||||
{
|
||||
if (activate_context (hcl, b1) <= -1) return -1;
|
||||
}
|
||||
else if (HCL_IS_PRIM(hcl, rcv))
|
||||
{
|
||||
if (call_primitive (hcl, b1) <= -1) return -1;
|
||||
}
|
||||
else
|
||||
{
|
||||
/* run time error */
|
||||
HCL_LOG1 (hcl, HCL_LOG_IC | HCL_LOG_ERROR, "Error - cannot call %O\n", rcv);
|
||||
hcl->errnum = HCL_ECALL;
|
||||
return -1;
|
||||
}
|
||||
break;
|
||||
}
|
||||
|
||||
/* -------------------------------------------------------- */
|
||||
|
||||
|
||||
@ -500,7 +500,6 @@ int hcl_ignite (hcl_t* hcl)
|
||||
*(hcl_oop_t*)((hcl_uint8_t*)hcl + syminfo[i].offset) = tmp;
|
||||
}
|
||||
|
||||
|
||||
if (!hcl->nil_process)
|
||||
{
|
||||
/* Create a nil process used to simplify nil check in GC.
|
||||
@ -520,7 +519,7 @@ int hcl_ignite (hcl_t* hcl)
|
||||
|
||||
if (!hcl->code.bc.arr)
|
||||
{
|
||||
hcl->code.bc.arr = hcl_makengcbytearray (hcl, HCL_NULL, 20000); /* TODO: set a proper intial size */
|
||||
hcl->code.bc.arr = (hcl_oop_byte_t)hcl_makengcbytearray (hcl, HCL_NULL, 20000); /* TODO: set a proper intial size */
|
||||
if (!hcl->code.bc.arr) return -1;
|
||||
}
|
||||
|
||||
|
||||
@ -66,6 +66,9 @@
|
||||
/* Define to 1 if you have the `getcontext' function. */
|
||||
#undef HAVE_GETCONTEXT
|
||||
|
||||
/* Define to 1 if you have the `getitimer' function. */
|
||||
#undef HAVE_GETITIMER
|
||||
|
||||
/* Define to 1 if you have the `gettimeofday' function. */
|
||||
#undef HAVE_GETTIMEOFDAY
|
||||
|
||||
@ -96,6 +99,9 @@
|
||||
/* Define to 1 if you have the `setcontext' function. */
|
||||
#undef HAVE_SETCONTEXT
|
||||
|
||||
/* Define to 1 if you have the `setitimer' function. */
|
||||
#undef HAVE_SETITIMER
|
||||
|
||||
/* Define to 1 if you have the `settimeofday' function. */
|
||||
#undef HAVE_SETTIMEOFDAY
|
||||
|
||||
|
||||
@ -54,6 +54,10 @@
|
||||
#define HCL_DEBUG_GC
|
||||
#define HCL_DEBUG_VM_EXEC
|
||||
|
||||
/* allow the caller to drive process switching by calling
|
||||
* stix_switchprocess(). */
|
||||
#define HCL_EXTERNAL_PROCESS_SWITCH
|
||||
|
||||
/* limit the maximum object size such that:
|
||||
* 1. an index to an object field can be represented in a small integer.
|
||||
* 2. the maximum number of bits including bit-shifts can be represented
|
||||
@ -1077,11 +1081,10 @@ HCL_EXPORT int hcl_compile (
|
||||
);
|
||||
|
||||
/* ========================================================================= */
|
||||
/* exec.c */
|
||||
/* prim.c */
|
||||
/* ========================================================================= */
|
||||
int hcl_getprimno (
|
||||
hcl_t* hcl,
|
||||
const hcl_oocs_t* name
|
||||
int hcl_addbuiltinprims (
|
||||
hcl_t* hcl
|
||||
);
|
||||
|
||||
/* TODO: remove debugging functions */
|
||||
|
||||
@ -62,7 +62,10 @@ enum hcl_errnum_t
|
||||
HCL_EIOERR, /**< I/O error */
|
||||
HCL_EECERR, /**< encoding conversion error */
|
||||
HCL_EFINIS, /**< end of data/input/stream/etc */
|
||||
HCL_ESYNERR /** < syntax error */
|
||||
HCL_ESYNERR, /**< syntax error */
|
||||
HCL_ECALL, /**< runtime error - cannot call */
|
||||
HCL_ERECALL, /**< runtime error - cannot call again */
|
||||
HCL_ECALLARG /**< runtime error - wrong number of arguments to call */
|
||||
};
|
||||
typedef enum hcl_errnum_t hcl_errnum_t;
|
||||
|
||||
@ -466,80 +469,6 @@ struct hcl_class_t
|
||||
#define HCL_CLASS_MTHDIC_CLASS 1
|
||||
|
||||
|
||||
#if defined(HCL_USE_OBJECT_TRAILER)
|
||||
# define HCL_METHOD_NAMED_INSTVARS 8
|
||||
#else
|
||||
# define HCL_METHOD_NAMED_INSTVARS 9
|
||||
#endif
|
||||
typedef struct hcl_method_t hcl_method_t;
|
||||
typedef struct hcl_method_t* hcl_oop_method_t;
|
||||
struct hcl_method_t
|
||||
{
|
||||
HCL_OBJ_HEADER;
|
||||
|
||||
hcl_oop_class_t owner; /* Class */
|
||||
|
||||
hcl_oop_char_t name; /* Symbol, method name */
|
||||
|
||||
/* primitive number */
|
||||
hcl_oop_t preamble; /* SmallInteger */
|
||||
|
||||
hcl_oop_t preamble_data[2]; /* SmallInteger */
|
||||
|
||||
/* number of temporaries including arguments */
|
||||
hcl_oop_t tmpr_count; /* SmallInteger */
|
||||
|
||||
/* number of arguments in temporaries */
|
||||
hcl_oop_t tmpr_nargs; /* SmallInteger */
|
||||
|
||||
#if defined(HCL_USE_OBJECT_TRAILER)
|
||||
/* no code field is used */
|
||||
#else
|
||||
hcl_oop_byte_t code; /* ByteArray */
|
||||
#endif
|
||||
|
||||
hcl_oop_t source; /* TODO: what should I put? */
|
||||
|
||||
/* == variable indexed part == */
|
||||
hcl_oop_t slot[1]; /* it stores literals */
|
||||
};
|
||||
|
||||
/* The preamble field is composed of a 8-bit code and a 16-bit
|
||||
* index.
|
||||
*
|
||||
* The code can be one of the following values:
|
||||
* 0 - no special action
|
||||
* 1 - return self
|
||||
* 2 - return nil
|
||||
* 3 - return true
|
||||
* 4 - return false
|
||||
* 5 - return index.
|
||||
* 6 - return -index.
|
||||
* 7 - return instvar[index]
|
||||
* 8 - do primitive[index]
|
||||
* 9 - do named primitive[index]
|
||||
* 10 - exception handler
|
||||
*/
|
||||
#define HCL_METHOD_MAKE_PREAMBLE(code,index) ((((hcl_ooi_t)index) << 8) | ((hcl_ooi_t)code))
|
||||
#define HCL_METHOD_GET_PREAMBLE_CODE(preamble) (((hcl_ooi_t)preamble) & 0xFF)
|
||||
#define HCL_METHOD_GET_PREAMBLE_INDEX(preamble) (((hcl_ooi_t)preamble) >> 8)
|
||||
|
||||
#define HCL_METHOD_PREAMBLE_NONE 0
|
||||
#define HCL_METHOD_PREAMBLE_RETURN_RECEIVER 1
|
||||
#define HCL_METHOD_PREAMBLE_RETURN_NIL 2
|
||||
#define HCL_METHOD_PREAMBLE_RETURN_TRUE 3
|
||||
#define HCL_METHOD_PREAMBLE_RETURN_FALSE 4
|
||||
#define HCL_METHOD_PREAMBLE_RETURN_INDEX 5
|
||||
#define HCL_METHOD_PREAMBLE_RETURN_NEGINDEX 6
|
||||
#define HCL_METHOD_PREAMBLE_RETURN_INSTVAR 7
|
||||
#define HCL_METHOD_PREAMBLE_PRIMITIVE 8
|
||||
#define HCL_METHOD_PREAMBLE_NAMED_PRIMITIVE 9 /* index is an index to the symbol table */
|
||||
#define HCL_METHOD_PREAMBLE_EXCEPTION 10
|
||||
|
||||
/* the index is an 16-bit unsigned integer. */
|
||||
#define HCL_METHOD_PREAMBLE_INDEX_MIN 0x0000
|
||||
#define HCL_METHOD_PREAMBLE_INDEX_MAX 0xFFFF
|
||||
#define HCL_OOI_IN_PREAMBLE_INDEX_RANGE(num) ((num) >= HCL_METHOD_PREAMBLE_INDEX_MIN && (num) <= HCL_METHOD_PREAMBLE_INDEX_MAX)
|
||||
|
||||
#define HCL_CONTEXT_NAMED_INSTVARS 8
|
||||
typedef struct hcl_context_t hcl_context_t;
|
||||
@ -1031,8 +960,7 @@ enum hcl_log_mask_t
|
||||
HCL_LOG_MNEMONIC = (1 << 8), /* bytecode mnemonic */
|
||||
HCL_LOG_GC = (1 << 9),
|
||||
HCL_LOG_IC = (1 << 10), /* instruction cycle, fetch-decode-execute */
|
||||
HCL_LOG_PRIMITIVE = (1 << 11),
|
||||
HCL_LOG_APP = (1 << 12) /* hcl applications, set by hcl logging primitive */
|
||||
HCL_LOG_APP = (1 << 11) /* hcl applications, set by hcl logging primitive */
|
||||
};
|
||||
typedef enum hcl_log_mask_t hcl_log_mask_t;
|
||||
|
||||
@ -1059,7 +987,6 @@ typedef enum hcl_log_mask_t hcl_log_mask_t;
|
||||
#define HCL_INFO4(hcl,fmt,a1,a2,a3,a4) HCL_LOG4(hcl, HCL_LOG_INFO, fmt, a1, a2, a3, a4)
|
||||
#define HCL_INFO5(hcl,fmt,a1,a2,a3,a4,a5) HCL_LOG5(hcl, HCL_LOG_INFO, fmt, a1, a2, a3, a4, a5
|
||||
|
||||
|
||||
/* =========================================================================
|
||||
* HCL COMMON OBJECTS
|
||||
* ========================================================================= */
|
||||
@ -1079,6 +1006,7 @@ enum
|
||||
HCL_BRAND_SET,
|
||||
|
||||
HCL_BRAND_CFRAME,/* compiler frame */
|
||||
HCL_BRAND_PRIM,
|
||||
|
||||
HCL_BRAND_CONTEXT,
|
||||
HCL_BRAND_PROCESS,
|
||||
@ -1114,6 +1042,8 @@ typedef struct hcl_cons_t* hcl_oop_cons_t;
|
||||
#define HCL_IS_CONS(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_CONS)
|
||||
#define HCL_IS_ARRAY(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_ARRAY)
|
||||
|
||||
#define HCL_IS_PRIM(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_PRIM)
|
||||
|
||||
#define HCL_CONS_CAR(v) (((hcl_cons_t*)(v))->car)
|
||||
#define HCL_CONS_CDR(v) (((hcl_cons_t*)(v))->cdr)
|
||||
|
||||
@ -1121,6 +1051,8 @@ typedef struct hcl_cons_t* hcl_oop_cons_t;
|
||||
extern "C" {
|
||||
#endif
|
||||
|
||||
#define hcl_switchprocess(hcl) ((hcl)->switch_proc = 1)
|
||||
|
||||
HCL_EXPORT hcl_t* hcl_open (
|
||||
hcl_mmgr_t* mmgr,
|
||||
hcl_oow_t xtnsize,
|
||||
@ -1456,6 +1388,13 @@ HCL_EXPORT hcl_oop_t hcl_reversecons (
|
||||
hcl_oop_t cons
|
||||
);
|
||||
|
||||
HCL_EXPORT hcl_oop_t hcl_makeprim (
|
||||
hcl_t* hcl,
|
||||
hcl_prim_impl_t primimpl,
|
||||
hcl_oow_t minargs,
|
||||
hcl_oow_t maxargs
|
||||
);
|
||||
|
||||
#if defined(__cplusplus)
|
||||
}
|
||||
#endif
|
||||
|
||||
@ -272,6 +272,7 @@ static int put_oocs (hcl_t* hcl, hcl_oow_t mask, const hcl_ooch_t* ptr, hcl_oow_
|
||||
hcl->log.len += len;
|
||||
|
||||
hcl->log.last_mask = mask;
|
||||
|
||||
return 1; /* success */
|
||||
}
|
||||
|
||||
|
||||
173
hcl/lib/main.c
173
hcl/lib/main.c
@ -35,20 +35,36 @@
|
||||
#if defined(_WIN32)
|
||||
# include <windows.h>
|
||||
# include <tchar.h>
|
||||
# if defined(STIX_HAVE_CFG_H)
|
||||
# include <ltdl.h>
|
||||
# define USE_LTDL
|
||||
# endif
|
||||
#elif defined(__OS2__)
|
||||
# define INCL_DOSMODULEMGR
|
||||
# define INCL_DOSPROCESS
|
||||
# define INCL_DOSERRORS
|
||||
# include <os2.h>
|
||||
#elif defined(__MSDOS__)
|
||||
/* nothing to include */
|
||||
# include <time.h>
|
||||
# include <dos.h>
|
||||
#elif defined(macintosh)
|
||||
/* nothing to include */
|
||||
# include <Timer.h>
|
||||
#else
|
||||
# include <errno.h>
|
||||
# include <unistd.h>
|
||||
# include <ltdl.h>
|
||||
# define USE_LTDL
|
||||
|
||||
# if defined(HAVE_TIME_H)
|
||||
# include <time.h>
|
||||
# endif
|
||||
# if defined(HAVE_SYS_TIME_H)
|
||||
# include <sys/time.h>
|
||||
# endif
|
||||
# if defined(HAVE_SIGNAL_H)
|
||||
# include <signal.h>
|
||||
# endif
|
||||
#endif
|
||||
|
||||
|
||||
typedef struct bb_t bb_t;
|
||||
struct bb_t
|
||||
@ -337,10 +353,10 @@ static int write_all (int fd, const char* ptr, hcl_oow_t len)
|
||||
|
||||
if (wr <= -1)
|
||||
{
|
||||
/*if (errno == EAGAIN || errno == EWOULDBLOCK)
|
||||
if (errno == EAGAIN || errno == EWOULDBLOCK)
|
||||
{
|
||||
push it to internal buffers? before writing data just converted, need to write buffered data first.
|
||||
}*/
|
||||
continue;
|
||||
}
|
||||
return -1;
|
||||
}
|
||||
|
||||
@ -360,27 +376,30 @@ static void log_write (hcl_t* hcl, hcl_oow_t mask, const hcl_ooch_t* msg, hcl_oo
|
||||
hcl_bch_t buf[256];
|
||||
hcl_oow_t ucslen, bcslen, msgidx;
|
||||
int n;
|
||||
char ts[64];
|
||||
size_t tslen;
|
||||
struct tm tm, *tmp;
|
||||
time_t now;
|
||||
|
||||
|
||||
if (mask & HCL_LOG_GC) return; /* don't show gc logs */
|
||||
|
||||
/* TODO: beautify the log message.
|
||||
* do classification based on mask. */
|
||||
|
||||
{
|
||||
char ts[32];
|
||||
struct tm tm, *tmp;
|
||||
time_t now;
|
||||
|
||||
now = time(NULL);
|
||||
#if defined(__MSDOS__)
|
||||
tmp = localtime (&now);
|
||||
#else
|
||||
tmp = localtime_r (&now, &tm);
|
||||
#endif
|
||||
strftime (ts, sizeof(ts), "%Y-%m-%d %H:%M:%S %z ", tmp);
|
||||
|
||||
write_all (1, ts, strlen(ts));
|
||||
tslen = strftime (ts, sizeof(ts), "%Y-%m-%d %H:%M:%S %z ", tmp);
|
||||
if (tslen == 0)
|
||||
{
|
||||
strcpy (ts, "0000-00-00 00:00:00 +0000");
|
||||
tslen = 25;
|
||||
}
|
||||
if (write_all (1, ts, tslen) <= -1) write (1, "XXXX ", 5);
|
||||
|
||||
msgidx = 0;
|
||||
while (len > 0)
|
||||
@ -418,6 +437,121 @@ if (mask & HCL_LOG_GC) return; /* don't show gc logs */
|
||||
#endif
|
||||
}
|
||||
|
||||
/* ========================================================================= */
|
||||
|
||||
static hcl_t* g_hcl = HCL_NULL;
|
||||
|
||||
/* ========================================================================= */
|
||||
|
||||
|
||||
#if defined(__MSDOS__) && defined(_INTELC32_)
|
||||
static void (*prev_timer_intr_handler) (void);
|
||||
|
||||
#pragma interrupt(timer_intr_handler)
|
||||
static void timer_intr_handler (void)
|
||||
{
|
||||
/*
|
||||
_XSTACK *stk;
|
||||
int r;
|
||||
stk = (_XSTACK *)_get_stk_frame();
|
||||
r = (unsigned short)stk_ptr->eax;
|
||||
*/
|
||||
|
||||
/* The timer interrupt (normally) occurs 18.2 times per second. */
|
||||
if (g_hcl) hcl_switchprocess (g_hcl);
|
||||
_chain_intr(prev_timer_intr_handler);
|
||||
}
|
||||
|
||||
#elif defined(macintosh)
|
||||
|
||||
static TMTask g_tmtask;
|
||||
static ProcessSerialNumber g_psn;
|
||||
|
||||
#define TMTASK_DELAY 50 /* milliseconds if positive, microseconds(after negation) if negative */
|
||||
|
||||
static pascal void timer_intr_handler (TMTask* task)
|
||||
{
|
||||
if (g_hcl) hcl_switchprocess (g_hcl);
|
||||
WakeUpProcess (&g_psn);
|
||||
PrimeTime ((QElem*)&g_tmtask, TMTASK_DELAY);
|
||||
}
|
||||
|
||||
#else
|
||||
static void arrange_process_switching (int sig)
|
||||
{
|
||||
if (g_hcl) hcl_switchprocess (g_hcl);
|
||||
}
|
||||
#endif
|
||||
|
||||
static void setup_tick (void)
|
||||
{
|
||||
#if defined(__MSDOS__) && defined(_INTELC32_)
|
||||
|
||||
prev_timer_intr_handler = _dos_getvect (0x1C);
|
||||
_dos_setvect (0x1C, timer_intr_handler);
|
||||
|
||||
#elif defined(macintosh)
|
||||
|
||||
GetCurrentProcess (&g_psn);
|
||||
memset (&g_tmtask, 0, HCL_SIZEOF(g_tmtask));
|
||||
g_tmtask.tmAddr = NewTimerProc (timer_intr_handler);
|
||||
InsXTime ((QElem*)&g_tmtask);
|
||||
|
||||
PrimeTime ((QElem*)&g_tmtask, TMTASK_DELAY);
|
||||
|
||||
#elif defined(HAVE_SETITIMER) && defined(SIGVTALRM) && defined(ITIMER_VIRTUAL)
|
||||
struct itimerval itv;
|
||||
struct sigaction act;
|
||||
|
||||
sigemptyset (&act.sa_mask);
|
||||
act.sa_handler = arrange_process_switching;
|
||||
act.sa_flags = 0;
|
||||
sigaction (SIGVTALRM, &act, HCL_NULL);
|
||||
|
||||
itv.it_interval.tv_sec = 0;
|
||||
itv.it_interval.tv_usec = 100; /* 100 microseconds */
|
||||
itv.it_value.tv_sec = 0;
|
||||
itv.it_value.tv_usec = 100;
|
||||
setitimer (ITIMER_VIRTUAL, &itv, HCL_NULL);
|
||||
#else
|
||||
|
||||
# error UNSUPPORTED
|
||||
#endif
|
||||
}
|
||||
|
||||
static void cancel_tick (void)
|
||||
{
|
||||
#if defined(__MSDOS__) && defined(_INTELC32_)
|
||||
|
||||
_dos_setvect (0x1C, prev_timer_intr_handler);
|
||||
|
||||
#elif defined(macintosh)
|
||||
RmvTime ((QElem*)&g_tmtask);
|
||||
/*DisposeTimerProc (g_tmtask.tmAddr);*/
|
||||
|
||||
#elif defined(HAVE_SETITIMER) && defined(SIGVTALRM) && defined(ITIMER_VIRTUAL)
|
||||
struct itimerval itv;
|
||||
struct sigaction act;
|
||||
|
||||
itv.it_interval.tv_sec = 0;
|
||||
itv.it_interval.tv_usec = 0;
|
||||
itv.it_value.tv_sec = 0; /* make setitimer() one-shot only */
|
||||
itv.it_value.tv_usec = 0;
|
||||
setitimer (ITIMER_VIRTUAL, &itv, HCL_NULL);
|
||||
|
||||
sigemptyset (&act.sa_mask);
|
||||
act.sa_handler = SIG_IGN; /* ignore the signal potentially fired by the one-shot arrange above */
|
||||
act.sa_flags = 0;
|
||||
sigaction (SIGVTALRM, &act, HCL_NULL);
|
||||
|
||||
#else
|
||||
# error UNSUPPORTED
|
||||
#endif
|
||||
}
|
||||
|
||||
/* ========================================================================= */
|
||||
|
||||
|
||||
/* ========================================================================= */
|
||||
|
||||
|
||||
@ -556,6 +690,13 @@ int main (int argc, char* argv[])
|
||||
return -1;
|
||||
}
|
||||
|
||||
if (hcl_addbuiltinprims(hcl) <= -1)
|
||||
{
|
||||
printf ("cannot add builtin primitives - %d\n", hcl_geterrnum(hcl));
|
||||
hcl_close (hcl);
|
||||
return -1;
|
||||
}
|
||||
|
||||
xtn = hcl_getxtn (hcl);
|
||||
|
||||
#if defined(macintosh)
|
||||
@ -623,10 +764,14 @@ int main (int argc, char* argv[])
|
||||
|
||||
hcl_decode (hcl, 0, hcl->code.bc.len);
|
||||
HCL_LOG0 (hcl, HCL_LOG_MNEMONIC, "------------------------------------------\n");
|
||||
g_hcl = hcl;
|
||||
setup_tick ();
|
||||
if (hcl_execute (hcl) <= -1)
|
||||
{
|
||||
printf ("ERROR: cannot execute - %d\n", hcl_geterrnum(hcl));
|
||||
}
|
||||
cancel_tick();
|
||||
g_hcl = HCL_NULL;
|
||||
|
||||
|
||||
{
|
||||
|
||||
@ -429,7 +429,6 @@ hcl_oop_t hcl_makeset (hcl_t* hcl, hcl_oow_t inisize)
|
||||
|
||||
|
||||
|
||||
|
||||
/* ------------------------------------------------------------------------ *
|
||||
* NGC HANDLING
|
||||
* ------------------------------------------------------------------------ */
|
||||
|
||||
191
hcl/lib/prim.c
Normal file
191
hcl/lib/prim.c
Normal file
@ -0,0 +1,191 @@
|
||||
/*
|
||||
* $Id$
|
||||
*
|
||||
Copyright (c) 2014-2016 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"
|
||||
|
||||
struct prim_t
|
||||
{
|
||||
hcl_oow_t minargs;
|
||||
hcl_oow_t maxargs;
|
||||
hcl_prim_impl_t impl;
|
||||
|
||||
hcl_oow_t namelen;
|
||||
hcl_ooch_t name[10];
|
||||
|
||||
};
|
||||
typedef struct prim_t prim_t;
|
||||
|
||||
/* ------------------------------------------------------------------------- */
|
||||
|
||||
hcl_oop_t hcl_makeprim (hcl_t* hcl, hcl_prim_impl_t primimpl, hcl_oow_t minargs, hcl_oow_t maxargs)
|
||||
{
|
||||
hcl_oop_word_t obj;
|
||||
|
||||
obj = (hcl_oop_word_t)hcl_allocwordobj (hcl, HCL_BRAND_PRIM, HCL_NULL, 3);
|
||||
if (obj)
|
||||
{
|
||||
obj->slot[0] = (hcl_oow_t)primimpl;
|
||||
obj->slot[1] = minargs;
|
||||
obj->slot[2] = maxargs;
|
||||
}
|
||||
|
||||
return (hcl_oop_t)obj;
|
||||
}
|
||||
|
||||
/* ------------------------------------------------------------------------- */
|
||||
|
||||
static void log_char_object (hcl_t* hcl, hcl_oow_t mask, hcl_oop_char_t msg)
|
||||
{
|
||||
hcl_ooi_t n;
|
||||
hcl_oow_t rem;
|
||||
const hcl_ooch_t* ptr;
|
||||
|
||||
HCL_ASSERT (HCL_OBJ_GET_FLAGS_TYPE(msg) == HCL_OBJ_TYPE_CHAR);
|
||||
|
||||
rem = HCL_OBJ_GET_SIZE(msg);
|
||||
ptr = msg->slot;
|
||||
|
||||
start_over:
|
||||
while (rem > 0)
|
||||
{
|
||||
if (*ptr == '\0')
|
||||
{
|
||||
n = hcl_logbfmt (hcl, mask, "%C", *ptr);
|
||||
HCL_ASSERT (n == 1);
|
||||
rem -= n;
|
||||
ptr += n;
|
||||
goto start_over;
|
||||
}
|
||||
|
||||
n = hcl_logbfmt (hcl, mask, "%.*S", rem, ptr);
|
||||
if (n <= -1) break;
|
||||
if (n == 0)
|
||||
{
|
||||
/* to skip the unprinted character.
|
||||
* actually, this check is not needed because of '\0' skipping
|
||||
* at the beginning of the loop */
|
||||
n = hcl_logbfmt (hcl, mask, "%C", *ptr);
|
||||
HCL_ASSERT (n == 1);
|
||||
}
|
||||
rem -= n;
|
||||
ptr += n;
|
||||
}
|
||||
}
|
||||
|
||||
static int prim_log (hcl_t* hcl, hcl_ooi_t nargs)
|
||||
{
|
||||
/* TODO: accept log level */
|
||||
hcl_oop_t msg, level;
|
||||
hcl_oow_t mask;
|
||||
hcl_ooi_t k;
|
||||
|
||||
/*level = HCL_STACK_GET(hcl, hcl->sp - nargs + 1);
|
||||
if (!HCL_OOP_IS_SMOOI(level)) mask = HCL_LOG_APP | HCL_LOG_INFO;
|
||||
else mask = HCL_LOG_APP | HCL_OOP_TO_SMOOI(level);*/
|
||||
mask = HCL_LOG_APP | HCL_LOG_INFO; /* TODO: accept logging level .. */
|
||||
|
||||
for (k = 0; k < nargs; k++)
|
||||
{
|
||||
msg = HCL_STACK_GETARG (hcl, nargs, k);
|
||||
|
||||
if (msg == hcl->_nil || msg == hcl->_true || msg == hcl->_false)
|
||||
{
|
||||
goto dump_object;
|
||||
}
|
||||
else if (HCL_OOP_IS_POINTER(msg))
|
||||
{
|
||||
if (HCL_OBJ_GET_FLAGS_TYPE(msg) == HCL_OBJ_TYPE_CHAR)
|
||||
{
|
||||
log_char_object (hcl, mask, (hcl_oop_char_t)msg);
|
||||
}
|
||||
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;
|
||||
|
||||
_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;
|
||||
|
||||
for (i = 0; i < HCL_OBJ_GET_SIZE(msg); i++)
|
||||
{
|
||||
inner = ((hcl_oop_oop_t)msg)->slot[i];
|
||||
|
||||
if (i > 0) hcl_logbfmt (hcl, mask, " ");
|
||||
if (HCL_OOP_IS_POINTER(inner) &&
|
||||
HCL_OBJ_GET_FLAGS_TYPE(inner) == HCL_OBJ_TYPE_CHAR)
|
||||
{
|
||||
log_char_object (hcl, mask, (hcl_oop_char_t)inner);
|
||||
}
|
||||
else
|
||||
{
|
||||
hcl_logbfmt (hcl, mask, "%O", inner);
|
||||
}
|
||||
}
|
||||
}
|
||||
else goto dump_object;
|
||||
}
|
||||
else
|
||||
{
|
||||
dump_object:
|
||||
hcl_logbfmt (hcl, mask, "%O", msg);
|
||||
}
|
||||
}
|
||||
|
||||
HCL_STACK_SETRET (hcl, nargs, hcl->_nil);
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* ------------------------------------------------------------------------- */
|
||||
|
||||
static prim_t builtin_prims[] =
|
||||
{
|
||||
{ 0, HCL_TYPE_MAX(hcl_oow_t), prim_log, 3, { 'l','o','g' } }
|
||||
};
|
||||
|
||||
|
||||
int hcl_addbuiltinprims (hcl_t* hcl)
|
||||
{
|
||||
hcl_oow_t i;
|
||||
hcl_oop_t prim, name;
|
||||
|
||||
for (i = 0; i < HCL_COUNTOF(builtin_prims); i++)
|
||||
{
|
||||
prim = hcl_makeprim (hcl, builtin_prims[i].impl, builtin_prims[i].minargs, builtin_prims[i].maxargs);
|
||||
if (!prim) return -1;
|
||||
|
||||
hcl_pushtmp (hcl, &prim);
|
||||
name = hcl_makesymbol (hcl, builtin_prims[i].name, builtin_prims[i].namelen);
|
||||
hcl_poptmp (hcl);
|
||||
if (!name) return -1;
|
||||
|
||||
if (!hcl_putatsysdic (hcl, name, prim)) return -1;
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
@ -193,10 +193,11 @@ enum
|
||||
WORD_NIL,
|
||||
WORD_TRUE,
|
||||
WORD_FALSE,
|
||||
|
||||
|
||||
WORD_SET,
|
||||
|
||||
WORD_CFRAME,
|
||||
WORD_PRIM,
|
||||
|
||||
WORD_CONTEXT,
|
||||
WORD_PROCESS,
|
||||
WORD_PROCESS_SCHEDULER,
|
||||
@ -215,6 +216,7 @@ static struct
|
||||
|
||||
{ 6, { '#','<','S','E','T','>' } },
|
||||
{ 9, { '#','<','C','F','R','A','M','E','>' } },
|
||||
{ 7, { '#','<','P','R','I','M','>' } },
|
||||
{ 10, { '#','<','C','O','N','T','E','X','T','>' } },
|
||||
{ 10, { '#','<','P','R','O','C','E','S','S','>' } },
|
||||
{ 20, { '#','<','P','R','O','C','E','S','S','-','S','C','H','E','D','U','L','E','R','>' } },
|
||||
@ -470,6 +472,10 @@ next:
|
||||
OUTPUT_STRX (pr, word[WORD_CFRAME].ptr, word[WORD_CFRAME].len);
|
||||
break;
|
||||
|
||||
case HCL_BRAND_PRIM:
|
||||
OUTPUT_STRX (pr, word[WORD_PRIM].ptr, word[WORD_PRIM].len);
|
||||
break;
|
||||
|
||||
case HCL_BRAND_CONTEXT:
|
||||
OUTPUT_STRX (pr, word[WORD_CONTEXT].ptr, word[WORD_CONTEXT].len);
|
||||
break;
|
||||
|
||||
Reference in New Issue
Block a user