Created
October 8, 2011 12:10
-
-
Save bullno1/1272229 to your computer and use it in GitHub Desktop.
Yo Dawg Scheme Interpreter
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
(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)) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
(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