X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fwin32.lisp;h=3aef59335d89c05c7d259545dc007ef8969bc75f;hb=95591ed483dbb8c0846c129953acac1554f28809;hp=c5210df12e6332872f25d2e440605a679c3a1411;hpb=0a62dd8d5169f4e7ee45013e18428df0854e75e3;p=sbcl.git diff --git a/src/code/win32.lisp b/src/code/win32.lisp index c5210df..3aef593 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) @@ -374,6 +374,8 @@ 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,84 @@ ;; 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 @@ -557,7 +624,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 +632,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))))