;;; -*- 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 (c)(1)(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-1989 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 a match succeeds and the accompanying CONDITION evaluates to non-NIL. Then the CLAUSE-BODY of that clause is executed and its last expression's value is returned. ,VARIABLE can appear in a pattern; it matches anything, and the variable is 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 objects in 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 "e 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)))) ;; 12/12/88 DNG - Replace variable "OBJ" with "OBJECT" because "OBJ" has been ;; declared special in file "SYS:MEMORY-MANAGEMENT;MEMORY-DEBUG.LISP". ;; 03/16/89 clm - integrated into Kernel from CLOS. (defun select-match-matchitems (patt expr) (declare (special boundvars)) (cond ((null patt) `(null ,expr)) ((symbolp patt) (cond ((eq patt 'ignore) `(progn ,expr 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 (object) ,(select-match-matchitems (cadr patt) 'object)) #'(lambda (object) ,(select-match-matchitems (caddr patt) 'object))) ) ((eq (car patt) 'xr-bq-list) (let ((exp '(null object)) (eltmatches (mapcar 'select-match-matchitems (cdr patt) (circular-list 'object)))) (loop for eltmatch in (reverse eltmatches) do (setq exp `(match-car-cdr object #'(lambda (object) ,eltmatch) #'(lambda (object) ,exp)))) `(match-car-cdr ,expr ,@(cddr exp)))) ((eq (car patt) 'xr-bq-list*) (let ((exp (select-match-matchitems (car (last patt)) 'object)) (eltmatches (mapcar 'select-match-matchitems (butlast (cdr patt)) (circular-list 'object)))) (loop for eltmatch in (reverse eltmatches) do (setq exp `(match-car-cdr object #'(lambda (object) ,eltmatch) #'(lambda (object) ,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))))) ;;03/16/89 clm - part of CLOS integration. ;; 3/21/89 DNG - Do this only at compile time. (eval-when (eval compile) (assert (not (compiler:specialp 'object)))) ;; Macro WITH-TIMEOUT moved to "UNKERNEL;WITH-TIMEOUT" -- DNG 8/26/86