source: trunk/source/level-1/linux-files.lisp @ 11744

Last change on this file since 11744 was 11744, checked in by gb, 11 years ago

Mostly experimental changes: try to make some operations on PROCESSes
generic. Work-in-progress.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 84.2 KB
RevLine 
[6]1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
[2326]17(in-package "CCL")
18
[10637]19(defconstant unix-to-universal-time 2208988800)
[6]20
[10637]21#+windows-target
22(progn
23
[10707]24
[10637]25           
26
27(defun nbackslash-to-forward-slash (namestring)
28  (dotimes (i (length namestring) namestring)
29    (when (eql (schar namestring i) #\\)
30      (setf (schar namestring i) #\/))))
31
32(defconstant univeral-time-start-in-windows-seconds 9435484800)
33
34(defun windows-filetime-to-universal-time (ft)
35  (let* ((100-ns (dpb (pref ft #>FILETIME.dwHighDateTime) (byte 32 32)
36                      (pref ft #>FILETIME.dwLowDateTime)))
37         (seconds-since-windows-epoch (floor 100-ns 10000000)))
38    (- seconds-since-windows-epoch univeral-time-start-in-windows-seconds)))
39)
40
[7624]41(defun get-foreign-namestring (pointer)
42  ;; On Darwin, foreign namestrings are encoded in UTF-8 and
43  ;; are canonically decomposed (NFD).  Use PRECOMPOSE-SIMPLE-STRING
44  ;; to ensure that the string is "precomposed" (NFC), like the
45  ;; rest of the world and most sane people would expect.
46  #+darwin-target
47  (precompose-simple-string (%get-utf-8-cstring pointer))
[10707]48  #+windows-target (nbackslash-to-forward-slash
49                     (%get-native-utf-16-cstring pointer))
[7624]50  ;; On some other platforms, the namestring is assumed to
51  ;; be encoded according to the current locale's character
52  ;; encoding (though FreeBSD seems to be moving towards
53  ;; precomposed UTF-8.).
[10637]54  #-(or darwin-target windows-target)
[11205]55  (let* ((encoding-name (pathname-encoding-name)))
56    (if encoding-name
57      (get-encoded-cstring encoding-name pointer)
58      (%get-cstring pointer))))
[7624]59
[6]60(defun nanoseconds (n)
[3297]61  (unless (and (typep n 'fixnum)
62               (>= (the fixnum n) 0))
[9007]63    (check-type n (real 0 #.(1- (ash 1 (1- target::nbits-in-word))))))
[6]64  (multiple-value-bind (q r)
65      (floor n)
[727]66    (if (zerop r)
67      (setq r 0)
[6]68      (setq r (floor (* r 1000000000))))
69    (values q r)))
[3297]70
71(defun milliseconds (n)
72  (unless (and (typep n 'fixnum)
73               (>= (the fixnum n) 0))
[9007]74    (check-type n (real 0 #.(1- (ash 1 (1- target::nbits-in-word))))))
[3297]75  (multiple-value-bind (q r)
76      (floor n)
77    (if (zerop r)
78      (setq r 0)
79      (setq r (floor (* r 1000))))
80    (values q r)))
81
[8267]82(defun microseconds (n)
83  (unless (and (typep n 'fixnum)
84               (>= (the fixnum n) 0))
[9007]85    (check-type n (real 0 #.(1- (ash 1 (1- target::nbits-in-word))))))
[8267]86  (multiple-value-bind (q r)
87      (floor n)
88    (if (zerop r)
89      (setq r 0)
90      (setq r (floor (* r 1000000))))
91    (values q r)))
92
[6]93(defun semaphore-value (s)
94  (if (istruct-typep s 'semaphore)
95    (semaphore.value s)
96    (semaphore-value (require-type s 'semaphore))))
97
[3297]98(defun %wait-on-semaphore-ptr (s seconds milliseconds &optional flag)
[2606]99  (if flag
100    (if (istruct-typep flag 'semaphore-notification)
101      (setf (semaphore-notification.status flag) nil)
102      (report-bad-arg flag 'semaphore-notification)))
103  (without-interrupts
[2405]104   (let* ((status (ff-call
[2606]105                   (%kernel-import target::kernel-import-wait-on-semaphore)
106                   :address s
107                   :unsigned seconds
[3297]108                   :unsigned milliseconds
[2606]109                   :signed))
110          (result (zerop status)))     
[2405]111     (declare (fixnum status))
[2606]112     (when flag (setf (semaphore-notification.status flag) result))
113     (values result status))))
[6]114
[4689]115(defun %process-wait-on-semaphore-ptr (s seconds milliseconds &optional
[6200]116                                         (whostate "semaphore wait") flag)
117  (or (%wait-on-semaphore-ptr s 0 0 flag)
118      (with-process-whostate  (whostate)
119        (loop
120          (when (%wait-on-semaphore-ptr s seconds milliseconds flag)
121            (return))))))
122
[6]123 
[2940]124(defun wait-on-semaphore (s &optional flag (whostate "semaphore wait"))
[2438]125  "Wait until the given semaphore has a positive count which can be
126atomically decremented."
[6200]127  (%process-wait-on-semaphore-ptr (semaphore-value s) #xffffff 0 whostate flag)
[2405]128  t)
[6]129
[4689]130
131(defun %timed-wait-on-semaphore-ptr (semptr duration notification)
[6200]132  (or (%wait-on-semaphore-ptr semptr 0 0 notification)
133      (with-process-whostate ("Semaphore timed wait")
134        (multiple-value-bind (secs millis) (milliseconds duration)
135          (let* ((now (get-internal-real-time))
136                 (stop (+ now
137                          (* secs 1000)
138                          millis)))
139            (loop
140              (multiple-value-bind (success err)
141                  (progn
142                    (%wait-on-semaphore-ptr semptr secs millis notification))
143                (when success
144                  (return t))
145                (when (or (not (eql err #$EINTR))
146                          (>= (setq now (get-internal-real-time)) stop))
147                  (return nil))
148                (unless (zerop duration)
149                  (let* ((diff (- stop now)))
150                    (multiple-value-bind (remaining-seconds remaining-millis)
151                        (floor diff 1000)
152                      (setq secs remaining-seconds
153                            millis remaining-millis)))))))))))
[6]154
[4689]155(defun timed-wait-on-semaphore (s duration &optional notification)
156  "Wait until the given semaphore has a postive count which can be
157atomically decremented, or until a timeout expires."
158  (%timed-wait-on-semaphore-ptr (semaphore-value s) duration notification))
[2405]159
[4689]160
[6]161(defun %signal-semaphore-ptr (p)
162  (ff-call
[1671]163   (%kernel-import target::kernel-import-signal-semaphore)
[6]164   :address p
165   :signed-fullword))
166
167(defun signal-semaphore (s)
[2438]168  "Atomically increment the count of a given semaphore."
[6]169  (%signal-semaphore-ptr (semaphore-value s)))
170
[10637]171(defun %os-getcwd (buf noctets)
[6]172  ;; Return N < 0, if error
[10637]173  ;;        N < noctets: success, string is of length N (octets).
174  ;;        N >= noctets: buffer needs to be larger.
175  (let* ((p #+windows-target
176           (#__wgetcwd buf (ash noctets -1))
177           #-windows-target
178           (#_getcwd buf noctets)))
[6]179    (declare (dynamic-extent p))
180    (if (%null-ptr-p p)
181      (let* ((err (%get-errno)))
182        (if (eql err (- #$ERANGE))
[10637]183          (+ noctets noctets)
[6]184          err))
[10637]185      #+windows-target
186      (do* ((i 0 (+ i 2)))
187           ((= i noctets) (+ noctets noctets))
188        (when (eql (%get-unsigned-word buf i) 0)
189          (return i)))
190      #-windows-target
191      (dotimes (i noctets (+ noctets noctets))
[6]192        (when (eql 0 (%get-byte buf i))
193          (return i))))))
194   
195   
196(defun current-directory-name ()
[2444]197  "Look up the current working directory of the OpenMCL process; unless
198it has been changed, this is the directory OpenMCL was started in."
[6]199  (flet ((try-getting-dirname (bufsize)
200           (%stack-block ((buf bufsize))
201             (let* ((len (%os-getcwd buf bufsize)))
[10637]202               (cond ((< len 0) (%errno-disp len))
[6]203                     ((< len bufsize)
[11125]204                      (setf (%get-unsigned-byte buf len) 0)
[7624]205                      (values (get-foreign-namestring buf) len))
[6]206                     (t (values nil len)))))))
207    (do* ((string nil)
[10637]208          (len #+windows-target 128 #-windows-target 64)
[6]209          (bufsize len len))
210         ((multiple-value-setq (string len) (try-getting-dirname bufsize))
211          string))))
212
213
[1150]214(defun current-directory ()
215  (mac-default-directory))
216
217(defun (setf current-directory) (path)
218  (cwd path)
219  path)
220
[1866]221(defun cd (path)
222  (cwd path))
223
[8343]224
[10637]225
[10692]226
[6]227(defun %chdir (dirname)
[8343]228  (with-filename-cstrs ((dirname dirname))
[10637]229    (int-errno-call (#+windows-target #__wchdir #-windows-target #_chdir dirname))))
[6]230
231(defun %mkdir (name mode)
[10637]232  #+windows-target (declare (ignore mode))
[7624]233  (let* ((name name)
234         (len (length name)))
235    (when (and (> len 0) (eql (char name (1- len)) #\/))
236      (setq name (subseq name 0 (1- len))))
[8343]237    (with-filename-cstrs ((name name))
[10637]238      (int-errno-call (#+windows-target #__wmkdir #-windows-target #_mkdir  name #-windows-target mode)))))
[6]239
[7517]240(defun %rmdir (name)
241  (let* ((last (1- (length name))))
[8343]242    (with-filename-cstrs ((name name))
[7517]243      (when (and (>= last 0)
244                 (eql (%get-byte name last) (char-code #\/)))
245        (setf (%get-byte name last) 0))
[10637]246      (int-errno-call (#+windows-target #__wrmdir #-windows-target #_rmdir  name)))))
[7517]247
[7624]248
[6]249(defun getenv (key)
[2444]250  "Look up the value of the environment variable named by name, in the
251OS environment."
[6]252  (with-cstrs ((key (string key)))
253    (let* ((env-ptr (%null-ptr)))
254      (declare (dynamic-extent env-ptr))
255      (%setf-macptr env-ptr (#_getenv key))
256      (unless (%null-ptr-p env-ptr)
257        (%get-cstring env-ptr))))
258  )
259
260(defun setenv (key value &optional (overwrite t))
[2444]261  "Set the value of the environment variable named by name, in the OS
262environment. If there is no such environment variable, create it."
[10637]263  #+windows-target (declare (ignore overwrite))
264  #-windows-target
[6]265  (with-cstrs ((ckey key)
266               (cvalue value))
[10637]267    (#_setenv ckey cvalue (if overwrite 1 0)))
268  #+windows-target
269  (with-cstrs ((pair (format nil "~a=~a" key value)))
270    (#__putenv pair))
271  )
[6]272
[10637]273#-windows-target                        ; Windows "impersonation" crap ?
[6]274(defun setuid (uid)
[2444]275  "Attempt to change the current user ID (both real and effective);
276fails unless the OpenMCL process has super-user privileges or the ID
277given is that of the current user."
[10515]278  (int-errno-call (#_setuid uid)))
[6]279
[10637]280#-windows-target
[6]281(defun setgid (uid)
[2444]282  "Attempt to change the current group ID (both real and effective);
283fails unless the OpenMCL process has super-user privileges or the ID
284given is that of a group to which the current user belongs."
[10515]285  (int-errno-call (#_setgid uid)))
[6]286 
287
288;;; On Linux, "stat" & friends are implemented in terms of deeper,
289;;; darker things that need to know what version of the stat buffer
290;;; they're talking about.
291
[10637]292#-windows-target
[6]293(defun %stat-values (result stat)
294  (if (eql 0 (the fixnum result)) 
295      (values
296       t
297       (pref stat :stat.st_mode)
298       (pref stat :stat.st_size)
[10053]299       #+(or linux-target solaris-target)
[812]300       (pref stat :stat.st_mtim.tv_sec)
[10053]301       #-(or linux-target solaris-target)
[6]302       (pref stat :stat.st_mtimespec.tv_sec)
303       (pref stat :stat.st_ino)
[1227]304       (pref stat :stat.st_uid)
[8343]305       (pref stat :stat.st_blksize)
[10053]306       #+(or linux-target solaris-target)
[8351]307       (round (pref stat :stat.st_mtim.tv_nsec) 1000)
[10053]308       #-(or linux-target solaris-target)
[8343]309       (round (pref stat :stat.st_mtimespec.tv_nsec) 1000)
310       (pref stat :stat.st_gid))
[1227]311      (values nil nil nil nil nil nil nil)))
[6]312
[10637]313#+win64-target
314(defun %stat-values (result stat)
315  (if (eql 0 (the fixnum result)) 
316      (values
317       t
318       (pref stat :_stat64.st_mode)
319       (pref stat :_stat64.st_size)
320       (pref stat :_stat64.st_mtime)
321       (pref stat :_stat64.st_ino)
322       (pref stat :_stat64.st_uid)
323       #$BUFSIZ
324       (pref stat :_stat64.st_mtime)     ; ???
325       (pref stat :_stat64.st_gid))
326      (values nil nil nil nil nil nil nil nil nil)))
[6]327
[10897]328#+win32-target
329(defun %stat-values (result stat)
330  (if (eql 0 (the fixnum result)) 
331      (values
332       t
333       (pref stat :__stat64.st_mode)
334       (pref stat :__stat64.st_size)
335       (pref stat :__stat64.st_mtime)
336       (pref stat :__stat64.st_ino)
337       (pref stat :__stat64.st_uid)
338       #$BUFSIZ
339       (pref stat :__stat64.st_mtime)     ; ???
340       (pref stat :__stat64.st_gid))
341      (values nil nil nil nil nil nil nil nil nil)))
342
[10637]343#+windows-target
344(defun windows-strip-trailing-slash (namestring)
345  (do* ((len (length namestring) (length namestring)))
346       ((<= len 3) namestring)
347    (let* ((p (1- len))
348           (ch (char namestring p)))
349      (unless (or (eql ch #\\)
350                  (eql ch #\/))
351        (return namestring))
352      (setq namestring (subseq namestring 0 p)))))
353
354
[6]355(defun %%stat (name stat)
[10637]356  (with-filename-cstrs ((cname #+windows-target (windows-strip-trailing-slash name) #-windows-target name))
[6]357    (%stat-values
[3960]358     #+linux-target
[6]359     (#_ __xstat #$_STAT_VER_LINUX cname stat)
[4828]360     #-linux-target
[10692]361     (int-errno-ffcall (%kernel-import target::kernel-import-lisp-stat)
362                       :address cname
363                       :address stat
364                       :int)
[6]365     stat)))
366
367(defun %%fstat (fd stat)
368  (%stat-values
[3960]369   #+linux-target
[6]370   (#_ __fxstat #$_STAT_VER_LINUX fd stat)
[4994]371   #-linux-target
[10692]372   (int-errno-ffcall (%kernel-import target::kernel-import-lisp-fstat)
373                     :int fd
374                     :address stat
375                     :int)
[6]376   stat))
377
[10637]378#-windows-target
[6]379(defun %%lstat (name stat)
[8343]380  (with-filename-cstrs ((cname name))
[6]381    (%stat-values
[3960]382     #+linux-target
[6]383     (#_ __lxstat #$_STAT_VER_LINUX cname stat)
[4828]384     #-linux-target
[10515]385     (#_lstat cname stat)
[6]386     stat)))
387
388
[7735]389;;; Returns: (values t mode size mtime inode uid blksize) on success,
390;;;          (values nil nil nil nil nil nil nil) otherwise
391;;; NAME should be a "native namestring", e.g,, have all lisp pathname
392;;; escaping removed.
[10637]393#-windows-target
[6]394(defun %stat (name &optional link-p)
395  (rlet ((stat :stat))
396    (if link-p
397      (%%lstat name stat)
398      (%%stat name stat))))
399
[10637]400#+windows-target
401(defun %stat (name &optional link-p)
402  (declare (ignore link-p))
[10897]403  (rlet ((stat  #+win64-target #>_stat64 #+win32-target #>__stat64))
[10637]404    (%%stat name stat)))
405
[6]406(defun %fstat (fd)
[10897]407  (rlet ((stat #+win64-target #>_stat64 #+win32-target #>__stat64 #-windows-target :stat))
[6]408    (%%fstat fd stat)))
409
410
[11081]411(defun %file-kind (mode &optional fd)
412  (declare (ignorable fd))
[6]413  (when mode
414    (let* ((kind (logand mode #$S_IFMT)))
415      (cond ((eql kind #$S_IFDIR) :directory)
416            ((eql kind #$S_IFREG) :file)
[10637]417            #-windows-target
[6]418            ((eql kind #$S_IFLNK) :link)
[11081]419            ((eql kind #$S_IFIFO) 
420             #-windows-target :pipe
421             ;; Windows doesn't seem to be able to distinguish between
422             ;; sockets and pipes.  Since this function is currently
423             ;; (mostly) used for printing streams and since we've
424             ;; already done something fairly expensive (stat, fstat)
425             ;; to get here.  try to distinguish between pipes and
426             ;; sockets by calling #_getsockopt.  If that succeeds,
427             ;; we've got a socket; otherwise, we're probably got a pipe.
428             #+windows-target (rlet ((ptype :int)
429                                     (plen :int 4))
430                                (if (and fd (eql 0 (#_getsockopt fd #$SOL_SOCKET #$SO_TYPE  ptype plen)))
431                                    :socket
432                                    :pipe)))
[10637]433            #-windows-target
[6]434            ((eql kind #$S_IFSOCK) :socket)
435            ((eql kind #$S_IFCHR) :character-special)
436            (t :special)))))
437
[8932]438(defun %unix-file-kind (native-namestring &optional check-for-link)
439  (%file-kind (nth-value 1 (%stat native-namestring check-for-link))))
[6]440
441(defun %unix-fd-kind (fd)
442  (if (isatty fd)
443    :tty
[11081]444    (%file-kind (nth-value 1 (%fstat fd)) fd)))
[6]445
[10637]446#-windows-target
[6]447(defun %uts-string (result idx buf)
[10182]448  (if (>= result 0)
[3960]449    (%get-cstring (%inc-ptr buf (* #+linux-target #$_UTSNAME_LENGTH
[4994]450                                   #+darwin-target #$_SYS_NAMELEN
[10053]451                                   #+(or freebsd-target solaris-target) #$SYS_NMLN
452                                   idx)))
[6]453    "unknown"))
454
[10683]455#-windows-target
[8343]456(defun copy-file-attributes (source-path dest-path)
457  "Copy the mode, owner, group and modification time of source-path to dest-path.
458   Returns T if succeeded, NIL if some of the attributes couldn't be copied due to
459   permission problems.  Any other failures cause an error to be signalled"
460  (multiple-value-bind (win mode ignore mtime-sec ignore uid ignore mtime-usec gid)
461                       (%stat (native-translated-namestring source-path) t)
462    (declare (ignore ignore))
463    (unless win
464      (error "Cannot get attributes of ~s" source-path))
465    (with-filename-cstrs ((cnamestr (native-translated-namestring dest-path)))
466      (macrolet ((errchk (form)
467                   `(let ((err ,form))
468                      (unless (eql err 0)
469                        (setq win nil)
470                        (when (eql err -1)
[8345]471                          (setq err (- (%get-errno))))
[8343]472                        (unless (eql err #$EPERM) (%errno-disp err dest-path))))))
473        (errchk (#_chmod cnamestr mode))
474        (errchk (%stack-block ((times (record-length (:array (:struct :timeval) 2))))
475                  (setf (pref times :timeval.tv_sec) mtime-sec)
476                  (setf (pref times :timeval.tv_usec) mtime-usec)
477                  (%incf-ptr times (record-length :timeval))
478                  (setf (pref times :timeval.tv_sec) mtime-sec)
479                  (setf (pref times :timeval.tv_usec) mtime-usec)
480                  (%incf-ptr times (- (record-length :timeval)))
481                  (#_utimes cnamestr times)))
482        (errchk (#_chown cnamestr uid gid))))
483    win))
484
[10878]485#+windows-target
486(defun copy-file-attributes (source-path dest-path)
487  "could at least copy the file times"
488  (declare (ignore source-path dest-path)))
489
490
[3960]491#+linux-target
[6]492(defun %uname (idx)
[3960]493  (%stack-block ((buf (* #$_UTSNAME_LENGTH 6))) 
[10515]494    (%uts-string (#_uname buf) idx buf)))
[6]495
[4994]496#+darwin-target
[6]497(defun %uname (idx)
[3960]498  (%stack-block ((buf (* #$_SYS_NAMELEN 5)))
[6]499    (%uts-string (#_uname buf) idx buf)))
500
[4828]501#+freebsd-target
502(defun %uname (idx)
503  (%stack-block ((buf (* #$SYS_NMLN 5)))
504    (%uts-string (#___xuname #$SYS_NMLN buf) idx buf)))
505
[10053]506#+solaris-target
507(defun %uname (idx)
508  (%stack-block ((buf (* #$SYS_NMLN 5)))
509    (%uts-string (#_uname buf) idx buf)))
510
[10637]511#-windows-target
[6]512(defun fd-dup (fd)
[10515]513  (int-errno-call (#_dup fd)))
[6]514
[10637]515#+windows-target
516(defun fd-dup (fd &key direction inheritable)
[11081]517  (declare (ignore direction))
[10637]518  (rlet ((handle #>HANDLE))
519    (#_DuplicateHandle (#_GetCurrentProcess)
[11081]520                       fd
[10637]521                       (#_GetCurrentProcess) 
522                       handle
523                       0
524                       (if inheritable #$TRUE #$FALSE)
[11081]525                       #$DUPLICATE_SAME_ACCESS)))
[10637]526
[11125]527
[6]528(defun fd-fsync (fd)
[11309]529  #+windows-target (#_FlushFileBuffers (%int-to-ptr fd))
[10637]530  #-windows-target
[10515]531  (int-errno-call (#_fsync fd)))
[6]532
[10637]533#-windows-target
534(progn
[6]535(defun fd-get-flags (fd)
[10515]536  (int-errno-call (#_fcntl fd #$F_GETFL)))
[6]537
538(defun fd-set-flags (fd new)
[10515]539  (int-errno-call (#_fcntl fd #$F_SETFL :int new)))
[6]540
541(defun fd-set-flag (fd mask)
542  (let* ((old (fd-get-flags fd)))
543    (if (< old 0)
544      old
545      (fd-set-flags fd (logior old mask)))))
546
547(defun fd-clear-flag (fd mask)
548  (let* ((old (fd-get-flags fd)))
549    (if (< old 0) 
550      old
551      (fd-set-flags fd (logandc2 old mask)))))
[10637]552)
[6]553
[6634]554;;; Assume that any quoting's been removed already.
555(defun tilde-expand (namestring)
556  (let* ((len (length namestring)))
557    (if (or (zerop len)
558            (not (eql (schar namestring 0) #\~)))
559      namestring
560      (if (or (= len 1)
561              (eql (schar namestring 1) #\/))
562        (concatenate 'string (get-user-home-dir (getuid)) (if (= len 1) "/" (subseq namestring 1)))
[10878]563        #+windows-target namestring
564        #-windows-target
[6634]565        (let* ((slash-pos (position #\/ namestring))
566               (user-name (subseq namestring 1 slash-pos))
567               (uid (or (get-uid-from-name user-name)
568                        (error "Unknown user ~s in namestring ~s" user-name namestring))))
569          (concatenate 'string (get-user-home-dir uid) (if slash-pos (subseq namestring slash-pos) "/")))))))
570
[10637]571
572#+windows-target
573(defun %windows-realpath (namestring)
574  (with-filename-cstrs ((path namestring))
575    (do* ((bufsize 256))
576         ()
577      (%stack-block ((buf bufsize))
[10897]578        (let* ((nchars (#_GetFullPathNameW path (ash bufsize -1) buf (%null-ptr))))
[10637]579          (if (eql 0 nchars)
580            (return nil)
581            (let* ((max (+ nchars nchars 2)))
582              (if (> max bufsize)
583                (setq bufsize max)
584                (let* ((real (get-foreign-namestring buf)))
585                  (return (and (%stat real) real)))))))))))
586
[6634]587   
[6]588;;; This doesn't seem to exist on VxWorks.  It's a POSIX
589;;; function AFAIK, so the source should be somewhere ...
590
591(defun %realpath (namestring)
[10637]592  ;; It's not at all right to just return the namestring here.
[4525]593  (when (zerop (length namestring))
594    (setq namestring (current-directory-name)))
[10637]595  #+windows-target (%windows-realpath namestring)
596  #-windows-target
[3960]597  (%stack-block ((resultbuf #$PATH_MAX))
[8343]598    (with-filename-cstrs ((name namestring #|(tilde-expand namestring)|#))
[6]599      (let* ((result (#_realpath name resultbuf)))
600        (declare (dynamic-extent result))
601        (unless (%null-ptr-p result)
[7624]602          (get-foreign-namestring result))))))
[6]603
[3960]604;;; Return fully resolved pathname & file kind, or (values nil nil)
[6]605
606(defun %probe-file-x (namestring)
607  (let* ((realpath (%realpath namestring))
608         (kind (if realpath (%unix-file-kind realpath))))
609    (if kind
610      (values realpath kind)
611      (values nil nil))))
612
[10825]613;;; The mingw headers define timeval.tv_sec and timeval.tv_usec to be
614;;; signed 32-bit quantities.
615(macrolet ((timeval-ref (ptr accessor)
616             #+windows-target `(logand #xfffffffff (pref ,ptr ,accessor))
617             #-windows-target `(pref ,ptr ,accessor))
618           (set-timeval-ref (ptr accessor new)
619           `(setf (pref ,ptr ,accessor)
620             #+windows-target (u32->s32 ,new)
621             #-windows-target ,new)))
622 
[6]623(defun timeval->milliseconds (tv)
[10825]624    (+ (* 1000 (timeval-ref tv :timeval.tv_sec)) (round (timeval-ref tv :timeval.tv_usec) 1000)))
[6]625
[7951]626(defun timeval->microseconds (tv)
[10825]627    (+ (* 1000000 (timeval-ref tv :timeval.tv_sec)) (timeval-ref tv :timeval.tv_usec)))
[6]628
629(defun %add-timevals (result a b)
[10825]630  (let* ((seconds (+ (timeval-ref a :timeval.tv_sec) (timeval-ref b :timeval.tv_sec)))
631         (micros (+ (timeval-ref a :timeval.tv_usec) (timeval-ref b :timeval.tv_usec))))
[6]632    (if (>= micros 1000000)
633      (setq seconds (1+ seconds) micros (- micros 1000000)))
[10825]634    (set-timeval-ref result :timeval.tv_sec seconds)
635    (set-timeval-ref result :timeval.tv_usec micros)
[6]636    result))
637
[1825]638(defun %sub-timevals (result a b)
[10825]639  (let* ((seconds (- (timeval-ref a :timeval.tv_sec) (timeval-ref b :timeval.tv_sec)))
640         (micros (- (timeval-ref a :timeval.tv_usec) (timeval-ref b :timeval.tv_usec))))
[1825]641    (if (< micros 0)
642      (setq seconds (1- seconds) micros (+ micros 1000000)))
[10825]643    (set-timeval-ref result :timeval.tv_sec  seconds)
644    (set-timeval-ref result :timeval.tv_usec micros)
[1825]645    result))
[6]646
[8267]647;;; Return T iff the time denoted by the timeval a is not later than the
648;;; time denoted by the timeval b.
649(defun %timeval<= (a b)
[10825]650  (let* ((asec (timeval-ref a :timeval.tv_sec))
651         (bsec (timeval-ref b :timeval.tv_sec)))
[8267]652    (or (< asec bsec)
653        (and (= asec bsec)
[10825]654             (< (timeval-ref a :timeval.tv_usec)
655                (timeval-ref b :timeval.tv_usec))))))
[6]656
[10825]657); windows signed nonsense.
[8267]658
[10637]659#-windows-target
[6]660(defun %%rusage (usage &optional (who #$RUSAGE_SELF))
[10515]661  (int-errno-call (#_getrusage who usage)))
[6]662
[90]663
[6]664
665
666(defun %file-write-date (namestring)
667  (let* ((date (nth-value 3 (%stat namestring))))
668    (if date
669      (+ date unix-to-universal-time))))
670
[10637]671#-windows-target
[6]672(defun %file-author (namestring)
673  (let* ((uid (nth-value 5 (%stat namestring))))
674    (if uid
675      (with-macptrs ((pw (#_getpwuid uid)))
676        (unless (%null-ptr-p pw)
677          (without-interrupts
678           (%get-cstring (pref pw :passwd.pw_name))))))))
679
[10878]680#+windows-target
681(defun %file-author (namestring)
682  (declare (ignore namestring))
683  nil)
684
[10637]685#-windows-target
[6]686(defun %utimes (namestring)
[8343]687  (with-filename-cstrs ((cnamestring namestring))
[6]688    (let* ((err (#_utimes cnamestring (%null-ptr))))
689      (declare (fixnum err))
690      (or (eql err 0)
691          (%errno-disp err namestring)))))
692
[10878]693#+windows-target
694(defun %utimes (namestring)
695  (with-filename-cstrs ((cnamestring namestring))
696    (let* ((handle (#_CreateFileW
697                    cnamestring
698                    #$FILE_WRITE_ATTRIBUTES
699                    (logior #$FILE_SHARE_READ #$FILE_SHARE_WRITE)
700                    (%null-ptr)
701                    #$OPEN_EXISTING
702                    #$FILE_ATTRIBUTE_NORMAL
703                    (%null-ptr))))
704      (if (eql handle *windows-invalid-handle*)
705        (%windows-error-disp (#_GetLastError))
706        (rlet ((st #>SYSTEMTIME)
707               (ft #>FILETIME))
708          (#_GetSystemTime st)
709          (#_SystemTimeToFileTime st ft)
710          (let* ((result (#_SetFileTime handle (%null-ptr) (%null-ptr) ft))
711                 (err (unless (eql 0 result) (#_GetLastError))))
712            (#_CloseHandle handle)
713            (if err
714              (%windows-error-disp err)
715              t)))))))
716
717
718             
719
[10637]720#-windows-target
[6634]721(defun get-uid-from-name (name)
722  (with-cstrs ((name name))
723    (let* ((pwent (#_getpwnam name)))
724      (unless (%null-ptr-p pwent)
725        (pref pwent :passwd.pw_uid)))))
726
[10637]727
[6]728(defun isatty (fd)
[10637]729  #+windows-target (declare (ignore fd))
730  #+windows-target nil
731  #-windows-target
[6]732  (= 1 (#_isatty fd)))
733
734(defun %open-dir (namestring)
[8343]735  (with-filename-cstrs ((name namestring))
[10664]736    (let* ((DIR (ff-call (%kernel-import target::kernel-import-lisp-opendir)
[10662]737                         :address name
738                         :address)))
[6]739      (unless (%null-ptr-p DIR)
740        DIR))))
741
742(defun close-dir (dir)
[10664]743  (ff-call (%kernel-import target::kernel-import-lisp-closedir)
[10662]744           :address dir
745           :int))
[6]746
747(defun %read-dir (dir)
[10668]748  (let* ((res (ff-call (%kernel-import target::kernel-import-lisp-readdir)
[10662]749                       :address dir
750                       :address)))
[10637]751    (unless (%null-ptr-p res)
[10662]752      (get-foreign-namestring (pref res
753                                    #+windows-target :_wdirent.d_name
754                                    #-windows-target :dirent.d_name)))))
[6]755
[10637]756
757#-windows-target
[6]758(defun tcgetpgrp (fd)
759  (#_tcgetpgrp fd))
760
761(defun getpid ()
[2444]762  "Return the ID of the OpenMCL OS process."
[10637]763  #-windows-target
764  (int-errno-call (#_getpid))
765  #+windows-target (#_GetCurrentProcessId))
[6]766
[10637]767
[6]768(defun getuid ()
[2444]769  "Return the (real) user ID of the current user."
[10637]770  #+windows-target 0
771  #-windows-target (int-errno-call (#_getuid)))
[6]772
773(defun get-user-home-dir (userid)
[2444]774  "Look up and return the defined home directory of the user identified
775by uid. This value comes from the OS user database, not from the $HOME
776environment variable. Returns NIL if there is no user with the ID uid."
[10637]777  #+windows-target
778  (declare (ignore userid))
779  #+windows-target
[10825]780  (dolist (k '(#||"HOME"||# "USERPROFILE")) 
781    (with-native-utf-16-cstrs ((key k))
782      (let* ((p (#__wgetenv key)))
783        (unless (%null-ptr-p p)
784          (return (get-foreign-namestring p))))))
[10637]785  #-windows-target
[4828]786  (rlet ((pwd :passwd)
[11125]787         (result :address pwd))
[4828]788    (do* ((buflen 512 (* 2 buflen)))
789         ()
790      (%stack-block ((buf buflen))
[10067]791        (let* ((err
792                #-solaris-target
793                 (#_getpwuid_r userid pwd buf buflen result)
794                 #+solaris-target
795                 (external-call "__posix_getpwuid_r"
796                                :uid_t userid
797                                :address pwd
798                                :address buf
799                                :int buflen
800                                :address result
801                                :int)))
[4828]802          (if (eql 0 err)
[11125]803            (return (let* ((rp (%get-ptr result)))
804                      (unless (%null-ptr-p rp)
805                        (get-foreign-namestring (pref rp :passwd.pw_dir)))))
[4828]806            (unless (eql err #$ERANGE)
807              (return nil))))))))
[6]808
809(defun %delete-file (name)
810  (with-cstrs ((n name))
[10637]811    (int-errno-call (#+windows-target #__unlink #-windows-target #_unlink n))))
[6]812
813(defun os-command (string)
[2444]814  "Invoke the Posix function system(), which invokes the user's default
815system shell (such as sh or tcsh) as a new process, and has that shell
816execute command-line.
817
818If the shell was able to find the command specified in command-line, then
819exit-code is the exit code of that command. If not, it is the exit code
820of the shell itself."
[6]821  (with-cstrs ((s string))
822    (#_system s)))
823
824(defun %strerror (errno)
825  (declare (fixnum errno))
826  (if (< errno 0)
827    (setq errno (- errno)))
828  (with-macptrs (p)
829    (%setf-macptr p (#_strerror errno))
830    (if (%null-ptr-p p)
831      (format nil "OS Error %d" errno)
832      (%get-cstring p))))
833
[10637]834#+windows-target
835(defun %windows-error-string (error-number) 
[10897]836  (rlet ((pbuffer :address (%null-ptr)))
[10637]837    (if (eql 0
838             (#_FormatMessageW (logior #$FORMAT_MESSAGE_ALLOCATE_BUFFER
839                                       #$FORMAT_MESSAGE_FROM_SYSTEM
840                                       #$FORMAT_MESSAGE_IGNORE_INSERTS
841                                       #$FORMAT_MESSAGE_MAX_WIDTH_MASK)
[10897]842                               (%null-ptr)
[10637]843                               (abs error-number)
844                               0                 ; default langid, more-or-less
845                               pbuffer
846                               0
[10897]847                               (%null-ptr)))
[10637]848      (format nil "Windows error ~d" (abs error-number))
849      (let* ((p (%get-ptr pbuffer))
850             (q (%get-native-utf-16-cstring p)))
851        (#_LocalFree p)
852        q))))
853       
854                     
855
[6]856;;; Kind of has something to do with files, and doesn't work in level-0.
[10053]857#+(or linux-target freebsd-target solaris-target)
[6]858(defun close-shared-library (lib &key (completely t))
[2442]859  "If completely is T, set the reference count of library to 0. Otherwise,
860decrements it by 1. In either case, if the reference count becomes 0,
861close-shared-library frees all memory resources consumed library and causes
862any EXTERNAL-ENTRY-POINTs known to be defined by it to become unresolved."
[6]863  (let* ((lib (if (typep lib 'string)
864                (or (shared-library-with-name lib)
865                    (error "Shared library ~s not found." lib))
866                (require-type lib 'shlib)))
[8587]867         (handle (shlib.handle lib)))
868      (when handle
[6]869        (let* ((found nil)
870               (base (shlib.base lib)))
871          (do* ()
872               ((progn           
[8587]873                  (#_dlclose handle)
[6]874                  (or (not (setq found (shlib-containing-address base)))
875                      (not completely)))))
876          (when (not found)
877            (setf (shlib.pathname lib) nil
878              (shlib.base lib) nil
[8587]879              (shlib.handle lib) nil
[6]880              (shlib.map lib) nil)
[812]881            (unload-foreign-variables lib)
[8587]882            (unload-library-entrypoints lib))))))
[6]883
[4994]884#+darwin-target
[6]885;; completely specifies whether to remove it totally from our list
886(defun close-shared-library (lib &key (completely nil))
[2442]887  "If completely is T, set the reference count of library to 0. Otherwise,
888decrements it by 1. In either case, if the reference count becomes 0,
889close-shared-library frees all memory resources consumed library and causes
890any EXTERNAL-ENTRY-POINTs known to be defined by it to become unresolved."
[6]891  (let* ((lib (if (typep lib 'string)
892                  (or (shared-library-with-name lib)
893                      (error "Shared library ~s not found." lib))
894                (require-type lib 'shlib))))
895    ;; no possible danger closing libsystem since dylibs can't be closed
896    (cond
897     ((or (not (shlib.map lib)) (not (shlib.base lib)))
898      (error "Shared library ~s uninitialized." (shlib.soname lib)))
899     ((and (not (%null-ptr-p (shlib.map lib)))
900           (%null-ptr-p (shlib.base lib)))
901      (warn "Dynamic libraries cannot be closed on Darwin."))
902     ((and (%null-ptr-p (shlib.map lib))
903           (not (%null-ptr-p (shlib.base lib))))
[1958]904      ;; we have a bundle type library not sure what to do with the
905      ;; completely flag when we open the same bundle more than once,
906      ;; Darwin gives back a new module address, so we have multiple
907      ;; entries on *shared-libraries* the best we can do is unlink
908      ;; the module asked for (or our best guess based on name) and
909      ;; invalidate any entries which refer to this container
[6]910      (if (= 0 (#_NSUnLinkModule (shlib.base lib) #$NSUNLINKMODULE_OPTION_NONE))
911          (error "Unable to close shared library, NSUnlinkModule failed.")
912        (progn
913          (setf (shlib.map lib) nil
914                (shlib.base lib) nil)
915          (unload-library-entrypoints lib)
916          (when completely
917            (setq *shared-libraries* (delete lib *shared-libraries*)))))))))
918
919
920
921;;; Foreign (unix) processes.
922
923(defun call-with-string-vector (function strings)
924  (let ((bufsize (reduce #'+ strings
925                         :key #'(lambda (s) (1+ (length (string s))))))
[1958]926        (argvsize (ash (1+ (length strings)) target::word-shift))
[6]927        (bufpos 0)
928        (argvpos 0))
929    (%stack-block ((buf bufsize) (argv argvsize))
930      (flet ((init (s)
931             (multiple-value-bind (sstr start end) (get-sstring s)
[5120]932               (declare (fixnum start end))
[6]933               (let ((len (- end start)))
[5120]934                 (declare (fixnum len))
935                 (do* ((i 0 (1+ i))
936                       (start start (1+ start))
937                       (bufpos bufpos (1+ bufpos)))
938                      ((= i len))
939                   (setf (%get-unsigned-byte buf bufpos)
940                         (logand #xff (%scharcode sstr start))))
[6]941                 (setf (%get-byte buf (%i+ bufpos len)) 0)
942                 (setf (%get-ptr argv argvpos) (%inc-ptr buf bufpos))
943                 (setq bufpos (%i+ bufpos len 1))
[1958]944                 (setq argvpos (%i+ argvpos target::node-size))))))
[6]945        (declare (dynamic-extent #'init))
946        (map nil #'init strings))
947      (setf (%get-ptr argv argvpos) (%null-ptr))
948      (funcall function argv))))
949
950(defmacro with-string-vector ((var &rest strings) &body body)
951  `(call-with-string-vector #'(lambda (,var) ,@body) ,@strings))
952
[10637]953(defloadvar *max-os-open-files* #-windows-target (#_getdtablesize) #+windows-target 32)
[6]954
[10683]955(defun pipe ()
956  ;;  (rlet ((filedes (:array :int 2)))
957  (%stack-block ((filedes 8))
958    (let* ((status (ff-call (%kernel-import target::kernel-import-lisp-pipe)
959                            :address filedes :int))
960           (errno (if (eql status 0) 0 (%get-errno))))
961      (unless (zerop status)
962        (when (or (eql errno (- #$EMFILE))
963                  (eql errno (- #$ENFILE)))
964          (gc)
965          (drain-termination-queue)
966          (setq status (ff-call (%kernel-import target::kernel-import-lisp-pipe)
967                            :address filedes :int)
968                errno (if (zerop status) 0 (%get-errno)))))
969      (if (zerop status)
970        (values (paref filedes (:array :int)  0) (paref filedes (:array :int)  1))
971        (%errno-disp errno)))))
972
[10637]973#-windows-target
974(progn
[11440]975  (defun %execvp (argv)
976    (#_execvp (%get-ptr argv) argv)
977    (#_exit #$EX_OSERR))
[6]978
[11440]979  (defun exec-with-io-redirection (new-in new-out new-err argv)
980    (#_setpgid 0 0)
981    (if new-in (#_dup2 new-in 0))
982    (if new-out (#_dup2 new-out 1))
983    (if new-err (#_dup2 new-err 2))
984    (do* ((fd 3 (1+ fd)))
985         ((= fd *max-os-open-files*) (%execvp argv))
986      (declare (fixnum fd))
987      (#_close fd)))
[6]988
989
990
[1958]991
[10683]992
[11440]993  (defstruct external-process
994    pid
995    %status
996    %exit-code
997    pty
998    input
999    output
1000    error
1001    status-hook
1002    plist
1003    token                               
1004    core
1005    args
1006    (signal (make-semaphore))
1007    (completed (make-semaphore))
1008    watched-fds
1009    watched-streams
1010    )
[6]1011
[11440]1012  (defmethod print-object ((p external-process) stream)
1013    (print-unreadable-object (p stream :type t :identity t)
1014      (let* ((status (external-process-%status p)))
1015        (let* ((*print-length* 3))
1016          (format stream "~a" (external-process-args p)))
1017        (format stream "[~d] (~a" (external-process-pid p) status)
1018        (unless (eq status :running)
1019          (format stream " : ~d" (external-process-%exit-code p)))
1020        (format stream ")"))))
[6]1021
[11440]1022  (defun get-descriptor-for (object proc close-in-parent close-on-error
1023                                    &rest keys
1024                                    &key direction (element-type 'character)
1025                                    (sharing :private)
1026                                    &allow-other-keys)
1027    (etypecase object
1028      ((eql t)
1029       (values nil nil close-in-parent close-on-error))
1030      (null
1031       (let* ((null-device #+windows-target "nul" #-windows-target "/dev/null")
1032              (fd (fd-open null-device (case direction
1033                                         (:input #$O_RDONLY)
1034                                         (:output #$O_WRONLY)
1035                                         (t #$O_RDWR)))))
1036         (if (< fd 0)
1037           (signal-file-error fd null-device))
1038         (values fd nil (cons fd close-in-parent) (cons fd close-on-error))))
1039      ((eql :stream)
1040       (multiple-value-bind (read-pipe write-pipe) (pipe)
1041         (case direction
1042           (:input
1043            (values read-pipe
1044                    (make-fd-stream write-pipe
1045                                    :direction :output
1046                                    :element-type element-type
1047                                    :interactive nil
1048                                    :sharing sharing
1049                                    :basic t
1050                                    :auto-close t)
1051                    (cons read-pipe close-in-parent)
1052                    (cons write-pipe close-on-error)))
1053           (:output
1054            (values write-pipe
1055                    (make-fd-stream read-pipe
1056                                    :direction :input
1057                                    :element-type element-type
1058                                    :interactive nil
1059                                    :basic t
1060                                    :sharing sharing
1061                                    :auto-close t)
1062                    (cons write-pipe close-in-parent)
1063                    (cons read-pipe close-on-error)))
1064           (t
1065            (fd-close read-pipe)
1066            (fd-close write-pipe)
1067            (report-bad-arg direction '(member :input :output))))))
1068      ((or pathname string)
1069       (with-open-stream (file (apply #'open object keys))
1070         (let* ((fd (fd-dup (ioblock-device (stream-ioblock file t)))))
1071           (values fd
1072                   nil
1073                   (cons fd close-in-parent)
1074                   (cons fd close-on-error)))))
1075      (fd-stream
1076       (let ((fd (fd-dup (ioblock-device (stream-ioblock object t)))))
[4385]1077         (values fd
1078                 nil
1079                 (cons fd close-in-parent)
[11440]1080                 (cons fd close-on-error))))
1081      (stream
1082       (ecase direction
1083         (:input
1084          (with-cstrs ((template "/tmp/lisp-tempXXXXXX"))
1085            (let* ((fd (#_mkstemp template)))
1086              (if (< fd 0)
1087                (%errno-disp fd))
1088              (#_unlink template)
1089              (loop
1090                (multiple-value-bind (line no-newline)
1091                    (read-line object nil nil)
1092                  (unless line
1093                    (return))
1094                  (let* ((len (length line)))
1095                    (%stack-block ((buf (1+ len)))
1096                      (%cstr-pointer line buf)
1097                      (fd-write fd buf len)
1098                      (if no-newline
1099                        (return))
1100                      (setf (%get-byte buf) (char-code #\newline))
1101                      (fd-write fd buf 1)))))
1102              (fd-lseek fd 0 #$SEEK_SET)
1103              (values fd nil (cons fd close-in-parent) (cons fd close-on-error)))))
1104         (:output
1105          (multiple-value-bind (read-pipe write-pipe) (pipe)
1106            (push read-pipe (external-process-watched-fds proc))
1107            (push object (external-process-watched-streams proc))
1108            (incf (car (external-process-token proc)))
1109            (values write-pipe
1110                    nil
1111                    (cons write-pipe close-in-parent)
1112                    (cons read-pipe close-on-error))))))))
[6]1113
[11440]1114  (let* ((external-processes ())
1115         (external-processes-lock (make-lock)))
1116    (defun add-external-process (p)
1117      (with-lock-grabbed (external-processes-lock)
1118        (push p external-processes)))
1119    (defun remove-external-process (p)
1120      (with-lock-grabbed (external-processes-lock)
1121        (setq external-processes (delete p external-processes))))
1122    ;; Likewise
1123    (defun external-processes ()
1124      (with-lock-grabbed (external-processes-lock)
1125        (copy-list external-processes)))
1126    )
[6]1127
1128
[11440]1129  (defmacro wtermsig (status)
1130    `(ldb (byte 7 0) ,status))
[6]1131
[11440]1132  (defmacro wexitstatus (status)
1133    `(ldb (byte 8 8) (the fixnum ,status)))
[8241]1134
[11440]1135  (defmacro wstopsig (status)
1136    `(wexitstatus ,status))
[8241]1137
[11440]1138  (defmacro wifexited (status)
1139    `(eql (wtermsig ,status) 0))
[8241]1140
[11440]1141  (defmacro wifstopped (status)
1142    `(eql #x7f (ldb (byte 7 0) (the fixnum ,status))))
[8241]1143
[11440]1144  (defun monitor-external-process (p)
1145    (let* ((in-fds (external-process-watched-fds p))
1146           (out-streams (external-process-watched-streams p))
1147           (token (external-process-token p))
1148           (terminated)
1149           (changed)
1150           (maxfd 0)
1151           (pairs (pairlis in-fds out-streams)))
1152      (%stack-block ((in-fd-set *fd-set-size*))
1153        (rlet ((tv #>timeval))
1154          (loop
1155            (when changed
[11516]1156              (setq pairs (delete nil pairs :key #'car)
[11440]1157                    changed nil))
1158            (when (and terminated (null pairs))
1159              (signal-semaphore (external-process-completed p))
1160              (return))
1161            (when pairs
1162              (fd-zero in-fd-set)
1163              (setq maxfd 0)
1164              (dolist (p pairs)
1165                (let* ((fd (car p)))
1166                  (when (> fd maxfd)
1167                    (setq maxfd fd))
1168                  (fd-set fd in-fd-set)))
1169              (setf (pref tv #>timeval.tv_sec) 1
1170                    (pref tv #>timeval.tv_usec) 0)
1171              (when (> (#_select (1+ maxfd) in-fd-set (%null-ptr) (%null-ptr) tv)
1172                       0)
1173                (dolist (p pairs)
1174                  (let* ((in-fd (car p))
1175                         (out-stream (cdr p)))
1176                    (when (fd-is-set in-fd in-fd-set)
1177                      (%stack-block ((buf 1024))
1178                        (let* ((n (fd-read in-fd buf 1024)))
1179                          (declare (fixnum n))
1180                          (if (<= n 0)
[11513]1181                            (without-interrupts
1182                              (decf (car token))
1183                              (fd-close in-fd)
[11516]1184                              (setf (car p) nil changed t))
[11440]1185                            (let* ((string (make-string 1024)))
1186                              (declare (dynamic-extent string))
1187                              (%str-from-ptr buf n string)
1188                              (write-sequence string out-stream :end n))))))))))
1189            (let* ((statusflags (check-pid (external-process-pid p)
1190                                           (logior
1191                                            (if in-fds #$WNOHANG 0)
1192                                            #$WUNTRACED)))
1193                   (oldstatus (external-process-%status p)))
1194              (cond ((null statusflags)
1195                     (remove-external-process p)
1196                     (setq terminated t))
1197                    ((eq statusflags t)) ; Running.
1198                    (t
1199                     (multiple-value-bind (status code core)
1200                         (cond ((wifstopped statusflags)
1201                                (values :stopped (wstopsig statusflags)))
1202                               ((wifexited statusflags)
1203                                (values :exited (wexitstatus statusflags)))
1204                               (t
1205                                (let* ((signal (wtermsig statusflags)))
1206                                  (declare (fixnum signal))
1207                                  (values
1208                                   (if (or (= signal #$SIGSTOP)
1209                                           (= signal #$SIGTSTP)
1210                                           (= signal #$SIGTTIN)
1211                                           (= signal #$SIGTTOU))
1212                                     :stopped
1213                                     :signaled)
1214                                   signal
1215                                   (logtest #-solaris-target #$WCOREFLAG
1216                                            #+solaris-target #$WCOREFLG
1217                                            statusflags)))))
1218                       (setf (external-process-%status p) status
1219                             (external-process-%exit-code p) code
1220                             (external-process-core p) core)
1221                       (let* ((status-hook (external-process-status-hook p)))
1222                         (when (and status-hook (not (eq oldstatus status)))
1223                           (funcall status-hook p)))
1224                       (when (or (eq status :exited)
1225                                 (eq status :signaled))
1226                         (remove-external-process p)
1227                         (setq terminated t)))))))))))
[824]1228     
[11440]1229  (defun run-external-process (proc in-fd out-fd error-fd argv &optional env)
1230    (let* ((signaled nil))
1231      (unwind-protect
1232           (let* ((child-pid (#-solaris-target #_fork #+solaris-target #_forkall)))
1233             (declare (fixnum child-pid))
1234             (cond ((zerop child-pid)
1235                    ;; Running in the child; do an exec
1236                    (setq signaled t)
1237                    (dolist (pair env)
1238                      (setenv (string (car pair)) (cdr pair)))
1239                    (without-interrupts
1240                     (exec-with-io-redirection
1241                      in-fd out-fd error-fd argv)))
1242                   ((> child-pid 0)
1243                    ;; Running in the parent: success
1244                    (setf (external-process-pid proc) child-pid)
1245                    (add-external-process proc)
1246                    (signal-semaphore (external-process-signal proc))
1247                    (setq signaled t)
1248                    (monitor-external-process proc))
1249                   (t
1250                    ;; Fork failed
1251                    (setf (external-process-%status proc) :error
1252                          (external-process-%exit-code proc) (%get-errno))
1253                    (signal-semaphore (external-process-signal proc))
1254                    (setq signaled t))))
1255        (unless signaled
1256          (setf (external-process-%status proc) :error
1257                (external-process-%exit-code proc) -1)
1258          (signal-semaphore (external-process-signal proc))))))
[6]1259
[11440]1260  (defparameter *silently-ignore-catastrophic-failure-in-run-program*
1261    #+ccl-0711 t #-ccl-0711 nil
1262    "If NIL, signal an error if run-program is unable to start the program.
[11125]1263If non-NIL, treat failure to start the same as failure from the program
1264itself, by setting the status and exit-code fields.")
1265
[11440]1266  (defun run-program (program args &key
1267                              (wait t) pty
1268                              input if-input-does-not-exist
1269                              output (if-output-exists :error)
1270                              (error :output) (if-error-exists :error)
1271                              status-hook (element-type 'character)
1272                              env
1273                              (sharing :private)
1274                              (silently-ignore-catastrophic-failures
1275                               *silently-ignore-catastrophic-failure-in-run-program*))
1276    "Invoke an external program as an OS subprocess of lisp."
1277    (declare (ignore pty))
1278    (unless (every #'(lambda (a) (typep a 'simple-string)) args)
1279      (error "Program args must all be simple strings : ~s" args))
1280    (dolist (pair env)
1281      (destructuring-bind (var . val) pair
1282        (check-type var (or string symbol character))
1283        (check-type val string)))
1284    (push (native-untranslated-namestring program) args)
1285    (let* ((token (list 0))
1286           (in-fd nil)
1287           (in-stream nil)
1288           (out-fd nil)
1289           (out-stream nil)
1290           (error-fd nil)
1291           (error-stream nil)
1292           (close-in-parent nil)
1293           (close-on-error nil)
1294           (proc
1295            (make-external-process
1296             :pid nil
1297             :args args
1298             :%status :running
1299             :input nil
1300             :output nil
1301             :error nil
1302             :token token
1303             :status-hook status-hook)))
1304      (unwind-protect
1305           (progn
1306             (multiple-value-setq (in-fd in-stream close-in-parent close-on-error)
1307               (get-descriptor-for input proc  nil nil :direction :input
1308                                   :if-does-not-exist if-input-does-not-exist
1309                                   :element-type element-type
1310                                   :sharing sharing))
1311             (multiple-value-setq (out-fd out-stream close-in-parent close-on-error)
1312               (get-descriptor-for output proc close-in-parent close-on-error
1313                                   :direction :output
1314                                   :if-exists if-output-exists
1315                                   :element-type element-type
1316                                   :sharing sharing))
1317             (multiple-value-setq (error-fd error-stream close-in-parent close-on-error)
1318               (if (eq error :output)
1319                 (values out-fd out-stream close-in-parent close-on-error)
1320                 (get-descriptor-for error proc close-in-parent close-on-error
1321                                     :direction :output
1322                                     :if-exists if-error-exists
1323                                     :sharing sharing
1324                                     :element-type element-type)))
1325             (setf (external-process-input proc) in-stream
1326                   (external-process-output proc) out-stream
1327                   (external-process-error proc) error-stream)
1328             (call-with-string-vector
1329              #'(lambda (argv)
1330                  (process-run-function
1331                   (list :name
1332                         (format nil "Monitor thread for external process ~a" args)
1333                         :stack-size (ash 128 10)
1334                         :vstack-size (ash 128 10)
1335                         :tstack-size (ash 128 10))
1336                   #'run-external-process proc in-fd out-fd error-fd argv env)
1337                  (wait-on-semaphore (external-process-signal proc)))
1338              args))
1339        (dolist (fd close-in-parent) (fd-close fd))
1340        (unless (external-process-pid proc)
1341          (dolist (fd close-on-error) (fd-close fd)))
1342        (when (and wait (external-process-pid proc))
1343          (with-interrupts-enabled
1344              (wait-on-semaphore (external-process-completed proc)))))
[4034]1345      (unless (external-process-pid proc)
[11440]1346        ;; something is wrong
1347        (if (eq (external-process-%status proc) :error)
1348          ;; Fork failed
1349          (unless silently-ignore-catastrophic-failures
1350            (cerror "Pretend the program ran and failed" 'external-process-creation-failure :proc proc))
1351          ;; Currently can't happen.
1352          (error "Bug: fork failed but status field not set?")))
1353      proc))
[6]1354
1355
1356
[11440]1357  (defmacro wifsignaled (status)
1358    (let* ((statname (gensym)))
1359      `(let* ((,statname ,status))
1360        (and (not (wifstopped ,statname)) (not (wifexited ,statname))))))
[6]1361
1362
[11440]1363  (defun check-pid (pid &optional (flags (logior  #$WNOHANG #$WUNTRACED)))
1364    (declare (fixnum pid))
1365    (rlet ((status :signed))
1366      (let* ((retval (ff-call-ignoring-eintr (#_waitpid pid status flags))))
1367        (declare (fixnum retval))
1368        (if (= retval pid)
1369          (pref status :signed)
1370          (zerop retval)))))
[6]1371
1372
1373
1374
1375
[11440]1376  (defun external-process-wait (proc &optional check-stopped)
1377    (process-wait "external-process-wait"
1378                  #'(lambda ()
1379                      (case (external-process-%status proc)
1380                        (:running)
1381                        (:stopped
1382                         (when check-stopped
1383                           t))
1384                        (t
1385                         (when (zerop (car (external-process-token proc)))
1386                           t))))))
[6]1387
[11440]1388  (defun external-process-status (proc)
1389    "Return information about whether an OS subprocess is running; or, if
[2441]1390not, why not; and what its result code was if it completed."
[11440]1391    (require-type proc 'external-process)
1392    (values (external-process-%status proc)
1393            (external-process-%exit-code proc)))
[6]1394
[11440]1395  (defun external-process-input-stream (proc)
1396    "Return the lisp stream which is used to write input to a given OS
[2441]1397subprocess, if it has one."
[11440]1398    (require-type proc 'external-process)
1399    (external-process-input proc))
[6]1400
[11440]1401  (defun external-process-output-stream (proc)
1402    "Return the lisp stream which is used to read output from a given OS
[2441]1403subprocess, if there is one."
[11440]1404    (require-type proc 'external-process)
1405    (external-process-output proc))
[6]1406
[11440]1407  (defun external-process-error-stream (proc)
1408    "Return the stream which is used to read error output from a given OS
[2441]1409subprocess, if it has one."
[11440]1410    (require-type proc 'external-process)
1411    (external-process-error proc))
[6]1412
[11440]1413  (defun external-process-id (proc)
1414    "Return the process id of an OS subprocess, a positive integer which
[2441]1415identifies it."
[11440]1416    (require-type proc 'external-process)
1417    (external-process-pid proc))
[6]1418 
[11440]1419  (defun signal-external-process (proc signal)
1420    "Send the specified signal to the specified external process.  (Typically,
[2441]1421it would only be useful to call this function if the EXTERNAL-PROCESS was
[11125]1422created with :WAIT NIL.) Return T if successful; NIL if the process wasn't
1423created successfully, and signal an error otherwise."
[11440]1424    (require-type proc 'external-process)
1425    (let* ((pid (external-process-pid proc)))
1426      (when pid
1427        (let ((error (int-errno-call (#_kill pid signal))))
1428          (or (eql error 0)
1429              (%errno-disp error))))))
[6]1430
[11440]1431  )                                     ; #-windows-target (progn
[10515]1432
[10637]1433#+windows-target
1434(progn
[11440]1435  (defun temp-file-name (prefix)
1436    "Returns a unique name for a temporary file, residing in system temp
[10637]1437space, and prefixed with PREFIX."
[11440]1438    (rlet ((buffer (:array :wchar_t #.#$MAX_PATH)))
1439      (#_GetTempPathW #$MAX_PATH buffer)
1440      (with-filename-cstrs ((c-prefix prefix)) 
1441        (#_GetTempFileNameW buffer c-prefix 0 buffer)
1442        (%get-native-utf-16-cstring buffer))))
[10637]1443 
[11440]1444  (defun get-descriptor-for (object proc close-in-parent close-on-error
1445                                    &rest keys
1446                                    &key
1447                                    direction (element-type 'character)
1448                                    (sharing :private)
1449                                    &allow-other-keys)
1450    (etypecase object
1451      ((eql t)
1452       (values nil nil close-in-parent close-on-error))
1453      (null
1454       (let* ((null-device "nul")
1455              (fd (fd-open null-device (case direction
1456                                         (:input #$O_RDONLY)
1457                                         (:output #$O_WRONLY)
1458                                         (t #$O_RDWR)))))
1459         (if (< fd 0)
1460           (signal-file-error fd null-device))
1461         (values fd nil (cons fd close-in-parent) (cons fd close-on-error))))
1462      ((eql :stream)
1463       (multiple-value-bind (read-pipe write-pipe) (pipe)
1464         (case direction
1465           (:input
1466            (values read-pipe
1467                    (make-fd-stream (fd-uninheritable write-pipe :direction :output)
1468                                    :direction :output
1469                                    :element-type element-type
1470                                    :interactive nil
1471                                    :basic t
1472                                    :sharing sharing
1473                                    :auto-close t)
1474                    (cons read-pipe close-in-parent)
1475                    (cons write-pipe close-on-error)))
1476           (:output
1477            (values write-pipe
1478                    (make-fd-stream (fd-uninheritable read-pipe :direction :input)
1479                                    :direction :input
1480                                    :element-type element-type
1481                                    :interactive nil
1482                                    :basic t
1483                                    :sharing sharing
1484                                    :auto-close t)
1485                    (cons write-pipe close-in-parent)
1486                    (cons read-pipe close-on-error)))
1487           (t
1488            (fd-close read-pipe)
1489            (fd-close write-pipe)
1490            (report-bad-arg direction '(member :input :output))))))
1491      ((or pathname string)
1492       (with-open-stream (file (apply #'open object keys))
1493         (let* ((fd (fd-dup (ioblock-device (stream-ioblock file t)) :direction direction :inheritable t)))
1494           (values fd
1495                   nil
1496                   (cons fd close-in-parent)
1497                   (cons fd close-on-error)))))
1498      (fd-stream
1499       (let ((fd (fd-dup (ioblock-device (stream-ioblock object t)))))
[10637]1500         (values fd
1501                 nil
1502                 (cons fd close-in-parent)
[11440]1503                 (cons fd close-on-error))))
1504      (stream
1505       (ecase direction
1506         (:input
1507          (let* ((tempname (temp-file-name "lisp-temp"))
1508                 (fd (fd-open tempname #$O_RDWR)))
1509            (if (< fd 0)
1510              (%errno-disp fd))
1511            (loop
1512              (multiple-value-bind (line no-newline)
1513                  (read-line object nil nil)
1514                (unless line
1515                  (return))
1516                (let* ((len (length line)))
1517                  (%stack-block ((buf (1+ len)))
1518                    (%cstr-pointer line buf)
1519                    (fd-write fd buf len)
1520                    (if no-newline
1521                      (return))
1522                    (setf (%get-byte buf) (char-code #\newline))
1523                    (fd-write fd buf 1)))))
1524            (fd-lseek fd 0 #$SEEK_SET)
1525            (values fd nil (cons fd close-in-parent) (cons fd close-on-error))))
1526         (:output
1527          (multiple-value-bind (read-pipe write-pipe) (pipe)
1528            (push read-pipe (external-process-watched-fds proc))
1529            (push object (external-process-watched-streams proc))
1530            (incf (car (external-process-token proc)))
1531            (values write-pipe
1532                    nil
1533                    (cons write-pipe close-in-parent)
1534                    (cons read-pipe close-on-error))))))))
[10637]1535
[11440]1536  (defstruct external-process
1537    pid
1538    %status
1539    %exit-code
1540    pty
1541    input
1542    output
1543    error
1544    status-hook
1545    plist
1546    token
1547    core
1548    args
1549    (signal (make-semaphore))
1550    (completed (make-semaphore))
1551    watched-fds
1552    watched-streams
1553    )
[10637]1554
[11440]1555  (defun external-process-status (proc)
1556    "Return information about whether an OS subprocess is running; or, if
[10637]1557not, why not; and what its result code was if it completed."
[11440]1558    (require-type proc 'external-process)
1559    (values (external-process-%status proc)
1560            (external-process-%exit-code proc)))
[10637]1561
1562
[11440]1563  (defmethod print-object ((p external-process) stream)
1564    (print-unreadable-object (p stream :type t :identity t)
1565      (let* ((status (external-process-%status p)))
1566        (let* ((*print-length* 3))
1567          (format stream "~a" (external-process-args p)))
1568        (format stream "[~d] (~a" (external-process-pid p) status)
1569        (unless (eq status :running)
1570          (format stream " : ~d" (external-process-%exit-code p)))
1571        (format stream ")"))))
[10637]1572
[11440]1573  (defun run-program (program args &key
1574                              (wait t) pty
1575                              input if-input-does-not-exist
1576                              output (if-output-exists :error)
1577                              (error :output) (if-error-exists :error)
1578                              status-hook (element-type 'character)
1579                              (sharing :private)
1580                              env)
1581    "Invoke an external program as an OS subprocess of lisp."
1582    (declare (ignore pty))
1583    (unless (every #'(lambda (a) (typep a 'simple-string)) args)
1584      (error "Program args must all be simple strings : ~s" args))
1585    (push program args)
1586    (let* ((token (list 0))
1587           (in-fd nil)
1588           (in-stream nil)
1589           (out-fd nil)
1590           (out-stream nil)
1591           (error-fd nil)
1592           (error-stream nil)
1593           (close-in-parent nil)
1594           (close-on-error nil)
1595           (proc
1596            (make-external-process
1597             :pid nil
1598             :args args
1599             :%status :running
1600             :input nil
1601             :output nil
1602             :error nil
1603             :token token
1604             :status-hook status-hook)))
1605      (unwind-protect
1606           (progn
1607             (multiple-value-setq (in-fd in-stream close-in-parent close-on-error)
1608               (get-descriptor-for input proc  nil nil :direction :input
1609                                   :if-does-not-exist if-input-does-not-exist
1610                                   :sharing sharing
1611                                   :element-type element-type))
1612             (multiple-value-setq (out-fd out-stream close-in-parent close-on-error)
1613               (get-descriptor-for output proc close-in-parent close-on-error
[10637]1614                                   :direction :output
[11440]1615                                   :if-exists if-output-exists
1616                                   :sharing sharing
1617                                   :element-type element-type))
1618             (multiple-value-setq (error-fd error-stream close-in-parent close-on-error)
1619               (if (eq error :output)
1620                 (values out-fd out-stream close-in-parent close-on-error)
1621                 (get-descriptor-for error proc close-in-parent close-on-error
1622                                     :direction :output
1623                                     :if-exists if-error-exists
1624                                     :sharing sharing
1625                                     :element-type element-type)))
1626             (setf (external-process-input proc) in-stream
1627                   (external-process-output proc) out-stream
1628                   (external-process-error proc) error-stream)
1629             (process-run-function
1630              (format nil "Monitor thread for external process ~a" args)
[10637]1631                   
[11440]1632              #'run-external-process proc in-fd out-fd error-fd env)
1633             (wait-on-semaphore (external-process-signal proc))
1634             )
1635        (dolist (fd close-in-parent) (fd-close fd))
1636        (if (external-process-pid proc)
1637          (when (and wait (external-process-pid proc))
1638            (with-interrupts-enabled
1639                (wait-on-semaphore (external-process-completed proc))))
1640          (progn
1641            (dolist (fd close-on-error) (fd-close fd))
1642            (error "Process execution failed"))))
1643      proc))
[10637]1644
[11440]1645  (let* ((external-processes ())
1646         (external-processes-lock (make-lock)))
1647    (defun add-external-process (p)
1648      (with-lock-grabbed (external-processes-lock)
1649        (push p external-processes)))
1650    (defun remove-external-process (p)
1651      (with-lock-grabbed (external-processes-lock)
1652        (setq external-processes (delete p external-processes))))
1653    ;; Likewise
1654    (defun external-processes ()
1655      (with-lock-grabbed (external-processes-lock)
1656        (copy-list external-processes)))
1657    )
[10637]1658
1659
1660
[10683]1661
[11440]1662  (defun run-external-process (proc in-fd out-fd error-fd &optional env)
1663    (let* ((args (external-process-args proc))
1664           (child-pid (exec-with-io-redirection in-fd out-fd error-fd args proc env)))
1665      (when child-pid
1666        (setf (external-process-pid proc) child-pid)
1667        (add-external-process proc)
1668        (signal-semaphore (external-process-signal proc))
1669        (monitor-external-process proc))))
[10637]1670
[11440]1671  (defun join-strings (strings)
1672    (reduce (lambda (left right) (concatenate 'string left " " right)) strings))
[10637]1673
[11440]1674  (defun exec-with-io-redirection (new-in new-out new-err args proc &optional env)
1675    (declare (ignore env))              ; until we can do better.
1676    (with-filename-cstrs ((command (join-strings args)))
1677      (rletz ((proc-info #>PROCESS_INFORMATION)
1678              (si #>STARTUPINFO))
1679        (setf (pref si #>STARTUPINFO.cb) (record-length #>STARTUPINFO))
1680        (setf (pref si #>STARTUPINFO.dwFlags)
1681              (logior #$STARTF_USESTDHANDLES #$STARTF_USESHOWWINDOW))
1682        (setf (pref si #>STARTUPINFO.wShowWindow) #$SW_HIDE)
1683        (setf (pref si #>STARTUPINFO.hStdInput)
1684              (if new-in
1685                (%int-to-ptr new-in)
1686                (#_GetStdHandle #$STD_INPUT_HANDLE)))
1687        (setf (pref si #>STARTUPINFO.hStdOutput)
1688              (if new-out
1689                (%int-to-ptr new-out)
1690                (#_GetStdHandle #$STD_OUTPUT_HANDLE)))
1691        (setf (pref si #>STARTUPINFO.hStdError)
1692              (if new-err
1693                (%int-to-ptr new-err)
1694                (#_GetStdHandle #$STD_ERROR_HANDLE)))
1695        (if (zerop (#_CreateProcessW (%null-ptr)
1696                                     command
1697                                     (%null-ptr)
1698                                     (%null-ptr)
1699                                     1
1700                                     #$CREATE_NEW_CONSOLE
1701                                     (%null-ptr)
1702                                     (%null-ptr)
1703                                     si
1704                                     proc-info))
1705          (setf (external-process-%status proc) :error
1706                (external-process-%exit-code proc) (#_GetLastError))
1707          (#_CloseHandle (pref proc-info #>PROCESS_INFORMATION.hThread)))
1708        (pref proc-info #>PROCESS_INFORMATION.hProcess))))
[10637]1709
[11440]1710  (defun fd-uninheritable (fd &key direction)
1711    (let ((new-fd (fd-dup fd :direction direction)))
1712      (fd-close fd)
1713      new-fd))
[10637]1714
[11448]1715 
1716  (defun data-available-on-pipe-p (hpipe)
1717    (rlet ((navail #>DWORD 0))
1718      (unless (eql 0 (#_PeekNamedPipe (if (typep hpipe 'macptr)
1719                                        hpipe
1720                                        (%int-to-ptr hpipe))
1721                                      (%null-ptr)
1722                                      0
1723                                      (%null-ptr)
1724                                      navail
1725                                      (%null-ptr)))
1726        (not (eql 0 (pref navail #>DWORD))))))
1727   
1728
1729  ;;; There doesn't seem to be any way to wait on input from an
1730  ;;; anonymous pipe in Windows (that would, after all, make too
1731  ;;; much sense.)  We -can- check for pending unread data on
1732  ;;; pipes, and can expect to eventually get EOF on a pipe.
1733  ;;; So, this tries to loop until the process handle is signaled and
1734  ;;; all data has been read.
[11516]1735 (defun monitor-external-process (p)
[11440]1736    (let* ((in-fds (external-process-watched-fds p))
1737           (out-streams (external-process-watched-streams p))
1738           (token (external-process-token p))
[11448]1739           (terminated)
1740           (changed)
1741           (pairs (pairlis in-fds out-streams))
1742           )
[11440]1743      (loop
[11448]1744        (when changed
[11516]1745          (setq pairs (delete nil pairs :key #'car)
[11448]1746                changed nil))
1747        (when (and terminated (null pairs))
[11440]1748          (without-interrupts
1749           (rlet ((code #>DWORD))
1750             (loop
1751               (#_GetExitCodeProcess (external-process-pid p) code)
1752               (unless (eql (pref code #>DWORD) #$STILL_ACTIVE)
[11448]1753                 (return))
1754               (#_SleepEx 10 #$TRUE))
[11440]1755             (setf (external-process-%exit-code p) (pref code #>DWORD)))
1756           (#_CloseHandle (external-process-pid p))
1757           (setf (external-process-pid p) nil)
1758           (setf (external-process-%status p) :exited)
1759           (let ((status-hook (external-process-status-hook p)))
1760             (when status-hook
1761               (funcall status-hook p)))
1762           (remove-external-process p)
1763           (signal-semaphore (external-process-completed p))
[11448]1764           (return)))
1765        (dolist (p pairs)
1766          (let* ((in-fd (car p))
1767                 (out-stream (cdr p)))
1768            (when (or terminated (data-available-on-pipe-p in-fd))
1769              (%stack-block ((buf 1024))
1770                (let* ((n (fd-read in-fd buf 1024)))
[11440]1771                    (declare (fixnum n))
1772                    (if (<= n 0)
[11448]1773                      (progn
1774                        (without-interrupts
1775                         (decf (car token))
1776                         (fd-close in-fd)
[11516]1777                         (setf (car p) nil changed t)))
[11448]1778
[11440]1779                      (let* ((string (make-string 1024)))
1780                        (declare (dynamic-extent string))
1781                        (%str-from-ptr buf n string)
1782                        (write-sequence string out-stream :end n))))))))
[11448]1783        (unless terminated
1784          (setq terminated (eql (#_WaitForSingleObjectEx
1785                                 (external-process-pid p)
1786                                 1000
1787                                 #$true)
1788                                #$WAIT_OBJECT_0))))))
[10637]1789 
1790
[11440]1791  )                                     ; #+windows-target (progn
[10637]1792
[6]1793;;; EOF on a TTY is transient, but I'm less sure of other cases.
1794(defun eof-transient-p (fd)
1795  (case (%unix-fd-kind fd)
1796    (:tty t)
[10637]1797    #+windows-target (:character-special t)
[6]1798    (t nil)))
[475]1799
1800
1801(defstruct (shared-resource (:constructor make-shared-resource (name)))
1802  (name)
1803  (lock (make-lock))
1804  (primary-owner *current-process*)
1805  (primary-owner-notify (make-semaphore))
1806  (current-owner nil)
1807  (requestors (make-dll-header)))
1808
1809(defstruct (shared-resource-request
1810             (:constructor make-shared-resource-request (process))
1811             (:include dll-node))
1812  process
1813  (signal (make-semaphore)))
1814             
1815
1816;; Returns NIL if already owned by calling thread, T otherwise
1817(defun %acquire-shared-resource (resource  &optional verbose)
1818  (let* ((current *current-process*))
1819    (with-lock-grabbed ((shared-resource-lock resource))
1820      (let* ((secondary (shared-resource-current-owner resource)))
1821        (if (or (eq current secondary)
1822                (and (null secondary)
1823                     (eq current (shared-resource-primary-owner resource))))
1824          (return-from %acquire-shared-resource nil))))
1825    (let* ((request (make-shared-resource-request *current-process*)))
1826      (when verbose
[11125]1827        (format t "~%~%;;;~%;;; ~a requires access to ~a~%;;; Type (:y ~D) to yield control to this thread.~%;;;~%"
1828                *current-process* (shared-resource-name resource)
1829                (process-serial-number *current-process*)))
[475]1830      (with-lock-grabbed ((shared-resource-lock resource))
1831        (append-dll-node request (shared-resource-requestors resource)))
1832      (wait-on-semaphore (shared-resource-request-signal request))
[512]1833      (assert (eq current (shared-resource-current-owner resource)))
[475]1834      (when verbose
1835        (format t "~%~%;;;~%;;; ~a is now owned by ~a~%;;;~%~%"
1836                (shared-resource-name resource) current))
1837      t)))
1838
1839;;; If we're the primary owner and there is no secondary owner, do nothing.
1840;;; If we're the secondary owner, cease being the secondary owner.
1841(defun %release-shared-resource (r)
1842  (let* ((not-any-owner ()))
1843    (with-lock-grabbed ((shared-resource-lock r))
1844      (let* ((current *current-process*)
1845             (primary (shared-resource-primary-owner r))
1846             (secondary (shared-resource-current-owner r)))
1847        (unless (setq not-any-owner
[512]1848                      (not (or (eq current secondary)
1849                               (and (null secondary)
1850                                    (eq current primary)))))
1851          (when (eq current secondary)
[475]1852            (setf (shared-resource-current-owner r) nil)
1853            (signal-semaphore (shared-resource-primary-owner-notify r))))))
1854    (when not-any-owner
1855      (signal-program-error "Process ~a does not own ~a" *current-process*
1856                            (shared-resource-name r)))))
1857
1858;;; The current thread should be the primary owner; there should be
1859;;; no secondary owner.  Wakeup the specified (or first) requesting
1860;;; process, then block on our semaphore
1861(defun %yield-shared-resource (r &optional to)
1862  (let* ((request nil))
1863    (with-lock-grabbed ((shared-resource-lock r))
1864      (let* ((current *current-process*)
1865             (primary (shared-resource-primary-owner r)))
1866        (when (and (eq current primary)
1867                   (null (shared-resource-current-owner r)))
1868          (setq request
1869                (let* ((header (shared-resource-requestors r)))
1870                  (if to 
1871                    (do-dll-nodes (node header)
1872                      (when (eq to (shared-resource-request-process node))
1873                        (return node)))
1874                    (let* ((first (dll-header-first header)))
1875                      (unless (eq first header)
1876                        first)))))
1877          (when request
1878            (remove-dll-node request)
[512]1879            (setf (shared-resource-current-owner r)
1880                  (shared-resource-request-process request))
[475]1881            (signal-semaphore (shared-resource-request-signal request))))))
1882    (when request
1883      (wait-on-semaphore (shared-resource-primary-owner-notify r))
[512]1884      (format t "~%;;;~%;;;control of ~a restored to ~a~%;;;~&"
[475]1885              (shared-resource-name r)
1886              *current-process*))))
1887
1888
1889     
1890
1891(defun %shared-resource-requestor-p (r proc)
1892  (with-lock-grabbed ((shared-resource-lock r))
1893    (do-dll-nodes (node (shared-resource-requestors r))
1894      (when (eq proc (shared-resource-request-process node))
1895        (return t)))))
1896
[2363]1897(defparameter *resident-editor-hook* nil
1898  "If non-NIL, should be a function that takes an optional argument
1899   (like ED) and invokes a \"resident\" editor.")
1900
1901(defun ed (&optional arg)
1902  (if *resident-editor-hook*
1903    (funcall *resident-editor-hook* arg)
1904    (error "This implementation doesn't provide a resident editor.")))
1905
1906(defun running-under-emacs-p ()
1907  (not (null (getenv "EMACS"))))
1908
1909(defloadvar *cpu-count* nil)
1910
1911(defun cpu-count ()
1912  (or *cpu-count*
1913      (setq *cpu-count*
[4994]1914            #+darwin-target
[2363]1915            (rlet ((info :host_basic_info)
1916                   (count :mach_msg_type_number_t #$HOST_BASIC_INFO_COUNT))
1917              (if (eql #$KERN_SUCCESS (#_host_info (#_mach_host_self)
1918                                                   #$HOST_BASIC_INFO
1919                                                   info
1920                                                   count))
1921                (pref info :host_basic_info.max_cpus)
1922                1))
[10053]1923            #+(or linux-target solaris-target)
[2363]1924            (or
[5998]1925             (let* ((n (#_sysconf #$_SC_NPROCESSORS_ONLN)))
1926               (declare (fixnum n))
1927               (if (> n 0) n))
[10053]1928             #+linux-target
[2363]1929             (ignore-errors
1930               (with-open-file (p "/proc/cpuinfo")
1931                 (let* ((ncpu 0)
1932                        (match "processor")
1933                        (matchlen (length match)))
1934                   (do* ((line (read-line p nil nil) (read-line p nil nil)))
1935                        ((null line) ncpu)
1936                     (let* ((line-length (length line)))
1937                       (when (and
1938                              (> line-length matchlen)
[2364]1939                              (string= match line
[2363]1940                                       :end2 matchlen)
1941                              (whitespacep (schar line matchlen)))
1942                         (incf ncpu)))))))
[4828]1943             1)
1944            #+freebsd-target
[6496]1945            (rlet ((ret :uint))
1946              (%stack-block ((mib (* (record-length :uint) 2)))
1947              (setf (paref mib (:array :uint) 0)
[4828]1948                    #$CTL_HW
[6496]1949                    (paref mib (:array :uint) 1)
[4828]1950                    #$HW_NCPU)
1951              (rlet ((oldsize :uint (record-length :uint)))
1952                (if (eql 0 (#_sysctl mib 2 ret oldsize (%null-ptr) 0))
1953                  (pref ret :uint)
[6496]1954                  1))))
[10637]1955            #+windows-target
[10897]1956            (rlet ((procmask #>DWORD_PTR)
1957                   (sysmask #>DWORD_PTR))
1958              (if (eql 0 (#_GetProcessAffinityMask (#_GetCurrentProcess) procmask sysmask))
1959                1
1960                (logcount (pref sysmask #>DWORD_PTR)))))))
[5984]1961
1962(def-load-pointers spin-count ()
1963  (if (eql 1 (cpu-count))
[6496]1964    (%defglobal '*spin-lock-tries* 1)
[7624]1965    (%defglobal '*spin-lock-tries* 1024))
1966  (%defglobal '*spin-lock-timeouts* 0))
[5984]1967
1968(defun yield ()
[11744]1969  (process-allow-schedule))
[6496]1970
[10637]1971(defloadvar *host-page-size*
1972    #-windows-target (#_getpagesize)
1973    #+windows-target
1974    (rlet ((info #>SYSTEM_INFO))
1975      (#_GetSystemInfo info)
1976      (pref info #>SYSTEM_INFO.dwPageSize))
1977    )
[6496]1978
1979;;(assert (= (logcount *host-page-size*) 1))
1980
[10822]1981(defun get-universal-time ()
1982  "Return a single integer for the current time of
1983   day in universal time format."
1984  (rlet ((tv :timeval))
1985    (gettimeofday tv)
1986    (+ (pref tv :timeval.tv_sec) unix-to-universal-time)))
1987
[10637]1988#-windows-target
1989(progn
[6496]1990(defun map-file-to-ivector (pathname element-type)
1991  (let* ((upgraded-type (upgraded-array-element-type element-type))
1992         (upgraded-ctype (specifier-type upgraded-type)))
1993    (unless (and (typep upgraded-ctype 'numeric-ctype)
1994                 (eq 'integer (numeric-ctype-class upgraded-ctype)))
1995      (error "Invalid element-type: ~s" element-type))
1996    (let* ((bits-per-element (integer-length (- (numeric-ctype-high upgraded-ctype)
1997                                                (numeric-ctype-low upgraded-ctype))))
1998           (fd (fd-open (native-translated-namestring pathname) #$O_RDONLY)))
1999      (if (< fd 0)
2000        (signal-file-error fd pathname)
2001        (let* ((len (fd-size fd)))
2002          (if (< len 0)
2003            (signal-file-error fd pathname)
2004            (let* ((nbytes (+ *host-page-size*
2005                              (logandc2 (+ len
2006                                           (1- *host-page-size*))
2007                                        (1- *host-page-size*))))
2008
2009                   (ndata-elements
2010                    (ash len
2011                         (ecase bits-per-element
2012                           (1 3)
2013                           (8 0)
2014                           (16 -1)
2015                           (32 -2)
2016                           (64 -3))))
2017                   (nalignment-elements
2018                    (ash target::nbits-in-word
2019                         (ecase bits-per-element
2020                           (1 0)
2021                           (8 -3)
2022                           (16 -4)
2023                           (32 -5)
2024                           (64 -6)))))
2025              (if (>= (+ ndata-elements nalignment-elements)
2026                      array-total-size-limit)
2027                (progn
2028                  (fd-close fd)
2029                  (error "Can't make a vector with ~s elements in this implementation." (+ ndata-elements nalignment-elements)))
[8398]2030                (let* ((addr (#_mmap (%null-ptr)
[6496]2031                                     nbytes
2032                                     #$PROT_NONE
2033                                     (logior #$MAP_ANON #$MAP_PRIVATE)
2034                                     -1
2035                                     0)))             
2036                  (if (eql addr (%int-to-ptr (1- (ash 1 target::nbits-in-word)))) ; #$MAP_FAILED
2037                    (let* ((errno (%get-errno)))
2038                      (fd-close fd)
2039                      (error "Can't map ~d bytes: ~a" nbytes (%strerror errno)))
2040              ;;; Remap the first page so that we can put a vector header
2041              ;;; there; use the first word on the first page to remember
2042              ;;; the file descriptor.
2043                    (progn
2044                      (#_mmap addr
2045                              *host-page-size*
2046                              (logior #$PROT_READ #$PROT_WRITE)
2047                              (logior #$MAP_ANON #$MAP_PRIVATE #$MAP_FIXED)
2048                              -1
2049                              0)
2050                      (setf (pref addr :int) fd)
2051                      (let* ((header-addr (%inc-ptr addr (- *host-page-size*
2052                                                            (* 2 target::node-size)))))
2053                        (setf (pref header-addr :unsigned-long)
2054                              (logior (element-type-subtype upgraded-type)
2055                                      (ash (+ ndata-elements nalignment-elements) target::num-subtag-bits)))
2056                        (when (> len 0)
2057                          (let* ((target-addr (%inc-ptr header-addr (* 2 target::node-size))))
2058                            (unless (eql target-addr
2059                                         (#_mmap target-addr
2060                                                 len
2061                                                 #$PROT_READ
2062                                                 (logior #$MAP_PRIVATE #$MAP_FIXED)
2063                                                 fd
2064                                                 0))
2065                              (let* ((errno (%get-errno)))
2066                                (fd-close fd)
2067                                (#_munmap addr nbytes)
2068                                (error "Mapping failed: ~a" (%strerror errno))))))
2069                        (with-macptrs ((v (%inc-ptr header-addr target::fulltag-misc)))
2070                          (let* ((vector (rlet ((p :address v)) (%get-object p 0))))
2071                            ;; Tell some parts of OpenMCL - notably the
2072                            ;; printer - that this thing off in foreign
2073                            ;; memory is a real lisp object and not
2074                            ;; "bogus".
2075                            (with-lock-grabbed (*heap-ivector-lock*)
2076                              (push vector *heap-ivectors*))
2077                            (make-array ndata-elements
2078                                        :element-type upgraded-type
2079                                        :displaced-to vector
2080                                        :adjustable t
2081                                        :displaced-index-offset nalignment-elements)))))))))))))))
2082
2083(defun map-file-to-octet-vector (pathname)
2084  (map-file-to-ivector pathname '(unsigned-byte 8)))
2085
2086(defun mapped-vector-data-address-and-size (displaced-vector)
2087  (let* ((v (array-displacement displaced-vector))
2088         (element-type (array-element-type displaced-vector)))
2089    (if (or (eq v displaced-vector)
2090            (not (with-lock-grabbed (*heap-ivector-lock*)
2091                   (member v *heap-ivectors*))))
2092      (error "~s doesn't seem to have been allocated via ~s and not yet unmapped" displaced-vector 'map-file-to-ivector))
2093    (let* ((pv (rlet ((x :address)) (%set-object x 0 v) (pref x :address)))
2094           (ctype (specifier-type element-type))
2095           (arch (backend-target-arch *target-backend*)))
2096      (values (%inc-ptr pv (- (* 2 target::node-size) target::fulltag-misc))
2097              (- (funcall (arch::target-array-data-size-function arch)
2098                          (ctype-subtype ctype)
2099                          (length v))
2100                 target::node-size)))))
2101
2102 
2103;;; Argument should be something returned by MAP-FILE-TO-IVECTOR;
2104;;; this should be called at most once for any such object.
2105(defun unmap-ivector (displaced-vector)
2106  (multiple-value-bind (data-address size-in-octets)
2107      (mapped-vector-data-address-and-size displaced-vector)
2108  (let* ((v (array-displacement displaced-vector))
2109         (base-address (%inc-ptr data-address (- *host-page-size*)))
2110         (fd (pref base-address :int)))
2111      (let* ((element-type (array-element-type displaced-vector)))
2112        (adjust-array displaced-vector 0
2113                      :element-type element-type
2114                      :displaced-to (make-array 0 :element-type element-type)
2115                      :displaced-index-offset 0))
2116      (with-lock-grabbed (*heap-ivector-lock*)
2117        (setq *heap-ivectors* (delete v *heap-ivectors*)))
2118      (#_munmap base-address (+ size-in-octets *host-page-size*))     
2119      (fd-close fd)
2120      t)))
2121
2122(defun unmap-octet-vector (v)
2123  (unmap-ivector v))
2124
2125(defun lock-mapped-vector (v)
2126  (multiple-value-bind (address nbytes)
2127      (mapped-vector-data-address-and-size v)
2128    (eql 0 (#_mlock address nbytes))))
2129
2130(defun unlock-mapped-vector (v)
2131  (multiple-value-bind (address nbytes)
2132      (mapped-vector-data-address-and-size v)
2133    (eql 0 (#_munlock address nbytes))))
2134
2135(defun bitmap-for-mapped-range (address nbytes)
2136  (let* ((npages (ceiling nbytes *host-page-size*)))
2137    (%stack-block ((vec npages))
2138      (when (eql 0 (#_mincore address nbytes vec))
2139        (let* ((bits (make-array npages :element-type 'bit)))
2140          (dotimes (i npages bits)
2141            (setf (sbit bits i)
2142                  (logand 1 (%get-unsigned-byte vec i)))))))))
2143
2144(defun percentage-of-resident-pages (address nbytes)
2145  (let* ((npages (ceiling nbytes *host-page-size*)))
2146    (%stack-block ((vec npages))
2147      (when (eql 0 (#_mincore address nbytes vec))
2148        (let* ((nresident 0))
2149          (dotimes (i npages (* 100.0 (/ nresident npages)))
2150            (when (logbitp 0 (%get-unsigned-byte vec i))
2151              (incf nresident))))))))
2152
2153(defun mapped-vector-resident-pages (v)
2154  (multiple-value-bind (address nbytes)
2155      (mapped-vector-data-address-and-size v)
2156    (bitmap-for-mapped-range address nbytes)))
2157
2158(defun mapped-vector-resident-pages-percentage (v)
2159  (multiple-value-bind (address nbytes)
2160      (mapped-vector-data-address-and-size v)
2161    (percentage-of-resident-pages address nbytes)))
[10637]2162)
2163
2164#+windows-target
2165(defun cygpath (winpath)
2166  "Try to use the Cygwin \"cygpath\" program to map a Windows-style
2167   pathname to a POSIX-stype Cygwin pathname."
2168  (let* ((posix-path winpath))
2169    (with-output-to-string (s)
2170      (multiple-value-bind (status exit-code)
2171          (external-process-status
2172           (run-program "cygpath" (list "-u" winpath) :output s))
2173        (when (and (eq status :exited)
2174                   (eql exit-code 0))
2175          (with-input-from-string (output (get-output-stream-string s))
2176            (setq posix-path (read-line output nil nil))))))
2177    posix-path))
2178
2179#-windows-target (defun cygpath (path) path)
2180     
2181
2182
2183
[7420]2184#+x86-target
2185(progn
2186(defloadvar *last-rdtsc-time* 0)
2187
2188(defstatic *rdtsc-estimated-increment* 1 "Should be positive ...")
2189
2190(defun rdtsc-monotonic ()
2191  "Return monotonically increasing values, partly compensating for
2192   OSes that don't keep the TSCs of all processorsin synch."
2193  (loop
2194    (let* ((old *last-rdtsc-time*)
2195           (new (rdtsc)))
2196      (when (< new old)
2197        ;; We're running on a CPU whose TSC is behind the one
2198        ;; on the last CPU we were scheduled on.
2199        (setq new (+ old *rdtsc-estimated-increment*)))
2200      (when (%store-node-conditional target::symbol.vcell *last-rdtsc-time* old new)
2201        (return new)))))
2202
2203(defun estimate-rdtsc-skew (&optional (niter 1000000))
2204  (do* ((i 0 (1+ i))
2205        (last (rdtsc) next)
2206        (next (rdtsc) (rdtsc))
2207        (skew 1))
2208       ((>= i niter) (setq *rdtsc-estimated-increment* skew))
2209    (declare (fixnum last next skew))
2210    (when (> last next)
2211      (let* ((s (- last next)))
2212        (declare (fixnum s))
2213        (when (> s skew) (setq skew s))))))
2214)
2215
2216
Note: See TracBrowser for help on using the repository browser.