mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2025-12-06 02:40:26 -08:00
[nucl] reorganize file and add "print stack" word
This commit is contained in:
Daniel Kochmański
parent
7bf3a380f3
commit
013075a8d7
1 changed files with 161 additions and 173 deletions
334
src/c/nucl.c
334
src/c/nucl.c
|
|
@ -81,6 +81,32 @@ void smoke_bytecodes (void)
|
|||
ecl_stack_frame_close(f);
|
||||
}
|
||||
|
||||
void nucl_test (void)
|
||||
{
|
||||
cl_env_ptr the_env = ecl_core.first_env;
|
||||
printf("\n[:handler t :restart t] -----------------------\n");
|
||||
ECL_CATCH_BEGIN(the_env, ecl_ct_resume_tag); {
|
||||
ecl_call_with_handler(_nucl_extinguisher, _nucl_flamethrower);
|
||||
} ECL_CATCH_END;
|
||||
printf("-----------------------------------------------\n\n");
|
||||
|
||||
printf("\n[:handler t :restart nil] ---------------------\n");
|
||||
ecl_call_with_handler(_nucl_extinguisher, _nucl_flamethrower);
|
||||
printf("-----------------------------------------------\n\n");
|
||||
|
||||
printf("\n[:handler nil] --------------------------------\n");
|
||||
nucl_flamethrower(0);
|
||||
printf("-----------------------------------------------\n\n");
|
||||
|
||||
cl_object handlers = ecl_cons_stack(_nucl_extinguisher, ECL_NIL);
|
||||
ECL_SETQ(the_env, ECL_SIGNAL_HANDLERS, handlers);
|
||||
|
||||
printf("\n[:bytecodes t] --------------------------------\n");
|
||||
smoke_bytecodes();
|
||||
printf("-----------------------------------------------\n\n");
|
||||
}
|
||||
|
||||
|
||||
/* -- Special variables ----------------------------------------------------- */
|
||||
#define DEFINE_SPECIAL(var,name,value) \
|
||||
static cl_object var = \
|
||||
|
|
@ -91,53 +117,7 @@ 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);
|
||||
|
||||
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);
|
||||
}
|
||||
|
||||
#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) \
|
||||
|
|
@ -329,56 +309,15 @@ cl_object nucl_stack_to_hexnum(void)
|
|||
return nucl_stack_push(self);
|
||||
}
|
||||
|
||||
/* Yeah! */
|
||||
cl_object nucl_call_word(int narg, cl_object 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;
|
||||
}
|
||||
|
||||
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
|
||||
and a value. We may need to rethink it at some point. */
|
||||
|
||||
#define make_dict_entry(name,value) \
|
||||
ecl_cast_ptr(cl_object, &ecl_constexpr_symbol(ecl_stp_special, name, value))
|
||||
|
||||
static cl_object nucl_dictionary_default_entries[] = {
|
||||
make_dict_entry(":", _nucl_word_df),
|
||||
make_dict_entry("!", _nucl_word_ps),
|
||||
NULL,
|
||||
};
|
||||
|
||||
/* -- Dictionary ------------------------------------------------------------ */
|
||||
|
||||
static void
|
||||
init_nucl_dictionary(void)
|
||||
{
|
||||
const cl_env_ptr the_env = ecl_process_env();
|
||||
cl_object dict = ecl_make_stack(2);
|
||||
cl_object dict = ecl_make_stack(0);
|
||||
ECL_SETQ(the_env, nucl_dt, dict);
|
||||
cl_object *iterator = nucl_dictionary_default_entries;
|
||||
for(; *iterator != NULL; iterator++) {
|
||||
ecl_stack_push(dict, *iterator);
|
||||
}
|
||||
}
|
||||
|
||||
static void
|
||||
|
|
@ -430,8 +369,65 @@ nucl_extend_dictionary(cl_object name, cl_object value)
|
|||
return entry;
|
||||
}
|
||||
|
||||
static cl_object
|
||||
nucl_append_dictionary(cl_object entry)
|
||||
{
|
||||
cl_env_ptr the_env = ecl_core.first_env;
|
||||
cl_object dict = ECL_SYM_VAL(the_env, nucl_dt);
|
||||
ecl_stack_push(dict, entry);
|
||||
return entry;
|
||||
}
|
||||
|
||||
|
||||
/* -- Lali-ho I/O starts here ----------------------------------------------- */
|
||||
|
||||
cl_object ecl_make_nucl_stream(FILE *f);
|
||||
|
||||
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);
|
||||
}
|
||||
|
||||
#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++));
|
||||
}
|
||||
|
||||
/* Ad-hoc printer */
|
||||
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)
|
||||
{
|
||||
|
|
@ -452,25 +448,6 @@ nucl_write_fixnum(cl_object strm, cl_object s)
|
|||
close_nucl_frame(frame);
|
||||
}
|
||||
|
||||
void
|
||||
nucl_read_until(cl_object strm, cl_fixnum delim)
|
||||
{
|
||||
cl_object frame = nucl_stack_frame();
|
||||
cl_object ch = ECL_NIL;
|
||||
while (!Null(ch = si_read_char(strm, ECL_NIL))) {
|
||||
nucl_stack_push(ch);
|
||||
if(ECL_CHAR_CODE(ch) == delim) break;
|
||||
}
|
||||
}
|
||||
|
||||
cl_object
|
||||
nucl_read_line(cl_object strm)
|
||||
{
|
||||
nucl_read_until(strm, '\n');
|
||||
return nucl_stack_to_string();
|
||||
}
|
||||
|
||||
/* Ad-hoc printer */
|
||||
cl_object
|
||||
nucl_write_object(cl_object strm, cl_object self)
|
||||
{
|
||||
|
|
@ -534,6 +511,24 @@ nucl_write_object(cl_object strm, cl_object self)
|
|||
}
|
||||
|
||||
/* Ad-hoc reader */
|
||||
void
|
||||
nucl_read_until(cl_object strm, cl_fixnum delim)
|
||||
{
|
||||
cl_object frame = nucl_stack_frame();
|
||||
cl_object ch = ECL_NIL;
|
||||
while (!Null(ch = si_read_char(strm, ECL_NIL))) {
|
||||
nucl_stack_push(ch);
|
||||
if(ECL_CHAR_CODE(ch) == delim) break;
|
||||
}
|
||||
}
|
||||
|
||||
cl_object
|
||||
nucl_read_line(cl_object strm)
|
||||
{
|
||||
nucl_read_until(strm, '\n');
|
||||
return nucl_stack_to_string();
|
||||
}
|
||||
|
||||
static cl_object rtable = ECL_NIL;
|
||||
static cl_object nucl_accept(cl_object strm, cl_object delim);
|
||||
|
||||
|
|
@ -765,40 +760,65 @@ nucl_accept(cl_object strm, cl_object delim)
|
|||
return result;
|
||||
}
|
||||
|
||||
void
|
||||
smoke_stream (void)
|
||||
{
|
||||
cl_object ostrm = ecl_make_nucl_stream(stdout);
|
||||
cl_object istrm = ecl_make_nucl_stream(stdin);
|
||||
cl_object line = ECL_NIL;
|
||||
char *string = "Hello World> ", c;
|
||||
int i;
|
||||
printf(">>> smoke_stream: stream is %p\n", ostrm);
|
||||
nucl_write_cstr(ostrm, string);
|
||||
line = nucl_read_line(istrm);
|
||||
nucl_write_object(ostrm, line);
|
||||
ecl_dealloc(line);
|
||||
|
||||
/* -- Default words --------------------------------------------------------- */
|
||||
cl_object nucl_call_word(int narg, cl_object op) {
|
||||
cl_object strm = nucl_stdout();
|
||||
(op == ECL_UNBOUND)
|
||||
? nucl_write_cstr(strm, ">>> nucl_call_word: undefined.\n")
|
||||
: _ecl_funcall2(op->symbol.value, op);
|
||||
return op;
|
||||
}
|
||||
|
||||
void
|
||||
smoke_accept (void)
|
||||
{
|
||||
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);
|
||||
nucl_write_object(ostrm, result);
|
||||
printf("\n");
|
||||
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 ssize = nucl_stack_size();
|
||||
cl_object size = ecl_make_fixnum(ssize);
|
||||
cl_object strm = nucl_stdout();
|
||||
cl_object frame = nucl_stack_frame();
|
||||
nucl_write_cstr(strm, "[");
|
||||
nucl_write_object(strm, size);
|
||||
nucl_write_cstr(strm, "] ");
|
||||
loop_across_frame_fifo(elt, frame) {
|
||||
nucl_write_object(strm, elt);
|
||||
if(--size) nucl_write_cstr(strm, " ");
|
||||
} end_loop_across_frame();
|
||||
return 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
|
||||
and a value. We may need to rethink it at some point. */
|
||||
|
||||
#define make_dict_entry(name,value) \
|
||||
ecl_cast_ptr(cl_object, &ecl_constexpr_symbol(ecl_stp_special, name, value))
|
||||
|
||||
static cl_object nucl_dictionary_default_entries[] = {
|
||||
make_dict_entry(":", _nucl_word_df),
|
||||
make_dict_entry("!", _nucl_word_ps),
|
||||
NULL,
|
||||
};
|
||||
|
||||
void init_nucl_dictionary_entries()
|
||||
{
|
||||
const cl_env_ptr the_env = ecl_process_env();
|
||||
cl_object dict = ECL_SYM_VAL(the_env, nucl_dt);
|
||||
cl_object *iterator = nucl_dictionary_default_entries;
|
||||
for(; *iterator != NULL; iterator++) {
|
||||
ecl_stack_push(dict, *iterator);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
/* -- REPL ------------------------------------------------------------------ */
|
||||
|
||||
cl_object nucl_read_command (cl_object istrm)
|
||||
|
|
@ -828,6 +848,7 @@ void nucl_repl (void)
|
|||
init_nucl_io();
|
||||
init_nucl_reader();
|
||||
init_nucl_dictionary();
|
||||
init_nucl_dictionary_entries();
|
||||
|
||||
ostrm = nucl_stdout();
|
||||
istrm = nucl_stdin();
|
||||
|
|
@ -844,39 +865,6 @@ void nucl_repl (void)
|
|||
nucl_write_cstr(ostrm, "... bye\n");
|
||||
}
|
||||
|
||||
void nucl_test (void)
|
||||
{
|
||||
cl_env_ptr the_env = ecl_core.first_env;
|
||||
printf("\n[:handler t :restart t] -----------------------\n");
|
||||
ECL_CATCH_BEGIN(the_env, ecl_ct_resume_tag); {
|
||||
ecl_call_with_handler(_nucl_extinguisher, _nucl_flamethrower);
|
||||
} ECL_CATCH_END;
|
||||
printf("-----------------------------------------------\n\n");
|
||||
|
||||
printf("\n[:handler t :restart nil] ---------------------\n");
|
||||
ecl_call_with_handler(_nucl_extinguisher, _nucl_flamethrower);
|
||||
printf("-----------------------------------------------\n\n");
|
||||
|
||||
printf("\n[:handler nil] --------------------------------\n");
|
||||
nucl_flamethrower(0);
|
||||
printf("-----------------------------------------------\n\n");
|
||||
|
||||
cl_object handlers = ecl_cons_stack(_nucl_extinguisher, ECL_NIL);
|
||||
ECL_SETQ(the_env, ECL_SIGNAL_HANDLERS, handlers);
|
||||
|
||||
printf("\n[:bytecodes t] --------------------------------\n");
|
||||
smoke_bytecodes();
|
||||
printf("-----------------------------------------------\n\n");
|
||||
|
||||
printf("\n[:stream t] --------------------------------\n");
|
||||
smoke_stream();
|
||||
printf("-----------------------------------------------\n\n");
|
||||
|
||||
printf("\n[:accept t] --------------------------------\n");
|
||||
smoke_accept();
|
||||
printf("-----------------------------------------------\n\n");
|
||||
}
|
||||
|
||||
int main() {
|
||||
cl_env_ptr the_env = ecl_core.first_env;
|
||||
ecl_boot();
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue