From: Ramakrishnan Muthukrishnan Date: Sun, 27 May 2012 16:30:34 +0000 (+0530) Subject: Lazy version of evaluator and tests. X-Git-Url: https://git.rkrishnan.org/components/com_hotproperty/frontends/FOOURL?a=commitdiff_plain;h=185aeca90595562fd31b2cdb730a12488d155348;p=sicp.git Lazy version of evaluator and tests. --- diff --git a/src/sicp/metacircular2-lazy-test.rkt b/src/sicp/metacircular2-lazy-test.rkt new file mode 100644 index 0000000..b19f2c8 --- /dev/null +++ b/src/sicp/metacircular2-lazy-test.rkt @@ -0,0 +1,88 @@ +#lang racket + +(require "metacircular2-lazy.rkt" + rackunit) + +(require rackunit/text-ui) + +(define metacircular2-tests + (test-suite "test suite for meta circular evaluator" + (let ([env1 (make-environment)]) +#| + (check-equal? (eval '(+ 1 1) env1) 2 "simple addition") + (check-equal? (eval '(- 2 1) env1) 1 "simple subtraction") + (check-equal? (eval '(quote x) env1) 'x "quote") + (eval '(define x 20) env1) + (check-equal? (eval 'x env1) 20 "definition of identifiers with simple values") + (eval '(set! x 42) env1) + (check-equal? (eval 'x env1) 42 "set!") + (eval '(define (square x) (* x x)) env1) + (check-equal? (eval '(square 10) env1) 100 "simple function definition") + (eval '(define (square x) (let ([s (* x x)]) s)) env1) + (check-equal? (eval '(square 20) env1) 400 "different way to define square") + (eval '(define (absolute x) + (cond ((> x 0) x) + ((= x 0) (display 'zero) 0) + (else (- x)))) + env1) + (check-equal? (eval '(absolute -2) env1) 2 "conditionals") + (check-equal? (eval '(absolute 2) env1) 2 "conditionals") + (eval '(define (foo) (let ((x 42) (y 100)) (list x y))) env1) + (check-equal? (eval '(foo) env1) '(42 100) "simple let") + (check-equal? (eval '(let* ((x 3) + (y (+ x 2)) + (z (+ x y 5))) + (* x z)) + env1) + 39 + "let* test") + (eval '(define (f x) + (define (even? n) + (if (= n 0) + true + (odd? (- n 1)))) + (define (odd? n) + (if (= n 0) + false + (even? (- n 1)))) + (odd? x)) + env1) + (check-equal? (eval '(f 2) env1) false "internal definitions") + (check-equal? (eval '(f 3) env1) true "internal definitions") + (eval '(define (f1 x) + (letrec ((even? + (lambda (n) + (if (= n 0) + true + (odd? (- n 1))))) + (odd? + (lambda (n) + (if (= n 0) + false + (even? (- n 1)))))) + (even? x))) + env1) + (check-equal? (eval '(f1 2) env1) true "internal definitions") + (check-equal? (eval '(f1 3) env1) false "internal definitions") + (eval '(define (fib n) + (let fib-iter ((a 1) + (b 0) + (count n)) + (if (= count 0) + b + (fib-iter (+ a b) a (- count 1))))) + env1) + (check-equal? (eval '(fib 10) env1) 55 "named let") + (eval '(define (factorial n) + (if (= n 1) + 1 + (* (factorial (- n 1)) n))) + env1) + (check-equal? (eval '(factorial 10) env1) 3628800 "factorial test") + (check-equal? (eval '(unless true "true" "false") env1) "false" "unless test 1") + (check-equal? (eval '(unless false "true" "false") env1) "true" "unless test 2")))) +|# + (eval '(define (try a b) (if (= a 0) 1 b)) env1) + (check-equal? (eval '(try 0 (/ 1 0)) env1) 1 "lazy test1")))) + +(run-tests metacircular2-tests) \ No newline at end of file diff --git a/src/sicp/metacircular2-lazy.rkt b/src/sicp/metacircular2-lazy.rkt new file mode 100644 index 0000000..b41ab4b --- /dev/null +++ b/src/sicp/metacircular2-lazy.rkt @@ -0,0 +1,278 @@ +#lang racket + +(require (rename-in racket/base + (apply apply-in-underlying-scheme) + (eval eval-in-underlying-scheme))) + +(provide (all-defined-out)) + +(define (self-evaluating? expr) + (match expr + [(? number? expr) #t] + [(? char? expr) #t] + [(? string? expr) #t] + [_ #f])) + +(define (variable? expr) (symbol? expr)) + +;; sequence +(define (eval-sequence exps env) + (cond + [(last-exp? exps) (eval (first-exp exps) env)] + [else (eval (first-exp exps) env) + (eval-sequence (rest-exps exps) env)])) + +;; begin +(define (last-exp? seq) (null? (cdr seq))) +(define (first-exp seq) (car seq)) +(define (rest-exps seq) (cdr seq)) + +;; lambda +(define (make-lambda parameters body) + (cons 'lambda (cons parameters body))) + +;; environment data structures +(define (enclosing-environment env) (cdr env)) +(define (first-frame env) (car env)) +(define the-empty-environment '()) + +(define (make-frame variables values) + (let ([ht (make-hash)]) + (for-each (lambda (var val) + (hash-set! ht var val)) + variables + values) + ht)) + +(define (frame-variables frame) + (hash-keys frame)) + +(define (frame-values frame) + (hash-values frame)) + +(define (add-binding-to-frame! var val frame) + (hash-set! frame var val)) + +;; environment is a list of frames, most recent being the last +;; one consed into the list +(define (extend-environment vars vals base-env) + (let ([frame (make-frame vars vals)]) + (cons frame base-env))) + +(define (lookup-variable-value var env) + (if (eq? env the-empty-environment) + (error "unbound variable: " var) + (let ([frame (first-frame env)]) + (let ([value (hash-ref frame var (lambda () (lookup-variable-value var (enclosing-environment env))))]) + (if (eq? value '*unassigned*) + (error "evaluating a variable that is not assigned a value -- " var) + value))))) + +(define (set-variable-value! var val env) + (if (eq? env the-empty-environment) + (error "unbound variable: " var) + (let ([frame (first-frame env)]) + (if (hash-has-key? frame var) + (hash-set! frame var val) + (set-variable-value! var val (enclosing-environment env)))))) + +(define (define-variable! var val env) + (let ([frame (first-frame env)]) + (if (hash-has-key? frame var) + (hash-set! frame var val) + (add-binding-to-frame! var val frame)))) + +;; primitive procedure +(define (primitive-implementation proc) (cadr proc)) + +(define primitive-procedures + (list (list 'car car) + (list 'cdr cdr) + (list 'cons cons) + (list 'null? null?) + (list 'list list) + (list '+ +) + (list '- -) + (list '* *) + (list '/ /) + (list '= =) + (list '> >) + (list '< <))) + +(define (primitive-procedure-names) + (map car primitive-procedures)) + +(define (primitive-procedure-objects) + (map (lambda (proc) (list 'primitive (cadr proc))) + primitive-procedures)) + +(define (apply-primitive-procedure proc args) + (apply-in-underlying-scheme + (primitive-implementation proc) args)) + +;; global env +(define (make-environment) + (let ((initial-env + (extend-environment (primitive-procedure-names) + (primitive-procedure-objects) + the-empty-environment))) + (define-variable! 'true true initial-env) + (define-variable! 'false false initial-env) + initial-env)) + +(define the-global-environment (make-environment)) + +;; application +(define (list-of-values exps env) + (if (no-operands? exps) + '() + (cons (eval (first-operand exps) env) + (list-of-values (rest-operands exps) env)))) + +(define (no-operands? ops) (null? ops)) +(define (first-operand ops) (car ops)) +(define (rest-operands ops) (cdr ops)) + +;; compound procedure +(define (make-procedure params body env) + (list 'procedure params (scan-out-definitions body) env)) + +(define (procedure-parameters p) (cadr p)) +(define (procedure-body p) (scan-out-definitions (caddr p))) +(define (procedure-environment p) (cadddr p)) + +(define (apply procedure arguments env) + (match procedure + [`(primitive ,f ...) (apply-primitive-procedure procedure (list-of-arg-values arguments env))] + [`(procedure ,f ...) (eval-sequence + (procedure-body procedure) + (extend-environment + (procedure-parameters procedure) + (list-of-delayed-args arguments env) + (procedure-environment procedure)))] + [_ (error "Unknown procedure type -- APPLY" procedure)])) + +(define (list-of-arg-values exps env) + (if (no-operands? exps) + '() + (cons (actual-value (first-operand exps) env) + (list-of-arg-values (rest-operands exps) env)))) + +(define (list-of-delayed-args exps env) + (if (no-operands? exps) + '() + (cons (delay-it (first-operand exps) env) + (list-of-delayed-args (rest-operands exps) env)))) + +;; truth +(define (true? x) + (not (eq? x false))) + +(define (false? x) + (eq? x false)) + +;; cond +(define (cond->if clauses) + (define (seq->exp actions) + (if (empty? (cdr actions)) + (car actions) + `(begin ,@actions))) + (if (empty? clauses) + 'false + (let ([clause (car clauses)]) + (match clause + [`(else ,action ...) (seq->exp action)] + [`(,pred ,action ...) `(if ,pred + ,(seq->exp action) + ,(cond->if (cdr clauses)))])))) + +;; let +(define (let->combination lexpr) + (match-let* ([`(let ,(? (lambda (x) (or (pair? x) (empty? x))) bindings) ,body ..1) lexpr] + [`((,var ,val) ...) bindings]) + `((lambda ,var ,@body) ,@val))) + +;; named let +(define (named-let->combination lexpr) + (match-let* ([`(let ,(? symbol? name) ,(? (lambda (x) (or (pair? x) (empty? x))) bindings) ,body ..1) lexpr] + [`((,var ,val) ...) bindings]) + `(begin (define ,name (lambda ,var ,@body)) + (,name ,@val)))) + +;; let* +(define (let*->nested-lets lexpr) + (match lexpr + [`(let* (,first-binding ,rest-bindings ...) ,body ..1) + `(let (,first-binding) ,(let*->nested-lets `(let* ,rest-bindings ,@body)))] + [`(let* () ,body ..1) `(let () ,@body)])) + +;; internal definitions +(define (scan-out-definitions body) + (match body + [`((define ,var ,e) ..1 ,rest) + `((let ,(map (lambda (v) (list (car v) ''*unassigned*)) var) + ,@(map (lambda (v e) `(set! ,(car v) (lambda ,(cdr v) ,e))) var e) + ,rest))] + [_ body])) + +;; letrec +(define (letrec->combination lexpr) + (match lexpr + [`(letrec (,bindings ...) ,body ..1) + `(let ,(map (lambda (v) (list (car v) ''*unassigned*)) bindings) + ,@(map (lambda (binding) + (let ([name (car binding)] + [value (cadr binding)]) + `(set! ,name ,value))) + bindings) + ,@body)])) + +;; thunks +(define (actual-value exp env) + (force-it (eval exp env))) + +(define (force-it obj) + (match obj + [`(thunk ,exp ,env) (actual-value exp env)] + [_ obj])) + +(define (delay-it exp env) + (list 'thunk exp env)) + +;; eval +(define (eval exp env) + ;; use this display statement to visualize the recursive evaluation process + ;;(display (format "~s~%" exp)) + (match exp + [(? self-evaluating? exp) exp] + [(? variable? exp) (lookup-variable-value exp env)] + [`(quote ,x) x] + [`(set! ,var ,val) (set-variable-value! var (eval val env) env)] + [`(define ,(? (lambda (x) (not (pair? x))) var) ,b) (define-variable! var (eval b env) env)] + [`(define ,(? pair? var) ,b ..1) (define-variable! (car var) (eval (make-lambda (cdr var) b) env) env)] + [`(if ,pred ,consequent ,alternative) (if (true? (actual-value pred env)) (eval consequent env) (eval alternative env))] + [`(unless ,condition ,consequent ,alternative) (if (true? (eval condition env)) (eval alternative env) (eval consequent env))] + [`(lambda ,parameters ,body ..1) (make-procedure parameters body env)] + [`(begin ,exp ...) (eval-sequence exp env)] + [`(cond ,clauses ...) (eval (cond->if clauses) env)] + [`(let ,(? (lambda (x) (or (pair? x) (empty? x))) bindings) ,body ..1) (eval (let->combination exp) env)] + [`(let ,(? symbol? name) ,bindings ,body ..1) (eval (named-let->combination exp) env)] + [`(let* ,bindings ,body ..1) (eval (let*->nested-lets exp) env)] + [`(letrec ,bindings ,body ..1) (eval (letrec->combination exp) env)] + [`(,f ,x ...) (apply (actual-value f env) + x + env)] + [_ (error "unable to evaluate expression -- EVAL " exp)])) + + +(define (interpret) + (let loop ([input (read)] + [env the-global-environment]) + (let ([output (actual-value input env)]) + (display output) + (loop (read) env)))) + +(define (t expr) + (let ([t1 (current-inexact-milliseconds)]) + (eval expr the-global-environment) + (displayln (- (current-inexact-milliseconds) t1)))) \ No newline at end of file