;;; -*-Scheme-*-
;;;
-;;; $Id: dos.scm,v 1.28 1995/10/24 05:37:48 cph Exp $
+;;; $Id: dos.scm,v 1.29 1995/10/25 02:19:50 cph Exp $
;;;
;;; Copyright (c) 1992-95 Massachusetts Institute of Technology
;;;
(declare (usual-integrations))
\f
-(define-variable backup-by-copying-when-linked
- "True means use copying to create backups for files with multiple names.
-This causes the alternate names to refer to the latest version as edited.
-This variable is relevant only if backup-by-copying is false."
- false
- boolean?)
+(define dos/encoding-pathname-types
+ '())
-(define-variable backup-by-copying-when-mismatch
- "True means create backups by copying if this preserves owner or group.
-Renaming may still be used (subject to control of other variables)
-when it would not result in changing the owner or group of the file;
-that is, for files which are owned by you and whose group matches
-the default for a new file created there by you.
-This variable is relevant only if Backup By Copying is false."
- false
- boolean?)
-
-(define-variable version-control
- "Control use of version numbers for backup files.
-#T means make numeric backup versions unconditionally.
-#F means make them for files that have some already.
-'NEVER means do not make them."
- true
- (lambda (thing)
- (or (eq? thing 'NEVER) (boolean? thing))))
-
-(define-variable kept-old-versions
- "Number of oldest versions to keep when a new numbered backup is made."
- 2
- exact-nonnegative-integer?)
-
-(define-variable kept-new-versions
- "Number of newest versions to keep when a new numbered backup is made.
-Includes the new backup. Must be > 0."
- 2
- (lambda (n) (and (exact-integer? n) (> n 0))))
-\f
-(define os/directory-char-set (char-set #\\ #\/))
-(define os/expand-char-set (char-set #\$ #\~))
-
-(define (os/trim-pathname-string string prefix)
- (let ((index (string-match-forward prefix string)))
- (if (and index
- (re-match-substring-forward
- (re-compile-pattern "[\\/$~]\\|[a-zA-Z]:" #t)
- #t #f string index (string-length string)))
- (string-tail string index)
- string)))
-
-(define os/pathname->display-string
- ->namestring)
-
-(define (file-type->version type version)
- (let ((version-string
- (and (fix:fixnum? version)
- (number->string (fix:remainder version 1000)))))
- (if (not version-string)
- (error "Illegal version" version)
- (let ((version-string
- (string-pad-left version-string 3 #\0)))
- (if (string? type)
- (if (fix:> (string-length type) 0)
- (string-append (substring type 0 1)
- (substring version-string 1 3))
- version-string)
- version-string)))))
-
-(define (filename->version-number filename)
- (let ((type (pathname-type filename)))
- (and (string? type)
- (fix:= (string-length type) 3)
- (or (string->number type)
- (string->number (substring type 1 3))))))
-
-(define (os/auto-save-pathname pathname buffer)
- buffer
- (pathname-new-type pathname
- (file-type->version (pathname-type pathname) 0)))
-
-(define (os/precious-backup-pathname pathname)
- ;; Use the autosave name for the precious backup
- (pathname-new-type pathname
- (file-type->version (pathname-type pathname) 0)))
+(define dos/executable-pathname-types
+ ;; Not sure if there are other possibilities under WinNT and/or Win95.
+ '("exe" "com" "bat"))
-(define (os/backup-buffer? truename)
- (let ((attrs (file-attributes truename)))
- (and attrs
- (memv (string-ref (file-attributes/mode-string attrs) 0)
- '(#\- #\l))
- (not (let ((directory (pathname-directory truename)))
- (and (pair? directory)
- (eq? 'ABSOLUTE (car directory))
- (pair? (cdr directory))
- (eqv? "tmp" (cadr directory))))))))
+(define dos/default-shell-file-name
+ ;; Not sure if this is right for WinNT and/or Win95.
+ "command.com")
-(define (os/default-backup-filename)
- "c:/tmp/edwin.bak")
+(define (os/form-shell-command command)
+ ;; Not sure if this is right.
+ (list "/c" command))
-(define (os/truncate-filename-for-modeline filename width)
- (let ((length (string-length filename)))
- (if (< 0 width length)
- (let ((result
- (substring
- filename
- (let ((index (- length width)))
- (or (and (not
- (char-set-member? os/directory-char-set
- (string-ref filename index)))
- (substring-find-next-char-in-set
- filename index length os/directory-char-set))
- (1+ index)))
- length)))
- (string-set! result 0 #\$)
- result)
- filename)))
-\f
-(define (os/backup-by-copying? truename buffer)
- truename buffer
- false)
-
-(define (os/buffer-backup-pathname truename)
- (let ((directory (directory-namestring truename))
- (type (pathname-type truename))
- (filename (pathname-name truename)))
+(define (os/directory-list directory)
+ (os/directory-list-completions directory ""))
- (define (no-versions)
- (values (pathname-new-type truename (file-type->version type 0)) '()))
- (define (version->pathname version)
- (pathname-new-type truename (file-type->version type version)))
- (define (files->versions files)
- (if (or (not files) (null? files))
- '()
- (let ((type-number (filename->version-number (car files))))
- (if type-number
- (cons type-number (files->versions (cdr files)))
- (files->versions (cdr files))))))
-
- (if (eq? 'NEVER (ref-variable version-control))
- (no-versions)
- (let ((search-name (string-append filename ".")))
- (let ((filenames
- (os/directory-list-completions directory search-name)))
- (let ((versions (sort (files->versions filenames) <)))
- (let ((high-water-mark (apply max (cons 0 versions))))
- (if (or (ref-variable version-control)
- (positive? high-water-mark))
- (values
- (version->pathname (+ high-water-mark 1))
- (let ((start (ref-variable kept-old-versions))
- (end (fix:- (length versions)
- (fix:-1+
- (ref-variable kept-new-versions)))))
- (if (fix:< start end)
- (map version->pathname
- (sublist versions start end))
- '())))
- (no-versions)))))))))
-\f
(define (os/directory-list-completions directory prefix)
- (define (->directory-namestring s)
- (->namestring (pathname-as-directory (->pathname s))))
-
- (define (->directory-wildcard s)
- (string-append (->directory-namestring s)
- "*.*"))
-
(let ((plen (string-length prefix)))
- (let loop ((pathnames (directory-read (->directory-wildcard directory))))
+ (let loop ((pathnames (directory-read (pathname-as-directory directory))))
(if (null? pathnames)
'()
(let ((filename (file-namestring (car pathnames))))
(cons filename (loop (cdr pathnames)))
(loop (cdr pathnames))))))))
-(define (os/directory-list directory)
- (os/directory-list-completions directory ""))
-\f
-(define dos/encoding-pathname-types '())
-
-(define dos/backup-suffixes '())
-
-(define (os/backup-filename? filename)
- (let ((version (filename->version-number filename)))
- (and (fix:fixnum? version)
- (fix:> version 0))))
-
-(define (os/numeric-backup-filename? filename)
- (let ((type (pathname-type filename)))
- (and (string? type)
- (fix:= (string-length type) 3)
- (let ((version (string->number type)))
- (and version
- (cons (->namestring (pathname-new-type filename #f))
- version)))
- (let ((version (substring->number type 1 3)))
- (and version
- (cons (->namestring (pathname-new-type filename
- (string-head type 1)))
- version))))))
-
-(define (os/auto-save-filename? filename)
- (let ((version (filename->version-number filename)))
- (and (fix:fixnum? version)
- (fix:= version 0))))
-
-(define (os/pathname-type-for-mode pathname)
- (let ((type (pathname-type pathname)))
- (if (member type dos/encoding-pathname-types)
- (pathname-type (->namestring (pathname-new-type pathname false)))
- type)))
-
-(define (os/completion-ignore-filename? filename)
- (or (os/backup-filename? filename)
- (os/auto-save-filename? filename)
- (and (not (file-directory? filename))
- (there-exists? (ref-variable completion-ignored-extensions)
- (lambda (extension)
- (string-suffix? extension filename))))))
+(define (os/set-file-modes-writable! pathname)
+ (set-file-modes! pathname #o777))
-(define (os/completion-ignored-extensions)
- (append '(".bin" ".com" ".ext"
- ".inf" ".bif" ".bsm" ".bci" ".bcs"
- ".psb" ".moc" ".fni"
- ".bco" ".bld" ".bad" ".glo" ".fre"
- ".obj" ".exe" ".pif" ".grp"
- ".dvi" ".toc" ".log" ".aux")
- (list-copy dos/backup-suffixes)))
+(define (os/scheme-can-quit?)
+ #t)
-(define-variable completion-ignored-extensions
- "Completion ignores filenames ending in any string in this list."
- (os/completion-ignored-extensions)
- (lambda (extensions)
- (and (list? extensions)
- (for-all? extensions
- (lambda (extension)
- (and (string? extension)
- (not (string-null? extension))))))))
+(define (os/quit dir)
+ (with-real-working-directory-pathname dir %quit))
-(define (os/file-type-to-major-mode)
- (alist-copy
- `(("asm" . midas)
- ("bat" . text)
- ("bib" . text)
- ("c" . c)
- ("h" . c)
- ("m4" . midas)
- ("pas" . pascal)
- ("s" . scheme)
- ("scm" . scheme)
- ("txi" . texinfo)
- ("txt" . text))))
-\f
-(define (os/init-file-name)
- (let ((user-init-file
- (merge-pathnames "edwin.ini"
- (pathname-as-directory (current-home-directory)))))
- (if (file-exists? user-init-file)
- (->namestring user-init-file)
- "/scheme/lib/edwin.ini")))
+(define (with-real-working-directory-pathname dir thunk)
+ (let ((inside (->namestring (directory-pathname-as-file dir)))
+ (outside false))
+ (dynamic-wind
+ (lambda ()
+ (stop-thread-timer)
+ (set! outside
+ (->namestring
+ (directory-pathname-as-file (working-directory-pathname))))
+ (set-working-directory-pathname! inside)
+ ((ucode-primitive set-working-directory-pathname! 1) inside))
+ thunk
+ (lambda ()
+ (set! inside
+ (->namestring
+ (directory-pathname-as-file (working-directory-pathname))))
+ ((ucode-primitive set-working-directory-pathname! 1) outside)
+ (set-working-directory-pathname! outside)
+ (start-thread-timer)))))
-(define (os/find-file-initialization-filename pathname)
- (or (and (equal? "scm" (pathname-type pathname))
- (let ((pathname (pathname-new-type pathname "ffi")))
- (and (file-exists? pathname)
- pathname)))
- (let ((pathname
- (merge-pathnames "edwin.ffi" (directory-pathname pathname))))
- (and (file-exists? pathname)
- pathname))))
+(define (os/interprogram-cut string push?) string push? unspecific)
+(define (os/interprogram-paste) #f)
(define (os/read-file-methods) '())
(define (os/write-file-methods) '())
(define (os/alternate-pathnames group pathname) group pathname '())
+
+(define (os/sendmail-program) "sendmail.exe")
+(define (os/rmail-pop-procedure) #f)
+(define (os/hostname) (error "OS/HOSTNAME procedure unimplemented."))
\f
;;;; Dired customization
;; 'DIRECTORY means FILE is a directory and a full listing is expected.
;; 'FILE means FILE itself should be listed, and not its contents.
;; SWITCHES are ignored.
- (case type
- ((WILDCARD)
- (generate-dired-listing! file mark))
- ((DIRECTORY)
- (generate-dired-listing!
- (string-append (->namestring (pathname-as-directory file))
- "*.*")
- mark))
- (else
- (generate-dired-entry! file mark))))
-
-;;; Scheme version of ls
+ (generate-dired-listing (if (eq? type 'DIRECTORY)
+ (pathname-as-directory file)
+ file)
+ mark))
(define (generate-dired-listing! pathname point)
- (let ((files (directory-read (->namestring (merge-pathnames pathname)))))
+ (let ((files (directory-read pathname)))
(for-each (lambda (file) (generate-dired-entry! file point))
files)))
(file-time->string (file-attributes/modification-time attr))))
(if (string? time-string)
(or (let ((len (string-length time-string)))
- (and (fix:> len 5) ;; Grap the space char as well
+ (and (fix:> len 5) ;; Grab the space char as well
(string-append (substring time-string (fix:- len 5) len)
" "
(substring time-string 0 (fix:- len 5)))))
""))))
(let ((name (file-namestring file))
- (attr (or (file-attributes file)
- (dummy-file-attributes))))
+ (attr (or (file-attributes file) (dummy-file-attributes))))
(let ((entry (string-append
(string-pad-right ; Mode string
(file-attributes/mode-string attr) 12 #\Space)
(mark-temporary! point)))))
(define-integrable (dummy-file-attributes)
- '#(#f 0 0 0 0 0 0 0 "----------" 0))
-\f
-(define (os/scheme-can-quit?)
- true)
-
-(define (os/quit dir)
- (with-real-working-directory-pathname dir %quit))
-
-(define (with-real-working-directory-pathname dir thunk)
- (let ((inside (->namestring (directory-pathname-as-file dir)))
- (outside false))
- (dynamic-wind
- (lambda ()
- (stop-thread-timer)
- (set! outside (->namestring
- (directory-pathname-as-file
- (working-directory-pathname))))
- (set-working-directory-pathname! inside)
- ((ucode-primitive set-working-directory-pathname! 1) inside))
- thunk
- (lambda ()
- (set! inside (->namestring
- (directory-pathname-as-file
- (working-directory-pathname))))
- ((ucode-primitive set-working-directory-pathname! 1) outside)
- (set-working-directory-pathname! outside)
- (start-thread-timer)))))
-
-(define (os/set-file-modes-writable! pathname)
- (set-file-modes! pathname #o777))
-
-(define (os/sendmail-program)
- "sendmail.exe")
-
-(define (os/rmail-pop-procedure)
- #f)
-
-(define (os/hostname)
- (error "OS/HOSTNAME procedure unimplemented."))
-
-(define (os/interprogram-cut string push?)
- string push?
- unspecific)
-
-(define (os/interprogram-paste)
- #f)
-
-(define (os/comint-filename-region start point end)
- (let ((chars "]\\\\A-Za-z0-9!#$%&'()+,.:;=@[^_`{}~---"))
- (let ((start (skip-chars-backward chars point start)))
- (make-region start (skip-chars-forward chars start end)))))
-\f
-;;;; Subprocess/Shell Support
-
-(define (os/parse-path-string string)
- (let ((end (string-length string))
- (substring
- (lambda (string start end)
- (pathname-as-directory (substring string start end)))))
- (let loop ((start 0))
- (if (< start end)
- (let ((index (substring-find-next-char string start end #\;)))
- (if index
- (if (= index start)
- (loop (+ index 1))
- (cons (substring string start index)
- (loop (+ index 1))))
- (list (substring string start end))))
- '()))))
-
-(define (os/find-program program default-directory)
- (or (dos/find-program program (ref-variable exec-path) default-directory)
- (error "Can't find program:" (->namestring program))))
-
-(define (dos/find-program program exec-path default-directory)
- (let* ((types dos/executable-suffixes)
- (try
- (lambda (pathname)
- (let ((type (pathname-type pathname)))
- (if type
- (and (member type types)
- (file-exists? pathname)
- (->namestring pathname))
- (let loop ((types types))
- (and (not (null? types))
- (let ((p
- (pathname-new-type pathname (car types))))
- (if (file-exists? p)
- (->namestring p)
- (loop (cdr types)))))))))))
- (cond ((pathname-absolute? program)
- (try program))
- ((not default-directory)
- (let loop ((path exec-path))
- (and (not (null? path))
- (or (and (pathname-absolute? (car path))
- (try (merge-pathnames program (car path))))
- (loop (cdr path))))))
- (else
- (let ((default-directory (merge-pathnames default-directory)))
- (let loop ((path exec-path))
- (and (not (null? path))
- (or (try (merge-pathnames
- program
- (merge-pathnames (car path)
- default-directory)))
- (loop (cdr path))))))))))
-
-(define (os/shell-file-name)
- (or (get-environment-variable "SHELL")
- ;; Not sure if this is right for WinNT and/or Win95.
- "command.com"))
-
-(define dos/executable-suffixes
- ;; Not sure if there are other possibilities under WinNT and/or Win95.
- '("exe" "com" "bat"))
-
-(define (os/form-shell-command command)
- (list "/c" command))
-
-(define (os/shell-name pathname)
- (if (member (pathname-type pathname) dos/executable-suffixes)
- (pathname-name pathname)
- (file-namestring pathname)))
-
-(define (os/default-shell-prompt-pattern)
- "^\\[[^]]*] *")
-
-(define (os/default-shell-args)
- '())
\ No newline at end of file
+ '#(#f 0 0 0 0 0 0 0 "----------" 0))
\ No newline at end of file
;;; -*-Scheme-*-
;;;
-;;; $Id: os2.scm,v 1.23 1995/10/12 22:47:48 cph Exp $
+;;; $Id: os2.scm,v 1.24 1995/10/25 02:19:44 cph Exp $
;;;
;;; Copyright (c) 1994-95 Massachusetts Institute of Technology
;;;
(declare (usual-integrations))
\f
-(define-variable version-control
- "Control use of version numbers for backup files.
-#T means make numeric backup versions unconditionally.
-#F means make them for files that have some already.
-'NEVER means do not make them."
- #f
- (lambda (object) (or (eq? object 'NEVER) (boolean? object))))
-
-(define-variable kept-old-versions
- "Number of oldest versions to keep when a new numbered backup is made."
- 2
- exact-nonnegative-integer?)
-
-(define-variable kept-new-versions
- "Number of newest versions to keep when a new numbered backup is made.
-Includes the new backup. Must be > 0."
- 2
- (lambda (n) (and (exact-integer? n) (> n 0))))
-
-(define os2/encoding-pathname-types
+(define dos/encoding-pathname-types
'("gz" #|"ky"|#))
-(define os2/backup-suffixes
- (cons "~"
- (map (lambda (type) (string-append "~." type))
- os2/encoding-pathname-types)))
-
-(define-variable completion-ignored-extensions
- "Completion ignores filenames ending in any string in this list."
- (append (list ".bin" ".com" ".ext"
- ".inf" ".bif" ".bsm" ".bci" ".bcs"
- ".psb" ".moc" ".fni"
- ".bco" ".bld" ".bad" ".glo" ".fre"
- ".obj" ".exe" ".pif" ".grp"
- ".dvi" ".toc" ".log" ".aux")
- (list-copy os2/backup-suffixes))
- (lambda (extensions)
- (and (list? extensions)
- (for-all? extensions
- (lambda (extension)
- (and (string? extension)
- (not (string-null? extension))))))))
-\f
-;;;; Filename I/O
-
-(define (os/trim-pathname-string string prefix)
- (let ((index (string-match-forward prefix string)))
- (if (and index
- (re-match-substring-forward
- (re-compile-pattern "[\\/$~]\\|[a-zA-Z]:" #t)
- #t #f string index (string-length string)))
- (string-tail string index)
- string)))
-
-(define (os/pathname->display-string pathname)
- (or (let ((relative (enough-pathname pathname (user-homedir-pathname))))
- (and (not (pathname-device relative))
- (not (pathname-absolute? relative))
- (string-append "~\\" (->namestring relative))))
- (->namestring pathname)))
-
-(define (os/truncate-filename-for-modeline filename width)
- (let ((length (string-length filename)))
- (if (< 0 width length)
- (let ((result
- (substring
- filename
- (let ((index (- length width)))
- (if (char=? #\\ (string-ref filename index))
- index
- (or (substring-find-next-char filename index length #\\)
- (fix:+ index 1))))
- length)))
- (string-set! result 0 #\$)
- result)
- filename)))
+(define dos/executable-pathname-types
+ '("exe" "cmd"))
+
+(define dos/default-shell-file-name
+ "cmd.exe")
+
+(define (os/form-shell-command command)
+ (list "/c" command))
(define (os/directory-list directory)
(let ((channel (directory-channel-open directory)))
(begin
(directory-channel-close channel)
result))))))
-\f
-;;;; Backup and Auto-Save Filenames
-
-(define (os/buffer-backup-pathname truename)
- (call-with-values
- (lambda ()
- (if (os2/fs-long-filenames? truename)
- (let ((type (pathname-type truename)))
- (if (member type os2/encoding-pathname-types)
- (values (pathname-new-type truename #f)
- (string-append "~." type))
- (values truename "~")))
- (values truename "")))
- (lambda (truename suffix)
- (if (eq? 'NEVER (ref-variable version-control))
- (values (os2/make-backup-pathname truename #f suffix) '())
- (let ((prefix
- (if (os2/fs-long-filenames? truename)
- (string-append (file-namestring truename) ".~")
- (string-append (pathname-name truename) "."))))
- (let ((backups
- (let loop
- ((filenames
- (os/directory-list-completions
- (directory-namestring truename)
- prefix))
- (backups '()))
- (if (null? filenames)
- (sort backups (lambda (x y) (< (cdr x) (cdr y))))
- (loop (cdr filenames)
- (let ((root.version
- (os/numeric-backup-filename?
- (car filenames))))
- (if root.version
- (cons (cons (car filenames)
- (cdr root.version))
- backups)
- backups)))))))
- (if (null? backups)
- (values (os2/make-backup-pathname
- truename
- (and (ref-variable version-control) 1)
- suffix)
- '())
- (values (os2/make-backup-pathname
- truename
- (+ (apply max (map cdr backups)) 1)
- suffix)
- (let ((start (ref-variable kept-old-versions))
- (end
- (- (length backups)
- (- (ref-variable kept-new-versions) 1))))
- (if (< start end)
- (map car (sublist backups start end))
- '()))))))))))
-
-(define (os2/make-backup-pathname pathname version suffix)
- (if (os2/fs-long-filenames? pathname)
- (string-append (->namestring pathname)
- (if version
- (string-append ".~" (number->string version) suffix)
- suffix))
- (pathname-new-type pathname
- (if (and version (< version 1000))
- (let ((type (pathname-type pathname))
- (vs (number->string version)))
- (if (and (< version 100)
- (string? type)
- (not (string-null? type)))
- (string-append (substring type 0 1)
- (string-pad-left vs 2 #\0))
- (string-pad-left vs 3 #\0)))
- "bak"))))
-
-(define (os/default-backup-filename)
- "$TMP\\edwin.bak")
-\f
-(define (os/backup-filename? filename)
- (or (there-exists? os2/backup-suffixes
- (lambda (suffix)
- (string-suffix? suffix filename)))
- (let ((type (pathname-type filename)))
- (and (string? type)
- (or (string-ci=? "bak" type)
- (re-match-string-forward (re-compile-pattern ".[0-9][0-9]" #f)
- #f
- #f
- type))))))
-
-(define (os/numeric-backup-filename? filename)
- (and (let ((try
- (lambda (pattern)
- (re-search-string-forward (re-compile-pattern pattern #f)
- #f
- #f
- filename))))
- (or (try "^\\([^.]+\\)\\.\\([0-9][0-9][0-9]\\)$")
- (try "^\\([^.]+\\.[^.]\\)\\([0-9][0-9]\\)$")
- (there-exists? os2/backup-suffixes
- (lambda (suffix)
- (try (string-append "^\\(.+\\)\\.~\\([0-9]+\\)"
- (re-quote-string suffix)
- "$"))))))
- (let ((root-start (re-match-start-index 1))
- (root-end (re-match-end-index 1))
- (version-start (re-match-start-index 2))
- (version-end (re-match-end-index 2)))
- (let ((version
- (substring->number filename version-start version-end)))
- (and (> version 0)
- (cons (substring filename root-start root-end)
- version))))))
-
-(define (os/auto-save-filename? filename)
- (or (re-match-string-forward (re-compile-pattern "^#.+#$" #f)
- #f
- #f
- (file-namestring filename))
- (let ((type (pathname-type filename)))
- (and (string? type)
- (string-ci=? "sav" type)))))
-
-(define (os/precious-backup-pathname pathname)
- (if (os2/fs-long-filenames? pathname)
- (let ((directory (directory-pathname pathname)))
- (let loop ((i 0))
- (let ((pathname
- (merge-pathnames (string-append "#tmp#" (number->string i))
- directory)))
- (if (allocate-temporary-file pathname)
- (begin
- (deallocate-temporary-file pathname)
- pathname)
- (loop (+ i 1))))))
- (os/auto-save-pathname pathname #f)))
-\f
-(define (os/auto-save-pathname pathname buffer)
- (let ((pathname
- (or pathname
- (let ((directory (buffer-default-directory buffer)))
- (merge-pathnames (if (os2/fs-long-filenames? directory)
- (string-append "%"
- (buffer-hpfs-name buffer))
- "%buffer%")
- directory)))))
- (if (os2/fs-long-filenames? pathname)
- (merge-pathnames (string-append "#" (file-namestring pathname) "#")
- (directory-pathname pathname))
- (pathname-new-type pathname "sav"))))
-
-(define (buffer-hpfs-name buffer)
- (let ((name (buffer-name buffer)))
- (let ((length (string-length name)))
- (let ((copy (make-string length)))
- (do ((i 0 (fix:+ i 1)))
- ((fix:= i length))
- (string-set!
- copy i
- (let ((char (string-ref name i)))
- (if (char-set-member? char-set:valid-hpfs-chars
- char)
- char
- #\_))))
- copy))))
-
-(define char-set:valid-hpfs-chars
- (char-set-invert
- (char-set-union (char-set #\\ #\/ #\: #\* #\? #\" #\< #\> #\|)
- (char-set-union (ascii-range->char-set 0 #x21)
- (ascii-range->char-set #x7F #x100)))))
-\f
-;;;; Miscellaneous
-
-(define (os/backup-buffer? truename)
- (let ((attrs (file-attributes truename)))
- (and attrs
- (eq? #f (file-attributes/type attrs)))))
-(define (os/backup-by-copying? truename buffer)
- truename buffer
- #f)
-
-(define (os/pathname-type-for-mode pathname)
- (let ((type (pathname-type pathname)))
- (if (member type os2/encoding-pathname-types)
- (pathname-type (->namestring (pathname-new-type pathname false)))
- type)))
-
-(define (os/completion-ignore-filename? filename)
- (or (os/backup-filename? filename)
- (os/auto-save-filename? filename)
- (and (not (file-directory? filename))
- (there-exists? (ref-variable completion-ignored-extensions)
- (lambda (extension)
- (string-suffix? extension filename))))))
-
-(define (os/file-type-to-major-mode)
- (alist-copy
- `(("asm" . midas)
- ("bat" . text)
- ("bib" . text)
- ("c" . c)
- ("h" . c)
- ("m4" . midas)
- ("pas" . pascal)
- ("s" . scheme)
- ("scm" . scheme)
- ("txi" . texinfo)
- ("txt" . text))))
-
-(define (os/init-file-name)
- (let ((name "edwin.ini"))
- (let ((user-init-file (merge-pathnames name (user-homedir-pathname))))
- (if (file-exists? user-init-file)
- user-init-file
- (merge-pathnames name (system-library-directory-pathname #f))))))
-
-(define (os/find-file-initialization-filename pathname)
- (or (and (equal? "scm" (pathname-type pathname))
- (let ((pathname (pathname-new-type pathname "ffi")))
- (and (file-exists? pathname)
- pathname)))
- (let ((pathname
- (merge-pathnames "edwin.ffi" (directory-pathname pathname))))
- (and (file-exists? pathname)
- pathname))))
+(define (os/set-file-modes-writable! pathname)
+ (set-file-modes! pathname (fix:andc (file-modes pathname) #x0001)))
(define (os/scheme-can-quit?)
#f)
(define (os/quit dir)
dir
(error "Can't quit."))
-
-(define (os/set-file-modes-writable! pathname)
- (set-file-modes! pathname (fix:andc (file-modes pathname) #x0001)))
\f
;;;; OS/2 Clipboard Interface
(+ (* (quotient time 16) 12)
(remainder time 16))))
\f
-;;;; Subprocess/Shell Support
-
-(define (os/parse-path-string string)
- (let ((end (string-length string))
- (substring
- (lambda (string start end)
- (pathname-as-directory (substring string start end)))))
- (let loop ((start 0))
- (if (< start end)
- (let ((index (substring-find-next-char string start end #\;)))
- (if index
- (if (= index start)
- (loop (+ index 1))
- (cons (substring string start index)
- (loop (+ index 1))))
- (list (substring string start end))))
- '()))))
-
-(define (os/find-program program default-directory)
- (or (os2/find-program program (ref-variable exec-path) default-directory)
- (error "Can't find program:" (->namestring program))))
-
-(define (os2/find-program program exec-path default-directory)
- (let* ((types '("exe" "cmd"))
- (try
- (lambda (pathname)
- (let ((type (pathname-type pathname)))
- (if type
- (and (member type types)
- (file-exists? pathname)
- (->namestring pathname))
- (let loop ((types types))
- (and (not (null? types))
- (let ((p
- (pathname-new-type pathname (car types))))
- (if (file-exists? p)
- (->namestring p)
- (loop (cdr types)))))))))))
- (cond ((pathname-absolute? program)
- (try program))
- ((not default-directory)
- (let loop ((path exec-path))
- (and (not (null? path))
- (or (and (pathname-absolute? (car path))
- (try (merge-pathnames program (car path))))
- (loop (cdr path))))))
- (else
- (let ((default-directory (merge-pathnames default-directory)))
- (let loop ((path exec-path))
- (and (not (null? path))
- (or (try (merge-pathnames
- program
- (merge-pathnames (car path)
- default-directory)))
- (loop (cdr path))))))))))
-
-(define (os/shell-file-name)
- (or (get-environment-variable "SHELL")
- "cmd.exe"))
-
-(define (os/form-shell-command command)
- (list "/c" command))
-
-(define (os/shell-name pathname)
- (if (member (pathname-type pathname) '("exe" "cmd"))
- (pathname-name pathname)
- (file-namestring pathname)))
-
-(define (os/default-shell-prompt-pattern)
- "^\\[[^]]*] *")
-
-(define (os/default-shell-args)
- '())
-
-(define (os/comint-filename-region start point end)
- (let ((chars "]\\\\A-Za-z0-9!#$%&'()+,.:;=@[^_`{}~---"))
- (let ((start (skip-chars-backward chars point start)))
- (make-region start (skip-chars-forward chars start end)))))
-\f
;;;; Compressed Files
(define (os/read-file-methods)
(define (os/alternate-pathnames group pathname)
(if (and (ref-variable enable-compressed-files group)
- (os2/fs-long-filenames? pathname)
+ (dos/fs-long-filenames? pathname)
(not (equal? "gz" (pathname-type pathname))))
(list (string-append (->namestring pathname) ".gz"))
'()))
(define (os2-pop-client server user-name password directory)
(let ((target
(->namestring
- (merge-pathnames (if (os2/fs-long-filenames? directory)
+ (merge-pathnames (if (dos/fs-long-filenames? directory)
".popmail"
"popmail.tmp")
directory))))
projects / mit-scheme.git / commitdiff