From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Sun, 7 Feb 2016 23:14:53 +0000 (-0700)
Subject: microcode/pruxffi (arg_pointer): Correct address of first double.
X-Git-Tag: mit-scheme-pucked-9.2.12~364
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=61280235f76283f5aaa928e4f12740130e74dcee;p=mit-scheme.git

microcode/pruxffi (arg_pointer): Correct address of first double.

Convert flonums/flovecs to the address of the first double, not the
manifest.  Punt flovec_ref and flovec_loc.  This simplifies callouts
to e.g. glVertex3dv.
---

diff --git a/src/gl/gl-adapter.c b/src/gl/gl-adapter.c
index cdbea1b92..565ed85fc 100644
--- a/src/gl/gl-adapter.c
+++ b/src/gl/gl-adapter.c
@@ -33,80 +33,59 @@ USA.
 #include "gl-shim.h"
 
 void
-gl_clear_color (SCM color)
+gl_clear_color (double *color)
 {
-  glClearColor (flovec_ref (color, 0),
-		flovec_ref (color, 1),
-		flovec_ref (color, 2),
-		flovec_ref (color, 3));
+  glClearColor (color[0], color[1], color[2], color[3]);
 }
 
 void
-gl_color (SCM color)
+gl_light (GLenum light, GLenum pname, double *params)
 {
-  glColor4dv (flovec_loc (color));
-}
-
-void
-gl_vertex (SCM point)
-{
-  glVertex3dv (flovec_loc (point));
-}
-
-void
-gl_light (GLenum light, GLenum pname, SCM params)
-{
-  int i, len = flovec_length (params);
+  int i,len = flovec_length (params);
   GLfloat *fvec = malloc (len * sizeof (GLfloat));
   if (!fvec)
     error_external_return ();
   for (i = 0; i < len; i++) {
-    fvec[i] = flovec_ref (params, i);
+    fvec[i] = params[i];
   }
   glLightfv (light, pname, fvec);
   free (fvec);
 }
 
 void
-gl_light_model_v (GLenum pname, const GLfloat *params)
+gl_light_model_v (GLenum pname, double *params)
 {
   int i, len = flovec_length (params);
   GLfloat *fvec = malloc (len * sizeof (GLfloat));
   if (!fvec)
     error_external_return ();
   for (i = 0; i < len; i++) {
-    fvec[i] = flovec_ref (params, i);
+    fvec[i] = params[i];
   }
   glLightModelfv (pname, fvec);
   free (fvec);
 }
 
 void
-gl_material (GLenum face, GLenum pname, SCM params)
+gl_material (GLenum face, GLenum pname, double *params)
 {
   int i, len = flovec_length (params);
   GLfloat *fvec = malloc (len * sizeof (GLfloat));
   if (!fvec)
     error_external_return ();
   for (i = 0; i < len; i++) {
-    fvec[i] = flovec_ref (params, i);
+    fvec[i] = params[i];
   }
   glMaterialfv (face, pname, fvec);
   free (fvec);
 }
 
 void
-gl_normal (SCM point)
-{
-  glNormal3dv (flovec_loc (point));
-}
-
-void
-glu_look_at (SCM eye, SCM center, SCM up)
+glu_look_at (double *eye, double *center, double *up)
 {
-  gluLookAt (flovec_ref (eye, 0), flovec_ref (eye, 1), flovec_ref (eye, 2),
-	     flovec_ref(center,0),flovec_ref(center,1),flovec_ref(center,2),
-	     flovec_ref (up,  0), flovec_ref (up,  1), flovec_ref (up,  2));
+  gluLookAt (eye[0], eye[1], eye[2],
+	     center[0], center[1], center[2],
+	     up[0], up[1], up[2]);
 }
 
 static int gdk_visual_get_visual_class (GdkVisual *v);
diff --git a/src/gl/gl-shim.h b/src/gl/gl-shim.h
index 160eea432..587f38ea2 100644
--- a/src/gl/gl-shim.h
+++ b/src/gl/gl-shim.h
@@ -29,14 +29,14 @@ USA.
 
 /* Do not declare in gl-const.c, which does not include mit-scheme.h. */
 #ifdef CSTACK_PUSH
-extern void gl_clear_color (SCM color);
-extern void gl_color (SCM color);
-extern void gl_vertex (SCM point);
-extern void gl_light (GLenum light, GLenum pname, SCM params);
-extern void gl_light_model_v (GLenum pname, const GLfloat *params);
-extern void gl_material (GLenum face, GLenum pname, SCM params);
-extern void gl_normal (SCM point);
-extern void glu_look_at (SCM eye, SCM center, SCM up);
+extern void gl_clear_color (double *color);
+extern void gl_color (double *color);
+extern void gl_vertex (double *point);
+extern void gl_light (GLenum light, GLenum pname, double *params);
+extern void gl_light_model_v (GLenum pname, double *params);
+extern void gl_material (GLenum face, GLenum pname, double *params);
+extern void gl_normal (double *point);
+extern void glu_look_at (double *eye, double *center, double *up);
 extern GdkVisual* glx_find_gdkvisual (GdkWindow *window, XVisualInfo *visinfo);
 extern int gdk_window_xid (GdkWindow *window);
 extern Display* gdk_window_xdisplay (GdkWindow *window);
diff --git a/src/gl/gl.cdecl b/src/gl/gl.cdecl
index bb1210ec5..42093dad0 100644
--- a/src/gl/gl.cdecl
+++ b/src/gl/gl.cdecl
@@ -30,13 +30,12 @@ USA.
 (typedef GLsizei int)
 (typedef GLfloat float)
 (typedef GLdouble double)
-(typedef SCM (* void))
 
 (extern void glShadeModel (mode GLenum))
 
 (enum (GL_SMOOTH))
 
-(extern void gl_clear_color (color SCM))
+(extern void gl_clear_color (color (* double)))
 
 (extern void glClearDepth (depth GLdouble))
 
@@ -97,9 +96,9 @@ USA.
       (GL_QUAD_STRIP)
       (GL_POLYGON))
 
-(extern void gl_color (color SCM))
+(extern void glColor4dv (color (* double)))
 
-(extern void gl_vertex (point SCM))
+(extern void glVertex3dv (point (* double)))
 
 (extern void glEnd)
 
@@ -114,11 +113,11 @@ USA.
 
 (extern GLuint glGenLists (range GLsizei))
 
-(extern void gl_light (light GLenum) (pname GLenum) (params SCM))
+(extern void gl_light (light GLenum) (pname GLenum) (params (* double)))
 
 (extern void glLightModelf (pname GLenum) (param GLfloat))
 (extern void glLightModeli (pname GLenum) (param GLint))
-(extern void gl_light_model_v (pname GLenum) (params SCM))
+(extern void gl_light_model_v (pname GLenum) (params (* double)))
 
 (enum (GL_LIGHT_MODEL_AMBIENT)
       (GL_LIGHT_MODEL_COLOR_CONTROL)
@@ -127,7 +126,7 @@ USA.
       (GL_SEPARATE_SPECULAR_COLOR)
       (GL_SINGLE_COLOR))
 
-(extern void gl_material (face GLenum) (pname GLenum) (params SCM))
+(extern void gl_material (face GLenum) (pname GLenum) (params (* double)))
 
 (extern void glMatrixMode (mode GLenum))
 (enum (GL_PROJECTION) (GL_MODELVIEW))
@@ -138,7 +137,7 @@ USA.
 
 (extern void glDeleteLists (list GLuint) (range GLsizei))
 
-(extern void gl_normal (point SCM))
+(extern void glNormal3dv (point (* double)))
 
 (extern void glPopMatrix)
 
@@ -167,7 +166,7 @@ USA.
       (GL_COMPILE)
       (GL_FLAT))
 
-(extern void glu_look_at (eye SCM) (center SCM) (up SCM))
+(extern void glu_look_at (eye (* double)) (center (* double)) (up (* double)))
 
 (extern void gluPerspective
 	(fovy GLdouble) (aspect GLdouble) (zNear GLdouble) (zFar GLdouble))
diff --git a/src/gl/gl.scm b/src/gl/gl.scm
index 0a6475a82..c5c5f259e 100644
--- a/src/gl/gl.scm
+++ b/src/gl/gl.scm
@@ -180,12 +180,12 @@ USA.
 (define (gl:color color)
   (guarantee-current 'GL:COLOR)
   (guarantee-color color 'GL:COLOR)
-  (C-call "gl_color" color))
+  (C-call "glColor4dv" color))
 
 (define (gl:vertex point)
   (guarantee-current 'GL:VERTEX)
   (guarantee-3d point 'GL:VERTEX)
-  (C-call "gl_vertex" point))
+  (C-call "glVertex3dv" point))
 
 (define (gl:end)
   (guarantee-current 'GL:END)
@@ -330,7 +330,7 @@ USA.
 (define (gl:normal 3d)
   (guarantee-current 'GL:NORMAL)
   (guarantee-3d 3d 'GL:NORMAL)
-  (C-call "gl_normal" 3d))
+  (C-call "glNormal3dv" 3d))
 
 (define (gl:pop-matrix)
   (guarantee-current 'GL:POP-MATRIX)
diff --git a/src/microcode/pruxffi.c b/src/microcode/pruxffi.c
index f6c3ca54e..e8c6c2c57 100644
--- a/src/microcode/pruxffi.c
+++ b/src/microcode/pruxffi.c
@@ -837,7 +837,7 @@ arg_pointer (int argn)
   if (is_alien (arg))
     return (alien_address (arg));
   if (FLONUM_P (arg))
-    return ((void *) (OBJECT_ADDRESS (arg)));
+    return ((void *) (MEMORY_LOC ((arg), 1)));
 
   error_wrong_type_arg (argn);
   /*NOTREACHED*/
@@ -1046,24 +1046,12 @@ empty_list (void)
 }
 
 int
-flovec_length (SCM vector)
+flovec_length (double *first)
 {
-  return (FLOATING_VECTOR_LENGTH (vector));
-}
-
-double*
-flovec_loc (SCM vector)
-{
-  return (FLOATING_VECTOR_LOC (vector, 0));
-}
+  /* FIRST must be the first double in a flonum/flovec. */
 
-double
-flovec_ref (SCM vector, int index)
-{
-  int len = FLOATING_VECTOR_LENGTH (vector);
-  if (0 <= index && index < len)
-    return (FLOATING_VECTOR_REF (vector, index));
-  error_external_return ();
+  SCM object = MAKE_POINTER_OBJECT (TC_BIG_FLONUM, (((SCM *)first) - 1));
+  return (FLOATING_VECTOR_LENGTH (object));
 }
 
 DEFINE_PRIMITIVE ("OUTF-ERROR", Prim_outf_error, 1, 1, 0)
diff --git a/src/microcode/pruxffi.h b/src/microcode/pruxffi.h
index 9f999ad8b..a78b2a02f 100644
--- a/src/microcode/pruxffi.h
+++ b/src/microcode/pruxffi.h
@@ -90,9 +90,7 @@ extern void* pointer_value (void);
 extern void check_number_of_args (int num);
 extern SCM unspecific (void);
 extern SCM empty_list (void);
-extern int flovec_length (SCM vector);
-extern double* flovec_loc (SCM vector);
-extern double flovec_ref (SCM vector, int index);
+extern int flovec_length (double *first);
 
 #ifndef MIT_SCHEME /* Do not include in the microcode, just shims. */
 extern SCM cons (SCM car, SCM cdr);