git.chise.org Git - chise/xemacs-chise.git.1/blob - 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)))