poe-18.el

   1 ;;; poe-18.el --- poe API implementation for Emacs 18.*
   2
   3 ;; Copyright (C) 1995,1996,1997,1998,1999 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-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)))
 101   (cons 'progn body))
 102
 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.
 106   (cons 'progn body))
 107
 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]"
 111   (and (consp exp)
 112        (let* ((rest (cdr (cdr exp))) elt)
 113          (if (stringp (car rest))
 114              (setq rest (cdr rest))
 115            )
 116          (catch 'tag
 117            (while rest
 118              (setq elt (car rest))
 119              (if (and (consp elt)(eq (car elt) 'byte-code))
 120                  (throw 'tag t)
 121                )
 122              (setq rest (cdr rest))
 123              ))
 124          )))
 125
 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)))
 136   fn)
 137
 138
 139 ;;; @ text property
 140 ;;;
 141
 142 (defun set-text-properties (start end properties &optional object))
 143
 144 (defun remove-text-properties (start end properties &optional object))
 145
 146
 147 ;;; @ file
 148 ;;;
 149
 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))))
 157
 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))
 164         (p 0) p1 path)
 165     (catch 'tag
 166       (while (and (< p len) (string-match "[^/]*/?" dir p))
 167         (setq p1 (match-end 0))
 168         (if (= p1 len)
 169             (throw 'tag nil)
 170           )
 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)
 175                    )
 176                   ((null parents)
 177                    (error "Creating directory: %s is not exist" path)
 178                    )
 179                   (t
 180                    (make-directory-internal path)
 181                    ))
 182           )
 183         (setq p p1)
 184         ))
 185     (make-directory-internal dir)
 186     ))
 187
 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."
 191   (and cd-path
 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))
 195            (setq cd-list
 196                  (nconc cd-list
 197                         (list (if (= cd-start cd-colon)
 198                                    nil
 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)))
 203          cd-list)))
 204
 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))))
 211   (let ((ancestor ""))
 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)))))
 216
 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)
 228   )
 229
 230
 231 ;;; @ Display Features
 232 ;;;
 233
 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)))
 241
 242
 243 ;;; @ overlay
 244 ;;;
 245
 246 (cond ((boundp 'NEMACS)
 247        (defvar emu:available-face-attribute-alist
 248          '(
 249            ;;(bold      . inversed-region)
 250            (italic    . underlined-region)
 251            (underline . underlined-region)
 252            ))
 253
 254        ;; by YAMATE Keiichirou 1994/10/28
 255        (defun attribute-add-narrow-attribute (attr from to)
 256          (or (consp (symbol-value attr))
 257              (set attr (list 1)))
 258          (let* ((attr-value (symbol-value attr))
 259                 (len (car attr-value))
 260                 (posfrom 1)
 261                 posto)
 262            (while (and (< posfrom len)
 263                        (> from (nth posfrom attr-value)))
 264              (setq posfrom (1+ posfrom)))
 265            (setq posto 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)
 271                    (if (and (< to len)
 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)
 276                                                                 from)
 277                                                     'point-type)
 278                                    (cons (set-marker-type
 279                                           (set-marker (make-marker)
 280                                                       to)
 281                                           nil)
 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)
 288                  nil
 289                (setq posto (1- posto))
 290                (set-marker (nth posto attr-value) to))
 291              (setcdr (nthcdr posfrom attr-value)
 292                      (nthcdr posto attr-value)))))
 293
 294        (defalias 'make-overlay 'cons)
 295
 296        (defun overlay-put (overlay prop value)
 297          (let ((ret (and (eq prop 'face)
 298                          (assq value emu:available-face-attribute-alist)
 299                          )))
 300            (if ret
 301                (attribute-add-narrow-attribute (cdr ret)
 302                                                (car overlay)(cdr overlay))
 303              )))
 304        )
 305       (t
 306        (defun make-overlay (beg end &optional buffer type))
 307        (defun overlay-put (overlay prop value))
 308        ))
 309
 310 (defun overlay-buffer (overlay))
 311
 312
 313 ;;; @ buffer
 314 ;;;
 315
 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)
 325       (let ((n 2) new)
 326         (while (get-buffer (setq new (format "%s<%d>" name n)))
 327           (setq n (1+ n)))
 328         new)
 329     name))
 330
 331 (or (fboundp 'si:mark)
 332     (fset 'si:mark (symbol-function 'mark)))
 333 (defun mark (&optional force)
 334   (si:mark)
 335   )
 336
 337
 338 ;;; @ end
 339 ;;;
 340
 341 (provide 'poe-18)
 342
 343 ;;; poe-18.el ends here