Skip to content

Comparing changes

Choose two branches to see what’s changed or to start a new pull request. If you need to, you can also compare across forks.

Open a pull request

Create a new pull request by comparing changes across two branches. If you need to, you can also compare across forks.
  • 5 commits
  • 8 files changed
  • 0 commit comments
  • 2 contributors
Commits on Oct 31, 2011
@patzy Added win32 gl 3.x context support. 8d67df1
Commits on Nov 01, 2011
@Ralith Ralith Corrected unix libGL designators. eee4dd8
Commits on Nov 05, 2011
@Ralith Ralith Wrap GLX context creation in without-fp-traps to postpone crashes und…
…er fglrx. Drawing code may also need this, but that's up to the user.
00e9315
Commits on Jan 06, 2012
@patzy Move video-mode rate slot from base struct to platform dependent stru…
…cts.

rate slot type should be integer on win32 and x11 and double-float on osx.
f60212a
Commits on Feb 25, 2012
@patzy Use reversed inheritance (like we did for window class) for video-mod…
…e struct
46a435f
Showing with 159 additions and 68 deletions.
  1. +2 −2 src/osx/glop-osx.lisp
  2. +1 −1 src/osx/quartz.lisp
  3. +19 −15 src/utils.lisp
  4. +23 −7 src/win32/glop-win32.lisp
  5. +68 −0 src/win32/wgl.lisp
  6. +5 −5 src/win32/win32.lisp
  7. +37 −34 src/x11/glop-x11.lisp
  8. +4 −4 src/x11/glx.lisp
View
4 src/osx/glop-osx.lisp
@@ -264,7 +264,7 @@
(glop-bridge:capture-all-displays)
(glop-bridge:set-display-mode
(glop-bridge:main-display-id)
- (osx-video-mode-mode fullscreen-mode)
+ (video-mode-mode fullscreen-mode)
(cffi:null-pointer))
(glop-bridge:ns-opengl-context-clear-drawable gl-context)
(glop-bridge:ns-opengl-context-set-full-screen gl-context)
@@ -274,7 +274,7 @@
(progn
(glop-bridge:set-display-mode
(glop-bridge:main-display-id)
- (osx-video-mode-mode *native-video-mode*)
+ (video-mode-mode *native-video-mode*)
(cffi:null-pointer))
(glop-bridge:ns-opengl-context-clear-drawable gl-context)
(glop-bridge:release-all-displays)
View
2 src/osx/quartz.lisp
@@ -11,7 +11,7 @@
(declaim (inline display-to-video-mode))
(defun translate-to-video-mode (mode)
- (glop::make-osx-video-mode
+ (glop::make-video-mode
:width (mode-width mode)
:height (mode-height mode)
:rate (mode-rate mode)
View
34 src/utils.lisp
@@ -1,10 +1,25 @@
(in-package #:glop)
-(defstruct video-mode
+#+(or win32 windows)
+(defstruct win32-video-mode
+ (rate 0 :type integer))
+
+#+(and unix (not darwin))
+(defstruct x11-video-mode
+ (rate 0 :type integer)
+ (index -1 :type integer))
+
+#+darwin
+(defstruct osx-video-mode
+ (rate 0 :type double-float)
+ mode)
+
+(defstruct (video-mode (:include #+(and unix (not darwin)) x11-video-mode
+ #+(and win32 windows) win32-video-mode
+ #+darwin osx-video-mode))
(width 0 :type integer)
(height 0 :type integer)
- (depth 0 :type integer)
- (rate 0 :type double-float))
+ (depth 0 :type integer))
;; platform specific windows
;; XXX: this may move to platform specific directories
@@ -17,9 +32,6 @@
(dc :accessor win32-window-dc)
(id :accessor win32-window-id)))
-#+(or win32 windows)
-(defstruct (win32-video-mode (:include video-mode)))
-
#+(and unix (not darwin))
(defclass x11-window ()
((display :initarg :display :accessor x11-window-display)
@@ -29,10 +41,6 @@
(fb-config :accessor x11-window-fb-config)
(cursor :accessor x11-window-cursor)))
-#+(and unix (not darwin))
-(defstruct (x11-video-mode (:include video-mode))
- (index -1 :type integer))
-
#+darwin
(defclass osx-window ()
((ns-window :initform nil
@@ -44,10 +52,6 @@
(invert-mouse-y :initform nil
:accessor invert-mouse-y)))
-#+darwin
-(defstruct (osx-video-mode (:include video-mode))
- mode)
-
;; base window structure
;; you may inherit your own window class from this
(defclass window (#+(and unix (not darwin)) x11-window
@@ -104,7 +108,7 @@ Otherwise, only one key-press event will be triggered.")
#+(and sbcl x86-64)
(defmacro without-fp-traps (&body body)
`(sb-int:with-float-traps-masked (:invalid :divide-by-zero)
- ,@body))
+ ,@body))
;;; Do nothing on Lisps that don't need traps disabled.
#-(and sbcl x86-64)
View
30 src/win32/glop-win32.lisp
@@ -9,7 +9,7 @@
(defmethod list-video-modes ()
(glop-win32::list-video-modes))
-(defmethod set-video-mode ((mode win32-video-mode))
+(defmethod set-video-mode ((mode video-mode))
(glop-win32::set-video-mode mode))
(defmethod current-video-mode ()
@@ -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))
View
68 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"))))
View
10 src/win32/win32.lisp
@@ -395,7 +395,7 @@
dmode devmode)
(setf size (foreign-type-size 'devmode))
(enum-display-settings (cffi:null-pointer) -1 dmode)
- (glop::make-win32-video-mode :width pels-width
+ (glop::make-video-mode :width pels-width
:height pels-height
:depth bits-per-pixel
:rate display-frequency))))
@@ -409,10 +409,10 @@
for res = (enum-display-settings (cffi:null-pointer) mode-index dmode)
do (incf mode-index)
until (zerop res)
- collect (glop::make-win32-video-mode :width pels-width
- :height pels-height
- :depth bits-per-pixel
- :rate display-frequency)))))
+ collect (glop::make-video-mode :width pels-width
+ :height pels-height
+ :depth bits-per-pixel
+ :rate display-frequency)))))
(defun set-video-mode (mode)
(let ((width (glop::video-mode-width mode))
View
71 src/x11/glop-x11.lisp
@@ -17,24 +17,24 @@
for rate = (third res)
for index = (fourth res)
do (loop for depth in depth-list
- do (push (make-x11-video-mode :width width
- :height height
- :depth depth
- :rate rate
- :index index)
+ do (push (make-video-mode :width width
+ :height height
+ :depth depth
+ :rate rate
+ :index index)
modes)))))
modes))
-(defmethod set-video-mode ((mode x11-video-mode))
+(defmethod set-video-mode ((mode video-mode))
(glop-xlib::with-current-display dpy
- (glop-xlib::set-mode dpy 0 (x11-video-mode-index mode)
- (x11-video-mode-rate mode))))
+ (glop-xlib::set-mode dpy 0 (video-mode-index mode)
+ (video-mode-rate mode))))
(defmethod current-video-mode ()
(glop-xlib::with-current-display dpy
(multiple-value-bind (width height depth rate index)
(glop-xlib::current-mode dpy 0)
- (make-x11-video-mode :width width :height height :depth depth
+ (make-video-mode :width width :height height :depth depth
:rate rate :index index))))
(defstruct glx-context
@@ -42,34 +42,37 @@
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)
- (let ((ctx (make-glx-context :display (x11-window-display win))))
- (setf (glx-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-glx:glx-create-specific-context (x11-window-display win)
- (x11-window-fb-config win)
- attrs))
- (glop-glx:glx-create-context (x11-window-display win)
- (x11-window-visual-infos win))))
- (when make-current
- (attach-gl-context win ctx))
- (when (and major minor)
- (glop-glx:correct-context? major minor))
- ctx))
+ (without-fp-traps
+ (let ((ctx (make-glx-context :display (x11-window-display win))))
+ (setf (glx-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-glx:glx-create-specific-context (x11-window-display win)
+ (x11-window-fb-config win)
+ attrs))
+ (glop-glx:glx-create-context (x11-window-display win)
+ (x11-window-visual-infos win))))
+ (when make-current
+ (attach-gl-context win ctx))
+ (when (and major minor)
+ (glop-glx:correct-context? major minor))
+ ctx)))
(defmethod destroy-gl-context ((ctx glx-context))
(detach-gl-context ctx)
View
8 src/x11/glx.lisp
@@ -54,9 +54,9 @@
(:bad-enum))
(define-foreign-library opengl
- (t (:or (:default "libGL")
- "libGL.so.1"
- "libGL.so.2")))
+ (:darwin (:framework "OpenGL"))
+ (:windows "opengl32.dll" :convention :stdcall)
+ (:unix (:or "libGL.so.4" "libGL.so.3" "libGL.so.2" "libGL.so.1" "libGL.so")))
(use-foreign-library opengl)
(defctype fb-config :pointer)
@@ -182,7 +182,7 @@
(redirect :boolean))
(defun glx-create-context (dpy visual)
- (let ((ctx (%glx-create-context dpy visual (null-pointer) 1)))
+ (let ((ctx (%glx-create-context dpy visual (null-pointer) t)))
(when (null-pointer-p ctx)
(error "Unable to create context"))
ctx))

No commit comments for this range

Something went wrong with that request. Please try again.