From: shuhei <shuhei>
Date: Sun, 5 Dec 1999 03:43:29 +0000 (+0000)
Subject: (byte-code-function-p): Docstring sync.
X-Git-Tag: apel-shubit-10_0~13
X-Git-Url: http://git.chise.org/gitweb/?a=commitdiff_plain;h=ee45c29a87d00228a305836224d3d7a40eb3dbe0;p=elisp%2Fapel.git

(byte-code-function-p): Docstring sync.
(cyclic-function-indirection): New error symbol.
(indirect-function): New function; use above symbol.
---

diff --git a/ChangeLog b/ChangeLog
index 7c325c8..3e81865 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+1999-12-05  Shuhei KOBAYASHI  <shuhei@aqua.ocn.ne.jp>
+
+	* poe-18.el (byte-code-function-p): Docstring sync.
+	(cyclic-function-indirection): New error symbol.
+	(indirect-function): New function; use above symbol.
+
 1999-11-30  Shuhei KOBAYASHI  <shuhei@aqua.ocn.ne.jp>
 
 	* poe-18.el (current-time-string): New local variable `lyear'
diff --git a/poe-18.el b/poe-18.el
index f2fb629..f8c62ee 100644
--- a/poe-18.el
+++ b/poe-18.el
@@ -56,10 +56,10 @@
 Associates the function with the current load file, if any."
   (fset sym newdef))
 
-(defun byte-code-function-p (exp)
-  "T if OBJECT is a byte-compiled function object."
-  (and (consp exp)
-       (let ((rest (cdr (cdr exp)))
+(defun byte-code-function-p (object)
+  "Return t if OBJECT is a byte-compiled function object."
+  (and (consp object)
+       (let ((rest (cdr (cdr object)))
 	     elt)
 	 (if (stringp (car rest))
 	     (setq rest (cdr rest)))
@@ -71,6 +71,41 @@ Associates the function with the current load file, if any."
 		 (throw 'tag t))
 	     (setq rest (cdr rest)))))))
 
+;; (symbol-plist 'cyclic-function-indirection)
+(put 'cyclic-function-indirection
+     'error-conditions
+     '(cyclic-function-indirection error)
+(put 'cyclic-function-indirection
+     'error-message
+     "Symbol's chain of function indirections contains a loop")
+
+;; The following function definition is a direct translation of its
+;; C definition in emacs-20.4/src/data.c.
+(defun indirect-function (object)
+  "Return the function at the end of OBJECT's function chain.
+If OBJECT is a symbol, follow all function indirections and return the final
+function binding.
+If OBJECT is not a symbol, just return it.
+Signal a void-function error if the final symbol is unbound.
+Signal a cyclic-function-indirection error if there is a loop in the
+function chain of symbols."
+  (let* ((hare object)
+         (tortoise hare))
+    (catch 'found
+      (while t
+        (or (symbolp hare) (throw 'found hare))
+        (or (fboundp hare) (signal 'void-function (cons object nil)))
+        (setq hare (symbol-function hare))
+        (or (symbolp hare) (throw 'found hare))
+        (or (fboundp hare) (signal 'void-function (cons object nil)))
+        (setq hare (symbol-function hare))
+
+        (setq tortoise (symbol-function tortoise))
+
+        (if (eq hare tortoise)
+            (signal 'cyclic-function-indirection (cons object nil)))))
+    hare))
+
 ;;; 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.)