| 1 | ;;; dos-fns.el --- MS-Dos specific functions. |
| 2 | |
| 3 | ;; Copyright (C) 1991, 1993 Free Software Foundation, Inc. |
| 4 | |
| 5 | ;; Maintainer: Morten Welinder (terra@diku.dk) |
| 6 | ;; Keywords: internal |
| 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 | ;;; Commentary: |
| 25 | |
| 26 | ;; Part of this code is taken from (or derived from) demacs. |
| 27 | |
| 28 | ;;; Code: |
| 29 | |
| 30 | (setq-default mode-line-format |
| 31 | (list (purecopy "") |
| 32 | 'mode-line-modified |
| 33 | 'mode-line-buffer-identification |
| 34 | (purecopy " ") |
| 35 | 'global-mode-string |
| 36 | (purecopy " %[(") |
| 37 | (purecopy "%t:") |
| 38 | 'mode-name 'mode-line-process 'minor-mode-alist "%n" |
| 39 | (purecopy ")%]--") |
| 40 | (purecopy '(line-number-mode "L%l--")) |
| 41 | (purecopy '(-3 . "%p")) |
| 42 | (purecopy "-%-"))) |
| 43 | |
| 44 | (defvar file-name-buffer-file-type-alist |
| 45 | '( |
| 46 | ("[:/].*config.sys$" . nil) ; config.sys text |
| 47 | ("\\.elc$" . t) ; emacs stuff |
| 48 | ("\\.\\(obj\\|exe\\|com\\|lib\\|sys\\|chk\\|out\\|bin\\|ico\\|pif\\)$" . t) |
| 49 | ; MS-Dos stuff |
| 50 | ("\\.\\(arc\\|zip\\|pak\\|lzh\\|zoo\\)$" . t) |
| 51 | ; Packers |
| 52 | ("\\.\\(a\\|o\\|tar\\|z\\|gz\\|taz\\)$" . t) |
| 53 | ; Unix stuff |
| 54 | ("\\.tp[ulpw]$" . t) |
| 55 | ; Borland Pascal stuff |
| 56 | ("[:/]tags$" . t ) |
| 57 | ; Emacs TAGS file |
| 58 | ) |
| 59 | "*Alist for distinguishing text files from binary files. |
| 60 | Each element has the form (REGEXP . TYPE), where REGEXP is matched |
| 61 | against the file name, and TYPE is nil for text, t for binary.") |
| 62 | |
| 63 | (defun find-buffer-file-type (filename) |
| 64 | (let ((alist file-name-buffer-file-type-alist) |
| 65 | (found nil) |
| 66 | (code nil)) |
| 67 | (let ((case-fold-search t)) |
| 68 | (setq filename (file-name-sans-versions filename)) |
| 69 | (while (and (not found) alist) |
| 70 | (if (string-match (car (car alist)) filename) |
| 71 | (setq code (cdr (car alist)) |
| 72 | found t)) |
| 73 | (setq alist (cdr alist)))) |
| 74 | (if found |
| 75 | (cond((memq code '(nil t)) code) |
| 76 | ((and (symbolp code) (fboundp code)) |
| 77 | (funcall code filename))) |
| 78 | default-buffer-file-type))) |
| 79 | |
| 80 | (defun find-file-binary (filename) |
| 81 | "Visit file FILENAME and treat it as binary." |
| 82 | (interactive "FFind file binary: ") |
| 83 | (let ((file-name-buffer-file-type-alist '(("" . t)))) |
| 84 | (find-file filename))) |
| 85 | |
| 86 | (defun find-file-text (filename) |
| 87 | "Visit file FILENAME and treat it as a text file." |
| 88 | (interactive "FFind file text: ") |
| 89 | (let ((file-name-buffer-file-type-alist '(("" . nil)))) |
| 90 | (find-file filename))) |
| 91 | |
| 92 | (defun find-file-not-found-set-buffer-file-type () |
| 93 | (save-excursion |
| 94 | (set-buffer (current-buffer)) |
| 95 | (setq buffer-file-type (find-buffer-file-type (buffer-file-name)))) |
| 96 | nil) |
| 97 | |
| 98 | ;;; To set the default file type on new files. |
| 99 | (add-hook 'find-file-not-found-hooks 'find-file-not-found-set-buffer-file-type) |
| 100 | |
| 101 | ;;; We use the Emacs directory, not /usr/local |
| 102 | (setq Info-default-directory-list (list "c:/emacs/info")) |
| 103 | |
| 104 | (defvar msdos-shells '("command.com" "4dos.com" "ndos.com") |
| 105 | "*List of shells that use `/c' instead of `-c' and a backslashed command.") |
| 106 | |
| 107 | (defconst register-name-by-word-alist |
| 108 | '((ax . 0) (bx . 1) (cx . 2) (dx . 3) (si . 4) (di . 5) |
| 109 | (cflag . 6) (flags . 7))) |
| 110 | |
| 111 | (defconst register-name-by-byte-alist |
| 112 | '((al . (0 . 0)) (ah . (0 . 1)) |
| 113 | (bl . (1 . 0)) (bh . (1 . 1)) |
| 114 | (cl . (2 . 0)) (ch . (2 . 1)) |
| 115 | (dl . (3 . 0)) (dh . (3 . 1)))) |
| 116 | |
| 117 | (defun make-register () |
| 118 | (make-vector 8 0)) |
| 119 | |
| 120 | (defun register-value (regs name) |
| 121 | (let ((where (or (cdr (assoc name register-name-by-word-alist)) |
| 122 | (cdr (assoc name register-name-by-byte-alist))))) |
| 123 | (cond ((consp where) |
| 124 | (let ((tem (aref regs (car where)))) |
| 125 | (if (zerop (cdr where)) |
| 126 | (% tem 256) |
| 127 | (/ tem 256)))) |
| 128 | ((numberp where) |
| 129 | (aref regs where)) |
| 130 | (t nil)))) |
| 131 | |
| 132 | (defun set-register-value (regs name value) |
| 133 | (and (numberp value) |
| 134 | (> value 0) |
| 135 | (let ((where (or (cdr (assoc name register-name-by-word-alist)) |
| 136 | (cdr (assoc name register-name-by-byte-alist))))) |
| 137 | (cond ((consp where) |
| 138 | (setq value (% value 256)) ; 0x100 |
| 139 | (let* ((tem (aref regs (car where))) |
| 140 | (l (% tem 256)) |
| 141 | (h (/ tem 256))) |
| 142 | (if (zerop (cdr where)) |
| 143 | (aset regs (car where) (+ (* h 256) value)) |
| 144 | (aset regs (car where) (+ (* value 256) h))))) |
| 145 | ((numberp where) |
| 146 | (setq value (% value 65536)) ; 0x10000 |
| 147 | (aset regs where value))))) |
| 148 | regs) |
| 149 | |
| 150 | (defsubst intdos (regs) |
| 151 | (int86 33 regs)) |
| 152 | |
| 153 | ;;; Fix interface to (X-specific) mouse.el |
| 154 | (defalias 'window-frame 'ignore) |
| 155 | (defalias 'x-set-selection 'ignore) |
| 156 | (fset 'x-get-selection '(lambda (&rest rest) "")) |
| 157 | (fset 'frame-parameters 'ignore) |
| 158 | (fmakunbound 'font-menu-add-default) |
| 159 | (global-unset-key [C-down-mouse-1]) |
| 160 | (global-unset-key [C-down-mouse-2]) |
| 161 | (global-unset-key [C-down-mouse-3]) |