Ignore:
Timestamp:
Oct 14, 2008, 6:30:00 PM (13 years ago)
Author:
gz
Message:

Merge/bootstrap assorted low level stuff from trunk - kernel, syscall stuff, lowmem-bias, formatting tweaks, a few bug fixes included

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/level-1/linux-files.lisp

    r10538 r11089  
    1717(in-package "CCL")
    1818
    19 (eval-when (:compile-toplevel :execute)
    20   #+linuxppc-target
    21   (require "PPC-LINUX-SYSCALLS")
    22   #+linuxx8664-target
    23   (require "X8664-LINUX-SYSCALLS")
    24   #+darwinppc-target
    25   (require "DARWINPPC-SYSCALLS")
    26   #+darwinx8664-target
    27   (require "DARWINX8664-SYSCALLS")
    28   #+(and freebsd-target x8664-target)
    29   (require "X8664-FREEBSD-SYSCALLS")
    30   )
    31 
     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)
    3240
    3341(defun get-foreign-namestring (pointer)
     
    3846  #+darwin-target
    3947  (precompose-simple-string (%get-utf-8-cstring pointer))
     48  #+windows-target (nbackslash-to-forward-slash
     49                     (%get-native-utf-16-cstring pointer))
    4050  ;; On some other platforms, the namestring is assumed to
    4151  ;; be encoded according to the current locale's character
    4252  ;; encoding (though FreeBSD seems to be moving towards
    4353  ;; precomposed UTF-8.).
    44   ;; In any case, the use if %GET-CSTRING here is wrong ...
    45   #-darwin-target
     54  ;; In any case, the use of %GET-CSTRING here is wrong ...
     55  #-(or darwin-target windows-target)
    4656  (%get-cstring pointer))
    4757
     
    157167  (%signal-semaphore-ptr (semaphore-value s)))
    158168
    159 (defun %os-getcwd (buf bufsize)
     169(defun %os-getcwd (buf noctets)
    160170  ;; Return N < 0, if error
    161   ;;        N < bufsize: success, string is of length n
    162   ;;        N > bufsize: buffer needs to be larger.
    163   (let* ((p (#_getcwd buf bufsize)))
     171  ;;        N < noctets: success, string is of length N (octets).
     172  ;;        N >= noctets: buffer needs to be larger.
     173  (let* ((p #+windows-target
     174           (#__wgetcwd buf (ash noctets -1))
     175           #-windows-target
     176           (#_getcwd buf noctets)))
    164177    (declare (dynamic-extent p))
    165178    (if (%null-ptr-p p)
    166179      (let* ((err (%get-errno)))
    167180        (if (eql err (- #$ERANGE))
    168           (+ bufsize bufsize)
     181          (+ noctets noctets)
    169182          err))
    170       (dotimes (i bufsize (+ bufsize bufsize))
     183      #+windows-target
     184      (do* ((i 0 (+ i 2)))
     185           ((= i noctets) (+ noctets noctets))
     186        (when (eql (%get-unsigned-word buf i) 0)
     187          (return i)))
     188      #-windows-target
     189      (dotimes (i noctets (+ noctets noctets))
    171190        (when (eql 0 (%get-byte buf i))
    172191          (return i))))))
     
    185204                     (t (values nil len)))))))
    186205    (do* ((string nil)
    187           (len 64)
     206          (len #+windows-target 128 #-windows-target 64)
    188207          (bufsize len len))
    189208         ((multiple-value-setq (string len) (try-getting-dirname bufsize))
     
    201220  (cwd path))
    202221
     222
     223
     224
    203225(defun %chdir (dirname)
    204   (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((dirname dirname))
    205     (syscall syscalls::chdir dirname)))
     226  (with-filename-cstrs ((dirname dirname))
     227    (int-errno-call (#+windows-target #__wchdir #-windows-target #_chdir dirname))))
    206228
    207229(defun %mkdir (name mode)
     230  #+windows-target (declare (ignore mode))
    208231  (let* ((name name)
    209232         (len (length name)))
    210233    (when (and (> len 0) (eql (char name (1- len)) #\/))
    211234      (setq name (subseq name 0 (1- len))))
    212     (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((name name))
    213       (syscall syscalls::mkdir name mode))))
     235    (with-filename-cstrs ((name name))
     236      (int-errno-call (#+windows-target #__wmkdir #-windows-target #_mkdir  name #-windows-target mode)))))
    214237
    215238(defun %rmdir (name)
    216239  (let* ((last (1- (length name))))
    217     (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((name name))
     240    (with-filename-cstrs ((name name))
    218241      (when (and (>= last 0)
    219242                 (eql (%get-byte name last) (char-code #\/)))
    220243        (setf (%get-byte name last) 0))
    221     (syscall syscalls::rmdir name))))
     244      (int-errno-call (#+windows-target #__wrmdir #-windows-target #_rmdir  name)))))
    222245
    223246
     
    236259  "Set the value of the environment variable named by name, in the OS
    237260environment. If there is no such environment variable, create it."
     261  #+windows-target (declare (ignore overwrite))
     262  #-windows-target
    238263  (with-cstrs ((ckey key)
    239264               (cvalue value))
    240     (#_setenv ckey cvalue (if overwrite 1 0))))
    241 
     265    (#_setenv ckey cvalue (if overwrite 1 0)))
     266  #+windows-target
     267  (with-cstrs ((pair (format nil "~a=~a" key value)))
     268    (#__putenv pair))
     269  )
     270
     271#-windows-target                        ; Windows "impersonation" crap ?
    242272(defun setuid (uid)
    243273  "Attempt to change the current user ID (both real and effective);
    244274fails unless the OpenMCL process has super-user privileges or the ID
    245275given is that of the current user."
    246   (syscall syscalls::setuid uid))
    247 
     276  (int-errno-call (#_setuid uid)))
     277
     278#-windows-target
    248279(defun setgid (uid)
    249280  "Attempt to change the current group ID (both real and effective);
    250281fails unless the OpenMCL process has super-user privileges or the ID
    251282given is that of a group to which the current user belongs."
    252   (syscall syscalls::setgid uid))
     283  (int-errno-call (#_setgid uid)))
    253284 
    254285
     
    257288;;; they're talking about.
    258289
     290#-windows-target
    259291(defun %stat-values (result stat)
    260292  (if (eql 0 (the fixnum result))
     
    263295       (pref stat :stat.st_mode)
    264296       (pref stat :stat.st_size)
    265        #+linux-target
     297       #+(or linux-target solaris-target)
    266298       (pref stat :stat.st_mtim.tv_sec)
    267        #-linux-target
     299       #-(or linux-target solaris-target)
    268300       (pref stat :stat.st_mtimespec.tv_sec)
    269301       (pref stat :stat.st_ino)
    270302       (pref stat :stat.st_uid)
    271        (pref stat :stat.st_blksize))
     303       (pref stat :stat.st_blksize)
     304       #+(or linux-target solaris-target)
     305       (round (pref stat :stat.st_mtim.tv_nsec) 1000)
     306       #-(or linux-target solaris-target)
     307       (round (pref stat :stat.st_mtimespec.tv_nsec) 1000)
     308       (pref stat :stat.st_gid))
    272309      (values nil nil nil nil nil nil nil)))
    273310
     311#+win64-target
     312(defun %stat-values (result stat)
     313  (if (eql 0 (the fixnum result))
     314      (values
     315       t
     316       (pref stat :_stat64.st_mode)
     317       (pref stat :_stat64.st_size)
     318       (pref stat :_stat64.st_mtime)
     319       (pref stat :_stat64.st_ino)
     320       (pref stat :_stat64.st_uid)
     321       #$BUFSIZ
     322       (pref stat :_stat64.st_mtime)     ; ???
     323       (pref stat :_stat64.st_gid))
     324      (values nil nil nil nil nil nil nil nil nil)))
     325
     326#+win32-target
     327(defun %stat-values (result stat)
     328  (if (eql 0 (the fixnum result))
     329      (values
     330       t
     331       (pref stat :__stat64.st_mode)
     332       (pref stat :__stat64.st_size)
     333       (pref stat :__stat64.st_mtime)
     334       (pref stat :__stat64.st_ino)
     335       (pref stat :__stat64.st_uid)
     336       #$BUFSIZ
     337       (pref stat :__stat64.st_mtime)     ; ???
     338       (pref stat :__stat64.st_gid))
     339      (values nil nil nil nil nil nil nil nil nil)))
     340
     341#+windows-target
     342(defun windows-strip-trailing-slash (namestring)
     343  (do* ((len (length namestring) (length namestring)))
     344       ((<= len 3) namestring)
     345    (let* ((p (1- len))
     346           (ch (char namestring p)))
     347      (unless (or (eql ch #\\)
     348                  (eql ch #\/))
     349        (return namestring))
     350      (setq namestring (subseq namestring 0 p)))))
     351
    274352
    275353(defun %%stat (name stat)
    276   (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((cname name))
     354  (with-filename-cstrs ((cname #+windows-target (windows-strip-trailing-slash name) #-windows-target name))
    277355    (%stat-values
    278356     #+linux-target
    279357     (#_ __xstat #$_STAT_VER_LINUX cname stat)
    280358     #-linux-target
    281      (syscall syscalls::stat cname stat)
     359     (int-errno-ffcall (%kernel-import target::kernel-import-lisp-stat)
     360                       :address cname
     361                       :address stat
     362                       :int)
    282363     stat)))
    283364
     
    287368   (#_ __fxstat #$_STAT_VER_LINUX fd stat)
    288369   #-linux-target
    289    (syscall syscalls::fstat fd stat)
     370   (int-errno-ffcall (%kernel-import target::kernel-import-lisp-fstat)
     371                     :int fd
     372                     :address stat
     373                     :int)
    290374   stat))
    291375
     376#-windows-target
    292377(defun %%lstat (name stat)
    293   (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((cname name))
     378  (with-filename-cstrs ((cname name))
    294379    (%stat-values
    295380     #+linux-target
    296381     (#_ __lxstat #$_STAT_VER_LINUX cname stat)
    297382     #-linux-target
    298      (syscall syscalls::lstat cname stat)
     383     (#_lstat cname stat)
    299384     stat)))
    300385
     
    304389;;; NAME should be a "native namestring", e.g,, have all lisp pathname
    305390;;; escaping removed.
     391#-windows-target
    306392(defun %stat (name &optional link-p)
    307393  (rlet ((stat :stat))
     
    310396      (%%stat name stat))))
    311397
     398#+windows-target
     399(defun %stat (name &optional link-p)
     400  (declare (ignore link-p))
     401  (rlet ((stat  #+win64-target #>_stat64 #+win32-target #>__stat64))
     402    (%%stat name stat)))
     403
    312404(defun %fstat (fd)
    313   (rlet ((stat :stat))
     405  (rlet ((stat #+win64-target #>_stat64 #+win32-target #>__stat64 #-windows-target :stat))
    314406    (%%fstat fd stat)))
    315407
    316408
    317 (defun %file-kind (mode)
     409(defun %file-kind (mode &optional fd)
     410  (declare (ignorable fd))
    318411  (when mode
    319412    (let* ((kind (logand mode #$S_IFMT)))
    320413      (cond ((eql kind #$S_IFDIR) :directory)
    321414            ((eql kind #$S_IFREG) :file)
     415            #-windows-target
    322416            ((eql kind #$S_IFLNK) :link)
    323             ((eql kind #$S_IFIFO) :pipe)
     417            ((eql kind #$S_IFIFO)
     418             #-windows-target :pipe
     419             ;; Windows doesn't seem to be able to distinguish between
     420             ;; sockets and pipes.  Since this function is currently
     421             ;; (mostly) used for printing streams and since we've
     422             ;; already done something fairly expensive (stat, fstat)
     423             ;; to get here.  try to distinguish between pipes and
     424             ;; sockets by calling #_getsockopt.  If that succeeds,
     425             ;; we've got a socket; otherwise, we're probably got a pipe.
     426             #+windows-target (rlet ((ptype :int)
     427                                     (plen :int 4))
     428                                (if (and fd (eql 0 (#_getsockopt fd #$SOL_SOCKET #$SO_TYPE  ptype plen)))
     429                                    :socket
     430                                    :pipe)))
     431            #-windows-target
    324432            ((eql kind #$S_IFSOCK) :socket)
    325433            ((eql kind #$S_IFCHR) :character-special)
     
    332440  (if (isatty fd)
    333441    :tty
    334     (%file-kind (nth-value 1 (%fstat fd)))))
    335 
     442    (%file-kind (nth-value 1 (%fstat fd)) fd)))
     443
     444#-windows-target
    336445(defun %uts-string (result idx buf)
    337   (if (eql 0 result)
     446  (if (>= result 0)
    338447    (%get-cstring (%inc-ptr buf (* #+linux-target #$_UTSNAME_LENGTH
    339448                                   #+darwin-target #$_SYS_NAMELEN
    340                                    #+freebsd-target #$SYS_NMLN idx)))
     449                                   #+(or freebsd-target solaris-target) #$SYS_NMLN
     450                                   idx)))
    341451    "unknown"))
     452
     453#-windows-target
     454(defun copy-file-attributes (source-path dest-path)
     455  "Copy the mode, owner, group and modification time of source-path to dest-path.
     456   Returns T if succeeded, NIL if some of the attributes couldn't be copied due to
     457   permission problems.  Any other failures cause an error to be signalled"
     458  (multiple-value-bind (win mode ignore mtime-sec ignore uid ignore mtime-usec gid)
     459                       (%stat (native-translated-namestring source-path) t)
     460    (declare (ignore ignore))
     461    (unless win
     462      (error "Cannot get attributes of ~s" source-path))
     463    (with-filename-cstrs ((cnamestr (native-translated-namestring dest-path)))
     464      (macrolet ((errchk (form)
     465                   `(let ((err ,form))
     466                      (unless (eql err 0)
     467                        (setq win nil)
     468                        (when (eql err -1)
     469                          (setq err (- (%get-errno))))
     470                        (unless (eql err #$EPERM) (%errno-disp err dest-path))))))
     471        (errchk (#_chmod cnamestr mode))
     472        (errchk (%stack-block ((times (record-length (:array (:struct :timeval) 2))))
     473                  (setf (pref times :timeval.tv_sec) mtime-sec)
     474                  (setf (pref times :timeval.tv_usec) mtime-usec)
     475                  (%incf-ptr times (record-length :timeval))
     476                  (setf (pref times :timeval.tv_sec) mtime-sec)
     477                  (setf (pref times :timeval.tv_usec) mtime-usec)
     478                  (%incf-ptr times (- (record-length :timeval)))
     479                  (#_utimes cnamestr times)))
     480        (errchk (#_chown cnamestr uid gid))))
     481    win))
     482
     483#+windows-target
     484(defun copy-file-attributes (source-path dest-path)
     485  "could at least copy the file times"
     486  (declare (ignore source-path dest-path)))
    342487
    343488
     
    345490(defun %uname (idx)
    346491  (%stack-block ((buf (* #$_UTSNAME_LENGTH 6))) 
    347     (%uts-string (syscall syscalls::uname buf) idx buf)))
     492    (%uts-string (#_uname buf) idx buf)))
    348493
    349494#+darwin-target
     
    357502    (%uts-string (#___xuname #$SYS_NMLN buf) idx buf)))
    358503
     504#+solaris-target
     505(defun %uname (idx)
     506  (%stack-block ((buf (* #$SYS_NMLN 5)))
     507    (%uts-string (#_uname buf) idx buf)))
     508
     509#-windows-target
    359510(defun fd-dup (fd)
    360   (syscall syscalls::dup fd))
     511  (int-errno-call (#_dup fd)))
     512
     513#+windows-target
     514(defun fd-dup (fd &key direction inheritable)
     515  (declare (ignore direction))
     516  (rlet ((handle #>HANDLE))
     517    (#_DuplicateHandle (#_GetCurrentProcess)
     518                       fd
     519                       (#_GetCurrentProcess)
     520                       handle
     521                       0
     522                       (if inheritable #$TRUE #$FALSE)
     523                       #$DUPLICATE_SAME_ACCESS)))
     524
    361525
    362526(defun fd-fsync (fd)
    363   (syscall syscalls::fsync fd))
    364 
     527  #+windows-target (#_FlushFileBuffers fd)
     528  #-windows-target
     529  (int-errno-call (#_fsync fd)))
     530
     531#-windows-target
     532(progn
    365533(defun fd-get-flags (fd)
    366   (syscall syscalls::fcntl fd #$F_GETFL))
     534  (int-errno-call (#_fcntl fd #$F_GETFL)))
    367535
    368536(defun fd-set-flags (fd new)
    369   (syscall syscalls::fcntl fd #$F_SETFL new))
     537  (int-errno-call (#_fcntl fd #$F_SETFL :int new)))
    370538
    371539(defun fd-set-flag (fd mask)
     
    380548      old
    381549      (fd-set-flags fd (logandc2 old mask)))))
    382 
     550)
    383551
    384552;;; Assume that any quoting's been removed already.
     
    391559              (eql (schar namestring 1) #\/))
    392560        (concatenate 'string (get-user-home-dir (getuid)) (if (= len 1) "/" (subseq namestring 1)))
     561        #+windows-target namestring
     562        #-windows-target
    393563        (let* ((slash-pos (position #\/ namestring))
    394564               (user-name (subseq namestring 1 slash-pos))
     
    397567          (concatenate 'string (get-user-home-dir uid) (if slash-pos (subseq namestring slash-pos) "/")))))))
    398568
    399                      
     569
     570#+windows-target
     571(defun %windows-realpath (namestring)
     572  (with-filename-cstrs ((path namestring))
     573    (do* ((bufsize 256))
     574         ()
     575      (%stack-block ((buf bufsize))
     576        (let* ((nchars (#_GetFullPathNameW path (ash bufsize -1) buf (%null-ptr))))
     577          (if (eql 0 nchars)
     578            (return nil)
     579            (let* ((max (+ nchars nchars 2)))
     580              (if (> max bufsize)
     581                (setq bufsize max)
     582                (let* ((real (get-foreign-namestring buf)))
     583                  (return (and (%stat real) real)))))))))))
     584
    400585   
    401586;;; This doesn't seem to exist on VxWorks.  It's a POSIX
     
    403588
    404589(defun %realpath (namestring)
     590  ;; It's not at all right to just return the namestring here.
    405591  (when (zerop (length namestring))
    406592    (setq namestring (current-directory-name)))
     593  #+windows-target (%windows-realpath namestring)
     594  #-windows-target
    407595  (%stack-block ((resultbuf #$PATH_MAX))
    408     (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((name namestring #|(tilde-expand namestring)|#))
     596    (with-filename-cstrs ((name namestring #|(tilde-expand namestring)|#))
    409597      (let* ((result (#_realpath name resultbuf)))
    410598        (declare (dynamic-extent result))
     
    421609      (values nil nil))))
    422610
     611;;; The mingw headers define timeval.tv_sec and timeval.tv_usec to be
     612;;; signed 32-bit quantities.
     613(macrolet ((timeval-ref (ptr accessor)
     614             #+windows-target `(logand #xfffffffff (pref ,ptr ,accessor))
     615             #-windows-target `(pref ,ptr ,accessor))
     616           (set-timeval-ref (ptr accessor new)
     617           `(setf (pref ,ptr ,accessor)
     618             #+windows-target (u32->s32 ,new)
     619             #-windows-target ,new)))
     620 
    423621(defun timeval->milliseconds (tv)
    424     (+ (* 1000 (pref tv :timeval.tv_sec)) (round (pref tv :timeval.tv_usec) 1000)))
     622    (+ (* 1000 (timeval-ref tv :timeval.tv_sec)) (round (timeval-ref tv :timeval.tv_usec) 1000)))
    425623
    426624(defun timeval->microseconds (tv)
    427     (+ (* 1000000 (pref tv :timeval.tv_sec)) (pref tv :timeval.tv_usec)))
     625    (+ (* 1000000 (timeval-ref tv :timeval.tv_sec)) (timeval-ref tv :timeval.tv_usec)))
    428626
    429627(defun %add-timevals (result a b)
    430   (let* ((seconds (+ (pref a :timeval.tv_sec) (pref b :timeval.tv_sec)))
    431          (micros (+ (pref a :timeval.tv_usec) (pref b :timeval.tv_usec))))
     628  (let* ((seconds (+ (timeval-ref a :timeval.tv_sec) (timeval-ref b :timeval.tv_sec)))
     629         (micros (+ (timeval-ref a :timeval.tv_usec) (timeval-ref b :timeval.tv_usec))))
    432630    (if (>= micros 1000000)
    433631      (setq seconds (1+ seconds) micros (- micros 1000000)))
    434     (setf (pref result :timeval.tv_sec) seconds
    435           (pref result :timeval.tv_usec) micros)
     632    (set-timeval-ref result :timeval.tv_sec seconds)
     633    (set-timeval-ref result :timeval.tv_usec micros)
    436634    result))
    437635
    438636(defun %sub-timevals (result a b)
    439   (let* ((seconds (- (pref a :timeval.tv_sec) (pref b :timeval.tv_sec)))
    440          (micros (- (pref a :timeval.tv_usec) (pref b :timeval.tv_usec))))
     637  (let* ((seconds (- (timeval-ref a :timeval.tv_sec) (timeval-ref b :timeval.tv_sec)))
     638         (micros (- (timeval-ref a :timeval.tv_usec) (timeval-ref b :timeval.tv_usec))))
    441639    (if (< micros 0)
    442640      (setq seconds (1- seconds) micros (+ micros 1000000)))
    443     (setf (pref result :timeval.tv_sec) seconds
    444           (pref result :timeval.tv_usec) micros)
     641    (set-timeval-ref result :timeval.tv_sec  seconds)
     642    (set-timeval-ref result :timeval.tv_usec micros)
    445643    result))
    446644
    447 
     645;;; Return T iff the time denoted by the timeval a is not later than the
     646;;; time denoted by the timeval b.
     647(defun %timeval<= (a b)
     648  (let* ((asec (timeval-ref a :timeval.tv_sec))
     649         (bsec (timeval-ref b :timeval.tv_sec)))
     650    (or (< asec bsec)
     651        (and (= asec bsec)
     652             (< (timeval-ref a :timeval.tv_usec)
     653                (timeval-ref b :timeval.tv_usec))))))
     654
     655); windows signed nonsense.
     656
     657#-windows-target
    448658(defun %%rusage (usage &optional (who #$RUSAGE_SELF))
    449   (syscall syscalls::getrusage who usage))
    450 
    451 
    452 
    453 (defconstant unix-to-universal-time 2208988800)
     659  (int-errno-call (#_getrusage who usage)))
     660
     661
     662
    454663
    455664(defun %file-write-date (namestring)
     
    457666    (if date
    458667      (+ date unix-to-universal-time))))
    459 
     668 
     669#-windows-target
    460670(defun %file-author (namestring)
    461671  (let* ((uid (nth-value 5 (%stat namestring))))
     
    466676           (%get-cstring (pref pw :passwd.pw_name))))))))
    467677
     678#+windows-target
     679(defun %file-author (namestring)
     680  (declare (ignore namestring))
     681  nil)
     682
     683#-windows-target
    468684(defun %utimes (namestring)
    469   (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((cnamestring namestring))
     685  (with-filename-cstrs ((cnamestring namestring))
    470686    (let* ((err (#_utimes cnamestring (%null-ptr))))
    471687      (declare (fixnum err))
    472688      (or (eql err 0)
    473689          (%errno-disp err namestring)))))
    474          
    475 
     690
     691#+windows-target
     692(defun %utimes (namestring)
     693  (with-filename-cstrs ((cnamestring namestring))
     694    (let* ((handle (#_CreateFileW
     695                    cnamestring
     696                    #$FILE_WRITE_ATTRIBUTES
     697                    (logior #$FILE_SHARE_READ #$FILE_SHARE_WRITE)
     698                    (%null-ptr)
     699                    #$OPEN_EXISTING
     700                    #$FILE_ATTRIBUTE_NORMAL
     701                    (%null-ptr))))
     702      (if (eql handle *windows-invalid-handle*)
     703        (%windows-error-disp (#_GetLastError))
     704        (rlet ((st #>SYSTEMTIME)
     705               (ft #>FILETIME))
     706          (#_GetSystemTime st)
     707          (#_SystemTimeToFileTime st ft)
     708          (let* ((result (#_SetFileTime handle (%null-ptr) (%null-ptr) ft))
     709                 (err (unless (eql 0 result) (#_GetLastError))))
     710            (#_CloseHandle handle)
     711            (if err
     712              (%windows-error-disp err)
     713              t)))))))
     714
     715
     716             
     717
     718#-windows-target
    476719(defun get-uid-from-name (name)
    477720  (with-cstrs ((name name))
     
    480723        (pref pwent :passwd.pw_uid)))))
    481724
    482    
     725
    483726(defun isatty (fd)
     727  #+windows-target (declare (ignore fd))
     728  #+windows-target nil
     729  #-windows-target
    484730  (= 1 (#_isatty fd)))
    485731
    486732(defun %open-dir (namestring)
    487   (#+darwin-target with-utf-8-cstrs #-darwin-target with-cstrs ((name namestring))
    488     (let* ((DIR (#_opendir name)))
     733  (with-filename-cstrs ((name namestring))
     734    (let* ((DIR (ff-call (%kernel-import target::kernel-import-lisp-opendir)
     735                         :address name
     736                         :address)))
    489737      (unless (%null-ptr-p DIR)
    490738        DIR))))
    491739
    492740(defun close-dir (dir)
    493   (#_closedir DIR))
     741  (ff-call (%kernel-import target::kernel-import-lisp-closedir)
     742           :address dir
     743           :int))
    494744
    495745(defun %read-dir (dir)
    496   (let* ((res (#_readdir dir)))
     746  (let* ((res (ff-call (%kernel-import target::kernel-import-lisp-readdir)
     747                       :address dir
     748                       :address)))
    497749    (unless (%null-ptr-p res)
    498       (get-foreign-namestring (pref res :dirent.d_name)))))
    499 
     750      (get-foreign-namestring (pref res
     751                                    #+windows-target :_wdirent.d_name
     752                                    #-windows-target :dirent.d_name)))))
     753
     754
     755#-windows-target
    500756(defun tcgetpgrp (fd)
    501757  (#_tcgetpgrp fd))
     
    503759(defun getpid ()
    504760  "Return the ID of the OpenMCL OS process."
    505   (syscall syscalls::getpid))
     761  #-windows-target
     762  (int-errno-call (#_getpid))
     763  #+windows-target (#_GetCurrentProcessId))
     764
    506765
    507766(defun getuid ()
    508767  "Return the (real) user ID of the current user."
    509   (syscall syscalls::getuid))
     768  #+windows-target 0
     769  #-windows-target (int-errno-call (#_getuid)))
    510770
    511771(defun get-user-home-dir (userid)
     
    513773by uid. This value comes from the OS user database, not from the $HOME
    514774environment variable. Returns NIL if there is no user with the ID uid."
     775  #+windows-target
     776  (declare (ignore userid))
     777  #+windows-target
     778  (dolist (k '(#||"HOME"||# "USERPROFILE"))
     779    (with-native-utf-16-cstrs ((key k))
     780      (let* ((p (#__wgetenv key)))
     781        (unless (%null-ptr-p p)
     782          (return (get-foreign-namestring p))))))
     783  #-windows-target
    515784  (rlet ((pwd :passwd)
    516785         (result :address pwd))
     
    518787         ()
    519788      (%stack-block ((buf buflen))
    520         (let* ((err (#_getpwuid_r userid pwd buf buflen result)))
     789        (let* ((err
     790                #-solaris-target
     791                 (#_getpwuid_r userid pwd buf buflen result)
     792                 #+solaris-target
     793                 (external-call "__posix_getpwuid_r"
     794                                :uid_t userid
     795                                :address pwd
     796                                :address buf
     797                                :int buflen
     798                                :address result
     799                                :int)))
    521800          (if (eql 0 err)
    522801            (return (let* ((rp (%get-ptr result)))
     
    528807(defun %delete-file (name)
    529808  (with-cstrs ((n name))
    530     (syscall syscalls::unlink n)))
     809    (int-errno-call (#+windows-target #__unlink #-windows-target #_unlink n))))
    531810
    532811(defun os-command (string)
     
    550829      (format nil "OS Error %d" errno)
    551830      (%get-cstring p))))
     831
     832#+windows-target
     833(defun %windows-error-string (error-number) 
     834  (rlet ((pbuffer :address (%null-ptr)))
     835    (if (eql 0
     836             (#_FormatMessageW (logior #$FORMAT_MESSAGE_ALLOCATE_BUFFER
     837                                       #$FORMAT_MESSAGE_FROM_SYSTEM
     838                                       #$FORMAT_MESSAGE_IGNORE_INSERTS
     839                                       #$FORMAT_MESSAGE_MAX_WIDTH_MASK)
     840                               (%null-ptr)
     841                               (abs error-number)
     842                               0                 ; default langid, more-or-less
     843                               pbuffer
     844                               0
     845                               (%null-ptr)))
     846      (format nil "Windows error ~d" (abs error-number))
     847      (let* ((p (%get-ptr pbuffer))
     848             (q (%get-native-utf-16-cstring p)))
     849        (#_LocalFree p)
     850        q))))
     851       
     852                     
    552853
    553854;;; Kind of has something to do with files, and doesn't work in level-0.
     
    649950  `(call-with-string-vector #'(lambda (,var) ,@body) ,@strings))
    650951
    651 (defloadvar *max-os-open-files* (#_getdtablesize))
    652 
     952(defloadvar *max-os-open-files* #-windows-target (#_getdtablesize) #+windows-target 32)
     953
     954(defun pipe ()
     955  ;;  (rlet ((filedes (:array :int 2)))
     956  (%stack-block ((filedes 8))
     957    (let* ((status (ff-call (%kernel-import target::kernel-import-lisp-pipe)
     958                            :address filedes :int))
     959           (errno (if (eql status 0) 0 (%get-errno))))
     960      (unless (zerop status)
     961        (when (or (eql errno (- #$EMFILE))
     962                  (eql errno (- #$ENFILE)))
     963          (gc)
     964          (drain-termination-queue)
     965          (setq status (ff-call (%kernel-import target::kernel-import-lisp-pipe)
     966                            :address filedes :int)
     967                errno (if (zerop status) 0 (%get-errno)))))
     968      (if (zerop status)
     969        (values (paref filedes (:array :int)  0) (paref filedes (:array :int)  1))
     970        (%errno-disp errno)))))
     971
     972#-windows-target
     973(progn
    653974(defun %execvp (argv)
    654975  (#_execvp (%get-ptr argv) argv)
     
    666987
    667988
    668 
    669 
    670 
    671 
    672 ;;; I believe that the Darwin/FreeBSD syscall infterface is rather ... odd.
    673 ;;; Use libc's interface.
    674 (defun pipe ()
    675   ;;  (rlet ((filedes (:array :int 2)))
    676   (%stack-block ((filedes 8))
    677     (let* ((status (#_pipe filedes))
    678            (errno (if (eql status 0) 0 (%get-errno))))
    679       (unless (zerop status)
    680         (when (or (eql errno (- #$EMFILE))
    681                   (eql errno (- #$ENFILE)))
    682           (gc)
    683           (drain-termination-queue)
    684           (setq status (#_pipe filedes)
    685                 errno (if (zerop status) 0 (%get-errno)))))
    686       (if (zerop status)
    687         (values (paref filedes (:array :int)  0) (paref filedes (:array :int)  1))
    688         (%errno-disp errno)))))
    689989
    690990
     
    7261026     (values nil nil close-in-parent close-on-error))
    7271027    (null
    728      (let* ((fd (fd-open "/dev/null" (case direction
     1028     (let* ((null-device #+windows-target "nul" #-windows-target "/dev/null")
     1029            (fd (fd-open null-device (case direction
    7291030                                       (:input #$O_RDONLY)
    7301031                                       (:output #$O_WRONLY)
    7311032                                       (t #$O_RDWR)))))
    7321033       (if (< fd 0)
    733          (signal-file-error fd "/dev/null"))
     1034         (signal-file-error fd null-device))
    7341035       (values fd nil (cons fd close-in-parent) (cons fd close-on-error))))
    7351036    ((eql :stream)
     
    8211122
    8221123
     1124(defmacro wtermsig (status)
     1125  `(ldb (byte 7 0) ,status))
     1126
     1127(defmacro wexitstatus (status)
     1128  `(ldb (byte 8 8) (the fixnum ,status)))
     1129
     1130(defmacro wstopsig (status)
     1131  `(wexitstatus ,status))
     1132
     1133(defmacro wifexited (status)
     1134  `(eql (wtermsig ,status) 0))
     1135
     1136(defmacro wifstopped (status)
     1137  `(eql #x7f (ldb (byte 7 0) (the fixnum ,status))))
    8231138
    8241139(defun monitor-external-process (p)
     
    8311146        (signal-semaphore (external-process-completed p))
    8321147        (return))
    833       (if in-fd
     1148      (when in-fd
    8341149        (when (fd-input-available-p in-fd 1000)
    8351150          (%stack-block ((buf 1024))
     
    8721187                               :signaled)
    8731188                             signal
    874                              (logtest #$WCOREFLAG statusflags)))))
     1189                             (logtest #-solaris-target #$WCOREFLAG
     1190                                      #+solaris-target #$WCOREFLG
     1191                                      statusflags)))))
    8751192                 (setf (external-process-%status p) status
    8761193                       (external-process-%exit-code p) code
     
    8831200                   (remove-external-process p)
    8841201                   (setq terminated t)))))))))
    885 
    886 
     1202     
    8871203(defun run-external-process (proc in-fd out-fd error-fd argv &optional env)
    8881204  (let* ((signaled nil))
     
    9901306        (with-interrupts-enabled
    9911307            (wait-on-semaphore (external-process-completed proc))))
    992       (if (eq (external-process-%status proc) :error)
    993         (if silently-ignore-catastrophic-failures
    994           proc
    995           (error 'external-process-creation-failure proc))
    996         (and (external-process-pid proc)
    997              proc))))
    998 
    999 
    1000 (defmacro wtermsig (status)
    1001   `(ldb (byte 7 0) ,status))
    1002 
    1003 (defmacro wexitstatus (status)
    1004   `(ldb (byte 8 8) (the fixnum ,status)))
    1005 
    1006 (defmacro wstopsig (status)
    1007   `(wexitstatus ,status))
    1008 
    1009 (defmacro wifexited (status)
    1010   `(eql (wtermsig ,status) 0))
    1011 
    1012 (defmacro wifstopped (status)
    1013   `(eql #x7f (ldb (byte 7 0) (the fixnum ,status))))
     1308    (if (eq (external-process-%status proc) :error)
     1309      (if silently-ignore-catastrophic-failures
     1310        proc
     1311        (error 'external-process-creation-failure proc))
     1312      (and (external-process-pid proc) proc))))
     1313
     1314
     1315
    10141316
    10151317(defmacro wifsignaled (status)
     
    10831385  (let* ((pid (external-process-pid proc)))
    10841386    (when pid
    1085       (let* ((error (syscall syscalls::kill pid signal)))
     1387      (let* ((error (int-errno-call (#_kill pid signal))))
    10861388        (or (eql error 0)
    10871389            (%errno-disp error))))))
     1390
     1391) ; #-windows-target (progn
     1392
     1393#+windows-target
     1394(progn
     1395(defun temp-file-name (prefix)
     1396  "Returns a unique name for a temporary file, residing in system temp
     1397space, and prefixed with PREFIX."
     1398  (rlet ((buffer (:array :wchar_t #.#$MAX_PATH)))
     1399    (#_GetTempPathW #$MAX_PATH buffer)
     1400    (with-filename-cstrs ((c-prefix prefix))
     1401      (#_GetTempFileNameW buffer c-prefix 0 buffer)
     1402      (%get-native-utf-16-cstring buffer))))
     1403 
     1404(defun get-descriptor-for (object proc close-in-parent close-on-error
     1405                                  &rest keys &key direction (element-type 'character)
     1406                                  &allow-other-keys)
     1407  (etypecase object
     1408    ((eql t)
     1409     (values nil nil close-in-parent close-on-error))
     1410    (null
     1411     (let* ((null-device "nul")
     1412            (fd (fd-open null-device (case direction
     1413                                       (:input #$O_RDONLY)
     1414                                       (:output #$O_WRONLY)
     1415                                       (t #$O_RDWR)))))
     1416       (if (< fd 0)
     1417         (signal-file-error fd null-device))
     1418       (values fd nil (cons fd close-in-parent) (cons fd close-on-error))))
     1419    ((eql :stream)
     1420     (multiple-value-bind (read-pipe write-pipe) (pipe)
     1421       (case direction
     1422         (:input
     1423          (values read-pipe
     1424                  (make-fd-stream (fd-uninheritable write-pipe :direction :output)
     1425                                  :direction :output
     1426                                  :element-type element-type
     1427                                  :interactive nil
     1428                                  :basic t
     1429                                  :auto-close t)
     1430                  (cons read-pipe close-in-parent)
     1431                  (cons write-pipe close-on-error)))
     1432         (:output
     1433          (values write-pipe
     1434                  (make-fd-stream (fd-uninheritable read-pipe :direction :input)
     1435                                  :direction :input
     1436                                  :element-type element-type
     1437                                  :interactive nil
     1438                                  :basic t
     1439                                  :auto-close t)
     1440                  (cons write-pipe close-in-parent)
     1441                  (cons read-pipe close-on-error)))
     1442         (t
     1443          (fd-close read-pipe)
     1444          (fd-close write-pipe)
     1445          (report-bad-arg direction '(member :input :output))))))
     1446    ((or pathname string)
     1447     (with-open-stream (file (apply #'open object keys))
     1448       (let* ((fd (fd-dup (ioblock-device (stream-ioblock file t)) :direction direction :inheritable t)))
     1449         (values fd
     1450                 nil
     1451                 (cons fd close-in-parent)
     1452                 (cons fd close-on-error)))))
     1453    (fd-stream
     1454     (let ((fd (fd-dup (ioblock-device (stream-ioblock object t)))))
     1455       (values fd
     1456               nil
     1457               (cons fd close-in-parent)
     1458               (cons fd close-on-error))))
     1459    (stream
     1460     (ecase direction
     1461       (:input
     1462        (let* ((tempname (temp-file-name "lisp-temp"))
     1463               (fd (fd-open tempname #$O_RDWR)))
     1464          (if (< fd 0)
     1465            (%errno-disp fd))
     1466          (loop
     1467            (multiple-value-bind (line no-newline)
     1468                (read-line object nil nil)
     1469              (unless line
     1470                (return))
     1471              (let* ((len (length line)))
     1472                (%stack-block ((buf (1+ len)))
     1473                  (%cstr-pointer line buf)
     1474                  (fd-write fd buf len)
     1475                  (if no-newline
     1476                    (return))
     1477                  (setf (%get-byte buf) (char-code #\newline))
     1478                  (fd-write fd buf 1)))))
     1479          (fd-lseek fd 0 #$SEEK_SET)
     1480          (values fd nil (cons fd close-in-parent) (cons fd close-on-error))))
     1481       (:output
     1482        (multiple-value-bind (read-pipe write-pipe) (pipe)
     1483          (setf (external-process-watched-fd proc) read-pipe
     1484                (external-process-watched-stream proc) object)
     1485          (incf (car (external-process-token proc)))
     1486          (values write-pipe
     1487                  nil
     1488                  (cons write-pipe close-in-parent)
     1489                  (cons read-pipe close-on-error))))))))
     1490
     1491(defstruct external-process
     1492  pid
     1493  %status
     1494  %exit-code
     1495  pty
     1496  input
     1497  output
     1498  error
     1499  status-hook
     1500  plist
     1501  token
     1502  core
     1503  args
     1504  (signal (make-semaphore))
     1505  (completed (make-semaphore))
     1506  watched-fd
     1507  watched-stream
     1508  )
     1509
     1510(defun external-process-status (proc)
     1511  "Return information about whether an OS subprocess is running; or, if
     1512not, why not; and what its result code was if it completed."
     1513  (require-type proc 'external-process)
     1514  (values (external-process-%status proc)
     1515          (external-process-%exit-code proc)))
     1516
     1517
     1518(defmethod print-object ((p external-process) stream)
     1519  (print-unreadable-object (p stream :type t :identity t)
     1520    (let* ((status (external-process-%status p)))
     1521      (let* ((*print-length* 3))
     1522        (format stream "~a" (external-process-args p)))
     1523      (format stream "[~d] (~a" (external-process-pid p) status)
     1524      (unless (eq status :running)
     1525        (format stream " : ~d" (external-process-%exit-code p)))
     1526      (format stream ")"))))
     1527
     1528(defun run-program (program args &key
     1529                            (wait t) pty
     1530                            input if-input-does-not-exist
     1531                            output (if-output-exists :error)
     1532                            (error :output) (if-error-exists :error)
     1533                            status-hook (element-type 'character)
     1534                            env)
     1535  "Invoke an external program as an OS subprocess of lisp."
     1536  (declare (ignore pty))
     1537  (unless (every #'(lambda (a) (typep a 'simple-string)) args)
     1538    (error "Program args must all be simple strings : ~s" args))
     1539  (push program args)
     1540  (let* ((token (list 0))
     1541         (in-fd nil)
     1542         (in-stream nil)
     1543         (out-fd nil)
     1544         (out-stream nil)
     1545         (error-fd nil)
     1546         (error-stream nil)
     1547         (close-in-parent nil)
     1548         (close-on-error nil)
     1549         (proc
     1550          (make-external-process
     1551           :pid nil
     1552           :args args
     1553           :%status :running
     1554           :input nil
     1555           :output nil
     1556           :error nil
     1557           :token token
     1558           :status-hook status-hook)))
     1559    (unwind-protect
     1560         (progn
     1561           (multiple-value-setq (in-fd in-stream close-in-parent close-on-error)
     1562             (get-descriptor-for input proc  nil nil :direction :input
     1563                                 :if-does-not-exist if-input-does-not-exist
     1564                                 :element-type element-type))
     1565           (multiple-value-setq (out-fd out-stream close-in-parent close-on-error)
     1566             (get-descriptor-for output proc close-in-parent close-on-error
     1567                                 :direction :output
     1568                                 :if-exists if-output-exists
     1569                                 :element-type element-type))
     1570           (multiple-value-setq (error-fd error-stream close-in-parent close-on-error)
     1571             (if (eq error :output)
     1572               (values out-fd out-stream close-in-parent close-on-error)
     1573               (get-descriptor-for error proc close-in-parent close-on-error
     1574                                   :direction :output
     1575                                   :if-exists if-error-exists
     1576                                   :element-type element-type)))
     1577           (setf (external-process-input proc) in-stream
     1578                 (external-process-output proc) out-stream
     1579                 (external-process-error proc) error-stream)
     1580           (process-run-function
     1581            (format nil "Monitor thread for external process ~a" args)
     1582                   
     1583            #'run-external-process proc in-fd out-fd error-fd env)
     1584           (wait-on-semaphore (external-process-signal proc))
     1585           )
     1586      (dolist (fd close-in-parent) (fd-close fd))
     1587      (if (external-process-pid proc)
     1588        (when (and wait (external-process-pid proc))
     1589          (with-interrupts-enabled
     1590              (wait-on-semaphore (external-process-completed proc))))
     1591        (progn
     1592          (dolist (fd close-on-error) (fd-close fd))
     1593          (error "Process execution failed"))))
     1594    proc))
     1595
     1596(let* ((external-processes ())
     1597       (external-processes-lock (make-lock)))
     1598  (defun add-external-process (p)
     1599    (with-lock-grabbed (external-processes-lock)
     1600      (push p external-processes)))
     1601  (defun remove-external-process (p)
     1602    (with-lock-grabbed (external-processes-lock)
     1603      (setq external-processes (delete p external-processes))))
     1604  ;; Likewise
     1605  (defun external-processes ()
     1606    (with-lock-grabbed (external-processes-lock)
     1607      (copy-list external-processes)))
     1608  )
     1609
     1610
     1611
     1612
     1613(defun run-external-process (proc in-fd out-fd error-fd &optional env)
     1614  (let* ((args (external-process-args proc))
     1615         (child-pid (exec-with-io-redirection in-fd out-fd error-fd args proc env)))
     1616    (when child-pid
     1617      (setf (external-process-pid proc) child-pid)
     1618      (add-external-process proc)
     1619      (signal-semaphore (external-process-signal proc))
     1620      (monitor-external-process proc))))
     1621
     1622(defun join-strings (strings)
     1623  (reduce (lambda (left right) (concatenate 'string left " " right)) strings))
     1624
     1625(defun exec-with-io-redirection (new-in new-out new-err args proc &optional env)
     1626  (declare (ignore env))                ; until we can do better.
     1627  (with-filename-cstrs ((command (join-strings args)))
     1628    (rletz ((proc-info #>PROCESS_INFORMATION)
     1629            (si #>STARTUPINFO))
     1630      (setf (pref si #>STARTUPINFO.cb) (record-length #>STARTUPINFO))
     1631      (setf (pref si #>STARTUPINFO.dwFlags)
     1632            (logior #$STARTF_USESTDHANDLES #$STARTF_USESHOWWINDOW))
     1633      (setf (pref si #>STARTUPINFO.wShowWindow) #$SW_HIDE)
     1634      (setf (pref si #>STARTUPINFO.hStdInput)
     1635            (if new-in
     1636              (%int-to-ptr new-in)
     1637              (#_GetStdHandle #$STD_INPUT_HANDLE)))
     1638      (setf (pref si #>STARTUPINFO.hStdOutput)
     1639            (if new-out
     1640              (%int-to-ptr new-out)
     1641              (#_GetStdHandle #$STD_OUTPUT_HANDLE)))
     1642      (setf (pref si #>STARTUPINFO.hStdError)
     1643            (if new-err
     1644              (%int-to-ptr new-err)
     1645              (#_GetStdHandle #$STD_ERROR_HANDLE)))
     1646      (if (zerop (#_CreateProcessW (%null-ptr)
     1647                                   command
     1648                                   (%null-ptr)
     1649                                   (%null-ptr)
     1650                                   1
     1651                                   #$CREATE_NEW_CONSOLE
     1652                                   (%null-ptr)
     1653                                   (%null-ptr)
     1654                                   si
     1655                                   proc-info))
     1656        (setf (external-process-%status proc) :error
     1657              (external-process-%exit-code proc) (#_GetLastError))
     1658        (#_CloseHandle (pref proc-info #>PROCESS_INFORMATION.hThread)))
     1659      (pref proc-info #>PROCESS_INFORMATION.hProcess))))
     1660
     1661(defun fd-uninheritable (fd &key direction)
     1662  (let ((new-fd (fd-dup fd :direction direction)))
     1663    (fd-close fd)
     1664    new-fd))
     1665
     1666(defun monitor-external-process (p)
     1667  (let* ((in-fd (external-process-watched-fd p))
     1668         (out-stream (external-process-watched-stream p))
     1669         (token (external-process-token p))
     1670         (terminated))
     1671    (loop
     1672      (when terminated
     1673        (without-interrupts
     1674         (decf (car token))
     1675         (if in-fd (fd-close in-fd))
     1676         (setq in-fd nil)
     1677         (rlet ((code #>DWORD))
     1678           (loop
     1679             (#_GetExitCodeProcess (external-process-pid p) code)
     1680             (unless (eql (pref code #>DWORD) #$STILL_ACTIVE)
     1681               (return)))
     1682           (#_SleepEx 10 #$TRUE)
     1683           (setf (external-process-%exit-code p) (pref code #>DWORD)))
     1684         (#_CloseHandle (external-process-pid p))
     1685         (setf (external-process-pid p) nil)
     1686         (setf (external-process-%status p) :exited)
     1687         (let ((status-hook (external-process-status-hook p)))
     1688           (when status-hook
     1689             (funcall status-hook p)))
     1690         (remove-external-process p)
     1691         (signal-semaphore (external-process-completed p))
     1692         (return)))     
     1693      (if in-fd
     1694        (rlet ((handles (:array #>HANDLE 2)))
     1695          (setf (paref handles (:array #>HANDLE) 0) (external-process-pid p))
     1696          (setf (paref handles (:array #>HANDLE) 1) (#__get_osfhandle in-fd))
     1697          (let ((rc (ignoring-eintr
     1698                     (let* ((code (#_WaitForMultipleObjectsEx 2 handles #$FALSE #$INFINITE #$true)))
     1699                       (if (eql code #$WAIT_IO_COMPLETION)
     1700                         (- #$EINTR)
     1701                         code)))))
     1702            (if (eq rc #$WAIT_OBJECT_0)
     1703              (setf terminated t)
     1704              (%stack-block ((buf 1024))
     1705                (let* ((n (fd-read in-fd buf 1024)))
     1706                  (declare (fixnum n))
     1707                  (if (<= n 0)
     1708                    (setf terminated t)
     1709                    (let* ((string (make-string 1024)))
     1710                      (declare (dynamic-extent string))
     1711                      (%str-from-ptr buf n string)
     1712                      (write-sequence string out-stream :end n))))))))
     1713        (progn
     1714          (ignoring-eintr
     1715           (let* ((code (#_WaitForSingleObjectEx (external-process-pid p) #$INFINITE #$true)))
     1716             (if (eql code #$WAIT_IO_COMPLETION)
     1717               (- #$EINTR)
     1718               code)))
     1719          (setf terminated t))))))
     1720 
     1721
     1722)                                   ; #+windows-target (progn
    10881723
    10891724;;; EOF on a TTY is transient, but I'm less sure of other cases.
     
    10911726  (case (%unix-fd-kind fd)
    10921727    (:tty t)
     1728    #+windows-target (:character-special t)
    10931729    (t nil)))
    10941730
     
    12161852                (pref info :host_basic_info.max_cpus)
    12171853                1))
    1218             #+linux-target
     1854            #+(or linux-target solaris-target)
    12191855            (or
    12201856             (let* ((n (#_sysconf #$_SC_NPROCESSORS_ONLN)))
    12211857               (declare (fixnum n))
    12221858               (if (> n 0) n))
     1859             #+linux-target
    12231860             (ignore-errors
    12241861               (with-open-file (p "/proc/cpuinfo")
     
    12471884                  (pref ret :uint)
    12481885                  1))))
    1249             )))
     1886            #+windows-target
     1887            (rlet ((procmask #>DWORD_PTR)
     1888                   (sysmask #>DWORD_PTR))
     1889              (if (eql 0 (#_GetProcessAffinityMask (#_GetCurrentProcess) procmask sysmask))
     1890                1
     1891                (logcount (pref sysmask #>DWORD_PTR)))))))
    12501892
    12511893(def-load-pointers spin-count ()
     
    12561898
    12571899(defun yield ()
     1900  #+windows-target
     1901  (#_Sleep 0)
     1902  #-windows-target 
    12581903  (#_sched_yield))
    12591904
    1260 (defloadvar *host-page-size* (#_getpagesize))
     1905(defloadvar *host-page-size*
     1906    #-windows-target (#_getpagesize)
     1907    #+windows-target
     1908    (rlet ((info #>SYSTEM_INFO))
     1909      (#_GetSystemInfo info)
     1910      (pref info #>SYSTEM_INFO.dwPageSize))
     1911    )
    12611912
    12621913;;(assert (= (logcount *host-page-size*) 1))
    12631914
     1915(defun get-universal-time ()
     1916  "Return a single integer for the current time of
     1917   day in universal time format."
     1918  (rlet ((tv :timeval))
     1919    (gettimeofday tv)
     1920    (+ (pref tv :timeval.tv_sec) unix-to-universal-time)))
     1921
     1922#-windows-target
     1923(progn
    12641924(defun map-file-to-ivector (pathname element-type)
    12651925  (let* ((upgraded-type (upgraded-array-element-type element-type))
     
    13021962                  (fd-close fd)
    13031963                  (error "Can't make a vector with ~s elements in this implementation." (+ ndata-elements nalignment-elements)))
    1304                 (let* ((addr (#_mmap +null-ptr+
     1964                (let* ((addr (#_mmap (%null-ptr)
    13051965                                     nbytes
    13061966                                     #$PROT_NONE
     
    14342094      (mapped-vector-data-address-and-size v)
    14352095    (percentage-of-resident-pages address nbytes)))
    1436  
     2096)
     2097
     2098#+windows-target
     2099(defun cygpath (winpath)
     2100  "Try to use the Cygwin \"cygpath\" program to map a Windows-style
     2101   pathname to a POSIX-stype Cygwin pathname."
     2102  (let* ((posix-path winpath))
     2103    (with-output-to-string (s)
     2104      (multiple-value-bind (status exit-code)
     2105          (external-process-status
     2106           (run-program "cygpath" (list "-u" winpath) :output s))
     2107        (when (and (eq status :exited)
     2108                   (eql exit-code 0))
     2109          (with-input-from-string (output (get-output-stream-string s))
     2110            (setq posix-path (read-line output nil nil))))))
     2111    posix-path))
     2112
     2113#-windows-target (defun cygpath (path) path)
     2114     
     2115
     2116
     2117
    14372118#+x86-target
    14382119(progn
Note: See TracChangeset for help on using the changeset viewer.