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

Compare commits

base: Zander671:b8c685fa17146fc620e71272216933035ca31331
Branches Tags
Zander671:main
...
compare: Zander671:main
Branches Tags
Zander671:main

2 Commits
b8c685fa17 ... main

Author SHA1 Message Date
Alexander Rosenberg
f1d3a71c32 Start work on objects 2025-11-04 20:26:28 -08:00
Alexander Rosenberg
6f927bf768 A bunch of changes 2025-10-28 03:02:39 -07:00
5 changed files with 821 additions and 185 deletions
Expand all files Collapse all files

4
CMakeLists.txt
View File

@ -15,8 +15,8 @@ FetchContent_Declare(
FetchContent_MakeAvailable(refcount)
add_compile_options(-fsanitize=address,leak,undefined)
add_link_options(-fsanitize=address,leak,undefined)
# add_compile_options(-fsanitize=address,leak,undefined)
# add_link_options(-fsanitize=address,leak,undefined)
add_executable(simple-lisp src/main.c src/lisp.c src/read.c)
target_link_libraries(simple-lisp PUBLIC refcount)

324
src/kernel.sl
View File

@ -3,24 +3,38 @@
(fset 'null 'not)
(fset 'list (lambda (&rest r) (declare (name list)) r))
;; these versions do not support (declare) forms
(fset 'defmacro
(lambda (name args &rest body)
(declare (name defmacro) macro)
(list 'progn
(list 'fset (list '\' name)
(apply 'list 'lambda args
(if (and (stringp (head body)) (not (null (tail body))))
(progn
(apply 'list
(head body)
(list 'declare (list 'name name)
'macro)
body))
(apply 'list
(list 'declare (list 'name name) 'macro)
body)))))
body))))))
(defmacro defun (name args &rest body)
(list 'progn
(list 'fset (list '\' name)
(apply 'list 'lambda args
(if (and (stringp (head body)) (not (null (tail body))))
(progn
(apply 'list
(head body)
(list 'declare (list 'name name))
body))))
(tail body)))
(progn
(list 'declare (list 'name name))
body)))))
(defun ensure-list (arg)
(if (pairp arg)
(if (or (null arg) (pairp arg))
arg
(list arg)))
@ -62,7 +76,7 @@
(list 'head tail-var))
(list 'setq tail-var (list 'tail tail-var))))
(second vars)))
(make-symbol "tail")))
'::tail))
(defun maphead (func list)
(funcall
@ -106,14 +120,13 @@
(throw 'argument-error))))
(apply 'list 'funcall (apply 'list 'lambda
(reverse vars)
(list 'declare (list 'name
(make-symbol "let")))
(list 'declare (list 'name '::let))
body)
(reverse vals)))))
(defmacro let* (bindings &rest body)
(list 'funcall (apply 'list 'lambda (apply 'list '&opt bindings)
(list 'declare (list 'name (make-symbol "let*")))
(list 'declare (list 'name '::let*))
body)))
(defun lasttail (list)
@ -124,12 +137,72 @@
list (tail list)))
out))
(defun mapconcat (func list)
(let (start end)
(dolist (elt list)
(if (not start)
(setq start (copy-list (funcall func elt))
end (lasttail start))
(settail end (copy-list (funcall func elt)))
(setq end (lasttail end))))
start))
(defun identity (e) e)
(defun complement (fn)
(lambda (&rest args) (not (apply fn args))))
(defun append (&rest lists)
;; another implementation
;; (mapconcat 'identity lists)
(let* ((start (copy-list (head lists)))
(end (lasttail start)))
(dolist (list (tail lists))
(settail end (copy-list list))
(setq end (lasttail end)))
start))
(defmacro prog1 (first-form &rest body)
(let ((rval '::rval))
(list 'let (list (list rval first-form))
(apply 'list 'progn body)
rval)))
;; these versions support (declare) forms
(defmacro defmacro (name args &rest body)
(list 'fset (list '\' name)
(append (list 'lambda args)
(when (and (stringp (head body)) (not (null (tail body))))
(prog1 (list (head body))
(setq body (tail body))))
(list
(apply 'list 'declare (list 'name name) 'macro
(when (and (pairp (head body))
(eq (head (head body)) 'declare))
(prog1 (tail (head body))
(setq body (tail body))))))
body)))
(defmacro defun (name args &rest body)
(list 'fset (list '\' name)
(append (list 'lambda args)
(when (and (stringp (head body)) (not (null (tail body))))
(prog1 (list (head body))
(setq body (tail body))))
(list
(apply 'list 'declare (list 'name name)
(when (and (pairp (head body))
(eq (head (head body)) 'declare))
(prog1 (tail (head body))
(setq body (tail body))))))
body)))
(defun internal-expand-single-cond (cond)
(if (tail cond)
(let ((res (list 'if (head cond)
(apply 'list 'progn (tail cond)))))
(pair res res))
(let* ((res-var (make-symbol "res"))
(let* ((res-var '::res)
(if-stmt (list 'if res-var res-var)))
(pair (list 'let (list (list res-var (head cond)))
if-stmt)
@ -158,7 +231,7 @@
(defmacro define-type-predicate (name args &rest body)
(cond
((eq args 'alias)
(let ((var (make-symbol "var")))
(let ((var '::var))
(list 'put (list '\' name) ''type-predicate
(list 'lambda (list var) (list 'typep var (pair '\' body))))))
((and (symbolp args) (null body))
@ -179,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)
@ -220,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))
@ -233,7 +311,7 @@
(get symbol 'type-predicate))
(defmacro tcase (obj &rest conds)
(let ((obj-var (make-symbol "obj")))
(let ((obj-var '::obj))
(list 'let (list (list obj-var obj))
(pair
'cond
@ -253,7 +331,7 @@
(list 'return-from nil value))
(defmacro dotails (vars &rest body)
(let ((cur (make-symbol "cur")))
(let ((cur '::cur))
(list 'let (list (list cur (second vars)))
(list 'while (list 'pairp cur)
(apply 'list 'let (list (list (first vars) cur))
@ -284,28 +362,6 @@
(return-from find-if cur)))
default)
(defun mapconcat (func list)
(let (start end)
(dolist (elt list)
(if (not start)
(setq start (copy-list (funcall func elt))
end (lasttail start))
(settail end (copy-list (funcall func elt)))
(setq end (lasttail end))))
start))
(defun identity (e) e)
(defun append (&rest lists)
;; another implementation
;; (mapconcat 'identity lists)
(let* ((start (copy-list (head lists)))
(end (lasttail start)))
(dolist (list (tail lists))
(settail end (copy-list list))
(setq end (lasttail end)))
start))
(defmacro macrolet (macros &rest body)
(let* ((found-macros (make-hash-table))
(macro-fns (mapconcat (lambda (entry)
@ -371,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)
@ -378,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))
@ -435,12 +498,175 @@
(defun char-code (str)
(aref str 0))
(defun print-readably (obj &opt (newline t) stream)
(unless (readablep obj)
(throw 'type-error '(readablep) obj))
(tcase obj
(symbol (print (quote-symbol-for-read obj :as-needed)))
(string (print (quote-string obj)))
(t (print obj)))
(when newline
(println)))
(defmacro defvar (name value &opt doc)
(unless (symbolp name)
(throw 'type-error '(symbolp) name))
(unless (or (not doc) (stringp doc))
(throw 'type-error '(null stringp) doc))
(apply 'list 'progn
(list 'make-symbol-special (list '\' name))
(list 'setq name value)
(when doc
(list (list 'set-symbol-value-docstr
(list '\' name) doc)))))
;; 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)))

547
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 #
@ -39,7 +28,10 @@ LispSymbol _Qnil = {
.plist = Qnil,
.function = Qnil,
.value = Qnil,
.is_constant = true,
.value_doc = Qnil,
.is_const_value = true,
.is_const_func = false,
.is_special_var = true,
};
DEF_STATIC_STRING(_Qunbound_name, "unbound");
@ -50,7 +42,10 @@ LispSymbol _Qunbound = {
.plist = Qnil,
.function = Qnil,
.value = Qunbound,
.is_constant = true,
.value_doc = Qnil,
.is_const_value = true,
.is_const_func = true,
.is_special_var = true,
};
DEF_STATIC_STRING(_Qt_name, "t");
@ -61,7 +56,10 @@ LispSymbol _Qt = {
.plist = Qnil,
.function = Qnil,
.value = Qt,
.is_constant = true,
.value_doc = Qnil,
.is_const_value = true,
.is_const_func = true,
.is_special_var = true,
};
// ###########################
@ -78,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 #
// ############################
@ -136,6 +143,7 @@ static bool held_refs_callback(void *obj, RefcountList **held, void *ignored) {
*held = refcount_list_push(*held, ((LispSymbol *) obj)->function);
*held = refcount_list_push(*held, ((LispSymbol *) obj)->plist);
*held = refcount_list_push(*held, ((LispSymbol *) obj)->value);
*held = refcount_list_push(*held, ((LispSymbol *) obj)->value_doc);
return true;
case TYPE_PAIR:
*held = refcount_list_push(*held, ((LispPair *) obj)->head);
@ -186,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();
}
@ -221,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:
@ -260,7 +277,10 @@ LispVal *make_lisp_symbol(LispVal *name) {
self->plist = Qnil;
self->function = Qnil;
self->value = Qunbound;
self->is_constant = false;
self->value_doc = Qnil;
self->is_const_value = false;
self->is_const_func = false;
self->is_special_var = false;
return LISPVAL(self);
}
@ -395,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:
@ -417,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();
}
@ -440,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);
@ -522,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;
@ -538,6 +596,10 @@ DEFUN(equal, "equal", (LispVal * obj1, LispVal *obj2), "(obj1 obj2)",
}
return Qt;
}
case TYPE_RECORD: {
// TODO implement this
return Qnil;
}
default:
abort();
}
@ -562,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)",
@ -579,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 #
// ##################################
@ -634,7 +717,8 @@ static LispVal **process_builtin_args(LispVal *fname, LispFunction *func,
goto key_no_val;
}
vec[oad->index] = refcount_ref(HEAD(arg));
} else if (KEYWORDP(arg) && !func->allow_other_keys && NILP(rest)) {
} else if (KEYWORDP(arg) && !func->allow_other_keys
&& NILP(func->rest_arg)) {
goto unknown_key;
} else if (NILP(func->rest_arg)) {
goto too_many;
@ -732,6 +816,14 @@ static LispVal *call_builtin(LispVal *name, LispFunction *func, LispVal *args,
return retval;
}
static void new_lexical_var(LispVal **lexenv, LispVal *name, LispVal *value) {
if (SPECIALP(name)) {
push_to_lexenv(&the_stack->dynenv, name, value);
} else {
push_to_lexenv(lexenv, name, value);
}
}
static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args,
LispVal **lexenv) {
LispVal *added_kwds = make_lisp_hashtable(Qnil, Qnil);
@ -747,7 +839,7 @@ static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args,
mode = OPT;
continue; // skip increment
}
push_to_lexenv(lexenv, HEAD(rargs), arg);
new_lexical_var(lexenv, HEAD(rargs), arg);
rargs = TAIL(rargs);
} break;
case OPT: {
@ -756,9 +848,9 @@ static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args,
continue; // skip increment
}
struct OptArgDesc *oad = USERPTR(struct OptArgDesc, HEAD(oargs));
push_to_lexenv(lexenv, oad->name, arg);
new_lexical_var(lexenv, oad->name, arg);
if (!NILP(oad->pred_var)) {
push_to_lexenv(lexenv, oad->pred_var, Qt);
new_lexical_var(lexenv, oad->pred_var, Qt);
}
oargs = TAIL(oargs);
} break;
@ -782,9 +874,9 @@ static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args,
}
LispVal *value = HEAD(args);
puthash(added_kwds, oad->name, Qt);
push_to_lexenv(lexenv, oad->name, value);
new_lexical_var(lexenv, oad->name, value);
if (!NILP(oad->pred_var)) {
push_to_lexenv(lexenv, oad->pred_var, Qt);
new_lexical_var(lexenv, oad->pred_var, Qt);
}
break;
case REST:
@ -800,7 +892,7 @@ static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args,
goto too_many_args;
}
}
push_to_lexenv(lexenv, func->rest_arg, args);
new_lexical_var(lexenv, func->rest_arg, args);
// done processing
goto done_adding;
}
@ -815,24 +907,24 @@ static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args,
// only check the current function's lexenv and not its parents'
if (NILP(gethash(added_kwds, oad->name, Qnil))) {
LispVal *eval_res = Feval(oad->default_form, the_stack->lexenv);
push_to_lexenv(lexenv, oad->name, eval_res);
new_lexical_var(lexenv, oad->name, eval_res);
refcount_unref(eval_res);
if (!NILP(oad->pred_var)) {
push_to_lexenv(lexenv, oad->pred_var, Qnil);
new_lexical_var(lexenv, oad->pred_var, Qnil);
}
}
}
FOREACH(arg, oargs) {
struct OptArgDesc *oad = USERPTR(struct OptArgDesc, arg);
LispVal *default_val = Feval(oad->default_form, the_stack->lexenv);
push_to_lexenv(lexenv, oad->name, default_val);
new_lexical_var(lexenv, oad->name, default_val);
refcount_unref(default_val);
if (!NILP(oad->pred_var)) {
push_to_lexenv(lexenv, oad->pred_var, Qnil);
new_lexical_var(lexenv, oad->pred_var, Qnil);
}
}
if (!NILP(func->rest_arg)) {
push_to_lexenv(lexenv, func->rest_arg, Qnil);
new_lexical_var(lexenv, func->rest_arg, Qnil);
}
done_adding:
cancel_cleanup(cl_handle);
@ -891,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)) {
@ -949,14 +1036,27 @@ static inline LispVal *find_in_lexenv(LispVal *lexenv, LispVal *key) {
return Fplist_get(lexenv, key, Qunbound, Qnil);
}
static inline LispVal *find_dynamic_value_on_stack(LispVal *key) {
if (!the_stack) {
return Qunbound;
}
return Fplist_get(the_stack->dynenv, key, Qunbound, Qnil);
}
static LispVal *symbol_value_in_lexenv(LispVal *lexenv, LispVal *key) {
if (!NILP(lexenv)) {
CHECK_TYPE(TYPE_SYMBOL, key);
if (SPECIALP(key)) {
LispVal *local = find_dynamic_value_on_stack(key);
if (local != Qunbound) {
return local;
}
} else if (!NILP(lexenv)) {
LispVal *local = find_in_lexenv(lexenv, key);
if (local != Qunbound) {
return local;
}
}
LispVal *sym_val = Fsymbol_value(key);
LispVal *sym_val = Fsymbol_value(key, Qt);
if (sym_val != Qunbound) {
return sym_val;
}
@ -973,13 +1073,13 @@ 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:
if (KEYWORDP(form)) {
return refcount_ref(form);
} else {
// this refs its return value
return symbol_value_in_lexenv(lexenv, form);
}
case TYPE_VECTOR: {
@ -1363,13 +1463,20 @@ DEFMACRO(if, "if", (LispVal * cond, LispVal *t, LispVal *nil),
static void set_symbol_in_lexenv(LispVal *key, LispVal *newval,
LispVal *lexenv) {
LispVal *lexval = Fplist_assoc(lexenv, key, Qnil);
if (PAIRP(lexval)) {
Fsethead(TAIL(lexval), newval);
if (VALUE_CONSTANTP(key)) {
Fthrow(Qconstant_value_error, Fpair(key, Qnil));
}
LispVal *val_pair = Qnil;
if (SPECIALP(key)) {
val_pair = Fplist_assoc(the_stack->dynenv, key, Qnil);
} else {
val_pair = Fplist_assoc(lexenv, key, Qnil);
}
if (PAIRP(val_pair)) {
Fsethead(TAIL(val_pair), newval);
} else {
refcount_ref(newval);
refcount_unref(((LispSymbol *) key)->value);
((LispSymbol *) key)->value = newval;
((LispSymbol *) key)->value = refcount_ref(newval);
}
}
@ -1388,7 +1495,9 @@ DEFMACRO(
LispVal *name = HEAD(tail);
tail = TAIL(tail);
retval = Feval(HEAD(tail), the_stack->lexenv);
set_symbol_in_lexenv(name, retval, the_stack->lexenv);
WITH_CLEANUP(retval, {
set_symbol_in_lexenv(name, retval, the_stack->lexenv); //
});
}
return retval;
}
@ -2382,11 +2491,40 @@ DEFUN(keywordp, "keywordp", (LispVal * val), "(obj)",
return LISP_BOOL(KEYWORDP(val));
}
DEFUN(const_value_p, "const-value-p", (LispVal * val), "(obj)",
"Return non-nil if OBJ's value is constant.") {
CHECK_TYPE(TYPE_SYMBOL, val);
return LISP_BOOL(VALUE_CONSTANTP(val));
}
DEFUN(const_func_p, "const-func-p", (LispVal * val), "(obj)",
"Return non-nil if OBJ's value as a function is constant.") {
CHECK_TYPE(TYPE_SYMBOL, val);
return LISP_BOOL(FUNC_CONSTANTP(val));
}
DEFUN(specialp, "specialp", (LispVal * val), "(obj)",
"Return non-nil if OBJ is a special variable.") {
CHECK_TYPE(TYPE_SYMBOL, val);
return LISP_BOOL(SPECIALP(val));
}
DEFUN(make_symbol, "make-symbol", (LispVal * name), "(name)",
"Return a new uninterned symbol named NAME.") {
return make_lisp_symbol(name);
}
DEFUN(make_symbol_special, "make-symbol-special", (LispVal * sym), "(sym)",
"Make it so that SYM is a special symbol, that is, it is dynamically "
"bound.") {
CHECK_TYPE(TYPE_SYMBOL, sym);
if (VALUE_CONSTANTP(sym)) {
Fthrow(Qconstant_value_error, Fpair(sym, Qnil));
}
((LispSymbol *) sym)->is_special_var = true;
return refcount_ref(sym);
}
DEFUN(symbol_package, "symbol-package", (LispVal * symbol), "(symbol)",
"Return the package of SYMBOL.") {
CHECK_TYPE(TYPE_SYMBOL, symbol);
@ -2413,12 +2551,72 @@ DEFUN(symbol_function, "symbol-function", (LispVal * symbol, LispVal *resolve),
return refcount_ref(symbol);
}
DEFUN(symbol_value, "symbol-value", (LispVal * symbol), "(symbol)",
"Return the global value of SYMBOL.") {
DEFUN(fset, "fset", (LispVal * sym, LispVal *new_func), "(symbol func)",
"Set the value as a function of SYMBOL to FUNC.") {
CHECK_TYPE(TYPE_SYMBOL, sym);
LispSymbol *sobj = ((LispSymbol *) sym);
if (FUNC_CONSTANTP(sobj)) {
Fthrow(Qconstant_function_error, Fpair(sym, Qnil));
}
refcount_ref(new_func);
refcount_unref(sobj->function);
sobj->function = new_func;
return refcount_ref(new_func);
}
DEFUN(symbol_value, "symbol-value", (LispVal * symbol, LispVal *default_only),
"(symbol &opt default-only)", "Return the global value of SYMBOL.") {
CHECK_TYPE(TYPE_SYMBOL, symbol);
if (KEYWORDP(symbol)) {
return refcount_ref(symbol);
} else if (SPECIALP(symbol) && NILP(default_only)) {
LispVal *dynenv_entry = Fplist_assoc(the_stack->dynenv, symbol, Qnil);
if (!NILP(dynenv_entry)) {
return refcount_ref(HEAD(TAIL(dynenv_entry)));
}
}
return refcount_ref(((LispSymbol *) symbol)->value);
}
DEFUN(set, "set", (LispVal * symbol, LispVal *value, LispVal *default_only),
"(symbol value &opt default-only)",
"Set the global value of SYMBOL to VALUE.") {
CHECK_TYPE(TYPE_SYMBOL, symbol);
if (VALUE_CONSTANTP(symbol)) {
Fthrow(Qconstant_value_error, Fpair(symbol, Qnil));
}
if (SPECIALP(symbol) && NILP(default_only)) {
LispVal *dynenv_entry = Fplist_assoc(the_stack->dynenv, symbol, Qnil);
if (!NILP(dynenv_entry)) {
Fsethead(TAIL(dynenv_entry), value);
return refcount_ref(value);
}
}
LispSymbol *sobj = (LispSymbol *) symbol;
refcount_unref(sobj->value);
sobj->value = refcount_ref(value);
return refcount_ref(value);
}
DEFUN(symbol_value_docstr, "symbol-value-docstr", (LispVal * symbol),
"(symbol)", "Return the documentation for SYMBOL's value.") {
CHECK_TYPE(TYPE_SYMBOL, symbol);
return refcount_ref(((LispSymbol *) symbol)->value_doc);
}
DEFUN(set_symbol_value_docstr, "set-symbol-value-docstr",
(LispVal * symbol, LispVal *docstr), "(symbol value)",
"Set the documentation for SYMBOL's value.") {
CHECK_TYPE(TYPE_SYMBOL, symbol);
if (VALUE_CONSTANTP(symbol)) {
Fthrow(Qconstant_value_error, Fpair(symbol, Qnil));
}
LispSymbol *sobj = (LispSymbol *) symbol;
refcount_unref(sobj->value_doc);
sobj->value_doc = refcount_ref(docstr);
return refcount_ref(docstr);
}
DEFUN(symbol_plist, "symbol-plist", (LispVal * symbol), "(symbol)",
"Return the plist of SYMBOL.") {
CHECK_TYPE(TYPE_SYMBOL, symbol);
@ -2434,23 +2632,14 @@ DEFUN(setplist, "setplist", (LispVal * symbol, LispVal *plist),
return Qnil;
}
DEFUN(fset, "fset", (LispVal * sym, LispVal *new_func), "(symbol func)",
"Set the value as a function of SYMBOL to FUNC.") {
CHECK_TYPE(TYPE_SYMBOL, sym);
LispSymbol *sobj = ((LispSymbol *) sym);
// TODO make sure this is not constant
refcount_ref(new_func);
refcount_unref(sobj->function);
sobj->function = new_func;
return refcount_ref(new_func);
}
DEFUN(exported_symbol_p, "exported-symbol-p", (LispVal * symbol), "(symbol)",
"Return non-nil if SYMBOL is exported by its package.") {
CHECK_TYPE(TYPE_SYMBOL, symbol);
LispSymbol *sym = (LispSymbol *) symbol;
if (NILP(sym->package)) {
return Qnil;
} else if (KEYWORDP(symbol)) {
return Qt;
}
LispPackage *pkg = (LispPackage *) sym->package;
return Fgethash(pkg->exported_sym_table, LISPVAL(sym), Qnil);
@ -2568,7 +2757,13 @@ DEFUN(quote_symbol_for_read, "quote-symbol-for-read",
LispSymbol *sym = (LispSymbol *) target;
LispString *sym_name =
(LispString *) Fquote_symbol_name(LISPVAL(sym->name));
if (NILP(include_package)) {
if (KEYWORDP(target)) {
size_t size = sym_name->length + 1;
char *new_name = lisp_malloc(size + 1);
snprintf(new_name, size + 1, ":%s", sym_name->data);
refcount_unref(sym_name);
return make_lisp_string(new_name, size, true, false);
} else if (NILP(include_package)) {
return LISPVAL(sym_name);
} else if (include_package == Qkw_as_needed) {
void *cl_handler =
@ -3368,7 +3563,7 @@ LispVal *sprintf_lisp(const char *format, ...) {
va_end(args_measure);
char *buffer = lisp_malloc(size);
vsnprintf(buffer, size, format, args);
LispVal *obj = make_lisp_string(buffer, size, true, false);
LispVal *obj = make_lisp_string(buffer, size - 1, true, false);
va_end(args);
return obj;
}
@ -3384,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 #
// ################
@ -3398,24 +3662,39 @@ static inline int CHECK_IO_RESULT(int res, int fd) {
return res;
}
static int64_t internal_print(void *obj, int64_t fd, bool first_in_list) {
static int64_t internal_print(void *obj, int64_t fd, bool readably,
bool first_in_list) {
switch (TYPEOF(obj)) {
case TYPE_STRING: {
if (readably) {
LispVal *quoted = Fquote_string(obj);
int64_t rval = 0;
WITH_CLEANUP(quoted, {
rval = internal_print(quoted, fd, false, true); //
});
return rval;
} else {
LispString *str = obj;
return CHECK_IO_RESULT(write(fd, str->data, str->length), fd);
}
}
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, true); //
np = internal_print(name, fd, false, true); //
});
return np;
} break;
case TYPE_PAIR: {
if (HEAD(obj) == Qquote && PAIRP(TAIL(obj)) && NILP(TAIL(TAIL(obj)))) {
int64_t np = CHECK_IO_RESULT(dprintf(fd, "'"), fd);
np += internal_print(HEAD(TAIL(obj)), fd, true);
np += internal_print(HEAD(TAIL(obj)), fd, readably, true);
return np;
}
int64_t np;
@ -3424,11 +3703,11 @@ static int64_t internal_print(void *obj, int64_t fd, bool first_in_list) {
} else {
np = CHECK_IO_RESULT(dprintf(fd, " "), fd);
}
np += internal_print(HEAD(obj), fd, true);
np += internal_print(HEAD(obj), fd, readably, true);
if (TAIL(obj) == Qnil) {
np = CHECK_IO_RESULT(dprintf(fd, ")"), fd);
} else {
np += internal_print(TAIL(obj), fd, false);
np += internal_print(TAIL(obj), fd, readably, false);
}
return np;
}
@ -3436,7 +3715,7 @@ static int64_t internal_print(void *obj, int64_t fd, bool first_in_list) {
LispVector *v = obj;
int64_t np = CHECK_IO_RESULT(dprintf(fd, "["), fd);
for (size_t i = 0; i < v->length; ++i) {
np += internal_print(v->data[i], fd, true);
np += internal_print(v->data[i], fd, readably, true);
np += CHECK_IO_RESULT(dprintf(fd, " "), fd);
}
np += CHECK_IO_RESULT(dprintf(fd, "]"), fd);
@ -3468,7 +3747,7 @@ static int64_t internal_print(void *obj, int64_t fd, bool first_in_list) {
np = CHECK_IO_RESULT(dprintf(fd, "<function "), fd);
}
if (need_name) {
np += internal_print(fn->name, fd, true);
np += internal_print(fn->name, fd, readably, true);
np += CHECK_IO_RESULT(dprintf(fd, " "), fd);
}
np += CHECK_IO_RESULT(dprintf(fd, "at %#jx>", (uintmax_t) obj), fd);
@ -3479,21 +3758,26 @@ static int64_t internal_print(void *obj, int64_t fd, bool first_in_list) {
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, true);
np += internal_print(eq_fn, fd, readably, true);
np += CHECK_IO_RESULT(dprintf(fd, " hash-fn="), fd);
np += internal_print(hash_fn, fd, true);
np += internal_print(hash_fn, fd, readably, true);
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);
LispVal *name_str = Fquote_string(LISPVAL(pkg->name));
WITH_CLEANUP(name_str, {
np += internal_print(name_str, fd, true); //
np += internal_print(name_str, fd, readably, true); //
});
np += CHECK_IO_RESULT(
dprintf(fd, " interned=%ju at %#jx>",
@ -3502,20 +3786,30 @@ static int64_t internal_print(void *obj, int64_t fd, bool first_in_list) {
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();
}
}
DEFUN_DISTINGUISHED(print, "print", (LispVal * obj, LispVal *stream),
"(obj &opt stream)",
DEFUN_DISTINGUISHED(print, "print",
(LispVal * obj, LispVal *readably, LispVal *stream),
"(obj &opt readably stream)",
"Write a human readable representation of OBJ to STREAM, "
"defaulting to the standard output.") {
"defaulting to the standard output. With READABLY non-nil, "
"print OBJ in a way that it can be read back.") {
int64_t fd;
if (stream == Qunbound) {
fd = 1;
@ -3526,12 +3820,15 @@ DEFUN_DISTINGUISHED(print, "print", (LispVal * obj, LispVal *stream),
Fthrow(Qtype_error, const_list(true, 1, stream));
}
}
return make_lisp_integer(internal_print(obj, fd, false));
bool readably_bool = readably != Qunbound && !NILP(readably);
return make_lisp_integer(internal_print(obj, fd, readably_bool, true));
}
DEFUN_DISTINGUISHED(
println, "println", (LispVal * obj, LispVal *stream), "(obj &opt stream)",
"Call print with OBJ and STREAM, then write a newline to STREAM.") {
println, "println", (LispVal * obj, LispVal *readably, LispVal *stream),
"(obj &opt readably stream)",
"Call print with OBJ and STREAM, then write a newline to STREAM. With "
"READABLY non-nil, print OBJ in a way that it can be read back.") {
static char NEWLINE = '\n';
int64_t fd;
if (stream == Qunbound) {
@ -3545,7 +3842,8 @@ DEFUN_DISTINGUISHED(
}
int64_t np = 0;
if (obj != Qunbound) {
np += internal_print(obj, fd, true);
bool readably_bool = readably != Qunbound && !NILP(readably);
np += internal_print(obj, fd, readably_bool, true);
}
np += CHECK_IO_RESULT(write(fd, &NEWLINE, 1), fd);
fsync(fd);
@ -3603,11 +3901,14 @@ DEFUN(throw, "throw", (LispVal * signal, LispVal *rest), "(signal &rest rest)",
LispVal *var = HEAD(handler);
LispVal *form = TAIL(handler);
WITH_PUSH_FRAME(Qnil, Qnil, true, {
WITH_CLEANUP(error_arg, {
if (!NILP(var)) {
// TODO make sure this isn't constant
CHECK_TYPE(TYPE_SYMBOL, var);
if (VALUE_CONSTANTP(var)) {
Fthrow(Qconstant_value_error, Fpair(var, Qnil));
}
push_to_lexenv(&the_stack->lexenv, var, error_arg);
}
WITH_CLEANUP(error_arg, {
stack_return = Feval(form, the_stack->lexenv); //
});
});
@ -3656,6 +3957,7 @@ void stack_enter(LispVal *name, LispVal *detail, bool inherit) {
if (inherit && the_stack) {
frame->lexenv = refcount_ref(the_stack->lexenv);
}
frame->dynenv = the_stack ? refcount_ref(the_stack->dynenv) : Qnil;
frame->enable_handlers = true;
frame->handlers = make_lisp_hashtable(Qnil, Qnil);
frame->unwind_form = Qnil;
@ -3672,6 +3974,7 @@ void stack_leave(void) {
refcount_unref(frame->return_tag);
refcount_unref(frame->detail);
refcount_unref(frame->lexenv);
refcount_unref(frame->dynenv);
refcount_unref(frame->handlers);
while (frame->cleanup_handlers) {
frame->cleanup_handlers->fun(frame->cleanup_handlers->data);
@ -3741,9 +4044,12 @@ void cancel_cleanup(void *handle) {
// # Errors and Conditions #
// #########################
DEF_STATIC_SYMBOL(shutdown_signal, "shutdown-signal");
DEF_STATIC_SYMBOL(error, "error");
DEF_STATIC_SYMBOL(type_error, "type-error");
DEF_STATIC_SYMBOL(read_error, "read-error");
DEF_STATIC_SYMBOL(unclosed_error, "read-error");
DEF_STATIC_SYMBOL(constant_function_error, "constant-function-error");
DEF_STATIC_SYMBOL(constant_value_error, "constant-value-error");
DEF_STATIC_SYMBOL(eof_error, "eof-error");
DEF_STATIC_SYMBOL(void_variable_error, "void-variable-error");
DEF_STATIC_SYMBOL(void_function_error, "void-function-error");
@ -3859,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);
@ -3917,14 +4231,25 @@ static void register_symbols_and_functions(void) {
REGISTER_SYMBOL(comma);
REGISTER_SYMBOL(comma_at);
REGISTER_SYMBOL(backquote);
REGISTER_SYMBOL_INTO(kw_success, keyword_package);
REGISTER_SYMBOL_INTO(kw_finally, keyword_package);
REGISTER_SYMBOL_INTO(kw_as_needed, keyword_package);
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);
REGISTER_SYMBOL(shutdown_signal);
REGISTER_SYMBOL(error);
REGISTER_SYMBOL(type_error);
REGISTER_SYMBOL(read_error);
REGISTER_SYMBOL(eof_error);
REGISTER_SYMBOL(unclosed_error);
REGISTER_SYMBOL(constant_function_error);
REGISTER_SYMBOL(constant_value_error);
REGISTER_SYMBOL(void_variable_error);
REGISTER_SYMBOL(void_function_error);
REGISTER_SYMBOL(circular_error);
@ -3955,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 #
@ -4032,14 +4359,21 @@ static void register_symbols_and_functions(void) {
// ####################
REGISTER_FUNCTION(symbolp);
REGISTER_FUNCTION(keywordp);
REGISTER_FUNCTION(const_value_p);
REGISTER_FUNCTION(const_func_p);
REGISTER_FUNCTION(specialp);
REGISTER_FUNCTION(make_symbol);
REGISTER_FUNCTION(make_symbol_special);
REGISTER_FUNCTION(symbol_package);
REGISTER_FUNCTION(symbol_name);
REGISTER_FUNCTION(symbol_function);
REGISTER_FUNCTION(fset);
REGISTER_FUNCTION(symbol_value);
REGISTER_FUNCTION(set);
REGISTER_FUNCTION(symbol_value_docstr);
REGISTER_FUNCTION(set_symbol_value_docstr);
REGISTER_FUNCTION(symbol_plist);
REGISTER_FUNCTION(setplist);
REGISTER_FUNCTION(fset);
REGISTER_FUNCTION(exported_symbol_p);
REGISTER_FUNCTION(intern_soft);
REGISTER_FUNCTION(intern);
@ -4093,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 #
// ################

100
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;
@ -67,7 +65,10 @@ typedef struct {
LispVal *plist;
LispVal *function;
LispVal *value;
bool is_constant;
LispVal *value_doc;
unsigned int is_const_value : 1;
unsigned int is_const_func : 1;
unsigned int is_special_var : 1;
} LispSymbol;
typedef struct {
@ -164,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 #
@ -198,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 #
// ############################
@ -213,7 +223,9 @@ extern LispVal *current_package;
#define TYPEOF(v) (LISPVAL(v)->type)
// only use on symbols!
#define VALUE_CONSTANTP(v) (((LispSymbol *) (v))->is_constant)
#define VALUE_CONSTANTP(v) (((LispSymbol *) (v))->is_const_value || KEYWORDP(v))
#define FUNC_CONSTANTP(v) (((LispSymbol *) (v))->is_const_func)
#define SPECIALP(v) (((LispSymbol *) (v))->is_special_var)
#define NILP(v) (((void *) (v)) == (void *) Qnil)
#define STRINGP(v) (TYPEOF(v) == TYPE_STRING)
@ -226,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)
@ -260,7 +273,10 @@ inline static bool NUMBERP(LispVal *v) {
.plist = Qnil, \
.function = Qnil, \
.value = Qunbound, \
.is_constant = false, \
.value_doc = Qnil, \
.is_const_value = false, \
.is_const_func = false, \
.is_special_var = false, \
}; \
LispVal *Q##c_name = LISPVAL(&_Q##c_name)
#define DECLARE_FUNCTION(c_name, args) \
@ -295,8 +311,11 @@ inline static bool NUMBERP(LispVal *v) {
.package = Qnil, \
.plist = Qnil, \
.value = Qunbound, \
.value_doc = Qnil, \
.function = LISPVAL(&_Q##c_name##_function), \
.is_constant = false, \
.is_const_value = false, \
.is_const_func = true, \
.is_special_var = false, \
}; \
LispVal *Q##c_name = (LispVal *) &_Q##c_name; \
static_kw LispVal *F##c_name c_args
@ -329,6 +348,11 @@ inline static bool NUMBERP(LispVal *v) {
#define REGISTER_SYMBOL_INTO(sym, pkg) \
REGISTER_SYMBOL_NOINTERN(sym) \
REGISTER_DO_INTERN(sym, pkg)
#define REGISTER_KEYWORD(sym) \
REGISTER_SYMBOL_NOINTERN(sym) \
REGISTER_DO_INTERN(sym, keyword_package) \
((LispSymbol *) Q##sym)->is_const_value = true; \
((LispSymbol *) Q##sym)->is_special_var = true;
#define REGISTER_SYMBOL(sym) REGISTER_SYMBOL_INTO(sym, system_package)
#define REGISTER_STATIC_FUNCTION(name) \
REGISTER_SYMBOL_NOINTERN(name); \
@ -393,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);
@ -413,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 #
@ -506,14 +542,22 @@ LispVal *find_package(const char *name, size_t length);
// ####################
DECLARE_FUNCTION(symbolp, (LispVal * val));
DECLARE_FUNCTION(keywordp, (LispVal * val));
DECLARE_FUNCTION(const_value_p, (LispVal * val));
DECLARE_FUNCTION(const_func_p, (LispVal * val));
DECLARE_FUNCTION(specialp, (LispVal * val));
DECLARE_FUNCTION(make_symbol, (LispVal * name));
DECLARE_FUNCTION(make_symbol_special, (LispVal * sym));
DECLARE_FUNCTION(symbol_package, (LispVal * symbol));
DECLARE_FUNCTION(symbol_name, (LispVal * symbol));
DECLARE_FUNCTION(symbol_function, (LispVal * symbol, LispVal *resolve));
DECLARE_FUNCTION(symbol_value, (LispVal * symbol));
DECLARE_FUNCTION(fset, (LispVal * sym, LispVal *new_func));
DECLARE_FUNCTION(symbol_value, (LispVal * symbol, LispVal *default_only));
DECLARE_FUNCTION(set,
(LispVal * symbol, LispVal *value, LispVal *default_only));
DECLARE_FUNCTION(symbol_value_docstr, (LispVal * symbol));
DECLARE_FUNCTION(set_symbol_value_docstr, (LispVal * symbol, LispVal *docstr));
DECLARE_FUNCTION(symbol_plist, (LispVal * symbol));
DECLARE_FUNCTION(setplist, (LispVal * symbol, LispVal *plist));
DECLARE_FUNCTION(fset, (LispVal * sym, LispVal *new_func));
DECLARE_FUNCTION(exported_symbol_p, (LispVal * symbol));
DECLARE_FUNCTION(intern_soft, (LispVal * name, LispVal *def, LispVal *package,
LispVal *included_too));
@ -586,11 +630,23 @@ 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 #
// ################
DECLARE_FUNCTION(print, (LispVal * obj, LispVal *stream));
DECLARE_FUNCTION(println, (LispVal * obj, LispVal *stream));
DECLARE_FUNCTION(print, (LispVal * obj, LispVal *readably, LispVal *stream));
DECLARE_FUNCTION(println, (LispVal * obj, LispVal *readably, LispVal *stream));
// ########################
// # Lexenv and the Stack #
@ -615,6 +671,7 @@ typedef struct StackFrame {
LispVal *return_tag;
LispVal *detail; // function arguments
LispVal *lexenv; // symbol -> value
LispVal *dynenv; // symbol -> value (for dynamic variables)
bool enable_handlers;
LispVal *handlers; // symbol -> (error-var form)
LispVal *unwind_form;
@ -693,10 +750,13 @@ void cancel_cleanup(void *handle);
// # Errors and Conditions #
// #########################
extern LispVal *Qshutdown_signal;
extern LispVal *Qerror;
extern LispVal *Qtype_error;
extern LispVal *Qread_error;
extern LispVal *Qeof_error;
extern LispVal *Qunclosed_error;
extern LispVal *Qconstant_function_error;
extern LispVal *Qconstant_value_error;
extern LispVal *Qvoid_variable_error;
extern LispVal *Qvoid_function_error;
extern LispVal *Qcircular_error;

9
src/main.c
View File

@ -23,14 +23,19 @@ STATIC_DEFUN(toplevel_error_handler, "toplevel-error-handler",
LispVal *backtrace = HEAD(TAIL(except));
fprintf(stderr, "Caught signal of type ");
debug_dump(stderr, type, true);
LispVal *stream = make_lisp_integer(fileno(stderr));
if (!NILP(detail)) {
fprintf(stderr, "Details: ");
debug_dump(stderr, detail, true);
Fprintln(detail, Qt, stream);
}
fprintf(stderr, "\nBacktrace (toplevel comes last):\n");
FOREACH(frame, backtrace) {
fprintf(stderr, " ");
debug_dump(stderr, frame, true);
Fprint(frame, Qt, stream);
if (SYMBOLP(HEAD(frame)) && !NILP(Fmacrop(HEAD(frame), Qnil))) {
fprintf(stderr, " ;; macro");
}
fputc('\n', stderr);
}
exit_status = 1;
return Qnil;