From ktilton at common-lisp.net Tue Jul 5 17:00:32 2005 From: ktilton at common-lisp.net (Kenny Tilton) Date: Tue, 5 Jul 2005 19:00:32 +0200 (CEST) Subject: [cello-cvs] CVS update: cello/cellodemo/cellodemo.asd cello/cellodemo/cellodemo.lisp cello/cellodemo/cellodemo.lpr cello/cellodemo/cll.lisp cello/cellodemo/demo-window.lisp cello/cellodemo/hedron-decoration.lisp cello/cellodemo/hedron-render.lisp cello/cellodemo/install-notes.txt cello/cellodemo/light-panel.lisp cello/cellodemo/tutor-geometry.lisp cello/cellodemo/virtual-human.lisp Message-ID: <20050705170032.0DF57880DF@common-lisp.net> Update of /project/cello/cvsroot/cello/cellodemo In directory common-lisp.net:/tmp/cvs-serv18729/cellodemo Added Files: cellodemo.asd cellodemo.lisp cellodemo.lpr cll.lisp demo-window.lisp hedron-decoration.lisp hedron-render.lisp install-notes.txt light-panel.lisp tutor-geometry.lisp virtual-human.lisp Log Message: Filling in omitted subdirectory Date: Tue Jul 5 19:00:29 2005 Author: ktilton From ktilton at common-lisp.net Fri Jul 8 16:26:51 2005 From: ktilton at common-lisp.net (Kenny Tilton) Date: Fri, 8 Jul 2005 18:26:51 +0200 (CEST) Subject: [cello-cvs] CVS update: cl-opengl/cl-opengl.lisp cl-opengl/gl-constants.lisp cl-opengl/gl-functions.lisp cl-opengl/glu-functions.lisp cl-opengl/nehe-14.lisp cl-opengl/ogl-macros.lisp cl-opengl/ogl-utils.lisp Message-ID: <20050708162651.69B9988536@common-lisp.net> Update of /project/cello/cvsroot/cl-opengl In directory common-lisp.net:/tmp/cvs-serv29876 Modified Files: cl-opengl.lisp gl-constants.lisp gl-functions.lisp glu-functions.lisp nehe-14.lisp ogl-macros.lisp ogl-utils.lisp Log Message: Filling in omitted subdirectory Date: Fri Jul 8 18:26:48 2005 Author: ktilton Index: cl-opengl/cl-opengl.lisp diff -u cl-opengl/cl-opengl.lisp:1.1 cl-opengl/cl-opengl.lisp:1.2 --- cl-opengl/cl-opengl.lisp:1.1 Wed May 25 05:14:30 2005 +++ cl-opengl/cl-opengl.lisp Fri Jul 8 18:26:47 2005 @@ -31,8 +31,8 @@ #:glut-get-window #:glut-set-window #:glut-post-redisplay - #:with-matrix - #:with-attrib + #:with-matrix #:with-matrix-mode + #:with-attrib #:with-client-attrib #:with-gl-begun #:gl-pushm #:gl-popm Index: cl-opengl/gl-constants.lisp diff -u cl-opengl/gl-constants.lisp:1.1 cl-opengl/gl-constants.lisp:1.2 --- cl-opengl/gl-constants.lisp:1.1 Wed May 25 05:14:30 2005 +++ cl-opengl/gl-constants.lisp Fri Jul 8 18:26:47 2005 @@ -347,6 +347,9 @@ (dfc gl_texture_matrix #x0ba8) (dfc gl_attrib_stack_depth #x0bb0) (dfc gl_client_attrib_stack_depth #x0bb1) +(dfc gl_client_pixel_store_bit #x00000001) +(dfc gl_client_vertex_array_bit #x00000002) +(dfc gl_client_all_attrib_bits #xffffffff) (dfc gl_alpha_test #x0bc0) (dfc gl_alpha_test_func #x0bc1) (dfc gl_alpha_test_ref #x0bc2) Index: cl-opengl/gl-functions.lisp diff -u cl-opengl/gl-functions.lisp:1.1 cl-opengl/gl-functions.lisp:1.2 --- cl-opengl/gl-functions.lisp:1.1 Wed May 25 05:14:31 2005 +++ cl-opengl/gl-functions.lisp Fri Jul 8 18:26:47 2005 @@ -162,8 +162,12 @@ (defun-ffx :void "open-gl" "glTexParameterfv" (glenum target glenum pname glfloat *params)) (defun-ffx :void "open-gl" "glTexParameteri" (glenum target glenum pname glint param)) (defun-ffx :void "open-gl" "glTexParameteriv" (glenum target glenum pname glint *params)) -;;;(defun-ffx :void "open-gl" "glTexSubImage1D" (GLenum target GLint level GLint xoffset GLsizei width GLenum format GLenum type GLvoid *pixels)) -;;;(defun-ffx :void "open-gl" "glTexSubImage2D" (GLenum target GLint level GLint xoffset GLint yoffset GLsizei width GLsizei height GLenum format GLenum type GLvoid *pixels)) +(defun-ffx :void "open-gl" "glTexSubImage1D" (GLenum target GLint level GLint xoffset + GLsizei width + GLenum format GLenum type GLvoid *pixels)) +(defun-ffx :void "open-gl" "glTexSubImage2D" (GLenum target GLint level GLint xoffset + GLint yoffset GLsizei width GLsizei height + GLenum format GLenum type GLvoid *pixels)) (defun-ffx :void "open-gl" "glGenTextures" (glsizei n gluint *textures)) (defun-ffx :void "open-gl" "glBindTexture" (glenum target gluint texture)) @@ -346,14 +350,34 @@ (defun-ogl :void "open-gl" "glTranslatef" (glfloat x glfloat y glfloat z )) (defun-ogl :void "open-gl" "glBitmap" (glsizei width glsizei height - glfloat xorig glfloat yorig - glfloat xmove glfloat ymove)) - + glfloat xorig glfloat yorig + glfloat xmove glfloat ymove + char *data)) + +#+not +(DEFUN-FFX :VOID "open-gl" "glBitmap" + (GLSIZEI WIDTH GLSIZEI HEIGHT + GLFLOAT XORIG GLFLOAT YORIG + GLFLOAT XMOVE GLFLOAT YMOVE + GLbyte *DATA)) + +#+not +(DEF-FUNCTION ("glBitmap" GLBITMAP) + ((WIDTH GLSIZEI) (HEIGHT GLSIZEI) (XORIG GLFLOAT) (YORIG GLFLOAT) (XMOVE GLFLOAT) + (YMOVE GLFLOAT) (*DATA :pointer-void)) + :RETURNING :VOID :MODULE "open-gl" + :call-direct t) + +;;;(FF:DEF-FOREIGN-CALL (GLBITMAP "glBitmap") +;;; ((WIDTH GLSIZEI) (HEIGHT GLSIZEI) (XORIG GLFLOAT) (YORIG GLFLOAT) (XMOVE GLFLOAT) +;;; (YMOVE GLFLOAT) (*DATA (* :void))) +;;; :RETURNING :VOID :CALL-DIRECT T :STRINGS-CONVERT NIL) (defun-ogl :void "open-gl" "glReadPixels" ( glint x glint y glsizei width glsizei height glenum format glenum type glvoid *pixels )) (defun-ogl :void "open-gl" "glDrawPixels" (glsizei width glsizei height glenum format glenum type glvoid *pixels)) + (defun-ogl :void "open-gl" "glCopyPixels" ( glint x glint y glsizei width glsizei height glenum type )) #| stenciling |# Index: cl-opengl/glu-functions.lisp diff -u cl-opengl/glu-functions.lisp:1.2 cl-opengl/glu-functions.lisp:1.3 --- cl-opengl/glu-functions.lisp:1.2 Wed Jun 15 23:09:09 2005 +++ cl-opengl/glu-functions.lisp Fri Jul 8 18:26:47 2005 @@ -156,8 +156,9 @@ (defun-ogl (* glubyte) "gl-util" "gluErrorString" (glenum error)) ;;;(defun-ogl GLubyte *"gl-util" "gluGetString" (GLenum name)) -;;;(defun-ogl void "gl-util" "gluGetTessProperty" (GLUtesselator *tess GLenum which GLdouble *data)) -;;;(defun-ogl void "gl-util" "gluLoadSamplingMatrices" (GLUnurbs *nurb GLfloat *model GLfloat *perspective GLint *view)) +(defun-ogl :void "gl-util" "gluGetTessProperty" (:void *tess GLenum which GLdouble *data)) + +;;;(defun-ogl :void "gl-util" "gluLoadSamplingMatrices" (GLUnurbs *nurb GLfloat *model GLfloat *perspective GLint *view)) (defun-ogl :int "gl-util" "gluBuild2DMipmaps" (glenum target glint components @@ -196,11 +197,10 @@ (defun-ogl :void "gl-util" "gluNurbsProperty" (:void *nurb GLenum property GLfloat value)) (defun-ogl :void "gl-util" "gluNurbsSurface" (:void *nurb GLint sKnotCount GLfloat *sKnots GLint tKnotCount GLfloat *tKnots GLint sStride GLint tStride GLfloat *control GLint sOrder GLint tOrder GLenum type)) -;;;(defun-ogl GLUtesselator *"gl-util" "gluNewTess" ()) -;;;(defun-ogl void "gl-util" "gluNextContour" (GLUtesselator *tess GLenum type)) +(defun-ogl :void "gl-util" "gluNextContour" (:void *tess GLenum type)) (defun-ogl :void "gl-util" "gluOrtho2D" (GLdouble left GLdouble right GLdouble bottom GLdouble top)) -;;;(defun-ogl void "gl-util" "gluPartialDisk" (GLUquadric *quad GLdouble inner GLdouble outer GLint slices GLint loops GLdouble start GLdouble sweep)) +;;;(defun-ogl :void "gl-util" "gluPartialDisk" (GLUquadric *quad GLdouble inner GLdouble outer GLint slices GLint loops GLdouble start GLdouble sweep)) (defun-ogl :void "gl-util" "gluPerspective" (gldouble fovy gldouble aspect gldouble z-near gldouble z-far)) @@ -208,20 +208,24 @@ (defun-ogl glint "gl-util" "gluProject" (gldouble obj-x gldouble obj-y gldouble obj-z gldouble *model gldouble *proj glint *view gldouble *winx gldouble *winy gldouble *winz)) -;;;(defun-ogl void "gl-util" "gluPwlCurve" (GLUnurbs *nurb GLint count GLfloat *data GLint stride GLenum type)) -;;;(defun-ogl void "gl-util" "gluQuadricDrawStyle" (GLUquadric *quad GLenum draw)) -;;;(defun-ogl void "gl-util" "gluQuadricNormals" (GLUquadric *quad GLenum normal)) -;;;(defun-ogl void "gl-util" "gluQuadricOrientation" (GLUquadric *quad GLenum orientation)) -(defun-ogl :void "gl-util" "gluQuadricTexture" (:void *quad glboolean texture)) +;;;(defun-ogl :void "gl-util" "gluPwlCurve" (GLUnurbs *nurb GLint count GLfloat *data GLint stride GLenum type)) +;;;(defun-ogl :void "gl-util" "gluQuadricDrawStyle" (GLUquadric *quad GLenum draw)) +;;;(defun-ogl :void "gl-util" "gluQuadricNormals" (GLUquadric *quad GLenum normal)) +;;;(defun-ogl :void "gl-util" "gluQuadricOrientation" (GLUquadric *quad GLenum orientation)) +(defun-ogl :void "gl-util" "gluQuadricTexture" (:void *quad glint texture)) ;;;(defun-ogl GLint "gl-util" "gluScaleImage" (GLenum format GLsizei wIn GLsizei hIn GLenum typeIn void *dataIn GLsizei wOut GLsizei hOut GLenum typeOut GLvoid *dataOut)) -;;;(defun-ogl void "gl-util" "gluSphere" (GLUquadric *quad GLdouble radius GLint slices GLint stacks)) -;;;(defun-ogl void "gl-util" "gluTessBeginContour" (GLUtesselator *tess)) -;;;(defun-ogl void "gl-util" "gluTessBeginPolygon" (GLUtesselator *tess GLvoid *data)) -;;;(defun-ogl void "gl-util" "gluTessEndContour" (GLUtesselator *tess)) -;;;(defun-ogl void "gl-util" "gluTessEndPolygon" (GLUtesselator *tess)) -;;;(defun-ogl void "gl-util" "gluTessNormal" (GLUtesselator *tess GLdouble valueX GLdouble valueY GLdouble valueZ)) -;;;(defun-ogl void "gl-util" "gluTessProperty" (GLUtesselator *tess GLenum which GLdouble data)) -;;;(defun-ogl void "gl-util" "gluTessVertex" (GLUtesselator *tess GLdouble *location GLvoid *data)) +;;;(defun-ogl :void "gl-util" "gluSphere" (GLUquadric *quad GLdouble radius GLint slices GLint stacks)) + (defun-ogl glint "gl-util" "gluUnProject" (gldouble winx gldouble winy gldouble winz gldouble *model gldouble *proj glint *view gldouble *obj-x gldouble *obj-y gldouble *obj-z)) +(defun-ogl (* :void) "gl-util" "gluNewTess" ()) +(defun-ogl :void "gl-util" "gluDeleteTess" (:void *tess)) +(defun-ogl :void "gl-util" "gluTessBeginContour" (:void *tess)) +(defun-ogl :void "gl-util" "gluTessBeginPolygon" (:void *tess GLvoid *data)) +(defun-ogl :void "gl-util" "gluTessEndContour" (:void *tess)) +(defun-ogl :void "gl-util" "gluTessEndPolygon" (:void *tess)) +(defun-ogl :void "gl-util" "gluTessNormal" (:void *tess GLdouble valueX GLdouble valueY GLdouble valueZ)) +(defun-ogl :void "gl-util" "gluTessProperty" (:void *tess GLenum which GLdouble data)) +(defun-ogl :void "gl-util" "gluTessVertex" (:void *tess GLdouble *location GLvoid *data)) +(defun-ogl :void "gl-util" "gluTessCallback" (:void *tess GLenum which :void *callback)) Index: cl-opengl/nehe-14.lisp diff -u cl-opengl/nehe-14.lisp:1.1 cl-opengl/nehe-14.lisp:1.2 --- cl-opengl/nehe-14.lisp:1.1 Wed May 25 05:14:31 2005 +++ cl-opengl/nehe-14.lisp Fri Jul 8 18:26:47 2005 @@ -29,7 +29,7 @@ (ff-defun-callable :cdecl :void nh14disp () (nh14-disp)) - +#+not (defun nh14-disp () (gl-load-identity) ;; Reset The Current Modelview Matrix (gl-clear-color 0.0 0.0 0.0 0.5) @@ -42,7 +42,7 @@ (gl-rotatef g_rot 1.0f0 0.0f0 0.0f0) ;; Rotate On The X Axis (gl-rotatef (* g_rot 1.5f0) 0.0f0 1.0f0 0.0f0) ;; Rotate On The Y Axis (gl-rotatef (* g_rot 1.4f0) 0.0f0 0.0f0 1.0f0) ;; Rotate On The Z Axis - (gl-scalef 0.002 0.003 0.0) + (gl-scalef 0.002 0.003 0.002) ;; Pulsing Colors Based On The Rotation (gl-color3f (* 1.0f0 (cos (/ g_rot 20.0f0))) @@ -54,6 +54,33 @@ (glut-stroke-string (ffi-glut-id glut_stroke_roman) (format nil "NeHe - ~a" (/ g_rot 50.0)))) + (gl-line-width 1) + (glut-wire-teapot 1000) + + (incf g_rot 0.4f0) + + (glut-swap-buffers) + (glut-post-redisplay)) + +(defun nh14-disp () + (gl-load-identity) ;; Reset The Current Modelview Matrix + (gl-clear-color 0.0 0.0 0.0 0.5) + (gl-clear (+ gl_color_buffer_bit gl_depth_buffer_bit)) + + (gl-translatef 0.0f0 0.0f0 2.0f0) ;; Move Into The Screen + + (gl-rotatef g_rot 1.0f0 0.0f0 0.0f0) ;; Rotate On The X Axis + (gl-rotatef (* g_rot 1.5f0) 0.0f0 1.0f0 0.0f0) ;; Rotate On The Y Axis + (gl-rotatef (* g_rot 1.4f0) 0.0f0 0.0f0 1.0f0) ;; Rotate On The Z Axis + + ;; Pulsing Colors Based On The Rotation + (gl-color3f (* 1.0f0 (cos (/ g_rot 20.0f0))) + (* 1.0f0 (sin (/ g_rot 25.0f0))) + (- 1.0f0 (* 0.5f0 (cos (/ g_rot 17.0f0))))) + + (gl-line-width 1) + (glut-wire-teapot 1) + (incf g_rot 0.4f0) (glut-swap-buffers) Index: cl-opengl/ogl-macros.lisp diff -u cl-opengl/ogl-macros.lisp:1.1 cl-opengl/ogl-macros.lisp:1.2 --- cl-opengl/ogl-macros.lisp:1.1 Wed May 25 05:14:31 2005 +++ cl-opengl/ogl-macros.lisp Fri Jul 8 18:26:47 2005 @@ -41,6 +41,16 @@ (funcall matrix-fn)) (gl-pop-matrix))) + +(defparameter *matrix-mode* GL_MODELVIEW) +(defmacro with-matrix-mode (mode &body body) + `(unwind-protect + (let ((*matrix-mode* ,mode)) + (glMatrixMode *matrix-mode*) + , at body) + (glMatrixMode *matrix-mode*))) + + #+debugversion (defun call-with-matrix (load-identity-p matrix-fn matrix-code) (let ((mm-pushed (ogl::get-matrix-mode)) @@ -83,6 +93,21 @@ (funcall attrib-fn) (glec :with-attrib)) (gl-pop-attrib) + )) + +(defmacro with-client-attrib ((&rest attribs) &body body) + `(call-with-client-attrib + ,(apply '+ (mapcar 'symbol-value attribs)) + (lambda () , at body))) + +(defun call-with-client-attrib (attrib-mask attrib-fn) + (gl-push-client-attrib attrib-mask) + (glec :with-client-attrib-push) + (unwind-protect + (prog1 + (funcall attrib-fn) + (glec :with-client-attrib)) + (gl-pop-client-attrib) )) (defvar *gl-begun*) Index: cl-opengl/ogl-utils.lisp diff -u cl-opengl/ogl-utils.lisp:1.2 cl-opengl/ogl-utils.lisp:1.3 --- cl-opengl/ogl-utils.lisp:1.2 Wed Jun 15 23:09:09 2005 +++ cl-opengl/ogl-utils.lisp Fri Jul 8 18:26:47 2005 @@ -205,7 +205,7 @@ (defun ogl-pen-move (x y) ;;(ukt::trc "ogl-pen-moving" x y) - (gl-bitmap 0 0 0 0 x y)) + (gl-bitmap 0 0 0 0 x y (uffi:make-null-pointer '(:array :cstring)))) (defclass ogl-texture () ((texture-name :accessor texture-name :initform nil) From ktilton at common-lisp.net Sun Jul 10 21:35:04 2005 From: ktilton at common-lisp.net (Kenny Tilton) Date: Sun, 10 Jul 2005 23:35:04 +0200 (CEST) Subject: [cello-cvs] CVS update: hello-c/definers.lisp hello-c/hello-c.lpr hello-c/primitives.lisp hello-c/strings.lisp Message-ID: <20050710213504.D147C884CA@common-lisp.net> Update of /project/cello/cvsroot/hello-c In directory common-lisp.net:/tmp/cvs-serv3125 Modified Files: definers.lisp hello-c.lpr primitives.lisp strings.lisp Log Message: No comment Date: Sun Jul 10 23:35:01 2005 Author: ktilton Index: hello-c/definers.lisp diff -u hello-c/definers.lisp:1.1 hello-c/definers.lisp:1.2 --- hello-c/definers.lisp:1.1 Tue May 24 01:51:57 2005 +++ hello-c/definers.lisp Sun Jul 10 23:35:01 2005 @@ -20,7 +20,7 @@ ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;;; IN THE SOFTWARE. -;; $Header: /project/cello/cvsroot/hello-c/definers.lisp,v 1.1 2005/05/23 23:51:57 ktilton Exp $ +;; $Header: /project/cello/cvsroot/hello-c/definers.lisp,v 1.2 2005/07/10 21:35:01 ktilton Exp $ (in-package :hello-c) @@ -39,11 +39,17 @@ #-lispworks ff-ptr #+lispworks (fli:pointer-address ff-ptr)) +;;;(defun make-ff-pointer (n) +;;; #-lispworks +;;; n +;;; #+lispworks +;;; (fli:make-pointer :address n :pointer-type '(:pointer :void))) + (defun make-ff-pointer (n) - #-lispworks - n - #+lispworks - (fli:make-pointer :address n :pointer-type '(:pointer :void))) + #+allegro (ff:make-foreign-pointer :address n :type '(* void)) + #+lispworks (fli:make-pointer :address n :pointer-type '(:pointer :void)) + #-(or lispworks allegro) n + ) (defmacro defun-ffx (rtn module$ name$ (&rest type-args) &body post-processing) (let* ((lisp-fn (lisp-fn name$)) Index: hello-c/hello-c.lpr diff -u hello-c/hello-c.lpr:1.1 hello-c/hello-c.lpr:1.2 --- hello-c/hello-c.lpr:1.1 Tue May 24 01:51:57 2005 +++ hello-c/hello-c.lpr Sun Jul 10 23:35:01 2005 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "7.0 [Windows] (May 6, 2005 8:25)"; cg: "1.54.2.17"; -*- +;; -*- lisp-version: "7.0 [Windows] (Jun 10, 2005 13:34)"; cg: "1.54.2.17"; -*- (in-package :cg-user) Index: hello-c/primitives.lisp diff -u hello-c/primitives.lisp:1.1 hello-c/primitives.lisp:1.2 --- hello-c/primitives.lisp:1.1 Tue May 24 01:51:57 2005 +++ hello-c/primitives.lisp Sun Jul 10 23:35:01 2005 @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: primitives.lisp,v 1.1 2005/05/23 23:51:57 ktilton Exp $ +;;;; $Id: primitives.lisp,v 1.2 2005/07/10 21:35:01 ktilton Exp $ ;;;; ;;;; This file, part of hello-c, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -242,37 +242,37 @@ (cond #+(or allegro cormanlisp) ((and (or (eq context :routine) (eq context :return)) - (eq type :cstring)) - (setq type '((* :char) integer))) + (eq type :cstring)) + (setq type '((* :char) integer))) #+(or cmu sbcl scl) ((eq context :type) - (let ((cmu-type (gethash type *cmu-def-type-hash*))) - (if cmu-type - cmu-type - (basic-convert-from-uffi-type type)))) + (let ((cmu-type (gethash type *cmu-def-type-hash*))) + (if cmu-type + cmu-type + (basic-convert-from-uffi-type type)))) #+lispworks ((and (eq context :return) - (eq type :cstring)) - (basic-convert-from-uffi-type :cstring-returning)) + (eq type :cstring)) + (basic-convert-from-uffi-type :cstring-returning)) #+(and mcl (not openmcl)) ((and (eq type :void) (eq context :return)) nil) (t - (basic-convert-from-uffi-type type))) + (basic-convert-from-uffi-type type))) (let ((sub-type (car type))) (case sub-type - (cl:quote - (convert-from-uffi-type (cadr type) context)) - (:struct-pointer - #+mcl `(:* (:struct ,(%convert-from-uffi-type (cadr type) :struct))) - #-mcl (%convert-from-uffi-type (list '* (cadr type)) :struct) - ) - (:struct - #+mcl `(:struct ,(%convert-from-uffi-type (cadr type) :struct)) - #-mcl (%convert-from-uffi-type (cadr type) :struct) - ) - (t - (cons (%convert-from-uffi-type (first type) context) - (%convert-from-uffi-type (rest type) context))))))) + (cl:quote + (convert-from-uffi-type (cadr type) context)) + (:struct-pointer + #+mcl `(:* (:struct ,(%convert-from-uffi-type (cadr type) :struct))) + #-mcl (%convert-from-uffi-type (list '* (cadr type)) :struct) + ) + (:struct + #+mcl `(:struct ,(%convert-from-uffi-type (cadr type) :struct)) + #-mcl (%convert-from-uffi-type (cadr type) :struct) + ) + (t + (cons (%convert-from-uffi-type (first type) context) + (%convert-from-uffi-type (rest type) context))))))) #+test Index: hello-c/strings.lisp diff -u hello-c/strings.lisp:1.1 hello-c/strings.lisp:1.2 --- hello-c/strings.lisp:1.1 Tue May 24 01:51:57 2005 +++ hello-c/strings.lisp Sun Jul 10 23:35:01 2005 @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: strings.lisp,v 1.1 2005/05/23 23:51:57 ktilton Exp $ +;;;; $Id: strings.lisp,v 1.2 2005/07/10 21:35:01 ktilton Exp $ ;;;; ;;;; This file, part of hic, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -68,28 +68,31 @@ (dispose-ptr ,obj)) ) -(defmacro with-cstring ((cstring lisp-string) &body body) +(defmacro with-cstring ((cstring lisp$-form) &body body) #+(or cmu sbcl scl lispworks) - `(let ((,cstring ,lisp-string)) , at body) + `(let ((,cstring ,lisp$-form)) , at body) #+allegro (let ((acl-native (gensym))) - `(excl:with-native-string (,acl-native ,lisp-string) - (let ((,cstring (if ,lisp-string ,acl-native 0))) - , at body))) + `(excl:with-native-string (,acl-native ,lisp$-form) + (let ((,cstring ,(if lisp$-form acl-native 0))) + , at body))) #+mcl - `(if (stringp ,lisp-string) - (ccl:with-cstrs ((,cstring ,lisp-string)) - , at body) - (let ((,cstring +null-cstring-pointer+)) - , at body)) - ) + (let ((lisp$ (gensym))) + `(let ((,lisp$ (let ((,lisp$ ,lisp$-form)) + (typecase ,lisp$ + (null +null-cstring-pointer+) + (string ,lisp$) + (t (error "with-cstring asked to handle non-string ~a" ,lisp$)))))) + (ccl:with-cstrs ((,cstring ,lisp$)) + , at body)))) + (defmacro with-cstrings (bindings &rest body) (if bindings `(with-cstring ,(car bindings) - (with-cstrings ,(cdr bindings) - , at body)) - `(progn , at body))) + (with-cstrings ,(cdr bindings) + , at body)) + `(progn , at body))) ;;; Foreign string functions