Fix soome stuff

lisp/kernel.gl

@@ -1,23 +1,26 @@
 ;; -*- mode: lisp-data -*-
 
 ;; Defining macros and functions
-(fset 'defmacro (cons 'macro
+(fset 'defmacro
-                      (lambda (name lambda-list &rest body)
+      (cons 'macro
-                        "Define NAME to be a macro."
+            (lambda (name lambda-list &rest body)
-                        (declare (name defmacro))
+              "Define NAME to be a macro."
-                        (list 'fset (list 'quote name)
+              (declare (name defmacro))
-                              (list 'cons
+              (list 'fset (list 'quote name)
-                                    (quote 'macro)
+                    (list 'cons
-                                    (list* 'lambda lambda-list
+                          (quote 'macro)
-                                           (list 'declare (list 'name name))
+                          (list 'lambda lambda-list
-                                           body))))))
+                                (list 'declare (list 'name name))
+                                (list* 'block name
+                                       body)))))))
 
 (defmacro defun (name lambda-list &rest body)
   "Define NAME to be a function."
   (list 'fset (list 'quote name)
-        (list* 'lambda lambda-list
+        (list 'lambda lambda-list
-               (list 'declare (list 'name name))
+              (list 'declare (list 'name name))
-               body)))
+              (list* 'block name
+                     body))))
 
 ;; List indicies
 (defun first (list)
@@ -101,6 +104,16 @@ Spec is of the form (VARIABLE LIST &optional RETURN-FORM)."
   (dolist (elt list list)
     (funcall function elt)))
 
+;; Functional functions
+(defun identity (x)
+  "Return X."
+  x)
+
+(defun complement (f)
+  "Return the complement function of F, that is (not (f))."
+  (lambda (&rest r)
+    (not (apply f r))))
+
 ;; Some other functions
 (defun terpri (&optional print-char-fun)
   "Print a newline to PRINT-CHAR-FUN, then flush it."
@@ -108,9 +121,107 @@ Spec is of the form (VARIABLE LIST &optional RETURN-FORM)."
     (funcall fun ?\n)
     (funcall fun nil)))
 
+(defun prin1ln (datum &optional print-char-fun)
+  "`prin1' DATUM to PRINT-CHAR-FUN, then do a `terpri'."
+  (prin1 datum print-char-fun)
+  (terpri print-char-fun))
+
 (defun princln (datum &optional print-char-fun)
   "`princ' DATUM to PRINT-CHAR-FUN, then do a `terpri'."
   (princ datum print-char-fun)
   (terpri print-char-fun))
 
-(princln (append '(1 2) '(3 4)))
+;; Cond
+(defun internal-expand-single-cond (cond)
+  (if (cdr cond)
+      (let ((res (list 'if (car cond)
+                       (list* 'progn (cdr cond)))))
+        (cons res res))
+    (let* ((res-var (make-symbol "res"))
+           (if-stmt (list 'if res-var res-var)))
+      (cons (list 'let (list (list res-var (car 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 (car res)
+                  last-if (cdr res))
+          (rplacd (last last-if) (list (car res)))
+          (setq last-if (cdr res)))))
+    out))
+
+;; Type predicates
+(defmacro define-type-predicate (name args &rest body)
+  (cond
+   ((eq args 'alias)
+    (let ((var (make-symbol "var")))
+      (list 'put (list 'quote name) ''type-predicate
+            (list 'lambda (list var) (list 'typep var (cons 'quote body))))))
+   ((and (symbolp args) (null body))
+    (list 'put (list 'quote name) ''type-predicate (list 'quote args)))
+   (t
+    (list 'put (list 'quote name) ''type-predicate
+          (list 'lambda args
+                (list 'declare (list 'name name))
+                (list* 'block name
+                       body))))))
+
+(defun typep (obj type)
+  (let* ((name (if (consp type)
+                   (car type)
+                 type))
+         (pred (get name 'type-predicate))
+         (args (and (consp type) (cdr type))))
+    (unless pred
+      (throw 'type-error))
+    (apply pred obj args)))
+
+(define-type-predicate t (obj) t)
+(define-type-predicate any alias t)
+(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 null)
+(define-type-predicate string stringp)
+(define-type-predicate symbol symbolp)
+(define-type-predicate cons consp)
+(define-type-predicate list listp)
+(define-type-predicate integer (obj &opt min max)
+  (and (integerp obj)
+       (or (not min) (>= obj min))
+       (or (not max) (<= obj max))))
+(define-type-predicate fixnum fixnump)
+(define-type-predicate bignum bignump)
+(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 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 number (obj &opt min max)
+  (typep obj (list 'or (list 'float min max)
+                   (list 'integer min max))))
+
+(princln (typep [] '(or vector list)))

src/lisp_math.c

@@ -54,10 +54,14 @@ DEFUN(fixnump, "fixnump", (LispVal * val), "(val)", "") {
     return FIXNUMP(val) ? Qt : Qnil;
 }
 
-DEFUN(integerp, "integerp", (LispVal * val), "(val)", "") {
+DEFUN(bignump, "bignump", (LispVal * val), "(val)", "") {
     return LISP_GMP_P(val) ? Qt : Qnil;
 }
 
+DEFUN(integerp, "integerp", (LispVal * val), "(val)", "") {
+    return LISP_GMP_P(val) || FIXNUMP(val) ? Qt : Qnil;
+}
+
 DEFUN(floatp, "floatp", (LispVal * val), "(val)", "") {
     return LISP_FLOAT_P(val) ? Qt : Qnil;
 }

src/lisp_math.h

@@ -32,6 +32,7 @@ LispVal *parse_gmp(const char *str, int base);
 LispVal *parse_number(const char *str, int base);
 
 DECLARE_FUNCTION(fixnump, (LispVal * val));
+DECLARE_FUNCTION(bignump, (LispVal * val));
 DECLARE_FUNCTION(integerp, (LispVal * val));
 DECLARE_FUNCTION(floatp, (LispVal * val));
 DECLARE_FUNCTION(numberp, (LispVal * val));

src/macro.c

@@ -151,9 +151,8 @@ static LispVal *macroexpand_special_form(LispVal *fobj, LispVal *form,
         if (!CONSP(XCDR(form)) || !LISTP(XCDR(XCDR(form)))) {
             return form;
         }
-        return CONS(
+        return LIST(FIRST(form), SECOND(form),
-            FIRST(form),
+                    Fmacroexpand_all(THIRD(form), lexical_macros));
-            CONS(SECOND(form), Fmacroexpand_all(THIRD(form), lexical_macros)));
     } else if (IS(declare)) {
         return form;
     }

src/memory.c

@@ -6,7 +6,7 @@
 
 void *lisp_realloc(void *oldptr, size_t size) {
     if (!size) {
-        assert(oldptr != NULL);
+        assert(oldptr == NULL);
         return NULL;
     } else {
         void *newptr = realloc(oldptr, size);