;;; poe-18.el --- poe API implementation for Emacs 18.*
-;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
+;; Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc.
+;; Copyright (C) 1999 Yuuichi Teranishi
-;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; Author: MORIOKA Tomohiko <tomo@m17n.org>
+;; Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
+;; Yuuichi Teranishi <teranisi@gohome.org>
;; Keywords: emulation, compatibility
;; This file is part of APEL (A Portable Emacs Library).
;; General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; along with this program; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;;; Commentary:
+
+;; Note to APEL developers and APEL programmers:
+;;
+;; If old (v18) compiler is used, top-level macros are expanded at
+;; *load-time*, not compile-time. Therefore,
+;;
+;; (1) Definitions with `*-maybe' won't be compiled.
+;;
+;; (2) you cannot use macros defined with `defmacro-maybe' within function
+;; definitions in the same file.
+;; (`defmacro-maybe' is evaluated at load-time, therefore byte-compiler
+;; treats such use of macros as (unknown) functions and compiles them
+;; into function calls, which will cause errors at run-time.)
+;;
+;; (3) `eval-when-compile' and `eval-and-compile' are evaluated at
+;; load-time if used at top-level.
;;; Code:
-(defvar-maybe data-directory exec-directory)
+(require 'pym)
-;;; @ for EMACS 18.55
+;;; @ Compilation.
;;;
+(defun defalias (sym newdef)
+ "Set SYMBOL's function definition to NEWVAL, and return NEWVAL."
+ (fset sym newdef))
+
+(defun byte-code-function-p (object)
+ "Return t if OBJECT is a byte-compiled function object."
+ (and (consp object) (consp (cdr object))
+ (let ((rest (cdr (cdr object)))
+ elt)
+ (if (stringp (car rest))
+ (setq rest (cdr rest)))
+ (catch 'tag
+ (while rest
+ (setq elt (car rest))
+ (if (and (consp elt)
+ (eq (car elt) 'byte-code))
+ (throw 'tag t))
+ (setq rest (cdr rest)))))))
+
+;; (symbol-plist 'cyclic-function-indirection)
+(put 'cyclic-function-indirection
+ 'error-conditions
+ '(cyclic-function-indirection error))
+(put 'cyclic-function-indirection
+ 'error-message
+ "Symbol's chain of function indirections contains a loop")
+
+;; The following function definition is a direct translation of its
+;; C definition in emacs-20.4/src/data.c.
+(defun indirect-function (object)
+ "Return the function at the end of OBJECT's function chain.
+If OBJECT is a symbol, follow all function indirections and return the final
+function binding.
+If OBJECT is not a symbol, just return it.
+Signal a void-function error if the final symbol is unbound.
+Signal a cyclic-function-indirection error if there is a loop in the
+function chain of symbols."
+ (let* ((hare object)
+ (tortoise hare))
+ (catch 'found
+ (while t
+ (or (symbolp hare) (throw 'found hare))
+ (or (fboundp hare) (signal 'void-function (cons object nil)))
+ (setq hare (symbol-function hare))
+ (or (symbolp hare) (throw 'found hare))
+ (or (fboundp hare) (signal 'void-function (cons object nil)))
+ (setq hare (symbol-function hare))
+
+ (setq tortoise (symbol-function tortoise))
+
+ (if (eq hare tortoise)
+ (signal 'cyclic-function-indirection (cons object nil)))))
+ hare))
+
+;;; Emulate all functions and macros of emacs-20.3/lisp/byte-run.el.
+;;; (note: jwz's original compiler and XEmacs compiler have some more
+;;; macros; they are "nuked" by rms in FSF version.)
+
+;; Use `*-maybe' here because new byte-compiler may be installed.
+(put 'inline 'lisp-indent-hook 0)
+(defmacro-maybe inline (&rest body)
+ "Eval BODY forms sequentially and return value of last one.
+
+This emulating macro does not support function inlining because old \(v18\)
+compiler does not support inlining feature."
+ (cons 'progn body))
-(defvar-maybe buffer-undo-list nil)
+(put 'defsubst 'lisp-indent-hook 'defun)
+(put 'defsubst 'edebug-form-spec 'defun)
+(defmacro-maybe defsubst (name arglist &rest body)
+ "Define an inline function. The syntax is just like that of `defun'.
+This emulating macro does not support function inlining because old \(v18\)
+compiler does not support inlining feature."
+ (cons 'defun (cons name (cons arglist body))))
-;;; @ Lisp Language
-;;;
+(defun-maybe make-obsolete (fn new)
+ "Make the byte-compiler warn that FUNCTION is obsolete.
+The warning will say that NEW should be used instead.
+If NEW is a string, that is the `use instead' message.
+
+This emulating function does nothing because old \(v18\) compiler does not
+support this feature."
+ (interactive "aMake function obsolete: \nxObsoletion replacement: ")
+ fn)
+
+(defun-maybe make-obsolete-variable (var new)
+ "Make the byte-compiler warn that VARIABLE is obsolete,
+and NEW should be used instead. If NEW is a string, then that is the
+`use instead' message.
+
+This emulating function does nothing because old \(v18\) compiler does not
+support this feature."
+ (interactive "vMake variable obsolete: \nxObsoletion replacement: ")
+ var)
+
+(put 'dont-compile 'lisp-indent-hook 0)
+(defmacro-maybe dont-compile (&rest body)
+ "Like `progn', but the body always runs interpreted \(not compiled\).
+If you think you need this, you're probably making a mistake somewhere."
+ (list 'eval (list 'quote (if (cdr body) (cons 'progn body) (car body)))))
-;;; @@ list
+(put 'eval-when-compile 'lisp-indent-hook 0)
+(defmacro-maybe eval-when-compile (&rest body)
+ "Like progn, but evaluates the body at compile-time.
+
+This emulating macro does not do compile-time evaluation at all because
+of the limitation of old \(v18\) compiler."
+ (cons 'progn body))
+
+(put 'eval-and-compile 'lisp-indent-hook 0)
+(defmacro-maybe eval-and-compile (&rest body)
+ "Like progn, but evaluates the body at compile-time as well as at load-time.
+
+This emulating macro does not do compile-time evaluation at all because
+of the limitation of old \(v18\) compiler."
+ (cons 'progn body))
+
+
+;;; @ C primitives emulation.
;;;
+(defun member (elt list)
+ "Return non-nil if ELT is an element of LIST. Comparison done with EQUAL.
+The value is actually the tail of LIST whose car is ELT."
+ (while (and list (not (equal elt (car list))))
+ (setq list (cdr list)))
+ list)
+
(defun delete (elt list)
"Delete by side effect any occurrences of ELT as a member of LIST.
The modified LIST is returned. Comparison is done with `equal'.
If the first member of LIST is ELT, deleting it is not a side effect;
it is simply using a different list.
Therefore, write `(setq foo (delete element foo))'
-to be sure of changing the value of `foo'.
-\[poe-18.el; EMACS 19 emulating function]"
- (if (equal elt (car list))
- (cdr list)
- (let ((rest list)
- (rrest (cdr list))
- )
- (while (and rrest (not (equal elt (car rrest))))
- (setq rest rrest
- rrest (cdr rrest))
- )
- (rplacd rest (cdr rrest))
- list)))
+to be sure of changing the value of `foo'."
+ (if list
+ (if (equal elt (car list))
+ (cdr list)
+ (let ((rest list)
+ (rrest (cdr list)))
+ (while (and rrest (not (equal elt (car rrest))))
+ (setq rest rrest
+ rrest (cdr rrest)))
+ (setcdr rest (cdr rrest))
+ list))))
+
+(defun default-boundp (symbol)
+ "Return t if SYMBOL has a non-void default value.
+This is the value that is seen in buffers that do not have their own values
+for this variable."
+ (condition-case error
+ (progn
+ (default-value symbol)
+ t)
+ (void-variable nil)))
+
+;;; @@ current-time.
+;;;
-(defun member (elt list)
- "Return non-nil if ELT is an element of LIST. Comparison done with EQUAL.
-The value is actually the tail of LIST whose car is ELT.
-\[poe-18.el; EMACS 19 emulating function]"
- (while (and list (not (equal elt (car list))))
- (setq list (cdr list)))
- list)
+(defvar current-time-world-timezones
+ '(("PST" . -800)("PDT" . -700)("MST" . -700)
+ ("MDT" . -600)("CST" . -600)("CDT" . -500)
+ ("EST" . -500)("EDT" . -400)("AST" . -400)
+ ("NST" . -330)("UT" . +000)("GMT" . +000)
+ ("BST" . +100)("MET" . +100)("EET" . +200)
+ ("JST" . +900)("GMT+1" . +100)("GMT+2" . +200)
+ ("GMT+3" . +300)("GMT+4" . +400)("GMT+5" . +500)
+ ("GMT+6" . +600)("GMT+7" . +700)("GMT+8" . +800)
+ ("GMT+9" . +900)("GMT+10" . +1000)("GMT+11" . +1100)
+ ("GMT+12" . +1200)("GMT+13" . +1300)("GMT-1" . -100)
+ ("GMT-2" . -200)("GMT-3" . -300)("GMT-4" . -400)
+ ("GMT-5" . -500)("GMT-6" . -600)("GMT-7" . -700)
+ ("GMT-8" . -800)("GMT-9" . -900)("GMT-10" . -1000)
+ ("GMT-11" . -1100) ("GMT-12" . -1200))
+ "Time differentials of timezone from GMT in +-HHMM form.
+Used in `current-time-zone' (Emacs 19 emulating function by APEL).")
+
+(defvar current-time-local-timezone nil
+ "*Local timezone name.
+Used in `current-time-zone' (Emacs 19 emulating function by APEL).")
+
+(defun set-time-zone-rule (tz)
+ "Set the local time zone using TZ, a string specifying a time zone rule.
+If TZ is nil, use implementation-defined default time zone information.
+If TZ is t, use Universal Time."
+ (cond
+ ((stringp tz)
+ (setq current-time-local-timezone tz))
+ (tz
+ (setq current-time-local-timezone "GMT"))
+ (t
+ (setq current-time-local-timezone
+ (with-temp-buffer
+ ;; We use `date' command to get timezone information.
+ (call-process "date" nil (current-buffer) t)
+ (goto-char (point-min))
+ (if (looking-at
+ "^.*\\([A-Z][A-Z][A-Z]\\([^ \n\t]*\\)\\).*$")
+ (buffer-substring (match-beginning 1)
+ (match-end 1))))))))
+
+(defun current-time-zone (&optional specified-time)
+ "Return the offset and name for the local time zone.
+This returns a list of the form (OFFSET NAME).
+OFFSET is an integer number of seconds ahead of UTC (east of Greenwich).
+ A negative value means west of Greenwich.
+NAME is a string giving the name of the time zone.
+Optional argument SPECIFIED-TIME is ignored in this implementation.
+Some operating systems cannot provide all this information to Emacs;
+in this case, `current-time-zone' returns a list containing nil for
+the data it can't find."
+ (let ((local-timezone (or current-time-local-timezone
+ (progn
+ (set-time-zone-rule nil)
+ current-time-local-timezone)))
+ timezone abszone seconds)
+ (setq timezone
+ (or (cdr (assoc (upcase local-timezone)
+ current-time-world-timezones))
+ ;; "+900" style or nil.
+ local-timezone))
+ (when timezone
+ (if (stringp timezone)
+ (setq timezone (string-to-int timezone)))
+ ;; Taking account of minute in timezone.
+ ;; HHMM -> MM
+ (setq abszone (abs timezone))
+ (setq seconds (* 60 (+ (* 60 (/ abszone 100)) (% abszone 100))))
+ (list (if (< timezone 0) (- seconds) seconds)
+ local-timezone))))
+
+(or (fboundp 'si:current-time-string)
+ (fset 'si:current-time-string (symbol-function 'current-time-string)))
+(defun current-time-string (&optional specified-time)
+ "Return the current time, as a human-readable string.
+Programs can use this function to decode a time,
+since the number of columns in each field is fixed.
+The format is `Sun Sep 16 01:03:52 1973'.
+If an argument SPECIFIED-TIME is given, it specifies a time to format
+instead of the current time. The argument should have the form:
+ (HIGH . LOW)
+or the form:
+ (HIGH LOW . IGNORED).
+Thus, you can use times obtained from `current-time'
+and from `file-attributes'."
+ (if (null specified-time)
+ (si:current-time-string)
+ (or (consp specified-time)
+ (error "Wrong type argument %s" specified-time))
+ (let ((high (car specified-time))
+ (low (cdr specified-time))
+ (offset (or (car (current-time-zone)) 0))
+ (mdays '(31 28 31 30 31 30 31 31 30 31 30 31))
+ (mnames '("Jan" "Feb" "Mar" "Apr" "May" "Jun"
+ "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
+ (wnames '("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat"))
+ days dd yyyy lyear mm HH MM SS)
+ (if (consp low)
+ (setq low (car low)))
+ (or (integerp high)
+ (error "Wrong type argument %s" high))
+ (or (integerp low)
+ (error "Wrong type argument %s" low))
+ (setq low (+ low offset))
+ (while (> low 65535)
+ (setq high (1+ high)
+ low (- low 65536)))
+ (setq yyyy 1970)
+ (while (or (> high 481)
+ (and (= high 481)
+ (>= low 13184)))
+ (if (and (> high 0)
+ (< low 13184))
+ (setq high (1- high)
+ low (+ 65536 low)))
+ (setq high (- high 481)
+ low (- low 13184))
+ (if (and (zerop (% yyyy 4))
+ (or (not (zerop (% yyyy 100)))
+ (zerop (% yyyy 400))))
+ (progn
+ (if (and (> high 0)
+ (< low 20864))
+ (setq high (1- high)
+ low (+ 65536 low)))
+ (setq high (- high 1)
+ low (- low 20864))))
+ (setq yyyy (1+ yyyy)))
+ (setq dd 1)
+ (while (or (> high 1)
+ (and (= high 1)
+ (>= low 20864)))
+ (if (and (> high 0)
+ (< low 20864))
+ (setq high (1- high)
+ low (+ 65536 low)))
+ (setq high (- high 1)
+ low (- low 20864)
+ dd (1+ dd)))
+ (setq days dd)
+ (if (= high 1)
+ (setq low (+ 65536 low)))
+ (setq mm 0)
+ (setq lyear (and (zerop (% yyyy 4))
+ (or (not (zerop (% yyyy 100)))
+ (zerop (% yyyy 400)))))
+ (while (> (- dd (if (and lyear (= mm 1)) 29 (nth mm mdays))) 0)
+ (setq dd (- dd (if (and lyear (= mm 1)) 29 (nth mm mdays))))
+ (setq mm (1+ mm)))
+ (setq HH (/ low 3600)
+ low (% low 3600)
+ MM (/ low 60)
+ SS (% low 60))
+ (format "%s %s %2d %02d:%02d:%02d %4d"
+ (nth (% (+ days
+ (- (+ (* (1- yyyy) 365) (/ (1- yyyy) 400)
+ (/ (1- yyyy) 4)) (/ (1- yyyy) 100))) 7)
+ wnames)
+ (nth mm mnames)
+ dd HH MM SS yyyy))))
+
+(defun current-time ()
+ "Return the current time, as the number of seconds since 1970-01-01 00:00:00.
+The time is returned as a list of three integers. The first has the
+most significant 16 bits of the seconds, while the second has the
+least significant 16 bits. The third integer gives the microsecond
+count.
+
+The microsecond count is zero on systems that do not provide
+resolution finer than a second."
+ (let* ((str (current-time-string))
+ (yyyy (string-to-int (substring str 20 24)))
+ (mm (length (member (substring str 4 7)
+ '("Dec" "Nov" "Oct" "Sep" "Aug" "Jul"
+ "Jun" "May" "Apr" "Mar" "Feb" "Jan"))))
+ (dd (string-to-int (substring str 8 10)))
+ (HH (string-to-int (substring str 11 13)))
+ (MM (string-to-int (substring str 14 16)))
+ (SS (string-to-int (substring str 17 19)))
+ (offset (or (car (current-time-zone)) 0))
+ dn ct1 ct2 i1 i2
+ year uru)
+ (setq ct1 0 ct2 0 i1 0 i2 0)
+ (setq year (- yyyy 1970))
+ (while (> year 0)
+ (setq year (1- year)
+ ct1 (+ ct1 481)
+ ct2 (+ ct2 13184))
+ (while (> ct2 65535)
+ (setq ct1 (1+ ct1)
+ ct2 (- ct2 65536))))
+ (setq year (- yyyy 1))
+ (setq uru (- (+ (- (/ year 4) (/ year 100))
+ (/ year 400)) 477))
+ (while (> uru 0)
+ (setq uru (1- uru)
+ i1 (1+ i1)
+ i2 (+ i2 20864))
+ (if (> i2 65535)
+ (setq i1 (1+ i1)
+ i2 (- i2 65536))))
+ (setq ct1 (+ ct1 i1)
+ ct2 (+ ct2 i2))
+ (while (> ct2 65535)
+ (setq ct1 (1+ ct1)
+ ct2 (- ct2 65536)))
+ (setq dn (+ dd (* 31 (1- mm))))
+ (if (> mm 2)
+ (setq dn (+ (- dn (/ (+ 23 (* 4 mm)) 10))
+ (if (and (zerop (% yyyy 4))
+ (or (not (zerop (% yyyy 100)))
+ (zerop (% yyyy 400))))
+ 1 0))))
+ (setq dn (1- dn)
+ i1 0
+ i2 0)
+ (while (> dn 0)
+ (setq dn (1- dn)
+ i1 (1+ i1)
+ i2 (+ i2 20864))
+ (if (> i2 65535)
+ (setq i1 (1+ i1)
+ i2 (- i2 65536))))
+ (setq ct1 (+ (+ (+ ct1 i1) (/ ct2 65536))
+ (/ (+ (* HH 3600) (* MM 60) SS)
+ 65536))
+ ct2 (+ (+ i2 (% ct2 65536))
+ (% (+ (* HH 3600) (* MM 60) SS)
+ 65536)))
+ (while (< (- ct2 offset) 0)
+ (setq ct1 (1- ct1)
+ ct2 (+ ct2 65536)))
+ (setq ct2 (- ct2 offset))
+ (while (> ct2 65535)
+ (setq ct1 (1+ ct1)
+ ct2 (- ct2 65536)))
+ (list ct1 ct2 0)))
+
+;;; @@ Floating point numbers.
+;;;
+(defun abs (arg)
+ "Return the absolute value of ARG."
+ (if (< arg 0) (- arg) arg))
-;;; @@ environment variable
+;;; @ Basic lisp subroutines.
;;;
-(autoload 'setenv "env"
- "Set the value of the environment variable named VARIABLE to VALUE.
-VARIABLE should be a string. VALUE is optional; if not provided or is
-`nil', the environment variable VARIABLE will be removed.
-This function works by modifying `process-environment'."
- t)
+(defmacro lambda (&rest cdr)
+ "Return a lambda expression.
+A call of the form (lambda ARGS DOCSTRING INTERACTIVE BODY) is
+self-quoting; the result of evaluating the lambda expression is the
+expression itself. The lambda expression may then be treated as a
+function, i.e., stored as the function value of a symbol, passed to
+funcall or mapcar, etc.
+
+ARGS should take the same form as an argument list for a `defun'.
+DOCSTRING is an optional documentation string.
+ If present, it should describe how to call the function.
+ But documentation strings are usually not useful in nameless functions.
+INTERACTIVE should be a call to the function `interactive', which see.
+It may also be omitted.
+BODY should be a list of lisp expressions."
+ ;; Note that this definition should not use backquotes; subr.el should not
+ ;; depend on backquote.el.
+ (list 'function (cons 'lambda cdr)))
+(defun force-mode-line-update (&optional all)
+ "Force the mode-line of the current buffer to be redisplayed.
+With optional non-nil ALL, force redisplay of all mode-lines."
+ (if all (save-excursion (set-buffer (other-buffer))))
+ (set-buffer-modified-p (buffer-modified-p)))
-;;; @@ function
-;;;
+(defalias 'set-match-data 'store-match-data)
-(defun defalias (sym newdef)
- "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.
-Associates the function with the current load file, if any.
-\[poe-18.el; EMACS 19 emulating function]"
- (fset sym newdef)
- )
+(defvar save-match-data-internal)
+
+;; We use save-match-data-internal as the local variable because
+;; that works ok in practice (people should not use that variable elsewhere).
+(defmacro save-match-data (&rest body)
+ "Execute the BODY forms, restoring the global value of the match data."
+ (` (let ((save-match-data-internal (match-data)))
+ (unwind-protect (progn (,@ body))
+ (set-match-data save-match-data-internal)))))
-;;; @ Compilation Features
+;;; @ Basic editing commands.
;;;
-(defmacro-maybe eval-and-compile (&rest body)
- "Like `progn', but evaluates the body at compile time and at load time."
- ;; Remember, it's magic.
- (cons 'progn body))
+;; 18.55 does not have these variables.
+(defvar-maybe buffer-undo-list nil
+ "List of undo entries in current buffer.
+APEL provides this as dummy for a compatibility.")
-(defun byte-code-function-p (exp)
- "T if OBJECT is a byte-compiled function object.
-\[poe-18.el; EMACS 19 emulating function]"
- (and (consp exp)
- (let* ((rest (cdr (cdr exp))) elt)
- (if (stringp (car rest))
- (setq rest (cdr rest))
- )
- (catch 'tag
- (while rest
- (setq elt (car rest))
- (if (and (consp elt)(eq (car elt) 'byte-code))
- (throw 'tag t)
- )
- (setq rest (cdr rest))
- ))
- )))
+(defvar-maybe auto-fill-function nil
+ "Function called (if non-nil) to perform auto-fill.
+APEL provides this as dummy for a compatibility.")
-(defun-maybe make-obsolete (fn new)
- "Make the byte-compiler warn that FUNCTION is obsolete.
-The warning will say that NEW should be used instead.
-If NEW is a string, that is the `use instead' message."
- (interactive "aMake function obsolete: \nxObsoletion replacement: ")
- (let ((handler (get fn 'byte-compile)))
- (if (eq 'byte-compile-obsolete handler)
- (setcar (get fn 'byte-obsolete-info) new)
- (put fn 'byte-obsolete-info (cons new handler))
- (put fn 'byte-compile 'byte-compile-obsolete)))
- fn)
+(defvar-maybe unread-command-event nil
+ "APEL provides this as dummy for a compatibility.")
+(defvar-maybe unread-command-events nil
+ "List of events to be read as the command input.
+APEL provides this as dummy for a compatibility.")
+;; (defvar-maybe minibuffer-setup-hook nil
+;; "Normal hook run just after entry to minibuffer.")
+;; (defvar-maybe minibuffer-exit-hook nil
+;; "Normal hook run just after exit from minibuffer.")
-;;; @ text property
-;;;
+(defvar-maybe minor-mode-map-alist nil
+ "Alist of keymaps to use for minor modes.
+APEL provides this as dummy for a compatibility.")
-(defun set-text-properties (start end properties &optional object))
+(defalias 'insert-and-inherit 'insert)
+(defalias 'insert-before-markers-and-inherit 'insert-before-markers)
+(defalias 'number-to-string 'int-to-string)
-(defun remove-text-properties (start end properties &optional object))
+(defun generate-new-buffer-name (name &optional ignore)
+ "Return a string that is the name of no existing buffer based on NAME.
+If there is no live buffer named NAME, then return NAME.
+Otherwise modify name by appending `<NUMBER>', incrementing NUMBER
+until an unused name is found, and then return that name.
+Optional second argument IGNORE specifies a name that is okay to use
+\(if it is in the sequence to be tried\)
+even if a buffer with that name exists."
+ (if (get-buffer name)
+ (let ((n 2) new)
+ (while (get-buffer (setq new (format "%s<%d>" name n)))
+ (setq n (1+ n)))
+ new)
+ name))
+(or (fboundp 'si:mark)
+ (fset 'si:mark (symbol-function 'mark)))
+(defun mark (&optional force)
+ (si:mark))
+
+(defun-maybe window-minibuffer-p (&optional window)
+"Return non-nil if WINDOW is a minibuffer window."
+ (eq (or window (selected-window)) (minibuffer-window)))
+
+(defun-maybe window-live-p (obj)
+ "Returns t if OBJECT is a window which is currently visible."
+ (and (windowp obj)
+ (or (eq obj (minibuffer-window))
+ (eq obj (get-buffer-window (window-buffer obj))))))
+
+;; Add optinal argument `hist'
+(or (fboundp 'si:read-from-minibuffer)
+ (progn
+ (fset 'si:read-from-minibuffer (symbol-function 'read-from-minibuffer))
+ (defun read-from-minibuffer (prompt &optional
+ initial-contents keymap read hist)
+
+ "Read a string from the minibuffer, prompting with string PROMPT.
+If optional second arg INITIAL-CONTENTS is non-nil, it is a string
+ to be inserted into the minibuffer before reading input.
+ If INITIAL-CONTENTS is (STRING . POSITION), the initial input
+ is STRING, but point is placed at position POSITION in the minibuffer.
+Third arg KEYMAP is a keymap to use whilst reading;
+ if omitted or nil, the default is `minibuffer-local-map'.
+If fourth arg READ is non-nil, then interpret the result as a lisp object
+ and return that object:
+ in other words, do `(car (read-from-string INPUT-STRING))'
+Fifth arg HIST is ignored in this implementation."
+ (si:read-from-minibuffer prompt initial-contents keymap read))))
+
+;; Add optional argument `frame'.
+(or (fboundp 'si:get-buffer-window)
+ (progn
+ (fset 'si:get-buffer-window (symbol-function 'get-buffer-window))
+ (defun get-buffer-window (buffer &optional frame)
+ "Return a window currently displaying BUFFER, or nil if none.
+Optional argument FRAME is ignored in this implementation."
+ (si:get-buffer-window buffer))))
+
+(defun-maybe walk-windows (proc &optional minibuf all-frames)
+ "Cycle through all visible windows, calling PROC for each one.
+PROC is called with a window as argument.
+
+Optional second arg MINIBUF t means count the minibuffer window even
+if not active. MINIBUF nil or omitted means count the minibuffer iff
+it is active. MINIBUF neither t nor nil means not to count the
+minibuffer even if it is active.
+Optional third argument ALL-FRAMES is ignored in this implementation."
+ (if (window-minibuffer-p (selected-window))
+ (setq minibuf t))
+ (let* ((walk-windows-start (selected-window))
+ (walk-windows-current walk-windows-start))
+ (unwind-protect
+ (while (progn
+ (setq walk-windows-current
+ (next-window walk-windows-current minibuf))
+ (funcall proc walk-windows-current)
+ (not (eq walk-windows-current walk-windows-start))))
+ (select-window walk-windows-start))))
+
+(defun buffer-disable-undo (&optional buffer)
+ "Make BUFFER stop keeping undo information.
+No argument or nil as argument means do this for the current buffer."
+ (buffer-flush-undo (or buffer (current-buffer))))
+
+
+;;; @@ Frame (Emacs 18 cannot make frame)
+;;;
+;; The following four are frequently used for manipulating the current frame.
+;; frame.el has `screen-width', `screen-height', `set-screen-width' and
+;; `set-screen-height' for backward compatibility and declare them as obsolete.
+(defun frame-width (&optional frame)
+ "Return number of columns available for display on FRAME.
+If FRAME is omitted, describe the currently selected frame."
+ (screen-width))
+
+(defun frame-height (&optional frame)
+ "Return number of lines available for display on FRAME.
+If FRAME is omitted, describe the currently selected frame."
+ (screen-height))
+
+(defun set-frame-width (frame cols &optional pretend)
+ "Specify that the frame FRAME has COLS columns.
+Optional third arg non-nil means that redisplay should use COLS columns
+but that the idea of the actual width of the frame should not be changed."
+ (set-screen-width cols pretend))
+
+(defun set-frame-height (frame lines &optional pretend)
+ "Specify that the frame FRAME has LINES lines.
+Optional third arg non-nil means that redisplay should use LINES lines
+but that the idea of the actual height of the frame should not be changed."
+ (set-screen-height lines pretend))
+
+;;; @@ Environment variables.
+;;;
+
+(autoload 'setenv "env"
+ "Set the value of the environment variable named VARIABLE to VALUE.
+VARIABLE should be a string. VALUE is optional; if not provided or is
+`nil', the environment variable VARIABLE will be removed.
+This function works by modifying `process-environment'."
+ t)
-;;; @ file
+
+;;; @ File input and output commands.
;;;
+(defvar data-directory exec-directory)
+
+;; In 18.55, `call-process' does not return exit status.
+(defun file-executable-p (filename)
+ "Return t if FILENAME can be executed by you.
+For a directory, this means you can access files in that directory."
+ (if (file-exists-p filename)
+ (let ((process (start-process "test" nil "test" "-x" filename)))
+ (while (eq 'run (process-status process)))
+ (zerop (process-exit-status process)))))
+
(defun make-directory-internal (dirname)
- "Create a directory. One argument, a file name string.
-\[poe-18.el; EMACS 19 emulating function]"
- (if (file-exists-p dirname)
- (error "Creating directory: %s is already exist" dirname)
- (if (not (= (call-process "mkdir" nil nil nil dirname) 0))
- (error "Creating directory: no such file or directory, %s" dirname)
- )))
+ "Create a directory. One argument, a file name string."
+ (let ((dir (expand-file-name dirname)))
+ (if (file-exists-p dir)
+ (signal 'file-already-exists
+ (list "Creating directory: %s already exists" dir))
+ (let ((exit-status (call-process "mkdir" nil nil nil dir)))
+ (if (or (and (numberp exit-status)
+ (not (zerop exit-status)))
+ (stringp exit-status))
+ (error "Create directory %s failed.")
+ ;; `make-directory' of v19 and later returns nil for success.
+ )))))
(defun make-directory (dir &optional parents)
"Create the directory DIR and any nonexistent parent dirs.
The second (optional) argument PARENTS says whether
-to create parent directories if they don't exist.
-\[poe-18.el; EMACS 19 emulating function]"
+to create parent directories if they don't exist."
(let ((len (length dir))
(p 0) p1 path)
(catch 'tag
(while (and (< p len) (string-match "[^/]*/?" dir p))
(setq p1 (match-end 0))
(if (= p1 len)
- (throw 'tag nil)
- )
+ (throw 'tag nil))
(setq path (substring dir 0 p1))
(if (not (file-directory-p path))
(cond ((file-exists-p path)
- (error "Creating directory: %s is not directory" path)
- )
+ (error "Creating directory: %s is not directory" path))
((null parents)
- (error "Creating directory: %s is not exist" path)
- )
+ (error "Creating directory: %s is not exist" path))
(t
- (make-directory-internal path)
- ))
- )
- (setq p p1)
- ))
- (make-directory-internal dir)
- ))
-
-;; Imported from files.el of EMACS 19.33.
+ (make-directory-internal path))))
+ (setq p p1)))
+ (make-directory-internal dir)))
+
+(defun delete-directory (directory)
+ "Delete the directory named DIRECTORY. Does not follow symlinks."
+ (let ((exit-status (call-process "rmdir" nil nil nil directory)))
+ (when (or (and (numberp exit-status) (not (zerop exit-status)))
+ (stringp exit-status))
+ (error "Delete directory %s failed."))))
+
(defun parse-colon-path (cd-path)
"Explode a colon-separated list of paths into a string list."
(and cd-path
(setq cd-list
(nconc cd-list
(list (if (= cd-start cd-colon)
- nil
+ nil
(substitute-in-file-name
(file-name-as-directory
(substring cd-path cd-start cd-colon)))))))
(setq cd-start (+ cd-colon 1)))
cd-list)))
-;; Imported from files.el of EMACS 19.33.
(defun file-relative-name (filename &optional directory)
"Convert FILENAME to be relative to DIRECTORY (default: default-directory)."
(setq filename (expand-file-name filename)
If FULL is non-nil, return absolute file names. Otherwise return names
that are relative to the specified directory.
If MATCH is non-nil, mention only file names that match the regexp MATCH.
-If NOSORT is dummy for compatibility.
-\[poe-18.el; EMACS 19 emulating function]"
- (si:directory-files directory full match)
- )
-
-
-;;; @ Display Features
+If NOSORT is dummy for compatibility."
+ (si:directory-files directory full match))
+
+(or (fboundp 'si:write-region)
+ (fset 'si:write-region (symbol-function 'write-region)))
+(defun write-region (start end filename &optional append visit)
+ "Write current region into specified file.
+When called from a program, requires three arguments:
+START, END and FILENAME. START and END are normally buffer positions
+specifying the part of the buffer to write.
+If START is nil, that means to use the entire buffer contents.
+If START is a string, then output that string to the file
+instead of any buffer contents; END is ignored.
+
+Optional fourth argument APPEND if non-nil means
+ append to existing file contents (if any). If it is an integer,
+ seek to that offset in the file before writing.
+Optional fifth argument VISIT if t means
+ set the last-save-file-modtime of buffer to this file's modtime
+ and mark buffer not modified.
+If VISIT is a string, it is a second file name;
+ the output goes to FILENAME, but the buffer is marked as visiting VISIT.
+ VISIT is also the file name to lock and unlock for clash detection.
+If VISIT is neither t nor nil nor a string,
+ that means do not display the \"Wrote file\" message."
+ (cond
+ ((null start)
+ (si:write-region (point-min) (point-max) filename append visit))
+ ((stringp start)
+ (with-temp-buffer
+ (insert start)
+ (si:write-region (point-min) (point-max) filename append visit)))
+ (t
+ (si:write-region start end filename append visit))))
+
+;;; @ Process.
+;;;
+(or (fboundp 'si:accept-process-output)
+ (progn
+ (fset 'si:accept-process-output (symbol-function 'accept-process-output))
+ (defun accept-process-output (&optional process timeout timeout-msecs)
+ "Allow any pending output from subprocesses to be read by Emacs.
+It is read into the process' buffers or given to their filter functions.
+Non-nil arg PROCESS means do not return until some output has been received
+ from PROCESS. Nil arg PROCESS means do not return until some output has
+ been received from any process.
+TIMEOUT and TIMEOUT-MSECS are ignored in this implementation."
+ (si:accept-process-output process))))
+
+;;; @ Text property.
;;;
-;;; Imported from Emacs 19.30.
-(defun force-mode-line-update (&optional all)
- "Force the mode-line of the current buffer to be redisplayed.
-With optional non-nil ALL, force redisplay of all mode-lines.
-\[poe-18.el; Emacs 19 emulating function]"
- (if all (save-excursion (set-buffer (other-buffer))))
- (set-buffer-modified-p (buffer-modified-p)))
+;; In Emacs 20.4, these functions are defined in src/textprop.c.
+(defun text-properties-at (position &optional object))
+(defun get-text-property (position prop &optional object))
+(defun get-char-property (position prop &optional object))
+(defun next-property-change (position &optional object limit))
+(defun next-single-property-change (position prop &optional object limit))
+(defun previous-property-change (position &optional object limit))
+(defun previous-single-property-change (position prop &optional object limit))
+(defun add-text-properties (start end properties &optional object))
+(defun put-text-property (start end property value &optional object))
+(defun set-text-properties (start end properties &optional object))
+(defun remove-text-properties (start end properties &optional object))
+(defun text-property-any (start end property value &optional object))
+(defun text-property-not-all (start end property value &optional object))
+;; the following two functions are new in v20.
+(defun next-char-property-change (position &optional object))
+(defun previous-char-property-change (position &optional object))
+;; the following two functions are obsolete.
+;; (defun erase-text-properties (start end &optional object)
+;; (defun copy-text-properties (start end src pos dest &optional prop)
-;;; @ overlay
+;;; @ Overlay.
;;;
-(cond ((boundp 'NEMACS)
- (defvar emu:available-face-attribute-alist
- '(
- ;;(bold . inversed-region)
- (italic . underlined-region)
- (underline . underlined-region)
- ))
-
- ;; by YAMATE Keiichirou 1994/10/28
- (defun attribute-add-narrow-attribute (attr from to)
- (or (consp (symbol-value attr))
- (set attr (list 1)))
- (let* ((attr-value (symbol-value attr))
- (len (car attr-value))
- (posfrom 1)
- posto)
- (while (and (< posfrom len)
- (> from (nth posfrom attr-value)))
- (setq posfrom (1+ posfrom)))
- (setq posto posfrom)
- (while (and (< posto len)
- (> to (nth posto attr-value)))
- (setq posto (1+ posto)))
- (if (= posto posfrom)
- (if (= (% posto 2) 1)
- (if (and (< to len)
- (= to (nth posto attr-value)))
- (set-marker (nth posto attr-value) from)
- (setcdr (nthcdr (1- posfrom) attr-value)
- (cons (set-marker-type (set-marker (make-marker)
- from)
- 'point-type)
- (cons (set-marker-type
- (set-marker (make-marker)
- to)
- nil)
- (nthcdr posto attr-value))))
- (setcar attr-value (+ len 2))))
- (if (= (% posfrom 2) 0)
- (setq posfrom (1- posfrom))
- (set-marker (nth posfrom attr-value) from))
- (if (= (% posto 2) 0)
- nil
- (setq posto (1- posto))
- (set-marker (nth posto attr-value) to))
- (setcdr (nthcdr posfrom attr-value)
- (nthcdr posto attr-value)))))
-
- (defalias 'make-overlay 'cons)
-
- (defun overlay-put (overlay prop value)
- (let ((ret (and (eq prop 'face)
- (assq value emu:available-face-attribute-alist)
- )))
- (if ret
- (attribute-add-narrow-attribute (cdr ret)
- (car overlay)(cdr overlay))
- )))
- )
- (t
- (defun make-overlay (beg end &optional buffer type))
- (defun overlay-put (overlay prop value))
- ))
-
+(defun overlayp (object))
+(defun make-overlay (beg end &optional buffer front-advance rear-advance))
+(defun move-overlay (overlay beg end &optional buffer))
+(defun delete-overlay (overlay))
+(defun overlay-start (overlay))
+(defun overlay-end (overlay))
(defun overlay-buffer (overlay))
-
-
-;;; @ buffer
-;;;
-
-(defun-maybe generate-new-buffer-name (name &optional ignore)
- "Return a string that is the name of no existing buffer based on NAME.
-If there is no live buffer named NAME, then return NAME.
-Otherwise modify name by appending `<NUMBER>', incrementing NUMBER
-until an unused name is found, and then return that name.
-Optional second argument IGNORE specifies a name that is okay to use
-\(if it is in the sequence to be tried)
-even if a buffer with that name exists."
- (if (get-buffer name)
- (let ((n 2) new)
- (while (get-buffer (setq new (format "%s<%d>" name n)))
- (setq n (1+ n)))
- new)
- name))
-
-(or (fboundp 'si:mark)
- (fset 'si:mark (symbol-function 'mark)))
-(defun mark (&optional force)
- (si:mark)
- )
-
-
-;;; @ hook
-;;;
-
-;; These function are imported from EMACS 19.28.
-(defun add-hook (hook function &optional append)
- "Add to the value of HOOK the function FUNCTION.
-FUNCTION is not added if already present.
-FUNCTION is added (if necessary) at the beginning of the hook list
-unless the optional argument APPEND is non-nil, in which case
-FUNCTION is added at the end.
-
-HOOK should be a symbol, and FUNCTION may be any valid function. If
-HOOK is void, it is first set to nil. If HOOK's value is a single
-function, it is changed to a list of functions.
-\[poe-18.el; EMACS 19 emulating function]"
- (or (boundp hook)
- (set hook nil)
- )
- ;; If the hook value is a single function, turn it into a list.
- (let ((old (symbol-value hook)))
- (if (or (not (listp old))
- (eq (car old) 'lambda))
- (set hook (list old))
- ))
- (or (if (consp function)
- ;; Clever way to tell whether a given lambda-expression
- ;; is equal to anything in the hook.
- (let ((tail (assoc (cdr function) (symbol-value hook))))
- (equal function tail)
- )
- (memq function (symbol-value hook))
- )
- (set hook
- (if append
- (nconc (symbol-value hook) (list function))
- (cons function (symbol-value hook))
- ))
- ))
-
-(defun remove-hook (hook function)
- "Remove from the value of HOOK the function FUNCTION.
-HOOK should be a symbol, and FUNCTION may be any valid function. If
-FUNCTION isn't the value of HOOK, or, if FUNCTION doesn't appear in the
-list of hooks to run in HOOK, then nothing is done. See `add-hook'.
-\[poe-18.el; EMACS 19 emulating function]"
- (if (or (not (boundp hook)) ;unbound symbol, or
- (null (symbol-value hook)) ;value is nil, or
- (null function)) ;function is nil, then
- nil ;Do nothing.
- (let ((hook-value (symbol-value hook)))
- (if (consp hook-value)
- (setq hook-value (delete function hook-value))
- (if (equal hook-value function)
- (setq hook-value nil)
- ))
- (set hook hook-value)
- )))
-
-
-;;; @ end
+(defun overlay-properties (overlay))
+(defun overlays-at (pos))
+(defun overlays-in (beg end))
+(defun next-overlay-change (pos))
+(defun previous-overlay-change (pos))
+(defun overlay-lists ())
+(defun overlay-recenter (pos))
+(defun overlay-get (overlay prop))
+(defun overlay-put (overlay prop value))
+
+;;; @ End.
;;;
-(provide 'poe-18)
+(require 'product)
+(product-provide (provide 'poe-18) (require 'apel-ver))
;;; poe-18.el ends here
projects / elisp / apel.git / blobdiff