-;;; lucid.el --- Emulate some Lucid Emacs functions.
+;;; lucid.el --- emulate some Lucid Emacs functions
-;; Copyright (C) 1993, 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 1995, 2001 Free Software Foundation, Inc.
+
+;; Maintainer: FSF
+;; Keywords: emulations
;; This file is part of GNU Emacs.
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
+;;; Commentary:
+
;;; Code:
-(defun copy-tree (tree)
- (if (consp tree)
- (cons (copy-tree (car tree))
- (copy-tree (cdr tree)))
- (if (vectorp tree)
- (let* ((new (copy-sequence tree))
- (i (1- (length new))))
- (while (>= i 0)
- (aset new i (copy-tree (aref new i)))
- (setq i (1- i)))
- new)
- tree)))
+;; XEmacs autoloads CL so we might as well make use of it.
+(require 'cl)
(defalias 'current-time-seconds 'current-time)
-(defun remprop (symbol prop)
- (let ((plist (symbol-plist symbol)))
- (while (eq (car plist) prop)
- (setplist symbol (setq plist (cdr (cdr plist)))))
- (while plist
- (if (eq (nth 2 plist) prop)
- (setcdr (cdr plist) (nthcdr 4 plist)))
- (setq plist (cdr (cdr plist))))))
+;; In case cl-map-keymap is an alias for map-keymap, avoid circular calls.
+(fset 'cl-map-keymap (indirect-function 'cl-map-keymap))
(defun map-keymap (function keymap &optional sort-first)
"Call FUNCTION for every binding in KEYMAP.
-This includes bindings inherited from a parent keymap.
+This does not include bindings inherited from a parent keymap.
FUNCTION receives two arguments each time it is called:
the character (more generally, the event type) that is bound,
and the binding it has.
type that you get. That will work in both versions of Emacs."
(if sort-first
(let (list)
- (map-keymap (function (lambda (a b)
- (setq list (cons (cons a b) list))))
- keymap)
+ (cl-map-keymap (lambda (a b) (push (cons a b) list))
+ keymap)
(setq list (sort list
- (function (lambda (a b)
- (setq a (car a) b (car b))
- (if (integerp a)
- (if (integerp b) (< a b)
- t)
- (if (integerp b) t
- (string< a b)))))))
- (while list
- (funcall function (car (car list)) (cdr (car list)))
- (setq list (cdr list))))
- (while (consp keymap)
- (if (consp (car keymap))
- (funcall function (car (car keymap)) (cdr (car keymap)))
- (if (vectorp (car keymap))
- (let ((i (1- (length (car keymap))))
- (vector (car keymap)))
- (while (>= i 0)
- (funcall function i (aref vector i))
- (setq i (1- i))))))
- (setq keymap (cdr keymap)))))
+ (lambda (a b)
+ (setq a (car a) b (car b))
+ (if (integerp a)
+ (if (integerp b) (< a b)
+ t)
+ (if (integerp b) t
+ (string< a b))))))
+ (dolist (p list)
+ (funcall function (car p) (cdr p))))
+ (cl-map-keymap function keymap)))
(defun read-number (prompt &optional integers-only)
"Read a number from the minibuffer.
(list buf)))
(buffer-list)))))))
+(defun device-class (&optional device)
+ "Return the class (color behavior) of DEVICE.
+This will be one of 'color, 'grayscale, or 'mono.
+This function exists for compatibility with XEmacs."
+ (cond
+ ((display-color-p device) 'color)
+ ((display-grayscale-p device) 'grayscale)
+ (t 'mono)))
+
(defalias 'find-face 'internal-find-face)
(defalias 'get-face 'internal-get-face)
(defalias 'try-face-font 'internal-try-face-font)
(defalias 'exec-to-string 'shell-command-to-string)
\f
+
+;; Buffer context
+
+(defun buffer-syntactic-context (&optional buffer)
+ "Syntactic context at point in BUFFER.
+Either of `string', `comment' or nil.
+This is an XEmacs compatibility function."
+ (with-current-buffer (or buffer (current-buffer))
+ (let ((state (syntax-ppss (point))))
+ (cond
+ ((nth 3 state) 'string)
+ ((nth 4 state) 'comment)))))
+
+
+(defun buffer-syntactic-context-depth (&optional buffer)
+ "Syntactic parenthesis depth at point in BUFFER.
+This is an XEmacs compatibility function."
+ (with-current-buffer (or buffer (current-buffer))
+ (nth 0 (syntax-ppss (point)))))
+
+
+;; Extents
(defun make-extent (beg end &optional buffer)
(make-overlay beg end buffer))
+(defun extent-properties (extent) (overlay-properties extent))
+(unless (fboundp 'extent-property) (defalias 'extent-property 'overlay-get))
+
+(defun extent-at (pos &optional object property before)
+ (with-current-buffer (or object (current-buffer))
+ (let ((overlays (overlays-at pos)))
+ (when property
+ (let (filtered)
+ (while overlays
+ (if (overlay-get (car overlays) property)
+ (setq filtered (cons (car overlays) filtered)))
+ (setq overlays (cdr overlays)))
+ (setq overlays filtered)))
+ (setq overlays
+ (sort overlays
+ (function (lambda (o1 o2)
+ (let ((p1 (or (overlay-get o1 'priority) 0))
+ (p2 (or (overlay-get o2 'priority) 0)))
+ (or (> p1 p2)
+ (and (= p1 p2)
+ (> (overlay-start o1) (overlay-start o2)))))))))
+ (if before
+ (nth 1 (memq before overlays))
+ (car overlays)))))
+
(defun set-extent-property (extent prop value)
+ ;; Make sure that separate adjacent extents
+ ;; with the same mouse-face value
+ ;; do not run together as one extent.
+ (and (eq prop 'mouse-face)
+ (symbolp value)
+ (setq value (list value)))
(if (eq prop 'duplicable)
(cond ((and value (not (overlay-get extent prop)))
;; If becoming duplicable, copy all overlayprops to text props.
(defun set-extent-face (extent face)
(set-extent-property extent 'face face))
+(defun set-extent-end-glyph (extent glyph)
+ (set-extent-property extent 'after-string glyph))
+
(defun delete-extent (extent)
(set-extent-property extent 'duplicable nil)
(delete-overlay extent))
(provide 'lucid)
-;;; end of lucid.el
+;;; arch-tag: 80f9ab46-0b36-4151-86ed-3edb6d449c9e
+;;; lucid.el ends here