Mercurial > hg > xemacs-beta

comparison lisp/specifier.el @ 288:e11d67e05968 r21-0b42

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-0b42
author cvs
date Mon, 13 Aug 2007 10:35:54 +0200
parents 57709be46d1b
children c9fe270a4101
comparison
equal deleted inserted replaced
287:13a0bd77a29d 288:e11d67e05968
409 ;; but it doesn't work for `letf' because set-specifier to the old 409 ;; but it doesn't work for `letf' because set-specifier to the old
410 ;; value cannot be used to "undo" a previous set-specifier, as letf 410 ;; value cannot be used to "undo" a previous set-specifier, as letf
411 ;; expects.) 411 ;; expects.)
412 ;; 412 ;;
413 ;; This macro might perhaps be made simpler, with an addition to 413 ;; This macro might perhaps be made simpler, with an addition to
414 ;; `remove-specifier'. Example (modulo gensyms for clarity): 414 ;; `remove-specifier'. Example (simplified for clarity):
415 ;; 415 ;;
416 ;; (defmacro with-specifier-instance (specifier value domain &rest body) 416 ;; (defmacro let-specifier (specifier value domain &rest body)
417 ;; `(unwind-protect 417 ;; `(unwind-protect
418 ;; (progn 418 ;; (progn
419 ;; (add-spec-to-specifier ,specifier ,value ,domain nil 'prepend) 419 ;; (add-spec-to-specifier ,specifier ,value ,domain nil 'prepend)
420 ;; ,@body) 420 ;; ,@body)
421 ;; (remove-specifier ,specifier ,domain))) 421 ;; (remove-specifier ,specifier ,domain)))
428 ;; argument.) 428 ;; argument.)
429 ;; 429 ;;
430 ;; The following version remembers the old speclist and returns it 430 ;; The following version remembers the old speclist and returns it
431 ;; later. It's probably less error-prone anyway. 431 ;; later. It's probably less error-prone anyway.
432 432
433 (defmacro with-specifier-instance (specifier value domain &rest body) 433 (defmacro let-specifier (specifier-list &rest body)
434 "Evaluate forms in BODY with SPECIFIER instantiating to VALUE in DOMAIN. 434 "(let-specifier SPECIFIER-LIST BODY): bind specifiers and evaluate BODY.
435 The value returned is the value of the last form in BODY. 435 The value of the last form in BODY is returned.
436 Each element of SPECIFIER-LIST should be a list of
437 \(SPECIFIER VALUE DOMAIN). VALUE and DOMAIN may be omitted, and default
438 to nil. The elements of SPECIFIER-LIST are evaluated sequentially.
439
436 For meaning of DOMAIN, see `specifier-instance'." 440 For meaning of DOMAIN, see `specifier-instance'."
437 (let ((specvar (gensym "wsi-")) 441 ;; Error-checking
438 (valvar (gensym "wsi-")) 442 (dolist (listel specifier-list)
439 (domvar (gensym "wsi-")) 443 (or (and (consp listel)
440 (oldvar (gensym "wsi-"))) 444 (<= (length listel) 3))
441 ;; Remember the arguments to prevent multiple evaluation. 445 (signal 'error (list "Should be a 3-element list" listel))))
442 `(let* ((,specvar ,specifier) 446 ;; Set up fresh symbols to avoid name clashes.
443 (,valvar ,value) 447 (let* ((specvarlist (mapcar #'(lambda (ignored) (gensym "specifier-"))
444 (,domvar ,domain) 448 specifier-list))
445 (,oldvar (specifier-spec-list ,specvar ,domvar))) 449 (valvarlist (mapcar #'(lambda (ignored) (gensym "value-"))
450 specifier-list))
451 (domvarlist (mapcar #'(lambda (ignored) (gensym "domain-"))
452 specifier-list))
453 (oldvarlist (mapcar #'(lambda (ignored) (gensym "old-"))
454 specifier-list)))
455 ;; Bind the appropriate variables.
456 `(let* (,@(mapcar* (lambda (symbol listel)
457 (list symbol (nth 0 listel)))
458 specvarlist specifier-list)
459 ,@(mapcar* (lambda (symbol listel)
460 (list symbol (nth 1 listel)))
461 valvarlist specifier-list)
462 ,@(mapcar* (lambda (symbol listel)
463 (list symbol (nth 2 listel)))
464 domvarlist specifier-list)
465 ,@(mapcar* (lambda (symbol specifier domain)
466 (list symbol `(specifier-spec-list
467 ,specifier ,domain)))
468 oldvarlist specvarlist domvarlist))
446 (unwind-protect 469 (unwind-protect
447 (progn 470 (progn
448 (add-spec-to-specifier ,specvar ,valvar ,domvar nil 'prepend) 471 ,@(mapcar* (lambda (specifier value domain)
472 `(add-spec-to-specifier
473 ,specifier ,value ,domain
474 nil 'prepend))
475 specvarlist valvarlist domvarlist)
449 ,@body) 476 ,@body)
450 (remove-specifier ,specvar ,domvar nil t) 477 ,@(apply
451 (add-spec-list-to-specifier ,specvar ,oldvar))))) 478 #'nconc
452 479 ;; Reverse the unwinding order for marginal safety gain.
480 (nreverse
481 (mapcar*
482 (lambda (specifier domain oldvalue)
483 `((remove-specifier ,specifier ,domain)
484 (add-spec-list-to-specifier ,specifier ,oldvalue)))
485 specvarlist domvarlist oldvarlist)))))))
486
487 ;; (cl-prettyexpand '(let-specifier ((modeline-shadow-thickness 0 (selected-window)) (fubar 0 baz)) (sit-for 1)))
488
453 (define-specifier-tag 'win 'device-on-window-system-p) 489 (define-specifier-tag 'win 'device-on-window-system-p)
454 490
455 ;; Add tags for device types that don't have support compiled 491 ;; Add tags for device types that don't have support compiled
456 ;; into the binary that we're about to dump. This will prevent 492 ;; into the binary that we're about to dump. This will prevent
457 ;; code like 493 ;; code like