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)