Mercurial > emacs
comparison lisp/term/pc-win.el @ 9571:b37425ecb3f0
Initial revision
author | Morten Welinder <terra@diku.dk> |
---|---|
date | Mon, 17 Oct 1994 08:04:13 +0000 |
parents | |
children | be831ed47a75 |
comparison
equal
deleted
inserted
replaced
9570:9eae919f9a23 | 9571:b37425ecb3f0 |
---|---|
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 "List of alternate names for colors.") | |
41 | |
42 (defun msdos-color-translate (name) | |
43 (setq name (downcase name)) | |
44 (let* ((len (length name)) | |
45 (val (cdr (assoc name | |
46 '(("black" . 0) | |
47 ("blue" . 1) | |
48 ("green" . 2) | |
49 ("cyan" . 3) | |
50 ("red" . 4) | |
51 ("magenta" . 5) | |
52 ("brown" . 6) | |
53 ("lightgray" . 7) ("light gray" . 7) | |
54 ("darkgray" . 8) ("dark gray" . 8) | |
55 ("lightblue" . 9) | |
56 ("lightgreen" . 10) | |
57 ("lightcyan" . 11) | |
58 ("lightred" . 12) | |
59 ("lightmagenta" . 13) | |
60 ("yellow" . 14) | |
61 ("white" . 15))))) | |
62 (try)) | |
63 (or val | |
64 (and (setq try (cdr (assoc name msdos-color-aliases))) | |
65 (msdos-color-translate try)) | |
66 (and (> len 5) | |
67 (string= "light" (substring name 0 4)) | |
68 (setq try (msdos-color-translate (substring name 5))) | |
69 (logior try 8)) | |
70 (and (> len 6) | |
71 (string= "light " (substring name 0 5)) | |
72 (setq try (msdos-color-translate (substring name 6))) | |
73 (logior try 8)) | |
74 (and (> len 4) | |
75 (string= "dark" (substring name 0 3)) | |
76 (msdos-color-translate (substring name 4))) | |
77 (and (> len 5) | |
78 (string= "dark " (substring name 0 4)) | |
79 (msdos-color-translate (substring name 5)))))) | |
80 ;; --------------------------------------------------------------------------- | |
81 ;; We want to delay setting frame parameters until the faces are setup | |
82 (defvar default-frame-alist nil) | |
83 | |
84 (defun msdos-face-setup () | |
85 (modify-frame-parameters (selected-frame) default-frame-alist) | |
86 | |
87 (set-face-foreground 'bold "white") | |
88 (set-face-foreground 'italic "red") | |
89 (set-face-foreground 'bold-italic "yellow") | |
90 (set-face-foreground 'underline "blue") | |
91 (set-face-background 'region "green") | |
92 | |
93 (make-face 'msdos-menu-active-face) | |
94 (make-face 'msdos-menu-passive-face) | |
95 (make-face 'msdos-menu-select-face) | |
96 (set-face-foreground 'msdos-menu-active-face "white") | |
97 (set-face-foreground 'msdos-menu-passive-face "lightgray") | |
98 (set-face-background 'msdos-menu-active-face "blue") | |
99 (set-face-background 'msdos-menu-passive-face "blue") | |
100 (set-face-background 'msdos-menu-select-face "red")) | |
101 | |
102 ;; We have only one font, so... | |
103 (add-hook 'before-init-hook 'msdos-face-setup) | |
104 ;; --------------------------------------------------------------------------- | |
105 ;; More or less useful immitations of certain X-functions. A lot of the | |
106 ;; values returned are questionable, but usually only the form of the | |
107 ;; returned value matters. Also, by the way, recall that `ignore' is | |
108 ;; a useful function for returning 'nil regardless of argument. | |
109 | |
110 ;; From src/xfns.c | |
111 (defun x-display-color-p () 't) | |
112 (fset 'focus-frame 'ignore) | |
113 (fset 'unfocus-frame 'ignore) | |
114 (defun x-list-fonts (pattern &optional face frame) (list "default")) | |
115 (defun x-color-defined-p (color) (numberp (msdos-color-translate color))) | |
116 (defun x-display-pixel-width (&optional frame) (* 8 (frame-width frame))) | |
117 (defun x-display-pixel-height (&optional frame) (* 8 (frame-height frame))) | |
118 (defun x-display-planes (&optional frame) 4) ; 3 for background, actually | |
119 (defun x-display-color-cells (&optional frame) 16) ; ??? | |
120 (defun x-server-max-request-size (&optional frame) 1000000) ; ??? | |
121 (defun x-server-vendor (&optional frame) t "GNU") | |
122 (defun x-server-version (&optional frame) '(1 0 0)) | |
123 (defun x-display-screens (&optional frame) 1) | |
124 (defun x-display-mm-height (&optional frame) 200) ; Guess the size of my | |
125 (defun x-display-mm-width (&optional frame) 253) ; monitor, MW... | |
126 (defun x-display-backing-store (&optional frame) 'not-useful) | |
127 (defun x-display-visual-class (&optional frame) 'static-color) | |
128 (fset 'x-display-save-under 'ignore) | |
129 (fset 'x-get-resource 'ignore) | |
130 | |
131 ;; From lisp/term/x-win.el | |
132 (setq x-display-name "pc") | |
133 (setq split-window-keep-point t) | |
134 | |
135 ;; From lisp/select.el | |
136 (defun x-get-selection (&rest rest) "") | |
137 (fset 'x-set-selection 'ignore) | |
138 | |
139 ;; From lisp/frame.el | |
140 (fset 'set-default-font 'ignore) | |
141 (fset 'set-mouse-color 'ignore) ; We cannot, I think. | |
142 (fset 'set-cursor-color 'ignore) ; Hardware determined by char under. | |
143 (fset 'set-border-color 'ignore) ; Not useful. | |
144 (fset 'auto-raise-mode 'ignore) | |
145 (fset 'auto-lower-mode 'ignore) | |
146 (defun set-background-color (color-name) | |
147 "Set the background color of the selected frame to COLOR. | |
148 When called interactively, prompt for the name of the color to use." | |
149 (interactive "sColor: ") | |
150 (modify-frame-parameters (selected-frame) | |
151 (list (cons 'background-color color-name)))) | |
152 (defun set-foreground-color (color-name) | |
153 "Set the foreground color of the selected frame to COLOR. | |
154 When called interactively, prompt for the name of the color to use." | |
155 (interactive "sColor: ") | |
156 (modify-frame-parameters (selected-frame) | |
157 (list (cons 'foreground-color color-name)))) | |
158 ;; --------------------------------------------------------------------------- | |
159 ;; Handle the X-like command line parameters "-fg" and "-bg" | |
160 (defun msdos-handle-args (args) | |
161 (let ((rest nil)) | |
162 (while args | |
163 (let ((this (car args))) | |
164 (setq args (cdr args)) | |
165 (cond ((or (string= this "-fg") (string= this "-foreground")) | |
166 (if args | |
167 (setq default-frame-alist | |
168 (cons (cons 'foreground-color (car args)) | |
169 default-frame-alist) | |
170 args (cdr args)))) | |
171 ((or (string= this "-bg") (string= this "-background")) | |
172 (if args | |
173 (setq default-frame-alist | |
174 (cons (cons 'background-color (car args)) | |
175 default-frame-alist) | |
176 args (cdr args)))) | |
177 (t (setq rest (cons this rest)))))) | |
178 (nreverse rest))) | |
179 | |
180 (setq command-line-args (msdos-handle-args command-line-args)) | |
181 ;; --------------------------------------------------------------------------- | |
182 (require 'faces) | |
183 (if (msdos-mouse-p) | |
184 (progn | |
185 (require 'menu-bar) | |
186 (menu-bar-mode t))) |