[f05756]: src / code / win32.lisp Maximize Restore History

Download this file

win32.lisp    916 lines (820 with data), 36.0 kB

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
;;;; This file contains Win32 support routines that SBCL needs to
;;;; implement itself, in addition to those that apply to Win32 in
;;;; unix.lisp. In theory, some of these functions might someday be
;;;; useful to the end user.
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!WIN32")
;;; Alien definitions for commonly used Win32 types. Woe unto whoever
;;; tries to untangle this someday for 64-bit Windows.
;;;
;;; FIXME: There used to be many more here, which are now groveled,
;;; but groveling HANDLE makes it unsigned, which currently breaks the
;;; build. --NS 2006-06-18
(define-alien-type handle int-ptr)
(define-alien-type lispbool (boolean 32))
(define-alien-type system-string
#!-sb-unicode c-string
#!+sb-unicode (c-string :external-format :ucs-2))
(defconstant default-environment-length 1024)
;;; HANDLEs are actually pointers, but an invalid handle is -1 cast
;;; to a pointer.
(defconstant invalid-handle -1)
;;;; Error Handling
;;; Retrieve the calling thread's last-error code value. The
;;; last-error code is maintained on a per-thread basis.
(define-alien-routine ("GetLastError" get-last-error) dword)
;;; Flag constants for FORMAT-MESSAGE.
(defconstant format-message-from-system #x1000)
;;; Format an error message based on a lookup table. See MSDN for the
;;; full meaning of the all options---most are not used when getting
;;; system error codes.
(define-alien-routine ("FormatMessageA" format-message) dword
(flags dword)
(source (* t))
(message-id dword)
(language-id dword)
(buffer c-string)
(size dword)
(arguments (* t)))
;;;; File Handles
;;; Get the operating system handle for a C file descriptor. Returns
;;; INVALID-HANDLE on failure.
(define-alien-routine ("_get_osfhandle" get-osfhandle) handle
(fd int))
;;; Read data from a file handle into a buffer. This may be used
;;; synchronously or with "overlapped" (asynchronous) I/O.
(define-alien-routine ("ReadFile" read-file) bool
(file handle)
(buffer (* t))
(bytes-to-read dword)
(bytes-read (* dword))
(overlapped (* t)))
;;; Write data from a buffer to a file handle. This may be used
;;; synchronously or with "overlapped" (asynchronous) I/O.
(define-alien-routine ("WriteFile" write-file) bool
(file handle)
(buffer (* t))
(bytes-to-write dword)
(bytes-written (* dword))
(overlapped (* t)))
;;; Copy data from a named or anonymous pipe into a buffer without
;;; removing it from the pipe. BUFFER, BYTES-READ, BYTES-AVAIL, and
;;; BYTES-LEFT-THIS-MESSAGE may be NULL if no data is to be read.
;;; Return TRUE on success, FALSE on failure.
(define-alien-routine ("PeekNamedPipe" peek-named-pipe) bool
(pipe handle)
(buffer (* t))
(buffer-size dword)
(bytes-read (* dword))
(bytes-avail (* dword))
(bytes-left-this-message (* dword)))
;;; Flush the console input buffer if HANDLE is a console handle.
;;; Returns true on success, false if the handle does not refer to a
;;; console.
(define-alien-routine ("FlushConsoleInputBuffer" flush-console-input-buffer) bool
(handle handle))
;;; Read data from the console input buffer without removing it,
;;; without blocking. Buffer should be large enough for LENGTH *
;;; INPUT-RECORD-SIZE bytes.
(define-alien-routine ("PeekConsoleInputA" peek-console-input) bool
(handle handle)
(buffer (* t))
(length dword)
(nevents (* dword)))
;;; Listen for input on a Windows file handle. Unlike UNIX, there
;;; isn't a unified interface to do this---we have to know what sort
;;; of handle we have. Of course, there's no way to actually
;;; introspect it, so we have to try various things until we find
;;; something that works. Returns true if there could be input
;;; available, or false if there is not.
(defun handle-listen (handle)
(with-alien ((avail dword)
(buf (array char #.input-record-size)))
(when
;; Make use of the fact that console handles are technically no
;; real handles, and unlike those, have these bits set:
(= 3 (logand 3 handle))
(return-from handle-listen
(alien-funcall (extern-alien "win32_tty_listen"
(function boolean handle))
handle)))
(unless (zerop (peek-named-pipe handle nil 0 nil (addr avail) nil))
(return-from handle-listen (plusp avail)))
(unless (zerop (peek-console-input handle
(cast buf (* t))
1 (addr avail)))
(return-from handle-listen (plusp avail)))
;; FIXME-SOCKETS: Try again here with WSAEventSelect in case
;; HANDLE is a socket.
t))
;;; Listen for input on a C runtime file handle. Returns true if
;;; there could be input available, or false if there is not.
(defun fd-listen (fd)
(let ((handle (get-osfhandle fd)))
(if handle
(handle-listen handle)
t)))
;;; Clear all available input from a file handle.
(defun handle-clear-input (handle)
(flush-console-input-buffer handle)
(with-alien ((buf (array char 1024))
(count dword))
(loop
(unless (handle-listen handle)
(return))
(when (zerop (read-file handle (cast buf (* t)) 1024 (addr count) nil))
(return))
(when (< count 1024)
(return)))))
;;; Clear all available input from a C runtime file handle.
(defun fd-clear-input (fd)
(let ((handle (get-osfhandle fd)))
(when handle
(handle-clear-input handle))))
;;;; System Functions
#!-sb-thread
(define-alien-routine ("Sleep" millisleep) void
(milliseconds dword))
#!+sb-thread
(defun sb!unix:nanosleep (sec nsec)
(let ((*allow-with-interrupts* *interrupts-enabled*))
(without-interrupts
(let ((timer (sb!impl::os-create-wtimer)))
(sb!impl::os-set-wtimer timer sec nsec)
(unwind-protect
(do () ((with-local-interrupts
(zerop (sb!impl::os-wait-for-wtimer timer)))))
(sb!impl::os-close-wtimer timer))))))
#!+sb-unicode
(progn
(defvar *ansi-codepage* nil)
(defvar *oem-codepage* nil)
(defvar *codepage-to-external-format* (make-hash-table)))
#!+sb-unicode
(dolist
(cp '(;;037 IBM EBCDIC - U.S./Canada
(437 :CP437) ;; OEM - United States
;;500 IBM EBCDIC - International
;;708 Arabic - ASMO 708
;;709 Arabic - ASMO 449+, BCON V4
;;710 Arabic - Transparent Arabic
;;720 Arabic - Transparent ASMO
;;737 OEM - Greek (formerly 437G)
;;775 OEM - Baltic
(850 :CP850) ;; OEM - Multilingual Latin I
(852 :CP852) ;; OEM - Latin II
(855 :CP855) ;; OEM - Cyrillic (primarily Russian)
(857 :CP857) ;; OEM - Turkish
;;858 OEM - Multilingual Latin I + Euro symbol
(860 :CP860) ;; OEM - Portuguese
(861 :CP861) ;; OEM - Icelandic
(862 :CP862) ;; OEM - Hebrew
(863 :CP863) ;; OEM - Canadian-French
(864 :CP864) ;; OEM - Arabic
(865 :CP865) ;; OEM - Nordic
(866 :CP866) ;; OEM - Russian
(869 :CP869) ;; OEM - Modern Greek
;;870 IBM EBCDIC - Multilingual/ROECE (Latin-2)
(874 :CP874) ;; ANSI/OEM - Thai (same as 28605, ISO 8859-15)
;;875 IBM EBCDIC - Modern Greek
(932 :CP932) ;; ANSI/OEM - Japanese, Shift-JIS
;;936 ANSI/OEM - Simplified Chinese (PRC, Singapore)
;;949 ANSI/OEM - Korean (Unified Hangul Code)
;;950 ANSI/OEM - Traditional Chinese (Taiwan; Hong Kong SAR, PRC)
;;1026 IBM EBCDIC - Turkish (Latin-5)
;;1047 IBM EBCDIC - Latin 1/Open System
;;1140 IBM EBCDIC - U.S./Canada (037 + Euro symbol)
;;1141 IBM EBCDIC - Germany (20273 + Euro symbol)
;;1142 IBM EBCDIC - Denmark/Norway (20277 + Euro symbol)
;;1143 IBM EBCDIC - Finland/Sweden (20278 + Euro symbol)
;;1144 IBM EBCDIC - Italy (20280 + Euro symbol)
;;1145 IBM EBCDIC - Latin America/Spain (20284 + Euro symbol)
;;1146 IBM EBCDIC - United Kingdom (20285 + Euro symbol)
;;1147 IBM EBCDIC - France (20297 + Euro symbol)
;;1148 IBM EBCDIC - International (500 + Euro symbol)
;;1149 IBM EBCDIC - Icelandic (20871 + Euro symbol)
(1200 :UCS-2LE) ;; Unicode UCS-2 Little-Endian (BMP of ISO 10646)
(1201 :UCS-2BE) ;; Unicode UCS-2 Big-Endian
(1250 :CP1250) ;; ANSI - Central European
(1251 :CP1251) ;; ANSI - Cyrillic
(1252 :CP1252) ;; ANSI - Latin I
(1253 :CP1253) ;; ANSI - Greek
(1254 :CP1254) ;; ANSI - Turkish
(1255 :CP1255) ;; ANSI - Hebrew
(1256 :CP1256) ;; ANSI - Arabic
(1257 :CP1257) ;; ANSI - Baltic
(1258 :CP1258) ;; ANSI/OEM - Vietnamese
;;1361 Korean (Johab)
;;10000 MAC - Roman
;;10001 MAC - Japanese
;;10002 MAC - Traditional Chinese (Big5)
;;10003 MAC - Korean
;;10004 MAC - Arabic
;;10005 MAC - Hebrew
;;10006 MAC - Greek I
(10007 :X-MAC-CYRILLIC) ;; MAC - Cyrillic
;;10008 MAC - Simplified Chinese (GB 2312)
;;10010 MAC - Romania
;;10017 MAC - Ukraine
;;10021 MAC - Thai
;;10029 MAC - Latin II
;;10079 MAC - Icelandic
;;10081 MAC - Turkish
;;10082 MAC - Croatia
;;12000 Unicode UCS-4 Little-Endian
;;12001 Unicode UCS-4 Big-Endian
;;20000 CNS - Taiwan
;;20001 TCA - Taiwan
;;20002 Eten - Taiwan
;;20003 IBM5550 - Taiwan
;;20004 TeleText - Taiwan
;;20005 Wang - Taiwan
;;20105 IA5 IRV International Alphabet No. 5 (7-bit)
;;20106 IA5 German (7-bit)
;;20107 IA5 Swedish (7-bit)
;;20108 IA5 Norwegian (7-bit)
;;20127 US-ASCII (7-bit)
;;20261 T.61
;;20269 ISO 6937 Non-Spacing Accent
;;20273 IBM EBCDIC - Germany
;;20277 IBM EBCDIC - Denmark/Norway
;;20278 IBM EBCDIC - Finland/Sweden
;;20280 IBM EBCDIC - Italy
;;20284 IBM EBCDIC - Latin America/Spain
;;20285 IBM EBCDIC - United Kingdom
;;20290 IBM EBCDIC - Japanese Katakana Extended
;;20297 IBM EBCDIC - France
;;20420 IBM EBCDIC - Arabic
;;20423 IBM EBCDIC - Greek
;;20424 IBM EBCDIC - Hebrew
;;20833 IBM EBCDIC - Korean Extended
;;20838 IBM EBCDIC - Thai
(20866 :KOI8-R) ;; Russian - KOI8-R
;;20871 IBM EBCDIC - Icelandic
;;20880 IBM EBCDIC - Cyrillic (Russian)
;;20905 IBM EBCDIC - Turkish
;;20924 IBM EBCDIC - Latin-1/Open System (1047 + Euro symbol)
;;20932 JIS X 0208-1990 & 0121-1990
;;20936 Simplified Chinese (GB2312)
;;21025 IBM EBCDIC - Cyrillic (Serbian, Bulgarian)
;;21027 (deprecated)
(21866 :KOI8-U) ;; Ukrainian (KOI8-U)
(28591 :LATIN-1) ;; ISO 8859-1 Latin I
(28592 :ISO-8859-2) ;; ISO 8859-2 Central Europe
(28593 :ISO-8859-3) ;; ISO 8859-3 Latin 3
(28594 :ISO-8859-4) ;; ISO 8859-4 Baltic
(28595 :ISO-8859-5) ;; ISO 8859-5 Cyrillic
(28596 :ISO-8859-6) ;; ISO 8859-6 Arabic
(28597 :ISO-8859-7) ;; ISO 8859-7 Greek
(28598 :ISO-8859-8) ;; ISO 8859-8 Hebrew
(28599 :ISO-8859-9) ;; ISO 8859-9 Latin 5
(28605 :LATIN-9) ;; ISO 8859-15 Latin 9
;;29001 Europa 3
(38598 :ISO-8859-8) ;; ISO 8859-8 Hebrew
;;50220 ISO 2022 Japanese with no halfwidth Katakana
;;50221 ISO 2022 Japanese with halfwidth Katakana
;;50222 ISO 2022 Japanese JIS X 0201-1989
;;50225 ISO 2022 Korean
;;50227 ISO 2022 Simplified Chinese
;;50229 ISO 2022 Traditional Chinese
;;50930 Japanese (Katakana) Extended
;;50931 US/Canada and Japanese
;;50933 Korean Extended and Korean
;;50935 Simplified Chinese Extended and Simplified Chinese
;;50936 Simplified Chinese
;;50937 US/Canada and Traditional Chinese
;;50939 Japanese (Latin) Extended and Japanese
(51932 :EUC-JP) ;; EUC - Japanese
;;51936 EUC - Simplified Chinese
;;51949 EUC - Korean
;;51950 EUC - Traditional Chinese
;;52936 HZ-GB2312 Simplified Chinese
;;54936 Windows XP: GB18030 Simplified Chinese (4 Byte)
;;57002 ISCII Devanagari
;;57003 ISCII Bengali
;;57004 ISCII Tamil
;;57005 ISCII Telugu
;;57006 ISCII Assamese
;;57007 ISCII Oriya
;;57008 ISCII Kannada
;;57009 ISCII Malayalam
;;57010 ISCII Gujarati
;;57011 ISCII Punjabi
;;65000 Unicode UTF-7
(65001 :UTF8))) ;; Unicode UTF-8
(setf (gethash (car cp) *codepage-to-external-format*) (cadr cp)))
#!+sb-unicode
;; FIXME: Something odd here: why are these two #+SB-UNICODE, whereas
;; the console just behave differently?
(progn
(declaim (ftype (function () keyword) ansi-codepage))
(defun ansi-codepage ()
(or *ansi-codepage*
(setq *ansi-codepage*
(gethash (alien-funcall (extern-alien "GetACP" (function UINT)))
*codepage-to-external-format*
:latin-1))))
(declaim (ftype (function () keyword) oem-codepage))
(defun oem-codepage ()
(or *oem-codepage*
(setq *oem-codepage*
(gethash (alien-funcall (extern-alien "GetOEMCP" (function UINT)))
*codepage-to-external-format*
:latin-1)))))
;; http://msdn.microsoft.com/library/en-us/dllproc/base/getconsolecp.asp
(declaim (ftype (function () keyword) console-input-codepage))
(defun console-input-codepage ()
(or #!+sb-unicode
(gethash (alien-funcall (extern-alien "GetConsoleCP" (function UINT)))
*codepage-to-external-format*)
:latin-1))
;; http://msdn.microsoft.com/library/en-us/dllproc/base/getconsoleoutputcp.asp
(declaim (ftype (function () keyword) console-output-codepage))
(defun console-output-codepage ()
(or #!+sb-unicode
(gethash (alien-funcall
(extern-alien "GetConsoleOutputCP" (function UINT)))
*codepage-to-external-format*)
:latin-1))
(define-alien-routine ("LocalFree" local-free) void
(lptr (* t)))
(defmacro cast-and-free (value &key (type 'system-string)
(free-function 'free-alien))
`(prog1 (cast ,value ,type)
(,free-function ,value)))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defmacro with-funcname ((name description) &body body)
`(let
((,name (etypecase ,description
(string ,description)
(cons (destructuring-bind (s &optional c) ,description
(format nil "~A~A" s
(if c #!-sb-unicode "A" #!+sb-unicode "W" "")))))))
,@body)))
(defmacro make-system-buffer (x)
`(make-alien char #!+sb-unicode (ash ,x 1) #!-sb-unicode ,x))
;;; FIXME: The various FOO-SYSCALL-BAR macros, and perhaps some other
;;; macros in this file, are only used in this file, and could be
;;; implemented using SB!XC:DEFMACRO wrapped in EVAL-WHEN.
(defmacro syscall ((name ret-type &rest arg-types) success-form &rest args)
(with-funcname (sname name)
`(locally
(declare (optimize (sb!c::float-accuracy 0)))
(let ((result (alien-funcall
(extern-alien ,sname
(function ,ret-type ,@arg-types))
,@args)))
(declare (ignorable result))
,success-form))))
;;; This is like SYSCALL, but if it fails, signal an error instead of
;;; returning error codes. Should only be used for syscalls that will
;;; never really get an error.
(defmacro syscall* ((name &rest arg-types) success-form &rest args)
(with-funcname (sname name)
`(locally
(declare (optimize (sb!c::float-accuracy 0)))
(let ((result (alien-funcall
(extern-alien ,sname (function bool ,@arg-types))
,@args)))
(when (zerop result)
(win32-error ,sname))
,success-form))))
(defmacro with-sysfun ((func name ret-type &rest arg-types) &body body)
(with-funcname (sname name)
`(with-alien ((,func (function ,ret-type ,@arg-types)
:extern ,sname))
,@body)))
(defmacro void-syscall* ((name &rest arg-types) &rest args)
`(syscall* (,name ,@arg-types) (values t 0) ,@args))
(defun get-last-error-message (err)
"http://msdn.microsoft.com/library/default.asp?url=/library/en-us/debug/base/retrieving_the_last_error_code.asp"
(with-alien ((amsg (* char)))
(syscall (("FormatMessage" t)
dword dword dword dword dword (* (* char)) dword dword)
(cast-and-free amsg :free-function local-free)
(logior FORMAT_MESSAGE_ALLOCATE_BUFFER FORMAT_MESSAGE_FROM_SYSTEM)
0 err 0 (addr amsg) 0 0)))
(defmacro win32-error (func-name &optional err)
`(let ((err-code ,(or err `(get-last-error))))
(declare (type (unsigned-byte 32) err-code))
(error "~%Win32 Error [~A] - ~A~%~A"
,func-name
err-code
(get-last-error-message err-code))))
(defun get-folder-namestring (csidl)
"http://msdn.microsoft.com/library/en-us/shellcc/platform/shell/reference/functions/shgetfolderpath.asp"
(with-alien ((apath (* char) (make-system-buffer (1+ max_path))))
(syscall (("SHGetFolderPath" t) int handle int handle dword (* char))
(concatenate 'string (cast-and-free apath) "\\")
0 csidl 0 0 apath)))
(defun get-folder-pathname (csidl)
(parse-native-namestring (get-folder-namestring csidl)))
(defun sb!unix:posix-getcwd ()
(with-alien ((apath (* char) (make-system-buffer (1+ max_path))))
(with-sysfun (afunc ("GetCurrentDirectory" t) dword dword (* char))
(let ((ret (alien-funcall afunc (1+ max_path) apath)))
(when (zerop ret)
(win32-error "GetCurrentDirectory"))
(when (> ret (1+ max_path))
(free-alien apath)
(setf apath (make-system-buffer ret))
(alien-funcall afunc ret apath))
(cast-and-free apath)))))
(defun sb!unix:unix-mkdir (name mode)
(declare (type sb!unix:unix-pathname name)
(type sb!unix:unix-file-mode mode)
(ignore mode))
(void-syscall* (("CreateDirectory" t) system-string dword) name 0))
(defun sb!unix:unix-rename (name1 name2)
(declare (type sb!unix:unix-pathname name1 name2))
(void-syscall* (("MoveFile" t) system-string system-string) name1 name2))
(defun sb!unix::posix-getenv (name)
(declare (type simple-string name))
(with-alien ((aenv (* char) (make-system-buffer default-environment-length)))
(with-sysfun (afunc ("GetEnvironmentVariable" t)
dword system-string (* char) dword)
(let ((ret (alien-funcall afunc name aenv default-environment-length)))
(when (> ret default-environment-length)
(free-alien aenv)
(setf aenv (make-system-buffer ret))
(alien-funcall afunc name aenv ret))
(if (> ret 0)
(cast-and-free aenv)
(free-alien aenv))))))
;; GET-CURRENT-PROCESS
;; The GetCurrentProcess function retrieves a pseudo handle for the current
;; process.
;;
;; http://msdn.microsoft.com/library/en-us/dllproc/base/getcurrentprocess.asp
(declaim (inline get-current-process))
(define-alien-routine ("GetCurrentProcess" get-current-process) handle)
;;;; Process time information
(defconstant 100ns-per-internal-time-unit
(/ 10000000 sb!xc:internal-time-units-per-second))
;; FILETIME
;; The FILETIME structure is a 64-bit value representing the number of
;; 100-nanosecond intervals since January 1, 1601 (UTC).
;;
;; http://msdn.microsoft.com/library/en-us/sysinfo/base/filetime_str.asp?
(define-alien-type FILETIME (sb!alien:unsigned 64))
(defmacro with-process-times ((creation-time exit-time kernel-time user-time)
&body forms)
`(with-alien ((,creation-time filetime)
(,exit-time filetime)
(,kernel-time filetime)
(,user-time filetime))
(syscall* (("GetProcessTimes") handle (* filetime) (* filetime)
(* filetime) (* filetime))
(progn ,@forms)
(get-current-process)
(addr ,creation-time)
(addr ,exit-time)
(addr ,kernel-time)
(addr ,user-time))))
(declaim (inline system-internal-real-time))
(let ((epoch 0))
(declare (unsigned-byte epoch))
;; FIXME: For optimization ideas see the unix implementation.
(defun reinit-internal-real-time ()
(setf epoch 0
epoch (get-internal-real-time)))
(defun get-internal-real-time ()
(- (with-alien ((system-time filetime))
(syscall (("GetSystemTimeAsFileTime") void (* filetime))
(values (floor system-time 100ns-per-internal-time-unit))
(addr system-time)))
epoch)))
(defun system-internal-run-time ()
(with-process-times (creation-time exit-time kernel-time user-time)
(values (floor (+ user-time kernel-time) 100ns-per-internal-time-unit))))
(define-alien-type hword (unsigned 16))
(define-alien-type systemtime
(struct systemtime
(year hword)
(month hword)
(weekday hword)
(day hword)
(hour hword)
(minute hword)
(second hword)
(millisecond hword)))
;; Obtained with, but the XC can't deal with that -- but
;; it's not like the value is ever going to change...
;; (with-alien ((filetime filetime)
;; (epoch systemtime))
;; (setf (slot epoch 'year) 1970
;; (slot epoch 'month) 1
;; (slot epoch 'day) 1
;; (slot epoch 'hour) 0
;; (slot epoch 'minute) 0
;; (slot epoch 'second) 0
;; (slot epoch 'millisecond) 0)
;; (syscall (("SystemTimeToFileTime" 8) void
;; (* systemtime) (* filetime))
;; filetime
;; (addr epoch)
;; (addr filetime)))
(defconstant +unix-epoch-filetime+ 116444736000000000)
#!-sb-fluid
(declaim (inline get-time-of-day))
(defun get-time-of-day ()
"Return the number of seconds and microseconds since the beginning of the
UNIX epoch: January 1st 1970."
(with-alien ((system-time filetime))
(syscall (("GetSystemTimeAsFileTime") void (* filetime))
(multiple-value-bind (sec 100ns)
(floor (- system-time +unix-epoch-filetime+)
(* 100ns-per-internal-time-unit
internal-time-units-per-second))
(values sec (floor 100ns 10)))
(addr system-time))))
;; SETENV
;; The SetEnvironmentVariable function sets the contents of the specified
;; environment variable for the current process.
;;
;; http://msdn.microsoft.com/library/en-us/dllproc/base/setenvironmentvariable.asp
(defun setenv (name value)
(declare (type simple-string name value))
(void-syscall* (("SetEnvironmentVariable" t) system-string system-string)
name value))
(defmacro c-sizeof (s)
"translate alien size (in bits) to c-size (in bytes)"
`(/ (alien-size ,s) 8))
;; OSVERSIONINFO
;; The OSVERSIONINFO data structure contains operating system version
;; information. The information includes major and minor version numbers,
;; a build number, a platform identifier, and descriptive text about
;; the operating system. This structure is used with the GetVersionEx function.
;;
;; http://msdn.microsoft.com/library/en-us/sysinfo/base/osversioninfo_str.asp
(define-alien-type nil
(struct OSVERSIONINFO
(dwOSVersionInfoSize dword)
(dwMajorVersion dword)
(dwMinorVersion dword)
(dwBuildNumber dword)
(dwPlatformId dword)
(szCSDVersion (array char #!-sb-unicode 128 #!+sb-unicode 256))))
(defun get-version-ex ()
(with-alien ((info (struct OSVERSIONINFO)))
(setf (slot info 'dwOSVersionInfoSize) (c-sizeof (struct OSVERSIONINFO)))
(syscall* (("GetVersionEx" t) (* (struct OSVERSIONINFO)))
(values (slot info 'dwMajorVersion)
(slot info 'dwMinorVersion)
(slot info 'dwBuildNumber)
(slot info 'dwPlatformId)
(cast (slot info 'szCSDVersion) system-string))
(addr info))))
;; GET-COMPUTER-NAME
;; The GetComputerName function retrieves the NetBIOS name of the local
;; computer. This name is established at system startup, when the system
;; reads it from the registry.
;;
;; http://msdn.microsoft.com/library/en-us/sysinfo/base/getcomputername.asp
(declaim (ftype (function () simple-string) get-computer-name))
(defun get-computer-name ()
(with-alien ((aname (* char) (make-system-buffer (1+ MAX_COMPUTERNAME_LENGTH)))
(length dword (1+ MAX_COMPUTERNAME_LENGTH)))
(with-sysfun (afunc ("GetComputerName" t) bool (* char) (* dword))
(when (zerop (alien-funcall afunc aname (addr length)))
(let ((err (get-last-error)))
(unless (= err ERROR_BUFFER_OVERFLOW)
(win32-error "GetComputerName" err))
(free-alien aname)
(setf aname (make-system-buffer length))
(alien-funcall afunc aname (addr length))))
(cast-and-free aname))))
(define-alien-routine ("_lseeki64" lseeki64)
(signed 64)
(fd int)
(position (signed 64))
(whence int))
(define-alien-routine ("SetFilePointerEx" set-file-pointer-ex) lispbool
(handle handle)
(offset long-long)
(new-position long-long :out)
(whence dword))
;; File mapping support routines
(define-alien-routine (#!+sb-unicode "CreateFileMappingW"
#!-sb-unicode "CreateFileMappingA"
create-file-mapping)
handle
(handle handle)
(security-attributes (* t))
(protection dword)
(maximum-size-high dword)
(maximum-size-low dword)
(name (c-string #!+sb-unicode #!+sb-unicode :external-format :ucs-2)))
(define-alien-routine ("MapViewOfFile" map-view-of-file)
system-area-pointer
(file-mapping handle)
(desired-access dword)
(offset-high dword)
(offset-low dword)
(size dword))
(define-alien-routine ("UnmapViewOfFile" unmap-view-of-file) bool
(address (* t)))
(define-alien-routine ("FlushViewOfFile" flush-view-of-file) bool
(address (* t))
(length dword))
;; Constants for CreateFile `disposition'.
(defconstant file-create-new 1)
(defconstant file-create-always 2)
(defconstant file-open-existing 3)
(defconstant file-open-always 4)
(defconstant file-truncate-existing 5)
;; access rights
(defconstant access-generic-read #x80000000)
(defconstant access-generic-write #x40000000)
(defconstant access-generic-execute #x20000000)
(defconstant access-generic-all #x10000000)
(defconstant access-file-append-data #x4)
;; share modes
(defconstant file-share-delete #x04)
(defconstant file-share-read #x01)
(defconstant file-share-write #x02)
;; CreateFile (the real file-opening workhorse)
(define-alien-routine (#!+sb-unicode "CreateFileW"
#!-sb-unicode "CreateFileA"
create-file)
handle
(name (c-string #!+sb-unicode #!+sb-unicode :external-format :ucs-2))
(desired-access dword)
(share-mode dword)
(security-attributes (* t))
(creation-disposition dword)
(flags-and-attributes dword)
(template-file handle))
(defconstant file-attribute-readonly #x1)
(defconstant file-attribute-hidden #x2)
(defconstant file-attribute-system #x4)
(defconstant file-attribute-directory #x10)
(defconstant file-attribute-archive #x20)
(defconstant file-attribute-device #x40)
(defconstant file-attribute-normal #x80)
(defconstant file-attribute-temporary #x100)
(defconstant file-attribute-sparse #x200)
(defconstant file-attribute-reparse-point #x400)
(defconstant file-attribute-reparse-compressed #x800)
(defconstant file-attribute-reparse-offline #x1000)
(defconstant file-attribute-not-content-indexed #x2000)
(defconstant file-attribute-encrypted #x4000)
(defconstant file-flag-overlapped #x40000000)
(defconstant file-flag-sequential-scan #x8000000)
;; GetFileAttribute is like a tiny subset of fstat(),
;; enough to distinguish directories from anything else.
(define-alien-routine (#!+sb-unicode "GetFileAttributesW"
#!-sb-unicode "GetFileAttributesA"
get-file-attributes)
dword
(name (c-string #!+sb-unicode #!+sb-unicode :external-format :ucs-2)))
(define-alien-routine ("CloseHandle" close-handle) bool
(handle handle))
(define-alien-routine ("_open_osfhandle" open-osfhandle)
int
(handle handle)
(flags int))
;; Intended to be an imitation of sb!unix:unix-open based on
;; CreateFile, as complete as possibly.
;; FILE_FLAG_OVERLAPPED is a must for decent I/O.
(defun unixlike-open (path flags mode &optional revertable)
(declare (type sb!unix:unix-pathname path)
(type fixnum flags)
(type sb!unix:unix-file-mode mode)
(ignorable mode))
(let* ((disposition-flags
(logior
(if (zerop (logand sb!unix:o_creat flags)) 0 #b100)
(if (zerop (logand sb!unix:o_excl flags)) 0 #b010)
(if (zerop (logand sb!unix:o_trunc flags)) 0 #b001)))
(create-disposition
;; there are 8 combinations of creat|excl|trunc, some of
;; them are equivalent. Case stmt below maps them to 5
;; dispositions (see CreateFile manual).
(case disposition-flags
((#b110 #b111) file-create-new)
((#b001 #b011) file-truncate-existing)
((#b000 #b010) file-open-existing)
(#b100 file-open-always)
(#b101 file-create-always))))
(let ((handle
(create-file path
(logior
(if revertable #x10000 0)
(if (plusp (logand sb!unix:o_append flags))
access-file-append-data
0)
(ecase (logand 3 flags)
(0 FILE_GENERIC_READ)
(1 FILE_GENERIC_WRITE)
((2 3) (logior FILE_GENERIC_READ
FILE_GENERIC_WRITE))))
(logior FILE_SHARE_READ
FILE_SHARE_WRITE)
nil
create-disposition
(logior
file-attribute-normal
file-flag-overlapped
file-flag-sequential-scan)
0)))
(if (eql handle invalid-handle)
(values nil
(let ((error-code (get-last-error)))
(case error-code
(#.error_file_not_found
sb!unix:enoent)
((#.error_already_exists #.error_file_exists)
sb!unix:eexist)
(otherwise (- error-code)))))
(progn
;; FIXME: seeking to the end is not enough for real APPEND
;; semantics, but it's better than nothing.
;; -- AK
;;
;; On the other hand, the CL spec implies the "better than
;; nothing" seek-once semantics implemented here, and our
;; POSIX backend is incorrect in implementing :APPEND as
;; O_APPEND. Other CL implementations get this right across
;; platforms.
;;
;; Of course, it would be nice if we had :IF-EXISTS
;; :ATOMICALLY-APPEND separately as an extension, and in
;; that case, we will have to worry about supporting it
;; here after all.
;;
;; I've tested this only very briefly (on XP and Windows 7),
;; but my impression is that WriteFile (without documenting
;; it?) is like ZwWriteFile, i.e. if we pass in -1 as the
;; offset in our overlapped structure, WriteFile seeks to the
;; end for us. Should we depend on that? How do we communicate
;; our desire to do so to the runtime?
;; -- DFL
;;
(set-file-pointer-ex handle 0 (if (plusp (logand sb!unix::o_append flags)) 2 0))
(let ((fd (open-osfhandle handle (logior sb!unix::o_binary flags))))
(if (minusp fd)
(values nil (sb!unix::get-errno))
(values fd 0))))))))
(define-alien-routine ("closesocket" close-socket) int (handle handle))
(define-alien-routine ("shutdown" shutdown-socket) int (handle handle)
(how int))
(define-alien-routine ("DuplicateHandle" duplicate-handle) lispbool
(from-process handle)
(from-handle handle)
(to-process handle)
(to-handle handle :out)
(access dword)
(inheritp lispbool)
(options dword))
(defconstant +handle-flag-inherit+ 1)
(defconstant +handle-flag-protect-from-close+ 2)
(define-alien-routine ("SetHandleInformation" set-handle-information) lispbool
(handle handle)
(mask dword)
(flags dword))
(define-alien-routine ("GetHandleInformation" get-handle-information) lispbool
(handle handle)
(flags dword :out))
(define-alien-routine getsockopt int
(handle handle)
(level int)
(opname int)
(dataword int-ptr :in-out)
(socklen int :in-out))
(defconstant sol_socket #xFFFF)
(defconstant so_type #x1008)
(defun socket-handle-p (handle)
(zerop (getsockopt handle sol_socket so_type 0 (alien-size int :bytes))))
(defconstant ebadf 9)
;;; For sockets, CloseHandle first and closesocket() afterwards is
;;; legal: winsock tracks its handles separately (that's why we have
;;; the problem with simple _close in the first place).
;;;
;;; ...Seems to be the problem on some OSes, though. We could
;;; duplicate a handle and attempt close-socket on a duplicated one,
;;; but it also have some problems...
;;;
;;; For now, we protect socket handle from close with SetHandleInformation,
;;; then call CRT _close() that fails to close a handle but _gets rid of fd_,
;;; and then we close a handle ourserves.
(defun unixlike-close (fd)
(let ((handle (get-osfhandle fd)))
(flet ((close-protection (enable)
(set-handle-information handle 2 (if enable 2 0))))
(if (= handle invalid-handle)
(values nil ebadf)
(progn
(when (and (socket-handle-p handle) (close-protection t))
(shutdown-socket handle 2)
(alien-funcall (extern-alien "_dup2" (function int int int)) 0 fd)
(close-protection nil)
(close-socket handle))
(sb!unix::void-syscall ("_close" int) fd))))))