X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fwin32.lisp;h=25b00ad4e1b836bc21a98a91c2acbf647c076466;hb=3cd198ea8fb1635057038934730624e68b5da012;hp=c4b7589f47b1d98fb2804f5fa1bc76b14289dab2;hpb=fdf46e7bd7aba9b5c8af629fdb2692d9b33b9207;p=sbcl.git diff --git a/src/code/win32.lisp b/src/code/win32.lisp index c4b7589..25b00ad 100644 --- a/src/code/win32.lisp +++ b/src/code/win32.lisp @@ -18,13 +18,12 @@ ;;; tries to untangle this someday for 64-bit Windows. ;;; ;;; FIXME: There used to be many more here, which are now groveled, -;;; but TCHAR is a bit nasty as at the time grovel-headers runs -;;; the unicodeness isn't conveniently known, and HANDLE... well, -;;; groveling HANDLE makes it unsigned, which currently breaks the +;;; but groveling HANDLE makes it unsigned, which currently breaks the ;;; build. --NS 2006-06-18 (define-alien-type handle int-ptr) -(define-alien-type tchar #!+sb-unicode (sb!alien:unsigned 16) - #!-sb-unicode char) +(define-alien-type system-string + #!-sb-unicode c-string + #!+sb-unicode (c-string :external-format :ucs-2)) (defconstant default-environment-length 1024) @@ -53,10 +52,6 @@ (size dword) (arguments (* t))) -(defun get-current-process () - (alien-funcall - (extern-alien "GetCurrentProcess@0" (function long)))) - ;;;; File Handles ;;; Get the operating system handle for a C file descriptor. Returns @@ -121,9 +116,9 @@ (unless (zerop (peek-named-pipe handle nil 0 nil (addr avail) nil)) (return-from handle-listen (plusp avail))) - (unless (zerop (peek-console-input handle + (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 @@ -163,14 +158,14 @@ (define-alien-routine ("Sleep@4" millisleep) void (milliseconds dword)) -#+sb-unicode +#!+sb-unicode (progn (defvar *ansi-codepage* nil) (defvar *oem-codepage* nil) (defvar *codepage-to-external-format* (make-hash-table))) -#+sb-unicode -(dolist +#!+sb-unicode +(dolist (cp '(;;037 IBM EBCDIC - U.S./Canada (437 :CP437) ;; OEM - United States ;;500 IBM EBCDIC - International @@ -196,7 +191,7 @@ ;;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) @@ -212,8 +207,8 @@ ;;1147 IBM EBCDIC - France (20297 + Euro symbol) ;;1148 IBM EBCDIC - International (500 + Euro symbol) ;;1149 IBM EBCDIC - Icelandic (20871 + Euro symbol) - ;;1200 Unicode UCS-2 Little-Endian (BMP of ISO 10646) - ;;1201 Unicode UCS-2 Big-Endian + (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 @@ -334,7 +329,7 @@ (gethash (alien-funcall (extern-alien "GetACP@0" (function UINT))) *codepage-to-external-format* :latin-1)))) - + (declaim (ftype (function () keyword) oem-codepage)) (defun oem-codepage () (or *oem-codepage* @@ -345,7 +340,7 @@ ;; http://msdn.microsoft.com/library/en-us/dllproc/base/getconsolecp.asp (declaim (ftype (function () keyword) console-input-codepage)) -(defun console-input-codepage () +(defun console-input-codepage () (or #!+sb-unicode (gethash (alien-funcall (extern-alien "GetConsoleCP@0" (function UINT))) *codepage-to-external-format*) @@ -355,167 +350,377 @@ (declaim (ftype (function () keyword) console-output-codepage)) (defun console-output-codepage () (or #!+sb-unicode - (gethash (alien-funcall + (gethash (alien-funcall (extern-alien "GetConsoleOutputCP@0" (function UINT))) *codepage-to-external-format*) :latin-1)) -;;;; FIXME (rudi 2006-03-29): this should really be (octets-to-string -;;;; :external-format :ucs2), except that we do not have an -;;;; implementation of ucs2 yet. -(defmacro ucs2->string (astr &optional size) - #!-sb-unicode - (declare (ignore size)) - #!-sb-unicode - `(cast ,astr c-string) - #!+sb-unicode - (let ((str-len (or size `(do ((i 0 (1+ i))) ((zerop (deref ,astr i)) i))))) - `(let* ((l ,str-len) - (s (make-string l))) - (dotimes (i l) (setf (aref s i) (code-char (deref ,astr i)))) - s))) - -(defmacro ucs2->string&free (astr &optional size) - `(prog1 (ucs2->string ,astr ,size) (free-alien ,astr))) - (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 (* tchar))) - (let ((nchars - (alien-funcall - (extern-alien #!+sb-unicode "FormatMessageW@28" - #!-sb-unicode "FormatMessageA@28" - (function dword dword dword dword dword - (* (* tchar)) dword dword)) - (logior FORMAT_MESSAGE_ALLOCATE_BUFFER FORMAT_MESSAGE_FROM_SYSTEM) - 0 err 0 (addr amsg) 0 0))) - (prog1 (ucs2->string amsg nchars) - (local-free amsg))))) - -(defmacro win32-error (func-name) - `(let ((err-code (sb!win32::get-last-error))) + (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 - (sb!win32::get-last-error-message err-code)))) + (get-last-error-message err-code)))) -(defun get-folder-path (CSIDL) +(defun get-folder-namestring (csidl) "http://msdn.microsoft.com/library/en-us/shellcc/platform/shell/reference/functions/shgetfolderpath.asp" - (with-alien ((apath (* tchar) (make-alien tchar (1+ MAX_PATH)))) - (alien-funcall - (extern-alien #!-sb-unicode "SHGetFolderPathA@20" - #!+sb-unicode "SHGetFolderPathW@20" - (function int handle int handle dword (* tchar))) - 0 CSIDL 0 0 apath) - (concatenate 'string (ucs2->string&free apath) "\\"))) + (with-alien ((apath (* char) (make-system-buffer (1+ max_path)))) + (syscall (("SHGetFolderPath" 20 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 (* tchar) (make-alien tchar (1+ MAX_PATH))) - (afunc (function dword dword (* tchar)) - :extern - #!-sb-unicode "GetCurrentDirectoryA@8" - #!+sb-unicode "GetCurrentDirectoryW@8")) - (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 tchar ret)) - (alien-funcall afunc ret apath)) - (ucs2->string&free apath ret)))) + (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)) - (let ((name-length (length name))) - (with-alien ((apath (* tchar) (make-alien tchar (1+ name-length)))) - (dotimes (i name-length) (setf (deref apath i) (char-code (aref name i)))) - (setf (deref apath name-length) 0) - (when (zerop (alien-funcall - (extern-alien #!-sb-unicode "CreateDirectoryA@8" - #!+sb-unicode "CreateDirectoryW@8" - (function bool (* tchar) dword)) - apath 0)) - (win32-error "CreateDirectory")) - (values t 0)))) + (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)) - (let ((name-length1 (length name1)) - (name-length2 (length name2))) - (with-alien ((apath1 (* tchar) (make-alien tchar (1+ name-length1))) - (apath2 (* tchar) (make-alien tchar (1+ name-length2)))) - (dotimes (i name-length1) - (setf (deref apath1 i) (char-code (aref name1 i)))) - (setf (deref apath1 name-length1) 0) - (dotimes (i name-length2) - (setf (deref apath2 i) (char-code (aref name2 i)))) - (setf (deref apath2 name-length2) 0) - (when (zerop (alien-funcall - (extern-alien #!-sb-unicode "MoveFileA@8" - #!+sb-unicode "MoveFileW@8" - (function bool (* tchar) (* tchar))) - apath1 apath2)) - (win32-error "MoveFile")) - (values t 0)))) + (void-syscall* (("MoveFile" 8 t) system-string system-string) name1 name2)) (defun sb!unix::posix-getenv (name) (declare (type simple-string name)) - (let ((name-length (length name))) - (with-alien ((aname (* tchar) (make-alien tchar (1+ name-length))) - (aenv (* tchar) (make-alien tchar default-environment-length)) - (afunc (function dword (* tchar) (* tchar) dword) - :extern - #!-sb-unicode "GetEnvironmentVariableA@12" - #!+sb-unicode "GetEnvironmentVariableW@12")) - (dotimes (i name-length) - (setf (deref aname i) (char-code (aref name i)))) - (setf (deref aname name-length) 0) - (let ((ret (alien-funcall afunc aname aenv 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 tchar ret)) - (alien-funcall afunc aname aenv ret)) + (setf aenv (make-system-buffer ret)) + (alien-funcall afunc name aenv ret)) (if (> ret 0) - (ucs2->string&free aenv ret) - nil))))) + (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 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 +;; 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 filetime - (dw-low-datetime dword) - (dw-high-datetime dword))) - -(defun get-process-times () - (with-alien ((creation-time (struct filetime)) - (exit-time (struct filetime)) - (kernel-time (struct filetime)) - (user-time (struct filetime))) - (let ((result (sb!alien:alien-funcall - (extern-alien - "GetProcessTimes@20" - (function bool - handle - (* (struct filetime)) - (* (struct filetime)) - (* (struct filetime)) - (* (struct filetime)))) - (get-current-process) - (addr creation-time) - (addr exit-time) - (addr kernel-time) - (addr user-time)))) - (if (zerop result) - (win32-error "GetProcessTimes") - (flet ((filetime-to-100-ns (time) - (+ (ash (slot time 'dw-high-datetime) 32) - (slot time 'dw-low-datetime)))) - (values (filetime-to-100-ns creation-time) - (filetime-to-100-ns exit-time) - (filetime-to-100-ns kernel-time) - (filetime-to-100-ns user-time))))))) + (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)))) + +;; 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))