mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-03-10 07:00:20 -07:00
[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.
This commit is contained in:
Daniel Kochmański
parent
f993eda32f
commit
d766f74ab0
1 changed files with 178 additions and 75 deletions
253
src/c/nucl.c
253
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; aux<s->string.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; aux<s->string.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)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue