Mercurial > hg > xemacs
diff shared/repl-comment.el @ 0:107d592c5f4a
DICE versions, used by pers/common, recursive, I think/hope
author | Henry S. Thompson <ht@inf.ed.ac.uk> |
---|---|
date | Mon, 08 Feb 2021 11:44:37 +0000 |
parents | |
children |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/shared/repl-comment.el Mon Feb 08 11:44:37 2021 +0000 @@ -0,0 +1,59 @@ +;; Universal (?) replace comment in function + +;; Last edited: Thu Oct 7 09:39:50 1993 +(defun repl-comment (fn comment) + "replace/install as FN's comment COMMENT, no matter what emacs/compiler" + (let ((defn (symbol-function fn))) + (if (consp defn) + (if (eq (car defn) 'autoload) + (progn (load-library (car (cdr defn))) + (if (equal defn (symbol-function fn)) + (error "autoloading didn't help define %s" fn) + (repl-comment fn comment))) + ;; either symbolic or old byte-compiler + (if (eq (car defn) 'lambda) + (if (stringp (car (cdr (cdr defn)))) + (rplaca (cdr (cdr defn)) + comment) + (rplacd (cdr defn) + (cons comment + (cdr (cdr defn))))) + (error "can't diagnose defn %s" defn))) + ;; array or not + (if (compiled-function-p defn) + (fset fn (if (fboundp 'compiled-function-arglist) + (progn (make-byte-code + (compiled-function-arglist defn) + (compiled-function-instructions defn) + (compiled-function-constants defn) + (compiled-function-stack-depth defn) + comment + (compiled-function-interactive defn)) defn) + (repl-byte fn (list (cons 4 comment))))) + (error "unrecognised defn %s" defn))))) + +(defun repl-byte (fn alist) + "compute a new byte-code defn for FN, replacing +elements using ALIST, which is interpreted as (index . newbit). +Elements are 0: arglist 1: byte-codes 2: symbols 3: stack-depth 4: comment" + (let + ((defn (symbol-function fn))) + (let ((ln (if (sequencep defn) + (length defn) + ;; hack otherwise + 6)) + (i 0) + new entry) + (apply (function make-byte-code) + (progn (while (< i ln) + (setq new + (cons + (if (setq entry (assoc i alist)) + (cdr entry) + (aref defn i)) + new)) + (setq i (1+ i))) + (nreverse new)))))) + + +(provide 'repl-comment)