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

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

Some changes in support of Slime:

Implement CCL:COMPUTE-APPLICABLE-METHODS-USING-CLASSES

Add a :stream-args argument to CCL:ACCEPT-CONNECTION, for one-time initargs for the stream being created. E.g. (accept-connection listener :stream-args `(:external-format ,external-format-for-this-connection-only))

Add CCL:TEMP-PATHNAME

Bind new var CCL:*TOP-ERROR-FRAME* to the error frame in break loops, to make it available to debugger/break hooks.

Add CCL:*SELECT-INTERACTIVE-PROCESS-HOOK* and call it to select the process to use for handling SIGINT.

Add CCL:*MERGE-COMPILER-WARNINGS* to control whether warnings with the same format string and args but different source locations should be merged.

Export CCL:COMPILER-WARNING, CCL:STYLE-WARNING, CCL:COMPILER-WARNING-FUNCTION-NAME and CCL:COMPILER-WARNING-SOURCE-NOTE.

Create a CCL:COMPILER-WARNING-SOURCE-NOTE even if not otherwise saving source locations, just using the fasl file and toplevel stream position, but taking into account compile-file-original-truename and compiler-file-original-buffer-offset. Get rid of stream-position and file-name slots in compiler warnings.

Export CCL:REPORT-COMPILER-WARNING, and make it accept a :SHORT keyword arg to skip the textual representation of the warning location.

Export CCL:NAME-OF, and make it return the fully qualified name for methods, return object for eql-specializer

Make CCL:FIND-DEFINITION-SOURCES handle xref-entries.

Export CCL:SETF-FUNCTION-SPEC-NAME, make it explicitly ignore the long-form setf method case.

Export the basic inspector API from the inspector package.

Export EQL-SPECIALIZER and SLOT-DEFINITION-DOCUMENTATION from OPENMCL-MOP

Refactor things a bit in backtrace code, define and export an API for examining backtraces:

CCL:MAP-CALL-FRAMES
CCL:FRAME-FUNCTION
CCL:FRAME-SUPPLIED-ARGUMENTS
CCL:FRAME-NAMED-VARIABLES

other misc new exports:

CCL:DEFINITION-TYPE
CCL;CALLER-FUNCTIONS
CCL:SLOT-DEFINITION-DOCUMENTATION
CCL:*SAVE-ARGLIST-INFO*
CCL:NATIVE-TRANSLATED-NAMESTRING
CCL:NATIVE-TO-PATHNAME
CCL:HASH-TABLE-WEAK-P
CCL;PROCESS-SERIAL-NUMBER
CCL:PROCESS-EXHAUSTED-P
CCL:APPLY-IN-FRAME

Other misc tweaks:

Make cbreak-loop use the break message when given a uselessly empty condition.

Use setf-function-name-p more consistently

Make find-applicable-methods handle eql specializers better.

Try to more consistently recognize lists of the form (:method ...) as method names.

Add xref-entry-full-name (which wasn't needed in the end)

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