Exercise 4.34: Pretty printing of lazy pairs

This change makes cons a special form that returns a tagged
procedure.  This tag is used to distinguish it from normal procedures
when printing out the pair.  Apply is modified to skip over the tag
and apply the procedure as normal.

mceval/common.rkt

@@ -29,12 +29,12 @@
   (newline) (display string) (newline))
 
 (define (user-print object)
-  (if (compound-procedure? object)
-      (display (list 'compound-procedure
-                     (procedure-parameters object)
-                     (procedure-body object)
-                     '<procedure-env>))
-      (display object)))
+  (cond ((compound-procedure? object)
+         (display (list 'compound-procedure
+                        (procedure-parameters object)
+                        (procedure-body object)
+                        '<procedure-env>)))
+        (else (display object))))
 
 ;; Program is a list of expressions to evaluate using the procedure
 ;; eval.  user-print will be called to print any output.

mceval/leval.rkt

@@ -21,6 +21,7 @@
 
 (define (lazy-eval exp env)
   (cond ((self-evaluating? exp) exp)
+        ((lazy-pair? exp) exp)
         ((variable? exp) (lookup-variable-value exp env))
         ((quoted? exp) (let ((text (text-of-quotation exp)))
                          (if (pair? text)
@@ -37,6 +38,9 @@
         ((begin? exp) 
          (eval-sequence (begin-actions exp) env lazy-eval))
         ((cond? exp) (lazy-eval (cond->if exp) env))
+        ((cons? exp) (eval-cons (cons-first-exp exp)
+                                (cons-second-exp exp)
+                                env))
         ((application? exp)             ; clause from book
          (lazy-apply (actual-value (operator exp) env)
                      (operands exp)
@@ -52,6 +56,9 @@
          (apply-primitive-procedure
           procedure
           (list-of-arg-values arguments env))) ; changed
+        ((lazy-pair? procedure)
+         (lazy-apply (lazy-pair-proc procedure)
+                     arguments env))
         ((compound-procedure? procedure)
          (eval-sequence
           (procedure-body procedure)
@@ -86,6 +93,27 @@
 (define input-prompt ";;; L-Eval input:")
 (define output-prompt ";;; L-Eval value:")
 
+
+(define (user-print object env)
+  (cond ((compound-procedure? object)
+         (display (list 'compound-procedure
+                        (procedure-parameters object)
+                        (procedure-body object)
+                        '<procedure-env>)))
+        ((lazy-pair? object) (display (print-lazy-pair object env)))
+        (else (display object))))
+
+(define (print-lazy-pair lazy-pair env)
+  (let loop ((lp lazy-pair) (i 0))
+    (cond ((= i 16) '(...))
+          ((null? lp) '())
+          ((pair? lp)
+           (cons (actual-value `(car ,lp) env)
+                 (loop
+                  (actual-value `(cdr ,lp) env)
+                  (+ i 1))))
+          (else lp))))
+
 (define (lazy-driver-loop)
   (define env (setup-environment))
   ;; Read in code to implement lazy lists
@@ -95,7 +123,7 @@
     (let ((input (read)))
       (let ((output (actual-value input env)))
         (announce-output output-prompt)
-        (user-print output))
+        (user-print output env))
       (driver-loop)))
   (driver-loop))
 

mceval/special-forms.rkt

@@ -4,13 +4,16 @@
            "common.rkt"
            "syntax.rkt")
 
+(#%require racket/trace)
+
 (#%provide eval-if
            eval-sequence
            eval-assignment
            eval-definition
            eval-unbind
            eval-and
-           eval-or)
+           eval-or
+           eval-cons)
 
 ;; Evaulation of special forms
 
@@ -59,5 +62,8 @@
             (eval-or (make-or (rest-disjuncts disjuncts))
                      env eval-proc)))))
 
+(define (eval-cons x y env)
+  (make-lazy-pair
+   (make-procedure '(m) `((m ,x ,y)) env)))
 
 

mceval/syntax.rkt

@@ -455,3 +455,19 @@
 
 (define (thunk-value evaluated-thunk) (cadr evaluated-thunk))
 
+;; Lazy lists (exercise 4.34)
+(define (make-lazy-pair exp)
+  (list 'lazy-pair exp))
+
+(define (lazy-pair? obj)
+  (tagged-list? obj 'lazy-pair))
+
+(define (lazy-pair-proc lazy-pair)
+  (cadr lazy-pair))
+
+(define (cons? exp)
+  (tagged-list? exp 'cons))
+(define (cons-first-exp exp)
+  (cadr exp))
+(define (cons-second-exp exp)
+  (caddr exp))