CASE and SELECT

[Ashwin Ram <ram@YALE.ARPA>]

BUG:
----
I think there is an inconsistency in the definition of CASE and SELECT in T.
Both should take an extra first argument, which is the predicate to use in
the comparison, and CASEQ and SELECTQ should be defined to use EQ? as the
default predicate.  (This is in keeping with MEM? and MEMQ?, ASS and ASSQ,
etc.)  Similarly, there may also be a CASEV and SELECTV.

FIX:
----
The fixed code for CASE follows.  Feel free to use it if you like.  (I've
been calling it CASEF so as not to clobber the original CASE, but I think
that CASE and CASEQ is a better way to go.)  The code is tested.


;;******************************************************************************
;; 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.

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

(define-syntax (case pred key . clauses)
  (labels (((expand-case-1 keyvar clauses)
            (if (atom? clauses) '**case-fell-off-end**
              (let ((clause (car clauses))
                    (lose (lambda () (syntax-error "bad ~s clause syntax: ~s"
                                                   'case
                                                   (car clauses)))))
                (cond ((atom? clause) (lose))
                      ((list? (car clause))
                       `(if (or ,@(map (lambda (k) `(,pred ,keyvar ',k))
                                       (car clause)))
                            ,(blockify (cdr clause))
                          ,(expand-case-1 keyvar (cdr clauses))))
                      ((memq? (car clause) '(t else)) (blockify (cdr clause)))
                      (t (lose)))))))
    (let ((keyvar '%%%%key%%%%))
      `((lambda (,keyvar)
          ,(expand-case-1 keyvar clauses))
        ,key))))

(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))

;;******************************************************************************

-------