X-Git-Url: http://git.chise.org/gitweb/?p=elisp%2Fapel.git;a=blobdiff_plain;f=poe-18.el;h=7ee62cefefa6caf96a5e6e3d79f30e6c9d335e90;hp=a7faa15d5af01dc047c0a4d8b62e47d153f264e7;hb=d11bfd0672b590339a79a49f9688ce250690b1de;hpb=88d4f128e223b2ece52dd6b157dd7d4025326fbf diff --git a/poe-18.el b/poe-18.el index a7faa15..7ee62ce 100644 --- a/poe-18.el +++ b/poe-18.el @@ -25,11 +25,12 @@ ;;; 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'. Especially, you cannot use -;; `eval-when-compile' and `eval-and-compile' in this file. +;; 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: @@ -62,15 +63,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))) - (setcdr 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. @@ -102,7 +104,7 @@ for this 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) @@ -135,36 +137,25 @@ Associates the function with the current load file, if any." ;;; @ Compilation Features ;;; -(put 'eval-when-compile 'lisp-indent-hook 0) -(defmacro-maybe eval-when-compile (&rest body) - "Like progn, but evaluates the body at compile-time. +;;; 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.) -This emulating macro does not work if used at top-level. -Top-level macros are expanded at load-time. -\[poe-18.el; EMACS 19 emulating macro]" - (list 'quote (eval (cons 'progn body)))) +(put 'inline 'lisp-indent-hook 0) +(defmacro inline (&rest body) + "Eval BODY forms sequentially and return value of last one. -(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 work if used at top-level. -Top-level macros are expanded at load-time. +This emulating macro does not support function inlining because old \(v18\) +compiler does not support inlining feature. \[poe-18.el; EMACS 19 emulating macro]" - ;; `form' is a parameter of `byte-compile-form'. kludge! kludge! kludge! - ;; this kludge prevents from evaluating `body' twice when this macro is - ;; expanded at load-time. - (if (and (boundp 'form) - (eq (car-safe form) 'eval-and-compile)) - (eval (cons 'progn body))) - (cons 'progn body)) + (` (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) +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)))) @@ -174,12 +165,48 @@ compiler does not support inlining feature. 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 +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: ") 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 ;;; @@ -188,6 +215,15 @@ support this feature. (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 ;;; @@ -264,7 +300,16 @@ If NOSORT is dummy for compatibility. \[poe-18.el; EMACS 19 emulating function]" (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 ;;; @@ -327,7 +372,7 @@ 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) @@ -366,6 +411,176 @@ even if a buffer with that name exists." (defun mark (&optional force) (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 ;;;