From 82f81d4d5ca9dcc8515cfae3385fad1fc500e2c3 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 24 Feb 1995 00:37:51 +0000
Subject: [PATCH] Lots of changes to generalize this code for OS/2 and Windows.
---
v7/src/6001/edextra.scm | 357 ++++++++++-----------------------
v7/src/6001/floppy.scm | 422 ++++++++++++++++++++++++++++------------
v7/src/6001/make.scm | 21 +-
3 files changed, 426 insertions(+), 374 deletions(-)
diff --git a/v7/src/6001/edextra.scm b/v7/src/6001/edextra.scm
index 8de968660..770e95e4e 100644
--- a/v7/src/6001/edextra.scm
+++ b/v7/src/6001/edextra.scm
@@ -1,8 +1,8 @@
#| -*-Scheme-*-
-$Id: edextra.scm,v 1.19 1993/11/02 23:33:32 cph Exp $
+$Id: edextra.scm,v 1.20 1995/02/24 00:37:35 cph Exp $
-Copyright (c) 1992-93 Massachusetts Institute of Technology
+Copyright (c) 1992-95 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
@@ -36,41 +36,75 @@ MIT in each case. |#
(declare (usual-integrations))
-(load-edwin-library 'PRINT)
+(define student-root-directory)
+(define student-work-directory)
+(define pset-directory)
+(define pset-list-file)
-#|
-(define-command print-graphics
- "Print out the last displayed picture."
- '()
- (lambda ()
- (call-with-last-picture-file
- (lambda (filename)
- (if filename
- (begin
- (message "Spooling...")
- (shell-command
- false false false false
- (string-append "/users/u6001/bin/print-pgm.sh "
- filename
- " "
- (print/assemble-switches "Scheme Picture" '())))
- (append-message "done"))
- (editor-error "No picture to print!"))))))
-
-(environment-link-name '(edwin)
- '(student pictures)
- 'call-with-last-picture-file)
-|#
+(set! standard-editor-initialization
+ (let ((usual standard-editor-initialization))
+ (lambda ()
+ (usual)
+ (standard-login-initialization))))
+(define (standard-login-initialization)
+ (if (not (file-directory? student-root-directory))
+ (set! student-root-directory (user-homedir-pathname)))
+ (set! student-work-directory
+ (merge-pathnames "work/" student-root-directory))
+ (if (not (file-directory? student-work-directory))
+ (set! student-work-directory student-root-directory))
+ (set-default-directory student-work-directory)
+ (set-working-directory-pathname! student-work-directory)
+ (let ((hairy-floppy-stuff? (eq? 'UNIX microcode-id/operating-system)))
+ (if hairy-floppy-stuff?
+ (run-floppy-login-loop))
+ (let ((pathname (merge-pathnames "motd" student-root-directory)))
+ (if (file-exists? pathname)
+ (let ((buffer (temporary-buffer "*motd*")))
+ (call-with-current-continuation
+ (lambda (k)
+ (bind-condition-handler (list condition-type:file-error)
+ (lambda (condition)
+ condition
+ (kill-buffer buffer)
+ (k unspecific))
+ (lambda ()
+ (%insert-file (buffer-start buffer) pathname false)))
+ (set-buffer-point! buffer (buffer-start buffer))
+ (select-buffer buffer))))))
+ (if hairy-floppy-stuff?
+ (message "Login completed."))))
+
+(define-command logout
+ "Logout from the 6.001 Scheme system."
+ ()
+ (lambda ()
+ (fluid-let ((paranoid-exit? false))
+ ((ref-command save-buffers-kill-scheme) #f))))
+
(define (restore-focus-to-editor)
- (let ((screen (selected-screen)))
- (if (xterm-screen/grab-focus! screen)
- (xterm-screen/flush! screen))))
+ (let ((name (graphics-type-name (graphics-type #f))))
+ (case name
+ ((X)
+ (let ((screen (selected-screen)))
+ (if (xterm-screen/grab-focus! screen)
+ (xterm-screen/flush! screen))))
+ ((WIN32)
+ ((access set-focus (->environment '(win32)))
+ ((access get-handle (->environment '(win32))) 1)))
+ ((OS/2)
+ (os2-screen/activate! (selected-screen)))
+ (else
+ (error "Unsupported graphics type:" name)))))
(environment-link-name '(student pictures)
'(edwin)
'restore-focus-to-editor)
+(if (eq? 'UNIX microcode-id/operating-system)
+ (load-edwin-library 'PRINT))
+
(define-command print-graphics
"Print out window with graphics."
'()
@@ -86,8 +120,10 @@ MIT in each case. |#
(message "Spooling...")
(shell-command
false false false false
- (string-append "/users/u6001/bin/print-given-x-window "
- "0x"
+ (string-append (->namestring
+ (merge-pathnames "bin/print-given-x-window"
+ student-root-directory))
+ " 0x"
(number->string x-window-id 16)
" "
(print/assemble-switches "Scheme Picture" '())))
@@ -97,17 +133,18 @@ MIT in each case. |#
(message "Click desired window...")
(shell-command
false false false false
- (string-append "/users/u6001/bin/print-pointed-x-window "
+ (string-append (->namestring
+ (merge-pathnames "bin/print-pointed-x-window"
+ student-root-directory))
+ " "
(print/assemble-switches "Scheme Picture" '())))
(append-message "done"))
-
#|
;;; If using pointer (mouse).
xwd | /usr/local/pbmbin/xwdtopnm | /usr/local/pbmbin/ppmtopgm | /usr/local/pbmbin/pnmscale 4 | /usr/local/pbmbin/pgmtopbm -cluster4 | /usr/local/pbmbin/pbmtolj -resolution 300 | lpr -h
-
;;; If using *** = x-graphics/window-id
xwd -id *** | /usr/local/pbmbin/xwdtopnm | /usr/local/pbmbin/ppmtopgm | /usr/local/pbmbin/pnmscale 4 | /usr/local/pbmbin/pgmtopbm -cluster4 | /usr/local/pbmbin/pbmtolj -resolution 300 | lpr -h
@@ -119,11 +156,6 @@ Now, there is formatting stuff to be considered here, in print-pgm.sh.
;;; Wired-in pathnames
-;;; We look in the "psn" subdir for problem set n
-(define pset-dir "/users/u6001/psets/")
-(define pset-list-file (merge-pathnames "probsets.scm" pset-dir))
-(define student-dir "/users/u6001/work/")
-
;;; The structure "problem-sets" must be loaded from pset-list-file whenever
;;; the set of available problem sets changes, or when the default
;;; problem set changes. Files should appear with name and extension, but
@@ -224,7 +256,8 @@ Now, there is formatting stuff to be considered here, in print-pgm.sh.
ps
" installed; ask a TA for help.")))
(groups (ps-groups ps error-handler))
- (pset-path (merge-pathnames (string-append "ps" ps "/") pset-dir)))
+ (pset-path
+ (merge-pathnames (string-append "ps" ps "/") pset-directory)))
(if (not (files-all-exist? (groups/all-files groups) pset-path))
(error-handler))
(for-each (lambda (file)
@@ -244,7 +277,7 @@ Now, there is formatting stuff to be considered here, in print-pgm.sh.
(find-file-noselect filename #t)))
(groups/files-to-load&reference groups))
(for-each (lambda (file)
- (load-ps-copy-file file pset-path student-dir))
+ (load-ps-copy-file file pset-path student-work-directory))
(groups/files-to-copy groups)))))
(define (load-quietly pathname environment)
@@ -333,225 +366,51 @@ option the file from the problem set will not be installed.
(set-visited-pathname buffer to-file)
(write-buffer buffer)))
-;;;; DOS Filenames
-
-(define valid-dos-filename?
- (let ((invalid-chars
- (char-set-invert
- (char-set-union
- (char-set-union char-set:lower-case char-set:numeric)
- (char-set #\_ #\^ #\$ #\! #\# #\% #\& #\-
- #\{ #\} #\( #\) #\@ #\' #\`)))))
- (lambda (filename)
- (let ((end (string-length filename))
- (valid-name?
- (lambda (end)
- (and (<= 1 end 8)
- (not (substring-find-next-char-in-set filename 0 end
- invalid-chars))
- (not
- (there-exists? '("clock$" "con" "aux" "com1" "com2"
- "com3" "com4" "lpt1" "lpt2"
- "lpt3" "nul" "prn")
- (lambda (name)
- (substring=? filename 0 end
- name 0 (string-length name)))))))))
- (let ((dot (string-find-next-char filename #\.)))
- (if (not dot)
- (valid-name? end)
- (and (valid-name? dot)
- (<= 2 (- end dot) 4)
- (not (substring-find-next-char-in-set filename (+ dot 1) end
- invalid-chars)))))))))
-
-
-(define dos-filename-description
- "DOS filenames are between 1 and 8 characters long, inclusive. They
-may optionally be followed by a period and a suffix of 1 to 3
-characters.
-
-In other words, a valid filename consists of:
-
-* 1 to 8 characters, OR
-
-* 1 to 8 characters, followed by a period, followed by 1 to 3
- characters.
-
-The characters that may be used in a filename (or a suffix) are:
-
-* The lower case letters: a b c ... z
-
-* The digits: 0 1 2 ... 9
-
-* These special characters: ' ` ! @ # $ % ^ & ( ) - _ { }
-
-The period (.) may appear exactly once as a separator between the
-filename and the suffix.
-
-The following filenames are reserved and may not be used:
-
- aux clock$ com1 com2 com3 com4
- con lpt1 lpt2 lpt3 nul prn")
-
-;;;; 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)))))
-
-(set! default-homedir-pathname
- (lambda () (->pathname student-dir)))
-
-(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)))
-
-(set! standard-editor-initialization
- (let ((usual standard-editor-initialization))
- (lambda ()
- (usual)
- (standard-login-initialization))))
-
-(set! prompt-for-pathname*
- (let ((usual prompt-for-pathname*))
- (lambda (prompt directory verify-final-value? require-match?)
- (let ((pathname
- (usual prompt directory verify-final-value? require-match?)))
- (if (or (not (student-directory? pathname))
- (valid-dos-filename? (file-namestring pathname))
- (file-exists? pathname)
- (with-saved-configuration
- (lambda ()
- (delete-other-windows (current-window))
- (select-buffer
- (temporary-buffer " *invalid-filename-dialog*"))
- (append-string
- "The file name you have specified,\n\n\t")
- (append-string (file-namestring pathname))
- (append-string
- "
-
-is not a valid name for a DOS disk. If you create a file with this
-name, you will not be able to save it to your floppy disk.
-
-If you want to use this name anyway, answer \"yes\" to the question
-below. Otherwise, answer \"no\" to use a different name.
-----------------------------------------------------------------------
-")
- (append-string dos-filename-description)
- (prompt-for-yes-or-no? "Use this non-DOS name"))))
- pathname
- (prompt-for-pathname* prompt directory
- verify-final-value? require-match?))))))
-
-(define (student-directory? pathname)
- (string-prefix? working-directory (->namestring pathname)))
-
;;;; Customization
+(set! default-homedir-pathname (lambda () student-work-directory))
+
(set! editor-can-exit? false)
(set! scheme-can-quit? false)
(set! paranoid-exit? true)
-(set! x-screen-auto-raise true)
+(if (eq? 'X (graphics-type-name (graphics-type #f)))
+ (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-header-function
- (let ((default-reply-to false))
- (lambda (point)
- (let ((reply-to
- (prompt-for-string "Please enter an email address for replies"
- default-reply-to
- 'INSERTED-DEFAULT)))
- (if (not (string-null? reply-to))
- (begin
- (set! default-reply-to reply-to)
- (insert-string "From: " point)
- (insert-string reply-to point)
- (insert-newline point)
- (insert-string "Reply-to: " point)
- (insert-string reply-to point)
- (insert-newline point)))))))
+(let ((variable-bound?
+ (lambda (name)
+ (string-table-get editor-variables (symbol->string name)))))
+ (if (variable-bound? 'enable-compressed-files)
+ (set-variable! enable-compressed-files false))
+ (if (variable-bound? 'enable-encrypted-files)
+ (set-variable! enable-encrypted-files false)))
+
+(if (eq? 'UNIX microcode-id/operating-system)
+ (set-variable!
+ mail-header-function
+ (let ((default-reply-to false))
+ (lambda (point)
+ (let ((reply-to
+ (prompt-for-string "Please enter an email address for replies"
+ default-reply-to
+ 'INSERTED-DEFAULT)))
+ (if (not (string-null? reply-to))
+ (begin
+ (set! default-reply-to reply-to)
+ (insert-string "From: " point)
+ (insert-string reply-to point)
+ (insert-newline point)
+ (insert-string "Reply-to: " point)
+ (insert-string reply-to point)
+ (insert-newline point))))))))
(set-variable! select-buffer-not-found-hooks
(cons (lambda (name)
- (find-file-noselect (merge-pathnames name
- working-directory)
- true))
- (ref-variable select-buffer-not-found-hooks)))
-
-;; 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
+ (find-file-noselect
+ (merge-pathnames name student-work-directory)
+ true))
+ (ref-variable select-buffer-not-found-hooks)))
\ No newline at end of file
diff --git a/v7/src/6001/floppy.scm b/v7/src/6001/floppy.scm
index a49a1dd89..2e1c202cb 100644
--- a/v7/src/6001/floppy.scm
+++ b/v7/src/6001/floppy.scm
@@ -1,8 +1,8 @@
#| -*-Scheme-*-
-$Id: floppy.scm,v 1.15 1993/11/02 19:11:49 cph Exp $
+$Id: floppy.scm,v 1.16 1995/02/24 00:37:42 cph Exp $
-Copyright (c) 1992 Massachusetts Institute of Technology
+Copyright (c) 1992-95 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
@@ -32,41 +32,13 @@ Technology nor of any adaptation thereof in any advertising,
promotional, or sales literature without prior written consent from
MIT in each case. |#
-;;;; 6.001: Floppy Commands
+;;;; 6.001: HP-UX Floppy Commands
(declare (usual-integrations))
-;;;; Login and Logout
-
-(define (standard-login-initialization)
+(define (run-floppy-login-loop)
(set! floppy-contents-loaded? false)
- (let ((homedir (user-homedir-pathname)))
- (let ((workdir
- (let ((workdir (merge-pathnames "work/" homedir)))
- (if (file-directory? workdir)
- workdir
- homedir))))
- (set! working-directory (->namestring workdir))
- (set-default-directory workdir)
- (set-working-directory-pathname! workdir))
- (standard-configuration 'login login-loop)
- (let ((buffer (temporary-buffer "*motd*")))
- (call-with-current-continuation
- (lambda (k)
- (bind-condition-handler (list condition-type:file-error)
- (lambda (condition)
- condition
- (kill-buffer buffer)
- (k unspecific))
- (lambda ()
- (%insert-file (buffer-start buffer)
- (merge-pathnames "motd" homedir)
- false)))
- (set-buffer-point! buffer (buffer-start buffer))
- (select-buffer buffer)))))
- (message "Login completed."))
-
-(define floppy-contents-loaded?)
+ (standard-configuration 'login login-loop))
(define (login-loop)
(buffer-reset! (current-buffer))
@@ -97,6 +69,7 @@ N Practice login (without floppy). Select this option if you
ABLE TO SAVE YOUR WORK!
Q Quit. Select this option if you do not want to log in.")
+ (show-dialog)
(let loop ()
(let ((char
(prompt-for-char
@@ -123,8 +96,9 @@ the instrument room.")
"
----------------------------------------------------------------------
Please select one of your floppy disks, label it as your \"backup\"
-disk, and insert it into the drive. When you have done this, type any
-character to continue.")
+disk, and insert it into the drive. When you have done this,
+type any character to continue.")
+ (show-dialog)
(wait-for-user)
(if (initialize-floppy)
(begin
@@ -134,8 +108,19 @@ character to continue.")
Please eject your backup disk from the floppy drive.
Now select your other disk, label it as your \"primary\" disk, and
-insert it into the floppy drive. When you have done this, type any
-character to continue.")
+insert it into the floppy drive.")
+ (append-string
+ (case microcode-id/operating-system
+ ((DOS NT)
+ "
+Again, use the File Manager to format the floppy.")
+ ((OS/2)
+ "
+Again, use the Drive object to format the floppy.")))
+ (append-string
+ "
+When you have done this, type any character to continue.")
+ (show-dialog)
(wait-for-user)
(if (initialize-floppy)
(begin
@@ -144,6 +129,7 @@ character to continue.")
----------------------------------------------------------------------
Your disks are now initialized.
Type any character to finish logging in.")
+ (show-dialog)
(wait-for-user))
(login-loop)))
(login-loop)))))
@@ -163,6 +149,7 @@ computer. You should make sure that your disk is in the floppy drive.")
"
----------------------------------------------------------------------
")
+ (show-dialog)
(call-with-current-continuation
(lambda (k)
(handle-floppy-errors
@@ -197,52 +184,115 @@ If you have chosen this login option by mistake, please type the
letter N, which will return you to the login loop.
Otherwise, type Y to continue with the initialization process.")
+ (show-dialog)
(if (prompt-for-confirmation? "Continue with login")
(thunk)
(login-loop)))
-(define-command logout
- "Logout from the 6.001 Scheme system."
- ()
- (lambda ()
- (standard-configuration 'logout
- (lambda ()
- (fluid-let ((paranoid-exit? false))
- (save-buffers-and-exit false "Scheme"
- (lambda ()
- (let ((abort
- (lambda ()
- (append-string
- "
+(define (run-floppy-logout)
+ (standard-configuration 'logout
+ (lambda ()
+ (fluid-let ((paranoid-exit? false))
+ (save-buffers-and-exit false "Scheme"
+ (lambda ()
+ (let ((abort
+ (lambda ()
+ (append-string
+ "
If you want to log out without saving your files, answer \"yes\" to
the question below.
Answer \"no\" if you want to return to the editor without logging out.")
- (if (prompt-for-yes-or-no?
- "Log out without saving files")
- (exit-scheme)
- (abort-current-command)))))
- (if (not floppy-contents-loaded?)
- (begin
- (append-string "You logged in without a floppy disk.\n")
- (abort)))
- (let loop ()
- (call-with-current-continuation
- (lambda (k)
- (handle-floppy-errors
- (lambda ()
- (append-string
- "
+ (show-dialog)
+ (if (prompt-for-yes-or-no?
+ "Log out without saving files")
+ (exit-scheme)
+ (abort-current-command)))))
+ (if (not floppy-contents-loaded?)
+ (begin
+ (append-string
+ "You logged in without a floppy disk.\n")
+ (abort)))
+ (let loop ()
+ (call-with-current-continuation
+ (lambda (k)
+ (handle-floppy-errors
+ (lambda ()
+ (append-string
+ "
----------------------------------------------------------------------
")
- (within-continuation k loop))
- (lambda ()
- (append-string
- "
+ (show-dialog)
+ (within-continuation k loop))
+ (lambda ()
+ (append-string
+ "
----------------------------------------------------------------------")
- (abort))
- checkpoint-floppy)))))
- (exit-scheme))))))))
+ (abort))
+ checkpoint-floppy)))))
+ (exit-scheme)))))))
+
+(set-command-procedure! (ref-command-object logout) run-floppy-logout)
+
+;; 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)
+
+(define (standard-configuration command thunk)
+ (with-editor-interrupts-disabled
+ (lambda ()
+ (let loop ()
+ (call-with-current-continuation
+ (lambda (k)
+ (with-saved-configuration
+ (lambda ()
+ (delete-other-windows (current-window))
+ (let ((buffer
+ (temporary-buffer
+ (string-append
+ " *"
+ (symbol->string command)
+ "-dialog*"))))
+ (select-buffer buffer)
+ (handle-floppy-errors (lambda () (within-continuation k loop))
+ default-floppy-abort-handler
+ thunk))))))))))
+
+(define (with-saved-configuration thunk)
+ (let ((screen (selected-screen)))
+ (let ((configuration (screen-window-configuration screen)))
+ (fluid-let ((restore-saved-continuation? true))
+ (dynamic-wind
+ (lambda () unspecific)
+ thunk
+ (lambda ()
+ (if restore-saved-continuation?
+ (set-screen-window-configuration! screen configuration))))))))
+
+(define (dont-restore-saved-configuration)
+ (set! restore-saved-continuation? false)
+ unspecific)
+
+(define restore-saved-continuation?)
+
+(define (append-string string)
+ (insert-string string (buffer-end (current-buffer))))
+
+(define (show-dialog)
+ (let ((window (selected-window)))
+ (let ((buffer (window-buffer window)))
+ (set-window-point! window (buffer-start buffer))
+ (if (not (window-mark-visible? window (buffer-end buffer)))
+ (set-window-point! window (buffer-end buffer)))))
+ (update-screens! false)
+ (sit-for 0))
+
+(define (wait-for-user)
+ ;; This should ignore input events (like focus change).
+ (prompt-for-char "Type any character to continue"))
;;;; Initialize Floppy
@@ -408,6 +458,8 @@ then answer \"yes\" to the prompt below.")
(set! floppy-contents-loaded? true)
(append-string "\n\nFloppy contents loaded.")
(wait-for-user))
+
+(define floppy-contents-loaded?)
(define-command checkpoint-floppy
"Update a floppy disk to contain the same files as the working directory."
@@ -480,7 +532,7 @@ otherwise answer \"no\" to leave these files on your floppy.
(make-file-record
(file-namestring pathname)
(* (quotient (file-modification-time pathname) 60) 60)))
- (list-transform-negative (directory-read working-directory)
+ (list-transform-negative (directory-read student-work-directory)
file-directory?)))
(valid-dos-record?
(lambda (record)
@@ -681,9 +733,8 @@ M-x rename-file, or use the `r' command in Dired.")
"/dev/rfd:/")
(define (file-record/unix-name record)
- (string-append working-directory (file-record/name record)))
-
-(define working-directory)
+ (->namestring
+ (merge-pathnames (file-record/name record) student-work-directory)))
(define (file-record/name=? x y)
(string=? (file-record/name x) (file-record/name y)))
@@ -858,52 +909,179 @@ M-x rename-file, or use the `r' command in Dired.")
both
set*-only)))))))))
-(define (standard-configuration command thunk)
- (with-editor-interrupts-disabled
- (lambda ()
- (let loop ()
- (call-with-current-continuation
- (lambda (k)
- (with-saved-configuration
- (lambda ()
- (delete-other-windows (current-window))
- (let ((buffer
- (temporary-buffer
- (string-append
- " *"
- (symbol->string command)
- "-dialog*"))))
- (select-buffer buffer)
- (handle-floppy-errors
- (lambda () (within-continuation k loop))
- default-floppy-abort-handler
- thunk))))))))))
-
-(define (with-saved-configuration thunk)
- (let ((screen (selected-screen)))
- (let ((configuration (screen-window-configuration screen)))
- (fluid-let ((restore-saved-continuation? true))
- (dynamic-wind
- (lambda () unspecific)
- thunk
- (lambda ()
- (if restore-saved-continuation?
- (set-screen-window-configuration! screen configuration))))))))
-
-(define (dont-restore-saved-configuration)
- (set! restore-saved-continuation? false)
- unspecific)
-
-(define restore-saved-continuation?)
-
-(define (append-string string)
- (insert-string string)
- (update-screens! false)
- (sit-for 0))
-
(define (buffer->string buffer)
(extract-string (buffer-start buffer) (buffer-end buffer)))
+
+;;;; DOS Filenames
+
+(define valid-dos-filename?
+ (let ((invalid-chars
+ (char-set-invert
+ (char-set-union
+ (char-set-union char-set:lower-case char-set:numeric)
+ (char-set #\_ #\^ #\$ #\! #\# #\% #\& #\-
+ #\{ #\} #\( #\) #\@ #\' #\`)))))
+ (lambda (filename)
+ (let ((end (string-length filename))
+ (valid-name?
+ (lambda (end)
+ (and (<= 1 end 8)
+ (not (substring-find-next-char-in-set filename 0 end
+ invalid-chars))
+ (not
+ (there-exists? '("clock$" "con" "aux" "com1" "com2"
+ "com3" "com4" "lpt1" "lpt2"
+ "lpt3" "nul" "prn")
+ (lambda (name)
+ (substring=? filename 0 end
+ name 0 (string-length name)))))))))
+ (let ((dot (string-find-next-char filename #\.)))
+ (if (not dot)
+ (valid-name? end)
+ (and (valid-name? dot)
+ (<= 2 (- end dot) 4)
+ (not (substring-find-next-char-in-set filename (+ dot 1) end
+ invalid-chars)))))))))
+
+
+(define dos-filename-description
+ "DOS filenames are between 1 and 8 characters long, inclusive. They
+may optionally be followed by a period and a suffix of 1 to 3
+characters.
+
+In other words, a valid filename consists of:
+
+* 1 to 8 characters, OR
+
+* 1 to 8 characters, followed by a period, followed by 1 to 3
+ characters.
+
+The characters that may be used in a filename (or a suffix) are:
+
+* The lower case letters: a b c ... z
+
+* The digits: 0 1 2 ... 9
+
+* These special characters: ' ` ! @ # $ % ^ & ( ) - _ { }
+
+The period (.) may appear exactly once as a separator between the
+filename and the suffix.
+
+The following filenames are reserved and may not be used:
+
+ aux clock$ com1 com2 com3 com4
+ con lpt1 lpt2 lpt3 nul prn")
+
+;;;; 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 ()
+ (->namestring (merge-pathnames "default.bak" student-work-directory))))
+
+(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)))
+
+(set! prompt-for-pathname*
+ (let ((usual prompt-for-pathname*))
+ (lambda (prompt directory verify-final-value? require-match?)
+ (let ((pathname
+ (usual prompt directory verify-final-value? require-match?)))
+ (if (or (not (student-directory? pathname))
+ (valid-dos-filename? (file-namestring pathname))
+ (file-exists? pathname)
+ (with-saved-configuration
+ (lambda ()
+ (delete-other-windows (current-window))
+ (select-buffer
+ (temporary-buffer " *invalid-filename-dialog*"))
+ (append-string
+ "The file name you have specified,\n\n\t")
+ (append-string (file-namestring pathname))
+ (append-string
+ "
-(define (wait-for-user)
- ;; This should ignore input events (like focus change).
- (prompt-for-char "Type any character to continue"))
\ No newline at end of file
+is not a valid name for a DOS disk. If you create a file with this
+name, you will not be able to save it to your floppy disk.
+
+If you want to use this name anyway, answer \"yes\" to the question
+below. Otherwise, answer \"no\" to use a different name.
+----------------------------------------------------------------------
+")
+ (append-string dos-filename-description)
+ (prompt-for-yes-or-no? "Use this non-DOS name"))))
+ pathname
+ (prompt-for-pathname* prompt directory
+ verify-final-value? require-match?))))))
+
+(define (student-directory? pathname)
+ (let ((pathname (->pathname pathname))
+ (prefix student-work-directory))
+ (and (host=? (pathname-host pathname) (pathname-host prefix))
+ (equal? (pathname-device pathname) (pathname-device prefix))
+ (let loop
+ ((d1 (pathname-directory pathname))
+ (d2 (pathname-directory prefix)))
+ (or (null? d2)
+ (and (not (null? d1))
+ (equal? (car d1) (car d2))
+ (loop (cdr d1) (cdr d2))))))))
\ No newline at end of file
diff --git a/v7/src/6001/make.scm b/v7/src/6001/make.scm
index b9136262d..140481688 100644
--- a/v7/src/6001/make.scm
+++ b/v7/src/6001/make.scm
@@ -1,8 +1,8 @@
#| -*-Scheme-*-
-$Id: make.scm,v 15.21 1993/08/12 07:01:10 cph Exp $
+$Id: make.scm,v 15.22 1995/02/24 00:37:51 cph Exp $
-Copyright (c) 1991-93 Massachusetts Institute of Technology
+Copyright (c) 1991-95 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
@@ -37,7 +37,10 @@ MIT in each case. |#
(declare (usual-integrations))
(package/system-loader "6001" '() 'QUERY)
-(load '("edextra" "floppy") (->environment '(edwin)))
+(let ((edwin (->environment '(edwin))))
+ (load "edextra" edwin)
+ (if (eq? 'UNIX microcode-id/operating-system)
+ (load "floppy" edwin)))
((access initialize-package! (->environment '(student scode-rewriting))))
(add-system! (make-system "6.001" 15 21 '()))
@@ -56,7 +59,19 @@ MIT in each case. |#
(set! hook/quit (lambda () (warn "QUIT has been disabled.")))
(set! user-initial-environment (->environment '(student)))
+(in-package (->environment '(edwin))
+ (set! student-root-directory
+ (merge-pathnames "/users/u6001/" (user-homedir-pathname)))
+ (set! student-work-directory
+ (merge-pathnames "work/" student-root-directory))
+ (set! pset-directory (merge-pathnames "psets/" student-root-directory))
+ (set! pset-list-file (merge-pathnames "probsets.scm" pset-directory)))
+
(in-package (->environment '(student))
+ (define u6001-dir
+ (let ((homedir (access student-root-directory (->environment '(edwin)))))
+ (lambda (filename)
+ (->namestring (merge-pathnames filename homedir)))))
(define nil #f))
(ge '(student))
\ No newline at end of file
--
2.25.1