1 ;;; poe-18.el --- poe API implementation for Emacs 18.*
3 ;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
6 ;; Keywords: emulation, compatibility
8 ;; This file is part of APEL (A Portable Emacs Library).
10 ;; This program is free software; you can redistribute it and/or
11 ;; modify it under the terms of the GNU General Public License as
12 ;; published by the Free Software Foundation; either version 2, or (at
13 ;; your option) any later version.
15 ;; This program is distributed in the hope that it will be useful, but
16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 ;; General Public License for more details.
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.
27 (defvar-maybe data-directory exec-directory)
33 (defvar-maybe buffer-undo-list nil)
42 (defun delete (elt list)
43 "Delete by side effect any occurrences of ELT as a member of LIST.
44 The modified LIST is returned. Comparison is done with `equal'.
45 If the first member of LIST is ELT, deleting it is not a side effect;
46 it is simply using a different list.
47 Therefore, write `(setq foo (delete element foo))'
48 to be sure of changing the value of `foo'.
49 \[poe-18.el; EMACS 19 emulating function]"
50 (if (equal elt (car list))
55 (while (and rrest (not (equal elt (car rrest))))
59 (rplacd rest (cdr rrest))
62 (defun member (elt list)
63 "Return non-nil if ELT is an element of LIST. Comparison done with EQUAL.
64 The value is actually the tail of LIST whose car is ELT.
65 \[poe-18.el; EMACS 19 emulating function]"
66 (while (and list (not (equal elt (car list))))
67 (setq list (cdr list)))
71 ;;; @@ environment variable
74 (autoload 'setenv "env"
75 "Set the value of the environment variable named VARIABLE to VALUE.
76 VARIABLE should be a string. VALUE is optional; if not provided or is
77 `nil', the environment variable VARIABLE will be removed.
78 This function works by modifying `process-environment'."
85 (defun defalias (sym newdef)
86 "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.
87 Associates the function with the current load file, if any.
88 \[poe-18.el; EMACS 19 emulating function]"
93 ;;; @ Compilation Features
96 (defmacro-maybe eval-when-compile (&rest body)
97 "Like `progn', but evaluates the body at compile time.
98 The result of the body appears to the compiler as a quoted constant."
99 ;; Not necessary because we have it in b-c-initial-macro-environment
100 ;; (list 'quote (eval (cons 'progn body)))
103 (defmacro-maybe eval-and-compile (&rest body)
104 "Like `progn', but evaluates the body at compile time and at load time."
105 ;; Remember, it's magic.
108 (defun byte-code-function-p (exp)
109 "T if OBJECT is a byte-compiled function object.
110 \[poe-18.el; EMACS 19 emulating function]"
112 (let* ((rest (cdr (cdr exp))) elt)
113 (if (stringp (car rest))
114 (setq rest (cdr rest))
118 (setq elt (car rest))
119 (if (and (consp elt)(eq (car elt) 'byte-code))
122 (setq rest (cdr rest))
126 (defun-maybe make-obsolete (fn new)
127 "Make the byte-compiler warn that FUNCTION is obsolete.
128 The warning will say that NEW should be used instead.
129 If NEW is a string, that is the `use instead' message."
130 (interactive "aMake function obsolete: \nxObsoletion replacement: ")
131 (let ((handler (get fn 'byte-compile)))
132 (if (eq 'byte-compile-obsolete handler)
133 (setcar (get fn 'byte-obsolete-info) new)
134 (put fn 'byte-obsolete-info (cons new handler))
135 (put fn 'byte-compile 'byte-compile-obsolete)))
142 (defun set-text-properties (start end properties &optional object))
144 (defun remove-text-properties (start end properties &optional object))
150 (defun make-directory-internal (dirname)
151 "Create a directory. One argument, a file name string.
152 \[poe-18.el; EMACS 19 emulating function]"
153 (let ((dir (expand-file-name dirname)))
154 (if (file-exists-p dir)
155 (error "Creating directory: %s is already exist" dir)
156 (call-process "mkdir" nil nil nil dir))))
158 (defun make-directory (dir &optional parents)
159 "Create the directory DIR and any nonexistent parent dirs.
160 The second (optional) argument PARENTS says whether
161 to create parent directories if they don't exist.
162 \[poe-18.el; EMACS 19 emulating function]"
163 (let ((len (length dir))
166 (while (and (< p len) (string-match "[^/]*/?" dir p))
167 (setq p1 (match-end 0))
171 (setq path (substring dir 0 p1))
172 (if (not (file-directory-p path))
173 (cond ((file-exists-p path)
174 (error "Creating directory: %s is not directory" path)
177 (error "Creating directory: %s is not exist" path)
180 (make-directory-internal path)
185 (make-directory-internal dir)
188 ;; Imported from files.el of EMACS 19.33.
189 (defun parse-colon-path (cd-path)
190 "Explode a colon-separated list of paths into a string list."
192 (let (cd-prefix cd-list (cd-start 0) cd-colon)
193 (setq cd-path (concat cd-path path-separator))
194 (while (setq cd-colon (string-match path-separator cd-path cd-start))
197 (list (if (= cd-start cd-colon)
199 (substitute-in-file-name
200 (file-name-as-directory
201 (substring cd-path cd-start cd-colon)))))))
202 (setq cd-start (+ cd-colon 1)))
205 ;; Imported from files.el of EMACS 19.33.
206 (defun file-relative-name (filename &optional directory)
207 "Convert FILENAME to be relative to DIRECTORY (default: default-directory)."
208 (setq filename (expand-file-name filename)
209 directory (file-name-as-directory (expand-file-name
210 (or directory default-directory))))
212 (while (not (string-match (concat "^" (regexp-quote directory)) filename))
213 (setq directory (file-name-directory (substring directory 0 -1))
214 ancestor (concat "../" ancestor)))
215 (concat ancestor (substring filename (match-end 0)))))
217 (or (fboundp 'si:directory-files)
218 (fset 'si:directory-files (symbol-function 'directory-files)))
219 (defun directory-files (directory &optional full match nosort)
220 "Return a list of names of files in DIRECTORY.
221 There are three optional arguments:
222 If FULL is non-nil, return absolute file names. Otherwise return names
223 that are relative to the specified directory.
224 If MATCH is non-nil, mention only file names that match the regexp MATCH.
225 If NOSORT is dummy for compatibility.
226 \[poe-18.el; EMACS 19 emulating function]"
227 (si:directory-files directory full match)
231 ;;; @ Display Features
234 ;;; Imported from Emacs 19.30.
235 (defun force-mode-line-update (&optional all)
236 "Force the mode-line of the current buffer to be redisplayed.
237 With optional non-nil ALL, force redisplay of all mode-lines.
238 \[poe-18.el; Emacs 19 emulating function]"
239 (if all (save-excursion (set-buffer (other-buffer))))
240 (set-buffer-modified-p (buffer-modified-p)))
246 (cond ((boundp 'NEMACS)
247 (defvar emu:available-face-attribute-alist
249 ;;(bold . inversed-region)
250 (italic . underlined-region)
251 (underline . underlined-region)
254 ;; by YAMATE Keiichirou 1994/10/28
255 (defun attribute-add-narrow-attribute (attr from to)
256 (or (consp (symbol-value attr))
258 (let* ((attr-value (symbol-value attr))
259 (len (car attr-value))
262 (while (and (< posfrom len)
263 (> from (nth posfrom attr-value)))
264 (setq posfrom (1+ posfrom)))
266 (while (and (< posto len)
267 (> to (nth posto attr-value)))
268 (setq posto (1+ posto)))
269 (if (= posto posfrom)
270 (if (= (% posto 2) 1)
272 (= to (nth posto attr-value)))
273 (set-marker (nth posto attr-value) from)
274 (setcdr (nthcdr (1- posfrom) attr-value)
275 (cons (set-marker-type (set-marker (make-marker)
278 (cons (set-marker-type
279 (set-marker (make-marker)
282 (nthcdr posto attr-value))))
283 (setcar attr-value (+ len 2))))
284 (if (= (% posfrom 2) 0)
285 (setq posfrom (1- posfrom))
286 (set-marker (nth posfrom attr-value) from))
287 (if (= (% posto 2) 0)
289 (setq posto (1- posto))
290 (set-marker (nth posto attr-value) to))
291 (setcdr (nthcdr posfrom attr-value)
292 (nthcdr posto attr-value)))))
294 (defalias 'make-overlay 'cons)
296 (defun overlay-put (overlay prop value)
297 (let ((ret (and (eq prop 'face)
298 (assq value emu:available-face-attribute-alist)
301 (attribute-add-narrow-attribute (cdr ret)
302 (car overlay)(cdr overlay))
306 (defun make-overlay (beg end &optional buffer type))
307 (defun overlay-put (overlay prop value))
310 (defun overlay-buffer (overlay))
316 (defun-maybe generate-new-buffer-name (name &optional ignore)
317 "Return a string that is the name of no existing buffer based on NAME.
318 If there is no live buffer named NAME, then return NAME.
319 Otherwise modify name by appending `<NUMBER>', incrementing NUMBER
320 until an unused name is found, and then return that name.
321 Optional second argument IGNORE specifies a name that is okay to use
322 \(if it is in the sequence to be tried)
323 even if a buffer with that name exists."
324 (if (get-buffer name)
326 (while (get-buffer (setq new (format "%s<%d>" name n)))
331 (or (fboundp 'si:mark)
332 (fset 'si:mark (symbol-function 'mark)))
333 (defun mark (&optional force)
343 ;;; poe-18.el ends here