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

186
src/kernel.sl
View File

@ -149,6 +149,9 @@
(defun identity (e) e)
(defun complement (fn)
(lambda (&rest args) (not (apply fn args))))
(defun append (&rest lists)
;; another implementation
;; (mapconcat 'identity lists)
@ -249,10 +252,6 @@
(throw 'type-error))
(apply pred obj args)))
(defun callablep (obj)
(or (functionp obj)
(and (pairp obj) (eq (head obj) 'lambda))))
(define-type-predicate any (obj) t)
(define-type-predicate t alias any)
(define-type-predicate or (obj &rest preds)
@ -290,10 +289,19 @@
(define-type-predicate callable callablep)
(define-type-predicate hash-table hash-table-p)
(define-type-predicate user-pointer user-pointer-p)
(define-type-predicate record recordp)
(define-type-predicate native-record (obj &opt backing-type)
(and (recordp obj)
(record-native-p obj)
(or (not backing-type)
(typep (record-native-backing obj) backing-type))))
(define-type-predicate number (obj &opt min max)
(typep obj (list 'or (list 'float min max)
(list 'integer min max))))
(define-type-predicate readable alias (or number vector pair symbol string))
(define-type-predicate callable-record alias (and record callable))
(defun callable-record-p (obj)
(typep obj 'callable-record))
(defun readablep (obj)
(typep obj 'readable))
@ -419,6 +427,7 @@
(list (list-length seq))
((or vector string) (vector-length seq))
(hash-table (hash-table-count seq))
(record (record-length seq))
(t (throw 'type-error))))
(fset 'copy-vector 'subvector)
@ -426,6 +435,12 @@
(defun zerop (n)
(= n 0))
(defun plusp (n)
(> n 0))
(defun minusp (n)
(< n 0))
(defun nth (n list)
(unless (integerp n)
(throw 'type-error '(integerp) n))
@ -495,4 +510,163 @@
(list (list 'set-symbol-value-docstr
(list '\' name) doc)))))
(set-symbol-value-docstr :a "d")
;; Object stuff
(defun symbol-class (symbol)
(unless (symbolp symbol)
(throw 'type-error '(symbolp) symbol))
(get symbol 'class))
(defun set-symbol-class (symbol class)
(unless (symbolp symbol)
(throw 'type-error '(symbolp) symbol))
(put symbol 'class class))
(defun classp (obj)
(or (eq (type-of obj) 'class)))
(define-type-predicate class classp)
(defun %default-slot-value (class obj slot)
(let* ((slots (record-slot class 3))
(unbound ::unbound)
(res (gethash slots slot unbound)))
(when (eq res unbound)
(throw 'slot-error slot))
(record-slot obj res)))
(defun %default-set-slot-value (class obj slot value)
(let* ((slots (record-slot class 3))
(unbound ::unbound)
(res (gethash slots slot unbound)))
(when (eq res unbound)
(throw 'slot-error slot))
(set-record-slot obj res value)))
(defun %default-lookup-method (class method)
(let* ((methods (record-slot class 4))
(unbound ::unbound)
(res (gethash methods method unbound)))
(unless (eq res unbound)
res)))
(defun %default-define-method (class method function)
(let* ((methods (record-slot class 4)))
(puthash methods method function)))
(defun %construct-class (class name superclass &rest slots)
nil)
;; Objects are records that have a class object as their first slot
;; Classes are records with their type set to 'class. The slots are
;; - class (class)
;; - name (symbol)
;; - superclass (class)
;; - slots (hash-table[symbol->integer])
;; - methods (hash-table[symbol->function])
;;
;; Special methods:
;; - (@construct obj &rest args)
;; Called when a new instance of this class is created. The newly allocated
;; object is passed to OBJ and the arguments to 'make-instance are passed to
;; ARGS.
;; - (@print obj stream)
;; Called to write OBJ out to STREAM.
(set-symbol-class 'class (make-record 'class 3))
(let ((class (symbol-class 'standard-class))
(slots (make-hash-table))
(methods (make-hash-table)))
(set-record-slot class 0 class)
(set-record-slot class 1 'class)
(set-record-slot class 2 class)
(set-record-slot class 3 slots)
(set-record-slot class 4 methods)
(puthash slots 'name 1)
(puthash slots 'superclass 2)
(puthash slots 'slots 3)
(puthash slots 'methods 4)
(puthash methods '@construct '%construct-class)
(puthash methods '@slot-value '%default-slot-value)
(puthash methods '@set-slot-value '%default-set-slot-value)
(puthash methods '@lookup-method '%default-lookup-method)
(puthash methods '@define-method '%default-define-method))
(defun objectp (obj)
"Return non-nil if OBJ is an object."
(and (recordp obj)
(plusp (length obj))
(classp (record-slot obj 0))))
(define-type-predicate object objectp)
(defun object-class (obj)
"Return the class of OBJ."
(unless (objectp obj)
(throw 'type-error '(objectp) obj))
(record-slot obj 0))
(defun methodp (obj)
"Return non-nil if OBJ is a method object."
(if (symbolp obj)
(methodp (symbol-function obj t))
(and (eq (type-of obj) 'method)
(= (length obj) 1)
(callable-record-p obj))))
(define-type-predicate method methodp)
;; Methods are callable records of length 1. The first slot is a hash table
;; mapping extra types to functions.
(defun make-method ()
"Return a new empty method object."
(let ((record (make-record 'method 1))
(extra-types (make-hash-table)))
(flet ((call-default (obj &rest args)
(let* ((unbound ::unbound)
(res (gethash extra-types t unbound)))
(when (eq res unbound)
(throw 'no-applicable-method-error obj))
(apply res obj args))))
(set-record-function
record
(lambda (obj &rest args)
(if (objectp obj)
(let ((method ()))))
(cond
((and (objectp obj)))))))
(set-record-slot record 0 extra-types)
record))
(defun %class-max-slot-index (class)
"Return the highest slot index of CLASS."
(let ((max 0))
(foreach (lambda (key val)
(when (> val max)
(setq max val)))
(record-slot class 2))
max))
(defun make-instance (class &rest args)
(tcase class
(symbol (setq class (symbol-class class)))
((not class) (throw 'type-error '(classp) class)))
(let ((constructor (gethash (record-slot class 3) '@construct))
(object (make-record (record-slot class
(%class-max-slot-index class)))))
(when (functionp constructor)
(apply constructor object args))
object))
(defmacro defclass (name &rest rest)
(unless (symbolp name)
(throw 'type-error '(symbolp) name))
(let (doc)
(when (stringp (head rest))
(setq doc (head rest)
rest (head rest)))
()))
(println (make-instance ()))
(println (symbol-class 'standard-class))
(doindex (i (symbol-class 'standard-class))
(print "- ")
(println (record-slot (symbol-class 'standard-class) i)))

258
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),
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 #
// ################

56
src/lisp.h
View File

@ -2,6 +2,7 @@
#define INCLUDED_LISP_H
#include <assert.h>
#include <limits.h>
#include <refcount/refcount.h>
#include <setjmp.h>
#include <stdarg.h>
@ -33,15 +34,10 @@ typedef enum {
TYPE_HASHTABLE,
TYPE_USER_POINTER,
TYPE_PACKAGE,
TYPE_RECORD,
N_LISP_TYPES,
} LispType;
struct _TypeNameEntry {
const char *name;
size_t len;
};
extern struct _TypeNameEntry LISP_TYPE_NAMES[N_LISP_TYPES];
#define LISP_OBJECT_HEADER \
LispType type; \
RefcountEntry refcount
@ -51,6 +47,8 @@ typedef struct {
} LispVal;
#define LISPVAL(obj) ((LispVal *) (obj))
extern LispVal *LISP_TYPE_SYMS[N_LISP_TYPES];
typedef struct {
LISP_OBJECT_HEADER;
@ -167,12 +165,11 @@ typedef struct {
typedef struct {
LISP_OBJECT_HEADER;
LispVal *class;
} LispObject;
typedef struct {
LispObject as_obj;
} LispClass;
LispVal *record_type;
LispVal *function;
size_t length;
LispVal **data;
} LispRecord;
// #######################
// # nil, unbound, and t #
@ -201,6 +198,16 @@ extern LispVal *Qrest;
extern LispVal *Qdeclare;
extern LispVal *Qname;
// Type symbols not defined elsewhere
extern LispVal *Qsymbol;
extern LispVal *Qinteger;
extern LispVal *Qfloat;
extern LispVal *Qfunction;
extern LispVal *Qhash_table;
extern LispVal *Quser_pointer;
extern LispVal *Qpackage;
extern LispVal *Qrecord;
// ############################
// # Global Package Variables #
// ############################
@ -231,6 +238,7 @@ extern LispVal *current_package;
#define HASHTABLEP(v) (TYPEOF(v) == TYPE_HASHTABLE)
#define USER_POINTER_P(v) (TYPEOF(v) == TYPE_USER_POINTER)
#define PACKAGEP(v) (TYPEOF(v) == TYPE_PACKAGE)
#define RECORDP(v) (TYPEOF(v) == TYPE_RECORD)
#define ATOM(v) (TYPEOF(v) != TYPE_PAIR)
@ -409,6 +417,7 @@ LispVal *make_user_pointer(void *data, void (*free_func)(void *));
#define ALLOC_USERPTR(type, free_func) \
(make_user_pointer(lisp_malloc(sizeof(type)), &free_func))
LispVal *make_lisp_package(LispVal *name);
LispVal *make_lisp_record(LispVal *type, size_t length);
LispVal *predicate_for_type(LispType type);
@ -429,6 +438,17 @@ DECLARE_FUNCTION(breakpoint, (LispVal * id));
DECLARE_FUNCTION(not, (LispVal * obj));
DECLARE_FUNCTION(type_of, (LispVal * val));
DECLARE_FUNCTION(user_pointer_p, (LispVal * val));
DECLARE_FUNCTION(callablep, (LispVal * val));
inline static bool CALLABLEP(LispVal *v) {
LispVal *res = Fcallablep(v);
bool rv = !NILP(res);
refcount_unref(res);
return rv;
}
inline static bool CALLABLE_RECORD_P(LispVal *v) {
return RECORDP(v) && CALLABLEP(v);
}
DECLARE_FUNCTION(native_type_p, (LispVal * sym));
// ##################################
// # Evaluation and Macro Expansion #
@ -610,6 +630,18 @@ DECLARE_FUNCTION(concat, (LispVal * strings));
LispVal *sprintf_lisp(const char *format, ...) PRINTF_FORMAT(1, 2);
bool strings_equal_nocase(const char *s1, const char *s2, size_t n);
// ####################
// # Record Functions #
// ####################
DECLARE_FUNCTION(recordp, (LispVal * val));
DECLARE_FUNCTION(make_record, (LispVal * type, LispVal *length));
DECLARE_FUNCTION(record_function, (LispVal * record));
DECLARE_FUNCTION(set_record_function, (LispVal * record, LispVal *value));
DECLARE_FUNCTION(record_length, (LispVal * record));
DECLARE_FUNCTION(record_slot, (LispVal * record, LispVal *index));
DECLARE_FUNCTION(set_record_slot,
(LispVal * record, LispVal *index, LispVal *value));
// ################
// # IO Functions #
// ################