Mercurial > hg > xemacs
comparison 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 |
comparison
equal
deleted
inserted
replaced
| -1:000000000000 | 0:107d592c5f4a |
|---|---|
| 1 ;; Universal (?) replace comment in function | |
| 2 | |
| 3 ;; Last edited: Thu Oct 7 09:39:50 1993 | |
| 4 (defun repl-comment (fn comment) | |
| 5 "replace/install as FN's comment COMMENT, no matter what emacs/compiler" | |
| 6 (let ((defn (symbol-function fn))) | |
| 7 (if (consp defn) | |
| 8 (if (eq (car defn) 'autoload) | |
| 9 (progn (load-library (car (cdr defn))) | |
| 10 (if (equal defn (symbol-function fn)) | |
| 11 (error "autoloading didn't help define %s" fn) | |
| 12 (repl-comment fn comment))) | |
| 13 ;; either symbolic or old byte-compiler | |
| 14 (if (eq (car defn) 'lambda) | |
| 15 (if (stringp (car (cdr (cdr defn)))) | |
| 16 (rplaca (cdr (cdr defn)) | |
| 17 comment) | |
| 18 (rplacd (cdr defn) | |
| 19 (cons comment | |
| 20 (cdr (cdr defn))))) | |
| 21 (error "can't diagnose defn %s" defn))) | |
| 22 ;; array or not | |
| 23 (if (compiled-function-p defn) | |
| 24 (fset fn (if (fboundp 'compiled-function-arglist) | |
| 25 (progn (make-byte-code | |
| 26 (compiled-function-arglist defn) | |
| 27 (compiled-function-instructions defn) | |
| 28 (compiled-function-constants defn) | |
| 29 (compiled-function-stack-depth defn) | |
| 30 comment | |
| 31 (compiled-function-interactive defn)) defn) | |
| 32 (repl-byte fn (list (cons 4 comment))))) | |
| 33 (error "unrecognised defn %s" defn))))) | |
| 34 | |
| 35 (defun repl-byte (fn alist) | |
| 36 "compute a new byte-code defn for FN, replacing | |
| 37 elements using ALIST, which is interpreted as (index . newbit). | |
| 38 Elements are 0: arglist 1: byte-codes 2: symbols 3: stack-depth 4: comment" | |
| 39 (let | |
| 40 ((defn (symbol-function fn))) | |
| 41 (let ((ln (if (sequencep defn) | |
| 42 (length defn) | |
| 43 ;; hack otherwise | |
| 44 6)) | |
| 45 (i 0) | |
| 46 new entry) | |
| 47 (apply (function make-byte-code) | |
| 48 (progn (while (< i ln) | |
| 49 (setq new | |
| 50 (cons | |
| 51 (if (setq entry (assoc i alist)) | |
| 52 (cdr entry) | |
| 53 (aref defn i)) | |
| 54 new)) | |
| 55 (setq i (1+ i))) | |
| 56 (nreverse new)))))) | |
| 57 | |
| 58 | |
| 59 (provide 'repl-comment) |