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

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

In CPU-COUNT on Linux/Solaris?: use #$_SC_NPROCESSORS_CONF. (This
seems to return the actual number of available procesessors, including
any that may be temporarily offline for power-management or similar
reasons.)

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