From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 15 Jun 2000 00:44:08 +0000 (+0000)
Subject: Allow description of a command, variable, or mode to be a thunk that
X-Git-Tag: 20090517-FFI~3537
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=890ee94bbe35be9e3af3f13a0ba9e1633299e6d7;p=mit-scheme.git

Allow description of a command, variable, or mode to be a thunk that
evaluates to a string.
---

diff --git a/v7/src/edwin/comman.scm b/v7/src/edwin/comman.scm
index cd1375e3b..4bdea0a3a 100644
--- a/v7/src/edwin/comman.scm
+++ b/v7/src/edwin/comman.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: comman.scm,v 1.83 2000/02/25 20:24:15 cph Exp $
+$Id: comman.scm,v 1.84 2000/06/15 00:43:40 cph Exp $
 
 Copyright (c) 1986, 1989-2000 Massachusetts Institute of Technology
 
@@ -36,10 +36,10 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 
 (define (command-description command)
   (let ((desc (command-%description command)))
-    (if (string? desc)
+    (if (description? desc)
 	desc
-	(let ((new (->doc-string (symbol->string (command-name command))
-				 desc)))
+	(let ((new
+	       (->doc-string (symbol->string (command-name command)) desc)))
 	  (if new
 	      (set-command-%description! command new))
 	  new))))
@@ -115,10 +115,10 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 
 (define (variable-description variable)
   (let ((desc (variable-%description variable)))
-    (if (string? desc)
+    (if (description? desc)
 	desc
-	(let ((new (->doc-string (symbol->string (variable-name variable))
-				 desc)))
+	(let ((new
+	       (->doc-string (symbol->string (variable-name variable)) desc)))
 	  (if new
 	      (set-variable-%description! variable new))
 	  new))))
diff --git a/v7/src/edwin/docstr.scm b/v7/src/edwin/docstr.scm
index 594a032d9..04bdd8618 100644
--- a/v7/src/edwin/docstr.scm
+++ b/v7/src/edwin/docstr.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: docstr.scm,v 1.3 1999/01/02 06:11:34 cph Exp $
+$Id: docstr.scm,v 1.4 2000/06/15 00:43:26 cph Exp $
 
-Copyright (c) 1993-1999 Massachusetts Institute of Technology
+Copyright (c) 1993-2000 Massachusetts Institute of Technology
 
 This program is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by
@@ -23,16 +23,15 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 
 (declare (usual-integrations))
 
-(define *external-doc-strings?* true)
-(define *external-doc-strings-file* false)
-(define *doc-strings* false)
+(define *external-doc-strings?* #t)
+(define *external-doc-strings-file* #f)
+(define *doc-strings* #f)
 (define *doc-string-posn* 0)
-(define *doc-string-channel* false)
-(define *doc-string-buffer* false)
+(define *doc-string-channel* #f)
+(define *doc-string-buffer* #f)
 
 (define (doc-string->posn name str)
-  (if (not *external-doc-strings?*)
-      str
+  (if (and *external-doc-strings?* (string? str))
       (let ((nlen (string-length name))
 	    (dslen (string-length str))
 	    (slen (if (not *doc-strings*)
@@ -62,7 +61,8 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	    (string-set! doc-strings (fix:- end 2) #\Newline)
 	    (string-set! doc-strings (fix:- end 1) #\Newline)
 	    (set! *doc-string-posn* end)
-	    posn)))))
+	    posn)))
+      str))
 
 (define-integrable doc-string-buffer-length 512)
 
@@ -142,9 +142,9 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
    output
    (lambda (port)
      (output-port/write-string port *doc-strings*)))
-  (set! *external-doc-strings?* false)
+  (set! *external-doc-strings?* #f)
   (set! *doc-string-posn* 0)
-  (set! *doc-strings* false)
+  (set! *doc-strings* #f)
   unspecific)
 
 (define (guarantee-doc-string-state)
@@ -171,5 +171,4 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 		 unspecific))))))
 
 (add-event-receiver! event:after-restart
-		     (lambda ()
-		       (set! *doc-string-channel* false)))
\ No newline at end of file
+		     (lambda () (set! *doc-string-channel* #f)))
\ No newline at end of file
diff --git a/v7/src/edwin/hlpcom.scm b/v7/src/edwin/hlpcom.scm
index 6edae27be..8b4cd8d16 100644
--- a/v7/src/edwin/hlpcom.scm
+++ b/v7/src/edwin/hlpcom.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: hlpcom.scm,v 1.118 2000/06/15 00:34:27 cph Exp $
+;;; $Id: hlpcom.scm,v 1.119 2000/06/15 00:44:08 cph Exp $
 ;;;
 ;;; Copyright (c) 1986, 1989-2000 Massachusetts Institute of Technology
 ;;;
@@ -346,6 +346,11 @@ If you want VALUE to be a string, you must surround it with doublequotes."
 	  (substring string 0 index)
 	  string))))
 
+(define (description? description)
+  (or (string? description)
+      (and (procedure? description)
+	   (procedure-arity-valid? description 0))))
+
 (define (description->string description)
   (cond ((string? description) description)
 	((procedure? description) (description))
diff --git a/v7/src/edwin/modes.scm b/v7/src/edwin/modes.scm
index 7e1ea03fa..cd782cec6 100644
--- a/v7/src/edwin/modes.scm
+++ b/v7/src/edwin/modes.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: modes.scm,v 1.32 2000/02/25 20:24:19 cph Exp $
+;;; $Id: modes.scm,v 1.33 2000/06/15 00:43:51 cph Exp $
 ;;;
 ;;; Copyright (c) 1986, 1989-2000 Massachusetts Institute of Technology
 ;;;
@@ -105,7 +105,7 @@
 
 (define (mode-description mode)
   (let ((desc (mode-%description mode)))
-    (if (string? desc)
+    (if (description? desc)
 	desc
 	(let ((new (->doc-string (symbol->string (mode-name mode)) desc)))
 	  (if new