* procs.c, procs.h (procedure-documentation): Moved from eval.c.

diff --git a/libguile/procs.c b/libguile/procs.c
index a80d79a..7370d1f 100644 (file)
--- a/libguile/procs.c
+++ b/libguile/procs.c
@@ -182,6 +182,37 @@ scm_thunk_p (obj)
   return SCM_BOOL_F;
 }
 
+SCM_PROC(s_procedure_documentation, "procedure-documentation", 1, 0, 0, scm_procedure_documentation);
+
+SCM 
+scm_procedure_documentation (proc)
+     SCM proc;
+{
+  SCM code;
+  SCM_ASSERT (SCM_BOOL_T == scm_procedure_p (proc) && SCM_NIMP (proc) && SCM_TYP7 (proc) != scm_tc7_contin,
+         proc, SCM_ARG1, s_procedure_documentation);
+  switch (SCM_TYP7 (proc))
+    {
+    case scm_tcs_closures:
+      code = SCM_CDR (SCM_CODE (proc));
+      if (SCM_IMP (SCM_CDR (code)))
+       return SCM_BOOL_F;
+      code = SCM_CAR (code);
+      if (SCM_IMP (code))
+       return SCM_BOOL_F;
+      if (SCM_STRINGP (code))
+       return code;
+    default:
+      return SCM_BOOL_F;
+/*
+  case scm_tcs_subrs:
+#ifdef CCLO
+  case scm_tc7_cclo:
+#endif
+*/
+    }
+}
+
 
 
 void

diff --git a/libguile/procs.h b/libguile/procs.h
index d1ffd59..5b31f50 100644 (file)
--- a/libguile/procs.h
+++ b/libguile/procs.h
@@ -97,6 +97,7 @@ extern SCM scm_makcclo SCM_P ((SCM proc, long len));
 extern SCM scm_procedure_p SCM_P ((SCM obj));
 extern SCM scm_closure_p SCM_P ((SCM obj));
 extern SCM scm_thunk_p SCM_P ((SCM obj));
+extern SCM scm_procedure_documentation SCM_P ((SCM proc));
 extern void scm_init_iprocs SCM_P ((scm_iproc *subra, int type));
 extern void scm_init_procs SCM_P ((void));