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

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

Windows version of RUN-PROGRAM and related functions:
RUN-PROGRAM allows its "args" argument to be a SIMPLE-STRING (as well
as a list of SIMPLE-STRINGs).

Use MAKE-WINDOWS-COMMAND-LINE (not just JOIN-STRINGS) to build the
command-line for CreateProcess? from a cons of the RUN-PROGRAM "program
name" and "args" arguments. A literal string "args" argument is passed
verbatim to the command line; the program name and any arguments in a
list-typed "args" arguments are processd by surrounding space/tab with
double-quotes and prefixing literal double-quote characters with backslash;
all other characters are passed verbatim to the command line and arguments
are separated by spaces.

This seems to be at least a first approximation of the rules used by
the MSVC runtime, though I haven't seen those rules written down
anywhere. (The program name is processed by the OS and any quoting of
it has to be done in a canonical way.)

This may fix ticket:858. How would anyone know ?

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