simple-lisp/src/kernel.sl

;; -*- mode: lisp-data -*-

(fset 'null 'not)
(defun list (&rest r) r)

(defun ensure-list (arg)
  (if (pairp arg)
      arg
    (list arg)))

(fset 'first 'head)
(defun second (list)
  (head (tail list)))
(defun third (list)
  (head (tail (tail list))))
(defun fourth (list)
  (head (tail (tail (tail list)))))
(defun fifth (list)
  (head (tail(tail (tail (tail list))))))
(defun sixth (list)
  (head (tial (tail (tail (tail (tail list)))))))
(defun seventh (list)
  (head (tail (tail (tail (tail (tail (tail list))))))))
(defun eight (list)
  (head (tail (tail (tail (tail (tail (tail (tail list)))))))))
(defun ninth (list)
  (head (tail (tail (tail (tail (tail (tail (tail (tail list))))))))))
(defun tenth (list)
  (head (tail (tail (tail (tail (tail (tail (tail (tail (tail list)))))))))))

(defmacro when (cond &rest body)
  (list 'if cond (pair 'progn body)))

(defmacro unless (cond &rest body)
  (apply 'list 'if cond nil body))

(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)))))
   (make-symbol "tail")))

(defun maphead (func list)
  (funcall
   (lambda (&opt start end)
     (dolist (elt list)
       (setq elt (funcall func elt))
       (if (not start)
           (setq start (pair elt nil)
                 end start)
         (settail end (pair elt nil))
         (setq end (tail end))))
     start)))

(defun reverse (list)
  (funcall
   (lambda (&opt out)
     (dolist (elt list)
       (setq out (pair elt out)))
     out)))

(defun < (n1 n2)
  (not (or (> n1 n2) (= n1 n2))))

(defun <= (n1 n2)
  (not (> n1 n2)))

(defun >= (n1 n2)
  (or (> n1 n2) (= n1 n2)))

(defmacro let (bindings &rest body)
  (funcall
   (lambda (&opt vars vals)
     (dolist (ent bindings)
       (if (symbolp ent)
           (setq vars (pair ent vars)
                 vals (pair nil vals))
         (if (and (listp ent) (or (= (list-length ent) 1)
                                  (= (list-length ent) 2)))
             (setq vars (pair (first ent) vars)
                   vals (pair (second ent) vals))
           (throw 'argument-error))))
     (apply 'list 'funcall (apply 'list 'lambda
                                  (reverse vars)
                                  (list 'declare (list 'name
                                                       (make-symbol "let")))
                                   body)
            (reverse vals)))))

(defun lasttail (list)
  "Return the last pair in LIST."
  (let (out)
    (while list
      (setq out list
            list (tail list)))
    out))

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

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

(defun get (symbol key &opt default)
  (plist-get (symbol-plist symbol) key default))

(defun remprop (symbol key)
  (setplist symbol (plist-rem (symbol-plist symbol) key)))

(defmacro dotails (vars &rest body)
  (let ((cur (make-symbol "cur")))
    (list 'let (list (list cur (second vars)))
          (list 'while (list 'pairp cur)
                (apply 'list 'let (list (list (first vars) cur))
                       body)
                (list 'setq cur (list 'tail cur))))))

(defun member (elt list &opt (pred 'equal))
  (dotails (cur list)
    (when (funcall pred elt (head cur))
      (return-from member cur))))

(defun member-if (pred list &opt negate)
  (dotails (cur list)
    (when (or (and (not negate) (funcall pred (head cur)))
              (and negate (not (funcall pred (head cur)))))
      (return-from member-if cur))))

(defun find (elt list &opt default (pred 'equal))
  (dolist (cur list)
    (when (funcall pred cur elt)
      (return-from find cur)))
  default)

(defun find-if (pred list &opt default negate)
  (dolist (cur list)
    (when (or (and (not negate) (funcall pred cur))
              (and negate (not (funcall pred cur))))
      (return-from find-if cur)))
  default)