145 lines
4.2 KiB
Plaintext
145 lines
4.2 KiB
Plaintext
;; -*- 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))
|