Scheme Interpreter in Scheme

scheme.rkt

#lang racket
; Metacircular evaluator

; Evaluate a "scheme" expression
(define (seval sexp env)
  (cond ((primitive? sexp) sexp)
        ((symbol? sexp) (lookup-environment env sexp))
        ; Special forms
        ((define? sexp) (seval-define sexp env))
        ((if? sexp) (seval-if sexp env))
        ((begin? sexp) (seval-begin sexp env))
        ((lambda? sexp) (seval-lambda sexp env))
        
        ; Procedure application
        ((list? sexp) (sapply sexp env))
        (else (error "Bad expression"))))

; Evaluate many scheme expressions, returning only the value of the last one
(define (seval-many sexp-list env)
  (if (null? (cdr sexp-list))
      (seval (car sexp-list) env)
      (begin
        (seval (car sexp-list) env)
        (seval-many (cdr sexp-list) env)
        )
  ))

; Basic objects like ints, floats, numbers, true/false
(define (primitive? sexp)
  (or (number? sexp) (boolean? sexp)))

; Define special form
; (define name value)
(define (define? sexp)
  (and (pair? sexp) (eq? (car sexp) 'define)))

(define (define-name sexp)
  (cadr sexp))

(define (define-value sexp)
  (caddr sexp)
  )

(define (seval-define sexp env)
  (let ((name (define-name sexp))
        (value (define-value sexp)))
    (if (pair? name)
        (define-in-environment env name (seval-lambda value env))
        (define-in-environment env name (seval value env)))))

; (if test then-clause else-clause)
(define (if? sexp)
  (and (pair? sexp) (eq? (car sexp) 'if)))
  
(define (seval-if sexp env)
  (let ((test (if-test sexp))
        (then-clause (if-then-clause sexp))
        (else-clause (if-else-clause sexp)))
    (if (seval test env)
        (seval then-clause env)
        (seval else-clause env))))
(define (if-test sexp) (cadr sexp))
(define (if-then-clause sexp) (caddr sexp))
(define (if-else-clause sexp) (cadddr sexp))

; (begin exp1 exp2 exp3 ... expn)
(define (begin? sexp)
  (and (pair? sexp) (eq? (car sexp) 'begin)))
 
(define (seval-begin sexp env)
  (seval-many (cdr sexp) env))

; (lambda (parameters) exp1 exp2 ... expn)
(define (lambda? sexp)
  (and (pair? sexp) (eq? (car sexp) 'lambda)))
    
(define (lambda-parameters sexp) (cadr sexp))
    
(define (lambda-expressions sexp) (cddr sexp))
    
(define (seval-lambda sexp env)
  (make-procedure (lambda-parameters sexp)
                  (lambda-expressions sexp)
                  env))

(define (make-procedure parameters expressions env)
  ; Creating some kind of type-tagged list or some other data structure that
  ; can be examined to see if it's a user procedure or not
  (list 'user-procedure parameters expressions env)  
  )

(define (user-procedure? proc)
  (and (pair? proc) (eq? (car proc) 'user-procedure)))
; Evaluation of a procedure call
; (proc arg1 arg2 arg3 ... argn)

(define (sapply sexp env)
  (let ((proc (actual-value (car sexp) env))
        (args (cadr sexp))))
    ; Must be able to distinguish between built-in scheme procedures and
    ; user-defined procedures created with lambda
    (if (user-procedure? proc)
        (apply-user-procedure proc args)  ; Lambda procedure
        (apply proc args))   ; Scheme procedure    
  )

(define (apply-builtin-procedure proc args env)
  (let ((evaluated-args 

(define (apply-user-procedure proc args env)
  ; make a new environment (local scope)
  (let ((delayed-args (map (lambda (arg) (delay-it arg env)) args)))
        
  ;Make a new environment
  (define new-env (make-environment (env proc)))
     
  ; bind argument values to parameter names
  (bind-arguments (procedure parameters proc) delayed-args new-env)
  ; evaluate the expressions (in the lambda) in the new environment
    (seval-many (procedure-expressions proc) new-env)))

;Thunk: an unevaluated exression along with an environment
(define (delay-it sexp env)
  (list 'thunk sexp env))

(define (thunk? obj)
  (and (pair? obj) (eq? (car obj) 'thunk)))

(define (thunk-exp obj)
  (cadr obj))

(define (thunk-env obj)
  (caddr obj))

(define (force-it obj)
  (if (thunk? obj)
      (actual-value (thunk-exp obj) (thunk-env obj))
      obj))

; Implementation of the environment  
  
(define (make-environment parent-env)
  (cons (make-hash) parent-env)
  )

(define (lookup-environment env name)
  (if (null? env)
      (null)
      (if (hash-has-key? (car env) name)
          (hash-ref env name)
          (lookup-environment (cdr env) name)))
  )
 
(define (define-in-environment env name value)
  (hash-set! env name value)
  )

; Define the "global" environment
(define env (make-environment '()))

; Define the "built-in" operators 
(define-in-environment env '+ +)
(define-in-environment env '- -)
(define-in-environment env '* *)
(define-in-environment env '/ /)
(define-in-environment env '< <)
(define-in-environment env '> >)
(define-in-environment env '= =)
(define-in-environment env 'cons cons)
(define-in-environment env 'car car)
(define-in-environment env 'cdr cdr)