From: Chris Hanson Date: Thu, 14 Oct 1993 22:43:35 +0000 (+0000) Subject: * Editor variables can now define a procedure that will "normalize" X-Git-Tag: 20090517-FFI~7759 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=7418e79a7ab2843761ba830624e8a7d04eb4e8fd;p=mit-scheme.git * Editor variables can now define a procedure that will "normalize" their values. The DEFINE-VARIABLE has been extended to allow the specification of this normalization procedure to follow the specification of a validity test. * New procedure VARIABLE-LOCAL-VALUE? is true iff the given variable is locally bound in the given buffer. * Procedure VARIABLE-VALUE-VALID? has been eliminated. --- diff --git a/v7/src/edwin/buffer.scm b/v7/src/edwin/buffer.scm index 7b83193b3..b5ce5aeca 100644 --- a/v7/src/edwin/buffer.scm +++ b/v7/src/edwin/buffer.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: buffer.scm,v 1.163 1993/08/13 23:20:09 cph Exp $ +;;; $Id: buffer.scm,v 1.164 1993/10/14 22:43:09 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology ;;; @@ -87,10 +87,10 @@ The buffer is guaranteed to be deselected at that time." (add-group-clip-daemon! group (buffer-clip-daemon buffer)) (%buffer-reset! buffer) (vector-set! buffer buffer-index:windows '()) - (vector-set! buffer buffer-index:display-start false) + (vector-set! buffer buffer-index:display-start #f) (vector-set! buffer buffer-index:default-directory directory) (vector-set! buffer buffer-index:local-bindings '()) - (vector-set! buffer buffer-index:local-bindings-installed? false) + (vector-set! buffer buffer-index:local-bindings-installed? #f) (%set-buffer-major-mode! buffer mode) (event-distributor/invoke! (variable-default-value (ref-variable-object buffer-creation-hook)) @@ -108,13 +108,13 @@ The buffer is guaranteed to be deselected at that time." (make-ring (variable-default-value (ref-variable-object mark-ring-maximum)))) (ring-push! (buffer-mark-ring buffer) (buffer-start buffer)) - (vector-set! buffer buffer-index:pathname false) - (vector-set! buffer buffer-index:truename false) - (vector-set! buffer buffer-index:auto-save-pathname false) - (vector-set! buffer buffer-index:auto-saved? false) + (vector-set! buffer buffer-index:pathname #f) + (vector-set! buffer buffer-index:truename #f) + (vector-set! buffer buffer-index:auto-save-pathname #f) + (vector-set! buffer buffer-index:auto-saved? #f) (vector-set! buffer buffer-index:save-length 0) - (vector-set! buffer buffer-index:backed-up? false) - (vector-set! buffer buffer-index:modification-time false) + (vector-set! buffer buffer-index:backed-up? #f) + (vector-set! buffer buffer-index:modification-time #f) (vector-set! buffer buffer-index:alist '())) (define (buffer-modeline-event! buffer type) @@ -261,9 +261,9 @@ The buffer is guaranteed to be deselected at that time." (let ((group (buffer-group buffer))) (if (group-modified? group) (begin - (set-group-modified?! group false) + (set-group-modified?! group #f) (buffer-modeline-event! buffer 'BUFFER-MODIFIED) - (vector-set! buffer buffer-index:auto-saved? false))))))) + (vector-set! buffer buffer-index:auto-saved? #f))))))) (define (buffer-modified! buffer) (without-interrupts @@ -271,15 +271,15 @@ The buffer is guaranteed to be deselected at that time." (let ((group (buffer-group buffer))) (if (not (group-modified? group)) (begin - (set-group-modified?! group true) + (set-group-modified?! group #t) (buffer-modeline-event! buffer 'BUFFER-MODIFIED))))))) (define (set-buffer-auto-saved! buffer) - (vector-set! buffer buffer-index:auto-saved? true) + (vector-set! buffer buffer-index:auto-saved? #t) (set-group-modified?! (buffer-group buffer) 'AUTO-SAVED)) (define-integrable (buffer-auto-save-modified? buffer) - (eq? true (group-modified? (buffer-group buffer)))) + (eq? #t (group-modified? (buffer-group buffer)))) (define (buffer-clip-daemon buffer) (lambda (group start end) @@ -315,19 +315,19 @@ The buffer is guaranteed to be deselected at that time." ;;;; Local Bindings (define (define-variable-local-value! buffer variable value) - (check-variable-value-validity! variable value) - (without-interrupts - (lambda () - (let ((binding (search-local-bindings buffer variable))) - (if binding - (set-cdr! binding value) - (vector-set! buffer - buffer-index:local-bindings - (cons (cons variable value) - (buffer-local-bindings buffer))))) - (if (buffer-local-bindings-installed? buffer) - (set-variable-%value! variable value)) - (invoke-variable-assignment-daemons! buffer variable)))) + (let ((value (normalize-variable-value variable value))) + (without-interrupts + (lambda () + (let ((binding (search-local-bindings buffer variable))) + (if binding + (set-cdr! binding value) + (vector-set! buffer + buffer-index:local-bindings + (cons (cons variable value) + (buffer-local-bindings buffer))))) + (if (buffer-local-bindings-installed? buffer) + (set-variable-%value! variable value)) + (invoke-variable-assignment-daemons! buffer variable))))) (define (undefine-variable-local-value! buffer variable) (without-interrupts @@ -349,30 +349,33 @@ The buffer is guaranteed to be deselected at that time." (cdr binding) (variable-default-value variable)))) +(define (variable-local-value? buffer variable) + (search-local-bindings buffer variable)) + (define (set-variable-local-value! buffer variable value) (cond ((variable-buffer-local? variable) (define-variable-local-value! buffer variable value)) ((search-local-bindings buffer variable) => (lambda (binding) - (check-variable-value-validity! variable value) - (without-interrupts - (lambda () - (set-cdr! binding value) - (if (buffer-local-bindings-installed? buffer) - (set-variable-%value! variable value)) - (invoke-variable-assignment-daemons! buffer variable))))) + (let ((value (normalize-variable-value variable value))) + (without-interrupts + (lambda () + (set-cdr! binding value) + (if (buffer-local-bindings-installed? buffer) + (set-variable-%value! variable value)) + (invoke-variable-assignment-daemons! buffer variable)))))) (else (set-variable-default-value! variable value)))) (define (set-variable-default-value! variable value) - (check-variable-value-validity! variable value) - (without-interrupts - (lambda () - (set-variable-%default-value! variable value) - (if (not (search-local-bindings (current-buffer) variable)) - (set-variable-%value! variable value)) - (invoke-variable-assignment-daemons! false variable)))) + (let ((value (normalize-variable-value variable value))) + (without-interrupts + (lambda () + (set-variable-%default-value! variable value) + (if (not (search-local-bindings (current-buffer) variable)) + (set-variable-%value! variable value)) + (invoke-variable-assignment-daemons! #f variable))))) (define-integrable (search-local-bindings buffer variable) (let loop ((bindings (buffer-local-bindings buffer))) @@ -411,25 +414,25 @@ The buffer is guaranteed to be deselected at that time." (do ((bindings (buffer-local-bindings buffer) (cdr bindings))) ((null? bindings)) (set-variable-%value! (caar bindings) (cdar bindings))) - (vector-set! buffer buffer-index:local-bindings-installed? true)) + (vector-set! buffer buffer-index:local-bindings-installed? #t)) (define (uninstall-buffer-local-bindings! buffer) (do ((bindings (buffer-local-bindings buffer) (cdr bindings))) ((null? bindings)) (set-variable-%value! (caar bindings) (variable-default-value (caar bindings)))) - (vector-set! buffer buffer-index:local-bindings-installed? false)) + (vector-set! buffer buffer-index:local-bindings-installed? #f)) (define (set-variable-value! variable value) (if within-editor? (set-variable-local-value! (current-buffer) variable value) (begin - (check-variable-value-validity! variable value) - (without-interrupts - (lambda () - (set-variable-%default-value! variable value) - (set-variable-%value! variable value) - (invoke-variable-assignment-daemons! false variable)))))) + (let ((value (normalize-variable-value variable value))) + (without-interrupts + (lambda () + (set-variable-%default-value! variable value) + (set-variable-%value! variable value) + (invoke-variable-assignment-daemons! #f variable))))))) (define (with-variable-value! variable new-value thunk) (let ((old-value)) diff --git a/v7/src/edwin/comman.scm b/v7/src/edwin/comman.scm index b44a51892..d0d14bf7f 100644 --- a/v7/src/edwin/comman.scm +++ b/v7/src/edwin/comman.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: comman.scm,v 1.74 1993/09/03 04:41:14 cph Exp $ +$Id: comman.scm,v 1.75 1993/10/14 22:43:17 cph Exp $ Copyright (c) 1986, 1989-1993 Massachusetts Institute of Technology @@ -122,7 +122,8 @@ of that license should have been included along with this file. initial-value %default-value assignment-daemons - value-validity-test) + value-validity-test + value-normalization) (define (variable-description variable) (let ((desc (variable-%description variable))) @@ -156,20 +157,21 @@ of that license should have been included along with this file. (set-variable-initial-value! variable value) (set-variable-%default-value! variable value) (set-variable-assignment-daemons! variable '()) - (set-variable-value-validity-test! variable false) + (set-variable-value-validity-test! variable #f) + (set-variable-value-normalization! variable #f) variable)) (define-integrable (make-variable-buffer-local! variable) (set-variable-buffer-local?! variable #t)) -(define (check-variable-value-validity! variable value) - (if (not (variable-value-valid? variable value)) +(define (normalize-variable-value variable value) + (if (or (not (variable-value-validity-test variable)) + ((variable-value-validity-test variable) value)) (editor-error "Invalid value for " (variable-name-string variable) - ": " value))) - -(define (variable-value-valid? variable value) - (or (not (variable-value-validity-test variable)) - ((variable-value-validity-test variable) value))) + ": " value)) + (if (variable-value-normalization variable) + ((variable-value-normalization variable) value) + value)) (define (add-variable-assignment-daemon! variable daemon) (let ((daemons (variable-assignment-daemons variable))) @@ -187,7 +189,7 @@ of that license should have been included along with this file. (define (name->variable name) (let ((name (canonicalize-name name))) (or (string-table-get editor-variables (symbol->string name)) - (make-variable name "" false false)))) + (make-variable name "" #f #f)))) (define (->variable object) (if (variable? object) diff --git a/v7/src/edwin/hlpcom.scm b/v7/src/edwin/hlpcom.scm index e9bf38412..a4cbba53a 100644 --- a/v7/src/edwin/hlpcom.scm +++ b/v7/src/edwin/hlpcom.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: hlpcom.scm,v 1.106 1993/08/10 06:35:52 cph Exp $ +;;; $Id: hlpcom.scm,v 1.107 1993/10/14 22:43:35 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-93 Massachusetts Institute of Technology ;;; @@ -235,10 +235,7 @@ If you want VALUE to be a string, you must surround it with doublequotes." (string-append "Set " (variable-name-string variable) " to value") (variable-value variable))))) (lambda (variable value) - (let ((variable (name->variable variable))) - (if (not (variable-value-valid? variable value)) - (editor-error "illegal value for variable:" value)) - (set-variable-value! variable value)))) + (set-variable-value! (name->variable variable) value))) (define-command make-local-variable "Make a variable have a local value in the current buffer." @@ -249,10 +246,8 @@ If you want VALUE to be a string, you must surround it with doublequotes." (string-append "Set " (variable-name-string variable) " to value") (variable-value variable))))) (lambda (variable value) - (let ((variable (name->variable variable))) - (if (not (variable-value-valid? variable value)) - (editor-error "illegal value for variable:" value)) - (define-variable-local-value! (current-buffer) variable value)))) + (define-variable-local-value! (current-buffer) (name->variable variable) + value))) (define-command kill-local-variable "Make a variable use its global value in the current buffer." diff --git a/v7/src/edwin/macros.scm b/v7/src/edwin/macros.scm index bf2b91da1..920599feb 100644 --- a/v7/src/edwin/macros.scm +++ b/v7/src/edwin/macros.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: macros.scm,v 1.60 1993/08/10 06:47:41 cph Exp $ +;;; $Id: macros.scm,v 1.61 1993/10/14 22:43:23 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-1993 Massachusetts Institute of Technology ;;; @@ -128,7 +128,7 @@ (let ((variable-definition (lambda (buffer-local?) - (lambda (name description #!optional value test) + (lambda (name description #!optional value test normalization) (let ((name (canonicalize-name name))) (let ((scheme-name (variable-name->scheme-name name))) `(BEGIN @@ -139,8 +139,13 @@ ',buffer-local?)) ,@(if (default-object? test) '() - `((DEFINE-VARIABLE-VALUE-VALIDITY-TEST ,scheme-name - ,test)))))))))) + `((SET-VARIABLE-VALUE-VALIDITY-TEST! ,scheme-name + ,test))) + ,@(if (default-object? normalization) + '() + `((SET-VARIABLE-VALUE-NORMALIZATION! + ,scheme-name + ,normalization)))))))))) (syntax-table-define edwin-syntax-table 'DEFINE-VARIABLE (variable-definition false)) (syntax-table-define edwin-syntax-table 'DEFINE-VARIABLE-PER-BUFFER