emacs: lisp/term/ns-win.el comparison

comparison lisp/term/ns-win.el @ 96748:92f7bbffcb45

Require CL; fix up comment style; reindent. (ns-define-service): Use subst-char-in-string. Avoid `eval'. (ns-save-preferences): Use `case'. (ns-initialize-window-system): Use `dolist'.

author	Stefan Monnier <monnier@iro.umontreal.ca>
date	Wed, 16 Jul 2008 20:06:14 +0000
parents	e2bc3521cdab
children	18b856a0216f

comparison

equal deleted inserted replaced

-:ebf3bd5f0017
+:92f7bbffcb45
 (if (not (featurep 'ns-windowing))
 (error "%s: Loading ns-win.el but not compiled for *Step/OS X"
 	   (invocation-name)))
+(eval-when-compile (require 'cl))
 ;; Documentation-purposes only: actually loaded in loadup.el
 (require 'frame)
 (require 'mouse)
 (require 'faces)
 (require 'easymenu)
 (require 'menu-bar)
 (require 'fontset)
-; Not needed?
+;; Not needed?
-;(require 'ispell)
+;;(require 'ispell)
 ;; nsterm.m
 (defvar ns-version-string)
 (defvar ns-expand-space)
 (defvar ns-cursor-blink-rate)
 (declare-function ns-server-vendor "nsfns.m" (&optional display))
 (declare-function ns-server-version "nsfns.m" (&optional display))
 (defun ns-submit-bug-report ()
 "Submit via mail a bug report on Emacs 23.0.0 for GNUstep / OS X."
 (interactive)
 (let ((frame-parameters (frame-parameters))
 (server-vendor (ns-server-vendor))
 (server-version (ns-server-version)))
 (reporter-submit-bug-report
 "Adrian Robert <Adrian.B.Robert@gmail.com>"
 ;;"Christophe de Dinechin <descubes@earthlink.net>"
 ;;"Scott Bender <emacs@harmony-ds.com>"
 ;;"Christian Limpach <chris@nice.ch>"
 ;;"Carl Edman <cedman@princeton.edu>"
 (concat "Emacs for GNUstep / OS X " ns-version-string)
 '(ns-expand-space ns-cursor-blink-rate ns-alternate-modifier
 data-directory frame-parameters window-system window-system-version
 server-vendor server-version system-configuration-options))))
 ;;;; Command line argument handling.
 (defvar ns-invocation-args nil)
 Returns an alist of the form ((top . TOP), (left . LEFT) ... ).
 The properties returned may include `top', `left', `height', and `width'."
 (if (string-match "\\([0-9]+\\)\\( \\([0-9]+\\)\\( \\([0-9]+\\)\\( \\([0-9]+\\) ?\\)?\\)?\\)?"
 geom)
 (apply 'append
-	   (list
+(list
-	    (list (cons 'top (string-to-number (match-string 1 geom))))
+(list (cons 'top (string-to-number (match-string 1 geom))))
-	    (if (match-string 3 geom)
+(if (match-string 3 geom)
-		(list (cons 'left (string-to-number (match-string 3 geom)))))
+(list (cons 'left (string-to-number (match-string 3 geom)))))
-	    (if (match-string 5 geom)
+(if (match-string 5 geom)
-		(list (cons 'height (string-to-number (match-string 5 geom)))))
+(list (cons 'height (string-to-number (match-string 5 geom)))))
-	    (if (match-string 7 geom)
+(if (match-string 7 geom)
-		(list (cons 'width (string-to-number (match-string 7 geom)))))))
+(list (cons 'width (string-to-number (match-string 7 geom)))))))
 '()))
 ;;;; Keyboard mapping.
 (define-key global-map [?\s-x] 'kill-region)
 (define-key global-map [?\s-y] 'ns-paste-secondary)
 (define-key global-map [?\s-z] 'undo)
 (define-key global-map [?\s-|] 'shell-command-on-region)
 (define-key global-map [s-kp-bar] 'shell-command-on-region)
-; (as in Terminal.app)
+;; (as in Terminal.app)
 (define-key global-map [s-right] 'ns-next-frame)
 (define-key global-map [s-left] 'ns-prev-frame)
 (define-key global-map [home] 'beginning-of-buffer)
 (define-key global-map [end] 'end-of-buffer)
 ;; Special NeXTSTEP generated events are converted to function keys.  Here
 ;; are the bindings for them.
 (define-key global-map [ns-power-off]
-'(lambda () (interactive) (save-buffers-kill-emacs t)))
+(lambda () (interactive) (save-buffers-kill-emacs t)))
 (define-key global-map [ns-open-file] 'ns-find-file)
 (define-key global-map [ns-open-temp-file] [ns-open-file])
 (define-key global-map [ns-drag-file] 'ns-insert-file)
 (define-key global-map [ns-drag-color] 'ns-set-foreground-at-mouse)
 (define-key global-map [S-ns-drag-color] 'ns-set-background-at-mouse)
 :init-value nil
 :global t
 :group 'ns
 (if ns-extended-platform-support-mode
 (progn
 (global-set-key [M-up] 'down-one)
 (global-set-key [M-down] 'up-one)
-; These conflict w/word-left, word-right
+;; These conflict w/word-left, word-right.
 ;;(global-set-key [M-left] 'left-one)
 ;;(global-set-key [M-right] 'right-one)
 (setq scroll-preserve-screen-position t)
 (transient-mark-mode 1)
 ;; Change file menu to simplify and add a couple of NS-specific items
 (easy-menu-remove-item global-map '("menu-bar") 'file)
 (easy-menu-add-item global-map '(menu-bar)
-			   (cons "File" menu-bar-ns-file-menu) 'edit))
+(cons "File" menu-bar-ns-file-menu) 'edit))
 (progn
-; undo everything above
+;; Undo everything above.
 (global-unset-key [M-up])
 (global-unset-key [M-down])
 (setq scroll-preserve-screen-position nil)
 (transient-mark-mode 0)
 (easy-menu-remove-item global-map '("menu-bar") 'file)
 (easy-menu-add-item global-map '(menu-bar)
-			   (cons "File" menu-bar-file-menu) 'edit))))
+(cons "File" menu-bar-file-menu) 'edit))))
 (defun x-setup-function-keys (frame)
 "Set up function Keys for NS for given FRAME."
 (unless (terminal-parameter frame 'x-setup-function-keys)
 (with-selected-frame frame
 (setq interprogram-cut-function 'ns-select-text
 	    interprogram-paste-function 'ns-pasteboard-value)
-;;;       (let ((map (copy-keymap x-alternatives-map)))
+;; (let ((map (copy-keymap x-alternatives-map)))
-;;; 	(set-keymap-parent map (keymap-parent local-function-key-map))
+;;   (set-keymap-parent map (keymap-parent local-function-key-map))
-;;; 	(set-keymap-parent local-function-key-map map))
+;;   (set-keymap-parent local-function-key-map map))
 (setq system-key-alist
 (list
 (cons (logior (lsh 0 16)   1) 'ns-power-off)
 (cons (logior (lsh 0 16)   2) 'ns-open-file)
 (cons (logior (lsh 0 16)   3) 'ns-open-temp-file)
 (cons (logior (lsh 0 16)   4) 'ns-drag-file)
 (cons (logior (lsh 0 16)   5) 'ns-drag-color)
 (cons (logior (lsh 0 16)   6) 'ns-drag-text)
 (cons (logior (lsh 0 16)   7) 'ns-change-font)
 (cons (logior (lsh 0 16)   8) 'ns-open-file-line)
 (cons (logior (lsh 0 16)   9) 'ns-insert-working-text)
 (cons (logior (lsh 0 16)  10) 'ns-delete-working-text)
 (cons (logior (lsh 0 16)  11) 'ns-spi-service-call)
 (cons (logior (lsh 1 16)  32) 'f1)
 (cons (logior (lsh 1 16)  33) 'f2)
 (cons (logior (lsh 1 16)  34) 'f3)
 (cons (logior (lsh 1 16)  35) 'f4)
 (cons (logior (lsh 1 16)  36) 'f5)
 (cons (logior (lsh 1 16)  37) 'f6)
 (cons (logior (lsh 1 16)  38) 'f7)
 (cons (logior (lsh 1 16)  39) 'f8)
 (cons (logior (lsh 1 16)  40) 'f9)
 (cons (logior (lsh 1 16)  41) 'f10)
 (cons (logior (lsh 1 16)  42) 'f11)
 (cons (logior (lsh 1 16)  43) 'f12)
 (cons (logior (lsh 1 16)  44) 'kp-insert)
 (cons (logior (lsh 1 16)  45) 'kp-delete)
 (cons (logior (lsh 1 16)  46) 'kp-home)
 (cons (logior (lsh 1 16)  47) 'kp-end)
 (cons (logior (lsh 1 16)  48) 'kp-prior)
 (cons (logior (lsh 1 16)  49) 'kp-next)
 (cons (logior (lsh 1 16)  50) 'print-screen)
 (cons (logior (lsh 1 16)  51) 'scroll-lock)
 (cons (logior (lsh 1 16)  52) 'pause)
 (cons (logior (lsh 1 16)  53) 'system)
 (cons (logior (lsh 1 16)  54) 'break)
 (cons (logior (lsh 1 16)  56) 'please-tell-carl-what-this-key-is-called-56)
 (cons (logior (lsh 1 16)  61) 'please-tell-carl-what-this-key-is-called-61)
 (cons (logior (lsh 1 16)  62) 'please-tell-carl-what-this-key-is-called-62)
 (cons (logior (lsh 1 16)  63) 'please-tell-carl-what-this-key-is-called-63)
 (cons (logior (lsh 1 16)  64) 'please-tell-carl-what-this-key-is-called-64)
 (cons (logior (lsh 1 16)  69) 'please-tell-carl-what-this-key-is-called-69)
 (cons (logior (lsh 1 16)  70) 'please-tell-carl-what-this-key-is-called-70)
 (cons (logior (lsh 1 16)  71) 'please-tell-carl-what-this-key-is-called-71)
 (cons (logior (lsh 1 16)  72) 'please-tell-carl-what-this-key-is-called-72)
 (cons (logior (lsh 1 16)  73) 'please-tell-carl-what-this-key-is-called-73)
 (cons (logior (lsh 2 16)   3) 'kp-enter)
 (cons (logior (lsh 2 16)   9) 'kp-tab)
 (cons (logior (lsh 2 16)  28) 'kp-quit)
 (cons (logior (lsh 2 16)  35) 'kp-hash)
 (cons (logior (lsh 2 16)  42) 'kp-multiply)
 (cons (logior (lsh 2 16)  43) 'kp-add)
 (cons (logior (lsh 2 16)  44) 'kp-separator)
 (cons (logior (lsh 2 16)  45) 'kp-subtract)
 (cons (logior (lsh 2 16)  46) 'kp-decimal)
 (cons (logior (lsh 2 16)  47) 'kp-divide)
 (cons (logior (lsh 2 16)  48) 'kp-0)
 (cons (logior (lsh 2 16)  49) 'kp-1)
 (cons (logior (lsh 2 16)  50) 'kp-2)
 (cons (logior (lsh 2 16)  51) 'kp-3)
 (cons (logior (lsh 2 16)  52) 'kp-4)
 (cons (logior (lsh 2 16)  53) 'kp-5)
 (cons (logior (lsh 2 16)  54) 'kp-6)
 (cons (logior (lsh 2 16)  55) 'kp-7)
 (cons (logior (lsh 2 16)  56) 'kp-8)
 (cons (logior (lsh 2 16)  57) 'kp-9)
 (cons (logior (lsh 2 16)  60) 'kp-less)
 (cons (logior (lsh 2 16)  61) 'kp-equal)
 (cons (logior (lsh 2 16)  62) 'kp-more)
 (cons (logior (lsh 2 16)  64) 'kp-at)
 (cons (logior (lsh 2 16)  92) 'kp-backslash)
 (cons (logior (lsh 2 16)  96) 'kp-backtick)
 (cons (logior (lsh 2 16) 124) 'kp-bar)
 (cons (logior (lsh 2 16) 126) 'kp-tilde)
 (cons (logior (lsh 2 16) 157) 'kp-mu)
 (cons (logior (lsh 2 16) 165) 'kp-yen)
 (cons (logior (lsh 2 16) 167) 'kp-paragraph)
 (cons (logior (lsh 2 16) 172) 'left)
 (cons (logior (lsh 2 16) 173) 'up)
 (cons (logior (lsh 2 16) 174) 'right)
 (cons (logior (lsh 2 16) 175) 'down)
 (cons (logior (lsh 2 16) 176) 'kp-ring)
 (cons (logior (lsh 2 16) 201) 'kp-square)
 (cons (logior (lsh 2 16) 204) 'kp-cube)
 (cons (logior (lsh 3 16)   8) 'backspace)
 (cons (logior (lsh 3 16)   9) 'tab)
 (cons (logior (lsh 3 16)  10) 'linefeed)
 (cons (logior (lsh 3 16)  11) 'clear)
 (cons (logior (lsh 3 16)  13) 'return)
 (cons (logior (lsh 3 16)  18) 'pause)
 (cons (logior (lsh 3 16)  25) 'S-tab)
 (cons (logior (lsh 3 16)  27) 'escape)
 (cons (logior (lsh 3 16) 127) 'delete)
 ))
 (set-terminal-parameter frame 'x-setup-function-keys t))))
 ;;;; Miscellaneous mouse bindings.
 (define-key global-map [S-mouse-1] 'mouse-extend-region)
 (global-unset-key [S-down-mouse-1])
-; must come after keybindings
+;; Must come after keybindings.
 (fmakunbound 'clipboard-yank)
 (fmakunbound 'clipboard-kill-ring-save)
 (fmakunbound 'clipboard-kill-region)
 (fmakunbound 'menu-bar-enable-clipboard)
 ;; Add a couple of menus and rearrange some others; easiest just to redo toplvl
 ;; Note keymap defns must be given last-to-first
 (define-key global-map [menu-bar] (make-sparse-keymap "menu-bar"))
-(cond ((eq system-type 'darwin)
+(setq menu-bar-final-items
-(setq menu-bar-final-items '(buffer windows services help-menu)))
+(cond ((eq system-type 'darwin)
-;; otherwise, gnustep
+'(buffer windows services help-menu))
-(t
+;; Otherwise, GNUstep.
-(setq menu-bar-final-items '(buffer windows services hide-app quit)) )
+(t
-)
+'(buffer windows services hide-app quit))))
-;; add standard top-level items to GNUstep menu
+;; Add standard top-level items to GNUstep menu.
-(cond ((not (eq system-type 'darwin))
+(unless (eq system-type 'darwin)
 (define-key global-map [menu-bar quit] '("Quit" . save-buffers-kill-emacs))
-(define-key global-map [menu-bar hide-app] '("Hide" . ns-do-hide-emacs))
+(define-key global-map [menu-bar hide-app] '("Hide" . ns-do-hide-emacs)))
-))
 (define-key global-map [menu-bar services]
 (cons "Services" (make-sparse-keymap "Services")))
 (define-key global-map [menu-bar windows] (make-sparse-keymap "Windows"))
 (define-key global-map [menu-bar buffer]
 '("New Frame" . make-frame))
 ;;;; Edit menu: Modify slightly
-; Substitute a Copy function that works better under X (for GNUstep)
+;; Substitute a Copy function that works better under X (for GNUstep).
 (easy-menu-remove-item global-map '("menu-bar" "edit") 'copy)
 (define-key-after menu-bar-edit-menu [copy]
 '(menu-item "Copy" ns-copy-including-secondary
-	      :enable mark-active
+:enable mark-active
-	      :help "Copy text in region between mark and current position")
+:help "Copy text in region between mark and current position")
 'cut)
-; Change to same precondition as select-and-paste, as we don't have
+;; Change to same precondition as select-and-paste, as we don't have
-; 'x-selection-exists-p
+;; `x-selection-exists-p'.
 (easy-menu-remove-item global-map '("menu-bar" "edit") 'paste)
 (define-key-after menu-bar-edit-menu [paste]
 '(menu-item "Paste" yank
-	      :enable (and (cdr yank-menu) (not buffer-read-only))
+:enable (and (cdr yank-menu) (not buffer-read-only))
-	      :help "Paste (yank) text most recently cut/copied")
+:help "Paste (yank) text most recently cut/copied")
 'copy)
-; Change text to be more consistent with surrounding menu items 'paste', etc.
+;; Change text to be more consistent with surrounding menu items `paste', etc.
 (easy-menu-remove-item global-map '("menu-bar" "edit") 'paste-from-menu)
 (define-key-after menu-bar-edit-menu [select-paste]
 '(menu-item "Select and Paste" yank-menu
-	      :enable (and (cdr yank-menu) (not buffer-read-only))
+:enable (and (cdr yank-menu) (not buffer-read-only))
-	      :help "Choose a string from the kill ring and paste it")
+:help "Choose a string from the kill ring and paste it")
 'paste)
-; Separate undo item from cut/paste section, add spell for platform consistency
+;; Separate undo from cut/paste section, add spell for platform consistency.
 (define-key-after menu-bar-edit-menu [separator-undo] '("--") 'undo)
 (define-key-after menu-bar-edit-menu [spell] '("Spell" . ispell-menu-map) 'fill)
 ;;;; Windows menu
 (raise-frame last-command-event)
 (select-frame last-command-event))
 (defun menu-bar-update-frames ()
 ;; If user discards the Windows item, play along.
-(and (lookup-key (current-global-map) [menu-bar windows])
+(when (lookup-key (current-global-map) [menu-bar windows])
 (let ((frames (frame-list))
-	     (frames-menu (make-sparse-keymap "Select Frame")))
+(frames-menu (make-sparse-keymap "Select Frame")))
-	 (setcdr frames-menu
+(setcdr frames-menu
-		 (nconc
+(nconc
-		  (mapcar '(lambda (frame)
+(mapcar (lambda (frame)
-			     (nconc (list frame
+(list* frame
-					  (cdr (assq 'name (frame-parameters frame)))
+(cdr (assq 'name (frame-parameters frame)))
-					  (cons nil nil))
+'menu-bar-select-frame))
-				    'menu-bar-select-frame))
+frames)
-			  frames)
+(cdr frames-menu)))
-		  (cdr frames-menu)))
+(define-key frames-menu [separator-frames] '("--"))
-	 (define-key frames-menu [separator-frames] '("--"))
+(define-key frames-menu [popup-color-panel]
-	 (define-key frames-menu [popup-color-panel]
+'("Colors..." . ns-popup-color-panel))
-	   '("Colors..." . ns-popup-color-panel))
+(define-key frames-menu [popup-font-panel]
-	 (define-key frames-menu [popup-font-panel]
+'("Font Panel..." . ns-popup-font-panel))
-	   '("Font Panel..." . ns-popup-font-panel))
+(define-key frames-menu [separator-arrange] '("--"))
-	 (define-key frames-menu [separator-arrange] '("--"))
+(define-key frames-menu [arrange-all-frames]
-	 (define-key frames-menu [arrange-all-frames]
+'("Arrange All Frames" . ns-arrange-all-frames))
-	   '("Arrange All Frames" . ns-arrange-all-frames))
+(define-key frames-menu [arrange-visible-frames]
-	 (define-key frames-menu [arrange-visible-frames]
+'("Arrange Visible Frames" . ns-arrange-visible-frames))
-	   '("Arrange Visible Frames" . ns-arrange-visible-frames))
+;; Don't use delete-frame as event name
-	 ;; Don't use delete-frame as event name
+;; because that is a special event.
-	 ;; because that is a special event.
+(define-key (current-global-map) [menu-bar windows]
-	 (define-key (current-global-map) [menu-bar windows]
+(cons "Windows" frames-menu)))))
-	   (cons "Windows" frames-menu)))))
 (defun force-menu-bar-update-buffers ()
 ;; This is a hack to get around fact that we already checked
 ;; frame-or-buffer-changed-p and reset it, so menu-bar-update-buffers
 ;; does not pick up any change.
 	(x-pos 100)                     ;start position
 	(y-pos 40)
 	(done nil))
 (while (not done)                   ;cycle through all frames
 (if (not (or vis (eq (frame-visible-p frame) t)))
-	(setq x-pos x-pos); do nothing; true case
+(setq x-pos x-pos); do nothing; true case
 	(set-frame-position frame x-pos y-pos)
 	(setq x-pos (+ x-pos inc-x))
 	(setq y-pos (+ y-pos inc-y))
 	(raise-frame frame))
 (select-frame frame)
 ;;;; Services
 (defun ns-define-service (path)
 (let ((mapping [menu-bar services])
 	(service (mapconcat 'identity path "/"))
 	(name (intern
-	       (mapconcat '(lambda (s) (if (= s 32) "-" (char-to-string s)))
+(subst-char-in-string
-			  (mapconcat 'identity (cons "ns-service" path) "-")
+?\s ?-
-			  ""))))
+(mapconcat 'identity (cons "ns-service" path) "-")))))
-;; This defines the function
+;; This defines the function.
-(eval (append (list 'defun name)
+(defalias name
-	  `((arg)
+(lexical-let ((service service))
-	    (interactive "p")
+(lambda (arg)
-	    (let* ((in-string (if (stringp arg) arg (if mark-active
+(interactive "p")
-			  (buffer-substring (region-beginning) (region-end)))))
+(let* ((in-string
-		   (out-string (ns-perform-service (,@service) in-string)))
+(cond ((stringp arg) arg)
-	      (cond
+(mark-active
-	       ((stringp arg) out-string)
+(buffer-substring (region-beginning) (region-end)))))
-	       ((and out-string (or (not in-string)
+(out-string (ns-perform-service service in-string)))
-				    (not (string= in-string out-string))))
+(cond
-		(if mark-active (delete-region (region-beginning) (region-end)))
+((stringp arg) out-string)
-		(insert out-string)
+((and out-string (or (not in-string)
-		(setq deactivate-mark nil)))))))
+(not (string= in-string out-string))))
+(if mark-active (delete-region (region-beginning) (region-end)))
+(insert out-string)
+(setq deactivate-mark nil)))))))
 (cond
 ((lookup-key global-map mapping)
 (while (cdr path)
 	(setq mapping (vconcat mapping (list (intern (car path)))))
 	(if (not (keymapp (lookup-key global-map mapping)))
 (make-variable-buffer-local 'ns-working-overlay)
 (defvar ns-working-overlay-len 0
 "Length of working text during compose sequence insert.")
 (make-variable-buffer-local 'ns-working-overlay-len)
-; Based on mac-win.el 2007/08/26 unicode-2.  This will fail if called
+;; Based on mac-win.el 2007/08/26 unicode-2.  This will fail if called
-; from an "interactive" function.
+;; from an "interactive" function.
 (defun ns-in-echo-area ()
 "Whether, for purposes of inserting working composition text, the minibuffer
 is currently being used."
 (or isearch-mode
 (and cursor-in-echo-area (current-message))
 			(get-char-property (point) 'display)))
 	       (and (get-char-property (point) 'composition)
 		    (eq (get-char-property (1- (point)) 'composition)
 			(get-char-property (point) 'composition)))))))
-; currently not used, doesn't work because the 'interactive' here stays
+;; Currently not used, doesn't work because the 'interactive' here stays
-; for subinvocations
+;; for subinvocations.
 (defun ns-insert-working-text ()
 (interactive)
 (if (ns-in-echo-area) (ns-echo-working-text) (ns-put-working-text)))
 (defvar ns-working-text)		; nsterm.m
 (set-file-name-coding-system 'utf-8-nfd)))
 ;; PENDING: disable composition-based display for Indic scripts as it
 ;;          is not working well under NS for some reason
 (set-char-table-range composition-function-table
 '(#x0900 . #x0DFF) nil)
 ;;;; Inter-app communications support.
 (defvar ns-input-text)			; nsterm.m
 (ns-set-resource nil "AlternateModifier" (symbol-name ns-alternate-modifier))
 (ns-set-resource nil "CommandModifier" (symbol-name ns-command-modifier))
 (ns-set-resource nil "ControlModifier" (symbol-name ns-control-modifier))
 (ns-set-resource nil "FunctionModifier" (symbol-name ns-function-modifier))
 (ns-set-resource nil "CursorBlinkRate"
 (if ns-cursor-blink-rate
 (number-to-string ns-cursor-blink-rate)
 "NO"))
 (ns-set-resource nil "ExpandSpace"
 (if ns-expand-space
 (number-to-string ns-expand-space)
 "NO"))
 (ns-set-resource nil "GSFontAntiAlias" (if ns-antialias-text "YES" "NO"))
 (ns-set-resource nil "UseQuickdrawSmoothing"
 		   (if ns-use-qd-smoothing "YES" "NO"))
 (ns-set-resource nil "UseSystemHighlightColor"
 		   (if ns-use-system-highlight-color "YES" "NO"))
 (if bgc (ns-set-resource nil "Background" (cdr bgc))))
 (let ((cc (assq 'cursor-color p)))
 (if cc (ns-set-resource nil "CursorColor" (cdr cc))))
 (let ((ct (assq 'cursor-type p)))
 (if ct (ns-set-resource nil "CursorType"
-(if (symbolp (cdr ct)) (symbol-name (cdr ct)) (cdr ct)))))
+(if (symbolp (cdr ct))
+(symbol-name (cdr ct)) (cdr ct)))))
 (let ((under (assq 'underline p)))
 (if under (ns-set-resource nil "Underline"
 				 (cond ((eq (cdr under) t) "YES")
 				       ((eq (cdr under) nil) "NO")
 				       (t (cdr under))))))
 (let ((ibw (assq 'internal-border-width p)))
 (if ibw (ns-set-resource nil "InternalBorderWidth"
 (number-to-string (cdr ibw)))))
 (let ((vsb (assq 'vertical-scroll-bars p)))
-(if vsb (ns-set-resource nil "VerticalScrollBars" (cond
+(if vsb (ns-set-resource nil "VerticalScrollBars"
-((eq t (cdr vsb)) "YES")
+(case (cdr vsb)
-((eq nil (cdr vsb)) "NO")
+((t) "YES")
-((eq 'left (cdr vsb)) "left")
+((nil) "NO")
-((eq 'right (cdr vsb)) "right")
+((left) "left")
-(t nil)))))
+((right) "right")
+(t nil)))))
 (let ((height (assq 'height p)))
 (if height (ns-set-resource nil "Height"
 (number-to-string (cdr height)))))
 (let ((width (assq 'width p)))
 (if width (ns-set-resource nil "Width"
 (number-to-string (cdr width)))))
 (let ((top (assq 'top p)))
 (if top (ns-set-resource nil "Top"
 (number-to-string (cdr top)))))
 (let ((left (assq 'left p)))
 (if left (ns-set-resource nil "Left"
 (number-to-string (cdr left)))))
 ;; These not fully supported
 (let ((ar (assq 'auto-raise p)))
 (if ar (ns-set-resource nil "AutoRaise"
 (if (cdr ar) "YES" "NO"))))
 (let ((al (assq 'auto-lower p)))
 (if al (ns-set-resource nil "AutoLower"
 (if (cdr al) "YES" "NO"))))
 (let ((mbl (assq 'menu-bar-lines p)))
 (if mbl (ns-set-resource nil "Menus"
 (if (cdr mbl) "YES" "NO"))))
 )
 (let ((fl (face-list)))
 (while (consp fl)
 (or (eq 'default (car fl))
 ;; dont save Default* since it causes all created faces to
 ;; inherit its values.  The properties of the default face
 ;; have already been saved from the frame-parameters anyway.
 (let* ((name (symbol-name (car fl)))
 (font (face-font (car fl)))
-;                 (fontsize (face-fontsize (car fl)))
+;; (fontsize (face-fontsize (car fl)))
 (foreground (face-foreground (car fl)))
 (background (face-background (car fl)))
 (underline (face-underline-p (car fl)))
 (italic (face-italic-p (car fl)))
 (bold (face-bold-p (car fl)))
 (stipple (face-stipple (car fl))))
-;            (ns-set-resource nil (concat name ".attributeFont")
+;; (ns-set-resource nil (concat name ".attributeFont")
-;                          (if font font nil))
+;;                  (if font font nil))
-;            (ns-set-resource nil (concat name ".attributeFontSize")
+;; (ns-set-resource nil (concat name ".attributeFontSize")
-;                          (if fontsize (number-to-string fontsize) nil))
+;;                  (if fontsize (number-to-string fontsize) nil))
 (ns-set-resource nil (concat name ".attributeForeground")
 (if foreground foreground nil))
 (ns-set-resource nil (concat name ".attributeBackground")
 (if background background nil))
 (ns-set-resource nil (concat name ".attributeUnderline")
 (if underline "YES" nil))
 (ns-set-resource nil (concat name ".attributeItalic")
 (if italic "YES" nil))
 (ns-set-resource nil (concat name ".attributeBold")
 (if bold "YES" nil))
 (and stipple
 (or (stringp stipple)
 (setq stipple (prin1-to-string stipple))))
 (ns-set-resource nil (concat name ".attributeStipple")
 (if stipple stipple nil))))
 (setq fl (cdr fl)))))
 (declare-function menu-bar-options-save-orig "ns-win" () t)
 ;; call ns-save-preferences when menu-bar-options-save is called
 ;;;; File handling.
 (defun ns-open-file-using-panel ()
 "Pop up open-file panel, and load the result in a buffer."
 (interactive)
-; prompt dir defaultName isLoad initial
+;; Prompt dir defaultName isLoad initial.
 (setq ns-input-file (ns-read-file-name "Select File to Load" nil t nil))
 (if ns-input-file
 (and (setq ns-input-file (list ns-input-file)) (ns-find-file))))
 (defun ns-write-file-using-panel ()
 "Pop up save-file panel, and save buffer in resulting name."
 (interactive)
 (let (ns-output-file)
-; prompt dir defaultName isLoad initial
+;; Prompt dir defaultName isLoad initial.
 (setq ns-output-file (ns-read-file-name "Save As" nil nil nil))
 (message ns-output-file)
 (if ns-output-file (write-file ns-output-file))))
 (defvar ns-pop-up-frames 'fresh
 (defun ns-prev-frame ()
 "Switch to previous visible frame."
 (interactive)
 (other-frame -1))
-; If no position specified, make new frame offset by 25 from current.
+;; If no position specified, make new frame offset by 25 from current.
 (add-hook 'before-make-frame-hook
-'(lambda ()
+(lambda ()
 (let ((left (cdr (assq 'left (frame-parameters))))
 (top (cdr (assq 'top (frame-parameters)))))
-	       (if (consp left) (setq left (cadr left)))
+(if (consp left) (setq left (cadr left)))
-	       (if (consp top) (setq top (cadr top)))
+(if (consp top) (setq top (cadr top)))
 (cond
 ((or (assq 'top parameters) (assq 'left parameters)))
 ((or (not left) (not top)))
 (t
 (setq parameters (cons (cons 'left (+ left 25))
 (cons (cons 'top (+ top 25))
 parameters))))))))
-; frame will be focused anyway, so select it
+;; frame will be focused anyway, so select it
 (add-hook 'after-make-frame-functions 'select-frame)
-;;; (defun ns-win-suspend-error ()
+;; (defun ns-win-suspend-error ()
-;;;   (error "Suspending an emacs running under *Step/OS X makes no sense"))
+;;   (error "Suspending an emacs running under *Step/OS X makes no sense"))
-;;; (add-hook 'suspend-hook 'ns-win-suspend-error)
+;; (add-hook 'suspend-hook 'ns-win-suspend-error)
-;;; (substitute-key-definition 'suspend-emacs 'iconify-or-deiconify-frame
+;; (substitute-key-definition 'suspend-emacs 'iconify-or-deiconify-frame
-;;; 			   global-map)
+;; 			   global-map)
 ;; Based on a function by David Reitter <dreitter@inf.ed.ac.uk> ;
 ;; see http://lists.gnu.org/archive/html/emacs-devel/2005-09/msg00681.html .
 (defun ns-toggle-toolbar (&optional frame)
 "Switches the tool bar on and off in frame FRAME.
 If FRAME is nil, the change applies to the selected frame."
 (interactive)
-(modify-frame-parameters frame
+(modify-frame-parameters
-	   (list (cons 'tool-bar-lines
+frame (list (cons 'tool-bar-lines
 		       (if (> (or (frame-parameter frame 'tool-bar-lines) 0) 0)
 				   0 1)) ))
 (if (not tool-bar-mode) (tool-bar-mode t)))
 (defvar ns-cursor-blink-mode) 		; nsterm.m
-; Redefine from frame.el
+;; Redefine from frame.el.
 (define-minor-mode blink-cursor-mode
 "Toggle blinking cursor mode.
 With a numeric argument, turn blinking cursor mode on if ARG is positive,
 otherwise turn it off.  When blinking cursor mode is enabled, the
 cursor of the selected window blinks.
 ;; Ask user for confirm before printing.  Due to Kevin Rodgers.
 (defun ns-print-buffer ()
 "Interactive front-end to `print-buffer': asks for user confirmation first."
 (interactive)
 (if (and (interactive-p)
-	     (or (listp last-nonmenu-event)
+(or (listp last-nonmenu-event)
-		 (and (char-or-string-p (event-basic-type last-command-event))
+(and (char-or-string-p (event-basic-type last-command-event))
-		      (memq 'super (event-modifiers last-command-event)))))
+(memq 'super (event-modifiers last-command-event)))))
 (let ((last-nonmenu-event (if (listp last-nonmenu-event)
-				  last-nonmenu-event
+last-nonmenu-event
-				;; fake it:
+;; Fake it:
-				`(mouse-1 POSITION 1))))
+`(mouse-1 POSITION 1))))
 (if (y-or-n-p (format "Print buffer %s? " (buffer-name)))
-	  (print-buffer)
+(print-buffer)
 	  (error "Cancelled")))
 (print-buffer)))
 (defun ns-yes-or-no-p (prompt)
 "As yes-or-no-p except that NS panel always used for querying."
 (interactive)
 (setq last-nonmenu-event nil)
 (yes-or-no-p prompt))
 ;;;; Font support.
 (defalias 'x-list-fonts 'ns-list-fonts)
 ;; Default fontset for Mac OS X.  This is mainly here to show how a fontset
 ;; can be set up manually.  Ordinarily, fontsets are auto-created whenever
 ;; a font is chosen by
 (defvar ns-standard-fontset-spec
-; Only some code supports this so far, so use uglier XLFD version
+;; Only some code supports this so far, so use uglier XLFD version
-; "-ns-*-*-*-*-*-10-*-*-*-*-*-fontset-standard,latin:Courier,han:Kai"
+;; "-ns-*-*-*-*-*-10-*-*-*-*-*-fontset-standard,latin:Courier,han:Kai"
-"-ns-*-*-*-*-*-10-*-*-*-*-*-fontset-standard,latin:-*-Courier-*-*-*-*-10-*-*-*-*-*-iso10646-1,han:-*-Kai-*-*-*-*-10-*-*-*-*-*-iso10646-1,cyrillic:-*-Trebuchet$MS-*-*-*-*-10-*-*-*-*-*-iso10646-1"
+(mapconcat 'identity
-"String of fontset spec of the standard fontset.
+'("-ns-*-*-*-*-*-10-*-*-*-*-*-fontset-standard"
+"latin:-*-Courier-*-*-*-*-10-*-*-*-*-*-iso10646-1"
+"han:-*-Kai-*-*-*-*-10-*-*-*-*-*-iso10646-1"
+"cyrillic:-*-Trebuchet$MS-*-*-*-*-10-*-*-*-*-*-iso10646-1")
+",")
+"String of fontset spec of the standard fontset.
 This defines a fontset consisting of the Courier and other fonts that
 come with OS X\".
 See the documentation of `create-fontset-from-fontset-spec for the format.")
-;; Conditional on new-fontset so bootstrapping works on non-GUI compiles
+;; Conditional on new-fontset so bootstrapping works on non-GUI compiles.
 (if (fboundp 'new-fontset)
 (progn
 ;; Setup the default fontset.
 (setup-default-fontset)
 ;; Create the standard fontset.
-(create-fontset-from-fontset-spec ns-standard-fontset-spec t)
+(create-fontset-from-fontset-spec ns-standard-fontset-spec t)))
-))
+;;(push (cons 'font "-ns-*-*-*-*-*-10-*-*-*-*-*-fontset-standard")
-;(setq default-frame-alist (cons (cons 'font "-ns-*-*-*-*-*-10-*-*-*-*-*-fontset-standard") default-frame-alist))
+;;      default-frame-alist)
-;; add some additional scripts to var we use for fontset generation
+;; Add some additional scripts to var we use for fontset generation.
 (setq script-representative-chars
 (cons '(kana #xff8a)
 	    (cons '(symbol #x2295 #x2287 #x25a1)
-		 script-representative-chars)))
+script-representative-chars)))
 ;;;; Pasteboard support.
 (declare-function ns-get-cut-buffer-internal "nsselect.m" (buffer))
 "Store STRING into the NS server's pasteboard."
 ;; Check the data type of STRING.
 (if (not (stringp string)) (error "Nonstring given to pasteboard"))
 (ns-store-cut-buffer-internal 'PRIMARY string))
-;;; We keep track of the last text selected here, so we can check the
+;; We keep track of the last text selected here, so we can check the
-;;; current selection against it, and avoid passing back our own text
+;; current selection against it, and avoid passing back our own text
-;;; from ns-pasteboard-value.
+;; from ns-pasteboard-value.
 (defvar ns-last-selected-text nil)
-;;; Put TEXT, a string, on the pasteboard.
 (defun ns-select-text (text &optional push)
+"Put TEXT, a string, on the pasteboard."
 ;; Don't send the pasteboard too much text.
 ;; It becomes slow, and if really big it causes errors.
 (ns-set-pasteboard text)
 (setq ns-last-selected-text text))
-;;; Return the value of the current NS selection.  For compatibility
+;; Return the value of the current NS selection.  For compatibility
-;;; with older NS applications, this checks cut buffer 0 before
+;; with older NS applications, this checks cut buffer 0 before
-;;; retrieving the value of the primary selection.
+;; retrieving the value of the primary selection.
 (defun ns-pasteboard-value ()
 (let (text)
 ;; Consult the selection, then the cut buffer.  Treat empty strings
 ;; as if they were unset.
 (defun ns-paste-secondary ()
 (interactive)
 (insert (ns-get-cut-buffer-internal 'SECONDARY)))
 ;; PENDING: not sure what to do here.. for now interprog- are set in
-;; init-fn-keys, and unsure whether these x- settings have an effect
+;; init-fn-keys, and unsure whether these x- settings have an effect.
 ;;(setq interprogram-cut-function 'ns-select-text
 ;;      interprogram-paste-function 'ns-pasteboard-value)
-; these only needed if above not working
+;; These only needed if above not working.
 (defalias 'x-select-text 'ns-select-text)
 (defalias 'x-cut-buffer-or-selection-value 'ns-pasteboard-value)
 (defalias 'x-disown-selection-internal 'ns-disown-selection-internal)
 (defalias 'x-get-selection-internal 'ns-get-selection-internal)
 (defalias 'x-own-selection-internal 'ns-own-selection-internal)
 ((eq bar-part 'ratio)
 (ns-scroll-bar-move event))
 ((eq bar-part 'handle)
 (if (eq window (selected-window))
 	  (track-mouse (ns-scroll-bar-move event))
-	; track-mouse faster for selected window, slower for unselected
+;; track-mouse faster for selected window, slower for unselected.
 	(ns-scroll-bar-move event)))
 (t
 (select-window window)
 (cond
 ((eq bar-part 'up)
 	(this-color nil)
 	(defined-colors nil))
 (while all-colors
 (setq this-color (car all-colors)
 	    all-colors (cdr all-colors))
-;      (and (face-color-supported-p frame this-color t)
+;; (and (face-color-supported-p frame this-color t)
-(setq defined-colors (cons this-color defined-colors)))
+(setq defined-colors (cons this-color defined-colors))) ;;)
-;)
 defined-colors))
 (defalias 'x-defined-colors 'ns-defined-colors)
 (defalias 'xw-defined-colors 'ns-defined-colors)
 (declare-function ns-set-alpha "nsfns.m" (color alpha))
 (t
 (set-face-background face ns-input-color frame)))))
-;; Misc aliases
+;; Misc aliases.
 (defalias 'x-display-mm-width 'ns-display-mm-width)
 (defalias 'x-display-mm-height 'ns-display-mm-height)
 (defalias 'x-display-backing-store 'ns-display-backing-store)
 (defalias 'x-display-save-under 'ns-display-save-under)
 (defalias 'x-display-visual-class 'ns-display-visual-class)
 ;; Set some options to be as NS-like as possible.
 (setq frame-title-format t
 icon-title-format t)
-;; Set up browser connectivity
+;; Set up browser connectivity.
 (defvar browse-url-generic-program)
 (setq browse-url-browser-function 'browse-url-generic)
-(cond ((eq system-type 'darwin)
+(setq browse-url-generic-program
-(setq browse-url-generic-program "open"))
+(cond ((eq system-type 'darwin) "open")
-;; otherwise, gnustep
+;; Otherwise, GNUstep.
-(t
+(t "gopen")))
-(setq browse-url-generic-program "gopen")) )
 (defvar ns-initialized nil
 "Non-nil if NS windowing has been initialized.")
 (declare-function ns-open-connection "nsfns.m"
 		  (display &optional resource_string must_succeed))
 (declare-function ns-list-services "nsfns.m" ())
-;;; Do the actual NS Windows setup here; the above code just defines
+;; Do the actual NS Windows setup here; the above code just defines
-;;; functions and variables that we use now.
+;; functions and variables that we use now.
 (defun ns-initialize-window-system ()
 "Initialize Emacs for NS (Cocoa / GNUstep) windowing."
-; PENDING: not needed?
+;; PENDING: not needed?
 (setq command-line-args (ns-handle-args command-line-args))
 (ns-open-connection (system-name) nil t)
-(let ((services (ns-list-services)))
+(dolist (service (ns-list-services))
-(while services
+(if (eq (car service) 'undefined)
-(if (eq (caar services) 'undefined)
+	  (ns-define-service (cdr service))
-	  (ns-define-service (cdar services))
+	(define-key global-map (vector (car service))
-	(define-key global-map (vector (caar services))
+	  (ns-define-service (cdr service)))))
-	  (ns-define-service (cdar services)))
-	)
-(setq services (cdr services))))
 (if (and (eq (get-lisp-resource nil "NXAutoLaunch") t)
 	   (eq (get-lisp-resource nil "HideOnAutoLaunch") t))
 (add-hook 'after-init-hook 'ns-do-hide-emacs))
+;; FIXME: This will surely lead to "MODIFIED OUTSIDE CUSTOM" warnings.
 (menu-bar-mode (if (get-lisp-resource nil "Menus") 1 -1))
 (mouse-wheel-mode 1)
 (setq ns-initialized t))

Mercurial > emacs

comparison lisp/term/ns-win.el @ 96748:92f7bbffcb45