[cello-cvs] CVS cello/kt-opengl
ktilton
ktilton at common-lisp.net
Mon Jul 3 00:35:16 UTC 2006
Update of /project/cello/cvsroot/cello/kt-opengl
In directory clnet:/tmp/cvs-serv10432/kt-opengl
Modified Files:
gl-constants.lisp gl-def.lisp gl-functions.lisp
glu-functions.lisp kt-opengl.lpr ogl-macros.lisp
Log Message:
--- /project/cello/cvsroot/cello/kt-opengl/gl-constants.lisp 2006/05/27 06:01:38 1.1
+++ /project/cello/cvsroot/cello/kt-opengl/gl-constants.lisp 2006/07/03 00:35:15 1.2
@@ -174,6 +174,15 @@
(dfc gl_t2f_c4f_n3f_v3f #x2a2c)
(dfc gl_t4f_c4f_n3f_v4f #x2a2d)
+(defun matrix-mode-symbol (n)
+ (ecase n
+ (#x1700 'gl_modelview)
+ (#x1701 'gl_projection)
+ (#x1702 'gl_texture)))
+
+#+test
+(assert (eq 'gl_modelview (matrix-mode-symbol #x1700)))
+
#| matrix mode |#
(dfc gl_modelview #x1700)
(dfc gl_projection #x1701)
--- /project/cello/cvsroot/cello/kt-opengl/gl-def.lisp 2006/05/27 06:01:38 1.1
+++ /project/cello/cvsroot/cello/kt-opengl/gl-def.lisp 2006/07/03 00:35:16 1.2
@@ -26,6 +26,7 @@
`(defun-ffx ,rtn ,module$ ,name$ (, at type-args)
(progn
;;(cells::count-it ,(intern (string-upcase name$) :keyword))
+ ;;(format t "~&~(~a~) ~{ ~a~}" ,name$ (list ,@(loop for (nil arg) on type-args by #'cddr collecting arg)))
(glec ',(intern name$)))))
(defun aforef (o n)
--- /project/cello/cvsroot/cello/kt-opengl/gl-functions.lisp 2006/05/27 06:01:38 1.1
+++ /project/cello/cvsroot/cello/kt-opengl/gl-functions.lisp 2006/07/03 00:35:16 1.2
@@ -22,7 +22,6 @@
(in-package #:kt-opengl)
-
(defparameter *ogl-listing-p* nil)
(defun-ogl :void "open-gl" "glFlush" ())
@@ -342,7 +341,9 @@
(defun-ogl :void "open-gl" "glScalef" (glfloat x glfloat y glfloat z ))
(defun-ogl :void "open-gl" "glTranslated" (gldouble x gldouble y gldouble z ))
(defun-ogl :void "open-gl" "glTranslatef" (glfloat x glfloat y glfloat z ))
-
+#+diehard (DEFUN-FFX :VOID "open-gl" "glTranslatef" (GLFLOAT X GLFLOAT Y GLFLOAT Z)
+ (PROGN (GLEC '|glTranslatef|)
+ (ukt:trc (or (not (zerop x))(not (zerop y))) "TRANSLATED" x y z)))
(defun-ogl :void "open-gl" "glBitmap" (glsizei width glsizei height
glfloat xorig glfloat yorig
glfloat xmove glfloat ymove
--- /project/cello/cvsroot/cello/kt-opengl/glu-functions.lisp 2006/05/27 06:01:38 1.1
+++ /project/cello/cvsroot/cello/kt-opengl/glu-functions.lisp 2006/07/03 00:35:16 1.2
@@ -118,7 +118,6 @@
(dfc GLU_TESS_COORD_TOO_LARGE GLU_TESS_ERROR5)
(dfc GLU_TESS_NEED_COMBINE_CALLBACK GLU_TESS_ERROR6)
-
;;; **** NURBS constants ****/
;;; NurbsProperty */
@@ -136,7 +135,6 @@
(dfc GLU_PARAMETRIC_ERROR 100216)
(dfc GLU_DOMAIN_DISTANCE 100217)
-
;;; NurbsTrim */
(dfc GLU_MAP1_TRIM_2 100210)
(dfc GLU_MAP1_TRIM_3 100211)
@@ -153,7 +151,6 @@
(dfc GLU_NURBS_ERROR1 100251)
(dfc GLU_NURBS_ERROR37 100287)
-
(defun-ogl (* glubyte) "gl-util" "gluErrorString" (glenum error))
;;;(defun-ogl GLubyte *"gl-util" "gluGetString" (GLenum name))
;;;(defun-ogl void "gl-util" "gluLoadSamplingMatrices" (GLUnurbs *nurb GLfloat *model GLfloat *perspective GLint *view))
--- /project/cello/cvsroot/cello/kt-opengl/kt-opengl.lpr 2006/06/26 17:05:33 1.2
+++ /project/cello/cvsroot/cello/kt-opengl/kt-opengl.lpr 2006/07/03 00:35:16 1.3
@@ -1,4 +1,4 @@
-;; -*- lisp-version: "8.0 [Windows] (Jun 21, 2006 9:54)"; cg: "1.81"; -*-
+;; -*- lisp-version: "8.0 [Windows] (Jun 28, 2006 10:53)"; cg: "1.81"; -*-
(in-package :cg-user)
--- /project/cello/cvsroot/cello/kt-opengl/ogl-macros.lisp 2006/06/26 17:05:33 1.3
+++ /project/cello/cvsroot/cello/kt-opengl/ogl-macros.lisp 2006/07/03 00:35:16 1.4
@@ -24,6 +24,9 @@
(in-package :kt-opengl)
+(eval-when (compile load eval)
+ (export '(with-gl-translation)))
+
(defvar *stack-depth*
(fgn-alloc :int 1 :ignore))
@@ -41,34 +44,42 @@
(funcall matrix-fn))
(gl-pop-matrix)))
+(defun get-stack-depth (mm)
+ (gl-get-integerv
+ (ecase (matrix-mode-symbol mm)
+ (gl_modelview gl_modelview_stack_depth)
+ (gl_projection gl_projection_stack_depth)
+ (gl_texture gl_texture_stack_depth))
+ *stack-depth*)
+ (aforef *stack-depth* 0))
+
+(defun get-matrix-mode ()
+ (gl-get-integerv gl_matrix_mode *ogl-int*)
+ (eltgli *ogl-int* 0))
+
#+debugversion
(defun call-with-matrix (load-identity-p matrix-fn matrix-code)
- (let ((mm-pushed (ogl::get-matrix-mode))
- (sd-pushed (ogl::get-stack-depth)))
-
- (gl-push-matrix)
- (glec :with-matrix-push)
- (unwind-protect
- (progn
- (when (eql gl_modelview_matrix mm-pushed)
- (gl-get-integerv gl_modelview_stack_depth *stack-depth*)
- (glec :get-stack-depth)
- (print `(with-matrix model matrix stack ,(aforef *stack-depth* 0))))
-
- (when load-identity-p
- (gl-load-identity))
- (prog1
- (funcall matrix-fn)
- (glec :with-matrix)))
- (assert (eql mm-pushed (ogl::get-matrix-mode))()
- "matrix-mode left as ~a instead of ~a by form ~a"
- (ogl::get-matrix-mode) mm-pushed matrix-code)
- (gl-pop-matrix)
- (assert (eql sd-pushed (ogl::get-stack-depth))()
- "matrix depth deviated ~d during ~a"
- (- sd-pushed (ogl::get-stack-depth))
- matrix-code)
- (glec :exit-with-stack))))
+ (let* ((mm-pushed (get-matrix-mode))
+ (sd-pushed (get-stack-depth mm-pushed)))
+ (ukt::wtrc (0 100 "with-matrix starts with mode" (matrix-mode-symbol mm-pushed) :depth sd-pushed)
+ (gl-push-matrix)
+ (unwind-protect
+ (progn
+ (when load-identity-p
+ (gl-load-identity))
+ (prog1
+ (funcall matrix-fn)
+ (glec :with-matrix-body)))
+ (assert (eql mm-pushed (get-matrix-mode))()
+ "matrix-mode left as ~a instead of ~a by form ~a"
+ (ogl::get-matrix-mode) mm-pushed matrix-code)
+ (ukt:trc "poppping matrix!!!!!" (matrix-mode-symbol (get-matrix-mode)) :from-depth (get-stack-depth (get-matrix-mode)))
+ (gl-pop-matrix)
+ (assert (eql sd-pushed (get-stack-depth mm-pushed))()
+ "matrix depth deviated ~d during ~a"
+ (- sd-pushed (get-stack-depth mm-pushed))
+ matrix-code)
+ (glec :exit-with-stack)))))
(defmacro with-attrib ((&rest attribs) &body body)
`(call-with-attrib
@@ -148,16 +159,19 @@
(kt-opengl-init))
(defun glec (&optional (id :anon))
- (unless (and (boundp '*gl-begun*) *gl-begun*)
+ (if (and (boundp '*gl-begun*) *gl-begun*)
+ (progn #+shhh (ukt:trc "not checking error inside gl-begin" id))
(let ((e (glgeterror)))
(if (zerop e)
(unless t ;; (find id '(glutcheckloop glutgetwindow))
(print `(cool ,id)))
(if t ;; (null (find id '(glutInitDisplayMode glutInitWindowSize)))
- (unless (boundp '*gl-stop*)
- (setf *gl-stop* t)
- (format t "~&~%OGL error ~a at ID ~a" e id)
- ;(break "OGL error ~a at ID ~a" e id)
- )
+ (if (boundp '*gl-stop*)
+ (ukt:trc "error but *gl-stop* already bound" e id)
+ (progn
+ (setf *gl-stop* t)
+ (format t "~&~%OGL error ~a at ID ~a" e id)
+ (break "OGL error ~a at ID ~a" e id)
+ ))
#+sigh (print `("OGL error ~a at ID ~a" ,e ,id)))))))
More information about the Cello-cvs
mailing list