From 4f1c2fea55aed3255a37e04617d769b0e7fdab79 Mon Sep 17 00:00:00 2001 From: Alexander Rosenberg Date: Sat, 20 Sep 2025 19:26:38 -0700 Subject: [PATCH] Beginnings of a common lisp-like type system --- src/kernel.sl | 156 +++++++++++++++++++++++++++++++++++++------------- src/lisp.c | 67 ++++++++++++++-------- 2 files changed, 159 insertions(+), 64 deletions(-) diff --git a/src/kernel.sl b/src/kernel.sl index 46dfc5c..5d30198 100644 --- a/src/kernel.sl +++ b/src/kernel.sl @@ -37,12 +37,15 @@ (defmacro dolist (vars &rest body) (funcall (lambda (tail-var) - (list 'progn - (list 'setq tail-var (second vars)) - (list 'while tail-var - (list 'funcall (apply 'list 'lambda (list (first vars)) body) - (list 'head tail-var)) - (list 'setq tail-var (list 'tail tail-var))))) + (list 'funcall + (list + 'lambda (list tail-var) + (list 'setq tail-var (second vars)) + (list 'while tail-var + (list 'funcall (apply 'list 'lambda (list (first vars)) body) + (list 'head tail-var)) + (list 'setq tail-var (list 'tail tail-var)))) + (second vars))) (make-symbol "tail"))) (defun maphead (func list) @@ -92,6 +95,11 @@ body) (reverse vals))))) +(defmacro let* (bindings &rest body) + (list 'funcall (apply 'list 'lambda (apply 'list '&opt bindings) + (list 'declare (list 'name (make-symbol "let*"))) + body))) + (defun lasttail (list) "Return the last pair in LIST." (let (out) @@ -102,47 +110,26 @@ (defun internal-expand-single-cond (cond) (if (tail cond) - (list 'if (head cond) - (apply 'list 'progn (tail cond))) - (let ((res-var (make-symbol "res"))) - (list 'let (list (list res-var (head cond))) - (list 'if res-var res-var))))) + (let ((res (list 'if (head cond) + (apply 'list 'progn (tail cond))))) + (pair res res)) + (let* ((res-var (make-symbol "res")) + (if-stmt (list 'if res-var res-var))) + (pair (list 'let (list (list res-var (head cond))) + if-stmt) + if-stmt)))) (defmacro cond (&rest conds) (let (out last-if) (dolist (cond conds) - (if (not out) - (setq out (internal-expand-single-cond cond) - last-if out) - (let ((new-if (internal-expand-single-cond cond))) - (settail (lasttail last-if) (list new-if)) - (setq last-if new-if)))) + (let ((res (internal-expand-single-cond cond))) + (if (not out) + (setq out (head res) + last-if (tail res)) + (settail (lasttail last-if) (list (head res))) + (setq last-if (tail res))))) out)) -(defmacro tcase (obj &rest conds) - (let ((obj-var (make-symbol "obj"))) - (list 'let (list (list obj-var obj)) - (pair - 'cond - (maphead - (lambda (cond) - (let ((pred (pair 'or (maphead - (lambda (elt) - (if (eq elt t) - t - (list 'eq (list 'type-of obj-var) - (list '\' elt)))) - (ensure-list (head cond)))))) - (pair pred (tail cond)))) - conds))))) - -(defmacro unwind-protect (form &rest unwind-forms) - (list 'condition-case form - (pair :finally unwind-forms))) - -(defmacro return (&opt value) - (list 'return-from nil value)) - (defun put (symbol key value) (setplist symbol (plist-set (symbol-plist symbol) key value))) @@ -152,6 +139,93 @@ (defun remprop (symbol key) (setplist symbol (plist-rem (symbol-plist symbol) key))) +(defmacro define-type-predicate (name args &rest body) + (cond + ((eq args 'alias) + (let ((var (make-symbol "var"))) + (list 'put (list '\' name) ''type-predicate + (list 'lambda (list var) (list 'typep var (pair '\' body)))))) + ((and (symbolp args) (null body)) + (list 'put (list '\' name) ''type-predicate (list '\' args))) + (t + (list 'put (list '\' name) ''type-predicate + (apply 'list 'lambda args + (list 'declare (list 'name name)) + body))))) + +(defun typep (obj type) + (let* ((name (if (pairp type) + (head type) + type)) + (pred (get name 'type-predicate)) + (args (and (pairp type) (tail type)))) + (unless pred + (throw 'void-function-error)) + (apply pred obj args))) + +(define-type-predicate any (obj) t) +(define-type-predicate t alias any) +(define-type-predicate or (obj &rest preds) + (dolist (pred preds) + (let ((res (typep obj pred))) + (when res + (return-from or res)))) + nil) +(define-type-predicate and (obj &rest preds) + (let (res) + (dolist (pred preds) + (unless (setq res (typep obj pred)) + (return-from and nil))) + res)) +(define-type-predicate pred (obj pred) + (funcall pred obj)) +(define-type-predicate null not) +(define-type-predicate string stringp) +(define-type-predicate symbol symbolp) +(define-type-predicate pair pairp) +(define-type-predicate integer (obj &opt min max) + (and (integerp obj) + (or (not min) (>= obj min)) + (or (not max) (<= obj max)))) +(define-type-predicate byte alias (integer -128 127)) +(define-type-predicate signed-byte alias byte) +(define-type-predicate unsigned-byte alias (integer 0 255)) +(define-type-predicate float (obj &opt min max) + (and (floatp obj) + (or (not min) (>= obj min)) + (or (not max) (<= obj max)))) +(define-type-predicate vector vectorp) +(define-type-predicate function functionp) +(define-type-predicate hashtable hashtablep) +(define-type-predicate user-pointer user-pointer-p) +(define-type-predicate number (obj &opt min max) + (typep obj (list 'or (list 'float min max) + (list 'integer min max)))) + +(defun symbol-type-predicate (symbol) + "Return the type predicate associated with SYMBOL." + (get symbol 'type-predicate)) + +(defmacro tcase (obj &rest conds) + (let ((obj-var (make-symbol "obj"))) + (list 'let (list (list obj-var obj)) + (pair + 'cond + (maphead + (lambda (cond) + (let ((pred (head cond)) + (body (tail cond))) + (pair (list 'typep obj-var (list '\' pred)) + body))) + conds))))) + +(defmacro unwind-protect (form &rest unwind-forms) + (list 'condition-case form + (pair :finally unwind-forms))) + +(defmacro return (&opt value) + (list 'return-from nil value)) + (defmacro dotails (vars &rest body) (let ((cur (make-symbol "cur"))) (list 'let (list (list cur (second vars))) diff --git a/src/lisp.c b/src/lisp.c index 8f875b8..969e9d9 100644 --- a/src/lisp.c +++ b/src/lisp.c @@ -380,7 +380,12 @@ LispVal *make_lisp_function(LispVal *name, LispVal *return_tag, LispVal *args, self->oargs = Qnil; self->rest_arg = Qnil; self->kwargs = Qnil; - void *cl = register_cleanup(&lisp_free, self); + self->name = Qnil; + self->return_tag = Qnil; + self->lexenv = Qnil; + self->doc = Qnil; + self->body = Qnil; + void *cl = register_cleanup(&refcount_unref_as_callback, self); set_function_args(self, args); cancel_cleanup(cl); @@ -1390,6 +1395,7 @@ static LispVal *call_builtin(LispVal *name, LispFunction *func, LispVal *args, static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args, LispVal **lexenv) { LispVal *added_kwds = make_lisp_hashtable(Qnil, Qnil); + void *cl_handle = register_cleanup(&refcount_unref_as_callback, added_kwds); enum { REQ, OPT, KEY, REST } mode = REQ; LispVal *rargs = func->rargs; LispVal *oargs = func->oargs; @@ -1491,6 +1497,7 @@ static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args, push_to_lexenv(lexenv, func->rest_arg, Qnil); } done_adding: + cancel_cleanup(cl_handle); refcount_unref(added_kwds); return; // TODO different messages @@ -1498,6 +1505,7 @@ missing_required: too_many_args: missing_value: unknown_key: + cancel_cleanup(cl_handle); refcount_unref(added_kwds); Fthrow(Qargument_error, Fpair(fname, Qnil)); } @@ -2285,14 +2293,18 @@ DEFMACRO(defun, "defun", (LispVal * name, LispVal *args, LispVal *body)) { } LispVal *return_tag = make_lisp_symbol(LISPVAL(((LispSymbol *) name)->name)); - LispVal *exp_args = Fcopy_list(args); - expand_lambda_list_for_toplevel(exp_args); - LispVal *expanded_body = expand_function_body(name, return_tag, body); LispVal *func = Qnil; - WITH_CLEANUP(exp_args, { - WITH_CLEANUP(expanded_body, { - func = make_lisp_function(name, return_tag, exp_args, - the_stack->lexenv, expanded_body, false); + WITH_CLEANUP(return_tag, { + LispVal *exp_args = Fcopy_list(args); + WITH_CLEANUP(exp_args, { + expand_lambda_list_for_toplevel(exp_args); + LispVal *expanded_body = + expand_function_body(name, return_tag, body); + WITH_CLEANUP(expanded_body, { + func = + make_lisp_function(name, return_tag, exp_args, + the_stack->lexenv, expanded_body, false); + }); }); }); refcount_unref(Ffset(name, func)); @@ -2306,14 +2318,18 @@ DEFMACRO(defmacro, "defmacro", (LispVal * name, LispVal *args, LispVal *body)) { } LispVal *return_tag = make_lisp_symbol(LISPVAL(((LispSymbol *) name)->name)); - LispVal *exp_args = Fcopy_list(args); - expand_lambda_list_for_toplevel(exp_args); - LispVal *expanded_body = expand_function_body(name, return_tag, body); LispVal *func = Qnil; - WITH_CLEANUP(exp_args, { - WITH_CLEANUP(expanded_body, { - func = make_lisp_function(name, return_tag, exp_args, - the_stack->lexenv, expanded_body, true); + WITH_CLEANUP(return_tag, { + LispVal *exp_args = Fcopy_list(args); + WITH_CLEANUP(exp_args, { + expand_lambda_list_for_toplevel(exp_args); + LispVal *expanded_body = + expand_function_body(name, return_tag, body); + WITH_CLEANUP(expanded_body, { + func = + make_lisp_function(name, return_tag, exp_args, + the_stack->lexenv, expanded_body, true); + }); }); }); refcount_unref(Ffset(name, func)); @@ -2336,14 +2352,18 @@ DEFMACRO(lambda, "lambda", (LispVal * args, LispVal *body)) { return_tag = make_lisp_symbol(LISPVAL(((LispSymbol *) name)->name)); tag_name = name; } - LispVal *expanded_body = expand_function_body(tag_name, return_tag, body); - LispVal *exp_args = Fcopy_list(args); - expand_lambda_list_for_toplevel(exp_args); LispVal *func = Qnil; - WITH_CLEANUP(exp_args, { - WITH_CLEANUP(expanded_body, { - func = make_lisp_function(name, return_tag, args, the_stack->lexenv, - expanded_body, false); + WITH_CLEANUP(return_tag, { + LispVal *expanded_body = + expand_function_body(tag_name, return_tag, body); + LispVal *exp_args = Fcopy_list(args); + WITH_CLEANUP(exp_args, { + expand_lambda_list_for_toplevel(exp_args); + WITH_CLEANUP(expanded_body, { + func = + make_lisp_function(name, return_tag, args, + the_stack->lexenv, expanded_body, false); + }); }); }); return func; @@ -2580,7 +2600,8 @@ DEFUN(plist_set, "plist-set", if (NILP(TAIL(cur))) { break; } - return refcount_ref(HEAD(TAIL(cur))); + Fsethead(TAIL(cur), value); + return refcount_ref(plist); } } return push_many(plist, 2, value, key);