Fix soome stuff

lisp/kernel.gl

@@ -1,23 +1,26 @@
 ;; -*- mode: lisp-data -*-
 
 ;; Defining macros and functions
-(fset 'defmacro (cons 'macro
-                      (lambda (name lambda-list &rest body)
-                        "Define NAME to be a macro."
-                        (declare (name defmacro))
-                        (list 'fset (list 'quote name)
-                              (list 'cons
-                                    (quote 'macro)
-                                    (list* 'lambda lambda-list
-                                           (list 'declare (list 'name name))
-                                           body))))))
+(fset 'defmacro
+      (cons 'macro
+            (lambda (name lambda-list &rest body)
+              "Define NAME to be a macro."
+              (declare (name defmacro))
+              (list 'fset (list 'quote name)
+                    (list 'cons
+                          (quote 'macro)
+                          (list 'lambda lambda-list
+                                (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 'declare (list 'name name))
-               body)))
+        (list 'lambda lambda-list
+              (list 'declare (list 'name name))
+              (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)))