这个附录包含了 58 个最常用的 Common Lisp 操作符。因为如此多的 Lisp 是（或可以）用 Lisp 所写成，而由于 Lisp 程序（或可以）相当精简，这是一种方便解释语言的方式。
这个练习也证明了，概念上 Common Lisp 不像看起来那样庞大。许多 Common Lisp 操作符是有用的函式库；要写出所有其它的东西，你所需要的操作符相当少。在这个附录的这些定义只需要:
`apply` `aref` `backquote` `block` `car` `cdr` `ceiling` `char=` `cons` `defmacro` `documentation` `eq` `error` `expt` `fdefinition` `function``floor` `gensym` `get-setf-expansion` `if` `imagpart` `labels` `length` `multiple-value-bind` `nth-value` `quote` `realpart` `symbol-function` `tagbody` `type-of` `typep` `=` `+` `-` `/` `<` `>`
这里给出的代码作为一种解释 Common Lisp 的方式，而不是实现它的方式。在实际的实现上，这些操作符可以更高效，也会做更多的错误检查。为了方便参找，这些操作符本身按字母顺序排列。如果你真的想要这样定义 Lisp，每个宏的定义需要在任何调用它们的代码之前。
~~~
(defun -abs (n)
(if (typep n 'complex)
(sqrt (+ (expt (realpart n) 2) (expt (imagpart n) 2)))
(if (< n 0) (- n) n)))
~~~
~~~
(defun -adjoin (obj lst &rest args)
(if (apply #'member obj lst args) lst (cons obj lst)))
~~~
~~~
(defmacro -and (&rest args)
(cond ((null args) t)
((cdr args) `(if ,(car args) (-and ,@(cdr args))))
(t (car args))))
~~~
~~~
(defun -append (&optional first &rest rest)
(if (null rest)
first
(nconc (copy-list first) (apply #'-append rest))))
~~~
~~~
(defun -atom (x) (not (consp x)))
~~~
~~~
(defun -butlast (lst &optional (n 1))
(nreverse (nthcdr n (reverse lst))))
~~~
~~~
(defun -cadr (x) (car (cdr x)))
~~~
~~~
(defmacro -case (arg &rest clauses)
(let ((g (gensym)))
`(let ((,g ,arg))
(cond ,@(mapcar #'(lambda (cl)
(let ((k (car cl)))
`(,(cond ((member k '(t otherwise))
t)
((consp k)
`(member ,g ',k))
(t `(eql ,g ',k)))
(progn ,@(cdr cl)))))
clauses)))))
~~~
~~~
(defun -cddr (x) (cdr (cdr x)))
~~~
~~~
(defun -complement (fn)
#'(lambda (&rest args) (not (apply fn args))))
~~~
~~~
(defmacro -cond (&rest args)
(if (null args)
nil
(let ((clause (car args)))
(if (cdr clause)
`(if ,(car clause)
(progn ,@(cdr clause))
(-cond ,@(cdr args)))
`(or ,(car clause)
(-cond ,@(cdr args)))))))
~~~
~~~
(defun -consp (x) (typep x 'cons))
~~~
~~~
(defun -constantly (x) #'(lambda (&rest args) x))
~~~
~~~
(defun -copy-list (lst)
(labels ((cl (x)
(if (atom x)
x
(cons (car x)
(cl (cdr x))))))
(cons (car lst)
(cl (cdr lst)))))
~~~
~~~
(defun -copy-tree (tr)
(if (atom tr)
tr
(cons (-copy-tree (car tr))
(-copy-tree (cdr tr)))))
~~~
~~~
(defmacro -defun (name parms &rest body)
(multiple-value-bind (dec doc bod) (analyze-body body)
`(progn
(setf (fdefinition ',name)
#'(lambda ,parms
,@dec
(block ,(if (atom name) name (second name))
,@bod))
(documentation ',name 'function)
,doc)
',name)))
~~~
~~~
(defun analyze-body (body &optional dec doc)
(let ((expr (car body)))
(cond ((and (consp expr) (eq (car expr) 'declare))
(analyze-body (cdr body) (cons expr dec) doc))
((and (stringp expr) (not doc) (cdr body))
(if dec
(values dec expr (cdr body))
(analyze-body (cdr body) dec expr)))
(t (values dec doc body)))))
~~~
这个定义不完全正确，参见 `let`
~~~
(defmacro -do (binds (test &rest result) &rest body)
(let ((fn (gensym)))
`(block nil
(labels ((,fn ,(mapcar #'car binds)
(cond (,test ,@result)
(t (tagbody ,@body)
(,fn ,@(mapcar #'third binds))))))
(,fn ,@(mapcar #'second binds))))))
~~~
~~~
(defmacro -dolist ((var lst &optional result) &rest body)
(let ((g (gensym)))
`(do ((,g ,lst (cdr ,g)))
((atom ,g) (let ((,var nil)) ,result))
(let ((,var (car ,g)))
,@body))))
~~~
~~~
(defun -eql (x y)
(typecase x
(character (and (typep y 'character) (char= x y)))
(number (and (eq (type-of x) (type-of y))
(= x y)))
(t (eq x y))))
~~~
~~~
(defun -evenp (x)
(typecase x
(integer (= 0 (mod x 2)))
(t (error "non-integer argument"))))
~~~
~~~
(defun -funcall (fn &rest args) (apply fn args))
~~~
~~~
(defun -identity (x) x)
~~~
这个定义不完全正确：表达式 `(let ((&key 1) (&optional 2)))` 是合法的，但它产生的表达式不合法。
~~~
(defmacro -let (parms &rest body)
`((lambda ,(mapcar #'(lambda (x)
(if (atom x) x (car x)))
parms)
,@body)
,@(mapcar #'(lambda (x)
(if (atom x) nil (cadr x)))
parms)))
~~~
~~~
(defun -list (&rest elts) (copy-list elts))
~~~
~~~
(defun -listp (x) (or (consp x) (null x)))
~~~
~~~
(defun -mapcan (fn &rest lsts)
(apply #'nconc (apply #'mapcar fn lsts)))
~~~
~~~
(defun -mapcar (fn &rest lsts)
(cond ((member nil lsts) nil)
((null (cdr lsts))
(let ((lst (car lsts)))
(cons (funcall fn (car lst))
(-mapcar fn (cdr lst)))))
(t
(cons (apply fn (-mapcar #'car lsts))
(apply #'-mapcar fn
(-mapcar #'cdr lsts))))))
~~~
~~~
(defun -member (x lst &key test test-not key)
(let ((fn (or test
(if test-not
(complement test-not))
#'eql)))
(member-if #'(lambda (y)
(funcall fn x y))
lst
:key key)))
~~~
~~~
(defun -member-if (fn lst &key (key #'identity))
(cond ((atom lst) nil)
((funcall fn (funcall key (car lst))) lst)
(t (-member-if fn (cdr lst) :key key))))
~~~
~~~
(defun -mod (n m)
(nth-value 1 (floor n m)))
~~~
~~~
(defun -nconc (&optional lst &rest rest)
(if rest
(let ((rest-conc (apply #'-nconc rest)))
(if (consp lst)
(progn (setf (cdr (last lst)) rest-conc)
lst)
rest-conc))
lst))
~~~
~~~
(defun -not (x) (eq x nil))
(defun -nreverse (seq)
(labels ((nrl (lst)
(let ((prev nil))
(do ()
((null lst) prev)
(psetf (cdr lst) prev
prev lst
lst (cdr lst)))))
(nrv (vec)
(let* ((len (length vec))
(ilimit (truncate (/ len 2))))
(do ((i 0 (1+ i))
(j (1- len) (1- j)))
((>= i ilimit) vec)
(rotatef (aref vec i) (aref vec j))))))
(if (typep seq 'vector)
(nrv seq)
(nrl seq))))
~~~
~~~
(defun -null (x) (eq x nil))
~~~
~~~
(defmacro -or (&optional first &rest rest)
(if (null rest)
first
(let ((g (gensym)))
`(let ((,g ,first))
(if ,g
,g
(-or ,@rest))))))
~~~
这两个 Common Lisp 没有，但这里有几的定义会需要用到。
~~~
(defun pair (lst)
(if (null lst)
nil
(cons (cons (car lst) (cadr lst))
(pair (cddr lst)))))
(defun -pairlis (keys vals &optional alist)
(unless (= (length keys) (length vals))
(error "mismatched lengths"))
(nconc (mapcar #'cons keys vals) alist))
~~~
~~~
(defmacro -pop (place)
(multiple-value-bind (vars forms var set access)
(get-setf-expansion place)
(let ((g (gensym)))
`(let* (,@(mapcar #'list vars forms)
(,g ,access)
(,(car var) (cdr ,g)))
(prog1 (car ,g)
,set)))))
~~~
~~~
(defmacro -prog1 (arg1 &rest args)
(let ((g (gensym)))
`(let ((,g ,arg1))
,@args
,g)))
~~~
~~~
(defmacro -prog2 (arg1 arg2 &rest args)
(let ((g (gensym)))
`(let ((,g (progn ,arg1 ,arg2)))
,@args
,g)))
~~~
~~~
(defmacro -progn (&rest args) `(let nil ,@args))
~~~
~~~
(defmacro -psetf (&rest args)
(unless (evenp (length args))
(error "odd number of arguments"))
(let* ((pairs (pair args))
(syms (mapcar #'(lambda (x) (gensym))
pairs)))
`(let ,(mapcar #'list
syms
(mapcar #'cdr pairs))
(setf ,@(mapcan #'list
(mapcar #'car pairs)
syms)))))
~~~
~~~
(defmacro -push (obj place)
(multiple-value-bind (vars forms var set access)
(get-setf-expansion place)
(let ((g (gensym)))
`(let* ((,g ,obj)
,@(mapcar #'list vars forms)
(,(car var) (cons ,g ,access)))
,set))))
~~~
~~~
(defun -rem (n m)
(nth-value 1 (truncate n m)))
(defmacro -rotatef (&rest args)
`(psetf ,@(mapcan #'list
args
(append (cdr args)
(list (car args))))))
~~~
~~~
(defun -second (x) (cadr x))
(defmacro -setf (&rest args)
(if (null args)
nil
`(setf2 ,@args)))
~~~
~~~
(defmacro setf2 (place val &rest args)
(multiple-value-bind (vars forms var set)
(get-setf-expansion place)
`(progn
(let* (,@(mapcar #'list vars forms)
(,(car var) ,val))
,set)
,@(if args `((setf2 ,@args)) nil))))
~~~
~~~
(defun -signum (n)
(if (zerop n) 0 (/ n (abs n))))
~~~
~~~
(defun -stringp (x) (typep x 'string))
~~~
~~~
(defun -tailp (x y)
(or (eql x y)
(and (consp y) (-tailp x (cdr y)))))
~~~
~~~
(defun -third (x) (car (cdr (cdr x))))
~~~
~~~
(defun -truncate (n &optional (d 1))
(if (> n 0) (floor n d) (ceiling n d)))
~~~
~~~
(defmacro -typecase (arg &rest clauses)
(let ((g (gensym)))
`(let ((,g ,arg))
(cond ,@(mapcar #'(lambda (cl)
`((typep ,g ',(car cl))
(progn ,@(cdr cl))))
clauses)))))
~~~
~~~
(defmacro -unless (arg &rest body)
`(if (not ,arg)
(progn ,@body)))
~~~
~~~
(defmacro -when (arg &rest body)
`(if ,arg (progn ,@body)))
~~~
~~~
(defun -1+ (x) (+ x 1))
~~~
~~~
(defun -1- (x) (- x 1))
~~~
~~~
(defun ->= (first &rest rest)
(or (null rest)
(and (or (> first (car rest)) (= first (car rest)))
(apply #'->= rest))))
~~~
