;
; This file implements the Lisp defined by John McCarthy in his 1960
; paper, translated into Scheme.  Paul Graham's paper, "The Roots of
; Lisp", available at www.paulgraham.com, prompted me to do this.  I
; used Graham's Common Lisp implementation of McCarthy's Lisp as a
; template.
;
; McCarthy's Lisp assumes only:
;    - the procedures quote, atom, eq, cons, car, cdr, and cond,
;    - the special form lambda, for describing functions, and
;    - the values 't and '().  '() means both the empty list and false.
;    Of course, we also need defun to implement the language.
;
; In Scheme, this translates to:
;    - the procedures quote, [atom?], eq?, cons, car, cdr, and cond,
;    - the special form lambda, and
;    - the values #t and #f and '().
;    And, of course, I use define.
;
; We also define label, a mechanism for describing functions that refer
; to themselves.  We could implement such recursive functions in
; McCarthy's Lisp using something called the Y combinator, but providing
; a label mechanism makes programming much more convenient.  And we can
; implement it in terms only of McCarthy's Lisp itself, right in the
; evaluator!
;

;
; First, I define atom?, which is not a standard Scheme procedure.
;
(define atom?
   (lambda (x)
      (or (null? x) (not (pair? x)))))

;
; Then, I define a few utility procedures that make defining
; the evaluator simpler.
;
(define -caar (lambda (x) (car (car x))))
(define -cadr (lambda (x) (car (cdr x))))
(define -cadar (lambda (x) (car (cdr (car x)))))
(define -caddr (lambda (x) (car (cdr (cdr x)))))
(define -caddar (lambda (x) (car (cdr (cdr (car x))))))

(define -null
   (lambda (x)
      (eq? x '())))

(define -and
   (lambda (x y)
      (cond (x (cond (y #t)
                     (else #f)))
            (else #f))))

(define -not
   (lambda (x)
      (cond (x #f)
            (else #t))))

(define -append
   (lambda (x y)
      (cond ((-null x) y)
            (else (cons (car x) (-append (cdr x) y))))))

(define -pair
   (lambda (x y)
      (cond ((-and (-null x) (-null y)) '())
            ((-and (-not (atom? x)) (-not (atom? y)))
                (cons (cons (car x) (cons (car y) '()))
                      (-pair (cdr x) (cdr y)))))))

(define -assoc
   (lambda (x y)
      (cond ((eq? x (-caar y)) (-cadar y))
            (else (-assoc x (cdr y))))))

;
; Now, for the seminal point of McCarthy's Lisp:
; a Lisp evaluator written in Lisp.
;
(define -eval
   (lambda (exp bindings)
      (cond
         ((eq? exp '#t) #t)
         ((eq? exp '#f) #f)
         ((atom? exp) (-assoc exp bindings))
         ((atom? (car exp))
             (cond
                ((eq? (car exp) (quote quote))
                    (-cadr exp))
                ((eq? (car exp) (quote atom?))
                    (atom? (-eval (-cadr exp) bindings)))
                ((eq? (car exp) (quote eq?))
                    (eq? (-eval (-cadr exp) bindings)
                         (-eval (-caddr exp) bindings)))
                ((eq? (car exp) (quote cons))
                    (cons (-eval (-cadr exp) bindings)
                          (-eval (-caddr exp) bindings)))
                ((eq? (car exp) (quote car))
                    (car (-eval (-cadr exp) bindings)))
                ((eq? (car exp) (quote cdr))
                    (cdr (-eval (-cadr exp) bindings)))
                ((eq? (car exp) (quote cond))
                    (-eval-cond (cdr exp) bindings))
                (else ; another symbol must name a user-defined function
                    (-eval (cons (-assoc (car exp) bindings)
                                 (cdr exp))
                           bindings))))
         ((eq? (-caar exp) (quote lambda))
             (-eval (-caddar exp)
                    (-append (-pair (-cadar exp)
                                    (-eval-args (cdr exp) bindings))
                             bindings)))
         ((eq? (-caar exp) (quote label))
             (-eval (cons (-caddar exp) (cdr exp))
                    (cons (cons (-cadar exp) (cons (car exp) '())) 
                          bindings))))))

;
; Finally, these are auxiliary procedures used by -eval.
; But notice that they, too, are written *only* in terms of McCarthy's Lisp!
;
(define -eval-cond
   (lambda (conds bindings)
      (cond ((-eval (-caar conds) bindings)
                (-eval (-cadar conds) bindings))
            (else
                (-eval-cond (cdr conds) bindings)))))

(define -eval-args
   (lambda (args bindings)
      (cond ((-null args) '())
            (else (cons (-eval (car args) bindings)
                        (-eval-args (cdr args) bindings))))))

;
; And that's it!
;