1 | ;;; poe-18.el --- poe API implementation for Emacs 18.* |
---|
2 | |
---|
3 | ;; Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc. |
---|
4 | ;; Copyright (C) 1999 Yuuichi Teranishi |
---|
5 | |
---|
6 | ;; Author: MORIOKA Tomohiko <tomo@m17n.org> |
---|
7 | ;; Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp> |
---|
8 | ;; Yuuichi Teranishi <teranisi@gohome.org> |
---|
9 | ;; Keywords: emulation, compatibility |
---|
10 | |
---|
11 | ;; This file is part of APEL (A Portable Emacs Library). |
---|
12 | |
---|
13 | ;; This program is free software; you can redistribute it and/or |
---|
14 | ;; modify it under the terms of the GNU General Public License as |
---|
15 | ;; published by the Free Software Foundation; either version 2, or (at |
---|
16 | ;; your option) any later version. |
---|
17 | |
---|
18 | ;; This program is distributed in the hope that it will be useful, but |
---|
19 | ;; WITHOUT ANY WARRANTY; without even the implied warranty of |
---|
20 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
---|
21 | ;; General Public License for more details. |
---|
22 | |
---|
23 | ;; You should have received a copy of the GNU General Public License |
---|
24 | ;; along with this program; see the file COPYING. If not, write to the |
---|
25 | ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, |
---|
26 | ;; Boston, MA 02111-1307, USA. |
---|
27 | |
---|
28 | ;;; Commentary: |
---|
29 | |
---|
30 | ;; Note to APEL developers and APEL programmers: |
---|
31 | ;; |
---|
32 | ;; If old (v18) compiler is used, top-level macros are expanded at |
---|
33 | ;; *load-time*, not compile-time. Therefore, |
---|
34 | ;; |
---|
35 | ;; (1) Definitions with `*-maybe' won't be compiled. |
---|
36 | ;; |
---|
37 | ;; (2) you cannot use macros defined with `defmacro-maybe' within function |
---|
38 | ;; definitions in the same file. |
---|
39 | ;; (`defmacro-maybe' is evaluated at load-time, therefore byte-compiler |
---|
40 | ;; treats such use of macros as (unknown) functions and compiles them |
---|
41 | ;; into function calls, which will cause errors at run-time.) |
---|
42 | ;; |
---|
43 | ;; (3) `eval-when-compile' and `eval-and-compile' are evaluated at |
---|
44 | ;; load-time if used at top-level. |
---|
45 | |
---|
46 | ;;; Code: |
---|
47 | |
---|
48 | (require 'pym) |
---|
49 | |
---|
50 | |
---|
51 | ;;; @ Compilation. |
---|
52 | ;;; |
---|
53 | (fset 'defalias 'fset) |
---|
54 | |
---|
55 | (defun byte-code-function-p (object) |
---|
56 | "Return t if OBJECT is a byte-compiled function object." |
---|
57 | (and (consp object) (consp (cdr object)) |
---|
58 | (let ((rest (cdr (cdr object))) |
---|
59 | elt) |
---|
60 | (if (stringp (car rest)) |
---|
61 | (setq rest (cdr rest))) |
---|
62 | (catch 'tag |
---|
63 | (while rest |
---|
64 | (setq elt (car rest)) |
---|
65 | (if (and (consp elt) |
---|
66 | (eq (car elt) 'byte-code)) |
---|
67 | (throw 'tag t)) |
---|
68 | (setq rest (cdr rest))))))) |
---|
69 | |
---|
70 | ;; (symbol-plist 'cyclic-function-indirection) |
---|
71 | (put 'cyclic-function-indirection |
---|
72 | 'error-conditions |
---|
73 | '(cyclic-function-indirection error)) |
---|
74 | (put 'cyclic-function-indirection |
---|
75 | 'error-message |
---|
76 | "Symbol's chain of function indirections contains a loop") |
---|
77 | |
---|
78 | ;; The following function definition is a direct translation of its |
---|
79 | ;; C definition in emacs-20.4/src/data.c. |
---|
80 | (defun indirect-function (object) |
---|
81 | "Return the function at the end of OBJECT's function chain. |
---|
82 | If OBJECT is a symbol, follow all function indirections and return the final |
---|
83 | function binding. |
---|
84 | If OBJECT is not a symbol, just return it. |
---|
85 | Signal a void-function error if the final symbol is unbound. |
---|
86 | Signal a cyclic-function-indirection error if there is a loop in the |
---|
87 | function chain of symbols." |
---|
88 | (let* ((hare object) |
---|
89 | (tortoise hare)) |
---|
90 | (catch 'found |
---|
91 | (while t |
---|
92 | (or (symbolp hare) (throw 'found hare)) |
---|
93 | (or (fboundp hare) (signal 'void-function (cons object nil))) |
---|
94 | (setq hare (symbol-function hare)) |
---|
95 | (or (symbolp hare) (throw 'found hare)) |
---|
96 | (or (fboundp hare) (signal 'void-function (cons object nil))) |
---|
97 | (setq hare (symbol-function hare)) |
---|
98 | |
---|
99 | (setq tortoise (symbol-function tortoise)) |
---|
100 | |
---|
101 | (if (eq hare tortoise) |
---|
102 | (signal 'cyclic-function-indirection (cons object nil))))) |
---|
103 | hare)) |
---|
104 | |
---|
105 | ;;; Emulate all functions and macros of emacs-20.3/lisp/byte-run.el. |
---|
106 | ;;; (note: jwz's original compiler and XEmacs compiler have some more |
---|
107 | ;;; macros; they are "nuked" by rms in FSF version.) |
---|
108 | |
---|
109 | ;; Use `*-maybe' here because new byte-compiler may be installed. |
---|
110 | (put 'inline 'lisp-indent-hook 0) |
---|
111 | (defmacro-maybe inline (&rest body) |
---|
112 | "Eval BODY forms sequentially and return value of last one. |
---|
113 | |
---|
114 | This emulating macro does not support function inlining because old \(v18\) |
---|
115 | compiler does not support inlining feature." |
---|
116 | (cons 'progn body)) |
---|
117 | |
---|
118 | (put 'defsubst 'lisp-indent-hook 'defun) |
---|
119 | (put 'defsubst 'edebug-form-spec 'defun) |
---|
120 | (defmacro-maybe defsubst (name arglist &rest body) |
---|
121 | "Define an inline function. The syntax is just like that of `defun'. |
---|
122 | |
---|
123 | This emulating macro does not support function inlining because old \(v18\) |
---|
124 | compiler does not support inlining feature." |
---|
125 | (cons 'defun (cons name (cons arglist body)))) |
---|
126 | |
---|
127 | (defun-maybe make-obsolete (fn new) |
---|
128 | "Make the byte-compiler warn that FUNCTION is obsolete. |
---|
129 | The warning will say that NEW should be used instead. |
---|
130 | If NEW is a string, that is the `use instead' message. |
---|
131 | |
---|
132 | This emulating function does nothing because old \(v18\) compiler does not |
---|
133 | support this feature." |
---|
134 | (interactive "aMake function obsolete: \nxObsoletion replacement: ") |
---|
135 | fn) |
---|
136 | |
---|
137 | (defun-maybe make-obsolete-variable (var new) |
---|
138 | "Make the byte-compiler warn that VARIABLE is obsolete, |
---|
139 | and NEW should be used instead. If NEW is a string, then that is the |
---|
140 | `use instead' message. |
---|
141 | |
---|
142 | This emulating function does nothing because old \(v18\) compiler does not |
---|
143 | support this feature." |
---|
144 | (interactive "vMake variable obsolete: \nxObsoletion replacement: ") |
---|
145 | var) |
---|
146 | |
---|
147 | (put 'dont-compile 'lisp-indent-hook 0) |
---|
148 | (defmacro-maybe dont-compile (&rest body) |
---|
149 | "Like `progn', but the body always runs interpreted \(not compiled\). |
---|
150 | If you think you need this, you're probably making a mistake somewhere." |
---|
151 | (list 'eval (list 'quote (if (cdr body) (cons 'progn body) (car body))))) |
---|
152 | |
---|
153 | (put 'eval-when-compile 'lisp-indent-hook 0) |
---|
154 | (defmacro-maybe eval-when-compile (&rest body) |
---|
155 | "Like progn, but evaluates the body at compile-time. |
---|
156 | |
---|
157 | This emulating macro does not do compile-time evaluation at all because |
---|
158 | of the limitation of old \(v18\) compiler." |
---|
159 | (cons 'progn body)) |
---|
160 | |
---|
161 | (put 'eval-and-compile 'lisp-indent-hook 0) |
---|
162 | (defmacro-maybe eval-and-compile (&rest body) |
---|
163 | "Like progn, but evaluates the body at compile-time as well as at load-time. |
---|
164 | |
---|
165 | This emulating macro does not do compile-time evaluation at all because |
---|
166 | of the limitation of old \(v18\) compiler." |
---|
167 | (cons 'progn body)) |
---|
168 | |
---|
169 | |
---|
170 | ;;; @ C primitives emulation. |
---|
171 | ;;; |
---|
172 | |
---|
173 | (defun member (elt list) |
---|
174 | "Return non-nil if ELT is an element of LIST. Comparison done with EQUAL. |
---|
175 | The value is actually the tail of LIST whose car is ELT." |
---|
176 | (while (and list (not (equal elt (car list)))) |
---|
177 | (setq list (cdr list))) |
---|
178 | list) |
---|
179 | |
---|
180 | (defun delete (elt list) |
---|
181 | "Delete by side effect any occurrences of ELT as a member of LIST. |
---|
182 | The modified LIST is returned. Comparison is done with `equal'. |
---|
183 | If the first member of LIST is ELT, deleting it is not a side effect; |
---|
184 | it is simply using a different list. |
---|
185 | Therefore, write `(setq foo (delete element foo))' |
---|
186 | to be sure of changing the value of `foo'." |
---|
187 | (if list |
---|
188 | (if (equal elt (car list)) |
---|
189 | (cdr list) |
---|
190 | (let ((rest list) |
---|
191 | (rrest (cdr list))) |
---|
192 | (while (and rrest (not (equal elt (car rrest)))) |
---|
193 | (setq rest rrest |
---|
194 | rrest (cdr rrest))) |
---|
195 | (setcdr rest (cdr rrest)) |
---|
196 | list)))) |
---|
197 | |
---|
198 | (defun default-boundp (symbol) |
---|
199 | "Return t if SYMBOL has a non-void default value. |
---|
200 | This is the value that is seen in buffers that do not have their own values |
---|
201 | for this variable." |
---|
202 | (condition-case error |
---|
203 | (progn |
---|
204 | (default-value symbol) |
---|
205 | t) |
---|
206 | (void-variable nil))) |
---|
207 | |
---|
208 | ;;; @@ current-time. |
---|
209 | ;;; |
---|
210 | |
---|
211 | (defvar current-time-world-timezones |
---|
212 | '(("PST" . -800)("PDT" . -700)("MST" . -700) |
---|
213 | ("MDT" . -600)("CST" . -600)("CDT" . -500) |
---|
214 | ("EST" . -500)("EDT" . -400)("AST" . -400) |
---|
215 | ("NST" . -330)("UT" . +000)("GMT" . +000) |
---|
216 | ("BST" . +100)("MET" . +100)("EET" . +200) |
---|
217 | ("JST" . +900)("GMT+1" . +100)("GMT+2" . +200) |
---|
218 | ("GMT+3" . +300)("GMT+4" . +400)("GMT+5" . +500) |
---|
219 | ("GMT+6" . +600)("GMT+7" . +700)("GMT+8" . +800) |
---|
220 | ("GMT+9" . +900)("GMT+10" . +1000)("GMT+11" . +1100) |
---|
221 | ("GMT+12" . +1200)("GMT+13" . +1300)("GMT-1" . -100) |
---|
222 | ("GMT-2" . -200)("GMT-3" . -300)("GMT-4" . -400) |
---|
223 | ("GMT-5" . -500)("GMT-6" . -600)("GMT-7" . -700) |
---|
224 | ("GMT-8" . -800)("GMT-9" . -900)("GMT-10" . -1000) |
---|
225 | ("GMT-11" . -1100) ("GMT-12" . -1200)) |
---|
226 | "Time differentials of timezone from GMT in +-HHMM form. |
---|
227 | Used in `current-time-zone' (Emacs 19 emulating function by APEL).") |
---|
228 | |
---|
229 | (defvar current-time-local-timezone nil |
---|
230 | "*Local timezone name. |
---|
231 | Used in `current-time-zone' (Emacs 19 emulating function by APEL).") |
---|
232 | |
---|
233 | (defun set-time-zone-rule (tz) |
---|
234 | "Set the local time zone using TZ, a string specifying a time zone rule. |
---|
235 | If TZ is nil, use implementation-defined default time zone information. |
---|
236 | If TZ is t, use Universal Time." |
---|
237 | (cond |
---|
238 | ((stringp tz) |
---|
239 | (setq current-time-local-timezone tz)) |
---|
240 | (tz |
---|
241 | (setq current-time-local-timezone "GMT")) |
---|
242 | (t |
---|
243 | (setq current-time-local-timezone |
---|
244 | (with-temp-buffer |
---|
245 | ;; We use `date' command to get timezone information. |
---|
246 | (call-process "date" nil (current-buffer) t) |
---|
247 | (goto-char (point-min)) |
---|
248 | (if (looking-at |
---|
249 | "^.*\\([A-Z][A-Z][A-Z]\\([^ \n\t]*\\)\\).*$") |
---|
250 | (buffer-substring (match-beginning 1) |
---|
251 | (match-end 1)))))))) |
---|
252 | |
---|
253 | (defun current-time-zone (&optional specified-time) |
---|
254 | "Return the offset and name for the local time zone. |
---|
255 | This returns a list of the form (OFFSET NAME). |
---|
256 | OFFSET is an integer number of seconds ahead of UTC (east of Greenwich). |
---|
257 | A negative value means west of Greenwich. |
---|
258 | NAME is a string giving the name of the time zone. |
---|
259 | Optional argument SPECIFIED-TIME is ignored in this implementation. |
---|
260 | Some operating systems cannot provide all this information to Emacs; |
---|
261 | in this case, `current-time-zone' returns a list containing nil for |
---|
262 | the data it can't find." |
---|
263 | (let ((local-timezone (or current-time-local-timezone |
---|
264 | (progn |
---|
265 | (set-time-zone-rule nil) |
---|
266 | current-time-local-timezone))) |
---|
267 | timezone abszone seconds) |
---|
268 | (setq timezone |
---|
269 | (or (cdr (assoc (upcase local-timezone) |
---|
270 | current-time-world-timezones)) |
---|
271 | ;; "+900" style or nil. |
---|
272 | local-timezone)) |
---|
273 | (when timezone |
---|
274 | (if (stringp timezone) |
---|
275 | (setq timezone (string-to-int timezone))) |
---|
276 | ;; Taking account of minute in timezone. |
---|
277 | ;; HHMM -> MM |
---|
278 | (setq abszone (abs timezone)) |
---|
279 | (setq seconds (* 60 (+ (* 60 (/ abszone 100)) (% abszone 100)))) |
---|
280 | (list (if (< timezone 0) (- seconds) seconds) |
---|
281 | local-timezone)))) |
---|
282 | |
---|
283 | (or (fboundp 'si:current-time-string) |
---|
284 | (fset 'si:current-time-string (symbol-function 'current-time-string))) |
---|
285 | (defun current-time-string (&optional specified-time) |
---|
286 | "Return the current time, as a human-readable string. |
---|
287 | Programs can use this function to decode a time, |
---|
288 | since the number of columns in each field is fixed. |
---|
289 | The format is `Sun Sep 16 01:03:52 1973'. |
---|
290 | If an argument SPECIFIED-TIME is given, it specifies a time to format |
---|
291 | instead of the current time. The argument should have the form: |
---|
292 | (HIGH . LOW) |
---|
293 | or the form: |
---|
294 | (HIGH LOW . IGNORED). |
---|
295 | Thus, you can use times obtained from `current-time' |
---|
296 | and from `file-attributes'." |
---|
297 | (if (null specified-time) |
---|
298 | (si:current-time-string) |
---|
299 | (or (consp specified-time) |
---|
300 | (error "Wrong type argument %s" specified-time)) |
---|
301 | (let ((high (car specified-time)) |
---|
302 | (low (cdr specified-time)) |
---|
303 | (offset (or (car (current-time-zone)) 0)) |
---|
304 | (mdays '(31 28 31 30 31 30 31 31 30 31 30 31)) |
---|
305 | (mnames '("Jan" "Feb" "Mar" "Apr" "May" "Jun" |
---|
306 | "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")) |
---|
307 | (wnames '("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat")) |
---|
308 | days dd yyyy lyear mm HH MM SS) |
---|
309 | (if (consp low) |
---|
310 | (setq low (car low))) |
---|
311 | (or (integerp high) |
---|
312 | (error "Wrong type argument %s" high)) |
---|
313 | (or (integerp low) |
---|
314 | (error "Wrong type argument %s" low)) |
---|
315 | (setq low (+ low offset)) |
---|
316 | (while (> low 65535) |
---|
317 | (setq high (1+ high) |
---|
318 | low (- low 65536))) |
---|
319 | (setq yyyy 1970) |
---|
320 | (while (or (> high 481) |
---|
321 | (and (= high 481) |
---|
322 | (>= low 13184))) |
---|
323 | (if (and (> high 0) |
---|
324 | (< low 13184)) |
---|
325 | (setq high (1- high) |
---|
326 | low (+ 65536 low))) |
---|
327 | (setq high (- high 481) |
---|
328 | low (- low 13184)) |
---|
329 | (if (and (zerop (% yyyy 4)) |
---|
330 | (or (not (zerop (% yyyy 100))) |
---|
331 | (zerop (% yyyy 400)))) |
---|
332 | (progn |
---|
333 | (if (and (> high 0) |
---|
334 | (< low 20864)) |
---|
335 | (setq high (1- high) |
---|
336 | low (+ 65536 low))) |
---|
337 | (setq high (- high 1) |
---|
338 | low (- low 20864)))) |
---|
339 | (setq yyyy (1+ yyyy))) |
---|
340 | (setq dd 1) |
---|
341 | (while (or (> high 1) |
---|
342 | (and (= high 1) |
---|
343 | (>= low 20864))) |
---|
344 | (if (and (> high 0) |
---|
345 | (< low 20864)) |
---|
346 | (setq high (1- high) |
---|
347 | low (+ 65536 low))) |
---|
348 | (setq high (- high 1) |
---|
349 | low (- low 20864) |
---|
350 | dd (1+ dd))) |
---|
351 | (setq days dd) |
---|
352 | (if (= high 1) |
---|
353 | (setq low (+ 65536 low))) |
---|
354 | (setq mm 0) |
---|
355 | (setq lyear (and (zerop (% yyyy 4)) |
---|
356 | (or (not (zerop (% yyyy 100))) |
---|
357 | (zerop (% yyyy 400))))) |
---|
358 | (while (> (- dd (if (and lyear (= mm 1)) 29 (nth mm mdays))) 0) |
---|
359 | (setq dd (- dd (if (and lyear (= mm 1)) 29 (nth mm mdays)))) |
---|
360 | (setq mm (1+ mm))) |
---|
361 | (setq HH (/ low 3600) |
---|
362 | low (% low 3600) |
---|
363 | MM (/ low 60) |
---|
364 | SS (% low 60)) |
---|
365 | (format "%s %s %2d %02d:%02d:%02d %4d" |
---|
366 | (nth (% (+ days |
---|
367 | (- (+ (* (1- yyyy) 365) (/ (1- yyyy) 400) |
---|
368 | (/ (1- yyyy) 4)) (/ (1- yyyy) 100))) 7) |
---|
369 | wnames) |
---|
370 | (nth mm mnames) |
---|
371 | dd HH MM SS yyyy)))) |
---|
372 | |
---|
373 | (defun current-time () |
---|
374 | "Return the current time, as the number of seconds since 1970-01-01 00:00:00. |
---|
375 | The time is returned as a list of three integers. The first has the |
---|
376 | most significant 16 bits of the seconds, while the second has the |
---|
377 | least significant 16 bits. The third integer gives the microsecond |
---|
378 | count. |
---|
379 | |
---|
380 | The microsecond count is zero on systems that do not provide |
---|
381 | resolution finer than a second." |
---|
382 | (let* ((str (current-time-string)) |
---|
383 | (yyyy (string-to-int (substring str 20 24))) |
---|
384 | (mm (length (member (substring str 4 7) |
---|
385 | '("Dec" "Nov" "Oct" "Sep" "Aug" "Jul" |
---|
386 | "Jun" "May" "Apr" "Mar" "Feb" "Jan")))) |
---|
387 | (dd (string-to-int (substring str 8 10))) |
---|
388 | (HH (string-to-int (substring str 11 13))) |
---|
389 | (MM (string-to-int (substring str 14 16))) |
---|
390 | (SS (string-to-int (substring str 17 19))) |
---|
391 | (offset (or (car (current-time-zone)) 0)) |
---|
392 | dn ct1 ct2 i1 i2 |
---|
393 | year uru) |
---|
394 | (setq ct1 0 ct2 0 i1 0 i2 0) |
---|
395 | (setq year (- yyyy 1970)) |
---|
396 | (while (> year 0) |
---|
397 | (setq year (1- year) |
---|
398 | ct1 (+ ct1 481) |
---|
399 | ct2 (+ ct2 13184)) |
---|
400 | (while (> ct2 65535) |
---|
401 | (setq ct1 (1+ ct1) |
---|
402 | ct2 (- ct2 65536)))) |
---|
403 | (setq year (- yyyy 1)) |
---|
404 | (setq uru (- (+ (- (/ year 4) (/ year 100)) |
---|
405 | (/ year 400)) 477)) |
---|
406 | (while (> uru 0) |
---|
407 | (setq uru (1- uru) |
---|
408 | i1 (1+ i1) |
---|
409 | i2 (+ i2 20864)) |
---|
410 | (if (> i2 65535) |
---|
411 | (setq i1 (1+ i1) |
---|
412 | i2 (- i2 65536)))) |
---|
413 | (setq ct1 (+ ct1 i1) |
---|
414 | ct2 (+ ct2 i2)) |
---|
415 | (while (> ct2 65535) |
---|
416 | (setq ct1 (1+ ct1) |
---|
417 | ct2 (- ct2 65536))) |
---|
418 | (setq dn (+ dd (* 31 (1- mm)))) |
---|
419 | (if (> mm 2) |
---|
420 | (setq dn (+ (- dn (/ (+ 23 (* 4 mm)) 10)) |
---|
421 | (if (and (zerop (% yyyy 4)) |
---|
422 | (or (not (zerop (% yyyy 100))) |
---|
423 | (zerop (% yyyy 400)))) |
---|
424 | 1 0)))) |
---|
425 | (setq dn (1- dn) |
---|
426 | i1 0 |
---|
427 | i2 0) |
---|
428 | (while (> dn 0) |
---|
429 | (setq dn (1- dn) |
---|
430 | i1 (1+ i1) |
---|
431 | i2 (+ i2 20864)) |
---|
432 | (if (> i2 65535) |
---|
433 | (setq i1 (1+ i1) |
---|
434 | i2 (- i2 65536)))) |
---|
435 | (setq ct1 (+ (+ (+ ct1 i1) (/ ct2 65536)) |
---|
436 | (/ (+ (* HH 3600) (* MM 60) SS) |
---|
437 | 65536)) |
---|
438 | ct2 (+ (+ i2 (% ct2 65536)) |
---|
439 | (% (+ (* HH 3600) (* MM 60) SS) |
---|
440 | 65536))) |
---|
441 | (while (< (- ct2 offset) 0) |
---|
442 | (setq ct1 (1- ct1) |
---|
443 | ct2 (+ ct2 65536))) |
---|
444 | (setq ct2 (- ct2 offset)) |
---|
445 | (while (> ct2 65535) |
---|
446 | (setq ct1 (1+ ct1) |
---|
447 | ct2 (- ct2 65536))) |
---|
448 | (list ct1 ct2 0))) |
---|
449 | |
---|
450 | ;;; @@ Floating point numbers. |
---|
451 | ;;; |
---|
452 | |
---|
453 | (defun abs (arg) |
---|
454 | "Return the absolute value of ARG." |
---|
455 | (if (< arg 0) (- arg) arg)) |
---|
456 | |
---|
457 | (defun floor (arg &optional divisor) |
---|
458 | "Return the largest integer no grater than ARG. |
---|
459 | With optional DIVISOR, return the largest integer no greater than ARG/DIVISOR." |
---|
460 | (if (null divisor) |
---|
461 | (setq divisor 1)) |
---|
462 | (if (< arg 0) |
---|
463 | (- (/ (- divisor 1 arg) divisor)) |
---|
464 | (/ arg divisor))) |
---|
465 | |
---|
466 | ;;; @ Basic lisp subroutines. |
---|
467 | ;;; |
---|
468 | |
---|
469 | (defmacro lambda (&rest cdr) |
---|
470 | "Return a lambda expression. |
---|
471 | A call of the form (lambda ARGS DOCSTRING INTERACTIVE BODY) is |
---|
472 | self-quoting; the result of evaluating the lambda expression is the |
---|
473 | expression itself. The lambda expression may then be treated as a |
---|
474 | function, i.e., stored as the function value of a symbol, passed to |
---|
475 | funcall or mapcar, etc. |
---|
476 | |
---|
477 | ARGS should take the same form as an argument list for a `defun'. |
---|
478 | DOCSTRING is an optional documentation string. |
---|
479 | If present, it should describe how to call the function. |
---|
480 | But documentation strings are usually not useful in nameless functions. |
---|
481 | INTERACTIVE should be a call to the function `interactive', which see. |
---|
482 | It may also be omitted. |
---|
483 | BODY should be a list of lisp expressions." |
---|
484 | ;; Note that this definition should not use backquotes; subr.el should not |
---|
485 | ;; depend on backquote.el. |
---|
486 | (list 'function (cons 'lambda cdr))) |
---|
487 | |
---|
488 | (defun force-mode-line-update (&optional all) |
---|
489 | "Force the mode-line of the current buffer to be redisplayed. |
---|
490 | With optional non-nil ALL, force redisplay of all mode-lines." |
---|
491 | (if all (save-excursion (set-buffer (other-buffer)))) |
---|
492 | (set-buffer-modified-p (buffer-modified-p))) |
---|
493 | |
---|
494 | (defalias 'set-match-data 'store-match-data) |
---|
495 | |
---|
496 | (defvar save-match-data-internal) |
---|
497 | |
---|
498 | ;; We use save-match-data-internal as the local variable because |
---|
499 | ;; that works ok in practice (people should not use that variable elsewhere). |
---|
500 | (defmacro save-match-data (&rest body) |
---|
501 | "Execute the BODY forms, restoring the global value of the match data." |
---|
502 | (` (let ((save-match-data-internal (match-data))) |
---|
503 | (unwind-protect (progn (,@ body)) |
---|
504 | (set-match-data save-match-data-internal))))) |
---|
505 | |
---|
506 | |
---|
507 | ;;; @ Basic editing commands. |
---|
508 | ;;; |
---|
509 | |
---|
510 | ;; 18.55 does not have these variables. |
---|
511 | (defvar-maybe buffer-undo-list nil |
---|
512 | "List of undo entries in current buffer. |
---|
513 | APEL provides this as dummy for a compatibility.") |
---|
514 | |
---|
515 | (defvar-maybe auto-fill-function nil |
---|
516 | "Function called (if non-nil) to perform auto-fill. |
---|
517 | APEL provides this as dummy for a compatibility.") |
---|
518 | |
---|
519 | (defvar-maybe unread-command-event nil |
---|
520 | "APEL provides this as dummy for a compatibility.") |
---|
521 | (defvar-maybe unread-command-events nil |
---|
522 | "List of events to be read as the command input. |
---|
523 | APEL provides this as dummy for a compatibility.") |
---|
524 | |
---|
525 | ;; (defvar-maybe minibuffer-setup-hook nil |
---|
526 | ;; "Normal hook run just after entry to minibuffer.") |
---|
527 | ;; (defvar-maybe minibuffer-exit-hook nil |
---|
528 | ;; "Normal hook run just after exit from minibuffer.") |
---|
529 | |
---|
530 | (defvar-maybe minor-mode-map-alist nil |
---|
531 | "Alist of keymaps to use for minor modes. |
---|
532 | APEL provides this as dummy for a compatibility.") |
---|
533 | |
---|
534 | (defalias 'insert-and-inherit 'insert) |
---|
535 | (defalias 'insert-before-markers-and-inherit 'insert-before-markers) |
---|
536 | (defalias 'number-to-string 'int-to-string) |
---|
537 | |
---|
538 | (defun generate-new-buffer-name (name &optional ignore) |
---|
539 | "Return a string that is the name of no existing buffer based on NAME. |
---|
540 | If there is no live buffer named NAME, then return NAME. |
---|
541 | Otherwise modify name by appending `<NUMBER>', incrementing NUMBER |
---|
542 | until an unused name is found, and then return that name. |
---|
543 | Optional second argument IGNORE specifies a name that is okay to use |
---|
544 | \(if it is in the sequence to be tried\) |
---|
545 | even if a buffer with that name exists." |
---|
546 | (if (get-buffer name) |
---|
547 | (let ((n 2) new) |
---|
548 | (while (get-buffer (setq new (format "%s<%d>" name n))) |
---|
549 | (setq n (1+ n))) |
---|
550 | new) |
---|
551 | name)) |
---|
552 | |
---|
553 | (or (fboundp 'si:mark) |
---|
554 | (fset 'si:mark (symbol-function 'mark))) |
---|
555 | (defun mark (&optional force) |
---|
556 | (si:mark)) |
---|
557 | |
---|
558 | (defun-maybe window-minibuffer-p (&optional window) |
---|
559 | "Return non-nil if WINDOW is a minibuffer window." |
---|
560 | (eq (or window (selected-window)) (minibuffer-window))) |
---|
561 | |
---|
562 | (defun-maybe window-live-p (obj) |
---|
563 | "Returns t if OBJECT is a window which is currently visible." |
---|
564 | (and (windowp obj) |
---|
565 | (or (eq obj (minibuffer-window)) |
---|
566 | (eq obj (get-buffer-window (window-buffer obj)))))) |
---|
567 | |
---|
568 | ;; Add optinal argument `hist' |
---|
569 | (or (fboundp 'si:read-from-minibuffer) |
---|
570 | (progn |
---|
571 | (fset 'si:read-from-minibuffer (symbol-function 'read-from-minibuffer)) |
---|
572 | (defun read-from-minibuffer (prompt &optional |
---|
573 | initial-contents keymap read hist) |
---|
574 | |
---|
575 | "Read a string from the minibuffer, prompting with string PROMPT. |
---|
576 | If optional second arg INITIAL-CONTENTS is non-nil, it is a string |
---|
577 | to be inserted into the minibuffer before reading input. |
---|
578 | If INITIAL-CONTENTS is (STRING . POSITION), the initial input |
---|
579 | is STRING, but point is placed at position POSITION in the minibuffer. |
---|
580 | Third arg KEYMAP is a keymap to use whilst reading; |
---|
581 | if omitted or nil, the default is `minibuffer-local-map'. |
---|
582 | If fourth arg READ is non-nil, then interpret the result as a lisp object |
---|
583 | and return that object: |
---|
584 | in other words, do `(car (read-from-string INPUT-STRING))' |
---|
585 | Fifth arg HIST is ignored in this implementatin." |
---|
586 | (si:read-from-minibuffer prompt initial-contents keymap read)))) |
---|
587 | |
---|
588 | ;; Add optional argument `frame'. |
---|
589 | (or (fboundp 'si:get-buffer-window) |
---|
590 | (progn |
---|
591 | (fset 'si:get-buffer-window (symbol-function 'get-buffer-window)) |
---|
592 | (defun get-buffer-window (buffer &optional frame) |
---|
593 | "Return a window currently displaying BUFFER, or nil if none. |
---|
594 | Optional argunemt FRAME is ignored in this implementation." |
---|
595 | (si:get-buffer-window buffer)))) |
---|
596 | |
---|
597 | (defun-maybe walk-windows (proc &optional minibuf all-frames) |
---|
598 | "Cycle through all visible windows, calling PROC for each one. |
---|
599 | PROC is called with a window as argument. |
---|
600 | |
---|
601 | Optional second arg MINIBUF t means count the minibuffer window even |
---|
602 | if not active. MINIBUF nil or omitted means count the minibuffer iff |
---|
603 | it is active. MINIBUF neither t nor nil means not to count the |
---|
604 | minibuffer even if it is active. |
---|
605 | Optional third argunemt ALL-FRAMES is ignored in this implementation." |
---|
606 | (if (window-minibuffer-p (selected-window)) |
---|
607 | (setq minibuf t)) |
---|
608 | (let* ((walk-windows-start (selected-window)) |
---|
609 | (walk-windows-current walk-windows-start)) |
---|
610 | (unwind-protect |
---|
611 | (while (progn |
---|
612 | (setq walk-windows-current |
---|
613 | (next-window walk-windows-current minibuf)) |
---|
614 | (funcall proc walk-windows-current) |
---|
615 | (not (eq walk-windows-current walk-windows-start)))) |
---|
616 | (select-window walk-windows-start)))) |
---|
617 | |
---|
618 | (defun buffer-disable-undo (&optional buffer) |
---|
619 | "Make BUFFER stop keeping undo information. |
---|
620 | No argument or nil as argument means do this for the current buffer." |
---|
621 | (buffer-flush-undo (or buffer (current-buffer)))) |
---|
622 | |
---|
623 | |
---|
624 | ;;; @@ Frame (Emacs 18 cannot make frame) |
---|
625 | ;;; |
---|
626 | ;; The following four are frequently used for manupulating the current frame. |
---|
627 | ;; frame.el has `screen-width', `screen-height', `set-screen-width' and |
---|
628 | ;; `set-screen-height' for backward compatibility and declare them as obsolete. |
---|
629 | (defun frame-width (&optional frame) |
---|
630 | "Return number of columns available for display on FRAME. |
---|
631 | If FRAME is omitted, describe the currently selected frame." |
---|
632 | (screen-width)) |
---|
633 | |
---|
634 | (defun frame-height (&optional frame) |
---|
635 | "Return number of lines available for display on FRAME. |
---|
636 | If FRAME is omitted, describe the currently selected frame." |
---|
637 | (screen-height)) |
---|
638 | |
---|
639 | (defun set-frame-width (frame cols &optional pretend) |
---|
640 | "Specify that the frame FRAME has COLS columns. |
---|
641 | Optional third arg non-nil means that redisplay should use COLS columns |
---|
642 | but that the idea of the actual width of the frame should not be changed." |
---|
643 | (set-screen-width cols pretend)) |
---|
644 | |
---|
645 | (defun set-frame-height (frame lines &optional pretend) |
---|
646 | "Specify that the frame FRAME has LINES lines. |
---|
647 | Optional third arg non-nil means that redisplay should use LINES lines |
---|
648 | but that the idea of the actual height of the frame should not be changed." |
---|
649 | (set-screen-height lines pretend)) |
---|
650 | |
---|
651 | ;;; @@ Environment variables. |
---|
652 | ;;; |
---|
653 | |
---|
654 | (autoload 'setenv "env" |
---|
655 | "Set the value of the environment variable named VARIABLE to VALUE. |
---|
656 | VARIABLE should be a string. VALUE is optional; if not provided or is |
---|
657 | `nil', the environment variable VARIABLE will be removed. |
---|
658 | This function works by modifying `process-environment'." |
---|
659 | t) |
---|
660 | |
---|
661 | |
---|
662 | ;;; @ File input and output commands. |
---|
663 | ;;; |
---|
664 | |
---|
665 | (defvar data-directory exec-directory) |
---|
666 | |
---|
667 | ;; In 18.55, `call-process' does not return exit status. |
---|
668 | (defun file-executable-p (filename) |
---|
669 | "Return t if FILENAME can be executed by you. |
---|
670 | For a directory, this means you can access files in that directory." |
---|
671 | (if (file-exists-p filename) |
---|
672 | (let ((process (start-process "test" nil "test" "-x" filename))) |
---|
673 | (while (eq 'run (process-status process))) |
---|
674 | (zerop (process-exit-status process))))) |
---|
675 | |
---|
676 | (defun make-directory-internal (dirname) |
---|
677 | "Create a directory. One argument, a file name string." |
---|
678 | (let ((dir (expand-file-name dirname))) |
---|
679 | (if (file-exists-p dir) |
---|
680 | (error "Creating directory: %s is already exist" dir) |
---|
681 | (call-process "mkdir" nil nil nil dir)))) |
---|
682 | |
---|
683 | (defun make-directory (dir &optional parents) |
---|
684 | "Create the directory DIR and any nonexistent parent dirs. |
---|
685 | The second (optional) argument PARENTS says whether |
---|
686 | to create parent directories if they don't exist." |
---|
687 | (let ((len (length dir)) |
---|
688 | (p 0) p1 path) |
---|
689 | (catch 'tag |
---|
690 | (while (and (< p len) (string-match "[^/]*/?" dir p)) |
---|
691 | (setq p1 (match-end 0)) |
---|
692 | (if (= p1 len) |
---|
693 | (throw 'tag nil)) |
---|
694 | (setq path (substring dir 0 p1)) |
---|
695 | (if (not (file-directory-p path)) |
---|
696 | (cond ((file-exists-p path) |
---|
697 | (error "Creating directory: %s is not directory" path)) |
---|
698 | ((null parents) |
---|
699 | (error "Creating directory: %s is not exist" path)) |
---|
700 | (t |
---|
701 | (make-directory-internal path)))) |
---|
702 | (setq p p1))) |
---|
703 | (make-directory-internal dir))) |
---|
704 | |
---|
705 | (defun parse-colon-path (cd-path) |
---|
706 | "Explode a colon-separated list of paths into a string list." |
---|
707 | (and cd-path |
---|
708 | (let (cd-prefix cd-list (cd-start 0) cd-colon) |
---|
709 | (setq cd-path (concat cd-path path-separator)) |
---|
710 | (while (setq cd-colon (string-match path-separator cd-path cd-start)) |
---|
711 | (setq cd-list |
---|
712 | (nconc cd-list |
---|
713 | (list (if (= cd-start cd-colon) |
---|
714 | nil |
---|
715 | (substitute-in-file-name |
---|
716 | (file-name-as-directory |
---|
717 | (substring cd-path cd-start cd-colon))))))) |
---|
718 | (setq cd-start (+ cd-colon 1))) |
---|
719 | cd-list))) |
---|
720 | |
---|
721 | (defun file-relative-name (filename &optional directory) |
---|
722 | "Convert FILENAME to be relative to DIRECTORY (default: default-directory)." |
---|
723 | (setq filename (expand-file-name filename) |
---|
724 | directory (file-name-as-directory (expand-file-name |
---|
725 | (or directory default-directory)))) |
---|
726 | (let ((ancestor "")) |
---|
727 | (while (not (string-match (concat "^" (regexp-quote directory)) filename)) |
---|
728 | (setq directory (file-name-directory (substring directory 0 -1)) |
---|
729 | ancestor (concat "../" ancestor))) |
---|
730 | (concat ancestor (substring filename (match-end 0))))) |
---|
731 | |
---|
732 | (or (fboundp 'si:directory-files) |
---|
733 | (fset 'si:directory-files (symbol-function 'directory-files))) |
---|
734 | (defun directory-files (directory &optional full match nosort) |
---|
735 | "Return a list of names of files in DIRECTORY. |
---|
736 | There are three optional arguments: |
---|
737 | If FULL is non-nil, return absolute file names. Otherwise return names |
---|
738 | that are relative to the specified directory. |
---|
739 | If MATCH is non-nil, mention only file names that match the regexp MATCH. |
---|
740 | If NOSORT is dummy for compatibility." |
---|
741 | (si:directory-files directory full match)) |
---|
742 | |
---|
743 | ;;; @ Process. |
---|
744 | ;;; |
---|
745 | (or (fboundp 'si:accept-process-output) |
---|
746 | (progn |
---|
747 | (fset 'si:accept-process-output (symbol-function 'accept-process-output)) |
---|
748 | (defun accept-process-output (&optional process timeout timeout-msecs) |
---|
749 | "Allow any pending output from subprocesses to be read by Emacs. |
---|
750 | It is read into the process' buffers or given to their filter functions. |
---|
751 | Non-nil arg PROCESS means do not return until some output has been received |
---|
752 | from PROCESS. Nil arg PROCESS means do not return until some output has |
---|
753 | been received from any process. |
---|
754 | TIMEOUT and TIMEOUT-MSECS are ignored in this implementation." |
---|
755 | (si:accept-process-output process)))) |
---|
756 | |
---|
757 | ;;; @ Text property. |
---|
758 | ;;; |
---|
759 | |
---|
760 | ;; In Emacs 20.4, these functions are defined in src/textprop.c. |
---|
761 | (defun text-properties-at (position &optional object)) |
---|
762 | (defun get-text-property (position prop &optional object)) |
---|
763 | (defun get-char-property (position prop &optional object)) |
---|
764 | (defun next-property-change (position &optional object limit)) |
---|
765 | (defun next-single-property-change (position prop &optional object limit)) |
---|
766 | (defun previous-property-change (position &optional object limit)) |
---|
767 | (defun previous-single-property-change (position prop &optional object limit)) |
---|
768 | (defun add-text-properties (start end properties &optional object)) |
---|
769 | (defun put-text-property (start end property value &optional object)) |
---|
770 | (defun set-text-properties (start end properties &optional object)) |
---|
771 | (defun remove-text-properties (start end properties &optional object)) |
---|
772 | (defun text-property-any (start end property value &optional object)) |
---|
773 | (defun text-property-not-all (start end property value &optional object)) |
---|
774 | ;; the following two functions are new in v20. |
---|
775 | (defun next-char-property-change (position &optional object)) |
---|
776 | (defun previous-char-property-change (position &optional object)) |
---|
777 | ;; the following two functions are obsolete. |
---|
778 | ;; (defun erase-text-properties (start end &optional object) |
---|
779 | ;; (defun copy-text-properties (start end src pos dest &optional prop) |
---|
780 | |
---|
781 | |
---|
782 | ;;; @ Overlay. |
---|
783 | ;;; |
---|
784 | |
---|
785 | (defun overlayp (object)) |
---|
786 | (defun make-overlay (beg end &optional buffer front-advance rear-advance)) |
---|
787 | (defun move-overlay (overlay beg end &optional buffer)) |
---|
788 | (defun delete-overlay (overlay)) |
---|
789 | (defun overlay-start (overlay)) |
---|
790 | (defun overlay-end (overlay)) |
---|
791 | (defun overlay-buffer (overlay)) |
---|
792 | (defun overlay-properties (overlay)) |
---|
793 | (defun overlays-at (pos)) |
---|
794 | (defun overlays-in (beg end)) |
---|
795 | (defun next-overlay-change (pos)) |
---|
796 | (defun previous-overlay-change (pos)) |
---|
797 | (defun overlay-lists ()) |
---|
798 | (defun overlay-recenter (pos)) |
---|
799 | (defun overlay-get (overlay prop)) |
---|
800 | (defun overlay-put (overlay prop value)) |
---|
801 | |
---|
802 | ;;; @ End. |
---|
803 | ;;; |
---|
804 | |
---|
805 | (require 'product) |
---|
806 | (product-provide (provide 'poe-18) (require 'apel-ver)) |
---|
807 | |
---|
808 | ;;; poe-18.el ends here |
---|