1.0.41.42: ppc: Documentation and NEWS updates for threading.
[sbcl.git] / 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 groveling HANDLE makes it unsigned, which currently breaks the
22 ;;; build. --NS 2006-06-18
23 (define-alien-type handle int-ptr)
24 (define-alien-type system-string
25                    #!-sb-unicode c-string
26                    #!+sb-unicode (c-string :external-format :ucs-2))
27
28 (defconstant default-environment-length 1024)
29
30 ;;; HANDLEs are actually pointers, but an invalid handle is -1 cast
31 ;;; to a pointer.
32 (defconstant invalid-handle -1)
33
34 ;;;; Error Handling
35
36 ;;; Retrieve the calling thread's last-error code value.  The
37 ;;; last-error code is maintained on a per-thread basis.
38 (define-alien-routine ("GetLastError@0" get-last-error) dword)
39
40 ;;; Flag constants for FORMAT-MESSAGE.
41 (defconstant format-message-from-system #x1000)
42
43 ;;; Format an error message based on a lookup table.  See MSDN for the
44 ;;; full meaning of the all options---most are not used when getting
45 ;;; system error codes.
46 (define-alien-routine ("FormatMessageA@28" format-message) dword
47   (flags dword)
48   (source (* t))
49   (message-id dword)
50   (language-id dword)
51   (buffer c-string)
52   (size dword)
53   (arguments (* t)))
54
55 ;;;; File Handles
56
57 ;;; Get the operating system handle for a C file descriptor.  Returns
58 ;;; INVALID-HANDLE on failure.
59 (define-alien-routine ("_get_osfhandle" get-osfhandle) handle
60   (fd int))
61
62 ;;; Read data from a file handle into a buffer.  This may be used
63 ;;; synchronously or with "overlapped" (asynchronous) I/O.
64 (define-alien-routine ("ReadFile@20" read-file) bool
65   (file handle)
66   (buffer (* t))
67   (bytes-to-read dword)
68   (bytes-read (* dword))
69   (overlapped (* t)))
70
71 ;;; Write data from a buffer to a file handle.  This may be used
72 ;;; synchronously  or with "overlapped" (asynchronous) I/O.
73 (define-alien-routine ("WriteFile@20" write-file) bool
74   (file handle)
75   (buffer (* t))
76   (bytes-to-write dword)
77   (bytes-written (* dword))
78   (overlapped (* t)))
79
80 ;;; Copy data from a named or anonymous pipe into a buffer without
81 ;;; removing it from the pipe.  BUFFER, BYTES-READ, BYTES-AVAIL, and
82 ;;; BYTES-LEFT-THIS-MESSAGE may be NULL if no data is to be read.
83 ;;; Return TRUE on success, FALSE on failure.
84 (define-alien-routine ("PeekNamedPipe@24" peek-named-pipe) bool
85   (pipe handle)
86   (buffer (* t))
87   (buffer-size dword)
88   (bytes-read (* dword))
89   (bytes-avail (* dword))
90   (bytes-left-this-message (* dword)))
91
92 ;;; Flush the console input buffer if HANDLE is a console handle.
93 ;;; Returns true on success, false if the handle does not refer to a
94 ;;; console.
95 (define-alien-routine ("FlushConsoleInputBuffer@4" flush-console-input-buffer) bool
96   (handle handle))
97
98 ;;; Read data from the console input buffer without removing it,
99 ;;; without blocking.  Buffer should be large enough for LENGTH *
100 ;;; INPUT-RECORD-SIZE bytes.
101 (define-alien-routine ("PeekConsoleInputA@16" peek-console-input) bool
102   (handle handle)
103   (buffer (* t))
104   (length dword)
105   (nevents (* dword)))
106
107 ;;; Listen for input on a Windows file handle.  Unlike UNIX, there
108 ;;; isn't a unified interface to do this---we have to know what sort
109 ;;; of handle we have.  Of course, there's no way to actually
110 ;;; introspect it, so we have to try various things until we find
111 ;;; something that works.  Returns true if there could be input
112 ;;; available, or false if there is not.
113 (defun handle-listen (handle)
114   (with-alien ((avail dword)
115                (buf (array char #.input-record-size)))
116     (unless (zerop (peek-named-pipe handle nil 0 nil (addr avail) nil))
117       (return-from handle-listen (plusp avail)))
118
119     (unless (zerop (peek-console-input handle
120                                        (cast buf (* t))
121                                        input-record-size (addr avail)))
122       (return-from handle-listen (plusp avail)))
123
124     ;; FIXME-SOCKETS: Try again here with WSAEventSelect in case
125     ;; HANDLE is a socket.
126     t))
127
128 ;;; Listen for input on a C runtime file handle.  Returns true if
129 ;;; there could be input available, or false if there is not.
130 (defun fd-listen (fd)
131   (let ((handle (get-osfhandle fd)))
132     (if handle
133         (handle-listen handle)
134         t)))
135
136 ;;; Clear all available input from a file handle.
137 (defun handle-clear-input (handle)
138   (flush-console-input-buffer handle)
139   (with-alien ((buf (array char 1024))
140                (count dword))
141     (loop
142      (unless (handle-listen handle)
143        (return))
144      (when (zerop (read-file handle (cast buf (* t)) 1024 (addr count) nil))
145        (return))
146      (when (< count 1024)
147        (return)))))
148
149 ;;; Clear all available input from a C runtime file handle.
150 (defun fd-clear-input (fd)
151   (let ((handle (get-osfhandle fd)))
152     (when handle
153       (handle-clear-input handle))))
154
155 ;;;; System Functions
156
157 ;;; Sleep for MILLISECONDS milliseconds.
158 (define-alien-routine ("Sleep@4" millisleep) void
159   (milliseconds dword))
160
161 #!+sb-unicode
162 (progn
163   (defvar *ansi-codepage* nil)
164   (defvar *oem-codepage* nil)
165   (defvar *codepage-to-external-format* (make-hash-table)))
166
167 #!+sb-unicode
168 (dolist
169     (cp '(;;037       IBM EBCDIC - U.S./Canada
170           (437 :CP437) ;; OEM - United States
171           ;;500       IBM EBCDIC - International
172           ;;708       Arabic - ASMO 708
173           ;;709       Arabic - ASMO 449+, BCON V4
174           ;;710       Arabic - Transparent Arabic
175           ;;720       Arabic - Transparent ASMO
176           ;;737       OEM - Greek (formerly 437G)
177           ;;775       OEM - Baltic
178           (850 :CP850)     ;; OEM - Multilingual Latin I
179           (852 :CP852)     ;; OEM - Latin II
180           (855 :CP855)     ;; OEM - Cyrillic (primarily Russian)
181           (857 :CP857)     ;; OEM - Turkish
182           ;;858       OEM - Multilingual Latin I + Euro symbol
183           (860 :CP860)     ;; OEM - Portuguese
184           (861 :CP861)     ;; OEM - Icelandic
185           (862 :CP862)     ;; OEM - Hebrew
186           (863 :CP863)     ;; OEM - Canadian-French
187           (864 :CP864)     ;; OEM - Arabic
188           (865 :CP865)     ;; OEM - Nordic
189           (866 :CP866)     ;; OEM - Russian
190           (869 :CP869)     ;; OEM - Modern Greek
191           ;;870       IBM EBCDIC - Multilingual/ROECE (Latin-2)
192           (874 :CP874) ;; ANSI/OEM - Thai (same as 28605, ISO 8859-15)
193           ;;875       IBM EBCDIC - Modern Greek
194           (932 :CP932)     ;; ANSI/OEM - Japanese, Shift-JIS
195           ;;936       ANSI/OEM - Simplified Chinese (PRC, Singapore)
196           ;;949       ANSI/OEM - Korean (Unified Hangul Code)
197           ;;950       ANSI/OEM - Traditional Chinese (Taiwan; Hong Kong SAR, PRC)
198           ;;1026      IBM EBCDIC - Turkish (Latin-5)
199           ;;1047      IBM EBCDIC - Latin 1/Open System
200           ;;1140      IBM EBCDIC - U.S./Canada (037 + Euro symbol)
201           ;;1141      IBM EBCDIC - Germany (20273 + Euro symbol)
202           ;;1142      IBM EBCDIC - Denmark/Norway (20277 + Euro symbol)
203           ;;1143      IBM EBCDIC - Finland/Sweden (20278 + Euro symbol)
204           ;;1144      IBM EBCDIC - Italy (20280 + Euro symbol)
205           ;;1145      IBM EBCDIC - Latin America/Spain (20284 + Euro symbol)
206           ;;1146      IBM EBCDIC - United Kingdom (20285 + Euro symbol)
207           ;;1147      IBM EBCDIC - France (20297 + Euro symbol)
208           ;;1148      IBM EBCDIC - International (500 + Euro symbol)
209           ;;1149      IBM EBCDIC - Icelandic (20871 + Euro symbol)
210           (1200 :UCS-2LE)    ;; Unicode UCS-2 Little-Endian (BMP of ISO 10646)
211           (1201 :UCS-2BE)    ;; Unicode UCS-2 Big-Endian
212           (1250 :CP1250)     ;; ANSI - Central European
213           (1251 :CP1251)     ;; ANSI - Cyrillic
214           (1252 :CP1252)     ;; ANSI - Latin I
215           (1253 :CP1253)     ;; ANSI - Greek
216           (1254 :CP1254)     ;; ANSI - Turkish
217           (1255 :CP1255)     ;; ANSI - Hebrew
218           (1256 :CP1256)     ;; ANSI - Arabic
219           (1257 :CP1257)     ;; ANSI - Baltic
220           (1258 :CP1258)     ;; ANSI/OEM - Vietnamese
221           ;;1361      Korean (Johab)
222           ;;10000 MAC - Roman
223           ;;10001     MAC - Japanese
224           ;;10002     MAC - Traditional Chinese (Big5)
225           ;;10003     MAC - Korean
226           ;;10004     MAC - Arabic
227           ;;10005     MAC - Hebrew
228           ;;10006     MAC - Greek I
229           (10007 :X-MAC-CYRILLIC) ;; MAC - Cyrillic
230           ;;10008     MAC - Simplified Chinese (GB 2312)
231           ;;10010     MAC - Romania
232           ;;10017     MAC - Ukraine
233           ;;10021     MAC - Thai
234           ;;10029     MAC - Latin II
235           ;;10079     MAC - Icelandic
236           ;;10081     MAC - Turkish
237           ;;10082     MAC - Croatia
238           ;;12000     Unicode UCS-4 Little-Endian
239           ;;12001     Unicode UCS-4 Big-Endian
240           ;;20000     CNS - Taiwan
241           ;;20001     TCA - Taiwan
242           ;;20002     Eten - Taiwan
243           ;;20003     IBM5550 - Taiwan
244           ;;20004     TeleText - Taiwan
245           ;;20005     Wang - Taiwan
246           ;;20105     IA5 IRV International Alphabet No. 5 (7-bit)
247           ;;20106     IA5 German (7-bit)
248           ;;20107     IA5 Swedish (7-bit)
249           ;;20108     IA5 Norwegian (7-bit)
250           ;;20127     US-ASCII (7-bit)
251           ;;20261     T.61
252           ;;20269     ISO 6937 Non-Spacing Accent
253           ;;20273     IBM EBCDIC - Germany
254           ;;20277     IBM EBCDIC - Denmark/Norway
255           ;;20278     IBM EBCDIC - Finland/Sweden
256           ;;20280     IBM EBCDIC - Italy
257           ;;20284     IBM EBCDIC - Latin America/Spain
258           ;;20285     IBM EBCDIC - United Kingdom
259           ;;20290     IBM EBCDIC - Japanese Katakana Extended
260           ;;20297     IBM EBCDIC - France
261           ;;20420     IBM EBCDIC - Arabic
262           ;;20423     IBM EBCDIC - Greek
263           ;;20424     IBM EBCDIC - Hebrew
264           ;;20833     IBM EBCDIC - Korean Extended
265           ;;20838     IBM EBCDIC - Thai
266           (20866 :KOI8-R) ;; Russian - KOI8-R
267           ;;20871     IBM EBCDIC - Icelandic
268           ;;20880     IBM EBCDIC - Cyrillic (Russian)
269           ;;20905     IBM EBCDIC - Turkish
270           ;;20924     IBM EBCDIC - Latin-1/Open System (1047 + Euro symbol)
271           ;;20932     JIS X 0208-1990 & 0121-1990
272           ;;20936     Simplified Chinese (GB2312)
273           ;;21025     IBM EBCDIC - Cyrillic (Serbian, Bulgarian)
274           ;;21027     (deprecated)
275           (21866 :KOI8-U)      ;; Ukrainian (KOI8-U)
276           (28591 :LATIN-1)     ;; ISO 8859-1 Latin I
277           (28592 :ISO-8859-2)  ;; ISO 8859-2 Central Europe
278           (28593 :ISO-8859-3)  ;; ISO 8859-3 Latin 3
279           (28594 :ISO-8859-4)  ;; ISO 8859-4 Baltic
280           (28595 :ISO-8859-5)  ;; ISO 8859-5 Cyrillic
281           (28596 :ISO-8859-6)  ;; ISO 8859-6 Arabic
282           (28597 :ISO-8859-7)  ;; ISO 8859-7 Greek
283           (28598 :ISO-8859-8)  ;; ISO 8859-8 Hebrew
284           (28599 :ISO-8859-9)  ;; ISO 8859-9 Latin 5
285           (28605 :LATIN-9)     ;; ISO 8859-15 Latin 9
286           ;;29001     Europa 3
287           (38598 :ISO-8859-8) ;; ISO 8859-8 Hebrew
288           ;;50220     ISO 2022 Japanese with no halfwidth Katakana
289           ;;50221     ISO 2022 Japanese with halfwidth Katakana
290           ;;50222     ISO 2022 Japanese JIS X 0201-1989
291           ;;50225     ISO 2022 Korean
292           ;;50227     ISO 2022 Simplified Chinese
293           ;;50229     ISO 2022 Traditional Chinese
294           ;;50930     Japanese (Katakana) Extended
295           ;;50931     US/Canada and Japanese
296           ;;50933     Korean Extended and Korean
297           ;;50935     Simplified Chinese Extended and Simplified Chinese
298           ;;50936     Simplified Chinese
299           ;;50937     US/Canada and Traditional Chinese
300           ;;50939     Japanese (Latin) Extended and Japanese
301           (51932 :EUC-JP) ;; EUC - Japanese
302           ;;51936     EUC - Simplified Chinese
303           ;;51949     EUC - Korean
304           ;;51950     EUC - Traditional Chinese
305           ;;52936     HZ-GB2312 Simplified Chinese
306           ;;54936     Windows XP: GB18030 Simplified Chinese (4 Byte)
307           ;;57002     ISCII Devanagari
308           ;;57003     ISCII Bengali
309           ;;57004     ISCII Tamil
310           ;;57005     ISCII Telugu
311           ;;57006     ISCII Assamese
312           ;;57007     ISCII Oriya
313           ;;57008     ISCII Kannada
314           ;;57009     ISCII Malayalam
315           ;;57010     ISCII Gujarati
316           ;;57011     ISCII Punjabi
317           ;;65000     Unicode UTF-7
318           (65001 :UTF8))) ;; Unicode UTF-8
319   (setf (gethash (car cp) *codepage-to-external-format*) (cadr cp)))
320
321 #!+sb-unicode
322 ;; FIXME: Something odd here: why are these two #+SB-UNICODE, whereas
323 ;; the console just behave differently?
324 (progn
325   (declaim (ftype (function () keyword) ansi-codepage))
326   (defun ansi-codepage ()
327     (or *ansi-codepage*
328         (setq *ansi-codepage*
329               (gethash (alien-funcall (extern-alien "GetACP@0" (function UINT)))
330                        *codepage-to-external-format*
331                        :latin-1))))
332
333   (declaim (ftype (function () keyword) oem-codepage))
334   (defun oem-codepage ()
335     (or *oem-codepage*
336         (setq *oem-codepage*
337             (gethash (alien-funcall (extern-alien "GetOEMCP@0" (function UINT)))
338                      *codepage-to-external-format*
339                      :latin-1)))))
340
341 ;; http://msdn.microsoft.com/library/en-us/dllproc/base/getconsolecp.asp
342 (declaim (ftype (function () keyword) console-input-codepage))
343 (defun console-input-codepage ()
344   (or #!+sb-unicode
345       (gethash (alien-funcall (extern-alien "GetConsoleCP@0" (function UINT)))
346                *codepage-to-external-format*)
347       :latin-1))
348
349 ;; http://msdn.microsoft.com/library/en-us/dllproc/base/getconsoleoutputcp.asp
350 (declaim (ftype (function () keyword) console-output-codepage))
351 (defun console-output-codepage ()
352   (or #!+sb-unicode
353       (gethash (alien-funcall
354                 (extern-alien "GetConsoleOutputCP@0" (function UINT)))
355                *codepage-to-external-format*)
356       :latin-1))
357
358 (define-alien-routine ("LocalFree@4" local-free) void
359   (lptr (* t)))
360
361 (defmacro cast-and-free (value &key (type 'system-string)
362                                 (free-function 'free-alien))
363   `(prog1 (cast ,value ,type)
364      (,free-function ,value)))
365
366 (eval-when (:compile-toplevel :load-toplevel :execute)
367 (defmacro with-funcname ((name description) &body body)
368   `(let
369      ((,name (etypecase ,description
370                (string ,description)
371                (cons (destructuring-bind (s &optional (l 0) c) ,description
372                        (format nil "~A~A~A" s
373                                (if c #!-sb-unicode "A@" #!+sb-unicode "W@" "@")
374                                l))))))
375      ,@body)))
376
377 (defmacro make-system-buffer (x)
378  `(make-alien char #!+sb-unicode (ash ,x 1) #!-sb-unicode ,x))
379
380 ;;; FIXME: The various FOO-SYSCALL-BAR macros, and perhaps some other
381 ;;; macros in this file, are only used in this file, and could be
382 ;;; implemented using SB!XC:DEFMACRO wrapped in EVAL-WHEN.
383
384 (defmacro syscall ((name ret-type &rest arg-types) success-form &rest args)
385   (with-funcname (sname name)
386     `(locally
387        (declare (optimize (sb!c::float-accuracy 0)))
388        (let ((result (alien-funcall
389                        (extern-alien ,sname
390                                      (function ,ret-type ,@arg-types))
391                        ,@args)))
392          (declare (ignorable result))
393          ,success-form))))
394
395 ;;; This is like SYSCALL, but if it fails, signal an error instead of
396 ;;; returning error codes. Should only be used for syscalls that will
397 ;;; never really get an error.
398 (defmacro syscall* ((name &rest arg-types) success-form &rest args)
399   (with-funcname (sname name)
400     `(locally
401        (declare (optimize (sb!c::float-accuracy 0)))
402        (let ((result (alien-funcall
403                        (extern-alien ,sname (function bool ,@arg-types))
404                        ,@args)))
405          (when (zerop result)
406            (win32-error ,sname))
407          ,success-form))))
408
409 (defmacro with-sysfun ((func name ret-type &rest arg-types) &body body)
410   (with-funcname (sname name)
411     `(with-alien ((,func (function ,ret-type ,@arg-types)
412                          :extern ,sname))
413        ,@body)))
414
415 (defmacro void-syscall* ((name &rest arg-types) &rest args)
416   `(syscall* (,name ,@arg-types) (values t 0) ,@args))
417
418 (defun get-last-error-message (err)
419   "http://msdn.microsoft.com/library/default.asp?url=/library/en-us/debug/base/retrieving_the_last_error_code.asp"
420   (with-alien ((amsg (* char)))
421     (syscall (("FormatMessage" 28 t)
422               dword dword dword dword dword (* (* char)) dword dword)
423              (cast-and-free amsg :free-function local-free)
424              (logior FORMAT_MESSAGE_ALLOCATE_BUFFER FORMAT_MESSAGE_FROM_SYSTEM)
425              0 err 0 (addr amsg) 0 0)))
426
427 (defmacro win32-error (func-name &optional err)
428   `(let ((err-code ,(or err `(get-last-error))))
429      (declare (type (unsigned-byte 32) err-code))
430      (error "~%Win32 Error [~A] - ~A~%~A"
431             ,func-name
432             err-code
433             (get-last-error-message err-code))))
434
435 (defun get-folder-pathname (csidl)
436   "http://msdn.microsoft.com/library/en-us/shellcc/platform/shell/reference/functions/shgetfolderpath.asp"
437   (with-alien ((apath (* char) (make-system-buffer (1+ max_path))))
438     (syscall (("SHGetFolderPath" 20 t) int handle int handle dword (* char))
439              (parse-native-namestring
440                (concatenate 'string (cast-and-free apath) "\\"))
441              0 csidl 0 0 apath)))
442
443 (defun sb!unix:posix-getcwd ()
444   (with-alien ((apath (* char) (make-system-buffer (1+ max_path))))
445     (with-sysfun (afunc ("GetCurrentDirectory" 8 t) dword dword (* char))
446       (let ((ret (alien-funcall afunc (1+ max_path) apath)))
447         (when (zerop ret)
448           (win32-error "GetCurrentDirectory"))
449         (when (> ret (1+ max_path))
450           (free-alien apath)
451           (setf apath (make-system-buffer ret))
452           (alien-funcall afunc ret apath))
453         (cast-and-free apath)))))
454
455 (defun sb!unix:unix-mkdir (name mode)
456   (declare (type sb!unix:unix-pathname name)
457            (type sb!unix:unix-file-mode mode)
458            (ignore mode))
459   (void-syscall* (("CreateDirectory" 8 t) system-string dword) name 0))
460
461 (defun sb!unix:unix-rename (name1 name2)
462   (declare (type sb!unix:unix-pathname name1 name2))
463   (void-syscall* (("MoveFile" 8 t) system-string system-string) name1 name2))
464
465 (defun sb!unix::posix-getenv (name)
466   (declare (type simple-string name))
467   (with-alien ((aenv (* char) (make-system-buffer default-environment-length)))
468     (with-sysfun (afunc ("GetEnvironmentVariable" 12 t)
469                         dword system-string (* char) dword)
470       (let ((ret (alien-funcall afunc name aenv default-environment-length)))
471         (when (> ret default-environment-length)
472           (free-alien aenv)
473           (setf aenv (make-system-buffer ret))
474           (alien-funcall afunc name aenv ret))
475         (if (> ret 0)
476             (cast-and-free aenv)
477             (free-alien aenv))))))
478
479 ;; GET-CURRENT-PROCESS
480 ;; The GetCurrentProcess function retrieves a pseudo handle for the current
481 ;; process.
482 ;;
483 ;; http://msdn.microsoft.com/library/en-us/dllproc/base/getcurrentprocess.asp
484 (declaim (inline get-current-process))
485 (define-alien-routine ("GetCurrentProcess@0" get-current-process) handle)
486
487 ;;;; Process time information
488
489 (defconstant 100ns-per-internal-time-unit
490   (/ 10000000 sb!xc:internal-time-units-per-second))
491
492 ;; FILETIME
493 ;; The FILETIME structure is a 64-bit value representing the number of
494 ;; 100-nanosecond intervals since January 1, 1601 (UTC).
495 ;;
496 ;; http://msdn.microsoft.com/library/en-us/sysinfo/base/filetime_str.asp?
497 (define-alien-type FILETIME (sb!alien:unsigned 64))
498
499 (defmacro with-process-times ((creation-time exit-time kernel-time user-time)
500                               &body forms)
501   `(with-alien ((,creation-time filetime)
502                 (,exit-time filetime)
503                 (,kernel-time filetime)
504                 (,user-time filetime))
505      (syscall* (("GetProcessTimes" 20) handle (* filetime) (* filetime)
506                 (* filetime) (* filetime))
507                (progn ,@forms)
508                (get-current-process)
509                (addr ,creation-time)
510                (addr ,exit-time)
511                (addr ,kernel-time)
512                (addr ,user-time))))
513
514 (declaim (inline system-internal-real-time))
515
516 (let ((epoch 0))
517   (declare (unsigned-byte epoch))
518   ;; FIXME: For optimization ideas see the unix implementation.
519   (defun reinit-internal-real-time ()
520     (setf epoch 0
521           epoch (get-internal-real-time)))
522   (defun get-internal-real-time ()
523     (- (with-alien ((system-time filetime))
524          (syscall (("GetSystemTimeAsFileTime" 4) void (* filetime))
525                   (values (floor system-time 100ns-per-internal-time-unit))
526                   (addr system-time)))
527        epoch)))
528
529 (defun system-internal-run-time ()
530   (with-process-times (creation-time exit-time kernel-time user-time)
531     (values (floor (+ user-time kernel-time) 100ns-per-internal-time-unit))))
532
533 (define-alien-type hword (unsigned 16))
534
535 (define-alien-type systemtime
536     (struct systemtime
537             (year hword)
538             (month hword)
539             (weekday hword)
540             (day hword)
541             (hour hword)
542             (minute hword)
543             (second hword)
544             (millisecond hword)))
545
546 ;; Obtained with, but the XC can't deal with that -- but
547 ;; it's not like the value is ever going to change...
548 ;; (with-alien ((filetime filetime)
549 ;;              (epoch systemtime))
550 ;;   (setf (slot epoch 'year) 1970
551 ;;         (slot epoch 'month) 1
552 ;;         (slot epoch 'day) 1
553 ;;         (slot epoch 'hour) 0
554 ;;         (slot epoch 'minute) 0
555 ;;         (slot epoch 'second) 0
556 ;;         (slot epoch 'millisecond) 0)
557 ;;   (syscall (("SystemTimeToFileTime" 8) void
558 ;;             (* systemtime) (* filetime))
559 ;;            filetime
560 ;;            (addr epoch)
561 ;;            (addr filetime)))
562 (defconstant +unix-epoch-filetime+ 116444736000000000)
563
564 #!-sb-fluid
565 (declaim (inline get-time-of-day))
566 (defun get-time-of-day ()
567   "Return the number of seconds and microseconds since the beginning of the
568 UNIX epoch: January 1st 1970."
569   (with-alien ((system-time filetime))
570     (syscall (("GetSystemTimeAsFileTime" 4) void (* filetime))
571              (multiple-value-bind (sec 100ns)
572                  (floor (- system-time +unix-epoch-filetime+)
573                         (* 100ns-per-internal-time-unit
574                            internal-time-units-per-second))
575                (values sec (floor 100ns 10)))
576              (addr system-time))))
577
578 ;; SETENV
579 ;; The SetEnvironmentVariable function sets the contents of the specified
580 ;; environment variable for the current process.
581 ;;
582 ;; http://msdn.microsoft.com/library/en-us/dllproc/base/setenvironmentvariable.asp
583 (defun setenv (name value)
584   (declare (type simple-string name value))
585   (void-syscall* (("SetEnvironmentVariable" 8 t) system-string system-string)
586                  name value))
587
588 (defmacro c-sizeof (s)
589   "translate alien size (in bits) to c-size (in bytes)"
590   `(/ (alien-size ,s) 8))
591
592 ;; OSVERSIONINFO
593 ;; The OSVERSIONINFO data structure contains operating system version
594 ;; information. The information includes major and minor version numbers,
595 ;; a build number, a platform identifier, and descriptive text about
596 ;; the operating system. This structure is used with the GetVersionEx function.
597 ;;
598 ;; http://msdn.microsoft.com/library/en-us/sysinfo/base/osversioninfo_str.asp
599 (define-alien-type nil
600   (struct OSVERSIONINFO
601     (dwOSVersionInfoSize dword)
602     (dwMajorVersion dword)
603     (dwMinorVersion dword)
604     (dwBuildNumber dword)
605     (dwPlatformId dword)
606     (szCSDVersion (array char #!-sb-unicode 128 #!+sb-unicode 256))))
607
608 (defun get-version-ex ()
609   (with-alien ((info (struct OSVERSIONINFO)))
610     (setf (slot info 'dwOSVersionInfoSize) (c-sizeof (struct OSVERSIONINFO)))
611     (syscall* (("GetVersionEx" 4 t) (* (struct OSVERSIONINFO)))
612               (values (slot info 'dwMajorVersion)
613                       (slot info 'dwMinorVersion)
614                       (slot info 'dwBuildNumber)
615                       (slot info 'dwPlatformId)
616                       (cast (slot info 'szCSDVersion) system-string))
617               (addr info))))
618
619 ;; GET-COMPUTER-NAME
620 ;; The GetComputerName function retrieves the NetBIOS name of the local
621 ;; computer. This name is established at system startup, when the system
622 ;; reads it from the registry.
623 ;;
624 ;; http://msdn.microsoft.com/library/en-us/sysinfo/base/getcomputername.asp
625 (declaim (ftype (function () simple-string) get-computer-name))
626 (defun get-computer-name ()
627   (with-alien ((aname (* char) (make-system-buffer (1+ MAX_COMPUTERNAME_LENGTH)))
628                (length dword (1+ MAX_COMPUTERNAME_LENGTH)))
629     (with-sysfun (afunc ("GetComputerName" 8 t) bool (* char) (* dword))
630       (when (zerop (alien-funcall afunc aname (addr length)))
631         (let ((err (get-last-error)))
632           (unless (= err ERROR_BUFFER_OVERFLOW)
633             (win32-error "GetComputerName" err))
634           (free-alien aname)
635           (setf aname (make-system-buffer length))
636           (alien-funcall afunc aname (addr length))))
637       (cast-and-free aname))))