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 <tomo@m17n.org>
   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 this program; 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 ;;; Commentary:
  26
  27 ;; Note to developers:
  28 ;;
  29 ;; If old (v18) compiler is used, top-level macros are expanded at
  30 ;; *load-time*, not compile-time.  So, you cannot use macros defined
  31 ;; in this file using `defmacro-maybe'.  In addition, due to this
  32 ;; limitation, `eval-when-compile' and `eval-and-compile' provided by
  33 ;; this file do not do compile-time evaluation at all.
  34
  35 ;;; Code:
  36
  37 ;; beware of circular dependency.
  38 (require 'product)
  39 (product-provide (provide 'poe-18) (require 'apel-ver))
  40
  41 (require 'poe)                          ; load definitions of `*-maybe'.
  42
  43 ;;; @ for EMACS 18.55
  44 ;;;
  45
  46 (defvar-maybe buffer-undo-list nil)
  47
  48
  49 ;;; @ Emacs 19 emulation
  50 ;;;
  51
  52 (defvar-maybe data-directory exec-directory)
  53
  54
  55 ;;; @ Lisp Language
  56 ;;;
  57
  58 ;;; @@ list
  59 ;;;
  60
  61 (defun delete (elt list)
  62   "Delete by side effect any occurrences of ELT as a member of LIST.
  63 The modified LIST is returned.  Comparison is done with `equal'.
  64 If the first member of LIST is ELT, deleting it is not a side effect;
  65 it is simply using a different list.
  66 Therefore, write `(setq foo (delete element foo))'
  67 to be sure of changing the value of `foo'.
  68 \[poe-18.el; EMACS 19 emulating function]"
  69   (if list
  70       (if (equal elt (car list))
  71           (cdr list)
  72         (let ((rest list)
  73               (rrest (cdr list)))
  74           (while (and rrest (not (equal elt (car rrest))))
  75             (setq rest rrest
  76                   rrest (cdr rrest)))
  77           (setcdr rest (cdr rrest))
  78           list))))
  79
  80 (defun member (elt list)
  81   "Return non-nil if ELT is an element of LIST.  Comparison done with EQUAL.
  82 The value is actually the tail of LIST whose car is ELT.
  83 \[poe-18.el; EMACS 19 emulating function]"
  84   (while (and list (not (equal elt (car list))))
  85     (setq list (cdr list)))
  86   list)
  87
  88
  89 ;;; @@ buffer-local variable
  90 ;;;
  91
  92 (defun default-boundp (symbol)
  93   "Return t if SYMBOL has a non-void default value.
  94 This is the value that is seen in buffers that do not have their own values
  95 for this variable.
  96 \[poe-18.el; EMACS 19 emulating function]"
  97   (condition-case error
  98       (progn
  99         (default-value symbol)
 100         t)
 101     (void-variable nil)))
 102
 103
 104 ;;; @@ environment variable
 105 ;;;
 106
 107 (autoload 'setenv "env"
 108   "Set the value of the environment variable named VARIABLE to VALUE.
 109 VARIABLE should be a string.  VALUE is optional; if not provided or is
 110 `nil', the environment variable VARIABLE will be removed.
 111 This function works by modifying `process-environment'."
 112   t)
 113
 114
 115 ;;; @@ function
 116 ;;;
 117
 118 (defun defalias (sym newdef)
 119   "Set SYMBOL's function definition to NEWVAL, and return NEWVAL.
 120 Associates the function with the current load file, if any."
 121   (fset sym newdef))
 122
 123 (defun byte-code-function-p (exp)
 124   "T if OBJECT is a byte-compiled function object.
 125 \[poe-18.el; EMACS 19 emulating function]"
 126   (and (consp exp)
 127        (let ((rest (cdr (cdr exp)))
 128              elt)
 129          (if (stringp (car rest))
 130              (setq rest (cdr rest)))
 131          (catch 'tag
 132            (while rest
 133              (setq elt (car rest))
 134              (if (and (consp elt)
 135                       (eq (car elt) 'byte-code))
 136                  (throw 'tag t))
 137              (setq rest (cdr rest)))))))
 138
 139
 140 ;;; @ Compilation Features
 141 ;;;
 142
 143 ;;; emulate all functions and macros of emacs-20.3/lisp/byte-run.el.
 144 ;;; (note: jwz's original compiler and XEmacs compiler have some more
 145 ;;;  macros; they are "nuked" by rms in FSF version.)
 146
 147 (put 'inline 'lisp-indent-hook 0)
 148 (defmacro inline (&rest body)
 149   "Eval BODY forms sequentially and return value of last one.
 150
 151 This emulating macro does not support function inlining because old \(v18\)
 152 compiler does not support inlining feature.
 153 \[poe-18.el; EMACS 19 emulating macro]"
 154   (` (progn (,@ body))))
 155
 156 (put 'defsubst 'lisp-indent-hook 'defun)
 157 (put 'defsubst 'edebug-form-spec 'defun)
 158 (defmacro-maybe defsubst (name arglist &rest body)
 159   "Define an inline function.  The syntax is just like that of `defun'.
 160
 161 This emulating macro does not support function inlining because old \(v18\)
 162 compiler does not support inlining feature.
 163 \[poe-18.el; EMACS 19 emulating macro]"
 164   (cons 'defun (cons name (cons arglist body))))
 165
 166 (defun-maybe make-obsolete (fn new)
 167   "Make the byte-compiler warn that FUNCTION is obsolete.
 168 The warning will say that NEW should be used instead.
 169 If NEW is a string, that is the `use instead' message.
 170
 171 This emulating function does nothing because old \(v18\) compiler does not
 172 support this feature.
 173 \[poe-18.el; EMACS 19 emulating function]"
 174   (interactive "aMake function obsolete: \nxObsoletion replacement: ")
 175   fn)
 176
 177 (defun-maybe make-obsolete-variable (var new)
 178   "Make the byte-compiler warn that VARIABLE is obsolete,
 179 and NEW should be used instead.  If NEW is a string, then that is the
 180 `use instead' message.
 181
 182 This emulating function does nothing because old \(v18\) compiler does not
 183 support this feature.
 184 \[poe-18.el; EMACS 19 emulating function]"
 185   (interactive "vMake variable obsolete: \nxObsoletion replacement: ")
 186   var)
 187
 188 (put 'dont-compile 'lisp-indent-hook 0)
 189 (defmacro-maybe dont-compile (&rest body)
 190   "Like `progn', but the body always runs interpreted \(not compiled\).
 191 If you think you need this, you're probably making a mistake somewhere.
 192 \[poe-18.el; EMACS 19 emulating macro]"
 193   (list 'eval (list 'quote (if (cdr body) (cons 'progn body) (car body)))))
 194
 195 (put 'eval-when-compile 'lisp-indent-hook 0)
 196 (defmacro-maybe eval-when-compile (&rest body)
 197   "Like progn, but evaluates the body at compile-time.
 198
 199 This emulating macro does not do compile-time evaluation at all because
 200 of the limitation of old \(v18\) compiler.
 201 \[poe-18.el; EMACS 19 emulating macro]"
 202   (cons 'progn body))
 203
 204 (put 'eval-and-compile 'lisp-indent-hook 0)
 205 (defmacro-maybe eval-and-compile (&rest body)
 206   "Like progn, but evaluates the body at compile-time as well as at load-time.
 207
 208 This emulating macro does not do compile-time evaluation at all because
 209 of the limitation of old \(v18\) compiler.
 210 \[poe-18.el; EMACS 19 emulating macro]"
 211   (cons 'progn body))
 212
 213
 214 ;;; @ text property
 215 ;;;
 216
 217 (defun set-text-properties (start end properties &optional object))
 218
 219 (defun remove-text-properties (start end properties &optional object))
 220
 221 (defun get-text-property (position prop &optional object))
 222
 223 (defun add-text-properties (start end properties &optional object))
 224
 225 (defun put-text-property (start end property value &optional object))
 226
 227 (defun next-property-change (position &optional object limit))
 228
 229 (defun text-properties-at (position &optional object))
 230
 231 ;;; @ file
 232 ;;;
 233
 234 (defun make-directory-internal (dirname)
 235   "Create a directory. One argument, a file name string.
 236 \[poe-18.el; EMACS 19 emulating function]"
 237  (let ((dir (expand-file-name dirname)))
 238    (if (file-exists-p dir)
 239        (error "Creating directory: %s is already exist" dir)
 240      (call-process "mkdir" nil nil nil dir))))
 241
 242 (defun make-directory (dir &optional parents)
 243   "Create the directory DIR and any nonexistent parent dirs.
 244 The second (optional) argument PARENTS says whether
 245 to create parent directories if they don't exist.
 246 \[poe-18.el; EMACS 19 emulating function]"
 247   (let ((len (length dir))
 248         (p 0) p1 path)
 249     (catch 'tag
 250       (while (and (< p len) (string-match "[^/]*/?" dir p))
 251         (setq p1 (match-end 0))
 252         (if (= p1 len)
 253             (throw 'tag nil))
 254         (setq path (substring dir 0 p1))
 255         (if (not (file-directory-p path))
 256             (cond ((file-exists-p path)
 257                    (error "Creating directory: %s is not directory" path))
 258                   ((null parents)
 259                    (error "Creating directory: %s is not exist" path))
 260                   (t
 261                    (make-directory-internal path))))
 262         (setq p p1)))
 263     (make-directory-internal dir)))
 264
 265 ;; Imported from files.el of EMACS 19.33.
 266 (defun parse-colon-path (cd-path)
 267   "Explode a colon-separated list of paths into a string list."
 268   (and cd-path
 269        (let (cd-prefix cd-list (cd-start 0) cd-colon)
 270          (setq cd-path (concat cd-path path-separator))
 271          (while (setq cd-colon (string-match path-separator cd-path cd-start))
 272            (setq cd-list
 273                  (nconc cd-list
 274                         (list (if (= cd-start cd-colon)
 275                                   nil
 276                                 (substitute-in-file-name
 277                                  (file-name-as-directory
 278                                   (substring cd-path cd-start cd-colon)))))))
 279            (setq cd-start (+ cd-colon 1)))
 280          cd-list)))
 281
 282 ;; Imported from files.el of EMACS 19.33.
 283 (defun file-relative-name (filename &optional directory)
 284   "Convert FILENAME to be relative to DIRECTORY (default: default-directory)."
 285   (setq filename (expand-file-name filename)
 286         directory (file-name-as-directory (expand-file-name
 287                                            (or directory default-directory))))
 288   (let ((ancestor ""))
 289     (while (not (string-match (concat "^" (regexp-quote directory)) filename))
 290       (setq directory (file-name-directory (substring directory 0 -1))
 291             ancestor (concat "../" ancestor)))
 292     (concat ancestor (substring filename (match-end 0)))))
 293
 294 (or (fboundp 'si:directory-files)
 295     (fset 'si:directory-files (symbol-function 'directory-files)))
 296 (defun directory-files (directory &optional full match nosort)
 297   "Return a list of names of files in DIRECTORY.
 298 There are three optional arguments:
 299 If FULL is non-nil, return absolute file names.  Otherwise return names
 300  that are relative to the specified directory.
 301 If MATCH is non-nil, mention only file names that match the regexp MATCH.
 302 If NOSORT is dummy for compatibility.
 303 \[poe-18.el; EMACS 19 emulating function]"
 304   (si:directory-files directory full match))
 305
 306 (defun file-executable-p (filename)
 307   "Return t if FILENAME can be executed by you.
 308 For a directory, this means you can access files in that directory.
 309 \[poe-18.el; EMACS 19 emulating function]"
 310   (if (file-exists-p filename)
 311       (let ((process (start-process "test" nil "test" "-x" filename)))
 312         (while (eq 'run (process-status process)))
 313         (zerop (process-exit-status process)))))
 314
 315
 316 ;;; @ Display Features
 317 ;;;
 318
 319 ;;; Imported from Emacs 19.30.
 320 (defun force-mode-line-update (&optional all)
 321   "Force the mode-line of the current buffer to be redisplayed.
 322 With optional non-nil ALL, force redisplay of all mode-lines.
 323 \[poe-18.el; Emacs 19 emulating function]"
 324   (if all (save-excursion (set-buffer (other-buffer))))
 325   (set-buffer-modified-p (buffer-modified-p)))
 326
 327
 328 ;;; @ overlay
 329 ;;;
 330
 331 (cond ((boundp 'NEMACS)
 332        (defvar emu:available-face-attribute-alist
 333          '(
 334            ;;(bold      . inversed-region)
 335            (italic    . underlined-region)
 336            (underline . underlined-region)
 337            ))
 338
 339        ;; by YAMATE Keiichirou 1994/10/28
 340        (defun attribute-add-narrow-attribute (attr from to)
 341          (or (consp (symbol-value attr))
 342              (set attr (list 1)))
 343          (let* ((attr-value (symbol-value attr))
 344                 (len (car attr-value))
 345                 (posfrom 1)
 346                 posto)
 347            (while (and (< posfrom len)
 348                        (> from (nth posfrom attr-value)))
 349              (setq posfrom (1+ posfrom)))
 350            (setq posto posfrom)
 351            (while (and (< posto len)
 352                        (> to (nth posto attr-value)))
 353              (setq posto (1+ posto)))
 354            (if  (= posto posfrom)
 355                (if (= (% posto 2) 1)
 356                    (if (and (< to len)
 357                             (= to (nth posto attr-value)))
 358                        (set-marker (nth posto attr-value) from)
 359                      (setcdr (nthcdr (1- posfrom) attr-value)
 360                              (cons (set-marker-type (set-marker (make-marker)
 361                                                                 from)
 362                                                     'point-type)
 363                                    (cons (set-marker-type
 364                                           (set-marker (make-marker)
 365                                                       to)
 366                                           nil)
 367                                          (nthcdr posto attr-value))))
 368                      (setcar attr-value (+ len 2))))
 369              (if (= (% posfrom 2) 0)
 370                  (setq posfrom (1- posfrom))
 371                (set-marker (nth posfrom attr-value) from))
 372              (if (= (% posto 2) 0)
 373                  nil
 374                (setq posto (1- posto))
 375                (set-marker (nth posto attr-value) to))
 376              (setcdr (nthcdr posfrom attr-value)
 377                      (nthcdr posto attr-value)))))
 378
 379        (defalias 'make-overlay 'cons)
 380
 381        (defun overlay-put (overlay prop value)
 382          (let ((ret (and (eq prop 'face)
 383                          (assq value emu:available-face-attribute-alist))))
 384            (if ret
 385                (attribute-add-narrow-attribute (cdr ret)
 386                                                (car overlay)(cdr overlay))))))
 387       (t
 388        (defun make-overlay (beg end &optional buffer type))
 389        (defun overlay-put (overlay prop value))))
 390
 391 (defun overlay-buffer (overlay))
 392
 393
 394 ;;; @ buffer
 395 ;;;
 396
 397 (defun-maybe generate-new-buffer-name (name &optional ignore)
 398   "Return a string that is the name of no existing buffer based on NAME.
 399 If there is no live buffer named NAME, then return NAME.
 400 Otherwise modify name by appending `<NUMBER>', incrementing NUMBER
 401 until an unused name is found, and then return that name.
 402 Optional second argument IGNORE specifies a name that is okay to use
 403 \(if it is in the sequence to be tried)
 404 even if a buffer with that name exists."
 405   (if (get-buffer name)
 406       (let ((n 2) new)
 407         (while (get-buffer (setq new (format "%s<%d>" name n)))
 408           (setq n (1+ n)))
 409         new)
 410     name))
 411
 412 (or (fboundp 'si:mark)
 413     (fset 'si:mark (symbol-function 'mark)))
 414 (defun mark (&optional force)
 415   (si:mark))
 416
 417 ;;; @@ current-time
 418 ;;;
 419
 420 (or (fboundp 'si:current-time-string)
 421     (fset 'si:current-time-string (symbol-function 'current-time-string)))
 422 (defun current-time-string (&optional specified-time)
 423   "Return the current time, as a human-readable string.
 424 Programs can use this function to decode a time,
 425 since the number of columns in each field is fixed.
 426 The format is `Sun Sep 16 01:03:52 1973'.
 427 If an argument is given, it specifies a time to format
 428 instead of the current time.  The argument should have the form:
 429   (HIGH . LOW)
 430 or the form:
 431   (HIGH LOW . IGNORED).
 432 Thus, you can use times obtained from `current-time'
 433 and from `file-attributes'.
 434 \[poe-18.el; EMACS 19 emulating function]"
 435   (if (null specified-time)
 436       (si:current-time-string)
 437     (unless (consp specified-time)
 438       (error "Wrong type argument %s" specified-time))
 439     (let ((high (car specified-time))
 440           (low  (cdr specified-time))
 441           (mdays '(31 28 31 30 31 30 31 31 30 31 30 31))
 442           (mnames '("Jan" "Feb" "Mar" "Apr" "May" "Jun"
 443                     "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
 444           (wnames '("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat"))
 445           days dd yyyy mm HH MM SS)
 446       (if (consp low)
 447           (setq low (car low)))
 448       (unless (integerp high)
 449         (error "Wrong type argument %s" high))
 450       (unless (integerp low)
 451         (error "Wrong type argument %s" low))
 452       (setq low (+ low 32400))
 453       (while (> low 65535)
 454         (setq high (1+ high)
 455               low (- low 65536)))
 456       (setq yyyy 1970)
 457       (while (or (> high 481)
 458                  (and (eq high 481)
 459                       (>= low 13184)))
 460         (when (and (> high 0)
 461                    (< low 13184))
 462           (setq high (1- high)
 463                 low  (+ 65536 low)))
 464         (setq high (- high 481)
 465               low  (- low 13184))
 466         (if (and (zerop (% yyyy 4))
 467                  (or (not (zerop (% yyyy 100)))
 468                    (zerop (% yyyy 400))))
 469             (progn
 470               (when (and (> high 0)
 471                          (< low 20864))
 472                 (setq high (1- high)
 473                       low  (+ 65536 low)))
 474               (setq high (- high 1)
 475                     low (- low 20864))))
 476         (setq yyyy (1+ yyyy)))
 477       (setq dd 1)
 478       (while (or (> high 1)
 479                  (and (eq high 1)
 480                       (>= low 20864)))
 481         (when (and (> high 0)
 482                    (< low 20864))
 483           (setq high (1- high)
 484                 low  (+ 65536 low)))
 485         (setq high (- high 1)
 486               low  (- low 20864)
 487               dd (1+ dd)))
 488       (setq days dd)
 489       (if (eq high 1)
 490           (setq low (+ 65536 low)))
 491       (setq mm 0)
 492       (setq uru (and (zerop (% yyyy 4))
 493                      (or (not (zerop (% yyyy 100)))
 494                          (zerop (% yyyy 400)))))
 495       (while (> (- dd (nth mm mdays)) 0)
 496         (if (and (eq mm 1) uru)
 497             (setq dd (- dd 29))
 498           (setq dd (- dd (nth mm mdays))))
 499         (setq mm (1+ mm)))
 500       (setq HH (/ low 3600)
 501             low (% low 3600)
 502             MM (/ low 60)
 503             SS (% low 60))
 504       (format "%s %s %2d %02d:%02d:%02d %4d"
 505               (nth (% (+ days
 506                          (- (+ (* (1- yyyy) 365) (/ (1- yyyy) 400)
 507                                (/ (1- yyyy) 4)) (/ (1- yyyy) 100))) 7)
 508                    wnames)
 509               (nth mm mnames)
 510               dd HH MM SS yyyy))))
 511
 512 (defun current-time ()
 513   "Return the current time, as the number of seconds since 1970-01-01 00:00:00.
 514 The time is returned as a list of three integers.  The first has the
 515 most significant 16 bits of the seconds, while the second has the
 516 least significant 16 bits.  The third integer gives the microsecond
 517 count.
 518
 519 The microsecond count is zero on systems that do not provide
 520 resolution finer than a second.
 521 \[poe-18.el; EMACS 19 emulating function]"
 522   (let* ((str (current-time-string))
 523          (yyyy (string-to-int (substring str 20 24)))
 524          (mm (length (member (substring str 4 7)
 525                              '("Dec" "Nov" "Oct" "Sep" "Aug" "Jul"
 526                                "Jun" "May" "Apr" "Mar" "Feb" "Jan"))))
 527          (dd (string-to-int (substring str 8 10)))
 528          (HH (string-to-int (substring str 11 13)))
 529          (MM (string-to-int (substring str 14 16)))
 530          (SS (string-to-int (substring str 17 19)))
 531          dn ct1 ct2 i1 i2
 532          year uru)
 533     (setq ct1 0 ct2 0 i1 0 i2 0)
 534     (setq year (- yyyy 1970))
 535     (while (> year 0)
 536       (setq year (1- year)
 537             ct1 (+ ct1 481)
 538             ct2 (+ ct2 13184))
 539       (while (> ct2 65535)
 540         (setq ct1 (1+ ct1)
 541               ct2 (- ct2 65536))))
 542     (setq uru (- (+ (- (/ yyyy 4) (/ yyyy 100))
 543                     (/ yyyy 400)) 477))
 544     (while (> uru 0)
 545       (setq uru (1- uru)
 546             i1 (1+ i1)
 547             i2 (+ i2 20864))
 548       (if (> i2 65535)
 549           (setq i1 (1+ i1)
 550                 i2 (- i2 65536))))
 551     (setq ct1 (+ ct1 i1)
 552           ct2 (+ ct2 i2))
 553     (while (> ct2 65535)
 554       (setq ct1 (1+ ct1)
 555             ct2 (- ct2 65536)))
 556     (setq dn (+ dd (* 31 (1- mm))))
 557     (if (> mm 2)
 558         (setq dn (+ (- dn (/ (+ 23 (* 4 mm)) 10))
 559                     (if (and (zerop (% yyyy 4))
 560                              (or (not (zerop (% yyyy 100)))
 561                                  (zerop (% yyyy 400))))
 562                         1 0))))
 563     (setq dn (1- dn)
 564           i1 0
 565           i2 0)
 566     (while (> dn 0)
 567       (setq dn (1- dn)
 568             i1 (1+ i1)
 569             i2 (+ i2 20864))
 570       (if (> i2 65535)
 571           (setq i1 (1+ i1)
 572                 i2 (- i2 65536))))
 573     (setq ct1 (+ (+ (+ ct1 i1) (/ ct2 65536))
 574                  (/ (+ (* HH 3600) (* MM 60) SS)
 575                     65536))
 576           ct2 (+ (+ i2 (% ct2 65536))
 577                  (% (+ (* HH 3600) (* MM 60) SS)
 578                     65536)))
 579     (while (< (- ct2 32400) 0)
 580       (setq ct1 (1- ct1)
 581             ct2 (+ ct2 65536)))
 582     (setq ct2 (- ct2 32400))
 583     (while (> ct2 65535)
 584       (setq ct1 (1+ ct1)
 585             ct2 (- ct2 65536)))
 586     (list ct1 ct2 0)))
 587
 588 ;;; @ end
 589 ;;;
 590
 591 ;;; poe-18.el ends here