Lesson Plan - 6.001 SP04 - recitation 20

metacircular evaluator - cont'd

syntactical transformations and quasiquote

(define case-expr second)
(define case-clauses cddr)

(define (case->cond exp)
  (let* ((expr (case-expr exp))
	 (xclauses (map (lambda (x)
			  (if (eq? (car x) 'else)
			      `(else ,@(cdr x))
			      `((memq ,expr ',(car x)) ,@(cdr x))))
			(case-clauses exp))))
    `(cond ,@xclauses)))

(define (case->cond exp)
  (let* ((expr (case-expr exp))
	 (xclauses (map (lambda (x)
			  (if (eq? (car x) 'else)
			      `(else ,@(cdr x))
			      `((memq **val** ',(car x)) ,@(cdr x))))
			(case-clauses exp))))
    `(let ((**val** ,expr))
       (cond ,@xclauses))))

(pp
(case->cond '(case x
	       ((FOO) 'yay)
	       ((BAR BAZ) 'rah)
	       (else 'yummy)))
)

(define (filter pred lst)
  (cond ((null? lst)
	 '())
	((pred (car lst))
	 (cons (car lst) (filter pred (cdr lst))))
	(else (filter pred (cdr lst)))))

(define (case->cond exp)
  (let ((xclauses (map (lambda (x)
			 `(list ',(car x) (lambda () ,@(cdr x))))
		       (filter (lambda (x) (not (eq? (car x) 'else)))
			       (case-clauses exp))))
	(else-expr (filter (lambda (x) (eq? x 'else))
			   (case-clauses exp))))
    `(let* ((ops (list ,@xclauses))
	    (lookup (association-procedure 
		     (lambda (key test) (memq test key)) car))
	    (val (lookup ,(case-expr exp) ops)))
       (if val
	   ((cadr val))
	   ,(if else-expr
		(car else-expr)
		''unspecified)))))