From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 28 Nov 1994 05:46:24 +0000 (+0000)
Subject: Initial revision
X-Git-Tag: 20090517-FFI~6922
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=ec39513c1a97080f522f188d7d8d90b271bf2849;p=mit-scheme.git

Initial revision
---

diff --git a/v7/src/runtime/os2dir.scm b/v7/src/runtime/os2dir.scm
new file mode 100644
index 000000000..fca523b25
--- /dev/null
+++ b/v7/src/runtime/os2dir.scm
@@ -0,0 +1,85 @@
+#| -*-Scheme-*-
+
+$Id: os2dir.scm,v 1.1 1994/11/28 05:45:36 cph Exp $
+
+Copyright (c) 1994 Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science.  Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Directory Operations -- OS/2
+;;; package: (runtime directory)
+
+(declare (usual-integrations))
+
+(define *expand-directory-prefixes?* true)
+
+(define (directory-read pattern #!optional sort?)
+  (if (if (default-object? sort?) true sort?)
+      (sort (directory-read-nosort pattern) pathname<?)
+      (directory-read-nosort pattern)))
+
+(define (directory-read-nosort pattern)
+  (let ((pattern
+	 (let ((pattern (merge-pathnames pattern)))
+	   (if (pathname-name pattern)
+	       pattern
+	       (make-pathname (pathname-host pattern)
+			      (pathname-device pattern)
+			      (pathname-directory pattern)
+			      'WILD
+			      'WILD
+			      (pathname-version pattern))))))
+    (map (let ((directory-path (directory-pathname pattern)))
+	   (lambda (pathname)
+	     (merge-pathnames pathname directory-path)))
+	 (let ((fnames (generate-directory-pathnames pattern)))
+	   (fluid-let ((*expand-directory-prefixes?* false))
+	     (map ->pathname fnames))))))
+
+(define (generate-directory-pathnames pathname)
+  (let ((channel (directory-channel-open (->namestring pathname))))
+    (let loop ((result '()))
+      (let ((name (directory-channel-read channel)))
+	(if name
+	    (loop (cons name result))
+	    (begin
+	      (directory-channel-close channel)
+	      result))))))
+
+(define (pathname<? x y)
+  (or (component<? (pathname-name x) (pathname-name y))
+      (and (equal? (pathname-name x) (pathname-name y))
+	   (component<? (pathname-type x) (pathname-type y)))))
+
+(define (component<? x y)
+  (and y
+       (or (not x)
+	   (and (string? y)
+		(or (not (string? x))
+		    (string<? x y))))))
\ No newline at end of file
diff --git a/v7/src/runtime/os2prm.scm b/v7/src/runtime/os2prm.scm
new file mode 100644
index 000000000..8b809ece3
--- /dev/null
+++ b/v7/src/runtime/os2prm.scm
@@ -0,0 +1,187 @@
+#| -*-Scheme-*-
+
+$Id: os2prm.scm,v 1.1 1994/11/28 05:46:24 cph Exp $
+
+Copyright (c) 1994 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science.  Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Miscellaneous OS/2 Primitives
+;;; package: ()
+
+(declare (usual-integrations))
+
+(define (initialize-system-primitives!)
+  unspecific)
+
+(define (file-directory? filename)
+  ((ucode-primitive file-directory? 1)
+   (->namestring (merge-pathnames filename))))
+
+(define (file-symbolic-link? filename)
+  ((ucode-primitive file-symlink? 1)
+   (->namestring (merge-pathnames filename))))
+
+(define (file-access filename amode)
+  ((ucode-primitive file-access 2)
+   (->namestring (merge-pathnames filename))
+   amode))
+
+(define (file-readable? filename)
+  (file-access filename 4))
+
+(define (file-writable? filename)
+  ((ucode-primitive file-access 2)
+   (let ((pathname (merge-pathnames filename)))
+     (let ((filename (->namestring pathname)))
+       (if ((ucode-primitive file-exists? 1) filename)
+	   filename
+	   (directory-namestring pathname))))
+   2))
+
+(define (file-executable? filename)
+  (file-access filename 1))
+
+(define (make-directory name)
+  ((ucode-primitive directory-make 1)
+   (->namestring (pathname-as-directory (merge-pathnames name)))))
+
+(define (delete-directory name)
+  ((ucode-primitive directory-delete 1)
+   (->namestring (pathname-as-directory (merge-pathnames name)))))
+
+(define (file-modes filename)
+  ((ucode-primitive file-attributes 1)
+   (->namestring (merge-pathnames filename))))
+
+(define (set-file-modes! filename modes)
+  ((ucode-primitive set-file-attributes! 2)
+   (->namestring (merge-pathnames filename))
+   modes))
+
+(define (file-length filename)
+  ((ucode-primitive file-length 1)
+   (->namestring (merge-pathnames filename))))
+
+(define (file-modification-time filename)
+  ((ucode-primitive file-mod-time 1)
+   (->namestring (merge-pathnames filename))))
+(define file-modification-time-direct file-modification-time)
+(define file-modification-time-indirect file-modification-time)
+
+(define (file-access-time filename)
+  ((ucode-primitive file-access-time 1)
+   (->namestring (merge-pathnames filename))))
+(define file-access-time-direct file-access-time)
+(define file-access-time-indirect file-access-time)
+
+(define (set-file-times! filename access-time modification-time)
+  ((ucode-primitive set-file-times! 3)
+   (->namestring (merge-pathnames filename))
+   access-time
+   modification-time))
+
+(define (file-touch filename)
+  ((ucode-primitive file-touch 1) (->namestring (merge-pathnames filename))))
+
+(define (get-environment-variable name)
+  ((ucode-primitive get-environment-variable 1) name))
+
+(define (temporary-file-pathname)
+  (let ((root (merge-pathnames "_scm_tmp" (temporary-directory-pathname))))
+    (let loop ((ext 0))
+      (let ((pathname (pathname-new-type root (number->string ext))))
+	(if (allocate-temporary-file pathname)
+	    pathname
+	    (begin
+	      (if (> ext 999)
+		  (error "Can't find unique temporary pathname:" root))
+	      (loop (+ ext 1))))))))
+
+(define (temporary-directory-pathname)
+  (let ((try-directory
+	 (lambda (directory)
+	   (let ((directory
+		  (pathname-as-directory (merge-pathnames directory))))
+	     (and (file-directory? directory)
+		  (file-writable? directory)
+		  directory)))))
+    (let ((try-variable
+	   (lambda (name)
+	     (let ((value (get-environment-variable name)))
+	       (and value
+		    (try-directory value))))))
+      (or (try-variable "TEMP")
+	  (try-variable "TMP")
+	  (try-directory "\\tmp")
+	  (try-directory "c:\\")
+	  (try-directory ".")
+	  (try-directory "\\")
+	  (error "Can't find temporary directory.")))))
+
+(define (file-attributes filename)
+  ((ucode-primitive file-info 1)
+   (->namestring (merge-pathnames filename))))
+(define file-attributes-direct file-attributes)
+(define file-attributes-indirect file-attributes)
+
+(define-structure (file-attributes
+		   (type vector)
+		   (constructor #f)
+		   (conc-name file-attributes/))
+  (type false read-only true)
+  (access-time false read-only true)
+  (modification-time false read-only true)
+  (change-time false read-only true)
+  (length false read-only true)
+  (mode-string false read-only true))
+
+(define (file-attributes/n-links attributes)
+  attributes
+  1)
+
+(define (os2/current-home-directory)
+  (or (get-environment-variable "HOME")
+      (os2/user-home-directory (os2/current-user-name))))
+
+(define (os2/current-user-name)
+  (get-environment-variable "USER"))
+
+(define (os2/user-home-directory user-name)
+  (or (and user-name
+	   (let ((directory (get-environment-variable "USERDIR")))
+	     (and directory
+		  (pathname-new-name
+		   (pathname-as-directory (merge-pathnames directory))
+		   user-name))))
+      "\\"))
+
+;; These two aliases are needed by the DOS pathname parser.
+(define dos/current-home-directory os2/current-home-directory)
+(define dos/user-home-directory os2/user-home-directory)
\ No newline at end of file