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

Last change on this file since 16800 was 16800, checked in by svspire, 3 years ago

Return yet another value from #'%stat-values: st_flags, so we
can examine e.g. UF_HIDDEN etc.

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