Mercurial > hg > xemacs-beta
comparison lisp/url/url-sysdp.el @ 70:131b0175ea99 r20-0b30
Import from CVS: tag r20-0b30
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 09:02:59 +0200 |
| parents | |
| children |
comparison
equal
deleted
inserted
replaced
| 69:804d1389bcd6 | 70:131b0175ea99 |
|---|---|
| 1 ;;; sysdep.el --- consolidate Emacs-version dependencies in one file. | |
| 2 | |
| 3 ;; Copyright (C) 1995 Ben Wing. | |
| 4 | |
| 5 ;; Author: Ben Wing <wing@666.com> | |
| 6 ;; Keywords: lisp, tools | |
| 7 ;; Version: 0.001 | |
| 8 | |
| 9 ;; The purpose of this file is to eliminate the cruftiness that | |
| 10 ;; would otherwise be required of packages that want to run on multiple | |
| 11 ;; versions of Emacs. The idea is that we make it look like we're running | |
| 12 ;; the latest version of XEmacs (currently 19.12) by emulating all the | |
| 13 ;; missing functions. | |
| 14 | |
| 15 ;; #### This file does not currently do any advising but should. | |
| 16 ;; Unfortunately, advice.el is a hugely big package. Is any such | |
| 17 ;; thing as `advice-lite' possible? | |
| 18 | |
| 19 ;; #### - This package is great, but its role needs to be thought out a bit | |
| 20 ;; more. Sysdep will not permit programs written for the old XEmacs API to | |
| 21 ;; run on new versions of XEmacs. Sysdep is a backward-compatibility | |
| 22 ;; package for the latest and greatest XEmacs API. It permits programmers | |
| 23 ;; to use the latest XEmacs functionality and still have their programs run | |
| 24 ;; on older versions of XEmacs...perhaps even on FSF Emacs. It should NEVER | |
| 25 ;; ever need to be loaded in the newest XEmacs. It doesn't even make sense | |
| 26 ;; to put it in the lisp/utils part of the XEmacs distribution because it's | |
| 27 ;; real purpose is to be distributed with packages like w3 which take | |
| 28 ;; advantage of the latest and greatest features of XEmacs but still need to | |
| 29 ;; be run on older versions. --Stig | |
| 30 | |
| 31 ;; Any packages that wish to use this file should load it using | |
| 32 ;; `load-library'. It will not load itself if a version of sysdep.el | |
| 33 ;; that is at least as recent has already been loaded, but will | |
| 34 ;; load over an older version of sysdep.el. It will attempt to | |
| 35 ;; not redefine functions that have already been custom-redefined, | |
| 36 ;; but will redefine a function if the supplied definition came from | |
| 37 ;; an older version of sysdep.el. | |
| 38 | |
| 39 ;; Packages such as w3 that wish to include this file with the package | |
| 40 ;; should rename it to something unique, such as `w3-sysdep.el', and | |
| 41 ;; load it with `load-library'. That will ensure that no conflicts | |
| 42 ;; arise if more than one package in the load path provides a version | |
| 43 ;; of sysdep.el. If multiple packages load sysdep.el, the most recent | |
| 44 ;; version will end up loaded; as long as I'm careful not to | |
| 45 ;; introduce bugs in previously working definitions, this should work | |
| 46 ;; fine. | |
| 47 | |
| 48 ;; You may well discover deficiencies in this file as you use it. | |
| 49 ;; The preferable way of dealing with this is to send me a patch | |
| 50 ;; to sysdep.el; that way, the collective body of knowledge gets | |
| 51 ;; increased. | |
| 52 | |
| 53 ;; DO NOT load this file with `require'. | |
| 54 ;; DO NOT put a `provide' statement in this file. | |
| 55 | |
| 56 ;; IMPORTANT: leave the version string in the format X.XXX (e.g. 1.001) | |
| 57 ;; so that string comparisons to other versions work properly. | |
| 58 | |
| 59 (defconst sysdep-potential-version "0.002") | |
| 60 | |
| 61 (if (and (boundp 'sysdep-version) | |
| 62 (not (string-lessp sysdep-version sysdep-potential-version))) | |
| 63 ;; if a more recent version of sysdep was already loaded, | |
| 64 ;; or if the same package is loaded again, don't load. | |
| 65 nil | |
| 66 | |
| 67 (defconst sysdep-version sysdep-potential-version) | |
| 68 | |
| 69 ;; this macro means: define the function, but only if either it | |
| 70 ;; wasn't bound before, or the supplied binding comes from an older | |
| 71 ;; version of sysdep.el. That way, user-supplied bindings don't | |
| 72 ;; get overridden. | |
| 73 | |
| 74 ;; note: sysdep-defalias is often more useful than this function, | |
| 75 ;; esp. since you can do load-time conditionalizing and can | |
| 76 ;; optionally leave the function undefined. (e.g. frame functions | |
| 77 ;; in v18.) | |
| 78 | |
| 79 (defmacro sysdep-defun (function &rest everything-else) | |
| 80 (` (cond ((or (not (fboundp (quote (, function)))) | |
| 81 (get (quote (, function)) 'sysdep-defined-this)) | |
| 82 (put (quote (, function)) 'sysdep-defined-this t) | |
| 83 (defun (, function) (,@ everything-else)))))) | |
| 84 | |
| 85 (defmacro sysdep-defvar (function &rest everything-else) | |
| 86 (` (cond ((or (not (boundp (quote (, function)))) | |
| 87 (get (quote (, function)) 'sysdep-defined-this)) | |
| 88 (put (quote (, function)) 'sysdep-defined-this t) | |
| 89 (defvar (, function) (,@ everything-else)))))) | |
| 90 | |
| 91 (defmacro sysdep-defconst (function &rest everything-else) | |
| 92 (` (cond ((or (not (boundp (quote (, function)))) | |
| 93 (get (quote (, function)) 'sysdep-defined-this)) | |
| 94 (put (quote (, function)) 'sysdep-defined-this t) | |
| 95 (defconst (, function) (,@ everything-else)))))) | |
| 96 | |
| 97 ;; similar for fset and defalias. No need to quote as the argument | |
| 98 ;; is already quoted. | |
| 99 | |
| 100 (defmacro sysdep-fset (function def) | |
| 101 (` (cond ((and (or (not (fboundp (, function))) | |
| 102 (get (, function) 'sysdep-defined-this)) | |
| 103 (, def)) | |
| 104 (put (, function) 'sysdep-defined-this t) | |
| 105 (fset (, function) (, def)))))) | |
| 106 | |
| 107 (defmacro sysdep-defalias (function def) | |
| 108 (` (cond ((and (or (not (fboundp (, function))) | |
| 109 (get (, function) 'sysdep-defined-this)) | |
| 110 (, def) | |
| 111 (or (listp (, def)) | |
| 112 (and (symbolp (, def)) | |
| 113 (fboundp (, def))))) | |
| 114 (put (, function) 'sysdep-defined-this t) | |
| 115 (defalias (, function) (, def)))))) | |
| 116 | |
| 117 ;; bootstrapping: defalias and define-function don't exist | |
| 118 ;; in older versions of lemacs | |
| 119 | |
| 120 (sysdep-fset 'defalias 'fset) | |
| 121 (sysdep-defalias 'define-function 'defalias) | |
| 122 | |
| 123 ;; useful ways of determining what version is running | |
| 124 ;; emacs-major-version and emacs-minor-version are | |
| 125 ;; already defined in recent versions of FSF Emacs and XEmacs | |
| 126 | |
| 127 (sysdep-defconst emacs-major-version | |
| 128 ;; will string-match ever fail? If so, assume 19.0. | |
| 129 ;; (should we assume 18.something?) | |
| 130 (if (string-match "^[0-9]+" emacs-version) | |
| 131 (string-to-int | |
| 132 (substring emacs-version | |
| 133 (match-beginning 0) (match-end 0))) | |
| 134 19)) | |
| 135 | |
| 136 (sysdep-defconst emacs-minor-version | |
| 137 (if (string-match "^[0-9]+\\.\\([0-9]+\\)" emacs-version) | |
| 138 (string-to-int | |
| 139 (substring emacs-version | |
| 140 (match-beginning 1) (match-end 1))) | |
| 141 0)) | |
| 142 | |
| 143 (sysdep-defconst sysdep-running-xemacs | |
| 144 (or (string-match "Lucid" emacs-version) | |
| 145 (string-match "XEmacs" emacs-version))) | |
| 146 | |
| 147 (sysdep-defconst window-system nil) | |
| 148 (sysdep-defconst window-system-version 0) | |
| 149 | |
| 150 (sysdep-defvar list-buffers-directory nil) | |
| 151 (sysdep-defvar x-library-search-path (` | |
| 152 ("/usr/X11R6/lib/X11/" | |
| 153 "/usr/X11R5/lib/X11/" | |
| 154 "/usr/lib/X11R6/X11/" | |
| 155 "/usr/lib/X11R5/X11/" | |
| 156 "/usr/local/X11R6/lib/X11/" | |
| 157 "/usr/local/X11R5/lib/X11/" | |
| 158 "/usr/local/lib/X11R6/X11/" | |
| 159 "/usr/local/lib/X11R5/X11/" | |
| 160 "/usr/X11/lib/X11/" | |
| 161 "/usr/lib/X11/" | |
| 162 "/usr/local/lib/X11/" | |
| 163 "/usr/X386/lib/X11/" | |
| 164 "/usr/x386/lib/X11/" | |
| 165 "/usr/XFree86/lib/X11/" | |
| 166 "/usr/unsupported/lib/X11/" | |
| 167 "/usr/athena/lib/X11/" | |
| 168 "/usr/local/x11r5/lib/X11/" | |
| 169 "/usr/lpp/Xamples/lib/X11/" | |
| 170 "/usr/openwin/lib/X11/" | |
| 171 "/usr/openwin/share/lib/X11/" | |
| 172 (, data-directory) | |
| 173 ) | |
| 174 ) | |
| 175 "Search path used for X11 libraries.") | |
| 176 | |
| 177 ;; frame-related stuff. | |
| 178 | |
| 179 (sysdep-defalias 'buffer-dedicated-frame 'buffer-dedicated-screen) | |
| 180 (sysdep-defalias 'deiconify-frame | |
| 181 (cond ((fboundp 'deiconify-screen) 'deiconify-screen) | |
| 182 ;; make-frame-visible will be defined as necessary | |
| 183 (t 'make-frame-visible))) | |
| 184 (sysdep-defalias 'delete-frame 'delete-screen) | |
| 185 (sysdep-defalias 'event-frame 'event-screen) | |
| 186 (sysdep-defalias 'event-glyph-extent 'event-glyph) | |
| 187 (sysdep-defalias 'find-file-other-frame 'find-file-other-screen) | |
| 188 (sysdep-defalias 'find-file-read-only-other-frame | |
| 189 'find-file-read-only-other-screen) | |
| 190 (sysdep-defalias 'frame-height 'screen-height) | |
| 191 (sysdep-defalias 'frame-iconified-p 'screen-iconified-p) | |
| 192 (sysdep-defalias 'frame-left-margin-width 'screen-left-margin-width) | |
| 193 (sysdep-defalias 'frame-list 'screen-list) | |
| 194 (sysdep-defalias 'frame-live-p | |
| 195 (cond ((fboundp 'screen-live-p) 'screen-live-p) | |
| 196 ((fboundp 'live-screen-p) 'live-screen-p) | |
| 197 ;; #### not sure if this is correct (this is for Epoch) | |
| 198 ;; but gnuserv.el uses it this way | |
| 199 ((fboundp 'screenp) 'screenp))) | |
| 200 (sysdep-defalias 'frame-name 'screen-name) | |
| 201 (sysdep-defalias 'frame-parameters 'screen-parameters) | |
| 202 (sysdep-defalias 'frame-pixel-height 'screen-pixel-height) | |
| 203 (sysdep-defalias 'frame-pixel-width 'screen-pixel-width) | |
| 204 (sysdep-defalias 'frame-right-margin-width 'screen-right-margin-width) | |
| 205 (sysdep-defalias 'frame-root-window 'screen-root-window) | |
| 206 (sysdep-defalias 'frame-selected-window 'screen-selected-window) | |
| 207 (sysdep-defalias 'frame-totally-visible-p 'screen-totally-visible-p) | |
| 208 (sysdep-defalias 'frame-visible-p 'screen-visible-p) | |
| 209 (sysdep-defalias 'frame-width 'screen-width) | |
| 210 (sysdep-defalias 'framep 'screenp) | |
| 211 (sysdep-defalias 'get-frame-for-buffer 'get-screen-for-buffer) | |
| 212 (sysdep-defalias 'get-frame-for-buffer-noselect 'get-screen-for-buffer-noselect) | |
| 213 (sysdep-defalias 'get-other-frame 'get-other-screen) | |
| 214 (sysdep-defalias 'iconify-frame 'iconify-screen) | |
| 215 (sysdep-defalias 'lower-frame 'lower-screen) | |
| 216 (sysdep-defalias 'mail-other-frame 'mail-other-screen) | |
| 217 | |
| 218 (sysdep-defalias 'make-frame | |
| 219 (cond ((fboundp 'make-screen) | |
| 220 (function (lambda (&optional parameters device) | |
| 221 (make-screen parameters)))) | |
| 222 ((fboundp 'x-create-screen) | |
| 223 (function (lambda (&optional parameters device) | |
| 224 (x-create-screen parameters)))))) | |
| 225 | |
| 226 (sysdep-defalias 'make-frame-invisible 'make-screen-invisible) | |
| 227 (sysdep-defalias 'make-frame-visible | |
| 228 (cond ((fboundp 'make-screen-visible) 'make-screen-visible) | |
| 229 ((fboundp 'mapraised-screen) 'mapraised-screen) | |
| 230 ((fboundp 'x-remap-window) | |
| 231 (lambda (&optional x) | |
| 232 (x-remap-window) | |
| 233 (accept-process-output))))) | |
| 234 (sysdep-defalias 'modify-frame-parameters 'modify-screen-parameters) | |
| 235 (sysdep-defalias 'new-frame 'new-screen) | |
| 236 (sysdep-defalias 'next-frame 'next-screen) | |
| 237 (sysdep-defalias 'next-multiframe-window 'next-multiscreen-window) | |
| 238 (sysdep-defalias 'other-frame 'other-screen) | |
| 239 (sysdep-defalias 'previous-frame 'previous-screen) | |
| 240 (sysdep-defalias 'previous-multiframe-window 'previous-multiscreen-window) | |
| 241 (sysdep-defalias 'raise-frame | |
| 242 (cond ((fboundp 'raise-screen) 'raise-screen) | |
| 243 ((fboundp 'mapraise-screen) 'mapraise-screen))) | |
| 244 (sysdep-defalias 'redraw-frame 'redraw-screen) | |
| 245 (sysdep-defalias 'select-frame 'select-screen) | |
| 246 (sysdep-defalias 'selected-frame 'selected-screen) | |
| 247 (sysdep-defalias 'set-buffer-dedicated-frame 'set-buffer-dedicated-screen) | |
| 248 (sysdep-defalias 'set-frame-height 'set-screen-height) | |
| 249 (sysdep-defalias 'set-frame-left-margin-width 'set-screen-left-margin-width) | |
| 250 (sysdep-defalias 'set-frame-position 'set-screen-position) | |
| 251 (sysdep-defalias 'set-frame-right-margin-width 'set-screen-right-margin-width) | |
| 252 (sysdep-defalias 'set-frame-size 'set-screen-size) | |
| 253 (sysdep-defalias 'set-frame-width 'set-screen-width) | |
| 254 (sysdep-defalias 'show-temp-buffer-in-current-frame 'show-temp-buffer-in-current-screen) | |
| 255 (sysdep-defalias 'switch-to-buffer-other-frame 'switch-to-buffer-other-screen) | |
| 256 (sysdep-defalias 'visible-frame-list 'visible-screen-list) | |
| 257 (sysdep-defalias 'window-frame 'window-screen) | |
| 258 (sysdep-defalias 'x-create-frame 'x-create-screen) | |
| 259 (sysdep-defalias 'x-set-frame-icon-pixmap 'x-set-screen-icon-pixmap) | |
| 260 (sysdep-defalias 'x-set-frame-pointer 'x-set-screen-pointer) | |
| 261 (sysdep-defalias 'x-display-color-p 'x-color-display-p) | |
| 262 (sysdep-defalias 'x-display-grayscale-p 'x-grayscale-display-p) | |
| 263 (sysdep-defalias 'menu-event-p 'misc-user-event-p) | |
| 264 | |
| 265 (sysdep-defun add-submenu (menu-path submenu &optional before) | |
| 266 "Add a menu to the menubar or one of its submenus. | |
| 267 If the named menu exists already, it is changed. | |
| 268 MENU-PATH identifies the menu under which the new menu should be inserted. | |
| 269 It is a list of strings; for example, (\"File\") names the top-level \"File\" | |
| 270 menu. (\"File\" \"Foo\") names a hypothetical submenu of \"File\". | |
| 271 If MENU-PATH is nil, then the menu will be added to the menubar itself. | |
| 272 SUBMENU is the new menu to add. | |
| 273 See the documentation of `current-menubar' for the syntax. | |
| 274 BEFORE, if provided, is the name of a menu before which this menu should | |
| 275 be added, if this menu is not on its parent already. If the menu is already | |
| 276 present, it will not be moved." | |
| 277 (add-menu menu-path (car submenu) (cdr submenu) before)) | |
| 278 | |
| 279 (sysdep-defun add-menu-button (menu-path menu-leaf &optional before) | |
| 280 "Add a menu item to some menu, creating the menu first if necessary. | |
| 281 If the named item exists already, it is changed. | |
| 282 MENU-PATH identifies the menu under which the new menu item should be inserted. | |
| 283 It is a list of strings; for example, (\"File\") names the top-level \"File\" | |
| 284 menu. (\"File\" \"Foo\") names a hypothetical submenu of \"File\". | |
| 285 MENU-LEAF is a menubar leaf node. See the documentation of `current-menubar'. | |
| 286 BEFORE, if provided, is the name of a menu item before which this item should | |
| 287 be added, if this item is not on the menu already. If the item is already | |
| 288 present, it will not be moved." | |
| 289 (add-menu-item menu-path (aref menu-leaf 0) (aref menu-leaf 1) | |
| 290 (aref menu-leaf 2) before)) | |
| 291 | |
| 292 (sysdep-defun make-glyph (&optional spec-list) | |
| 293 (if (and spec-list (cdr-safe (assq 'x spec-list))) | |
| 294 (make-pixmap (cdr-safe (assq 'x spec-list))))) | |
| 295 | |
| 296 (sysdep-defalias 'face-list 'list-faces) | |
| 297 | |
| 298 (sysdep-defun facep (face) | |
| 299 "Return t if X is a face name or an internal face vector." | |
| 300 ;; CAUTION!!! This is Emacs 19.x, for x <= 28, specific | |
| 301 ;; I know of no version of Lucid Emacs or XEmacs that did not have | |
| 302 ;; facep. Even if they did, they are unsupported, so big deal. | |
| 303 (and (or (internal-facep face) | |
| 304 (and (symbolp face) (assq face global-face-data))) | |
| 305 t)) | |
| 306 | |
| 307 (sysdep-defun set-face-property (face property value &optional locale | |
| 308 tag-set how-to-add) | |
| 309 "Change a property of FACE." | |
| 310 (and (symbolp face) | |
| 311 (put face property value))) | |
| 312 | |
| 313 (sysdep-defun face-property (face property &optional locale tag-set exact-p) | |
| 314 "Return FACE's value of the given PROPERTY." | |
| 315 (and (symbolp face) (get face property))) | |
| 316 | |
| 317 ;; Property list functions | |
| 318 ;; | |
| 319 (sysdep-defun plist-put (plist prop val) | |
| 320 "Change value in PLIST of PROP to VAL. | |
| 321 PLIST is a property list, which is a list of the form | |
| 322 (PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object. | |
| 323 If PROP is already a property on the list, its value is set to VAL, | |
| 324 otherwise the new PROP VAL pair is added. The new plist is returned; | |
| 325 use `(setq x (plist-put x prop val))' to be sure to use the new value. | |
| 326 The PLIST is modified by side effects." | |
| 327 (let ((node (memq prop plist))) | |
| 328 (if node | |
| 329 (setcar (cdr node) val) | |
| 330 (setq plist (cons prop (cons val plist)))) | |
| 331 plist)) | |
| 332 | |
| 333 (sysdep-defun plist-get (plist prop) | |
| 334 "Extract a value from a property list. | |
| 335 PLIST is a property list, which is a list of the form | |
| 336 (PROP1 VALUE1 PROP2 VALUE2...). This function returns the value | |
| 337 corresponding to the given PROP, or nil if PROP is not | |
| 338 one of the properties on the list." | |
| 339 (car-safe (cdr-safe (memq prop plist)))) | |
| 340 | |
| 341 ;; Device functions | |
| 342 ;; By wmperry@cs.indiana.edu | |
| 343 ;; This is a complete implementation of all the device-* functions found in | |
| 344 ;; XEmacs 19.14. A 'device' for Emacs 19 is just a frame, from which we can | |
| 345 ;; determine the connection to an X display, etc. | |
| 346 | |
| 347 (sysdep-defalias 'selected-device 'ignore) | |
| 348 (sysdep-defalias 'device-or-frame-p 'framep) | |
| 349 (sysdep-defalias 'device-console 'ignore) | |
| 350 (sysdep-defalias 'device-sound-enabled-p 'ignore) | |
| 351 (sysdep-defalias 'device-live-p 'frame-live-p) | |
| 352 (sysdep-defalias 'devicep 'framep) | |
| 353 (sysdep-defalias 'frame-device 'identity) | |
| 354 (sysdep-defalias 'redisplay-device 'redraw-frame) | |
| 355 (sysdep-defalias 'redraw-device 'redraw-frame) | |
| 356 (sysdep-defalias 'select-device 'select-frame) | |
| 357 (sysdep-defalias 'set-device-class 'ignore) | |
| 358 | |
| 359 (sysdep-defun make-device (type connection &optional props) | |
| 360 "Create a new device of type TYPE, attached to connection CONNECTION. | |
| 361 | |
| 362 The valid values for CONNECTION are device-specific; however, | |
| 363 CONNECTION is generally a string. (Specifically, for X devices, | |
| 364 CONNECTION should be a display specification such as \"foo:0\", and | |
| 365 for TTY devices, CONNECTION should be the filename of a TTY device | |
| 366 file, such as \"/dev/ttyp4\", or nil to refer to XEmacs' standard | |
| 367 input/output.) | |
| 368 | |
| 369 PROPS, if specified, should be a plist of properties controlling | |
| 370 device creation. | |
| 371 | |
| 372 If CONNECTION specifies an already-existing device connection, that | |
| 373 device is simply returned; no new device is created, and PROPS | |
| 374 have no effect." | |
| 375 (cond | |
| 376 ((and (eq type 'x) connection) | |
| 377 (make-frame-on-display display props)) | |
| 378 ((eq type 'x) | |
| 379 (make-frame props)) | |
| 380 ((eq type 'tty) | |
| 381 nil) | |
| 382 (t | |
| 383 (error "Unsupported device-type: %s" type)))) | |
| 384 | |
| 385 (sysdep-defun make-frame-on-device (type connection &optional props) | |
| 386 "Create a frame of type TYPE on CONNECTION. | |
| 387 TYPE should be a symbol naming the device type, i.e. one of | |
| 388 | |
| 389 x An X display. CONNECTION should be a standard display string | |
| 390 such as \"unix:0\", or nil for the display specified on the | |
| 391 command line or in the DISPLAY environment variable. Only if | |
| 392 support for X was compiled into XEmacs. | |
| 393 tty A standard TTY connection or terminal. CONNECTION should be | |
| 394 a TTY device name such as \"/dev/ttyp2\" (as determined by | |
| 395 the Unix command `tty') or nil for XEmacs' standard input | |
| 396 and output (usually the TTY in which XEmacs started). Only | |
| 397 if support for TTY's was compiled into XEmacs. | |
| 398 ns A connection to a machine running the NeXTstep windowing | |
| 399 system. Not currently implemented. | |
| 400 win32 A connection to a machine running Microsoft Windows NT or | |
| 401 Windows 95. Not currently implemented. | |
| 402 pc A direct-write MS-DOS frame. Not currently implemented. | |
| 403 | |
| 404 PROPS should be a plist of properties, as in the call to `make-frame'. | |
| 405 | |
| 406 If a connection to CONNECTION already exists, it is reused; otherwise, | |
| 407 a new connection is opened." | |
| 408 (make-device type connection props)) | |
| 409 | |
| 410 (sysdep-defun make-tty-device (&optional tty terminal-type) | |
| 411 "Create a new device on TTY. | |
| 412 TTY should be the name of a tty device file (e.g. \"/dev/ttyp3\" under | |
| 413 SunOS et al.), as returned by the `tty' command. A value of nil means | |
| 414 use the stdin and stdout as passed to XEmacs from the shell. | |
| 415 If TERMINAL-TYPE is non-nil, it should be a string specifying the | |
| 416 type of the terminal attached to the specified tty. If it is nil, | |
| 417 the terminal type will be inferred from the TERM environment variable." | |
| 418 (make-device 'tty tty (list 'terminal-type terminal-type))) | |
| 419 | |
| 420 (sysdep-defun make-x-device (&optional display) | |
| 421 (make-device 'x display)) | |
| 422 | |
| 423 (sysdep-defun set-device-selected-frame (device frame) | |
| 424 "Set the selected frame of device object DEVICE to FRAME. | |
| 425 If DEVICE is nil, the selected device is used. | |
| 426 If DEVICE is the selected device, this makes FRAME the selected frame." | |
| 427 (select-frame frame)) | |
| 428 | |
| 429 (sysdep-defun set-device-baud-rate (device rate) | |
| 430 "Set the output baud rate of DEVICE to RATE. | |
| 431 On most systems, changing this value will affect the amount of padding | |
| 432 and other strategic decisions made during redisplay." | |
| 433 (setq baud-rate rate)) | |
| 434 | |
| 435 (sysdep-defun dfw-device (obj) | |
| 436 "Given a device, frame, or window, return the associated device. | |
| 437 Return nil otherwise." | |
| 438 (cond | |
| 439 ((windowp obj) | |
| 440 (window-frame obj)) | |
| 441 ((framep obj) | |
| 442 obj) | |
| 443 (t | |
| 444 nil))) | |
| 445 | |
| 446 (sysdep-defun event-device (event) | |
| 447 "Return the device that EVENT occurred on. | |
| 448 This will be nil for some types of events (e.g. keyboard and eval events)." | |
| 449 (dfw-device (posn-window (event-start event)))) | |
| 450 | |
| 451 (sysdep-defun find-device (connection &optional type) | |
| 452 "Look for an existing device attached to connection CONNECTION. | |
| 453 Return the device if found; otherwise, return nil. | |
| 454 | |
| 455 If TYPE is specified, only return devices of that type; otherwise, | |
| 456 return devices of any type. (It is possible, although unlikely, | |
| 457 that two devices of different types could have the same connection | |
| 458 name; in such a case, the first device found is returned.)" | |
| 459 (let ((devices (device-list)) | |
| 460 (retval nil)) | |
| 461 (while (and devices (not nil)) | |
| 462 (if (equal connection (device-connection (car devices))) | |
| 463 (setq retval (car devices))) | |
| 464 (setq devices (cdr devices))) | |
| 465 retval)) | |
| 466 | |
| 467 (sysdep-defalias 'get-device 'find-device) | |
| 468 | |
| 469 (sysdep-defun device-baud-rate (&optional device) | |
| 470 "Return the output baud rate of DEVICE." | |
| 471 baud-rate) | |
| 472 | |
| 473 (sysdep-defun device-on-window-system-p (&optional device) | |
| 474 "Return non-nil if DEVICE is on a window system. | |
| 475 This generally means that there is support for the mouse, the menubar, | |
| 476 the toolbar, glyphs, etc." | |
| 477 (and (cdr-safe (assq 'display (frame-parameters device))) t)) | |
| 478 | |
| 479 (sysdep-defun device-name (&optional device) | |
| 480 "Return the name of the specified device." | |
| 481 ;; doesn't handle the 19.29 multiple X display stuff yet | |
| 482 ;; doesn't handle NeXTStep either | |
| 483 (cond | |
| 484 ((null window-system) "stdio") | |
| 485 ((getenv "DISPLAY") | |
| 486 (let ((str (getenv "DISPLAY")) | |
| 487 (x (1- (length (getenv "DISPLAY")))) | |
| 488 (y 0)) | |
| 489 (while (/= y x) | |
| 490 (if (or (= (aref str y) ?:) | |
| 491 (= (aref str y) ?.)) | |
| 492 (aset str y ?-)) | |
| 493 (setq y (1+ y))) | |
| 494 str)) | |
| 495 (t "stdio"))) | |
| 496 | |
| 497 (sysdep-defun device-connection (&optional device) | |
| 498 "Return the connection of the specified device. | |
| 499 DEVICE defaults to the selected device if omitted" | |
| 500 (or (cdr-safe (assq 'display (frame-parameters device))) "stdio")) | |
| 501 | |
| 502 (sysdep-defun device-frame-list (&optional device) | |
| 503 "Return a list of all frames on DEVICE. | |
| 504 If DEVICE is nil, the selected device will be used." | |
| 505 (let ((desired (device-connection device))) | |
| 506 (filtered-frame-list (function (lambda (x) (equal (device-connection x) | |
| 507 desired)))))) | |
| 508 (sysdep-defun device-list () | |
| 509 "Return a list of all devices" | |
| 510 (let ((seen nil) | |
| 511 (cur nil) | |
| 512 (conn nil) | |
| 513 (retval nil) | |
| 514 (not-heard (frame-list))) | |
| 515 (while not-heard | |
| 516 (setq cur (car not-heard) | |
| 517 conn (device-connection cur) | |
| 518 not-heard (cdr not-heard)) | |
| 519 (if (member conn seen) | |
| 520 nil ; Already got it | |
| 521 (setq seen (cons conn seen) ; Whoo hoo, a new one! | |
| 522 retval (cons cur retval)))) | |
| 523 retval)) | |
| 524 | |
| 525 (sysdep-defvar delete-device-hook nil | |
| 526 "Function or functions to call when a device is deleted. | |
| 527 One argument, the to-be-deleted device.") | |
| 528 | |
| 529 (sysdep-defun delete-device (device &optional force) | |
| 530 "Delete DEVICE, permanently eliminating it from use. | |
| 531 Normally, you cannot delete the last non-minibuffer-only frame (you must | |
| 532 use `save-buffers-kill-emacs' or `kill-emacs'). However, if optional | |
| 533 second argument FORCE is non-nil, you can delete the last frame. (This | |
| 534 will automatically call `save-buffers-kill-emacs'.)" | |
| 535 (let ((frames (device-frame-list device))) | |
| 536 (run-hook-with-args 'delete-device-hook device) | |
| 537 (while frames | |
| 538 (delete-frame (car frames) force) | |
| 539 (setq frames (cdr frames))))) | |
| 540 | |
| 541 (sysdep-defalias 'device-color-cells | |
| 542 (cond | |
| 543 ((null window-system) 'ignore) | |
| 544 ((fboundp 'display-color-cells) 'display-color-cells) | |
| 545 ((fboundp 'x-display-color-cells) 'x-display-color-cells) | |
| 546 ((fboundp 'ns-display-color-cells) 'ns-display-color-celles) | |
| 547 (t 'ignore))) | |
| 548 | |
| 549 (sysdep-defun try-font-name (fontname &rest args) | |
| 550 (car-safe (x-list-fonts fontname))) | |
| 551 | |
| 552 (sysdep-defalias 'device-pixel-width | |
| 553 (cond | |
| 554 ((and (eq window-system 'x) (fboundp 'x-display-pixel-width)) | |
| 555 'x-display-pixel-width) | |
| 556 ((and (eq window-system 'ns) (fboundp 'ns-display-pixel-width)) | |
| 557 'ns-display-pixel-width) | |
| 558 (t 'ignore))) | |
| 559 | |
| 560 (sysdep-defalias 'device-pixel-height | |
| 561 (cond | |
| 562 ((and (eq window-system 'x) (fboundp 'x-display-pixel-height)) | |
| 563 'x-display-pixel-height) | |
| 564 ((and (eq window-system 'ns) (fboundp 'ns-display-pixel-height)) | |
| 565 'ns-display-pixel-height) | |
| 566 (t 'ignore))) | |
| 567 | |
| 568 (sysdep-defalias 'device-mm-width | |
| 569 (cond | |
| 570 ((and (eq window-system 'x) (fboundp 'x-display-mm-width)) | |
| 571 'x-display-mm-width) | |
| 572 ((and (eq window-system 'ns) (fboundp 'ns-display-mm-width)) | |
| 573 'ns-display-mm-width) | |
| 574 (t 'ignore))) | |
| 575 | |
| 576 (sysdep-defalias 'device-mm-height | |
| 577 (cond | |
| 578 ((and (eq window-system 'x) (fboundp 'x-display-mm-height)) | |
| 579 'x-display-mm-height) | |
| 580 ((and (eq window-system 'ns) (fboundp 'ns-display-mm-height)) | |
| 581 'ns-display-mm-height) | |
| 582 (t 'ignore))) | |
| 583 | |
| 584 (sysdep-defalias 'device-bitplanes | |
| 585 (cond | |
| 586 ((and (eq window-system 'x) (fboundp 'x-display-planes)) | |
| 587 'x-display-planes) | |
| 588 ((and (eq window-system 'ns) (fboundp 'ns-display-planes)) | |
| 589 'ns-display-planes) | |
| 590 (t 'ignore))) | |
| 591 | |
| 592 (sysdep-defalias 'device-class | |
| 593 (cond | |
| 594 ;; First, Xwindows | |
| 595 ((and (eq window-system 'x) (fboundp 'x-display-visual-class)) | |
| 596 (function | |
| 597 (lambda (&optional device) | |
| 598 (let ((val (symbol-name (x-display-visual-class device)))) | |
| 599 (cond | |
| 600 ((string-match "color" val) 'color) | |
| 601 ((string-match "gray-scale" val) 'grayscale) | |
| 602 (t 'mono)))))) | |
| 603 ;; Now, Presentation-Manager under OS/2 | |
| 604 ((and (eq window-system 'pm) (fboundp 'pm-display-visual-class)) | |
| 605 (function | |
| 606 (lambda (&optional device) | |
| 607 (let ((val (symbol-name (pm-display-visual-class device)))) | |
| 608 (cond | |
| 609 ((string-match "color" val) 'color) | |
| 610 ((string-match "gray-scale" val) 'grayscale) | |
| 611 (t 'mono)))))) | |
| 612 ;; A slightly different way of doing it under OS/2 | |
| 613 ((and (eq window-system 'pm) (fboundp 'pm-display-color-p)) | |
| 614 (function | |
| 615 (lambda (&optional device) | |
| 616 (if (pm-display-color-p) | |
| 617 'color | |
| 618 'mono)))) | |
| 619 ((fboundp 'number-of-colors) | |
| 620 (function | |
| 621 (lambda (&optional device) | |
| 622 (if (= 2 (number-of-colors)) | |
| 623 'mono | |
| 624 'color)))) | |
| 625 ((and (eq window-system 'x) (fboundp 'x-color-p)) | |
| 626 (function | |
| 627 (lambda (&optional device) | |
| 628 (if (x-color-p) | |
| 629 'color | |
| 630 'mono)))) | |
| 631 ((and (eq window-system 'ns) (fboundp 'ns-display-visual-class)) | |
| 632 (function | |
| 633 (lambda (&optional device) | |
| 634 (let ((val (symbol-name (ns-display-visual-class)))) | |
| 635 (cond | |
| 636 ((string-match "color" val) 'color) | |
| 637 ((string-match "gray-scale" val) 'grayscale) | |
| 638 (t 'mono)))))) | |
| 639 (t (function (lambda (&optional device) 'mono))))) | |
| 640 | |
| 641 (sysdep-defun device-class-list () | |
| 642 "Returns a list of valid device classes." | |
| 643 (list 'color 'grayscale 'mono)) | |
| 644 | |
| 645 (sysdep-defun valid-device-class-p (class) | |
| 646 "Given a CLASS, return t if it is valid. | |
| 647 Valid classes are 'color, 'grayscale, and 'mono." | |
| 648 (memq class (device-class-list))) | |
| 649 | |
| 650 (sysdep-defun device-or-frame-type (device-or-frame) | |
| 651 "Return the type (e.g. `x' or `tty') of DEVICE-OR-FRAME. | |
| 652 DEVICE-OR-FRAME should be a device or a frame object. See `device-type' | |
| 653 for a description of the possible types." | |
| 654 (if (or (cdr-safe (assq 'display (frame-parameters device-or-frame))) | |
| 655 (cdr-safe (assq 'window-id (frame-parameters device-or-frame)))) | |
| 656 window-system | |
| 657 'tty)) | |
| 658 | |
| 659 (sysdep-defun device-type (&optional device) | |
| 660 "Return the type of the specified device (e.g. `x' or `tty'). | |
| 661 Value is `tty' for a tty device (a character-only terminal), | |
| 662 `x' for a device which is a connection to an X server, | |
| 663 'ns' for a device which is a connection to a NeXTStep dps server, | |
| 664 'win32' for a Windows-NT window, | |
| 665 'pm' for an OS/2 Presentation Manager window, | |
| 666 'intuition' for an Amiga screen" | |
| 667 (device-or-frame-type device)) | |
| 668 | |
| 669 (sysdep-defun device-type-list () | |
| 670 "Return a list of valid console types." | |
| 671 (if window-system | |
| 672 (list window-system 'tty) | |
| 673 (list 'tty))) | |
| 674 | |
| 675 (sysdep-defun valid-device-type-p (type) | |
| 676 "Given a TYPE, return t if it is valid." | |
| 677 (memq type (device-type-list))) | |
| 678 | |
| 679 | |
| 680 ;; Extent stuff | |
| 681 (sysdep-fset 'delete-extent 'delete-overlay) | |
| 682 (sysdep-fset 'extent-end-position 'overlay-end) | |
| 683 (sysdep-fset 'extent-start-position 'overlay-start) | |
| 684 (sysdep-fset 'set-extent-endpoints 'move-overlay) | |
| 685 (sysdep-fset 'set-extent-property 'overlay-put) | |
| 686 (sysdep-fset 'make-extent 'make-overlay) | |
| 687 | |
| 688 (sysdep-defun extent-property (extent property &optional default) | |
| 689 (or (overlay-get extent property) default)) | |
| 690 | |
| 691 (sysdep-defun extent-at (pos &optional object property before at-flag) | |
| 692 (let ((tmp (overlays-at (point))) | |
| 693 ovls) | |
| 694 (if property | |
| 695 (while tmp | |
| 696 (if (extent-property (car tmp) property) | |
| 697 (setq ovls (cons (car tmp) ovls))) | |
| 698 (setq tmp (cdr tmp))) | |
| 699 (setq ovls tmp | |
| 700 tmp nil)) | |
| 701 (car-safe | |
| 702 (sort ovls | |
| 703 (function | |
| 704 (lambda (a b) | |
| 705 (< (- (extent-end-position a) (extent-start-position a)) | |
| 706 (- (extent-end-position b) (extent-start-position b))))))))) | |
| 707 | |
| 708 (sysdep-defun overlays-in (beg end) | |
| 709 "Return a list of the overlays that overlap the region BEG ... END. | |
| 710 Overlap means that at least one character is contained within the overlay | |
| 711 and also contained within the specified region. | |
| 712 Empty overlays are included in the result if they are located at BEG | |
| 713 or between BEG and END." | |
| 714 (let ((ovls (overlay-lists)) | |
| 715 tmp retval) | |
| 716 (if (< end beg) | |
| 717 (setq tmp end | |
| 718 end beg | |
| 719 beg tmp)) | |
| 720 (setq ovls (nconc (car ovls) (cdr ovls))) | |
| 721 (while ovls | |
| 722 (setq tmp (car ovls) | |
| 723 ovls (cdr ovls)) | |
| 724 (if (or (and (<= (overlay-start tmp) end) | |
| 725 (>= (overlay-start tmp) beg)) | |
| 726 (and (<= (overlay-end tmp) end) | |
| 727 (>= (overlay-end tmp) beg))) | |
| 728 (setq retval (cons tmp retval)))) | |
| 729 retval)) | |
| 730 | |
| 731 (sysdep-defun map-extents (function &optional object from to | |
| 732 maparg flags property value) | |
| 733 (let ((tmp (overlays-in (or from (point-min)) | |
| 734 (or to (point-max)))) | |
| 735 ovls) | |
| 736 (if property | |
| 737 (while tmp | |
| 738 (if (extent-property (car tmp) property) | |
| 739 (setq ovls (cons (car tmp) ovls))) | |
| 740 (setq tmp (cdr tmp))) | |
| 741 (setq ovls tmp | |
| 742 tmp nil)) | |
| 743 (catch 'done | |
| 744 (while ovls | |
| 745 (setq tmp (funcall function (car ovls) maparg) | |
| 746 ovls (cdr ovls)) | |
| 747 (if tmp | |
| 748 (throw 'done tmp)))))) | |
| 749 | |
| 750 ;; misc | |
| 751 (sysdep-fset 'make-local-hook 'make-local-variable) | |
| 752 | |
| 753 (sysdep-defun buffer-substring-no-properties (beg end) | |
| 754 "Return the text from BEG to END, without text properties, as a string." | |
| 755 (format "%s" (buffer-substring beg end))) | |
| 756 | |
| 757 (sysdep-defun symbol-value-in-buffer (symbol buffer &optional unbound-value) | |
| 758 "Return the value of SYMBOL in BUFFER, or UNBOUND-VALUE if it is unbound." | |
| 759 (save-excursion | |
| 760 (set-buffer buffer) | |
| 761 (if (not (boundp symbol)) | |
| 762 unbound-value | |
| 763 (symbol-value symbol)))) | |
| 764 | |
| 765 (sysdep-defun insert-file-contents-literally | |
| 766 (file &optional visit beg end replace) | |
| 767 "Like `insert-file-contents', q.v., but only reads in the file. | |
| 768 A buffer may be modified in several ways after reading into the buffer due | |
| 769 to advanced Emacs features, such as file-name-handlers, format decoding, | |
| 770 find-file-hooks, etc. | |
| 771 This function ensures that none of these modifications will take place." | |
| 772 (let ((file-name-handler-alist nil) | |
| 773 (find-file-hooks nil)) | |
| 774 (insert-file-contents file visit beg end replace))) | |
| 775 | |
| 776 (sysdep-defun alist-to-plist (alist) | |
| 777 "Convert association list ALIST into the equivalent property-list form. | |
| 778 The plist is returned. This converts from | |
| 779 | |
| 780 \((a . 1) (b . 2) (c . 3)) | |
| 781 | |
| 782 into | |
| 783 | |
| 784 \(a 1 b 2 c 3) | |
| 785 | |
| 786 The original alist is not modified. See also `destructive-alist-to-plist'." | |
| 787 (let (plist) | |
| 788 (while alist | |
| 789 (let ((el (car alist))) | |
| 790 (setq plist (cons (cdr el) (cons (car el) plist)))) | |
| 791 (setq alist (cdr alist))) | |
| 792 (nreverse plist))) | |
| 793 | |
| 794 (sysdep-defun add-minor-mode (toggle name &optional keymap after toggle-fun) | |
| 795 "Add a minor mode to `minor-mode-alist' and `minor-mode-map-alist'. | |
| 796 TOGGLE is a symbol which is used as the variable which toggle the minor mode, | |
| 797 NAME is the name that should appear in the modeline (it should be a string | |
| 798 beginning with a space), KEYMAP is a keymap to make active when the minor | |
| 799 mode is active, and AFTER is the toggling symbol used for another minor | |
| 800 mode. If AFTER is non-nil, then it is used to position the new mode in the | |
| 801 minor-mode alists. TOGGLE-FUN specifies an interactive function that | |
| 802 is called to toggle the mode on and off; this affects what appens when | |
| 803 button2 is pressed on the mode, and when button3 is pressed somewhere | |
| 804 in the list of modes. If TOGGLE-FUN is nil and TOGGLE names an | |
| 805 interactive function, TOGGLE is used as the toggle function. | |
| 806 | |
| 807 Example: (add-minor-mode 'view-minor-mode \" View\" view-mode-map)" | |
| 808 (if (not (assq toggle minor-mode-alist)) | |
| 809 (setq minor-mode-alist (cons (list toggle name) minor-mode-alist))) | |
| 810 (if (and keymap (not (assq toggle minor-mode-map-alist))) | |
| 811 (setq minor-mode-map-alist (cons (cons toggle keymap) | |
| 812 minor-mode-map-alist)))) | |
| 813 | |
| 814 (sysdep-defvar x-font-regexp-foundry-and-family | |
| 815 (let ((- "[-?]") | |
| 816 (foundry "[^-]+") | |
| 817 (family "[^-]+") | |
| 818 ) | |
| 819 (concat "\\`[-?*]" foundry - "\\(" family "\\)" -))) | |
| 820 | |
| 821 (sysdep-defun match-string (num &optional string) | |
| 822 "Return string of text matched by last search. | |
| 823 NUM specifies which parenthesized expression in the last regexp. | |
| 824 Value is nil if NUMth pair didn't match, or there were less than NUM pairs. | |
| 825 Zero means the entire text matched by the whole regexp or whole string. | |
| 826 STRING should be given if the last search was by `string-match' on STRING." | |
| 827 (if (match-beginning num) | |
| 828 (if string | |
| 829 (substring string (match-beginning num) (match-end num)) | |
| 830 (buffer-substring (match-beginning num) (match-end num))))) | |
| 831 | |
| 832 (sysdep-defun add-hook (hook-var function &optional at-end) | |
| 833 "Add a function to a hook. | |
| 834 First argument HOOK-VAR (a symbol) is the name of a hook, second | |
| 835 argument FUNCTION is the function to add. | |
| 836 Third (optional) argument AT-END means to add the function at the end | |
| 837 of the hook list instead of the beginning. If the function is already | |
| 838 present, this has no effect. | |
| 839 Returns nil if FUNCTION was already present in HOOK-VAR, else new | |
| 840 value of HOOK-VAR." | |
| 841 (if (not (boundp hook-var)) (set hook-var nil)) | |
| 842 (let ((old (symbol-value hook-var))) | |
| 843 (if (or (not (listp old)) (eq (car old) 'lambda)) | |
| 844 (setq old (list old))) | |
| 845 (if (member function old) | |
| 846 nil | |
| 847 (set hook-var | |
| 848 (if at-end | |
| 849 (append old (list function)) ; don't nconc | |
| 850 (cons function old)))))) | |
| 851 | |
| 852 (sysdep-defalias 'valid-color-name-p | |
| 853 (cond | |
| 854 ((fboundp 'x-valid-color-name-p) ; XEmacs/Lucid | |
| 855 'x-valid-color-name-p) | |
| 856 ((and window-system | |
| 857 (fboundp 'color-defined-p)) ; NS/Emacs 19 | |
| 858 'color-defined-p) | |
| 859 ((and window-system | |
| 860 (fboundp 'pm-color-defined-p)) | |
| 861 'pm-color-defined-p) | |
| 862 ((and window-system | |
| 863 (fboundp 'x-color-defined-p)) ; Emacs 19 | |
| 864 'x-color-defined-p) | |
| 865 ((fboundp 'get-color) ; Epoch | |
| 866 (function (lambda (color) | |
| 867 (let ((x (get-color color))) | |
| 868 (if x | |
| 869 (setq x (progn | |
| 870 (free-color x) | |
| 871 t))) | |
| 872 x)))) | |
| 873 (t 'identity))) ; All others | |
| 874 | |
| 875 ;; Misc. | |
| 876 (sysdep-defun split-string (string pattern) | |
| 877 "Return a list of substrings of STRING which are separated by PATTERN." | |
| 878 (let (parts (start 0)) | |
| 879 (while (string-match pattern string start) | |
| 880 (setq parts (cons (substring string start (match-beginning 0)) parts) | |
| 881 start (match-end 0))) | |
| 882 (nreverse (cons (substring string start) parts)) | |
| 883 )) | |
| 884 | |
| 885 (sysdep-defun member (elt list) | |
| 886 (while (and list (not (equal elt (car list)))) | |
| 887 (setq list (cdr list))) | |
| 888 list) | |
| 889 | |
| 890 (sysdep-defun rassoc (key list) | |
| 891 (let ((found nil)) | |
| 892 (while (and list (not found)) | |
| 893 (if (equal (cdr (car list)) key) (setq found (car list))) | |
| 894 (setq list (cdr list))) | |
| 895 found)) | |
| 896 | |
| 897 (sysdep-defun display-error (error-object stream) | |
| 898 "Display `error-object' on `stream' in a user-friendly way." | |
| 899 (funcall (or (let ((type (car-safe error-object))) | |
| 900 (catch 'error | |
| 901 (and (consp error-object) | |
| 902 (symbolp type) | |
| 903 ;;(stringp (get type 'error-message)) | |
| 904 (consp (get type 'error-conditions)) | |
| 905 (let ((tail (cdr error-object))) | |
| 906 (while (not (null tail)) | |
| 907 (if (consp tail) | |
| 908 (setq tail (cdr tail)) | |
| 909 (throw 'error nil))) | |
| 910 t) | |
| 911 ;; (check-type condition condition) | |
| 912 (get type 'error-conditions) | |
| 913 ;; Search class hierarchy | |
| 914 (let ((tail (get type 'error-conditions))) | |
| 915 (while (not (null tail)) | |
| 916 (cond ((not (and (consp tail) | |
| 917 (symbolp (car tail)))) | |
| 918 (throw 'error nil)) | |
| 919 ((get (car tail) 'display-error) | |
| 920 (throw 'error (get (car tail) | |
| 921 'display-error))) | |
| 922 (t | |
| 923 (setq tail (cdr tail))))) | |
| 924 ;; Default method | |
| 925 (function | |
| 926 (lambda (error-object stream) | |
| 927 (let ((type (car error-object)) | |
| 928 (tail (cdr error-object)) | |
| 929 (first t)) | |
| 930 (if (eq type 'error) | |
| 931 (progn (princ (car tail) stream) | |
| 932 (setq tail (cdr tail))) | |
| 933 (princ (or (get type 'error-message) type) | |
| 934 stream)) | |
| 935 (while tail | |
| 936 (princ (if first ": " ", ") stream) | |
| 937 (prin1 (car tail) stream) | |
| 938 (setq tail (cdr tail) | |
| 939 first nil))))))))) | |
| 940 (function | |
| 941 (lambda (error-object stream) | |
| 942 (princ "Peculiar error " stream) | |
| 943 (prin1 error-object stream)))) | |
| 944 error-object stream)) | |
| 945 | |
| 946 (sysdep-defun find-face (face) | |
| 947 (car-safe (memq face (face-list)))) | |
| 948 | |
| 949 (sysdep-defun set-marker-insertion-type (marker type) | |
| 950 "Set the insertion-type of MARKER to TYPE. | |
| 951 If TYPE is t, it means the marker advances when you insert text at it. | |
| 952 If TYPE is nil, it means the marker stays behind when you insert text at it." | |
| 953 nil) | |
| 954 | |
| 955 ;; window functions | |
| 956 | |
| 957 ;; not defined in v18 | |
| 958 (sysdep-defun eval-buffer (bufname &optional printflag) | |
| 959 (save-excursion | |
| 960 (set-buffer bufname) | |
| 961 (eval-current-buffer))) | |
| 962 | |
| 963 (sysdep-defun window-minibuffer-p (window) | |
| 964 "Returns non-nil if WINDOW is a minibuffer window." | |
| 965 (eq window (minibuffer-window))) | |
| 966 | |
| 967 (sysdep-defun window-live-p (window) | |
| 968 "Returns t if OBJ is a window which is currently visible." | |
| 969 (and (windowp window) | |
| 970 (window-point window))) | |
| 971 | |
| 972 ;; this parenthesis closes the if statement at the top of the file. | |
| 973 | |
| 974 ) | |
| 975 | |
| 976 ;; DO NOT put a provide statement here. This file should never be | |
| 977 ;; loaded with `require'. Use `load-library' instead. | |
| 978 | |
| 979 ;;; sysdep.el ends here | |
| 980 | |
| 981 ;;;(sysdep.el) Local Variables: | |
| 982 ;;;(sysdep.el) eval: (put 'sysdep-defun 'lisp-indent-function 'defun) | |
| 983 ;;;(sysdep.el) eval: (put 'sysdep-defalias 'lisp-indent-function 'defun) | |
| 984 ;;;(sysdep.el) eval: (put 'sysdep-defconst 'lisp-indent-function 'defun) | |
| 985 ;;;(sysdep.el) eval: (put 'sysdep-defvar 'lisp-indent-function 'defun) | |
| 986 ;;;(sysdep.el) End: |