LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760031519. :SYSTEM-TYPE :LOGICAL :VERSION 7. :TYPE "LISP" :NAME "SELECT-MATCH" :DIRECTORY ("REL3-SOURCE" "KERNEL") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-SOURCE\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :VERSION-LIMIT 0. :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2758644232. :AUTHOR "REL3" :LENGTH-IN-BYTES 6000. :LENGTH-IN-BLOCKS 6. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                           ;;; -*- Mode:Common-Lisp; Package:SYSTEM-INTERNALS; Base:10 -*-;;;                           RESTRICTED RIGHTS LEGEND;;;Use, duplication, or disclosure by the Government is subject to;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in;;;Technical Data and Computer Software clause at 52.227-7013.;;;                     TEXAS INSTRUMENTS INCORPORATED.;;;                              P.O. BOX 2909;;;                           AUSTIN, TEXAS 78769;;;                                 MS 2151;;; Copyright (C) 1985,1987 Texas Instruments Incorporated. All rights reserved.;;; Macros to do things similar to BLISS' SELECT.;; Make SELECT-MATCH indent like SELECTQ.;;;(when (boundp 'zwei:*lisp-indent-offset-alist*);;;  (setq zwei:*lisp-indent-offset-alist*;;;(cons;;; (cons 'select-match (cdr (assoc 'selectq zwei:*lisp-indent-offset-alist* :test #'eq)));;; zwei:*lisp-indent-offset-alist*));;;  (setq zwei:*initial-lisp-indent-offset-alist*;;;(cons;;; (cons 'select-match;;;       (cdr (assoc 'selectq zwei:*initial-lisp-indent-offset-alist* :test #'eq)));;; zwei:*initial-lisp-indent-offset-alist*)));;;Make pprint treat select-match like case.(defprint select-match -1) (defmacro select-match (object . clauses) ;; We want ARGLIST to say we have a BODY, ;; but don't set up &BODY indentation, because we use the hairier SELECTQ identation.  (declare (arglist object &body clauses))  "Execute the first clause whose pattern matches the value of OBJECT.The syntax is    (SELECT-MATCH OBJECT     (`PATTERN CONDITION CLAUSE-BODY...)     (`PATTERN CONDITION CLAUSE-BODY...)     ...     (`PATTERN CONDITION CLAUSE-BODY...)     (OTHERWISE CLAUSE-BODY...)The value of OBJECT is matched against the PATTERNs one at a time until amatch succeeds and the accompanying CONDITION evaluates to non-NIL.Then the CLAUSE-BODY of that clause is executed and its last expression'svalue is returned.,VARIABLE can appear in a pattern; it matches anything, and the variableis bound to what it matched for the execution of the CONDITION and CLAUSE-BODY.If one variable appears twice in a pattern, it must match EQUAL objectsin both occurrences:    (SELECT-MATCH '(A B C)       (`(,X B ,X) T 'LOSE)      (`(,X B ,Y) T 'WIN)      (OTHERWISE 'LOSE-BIG))returns WIN.  Use ,IGNORE to match anything and not use it."  (let* ((binding-list ()) (genvar (gensym)) (clauses (mapcar #'select-match-clause clauses (circular-list genvar))))    (declare (special binding-list))    `(let ((,genvar ,object)   . ,binding-list)       (cond . ,clauses)))) (defmacro list-match-p (list pattern)  "T if the value of LIST matches PATTERN.  PATTERN is a backquote expression.Constant parts of PATTERN are matched against the corresponsing parts of LIST.Variables preceded by commas are SETQ'd to the corresponding parts of LIST.If the same variable appears twice, it must match EQUAL objects both times.Example: (LIST-MATCH-P '(FOO BAR BAR) `(FOO ,X ,X)) returns T and sets X to BAR."  (let (boundvars)    (declare (special boundvars))    (select-match-matchitems pattern list))) ;Return the COND clause corresponding to one SELECT-MATCH clause.;Merges any pattern variables used into BOUNDVARS.(defun select-match-clause (clause objectvar)  (if (member (car clause) '(otherwise :otherwise t) :test #'eq)    (cons 't (cdr clause))    (let* (boundvars  (patcond (select-match-matchitems (car clause) objectvar)))      (declare (special boundvars binding-list))      (setf binding-list (nunion binding-list boundvars :test #'eq))      `((and ,patcond ,@(if (eq (cadr clause) 't) nil (list (cadr clause))))    . ,(cddr clause)))));; MATCHCARCDR evals ARG, tests its car with CAR (a function of one arg);; and its cdr with CDR.  The COMPILER P1 handler  takes care;; of open coding it with very fast code.(defun matchcarcdr (argval &quote car cdr)  (and (consp argval)       (with-stack-list (q-car 'quote (car argval)) (with-stack-list (l car q-car)   (eval1 l)))       (with-stack-list (q-cdr 'quote (cdr argval)) (with-stack-list (l cdr q-cdr)   (eval1 l)))))(proclaim '(inline match-car-cdr))(defun match-car-cdr (arg car-fun cdr-fun)  (and (consp arg)       (funcall car-fun (car arg))       (funcall cdr-fun (cdr arg))))(defun select-match-matchitems (patt expr)  (declare (special boundvars))  (cond    ((null patt) `(null ,expr))    ((symbolp patt)     (cond       ((eq patt 'ignore) t)       ((member patt boundvars :test #'eq) `(equal ,expr ,patt))       (t (push patt boundvars) `(progn   (setq ,patt ,expr)   t))))    ((eq (car patt) 'xr-bq-cons)     `(match-car-cdr ,expr #'(lambda (obj)   ,(select-match-matchitems (cadr patt) 'obj)) #'(lambda  (obj)   ,(select-match-matchitems (caddr patt) 'obj))) )    ((eq (car patt) 'xr-bq-list)     (let ((exp '(null obj))   (eltmatches (mapcar 'select-match-matchitems (cdr patt) (circular-list 'obj))))       (loop for eltmatch in (reverse eltmatches) do  (setq exp`(match-car-cdr obj #'(lambda (obj)    ,eltmatch)    #'(lambda (obj)      ,exp))))       `(match-car-cdr ,expr ,@(cddr exp))))    ((eq (car patt) 'xr-bq-list*)     (let ((exp (select-match-matchitems (car (last patt)) 'obj))   (eltmatches (mapcar 'select-match-matchitems (butlast (cdr patt)) (circular-list 'obj))))       (loop for eltmatch in (reverse eltmatches) do   (setq  exp`(match-car-cdr obj #'(lambda (obj)    ,eltmatch)    #'(lambda (obj)      ,exp))))       `(match-car-cdr ,expr ,@(cddr exp))))    ((eq (car patt) 'quote) `(equal ,expr ',(cadr patt)))    ((member (car patt) '`(,@xr-bq-nconc ,@xr-bq-vector) :test #'eq)     (ferror () "Appending, nconcing or vector construction in SELECT-MATCH pattern."))    (t (ferror () "Unexpected function ~S found in SELECT-MATCH pattern." (car patt))))) ;; Macro WITH-TIMEOUT moved to "UNKERNEL;WITH-TIMEOUT"  -- DNG 8/26/86.FLAVOR may also be a flavor instance, instead of a flavor name.  In this casethe instance is used instead of creating a new instance.  It is