From c9286b66d9fbac466797e52ef7b9a2a6cce854e8 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Fri, 11 Aug 1989 10:54:26 +0000 Subject: [PATCH] Formatting. --- v7/src/edwin/basic.scm | 201 +++++++++++++++++++++------------------- v7/src/edwin/comred.scm | 9 +- v7/src/edwin/filcom.scm | 7 +- v7/src/edwin/utils.scm | 12 ++- 4 files changed, 118 insertions(+), 111 deletions(-) diff --git a/v7/src/edwin/basic.scm b/v7/src/edwin/basic.scm index 56e3ad742..c43334cde 100644 --- a/v7/src/edwin/basic.scm +++ b/v7/src/edwin/basic.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/basic.scm,v 1.102 1989/08/08 10:05:18 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/basic.scm,v 1.103 1989/08/11 10:51:43 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology ;;; @@ -88,66 +88,38 @@ With an argument, inserts several newlines." (let ((m* (mark-right-inserting (current-point)))) (insert-newlines (or argument 1)) (set-current-point! m*)))) - -(define-command keyboard-quit - "Signals a quit condition." + +(define-command narrow-to-region + "Restrict editing in current buffer to text between point and mark. +Use \\[widen] to undo the effects of this command." () (lambda () - (editor-beep) - (temporary-message "Quit") - (^G-signal))) + (region-clip! (current-region)))) -(define-command ^r-bad-command - "This command is used to capture undefined keys. -It is usually called directly by the command lookup -procedure when it fails to find a command." +(define-command widen + "Remove restrictions from current buffer. +Allows full text to be seen and edited." () (lambda () - (editor-error "Undefined command: " (xchar->name (current-command-char))))) - -(define (barf-if-read-only) - (editor-error "Trying to modify read only text.")) - -(define-variable debug-on-editor-error - "True means signal Scheme error when an editor error occurs." - false) - -(define condition-type:editor-error - (make-error-type '() - (lambda (condition port) - (write-string "Editor error: " port) - (write-string (message-args->string (condition/irritants condition)) - port)))) - -(define (editor-error . strings) - (if (ref-variable debug-on-editor-error) - (call-with-current-continuation - (lambda (continuation) - (debug-scheme-error - (make-condition condition-type:editor-error - strings - continuation)) - (%editor-error))) - (begin - (if (not (null? strings)) (apply temporary-message strings)) - (%editor-error)))) - -(define (%editor-error) - (editor-beep) - (abort-current-command)) - -(define (editor-failure . strings) - (cond ((not (null? strings)) (apply temporary-message strings)) - (*defining-keyboard-macro?* (clear-message))) - (editor-beep) - (keyboard-macro-disable)) - -(define-integrable (editor-beep) - (screen-beep (current-screen))) + (buffer-widen! (current-buffer)))) -(define (not-implemented) - (editor-error "Not yet implemented")) +(define-command set-key + "Define a key binding from the keyboard. +Prompts for a command and a key, and sets the key's binding. +The key is bound in fundamental mode." + (lambda () + (let ((command (prompt-for-command "Command"))) + (list command + (prompt-for-key (string-append "Put \"" + (command-name-string command) + "\" on key") + (mode-comtabs (ref-mode-object fundamental)))))) + (lambda (command key) + (if (prompt-for-confirmation? "Go ahead") + (define-key 'fundamental key (command-name command))))) +;;;; Prefixes + (define-command control-prefix "Sets Control-bit of following character. This command followed by an = is equivalent to a Control-=." @@ -221,6 +193,83 @@ For more information type the HELP key while entering the name." (lambda () (dispatch-on-command (prompt-for-command "Extended Command") true))) +;;;; Errors + +(define-command keyboard-quit + "Signals a quit condition." + () + (lambda () + (editor-beep) + (temporary-message "Quit") + (^G-signal))) + +(define-command ^r-bad-command + "This command is used to capture undefined keys. +It is usually called directly by the command lookup +procedure when it fails to find a command." + () + (lambda () + (editor-error "Undefined command: " (xchar->name (current-command-char))))) + +(define (barf-if-read-only) + (editor-error "Trying to modify read only text.")) + +(define-variable debug-on-editor-error + "True means signal Scheme error when an editor error occurs." + false) + +(define condition-type:editor-error + (make-error-type '() + (lambda (condition port) + (write-string "Editor error: " port) + (write-string (message-args->string (condition/irritants condition)) + port)))) + +(define (editor-error . strings) + (if (ref-variable debug-on-editor-error) + (call-with-current-continuation + (lambda (continuation) + (debug-scheme-error + (make-condition condition-type:editor-error + strings + continuation)) + (%editor-error))) + (begin + (if (not (null? strings)) (apply temporary-message strings)) + (%editor-error)))) + +(define (%editor-error) + (editor-beep) + (abort-current-command)) + +(define (editor-failure . strings) + (cond ((not (null? strings)) (apply temporary-message strings)) + (*defining-keyboard-macro?* (clear-message))) + (editor-beep) + (keyboard-macro-disable)) + +(define-integrable (editor-beep) + (screen-beep (current-screen))) + +(define (not-implemented) + (editor-error "Not yet implemented")) + +;;;; Level Control + +(define-command exit-recursive-edit + "Exit normally from a subsystem of a level of editing." + () + (lambda () + (exit-recursive-edit 'EXIT))) + +(define-command abort-recursive-edit + "Abnormal exit from recursive editing command. +The recursive edit is exited and the command that invoked it is aborted. +For a normal exit, you should use \\[exit-recursive-edit], NOT this command." + () + (lambda () + (exit-recursive-edit 'ABORT))) + (define-command suspend-scheme "Go back to Scheme's superior job. With argument, saves visited file first." @@ -263,49 +312,7 @@ With prefix arg, silently save all file-visiting buffers, then kill." (set! edwin-finalization false) (reset-editor))) ((ref-command suspend-edwin)))) - -(define-command exit-recursive-edit - "Exit normally from a subsystem of a level of editing." - () - (lambda () - (exit-recursive-edit 'EXIT))) - -(define-command abort-recursive-edit - "Abnormal exit from recursive editing command. -The recursive edit is exited and the command that invoked it is aborted. -For a normal exit, you should use \\[exit-recursive-edit], NOT this command." - () - (lambda () - (exit-recursive-edit 'ABORT))) - -(define-command narrow-to-region - "Restrict editing in current buffer to text between point and mark. -Use \\[widen] to undo the effects of this command." - () - (lambda () - (region-clip! (current-region)))) - -(define-command widen - "Remove restrictions from current buffer. -Allows full text to be seen and edited." - () - (lambda () - (buffer-widen! (current-buffer)))) - -(define-command set-key - "Define a key binding from the keyboard. -Prompts for a command and a key, and sets the key's binding. -The key is bound in fundamental mode." - (lambda () - (let ((command (prompt-for-command "Command"))) - (list command - (prompt-for-key (string-append "Put \"" - (command-name-string command) - "\" on key") - (mode-comtabs (ref-mode-object fundamental)))))) - (lambda (command key) - (if (prompt-for-confirmation? "Go ahead") - (define-key 'fundamental key (command-name command))))) + ;;;; Comment Commands (define-variable comment-column diff --git a/v7/src/edwin/comred.scm b/v7/src/edwin/comred.scm index a5cb408e6..79f138b11 100644 --- a/v7/src/edwin/comred.scm +++ b/v7/src/edwin/comred.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comred.scm,v 1.78 1989/08/09 13:16:59 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comred.scm,v 1.79 1989/08/11 10:51:02 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology ;;; @@ -273,14 +273,13 @@ (record-command-arguments expressions)) arguments))) ((null? specification) - (if record? - (record-command-arguments '())) + (if record? (record-command-arguments '())) '()) (else (let ((old-chars-read keyboard-chars-read)) (let ((arguments (specification))) - (if (or record? - (not (= keyboard-chars-read old-chars-read))) (record-command-arguments (map quotify-sexp arguments))) + (if (or record? (not (= keyboard-chars-read old-chars-read))) + (record-command-arguments (map quotify-sexp arguments))) arguments)))))) (define (execute-command-history-entry entry) diff --git a/v7/src/edwin/filcom.scm b/v7/src/edwin/filcom.scm index 15709e6c5..47f7d09ff 100644 --- a/v7/src/edwin/filcom.scm +++ b/v7/src/edwin/filcom.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/filcom.scm,v 1.137 1989/08/07 08:44:52 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/filcom.scm,v 1.138 1989/08/11 10:54:26 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology ;;; @@ -120,10 +120,7 @@ (let ((truename* (buffer-truename buffer))) (and truename* (pathname=? truename truename*)))))))))))) - -(define (pathname=? x y) - (string=? (pathname->string x) - (pathname->string y))) + (define-command find-file "Visit a file in its own buffer. If the file is already in some buffer, select that buffer. diff --git a/v7/src/edwin/utils.scm b/v7/src/edwin/utils.scm index 6da9dbebc..74e385f00 100644 --- a/v7/src/edwin/utils.scm +++ b/v7/src/edwin/utils.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/utils.scm,v 1.16 1989/08/09 13:18:15 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/utils.scm,v 1.17 1989/08/11 10:54:14 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology ;;; @@ -110,7 +110,7 @@ (define char-set:not-graphic (char-set-invert char-set:graphic)) - + (define (read-line #!optional port) (read-string char-set:return (if (default-object? port) @@ -118,7 +118,7 @@ (guarantee-input-port port)))) (define (read-from-string string) - (with-input-from-string string read)) + (with-input-from-string string read)) (define (y-or-n? . strings) (define (loop) (let ((char (char-upcase (read-char)))) @@ -181,4 +181,8 @@ (fluid-let ((*unparser-list-depth-limit* 5) (*unparser-list-breadth-limit* 10)) (write value)) - (write value))))) \ No newline at end of file + (write value))))) + +(define (pathname=? x y) + (string=? (pathname->string x) + (pathname->string y))) \ No newline at end of file -- 2.25.1