From: Nikodemus Siivola Date: Sun, 18 Jun 2006 19:11:31 +0000 (+0000) Subject: 0.9.13.46: GET-INTERNAL-RUN-TIME on Windows, + Windows cleanups X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=fdf46e7bd7aba9b5c8af629fdb2692d9b33b9207;p=sbcl.git 0.9.13.46: GET-INTERNAL-RUN-TIME on Windows, + Windows cleanups * Merge the patch by Frank Buss, that implements get-internal-run-time for Windows, modulo stylistic changes. (Restores buildability on Windows.) * LESS UPCASE. * Also slightly less #!+/-win32 conditionalization. * Grovel more stuff on Windows. --- diff --git a/NEWS b/NEWS index e7e4853..926189a 100644 --- a/NEWS +++ b/NEWS @@ -31,8 +31,6 @@ changes in sbcl-0.9.14 relative to sbcl-0.9.13: * bug fix: merging pathnames against defaults with :DIRECTORY starting with '(:RELATIVE :BACK) should preserve the :BACK. (reported by James Y Knight) - * improved SB-BSD-SOCKETS support on Windows. (thanks to Timothy - Ritchey) * bug fix: saving large (>2GB) cores on x86-64 now works * bug fix: a x86-64 backend bug when compiling (setf aref) with a constant index and a (simple-array (signed-byte 32)) array @@ -48,7 +46,9 @@ changes in sbcl-0.9.14 relative to sbcl-0.9.13: * fixed some bugs revealed by Paul Dietz' test suite: ** MISC.641: LET-conversion were not supposed to work in late compilation stages. - + * improvements to the Win32/x86 port: + ** GET-INTERNAL-RUN-TIME implemented, thanks to Frank Buss. + ** improved SB-BSD-SOCKETS support, thanks to Timothy Ritchey. changes in sbcl-0.9.13 relative to sbcl-0.9.12: * new feature: source path information is generated for macro-expansion diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 075589c..7ff9268 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -2358,4 +2358,6 @@ SBCL itself" "GET-LAST-ERROR" "GET-OSFHANDLE" "HANDLE" "HANDLE-CLEAR-INPUT" "HANDLE-LISTEN" "INT-PTR" "INVALID-HANDLE" "MILLISLEEP" "PEEK-CONSOLE-INPUT" - "PEEK-NAMED-PIPE" "READ-FILE" "WRITE-FILE"))) + "PEEK-NAMED-PIPE" "READ-FILE" "WRITE-FILE" + + "GET-PROCESS-TIMES"))) diff --git a/src/code/linux-os.lisp b/src/code/linux-os.lisp index 7b1b5f4..1e1e786 100644 --- a/src/code/linux-os.lisp +++ b/src/code/linux-os.lisp @@ -33,7 +33,7 @@ (sb!ext:run-program "/bin/uname" `("-r") :output stream)))))) -;;; Return system time, user time and number of page faults. +;;; Return user time, system time, and number of page faults. (defun get-system-info () (multiple-value-bind (err? utime stime maxrss ixrss idrss isrss minflt majflt) diff --git a/src/code/time.lisp b/src/code/time.lisp index 29a7687..e211015 100644 --- a/src/code/time.lisp +++ b/src/code/time.lisp @@ -18,6 +18,9 @@ (defconstant micro-seconds-per-internal-time-unit (/ 1000000 sb!xc:internal-time-units-per-second)) + +(defconstant 100ns-per-internal-time-unit + (/ 10000000 internal-time-units-per-second)) ;;; The base number of seconds for our internal "epoch". We initialize ;;; this to the time of the first call to GET-INTERNAL-REAL-TIME, and @@ -47,6 +50,12 @@ #!+sb-doc "Return the run time in the internal time format. (See INTERNAL-TIME-UNITS-PER-SECOND.) This is useful for finding CPU usage." + ;; FIXME: This is yet another creeping malaise: instead of #+/-win32 + ;; conditionals things like these need to be split into wholly separate + ;; implementations of get-internal-run-time, probably one in + ;; unix.lisp and one in win32.lisp -- that however requires also + ;; cleaning up unix.lisp sufficiently to remove it from the Windows build. + #-win32 (multiple-value-bind (ignore utime-sec utime-usec stime-sec stime-usec) (sb!unix:unix-fast-getrusage sb!unix:rusage_self) (declare (ignore ignore) @@ -62,7 +71,13 @@ stime-usec (floor micro-seconds-per-internal-time-unit 2)) micro-seconds-per-internal-time-unit)))) - result))) + result)) + #!+win32 + (multiple-value-bind + (creation-time exit-time kernel-time user-time) + (sb!win32:get-process-times) + (declare (ignore creation-time exit-time)) + (values (floor (+ user-time kernel-time) 100ns-per-internal-time-unit)))) ;;;; Encode and decode universal times. diff --git a/src/code/unix.lisp b/src/code/unix.lisp index d6290d8..b9c1d80 100644 --- a/src/code/unix.lisp +++ b/src/code/unix.lisp @@ -107,26 +107,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." #!+win32 (progn - (defconstant o_rdonly 0) - (defconstant o_wronly 1) - (defconstant o_rdwr 2) - (defconstant o_creat #x100) - (defconstant o_trunc #x200) - (defconstant o_append #x008) - (defconstant o_excl #x400) - (defconstant enoent 2) - (defconstant eexist 17) (defconstant espipe 29) - (defconstant o_binary #x8000) - (defconstant s-ifmt #xf000) - (defconstant s-ifdir #x4000) - (defconstant s-ifreg #x8000) - (define-alien-type ino-t short) - (define-alien-type time-t long) - (define-alien-type off-t long) - (define-alien-type size-t long) - (define-alien-type mode-t unsigned-short) - ;; For stat-wrapper hack (different-type or non-existing win32 fields). (define-alien-type nlink-t short) (define-alien-type uid-t short) @@ -314,18 +295,21 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." ;;; value is the pipe to be read from and the second is can be written ;;; to. If an error occurred the first value is NIL and the second the ;;; unix error code. -#!-win32(defun unix-pipe () +#!-win32 +(defun unix-pipe () (with-alien ((fds (array int 2))) (syscall ("pipe" (* int)) (values (deref fds 0) (deref fds 1)) (cast fds (* int))))) -#!+win32(defun msvcrt-raw-pipe (fds size mode) - (syscall ("_pipe" (* int) int int) - (values (deref fds 0) (deref fds 1)) - (cast fds (* int)) size mode)) -#!+win32(defun unix-pipe () +#!+win32 +(defun msvcrt-raw-pipe (fds size mode) + (syscall ("_pipe" (* int) int int) + (values (deref fds 0) (deref fds 1)) + (cast fds (* int)) size mode)) +#!+win32 +(defun unix-pipe () (with-alien ((fds (array int 2))) - (msvcrt-raw-pipe fds 256 o_binary))) + (msvcrt-raw-pipe fds 256 o_binary))) ;; Windows mkdir() doesn't take the mode argument. It's cdecl, so we could ;; actually call it passing the mode argument, but some sharp-eyed reader diff --git a/src/code/win32-os.lisp b/src/code/win32-os.lisp index dddc8a0..ea085e5 100644 --- a/src/code/win32-os.lisp +++ b/src/code/win32-os.lisp @@ -24,23 +24,16 @@ #!+sb-doc "Return a string describing version of the supporting software, or NIL if not available." - nil ;; FIXME: Implement. - #+nil(or *software-version* - (setf *software-version* - (string-trim '(#\newline) - (with-output-to-string (stream) - (sb!ext:run-program "/bin/uname" `("-r") - :output stream)))))) + ;; FIXME: Implement. + nil) -;;; Return system time, user time and number of page faults. +;;; Return user time, system time, and number of page faults. (defun get-system-info () -#+nil (multiple-value-bind - (err? utime stime maxrss ixrss idrss isrss minflt majflt) - (sb!unix:unix-getrusage sb!unix:rusage_self) - (declare (ignore maxrss ixrss idrss isrss minflt)) - (unless err? ; FIXME: nonmnemonic (reversed) name for ERR? - (error "Unix system call getrusage failed: ~A." (strerror utime))) - (values utime stime majflt))) + ;; FIXME: number of page faults is always zero + (multiple-value-bind (creation-time exit-time kernel-time user-time) + (sb!win32:get-process-times) + (declare (ignore creation-time exit-time)) + (values (floor user-time 10) (floor kernel-time 10) 0))) ;;; Return the system page size. (defun get-page-size () diff --git a/src/code/win32.lisp b/src/code/win32.lisp index e4152a8..c4b7589 100644 --- a/src/code/win32.lisp +++ b/src/code/win32.lisp @@ -16,11 +16,13 @@ ;;; Alien definitions for commonly used Win32 types. Woe unto whoever ;;; tries to untangle this someday for 64-bit Windows. -(define-alien-type int-ptr long) +;;; +;;; 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 +;;; build. --NS 2006-06-18 (define-alien-type handle int-ptr) -(define-alien-type dword unsigned-long) -(define-alien-type bool int) -(define-alien-type UINT unsigned-int) (define-alien-type tchar #!+sb-unicode (sb!alien:unsigned 16) #!-sb-unicode char) @@ -51,6 +53,10 @@ (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 @@ -115,7 +121,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 (cast buf (* t)) input-record-size (addr avail))) + (unless (zerop (peek-console-input handle + (cast buf (* t)) + input-record-size (addr avail))) (return-from handle-listen (plusp avail))) ;; FIXME-SOCKETS: Try again here with WSAEventSelect in case @@ -155,203 +163,202 @@ (define-alien-routine ("Sleep@4" millisleep) void (milliseconds dword)) -#!+sb-unicode (defvar *ANSI-CODEPAGE* nil) -#!+sb-unicode (defvar *OEM-CODEPAGE* nil) - -#!+sb-unicode -(defparameter *codepage-to-external-format* (make-hash-table)) - -#!+sb-unicode -(dolist (cp - '(;;037 IBM EBCDIC - U.S./Canada - (437 :CP437) ;; OEM - United States - ;;500 IBM EBCDIC - International - ;;708 Arabic - ASMO 708 - ;;709 Arabic - ASMO 449+, BCON V4 - ;;710 Arabic - Transparent Arabic - ;;720 Arabic - Transparent ASMO - ;;737 OEM - Greek (formerly 437G) - ;;775 OEM - Baltic - (850 :CP850) ;; OEM - Multilingual Latin I - (852 :CP852) ;; OEM - Latin II - (855 :CP855) ;; OEM - Cyrillic (primarily Russian) - (857 :CP857) ;; OEM - Turkish - ;;858 OEM - Multilingual Latin I + Euro symbol - (860 :CP860) ;; OEM - Portuguese - (861 :CP861) ;; OEM - Icelandic - (862 :CP862) ;; OEM - Hebrew - (863 :CP863) ;; OEM - Canadian-French - (864 :CP864) ;; OEM - Arabic - (865 :CP865) ;; OEM - Nordic - (866 :CP866) ;; OEM - Russian - (869 :CP869) ;; OEM - Modern Greek - ;;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 - ;;936 ANSI/OEM - Simplified Chinese (PRC, Singapore) - ;;949 ANSI/OEM - Korean (Unified Hangul Code) - ;;950 ANSI/OEM - Traditional Chinese (Taiwan; Hong Kong SAR, PRC) - ;;1026 IBM EBCDIC - Turkish (Latin-5) - ;;1047 IBM EBCDIC - Latin 1/Open System - ;;1140 IBM EBCDIC - U.S./Canada (037 + Euro symbol) - ;;1141 IBM EBCDIC - Germany (20273 + Euro symbol) - ;;1142 IBM EBCDIC - Denmark/Norway (20277 + Euro symbol) - ;;1143 IBM EBCDIC - Finland/Sweden (20278 + Euro symbol) - ;;1144 IBM EBCDIC - Italy (20280 + Euro symbol) - ;;1145 IBM EBCDIC - Latin America/Spain (20284 + Euro symbol) - ;;1146 IBM EBCDIC - United Kingdom (20285 + Euro symbol) - ;;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 - (1250 :CP1250) ;; ANSI - Central European - (1251 :CP1251) ;; ANSI - Cyrillic - (1252 :CP1252) ;; ANSI - Latin I - (1253 :CP1253) ;; ANSI - Greek - (1254 :CP1254) ;; ANSI - Turkish - (1255 :CP1255) ;; ANSI - Hebrew - (1256 :CP1256) ;; ANSI - Arabic - (1257 :CP1257) ;; ANSI - Baltic - (1258 :CP1258) ;; ANSI/OEM - Vietnamese - ;;1361 Korean (Johab) - ;;10000 MAC - Roman - ;;10001 MAC - Japanese - ;;10002 MAC - Traditional Chinese (Big5) - ;;10003 MAC - Korean - ;;10004 MAC - Arabic - ;;10005 MAC - Hebrew - ;;10006 MAC - Greek I - (10007 :X-MAC-CYRILLIC) ;; MAC - Cyrillic - ;;10008 MAC - Simplified Chinese (GB 2312) - ;;10010 MAC - Romania - ;;10017 MAC - Ukraine - ;;10021 MAC - Thai - ;;10029 MAC - Latin II - ;;10079 MAC - Icelandic - ;;10081 MAC - Turkish - ;;10082 MAC - Croatia - ;;12000 Unicode UCS-4 Little-Endian - ;;12001 Unicode UCS-4 Big-Endian - ;;20000 CNS - Taiwan - ;;20001 TCA - Taiwan - ;;20002 Eten - Taiwan - ;;20003 IBM5550 - Taiwan - ;;20004 TeleText - Taiwan - ;;20005 Wang - Taiwan - ;;20105 IA5 IRV International Alphabet No. 5 (7-bit) - ;;20106 IA5 German (7-bit) - ;;20107 IA5 Swedish (7-bit) - ;;20108 IA5 Norwegian (7-bit) - ;;20127 US-ASCII (7-bit) - ;;20261 T.61 - ;;20269 ISO 6937 Non-Spacing Accent - ;;20273 IBM EBCDIC - Germany - ;;20277 IBM EBCDIC - Denmark/Norway - ;;20278 IBM EBCDIC - Finland/Sweden - ;;20280 IBM EBCDIC - Italy - ;;20284 IBM EBCDIC - Latin America/Spain - ;;20285 IBM EBCDIC - United Kingdom - ;;20290 IBM EBCDIC - Japanese Katakana Extended - ;;20297 IBM EBCDIC - France - ;;20420 IBM EBCDIC - Arabic - ;;20423 IBM EBCDIC - Greek - ;;20424 IBM EBCDIC - Hebrew - ;;20833 IBM EBCDIC - Korean Extended - ;;20838 IBM EBCDIC - Thai - (20866 :KOI8-R) ;; Russian - KOI8-R - ;;20871 IBM EBCDIC - Icelandic - ;;20880 IBM EBCDIC - Cyrillic (Russian) - ;;20905 IBM EBCDIC - Turkish - ;;20924 IBM EBCDIC - Latin-1/Open System (1047 + Euro symbol) - ;;20932 JIS X 0208-1990 & 0121-1990 - ;;20936 Simplified Chinese (GB2312) - ;;21025 IBM EBCDIC - Cyrillic (Serbian, Bulgarian) - ;;21027 (deprecated) - (21866 :KOI8-U) ;; Ukrainian (KOI8-U) - (28591 :LATIN-1) ;; ISO 8859-1 Latin I - (28592 :ISO-8859-2) ;; ISO 8859-2 Central Europe - (28593 :ISO-8859-3) ;; ISO 8859-3 Latin 3 - (28594 :ISO-8859-4) ;; ISO 8859-4 Baltic - (28595 :ISO-8859-5) ;; ISO 8859-5 Cyrillic - (28596 :ISO-8859-6) ;; ISO 8859-6 Arabic - (28597 :ISO-8859-7) ;; ISO 8859-7 Greek - (28598 :ISO-8859-8) ;; ISO 8859-8 Hebrew - (28599 :ISO-8859-9) ;; ISO 8859-9 Latin 5 - (28605 :LATIN-9) ;; ISO 8859-15 Latin 9 - ;;29001 Europa 3 - (38598 :ISO-8859-8) ;; ISO 8859-8 Hebrew - ;;50220 ISO 2022 Japanese with no halfwidth Katakana - ;;50221 ISO 2022 Japanese with halfwidth Katakana - ;;50222 ISO 2022 Japanese JIS X 0201-1989 - ;;50225 ISO 2022 Korean - ;;50227 ISO 2022 Simplified Chinese - ;;50229 ISO 2022 Traditional Chinese - ;;50930 Japanese (Katakana) Extended - ;;50931 US/Canada and Japanese - ;;50933 Korean Extended and Korean - ;;50935 Simplified Chinese Extended and Simplified Chinese - ;;50936 Simplified Chinese - ;;50937 US/Canada and Traditional Chinese - ;;50939 Japanese (Latin) Extended and Japanese - (51932 :EUC-JP) ;; EUC - Japanese - ;;51936 EUC - Simplified Chinese - ;;51949 EUC - Korean - ;;51950 EUC - Traditional Chinese - ;;52936 HZ-GB2312 Simplified Chinese - ;;54936 Windows XP: GB18030 Simplified Chinese (4 Byte) - ;;57002 ISCII Devanagari - ;;57003 ISCII Bengali - ;;57004 ISCII Tamil - ;;57005 ISCII Telugu - ;;57006 ISCII Assamese - ;;57007 ISCII Oriya - ;;57008 ISCII Kannada - ;;57009 ISCII Malayalam - ;;57010 ISCII Gujarati - ;;57011 ISCII Punjabi - ;;65000 Unicode UTF-7 - (65001 :UTF8))) ;; Unicode UTF-8 +#+sb-unicode +(progn + (defvar *ansi-codepage* nil) + (defvar *oem-codepage* nil) + (defvar *codepage-to-external-format* (make-hash-table))) + +#+sb-unicode +(dolist + (cp '(;;037 IBM EBCDIC - U.S./Canada + (437 :CP437) ;; OEM - United States + ;;500 IBM EBCDIC - International + ;;708 Arabic - ASMO 708 + ;;709 Arabic - ASMO 449+, BCON V4 + ;;710 Arabic - Transparent Arabic + ;;720 Arabic - Transparent ASMO + ;;737 OEM - Greek (formerly 437G) + ;;775 OEM - Baltic + (850 :CP850) ;; OEM - Multilingual Latin I + (852 :CP852) ;; OEM - Latin II + (855 :CP855) ;; OEM - Cyrillic (primarily Russian) + (857 :CP857) ;; OEM - Turkish + ;;858 OEM - Multilingual Latin I + Euro symbol + (860 :CP860) ;; OEM - Portuguese + (861 :CP861) ;; OEM - Icelandic + (862 :CP862) ;; OEM - Hebrew + (863 :CP863) ;; OEM - Canadian-French + (864 :CP864) ;; OEM - Arabic + (865 :CP865) ;; OEM - Nordic + (866 :CP866) ;; OEM - Russian + (869 :CP869) ;; OEM - Modern Greek + ;;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 + ;;936 ANSI/OEM - Simplified Chinese (PRC, Singapore) + ;;949 ANSI/OEM - Korean (Unified Hangul Code) + ;;950 ANSI/OEM - Traditional Chinese (Taiwan; Hong Kong SAR, PRC) + ;;1026 IBM EBCDIC - Turkish (Latin-5) + ;;1047 IBM EBCDIC - Latin 1/Open System + ;;1140 IBM EBCDIC - U.S./Canada (037 + Euro symbol) + ;;1141 IBM EBCDIC - Germany (20273 + Euro symbol) + ;;1142 IBM EBCDIC - Denmark/Norway (20277 + Euro symbol) + ;;1143 IBM EBCDIC - Finland/Sweden (20278 + Euro symbol) + ;;1144 IBM EBCDIC - Italy (20280 + Euro symbol) + ;;1145 IBM EBCDIC - Latin America/Spain (20284 + Euro symbol) + ;;1146 IBM EBCDIC - United Kingdom (20285 + Euro symbol) + ;;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 + (1250 :CP1250) ;; ANSI - Central European + (1251 :CP1251) ;; ANSI - Cyrillic + (1252 :CP1252) ;; ANSI - Latin I + (1253 :CP1253) ;; ANSI - Greek + (1254 :CP1254) ;; ANSI - Turkish + (1255 :CP1255) ;; ANSI - Hebrew + (1256 :CP1256) ;; ANSI - Arabic + (1257 :CP1257) ;; ANSI - Baltic + (1258 :CP1258) ;; ANSI/OEM - Vietnamese + ;;1361 Korean (Johab) + ;;10000 MAC - Roman + ;;10001 MAC - Japanese + ;;10002 MAC - Traditional Chinese (Big5) + ;;10003 MAC - Korean + ;;10004 MAC - Arabic + ;;10005 MAC - Hebrew + ;;10006 MAC - Greek I + (10007 :X-MAC-CYRILLIC) ;; MAC - Cyrillic + ;;10008 MAC - Simplified Chinese (GB 2312) + ;;10010 MAC - Romania + ;;10017 MAC - Ukraine + ;;10021 MAC - Thai + ;;10029 MAC - Latin II + ;;10079 MAC - Icelandic + ;;10081 MAC - Turkish + ;;10082 MAC - Croatia + ;;12000 Unicode UCS-4 Little-Endian + ;;12001 Unicode UCS-4 Big-Endian + ;;20000 CNS - Taiwan + ;;20001 TCA - Taiwan + ;;20002 Eten - Taiwan + ;;20003 IBM5550 - Taiwan + ;;20004 TeleText - Taiwan + ;;20005 Wang - Taiwan + ;;20105 IA5 IRV International Alphabet No. 5 (7-bit) + ;;20106 IA5 German (7-bit) + ;;20107 IA5 Swedish (7-bit) + ;;20108 IA5 Norwegian (7-bit) + ;;20127 US-ASCII (7-bit) + ;;20261 T.61 + ;;20269 ISO 6937 Non-Spacing Accent + ;;20273 IBM EBCDIC - Germany + ;;20277 IBM EBCDIC - Denmark/Norway + ;;20278 IBM EBCDIC - Finland/Sweden + ;;20280 IBM EBCDIC - Italy + ;;20284 IBM EBCDIC - Latin America/Spain + ;;20285 IBM EBCDIC - United Kingdom + ;;20290 IBM EBCDIC - Japanese Katakana Extended + ;;20297 IBM EBCDIC - France + ;;20420 IBM EBCDIC - Arabic + ;;20423 IBM EBCDIC - Greek + ;;20424 IBM EBCDIC - Hebrew + ;;20833 IBM EBCDIC - Korean Extended + ;;20838 IBM EBCDIC - Thai + (20866 :KOI8-R) ;; Russian - KOI8-R + ;;20871 IBM EBCDIC - Icelandic + ;;20880 IBM EBCDIC - Cyrillic (Russian) + ;;20905 IBM EBCDIC - Turkish + ;;20924 IBM EBCDIC - Latin-1/Open System (1047 + Euro symbol) + ;;20932 JIS X 0208-1990 & 0121-1990 + ;;20936 Simplified Chinese (GB2312) + ;;21025 IBM EBCDIC - Cyrillic (Serbian, Bulgarian) + ;;21027 (deprecated) + (21866 :KOI8-U) ;; Ukrainian (KOI8-U) + (28591 :LATIN-1) ;; ISO 8859-1 Latin I + (28592 :ISO-8859-2) ;; ISO 8859-2 Central Europe + (28593 :ISO-8859-3) ;; ISO 8859-3 Latin 3 + (28594 :ISO-8859-4) ;; ISO 8859-4 Baltic + (28595 :ISO-8859-5) ;; ISO 8859-5 Cyrillic + (28596 :ISO-8859-6) ;; ISO 8859-6 Arabic + (28597 :ISO-8859-7) ;; ISO 8859-7 Greek + (28598 :ISO-8859-8) ;; ISO 8859-8 Hebrew + (28599 :ISO-8859-9) ;; ISO 8859-9 Latin 5 + (28605 :LATIN-9) ;; ISO 8859-15 Latin 9 + ;;29001 Europa 3 + (38598 :ISO-8859-8) ;; ISO 8859-8 Hebrew + ;;50220 ISO 2022 Japanese with no halfwidth Katakana + ;;50221 ISO 2022 Japanese with halfwidth Katakana + ;;50222 ISO 2022 Japanese JIS X 0201-1989 + ;;50225 ISO 2022 Korean + ;;50227 ISO 2022 Simplified Chinese + ;;50229 ISO 2022 Traditional Chinese + ;;50930 Japanese (Katakana) Extended + ;;50931 US/Canada and Japanese + ;;50933 Korean Extended and Korean + ;;50935 Simplified Chinese Extended and Simplified Chinese + ;;50936 Simplified Chinese + ;;50937 US/Canada and Traditional Chinese + ;;50939 Japanese (Latin) Extended and Japanese + (51932 :EUC-JP) ;; EUC - Japanese + ;;51936 EUC - Simplified Chinese + ;;51949 EUC - Korean + ;;51950 EUC - Traditional Chinese + ;;52936 HZ-GB2312 Simplified Chinese + ;;54936 Windows XP: GB18030 Simplified Chinese (4 Byte) + ;;57002 ISCII Devanagari + ;;57003 ISCII Bengali + ;;57004 ISCII Tamil + ;;57005 ISCII Telugu + ;;57006 ISCII Assamese + ;;57007 ISCII Oriya + ;;57008 ISCII Kannada + ;;57009 ISCII Malayalam + ;;57010 ISCII Gujarati + ;;57011 ISCII Punjabi + ;;65000 Unicode UTF-7 + (65001 :UTF8))) ;; Unicode UTF-8 (setf (gethash (car cp) *codepage-to-external-format*) (cadr cp))) #!+sb-unicode -(declaim (ftype (function () keyword) ansi-codepage)) -#!+sb-unicode -(defun ansi-codepage () - (or *ANSI-CODEPAGE* - (setq *ANSI-CODEPAGE* - (or - (gethash (alien-funcall (extern-alien "GetACP@0" (function UINT))) - *codepage-to-external-format*) - :LATIN-1)))) - -#!+sb-unicode -(declaim (ftype (function () keyword) oem-codepage)) -#!+sb-unicode -(defun oem-codepage () - (or *OEM-CODEPAGE* - (setq *OEM-CODEPAGE* - (or - (gethash (alien-funcall (extern-alien "GetOEMCP@0" (function UINT))) - *codepage-to-external-format*) - :LATIN-1)))) +;; FIXME: Something odd here: why are these two #+SB-UNICODE, whereas +;; the console just behave differently? +(progn + (declaim (ftype (function () keyword) ansi-codepage)) + (defun ansi-codepage () + (or *ansi-codepage* + (setq *ansi-codepage* + (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* + (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 () +(defun console-input-codepage () (or #!+sb-unicode (gethash (alien-funcall (extern-alien "GetConsoleCP@0" (function UINT))) *codepage-to-external-format*) - :LATIN-1)) + :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))) + (gethash (alien-funcall + (extern-alien "GetConsoleOutputCP@0" (function UINT))) *codepage-to-external-format*) - :LATIN-1)) + :latin-1)) ;;;; FIXME (rudi 2006-03-29): this should really be (octets-to-string ;;;; :external-format :ucs2), except that we do not have an @@ -378,13 +385,13 @@ "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))) + (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))))) @@ -399,17 +406,18 @@ "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) + (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) "\\"))) (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")) + :extern + #!-sb-unicode "GetCurrentDirectoryA@8" + #!+sb-unicode "GetCurrentDirectoryW@8")) (let ((ret (alien-funcall afunc (1+ MAX_PATH) apath))) (when (zerop ret) (win32-error "GetCurrentDirectory")) @@ -427,12 +435,11 @@ (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)) + (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)))) @@ -442,35 +449,73 @@ (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)))) + (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)))) + (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)) + (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)))) - (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" + :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))) - (when (> ret default-environment-length) - (free-alien aenv) - (setf aenv (make-alien tchar ret)) - (alien-funcall afunc aname aenv ret)) - (if (> ret 0) - (ucs2->string&free aenv ret) - nil))))) + (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))) + (when (> ret default-environment-length) + (free-alien aenv) + (setf aenv (make-alien tchar ret)) + (alien-funcall afunc aname aenv ret)) + (if (> ret 0) + (ucs2->string&free aenv ret) + nil))))) + +;;;; Process time information + +(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))))))) diff --git a/src/runtime/win32-os.c b/src/runtime/win32-os.c index 9b78fd5..eba3a6a 100644 --- a/src/runtime/win32-os.c +++ b/src/runtime/win32-os.c @@ -673,6 +673,8 @@ void scratch(void) GetConsoleCP(); GetConsoleOutputCP(); GetExitCodeProcess(0, 0); + GetCurrentProcess(); + GetProcessTimes(0, 0, 0, 0, 0); } char * diff --git a/tools-for-build/grovel-headers.c b/tools-for-build/grovel-headers.c index 9b533d4..169a719 100644 --- a/tools-for-build/grovel-headers.c +++ b/tools-for-build/grovel-headers.c @@ -158,6 +158,37 @@ main(int argc, char *argv[]) defconstant ("ERROR_ENVVAR_NOT_FOUND", ERROR_ENVVAR_NOT_FOUND); + printf(";;; Windows Types\n"); + DEFTYPE("int-ptr", INT_PTR); + DEFTYPE("dword", DWORD); + DEFTYPE("bool", BOOL); + DEFTYPE("uint", UINT); + + /* FIXME: SB-UNIX and SB-WIN32 really need to be untangled. */ + printf("(in-package \"SB!UNIX\")\n\n"); + printf(";;; Unix-like constants and types on Windows\n"); + defconstant("o_rdonly", _O_RDONLY); + defconstant("o_wronly", _O_WRONLY); + defconstant("o_rdwr", _O_RDWR); + defconstant("o_creat", _O_CREAT); + defconstant("o_trunc", _O_TRUNC); + defconstant("o_append", _O_APPEND); + defconstant("o_excl", _O_EXCL); + defconstant("o_binary", _O_BINARY); + + defconstant("enoent", ENOENT); + defconstant("eexist", EEXIST); + + defconstant("s-ifmt", S_IFMT); + defconstant("s-ifdir", S_IFDIR); + defconstant("s-ifreg", S_IFREG); + + DEFTYPE("ino-t", ino_t); + DEFTYPE("time-t", time_t); + DEFTYPE("off-t", off_t); + DEFTYPE("size-t", size_t); + DEFTYPE("mode-t", mode_t); + #else printf("(in-package \"SB!ALIEN\")\n\n"); diff --git a/version.lisp-expr b/version.lisp-expr index 44402d9..ea15df7 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.13.45" +"0.9.13.46"