home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / ntprm.scm < prev    next >
Text File  |  2001-05-08  |  25KB  |  747 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: ntprm.scm,v 1.36 2001/05/09 03:17:05 cph Exp $
  4.  
  5. Copyright (c) 1992-2001 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
  20. USA.
  21. |#
  22.  
  23. ;;;; Miscellaneous Win32 Primitives
  24. ;;; package: ()
  25.  
  26. (declare (usual-integrations))
  27.  
  28. (define (file-modes filename)
  29.   ((ucode-primitive file-modes 1) (->namestring (merge-pathnames filename))))
  30.  
  31. (define (set-file-modes! filename modes)
  32.   ((ucode-primitive set-file-modes! 2)
  33.    (->namestring (merge-pathnames filename))
  34.    modes))
  35.  
  36. (define-integrable nt-file-mode/read-only  #x001)
  37. (define-integrable nt-file-mode/hidden     #x002)
  38. (define-integrable nt-file-mode/system     #x004)
  39. (define-integrable nt-file-mode/directory  #x010)
  40. (define-integrable nt-file-mode/archive    #x020)
  41. (define-integrable nt-file-mode/normal     #x080)
  42. (define-integrable nt-file-mode/temporary  #x100)
  43. (define-integrable nt-file-mode/compressed #x800)
  44.  
  45. (define (file-attributes filename)
  46.   ((ucode-primitive file-attributes 1)
  47.    (->namestring (merge-pathnames filename))))
  48. (define file-attributes-direct file-attributes)
  49. (define file-attributes-indirect file-attributes)
  50.  
  51. (define-structure (file-attributes (type vector)
  52.                    (constructor #f)
  53.                    (conc-name file-attributes/))
  54.   (type #f read-only #t)
  55.   (n-links #f read-only #t)
  56.   (uid #f read-only #t)
  57.   (gid #f read-only #t)
  58.   (access-time #f read-only #t)
  59.   (modification-time #f read-only #t)
  60.   (change-time #f read-only #t)
  61.   (length #f read-only #t)
  62.   (mode-string #f read-only #t)
  63.   (inode-number #f read-only #t)
  64.   (modes #f read-only #t))
  65.  
  66. (define (file-length namestring)
  67.   (let ((attr (file-attributes namestring)))
  68.     (and attr
  69.      (file-attributes/length attr))))
  70.  
  71. (define (copy-file from to)
  72.   ((ucode-primitive nt-copy-file 2) (->namestring (merge-pathnames from))
  73.                     (->namestring (merge-pathnames to))))
  74.  
  75. (define (file-modification-time filename)
  76.   ((ucode-primitive file-mod-time 1)
  77.    (->namestring (merge-pathnames filename))))
  78. (define file-modification-time-direct file-modification-time)
  79. (define file-modification-time-indirect file-modification-time)
  80.  
  81. (define (file-access-time namestring)
  82.   (let ((attr (file-attributes namestring)))
  83.     (and attr
  84.      (file-attributes/access-time attr))))
  85. (define file-access-time-direct file-modification-time-direct)
  86. (define file-access-time-indirect file-modification-time-indirect)
  87.  
  88. (define (set-file-times! filename access-time modification-time)
  89.   (let ((filename (->namestring (merge-pathnames filename))))
  90.     ((ucode-primitive set-file-times! 3)
  91.      filename
  92.      (or access-time (file-access-time filename))
  93.      (or modification-time (file-modification-time filename)))))
  94.  
  95. (define (file-time->local-decoded-time time)
  96.   (universal-time->local-decoded-time (file-time->universal-time time)))
  97.  
  98. (define (file-time->global-decoded-time time)
  99.   (universal-time->global-decoded-time (file-time->universal-time time)))
  100.  
  101. (define (decoded-time->file-time dt)
  102.   (universal-time->file-time (decoded-time->universal-time dt)))
  103.  
  104. (define decode-file-time file-time->local-decoded-time)
  105. (define encode-file-time decoded-time->file-time)
  106.  
  107. (define (file-time->universal-time time) (+ time epoch))
  108. (define (universal-time->file-time time) (- time epoch))
  109.  
  110. (define get-environment-variable)
  111. (define set-environment-variable!)
  112. (define set-environment-variable-default!)
  113. (define delete-environment-variable!)
  114. (define reset-environment-variables!)
  115. (let ((environment-variables '())
  116.       (environment-defaults '()))
  117.  
  118.   ;; Kludge: since getenv returns #f for unbound,
  119.   ;; that can also be the marker for a deleted variable
  120.   (define-integrable *variable-deleted* #f)
  121.  
  122.   (define (env-error proc var)
  123.     (error "Variable must be a string:" var proc))
  124.  
  125.   (define (default-variable! var val)
  126.     (if (and (not (assoc var environment-variables))
  127.          (not ((ucode-primitive get-environment-variable 1) var)))
  128.     (set! environment-variables
  129.           (cons (cons var (if (procedure? val) (val) val))
  130.             environment-variables)))
  131.     unspecific)
  132.  
  133.   (set! get-environment-variable
  134.     (lambda (variable)
  135.       (if (not (string? variable))
  136.           (env-error 'GET-ENVIRONMENT-VARIABLE variable))
  137.       (let ((variable (string-upcase variable)))
  138.         (cond ((assoc variable environment-variables)
  139.            => cdr)
  140.           (else
  141.            ((ucode-primitive get-environment-variable 1) variable))))))
  142.  
  143.   (set! set-environment-variable!
  144.     (lambda (variable value)
  145.       (if (not (string? variable))
  146.           (env-error 'SET-ENVIRONMENT-VARIABLE! variable))
  147.       (let ((variable (string-upcase variable)))
  148.         (cond ((assoc variable environment-variables)
  149.            => (lambda (pair) (set-cdr! pair value)))
  150.           (else
  151.            (set! environment-variables
  152.              (cons (cons variable value) environment-variables)))))
  153.       unspecific))
  154.  
  155.   (set! delete-environment-variable!
  156.     (lambda (variable)
  157.       (if (not (string? variable))
  158.           (env-error 'DELETE-ENVIRONMENT-VARIABLE! variable))
  159.       (set-environment-variable! variable *variable-deleted*)))
  160.  
  161.   (set! reset-environment-variables!
  162.     (lambda ()
  163.       (set! environment-variables '())
  164.       (for-each (lambda (def) (default-variable! (car def) (cdr def)))
  165.             environment-defaults)))
  166.  
  167.   (set! set-environment-variable-default!
  168.     (lambda (var val)
  169.       (if (not (string? var))
  170.           (env-error 'SET-ENVIRONMENT-VARIABLE-DEFAULT! var))
  171.       (let ((var (string-upcase var)))
  172.         (cond ((assoc var environment-defaults)
  173.            => (lambda (pair) (set-cdr! pair val)))
  174.           (else
  175.            (set! environment-defaults
  176.              (cons (cons var val) environment-defaults))))
  177.         (default-variable! var val))))
  178.  
  179.   )
  180.  
  181. (define current-user-name)
  182. (define current-home-directory)
  183. (define user-home-directory)
  184. (letrec
  185.     ((trydir
  186.       (lambda (directory)
  187.     (and directory
  188.          (file-directory? directory)
  189.          (pathname-as-directory directory))))
  190.      (%current-user-name
  191.       (lambda ()
  192.     (or (get-environment-variable "USERNAME")
  193.         (get-environment-variable "USER"))))
  194.      (%current-home-directory
  195.       (lambda ()
  196.     (or (let ((homedrive (get-environment-variable "HOMEDRIVE"))
  197.           (homepath (get-environment-variable "HOMEPATH")))
  198.           (and homedrive
  199.            homepath
  200.            (trydir (merge-pathnames homepath homedrive))))
  201.         (trydir (get-environment-variable "HOME")))))
  202.      (%users-directory
  203.       (lambda ()
  204.     (trydir (get-environment-variable "USERDIR")))))
  205.   (set! current-user-name
  206.     (lambda ()
  207.       (or (%current-user-name)
  208.           ;; If the home directory is defined, use the last part of the
  209.           ;; path as the user's name.  If the home directory is the root
  210.           ;; of a drive, this won't do anything.
  211.           (let ((homedir (%current-home-directory)))
  212.         (and homedir
  213.              (pathname-name (directory-pathname-as-file homedir))))
  214.           (error "Unable to determine current user name."))))
  215.   (set! current-home-directory
  216.     (lambda ()
  217.       (or (%current-home-directory)
  218.           (let ((user-name (%current-user-name)))
  219.         ;; If home directory not defined, look for directory
  220.         ;; with user's name in users directory and in root
  221.         ;; directory of system drive.  If still nothing, use
  222.         ;; root directory of system drive.
  223.         (or (let ((usersdir (%users-directory)))
  224.               (and user-name
  225.                usersdir
  226.                (trydir (merge-pathnames user-name usersdir))))
  227.             (let ((rootdir (nt/system-root-directory)))
  228.               (or (and user-name
  229.                    (trydir (merge-pathnames user-name rootdir)))
  230.               rootdir)))))))
  231.   (set! user-home-directory
  232.     (lambda (user-name)
  233.       (let ((homedir (%current-home-directory)))
  234.         ;; If USER-NAME is current user, use current home
  235.         ;; directory.
  236.         (or (let ((user-name* (%current-user-name)))
  237.           (and user-name*
  238.                (string=? user-name user-name*)
  239.                homedir))
  240.         ;; Look for USER-NAME in users directory.
  241.         (let ((usersdir (%users-directory)))
  242.           (and usersdir
  243.                (trydir (merge-pathnames user-name usersdir))))
  244.         ;; Look for USER-NAME in same directory as current
  245.         ;; user's home directory.
  246.         (and homedir
  247.              (trydir (merge-pathnames
  248.                   user-name
  249.                   (directory-pathname-as-file homedir))))
  250.         ;; Look for USER-NAME in root directory of system
  251.         ;; drive.
  252.         (trydir (merge-pathnames user-name (nt/system-root-directory)))
  253.         ;; OK, give up:
  254.         (error "Can't find user's home directory:" user-name))))))
  255.  
  256. (define dos/user-home-directory user-home-directory)
  257. (define dos/current-user-name current-user-name)
  258. (define dos/current-home-directory current-home-directory)
  259.  
  260. (define (temporary-file-pathname #!optional directory)
  261.   (let ((root
  262.      (merge-pathnames "_scm_tmp"
  263.               (if (or (default-object? directory) (not directory))
  264.                   (temporary-directory-pathname)
  265.                   (pathname-as-directory directory)))))
  266.     (let loop ((ext 0))
  267.       (let ((pathname (pathname-new-type root (number->string ext))))
  268.     (if (allocate-temporary-file pathname)
  269.         pathname
  270.         (begin
  271.           (if (> ext 999)
  272.           (error "Can't find unique temporary pathname:" root))
  273.           (loop (+ ext 1))))))))
  274.  
  275. (define (temporary-directory-pathname)
  276.   (let ((try-directory
  277.      (lambda (directory)
  278.        (let ((directory
  279.           (pathname-as-directory (merge-pathnames directory))))
  280.          (and (file-directory? directory)
  281.           (file-writeable? directory)
  282.           directory)))))
  283.     (let ((try-variable
  284.        (lambda (name)
  285.          (let ((value (get-environment-variable name)))
  286.            (and value
  287.             (try-directory value)))))
  288.       (try-system-directory
  289.        (lambda (directory)
  290.          (try-directory
  291.           (merge-pathnames directory (nt/system-root-directory))))))
  292.       (or (try-variable "TMPDIR")
  293.       (try-variable "TEMP")
  294.       (try-variable "TMP")
  295.       (try-system-directory "\\temp")
  296.       (try-system-directory "\\tmp")
  297.       (try-system-directory "")
  298.       (try-directory ".")
  299.       (error "Can't find temporary directory.")))))
  300.  
  301. (define (nt/system-root-directory)
  302.   (let ((trydir
  303.      (lambda (directory)
  304.        (and directory
  305.         (file-directory? directory)
  306.         directory))))
  307.     (let ((sysroot
  308.        (or (trydir (get-environment-variable "SystemRoot"))
  309.            (trydir (get-environment-variable "windir"))
  310.            (trydir (get-environment-variable "winbootdir")))))
  311.       (if (not sysroot)
  312.       (error "Unable to find Windows system root."))
  313.       (pathname-new-directory (pathname-as-directory sysroot) '(ABSOLUTE)))))
  314.  
  315. (define (os/file-end-of-line-translation pathname)
  316.   (if (let ((type (dos/fs-drive-type pathname)))
  317.     (or (string=? "NFS" (car type))
  318.         (string=? "NtNfs" (car type))
  319.         (string=? "Samba" (car type))))
  320.       #f
  321.       "\r\n"))
  322.  
  323. (define (os/default-end-of-line-translation)
  324.   "\r\n")
  325.  
  326. (define (dos/fs-drive-type pathname)
  327.   ;; (system-name . [nfs-]mount-point)
  328.   (cons (let ((info (nt-volume-info pathname)))
  329.       (let ((name (nt-volume-info/file-system-name info)))
  330.         ;; Samba normally advertises itself as NTFS, except that
  331.         ;; it doesn't claim to store Unicode on the disk.
  332.         (if (and (string-ci=? name "NTFS")
  333.              (fix:= 0
  334.                 (fix:and (nt-volume-info/file-system-flags info)
  335.                      nt-fs-flag/unicode-on-disk)))
  336.         "Samba"
  337.         name)))
  338.     ""))
  339.  
  340. (define (dos/fs-long-filenames? pathname)
  341.   ;; Currently we have a problem with long filenames on FAT systems because
  342.   ;; the invented backup names may clash: FOO.SCM and FOO.SCM~ are confused.
  343.   ;; The temporary fix is to treat backup names on FAT systems like the short
  344.   ;; version, even if the VFAT driver is being used to provide long file names.
  345.   (let* ((volume-info (nt-volume-info pathname))
  346.      (fs-type     (nt-volume-info/file-system-name volume-info)))
  347.     (cond ((or (string-ci=? fs-type "VFAT")
  348.            (string-ci=? fs-type "FAT32"))
  349.        'VFAT)            ; ``kind of''
  350.       ((string-ci=? fs-type "FAT")
  351.        #F)
  352.       ((> (nt-volume-info/max-component-length volume-info) 32)
  353.        ;; 32 is random -- FAT is 12 and everything else is much larger.
  354.        #T)                ; NTFS HPFS
  355.       (else #F))))            ; FAT
  356.  
  357. (define (nt-volume-info pathname)
  358.   (let ((root
  359.      (pathname-new-directory
  360.       (directory-pathname (merge-pathnames pathname))
  361.       '(ABSOLUTE))))
  362.     (let ((info
  363.        ((ucode-primitive nt-get-volume-information 1)
  364.         (->namestring root))))
  365.       (if (not info)
  366.       (error "Error reading volume information:" root))
  367.       info)))
  368.  
  369. (define-structure (nt-volume-info (type vector)
  370.                   (constructor #f)
  371.                   (conc-name nt-volume-info/))
  372.   (name #f read-only #t)
  373.   (serial-number #f read-only #t)
  374.   (max-component-length #f read-only #t)
  375.   (file-system-flags #f read-only #t)
  376.   (file-system-name #f read-only #t))
  377.  
  378. (define nt-fs-flag/case-sensitive-search    #x00000001)
  379. (define nt-fs-flag/case-preserved-names        #x00000002)
  380. (define nt-fs-flag/unicode-on-disk        #x00000004)
  381. (define nt-fs-flag/persistent-acls        #x00000008)
  382. (define nt-fs-flag/file-compression        #x00000010)
  383. (define nt-fs-flag/volume-is-compressed        #x00008000)
  384.  
  385. (define (init-file-specifier->pathname specifier)
  386.  
  387.   (define (read-fat-init-file-map port)
  388.     (let loop ((result '()))
  389.       (let ((item (read port)))
  390.     (if (eof-object? item)
  391.         result
  392.         (begin
  393.           (if (not (and (pair? item)
  394.                 (init-file-specifier? (car item))
  395.                 (string? (cdr item))))
  396.           (error "Malformed init-file map item:" item))
  397.           (loop (cons item result)))))))
  398.  
  399.   (define (generate-fat-init-file directory)
  400.     (let loop ((index 1))
  401.       (let ((filename
  402.          (string-append "ini"
  403.                 (string-pad-left (number->string index) 5 #\0)
  404.                 ".dat")))
  405.     (if (file-exists? (merge-pathnames filename directory))
  406.         (loop (+ index 1))
  407.         filename))))
  408.  
  409.   (guarantee-init-file-specifier specifier 'INIT-FILE-SPECIFIER->PATHNAME)
  410.   (let ((long-base (merge-pathnames ".mit-scheme/" (user-homedir-pathname))))
  411.     (if (dos/fs-long-filenames? long-base)
  412.     (if (null? specifier)
  413.         (directory-pathname-as-file long-base)
  414.         (merge-pathnames
  415.          (apply string-append
  416.             (cons (car specifier)
  417.               (append-map (lambda (string) (list "/" string))
  418.                       (cdr specifier))))
  419.          long-base))
  420.     (let ((short-base
  421.            (merge-pathnames "mitschem.ini/" (user-homedir-pathname))))
  422.       (let ((file-map-pathname (merge-pathnames "filemap.dat" short-base)))
  423.         (let ((port #f))
  424.           (dynamic-wind
  425.            (lambda ()
  426.          (set! port (open-i/o-file file-map-pathname))
  427.          unspecific)
  428.            (lambda ()
  429.          (merge-pathnames
  430.           (or (let ((entry
  431.                  (assoc specifier (read-fat-init-file-map port))))
  432.             (and entry
  433.                  (cdr entry)))
  434.               (let ((filename (generate-fat-init-file short-base)))
  435.             (let ((channel (port/output-channel port)))
  436.               (channel-file-set-position
  437.                channel
  438.                (channel-file-length channel)))
  439.             (write (cons specifier filename) port)
  440.             (newline port)
  441.             filename))
  442.           short-base))
  443.            (lambda ()
  444.          (if port
  445.              (begin
  446.                (close-port port)
  447.                (set! port #f)
  448.                unspecific))))))))))
  449.  
  450. (define-structure (nt-select-registry (conc-name nt-select-registry/))
  451.   descriptors)
  452.  
  453. (define (make-select-registry . descriptors)
  454.   (make-nt-select-registry descriptors))
  455.  
  456. (define (add-to-select-registry! registry descriptor)
  457.   (if (not (memv descriptor (nt-select-registry/descriptors registry)))
  458.       (set-nt-select-registry/descriptors!
  459.        registry
  460.        (cons descriptor (nt-select-registry/descriptors registry)))))
  461.  
  462. (define (remove-from-select-registry! registry descriptor)
  463.   (set-nt-select-registry/descriptors!
  464.    registry
  465.    (delv! descriptor (nt-select-registry/descriptors registry))))
  466.  
  467. (define (select-registry-test registry block?)
  468.   (let ((descriptors (list->vector (nt-select-registry/descriptors registry))))
  469.     (let ((result
  470.        ((ucode-primitive nt:waitformultipleobjects 3)
  471.         descriptors #f block?)))
  472.       (cond ((and (fix:<= 0 result) (fix:< result (vector-length descriptors)))
  473.          (list (vector-ref descriptors result)))
  474.         ((fix:= result -1) #f)
  475.         ((fix:= result -2) 'INTERRUPT)
  476.         ((fix:= result -3) 'PROCESS-STATUS-CHANGE)
  477.         (else (error "Illegal result from select-internal:" result))))))
  478.  
  479. (define (select-descriptor descriptor block?)
  480.   (let ((result
  481.      ((ucode-primitive nt:waitformultipleobjects 3)
  482.       (vector descriptor) #f block?)))
  483.     (case result
  484.       ((0) 'INPUT-AVAILABLE)
  485.       ((-1) #f)
  486.       ((-2) 'INTERRUPT)
  487.       ((-3) 'PROCESS-STATUS-CHANGE)
  488.       (else (error "Illegal result from select-internal:" result)))))
  489.  
  490. (define console-channel-descriptor)
  491.  
  492. (define (cache-console-channel-descriptor!)
  493.   (set! console-channel-descriptor
  494.     (channel-descriptor-for-select (tty-input-channel)))
  495.   unspecific)
  496.  
  497. ;;;; Subprocess/Shell Support
  498.  
  499. (define nt/hide-subprocess-windows?)
  500. (define nt/subprocess-argument-quote-char)
  501. (define nt/subprocess-argument-escape-char)
  502.  
  503. (define (initialize-system-primitives!)
  504.   (let ((reset!
  505.      (lambda ()
  506.        (reset-environment-variables!)
  507.        (cache-console-channel-descriptor!))))
  508.     (reset!)
  509.     (add-event-receiver! event:after-restart reset!))
  510.   (set! nt/hide-subprocess-windows? #t)
  511.   (set! nt/subprocess-argument-quote-char #f)
  512.   (set! nt/subprocess-argument-escape-char #f)
  513.   unspecific)
  514.  
  515. (define (os/make-subprocess filename arguments environment working-directory
  516.                 ctty stdin stdout stderr)
  517.   (if ctty
  518.       (error "Can't manipulate controlling terminal of subprocess:" ctty))
  519.   ((ucode-primitive nt-make-subprocess 8)
  520.    filename
  521.    (nt/rewrite-subprocess-arguments filename (vector->list arguments))
  522.    (and environment
  523.     (nt/rewrite-subprocess-environment (vector->list environment)))
  524.    working-directory
  525.    stdin
  526.    stdout
  527.    stderr
  528.    (vector nt/hide-subprocess-windows?)))
  529.  
  530. (define (nt/rewrite-subprocess-environment strings)
  531.   (let ((strings
  532.      (map car
  533.           (sort (map (lambda (binding)
  534.                (cons binding
  535.                  (or (string-find-next-char binding #\=)
  536.                      (string-length binding))))
  537.              strings)
  538.             (lambda (s1 s2)
  539.               (substring<? (car s1) 0 (cdr s1)
  540.                    (car s2) 0 (cdr s2)))))))
  541.     (let ((result
  542.        (make-string
  543.         (reduce +
  544.             0
  545.             (map (lambda (s) (fix:+ (string-length s) 1))
  546.              strings)))))
  547.       (let loop ((strings strings) (index 0))
  548.     (if (not (null? strings))
  549.         (let ((n (string-length (car strings))))
  550.           (substring-move! (car strings) 0 n result index)
  551.           (let ((index* (fix:+ index n)))
  552.         (string-set! result index* #\NUL)
  553.         (loop (cdr strings) (fix:+ index* 1))))))
  554.       result)))
  555.  
  556. (define (nt/rewrite-subprocess-arguments program strings)
  557.   ;; PROGRAM will eventually be used to determine the appropriate
  558.   ;; escape character -- strangely enough, this depends on what
  559.   ;; runtime library PROGRAM is linked with.
  560.   program
  561.   (let ((quote-char nt/subprocess-argument-quote-char)
  562.     (escape-char nt/subprocess-argument-escape-char))
  563.     (if (not quote-char)
  564.     (nt/rewrite-subprocess-arguments/no-quoting strings)
  565.     (nt/rewrite-subprocess-arguments/quoting strings
  566.                          quote-char escape-char))))
  567.  
  568. (define (nt/rewrite-subprocess-arguments/no-quoting strings)
  569.   (if (null? strings)
  570.       ""
  571.       (let ((result
  572.          (make-string
  573.           (fix:+ (reduce +
  574.                  0
  575.                  (map (lambda (s) (string-length s)) strings))
  576.              (fix:- (length strings) 1)))))
  577.     (let ((n (string-length (car strings))))
  578.       (substring-move! (car strings) 0 n result 0)
  579.       (let loop ((strings (cdr strings)) (index n))
  580.         (if (not (null? strings))
  581.         (let ((n (string-length (car strings))))
  582.           (string-set! result index #\space)
  583.           (substring-move! (car strings) 0 n result (fix:+ index 1))
  584.           (loop (cdr strings) (fix:+ (fix:+ index 1) n))))))
  585.     result)))
  586.  
  587. (define (nt/rewrite-subprocess-arguments/quoting strings
  588.                          quote-char escape-char)
  589.   (define (analyze-arg s)
  590.     (let ((need-quotes? #f)
  591.       (n (string-length s)))
  592.       (do ((i 0 (fix:+ i 1))
  593.        (j 0
  594.           (fix:+ j
  595.              (let ((c (string-ref s i)))
  596.                (if (or (char=? quote-char c)
  597.                    (char=? escape-char c))
  598.                (begin
  599.                  (set! need-quotes? #t)
  600.                  2)
  601.                (begin
  602.                  (if (or (char=? #\space c)
  603.                      (char=? #\tab c))
  604.                  (set! need-quotes? #t))
  605.                  1))))))
  606.       ((fix:= i n)
  607.        (cons (if need-quotes? (fix:+ j 2) j)
  608.          need-quotes?)))))
  609.   (let ((analyses (map analyze-arg strings)))
  610.     (let ((result (make-string (reduce + 0 (map car analyses)))))
  611.       (define (do-arg index s analysis)
  612.     (if (cdr analysis)
  613.         (begin
  614.           (string-set! result index quote-char)
  615.           (let ((index (do-arg-1 index s)))
  616.         (string-set! result index quote-char)
  617.         (fix:+ index 1)))
  618.         (do-arg-1 index s)))
  619.       (define (do-arg-1 index s)
  620.     (let ((n (string-length s)))
  621.       (do ((i 0 (fix:+ i 1))
  622.            (index index
  623.               (let ((c (string-ref s i)))
  624.             (if (or (char=? quote-char c)
  625.                 (char=? escape-char c))
  626.                 (begin
  627.                   (string-set! result index escape-char)
  628.                   (string-set! result (fix:+ index 1) c)
  629.                   (fix:+ index 2))
  630.                 (begin
  631.                   (string-set! result index c)
  632.                   (fix:+ index 1))))))
  633.           ((fix:= i n) index))))
  634.       (let loop ((index 0) (strings strings) (analyses analyses))
  635.     (if (not (null? strings))
  636.         (loop (do-arg index (car strings) (car analyses))
  637.           (cdr strings)
  638.           (cdr analyses))))
  639.       result)))
  640.  
  641. (define (os/find-program program default-directory #!optional exec-path error?)
  642.   (let ((namestring
  643.      (let* ((exec-path
  644.          (if (default-object? exec-path)
  645.              (os/exec-path)
  646.              exec-path))
  647.         (try
  648.          (let ((types (os/executable-pathname-types)))
  649.            (lambda (pathname)
  650.              (let ((type (pathname-type pathname)))
  651.                (if type
  652.                (and (member type types)
  653.                 (file-exists? pathname)
  654.                 (->namestring pathname))
  655.                (let loop ((types types))
  656.                  (and (not (null? types))
  657.                   (let ((p
  658.                      (pathname-new-type pathname
  659.                                 (car types))))
  660.                     (if (file-exists? p)
  661.                     (->namestring p)
  662.                     (loop (cdr types)))))))))))
  663.         (try-dir
  664.          (lambda (directory)
  665.            (try (merge-pathnames program directory)))))
  666.        (if (pathname-absolute? program)
  667.            (try program)
  668.            (or (let ((ns (nt/scheme-executable-pathname)))
  669.              (and ns
  670.               (try-dir (directory-pathname ns))))
  671.            (if (not default-directory)
  672.                (let loop ((path exec-path))
  673.              (and (not (null? path))
  674.                   (or (and (pathname-absolute? (car path))
  675.                        (try-dir (car path)))
  676.                   (loop (cdr path)))))
  677.                (let ((default-directory
  678.                    (merge-pathnames default-directory)))
  679.              (let loop ((path exec-path))
  680.                (and (not (null? path))
  681.                 (or (try-dir
  682.                      (merge-pathnames (car path)
  683.                               default-directory))
  684.                     (loop (cdr path))))))))))))
  685.     (if (and (not namestring)
  686.          (if (default-object? error) #t error?))
  687.     (error "Can't find program:" (->namestring program)))
  688.     namestring))
  689.  
  690. (define (os/exec-path)
  691.   (os/parse-path-string
  692.    (let ((path (get-environment-variable "PATH")))
  693.      (if (not path)
  694.      (error "Can't find PATH environment variable."))
  695.      path)))
  696.  
  697. (define (os/parse-path-string string)
  698.   (let ((end (string-length string))
  699.     (substring
  700.      (lambda (string start end)
  701.        (pathname-as-directory (substring string start end)))))
  702.     (let loop ((start 0))
  703.       (if (< start end)
  704.       (let ((index (substring-find-next-char string start end #\;)))
  705.         (if index
  706.         (if (= index start)
  707.             (loop (+ index 1))
  708.             (cons (substring string start index)
  709.               (loop (+ index 1))))
  710.         (list (substring string start end))))
  711.       '()))))
  712.  
  713. (define (nt/scheme-executable-pathname)
  714.   (let ((env (->environment '(win32))))
  715.     (let ((handle
  716.        ((access get-module-handle env)
  717.         (file-namestring
  718.          (pathname-default-type
  719.           ((make-primitive-procedure 'SCHEME-PROGRAM-NAME))
  720.           "exe"))))
  721.       (buf (make-string 256)))
  722.       (substring buf 0 ((access get-module-file-name env) handle buf 256)))))
  723.  
  724. (define (os/shell-file-name)
  725.   (or (get-environment-variable "SHELL")
  726.       (get-environment-variable "COMSPEC")
  727.       (if (eq? 'WINNT (nt/windows-type))
  728.       "cmd.exe"
  729.       "command.com")))
  730.  
  731. (define (nt/windows-type)
  732.   (cond ((string-prefix? "Microsoft Windows NT"
  733.              microcode-id/operating-system-variant)
  734.      'WINNT)
  735.     ((string-prefix? "Microsoft Windows 9"
  736.              microcode-id/operating-system-variant)
  737.      'WIN9X)
  738.     ((string-prefix? "Microsoft Windows"
  739.              microcode-id/operating-system-variant)
  740.      'WIN3X)
  741.     (else #f)))
  742.  
  743. (define (os/form-shell-command command)
  744.   (list "/c" command))
  745.  
  746. (define (os/executable-pathname-types)
  747.   '("exe" "com" "bat" "btm"))