diff lisp/hyperbole/hypb.el @ 171:929b76928fce r20-3b12

Import from CVS: tag r20-3b12
author cvs
date Mon, 13 Aug 2007 09:47:52 +0200
parents cf808b4c4290
children
line wrap: on
line diff
--- a/lisp/hyperbole/hypb.el	Mon Aug 13 09:47:00 2007 +0200
+++ b/lisp/hyperbole/hypb.el	Mon Aug 13 09:47:52 2007 +0200
@@ -227,8 +227,22 @@
 	      ((subrp func) (error "(hypb:function-copy): `%s' is a primitive; can't copy body."
 				   func-symbol))
 	      ((and (hypb:v19-byte-code-p func) (fboundp 'make-byte-code))
-	       (let ((new-code (append func nil))) ; turn it into a list
-		 (apply 'make-byte-code new-code)))
+	       (if (not (fboundp 'compiled-function-arglist))
+		   ;; This is evil -slb
+		   (let ((new-code (append func nil))) ; turn it into a list
+		     (apply 'make-byte-code new-code))
+		 ;; Can't reference bytecode objects as vectors in modern
+		 ;; XEmacs.
+		 (let ((new-code (nconc
+				  (list (compiled-function-arglist func)
+					(compiled-function-instructions func)
+					(compiled-function-constants func)
+					(compiled-function-stack-depth func)
+					(compiled-function-doc-string func))))
+		       spec)
+		   (if (setq spec (compiled-function-interactive func))
+		       (setq new-code (nconc new-code (list (nth 1 spec)))))
+		   (apply 'make-byte-code new-code))))
 	      (t (error "(hypb:function-copy): Can't copy function body: %s" func))
 	      ))
     (error "(hypb:function-copy): `%s' symbol is not bound to a function."
@@ -261,6 +275,7 @@
 		  (append new-forms old-func-call)
 		(append old-func-call new-forms)))))))
 
+;; #### FIXME -- This code is highly broken in XEmacs 20.3
 (defun hypb:function-symbol-replace (func-sym sym-to-replace replace-with-sym)
   "Replaces in body of FUNC-SYM SYM-TO-REPLACE with REPLACE-WITH-SYM.
 All occurrences within lists are replaced.  Returns body of modified FUNC-SYM."
@@ -277,7 +292,9 @@
 					arg-vector)))
 			       body))))
       ;; assume V19 byte compiler   (eq (compiled-function-p body) t)
-      (setq arg (aref body 2)
+      (setq arg (if (fboundp 'compiled-function-arglist)
+		    (compiled-function-arglist body)
+		  (aref body 2))
 	    arg-vector (if (vectorp arg) arg))
       )
     (if arg-vector