Move editor customizations from "make.scm" to "edextra.scm". Extend

filename customizations so that they do the usual thing when the files
being operated on are not part of the student environment.  Add
remaining backup and auto-save filename customizations.  Add
Scheme's file types to list of ignored types.  Disable key bindings
that exit the editor.

diff --git a/v7/src/6001/edextra.scm b/v7/src/6001/edextra.scm
index 64847a8298fe519227843f10137e36aaab817bf1..dc1219485a7a3ea527623d5fe147b034809cad23 100644 (file)
--- a/v7/src/6001/edextra.scm
+++ b/v7/src/6001/edextra.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: edextra.scm,v 1.10 1992/09/10 05:20:01 cph Exp $
+$Id: edextra.scm,v 1.11 1992/09/10 07:32:09 cph Exp $
 
 Copyright (c) 1992 Massachusetts Institute of Technology
 
@@ -129,7 +129,6 @@ MIT in each case. |#
               (groups/files-to-load groups)
               (groups/files-to-reference groups)
               (groups/files-to-load&reference groups)))
-
 \f
 ;;; Procedure to get the "files" object corresponding to a particular
 ;;; problem set.  Runs error-handler (which should never return) if
@@ -158,13 +157,11 @@ MIT in each case. |#
                (loop rest accumulated)
                (loop rest (cons first accumulated))))))))
 
-;;; Returns #t iff files all exist in directory.
+;;; Returns #t iff FILES all exist in DIRECTORY.
 (define (files-all-exist? files directory)
-  (let loop ((files files))
-    (or (null? files)
-       (and (file-exists?
-             (merge-pathnames directory (->pathname (car files))))
-            (loop (cdr files))))))
+  (for-all? files
+    (lambda (file)
+      (file-exists? (merge-pathnames directory file)))))
 \f
 (define (->string object)
   (if (string? object)
@@ -284,30 +281,119 @@ The following filenames are reserved and may not be used:
        aux     clock$  com1    com2    com3    com4
        con     lpt1    lpt2    lpt3    nul     prn")
 \f
-(define (os/auto-save-pathname pathname buffer)
-  (if (not pathname)
-      (merge-pathnames
-       (let ((name
-             (string-append
-              (let ((name (buffer-name buffer)))
-                (let ((index (string-find-next-char name #\.)))
-                  (if (not index)
-                      (if (> (string-length name) 8)
-                          (substring name 0 8)
-                          name)
-                      (substring name 0 (min 8 index)))))
-              ".asv")))
-        (if (valid-dos-filename? name)
-            name
-            "default.asv"))
-       (buffer-default-directory buffer))
-      (pathname-new-type pathname "asv")))
-
-(define (os/precious-backup-pathname pathname)
-  (pathname-new-type pathname "bak"))
-
-(define (os/default-backup-filename)
-  "~/work/default.bak")
-
-(define (os/buffer-backup-pathname truename)
-  (values (pathname-new-type truename "bak") '()))
\ No newline at end of file
+;;;; Overrides of Editor Procedures
+
+(set! os/auto-save-pathname
+      (let ((usual os/auto-save-pathname))
+       (lambda (pathname buffer)
+         (if pathname
+             (if (student-directory? pathname)
+                 (pathname-new-type pathname "asv")
+                 (usual pathname buffer))
+             (let ((directory (buffer-default-directory buffer)))
+               (if (student-directory? directory)
+                   (merge-pathnames
+                    (let ((name
+                           (string-append
+                            (let ((name (buffer-name buffer)))
+                              (let ((index (string-find-next-char name #\.)))
+                                (if (not index)
+                                    (if (> (string-length name) 8)
+                                        (substring name 0 8)
+                                        name)
+                                    (substring name 0 (min 8 index)))))
+                            ".asv")))
+                      (if (valid-dos-filename? name)
+                          name
+                          "default.asv"))
+                    directory)
+                   (usual pathname buffer)))))))
+
+(set! os/precious-backup-pathname
+      (let ((usual os/precious-backup-pathname))
+       (lambda (pathname)
+         (if (student-directory? pathname)
+             (pathname-new-type pathname "bak")
+             (usual pathname)))))
+
+(set! os/default-backup-filename
+      (lambda () (string-append working-directory "default.bak")))
+
+(set! os/buffer-backup-pathname
+      (let ((usual os/buffer-backup-pathname))
+       (lambda (truename)
+         (if (student-directory? truename)
+             (values (pathname-new-type truename "bak") '())
+             (usual truename)))))
+
+;;; These next two depend on the fact that they are only invoked when
+;;; the current buffer is the Dired buffer that is being tested.
+
+(set! os/backup-filename?
+      (let ((usual os/backup-filename?))
+       (lambda (filename)
+         (if (student-directory? (dired-buffer-directory (current-buffer)))
+             (equal? "bak" (pathname-type filename))
+             (usual filename)))))
+
+(set! os/auto-save-filename?
+      (let ((usual os/auto-save-filename?))
+       (lambda (filename)
+         (if (student-directory? (dired-buffer-directory (current-buffer)))
+             (equal? "asv" (pathname-type filename))
+             (usual filename)))))
+
+(define (dired-buffer-directory buffer)
+  ;; Similar to the definition in "dired.scm".  That definition should
+  ;; be exported in order to eliminate this redundant definition.
+  (or (buffer-get buffer 'DIRED-DIRECTORY)
+      (buffer-default-directory buffer)))
+
+(define (student-directory? pathname)
+  (string-prefix? working-directory (->namestring pathname)))
+
+(set! standard-editor-initialization
+      (let ((usual standard-editor-initialization))
+       (lambda ()
+         (usual)
+         (standard-login-initialization))))
+\f
+;;;; Customization
+
+(set! editor-can-exit? false)
+(set! scheme-can-quit? false)
+(set! paranoid-exit? true)
+(set! x-screen-auto-raise true)
+
+(set-variable! enable-transcript-buffer true)
+(set-variable! evaluate-in-inferior-repl true)
+(set-variable! repl-error-decision true)
+(set-variable! version-control true)
+(set-variable! trim-versions-without-asking true)
+(set-variable! enable-compressed-files false)
+(set-variable! enable-encrypted-files false)
+
+(set-variable! completion-ignored-extensions
+              (append '(".bci" ".bif" ".bin" ".com" ".ext")
+                      (ref-variable completion-ignored-extensions)))
+
+(set-variable!
+ mail-default-reply-to
+ (let ((default-reply-to false))
+   (lambda ()
+     (let ((reply-to
+           (prompt-for-string "Please enter an email address for replies"
+                              default-reply-to
+                              'INSERTED-DEFAULT)))
+       (if (string-null? reply-to)
+          false
+          (begin
+            (set! default-reply-to reply-to)
+            reply-to))))))
+
+;; Disable key bindings that exit the editor.
+;; M-x logout is all the students should need.
+(define-key 'fundamental '(#\c-x #\c-c) false)
+(define-key 'fundamental '(#\c-x #\c-z) false)
+(define-key 'fundamental '(#\c-x #\c) false)
+(define-key 'fundamental '(#\c-x #\z) false)
\ No newline at end of file

diff --git a/v7/src/6001/make.scm b/v7/src/6001/make.scm
index 52aa396d81f557410e1ae9b06bc1fad084e0d4a0..21eae9a8867aa4c9abbb6a6a9e1e0ae904607ab1 100644 (file)
--- a/v7/src/6001/make.scm
+++ b/v7/src/6001/make.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: make.scm,v 15.16 1992/09/10 05:21:53 cph Exp $
+$Id: make.scm,v 15.17 1992/09/10 07:32:50 cph Exp $
 
 Copyright (c) 1991-92 Massachusetts Institute of Technology
 
@@ -39,8 +39,9 @@ MIT in each case. |#
 (package/system-loader "6001" '() 'QUERY)
 (load '("edextra" "floppy") (->environment '(edwin)))
 ((access initialize-package! (->environment '(student scode-rewriting))))
-(add-system! (make-system "6.001" 15 16 '()))
+(add-system! (make-system "6.001" 15 17 '()))
 
+;;; Customize the runtime system:
 (set! repl:allow-restart-notifications? false)
 (set! repl:write-result-hash-numbers? false)
 (set! *unparse-disambiguate-null-as-itself?* false)
@@ -52,35 +53,4 @@ MIT in each case. |#
              (->environment '(runtime user-interface)))
       false)
 
-(in-package (->environment '(edwin))
-  (set! editor-can-exit? false)
-  (set! scheme-can-quit? false)
-  (set! paranoid-exit? true)
-  (set! x-screen-auto-raise true)
-  (set! standard-editor-initialization
-       (let ((usual standard-editor-initialization))
-         (lambda ()
-           (usual)
-           (standard-login-initialization))))
-  (set-variable-value! edwin-variable$enable-transcript-buffer true)
-  (set-variable-value! edwin-variable$evaluate-in-inferior-repl true)
-  (set-variable-value! edwin-variable$repl-error-decision true)
-  (set-variable-value! edwin-variable$version-control true)
-  (set-variable-value! edwin-variable$trim-versions-without-asking true)
-  (set-variable-value! edwin-variable$enable-compressed-files false)
-  (set-variable-value! edwin-variable$enable-encrypted-files false)
-  (set-variable-value!
-   edwin-variable$mail-default-reply-to
-   (let ((default-reply-to false))
-     (lambda ()
-       (let ((reply-to
-             (prompt-for-string "Please enter an email address for replies"
-                                default-reply-to
-                                'INSERTED-DEFAULT)))
-        (if (string-null? reply-to)
-            false
-            (begin
-              (set! default-reply-to reply-to)
-              reply-to)))))))
-
 (ge '(student))
\ No newline at end of file