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

Last change on this file since 13675 was 13675, checked in by gz, 9 years ago

Rename feature ccl-0711 to ccl-qres

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