Mercurial > hg > xemacs-beta
diff lisp/specifier.el @ 288:e11d67e05968 r21-0b42
Import from CVS: tag r21-0b42
author | cvs |
---|---|
date | Mon, 13 Aug 2007 10:35:54 +0200 |
parents | 57709be46d1b |
children | c9fe270a4101 |
line wrap: on
line diff
--- a/lisp/specifier.el Mon Aug 13 10:35:07 2007 +0200 +++ b/lisp/specifier.el Mon Aug 13 10:35:54 2007 +0200 @@ -411,9 +411,9 @@ ;; expects.) ;; ;; This macro might perhaps be made simpler, with an addition to -;; `remove-specifier'. Example (modulo gensyms for clarity): +;; `remove-specifier'. Example (simplified for clarity): ;; -;; (defmacro with-specifier-instance (specifier value domain &rest body) +;; (defmacro let-specifier (specifier value domain &rest body) ;; `(unwind-protect ;; (progn ;; (add-spec-to-specifier ,specifier ,value ,domain nil 'prepend) @@ -430,26 +430,62 @@ ;; The following version remembers the old speclist and returns it ;; later. It's probably less error-prone anyway. -(defmacro with-specifier-instance (specifier value domain &rest body) - "Evaluate forms in BODY with SPECIFIER instantiating to VALUE in DOMAIN. -The value returned is the value of the last form in BODY. +(defmacro let-specifier (specifier-list &rest body) + "(let-specifier SPECIFIER-LIST BODY): bind specifiers and evaluate BODY. +The value of the last form in BODY is returned. +Each element of SPECIFIER-LIST should be a list of +\(SPECIFIER VALUE DOMAIN). VALUE and DOMAIN may be omitted, and default +to nil. The elements of SPECIFIER-LIST are evaluated sequentially. + For meaning of DOMAIN, see `specifier-instance'." - (let ((specvar (gensym "wsi-")) - (valvar (gensym "wsi-")) - (domvar (gensym "wsi-")) - (oldvar (gensym "wsi-"))) - ;; Remember the arguments to prevent multiple evaluation. - `(let* ((,specvar ,specifier) - (,valvar ,value) - (,domvar ,domain) - (,oldvar (specifier-spec-list ,specvar ,domvar))) + ;; Error-checking + (dolist (listel specifier-list) + (or (and (consp listel) + (<= (length listel) 3)) + (signal 'error (list "Should be a 3-element list" listel)))) + ;; Set up fresh symbols to avoid name clashes. + (let* ((specvarlist (mapcar #'(lambda (ignored) (gensym "specifier-")) + specifier-list)) + (valvarlist (mapcar #'(lambda (ignored) (gensym "value-")) + specifier-list)) + (domvarlist (mapcar #'(lambda (ignored) (gensym "domain-")) + specifier-list)) + (oldvarlist (mapcar #'(lambda (ignored) (gensym "old-")) + specifier-list))) + ;; Bind the appropriate variables. + `(let* (,@(mapcar* (lambda (symbol listel) + (list symbol (nth 0 listel))) + specvarlist specifier-list) + ,@(mapcar* (lambda (symbol listel) + (list symbol (nth 1 listel))) + valvarlist specifier-list) + ,@(mapcar* (lambda (symbol listel) + (list symbol (nth 2 listel))) + domvarlist specifier-list) + ,@(mapcar* (lambda (symbol specifier domain) + (list symbol `(specifier-spec-list + ,specifier ,domain))) + oldvarlist specvarlist domvarlist)) (unwind-protect (progn - (add-spec-to-specifier ,specvar ,valvar ,domvar nil 'prepend) + ,@(mapcar* (lambda (specifier value domain) + `(add-spec-to-specifier + ,specifier ,value ,domain + nil 'prepend)) + specvarlist valvarlist domvarlist) ,@body) - (remove-specifier ,specvar ,domvar nil t) - (add-spec-list-to-specifier ,specvar ,oldvar))))) + ,@(apply + #'nconc + ;; Reverse the unwinding order for marginal safety gain. + (nreverse + (mapcar* + (lambda (specifier domain oldvalue) + `((remove-specifier ,specifier ,domain) + (add-spec-list-to-specifier ,specifier ,oldvalue))) + specvarlist domvarlist oldvarlist))))))) +;; (cl-prettyexpand '(let-specifier ((modeline-shadow-thickness 0 (selected-window)) (fubar 0 baz)) (sit-for 1))) + (define-specifier-tag 'win 'device-on-window-system-p) ;; Add tags for device types that don't have support compiled