mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2025-12-06 02:40:26 -08:00
Code Issues Projects Releases Packages Wiki Activity

nucleus: introduce a table with early symbols ecl_symbols

Browse source 
This table contains symbols that are essential to the core runtime: ECL_T,
ECL_UNBOUND, ECL_SIGNAL_HANDLERS, ECL_RESTART_CLUSTERs, ECL_INTERRUPTS_ENABLED,
ECL_ALLOW_OTHER_KEYS and ECL_UNBOUND.

The table is initialized with constexpr, so it is possible to use its elements
in static elements. We also add ecl_def_function to ecl-inl to allow
appropriating C functions into Lisp world at top level.
This commit is contained in:
Daniel Kochmański 2024-12-10 13:24:21 +01:00
parent 0fa2095bd8
commit f41fb2ae38
16 changed files with 120 additions and 59 deletions
Download patch file Download diff file Expand all files Collapse all files

4
src/c/all_symbols.d
View file

@ -292,8 +292,8 @@ init_all_symbols(void)
cl_object s, value;
cl_objectfn fun;
/* We skip NIL and T */
for (i = 2; cl_symbols[i].init.name != NULL; i++) {
/* We skip ECL_NIL_SYMBOL */
for (i = 1; cl_symbols[i].init.name != NULL; i++) {
s = (cl_object)(cl_symbols + i);
code = cl_symbols[i].init.type;
name = cl_symbols[i].init.name;

18
src/c/boot.d
View file

@ -58,9 +58,21 @@ ecl_def_ct_ratio(ecl_ct_minus_half,ecl_make_fixnum(-1),ecl_make_fixnum(2),,const
ecl_def_constant(ecl_ct_protect_tag, ECL_NIL, "PROTECT-TAG", 11);
ecl_def_constant(ecl_ct_dummy_tag, ECL_NIL, "DUMMY-TAG", 9);
/* This variable is a stack with functions that are called for raised exceptions
and signaled conditions. */
ecl_def_variable(ecl_vr_shandlers, ECL_NIL, "*SIGNAL-HANDLERS*", 17);
struct ecl_symbol
ecl_symbols[] = {
/* This variable contains handlers for signals and exceptions. */
ecl_constexpr_symbol(ecl_stp_special, "*SIGNAL-HANDLERS*", ECL_NIL),
/* Restart clusters allow us to estabilish selectable correction actions. */
ecl_constexpr_symbol(ecl_stp_special, "*RESTART-CLUSTERS*", ECL_NIL),
/* This variable allows for interrupting sygnals from Lisp.. */
ecl_constexpr_symbol(ecl_stp_special, "*INTERRUPTS-ENABLED*", ECL_T),
/* OP_PUSHKEYS handles specially :ALLOW-OTHER-KEYS (per CL semantics). */
ecl_constexpr_symbol(ecl_stp_constant, "ALLOW-OTHER-KEYS", ECL_ALLOW_OTHER_KEYS),
/* The universal truth, the supertype of all, the class above classes. */
ecl_constexpr_symbol(ecl_stp_constant, "T", ECL_T),
/* The marker for unbound slots. This is more a tag than a symbol. */
ecl_constexpr_symbol(ecl_stp_constant, "UNBOUND", ECL_UNBOUND),
};
/* -- implementation ------------------------------------------------ */

2
src/c/cinit.d
View file

@ -68,7 +68,7 @@ si_bind_simple_restarts(cl_object tag, cl_object names)
if (ECL_FBOUNDP(@'si::bind-simple-restarts'))
return _ecl_funcall3(@'si::bind-simple-restarts', tag, names);
else
return ECL_SYM_VAL(ecl_process_env(), @'si::*restart-clusters*');
return ECL_SYM_VAL(ecl_process_env(), ECL_RESTART_CLUSTERS);
}
extern cl_object

5
src/c/cmpaux.d
View file

@ -180,7 +180,7 @@ cl_parse_key(
}
}
/* the key is a new one */
if (keyword == @':allow-other-keys') {
if (keyword == ECL_ALLOW_OTHER_KEYS) {
if (supplied_allow_other_keys == OBJNULL)
supplied_allow_other_keys = value;
} else if (unknown_keyword == OBJNULL)
@ -193,7 +193,8 @@ cl_parse_key(
(supplied_allow_other_keys == ECL_NIL ||
supplied_allow_other_keys == OBJNULL))) {
for (i = 0; i < nkey; i++) {
if (keys[i] == @':allow-other-keys' && vars[nkey+i] == ECL_T && !Null(vars[i])) {
if (keys[i] == ECL_ALLOW_OTHER_KEYS && vars[nkey+i] == ECL_T
&& !Null(vars[i])) {
return;
}
}

4
src/c/interpreter.d
View file

@ -717,12 +717,12 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes)
ptr = ECL_STACK_FRAME_PTR(frame) + frame_index;
end = ptr + limit;
for (; ptr != end; ptr++) {
if (*(ptr++) == @':allow-other-keys') {
if (*(ptr++) == ECL_ALLOW_OTHER_KEYS) {
aok = *ptr;
count -= 2;
/* only the first :allow-other-keys argument is considered */
for (ptr++; ptr != end; ptr++) {
if (*(ptr++) != @':allow-other-keys')
if (*(ptr++) != ECL_ALLOW_OTHER_KEYS)
break;
count -= 2;
}

66
src/c/main.d
View file

@ -146,6 +146,42 @@ maybe_fix_console_stream(cl_object stream)
}
#endif
static void
init_early_symbol(cl_object symbol, cl_object package) {
symbol->symbol.undef_entry = ecl_undefined_function_entry;
ECL_FMAKUNBOUND(symbol);
cl_import2(symbol, package);
cl_export2(symbol, package);
}
static void
init_ecl_symbols()
{
init_early_symbol(ECL_SIGNAL_HANDLERS, cl_core.system_package);
init_early_symbol(ECL_RESTART_CLUSTERS, cl_core.system_package);
init_early_symbol(ECL_INTERRUPTS_ENABLED, cl_core.system_package);
init_early_symbol(ECL_T, cl_core.lisp_package);
init_early_symbol(ECL_UNBOUND, cl_core.system_package);
/* SYSTEM:UNBOUND has an associated function si_unbound that returns it. */
ECL_SYM_FUN(ECL_UNBOUND)
= ecl_make_cfun((cl_objectfn_fixed)si_unbound, ECL_UNBOUND, NULL, 0);
/* Initialize the :ALLOW-OTHER-KEYS symbol (it is not part of cl_symbols). */
{
cl_object p = cl_core.keyword_package;
cl_object s = ECL_ALLOW_OTHER_KEYS;
cl_object n = s->symbol.name;
ECL_SET(s, OBJNULL);
ECL_FMAKUNBOUND(s);
s->symbol.hpack = p;
s->symbol.undef_entry = ecl_undefined_function_entry;
ecl_symbol_type_set(s, ecl_symbol_type(s) | ecl_stp_constant);
ECL_SET(s, s);
p->pack.external = _ecl_sethash(n, p->pack.external, s);
}
}
int
cl_boot(int argc, char **argv)
{
@ -174,7 +210,7 @@ cl_boot(int argc, char **argv)
/*
* Initialize the per-thread data.
* This cannot come later, because we need to be able to bind
* ext::*interrupts-enabled* while creating packages.
* ECL_INTERRUPTS_ENABLED while creating packages.
*/
env = ecl_core.first_env;
@ -202,22 +238,6 @@ cl_boot(int argc, char **argv)
#endif
cl_num_symbols_in_core=1;
ECL_T->symbol.t = (short)t_symbol;
ECL_T->symbol.value = ECL_T;
ECL_T->symbol.name = str_T;
ECL_T->symbol.cname = ECL_NIL;
ECL_FMAKUNBOUND(ECL_T);
ECL_T->symbol.sfdef = ECL_NIL;
ECL_T->symbol.macfun = ECL_NIL;
ECL_T->symbol.plist = ECL_NIL;
ECL_T->symbol.hpack = ECL_NIL;
ECL_T->symbol.stype = ecl_stp_constant;
ECL_T->symbol.undef_entry = ecl_undefined_function_entry;
#ifdef ECL_THREADS
ECL_T->symbol.binding = ECL_MISSING_SPECIAL_BINDING;
#endif
cl_num_symbols_in_core=2;
cl_core.gensym_prefix = (cl_object)&str_G_data;
cl_core.gentemp_prefix = (cl_object)&str_T_data;
@ -277,19 +297,15 @@ cl_boot(int argc, char **argv)
cl_import2(ECL_NIL, cl_core.lisp_package);
cl_export2(ECL_NIL, cl_core.lisp_package);
ECL_T->symbol.hpack = cl_core.lisp_package;
cl_import2(ECL_T, cl_core.lisp_package);
cl_export2(ECL_T, cl_core.lisp_package);
/* At exit, clean up */
atexit(cl_shutdown);
/* These must come _after_ the packages and NIL/T have been created */
/* These must come _after_ the packages have been created */
init_ecl_symbols();
init_all_symbols();
/* Initialize the handler stack with the exception handler. */
cl_import2(ECL_SIGNAL_HANDLERS, cl_core.system_package);
cl_export2(ECL_SIGNAL_HANDLERS, cl_core.system_package);
/* Set the default exception handler that coerces exceptions to conditions
that are understood by the condition system. */
ECL_SET(ECL_SIGNAL_HANDLERS, ecl_list1(ECL_SYM_FUN(@'si::exception-handler')));
/*

9
src/c/mem_gc.d
View file

@ -85,11 +85,11 @@ out_of_memory(size_t requested_bytes)
int interrupts = the_env->disable_interrupts;
int method = 0;
void *output;
/* Disable interrupts only with the ext::*interrupts-enabled*
* mechanism to allow for writes in the thread local environment */
/* Disable interrupts only with the ECL_INTERRUPTS_ENABLED mechanism to allow
* for writes in the thread local environment */
if (interrupts)
ecl_enable_interrupts_env(the_env);
ecl_bds_bind(the_env, @'ext::*interrupts-enabled*', ECL_NIL);
ecl_bds_bind(the_env, ECL_INTERRUPTS_ENABLED, ECL_NIL);
/* Free the input / output buffers */
the_env->string_pool = ECL_NIL;
@ -1165,7 +1165,8 @@ stacks_scanner()
} end_loop_for_on_unsafe(l);
/* ECL runtime */
GC_push_all((void *)(&ecl_core), (void *)(&ecl_core + 1));
GC_push_all((void *)ecl_vr_shandlers, (void *)(ecl_vr_shandlers + 1));
GC_push_all((void *)(ECL_SIGNAL_HANDLERS),
(void *)(ECL_SIGNAL_HANDLERS + 1));
/* Common Lisp */
GC_push_all((void *)(&cl_core), (void *)(&cl_core + 1));
GC_push_all((void *)cl_symbols, (void *)(cl_symbols + cl_num_symbols_in_core));

2
src/c/pathname.d
View file

@ -562,7 +562,7 @@ ecl_parse_namestring(cl_object s, cl_index start, cl_index end, cl_index *ep,
bool logical;
if (start == end) {
host = device = path = name = type = aux = version = @'nil';
host = device = path = name = type = aux = version = ECL_NIL;
logical = 0;
*ep = end;
goto make_it;

2
src/c/read.d
View file

@ -1718,7 +1718,7 @@ do_read_delimited_list(int d, cl_object in, bool proper_list)
@(return ECL_CODE_CHAR(c));
}
} else if (f == ECL_LISTEN_NO_CHAR) {
@(return @'nil');
@(return ECL_NIL);
}
/* We reach here if there was an EOF */
END_OF_FILE:

2
src/c/symbol.d
View file

@ -159,7 +159,7 @@ ecl_cmp_symbol_value(cl_env_ptr the_env, cl_object s)
#ifndef ECL_FINAL
/* Symbols are not initialized yet. This test is issued only during ECL
compilation to ensure, that we have no early references in the core. */
if(cl_num_symbols_in_core < 3) {
if(cl_num_symbols_in_core < 2) {
ecl_internal_error("SYMBOL-VALUE: symbols are not initialized yet.");
}
#endif

5
src/c/symbols_list.h
View file

@ -102,10 +102,6 @@ cl_symbol_initializer
cl_symbols[] = {
{"NIL" ECL_FUN(NULL, NULL, -1) ECL_VAR(CL_ORDINARY, OBJNULL)},
{"T" ECL_FUN(NULL, NULL, -1) ECL_VAR(CL_ORDINARY, OBJNULL)},
{SYS_ "UNBOUND" ECL_FUN("si_unbound", si_unbound, 0) ECL_VAR(SI_CONSTANT, ECL_UNBOUND)},
{SYS_ "*RESTART-CLUSTERS*" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_SPECIAL, ECL_NIL)},
{EXT_ "*INTERRUPTS-ENABLED*" ECL_FUN(NULL, NULL, 1) ECL_VAR(EXT_SPECIAL, ECL_T)},
{SYS_ "%ESCAPE" ECL_FUN("ecl_escape", ecl_escape, 1) ECL_VAR(SI_ORDINARY, OBJNULL)},
{SYS_ "%SIGNAL" ECL_FUN("ecl_signal", ecl_signal, 3) ECL_VAR(SI_ORDINARY, OBJNULL)},
@ -1359,7 +1355,6 @@ cl_symbols[] = {
{KEY_ "ADJUSTABLE" ECL_FUN(NULL, NULL, -1) ECL_VAR(KEYWORD, OBJNULL)},
{KEY_ "ABORT" ECL_FUN(NULL, NULL, -1) ECL_VAR(KEYWORD, OBJNULL)},
{KEY_ "ABSOLUTE" ECL_FUN(NULL, NULL, -1) ECL_VAR(KEYWORD, OBJNULL)},
{KEY_ "ALLOW-OTHER-KEYS" ECL_FUN(NULL, NULL, -1) ECL_VAR(KEYWORD, OBJNULL)},
{KEY_ "APPEND" ECL_FUN(NULL, NULL, -1) ECL_VAR(KEYWORD, OBJNULL)},
{KEY_ "ARRAY" ECL_FUN(NULL, NULL, -1) ECL_VAR(KEYWORD, OBJNULL)},
{KEY_ "BACK" ECL_FUN(NULL, NULL, -1) ECL_VAR(KEYWORD, OBJNULL)},

6
src/c/threads/thread.d
View file

@ -449,8 +449,8 @@ mp_block_signals(void)
{
#ifdef ECL_WINDOWS_THREADS
cl_env_ptr the_env = ecl_process_env();
cl_object previous = ecl_cmp_symbol_value(the_env, @'ext::*interrupts-enabled*');
ECL_SETQ(the_env, @'ext::*interrupts-enabled*', ECL_NIL);
cl_object previous = ecl_cmp_symbol_value(the_env, ECL_INTERRUPTS_ENABLED);
ECL_SETQ(the_env, ECL_INTERRUPTS_ENABLED, ECL_NIL);
@(return previous);
#else
cl_object previous = mp_get_sigmask();
@ -471,7 +471,7 @@ mp_restore_signals(cl_object sigmask)
{
#ifdef ECL_WINDOWS_THREADS
cl_env_ptr the_env = ecl_process_env();
ECL_SETQ(the_env, @'ext::*interrupts-enabled*', sigmask);
ECL_SETQ(the_env, ECL_INTERRUPTS_ENABLED, sigmask);
ecl_check_pending_interrupts(the_env);
@(return sigmask);
#else

4
src/c/unixint.d
View file

@ -257,7 +257,7 @@ static ECL_INLINE bool
interrupts_disabled_by_lisp(cl_env_ptr the_env)
{
return !ecl_option_values[ECL_OPT_BOOTED] ||
Null(ECL_SYM_VAL(the_env, @'ext::*interrupts-enabled*'));
Null(ECL_SYM_VAL(the_env, ECL_INTERRUPTS_ENABLED));
}
static void early_signal_error() ecl_attr_noreturn;
@ -1577,7 +1577,7 @@ enable_unixint(void)
create_signal_code_constants();
install_fpe_signal_handlers();
install_signal_handling_thread();
ECL_SET(@'ext::*interrupts-enabled*', ECL_T);
ECL_SET(ECL_INTERRUPTS_ENABLED, ECL_T);
ecl_process_env()->disable_interrupts = 0;
return ECL_NIL;
}

31
src/h/ecl-inl.h
View file

@ -129,6 +129,28 @@
#define ecl_cast_ptr(type,n) ((type)(n))
#endif
#define ecl_constexpr_string(name) \
((struct ecl_base_string) \
{ (int8_t)t_base_string, 0, ecl_aet_bc, 0, ECL_NIL, \
(cl_index)((sizeof(name)-1)), (cl_index)((sizeof(name)-1)), \
(ecl_base_char*)(name) })
#ifdef ECL_THREADS
#define ecl_constexpr_symbol(type, name, value) \
((struct ecl_symbol) \
{ (int8_t)t_symbol, 0, type, 0, \
value, ECL_NIL /*gfdef*/, NULL /*undefined_function_entry*/, \
ECL_NIL, ECL_NIL, ECL_NIL, (cl_object)&ecl_constexpr_string(name), \
ECL_NIL, ECL_NIL, ECL_MISSING_SPECIAL_BINDING } )
#else
#define ecl_constexpr_symbol(type, name, value) \
((struct ecl_symbol) \
{ (int8_t)t_symbol, 0, type, 0, \
value, ECL_NIL /*gfdef*/, NULL /*undefined_function_entry*/, \
ECL_NIL, ECL_NIL, ECL_NIL, (cl_object)&ecl_constexpr_string(name), \
ECL_NIL, ECL_NIL } )
#endif
#define ecl_def_variable(name, value, chars, len) \
ecl_def_ct_base_string (name ## _var_name, chars, len,static,const); \
ecl_def_ct_token(name, ecl_stp_special, name ## _var_name, value,,)
@ -154,6 +176,15 @@
static const cl_object name = (cl_object)(& name ## _data)
#endif
#define ecl_def_function(name, cname, static, const) \
static const struct ecl_cfunfixed name ##_data = { \
(int8_t)t_cfunfixed, 0, 0, 0, \
/*name*/ECL_NIL, /*block*/ECL_NIL, \
/*entry*/(cl_objectfn)cname, \
/*funfixed_entry*/(cl_objectfn_fixed)NULL, \
ECL_NIL, ECL_NIL }; \
static const cl_object name = (cl_object)(& name ## _data)
#define ecl_def_string_array(name,static,const) \
static const union { \
struct ecl_base_string elt; \

2
src/h/external.h
View file

@ -212,6 +212,7 @@ extern ECL_API struct cl_core_struct cl_core;
/* variables */
extern ECL_API cl_object ecl_vr_shandlers;
extern ECL_API cl_object ecl_vr_allow_other_keys;
/* memory.c */
extern ECL_API void *ecl_malloc(cl_index n);
@ -287,6 +288,7 @@ typedef union {
} cl_symbol_initializer;
extern ECL_API cl_symbol_initializer cl_symbols[];
extern ECL_API cl_index cl_num_symbols_in_core;
extern ECL_API struct ecl_symbol ecl_symbols[];
#define ECL_SYM(name,code) ((cl_object)(cl_symbols+(code)))

17
src/h/object.h
View file

@ -262,16 +262,19 @@ enum ecl_stype { /* symbol type */
};
#define ECL_NIL ((cl_object)t_list)
#define ECL_NO_TL_BINDING ((cl_object)(1 << ECL_TAG_BITS))
#define ECL_PROTECT_TAG ecl_ct_protect_tag
#define ECL_DUMMY_TAG ecl_ct_dummy_tag
#define ECL_SIGNAL_HANDLERS ecl_vr_shandlers
#define ECL_NIL_SYMBOL ((cl_object)cl_symbols)
#define ECL_T ((cl_object)(cl_symbols+1))
#define ECL_UNBOUND ((cl_object)(cl_symbols+2))
#define ECL_RESTART_CLUSTERS ((cl_object)(cl_symbols+3))
#define ECL_INTERRUPTS_ENABLED ((cl_object)(cl_symbols+4))
#define ECL_NO_TL_BINDING ((cl_object)(1 << ECL_TAG_BITS))
#define ECL_SIGNAL_HANDLERS ((cl_object)(ecl_symbols+0))
#define ECL_RESTART_CLUSTERS ((cl_object)(ecl_symbols+1))
#define ECL_INTERRUPTS_ENABLED ((cl_object)(ecl_symbols+2))
#define ECL_ALLOW_OTHER_KEYS ((cl_object)(ecl_symbols+3))
#define ECL_T ((cl_object)(ecl_symbols+4))
#define ECL_UNBOUND ((cl_object)(ecl_symbols+5))
#define ECL_NIL_SYMBOL ((cl_object)(cl_symbols+0))
struct ecl_symbol {
_ECL_HDR1(stype); /* symbol type */