mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2025-12-05 18:30:24 -08:00
Code Issues Projects Releases Packages Wiki Activity
ecl/src/c/all_symbols.d
Daniel Kochmański 71490141aa wip
2020-09-16 12:15:43 +02:00

340 lines
11 KiB
C
Raw Blame History

/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */
/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */
#include <ecl/ecl.h>
#include <ctype.h>
#include <limits.h>
#include <ecl/internal.h>
#define CL_PACKAGE 0
#define SI_PACKAGE 4
#define EXT_PACKAGE 64
#define GRAY_PACKAGE 32
#define FFI_PACKAGE 128
#define KEYWORD_PACKAGE 8
#define MP_PACKAGE 12
#define CLOS_PACKAGE 16
#define ORDINARY_SYMBOL 0
#define CONSTANT_SYMBOL 1
#define SPECIAL_SYMBOL 2
#define FORM_SYMBOL 3
#define PRIVATE 256
#define CL_ORDINARY CL_PACKAGE | ORDINARY_SYMBOL
#define CL_SPECIAL CL_PACKAGE | SPECIAL_SYMBOL
#define CL_CONSTANT CL_PACKAGE | CONSTANT_SYMBOL
#define CL_FORM CL_PACKAGE | ORDINARY_SYMBOL | FORM_SYMBOL
#define SI_ORDINARY SI_PACKAGE | ORDINARY_SYMBOL
#define SI_SPECIAL SI_PACKAGE | SPECIAL_SYMBOL
#define SI_CONSTANT SI_PACKAGE | CONSTANT_SYMBOL
#define EXT_ORDINARY EXT_PACKAGE | ORDINARY_SYMBOL
#define EXT_SPECIAL EXT_PACKAGE | SPECIAL_SYMBOL
#define EXT_CONSTANT EXT_PACKAGE | CONSTANT_SYMBOL
#define EXT_FORM EXT_PACKAGE | ORDINARY_SYMBOL | FORM_SYMBOL
#define MP_ORDINARY MP_PACKAGE | ORDINARY_SYMBOL
#define MP_SPECIAL MP_PACKAGE | SPECIAL_SYMBOL
#define MP_CONSTANT MP_PACKAGE | CONSTANT_SYMBOL
#define CLOS_ORDINARY CLOS_PACKAGE | ORDINARY_SYMBOL
#define CLOS_SPECIAL CLOS_PACKAGE | SPECIAL_SYMBOL
#define KEYWORD KEYWORD_PACKAGE | CONSTANT_SYMBOL
#define GRAY_ORDINARY GRAY_PACKAGE | ORDINARY_SYMBOL
#define FFI_ORDINARY FFI_PACKAGE | ORDINARY_SYMBOL
#define FFI_CONSTANT FFI_PACKAGE | CONSTANT_SYMBOL
#include "symbols_list.h"
cl_index cl_num_symbols_in_core = 0;
static unsigned char *
mangle_name(cl_object output, unsigned char *source, int l)
{
unsigned char c;
while (l--) {
c = *(source++);
if (ecl_alphanumericp(c)) {
c = ecl_char_downcase(c);
} else if (c == '-' || c == '_') {
c = '_';
} else if (c == '&') {
c = 'A';
} else if (c == '*') {
c = 'X';
} else if (c == '+') {
c = 'P';
} else if (c == '<') {
c = 'L';
} else if (c == '>') {
c = 'G';
} else if (c == '=') {
c = 'E';
} else if (c == '/') {
c = 'N';
} else if (c == ':') {
c = 'X';
} else {
return NULL;
}
output->base_string.self[output->base_string.fillp++] = c;
}
return &output->base_string.self[output->base_string.fillp];
}
@(defun si::mangle-name (symbol &optional as_function)
cl_index l;
unsigned char c, *source, *dest;
cl_object output;
cl_object package;
cl_object found = ECL_NIL;
cl_object maxarg = ecl_make_fixnum(ECL_CALL_ARGUMENTS_LIMIT);
cl_object minarg = ecl_make_fixnum(0);
bool is_symbol;
cl_object name;
@
name = ecl_symbol_name(symbol);
is_symbol = Null(as_function);
if (is_symbol) {
cl_fixnum p;
if (symbol == ECL_NIL) {
@(return ECL_T ecl_make_constant_base_string("ECL_NIL",-1) minarg maxarg);
}
else if (symbol == ECL_T) {
@(return ECL_T ecl_make_constant_base_string("ECL_T",-1) minarg maxarg);
}
p = (cl_symbol_initializer*)symbol - cl_symbols;
if (p >= 0 && p <= cl_num_symbols_in_core) {
found = ECL_T;
output = cl_format(4, ECL_NIL,
ecl_make_constant_base_string("ECL_SYM(~S,~D)",-1),
name, ecl_make_fixnum(p));
#ifndef ECL_FINAL
/* XXX to allow the Lisp compiler to check that the narg
* declaration in symbols_list.h matches the actual function
* definition, return the previously saved narg here. -- mg
* 2019-12-02 */
cl_object plist = cl_symbol_plist(symbol);
for ( ; ECL_CONSP(plist); plist = ECL_CONS_CDR(plist)) {
if (ECL_CONS_CAR(plist) == @'call-arguments-limit') {
plist = ECL_CONS_CDR(plist);
if (ECL_CONSP(plist) && ECL_FIXNUMP(ECL_CONS_CAR(plist))) {
cl_fixnum narg = ecl_fixnum(ECL_CONS_CAR(plist));
if (narg >= 0) {
minarg = maxarg = ecl_make_fixnum(narg);
} else {
minarg = ecl_make_fixnum(-narg-1);
}
}
break;
}
}
#endif
@(return found output minarg maxarg);
}
} else if (!Null(symbol)) {
cl_object fun = symbol->symbol.gfdef;
cl_type t = (fun == OBJNULL)? t_other : ecl_t_of(fun);
if ((t == t_cfun || t == t_cfunfixed) && fun->cfun.block == OBJNULL) {
for (l = 0; l <= cl_num_symbols_in_core; l++) {
cl_object s = (cl_object)(cl_symbols + l);
if (fun == ECL_SYM_FUN(s)) {
symbol = s;
found = ECL_T;
if (fun->cfun.narg >= 0) {
if (t == t_cfunfixed) {
minarg =
maxarg = ecl_make_fixnum(fun->cfunfixed.narg);
} else {
minarg = ecl_make_fixnum(fun->cfun.narg);
}
}
break;
}
}
}
}
if (!Null(symbol->symbol.cname)) {
@(return found symbol->symbol.cname minarg maxarg);
}
package = ecl_symbol_package(symbol);
if (Null(package)) {
;
}
else if (package == cl_core.lisp_package)
package = ecl_make_constant_base_string("cl",-1);
else if (package == cl_core.system_package)
package = ecl_make_constant_base_string("si",-1);
else if (package == cl_core.ext_package)
package = ecl_make_constant_base_string("si",-1);
else if (package == cl_core.keyword_package)
package = ECL_NIL;
else
package = package->pack.name;
symbol = ecl_symbol_name(symbol);
l = symbol->base_string.fillp;
source = symbol->base_string.self;
output = ecl_alloc_simple_base_string(ecl_length(package) + l + 1);
if (is_symbol && source[0] == '*') {
if (l > 2 && source[l-1] == '*') l--;
c = 'V';
l--;
source++;
} else if (is_symbol && l > 2 && source[0] == '+' && source[l-1] == '+') {
c = 'C';
l-= 2;
source++;
} else if (!is_symbol) {
c = '_';
} else if (package == cl_core.keyword_package) {
c = 'K';
} else {
c = 'S';
}
output->base_string.fillp = 0;
if (!Null(package)) {
if (!mangle_name(output, package->base_string.self, package->base_string.fillp)) {
@(return ECL_NIL ECL_NIL minarg maxarg);
}
}
output->base_string.self[output->base_string.fillp++] = c;
if (!(dest = mangle_name(output, source, l))) {
@(return ECL_NIL ECL_NIL minarg maxarg);
}
if (dest[-1] == '_')
dest[-1] = 'M';
*(dest++) = '\0';
@(return found output minarg maxarg);
@)
/* #ifndef ECL_FINAL */
/* Fletcher's checksum is curbed from Wikipedia[1]. We use it to compute the
checksum of the symbol table. We account only for symbol names in sequence,
because we want to allow loading FASL's from different ECL builds (possibly
with a different configuration), under the condition that the table indexes
are matching.
[1] https://en.wikipedia.org/wiki/Fletcher%27s_checksum */
uint16_t cl_core_symbols_checksum = 0;
static void
update_symbols_checksum(const char *data) {
size_t i = 0;
uint16_t sum1 = cl_core_symbols_checksum & 255;
uint16_t sum2 = cl_core_symbols_checksum >> 8;
uint8_t word;
while ((word=(uint8_t)data[i++])) {
sum1 = (sum1 + word) % 255;
sum2 = (sum2 + sum1) % 255;
}
cl_core_symbols_checksum = (sum2 << 8) | sum1;
}
/* #endif /\* ECL_FINAL *\/ */
static void
make_this_symbol(int i, cl_object s, int code,
const char *name, const char *cname,
cl_objectfn fun, int narg, cl_object value)
{
enum ecl_stype stp;
cl_object package;
bool form = 0;
switch (code & 3) {
case ORDINARY_SYMBOL: stp = ecl_stp_ordinary; break;
case SPECIAL_SYMBOL: stp = ecl_stp_special; break;
case CONSTANT_SYMBOL: stp = ecl_stp_constant; break;
case FORM_SYMBOL: form = 1; stp = ecl_stp_ordinary;
}
switch (code & 0xfc) {
case CL_PACKAGE: package = cl_core.lisp_package; break;
case SI_PACKAGE: package = cl_core.system_package; break;
case EXT_PACKAGE: package = cl_core.ext_package; break;
case KEYWORD_PACKAGE: package = cl_core.keyword_package; break;
case MP_PACKAGE: package = cl_core.mp_package; break;
case CLOS_PACKAGE: package = cl_core.clos_package; break;
#ifdef ECL_CLOS_STREAMS
case GRAY_PACKAGE: package = cl_core.gray_package; break;
#endif
case FFI_PACKAGE: package = cl_core.ffi_package; break;
default: printf("%d\n", code & ~(int)3); ecl_internal_error("Unknown package code in init_all_symbols()");
}
s->symbol.t = t_symbol;
s->symbol.dynamic = 0;
#ifdef ECL_THREADS
s->symbol.binding = ECL_MISSING_SPECIAL_BINDING;
#endif
ECL_SET(s, OBJNULL);
ECL_SYM_FUN(s) = ECL_NIL;
s->symbol.plist = ECL_NIL;
s->symbol.hpack = ECL_NIL;
s->symbol.stype = stp;
s->symbol.hpack = package;
s->symbol.name = ecl_make_constant_base_string(name,-1);
s->symbol.cname = ecl_cstring_to_base_string_or_nil(cname);
if (package == cl_core.keyword_package) {
package->pack.external =
_ecl_sethash(s->symbol.name, package->pack.external, s);
ECL_SET(s, s);
} else {
int intern_flag;
ECL_SET(s, value);
if (ecl_find_symbol(s->symbol.name, package, &intern_flag) != ECL_NIL
&& intern_flag == ECL_INHERITED) {
ecl_shadowing_import(s, package);
} else {
cl_import2(s, package);
}
if (!(code & PRIVATE)) {
cl_export2(s, package);
if (package == cl_core.ext_package)
cl_export2(s, cl_core.system_package);
}
}
if (form) {
s->symbol.stype |= ecl_stp_special_form;
} else if (fun) {
cl_object f;
if (narg >= 0) {
f = ecl_make_cfun((cl_objectfn_fixed)fun, s, NULL, narg);
} else {
f = ecl_make_cfun_va(fun, s, NULL, -narg - 1);
}
ECL_SYM_FUN(s) = f;
}
#ifndef ECL_FINAL
/* XXX to allow the Lisp compiler to check that the narg declaration
* in symbols_list.h matches the actual function definition, we save
* narg here. -- mg 2019-12-02 */
si_set_symbol_plist(s, cl_list(2,
@'call-arguments-limit',
ecl_make_fixnum(narg)));
#endif
/* Update the symbols checksum. -- jd 2020-09-15 */
update_symbols_checksum(name);
cl_num_symbols_in_core = i + 1;
}
void
init_all_symbols(void)
{
int i, code, narg;
const char *name, *cname;
cl_object s, value;
cl_objectfn fun;
/* We skip NIL and T */
for (i = 2; 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;
fun = (cl_objectfn)cl_symbols[i].init.fun;
narg = cl_symbols[i].init.narg;
value = cl_symbols[i].init.value;
cname = cl_symbols[i].init.translation;
make_this_symbol(i, s, code, name, cname, fun, narg, value);
}
/* #ifndef ECL_FINAL */
ECL_SET(@'SI::LISP-CORE-CHECKSUM', ecl_make_fixnum(cl_core_symbols_checksum));
/* #endif */
}
Reference in a new issue View git blame Copy permalink