test_performance.cl: fixed target to nvptx, added some builtin declarations

// Test source code is from http://musicdsp.org/archive.php?classid=0#1 and
// modified to pass clang C compiler and changed TF to be local var in main
// to support ClampPointers pass.

// FormantsAM.cpp

// Thierry Rochebois' "Formantic Synthesis by Double Amplitude Modulation"

// Based on a tutorial by Thierry Rochebois.
// Comments by Paul Sernine.

// The spectral content of the signal is obtained by adding amplitude modulated formantic
// waveforms. The amplitude modulations spectraly shift the formantic waveforms.
// Continuous spectral shift, without losing the harmonic structure, is obtained
// by using crossfaded double carriers (multiple of the base frequency).
// To avoid  unwanted interference artifacts, phase relationships must be of the
// "cosine type".

// The output is a 44100Hz 16bit stereo PCM file.

// NOTE: for now looks like -O3 cripples safe exception load/store analysis
// TODO: get times from unclamped versions and compare to clamped ones and expect perf hit to be max 30%

// RUN: clang -target nvptx -S -c $TEST_SRC -O0 -emit-llvm -S -o $OUT_FILE.ll &&
// RUN: echo "Running and verifying 'Formantic Synthesis by Double Amplitude Modulation' case" &&
// RUN: opt -S -O3 $OUT_FILE.ll -o $OUT_FILE.O3.ll &&
// RUN: opt -debug -S -load $CLAMP_PLUGIN -clamp-pointers -allow-unsafe-exceptions $OUT_FILE.ll -o $OUT_FILE.clamped.ll &&
// RUN: opt -debug -S -load $CLAMP_PLUGIN -clamp-pointers -allow-unsafe-exceptions $OUT_FILE.O3.ll -o $OUT_FILE.O3.clamped.ll &&
// RUN: opt -S -O3 $OUT_FILE.clamped.ll -o $OUT_FILE.clamped.O3.ll &&
// RUN: echo "Running original.O0:" &&
// RUN: time lli $OUT_FILE.ll &&
// RUN: echo "Running original.O3:" &&
// RUN: time lli $OUT_FILE.O3.ll &&
// RUN: echo "Running clamped.O0:" &&
// RUN: time lli $OUT_FILE.clamped.ll &&
// RUN: echo "Running O3.clamped:" &&
// RUN: time lli $OUT_FILE.O3.clamped.ll &&
// RUN: echo "Running clamped.O3:" &&
// RUN: time lli $OUT_FILE.clamped.O3.ll

typedef int int32_t;
typedef short int16_t;

float expf(float f);
float sinf(float f);
float cosf(float f);
float floorf(float f);
float powf(float a, float b);
float fmodf(float x, float y);

//Approximates cos(pi*x) for x in [-1,1].
float fast_cos(const float x)
{
  float x2 = x*x;
  return 1+x2*(-4+2*x2);
}

// Length of the table
#define L_TABLE (256+1) //The last entry of the table equals the first (to avoid a modulo)
// Maximal formant width
#define I_MAX 64

//Formantic function of width I (used to fill the table of formants)
float fonc_formant(float p,const float I)
{
  float a=0.5f;
  int32_t hmax=(int)(10*I)>L_TABLE/2?L_TABLE/2:(int32_t)(10*I);
  float phi=0.0f;
  for(int32_t h=1;h<hmax;h++)
    {
      phi+=3.14159265359f*p;
      float hann=0.5f+0.5f*fast_cos(h*(1.0f/hmax));
      float gaussienne=0.85f*expf(-h*h/(I*I));
      float jupe=0.15f;
      float harmonique=cosf(phi);
      a+=hann*(gaussienne+jupe)*harmonique;
    }
  return a;
}

//Initialisation of the table TF with the fonction fonc_formant.
void init_formant(float TF[])
{ float coef=2.0f/(L_TABLE-1);
  for(int32_t I=0;I<I_MAX;I++)
    for(int32_t P=0;P<L_TABLE;P++)
      TF[P+I*L_TABLE]=fonc_formant(-1+P*coef,(float)(I));
}

//This function emulates the function fonc_formant
// thanks to the table TF. A bilinear interpolation is
// performed
float formant(float p,float i, float TF[])
{
  i=i<0?0:i>I_MAX-2?I_MAX-2:i;    // width limitation
  float P=(L_TABLE-1)*(p+1)*0.5f; // phase normalisation
  int32_t P0=(int32_t)P;     float fP=P-P0;  // Integer and fractional
  int32_t I0=(int32_t)i;     float fI=i-I0;  // parts of the phase (p) and width (i).
  int32_t i00=P0+L_TABLE*I0;     int32_t i10=i00+L_TABLE;
  //bilinear interpolation.
  return (1-fI)*(TF[i00] + fP*(TF[i00+1]-TF[i00]))
    +    fI*(TF[i10] + fP*(TF[i10+1]-TF[i10]));
}

// Double carrier.
// h : position (float harmonic number)
// p : phase
float porteuse(const float h,const float p)
{
  float h0=floorf(h);  //integer and
  float hf=h-h0;      //decimal part of harmonic number.
  // modulos pour ramener p*h0 et p*(h0+1) dans [-1,1]
  float phi0=fmodf(p* h0   +1+1000,2.0f)-1.0f;
  float phi1=fmodf(p*(h0+1)+1+1000,2.0f)-1.0f;
  // two carriers.
  float Porteuse0=fast_cos(phi0);  float Porteuse1=fast_cos(phi1);
  // crossfade between the two carriers.
  return Porteuse0+hf*(Porteuse1-Porteuse0);
}

__kernel void test_kernel(__global int16_t* out_val)
{
  //Formant table for various french vowels (you can add your own)
  float F1[]={  730,  200,  400,  250,  190,  350,  550,  550,  450};
  float A1[]={ 1.0f, 0.5f, 1.0f, 1.0f, 0.7f, 1.0f, 1.0f, 0.3f, 1.0f};
  float F2[]={ 1090, 2100,  900, 1700,  800, 1900, 1600,  850, 1100};
  float A2[]={ 2.0f, 0.5f, 0.7f, 0.7f,0.35f, 0.3f, 0.5f, 1.0f, 0.7f};
  float F3[]={ 2440, 3100, 2300, 2100, 2000, 2500, 2250, 1900, 1500};
  float A3[]={ 0.3f,0.15f, 0.2f, 0.4f, 0.1f, 0.3f, 0.7f, 0.2f, 0.2f};
  float F4[]={ 3400, 4700, 3000, 3300, 3400, 3700, 3200, 3000, 3000};
  float A4[]={ 0.2f, 0.1f, 0.2f, 0.3f, 0.1f, 0.1f, 0.3f, 0.2f, 0.3f};

  float f0,dp0,p0=0.0f;
  int32_t F=7; //number of the current formant preset
  float f1,f2,f3,f4,a1,a2,a3,a4;
  f1=f2=f3=f4=100.0f;a1=a2=a3=a4=0.0f;

  //Table of formants
  float TF[L_TABLE*I_MAX];

  init_formant(TF);

  for(int ns=0;ns<200*44100;ns++)
    {
      if(0==(ns%11025)){F++;F%=8;} //formant change
      f0=12*powf(2.0f,4-4*ns/(10*44100.0f)); //sweep
      f0*=(1.0f+0.01f*sinf(ns*0.0015f));        //vibrato
      dp0=f0*(1/22050.0f);
      float un_f0=1.0f/f0;
      p0+=dp0;  //phase increment
      p0-=2*(p0>1);
      { //smoothing of the commands.
        float r=0.001f;
        f1+=r*(F1[F]-f1);f2+=r*(F2[F]-f2);f3+=r*(F3[F]-f3);f4+=r*(F4[F]-f4);
        a1+=r*(A1[F]-a1);a2+=r*(A2[F]-a2);a3+=r*(A3[F]-a3);a4+=r*(A4[F]-a4);
      }

      //The f0/fn coefficients stand for a -3dB/oct spectral enveloppe
      float out=
        a1*(f0/f1)*formant(p0,100*un_f0,TF)*porteuse(f1*un_f0,p0)
        +0.7f*a2*(f0/f2)*formant(p0,120*un_f0,TF)*porteuse(f2*un_f0,p0)
        +     a3*(f0/f3)*formant(p0,150*un_f0,TF)*porteuse(f3*un_f0,p0)
        +     a4*(f0/f4)*formant(p0,300*un_f0,TF)*porteuse(f4*un_f0,p0);

      // write to volatile variable to test... (use puts to verify correctness)
      out_val[0] = (int16_t)(15000.0f*out);
    }
}

// Test source code is from http://musicdsp.org/archive.php?classid=0#1 and
// modified to pass clang C compiler and changed TF to be local var in main
// to support ClampPointers pass.

// FormantsAM.cpp

// Thierry Rochebois' "Formantic Synthesis by Double Amplitude Modulation"

// Based on a tutorial by Thierry Rochebois.
// Comments by Paul Sernine.

// The spectral content of the signal is obtained by adding amplitude modulated formantic
// waveforms. The amplitude modulations spectraly shift the formantic waveforms.
// Continuous spectral shift, without losing the harmonic structure, is obtained
// by using crossfaded double carriers (multiple of the base frequency).
// To avoid  unwanted interference artifacts, phase relationships must be of the
// "cosine type".

// The output is a 44100Hz 16bit stereo PCM file.

// NOTE: for now looks like -O3 cripples safe exception load/store analysis
// TODO: get times from unclamped versions and compare to clamped ones and expect perf hit to be max 30%

// RUN: TARGET_FLAGS="-target nvptx" clang -S -c $TEST_SRC -O0 -emit-llvm -S -o $OUT_FILE.ll &&
// RUN: echo "Running and verifying 'Formantic Synthesis by Double Amplitude Modulation' case" &&
// RUN: opt -S -O3 $OUT_FILE.ll -o $OUT_FILE.O3.ll &&
// RUN: opt -S -load $CLAMP_PLUGIN -clamp-pointers -allow-unsafe-exceptions $OUT_FILE.ll -o $OUT_FILE.clamped.ll &&
// RUN: opt -debug -S -load $CLAMP_PLUGIN -clamp-pointers -allow-unsafe-exceptions $OUT_FILE.O3.ll -o $OUT_FILE.O3.clamped.ll &&
// RUN: opt -S -O3 $OUT_FILE.clamped.ll -o $OUT_FILE.clamped.O3.ll &&
// RUN: echo "Running original.O0:" &&
// RUN: time lli $OUT_FILE.ll &&
// RUN: echo "Running original.O3:" &&
// RUN: time lli $OUT_FILE.O3.ll &&
// RUN: echo "Running clamped.O0:" &&
// RUN: time lli $OUT_FILE.clamped.ll &&
// RUN: echo "Running O3.clamped:" &&
// RUN: time lli $OUT_FILE.O3.clamped.ll &&
// RUN: echo "Running clamped.O3:" &&
// RUN: time lli $OUT_FILE.clamped.O3.ll

typedef int int32_t;
typedef short int16_t;

float expf(float f)
{
  return exp(f);
}

//Approximates cos(pi*x) for x in [-1,1].
float fast_cos(const float x)
{
  float x2 = x*x;
  return 1+x2*(-4+2*x2);
}

// Length of the table
#define L_TABLE (256+1) //The last entry of the table equals the first (to avoid a modulo)
// Maximal formant width
#define I_MAX 64

//Formantic function of width I (used to fill the table of formants)
float fonc_formant(float p,const float I)
{
  float a=0.5f;
  int32_t hmax=(int)(10*I)>L_TABLE/2?L_TABLE/2:(int32_t)(10*I);
  float phi=0.0f;
  for(int32_t h=1;h<hmax;h++)
    {
      phi+=3.14159265359f*p;
      float hann=0.5f+0.5f*fast_cos(h*(1.0f/hmax));
      float gaussienne=0.85f*expf(-h*h/(I*I));
      float jupe=0.15f;
      float harmonique=cosf(phi);
      a+=hann*(gaussienne+jupe)*harmonique;
    }
  return a;
}

//Initialisation of the table TF with the fonction fonc_formant.
void init_formant(float TF[])
{ float coef=2.0f/(L_TABLE-1);
  for(int32_t I=0;I<I_MAX;I++)
    for(int32_t P=0;P<L_TABLE;P++)
      TF[P+I*L_TABLE]=fonc_formant(-1+P*coef,(float)(I));
}

//This function emulates the function fonc_formant
// thanks to the table TF. A bilinear interpolation is
// performed
float formant(float p,float i, float TF[])
{
  i=i<0?0:i>I_MAX-2?I_MAX-2:i;    // width limitation
  float P=(L_TABLE-1)*(p+1)*0.5f; // phase normalisation
  int32_t P0=(int32_t)P;     float fP=P-P0;  // Integer and fractional
  int32_t I0=(int32_t)i;     float fI=i-I0;  // parts of the phase (p) and width (i).
  int32_t i00=P0+L_TABLE*I0;     int32_t i10=i00+L_TABLE;
  //bilinear interpolation.
  return (1-fI)*(TF[i00] + fP*(TF[i00+1]-TF[i00]))
    +    fI*(TF[i10] + fP*(TF[i10+1]-TF[i10]));
}

// Double carrier.
// h : position (float harmonic number)
// p : phase
float porteuse(const float h,const float p)
{
  float h0=floor(h);  //integer and
  float hf=h-h0;      //decimal part of harmonic number.
  // modulos pour ramener p*h0 et p*(h0+1) dans [-1,1]
  float phi0=fmodf(p* h0   +1+1000,2.0f)-1.0f;
  float phi1=fmodf(p*(h0+1)+1+1000,2.0f)-1.0f;
  // two carriers.
  float Porteuse0=fast_cos(phi0);  float Porteuse1=fast_cos(phi1);
  // crossfade between the two carriers.
  return Porteuse0+hf*(Porteuse1-Porteuse0);
}

__kernel void test_kernel(__global int16_t* out_val)
{
  //Formant table for various french vowels (you can add your own)
  float F1[]={  730,  200,  400,  250,  190,  350,  550,  550,  450};
  float A1[]={ 1.0f, 0.5f, 1.0f, 1.0f, 0.7f, 1.0f, 1.0f, 0.3f, 1.0f};
  float F2[]={ 1090, 2100,  900, 1700,  800, 1900, 1600,  850, 1100};
  float A2[]={ 2.0f, 0.5f, 0.7f, 0.7f,0.35f, 0.3f, 0.5f, 1.0f, 0.7f};
  float F3[]={ 2440, 3100, 2300, 2100, 2000, 2500, 2250, 1900, 1500};
  float A3[]={ 0.3f,0.15f, 0.2f, 0.4f, 0.1f, 0.3f, 0.7f, 0.2f, 0.2f};
  float F4[]={ 3400, 4700, 3000, 3300, 3400, 3700, 3200, 3000, 3000};
  float A4[]={ 0.2f, 0.1f, 0.2f, 0.3f, 0.1f, 0.1f, 0.3f, 0.2f, 0.3f};

  float f0,dp0,p0=0.0f;
  int32_t F=7; //number of the current formant preset
  float f1,f2,f3,f4,a1,a2,a3,a4;
  f1=f2=f3=f4=100.0f;a1=a2=a3=a4=0.0f;

  //Table of formants
  float TF[L_TABLE*I_MAX];

  init_formant(TF);

  for(int ns=0;ns<200*44100;ns++)
    {
      if(0==(ns%11025)){F++;F%=8;} //formant change
      f0=12*powf(2.0f,4-4*ns/(10*44100.0f)); //sweep
      f0*=(1.0f+0.01f*sinf(ns*0.0015f));        //vibrato
      dp0=f0*(1/22050.0f);
      float un_f0=1.0f/f0;
      p0+=dp0;  //phase increment
      p0-=2*(p0>1);
      { //smoothing of the commands.
        float r=0.001f;
        f1+=r*(F1[F]-f1);f2+=r*(F2[F]-f2);f3+=r*(F3[F]-f3);f4+=r*(F4[F]-f4);
        a1+=r*(A1[F]-a1);a2+=r*(A2[F]-a2);a3+=r*(A3[F]-a3);a4+=r*(A4[F]-a4);
      }

      //The f0/fn coefficients stand for a -3dB/oct spectral enveloppe
      float out=
        a1*(f0/f1)*formant(p0,100*un_f0,TF)*porteuse(f1*un_f0,p0)
        +0.7f*a2*(f0/f2)*formant(p0,120*un_f0,TF)*porteuse(f2*un_f0,p0)
        +     a3*(f0/f3)*formant(p0,150*un_f0,TF)*porteuse(f3*un_f0,p0)
        +     a4*(f0/f4)*formant(p0,300*un_f0,TF)*porteuse(f4*un_f0,p0);

      // write to volatile variable to test... (use puts to verify correctness)
      out_val[0] = (int16_t)(15000.0f*out);
    }
}


r2893: *** empty log message ***

r2893: *** empty log message ***

;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name:          mysql-sql.cl
;;;; Purpose:       High-level MySQL interface using UFFI
;;;; Programmers:   Kevin M. Rosenberg based on
;;;;                Original code by Pierre R. Mai
;;;; Date Started:  Feb 2002
;;;;
;;;; $Id: mysql-sql.cl,v 1.3 2002/09/30 02:07:42 kevin Exp $
;;;;
;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
;;;;
;;;; CLSQL users are granted the rights to distribute and use this software
;;;; as governed by the terms of the Lisp Lesser GNU Public License
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************

(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))

;;;; Modified by Kevin Rosenberg, Feb 20002
;;;; -- Added support for Allegro CL and Lispworks using UFFI layer
;;;; -- Changed database-connect to use mysql-real-connect. This way,
;;;;    can avoid using double (unwind-protect)
;;;; -- Changed database-connect to have MySQL library allocate space
;;;;    for MYSQL structure. This will make the code more robust in
;;;;    the event that MySQL library changes the size of the mysql-mysql
;;;;    structure.
;;;;
;;;; Mar 2002
;;;; Added field types

(defpackage :clsql-mysql
    (:use :common-lisp :clsql-base-sys :mysql :clsql-uffi)
    (:export #:mysql-database)
    (:documentation "This is the CLSQL interface to MySQL."))

(in-package :clsql-mysql)

;;; Field conversion functions

(defun make-type-list-for-auto (num-fields res-ptr)
  (let ((new-types '())
	#+ignore (field-vec (mysql-fetch-fields res-ptr)))
    (dotimes (i num-fields)
      (declare (fixnum i))
      (let* ( (field (mysql-fetch-field-direct res-ptr i))
	     #+ignore (field (uffi:deref-array field-vec '(:array mysql-field) i))
	      (type (uffi:get-slot-value field 'mysql-field 'type)))
	(push
	 (case type
	   ((#.mysql-field-types#tiny
	     #.mysql-field-types#short
	     #.mysql-field-types#int24
	     #.mysql-field-types#long)
	    :int32)
	   (#.mysql-field-types#longlong
	    :int64)
	   ((#.mysql-field-types#double
	     #.mysql-field-types#float
	     #.mysql-field-types#decimal)
	    :double)
	   (otherwise
	    t))
	 new-types)))
    (nreverse new-types)))

(defun canonicalize-types (types num-fields res-ptr)
  (if (null types)
      nil
      (let ((auto-list (make-type-list-for-auto num-fields res-ptr)))
	(cond
	  ((listp types)
	   (canonicalize-type-list types auto-list))
	  ((eq types :auto)
	   auto-list)
	  (t
	   nil)))))

(defmethod database-initialize-database-type ((database-type (eql :mysql)))
  t)

(uffi:def-type mysql-mysql-ptr-def (* mysql-mysql))
(uffi:def-type mysql-row-def mysql-row)
(uffi:def-type mysql-mysql-res-ptr-def (* mysql-mysql-res))

(defclass mysql-database (database)
  ((mysql-ptr :accessor database-mysql-ptr :initarg :mysql-ptr
	      :type mysql-mysql-ptr-def)))

(defmethod database-type ((database mysql-database))
  :mysql)

(defmethod database-name-from-spec (connection-spec (database-type (eql :mysql)))
  (check-connection-spec connection-spec database-type (host db user password))
  (destructuring-bind (host db user password) connection-spec
    (declare (ignore password))
    (concatenate 'string host "/" db "/" user)))

(defmethod database-connect (connection-spec (database-type (eql :mysql)))
  (check-connection-spec connection-spec database-type (host db user password))
  (destructuring-bind (host db user password) connection-spec
    (let ((mysql-ptr (mysql-init (uffi:make-null-pointer 'mysql-mysql)))
	  (socket nil))
      (if (uffi:null-pointer-p mysql-ptr)
	  (error 'clsql-connect-error
		 :database-type database-type
		 :connection-spec connection-spec
		 :errno (mysql-errno mysql-ptr)
		 :error (mysql-error-string mysql-ptr))
	(uffi:with-cstrings ((host-native host)
			    (user-native user)
			    (password-native password)
			    (db-native db)
			    (socket-native socket))
	  (let ((error-occurred nil))
	    (unwind-protect
		(if (uffi:null-pointer-p
		     (mysql-real-connect
		      mysql-ptr host-native user-native password-native
		      db-native 0 socket-native 0))
		    (progn
		      (setq error-occurred t)
		      (error 'clsql-connect-error
			     :database-type database-type
			     :connection-spec connection-spec
			     :errno (mysql-errno mysql-ptr)
			     :error (mysql-error-string mysql-ptr)))
		  (make-instance 'mysql-database
		    :name (database-name-from-spec connection-spec
						   database-type)
		    :connection-spec connection-spec
		    :mysql-ptr mysql-ptr))
	      (when error-occurred (mysql-close mysql-ptr)))))))))

(defmethod database-disconnect ((database mysql-database))
  (mysql-close (database-mysql-ptr database))
  (setf (database-mysql-ptr database) nil)
  t)

(defmethod database-query (query-expression (database mysql-database)
			   types)
  (with-slots (mysql-ptr) database
    (uffi:with-cstring (query-native query-expression)
       (if (zerop (mysql-query mysql-ptr query-native))
	   (let ((res-ptr (mysql-use-result mysql-ptr)))
	     (if res-ptr
		 (let ((num-fields (mysql-num-fields res-ptr)))
		   (setq types (canonicalize-types
				      types num-fields
				      res-ptr))
		   (unwind-protect
		       (loop for row = (mysql-fetch-row res-ptr)
			      until (uffi:null-pointer-p row)
			      collect
			      (loop for i from 0 below num-fields
				    collect
				    (convert-raw-field
				     (uffi:deref-array row '(:array (* :unsigned-char)) i)
				     types i)))
		     (mysql-free-result res-ptr)))
	       (error 'clsql-sql-error
		      :database database
		      :expression query-expression
		      :errno (mysql-errno mysql-ptr)
		      :error (mysql-error-string mysql-ptr))))
	 (error 'clsql-sql-error
		:database database
		:expression query-expression
		:errno (mysql-errno mysql-ptr)
		:error (mysql-error-string mysql-ptr))))))

(defmethod database-execute-command (sql-expression (database mysql-database))
  (uffi:with-cstring (sql-native sql-expression)
    (let ((mysql-ptr (database-mysql-ptr database)))
      (declare (type mysql-mysql-ptr-def mysql-ptr))
      (if (zerop (mysql-query mysql-ptr sql-native))
	  t
	(error 'clsql-sql-error
	       :database database
	       :expression sql-expression
	       :errno (mysql-errno mysql-ptr)
	       :error (mysql-error-string mysql-ptr))))))

(defstruct mysql-result-set
  (res-ptr (uffi:make-null-pointer 'mysql-mysql-res)
	   :type mysql-mysql-res-ptr-def)
  (types nil)
  (num-fields nil :type fixnum)
  (full-set nil :type boolean))

(defmethod database-query-result-set (query-expression
				      (database mysql-database)
				      &key full-set types)
  (uffi:with-cstring (query-native query-expression)
    (let ((mysql-ptr (database-mysql-ptr database)))
     (declare (type mysql-mysql-ptr-def mysql-ptr))
      (if (zerop (mysql-query mysql-ptr query-native))
	  (let ((res-ptr (if full-set
			     (mysql-store-result mysql-ptr)
			   (mysql-use-result mysql-ptr))))
	    (declare (type mysql-mysql-res-ptr-def res-ptr))
	    (if (not (uffi:null-pointer-p res-ptr))
		(let* ((num-fields (mysql-num-fields res-ptr))
		       (result-set (make-mysql-result-set
				    :res-ptr res-ptr
				    :num-fields num-fields
				    :full-set full-set
				    :types
				    (canonicalize-types
				     types num-fields
				     res-ptr))))
		  (if full-set
		      (values result-set
			      num-fields
			      (mysql-num-rows res-ptr))
		      (values result-set
			      num-fields)))
		(error 'clsql-sql-error
		     :database database
		     :expression query-expression
		     :errno (mysql-errno mysql-ptr)
		     :error (mysql-error-string mysql-ptr))))
	(error 'clsql-sql-error
	       :database database
	       :expression query-expression
	       :errno (mysql-errno mysql-ptr)
	       :error (mysql-error-string mysql-ptr))))))

(defmethod database-dump-result-set (result-set (database mysql-database))
  (mysql-free-result (mysql-result-set-res-ptr result-set))
  t)

(defmethod database-store-next-row (result-set (database mysql-database) list)
  (let* ((res-ptr (mysql-result-set-res-ptr result-set))
	 (row (mysql-fetch-row res-ptr))
	 (types (mysql-result-set-types result-set)))
    (declare (type mysql-mysql-res-ptr-def res-ptr)
	     (type mysql-row-def row))
    (unless (uffi:null-pointer-p row)
      (loop for i from 0 below (mysql-result-set-num-fields result-set)
	    for rest on list
	    do
	    (setf (car rest)
		  (convert-raw-field
		   (uffi:deref-array row '(:array (* :unsigned-char)) i)
		   types
		   i)))
      list)))

(when (clsql-base-sys:database-type-library-loaded :mysql)
  (clsql-base-sys:initialize-database-type :database-type :mysql)
  (pushnew :mysql cl:*features*))

;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name:          mysql-sql.cl
;;;; Purpose:       High-level MySQL interface using UFFI
;;;; Programmers:   Kevin M. Rosenberg based on
;;;;                Original code by Pierre R. Mai
;;;; Date Started:  Feb 2002
;;;;
;;;; $Id: mysql-sql.cl,v 1.2 2002/09/30 01:57:32 kevin Exp $
;;;;
;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
;;;;
;;;; CLSQL users are granted the rights to distribute and use this software
;;;; as governed by the terms of the Lisp Lesser GNU Public License
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************

(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))

;;;; Modified by Kevin Rosenberg, Feb 20002
;;;; -- Added support for Allegro CL and Lispworks using UFFI layer
;;;; -- Changed database-connect to use mysql-real-connect. This way,
;;;;    can avoid using double (unwind-protect)
;;;; -- Changed database-connect to have MySQL library allocate space
;;;;    for MYSQL structure. This will make the code more robust in
;;;;    the event that MySQL library changes the size of the mysql-mysql
;;;;    structure.
;;;;
;;;; Mar 2002
;;;; Added field types

(defpackage :clsql-mysql
    (:use :common-lisp :clsql-base-sys :mysql :clsql-uffi)
    (:export #:mysql-database)
    (:documentation "This is the CLSQL interface to MySQL."))

(in-package :clsql-mysql)

;;; Field conversion functions

(defun make-type-list-for-auto (num-fields res-ptr)
  (let ((new-types '())
	#+ignore (field-vec (mysql-fetch-fields res-ptr)))
    (dotimes (i num-fields)
      (declare (fixnum i))
      (let* ( (field (mysql-fetch-field-direct res-ptr i))
	     #+ignore (field (uffi:deref-array field-vec '(* mysql-field) i))
	      (type (uffi:get-slot-value field 'mysql-field 'type)))
	(push
	 (case type
	   ((#.mysql-field-types#tiny
	     #.mysql-field-types#short
	     #.mysql-field-types#int24
	     #.mysql-field-types#long)
	    :int32)
	   (#.mysql-field-types#longlong
	    :int64)
	   ((#.mysql-field-types#double
	     #.mysql-field-types#float
	     #.mysql-field-types#decimal)
	    :double)
	   (otherwise
	    t))
	 new-types)))
    (nreverse new-types)))

(defun canonicalize-types (types num-fields res-ptr)
  (if (null types)
      nil
      (let ((auto-list (make-type-list-for-auto num-fields res-ptr)))
	(cond
	  ((listp types)
	   (canonicalize-type-list types auto-list))
	  ((eq types :auto)
	   auto-list)
	  (t
	   nil)))))

(defmethod database-initialize-database-type ((database-type (eql :mysql)))
  t)

(uffi:def-type mysql-mysql-ptr-def (* mysql-mysql))
(uffi:def-type mysql-row-def mysql-row)
(uffi:def-type mysql-mysql-res-ptr-def (* mysql-mysql-res))

(defclass mysql-database (database)
  ((mysql-ptr :accessor database-mysql-ptr :initarg :mysql-ptr
	      :type mysql-mysql-ptr-def)))

(defmethod database-type ((database mysql-database))
  :mysql)

(defmethod database-name-from-spec (connection-spec (database-type (eql :mysql)))
  (check-connection-spec connection-spec database-type (host db user password))
  (destructuring-bind (host db user password) connection-spec
    (declare (ignore password))
    (concatenate 'string host "/" db "/" user)))

(defmethod database-connect (connection-spec (database-type (eql :mysql)))
  (check-connection-spec connection-spec database-type (host db user password))
  (destructuring-bind (host db user password) connection-spec
    (let ((mysql-ptr (mysql-init (uffi:make-null-pointer 'mysql-mysql)))
	  (socket nil))
      (if (uffi:null-pointer-p mysql-ptr)
	  (error 'clsql-connect-error
		 :database-type database-type
		 :connection-spec connection-spec
		 :errno (mysql-errno mysql-ptr)
		 :error (mysql-error-string mysql-ptr))
	(uffi:with-cstrings ((host-native host)
			    (user-native user)
			    (password-native password)
			    (db-native db)
			    (socket-native socket))
	  (let ((error-occurred nil))
	    (unwind-protect
		(if (uffi:null-pointer-p
		     (mysql-real-connect
		      mysql-ptr host-native user-native password-native
		      db-native 0 socket-native 0))
		    (progn
		      (setq error-occurred t)
		      (error 'clsql-connect-error
			     :database-type database-type
			     :connection-spec connection-spec
			     :errno (mysql-errno mysql-ptr)
			     :error (mysql-error-string mysql-ptr)))
		  (make-instance 'mysql-database
		    :name (database-name-from-spec connection-spec
						   database-type)
		    :connection-spec connection-spec
		    :mysql-ptr mysql-ptr))
	      (when error-occurred (mysql-close mysql-ptr)))))))))

(defmethod database-disconnect ((database mysql-database))
  (mysql-close (database-mysql-ptr database))
  (setf (database-mysql-ptr database) nil)
  t)

(defmethod database-query (query-expression (database mysql-database)
			   types)
  (with-slots (mysql-ptr) database
    (uffi:with-cstring (query-native query-expression)
       (if (zerop (mysql-query mysql-ptr query-native))
	   (let ((res-ptr (mysql-use-result mysql-ptr)))
	     (if res-ptr
		 (let ((num-fields (mysql-num-fields res-ptr)))
		   (setq types (canonicalize-types
				      types num-fields
				      res-ptr))
		   (unwind-protect
		       (loop for row = (mysql-fetch-row res-ptr)
			      until (uffi:null-pointer-p row)
			      collect
			      (loop for i from 0 below num-fields
				    collect
				    (convert-raw-field
				     (uffi:deref-array row '(* (* :unsigned-char)) i)
				     types i)))
		     (mysql-free-result res-ptr)))
	       (error 'clsql-sql-error
		      :database database
		      :expression query-expression
		      :errno (mysql-errno mysql-ptr)
		      :error (mysql-error-string mysql-ptr))))
	 (error 'clsql-sql-error
		:database database
		:expression query-expression
		:errno (mysql-errno mysql-ptr)
		:error (mysql-error-string mysql-ptr))))))

(defmethod database-execute-command (sql-expression (database mysql-database))
  (uffi:with-cstring (sql-native sql-expression)
    (let ((mysql-ptr (database-mysql-ptr database)))
      (declare (type mysql-mysql-ptr-def mysql-ptr))
      (if (zerop (mysql-query mysql-ptr sql-native))
	  t
	(error 'clsql-sql-error
	       :database database
	       :expression sql-expression
	       :errno (mysql-errno mysql-ptr)
	       :error (mysql-error-string mysql-ptr))))))

(defstruct mysql-result-set
  (res-ptr (uffi:make-null-pointer 'mysql-mysql-res)
	   :type mysql-mysql-res-ptr-def)
  (types nil)
  (num-fields nil :type fixnum)
  (full-set nil :type boolean))

(defmethod database-query-result-set (query-expression
				      (database mysql-database)
				      &key full-set types)
  (uffi:with-cstring (query-native query-expression)
    (let ((mysql-ptr (database-mysql-ptr database)))
     (declare (type mysql-mysql-ptr-def mysql-ptr))
      (if (zerop (mysql-query mysql-ptr query-native))
	  (let ((res-ptr (if full-set
			     (mysql-store-result mysql-ptr)
			   (mysql-use-result mysql-ptr))))
	    (declare (type mysql-mysql-res-ptr-def res-ptr))
	    (if (not (uffi:null-pointer-p res-ptr))
		(let* ((num-fields (mysql-num-fields res-ptr))
		       (result-set (make-mysql-result-set
				    :res-ptr res-ptr
				    :num-fields num-fields
				    :full-set full-set
				    :types
				    (canonicalize-types
				     types num-fields
				     res-ptr))))
		  (if full-set
		      (values result-set
			      num-fields
			      (mysql-num-rows res-ptr))
		      (values result-set
			      num-fields)))
		(error 'clsql-sql-error
		     :database database
		     :expression query-expression
		     :errno (mysql-errno mysql-ptr)
		     :error (mysql-error-string mysql-ptr))))
	(error 'clsql-sql-error
	       :database database
	       :expression query-expression
	       :errno (mysql-errno mysql-ptr)
	       :error (mysql-error-string mysql-ptr))))))

(defmethod database-dump-result-set (result-set (database mysql-database))
  (mysql-free-result (mysql-result-set-res-ptr result-set))
  t)

(defmethod database-store-next-row (result-set (database mysql-database) list)
  (let* ((res-ptr (mysql-result-set-res-ptr result-set))
	 (row (mysql-fetch-row res-ptr))
	 (types (mysql-result-set-types result-set)))
    (declare (type mysql-mysql-res-ptr-def res-ptr)
	     (type mysql-row-def row))
    (unless (uffi:null-pointer-p row)
      (loop for i from 0 below (mysql-result-set-num-fields result-set)
	    for rest on list
	    do
	    (setf (car rest)
		  (convert-raw-field
		   (uffi:deref-array row '(* (* :unsigned-char)) i)
		   types
		   i)))
      list)))

(when (clsql-base-sys:database-type-library-loaded :mysql)
  (clsql-base-sys:initialize-database-type :database-type :mysql)
  (pushnew :mysql cl:*features*))