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

Beginnings of a common lisp-like type system

Browse Source
This commit is contained in:
Alexander Rosenberg
2025-09-20 19:26:38 -07:00
parent bdb4bf6824
commit 4f1c2fea55
2 changed files with 159 additions and 64 deletions
Download Patch File Download Diff File Expand all files Collapse all files

156
src/kernel.sl
View File

@ -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)))

67
src/lisp.c
View File

@ -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);