X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/c9411d2f035ff9aa297aa53f8abf5337186e9a57..09c774f7137ab0efacf7858ba4ccd454a7c72bed:/lisp/emacs-lisp/lucid.el

diff --git a/lisp/emacs-lisp/lucid.el b/lisp/emacs-lisp/lucid.el
index 80c5973046..80e5ef330d 100644
--- a/lisp/emacs-lisp/lucid.el
+++ b/lisp/emacs-lisp/lucid.el
@@ -1,6 +1,9 @@
-;;; 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.
 
@@ -19,35 +22,21 @@
 ;; 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.
@@ -58,30 +47,19 @@ If your code does that, modify it to make a vector containing the event
 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.
@@ -132,17 +110,48 @@ bottom of the buffer stack."
 		      (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)
 
+
+;; 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))
+(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))
@@ -197,6 +206,9 @@ bottom of the buffer stack."
 (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))
@@ -251,4 +263,5 @@ bottom of the buffer stack."
 
 (provide 'lucid)
 
-;;; end of lucid.el
+;;; arch-tag: 80f9ab46-0b36-4151-86ed-3edb6d449c9e
+;;; lucid.el ends here