+;;; multi-tty support
+(defvar w32-initialized nil
+ "Non-nil if the w32 window system has been initialized.")
+
+(defun w32-initialize-window-system ()
+ "Initialize Emacs for W32 GUI frames."
+
+ ;; 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)
+ (setq x-resource-name
+ ;; Change any . or * characters in x-resource-name to hyphens,
+ ;; so as not to choke when we use it in X resource queries.
+ (replace-regexp-in-string "[.*]" "-" (invocation-name))))
+
+ (x-open-connection "" x-command-line-resources
+ ;; Exit with a fatal error if this fails and we
+ ;; are the initial display
+ (eq initial-window-system 'w32))
+
+ ;; Setup the default fontset.
+ (setup-default-fontset)
+ ;; Create the standard fontset.
+ (create-fontset-from-fontset-spec w32-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)
+ (push (cons 'height (cdr (assq 'height parsed)))
+ default-frame-alist))
+ (if (assq 'width parsed)
+ (push (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))
+ (push '(reverse . t) default-frame-alist))))
+
+ ;; Don't let Emacs suspend under w32 gui
+ (add-hook 'suspend-hook 'x-win-suspend-error)
+
+ ;; Turn off window-splitting optimization; w32 is usually fast enough
+ ;; that this is only annoying.
+ (setq split-window-keep-point t)
+
+ ;; Turn on support for mouse wheels
+ (mouse-wheel-mode 1)
+
+ ;; W32 expects the menu bar cut and paste commands to use the clipboard.
+ (menu-bar-enable-clipboard)
+
+ ;; Don't show the frame name; that's redundant.
+ (setq-default mode-line-frame-identification " ")
+
+ ;; Set to a system sound if you want a fancy bell.
+ (set-message-beep 'ok)
+ (setq w32-initialized t))
+
+(add-to-list 'handle-args-function-alist '(w32 . x-handle-args))
+(add-to-list 'frame-creation-function-alist '(w32 . x-create-frame-with-faces))
+(add-to-list 'window-system-initialization-alist '(w32 . w32-initialize-window-system))
+
+(provide 'w32-win)
+