+ (declaim (ftype (function () keyword) oem-codepage))
+ (defun oem-codepage ()
+ (or *oem-codepage*
+ (setq *oem-codepage*
+ (gethash (alien-funcall (extern-alien "GetOEMCP@0" (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@0" (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@0" (function UINT)))
+ *codepage-to-external-format*)
+ :latin-1))
+
+(define-alien-routine ("LocalFree@4" 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 (l 0) c) ,description
+ (format nil "~A~A~A" s
+ (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
+;;; 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" 28 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-pathname (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" 20 t) int handle int handle dword (* char))
+ (parse-native-namestring
+ (concatenate 'string (cast-and-free apath) "\\"))
+ 0 csidl 0 0 apath)))
+
+(defun sb!unix:posix-getcwd ()
+ (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-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" 8 t) system-string dword) name 0))
+
+(defun sb!unix:unix-rename (name1 name2)
+ (declare (type sb!unix:unix-pathname name1 name2))
+ (void-syscall* (("MoveFile" 8 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" 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-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@0" 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" 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 og 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
+;; 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" 8 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" 4 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" 8 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))))