From d766f74ab0dc1f500b756b690b78cdbc548a1af5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 29 May 2025 16:10:36 +0200 Subject: [PATCH] [nucl] allow calling into words and properly maintain the stack This commit takes a correction over things corrected (and rebased) in refactor-stacks branch. consturctors nucl_stack_to_foo remove elements from the stack and leave the parsed element on the stack. Move specials at the beginning. --- src/c/nucl.c | 253 ++++++++++++++++++++++++++++++++++++--------------- 1 file changed, 178 insertions(+), 75 deletions(-) diff --git a/src/c/nucl.c b/src/c/nucl.c index d229aec61..6dc2eef73 100644 --- a/src/c/nucl.c +++ b/src/c/nucl.c @@ -81,12 +81,64 @@ void smoke_bytecodes (void) ecl_stack_frame_close(f); } +/* -- Special variables ----------------------------------------------------- */ +#define DEFINE_SPECIAL(var,name,value) \ + static cl_object var = \ + ecl_cast_ptr(cl_object, &ecl_constexpr_symbol(ecl_stp_special, name, value)) + +DEFINE_SPECIAL(nucl_ostrm, "*ISTRM*", ECL_NIL); /* standard input */ +DEFINE_SPECIAL(nucl_istrm, "*OSTRM*", ECL_NIL); /* standard output */ +DEFINE_SPECIAL(nucl_fp, "*FP*", ECL_NIL); /* stack frame */ +DEFINE_SPECIAL(nucl_dt, "*DT*", ECL_NIL); /* dictionary */ + +/* -- Early printing routines ----------------------------------------------- */ cl_object ecl_make_nucl_stream(FILE *f); -/* -- Since now on we will often use the stack, so here are some operators - */ +void +init_nucl_io(void) +{ + const cl_env_ptr the_env = ecl_process_env(); + cl_object ostrm = ecl_make_nucl_stream(stdout); + cl_object istrm = ecl_make_nucl_stream(stdin); + ECL_SETQ(the_env, nucl_ostrm, ostrm); + ECL_SETQ(the_env, nucl_istrm, istrm); +} -/* GC won't catch pointers from constexpr symbols unless registered as root. */ -static cl_object nucl_fp = ecl_cast_ptr(cl_object,&(ecl_constexpr_symbol(ecl_stp_special, "*FP*", ECL_NIL))); +#define ECL_EOF ECL_DUMMY_TAG + +cl_object +nucl_stdout(void) +{ + const cl_env_ptr the_env = ecl_process_env(); + return ECL_SYM_VAL(the_env, nucl_ostrm); +} + + +cl_object +nucl_stdin(void) +{ + const cl_env_ptr the_env = ecl_process_env(); + return ECL_SYM_VAL(the_env, nucl_istrm); +} + +cl_object +nucl_write_cstr(cl_object strm, const char *s) +{ + while(*s != '\0') + si_write_char(strm, ECL_CODE_CHAR(*s++)); +} + +void +nucl_write_string(cl_object strm, cl_object s) +{ + int aux; + for(aux=0; auxstring.fillp; aux++) + (s->d.t == t_string) + ? si_write_char(strm, ECL_CODE_CHAR(s->string.self[aux])) + : si_write_char(strm, ECL_CODE_CHAR(s->base_string.self[aux])); +} + +/* -- Since now on we will often use the stack, so here are some operators - */ #define open_nucl_frame(name) \ const cl_env_ptr the_env = ecl_process_env(); \ @@ -109,25 +161,52 @@ nucl_stack_frame(void) static cl_index nucl_frame_size(cl_object fp) { - return fp->frame.size; + return fp->frame.sp - fp->frame.base; } -static void +static cl_index +nucl_stack_size(void) +{ + return nucl_frame_size(nucl_stack_frame()); +} + +static cl_object nucl_stack_push(cl_object object) { cl_object frame = nucl_stack_frame(); - frame->frame.size++; - frame->frame.sp++; ecl_stack_frame_push(frame, object); + return object; } static cl_object nucl_stack_pop(void) { cl_object frame = nucl_stack_frame(); - frame->frame.size--; - frame->frame.sp--; - return ECL_STACK_POP_UNSAFE(frame->frame.env); + return ecl_stack_frame_pop(frame); +} + +/* FIXME these functions work as expected, but if we use nucl_write_object, it + calls in turn si_nucl_write using ecl_return1 that changes values vector. */ +static cl_object +nucl_stack_from_values(void) +{ + cl_object frame = nucl_stack_frame(); + ecl_stack_frame_push_values(frame); +} + +static cl_object +nucl_stack_into_values(void) +{ + cl_object frame = nucl_stack_frame(); + ecl_stack_frame_pop_values(frame); +} + +static void +nucl_stack_clear(void) +{ + cl_object frame = nucl_stack_frame(); + cl_index size = nucl_frame_size(frame); + while(size--) ecl_stack_frame_pop(frame); } /* And constructors */ @@ -169,8 +248,20 @@ nucl_alloc_symbol(cl_object name, cl_object value) return x; } -cl_object -nucl_stack_to_string(void) +/* ( lisp* -- list ) */ +cl_object nucl_stack_to_list(void) +{ + cl_object frame = nucl_stack_frame(); + cl_object self = ECL_NIL; + loop_across_frame_filo(elt, frame) { + self = ecl_cons(elt, self); + } end_loop_across_frame(); + nucl_stack_clear(); + return nucl_stack_push(self); +} + +/* ( char* -- string ) */ +cl_object nucl_stack_to_string(void) { cl_object frame = nucl_stack_frame(); cl_index size = nucl_frame_size(frame), idx=0; @@ -178,26 +269,14 @@ nucl_stack_to_string(void) loop_across_frame_fifo(elt, frame) { self->base_string.self[idx++] = ECL_CHAR_CODE(elt); } end_loop_across_frame(); - return self; + nucl_stack_clear(); + return nucl_stack_push(self); } -cl_object -nucl_stack_to_list(void) +/* ( char* -- fixnum ) */ +cl_object nucl_stack_to_fixnum(void) { cl_object frame = nucl_stack_frame(); - cl_index size = nucl_frame_size(frame), idx=0; - cl_object self = ECL_NIL; - loop_across_frame_filo(elt, frame) { - self = ecl_cons(elt, self); - } end_loop_across_frame(); - return self; -} - -cl_object -nucl_stack_to_fixnum(void) -{ - cl_object frame = nucl_stack_frame(); - cl_index size = nucl_frame_size(frame); cl_object self = ECL_NIL; intmax_t acc = 0; int dig; @@ -214,14 +293,15 @@ nucl_stack_to_fixnum(void) if (acc>MOST_POSITIVE_FIXNUM) ecl_internal_error("Integer is too big!"); } end_loop_across_frame(); - return ecl_make_fixnum((cl_fixnum)acc); + nucl_stack_clear(); + self = ecl_make_fixnum((cl_fixnum)acc); + return nucl_stack_push(self); } -cl_object -nucl_stack_to_hexnum(void) +/* ( char* -- fixnum ) */ +cl_object nucl_stack_to_hexnum(void) { cl_object frame = nucl_stack_frame(); - cl_index size = nucl_frame_size(frame); cl_object self = ECL_NIL; intmax_t acc = 0; int dig; @@ -244,16 +324,37 @@ nucl_stack_to_hexnum(void) if (acc>MOST_POSITIVE_FIXNUM) ecl_internal_error("Integer is too big!"); } end_loop_across_frame(); - return ecl_make_fixnum((cl_fixnum)acc); + nucl_stack_clear(); + self = ecl_make_fixnum((cl_fixnum)acc); + return nucl_stack_push(self); } /* Yeah! */ cl_object nucl_call_word(int narg, cl_object op) { - const cl_env_ptr the_env = ecl_process_env(); - printf(">>> nucl_call_word: %p!\n", op); - ecl_return1(the_env, op); + cl_object strm = nucl_stdout(); + if (op == ECL_UNBOUND) + nucl_write_cstr(strm, ">>> nucl_call_word: undefined.\n"); + else + _ecl_funcall2(op->symbol.value, op); + return op; } -ecl_def_function(_nucl_call_word, nucl_call_word, static, const); + +cl_object nucl_word_df(int narg, cl_object op) { + cl_index size = nucl_stack_size(); + cl_object strm = nucl_stdout(); + nucl_write_cstr(strm, ">>> nucl_call_word: define word.\n"); + return ecl_make_fixnum(size); +} + +cl_object nucl_word_ps(int narg, cl_object op) { + cl_index size = nucl_stack_size(); + cl_object strm = nucl_stdout(); + nucl_write_cstr(strm, ">>> nucl_call_word: print stack.\n"); + return ecl_make_fixnum(size); +} + +ecl_def_function(_nucl_word_df, nucl_word_df, static, const); +ecl_def_function(_nucl_word_ps, nucl_word_ps, static, const); /* Our dictionary is based on symbols. Each symbol in a dictionary has a name @@ -262,11 +363,9 @@ ecl_def_function(_nucl_call_word, nucl_call_word, static, const); #define make_dict_entry(name,value) \ ecl_cast_ptr(cl_object, &ecl_constexpr_symbol(ecl_stp_special, name, value)) -static cl_object nucl_dt = make_dict_entry("*DT*", ECL_NIL); /* ha! */ - static cl_object nucl_dictionary_default_entries[] = { - make_dict_entry(":", _nucl_call_word), - make_dict_entry("!", _nucl_call_word), + make_dict_entry(":", _nucl_word_df), + make_dict_entry("!", _nucl_word_ps), NULL, }; @@ -325,32 +424,14 @@ nucl_extend_dictionary(cl_object name, cl_object value) return entry; } ecl_internal_error("sorry! allocate me."); - entry = nucl_alloc_symbol(name,value); /* make_dict_entry ends on a stack */ + /* Allocate on a heap, because make_dict_entry would allocate on a stack. */ + entry = nucl_alloc_symbol(name,value); ecl_stack_push(dict, entry); return entry; } /* -- Lali-ho I/O starts here ----------------------------------------------- */ -#define ECL_EOF ECL_DUMMY_TAG - -cl_object -nucl_write_cstr(cl_object strm, const char *s) -{ - while(*s != '\0') - si_write_char(strm, ECL_CODE_CHAR(*s++)); -} - -void -nucl_write_string(cl_object strm, cl_object s) -{ - int aux; - for(aux=0; auxstring.fillp; aux++) - (s->d.t == t_string) - ? si_write_char(strm, ECL_CODE_CHAR(s->string.self[aux])) - : si_write_char(strm, ECL_CODE_CHAR(s->base_string.self[aux])); -} - void nucl_write_fixnum(cl_object strm, cl_object s) { @@ -702,11 +783,15 @@ smoke_stream (void) void smoke_accept (void) { - cl_object ostrm = ecl_make_nucl_stream(stdout); - cl_object istrm = ecl_make_nucl_stream(stdin); - cl_object result = ECL_NIL; + cl_object ostrm, istrm, result; + + init_nucl_io(); init_nucl_reader(); init_nucl_dictionary(); + + ostrm = nucl_stdout(); + istrm = nucl_stdin(); + printf(">>> smoke_accept: readtable is %p\n", rtable); nucl_write_cstr(ostrm, "token> "); result = nucl_accept(istrm, ECL_NIL); @@ -718,27 +803,45 @@ smoke_accept (void) cl_object nucl_read_command (cl_object istrm) { - return limited_reader(istrm, ECL_CODE_CHAR('\n')); + cl_object result = limited_reader(istrm, ECL_CODE_CHAR('\n')); + nucl_stack_to_list(); + return result; +} + +cl_object nucl_exec_command (cl_object command) +{ + loop_for_on_unsafe(command) { + cl_object word = ECL_CONS_CAR(command); + if(ecl_t_of(word) == t_symbol) { + nucl_call_word(0, word); + } else { + nucl_stack_push(word); + } + } end_loop_for_on_unsafe (command); + return ECL_NIL; } void nucl_repl (void) { - cl_object ostrm = ecl_make_nucl_stream(stdout); - cl_object istrm = ecl_make_nucl_stream(stdin); - cl_object result = ECL_NIL, command = ECL_NIL; + cl_object result, command, ostrm, istrm; + cl_index idx; + init_nucl_io(); init_nucl_reader(); init_nucl_dictionary(); + + ostrm = nucl_stdout(); + istrm = nucl_stdin(); + + open_nucl_frame(frame); /* top level frame */ do { - open_nucl_frame(frame); /* top level frame */ nucl_write_cstr(ostrm, "nucl> "); result = nucl_read_command(istrm); - command = nucl_stack_to_list(); - nucl_write_cstr(ostrm, "... "); - nucl_write_object(ostrm, command); - nucl_write_cstr(ostrm, "\n"); - close_nucl_frame(frame); + command = nucl_stack_pop(); + nucl_exec_command(command); + nucl_write_cstr(ostrm, "... ok\n"); } while(result != ECL_EOF); - nucl_write_cstr(ostrm, "... exit\n"); + close_nucl_frame(frame); + nucl_write_cstr(ostrm, "... bye\n"); } void nucl_test (void)