+(defun xw-defined-colors (&optional frame)
+ "Internal function called by `defined-colors', which see."
+ (or frame (setq frame (selected-frame)))
+ (let ((all-colors x-colors)
+ (this-color nil)
+ (defined-colors nil))
+ (while all-colors
+ (setq this-color (car all-colors)
+ all-colors (cdr all-colors))
+ (and (color-supported-p this-color frame t)
+ (setq defined-colors (cons this-color defined-colors))))
+ defined-colors))
+\f
+;;;; Function keys
+
+(substitute-key-definition 'suspend-emacs 'iconify-or-deiconify-frame
+ global-map)
+
+;; Map certain keypad keys into ASCII characters
+;; that people usually expect.
+(define-key function-key-map [return] [?\C-m])
+(define-key function-key-map [M-return] [?\M-\C-m])
+(define-key function-key-map [tab] [?\t])
+(define-key function-key-map [M-tab] [?\M-\t])
+(define-key function-key-map [backspace] [?\d])
+(define-key function-key-map [M-backspace] [?\M-\d])
+(define-key function-key-map [escape] [?\e])
+(define-key function-key-map [M-escape] [?\M-\e])
+
+;; These tell read-char how to convert
+;; these special chars to ASCII.
+(put 'return 'ascii-character ?\C-m)
+(put 'tab 'ascii-character ?\t)
+(put 'backspace 'ascii-character ?\d)
+(put 'escape 'ascii-character ?\e)
+
+\f
+;;;; Keysyms
+
+;; Define constant values to be set to mac-keyboard-text-encoding
+(defconst kTextEncodingMacRoman 0)
+(defconst kTextEncodingISOLatin1 513 "0x201")
+(defconst kTextEncodingISOLatin2 514 "0x202")
+
+\f
+;;;; Selections and cut buffers
+
+;; Setup to use the Mac clipboard. The functions mac-cut-function and
+;; mac-paste-function are defined in mac.c.
+(set-selection-coding-system 'compound-text-mac)
+
+(setq interprogram-cut-function
+ '(lambda (str push)
+ (mac-cut-function
+ (encode-coding-string str selection-coding-system t) push)))
+
+(setq interprogram-paste-function
+ '(lambda ()
+ (let ((clipboard (mac-paste-function)))
+ (if clipboard
+ (decode-coding-string clipboard selection-coding-system t)))))
+
+\f
+;;; Do the actual Windows setup here; the above code just defines
+;;; functions and variables that we use now.
+
+(setq command-line-args (x-handle-args command-line-args))
+
+;;; Make sure we have a valid resource name.
+(or (stringp x-resource-name)
+ (let (i)
+ (setq x-resource-name (invocation-name))
+
+ ;; Change any . or * characters in x-resource-name to hyphens,
+ ;; so as not to choke when we use it in X resource queries.
+ (while (setq i (string-match "[.*]" x-resource-name))
+ (aset x-resource-name i ?-))))
+
+(if (x-display-list)
+ ;; On Mac OS 8/9, Most coding systems used in code conversion for
+ ;; font names are not ready at the time when the terminal frame is
+ ;; created. So we reconstruct font name table for the initial
+ ;; frame.
+ (mac-clear-font-name-table)
+ (x-open-connection "Mac"
+ x-command-line-resources
+ ;; Exit Emacs with fatal error if this fails.
+ t))
+
+(setq frame-creation-function 'x-create-frame-with-faces);; Setup the default fontset.
+(setup-default-fontset)
+
+;; Carbon uses different fonts than commonly found on X, so
+;; we define our own standard fontset here.
+(defvar mac-standard-fontset-spec
+ "-apple-Monaco-normal-r-*-*-12-*-*-*-*-*-fontset-mac"
+ "String of fontset spec of the standard fontset.
+This defines a fontset consisting of the Monaco variations for
+European languages which are distributed with Mac OS X.
+
+See the documentation of `create-fontset-from-fontset-spec for the format.")
+
+;; Create a fontset that uses mac-roman font. With this fontset,
+;; characters decoded from mac-roman encoding (ascii, latin-iso8859-1,
+;; and mule-unicode-xxxx-yyyy) are displayed by a mac-roman font.
+(create-fontset-from-fontset-spec mac-standard-fontset-spec t)
+
+;; Create fontset specified in X resources "Fontset-N" (N is 0, 1, ...).
+(create-fontset-from-x-resource)
+
+;; Try to create a fontset from a font specification which comes
+;; from initial-frame-alist, default-frame-alist, or X resource.
+;; A font specification in command line argument (i.e. -fn XXXX)
+;; should be already in default-frame-alist as a `font'
+;; parameter. However, any font specifications in site-start
+;; library, user's init file (.emacs), and default.el are not
+;; yet handled here.
+
+(let ((font (or (cdr (assq 'font initial-frame-alist))
+ (cdr (assq 'font default-frame-alist))
+ (x-get-resource "font" "Font")))
+ xlfd-fields resolved-name)
+ (if (and font
+ (not (query-fontset font))
+ (setq resolved-name (x-resolve-font-name font))
+ (setq xlfd-fields (x-decompose-font-name font)))
+ (if (string= "fontset" (aref xlfd-fields xlfd-regexp-registry-subnum))
+ (new-fontset font (x-complement-fontset-spec xlfd-fields nil))
+ ;; Create a fontset from FONT. The fontset name is
+ ;; generated from FONT.
+ (create-fontset-from-ascii-font font resolved-name "startup"))))
+
+;; Apply a geometry resource to the initial frame. Put it at the end
+;; of the alist, so that anything specified on the command line takes
+;; precedence.
+(let* ((res-geometry (x-get-resource "geometry" "Geometry"))
+ parsed)
+ (if res-geometry
+ (progn
+ (setq parsed (x-parse-geometry res-geometry))
+ ;; If the resource specifies a position,
+ ;; call the position and size "user-specified".
+ (if (or (assq 'top parsed) (assq 'left parsed))
+ (setq parsed (cons '(user-position . t)
+ (cons '(user-size . t) parsed))))
+ ;; All geometry parms apply to the initial frame.
+ (setq initial-frame-alist (append initial-frame-alist parsed))
+ ;; The size parms apply to all frames.
+ (if (assq 'height parsed)
+ (setq default-frame-alist
+ (cons (cons 'height (cdr (assq 'height parsed)))
+ default-frame-alist)))
+ (if (assq 'width parsed)
+ (setq default-frame-alist
+ (cons (cons 'width (cdr (assq 'width parsed)))
+ default-frame-alist))))))
+
+;; Check the reverseVideo resource.
+(let ((case-fold-search t))
+ (let ((rv (x-get-resource "reverseVideo" "ReverseVideo")))
+ (if (and rv
+ (string-match "^\\(true\\|yes\\|on\\)$" rv))
+ (setq default-frame-alist
+ (cons '(reverse . t) default-frame-alist)))))
+
+(defun x-win-suspend-error ()
+ (error "Suspending an Emacs running under Mac makes no sense"))
+(add-hook 'suspend-hook 'x-win-suspend-error)
+
+;; Don't show the frame name; that's redundant.
+(setq-default mode-line-frame-identification " ")
+
+;; Turn on support for mouse wheels.
+(mouse-wheel-mode 1)
+
+(defun mac-drag-n-drop (event)
+ "Edit the files listed in the drag-n-drop EVENT.
+Switch to a buffer editing the last file dropped."
+ (interactive "e")
+ ;; Make sure the drop target has positive co-ords
+ ;; before setting the selected frame - otherwise it
+ ;; won't work. <skx@tardis.ed.ac.uk>
+ (let* ((window (posn-window (event-start event)))
+ (coords (posn-x-y (event-start event)))
+ (x (car coords))
+ (y (cdr coords)))
+ (if (and (> x 0) (> y 0))
+ (set-frame-selected-window nil window))
+ (mapcar (lambda (file-name)
+ (if (listp file-name)
+ (let ((line (car file-name))
+ (start (car (cdr file-name)))
+ (end (car (cdr (cdr file-name)))))
+ (if (> line 0)
+ (goto-line line)
+ (if (and (> start 0) (> end 0))
+ (progn (set-mark start)
+ (goto-char end)))))
+ (x-dnd-handle-one-url window 'private
+ (concat "file:" file-name))))
+ (car (cdr (cdr event)))))
+ (raise-frame))
+
+(global-set-key [drag-n-drop] 'mac-drag-n-drop)
+
+;; By checking whether the variable mac-ready-for-drag-n-drop has been
+;; defined, the event loop in macterm.c can be informed that it can
+;; now receive Finder drag and drop events. Files dropped onto the
+;; Emacs application icon can only be processed when the initial frame
+;; has been created: this is where the files should be opened.
+(add-hook 'after-init-hook
+ '(lambda ()
+ (defvar mac-ready-for-drag-n-drop t)))
+\f
+;;;; Scroll bars
+
+;; for debugging
+;; (defun mac-handle-scroll-bar-event (event) (interactive "e") (princ event))
+
+;;(global-set-key [vertical-scroll-bar mouse-1] 'mac-handle-scroll-bar-event)
+
+(global-set-key
+ [vertical-scroll-bar down-mouse-1]
+ 'mac-handle-scroll-bar-event)
+
+(global-unset-key [vertical-scroll-bar drag-mouse-1])
+(global-unset-key [vertical-scroll-bar mouse-1])
+
+(defun mac-handle-scroll-bar-event (event)
+ "Handle scroll bar EVENT to emulate Mac Toolbox style scrolling."
+ (interactive "e")
+ (let* ((position (event-start event))
+ (window (nth 0 position))
+ (bar-part (nth 4 position)))
+ (select-window window)
+ (cond
+ ((eq bar-part 'up)
+ (goto-char (window-start window))
+ (mac-scroll-down-line))
+ ((eq bar-part 'above-handle)
+ (mac-scroll-down))
+ ((eq bar-part 'handle)
+ (scroll-bar-drag event))
+ ((eq bar-part 'below-handle)
+ (mac-scroll-up))
+ ((eq bar-part 'down)
+ (goto-char (window-start window))
+ (mac-scroll-up-line)))))
+
+(defun mac-scroll-ignore-events ()
+ ;; Ignore confusing non-mouse events
+ (while (not (memq (car-safe (read-event))
+ '(mouse-1 double-mouse-1 triple-mouse-1))) nil))
+
+(defun mac-scroll-down ()
+ (track-mouse
+ (mac-scroll-ignore-events)
+ (scroll-down)))
+
+(defun mac-scroll-down-line ()
+ (track-mouse
+ (mac-scroll-ignore-events)
+ (scroll-down 1)))
+
+(defun mac-scroll-up ()
+ (track-mouse
+ (mac-scroll-ignore-events)
+ (scroll-up)))
+
+(defun mac-scroll-up-line ()
+ (track-mouse
+ (mac-scroll-ignore-events)
+ (scroll-up 1)))
+
+\f
+;;;; Others
+
+(unless (eq system-type 'darwin)
+ ;; This variable specifies the Unix program to call (as a process) to
+ ;; determine the amount of free space on a file system (defaults to
+ ;; df). If it is not set to nil, ls-lisp will not work correctly
+ ;; unless an external application df is implemented on the Mac.
+ (setq directory-free-space-program nil)
+
+ ;; Set this so that Emacs calls subprocesses with "sh" as shell to
+ ;; expand filenames Note no subprocess for the shell is actually
+ ;; started (see run_mac_command in sysdep.c).
+ (setq shell-file-name "sh")
+
+ ;; To display filenames in Chinese or Japanese, replace mac-roman with
+ ;; big5 or sjis
+ (setq file-name-coding-system 'mac-roman))
+
+;; X Window emulation in macterm.c is not complete enough to start a
+;; frame without a minibuffer properly. Call this to tell ediff
+;; library to use a single frame.
+; (ediff-toggle-multiframe)
+
+;; If Emacs is started from the Finder, change the default directory
+;; to the user's home directory.
+(if (string= default-directory "/")
+ (cd "~"))
+
+;; Darwin 6- pty breakage is now controlled from the C code so that
+;; it applies to all builds on darwin. See s/darwin.h PTY_ITERATION.
+;; (setq process-connection-type t)
+
+;; Assume that fonts are always scalable on the Mac. This sometimes
+;; results in characters with jagged edges. However, without it,
+;; fonts with both truetype and bitmap representations but no italic
+;; or bold bitmap versions will not display these variants correctly.
+(setq scalable-fonts-allowed t)
+
+;; (prefer-coding-system 'mac-roman)
+
+;; arch-tag: 71dfcd14-cde8-4d66-b05c-85ec94fb23a6