From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 28 Oct 1995 01:14:16 +0000 (+0000)
Subject: New file "ntprm.scm" has Win32 primitive interface, which is now
X-Git-Tag: 20090517-FFI~5831
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=1f5f09df488c09991d9b7aea945abbfc9f2c6a30;p=mit-scheme.git

New file "ntprm.scm" has Win32 primitive interface, which is now
different from the DOS primitive interface.
---

diff --git a/v7/src/runtime/dosprm.scm b/v7/src/runtime/dosprm.scm
index 86a330eac..01045b5e3 100644
--- a/v7/src/runtime/dosprm.scm
+++ b/v7/src/runtime/dosprm.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: dosprm.scm,v 1.34 1995/10/27 08:00:18 cph Exp $
+$Id: dosprm.scm,v 1.35 1995/10/28 01:14:16 cph Exp $
 
 Copyright (c) 1992-95 Massachusetts Institute of Technology
 
@@ -298,33 +298,61 @@ MIT in each case. |#
     (add-event-receiver! event:after-restart reset!)))
 
 (define (dos/fs-drive-type pathname)
-  (cons (nt-volume-info/file-system-name (nt-volume-info pathname)) ""))
+  pathname
+  (cons "FAT" ""))
 
 (define (dos/fs-long-filenames? pathname)
-  ;; 32 is random -- FAT is 12 and everything else is much larger.
-  (> (nt-volume-info/max-component-length (nt-volume-info pathname)) 32))
-
-(define (nt-volume-info pathname)
-  (let ((root
-	 (pathname-new-directory
-	  (directory-pathname (merge-pathnames pathname))
-	  '(ABSOLUTE))))
-    (let ((info
-	   ((ucode-primitive nt-get-volume-information 1)
-	    (->namestring root))))
-      (if (not info)
-	  (error "Error reading volume information:" root))
-      info)))
-
-(define-structure (nt-volume-info (type vector)
-				  (constructor #f)
-				  (conc-name nt-volume-info/))
-  (name #f read-only #t)
-  (serial-number #f read-only #t)
-  (max-component-length #f read-only #t)
-  (file-system-flags #f read-only #t)
-  (file-system-name #f read-only #t))
-
+  pathname
+  #f)
+
+(define (copy-file from to)
+  (let ((input-filename (->namestring (merge-pathnames from)))
+	(output-filename (->namestring (merge-pathnames to))))
+    (let ((input-channel false)
+	  (output-channel false))
+      (dynamic-wind
+       (lambda ()
+	 (set! input-channel (file-open-input-channel input-filename))
+	 (set! output-channel
+	       (begin
+		 ((ucode-primitive file-remove-link 1) output-filename)
+		 (file-open-output-channel output-filename)))
+	 unspecific)
+       (lambda ()
+	 (let ((source-length (channel-file-length input-channel))
+	       (buffer-length 8192))
+	   (if (zero? source-length)
+	       0
+	       (let* ((buffer (make-string buffer-length))
+		      (transfer
+		       (lambda (length)
+			 (let ((n-read
+				(channel-read-block input-channel
+						    buffer
+						    0
+						    length)))
+			   (if (positive? n-read)
+			       (channel-write-block output-channel
+						    buffer
+						    0
+						    n-read))
+			   n-read))))
+		 (let loop ((source-length source-length))
+		   (if (< source-length buffer-length)
+		       (transfer source-length)
+		       (let ((n-read (transfer buffer-length)))
+			 (if (= n-read buffer-length)
+			     (+ (loop (- source-length buffer-length))
+				buffer-length)
+			     n-read))))))))
+       (lambda ()
+	 (if output-channel (channel-close output-channel))
+	 (if input-channel (channel-close input-channel)))))
+    (set-file-times! output-filename
+		     #f
+		     (file-modification-time input-filename))
+    (set-file-modes! output-filename (file-modes input-filename))))
+
 (define (select-internal console? handles block?)
   (let* ((nt/qs-allinput #xff)
 	 (select
@@ -346,10 +374,7 @@ MIT in each case. |#
 (define console-channel-descriptor)
 
 (define (cache-console-channel-descriptor!)
-  (set! console-channel-descriptor
-	(if (eq? 'DOS microcode-id/operating-system)
-	    -1
-	    ((ucode-primitive get-handle 1) 1)))
+  (set! console-channel-descriptor -1)
   unspecific)
 
 (define (select-descriptor descriptor block?)
diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg
index b7c177f24..17515fe44 100644
--- a/v8/src/runtime/runtime.pkg
+++ b/v8/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.264 1995/09/11 19:05:39 cph Exp $
+$Id: runtime.pkg,v 14.265 1995/10/28 01:12:35 cph Exp $
 
 Copyright (c) 1988-95 Massachusetts Institute of Technology
 
@@ -54,7 +54,8 @@ MIT in each case. |#
     (else))
   (file-case os-type
     ((unix) "unxprm")
-    ((dos nt) "dosprm")
+    ((dos) "dosprm")
+    ((nt) "ntprm")
     ((os/2) "os2prm")
     (else)))