Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

New DEFGLEXTFUN and other minor changes

- New DEFGLEXTFUN macro courtesy of Thomas Weidner.
- GLUT: set %gl:*gl-get-proc-address* to glut:get-proc-address.

darcs-hash:20070307010114-28748-18f31c6979d93d8b17ad88c09cebf639c08ab5d2.gz
  • Loading branch information...
commit 37cde45eacf6f25322bf67238f36bfd45bc2ef1d 1 parent 6ea7fac
Luís Oliveira luismbo authored
10 cl-glu.asd
View
@@ -3,20 +3,20 @@
;;; cl-glu.asd --- ASDF system definition for cl-glu.
;;;
;;; Copyright (C) 2006, Luis Oliveira <loliveira@common-lisp.net>
-;;; All rights reserved.
+;;; All rights reserved.
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;
;;; o Redistributions of source code must retain the above copyright
-;;; notice, this list of conditions and the following disclaimer.
+;;; notice, this list of conditions and the following disclaimer.
;;; o Redistributions in binary form must reproduce the above copyright
;;; notice, this list of conditions and the following disclaimer in the
;;; documentation and/or other materials provided with the distribution.
;;; o Neither the name of the author nor the names of the contributors may
;;; be used to endorse or promote products derived from this software
-;;; without specific prior written permission.
+;;; without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
@@ -30,10 +30,6 @@
;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-(defpackage #:cl-glu-system
- (:use #:cl #:asdf))
-(in-package #:cl-glu-system)
-
(defsystem cl-glu
:description "Common Lisp bindings to the GLU API v1.3"
:author "Luis Oliveira <loliveira@common-lisp.net>"
14 cl-glut.asd
View
@@ -3,20 +3,20 @@
;;; cl-glut.asd --- ASDF system definition for cl-glut.
;;;
;;; Copyright (C) 2006, Luis Oliveira <loliveira@common-lisp.net>
-;;; All rights reserved.
+;;; All rights reserved.
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;
;;; o Redistributions of source code must retain the above copyright
-;;; notice, this list of conditions and the following disclaimer.
+;;; notice, this list of conditions and the following disclaimer.
;;; o Redistributions in binary form must reproduce the above copyright
;;; notice, this list of conditions and the following disclaimer in the
;;; documentation and/or other materials provided with the distribution.
;;; o Neither the name of the author nor the names of the contributors may
;;; be used to endorse or promote products derived from this software
-;;; without specific prior written permission.
+;;; without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
@@ -30,10 +30,6 @@
;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-(defpackage #:cl-glut-system
- (:use #:cl #:asdf))
-(in-package #:cl-glut-system)
-
(defsystem cl-glut
:description "Common Lisp bindings to Freeglut."
:author "Luis Oliveira <loliveira@common-lisp.net>"
@@ -47,12 +43,12 @@
(:file "library" :depends-on ("package"))
(:file "state" :depends-on ("library"))
(:file "init" :depends-on ("library" "state"))
- (:file "main" :depends-on ("library" "init"))
+ (:file "main" :depends-on ("library" "init"))
(:file "window" :depends-on ("library"))
(:file "overlay" :depends-on ("library"))
(:file "menu" :depends-on ("library"))
(:file "callbacks" :depends-on ("library"))
- (:file "misc" :depends-on ("library"))
+ (:file "misc" :depends-on ("library"))
(:file "fonts" :depends-on ("library"))
(:file "geometry" :depends-on ("library"))
(:file "interface"
8 cl-opengl.asd
View
@@ -27,8 +27,8 @@
;;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
;;; POSSIBILITY OF SUCH DAMAGE.
-(defsystem :cl-opengl
- :depends-on (:cffi)
+(defsystem cl-opengl
+ :depends-on (cffi)
:components
((:module "gl"
:components
@@ -37,10 +37,10 @@
(:file "types" :depends-on ("bindings-package"))
(:file "library" :depends-on ("bindings-package"))
(:file "constants" :depends-on ("bindings"))
- (:file "funcs" :depends-on ("bindings" "constants" "library"))
+ (:file "funcs" :depends-on ("bindings" "constants" "library" "types"))
;; Lispifications.
(:file "package" :depends-on ("bindings-package"))
- (:file "util" :depends-on ("constants" "types"))
+ (:file "util" :depends-on ("constants" "types" "package"))
(:file "opengl" :depends-on ("funcs" "util"))
(:file "rasterization" :depends-on ("funcs" "util"))
(:file "framebuffer" :depends-on ("funcs" "util"))
8 examples/mesademos/gears.lisp
View
@@ -22,7 +22,7 @@
(gl:shade-model :flat)
(gl:normal 0 0 1)
;; Draw front face.
- (gl:with-primitives :quad-strip
+ (gl:with-primitives :quad-strip
(dotimes (i (1+ n-teeth))
(let ((angle (/ (* i 2.0 +pif+) n-teeth)))
(gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5))
@@ -54,7 +54,7 @@
(gl:vertex (* r1 (cos (+ angle (* 3 da))))
(* r1 (sin (+ angle (* 3 da))))
(* width -0.5))
- (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width -0.5)))))
+ (gl:vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width -0.5)))))
;; Draw back sides of teeth.
(gl:with-primitives :quads
(dotimes (i n-teeth)
@@ -171,7 +171,7 @@
(gl:with-pushed-matrix ; gear1
(gl:translate -3 -2 0)
(gl:rotate angle 0 0 1)
- (gl:call-list gear1))
+ (gl:call-list gear1))
(gl:with-pushed-matrix ; gear2
(gl:translate 3.1 -2 0)
(gl:rotate (- (* -2 angle) 9) 0 0 1)
@@ -188,7 +188,7 @@
(glut:post-redisplay))
(defmethod glut:keyboard ((window gears-window) key x y)
- (declare (ignore x y))
+ (declare (ignore x y))
(case key
(#\z (incf (slot-value window 'view-rotz) 5.0)
(glut:post-redisplay))
109 gl/bindings.lisp
View
@@ -30,67 +30,100 @@
(in-package #:cl-opengl-bindings)
;;; Helper macro to define a GL API function and declare it inline.
-;;;
-;;; FIXME: LISP-FUNCTION-NAME should probably be exported from CFFI
-;;; for helper macros like this one.
(defmacro defglfun (name result-type &body body)
(let ((lisp-name (second name)))
`(progn
(declaim (inline ,lisp-name))
(defcfun ,name ,result-type ,@body))))
-;;; Helpers for wrapping dynamically loaded extension function pointers
-;;;
+;;;; Extensions
+
;;; TODO: need to handle multiple contexts.
;;;
;;; TODO: probably should have the option of using directly exported
-;;; functions on platforms that have them, but that would need to deal
-;;; with the possibility of a core being loaded on a system with different
-;;; functions exported than the one on which the core was saved.
+;;; functions on platforms that have them, but that would need
+;;; to deal with the possibility of a core being loaded on a
+;;; system with different functions exported than the one on
+;;; which the core was saved.
-(defparameter *gl-extension-resetter-list* nil)
-(defun %reset-gl-extension-pointers ()
- (format t " resetting extension pointers ...") (finish-output)
- ;; fixme?: race here, but intended to be called while saving an
- ;; image, so if someone is still calling GL functions we lose
- ;; anyway...
- (mapc #'funcall *gl-extension-resetter-list*)
- (setf *gl-extension-resetter-list* nil))
+;;; Set this to a function which knows how to get a GL extension
+;;; pointer from the OS: glutGetProcAddress(), SDL_GL_GetProcAddress(),
+;;; wglGetProcAddress(), etc.
+(defparameter *gl-get-proc-address* nil)
+
+(defun gl-get-proc-address (name)
+ (funcall *gl-get-proc-address* name))
(eval-when (:load-toplevel :execute)
- #+clisp (pushnew #'%reset-gl-extension-pointers custom:*fini-hooks*)
- #+sbcl (pushnew #'%reset-gl-extension-pointers sb-ext:*save-hooks*)
- #+cmu (pushnew #'%reset-gl-extension-pointers
- ext:*before-save-initializations*)
+ #+clisp (pushnew 'reset-gl-pointers custom:*fini-hooks*)
+ #+sbcl (pushnew 'reset-gl-pointers sb-ext:*save-hooks*)
+ #+cmu (pushnew 'reset-gl-pointers ext:*before-save-initializations*)
#-(or clisp sbcl cmu)
(warn "Don't know how to setup a hook before saving cores on this Lisp."))
-(defparameter *gl-get-proc-address* nil
- "set this to a function which knows how to get a GL extension
- pointer from the OS (glutGetProcAddress, SDL_GL_GetProcAddress,
- wglGetProcAddress, etc.)")
+;;;; Bart's version of DEFGLEXTFUN.
+
+#-(and)
+(defparameter *gl-extension-resetter-list* nil)
-(defun %gl-get-proc-address (name)
- "override this with something useful..."
- (if (and *gl-get-proc-address* (functionp *gl-get-proc-address*))
- (funcall *gl-get-proc-address* name)
- (error "no glGetProcAddress specified!")))
+;;; FIXME? There's a possible race condition here, but this function
+;;; is intended to be called while saving an image, so if someone is
+;;; still calling GL functions we lose anyway...
+#-(and)
+(defun reset-gl-pointers ()
+ (format t "~&;; resetting extension pointers...~%")
+ (mapc #'funcall *gl-extension-resetter-list*)
+ (setf *gl-extension-resetter-list* nil))
+#-(and)
(defmacro defglextfun ((cname lname &rest fargs) return-type &body args)
- (let ((pointer (gensym "GLEXT-FUN-POINTER")))
- `(let ((,pointer (cffi:null-pointer)))
+ (with-unique-names (pointer)
+ `(let ((,pointer (null-pointer)))
(defun ,lname ,(mapcar #'car args)
- (when (cffi:null-pointer-p ,pointer)
+ (when (null-pointer-p ,pointer)
(setf ,pointer (%gl-get-proc-address ,cname))
- (assert (not (cffi:null-pointer-p ,pointer))
- () "couldn't load symbol ~a ~%" ,cname)
- (format t "loaded function pointer for ~a : ~a ~%"
- ,cname ,pointer)
- (push (lambda ()
- (setf ,pointer (cffi:null-pointer)))
+ (assert (not (null-pointer-p ,pointer)) ()
+ "Couldn't load symbol ~A~%" ,cname)
+ (format t "Loaded function pointer for ~A: ~A~%" ,cname ,pointer)
+ (push (lambda () (setf ,pointer (null-pointer)))
*gl-extension-resetter-list*))
(foreign-funcall-pointer
,pointer
,fargs
,@(loop for arg in args collect (second arg) collect (first arg))
,return-type)))))
+
+;;;; Thomas's version of DEFGLEXTFUN.
+
+(defun reset-gl-pointers ()
+ (do-external-symbols (sym (find-package '#:%gl))
+ (let ((dummy (get sym 'proc-address-dummy)))
+ (when dummy
+ (setf (fdefinition sym) dummy)))))
+
+(defun generate-gl-function (foreign-name lisp-name function-args result-type
+ body &rest args)
+ (let ((address (gl-get-proc-address foreign-name))
+ (arg-list (mapcar #'first body)))
+ (when (pointer-eq address (null-pointer))
+ (error "Couldn't find function ~A" foreign-name))
+ (compile lisp-name
+ `(lambda ,arg-list
+ (foreign-funcall-pointer
+ ,address
+ ,function-args
+ ,@(loop for i in body
+ collect (second i)
+ collect (first i))
+ ,result-type)))
+ (apply lisp-name args)))
+
+(defmacro defglextfun ((foreign-name lisp-name &rest function-args)
+ result-type &rest body)
+ (let ((args-list (mapcar #'first body)))
+ `(progn
+ (defun ,lisp-name ,args-list
+ (generate-gl-function ,foreign-name ',lisp-name ',function-args
+ ',result-type ',body ,@args-list))
+ (setf (get ',lisp-name 'proc-address-dummy) #',lisp-name)
+ ',lisp-name)))
2  gl/package.lisp
View
@@ -133,7 +133,7 @@
;; 3.5.2 Stippling
#:polygon-stipple
;; 3.5.4 Options Controlling Polygon Rasterization
- #:polygon-mode
+ #:polygon-mode
#:polygon-offset
;; 3.8.1 Texture Image Specification
#:tex-image-1d
5 glut/init.lisp
View
@@ -59,7 +59,10 @@
(%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)))
+ (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))
;; We call init at load-time in order to ensure a usable glut as
;; often as possible. Also, we call init when the main event loop
6 glut/package.lisp
View
@@ -57,7 +57,7 @@
#:rendering-context-options
#:joystick-buttons
#:special-keys
- #:visibility-state
+ #:visibility-state
#:options ; freeglut ext
#:window-close-behaviour ; freeglut ext
#:window-status
@@ -125,7 +125,7 @@
#:special-func
#:reshape-func
#:visibility-func
- #:display-func
+ #:display-func
#:mouse-func
#:motion-func
#:passive-motion-func
@@ -230,7 +230,7 @@
#:stop-video-resizing
#:video-resize
#:video-pan
-
+
;; misc
#:set-color
#:get-color
Please sign in to comment.
Something went wrong with that request. Please try again.