;;; -*-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
(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))))
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))
(lambda (state variable)
(unparse-object state (variable-name variable))))))
name
- description
+ %description
%value
buffer-local?
initial-value
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
(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)
(define (->variable object)
(if (variable? object)
object
- (name->variable object)))
\ No newline at end of file
+ (name->variable object)))
+\f
+;;;; 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)))))
+\f
+(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))))))))))
+\f
+(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
;;; -*-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
(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)
;; 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))
projects / mit-scheme.git / commitdiff