New improved CASE macro

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

Well, Martin's jumping on me for my variable naming style made me sit down and
do it *right*, i.e. with no variable conflicts possible at all. Below, the
new improved code. You cannot tromp on the runtime variables of this solution.
Aren't lexically scoped lisps 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)
 (labels (((expand-case-1 names clauses)
	   (if (atom? clauses) '**case-fell-off-end**
	       (let ((clause (car clauses)) (clauses (cdr clauses))
		     (name   (car names))   (names   (cdr names)))
		 (cond ((list? (car clause))
			`(if (or . ,(map (lambda (k) `(pred key ',k))
					 (car clause)))
			     (,name)
			     ,(expand-case-1 names clauses)))
		       ((memq? (car clause) '(t else))
			`(,name))
		       ;; Should never come here.
		       (t (lose clause))))))
	  ((syntax-check-keys keys)
	   (or (memq? keys '(t else))
	       (and (list? keys)
		    (every (lambda (k) (atom? k)) keys))))
	  ((lose clause)
	   (syntax-error "bad ~s clause syntax: ~s" 'case clauses)))

   ;; A little initial syntax checking.
   (walk (lambda (c) (if (or (not (pair? c))
			     (not (syntax-check-keys (car c))))
			 (lose c)))
	 clauses)
   (let ((names  (map (lambda (()) (generate-symbol 'thunk)) clauses))
	 (thunks (map (lambda (c) `(lambda () . ,(cdr c))) clauses)))
     `(let ((key ,key) (pred ,pred)
	    . , (map (lambda (name thunk) `(,name ,thunk)) names thunks))
	,(expand-case-1 names clauses)))))



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

;;; Expands as
;(LET ((KEY (HAIRY-COMPUTATION))
;      (PRED (POP PREDLIST))
;      (THUNK.64 (LAMBDA () (FOO) (BAR 3) (BAZ)))
;      (THUNK.65 (LAMBDA () 37))
;      (THUNK.66 (LAMBDA () 0)))
;  (IF (OR (PRED KEY (QUOTE 5))
;	   (PRED KEY (QUOTE 9))
;	   (PRED KEY (QUOTE 8)))
;      (THUNK.64)
;      (IF (OR (PRED KEY (QUOTE "T"))
;	       (PRED KEY (QUOTE "Scheme")))
;	   (THUNK.65)
;	   (IF (OR (PRED KEY (QUOTE FRANZ))
;		   (PRED KEY (QUOTE FORTRAN)))
;	       (THUNK.66)
;	       **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