Optimize MAKE-ARRAY on unknown element-type.

[sbcl.git] / src / code / win32.lisp

diff --git a/src/code/win32.lisp b/src/code/win32.lisp
index 3bdbf58..41b8068 100644 (file)
--- a/src/code/win32.lisp
+++ b/src/code/win32.lisp
@@ -74,21 +74,6 @@
 ;;; last-error code is maintained on a per-thread basis.
 (define-alien-routine ("GetLastError" get-last-error) dword)
 
-;;; Flag constants for FORMAT-MESSAGE.
-(defconstant format-message-from-system #x1000)
-
-;;; Format an error message based on a lookup table.  See MSDN for the
-;;; full meaning of the all options---most are not used when getting
-;;; system error codes.
-(define-alien-routine ("FormatMessageA" format-message) dword
-  (flags dword)
-  (source (* t))
-  (message-id dword)
-  (language-id dword)
-  (buffer c-string)
-  (size dword)
-  (arguments (* t)))
-
 ;;;; File Handles
 
 ;;; Historically, SBCL on Windows used CRT (lowio) file descriptors,
@@ -521,16 +506,17 @@
 (defmacro void-syscall* ((name &rest arg-types) &rest args)
   `(syscall* (,name ,@arg-types) (values t 0) ,@args))
 
-(defun get-last-error-message (err)
+(defun format-system-message (err)
   "http://msdn.microsoft.com/library/default.asp?url=/library/en-us/debug/base/retrieving_the_last_error_code.asp"
   (let ((message
          (with-alien ((amsg (* char)))
            (syscall (("FormatMessage" 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
-                            FORMAT_MESSAGE_MAX_WIDTH_MASK)
+                    (logior format-message-allocate-buffer
+                            format-message-from-system
+                            format-message-max-width-mask
+                            format-message-ignore-inserts)
                     0 err 0 (addr amsg) 0 0))))
     (and message (string-right-trim '(#\Space) message))))
 
@@ -540,7 +526,7 @@
      (error "~%Win32 Error [~A] - ~A~%~A"
             ,func-name
             err-code
-            (get-last-error-message err-code))))
+            (format-system-message err-code))))
 
 (defun get-folder-namestring (csidl)
   "http://msdn.microsoft.com/library/en-us/shellcc/platform/shell/reference/functions/shgetfolderpath.asp"
@@ -569,13 +555,13 @@
            (type sb!unix:unix-file-mode mode)
            (ignore mode))
   (syscall (("CreateDirectory" t) lispbool system-string (* t))
-           (values result (if result 0 (- (get-last-error))))
+           (values result (if result 0 (get-last-error)))
            name nil))
 
 (defun sb!unix:unix-rename (name1 name2)
   (declare (type sb!unix:unix-pathname name1 name2))
   (syscall (("MoveFile" t) lispbool system-string system-string)
-           (values result (if result 0 (- (get-last-error))))
+           (values result (if result 0 (get-last-error)))
            name1 name2))
 
 (defun sb!unix::posix-getenv (name)
@@ -894,7 +880,7 @@ absense."
       (set-file-pointer-ex handle offset whence)
     (if moved
         (values to-place 0)
-        (values -1 (- (get-last-error))))))
+        (values -1 (get-last-error)))))
 
 ;; File mapping support routines
 (define-alien-routine (#!+sb-unicode "CreateFileMappingW"
@@ -1030,7 +1016,7 @@ absense."
                        sb!unix:enoent)
                       ((#.error_already_exists #.error_file_exists)
                        sb!unix:eexist)
-                      (otherwise (- error-code)))))
+                      (otherwise error-code))))
           (progn
             ;; FIXME: seeking to the end is not enough for real APPEND
             ;; semantics, but it's better than nothing.
@@ -1174,7 +1160,7 @@ absense."
         (duplicate-handle me fd me 0 t +duplicate-same-access+)
       (if duplicated
           (values handle 0)
-          (values nil (- (get-last-error)))))))
+          (values nil (get-last-error))))))
 
 (defun call-with-crt-fd (thunk handle &optional (flags 0))
   (multiple-value-bind (duplicate errno)
@@ -1184,3 +1170,38 @@ absense."
           (unwind-protect (funcall thunk fd)
             (real-crt-close fd)))
         (values nil errno))))
+
+;;; random seeding
+
+(define-alien-routine ("CryptGenRandom" %crypt-gen-random) lispbool
+  (handle handle)
+  (length dword)
+  (buffer (* t)))
+
+(define-alien-routine (#!-sb-unicode "CryptAcquireContextA"
+                       #!+sb-unicode "CryptAcquireContextW"
+                       %crypt-acquire-context) lispbool
+  (handle handle :out)
+  (container system-string)
+  (provider system-string)
+  (provider-type dword)
+  (flags dword))
+
+(define-alien-routine ("CryptReleaseContext" %crypt-release-context) lispbool
+  (handle handle)
+  (flags dword))
+
+(defun crypt-gen-random (length)
+  (multiple-value-bind (ok context)
+      (%crypt-acquire-context nil nil prov-rsa-full
+                              (logior crypt-verifycontext crypt-silent))
+    (unless ok
+      (return-from crypt-gen-random (values nil (get-last-error))))
+    (unwind-protect
+         (let ((data (make-array length :element-type '(unsigned-byte 8))))
+           (with-pinned-objects (data)
+             (if (%crypt-gen-random context length (vector-sap data))
+                 data
+                 (values nil (get-last-error)))))
+      (unless (%crypt-release-context context 0)
+        (win32-error '%crypt-release-context)))))