;;; -*- Mode: Common-Lisp; Package: sys; Base: 10.; Patch-File: T -*-

;;; Reason: Fixed comma in select-memq.

;;;                           RESTRICTED RIGHTS LEGEND
;;;
;;; Use, duplication, or disclosure by the Government is subject to
;;; restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;; Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;   TEXAS INSTRUMENTS INCORPORATED      
;;;   P.O. BOX 2909, M/S 2151             
;;;   AUSTIN, TEXAS 78769                 
;;;
;;; Copyright (C) 1989 Texas Instruments Incorporated.
;;; All rights reserved.

;;; Written 06/07/90 07:13:13 by BERGER,
;;; while running on ARIES from band LODX
;;; With SYSTEM 6.36, VIRTUAL-MEMORY 6.3, EH 6.8, MAKE-SYSTEM 6.3, MICRONET 6.0, LOCAL-FILE 6.2,
;;;  BASIC-PATHNAME 6.5, NETWORK-SUPPORT-COLD 6.2, BASIC-NAMESPACE 6.8, NETWORK-NAMESPACE 6.1,
;;;  DISK-IO 6.3, DISK-LABEL 6.0, BASIC-FILE 6.13, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.2,
;;;  COMPILER 6.18, TV 6.26, DATALINK 6.0, CHAOSNET 6.8, GC 6.4, MEMORY-AUX 6.0, NVRAM 6.3,
;;;  SYSLOG 6.2, STREAMER-TAPE 6.6, UCL 6.0, INPUT-EDITOR 6.0, METER 6.2, ZWEI 6.21,
;;;  DEBUG-TOOLS 6.4, NETWORK-SUPPORT 6.1, NETWORK-SERVICE 6.3, DATALINK-DISPLAYS 6.0,
;;;  FONT-EDITOR 6.1, SERIAL 6.0, PRINTER 6.7, MAC-PRINTER-TYPES 6.2, PRINTER-TYPES 6.2,
;;;  IMAGEN 6.1, SUGGESTIONS 6.1, MAIL-DAEMON 6.6, MAIL-READER 6.8, TELNET 6.1, VT100 6.0,
;;;  NAMESPACE-EDITOR 6.5, PROFILE 6.3, VISIDOC 6.7, TI-CLOS 6.50, CLEH 6.5, IP 3.65,
;;;  Experimental CLX 6.11, CLUE 6.104, X11M 6.26, Experimental BUG 11.19, VISIDOC-SERVER 6.2,
;;;   microcode 483, Band Name: 6.1-A 5-31 +P6/4

#!C
; From file CONDITIONALS-MACROS.LISP#> KERNEL; sys:
#10R SYSTEM#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "SYSTEM"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* *COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: KERNEL; CONDITIONALS-MACROS.#"


(defmacro select-memq (test-list &body clauses)
  "Execute the first clause that matches some element of TEST-LIST.
The first element of each clause is a match value or a list of match values.
Each match value is compare with each element of TEST-LIST, using EQ.
When a match-value matches, the rest of that clause is executed
and the value of the last thing in the clause is the value of the SELECT-MEMQ.
T or :OTHERWISE as the first element of a clause matches any test object."
  (let (test-exp cond-exp)
    (setq test-exp
	  ;; If TEST-LIST is an eval-at-load-time,
	  ;; we will treat it as a random expression, which is right.
	  (cond ((or (atom test-list)
		     (and (member (car test-list) '(car cdr caar cadr cdar cddr) :test #'eq)
			  (atom (cadr test-list))))
		 test-list)
		(t '.case.item.)))
    (setq cond-exp
	  (cons 'cond
		(mapcar #'(lambda (clause)
			    (macro-type-check-warning 'select-memq (car clause))
			    (cond ((member (car clause) '(otherwise :otherwise t) :test #'eq)
				   (list* t nil (cdr clause)))
				  ((atom (car clause))
				   `((member ',(car clause) ,test-exp :test #'eq) nil . ,(cdr clause)))
				  (t
				   `((or . ,(mapcar #'(lambda (match-value)
							`(member ',match-value ,test-exp :test #'eq))
						    (car clause)))
				     nil . ,(or (cdr clause) T) ; DAB 05-24-90
				     ))))
			clauses)))
    (dead-clauses-warning (cdr cond-exp) 'select-memq)
    (cond ((eq test-exp test-list) cond-exp)
	  (t
	   `(let ((.case.item. ,test-list))
	      ,cond-exp)))))
))