Bug fix for Ashwin's CASE

[Olin.Shivers@H.CS.CMU.EDU]

I thought Ashwin had a good idea there, but the implementation seemed to have
a bug. Briefly, the code that Ashwin's macro turned out would evaluate the
the predicate and key value forms multiple times. This could get you into 
trouble if the predicate or key forms had side effects or took 30 minutes to
compute or something. Consider
    (CASE (POP PREDS) X . clauses)
You don't want to evaluate (POP PREDS) more than once. So I rewrote his macro
expander. It's below. Have fun.
    -Olin
----------
(herald case)
;;******************************************************************************
;; CASE with specifiable PREDicate to compare the cases with.
;; Original CASE is equivalent to: (CASE eq? key . clauses)  [now called CASEQ].
;; Ashwin Ram, May 1985.
;; Rewritten by Olin Shivers (shivers@a.cs.cmu.edu) 2/26/86
;;     CASE now evaluates the KEY and PRED forms exactly once, in the
;;     environment that the CASE statement appears in.

(define **case-fell-off-end** '**case-fell-off-end**)

(define-syntax (case pred key . clauses)
  (let ((comparator '%%%%casefun%%%%))
    (labels (((expand-case-1 clauses)
	      (if (atom? clauses) '**case-fell-off-end**
		  (let ((clause (car clauses)))
		    (cond ((atom? clause) (lose clauses))
			  ((list? (car clause))
			   `(if (or ,@(map (lambda (k) `(,comparator ',k))
					   (car clause)))
				,(blockify (cdr clause))
				,(expand-case-1 (cdr clauses))))
			  ((memq? (car clause) '(t else))
			   (blockify (cdr clause)))
			  (t (lose clauses))))))
	     ((lose clauses)
	      (syntax-error "bad ~s clause syntax: ~s" 'case (car clauses))))
      ;; Bind %%%%casefun%%%% to a monadic function returning true if its
      ;; argument is "equal" to the key, with "equal" defined by the value of
      ;; the PRED form.
      `(let ( (,comparator (let ((key ,key) (pred ,pred))
			     (lambda (x) (pred key x)))) )
	 ,(expand-case-1 clauses)))))

;;; Example: 
; (CASE (POP PREDLIST) (HAIRY-COMPUTATION)
;   ((5 9 8) (FOO) (BAR 3) (BAZ))
;   (("T" "Scheme") 37)
;   ((franz) 0))

;;; Expands as
;(LET ((%%%%CASEFUN%%%% (LET ((KEY (HAIRY-COMPUTATION))
;			     (PRED (POP PREDLIST)))
;			 (LAMBDA (X) (PRED KEY X)))))
;  (IF (OR (%%%%CASEFUN%%%% '5)
;	   (%%%%CASEFUN%%%% '9)
;	   (%%%%CASEFUN%%%% '8))
;      (BLOCK (FOO) (BAR 3) (BAZ))
;      (IF (OR (%%%%CASEFUN%%%% '"T")
;	      (%%%%CASEFUN%%%% '"Scheme"))
;	   37
;	   (IF (OR (%%%%CASEFUN%%%% 'FRANZ))
;	       0
;	       **CASE-FELL-OFF-END**))))

(define-syntax (xcase pred key . clauses)
  `(case ,pred ,key ,@clauses (else (losing-xcase))))

(define (losing-xcase)
  (error "no clause selected in ~s expression" 'xcase))

(define-syntax (caseq key . clauses)
  `(case eq? ,key ,@clauses))

(define-syntax (casev key . clauses)
  `(case alikev? ,key ,@clauses))

;;; EOF