Mercurial > hg > xemacs-beta

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

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-3b12
author cvs
date Mon, 13 Aug 2007 09:47:52 +0200
parents cf808b4c4290
children
comparison
equal deleted inserted replaced
170:98a42ee61975 171:929b76928fce
225 (let ((func (hypb:indirect-function func-symbol))) 225 (let ((func (hypb:indirect-function func-symbol)))
226 (cond ((listp func) (copy-sequence func)) 226 (cond ((listp func) (copy-sequence func))
227 ((subrp func) (error "(hypb:function-copy): `%s' is a primitive; can't copy body." 227 ((subrp func) (error "(hypb:function-copy): `%s' is a primitive; can't copy body."
228 func-symbol)) 228 func-symbol))
229 ((and (hypb:v19-byte-code-p func) (fboundp 'make-byte-code)) 229 ((and (hypb:v19-byte-code-p func) (fboundp 'make-byte-code))
230 (let ((new-code (append func nil))) ; turn it into a list 230 (if (not (fboundp 'compiled-function-arglist))
231 (apply 'make-byte-code new-code))) 231 ;; This is evil -slb
232 (let ((new-code (append func nil))) ; turn it into a list
233 (apply 'make-byte-code new-code))
234 ;; Can't reference bytecode objects as vectors in modern
235 ;; XEmacs.
236 (let ((new-code (nconc
237 (list (compiled-function-arglist func)
238 (compiled-function-instructions func)
239 (compiled-function-constants func)
240 (compiled-function-stack-depth func)
241 (compiled-function-doc-string func))))
242 spec)
243 (if (setq spec (compiled-function-interactive func))
244 (setq new-code (nconc new-code (list (nth 1 spec)))))
245 (apply 'make-byte-code new-code))))
232 (t (error "(hypb:function-copy): Can't copy function body: %s" func)) 246 (t (error "(hypb:function-copy): Can't copy function body: %s" func))
233 )) 247 ))
234 (error "(hypb:function-copy): `%s' symbol is not bound to a function." 248 (error "(hypb:function-copy): `%s' symbol is not bound to a function."
235 func-symbol))) 249 func-symbol)))
236 250
259 (action:commandp old-func-sym))) 273 (action:commandp old-func-sym)))
260 (if prepend 274 (if prepend
261 (append new-forms old-func-call) 275 (append new-forms old-func-call)
262 (append old-func-call new-forms))))))) 276 (append old-func-call new-forms)))))))
263 277
278 ;; #### FIXME -- This code is highly broken in XEmacs 20.3
264 (defun hypb:function-symbol-replace (func-sym sym-to-replace replace-with-sym) 279 (defun hypb:function-symbol-replace (func-sym sym-to-replace replace-with-sym)
265 "Replaces in body of FUNC-SYM SYM-TO-REPLACE with REPLACE-WITH-SYM. 280 "Replaces in body of FUNC-SYM SYM-TO-REPLACE with REPLACE-WITH-SYM.
266 All occurrences within lists are replaced. Returns body of modified FUNC-SYM." 281 All occurrences within lists are replaced. Returns body of modified FUNC-SYM."
267 (let ((body (hypb:indirect-function func-sym)) 282 (let ((body (hypb:indirect-function func-sym))
268 (arg-vector) (arg)) 283 (arg-vector) (arg))
275 (and (listp elt) 290 (and (listp elt)
276 (vectorp (setq arg-vector (nth 2 elt))) 291 (vectorp (setq arg-vector (nth 2 elt)))
277 arg-vector))) 292 arg-vector)))
278 body)))) 293 body))))
279 ;; assume V19 byte compiler (eq (compiled-function-p body) t) 294 ;; assume V19 byte compiler (eq (compiled-function-p body) t)
280 (setq arg (aref body 2) 295 (setq arg (if (fboundp 'compiled-function-arglist)
296 (compiled-function-arglist body)
297 (aref body 2))
281 arg-vector (if (vectorp arg) arg)) 298 arg-vector (if (vectorp arg) arg))
282 ) 299 )
283 (if arg-vector 300 (if arg-vector
284 ;; Code is byte-compiled. 301 ;; Code is byte-compiled.
285 (let ((i (1- (length arg-vector)))) 302 (let ((i (1- (length arg-vector))))