poe-18.el

   1 ;;; poe-18.el --- poe API implementation for Emacs 18.*
   2
   3 ;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
   4
   5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;; Keywords: emulation, compatibility
   7
   8 ;; This file is part of APEL (A Portable Emacs Library).
   9
  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.
  14
  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.
  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 (defvar-maybe data-directory exec-directory)
  28
  29
  30 ;;; @ for EMACS 18.55
  31 ;;;
  32
  33 (defvar-maybe buffer-undo-list nil)
  34
  35
  36 ;;; @ Lisp Language
  37 ;;;
  38
  39 ;;; @@ list
  40 ;;;
  41
  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))
  51       (cdr list)
  52     (let ((rest list)
  53           (rrest (cdr list))
  54           )
  55       (while (and rrest (not (equal elt (car rrest))))
  56         (setq rest rrest
  57               rrest (cdr rrest))
  58         )
  59       (rplacd rest (cdr rrest))
  60       list)))
  61
  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)))
  68   list)
  69
  70
  71 ;;; @@ environment variable
  72 ;;;
  73
  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'."
  79   t)
  80
  81
  82 ;;; @@ function
  83 ;;;
  84
  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]"
  89   (fset sym newdef)
  90   )
  91
  92
  93 ;;; @ Compilation Features
  94 ;;;
  95
  96 (defmacro-maybe eval-and-compile (&rest body)
  97   "Like `progn', but evaluates the body at compile time and at load time."
  98   ;; Remember, it's magic.
  99   (cons 'progn body))
 100
 101 (defun byte-code-function-p (exp)
 102   "T if OBJECT is a byte-compiled function object.
 103 \[poe-18.el; EMACS 19 emulating function]"
 104   (and (consp exp)
 105        (let* ((rest (cdr (cdr exp))) elt)
 106          (if (stringp (car rest))
 107              (setq rest (cdr rest))
 108            )
 109          (catch 'tag
 110            (while rest
 111              (setq elt (car rest))
 112              (if (and (consp elt)(eq (car elt) 'byte-code))
 113                  (throw 'tag t)
 114                )
 115              (setq rest (cdr rest))
 116              ))
 117          )))
 118
 119 (defun-maybe make-obsolete (fn new)
 120   "Make the byte-compiler warn that FUNCTION is obsolete.
 121 The warning will say that NEW should be used instead.
 122 If NEW is a string, that is the `use instead' message."
 123   (interactive "aMake function obsolete: \nxObsoletion replacement: ")
 124   (let ((handler (get fn 'byte-compile)))
 125     (if (eq 'byte-compile-obsolete handler)
 126         (setcar (get fn 'byte-obsolete-info) new)
 127       (put fn 'byte-obsolete-info (cons new handler))
 128       (put fn 'byte-compile 'byte-compile-obsolete)))
 129   fn)
 130
 131
 132 ;;; @ text property
 133 ;;;
 134
 135 (defun set-text-properties (start end properties &optional object))
 136
 137 (defun remove-text-properties (start end properties &optional object))
 138
 139
 140 ;;; @ file
 141 ;;;
 142
 143 (defun make-directory-internal (dirname)
 144   "Create a directory. One argument, a file name string.
 145 \[poe-18.el; EMACS 19 emulating function]"
 146  (let ((dir (expand-file-name dirname)))
 147    (if (file-exists-p dir)
 148       (error "Creating directory: %s is already exist" dir)
 149      (call-process "mkdir" nil nil nil dir))))
 150
 151 (defun make-directory (dir &optional parents)
 152   "Create the directory DIR and any nonexistent parent dirs.
 153 The second (optional) argument PARENTS says whether
 154 to create parent directories if they don't exist.
 155 \[poe-18.el; EMACS 19 emulating function]"
 156   (let ((len (length dir))
 157         (p 0) p1 path)
 158     (catch 'tag
 159       (while (and (< p len) (string-match "[^/]*/?" dir p))
 160         (setq p1 (match-end 0))
 161         (if (= p1 len)
 162             (throw 'tag nil)
 163           )
 164         (setq path (substring dir 0 p1))
 165         (if (not (file-directory-p path))
 166             (cond ((file-exists-p path)
 167                    (error "Creating directory: %s is not directory" path)
 168                    )
 169                   ((null parents)
 170                    (error "Creating directory: %s is not exist" path)
 171                    )
 172                   (t
 173                    (make-directory-internal path)
 174                    ))
 175           )
 176         (setq p p1)
 177         ))
 178     (make-directory-internal dir)
 179     ))
 180
 181 ;; Imported from files.el of EMACS 19.33.
 182 (defun parse-colon-path (cd-path)
 183   "Explode a colon-separated list of paths into a string list."
 184   (and cd-path
 185        (let (cd-prefix cd-list (cd-start 0) cd-colon)
 186          (setq cd-path (concat cd-path path-separator))
 187          (while (setq cd-colon (string-match path-separator cd-path cd-start))
 188            (setq cd-list
 189                  (nconc cd-list
 190                         (list (if (= cd-start cd-colon)
 191                                    nil
 192                                 (substitute-in-file-name
 193                                  (file-name-as-directory
 194                                   (substring cd-path cd-start cd-colon)))))))
 195            (setq cd-start (+ cd-colon 1)))
 196          cd-list)))
 197
 198 ;; Imported from files.el of EMACS 19.33.
 199 (defun file-relative-name (filename &optional directory)
 200   "Convert FILENAME to be relative to DIRECTORY (default: default-directory)."
 201   (setq filename (expand-file-name filename)
 202         directory (file-name-as-directory (expand-file-name
 203                                            (or directory default-directory))))
 204   (let ((ancestor ""))
 205     (while (not (string-match (concat "^" (regexp-quote directory)) filename))
 206       (setq directory (file-name-directory (substring directory 0 -1))
 207             ancestor (concat "../" ancestor)))
 208     (concat ancestor (substring filename (match-end 0)))))
 209
 210 (or (fboundp 'si:directory-files)
 211     (fset 'si:directory-files (symbol-function 'directory-files)))
 212 (defun directory-files (directory &optional full match nosort)
 213   "Return a list of names of files in DIRECTORY.
 214 There are three optional arguments:
 215 If FULL is non-nil, return absolute file names.  Otherwise return names
 216  that are relative to the specified directory.
 217 If MATCH is non-nil, mention only file names that match the regexp MATCH.
 218 If NOSORT is dummy for compatibility.
 219 \[poe-18.el; EMACS 19 emulating function]"
 220   (si:directory-files directory full match)
 221   )
 222
 223
 224 ;;; @ Display Features
 225 ;;;
 226
 227 ;;; Imported from Emacs 19.30.
 228 (defun force-mode-line-update (&optional all)
 229   "Force the mode-line of the current buffer to be redisplayed.
 230 With optional non-nil ALL, force redisplay of all mode-lines.
 231 \[poe-18.el; Emacs 19 emulating function]"
 232   (if all (save-excursion (set-buffer (other-buffer))))
 233   (set-buffer-modified-p (buffer-modified-p)))
 234
 235
 236 ;;; @ overlay
 237 ;;;
 238
 239 (cond ((boundp 'NEMACS)
 240        (defvar emu:available-face-attribute-alist
 241          '(
 242            ;;(bold      . inversed-region)
 243            (italic    . underlined-region)
 244            (underline . underlined-region)
 245            ))
 246
 247        ;; by YAMATE Keiichirou 1994/10/28
 248        (defun attribute-add-narrow-attribute (attr from to)
 249          (or (consp (symbol-value attr))
 250              (set attr (list 1)))
 251          (let* ((attr-value (symbol-value attr))
 252                 (len (car attr-value))
 253                 (posfrom 1)
 254                 posto)
 255            (while (and (< posfrom len)
 256                        (> from (nth posfrom attr-value)))
 257              (setq posfrom (1+ posfrom)))
 258            (setq posto posfrom)
 259            (while (and (< posto len)
 260                        (> to (nth posto attr-value)))
 261              (setq posto (1+ posto)))
 262            (if  (= posto posfrom)
 263                (if (= (% posto 2) 1)
 264                    (if (and (< to len)
 265                             (= to (nth posto attr-value)))
 266                        (set-marker (nth posto attr-value) from)
 267                      (setcdr (nthcdr (1- posfrom) attr-value)
 268                              (cons (set-marker-type (set-marker (make-marker)
 269                                                                 from)
 270                                                     'point-type)
 271                                    (cons (set-marker-type
 272                                           (set-marker (make-marker)
 273                                                       to)
 274                                           nil)
 275                                          (nthcdr posto attr-value))))
 276                      (setcar attr-value (+ len 2))))
 277              (if (= (% posfrom 2) 0)
 278                  (setq posfrom (1- posfrom))
 279                (set-marker (nth posfrom attr-value) from))
 280              (if (= (% posto 2) 0)
 281                  nil
 282                (setq posto (1- posto))
 283                (set-marker (nth posto attr-value) to))
 284              (setcdr (nthcdr posfrom attr-value)
 285                      (nthcdr posto attr-value)))))
 286
 287        (defalias 'make-overlay 'cons)
 288
 289        (defun overlay-put (overlay prop value)
 290          (let ((ret (and (eq prop 'face)
 291                          (assq value emu:available-face-attribute-alist)
 292                          )))
 293            (if ret
 294                (attribute-add-narrow-attribute (cdr ret)
 295                                                (car overlay)(cdr overlay))
 296              )))
 297        )
 298       (t
 299        (defun make-overlay (beg end &optional buffer type))
 300        (defun overlay-put (overlay prop value))
 301        ))
 302
 303 (defun overlay-buffer (overlay))
 304
 305
 306 ;;; @ buffer
 307 ;;;
 308
 309 (defun-maybe generate-new-buffer-name (name &optional ignore)
 310   "Return a string that is the name of no existing buffer based on NAME.
 311 If there is no live buffer named NAME, then return NAME.
 312 Otherwise modify name by appending `<NUMBER>', incrementing NUMBER
 313 until an unused name is found, and then return that name.
 314 Optional second argument IGNORE specifies a name that is okay to use
 315 \(if it is in the sequence to be tried)
 316 even if a buffer with that name exists."
 317   (if (get-buffer name)
 318       (let ((n 2) new)
 319         (while (get-buffer (setq new (format "%s<%d>" name n)))
 320           (setq n (1+ n)))
 321         new)
 322     name))
 323
 324 (or (fboundp 'si:mark)
 325     (fset 'si:mark (symbol-function 'mark)))
 326 (defun mark (&optional force)
 327   (si:mark)
 328   )
 329
 330
 331 ;;; @ end
 332 ;;;
 333
 334 (provide 'poe-18)
 335
 336 ;;; poe-18.el ends here