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

Last change on this file since 13067 was 13067, checked in by rme, 10 years ago

Update copyright notices.

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