temacs crashes as follows for me with this configuration. Lstream_really_write(lstream * 0x0113bca4, const unsigned char * 0x02aca240, int 0) line 402 + 9 bytes Lstream_flush(lstream * 0x02aca240) line 442 + 20 bytes coding_flusher(lstream * 0x02a42b60) line 1967 + 13 bytes Lstream_really_write(lstream * 0x0113b881, const unsigned char * 0x02a42b60, int 0) line 403 + 3 bytes finalize_lstream(void * 0x01043e30, int 44313440) line 95 mc_finalize() line 1565 + 461 bytes gc_incremental() line 1945 + 737 bytes Ffuncall(int 17123518, long * 0x00000002) line 3826 execute_optimized_program(const unsigned char * 0x0082cbd4, int 174, long * 0x026ce55c) line 862 + 11 bytes Ffuncall(int 17123518, long * 0x00000001) line 3929 + 846 bytes execute_optimized_program(const unsigned char * 0x0082cc98, int 172, long * 0x027cb1dc) line 862 + 11 bytes Ffuncall(int 17123518, long * 0x00000001) line 3929 + 846 bytes execute_optimized_program(const unsigned char * 0x0082cd58, int 171, long * 0x029c4008) line 862 + 11 bytes Ffuncall(int 17123518, long * 0x00000001) line 3929 + 846 bytes execute_optimized_program(const unsigned char * 0x0082ce18, int 168, long * 0x026ce55c) line 862 + 11 bytes Ffuncall(int 17123518, long * 0x00000002) line 3929 + 846 bytes execute_optimized_program(const unsigned char * 0x0082cedc, int 164, long * 0x02a3337c) line 862 + 11 bytes Ffuncall(int 17123518, long * 0x00000001) line 3929 + 846 bytes execute_optimized_program(const unsigned char * 0x0082cf9c, int 161, long * 0x026ce55c) line 862 + 11 bytes Ffuncall(int 17123518, long * 0x00000002) line 3929 + 846 bytes execute_optimized_program(const unsigned char * 0x0082d060, int 153, long * 0x027c2a94) line 862 + 11 bytes Ffuncall(int 17123518, long * 0x00000003) line 3929 + 846 bytes execute_optimized_program(const unsigned char * 0x0082d130, int 150, long * 0x027cad28) line 862 + 11 bytes Ffuncall(int 17123518, long * 0x00000002) line 3929 + 846 bytes execute_optimized_program(const unsigned char * 0x0082d1f8, int 148, long * 0x02230b30) line 862 + 11 bytes Ffuncall(int 17123518, long * 0x00000001) line 3929 + 846 bytes execute_optimized_program(const unsigned char * 0x0082d2bc, int 145, long * 0x026ce55c) line 862 + 11 bytes Ffuncall(int 17123518, long * 0x00000002) line 3929 + 846 bytes execute_optimized_program(const unsigned char * 0x01e1ce70, int 31575712, long * 0x01edc540) line 862 + 11 bytes 01ec6bb8() 01d5c888() Best regards, Adrian OS version: Microsoft Windows XP [Version 5.1.2600] OS: Windows_NT XEmacs 21.5-b24 "dandelion" (+CVS-20051219) configured for `i586-pc-win32'. Building XEmacs using "NMAKE". Building XEmacs using make flags " ". Building XEmacs in source tree "c:\\Hacking\\cvs.xemacs.org\\XEmacs\\xemacs-21.5-clean". For src, using compiler "cl -nologo -W3 -DSTRICT -Zi -O2 -G5 -Ob2 -MDd -c -Ic:\Hacking\cvs.xemacs.org\XEmacs\xemacs-21.5-clean\nt\inc -Ic:\Hacking\cvs.xemacs.org\XEmacs\xemacs-21.5-clean\src -I"c:\Hacking\libs4xemacs\xpm-3.4k" -I"c:\Hacking\libs4xemacs\xpm-3.4k\lib" -I"c:\Hacking\libs4xemacs\libpng-1.0.2" -I"c:\Hacking\libs4xemacs\zlib" -I"c:\Hacking\libs4xemacs\tiff-v3.4\libtiff" -I"c:\Hacking\libs4xemacs\jpeg-6b" -I"c:\Hacking\libs4xemacs\compface" -I"c:\Hacking\libs4xemacs\zlib" -DHAVE_MS_WINDOWS -DHAVE_MENUBARS -DHAVE_SCROLLBARS -DHAVE_TOOLBARS -DHAVE_WIDGETS -DHAVE_DIALOGS -DHAVE_XPM -DFOR_MSW -DHAVE_GIF -DHAVE_PNG -DHAVE_TIFF -DHAVE_JPEG -DHAVE_XFACE -DHAVE_ZLIB -DHAVE_NATIVE_SOUND -DMULE -DPDUMP -DNEW_GC -DUSE_KKCC -DMC_ALLOC -DSYSTEM_MALLOC -DDEBUG_XEMACS -D_DEBUG -DWIN32_LEAN_AND_MEAN -DWIN32_NATIVE -Demacs -DHAVE_CONFIG_H -DPATH_VERSION=\"21.5-b24\" -DPATH_PROGNAME=\"xemacs\" -DEMACS_VERSION=\"21.5-b24\" -DEMACS_PROGNAME=\"xemacs\" -DSTACK_TRACE_EYE_CATCHER=xemacs_21_5_b24_i586_pc_win32 -DPATH_PREFIX=\"..\" -DEMACS_MAJOR_VERSION=21 -DEMACS_MINOR_VERSION=5 -DEMACS_BETA_VERSION=24 -DXEMACS_CODENAME=\""dandelion"\" -DXEMACS_EXTRA_NAME=\"(+CVS-20051219)\" -DEMACS_CONFIGURATION=\"i586-pc-win32\" -DPATH_PACKAGEPATH=\""~\\.xemacs;;c:\\Program Files\\XEmacs\\site-packages;c:\\Program Files\\XEmacs\\mule-packages;c:\\Program Files\\XEmacs\\xemacs-packages"\"". For lib-src, using compiler "cl -nologo -W3 -DSTRICT -Zi -O2 -G5 -Ob2 -MDd -Ic:\Hacking\cvs.xemacs.org\XEmacs\xemacs-21.5-clean\lib-src -Ic:\Hacking\cvs.xemacs.org\XEmacs\xemacs-21.5-clean\src -DHAVE_CONFIG_H -DWIN32_NATIVE". Installing XEmacs in "c:\\Program Files\\XEmacs\\XEmacs-21.5-b24". Package path is "~\\.xemacs;;c:\\Program Files\\XEmacs\\site-packages;c:\\Program Files\\XEmacs\\mule-packages;c:\\Program Files\\XEmacs\\xemacs-packages". Compiling in support for Microsoft Windows native GUI. Compiling in international (MULE) support. Compiling in support for XPM images. Compiling in support for GIF images. Compiling in support for PNG images. Compiling in support for TIFF images. Compiling in support for JPEG images. Compiling in support for X-Face message headers. Compiling in support for GZIP compression/decompression. Compiling in support for toolbars. Compiling in support for dialogs. Compiling in support for widgets. Compiling in support for native sounds. Using portable dumper. Using system malloc. Using DLL version of C runtime library. Compiling in debugging support (no slowdown). Compiling with optimization. Using new experimental GC algorithms. Using new experimental allocator. Using new experimental incremental garbage collector. \s-+.+\)*\|^Note:\|Installing\|[Ff]ile(s) copied\|\s-+tests\s-+\|^[A-Z] [^ ]+$\|^Wrong number of arguments:\|^ \*\* " cd c:\Hacking\cvs.xemacs.org\XEmacs\xemacs-21.5-clean\ Compilation started at Tue Dec 20 21:58:40 2005 +0100 (W. Europe Standard Time) ? gunzip-error.txt ? man/lispref/errors.texi.new ? nt/xemacs-21.5-clean-make-all-texinfo-error.err P version.sh M lisp/cmdloop.el M src/frame-msw.c cvs server: Updating tests cvs server: Updating tests/DLL M tests/automated/region-tests.el Compilation finished at Tue Dec 20 21:59:41 \s-+.+\)*\|^Note:\|Installing\|[Ff]ile(s) copied\|\s-+tests\s-+\|^[A-Z] [^ ]+$\|^Wrong number of arguments:\|^ \*\* " cd c:\Hacking\cvs.xemacs.org\XEmacs\xemacs-21.5-clean\nt\ nmake /f xemacs.mak all Compilation started at Tue Dec 20 22:12:18 2005 +0100 (W. Europe Standard Time) Installing XEmacs in "c:\\Program Files\\XEmacs\\XEmacs-21.5-b24". 1 file(s) copied. 1 File(s) copied 1 File(s) copied Using load-path (c:\Hacking\cvs.xemacs.org\XEmacs\xemacs-21.5-clean\lisp\) Using module-load-path (c:\Hacking\cvs.xemacs.org\XEmacs\xemacs-21.5-clean\modules) Generating autoloads for lisp/next-error.el... Fatal error. byte-compile-unwind-protect((unwind-protect (progn (fset (quote frob-face-inst-list) (function (lambda (locale inst-list prop devtype-spec) "\nCommon Lisp lambda list:\n (lambda LOCALE INST-LIST PROP DEVTYPE-SPEC)\n\n" (block frob-face-inst-list (let* ((ffpdev Face-frob-property-device-considered-current) (results (loop for (tag-set . x) in inst-list for devtype = (derive-device-type-from-locale-and-tag-set locale tag-set devtype-spec ffpdev) if devtype if (let* ((mapper (if (functionp frob-mapping) frob-mapping (plist-get frob-mapping devtype))) (result (cond ((vectorp x) (let ((change-to (cdr (assoc x standard-face-mapping)))) (cond ((or change-to (null (length x))) (list (cons tag-set (cond ((eq change-to t) x) (change-to) (t x))))) (t (let* ((subprop (if (> (length x) 1) (elt x 1) prop)) (subinsts (frob-face-inst-list locale (cdar (specifier-spec-list (face-property (elt x 0) subprop))) subprop devtype-spec))) (add-tag-to-inst-list subinsts tag-set)))))) (t (let ((value (if (eq devtype-spec (quote tty)) (funcall mapper x) (funcall mapper x (derive-domain-from-locale locale devtype-spec ffpdev))))) (and (nil-instantiator-ok value devtype-spec) (list (cons tag-set value)))))))) (if (and (eq (quote tty) devtype-spec) (not (or (eq (quote tty) tag-set) (memq (quote tty) tag-set)))) (nconc (add-tag-to-inst-list result (quote tty)) (list (cons tag-set x))) result)) nconc it))) (delete-duplicates results:test (function equal))))))) (let* ((--letf-bound--25565 (fboundp (quote frob-locale))) (--letf-save--25564 (and --letf-bound--25565 (symbol-function (quote frob-locale))))) (unwind-protect (progn (fset (quote frob-locale) (function (lambda (sp locale inst-list thunk) "\nCommon Lisp lambda list:\n (lambda SP LOCALE INST-LIST THUNK)\n\n" (block frob-locale (let ((newinst (frob-face-inst-list locale inst-list (car thunk) (cdr thunk)))) (remove-specifier sp locale tag-set exact-p) (add-spec-list-to-specifier sp (list (cons locale newinst)))) nil)))) (let* ((--letf-bound--25569 (fboundp (quote map-over-locales))) (--letf-save--25568 (and --letf-bound--25569 (symbol-function (quote map-over-locales))))) (unwind-protect (progn (fset (quote map-over-locales) (function (lambda (locale) "\nCommon Lisp lambda list:\n (lambda LOCALE)\n\n" (block map-over-locales (map-specifier (get face win-prop) (function frob-locale) locale (cons win-prop (quote window-system)) tag-set exact-p) (loop for prop in tty-props do (map-specifier (get face prop) (function frob-locale) locale (cons prop (quote tty)) tag-set exact-p)))))) (let* ((ffpdev Face-frob-property-device-considered-current) (do-later-stages (or (global-locale locale) (valid-specifier-domain-p locale) (bufferp locale))) (domain (and do-later-stages (derive-domain-from-locale locale (quote window-system) ffpdev))) (check-differences (and unfrobbed-face frobbed-face domain (not (memq (face-name face) (quote (default bold italic bold-italic)))))) (orig-instance (and check-differences (face-property-instance face win-prop domain)))) (setq face (get-face face)) (map-over-locales locale) (if do-later-stages (progn (if (global-locale locale) (setq locale (quote global))) (let (do-something) (cl-block-wrapper (catch (quote --cl-block-nil--) (let* ((G25570 (cons win-prop tty-props)) (prop nil) (propspec nil) (devtype-spec nil)) (while (consp G25570) (setq prop (car G25570)) (setq propspec (get face prop)) (setq devtype-spec (if (eq prop win-prop) (quote window-system) (quote tty))) (if propspec (progn (or (specifier-spec-list propspec locale) (let ((doit (derive-specifier-specs-from-locale propspec locale devtype-spec ffpdev (and (not tag-set) (not exact-p))))) (if (and (not doit) (eq locale (quote global))) (error "No fallback for specifier property %s in face %s???" prop face)) (when doit (add-spec-list-to-specifier propspec (list (cons locale (add-tag-to-inst-list doit (append (if (listp tag-set) tag-set (list tag-set)) (if (eq devtype-spec (quote tty)) (quote (tty)))))))) (setq do-something t)))))) (setq G25570 (cdr G25570))) nil))) (if do-something (map-over-locales (or (global-locale locale) locale)))) (if (and check-differences (let ((new-instance (face-property-instance face win-prop domain))) (and (equal orig-instance new-instance) (equal orig-instance (face-property-instance unfrobbed-face win-prop domain))))) (set-face-property face win-prop (vector frobbed-face) (or (global-locale locale) locale) tag-set)))))) (if --letf-bound--25569 (fset (quote map-over-locales) --letf-save--25568) (fmakunbound (quote map-over-locales)))))) (if --letf-bound--25565 (fset (quote frob-locale) --letf-save--25564) (fmakunbound (quote frob-locale)))))) (if --letf-bound--25561 (fset (quote frob-face-inst-list) --letf-save--25560) (fmakunbound (quote frob-face-inst-list))))) byte-compile-form((unwind-protect (progn (fset (quote frob-face-inst-list) (function (lambda (locale inst-list prop devtype-spec) "\nCommon Lisp lambda list:\n (lambda LOCALE INST-LIST PROP DEVTYPE-SPEC)\n\n" (block frob-face-inst-list (let* ((ffpdev Face-frob-property-device-considered-current) (results (loop for (tag-set . x) in inst-list for devtype = (derive-device-type-from-locale-and-tag-set locale tag-set devtype-spec ffpdev) if devtype if (let* ((mapper (if (functionp frob-mapping) frob-mapping (plist-get frob-mapping devtype))) (result (cond ((vectorp x) (let ((change-to (cdr (assoc x standard-face-mapping)))) (cond ((or change-to (null (length x))) (list (cons tag-set (cond ((eq change-to t) x) (change-to) (t x))))) (t (let* ((subprop (if (> (length x) 1) (elt x 1) prop)) (subinsts (frob-face-inst-list locale (cdar (specifier-spec-list (face-property (elt x 0) subprop))) subprop devtype-spec))) (add-tag-to-inst-list subinsts tag-set)))))) (t (let ((value (if (eq devtype-spec (quote tty)) (funcall mapper x) (funcall mapper x (derive-domain-from-locale locale devtype-spec ffpdev))))) (and (nil-instantiator-ok value devtype-spec) (list (cons tag-set value)))))))) (if (and (eq (quote tty) devtype-spec) (not (or (eq (quote tty) tag-set) (memq (quote tty) tag-set)))) (nconc (add-tag-to-inst-list result (quote tty)) (list (cons tag-set x))) result)) nconc it))) (delete-duplicates results :test (function equal))))))) (let* ((--letf-bound--25565 (fboundp (quote frob-locale))) (--letf-save--25564 (and --letf-bound--25565 (symbol-function (quote frob-locale))))) (unwind-protect (progn (fset (quote frob-locale) (function (lambda (sp locale inst-list thunk) "\nCommon Lisp lambda list:\n (lambda SP LOCALE INST-LIST THUNK)\n\n" (block frob-locale (let ((newinst (frob-face-inst-list locale inst-list (car thunk) (cdr thunk)))) (remove-specifier sp locale tag-set exact-p) (add-spec-list-to-specifier sp (list (cons locale newinst)))) nil)))) (let* ((--letf-bound--25569 (fboundp (quote map-over-locales))) (--letf-save--25568 (and --letf-bound--25569 (symbol-function (quote map-over-locales))))) (unwind-protect (progn (fset (quote map-over-locales) (function (lambda (locale) "\nCommon Lisp lambda list:\n (lambda LOCALE)\n\n" (block map-over-locales (map-specifier (get face win-prop) (function frob-locale) locale (cons win-prop (quote window-system)) tag-set exact-p) (loop for prop in tty-props do (map-specifier (get face prop) (function frob-locale) locale (cons prop (quote tty)) tag-set exact-p)))))) (let* ((ffpdev Face-frob-property-device-considered-current) (do-later-stages (or (global-locale locale) (valid-specifier-domain-p locale) (bufferp locale))) (domain (and do-later-stages (derive-domain-from-locale locale (quote window-system) ffpdev))) (check-differences (and unfrobbed-face frobbed-face domain (not (memq (face-name face) (quote (default bold italic bold-italic)))))) (orig-instance (and check-differences (face-property-instance face win-prop domain)))) (setq face (get-face face)) (map-over-locales locale) (if do-later-stages (progn (if (global-locale locale) (setq locale (quote global))) (let (do-something) (cl-block-wrapper (catch (quote --cl-block-nil--) (let* ((G25570 (cons win-prop tty-props)) (prop nil) (propspec nil) (devtype-spec nil)) (while (consp G25570) (setq prop (car G25570)) (setq propspec (get face prop)) (setq devtype-spec (if (eq prop win-prop) (quote window-system) (quote tty))) (if propspec (progn (or (specifier-spec-list propspec locale) (let ((doit (derive-specifier-specs-from-locale propspec locale devtype-spec ffpdev (and (not tag-set) (not exact-p))))) (if (and (not doit) (eq locale (quote global))) (error "No fallback for specifier property %s in face %s???" prop face)) (when doit (add-spec-list-to-specifier propspec (list (cons locale (add-tag-to-inst-list doit (append (if (listp tag-set) tag-set (list tag-set)) (if (eq devtype-spec (quote tty)) (quote (tty)))))))) (setq do-something t)))))) (setq G25570 (cdr G25570))) nil))) (if do-something (map-over-locales (or (global-locale locale) locale)))) (if (and check-differences (let ((new-instance (face-property-instance face win-prop domain))) (and (equal orig-instance new-instance) (equal orig-instance (face-property-instance unfrobbed-face win-prop domain))))) (set-face-property face win-prop (vector frobbed-face) (or (global-locale locale) locale) tag-set)))))) (if --letf-bound--25569 (fset (quote map-over-locales) --letf-save--25568) (fmakunbound (quote map-over-locales)))))) (if --letf-bound--25565 (fset (quote frob-locale) --letf-save--25564) (fmakunbound (quote frob-locale)))))) (if --letf-bound--25561 (fset (quote frob-face-inst-list) --letf-save--25560) (fmakunbound (quote frob-face-inst-list)))) nil) byte-compile-body(((unwind-protect (progn (fset (quote frob-face-inst-list) (function (lambda (locale inst-list prop devtype-spec) "\nCommon Lisp lambda list:\n (lambda LOCALE INST-LIST PROP DEVTYPE-SPEC)\n\n" (block frob-face-inst-list (let* ((ffpdev Face-frob-property-device-considered-current) (results (loop for (tag-set . x) in inst-list for devtype = (derive-device-type-from-locale-and-tag-set locale tag-set devtype-spec ffpdev) if devtype if (let* ((mapper (if (functionp frob-mapping) frob-mapping (plist-get frob-mapping devtype))) (result (cond ((vectorp x) (let ((change-to (cdr (assoc x standard-face-mapping)))) (cond ((or change-to (null (length x))) (list (cons tag-set (cond ((eq change-to t) x) (change-to) (t x))))) (t (let* ((subprop (if (> (length x) 1) (elt x 1) prop)) (subinsts (frob-face-inst-list locale (cdar (specifier-spec-list (face-property (elt x 0) subprop))) subprop devtype-spec))) (add-tag-to-inst-list subinsts tag-set)))))) (t (let ((value (if (eq devtype-spec (quote tty)) (funcall mapper x) (funcall mapper x (derive-domain-from-locale locale devtype-spec ffpdev))))) (and (nil-instantiator-ok value devtype-spec) (list (cons tag-set value)))))))) (if (and (eq (quote tty) devtype-spec) (not (or (eq (quote tty) tag-set) (memq (quote tty) tag-set)))) (nconc (add-tag-to-inst-list result (quote tty)) (list (cons tag-set x))) result)) nconc it))) (delete-duplicates results :test (function equal))))))) (let* ((--letf-bound--25565 (fboundp (quote frob-locale))) (--letf-save--25564 (and --letf-bound--25565 (symbol-function (quote frob-locale))))) (unwind-protect (progn (fset (quote frob-locale) (function (lambda (sp locale inst-list thunk) "\nCommon Lisp lambda list:\n (lambda SP LOCALE INST-LIST THUNK)\n\n" (block frob-locale (let ((newinst (frob-face-inst-list locale inst-list (car thunk) (cdr thunk)))) (remove-specifier sp locale tag-set exact-p) (add-spec-list-to-specifier sp (list (cons locale newinst)))) nil)))) (let* ((--letf-bound--25569 (fboundp (quote map-over-locales))) (--letf-save--25568 (and --letf-bound--25569 (symbol-function (quote map-over-locales))))) (unwind-protect (progn (fset (quote map-over-locales) (function (lambda (locale) "\nCommon Lisp lambda list:\n (lambda LOCALE)\n\n" (block map-over-locales (map-specifier (get face win-prop) (function frob-locale) locale (cons win-prop (quote window-system)) tag-set exact-p) (loop for prop in tty-props do (map-specifier (get face prop) (function frob-locale) locale (cons prop (quote tty)) tag-set exact-p)))))) (let* ((ffpdev Face-frob-property-device-considered-current) (do-later-stages (or (global-locale locale) (valid-specifier-domain-p locale) (bufferp locale))) (domain (and do-later-stages (derive-domain-from-locale locale (quote window-system) ffpdev))) (check-differences (and unfrobbed-face frobbed-face domain (not (memq (face-name face) (quote (default bold italic bold-italic)))))) (orig-instance (and check-differences (face-property-instance face win-prop domain)))) (setq face (get-face face)) (map-over-locales locale) (if do-later-stages (progn (if (global-locale locale) (setq locale (quote global))) (let (do-something) (cl-block-wrapper (catch (quote --cl-block-nil--) (let* ((G25570 (cons win-prop tty-props)) (prop nil) (propspec nil) (devtype-spec nil)) (while (consp G25570) (setq prop (car G25570)) (setq propspec (get face prop)) (setq devtype-spec (if (eq prop win-prop) (quote window-system) (quote tty))) (if propspec (progn (or (specifier-spec-list propspec locale) (let ((doit (derive-specifier-specs-from-locale propspec locale devtype-spec ffpdev (and (not tag-set) (not exact-p))))) (if (and (not doit) (eq locale (quote global))) (error "No fallback for specifier property %s in face %s???" prop face)) (when doit (add-spec-list-to-specifier propspec (list (cons locale (add-tag-to-inst-list doit (append (if (listp tag-set) tag-set (list tag-set)) (if (eq devtype-spec (quote tty)) (quote (tty)))))))) (setq do-something t)))))) (setq G25570 (cdr G25570))) nil))) (if do-something (map-over-locales (or (global-locale locale) locale)))) (if (and check-differences (let ((new-instance (face-property-instance face win-prop domain))) (and (equal orig-instance new-instance) (equal orig-instance (face-property-instance unfrobbed-face win-prop domain))))) (set-face-property face win-prop (vector frobbed-face) (or (global-locale locale) locale) tag-set)))))) (if --letf-bound--25569 (fset (quote map-over-locales) --letf-save--25568) (fmakunbound (quote map-over-locales)))))) (if --letf-bound--25565 (fset (quote frob-locale) --letf-save--25564) (fmakunbound (quote frob-locale)))))) (if --letf-bound--25561 (fset (quote frob-face-inst-list) --letf-save--25560) (fmakunbound (quote frob-face-inst-list))))) nil) byte-compile-let*((let* ((--letf-bound--25561 (fboundp (quote frob-face-inst-list))) (--letf-save--25560 (and --letf-bound--25561 (symbol-function (quote frob-face-inst-list))))) (unwind-protect (progn (fset (quote frob-face-inst-list) (function (lambda (locale inst-list prop devtype-spec) "\nCommon Lisp lambda list:\n (lambda LOCALE INST-LIST PROP DEVTYPE-SPEC)\n\n" (block frob-face-inst-list (let* ((ffpdev Face-frob-property-device-considered-current) (results (loop for (tag-set . x) in inst-list for devtype = (derive-device-type-from-locale-and-tag-set locale tag-set devtype-spec ffpdev) if devtype if (let* ((mapper (if (functionp frob-mapping) frob-mapping (plist-get frob-mapping devtype))) (result (cond ((vectorp x) (let ((change-to (cdr (assoc x standard-face-mapping)))) (cond ((or change-to (null (length x))) (list (cons tag-set (cond ((eq change-to t) x) (change-to) (t x))))) (t (let* ((subprop (if (> (length x) 1) (elt x 1) prop)) (subinsts (frob-face-inst-list locale (cdar (specifier-spec-list (face-property (elt x 0) subprop))) subprop devtype-spec))) (add-tag-to-inst-list subinsts tag-set)))))) (t (let ((value (if (eq devtype-spec (quote tty)) (funcall mapper x) (funcall mapper x (derive-domain-from-locale locale devtype-spec ffpdev))))) (and (nil-instantiator-ok value devtype-spec) (list (cons tag-set value)))))))) (if (and (eq (quote tty) devtype-spec) (not (or (eq (quote tty) tag-set) (memq (quote tty) tag-set)))) (nconc (add-tag-to-inst-list result (quote tty)) (list (cons tag-set x))) result)) nconc it))) (delete-duplicates results:test (function equal))))))) (let* ((--letf-bound--25565 (fboundp (quote frob-locale))) (--letf-save--25564 (and --letf-bound--25565 (symbol-function (quote frob-locale))))) (unwind-protect (progn (fset (quote frob-locale) (function (lambda (sp locale inst-list thunk) "\nCommon Lisp lambda list:\n (lambda SP LOCALE INST-LIST THUNK)\n\n" (block frob-locale (let ((newinst (frob-face-inst-list locale inst-list (car thunk) (cdr thunk)))) (remove-specifier sp locale tag-set exact-p) (add-spec-list-to-specifier sp (list (cons locale newinst)))) nil)))) (let* ((--letf-bound--25569 (fboundp (quote map-over-locales))) (--letf-save--25568 (and --letf-bound--25569 (symbol-function (quote map-over-locales))))) (unwind-protect (progn (fset (quote map-over-locales) (function (lambda (locale) "\nCommon Lisp lambda list:\n (lambda LOCALE)\n\n" (block map-over-locales (map-specifier (get face win-prop) (function frob-locale) locale (cons win-prop (quote window-system)) tag-set exact-p) (loop for prop in tty-props do (map-specifier (get face prop) (function frob-locale) locale (cons prop (quote tty)) tag-set exact-p)))))) (let* ((ffpdev Face-frob-property-device-considered-current) (do-later-stages (or (global-locale locale) (valid-specifier-domain-p locale) (bufferp locale))) (domain (and do-later-stages (derive-domain-from-locale locale (quote window-system) ffpdev))) (check-differences (and unfrobbed-face frobbed-face domain (not (memq (face-name face) (quote (default bold italic bold-italic)))))) (orig-instance (and check-differences (face-property-instance face win-prop domain)))) (setq face (get-face face)) (map-over-locales locale) (if do-later-stages (progn (if (global-locale locale) (setq locale (quote global))) (let (do-something) (cl-block-wrapper (catch (quote --cl-block-nil--) (let* ((G25570 (cons win-prop tty-props)) (prop nil) (propspec nil) (devtype-spec nil)) (while (consp G25570) (setq prop (car G25570)) (setq propspec (get face prop)) (setq devtype-spec (if (eq prop win-prop) (quote window-system) (quote tty))) (if propspec (progn (or (specifier-spec-list propspec locale) (let ((doit (derive-specifier-specs-from-locale propspec locale devtype-spec ffpdev (and (not tag-set) (not exact-p))))) (if (and (not doit) (eq locale (quote global))) (error "No fallback for specifier property %s in face %s???" prop face)) (when doit (add-spec-list-to-specifier propspec (list (cons locale (add-tag-to-inst-list doit (append (if (listp tag-set) tag-set (list tag-set)) (if (eq devtype-spec (quote tty)) (quote (tty)))))))) (setq do-something t)))))) (setq G25570 (cdr G25570))) nil))) (if do-something (map-over-locales (or (global-locale locale) locale)))) (if (and check-differences (let ((new-instance (face-property-instance face win-prop domain))) (and (equal orig-instance new-instance) (equal orig-instance (face-property-instance unfrobbed-face win-prop domain))))) (set-face-property face win-prop (vector frobbed-face) (or (global-locale locale) locale) tag-set)))))) (if --letf-bound--25569 (fset (quote map-over-locales) --letf-save--25568) (fmakunbound (quote map-over-locales)))))) (if --letf-bound--25565 (fset (quote frob-locale) --letf-save--25564) (fmakunbound (quote frob-locale)))))) (if --letf-bound--25561 (fset (quote frob-face-inst-list) --letf-save--25560) (fmakunbound (quote frob-face-inst-list)))))) byte-compile-form((let* ((--letf-bound--25561 (fboundp (quote frob-face-inst-list))) (--letf-save--25560 (and --letf-bound--25561 (symbol-function (quote frob-face-inst-list))))) (unwind-protect (progn (fset (quote frob-face-inst-list) (function (lambda (locale inst-list prop devtype-spec) "\nCommon Lisp lambda list:\n (lambda LOCALE INST-LIST PROP DEVTYPE-SPEC)\n\n" (block frob-face-inst-list (let* ((ffpdev Face-frob-property-device-considered-current) (results (loop for (tag-set . x) in inst-list for devtype = (derive-device-type-from-locale-and-tag-set locale tag-set devtype-spec ffpdev) if devtype if (let* ((mapper (if (functionp frob-mapping) frob-mapping (plist-get frob-mapping devtype))) (result (cond ((vectorp x) (let ((change-to (cdr (assoc x standard-face-mapping)))) (cond ((or change-to (null (length x))) (list (cons tag-set (cond ((eq change-to t) x) (change-to) (t x))))) (t (let* ((subprop (if (> (length x) 1) (elt x 1) prop)) (subinsts (frob-face-inst-list locale (cdar (specifier-spec-list (face-property (elt x 0) subprop))) subprop devtype-spec))) (add-tag-to-inst-list subinsts tag-set)))))) (t (let ((value (if (eq devtype-spec (quote tty)) (funcall mapper x) (funcall mapper x (derive-domain-from-locale locale devtype-spec ffpdev))))) (and (nil-instantiator-ok value devtype-spec) (list (cons tag-set value)))))))) (if (and (eq (quote tty) devtype-spec) (not (or (eq (quote tty) tag-set) (memq (quote tty) tag-set)))) (nconc (add-tag-to-inst-list result (quote tty)) (list (cons tag-set x))) result)) nconc it))) (delete-duplicates results:test (function equal))))))) (let* ((--letf-bound--25565 (fboundp (quote frob-locale))) (--letf-save--25564 (and --letf-bound--25565 (symbol-function (quote frob-locale))))) (unwind-protect (progn (fset (quote frob-locale) (function (lambda (sp locale inst-list thunk) "\nCommon Lisp lambda list:\n (lambda SP LOCALE INST-LIST THUNK)\n\n" (block frob-locale (let ((newinst (frob-face-inst-list locale inst-list (car thunk) (cdr thunk)))) (remove-specifier sp locale tag-set exact-p) (add-spec-list-to-specifier sp (list (cons locale newinst)))) nil)))) (let* ((--letf-bound--25569 (fboundp (quote map-over-locales))) (--letf-save--25568 (and --letf-bound--25569 (symbol-function (quote map-over-locales))))) (unwind-protect (progn (fset (quote map-over-locales) (function (lambda (locale) "\nCommon Lisp lambda list:\n (lambda LOCALE)\n\n" (block map-over-locales (map-specifier (get face win-prop) (function frob-locale) locale (cons win-prop (quote window-system)) tag-set exact-p) (loop for prop in tty-props do (map-specifier (get face prop) (function frob-locale) locale (cons prop (quote tty)) tag-set exact-p)))))) (let* ((ffpdev Face-frob-property-device-considered-current) (do-later-stages (or (global-locale locale) (valid-specifier-domain-p locale) (bufferp locale))) (domain (and do-later-stages (derive-domain-from-locale locale (quote window-system) ffpdev))) (check-differences (and unfrobbed-face frobbed-face domain (not (memq (face-name face) (quote (default bold italic bold-italic)))))) (orig-instance (and check-differences (face-property-instance face win-prop domain)))) (setq face (get-face face)) (map-over-locales locale) (if do-later-stages (progn (if (global-locale locale) (setq locale (quote global))) (let (do-something) (cl-block-wrapper (catch (quote --cl-block-nil--) (let* ((G25570 (cons win-prop tty-props)) (prop nil) (propspec nil) (devtype-spec nil)) (while (consp G25570) (setq prop (car G25570)) (setq propspec (get face prop)) (setq devtype-spec (if (eq prop win-prop) (quote window-system) (quote tty))) (if propspec (progn (or (specifier-spec-list propspec locale) (let ((doit (derive-specifier-specs-from-locale propspec locale devtype-spec ffpdev (and (not tag-set) (not exact-p))))) (if (and (not doit) (eq locale (quote global))) (error "No fallback for specifier property %s in face %s???" prop face)) (when doit (add-spec-list-to-specifier propspec (list (cons locale (add-tag-to-inst-list doit (append (if (listp tag-set) tag-set (list tag-set)) (if (eq devtype-spec (quote tty)) (quote (tty)))))))) (setq do-something t)))))) (setq G25570 (cdr G25570))) nil))) (if do-something (map-over-locales (or (global-locale locale) locale)))) (if (and check-differences (let ((new-instance (face-property-instance face win-prop domain))) (and (equal orig-instance new-instance) (equal orig-instance (face-property-instance unfrobbed-face win-prop domain))))) (set-face-property face win-prop (vector frobbed-face) (or (global-locale locale) locale) tag-set)))))) (if --letf-bound--25569 (fset (quote map-over-locales) --letf-save--25568) (fmakunbound (quote map-over-locales)))))) (if --letf-bound--25565 (fset (quote frob-locale) --letf-save--25564) (fmakunbound (quote frob-locale)))))) (if --letf-bound--25561 (fset (quote frob-face-inst-list) --letf-save--25560) (fmakunbound (quote frob-face-inst-list))))) nil) byte-compile-body(((fset (quote global-locale) (function (lambda (locale) "\nCommon Lisp lambda list:\n (lambda LOCALE)\n\n" (block global-locale (and (memq locale (quote (all nil global))) (quote global)))))) (let* ((--letf-bound--25561 (fboundp (quote frob-face-inst-list))) (--letf-save--25560 (and --letf-bound--25561 (symbol-function (quote frob-face-inst-list))))) (unwind-protect (progn (fset (quote frob-face-inst-list) (function (lambda (locale inst-list prop devtype-spec) "\nCommon Lisp lambda list:\n (lambda LOCALE INST-LIST PROP DEVTYPE-SPEC)\n\n" (block frob-face-inst-list (let* ((ffpdev Face-frob-property-device-considered-current) (results (loop for (tag-set . x) in inst-list for devtype = (derive-device-type-from-locale-and-tag-set locale tag-set devtype-spec ffpdev) if devtype if (let* ((mapper (if (functionp frob-mapping) frob-mapping (plist-get frob-mapping devtype))) (result (cond ((vectorp x) (let ((change-to (cdr (assoc x standard-face-mapping)))) (cond ((or change-to (null (length x))) (list (cons tag-set (cond ((eq change-to t) x) (change-to) (t x))))) (t (let* ((subprop (if (> (length x) 1) (elt x 1) prop)) (subinsts (frob-face-inst-list locale (cdar (specifier-spec-list (face-property (elt x 0) subprop))) subprop devtype-spec))) (add-tag-to-inst-list subinsts tag-set)))))) (t (let ((value (if (eq devtype-spec (quote tty)) (funcall mapper x) (funcall mapper x (derive-domain-from-locale locale devtype-spec ffpdev))))) (and (nil-instantiator-ok value devtype-spec) (list (cons tag-set value)))))))) (if (and (eq (quote tty) devtype-spec) (not (or (eq (quote tty) tag-set) (memq (quote tty) tag-set)))) (nconc (add-tag-to-inst-list result (quote tty)) (list (cons tag-set x))) result)) nconc it))) (delete-duplicates results :test (function equal))))))) (let* ((--letf-bound--25565 (fboundp (quote frob-locale))) (--letf-save--25564 (and --letf-bound--25565 (symbol-function (quote frob-locale))))) (unwind-protect (progn (fset (quote frob-locale) (function (lambda (sp locale inst-list thunk) "\nCommon Lisp lambda list:\n (lambda SP LOCALE INST-LIST THUNK)\n\n" (block frob-locale (let ((newinst (frob-face-inst-list locale inst-list (car thunk) (cdr thunk)))) (remove-specifier sp locale tag-set exact-p) (add-spec-list-to-specifier sp (list (cons locale newinst)))) nil)))) (let* ((--letf-bound--25569 (fboundp (quote map-over-locales))) (--letf-save--25568 (and --letf-bound--25569 (symbol-function (quote map-over-locales))))) (unwind-protect (progn (fset (quote map-over-locales) (function (lambda (locale) "\nCommon Lisp lambda list:\n (lambda LOCALE)\n\n" (block map-over-locales (map-specifier (get face win-prop) (function frob-locale) locale (cons win-prop (quote window-system)) tag-set exact-p) (loop for prop in tty-props do (map-specifier (get face prop) (function frob-locale) locale (cons prop (quote tty)) tag-set exact-p)))))) (let* ((ffpdev Face-frob-property-device-considered-current) (do-later-stages (or (global-locale locale) (valid-specifier-domain-p locale) (bufferp locale))) (domain (and do-later-stages (derive-domain-from-locale locale (quote window-system) ffpdev))) (check-differences (and unfrobbed-face frobbed-face domain (not (memq (face-name face) (quote (default bold italic bold-italic)))))) (orig-instance (and check-differences (face-property-instance face win-prop domain)))) (setq face (get-face face)) (map-over-locales locale) (if do-later-stages (progn (if (global-locale locale) (setq locale (quote global))) (let (do-something) (cl-block-wrapper (catch (quote --cl-block-nil--) (let* ((G25570 (cons win-prop tty-props)) (prop nil) (propspec nil) (devtype-spec nil)) (while (consp G25570) (setq prop (car G25570)) (setq propspec (get face prop)) (setq devtype-spec (if (eq prop win-prop) (quote window-system) (quote tty))) (if propspec (progn (or (specifier-spec-list propspec locale) (let ((doit (derive-specifier-specs-from-locale propspec locale devtype-spec ffpdev (and (not tag-set) (not exact-p))))) (if (and (not doit) (eq locale (quote global))) (error "No fallback for specifier property %s in face %s???" prop face)) (when doit (add-spec-list-to-specifier propspec (list (cons locale (add-tag-to-inst-list doit (append (if (listp tag-set) tag-set (list tag-set)) (if (eq devtype-spec (quote tty)) (quote (tty)))))))) (setq do-something t)))))) (setq G25570 (cdr G25570))) nil))) (if do-something (map-over-locales (or (global-locale locale) locale)))) (if (and check-differences (let ((new-instance (face-property-instance face win-prop domain))) (and (equal orig-instance new-instance) (equal orig-instance (face-property-instance unfrobbed-face win-prop domain))))) (set-face-property face win-prop (vector frobbed-face) (or (global-locale locale) locale) tag-set)))))) (if --letf-bound--25569 (fset (quote map-over-locales) --letf-save--25568) (fmakunbound (quote map-over-locales)))))) (if --letf-bound--25565 (fset (quote frob-locale) --letf-save--25564) (fmakunbound (quote frob-locale)))))) (if --letf-bound--25561 (fset (quote frob-face-inst-list) --letf-save--25560) (fmakunbound (quote frob-face-inst-list)))))) nil) byte-compile-progn((progn (fset (quote global-locale) (function (lambda (locale) "\nCommon Lisp lambda list:\n (lambda LOCALE)\n\n" (block global-locale (and (memq locale (quote (all nil global))) (quote global)))))) (let* ((--letf-bound--25561 (fboundp (quote frob-face-inst-list))) (--letf-save--25560 (and --letf-bound--25561 (symbol-function (quote frob-face-inst-list))))) (unwind-protect (progn (fset (quote frob-face-inst-list) (function (lambda (locale inst-list prop devtype-spec) "\nCommon Lisp lambda list:\n (lambda LOCALE INST-LIST PROP DEVTYPE-SPEC)\n\n" (block frob-face-inst-list (let* ((ffpdev Face-frob-property-device-considered-current) (results (loop for (tag-set . x) in inst-list for devtype = (derive-device-type-from-locale-and-tag-set locale tag-set devtype-spec ffpdev) if devtype if (let* ((mapper (if (functionp frob-mapping) frob-mapping (plist-get frob-mapping devtype))) (result (cond ((vectorp x) (let ((change-to (cdr (assoc x standard-face-mapping)))) (cond ((or change-to (null (length x))) (list (cons tag-set (cond ((eq change-to t) x) (change-to) (t x))))) (t (let* ((subprop (if (> (length x) 1) (elt x 1) prop)) (subinsts (frob-face-inst-list locale (cdar (specifier-spec-list (face-property (elt x 0) subprop))) subprop devtype-spec))) (add-tag-to-inst-list subinsts tag-set)))))) (t (let ((value (if (eq devtype-spec (quote tty)) (funcall mapper x) (funcall mapper x (derive-domain-from-locale locale devtype-spec ffpdev))))) (and (nil-instantiator-ok value devtype-spec) (list (cons tag-set value)))))))) (if (and (eq (quote tty) devtype-spec) (not (or (eq (quote tty) tag-set) (memq (quote tty) tag-set)))) (nconc (add-tag-to-inst-list result (quote tty)) (list (cons tag-set x))) result)) nconc it))) (delete-duplicates results :test (function equal))))))) (let* ((--letf-bound--25565 (fboundp (quote frob-locale))) (--letf-save--25564 (and --letf-bound--25565 (symbol-function (quote frob-locale))))) (unwind-protect (progn (fset (quote frob-locale) (function (lambda (sp locale inst-list thunk) "\nCommon Lisp lambda list:\n (lambda SP LOCALE INST-LIST THUNK)\n\n" (block frob-locale (let ((newinst (frob-face-inst-list locale inst-list (car thunk) (cdr thunk)))) (remove-specifier sp locale tag-set exact-p) (add-spec-list-to-specifier sp (list (cons locale newinst)))) nil)))) (let* ((--letf-bound--25569 (fboundp (quote map-over-locales))) (--letf-save--25568 (and --letf-bound--25569 (symbol-function (quote map-over-locales))))) (unwind-protect (progn (fset (quote map-over-locales) (function (lambda (locale) "\nCommon Lisp lambda list:\n (lambda LOCALE)\n\n" (block map-over-locales (map-specifier (get face win-prop) (function frob-locale) locale (cons win-prop (quote window-system)) tag-set exact-p) (loop for prop in tty-props do (map-specifier (get face prop) (function frob-locale) locale (cons prop (quote tty)) tag-set exact-p)))))) (let* ((ffpdev Face-frob-property-device-considered-current) (do-later-stages (or (global-locale locale) (valid-specifier-domain-p locale) (bufferp locale))) (domain (and do-later-stages (derive-domain-from-locale locale (quote window-system) ffpdev))) (check-differences (and unfrobbed-face frobbed-face domain (not (memq (face-name face) (quote (default bold italic bold-italic)))))) (orig-instance (and check-differences (face-property-instance face win-prop domain)))) (setq face (get-face face)) (map-over-locales locale) (if do-later-stages (progn (if (global-locale locale) (setq locale (quote global))) (let (do-something) (cl-block-wrapper (catch (quote --cl-block-nil--) (let* ((G25570 (cons win-prop tty-props)) (prop nil) (propspec nil) (devtype-spec nil)) (while (consp G25570) (setq prop (car G25570)) (setq propspec (get face prop)) (setq devtype-spec (if (eq prop win-prop) (quote window-system) (quote tty))) (if propspec (progn (or (specifier-spec-list propspec locale) (let ((doit (derive-specifier-specs-from-locale propspec locale devtype-spec ffpdev (and (not tag-set) (not exact-p))))) (if (and (not doit) (eq locale (quote global))) (error "No fallback for specifier property %s in face %s???" prop face)) (when doit (add-spec-list-to-specifier propspec (list (cons locale (add-tag-to-inst-list doit (append (if (listp tag-set) tag-set (list tag-set)) (if (eq devtype-spec (quote tty)) (quote (tty)))))))) (setq do-something t)))))) (setq G25570 (cdr G25570))) nil))) (if do-something (map-over-locales (or (global-locale locale) locale)))) (if (and check-differences (let ((new-instance (face-property-instance face win-prop domain))) (and (equal orig-instance new-instance) (equal orig-instance (face-property-instance unfrobbed-face win-prop domain))))) (set-face-property face win-prop (vector frobbed-face) (or (global-locale locale) locale) tag-set)))))) (if --letf-bound--25569 (fset (quote map-over-locales) --letf-save--25568) (fmakunbound (quote map-over-locales)))))) (if --letf-bound--25565 (fset (quote frob-locale) --letf-save--25564) (fmakunbound (quote frob-locale)))))) (if --letf-bound--25561 (fset (quote frob-face-inst-list) --letf-save--25560) (fmakunbound (quote frob-face-inst-list))))))) byte-compile-form((progn (fset (quote global-locale) (function (lambda (locale) "\nCommon Lisp lambda list:\n (lambda LOCALE)\n\n" (block global-locale (and (memq locale (quote (all nil global))) (quote global)))))) (let* ((--letf-bound--25561 (fboundp (quote frob-face-inst-list))) (--letf-save--25560 (and --letf-bound--25561 (symbol-function (quote frob-face-inst-list))))) (unwind-protect (progn (fset (quote frob-face-inst-list) (function (lambda (locale inst-list prop devtype-spec) "\nCommon Lisp lambda list:\n (lambda LOCALE INST-LIST PROP DEVTYPE-SPEC)\n\n" (block frob-face-inst-list (let* ((ffpdev Face-frob-property-device-considered-current) (results (loop for (tag-set . x) in inst-list for devtype = (derive-device-type-from-locale-and-tag-set locale tag-set devtype-spec ffpdev) if devtype if (let* ((mapper (if (functionp frob-mapping) frob-mapping (plist-get frob-mapping devtype))) (result (cond ((vectorp x) (let ((change-to (cdr (assoc x standard-face-mapping)))) (cond ((or change-to (null (length x))) (list (cons tag-set (cond ((eq change-to t) x) (change-to) (t x))))) (t (let* ((subprop (if (> (length x) 1) (elt x 1) prop)) (subinsts (frob-face-inst-list locale (cdar (specifier-spec-list (face-property (elt x 0) subprop))) subprop devtype-spec))) (add-tag-to-inst-list subinsts tag-set)))))) (t (let ((value (if (eq devtype-spec (quote tty)) (funcall mapper x) (funcall mapper x (derive-domain-from-locale locale devtype-spec ffpdev))))) (and (nil-instantiator-ok value devtype-spec) (list (cons tag-set value)))))))) (if (and (eq (quote tty) devtype-spec) (not (or (eq (quote tty) tag-set) (memq (quote tty) tag-set)))) (nconc (add-tag-to-inst-list result (quote tty)) (list (cons tag-set x))) result)) nconc it))) (delete-duplicates results :test (function equal))))))) (let* ((--letf-bound--25565 (fboundp (quote frob-locale))) (--letf-save--25564 (and --letf-bound--25565 (symbol-function (quote frob-locale))))) (unwind-protect (progn (fset (quote frob-locale) (function (lambda (sp locale inst-list thunk) "\nCommon Lisp lambda list:\n (lambda SP LOCALE INST-LIST THUNK)\n\n" (block frob-locale (let ((newinst (frob-face-inst-list locale inst-list (car thunk) (cdr thunk)))) (remove-specifier sp locale tag-set exact-p) (add-spec-list-to-specifier sp (list (cons locale newinst)))) nil)))) (let* ((--letf-bound--25569 (fboundp (quote map-over-locales))) (--letf-save--25568 (and --letf-bound--25569 (symbol-function (quote map-over-locales))))) (unwind-protect (progn (fset (quote map-over-locales) (function (lambda (locale) "\nCommon Lisp lambda list:\n (lambda LOCALE)\n\n" (block map-over-locales (map-specifier (get face win-prop) (function frob-locale) locale (cons win-prop (quote window-system)) tag-set exact-p) (loop for prop in tty-props do (map-specifier (get face prop) (function frob-locale) locale (cons prop (quote tty)) tag-set exact-p)))))) (let* ((ffpdev Face-frob-property-device-considered-current) (do-later-stages (or (global-locale locale) (valid-specifier-domain-p locale) (bufferp locale))) (domain (and do-later-stages (derive-domain-from-locale locale (quote window-system) ffpdev))) (check-differences (and unfrobbed-face frobbed-face domain (not (memq (face-name face) (quote (default bold italic bold-italic)))))) (orig-instance (and check-differences (face-property-instance face win-prop domain)))) (setq face (get-face face)) (map-over-locales locale) (if do-later-stages (progn (if (global-locale locale) (setq locale (quote global))) (let (do-something) (cl-block-wrapper (catch (quote --cl-block-nil--) (let* ((G25570 (cons win-prop tty-props)) (prop nil) (propspec nil) (devtype-spec nil)) (while (consp G25570) (setq prop (car G25570)) (setq propspec (get face prop)) (setq devtype-spec (if (eq prop win-prop) (quote window-system) (quote tty))) (if propspec (progn (or (specifier-spec-list propspec locale) (let ((doit (derive-specifier-specs-from-locale propspec locale devtype-spec ffpdev (and (not tag-set) (not exact-p))))) (if (and (not doit) (eq locale (quote global))) (error "No fallback for specifier property %s in face %s???" prop face)) (when doit (add-spec-list-to-specifier propspec (list (cons locale (add-tag-to-inst-list doit (append (if (listp tag-set) tag-set (list tag-set)) (if (eq devtype-spec (quote tty)) (quote (tty)))))))) (setq do-something t)))))) (setq G25570 (cdr G25570))) nil))) (if do-something (map-over-locales (or (global-locale locale) locale)))) (if (and check-differences (let ((new-instance (face-property-instance face win-prop domain))) (and (equal orig-instance new-instance) (equal orig-instance (face-property-instance unfrobbed-face win-prop domain))))) (set-face-property face win-prop (vector frobbed-face) (or (global-locale locale) locale) tag-set)))))) (if --letf-bound--25569 (fset (quote map-over-locales) --letf-save--25568) (fmakunbound (quote map-over-locales)))))) (if --letf-bound--25565 (fset (quote frob-locale) --letf-save--25564) (fmakunbound (quote frob-locale)))))) (if --letf-bound--25561 (fset (quote frob-face-inst-list) --letf-save--25560) (fmakunbound (quote frob-face-inst-list)))))) nil) byte-compile-unwind-protect((unwind-protect (progn (fset (quote global-locale) (function (lambda (locale) "\nCommon Lisp lambda list:\n (lambda LOCALE)\n\n" (block global-locale (and (memq locale (quote (all nil global))) (quote global)))))) (let* ((--letf-bound--25561 (fboundp (quote frob-face-inst-list))) (--letf-save--25560 (and --letf-bound--25561 (symbol-function (quote frob-face-inst-list))))) (unwind-protect (progn (fset (quote frob-face-inst-list) (function (lambda (locale inst-list prop devtype-spec) "\nCommon Lisp lambda list:\n (lambda LOCALE INST-LIST PROP DEVTYPE-SPEC)\n\n" (block frob-face-inst-list (let* ((ffpdev Face-frob-property-device-considered-current) (results (loop for (tag-set . x) in inst-list for devtype = (derive-device-type-from-locale-and-tag-set locale tag-set devtype-spec ffpdev) if devtype if (let* ((mapper (if (functionp frob-mapping) frob-mapping (plist-get frob-mapping devtype))) (result (cond ((vectorp x) (let ((change-to (cdr (assoc x standard-face-mapping)))) (cond ((or change-to (null (length x))) (list (cons tag-set (cond ((eq change-to t) x) (change-to) (t x))))) (t (let* ((subprop (if (> (length x) 1) (elt x 1) prop)) (subinsts (frob-face-inst-list locale (cdar (specifier-spec-list (face-property (elt x 0) subprop))) subprop devtype-spec))) (add-tag-to-inst-list subinsts tag-set)))))) (t (let ((value (if (eq devtype-spec (quote tty)) (funcall mapper x) (funcall mapper x (derive-domain-from-locale locale devtype-spec ffpdev))))) (and (nil-instantiator-ok value devtype-spec) (list (cons tag-set value)))))))) (if (and (eq (quote tty) devtype-spec) (not (or (eq (quote tty) tag-set) (memq (quote tty) tag-set)))) (nconc (add-tag-to-inst-list result (quote tty)) (list (cons tag-set x))) result)) nconc it))) (delete-duplicates results:test (function equal))))))) (let* ((--letf-bound--25565 (fboundp (quote frob-locale))) (--letf-save--25564 (and --letf-bound--25565 (symbol-function (quote frob-locale))))) (unwind-protect (progn (fset (quote frob-locale) (function (lambda (sp locale inst-list thunk) "\nCommon Lisp lambda list:\n (lambda SP LOCALE INST-LIST THUNK)\n\n" (block frob-locale (let ((newinst (frob-face-inst-list locale inst-list (car thunk) (cdr thunk)))) (remove-specifier sp locale tag-set exact-p) (add-spec-list-to-specifier sp (list (cons locale newinst)))) nil)))) (let* ((--letf-bound--25569 (fboundp (quote map-over-locales))) (--letf-save--25568 (and --letf-bound--25569 (symbol-function (quote map-over-locales))))) (unwind-protect (progn (fset (quote map-over-locales) (function (lambda (locale) "\nCommon Lisp lambda list:\n (lambda LOCALE)\n\n" (block map-over-locales (map-specifier (get face win-prop) (function frob-locale) locale (cons win-prop (quote window-system)) tag-set exact-p) (loop for prop in tty-props do (map-specifier (get face prop) (function frob-locale) locale (cons prop (quote tty)) tag-set exact-p)))))) (let* ((ffpdev Face-frob-property-device-considered-current) (do-later-stages (or (global-locale locale) (valid-specifier-domain-p locale) (bufferp locale))) (domain (and do-later-stages (derive-domain-from-locale locale (quote window-system) ffpdev))) (check-differences (and unfrobbed-face frobbed-face domain (not (memq (face-name face) (quote (default bold italic bold-italic)))))) (orig-instance (and check-differences (face-property-instance face win-prop domain)))) (setq face (get-face face)) (map-over-locales locale) (if do-later-stages (progn (if (global-locale locale) (setq locale (quote global))) (let (do-something) (cl-block-wrapper (catch (quote --cl-block-nil--) (let* ((G25570 (cons win-prop tty-props)) (prop nil) (propspec nil) (devtype-spec nil)) (while (consp G25570) (setq prop (car G25570)) (setq propspec (get face prop)) (setq devtype-spec (if (eq prop win-prop) (quote window-system) (quote tty))) (if propspec (progn (or (specifier-spec-list propspec locale) (let ((doit (derive-specifier-specs-from-locale propspec locale devtype-spec ffpdev (and (not tag-set) (not exact-p))))) (if (and (not doit) (eq locale (quote global))) (error "No fallback for specifier property %s in face %s???" prop face)) (when doit (add-spec-list-to-specifier propspec (list (cons locale (add-tag-to-inst-list doit (append (if (listp tag-set) tag-set (list tag-set)) (if (eq devtype-spec (quote tty)) (quote (tty)))))))) (setq do-something t)))))) (setq G25570 (cdr G25570))) nil))) (if do-something (map-over-locales (or (global-locale locale) locale)))) (if (and check-differences (let ((new-instance (face-property-instance face win-prop domain))) (and (equal orig-instance new-instance) (equal orig-instance (face-property-instance unfrobbed-face win-prop domain))))) (set-face-property face win-prop (vector frobbed-face) (or (global-locale locale) locale) tag-set)))))) (if --letf-bound--25569 (fset (quote map-over-locales) --letf-save--25568) (fmakunbound (quote map-over-locales)))))) (if --letf-bound--25565 (fset (quote frob-locale) --letf-save--25564) (fmakunbound (quote frob-locale)))))) (if --letf-bound--25561 (fset (quote frob-face-inst-list) --letf-save--25560) (fmakunbound (quote frob-face-inst-list)))))) (if --letf-bound--25557 (fset (quote global-locale) --letf-save--25556) (fmakunbound (quote global-locale))))) byte-compile-form((unwind-protect (progn (fset (quote global-locale) (function (lambda (locale) "\nCommon Lisp lambda list:\n (lambda LOCALE)\n\n" (block global-locale (and (memq locale (quote (all nil global))) (quote global)))))) (let* ((--letf-bound--25561 (fboundp (quote frob-face-inst-list))) (--letf-save--25560 (and --letf-bound--25561 (symbol-function (quote frob-face-inst-list))))) (unwind-protect (progn (fset (quote frob-face-inst-list) (function (lambda (locale inst-list prop devtype-spec) "\nCommon Lisp lambda list:\n (lambda LOCALE INST-LIST PROP DEVTYPE-SPEC)\n\n" (block frob-face-inst-list (let* ((ffpdev Face-frob-property-device-considered-current) (results (loop for (tag-set . x) in inst-list for devtype = (derive-device-type-from-locale-and-tag-set locale tag-set devtype-spec ffpdev) if devtype if (let* ((mapper (if (functionp frob-mapping) frob-mapping (plist-get frob-mapping devtype))) (result (cond ((vectorp x) (let ((change-to (cdr (assoc x standard-face-mapping)))) (cond ((or change-to (null (length x))) (list (cons tag-set (cond ((eq change-to t) x) (change-to) (t x))))) (t (let* ((subprop (if (> (length x) 1) (elt x 1) prop)) (subinsts (frob-face-inst-list locale (cdar (specifier-spec-list (face-property (elt x 0) subprop))) subprop devtype-spec))) (add-tag-to-inst-list subinsts tag-set)))))) (t (let ((value (if (eq devtype-spec (quote tty)) (funcall mapper x) (funcall mapper x (derive-domain-from-locale locale devtype-spec ffpdev))))) (and (nil-instantiator-ok value devtype-spec) (list (cons tag-set value)))))))) (if (and (eq (quote tty) devtype-spec) (not (or (eq (quote tty) tag-set) (memq (quote tty) tag-set)))) (nconc (add-tag-to-inst-list result (quote tty)) (list (cons tag-set x))) result)) nconc it))) (delete-duplicates results :test (function equal))))))) (let* ((--letf-bound--25565 (fboundp (quote frob-locale))) (--letf-save--25564 (and --letf-bound--25565 (symbol-function (quote frob-locale))))) (unwind-protect (progn (fset (quote frob-locale) (function (lambda (sp locale inst-list thunk) "\nCommon Lisp lambda list:\n (lambda SP LOCALE INST-LIST THUNK)\n\n" (block frob-locale (let ((newinst (frob-face-inst-list locale inst-list (car thunk) (cdr thunk)))) (remove-specifier sp locale tag-set exact-p) (add-spec-list-to-specifier sp (list (cons locale newinst)))) nil)))) (let* ((--letf-bound--25569 (fboundp (quote map-over-locales))) (--letf-save--25568 (and --letf-bound--25569 (symbol-function (quote map-over-locales))))) (unwind-protect (progn (fset (quote map-over-locales) (function (lambda (locale) "\nCommon Lisp lambda list:\n (lambda LOCALE)\n\n" (block map-over-locales (map-specifier (get face win-prop) (function frob-locale) locale (cons win-prop (quote window-system)) tag-set exact-p) (loop for prop in tty-props do (map-specifier (get face prop) (function frob-locale) locale (cons prop (quote tty)) tag-set exact-p)))))) (let* ((ffpdev Face-frob-property-device-considered-current) (do-later-stages (or (global-locale locale) (valid-specifier-domain-p locale) (bufferp locale))) (domain (and do-later-stages (derive-domain-from-locale locale (quote window-system) ffpdev))) (check-differences (and unfrobbed-face frobbed-face domain (not (memq (face-name face) (quote (default bold italic bold-italic)))))) (orig-instance (and check-differences (face-property-instance face win-prop domain)))) (setq face (get-face face)) (map-over-locales locale) (if do-later-stages (progn (if (global-locale locale) (setq locale (quote global))) (let (do-something) (cl-block-wrapper (catch (quote --cl-block-nil--) (let* ((G25570 (cons win-prop tty-props)) (prop nil) (propspec nil) (devtype-spec nil)) (while (consp G25570) (setq prop (car G25570)) (setq propspec (get face prop)) (setq devtype-spec (if (eq prop win-prop) (quote window-system) (quote tty))) (if propspec (progn (or (specifier-spec-list propspec locale) (let ((doit (derive-specifier-specs-from-locale propspec locale devtype-spec ffpdev (and (not tag-set) (not exact-p))))) (if (and (not doit) (eq locale (quote global))) (error "No fallback for specifier property %s in face %s???" prop face)) (when doit (add-spec-list-to-specifier propspec (list (cons locale (add-tag-to-inst-list doit (append (if (listp tag-set) tag-set (list tag-set)) (if (eq devtype-spec (quote tty)) (quote (tty)))))))) (setq do-something t)))))) (setq G25570 (cdr G25570))) nil))) (if do-something (map-over-locales (or (global-locale locale) locale)))) (if (and check-differences (let ((new-instance (face-property-instance face win-prop domain))) (and (equal orig-instance new-instance) (equal orig-instance (face-property-instance unfrobbed-face win-prop domain))))) (set-face-property face win-prop (vector frobbed-face) (or (global-locale locale) locale) tag-set)))))) (if --letf-bound--25569 (fset (quote map-over-locales) --letf-save--25568) (fmakunbound (quote map-over-locales)))))) (if --letf-bound--25565 (fset (quote frob-locale) --letf-save--25564) (fmakunbound (quote frob-locale)))))) (if --letf-bound--25561 (fset (quote frob-face-inst-list) --letf-save--25560) (fmakunbound (quote frob-face-inst-list)))))) (if --letf-bound--25557 (fset (quote global-locale) --letf-save--25556) (fmakunbound (quote global-locale)))) nil) byte-compile-body(((unwind-protect (progn (fset (quote global-locale) (function (lambda (locale) "\nCommon Lisp lambda list:\n (lambda LOCALE)\n\n" (block global-locale (and (memq locale (quote (all nil global))) (quote global)))))) (let* ((--letf-bound--25561 (fboundp (quote frob-face-inst-list))) (--letf-save--25560 (and --letf-bound--25561 (symbol-function (quote frob-face-inst-list))))) (unwind-protect (progn (fset (quote frob-face-inst-list) (function (lambda (locale inst-list prop devtype-spec) "\nCommon Lisp lambda list:\n (lambda LOCALE INST-LIST PROP DEVTYPE-SPEC)\n\n" (block frob-face-inst-list (let* ((ffpdev Face-frob-property-device-considered-current) (results (loop for (tag-set . x) in inst-list for devtype = (derive-device-type-from-locale-and-tag-set locale tag-set devtype-spec ffpdev) if devtype if (let* ((mapper (if (functionp frob-mapping) frob-mapping (plist-get frob-mapping devtype))) (result (cond ((vectorp x) (let ((change-to (cdr (assoc x standard-face-mapping)))) (cond ((or change-to (null (length x))) (list (cons tag-set (cond ((eq change-to t) x) (change-to) (t x))))) (t (let* ((subprop (if (> (length x) 1) (elt x 1) prop)) (subinsts (frob-face-inst-list locale (cdar (specifier-spec-list (face-property (elt x 0) subprop))) subprop devtype-spec))) (add-tag-to-inst-list subinsts tag-set)))))) (t (let ((value (if (eq devtype-spec (quote tty)) (funcall mapper x) (funcall mapper x (derive-domain-from-locale locale devtype-spec ffpdev))))) (and (nil-instantiator-ok value devtype-spec) (list (cons tag-set value)))))))) (if (and (eq (quote tty) devtype-spec) (not (or (eq (quote tty) tag-set) (memq (quote tty) tag-set)))) (nconc (add-tag-to-inst-list result (quote tty)) (list (cons tag-set x))) result)) nconc it))) (delete-duplicates results :test (function equal))))))) (let* ((--letf-bound--25565 (fboundp (quote frob-locale))) (--letf-save--25564 (and --letf-bound--25565 (symbol-function (quote frob-locale))))) (unwind-protect (progn (fset (quote frob-locale) (function (lambda (sp locale inst-list thunk) "\nCommon Lisp lambda list:\n (lambda SP LOCALE INST-LIST THUNK)\n\n" (block frob-locale (let ((newinst (frob-face-inst-list locale inst-list (car thunk) (cdr thunk)))) (remove-specifier sp locale tag-set exact-p) (add-spec-list-to-specifier sp (list (cons locale newinst)))) nil)))) (let* ((--letf-bound--25569 (fboundp (quote map-over-locales))) (--letf-save--25568 (and --letf-bound--25569 (symbol-function (quote map-over-locales))))) (unwind-protect (progn (fset (quote map-over-locales) (function (lambda (locale) "\nCommon Lisp lambda list:\n (lambda LOCALE)\n\n" (block map-over-locales (map-specifier (get face win-prop) (function frob-locale) locale (cons win-prop (quote window-system)) tag-set exact-p) (loop for prop in tty-props do (map-specifier (get face prop) (function frob-locale) locale (cons prop (quote tty)) tag-set exact-p)))))) (let* ((ffpdev Face-frob-property-device-considered-current) (do-later-stages (or (global-locale locale) (valid-specifier-domain-p locale) (bufferp locale))) (domain (and do-later-stages (derive-domain-from-locale locale (quote window-system) ffpdev))) (check-differences (and unfrobbed-face frobbed-face domain (not (memq (face-name face) (quote (default bold italic bold-italic)))))) (orig-instance (and check-differences (face-property-instance face win-prop domain)))) (setq face (get-face face)) (map-over-locales locale) (if do-later-stages (progn (if (global-locale locale) (setq locale (quote global))) (let (do-something) (cl-block-wrapper (catch (quote --cl-block-nil--) (let* ((G25570 (cons win-prop tty-props)) (prop nil) (propspec nil) (devtype-spec nil)) (while (consp G25570) (setq prop (car G25570)) (setq propspec (get face prop)) (setq devtype-spec (if (eq prop win-prop) (quote window-system) (quote tty))) (if propspec (progn (or (specifier-spec-list propspec locale) (let ((doit (derive-specifier-specs-from-locale propspec locale devtype-spec ffpdev (and (not tag-set) (not exact-p))))) (if (and (not doit) (eq locale (quote global))) (error "No fallback for specifier property %s in face %s???" prop face)) (when doit (add-spec-list-to-specifier propspec (list (cons locale (add-tag-to-inst-list doit (append (if (listp tag-set) tag-set (list tag-set)) (if (eq devtype-spec (quote tty)) (quote (tty)))))))) (setq do-something t)))))) (setq G25570 (cdr G25570))) nil))) (if do-something (map-over-locales (or (global-locale locale) locale)))) (if (and check-differences (let ((new-instance (face-property-instance face win-prop domain))) (and (equal orig-instance new-instance) (equal orig-instance (face-property-instance unfrobbed-face win-prop domain))))) (set-face-property face win-prop (vector frobbed-face) (or (global-locale locale) locale) tag-set)))))) (if --letf-bound--25569 (fset (quote map-over-locales) --letf-save--25568) (fmakunbound (quote map-over-locales)))))) (if --letf-bound--25565 (fset (quote frob-locale) --letf-save--25564) (fmakunbound (quote frob-locale)))))) (if --letf-bound--25561 (fset (quote frob-face-inst-list) --letf-save--25560) (fmakunbound (quote frob-face-inst-list)))))) (if --letf-bound--25557 (fset (quote global-locale) --letf-save--25556) (fmakunbound (quote global-locale))))) nil) byte-compile-let*((let* ((--letf-bound--25557 (fboundp (quote global-locale))) (--letf-save--25556 (and --letf-bound--25557 (symbol-function (quote global-locale))))) (unwind-protect (progn (fset (quote global-locale) (function (lambda (locale) "\nCommon Lisp lambda list:\n (lambda LOCALE)\n\n" (block global-locale (and (memq locale (quote (all nil global))) (quote global)))))) (let* ((--letf-bound--25561 (fboundp (quote frob-face-inst-list))) (--letf-save--25560 (and --letf-bound--25561 (symbol-function (quote frob-face-inst-list))))) (unwind-protect (progn (fset (quote frob-face-inst-list) (function (lambda (locale inst-list prop devtype-spec) "\nCommon Lisp lambda list:\n (lambda LOCALE INST-LIST PROP DEVTYPE-SPEC)\n\n" (block frob-face-inst-list (let* ((ffpdev Face-frob-property-device-considered-current) (results (loop for (tag-set . x) in inst-list for devtype = (derive-device-type-from-locale-and-tag-set locale tag-set devtype-spec ffpdev) if devtype if (let* ((mapper (if (functionp frob-mapping) frob-mapping (plist-get frob-mapping devtype))) (result (cond ((vectorp x) (let ((change-to (cdr (assoc x standard-face-mapping)))) (cond ((or change-to (null (length x))) (list (cons tag-set (cond ((eq change-to t) x) (change-to) (t x))))) (t (let* ((subprop (if (> (length x) 1) (elt x 1) prop)) (subinsts (frob-face-inst-list locale (cdar (specifier-spec-list (face-property (elt x 0) subprop))) subprop devtype-spec))) (add-tag-to-inst-list subinsts tag-set)))))) (t (let ((value (if (eq devtype-spec (quote tty)) (funcall mapper x) (funcall mapper x (derive-domain-from-locale locale devtype-spec ffpdev))))) (and (nil-instantiator-ok value devtype-spec) (list (cons tag-set value)))))))) (if (and (eq (quote tty) devtype-spec) (not (or (eq (quote tty) tag-set) (memq (quote tty) tag-set)))) (nconc (add-tag-to-inst-list result (quote tty)) (list (cons tag-set x))) result)) nconc it))) (delete-duplicates results :test (function equal))))))) (let* ((--letf-bound--25565 (fboundp (quote frob-locale))) (--letf-save--25564 (and --letf-bound--25565 (symbol-function (quote frob-locale))))) (unwind-protect (progn (fset (quote frob-locale) (function (lambda (sp locale inst-list thunk) "\nCommon Lisp lambda list:\n (lambda SP LOCALE INST-LIST THUNK)\n\n" (block frob-locale (let ((newinst (frob-face-inst-list locale inst-list (car thunk) (cdr thunk)))) (remove-specifier sp locale tag-set exact-p) (add-spec-list-to-specifier sp (list (cons locale newinst)))) nil)))) (let* ((--letf-bound--25569 (fboundp (quote map-over-locales))) (--letf-save--25568 (and --letf-bound--25569 (symbol-function (quote map-over-locales))))) (unwind-protect (progn (fset (quote map-over-locales) (function (lambda (locale) "\nCommon Lisp lambda list:\n (lambda LOCALE)\n\n" (block map-over-locales (map-specifier (get face win-prop) (function frob-locale) locale (cons win-prop (quote window-system)) tag-set exact-p) (loop for prop in tty-props do (map-specifier (get face prop) (function frob-locale) locale (cons prop (quote tty)) tag-set exact-p)))))) (let* ((ffpdev Face-frob-property-device-considered-current) (do-later-stages (or (global-locale locale) (valid-specifier-domain-p locale) (bufferp locale))) (domain (and do-later-stages (derive-domain-from-locale locale (quote window-system) ffpdev))) (check-differences (and unfrobbed-face frobbed-face domain (not (memq (face-name face) (quote (default bold italic bold-italic)))))) (orig-instance (and check-differences (face-property-instance face win-prop domain)))) (setq face (get-face face)) (map-over-locales locale) (if do-later-stages (progn (if (global-locale locale) (setq locale (quote global))) (let (do-something) (cl-block-wrapper (catch (quote --cl-block-nil--) (let* ((G25570 (cons win-prop tty-props)) (prop nil) (propspec nil) (devtype-spec nil)) (while (consp G25570) (setq prop (car G25570)) (setq propspec (get face prop)) (setq devtype-spec (if (eq prop win-prop) (quote window-system) (quote tty))) (if propspec (progn (or (specifier-spec-list propspec locale) (let ((doit (derive-specifier-specs-from-locale propspec locale devtype-spec ffpdev (and (not tag-set) (not exact-p))))) (if (and (not doit) (eq locale (quote global))) (error "No fallback for specifier property %s in face %s???" prop face)) (when doit (add-spec-list-to-specifier propspec (list (cons locale (add-tag-to-inst-list doit (append (if (listp tag-set) tag-set (list tag-set)) (if (eq devtype-spec (quote tty)) (quote (tty)))))))) (setq do-something t)))))) (setq G25570 (cdr G25570))) nil))) (if do-something (map-over-locales (or (global-locale locale) locale)))) (if (and check-differences (let ((new-instance (face-property-instance face win-prop domain))) (and (equal orig-instance new-instance) (equal orig-instance (face-property-instance unfrobbed-face win-prop domain))))) (set-face-property face win-prop (vector frobbed-face) (or (global-locale locale) locale) tag-set)))))) (if --letf-bound--25569 (fset (quote map-over-locales) --letf-save--25568) (fmakunbound (quote map-over-locales)))))) (if --letf-bound--25565 (fset (quote frob-locale) --letf-save--25564) (fmakunbound (quote frob-locale)))))) (if --letf-bound--25561 (fset (quote frob-face-inst-list) --letf-save--25560) (fmakunbound (quote frob-face-inst-list)))))) (if --letf-bound--25557 (fset (quote global-locale) --letf-save--25556) (fmakunbound (quote global-locale)))))) byte-compile-form((let* ((--letf-bound--25557 (fboundp (quote global-locale))) (--letf-save--25556 (and --letf-bound--25557 (symbol-function (quote global-locale))))) (unwind-protect (progn (fset (quote global-locale) (function (lambda (locale) "\nCommon Lisp lambda list:\n (lambda LOCALE)\n\n" (block global-locale (and (memq locale (quote (all nil global))) (quote global)))))) (let* ((--letf-bound--25561 (fboundp (quote frob-face-inst-list))) (--letf-save--25560 (and --letf-bound--25561 (symbol-function (quote frob-face-inst-list))))) (unwind-protect (progn (fset (quote frob-face-inst-list) (function (lambda (locale inst-list prop devtype-spec) "\nCommon Lisp lambda list:\n (lambda LOCALE INST-LIST PROP DEVTYPE-SPEC)\n\n" (block frob-face-inst-list (let* ((ffpdev Face-frob-property-device-considered-current) (results (loop for (tag-set . x) in inst-list for devtype = (derive-device-type-from-locale-and-tag-set locale tag-set devtype-spec ffpdev) if devtype if (let* ((mapper (if (functionp frob-mapping) frob-mapping (plist-get frob-mapping devtype))) (result (cond ((vectorp x) (let ((change-to (cdr (assoc x standard-face-mapping)))) (cond ((or change-to (null (length x))) (list (cons tag-set (cond ((eq change-to t) x) (change-to) (t x))))) (t (let* ((subprop (if (> (length x) 1) (elt x 1) prop)) (subinsts (frob-face-inst-list locale (cdar (specifier-spec-list (face-property (elt x 0) subprop))) subprop devtype-spec))) (add-tag-to-inst-list subinsts tag-set)))))) (t (let ((value (if (eq devtype-spec (quote tty)) (funcall mapper x) (funcall mapper x (derive-domain-from-locale locale devtype-spec ffpdev))))) (and (nil-instantiator-ok value devtype-spec) (list (cons tag-set value)))))))) (if (and (eq (quote tty) devtype-spec) (not (or (eq (quote tty) tag-set) (memq (quote tty) tag-set)))) (nconc (add-tag-to-inst-list result (quote tty)) (list (cons tag-set x))) result)) nconc it))) (delete-duplicates results :test (function equal))))))) (let* ((--letf-bound--25565 (fboundp (quote frob-locale))) (--letf-save--25564 (and --letf-bound--25565 (symbol-function (quote frob-locale))))) (unwind-protect (progn (fset (quote frob-locale) (function (lambda (sp locale inst-list thunk) "\nCommon Lisp lambda list:\n (lambda SP LOCALE INST-LIST THUNK)\n\n" (block frob-locale (let ((newinst (frob-face-inst-list locale inst-list (car thunk) (cdr thunk)))) (remove-specifier sp locale tag-set exact-p) (add-spec-list-to-specifier sp (list (cons locale newinst)))) nil)))) (let* ((--letf-bound--25569 (fboundp (quote map-over-locales))) (--letf-save--25568 (and --letf-bound--25569 (symbol-function (quote map-over-locales))))) (unwind-protect (progn (fset (quote map-over-locales) (function (lambda (locale) "\nCommon Lisp lambda list:\n (lambda LOCALE)\n\n" (block map-over-locales (map-specifier (get face win-prop) (function frob-locale) locale (cons win-prop (quote window-system)) tag-set exact-p) (loop for prop in tty-props do (map-specifier (get face prop) (function frob-locale) locale (cons prop (quote tty)) tag-set exact-p)))))) (let* ((ffpdev Face-frob-property-device-considered-current) (do-later-stages (or (global-locale locale) (valid-specifier-domain-p locale) (bufferp locale))) (domain (and do-later-stages (derive-domain-from-locale locale (quote window-system) ffpdev))) (check-differences (and unfrobbed-face frobbed-face domain (not (memq (face-name face) (quote (default bold italic bold-italic)))))) (orig-instance (and check-differences (face-property-instance face win-prop domain)))) (setq face (get-face face)) (map-over-locales locale) (if do-later-stages (progn (if (global-locale locale) (setq locale (quote global))) (let (do-something) (cl-block-wrapper (catch (quote --cl-block-nil--) (let* ((G25570 (cons win-prop tty-props)) (prop nil) (propspec nil) (devtype-spec nil)) (while (consp G25570) (setq prop (car G25570)) (setq propspec (get face prop)) (setq devtype-spec (if (eq prop win-prop) (quote window-system) (quote tty))) (if propspec (progn (or (specifier-spec-list propspec locale) (let ((doit (derive-specifier-specs-from-locale propspec locale devtype-spec ffpdev (and (not tag-set) (not exact-p))))) (if (and (not doit) (eq locale (quote global))) (error "No fallback for specifier property %s in face %s???" prop face)) (when doit (add-spec-list-to-specifier propspec (list (cons locale (add-tag-to-inst-list doit (append (if (listp tag-set) tag-set (list tag-set)) (if (eq devtype-spec (quote tty)) (quote (tty)))))))) (setq do-something t)))))) (setq G25570 (cdr G25570))) nil))) (if do-something (map-over-locales (or (global-locale locale) locale)))) (if (and check-differences (let ((new-instance (face-property-instance face win-prop domain))) (and (equal orig-instance new-instance) (equal orig-instance (face-property-instance unfrobbed-face win-prop domain))))) (set-face-property face win-prop (vector frobbed-face) (or (global-locale locale) locale) tag-set)))))) (if --letf-bound--25569 (fset (quote map-over-locales) --letf-save--25568) (fmakunbound (quote map-over-locales)))))) (if --letf-bound--25565 (fset (quote frob-locale) --letf-save--25564) (fmakunbound (quote frob-locale)))))) (if --letf-bound--25561 (fset (quote frob-face-inst-list) --letf-save--25560) (fmakunbound (quote frob-face-inst-list)))))) (if --letf-bound--25557 (fset (quote global-locale) --letf-save--25556) (fmakunbound (quote global-locale))))) nil) byte-compile-body(((fset (quote nil-instantiator-ok) (function (lambda (inst devtype-spec) "\nCommon Lisp lambda list:\n (lambda INST DEVTYPE-SPEC)\n\n" (block nil-instantiator-ok (or inst (eq devtype-spec (quote tty))))))) (let* ((--letf-bound--25557 (fboundp (quote global-locale))) (--letf-save--25556 (and --letf-bound--25557 (symbol-function (quote global-locale))))) (unwind-protect (progn (fset (quote global-locale) (function (lambda (locale) "\nCommon Lisp lambda list:\n (lambda LOCALE)\n\n" (block global-locale (and (memq locale (quote (all nil global))) (quote global)))))) (let* ((--letf-bound--25561 (fboundp (quote frob-face-inst-list))) (--letf-save--25560 (and --letf-bound--25561 (symbol-function (quote frob-face-inst-list))))) (unwind-protect (progn (fset (quote frob-face-inst-list) (function (lambda (locale inst-list prop devtype-spec) "\nCommon Lisp lambda list:\n (lambda LOCALE INST-LIST PROP DEVTYPE-SPEC)\n\n" (block frob-face-inst-list (let* ((ffpdev Face-frob-property-device-considered-current) (results (loop for (tag-set . x) in inst-list for devtype = (derive-device-type-from-locale-and-tag-set locale tag-set devtype-spec ffpdev) if devtype if (let* ((mapper (if (functionp frob-mapping) frob-mapping (plist-get frob-mapping devtype))) (result (cond ((vectorp x) (let ((change-to (cdr (assoc x standard-face-mapping)))) (cond ((or change-to (null (length x))) (list (cons tag-set (cond ((eq change-to t) x) (change-to) (t x))))) (t (let* ((subprop (if (> (length x) 1) (elt x 1) prop)) (subinsts (frob-face-inst-list locale (cdar (specifier-spec-list (face-property (elt x 0) subprop))) subprop devtype-spec))) (add-tag-to-inst-list subinsts tag-set)))))) (t (let ((value (if (eq devtype-spec (quote tty)) (funcall mapper x) (funcall mapper x (derive-domain-from-locale locale devtype-spec ffpdev))))) (and (nil-instantiator-ok value devtype-spec) (list (cons tag-set value)))))))) (if (and (eq (quote tty) devtype-spec) (not (or (eq (quote tty) tag-set) (memq (quote tty) tag-set)))) (nconc (add-tag-to-inst-list result (quote tty)) (list (cons tag-set x))) result)) nconc it))) (delete-duplicates results :test (function equal))))))) (let* ((--letf-bound--25565 (fboundp (quote frob-locale))) (--letf-save--25564 (and --letf-bound--25565 (symbol-function (quote frob-locale))))) (unwind-protect (progn (fset (quote frob-locale) (function (lambda (sp locale inst-list thunk) "\nCommon Lisp lambda list:\n (lambda SP LOCALE INST-LIST THUNK)\n\n" (block frob-locale (let ((newinst (frob-face-inst-list locale inst-list (car thunk) (cdr thunk)))) (remove-specifier sp locale tag-set exact-p) (add-spec-list-to-specifier sp (list (cons locale newinst)))) nil)))) (let* ((--letf-bound--25569 (fboundp (quote map-over-locales))) (--letf-save--25568 (and --letf-bound--25569 (symbol-function (quote map-over-locales))))) (unwind-protect (progn (fset (quote map-over-locales) (function (lambda (locale) "\nCommon Lisp lambda list:\n (lambda LOCALE)\n\n" (block map-over-locales (map-specifier (get face win-prop) (function frob-locale) locale (cons win-prop (quote window-system)) tag-set exact-p) (loop for prop in tty-props do (map-specifier (get face prop) (function frob-locale) locale (cons prop (quote tty)) tag-set exact-p)))))) (let* ((ffpdev Face-frob-property-device-considered-current) (do-later-stages (or (global-locale locale) (valid-specifier-domain-p locale) (bufferp locale))) (domain (and do-later-stages (derive-domain-from-locale locale (quote window-system) ffpdev))) (check-differences (and unfrobbed-face frobbed-face domain (not (memq (face-name face) (quote (default bold italic bold-italic)))))) (orig-instance (and check-differences (face-property-instance face win-prop domain)))) (setq face (get-face face)) (map-over-locales locale) (if do-later-stages (progn (if (global-locale locale) (setq locale (quote global))) (let (do-something) (cl-block-wrapper (catch (quote --cl-block-nil--) (let* ((G25570 (cons win-prop tty-props)) (prop nil) (propspec nil) (devtype-spec nil)) (while (consp G25570) (setq prop (car G25570)) (setq propspec (get face prop)) (setq devtype-spec (if (eq prop win-prop) (quote window-system) (quote tty))) (if propspec (progn (or (specifier-spec-list propspec locale) (let ((doit (derive-specifier-specs-from-locale propspec locale devtype-spec ffpdev (and (not tag-set) (not exact-p))))) (if (and (not doit) (eq locale (quote global))) (error "No fallback for specifier property %s in face %s???" prop face)) (when doit (add-spec-list-to-specifier propspec (list (cons locale (add-tag-to-inst-list doit (append (if (listp tag-set) tag-set (list tag-set)) (if (eq devtype-spec (quote tty)) (quote (tty)))))))) (setq do-something t)))))) (setq G25570 (cdr G25570))) nil))) (if do-something (map-over-locales (or (global-locale locale) locale)))) (if (and check-differences (let ((new-instance (face-property-instance face win-prop domain))) (and (equal orig-instance new-instance) (equal orig-instance (face-property-instance unfrobbed-face win-prop domain))))) (set-face-property face win-prop (vector frobbed-face) (or (global-locale locale) locale) tag-set)))))) (if --letf-bound--25569 (fset (quote map-over-locales) --letf-save--25568) (fmakunbound (quote map-over-locales)))))) (if --letf-bound--25565 (fset (quote frob-locale) --letf-save--25564) (fmakunbound (quote frob-locale)))))) (if --letf-bound--25561 (fset (quote frob-face-inst-list) --letf-save--25560) (fmakunbound (quote frob-face-inst-list)))))) (if --letf-bound--25557 (fset (quote global-locale) --letf-save--25556) (fmakunbound (quote global-locale)))))) nil) byte-compile-progn((progn (fset (quote nil-instantiator-ok) (function (lambda (inst devtype-spec) "\nCommon Lisp lambda list:\n (lambda INST DEVTYPE-SPEC)\n\n" (block nil-instantiator-ok (or inst (eq devtype-spec (quote tty))))))) (let* ((--letf-bound--25557 (fboundp (quote global-locale))) (--letf-save--25556 (and --letf-bound--25557 (symbol-function (quote global-locale))))) (unwind-protect (progn (fset (quote global-locale) (function (lambda (locale) "\nCommon Lisp lambda list:\n (lambda LOCALE)\n\n" (block global-locale (and (memq locale (quote (all nil global))) (quote global)))))) (let* ((--letf-bound--25561 (fboundp (quote frob-face-inst-list))) (--letf-save--25560 (and --letf-bound--25561 (symbol-function (quote frob-face-inst-list))))) (unwind-protect (progn (fset (quote frob-face-inst-list) (function (lambda (locale inst-list prop devtype-spec) "\nCommon Lisp lambda list:\n (lambda LOCALE INST-LIST PROP DEVTYPE-SPEC)\n\n" (block frob-face-inst-list (let* ((ffpdev Face-frob-property-device-considered-current) (results (loop for (tag-set . x) in inst-list for devtype = (derive-device-type-from-locale-and-tag-set locale tag-set devtype-spec ffpdev) if devtype if (let* ((mapper (if (functionp frob-mapping) frob-mapping (plist-get frob-mapping devtype))) (result (cond ((vectorp x) (let ((change-to (cdr (assoc x standard-face-mapping)))) (cond ((or change-to (null (length x))) (list (cons tag-set (cond ((eq change-to t) x) (change-to) (t x))))) (t (let* ((subprop (if (> (length x) 1) (elt x 1) prop)) (subinsts (frob-face-inst-list locale (cdar (specifier-spec-list (face-property (elt x 0) subprop))) subprop devtype-spec))) (add-tag-to-inst-list subinsts tag-set)))))) (t (let ((value (if (eq devtype-spec (quote tty)) (funcall mapper x) (funcall mapper x (derive-domain-from-locale locale devtype-spec ffpdev))))) (and (nil-instantiator-ok value devtype-spec) (list (cons tag-set value)))))))) (if (and (eq (quote tty) devtype-spec) (not (or (eq (quote tty) tag-set) (memq (quote tty) tag-set)))) (nconc (add-tag-to-inst-list result (quote tty)) (list (cons tag-set x))) result)) nconc it))) (delete-duplicates results :test (function equal))))))) (let* ((--letf-bound--25565 (fboundp (quote frob-locale))) (--letf-save--25564 (and --letf-bound--25565 (symbol-function (quote frob-locale))))) (unwind-protect (progn (fset (quote frob-locale) (function (lambda (sp locale inst-list thunk) "\nCommon Lisp lambda list:\n (lambda SP LOCALE INST-LIST THUNK)\n\n" (block frob-locale (let ((newinst (frob-face-inst-list locale inst-list (car thunk) (cdr thunk)))) (remove-specifier sp locale tag-set exact-p) (add-spec-list-to-specifier sp (list (cons locale newinst)))) nil)))) (let* ((--letf-bound--25569 (fboundp (quote map-over-locales))) (--letf-save--25568 (and --letf-bound--25569 (symbol-function (quote map-over-locales))))) (unwind-protect (progn (fset (quote map-over-locales) (function (lambda (locale) "\nCommon Lisp lambda list:\n (lambda LOCALE)\n\n" (block map-over-locales (map-specifier (get face win-prop) (function frob-locale) locale (cons win-prop (quote window-system)) tag-set exact-p) (loop for prop in tty-props do (map-specifier (get face prop) (function frob-locale) locale (cons prop (quote tty)) tag-set exact-p)))))) (let* ((ffpdev Face-frob-property-device-considered-current) (do-later-stages (or (global-locale locale) (valid-specifier-domain-p locale) (bufferp locale))) (domain (and do-later-stages (derive-domain-from-locale locale (quote window-system) ffpdev))) (check-differences (and unfrobbed-face frobbed-face domain (not (memq (face-name face) (quote (default bold italic bold-italic)))))) (orig-instance (and check-differences (face-property-instance face win-prop domain)))) (setq face (get-face face)) (map-over-locales locale) (if do-later-stages (progn (if (global-locale locale) (setq locale (quote global))) (let (do-something) (cl-block-wrapper (catch (quote --cl-block-nil--) (let* ((G25570 (cons win-prop tty-props)) (prop nil) (propspec nil) (devtype-spec nil)) (while (consp G25570) (setq prop (car G25570)) (setq propspec (get face prop)) (setq devtype-spec (if (eq prop win-prop) (quote window-system) (quote tty))) (if propspec (progn (or (specifier-spec-list propspec locale) (let ((doit (derive-specifier-specs-from-locale propspec locale devtype-spec ffpdev (and (not tag-set) (not exact-p))))) (if (and (not doit) (eq locale (quote global))) (error "No fallback for specifier property %s in face %s???" prop face)) (when doit (add-spec-list-to-specifier propspec (list (cons locale (add-tag-to-inst-list doit (append (if (listp tag-set) tag-set (list tag-set)) (if (eq devtype-spec (quote tty)) (quote (tty)))))))) (setq do-something t)))))) (setq G25570 (cdr G25570))) nil))) (if do-something (map-over-locales (or (global-locale locale) locale)))) (if (and check-differences (let ((new-instance (face-property-instance face win-prop domain))) (and (equal orig-instance new-instance) (equal orig-instance (face-property-instance unfrobbed-face win-prop domain))))) (set-face-property face win-prop (vector frobbed-face) (or (global-locale locale) locale) tag-set)))))) (if --letf-bound--25569 (fset (quote map-over-locales) --letf-save--25568) (fmakunbound (quote map-over-locales)))))) (if --letf-bound--25565 (fset (quote frob-locale) --letf-save--25564) (fmakunbound (quote frob-locale)))))) (if --letf-bound--25561 (fset (quote frob-face-inst-list) --letf-save--25560) (fmakunbound (quote frob-face-inst-list)))))) (if --letf-bound--25557 (fset (quote global-locale) --letf-save--25556) (fmakunbound (quote global-locale))))))) byte-compile-form((progn (fset (quote nil-instantiator-ok) (function (lambda (inst devtype-spec) "\nCommon Lisp lambda list:\n (lambda INST DEVTYPE-SPEC)\n\n" (block nil-instantiator-ok (or inst (eq devtype-spec (quote tty))))))) (let* ((--letf-bound--25557 (fboundp (quote global-locale))) (--letf-save--25556 (and --letf-bound--25557 (symbol-function (quote global-locale))))) (unwind-protect (progn (fset (quote global-locale) (function (lambda (locale) "\nCommon Lisp lambda list:\n (lambda LOCALE)\n\n" (block global-locale (and (memq locale (quote (all nil global))) (quote global)))))) (let* ((--letf-bound--25561 (fboundp (quote frob-face-inst-list))) (--letf-save--25560 (and --letf-bound--25561 (symbol-function (quote frob-face-inst-list))))) (unwind-protect (progn (fset (quote frob-face-inst-list) (function (lambda (locale inst-list prop devtype-spec) "\nCommon Lisp lambda list:\n (lambda LOCALE INST-LIST PROP DEVTYPE-SPEC)\n\n" (block frob-face-inst-list (let* ((ffpdev Face-frob-property-device-considered-current) (results (loop for (tag-set . x) in inst-list for devtype = (derive-device-type-from-locale-and-tag-set locale tag-set devtype-spec ffpdev) if devtype if (let* ((mapper (if (functionp frob-mapping) frob-mapping (plist-get frob-mapping devtype))) (result (cond ((vectorp x) (let ((change-to (cdr (assoc x standard-face-mapping)))) (cond ((or change-to (null (length x))) (list (cons tag-set (cond ((eq change-to t) x) (change-to) (t x))))) (t (let* ((subprop (if (> (length x) 1) (elt x 1) prop)) (subinsts (frob-face-inst-list locale (cdar (specifier-spec-list (face-property (elt x 0) subprop))) subprop devtype-spec))) (add-tag-to-inst-list subinsts tag-set)))))) (t (let ((value (if (eq devtype-spec (quote tty)) (funcall mapper x) (funcall mapper x (derive-domain-from-locale locale devtype-spec ffpdev))))) (and (nil-instantiator-ok value devtype-spec) (list (cons tag-set value)))))))) (if (and (eq (quote tty) devtype-spec) (not (or (eq (quote tty) tag-set) (memq (quote tty) tag-set)))) (nconc (add-tag-to-inst-list result (quote tty)) (list (cons tag-set x))) result)) nconc it))) (delete-duplicates results :test (function equal))))))) (let* ((--letf-bound--25565 (fboundp (quote frob-locale))) (--letf-save--25564 (and --letf-bound--25565 (symbol-function (quote frob-locale))))) (unwind-protect (progn (fset (quote frob-locale) (function (lambda (sp locale inst-list thunk) "\nCommon Lisp lambda list:\n (lambda SP LOCALE INST-LIST THUNK)\n\n" (block frob-locale (let ((newinst (frob-face-inst-list locale inst-list (car thunk) (cdr thunk)))) (remove-specifier sp locale tag-set exact-p) (add-spec-list-to-specifier sp (list (cons locale newinst)))) nil)))) (let* ((--letf-bound--25569 (fboundp (quote map-over-locales))) (--letf-save--25568 (and --letf-bound--25569 (symbol-function (quote map-over-locales))))) (unwind-protect (progn (fset (quote map-over-locales) (function (lambda (locale) "\nCommon Lisp lambda list:\n (lambda LOCALE)\n\n" (block map-over-locales (map-specifier (get face win-prop) (function frob-locale) locale (cons win-prop (quote window-system)) tag-set exact-p) (loop for prop in tty-props do (map-specifier (get face prop) (function frob-locale) locale (cons prop (quote tty)) tag-set exact-p)))))) (let* ((ffpdev Face-frob-property-device-considered-current) (do-later-stages (or (global-locale locale) (valid-specifier-domain-p locale) (bufferp locale))) (domain (and do-later-stages (derive-domain-from-locale locale (quote window-system) ffpdev))) (check-differences (and unfrobbed-face frobbed-face domain (not (memq (face-name face) (quote (default bold italic bold-italic)))))) (orig-instance (and check-differences (face-property-instance face win-prop domain)))) (setq face (get-face face)) (map-over-locales locale) (if do-later-stages (progn (if (global-locale locale) (setq locale (quote global))) (let (do-something) (cl-block-wrapper (catch (quote --cl-block-nil--) (let* ((G25570 (cons win-prop tty-props)) (prop nil) (propspec nil) (devtype-spec nil)) (while (consp G25570) (setq prop (car G25570)) (setq propspec (get face prop)) (setq devtype-spec (if (eq prop win-prop) (quote window-system) (quote tty))) (if propspec (progn (or (specifier-spec-list propspec locale) (let ((doit (derive-specifier-specs-from-locale propspec locale devtype-spec ffpdev (and (not tag-set) (not exact-p))))) (if (and (not doit) (eq locale (quote global))) (error "No fallback for specifier property %s in face %s???" prop face)) (when doit (add-spec-list-to-specifier propspec (list (cons locale (add-tag-to-inst-list doit (append (if (listp tag-set) tag-set (list tag-set)) (if (eq devtype-spec (quote tty)) (quote (tty)))))))) (setq do-something t)))))) (setq G25570 (cdr G25570))) nil))) (if do-something (map-over-locales (or (global-locale locale) locale)))) (if (and check-differences (let ((new-instance (face-property-instance face win-prop domain))) (and (equal orig-instance new-instance) (equal orig-instance (face-property-instance unfrobbed-face win-prop domain))))) (set-face-property face win-prop (vector frobbed-face) (or (global-locale locale) locale) tag-set)))))) (if --letf-bound--25569 (fset (quote map-over-locales) --letf-save--25568) (fmakunbound (quote map-over-locales)))))) (if --letf-bound--25565 (fset (quote frob-locale) --letf-save--25564) (fmakunbound (quote frob-locale)))))) (if --letf-bound--25561 (fset (quote frob-face-inst-list) --letf-save--25560) (fmakunbound (quote frob-face-inst-list)))))) (if --letf-bound--25557 (fset (quote global-locale) --letf-save--25556) (fmakunbound (quote global-locale)))))) nil) byte-compile-unwind-protect((unwind-protect (progn (fset (quote nil-instantiator-ok) (function (lambda (inst devtype-spec) "\nCommon Lisp lambda list:\n (lambda INST DEVTYPE-SPEC)\n\n" (block nil-instantiator-ok (or inst (eq devtype-spec (quote tty))))))) (let* ((--letf-bound--25557 (fboundp (quote global-locale))) (--letf-save--25556 (and --letf-bound--25557 (symbol-function (quote global-locale))))) (unwind-protect (progn (fset (quote global-locale) (function (lambda (locale) "\nCommon Lisp lambda list:\n (lambda LOCALE)\n\n" (block global-locale (and (memq locale (quote (all nil global))) (quote global)))))) (let* ((--letf-bound--25561 (fboundp (quote frob-face-inst-list))) (--letf-save--25560 (and --letf-bound--25561 (symbol-function (quote frob-face-inst-list))))) (unwind-protect (progn (fset (quote frob-face-inst-list) (function (lambda (locale inst-list prop devtype-spec) "\nCommon Lisp lambda list:\n (lambda LOCALE INST-LIST PROP DEVTYPE-SPEC)\n\n" (block frob-face-inst-list (let* ((ffpdev Face-frob-property-device-considered-current) (results (loop for (tag-set . x) in inst-list for devtype = (derive-device-type-from-locale-and-tag-set locale tag-set devtype-spec ffpdev) if devtype if (let* ((mapper (if (functionp frob-mapping) frob-mapping (plist-get frob-mapping devtype))) (result (cond ((vectorp x) (let ((change-to (cdr (assoc x standard-face-mapping)))) (cond ((or change-to (null (length x))) (list (cons tag-set (cond ((eq change-to t) x) (change-to) (t x))))) (t (let* ((subprop (if (> (length x) 1) (elt x 1) prop)) (subinsts (frob-face-inst-list locale (cdar (specifier-spec-list (face-property (elt x 0) subprop))) subprop devtype-spec))) (add-tag-to-inst-list subinsts tag-set)))))) (t (let ((value (if (eq devtype-spec (quote tty)) (funcall mapper x) (funcall mapper x (derive-domain-from-locale locale devtype-spec ffpdev))))) (and (nil-instantiator-ok value devtype-spec) (list (cons tag-set value)))))))) (if (and (eq (quote tty) devtype-spec) (not (or (eq (quote tty) tag-set) (memq (quote tty) tag-set)))) (nconc (add-tag-to-inst-list result (quote tty)) (list (cons tag-set x))) result)) nconc it))) (delete-duplicates results:test (function equal))))))) (let* ((--letf-bound--25565 (fboundp (quote frob-locale))) (--letf-save--25564 (and --letf-bound--25565 (symbol-function (quote frob-locale))))) (unwind-protect (progn (fset (quote frob-locale) (function (lambda (sp locale inst-list thunk) "\nCommon Lisp lambda list:\n (lambda SP LOCALE INST-LIST THUNK)\n\n" (block frob-locale (let ((newinst (frob-face-inst-list locale inst-list (car thunk) (cdr thunk)))) (remove-specifier sp locale tag-set exact-p) (add-spec-list-to-specifier sp (list (cons locale newinst)))) nil)))) (let* ((--letf-bound--25569 (fboundp (quote map-over-locales))) (--letf-save--25568 (and --letf-bound--25569 (symbol-function (quote map-over-locales))))) (unwind-protect (progn (fset (quote map-over-locales) (function (lambda (locale) "\nCommon Lisp lambda list:\n (lambda LOCALE)\n\n" (block map-over-locales (map-specifier (get face win-prop) (function frob-locale) locale (cons win-prop (quote window-system)) tag-set exact-p) (loop for prop in tty-props do (map-specifier (get face prop) (function frob-locale) locale (cons prop (quote tty)) tag-set exact-p)))))) (let* ((ffpdev Face-frob-property-device-considered-current) (do-later-stages (or (global-locale locale) (valid-specifier-domain-p locale) (bufferp locale))) (domain (and do-later-stages (derive-domain-from-locale locale (quote window-system) ffpdev))) (check-differences (and unfrobbed-face frobbed-face domain (not (memq (face-name face) (quote (default bold italic bold-italic)))))) (orig-instance (and check-differences (face-property-instance face win-prop domain)))) (setq face (get-face face)) (map-over-locales locale) (if do-later-stages (progn (if (global-locale locale) (setq locale (quote global))) (let (do-something) (cl-block-wrapper (catch (quote --cl-block-nil--) (let* ((G25570 (cons win-prop tty-props)) (prop nil) (propspec nil) (devtype-spec nil)) (while (consp G25570) (setq prop (car G25570)) (setq propspec (get face prop)) (setq devtype-spec (if (eq prop win-prop) (quote window-system) (quote tty))) (if propspec (progn (or (specifier-spec-list propspec locale) (let ((doit (derive-specifier-specs-from-locale propspec locale devtype-spec ffpdev (and (not tag-set) (not exact-p))))) (if (and (not doit) (eq locale (quote global))) (error "No fallback for specifier property %s in face %s???" prop face)) (when doit (add-spec-list-to-specifier propspec (list (cons locale (add-tag-to-inst-list doit (append (if (listp tag-set) tag-set (list tag-set)) (if (eq devtype-spec (quote tty)) (quote (tty)))))))) (setq do-something t)))))) (setq G25570 (cdr G25570))) nil))) (if do-something (map-over-locales (or (global-locale locale) locale)))) (if (and check-differences (let ((new-instance (face-property-instance face win-prop domain))) (and (equal orig-instance new-instance) (equal orig-instance (face-property-instance unfrobbed-face win-prop domain))))) (set-face-property face win-prop (vector frobbed-face) (or (global-locale locale) locale) tag-set)))))) (if --letf-bound--25569 (fset (quote map-over-locales) --letf-save--25568) (fmakunbound (quote map-over-locales)))))) (if --letf-bound--25565 (fset (quote frob-locale) --letf-save--25564) (fmakunbound (quote frob-locale)))))) (if --letf-bound--25561 (fset (quote frob-face-inst-list) --letf-save--25560) (fmakunbound (quote frob-face-inst-list)))))) (if --letf-bound--25557 (fset (quote global-locale) --letf-save--25556) (fmakunbound (quote global-locale)))))) (if --letf-bound--25553 (fset (quote nil-instantiator-ok) --letf-save--25552) (fmakunbound (quote nil-instantiator-ok))))) byte-compile-form((unwind-protect (progn (fset (quote nil-instantiator-ok) (function (lambda (inst devtype-spec) "\nCommon Lisp lambda list:\n (lambda INST DEVTYPE-SPEC)\n\n" (block nil-instantiator-ok (or inst (eq devtype-spec (quote tty))))))) (let* ((--letf-bound--25557 (fboundp (quote global-locale))) (--letf-save--25556 (and --letf-bound--25557 (symbol-function (quote global-locale))))) (unwind-protect (progn (fset (quote global-locale) (function (lambda (locale) "\nCommon Lisp lambda list:\n (lambda LOCALE)\n\n" (block global-locale (and (memq locale (quote (all nil global))) (quote global)))))) (let* ((--letf-bound--25561 (fboundp (quote frob-face-inst-list))) (--letf-save--25560 (and --letf-bound--25561 (symbol-function (quote frob-face-inst-list))))) (unwind-protect (progn (fset (quote frob-face-inst-list) (function (lambda (locale inst-list prop devtype-spec) "\nCommon Lisp lambda list:\n (lambda LOCALE INST-LIST PROP DEVTYPE-SPEC)\n\n" (block frob-face-inst-list (let* ((ffpdev Face-frob-property-device-considered-current) (results (loop for (tag-set . x) in inst-list for devtype = (derive-device-type-from-locale-and-tag-set locale tag-set devtype-spec ffpdev) if devtype if (let* ((mapper (if (functionp frob-mapping) frob-mapping (plist-get frob-mapping devtype))) (result (cond ((vectorp x) (let ((change-to (cdr (assoc x standard-face-mapping)))) (cond ((or change-to (null (length x))) (list (cons tag-set (cond ((eq change-to t) x) (change-to) (t x))))) (t (let* ((subprop (if (> (length x) 1) (elt x 1) prop)) (subinsts (frob-face-inst-list locale (cdar (specifier-spec-list (face-property (elt x 0) subprop))) subprop devtype-spec))) (add-tag-to-inst-list subinsts tag-set)))))) (t (let ((value (if (eq devtype-spec (quote tty)) (funcall mapper x) (funcall mapper x (derive-domain-from-locale locale devtype-spec ffpdev))))) (and (nil-instantiator-ok value devtype-spec) (list (cons tag-set value)))))))) (if (and (eq (quote tty) devtype-spec) (not (or (eq (quote tty) tag-set) (memq (quote tty) tag-set)))) (nconc (add-tag-to-inst-list result (quote tty)) (list (cons tag-set x))) result)) nconc it))) (delete-duplicates results :test (function equal))))))) (let* ((--letf-bound--25565 (fboundp (quote frob-locale))) (--letf-save--25564 (and --letf-bound--25565 (symbol-function (quote frob-locale))))) (unwind-protect (progn (fset (quote frob-locale) (function (lambda (sp locale inst-list thunk) "\nCommon Lisp lambda list:\n (lambda SP LOCALE INST-LIST THUNK)\n\n" (block frob-locale (let ((newinst (frob-face-inst-list locale inst-list (car thunk) (cdr thunk)))) (remove-specifier sp locale tag-set exact-p) (add-spec-list-to-specifier sp (list (cons locale newinst)))) nil)))) (let* ((--letf-bound--25569 (fboundp (quote map-over-locales))) (--letf-save--25568 (and --letf-bound--25569 (symbol-function (quote map-over-locales))))) (unwind-protect (progn (fset (quote map-over-locales) (function (lambda (locale) "\nCommon Lisp lambda list:\n (lambda LOCALE)\n\n" (block map-over-locales (map-specifier (get face win-prop) (function frob-locale) locale (cons win-prop (quote window-system)) tag-set exact-p) (loop for prop in tty-props do (map-specifier (get face prop) (function frob-locale) locale (cons prop (quote tty)) tag-set exact-p)))))) (let* ((ffpdev Face-frob-property-device-considered-current) (do-later-stages (or (global-locale locale) (valid-specifier-domain-p locale) (bufferp locale))) (domain (and do-later-stages (derive-domain-from-locale locale (quote window-system) ffpdev))) (check-differences (and unfrobbed-face frobbed-face domain (not (memq (face-name face) (quote (default bold italic bold-italic)))))) (orig-instance (and check-differences (face-property-instance face win-prop domain)))) (setq face (get-face face)) (map-over-locales locale) (if do-later-stages (progn (if (global-locale locale) (setq locale (quote global))) (let (do-something) (cl-block-wrapper (catch (quote --cl-block-nil--) (let* ((G25570 (cons win-prop tty-props)) (prop nil) (propspec nil) (devtype-spec nil)) (while (consp G25570) (setq prop (car G25570)) (setq propspec (get face prop)) (setq devtype-spec (if (eq prop win-prop) (quote window-system) (quote tty))) (if propspec (progn (or (specifier-spec-list propspec locale) (let ((doit (derive-specifier-specs-from-locale propspec locale devtype-spec ffpdev (and (not tag-set) (not exact-p))))) (if (and (not doit) (eq locale (quote global))) (error "No fallback for specifier property %s in face %s???" prop face)) (when doit (add-spec-list-to-specifier propspec (list (cons locale (add-tag-to-inst-list doit (append (if (listp tag-set) tag-set (list tag-set)) (if (eq devtype-spec (quote tty)) (quote (tty)))))))) (setq do-something t)))))) (setq G25570 (cdr G25570))) nil))) (if do-something (map-over-locales (or (global-locale locale) locale)))) (if (and check-differences (let ((new-instance (face-property-instance face win-prop domain))) (and (equal orig-instance new-instance) (equal orig-instance (face-property-instance unfrobbed-face win-prop domain))))) (set-face-property face win-prop (vector frobbed-face) (or (global-locale locale) locale) tag-set)))))) (if --letf-bound--25569 (fset (quote map-over-locales) --letf-save--25568) (fmakunbound (quote map-over-locales)))))) (if --letf-bound--25565 (fset (quote frob-locale) --letf-save--25564) (fmakunbound (quote frob-locale)))))) (if --letf-bound--25561 (fset (quote frob-face-inst-list) --letf-save--25560) (fmakunbound (quote frob-face-inst-list)))))) (if --letf-bound--25557 (fset (quote global-locale) --letf-save--25556) (fmakunbound (quote global-locale)))))) (if --letf-bound--25553 (fset (quote nil-instantiator-ok) --letf-save--25552) (fmakunbound (quote nil-instantiator-ok)))) nil) byte-compile-body(((unwind-protect (progn (fset (quote nil-instantiator-ok) (function (lambda (inst devtype-spec) "\nCommon Lisp lambda list:\n (lambda INST DEVTYPE-SPEC)\n\n" (block nil-instantiator-ok (or inst (eq devtype-spec (quote tty))))))) (let* ((--letf-bound--25557 (fboundp (quote global-locale))) (--letf-save--25556 (and --letf-bound--25557 (symbol-function (quote global-locale))))) (unwind-protect (progn (fset (quote global-locale) (function (lambda (locale) "\nCommon Lisp lambda list:\n (lambda LOCALE)\n\n" (block global-locale (and (memq locale (quote (all nil global))) (quote global)))))) (let* ((--letf-bound--25561 (fboundp (quote frob-face-inst-list))) (--letf-save--25560 (and --letf-bound--25561 (symbol-function (quote frob-face-inst-list))))) (unwind-protect (progn (fset (quote frob-face-inst-list) (function (lambda (locale inst-list prop devtype-spec) "\nCommon Lisp lambda list:\n (lambda LOCALE INST-LIST PROP DEVTYPE-SPEC)\n\n" (block frob-face-inst-list (let* ((ffpdev Face-frob-property-device-considered-current) (results (loop for (tag-set . x) in inst-list for devtype = (derive-device-type-from-locale-and-tag-set locale tag-set devtype-spec ffpdev) if devtype if (let* ((mapper (if (functionp frob-mapping) frob-mapping (plist-get frob-mapping devtype))) (result (cond ((vectorp x) (let ((change-to (cdr (assoc x standard-face-mapping)))) (cond ((or change-to (null (length x))) (list (cons tag-set (cond ((eq change-to t) x) (change-to) (t x))))) (t (let* ((subprop (if (> (length x) 1) (elt x 1) prop)) (subinsts (frob-face-inst-list locale (cdar (specifier-spec-list (face-property (elt x 0) subprop))) subprop devtype-spec))) (add-tag-to-inst-list subinsts tag-set)))))) (t (let ((value (if (eq devtype-spec (quote tty)) (funcall mapper x) (funcall mapper x (derive-domain-from-locale locale devtype-spec ffpdev))))) (and (nil-instantiator-ok value devtype-spec) (list (cons tag-set value)))))))) (if (and (eq (quote tty) devtype-spec) (not (or (eq (quote tty) tag-set) (memq (quote tty) tag-set)))) (nconc (add-tag-to-inst-list result (quote tty)) (list (cons tag-set x))) result)) nconc it))) (delete-duplicates results :test (function equal))))))) (let* ((--letf-bound--25565 (fboundp (quote frob-locale))) (--letf-save--25564 (and --letf-bound--25565 (symbol-function (quote frob-locale))))) (unwind-protect (progn (fset (quote frob-locale) (function (lambda (sp locale inst-list thunk) "\nCommon Lisp lambda list:\n (lambda SP LOCALE INST-LIST THUNK)\n\n" (block frob-locale (let ((newinst (frob-face-inst-list locale inst-list (car thunk) (cdr thunk)))) (remove-specifier sp locale tag-set exact-p) (add-spec-list-to-specifier sp (list (cons locale newinst)))) nil)))) (let* ((--letf-bound--25569 (fboundp (quote map-over-locales))) (--letf-save--25568 (and --letf-bound--25569 (symbol-function (quote map-over-locales))))) (unwind-protect (progn (fset (quote map-over-locales) (function (lambda (locale) "\nCommon Lisp lambda list:\n (lambda LOCALE)\n\n" (block map-over-locales (map-specifier (get face win-prop) (function frob-locale) locale (cons win-prop (quote window-system)) tag-set exact-p) (loop for prop in tty-props do (map-specifier (get face prop) (function frob-locale) locale (cons prop (quote tty)) tag-set exact-p)))))) (let* ((ffpdev Face-frob-property-device-considered-current) (do-later-stages (or (global-locale locale) (valid-specifier-domain-p locale) (bufferp locale))) (domain (and do-later-stages (derive-domain-from-locale locale (quote window-system) ffpdev))) (check-differences (and unfrobbed-face frobbed-face domain (not (memq (face-name face) (quote (default bold italic bold-italic)))))) (orig-instance (and check-differences (face-property-instance face win-prop domain)))) (setq face (get-face face)) (map-over-locales locale) (if do-later-stages (progn (if (global-locale locale) (setq locale (quote global))) (let (do-something) (cl-block-wrapper (catch (quote --cl-block-nil--) (let* ((G25570 (cons win-prop tty-props)) (prop nil) (propspec nil) (devtype-spec nil)) (while (consp G25570) (setq prop (car G25570)) (setq propspec (get face prop)) (setq devtype-spec (if (eq prop win-prop) (quote window-system) (quote tty))) (if propspec (progn (or (specifier-spec-list propspec locale) (let ((doit (derive-specifier-specs-from-locale propspec locale devtype-spec ffpdev (and (not tag-set) (not exact-p))))) (if (and (not doit) (eq locale (quote global))) (error "No fallback for specifier property %s in face %s???" prop face)) (when doit (add-spec-list-to-specifier propspec (list (cons locale (add-tag-to-inst-list doit (append (if (listp tag-set) tag-set (list tag-set)) (if (eq devtype-spec (quote tty)) (quote (tty)))))))) (setq do-something t)))))) (setq G25570 (cdr G25570))) nil))) (if do-something (map-over-locales (or (global-locale locale) locale)))) (if (and check-differences (let ((new-instance (face-property-instance face win-prop domain))) (and (equal orig-instance new-instance) (equal orig-instance (face-property-instance unfrobbed-face win-prop domain))))) (set-face-property face win-prop (vector frobbed-face) (or (global-locale locale) locale) tag-set)))))) (if --letf-bound--25569 (fset (quote map-over-locales) --letf-save--25568) (fmakunbound (quote map-over-locales)))))) (if --letf-bound--25565 (fset (quote frob-locale) --letf-save--25564) (fmakunbound (quote frob-locale)))))) (if --letf-bound--25561 (fset (quote frob-face-inst-list) --letf-save--25560) (fmakunbound (quote frob-face-inst-list)))))) (if --letf-bound--25557 (fset (quote global-locale) --letf-save--25556) (fmakunbound (quote global-locale)))))) (if --letf-bound--25553 (fset (quote nil-instantiator-ok) --letf-save--25552) (fmakunbound (quote nil-instantiator-ok))))) nil) byte-compile-let*((let* ((--letf-bound--25553 (fboundp (quote nil-instantiator-ok))) (--letf-save--25552 (and --letf-bound--25553 (symbol-function (quote nil-instantiator-ok))))) (unwind-protect (progn (fset (quote nil-instantiator-ok) (function (lambda (inst devtype-spec) "\nCommon Lisp lambda list:\n (lambda INST DEVTYPE-SPEC)\n\n" (block nil-instantiator-ok (or inst (eq devtype-spec (quote tty))))))) (let* ((--letf-bound--25557 (fboundp (quote global-locale))) (--letf-save--25556 (and --letf-bound--25557 (symbol-function (quote global-locale))))) (unwind-protect (progn (fset (quote global-locale) (function (lambda (locale) "\nCommon Lisp lambda list:\n (lambda LOCALE)\n\n" (block global-locale (and (memq locale (quote (all nil global))) (quote global)))))) (let* ((--letf-bound--25561 (fboundp (quote frob-face-inst-list))) (--letf-save--25560 (and --letf-bound--25561 (symbol-function (quote frob-face-inst-list))))) (unwind-protect (progn (fset (quote frob-face-inst-list) (function (lambda (locale inst-list prop devtype-spec) "\nCommon Lisp lambda list:\n (lambda LOCALE INST-LIST PROP DEVTYPE-SPEC)\n\n" (block frob-face-inst-list (let* ((ffpdev Face-frob-property-device-considered-current) (results (loop for (tag-set . x) in inst-list for devtype = (derive-device-type-from-locale-and-tag-set locale tag-set devtype-spec ffpdev) if devtype if (let* ((mapper (if (functionp frob-mapping) frob-mapping (plist-get frob-mapping devtype))) (result (cond ((vectorp x) (let ((change-to (cdr (assoc x standard-face-mapping)))) (cond ((or change-to (null (length x))) (list (cons tag-set (cond ((eq change-to t) x) (change-to) (t x))))) (t (let* ((subprop (if (> (length x) 1) (elt x 1) prop)) (subinsts (frob-face-inst-list locale (cdar (specifier-spec-list (face-property (elt x 0) subprop))) subprop devtype-spec))) (add-tag-to-inst-list subinsts tag-set)))))) (t (let ((value (if (eq devtype-spec (quote tty)) (funcall mapper x) (funcall mapper x (derive-domain-from-locale locale devtype-spec ffpdev))))) (and (nil-instantiator-ok value devtype-spec) (list (cons tag-set value)))))))) (if (and (eq (quote tty) devtype-spec) (not (or (eq (quote tty) tag-set) (memq (quote tty) tag-set)))) (nconc (add-tag-to-inst-list result (quote tty)) (list (cons tag-set x))) result)) nconc it))) (delete-duplicates results :test (function equal))))))) (let* ((--letf-bound--25565 (fboundp (quote frob-locale))) (--letf-save--25564 (and --letf-bound--25565 (symbol-function (quote frob-locale))))) (unwind-protect (progn (fset (quote frob-locale) (function (lambda (sp locale inst-list thunk) "\nCommon Lisp lambda list:\n (lambda SP LOCALE INST-LIST THUNK)\n\n" (block frob-locale (let ((newinst (frob-face-inst-list locale inst-list (car thunk) (cdr thunk)))) (remove-specifier sp locale tag-set exact-p) (add-spec-list-to-specifier sp (list (cons locale newinst)))) nil)))) (let* ((--letf-bound--25569 (fboundp (quote map-over-locales))) (--letf-save--25568 (and --letf-bound--25569 (symbol-function (quote map-over-locales))))) (unwind-protect (progn (fset (quote map-over-locales) (function (lambda (locale) "\nCommon Lisp lambda list:\n (lambda LOCALE)\n\n" (block map-over-locales (map-specifier (get face win-prop) (function frob-locale) locale (cons win-prop (quote window-system)) tag-set exact-p) (loop for prop in tty-props do (map-specifier (get face prop) (function frob-locale) locale (cons prop (quote tty)) tag-set exact-p)))))) (let* ((ffpdev Face-frob-property-device-considered-current) (do-later-stages (or (global-locale locale) (valid-specifier-domain-p locale) (bufferp locale))) (domain (and do-later-stages (derive-domain-from-locale locale (quote window-system) ffpdev))) (check-differences (and unfrobbed-face frobbed-face domain (not (memq (face-name face) (quote (default bold italic bold-italic)))))) (orig-instance (and check-differences (face-property-instance face win-prop domain)))) (setq face (get-face face)) (map-over-locales locale) (if do-later-stages (progn (if (global-locale locale) (setq locale (quote global))) (let (do-something) (cl-block-wrapper (catch (quote --cl-block-nil--) (let* ((G25570 (cons win-prop tty-props)) (prop nil) (propspec nil) (devtype-spec nil)) (while (consp G25570) (setq prop (car G25570)) (setq propspec (get face prop)) (setq devtype-spec (if (eq prop win-prop) (quote window-system) (quote tty))) (if propspec (progn (or (specifier-spec-list propspec locale) (let ((doit (derive-specifier-specs-from-locale propspec locale devtype-spec ffpdev (and (not tag-set) (not exact-p))))) (if (and (not doit) (eq locale (quote global))) (error "No fallback for specifier property %s in face %s???" prop face)) (when doit (add-spec-list-to-specifier propspec (list (cons locale (add-tag-to-inst-list doit (append (if (listp tag-set) tag-set (list tag-set)) (if (eq devtype-spec (quote tty)) (quote (tty)))))))) (setq do-something t)))))) (setq G25570 (cdr G25570))) nil))) (if do-something (map-over-locales (or (global-locale locale) locale)))) (if (and check-differences (let ((new-instance (face-property-instance face win-prop domain))) (and (equal orig-instance new-instance) (equal orig-instance (face-property-instance unfrobbed-face win-prop domain))))) (set-face-property face win-prop (vector frobbed-face) (or (global-locale locale) locale) tag-set)))))) (if --letf-bound--25569 (fset (quote map-over-locales) --letf-save--25568) (fmakunbound (quote map-over-locales)))))) (if --letf-bound--25565 (fset (quote frob-locale) --letf-save--25564) (fmakunbound (quote frob-locale)))))) (if --letf-bound--25561 (fset (quote frob-face-inst-list) --letf-save--25560) (fmakunbound (quote frob-face-inst-list)))))) (if --letf-bound--25557 (fset (quote global-locale) --letf-save--25556) (fmakunbound (quote global-locale)))))) (if --letf-bound--25553 (fset (quote nil-instantiator-ok) --letf-save--25552) (fmakunbound (quote nil-instantiator-ok)))))) byte-compile-form((let* ((--letf-bound--25553 (fboundp (quote nil-instantiator-ok))) (--letf-save--25552 (and --letf-bound--25553 (symbol-function (quote nil-instantiator-ok))))) (unwind-protect (progn (fset (quote nil-instantiator-ok) (function (lambda (inst devtype-spec) "\nCommon Lisp lambda list:\n (lambda INST DEVTYPE-SPEC)\n\n" (block nil-instantiator-ok (or inst (eq devtype-spec (quote tty))))))) (let* ((--letf-bound--25557 (fboundp (quote global-locale))) (--letf-save--25556 (and --letf-bound--25557 (symbol-function (quote global-locale))))) (unwind-protect (progn (fset (quote global-locale) (function (lambda (locale) "\nCommon Lisp lambda list:\n (lambda LOCALE)\n\n" (block global-locale (and (memq locale (quote (all nil global))) (quote global)))))) (let* ((--letf-bound--25561 (fboundp (quote frob-face-inst-list))) (--letf-save--25560 (and --letf-bound--25561 (symbol-function (quote frob-face-inst-list))))) (unwind-protect (progn (fset (quote frob-face-inst-list) (function (lambda (locale inst-list prop devtype-spec) "\nCommon Lisp lambda list:\n (lambda LOCALE INST-LIST PROP DEVTYPE-SPEC)\n\n" (block frob-face-inst-list (let* ((ffpdev Face-frob-property-device-considered-current) (results (loop for (tag-set . x) in inst-list for devtype = (derive-device-type-from-locale-and-tag-set locale tag-set devtype-spec ffpdev) if devtype if (let* ((mapper (if (functionp frob-mapping) frob-mapping (plist-get frob-mapping devtype))) (result (cond ((vectorp x) (let ((change-to (cdr (assoc x standard-face-mapping)))) (cond ((or change-to (null (length x))) (list (cons tag-set (cond ((eq change-to t) x) (change-to) (t x))))) (t (let* ((subprop (if (> (length x) 1) (elt x 1) prop)) (subinsts (frob-face-inst-list locale (cdar (specifier-spec-list (face-property (elt x 0) subprop))) subprop devtype-spec))) (add-tag-to-inst-list subinsts tag-set)))))) (t (let ((value (if (eq devtype-spec (quote tty)) (funcall mapper x) (funcall mapper x (derive-domain-from-locale locale devtype-spec ffpdev))))) (and (nil-instantiator-ok value devtype-spec) (list (cons tag-set value)))))))) (if (and (eq (quote tty) devtype-spec) (not (or (eq (quote tty) tag-set) (memq (quote tty) tag-set)))) (nconc (add-tag-to-inst-list result (quote tty)) (list (cons tag-set x))) result)) nconc it))) (delete-duplicates results :test (function equal))))))) (let* ((--letf-bound--25565 (fboundp (quote frob-locale))) (--letf-save--25564 (and --letf-bound--25565 (symbol-function (quote frob-locale))))) (unwind-protect (progn (fset (quote frob-locale) (function (lambda (sp locale inst-list thunk) "\nCommon Lisp lambda list:\n (lambda SP LOCALE INST-LIST THUNK)\n\n" (block frob-locale (let ((newinst (frob-face-inst-list locale inst-list (car thunk) (cdr thunk)))) (remove-specifier sp locale tag-set exact-p) (add-spec-list-to-specifier sp (list (cons locale newinst)))) nil)))) (let* ((--letf-bound--25569 (fboundp (quote map-over-locales))) (--letf-save--25568 (and --letf-bound--25569 (symbol-function (quote map-over-locales))))) (unwind-protect (progn (fset (quote map-over-locales) (function (lambda (locale) "\nCommon Lisp lambda list:\n (lambda LOCALE)\n\n" (block map-over-locales (map-specifier (get face win-prop) (function frob-locale) locale (cons win-prop (quote window-system)) tag-set exact-p) (loop for prop in tty-props do (map-specifier (get face prop) (function frob-locale) locale (cons prop (quote tty)) tag-set exact-p)))))) (let* ((ffpdev Face-frob-property-device-considered-current) (do-later-stages (or (global-locale locale) (valid-specifier-domain-p locale) (bufferp locale))) (domain (and do-later-stages (derive-domain-from-locale locale (quote window-system) ffpdev))) (check-differences (and unfrobbed-face frobbed-face domain (not (memq (face-name face) (quote (default bold italic bold-italic)))))) (orig-instance (and check-differences (face-property-instance face win-prop domain)))) (setq face (get-face face)) (map-over-locales locale) (if do-later-stages (progn (if (global-locale locale) (setq locale (quote global))) (let (do-something) (cl-block-wrapper (catch (quote --cl-block-nil--) (let* ((G25570 (cons win-prop tty-props)) (prop nil) (propspec nil) (devtype-spec nil)) (while (consp G25570) (setq prop (car G25570)) (setq propspec (get face prop)) (setq devtype-spec (if (eq prop win-prop) (quote window-system) (quote tty))) (if propspec (progn (or (specifier-spec-list propspec locale) (let ((doit (derive-specifier-specs-from-locale propspec locale devtype-spec ffpdev (and (not tag-set) (not exact-p))))) (if (and (not doit) (eq locale (quote global))) (error "No fallback for specifier property %s in face %s???" prop face)) (when doit (add-spec-list-to-specifier propspec (list (cons locale (add-tag-to-inst-list doit (append (if (listp tag-set) tag-set (list tag-set)) (if (eq devtype-spec (quote tty)) (quote (tty)))))))) (setq do-something t)))))) (setq G25570 (cdr G25570))) nil))) (if do-something (map-over-locales (or (global-locale locale) locale)))) (if (and check-differences (let ((new-instance (face-property-instance face win-prop domain))) (and (equal orig-instance new-instance) (equal orig-instance (face-property-instance unfrobbed-face win-prop domain))))) (set-face-property face win-prop (vector frobbed-face) (or (global-locale locale) locale) tag-set)))))) (if --letf-bound--25569 (fset (quote map-over-locales) --letf-save--25568) (fmakunbound (quote map-over-locales)))))) (if --letf-bound--25565 (fset (quote frob-locale) --letf-save--25564) (fmakunbound (quote frob-locale)))))) (if --letf-bound--25561 (fset (quote frob-face-inst-list) --letf-save--25560) (fmakunbound (quote frob-face-inst-list)))))) (if --letf-bound--25557 (fset (quote global-locale) --letf-save--25556) (fmakunbound (quote global-locale)))))) (if --letf-bound--25553 (fset (quote nil-instantiator-ok) --letf-save--25552) (fmakunbound (quote nil-instantiator-ok))))) nil) byte-compile-top-level((progn (flet ((nil-instantiator-ok (inst devtype-spec) (or inst (eq devtype-spec (quote tty)))) (global-locale (locale) (and (memq locale (quote (all nil global))) (quote global))) (frob-face-inst-list (locale inst-list prop devtype-spec) (let* ((ffpdev Face-frob-property-device-considered-current) (results (loop for (tag-set . x) in inst-list for devtype = (derive-device-type-from-locale-and-tag-set locale tag-set devtype-spec ffpdev) if devtype if (let* ((mapper (if (functionp frob-mapping) frob-mapping (plist-get frob-mapping devtype))) (result (cond ((vectorp x) (let ((change-to (cdr (assoc x standard-face-mapping)))) (cond ((or change-to (null (length x))) (list (cons tag-set (cond ((eq change-to t) x) (change-to) (t x))))) (t (let* ((subprop (if (> (length x) 1) (elt x 1) prop)) (subinsts (frob-face-inst-list locale (cdar (specifier-spec-list (face-property (elt x 0) subprop))) subprop devtype-spec))) (add-tag-to-inst-list subinsts tag-set)))))) (t (let ((value (if (eq devtype-spec (quote tty)) (funcall mapper x) (funcall mapper x (derive-domain-from-locale locale devtype-spec ffpdev))))) (and (nil-instantiator-ok value devtype-spec) (list (cons tag-set value)))))))) (if (and (eq (quote tty) devtype-spec) (not (or (eq (quote tty) tag-set) (memq (quote tty) tag-set)))) (nconc (add-tag-to-inst-list result (quote tty)) (list (cons tag-set x))) result)) nconc it))) (delete-duplicates results :test (function equal)))) (frob-locale (sp locale inst-list thunk) (let ((newinst (frob-face-inst-list locale inst-list (car thunk) (cdr thunk)))) (remove-specifier sp locale tag-set exact-p) (add-spec-list-to-specifier sp (list (cons locale newinst)))) nil) (map-over-locales (locale) (map-specifier (get face win-prop) (function frob-locale) locale (cons win-prop (quote window-system)) tag-set exact-p) (loop for prop in tty-props do (map-specifier (get face prop) (function frob-locale) locale (cons prop (quote tty)) tag-set exact-p)))) (let* ((ffpdev Face-frob-property-device-considered-current) (do-later-stages (or (global-locale locale) (valid-specifier-domain-p locale) (bufferp locale))) (domain (and do-later-stages (derive-domain-from-locale locale (quote window-system) ffpdev))) (check-differences (and unfrobbed-face frobbed-face domain (not (memq (face-name face) (quote (default bold italic bold-italic)))))) (orig-instance (and check-differences (face-property-instance face win-prop domain)))) (setq face (get-face face)) (map-over-locales locale) (when do-later-stages (if (global-locale locale) (setq locale (quote global))) (let (do-something) (loop for prop in (cons win-prop tty-props) for propspec = (get face prop) for devtype-spec = (if (eq prop win-prop) (quote window-system) (quote tty)) if propspec do (or (specifier-spec-list propspec locale) (let ((doit (derive-specifier-specs-from-locale propspec locale devtype-spec ffpdev (and (not tag-set) (not exact-p))))) (if (and (not doit) (eq locale (quote global))) (error "No fallback for specifier property %s in face %s???" prop face)) (when doit (add-spec-list-to-specifier propspec (list (cons locale (add-tag-to-inst-list doit (append (if (listp tag-set) tag-set (list tag-set)) (if (eq devtype-spec (quote tty)) (quote (tty)))))))) (setq do-something t))))) (when do-something (map-over-locales (or (global-locale locale) locale)))) (when (and check-differences (let ((new-instance (face-property-instance face win-prop domain))) (and (equal orig-instance new-instance) (equal orig-instance (face-property-instance unfrobbed-face win-prop domain))))) (set-face-property face win-prop (vector frobbed-face) (or (global-locale locale) locale) tag-set)))))) nil lambda) byte-compile-lambda((lambda (face locale tag-set exact-p unfrobbed-face frobbed-face win-prop tty-props frob-mapping standard-face-mapping) (flet ((nil-instantiator-ok (inst devtype-spec) (or inst (eq devtype-spec (quote tty)))) (global-locale (locale) (and (memq locale (quote (all nil global))) (quote global))) (frob-face-inst-list (locale inst-list prop devtype-spec) (let* ((ffpdev Face-frob-property-device-considered-current) (results (loop for (tag-set . x) in inst-list for devtype = (derive-device-type-from-locale-and-tag-set locale tag-set devtype-spec ffpdev) if devtype if (let* ((mapper (if (functionp frob-mapping) frob-mapping (plist-get frob-mapping devtype))) (result (cond ((vectorp x) (let ((change-to (cdr (assoc x standard-face-mapping)))) (cond ((or change-to (null (length x))) (list (cons tag-set (cond ((eq change-to t) x) (change-to) (t x))))) (t (let* ((subprop (if (> (length x) 1) (elt x 1) prop)) (subinsts (frob-face-inst-list locale (cdar (specifier-spec-list (face-property (elt x 0) subprop))) subprop devtype-spec))) (add-tag-to-inst-list subinsts tag-set)))))) (t (let ((value (if (eq devtype-spec (quote tty)) (funcall mapper x) (funcall mapper x (derive-domain-from-locale locale devtype-spec ffpdev))))) (and (nil-instantiator-ok value devtype-spec) (list (cons tag-set value)))))))) (if (and (eq (quote tty) devtype-spec) (not (or (eq (quote tty) tag-set) (memq (quote tty) tag-set)))) (nconc (add-tag-to-inst-list result (quote tty)) (list (cons tag-set x))) result)) nconc it))) (delete-duplicates results :test (function equal)))) (frob-locale (sp locale inst-list thunk) (let ((newinst (frob-face-inst-list locale inst-list (car thunk) (cdr thunk)))) (remove-specifier sp locale tag-set exact-p) (add-spec-list-to-specifier sp (list (cons locale newinst)))) nil) (map-over-locales (locale) (map-specifier (get face win-prop) (function frob-locale) locale (cons win-prop (quote window-system)) tag-set exact-p) (loop for prop in tty-props do (map-specifier (get face prop) (function frob-locale) locale (cons prop (quote tty)) tag-set exact-p)))) (let* ((ffpdev Face-frob-property-device-considered-current) (do-later-stages (or (global-locale locale) (valid-specifier-domain-p locale) (bufferp locale))) (domain (and do-later-stages (derive-domain-from-locale locale (quote window-system) ffpdev))) (check-differences (and unfrobbed-face frobbed-face domain (not (memq (face-name face) (quote (default bold italic bold-italic)))))) (orig-instance (and check-differences (face-property-instance face win-prop domain)))) (setq face (get-face face)) (map-over-locales locale) (when do-later-stages (if (global-locale locale) (setq locale (quote global))) (let (do-something) (loop for prop in (cons win-prop tty-props) for propspec = (get face prop) for devtype-spec = (if (eq prop win-prop) (quote window-system) (quote tty)) if propspec do (or (specifier-spec-list propspec locale) (let ((doit (derive-specifier-specs-from-locale propspec locale devtype-spec ffpdev (and (not tag-set) (not exact-p))))) (if (and (not doit) (eq locale (quote global))) (error "No fallback for specifier property %s in face %s???" prop face)) (when doit (add-spec-list-to-specifier propspec (list (cons locale (add-tag-to-inst-list doit (append (if (listp tag-set) tag-set (list tag-set)) (if (eq devtype-spec (quote tty)) (quote (tty)))))))) (setq do-something t))))) (when do-something (map-over-locales (or (global-locale locale) locale)))) (when (and check-differences (let ((new-instance (face-property-instance face win-prop domain))) (and (equal orig-instance new-instance) (equal orig-instance (face-property-instance unfrobbed-face win-prop domain))))) (set-face-property face win-prop (vector frobbed-face) (or (global-locale locale) locale) tag-set))))))) byte-compile-file-form-defmumble((defun Face-frob-property (face locale tag-set exact-p unfrobbed-face frobbed-face win-prop tty-props frob-mapping standard-face-mapping) (flet ((nil-instantiator-ok (inst devtype-spec) (or inst (eq devtype-spec (quote tty)))) (global-locale (locale) (and (memq locale (quote (all nil global))) (quote global))) (frob-face-inst-list (locale inst-list prop devtype-spec) (let* ((ffpdev Face-frob-property-device-considered-current) (results (loop for (tag-set . x) in inst-list for devtype = (derive-device-type-from-locale-and-tag-set locale tag-set devtype-spec ffpdev) if devtype if (let* ((mapper (if (functionp frob-mapping) frob-mapping (plist-get frob-mapping devtype))) (result (cond ((vectorp x) (let ((change-to (cdr (assoc x standard-face-mapping)))) (cond ((or change-to (null (length x))) (list (cons tag-set (cond ((eq change-to t) x) (change-to) (t x))))) (t (let* ((subprop (if (> (length x) 1) (elt x 1) prop)) (subinsts (frob-face-inst-list locale (cdar (specifier-spec-list (face-property (elt x 0) subprop))) subprop devtype-spec))) (add-tag-to-inst-list subinsts tag-set)))))) (t (let ((value (if (eq devtype-spec (quote tty)) (funcall mapper x) (funcall mapper x (derive-domain-from-locale locale devtype-spec ffpdev))))) (and (nil-instantiator-ok value devtype-spec) (list (cons tag-set value)))))))) (if (and (eq (quote tty) devtype-spec) (not (or (eq (quote tty) tag-set) (memq (quote tty) tag-set)))) (nconc (add-tag-to-inst-list result (quote tty)) (list (cons tag-set x))) result)) nconc it))) (delete-duplicates results :test (function equal)))) (frob-locale (sp locale inst-list thunk) (let ((newinst (frob-face-inst-list locale inst-list (car thunk) (cdr thunk)))) (remove-specifier sp locale tag-set exact-p) (add-spec-list-to-specifier sp (list (cons locale newinst)))) nil) (map-over-locales (locale) (map-specifier (get face win-prop) (function frob-locale) locale (cons win-prop (quote window-system)) tag-set exact-p) (loop for prop in tty-props do (map-specifier (get face prop) (function frob-locale) locale (cons prop (quote tty)) tag-set exact-p)))) (let* ((ffpdev Face-frob-property-device-considered-current) (do-later-stages (or (global-locale locale) (valid-specifier-domain-p locale) (bufferp locale))) (domain (and do-later-stages (derive-domain-from-locale locale (quote window-system) ffpdev))) (check-differences (and unfrobbed-face frobbed-face domain (not (memq (face-name face) (quote (default bold italic bold-italic)))))) (orig-instance (and check-differences (face-property-instance face win-prop domain)))) (setq face (get-face face)) (map-over-locales locale) (when do-later-stages (if (global-locale locale) (setq locale (quote global))) (let (do-something) (loop for prop in (cons win-prop tty-props) for propspec = (get face prop) for devtype-spec = (if (eq prop win-prop) (quote window-system) (quote tty)) if propspec do (or (specifier-spec-list propspec locale) (let ((doit (derive-specifier-specs-from-locale propspec locale devtype-spec ffpdev (and (not tag-set) (not exact-p))))) (if (and (not doit) (eq locale (quote global))) (error "No fallback for specifier property %s in face %s???" prop face)) (when doit (add-spec-list-to-specifier propspec (list (cons locale (add-tag-to-inst-list doit (append (if (listp tag-set) tag-set (list tag-set)) (if (eq devtype-spec (quote tty)) (quote (tty)))))))) (setq do-something t))))) (when do-something (map-over-locales (or (global-locale locale) locale)))) (when (and check-differences (let ((new-instance (face-property-instance face win-prop domain))) (and (equal orig-instance new-instance) (equal orig-instance (face-property-instance unfrobbed-face win-prop domain))))) (set-face-property face win-prop (vector frobbed-face) (or (global-locale locale) locale) tag-set)))))) nil) byte-compile-file-form-defun((defun Face-frob-property (face locale tag-set exact-p unfrobbed-face frobbed-face win-prop tty-props frob-mapping standard-face-mapping) (flet ((nil-instantiator-ok (inst devtype-spec) (or inst (eq devtype-spec (quote tty)))) (global-locale (locale) (and (memq locale (quote (all nil global))) (quote global))) (frob-face-inst-list (locale inst-list prop devtype-spec) (let* ((ffpdev Face-frob-property-device-considered-current) (results (loop for (tag-set . x) in inst-list for devtype = (derive-device-type-from-locale-and-tag-set locale tag-set devtype-spec ffpdev) if devtype if (let* ((mapper (if (functionp frob-mapping) frob-mapping (plist-get frob-mapping devtype))) (result (cond ((vectorp x) (let ((change-to (cdr (assoc x standard-face-mapping)))) (cond ((or change-to (null (length x))) (list (cons tag-set (cond ((eq change-to t) x) (change-to) (t x))))) (t (let* ((subprop (if (> (length x) 1) (elt x 1) prop)) (subinsts (frob-face-inst-list locale (cdar (specifier-spec-list (face-property (elt x 0) subprop))) subprop devtype-spec))) (add-tag-to-inst-list subinsts tag-set)))))) (t (let ((value (if (eq devtype-spec (quote tty)) (funcall mapper x) (funcall mapper x (derive-domain-from-locale locale devtype-spec ffpdev))))) (and (nil-instantiator-ok value devtype-spec) (list (cons tag-set value)))))))) (if (and (eq (quote tty) devtype-spec) (not (or (eq (quote tty) tag-set) (memq (quote tty) tag-set)))) (nconc (add-tag-to-inst-list result (quote tty)) (list (cons tag-set x))) result)) nconc it))) (delete-duplicates results:test (function equal)))) (frob-locale (sp locale inst-list thunk) (let ((newinst (frob-face-inst-list locale inst-list (car thunk) (cdr thunk)))) (remove-specifier sp locale tag-set exact-p) (add-spec-list-to-specifier sp (list (cons locale newinst)))) nil) (map-over-locales (locale) (map-specifier (get face win-prop) (function frob-locale) locale (cons win-prop (quote window-system)) tag-set exact-p) (loop for prop in tty-props do (map-specifier (get face prop) (function frob-locale) locale (cons prop (quote tty)) tag-set exact-p)))) (let* ((ffpdev Face-frob-property-device-considered-current) (do-later-stages (or (global-locale locale) (valid-specifier-domain-p locale) (bufferp locale))) (domain (and do-later-stages (derive-domain-from-locale locale (quote window-system) ffpdev))) (check-differences (and unfrobbed-face frobbed-face domain (not (memq (face-name face) (quote (default bold italic bold-italic)))))) (orig-instance (and check-differences (face-property-instance face win-prop domain)))) (setq face (get-face face)) (map-over-locales locale) (when do-later-stages (if (global-locale locale) (setq locale (quote global))) (let (do-something) (loop for prop in (cons win-prop tty-props) for propspec = (get face prop) for devtype-spec = (if (eq prop win-prop) (quote window-system) (quote tty)) if propspec do (or (specifier-spec-list propspec locale) (let ((doit (derive-specifier-specs-from-locale propspec locale devtype-spec ffpdev (and (not tag-set) (not exact-p))))) (if (and (not doit) (eq locale (quote global))) (error "No fallback for specifier property %s in face %s???" prop face)) (when doit (add-spec-list-to-specifier propspec (list (cons locale (add-tag-to-inst-list doit (append (if (listp tag-set) tag-set (list tag-set)) (if (eq devtype-spec (quote tty)) (quote (tty)))))))) (setq do-something t))))) (when do-something (map-over-locales (or (global-locale locale) locale)))) (when (and check-differences (let ((new-instance (face-property-instance face win-prop domain))) (and (equal orig-instance new-instance) (equal orig-instance (face-property-instance unfrobbed-face win-prop domain))))) (set-face-property face win-prop (vector frobbed-face) (or (global-locale locale) locale) tag-set))))))) byte-compile-file-form((defun Face-frob-property (face locale tag-set exact-p unfrobbed-face frobbed-face win-prop tty-props frob-mapping standard-face-mapping) (flet ((nil-instantiator-ok (inst devtype-spec) (or inst (eq devtype-spec (quote tty)))) (global-locale (locale) (and (memq locale (quote (all nil global))) (quote global))) (frob-face-inst-list (locale inst-list prop devtype-spec) (let* ((ffpdev Face-frob-property-device-considered-current) (results (loop for (tag-set . x) in inst-list for devtype = (derive-device-type-from-locale-and-tag-set locale tag-set devtype-spec ffpdev) if devtype if (let* ((mapper (if (functionp frob-mapping) frob-mapping (plist-get frob-mapping devtype))) (result (cond ((vectorp x) (let ((change-to (cdr (assoc x standard-face-mapping)))) (cond ((or change-to (null (length x))) (list (cons tag-set (cond ((eq change-to t) x) (change-to) (t x))))) (t (let* ((subprop (if (> (length x) 1) (elt x 1) prop)) (subinsts (frob-face-inst-list locale (cdar (specifier-spec-list (face-property (elt x 0) subprop))) subprop devtype-spec))) (add-tag-to-inst-list subinsts tag-set)))))) (t (let ((value (if (eq devtype-spec (quote tty)) (funcall mapper x) (funcall mapper x (derive-domain-from-locale locale devtype-spec ffpdev))))) (and (nil-instantiator-ok value devtype-spec) (list (cons tag-set value)))))))) (if (and (eq (quote tty) devtype-spec) (not (or (eq (quote tty) tag-set) (memq (quote tty) tag-set)))) (nconc (add-tag-to-inst-list result (quote tty)) (list (cons tag-set x))) result)) nconc it))) (delete-duplicates results :test (function equal)))) (frob-locale (sp locale inst-list thunk) (let ((newinst (frob-face-inst-list locale inst-list (car thunk) (cdr thunk)))) (remove-specifier sp locale tag-set exact-p) (add-spec-list-to-specifier sp (list (cons locale newinst)))) nil) (map-over-locales (locale) (map-specifier (get face win-prop) (function frob-locale) locale (cons win-prop (quote window-system)) tag-set exact-p) (loop for prop in tty-props do (map-specifier (get face prop) (function frob-locale) locale (cons prop (quote tty)) tag-set exact-p)))) (let* ((ffpdev Face-frob-property-device-considered-current) (do-later-stages (or (global-locale locale) (valid-specifier-domain-p locale) (bufferp locale))) (domain (and do-later-stages (derive-domain-from-locale locale (quote window-system) ffpdev))) (check-differences (and unfrobbed-face frobbed-face domain (not (memq (face-name face) (quote (default bold italic bold-italic)))))) (orig-instance (and check-differences (face-property-instance face win-prop domain)))) (setq face (get-face face)) (map-over-locales locale) (when do-later-stages (if (global-locale locale) (setq locale (quote global))) (let (do-something) (loop for prop in (cons win-prop tty-props) for propspec = (get face prop) for devtype-spec = (if (eq prop win-prop) (quote window-system) (quote tty)) if propspec do (or (specifier-spec-list propspec locale) (let ((doit (derive-specifier-specs-from-locale propspec locale devtype-spec ffpdev (and (not tag-set) (not exact-p))))) (if (and (not doit) (eq locale (quote global))) (error "No fallback for specifier property %s in face %s???" prop face)) (when doit (add-spec-list-to-specifier propspec (list (cons locale (add-tag-to-inst-list doit (append (if (listp tag-set) tag-set (list tag-set)) (if (eq devtype-spec (quote tty)) (quote (tty)))))))) (setq do-something t))))) (when do-something (map-over-locales (or (global-locale locale) locale)))) (when (and check-differences (let ((new-instance (face-property-instance face win-prop domain))) (and (equal orig-instance new-instance) (equal orig-instance (face-property-instance unfrobbed-face win-prop domain))))) (set-face-property face win-prop (vector frobbed-face) (or (global-locale locale) locale) tag-set))))))) call-with-condition-handler(#<compiled-function (error-info) "...(4)" [error-info byte-compile-report-error] 2> #<compiled-function nil "...(43)" [byte-compile-unresolved-functions byte-compile-inbuffer 1 " \n" nil looking-at ";" byte-compile-file-form read byte-compile-flush-pending byte-compile-warn-about-unresolved-functions] 3>) # bind (byte-compile-warnings-beginning byte-compile-point-max-prev byte-compile-log-buffer byte-compile-macro-environment byte-compile-function-environment byte-compile-autoload-environment byte-compile-unresolved-functions byte-compile-bound-variables byte-compile-free-references byte-compile-free-assignments byte-compile-verbose byte-optimize byte-compile-emacs19-compatibility byte-compile-dynamic byte-compile-dynamic-docstrings byte-compile-warnings byte-compile-file-domain byte-compile-outbuffer float-output-format case-fold-search print-length print-level byte-compile-constants byte-compile-variables byte-compile-tag-number byte-compile-depth byte-compile-maxdepth byte-compile-output eval filename byte-compile-inbuffer) # (condition-case ... . ((error (byte-code "€ ﾂ € ﾃ! 妾 € ﾂ! 妾 € ﾂ € ﾄ! 妾 € ﾅ € ﾆ! € ｫ 奨 € ﾆ € ﾇ\" 妾 € ｪ 廠 € ﾂ ＠€ ﾈN € ｮ 召 ＠!妾 € ﾉ € ﾊ A\"妾 € ﾂ € ﾋ! 妾 € ﾇ 奨" [file err princ ">>Error occurred processing " ": " fboundp display-error nil error-message mapcar #<compiled-function (x) "...(8)" [x princ " " prin1] 2> "\n"] 3)))) # bind (error file-to-process) # bind (error) (cond ((null command-line-args-left) (unless noninteractive (run-hooks (quote term-setup-hook)) (setq term-setup-hook nil) (when (string= (buffer-name) "*scratch*") (unless (or inhibit-startup-message (input-pending-p)) (let (tmout) (unwind-protect (catch (quote tmout) (setq tmout (add-timeout startup-message-timeout (lambda (ignore) (condition-case nil (throw (quote tmout) t) (error nil))) nil)) (display-splash-screen) (or nil (goto-char (point-min))) (sit-for 0) (setq unread-command-event (next-command-event))) (when tmout (disable-timeout tmout))))) (with-current-buffer (get-buffer "*scratch*") (erase-buffer) (when (stringp initial-scratch-message) (insert initial-scratch-message)) (set-buffer-modified-p nil))))) (t (let ((dir command-line-default-directory) (file-count 0) (line nil) (end-of-options nil) file-p arg tem) (while command-line-args-left (setq arg (pop command-line-args-left)) (cond (end-of-options (setq file-p t)) ((setq tem (when (eq (aref arg 0) ?-) (or (! assoc arg command-switch-alist) (assoc (substring arg 1) command-switch-alist)))) (funcall (cdr tem) arg)) ((string-match "\\`\\+[0-9]+\\'" arg) (setq line (string-to-int arg))) ((or (string= arg "-") (string= arg "--")) (setq end-of-options t)) (t (setq file-p t))) (when file-p (setq file-p nil) (incf file-count) (setq arg (expand-file-name arg dir)) (cond ((= file-count 1) (find-file arg)) (noninteractive (find-file arg)) (t (find-file-other-window arg))) (when line (goto-line line) (setq line nil))))))) (let ((command-line-args-left (cdr command-line-args))) (let ((debugger (quote early-error-handler)) (debug-on-error t)) (setq command-line-args-left (command-line-early command-line-args-left)) (when (eq system-type (quote windows-nt)) (declare-fboundp (init-mswindows-at-startup))) (when (featurep (quote toolbar)) (init-toolbar-location)) (when (featurep (quote mule)) (declare-fboundp (init-mule-at-startup))) (if (featurep (quote toolbar)) (if (featurep (quote infodock)) (require (quote id-x-toolbar)) (init-toolbar))) (when (and initial-window-system (not noninteractive)) (funcall (intern (concat "init-" (symbol-name initial-window-system) "-win")))) (frame-initialize)) (startup-initialize-custom-faces) (if (featurep (quote menubar)) (init-menubar-at-startup)) (load-init-file) (with-current-buffer (get-buffer "*scratch*") (erase-buffer) (set-buffer-modified-p nil) (when (eq major-mode (quote fundamental-mode)) (funcall initial-major-mode)) (font-lock-set-defaults)) (when ! (and (eq (quote tty) (console-type)) (not (noninteractive))) (load-terminal-library)) (command-line-1) (setq inhibit-warning-display nil) (when (noninteractive) (kill-emacs t))) (if (noninteractive) (command-line) (condition-case data (command-line) (t (setq error-data data)))) # bind (error-data) (let (error-data) (if (noninteractive) (command-line) (condition-case data (command-line) (t (setq error-data data)))) (setq default-directory (abbreviate-file-name default-directory)) (if auto-save-list-file-prefix (setq auto-save-list-file-name (expand-file-name (format "%s%d-%s" auto-save-list-file-prefix (emacs-pid) (system-name))))) (run-hooks (quote emacs-startup-hook)) (and term-setup-hook (run-hooks (quote term-setup-hook))) (setq term-setup-hook nil) (frame-notice-user-settings) (when window-setup-hook (run-hooks (quote window-setup-hook))) (setq window-setup-hook nil) (if error-data (signal-error (car error-data) (cdr error-data)))) (if command-line-processed (message "Back to top level.") (setq command-line-processed t) (when (getenv "XEMACSDEBUG") (eval (read (getenv "XEMACSDEBUG")))) (let ((value (user-home-directory))) (if (and value (< (length value) (length default-directory)) (equal (file-attributes default-directory) (file-attributes value))) (setq default-directory (file-name-as-directory value)))) (setq default-directory (abbreviate-file-name default-directory)) (initialize-xemacs-paths) (startup-set-invocation-environment) (startup-setup-paths (cond (inhibit-all-packages t) (inhibit-early-packages (quote (early))) (t nil)) nil) (startup-setup-paths-warning) (startup-load-autoloads) (let (error-data) (if (noninteractive) (command-line) (condition-case data (command-line) (t (setq error-data data)))) (setq default-directory (abbreviate-file-name default-directory)) (if auto-save-list-file-prefix (setq auto-save-list-file-name (expand-file-name (format "%s%d-%s" auto-save-list-file-prefix (ema! cs-pid) (system-name))))) (run-hooks (quote emacs-startup-hook)) (and term-setup-hook (run-hooks (quote term-setup-hook))) (setq term-setup-hook nil) (frame-notice-user-settings) (when window-setup-hook (run-hooks (quote window-setup-hook))) (setq window-setup-hook nil) (if error-data (signal-error (car error-data) (cdr error-data)))) (if load-user-init-file-p (maybe-migrate-user-init-file))) # (condition-case ... . error) \s-+.+\)*\|^Note:\|Installing\|[Ff]ile(s) copied\|\s-+tests\s-+\|^[A-Z] [^ ]+$\|^Wrong number of arguments:\|^ \*\* " -- Adrian Aichner mailto:adrian＠xemacs.org http://www.xemacs.org/