Add first version of floppy code.

diff --git a/v7/src/6001/edextra.scm b/v7/src/6001/edextra.scm
index a01bfe77c066ea6bc7d95b09d74bf0ef42c77f75..64847a8298fe519227843f10137e36aaab817bf1 100644 (file)
--- a/v7/src/6001/edextra.scm
+++ b/v7/src/6001/edextra.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/6001/edextra.scm,v 1.9 1992/09/08 21:40:29 cph Exp $
+$Id: edextra.scm,v 1.10 1992/09/10 05:20:01 cph Exp $
 
 Copyright (c) 1992 Massachusetts Institute of Technology
 
@@ -222,4 +222,92 @@ MIT in each case. |#
                   (write-buffer buffer))
                 (append-message " -- done")
                 (find-file dest-file)))
-            (groups/files-to-copy groups))))))
\ No newline at end of file
+            (groups/files-to-copy groups))))))
+\f
+;;;; 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")
+\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

diff --git a/v7/src/6001/make.scm b/v7/src/6001/make.scm
index 006d86eed7fbbf4c7620ce7228d720452a2c3b10..52aa396d81f557410e1ae9b06bc1fad084e0d4a0 100644 (file)
--- a/v7/src/6001/make.scm
+++ b/v7/src/6001/make.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: make.scm,v 15.15 1992/09/10 05:19:51 cph Exp $
+$Id: make.scm,v 15.16 1992/09/10 05:21:53 cph Exp $
 
 Copyright (c) 1991-92 Massachusetts Institute of Technology
 
@@ -39,7 +39,7 @@ 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 6 '()))
+(add-system! (make-system "6.001" 15 16 '()))
 
 (set! repl:allow-restart-notifications? false)
 (set! repl:write-result-hash-numbers? false)