1.0.11.34: better SUBSEQ on lists
[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 ;; SETENV
534 ;; The SetEnvironmentVariable function sets the contents of the specified
535 ;; environment variable for the current process.
536 ;;
537 ;; http://msdn.microsoft.com/library/en-us/dllproc/base/setenvironmentvariable.asp
538 (defun setenv (name value)
539   (declare (type simple-string name value))
540   (void-syscall* (("SetEnvironmentVariable" 8 t) system-string system-string)
541                  name value))
542
543 (defmacro c-sizeof (s)
544   "translate alien size (in bits) to c-size (in bytes)"
545   `(/ (alien-size ,s) 8))
546
547 ;; OSVERSIONINFO
548 ;; The OSVERSIONINFO data structure contains operating system version
549 ;; information. The information includes major and minor version numbers,
550 ;; a build number, a platform identifier, and descriptive text about
551 ;; the operating system. This structure is used with the GetVersionEx function.
552 ;;
553 ;; http://msdn.microsoft.com/library/en-us/sysinfo/base/osversioninfo_str.asp
554 (define-alien-type nil
555   (struct OSVERSIONINFO
556     (dwOSVersionInfoSize dword)
557     (dwMajorVersion dword)
558     (dwMinorVersion dword)
559     (dwBuildNumber dword)
560     (dwPlatformId dword)
561     (szCSDVersion (array char #!-sb-unicode 128 #!+sb-unicode 256))))
562
563 (defun get-version-ex ()
564   (with-alien ((info (struct OSVERSIONINFO)))
565     (setf (slot info 'dwOSVersionInfoSize) (c-sizeof (struct OSVERSIONINFO)))
566     (syscall* (("GetVersionEx" 4 t) (* (struct OSVERSIONINFO)))
567               (values (slot info 'dwMajorVersion)
568                       (slot info 'dwMinorVersion)
569                       (slot info 'dwBuildNumber)
570                       (slot info 'dwPlatformId)
571                       (cast (slot info 'szCSDVersion) system-string))
572               (addr info))))
573
574 ;; GET-COMPUTER-NAME
575 ;; The GetComputerName function retrieves the NetBIOS name of the local
576 ;; computer. This name is established at system startup, when the system
577 ;; reads it from the registry.
578 ;;
579 ;; http://msdn.microsoft.com/library/en-us/sysinfo/base/getcomputername.asp
580 (declaim (ftype (function () simple-string) get-computer-name))
581 (defun get-computer-name ()
582   (with-alien ((aname (* char) (make-system-buffer (1+ MAX_COMPUTERNAME_LENGTH)))
583                (length dword (1+ MAX_COMPUTERNAME_LENGTH)))
584     (with-sysfun (afunc ("GetComputerName" 8 t) bool (* char) (* dword))
585       (when (zerop (alien-funcall afunc aname (addr length)))
586         (let ((err (get-last-error)))
587           (unless (= err ERROR_BUFFER_OVERFLOW)
588             (win32-error "GetComputerName" err))
589           (free-alien aname)
590           (setf aname (make-system-buffer length))
591           (alien-funcall afunc aname (addr length))))
592       (cast-and-free aname))))