diff --git a/configure b/configure index 3b2e050..7808346 100755 --- a/configure +++ b/configure @@ -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" diff --git a/configure.ac b/configure.ac index 6ccdaf5..cb8c8a0 100644 --- a/configure.ac +++ b/configure.ac @@ -130,7 +130,8 @@ dnl [], dnl [#include ]) 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]) diff --git a/lib/Makefile.am b/lib/Makefile.am index 070fe73..60d42ce 100644 --- a/lib/Makefile.am +++ b/lib/Makefile.am @@ -40,6 +40,7 @@ libhcl_la_SOURCES = \ heap.c \ logfmt.c \ obj.c \ + prim.c \ print.c \ rbt.c \ read.c \ diff --git a/lib/Makefile.in b/lib/Makefile.in index cc587e0..d5a8174 100644 --- a/lib/Makefile.in +++ b/lib/Makefile.in @@ -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 diff --git a/lib/comp.c b/lib/comp.c index cccc059..753c306 100644 --- a/lib/comp.c +++ b/lib/comp.c @@ -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); diff --git a/lib/decode.c b/lib/decode.c index aa61167..4a68c9e 100644 --- a/lib/decode.c +++ b/lib/decode.c @@ -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; diff --git a/lib/exec.c b/lib/exec.c index 1974e68..601bb44 100644 --- a/lib/exec.c +++ b/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; + return 0; } -static int activate_context (hcl_t* hcl, hcl_ooi_t nargs) +static HCL_INLINE int activate_context (hcl_t* hcl, hcl_ooi_t nargs) { int x; - hcl_oop_context_t rcv_blkctx, blkctx; + hcl_oop_context_t rcv, 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 + rcv = (hcl_oop_context_t)HCL_STACK_GETRCV(hcl, nargs); + HCL_ASSERT (HCL_IS_CONTEXT (hcl, rcv)); - x = __activate_context (hcl, rcv_blkctx, nargs, &blkctx); - if (x <= 0) return x; /* hard failure and soft failure */ + 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; @@ -1255,12 +1166,12 @@ static int execute (hcl_t* hcl) HCL_ASSERT (hcl->processor->tally = HCL_SMOOI_TO_OOP(0)); HCL_LOG0 (hcl, HCL_LOG_IC | HCL_LOG_DEBUG, "No more runnable process\n"); -#if 0 -if (there is semaphore awaited.... ) -{ -/* DO SOMETHING */ -} -#endif + #if 0 + if (there is semaphore awaited.... ) + { + /* DO SOMETHING */ + } + #endif break; } @@ -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; + } /* -------------------------------------------------------- */ diff --git a/lib/gc.c b/lib/gc.c index 45f446f..ec46331 100644 --- a/lib/gc.c +++ b/lib/gc.c @@ -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; } diff --git a/lib/hcl-cfg.h.in b/lib/hcl-cfg.h.in index e160236..fa63888 100644 --- a/lib/hcl-cfg.h.in +++ b/lib/hcl-cfg.h.in @@ -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 diff --git a/lib/hcl-prv.h b/lib/hcl-prv.h index 36a63f6..b91f891 100644 --- a/lib/hcl-prv.h +++ b/lib/hcl-prv.h @@ -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 */ diff --git a/lib/hcl.h b/lib/hcl.h index 04034a7..38a236e 100644 --- a/lib/hcl.h +++ b/lib/hcl.h @@ -40,29 +40,32 @@ */ enum hcl_errnum_t { - HCL_ENOERR, /**< no error */ - HCL_EOTHER, /**< other error */ - HCL_ENOIMPL, /**< not implemented */ - HCL_ESYSERR, /**< subsystem error */ - HCL_EINTERN, /**< internal error */ - HCL_ESYSMEM, /**< insufficient system memory */ - HCL_EOOMEM, /**< insufficient object memory */ - HCL_EINVAL, /**< invalid parameter or data */ - HCL_ETOOBIG, /**< data too large */ - HCL_EPERM, /**< operation not permitted */ - HCL_ERANGE, /**< range error. overflow and underflow */ - HCL_ENOENT, /**< no matching entry */ - HCL_EEXIST, /**< duplicate entry */ - HCL_EBCFULL, /**< byte-code full */ - HCL_EDFULL, /**< dictionary full */ - HCL_EPFULL, /**< processor full */ - HCL_ESHFULL, /**< semaphore heap full */ - HCL_ESLFULL, /**< semaphore list full */ - HCL_EDIVBY0, /**< divide by zero */ - HCL_EIOERR, /**< I/O error */ - HCL_EECERR, /**< encoding conversion error */ - HCL_EFINIS, /**< end of data/input/stream/etc */ - HCL_ESYNERR /** < syntax error */ + HCL_ENOERR, /**< no error */ + HCL_EOTHER, /**< other error */ + HCL_ENOIMPL, /**< not implemented */ + HCL_ESYSERR, /**< subsystem error */ + HCL_EINTERN, /**< internal error */ + HCL_ESYSMEM, /**< insufficient system memory */ + HCL_EOOMEM, /**< insufficient object memory */ + HCL_EINVAL, /**< invalid parameter or data */ + HCL_ETOOBIG, /**< data too large */ + HCL_EPERM, /**< operation not permitted */ + HCL_ERANGE, /**< range error. overflow and underflow */ + HCL_ENOENT, /**< no matching entry */ + HCL_EEXIST, /**< duplicate entry */ + HCL_EBCFULL, /**< byte-code full */ + HCL_EDFULL, /**< dictionary full */ + HCL_EPFULL, /**< processor full */ + HCL_ESHFULL, /**< semaphore heap full */ + HCL_ESLFULL, /**< semaphore list full */ + HCL_EDIVBY0, /**< divide by zero */ + HCL_EIOERR, /**< I/O error */ + HCL_EECERR, /**< encoding conversion error */ + HCL_EFINIS, /**< end of data/input/stream/etc */ + 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; @@ -1028,11 +957,10 @@ enum hcl_log_mask_t HCL_LOG_ERROR = (1 << 3), HCL_LOG_FATAL = (1 << 4), - HCL_LOG_MNEMONIC = (1 << 8), /* bytecode mnemonic */ + 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 diff --git a/lib/logfmt.c b/lib/logfmt.c index 6151669..08a20ea 100644 --- a/lib/logfmt.c +++ b/lib/logfmt.c @@ -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 */ } diff --git a/lib/main.c b/lib/main.c index da60660..378e1a0 100644 --- a/lib/main.c +++ b/lib/main.c @@ -35,21 +35,37 @@ #if defined(_WIN32) # include # include +# if defined(STIX_HAVE_CFG_H) +# include +# define USE_LTDL +# endif #elif defined(__OS2__) # define INCL_DOSMODULEMGR # define INCL_DOSPROCESS # define INCL_DOSERRORS # include #elif defined(__MSDOS__) - /* nothing to include */ -# include +# include #elif defined(macintosh) - /* nothing to include */ +# include #else +# include # include -# include +# include +# define USE_LTDL + +# if defined(HAVE_TIME_H) +# include +# endif +# if defined(HAVE_SYS_TIME_H) +# include +# endif +# if defined(HAVE_SIGNAL_H) +# include +# 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; { diff --git a/lib/obj.c b/lib/obj.c index 04a5194..fc61b15 100644 --- a/lib/obj.c +++ b/lib/obj.c @@ -429,7 +429,6 @@ hcl_oop_t hcl_makeset (hcl_t* hcl, hcl_oow_t inisize) - /* ------------------------------------------------------------------------ * * NGC HANDLING * ------------------------------------------------------------------------ */ diff --git a/lib/prim.c b/lib/prim.c new file mode 100644 index 0000000..24fd604 --- /dev/null +++ b/lib/prim.c @@ -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; +} diff --git a/lib/print.c b/lib/print.c index 5954c14..c75f4bd 100644 --- a/lib/print.c +++ b/lib/print.c @@ -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;