source: branches/working-0711/ccl/level-1/linux-files.lisp @ 12944

Last change on this file since 12944 was 12415, checked in by gz, 10 years ago

Add CCL:TEMP-PATHNAME

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