--- /dev/null
+#| -*-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))
+\f
+(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
--- /dev/null
+#| -*-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))
+\f
+(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))
+\f
+(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
projects / mit-scheme.git / commitdiff