src/code/win32.lisp

   1 ;;;; This file contains Win32 support routines that SBCL needs to
   2 ;;;; implement itself, in addition to those that apply to Win32 in
   3 ;;;; unix.lisp.  In theory, some of these functions might someday be
   4 ;;;; useful to the end user.
   5
   6 ;;;; This software is part of the SBCL system. See the README file for
   7 ;;;; more information.
   8 ;;;;
   9 ;;;; This software is derived from the CMU CL system, which was
  10 ;;;; written at Carnegie Mellon University and released into the
  11 ;;;; public domain. The software is in the public domain and is
  12 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  13 ;;;; files for more information.
  14
  15 (in-package "SB!WIN32")
  16
  17 ;;; Alien definitions for commonly used Win32 types.  Woe unto whoever
  18 ;;; tries to untangle this someday for 64-bit Windows.
  19 ;;;
  20 ;;; FIXME: There used to be many more here, which are now groveled,
  21 ;;; but TCHAR is a bit nasty as at the time grovel-headers runs
  22 ;;; the unicodeness isn't conveniently known, and HANDLE... well,
  23 ;;; groveling HANDLE makes it unsigned, which currently breaks the
  24 ;;; build. --NS 2006-06-18
  25 (define-alien-type handle int-ptr)
  26 (define-alien-type tchar #!+sb-unicode (sb!alien:unsigned 16)
  27                          #!-sb-unicode char)
  28
  29 (defconstant default-environment-length 1024)
  30
  31 ;;; HANDLEs are actually pointers, but an invalid handle is -1 cast
  32 ;;; to a pointer.
  33 (defconstant invalid-handle -1)
  34
  35 ;;;; Error Handling
  36
  37 ;;; Retrieve the calling thread's last-error code value.  The
  38 ;;; last-error code is maintained on a per-thread basis.
  39 (define-alien-routine ("GetLastError@0" get-last-error) dword)
  40
  41 ;;; Flag constants for FORMAT-MESSAGE.
  42 (defconstant format-message-from-system #x1000)
  43
  44 ;;; Format an error message based on a lookup table.  See MSDN for the
  45 ;;; full meaning of the all options---most are not used when getting
  46 ;;; system error codes.
  47 (define-alien-routine ("FormatMessageA@28" format-message) dword
  48   (flags dword)
  49   (source (* t))
  50   (message-id dword)
  51   (language-id dword)
  52   (buffer c-string)
  53   (size dword)
  54   (arguments (* t)))
  55
  56 (defun get-current-process ()
  57   (alien-funcall
  58    (extern-alien "GetCurrentProcess@0" (function long))))
  59
  60 ;;;; File Handles
  61
  62 ;;; Get the operating system handle for a C file descriptor.  Returns
  63 ;;; INVALID-HANDLE on failure.
  64 (define-alien-routine ("_get_osfhandle" get-osfhandle) handle
  65   (fd int))
  66
  67 ;;; Read data from a file handle into a buffer.  This may be used
  68 ;;; synchronously or with "overlapped" (asynchronous) I/O.
  69 (define-alien-routine ("ReadFile@20" read-file) bool
  70   (file handle)
  71   (buffer (* t))
  72   (bytes-to-read dword)
  73   (bytes-read (* dword))
  74   (overlapped (* t)))
  75
  76 ;;; Write data from a buffer to a file handle.  This may be used
  77 ;;; synchronously  or with "overlapped" (asynchronous) I/O.
  78 (define-alien-routine ("WriteFile@20" write-file) bool
  79   (file handle)
  80   (buffer (* t))
  81   (bytes-to-write dword)
  82   (bytes-written (* dword))
  83   (overlapped (* t)))
  84
  85 ;;; Copy data from a named or anonymous pipe into a buffer without
  86 ;;; removing it from the pipe.  BUFFER, BYTES-READ, BYTES-AVAIL, and
  87 ;;; BYTES-LEFT-THIS-MESSAGE may be NULL if no data is to be read.
  88 ;;; Return TRUE on success, FALSE on failure.
  89 (define-alien-routine ("PeekNamedPipe@24" peek-named-pipe) bool
  90   (pipe handle)
  91   (buffer (* t))
  92   (buffer-size dword)
  93   (bytes-read (* dword))
  94   (bytes-avail (* dword))
  95   (bytes-left-this-message (* dword)))
  96
  97 ;;; Flush the console input buffer if HANDLE is a console handle.
  98 ;;; Returns true on success, false if the handle does not refer to a
  99 ;;; console.
 100 (define-alien-routine ("FlushConsoleInputBuffer@4" flush-console-input-buffer) bool
 101   (handle handle))
 102
 103 ;;; Read data from the console input buffer without removing it,
 104 ;;; without blocking.  Buffer should be large enough for LENGTH *
 105 ;;; INPUT-RECORD-SIZE bytes.
 106 (define-alien-routine ("PeekConsoleInputA@16" peek-console-input) bool
 107   (handle handle)
 108   (buffer (* t))
 109   (length dword)
 110   (nevents (* dword)))
 111
 112 ;;; Listen for input on a Windows file handle.  Unlike UNIX, there
 113 ;;; isn't a unified interface to do this---we have to know what sort
 114 ;;; of handle we have.  Of course, there's no way to actually
 115 ;;; introspect it, so we have to try various things until we find
 116 ;;; something that works.  Returns true if there could be input
 117 ;;; available, or false if there is not.
 118 (defun handle-listen (handle)
 119   (with-alien ((avail dword)
 120                (buf (array char #.input-record-size)))
 121     (unless (zerop (peek-named-pipe handle nil 0 nil (addr avail) nil))
 122       (return-from handle-listen (plusp avail)))
 123
 124     (unless (zerop (peek-console-input handle
 125                                        (cast buf (* t))
 126                                        input-record-size (addr avail)))
 127       (return-from handle-listen (plusp avail)))
 128
 129     ;; FIXME-SOCKETS: Try again here with WSAEventSelect in case
 130     ;; HANDLE is a socket.
 131     t))
 132
 133 ;;; Listen for input on a C runtime file handle.  Returns true if
 134 ;;; there could be input available, or false if there is not.
 135 (defun fd-listen (fd)
 136   (let ((handle (get-osfhandle fd)))
 137     (if handle
 138         (handle-listen handle)
 139         t)))
 140
 141 ;;; Clear all available input from a file handle.
 142 (defun handle-clear-input (handle)
 143   (flush-console-input-buffer handle)
 144   (with-alien ((buf (array char 1024))
 145                (count dword))
 146     (loop
 147      (unless (handle-listen handle)
 148        (return))
 149      (when (zerop (read-file handle (cast buf (* t)) 1024 (addr count) nil))
 150        (return))
 151      (when (< count 1024)
 152        (return)))))
 153
 154 ;;; Clear all available input from a C runtime file handle.
 155 (defun fd-clear-input (fd)
 156   (let ((handle (get-osfhandle fd)))
 157     (when handle
 158       (handle-clear-input handle))))
 159
 160 ;;;; System Functions
 161
 162 ;;; Sleep for MILLISECONDS milliseconds.
 163 (define-alien-routine ("Sleep@4" millisleep) void
 164   (milliseconds dword))
 165
 166 #+sb-unicode
 167 (progn
 168   (defvar *ansi-codepage* nil)
 169   (defvar *oem-codepage* nil)
 170   (defvar *codepage-to-external-format* (make-hash-table)))
 171
 172 #+sb-unicode
 173 (dolist
 174     (cp '(;;037       IBM EBCDIC - U.S./Canada
 175           (437 :CP437) ;; OEM - United States
 176           ;;500       IBM EBCDIC - International
 177           ;;708       Arabic - ASMO 708
 178           ;;709       Arabic - ASMO 449+, BCON V4
 179           ;;710       Arabic - Transparent Arabic
 180           ;;720       Arabic - Transparent ASMO
 181           ;;737       OEM - Greek (formerly 437G)
 182           ;;775       OEM - Baltic
 183           (850 :CP850)     ;; OEM - Multilingual Latin I
 184           (852 :CP852)     ;; OEM - Latin II
 185           (855 :CP855)     ;; OEM - Cyrillic (primarily Russian)
 186           (857 :CP857)     ;; OEM - Turkish
 187           ;;858       OEM - Multilingual Latin I + Euro symbol
 188           (860 :CP860)     ;; OEM - Portuguese
 189           (861 :CP861)     ;; OEM - Icelandic
 190           (862 :CP862)     ;; OEM - Hebrew
 191           (863 :CP863)     ;; OEM - Canadian-French
 192           (864 :CP864)     ;; OEM - Arabic
 193           (865 :CP865)     ;; OEM - Nordic
 194           (866 :CP866)     ;; OEM - Russian
 195           (869 :CP869)     ;; OEM - Modern Greek
 196           ;;870       IBM EBCDIC - Multilingual/ROECE (Latin-2)
 197           (874 :CP874) ;; ANSI/OEM - Thai (same as 28605, ISO 8859-15)
 198           ;;875       IBM EBCDIC - Modern Greek
 199           ;;932       ANSI/OEM - Japanese, Shift-JIS
 200           ;;936       ANSI/OEM - Simplified Chinese (PRC, Singapore)
 201           ;;949       ANSI/OEM - Korean (Unified Hangul Code)
 202           ;;950       ANSI/OEM - Traditional Chinese (Taiwan; Hong Kong SAR, PRC)
 203           ;;1026      IBM EBCDIC - Turkish (Latin-5)
 204           ;;1047      IBM EBCDIC - Latin 1/Open System
 205           ;;1140      IBM EBCDIC - U.S./Canada (037 + Euro symbol)
 206           ;;1141      IBM EBCDIC - Germany (20273 + Euro symbol)
 207           ;;1142      IBM EBCDIC - Denmark/Norway (20277 + Euro symbol)
 208           ;;1143      IBM EBCDIC - Finland/Sweden (20278 + Euro symbol)
 209           ;;1144      IBM EBCDIC - Italy (20280 + Euro symbol)
 210           ;;1145      IBM EBCDIC - Latin America/Spain (20284 + Euro symbol)
 211           ;;1146      IBM EBCDIC - United Kingdom (20285 + Euro symbol)
 212           ;;1147      IBM EBCDIC - France (20297 + Euro symbol)
 213           ;;1148      IBM EBCDIC - International (500 + Euro symbol)
 214           ;;1149      IBM EBCDIC - Icelandic (20871 + Euro symbol)
 215           ;;1200      Unicode UCS-2 Little-Endian (BMP of ISO 10646)
 216           ;;1201      Unicode UCS-2 Big-Endian
 217           (1250 :CP1250)     ;; ANSI - Central European
 218           (1251 :CP1251)     ;; ANSI - Cyrillic
 219           (1252 :CP1252)     ;; ANSI - Latin I
 220           (1253 :CP1253)     ;; ANSI - Greek
 221           (1254 :CP1254)     ;; ANSI - Turkish
 222           (1255 :CP1255)     ;; ANSI - Hebrew
 223           (1256 :CP1256)     ;; ANSI - Arabic
 224           (1257 :CP1257)     ;; ANSI - Baltic
 225           (1258 :CP1258)     ;; ANSI/OEM - Vietnamese
 226           ;;1361      Korean (Johab)
 227           ;;10000 MAC - Roman
 228           ;;10001     MAC - Japanese
 229           ;;10002     MAC - Traditional Chinese (Big5)
 230           ;;10003     MAC - Korean
 231           ;;10004     MAC - Arabic
 232           ;;10005     MAC - Hebrew
 233           ;;10006     MAC - Greek I
 234           (10007 :X-MAC-CYRILLIC) ;; MAC - Cyrillic
 235           ;;10008     MAC - Simplified Chinese (GB 2312)
 236           ;;10010     MAC - Romania
 237           ;;10017     MAC - Ukraine
 238           ;;10021     MAC - Thai
 239           ;;10029     MAC - Latin II
 240           ;;10079     MAC - Icelandic
 241           ;;10081     MAC - Turkish
 242           ;;10082     MAC - Croatia
 243           ;;12000     Unicode UCS-4 Little-Endian
 244           ;;12001     Unicode UCS-4 Big-Endian
 245           ;;20000     CNS - Taiwan
 246           ;;20001     TCA - Taiwan
 247           ;;20002     Eten - Taiwan
 248           ;;20003     IBM5550 - Taiwan
 249           ;;20004     TeleText - Taiwan
 250           ;;20005     Wang - Taiwan
 251           ;;20105     IA5 IRV International Alphabet No. 5 (7-bit)
 252           ;;20106     IA5 German (7-bit)
 253           ;;20107     IA5 Swedish (7-bit)
 254           ;;20108     IA5 Norwegian (7-bit)
 255           ;;20127     US-ASCII (7-bit)
 256           ;;20261     T.61
 257           ;;20269     ISO 6937 Non-Spacing Accent
 258           ;;20273     IBM EBCDIC - Germany
 259           ;;20277     IBM EBCDIC - Denmark/Norway
 260           ;;20278     IBM EBCDIC - Finland/Sweden
 261           ;;20280     IBM EBCDIC - Italy
 262           ;;20284     IBM EBCDIC - Latin America/Spain
 263           ;;20285     IBM EBCDIC - United Kingdom
 264           ;;20290     IBM EBCDIC - Japanese Katakana Extended
 265           ;;20297     IBM EBCDIC - France
 266           ;;20420     IBM EBCDIC - Arabic
 267           ;;20423     IBM EBCDIC - Greek
 268           ;;20424     IBM EBCDIC - Hebrew
 269           ;;20833     IBM EBCDIC - Korean Extended
 270           ;;20838     IBM EBCDIC - Thai
 271           (20866 :KOI8-R) ;; Russian - KOI8-R
 272           ;;20871     IBM EBCDIC - Icelandic
 273           ;;20880     IBM EBCDIC - Cyrillic (Russian)
 274           ;;20905     IBM EBCDIC - Turkish
 275           ;;20924     IBM EBCDIC - Latin-1/Open System (1047 + Euro symbol)
 276           ;;20932     JIS X 0208-1990 & 0121-1990
 277           ;;20936     Simplified Chinese (GB2312)
 278           ;;21025     IBM EBCDIC - Cyrillic (Serbian, Bulgarian)
 279           ;;21027     (deprecated)
 280           (21866 :KOI8-U)      ;; Ukrainian (KOI8-U)
 281           (28591 :LATIN-1)     ;; ISO 8859-1 Latin I
 282           (28592 :ISO-8859-2)  ;; ISO 8859-2 Central Europe
 283           (28593 :ISO-8859-3)  ;; ISO 8859-3 Latin 3
 284           (28594 :ISO-8859-4)  ;; ISO 8859-4 Baltic
 285           (28595 :ISO-8859-5)  ;; ISO 8859-5 Cyrillic
 286           (28596 :ISO-8859-6)  ;; ISO 8859-6 Arabic
 287           (28597 :ISO-8859-7)  ;; ISO 8859-7 Greek
 288           (28598 :ISO-8859-8)  ;; ISO 8859-8 Hebrew
 289           (28599 :ISO-8859-9)  ;; ISO 8859-9 Latin 5
 290           (28605 :LATIN-9)     ;; ISO 8859-15 Latin 9
 291           ;;29001     Europa 3
 292           (38598 :ISO-8859-8) ;; ISO 8859-8 Hebrew
 293           ;;50220     ISO 2022 Japanese with no halfwidth Katakana
 294           ;;50221     ISO 2022 Japanese with halfwidth Katakana
 295           ;;50222     ISO 2022 Japanese JIS X 0201-1989
 296           ;;50225     ISO 2022 Korean
 297           ;;50227     ISO 2022 Simplified Chinese
 298           ;;50229     ISO 2022 Traditional Chinese
 299           ;;50930     Japanese (Katakana) Extended
 300           ;;50931     US/Canada and Japanese
 301           ;;50933     Korean Extended and Korean
 302           ;;50935     Simplified Chinese Extended and Simplified Chinese
 303           ;;50936     Simplified Chinese
 304           ;;50937     US/Canada and Traditional Chinese
 305           ;;50939     Japanese (Latin) Extended and Japanese
 306           (51932 :EUC-JP) ;; EUC - Japanese
 307           ;;51936     EUC - Simplified Chinese
 308           ;;51949     EUC - Korean
 309           ;;51950     EUC - Traditional Chinese
 310           ;;52936     HZ-GB2312 Simplified Chinese
 311           ;;54936     Windows XP: GB18030 Simplified Chinese (4 Byte)
 312           ;;57002     ISCII Devanagari
 313           ;;57003     ISCII Bengali
 314           ;;57004     ISCII Tamil
 315           ;;57005     ISCII Telugu
 316           ;;57006     ISCII Assamese
 317           ;;57007     ISCII Oriya
 318           ;;57008     ISCII Kannada
 319           ;;57009     ISCII Malayalam
 320           ;;57010     ISCII Gujarati
 321           ;;57011     ISCII Punjabi
 322           ;;65000     Unicode UTF-7
 323           (65001 :UTF8))) ;; Unicode UTF-8
 324   (setf (gethash (car cp) *codepage-to-external-format*) (cadr cp)))
 325
 326 #!+sb-unicode
 327 ;; FIXME: Something odd here: why are these two #+SB-UNICODE, whereas
 328 ;; the console just behave differently?
 329 (progn
 330   (declaim (ftype (function () keyword) ansi-codepage))
 331   (defun ansi-codepage ()
 332     (or *ansi-codepage*
 333         (setq *ansi-codepage*
 334               (gethash (alien-funcall (extern-alien "GetACP@0" (function UINT)))
 335                        *codepage-to-external-format*
 336                        :latin-1))))
 337
 338   (declaim (ftype (function () keyword) oem-codepage))
 339   (defun oem-codepage ()
 340     (or *oem-codepage*
 341         (setq *oem-codepage*
 342             (gethash (alien-funcall (extern-alien "GetOEMCP@0" (function UINT)))
 343                      *codepage-to-external-format*
 344                      :latin-1)))))
 345
 346 ;; http://msdn.microsoft.com/library/en-us/dllproc/base/getconsolecp.asp
 347 (declaim (ftype (function () keyword) console-input-codepage))
 348 (defun console-input-codepage ()
 349   (or #!+sb-unicode
 350       (gethash (alien-funcall (extern-alien "GetConsoleCP@0" (function UINT)))
 351                *codepage-to-external-format*)
 352       :latin-1))
 353
 354 ;; http://msdn.microsoft.com/library/en-us/dllproc/base/getconsoleoutputcp.asp
 355 (declaim (ftype (function () keyword) console-output-codepage))
 356 (defun console-output-codepage ()
 357   (or #!+sb-unicode
 358       (gethash (alien-funcall
 359                 (extern-alien "GetConsoleOutputCP@0" (function UINT)))
 360                *codepage-to-external-format*)
 361       :latin-1))
 362
 363 ;;;; FIXME (rudi 2006-03-29): this should really be (octets-to-string
 364 ;;;; :external-format :ucs2), except that we do not have an
 365 ;;;; implementation of ucs2 yet.
 366 (defmacro ucs2->string (astr &optional size)
 367   #!-sb-unicode
 368   (declare (ignore size))
 369   #!-sb-unicode
 370   `(cast ,astr c-string)
 371   #!+sb-unicode
 372   (let ((str-len (or size `(do ((i 0 (1+ i))) ((zerop (deref ,astr i)) i)))))
 373     `(let* ((l ,str-len)
 374             (s (make-string l)))
 375       (dotimes (i l) (setf (aref s i) (code-char (deref ,astr i))))
 376       s)))
 377
 378 (defmacro ucs2->string&free (astr &optional size)
 379   `(prog1 (ucs2->string ,astr ,size) (free-alien ,astr)))
 380
 381 (define-alien-routine ("LocalFree@4" local-free) void
 382   (lptr (* t)))
 383
 384 (defun get-last-error-message (err)
 385   "http://msdn.microsoft.com/library/default.asp?url=/library/en-us/debug/base/retrieving_the_last_error_code.asp"
 386   (with-alien ((amsg (* tchar)))
 387     (let ((nchars
 388            (alien-funcall
 389             (extern-alien #!+sb-unicode "FormatMessageW@28"
 390                           #!-sb-unicode "FormatMessageA@28"
 391                           (function dword dword dword dword dword
 392                                     (* (* tchar)) dword dword))
 393             (logior FORMAT_MESSAGE_ALLOCATE_BUFFER FORMAT_MESSAGE_FROM_SYSTEM)
 394             0 err 0 (addr amsg) 0 0)))
 395       (prog1 (ucs2->string amsg nchars)
 396         (local-free amsg)))))
 397
 398 (defmacro win32-error (func-name)
 399   `(let ((err-code (sb!win32::get-last-error)))
 400      (error "~%Win32 Error [~A] - ~A~%~A"
 401             ,func-name
 402             err-code
 403             (sb!win32::get-last-error-message err-code))))
 404
 405 (defun get-folder-pathname (csidl)
 406   "http://msdn.microsoft.com/library/en-us/shellcc/platform/shell/reference/functions/shgetfolderpath.asp"
 407   (with-alien ((apath (* tchar) (make-alien tchar (1+ max_path))))
 408     (alien-funcall
 409      (extern-alien #!-sb-unicode "SHGetFolderPathA@20"
 410                    #!+sb-unicode "SHGetFolderPathW@20"
 411                    (function int handle int handle dword (* tchar)))
 412      0 csidl 0 0 apath)
 413     (parse-native-namestring
 414      (concatenate 'string (ucs2->string&free apath) "\\"))))
 415
 416 (defun sb!unix:posix-getcwd ()
 417   (with-alien ((apath (* tchar) (make-alien tchar (1+ max_path)))
 418                (afunc (function dword dword (* tchar))
 419                       :extern
 420                       #!-sb-unicode "GetCurrentDirectoryA@8"
 421                       #!+sb-unicode "GetCurrentDirectoryW@8"))
 422     (let ((ret (alien-funcall afunc (1+ max_path) apath)))
 423       (when (zerop ret)
 424         (win32-error "GetCurrentDirectory"))
 425       (when (> ret (1+ max_path))
 426         (free-alien apath)
 427         (setf apath (make-alien tchar ret))
 428         (alien-funcall afunc ret apath))
 429       (ucs2->string&free apath ret))))
 430
 431 (defun sb!unix:unix-mkdir (name mode)
 432   (declare (type sb!unix:unix-pathname name)
 433            (type sb!unix:unix-file-mode mode)
 434            (ignore mode))
 435   (let ((name-length (length name)))
 436     (with-alien ((apath (* tchar) (make-alien tchar (1+ name-length))))
 437       (dotimes (i name-length) (setf (deref apath i) (char-code (aref name i))))
 438       (setf (deref apath name-length) 0)
 439       (when (zerop (alien-funcall
 440                     (extern-alien #!-sb-unicode "CreateDirectoryA@8"
 441                                   #!+sb-unicode "CreateDirectoryW@8"
 442                                   (function bool (* tchar) dword))
 443                     apath 0))
 444         (win32-error "CreateDirectory"))
 445       (values t 0))))
 446
 447 (defun sb!unix:unix-rename (name1 name2)
 448   (declare (type sb!unix:unix-pathname name1 name2))
 449   (let ((name-length1 (length name1))
 450         (name-length2 (length name2)))
 451     (with-alien ((apath1 (* tchar) (make-alien tchar (1+ name-length1)))
 452                  (apath2 (* tchar) (make-alien tchar (1+ name-length2))))
 453       (dotimes (i name-length1)
 454         (setf (deref apath1 i) (char-code (aref name1 i))))
 455       (setf (deref apath1 name-length1) 0)
 456       (dotimes (i name-length2)
 457         (setf (deref apath2 i) (char-code (aref name2 i))))
 458       (setf (deref apath2 name-length2) 0)
 459       (when (zerop (alien-funcall
 460                     (extern-alien #!-sb-unicode "MoveFileA@8"
 461                                   #!+sb-unicode "MoveFileW@8"
 462                                   (function bool (* tchar) (* tchar)))
 463                     apath1 apath2))
 464         (win32-error "MoveFile"))
 465       (values t 0))))
 466
 467 (defun sb!unix::posix-getenv (name)
 468   (declare (type simple-string name))
 469   (let ((name-length (length name)))
 470     (with-alien ((aname (* tchar) (make-alien tchar (1+ name-length)))
 471                  (aenv (* tchar) (make-alien tchar default-environment-length))
 472                  (afunc (function dword (* tchar) (* tchar) dword)
 473                         :extern
 474                         #!-sb-unicode "GetEnvironmentVariableA@12"
 475                         #!+sb-unicode "GetEnvironmentVariableW@12"))
 476       (dotimes (i name-length)
 477         (setf (deref aname i) (char-code (aref name i))))
 478       (setf (deref aname name-length) 0)
 479       (let ((ret (alien-funcall afunc aname aenv default-environment-length)))
 480         (when (> ret default-environment-length)
 481           (free-alien aenv)
 482           (setf aenv (make-alien tchar ret))
 483           (alien-funcall afunc aname aenv ret))
 484         (if (> ret 0)
 485             (ucs2->string&free aenv ret)
 486             nil)))))
 487
 488 ;;;; Process time information
 489
 490 (define-alien-type nil
 491     (struct filetime
 492             (dw-low-datetime dword)
 493             (dw-high-datetime dword)))
 494
 495 (defun get-process-times ()
 496   (with-alien ((creation-time (struct filetime))
 497                (exit-time (struct filetime))
 498                (kernel-time (struct filetime))
 499                (user-time (struct filetime)))
 500     (let ((result (sb!alien:alien-funcall
 501                    (extern-alien
 502                     "GetProcessTimes@20"
 503                     (function bool
 504                               handle
 505                               (* (struct filetime))
 506                               (* (struct filetime))
 507                               (* (struct filetime))
 508                               (* (struct filetime))))
 509                    (get-current-process)
 510                    (addr creation-time)
 511                    (addr exit-time)
 512                    (addr kernel-time)
 513                    (addr user-time))))
 514       (if (zerop result)
 515           (win32-error "GetProcessTimes")
 516           (flet ((filetime-to-100-ns (time)
 517                    (+ (ash (slot time 'dw-high-datetime) 32)
 518                       (slot time 'dw-low-datetime))))
 519             (values (filetime-to-100-ns creation-time)
 520                     (filetime-to-100-ns exit-time)
 521                     (filetime-to-100-ns kernel-time)
 522                     (filetime-to-100-ns user-time)))))))