sicp-ex-4.34



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


Felix021

  
  
  
 ;; 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)) 
  
 (actual-value 
     '(begin 
  
         (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))) 
     ) 
     the-global-environment) 
  
 (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))))))) 
         (cond 
             ((>= depth 10) 
                 (display "... )")) 
             ((null? obj) 
                 (display "")) 
             (else 
                 (let ((cdr-value (user-cdr obj))) 
                     (display "(") 
                     (display (user-car obj)) 
                     (if (tagged-list? cdr-value 'cons) 
                         (begin 
                             (display " ") 
                             (disp-cons cdr-value (+ depth 1))) 
                         (begin 
                             (display " . ") 
                             (display cdr-value))) 
                     (display ")")))))) 
  
 (define (user-print object) 
     (if (compound-procedure? object) 
         (display 
             (list 'compound-procedure 
                 (procedure-parameters object) 
                 (procedure-body object) 
                 '<procedure-env>)) 
         (if (tagged-list? object 'cons) 
             (disp-cons object 0) 
             (display object)))) 
  
 (driver-loop) 

awkravchuk

Arguably a bit more elegant solution:

  
 (define (setup-environment) 
     (let ((initial-env 
            (extend-environment (primitive-procedure-names) 
                                (primitive-procedure-objects) 
                                the-empty-environment))) 
         (define-variable! 'true true initial-env) 
         (define-variable! 'false false initial-env) 
         (eval 
          '(begin 
               (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 '()))) 
          initial-env) 
         initial-env)) 
  
  
 (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 "...") 
                     (begin 
                         (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 " ") 
                         (lazy-cons-print-internal 
                          (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) 
                            '<procedure-env>))) 
         (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.



davl

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) 
           '<procedure-env>) 
     object)) 
  
 (define (lazy-pair? object) 
   '*varies*) 
  
 (define (serialize-object object depth) 
   (if (compound-procedure? object) 
     (if (lazy-pair? object) 
       (serialize-lazy-pairs object (+ 1 depth)) 
       (serialize-compound-procedure object)) 
     object)) 
  
 (define (user-print object) 
   (newline) 
   (display (serialize-object object 0))) 
  

revc

Print cyclic or infinite list in some reasonable way —— with tag replacements.

  
 ;; Exercise 4.34 
  
 (define primitive-procedures 
   (list (list 'car-in-underly-scheme car)   ; preserved but renamed 
         (list 'cdr-in-underly-scheme cdr)   ; preserved but renamed 
         (list 'cons-in-underly-scheme cons) ; preserved but renamed 
         (list 'null? null?) 
         (list 'list list) 
         (list '+ +) 
         (list '- -) 
         (list '* *) 
         (list '/ /) 
         (list '= =) 
         (list 'newline newline) 
         (list 'display display) 
 ;;      more primitives 
         )) 
  
 (define the-global-environment (setup-environment)) 
  
 ;;; represent pair of META-CIRCULAR as pair of SCHEME which is composed of a tag 'cons 
 ;;; and a lexical closure(i.e. a procedure of META-CIRCULAR). 
 (eval '(define (cons x y) 
          (cons-in-underly-scheme 'pair? (lambda (m) (m x y)))) the-global-environment) 
  
 (eval '(define (car z) 
          ((cdr-in-underly-scheme z) (lambda (p q) p))) the-global-environment) 
  
 (eval '(define (cdr z) 
          ((cdr-in-underly-scheme z) (lambda (p q) q))) the-global-environment) 
  
 ;;; predicate that check if an object is a pair of META-CIRCULAR 
 (define (meta-pair? object) 
   (tagged-list? object 'pair?)) 
  
 ;;; print pair of META-CIRCULAR 
 (define (print-pair object) 
  
   (define counter 0)                    ; the number of pairs which were revisited 
  
   ;; use a pair as key and the correspoding number of revisited times as value 
   ;; when the recursion to CAR and CDR of some pair ends, check if VALUE > 0, 
   ;; change VALUE to counter, and then increment counter by 1 
   ;; NOTE: We do not add things which are not pair into hashtable 
   (define visited (make-hash-table)) 
  
   (define (put k v) (put-hash-table! visited k v))   ; an interface to visited for convenience 
   (define (get k) (get-hash-table visited k #f))     ; an interface to visited for convenience 
   (define (remove k) (remove-hash-table! visited k)) ; an interface to visited for convenience 
  
   ;; convert pair of META-CIRCULAR into pair of SCHEME for which we can handle more conveniently. 
   ;; The struct of converted pair is as follows: 
  
   ;;========================================================================== 
  
   ;; Printable-pair ::= ('be-referred-as Pair-of-META-CIRCULAR X Y)) 
   ;;                ||  ('refer-to Pair-of-META-CIRCULAR '*CAR* '*CDR*) 
   ;;                ||  ('just-pair Pair-of-META-CIRCULAR X Y) 
   ;;                ||  Not-pair 
  
   ;; X ::= #<Thunk CAR> 
   ;;   ||  Printable-pair 
  
   ;; Y ::= #<Thunk CDR> 
   ;;   ||  Printable-pair 
  
   ;;========================================================================== 
  
   (define (convert-printable-pair object) 
  
     ;; if object is evaluated-thunk, then return its value, otherwise return a tag like #<Thunk {alternative}> 
     (define (thunk-or-value object alternative) 
       (if (evaluated-thunk? object) 
           (convert-printable-pair (thunk-value object)) 
           (string-append "#<thunk " alternative ">"))) 
  
     ;; we visit some pair in visited table again, so change the its value to the desired string 
     (define (visit-again! object) 
       (put object (+ 1 (get object))) 
       (list 'refer-to object '*CAR* '*CDR*)) 
  
     (if (meta-pair? object) 
         (cond [(get object) (visit-again! object)]      ; visit again! return a string like "#{counter}" 
               [else 
                (put object 0)                           ; the first visit! 
                (let ([x (thunk-or-value (eval 'x (procedure-environment (cdr object))) "CAR")] 
                      [y (thunk-or-value (eval 'y (procedure-environment (cdr object))) "CDR")]) 
                  (if (zero? (get object))                       ; no inner elements refer to it 
                      (begin 
                        (remove object)                          ; no tagging required 
                        (list 'just-pair object x y)) 
  
                      (begin 
                        (put object counter) 
                        (set! counter (+ counter 1))             ; increment counter 
                        (list 'be-referred-as object x y))))])   ; return the processed pair 
         object))                                                ; not pair, return directly 
  
   (define (be-referred? object) 
     (tagged-list? object 'be-referred-as)) 
  
   (define (referer? object) 
     (tagged-list? object 'refer-to)) 
  
   ;; print printable pair 
   ;; We need consider three cases: 
   ;; 1. a pair refers to its outer list, which will be printed as #{counter} where counter is the corresponding 
   ;; serial number of its outer list. 
   ;; 2. a pair is referenced by its inner elements, which will be printed as #{counter}=(X . Y) where counter is 
   ;; its serial number 
   ;; 3. a normal pair which does not refer to another pair and is not referenced by others, that will be printed 
   ;; as (X . Y) 
   ;; NOTE: if Y is a pair, then print-pair won't print the preceding ". "  and the parentheses enclosing it. 
  
   (define (print-pair pair with-paren) 
     (let* ([left (if with-paren "(" "")] 
            [right (if with-paren ")" "")] 
            [val (get (cadr pair))] 
            [x (list-ref pair 2)] 
            [y (list-ref pair 3)] 
            [tag (if val (string-append "#" (number->string val)) val)] 
            [middle (if (null? y) "" " ")]) 
  
       (cond [(be-referred? pair) (display tag) (display "=") (display left)] 
             [(referer? pair) (display tag) (display "#")] 
             [else (display left)]) 
  
       (cond [(not (referer? pair)) 
               (cond [(pair? x) (print-pair x #t)] 
                     [else (display x)]) 
  
               (display middle) 
  
               (cond [(be-referred? y) (print-pair y #t)] 
                     [(referer? y) (display ". ") (print-pair y #f)] 
                     [(pair? y) (print-pair y #f)] 
                     [(null? y) (display "")] 
                     [else y (display ". ") (display y)]) 
  
               (display right)] 
           ))) 
  
   (print-pair (convert-printable-pair object) #t)) 
  
 (define (user-print object) 
   (cond [(meta-pair? object) (print-pair object)] ; the clause for pair of META-CIRCULAR 
         [(compound-procedure? object) 
          (display (list 'compound-procedure 
                         (procedure-parameters object) 
                         (procedure-body object) 
                         '<procedure-env>))] 
         [else (display object)])) 
  
 ;;; Exercise 4.34 additional procedures 
 (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) 
  
 (eval '(define ones (cons 1 ones)) the-global-environment) 
  
 (eval '(define integers (cons 1 (add-lists ones integers))) the-global-environment) 
  
 (eval '(define (for-each proc items) 
          (if (null? items) 
              'done 
              (begin (proc (car items)) 
                     (for-each proc (cdr items))))) the-global-environment) 
  
  
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
 ;;;;;;;;;;; test ;;;;;;;;;;;;;;; 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
  
 ;;;;;;;;;;;;;; 
 ;;; ones ;;;;; 
 ;;;;;;;;;;;;;; 
  
 ;;; L-Eval input: 
 ones 
  
 ;;; L-Eval value: 
 (#<thunk CAR> . #<thunk CDR>) 
  
 ;;; L-Eval input: 
 (car ones) 
  
 ;;; L-Eval value: 
 1 
  
 ;;; L-Eval input: 
 ones 
  
 ;;; L-Eval value: 
 (1 . #<thunk CDR>) 
  
 ;;; L-Eval input: 
 (cdr ones) 
  
 ;;; L-Eval value: 
 #0=(1 . #0#) 
  
  
 ;;;;;;;;;;;;;;;;;; 
 ;;; integers ;;;;; 
 ;;;;;;;;;;;;;;;;;; 
  
 ;;; L-Eval input: 
 (list-ref integers 3) 
  
 ;;; L-Eval value: 
 4 
  
 ;;; L-Eval input: 
 integers 
  
 ;;; L-Eval value: 
 (1 2 3 4 . #<thunk CDR>) 
  
 ;;; L-Eval input: 
 (list-ref integers 20) 
  
 ;;; L-Eval value: 
 21 
  
 ;;; L-Eval input: 
 integers 
  
 ;;; L-Eval value: 
 (1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 . #<thunk CDR>) 
  
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
 ;;;;  not cyclic but referenced ;;;;;; 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
 ;;; L-Eval input: 
 (define s (cons 1 2)) 
  
 ;;; L-Eval value: 
 ok 
  
 ;;; L-Eval input: 
 (define w (cons s s)) 
  
 ;;; L-Eval value: 
 ok 
  
 ;;; L-Eval input: 
 (car s) 
  
 ;;; L-Eval value: 
 1 
  
 ;;; L-Eval input: 
 (cdr s) 
  
 ;;; L-Eval value: 
 2 
  
 ;;; L-Eval input: 
 (car w) 
  
 ;;; L-Eval value: 
 (1 . 2) 
  
 ;;; L-Eval input: 
 (cdr w) 
  
 ;;; L-Eval value: 
 (1 . 2) 
  
 ;;; L-Eval input: 
 w 
  
 ;;; L-Eval value: 
 ((1 . 2) 1 . 2) 
  
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
 ;;;; list: special pair ;;;; 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
  
 ;;; L-Eval input: 
 (define lst '(1 2 3 4)) 
  
 ;;; L-Eval value: 
 ok 
  
 ;;; L-Eval input: 
 (for-each (lambda (x) (display x)) lst) 
 1234 
 ;;; L-Eval value: 
 done 
  
 ;;; L-Eval input: 
 lst 
  
 ;;; L-Eval value: 
 (1 2 3 4) 
  
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
 ;;; Multiplex cycle ;;;;;;;;;;;;; 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
  
                                                    
                             e3                     
                      +-------|-------+             
                      |       |       |             
 +------------------> |   +   |   +---------------+ 
 |                    |   |   |       |           | 
 |                    +---|---|-------+           | 
 |                        |                       | 
 |                        v                       v 
 |              +-------|-------+                 3 
 |           e2 |       |       |                   
 |          +-> |   +   |   +-------------+         
 |          |   |   |   |       |         |         
 |          |   +---|---|-------+         |         
 |          |       |                     |         
 |          |  e1   v                     |         
 |      +---|---|-------+                 |         
 |      |   |   |       |                 v         
 |      |   +   |   +   |                 2         
 |      |       |   |   |                           
 |      +-------|---|---+                           
 |                  |                               
 |                  |                               
 |                  |                               
 |                  |                               
 +------------------+                               
  
 ;;; L-Eval input: 
 (define c1 (cons 1 1)) 
  
 ;;; L-Eval value: 
 ok 
  
 ;;; L-Eval input: 
 (define c2 (cons c1 2)) 
  
 ;;; L-Eval value: 
 ok 
  
 ;;; L-Eval input: 
 (define c3 (cons c2 3)) 
  
 ;;; L-Eval value: 
 ok 
  
 ;;; L-Eval input: 
 (define c1 (cons c2 c3)) 
  
 ;;;;;; 
 Skip the access section 
 ;;;;;; 
  
 ;;; L-Eval input: 
 c1 
  
 ;;; L-Eval value: 
 #0=((#0# . 2) (#0# . 2) . 3) 
  
 ;;; L-Eval input: 
 c3 
  
 ;;; L-Eval value: 
 #1=(#0=((#0# . #1#) . 2) . 3) 

Sphinxsky

a simpler implementation it is modified on the basis of 4.33

  
  
  
  
  
  
 ; add primitive procedure identity 
 (define primitive-procedures 
     (list 
         (list 'null?- null?) 
         (list 'display- display) 
         (list 'newline- newline) 
         (list '= =) 
         (list '/ /) 
         (list '- -) 
         (list '* *) 
         (list '+ +) 
         (list 'identity (lambda (x) x)))) 
  
  
  
 ; define list expression 
 ; ======================================================================= 
 (define (is-list? exp-) 
     (tagged-list? exp- 'list-)) 
  
 (define (is-empty-list? exp-) 
     (null? exp-)) 
  
 (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))))) 
 ; ======================================================================= 
  
 ; add list operation 
 ; ======================================================================= 
 (define list-operation-exp-1 
     '(define- (cons- x y) 
         (define- x-Evaluated? false-) 
         (define- y-Evaluated? false-)         
         (define- x-Evaluated '()) 
         (define- y-Evaluated '()) 
         (lambda- (__cons-signal__) 
             (cond- ((= __cons-signal__ 0) 
                     (if- x-Evaluated? 
                         x-Evaluated 
                         (begin- 
                             (set!- x-Evaluated (identity x)) 
                             (set!- x-Evaluated? true-) 
                             x-Evaluated))) 
                 ((= __cons-signal__ 1) 
                     (if- y-Evaluated? 
                         y-Evaluated 
                         (begin- 
                             (set!- y-Evaluated (identity y)) 
                             (set!- y-Evaluated? true-) 
                             y-Evaluated))) 
                 ((= __cons-signal__ 2) 
                     (if- x-Evaluated? 
                         x-Evaluated 
                         'promise-head)) 
                 ((= __cons-signal__ 3) 
                     (if- y-Evaluated? 
                         y-Evaluated 
                         'promise-tail)))))) 
  
 (define list-operation-exp-2 
     '(define- (car- z) (z 0))) 
  
 (define list-operation-exp-3 
     '(define- (cdr- z) (z 1))) 
  
 (define list-operation-exp-4 
     '(define- (list-ref- items n) 
         (if- (= n 0) 
             (car- items) 
             (list-ref- (cdr- items) (- n 1))))) 
              
 (define list-operation-exp-5 
     '(define- (map- proc items) 
         (if- (null?- items) 
             items 
             (cons- 
                 (proc (car- items)) 
                 (map- proc (cdr- items)))))) 
  
 (define list-operation-exp-6 
     '(define- (scale-list items factor) 
         (map- 
             (lambda- (x) (* x factor)) 
             items))) 
  
 (define list-operation-exp-7 
     '(define- (add-lists list1 list2) 
         (cond- ((null?- list1) list2) 
             ((null?- list2) list1) 
             (else- 
                 (cons- 
                     (+ (car- list1) (car- list2)) 
                     (add-lists (cdr- list1) (cdr- list2))))))) 
  
 (define list-operation-exp-8 
     '(define- (matrix-ref matrix x y) 
         (list-ref- (list-ref- matrix x) y))) 
  
 (define list-operation-exp-9 
     '(define- (append- x y) 
         (if- (null?- x) 
             y 
             (cons- (car- x) 
                    (append- (cdr- x) y))))) 
  
 ; import interpreter 
 (for-each 
     (lambda (exp-) 
         (actual-value exp- the-global-environment)) 
     (list 
         list-operation-exp-1 
         list-operation-exp-2 
         list-operation-exp-3 
         list-operation-exp-4 
         list-operation-exp-5 
         list-operation-exp-6 
         list-operation-exp-7 
         list-operation-exp-8 
         list-operation-exp-9)) 
 ; ======================================================================= 
  
  
  
 ; predicate to add an empty list 
 (define (eval- exp- env) 
     (cond ((self-evaluating? exp-) exp-) 
         ((variable? exp-) (lookup-variable-value exp- env)) 
         ((quoted? exp-) (eval-quotation exp- env)) 
         ((is-empty-list? exp-) '()) 
         ((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-)))) 
  
  
  
 ; printing result processing 
 ; ======================================================================= 
 (define (make-compound-procedure-show cp) 
     (list 
         'compound-procedure 
         (procedure-parameters cp) 
         (procedure-body cp) 
         '<procedure-env>)) 
  
 (define (is-cons? object) 
     (if (compound-procedure? object) 
         (let ((parameters (procedure-parameters object))) 
             (equal? parameters (list '__cons-signal__))) 
         false)) 
  
 (define (make-cons-show c) c) 
  
 (define (make-show object) 
     (cond ((is-cons? object) 
             (make-cons-show object)) 
         ((compound-procedure? object) 
             (make-compound-procedure-show object)) 
         (else object))) 
  
 (define (make-cons-show c) 
     (let* ((cons-env (procedure-environment c)) 
            (cons-head (apply- c (list 2) cons-env)) 
            (cons-tail (apply- c (list 3) cons-env)))  
         (list 
             (make-show cons-head) 
             (make-show cons-tail)))) 
  
 (define (user-print object) 
     (display (make-show object))) 
 ; ======================================================================= 
  
  

closeparen

Interact between the interpreter and user-land to use the car and cdr procedures normally. It took a lot of banging my head against the wall to figure out the "quote" parts!

 ; user-print definition. driver-loop needs to be modified to pass env. 
  
 (define (user-print object env) 
   (if (compound-procedure? object) 
       (if (eq? (car (procedure-parameters object)) 'user-cons-arg) 
           (display (actual-value (list 'take (list 'quote object) 2) env)) 
           (display (list 'compound-procedure 
                          (procedure-parameters object) 
                          (procedure-body object) 
                          '<procedure-env>))) 
         (display object))) 
  
 ; test client 
  
 (define the-global-environment (setup-environment)) 
 (driver-loop) 
  
 (define (take x n) 
   (cond ((null? x) '()) 
         ((= n 0) (list "...")) 
         (else (old-cons (car x) (take (cdr x) (- n 1)))))) 
  
 (define (cons x y) 
   (lambda (user-cons-arg) (user-cons-arg x y))) 
  
 (define (car z) 
   (z (lambda (p q) p))) 
  
 (define (cdr z) 
   (z (lambda (p q) q))) 
  
 (define ll (cons 'a (cons 'b (cons 'c '())))) 
  
 (car ll) 
 (car (cdr ll)) 
 (car (cdr (cdr ll))) 
 ll ;; "(a b ...)" 

SteeleDynamics

It took a while to figure out how to neatly encapsulate the mutual recursion required to print 'cons' pairs in the REPL. The unit tests were omitted for clarity.

  1. Completed exercise 4.33.
  2. Added 'cons', 'car', and 'cdr' procedures to environment 'E0'.
  3. Defined 'max-length' and 'max-depth' to prevent infinite recursion.
  4. Created 'cons?' predicate procedure that is almost alpha-equivalence (no pattern-matching/unification).
  5. Noting that printing from REPL is a primitive procedure, displayed list elements are forced via 'force-it' procedure.
  6. All printing is encapsulated within the two mutually recursive procedures 'lazy-print' and 'cons-print'.
  7. Mutual recursion starts in 'user-print' procedure.
 ; starting with a completed exercise 4.33 implementation... 
  
 ; setup environment E0 for lazy evaluator 
 (define E0 (setup-environment)) 
  
 ; (lazy-evaluator) cons constructor procedure 
 (actual-value '(define (cons a d) (lambda (m) (m a d))) E0) 
  
 ; (lazy-evaluator) car selector procedure 
 (actual-value '(define (car z) (z (lambda (a d) a))) E0) 
  
 ; (lazy-evaluator) cdr selector procedure 
 (actual-value '(define (cdr z) (z (lambda (a d) d))) E0) 
  
 ; max-length definition                                         ;! 
 (define max-length 8) 
  
 ; max-depth definition                                          ;! 
 (define max-depth 4) 
  
 ; cons? predicate procedure                                     ;! 
 ; Or, "A 'cons' by any other name would construct as neat." 
 (define (cons? object) 
   (and (compound-procedure? object) 
        (equal? (procedure-parameters object) '(m)) 
        (equal? (procedure-body object) '((m a d))))) 
  
 ; cons-print procedure                                          ;! 
 (define (cons-print object length depth) 
   (let ((env (procedure-environment object))) 
     (let ((a (force-it (lookup-variable-value 'a env))) 
           (d (force-it (lookup-variable-value 'd env)))) 
       (if (= length max-length) 
           (display "(") 
           (display " ")) 
       (cond ((zero? length) (display "...")) 
             ((zero? depth) (display "...")) 
             ((cons? a) (lazy-print a max-length (- depth 1))) 
             (else (lazy-print a length depth))) 
       (cond ((zero? length) (display ")")) 
             ((zero? depth) (display ")")) 
             ((null? d) (display ")")) 
             ((cons? d) (lazy-print d (- length 1) depth)) 
             (else (display " . ") 
                   (lazy-print d (- length 1) depth) 
                   (display ")")))))) 
  
 ; lazy-print procedure                                          ;! 
 (define (lazy-print object length depth) 
   (cond ((cons? object) 
          (cons-print object length depth)) 
         ((compound-procedure? object) 
          (display (list 'compound-procedure 
                         (procedure-parameters object) 
                         (procedure-body object) 
                         '<procedure-env>))) 
         (else (display object)))) 
  
 ; user-print procedure                                          ;! 
 (define (user-print object) (lazy-print object max-length max-depth))