From 4e1a51f5a0212404d23e82dfb6daae32f55eae51 Mon Sep 17 00:00:00 2001 From: Felix Martin Date: Wed, 20 Jan 2021 11:55:13 -0500 Subject: [PATCH] Implement till 4.11 --- ex-4_01-xx.scm | 127 +++++++++++++++++++++++++++++++++++++++++---- misc/evaluator.scm | 73 ++++++++++++++++++++++++++ 2 files changed, 191 insertions(+), 9 deletions(-) diff --git a/ex-4_01-xx.scm b/ex-4_01-xx.scm index c623605..e8e9179 100644 --- a/ex-4_01-xx.scm +++ b/ex-4_01-xx.scm @@ -235,19 +235,128 @@ (define (while-predicate exp) (cadr exp)) (define (while-body exp) (cddr exp)) -(define (while->combination exp) +(define (eval-while exp env) (let ((body (while-body exp)) (predicate (while-predicate exp))) - (if (not (true? predicate)) + (if (true? (eval predicate env)) '() - (list + (begin (sequence->exp body) - (cons 'while - (cons predicate - body)))))) + (eval-while exp env))))) -(display "while: ") -(display (while->combination '(while (lambda () #t) (display "one")))) +(display "while: [done]\n") -(display "\nex-4.10\n") +(display "\nex-4.10 - alternative-syntax\n") + +; I am not going to reimplement everything, but we can easily see, that all we +; need to change is the operator and operands procedures, and the selectors for +; the specific procedure. I use an alternative if-syntax as an example. + +; new syntax : ( if else ) + +; (define (operator exp) (cadr exp)) +; (define (operands exp) (cons (car exp) (cddddr exp))) +; (define (if? exp) (eq (cadr exp) 'if)) +; (define (if-predicate exp) (caddr exp)) +; (define (if-consequent exp) (car exp)) +; (define (if-alternative exp) (caddddr exp)) + +(display "[done]\n") + +(display "\nex-4.11 - alternative-frame-implementation\n") + +; Test implementation from book. +(define env-0 the-empty-environment) +(define env-1 (extend-environment '(a b) '(1 2) env-0)) +(define env-2 (extend-environment '(c d) '(3 4) env-1)) + +(assert (lookup-variable-value 'b env-2) 2) +(set-variable-value! 'b 42 env-2) +(assert (lookup-variable-value 'b env-2) 42) + +(define (make-frame variables values) + (map cons variables values)) +(define (frame-variables frame) (map car frame)) +(define (frame-values frame) (map cdr frame)) +(define (add-binding-to-frame! var val frame) + (set-car! frame (cons (cons var val) frame))) + +(define frame-var car) +(define frame-val cdr) + +(define (lookup-variable-value var env) + (define (env-loop env) + (define (scan vars vals) + (cond ((null? vars) + (env-loop (enclosing-environment env))) + ((eq? var (car vars)) + (car vals)) + (else (scan (cdr vars) (cdr vals))))) + (if (eq? env the-empty-environment) + (error "Unbound variable" var) + (let ((frame (first-frame env))) + (scan (frame-variables frame) + (frame-values frame))))) + (env-loop env)) + +(define (set-variable-value! var val env) + (define (env-loop env) + (define (scan frame) + (cond ((null? frame) + (env-loop (enclosing-environment env))) + ((eq? var (frame-var (car frame))) + (set-cdr! (car frame) val)) + (else (scan (cdr frame))))) + (if (eq? env the-empty-environment) + (error "Unbound variable -- SET!" var) + (let ((frame (first-frame env))) + (scan frame)))) + (env-loop env)) + +(define (define-variable! var val env) + (let ((frame (first-frame env))) + (define (scan vars vals) + (cond ((null? vars) + (add-binding-to-frame! var val frame)) + ((eq? var (car vars)) + (set-car! vals val)) + (else (scan (cdr vars) (cdr vals))))) + (scan (frame-variables frame) + (frame-values frame)))) + +(define env-0 the-empty-environment) +(define env-1 (extend-environment '(a b) '(1 2) env-0)) +(define env-2 (extend-environment '(c d) '(3 4) env-1)) + +(assert (lookup-variable-value 'b env-2) 2) +(set-variable-value! 'b 42 env-2) +(assert (lookup-variable-value 'b env-2) 42) + +(display "\nex-4.12 - abstract-traversal\n") + +(define (find-pair-frame frame var) + ; (display "FIND-PAIR-FRAME ") (display frame) (newline) + (define (frame-loop frame) + (cond + ((null? frame) 'pair-not-found) + ((eq? var (frame-var (car frame))) (car frame)) + (else (frame-loop (cdr frame))))) + (frame-loop frame)) + +(define (find-pair-env env var) + (define (env-loop env) + (if (eq? env the-empty-environment) + 'pair-not-found + (let ((pair (find-pair-frame (first-frame env) var))) + (if (eq? pair 'pair-not-found) + (env-loop (enclosing-environment env)) + pair)))) + (env-loop env)) + +(display (find-pair-env env-2 'd)) +(newline) + +(display "\nex-4.13\n") + +; (display "\nex-4.14\n") diff --git a/misc/evaluator.scm b/misc/evaluator.scm index 9504f03..3ed177c 100644 --- a/misc/evaluator.scm +++ b/misc/evaluator.scm @@ -159,4 +159,77 @@ (sequence->exp (cond-actions first)) (expand-clauses rest)))))) +(define (true? x) + (not (eq? x false))) +(define (false? x) + (eq? x false)) + +(define (make-procedure parameters body env) + (list 'procedure parameters body env)) +(define (compound-procedure? p) + (tagged-list? p 'procedure)) +(define (procedure-parameters p) (cadr p)) +(define (procedure-body p) (caddr p)) +(define (procedure-environment p) (cadddr p)) + +(define (enclosing-environment env) (cdr env)) +(define (first-frame env) (car env)) +(define the-empty-environment '()) + +(define (make-frame variables values) + (cons variables values)) +(define (frame-variables frame) (car frame)) +(define (frame-values frame) (cdr frame)) +(define (add-binding-to-frame! var val frame) + (set-car! frame (cons var (car frame))) + (set-cdr! frame (cons val (cdr frame)))) + +(define (extend-environment vars vals base-env) + (if (= (length vars) (length vals)) + (cons (make-frame vars vals) base-env) + (if (< (length vars) (length vals)) + (error "Too many arguments supplied" vars vals) + (error "Too few arguments supplied" vars vals)))) + +(define (lookup-variable-value var env) + (define (env-loop env) + (define (scan vars vals) + (cond ((null? vars) + (env-loop (enclosing-environment env))) + ((eq? var (car vars)) + (car vals)) + (else (scan (cdr vars) (cdr vals))))) + (if (eq? env the-empty-environment) + (error "Unbound variable" var) + (let ((frame (first-frame env))) + (scan (frame-variables frame) + (frame-values frame))))) + (env-loop env)) + +(define (set-variable-value! var val env) + (define (env-loop env) + (define (scan vars vals) + (cond ((null? vars) + (env-loop (enclosing-environment env))) + ((eq? var (car vars)) + (set-car! vals val)) + (else (scan (cdr vars) (cdr vals))))) + (if (eq? env the-empty-environment) + (error "Unbound variable -- SET!" var) + (let ((frame (first-frame env))) + (scan (frame-variables frame) + (frame-values frame))))) + (env-loop env)) + +(define (define-variable! var val env) + (let ((frame (first-frame env))) + (define (scan vars vals) + (cond ((null? vars) + (add-binding-to-frame! var val frame)) + ((eq? var (car vars)) + (set-car! vals val)) + (else (scan (cdr vars) (cdr vals))))) + (scan (frame-variables frame) + (frame-values frame)))) + 'evaluator-loaded