mccarthy-eval.lisp

; A MICRO-MANUAL FOR LISP - NOT THE WHOLE TRUTH, 1978
; John McCarthy, Artificial Intelligence Laboratory, Stanford University

; https://www.ee.ryerson.ca/~elf/pub/misc/micromanualLISP.pdf
; https://github.com/jaseemabid/micromanual

; for CL : Rainer Joswig, joswig@lisp.de

; this version runs in a Common Lisp


(cl:defpackage "MCCARTHY-LISP"
  (:use "CL")
  (:shadow cl:eval cl:assoc)
  (:nicknames "MCLISP")
  (:export "MCCARTHY-EVAL" "MCCARTHY-REPL"))

(in-package "MCLISP")

(defmacro definterpreter (fn)
  `(progn
     (defun mccarthy-eval (form)
       (label eval ,fn form nil))
     (defparameter *eval-function-code* ',fn)))

(defmacro label (name fn &rest args)
  `(labels ((,name ,(second fn)
              ,@(cddr fn)))
     (,name ,@args)))


; The LABEL syntax is slightly different from the original paper -> it is altered for CL compatibility.
; The interpreter is updated for the different LABEL syntax.
; ((label foo (lambda (x) x)) 'bar)   is now   (label foo (lambda (x) x) 'bar)

;; Language of the interpreter
;
; * QUOTE, CAR, CDR, CADR, CADDR, CAAR, CADAR, CADDAR, ATOM, NULL, CONS, EQ, COND, LABEL, LAMBDA, EVAL
; * variable reference, function call
;
;; Functions used by the interpreter:
; 
; * ASSOC, EVCOND, FFAPPEND, PAIRUP, EVLIS
;
;; Notes
;
; * literals need to be quoted
; * undefined variables evaluate to NIL
; * given a LABEL macro, the interpreter code is valid Common Lisp code


(definterpreter
 (LAMBDA (E A)
   (COND ((ATOM E)
          (COND ((EQ E NIL) NIL)
                ((EQ E T) T)
                (T (CDR (LABEL ASSOC
                               (LAMBDA (E A)
                                 (COND ((NULL A) NIL)
                                       ((EQ E (CAAR A)) (CAR A))
                                       (T (ASSOC E (CDR A)))))
                               E
                               A)))))
         ((ATOM (CAR E))
          (COND
           ((EQ (CAR E) (QUOTE QUOTE))
            (CADR E))
           ((EQ (CAR E) (QUOTE CAR))
            (CAR (EVAL (CADR E) A)))
           ((EQ (CAR E) (QUOTE CDR))
            (CDR (EVAL (CADR E) A)))
           ((EQ (CAR E) (QUOTE CADR))
            (CADR (EVAL (CADR E) A)))
           ((EQ (CAR E) (QUOTE CADDR))
            (CADDR (EVAL (CADR E) A)))
           ((EQ (CAR E) (QUOTE CAAR))
            (CAAR (EVAL (CADR E) A)))
           ((EQ (CAR E) (QUOTE CADAR))
            (CADAR (EVAL (CADR E) A)))
           ((EQ (CAR E) (QUOTE CADDAR))
            (CADDAR (EVAL (CADR E) A)))
           ((EQ (CAR E) (QUOTE ATOM))
            (ATOM (EVAL (CADR E) A)))
           ((EQ (CAR E) (QUOTE NULL))
            (NULL (EVAL (CADR E) A)))
           ((EQ (CAR E) (QUOTE CONS))
            (CONS (EVAL (CADR E) A) (EVAL (CADDR E) A)))
           ((EQ (CAR E) (QUOTE EQ))
            (EQ (EVAL (CADR E) A) (EVAL (CADDR E) A)))
           ((EQ (CAR E) (QUOTE COND))
            (LABEL EVCOND
                   (LAMBDA (U A)
                     (COND ((EVAL (CAAR U) A)
                            (EVAL (CADAR U) A))
                           (T (EVCOND (CDR U) A))))
                   (CDR E)
                   A))
           ((EQ (CAR E) (QUOTE LABEL))                    
            (EVAL (CONS (CADDR E) (CDR (CDR (CDR E))))
                  (CONS (CONS (CADR E)
                              (CONS 'LAMBDA
                                    (CONS (CADR (CADDR E))
                                          (CONS (CONS (CAR E)
                                                      (CONS (CADR E)
                                                            (CONS (CADDR E) (CADR (CADDR E)))))
                                                NIL)
                                          )))
                        A)))
           (T (EVAL (CONS (CDR (LABEL ASSOC
                                      (LAMBDA (E A)
                                        (COND
                                         ((NULL A) NIL)
                                         ((EQ E (CAAR A)) (CAR A))
                                         (T (ASSOC E (CDR A)))))
                                      (CAR E)
                                      A))
                          (CDR E))
                    A))))
         ((EQ (CAAR E) (QUOTE LAMBDA))
          (EVAL (CADDAR E)
                (LABEL FFAPPEND
                       (LAMBDA (U V)
                         (COND ((NULL U) V)
                               (T (CONS (CAR U)
                                        (FFAPPEND (CDR U) V)))))
                       (LABEL PAIRUP
                              (LAMBDA (U V)
                                (COND ((NULL U) NIL)
                                      (T (CONS (CONS (CAR U) (CAR V))
                                               (PAIRUP (CDR U) (CDR V))))))
                              (CADAR E)
                              (LABEL EVLIS
                                     (LAMBDA (U A)
                                       (COND ((NULL U) NIL)
                                             (T (CONS (EVAL (CAR U) A)
                                                      (EVLIS (CDR U) A)))))
                                     (CDR E)
                                     A))
                       A))))))


(defparameter *test-cases*
  '((undefined-var A NIL)
    (T T T)
    (NIL NIL NIL)
    (quote1 (quote t)      T)
    (quote2 (quote nil)    nil)
    (quote3 (quote A)      A)
    (quote4 (quote (quote a)) (quote a))
    (atom1  (atom T)       t)
    (atom2  (atom NIL)     t)
    (atom3  (atom 'A)      t)
    (atom4  (atom (cons 'a 'b)) nil)
    (null1  (null 'a)      nil)
    (null2  (null T)       nil)
    (null3  (null NIL)     T)
    (null4  (null 'NIL)    T)
    (null5  (null (cons 'a 'b))  nil)
    (cons1  (cons 'a 'b)   (a . b))
    (cons2  (cons (cons 'a 'b) 'C)   ((a . b) . c))
    (eq1    (eq T T)       T)
    (eq2    (eq NIL T)     NIL)
    (eq3    (eq T NIL)     NIL)
    (eq4    (eq NIL NIL)   T)
    (eq5    (eq 'A 'B)     NIL)
    (eq6    (eq 'B 'A)     NIL)
    (eq7    (eq 'A 'A)     T)
    (eq8    (eq 'B 'B)     T)
    (car    (car '(a))     A)
    (cadr   (cadr '(a b))  B)
    (caddr  (caddr '(a b c))  C)
    (cdr1   (cdr '(a . b)) B)
    (cdr2   (cdr '(a b))   (B))
    (cdr3   (cdr '(a b c)) (B C))
    (cond1  (cond (nil 'foo) (t 'bar)) bar)
    (cond2  (cond (t   'foo) (t 'bar)) foo)
    (cond3  (cond ((null 'a) 'foo) (t 'bar)) bar)
    (cond4  (cond (nil 'foo) (nil 'baz) (t 'bar)) bar)
    (lamb1  ((lambda (a) a) 'a) a)
    (lamb2  ((lambda (a) a)  T) T)
    (lamb3  ((lambda (a) (cons a a))  T)   (T . T))
    (lamb4  ((lambda (a b) (cons a b))  'A 'B)   (A . B))
    (labl1  (label foo (lambda (a)
                         (cond ((null a) nil)
                               (t (cons (eq (car a) T)
                                        (foo (cdr a))))))
                   '(A B T A B))
            (NIL NIL T NIL NIL))
    ))

(defun test-mce-1 (&optional (tests *test-cases*))
  "Testng the interpreter"
  (mapc (lambda (test)
            (let ((value (mccarthy-eval (second test))))
              (if (equal value (third test))
                  (print (list T (first test)))
                (print (list NIL test value)))))
          tests)
  (values))

(defun test-mce-2 (&optional (tests *test-cases*))
  "Testing the interpreter running the interpreter"
  (mapc (lambda (test)
            (let ((value (mccarthy-eval 
                          (list 'label 'eval *eval-function-code* (list 'quote (second test)) nil))))
              (if (equal value (third test))
                  (print (list 2 T (first test)))
                (print (list 2 NIL test value)))))
          tests)
  (values))

(defun test-all ()
  (test-mce-1)
  (test-mce-2))