Reformatted.
[chise/xemacs-chise.git] / lisp / term / pc-win.el
1 ;; pc-win.el -- setup support for `PC windows' (whatever that is).
2
3 ;; Copyright (C) 1994 Free Software Foundation, Inc.
4
5 ;; Author: Morten Welinder <terra@diku.dk>
6 ;; Version: 1,00
7
8 ;; This file is part of GNU Emacs.
9
10 ;; GNU Emacs is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
13 ;; any later version.
14
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
18 ;; GNU General Public License for more details.
19
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING.  If not, write to
22 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
23 ;; ---------------------------------------------------------------------------
24 (load "term/internal" nil t)
25
26 ;; Color translation -- doesn't really need to be fast
27
28 (defvar msdos-color-aliases
29   '(("purple"         . "magenta")
30     ("firebrick"      . "red")          ; ?
31     ("pink"           . "lightred")
32     ("royalblue"      . "blue")
33     ("cadetblue"      . "blue")
34     ("forestgreen"    . "green")
35     ("darkolivegreen" . "green")
36     ("darkgoldenrod"  . "brown")
37     ("goldenrod"      . "yellow")
38     ("grey40"         . "darkgray")
39     ("rosybrown"      . "brown")
40     ("blue"           . "lightblue")  ;; from here: for Enriched Text
41     ("darkslategray"  . "darkgray")
42     ("orange"         . "brown")
43     ("light blue"     . "lightblue")  ;; from here: for cpp-highlight
44     ("light cyan"     . "lightcyan")
45     ("light yellow"   . "yellow")
46     ("light pink"     . "lightred")
47     ("pale green"     . "lightgreen")
48     ("beige"          . "brown")
49     ("medium purple"  . "magenta")
50     ("turquoise"      . "lightgreen")
51     ("violet"         . "magenta"))
52   "List of alternate names for colors.")
53
54 (defun msdos-color-translate (name)
55   (setq name (downcase name))
56   (let* ((len (length name))
57          (val (cdr (assoc name
58                          '(("black" . 0)
59                            ("blue" . 1)
60                            ("green" . 2)
61                            ("cyan" . 3)
62                            ("red" . 4)
63                            ("magenta" . 5)
64                            ("brown" . 6)
65                            ("lightgray" . 7) ("light gray" . 7)
66                            ("darkgray" . 8) ("dark gray" . 8)
67                            ("lightblue" . 9)
68                            ("lightgreen" . 10)
69                            ("lightcyan" . 11)
70                            ("lightred" . 12)
71                            ("lightmagenta" . 13)
72                            ("yellow" . 14)
73                            ("white" . 15)))))
74          (try))
75     (or val
76         (and (setq try (cdr (assoc name msdos-color-aliases)))
77              (msdos-color-translate try))
78         (and (> len 5)
79              (string= "light" (substring name 0 4))
80              (setq try (msdos-color-translate (substring name 5)))
81              (logior try 8))
82         (and (> len 6)
83              (string= "light " (substring name 0 5))
84              (setq try (msdos-color-translate (substring name 6)))
85              (logior try 8))
86         (and (> len 4)
87              (string= "dark" (substring name 0 3))
88              (msdos-color-translate (substring name 4)))
89         (and (> len 5)
90              (string= "dark " (substring name 0 4))
91              (msdos-color-translate (substring name 5))))))
92 ;; ---------------------------------------------------------------------------
93 ;; We want to delay setting frame parameters until the faces are setup
94 (defvar default-frame-alist nil)
95
96 (defun msdos-face-setup ()
97   (modify-frame-parameters (selected-frame) default-frame-alist)
98
99   (set-face-foreground 'bold "yellow")
100   (set-face-foreground 'italic "red")
101   (set-face-foreground 'bold-italic "lightred")
102   (set-face-foreground 'underline "white")
103   (set-face-background 'region "green")
104
105   (make-face 'msdos-menu-active-face)
106   (make-face 'msdos-menu-passive-face)
107   (make-face 'msdos-menu-select-face)
108   (set-face-foreground 'msdos-menu-active-face "white")
109   (set-face-foreground 'msdos-menu-passive-face "lightgray")
110   (set-face-background 'msdos-menu-active-face "blue")
111   (set-face-background 'msdos-menu-passive-face "blue")
112   (set-face-background 'msdos-menu-select-face "red"))
113
114 ;; We have only one font, so...
115 (add-hook 'before-init-hook 'msdos-face-setup)
116 ;; ---------------------------------------------------------------------------
117 ;; More or less useful imitations of certain X-functions.  A lot of the
118 ;; values returned are questionable, but usually only the form of the
119 ;; returned value matters.  Also, by the way, recall that `ignore' is
120 ;; a useful function for returning 'nil regardless of argument.
121
122 ;; From src/xfns.c
123 (defun x-display-color-p (&optional display) 't)
124 (fset 'focus-frame 'ignore)
125 (fset 'unfocus-frame 'ignore)
126 (defun x-list-fonts (pattern &optional face frame) (list "default"))
127 (defun x-color-defined-p (color) (numberp (msdos-color-translate color)))
128 (defun x-display-pixel-width (&optional frame) (* 8 (frame-width frame)))
129 (defun x-display-pixel-height (&optional frame) (* 8 (frame-height frame)))
130 (defun x-display-planes (&optional frame) 4) ; 3 for background, actually
131 (defun x-display-color-cells (&optional frame) 16) ; ???
132 (defun x-server-max-request-size (&optional frame) 1000000) ; ???
133 (defun x-server-vendor (&optional frame) t "GNU")
134 (defun x-server-version (&optional frame) '(1 0 0))
135 (defun x-display-screens (&optional frame) 1)
136 (defun x-display-mm-height (&optional frame) 200) ; Guess the size of my
137 (defun x-display-mm-width (&optional frame) 253)  ; monitor, MW...
138 (defun x-display-backing-store (&optional frame) 'not-useful)
139 (defun x-display-visual-class (&optional frame) 'static-color)
140 (fset 'x-display-save-under 'ignore)
141 (fset 'x-get-resource 'ignore)
142
143 ;; From lisp/term/x-win.el
144 (setq x-display-name "pc")
145 (setq split-window-keep-point t)
146
147 ;; From lisp/select.el
148 (defun x-get-selection (&rest rest) "")
149 (fset 'x-set-selection 'ignore)
150
151 ;; From lisp/faces.el: we only have one font, so always return
152 ;; it, no matter which variety they've asked for.
153 (defun x-frob-font-slant (font which)
154   font)
155
156 ;; From lisp/frame.el
157 (fset 'set-default-font 'ignore)
158 (fset 'set-mouse-color 'ignore)         ; We cannot, I think.
159 (fset 'set-cursor-color 'ignore)        ; Hardware determined by char under.
160 (fset 'set-border-color 'ignore)        ; Not useful.
161 (fset 'auto-raise-mode 'ignore)
162 (fset 'auto-lower-mode 'ignore)
163 (defun set-background-color (color-name)
164   "Set the background color of the selected frame to COLOR.
165 When called interactively, prompt for the name of the color to use."
166   (interactive "sColor: ")
167   (modify-frame-parameters (selected-frame)
168                            (list (cons 'background-color color-name))))
169 (defun set-foreground-color (color-name)
170   "Set the foreground color of the selected frame to COLOR.
171 When called interactively, prompt for the name of the color to use."
172   (interactive "sColor: ")
173   (modify-frame-parameters (selected-frame)
174                            (list (cons 'foreground-color color-name))))
175 ;; ---------------------------------------------------------------------------
176 ;; Handle the X-like command line parameters "-fg" and "-bg"
177 (defun msdos-handle-args (args)
178   (let ((rest nil))
179     (while args
180       (let ((this (car args)))
181         (setq args (cdr args))
182         (cond ((or (string= this "-fg") (string= this "-foreground"))
183                (if args
184                    (setq default-frame-alist
185                          (cons (cons 'foreground-color (car args))
186                                default-frame-alist)
187                          args (cdr args))))
188               ((or (string= this "-bg") (string= this "-background"))
189                (if args
190                    (setq default-frame-alist
191                          (cons (cons 'background-color (car args))
192                                default-frame-alist)
193                          args (cdr args))))
194               (t (setq rest (cons this rest))))))
195     (nreverse rest)))
196
197 (setq command-line-args (msdos-handle-args command-line-args))
198 ;; ---------------------------------------------------------------------------
199 ;; XEmacs always has faces
200 ;;(require 'faces)
201 (if (msdos-mouse-p)
202     (progn
203       (require 'menu-bar)
204       (menu-bar-mode t)))