[转贴]：lisp的一些标准函数的lisp实现

秋枫

2. 
   
3. [font=courier]
   
4. ; 下面是common lisp代码(不是autolisp)
   
5. 
   
6. ; The Lisp defined in McCarthy's 1960 paper, translated into CL.
   
7. ; Assumes only quote, atom, eq, cons, car, cdr, cond.
   
8. ; Bug reports to [email]lispcode@paulgraham.com[/email].
   
9. 
   
10. (defun null. (x)
    
11.   (eq x '()))
    
12. 
    
13. (defun and. (x y)
    
14.   (cond (x (cond (y 't) ('t '())))
    
15.         ('t '())))
    
16. 
    
17. (defun not. (x)
    
18.   (cond (x '())
    
19.         ('t 't)))
    
20. 
    
21. (defun append. (x y)
    
22.   (cond ((null. x) y)
    
23.         ('t (cons (car x) (append. (cdr x) y)))))
    
24. 
    
25. (defun pair. (x y)
    
26.   (cond ((and. (null. x) (null. y)) '())
    
27.         ((and. (not. (atom x)) (not. (atom y)))
    
28.          (cons (list (car x) (car y))
    
29.                (pair. (cdr x) (cdr y))))))
    
30. 
    
31. (defun assoc. (x y)
    
32.   (cond ((eq (caar y) x) (cadar y))
    
33.         ('t (assoc. x (cdr y)))))
    
34. 
    
35. (defun eval. (e a)
    
36.   (cond
    
37.     ((atom e) (assoc. e a))
    
38.     ((atom (car e))
    
39.      (cond
    
40.        ((eq (car e) 'quote) (cadr e))
    
41.        ((eq (car e) 'atom)  (atom   (eval. (cadr e) a)))
    
42.        ((eq (car e) 'eq)    (eq     (eval. (cadr e) a)
    
43.                                     (eval. (caddr e) a)))
    
44.        ((eq (car e) 'car)   (car    (eval. (cadr e) a)))
    
45.        ((eq (car e) 'cdr)   (cdr    (eval. (cadr e) a)))
    
46.        ((eq (car e) 'cons)  (cons   (eval. (cadr e) a)
    
47.                                     (eval. (caddr e) a)))
    
48.        ((eq (car e) 'cond)  (evcon. (cdr e) a))
    
49.        ('t (eval. (cons (assoc. (car e) a)
    
50.                         (cdr e))
    
51.                   a))))
    
52.     ((eq (caar e) 'label)
    
53.      (eval. (cons (caddar e) (cdr e))
    
54.             (cons (list (cadar e) (car e)) a)))
    
55.     ((eq (caar e) 'lambda)
    
56.      (eval. (caddar e)
    
57.             (append. (pair. (cadar e) (evlis. (cdr e) a))
    
58.                      a)))))
    
59. 
    
60. (defun evcon. (c a)
    
61.   (cond ((eval. (caar c) a)
    
62.          (eval. (cadar c) a))
    
63.         ('t (evcon. (cdr c) a))))
    
64. 
    
65. (defun evlis. (m a)
    
66.   (cond ((null. m) '())
    
67.         ('t (cons (eval.  (car m) a)
    
68.                   (evlis. (cdr m) a)))))
    

<br /> [font=courier]<br /> ; 下面是common lisp代码(不是autolisp)<br /> <br /> ; The Lisp defined in McCarthy's 1960 paper, translated into CL.<br /> ; Assumes only quote, atom, eq, cons, car, cdr, cond.<br /> ; Bug reports to [email]lispcode@paulgraham.com[/email].<br /> <br /> (defun null. (x)<br />   (eq x '()))<br /> <br /> (defun and. (x y)<br />   (cond (x (cond (y 't) ('t '())))<br />         ('t '())))<br /> <br /> (defun not. (x)<br />   (cond (x '())<br />         ('t 't)))<br /> <br /> (defun append. (x y)<br />   (cond ((null. x) y)<br />         ('t (cons (car x) (append. (cdr x) y)))))<br /> <br /> (defun pair. (x y)<br />   (cond ((and. (null. x) (null. y)) '())<br />         ((and. (not. (atom x)) (not. (atom y)))<br />          (cons (list (car x) (car y))<br />                (pair. (cdr x) (cdr y))))))<br /> <br /> (defun assoc. (x y)<br />   (cond ((eq (caar y) x) (cadar y))<br />         ('t (assoc. x (cdr y)))))<br /> <br /> (defun eval. (e a)<br />   (cond<br />     ((atom e) (assoc. e a))<br />     ((atom (car e))<br />      (cond<br />        ((eq (car e) 'quote) (cadr e))<br />        ((eq (car e) 'atom)  (atom   (eval. (cadr e) a)))<br />        ((eq (car e) 'eq)    (eq     (eval. (cadr e) a)<br />                                     (eval. (caddr e) a)))<br />        ((eq (car e) 'car)   (car    (eval. (cadr e) a)))<br />        ((eq (car e) 'cdr)   (cdr    (eval. (cadr e) a)))<br />        ((eq (car e) 'cons)  (cons   (eval. (cadr e) a)<br />                                     (eval. (caddr e) a)))<br />        ((eq (car e) 'cond)  (evcon. (cdr e) a))<br />        ('t (eval. (cons (assoc. (car e) a)<br />                         (cdr e))<br />                   a))))<br />     ((eq (caar e) 'label)<br />      (eval. (cons (caddar e) (cdr e))<br />             (cons (list (cadar e) (car e)) a)))<br />     ((eq (caar e) 'lambda)<br />      (eval. (caddar e)<br />             (append. (pair. (cadar e) (evlis. (cdr e) a))<br />                      a)))))<br /> <br /> (defun evcon. (c a)<br />   (cond ((eval. (caar c) a)<br />          (eval. (cadar c) a))<br />         ('t (evcon. (cdr c) a))))<br /> <br /> (defun evlis. (m a)<br />   (cond ((null. m) '())<br />         ('t (cons (eval.  (car m) a)<br />                   (evlis. (cdr m) a)))))<br />