(unless (zerop (peek-console-input handle
(cast buf (* t))
- input-record-size (addr avail)))
+ 1 (addr avail)))
(return-from handle-listen (plusp avail)))
;; FIXME-SOCKETS: Try again here with WSAEventSelect in case
;;870 IBM EBCDIC - Multilingual/ROECE (Latin-2)
(874 :CP874) ;; ANSI/OEM - Thai (same as 28605, ISO 8859-15)
;;875 IBM EBCDIC - Modern Greek
- ;;932 ANSI/OEM - Japanese, Shift-JIS
+ (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)
(string ,description)
(cons (destructuring-bind (s &optional (l 0) c) ,description
(format nil "~A~A~A" s
- (if c #-sb-unicode "A@" #+sb-unicode "W@" "@")
+ (if c #!-sb-unicode "A@" #!+sb-unicode "W@" "@")
l))))))
,@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
err-code
(get-last-error-message err-code))))
-(defun get-folder-pathname (csidl)
+(defun get-folder-namestring (csidl)
"http://msdn.microsoft.com/library/en-us/shellcc/platform/shell/reference/functions/shgetfolderpath.asp"
- (with-alien ((apath (* char) (make-alien char (1+ max_path))))
+ (with-alien ((apath (* char) (make-system-buffer (1+ max_path))))
(syscall (("SHGetFolderPath" 20 t) int handle int handle dword (* char))
- (parse-native-namestring
- (concatenate 'string (cast-and-free apath) "\\"))
+ (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-alien char (1+ max_path))))
+ (with-alien ((apath (* char) (make-system-buffer (1+ max_path))))
(with-sysfun (afunc ("GetCurrentDirectory" 8 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-alien char ret))
+ (setf apath (make-system-buffer ret))
(alien-funcall afunc ret apath))
(cast-and-free apath)))))
(defun sb!unix::posix-getenv (name)
(declare (type simple-string name))
- (with-alien ((aenv (* char) (make-alien char default-environment-length)))
+ (with-alien ((aenv (* char) (make-system-buffer default-environment-length)))
(with-sysfun (afunc ("GetEnvironmentVariable" 12 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-alien char ret))
+ (setf aenv (make-system-buffer ret))
(alien-funcall afunc name aenv ret))
(if (> ret 0)
(cast-and-free aenv)
;;;; 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))
-(defun get-process-times ()
- (with-alien ((creation-time filetime)
- (exit-time filetime)
- (kernel-time filetime)
- (user-time filetime))
- (syscall* (("GetProcessTimes" 20) handle (* filetime) (* filetime)
- (* filetime) (* filetime))
- (values creation-time
- exit-time
- kernel-time
- user-time)
- (get-current-process)
- (addr creation-time)
- (addr exit-time)
- (addr kernel-time)
- (addr user-time))))
+(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" 20) 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" 4) 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" 4) 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
;; 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-alien char (1+ MAX_COMPUTERNAME_LENGTH)))
+ (with-alien ((aname (* char) (make-system-buffer (1+ MAX_COMPUTERNAME_LENGTH)))
(length dword (1+ MAX_COMPUTERNAME_LENGTH)))
(with-sysfun (afunc ("GetComputerName" 8 t) bool (* char) (* dword))
(when (zerop (alien-funcall afunc aname (addr length)))
(unless (= err ERROR_BUFFER_OVERFLOW)
(win32-error "GetComputerName" err))
(free-alien aname)
- (setf aname (make-alien char length))
+ (setf aname (make-system-buffer length))
(alien-funcall afunc aname (addr length))))
(cast-and-free aname))))
+
+;; 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)
+
+;; 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))