SICP/ex-4_01-xx.scm

(load "util.scm")
(load "misc/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->lambda 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 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-init exp) (cadr exp))
(define (let-body exp) (cddr exp))
(define (let-init-var init) (car init))
(define (let-init-exp init) (cadr init))
(define (let-init-vars exp) (map let-init-var (let-init exp)))
(define (let-init-exps exp) (map let-init-exp (let-init exp)))

(define (let->lambda exp)
  (let ((let-variables (let-init-vars exp))
        (let-expressions (let-init-exps exp)))
    (cons (make-lambda let-variables (let-body exp))
          let-expressions)))

(assert (let->lambda '(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")


(display "\nex-4.9\n")