Added win32 gl 3.x context support.

src/win32/glop-win32.lisp

@@ -18,19 +18,35 @@
 (defstruct wgl-context
   ctx)
 
+;; FIXME: we should use specific context creation if available regardless of
+;; :major and :minor being nil
 (defmethod create-gl-context ((win win32-window) &key (make-current t) major minor
                                                       forward-compat debug
                                                       profile)
 
-  (when (or major minor forward-compat debug profile)
-      (warn "Specific context version is not implemented, MAJOR and MINOR arguments ignored."))
   (let ((ctx (make-wgl-context)))
-    (let ((wgl-ctx (glop-wgl:wgl-create-context (win32-window-dc win))))
-      (unless wgl-ctx
-        (format t "Error creating GL context: ~S~%" (glop-win32:get-last-error)))
-      (setf (wgl-context-ctx ctx) wgl-ctx))
+    (setf (wgl-context-ctx ctx)
+          (if (and major minor)
+              (let ((attrs (list :major-version major :minor-version minor)))
+                (when profile
+                  (case profile
+                    (:core (push :core-profile-bit attrs))
+                    (:compat (push :compatibility-profile-bit attrs)))
+                  (push :profile-mask attrs))
+                (when (or forward-compat debug)
+                  (let ((flags '()))
+                    (when forward-compat (push :forward-compatible-bit flags))
+                    (when debug (push :debug-bit flags))
+                    (push flags attrs)
+                    (push :flags attrs)))
+                (glop-wgl:wgl-create-specific-context (win32-window-dc win) attrs))
+              (glop-wgl:wgl-create-context (win32-window-dc win))))
+    (unless wgl-ctx
+      (format t "Error creating GL context: ~S~%" (glop-win32:get-last-error)))
     (when make-current
       (attach-gl-context win ctx))
+    (when (and major minor)
+      (glop-glx:correct-context? major minor))
     ctx))
 
 (defmethod destroy-gl-context ((ctx wgl-context))

src/win32/wgl.lisp

@@ -53,6 +53,19 @@
   (:pfd-type-rgba 0)
   (:pfd-type-color-index 1))
 
+(defcenum (wgl-context-attributes :unsigned-int)
+  (:major-version #x2091)
+  (:minor-version #x2092)
+  (:layer-planes #x2093)
+  (:flags #x2094)
+  (:profile-mask #x9126)
+  (:core-profile-bit #x00000001)
+  (:compatibility-profile-bit #x00000002))
+
+(defbitfield (wgl-context-attribute-flags :unsigned-int)
+  (:debug-bit #x00000001)
+  (:forward-compatible-bit #x00000002))
+
 (define-foreign-library opengl
   (t (:default "opengl32")))
 (use-foreign-library opengl)
@@ -62,6 +75,41 @@
 (defcfun ("wglCreateContext" wgl-create-context) hglrc
   (dc hdc))
 
+(defun wgl-create-specific-context (hdc context-attribs)
+  (with-foreign-object ( atts :int (1+ (length context-attribs)))
+    (loop
+      for i below (length context-attribs)
+      for attr in context-attribs do
+        (setf (mem-aref atts :int i)
+              (typecase attr
+                (keyword (foreign-enum-value 'glx-context-attributes attr))
+                (list (foreign-bitfield-value 'glx-context-attribute-flags attr))
+                (t attr))))
+    (setf (mem-aref atts :int (length context-attribs)) 0)
+    ;; we need a fake gl context to be able to use wgl-get-proc-address
+    ;; see http://www.opengl.org/wiki/Creating_an_OpenGL_Context#Proper_Context_Creation
+    ;; FIXME: need some more error checking here
+    (let ((tmp-ctx  (wgl-create-context hdc)))
+      (wgl-make-current hdc tmp-ctx)
+      (let ((ptr (glx-get-proc-address "wglCreateContextAttribsARB")))
+        ;; remove out temporary context
+        (wgl-make-current (cffi:null-pointer) (cffi:null-pointer))
+        (wgl-delete-context tmp-ctx)
+        (when (null-pointer-p ptr)
+          (error "wglCreateContextAttribsARB unavailable"))
+        (let ((ctx (cffi:foreign-funcall-pointer ptr ()
+                                                 :pointer hdc
+                                                 :int 0
+                                                 (:pointer :int) atts
+                                                 :pointer)))
+          (when (null-pointer-p ctx)
+            (error "Unable to create context"))
+          ctx)))))
+
+
+(defcfun ("glGetString" get-string) :pointer
+  (name :unsigned-int))
+
 (defcfun ("wglMakeCurrent" wgl-make-current) bool
   (dc hdc) (rc hglrc))
 
@@ -136,3 +184,23 @@
 
 (defcfun ("SwapBuffers" swap-buffers) bool
   (dc hdc))
+
+
+;; FIXME: this is copied from x11/glx.lisp, we should put this in some common file
+(defun parse-gl-version-string-values (string)
+  ;; major version is integer value up to first #\.
+  ;; minor version is integer from first #\. to a #\. or #\space
+  (let ((dot (position #\. string)))
+    (values
+     (values (parse-integer string :end dot :junk-allowed t)) ; major
+     (if dot ; minor
+         (values (parse-integer string :start (1+ dot) :junk-allowed t))
+         0))))
+
+(defun correct-context? (major-desired minor-desired)
+  (multiple-value-bind (major minor)
+      (parse-gl-version-string-values
+       (foreign-string-to-lisp (get-string (foreign-enum-value 'gl-enum :version))))
+    (when (or (< major major-desired)
+              (and (= major major-desired) (< minor minor-desired)))
+      (error "unable to create requested context"))))

src/x11/glop-x11.lisp

@@ -42,6 +42,8 @@
   display       ;; X display ptr
   )
 
+;; FIXME: we should use specific context creation if available regardless of
+;; :major and :minor being nil
 (defmethod create-gl-context ((win x11-window) &key (make-current t) major minor
                                                     forward-compat debug
                                                     profile)