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

Last change on this file since 14376 was 14351, checked in by rme, 9 years ago

Remove conditionalizations on ccl-qres.

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