sicp-ex-4.33

  
  
 ;; '(a b c) is equal to (quote (a b c)). so we should change the code in text-of-quotation like this. 
  
  
 (define prev-eval eval) 
  
 (define (eval expr env) 
     (if (quoted? expr) 
         (text-of-quotation expr env) 
         (prev-eval expr env))) 
  
 (define (quoted? expr) (tagged-list? expr 'quote)) 
  
 (define (text-of-quotation expr env)  
         (let ((text (cadr expr))) 
                 (if (pair? text) 
                         (evaln (make-list text) env) 
                         text))) 
 (define (make-list expr) 
         (if (null? expr) 
                 (list 'quote '()) 
                 (list 'cons 
                           (list 'quote (car expr)) 
                           (make-list (cdr expr))))) 

  
  
 ;; this version relies on the implementation of cons/car/cdr. 
 (define (text-of-quotation expr) 
  
     (define (new-list pair) 
         (if (null? pair) 
             '() 
             (make-procedure 
                 '(m) 
                 (list (list 'm 'car-value 'cdr-value)) 
                 (extend-environment 
                     (list 'car-value 'cdr-value) 
                     (list (car pair) (new-list (cdr pair))) 
                     the-empty-environment)))) 
  
     (let ((text (cadr expr))) 
         (if (not (pair? text)) 
             text 
             (new-list text)))) 

Support nested list:

  
 (define (text-of-quotation-lazy exp) 
   (define (quotation->cons exp) 
     (if (null? exp) 
       ''() 
       (if (pair? exp) 
         (list 'cons (quotation->cons (car exp)) (quotation->cons (cdr exp))) 
         `',exp))) 
   (let ((env (cons (make-frame '() '()) '()))) 
     (eval '(define (cons x y) (lambda (m) (m x y))) env) 
     (eval '(define (car z) (z (lambda (p q) p))) env) 
     (eval '(define (cdr z) (z (lambda (p q) q))) env) 
     (let ((text (cadr exp))) 
       (if (pair? text) 
         (eval (quotation->cons text) env) 
         text)))) 
 ; if do so, all of the cons will be the lazy one even if they have been defined already 
 (define text-of-quotation text-of-quotation-lazy) 
  
 ;(car '(a b c)) 
 ; output: 'a 
 ; 
 ;(car (car '((a b) (c (d e))))) 
 ; output: a 
 ; 
 ;'() 
 ; output: () 
  

  
  
  
  
  
 ;;; Exercise 4.33 
  
  
 ;;; redefined text-of-quotation will transform the exp into its corresponding  
 ;;; expression of meta-circular evaluator, such as '(cons <quotation> (cons   
 ;;; <quotation> (cons ...))) or '<quotation>, and then evaluate that expression. 
 ;;; 
 (define (text-of-quotation exp) 
   (if (pair? (cadr exp)) 
       (eval (text->lazy-conses-exp (cadr exp)) the-global-environment) 
       (cadr exp))) 
  
 (define (text->lazy-conses-exp exp) 
   (cond [(pair? exp) 
          `(cons ,(text->lazy-conses-exp (car exp)) ,(text->lazy-conses-exp (cdr exp)))] 
         [else (list 'quote exp)])) 
  
  
 ;;; add desired procedure to the-global-environment 
 (eval '(define (cons x y) 
          (lambda (m) (m x y))) the-global-environment) 
  
 (eval '(define (car z) 
          (z (lambda (p q) p))) the-global-environment) 
  
 (eval '(define (cdr z) 
          (z (lambda (p q) q))) the-global-environment) 
  
  
 (eval '(define (list-ref items n) 
          (if (= n 0) 
              (car items) 
              (list-ref (cdr items) (- n 1)))) the-global-environment) 
  
 (eval '(define (map proc items) 
          (if (null? items) 
              '() 
              (cons (proc (car items)) 
                    (map proc (cdr items))))) the-global-environment) 
  
 (eval '(define (scale-list items factor) 
          (map (lambda (x) (* x factor)) 
               items)) the-global-environment) 
  
 (eval '(define (add-lists list1 list2) 
          (cond ((null? list1) list2) 
                ((null? list2) list1) 
                (else (cons (+ (car list1) (car list2)) 
                            (add-lists (cdr list1) (cdr list2)))))) the-global-environment) 
  

  
  
  
  
  
 (define (quoted? exp-) 
     (tagged-list? exp- 'quote)) 
  
  
 ; Define the symbolic variables of L-Eval in the internal evaluation process 
 ; It is used to distinguish it from MIT-Scheme forms such as <''a> 
 ; The <''a> storage form of evaluation in MIT-Scheme is (list 'quote 'a) 
 (define (make-symbol symbol-) 
     (cons 'quote symbol-)) 
  
 ; Constructing symbolic expression in MIT-Scheme 
 (define (make-scheme-quote exp-) 
     (list 'quote exp-)) 
  
  
  
  
  
  
 (define (is-list? exp-) 
     (tagged-list? exp- 'list-)) 
  
 (define (get-list-items exp-) 
     (cdr exp-)) 
  
 (define (make-cons exp-car exp-cdr) 
     (list 'cons- exp-car exp-cdr)) 
  
 (define (make-list items) 
     (if (null? items) 
         items 
         (make-cons 
             (car items) 
             (make-list (cdr items))))) 
  
  
  
  
  
 ; Final evaluation of symbols 
 ; L-Eval is implemented by using symbol data implementation in MIT-Scheme 
 (define (eval-quotation exp- env) 
     (let ((text (cdr exp-))) 
         (if (pair? text) 
             ; symbolic data defined in MIT-Scheme  
             (let ((data (car text)))  
                 (if (pair? data) 
                     ; if symbol list,converted to an lazy list evaluation 
                     (eval- (make-list (map make-scheme-quote data)) env)  
                     ; a single symbol is converted to an L-Eval internal evaluation expression  
                     (eval- (make-symbol data) env)))  
             ; a single symbol defined internally in l-eval is returned directly  
             text)))  
  
  
 (define (eval- exp- env) 
     (cond ((self-evaluating? exp-) exp-) 
         ((variable? exp-) (lookup-variable-value exp- env)) 
         ((quoted? exp-) (eval-quotation exp- env)) 
         ((is-list? exp-) (eval- (make-list (get-list-items exp-)) env)) 
         ((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- 
                 (actual-value (operator exp-) env) 
                 (operands exp-) 
                 env)) 
         (else (error "Unknown expression type -- EVAL" exp-)))) 
  
  
  
 ; => (car- (car- (cdr- (car- (cdr- (list- '(a b) '(c (list- d e)))))))) 
 ; => list-