lisp/term/pc-win.el

   1 ;; pc-win.el -- setup support for `PC windows' (whatever that is).
   2
   3 ;; Copyright (C) 1994, 1996 Free Software Foundation, Inc.
   4
   5 ;; Author: Morten Welinder <terra@diku.dk>
   6 ;; Maintainer: FSF
   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 the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Code:
  26
  27 (load "term/internal" nil t)
  28
  29 ;; Color translation -- doesn't really need to be fast.
  30 ;; Colors listed here do not include the "light-",
  31 ;; "medium-" and "dark-" prefixes that are accounted for
  32 ;; by `msdos-color-translate', which see below).
  33
  34 (defvar msdos-color-aliases
  35   '(("snow"             . "white")
  36     ("ghost white"      . "white")
  37     ("ghostwhite"       . "white")
  38     ("white smoke"      . "white")
  39     ("whitesmoke"       . "white")
  40     ("gainsboro"        . "white")
  41     ("floral white"     . "white")
  42     ("floralwhite"      . "white")
  43     ("old lace"         . "white")
  44     ("oldlace"          . "white")
  45     ("linen"            . "white")
  46     ("antique white"    . "white")
  47     ("antiquewhite"     . "white")
  48     ("papaya whip"      . "white")
  49     ("papayawhip"       . "white")
  50     ("blanched almond"  . "white")
  51     ("blanchedalmond"   . "white")
  52     ("bisque"           . "white")
  53     ("peach puff"       . "lightred")
  54     ("peachpuff"        . "lightred")
  55     ("navajo white"     . "lightred")
  56     ("navajowhite"      . "lightred")
  57     ("moccasin"         . "lightred")
  58     ("cornsilk"         . "white")
  59     ("ivory"            . "white")
  60     ("lemon chiffon"    . "yellow")
  61     ("lemonchiffon"     . "yellow")
  62     ("seashell"         . "white")
  63     ("honeydew"         . "white")
  64     ("mint cream"       . "white")
  65     ("mintcream"        . "white")
  66     ("azure"            . "lightcyan")
  67     ("alice blue"       . "lightcyan")
  68     ("aliceblue"        . "lightcyan")
  69     ("lavender"         . "lightcyan")
  70     ("lavender blush"   . "lightcyan")
  71     ("lavenderblush"    . "lightcyan")
  72     ("misty rose"       . "lightred")
  73     ("mistyrose"        . "lightred")
  74     ("aquamarine"       . "blue")
  75     ("cadet blue"       . "blue")
  76     ("cadetblue"        . "blue")
  77     ("cornflower blue"  . "lightblue")
  78     ("cornflowerblue"   . "lightblue")
  79     ("midnight blue"    . "blue")
  80     ("midnightblue"     . "blue")
  81     ("navy blue"        . "cyan")
  82     ("navyblue"         . "cyan")
  83     ("navy"             . "cyan")
  84     ("sky blue"         . "lightblue")
  85     ("skyblue"          . "lightblue")
  86     ("dodger blue"      . "blue")
  87     ("dodgerblue"       . "blue")
  88     ("powder blue"      . "lightblue")
  89     ("powderblue"       . "lightblue")
  90     ("slate blue"       . "cyan")
  91     ("slateblue"        . "cyan")
  92     ("steel blue"       . "blue")
  93     ("steelblue"        . "blue")
  94     ("coral"            . "lightred")
  95     ("firebrick"        . "red")
  96     ("gold"             . "yellow")
  97     ("goldenrod"        . "yellow")
  98     ("pale goldenrod"   . "yellow")
  99     ("palegoldenrod"    . "yellow")
 100     ("olive green"      . "lightgreen")
 101     ("olivegreen"       . "lightgreen")
 102     ("olive drab"       . "green")
 103     ("olivedrab"        . "green")
 104     ("forest green"     . "green")
 105     ("forestgreen"      . "green")
 106     ("lime green"       . "lightgreen")
 107     ("limegreen"        . "lightgreen")
 108     ("sea green"        . "lightcyan")
 109     ("seagreen"         . "lightcyan")
 110     ("spring green"     . "green")
 111     ("springgreen"      . "green")
 112     ("pale green"       . "lightgreen")
 113     ("palegreen"        . "lightgreen")
 114     ("lawn green"       . "lightgreen")
 115     ("lawngreen"        . "lightgreen")
 116     ("chartreuse"       . "yellow")
 117     ("yellow green"     . "lightgreen")
 118     ("yellowgreen"      . "lightgreen")
 119     ("green yellow"     . "lightgreen")
 120     ("greenyellow"      . "lightgreen")
 121     ("slate grey"       . "lightgray")
 122     ("slategrey"        . "lightgray")
 123     ("slate gray"       . "lightgray")
 124     ("slategray"        . "lightgray")
 125     ("dim grey"         . "darkgray")
 126     ("dimgrey"          . "darkgray")
 127     ("dim gray"         . "darkgray")
 128     ("dimgray"          . "darkgray")
 129     ("light grey"       . "lightgray")
 130     ("lightgrey"        . "lightgray")
 131     ("light gray"       . "lightgray")
 132     ("gray"             . "darkgray")
 133     ("grey"             . "darkgray")
 134     ("gray80"           . "darkgray")
 135     ("gray50"           . "black")
 136     ("gray90"           . "darkgray")
 137     ("khaki"            . "green")
 138     ("maroon"           . "red")
 139     ("orange"           . "brown")
 140     ("orchid"           . "brown")
 141     ("saddle brown"     . "red")
 142     ("saddlebrown"      . "red")
 143     ("sienna"           . "red")
 144     ("peru"             . "red")
 145     ("pink"             . "lightred")
 146     ("plum"             . "magenta")
 147     ("indian red"       . "red")
 148     ("indianred"        . "red")
 149     ("violet red"       . "magenta")
 150     ("violetred"        . "magenta")
 151     ("orange red"       . "red")
 152     ("orangered"        . "red")
 153     ("salmon"           .  "lightred")
 154     ("sienna"           . "lightred")
 155     ("tan"              . "lightred")
 156     ("thistle"          . "magenta")
 157     ("turquoise"        . "lightgreen")
 158     ("pale turquoise"   . "cyan")
 159     ("paleturquoise"    . "cyan")
 160     ("violet"           . "magenta")
 161     ("blue violet"      . "lightmagenta")
 162     ("blueviolet"       . "lightmagenta")
 163     ("wheat"            . "white")
 164     ("green yellow"     . "yellow")
 165     ("greenyellow"      . "yellow")
 166     ("purple"           . "magenta")
 167     ("royalblue"        . "blue")
 168     ("grey40"           . "darkgray")
 169     ("rosybrown"        . "brown")
 170     ("rosy brown"       . "brown")
 171     ("beige"            . "brown"))
 172   "List of alternate names for colors.")
 173
 174 (defun msdos-color-translate (name)
 175   (setq name (downcase name))
 176   (let* ((len (length name))
 177          (val (- (length x-colors)
 178                  (length (member name x-colors))))
 179          (try))
 180     (if (or (< val 0) (>= val (length x-colors))) (setq val nil))
 181     (or val
 182         (and (setq try (cdr (assoc name msdos-color-aliases)))
 183              (msdos-color-translate try))
 184         (and (> len 5)
 185              (string= "light" (substring name 0 5))
 186              (setq try (msdos-color-translate (substring name 5)))
 187              (logior try 8))
 188         (and (> len 6)
 189              (string= "light " (substring name 0 6))
 190              (setq try (msdos-color-translate (substring name 6)))
 191              (logior try 8))
 192         (and (> len 6)
 193              (string= "medium" (substring name 0 6))
 194              (msdos-color-translate (substring name 6)))
 195         (and (> len 7)
 196              (string= "medium " (substring name 0 7))
 197              (msdos-color-translate (substring name 7)))
 198         (and (> len 4)
 199              (string= "dark" (substring name 0 4))
 200              (msdos-color-translate (substring name 4)))
 201         (and (> len 5)
 202              (string= "dark " (substring name 0 5))
 203              (msdos-color-translate (substring name 5))))))
 204 ;; ---------------------------------------------------------------------------
 205 ;; We want to delay setting frame parameters until the faces are setup
 206 (defvar default-frame-alist nil)
 207 (modify-frame-parameters terminal-frame default-frame-alist)
 208
 209 (defun msdos-face-setup ()
 210   (modify-frame-parameters terminal-frame default-frame-alist)
 211
 212   (set-face-foreground 'bold "yellow" terminal-frame)
 213   (set-face-foreground 'italic "red" terminal-frame)
 214   (set-face-foreground 'bold-italic "lightred" terminal-frame)
 215   (set-face-foreground 'underline "white" terminal-frame)
 216   (set-face-background 'region "green" terminal-frame)
 217
 218   (make-face 'msdos-menu-active-face)
 219   (make-face 'msdos-menu-passive-face)
 220   (make-face 'msdos-menu-select-face)
 221   (set-face-foreground 'msdos-menu-active-face "white" terminal-frame)
 222   (set-face-foreground 'msdos-menu-passive-face "lightgray" terminal-frame)
 223   (set-face-background 'msdos-menu-active-face "blue" terminal-frame)
 224   (set-face-background 'msdos-menu-passive-face "blue" terminal-frame)
 225   (set-face-background 'msdos-menu-select-face "red" terminal-frame))
 226
 227 ;; We have only one font, so...
 228 (add-hook 'before-init-hook 'msdos-face-setup)
 229
 230 ;; We create frames as if we were a terminal, but with a twist.
 231 (defun make-msdos-frame (&optional parameters)
 232   (let ((parms
 233          (append initial-frame-alist default-frame-alist parameters nil)))
 234     (make-terminal-frame parms)))
 235
 236 (setq frame-creation-function 'make-msdos-frame)
 237
 238 ;; ---------------------------------------------------------------------------
 239 ;; More or less useful imitations of certain X-functions.  A lot of the
 240 ;; values returned are questionable, but usually only the form of the
 241 ;; returned value matters.  Also, by the way, recall that `ignore' is
 242 ;; a useful function for returning 'nil regardless of argument.
 243
 244 ;; From src/xfns.c
 245 (defun x-display-color-p (&optional display) 't)
 246 (defun x-list-fonts (pattern &optional face frame) (list "default"))
 247 (defun x-color-defined-p (color) (numberp (msdos-color-translate color)))
 248 (defun x-display-pixel-width (&optional frame) (frame-width frame))
 249 (defun x-display-pixel-height (&optional frame) (frame-height frame))
 250 (defun x-display-planes (&optional frame) 4) ; 3 for background, actually
 251 (defun x-display-color-cells (&optional frame) 16) ; ???
 252 (defun x-server-max-request-size (&optional frame) 1000000) ; ???
 253 (defun x-server-vendor (&optional frame) t "GNU")
 254 (defun x-server-version (&optional frame) '(1 0 0))
 255 (defun x-display-screens (&optional frame) 1)
 256 (defun x-display-mm-height (&optional frame) 200) ; Guess the size of my
 257 (defun x-display-mm-width (&optional frame) 253)  ; monitor, MW...
 258 (defun x-display-backing-store (&optional frame) 'not-useful)
 259 (defun x-display-visual-class (&optional frame) 'static-color)
 260 (fset 'x-display-save-under 'ignore)
 261 (fset 'x-get-resource 'ignore)
 262
 263 ;; From lisp/term/x-win.el
 264 (setq x-display-name "pc")
 265 (setq split-window-keep-point t)
 266 (defvar x-colors '("black"
 267                    "blue"
 268                    "green"
 269                    "cyan"
 270                    "red"
 271                    "magenta"
 272                    "brown"
 273                    "lightgray"
 274                    "darkgray"
 275                    "lightblue"
 276                    "lightgreen"
 277                    "lightcyan"
 278                    "lightred"
 279                    "lightmagenta"
 280                    "yellow"
 281                    "white")
 282   "The list of colors available on a PC display under MS-DOS.")
 283 (defun x-defined-colors (&optional frame)
 284   "Return a list of colors supported for a particular frame.
 285 The argument FRAME specifies which frame to try.
 286 The value may be different for frames on different X displays."
 287   x-colors)
 288 ;
 289 ;; From lisp/select.el
 290 (defun x-get-selection (&rest rest) "")
 291 (fset 'x-set-selection 'ignore)
 292
 293 ;; From lisp/faces.el: we only have one font, so always return
 294 ;; it, no matter which variety they've asked for.
 295 (defun x-frob-font-slant (font which)
 296   font)
 297
 298 ;; From lisp/term/x-win.el: make iconify-or-deiconify-frame a no-op.
 299 (fset 'iconify-or-deiconify-frame 'ignore)
 300
 301 ;; From lisp/frame.el
 302 (fset 'set-default-font 'ignore)
 303 (fset 'set-mouse-color 'ignore)         ; We cannot, I think.
 304 (fset 'set-cursor-color 'ignore)        ; Hardware determined by char under.
 305 (fset 'set-border-color 'ignore)        ; Not useful.
 306 ;; ---------------------------------------------------------------------------
 307 ;; Handle the X-like command line parameters "-fg" and "-bg"
 308 (defun msdos-handle-args (args)
 309   (let ((rest nil))
 310     (while args
 311       (let ((this (car args)))
 312         (setq args (cdr args))
 313         (cond ((or (string= this "-fg") (string= this "-foreground"))
 314                (if args
 315                    (setq default-frame-alist
 316                          (cons (cons 'foreground-color (car args))
 317                                default-frame-alist)
 318                          args (cdr args))))
 319               ((or (string= this "-bg") (string= this "-background"))
 320                (if args
 321                    (setq default-frame-alist
 322                          (cons (cons 'background-color (car args))
 323                                default-frame-alist)
 324                          args (cdr args))))
 325               (t (setq rest (cons this rest))))))
 326     (nreverse rest)))
 327
 328 (setq command-line-args (msdos-handle-args command-line-args))
 329 ;; ---------------------------------------------------------------------------