266 lines
8.3 KiB
Scheme
266 lines
8.3 KiB
Scheme
(load "shared/util.scm")
|
|
(load "shared/sicp-evaluator.scm")
|
|
|
|
(display "\nex-4.1 - list-of-values\n")
|
|
|
|
(define (list-of-values-left-to-right exps env)
|
|
(if (no-operands? exps)
|
|
'()
|
|
(let ((first (eval (first-operand exps) env)))
|
|
(let ((rest ((list-of-values (rest-operands exps) env))))
|
|
(cons first rest)))))
|
|
|
|
(define (list-of-values-right-to-left exps env)
|
|
(if (no-operands? exps)
|
|
'()
|
|
(let ((rest ((list-of-values (rest-operands exps) env))))
|
|
(let ((first (eval (first-operand exps) env)))
|
|
(cons first rest)))))
|
|
|
|
(display "[done]\n")
|
|
|
|
(display "\nex-4.2 - explicite-call\n")
|
|
|
|
; Louis's plan does not work because the implementation would treat assignments
|
|
; and definitions as applications. That means define and set! would no longer be
|
|
; special forms.
|
|
|
|
(define (application?-call exp) (tagged-list exp 'call))
|
|
(define (operator-call exp) (cadr exp))
|
|
(define (operands-call exp) (cddr exp))
|
|
|
|
(display "[done]\n")
|
|
|
|
(display "\nex-4.3 - data-directed-eval\n")
|
|
|
|
(define *eval-table* (make-hash-table))
|
|
(define (put op proc)
|
|
(hash-table/put! *eval-table* (list op) proc))
|
|
(define (get op)
|
|
(hash-table/get *eval-table* (list op) #f))
|
|
|
|
(define (install-eval-package)
|
|
(put 'quote (lambda (exp env) (text-of-quotation exp)))
|
|
(put 'set! eval-assignment)
|
|
(put 'define eval-definition)
|
|
(put 'if eval-if)
|
|
(put 'lambda
|
|
(lambda (exp env)
|
|
(make-procedure (lambda-parameters exp)
|
|
(lambda-body exp)
|
|
env)))
|
|
(put 'begin (lambda (exp env) (eval-sequence (begin-actions exp) env)))
|
|
(put 'cond (lambda (exp env) (eval (cond->if exp) env)))
|
|
(put 'let (lambda (exp env) (eval (let->combination exp) env)))
|
|
(put 'let* (lambda (exp env) (eval (let*->nested-lets exp) env)))
|
|
(put 'and (lambda (exp env) (eval-and (clauses exp) env)))
|
|
(put 'or (lambda (exp env) (eval-or (clauses exp) env)))
|
|
(display "[install-eval-package]\n")
|
|
'done)
|
|
|
|
(install-eval-package)
|
|
|
|
(define (eval exp env)
|
|
; (display "(EVAL ") (display exp) (display ")") (newline)
|
|
(cond
|
|
((self-evaluating? exp) exp)
|
|
((variable? exp) (lookup-variable-value exp env))
|
|
((and (not (null? exp)) (get (car exp)))
|
|
((get (car exp)) exp env))
|
|
((application? exp)
|
|
(apply (eval (operator exp) env)
|
|
(list-of-values (operands exp) env)))
|
|
(else (error "Unknown expression type -- EVAL" exp))))
|
|
|
|
(display "[done]\n")
|
|
|
|
(display "\nex-4.4 - and/or\n")
|
|
|
|
(define (clauses exp) (cdr exp))
|
|
(define (no-clauses? exp) (null? exp))
|
|
(define (first-clause exp) (car exp))
|
|
(define (rest-clauses exp) (cdr exp))
|
|
|
|
(define (eval-and exp env)
|
|
(if (no-clauses? exp)
|
|
#t
|
|
(if (true? (eval (first-clause exp) env))
|
|
(eval-and (rest-clauses exp) env)
|
|
#f)))
|
|
|
|
(define (eval-or exp env)
|
|
(if (no-clauses? exp)
|
|
#f
|
|
(if (true? (eval (first-clause exp) env))
|
|
#t
|
|
(eval-or (rest-clauses exp) env))))
|
|
|
|
(define (true? a) a)
|
|
|
|
(assert (eval '(or) '()) #f)
|
|
(assert (eval '(and) '()) #t)
|
|
(assert (eval '(and 0 0 0 #f) '()) #f)
|
|
(assert (eval '(or #f #f #t) '()) #t)
|
|
|
|
(display "\nex-4.5 - modified-cond\n")
|
|
|
|
(define (cond-test exp) (car exp))
|
|
(define (cond-recipient exp) (caddr exp))
|
|
(define (cond-test-recipient-clause? exp)
|
|
(eq? (cadr exp) '=>))
|
|
|
|
(define (expand-clauses clauses)
|
|
(if (null? clauses)
|
|
'false ; no else clause
|
|
(let ((first (car clauses))
|
|
(rest (cdr clauses)))
|
|
(cond
|
|
((cond-else-clause? first)
|
|
(if (null? rest)
|
|
(sequence->exp (cond-actions first))
|
|
(error "ELSE clause isn't last -- COND->IF"
|
|
clauses)))
|
|
((cond-test-recipient-clause? first)
|
|
(let ((test-evaluated (eval (cond-test exp) env)))
|
|
(if (true? test-evaluated)
|
|
(eval (list (cond-recipient exp) test-evaluated) env)
|
|
(expand-clauses rest))))
|
|
(else
|
|
(make-if (cond-predicate first)
|
|
(sequence->exp (cond-actions first))
|
|
(expand-clauses rest)))))))
|
|
|
|
(display "[done]\n")
|
|
|
|
(display "\nex-4.6 - let\n")
|
|
|
|
(define (let? exp) (tagged-list exp 'let))
|
|
(define (let-bindings exp) (cadr exp))
|
|
(define (let-body exp) (cddr exp))
|
|
(define (let-binding-var binding) (car binding))
|
|
(define (let-binding-exp binding) (cadr binding))
|
|
(define (let-vars exp) (map let-binding-var (let-bindings exp)))
|
|
(define (let-exps exp) (map let-binding-exp (let-bindings exp)))
|
|
|
|
(define (let->combination exp)
|
|
(let ((let-variables (let-vars exp))
|
|
(let-expressions (let-exps exp)))
|
|
(cons (make-lambda let-variables (let-body exp))
|
|
let-expressions)))
|
|
|
|
(assert (let->combination '(let ((a 3) (b 4)) (* 3 a b)))
|
|
'((lambda (a b) (* 3 a b)) 3 4))
|
|
|
|
(display "\nex-4.7 - let*\n")
|
|
|
|
(define (let*? exp) (tagged-list exp 'let*))
|
|
(define (let*-inits exp) (cadr exp))
|
|
(define (let*-body exp) (cddr exp))
|
|
(define (let*-inits-empty? inits) (null? inits))
|
|
(define (let*-first-init inits) (car inits))
|
|
(define (let*-rest-init inits) (cdr inits))
|
|
|
|
(define (let*->nested-lets exp)
|
|
(define (nest-lets inits)
|
|
(if (let*-inits-empty? inits)
|
|
(sequence->exp (let*-body exp))
|
|
(list
|
|
'let
|
|
(list (let*-first-init inits))
|
|
(nest-lets (let*-rest-init inits)))))
|
|
(nest-lets (let*-inits exp)))
|
|
|
|
(assert (let*->nested-lets '(let* ((x 1) (y 2)) (* x y) (+ x y)))
|
|
'(let ((x 1)) (let ((y 2)) (begin (* x y) (+ x y)))))
|
|
|
|
|
|
(display "\nex-4.8 - named-let\n")
|
|
|
|
(define (simple-let? exp) (pair? (let-bindings exp)))
|
|
(define (named-let? exp) (symbol? (let-bindings exp)))
|
|
(define (named-let-var exp) (cadr exp))
|
|
(define (named-let-bindings exp) (caddr exp))
|
|
|
|
(define (named-let-var exp) (cadr exp))
|
|
(define (named-let-bindings exp) (caddr exp))
|
|
(define (named-let-body exp) (cdddr exp))
|
|
(define (named-let-vars exp) (map let-binding-var (named-let-bindings exp)))
|
|
(define (named-let-exps exp) (map let-binding-exp (named-let-bindings exp)))
|
|
|
|
(define (let->combination exp)
|
|
(cond
|
|
((simple-let? exp)
|
|
(let ((let-variables (let-vars exp))
|
|
(let-expressions (let-exps exp)))
|
|
(cons (make-lambda let-variables (let-body exp))
|
|
let-expressions)))
|
|
((named-let? exp)
|
|
(let ((let-name (named-let-var exp))
|
|
(let-variables (named-let-vars exp))
|
|
(let-expressions (named-let-exps exp))
|
|
(let-body (named-let-body exp)))
|
|
(list
|
|
'let
|
|
(cons (list let-name (make-lambda let-variables let-body))
|
|
(named-let-bindings exp))
|
|
(sequence->exp let-body))))
|
|
(else (error "Unsupported let expression -- LET->COMBINATION"))))
|
|
|
|
(assert (let->combination '(let ((a 3) (b 4)) (* 3 a b)))
|
|
'((lambda (a b) (* 3 a b)) 3 4))
|
|
|
|
(assert (let->combination '(let fib-iter ((a 1)) (fib-iter (+ a 1)) 3))
|
|
'(let ((fib-iter (lambda (a) (fib-iter (+ a 1)) 3)) (a 1)) (begin (fib-iter (+ a 1)) 3)))
|
|
|
|
(display "\nex-4.9 - iteration-constructs\n")
|
|
|
|
(define (repeat? exp) (tagged-list exp 'repeat))
|
|
(define (repeat-count exp) (cadr exp))
|
|
(define (repeat-body exp) (cddr exp))
|
|
|
|
(define (repeat->combination exp)
|
|
(if (= (repeat-count exp) 0)
|
|
'()
|
|
(list
|
|
(sequence->exp (repeat-body exp))
|
|
(cons 'repeat
|
|
(cons (- (repeat-count exp) 1)
|
|
(repeat-body exp))))))
|
|
|
|
(display "repeat: ")
|
|
(assert (repeat->combination '(repeat 10 (display "foo") (newline)))
|
|
'((begin (display "foo") (newline)) (repeat 9 (display "foo") (newline))))
|
|
|
|
(define (while? exp) (tagged-list exp 'while))
|
|
(define (while-predicate exp) (cadr exp))
|
|
(define (while-body exp) (cddr exp))
|
|
|
|
(define (eval-while exp env)
|
|
(let ((body (while-body exp))
|
|
(predicate (while-predicate exp)))
|
|
(if (true? (eval predicate env))
|
|
'()
|
|
(begin
|
|
(sequence->exp body)
|
|
(eval-while exp env)))))
|
|
|
|
(display "while: [done]\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-true> if <predicate> else <if-false>)
|
|
|
|
; (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")
|
|
|