A part of code to implement the metacircular evaluator on Chapter 4 of SICP.

lisp_evaluator.rkt

#lang racket
(require r5rs)

;;;
(define apply-in-underlying-scheme apply)

;;; ENVIROMENT PART BEGIN

(define (enclosing-enviroment env) (cdr env))
(define (first-frame env) (car env))
(define empty-enviroment '())

(define (make-frame variables values) (cons variables values))
(define (frame-variables frame) (car frame))
(define (frame-values frame) (cdr frame))

(define (add-binding-to-frame! var val frame)
  (set-car! frame (cons var (frame-variables frame)))
  (set-cdr! frame (cons val (frame-values frame))))

(define (extend-enviroment vars vals base-env)
  (if (= (length vars) (length vals))
      (cons (make-frame vars vals) base-env)
      (if (< (length vars) (length vals))
          (error "Too many arguments supplied" vars vals)
          (error "Too few arguments supplied" vars vals))))

(define (lookup-variable-value var env)
  (define (env-loop env)
    (define (scan vars vals)
      (cond ((null? vars) (env-loop (enclosing-enviroment env)))
            ((eq? var (car vars)) (car vals))
            (else
             (scan (cdr vars) (cdr vals)))))
    (if (eq? env empty-enviroment)
        (error "Unbound variable" var)
        (let ((frame (first-frame env)))
          (scan (frame-variables frame)
                (frame-values frame)))))
  (env-loop env))

(define (set-variable-value! var val env)
  (define (env-loop env)
    (define (scan vars vals)
      (cond ((null? vars) (env-loop (enclosing-enviroment env)))
            ((eq? var (car vars)) (set-car! vals val))
            (else (scan (cdr vars) (cdr vals)))))

    (if (eq? env empty-enviroment)
        (error "Unbound variable -- SET!" var)
        (let ((frame (first-frame env)))
          (scan (frame-variables frame)
                (frame-values frame)))))
  (env-loop env))

(define (define-variable! var val env)
  (let ((frame (first-frame env)))
    (define (scan vars vals)
      (cond ((null? vars) (add-binding-to-frame! var val frame))
            ((eq? var (car vars)) (set-car! vals val))
            (else
             (scan (cdr vars) (cdr vals)))))
    (scan (frame-variables frame)
          (frame-values frame))))

(define (setup-enviroment)
  (let ((init-env
         (extend-enviroment (primitive-procedure-names)
                            (primitive-procedure-objects)
                            empty-enviroment)))
    (define-variable! 'true #t init-env)
    (define-variable! 'false #f init-env)
    init-env))

;;; ENVIROMENT PART END

;;; APPLY PART BEGIN

(define (_apply procedure args)
  (cond ((primitive-procedure? procedure) (apply-primitive-procedure procedure args))
        ((compound-procedure? procedure)
         (eval-sequence (procedure-body procedure)
                        (extend-enviroment
                         (procedure-parameters procedure)
                         args
                         (procedure-enviroment procedure))))
    (else
     (error "Unknown procedure type -- APPLY" procedure))))

(define (primitive-procedure? proc)
  (tagged-list? proc 'primitive))

(define (compound-procedure? proc)
  (tagged-list? proc 'procedure))
(define (procedure-parameters proc) (cadr proc))

(define (procedure-body proc) (caddr proc))

(define (procedure-enviroment proc) (cadddr proc))

(define (apply-primitive-procedure proc args)
  (apply-in-underlying-scheme (primitive-implementation proc) args))

(define (primitive-implementation proc) (cadr proc))

(define primitive-procedures
  (list
   (list 'car car)
   (list 'cdr cdr)
   (list 'cons cons)
   (list 'null? null?)
   (list 'eq? eq?)
   (list '+ +)
   (list '- -)
   (list '* *)
   (list '/ /)
   (list '> >)
   (list '< <)
   ))

(define (primitive-procedure-names) (map car primitive-procedures))

(define (primitive-procedure-objects)
  (map (lambda (proc) (list 'primitive (cadr proc))) primitive-procedures))
;;; APPLY PART END

;;; EVAL PART BEGIN
(define (eval expr env)
  (cond ((self-eval? expr) expr)
        ((variable? expr) (lookup-variable-value expr env))
        ((quote? expr) (text-of-quotation expr))
        ((assignment? expr) (eval-assignment expr env))
        ((definition? expr) (eval-definition expr env))
        ((if? expr) (eval-if expr env))
        ((lambda? expr)
         (make-procedure (lambda-parameters expr)
                         (lambda-body expr)
                         env))
        ((begin? expr)
         (eval-sequence (begin-actions expr) env))
        ((cond? expr) (eval (cond->if expr) env))
        ((application? expr)
         (display (operator expr))(_apply (eval (operator expr) env)
                (list-of-values (operands expr) env)))
         (else
          (error "Unknown expression type -- EVAL" expr))))

(define (list-of-values exprs env)
  (if (no-operands? exprs)
      '()
      (cons (eval (first-operand exprs) env)
            (list-of-values (rest-operand exprs) env))))

(define (application? expr)
  (pair? expr))

(define (operator expr) (car expr))
(define (operands expr) (cdr expr))

(define (no-operands? ops) (null? ops))
(define (first-operand ops) (car ops))
(define (rest-operand ops) (cdr ops))

(define (text-of-quotation expr)
  (cadr expr))

(define (eval-assignment expr env)
  (set-variable-value! (assignment-variable expr)
                       (eval (assignment-value expr) env)
                       env))

(define (eval-definition expr env)
  (define-variable! (definition-variable expr)
                        (eval (definition-value expr) env)
                         env)
'ok)

(define (eval-if expr env)
  (if (true? (if-predicate expr))
      (eval (if-consequent expr) env)
      (eval (if-alternative expr) env)))

(define (if-predicate expr)
  (cadr expr))

(define (if-consequent expr)
  (caddr expr))

(define (if-alternative expr)
  (if (not (null? (cdddr expr)))
      (cadddr expr)
      'false))

(define (make-if predicate consequent alternative)
  (list 'if predicate consequent alternative))

(define (make-procedure parameters body env)
  (list 'procedure parameters body env))

(define (make-lambda parameters body)
  (cons 'lambda (cons parameters body)))

(define (eval-sequence exprs env)
  (cond ((last-expr? exprs) (eval (first-expr exprs) env))
        (else
         (eval (first-expr exprs) env)
         (eval-sequence (rest-expr exprs) env))))

(define (sequence->expr seq)
  (cond ((null? seq) seq)
        ((last-expr? seq) (first-expr seq))
        (else
         (make-begin seq))))

(define (make-begin seq)
  (cons 'begin seq))

(define (begin-actions expr)
  (cdr expr))

(define (cond->if expr)
  (expand-clause (cond-clauses expr)))

(define (expand-clause clauses)
  (if (null? clauses)
      #f
      (let ((first (car clauses))
            (rest (cdr clauses)))
        (if (cond-else-clauses? first)
            (if (null? rest)
                (sequence->expr (cond-actions first))
                (error "ELSE clause isn't last -- COND->IF" clauses))
            (make-if (cond-predicate first)
                     (sequence->expr (cond-actions first))
                     (expand-clause rest))))))
            
(define (cond-clauses expr)
  (cdr expr))

(define (cond-else-clauses? clause)
  (eq? (cond-predicate clause) 'else))

(define (cond-predicate clause)
  (car clause))

(define (cond-actions clause)
  (cdr clause))

(define (cond? expr)
  (tagged-list? expr 'cond))

(define (begin? expr)
  (tagged-list? expr 'begin))

(define (last-expr? seq)
  (null? (cdr seq)))
(define (first-expr seq)
  (car seq))

(define (rest-expr seq)
  (cdr seq))

(define (lambda? expr)
  (tagged-list? expr 'lambda))

(define (lambda-parameters expr)
  (cadr expr))

(define (lambda-body expr)
  (cddr expr))

(define (true? expr)
  (not (eq? #f expr)))

(define (false? expr)
  (eq? #f expr))

(define (if? expr)
  (tagged-list? expr 'if))

(define (definition? expr)
  (tagged-list? expr 'define))

(define (definition-variable expr)
  (if (symbol? (cadr expr))
      (cadr expr)
      (caddr expr)))

(define (definition-value expr)
  (if (symbol? (cadr expr))
      (caddr expr)
      (make-lambda (cdadr expr)
                   (cddr expr))))

(define (assignment? expr)
  (tagged-list? expr 'set!))

(define (assignment-variable expr)
  (cadr expr))

(define (assignment-value expr)
  (caddr expr))

(define (quote? expr)
  (tagged-list? expr 'quote))

(define (tagged-list? expr tag)
  (if (pair? expr)
      (eq? (car expr) tag)
      #f))

(define (variable? expr)
  (symbol? expr))

(define (self-eval? expr)
  (cond ((number? expr) #t)
        ((string? expr) #t)
        (else #f)))
;;; EVAL PART END

;;; GLOBAL DEFINITION BEGIN

(define global-env (setup-enviroment))


(define input-prompt ";;; M-Eval input:")
(define output-prompt ";;; M-Eval value:")

(define (driver-loop)
  (prompt-for-input input-prompt)
  (let ((inputs (read)))
    (display (format "INPUT: ~a" inputs))
    (let ((output (eval inputs global-env)))
      (announce-output output-prompt)
      (user-print output)))
  (driver-loop))

(define (prompt-for-input text)
  (newline)
  (newline)
  (display text)
  (newline))

(define (announce-output text)
  (newline)
  (display text)
  (newline))

(define (user-print object)
  (if (compound-procedure? object)
      (display (list 'compound-procedure
                     (procedure-parameters object)
                     (procedure-body object)
                     (procedure-enviroment object)))
      (display object)))

;;; GLOBAL DEFINITION END

;;; TEST-CASE BEGIN
;;; test-case list
(define test-cases
  (list
  (cons 'self-eval-expr '3)
  (cons 'definition-expr '(define x 10))
  (cons 'variable-expr 'x)
  (cons 'quote-expr '(quote a))
  (cons 'assignement-expr '(set! x 3))
  (cons 'if-expr '(if #f 1 0))
  (cons 'lambda-expr '(lambda (x) 1))
  (cons 'begin-expr '(begin '3 '4))
  (cons 'cond-expr '(cond ((#f) 1) (else #f)))
  (cons 'end-expr '(quote done))))

;;; run all test-cases
(define (run-test-suite test-case-list)
  (display "Run test...")
  (newline)
  (let ((i 1))
  (for ((test-case test-case-list))
    (display (format "Case ~a - " i))
    (display (car test-case))
    (display " => ")
    (display (eval (cdr test-case) global-env))
    (newline)
    (set! i (+ i 1))))
  )

(run-test-suite test-cases)

(driver-loop)