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

Last change on this file since 14461 was 14461, checked in by gb, 9 years ago

Ensure that any streams created to read external-process output
are interactive.
Fixes ticket:786.

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