Skip to content

Instantly share code, notes, and snippets.

@lispm
Last active August 14, 2023 22:39
  • Star 7 You must be signed in to star a gist
  • Fork 2 You must be signed in to fork a gist
Star You must be signed in to star a gist
Save lispm/d752d5761f7078de4041d4e453e70cbe to your computer and use it in GitHub Desktop.
; 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"))
(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*))
"Testing 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))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment