<< Previous exercise (4.33) | Index | Next exercise (4.35) >>


 ;; based on 4-33 
 (map (lambda (name obj) 
         (define-variable!  name (list 'primitive obj) the-global-environment)) 
     (list 'raw-cons 'raw-car 'raw-cdr) 
     (list cons car cdr)) 
         (define (cons x y) 
             (raw-cons 'cons (lambda (m) (m x y)))) 
         (define (car z) 
             ((raw-cdr z) (lambda (p q) p))) 
         (define (cdr z) 
             ((raw-cdr z) (lambda (p q) q))) 
 (define (disp-cons obj depth) 
     (letrec ((user-car (lambda (z) 
                 (force-it (lookup-variable-value 'x (procedure-environment (cdr z)))))) 
              (user-cdr (lambda (z) 
                 (force-it (lookup-variable-value 'y (procedure-environment (cdr z))))))) 
             ((>= depth 10) 
                 (display "... )")) 
             ((null? obj) 
                 (display "")) 
                 (let ((cdr-value (user-cdr obj))) 
                     (display "(") 
                     (display (user-car obj)) 
                     (if (tagged-list? cdr-value 'cons) 
                             (display " ") 
                             (disp-cons cdr-value (+ depth 1))) 
                             (display " . ") 
                             (display cdr-value))) 
                     (display ")")))))) 
 (define (user-print object) 
     (if (compound-procedure? object) 
             (list 'compound-procedure 
                 (procedure-parameters object) 
                 (procedure-body object) 
         (if (tagged-list? object 'cons) 
             (disp-cons object 0) 
             (display object)))) 


Arguably a bit more elegant solution:

 (define (setup-environment) 
     (let ((initial-env 
            (extend-environment (primitive-procedure-names) 
         (define-variable! 'true true initial-env) 
         (define-variable! 'false false initial-env) 
               (define (cons cons-first cons-rest) 
                   (lambda (m) (m cons-first cons-rest))) 
               (define (car z) 
                   (z (lambda (p q) p))) 
               (define (cdr z) 
                   (z (lambda (p q) q))) 
               (define (null? c) 
                   (equal? c '()))) 
 (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) 
             (let ((frame (first-frame env))) 
                 (scan (frame-variables frame) 
                       (frame-values frame))))) 
     (env-loop env)) 
 (define (lazy-cons? procedure) 
     (let ((env (procedure-environment procedure))) 
         (and (not (null? (lookup-variable-value* 'cons-first env))) 
              (not (null? (lookup-variable-value* 'cons-rest env)))))) 
 (define (lazy-cons-print object) 
     (define (lazy-cons-print-internal object n) 
         (if (not (null? object)) 
             (let* ((env (procedure-environment object)) 
                    (first (lookup-variable-value* 'cons-first env)) 
                    (rest (lookup-variable-value* 'cons-rest env))) 
                 (if (> n 10) 
                     (display "...") 
                         (let ((first-forced (force-it first))) 
                             (if (and (compound-procedure? first-forced) 
                                      (lazy-cons? first-forced)) 
                                 (lazy-cons-print first-forced) 
                                 (display first-forced))) 
                         (display " ") 
                          (force-it rest) 
                          (+ n 1))))))) 
     (display "(") 
     (lazy-cons-print-internal object 0) 
     (display ")")) 
 (define (user-print object) 
     (if (compound-procedure? object) 
         (if (lazy-cons? object) 
             (lazy-cons-print object) 
             (display (list 'compound-procedure 
                            (procedure-parameters object) 
                            (procedure-body object) 
         (display object))) 
 ;; To test: 
 ;; '(a b (c d)) 
 ;; (define ones (cons 1 ones)) 
 ;; ones 

Just to pose the question, wouldn't this implementation regard any procedure with an environment containing 'cons-first and 'cons-rest as a cons'ed value, as illustrated below?

 (define (make-fake-cons)  
   (define cons-first 1)  
   (define cons-rest 2)   
   (lambda (m) 'fooled-you)) 
 (define a-fake-cons (make-fake-cons)) 
 (lazy-cons? a-fake-cons) ; true, even though it really isn't 

Perhaps the interpreter can be meaningfully adapted to handle this situation.


Less nesting

 (define (serialize-lazy-pairs object depth) 
   (if (<= depth 9) ;; THRESHOLD HERE 
     (list 'lazy-pair 
           (serialize-object (actual-value 'x (procedure-environment object)) (+ depth 1)) 
           (serialize-object (actual-value 'y (procedure-environment object)) (+ depth 1))) 
     (list 'lazy-pair "..."))) 
 (define (serialize-compound-procedure object) 
   (if (compound-procedure? object) 
     (list 'compound-procedure 
           (procedure-parameters object) 
           (procedure-body object) 
 (define (lazy-pair? object) 
 (define (serialize-object object depth) 
   (if (compound-procedure? object) 
     (if (lazy-pair? object) 
       (serialize-lazy-pairs object (+ 1 depth)) 
       (serialize-compound-procedure object)) 
 (define (user-print object) 
   (display (serialize-object object 0)))