From the book LISP From Nothing.
Note: only the part in UPPERCASE characters is metacircular! Then there is some glue in Scheme that facilitates experiments with the code. See the end of the file for examples evaluating an expression and evaluating an evaluator evaluating an expression. See the Common Lisp version for a pure metacircular implementation.
;;; Meta-circular interpreter
;;; Nils M Holm, 2019, 2020
;;;
;;; In the public domain
;;; (CC0 applies when there is no public domain)
;;;
;;; Based on John McCarthy's Micro Manual for LISP,
;;; HOPL II proceedings, 1978
(define-syntax label
(syntax-rules ()
((label ((n f) ...) x)
(letrec ((n f) ...) x))))
(define (print x)
(write x)
(newline))
(define atom symbol?)
(define t (quote t))
(define nil (quote ()))
(define eq eq?)
(define evsrc '(lambda (x e)
(LABEL
((LOOKUP
(LAMBDA (X E)
(COND ((EQ NIL E) NIL)
((EQ X (CAAR E))
(CADAR E))
(T (LOOKUP X (CDR E))))))
(EVCON
(LAMBDA (C E)
(COND ((XEVAL (CAAR C) E)
(XEVAL (CADAR C) E))
(T (EVCON (CDR C) E)))))
(BIND
(LAMBDA (V A E)
(COND ((EQ V NIL) E)
(T (CONS (CONS (CAR V)
(CONS (XEVAL (CAR A) E)
NIL))
(BIND (CDR V) (CDR A) E))))))
(APPEND2
(LAMBDA (A B)
(COND ((EQ A NIL) B)
(T (CONS (CAR A) (APPEND2 (CDR A) B))))))
(XEVAL
(LAMBDA (X E)
(COND ((EQ X T) T)
((ATOM X)
(LOOKUP X E))
((ATOM (CAR X))
(COND ((EQ (CAR X) (QUOTE QUOTE))
(CADR X))
((EQ (CAR X) (QUOTE ATOM))
(ATOM (XEVAL (CADR X) E)))
((EQ (CAR X) (QUOTE EQ))
(EQ (XEVAL (CADR X) E)
(XEVAL (CADDR X) E)))
((EQ (CAR X) (QUOTE CAR))
(CAR (XEVAL (CADR X) E)))
((EQ (CAR X) (QUOTE CDR))
(CDR (XEVAL (CADR X) E)))
((EQ (CAR X) (QUOTE CAAR))
(CAAR (XEVAL (CADR X) E)))
((EQ (CAR X) (QUOTE CADR))
(CADR (XEVAL (CADR X) E)))
((EQ (CAR X) (QUOTE CDAR))
(CDAR (XEVAL (CADR X) E)))
((EQ (CAR X) (QUOTE CADAR))
(CADAR (XEVAL (CADR X) E)))
((EQ (CAR X) (QUOTE CADDR))
(CADDR (XEVAL (CADR X) E)))
((EQ (CAR X) (QUOTE CONS))
(CONS (XEVAL (CADR X) E)
(XEVAL (CADDR X) E)))
((EQ (CAR X) (QUOTE COND))
(EVCON (CDR X) E))
((EQ (CAR X) (QUOTE LABEL))
(XEVAL (CADDR X)
(APPEND2 (CADR X) E)))
((EQ (CAR X) NIL)
'*UNDEFINED)
((EQ (CAR X) (QUOTE LAMBDA))
X)
(T (XEVAL (CONS (XEVAL (CAR X) E)
(CDR X))
E))))
((EQ (CAAR X) (QUOTE LAMBDA))
(XEVAL (CADR (CDAR X))
(BIND (CADAR X) (CDR X) E)))))))
(XEVAL X E))))
(define xeval (eval evsrc))
(define expr (quote
(label
((append
(lambda (a b)
(cond ((eq a nil) b)
(t (cons (car a)
(append (cdr a)
b)))))))
(append (quote (a b c))
(quote (d e f))))))
(print (xeval expr nil))
(print (xeval `(,evsrc ',expr nil) nil))