From edf1728daee3621d713fcad62e0920c5a00cf919 Mon Sep 17 00:00:00 2001
From: "Guillermo J. Rozas" <edu/mit/csail/zurich/gjr>
Date: Wed, 1 Sep 1993 18:09:29 +0000
Subject: [PATCH] Add ability to dump doc strings externally.

---
 v7/src/edwin/comman.scm | 204 ++++++++++++++++++++++++++++++++++++----
 v7/src/edwin/modes.scm  |  30 ++++--
 2 files changed, 205 insertions(+), 29 deletions(-)

diff --git a/v7/src/edwin/comman.scm b/v7/src/edwin/comman.scm
index e0b1a43f6..b9d18dcde 100644
--- a/v7/src/edwin/comman.scm
+++ b/v7/src/edwin/comman.scm
@@ -1,8 +1,8 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: comman.scm,v 1.70 1993/08/10 23:27:57 cph Exp $
+;;;	$Id: comman.scm,v 1.71 1993/09/01 18:08:30 gjr Exp $
 ;;;
-;;;	Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology
+;;;	Copyright (c) 1986, 1989-1993 Massachusetts Institute of Technology
 ;;;
 ;;;	This material was developed by the Scheme project at the
 ;;;	Massachusetts Institute of Technology, Department of
@@ -53,10 +53,23 @@
 		      (lambda (state command)
 			(unparse-object state (command-name command))))))
   name
-  description
+  %description
   interactive-specification
   procedure)
 
+(define-integrable (%symbol->string sym)
+  (system-pair-car sym))
+
+(define (command-description command)
+  (let ((desc (command-%description command)))
+    (if (string? desc)
+	desc
+	(let ((new (->doc-string (%symbol->string (command-name command))
+				 desc)))
+	  (if new
+	      (set-command-%description! command new))
+	  new))))
+
 (define (command-name-string command)
   (editor-name/internal->external (symbol->string (command-name command))))
 
@@ -67,14 +80,14 @@
   string)
 
 (define (make-command name description specification procedure)
-  (let ((command
-	 (let ((name (symbol->string name)))
-	   (or (string-table-get editor-commands name)
-	       (let ((command (%make-command)))
-		 (string-table-put! editor-commands name command)
-		 command)))))
+  (let* ((sname (symbol->string name))
+	 (command
+	  (or (string-table-get editor-commands sname)
+	      (let ((command (%make-command)))
+		(string-table-put! editor-commands sname command)
+		command))))
     (set-command-name! command name)
-    (set-command-description! command description)
+    (set-command-%description! command (doc-string->posn sname description))
     (set-command-interactive-specification! command specification)
     (set-command-procedure! command procedure)
     command))
@@ -107,7 +120,7 @@
 		      (lambda (state variable)
 			(unparse-object state (variable-name variable))))))
   name
-  description
+  %description
   %value
   buffer-local?
   initial-value
@@ -115,6 +128,16 @@
   assignment-daemons
   value-validity-test)
 
+(define (variable-description variable)
+  (let ((desc (variable-%description variable)))
+    (if (string? desc)
+	desc
+	(let ((new (->doc-string (%symbol->string (veriable-name variable))
+				 desc)))
+	  (if new
+	      (set-variable-%description! variable new))
+	  new))))
+
 (define-integrable variable-value variable-%value)
 (define-integrable variable-default-value variable-%default-value)
 (define-integrable define-variable-value-validity-test
@@ -124,14 +147,14 @@
   (editor-name/internal->external (symbol->string (variable-name variable))))
 
 (define (make-variable name description value buffer-local?)
-  (let ((variable
-	 (let ((name (symbol->string name)))
-	   (or (string-table-get editor-variables name)
-	       (let ((variable (%make-variable)))
-		 (string-table-put! editor-variables name variable)
-		 variable)))))
+  (let* ((sname (symbol->string name))
+	 (variable
+	  (or (string-table-get editor-variables sname)
+	      (let ((variable (%make-variable)))
+		(string-table-put! editor-variables sname variable)
+		variable))))
     (set-variable-name! variable name)
-    (set-variable-description! variable description)
+    (set-variable-%description! variable (doc-string->posn sname description))
     (set-variable-%value! variable value)
     (set-variable-buffer-local?! variable buffer-local?)
     (set-variable-initial-value! variable value)
@@ -173,4 +196,147 @@
 (define (->variable object)
   (if (variable? object)
       object
-      (name->variable object)))
\ No newline at end of file
+      (name->variable object)))
+
+;;;; Maintaining doc strings externally.
+
+(define *external-doc-strings?* true)
+(define *external-doc-strings-file* false)
+(define *doc-strings* false)
+(define *doc-string-posn* 0)
+(define *doc-string-channel* false)
+(define *doc-string-buffer* false)
+
+(define (doc-string->posn name str)
+  (if (not *external-doc-strings?*)
+      str
+      (let ((nlen (string-length name))
+	    (dslen (string-length str))
+	    (slen (if (not *doc-strings*)
+		      0
+		      (string-length *doc-strings*)))
+	    (posn *doc-string-posn*))
+	(let* ((next (fix:+ posn nlen))
+	       (end (fix:+ next (fix:+ dslen 6))))
+	  (if (> end slen)
+	      (let ((new (string-allocate
+			  (max end
+			       (if (fix:zero? slen)
+				   4096
+				   (fix:+ slen (fix:quotient slen 2)))))))
+		(if *doc-strings*
+		    (substring-move-right! *doc-strings* 0 posn new 0))
+		(set! *doc-strings* new)))
+	  (let ((doc-strings *doc-strings*))
+	    (vector-8b-set! doc-strings posn (fix:remainder dslen 256))
+	    (vector-8b-set! doc-strings
+			    (fix:+ posn 1)
+			    (fix:quotient dslen 256))
+	    (string-set! doc-strings (fix:+ posn 2) #\Newline)
+	    (substring-move-right! name 0 nlen doc-strings (fix:+ posn 3))
+	    (string-set! doc-strings (fix:+ next 3) #\Newline)
+	    (substring-move-right! str 0 dslen doc-strings (fix:+ next 4))
+	    (string-set! doc-strings (fix:- end 2) #\Newline)
+	    (string-set! doc-strings (fix:- end 1) #\Newline)
+	    (set! *doc-string-posn* end)
+	    posn)))))
+
+(define-integrable doc-string-buffer-length 512)
+
+(define (->doc-string name posn)
+  (define (out-of-range)
+    (editor-error "->doc-string: Out of range argument" posn))
+
+  (define (fill-buffer channel buffer posn blen)
+    (let fill-loop ((posn posn))
+      (if (fix:< posn blen)
+	  (let ((n (channel-read-block channel buffer posn blen)))
+	    (fill-loop (fix:+ posn n))))))
+
+  (define (verify-and-extract buffer nlen dslen nposn)
+    (let ((nend (fix:+ nposn nlen)))
+      (if (not (string=? (substring buffer nposn nend) name))
+	  (editor-error "->doc-string: Inconsistency" posn)
+	  (let ((dstart (fix:+ nend 1)))
+	    (substring buffer dstart (fix:+ dstart dslen))))))
+
+  (cond ((string? posn)
+	 posn)
+	((not (fix:fixnum? posn))
+	 (editor-error "->doc-string: Wrong type argument" posn))
+	((fix:< posn 0)
+	 (out-of-range))
+	(*doc-strings*
+	 (let ((slen (string-length *doc-strings*))
+	       (nlen (string-length name)))
+	   (if (fix:> (fix:+ posn 2) slen)
+	       (out-of-range))
+	   (let ((dslen
+		  (fix:+ (vector-8b-ref *doc-strings* posn)
+			 (fix:lsh (vector-8b-ref *doc-strings* (fix:+ posn 1))
+				  8))))
+	     (if (fix:> (fix:+ (fix:+ posn 6) (fix:+ nlen dslen)) slen)
+		 (out-of-range)
+		 (verify-and-extract *doc-strings* nlen dslen
+				     (fix:+ posn 3))))))
+	(else
+	 (guarantee-doc-string-state)
+	 (let* ((channel *doc-string-channel*)
+		(buffer *doc-string-buffer*)
+		(flen (file-length channel))
+		(nlen (string-length name))
+		(delta (fix:- flen (fix:+ posn 2))))
+	   (if (fix:< delta 0)
+	       (out-of-range))
+	   (file-set-position channel posn)
+	   (let ((blen (min doc-string-buffer-length delta)))
+	     (fill-buffer channel buffer 0 blen)
+	     (let* ((dslen (fix:+ (vector-8b-ref buffer 0)
+				  (fix:lsh (vector-8b-ref buffer 1)
+					   8)))
+		    (end (fix:+ (fix:+ dslen nlen) 6)))
+	       (cond ((not (fix:> end blen))
+		      (verify-and-extract buffer nlen dslen 3))
+		     ((fix:> (fix:+ end posn) flen)
+		      (out-of-range))
+		     (else
+		      (let* ((rlen (fix:+ (fix:+ nlen dslen) 1))
+			     (result (string-allocate rlen)))
+			(substring-move-right! buffer 3 blen result 0)
+			(fill-buffer channel result (fix:- blen 3) rlen)
+			(verify-and-extract result nlen dslen 0))))))))))
+
+(define (dump-doc-strings output #!optional permanent)
+  (if (not *doc-strings*)
+      (error "dump-doc-strings: No doc strings to dump!"))
+  (set! *external-doc-strings-file*
+	(if (or (default-object? permanent)
+		(not permanent))
+	    output
+	    permanent))	
+  (set-string-length! *doc-strings* *doc-string-posn*)
+  (call-with-binary-output-file
+   output
+   (lambda (port)
+     (output-port/write-string port *doc-strings*)))
+  (set! *external-doc-strings?* false)
+  (set! *doc-string-posn* 0)
+  (set! *doc-strings* false)
+  unspecific)
+
+(define (guarantee-doc-string-state)
+  (if (not *doc-string-buffer*)
+      (set! *doc-string-buffer* (string-allocate doc-string-buffer-length)))
+  (cond (*doc-string-channel*)
+	((not *external-doc-strings-file*)
+	 (editor-error "guarantee-doc-string-channel: Undeclared doc-string file"))
+	((not (file-exists? *external-doc-strings-file*))
+	 (editor-error "guarantee-doc-string-channel: Non-existent doc-string file"))
+	(else
+	 (set! *doc-string-channel*
+	       (file-open-input-channel (->namestring *external-doc-strings-file*)))
+	 unspecific)))
+
+(add-event-receiver! event:after-restart
+		     (lambda ()
+		       (set! *doc-string-channel* false)))
\ No newline at end of file
diff --git a/v7/src/edwin/modes.scm b/v7/src/edwin/modes.scm
index ae3cca313..a7f5f6159 100644
--- a/v7/src/edwin/modes.scm
+++ b/v7/src/edwin/modes.scm
@@ -1,8 +1,8 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modes.scm,v 1.26 1992/01/09 17:45:16 cph Exp $
+;;;	$Id: modes.scm,v 1.27 1993/09/01 18:09:29 gjr Exp $
 ;;;
-;;;	Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
+;;;	Copyright (c) 1986, 1989-1993 Massachusetts Institute of Technology
 ;;;
 ;;;	This material was developed by the Scheme project at the
 ;;;	Massachusetts Institute of Technology, Department of
@@ -58,18 +58,28 @@
   (comtabs false read-only true)
   display-name
   major?
-  description
+  %description
   initialization
   alist)
 
+(define (mode-description mode)
+  (let ((desc (mode-%description mode)))
+    (if (string? desc)
+	desc
+	(let ((new (->doc-string (%symbol->string (mode-name mode))
+				 desc)))
+	  (if new
+	      (set-mode-%description! mode new))
+	  new))))
+
 (define (make-mode name major? display-name super-mode description
 		   initialization)
-  (let ((mode
-	 (let ((string (symbol->string name)))
-	   (or (string-table-get editor-modes string)
-	       (let ((mode (%make-mode name (list (make-comtab)))))
-		 (string-table-put! editor-modes string mode)
-		 mode)))))
+  (let* ((sname (symbol->string name))
+	 (mode
+	  (or (string-table-get editor-modes sname)
+	      (let ((mode (%make-mode name (list (make-comtab)))))
+		(string-table-put! editor-modes sname mode)
+		mode))))
     (set-mode-display-name! mode display-name)
     (set-mode-major?! mode major?)
     (set-cdr! (mode-comtabs mode)
@@ -82,7 +92,7 @@
 		     ;; that as a valid argument.  Later, this can be
 		     ;; an error.
 		     super-mode)))
-    (set-mode-description! mode description)
+    (set-mode-%description! mode (doc-string->posn sname description))
     (set-mode-initialization! mode initialization)
     (set-mode-alist! mode '())
     mode))
-- 
2.25.1