Use the GLUT Framework on Darwin
Sat Jul 25 15:55:54 PDT 2009 Luis Oliveira <loliveira@common-lisp.net>
* Use the GLUT Framework on Darwin
Patch courtesy of Xristos <xristos@suspicious.org> and others.
diff -rN -u old-cl-opengl/glut/callbacks.lisp new-cl-opengl/glut/callbacks.lisp
--- old-cl-opengl/glut/callbacks.lisp 2014-08-01 02:50:36.000000000 -0700
+++ new-cl-opengl/glut/callbacks.lisp 2014-08-01 02:50:36.000000000 -0700
@@ -137,12 +137,14 @@
(poll-interval :int))
;; freeglut ext
+#-darwin
(defcfun ("glutMouseWheelFunc" mouse-wheel-func) :void
;; void (*func)(int button, int pressed, int x, int y)
(callback-pointer :pointer))
-;; freeglut ext
-(defcfun ("glutCloseFunc" close-func) :void
+;; freeglut/GLUT.framework ext
+(defcfun (#-darwin "glutCloseFunc"
+ #+darwin "glutWMCloseFunc" close-func) :void
;; void (*func)(void)
(callback-pointer :pointer))
@@ -152,6 +154,7 @@
(callback-pointer :pointer))
;; freeglut ext
+#-darwin
(defcfun ("glutMenuDestroyFunc" menu-destroy-func) :void
;; void (*func)(void)
(callback-pointer :pointer))
diff -rN -u old-cl-opengl/glut/fonts.lisp new-cl-opengl/glut/fonts.lisp
--- old-cl-opengl/glut/fonts.lisp 2014-08-01 02:50:36.000000000 -0700
+++ new-cl-opengl/glut/fonts.lisp 2014-08-01 02:50:36.000000000 -0700
@@ -107,19 +107,23 @@
(string :string))
;; freeglut ext
+#-darwin
(defcfun ("glutBitmapHeight" bitmap-height) :int
(font :pointer))
;; freeglut ext
+#-darwin
(defcfun ("glutStrokeHeight" stroke-height) %gl:float
(font :pointer))
;; freeglut ext
+#-darwin
(defcfun ("glutBitmapString" bitmap-string) :void
(font :pointer)
(string :string))
;; freeglut ext
+#-darwin
(defcfun ("glutStrokeString" stroke-string) :void
(font :pointer)
(string :string))
\ No newline at end of file
diff -rN -u old-cl-opengl/glut/geometry.lisp new-cl-opengl/glut/geometry.lisp
--- old-cl-opengl/glut/geometry.lisp 2014-08-01 02:50:36.000000000 -0700
+++ new-cl-opengl/glut/geometry.lisp 2014-08-01 02:50:36.000000000 -0700
@@ -92,33 +92,42 @@
;;; The following are freeglut extensions:
+#-darwin
(defcfun ("glutWireRhombicDodecahedron" wire-rhombic-dodecahedron) :void)
+
+#-darwin
(defcfun ("glutSolidRhombicDodecahedron" solid-rhombic-dodecahedron) :void)
+#-darwin
(defcfun ("glutWireSierpinskiSponge" %glutWireSierpinskiSponge) :void
(num-levels :int)
(offset-seq :pointer) ; GLdouble offset[3]
(scale %gl:double))
+#-darwin
(defun wire-sierpinski-sponge (num-levels offset-seq scale)
(gl::with-opengl-sequence (offset '%gl:double offset-seq)
(%glutWireSierpinskiSponge num-levels offset scale)))
+#-darwin
(defcfun ("glutSolidSierpinskiSponge" %glutSolidSierpinskiSponge) :void
(num-levels :int)
(offset-seq :pointer) ; GLdouble offset[3]
(scale %gl:double))
+#-darwin
(defun solid-sierpinski-sponge (num-levels offset-seq scale)
(gl::with-opengl-sequence (offset '%gl:double offset-seq)
(%glutSolidSierpinskiSponge num-levels offset scale)))
+#-darwin
(defcfun ("glutWireCylinder" wire-cylinder) :void
(radius %gl:double)
(height %gl:double)
(slices %gl:int)
(stacks %gl:int))
+#-darwin
(defcfun ("glutSolidCylinder" solid-cylinder) :void
(radius %gl:double)
(height %gl:double)
diff -rN -u old-cl-opengl/glut/init.lisp new-cl-opengl/glut/init.lisp
--- old-cl-opengl/glut/init.lisp 2014-08-01 02:50:36.000000000 -0700
+++ new-cl-opengl/glut/init.lisp 2014-08-01 02:50:36.000000000 -0700
@@ -43,21 +43,71 @@
#-(and sbcl (or x86 x86-64))
`(progn ,@body))
+(defparameter *glut-initialized-p* nil)
+
+#+(and darwin (or openmcl-native-threads sb-thread))
+(defparameter *glut-thread* nil)
+
+(defun make-thread (name function)
+ #+openmcl-native-threads (ccl:process-run-function name function)
+ #+sb-thread (sb-thread:make-thread function :name name)
+ #-(or openmcl-native-threads sb-thread)
+ (error "CL-GLUT::MAKE-THREAD not implemented for this Lisp."))
+
+(defun %init (program-name)
+ (with-foreign-objects ((argcp :int) (argv :pointer))
+ (setf (mem-ref argcp :int) 1)
+ (with-foreign-string (str program-name)
+ (setf (mem-ref argv :pointer) str)
+ (%glutInit argcp argv)
+ (setf *glut-initialized-p* t)))
+ ;; By default, we choose the saner option to return from the event
+ ;; loop on window close instead of exit()ing.
+ (set-action-on-window-close :action-continue-execution)
+ ;; this probably doesn't play well with other toolkits
+ (setq %gl:*gl-get-proc-address* 'get-proc-address)
+ (values))
+
+;;; From CCL's opengl-ffi:
+;;;
+;;; "On OSX, we need to use an undocumented API or two to ensure that
+;;; the thread we're creating is seen as the 'main' event handling
+;;; thread (that's what the code that sets the current thread's
+;;; CFRunLoop to the main CFRunLoop does.)"
+
+#+(and darwin (or sb-thread openmcl-native-threads))
+(progn
+ (defcfun ("CFRunLoopGetCurrent" cf-run-loop-get-current) :pointer)
+ (defcfun ("_CFRunLoopSetCurrent" cf-run-loop-set-current)
+ :pointer (arg :pointer))
+ (defcfun ("CFRunLoopGetMain" cf-run-loop-get-main) :pointer))
+
(defun init (&optional (program-name (lisp-implementation-type)))
(without-fp-traps
- ;; freeglut will exit() if we try to call initGlut() when
- ;; things are already initialized.
- (unless (getp :init-state)
- (with-foreign-objects ((argcp :int) (argv :pointer))
- (setf (mem-ref argcp :int) 1)
- (with-foreign-string (str program-name)
- (setf (mem-ref argv :pointer) str)
- (%glutInit argcp argv)))
- ;; By default, we choose the saner option to return from the event
- ;; loop on window close instead of exit()ing.
- (set-action-on-window-close :action-continue-execution)
- ;; this probably doesn't play well with other toolkits
- (setq %gl:*gl-get-proc-address* 'get-proc-address)))
+ ;; freeglut will exit() if we try to call initGlut() when
+ ;; things are already initialized.
+ (unless *glut-initialized-p*
+ #+(and darwin (or sb-thread openmcl-native-threads))
+ (setf *glut-thread*
+ (make-thread
+ "CL-GLUT thread"
+ (lambda ()
+ ;; In OSX, a "run loop" is a data structure that
+ ;; describes how event-handling code should block for
+ ;; events, timers, and other event sources. Ensure that
+ ;; this thread has a "current run loop". (Under some
+ ;; circumstances, there may not yet be a "main" run
+ ;; loop; setting the "current" ensures that a main loop
+ ;; exists.)
+ (cf-run-loop-get-current)
+ ;; Make the current thread's run loop be the "main" one;
+ ;; only the main run loop can interact with the window
+ ;; server.
+ (cf-run-loop-set-current (cf-run-loop-get-main))
+ (%init program-name)
+ (loop (sleep 1)))))
+ #-(and darwin (or sb-thread openmcl-native-threads))
+ (%init program-name)))
(values))
;; We call init at load-time in order to ensure a usable glut as often
diff -rN -u old-cl-opengl/glut/interface.lisp new-cl-opengl/glut/interface.lisp
--- old-cl-opengl/glut/interface.lisp 2014-08-01 02:50:36.000000000 -0700
+++ new-cl-opengl/glut/interface.lisp 2014-08-01 02:50:36.000000000 -0700
@@ -189,7 +189,6 @@
(mouse-wheel (window (button mouse-button) (pressed mouse-button-state)
(x :int) (y :int)))
(close (window))
- ;; (wm-close (window)) ; synonym for CLOSE
(menu-destroy (window)))
;;; These two functions should not be called directly and are called
@@ -220,6 +219,7 @@
(defclass base-window ()
((name :reader name :initarg :name :initform (gensym "GLUT-WINDOW"))
(id :reader id)
+ (destroyed :accessor destroyed :initform nil)
(pos-x :accessor pos-x :initarg :pos-x)
(pos-y :accessor pos-y :initarg :pos-y)
(height :accessor height :initarg :height)
@@ -305,40 +305,74 @@
(defmethod enable-event ((window base-window) event-name)
(let ((event (find-event-or-lose event-name)))
- (with-window window
- (register-callback event))
- (pushnew event (events window))
- (when (eq event-name :idle)
- (push window *windows-with-idle-event*))))
+ (when (not (find event (events window)))
+ (with-window window
+ (register-callback event))
+ (push event (events window))
+ (when (eq event-name :idle)
+ (push window *windows-with-idle-event*)))))
+
(defmethod disable-event ((window base-window) event-name)
(if (eq event-name :display)
(warn "GLUT would be upset if we set the DISPLAY callback to NULL. ~
So we won't do that.")
(let ((event (find-event-or-lose event-name)))
- ;; We don't actually disable the CLOSE event since we need it
- ;; for bookkeeping. See the CLOSE methods below.
- (unless (or (eq event-name :idle) (eq event-name :close))
- (with-window window
- (unregister-callback event)))
- (setf (events window) (delete event (events window)))
- (when (eq event-name :idle)
- (setq *windows-with-idle-event*
- (delete window *windows-with-idle-event*))))))
+ (when (find event (events window))
+ ;; We don't actually disable the CLOSE event since we need it
+ ;; for bookkeeping. See the CLOSE methods below.
+ (unless (or (eq event-name :idle)
+ (eq event-name :close))
+ (with-window window
+ (unregister-callback event)))
+ (setf (events window) (delete event (events window)))
+ (when (eq event-name :idle)
+ (setq *windows-with-idle-event*
+ (delete window *windows-with-idle-event*))
+ ;; We need to disable the idle callback here too in
+ ;; addition to close.
+ (when (null *windows-with-idle-event*)
+ (unregister-callback event)))))))
(defun destroy-current-window ()
(when-current-window-exists
- (if (game-mode current-window)
- (leave-game-mode)
- (destroy-window (id current-window)))))
+ (cond
+ ((game-mode current-window)
+ (leave-game-mode))
+ (t
+ (destroy-window (id current-window))
+ #+darwin
+ (progn
+ (setf (destroyed current-window) t)
+ (close current-window))))))
(defmethod close :around ((w base-window))
(when (member :close (events w) :key #'event-name)
(call-next-method))
(setf (aref *id->window* (id w)) nil)
(setq *windows-with-idle-event* (delete w *windows-with-idle-event*))
+ #+darwin
+ (when (not (destroyed w))
+ (setf (destroyed w) t)
+ (destroy-window (id w)))
(when (null *windows-with-idle-event*)
- (unregister-callback (find-event-or-lose :idle))))
+ (unregister-callback (find-event-or-lose :idle)))
+ #+darwin
+ (progn
+ (when (= 0 (length (remove-if #'null *id->window*)))
+ ;; We want to leave the glut event loop if all glut windows are
+ ;; closed, even when :action-continue-execution is set.
+ (leave-main-loop))
+ (ecase *window-close-action*
+ ;; :action-exit is probably unnecessary, as it should never be used.
+ (:action-exit
+ #+sbcl (sb-ext:quit)
+ #+ccl (ccl:quit)
+ #-(or sbcl ccl) (warn "Don't know how to quit."))
+ (:action-glutmainloop-returns
+ (leave-main-loop))
+ (:action-continue-execution
+ nil))))
(defmethod close ((w base-window))
(values))
@@ -409,24 +443,3 @@
(defmethod display-window :around ((win sub-window))
(setf (slot-value win 'id) (create-sub-window (id (parent win)) 0 0 0 0))
(call-next-method))
-
-;;;; For posterity
-
-;;; "This is quite ugly: OS X is very picky about which thread gets to handle
-;;; events and only allows the main thread to do so. We need to run any event
-;;; loops in the initial thread on multithreaded Lisps, or in this case,
-;;; OpenMCL."
-
-;; #-openmcl
-;; (defun run-event-loop ()
-;; (glut:main-loop))
-
-;; #+openmcl
-;; (defun run-event-loop ()
-;; (flet ((start ()
-;; (ccl:%set-toplevel nil)
-;; (glut:main-loop)))
-;; (ccl:process-interrupt ccl::*initial-process*
-;; (lambda ()
-;; (ccl:%set-toplevel #'start)
-;; (ccl:toplevel)))))
diff -rN -u old-cl-opengl/glut/library.lisp new-cl-opengl/glut/library.lisp
--- old-cl-opengl/glut/library.lisp 2014-08-01 02:50:36.000000000 -0700
+++ new-cl-opengl/glut/library.lisp 2014-08-01 02:50:36.000000000 -0700
@@ -32,9 +32,16 @@
(in-package :cl-glut)
+;;; TODO: check what other (threaded) Lisps might need to load this
+;;; framework which is necessary to setup the necessary magic for
+;;; GLUT's main loop. CCL already loads this framework by default.
+(define-foreign-library core-foundation
+ ((:and :darwin :sb-thread) (:framework "CoreFoundation")))
+
(define-foreign-library glut
- (:darwin (:or "libglut.dylib" "libglut.3.dylib"))
+ (:darwin (:framework "GLUT"))
(:windows "freeglut.dll")
(:unix (:or "libglut.so" "libglut.so.3")))
-(use-foreign-library glut)
\ No newline at end of file
+(use-foreign-library glut)
+(use-foreign-library core-foundation)
\ No newline at end of file
diff -rN -u old-cl-opengl/glut/main.lisp new-cl-opengl/glut/main.lisp
--- old-cl-opengl/glut/main.lisp 2014-08-01 02:50:36.000000000 -0700
+++ new-cl-opengl/glut/main.lisp 2014-08-01 02:50:36.000000000 -0700
@@ -34,11 +34,34 @@
(defcfun ("glutMainLoop" %glutMainLoop) :void)
+#+darwin
+(defcfun ("glutCheckLoop" check-loop) :void)
+
+#-darwin
(defun main-loop ()
(without-fp-traps
(%glutMainLoop))
(init))
-(defcfun ("glutMainLoopEvent" main-loop-event) :void)
+#+(and darwin (or openmcl-native-threads sb-thread))
+(defun interrupt-thread (thread function)
+ #+ccl (ccl:process-interrupt thread function)
+ #+sbcl (sb-thread:interrupt-thread thread function))
+
+#+darwin
+(let ((darwin-run-main-loop-p t))
+ (defun main-loop ()
+ (flet ((%loop ()
+ (without-fp-traps
+ (loop while darwin-run-main-loop-p do (check-loop)))
+ (init)
+ (setf darwin-run-main-loop-p t)))
+ #+(or openmcl-native-threads sb-thread)
+ (interrupt-thread *glut-thread* #'%loop)
+ #-(or openmcl-native-threads sb-thread)
+ (%loop)))
+ (defun leave-main-loop ()
+ (setf darwin-run-main-loop-p nil)))
-(defcfun ("glutLeaveMainLoop" leave-main-loop) :void)
\ No newline at end of file
+#-darwin (defcfun ("glutMainLoopEvent" main-loop-event) :void)
+#-darwin (defcfun ("glutLeaveMainLoop" leave-main-loop) :void)
diff -rN -u old-cl-opengl/glut/misc.lisp new-cl-opengl/glut/misc.lisp
--- old-cl-opengl/glut/misc.lisp 2014-08-01 02:50:36.000000000 -0700
+++ new-cl-opengl/glut/misc.lisp 2014-08-01 02:50:36.000000000 -0700
@@ -73,7 +73,7 @@
(defcfun ("glutGameModeString" game-mode-string) :void
(string :string))
-(defcfun ("glutEnterGameMode" enter-game-mode) :int)
+(defcfun ("glutEnterGameMode" enter-game-mode) #-darwin :int #+darwin :void)
(defcfun ("glutLeaveGameMode" leave-game-mode) :void)
(defcenum (game-mode-param %gl:enum)
diff -rN -u old-cl-opengl/glut/state.lisp new-cl-opengl/glut/state.lisp
--- old-cl-opengl/glut/state.lisp 2014-08-01 02:50:36.000000000 -0700
+++ new-cl-opengl/glut/state.lisp 2014-08-01 02:50:36.000000000 -0700
@@ -41,6 +41,8 @@
;;; Setting Options
+(defparameter *window-close-action* nil)
+
;; freeglut ext
(defcenum (options %gl:enum)
(:init-window-x #x01F4)
@@ -54,10 +56,16 @@
(:window-cursor #x007A))
;;; freeglut ext
+#-darwin
(defcfun ("glutSetOption" set-option) :void
(option options)
(value :int))
+#+darwin
+(defun set-option (val1 val2)
+ (declare (ignore val1 val2))
+ (warn "GLUT:SET-OPTION not supported in GLUT.framework"))
+
;;; Also provide some utility functions around glutSetOption().
;; freeglut ext
@@ -101,8 +109,10 @@
(foreign-bitfield-value 'display-mode options)))
(defun set-action-on-window-close (action)
+ #-darwin
(set-option :action-on-window-close
- (foreign-enum-value 'window-close-behaviour action)))
+ (foreign-enum-value 'window-close-behaviour action))
+ (setf *window-close-action* action))
(defun set-rendering-context (option)
(set-option :rendering-context
@@ -156,7 +166,7 @@
:window-border-width ; freeglut ext
:window-header-height ; freeglut ext
:version ; freeglut ext
- :rendering-context ; freeglut ext
+ #-darwin :rendering-context ; freeglut ext
:direct-rendering)
(defcfun ("glutGet" get) :int
Warning: CRC errors found. These are probably harmless but should be repaired.
See 'darcs gzcrcs --help' for more information.