;----------------------------------------------------------------
; jmc.lisp
; Tiago Charters de Azevedo
; email: tca@diale.org
; date: 20100519
; Simple LISP as described in JMC 1960 paper, highly inspired
; on:
; 1. Recursive Functions of Symbolic Expressions and Their 
;    Computation by Machine,  John McCarthy
; 2. The Roots of Lisp, Paul Graham
;
; Works in Common Lisp and Emacs Lisp.
;
; Uses only the 7 the primitive operators: 
; quote, atom, eq, car, cdr, cons and cond.
;----------------------------------------------------------------

(defun not. (x) 
  (cond (x '())
        ('t 't)))

(defun null. (x)
  (eq x '()))

(defun and. (x y)
  (cond (x (cond (y't) ('t '())))
        ('t '())))

(defun pair. (x y)
  (cond ((and. (null. x) (null. y)) '())
        ((and. (not. (atom x)) (not. (atom y)))
         (cons (list (car x) (car y))
               (pair. (cdr x) (cdr y))))))

(defun append. (x y)
  (cond ((null. x) y)
        ('t (cons (car x) (append. (cdr x) y)))))

(defun assoc. (x y)
  (cond ((eq (caar y) x) (cadar y))
        ('t (assoc. x (cdr y)))))

(defun eval. (e a)
  (cond
    ((atom e) (assoc. e a))
    ((atom (car e))
     (cond
       ((eq (car e) 'quote) (cadr e))
       ((eq (car e) 'atom)  (atom   (eval. (cadr e) a)))
       ((eq (car e) 'eq)    (eq     (eval. (cadr e) a)
                                    (eval. (caddr e) a)))
       ((eq (car e) 'car)   (car    (eval. (cadr e) a)))
       ((eq (car e) 'cdr)   (cdr    (eval. (cadr e) a)))
       ((eq (car e) 'cons)  (cons   (eval. (cadr e) a)
                                    (eval. (caddr e) a)))
       ((eq (car e) 'cond)  (evcon. (cdr e) a))
       ((eq (car e) 'list) (evlis. (cdr e) a))
       ('t (eval. (cons (assoc. (car e) a)
			(cdr e))
                  a))))
    ((eq (caar e) 'label)
     (eval. (cons (caddar e) (cdr e))
	    (cons (list (cadar e) (car e)) a)))
    ((eq (caar e) 'lambda)
     (eval. (caddar e)
	    (append. (pair. (cadar e) (evlis. (cdr e) a))
		     a)))))


(defun evcon. (c a)
  (cond ((eval. (caar c) a)
         (eval. (cadar c) a))
        ('t (evcon. (cdr c) a))))

(defun evlis. (m a)
  (cond ((null. m) '())
        ('t (cons (eval. (car m) a)
            (evlis. (cdr m) a)))))

(defun apply. (f a)
  (eval. (cons f (appq. a)) '()))


(defun appq. (m)
  (cond ((null m) '())
        (t
         (cons (list 'quote (car m)) (appq. (cdr m))))))