Skip to content

Instantly share code, notes, and snippets.

@chelseatroy

chelseatroy/scheme.rkt

Last active Nov 7, 2019
Embed
What would you like to do?
Lazy Scheme Interpreter in Scheme
#lang racket
; Metacircular evaluator with lazy evaluation
; New features
; "Thunk:" An unevaluated expression along with an environment (where it would evaluate)
(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))
; Evaluation of thunks
(define (force-it obj)
(if (thunk? obj)
(actual-value (thunk-exp obj) (thunk-env obj))
obj))
; Unwinds all possible thunks until an actual value is encountered
(define (actual-value sexp env)
(force-it (seval sexp env)))
; Evaluate a "scheme" expression
; Purpose of fail: backtrack or unwind
;You can neer return a result. You can only succeed or fail.
(define (seval sexp succeed fail env)
(cond ((primitive? sexp) sexp)
((symbol? sexp) (succeed (lookup-environment env sexp) fail))
; Special forms
((define? sexp) (seval-define sexp env))
((if? sexp) (succeed (seval-if sexp env) fail)
((lambda? sexp) (succeed (seval-lambda sexp env) fail))
; 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-listsucced fail env)
(if (null? (cdr sexp-list))
(seval (car sexp-list) env)
(begin
(seval (car sexp-list)
(lambda (result fail2)
(seval-many 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 (proc-name parameters) exp-list)
(define (define? sexp)
(and (pair? sexp) (eq? (car sexp) 'define)))
(define (define-name sexp)
(if (pair? (cadr sexp))
(caadr sexp)
(cadr sexp)))
(define (define-value sexp)
(if (pair? (cadr sexp))
(let ((parameters (cdr (cadr sexp)))
(expressions (cddr sexp)))
(append (list 'lambda parameters) expressions)
)
(caddr sexp)
)
)
(define (seval-define sexp env)
(let ((name (define-name sexp))
(value (define-value sexp)))
(seval value
(lambda (result fail2)
(define-in-environment env name (actual-value value env name result)) fail 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 (actual-value test env)
(seval then-clause env) ; Do we delay? Or force?
(seval else-clause env))))
; "selectors" (extracting info from an expression)
(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 succeed fail env)
(succeed (make-procedure (lambda-parameters sexp)
(lambda-expressions sexp)
env) fail))
(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 (procedure-env proc)
(cadddr proc))
(define (procedure-parameters proc)
(cadr proc))
(define (procedure-expressions proc)
(caddr proc))
(define (user-procedure? proc)
(and (pair? proc) (eq? (car proc) 'user-procedure)))
; Data Structures
(define (cons x y)
(lambda (m) (m x y)))
(define (car z)
(z (lambda (p q) p)))
(define (cdr z)
(z (lambda (p q) q)))
(define (liust-ref items n)
(if (= n 0)
(car items)
(list-ref (cdr items) (- n 1))))
(define (map proc items)
(if (null? items)
'()
(cons (proc (car items))
(map proc (cdr items)))))
(define (scale-list items factor)
(map (lambda (x) (* x factor))
items))
(define (add-lists list1 list2)
(cond ((null? list1) list2)
((null? list2) list1)
(else (cons (+ (car list1) (car list2))
(add-lists (cdr list1) (cdr list2))))))
(define ones (stream-cons 1 ones))
(define integers (stream-cons 1 (add-lists ones integers)))
; Evaluation of a procedure call
; (proc arg1 arg2 arg3 ... argn)
(define (sapply sexp env)
(let((args (cdr sexp)))
(seval (car sexp)
; Must be able to distinguish between built-in scheme procedures and
; user-defined procedures created with lambda
(lambda (proc fail2)
(if (user-procedure? proc)
(apply-user-procedure proc args env) ; Lambda procedure
(apply-builtin-procedure proc args env)) ; Builtin- Scheme/Racket procedure
))))
(define (apply-builtin-procedure proc args env)
(let ((evaluated-args (map (lambda (arg) (actual-value arg env)) args)))
(apply proc evaluated-args))
)
(define (bind-arguments parameters args env)
(if (null? parameters)
'done
(begin
(define-in-environment env (car parameters) (car args))
(bind-arguments (cdr parameters) (cdr args) env))))
(define (apply-user-procedure proc args env)
(let ((delayed-args (map (lambda (arg) (delay-it arg env)) args))
; Make a new environment (local scope)
(new-env (make-environment (procedure-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)
)
)
; Implementation of the environment
; Modify: To allow nested environments
; Proposal: Define the environment as a list
(define (make-environment parent-env)
(cons (make-hash) parent-env)
)
(define (lookup-environment env name)
(if (null? env)
(error "Bad name")
(if (hash-has-key? (car env) name)
(hash-ref (car env) name)
(lookup-environment (cdr env) name))))
(define (set-environment! env name value)
(if (null? env)
(error "Bad Name")
(if (hash-has-key? (car env) name)
(hash-set! (car env) name value)
(set-environment! (cdr env) name value))))
(define (define-in-environment env name value)
(hash-set! (car env) name value)
)
; Define the "global" environment. Note: The parent environment is '() (null)
(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 '>= >=)
(define-in-environment env '= =)
(define-in-environment env 'cons cons)
(define-in-environment env 'car car)
(define-in-environment env 'cdr cdr)
(define-in-environment env 'abs abs)
(define-in-environment env 'true true)
(define-in-environment env 'false false)
(define-in-environment env 'displayln displayln)
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.