X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fwin32.lisp;h=facc8c93ba82a9001e0b32c455b35a96b75c582c;hb=5d04a95274c9ddaebbcd6ddffc5d646e2c25598c;hp=3851f556267799666181dce303178ded5c1de332;hpb=94284af2ff059b0d83d891fb9903f182db6751af;p=sbcl.git diff --git a/src/code/win32.lisp b/src/code/win32.lisp index 3851f55..facc8c9 100644 --- a/src/code/win32.lisp +++ b/src/code/win32.lisp @@ -191,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) @@ -370,10 +370,12 @@ (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 @@ -432,21 +434,21 @@ (defun get-folder-pathname (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) "\\")) 0 csidl 0 0 apath))) (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))))) @@ -462,13 +464,13 @@ (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) @@ -484,6 +486,9 @@ ;;;; 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). @@ -491,22 +496,39 @@ ;; 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)))) ;; SETENV ;; The SetEnvironmentVariable function sets the contents of the specified @@ -557,7 +579,7 @@ ;; 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))) @@ -565,6 +587,6 @@ (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))))