[librep] ABI-incompatible change! improved documentation function regarding subrs, byte-code and macros Pleas

[Christopher Bratusek <chrisb src gnome org>]

commit d83b5890cc9f1ba1b0c86f56c57827a7bb9e1cde
Author: Christopher Roy Bratusek <zanghar freenet de>
Date:   Sun Aug 29 07:57:35 2010 +0200

    ABI-incompatible change!
    improved documentation function regarding subrs, byte-code and macros
    Please test this change!

 lisp/rep/lang/doc.jl        |   16 ++++++++++++----
 lisp/rep/vm/compiler/rep.jl |   15 ++++++++++++++-
 src/rep_lisp.h              |    7 +++++--
 src/structures.c            |    1 +
 src/symbols.c               |   27 ++++++++++++++++++++++++++-
 5 files changed, 58 insertions(+), 8 deletions(-)
---
diff --git a/lisp/rep/lang/doc.jl b/lisp/rep/lang/doc.jl
index 193a17c..6bb4a31 100644
--- a/lisp/rep/lang/doc.jl
+++ b/lisp/rep/lang/doc.jl
@@ -142,11 +142,19 @@ NAME is true, then it should be the symbol that is associated with VALUE."
       'documentation))
 
   (defun documentation (symbol #!optional structure value)
-    "Returns the documentation-string for SYMBOL."
+    "Returns the documentation-string for SYMBOL which should be the name
+of one of a special variable, function, macro, or a special form.
+If it's not a variable, then VALUE should be the function etc.
+
+STRUCTURE is a compatibility argument, and can be nil."
     (catch 'exit
-      (when (and (not structure) (closurep value))
-	(let ((tem (closure-structure value)))
-	  (when (structure-name tem)
+      (when (and (not structure) value)
+	(let (tem)
+	  (if (closurep value)
+	      (setq tem (closure-structure value))
+	    (if (subrp value) ;; t for subr and special form
+		(setq tem (subr-structure value))))
+	  (when (and tem (structure-name tem))
 	    (setq structure (structure-name tem)))))
 
       ;; First check for in-core documentation
diff --git a/lisp/rep/vm/compiler/rep.jl b/lisp/rep/vm/compiler/rep.jl
index 4d7a49a..15c8b92 100644
--- a/lisp/rep/vm/compiler/rep.jl
+++ b/lisp/rep/vm/compiler/rep.jl
@@ -107,7 +107,20 @@
 			       (memq (car out) top-level-compiled))))))
       (case (car form)
 	((defun)
-	 (remember-function (nth 1 form) (nth 2 form) (nthcdr 3 form)))
+	 (remember-function (nth 1 form) (nth 2 form) (nthcdr 3 form))
+	 (let* ((body (cdddr form))
+		(doc (car body))
+		prop-name)
+	   (when (and (not *compiler-write-docs*)
+		      (stringp doc))
+	     (setq prop-name
+		   (intern
+		    (concat "documentation#"
+			    (symbol-name (fluid current-module)))))
+	     (format standard-error "prop-name: %s\n" prop-name)
+	     (setq form
+		   `(progn (put ',(cadr form) ',prop-name ,doc)
+			   ,form)))))
 
 	((defmacro)
 	 (remember-function (nth 1 form) (nth 2 form))
diff --git a/src/rep_lisp.h b/src/rep_lisp.h
index 33fb8c5..b687c2e 100644
--- a/src/rep_lisp.h
+++ b/src/rep_lisp.h
@@ -564,6 +564,7 @@ typedef struct {
     } fun;
     repv name;
     repv int_spec;
+    repv structure;
 } rep_subr;
 
 typedef struct {
@@ -571,6 +572,7 @@ typedef struct {
     repv (*fun)();
     repv name;
     repv int_spec;			/* put this in plist? */
+    repv structure;
 } rep_xsubr;
 
 /* If set in rep_SubrN types, it'll be passed a vector of args,
@@ -775,7 +777,7 @@ typedef struct rep_gc_n_roots {
     extern repv fsym args;						\
     rep_ALIGN_CELL(rep_xsubr ssym) = { type, (repv (*)()) fsym,		\
 				       rep_VAL(&rep_CONCAT(ssym, __name)), \
-				       rep_NULL };			\
+				       rep_NULL, rep_NULL };		\
     repv fsym args
 
 /* Same as above but with an extra arg -- an interactive-spec string. */
@@ -785,7 +787,8 @@ typedef struct rep_gc_n_roots {
     extern repv fsym args;						\
     rep_ALIGN_CELL(rep_xsubr ssym) = { type, (repv (*)()) fsym,		\
 				       rep_VAL(&rep_CONCAT(ssym, __name)), \
-				       rep_VAL(&rep_CONCAT(ssym, __int)) };\
+				       rep_VAL(&rep_CONCAT(ssym, __int)), \
+				       rep_NULL};			\
     repv fsym args
 
 /* Add a subroutine */    
diff --git a/src/structures.c b/src/structures.c
index c4d83f4..6631df6 100644
--- a/src/structures.c
+++ b/src/structures.c
@@ -1542,6 +1542,7 @@ rep_add_subr(rep_xsubr *subr, rep_bool export)
 	rep_struct_node *n = lookup_or_add (s, sym);
 	n->binding = rep_VAL (subr);
 	n->is_exported = export;
+	subr->structure = rep_structure;
     }
     return sym;
 }
diff --git a/src/symbols.c b/src/symbols.c
index 9b879d2..ad9eea7 100644
--- a/src/symbols.c
+++ b/src/symbols.c
@@ -417,7 +417,7 @@ Set the function value in the closure FUNARG to FUNCTION.
 DEFUN("closure-structure", Fclosure_structure,
       Sclosure_structure, (repv funarg), rep_Subr1) /*
 ::doc:rep.structures#closure-function::
-closure-function FUNARG
+closure-structure FUNARG
 
 Return the structure associated with the closure FUNARG.
 ::end:: */
@@ -426,6 +426,30 @@ Return the structure associated with the closure FUNARG.
     return rep_FUNARG(funarg)->structure;
 }
 
+DEFUN("subr-structure", Fsubr_structure,
+      Ssubr_structure, (repv arg), rep_Subr1) /*
+::doc:rep.structures#closure-function::
+subr-structure SUBR
+
+Return the structure associated with the subr SUBR.
+::end:: */
+{
+  /* Simple rep_DECLARE1 can't be used. Borrow rep_DECLARE1 macro
+     definition. */
+  do{
+    if(Fsubrp(arg) == Qnil){
+      rep_signal_arg_error(arg, 1);
+      return rep_NULL;
+    }
+  }while(0);
+
+  if(rep_XSUBR(arg)->structure != rep_NULL){
+    return rep_XSUBR(arg)->structure;
+  }else{
+    return Qnil;
+  }
+}
+
 DEFUN ("set-closure-structure", Fset_closure_structure,
        Sset_closure_structure, (repv closure, repv structure), rep_Subr2)
 {
@@ -1494,6 +1518,7 @@ rep_symbols_init(void)
     rep_ADD_SUBR(Sset_closure_function);
     rep_ADD_SUBR(Sclosure_name);
     rep_ADD_SUBR(Sclosurep);
+    rep_ADD_SUBR(Ssubr_structure);
     rep_pop_structure (tem);
 
     tem = rep_push_structure ("rep.structures");