Zander671/simple-lisp
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Start work on objects

Browse Source
This commit is contained in:
Alexander Rosenberg
2025-11-04 20:26:28 -08:00
parent 6f927bf768
commit f1d3a71c32
3 changed files with 445 additions and 57 deletions
Download Patch File Download Diff File Expand all files Collapse all files

260
src/lisp.c
View File

@ -15,18 +15,7 @@
// used to fix up some indentation or syntax highlighting problems
#define IGNORE() struct __ignored_struct
struct _TypeNameEntry LISP_TYPE_NAMES[N_LISP_TYPES] = {
[TYPE_STRING] = {"string", sizeof("string") - 1},
[TYPE_SYMBOL] = {"symbol", sizeof("symbol") - 1},
[TYPE_PAIR] = {"pair", sizeof("pair") - 1},
[TYPE_INTEGER] = {"integer", sizeof("integer") - 1},
[TYPE_FLOAT] = {"float", sizeof("float") - 1},
[TYPE_VECTOR] = {"vector", sizeof("vector") - 1},
[TYPE_FUNCTION] = {"function", sizeof("function") - 1},
[TYPE_HASHTABLE] = {"hashtable", sizeof("hashtable") - 1},
[TYPE_USER_POINTER] = {"user-pointer", sizeof("user-pointer") - 1},
[TYPE_PACKAGE] = {"package", sizeof("package") - 1},
};
LispVal *LISP_TYPE_SYMS[N_LISP_TYPES] = {NULL};
// #######################
// # nil, unbound, and t #
@ -87,6 +76,15 @@ DEF_STATIC_SYMBOL(rest, "&rest");
DEF_STATIC_SYMBOL(declare, "declare");
DEF_STATIC_SYMBOL(name, "name");
DEF_STATIC_SYMBOL(symbol, "symbol");
DEF_STATIC_SYMBOL(integer, "integer");
DEF_STATIC_SYMBOL(float, "float");
DEF_STATIC_SYMBOL(function, "function");
DEF_STATIC_SYMBOL(hash_table, "hash_table");
DEF_STATIC_SYMBOL(user_pointer, "user_pointer");
DEF_STATIC_SYMBOL(package, "package");
DEF_STATIC_SYMBOL(record, "record");
// ############################
// # Global Package Variables #
// ############################
@ -196,6 +194,14 @@ static bool held_refs_callback(void *obj, RefcountList **held, void *ignored) {
*held = refcount_list_push(*held, pkg->exported_sym_table);
return true;
}
case TYPE_RECORD: {
LispRecord *rec = obj;
*held = refcount_list_push(*held, rec->record_type);
for (size_t i = 0; i < rec->length; ++i) {
*held = refcount_list_push(*held, rec->data[i]);
}
return true;
}
default:
abort();
}
@ -231,6 +237,7 @@ static void free_obj_callback(void *obj, void *ignored) {
case TYPE_INTEGER:
case TYPE_FLOAT:
case TYPE_PACKAGE:
case TYPE_RECORD:
// no internal data to free
break;
default:
@ -408,6 +415,18 @@ LispVal *make_lisp_package(LispVal *name) {
return LISPVAL(self);
}
LispVal *make_lisp_record(LispVal *type, size_t length) {
CONSTRUCT_OBJECT(self, LispRecord, TYPE_RECORD);
self->record_type = refcount_ref(type);
self->function = Qnil;
self->data = lisp_malloc(sizeof(LispVal *) * length);
for (size_t i = 0; i < length; ++i) {
self->data[i] = Qnil;
}
self->length = length;
return LISPVAL(self);
}
LispVal *predicate_for_type(LispType type) {
switch (type) {
case TYPE_STRING:
@ -430,6 +449,8 @@ LispVal *predicate_for_type(LispType type) {
return Quser_pointer_p;
case TYPE_PACKAGE:
return Qpackagep;
case TYPE_RECORD:
return Qrecordp;
default:
abort();
}
@ -453,6 +474,18 @@ void lisp_init(void) {
REGISTER_SYMBOL_NOINTERN(nil);
REGISTER_SYMBOL_NOINTERN(t);
LISP_TYPE_SYMS[TYPE_STRING] = Qstring;
LISP_TYPE_SYMS[TYPE_SYMBOL] = Qsymbol;
LISP_TYPE_SYMS[TYPE_PAIR] = Qpair;
LISP_TYPE_SYMS[TYPE_INTEGER] = Qinteger;
LISP_TYPE_SYMS[TYPE_FLOAT] = Qfloat;
LISP_TYPE_SYMS[TYPE_VECTOR] = Qvector;
LISP_TYPE_SYMS[TYPE_FUNCTION] = Qfunction;
LISP_TYPE_SYMS[TYPE_HASHTABLE] = Qhash_table;
LISP_TYPE_SYMS[TYPE_USER_POINTER] = Quser_pointer;
LISP_TYPE_SYMS[TYPE_PACKAGE] = Qpackage;
LISP_TYPE_SYMS[TYPE_RECORD] = Qrecord;
package_table = make_lisp_hashtable(Qstrings_equal, Qhash_string);
LispVal *sys_package_name = STATIC_STRING("sys");
system_package = make_lisp_package(sys_package_name);
@ -535,7 +568,19 @@ DEFUN(equal, "equal", (LispVal * obj1, LispVal *obj2), "(obj1 obj2)",
case TYPE_FLOAT:
return LISP_BOOL(((LispFloat *) obj1)->value
== ((LispFloat *) obj2)->value);
case TYPE_VECTOR:
case TYPE_VECTOR: {
LispVector *v1 = (LispVector *) obj1;
LispVector *v2 = (LispVector *) obj2;
if (v1->length != v2->length) {
return Qnil;
}
for (size_t i = 0; i < v1->length; ++i) {
if (!Fequal(v1->data[i], v2->data[i])) {
return Qnil;
}
}
return Qt;
}
case TYPE_HASHTABLE: {
LispHashtable *t1 = (LispHashtable *) obj1;
LispHashtable *t2 = (LispHashtable *) obj2;
@ -551,6 +596,10 @@ DEFUN(equal, "equal", (LispVal * obj1, LispVal *obj2), "(obj1 obj2)",
}
return Qt;
}
case TYPE_RECORD: {
// TODO implement this
return Qnil;
}
default:
abort();
}
@ -575,16 +624,12 @@ DEFUN(not, "not", (LispVal * obj), "(obj)",
DEFUN(
type_of, "type-of", (LispVal * obj), "(obj)",
"Return a symbol that describes the type of OBJ. This is for informational "
"purpoese only, don't use this to test for objects of a specific type.") {
if (obj->type < 0 || obj->type >= N_LISP_TYPES) {
return Qnil;
"purposes only, don't use this to test for objects of a specific type.") {
if (TYPEOF(obj) != TYPE_RECORD) {
return refcount_ref(LISP_TYPE_SYMS[TYPEOF(obj)]);
} else {
return refcount_ref(((LispRecord *) obj)->record_type);
}
LispVal *name =
make_lisp_string((char *) LISP_TYPE_NAMES[obj->type].name,
LISP_TYPE_NAMES[obj->type].len, true, true);
LispVal *sym = Fintern(name, system_package, Qnil);
refcount_unref(name);
return sym;
}
DEFUN(user_pointer_p, "user-pointer-p", (LispVal * val), "(obj)",
@ -592,6 +637,31 @@ DEFUN(user_pointer_p, "user-pointer-p", (LispVal * val), "(obj)",
return LISP_BOOL(USER_POINTER_P(val));
}
DEFUN(callablep, "callablep", (LispVal * val), "(obj)",
"Return non-nil if OBJ is callable.") {
if (FUNCTIONP(val)) {
return refcount_ref(val);
} else if (SYMBOLP(val)) {
return Fcallablep(Fsymbol_function(val, Qt));
} else if (PAIRP(val) && HEAD(val) == Qlambda) {
return refcount_ref(val);
} else if (CALLABLE_RECORD_P(val)) {
return Fcallablep(((LispRecord *) val)->function);
}
return Qnil;
}
DEFUN(native_type_p, "native-type-p", (LispVal * sym), "(sym)",
"Return non-nil if SYM names a native type.") {
CHECK_TYPE(TYPE_SYMBOL, sym);
for (size_t i = 0; i < N_LISP_TYPES; ++i) {
if (!NILP(Feq(LISP_TYPE_SYMS[i], sym))) {
return Qt;
}
}
return Qnil;
}
// ##################################
// # Evaluation and Macro Expansion #
// ##################################
@ -913,16 +983,11 @@ static inline void setup_return_handler(LispVal *tag, LispVal *dest) {
static LispVal *call_function(LispVal *func, LispVal *args,
LispVal *args_lexenv, bool eval_args,
bool allow_macro) {
LispFunction *fobj = (LispFunction *) Qnil;
if (FUNCTIONP(func)) {
fobj = (LispFunction *) refcount_ref(func);
} else if (SYMBOLP(func)) {
fobj = (LispFunction *) Fsymbol_function(func, Qt);
} else if (PAIRP(func) && HEAD(func) == Qlambda) {
fobj = (LispFunction *) Feval(func, args_lexenv);
assert(FUNCTIONP(fobj));
} else {
Fthrow(Qinvalid_function_error, Fpair(func, Qnil));
LispFunction *fobj = (LispFunction *) Fcallablep(func);
if (PAIRP(fobj)) {
LispVal *real_fobj = Feval(LISPVAL(fobj), args_lexenv);
refcount_unref(fobj);
fobj = (LispFunction *) real_fobj;
}
void *cl_handle = register_cleanup(refcount_unref_as_callback, fobj);
if (NILP(fobj)) {
@ -1008,6 +1073,7 @@ DEFUN(eval, "eval", (LispVal * form, LispVal *lexenv), "(eval &opt lexenv)",
case TYPE_HASHTABLE:
case TYPE_USER_POINTER:
case TYPE_PACKAGE:
case TYPE_RECORD:
// the above all are self-evaluating
return refcount_ref(form);
case TYPE_SYMBOL:
@ -3513,6 +3579,75 @@ bool strings_equal_nocase(const char *s1, const char *s2, size_t n) {
return true;
}
// ####################
// # Record Functions #
// ####################
DEFUN(recordp, "recordp", (LispVal * val), "(obj)",
"Return non-nil if OBJ is a record.") {
return LISP_BOOL(RECORDP(val));
}
DEFUN_DISTINGUISHED(make_record, "make-record",
(LispVal * type, LispVal *length),
"(type length &opt native-backing)",
"Return a new record object of TYPE.") {
CHECK_TYPE(TYPE_INTEGER, length);
int64_t real_length = ((LispInteger *) length)->value;
if (real_length < 0) {
Fthrow(Qout_of_bounds_error, Qnil);
}
return make_lisp_record(type, real_length);
}
DEFUN(record_function, "record-function", (LispVal * record), "(record)",
"Return the function associated with RECORD.") {
CHECK_TYPE(TYPE_RECORD, record);
return refcount_ref(((LispRecord *) record)->function);
}
DEFUN(set_record_function, "set-record-function",
(LispVal * record, LispVal *value), "(record value)",
"Set the function of RECORD to VALUE.") {
CHECK_TYPE(TYPE_RECORD, record);
LispRecord *rec = (LispRecord *) record;
refcount_unref(rec->function);
rec->function = refcount_ref(value);
return refcount_ref(value);
}
DEFUN(record_length, "record-length", (LispVal * record), "(record)",
"Return the length of RECORD.") {
CHECK_TYPE(TYPE_RECORD, record);
return make_lisp_integer(((LispRecord *) record)->length);
}
DEFUN(record_slot, "record-slot", (LispVal * record, LispVal *index),
"(obj index)", "Return the INDEXth slot of RECORD.") {
CHECK_TYPE(TYPE_RECORD, record);
CHECK_TYPE(TYPE_INTEGER, index);
LispRecord *rec = (LispRecord *) record;
int64_t real_index = ((LispInteger *) index)->value;
if (real_index < 0 || real_index > rec->length) {
Fthrow(Qout_of_bounds_error, Fpair(index, Qnil));
}
return refcount_ref(rec->data[real_index]);
}
DEFUN(set_record_slot, "set-record-slot",
(LispVal * record, LispVal *index, LispVal *value),
"(record index value)", "Set the INDEXth slot of RECORD to VALUE.") {
CHECK_TYPE(TYPE_RECORD, record);
CHECK_TYPE(TYPE_INTEGER, index);
LispRecord *rec = (LispRecord *) record;
int64_t real_index = ((LispInteger *) index)->value;
if (real_index < 0 || real_index > rec->length) {
Fthrow(Qout_of_bounds_error, Fpair(index, Qnil));
}
refcount_unref(rec->data[real_index]);
rec->data[real_index] = refcount_ref(value);
return Qnil;
}
// ################
// # IO Functions #
// ################
@ -3544,7 +3679,12 @@ static int64_t internal_print(void *obj, int64_t fd, bool readably,
}
}
case TYPE_SYMBOL: {
LispVal *name = Fquote_symbol_for_read(obj, Qkw_as_needed, Qnil);
LispVal *name = Qnil;
if (readably) {
name = Fquote_symbol_for_read(obj, Qkw_as_needed, Qnil);
} else {
name = refcount_ref(((LispSymbol *) obj)->name);
}
int64_t np;
WITH_CLEANUP(name, {
np = internal_print(name, fd, false, true); //
@ -3618,7 +3758,7 @@ static int64_t internal_print(void *obj, int64_t fd, bool readably,
LispVal *hash_fn = NILP(ht->hash_fn) ? Qid : ht->hash_fn;
LispVal *eq_fn = NILP(ht->eq_fn) ? Qeq : ht->eq_fn;
int64_t np = CHECK_IO_RESULT(
dprintf(fd, "<hash-table size=%#jx count=%#jx eq-fn=",
dprintf(fd, "<hash-table size=%ju count=%ju eq-fn=",
(uintmax_t) ht->table_size, (uintmax_t) ht->count),
fd);
np += internal_print(eq_fn, fd, readably, true);
@ -3627,6 +3767,11 @@ static int64_t internal_print(void *obj, int64_t fd, bool readably,
np += CHECK_IO_RESULT(dprintf(fd, " at %#jx>", (uintmax_t) obj), fd);
return np;
}
case TYPE_USER_POINTER:
return CHECK_IO_RESULT(dprintf(fd, "<user-pointer to %#jx at %#jx>",
(uintmax_t) USERPTR(void *, obj),
(uintmax_t) obj),
fd);
case TYPE_PACKAGE: {
LispPackage *pkg = obj;
int64_t np = CHECK_IO_RESULT(dprintf(fd, "<package "), fd);
@ -3641,11 +3786,19 @@ static int64_t internal_print(void *obj, int64_t fd, bool readably,
fd);
return np;
} break;
case TYPE_USER_POINTER:
return CHECK_IO_RESULT(dprintf(fd, "<user-pointer to %#jx at %#jx>",
(uintmax_t) USERPTR(void *, obj),
(uintmax_t) obj),
fd);
case TYPE_RECORD: {
// TODO implement
LispRecord *rec = (LispRecord *) obj;
int64_t np = CHECK_IO_RESULT(
dprintf(fd,
"<%srecord type=", NILP(rec->function) ? "" : "callable-"),
fd);
np += internal_print(rec->record_type, fd, readably, true);
np += CHECK_IO_RESULT(dprintf(fd, " length=%ju at %#jx>",
(uintmax_t) rec->length, (uintmax_t) obj),
fd);
return np;
} break;
default:
abort();
}
@ -4012,6 +4165,14 @@ static void debug_dump_real(FILE *stream, void *obj, bool first) {
fprintf(stream, " obarray-size=%zu at %#jx>",
((LispHashtable *) pkg->obarray)->count, (uintmax_t) obj);
} break;
case TYPE_RECORD: {
LispRecord *rec = (LispRecord *) obj;
fprintf(stream,
"<%srecord type=", NILP(rec->function) ? "" : "callable-");
debug_dump_real(stream, rec->record_type, true);
fprintf(stream, " length=%ju at %#jx>", (uintmax_t) rec->length,
(uintmax_t) obj);
} break;
default:
fprintf(stream, "<object type=%ju at %#jx>",
(uintmax_t) LISPVAL(obj)->type, (uintmax_t) obj);
@ -4070,6 +4231,14 @@ static void register_symbols_and_functions(void) {
REGISTER_SYMBOL(comma);
REGISTER_SYMBOL(comma_at);
REGISTER_SYMBOL(backquote);
REGISTER_SYMBOL(symbol);
REGISTER_SYMBOL(integer);
REGISTER_SYMBOL(float);
REGISTER_SYMBOL(function);
REGISTER_SYMBOL(hash_table);
REGISTER_SYMBOL(user_pointer);
REGISTER_SYMBOL(package);
REGISTER_SYMBOL(record);
REGISTER_KEYWORD(kw_success);
REGISTER_KEYWORD(kw_finally);
REGISTER_KEYWORD(kw_as_needed);
@ -4111,6 +4280,8 @@ static void register_symbols_and_functions(void) {
REGISTER_FUNCTION(not);
REGISTER_FUNCTION(type_of);
REGISTER_FUNCTION(user_pointer_p);
REGISTER_FUNCTION(callablep);
REGISTER_FUNCTION(native_type_p);
// ##################################
// # Evaluation and Macro Expansion #
@ -4256,6 +4427,17 @@ static void register_symbols_and_functions(void) {
REGISTER_FUNCTION(quote_string);
REGISTER_FUNCTION(concat);
// ####################
// # Record Functions #
// ####################
REGISTER_FUNCTION(recordp);
REGISTER_FUNCTION(make_record);
REGISTER_FUNCTION(record_function);
REGISTER_FUNCTION(set_record_function);
REGISTER_FUNCTION(record_length);
REGISTER_FUNCTION(record_slot);
REGISTER_FUNCTION(set_record_slot);
// ################
// # IO Functions #
// ################