X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=poe-18.el;h=27dcc96d026450023f22124db19b74462e89947c;hb=856f094dabc99315a46caf8865beee174228f8af;hp=812e5c7ff35662b19296bd7ca45464802b4fa7d3;hpb=06a7b5144e06de214d0c6a1e3664a5d36a9a3302;p=elisp%2Fapel.git

diff --git a/poe-18.el b/poe-18.el
index 812e5c7..27dcc96 100644
--- a/poe-18.el
+++ b/poe-18.el
@@ -1,8 +1,8 @@
 ;;; 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).
@@ -18,14 +18,27 @@
 ;; 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.
 
+;;; Commentary:
+
+;; 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:
 
-(defvar-maybe data-directory exec-directory)
+;; beware of circular dependency.
+(require 'product)
+(product-provide (provide 'poe-18) (require 'apel-ver))
 
+(require 'poe)				; load definitions of `*-maybe'.
 
 ;;; @ for EMACS 18.55
 ;;;
@@ -33,6 +46,12 @@
 (defvar-maybe buffer-undo-list nil)
 
 
+;;; @ Emacs 19 emulation
+;;;
+
+(defvar-maybe data-directory exec-directory)
+
+
 ;;; @ Lisp Language
 ;;;
 
@@ -47,17 +66,16 @@ 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)))
+  (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.
@@ -68,13 +86,28 @@ The value is actually the tail of LIST whose car is ELT.
   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)
 
@@ -84,57 +117,99 @@ This function works by modifying `process-environment'."
 
 (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 eval-when-compile (&rest body)
-  "Like `progn', but evaluates the body at compile time.
-The result of the body appears to the compiler as a quoted constant."
-  ;; Not necessary because we have it in b-c-initial-macro-environment
-  ;; (list 'quote (eval (cons 'progn body)))
-  (cons 'progn 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
 ;;;
@@ -143,6 +218,15 @@ If NEW is a string, that is the `use instead' message."
 
 (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
 ;;;
@@ -152,7 +236,7 @@ If NEW is a string, that is the `use instead' message."
 \[poe-18.el; EMACS 19 emulating function]"
  (let ((dir (expand-file-name dirname)))
    (if (file-exists-p dir)
-      (error "Creating directory: %s is already exist" dir)
+       (error "Creating directory: %s is already exist" dir)
      (call-process "mkdir" nil nil nil dir))))
 
 (defun make-directory (dir &optional parents)
@@ -166,24 +250,17 @@ to create parent directories if they don't exist.
       (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)
@@ -195,7 +272,7 @@ to create parent directories if they don't exist.
 	   (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)))))))
@@ -224,10 +301,18 @@ If FULL is non-nil, return absolute file names.  Otherwise return names
 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
 ;;;
 
@@ -290,22 +375,18 @@ With optional non-nil ALL, force redisplay of all mode-lines.
 	       (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))
 
@@ -331,13 +412,180 @@ even if a buffer with that name exists."
 (or (fboundp 'si:mark)
     (fset 'si:mark (symbol-function 'mark)))
 (defun mark (&optional force)
-  (si:mark)
-  )
+  (si:mark))
 
+;;; @@ current-time
+;;;
+
+(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]"
+  (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]"
+  (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