; 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)) | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment