Skip to content

Instantly share code, notes, and snippets.

@bullno1
Created October 8, 2011 12:10
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
Star You must be signed in to star a gist
Save bullno1/1272229 to your computer and use it in GitHub Desktop.
Yo Dawg Scheme Interpreter
(load "yo_dawg.rkt")
(define test-fib
'[(define (fib n)
(if (<= n 2)
1
(+ (fib (- n 1)) (fib (- n 2)))))
(fib 6)])
(evaluate-block test-fib)
(define fib (get-global 'fib));retrieve the synthesized procedure
(fib 5);it can be used as a normal procedure
(evaluate-block '[(begin
(display "a")
(newline)
(display "b")
(newline)
1)])
(define test-tail-recursion
'[(define (loop N)
(if (> N 0)
(loop (- N 1))))
(loop 5000)])
(evaluate-block test-tail-recursion)
;benchmark
(time (fib 25))
(define(s-fib n)
(if (<= n 2)
1
(+ (s-fib (- n 1)) (s-fib (- n 2)))))
(time (s-fib 25))
(newline)
(define loop (get-global 'loop))
(time (loop 5000))
(define (s-loop N)
(if (> N 0)
(s-loop (- N 1))))
(time (s-loop 5000))
(require racket/mpair)
;----------------evaluation---------------------
;Evaluate expression exp inside frame and return the result
(define (evaluate-in frame exp)
(cond
((or (boolean? exp) (number? exp) (string? exp)) exp);keep boolean, number, string intact
((symbol? exp) (frame-get frame exp));lookup value of symbol
((list? exp) (evaluate-list exp frame))
(else "Cannot evaluate" exp)))
;Evaluate list lst inside frame using eval-apply rule
(define (evaluate-list lst frame)
(let ((first-element (car lst))
(rest (cdr lst))
(error (lambda (value);error reporting shortcut
(error "Expected procedure, got" value " in " lst))))
(cond
((symbol? first-element);if the first element is a symbol
(let ((special-form (get-special-form first-element)));test if the first element is a special form
(if special-form
(apply special-form (cons frame rest));pass the rest of the list and the frame as arguments
(let ((value (frame-get frame first-element)));look up the value of the first element
(if (procedure? value)
(apply-procedure value rest frame);apply if it is a procedure
(error value))))))
((list? first-element);if the first element is a list
(let ((value (evaluate-list lst frame)));evaluate the list
(if (procedure? value);if the result is a procedure
(apply-procedure value rest frame);apply it
(error value))))
(else (error value)))))
(define (apply-procedure proc param-exps frame)
(let ((params (map (lambda (exp)
(evaluate-in frame exp))
param-exps)));evaluate all sub expressions
(apply proc params)));apply
;evaluate a block of code and return the result of the last expression
(define (evaluate-block-in frame exps)
(define (helper exps result)
(if (null? exps)
result
(helper (cdr exps)
(evaluate-in frame (car exps)))))
(helper exps (void)))
;----------------------------------
;-------------frame----------------
;make a frame linked to a parent
(define (make-frame parent)
(mcons parent '()))
;get the value of a symbol from a frame
(define (frame-get frame key)
(let ((pair (massq key (mcdr frame)));search for pair
(parent (mcar frame)))
(cond
(pair (mcdr pair));return if found
((not (null? parent)) (frame-get parent key));search in parent
(else (error "Unknown symbol" key)))))
;set the value of the pair in the nearest frame
(define (frame-set! frame key value)
(let ((pair (massq key (mcdr frame)));search for pair
(parent (mcar frame)))
(cond
(pair (set-mcdr pair value));set here if found
(parent (frame-set! parent key value));try to set in parent
(else (error "Unknown symbol" key)))))
;put a key-value pair into the frame
(define (frame-put! frame key value)
(let ((pair (massq key (mcdr frame))))
(if pair
(set-mcdr! pair value)
(set-mcdr! frame (mcons (mcons key value)
(mcdr frame))))))
;----------------------------------
;----------special form------------
(define special-forms '())
;register a special form
;A special form has the signature (frame . more-params) -> anything
(define (register-special-form name proc)
(set! special-forms (cons (cons name proc)
special-forms)))
;retrive a special form
(define (get-special-form name)
(let ((pair (assq name special-forms)))
(if pair
(cdr pair)
#f)))
;----------------------------------
;----------------global------------
(define global-environment (make-frame '()))
;evaluate an expression in the global environment
(define (evaluate exp)
(evaluate-in global-environment exp))
;evaluate a list of expressions in the global environment
(define (evaluate-block exps)
(evaluate-block-in global-environment exps))
;define a global variable
(define (define-global name value)
(frame-put! global-environment name value))
;set a predefined global variable
(define (set-global! name value)
(frame-set! global-environment name value))
;get a global variable
(define (get-global name)
(frame-get global-environment name))
;----------------------------------
;-------primitive registration-----
;arithmetic
(define-global '+ +)
(define-global '- -)
(define-global '* *)
(define-global '/ /)
;comparison
(define-global '= =)
(define-global '< <)
(define-global '> >)
(define-global '>= >=)
(define-global '<= <=)
;misc
(define-global 'display display)
(define-global 'newline newline)
;special forms
(define-global
'!=
(lambda (lhs rhs)
(not (= lhs rhs))))
(define-global 'not not)
(register-special-form
'define
(lambda (frame firstParam . more)
(cond
((symbol? firstParam);first form
(frame-put! frame firstParam (evaluate-in frame (car more))))
((list? firstParam);second form
(let* ((lambda_ (get-special-form 'lambda))
(proc
(apply lambda_ (append (list frame (cdr firstParam)) more))))
(frame-put! frame (car firstParam) proc)))
(else (error "Syntax error" (cons firstParam more))))))
(register-special-form
'if
(lambda (frame condition then . else)
(define (evaluate exp)
(evaluate-in frame exp))
(cond
((evaluate condition) (evaluate then))
((not (null? else)) (evaluate (car else))))))
(register-special-form
'lambda
(lambda (frame param-names . body)
(define (bind-param names values frame)
(if (not (null? names))
(begin
(frame-put! frame (car names) (car values))
(bind-param (cdr names) (cdr values) frame))))
(let ((my-frame (make-frame frame))
(arity (length param-names)))
(lambda params
(let ((param-count (length params)))
(if (= arity param-count)
(let ((call-frame (make-frame my-frame)))
(bind-param param-names params call-frame)
(evaluate-block-in call-frame body))
(error "Expected" arity 'parameters 'got param-count)))))))
(register-special-form
'begin
(lambda (frame . body)
(evaluate-block-in frame body)))
(register-special-form
'set!
(lambda (frame symbol exp)
(if (symbol? symbol)
(frame-set! frame symbol (evaluate-in frame exp))
(error "Expected symbol, got" symbol))))
(register-special-form
'time
(lambda (frame exp)
(time (evaluate-in frame exp))))
;----------------------------------
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment