From: Chris Hanson Date: Sat, 12 Aug 1989 08:32:56 +0000 (+0000) Subject: * Change internal names of various user procedures to correspond to X-Git-Tag: 20090517-FFI~11836 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=0b20c10684408df27be2137030ba481a58585baa;p=mit-scheme.git * Change internal names of various user procedures to correspond to the external names: edwin edit edwin-discard-state! reset-editor edwin-reset create-editor edwin-reset-args create-editor-args edwin-set-display! set-editor-display-type! The external interface to Edwin now consists of the following procedures: (EDIT) (RESET-EDITOR) (RESET-EDITOR-WINDOWS) As before. (EDITOR-DISPLAY-TYPE) Returns the display-type of the current editor. This is either a symbol or #F. (EDITOR-DISPLAY-TYPES) Returns the names of all the known display types, in a list. (CREATE-EDITOR DISPLAY-TYPE . ARGS) Initializes a display of the given type, passing the args to the screen-construction code. CREATE-EDITOR-ARGS This variable is a list of arguments to be passed to `create-editor' if it is necessary for `edit' to call it. * Add new command `define-command', which is solely a placeholder for the documentation string it possesses. * Implement editor variable `inhibit-startup-message' -- see the documentation string. * `enable-transcript-buffer' is now #F by default -- it is normally enabled in Scheme-Interaction mode only. * Change the definitions of the commands `set-environment' and `set-syntax-table' to set the editor variables `scheme-environment' and `scheme-syntax-table'. The old behavior of these commands is available via the new commands `set-repl-environment' and `set-repl-syntax-table'. Other new commands are `set-default-environment' and `set-default-syntax-table'. * Change definition of `scheme-syntax-table', allowing it to be a symbol which is regarded as a variable to be evaluated relative to the evaluation environment. * Add init files, which are found in "~/.edwin". The new global variable `inhibit-editor-init-file?' (defined in the system global environment), prevents your init file from being loaded if it is true. * Add new "find-file initialization" hack: this is invoked whenever `find-file' or `revert-buffer' is done. The reason for this hack is to allow a database file to contain evaluation environment and syntax-table information for the editor. When a `find-file' (or `revert-buffer') is done, the editor looks in the directory of the file for one of two files: 1. If the file's name is "foo.scm", the editor looks for a file "foo.ffi" (-only- if the type is ".scm"). Otherwise, 2. The editor looks for the file ".edwin-ffi". If one of these files are found, it is loaded into the editor (if the first file is found, the second is ignored). The loading is performed in the (edwin) package with `edwin-syntax-table'. The result of loading the file must be a Scheme procedure which accepts no arguments; this procedure will be added to the buffer's initializations, to be performed the next time the buffer is selected. The procedure `standard-scheme-find-file-initialization' is useful in this regard. It should be straightforward to automatically generate these files from the package-modeller. * The binding for `describe-command' has been changed from `C-h d' to `C-h f' for compatibility with Emacs. * Under some circumstances, files in the user's home directory tree will be displayed using the "~/" notation. * Implement overlooked command `x-set-position'. ---------------------------------------------------------------------- * Change definition of `load-edwin-file' procedure to make it more generally useful for loading files into the editor. Similar changes to the `load-file' and `load-library' commands. * Bullet-proof the evaluation environment and syntax-table code so that they signal an editor-error if unable to be resolved to the appropriate kind of object. ---------------------------------------------------------------------- * Cause a modeline-event to occur whenever a buffer's clipping is changed. * Change handling of `edwin-initialization' so that the code is run inside the command-reader loop -- thus making sure that all of the editor's dynamic-state is bound. * Fix bug in command-reader: undo boundaries were not being marked when they should have been. * Change `kill-buffer' to pick a different replacement buffer for each of its windows, if possible. --- diff --git a/v7/src/edwin/autold.scm b/v7/src/edwin/autold.scm index 417711dc0..a76bf94e5 100644 --- a/v7/src/edwin/autold.scm +++ b/v7/src/edwin/autold.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/autold.scm,v 1.45 1989/08/09 13:16:41 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/autold.scm,v 1.46 1989/08/12 08:31:05 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology ;;; @@ -51,7 +51,7 @@ (define (make-autoloading-procedure library-name get-procedure) (define entity (make-entity (lambda arguments - (load-library library-name) + ((ref-command load-library) library-name 'NO-WARN) (let ((procedure (get-procedure))) (set-entity-procedure! entity procedure) (apply procedure (cdr arguments)))) @@ -129,7 +129,9 @@ (define (guarantee-command-loaded command) (let ((procedure (command-procedure command))) (if (autoloading-procedure? procedure) - (load-library (autoloading-procedure/library-name procedure))))) + ((ref-command load-library) + (autoloading-procedure/library-name procedure) + 'NO-WARN)))) ;;;; Libraries @@ -174,42 +176,16 @@ (hook) (loop)))) (if entry (loop)))) - -(define (load-library name) - (if (not (library-loaded? name)) - (let ((entry (assq name known-libraries))) - (if entry - (%load-library entry) - (error "LOAD-LIBRARY: Unknown library name" name))))) - -(define (%load-library library) - (for-each (lambda (entry) - (apply load-edwin-file entry)) - (cdr library)) - (if (not (memq (car library) loaded-libraries)) - (set! loaded-libraries (cons (car library) loaded-libraries))) - (run-library-load-hooks! (car library))) ;;;; Loading -(define (load-edwin-file filename package #!optional purify?) - (let ((pathname - (merge-pathnames (->pathname filename) (edwin-binary-directory)))) - (temporary-message "Loading file \"" (pathname->string pathname) "\"") - (let ((scode (fasload pathname true))) - (if (or (default-object? purify?) purify?) (purify scode)) - (scode-eval-with-history scode (->environment package)))) - (append-message " -- done")) - -(define-command load-file - "Load an Edwin binary file. -An argument, if given, means purify the file too." - "fLoad file\nP" - (lambda (filename purify?) - (load-edwin-file filename '(EDWIN) purify?))) - (define-command load-library - "Load an Edwin library." + "Load the Edwin library NAME. +Second arg FORCE? controls what happens if the library is already loaded: + 'NO-WARN means do nothing, + false means display a warning message in the minibuffer, + anything else means load it anyway. +Second arg is prefix arg when called interactively." (lambda () (list (car @@ -217,8 +193,46 @@ An argument, if given, means purify the file too." (map (lambda (library) (cons (symbol->string (car library)) library)) - known-libraries))))) - (lambda (name) - (%load-library - (or (assq name known-libraries) - (editor-error "Unknown library name: " name))))) \ No newline at end of file + known-libraries))) + (command-argument-standard-value))) + (lambda (name force?) + (let ((do-it + (let ((library + (or (assq name known-libraries) + (editor-error "Unknown library name: " name)))) + (temporary-message "Loading " (car library)) + (let ((directory (edwin-binary-directory))) + (for-each + (lambda (entry) + (load-edwin-file + (merge-pathnames (->pathname (car entry)) directory) + (cadr entry) + (or (null? (cddr entry)) (caddr entry)))) + (cdr library))) + (if (not (memq (car library) loaded-libraries)) + (set! loaded-libraries (cons (car library) loaded-libraries))) + (run-library-load-hooks! (car library)) + (append-message " -- done")))) + (cond ((not (library-loaded? name)) + (do-it)) + ((not force?) + (temporary-message "Library already loaded: " name)) + ((not (eq? force? 'NO-WARN)) + (do-it)))))) + +(define-command load-file + "Load the Edwin binary file FILENAME. +Second arg PURIFY? means purify the file's contents after loading; + this is the prefix arg when called interactively." + "fLoad file\nP" + (lambda (filename purify?) + (temporary-message "Loading file \"" filename "\"") + (load-edwin-file filename '(EDWIN) purify?) + (append-message " -- done"))) +(define (load-edwin-file filename environment purify?) + (with-output-to-transcript-buffer + (lambda () + (bind-condition-handler '() evaluation-error-handler + (lambda () + (fluid-let ((load/suppress-loading-message? true)) + (load filename environment edwin-syntax-table purify?))))))) \ No newline at end of file diff --git a/v7/src/edwin/basic.scm b/v7/src/edwin/basic.scm index c43334cde..c8f001b2b 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.103 1989/08/11 10:51:43 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/basic.scm,v 1.104 1989/08/12 08:31:18 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology ;;; @@ -280,7 +280,7 @@ With argument, saves visited file first." (lambda () (set! edwin-finalization false) (quit) - (edwin))) + (edit))) ((ref-command suspend-edwin)))) (define-command suspend-edwin @@ -423,4 +423,61 @@ on new line, with no new terminator or starter." (end (line-end (current-point) 0))) (let ((com ((ref-variable comment-locator-hook) start))) (if com - (kill-string (horizontal-space-start (car com)) end))))))) \ No newline at end of file + (kill-string (horizontal-space-start (car com)) end))))))) + +;;;; Useful Documentation + +(define-command define-command + "Scheme special form used to define commands: + + (define-command NAME DOCUMENTATION INTERACTIVE-SPEC PROCEDURE) + +where: + NAME is a symbol; + DOCUMENTATION is a string; + INTERACTIVE-SPEC describes how to call PROCEDURE when the command is + invoked interactively (see below); and + PROCEDURE is a Scheme procedure that is called to perform the + command's actions. + +INTERACTIVE-SPEC and PROCEDURE are evaluated, the others aren't. + +INTERACTIVE-SPEC specifies a way of parsing arguments for interactive +use of a command. For example, write + (define-command foo \"Doc string\" \"p\" (lambda (arg) ...use arg...)) +to make arg be the prefix numeric argument when foo is invoked. + +INTERACTIVE-SPEC is usually a string containing a code letter + followed by a prompt. (Some code letters do not use I/O to get + the argument and do not need prompts.) To prompt for multiple arguments, + give a code letter, its prompt, a newline, and another code letter, etc. +If INTERACTIVE-SPEC is not a string, it is either a procedure or (). + If it's a procedure, then the procedure is invoked with no arguments, + and should return a list of arguments for the command. + Otherwise, if it's the empty list, the command gets no arguments. + +Code letters available are: +b -- Name of existing buffer (string). +B -- Name of buffer, possibly nonexistent (string). +c -- Character. +C -- Command name (symbol). +d -- Value of point (editor-mark object). Does not do I/O. +D -- Directory name (string). +f -- Existing file name (string). +F -- Possibly nonexistent file name (string). +k -- Key sequence (list of chars). +m -- Value of mark (editor-mark object). Does not do I/O. +n -- Number read using minibuffer. +N -- Prefix arg converted to number, or if none, do like code `n'. +p -- Prefix arg converted to number, or 1 if no prefix. Does not do I/O. +P -- Prefix arg converted to number, or #F if no prefix. Does not do I/O. +r -- Region: current region (editor-region object). Does no I/O. +s -- Any string. +v -- Variable name (symbol). +x -- Scheme expression read but not evaluated. +X -- Scheme expression read and evaluated. +In addition, if the first character of the string is '*' then an error is + signaled if the buffer is read-only. + This happens before reading any arguments." + () + (lambda () (editor-error "DEFINE-COMMAND shouldn't be invoked"))) \ No newline at end of file diff --git a/v7/src/edwin/buffer.scm b/v7/src/edwin/buffer.scm index 0c0a5090a..5d88908b3 100644 --- a/v7/src/edwin/buffer.scm +++ b/v7/src/edwin/buffer.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffer.scm,v 1.135 1989/08/11 11:49:53 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/buffer.scm,v 1.136 1989/08/12 08:31:27 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology ;;; @@ -87,6 +87,7 @@ The buffer is guaranteed to be deselected at that time." (let ((daemon (buffer-modification-daemon buffer))) (add-group-insert-daemon! group daemon) (add-group-delete-daemon! group daemon)) + (add-group-clip-daemon! group (buffer-clip-daemon buffer)) (if (not (minibuffer? buffer)) (enable-group-undo! group)) (vector-set! buffer @@ -274,6 +275,12 @@ The buffer is guaranteed to be deselected at that time." (buffer-modeline-event! buffer 'BUFFER-MODIFIED))) (vector-set! buffer buffer-index:auto-save-modified? true) unspecific)) + +(define (buffer-clip-daemon buffer) + (lambda (group start end) + group start end ;ignore + (buffer-modeline-event! buffer 'CLIPPING-CHANGED))) + (define-integrable (buffer-read-only? buffer) (group-read-only? (buffer-group buffer))) diff --git a/v7/src/edwin/comred.scm b/v7/src/edwin/comred.scm index e6c866c8b..860d3ca3d 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.80 1989/08/11 16:17:44 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comred.scm,v 1.81 1989/08/12 08:31:32 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology ;;; @@ -62,13 +62,13 @@ unspecific) (define (top-level-command-reader initialization) - (let loop () + (let loop ((initialization initialization)) (with-keyboard-macro-disabled (lambda () (intercept-^G-interrupts (lambda () unspecific) (lambda () (command-reader initialization))))) - (loop))) + (loop false))) (define (command-reader #!optional initialization) (define (command-reader-loop) @@ -182,57 +182,56 @@ (define (%dispatch-on-command window command record?) (set! *command* command) (guarantee-command-loaded command) - (let ((procedure (command-procedure command))) + (let ((point (window-point window)) + (point-x (window-point-x window)) + (procedure (command-procedure command))) (let ((normal (lambda () + (set! *non-undo-count* 0) + (undo-boundary! point) (apply procedure (interactive-arguments command record?))))) - (if (or *executing-keyboard-macro?* - (window-needs-redisplay? window) - (command-argument-standard-value?)) - (begin - (set! *non-undo-count* 0) - (normal)) - (let ((point (window-point window)) - (point-x (window-point-x window))) - (if (or (eq? procedure (ref-command self-insert-command)) - (and (eq? procedure (ref-command auto-fill-space)) - (not (auto-fill-break? point))) - (command-argument-self-insert? procedure)) - (let ((char *command-char*)) - (if (let ((buffer (window-buffer window))) - (and (buffer-auto-save-modified? buffer) - (null? (cdr (buffer-windows buffer))) - (line-end? point) - (char-graphic? char) - (< point-x (-1+ (window-x-size window))))) - (begin - (if (or (zero? *non-undo-count*) - (>= *non-undo-count* 20)) - (begin - (undo-boundary! point) - (set! *non-undo-count* 0))) - (set! *non-undo-count* (1+ *non-undo-count*)) - (window-direct-output-insert-char! window char)) - (region-insert-char! point char))) - (begin - (set! *non-undo-count* 0) - (cond ((eq? procedure (ref-command forward-char)) - (if (and (not (group-end? point)) - (char-graphic? (mark-right-char point)) - (< point-x (- (window-x-size window) 2))) - (window-direct-output-forward-char! window) - (normal))) - ((eq? procedure (ref-command backward-char)) - (if (and (not (group-start? point)) - (char-graphic? (mark-left-char point)) - (positive? point-x) - (< point-x (-1+ (window-x-size window)))) - (window-direct-output-backward-char! window) - (normal))) - (else - (if (not (typein-window? window)) - (undo-boundary! point)) - (normal)))))))))) + (cond ((or *executing-keyboard-macro?* + (command-argument-standard-value?)) + (set! *non-undo-count* 0) + (apply procedure (interactive-arguments command record?))) + ((window-needs-redisplay? window) + (normal)) + ((eq? procedure (ref-command forward-char)) + (if (and (not (group-end? point)) + (char-graphic? (mark-right-char point)) + (< point-x (- (window-x-size window) 2))) + (window-direct-output-forward-char! window) + (normal))) + ((eq? procedure (ref-command backward-char)) + (if (and (not (group-start? point)) + (char-graphic? (mark-left-char point)) + (positive? point-x) + (< point-x (-1+ (window-x-size window)))) + (window-direct-output-backward-char! window) + (normal))) + ((or (eq? procedure (ref-command self-insert-command)) + (and (eq? procedure (ref-command auto-fill-space)) + (not (auto-fill-break? point))) + (command-argument-self-insert? procedure)) + (let ((char *command-char*)) + (if (let ((buffer (window-buffer window))) + (and (buffer-auto-save-modified? buffer) + (null? (cdr (buffer-windows buffer))) + (line-end? point) + (char-graphic? char) + (< point-x (-1+ (window-x-size window))))) + (begin + (if (or (zero? *non-undo-count*) + (>= *non-undo-count* 20)) + (begin + (set! *non-undo-count* 0) + (undo-boundary! point))) + (set! *non-undo-count* (1+ *non-undo-count*)) + (window-direct-output-insert-char! window char)) + (region-insert-char! point char)))) + (else + (normal)))))) + (define (interactive-arguments command record?) (let ((specification (command-interactive-specification command)) (record-command-arguments diff --git a/v7/src/edwin/curren.scm b/v7/src/edwin/curren.scm index 2b951f436..c68da1732 100644 --- a/v7/src/edwin/curren.scm +++ b/v7/src/edwin/curren.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/curren.scm,v 1.85 1989/08/09 13:17:02 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/curren.scm,v 1.86 1989/08/12 08:31:40 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology ;;; @@ -171,13 +171,17 @@ (bufferset-rename-buffer (current-bufferset) buffer new-name)) (define (kill-buffer buffer) - (if (buffer-visible? buffer) - (let ((new-buffer - (or (other-buffer buffer) - (error "Buffer to be killed has no replacement" buffer)))) - (for-each (lambda (window) - (set-window-buffer! window new-buffer false)) - (buffer-windows buffer)))) (bufferset-kill-buffer! (current-bufferset) buffer)) + (let loop + ((windows (buffer-windows buffer)) + (last-buffer false)) + (if (not (null? windows)) + (let ((new-buffer + (or (other-buffer buffer) + last-buffer + (error "Buffer to be killed has no replacement" buffer)))) + (set-window-buffer! (car windows) new-buffer false) + (loop (cdr windows) new-buffer)))) + (bufferset-kill-buffer! (current-bufferset) buffer)) (define-integrable (select-buffer buffer) (set-window-buffer! (current-window) buffer true)) diff --git a/v7/src/edwin/decls.scm b/v7/src/edwin/decls.scm index 2ecd1bf70..1610ee5b2 100644 --- a/v7/src/edwin/decls.scm +++ b/v7/src/edwin/decls.scm @@ -3,11 +3,12 @@ '("bufinp" "bufott" "bufout" - "comtab" "class" "clscon" "clsmac" + "comtab" "cterm" + "display" "entity" "grpops" "image" @@ -26,10 +27,10 @@ "strpad" "strtab" "utils" - "xform" - "xterm" "winout" - "winren"))) + "winren" + "xform" + "xterm"))) (fluid-let ((sf/default-syntax-table (access edwin-syntax-table (->environment '(EDWIN))))) @@ -50,7 +51,9 @@ "curren" "debug" "debuge" - "dired" "editor" + "dired" + "ed-ffi" + "editor" "edtstr" "evlcom" "filcom" diff --git a/v7/src/edwin/editor.scm b/v7/src/edwin/editor.scm index 7e8dc7787..b5cc277c8 100644 --- a/v7/src/edwin/editor.scm +++ b/v7/src/edwin/editor.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/editor.scm,v 1.191 1989/08/11 16:17:58 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/editor.scm,v 1.192 1989/08/12 08:31:48 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology ;;; @@ -46,42 +46,39 @@ (declare (usual-integrations)) -(define (edwin) +(define (edit) (if (not edwin-editor) - (apply edwin-reset edwin-reset-args)) + (apply create-editor create-editor-args)) (call-with-current-continuation (lambda (continuation) (fluid-let ((editor-abort continuation) (*auto-save-keystroke-count* 0)) (within-editor edwin-editor (lambda () - (using-screen edwin-screen + (with-editor-interrupts (lambda () - (with-editor-input-port edwin-input-port + (with-current-local-bindings! (lambda () - (with-editor-interrupts + (bind-condition-handler '() internal-error-handler (lambda () - (with-current-local-bindings! - (lambda () - (bind-condition-handler '() internal-error-handler - (lambda () - (dynamic-wind - (lambda () (update-screens! true)) - (lambda () - (let ((message (cmdl-message/null))) - (push-cmdl (lambda (cmdl) - cmdl ;ignore - (top-level-command-reader - edwin-initialization) - message) - false - message))) - (lambda () unspecific))))))))))))))))) + (dynamic-wind + (lambda () (update-screens! true)) + (lambda () + (let ((message (cmdl-message/null))) + (push-cmdl (lambda (cmdl) + cmdl ;ignore + (top-level-command-reader + edwin-initialization) + message) + false + message))) + (lambda () unspecific))))))))))))) (if edwin-finalization (edwin-finalization)) unspecific) -(define edwin-reset-args '()) +(define create-editor-args (list false)) (define editor-abort) +(define edwin-editor false) ;; Set this before entering the editor to get something done after the ;; editor's dynamic environment is initialized, but before the command @@ -93,13 +90,84 @@ ;; reset and then reenter the editor. (define edwin-finalization false) +(define (create-editor display-type . make-screen-args) + (reset-editor) + (initialize-typein!) + (initialize-typeout!) + (initialize-syntax-table!) + (initialize-command-reader!) + (if display-type + (set-editor-display-type! display-type) + (initialize-display-type!)) + (set! edwin-editor + (let ((screen (apply make-editor-screen make-screen-args))) + (make-editor "Edwin" screen (make-editor-input-port screen)))) + (set! edwin-initialization + (lambda () + (set! edwin-initialization false) + (with-editor-interrupts-disabled standard-editor-initialization))) + unspecific) + +(define (reset-editor) + (without-interrupts + (lambda () + (if edwin-editor + (begin + (screen-discard! (editor-screen edwin-editor)) + (set! edwin-editor false) + unspecific))))) + +(define (standard-editor-initialization) + (if (not init-file-loaded?) + (begin + (let ((filename (os/init-file-name))) + (if (file-exists? filename) + (load-edwin-file filename '(EDWIN) true))) + (set! init-file-loaded? true) + unspecific)) + (if (not (ref-variable inhibit-startup-message)) + (let ((window (current-window))) + (with-output-to-mark (window-point window) + write-initial-buffer-greeting!) + (let ((buffer (window-buffer window))) + (set-window-start-mark! window (buffer-start buffer) false) + (buffer-not-modified! buffer) + (sit-for 120000) + (region-delete! (buffer-unclipped-region buffer)) + (buffer-not-modified! buffer))))) + +(define inhibit-editor-init-file? false) +(define init-file-loaded? false) + +(define-variable inhibit-startup-message + "*True inhibits the initial startup messages. +This is for use in your personal init file, once you are familiar +with the contents of the startup message." + false) + +(define (write-initial-buffer-greeting!) + (identify-world) + (write-string initial-buffer-greeting)) + +(define initial-buffer-greeting + " + +;You are in an interaction window of the Edwin editor. +;Type C-h for help. C-h m will describe some commands. + +") + ;;;; Recursive Edit Levels (define (within-editor editor thunk) (fluid-let ((current-editor editor) (recursive-edit-continuation false) (recursive-edit-level 0)) - (thunk))) + (using-screen (current-screen) + (lambda () + (with-editor-input-port (current-editor-input-port) + thunk))))) + (define (within-editor?) (not (unassigned? current-editor))) (define (enter-recursive-edit) diff --git a/v7/src/edwin/edtstr.scm b/v7/src/edwin/edtstr.scm index 1bf93c14c..4ca6fb499 100644 --- a/v7/src/edwin/edtstr.scm +++ b/v7/src/edwin/edtstr.scm @@ -47,13 +47,14 @@ (define-structure (editor (constructor %make-editor)) (name false read-only true) (screen false read-only true) + (input-port false read-only true) (frame-window false read-only true) (bufferset false read-only true) (kill-ring false read-only true) (char-history false read-only true) (button-event false)) -(define (make-editor name screen) +(define (make-editor name screen input-port) (let ((initial-buffer (make-buffer initial-buffer-name initial-buffer-mode))) (let ((bufferset (make-bufferset initial-buffer))) (let ((frame @@ -64,6 +65,7 @@ (set-screen-window! screen frame) (%make-editor name screen + input-port frame bufferset (make-ring 10) @@ -75,6 +77,10 @@ (define-integrable (all-screens) (list (current-screen))) + +(define-integrable (current-editor-input-port) + (editor-input-port current-editor)) + (define-integrable (current-editor-frame) (editor-frame-window current-editor)) diff --git a/v7/src/edwin/edwin.ldr b/v7/src/edwin/edwin.ldr index c57873870..a3635af01 100644 --- a/v7/src/edwin/edwin.ldr +++ b/v7/src/edwin/edwin.ldr @@ -1,5 +1,5 @@ ;;; -*-Scheme-*- -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.ldr,v 1.6 1989/08/09 13:17:13 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.ldr,v 1.7 1989/08/12 08:31:57 cph Exp $ ;;; program to load package contents ;;; **** This program (unlike most .ldr files) is not generated by a program. @@ -33,6 +33,7 @@ (load "buffer" environment) (load "bufset" environment) (load "undo" (->environment '(EDWIN UNDO))) + (load "display" (->environment '(EDWIN DISPLAY-TYPE))) (load "screen" (->environment '(EDWIN SCREEN))) (load "winren" (->environment '(EDWIN))) (let ((environment (->environment '(EDWIN WINDOW)))) diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg index f324f9f07..3039d077c 100644 --- a/v7/src/edwin/edwin.pkg +++ b/v7/src/edwin/edwin.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.10 1989/08/11 11:50:37 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.11 1989/08/12 08:32:00 cph Exp $ Copyright (c) 1989 Massachusetts Institute of Technology @@ -100,7 +100,11 @@ MIT in each case. |# (export (edwin class-macros) class-instance-transforms) (export () - edwin-reset-args)) + create-editor + create-editor-args + edit + inhibit-editor-init-file? + reset-editor)) (define-package (edwin class-macros) (files "clsmac") @@ -179,6 +183,23 @@ MIT in each case. |# undo-record-deletion! undo-record-insertion!)) +(define-package (edwin display-type) + (files "display") + (parent (edwin)) + (export () + editor-display-type + editor-display-types) + (export (edwin) + display-type? + initialize-display-type! + make-display-type + make-editor-input-port + make-editor-screen + set-editor-display-type! + with-editor-interrupts + with-editor-interrupts-disabled + with-editor-interrupts-enabled)) + (define-package (edwin screen) (files "screen") (parent (edwin)) @@ -219,23 +240,20 @@ MIT in each case. |# button3-up button4-up button5-up - x-display) + x-display-type) (export (edwin x-commands) screen-xterm) (initialization (initialize-package!))) (define-package (edwin x-commands) (files "xcom") - (parent (edwin)) - (export (edwin) - x-move-to-coordinates - x-switch-to-window)) + (parent (edwin))) (define-package (edwin console-screen) (files "cterm") (parent (edwin)) (export (edwin) - console-display) + console-display-type) (initialization (initialize-package!))) (define-package (edwin window) @@ -252,7 +270,7 @@ MIT in each case. |# "winmis") (parent (edwin)) (export () - edwin-set-display!) + reset-editor-windows) (export (edwin) button-downify button-upify @@ -263,15 +281,7 @@ MIT in each case. |# editor-frame-typein-window editor-frame-window0 editor-frame-windows - edwin-discard-state! - edwin-display - edwin-editor - edwin-input-port - edwin-reset - edwin-reset-windows - edwin-screen initialize-buttons! - make-display make-editor-frame set-window-point! set-window-start-mark! @@ -307,10 +317,7 @@ MIT in each case. |# window-set-override-message! window-setup-truncate-lines! window-start-index - window-y-center - with-editor-interrupts - with-editor-interrupts-enabled - with-editor-interrupts-disabled) + window-y-center) (export (edwin prompt) clear-override-message! frame-text-inferior @@ -386,7 +393,6 @@ MIT in each case. |# char-metafy clear-message command-prompt - editor-input-port initialize-typeout! keyboard-active? keyboard-peek-char @@ -395,7 +401,6 @@ MIT in each case. |# message-args->string reset-command-prompt! set-command-prompt! - set-editor-input-port! temporary-message with-editor-input-port)) diff --git a/v7/src/edwin/evlcom.scm b/v7/src/edwin/evlcom.scm index f6f611c58..e126770fd 100644 --- a/v7/src/edwin/evlcom.scm +++ b/v7/src/edwin/evlcom.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/evlcom.scm,v 1.16 1989/08/09 13:17:23 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/evlcom.scm,v 1.17 1989/08/12 08:32:04 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology ;;; @@ -66,7 +66,7 @@ This does not affect editor errors." (define-variable enable-transcript-buffer "If true, output from evaluation commands is recorded in transcript buffer." - true) + false) (define-variable transcript-buffer-name "Name of evaluation transcript buffer. @@ -140,18 +140,44 @@ With an argument, prompts for the evaluation environment." "xEvaluate expression\nP" (lambda (expression argument) (editor-eval expression (evaluation-environment argument)))) - + (define-command set-environment - "Sets the environment for the editor and any inferior REP loops." + "Make ENVIRONMENT the current evaluation environment." "XSet environment" + (lambda (environment) + (set-variable! scheme-environment (->environment environment)))) + +(define-command set-syntax-table + "Make SYNTAX-TABLE the current syntax table." + "XSet syntax table" + (lambda (syntax-table) + (set-variable! scheme-syntax-table syntax-table))) + +(define-command set-default-environment + "Make ENVIRONMENT the default evaluation environment." + "XSet default environment" + (lambda (environment) + (set-variable-default-value! (ref-variable-object scheme-environment) + (->environment environment)))) + +(define-command set-default-syntax-table + "Make SYNTAX-TABLE the default syntax table." + "XSet default syntax table" + (lambda (syntax-table) + (set-variable-default-value! (ref-variable-object scheme-syntax-table) + syntax-table))) + +(define-command set-repl-environment + "Make ENVIRONMENT the environment of the nearest REP loop." + "XSet REPL environment" (lambda (environment) (set-repl/environment! (nearest-repl) (->environment environment)))) -(define-command set-syntactic-environment - "Sets the current syntactic environment." - "XSet syntactic environment" - (lambda (syntactic-environment) - (set-repl/syntax-table! (nearest-repl) syntactic-environment))) +(define-command set-repl-syntax-table + "Make SYNTAX-TABLE the syntax table of the nearest REP loop." + "XSet REPL syntax table" + (lambda (syntax-table) + (set-repl/syntax-table! (nearest-repl) syntax-table))) (define-command select-transcript-buffer "Select the transcript buffer." @@ -207,20 +233,43 @@ may be available. The following commands are special to this mode: (loop (read))))))))) (define (evaluation-environment argument) - (if argument - (if (environment? argument) - argument - (->environment - (prompt-for-expression-value "Evaluate in environment"))) - (let ((environment (ref-variable scheme-environment))) - (if (eq? 'DEFAULT environment) - (nearest-repl/environment) - (->environment environment))))) - -(define (evaluation-syntax-table) - (or (ref-variable scheme-syntax-table) - (nearest-repl/syntax-table))) - + (let ((->environment + (lambda (object) + (bind-condition-handler '() + (lambda (condition) + (and (not (condition/internal? condition)) + (error? condition) + (editor-error "Illegal environment: " object))) + (lambda () + (->environment object)))))) + (if argument + (if (environment? argument) + argument + (->environment + (prompt-for-expression-value "Evaluate in environment"))) + (let ((environment (ref-variable scheme-environment))) + (if (eq? 'DEFAULT environment) + (nearest-repl/environment) + (->environment environment)))))) + +(define (evaluation-syntax-table environment) + (let ((syntax-table (ref-variable scheme-syntax-table))) + (cond ((or (not syntax-table) (eq? 'DEFAULT syntax-table)) + (nearest-repl/syntax-table)) + ((scheme-syntax-table? syntax-table) + syntax-table) + ((and (symbol? syntax-table) + (not (lexical-unreferenceable? environment syntax-table)) + (let ((syntax-table + (lexical-reference environment syntax-table))) + (and (scheme-syntax-table? syntax-table) + syntax-table)))) + (else + (editor-error "Illegal syntax table: " syntax-table))))) + +(define scheme-syntax-table? + (access syntax-table? system-global-environment)) + (define (editor-eval sexp environment) (with-output-to-transcript-buffer (lambda () @@ -229,34 +278,36 @@ may be available. The following commands are special to this mode: value)))) (define (eval-with-history expression environment) - (scode-eval-with-history (syntax expression (evaluation-syntax-table)) + (scode-eval-with-history (syntax expression + (evaluation-syntax-table environment)) environment)) (define (scode-eval-with-history scode environment) - (bind-condition-handler '() - (lambda (condition) - (and (not (condition/internal? condition)) - (error? condition) - (begin - (if (ref-variable debug-on-evaluation-error) - (debug-scheme-error condition) - (let ((string - (with-output-to-string - (lambda () - ((condition/reporter condition) - condition - (current-output-port)))))) - (if (and (not (string-find-next-char string #\newline)) - (< (string-column-length string 18) 80)) - (message "Evaluation error: " string) - (begin - (string->temporary-buffer string "*Error*") - (message "Evaluation error"))))) - (%editor-error)))) + (bind-condition-handler '() evaluation-error-handler (lambda () (with-new-history (lambda () (extended-scode-eval scode environment)))))) + +(define (evaluation-error-handler condition) + (and (not (condition/internal? condition)) + (error? condition) + (begin + (if (ref-variable debug-on-evaluation-error) + (debug-scheme-error condition) + (let ((string + (with-output-to-string + (lambda () + ((condition/reporter condition) + condition + (current-output-port)))))) + (if (and (not (string-find-next-char string #\newline)) + (< (string-column-length string 18) 80)) + (message "Evaluation error: " string) + (begin + (string->temporary-buffer string "*Error*") + (message "Evaluation error"))))) + (%editor-error)))) ;;;; Transcript Buffer @@ -289,7 +340,9 @@ may be available. The following commands are special to this mode: (let ((value-message (lambda () (message value-string)))) (if (ref-variable enable-transcript-buffer) (begin - (fresh-lines 1) (write-string value-string) + (fresh-lines 1) + (write-char #\;) + (write-string value-string) (fresh-lines 2) (if (null? (buffer-windows (transcript-buffer))) (value-message))) diff --git a/v7/src/edwin/filcom.scm b/v7/src/edwin/filcom.scm index 47f7d09ff..0bfe104ae 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.138 1989/08/11 10:54:26 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/filcom.scm,v 1.139 1989/08/12 08:32:08 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology ;;; @@ -74,53 +74,9 @@ (revert-buffer buffer true true)))) buffer) (let ((buffer (new-buffer (pathname->buffer-name pathname)))) - (after-find-file - buffer - (catch-file-errors (lambda () true) - (lambda () - (not (read-buffer buffer pathname))))) + (visit-file buffer pathname) buffer)))))) -(define (after-find-file buffer error?) - (let ((pathname (or (buffer-truename buffer) (buffer-pathname buffer)))) - (if (or (not pathname) (file-writable? pathname)) - (set-buffer-writeable! buffer) - (set-buffer-read-only! buffer))) - (let ((msg - (cond ((not (buffer-read-only? buffer)) - (and error? "(New file)")) - ((not error?) - "File is write protected") - ((file-attributes (buffer-pathname buffer)) - "File exists, but is read-protected.") - ((file-attributes - (pathname-directory-path (buffer-pathname buffer))) - "File not found and directory write-protected") - (else - "File not found and directory doesn't exist")))) - (if msg - (message msg))) - (setup-buffer-auto-save! buffer) - (initialize-buffer! buffer)) - -(define (pathname->buffer pathname) - (or (list-search-positive (buffer-list) - (lambda (buffer) - (let ((pathname* (buffer-pathname buffer))) - (and pathname* - (pathname=? pathname pathname*))))) - (let ((truename (pathname->input-truename pathname))) - (and truename - (list-search-positive (buffer-list) - (lambda (buffer) - (let ((pathname* (buffer-pathname buffer))) - (and pathname* - (or (pathname=? pathname pathname*) - (pathname=? truename pathname*) - (let ((truename* (buffer-truename buffer))) - (and truename* - (pathname=? truename truename*)))))))))))) - (define-command find-file "Visit a file in its own buffer. If the file is already in some buffer, select that buffer. @@ -151,6 +107,38 @@ Like \\[kill-buffer] followed by \\[find-file]." (let ((buffer* (new-buffer "*dummy*"))) (do-it) (kill-buffer buffer*))))))) + +(define-command revert-buffer + "Replace the buffer text with the text of the visited file on disk. +This undoes all changes since the file was visited or saved. +If latest auto-save file is more recent than the visited file, +asks user whether to use that instead. +Argument means don't offer to use auto-save file." + "P" + (lambda (argument) + (revert-buffer (current-buffer) argument false))) + +(define (revert-buffer buffer dont-use-auto-save? dont-confirm?) + (let ((method (buffer-get buffer 'REVERT-BUFFER-METHOD))) + (if method + (method buffer dont-use-auto-save? dont-confirm?) + (let ((pathname (buffer-pathname buffer))) + (cond ((not pathname) + (editor-error + "Buffer does not seem to be associated with any file")) + ((not (file-exists? pathname)) + (editor-error "File " + (pathname->string pathname) + " no longer exists!")) + ((or dont-confirm? + (prompt-for-yes-or-no? + (string-append "Revert buffer from file " + (pathname->string pathname)))) + (let ((where (mark-index (buffer-point buffer)))) + (visit-file buffer pathname) + (set-buffer-point! + buffer + (mark+ (buffer-start buffer) where 'LIMIT))))))))) (define-command toggle-read-only "Change whether this buffer is visiting its file read-only." @@ -162,6 +150,60 @@ Like \\[kill-buffer] followed by \\[find-file]." set-buffer-writeable!) buffer)))) +(define (visit-file buffer pathname) + (let ((error? + (catch-file-errors (lambda () true) + (lambda () + (not (read-buffer buffer pathname)))))) + (let ((pathname (or (buffer-truename buffer) pathname))) + (if (file-writable? pathname) + (set-buffer-writeable! buffer) + (set-buffer-read-only! buffer)) + (let ((msg + (cond ((not (buffer-read-only? buffer)) + (and error? "(New file)")) + ((not error?) + "File is write protected") + ((file-attributes pathname) + "File exists, but is read-protected.") + ((file-attributes (pathname-directory-path pathname)) + "File not found and directory write-protected") + (else + "File not found and directory doesn't exist")))) + (if msg + (message msg))))) + (setup-buffer-auto-save! buffer) + (initialize-buffer! buffer) + (let ((filename (os/find-file-initialization-filename pathname))) + (if filename + (let ((database (load-edwin-file filename '(EDWIN) false))) + (if (and (procedure? database) + (procedure-arity-valid? database 0)) + (add-buffer-initialization! buffer database) + (message + "Ill-formed find-file initialization file: " + (os/pathname->display-string (->pathname filename)))))))) + +(define (standard-scheme-find-file-initialization database) + ;; DATABASE -must- be a vector whose elements are all three element + ;; lists. The car of each element must be a string, and the + ;; elements must be sorted on those strings. + (lambda () + (let ((entry + (let ((pathname (buffer-pathname (current-buffer)))) + (and pathname + (equal? "scm" (pathname-type pathname)) + (let ((name (pathname-name pathname))) + (and name + (vector-binary-search database + stringbuffer-name pathname) - (let ((name (pathname-name pathname))) - (if name - (pathname->string - (make-pathname false false false - name - (pathname-type pathname) - false)) - (let ((name - (let ((directory (pathname-directory pathname))) - (and (pair? directory) - (car (last-pair directory)))))) - (if (string? name) - name - "*random*"))))) - (define-command write-file "Store buffer in specified file. This file becomes the one being visited." @@ -302,39 +328,6 @@ Leaves point at the beginning, mark at the end." (lambda (filename) (set-current-region! (insert-file (current-point) filename)))) -(define-command revert-buffer - "Replace the buffer text with the text of the visited file on disk. -This undoes all changes since the file was visited or saved. -If latest auto-save file is more recent than the visited file, -asks user whether to use that instead. -Argument means don't offer to use auto-save file." - "P" - (lambda (argument) - (revert-buffer (current-buffer) argument false))) - -(define (revert-buffer buffer dont-use-auto-save? dont-confirm?) - (let ((method (buffer-get buffer 'REVERT-BUFFER-METHOD))) - (if method - (method buffer dont-use-auto-save? dont-confirm?) - (let ((pathname (buffer-pathname buffer))) - (cond ((not pathname) - (editor-error - "Buffer does not seem to be associated with any file")) - ((not (file-exists? pathname)) - (editor-error "File " - (pathname->string pathname) - " no longer exists!")) - ((or dont-confirm? - (prompt-for-yes-or-no? - (string-append "Revert buffer from file " - (pathname->string pathname)))) - (let ((where (mark-index (buffer-point buffer)))) - (read-buffer buffer pathname) - (set-buffer-point! - buffer - (mark+ (buffer-start buffer) where 'LIMIT))) - (after-find-file buffer false))))))) - (define-command copy-file "Copy a file; the old and new names are read in the typein window. If a file with the new name already exists, confirmation is requested first." @@ -386,6 +379,8 @@ If a file with the new name already exists, confirmation is requested first." ;;;; Printer Support +#| + (define-command print-file "Print a file on the local printer." "fPrint File" @@ -410,8 +405,6 @@ If a file with the new name already exists, confirmation is requested first." (lambda (region) (print-region region))) -#| - (define (print-region region) (let ((temp (temporary-buffer "*Printout*"))) (region-insert! (buffer-point temp) region) @@ -433,10 +426,13 @@ If a file with the new name already exists, confirmation is requested first." ;;;; Prompting (define (prompt-for-filename prompt default require-match?) - (let ((default (pathname-directory-path default))) + (let ((default + (if default + (pathname-directory-path default) + (working-directory-pathname)))) (prompt-for-completed-string prompt - (pathname-directory-string default) + (os/pathname->display-string default) 'INSERTED-DEFAULT (lambda (string if-unique if-not-unique if-not-found) (define (loop directory filenames) @@ -552,4 +548,34 @@ If a file with the new name already exists, confirmation is requested first." (and pathname-newest 'NEWEST))) (define-integrable (prompt-string->pathname string) - (string->pathname (os/trim-pathname-string string))) \ No newline at end of file + (string->pathname (os/trim-pathname-string string))) + +(define (pathname->buffer-name pathname) + (let ((name (pathname-name pathname))) + (if name + (pathname->string + (make-pathname false false false + name (pathname-type pathname) false)) + (let ((name + (let ((directory (pathname-directory pathname))) + (and (pair? directory) + (car (last-pair directory)))))) + (if (string? name) name "*random*"))))) + +(define (pathname->buffer pathname) + (or (list-search-positive (buffer-list) + (lambda (buffer) + (let ((pathname* (buffer-pathname buffer))) + (and pathname* + (pathname=? pathname pathname*))))) + (let ((truename (pathname->input-truename pathname))) + (and truename + (list-search-positive (buffer-list) + (lambda (buffer) + (let ((pathname* (buffer-pathname buffer))) + (and pathname* + (or (pathname=? pathname pathname*) + (pathname=? truename pathname*) + (let ((truename* (buffer-truename buffer))) + (and truename* + (pathname=? truename truename*)))))))))))) \ No newline at end of file diff --git a/v7/src/edwin/hlpcom.scm b/v7/src/edwin/hlpcom.scm index 79bcdc0b9..7f8e9f78a 100644 --- a/v7/src/edwin/hlpcom.scm +++ b/v7/src/edwin/hlpcom.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/hlpcom.scm,v 1.89 1989/08/03 23:32:55 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/hlpcom.scm,v 1.90 1989/08/12 08:32:15 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology ;;; @@ -49,7 +49,7 @@ (define-command help-prefix "This is a prefix for more commands. It reads another character (a subcommand) and dispatches on it." - "cA C D I K L M T V W or C-h for more help" + "cA C F I K L M T V W or C-h for more help" (lambda (char) (dispatch-on-char (current-comtabs) @@ -66,7 +66,7 @@ A command-apropos. Type a substring, and see a list of commands that contain that substring. C describe-key-briefly. Type a key sequence; it prints the name of the command that sequence runs. -D describe-command. Type a command name and get its documentation. +F describe-command. Type a command name and get its documentation. I info. The Info documentation reader. K describe-key. Type a key sequence; it prints the full documentation. @@ -84,7 +84,7 @@ W where-is. Type a command name and get its key binding." (let loop () (let ((char (prompt-for-char - "A C D I K L M T V W or space to scroll"))) (let ((test-for + "A C F I K L M T V W or space to scroll"))) (let ((test-for (lambda (char*) (char=? char (remap-alias-char char*))))) (cond ((or (test-for #\C-h) diff --git a/v7/src/edwin/input.scm b/v7/src/edwin/input.scm index 9589de43b..b8eb8d172 100644 --- a/v7/src/edwin/input.scm +++ b/v7/src/edwin/input.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/input.scm,v 1.80 1989/08/07 08:44:56 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/input.scm,v 1.81 1989/08/12 08:32:19 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology ;;; @@ -174,8 +174,6 @@ B 3BAB8C (define editor-input-port) -(define (set-editor-input-port! port) - (set! editor-input-port port)) (define (with-editor-input-port new-port thunk) (fluid-let ((editor-input-port new-port)) (thunk))) diff --git a/v7/src/edwin/make.scm b/v7/src/edwin/make.scm index 197ddd9f9..17ebedf8d 100644 --- a/v7/src/edwin/make.scm +++ b/v7/src/edwin/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/make.scm,v 3.15 1989/08/11 11:50:45 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/make.scm,v 3.16 1989/08/12 08:32:23 cph Exp $ Copyright (c) 1989 Massachusetts Institute of Technology @@ -37,4 +37,4 @@ MIT in each case. |# (declare (usual-integrations)) (package/system-loader "edwin" '() 'QUERY) -(add-system! (make-system "Edwin" 3 15 '())) \ No newline at end of file +(add-system! (make-system "Edwin" 3 16 '())) \ No newline at end of file diff --git a/v7/src/edwin/modefs.scm b/v7/src/edwin/modefs.scm index e18df53d6..1c2fff500 100644 --- a/v7/src/edwin/modefs.scm +++ b/v7/src/edwin/modefs.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modefs.scm,v 1.120 1989/08/09 13:17:51 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/modefs.scm,v 1.121 1989/08/12 08:32:28 cph Exp $ ;;; ;;; Copyright (c) 1985, 1989 Massachusetts Institute of Technology ;;; @@ -229,7 +229,8 @@ and the cdrs of which are major modes." (define-key 'fundamental '(#\c-c #\c-s) 'select-transcript-buffer) (define-key 'fundamental '(#\c-h #\a) 'command-apropos)(define-key 'fundamental '(#\c-h #\c) 'describe-key-briefly) -(define-key 'fundamental '(#\c-h #\d) 'describe-command)(define-key 'fundamental '(#\c-h #\i) 'info) +(define-key 'fundamental '(#\c-h #\f) 'describe-command) +(define-key 'fundamental '(#\c-h #\i) 'info) (define-key 'fundamental '(#\c-h #\k) 'describe-key) (define-key 'fundamental '(#\c-h #\l) 'view-lossage) (define-key 'fundamental '(#\c-h #\m) 'describe-mode) diff --git a/v7/src/edwin/rename.scm b/v7/src/edwin/rename.scm index dda64a30c..2f241ba68 100644 --- a/v7/src/edwin/rename.scm +++ b/v7/src/edwin/rename.scm @@ -50,10 +50,8 @@ (let ((g<-e (lambda (g e) (local-assignment global g (lexical-reference edwin e))))) - (g<-e 'edit 'edwin) - (g<-e 'save-editor-files 'debug-save-files) - (g<-e 'reset-editor 'edwin-discard-state!) - (g<-e 'reset-editor-windows 'edwin-reset-windows)) (let ((e<-w + (g<-e 'save-editor-files 'debug-save-files)) + (let ((e<-w (lambda (e w) (lexical-assignment edwin e (lexical-reference window w))))) (e<-w 'window? 'buffer-frame?) diff --git a/v7/src/edwin/unix.scm b/v7/src/edwin/unix.scm index e7689aa6e..f22d0a51a 100644 --- a/v7/src/edwin/unix.scm +++ b/v7/src/edwin/unix.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/unix.scm,v 1.9 1989/08/09 13:18:11 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/unix.scm,v 1.10 1989/08/12 08:32:36 cph Exp $ ;;; ;;; Copyright (c) 1989 Massachusetts Institute of Technology ;;; @@ -71,6 +71,12 @@ (wrap (pathname-name-string pathname) (pathname-directory-path pathname))))) +(define (os/pathname->display-string pathname) + (let ((relative (pathname-relative? pathname (home-directory-pathname)))) + (if relative + (string-append "~/" (pathname->string relative)) + (pathname->string pathname)))) + (define-variable backup-by-copying-when-linked "*Non-false means use copying to create backups for files with multiple names. This causes the alternate names to refer to the latest version as edited. @@ -228,6 +234,22 @@ Includes the new backup. Must be > 0" (sort pathnames (lambda (x y) (string 0" ("txt" . text) ("y" . c)))) -(define (os/truncate-filename-for-modeline filename width) - (let ((length (string-length filename))) - (if (< 0 width length) - (let ((result - (substring - filename - (let ((index (- length width))) - (or (and (not (char=? #\/ (string-ref filename index))) - (substring-find-next-char filename index length - #\/)) - (1+ index))) - length))) - (string-set! result 0 #\$) - result) - filename))) \ No newline at end of file +(define (os/init-file-name) + "~/.edwin") + +(define os/find-file-initialization-filename + (let ((name-path (string->pathname ".edwin-ffi"))) + (lambda (pathname) + (or (and (equal? "scm" (pathname-type pathname)) + (let ((pathname (pathname-new-version pathname "ffi"))) + (and (file-exists? pathname) + pathname))) + (let ((pathname + (merge-pathnames name-path + (pathname-directory-path pathname)))) + (and (file-exists? pathname) + pathname)))))) \ No newline at end of file diff --git a/v7/src/edwin/utils.scm b/v7/src/edwin/utils.scm index 74e385f00..4e76e7d4f 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.17 1989/08/11 10:54:14 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/utils.scm,v 1.18 1989/08/12 08:32:42 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology ;;; @@ -175,9 +175,10 @@ (define (write-value value truncate?) (if (undefined-value? value) - (write-string ";No value") + (write-string "No value") (begin - (write-string ";Value: ") (if truncate? + (write-string "Value: ") + (if truncate? (fluid-let ((*unparser-list-depth-limit* 5) (*unparser-list-breadth-limit* 10)) (write value)) diff --git a/v7/src/edwin/xcom.scm b/v7/src/edwin/xcom.scm index bd399e2b7..d84acb447 100644 --- a/v7/src/edwin/xcom.scm +++ b/v7/src/edwin/xcom.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/xcom.scm,v 1.2 1989/08/11 11:50:55 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/xcom.scm,v 1.3 1989/08/12 08:32:52 cph Exp $ ;;; ;;; Copyright (c) 1989 Massachusetts Institute of Technology ;;; @@ -51,6 +51,7 @@ (x-window-x-size 1) (x-window-y-size 1) (x-window-set-size 3) + (x-window-set-position 3) (x-window-map 1) (x-window-unmap 1) (x-window-beep 1) @@ -119,10 +120,17 @@ (xterm-set-size xterm x-size y-size))))) (define-command x-set-size - "Set size of editor screen to (WIDTH, HEIGHT)." - "nScreen width\nnScreen height" + "Set size of editor screen to WIDTH x HEIGHT." + "nScreen width (chars)\nnScreen height (chars)" (lambda (width height) (xterm-set-size (current-xterm) (max 2 width) (max 2 height)))) + +(define-command x-set-position + "Set position of editor screen to (X,Y)." + "nX position (pixels)\nnY position (pixels)" + (lambda (x y) + (x-window-set-position (current-xterm) x y))) + (define-command x-set-border-width "Set width of border to WIDTH." "nSet border width" diff --git a/v7/src/edwin/xterm.scm b/v7/src/edwin/xterm.scm index 8f773f9d1..665b6e782 100644 --- a/v7/src/edwin/xterm.scm +++ b/v7/src/edwin/xterm.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/xterm.scm,v 1.7 1989/06/21 10:43:20 cph Rel $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/xterm.scm,v 1.8 1989/08/12 08:32:56 cph Exp $ ;;; ;;; Copyright (c) 1989 Massachusetts Institute of Technology ;;; @@ -403,7 +403,7 @@ ;;;; Display description for X displays -(define x-display) +(define x-display-type) (define x-display-data false) (define (get-x-display) @@ -418,13 +418,15 @@ unspecific) (define (initialize-package!) - (set! x-display - (make-display get-x-display - make-xterm-screen - make-xterm-input-port - with-editor-interrupts-from-x - with-x-interrupts-enabled - with-x-interrupts-disabled)) (initialize-buttons! 5) + (set! x-display-type + (make-display-type 'X + get-x-display + make-xterm-screen + make-xterm-input-port + with-editor-interrupts-from-x + with-x-interrupts-enabled + with-x-interrupts-disabled)) + (initialize-buttons! 5) (set! button1-down (button-downify 0)) (set! button2-down (button-downify 1)) (set! button3-down (button-downify 2))