scheme in one lambda, self-evaluating

lambda2.rkt

#lang racket

; host eval implementation
((lambda (e env)
   ((lambda (eval apply)
      (eval eval apply e env)) ; call eval
    (lambda (eval^ apply^ e env) ; define eval
      ;(printf "ENV: ~a~%" env)
      (printf "EXP: ~a~%" e)
      (if (symbol? e)
          (car (cdr (assq e env)))
          (if (pair? e)
              (if (eq? (car e) #\λ)
                  (list 'closure e env)
                  (if (eq? (car e) 'if)
                      (if (eval^ eval^ apply^ (car (cdr e)) env)
                          (eval^ eval^ apply^ (car (cdr (cdr e))) env)
                          (eval^ eval^ apply^ (car (cdr (cdr (cdr e)))) env))
                      (if (eq? (car e) 'quote)
                          (car (cdr e))
                          (apply^ apply^ eval^ (eval^ eval^ apply^ (car e) env)
                                  ; inline evlist
                                  ((lambda (e1 env1)
                                     ((lambda (evlist)
                                        (evlist evlist e1 env1))  ; call evlist
                                      (lambda (evlist^ e1 env1)  ; define evlist
                                        (if (null? e1)
                                            '()
                                            (cons (eval^ eval^ apply^ (car e1) env1) (evlist^ evlist^ (cdr e1) env1))))))
                                   (cdr e) env)))))
              e)))
    (lambda (apply^ eval^ f x) ; define apply
      (printf "~a ::: ~a ~%" f x)
      (if (procedure? f)
          (apply f x)
          (eval^ eval^ apply^ (car (cdr (cdr (car (cdr f)))))
                 ; inline newenv
                 ((lambda (names values env)
                    ((lambda (newenv)
                       (newenv newenv names values env)) ; call newenv
                     (lambda (newenv^ names values env) ; define newenv
                       (if (null? names)
                           env
                           (cons (list (car names) (car values))
                                 (newenv^ newenv^ (cdr names) (cdr values) env))))))
                  
                  (car (cdr (car (cdr f)))) x (car (cdr (cdr f)))
                  
                  ) ) ))
    ))
 
 ; expression
 ;'((#\λ (x) x ) 1 )
 ;'(cons 1 2)
 ;'(if #t 1 2)
 ;`(inc (inc (inc 3)))
 ;`(((curry2 ,+) 1 ) 2 )
 ;`(((curry2 ,-) 12 ) 7 )

 ; REPL interpreted by host eval/apply implementation above,
 ; with a few test primitives and closures in the environment
 `(print (eval (read) '((inc    (closure (#\λ (x) (,+ x 1)) '()))
                        (curry2 (closure (#\λ (f)
                                              (#\λ (x)
                                                   (#\λ (y) (f x y))))
                                         '()))
                        (- ,-)
                        (+ ,+)
                        )
               ))
 
 ; environment containing built-in primitives
 ; required by the host eval implementation
 `((cons   ,cons)
   (car    ,car)
   (cdr    ,cdr)
   (list   ,list)
   (eq?    ,eq?)
   (symbol? ,symbol?)
   (null?  ,null?)
   (pair?  ,pair?)
   (procedure? ,procedure?)
   (eof-object? ,eof-object?)
   (assq ,assq)
   (printf ,printf)
   (read ,read)
   (print ,display)
   (apply ,apply)
   
   ; guest eval implementation equivalent to above interpreter,
   ; to show that our eval implementation can eval itself
   (eval (closure (#\λ (e env)
                       ((#\λ (eval apply)
                             (eval eval apply e env)) ; call eval
                        (#\λ (eval^ apply^ e env) ; define eval
                             (if (symbol? e)
                                 (car (cdr (assq e env)))
                                 (if (pair? e)
                                     (if (eq? (car e) #\λ)
                                         (list 'closure e env)
                                         (if (eq? (car e) 'if)
                                             (if (eval^ eval^ apply^ (car (cdr e)) env)
                                                 (eval^ eval^ apply^ (car (cdr (cdr e))) env)
                                                 (eval^ eval^ apply^ (car (cdr (cdr (cdr e)))) env))
                                             (if (eq? (car e) 'quote)
                                                 (car (cdr e))
                                                 (apply^ apply^ eval^ (eval^ eval^ apply^ (car e) env)
                                                         ; inline evlist
                                                         ((#\λ (e1 env1)
                                                               ((#\λ (evlist)
                                                                     (evlist evlist e1 env1))  ; call evlist
                                                                (#\λ (evlist^ e1 env1)  ; define evlist
                                                                     (if (null? e1)
                                                                         '()
                                                                         (cons (eval^ eval^ apply^ (car e1) env1) (evlist^ evlist^ (cdr e1) env1))))))
                                                          (cdr e) env)))))
                                     e)))
                        (#\λ (apply^ eval^ f x) ; define apply
                             (if (procedure? f)
                                 (apply f x)
                                 (eval^ eval^ apply^ (car (cdr (cdr (car (cdr f)))))
                                        ; inline newenv (it extends an environment)
                                        ((#\λ (names values env)
                                              ((#\λ (newenv)
                                                    (newenv newenv names values env)) ; call newenv
                                               (#\λ (newenv^ names values env) ; define newenv
                                                    (if (null? names)
                                                        env
                                                        (cons (list (car names) (car values))
                                                              (newenv^ newenv^ (cdr names) (cdr values) env))))))
                                         
                                         (car (cdr (car (cdr f)))) x (car (cdr (cdr f))))) ))
                        ))
                  
                  ; environment containing built-in primitives required
                  ; by the guest eval implementation above
                  ((cons   ,cons)
                   (car    ,car)
                   (cdr    ,cdr)
                   (list   ,list)
                   (eq?    ,eq?)
                   (symbol? ,symbol?)
                   (null?  ,null?)
                   (pair?  ,pair?)
                   (procedure? ,procedure?)
                   (eof-object? ,eof-object?)
                   (assq ,assq)
                   (printf ,printf)
                   (apply ,apply))
                  ))
   )
 )