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 / os2prm.scm < prev    next >
Text File  |  2001-05-08  |  20KB  |  573 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: os2prm.scm,v 1.47 2001/05/09 03:17:08 cph Exp $
  4.  
  5. Copyright (c) 1994-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 OS/2 Primitives
  24. ;;; package: ()
  25.  
  26. (declare (usual-integrations))
  27.  
  28. (define (file-modes filename)
  29.   ((ucode-primitive file-attributes 1)
  30.    (->namestring (merge-pathnames filename))))
  31.  
  32. (define (set-file-modes! filename modes)
  33.   ((ucode-primitive set-file-attributes! 2)
  34.    (->namestring (merge-pathnames filename))
  35.    modes))
  36.  
  37. (define-integrable os2-file-mode/read-only #x01)
  38. (define-integrable os2-file-mode/hidden    #x02)
  39. (define-integrable os2-file-mode/system    #x04)
  40. (define-integrable os2-file-mode/directory #x10)
  41. (define-integrable os2-file-mode/archived  #x20)
  42.  
  43. (define (file-length filename)
  44.   ((ucode-primitive file-length 1)
  45.    (->namestring (merge-pathnames filename))))
  46.  
  47. (define (file-modification-time filename)
  48.   ((ucode-primitive file-mod-time 1)
  49.    (->namestring (merge-pathnames filename))))
  50. (define file-modification-time-direct file-modification-time)
  51. (define file-modification-time-indirect file-modification-time)
  52.  
  53. (define (file-access-time filename)
  54.   ((ucode-primitive file-access-time 1)
  55.    (->namestring (merge-pathnames filename))))
  56. (define file-access-time-direct file-access-time)
  57. (define file-access-time-indirect file-access-time)
  58.  
  59. (define (set-file-times! filename access-time modification-time)
  60.   ((ucode-primitive set-file-times! 3)
  61.    (->namestring (merge-pathnames filename))
  62.    access-time
  63.    modification-time))
  64.  
  65. (define (file-time->local-decoded-time time)
  66.   (let* ((twosecs (remainder time 32)) (time (quotient time 32))
  67.      (minutes (remainder time 64)) (time (quotient time 64))
  68.      (hours   (remainder time 32)) (time (quotient time 32))
  69.      (day     (remainder time 32)) (time (quotient time 32))
  70.      (month   (remainder time 16)) (year (quotient time 16)))
  71.     (make-decoded-time (* twosecs 2) minutes hours day month (+ 1980 year))))
  72.  
  73. (define (file-time->global-decoded-time time)
  74.   (universal-time->global-decoded-time (file-time->universal-time time)))
  75.  
  76. (define (decoded-time->file-time dt)
  77.   (let ((f (lambda (i j k) (+ (* i j) k))))
  78.     (f (f (f (f (f (let ((year (decoded-time/year dt)))
  79.              (if (< year 1980)
  80.              (error "Can't encode years earlier than 1980:" year))
  81.              year)
  82.            16 (decoded-time/month dt))
  83.         32 (decoded-time/day dt))
  84.          32 (decoded-time/hour dt))
  85.       64 (decoded-time/minute dt))
  86.        32 (quotient (decoded-time/second dt) 2))))
  87.  
  88. (define decode-file-time file-time->local-decoded-time)
  89. (define encode-file-time decoded-time->file-time)
  90.  
  91. (define (file-time->universal-time time)
  92.   (decoded-time->universal-time (file-time->local-decoded-time time)))
  93.  
  94. (define (universal-time->file-time time)
  95.   (decoded-time->file-time (universal-time->local-decoded-time time)))
  96.  
  97. (define (file-attributes filename)
  98.   ((ucode-primitive file-info 1)
  99.    (->namestring (merge-pathnames filename))))
  100. (define file-attributes-direct file-attributes)
  101. (define file-attributes-indirect file-attributes)
  102.  
  103. (define-structure (file-attributes (type vector)
  104.                    (constructor #f)
  105.                    (conc-name file-attributes/))
  106.   (type #f read-only #t)
  107.   (access-time #f read-only #t)
  108.   (modification-time #f read-only #t)
  109.   (change-time #f read-only #t)
  110.   (length #f read-only #t)
  111.   (mode-string #f read-only #t)
  112.   (modes #f read-only #t)
  113.   (allocated-length #f read-only #t))
  114.  
  115. (define (file-attributes/n-links attributes) attributes 1)
  116.  
  117. (define (get-environment-variable name)
  118.   ((ucode-primitive get-environment-variable 1) name))
  119.  
  120. (define (temporary-file-pathname #!optional directory)
  121.   (let ((root
  122.      (let ((directory
  123.         (if (or (default-object? directory) (not directory))
  124.             (temporary-directory-pathname)
  125.             (pathname-as-directory directory))))
  126.        (merge-pathnames
  127.         (if (dos/fs-long-filenames? directory)
  128.         (string-append
  129.          "sch"
  130.          (string-pad-left (number->string (os2/current-pid)) 6 #\0))
  131.         "_scm_tmp")
  132.         directory))))
  133.     (let loop ((ext 0))
  134.       (let ((pathname (pathname-new-type root (number->string ext))))
  135.     (if (allocate-temporary-file pathname)
  136.         pathname
  137.         (begin
  138.           (if (> ext 999)
  139.           (error "Can't find unique temporary pathname:" root))
  140.           (loop (+ ext 1))))))))
  141.  
  142. (define (temporary-directory-pathname)
  143.   (let ((try-directory
  144.      (lambda (directory)
  145.        (let ((directory
  146.           (pathname-as-directory (merge-pathnames directory))))
  147.          (and (file-directory? directory)
  148.           (file-writeable? directory)
  149.           directory)))))
  150.     (let ((try-variable
  151.        (lambda (name)
  152.          (let ((value (get-environment-variable name)))
  153.            (and value
  154.             (try-directory value)))))
  155.       (try-system-directory
  156.        (lambda (directory)
  157.          (try-directory
  158.           (merge-pathnames directory (os2/system-root-directory))))))
  159.       (or (try-variable "TMPDIR")
  160.       (try-variable "TEMP")
  161.       (try-variable "TMP")
  162.       (try-system-directory "\\temp")
  163.       (try-system-directory "\\tmp")
  164.       (try-system-directory "")
  165.       (try-directory ".")
  166.       (error "Can't find temporary directory.")))))
  167.  
  168. (define (os2/system-root-directory)
  169.   (let ((system.ini (get-environment-variable "SYSTEM_INI")))
  170.     (if (not (file-exists? system.ini))
  171.     (error "Unable to find OS/2 system.ini file:" system.ini))
  172.     (pathname-new-directory (directory-pathname system.ini) '(ABSOLUTE))))
  173.  
  174. (define-integrable os2/current-pid
  175.   (ucode-primitive current-pid 0))
  176.  
  177. (define current-user-name)
  178. (define current-home-directory)
  179. (define user-home-directory)
  180. (letrec
  181.     ((trydir
  182.       (lambda (directory)
  183.     (and directory
  184.          (file-directory? directory)
  185.          (pathname-as-directory directory))))
  186.      (%current-user-name
  187.       (lambda ()
  188.     (get-environment-variable "USER")))
  189.      (%current-home-directory
  190.       (lambda ()
  191.     (trydir (get-environment-variable "HOME"))))
  192.      (%users-directory
  193.       (lambda ()
  194.     (trydir (get-environment-variable "USERDIR")))))
  195.  
  196.   (set! current-user-name
  197.     (lambda ()
  198.       (or (%current-user-name)
  199.           ;; If the home directory is defined, use the last part of the
  200.           ;; path as the user's name.  If the home directory is the root
  201.           ;; of a drive, this won't do anything.
  202.           (let ((homedir (%current-home-directory)))
  203.         (and homedir
  204.              (pathname-name (directory-pathname-as-file homedir))))
  205.           (error "Unable to determine current user name."))))
  206.  
  207.   (set! current-home-directory
  208.     (lambda ()
  209.       (or (%current-home-directory)
  210.           ;; If home directory not defined, look for directory
  211.           ;; with user's name in users directory and in root
  212.           ;; directory of system drive.  If still nothing, use
  213.           ;; root directory of system drive.
  214.           (let ((user-name (%current-user-name))
  215.             (rootdir (os2/system-root-directory)))
  216.         (or (and user-name
  217.              (or (let ((usersdir (%users-directory)))
  218.                    (and usersdir
  219.                     (trydir
  220.                      (merge-pathnames user-name usersdir))))
  221.                  (trydir (merge-pathnames user-name rootdir))))
  222.             rootdir)))))
  223.  
  224.   (set! user-home-directory
  225.     (lambda (user-name)
  226.       (let ((homedir (%current-home-directory)))
  227.         ;; If USER-NAME is current user, use current home
  228.         ;; directory.
  229.         (or (let ((user-name* (%current-user-name)))
  230.           (and user-name*
  231.                (string=? user-name user-name*)
  232.                homedir))
  233.         ;; Look for USER-NAME in users directory.
  234.         (let ((usersdir (%users-directory)))
  235.           (and usersdir
  236.                (trydir (merge-pathnames user-name usersdir))))
  237.         ;; Look for USER-NAME in same directory as current
  238.         ;; user's home directory.
  239.         (and homedir
  240.              (trydir (merge-pathnames
  241.                   user-name
  242.                   (directory-pathname-as-file homedir))))
  243.         ;; Look for USER-NAME in root directory of system
  244.         ;; drive.
  245.         (trydir
  246.          (merge-pathnames user-name (os2/system-root-directory)))
  247.         ;; OK, give up:
  248.         (error "Can't find user's home directory:" user-name))))))
  249.  
  250. (define (dos/fs-drive-type pathname)
  251.   (let ((type
  252.      ((ucode-primitive drive-type 1)
  253.       (pathname-device (merge-pathnames pathname)))))
  254.     (let ((colon (string-find-next-char type #\:)))
  255.       (if colon
  256.       (cons (string-head type colon) (string-tail type (fix:+ colon 1)))
  257.       (cons type "")))))
  258.  
  259. (define (dos/fs-long-filenames? pathname)
  260.   (not (string-ci=? "fat" (car (dos/fs-drive-type pathname)))))
  261.  
  262. (define (os/file-end-of-line-translation pathname)
  263.   (let ((type (dos/fs-drive-type pathname)))
  264.     ;; "ext2" is the Linux ext2 file-system driver.  "NFS" is the IBM
  265.     ;; TCP/IP NFS driver, which we further qualify by examining the
  266.     ;; mount info -- if the directory starts with a "/", we assume
  267.     ;; that it is a unix system.
  268.     (if (or (string=? "ext2" (car type))
  269.         (and (string=? "NFS" (car type))
  270.          (let* ((mount (cdr type))
  271.             (colon (string-find-next-char mount #\:)))
  272.            (and colon
  273.             (fix:< (fix:+ colon 1) (string-length mount))
  274.             (char=? #\/ (string-ref mount (fix:+ colon 1)))))))
  275.     #f
  276.     "\r\n")))
  277.  
  278. (define (os/default-end-of-line-translation)
  279.   "\r\n")
  280.  
  281. (define (copy-file from to)
  282.   ((ucode-primitive os2-copy-file 2) (->namestring (merge-pathnames from))
  283.                      (->namestring (merge-pathnames to))))
  284.  
  285. (define (init-file-specifier->pathname specifier)
  286.  
  287.   (define (read-fat-init-file-map port)
  288.     (let loop ((result '()))
  289.       (let ((item (read port)))
  290.     (if (eof-object? item)
  291.         result
  292.         (begin
  293.           (if (not (and (pair? item)
  294.                 (init-file-specifier? (car item))
  295.                 (string? (cdr item))))
  296.           (error "Malformed init-file map item:" item))
  297.           (loop (cons item result)))))))
  298.  
  299.   (define (generate-fat-init-file directory)
  300.     (let loop ((index 1))
  301.       (let ((filename
  302.          (string-append "ini"
  303.                 (string-pad-left (number->string index) 5 #\0)
  304.                 ".dat")))
  305.     (if (file-exists? (merge-pathnames filename directory))
  306.         (loop (+ index 1))
  307.         filename))))
  308.  
  309.   (guarantee-init-file-specifier specifier 'INIT-FILE-SPECIFIER->PATHNAME)
  310.   (let ((long-base (merge-pathnames ".mit-scheme/" (user-homedir-pathname))))
  311.     (if (dos/fs-long-filenames? long-base)
  312.     (if (null? specifier)
  313.         (directory-pathname-as-file long-base)
  314.         (merge-pathnames
  315.          (apply string-append
  316.             (cons (car specifier)
  317.               (append-map (lambda (string) (list "/" string))
  318.                       (cdr specifier))))
  319.          long-base))
  320.     (let ((short-base
  321.            (merge-pathnames "mitschem.ini/" (user-homedir-pathname))))
  322.       (let ((file-map-pathname (merge-pathnames "filemap.dat" short-base)))
  323.         (let ((port #f))
  324.           (dynamic-wind
  325.            (lambda ()
  326.          (set! port (open-i/o-file file-map-pathname))
  327.          unspecific)
  328.            (lambda ()
  329.          (merge-pathnames
  330.           (or (let ((entry
  331.                  (assoc specifier (read-fat-init-file-map port))))
  332.             (and entry
  333.                  (cdr entry)))
  334.               (let ((filename (generate-fat-init-file short-base)))
  335.             (let ((channel (port/output-channel port)))
  336.               (channel-file-set-position
  337.                channel
  338.                (channel-file-length channel)))
  339.             (write (cons specifier filename) port)
  340.             (newline port)
  341.             filename))
  342.           short-base))
  343.            (lambda ()
  344.          (if port
  345.              (begin
  346.                (close-port port)
  347.                (set! port #f)
  348.                unspecific))))))))))
  349.  
  350. (define (initialize-system-primitives!)
  351.   (discard-select-registry-result-vectors!)
  352.   (add-event-receiver! event:after-restart
  353.                discard-select-registry-result-vectors!))
  354.  
  355. (define os2/select-registry-lub)
  356. (define select-registry-result-vectors)
  357.  
  358. (define (discard-select-registry-result-vectors!)
  359.   (set! os2/select-registry-lub ((ucode-primitive os2-select-registry-lub 0)))
  360.   (set! select-registry-result-vectors '())
  361.   unspecific)
  362.  
  363. (define (allocate-select-registry-result-vector)
  364.   (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
  365.     (let ((v
  366.        (let loop ((rv select-registry-result-vectors))
  367.          (cond ((null? rv)
  368.             (make-string os2/select-registry-lub))
  369.            ((car rv)
  370.             => (lambda (v) (set-car! rv #f) v))
  371.            (else
  372.             (loop (cdr rv)))))))
  373.       (set-interrupt-enables! interrupt-mask)
  374.       v)))
  375.  
  376. (define (deallocate-select-registry-result-vector v)
  377.   (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
  378.     (let loop ((rv select-registry-result-vectors))
  379.       (cond ((null? rv)
  380.          (set! select-registry-result-vectors
  381.            (cons v select-registry-result-vectors)))
  382.         ((car rv)
  383.          (loop (cdr rv)))
  384.         (else
  385.          (set-car! rv v))))
  386.     (set-interrupt-enables! interrupt-mask))
  387.   unspecific)
  388.  
  389. (define (make-select-registry . descriptors)
  390.   (let ((registry (make-string os2/select-registry-lub)))
  391.     (vector-8b-fill! registry 0 os2/select-registry-lub 0)
  392.     (do ((descriptors descriptors (cdr descriptors)))
  393.     ((null? descriptors))
  394.       (add-to-select-registry! registry (car descriptors)))
  395.     registry))
  396.  
  397. (define (os2/guarantee-select-descriptor descriptor procedure)
  398.   (if (not (and (fix:fixnum? descriptor)
  399.         (fix:<= 0 descriptor)
  400.         (fix:< descriptor os2/select-registry-lub)))
  401.       (error:wrong-type-argument descriptor "select descriptor" procedure))
  402.   descriptor)
  403.  
  404. (define (add-to-select-registry! registry descriptor)
  405.   (os2/guarantee-select-descriptor descriptor 'ADD-TO-SELECT-REGISTRY!)
  406.   (vector-8b-set! registry descriptor 1))
  407.  
  408. (define (remove-from-select-registry! registry descriptor)
  409.   (os2/guarantee-select-descriptor descriptor 'REMOVE-FROM-SELECT-REGISTRY!)
  410.   (vector-8b-set! registry descriptor 0))
  411.  
  412. (define (select-descriptor descriptor block?)
  413.   (vector-ref os2/select-result-values
  414.           ((ucode-primitive os2-select-descriptor 2) descriptor block?)))
  415.  
  416. (define (select-registry-test registry block?)
  417.   (let ((result-vector (allocate-select-registry-result-vector)))
  418.     (let ((result
  419.        ((ucode-primitive os2-select-registry-test 3) registry
  420.                              result-vector
  421.                              block?)))
  422.       (if (fix:= result 0)
  423.       (let loop
  424.           ((index (fix:- os2/select-registry-lub 1))
  425.            (descriptors '()))
  426.         (let ((descriptors
  427.            (if (fix:= 0 (vector-8b-ref result-vector index))
  428.                descriptors
  429.                (cons index descriptors))))
  430.           (if (fix:= 0 index)
  431.           (begin
  432.             (deallocate-select-registry-result-vector result-vector)
  433.             descriptors)
  434.           (loop (fix:- index 1) descriptors))))
  435.       (begin
  436.         (deallocate-select-registry-result-vector result-vector)
  437.         (vector-ref os2/select-result-values result))))))
  438.  
  439. (define os2/select-result-values
  440.   '#(INPUT-AVAILABLE #F INTERRUPT PROCESS-STATUS-CHANGE))
  441.  
  442. ;;;; Subprocess/Shell Support
  443.  
  444. (define (os/make-subprocess filename arguments environment working-directory
  445.                 ctty stdin stdout stderr)
  446.   (if ctty
  447.       (error "Can't manipulate controlling terminal of subprocess:" ctty))
  448.   ((ucode-primitive os2-make-subprocess 7)
  449.    filename
  450.    (os2/rewrite-subprocess-arguments (vector->list arguments))
  451.    (and environment
  452.     (os2/rewrite-subprocess-environment (vector->list environment)))
  453.    working-directory
  454.    stdin
  455.    stdout
  456.    stderr))
  457.  
  458. (define (os2/rewrite-subprocess-arguments strings)
  459.   (let ((strings
  460.      (cond ((null? strings) (list "" ""))
  461.            ((null? (cdr strings)) (list (car strings) ""))
  462.            (else strings))))
  463.     (let ((result
  464.        (make-string
  465.         (reduce +
  466.             0
  467.             (map (lambda (s) (fix:+ (string-length s) 1)) strings)))))
  468.       (let ((n (string-length (car strings))))
  469.     (substring-move! (car strings) 0 n result 0)
  470.     (string-set! result n #\NUL)
  471.     (let loop ((strings (cdr strings)) (index (fix:+ n 1)))
  472.       (let ((n (string-length (car strings))))
  473.         (substring-move! (car strings) 0 n result index)
  474.         (if (null? (cdr strings))
  475.         (string-set! result (fix:+ index n) #\NUL)
  476.         (begin
  477.           (string-set! result (fix:+ index n) #\space)
  478.           (loop (cdr strings) (fix:+ (fix:+ index n) 1)))))))
  479.       result)))
  480.  
  481. (define (os2/rewrite-subprocess-environment strings)
  482.   (let ((result
  483.      (make-string
  484.       (reduce +
  485.           0
  486.           (map (lambda (s) (fix:+ (string-length s) 1)) strings)))))
  487.     (let loop ((strings strings) (index 0))
  488.       (if (not (null? strings))
  489.       (let ((n (string-length (car strings))))
  490.         (substring-move! (car strings) 0 n result index)
  491.         (string-set! result (fix:+ index n) #\NUL)
  492.         (loop (cdr strings) (fix:+ (fix:+ index n) 1)))))
  493.     result))
  494.  
  495. (define (os/find-program program default-directory #!optional exec-path error?)
  496.   (let ((namestring
  497.      (let* ((exec-path
  498.          (if (default-object? exec-path)
  499.              (os/exec-path)
  500.              exec-path))
  501.         (try
  502.          (let ((types (os/executable-pathname-types)))
  503.            (lambda (pathname)
  504.              (let ((type (pathname-type pathname)))
  505.                (if type
  506.                (and (member type types)
  507.                 (file-exists? pathname)
  508.                 (->namestring pathname))
  509.                (let loop ((types types))
  510.                  (and (not (null? types))
  511.                   (let ((p
  512.                      (pathname-new-type pathname
  513.                                 (car types))))
  514.                     (if (file-exists? p)
  515.                     (->namestring p)
  516.                     (loop (cdr types)))))))))))
  517.         (try-dir
  518.          (lambda (directory)
  519.            (try (merge-pathnames program directory)))))
  520.        (cond ((pathname-absolute? program)
  521.           (try program))
  522.          ((not default-directory)
  523.           (let loop ((path exec-path))
  524.             (and (not (null? path))
  525.              (or (and (pathname-absolute? (car path))
  526.                   (try-dir (car path)))
  527.                  (loop (cdr path))))))
  528.          (else
  529.           (let ((default-directory
  530.               (merge-pathnames default-directory)))
  531.             (let loop ((path exec-path))
  532.               (and (not (null? path))
  533.                (or (try-dir
  534.                 (merge-pathnames (car path) default-directory))
  535.                    (loop (cdr path)))))))))))
  536.     (if (and (not namestring)
  537.          (if (default-object? error) #t error?))
  538.     (error "Can't find program:" (->namestring program)))
  539.     namestring))
  540.  
  541. (define (os/exec-path)
  542.   (os/parse-path-string
  543.    (let ((path (get-environment-variable "PATH")))
  544.      (if (not path)
  545.      (error "Can't find PATH environment variable."))
  546.      path)))
  547.  
  548. (define (os/parse-path-string string)
  549.   (let ((end (string-length string))
  550.     (substring
  551.      (lambda (string start end)
  552.        (pathname-as-directory (substring string start end)))))
  553.     (let loop ((start 0))
  554.       (if (< start end)
  555.       (let ((index (substring-find-next-char string start end #\;)))
  556.         (if index
  557.         (if (= index start)
  558.             (loop (+ index 1))
  559.             (cons (substring string start index)
  560.               (loop (+ index 1))))
  561.         (list (substring string start end))))
  562.       '()))))
  563.  
  564. (define (os/shell-file-name)
  565.   (or (get-environment-variable "SHELL")
  566.       (get-environment-variable "COMSPEC")
  567.       "cmd.exe"))
  568.  
  569. (define (os/form-shell-command command)
  570.   (list "/c" command))
  571.  
  572. (define (os/executable-pathname-types)
  573.   '("exe" "com" "bat" "cmd" "btm"))