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

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

Lisp side of WAIT-FOR-SIGNAL.

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