;;; 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.
-;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; Author: MORIOKA Tomohiko <tomo@m17n.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
+;; along with this program; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
-;;; Code:
+;;; Commentary:
-(defvar-maybe data-directory exec-directory)
+;; Note to developers:
+;;
+;; If old (v18) compiler is used, top-level macros are expanded at
+;; *load-time*, not compile-time. So, you cannot use macros defined
+;; in this file using `defmacro-maybe'. In addition, due to this
+;; limitation, `eval-when-compile' and `eval-and-compile' provided by
+;; this file do not do compile-time evaluation at all.
+
+;;; Code:
+(provide 'poe-18) ; beware of circular dependency.
+(require 'poe) ; load definitions of `*-maybe'.
;;; @ for EMACS 18.55
;;;
(defvar-maybe buffer-undo-list nil)
+;;; @ Emacs 19 emulation
+;;;
+
+(defvar-maybe data-directory exec-directory)
+
+
;;; @ Lisp Language
;;;
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)))
+ (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 member (elt list)
"Return non-nil if ELT is an element of LIST. Comparison done with EQUAL.
list)
+;;; @@ buffer-local variable
+;;;
+
+(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.
+\[poe-18.el; EMACS 19 emulating function]"
+ (condition-case error
+ (progn
+ (default-value symbol)
+ t)
+ (void-variable nil)))
+
+
;;; @@ environment variable
;;;
(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.
+`nil', the environment variable VARIABLE will be removed.
This function works by modifying `process-environment'."
t)
(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)
- )
-
-
-;;; @ Compilation Features
-;;;
-
-(defmacro-maybe defsubst (name arglist &rest body)
- "Define an inline function. The syntax is just like that of `defun'."
- (cons 'defun (cons name (cons arglist body)))
- )
-
-(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))
+Associates the function with the current load file, if any."
+ (fset sym newdef))
(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)
+ (let ((rest (cdr (cdr exp)))
+ elt)
(if (stringp (car rest))
- (setq rest (cdr 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))
- ))
- )))
+ (if (and (consp elt)
+ (eq (car elt) 'byte-code))
+ (throw 'tag t))
+ (setq rest (cdr rest)))))))
+
+
+;;; @ Compilation Features
+;;;
+
+;;; 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.)
+
+(put 'inline 'lisp-indent-hook 0)
+(defmacro 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.
+\[poe-18.el; EMACS 19 emulating macro]"
+ (` (progn (,@ body))))
+
+(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.
+\[poe-18.el; EMACS 19 emulating macro]"
+ (cons 'defun (cons name (cons arglist body))))
(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."
+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.
+\[poe-18.el; EMACS 19 emulating function]"
(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)
+(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.
+\[poe-18.el; EMACS 19 emulating function]"
+ (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.
+\[poe-18.el; EMACS 19 emulating macro]"
+ (list 'eval (list 'quote (if (cdr body) (cons 'progn body) (car body)))))
+
+(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.
+\[poe-18.el; EMACS 19 emulating macro]"
+ (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.
+\[poe-18.el; EMACS 19 emulating macro]"
+ (cons 'progn body))
+
;;; @ text property
;;;
(defun remove-text-properties (start end properties &optional object))
+(defun get-text-property (position prop &optional object))
+
+(defun add-text-properties (start end properties &optional object))
+
+(defun put-text-property (start end property value &optional object))
+
+(defun next-property-change (position &optional object limit))
+
+(defun text-properties-at (position &optional object))
;;; @ file
;;;
(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)
- )))
+ (let ((dir (expand-file-name dirname)))
+ (if (file-exists-p dir)
+ (error "Creating directory: %s is already exist" dir)
+ (call-process "mkdir" nil nil nil dir))))
(defun make-directory (dir &optional parents)
"Create the directory DIR and any nonexistent parent dirs.
(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)
- ))
+ (make-directory-internal path))))
+ (setq p p1)))
+ (make-directory-internal dir)))
;; Imported from files.el of EMACS 19.33.
(defun parse-colon-path (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)))))))
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)
- )
+ (si:directory-files directory full match))
+
+(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.
+\[poe-18.el; EMACS 19 emulating function]"
+ (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)))))
+
-
;;; @ Display Features
;;;
(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)
- )))
+ (assq value emu:available-face-attribute-alist))))
(if ret
(attribute-add-narrow-attribute (cdr ret)
- (car overlay)(cdr overlay))
- )))
- )
+ (car overlay)(cdr overlay))))))
(t
(defun make-overlay (beg end &optional buffer type))
- (defun overlay-put (overlay prop value))
- ))
+ (defun overlay-put (overlay prop value))))
(defun overlay-buffer (overlay))
(or (fboundp 'si:mark)
(fset 'si:mark (symbol-function 'mark)))
(defun mark (&optional force)
- (si:mark)
- )
+ (si:mark))
-
-;;; @ hook
+;;; @@ current-time
;;;
-;; 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.
+(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 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'.
\[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'.
+ (if (null specified-time)
+ (si:current-time-string)
+ (unless (consp specified-time)
+ (error "Wrong type argument %s" specified-time))
+ (let ((high (car specified-time))
+ (low (cdr specified-time))
+ (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 mm HH MM SS)
+ (if (consp low)
+ (setq low (car low)))
+ (unless (integerp high)
+ (error "Wrong type argument %s" high))
+ (unless (integerp low)
+ (error "Wrong type argument %s" low))
+ (setq low (+ low 32400))
+ (while (> low 65535)
+ (setq high (1+ high)
+ low (- low 65536)))
+ (setq yyyy 1970)
+ (while (or (> high 481)
+ (and (eq high 481)
+ (>= low 13184)))
+ (when (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
+ (when (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 (eq high 1)
+ (>= low 20864)))
+ (when (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 (eq high 1)
+ (setq low (+ 65536 low)))
+ (setq mm 0)
+ (setq uru (and (zerop (% yyyy 4))
+ (or (not (zerop (% yyyy 100)))
+ (zerop (% yyyy 400)))))
+ (while (> (- dd (nth mm mdays)) 0)
+ (if (and (eq mm 1) uru)
+ (setq dd (- dd 29))
+ (setq dd (- dd (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.
\[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)
- )))
-
+ (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)))
+ 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 uru (- (+ (- (/ yyyy 4) (/ yyyy 100))
+ (/ yyyy 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 32400) 0)
+ (setq ct1 (1- ct1)
+ ct2 (+ ct2 65536)))
+ (setq ct2 (- ct2 32400))
+ (while (> ct2 65535)
+ (setq ct1 (1+ ct1)
+ ct2 (- ct2 65536)))
+ (list ct1 ct2 0)))
;;; @ end
;;;
-(provide 'poe-18)
-
;;; poe-18.el ends here
projects / elisp / apel.git / blobdiff