Mercurial > hg > xemacs-beta

comparison lisp/specifier.el @ 290:c9fe270a4101 r21-0b43

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-0b43
author cvs
date Mon, 13 Aug 2007 10:36:47 +0200
parents e11d67e05968
children 70ad99077275
comparison
equal deleted inserted replaced
289:6e6992ccc4b6 290:c9fe270a4101
401 specifier 401 specifier
402 (canonicalize-spec-list nval (specifier-type specifier)) 402 (canonicalize-spec-list nval (specifier-type specifier))
403 how-to-add)))) 403 how-to-add))))
404 value) 404 value)
405 405
406 ;; Note: you cannot replace the following macro with `letf' because
407 ;; `specifier-instance' does not have a setf method defined. (I tried
408 ;; to use `set-specifier' as the setf method for `specifier-instance',
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
411 ;; expects.)
412 ;;
413 ;; This macro might perhaps be made simpler, with an addition to
414 ;; `remove-specifier'. Example (simplified for clarity):
415 ;;
416 ;; (defmacro let-specifier (specifier value domain &rest body)
417 ;; `(unwind-protect
418 ;; (progn
419 ;; (add-spec-to-specifier ,specifier ,value ,domain nil 'prepend)
420 ;; ,@body)
421 ;; (remove-specifier ,specifier ,domain)))
422 ;;
423 ;; So, the idea is to unconditionally prepend a specification for
424 ;; DOMAIN, and unconditionally remove it. This does not work because
425 ;; `remove-specifier' removes *all* the specifications of DOMAIN,
426 ;; nuking the old ones, in the process. (for this purpose, it might
427 ;; make sense for `remove-specifier' to have a HOW-TO-REMOVE
428 ;; argument.)
429 ;;
430 ;; The following version remembers the old speclist and returns it
431 ;; later. It's probably less error-prone anyway.
432
433 (defmacro let-specifier (specifier-list &rest body) 406 (defmacro let-specifier (specifier-list &rest body)
434 "(let-specifier SPECIFIER-LIST BODY): bind specifiers and evaluate BODY. 407 "Add specifier specs, evaluate forms in BODY and restore the specifiers.
408 \(let-specifier SPECIFIER-LIST BODY...)
409
410 Each element of SPECIFIER-LIST should look like this:
411 \(SPECIFIER VALUE &optional LOCALE TAG-SET HOW-TO-ADD).
412
413 SPECIFIER is the specifier to be temporarily modified. VALUE is the
414 instantiator to be temporarily added to SPECIFIER in LOCALE. LOCALE,
415 TAG-SET and HOW-TO-ADD have the same meaning as in
416 `add-spec-to-specifier'.
417
418 The code resulting from macro expansion will add specifications to
419 specifiers using `add-spec-to-specifier'. After BODY is finished, the
420 temporary specifications are removed and old spec-lists are restored.
421
422 LOCALE, TAG-SET and HOW-TO-ADD may be omitted, and default to nil.
435 The value of the last form in BODY is returned. 423 The value of the last form in BODY is returned.
436 Each element of SPECIFIER-LIST should be a list of 424
437 \(SPECIFIER VALUE DOMAIN). VALUE and DOMAIN may be omitted, and default 425 NOTE: If you want the specifier's instance to change in all
438 to nil. The elements of SPECIFIER-LIST are evaluated sequentially. 426 circumstances, use (selected-window) as the LOCALE. If LOCALE is nil
439 427 or omitted, it defaults to `global'.
440 For meaning of DOMAIN, see `specifier-instance'." 428
441 ;; Error-checking 429 Example:
442 (dolist (listel specifier-list) 430 (let-specifier ((modeline-shadow-thickness 0 (selected-window)))
443 (or (and (consp listel) 431 (sit-for 1))"
444 (<= (length listel) 3)) 432 (check-argument-type 'listp specifier-list)
445 (signal 'error (list "Should be a 3-element list" listel)))) 433 (flet ((gensym-frob (x name)
446 ;; Set up fresh symbols to avoid name clashes. 434 (if (or (atom x) (eq (car x) 'quote))
447 (let* ((specvarlist (mapcar #'(lambda (ignored) (gensym "specifier-")) 435 (list x)
448 specifier-list)) 436 (list (gensym name) x))))
449 (valvarlist (mapcar #'(lambda (ignored) (gensym "value-")) 437 ;; VARLIST is a list of
450 specifier-list)) 438 ;; ((SPECIFIERSYM SPECIFIER) (VALUE) (LOCALESYM LOCALE)
451 (domvarlist (mapcar #'(lambda (ignored) (gensym "domain-")) 439 ;; (TAG-SET) (HOW-TO-ADD))
452 specifier-list)) 440 ;; If any of these is an atom, then a separate symbol is
453 (oldvarlist (mapcar #'(lambda (ignored) (gensym "old-")) 441 ;; unnecessary, the CAR will contain the atom and CDR will be nil.
454 specifier-list))) 442 (let* ((varlist (mapcar #'(lambda (listel)
455 ;; Bind the appropriate variables. 443 (or (and (consp listel)
456 `(let* (,@(mapcar* (lambda (symbol listel) 444 (<= (length listel) 5)
457 (list symbol (nth 0 listel))) 445 (> (length listel) 1))
458 specvarlist specifier-list) 446 (signal 'error
459 ,@(mapcar* (lambda (symbol listel) 447 (list
460 (list symbol (nth 1 listel))) 448 "should be a list of 2-5 elements"
461 valvarlist specifier-list) 449 listel)))
462 ,@(mapcar* (lambda (symbol listel) 450 ;; VALUE, TAG-SET and HOW-TO-ADD are
463 (list symbol (nth 2 listel))) 451 ;; referenced only once, so we needn't
464 domvarlist specifier-list) 452 ;; frob them with gensym.
465 ,@(mapcar* (lambda (symbol specifier domain) 453 (list (gensym-frob (nth 0 listel) "specifier-")
466 (list symbol `(specifier-spec-list 454 (list (nth 1 listel))
467 ,specifier ,domain))) 455 (gensym-frob (nth 2 listel) "locale-")
468 oldvarlist specvarlist domvarlist)) 456 (list (nth 3 listel))
469 (unwind-protect 457 (list (nth 4 listel))))
470 (progn 458 specifier-list))
471 ,@(mapcar* (lambda (specifier value domain) 459 ;; OLDVALLIST is a list of (OLDVALSYM OLDVALFORM)
472 `(add-spec-to-specifier 460 (oldvallist (mapcar #'(lambda (varel)
473 ,specifier ,value ,domain 461 (list (gensym "old-")
474 nil 'prepend)) 462 `(specifier-spec-list
475 specvarlist valvarlist domvarlist) 463 ,(car (nth 0 varel))
476 ,@body) 464 ,(car (nth 2 varel)))))
477 ,@(apply 465 varlist)))
478 #'nconc 466 ;; Bind the appropriate variables.
479 ;; Reverse the unwinding order for marginal safety gain. 467 `(let* (,@(mapcan #'(lambda (varel)
480 (nreverse 468 (delq nil (mapcar
481 (mapcar* 469 #'(lambda (varcons)
482 (lambda (specifier domain oldvalue) 470 (and (cdr varcons) varcons))
483 `((remove-specifier ,specifier ,domain) 471 varel)))
484 (add-spec-list-to-specifier ,specifier ,oldvalue))) 472 varlist)
485 specvarlist domvarlist oldvarlist))))))) 473 ,@oldvallist)
486 474 (unwind-protect
487 ;; (cl-prettyexpand '(let-specifier ((modeline-shadow-thickness 0 (selected-window)) (fubar 0 baz)) (sit-for 1))) 475 (progn
476 ,@(mapcar #'(lambda (varel)
477 `(add-spec-to-specifier
478 ,(car (nth 0 varel)) ,(car (nth 1 varel))
479 ,(car (nth 2 varel)) ,(car (nth 3 varel))
480 ,(car (nth 4 varel))))
481 varlist)
482 ,@body)
483 ;; Reverse the unwinding order, so that using the same
484 ;; specifier multiple times works.
485 ,@(apply #'nconc (nreverse (mapcar*
486 #'(lambda (oldval varel)
487 `((remove-specifier
488 ,(car (nth 0 varel))
489 ,(car (nth 2 varel)))
490 (add-spec-list-to-specifier
491 ,(car (nth 0 varel))
492 ,(car oldval))))
493 oldvallist varlist))))))))
494
495 ;; Evaluate this for testing:
496 ; (cl-prettyexpand '(let-specifier ((modeline-shadow-thickness 0 (selected-window) 'x) (fubar (value) baz)) (sit-for 1)))
488 497
489 (define-specifier-tag 'win 'device-on-window-system-p) 498 (define-specifier-tag 'win 'device-on-window-system-p)
490 499
491 ;; Add tags for device types that don't have support compiled 500 ;; Add tags for device types that don't have support compiled
492 ;; into the binary that we're about to dump. This will prevent 501 ;; into the binary that we're about to dump. This will prevent