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

Last change on this file since 15083 was 15083, checked in by gb, 7 years ago

%%STAT-VALUES returns stat.st_dev. (I haven't checked to see
if it's called by any other name on non-Linux systems.)

DIRECTORY treats links to directories as directories when :FOLLOW-LINKS
is T (as it is by default.) The :DIRECTORIES argument now defaults to T.
AFAICT, fixes ticket:891.

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