From 47ff76ded505c9e50b6e9deab29816e0be366507 Mon Sep 17 00:00:00 2001 From: flaming0 Date: Tue, 28 Aug 2012 21:35:11 +0400 Subject: [PATCH] ch4 --- ch4/ex4-5.scm | 58 ++++++++++------------------------------ ch4/ex4-6.scm | 33 +++++++++++++++++++++++ ch4/ex4-7.scm | 52 +++++++++++++++++++++++++++++++++++ ch4/ex4-8.scm | 5 ++++ ch4/ex4-9.scm | 27 +++++++++++++++++++ ch4/test_interpreter.scm | 20 +++++++++++++- 6 files changed, 150 insertions(+), 45 deletions(-) create mode 100644 ch4/ex4-6.scm create mode 100644 ch4/ex4-7.scm create mode 100644 ch4/ex4-8.scm create mode 100644 ch4/ex4-9.scm diff --git a/ch4/ex4-5.scm b/ch4/ex4-5.scm index c387b95..58d798f 100644 --- a/ch4/ex4-5.scm +++ b/ch4/ex4-5.scm @@ -2,54 +2,24 @@ ;; Example 4.5 -;; TODO +;; Need testing. -(define (eval exp env) - (cond ((self-evaluating? exp) exp) - ((variable? exp) (lookup-variable-value exp env)) - ((quoted? exp) (text-of-quotation exp)) - ((assignment? exp) (eval-assignment exp env)) - ((definition? exp) (eval-definition exp env)) - ((if? exp) (eval-if exp env)) - ((lambda? exp) - (make-procedure (lambda-parameters exp) - (lambda-body exp) - env)) - ((begin? exp) - (eval-sequence (begin-actions exp) env)) - ((cond? exp) (eval (cond->if exp) env)) - ((application? exp) - (apply (eval (operator exp) env) ;; apply procedure (proc, args) - (list-of-values (operands exp) env))) - (else - (error "Unknown expression type -- EVAL" exp)))) - -(define (cond? exp) (tagged-list? exp 'cond)) -(define (cond-clauses exp) (cdr exp)) -(define (cond-else-clause? clause) - (eq? (cond-predicate clause) 'else)) -(define (cond-predicate clause) (car clause)) -(define (cond-actions clause) (cdr clause)) -(define (cond->if exp) - (expand-clauses (cond-clauses exp))) +(define (cond=>clause? exp) + (eq? (cadr exp) '=>)) (define (expand-clauses clauses) (if (null? clauses) 'false (let ((first (car clauses)) (rest (cdr clauses))) - (if (cond-else-clause? first) - (if (null? rest) - (sequence->exp (cond-actions first)) - (error "Clause else not the last" clauses)) - (make-if (cond-predicate first) - (sequence->exp (cond-actions first)) - (expand-clauses rest)))))) - -(define (last-exp? seq) (null? (cdr seq))) -(define (first-exp seq) (car seq)) -(define (make-begin seq) (cons 'begin seq)) -(define (sequence->exp seq) - (cond ((null? seq) seq) - ((last-exp? seq) (first-exp seq)) - (else (make-begin seq)))) \ No newline at end of file + (cond ((cond=>clause? first) + (make-if (car first) ;; (if (test?) (list recipient test) ..) + (list (caddr first) (car first)) + (expand-clauses rest))) + ((cond-else-clause? first) + (if (null? rest) + (sequence->exp (cond-actions first)) + (error "Clause else not the last" clauses))) + (else (make-if (cond-predicate first) + (sequence->exp (cond-actions first)) + (expand-clauses rest))))))) \ No newline at end of file diff --git a/ch4/ex4-6.scm b/ch4/ex4-6.scm new file mode 100644 index 0000000..1fc7652 --- /dev/null +++ b/ch4/ex4-6.scm @@ -0,0 +1,33 @@ +#lang racket + +;; Example 4.6 + +;; Need testing. + +(define (eval exp env) + (cond (...) + ((let? exp) (eval (let->combination (cdr exp)) env)) + (...))) + +;; let stuff + +(define (let? exp) + (tagged-list? exp 'let)) + +(define (let-body exp) (cdr exp)) +(define (let-vars-and-exps exp) (car exp)) + +;; should use foldr with cons '() and filter. But.... let's use simple scheme to make simple scheme interpreter +(define (let-vars exp) + (if (null? exp) + '() + (cons (caar exp) (let-vars (cdr exp))))) + +(define (let-exps exp) + (if (null? exp) + '() + (cons (cadar exp) (let-vars (cdr exp))))) + +(define (let->combination exp) + (cons (make-lambda (let-vars (let-vars-and-exps exp)) (let-body exp)) + (let-exps (let-vars-and-exps exp)))) \ No newline at end of file diff --git a/ch4/ex4-7.scm b/ch4/ex4-7.scm new file mode 100644 index 0000000..2eb99aa --- /dev/null +++ b/ch4/ex4-7.scm @@ -0,0 +1,52 @@ +#lang racket + +;; Example 4.7 + +;; Need testing. + +(define (eval exp env) + (cond (...) + ((let*? exp) (eval (let*->nested-lets (cdr exp)) env)) + (...))) + +;; let* stuff + +(define (let*? exp) + (tagged-list? exp 'let*)) + +(define (let*-body exp) (cdr exp)) +(define (let*-vars-and-exps exp) (car exp)) + +(define (let*->nested-lets exp) + (define (helper var-exps body) + (if (null? (cdr var-exps)) + (cons 'let (cons var-exps body)) ;; final let + (list 'let (list (car var-exps)) + (helper (cdr var-exps) body)))) + (helper (let*-vars-and-exps exp) (let*-body exp))) + + +;; random test stuff + +(define initial '(let ((a 2) + (b 3) + (c (foo 42))) + (body 2))) + +initial + +(define vars-exps (cadr initial)) +(define body (cddr initial)) + +vars-exps +body + +(define last-var-exp (cddr vars-exps)) +(cons 'let (cons last-var-exp body)) + +(display "***") + +(car vars-exps) + +(list 'let (list (car vars-exps)) + (cons 'let (cons last-var-exp body))) \ No newline at end of file diff --git a/ch4/ex4-8.scm b/ch4/ex4-8.scm new file mode 100644 index 0000000..470065c --- /dev/null +++ b/ch4/ex4-8.scm @@ -0,0 +1,5 @@ +#lang racket + +;; Example 4.8 + +;; Need testing. diff --git a/ch4/ex4-9.scm b/ch4/ex4-9.scm new file mode 100644 index 0000000..4192d26 --- /dev/null +++ b/ch4/ex4-9.scm @@ -0,0 +1,27 @@ +#lang racket + +;; Example 4.9 + +;; Need testing. + +;; (while (exp) +;; (body))) + +(define (eval exp env) + (cond (...) + ((while? exp) (eval-while exp env)) + (...))) + +(define (while? exp) (tagged-list? exp 'while)) +(define (while-cond exp) (cadr exp)) +(define (while-body exp) (caddr exp)) + +(define (while->combination exp) + (sequence->exp + (list (list 'define + (list 'loop) ;; (define (loop) (if () (begin (body) (loop)) 'done)) + (make-if (while-cond exp) + (sequence->exp (list (while-body) + (list 'loop))) + 'done)) + (list 'loop)))) diff --git a/ch4/test_interpreter.scm b/ch4/test_interpreter.scm index b6feec8..18cdb42 100644 --- a/ch4/test_interpreter.scm +++ b/ch4/test_interpreter.scm @@ -170,4 +170,22 @@ (error "Clause else not the last" clauses)) (make-if (cond-predicate first) (sequence->exp (cond-actions first)) - (expand-clauses rest)))))) \ No newline at end of file + (expand-clauses rest)))))) + +;; data structures + +(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-body p) (cadddr p)) \ No newline at end of file