Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
Scheme Interpreter in Scheme
#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)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.