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

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

As suggested by Scott Burson: WAIT-ON-SIGNAL accepts a null DURATION
(which means "wait as long as we can express", which seems to be
"many years".)

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