Beginnings of a common lisp-like type system

src/kernel.sl

@@ -37,12 +37,15 @@
 (defmacro dolist (vars &rest body)
   (funcall
    (lambda (tail-var)
-     (list 'progn
+     (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)))))
+                  (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)
+      (let ((res (list 'if (head cond)
-            (apply 'list 'progn (tail cond)))
+                       (apply 'list 'progn (tail cond)))))
-    (let ((res-var (make-symbol "res")))
+        (pair res res))
-      (list 'let (list (list res-var (head cond)))
+    (let* ((res-var (make-symbol "res"))
-            (list 'if res-var res-var)))))
+           (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)
+      (let ((res (internal-expand-single-cond cond)))
         (if (not out)
-          (setq out (internal-expand-single-cond cond)
+            (setq out (head res)
-                last-if out)
+                  last-if (tail res))
-        (let ((new-if (internal-expand-single-cond cond)))
+          (settail (lasttail last-if) (list (head res)))
-          (settail (lasttail last-if) (list new-if))
+          (setq last-if (tail res)))))
-          (setq last-if new-if))))
     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)))

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,16 +2293,20 @@ 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(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,
+                func =
+                    make_lisp_function(name, return_tag, exp_args,
                                        the_stack->lexenv, expanded_body, false);
             });
         });
+    });
     refcount_unref(Ffset(name, func));
     return func;
 }
@@ -2306,16 +2318,20 @@ 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(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,
+                func =
+                    make_lisp_function(name, return_tag, exp_args,
                                        the_stack->lexenv, expanded_body, true);
             });
         });
+    });
     refcount_unref(Ffset(name, func));
     return 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(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,
+                func =
-                                      expanded_body, false);
+                    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);