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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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))
 \f
 ;;; 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))))
 \f
 ;;;; Encode and decode universal times.
 

diff --git a/src/code/unix.lisp b/src/code/unix.lisp
index d6290d8..b9c1d80 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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"